Draw Rotatable 3D Charts in R Shiny with Highcharts and JQuery

While it might be tempting to liven up a report or presentation with a few 3D graphs, two-dimensional representation is generally better when numbers are the primary information you want to communicate. Nevertheless, on occasions when numeric values aren’t the primary focus, and you’re more interested in showing the shape of the data, adding a third dimension might help. However, you’ll likely want more than a static graph. The key to getting the most out of this type of visualization is having the ability to move and view the graph from as many angles as possible. In this tutorial, we’ll cover how to create a 3D chart using RShiny, Highcharts and JQuery to draw a 3D graph that can be rotated as well as viewed from above and below.

To generate a three-dimensional graph that you can push, pull and rotate, you need to add handler code in JQuery or incorporate some other interactive controls into the user interface. In this tutorial we will be using the R packages shiny  and highcharter  to generate the initial Highchart. We’ll use JQuery to enable rotation.

The Tools: Highcharts and JQuery

Highcharts and JQuery are both JavaScript libraries. The handler code below is taken from a Highcharts demo by Torstein Hønsi, the creator of Highcharts. In this code snippet, JQuery selectors are used to find and manipulate an existing Highcharts object. To create the effect of 3D rotation, we need to be able to vary the *alpha* and *beta* values of the Highchart. The beta values rotate the chart left and right, while the alpha values rotate it up and down.

Since our code is ultimately going to be in R shiny, we load R highcharter and wrap the JQuery snippet with the function JS, storing it in a variable called rotate. When we run our Shiny app, we will include rotate in the Shiny UI as a script.

The handler code below consists of three functions. First, JQuery selects the Highchart div container by its element id, chart3D in response to either a mousedown or touchstart event, attaching the event handler to this object. (A mousedown event is holding down on a click on the div container, while touchstart refers to a touch on a touch screen.) JQuery locates the Highcharts object inside the id and derives different variables from the event start, eStart and the chart object, chart. These variables include the current alpha and beta values of the Highchart as well as the coordinates of the starting position of the mouse on the page.

There are two more functions nested inside the main mousedown / touchstart function. On mousemove the new position of the mouse is calculated, then the difference between the positions of the mouse is added respectively to the existing alpha and beta values and divided by a “sensitivity” value. This formula results in new alpha and beta values, permitting the chart to be adjusted accordingly. On mouseup, the event handler is removed from the object.

library(highcharter)

rotate <- highcharter::JS(
   "$(function() {

      // Add mouse events for rotation
      $('#chart3D').on('mousedown.hc touchstart.hc', function(eStart) {
   
         var chart = $(this).highcharts(); //Highcharts object

         eStart = chart.pointer.normalize(eStart);

         var posX = eStart.pageX,
         posY = eStart.pageY,
         alpha = chart.options.chart.options3d.alpha,
         beta = chart.options.chart.options3d.beta,
         newAlpha,
         newBeta,
         sensitivity = 5; // lower is more sensitive

         $(document).on({

            'mousemove.hc touchdrag.hc': function(e) {

               // Run beta
               newBeta = beta + (posX - e.pageX) / sensitivity;
               chart.options.chart.options3d.beta = newBeta;

               // Run alpha
               newAlpha = alpha + (e.pageY - posY) / sensitivity;
               chart.options.chart.options3d.alpha = newAlpha;

               chart.redraw(false);
            },

            'mouseup touchend': function() {
               $(document).off('.hc');
            } 
         });
      });
   });"
)

You can also integrate this JQuery code with a Shiny app as a separate .js file. Simply take the character string out of the JS  function, save it as a .js file (for example, rotate.js), and include the file in the app’s www  directory, and also add the following line of code to the Shiny UI:

tags$head(tags$script(src = 'rotate.js'))

The Data

For this demo, we’ll use the HairEyeColor from the R package datasets. This data comes from a 1974 survey of 592 students from the University of Delaware. The data comes in as a three-dimensional array containing three variables: hair color, eye color, and sex.

