R Highcharter: dynamic drilldown in Shiny on the fly

Question

I am trying to create a multi-layer drilldown graph using highcharter with dynamic data in shiny . With the help of the SO Community (shoutout to @K. Rohde) was able to figure it out by looping through all possible drilldowns. My actual shiny application will have hundreds off possible drilldowns and I don't want to add this extra time to the application but rather have the drilldown be created on the fly using addSingleSeriesAsDrilldown . Unsure of how to use it in R though.

Below is the working example of my issue looping through all drilldown possibilities:

library (shinyjs)
library (tidyr)
library (data.table)
library (highcharter)
library (dplyr)
library (shinydashboard)
library (shiny)

x <- c("Farm","Farm","Farm","City","City","City","Ocean","Ocean")
y <- c("Sheep","Sheep","Cow","Car","Bus","Bus","Boat","Boat")
z <- c("Bill","Tracy","Sandy","Bob","Carl","Newt","Fig","Tony")
a <- c(1,1,1,1,1,1,1,1)

dat <- data.frame(x,y,z,a)

header <- dashboardHeader()
body <- dashboardBody(

  highchartOutput("Working"),
  verbatimTextOutput("trial")

)
sidebar <- dashboardSidebar()

ui <- dashboardPage(header, sidebar, body)

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

  output$Working <- renderHighchart({
    #First Tier #Copied
    datSum <- dat %>%
      group_by(x) %>%
      summarize(Quantity = sum(a)
      )
    datSum <- arrange(datSum,desc(Quantity))
    Lvl1dfStatus <- tibble(name = datSum$x, y = datSum$Quantity, drilldown = tolower(name))

    #Second Tier # Generalized to not use one single input
    # Note: I am creating a list of Drilldown Definitions here.

    Level_2_Drilldowns <- lapply(unique(dat$x), function(x_level) {
      # x_level is what you called 'input' earlier.
      datSum2 <- dat[dat$x == x_level,]

      datSum2 <- datSum2 %>%
        group_by(y) %>%
        summarize(Quantity = sum(a)
        )
      datSum2 <- arrange(datSum2,desc(Quantity))

      # Note: The "drilldown" variable has to be unique, this is why we use level 1 plus level 2 names.
      Lvl2dfStatus <- tibble(name = datSum2$y,y = datSum2$Quantity, drilldown = tolower(paste(x_level, name, sep = "_")))

      list(id = tolower(x_level), type = "column", data = list_parse(Lvl2dfStatus))
    })


    #Third Tier # Generalized through all of level 2
    # Note: Again creating a list of Drilldown Definitions here.
    Level_3_Drilldowns <- lapply(unique(dat$x), function(x_level) {

      datSum2 <- dat[dat$x == x_level,]

      lapply(unique(datSum2$y), function(y_level) {

        datSum3 <- datSum2[datSum2$y == y_level,]

        datSum3 <- datSum3 %>%
          group_by(z) %>%
          summarize(Quantity = sum(a)
          )
        datSum3 <- arrange(datSum3,desc(Quantity))

        Lvl3dfStatus <- tibble(name = datSum3$z,y = datSum3$Quantity)

        # Note: The id must match the one we specified above as "drilldown"
        list(id = tolower(paste(x_level, y_level, sep = "_")), type = "column", data = list_parse2(Lvl3dfStatus))
      })
    }) %>% unlist(recursive = FALSE)

    highchart() %>%
      hc_xAxis(type = "category") %>%
      hc_add_series(Lvl1dfStatus, "column", hcaes(x = name, y = y), color = "#E4551F") %>%
      hc_plotOptions(column = list(stacking = "normal")) %>%
      hc_drilldown(
        allowPointDrilldown = TRUE,
        series = c(Level_2_Drilldowns, Level_3_Drilldowns)
      )
  })

  output$trial <- renderText({input$ClickedInput})

}


shinyApp(ui, server)

Below is an example of R code using the addSingleSeriesAsDrilldown but I am unsure of how to apply it. I would need to dynamically change the JS string.

library(highcharter)
highchart() %>%
  hc_chart(
    events = list(
      drilldown = JS("function(e) {
        var chart = this,
        newSeries = [{
          color: 'red',
          type: 'column',
          stacking: 'normal',
          data: [1, 5, 3, 4]
        }, {
          type: 'column',
          stacking: 'normal',
          data: [3, 4, 5, 1]
        }]
        chart.addSingleSeriesAsDrilldown(e.point, newSeries[0]);
        chart.addSingleSeriesAsDrilldown(e.point, newSeries[1]);
        chart.applyDrilldown();
      }")
    )
  ) %>%
  hc_add_series(type = "pie", data= list(list(y = 3, drilldown = TRUE), list(y = 2, drilldown = TRUE))) %>%
  hc_drilldown(
    series = list()
  )

