R/zzz.R

In rgl: 3D Visualization Using OpenGL

##
## R source file
## This file is part of rgl
##
##

##
## ===[ SECTION: package entry/exit point ]===================================
##

##
## entry-point
##
##
  
.onLoad <- function(lib, pkg) {

  in_pkgload_loadall <- function() {
    caller <- deparse(sys.call(-4))
    isNamespaceLoaded("pkgload") && any(grepl("load_all", caller))
  }
  
  getDir <- function(useNULL) {
    if (in_pkgload_loadall()) {
      dir <- if (useNULL) file.path("inst", "useNULL") else "src"
    } else {
      dir <- if (useNULL) "useNULL" else "libs"
      if (nchar(.Platform$r_arch))
        dir <- file.path(dir, .Platform$r_arch)
    }
    dir
  }
    
  getDynlib <- function(dir)
    system.file(dir, paste0("rgl", .Platform$dynlib.ext), 
                package = pkg, lib.loc = lib,
                mustWork = TRUE)
  
  is_tahoe <- function() {
    mac_version_string <- system("sw_vers -productVersion", intern = TRUE)
    mac_version <- as.numeric_version(mac_version_string)
    tahoe_version <- as.numeric_version("26.0")
    mac_version >= tahoe_version
  }
  
  # OS-specific 
  initValue <- 0  
  
  onlyNULL <- noOpenGL || rgl.useNULL()
  
  useNULL <- onlyNULL && !noOpenGL && .Platform$OS.type != "windows"
  dir <- getDir(useNULL)
  
  unixos <- "none"
  if (.Platform$OS.type == "unix")
    unixos <- Sys.info()["sysname"]
  
  dll <- try(dyn.load(dynlib <- getDynlib(dir)))
  if (inherits(dll, "try-error")) {
    if (unixos == "Darwin" && !onlyNULL)
      warning(paste("\tLoading rgl's DLL failed.", 
    	       if (unixos == "Darwin" && !onlyNULL) {
    	         paste(if (is_tahoe()) "\n\tYou appear to be running macOS Tahoe or newer.
    	               Tahoe 26.1 is known not to support OpenGL." else "\n\tThis build of rgl depends on XQuartz, which failed to load.\n",
    	           "See the discussion in https://stackoverflow.com/a/66127391")
             }),
         call. = FALSE)
    if (!onlyNULL) {
      dir <- getDir(TRUE)
      warning("Trying without OpenGL...", call. = FALSE)
      noOpenGL <<- TRUE
      dll <- try(dyn.load(dynlib <- getDynlib(dir)))
    }
    if (inherits(dll, "try-error"))
      stop("Loading failed.")
  }
  routines <- getDLLRegisteredRoutines(dll, addNames = FALSE)
  ns <- asNamespace(pkg)
  for(i in 1:4)
    lapply(routines[[i]],
      function(sym) assign(sym$name, sym, envir = ns))
      
  if ( !noOpenGL && .Platform$OS.type == "windows" && !onlyNULL) {
    frame <- getWindowsHandle("Frame")  # nolint 
    ## getWindowsHandle was numeric pre-2.6.0 
    if ( !is.null(frame) ) initValue <- getWindowsHandle("Console") # nolint
  } 
 
  if (onlyNULL) {
    rglFonts(serif = rep("serif", 4), sans = rep("sans", 4), mono = rep("mono", 4), symbol = rep("symbol", 4))
  } else {
    rglFonts(serif = rep(system.file("fonts", "FreeSerif.ttf", package="rgl"), 4),
             sans  = rep(system.file("fonts", "FreeSans.ttf", package="rgl"), 4),
             mono  = rep(system.file("fonts", "FreeMono.ttf", package="rgl"), 4),
             symbol = rep(system.file("fonts", "FreeSerif.ttf", package="rgl"), 4))
    if (requireNamespace("extrafont", quietly = TRUE))
      suppressWarnings(
        rglExtrafonts(sans = c("Helvetica", "Arial"), 
                      serif = c("Times", "Times New Roman"), 
                      mono = c("Courier", "Courier New")))
  }
  
  register_compare_proxy()
  
  .rglEnv$subsceneList <- NULL
  
  dir <- tempfile("rgl")
  dir.create(dir)
  .rglEnv$textureDir <- normalizePath(dir)

  # Workaround for incompatibility with quartz device
  # By default only run this if we'll be using the X11 display on macOS
  # and we're not on R.app.  options("rgl.startQuartz") can 
  # override this.
  # Then we need to start quartz() before starting rgl.
  # See https://github.com/dmurdoch/rgl/issues/27
  if (getOption("rgl.startQuartz", 
           !onlyNULL &&
           interactive() &&
           unixos == "Darwin" && 
           !(.Platform$GUI %in% c("AQUA", "RStudio"))) &&
         exists("quartz", getNamespace("grDevices"))) {
    grDevices::quartz()
    safe.dev.off()
  }
  
  ret <- rgl.init(initValue, onlyNULL)
  
  if (!ret) {
    warning("'rgl.init' failed, will use the null device.\nSee '?rgl.useNULL' for ways to avoid this warning.", call. = FALSE)
    options(rgl.useNULL = TRUE)
    rgl.init(initValue, TRUE)	
  }

  if (!rgl.useNULL()) 
    setGraphicsDelay(unixos = unixos)
  
  # Are we running in reprex::reprex?  If so, do
  # the knitr setup so our output appears there.
  
  if (in_reprex()) {
    setupKnitr(autoprint = TRUE)
  }
}