library(reshape2)
library(datasets)

data("HairEyeColor")
HairEyeColor

Our visualization will show the distribution of hair and eye color only, so we divide the data by Male  and Female into two-dimensional arrays. We then turn these arrays into data frames, merge them on the Hair and Eye variables, and aggregate the frequency counts. The resulting data frame will be in long form, with the columns Hair, Eye, and Freq, so to restore the data to wide form, we use dcast.

men_hairEyeColor <- as.data.frame(HairEyeColor[,,'Male'])
women_hairEyeColor <- as.data.frame(HairEyeColor[,,'Female'])

combined_hairEyeColor <- merge(women_hairEyeColor, men_hairEyeColor, by = c("Hair", "Eye"))
combined_hairEyeColor$Freq <- combined_hairEyeColor$Freq.x + combined_hairEyeColor$Freq.y

longForm_hairEyeColor <- subset(combined_hairEyeColor, select = c('Hair', 'Eye', 'Freq'))

hairEyeColor <- reshape2::dcast(longForm_hairEyeColor, Hair ~ Eye, value.var = 'Freq')

hairEyeColor

The Chart

The data is ready to be passed it into Shiny. Our x-axis variable is hair color, or the first column of the hairEyeColor data frame, and our data series are delineated by eye color (the remaining columns). We remove the the first categorical column Hair and use lapply across the remaining columns to create a list of the data series. We create this list so we can use hc_add_series_list, a shortcut function in highcharter. We enable the options3d parameter in hc_chart.

Scroll down and give it a spin! A graph of the same data as a two-dimensional bar chart has been included for comparison.

library(shiny)

shinyApp(
ui <- fluidPage(
   tags$head(tags$script(rotate))

   , fluidRow(
      highchartOutput('chart3D')
   )

   , fluidRow(
      highchartOutput('chart2D')
   )

),

server <- function(input, output, session) {

   data_series <- hairEyeColor[2:length(hairEyeColor)]

   # optional step
   # orders data series according to which has highest max
   col_max <- sapply(data_series, FUN = max, na.rm = TRUE)
   data_series <- data_series[,order(col_max)]

   categories <- names(data_series)

   ds <- lapply(seq(length(categories)), function(x){
      list(
         name = paste(categories[x], 'Eyes', ' '), 
         data = data_series[[categories[x]]]
      ) 
   })

   output$chart2D <- renderHighchart({

      hc <- highchart() %>%
         hc_xAxis(categories = paste(hairEyeColor$Hair, 'Hair', " ")
                  , labels = list(rotation = 0)) %>%
         hc_colors(colors = c('#3bb300', '#b5ae6e', '#00bfff', '#86592d')) %>%
         hc_add_series_list(ds) %>%
         hc_title(text = 'Hair and Eye Color for University of Delaware Stats Students - 1974') %>%
         hc_chart(type = "column")

      hc

   })

   output$chart3D <- renderHighchart({

      hc <- highchart() %>%
         hc_xAxis(categories = paste(hairEyeColor$Hair, 'Hair', " ")
                  , labels = list(rotation = 0)) %>%
         hc_colors(colors = c('#3bb300', '#b5ae6e', '#00bfff', '#86592d')) %>%
         hc_add_series_list(ds) %>%
         hc_title(text = 'Hair and Eye Color for University of Delaware Stats Students - 1974') %>%
         hc_chart(type = "column", 
                  options3d = list(enabled = TRUE
                                   , beta = 20
                                   , alpha = 30
                                   , depth = 400
                                   , viewDistance = 5)) %>%
         hc_plotOptions(
            series = list(groupZpadding = 0
                           , depth = 100
                           , groupPadding = 0
                           , grouping = FALSE
                           , frame = list(
                                     bottom = list(
                                                size = 1
                                                , color = 'rgba(0,0,0,0.05)'
                                              )
                                          )
                          )
                       )

      hc

   })
})