Nothing
#' @title Create a Threejs Brain and View it in Browsers
#' @author Zhengjia Wang
#' @param ...,.list geometries inherit from AbstractGeom
#' @param width,height positive integers. Width and height of the widget.
#' By default width=`100\%`, and height varies.
#' @param background character, background color such as \code{"#FFFFFF"} or \code{"white"}
#' @param cex positive number, relative text magnification level
#' @param default_colormap character, which color map name to display at startup
#' @param palettes named list, names corresponds to color-map names if you want to change color palettes
#' @param value_ranges named list, similar to \code{palettes}, value range for each values
#' @param value_alias named list, legend title for corresponding variable
#' @param surface_colormap a color map or its path generated by \code{create_colormap(gtype="surface")} to render surfaces vertices; see \code{\link{create_colormap}} for details.
#' @param voxel_colormap a color map or its path generated by \code{create_colormap(gtype="volume")} to render volume such as atlases; see \code{\link{create_colormap}} for details.
#' @param videos named list, names corresponds to color-map names, and items are generated from \code{\link{video_content}}
#' @param show_inactive_electrodes logical, whether to show electrodes with no values
#' @param timestamp logical, whether to show time-stamp at the beginning
#' @param side_canvas logical, enable side cameras to view objects from fixed perspective
#' @param side_zoom numerical, if side camera is enabled, zoom-in level, from 1 to 5
#' @param side_width positive integer, side panel size in pixels
#' @param side_shift integer of length two, side panel shift in pixels (`CSS style`: top, left)
#' @param side_display logical, show/hide side panels at beginning
#' @param title viewer title
#' @param control_panel logical, enable control panels for the widget
#' @param control_presets characters, presets to be shown in control panels
#' @param control_display logical, whether to expand/collapse control UI at the beginning
#' @param camera_center numerical, length of three, XYZ position where camera should focus at
#' @param camera_pos XYZ position of camera itself, default (0, 0, 500)
#' @param start_zoom numerical, positive number indicating camera zoom level
#' @param symmetric numerical, default 0, color center will be mapped to this value
#' @param tmp_dirname character path, internally used, where to store temporary files
#' @param token unique character, internally used to identify widgets in 'JavaScript' \code{'localStorage'}
#' @param debug logical, internally used for debugging
#' @param controllers list to override the settings, for example \code{proxy$get_controllers()}
#' @param browser_external logical, use system default browser (default) or built-in one.
#' @param global_data,global_files internally use, mainly to store orientation matrices and files.
#' @param qrcode 'URL' to show in the 'QR' code; can be a character string or a named list of \code{'url'} and \code{'text'} (hyper-reference text)
#' @param show_modal logical or \code{"auto"}, whether to show a modal instead of direct rendering the viewers; designed for users who do not have \code{'WebGL'} support; only used in shiny applications
#' @param widget_id character, internally used as unique identifiers for widgets;
#' only use it when you have multiple widgets in one website
#' @param enable_cache whether to enable cache, useful when rendering the viewers repeatedly in shiny applications
#' @param embed whether to try embedding the viewer in current run-time; default is false (will launch default web browser); set to true if running in \code{'rmarkdown'} or \code{'quarto'}, or to see the viewer in \code{'RStudio'} default panel.
#' @param custom_javascript customized temporary 'JavaScript' code that runs after ready state; available 'JavaScript' variables are:
#' \describe{
#' \item{\code{'groups'}}{input information about each group}
#' \item{\code{'geoms'}}{input information about each geometry}
#' \item{\code{'settings'}}{input information about canvas settings}
#' \item{\code{'scene'}}{'threejs' scene object}
#' \item{\code{'canvas'}}{canvas object}
#' \item{\code{'gui'}}{controls data panel}
#' \item{\code{'presets'}}{preset \code{'gui'} methods}
#' }
#'
#' @examples
#' if( interactive() ) {
#' library(threeBrain)
#'
#' # Please use `download_N27` to download N27 Collins template brain
#' n27_path <- file.path(default_template_directory(), "N27")
#' if( dir.exists(n27_path) ) {
#'
#' brain <- threeBrain(path = n27_path, subject_code = "N27",
#' surface_types = c('pial', 'smoothwm'))
#' print(brain)
#'
#' brain$plot(
#' background = "#000000",
#' controllers = list(
#' 'Voxel Type' = 'aparc_aseg',
#' 'Surface Type' = 'smoothwm',
#' 'Blend Factor' = 1,
#' 'Right Opacity' = 0.3,
#' 'Overlay Sagittal' = TRUE
#' ),
#' show_modal = TRUE
#' )
#'
#' }
#' }
#'
#' @export
threejs_brain <- function(
..., .list = list(), width = NULL, height = NULL, background = "#FFFFFF",
cex = 1, timestamp = TRUE, title = "",
# Args for the side panels
side_canvas = FALSE, side_zoom = 1, side_width = 250, side_shift = c(0, 0),
side_display = TRUE, # side_background = background,
# for controls GUI
control_panel = TRUE, control_presets = NULL, control_display = TRUE,
# Main camera and scene center
camera_center = c(0,0,0), camera_pos = c(500,0,0), start_zoom = 1,
# For colors and animation
symmetric = 0, default_colormap = 'Value', palettes = NULL,
value_ranges = NULL, value_alias = NULL,
show_inactive_electrodes = TRUE,
# color palettes for volume rendering (datacube2)
surface_colormap = system.file(
'palettes', 'surface', 'ContinuousSample.json', package = 'threeBrain'),
voxel_colormap = system.file(
'palettes', 'datacube2', 'FreeSurferColorLUT.json', package = 'threeBrain'),
videos = list(),
# Builds, additional data, etc (misc)
widget_id = 'threebrain_data', tmp_dirname = NULL,
debug = FALSE, enable_cache = FALSE, token = NULL, controllers = list(),
browser_external = TRUE, global_data = list(), global_files = list(),
# QRCode
qrcode = NULL,
# customized js code
custom_javascript = NULL,
show_modal = "auto", embed = FALSE
){
if(isTRUE(show_modal == 'auto')){
if( is.null(shiny::getDefaultReactiveDomain()) ){
show_modal <- FALSE
} else {
# check if rave is launched
if( isNamespaceLoaded("rave") || isNamespaceLoaded("ravedash") ){
show_modal <- FALSE
} else {
show_modal <- TRUE
}
}
} else {
show_modal <- isTRUE(as.logical(show_modal))
}
stopifnot2(length(camera_center) == 3 && is.numeric(camera_center), msg = 'camera_center must be a numeric vector of 3')
stopifnot2(length(camera_pos) == 3 && is.numeric(camera_pos) && sum(abs(camera_pos)) > 0, msg = 'camera_pos must be a vector length of 3 and cannot be origin')
# Inject global data
global_container <- BlankGeom$new(name = '__blank__', group = GeomGroup$new(name = '__global_data'))
sapply( names(global_data), function(nm){
global_container$group$set_group_data(
name = sprintf('__global_data__%s', nm),
value = global_data[[ nm ]]
)
})
sapply( names(global_files), function(nm){
file_info <- as.list(global_files[[nm]])
if(all(c("path", "absolute_path", "file_name", "is_new_cache", "is_cache") %in% names(file_info))){
global_container$group$set_group_data(
name = sprintf('__global_data__%s', nm),
value = file_info,
is_cached = TRUE,
cache_if_not_exists = FALSE
)
}
})
# surface cmap
if( 'colormap' %in% class(surface_colormap) ){
f <- tempfile(fileext = '.json', pattern = "surface_palette_")
save_colormap( surface_colormap, f )
surface_colormap <- normalizePath(f)
}
global_container$group$set_group_data(
name = '__global_data__.SurfaceColorLUT',
value = list(
'path' = normalizePath(surface_colormap, mustWork = FALSE),
'absolute_path' = normalizePath(surface_colormap, mustWork = FALSE),
'file_name' = filename(surface_colormap),
'is_new_cache' = FALSE,
'is_cache' = TRUE
),
is_cached = TRUE,
cache_if_not_exists = FALSE
)
# Voxel cmap
if( 'colormap' %in% class(voxel_colormap) ){
f <- tempfile(fileext = '.json', pattern = "volume_palette_")
save_colormap( voxel_colormap, f )
voxel_colormap <- normalizePath(f)
}
global_container$group$set_group_data(
name = '__global_data__.VolumeColorLUT',
value = list(
'path' = normalizePath(voxel_colormap, mustWork = FALSE),
'absolute_path' = normalizePath(voxel_colormap, mustWork = FALSE),
'file_name' = filename(voxel_colormap),
'is_new_cache' = FALSE,
'is_cache' = TRUE
),
is_cached = TRUE,
cache_if_not_exists = FALSE
)
fs_colormap <- system.file(
'palettes', 'FSColorLUT.json', package = 'threeBrain')
global_container$group$set_group_data(
name = '__global_data__.FSColorLUT',
value = list(
'path' = normalizePath(fs_colormap, mustWork = TRUE),
'absolute_path' = normalizePath(fs_colormap, mustWork = TRUE),
'file_name' = filename(fs_colormap),
'is_new_cache' = FALSE,
'is_cache' = TRUE
),
is_cached = TRUE,
cache_if_not_exists = FALSE
)
# Video contents
if( length(videos) ){
nms <- names(videos)
sel <- !nms %in% ""
if(length(nms) && any(sel)){
videos <- videos[sel]
nms <- nms[sel]
videos <- lapply(nms, function(nm){
x <- videos[[nm]]
x$name <- stringr::str_replace_all(nm, "[^a-zA-Z0-9-_]", "_")
x
})
names(videos) <- sapply(videos, "[[", 'name')
global_container$group$set_group_data(
name = '__global_data__.media_content',
value = videos,
is_cached = FALSE,
cache_if_not_exists = FALSE
)
}
}
# Create element list
geoms <- unlist(c(global_container, list(...), .list))
# Remove illegal geoms
is_geom <- vapply(geoms, function(x){ R6::is.R6(x) && inherits(x, 'AbstractGeom') }, FUN.VALUE = FALSE)
geoms <- unlist(geoms[is_geom])
groups <- unique(lapply(geoms, '[[', 'group'))
groups <- groups[!vapply(groups, is.null, FUN.VALUE = FALSE)]
# get color schema
animation_types <- unique(unlist( lapply(geoms, function(g){ g$animation_types }) ))
if(!is.list(palettes)){ palettes <- list() }
pnames <- names(palettes)
if(!is.list(value_ranges)){ value_ranges <- list() }
color_maps <- sapply(animation_types, function(atype){
c <- ColorMap$new(name = atype, .list = geoms, symmetric = symmetric,
alias = value_alias[[atype]])
if( atype %in% pnames ){
c$set_colors( palettes[[atype]] )
}
if( c$value_type == 'continuous' && length(value_ranges[[atype]]) >= 2 ){
c$value_range <- value_ranges[[atype]][c(1,2)]
if( length(value_ranges[[atype]]) >= 4 ){
c$hard_range <- sort(value_ranges[[atype]][c(3,4)])
}
}
c$to_list()
}, USE.NAMES = TRUE, simplify = FALSE)
if( length(animation_types) ){
if( !length(default_colormap) || !default_colormap %in% animation_types){
default_colormap <- animation_types[1]
}
}else{
default_colormap <- NULL
}
# backgrounds
background <- col2hexStr(background)
# side_background = col2hexStr(side_background)
# Check elements
geoms <- lapply(geoms, function(g){ g$to_list() })
# Check lib_path. whether running inside of shiny or standalone
if(is.null(shiny::getDefaultReactiveDomain())){
lib_path <- 'lib/'
}else{
lib_path <- ''
if(is.null(token)){
session <- shiny::getDefaultReactiveDomain()
token <- session$userData$rave_id
}
# If in shiny, token is given or rave_id is given, we use fixed temp path
# in this way to reduce redundency
if( !is.null(token) && length(tmp_dirname) != 1 ){
tmp_dirname <- token
}
}
# Check cached json files
if(length(tmp_dirname) != 1){
tmp_dirname <- rand_string(10)
}
tmp_dir <- file.path(tempdir(), 'threebrain_cache', tmp_dirname)
dir_create(tmp_dir)
lapply(groups, function(g){
if(length(g$cached_items)){
dir_create(file.path(tmp_dir, g$cache_name()))
for(f in g$cached_items){
re <- g$group_data[[f]]
file.copy(
from = re$absolute_path,
to = file.path(tmp_dir, g$cache_name(), re$file_name),
overwrite = TRUE
)
}
}
})
lapply(videos, function(x){
if(!x$is_url){
target <- file.path(
tmp_dir, global_container$group$cache_name(), filename(x$path)
)
file.copy(x$path, target, overwrite = TRUE)
if( x$temp ){
unlink(x$path)
}
}
})
# This is a tricky part, if the widget is created from shiny, there might be multiple instance running and we cannot have any cross talk
# TODO: Need to think on how to resolve conflicts.
widget_id <- stringr::str_replace_all(widget_id, '[^a-zA-Z0-9]', '_')
dependencies <- htmlDependency(
name = widget_id,
version = '0',
src = tmp_dir,
all_files = TRUE
)
# Get groups
groups <- lapply(groups, function(g){ g$to_list() })
# Generate settings
settings <- list(
title = paste(format(title), collapse = "\n"),
side_camera = side_canvas,
side_canvas_zoom = side_zoom,
side_canvas_width = side_width,
side_canvas_shift = side_shift,
color_maps = color_maps,
default_colormap = default_colormap,
hide_controls = !control_panel,
control_center = as.vector(camera_center),
camera_pos = camera_pos,
font_magnification = ifelse(cex > 0, cex, 1),
start_zoom = ifelse(start_zoom > 0, start_zoom, 1),
show_legend = TRUE,
render_timestamp = isTRUE(timestamp),
control_presets = control_presets,
cache_folder = paste0(lib_path, widget_id, '-0/'),
worker_script = paste0(lib_path, "three-brain-1.0.0/threebrain-worker.js"),
lib_path = lib_path,
default_controllers = controllers,
debug = debug,
enable_cache = enable_cache,
background = background,
# has_animation = v_count > 1,
token = token,
show_inactive_electrodes = isTRUE(show_inactive_electrodes),
side_display = side_display,
control_display = control_display,
qrcode = qrcode,
custom_javascript = custom_javascript
)
# Generate external file
# sapply(names(external_files) , function(nm){
# data_uri(file = external_files[[nm]]);
# }, simplify = F, USE.NAMES = T)
x <- list(
groups = groups,
geoms = geoms
)
attr(x, 'TOJSON_ARGS') <- list(null = 'null', na = 'null')
# Save x to $tmp_dir/config.json
data_filename <- sprintf("config_%s.json", digest::digest(x))
path <- file.path(tmp_dir, data_filename)
writeLines(to_json2(x), path)
htmlwidgets::createWidget(
name = 'threejs_brain', x = list(
data_filename = data_filename,
settings = settings,
force_render = !show_modal
), width = width, height = height, package = 'threeBrain', sizingPolicy = htmlwidgets::sizingPolicy(
defaultWidth = '100%',
browser.external = browser_external,
defaultHeight = '100vh',
viewer.paneHeight = 500,
viewer.suppress = !isTRUE(embed),
viewer.fill = TRUE,
padding = '0px',
), dependencies = dependencies)
}
#' Shiny Output for threeBrain Widgets
#' @author Zhengjia Wang
#' @name threejsBrainOutput
#' @param outputId unique identifier for the widget
#' @param width,height width and height of the widget. By default width="100%",
#' and height="500px".
#' @param reportSize whether to report widget size in shiny
#' \code{session$clientData}
NULL
#' @export
threejsBrainOutput <- function(outputId, width = '100%', height = '500px', reportSize = TRUE){
htmlwidgets::shinyWidgetOutput(outputId, "threejs_brain", width, height, package = "threeBrain",
reportSize = reportSize, inline = FALSE)
}
#' Shiny Renderer for threeBrain Widgets
#' @author Zhengjia Wang
#' @name renderBrain
#' @param expr R expression that calls three_brain function or Brain object
#' @param env environment of expression to be evaluated
#' @param quoted is expr quoted? Default is false.
NULL
#' @export
renderBrain <- function(expr, env = parent.frame(), quoted = FALSE) {
if (!quoted) { expr <- substitute(expr) }
htmlwidgets::shinyRenderWidget(expr, threejsBrainOutput, env, quoted = TRUE)
}
#' Save threeBrain widgets to local file system
#' @author Zhengjia Wang
#' @param widget generated from function 'threejs_brain'
#' @param path path to save the brain widget
#' @param title widget title.
#' @param as_zip whether to create zip file "compressed.zip".
#' @param ... ignored, used for backward compatibility
#' @export
save_brain <- function(widget, path, title = '3D Viewer', as_zip = FALSE, ...){
# Backward compatible:
# old: directory is specified, path = directory/filename
# new: path is specified directory
args <- list(...)
if(missing(path)) {
path <- file.path(c(args$directory, ".")[[1]], c(args$filename, 'index.html')[[1]])
} else if ( !grepl(pattern = "\\.htm[l]{0,1}$", path, ignore.case = TRUE) ){
path <- sprintf("%s.html", path)
}
widget$width <- args$width
widget$height <- args$height
# set up working directory
wdir <- dir_create(tempfile())
on.exit({ unlink(wdir, recursive = TRUE) })
widget$x$settings$cache_folder <- "#"
# selfcontained = FALSE to save all data information
temp_file <- file.path(wdir, "_tmp.html")
htmlwidgets::saveWidget(
widget,
file = temp_file,
selfcontained = FALSE,
title = title,
libdir = "_lib"
)
# Use htmlwidgets to save all js and css to html
html_text <- readLines(temp_file)
# convert <script src=*> to <script>js file contents</script>
js_lines <- which(grepl(
x = html_text,
pattern = '(src=.*js)'
))
# convert link[rel=stylesheet] to <style>css file contents</style>
css_lines <- which(grepl(
x = html_text,
pattern = '(href=.*css)'
))
readlines_quiet <- function(path) {
suppressWarnings({
readLines(path)
})
}
# perform self-contained conversion/replacement of JS
if(length(js_lines) > 0) {
html_text[js_lines] <- lapply(js_lines, function(js_line) {
js_file <- sub(x = html_text[js_line],
pattern = '.*src=[":\'](.*\\.js).*',
replacement = "\\1")
js_content <- paste0("<script>",
paste0(readlines_quiet(file.path(wdir, js_file)), collapse = "\n"),
"</script>",
collapse = "\n")
})
}
# perform self-contained conversion/replacement of JS
if(length(css_lines) > 0) {
html_text[css_lines] <- lapply(css_lines, function(css_line) {
css_file <- sub(x=html_text[css_line], pattern='.*href=[":\'](.*\\.css).*', replacement="\\1")
css_content <- paste0(
"<style>",
paste0(readlines_quiet(file.path(wdir,css_file)), collapse="\n"),
"</style>",
collapse="\n"
)
})
}
# save self-contained html
write(paste0(html_text, collapse = "\n"), file = temp_file)
# htmlwidgets::saveWidget(
# widget,
# file = file.path(wdir, "_tmp.html"),
# selfcontained = TRUE,
# title = title,
# libdir = "lib"
# )
# modify the html so the data is injected as data URI
index <- file.path(wdir, "_tmp.html")
s <- readLines(index)
m <- stringr::str_match(s, '^(.*)</head>(.*)$')
idx <- which(!is.na(m[,1]))
if(length(idx)) {
idx <- idx[[1]]
} else {
idx <- 2L
}
pre <- s[seq_len(idx - 1)]
post <- s[seq.int(idx, length(s))]
# read in base64 of each files
datapath_root <- file.path(wdir, "_lib", 'threebrain_data-0/')
data_files <- list.files(datapath_root, all.files = FALSE, full.names = FALSE, recursive = TRUE, include.dirs = FALSE)
# Make sure the parent path exists
directory <- dir_create(dirname(path))
if(length(data_files)) {
# convert data into base64
conn <- file(path, "w+")
writeLines(pre, conn)
DATAURI_MAX <- floor(65529 / 73 * 54) #72 / 4 * 3
lapply(data_files, function(data_file) {
data_abspath <- file.path(datapath_root, data_file)
data_file <- gsub("[\\\\/]+", "/", x = data_file)
data_file <- gsub("^[/]+", "", data_file)
if(endsWith(data_file, "json")) {
datauri_type <- 'application/json'
} else {
datauri_type <- 'application/octet-stream'
}
fsize0 <- file.size(data_abspath)
fsize <- fsize0
fin <- file(data_abspath, open = "rb")
ii <- 0
while(fsize > 0) {
raws <- readBin(con = fin, what = "raw", n = min(fsize, DATAURI_MAX))
writeLines(c(
sprintf("<script type='text/plain;charset=UTF-8' data-for='#%s' data-partition='%d' data-type='%s' data-size='%.0f' data-start='%.0f' data-parition-size='%.0f'>", data_file, ii, datauri_type, fsize0, fsize0 - fsize, length(raws)),
jsonlite::base64_enc(input = raws),
"</script>"
), conn)
fsize <- fsize - length(raws)
ii <- ii + 1
}
close(fin)
})
writeLines(post, conn)
close(conn)
} else {
file.copy(index, path, overwrite = TRUE)
}
unlink(wdir, recursive = TRUE)
if(as_zip){
wd <- getwd()
on.exit({ setwd(wd) })
setwd(directory)
fname <- basename(path)
zipfile <- paste0(fname, ".zip")
utils::zip(zipfile, files = fname)
}
structure(
normalizePath(path),
class = 'threeBrain.save_brain'
)
#
# directory <- normalizePath(directory)
#
#
# s <- paste(readLines(file.path(directory, filename)), collapse = '\n')
#
#
# # s <- stringr::str_replace_all(s, '\\n', '')
#
# m <- stringr::str_match(s, '<head(.*?)</head>')
# if(length(m)){
# m <- m[1,2]
# css <- unlist(stringr::str_extract_all(m, '<link[^>]*>'))
# js <- unlist(stringr::str_extract_all(m, '<script[^>]*></script>'))
# }else{
# css <- NULL
# js <- NULL
# }
#
# json <- stringr::str_match(s, '<script type="application/json" data-for=[^>]*>(.*)</script>')
# if(length(json)){
# json <- json[1,2]
# }else{
# json <- NULL
# }
#
# as_shiny <- function(outputId, width = "100%", height = "100vh") {
# f <- tempfile()
# on.exit(unlink(f))
# writeLines(c(
# paste0(
# '<div class="htmlwidget_container">\n\t<div id="',
# outputId,
# '" style="width:',
# shiny::validateCssUnit(width),
# ';height:',
# shiny::validateCssUnit(height),
# ';" class="threejs_brain html-widget">\n\t</div>\n</div>\n'
# ),
# paste0(
# '<script type="application/json" data-for="',
# outputId, '">',
# json,
# '</script>'
# )
# ), con = f, sep = "\n")
# shiny::tagList(
# shiny::singleton(shiny::HTML(c(css, js))),
# shiny::includeHTML(f)
# )
# }
#
#
#
#
# return(structure(list(
# directory = directory,
# index = index,
# zipfile = file.path(directory, 'compressed.zip'),
# has_zip = as_zip,
# as_shiny = as_shiny
# ), class = 'threeBrain_saved'))
}
grey_col <- function(...){
if( rs_avail() ){
cat("\033[38;5;246m", paste(..., sep = " ", collapse = "\n"),
"\033[39m", sep = "")
} else {
cat(..., sep = " ")
}
}
green_col <- function(...){
if( rs_avail() ){
cat("\033[38;5;35m", paste(..., sep = " ", collapse = "\n"),
"\033[39m", sep = "")
} else {
cat(..., sep = " ")
}
}
red_col <- function(...){
if( rs_avail() ){
cat("\033[38;5;215m", paste(..., sep = " ", collapse = "\n"),
"\033[39m", sep = "")
} else {
cat(..., sep = " ")
}
}
#' @export
plot.threeBrain.save_brain <- function(x, ...){
x <- normalizePath(x, winslash = "/", mustWork = TRUE)
x <- gsub("[\\\\/]+", "/", x)
utils::browseURL(sprintf("file://%s", x))
}
#' @export
format.threeBrain.save_brain <- function(x, ...){
path_exists <- file.exists(x)
paste(
c(
"<Static 3D Viewer>\n",
"Path : ", x, "\n",
"Valid: ", as.character(path_exists), "\n",
"To view the static viewer, use:\n",
sprintf(" utils::browseURL('%s')", x)
),
collapse = ""
)
}
#' @export
print.threeBrain.save_brain <- function(x, ...){
cat(format(x), "\n", sep = "")
invisible(x)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.