misc3d/0000755000176000001440000000000012100516564011464 5ustar ripleyusersmisc3d/MD50000644000176000001440000000305012100516564011772 0ustar ripleyusers3c1c53ad9d3bf729fd775951bf73ddb9 *DESCRIPTION 0a55142749e9a3bbd1ec9f6f2295dc21 *NAMESPACE 073be2cddf71d95c5964ba6a396ae3d1 *R/contour3d.R 3ed6767686362c789bb697958751576a *R/export.R 5f0852a47b29cf8517f47cb50c618b67 *R/image3d.R 5f751598d3f305c4c37c70069e213de9 *R/kde3d.R 2dd124db892f3187e051fe86dab3e97c *R/lighting.R b2e532d31ee92bf06c1c4773ecb3e044 *R/loadRGL.R e6765c4f2cf664694a7b0f93a0d24cea *R/parametric3d.R 25d91393cb0ed8fd3bc832cba12be53e *R/render.R 6553b403317159b8ebc0b7037dd574c6 *R/slices3d.R e0707e209b974f6bd8fee9a9801416e1 *R/triangles.R f9d4d32e8723451f399d0ebd007b55d1 *README ff1931aa94ed3dbcf867671d32ea06b6 *data/teapot.rda fcfe87523fa087e3102a01dcefe51e10 *demo/00Index bb8ce39ffc3c13f4e8e4b2c4515e2072 *demo/lighting.R 346861c529d2908f9f5936eb7dcbb22e *demo/teapot.R 6922f75ac93334278ca2076371edf406 *inst/CITATION 0c144caaee4fe1ad9568b5cc9d9e4080 *man/computeContour3d.Rd 54366f550d51bf5e56128d25aa76c885 *man/contour3d.Rd 88d5b17cc124e9ae889947abf2fa013d *man/drawScene.Rd 1158d7150f8210c86195057ab3cc613b *man/exportScene.Rd e8a0e9f1357edac205726ad2fb78db31 *man/image3d.Rd 96aa1e191ad2a23ed9d8df81405096e3 *man/kde3d.Rd 458e9e5ca1fb63a75d80ce4f09d91ea9 *man/lighting.Rd 04f1bcd835319795221f2f6129787523 *man/linesTetrahedra.Rd 0b2b7b2f5f6131fcb77510773d1d281f *man/parametric3d.Rd 94e1eb4d61ce0a7a515af2a455c8f0b0 *man/pointsTetrahedra.Rd ba521a7e8ecd7c24e243059cefcf26d4 *man/slices3d.Rd 7df1762a92f8900affaa66fcd193fbed *man/surfaceTriangles.Rd 21e31cda6dea54affef59c03c38b6f81 *man/teapot.Rd 6d4f7f29e1230d8f8ef7c746b46e84b9 *man/triangles.Rd misc3d/R/0000755000176000001440000000000012100512546011661 5ustar ripleyusersmisc3d/R/lighting.R0000644000176000001440000002136411712563512013626 0ustar ripleyusers## Lighting functions are functions of the form ## ## lighting(normals, view, light, color, color2, material) ## ## with ## ## normals a matrix of unit normal vectors as computed by triangleNormals ## view vector pointing to the viewer ## light vector pointing to the light source ## color color or vector of n colors for the sides of the triangles ## in the direction of to the normal vectors ## color2 color or vector of n colors for the sides of the triangles ## in the opposite direction of to the normal vectors. NA means ## same as 'color' ## alpha the alpha level to use ## material material parameters controlling the lighting calculation. ## ## lighting functions return a vector of n rgb colors corresponding ## to the sides of the trinagles facing the viewer and the lighting ## algorithm. ## phongLighting implements a simple version of the Phong lighting ## model (not shading--that would involve interpolation within the ## triangles). It incorporates ambient and diffuse light, which are ## the same color as the object, and specular light, which is a convex ## combination of the object color and the (white) light color. This ## is based roughly on the description in Foley and Van Dam. phongLighting <- function(normals, view, light, color, color2, alpha, material = "default") { if (length(light) == 4) { LI <- light[4] light <- light[1:3] } else LI <- 1 if (is.character(material)) material <- getMaterial(material) ambient <- material$ambient diffuse <- material$diffuse specular <- material$specular exponent <- material$exponent sr <- material$sr V <- view / sqrt(sum(view^2)) L <- light / sqrt(sum(light^2)) H <- (L + V) / sqrt(sum((L + V)^2)) sgn <- as.vector(normals %*% V) > 0 N <- ifelse(sgn,1, -1) * normals Is <- as.vector(specular * abs(N %*% H) ^ exponent) Id <- as.vector(diffuse * pmax(N %*% L,0)) rgbcol <- t(col2rgb(ifelse(sgn, color, color2)) / 255) Lrgbcol <- pmin(LI * ((ambient + Id + sr * Is) * rgbcol + (1 - sr) * Is), 1) Lrgbcol[is.na(Lrgbcol)] <- 0 rgb(Lrgbcol[,1], Lrgbcol[,2], Lrgbcol[,3], alpha) } ## A simple data base is used to register properties of named ## materials. Some initial entries are based on valuaes for similarly ## named materials in Matlab. materials.database <- new.env(hash = TRUE) registerMaterial <- function(name, ambient = 0.3, diffuse = 0.7, specular = 0.1, exponent = 10, sr = 0) { value <- list(ambient = ambient, diffuse = diffuse, specular = specular, exponent = exponent, sr = sr) assign(name, value, materials.database) } getMaterial <- function(name) { if (exists(name, materials.database, inherits = FALSE)) get(name, materials.database) else get("default", materials.database, inherits = FALSE) } registerMaterial("shiny", ambient = 0.3, diffuse = 0.6, specular = 0.9, exponent = 20, sr = 0) registerMaterial("dull", ambient = 0.3, diffuse = 0.8, specular = 0.0, exponent = 10, sr = 0) registerMaterial("metal", ambient = 0.3, diffuse = 0.3, specular = 1.0, exponent = 25, sr = 0.5) registerMaterial("default", ambient = 0.3, diffuse = 0.7, specular = 0.1, exponent = 10, sr = 0) # Alternate version of metal, about 50% brighter? registerMaterial("metal", ambient = 0.45, diffuse = 0.45, specular = 1.5, exponent = 25, sr = 0.5) # 50% would be 0.45 0.45 1.50? # Alternate version of shiny, about 20% brighter? registerMaterial("shiny", ambient = 0.36, diffuse = 0.72, specular = 1.08, exponent = 20, sr = 0) ## perspLighting is an implementation of the lighting algorithm ## described in the help page for persp(). The 'shade' parameter of ## persp is here named is computed from the material's 'exponent' ## component. To make the "default" material with expone t = 10 ## correspond to the shade = 0.75 value of the volcano example from ## the persp help page, 'exponent' is scaled by a factor of 3 / 40. perspLighting <- function(normals, view, light, color, color2, alpha, material = "default") { if (length(light) == 4) { LI <- light[4] light <- light[1:3] } else LI <- 1 if (is.character(material)) material <- getMaterial(material) exponent <- material$exponent V <- view / sqrt(sum(view^2)) L <- light / sqrt(sum(light^2)) sgn <- as.vector(normals %*% V) > 0 N <- ifelse(sgn,1, -1) * normals I <- (pmax(1 + as.vector(N %*% L), 0) / 2) ^ (exponent * (3 / 40)) Lrgbcol <- I * LI * t(col2rgb(ifelse(sgn, color, color2)) / 255) rgb(Lrgbcol[,1], Lrgbcol[,2], Lrgbcol[,3], alpha) } triangleNormalsPhong <- function(triangles) { N <- triangleNormals(triangles) ve <- t2ve(triangles) vt <- vertexTriangles(ve) VN <- vertexNormals(vt, N) interpolateVertexNormals(VN, ve$ib) } triangleNormalsPhongEX <- function(triangles, reps = 1) { N <- triangleNormals(triangles) ve <- t2ve(triangles) vt <- vertexTriangles(ve) VN <- vertexNormals(vt, N) vb <- ve$vb ib <- ve$ib n.tri <- nrow(N) while (reps > 0) { reps <- reps - 1 n.ver <- nrow(VN) mt <- triangleMidTriangles(vb, ib, VN) vb <- cbind(vb, mt$vb) VN <- rbind(VN, mt$VN) mtib <- mt$ib + n.ver ib <- matrix(rbind(ib[1,], mtib[1,],mtib[3,], mtib[1,], ib[2,],mtib[2,], mtib[2,], ib[3,], mtib[3,], mtib), nrow = 3) for (i in seq(along = triangles)) if (length(triangles[[i]]) == n.tri) triangles[[i]] <- rep(triangles[[i]], each = 4) n.tri <- 4 * n.tri } triangles$N <- interpolateVertexNormals(VN, ib) triangles$v1 <- t(vb[,ib[1,]]) triangles$v2 <- t(vb[,ib[2,]]) triangles$v3 <- t(vb[,ib[3,]]) triangles } # version that handles color interpolation # **** could lift out and triangleEdges calls triangleNormalsPhongEX <- function(triangles, reps = 1) { N <- triangleNormals(triangles) ve <- t2ve(triangles) vt <- vertexTriangles(ve) VN <- vertexNormals(vt, N) vb <- ve$vb ib <- ve$ib n.tri <- nrow(N) color <- rep(triangles$color, length = n.tri) color2 <- rep(triangles$color2, length = n.tri) col.mesh <- rep(triangles$col.mesh, length = n.tri) color2 <- ifelse(is.na(color2), color, color2) col.mesh <- ifelse(is.na(col.mesh), color, col.mesh) VC <- vertexColors(vt, color) VC2 <- vertexColors(vt, color2) VCm <- vertexColors(vt, col.mesh) while (reps > 0) { reps <- reps - 1 n.ver <- nrow(VN) edges <- triangleEdges(vb, ib) VC <- rbind(VC, (VC[edges[1,],] + VC[edges[2,],]) / 2) VC2 <- rbind(VC2, (VC2[edges[1,],] + VC2[edges[2,],]) / 2) VCm <- rbind(VCm, (VCm[edges[1,],] + VCm[edges[2,],]) / 2) mt <- triangleMidTriangles(vb, ib, VN) vb <- cbind(vb, mt$vb) VN <- rbind(VN, mt$VN) mtib <- mt$ib + n.ver ib <- matrix(rbind(ib[1,], mtib[1,],mtib[3,], mtib[1,], ib[2,],mtib[2,], mtib[2,], ib[3,], mtib[3,], mtib), nrow = 3) for (i in seq(along = triangles)) if (length(triangles[[i]]) == n.tri) triangles[[i]] <- rep(triangles[[i]], each = 4) n.tri <- 4 * n.tri } triangles$color <- interpolateVertexColors(VC, ib) triangles$color2 <- interpolateVertexColors(VC2, ib) triangles$color.mesh <- interpolateVertexColors(VCm, ib) triangles$N <- interpolateVertexNormals(VN, ib) triangles$v1 <- t(vb[,ib[1,]]) triangles$v2 <- t(vb[,ib[2,]]) triangles$v3 <- t(vb[,ib[3,]]) triangles } lightTriangles <- function(triangles, lighting, light) { view <- c(0, 0, 1) normals <- triangleNormals(triangles) smooth <- if (is.null(triangles$smooth)) 0 else triangles$smooth if (smooth == 0) normals <- triangleNormals(triangles) else if (smooth == 1) normals <- triangleNormalsPhong(triangles) else { triangles <- triangleNormalsPhongEX(triangles, reps = smooth - 1) normals <- triangles$N } n.tri <- nrow(normals) color <- rep(triangles$color, length = n.tri) color2 <- rep(triangles$color2, length = n.tri) color2 <- ifelse(is.na(color2), color, color2) alpha <- rep(triangles$alpha, length = n.tri) mat <- triangles$material triangles$col.light <- lighting(normals, view, light, color, color2, alpha, mat) triangles } lightScene <- function(scene, lighting, light) { if (is.Triangles3D(scene)) lightTriangles(scene, lighting, light) else lapply(scene, lightTriangles, lighting, light) } misc3d/R/slices3d.R0000644000176000001440000001216211712563512013526 0ustar ripleyusersif (! exists("gray.colors")) gray.colors <- function (n, start = 0.3, end = 0.9, gamma = 2.2) gray(seq(from = start^gamma, to = end^gamma, length = n)^(1/gamma)) vslice <- function(vol, which, k, tpt = 1) { if (length(dim(vol)) == 4) switch(which, x = vol[k,,,tpt], y = vol[,k,,tpt], z = vol[,,k,tpt]) else switch(which, x = vol[k,,], y = vol[,k,], z = vol[,,k]) } slices3d <- function(vol1, vol2=NULL, rlim1=c(-Inf, Inf), rlim2=NULL, col1=gray.colors(512), col2=NULL, main="Three Planes View", scale = 0.8, alpha=1, cross = TRUE, layout=c("counterclockwise", "clockwise")){ mkimg <- function(which) { switch(which, x = { i <- 1; j <- 2; k <- 3 }, y = { i <- 2; j <- 1; k <- 3 }, z = { i <- 3; j <- 1; k <- 2 }) f <- function() { opar = par(mar=c(0,0,0,0)) on.exit(par(opar)) if(!(is.array(col))) image(vslice(vol, which, bb[i],bb[4]), col=col, zlim = rlim1) else{ v <- switch(which, x = matrix(1:(d[2]*d[3]), nrow=d[2]), y = matrix(1:(d[1]*d[3]), nrow=d[1]), z = matrix(1:(d[1]*d[2]), nrow=d[1])) image(v, col=vslice(col, which, bb[i],bb[4])) } lines(rep(bb[j]/d[j],100), seq(0,1,len=100)) lines(seq(0,1,len=100), rep(bb[k]/d[k],100)) } tkrplot(tt, f, hscale = 0.8, vscale = 0.8) } mkscale <- function(i) { f <- function(...) { b <- as.numeric(tclvalue(bbv[[i]])) if (b != bb[i]) { bb[i] <<- b if (cross || i == 4) for (j in 1:3) tkrreplot(img[[j]]) else tkrreplot(img[[i]]) tkconfigure(l2, text=bb[i]) } } fr <- tkframe(tt) s <- tkscale(fr, command=f, from=1, to=d[i], resolution=1, variable=bbv[[i]], showvalue=FALSE, orient="horiz") l1 <- tklabel(fr, text = dn[i]) l2 <- tklabel(fr, textvariable = bbv[[i]]) tkgrid(l1, s, l2) fr } move <- function(which){ if(lay=="clockwise"){ switch(which, x = { i <- 1; j <- 2; k <- 3 }, y = { i <- 2; j <- 1; k <- 3 }, z = { i <- 3; j <- 1; k <- 2 }) } else{ switch(which, y = { i <- 1; j <- 2; k <- 3 }, x = { i <- 2; j <- 1; k <- 3 }, z = { i <- 3; j <- 1; k <- 2 }) } tkbind(img[[i]],"", function(x,y){ wid <- as.integer(tkwinfo("width",img[[i]])) hei <- as.integer(tkwinfo("height",img[[i]])) if(lay=="clockwise" || which=="z") bb[j] <<- as.numeric(x)/wid*d[j] else bb[i] <<- as.numeric(x)/wid*d[i] bb[k] <<- d[k] - as.numeric(y)/hei*d[k] for (j in 1:3){ tkrreplot(img[[j]]) tclvalue(bbv[[j]]) <<- as.character(round(bb[j])) } }) } overlay <- function(vol1, vol2, rlim1, rlim2, col1, col2, alpha){ choose1 <- vol1 <= rlim1[2] & vol1 >= rlim1[1] vol1 <- floor((length(col1) - .01) * (vol1 - min(vol1))/(max(vol1) - min(vol1)) + 1) vol1c <- col1[vol1] vol1c[!choose1] <- "white" choose2 <- vol2 <= rlim2[2] & vol2 >= rlim2[1] vol2 <- floor((length(col2) - .01) * (vol2 - min(vol2))/(max(vol2) - min(vol2)) + 1) vol2c <- col2[vol2] vol2c[!choose2] <- "transparent" alpha <- as.vector(ifelse(choose2, alpha, 0)) col <- t(col2rgb(vol1c)) * (1 - alpha) + t(col2rgb(vol2c)) * alpha array(rgb(col, maxColorValue=255), dim=dim(vol1)) } if (! require(tkrplot)) stop("tkrplot is required."); if(missing(rlim1)) rlim1 <- range(vol1,na.rm = TRUE) if(is.null(vol2)){ vol <- vol1 col <- col1 } else{ if(!all(dim(vol1 == vol2))) stop("two layers have to have the same dimensions") if(missing(rlim2)) rlim2 <- range(vol2,na.rm = TRUE) col <- overlay(vol1, vol2, rlim1, rlim2, col1, col2, alpha) vol <- array(0, dim=dim(vol1)) } lay <- match.arg(layout) layout <- switch(lay, counterclockwise = c(2,1,3), clockwise = c(1,2,3)) direct <- c("x", "y", "z") d <- dim(vol) #dn <- c("x", "y", "z", "t") dn <- c(direct, "t") tt <- tktoplevel() tktitle(tt) <- main bb <- c(round(d[1:3]) / 2, 1) bbv <- lapply(bb, tclVar) s <- lapply(layout, mkscale) img <- lapply(direct[layout], mkimg) tkgrid(img[[1]], img[[2]]) tkgrid(s[[1]],s[[2]]) tkgrid(img[[3]]) if (length(d) == 4 && d[4] > 1) tkgrid(s[[3]], mkscale(4)) else tkgrid(s[[3]]) lapply(direct[layout], move) environment() } misc3d/R/triangles.R0000644000176000001440000005511712100234236014002 0ustar ripleyusers## These functions work with collections of n triangles. A collection of ## triangles is a list with components v1, v2, v3 representing the ## coordinates of the three vertices; each of these components is an n by ## 3 matrix. makeTriangles <- function(v1, v2, v3, color = "red", color2 = NA, alpha = 1, fill = TRUE, col.mesh = if (fill) NA else color, smooth = 0, material = "default") { if (missing(v2) || missing(v3)) { if (missing(v2) && missing(v3)) v <- unzipTriangleMatrix(v1) else if (missing(v3)) v <- ve2t(list(vb = v1, ib = v2)) else stop("unknown form of triangle specification") v1 <- v$v1 v2 <- v$v2 v3 <- v$v3 } tris <- structure(list(v1 = v1, v2 = v2, v3 = v3, color = color, color2 = color2, fill = fill, material = material, col.mesh = col.mesh, alpha = alpha, smooth = smooth), class = "Triangles3D") colorTriangles(tris) } is.Triangles3D <- function(x) identical(class(x), "Triangles3D") updateTriangles <- function(triangles, color, color2, alpha, fill, col.mesh, material, smooth) { if (! missing(color)) triangles$color <- color if (! missing(color2)) triangles$color2 <- color2 if (! missing(fill)) triangles$fill <- fill if (! missing(col.mesh)) triangles$col.mesh <- col.mesh if (! missing(material)) triangles$material <- material if (! missing(alpha)) triangles$alpha <- alpha if (! missing(smooth)) triangles$smooth <- smooth colorTriangles(triangles) } #**** This assumes comparable scaling of dimensions #**** 5 is the largest exponent for S that will work; smaller is OK t2ve <- function (triangles) { vb <- rbind(triangles$v1, triangles$v2, triangles$v3) vbmin <- min(vb) vbmax <- max(vb) S <- 10^5 score <- function(v, d) floor(as.vector(v %*% d)) scale <- function(v) (1 - 1 / S) * (v - vbmin) / (vbmax - vbmin) d <- c(S, S^2, S^3) scores <- score(scale(vb), d) vb <- vb[! duplicated(scores),] scores <- score(scale(vb), d) ib <- rbind(match(score(scale(triangles$v1), d), scores), match(score(scale(triangles$v2), d), scores), match(score(scale(triangles$v3), d), scores)) list(vb = t(vb), ib = ib) } ve2t <- function(ve) { list (v1 = t(ve$vb[,ve$ib[1,]]), v2 = t(ve$vb[,ve$ib[2,]]), v3 = t(ve$vb[,ve$ib[3,]])) } unzipTriangleMatrix <- function(tris) { if (ncol(tris) != 3) stop("triangle matrix must have three columns.") if (nrow(tris) %% 3 != 0) stop("number of rows in triangle matrix must be divisible by 3") n <- nrow(tris) / 3 list(v1 = tris[3 * (1 : n) - 2,], v2 = tris[3 * (1 : n) - 1,], v3 = tris[3 * (1 : n),]) } zipTriangles <- function(tris) { n <- nrow(tris$v1) if (nrow(tris$v2) != n || nrow(tris$v3) != n) stop("vertex arrays must have the same number of rows") v <- matrix(0, nrow = 3 * n, ncol = 3) v[3 * (1 : n) - 2,] <- tris$v1 v[3 * (1 : n) - 1,] <- tris$v2 v[3 * (1 : n),] <- tris$v3 v } colorTriangles <- function(triangles) { if (is.function(triangles$color) || is.function(triangles$color2)) { v <- (triangles$v1 + triangles$v2 + triangles$v3) / 3 if (is.function(triangles$color)) triangles$color <- triangles$color(v[,1], v[,2], v[,3]) if (is.function(triangles$color2)) triangles$color2 <- triangles$color2(v[,1], v[,2], v[,3]) if (is.function(triangles$col.mesh)) triangles$col.mesh <- triangles$col.mesh(v[,1], v[,2], v[,3]) } triangles } colorScene <- function(scene) { if (is.Triangles3D(scene)) colorTriangles(scene) else lapply(scene, colorTriangles) } ## **** better to make new triangles including only requested components? canonicalizeAndMergeScene <- function(scene, ...) { which <- list(...) if (is.Triangles3D(scene)) { n.tri <- nrow(scene$v1) for (n in which) if (length(scene[[n]]) != n.tri) scene[[n]] <- rep(scene[[n]], length = n.tri) scene } else { scene <- lapply(scene, canonicalizeAndMergeScene, ...) x <- scene[[1]] x$v1 <- do.call(rbind, lapply(scene, function(x) x$v1)) x$v2 <- do.call(rbind, lapply(scene, function(x) x$v2)) x$v3 <- do.call(rbind, lapply(scene, function(x) x$v3)) for (n in which) x[[n]] <- do.call(c, lapply(scene, function(x) x[[n]])) x } } expandTriangleGrid <- function(x, y) { nx <- length(x) - 1 ny <- length(y) - 1 A <- c(0, 0) B <- c(1, 0) C <- c(1, 1) D <- c(0, 1) g <- expand.grid(x = 1 : nx, y = 1 : ny) even <- (g$x + g$y) %% 2 == 0 gx11 <- ifelse(even, g$x + A[1], g$x + A[1]) gy11 <- ifelse(even, g$y + A[2], g$y + A[2]) gx12 <- ifelse(even, g$x + A[1], g$x + B[1]) gy12 <- ifelse(even, g$y + A[2], g$y + B[2]) i1 <- rbind(cbind(gx11, gy11), cbind(gx12, gy12)) gx21 <- ifelse(even, g$x + B[1], g$x + B[1]) gy21 <- ifelse(even, g$y + B[2], g$y + B[2]) gx22 <- ifelse(even, g$x + C[1], g$x + C[1]) gy22 <- ifelse(even, g$y + C[2], g$y + C[2]) i2 <- rbind(cbind(gx21, gy21), cbind(gx22, gy22)) gx31 <- ifelse(even, g$x + C[1], g$x + D[1]) gy31 <- ifelse(even, g$y + C[2], g$y + D[2]) gx32 <- ifelse(even, g$x + D[1], g$x + D[1]) gy32 <- ifelse(even, g$y + D[2], g$y + D[2]) i3 <- rbind(cbind(gx31, gy31), cbind(gx32, gy32)) v1 <- cbind(x[i1[,1]], y[i1[,2]]) v2 <- cbind(x[i2[,1]], y[i2[,2]]) v3 <- cbind(x[i3[,1]], y[i3[,2]]) list(v1 = v1, v2 = v2, v3 = v3) } ## adapted from lattice ltransform3dto3d trans3dto3d <- function (x, R.mat) { if (length(x) == 0) return(x) val <- R.mat %*% rbind(t(x), 1) val[1, ] <- val[1, ]/val[4, ] val[2, ] <- val[2, ]/val[4, ] val[3, ] <- val[3, ]/val[4, ] t(val[1:3, , drop = FALSE]) } transformTriangles <- function(triangles, R) { tr <- function(v) trans3dto3d(v, R) triangles$v1 <- tr(triangles$v1) triangles$v2 <- tr(triangles$v2) triangles$v3 <- tr(triangles$v3) triangles } transformScene <- function(scene, rot.mat) { if (is.Triangles3D(scene)) transformTriangles(scene, rot.mat) else lapply(scene, transformTriangles, rot.mat) } translateTriangles <- function(triangles, x = 0, y = 0, z = 0) { M <- diag(4) M[1:3,4] <- c(x, y, z) transformTriangles(triangles, M) } scaleTriangles <- function(triangles, x = 1, y = x, z = x) { M <- diag(c(x, y, z, 1)) transformTriangles(triangles, M) } ## triangleNormals computes the normal vectors to a collection of ## triangles as the vector crossprocuct of the direction from v1 to v2 ## and the direction from v2 to v3. The result is an n by 3 matrix of ## unit representing the n unit normal vectors. triangleNormals <- function(triangles) { x <- triangles$v2 - triangles$v1 y <- triangles$v3 - triangles$v2 z <- cbind(x[,2]*y[,3] - x[,3]*y[,2], x[,3]*y[,1] - x[,1]*y[,3], x[,1]*y[,2] - x[,2]*y[,1]) z / sqrt(rowSums(z^2)) } # adapted from lattice ltransform3dMatrix trans3dMat <- function (screen, P = diag(4)) { givens4 <- function(i, j, gamma) { T <- diag(4) cgamma <- cos(gamma) sgamma <- sin(gamma) T[c(i,j),c(i,j)] <- matrix(c(cgamma, sgamma, -sgamma, cgamma), 2, 2) T } screen.names <- names(screen) for (i in seq(along = screen.names)) { if (screen.names[i] == "x") P <- givens4(2, 3, screen[[i]] * pi/180) %*% P else if (screen.names[i] == "y") P <- givens4(1, 3, -screen[[i]] * pi/180) %*% P #**** whi negative? else if (screen.names[i] == "z") P <- givens4(1, 2, screen[[i]] * pi/180) %*% P } P } makeViewTransform <- function(ranges, scale, aspect, screen, R.mat) { m <- c(mean(ranges$xlim), mean(ranges$ylim), mean(ranges$zlim)) s <- 0.5 * c(diff(ranges$xlim), diff(ranges$ylim), diff(ranges$zlim)) if (! scale) s <- rep(max(s), 3) else s <- s / c(1, aspect) A <- diag(1 / c(s, 1)) A[1:3, 4] <- -m / s trans3dMat(screen, R.mat %*% A) } trianglesRanges <- function(triangles, xlim, ylim, zlim) { v1 <- triangles$v1 v2 <- triangles$v2 v3 <- triangles$v3 if (is.null(xlim)) xlim <- range(v1[,1], v2[,1], v3[,1], na.rm = TRUE) if (is.null(ylim)) ylim <- range(v1[,2], v2[,2], v3[,2], na.rm = TRUE) if (is.null(zlim)) zlim <- range(v1[,3], v2[,3], v3[,3], na.rm = TRUE) list(xlim = xlim, ylim = ylim, zlim = zlim) } sceneRanges <- function(scene, xlim, ylim, zlim) { if (is.Triangles3D(scene)) trianglesRanges(scene, xlim, ylim, zlim) else { ranges <- lapply(scene, trianglesRanges, xlim, ylim, zlim) list(xlim = range(sapply(ranges,function(x) x$xlim)), ylim = range(sapply(ranges,function(x) x$ylim)), zlim = range(sapply(ranges,function(x) x$zlim))) } } addTrianglesPerspective <- function(triangles, distance) { pt <- function(v) { v[, 1] <- v[, 1] / (1 / distance - v[, 3]) v[, 2] <- v[, 2] / (1 / distance - v[, 3]) v } triangles$v1 <- pt(triangles$v1) triangles$v2 <- pt(triangles$v2) triangles$v3 <- pt(triangles$v3) triangles } addPerspective <- function(scene, distance) { if (is.Triangles3D(scene)) addTrianglesPerspective(scene, distance) else lapply(scene, addTrianglesPerspective, distance) } screenRange <- function(v1, v2, v3) range(v1[,1:2], v2[,1:2], v3[,1:2], na.rm = TRUE) vertexTriangles <- function(ve) { n.vert <- ncol(ve$vb) ib <- ve$ib vt <- function(i) which(ib[1,] == i | ib[2,] == i | ib[3,] == i) lapply(1 : n.vert, vt) } # faster version vertexTriangles <- function(ve) { n.vert <- ncol(ve$vb) val <- vector("list", n.vert) ib <- ve$ib for (i in 1 : ncol(ib)) { val[[ib[1,i]]] <- c(val[[ib[1,i]]], i) val[[ib[2,i]]] <- c(val[[ib[2,i]]], i) val[[ib[3,i]]] <- c(val[[ib[3,i]]], i) } val } vertexNormals <- function(vt, N) { vn <- function(tris) { z <- apply(N[tris,,drop = FALSE], 2, mean, na.rm = TRUE); z <- z / sqrt(sum(z^2)) if (any(is.na(z))) c(1,0,0) else z } t(sapply(vt, vn)) } # faster version vertexNormals <- function(vt, N) { val <- matrix(0, nrow = length(vt), ncol = 3) for (i in seq(along = vt)) { Ni <- N[vt[[i]],,drop = FALSE] Ni1 <- Ni[,1] Ni2 <- Ni[,2] Ni3 <- Ni[,3] z1 <- if (any(is.na(Ni1))) mean(Ni1, na.rm = TRUE) else sum(Ni1) / length(Ni1) z2 <- if (any(is.na(Ni2))) mean(Ni2, na.rm = TRUE) else sum(Ni2) / length(Ni2) z3 <- if (any(is.na(Ni3))) mean(Ni3, na.rm = TRUE) else sum(Ni3) / length(Ni3) z <- c(z1, z2, z3) z <- z / sqrt(sum(z^2)) val[i,] <- if (any(is.na(z))) c(1,0,0) else z } val } interpolateVertexNormals <- function(VN, ib) { z <- (VN[ib[1,],] + VN[ib[2,],] + VN[ib[3,],]) / 3 z / sqrt(rowSums(z^2)) } ## triangleVertexNormals computes the normals at the vertices by ## averaging the normals of the incident triangles. This is used by ## the rgl engine. The result form is chosen so zipTriangles can be ## used on it. triangleVertexNormals <- function(v) { N <- triangleNormals(v) ve <- t2ve(v) vt <- vertexTriangles(ve) VN <- misc3d:::vertexNormals(vt, N) list(v1 = VN[ve$ib[1,],], v2 = VN[ve$ib[2,],], v3 = VN[ve$ib[3,],]) } vertexColors <- function(vt, col) { C <- t(col2rgb(col)) val <- matrix(0, nrow = length(vt), ncol = 3) for (i in seq(along = vt)) { vti <- vt[[i]] nti <- length(vti) Ci <- C[vti,,drop = FALSE] Ci1 <- Ci[,1] Ci2 <- Ci[,2] Ci3 <- Ci[,3] val[i,] <- c(sum(Ci1), sum(Ci2), sum(Ci3)) / nti } val } interpolateVertexColors <- function(VC, ib) { TC <- (VC[ib[1,],] + VC[ib[2,],] + VC[ib[3,],]) / 3 rgb(TC[,1], TC[,2], TC[,3], maxColorValue = 255) } triangleEdges <- function(vb, ib) { edges <- cbind(ib[c(1,2),], ib[c(2,3),], ib[c(3,1),]) swap <- edges[1,] > edges[2,] edges[,swap] <- edges[2:1,swap] edges[,! duplicated(edges, MARGIN = 2)] } # faster version triangleEdges <- function(vb, ib) { n.vert <- ncol(vb) edges <- cbind(ib[c(1,2),], ib[c(2,3),], ib[c(3,1),]) swap <- edges[1,] > edges[2,] edges[,swap] <- edges[2:1,swap] score <- as.vector(c(1 + n.vert, 1) %*% edges) edges[,! duplicated(score)] } triangleMidTriangles <- function(vb, ib, VN) { n.vert <- ncol(vb) edges <- triangleEdges(vb, ib) vb <- (vb[,edges[1,]] + vb[,edges[2,]]) / 2 d <- c(1 + n.vert, 1) scores <- as.vector(d %*% edges) mpi <- function(a, b) { s <- d[1] * pmin(a, b) + d[2] * pmax(a, b) match(s, scores) } mpi1 <- mpi(ib[1,], ib[2,]) mpi2 <- mpi(ib[2,], ib[3,]) mpi3 <- mpi(ib[3,], ib[1,]) ib <- rbind(mpi1, mpi2, mpi3) z <- VN[edges[1,],] + VN[edges[2,],] z <- z / sqrt(rowSums(z^2)) list(vb = vb, ib = ib, VN = z) } ## surfaceTriangles creates a set of triangles for a grid specified by x, ## y and function falues computed with f if f is a function or taken ## from f if f is a matrix. surfaceTriangles <- function(x, y, f, color = "red", color2 = NA, alpha = 1, fill = TRUE, col.mesh = if (fill) NA else color, smooth = 0, material = "default") { if (is.function(f)) ff <- function(ix, iy) f(x[ix], y[iy]) else ff <- function(ix, iy) f[ix + length(x) * (iy - 1)] i <- expandTriangleGrid(1 : length(x), 1 : length(y)) i1 <- i$v1 i2 <- i$v2 i3 <- i$v3 v1 <- cbind(x[i1[,1]], y[i1[,2]], ff(i1[,1], i1[,2])) v2 <- cbind(x[i2[,1]], y[i2[,2]], ff(i2[,1], i2[,2])) v3 <- cbind(x[i3[,1]], y[i3[,2]], ff(i3[,1], i3[,2])) na1 <- is.na(v1[,1]) | is.na(v1[,2]) | is.na(v1[,3]) na2 <- is.na(v2[,1]) | is.na(v2[,2]) | is.na(v2[,3]) na3 <- is.na(v3[,1]) | is.na(v3[,2]) | is.na(v3[,3]) nna <- ! (na1 | na2 | na3) makeTriangles(v1[nna,], v2[nna,], v3[nna,], color = color, color2 = color2, fill = fill, smooth = smooth, material = material, col.mesh = col.mesh, alpha = alpha) } ## pointsTetrahedra computes a collection of tetrahedra centered at ## the specified point locations. This is useful, for example, for ## displaying raw data along with a density contour in a scene ## rendered with standard or grid graphics. Random orientation might ## be useful to avoid strange results at certain lighting angles. pointsTetrahedra <- function(x, y, z, size = 0.01, color = "black", ...) { n <- length(x) if (length(y) != n || length(z) != n) stop("coordinate vectors must be the same length.") ## Create a basic tetrahedron centered at the origin a <- sqrt(3) / 2 b <- 1 / (2 * sqrt(3)) h <- sqrt(2 / 3) mx <- 1 / 2 my <- (a + b) / 4 mz <- h / 4 A <- c( -mx, -my, -mz) B <- c( 1 - mx, -my, -mz) C <- c(1 / 2 - mx, a - my, -mz) D <- c(1 / 2 - mx, b - my, h - mz) v1 <- rbind(B, A, B, C) v2 <- rbind(A, B, C, A) v3 <- rbind(C, D, D, D) ## Scale the tetrahedron if (length(size) < 3) size <- rep(size, len = 3) if (n == 1) s <- diag(size) else s <- diag(size * c(diff(range(x)), diff(range(y)), diff(range(z)))) sv1 <- v1 %*% s sv2 <- v2 %*% s sv3 <- v3 %*% s ## Compute the tetrahedra for the points, taking advantage of recycling x4 <- rep(x, each = 4) y4 <- rep(y, each = 4) z4 <- rep(z, each = 4) V1 <- cbind(x4 + sv1[,1], y4 + sv1[,2], z4 + sv1[,3]) V2 <- cbind(x4 + sv2[,1], y4 + sv2[,2], z4 + sv2[,3]) V3 <- cbind(x4 + sv3[,1], y4 + sv3[,2], z4 + sv3[,3]) makeTriangles(V1, V2, V3, color = color, ...) } bresenhamLine <- function(x1, y1, z1, x2, y2, z2, delta){ if (length(delta) < 3) delta <- rep(delta, len = 3) vertex <- rep(0,3) vertex[1] <- x1 vertex[2] <- y1 vertex[3] <- z1 dx <- x2 - x1 dy <- y2 - y1 dz <- z2 - z1 x_inc <- ifelse(dx < 0, -delta, delta) l <- abs(dx)/delta[1] y_inc <- ifelse(dy < 0, -delta, delta) m <- abs(dy)/delta[2] z_inc <- ifelse(dz < 0, -delta, delta) n <- abs(dz)/delta[3] dx2 <- 2*l dy2 <- 2*m dz2 <- 2*n if ((l >= m) && (l >= n)){ err_1 <- dy2 - l err_2 <- dz2 - l Mat <- matrix(0, ncol=3, nrow=l+1) ii <- 1 for (i in 1:l){ Mat[ii,] <- c(vertex[1],vertex[2],vertex[3]) if (err_1 > 0){ vertex[2] <- vertex[2] + y_inc err_1 <- err_1 - dx2 } if (err_2 > 0){ vertex[3] <- vertex[3]+ z_inc err_2 <- err_2 - dx2 } err_1 <- err_1 + dy2 err_2 <- err_2 + dz2 vertex[1] <- vertex[1] + x_inc ii <- ii + 1 } } else if ((m >= l) && (m >= n)){ err_1 <- dx2 - m err_2 <- dz2 - m Mat <- matrix(0, ncol=3, nrow=m+1) ii <- 1 for (i in 1:m){ Mat[ii,] <- c(vertex[1],vertex[2],vertex[3]) if (err_1 > 0){ vertex[1] <- vertex[1] + x_inc err_1 <- err_1 - dy2 } if (err_2 > 0){ vertex[3] <- vertex[3] + z_inc err_2 <- err_2 - dy2 } err_1 <- err_1 + dx2 err_2 <- err_2 + dz2 vertex[2] <- vertex[2] + y_inc ii <- ii + 1 } } else{ err_1 <- dy2 - n err_2 <- dx2 - n Mat <- matrix(0, ncol=3, nrow=n+1) ii <- 1 for (i in 1:n){ Mat[ii,] <- c(vertex[1],vertex[2],vertex[3]) if (err_1 > 0){ vertex[2] <- vertex[2] + y_inc err_1 <- err_1 - dz2 } if (err_2 > 0){ vertex[1] <- vertex[1] + x_inc err_2 <- err_2 - dz2 } err_1 <- err_1 + dy2 err_2 <- err_2 + dx2 vertex[3] <- vertex[3] + z_inc ii <- ii + 1 } } Mat[ii,] <- c(vertex[1],vertex[2],vertex[3]) Mat } linesTetrahedra <- function(x, y, z, delta=c(min(x[,2]-x[,1])/10, min(y[,2]-y[,1])/10, min(z[,2]-z[,1])/10), lwd = 0.01, color = "black", ...){ n <- length(x) if (length(y) != n || length(z) != n) stop("coordinates must be of the same length.") if (is.vector(x)){ if (!is.vector(y) || !is.vector(z)) stop("coordinates have to be all vectors or matrices!") if (length(x) != 2) stop("need to specify the coordinates of starting and ending points.") else{ x <- matrix(x, nrow=1) y <- matrix(y, nrow=1) z <- matrix(z, nrow=1) } } if (is.matrix(x)){ if (!is.matrix(y) || !is.matrix(z)) stop("coordinates have to be all vectors or matrices!") if (ncol(x) != 2) stop("need to specify the coordinates of starting and ending points.") } nl <- nrow(x) xyz <- do.call(rbind, lapply(1:nl, function(i) bresenhamLine(x[i,1], y[i,1], z[i,1], x[i,2], y[i,2], z[i,2], delta))) pointsTetrahedra(xyz[,1], xyz[,2], xyz[,3], size = lwd, color = color, ...) } ## Compute for each triangle the indices of triangles that share an ## edge with it. This could be done more efficiently. triangleNeighbors <- function(tris) { ve <- misc3d:::t2ve(tris) vt <- misc3d:::vertexTriangles(ve) ib <- ve$ib n.tri <- ncol(ib) tn <- vector("list", n.tri) for (i in 1 : n.tri) { v1 <- unique(vt[[ib[1, i]]]) v2 <- unique(vt[[ib[2, i]]]) v3 <- unique(vt[[ib[3, i]]]) i12 <- intersect(v1, v2) i23 <- intersect(v2, v3) i31 <- intersect(v3, v1) u <- union(union(i12, i23), i31) tn[[i]] <- u[u != i] } tn } ## 'unique' in unique(vt[[ib[1, i]]]) seems to be unnecessary ## unless a triangle has essentially two vertices or one vertex triangleNeighbors <- function(tris) { ve <- misc3d:::t2ve(tris) vt <- misc3d:::vertexTriangles(ve) ib <- ve$ib n.tri <- ncol(ib) tn <- vector("list", n.tri) for (i in 1 : n.tri) { v1 <- vt[[ib[1, i]]] v2 <- vt[[ib[2, i]]] v3 <- vt[[ib[3, i]]] i12 <- intersect(v1, v2) i23 <- intersect(v2, v3) i31 <- intersect(v3, v1) u <- union(union(i12, i23), i31) tn[[i]] <- u[u != i] } tn } ## Dijkstra's version of Rem's algorithm for computing equivalence ## classes based on a number of vertices 1:nvert and a set of N edges ## provided as an N x 2 matrix. GetPatches <- function(nvert, edges) { f <- 1:nvert if (!(is.vector(edges)) && dim(edges)[1] != 0){ nedge <- nrow(edges) for (e in 1:nedge) { p0 <- edges[e, 1] q0 <- edges[e, 2] p1 <- f[p0] q1 <- f[q0] while (p1 != q1) { if (q1 < p1) { f[p0] <- q1 p0 <- p1 p1 <- f[p1] } else { f[q0] <- p1 q0 <- q1 q1 <- f[q1] } } } } if(is.vector(edges)){ if(edges[1] < edges[2]) f[edges[2]] <- edges[1] else f[edges[1]] <- edges[2] } for (v in 1:nvert) f[v] <- f[f[v]] split(1:nvert,f) } ## compute the edges to indicate which triangles share an edge -- this ## needs more error checking triangleNeighborEdges <- function(tn) { edges <- function(i) { v <- tn[[i]] if (length(v) > 0) cbind(i,v) else numeric(0) } do.call(rbind, lapply(1:length(tn), edges)) } ## separate triangles into disconnected chunks separateTriangles <- function(contour3dObj){ tn <- triangleNeighbors(contour3dObj) edges <- triangleNeighborEdges(tn) edges <- edges[edges[,1] < edges[,2],] p <- GetPatches(length(tn), edges) newContour3dObj <- vector("list", length(p)) for(i in 1:length(newContour3dObj)){ newContour3dObj[[i]] <- contour3dObj newContour3dObj[[i]]$v1 <- contour3dObj$v1[p[[i]],] newContour3dObj[[i]]$v2 <- contour3dObj$v2[p[[i]],] newContour3dObj[[i]]$v3 <- contour3dObj$v3[p[[i]],] } newContour3dObj } misc3d/R/export.R0000644000176000001440000002360711712563512013344 0ustar ripleyusers## Write out a triangle mesh scene as an OFF format file. This only ## outputs the geometry; color and transparency are ignored for now. ## The format supports adding three or four rgb values to each face ## line, but MeshLab seems to ignore these. saveTrianglesAsOFF <- function(scene, filename = "scene.OFF") { scene <- misc3d:::colorScene(scene) triangles <- misc3d:::canonicalizeAndMergeScene(scene, "color", "color2", "alpha", "col.mesh", "fill", "smooth") ve <- misc3d:::t2ve(triangles) f <- file(filename, open = "w") on.exit(close(f)) write("OFF", f) write(c(ncol(ve$vb), ncol(ve$ib), 3 * ncol(ve$ib)), f, 3) write(ve$vb, f, 3) write(rbind(3, ve$ib - 1), f, 4) invisible(NULL) } ## write an asymptote program for recreating a triangular mesh ## scene. Color and transparency are supported; mesh drawing, color2, ## and material properties are not currently supported. The loops ## could be vectorized but seem adequate for now. saveTrianglesAsASY <- function(scene, filename = "scene.asy") { scene <- misc3d:::colorScene(scene) triangles <- misc3d:::canonicalizeAndMergeScene(scene, "color", "color2", "alpha", "col.mesh", "fill", "smooth") ve <- misc3d:::t2ve(triangles) f <- file(filename, open = "w") on.exit(close(f)) ## write out header information and vertices cat("//generated by saveTrianglesAsASY\n\n", "import three;\n\n", "size(20cm);\n\n", "//currentprojection=perspective(250,-250,250);\n", "currentlight=Viewport;\n\n", "typedef path3[] trimesh;\n\n", "// Vertices\n", "triple[] V;\n", sep = "", file = f) nv <- ncol(ve$vb) x <- ve$vb[1,] y <- ve$vb[2,] z <- ve$vb[3,] for (i in 1 : nv) cat(sprintf("V[%d] = (%f, %f, %f);\n", i - 1, x[i], y[i], z[i]), file = f) ## write out the faces cat("\n", "guide3 triface_(int i, int j, int k) {\n", " guide3 gh; gh=V[i-1]--V[j-1]--V[k-1]--cycle;\n", " return gh;\n", "};\n\n", "// Faces\n", "trimesh F;\n", sep = "", file = f) nf <- ncol(ve$ib) v1 <- ve$ib[1,] v2 <- ve$ib[2,] v3 <- ve$ib[3,] for (i in 1 : nf) cat(sprintf("F[%d] = triface_(%d, %d, %d);\n", i - 1, v1[i], v2[i], v3[i]), file = f) ## write out color and transparency values cat("\n", "// Colors\n", "material M[];\n", sep = "", file = f) cols <- col2rgb(triangles$color) alpha <- triangles$alpha r <- cols[1,] g <- cols[2,] b <- cols[3,] if (any(alpha < 1)) for (i in 1 : nf) cat(sprintf("M[%d] = rgb(%f, %f, %f) + opacity(%f);\n", i - 1, r[i], g[i], b[i], alpha[i]), file = f) else for (i in 1 : nf) cat(sprintf("M[%d] = rgb(%f, %f, %f);\n", i - 1, r[i], g[i], b[i]), file = f) cat("\ndraw(surface(F), M);\n", file = f) invisible(NULL) } ## write out a triangle mesh scene as an IDTF format file. saveTrianglesAsIDTF <- function(scene, filename = "scene.idtf") { ns <- length(scene) f <- file(filename, open = "w") on.exit(close(f)) ## write out header information cat("FILE_FORMAT \"IDTF\"\n", "FORMAT_VERSION 100\n\n",sep="", file=f) ## write out group information cat("NODE \"GROUP\" {\n", "\tNODE_NAME \"Mesh_Group\"\n", "\tPARENT_LIST {\n", "\t\tPARENT_COUNT 1\n", "\t\tPARENT 0 {\n", "\t\t\tPARENT_NAME \"\"\n", "\t\t\tPARENT_TM {\n", "\t\t\t\t1.000000 0.000000 0.000000 0.000000\n", "\t\t\t\t0.000000 1.000000 0.000000 0.000000\n", "\t\t\t\t0.000000 0.000000 1.000000 0.000000\n", "\t\t\t\t0.000000 0.000000 0.000000 1.000000\n", "\t\t\t}\n", "\t\t}\n", "\t}\n", "}\n\n", sep="", file=f) ## write out node "model" for(i in 1:ns){ cat("NODE \"MODEL\" {\n", sep="", file=f) cat(sprintf("\tNODE_NAME \"Mesh%d\"\n", i), file=f) cat("\tPARENT_LIST {\n", "\t\tPARENT_COUNT 1\n", "\t\tPARENT 0 {\n", "\t\t\tPARENT_NAME \"Mesh_Group\"\n", "\t\t\tPARENT_TM {\n", "\t\t\t\t1.000000 0.000000 0.000000 0.000000\n", "\t\t\t\t0.000000 1.000000 0.000000 0.000000\n", "\t\t\t\t0.000000 0.000000 1.000000 0.000000\n", "\t\t\t\t0.000000 0.000000 0.000000 1.000000\n", "\t\t\t}\n", "\t\t}\n", "\t}\n", sep="", file=f) cat(sprintf("\tRESOURCE_NAME \"MyMesh%d\"\n", i), file=f) cat("}\n\n", sep="", file=f) } ## write out resource_list "model" cat("RESOURCE_LIST \"MODEL\" {\n", sep="", file=f) cat(sprintf("\tRESOURCE_COUNT %d\n", ns), file=f) for(s in 1:ns){ cat(sprintf("\tRESOURCE %d {\n", s-1), file=f) cat(sprintf("\t\tRESOURCE_NAME \"MyMesh%d\"\n", s), file=f) cat("\t\tMODEL_TYPE \"MESH\"\n", "\t\tMESH {\n", sep="", file=f) ve <- t2ve(scene[[s]]) nv <- ncol(ve$vb) x <- ve$vb[1,] y <- ve$vb[2,] z <- ve$vb[3,] nf <- ncol(ve$ib) v1 <- ve$ib[1,] v2 <- ve$ib[2,] v3 <- ve$ib[3,] N <- triangleNormals(scene[[s]]) vt <- vertexTriangles(ve) VN <- vertexNormals(vt, N) cat(sprintf("\t\t\tFACE_COUNT %d\n", nf), file=f) cat(sprintf("\t\t\tMODEL_POSITION_COUNT %d\n", nv), file=f) cat(sprintf("\t\t\tMODEL_NORMAL_COUNT %d\n", nv), file=f) cat("\t\t\tMODEL_DIFFUSE_COLOR_COUNT 0\n", "\t\t\tMODEL_SPECULAR_COLOR_COUNT 0\n", "\t\t\tMODEL_TEXTURE_COORD_COUNT 0\n", "\t\t\tMODEL_BONE_COUNT 0\n", "\t\t\tMODEL_SHADING_COUNT 1\n", "\t\t\tMODEL_SHADING_DESCRIPTION_LIST {\n", "\t\t\t\tSHADING_DESCRIPTION 0 {\n", "\t\t\t\t\tTEXTURE_LAYER_COUNT 0\n", "\t\t\t\t\tSHADER_ID 0\n", "\t\t\t\t}\n", "\t\t\t}\n", sep="", file=f) #face position cat("\t\t\tMESH_FACE_POSITION_LIST {\n", sep="", file=f) for(i in 1:nf) cat(sprintf("\t\t\t\t%d %d %d \n", v1[i]-1, v2[i]-1, v3[i]-1), file=f) cat("\t\t\t}\n", sep="", file=f) #face normal cat("\t\t\tMESH_FACE_NORMAL_LIST {\n", sep="", file=f) for(i in 1:nf) cat(sprintf("\t\t\t\t%d %d %d \n", v1[i]-1, v2[i]-1, v3[i]-1), file=f) cat("\t\t\t}\n", sep="", file=f) #shading list---not sure what that is use 0 for all cat("\t\t\tMESH_FACE_SHADING_LIST {\n", sep="", file=f) for(i in 1:nf) cat(sprintf("\t\t\t\t%d\n", 0), file=f) cat("\t\t\t}\n", sep="", file=f) #model position cat("\t\t\tMODEL_POSITION_LIST {\n", sep="", file=f) for(i in 1:nv) cat(sprintf("\t\t\t\t%f %f %f \n", x[i], y[i], z[i]), file=f) cat("\t\t\t}\n", sep="", file=f) #model normal cat("\t\t\tMODEL_NORMAL_LIST {\n", sep="", file=f) for(i in 1:nv) cat(sprintf("\t\t\t\t%f %f %f \n", VN[i,1], VN[i,2], VN[i,3]), file=f) cat("\t\t\t}\n", sep="", file=f) # cat("\t\t}\n", sep="", file=f) cat("\t}\n", sep="", file=f) } cat("}\n\n", sep="", file=f) ## write out resource_list "shader" cat("RESOURCE_LIST \"SHADER\" {\n", sep="", file=f) cat(sprintf("\tRESOURCE_COUNT %d\n", ns), file=f) for(s in 1:ns){ cat(sprintf("\tRESOURCE %d {\n", s-1), file=f) cat(sprintf("\t\tRESOURCE_NAME \"Box0%d0\"\n", s), file=f) cat(sprintf("\t\tSHADER_MATERIAL_NAME \"Box0%d0\"\n", s), file=f) cat("\t\tSHADER_ACTIVE_TEXTURE_COUNT 0\n", "\t}\n", sep="", file=f) } cat("}\n\n", sep="", file=f) ## write out resource_list "material" ## need to be more flexible cat("RESOURCE_LIST \"MATERIAL\" {\n", sep="", file=f) cat(sprintf("\tRESOURCE_COUNT %d\n", ns), file=f) for(s in 1:ns){ cat(sprintf("\tRESOURCE %d {\n", s-1), file=f) cat(sprintf("\t\tRESOURCE_NAME \"Box0%d0\"\n", s), file=f) cat("\t\tMATERIAL_AMBIENT 0.0 0.0 0.0\n", sep="", file=f) rgb <- col2rgb(scene[[s]]$color)/255 cat(sprintf("\t\tMATERIAL_DIFFUSE %f %f %f\n", rgb[1], rgb[2], rgb[3]), file=f) cat("\t\tMATERIAL_SPECULAR 0.0 0.0 0.0\n", "\t\tMATERIAL_EMISSIVE 0.0 0.0 0.0\n", "\t\tMATERIAL_REFLECTIVITY 0.000000\n", sep="", file=f) cat(sprintf("\t\tMATERIAL_OPACITY %f\n", scene[[s]]$alpha), file=f) cat("\t}\n", sep="", file=f) } cat("}\n\n", sep="", file=f) ## write out modifier "shading" for(s in 1:ns){ cat("MODIFIER \"SHADING\" {\n", sep="", file=f) cat(sprintf("\tMODIFIER_NAME \"Mesh%d\"\n", s), file=f) cat("\tPARAMETERS {\n", "\t\tSHADER_LIST_COUNT 1\n", "\t\tSHADER_LIST_LIST {\n", "\t\t\tSHADER_LIST 0 {\n", "\t\t\t\tSHADER_COUNT 1\n", "\t\t\t\tSHADER_NAME_LIST {\n", sep="", file=f) cat(sprintf("\t\t\t\t\tSHADER 0 NAME: \"Box0%d0\"\n", s), file=f) cat("\t\t\t\t}\n", "\t\t\t}\n", "\t\t}\n", "\t}\n", "}\n\n", sep="", file=f) } invisible(NULL) } exportScene <- function(scene, filename, format=c("OFF", "IDTF", "ASY")){ format <- match.arg(format) switch(format, OFF = saveTrianglesAsOFF(scene, filename = paste(filename, ".off", sep="")), IDTF = saveTrianglesAsIDTF(scene, filename = paste(filename, ".idtf", sep="")), ASY = saveTrianglesAsASY(scene, filename = paste(filename, ".asy", sep="")) ) } misc3d/R/kde3d.R0000644000176000001440000000210111712563512012777 0ustar ripleyusers## Based on kde2d in MASS. kde3d <- function (x, y, z, h, n = 20, lims = c(range(x), range(y), range(z))) { nx <- length(x) if (length(y) != nx || length(z) != nx) stop("data vectors must be the same length") if (missing(h)) h <- c(MASS::bandwidth.nrd(x), MASS::bandwidth.nrd(y), MASS::bandwidth.nrd(z)) / 6 else if (length(h) != 3) h <- rep(h, length = 3) if (length(n) != 3) n <- rep(n, length = 3) if (length(lims) == 2) lims <- rep(lims, length = 6) gx <- seq(lims[1], lims[2], length = n[1]) gy <- seq(lims[3], lims[4], length = n[2]) gz <- seq(lims[5], lims[6], length = n[3]) mx <- matrix(outer(gx, x, dnorm, h[1]), n[1], nx) my <- matrix(outer(gy, y, dnorm, h[2]), n[2], nx) mz <- matrix(outer(gz, z, dnorm, h[3]), n[3], nx) v <- array(0, n) tmy.nx <- t(my) / nx for (k in 1:n[3]) { tmy.nz.zk <- tmy.nx * mz[k,] # uses recycling to scale the rows v[,,k] <- mx %*% tmy.nz.zk } return(list(x = gx, y = gy, z = gz, d = v)) } misc3d/R/contour3d.R0000644000176000001440000007377612100512300013734 0ustar ripleyusers##**** need some more examples/test cases ##**** add standard, grid versions ##**** Redo with 21 cases, breaking face ambiguity by always cutting ##**** off high vertices. ##**** Allow processing of one slice at a time (maybe even for multiple ##**** contours?) ##**** Need more complete documentation/commenting PreProcessing <- local({ explode <- function(x) floor(((x - 1) %% 2^(1:8))/2^(0:7)) BasicRotation <- matrix(c(1,2,3,4,5,6,7,8,5,6,2,1,8,7,3,4,8,7,6,5,4,3,2,1, 4,3,7,8,1,2,6,5,2,6,7,3,1,5,8,4,6,5,8,7,2,1,4,3, 5,1,4,8,6,2,3,7,4,1,2,3,8,5,6,7,3,4,1,2,7,8,5,6, 2,3,4,1,6,7,8,5,6,7,3,2,5,8,4,1,7,8,4,3,6,5,1,2, 8,5,1,4,7,6,2,3,7,3,2,6,8,4,1,5,4,8,5,1,3,7,6,2, 3,2,6,7,4,1,5,8,2,1,5,6,3,4,8,7,1,4,8,5,2,3,7,6, 1,5,6,2,4,8,7,3,5,8,7,6,1,4,3,2,8,4,3,7,5,1,2,6, 3,7,8,4,2,6,5,1,7,6,5,8,3,2,1,4,6,2,1,5,7,3,4,8), ncol=8, byrow=TRUE) CaseRotation <- matrix(c(1,24,2,19,2,17,3,17,2,24,4,24,3,24,6,10,2,15,3,19, 4,17,6,9,3,9,6,8,6,1,9,23,2,20,3,18,4,7,6,16,5,24, 7,5,7,24,12,9,4,20,6,22,8,24,10,24,7,9,15,24,13,20, 6,20,2,21,4,6,3,16,6,4,4,16,8,23,6,14,10,23,5,21, 7,10,7,16,15,9,7,2,13,8,12,23,6,6,3,6,6,17,6,18, 9,18,7,4,13,17,15,18,6,13,7,6,12,16,13,18,6,2,11,24, 7,3,7,12,3,12,2,23,5,23,4,23,7,1,3,14,7,14,6,21, 15,23,4,15,7,19,8,19,13,23,6,11,12,17,10,19,6,23,4,12, 7,18,8,22,13,16,7,13,11,23,13,21,7,15,8,21,13,22,14,24, 8,15,13,11,7,7,8,12,4,22,3,23,7,23,6,24,12,18,6,7, 13,19,9,24,6,19,7,21,11,18,13,24,7,20,15,16,7,22,6,15, 3,22,6,3,15,17,10,22,6,12,12,24,7,11,6,5,3,15,13,10, 7,8,8,20,4,9,7,17,5,22,4,18,2,22,2,22,4,18,5,22, 7,17,4,9,8,20,7,8,13,10,3,15,6,5,7,11,12,24,6,12, 10,22,15,17,6,3,3,22,6,15,7,22,15,16,7,20,13,24,11,18, 7,21,6,19,9,24,13,19,6,7,12,18,6,24,7,23,3,23,4,22, 8,12,7,7,13,11,8,15,14,24,13,22,8,21,7,15,13,21,11,23, 7,13,13,16,8,22,7,18,4,12,6,23,10,19,12,17,6,11,13,23, 8,19,7,19,4,15,15,23,6,21,7,14,3,14,7,1,4,23,5,23, 2,23,3,12,7,12,7,3,11,24,6,2,13,18,12,16,7,6,6,13, 15,18,13,17,7,4,9,18,6,18,6,17,3,6,6,6,12,23,13,8, 7,2,15,9,7,16,7,10,5,21,10,23,6,14,8,23,4,16,6,4, 3,16,4,6,2,21,6,20,13,20,15,24,7,9,10,24,8,24,6,22, 4,20,12,9,7,24,7,5,5,24,6,16,4,7,3,18,2,20,9,23, 6,1,6,8,3,9,6,9,4,17,3,19,2,15,6,10,3,24,4,24, 2,24,3,17,2,17,2,19,1,24), ncol=2,byrow=TRUE) CaseRotationFlip <- cbind(CaseRotation, c(1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,-1,1,1,1,1,1,1,1,1,1, 1,1,-1,1,-1,-1,-1,1,1,1,1,1,1,1,-1,1,1,1,1,1,1,-1,-1,1,1, 1,1,1,1,1,-1,1,1,1,-1,1,-1,-1,-1,1,1,1,1,1,1,1,-1,1,1,1, -1,1,-1,-1,-1,1,1,1,1,1,1,1,-1,1,1,-1,-1,1,-1,-1,-1,1,1,1,1, 1,-1,1,-1,1,1,1,-1,-1,-1,-1,-1,1,1,-1,-1,1,-1,-1,-1,-1,-1,-1, -1,-1, -1,-1,-1,1,1,1,1,1,1,1,1,1,1,1,-1,1,1,-1,-1,1,1,1,1,1,-1, -1,-1,1,-1,1,-1,-1,-1,-1,-1,1,1,1,-1,1,1,-1,-1,1,-1,-1,-1,-1, -1,-1, -1,1,1,1,-1,1,-1,-1,-1,1,-1,-1,-1,-1,-1,-1,-1,1,1,1,-1,1,-1, -1,-1, 1,-1,-1,-1,-1,-1,-1,-1,1,1,-1,-1,-1,-1,-1,-1,1,-1,-1,-1,-1,-1, -1,-1,1, 1,1,-1,1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,1,-1,-1,-1,-1,-1,-1, -1,-1,-1, -1,-1,-1,-1,-1,-1)) EdgePoints <- matrix(c(1,1,2,2,2,3,3,3,4,4,4,1,5,5,6,6,6,7, 7,7,8,8,8,5,9,1,5,10,2,6,11,3,7,12,4,8,13,9,9), ncol=3, byrow=TRUE) BasicEdges <- list(c(1,4,9), c(2,4,9,10), c(1,4,5,6,9,10), c(1,4,6,7,9,11), c(1,4,10,11,12), c(2,4,6,7,9,10,11), c(1,2,5,6,7,8,9,10,11,13), c(9,10,11,12), c(1,2,7,8,9,11), c(1,2,3,4,5,6,7,8,13), c(1,2,6,7,9,12), c(1,4,5,8,9,10,11,12,13), c(1,2,3,4,5,6,7,8,9,10,11,12,13), c(1,4,7,8,10,11)) EdgeSequence1 <- list(c(1,2,3), c(1,2,4,2,3,4), list(c(1,2,5,3,4,6), c(1,2,6,2,4,6,2,3,4,2,5,3)), list(c(1,2,5,3,4,6), c(1,3,5,3,4,5,2,5,4,1,2,6,1,6,3,2,4,6)), c(1,3,2,2,3,5,3,4,5), list(c(1,2,6,2,5,6,3,4,7), c(1,2,7,2,4,7,2,5,4,3,4,5,3,5,6,1,6,3,1,3,7,7,3,4), c(1,2,7,2,4,7,2,5,4,3,4,5,3,5,6)), list(c(1,8,2,3,7,6,4,5,9), c(1,8,2,3,9,4,3,7,9,5,9,7,5,7,6), c(3,7,6,1,8,4,1,4,5,1,9,2,1,5,9), c(4,5,9,1,7,6,1,6,2,2,6,3,2,3,8), c(1,10,2,2,10,9,5,9,10,5,10,6,6,10,7,3,7,10,3,10,4,4,10,8,1, 8,10), c(1,10,2,1,10,7,6,10,7,5,10,6,5,9,10,4,9,10,3,10,4,3,8,10,2, 10,8), c(5,9,10,2,10,9,1,10,2,1,7,10,6,10,7,3,10,6,3,8,10,4,10,8,4, 5,10), c(1,7,6,1,6,9,1,9,2,5,9,6,3,8,4), c(1,7,8,3,8,7,3,7,6,3,6,5,3,5,4,4,5,9,4,9,8,2,8,9,1,8,2)), c(1,2,3,1,3,4), c(1,2,6,1,3,5,1,6,3,3,4,5), list(c(1,4,5,2,6,3,3,6,7,4,8,5), c(1,4,3,1,3,2,3,4,8,3,8,7,5,8,6,6,8,7,1,2,6,1,6,5), c(1,2,9,1,9,5,5,9,8,4,8,9,3,4,9,3,9,7,6,7,9,2,6,9), c(5,9,6,1,9,5,1,4,9,4,8,9,7,9,8,3,9,7,2,9,3,2,6,9), c(1,2,5,2,6,5,3,4,8,3,8,7)), c(1,2,3,1,3,6,1,6,5,3,4,6), list(c(1,6,2,2,6,8,3,5,4,6,7,8), c(1,5,3,1,3,6,3,6,7,3,7,4,2,4,8,2,5,4,1,5,2,4,7,8), c(1,9,2,2,9,5,3,5,9,4,9,8,3,9,4,7,8,9,6,7,9,1,9,6), c(4,9,5,1,5,9,1,9,2,2,9,8,7,8,9,6,9,7,3,6,9,3,9,4), c(1,5,2,3,8,4,3,6,8,6,7,8)), list( ##13.1 c(7,8,12,2,3,11,1,4,9,5,6,10), ##13.2 c(2, 3, 11, 7, 8, 12, 9, 5, 4, 5, 4, 6, 4, 6, 1, 6, 1, 10), c(1, 4, 9, 7, 8, 12, 10, 2, 5, 2, 5, 3, 5, 3, 6, 3, 6, 11), c(5, 6, 10, 1, 4, 9, 11, 7, 2, 7, 2, 8, 2, 8, 3, 8, 3, 12), c(5, 6, 10, 2, 3, 11, 12, 4, 7, 4, 7, 1, 7, 1, 8, 1, 8, 9), c(5, 6, 10, 7, 8, 12, 2, 11, 1, 11, 1, 9, 11, 9, 3, 9, 3, 4), c(2, 3, 11, 4, 1, 9, 5, 10, 8, 10, 8, 12, 10, 12, 6, 12, 6, 7), ##13.3 c(7, 8, 12, 13, 3, 11, 13, 11, 6, 13, 6, 5, 13, 5, 9, 13, 9, 4, 13, 4, 1, 13, 1,10,13,10, 2,13,2,3), c(2, 3, 11, 13, 6, 10, 13, 10, 1, 13, 1, 4, 13, 4, 12, 13, 12, 7, 13, 7, 8, 13, 8, 9,13,9, 5, 13,5,6), c(7, 8, 12, 13, 6, 5, 13, 5, 9, 13, 9, 4, 13, 4, 3, 13, 3, 11, 13, 11, 2, 13, 2, 1,13,1,10,13,10,6), c(2, 3, 11, 13, 4, 1, 13, 1, 10, 13, 10, 6, 13, 6, 7,13, 7, 12, 13, 12, 8, 13, 8, 5,13,5, 9,13, 9,4), c(1, 4, 9, 13, 8, 12, 13, 12, 3, 13, 3, 2, 13, 2, 10, 13, 10, 5, 13, 5, 6, 13, 6,11,13,11,7,13, 7,8), c(7, 8, 12, 13, 5, 6, 13, 6, 11, 13, 11, 3, 13, 3, 4, 13, 4, 9, 13, 9, 1, 13, 1, 2,13,2,10,13,10,5), c(1, 4, 9, 13, 3, 2, 13, 2, 10, 13, 10, 5, 13, 5, 8, 13, 8, 12,13, 12, 7, 13, 7, 6,13,6,11,13,11,3), c(5, 6, 10, 13, 1, 9, 13, 9, 8, 13, 8, 7, 13, 7, 11, 13, 11, 2,13, 2, 3, 13, 3, 12, 13, 12, 4,13, 4, 1), c(5, 6, 10, 13, 8, 7, 13, 7, 11, 13, 11, 2, 13, 2, 1, 13, 1, 9,13, 9, 4, 13, 4, 3, 13, 3, 12,13, 12, 8), c(1, 4, 9, 13, 2, 3, 13, 3, 12, 13, 12, 8, 13, 8, 5, 13, 5, 10, 13, 10, 6, 13, 6, 7, 13, 7, 11,13, 11, 2), c(5, 6, 10, 13, 7, 8, 13, 8, 9, 13, 9, 1, 13, 1, 2, 13, 2, 11, 13, 11, 3, 13, 3, 4, 13, 4, 12,13, 12, 7), c(2, 3, 11, 13, 1, 4, 13, 4, 12, 13, 12, 7, 13, 7, 6, 13, 6, 10, 13, 10, 5, 13, 5, 8, 13, 8, 9, 13, 9, 1), ##13.4 c(13, 3, 11, 13, 11, 6, 13, 6, 7, 13, 7, 12, 13, 12, 8, 13, 8, 5, 13, 5, 9, 13, 9, 4, 13, 4, 1, 13, 1, 10, 13,10, 2, 13, 2, 3), c(13, 4, 12, 13, 12, 7, 13, 7, 8, 13, 8, 9, 13, 9, 5, 13, 5, 6, 13, 6, 10, 13, 10, 1, 13, 1, 2, 13, 2, 11, 13, 11, 3, 13, 3, 4), c(13, 2, 10, 13, 10, 5, 13, 5, 6, 13, 6, 11, 13, 11, 7, 13, 7, 8, 13, 8, 12, 13,12, 3, 13, 3, 4, 13, 4, 9, 13, 9, 1, 13, 1, 2), c(13, 1, 9, 13, 9, 8, 13, 8, 5, 13, 5, 10, 13, 10, 6, 13, 6, 7, 13, 7, 11, 13,11, 2, 13, 2, 3, 13, 3, 12, 13, 12, 4, 13, 4, 1), ##13.5.1 c(7, 8, 12, 2, 1, 10, 3, 4, 11, 4, 11, 6, 4, 6, 9, 6, 9, 5), c(3, 2, 11, 8, 5, 9, 4, 1, 12, 1, 12, 7, 1, 7, 10, 7, 10, 6), c(1, 4, 9, 6, 7, 11, 2, 3, 10, 3, 10, 5, 3, 5, 12, 5, 12, 8), c(5, 6, 10, 4, 3, 12, 1, 2, 9, 2, 9, 8, 2, 8, 11, 8, 11, 7), ##13.5.2 c(1, 2, 10, 8, 5, 9, 8, 9, 4, 8, 4,12, 4,12, 3,12, 3,11, 12,11, 7,11, 7, 6, 7, 6, 8, 6, 8, 5), c(8, 5, 9, 3, 4, 12, 3, 12, 7, 3, 7,11, 7,11, 6,11, 6,10, 11,10, 2,10, 2, 1, 2, 1, 3, 1, 3, 4), c(6, 7, 11, 1, 2, 10, 1, 10, 5, 1, 5, 9, 5, 9, 8, 9, 8,12, 9,12, 4,12, 4, 3, 4, 3, 1, 3, 1, 2), c(3, 4, 12, 6, 7, 11, 6, 11, 2, 6, 2, 10,2, 10, 1,10,1, 9, 10,9, 5, 5, 9, 8, 5, 8, 6, 8, 6, 7)), c(1,4,2,1,6,4,1,5,6,3,6,4)) switch23 <- function(x){ num <- length(x) / 3 temp <- x[0: (num-1)*3 + 2] x[0: (num-1)*3 + 2] <- x[0: (num-1)*3+ 3] x[0: (num-1)*3 + 3] <- temp x } SwitchSeq <- function(ed){ if (is.list(ed)){ lapply(1:length(ed), function(x) SwitchSeq(ed[[x]])) } else switch23(ed) } EdgeSequence2 <- SwitchSeq(EdgeSequence1) getedge <- function(x){ case <- x[1] rotation <- x[2] map <- rep(0,8) for(i in 1:8){ temp <- as.integer(BasicRotation[rotation,][i]) map[temp] <- i } sapply(BasicEdges[[case-1]], function(x){ if (x!=13){ EndP1 <- EdgePoints[x,2] EndP2 <- EdgePoints[x,3] newEdge <- EdgePoints[(EdgePoints[,2]==map[EndP1] &EdgePoints[,3]==map[EndP2])| (EdgePoints[,3]==map[EndP1] &EdgePoints[,2]==map[EndP2]),][1] } else newEdge <- 13 newEdge}) } GetEdges <- local({ Edges <- apply(CaseRotationFlip[-c(1,256),], 1, getedge) Case <- cbind(seq(1:256), CaseRotationFlip[,c(1,3)]) Edges <- apply(Case[-c(1,256),], 1, function(x){ case <- x[2]-1 EdgeNum <- x[1]-1 if (x[3]==1) sapply(EdgeSequence1[[case]], function(x) Edges[[EdgeNum]][x]) else sapply(EdgeSequence2[[case]], function(x) Edges[[EdgeNum]][x]) }) Edges }) BasicFace <- list(c(0),c(0),c(1),c(7),c(0),c(2,7),c(1,2,6,7),c(0),c(0), c(5,6,7),c(0), c(1,4,7),c(1,2,3,4,5,6,7),c(0)) FacePoints <- matrix(c(seq(1,6),1,2,4,1,1,5,6,7,7,8,3,7,2,3,3,4,2, 6,5,6,8,5,4,8), ncol=5) FacePoints <- cbind(FacePoints, apply(FacePoints[,2:5],1,prod)) getface <- function(x) { case <- x[1] rotation <- x[2] map <- rep(0,8) for(i in 1:8){ temp <- as.integer(BasicRotation[rotation,][i]) map[temp] <- i } sapply(BasicFace[[case-1]], function(x){ EndP <- rep(0,4) if (x==0) newFace <- 0 else if (x==7) newFace <- 7 else { for (i in 1:4){ point <- FacePoints[x,i+1] EndP[i] <- map[point] } newFace<- FacePoints[FacePoints[,6]==prod(EndP[1:4]),][1] } newFace}) } flipface <- function(case, face){ if (face!=0){ index <- explode(case+1) if (sum(index) > 4) index <- ifelse(index==0,1,0) if (face!=7 && index[FacePoints[face,2]]==0) face <- -face else if (face==7){ tcase <- CaseRotationFlip[case+1,1]-1 if ((tcase == 4 || tcase==6 || tcase==10 ||tcase==12) && !(index[1]+index[7]==2) && !(index[3]+index[5]==2)) face <- -face else if (tcase==7 && !(index[1]+index[7]==0) && !(index[3]+index[5]==0)) face <- -face } } face } GetFaces <- local({ Faces <- apply(CaseRotationFlip[-c(1,256),], 1, getface) for (i in 1:254) for(j in 1:length(Faces[[i]])) Faces[[i]][j] <- flipface(i, Faces[[i]][j]) Faces }) ## special ## name : name of the case ## nface: how many cases need to be checked ## sev: whether face 7 need to be checked ## nedge: total number of edges in the lookuptable ## ind: the index needed to check the lookuptable ## position: the corresponding positions in the lookuptable. special <- list(name = c(3, 4, 6, 7, 10,12,13), nface= c(1, 1, 2, 4, 3, 3, 7), sev = c(0, 1, 1, 1, 1, 1, 1), nedge = c(18,24,48,177,96,96,816), ind = list(c(0,1), c(0,1), c(0,2,1,3), c(0,8,4,12,2,10,1,9,6,14,5,13,3,11,15,7), c(0,4,1,5,2,6,3,7),c(0,4,2,6,1,5,3,7), c(0,1,2,4,8,16,32,3,9,17,33,6,18,34,12,20,36,24, 40,35,25,22,44,19,41,38,28,83,105,102,92)), position=list(list(c(1:6),c(7:18)), list(c(1:6),c(7:24)), list(c(1:9),c(10:33),c(34:48),c(34:48)), list(c(1:9),c(1:9),c(10:24),c(10:24), c(25:39),c(25:39),c(40:54), c(40:54), c(55:81), c(55:81),c(82:108),c(82:108), c(109:135),c(109:135),c(136:150), c(151:177)), list(c(1:12),c(13:36),c(37:60),c(37:60), c(61:84), c(61:84),c(85:96),c(85:96)), list(c(1:12), c(13:36), c(37:60), c(37:60), c(61:84), c(61:84),c(85:96),c(85:96)), list(c(1:12), c(13:30),c(31:48),c(49:66),c(67:84), c(85:102),c(103:120), c(121:150),c(151:180),c(181:210), c(211:240),c(241:270),c(271:300), c(301:330), c(331:360),c(361:390),c(391:420), c(421:450),c(451:480), c(481:516),c(517:552),c(553:588), c(589:624), c(625:642),c(643:660),c(661:678), c(679:696), c(697:726),c(727:756),c(757:786), c(787:816)) ) ) list(Edges = GetEdges, Faces = GetFaces, EdgePoints = EdgePoints, FacePoints = FacePoints, CaseRotationFlip = CaseRotationFlip, special = special) }) Faces <- PreProcessing$Faces Edges <- PreProcessing$Edges EdgePoints <- PreProcessing$EdgePoints FacePoints <- PreProcessing$FacePoints CaseRotationFlip <- PreProcessing$CaseRotationFlip special <- PreProcessing$special fgrid <- function(fun, x, y, z) { g <- expand.grid(x = x, y = y, z = z) array(fun(g$x, g$y, g$z), c(length(x), length(y), length(z))) } faceType <- function(v, nx, ny, level, maxvol) { ## the following line replaces: v <- ifelse(v > level, 1, 0) if(level==maxvol) p <- v >= level else p <- v > level v[p] <- 1; v[! p] <- 0 v[-nx, -ny] + 2 * v[-1, -ny] + 4 * v[-1, -1] + 8 * v[-nx, -1] } levCells <- function(v, level, maxvol) { nx <- dim(v)[1] ny <- dim(v)[2] nz <- dim(v)[3] cells <- vector("list", nz - 1) types <- vector("list", nz - 1) bottomTypes <- faceType(v[,,1], nx, ny, level, maxvol) for (k in 1 : (nz - 1)) { topTypes <- faceType(v[,, k + 1], nx, ny, level, maxvol) cellTypes <- bottomTypes + 16 * topTypes contourCells <- which(cellTypes > 0 & cellTypes < 255) cells[[k]] <- contourCells + (nx - 1) * (ny - 1) * (k - 1) types[[k]] <- as.integer(cellTypes[contourCells]) bottomTypes <- topTypes } cells <- unlist(cells) i <- as.integer((cells - 1) %% (nx - 1) + 1) j <- as.integer(((cells - 1) %/% (nx - 1)) %% (ny - 1) + 1) k <- as.integer((cells - 1) %/% ((nx - 1) * (ny - 1)) + 1) t <- unlist(types) list(i = i, j = j, k = k, t = t) } CalPoint <- function(x1,x2,y1,y2,z1,z2,v1,v2){ s <- v1 / (v1-v2) x <- x1+s*(x2-x1) y <- y1+s*(y2-y1) z <- z1+s*(z2-z1) c(x,y,z) } GetPoints<-function(edge, p1, info){ ##**** need better name than info ## info is the output from GetBasic() x1 <- EdgePoints[edge,2] x2 <- EdgePoints[edge,3] c((1-floor(x1/9))*info[p1+x1-1,1]+floor(x1/9)*info[p1,1], (1-floor(x1/9))*info[p1+x2-1,1]+floor(x1/9)*info[p1+1,1], (1-floor(x1/9))*info[p1+x1-1,2]+floor(x1/9)*info[p1+1,2], (1-floor(x1/9))*info[p1+x2-1,2]+floor(x1/9)*info[p1+2,2], (1-floor(x1/9))*info[p1+x1-1,3]+floor(x1/9)*info[p1+1,3], (1-floor(x1/9))*info[p1+x2-1,3]+floor(x1/9)*info[p1+5,3], (1-floor(x1/9))*info[p1+x1-1,4]+floor(x1/9)*(0*info[p1+1,3]+1), (1-floor(x1/9))*info[p1+x2-1,4]+floor(x1/9)*(0*info[p1+1,3]-1)) } FaceNo7 <- function(faces, p1, info){ ##**** need better name than info ## info is the output from GetBasic() index <- ifelse(faces > 0, 1, -1) faces <- abs(faces) e1 <- FacePoints[faces,2] e2 <- FacePoints[faces,3] e3 <- FacePoints[faces,4] e4 <- FacePoints[faces,5] A <- info[p1+e1-1,4] B <- info[p1+e2-1,4] C <- info[p1+e3-1,4] D <- info[p1+e4-1,4] index <- index*ifelse (A*B-C*D > 0, 1, -1) ifelse(index==1, 1, 0) } Face7 <- function(faces, p1, info){ ## info is the output from GetBasic() index <- ifelse(faces > 0, 1, -1) A0 <- info[p1,4]; B0 <- info[p1+3,4] C0 <- info[p1+2,4]; D0 <- info[p1+1,4] A1 <- info[p1+4,4]; B1 <- info[p1+7,4] C1 <- info[p1+6,4]; D1 <- info[p1+5,4] a <- (A1 - A0)*(C1 - C0) - (B1 - B0)*(D1 - D0) b <- C0*(A1 - A0) + A0*(C1 - C0) - D0*(B1 - B0) - B0*(D1 - D0) c <- A0*C0 - B0*D0 tmax <- -b/(2*a) maximum <- a*tmax^2 + b*tmax + c maximum <- ifelse(maximum=="NaN",-1,maximum) cond1 <- ifelse (a < 0, 1 ,0) cond2 <- ifelse (tmax > 0, 1 ,0) cond3 <- ifelse (tmax < 1, 1, 0) cond4 <- ifelse (maximum >0, 1, 0) totalcond <- cond1 * cond2 * cond3 * cond4 index <- index*ifelse(totalcond==1, 1, -1) ifelse(index==1, 1, 0) } ## GetBasic()--- The output matrix "information" consists of 4 columns ## and #-of-cubes*8 rows. The first 3 columns tell the ## coordinate(x,y,z) of each vertex of the cube, the 4th gives the ## intensity minus the threshold, which actually makes the threshold ## eaqual to 0. This is convenient for further judgment of subcases GetBasic <- function(R, vol, level, v) { cube.1 <- cbind(v$i[R], v$j[R], v$k[R]) index <- matrix(c(0,1,1,0,0,1,1,0, 0,0,1,1,0,0,1,1, 0,0,0,0,1,1,1,1), nrow=8) ax.inc <- c(1,1,1) ver.inc <- t(apply(index,1, function(x) x*ax.inc)) cube.co <- kronecker(rep(1,nrow(cube.1)),ver.inc) + kronecker(cube.1,rep(1,8)) value <- vol[cube.co] - level information <- cbind(cube.co, value) information <- rbind(information, rep(0, 4)) p1 <- (1:length(R) - 1) * 8 + 1 cases <- v$t[R] list(information=information, p1 = p1, cases=cases) } PreRender <- function(edges, p1, type, info) { if(type==1){ if (typeof(edges)=="list"){ count <- sapply(edges, function(x) length(x)) edges <- cbind(unlist(edges), rep(p1,count)) } else{ count <- nrow(edges) edges <- cbind(as.vector(t(edges)), rep(p1,each=count)) } } else{ if (is.vector(edges)) edges <- matrix(edges, ncol = length(edges)) p1 <- edges[, 1] count <- ncol(edges) - 1 edges <- cbind(as.vector(t(edges[, -1])), rep(p1, each = count)) } ##The output of GetPoints() are coordinates of cubes. info <- GetPoints(edges[,1],edges[,2], info) info <- matrix(info,ncol=8) ##The output of CalPoint() are coordinates of triangles. info <- CalPoint(info[,1],info[,2],info[,3],info[,4], info[,5],info[,6],info[,7],info[,8]) matrix(info,ncol=3) } rescale <- function(i, x) { nx <- length(x) low <- pmin(pmax(1, floor(i)), nx - 1) x[low] + (i - low) * (x[low + 1] - x[low]) } computeContour3d <- function (vol, maxvol = max(vol), level, x = 1:dim(vol)[1], y = 1:dim(vol)[2], z = 1:dim(vol)[3], mask) { nx <- length(x) ny <- length(y) nz <- length(z) if (missing(mask)) mask <- NULL if (is.function(mask)) mask <- fgrid(mask, x, y, z) if (! all(mask)) vol[! mask] <- NA v <- levCells(vol, level, maxvol) tcase <- CaseRotationFlip[v$t+1,1]-1 R <- which(tcase %in% c(1,2,5,8,9,11,14)) if (length(R) > 0){ Basics <- GetBasic(R, vol, level, v) information <- Basics$information p1 <- Basics$p1 cases <- Basics$cases edges <- Edges[cases] triangles <- PreRender(edges, p1,type=1, information) } else triangles <- matrix(0, nrow=0,ncol=3) # emty contour, e.g. for (i in 1:length(special$name)){ R <- which(tcase == special$name[i]) if (length(R) > 0) { Basics <- GetBasic(R, vol, level, v) information <- Basics$information p1 <- Basics$p1 cases <- Basics$cases nface <- special$nface[i] nedge <- special$nedge[i] faces <- matrix(unlist(Faces[cases]), ncol = nface, byrow = TRUE) if (i==1) index <- FaceNo7(faces[, 1], p1, information) else if (i==2) index <- Face7(faces[, 1], p1, information) else{ index <- Face7(faces[, nface], p1, information)*2^(nface-1) for(j in 1:(nface-1)){ temp <- FaceNo7(faces[, j], p1, information) index <- index + temp * 2^(j-1) } } edges <- matrix(unlist(Edges[cases]), ncol = nedge, byrow = TRUE) edges <- cbind(edges, p1, index) ind <- special$ind[[i]] position <- special$position[[i]] for (j in 1:length(ind)){ ed <- edges[which(index == ind[j]), c(nedge+1, position[[j]])] if (length(ed) > 0) { prtri <- PreRender(ed,nedge+1,type=2, information) triangles <- rbind(triangles, prtri) } } } } if (! identical(x, 1 : nx)) triangles[,1] <- rescale(triangles[,1], x) if (! identical(y, 1 : ny)) triangles[,2] <- rescale(triangles[,2], y) if (! identical(z, 1 : nz)) triangles[,3] <- rescale(triangles[,3], z) triangles } contourTriangles <- function(vol, maxvol, level, x = 1:dim(vol)[1], y = 1:dim(vol)[2], z = 1:dim(vol)[3], mask = NULL, color = "white", color2 = NA, alpha = 1, fill = TRUE, col.mesh = if (fill) NA else color, material = "default", smooth = 0) { if (length(level) > 1) { val <- vector("list", length(level)) for (i in seq(along = level)) { m <- if (is.list(mask)) mask[[i]] else mask col <- if (length(color) > 1) color[[i]] else color col2 <- if (length(color2) > 1) color2[[i]] else color2 a <- if (length(alpha) > 1) alpha[[i]] else alpha fl <- if (length(fill) > 1) fill[[i]] else fill cm <- if (length(col.mesh) > 1) col.mesh[[i]] else col.mesh mat <- if (length(material) > 1) material[[1]] else material sm <- if (length(smooth) > 1) smooth[[1]] else smooth val[[i]] <- contourTriangles(vol, maxvol, level[i], x, y, z, m, col, col2, a, fl, cm, mat, sm) } val } else makeTriangles(computeContour3d(vol, maxvol, level, x, y, z, mask), color = color, color2 = color2, alpha = alpha, fill = fill, col.mesh = col.mesh, material = material, smooth = smooth) } contour3d <- function(f, level, x = 1:dim(f)[1], y = 1:dim(f)[2], z = 1:dim(f)[3], mask = NULL, color = "white", color2 = NA, alpha = 1, fill = TRUE, col.mesh = if (fill) NA else color, material = "default", smooth = 0, add = FALSE, draw = TRUE, engine = "rgl", separate=FALSE,...){ if (! all(is.finite(x), is.finite(y), is.finite(z))) stop("'x', 'y', and 'z' values must be finite and non-missing") if (is.function(f) || is.array(f) && length(dim(f)) == 3){ if (is.function(f)){ if (length(formals(f)) < 3) stop("The function must have at least 3 arguments.") vol <- fgrid(f, x, y, z) } else{ if (dim(f)[1] != length(x) || dim(f)[2] != length(y) || dim(f)[3] != length(z)) stop("dimensions of f do not match x, y, or z") vol <- f } maxvol <- max(vol) minvol <- min(vol) #cat("The range of 'f' is between ", round(minvol,2), " and ", round(maxvol,2), ".\n", sep="") con <- which(! level <= maxvol & level >= minvol) if (length(con) == length(level)) stop(paste("The 'level' has to be within the range of 'f' (between ", round(minvol, 2), " and ", round(maxvol, 2),").\n", sep="")) else if (length(con) > 0){ warning(paste("The 'level' outside the range of 'f' (between ", round(minvol, 2), " and ", round(maxvol, 2), ") has been removed. \n", sep="")) level <- level[-con] if (is.list(mask)) mask <- mask[-con] if (length(color) > 1) color <- color[-con] if (length(color2) > 1) color2 <- color2[-con] if (length(alpha) > 1) alpha <- alpha[-con] if (length(fill) > 1) fill <- fill[-con] if (length(col.mesh) > 1) col.mesh <- col.mesh[-con] if (length(material) > 1) material <- material[-con] if (length(smooth) > 1) smooth <- smooth[-con] } } else stop("vol has to be a function or a 3-dimensional array") scene <- contourTriangles(vol, maxvol, level, x, y, z, mask, color, color2, alpha, fill, col.mesh, material, smooth) if (! draw || engine == "none"){ if (! any(separate)) scene else{ if (length(level)==1){ newScene <- separateTriangles(scene) cat("Triangles are separated into ", length(newScene), " chunks.", "\n", sep="") } else{ if (length(separate) < length(level)) separate <- c(separate, rep(FALSE, length(level)-length(separate))) newScene <- NULL for (i in 1:length(level)){ if (separate[i]){ new <- separateTriangles(scene[[i]]) newScene <- c(newScene, new) cat("Triangles from level ", level[i], " are separated into ", length(new), " chunks.", "\n", sep="") } else newScene <- c(newScene, list(scene[[i]])) } } newScene } } else { scene <- colorScene(scene) if (engine == "rgl") drawScene.rgl(scene, add = add, ...) else if (engine %in% c("standard", "grid")) drawScene(scene, add = add, engine = engine, ...) else stop(paste("unknown rendering engine:", engine)) } } misc3d/R/render.R0000644000176000001440000001524111712563512013275 0ustar ripleyusersdrawScene.rgl <- function(scene, add = FALSE, ...) { loadRGL() if (! rgl.cur()) open3d() if (!add) clear3d() scene <- colorScene(scene) triangles <- canonicalizeAndMergeScene(scene, "color", "color2", "alpha", "col.mesh", "fill", "smooth") use.col2 <- ! all(is.na(triangles$color2)) if (use.col2 && any(is.na(triangles$color2))) warning(paste("mixing surfaces with and without color2 may not", "work properly in the rgl engine")) col <- rep(triangles$color, each = 3) if (use.col2) col2 <- rep(triangles$color2, each=3) alpha <- rep(triangles$alpha, each = 3) fill <- rep(triangles$fill, each = 3) col.mesh <- rep(triangles$col.mesh, each = 3) data <- zipTriangles(triangles) if (all(fill)) { front <- "filled" back <- "filled" } else if (any(fill)) ##**** handle these by splitting; OK if no alpha < 1 stop(paste("for now rgl engine cannot handle mixed fill/wire", "frame surfaces")) else { front <- "lines" back <- "lines" col <- col.mesh } oldstyle = getOption("old.misc3d.orientation") if (! is.null(oldstyle) && oldstyle) { data <- data[,c(1, 3, 2)] data[,3] <- -data[,3] } if (any(triangles$smooth > 0)) { if (any(triangles$smooth == 0)) stop(paste("for now for the rgl engine cannot handle mixed", "smooth/non-smooth surfaces")) normals <- zipTriangles(triangleVertexNormals(triangles)) } else normals <- NULL if (nrow(data) > 0) # to avoid a segfault in rgl { if (! use.col2) triangles3d(data[,1], data[,2], data[,3], col = col, alpha = alpha, normals = normals, front = front, back = back, ...) else { triangles3d(data[,1], data[,2], data[,3], col = col, alpha = alpha, normals = normals, front = front, back = "cull", ...) triangles3d(data[,1], data[,2], data[,3], col = col2, alpha = alpha, normals = normals, front = "cull", back = back, ...) } } } renderScene <- function(scene, box, fill, col.mesh, add, engine, polynum, col.bg, depth, newpage) { triangles <- canonicalizeAndMergeScene(scene, "color", "col.light", "col.mesh", "fill") v1 <- triangles$v1 v2 <- triangles$v2 v3 <- triangles$v3 n.tri <- nrow(v1) if (fill) { fill <- rep(triangles$fill, length = n.tri) col.mesh <- rep(triangles$col.mesh, length = n.tri) } else col.mesh <- rep(col.mesh, length = n.tri) col.fill <- ifelse(fill, triangles$col.light, NA) z <- (v1[,3] + v2[,3] + v3[,3]) / 3 if (depth > 0) { rgbcol <- col2rgb(col.fill, alpha = TRUE)/255 rgbcol.bg <- col2rgb(col.bg, alpha = TRUE)/255 s <- (1 + depth * z) / (1 + depth * max(z)) col.fill <- rgb(rgbcol[1,] * s + rgbcol.bg[1,] * (1 - s), rgbcol[2,] * s + rgbcol.bg[2,] * (1 - s), rgbcol[3,] * s + rgbcol.bg[3,] * (1 - s), rgbcol[4,]) } col.mesh <- ifelse(is.na(col.mesh), col.fill, col.mesh) i <- order(z, na.last = NA) if (engine == "grid") render.grid(v1[i,], v2[i,], v3[i,], box, fill[i], col.fill[i], col.mesh[i], add, polynum, newpage) else render.standard(v1[i,], v2[i,], v3[i,], box, fill[i], col.fill[i], col.mesh[i], add) } render.standard <- function(v1, v2, v3, box, fill, col.fill, col.mesh, add) { if (! add) { # rr <- screenRange(v1, v2, v3) rr <- range(box) plot(rr, rr,type="n", axes = FALSE, ann = FALSE) } xx <- as.vector(rbind(v1[,1], v2[,1], v3[,1], NA)) yy <- as.vector(rbind(v1[,2], v2[,2], v3[,2], NA)) polygon(xx, yy, col=col.fill, border=col.mesh) } render.grid <- function(v1, v2, v3, box, fill, col.fill, col.mesh, add, polynum, newpage) { if (! add) { if (newpage) grid::grid.newpage() rr <- range(box) grid::pushViewport(grid::viewport(w = 0.8, h = 0.8, xscale = rr, yscale = rr, name = "misc3dScene")) on.exit(grid::upViewport()) } xx <- as.vector(rbind(v1[,1], v2[,1], v3[,1])) yy <- as.vector(rbind(v1[,2], v2[,2], v3[,2])) n.tri <- nrow(v1) idlen <- rep(3, n.tri) start <- 1 end <- start + polynum - 1 while (start <= n.tri) { end <- min(end, n.tri) j <- start : end j3 <- (3 * start - 2) : (3 * end) gp <- grid::gpar(fill = col.fill[j], col = col.mesh[j]) grid::grid.polygon(x = xx[j3], y = yy[j3], default.units = "native", gp = gp, id.lengths = idlen[j]) start <- start + polynum end <- start + polynum } } makePerspMatrix <- function(d) { rbind(c(1, 0, 0, 0), c(0, 1, 0, 0), c(0, 0, 1, 0), c(0, 0, -1, 1 / d)) } ## drawScene is a simple function for plotting triangles. The viewer is ## looking down the positive Z axis. ## The returned value is suitable for use with trans3d. drawScene <- function(scene, light = c(0, 0, 1), screen = list(z = 40, x = -60), scale = TRUE, R.mat = diag(4), perspective = FALSE, distance = if (perspective) 0.2 else 0, fill = TRUE, xlim = NULL, ylim = NULL, zlim = NULL, aspect = c(1, 1), col.mesh = if (fill) NA else "black", polynum = 100, lighting = phongLighting, add = FALSE, engine = "standard", col.bg = "transparent", depth = 0, newpage = TRUE) { scene <- colorScene(scene) sr <- sceneRanges(scene, xlim, ylim, zlim) if (add) rot.mat <- R.mat else rot.mat <- makeViewTransform(sr, scale, aspect, screen, R.mat) scene <- transformScene(scene, rot.mat) scene <- lightScene(scene, lighting, light) if (distance > 0) { scene <- addPerspective(scene, distance) rot.mat <- makePerspMatrix(distance) %*% rot.mat } box <- as.matrix(expand.grid(sr$xlim, sr$ylim, sr$zlim)) box <- trans3dto3d(box, rot.mat) renderScene(scene, box, fill, col.mesh, add, engine, polynum, col.bg, depth, newpage) invisible(t(rot.mat)) } misc3d/R/parametric3d.R0000644000176000001440000000273511712563512014400 0ustar ripleyusersparametric3d <- function(fx, fy, fz, u, v, umin, umax, vmin, vmax, n=100, color = "white", color2 = NA, alpha = 1, fill = TRUE, col.mesh = if (fill) NA else color, smooth = 0, material = "default", add = FALSE, draw = TRUE, engine = "rgl", ...){ ##**** handle other args ##**** quads would be better if (missing(u)) u <- seq(umin, umax, len=n) if (missing(v)) v <- seq(vmin, vmax, len=n) tg <- expandTriangleGrid(u, v) f <- function(uv) cbind(fx(uv[,1], uv[,2]), fy(uv[,1], uv[,2]), fz(uv[,1], uv[,2])) v1 <- f(tg$v1) v2 <- f(tg$v2) v3 <- f(tg$v3) na1 <- is.na(v1[,1]) | is.na(v1[,2]) | is.na(v1[,3]) na2 <- is.na(v2[,1]) | is.na(v2[,2]) | is.na(v2[,3]) na3 <- is.na(v3[,1]) | is.na(v3[,2]) | is.na(v3[,3]) nna <- ! (na1 | na2 | na3) tris <- makeTriangles(v1[nna,], v2[nna,], v3[nna,], color = color, color2 = color2, smooth = smooth, material = material, alpha = alpha, fill = fill, col.mesh = col.mesh) if (! draw || engine == "none") tris else { tris <- colorScene(tris) if (engine == "rgl") drawScene.rgl(tris, add = add, ...) else if (engine %in% c("standard", "grid")) drawScene(tris, add = add, engine = engine, ...) else stop(paste("unknown rendering engine:", engine)) } } misc3d/R/image3d.R0000644000176000001440000000535012077756750013344 0ustar ripleyusersif(! exists(".bincode", envir = .BaseNamespaceEnv)) .bincode <- function(v, breaks, ...) { .C("bincode", as.double(v), length(v), as.double(breaks), length(breaks), code = integer(length(v)), as.logical(TRUE), as.logical(TRUE), nok = TRUE, NAOK = TRUE, DUP = FALSE, PACKAGE = "base")$code } image3d <- function (v, x = 1:dim(v)[1], y = 1:dim(v)[2], z = 1:dim(v)[3], vlim = quantile(v, c(.9, 1),na.rm=TRUE), col = heat.colors(256), alpha.power = 2, alpha = ((1:length(col))/ length(col))^alpha.power, breaks,sprites = TRUE, jitter = FALSE, radius = min(diff(x), diff(y), diff(z)), add = FALSE,...) { loadRGL() if (!is.array(v) && length(dim(v)) != 3) stop("'v' must be a 3D array") nx <- dim(v)[1] ny <- dim(v)[2] nz <- dim(v)[3] if (length(x) != nx || length(y) != ny || length(z) != nz) stop("dimensions of v do not match x, y, or z") if (missing(breaks)) { nc <- length(col) if (any(!is.finite(vlim)) || diff(vlim) < 0) stop("invalid v limits") if (diff(vlim) == 0) vlim <- if (vlim[1] == 0) c(-1, 1) else vlim[1] + c(-0.4, 0.4) * abs(vlim[1]) v <- (v - vlim[1])/diff(vlim) vi <- floor((nc - 1e-05) * v + 1e-07) vi[vi < 0 | vi >= nc] <- NA if (length(alpha) == 1) alpha <- rep(alpha, nc) else if (length(alpha) != nc) stop("number of colors and alpha levels must be identical") } else { if (length(breaks) != length(col) + 1) stop("must have one more break than colour") if (length(breaks) != length(alpha) + 1) stop("must have one more break than alpha levels") if (any(!is.finite(breaks))) stop("breaks must all be finite") vi <- .bincode(v, breaks, TRUE, TRUE) - 1 } if (!add) clear3d() i <- which(is.finite(vi)) xi <- x[as.integer((i - 1) %% nx + 1)] yi <- y[as.integer(((i - 1) %/% nx) %% ny + 1)] zi <- z[as.integer((i - 1) %/% (nx * ny) + 1)] vi <- vi[i] + 1 if (jitter) { ni <- length(i) xi <- xi + runif(ni, max = min(diff(x))) yi <- yi + runif(ni, max = min(diff(y))) zi <- zi + runif(ni, max = min(diff(z))) } if (sprites) { texture <- system.file("textures/particle.png", package="rgl") sprites3d(xi, yi, zi, color = col[vi], alpha = alpha[vi], lit=FALSE, radius = radius, textype="alpha", texture = texture, ...) } else points3d(xi, yi, zi, color = col[vi], alpha = alpha[vi], ...) } misc3d/R/loadRGL.R0000644000176000001440000000017011712563512013275 0ustar ripleyusersloadRGL <- function() { if (! suppressWarnings(require(rgl,quietly=TRUE))) stop("rgl is mot available") } misc3d/man/0000755000176000001440000000000012100512546012233 5ustar ripleyusersmisc3d/man/teapot.Rd0000644000176000001440000000114111712563512014022 0ustar ripleyusers\name{teapot} \docType{data} \alias{teapot} \title{Utah Teapot} \description{ The Utah teapot is a classic computer graphics example. This data set contains a representation in terms of triangles. } \usage{volcano} \format{ A list with components \code{vertices} and \code{edges}. \code{vertices} is a 3 by 1976 numeric matrix of the coordinates of the vertices. \code{edges} is a 3 by 3751 integer matrix of the indices of the triangles.} \source{ Converted from the netCDF file made available by Dave Forrest at \url{http://www.maplepark.com/~drf5n/extras/teapot.nc}. } \keyword{datasets} misc3d/man/drawScene.Rd0000644000176000001440000001336511712563512014454 0ustar ripleyusers\name{drawScene} \alias{drawScene} \alias{drawScene.rgl} \title{Rendering of Triangular Mesh Surface Data} \description{ Draw scenes consisting of one or more surfaces described by triangular mesh data structures. } \usage{ drawScene(scene, light = c(0, 0, 1), screen = list(z = 40, x = -60), scale = TRUE, R.mat = diag(4), perspective = FALSE, distance = if (perspective) 0.2 else 0, fill = TRUE, xlim = NULL, ylim = NULL, zlim = NULL, aspect = c(1, 1), col.mesh = if (fill) NA else "black", polynum = 100, lighting = phongLighting, add = FALSE, engine = "standard", col.bg = "transparent", depth = 0, newpage = TRUE) drawScene.rgl(scene, add = FALSE, ...) } \arguments{ \item{scene}{a triangle mesh object of class \code{Triangles3D} or a list of such objects representing the scene to be rendered.} \item{light}{numeric vector of length 3 or 4. The first three elements represent the direction to the light in viewer coordinates; the viewer is at \code{(0, 0, 1 / distance)} looking down along the positive z-axis. The fourth element, if present, represents light intensity; the default is 1.} \item{screen}{as for \code{\link[lattice]{panel.3dwire}}, a list giving sequence of rotations to be applied to the scene before being rendered. The initial position starts with the viewing point along the positive z-axis, and the x and y axes in the usual position. Each component of the list should be named one of "x", "y" or "z"; repetitions are allowed. The values indicate the amount of rotation about that axis in degrees.} \item{scale}{logical. Before viewing the x, y and z coordinates of the scene defining the surface are transformed to the interval [-0.5,0.5]. If \code{scale} is true the x, y and z coordinates are transformed separately. Otherwise, the coordinates are scaled so that aspect ratios are retained. Ignored if \code{draw = TRUE}} \item{R.mat}{initial rotation matrix in homogeneous coordinates, to be applied to the data before \code{screen} rotates the view further.} \item{perspective}{logical, whether to render a perspective view. Setting this to \code{FALSE} is equivalent to setting \code{distance} to 0} \item{distance}{numeric, between 0 and 1, controls amount of perspective. The distance of the viewing point from the origin (in the transformed coordinate system) is \code{1 / distance}. This is described in a little more detail in the documentation for \code{\link[lattice]{cloud}}.} \item{fill}{logical; if \code{TRUE}, drawing should use filled surfaces or wire frames as indicated by the object properties. Otherwise all objects in the scene should be rendered as wire frames.} \item{xlim,ylim,zlim}{x-, y- and z-limits. The scene is rendered so that the rectangular volume defined by these limits is visible.} \item{aspect}{vector of length 2. Gives the relative aspects of the y-size/x-size and z-size/x-size of the enclosing cube.} \item{col.mesh}{color to use for the wire frame if \code{frames} is true.} \item{polynum}{integer. Number of triangles to pass in batches to grid primitives for the "grid" engine. The default should be adequate.} \item{lighting}{a lighting function. Current options are \code{phongLighting} and \code{perspLighting}.} \item{add}{logical; if \code{TRUE}, add to current graph.} \item{engine}{character; currently "standard" or "grid".} \item{col.bg}{background dolor to use in color depth cuing.} \item{depth}{numeric, between 0 and 1. Controls the amount of color blending to \code{col.bg} for objects farther from the viewer. \code{depth} equal to zero means no depth cuing.} \item{newpage}{logical; if \code{TRUE}, and \code{add} is true, then the "grid" engine will call \code{"grid.newpage"}; otherwise the current page is used.} \item{...}{rgl material and texture properties; see documentation for \code{\link[rgl]{rgl.material}}} } \value{ \code{drawScene.rgl} returns \code{NULL}. The return value of \code{drawScene} is the viewing transformation as returned by \code{persp}. } \details{ \code{drawScene} renders a scene consisting of one or more triangle mesh objects using standard or grid graphics. Object-specific rendering features such as smoothing and material are controlled by setting in the objects. Arguments to \code{drawScene} control global factors such as viewer and light position. \code{drawScene.rgl} renders the scene in an rgl window. If \code{add=TRUE} in standard or grid graphics then coordinates are not further scaled after the transformations implied by \code{R.mat}, and \code{distance} are applied. For the grid engine drawing occurs in the current viewport. } \note{ The "rgl" engine now uses the standard rgl coordinates instead of negating \code{y} and swapping \code{y} and \code{z}. If you need to reproduce the previous behavior you can use \code{options(old.misc3d.orientation=TRUE)}. Transparency only works properly in the "rgl" engine. For standard or grid graphics on devices that support transparency using alpha levels less than 1 does work but the triangle borders show as a less transparent mesh. } \seealso{\code{\link[rgl]{rgl.material}}} \examples{ vtri <- local({ z <- 2 * volcano x <- 10 * (1:nrow(z)) y <- 10 * (1:ncol(z)) surfaceTriangles(x, y, z, color="green3") }) drawScene(vtri, scale = FALSE) drawScene(vtri, screen=list(x=40, y=-40, z=-135), scale = FALSE) drawScene(vtri, screen=list(x=40, y=-40, z=-135), scale = FALSE, perspective = TRUE) drawScene(vtri, screen=list(x=40, y=-40, z=-135), scale = FALSE, perspective = TRUE, depth = 0.4) } \keyword{hplot} misc3d/man/pointsTetrahedra.Rd0000644000176000001440000000250411712563512016052 0ustar ripleyusers\name{pointsTetrahedra} \alias{pointsTetrahedra} \title{Create a Set of Tetrahetra Centered at Data Points} \description{ Creates a scene consisting of small tetrahedra centered at specified data points in three dimensions. } \usage{ pointsTetrahedra(x, y, z, size = 0.01, color = "black", ...) } \arguments{ \item{x, y, z}{numeric vectors representing point coordinates.} \item{size}{numeric; multiple of data range to use for the size of the tetrahedron in each dimension; recycled to length 3.} \item{color}{color to use for the tetrahedra.} \item{...}{additional arguments to be passed on to \code{makeTriangles}.} } \value{ Returns a triangle mesh scene representing the tetrahedra. } \details{ This function is useful, for example, for incorporating raw data along with a density estimate surface in a scene rendered using standard or grid graphics. For \pkg{rgl} rendering \code{\link[rgl]{points3d}} is an alternative. } \seealso{ \code{\link[rgl]{points3d}}. } \examples{ with(quakes, { d <- kde3d(long, lat, -depth, n = 40) v <- contour3d(d$d, exp(-12),d$x/22, d$y/28, d$z/640, color="green", color2="gray", draw=FALSE) p <- pointsTetrahedra(long/22, lat/28, -depth/640, size = 0.005) drawScene(list(v, p)) }) } \keyword{hplot} misc3d/man/kde3d.Rd0000644000176000001440000000315011712563512013522 0ustar ripleyusers\name{kde3d} \alias{kde3d} \title{Compute a Three Dimension Kernel Density Estimate} \description{ Evaluates a three dimensional kernel density estimate using a Gaussian kernel with diagonal covariance matrix on a regular grid. } \usage{ kde3d(x, y, z, h, n = 20, lims = c(range(x), range(y), range(z))) } \arguments{ \item{x,y,z}{\code{x}, \code{y}, and \code{z} coordinates of the data.} \item{h}{vector of three bandwidths for the density estimate; recycled if length is less than three; default is based on the normal reference bandwidth (see \code{\link[MASS]{bandwidth.nrd}}).} \item{n}{numbers of grid points to use for each dimension; recycled if length is less than three.} \item{lims}{lower and upper limits on the region for which the density estimate is to be computed, provides as a vector of length 6, corresponding to low and high values of \code{x}, \code{y}, and \code{z}; recycled if only two values are supplied.} } \value{A list of four components, \code{x}, \code{y}, \code{z}, and \code{d}. \code{x}, \code{y}, and \code{z} are the coordinates of the grid points at which the density estimate has been evaluated, and \code{d} is a three dimensional array of the estimated density values. } \references{Based on the function \code{\link[MASS]{kde2d}} in package \pkg{MASS}. } \seealso{ \code{\link[MASS]{kde2d}}. } \examples{ with(quakes, { d <- kde3d(long, lat, -depth, n = 40) contour3d(d$d, exp(-12), d$x/22, d$y/28, d$z/640, color = "green", color2 = "gray", scale=FALSE, engine = "standard") }) } \keyword{dplot} misc3d/man/image3d.Rd0000644000176000001440000000503211712563512014042 0ustar ripleyusers\name{image3d} \alias{image3d} \title{Draw Points on a 3D Grid} \description{ Plots points on a three dimensional grid representing values in a three dimensional array. Assumes high values are inside and uses alpha blending to make outside points more transparent. } \usage{ image3d(v, x = 1:dim(v)[1], y = 1:dim(v)[2], z = 1:dim(v)[3], vlim = quantile(v, c(.9, 1),na.rm=TRUE), col = heat.colors(256), alpha.power = 2, alpha = ((1:length(col))/ length(col))^alpha.power, breaks, sprites = TRUE, jitter = FALSE, radius = min(diff(x), diff(y), diff(z)), add = FALSE,...) } \arguments{ \item{v}{three dimensional data array.} \item{x,y,z}{locations of grid planes at which values in \code{v} are measured.} \item{vlim}{minimum and maximum \code{v} values for which points are to be drawn.} \item{col}{vector of colors for the points as generated by \code{heat.colors} or similar functions.} \item{alpha.power}{used to calculate the alpha values. The larger the power, the smaller the alpha, the more transparent the point. Only used if \code{alpha} is not supplied.} \item{alpha}{vector of alpha values between 0 and 1. The length of the vector should be equal to the length of \code{col}.} \item{breaks}{breakpoints for the colors; must give one more breakpoint than colors.} \item{sprites}{logical; if \code{TRUE}, use \code{sprites3d} to draw the points.} \item{radius}{radius used in \code{sprites3d}.} \item{jitter}{logical; if \code{TRUE}, add a small amount of noise to the point locations.} \item{add}{logical; if \code{TRUE}, add to current \code{rgl} graph.} \item{...}{material and texture properties. See \code{rgl.material} for details.} } \references{ Daniel Adler, Oleg Nenadic and Walter Zucchini (2003) RGL: A R-library for 3D visualization with OpenGL } \seealso{ \code{\link{image}}, \code{\link[rgl]{sprites3d}}, \code{\link[rgl]{points3d}}, \code{\link{jitter}}. } \examples{ # view density of mixture of tri-variate normals nmix3 <- function(x, y, z, m, s) { 0.4 * dnorm(x, m, s) * dnorm(y, m, s) * dnorm(z, m, s) + 0.3 * dnorm(x, -m, s) * dnorm(y, -m, s) * dnorm(z, -m, s) + 0.3 * dnorm(x, m, s) * dnorm(y, -1.5 * m, s) * dnorm(z, m, s) } f <- function(x,y,z) nmix3(x,y,z,.5,.5) x<-seq(-2,2,len=50) g <- expand.grid(x = x, y = x, z = x) v <- array(f(g$x, g$y, g$z), c(length(x), length(x), length(x))) image3d(v) image3d(v, jitter = TRUE) } \keyword{hplot} misc3d/man/computeContour3d.Rd0000644000176000001440000000400212100512300015757 0ustar ripleyusers\name{computeContour3d} \alias{computeContour3d} \title{Compute Isosurface, a Three Dimension Contour} \description{ Computes a 3D contours or isosurface by the marching cubes algorithm. } \usage{ computeContour3d(vol, maxvol = max(vol), level, x = 1:dim(vol)[1], y = 1:dim(vol)[2], z = 1:dim(vol)[3], mask) } \arguments{ \item{vol}{a three dimensional array.} \item{maxvol}{maximum of the \code{vol} array.} \item{level}{The level at which to construct the contour surface.} \item{x,y,z}{locations of grid planes at which values in \code{vol} are measured.} \item{mask}{a function of 3 arguments returning a logical array, a three dimensional logical array, or \code{NULL}. If not \code{NULL}, only cells for which \code{mask} is true at all eight vertices are used in forming the contour.} } \value{ A matrix of three columns representing the triangles making up the contour surface. Each row represents a vertex and goups of three rows represent a triangle. } \details{ Uses the marching-cubes algorithm, with adjustments for dealing with face and internal ambiguities, to compute an isosurface. See references for the details. The function \code{\link[misc3d]{contour3d}} provides a higher-level interface. } \references{ Chernyaev E. (1995) Marching Cubes 33: Construction of Topologically Correct Isosurfaces \emph{Technical Report CN/95-17, CERN} Lorensen W. and Cline H. (1987) Marching Cubes: A High Resolution 3D Surface Reconstruction Algorithm \emph{Computer Graphics} \bold{vol. 21, no. 4}, 163-169 Nielson G. and Hamann B. (1992) The Asymptotic Decider: Resolving the Ambiguity in Marching Cubes \emph{Proc. IEEE Visualization} \bold{92}, 83-91 } \seealso{ \code{\link[misc3d]{contour3d}} } \examples{ x <- seq(-2,2,len=50) g <- expand.grid(x = x, y = x, z = x) v <- array(g$x^4 + g$y^4 + g$z^4, rep(length(x),3)) con <- computeContour3d(v, max(v), 1) drawScene(makeTriangles(con)) } \keyword{hplot} misc3d/man/parametric3d.Rd0000644000176000001440000001540111712563512015110 0ustar ripleyusers\name{parametric3d} \alias{parametric3d} \title{Draw a 3D Parametric Plot} \description{ Plot a two-parameter surface in three dimensions. } \usage{ parametric3d(fx, fy, fz, u, v, umin, umax, vmin, vmax, n = 100, color = "white", color2 = NA, alpha = 1, fill = TRUE, col.mesh = if (fill) NA else color, smooth = 0, material = "default", add = FALSE, draw = TRUE, engine = "rgl", ...) } \arguments{ \item{fx,fy,fz}{vectorized functions of u and v to compute the \code{x}, \code{y}, and \code{z} coordinates.} \item{u}{numeric vector of u values.} \item{v}{numeric vector of v values.} \item{umin}{numeric; the minimum value of u. Ignored if \code{u} is supplied.} \item{umax}{numeric; the maximum value of u. Ignored if \code{u} is supplied.} \item{vmin}{numeric; the minimum value of v. Ignored if \code{v} is supplied.} \item{vmax}{numeric; the maximum value of v. Ignored if \code{v} is supplied.} \item{n}{the number of equally spaced \code{u} and \code{v} values to use. Ignored if \code{u} and \code{v} are supplied.} \item{color}{color to use for the surface. Can also be a function of three arguments. This is called with three arguments, the coordinates of the midpoints of the triangles making up the surface. The function should return a vector of colors to use for the triangles.} \item{color2}{opposite face color.} \item{alpha}{alpha channel level, a number between 0 and 1..} \item{fill}{logical; if \code{TRUE}, drawing should use filled surfaces; otherwise a wire frame should be drawn.} \item{col.mesh}{color to use for the wire frame.} \item{smooth}{integer or logical specifying Phong shading level for "standard" and "grid" engines or whether or not to use shading for the "rgl" engine.} \item{material}{material specification; currently only used by "standard" and "grid" engines. Currently possible values are the character strings "dull", "shiny", "metal", and "default".} \item{add}{logical; if \code{TRUE}, add to current graph.} \item{draw}{logical; if \code{TRUE}, draw the results; otherwise, return triangle mesh structure.} \item{engine}{character; currently "rgl", "standard", "grid" or "none"; for "none" the computed triangles are returned.} \item{...}{additional rendering arguments, e.g. material and texture properties for the "rgl" engine. See documentation for \code{\link[misc3d]{drawScene}} and \code{\link[misc3d]{drawScene.rgl}}} } \value{ For the "rgl" engine the returned value is \code{NULL}. For the "standard" and "grid" engines the returned value is the viewing transformation as returned by \code{persp}. For the engine "none", or when \code{draw} is not true, the returned value is a structure representing the triangles making up the surface. } \details{ Analogous to Mathematica's \code{Param3D}. Evaluates the functions \code{fx}, \code{fy}, and \code{fz} specifying the coordinates of the surface at a grid of values for the parameters \code{u} and \code{v}. } \note{ The "rgl" engine now uses the standard rgl coordinates instead of negating \code{y} and swapping \code{y} and \code{z}. If you need to reproduce the previous behavior you can use \code{options(old.misc3d.orientation=TRUE)}. Transparency only works properly in the "rgl" engine. For standard or grid graphics on pdf or quartz devices using alpha levels less than 1 does work but the triangle borders show as a less transparent mesh. } \references{ Daniel Adler, Oleg Nenadic and Walter Zucchini (2003) RGL: A R-library for 3D visualization with OpenGL } \seealso{ \code{\link[rgl]{surface3d}}, \code{\link[rgl]{material3d}},\code{\link[scatterplot3d]{scatterplot3d}}. } \examples{ #Example 1: Ratio-of-Uniform sampling region of bivariate normal parametric3d(fx = function(u, v) u * exp(-0.5 * (u^2 + v^2 - 2 * 0.75 * u * v)/sqrt(1-.75^2))^(1/3), fy = function(u, v) v * exp(-0.5 * (u^2 + v^2 - 2 * 0.75 * u * v)/sqrt(1-.75^2))^(1/3), fz = function(u, v) exp(-0.5 * (u^2 + v^2 - 2 * 0.75 * u * v)/sqrt(1-.75^2))^(1/3), umin = -20, umax = 20, vmin = -20, vmax = 20, n = 100) parametric3d(fx = function(u, v) u * exp(-0.5 * (u^2 + v^2 - 2 * 0.75 * u * v)/sqrt(1-.75^2))^(1/3), fy = function(u, v) v * exp(-0.5 * (u^2 + v^2 - 2 * 0.75 * u * v)/sqrt(1-.75^2))^(1/3), fz = function(u, v) exp(-0.5 * (u^2 + v^2 - 2 * 0.75 * u * v)/sqrt(1-.75^2))^(1/3), u = qcauchy((1:100)/101), v = qcauchy((1:100)/101)) parametric3d(fx = function(u, v) u * exp(-0.5 * (u^2 + v^2 - 2 * 0.75 * u * v)/sqrt(1-.75^2))^(1/3), fy = function(u, v) v * exp(-0.5 * (u^2 + v^2 - 2 * 0.75 * u * v)/sqrt(1-.75^2))^(1/3), fz = function(u, v) exp(-0.5 * (u^2 + v^2 - 2 * 0.75 * u * v)/sqrt(1-.75^2))^(1/3), u = qcauchy((1:100)/101), v = qcauchy((1:100)/101), engine = "standard", scale = FALSE, screen = list(x=-90, y=20)) #Example 2: Ratio-of-Uniform sampling region of Bivariate t parametric3d(fx = function(u,v) u*(dt(u,2) * dt(v,2))^(1/3), fy = function(u,v) v*(dt(u,2) * dt(v,2))^(1/3), fz = function(u,v) (dt(u,2) * dt(v,2))^(1/3), umin = -20, umax = 20, vmin = -20, vmax = 20, n = 100, color = "green") parametric3d(fx = function(u,v) u*(dt(u,2) * dt(v,2))^(1/3), fy = function(u,v) v*(dt(u,2) * dt(v,2))^(1/3), fz = function(u,v) (dt(u,2) * dt(v,2))^(1/3), u = qcauchy((1:100)/101), v = qcauchy((1:100)/101), color = "green") parametric3d(fx = function(u,v) u*(dt(u,2) * dt(v,2))^(1/3), fy = function(u,v) v*(dt(u,2) * dt(v,2))^(1/3), fz = function(u,v) (dt(u,2) * dt(v,2))^(1/3), u = qcauchy((1:100)/101), v = qcauchy((1:100)/101), color = "green", engine = "standard", scale = FALSE) #Example 3: Surface of revolution parametric3d(fx = function(u,v) u, fy = function(u,v) sin(v)*(u^3+2*u^2-2*u+2)/5, fz = function(u,v) cos(v)*(u^3+2*u^2-2*u+2)/5, umin = -2.3, umax = 1.3, vmin = 0, vmax = 2*pi) parametric3d(fx = function(u,v) u, fy = function(u,v) sin(v)*(u^3+2*u^2-2*u+2)/5, fz = function(u,v) cos(v)*(u^3+2*u^2-2*u+2)/5, umin = -2.3, umax = 1.3, vmin = 0, vmax = 2*pi, engine = "standard", scale = FALSE, color = "red", color2 = "blue", material = "shiny") } \keyword{hplot} misc3d/man/linesTetrahedra.Rd0000644000176000001440000000350512100512222015632 0ustar ripleyusers\name{linesTetrahedra} \alias{linesTetrahedra} \title{Create a Set of Lines with Tetrahetra Centered at Points along the Lines} \description{ Creates a scene consisting of lines made up of small tetrahedra centered at points along them. } \usage{ linesTetrahedra(x, y, z, delta=c(min(x[,2]-x[,1])/10, min(y[,2]-y[,1])/10, min(z[,2]-z[,1])/10), lwd = 0.01, color = "black", ...) } \arguments{ \item{x, y, z}{numeric vectors of length two or matrices with two columns representing coordinates of starting and ending points of line(s).} \item{delta}{numeric; increase in each dimension used to locate points along the lines; recycled to length 3.} \item{lwd}{numeric; used for the size of the tetrahedron in each dimension; recycled to length 3.} \item{color}{color to use for the tetrahedra.} \item{...}{additional arguments to be passed on to \code{makeTriangles}.} } \value{ Returns a triangle mesh scene representing the lines. } \details{ The function uses the Bresenham's line algorithm to locate points along lines and then creates a triangle mesh scene representing tetrahedra centered at those points. } \seealso{ \code{\link[rgl]{lines3d}}. } \examples{ p <- pointsTetrahedra(x=c(100,100, 257, 257), y=c(100,100, 257, 257), z=c(100,257, 257, 100), size=1) l <- linesTetrahedra(x=matrix(c(100,257, 100,257), nrow=2, byrow=TRUE), y=matrix(c(100,257, 100,257), nrow=2, byrow=TRUE), z=matrix(c(100,257, 257,100), nrow=2, byrow=TRUE), lwd=0.4, col="red") drawScene.rgl(list(p, l)) } \keyword{hplot} misc3d/man/slices3d.Rd0000644000176000001440000000630611712563512014247 0ustar ripleyusers\name{slices3d} \alias{slices3d} \title{Interactive Image Slices of 3D or 4D Volume Data} \description{ Uses \pkg{tkrplot} to create an interactive slice view of three or four dimensional volume data. } \usage{ slices3d(vol1, vol2=NULL, rlim1, rlim2, col1, col2, main, scale = 0.8, alpha=1, cross = TRUE, layout=c("counterclockwise", "clockwise")) } \arguments{ \item{vol1}{a three or four dimensional real array. If two images are overlaid, then this is the one at bottom.} \item{vol2}{a three or four dimensional real array. If two images are overlaid, then this is the one on top. The default value is \code{NULL}, when only \code{vol1} is drawn.} \item{rlim1}{the minimum and maximum \code{vol1} values for which colors should be plotted, defaulting to the range of the values of \code{vol1}.} \item{rlim2}{the minimum and maximum \code{vol2} values for which colors should be plotted, defaulting to the range of the values of \code{vol2}, if two images are overlaid.} \item{col1}{a list of colors for \code{vol1}.} \item{col2}{a list of colors for \code{vol2}.} \item{main}{a character vector; main title for the plot.} \item{scale}{real value for scaling embedded plot size.} \item{alpha}{real value for transparency level, if two images are overlaid. The default value is 1.} \item{cross}{logical; if \code{TRUE}, show cross hairs of current slices.} \item{layout}{a character string specifying the layout. It must be either "counterclockwise" or "clockwise", and may be abbreviated. The default is "counterclockwise". Images corresponding to the x-y planes are always displayed in the third quadrant. If \code{layout} is counterclockwise, then the first quadrant shows images from the y-z planes and the second quadrant the x-z planes. Otherwise, the images in the first and the second quadrant are switched. The fourth quadrant is left for the slider used to select the value of the fourth index (if any) of input array(s).} } \details{ Shows slices of 3D array along the axes as produced by \code{image}, along with sliders for controlling which slices are shown. For 4D data an additional slider selects the value of the fourth index. Two images can be overlaid. This is useful for viewing medical imaging data (e.g. PET scans and fMRI data). } \examples{ #Example 1: View of a mixture of three tri-variate normal densities nmix3 <- function(x, y, z, m, s) { 0.4 * dnorm(x, m, s) * dnorm(y, m, s) * dnorm(z, m, s) + 0.3 * dnorm(x, -m, s) * dnorm(y, -m, s) * dnorm(z, -m, s) + 0.3 * dnorm(x, m, s) * dnorm(y, -1.5 * m, s) * dnorm(z, m, s) } x<-seq(-2, 2, len=40) g<-expand.grid(x = x, y = x, z = x) v<-array(nmix3(g$x,g$y,g$z, .5,.5), c(40,40,40)) slices3d(vol1=v, main="View of a mixture of three tri-variate normals", col1=heat.colors(256)) \dontrun{ #Example 2: Put a z-map from fMRI data on top of a structure # image. The threshold value of the z-map is 2. library(AnalyzeFMRI) temp<-f.read.analyze.volume("standard.img") z<-f.read.analyze.volume("z-map.img") slices3d(vol1=temp, vol2=z[,,,1], rlim2=c(2,Inf),col2=heat.colors(20), main="Regions above threshold values.") } } \keyword{hplot} misc3d/man/lighting.Rd0000644000176000001440000000254211712563512014341 0ustar ripleyusers\name{lighting} \alias{perspLighting} \alias{phongLighting} \title{Lighting Functions} \description{ Functions to compute colors modified for lighting effects. } \usage{ phongLighting(normals, view, light, color, color2, alpha, material = "default") perspLighting(normals, view, light, color, color2, alpha, material = "default") } \arguments{ \item{normals}{numeric matrix with three columns representing surface normal vectors.} \item{view}{numeric vector of length 3 representing the direction to the viewer.} \item{light}{numeric vector of length 3 or 4. The first three elements represent the direction to the light. The fourth element, if present, represents light intensity; the default is 1.} \item{color}{colors to use for faces in the direction of the normal vectors.} \item{color2}{opposite face color.} \item{alpha}{alpha channel level, a number between 0 and 1.} \item{material}{material specification. Currently possible values are the character strings "dull", "shiny", "metal", and "default".} } \value{ Vector of color specifications. } \details{ \code{phongLighting} uses the Phong lighting model to compute colors modified for view direction, light direction, and material properties. \code{perspLighting} implements approximately the same lighting model as the \code{persp} function. } \keyword{hplot} misc3d/man/exportScene.Rd0000644000176000001440000000323111712563512015027 0ustar ripleyusers\name{exportScene} \alias{exportScene} \title{Writing Out Triangular Mesh Scenes} \description{ Writing out scenes consisting of one or more surfaces represented by triangular mesh data structures to textual files. } \usage{ exportScene(scene, filename, format=c("OFF", "IDTF", "ASY")) } \arguments{ \item{scene}{a triangle mesh object of class \code{Triangles3D} or a list of such objects representing the scene to be exported.} \item{filename}{the name of the exported textual file.} \item{format}{the format of the exported textual file. It must be one of "OFF", "IDTF", or "ASY" and can be abbreviated. The default is "OFF".} } \value{ Textual files representing triangular mesh scenes. } \details{ \code{exportScene} writes out scenes to textual files, which can be used for other purposes, for example the generation of U3d and PRC files for interactive 3D visualization in a PDF. } \examples{ nmix3 <- function(x, y, z, m, s) { 0.4 * dnorm(x, m, s) * dnorm(y, m, s) * dnorm(z, m, s) + 0.3 * dnorm(x, -m, s) * dnorm(y, -m, s) * dnorm(z, -m, s) + 0.3 * dnorm(x, m, s) * dnorm(y, -1.5 * m, s) * dnorm(z, m, s) } f <- function(x,y,z) nmix3(x,y,z,.5,.5) gs1 <- function(n = 40, k = 5, cmap = heat.colors, ...) { th <- seq(0.05, 0.2, len = k) col <- rev(cmap(length(th))) x <- seq(-2, 2, len=n) m <- function(x,y,z) x > .25 | y < -.3 contour3d(f,th,x,x,x,color=col, mask = m, engine = "none", scale = FALSE, ...) } conts <- gs1(40, 5, screen=list(z = 130, x = -80), color2 = "lightgray", cmap=rainbow) exportScene(conts, "nmix", "OFF") } \keyword{hplot} misc3d/man/surfaceTriangles.Rd0000644000176000001440000000366211712563512016041 0ustar ripleyusers\name{surfaceTriangles} \alias{surfaceTriangles} \title{Create a Triangle Mesh Representing a Surface} \description{ Creates a triangle mesh object representing a surface over a rectangular grid. } \usage{ surfaceTriangles(x, y, f, color = "red", color2 = NA, alpha = 1, fill = TRUE, col.mesh = if (fill) NA else color, smooth = 0, material = "default") } \arguments{ \item{x, y}{numeric vectors.} \item{f}{numeric matrix of dimension \code{length(x)} by \code{length(y)} or vectorized function of two arguments.} \item{color}{color to use for the surface. Can also be a function of three arguments. This is called with three arguments, the coordinates of the midpoints of the triangles making up the surface. The function should return a vector of colors to use for the triangles.} \item{color2}{opposite face color.} \item{alpha}{alpha channel level, a number between 0 and 1..} \item{fill}{logical; if \code{TRUE}, drawing should use filled surfaces; otherwise a wire frame should be drawn.} \item{col.mesh}{color to use for the wire frame.} \item{smooth}{integer or logical specifying Phong shading level for "standard" and "grid" engines or whether or not to use shading for the "rgl" engine.} \item{material}{material specification; currently only used by "standard" and "grid" engines. Currently possible values are the character strings "dull", "shiny", "metal", and "default".} } \value{ Returns a triangle mesh object representing the surface. } \seealso{ \code{\link{persp}}, \code{\link[rgl]{rgl.surface}}, \code{\link[rgl]{surface3d}}. } \examples{ drawScene(surfaceTriangles(seq(-1,1,len=30), seq(-1,1,len=30), function(x, y) (x^2 + y^2), color2 = "green")) drawScene.rgl(surfaceTriangles(seq(-1,1,len=30), seq(-1,1,len=30), function(x, y) (x^2 + y^2), color2 = "green")) } \keyword{hplot} misc3d/man/contour3d.Rd0000644000176000001440000002010611712563512014450 0ustar ripleyusers\name{contour3d} \alias{contour3d} \title{Draw an Isosurface, a Three Dimension Contour Plot} \description{ Computes and renders 3D contours or isosurfaces computed by the marching cubes algorithm. } \usage{ contour3d(f, level, x, y, z, mask = NULL, color = "white", color2 = NA, alpha = 1, fill = TRUE, col.mesh = if (fill) NA else color, material = "default", smooth = 0, add = FALSE, draw = TRUE, engine = "rgl", separate=FALSE, ...) } \arguments{ \item{f}{a function of 3 arguments or a three dimensional array.} \item{level}{The level or levels at which to construct contour surfaces.} \item{x,y,z}{locations of grid planes at which values in \code{f} are measured or \code{f} is to be evaluated. Can be omitted if \code{f} is an array.} \item{mask}{a function of 3 arguments returning a logical array, a three dimensional logical array, or \code{NULL}. If not \code{NULL}, only cells for which \code{mask} is true at all eight vertices are used in forming the contour. Can also be a list of functions the same length as \code{level}.} \item{color}{color to use for the contour surface. Recycled to the length of \code{'levels'}. Can also be a function, or list of functions, of three arguments. These are called for each level with three arguments, the coordinates of the midpoints of the triangles making up the surface. They should return a vector of colors to use for the triangles.} \item{color2}{opposite face color. Recycled to the length of \code{'levels'}.} \item{alpha}{alpha channel level, a number between 0 and 1. Recycled to the length of \code{'levels'}.} \item{fill}{logical; if \code{TRUE}, drawing should use filled surfaces; otherwise a wire frame should be drawn. Recycled to the length of \code{'levels'}.} \item{col.mesh}{color to use for the wire frame. Recycled to the length of \code{'levels'}.} \item{smooth}{integer or logical specifying Phong shading level for "standard" and "grid" engines or whether or not to use shading for the "rgl" engine. Recycled to the length of \code{'levels'}.} \item{material}{material specification; currently only used by "standard" and "grid" engines. Currently possible values are the character strings "dull", "shiny", "metal", and "default". Recycled to the length of \code{'levels'}.} \item{add}{logical; if \code{TRUE}, add to current \code{rgl} graph.} \item{draw}{logical; if \code{TRUE}, draw the results; otherwise, return contour triangles.} \item{engine}{character; currently "rgl", "standard", "grid" or "none"; for "none" the computed triangles are returned.} \item{separate}{logical and one for each \code{level}; if it is \code{TRUE}, and either the \code{engine} is "none" or \code{draw} is not true, the triangles from the corresponding \code{level} are separated into disconnected chunks, namely that triangles from different chunks have no vertex in common. The default is \code{FALSE} for each level. } \item{...}{additional rendering arguments, e.g. material and texture properties for the "rgl" engine. See documentation for \code{\link[misc3d]{drawScene}} and \code{\link[misc3d]{drawScene.rgl}}} } \value{ For the "rgl" engine the returned value is \code{NULL}. For the "standard" and "grid" engines the returned value is the viewing transformation as returned by \code{persp}. For the engine "none", or when \code{draw} is not true, the returned value is a structure representing the triangles making up the contour, or a list of such structures for multiple contours. } \details{ Uses the marching-cubes algorithm, with adjustments for dealing with face and internal ambiguities, to draw isosurfaces. See references for the details. } \note{ The "rgl" engine now uses the standard rgl coordinates instead of negating \code{y} and swapping \code{y} and \code{z}. If you need to reproduce the previous behavior you can use \code{options(old.misc3d.orientation=TRUE)}. Transparency only works properly in the "rgl" engine. For standard or grid graphics on pdf or quartz devices using alpha levels less than 1 does work but the triangle borders show as a less transparent mesh. } \references{ Chernyaev E. (1995) Marching Cubes 33: Construction of Topologically Correct Isosurfaces \emph{Technical Report CN/95-17, CERN} Daniel Adler, Oleg Nenadic and Walter Zucchini (2003) RGL: A R-library for 3D visualization with OpenGL Lorensen W. and Cline H. (1987) Marching Cubes: A High Resolution 3D Surface Reconstruction Algorithm \emph{Computer Graphics} \bold{vol. 21, no. 4}, 163-169 Nielson G. and Hamann B. (1992) The Asymptotic Decider: Resolving the Ambiguity in Marching Cubes \emph{Proc. IEEE Visualization} \bold{92}, 83-91 } \seealso{ \code{\link[rgl]{triangles3d}}, \code{\link[rgl]{material3d}}, \code{\link[rgl]{surface3d}}. } \examples{ #Example 1: Draw a ball f <- function(x, y, z)x^2+y^2+z^2 x <- seq(-2,2,len=20) contour3d(f,4,x,x,x) contour3d(f,4,x,x,x, engine = "standard") # ball with one corner removed. contour3d(f,4,x,x,x, mask = function(x,y,z) x > 0 | y > 0 | z > 0) contour3d(f,4,x,x,x, mask = function(x,y,z) x > 0 | y > 0 | z > 0, engine="standard", screen = list(x = 290, y = -20), color = "red", color2 = "white") # ball with computed colors w <- function(x,y,z) { v <- sin(x) + cos(2 * y) * sin(5 * z) r <- range(v) n <- 100 i <- pmax(pmin(ceiling(n * (v - r[1]) / (r[2] - r[1])), n), 1) terrain.colors(n)[i] } contour3d(f,4,x,x,x, color = w) #Example 2: Nested contours of mixture of three tri-variate normal densities nmix3 <- function(x, y, z, m, s) { 0.4 * dnorm(x, m, s) * dnorm(y, m, s) * dnorm(z, m, s) + 0.3 * dnorm(x, -m, s) * dnorm(y, -m, s) * dnorm(z, -m, s) + 0.3 * dnorm(x, m, s) * dnorm(y, -1.5 * m, s) * dnorm(z, m, s) } f <- function(x,y,z) nmix3(x,y,z,.5,.5) g <- function(n = 40, k = 5, alo = 0.1, ahi = 0.5, cmap = heat.colors) { th <- seq(0.05, 0.2, len = k) col <- rev(cmap(length(th))) al <- seq(alo, ahi, len = length(th)) x <- seq(-2, 2, len=n) contour3d(f,th,x,x,x,color=col,alpha=al) bg3d(col="white") } g(40,5) gs <- function(n = 40, k = 5, cmap = heat.colors, ...) { th <- seq(0.05, 0.2, len = k) col <- rev(cmap(length(th))) x <- seq(-2, 2, len=n) m <- function(x,y,z) x > .25 | y < -.3 contour3d(f,th,x,x,x,color=col, mask = m, engine = "standard", scale = FALSE, ...) bg3d(col="white") } gs(40, 5, screen=list(z = 130, x = -80), color2 = "lightgray", cmap=rainbow) \dontrun{ #Example 3: Nested contours for FMRI data. library(AnalyzeFMRI) a <- f.read.analyze.volume(system.file("example.img", package="AnalyzeFMRI")) a <- a[,,,1] contour3d(a, 1:64, 1:64, 1.5*(1:21), lev=c(3000, 8000, 10000), alpha = c(0.2, 0.5, 1), color = c("white", "red", "green")) # alternative masking out a corner m <- array(TRUE, dim(a)) m[1:30,1:30,1:10] <- FALSE contour3d(a, 1:64, 1:64, 1.5*(1:21), lev=c(3000, 8000, 10000), mask = m, color = c("white", "red", "green")) contour3d(a, 1:64, 1:64, 1.5*(1:21), lev=c(3000, 8000, 10000), color = c("white", "red", "green"), color2 = c("gray", "red", "green"), mask = m, engine="standard", scale = FALSE, screen=list(z = 60, x = -120)) } #Example 4: Separate the triangles from the contours of # mixture of three tri-variate normal densities nmix3 <- function(x, y, z, m, s) { 0.3*dnorm(x, -m, s) * dnorm(y, -m, s) * dnorm(z, -m, s) + 0.3*dnorm(x, -2*m, s) * dnorm(y, -2*m, s) * dnorm(z, -2*m, s) + 0.4*dnorm(x, -3*m, s) * dnorm(y, -3 * m, s) * dnorm(z, -3*m, s) } f <- function(x,y,z) nmix3(x,y,z,0.5,.1) n <- 20 x <- y <- z <- seq(-2, 2, len=n) contour3dObj <- contour3d(f, 0.35, x, y, z, draw=FALSE, separate=TRUE) for(i in 1:length(contour3dObj)) contour3dObj[[i]]$color <- rainbow(length(contour3dObj))[i] drawScene.rgl(contour3dObj) } \keyword{hplot} misc3d/man/triangles.Rd0000644000176000001440000000574511712563512014534 0ustar ripleyusers\name{triangles} \alias{makeTriangles} \alias{updateTriangles} \alias{scaleTriangles} \alias{translateTriangles} \alias{transformTriangles} \title{Triangle Mesh Functions} \description{ Functions to create and modify triangle mesh objects representing 3D surfaces.. } \usage{ makeTriangles(v1, v2, v3, color = "red", color2 = NA, alpha = 1, fill = TRUE, col.mesh = if (fill) NA else color, smooth = 0, material = "default") updateTriangles(triangles, color, color2, alpha, fill, col.mesh, material, smooth) translateTriangles(triangles, x = 0, y = 0, z = 0) scaleTriangles(triangles, x = 1, y = x, z = x) transformTriangles(triangles, R) } \arguments{ \item{v1,v2,v3}{specification of triangle coordinates. If all three are provided then they should be matrices with three columns representing coordinates of the first, second, and third vertices of the triangles. If only \code{v1} and \code{v2} are provided then \code{v1} should be a numeric matrix with three rows specifying coordinates of vertices, and \code{v2} should be an integer matrix with three rows specifying the indexes of the vertices in the triangles. If only \code{v1} is provided then it should be a matrix with three columns and number of rows divisible by three specifying the vertices of the triangles in groups of three.} \item{triangles}{triangle mesh object.} \item{x,y,z}{numeric of length one. Amounts by which to translate or scale corresponding coordinates.} \item{color}{color to use for the surface. Can also be a function of three arguments. This is called with three arguments, the coordinates of the midpoints of the triangles making up the surface. The function should return a vector of colors to use for the triangles.} \item{color2}{opposite face color.} \item{alpha}{alpha channel level, a number between 0 and 1.} \item{fill}{logical; if \code{TRUE}, drawing should use filled surfaces; otherwise a wire frame should be drawn.} \item{col.mesh}{color to use for the wire frame.} \item{smooth}{integer or logical specifying Phong shading level for "standard" and "grid" engines or whether or not to use shading for the "rgl" engine.} \item{material}{material specification; currently only used by "standard" and "grid" engines. Currently possible values are the character strings "dull", "shiny", "metal", and "default".} \item{R}{4 by 4 homogeneous coordinate transformation matrix to apply.} } \value{ A triangle mesh object of class \code{Triangles3D}. } \details{ \code{makeTriangles} creates a triangle mesh object. \code{updateTriangles} modifies fields of such an object. Both may perform some consistency checks. \code{translateTriangles} and \code{scaleTriangles} translate or scale the vertex locations of triangle mesh objects by specified amounts. \code{transformTriangles} applies a transformation specified by a 4 by 4 homogeneous transformation matrix. } \keyword{hplot} misc3d/data/0000755000176000001440000000000012100512546012371 5ustar ripleyusersmisc3d/data/teapot.rda0000644000176000001440000006454211712563512014377 0ustar ripleyusersǿw6dJP)*-n@ER) B|q_}|gonWX,;)ˊŎ,?N='UQc*Kb,KI/* p%|8ď s%qwM0mٸO+''˙}|^YwUVtI_/o:O2sRG3- p%|Ŷ/<\Γ%%o>|;;K[<ng&t,?nCS\9EiMVk뿧?~x+ w<0y ~]OjQlM3Ę{\E<m[ֿt_WLxj}<ضM/J]^ϝk/sJoyqz7JiLzNֶL=d#wǥiLz8s\PJ}n{z8΃z\ܓݸSYZ;sion˹ڀvx2/Gzys-gvsNCqnsh/}[9ǹiͦKm=+W ~7㱎Γbk퉧O:;۶~]]qAY+዆Z~r_]Z.߫[O'oֻe{5oͣJR盞^iM`q zY;cv˒W^SE>sNΥɶۚ.-MO3כvQfΓ]f93=1#SI+5z\?6~\ ?2=W\9~y]hGo<׶\ [x>%,_;ڎK%fqC+]?jUkci7iփk`{[>"+y~k]~s%|LͿr>ǖ<4vV`'ϕ6uR7e߼P=4J8 [O.;?h(}K* p|EX<<.p`q֗MryϿ'm}胢M,}\i+ar3<.Ɂn9n%_)ۡe;eE7靲z&~qcI_~\WdyGƹK\ ?Y/n^*}ho,7(pq+=wmo/p%"^f=>O \ [Jx5vp˰e"GJRW\ y[lo{3ĕp@,_bO?w4\WJxZe|%n9q9i1,u,/ p%<γ8uvs^mx\nöeC\ E<w) p?>u}) p%M>9mx+3{ \ o=AuX+)˺ q%reυ\ -t\WJ9=AaIԸ0'^TJl}?J;|xuWՍN艙W\ W[b[l{l}gv@ J)\\>ewBœvY(p7'3pSq+KR9=W߱xr-l;JL/%UK\ u}q,uZJ_L;^7\ sKW·Λx+e:vmw|>xry~+c7Wo_t|%W]D-W|͗غFCbU>%W^sRm \ osqYJ]Z,8l\ ~iQJ=j}XJ8?w]}?0n :}q2s%܍+Hq+ƻq`c\ w/bJ5v=,+uNgǕ,=lhZXJ; c)z^X_}<.˛'y^|"yX򱑥~7\ |n|Ҿ$p7n!45|?je\E%JW{lox+n[9\%=U78/Jޒc>Wq7Yw\8.\ w/b\*qqEvWIc|"nEL|ݫZI+nTS\ wra\Jx#?\ wBJ+:\E>U/>WFK|ү㾦ϕveXu}Jx;h{y{\ wE}S3.%)ƭ|FE+~Csq/rs%E+c\EuO~ϕ-" q 93s%]K<>Wu,/>W 7>W/hQf<JNe{f;81}+L\\ `waj8Uy^FQWs%&lyKsJ#sR7s5WdϕpwIO>WyV+n{*nn3@?OKH;}~\ w7I|׵c<W ,IiČ$UyNGx|<. <۲_s^^”(ےWgJ/g\ wϿc|Pq,e s>WsҞ<'s%=쏹|"㮞E&C\ -{_\ QZ=v/~ϕ~>W}Wp_J;^JWv;wMW_Gq,e\EcUXhu?WFJxzYeĜ%jw^ߎF$lqVq>\ϕp\>ϕpw_1+'K{7:Nqϕp^\7ޅϕpw+U}[>W}}+oL|vǕ[Sq%?8*ses%[{N* p%㶞uݸk\E:}:}c0s%\kR%<xs\+h^i{z&&#ĕpܮ\\ϕ:Ĥbg]X~>lpqo,r\xs%HJRSϕphR+u{*3֞iyt\ wV9ү8u\ wJ9?x"z)[rE3*S[Wp?sJۮegjũpS,*q+ᮿ +>W#?'sUĹ~>׷>W^89~8\ wO`J,י>Wzz8 r*xH?*✟es%ܝe{sq3Y^C+/{;2>W>W>ayD6>qrd\2ޓ9{y4.>W>Ҟ^NrqYߣi)a\s?szثgth|ks G^Dp?!Gs|9~yt7:WM+ϕyy_eW\ [|[T~ϣ~yRu>WFGF_h} ^+~ϕpQ]e.y >p]Fen.yt]2\\ _W<*uϕuϕuϕuϕϕϣq aJxx\JxxJxx\Qewy42\  x>W>W>!UqN+qT+qZG*8ϕ8ϕ8ϕ8ϣqraJxxJx>ϕ} G)T*}+/*}+D> |s<:Ϊ Tn>W|T> %}yᾧϕ}U+>W};<2os%<|_qAes%<\ϕs >WE\ ?ws%<\ϣ:TF|K~NgxnJx +|k~nJx+9.+|C~MyϿE)y9\|SytU3~s*s>Wa\ ?9O9R+T}~Jx9^Gc9aG !\ ?9g9j+U}yܸ\ϣU}~nJxG WW]\ NQ+R}2s%<^ϕ{>U ~Jxf+}~*Ƀ$~Jx;0>Wߙϣ+\ Jx;B>W)yPs%<%+8\ /vNϕw|ss%<-G^eNϕw|3s%<3+Wϕw}Cs%W}2|WJx>Wϕw}}s%<]b+\ WJx>;>WK|Z\ 7Jx*w}s%<r+\ GҟvK w}3s%<{+ \e]+]+Mge]+}] >P~Jxw7|JxAT%CNgw[|Ee;5>Wÿsd;>>Q~He]!ur-H> s%~7T> sqُ2p |. _sy:\7~2N|. sy)֩ s|.3ޟ< \Ƌ3>YI\gF|y_~>xfW>_S:׮辧Ǖ0X87_p~I|zsPE}{{gS} sﴺ; s;> csyn& sw{}.k3.9 ;syfV63#썥W_,۞+lmWÿsyOc?s,2LOLy{pi+qo*=kVƔ|Grz5mmޓZدj,z\C?sO/Yԭk{3>Ǣ7 \ q(3s\%y?;u UQZy'v޵qTWW]SbIZsiն?>fˏv®j~twefyfRR?YJx+w^wq;~'\ SY*o4 W_dg$ p%7O[t\q|Wca+g>=g}d%SJv~e?ڵWM_DQgn#,aa+k'^h/Kb״_Q;/9g\ o̭7i6GEv~ޯ~}-[%o q%)p-yW\ :жRywMkWGM~2[|y:W'l-%1'n6~O\|[ou>Ϳm q%|Ԟ*MXP*9Yn~wobn%1~qszx-;ſ q%Nɖ %qi|kM_Z,n7Sr̡4+e4o~]F_h׶slG;w\JW/e?G9nzai׃%UszP[qr|Yx]}rl}W=hgOl|ouon6>1ԑ!_gd|cx\ o-75q9.e7Xmyx+yUl68>lo?֭hwV6]|q98XhgNQz|v~\HY+kr]׷~[sk_=.y]w/XRJ7B۞ZJWv晦rGrWi{Dw[Jfށ/( pr|Wb<.jEoA 3=\ /t|8:>{\y(7_]60.i]J\ G,x+{yrWۿi!z>CΧi9{Ύ[$U4pw?1{JSv]Ӟqz\ F>ծ&oSJ8i?~^گ=.{~AwX=8S{T6յv*c%& ?Go<.ޒ_}GI+-Ӷh\ >>nܔB\ o;eG{C\ ?w w|=agI+Oo}/ߏW\ ϭf9:{\OrKM:^OmlG^Һ8CRzջGZ~/<%Oǽx߫͟Ycmѣ0yٿُi'&DIJlgtJzǥ͗}OS۞gp%|M{ӾWI>[IW7sp?xВW7q\/>Pf[m;QZf}"^pYc_.W=.ۂڸ]->(clWv[d9z\>Ö?5.L:WvsM_.\J|mYlۧBvI+>w\_La-6J<.ؿ&_{\E vQ{z\eRN ٝ8Pb%w^]aw!7r/+ p%Oѿ!7UVfzb,Ǖ[{;> + p%%l֝7QJHul_YĨM>{[;yzY+ --?1Xs W{\%s^iˏ7$σijn[N; \ ossZrV+%]Xn3O=.oVv\I_JLWm_Z|q9/^hfK?ˋ}f/<.E9|@<FhI+Sv{z\rKv߹ݢ|W0Io) v>ُ^c=.zH{F#m~uC?|OxWDe(c<. Ky 9n{\?X':{\r{<.Sq6>xf*._|~ǥYX=Nq[~t}qpޤ2}_qVmfdY?qWkUڡ߻(bfɊŎ,ua:L;btӧ:SH^ GxN#6@gsNW[1u\F?gz)bt*oba>&q?NWSGsNW[}^-,cyƗwl11c]L:@Q-xN'ZX9C]L?:phk?q-ove5,mN;7~>u41/ "У/:ں6y:oqofNlY:}7z~砇7 ?QY&9:#3z9ʼ6@ߍo|L~w?1}9z1 &NFO03XD&N{)3 ۈYƣޏ?3zs4l{1G~ކmļS KĶ@ǿmi$khOݎ)<˚n?-i ~1ySG_ĶEhvPa eu:{;xsw⛻x.&[/{~ y㍾u07>t?تQGS7öwxGg>ntDށItѩ) M]iuontw"O6KT%f<1z=15_B`x=紬>W~ 1=nYCA̧˲11uNl}|-Fƿ6b }.ބ7[UgmDvފlb:t;f}]bC7ץn׍z$M3_Lћ3Q'HBw&T [vm.hÈMT; ?lbtg=Hcl#&I?I#'|lVT|We~5mE0bt+7~, cyVg:ujvFs: ¿~3o8b~~oi%~6+ZgI̿Zoթ//11o-bC¿|L̷:-KR'o٭.xW4s˘}N7eoB7z1]uJPt3ۈ@k3ܠSFXo蛨d77`ٛ7`>&F;;}3u415{ ~"[C]mLnunboF[l=tz߃Qt1e  v(~P|bOa11r(~5|Lu~V{0z(1"b_D?1:%cMPG*f_b*'i¶qNgчb=t~&FLg:mFFgnƕ:6sJ؈nLjt ~ P| cbľn: :O v5~[#QF.F9?&o`#3kwϑ]ux73WĮGkWөFXQz5Ͱnou q31u;yǡ@M<.~[Ρ\(c+1w9ڢ@G^?JFHn1bǠF>qi1O>ݖ}!JJcb&o1y#~?:/q/1}v1ۆ>6vVb?z6ۆKN%tS|_t ݇_n/>v(؇nNh[6cꦏ;ߏ:_rXadbStjDsxQ:ᛐ|ֳӻ^ľz61f;&~ۈ*Jѳ_1}6ukӳ,7 ?INAL7tbCNM˜ 鿡m#Tt㭞L>Wovovm^{,y|2KyCo'\b2\%Ğ'cktyM(\bcƕG =?]gg?ou[Nt[q߂D>柂E)S\;ۍv[]ٴi[3&9S3S:ߒЧIK=}RhbW#6>_:Mwm,Vʻߕ|ףwu6 _oz6G:=O6bbN .xdc*y_`YoEOſ@ML ]V_OBc ~u41i4kOWk;FeƦ12{6[nƾdb^t1)v@} k~ot1.>Z ĔtywὉG{m.݁]k<sN[ ml$Ÿ֛Vd[VdeO&62ۈ9B wplt#ꦏY[÷d>&F_dU%".11\1"1N9ovNoGgPSܧ~ujxܭ"^k;FbbľNg-[g3N`btݲ&=nƘqo<vlAYrpQZ_2sڶi[3Ε??v21f_;_SѧN&F͓֟Kl.mlbթ^b{oc:m`[ۆޅ|L̸C{4< (11gt>,bG?:}ꆿn8V2fی~lgy[`114*3mn':̉.)cӶn'k-~˺ ?Mmo`.BXKLb5GT|Ob[{:ںUU\Z_2:m͵>v>uan?}h11s%.Cb.!~551\L: _La|"׉]n7z1Kt"~~ נ#F/kqۼF/'f?׬5twk'۶X$Vݭ7뫳 N2b>i CbנH6kFUtW5 #NS]ncVG̷֬6*1k_&Tb7Ouu}[I.(c1Sy^o-yֳYF3v va=mE#Of;rgQ.bjk{-"&&FqZ}-^1ZmMVte=_cVU̷*e$Zb> ߈V񍨣k[Э25N7㍾ ߖ鷡%*_E9&}1_!7㍎Qտ]>g9|b8oV_꼭ʮ.[}uL& > +X'X'dIs_N.~,1[|X3}'bi7>ފ7VڰN}X}c01fc#dkշncRu'u')]?ous8}b|'01o5^ۼ9uވ2LL-_r[]LZ,Yv;/ {is֋X㭾0S:u&o' hhbxk={<۩9o{y Ę|MwN1?6GbFH;^nĿF1S?uo?z>1';7~11m&|hhb)8m}gXw8B~!ۈVL׬.q811ĿMEFL?ou'JM;/_eF߈crkr&NbL5~_PG9/s\VIƨ1Z{~c13)Gξ,yoDOmjZKϱe"K-Bg)Qf?3cbw1Y_4K>^ۼ_xonu(䝥Y}~m`<8e2Ct?&_@1"M_d/!LІ77 8Ęg{"|Mu ; 4v01uOlmg _3ꊔSq3vcɻ y3GQ GQɫfƜeT_Ųwa|w7ݙ\ˉm 951ttbAƟhc8F|!ulf6ϥo[[lf6G$o|Hq[}?:N6@kǐ:1UKܱxp,y@{1u41i}5=ltelb90 ];MLSZߔmĘ6_Ll396Ϛeވsl|?#CH] ?u41UoMl5c ^7獣}7Ze6_wLǖ <\2t.A71FbBkף.WOף ^FK-Llu'11t)4b/Eǟ|L&ꊿخZ˨yB'oZ 6`76vlٌcphk)mޯtڎzmG?ʕasBYZ_23:R3+E߀ƍ#ڱJ:cLe&WYe+歪˔YZ_2f9m,b*ueb v]o1]3|1o& зtuuS_\Z_28mSmOxfKiSg|b;7a;514#ЗL̇:mHtWϿotӋН<>bG7|Ln۬i7:}MuEl#f[ש=>6@}\SwvGW_6bb<Ǐ w}nFz4p7vjbsN 9t=ČOxbDwǏwuu}.)O}{oB]svh[:ǘ~l"Fr7y͵wxM_Z_cl <\2x,-yf 6N7-1]f{;} nVZxWP2bfy{>|vsYvgqSFyOg{MNg.GZiC}ۃ_rA_{+zYq.(cOۼf˨ |+(yBL+7$M+cbpߤ&|ߔM^}Mui>ep1z7vڶYv365j.}n>6Fv>f~ /ğ@M3i?U6۩ݶ{n+8&gb4 ?Yn;1a.x&vlz]_@غV7k11eNĿADt;Ę,.xghfVSɫЇOe=eW7Ucޕ_@<\ml#&fo̎{{ഝ>uԩߑe-Fwd>&ĿG1e]:1waz~%ӗ9e\ЩZ7z-n7sf+ǺXumވf!O)z11xRݷ-W#rt[7 x~b?My#nʚ L2?ӕac뇟Hl?rџz]z~_AH;:! eb֩7o3͔թYn~,1uǗXWO_`bb6cކɫxwfۈ)ҩ5"ԡN÷$(h5_K ѷD>T˴-1(h}D{@8G֋]ث7y5bTT-K)\) =!̲ki-Q?tc<9澃v*xL?} 1Uu*Jl9A(ꒃ>e36?,ax3؆c87S2|Uk}U7捸)K?b_] Dҕact76??ZϙU*[崙nVs}c{ι nFܔN࿡.߸2lw1w\]?@?ux?nތ~qWb5F駠o&N߈6uxI=}N7Rvs97XC#F_ ǎW'8t |M^}mhd?/`z8b8#=}(H<.ŸGQѧe7@7\bi(gtz zoǔ9R#}OsO/G1EVoeۢѩڦ"5ǔN] i<sW]3K 7yoש=v;eN1קx߉09tkbѩ#b;;nHL37#*tk|3y[xſwVW~ *41=tAl_tGs-k1=c9:|xs(ӼT*+"&O|||M^1y5V ԥ 2f0f?_N;=qwN Fa\<:7zOC/ /6"v#zRPnE/dL"]_D6d8MFŏc:}AgFO%bS31E.Lߏ_|._tWhb~׬w75ڜ>nez>hb;h[kQ; ot5|%WCW&篍?xP:)|M)(u6e_?xşsѵ9Km> Ř6}%e^w6>1N>x[цMuߔ܋n7=1w$nbD1y$^]!}J|w: 'v^|ib^saט> }DIx?×03tb4 ?iFNn}7eX뗹6SY>b'PGN= jqN_Ǔ+tx|sw_?bWyi g= 3L̏:mHt#41yk|LF5=2Lʘ;gEǯdzI> ~;bש|b;G}gF;1݁o?Llxө#>otbt)A%>> qW_?A]; 7O&#I,/= ӇNo;,>&7cL=u,>>EE1:ď!v&?>&O.sS)|R7.E7\mo bt=ku~MJZ Q](|ͼsiw⟧ _icO F籌:]bPnfxs(S_߈Ky(hG[#nK^,@(:Mm&_Ïdu|Q4eOFĿz0Zc3)W|)G2^__Y^ bW?ߑOwp]ɫϯy-.oa^:bv\ths3F}#z:1ܝ=_⍞Kv߁_Ltbփr5.5L߁kxWg*rb̳:kݏ qG[S筮vz꠯o *z9 L[>H[]ӫ&clY>bΥ.9mAM}|aoCu1"e5h;='mYZp8i;"1 9خMsAuWi;"<1t2bOF#n |-r"ez:5#:aTZOe@ß|Le:_Fl{I(}҂nxo[Rb琂Gvo?r:!|K%m`bsAvA_ɫS^(: })Su ^?Au_` 7ܘSs7b)1F otw}LΧtj?|Mѹ(uz7e?n^x_`G4od(OF?B=uzߓ|G1F??B}mR[Y(hwI:.Orb@N}O}я5};!,;WC)9#v039ɬ } o:L_ouZe;7<~n*;)l_fbof9L:'7>Atw7ytZ/.eab~i gb6}t/b۽x'"/"=P|M:` N}/#y:#_pGS?IF3(]uzߕAƏf>&fNcÈkU7z k/A%fNS?0ux]mto봁y9Io_f)@/P/cPs_3 ~lt*}2Ovg60F\|Mst'ϡ SSG⵶CLl>yKc+[pN'QG㫹2l>'t6>0N=no|Ḽ:݅ػЗ#ncEAOzZי>}e}1|W=~G~>߇v2X̧9>1mlbjT_غQ{N7o^7G1F>B=G=p0jWml/f?61h!/&fN ]1|sbBvP I;>$1uۭ>noc6ԩ6!mY]ߐz2i/ހdb~q1}C 7uSe筮vzm*1UQ^t:o)~ 1ttbo@W}1w=uw|.}|_tj3W1O8-F߀7?ûw>É)| A9}O3h@>?|&C>Hgw2O9[AD'/hW.:]7|闠[sNm7})&k} ߙ|f^o\p!3,t[b5\5^ߔy}-\7mwӮί4 Ѯ&F F; =?ubb&>~?O ׳:=?~ ,LLakςWC}= o9m~N?_#o;{3{* L"Q CjKBLqe! J($QtU,Nd2a !ĶZ&d(\uYw}9s{<, /;2:B`]ѕpuwppcux߅U1g9D'P7nD8Xu <s܁+2 \8: HMF3zlhd8dt9{!gURx#xJ].rY*1^wz5:kċ%rڗWY&^w!z1#gi+yXx&ucᙬz$ix34D=sztI>6y_'9x8&9U=D%.==eݽ}?::Ț|zt$}u\MG27lϿvt7rBaֿBwS61-g9ʦY;SV_} =Kl3~[TC-K꿆{9q/6VV^: nI{TVaqp+㜶1u%rZf̈Fksm|19\eݮ0N5-x>wKKU=OJ'{=+$cjrmAt-{T(Q HߥX<=+*T{b(~{9VݗEWOS-ɡ(?Esa?ϒxVE&ʀ V1O9_4H]jws#?kAW9T\o= ݂ x[ DuljkohxH$>o?1}U"n 6ҧ}p=u Q}H0|‡XoS9cfª7о Bix%`iģZV|Xu),4wP&#qu7Ч`<; LrU\r%4zD'+_]/$Z xU~^ph܁5F>c<w'rOԕG¾Gllތf8CU[o#rǘgK9mqMZ`Չp/xT^Xu['mя q ơ`ߣ:Eb8BIQ,3ࡌ3} <5VCx7~^kHSW!1(OdyqD>( ==H/хjyf *r??i&$wii'Xgؘ?V]F{yj g>7%r@cFiyW~۸#cZ㝶MiD&[撉 Vݛ>g<޴w ?D{f?Bb:<뛎N}! =˜ڧ{ t8M<9O=i[ӝ;yn>Gowyx/~^k.;^F!QYC;S<*9{T>Aߢ'X' yqm5VKwt/m6g9kk_DqsW6˜: p M<]~Bo=y^U OUonAxaK##{\WGxB/U{ʫ֣_˘zVHT+V`^ckvڳѥXv=zXVJ2Y ?˘do <a>D3fNQϝjג?wnꉎMnzHul:ñjk@ݎM:VmJjH܀P{|=|qtn ^ѾgD<o:Z_a+i_#,p!p!ks/. wk`yF-x[g^a8<΂C=n >=g^ՠ+]ܧY. +erqșKGM@OG{;qH@079CxG 7 yJr%gָ5(:& 7].CЕ3Q=xaOu&K4's_7C'NȾ\v^ zy-|EѴgY|>w9.گ/bŃP/a ԣcG.>-1~LF0~owt:=ҵe^/3 "׸C<ƱjU#gp5nڭ p.y8WtGj[m_cZ $QWȟc-NITçF_O50`?$6f x}G͕ a^>cuo96]XǦ9Vmo eԩg8x>q-x ̃_ś#k\ w1z/,~kC܍kA~8}N=|:Ǫ}z5zwp'ً k`Ou/,ܚn~kA=% y;v>D/}Y'<. ?7?θ:W9E| |> ׻q#=> y* ʳ JwZo-S]]sEq]3q5h*Kzo˙2΢v%8:Q(; b$~ Jt!vDV]gz1p2}[~-1ձǪ=0M<1)1~t^;i&+zo񾁎G3G,/ Vݎkߺ;6=N}*8<w8bxхW\SᷨSoVNWыQ=~ƻx7W읜>1w_+^}~}нKX Q ySb/&޽𛬓z~W㽎~f:ӢOFJӌs%6<ڷ}`V+gA{Mlj]xp:y[;^ oa #c[<VNz C LIៜWajUױGXiگ',7c8űXǪ=}icNqStwz ܕ1c<m۸-ȧax$t,6^b(EC=#%x HC0^O]1:'7~.si/n2z\@K2,Z?OwV#? geMۖѺqȷdTєYӲ4LS&gAimisc3d/demo/0000755000176000001440000000000012100512546012404 5ustar ripleyusersmisc3d/demo/lighting.R0000644000176000001440000001221511712563512014344 0ustar ripleyuserslibrary(misc3d) local({ haveRGL <- suppressWarnings(require(rgl,quietly=TRUE)) ## Example 1: Bivariate quadratic zz<-surfaceTriangles(seq(-1,1,len=30), seq(-1,1,len=30), function(x, y) (x^2 + y^2), color2 = "green") drawScene(zz) drawScene(updateTriangles(zz, material = "metal"), screen=list(z=45, y=110),light=c(.3,.3,1)) ## Example 2: Bivariate normal density zz<-surfaceTriangles(seq(-2,2,len=30), seq(-2,2,len=30), function(x, y) 2 * exp(-0.5 * (x^2 + y^2))) drawScene(zz) drawScene(zz, light=c(.5,.5,1)) drawScene(zz, lighting=perspLighting, light=c(.5,.5,1)) drawScene(updateTriangles(zz, material = "dull"), light=c(.5,.5,1)) drawScene(updateTriangles(zz, material = "shiny"), light=c(.5,.5,1)) drawScene(updateTriangles(zz, material = "metal"), light=c(.5,.5,1)) ## Example 3: Volcano z <- 2 * volcano x <- 10 * (1:nrow(z)) y <- 10 * (1:ncol(z)) vtri <- surfaceTriangles(x, y, z, color="green3") vtriDull <- updateTriangles(vtri,material="dull") vtriMetal <- updateTriangles(vtri,material="metal") vtriShiny <- updateTriangles(vtri,material="shiny") drawScene(vtri, screen=list(x=40, y=-40, z=-135), scale = FALSE) drawScene(vtriShiny, screen=list(x=40, y=-40, z=-135), scale = FALSE) drawScene(vtri,lighting=perspLighting, screen=list(x=40, y=-40, z=-135), scale = FALSE) drawScene(vtri, light=c(1, 1.5, 0),screen=list(x=40, y=-40, z=-135), scale=FALSE) drawScene(vtri,lighting=perspLighting, light=c(1, 1.5, 0), screen=list(x=40, y=-40, z=-135), scale = FALSE) drawScene(vtriDull, light=c(1, 1.5, 0), screen=list(x=40, y=-40, z=-135), scale = FALSE) drawScene(vtriMetal, light=c(1, 1.5, 0), screen=list(x=40, y=-40, z=-135), scale = FALSE) drawScene(vtriShiny, light=c(1, 1.5, 0), screen=list(x=40, y=-40, z=-135), scale = FALSE) drawScene(vtriDull, light=c(1, 1.5, 0), screen=list(x=40, y=-40, z=-135), scale = FALSE, engine = "grid") drawScene(vtriMetal, light=c(1, 1.5, 0), screen=list(x=40, y=-40, z=-135), scale = FALSE, engine = "grid") drawScene(vtriShiny, light=c(1, 1.5, 0), screen=list(x=40, y=-40, z=-135), scale = FALSE, engine = "grid") drawScene(list(vtri, translateTriangles(vtriMetal, y = 650), translateTriangles(vtriDull, x=900), translateTriangles(vtriShiny, x=900,y = 650)), light = c(1, 1.5, 0), screen = list(x=40, y=-40, z=-135), scale = FALSE) ## based on an example from lattice wireframe() vv <- parametric3d(fx = function(u, v) cos(u)*cos(v), fy = function(u,v) sin(u) * cos(v), fz = function(u,v) sin(v), umin = -pi, umax = pi, vmin = -pi/2, vmax = pi/2, n = 50, draw = FALSE) dv <- function(vv, cmap = terrain.colors, ...) { cf <- function(x, y, z) { w <- sin(3 * x) + cos(5 * y) + sin(7 * z) cmap(length(w))[rank(w)] } drawScene(updateTriangles(vv, color = cf, ...)) } dv(vv) dv(vv, cmap = rainbow) dv(vv, cmap = rainbow, col.mesh="black") if (suppressWarnings(require(maps,quietly=TRUE))) { m <- map(plot = F) drawScene(updateTriangles(vv,color="lightblue")) i <- which(m$x > 0) m$x[i] <- NA m$y[i] <- NA m$x <- m$x * pi / 180 m$y <- m$y * pi / 180 lines(sin(m$x+pi/2)*cos(m$y), sin(m$y)) } vvv <- local({ u <- seq(-pi, pi, len = 50) v <- seq(-pi/2, pi/2, len = 50) v[(1:12) * 4] <- NA parametric3d(fx = function(u, v) cos(u)*cos(v), fy = function(u,v) sin(u) * cos(v), fz = function(u,v) sin(v), u = u, v = v, draw = FALSE) }) dv(vvv) dv(vvv, cmap = rainbow) dv(vvv, cmap = rainbow, col.mesh="black") drawScene(updateTriangles(vtri, smooth = 1), screen = list(x = 40, y= -40, z = -135), scale = FALSE) drawScene(updateTriangles(vtri, smooth = 2), screen = list(x = 40, y = -40, z = -135), scale = FALSE) drawScene(updateTriangles(vtri, smooth = 2, color = function(x,y,z) { cols <- terrain.colors(diff(range(z))) cols[z - min(z) + 1]}), screen = list(x = 40, y = -40, z = -135), scale = FALSE, persp = TRUE, depth = 0.6) svtri <- local({ z <- 2 * volcano x <- 10 * (1:nrow(z)) y <- 10 * (1:ncol(z)) i <- 1 : nrow(z) z[ i %% 4 == 0] <- NA surfaceTriangles(x, y, z, color="green3") }) drawScene(updateTriangles(svtri, smooth=2, color = function(x,y,z) { cols <- terrain.colors(diff(range(z))) cols[z - min(z) + 1]}), screen=list(x=40, y=-40, z=-135), scale = FALSE) }) misc3d/demo/teapot.R0000644000176000001440000000547111712563512014041 0ustar ripleyuserslibrary(misc3d) local({ data(teapot) haveRGL <- suppressWarnings(require(rgl,quietly=TRUE)) ttri <- makeTriangles(teapot$vertices, teapot$edges, color = "red", color2 = "green") edges <- teapot$edges ttriDull <- updateTriangles(ttri,material="dull") ttriShiny <- updateTriangles(ttri,material="shiny") ttriMetal <- updateTriangles(ttri,material="metal") ## teapots with varying materials drawScene(ttri,screen=list(y=-30,x=40), scale = FALSE) drawScene(ttriDull,screen=list(y=-30,x=40), scale = FALSE) drawScene(ttriShiny,screen=list(y=-30,x=40), scale = FALSE) drawScene(ttriMetal,screen=list(y=-30,x=40), scale = FALSE) drawScene(ttri,screen=list(y=-30,x=40),lighting=perspLighting, scale = FALSE) if (haveRGL) drawScene.rgl(ttri) ## teapots with varying colors drawScene(updateTriangles(ttriShiny,color2=grey.colors(ncol(edges))), screen=list(y=-30,x=40), scale = FALSE) drawScene(updateTriangles(ttriMetal, color2=heat.colors(ncol(edges))), screen=list(y=-30,x=40), scale = FALSE) drawScene(updateTriangles(ttriMetal,color2=heat.colors(ncol(edges))), screen=list(y=-30,x=40), scale = FALSE, engine="grid") ## two teapots side by side hc <- heat.colors(ncol(edges)) drawScene(list(updateTriangles(ttri, color2 = hc), translateTriangles(ttri,z=4)), screen=list(y=-30,x=40), scale = FALSE) drawScene(list(updateTriangles(ttri, color2 = hc), translateTriangles(ttri,z=4)), screen=list(y=-30,x=40), scale = FALSE, engine="grid") drawScene(list(updateTriangles(ttriShiny,color2=hc), translateTriangles(ttriMetal,z=4)), screen=list(y=-30,x=40), scale = FALSE, engine="grid") if (haveRGL) drawScene.rgl(list(updateTriangles(ttri, color=hc), translateTriangles(ttri,z=4))) ## nested teapots drawScene(list(updateTriangles(ttri,color="blue", fill=FALSE, col.mesh="blue"), scaleTriangles(updateTriangles(ttriMetal, color2="red"), 0.6)), screen=list(y=-30,x=20,y=-140), scale = FALSE) if (haveRGL) drawScene.rgl(list(updateTriangles(ttri, alpha = 0.5, color="blue"), scaleTriangles(ttriMetal, 0.6))) ## teapot with smoothing (Phong shading) drawScene(updateTriangles(ttriMetal, color2 = hc, smooth = 1), screen=list(y=-30,x=40), scale = FALSE) drawScene(updateTriangles(ttriMetal, color2 = hc, smooth = 2), screen=list(y=-30,x=40), scale = FALSE) drawScene(updateTriangles(ttriMetal, color2 = hc, smooth = 3), screen=list(y=-30,x=40), scale = FALSE) }) misc3d/demo/00Index0000644000176000001440000000025511712563512013547 0ustar ripleyusersteapot Some examples using the Utah teapot. lighting Some examples of surfaces rendered with lighting and shading misc3d/DESCRIPTION0000644000176000001440000000055612100516564013200 0ustar ripleyusersPackage: misc3d Title: Miscellaneous 3D Plots Version: 0.8-4 Author: Dai Feng and Luke Tierney Maintainer: Luke Tierney Suggests: rgl, tkrplot, MASS Description: A collection of miscellaneous 3d plots, including isosurfaces. License: GPL Packaged: 2013-01-25 14:23:34 UTC; luke Repository: CRAN Date/Publication: 2013-01-25 15:57:56 misc3d/README0000644000176000001440000000200011712563512012337 0ustar ripleyusersThis package provides a small collection of functions for 3D data: contour3d Uses rgl, standard, or grid graphics to render isosurfaces, or three-dimensional contours, computed by the marching cubes algorithm. image3d Crude 3d analog of image() using rgl to plot points on a three dimensional grid representing values in a three dimensional array. Assumes high values are inside and uses alpha blending to make outside points more transparent. parametric3d Plots a two-parameter surface in three dimensions. Based on Mathematica's Param3D slices3d Uses tkrplot to create an interactive slice view of three or four dimensional volume data, such as MRI data. Additional support functions are available for managing triangle mesh representations of surfaces, rendering these surfaces with lighting and (minimal) shading in standard or grid graphics, and writing out triangular mesh scenes to different textual file formats. misc3d/inst/0000755000176000001440000000000012100512546012435 5ustar ripleyusersmisc3d/inst/CITATION0000644000176000001440000000117111712563512013601 0ustar ripleyuserscitHeader("To cite misc3d in publications use:") citEntry(entry = "Article", title = "Computing and Displaying Isosurfaces in {R}", author = personList(as.person("Dai Feng"), as.person("Luke Tierney")), journal = "Journal of Statistical Software", year = "2008", volume = "28", number = "1", url = "http://www.jstatsoft.org/v28/i01/", textVersion = paste("Dai Feng, Luke Tierney (2008).", "Computing and Displaying Isosurfaces in R.", "Journal of Statistical Software 28(1).", "URL http://www.jstatsoft.org/v28/i01/.") ) misc3d/NAMESPACE0000644000176000001440000000063212100512300012664 0ustar ripleyusers# Should import rgl once it has a name space export(contour3d,computeContour3d) export(image3d) export(parametric3d) export(slices3d) export(drawScene,drawScene.rgl) export(exportScene) export(surfaceTriangles) export(makeTriangles,updateTriangles) export(scaleTriangles,translateTriangles,transformTriangles) export(perspLighting,phongLighting) export(kde3d) export(pointsTetrahedra) export(linesTetrahedra)