# Do we need a delay opening graphics?    
# Work around bug in MacOS Catalina:  if base plotting happens
# too quickly after first call to quartz, R crashes.
# This inserts a delay after the
# first call to the graphics device.  The default is
# no delay, unless on Catalina with no graphics device
# currently open, when a 1 second delay will be introduced.
# Use "RGL_SLOW_DEV = value" to change the delay from 
# the default to "value" seconds.  

setGraphicsDelay <- function(delay = Sys.getenv("RGL_SLOW_DEV", 0), 
                             unixos = "none") {
  if (unixos == "Darwin") {
    version <- try(numeric_version(Sys.info()["release"]))
    if (missing(delay) &&
        !inherits(version, "try-error") && 
        !is.na(version) && 
        version >= "19.0.0" &&
        dev.cur() == 1 &&
        identical(getOption("device"), grDevices::quartz))
      delay <- Sys.getenv("RGL_SLOW_DEV", 1)
  }
  delay <- suppressWarnings(as.numeric(delay))
  if (is.na(delay))
    delay <- 1
  if (delay > 0) {
    olddev <- getOption("device")
    if (is.character(olddev)) {
      if (exists(olddev, globalenv(), mode = "function"))
        olddev <- get(olddev, envir = globalenv(), mode = "function")
      else if (exists(olddev, asNamespace("grDevices"), mode = "function"))
        olddev <- get(olddev, asNamespace("grDevices"), mode = "function")
    }
    if (is.function(olddev))
      options(device = function(...) {
        olddev(...)
        Sys.sleep(delay)
        options(device = olddev)
      })
  }
}

rgl.init <- function(initValue = 0, onlyNULL = FALSE, debug = getOption("rgl.debug", FALSE)) 
  .Call( rgl_init, 
    initValue, onlyNULL, environment(rgl.init), debug )

.onAttach <- function(libname, pkgname) {
  if (noOpenGL)
    packageStartupMessage(
      "This build of rgl does not include OpenGL functions.  Use
 rglwidget() to display results, e.g. via options(rgl.printRglwidget = TRUE).")
}

##
## exit-point
##
##

.onUnload <- function(libpath) {
  
  unregisterShinyHandlers()
  unlink(.rglEnv$textureDir, recursive = TRUE)
  
  # shutdown
  .C( rgl_quit, success=FALSE )
  
}

in_reprex <- function() 
  !is.null(getOption("reprex.current_venue"))