R Highcharter: Dynamic multi level drilldown in Shiny - r

Question

I am trying to create a multi-layer drilldown graph using highcharter with dynamic data in shiny. I am able to accomplish this using just R code with a set input but when I put it in a shiny application and try to have it subset the data dynamically, it fails.
Below is the code that that works in R (only drilling down from Farm to Sheep):
library(shinyjs)
library(tidyr)
library(data.table)
library(highcharter)
library(dplyr)
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)
input <- "Farm"
input2 <- "Sheep"
#First Tier
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
datSum2 <- dat[dat$x == input,]
datSum2 <- datSum2 %>%
group_by(y) %>%
summarize(Quantity = sum(a)
)
datSum2 <- arrange(datSum2,desc(Quantity))
Lvl2dfStatus <- tibble(name = datSum2$y,y = datSum2$Quantity, drilldown = tolower(name))
#Third Tier
datSum2 <- dat[dat$x == input,]
datSum3 <- datSum2[datSum2$y == input2,]
datSum3 <- datSum3 %>%
group_by(z) %>%
summarize(Quantity = sum(a)
)
datSum3 <- arrange(datSum3,desc(Quantity))
Lvl3dfStatus <- tibble(name = datSum3$z,y = datSum3$Quantity)
#Graph
ClickedTest <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.name);}")
highchart() %>%
hc_xAxis(type = "category") %>%
hc_add_series(Lvl1dfStatus, "column", hcaes(x = name, y = y), color = "#E4551F") %>%
hc_plotOptions(column = list(stacking = "normal",
events = list(click = ClickedTest))) %>%
hc_drilldown(
allowPointDrilldown = TRUE,
series = list(
list(id = tolower(input), type = "column", data = list_parse(Lvl2dfStatus)),
list(id = tolower(input2), type = "column", data = list_parse2(Lvl3dfStatus))
)
)
Below is the code that fails in Shiny when changing input to dynamic:
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)
# input <- "Farm"
# input2 <- "Sheep"
header <- dashboardHeader()
body <- dashboardBody(
highchartOutput("Test"),
verbatimTextOutput("trial")
)
sidebar <- dashboardSidebar()
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
Lvl1ClickHardCoded <- ""
output$Test <- renderHighchart({
#First Tier
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
rowcheck <- dat[dat$x == input$ClickedInput,]
if (nrow(rowcheck)!=0){
datSum2 <- dat[dat$x == input$ClickedInput,]
datSum2 <- datSum2 %>%
group_by(y) %>%
summarize(Quantity = sum(a)
)
datSum2 <- arrange(datSum2,desc(Quantity))
Lvl2dfStatus <- tibble(name = datSum2$y,y = datSum2$Quantity, drilldown = tolower(name))
Lvl1ClickHardCoded <<- input$ClickedInput
Lvl1id <<- tolower(input$ClickedInput)
}
else{
Lvl2dfStatus <- data.table(Group.1=numeric(), x=numeric())
Lvl2dfStatus <- tibble(name = Lvl2dfStatus$Group.1,y = Lvl2dfStatus$x)
Lvl1id <- ""
}
#Third Tier
rowcheck <- dat[dat$x == Lvl1ClickHardCoded,]
rowcheck <- rowcheck[rowcheck$y == input$ClickedInput,]
if (nrow(rowcheck)!=0){
datSum2 <- dat[dat$x == Lvl1ClickHardCoded,]
datSum3 <- datSum2[datSum2$y == input$ClickedInput,]
datSum3 <- datSum3 %>%
group_by(z) %>%
summarize(Quantity = sum(a)
)
datSum3 <- arrange(datSum3,desc(Quantity))
Lvl3dfStatus <- tibble(name = datSum3$z,y = datSum3$Quantity)
Lvl2id <<- tolower(input$ClickedInput)
}
else{
Lvl3dfStatus <- data.table(Group.1=numeric(), x=numeric())
Lvl3dfStatus <- tibble(name = Lvl3dfStatus$Group.1,y = Lvl3dfStatus$x)
Lvl2id <- ""
}
#Graph
ClickedTest <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.name);}")
highchart() %>%
hc_xAxis(type = "category") %>%
hc_add_series(Lvl1dfStatus, "column", hcaes(x = name, y = y), color = "#E4551F") %>%
hc_plotOptions(column = list(stacking = "normal",
events = list(click = ClickedTest))) %>%
hc_drilldown(
allowPointDrilldown = TRUE,
series = list(
list(id = Lvl1id, type = "column", data = list_parse(Lvl2dfStatus)),
list(id = Lvl2id, type = "column", data = list_parse2(Lvl3dfStatus))
)
)
})
output$trial <- renderText({input$ClickedInput})
}
shinyApp(ui, server)

Answer 1

Your approach was kind of mislead by the click function. It is totally unnecessary, since (as can be seen in the non-shiny example) Highcharts has its own mechanisms to detect series clicks and can find and render drilldowns on its own.
You trying to catch the click event made the Highcharts chart building function re-render every time (resetting any drilldown) so you could not see any drilldown events at all.
The solution is to just copy your working Highcharts example into the renderHighchart function. You will immediately see that the "Farm" and "Sheep" dropdowns work.
I suppose that you were confusing yourself by using the terms "input" for the sublevel names as they are no input at all (in the shiny sense). What you have to do to get the drilldown working properly is to predefine the drilldown sets when you create the Highcharts chart. So you tell the Plugin in advance what drilldowns will be used and Highchart drills down only based on the IDs you specify.
I edited your code such that all the possible drilldowns are created in a loop and everything is working:
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)
If for any reason, you should not be satisfied with collecting all drilldowns beforehand, there is an api for adding drilldowns on the fly. Try searching for Highcharts and "addSeriesAsDrilldown". I am not sure, however, if this is accessible outside of JavaScript.