In MilesMcBain/r2vr: Compose and Serve WebVR Scenes

knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>"
)

Making VR Scatteplots

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.

Using a community component

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()

A Scattleplot from scratch using HTML entities

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()