version 0.100.18

Author: dmurdoch

DESCRIPTION

@@ -1,11 +1,12 @@
 Package: rgl
-Version: 0.99.16
+Version: 0.100.18
 Title: 3D Visualization Using OpenGL
 Author: Daniel Adler <dadler@uni-goettingen.de>, Duncan Murdoch <murdoch@stats.uwo.ca>, and others (see README)
 Maintainer: Duncan Murdoch <murdoch@stats.uwo.ca>
 Depends: R (>= 3.2.0)
 Suggests: MASS, rmarkdown, deldir, orientlib, lattice, misc3d,
-        rstudioapi, magick
+        rstudioapi, magick, plotrix (>= 3.7-3), tripack, interp,
+        alphashape3d
 Imports: graphics, grDevices, stats, utils, htmlwidgets, htmltools,
         knitr, jsonlite (>= 0.9.20), shiny, magrittr, crosstalk,
         manipulateWidget (>= 0.9.0)
@@ -22,6 +23,6 @@ SystemRequirements: OpenGL, GLU Library, XQuartz (on OSX), zlib
 BugReports: https://r-forge.r-project.org/projects/rgl/
 VignetteBuilder: knitr
 NeedsCompilation: yes
-Packaged: 2018-03-28 12:29:10 UTC; murdoch
+Packaged: 2019-03-05 21:02:05 UTC; murdoch
 Repository: CRAN
-Date/Publication: 2018-03-28 14:53:30 UTC
+Date/Publication: 2019-03-08 16:10:06 UTC

MD5

