version 0.104.16

Author: dmurdoch

DESCRIPTION

@@ -1,15 +1,15 @@
 Package: rgl
-Version: 0.103.5
+Version: 0.104.16
 Title: 3D Visualization Using OpenGL
 Author: Daniel Adler <dadler@uni-goettingen.de>, Duncan Murdoch <murdoch.duncan@gmail.com>, and others (see README)
 Maintainer: Duncan Murdoch <murdoch.duncan@gmail.com>
-Depends: R (>= 4.0.0)
+Depends: R (>= 3.2.0)
 Suggests: MASS, rmarkdown, deldir, orientlib, lattice, misc3d,
         rstudioapi, magick, plotrix (>= 3.7-3), tripack, interp,
         alphashape3d, tcltk, js (>= 1.2), akima
 Imports: graphics, grDevices, stats, utils, htmlwidgets, htmltools,
         knitr, jsonlite (>= 0.9.20), shiny, magrittr, crosstalk,
-        manipulateWidget (>= 0.9.0), mathjaxr
+        manipulateWidget (>= 0.9.0)
 Description: Provides medium to high level functions for 3D interactive graphics, including
     functions modelled on base graphics (plot3d(), etc.) as well as functions for
     constructing representations of geometric objects (cube3d(), etc.).  Output
@@ -18,14 +18,11 @@ Description: Provides medium to high level functions for 3D interactive graphics
 License: GPL
 URL: https://r-forge.r-project.org/projects/rgl/
 SystemRequirements: OpenGL, GLU Library, XQuartz (on OSX), zlib
-        (optional on Unix, required on Windows), libpng (>=1.2.9,
-        optional on Unix, required on Windows), FreeType (optional on
-        Unix, required on Windows), pandoc (>=1.14, needed for
-        vignettes)
+        (optional), libpng (>=1.2.9, optional), FreeType (optional),
+        pandoc (>=1.14, needed for vignettes)
 BugReports: https://r-forge.r-project.org/projects/rgl/
 VignetteBuilder: knitr
-RdMacros: mathjaxr
 NeedsCompilation: yes
-Packaged: 2020-11-19 00:52:36 UTC; murdoch
+Packaged: 2021-01-09 01:07:36 UTC; murdoch
 Repository: CRAN
-Date/Publication: 2020-11-23 15:00:02 UTC
+Date/Publication: 2021-01-10 17:10:13 UTC

MD5

