R/render-webgl.R

In shinyRGL: Shiny Wrappers for RGL

#' Render a WebGL Element
#' 
#' Render a WebGL Shiny output.
#' @param expr The expression to be evaluated which should produce a rgl scene.
#' @param width Either "auto", in which case the width will be calculated
#'   (reactively) based on the size of the glOutput element associated with this
#'   function, or a numeric value representing the width of the desired WebGL
#'   scene in pixels.
#' @param height The height of the WebGL scene. See \code{width} for details.
#' @param env The environment in which \code{expr} should be evaluated.
#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
#'   is useful if you want to save an expression in a variable.
#' @importFrom rgl open3d
#' @importFrom rgl bg3d
#' @importFrom rgl rgl.close
#' @importFrom rgl writeWebGL
#' @importFrom rgl par3d
#' @importFrom shiny exprToFunction
#' @importFrom shiny HTML
#' @importFrom shiny isolate
#' @author Jeff Allen \email{jeff@@trestletech.com}
#' @examples \dontrun{ 
#'    renderWebGL({
#'      points3d(1:10,1:10,1:10)
#'    })
#' }
#' @export
renderWebGL <- function(expr, width="auto", height="auto", env = parent.frame(), 
                     quoted = FALSE){
  func <- exprToFunction(expr, env, quoted)
  return(function(shinysession, name, ...) {
    #Open a null RGL device.
    open3d(useNULL = TRUE)    
    func()
    prefix <- "gl_output_"
    
    # Read in WebGL's width and height from the browser
    if (width == "auto") width <- shinysession$clientData[[paste(prefix, 
                                                    name, "_width", sep = "")]]
    if (height == "auto") height <- shinysession$clientData[[paste(prefix, 
                                                    name, "_height", sep = "")]]
    
    
    if (is.null(width) || is.null(height) || width <= 0 || 
          height <= 0) return(NULL)
    
    if (is.null(width) || !is.numeric(width)){
      stop("Can't support non-numeric width parameter. 'width' must be in px.")
    }
    
    if (is.null(height) || !is.numeric(height)){
      stop("Can't support non-numeric height parameter. 'height' must be in px.")
    }
    
    # Read in current values as they're updated so that we can regenerate 
    # the graph honoring the user's changes to the view, but isolate() so we
    # don't force a new graph every time the user interacts with it.
    zoom <- 
      isolate(shinysession$clientData[[paste(prefix, name, "_zoom", sep="")]])
    fov <- 
      isolate(shinysession$clientData[[paste(prefix, name, "_fov", sep="")]])
    pan <- 
      isolate(shinysession$clientData[[paste(prefix, name, "_pan", sep="")]])
    
    if (!is.null(zoom)){
      par3d(zoom = zoom)  
    }
    if (!is.null(fov)){
      par3d(FOV=fov)
    }
    if (!is.null(pan)){
      mat <- matrix(pan, ncol=4)
      par3d(userMatrix=mat)
    }
        
    #generate a random 10 character sequence to represent this file
    id <- paste(sample(c(letters, LETTERS), 10), collapse="")  
    tempDir <- paste(tempdir(), "/", id, "/", sep="")
    
    # Write out a template file containing the prefix.
    # TODO: Work with RGL guys to clean this up.
    tempFile <- file(file.path(tempdir(), paste(id,".html", sep="")), "w");
    writeLines(paste("%", id, "WebGL%", sep=""), 
                     tempFile)
    close(tempFile)
      
    # Write out the WebGL file and read it back in
    # TODO: Work with RGL guys to clean this process up.
    writeWebGL(dir=tempDir, snapshot= FALSE,
               template=file.path(tempdir(),paste(id,'.html', sep="")), 
               height=height, width=width, prefix=id)    
    
    #read in the file
    lines <- readLines(paste(tempDir, "/index.html", sep=""))
    #remove canvasMatrix load -- we'll load it elsewhere
    lines <- lines[-1]
        
    
    #remove the temporary directory
    #TODO: Doesn't seem to work in Windows
    unlink(tempDir, recursive=TRUE)
    #remove the template file.
    unlink(paste(tempdir(), id,".html", sep=""))
        
    rgl.close()
    
    #return the HTML lines generated by RGL
    toRet <- paste(lines, collapse="\n")
    return(list(prefix=id,html=HTML(toRet)))
  })
}