@@ -1,5 +1,5 @@
 export(.check3d, 
-        abclines3d, addNormals, addToSubscene3d, 
+        abclines3d, addNormals, addToSubscene3d, arc3d,
         arrow3d, as.mesh3d, asRow,
         ageSetter, asEuclidean, asHomogeneous, aspect3d, axes3d, axis3d, box3d,
         bbox3d, bg3d, bgplot3d, 
@@ -31,12 +31,12 @@ export(.check3d,
 	scale3d, scaleMatrix, scene3d, segments3d, select3d, selectpoints3d,
 	rgl.setMouseCallbacks, rgl.setWheelCallback, setupKnitr, 
         setUserShaders, shade3d, 
-	shapelist3d, show2d, snapshot3d, 
+	shapelist3d, shinyGetPar3d, shinySetPar3d, show2d, snapshot3d, 
 	spheres3d, spin3d, sprites3d, subdivision3d, 
 	subsceneInfo, subsceneList, subsetSetter, subsetSlider, Sweave.snapshot,
 	surface3d, terrain3d, 
-	tetrahedron3d, text3d,
-	texts3d, title3d, toggleButton, toggleWidget, triangulate, 
+	tetrahedron3d, text3d, texts3d, 
+	thigmophobe3d, title3d, toggleButton, toggleWidget, triangulate, 
 	tmesh3d, transform3d, translate3d, translationMatrix, triangles3d,
 	turn3d, useSubscene3d, vertexSetter, view3d, wire3d, 
         writeASY, writeOBJ, writePLY, writeSTL, writeWebGL)
@@ -62,6 +62,9 @@ export(.check3d,
  S3method(plot3d, mesh3d)
 
  S3method(as.mesh3d, deldir)
+ S3method(as.mesh3d, tri)
+ S3method(as.mesh3d, triSht)
+ S3method(as.mesh3d, ashape3d)
 
  S3method(translate3d, default)
  S3method(rotate3d, default)
@@ -76,6 +79,10 @@ export(.check3d,
  S3method(persp3d, default)
  S3method(persp3d, "function")
  S3method(persp3d, deldir)
+ S3method(persp3d, tri)
+ S3method(persp3d, triSht)
+ S3method(persp3d, ashape3d)
+ S3method(persp3d, formula)
 
  S3method(plot3d, rglscene)
  S3method(plot3d, rglobject)
@@ -84,12 +91,19 @@ export(.check3d,
  S3method(plot3d, rglsubscene)
  S3method(plot3d, "function")
  S3method(plot3d, deldir)
+ S3method(plot3d, tri)
+ S3method(plot3d, triSht)
+ S3method(plot3d, ashape3d)
+ S3method(plot3d, formula)
+ S3method(plot3d, lm)
 
  S3method(print, rglscene)
  S3method(print, rglobject)
  S3method(print, rglsubscene)
  S3method(print, indexedSetter)
  S3method(print, rglId)
+ S3method(print, mesh3d)
+ S3method(print, shapelist3d)
 
  S3method(knit_print, rglId)
 
@@ -122,7 +136,8 @@ importFrom(htmltools, HTML, includeScript, tags, tagAppendAttributes,
 	   tagHasAttribute, tagList, browsable, resolveDependencies)
 importFrom(jsonlite, toJSON)
 importFrom(knitr, fig_path, hook_plot_custom, image_uri, knit_hooks, knit_print, opts_current, opts_knit)
-importFrom(shiny, getDefaultReactiveDomain, markRenderFunction)
+importFrom(shiny, getDefaultReactiveDomain, markRenderFunction, registerInputHandler)
 importFrom(magrittr, "%>%")
 importFrom(manipulateWidget, combineWidgets)
+importFrom(stats, coef, predict, residuals)
 

NAMESPACE

@@ -0,0 +1,82 @@
+arc3d <- function(from, to, center, radius, n, circle = 50, base = 0, plot = TRUE, ...) {
+  fixarg <- function(arg) {
+    if (is.matrix(arg))
+      arg[, 1:3, drop = FALSE]
+    else
+      matrix(arg, 1, 3)
+  }
+  normalize <- function(v)
+    v / veclen(v)
+  getrow <- function(arg, i) {
+    arg[1 + (i - 1) %% nrow(arg),]
+  }
+  from <- fixarg(from)
+  to <- fixarg(to)
+  center <- fixarg(center)
+
+  m <- max(nrow(from), nrow(to), nrow(center), length(base))
+  base <- rep_len(base, m)
+  
+  result <- matrix(NA_real_, nrow = 1, ncol = 3)
+  
+  for (j in seq_len(m)) {
+    from1 <- getrow(from, j)
+    to1 <- getrow(to, j)
+    center1 <- getrow(center, j)
+    base1 <- base[j]
+    logr1 <- log(veclen(from1 - center1))
+    logr2 <- log(veclen(to1 - center1))
+    A <- normalize(from1 - center1)
+    B <- normalize(to1 - center1)
+    steps <- if (base1 <= 0) 4*abs(base1) + 1 else 4*base1 - 1
+    for (k in seq_len(steps)) {
+      if (k %% 2) {
+        A1 <- A * (-1)^(k %/% 2)
+        B1 <- B * (-1)^(k %/% 2 + (base1 > 0))
+      } else {
+        A1 <- B * (-1)^(k %/% 2 + (base1 <= 0))
+        B1 <- A * (-1)^(k %/% 2)
+      }
+      theta <- acos(sum(A1*B1))
+      if (isTRUE(all.equal(theta, pi)))
+        warning("Arc ", j, " points are opposite each other!  Arc is not well defined.")
+      if (missing(n))
+        n1 <- ceiling(circle*theta/(2*pi))
+      else
+        n1 <- n
+      
+      if (missing(radius)) {
+        pretheta <- (k %/% 2)*pi - (k %% 2 == 0)*theta
+        if (k == 1)
+          totaltheta <- (steps %/% 2)*pi - (steps %% 2 == 0)*theta + theta
+        p1 <- pretheta/totaltheta
+        p2 <- (pretheta + theta)/totaltheta
+        radius1 <- exp(seq(from = (1 - p1)*logr1 + p1*logr2,
+                           to   = (1 - p2)*logr1 + p2*logr2,
+                           length.out = n1 + 1))
+      } else
+        radius1 <- rep_len(radius, n1)
+      arc <- matrix(NA_real_, nrow = n1 + 1, ncol = 3)
+      p <- seq(0, 1, length.out = n1 + 1)
+      arc[1,] <- center1 + radius1[1]*A1
+      arc[n1 + 1,] <- center1 + radius1[n1 + 1]*B1
+      AB <- veclen(A1 - B1)
+      for (i in seq_len(n1)[-1]) {
+        ptheta <- p[i]*theta
+        phi <- pi/2 + (0.5 - p[i])*theta
+        q <- (sin(ptheta) / sin(phi))/AB
+        D <- (1-q)*A1 + q*B1
+        arc[i,] <- center1 + radius1[i] * normalize(D)
+      }
+      if (k == 1)
+        result <- rbind(result, arc)
+      else
+        result <- rbind(result[-nrow(result), ,drop = FALSE], arc)
+    }
+    result <- rbind(result, result[1,])  
+  }
+  if (plot)
+    lines3d(result[c(-1, -nrow(result)), , drop = FALSE], ...)
+  else
+    result[c(-1, -nrow(result)), , drop = FALSE]
+}

R/arc3d.R

@@ -0,0 +1,107 @@
+# Support for objects from alphashape3d package
+
+persp3d.ashape3d <- function(x, ..., add = FALSE) {
+  plot3d(as.mesh3d(x, ...), add = add, ...)
+}
+
+plot3d.ashape3d <- function(x, ...) persp3d(x, ...)
+
+reOrient <- function(vertices) {
+  warned <- FALSE
+
+  # Count how many other triangles touch each edge of this one, in order 2-3, 1-3, 1-2:
+  edgeCounts <- function(index) {
+    triangle <- vertices[,index]
+    result <- integer(3)
+    for (i in 1:3) {
+      result[i] <- sum(apply(vertices, 2, function(col) all(triangle[-i] %in% col)))
+    }
+    result - 1
+  }
+  polys <- ncol(vertices)
+  verts <- nrow(vertices)
+  cols <- col(vertices)
+  fixed <- 0L
+  for (i in seq_len(polys - 1)) {
+    fixed <- max(i, fixed)
+    # Get all polygons touching polygon i
+    thistriangle <- vertices[,i]
+    if (any(is.na(thistriangle))) next
+    touches <- which(matrix(vertices %in% thistriangle,nrow=3),  arr.ind = TRUE)
+    if (!nrow(touches)) next
+    counts <- table(touches[,2L])
+    # Get col number of all polygons sharing an edge with i
+    shared <- as.numeric(names(counts)[counts > 1L])
+    shared <- shared[shared != i]
+    if (!length(shared)) next
+    otherverts <- vertices[, shared, drop=FALSE]
+    
+    # FIXME:  otherverts may include multiple triangles sharing the
+    #         same edge, because ashape3d sometimes embeds 
+    #         tetrahedrons (or larger polyhedra?) in the surfaces
+    #         it produces.  It doesn't appear to be safe to just 
+    #         delete these
+    
+    if (!warned && length(shared) > 1L && any( edgeCounts(i) > 1)) {
+      warning("Surface may not be simple; smoothing may not be possible.")
+      warned <- TRUE
+    }
+    
+    shared <- shared[shared > fixed]
+    if (!length(shared)) next
+    
+    otherverts <- vertices[, shared, drop=FALSE]
+    
+    for (m in seq_len(ncol(otherverts))) { # m is intersection number
+      # For each vertex in i, see if it is in the shared one, and
+      # if they have opposite orientations as we need
+      for (j in seq_len(verts)) {
+        # Where is j in the others?
+        jother <- which(otherverts[,m] == vertices[j,i])
+        if (!length(jother)) next
+        k <- j %% verts + 1L               # k follows j
+        kother <- jother  %% verts + 1L    # kother is entry following jother
+        if (vertices[k, i] == otherverts[kother, m]) {
+          otherverts[, m] <- rev(otherverts[, m])
+          break
+        }
+      }
+    }
+    # Now move all of shared to the front
+    unshared <- (fixed+1L):max(shared)
+    unshared <- unshared[!(unshared %in% shared)]
+    if (length(unshared))
+      vertices[, (fixed+length(shared)+1L):max(shared)] <- vertices[,unshared]
+    vertices[, fixed + seq_along(shared)] <- otherverts
+    fixed <- fixed + length(shared)
+  }
+  vertices
+}
+
+as.mesh3d.ashape3d <- function(x, alpha = x$alpha[1], 
+                               col = "gray", smooth = FALSE,
+                               normals = NULL, texcoords = NULL,
+                               ...) {
+  whichAlpha <- which(alpha == x$alpha)[1]
+  if (!length(whichAlpha))
+    stop("'alpha = ", alpha, "' not found in ", deparse(substitute(x)))
+  triangles <- x$triang
+  keep <- triangles[,8 + whichAlpha] > 1
+  triangs <- t(triangles[keep, 1:3])
+  points <- t(x$x)
+  if (!is.null(texcoords))
+    texcoords <- texcoords[triangs, ]
+  material <- .getMaterialArgs(...)
+  material$color <- col
+  result <- tmesh3d(points, triangs, homogeneous = FALSE,
+                    normals = normals, texcoords = texcoords,
+                    material = material)
+  if (smooth) {
+    if (is.null(normals)) {
+      result$it <- reOrient(result$it)
+      result <- addNormals(result)
+    } else
+      warning("smoothing ignored when 'normals' specified")
+  }
+  result 
+}

R/ashape3d.R

@@ -1,13 +1,14 @@
-rgl.setMouseCallbacks <- function(button, begin=NULL, update=NULL, end=NULL) {
-    invisible(.Call(rgl_setMouseCallbacks, as.integer(button), begin, update, end))
+rgl.setMouseCallbacks <- function(button, begin=NULL, update=NULL, end=NULL, dev = rgl.cur(), subscene = currentSubscene3d(dev)) {
+    invisible(.Call(rgl_setMouseCallbacks, as.integer(button), begin, update, end, 
+                    as.integer(dev), as.integer(subscene)))
 }
 
-rgl.getMouseCallbacks <- function(button) 
-    .Call(rgl_getMouseCallbacks, as.integer(button))
+rgl.getMouseCallbacks <- function(button, dev = rgl.cur(), subscene = currentSubscene3d(dev)) 
+    .Call(rgl_getMouseCallbacks, as.integer(button), as.integer(dev), as.integer(subscene))
 
-rgl.setWheelCallback <- function(rotate=NULL) {
-    invisible(.Call(rgl_setWheelCallback, rotate))
+rgl.setWheelCallback <- function(rotate=NULL, dev = rgl.cur(), subscene = currentSubscene3d(dev)) {
+    invisible(.Call(rgl_setWheelCallback, rotate, as.integer(dev), as.integer(subscene)))
 }
 
-rgl.getWheelCallback <- function() 
-    .Call(rgl_getWheelCallback)
+rgl.getWheelCallback <- function(dev = rgl.cur(), subscene = currentSubscene3d(dev)) 
+    .Call(rgl_getWheelCallback, as.integer(dev), as.integer(subscene))

R/callbacks.R

@@ -130,14 +130,17 @@ convertScene <- function(x = scene3d(), width = NULL, height = NULL, reuse = NUL
 
     result["is_smooth"] <- mat$smooth && type %in% c("triangles", "quads", "surface", "planes",
                  "spheres")
+
+    result["sprites_3d"] <- sprites_3d <- type == "sprites" && length(obj$ids)
 
-    result["has_texture"] <- has_texture <- !is.null(mat$texture) && !is.null(obj$texcoords)
+    result["has_texture"] <- has_texture <- !is.null(mat$texture) &&
+                                            (!is.null(obj$texcoords) 
+                                             || (type == "sprites" && !sprites_3d))
 
     result["is_transparent"] <- is_transparent <- (has_texture && mat$isTransparent) || any(obj$colors[,"a"] < 1)
 
     result["depth_sort"] <- depth_sort <- is_transparent && type %in% c("triangles", "quads", "surface",
                         "spheres", "sprites", "text")
-    result["sprites_3d"] <- sprites_3d <- type == "sprites" && length(obj$ids)
 
     result["fixed_quads"] <- type %in% c("text", "sprites") && !sprites_3d
     result["is_lines"]    <- type %in% c("lines", "linestrip", "abclines")

R/convertScene.R

@@ -31,7 +31,7 @@ rgl.enum.attribtype <- function (attrib)
 rgl.enum( attrib, vertices=1, normals=2, colors=3, texcoords=4, dim=5, 
           texts=6, cex=7, adj=8, radii=9, centers=10, ids=11, 
           usermatrix=12, types=13, flags=14, offsets=15,
-	  family=16, font=17)
+	        family=16, font=17, pos=18)
 
 rgl.enum.pixfmt <- function (fmt)
 rgl.enum( fmt, png=0 )

R/enum.R

@@ -22,7 +22,7 @@ scene3d <- function() {
     attribs <- c("vertices", "normals", "colors", "texcoords", "dim",
           "texts", "cex", "adj", "radii", "ids",
           "usermatrix", "types", "offsets", "centers",
-          "family", "font")
+          "family", "font", "pos")
     for (a in attribs) 
       if (rgl.attrib.count(id, a))
         result[[a]] <- rgl.attrib(id, a)

R/getscene.R

@@ -24,7 +24,7 @@ grid3d <- function (side, at = NULL, col="gray",
     at[[coord]] <- NULL
   }
 
-  result <- c()
+  result <- integer()
 
   for (cside in sides) {
     range <- ranges[[cside]]
@@ -53,8 +53,8 @@ grid3d <- function (side, at = NULL, col="gray",
       mpos1 <- temp1
       mpos2 <- temp2
     }
-      
-    result[sidenames[cside]] <- segments3d(x=c(rbind(mpos1[,1],mpos2[,1])),
+    if (nrow(mpos1) + nrow(mpos2) > 0)
+      result[sidenames[cside]] <- segments3d(x=c(rbind(mpos1[,1],mpos2[,1])),
                y=c(rbind(mpos1[,2],mpos2[,2])),
                z=c(rbind(mpos1[,3],mpos2[,3])),
                lwd=lwd,color=col)