# Writes current RGL device to a WebGL HTML file (atomically)
.writeWebGL <- function(pathname, header=TRUE, class=c("rglWebGL"), ...) {
# Argument 'pathname':
pathname <- Arguments$getWritablePathname(pathname)
# Argument 'header':
header <- Arguments$getLogical(header)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Prefix
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
fullname <- tools::file_path_sans_ext(basename(pathname))
fullname <- gsub("[.](WebGL)$", "", fullname, ignore.case=TRUE)
# HTML/Javascript name prefix to use
prefix <- sprintf("%s_", gsub("[,]", "_", fullname))
# Encode prefix character (FIXME)
prefix <- gsub("[^[:alnum:]]", "_", prefix)
prefix <- sub("^([^[:alpha:]])", "_\\1", prefix)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Write RGL plot to WebGL HTML code
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# (a) Set temporary working directory
pathT <- tempdir()
prefixT <- sprintf("rgl_WebGL_%s", fullname)
pathT <- file.path(pathT, prefixT)
pathT <- Arguments$getWritablePath(pathT, mustNotExist=FALSE)
opwd <- setwd(pathT)
on.exit({
setwd(opwd)
}, add=TRUE)
# (c) Export full WebGL HTML code
printf(file="WebGL.tmpl",
"%%%sWebGL%%\n<script>%swebGLStart();</script>\n", prefix, prefix)
rgl::writeWebGL(dir=".", filename="WebGL.html", template="WebGL.tmpl",
prefix=prefix, ...)
# (d) Import WebGL HTML code
bfr <- readLines("WebGL.html", warn=FALSE)
# (e) Trim exported full WebGL HTML code
# Trim white space (to make file smaller and to avoid any Markdown
# parser to interpret it as code chunks)
bfr <- trim(bfr)
# Drop empty lines (to make file smaller)
bfr <- bfr[nchar(bfr) > 0L]
# Insert or drop 'CanvasMatrix.js' script?
idx <- grep("^[[:space:]]*<script src=.CanvasMatrix[.]js..*>.*</script>$", bfr)
# Sanity check
stopifnot(length(idx) == 1L)
if (header) {
hdr <- readLines("CanvasMatrix.js", warn=FALSE)
hdr <- c('<script type="text/javascript">', hdr, '</script>')
hdr <- paste(hdr, collapse="\n")
bfr[idx] <- hdr
} else {
bfr <- bfr[-idx]
}
# Add 'class' attribute to HTML canvas?
if (length(class) > 0L) {
pattern <- sprintf('(<canvas)( *)(id=")', prefix);
pattern <- sprintf('(<canvas)( *)(id="%scanvas")', prefix);
idx <- grep(pattern, bfr)
if (length(idx) > 1L) {
throw(sprintf("Detected %d HTML canvases, but there should be exactly one.", length(idx)))
}
replace <- sprintf('\\1 class="%s" \\3', paste(class, collapse=" "))
bfr[idx] <- gsub(pattern, replace, bfr[idx])
}
# (f) Cleanup
# Remove auxillary files
file.remove(c("CanvasMatrix.js", "WebGL.tmpl", "WebGL.html"))
# Reset working directory
setwd(opwd)
# Remove temporary directory
unlink(pathT, recursive=TRUE)
# (g) Write trimmed HTML
bfr <- paste(bfr, collapse="\n")
writeChar(bfr, con=pathname)
pathname
} # .writeWebGL()
############################################################################
# HISTORY:
# 2015-02-03
# o Now .writeWebGL() can inject a 'class' attribute to the HTML canvas.
# 2015-01-28
# o DOCUMENTATION: Added Rdoc help.
# o Added useRGL().
# o ROBUSTNESS: Now webgl(..., useNULL=FALSE) will set option
# rgl.useNULL=FALSE before loading the 'rgl' package, which makes
# the package work also on Linux when X11 is not available.
# 2014-10-17
# o Now using R.devices (>= 2.12.0) device-option style.
# 2014-09-24
# o Added class 'DevEvalProductField' and as.character() for it.
# 2014-09-10
# o Added devOffRGL(), which now tries hard to make sure devices are closed.
# o Extract webgl() out of devNewRGL(). Harmozing with R.devices.
# 2014-09-09
# o Added devNewRGL().
# o WORKAROUND: devEvalRGL() detects if the rgl version has a bug in
# exporting from RGL "null" devices or not. If so, it avoids using
# such devices.
# o CLEANUP: Simplified .writeWebGL(), moved functionality to devEvalRGL()
# and now toWebGL() is a simple wrapper around devEvalRGL(). This makes
# the code work more like what's in R.devices.
# Next is to move more code from devEvalRGL() to devNewGRL().
# 2014-09-05
# o Now argument 'font' supports a vector of font names.
# 2014-09-03
# o For now, WebGL 'width' and 'height' defaults to devOptions('png').
# o Added argument 'aspectRatio'.
# 2014-09-02
# o Added toWebGL() immitating toNnn() functions of R.devices.
# o Created.
############################################################################
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.