@@ -30,10 +30,12 @@ export(.check3d,
 	rgl.viewpoint, rgl.window2user, 
 	rglFonts, rglId, rglMouse, rglShared, rglToLattice, rglToBase,
   r3dDefaults, rotate3d, rotationMatrix,
-	scale3d, scaleMatrix, scene3d, segments3d, select3d, selectpoints3d,
+	scale3d, scaleMatrix, scene3d, segments3d, 
+	select3d, selectionFunction3d, selectpoints3d,
 	rgl.setMouseCallbacks, rgl.setWheelCallback, set3d, 
 	setGraphicsDelay, setupKnitr, setUserShaders, shade3d, 
-	shapelist3d, shinyGetPar3d, shinySetPar3d, show2d, snapshot3d, 
+	shapelist3d, shinyGetPar3d, shinySetPar3d, shinyResetBrush, 
+	show2d, snapshot3d, 
 	spheres3d, spin3d, sprites3d, subdivision3d, 
 	subsceneInfo, subsceneList, subsetSetter, subsetSlider, Sweave.snapshot,
 	surface3d, terrain3d, 
@@ -116,10 +118,13 @@ export(.check3d,
  S3method(print, rglsubscene)
  S3method(print, indexedSetter)
  S3method(print, rglId)
+ S3method(print, rglOpen3d)
  S3method(print, mesh3d)
  S3method(print, shapelist3d)
+ S3method(print, rglMouseSelection)
 
  S3method(knit_print, rglId)
+ S3method(knit_print, rglOpen3d)
 
  S3method(summary, rglscene)
  S3method(summary, rglsubscene)

NAMESPACE

@@ -24,7 +24,8 @@ rgl.Sweave <- function(name, width, height, options, ...) {
   } 
 
   snapshotDone <- FALSE
-
+  
+  # stayOpen is used below in rgl.Sweave.off
   stayOpen <- isTRUE(options$stayopen)
 
   type <- options$outputtype
@@ -217,7 +218,7 @@ withPrivateSeed <- local({
       # Need to call this to make sure that the value of .Random.seed gets put
       # into R's internal RNG state. (Issue #1763)
 
-      # httpuv::getRNGState()
+      # httpuv::getRNGState() # nolint
     })
 
     expr
@@ -287,6 +288,14 @@ fns <- local({
       }
   }  
 
+  knit_print.rglOpen3d <- function(x, options, ...) {
+    print(x, ...)
+    if (getOption("rgl.printRglwidget", FALSE)) {
+      plotnum <<- plotnum + 1
+    }
+    invisible(x)
+  }
+  
   knit_print.rglId <- function(x, options, ...) {
     if (getOption("rgl.printRglwidget", FALSE))	{
       scene <- scene3d()
@@ -312,16 +321,16 @@ fns <- local({
     }, logical(1))
 
   # move plots before source code
-  fig_before_code = function(x) {
-    s = vapply(x, evaluate::is.source, logical(1))
+  fig_before_code <- function(x) {
+    s <- vapply(x, evaluate::is.source, logical(1))
     if (length(s) == 0 || !any(s)) return(x)
-    s = which(s)
-    f = which(find_figs(x))
-    f = f[f >= min(s)]  # only move those plots after the first code block
+    s <- which(s)
+    f <- which(find_figs(x))
+    f <- f[f >= min(s)]  # only move those plots after the first code block
     for (i in f) {
-      j = max(s[s < i])
-      tmp = x[i]; x[[i]] = NULL; x = append(x, tmp, j - 1)
-      s = which(vapply(x, evaluate::is.source, logical(1)))
+      j <- max(s[s < i])
+      tmp <- x[i]; x[[i]] <- NULL; x <- append(x, tmp, j - 1)
+      s <- which(vapply(x, evaluate::is.source, logical(1)))
     }
     x
   }
@@ -439,8 +448,8 @@ fns <- local({
   # These functions are closely based on code from knitr:
 
   # compare two recorded plots
-  is_low_change = function(p1, p2) {
-    p1 = p1[[1]]; p2 = p2[[1]]  # real plot info is in [[1]],
+  is_low_change <- function(p1, p2) {
+    p1 <- p1[[1]]; p2 <- p2[[1]]  # real plot info is in [[1]],
                                 # as is plotnum
     if (length(p2) < (n1 <- length(p1))) return(FALSE)  # length must increase
     identical(p1[1:n1], p2[1:n1])
@@ -452,9 +461,9 @@ fns <- local({
     i1 <- idx[1]; i2 <- idx[2]  # compare plots sequentially
     for (i in 1:(n - 1)) {
       # remove the previous plot and move its index to the next plot
-      if (is_low_change(x[[i1]], x[[i2]])) m = c(m, i1)
-      i1 = idx[i + 1]
-      i2 = idx[i + 2]
+      if (is_low_change(x[[i1]], x[[i2]])) m <- c(m, i1)
+      i1 <- idx[i + 1]
+      i2 <- idx[i + 2]
     }
     if (is.null(m)) x else x[-m]
   }
@@ -464,7 +473,8 @@ fns <- local({
        hook_figkeep = hook_figkeep,
        hook_figshow = hook_figshow,
        hook_figbeforecode = hook_figbeforecode,
-       knit_print.rglId = knit_print.rglId)
+       knit_print.rglId = knit_print.rglId,
+       knit_print.rglOpen3d = knit_print.rglOpen3d)
 })
 
 setupKnitr <- fns[["setupKnitr"]]
@@ -473,6 +483,7 @@ hook_figkeep <- fns[["hook_figkeep"]]
 hook_figshow <- fns[["hook_figshow"]]
 hook_figbeforecode <- fns[["hook_figbeforecode"]]
 knit_print.rglId <- fns[["knit_print.rglId"]]
+knit_print.rglOpen3d <- fns[["knit_print.rglOpen3d"]]
 rm(fns)
 
 figWidth <- function() 

R/Sweave_knitr.R

@@ -1,45 +1,53 @@
 addNormals <- function(x, ...) UseMethod("addNormals")
 
-addNormals.mesh3d <- function(x, ...) {
+addNormals.mesh3d <- function(x, angleWeighted = TRUE, ...) {
   v <- x$vb
 
   # Make sure v is homogeneous with unit w
   if (nrow(v) == 3) v <- rbind(v, 1)
   else v <- t( t(v)/v[4,] )
 
-  normals <- v*0
   v <- v[1:3,]
+  normals <- v*0
 
-  if (length(x$it)) {
-    it <- x$it
-    for (i in 1:ncol(it)) {
-      normal <- normalize(xprod( v[, it[1, i]] - v[, it[3, i]], 
-                                 v[, it[2, i]] - v[, it[1, i]]))
-      if (!any(is.na(normal)))
-        for (j in 1:3) {
-          if (sum(normals[1:3, it[j,i]]*normal) < 0)
-      	    normals[, it[j,i]] <- normals[, it[j,i]] + c(-normal, 1)
-      	  else
-            normals[, it[j,i]] <- normals[, it[j,i]] + c(normal, 1)
-        }
-    }
-  }
+  if (is.na(angleWeighted)) {
+    reproduceBug <- TRUE
+    angleWeighted <- FALSE
+  } else
+    reproduceBug <- FALSE
 
-  if (length(x$ib)) {
-    it <- x$ib
-    for (i in 1:ncol(it)) {
-      normal <- normalize(xprod( v[, it[1, i]] - v[, it[4, i]],
-                                 v[, it[2, i]] - v[, it[1, i]]))
-      if (!any(is.na(normal)))
-        for (j in 1:4) {
-      	  if (sum(normals[1:3, it[j,i]]*normal) < 0)
-      	    normals[, it[j,i]] <- normals[, it[j,i]] + c(-normal, 1)
-      	  else
-            normals[, it[j,i]] <- normals[, it[j,i]] + c(normal, 1)
+  dopolys <- function(it, normals) {
+    n <- nrow(it)
+    for (i in seq_len(ncol(it))) {
+      normal <- xprod( v[, it[1, i]] - v[, it[3, i]], 
+                       v[, it[2, i]] - v[, it[1, i]])
+      if (reproduceBug)
+        normal <- normalize(normal)
+      if (!any(is.na(normal))) {
+        if (angleWeighted) 
+          normal <- normalize(normal)
+        
+        for (j in seq_len(n)) {
+          if (angleWeighted) {
+            jm1 <- (j + n - 2) %% n + 1
+            jp1 <- j %% n + 1
+            weight <- angle(v[, it[jm1, i]] - v[, it[j, i]],
+                           v[, it[jp1, i]] - v[, it[j, i]])
+          } else
+            weight <- 1
+          normals[, it[j,i]] <- normals[, it[j,i]] + normal*weight
         }
+      }
     }
+    normals
   }
-  normals <- t( t(normals)/normals[4,] )
+  
+  if (length(x$it)) 
+    normals <- dopolys(x$it, normals)
+  
+  if (length(x$ib)) 
+    normals <- dopolys(x$ib, normals)
+  normals <- rbind(apply(normals, 2, function(n) n/veclen(n)), 1)
   x$normals <- normals
   x
 }
@@ -51,3 +59,8 @@ normalize <- function(v) v/veclen(v)
 xprod <- function(v, w) c( v[2]*w[3] - v[3]*w[2],
                            v[3]*w[1] - v[1]*w[3],
                            v[1]*w[2] - v[2]*w[1] )
+
+angle <- function(a,b) {
+  dot <- sum(a*b)
+  acos(dot/veclen(a)/veclen(b))
+}

R/addNormals.mesh3d.R

@@ -31,7 +31,7 @@ toRotmatrix <- function(x) {
 
 par3dinterp <- function(times=NULL, userMatrix, scale, zoom, FOV, method=c("spline", "linear"), 
                      extrapolate = c("oscillate","cycle","constant", "natural"),
-                     dev = cur3d(), subscene = par3d("listeners", dev = dev)) {  
+                     dev = cur3d(), subscene = par3d("listeners", dev = dev)) {
     force(dev)
     force(subscene)
 
@@ -197,7 +197,7 @@ movie3d <- function(f, duration, dev = cur3d(), ..., fps=10,
         rgl.snapshot(filename=filename, fmt="png", top=top)
     }	
     cat("\n")
-    if (.Platform$OS.type == "windows") system <- shell
+    if (.Platform$OS.type == "windows") system <- shell  # nolint
     if (is.null(convert) && requireNamespace("magick")) {
     	m <- NULL
     	for (i in round(startTime*fps):(duration*fps)) {
@@ -249,4 +249,3 @@ movie3d <- function(f, duration, dev = cur3d(), ..., fps=10,
     }
     invisible(convert)
 }
-

R/animate.R

@@ -8,7 +8,7 @@ arrow3d <- function(p0=c(1,1,1), p1=c(0,0,0), barblen, s=1/3, theta=pi/12,
 		     width = 1/3, 
 		     thickness = 0.618*width,
 		     spriteOrigin = NULL, 
-		     plot = TRUE, ...){
+		     plot = TRUE, ...) {
  ##      p0: start point
  ##      p1: end point
  ## barblen: length of barb
@@ -56,8 +56,7 @@ arrow3d <- function(p0=c(1,1,1), p1=c(0,0,0), barblen, s=1/3, theta=pi/12,
  r <- gs[2,]
 
  ## now compute the barb end points and draw:
- pts = list()
- for(i in 1:length(phi)){
+ for(i in seq_along(phi)) {
    ptb <- rotate3d(r,phi[i],(p1-p0)[1],(p1-p0)[2],(p1-p0)[3])
    xyz <- rbind(xyz, p1, cpt + barblen*sin(theta)*ptb)
  }

R/arrow3d.R

@@ -20,7 +20,6 @@ reOrient <- function(vertices) {
   }
   polys <- ncol(vertices)
   verts <- nrow(vertices)
-  cols <- col(vertices)
   fixed <- 0L
   for (i in seq_len(polys - 1)) {
     fixed <- max(i, fixed)

R/ashape3d.R

@@ -60,7 +60,7 @@ ticklabel RGLScale(real s)
   }
 
   # simulate rgl.attrib
-  get.attrib <- function(id, attrib) { 
+  get.attrib <- function(id, attrib) {
     obj <- scene$objects[[as.character(id)]]
     obj[[attrib]]
   }
@@ -144,7 +144,7 @@ ticklabel RGLScale(real s)
 
   writePoly <- function(vertices) {
     if (any(!is.finite(vertices)))
-      return();
+      return()
     setPen(apply(vertices[, rgba], 2, mean))
     v <- vertices[1, 1:3]
     result <<- c(result, subst('draw(surface((%x%, %y%, %z%)', x=v[1], y=v[2], z=v[3]))
@@ -246,7 +246,6 @@ ticklabel RGLScale(real s)
     setPen(size = getmaterial(id)$lwd)          
     vertices <- getVertices(id)
     n <- nrow(vertices)    
-    inds <- seq_len(n)
     open <- FALSE
     for (i in seq_len(n)) {
       if (open) {
@@ -261,7 +260,7 @@ ticklabel RGLScale(real s)
       	  setPen(vertices[i, rgba])
       	  result <<- c(result, subst('draw((%x%, %y%, %z%)',
       	    x = vertices[i, 1], y = vertices[i, 2], z = vertices[i, 3]))
-      	  open = TRUE
+      	  open <- TRUE
       	}
     }
     if (open)
@@ -445,7 +444,7 @@ ticklabel RGLScale(real s)
       text = writeText(ids[i]),
       background = writeBackground(ids[i]),
       bboxdeco = writeBBox(ids[i]),
-      light = {}
+      light = {} # nolint
     )
   }
   if (outtype %in% c("latex", "pdflatex")) {