Answer 1

You're getting a double answer for this one. There are two basic ways to achieve what you desire. One is to use the drilldown that Highcharts provides, even though you have to collect the sub-series from the R backend. The other one is to simply replace the Highcharts drilldown and implementing an R driven drilldown, using Highcharts only for rendering.

Since it is probably easier to digest, I will start with the latter.

Drilldown functionality from Shiny

Just forget that Highcharts can do drilldowns. You already have all you need, since you know how to add an event broadcaster that tells you when a point on the graph has been clicked.

For that, you really use the reactiveness of renderHighcharts and re-render the chart with a different data set that represents the current drilldown. The process is as follows: Column "Farm" gets clicked and you now render the Chart with the "Farm" subset. The next column gets clicked and you build the even deeper nested subset and render that. The only thing that Highcharts has been providing, which you have to do yourself, is to add a "Back" button to drill up again.

The solution below might be confusing at first, since it consists of some reactive expressions that converge into one reactive dataset which contains your current drilldown status. Note that we have to store the current drill status in the backend in order to be able to drill back up and also drill to deeper levels.

library (shinyjs)
library (tidyr)
library (data.table)
library (highcharter)
library (dplyr)
library (shinydashboard)
library (shiny)

x <- c("Farm","Farm","Farm","City","City","City","Ocean","Ocean")
y <- c("Sheep","Sheep","Cow","Car","Bus","Bus","Boat","Boat")
z <- c("Bill","Tracy","Sandy","Bob","Carl","Newt","Fig","Tony")
a <- c(1,1,1,1,1,1,1,1)

dat <- data.frame(x,y,z,a)

header <- dashboardHeader()
body <- dashboardBody(
  actionButton("Back", "Back"),
  highchartOutput("Working"),
  verbatimTextOutput("trial")

)
sidebar <- dashboardSidebar()

ui <- dashboardPage(header, sidebar, body)

server <- function(input, output, session) {
  # To hold the current drilldown status as list, i.e. list("Farm", "Sheep")
  state <- reactiveValues(drills = list())

  # Reactive reacting to the above drill list, giving out a normalized data.frame (category, amount)
  filtered <- reactive({
    if (length(state$drills) == 0) {
      # Case no drills are present.
      data.frame(category = dat$x, amount = dat$a)

    } else if (length(state$drills) == 1) {
      # Case only x_level drill is present.
      x_level = state$drills[[1]]
      sub <- dat[dat$x == x_level,]
      data.frame(category = sub$y, amount = sub$a)

    } else if (length(state$drills) == 2) {
      # Case x_level and y_level drills are present.

      x_level = state$drills[[1]]
      y_level = state$drills[[2]]
      sub <- dat[dat$x == x_level & dat$y == y_level,]
      data.frame(category = sub$z, amount = sub$a)
    }
  })

  # Since Drilldown from Highcharts is not used: Install own click handler that builds up the drill list.
  observeEvent(input$ClickedInput, {
    if (length(state$drills) < 2) {
      # Push drill name.
      state$drills <<- c(state$drills, input$ClickedInput)
    }
  })

  # Since Drilldown from Highcharts is not used: Back button is manually inserted.
  observeEvent(input$Back, {
    if (length(state$drills) > 0) {
      # Pop drill name.
      state$drills <<- state$drills[-length(state$drills)]
    }
  })

  output$Working <- renderHighchart({

    # Using normalized names from above.
    summarized <- filtered() %>%
      group_by(category) %>%
      summarize(Quantity = sum(amount))

    summarized <- arrange(summarized, desc(Quantity))
    tibbled <- tibble(name = summarized$category, y = summarized$Quantity)

    # This time, click handler is needed.
    pointClickFunction <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.name);}")

    highchart() %>%
      hc_xAxis(type = "category") %>%
      hc_add_series(tibbled, "column", hcaes(x = name, y = y), color = "#E4551F") %>%
      hc_plotOptions(column = list(stacking = "normal", events = list(click = pointClickFunction)))
  })

  output$trial <- renderText({input$ClickedInput})
}

shinyApp(ui, server)

Drilldown functionality from Highcharts

Here we have the situation, that you need to send data from the backend to the JavaScript to make use of the addSeriesAsDrilldown method from the charting library. This works in a kind of asynchronous way: Highcharts alerts that some point was requested to drill down (by clicking on it). Then the backend has to calculate the corresponding dataset and then report the dataset back to Highcharts so that it can be rendered. We use the CustomMessageHandler for this.

We don't add any drilldown series to the original Highcharts but we tell Highcharts what keyword it has to send when a drilldown is requested (drilldown-event). Note that this is not the click event, but more specialized (only if drilldown available).

