knitr::opts_chunk$set( collapse = TRUE, comment = "#>" )
This document describes two methods of using r2vr
to create a VR scatter plot:
1. Using a single entity that with a community developed A-Frame scatterplot component attached.
2. Generating a list of entity HTML elements representing the geometric primitives of the plot data and dressing.
Rather than building a plot from A-Frame primitives, it's a good idea to check if there is some A-Frame components written in Javascript that will suit the objective. Places to look are: The A-Frame component registry The NPM archive 'aframe' tag
As it happens there are a couple of options for making VR plots. This example will use: https://github.com/zcanter/aframe-scatterplot.
According to the documentation our data needs to be JSON that looks like this:
```{js, eval = FALSE} [ { // Data Point "Field1": 13.90738679789567, "Field2": 11.77935227940546, "Field3": 12.02052097080796, "Field4": 11.31274091176219, "Field5": 14.13415151546462, }, { // Data Point "Field1": 12.29829187876160, "Field2": 10.12398967761787, "Field3": 16.81298749861520, "Field4": 13.92371645984898, "Field5": 11.35138647618786, }, {...}, {...}, ]
```r library(r2vr) library(jsonlite) library(ggplot2) a_scatterplot <- function(json_data, x, y, z, ...){ ## js sources for scatterplot .scatter_source <- "https://cdn.rawgit.com/zcanter/aframe-scatterplot/master/dist/a-scatterplot.min.js" .d3_source <- "https://cdnjs.cloudflare.com/ajax/libs/d3/4.4.1/d3.min.js" ## Create in-memory asset for JSON data ## A regular a_asset could be used that points to a real file ## this is necessary in a vignette to avoid CRAN issues. json_file_asset <- a_in_mem_asset(id = "scatterdata", src = "./scatter_data.json", .data = json_data) a_entity(.tag = "scatterplot", src = json_file_asset, .js_sources = list(.scatter_source, .d3_source), x = x, y = z, z = z, ...) } diamonds_json <- jsonlite::toJSON(diamonds) my_scene <- a_scene(.template = "empty", .children = list( a_scatterplot(diamonds_json, x = "depth", y = "carat", z = "table", val = "price", xlabel = "depth", ylabel = "carat", zlabel = "table", showFloor = TRUE, ycage = TRUE, title = "Price of Diamond$$$", pointsize = "10", position = c(0, 0, -2), scale = c(3,3,3)), a_pc_control_camera())) my_scene$serve() my_scene$stop()
This section contains r2vr
code to compose a simple 3D scatter plot of mpg
vs wt
vs hp
, coloured by am
from the mtcars
data. Since it is made 'from
scratch', using geometric primitives, there are a few considerations: What
dimensions should the plot be? How do we scale the data to these dimensions? Can
we apply labels that appear when the points are looked at?
Since data is used to answer these questions, we may as well create a function that returns a scene so we can re-use the code.
The code here should be considered a proof of concept only. It is overly long
and could be decoupled and abstracted further into composable functions on the way to creating
a general purpose VR plotting API. At the moment that API is not planned for
r2vr
. If it comes, it will be as a separate package that builds on r2vr
.
library(r2vr) library(purrr) library(tibble) a_scatter_ents <- function(x, y, z, colour = rep(1, length(x)), palette_fn = rainbow, sizes = rep(0.1, length(x)), labels, dimensions = c(2,2,2), ...){ force(sizes) x_label <- deparse(substitute(x)) y_label <- deparse(substitute(y)) z_label <- deparse(substitute(z)) legend_label <- deparse(substitute(colour)) colour_factor <- as.factor(colour) ent_colours <- palette_fn(nlevels(colour_factor))[colour_factor] range_scale <- function(a) (a - min(a, na.rm=TRUE)) / diff(range(a, na.rm=TRUE)) x <- range_scale(x) y <- range_scale(y) z <- range_scale(z) positions <- cbind(x,y,z) * dimensions entity_data <- tibble::tibble(position = purrr::transpose(as.data.frame(positions)), color = ent_colours, radius = sizes, label = labels) points <- purrr::pmap(entity_data, function(position, color, radius, label){ id = gsub(" ", "", label) point <- a_entity(.tag = "sphere", position = unlist(position), color = color, radius = radius, event_set__click = list(`_event`= "click", `_target`= "#labelview", visible = TRUE, value = label), event_set__leave = list(`_event`="mouseleave", `_target`= "#labelview", visible = FALSE, value = label), .js_sources = "https://unpkg.com/aframe-event-set-component@^4.0.0/dist/aframe-event-set-component.min.js") point }) ## camera entity with cursor cursor <- a_entity(.tag = "camera", position = c(0,1.6,3), .children = list( a_entity(.tag = "cursor", position = c(0,0,3)), a_label(id = "labelview", text = "", scale = c(0.4, 0.4, 0.4), position = c(0,-0.4,-1)))) ## make axis labels label_offset <- 0.1 * dimensions x_axis_label <- a_label(text = x_label, position = dimensions * c(0.5, 0.1, 0)) y_axis_label <- a_label(text = y_label, position = dimensions * c(0, 0.5, 0), rotation = c(0, 45, 0)) z_axis_label <- a_label(text = z_label, position = dimensions * c(0, 0.1, 0.5), rotation = c(0, 90, 0)) ## make each axis x_axis <- a_entity(line = list(start = c(0,0,0), end = c(dimensions[[1]], 0, 0), color = "#000000"), children = list(x_axis_label)) y_axis <- a_entity(line = list(start = c(0,0,0), end = c(0, dimensions[[2]], 0), color = "#000000"), children = list(y_axis_label)) z_axis <- a_entity(line = list(start = c(0,0,0), end = c(0, 0, dimensions[[3]]), color = "#000000"), children = list(z_axis_label)) ## make legend legend_levels <- levels(colour_factor) legend_colours <- palette_fn(nlevels(colour_factor)) if(length(legend_levels > 1)){ box_size = 0.2 box_spacing = 0.2 legend_position = c(dimensions[[1]] * 1.1, 0, 0) legend_ents <- purrr::imap(legend_levels, function(level, index){ a_entity(.tag = "text", value = as.character(level), position = c(0, index * (box_size + box_spacing), 0), rotation = c(0, 0, 0), color = "#000000", align = "right", anchor = "right", text = list(xOffset = box_size*2), geometry= list(primitive = "box", width = box_size, height = box_size, depth = box_size), material = list(transparent = FALSE, color = legend_colours[[index]] ) ) }) ## Legend label legend_label <- a_entity(.tag = "text", value = legend_label, position = c(0, (box_size + box_spacing) * (nlevels(colour_factor) + 1), 0), rotation = c(0, 0, 0), color = "#000000", align = "center", geometry= list(primitive = "box", width = box_size, height = box_size, depth = box_size), material = list(transparent = TRUE, opacity = 0)) plot_legend <- a_entity(position = legend_position, .children = c(legend_ents, legend_label)) } else { plot_legend <- list() } ## make plot and add points plot <- a_entity(position = c(0,0.1,-3), .children = c(x_axis, y_axis, z_axis, points, plot_legend)) my_scene <- a_scene(.template = "basic", .title = "A scattering of cars", .children = c(cursor, plot)) my_scene } my_scene <- a_scatter_ents( x = mtcars$hp, y = mtcars$mpg, z = mtcars$wt, colour = mtcars$am, purrr::partial(rainbow, alpha = NULL), #for RGB -alpha labels = row.names(mtcars), dimensions = c(3,3,3)) ## my_scene$serve() ## my_scene$stop()
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.