version 0.110.2

Author: dmurdoch

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: rgl
-Version: 0.109.6
+Version: 0.110.2
 Title: 3D Visualization Using OpenGL
 Authors@R: c(person("Duncan", "Murdoch", role = c("aut", "cre"),
                      email = "murdoch.duncan@gmail.com"),
@@ -51,9 +51,9 @@ SystemRequirements: OpenGL and GLU Library (Required for display in R.
 BugReports: https://github.com/dmurdoch/rgl/issues
 VignetteBuilder: knitr, rmarkdown
 Biarch: true
-RoxygenNote: 7.1.2
+RoxygenNote: 7.2.0
 NeedsCompilation: yes
-Packaged: 2022-07-07 23:44:06 UTC; murdoch
+Packaged: 2022-09-05 13:37:46 UTC; murdoch
 Author: Duncan Murdoch [aut, cre],
   Daniel Adler [aut],
   Oleg Nenadic [ctb],
@@ -78,4 +78,4 @@ Author: Duncan Murdoch [aut, cre],
   Mike Stein [ctb]
 Maintainer: Duncan Murdoch <murdoch.duncan@gmail.com>
 Repository: CRAN
-Date/Publication: 2022-07-08 23:30:02 UTC
+Date/Publication: 2022-09-26 12:10:03 UTC

MD5

@@ -181,7 +181,7 @@ export(rglwidget, renderRglwidget, rglwidgetOutput,
 
 importFrom(htmlwidgets, createWidget, prependContent, saveWidget, 
            shinyRenderWidget, shinyWidgetOutput, sizingPolicy)
-importFrom(htmltools, css, HTML, htmlDependency, img,
+importFrom(htmltools, css, HTML, htmlDependency, htmlPreserve, img,
            includeScript, tags, tagAppendAttributes,
 	   tagHasAttribute, tagList, browsable, resolveDependencies)
 importFrom(jsonlite, toJSON, base64_dec)

NAMESPACE

@@ -1,3 +1,53 @@
+
+# rgl 0.110.2
+
+## Major changes
+
+* Material property `"blend"` has been added, to allow
+various kinds of blending for semi-transparent objects
+(issue #245).
+
+## Minor changes
+
+* The `Buffer` object now handles reading of sparse
+accessors.
+* Low level drawing of primitives has been made more
+memory efficient.  This is only likely to make a 
+noticeable change with very large objects, where R
+was running out of memory because of unnecessary
+duplication. (Related to issue #260.)
+* Recycling of x, y and z vectors in several functions
+is more consistent.
+* The `polygon3d()` function now chooses coordinates
+automatically, as `triangulate()` does (PR #262.)
+* The `mtext3d()` and related functions such as
+`title3d()' now accept language objects
+other than expressions, as `plotmath3d()` always has 
+(issue #273).
+
+## Bug fixes
+
+* The bounding box could be calculated incorrectly
+if data all had large values (issue #250).
+* Shiny displays failed to load the shaders (issue #249).
+* `transform3d()` failed due to missing argument (issue #253).
+* `readOBJ()` is now more flexible in what kinds of
+separators it will accept. (issue #258).
+* Failure to initialize could cause a segfault.
+* On non-macOS platforms, gray-scale textures failed
+to display, with a message about an invalid enumerant.
+* The third coordinate for `adj` that was added in 0.108.3
+was not rendered properly in `rglwidget()` displays of
+text.  This sometimes caused text to disappear when it
+was near the far limit of the display (issue #269).
+* The X11 error fix in 0.109.6 could result in R
+freezing in `Rcmdr`.
+* Low level drawing functions are now more consistent
+about returning an invisible `NULL` if asked to plot zero
+items, rather than raising an error or crashing (issue #274).
+* Calling `axis3d()` with no ticks or labels no longer triggers
+an error, it now silently returns `NULL`.
+
 # rgl  0.109.6
 
 ## Minor changes

NEWS.md

@@ -10,10 +10,7 @@ as.mesh3d.default <- function(x, y = NULL, z = NULL,
     x <- rglId(ids3d()$id)
     return(as.mesh3d(x, ...))
   }
-  xyz <- xyz.coords(x, y, z, recycle = TRUE)
-  x <- xyz$x
-  y <- xyz$y
-  z <- xyz$z
+  verts <- rgl.vertex(x, y, z)
   if (!missing(triangles)) {
     warning("Argument 'triangles' is deprecated; please use 'type' instead.")
     if (missing(type)) {
@@ -25,7 +22,7 @@ as.mesh3d.default <- function(x, y = NULL, z = NULL,
   }
   type <- match.arg(type, several.ok = TRUE)
   pcs <- c(triangles = 3, quads = 4, segments = 2, points = 1)
-  nvert <- length(x)
+  nvert <- ncol(verts)
   okay <- FALSE
   for (i in seq_along(type)) {
     if (nvert %% pcs[type[i]] == 0) {
@@ -36,8 +33,7 @@ as.mesh3d.default <- function(x, y = NULL, z = NULL,
   if (okay) type <- type[i]
   else stop("Wrong number of vertices")
 
-  verts <- rbind(x, y, z)
-  indices <- matrix(seq_along(x), nrow = pcs[type])
+  indices <- matrix(seq_len(nvert), nrow = pcs[type])
   if (merge) {
     if (!is.null(notEqual)) {
       dim <- dim(notEqual)
@@ -46,7 +42,7 @@ as.mesh3d.default <- function(x, y = NULL, z = NULL,
       notEqual <- notEqual | t(notEqual) # Make it symmetric
     } else
       notEqual <- matrix(FALSE, nvert, nvert)
-    o <- order(x, y, z)
+    o <- order(verts[1,], verts[2,], verts[3,])
     i1 <- seq_len(nvert)[o]
     for (i in seq_len(nvert)[-1]) {
       if (isTRUE(all.equal(verts[,i1[i-1]], verts[,i1[i]], tolerance = tolerance))

R/as.mesh3d.default.R

@@ -46,42 +46,43 @@ axis3d <- function(edge, at = NULL, labels = TRUE, tick = TRUE, line = 0,
     at <- pretty(range, nticks)
     at <- at[at >= range[1] & at <= range[2]]
   }
-  
-  if (is.logical(labels)) {
-    if (labels) labels <- format(at)
-    else labels <- NA
-  }
-  
-  mpos <- matrix(NA,3,length(at))
-  if (edge[1] == '+') mpos[1,] <- ranges$x[2]
-  else mpos[1,] <- ranges$x[1]
-  if (edge[2] == '+') mpos[2,] <- ranges$y[2]
-  else mpos[2,] <- ranges$y[1]
-  if (edge[3] == '+') mpos[3,] <- ranges$z[2]
-  else mpos[3,] <- ranges$z[1]
-  
-  ticksize <- 0.05*(mpos[,1]-c(mean(ranges$x),mean(ranges$y),mean(ranges$z)))
-  ticksize[coord] <- 0
-  
-  if (!is.null(pos)) mpos <- matrix(pos,3,length(at))
-  mpos[coord,] <- at
-  
-  x <- c(mpos[1,1],mpos[1,length(at)])
-  y <- c(mpos[2,1],mpos[2,length(at)])
-  z <- c(mpos[3,1],mpos[3,length(at)])
-  if (tick) {
-    x <- c(x,as.double(rbind(mpos[1,],mpos[1,]+ticksize[1])))
-    y <- c(y,as.double(rbind(mpos[2,],mpos[2,]+ticksize[2])))
-    z <- c(z,as.double(rbind(mpos[3,],mpos[3,]+ticksize[3])))
+  if (length(at)) {
+    if (is.logical(labels)) {
+      if (labels) labels <- format(at)
+      else labels <- NA
+    }
+    
+    mpos <- matrix(NA,3,length(at))
+    if (edge[1] == '+') mpos[1,] <- ranges$x[2]
+    else mpos[1,] <- ranges$x[1]
+    if (edge[2] == '+') mpos[2,] <- ranges$y[2]
+    else mpos[2,] <- ranges$y[1]
+    if (edge[3] == '+') mpos[3,] <- ranges$z[2]
+    else mpos[3,] <- ranges$z[1]
+    
+    ticksize <- 0.05*(mpos[,1]-c(mean(ranges$x),mean(ranges$y),mean(ranges$z)))
+    ticksize[coord] <- 0
+    
+    if (!is.null(pos)) mpos <- matrix(pos,3,length(at))
+    mpos[coord,] <- at
+    
+    x <- c(mpos[1,1],mpos[1,length(at)])
+    y <- c(mpos[2,1],mpos[2,length(at)])
+    z <- c(mpos[3,1],mpos[3,length(at)])
+    if (tick) {
+      x <- c(x,as.double(rbind(mpos[1,],mpos[1,]+ticksize[1])))
+      y <- c(y,as.double(rbind(mpos[2,],mpos[2,]+ticksize[2])))
+      z <- c(z,as.double(rbind(mpos[3,],mpos[3,]+ticksize[3])))
+    }
+    result <- c(ticks=segments3d(x,y,z,...))
+    
+    if (!all(is.na(labels)))
+      result <- c(result, labels=text3d(mpos[1,]+3*ticksize[1],
+                                        mpos[2,]+3*ticksize[2],
+                                        mpos[3,]+3*ticksize[3],
+                                        labels, ...))
+    lowlevel(result)
   }
-  result <- c(ticks=segments3d(x,y,z,...))
-  
-  if (!all(is.na(labels)))
-    result <- c(result, labels=text3d(mpos[1,]+3*ticksize[1],
-                                      mpos[2,]+3*ticksize[2],
-                                      mpos[3,]+3*ticksize[3],
-                                      labels, ...))
-  lowlevel(result)
 }
 
 axes3d <- function(edges='bbox', labels=TRUE,
@@ -182,6 +183,9 @@ mtext3d <- function(text, edge, at = NULL, line = 0,
 
   ranges <- .getRanges()
 
+  if (is.language(text))
+    text <- as.expression(text)
+  
   newlen <- max(length(text),length(line),length(at))
   text <- rep(text, length.out = newlen)
   line <- rep(line, length.out = newlen)

R/axes.R

@@ -328,14 +328,29 @@ Buffer <- R6Class("Buffer",
         private$accessors[[acc + 1]] <- unclass(accessor),
 
 #' @description
-#'   Read data given by accessor object.
+#'   Read data given by accessor number.
 #'
 #' @param acc Accessor number.
 #'
 #' @return A vector or array as specified in the accessor.  For the `MATn` types, the 3rd index
 #' indexes the element.
 #'
-      readAccessor = function(acc) {
+   readAccessor = function(acc) {
+     if (acc + 1 > length(private$accessors))
+       stop("No such accessor")
+     accessor <- self$getAccessor(acc)
+     self$readAccessor0(accessor)
+   },
+
+#' @description
+#'   Read data given by accessor object.
+#'
+#' @param accessor Accessor object
+#'
+#' @return A vector or array as specified in the accessor.  For the `MATn` types, the 3rd index
+#' indexes the element.
+#'
+      readAccessor0 = function(accessor) {
         typenames <- c("5120" = "byte", "5121" = "unsigned_byte",
                        "5122" = "short", "5123" = "unsigned_short",
                        "5125" = "unsigned_int", "5126" = "float")
@@ -351,43 +366,62 @@ Buffer <- R6Class("Buffer",
                      "5126" = TRUE)
         lens <- c(SCALAR = 1, VEC2 = 2, VEC3 = 3, VEC4 = 4,
                   MAT2 = 4, MAT3 = 9, MAT4 = 16)
-        if (acc + 1 > length(private$accessors))
-          stop("No such accessor")
-        accessor <- self$getAccessor(acc)
-        view <- self$getBufferview(accessor$bufferView)
-        con <- self$openBufferview(accessor$bufferView)
         ctype <- as.character(accessor$componentType)
         atype <- accessor$type
         type <- types[ctype]
         len <- lens[atype]
         size <- sizes[ctype]
         signed <- signeds[ctype]
         count <- accessor$count
-        if (is.null(view$byteStride)) {
-          skip <- 0
-        } else
-          skip <- len*size - view$byteStride
-        if (is.null(byteOffset <- accessor$byteOffset))
-          byteOffset <- 0
-        start <- seek(con) + byteOffset
-
-        if (skip == 0) {
-          seek(con, start)
-          values <- readBin(con, type, n = len*count,  size = size,
-                            signed = signed, endian = "little")
+        if (is.null(accessor$bufferView)) {
+          values <- numeric(count*len) # initialized to zero
         } else {
-          values <- numeric(count*len)
-          for (i in seq_len(count)) {
-            seek(con, start + (i-1)*view$byteStride)
-            values[(i-1)*len + seq_len(len)] <-
-              readBin(con, type, n = len,  size = size,
+          view <- self$getBufferview(accessor$bufferView)
+          con <- self$openBufferview(accessor$bufferView)
+          if (is.null(view$byteStride)) {
+            skip <- 0
+          } else
+            skip <- len*size - view$byteStride
+          if (is.null(byteOffset <- accessor$byteOffset))
+            byteOffset <- 0
+          start <- seek(con) + byteOffset
+
+          if (skip == 0) {
+            seek(con, start)
+            values <- readBin(con, type, n = len*count,  size = size,
+                              signed = signed, endian = "little")
+          } else {
+            values <- numeric(count*len)
+            for (i in seq_len(count)) {
+              seek(con, start + (i-1)*view$byteStride)
+              values[(i-1)*len + seq_len(len)] <-
+                readBin(con, type, n = len,  size = size,
                       signed = signed, endian = "little")
+            }
+          }
+          if (ctype == "5125") { # fix up unsigned integers
+            values[is.na(values)] <- 2^31
+            values[values < 0] <- values[values < 0] + 2^32
           }
         }
-        if (ctype == "5125") { # fix up unsigned integers
-          values[is.na(values)] <- 2^31
-          values[values < 0] <- values[values < 0] + 2^32
+        if (!is.null(sparse <- accessor$sparse)) {
+          indexobj <- sparse$indices
+          indexobj$type <- "SCALAR"
+          indexobj$count <- sparse$count
+          index <- self$readAccessor0(indexobj)
+          
+          valueobj <- sparse$values
+          valueobj$type <- "SCALAR"
+          valueobj$componentType <- accessor$componentType
+          valueobj$count <- len*sparse$count
+          newvalues <- self$readAccessor0(valueobj)
+          
+          for (i in seq_len(sparse$count)) 
+            for (j in seq_len(len))
+              values[len*index[i] + j] <-
+                newvalues[len*(i-1) + j]
         }
+        
         if (!is.null(accessor$normalized) && accessor$normalized)
           values <- switch(ctype,
                            "5120" = (values + 128)/255 - 1, # byte

R/buffer.R

@@ -63,3 +63,13 @@ rgl.enum(component, red=0, green=1, blue=2, alpha=3, depth=4, luminance=5)
 rgl.enum.depthtest <- function(depthtest)
 rgl.enum(depthtest, never=0, less=1, equal=2, lequal=3, greater=4, 
                     notequal=5, gequal=6, always= 7)
+
+rgl.enum.blend <- function(blend)
+rgl.enum(blend, zero=0, one=1, 
+         src_color=2, one_minus_src_color=3, 
+         dst_color=4, one_minus_dst_color=5,
+         src_alpha=6, one_minus_src_alpha=7,
+         dst_alpha=8, one_minus_dst_alpha=9,
+         constant_color=10, one_minus_constant_color=11,
+         constant_alpha=12, one_minus_constant_alpha=13,
+         src_alpha_saturate=14)

R/enum.R

@@ -71,8 +71,10 @@ rgl.string <- function( x ) {
 # vertex data object
 #
 
-rgl.vertex <- function(x,y=NULL,z=NULL) {
-  xyz <- xyz.coords(x,y,z,recycle=TRUE)
+rgl.vertex <- function(x, y = NULL, z = NULL) {
+  xyz <- xyz.coords(x, y, z, recycle=TRUE)
+  # This is not the same as just rbind(xyz$x,xyz$y,xyz$z)!
+  # xyz.coords puts all of named vector x into xyz$x
   return( matrix( rbind(xyz$x,xyz$y,xyz$z), nrow=3, dimnames=list( c("x","y","z"), NULL ) ) )
 }