The data we send back has to be formatted correctly, so here you would need some insight into the api of Highcharts (JS, not highcharter).

There are so many ways to create the drilldown data, so here I wrote another function that does it even more generally. The most important thing, however, is that you work with level-IDs that can be used to determine what filter level we are currently at. There are some comments in the code to point out those situations.

library (shinyjs)
library (tidyr)
library (data.table)
library (highcharter)
library (dplyr)
library (shinydashboard)
library (shiny)

x <- c("Farm","Farm","Farm","City","City","City","Ocean","Ocean")
y <- c("Sheep","Sheep","Cow","Car","Bus","Bus","Boat","Boat")
z <- c("Bill","Tracy","Sandy","Bob","Carl","Newt","Fig","Tony")
a <- c(1,1,1,1,1,1,1,1)

dat <- data.frame(x,y,z,a)

header <- dashboardHeader()
body <- dashboardBody(
  highchartOutput("Working"),
  verbatimTextOutput("trial")

)
sidebar <- dashboardSidebar()

ui <- dashboardPage(header, sidebar, body)

server <- function(input, output, session) {
  output$Working <- renderHighchart({
    # Make the initial data.
    summarized <- dat %>%
      group_by(x) %>%
      summarize(Quantity = sum(a))

    summarized <- arrange(summarized, desc(Quantity))
    tibbled <- tibble(name = summarized$x, y = summarized$Quantity)

    # This time, click handler is needed.
    drilldownHandler <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.drilldown);}")

    # Also a message receiver for later async drilldown data has to be set.
    # Note in the JS: message.point is going to be the point ID. Highcharts addSeriesAsDrilldown need a point to attach
    #   the drilldown series to. This is retrieved via chart.get which takes the ID of any Highcharts Element.
    #   This means: IDs are kind of important here, so keep track of what you assign.
    installDrilldownReceiver <- JS("function() {
      var chart = this;
      Shiny.addCustomMessageHandler('drilldown', function(message) {
        var point = chart.get(message.point)
        chart.addSeriesAsDrilldown(point, message.series);
      });
    }")

    highchart() %>%
      # Both events are on the chart layer, not by series. 
      hc_chart(events = list(load = installDrilldownReceiver, drilldown = drilldownHandler)) %>%
      hc_xAxis(type = "category") %>%
      # Note: We add a drilldown directive (= name) to tell Highcharts that this has a drilldown functionality.
      hc_add_series(tibbled, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#E4551F") %>%
      hc_plotOptions(column = list(stacking = "normal")) %>%
      hc_drilldown(allowPointDrilldown = TRUE)
  })

  # Drilldown handler to calculate the correct drilldown
  observeEvent(input$ClickedInput, {
    # We will code the drill levels to be i.e. Farm_Car. By that we calculate the next Sub-Chart.
    levels <- strsplit(input$ClickedInput, "_", fixed = TRUE)[[1]]
    # This is just for generalizing this function to work in all the levels and even be expandable to further more levels.
    resemblences <- c("x", "y", "z")

    dataSubSet <- dat

    # We subsequently narrow down the original dataset by walking through the drilled levels
    for (i in 1:length(levels)) {
      dataSubSet <- dat[dat[[resemblences[i]]] == levels[i],]
    }

    # Create a common data.frame for all level names.
    normalized <- data.frame(category = dataSubSet[[resemblences[length(levels) + 1]]], amount = dataSubSet$a)

    summarized <- normalized %>%
      group_by(category) %>%
      summarize(Quantity = sum(amount))

    summarized <- arrange(summarized, desc(Quantity))

    tibbled <- tibble(name = summarized$category, y = summarized$Quantity)

    # Preparing the names and drilldown directives for the next level below.
    # If already in "Farm_Car", the name for column "Bob" will be "Farm_Car_Bob"
    nextLevelCodes = lapply(tibbled$name, function(fac) {
      paste(c(levels, as.character(fac)), collapse = "_")
    }) %>% unlist

    tibbled$id = nextLevelCodes

    # This is dynamic handling for when there is no further drilldown possible.
    # If no "drilldown" property is set in the data object, Highcharts will not let further drilldowns be triggered.
    if (length(levels) < length(resemblences) - 1) {
      tibbled$drilldown = nextLevelCodes
    }

    # Sending data to the installed Drilldown Data listener.
    session$sendCustomMessage("drilldown", list(
      series = list(
        type = "column",
        name = paste(levels, sep = "_"),
        data = list_parse(tibbled)
      ),
      # Here, point is, as mentioned above, the ID of the point that triggered the drilldown.
      point = input$ClickedInput
    ))
  })

  output$trial <- renderText({input$ClickedInput})
}

shinyApp(ui, server)