R/knitr.R

In rgl: 3D Visualization Using OpenGL

in_knitr <- function()
  isTRUE(getOption("knitr.in.progress"))

in_knitr_with_altText_support  <- function()
  in_knitr() && packageVersion("knitr") >= "1.42.12"

##
## knitr hook functions
##
##

fns <- local({
  newwindowdone <- FALSE
  closewindowsdone <- FALSE
  do_newwindow <- function(options) {
    if (!newwindowdone) {
      newwindow <- options$rgl.newwindow
      if (!is.null(newwindow) && newwindow)
        open3d()
      if (!is.null(options$rgl.keepopen))
        warning("rgl.keepopen has been replaced by rgl.newwindow")
      newwindowdone <<- TRUE
      closewindowsdone <<- FALSE
    }
  }
  do_closewindows <- function(options) {
    if (!closewindowsdone) {
      closewindows <- options$rgl.closewindows
      if (!is.null(closewindows) && closewindows)
        while (cur3d())
          close3d()
      newwindowdone <<- FALSE
      closewindowsdone <<- TRUE
    }
  }
  list(do_newwindow = do_newwindow,
       do_closewindows = do_closewindows)
})

do_newwindow <- fns[["do_newwindow"]]
do_closewindows <- fns[["do_closewindows"]]
rm(fns)

hook_webgl <- function(before, options, envir) {
  if (before) {
    do_newwindow(options)
    return()
  }
  res <- if (cur3d() != 0) {
    out_type <- opts_knit$get("out.format")
    if (!length(intersect(out_type, c("markdown", "html"))))
      stop("'hook_webgl' is for HTML only. ",
           "Use 'hook_rgl' instead, or 'setupKnitr(autoprint = TRUE)'.")
    knit_print(rglwidget(), options = options)
  }
  do_closewindows(options)
  m <- attr(res, 'knit_meta')
  knit_meta_add(m, if (missing(options)) '' else options$label)
  res
}

hook_rgl <- function(before, options, envir) {
  if (before) {
    do_newwindow(options)
    return()
  }
  res <- if (cur3d() != 0) {
    name <- fig_path("", options)
    margin <- options$rgl.margin
    if (is.null(margin)) margin <- 100
    par3d(windowRect = margin + options$dpi * 
            c(0, 0, options$fig.width, options$fig.height))
    Sys.sleep(.05) # need time to respond to window size change
    
    dir <- knitr::opts_knit$get("base_dir")
    if (is.character(dir)) {
      if (!file_test("-d", dir)) dir.create(dir, recursive = TRUE)
      owd <- setwd(dir)
      on.exit(setwd(owd))
    }
    save_rgl(name, options$dev)
    options$fig.num <- 1L  # only one figure in total
    options$dev <- "png"
    hook_plot_custom(before, options, envir)
  }
  do_closewindows(options)
  res
}

hook_rglchunk <- function(before, options, envir) {
  if (before)
    do_newwindow(options)
  else if (is.null(options$webgl) && is.null(options$rgl))
    do_closewindows(options)
}

save_rgl <- function(name, devices) {
  if (!file_test("-d", dirname(name))) 
    dir.create(dirname(name), recursive = TRUE)
  # support 3 formats: eps, pdf and png (default)
  for (dev in devices) switch(
    dev,
    eps = ,
    postscript = rgl.postscript(paste0(name, ".eps"), fmt = "eps"),
    pdf = rgl.postscript(paste0(name, '.pdf'), fmt = "pdf"),
    snapshot3d(paste0(name, ".png"))
  )
}


# This code is mostly taken from Shiny, which has lots of authors:  see
# https://github.com/rstudio/shiny/blob/master/R/utils.R

# Evaluate an expression using our own private stream of
# randomness (not affected by set.seed).
withPrivateSeed <- local({
  
  ownSeed <- NULL
  
  function(expr) {
    # Save the old seed if present.
    if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
      hasOrigSeed <- TRUE
      origSeed <- .GlobalEnv$.Random.seed
    } else {
      hasOrigSeed <- FALSE
    }
    
    # Swap in the private seed.
    if (is.null(ownSeed)) {
      if (hasOrigSeed) {
        # Move old seed out of the way if present.
        rm(.Random.seed, envir = .GlobalEnv, inherits = FALSE)
      }
    } else {
      .GlobalEnv$.Random.seed <- ownSeed
    }
    
    # On exit, save the modified private seed, and put the old seed back.
    on.exit({
      ownSeed <<- .GlobalEnv$.Random.seed
      
      if (hasOrigSeed) {
        .GlobalEnv$.Random.seed <- origSeed
      } else {
        rm(.Random.seed, envir = .GlobalEnv, inherits = FALSE)
      }
      # Shiny had this workaround.  I think we don't need it, and have
      # commented it out.
      # 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() # nolint
    })
    
    expr
  }
})

# Version of sample that runs with private seed
p_sample <- function(...) {
  withPrivateSeed(sample(...))
}

fns <- local({
  saveopts <- NULL
  plotnum <- 0
  setupDone <- NULL
  latex <- FALSE
  
  counter <- 0L
  rgl_counter <- function() {
    counter <<- counter + 1L
    counter
  }
  
  setupKnitr <- function(autoprint = FALSE, 
                         rgl.newwindow = autoprint,
                         rgl.closewindows = autoprint) {
    
    # R produces multiple vignettes in the same session.
    # Watch out for leftovers
    
    if (!is.null(setupDone)) {
      options(saveopts)
      saveopts <<- NULL
      counter <<- 0L
    }

    setupDone <<- list(autoprint = autoprint,
                       rgl.newwindow = rgl.newwindow,
                       rgl.closewindows = rgl.closewindows)
    
    knitr::opts_chunk$set(rgl.newwindow = rgl.newwindow, 
                          rgl.closewindows = rgl.closewindows,
                          rgl.chunk = TRUE)
    
    knit_hooks$set(webgl = hook_webgl)
    knit_hooks$set(webGL = hook_webgl)
    knit_hooks$set(rgl = hook_rgl)
    knit_hooks$set(rgl.chunk = hook_rglchunk)
    latex <<- identical(opts_knit$get("out.format"), "latex") || identical(opts_knit$get("rmarkdown.pandoc.to"), "latex")
    if (autoprint)
      saveopts <<- options(rgl.printRglwidget = TRUE)
  }  
  
  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) && !par3d("skipRedraw"))	{
      scene <- scene3d()
      args <- list(...)
      if (inherits(x, "rglHighlevel"))
        plotnum <<- plotnum + 1
      structure(list(plotnum = plotnum,
                     scene = scene,
                     width = figWidth(),
                     height = figHeight(),
                     options = options, args = args),
                class = c("rglRecordedplot", "knit_other_plot"))
    } else
      invisible(x)
  }
  
  sew.rglRecordedplot <- function(x, options = list(), ...)  {
    latex <- identical(opts_knit$get("out.format"), "latex") || identical(opts_knit$get("rmarkdown.pandoc.to"), "latex")
    scene <- x$scene
    doSnapshot <- knitrNeedsSnapshot(options)
    content <- rglwidget(scene,
                         width = x$width,
                         height = x$height,
                         webgl = !doSnapshot)
    if (inherits(content, "knit_image_paths")) {
      # # We've done a snapshot, put it in the right place.
      name <- fig_path("-rgl.png", options, rgl_counter())
      if (!file_test("-d", dirname(name)))
        dir.create(dirname(name), recursive = TRUE)
      file.copy(content, name, overwrite = TRUE)
      unlink(content)
      content <- structure(list(file = name,
                                extension = "png"),
                           class = "html_screenshot")
    }
    fig.align <- options$fig.align
    if (length(fig.align) ==  1 && fig.align != "default")
      content <- prependContent(content,
                                tags$style(sprintf(
                                  "#%s {%s}",
                                  content$elementId,
                                  switch(fig.align,
                                         center = "margin:auto;",
                                         left   = "margin-left:0;margin-right:auto;",
                                         right  = "margin-left:auto;margin-right:0;",
                                         ""))))
    
    result <- do.call("knit_print", c(list(x = content, options = options), x$args))
    if (!latex)
      class(result) <- c(class(result), "knit_asis_htmlwidget")
    
    sew(result, options)
  }
  
  list(
    setupKnitr = setupKnitr,
    knit_print.rglOpen3d = knit_print.rglOpen3d,
    knit_print.rglId = knit_print.rglId,
    sew.rglRecordedplot = sew.rglRecordedplot)
})

setupKnitr <- fns[["setupKnitr"]]
knit_print.rglId <- fns[["knit_print.rglId"]]
knit_print.rglOpen3d <- fns[["knit_print.rglOpen3d"]]
sew.rglRecordedplot <- fns[["sew.rglRecordedplot"]]

rm(fns)

is_low_change.rglRecordedplot <- function(p1, p2) {
  inherits(p2, "rglRecordedplot") && p1$plotnum == p2$plotnum
}

figWidth <- function() {
  if (in_pkgdown_example())
    return(pkgdown_dims()$width)
  else if (in_knitr())
    opts <- opts_current$get(c("fig.width", "dpi", "fig.retina"))
  else
    opts <- NULL
  if (length(opts)) {
    result <- with(opts, fig.width*dpi/fig.retina)
    result[1] 
  } else NULL
}

figHeight <- function() {
  if (in_pkgdown_example())
    return(pkgdown_dims()$height)
  else if (in_knitr())
    opts <- opts_current$get(c("fig.height", "dpi", "fig.retina"))
  else
    opts <- NULL
  if (length(opts)) {
    result <- with(opts, fig.height*dpi/fig.retina)
    result[1] 
  } else NULL
}