how to create two independent drill down plot using Highcharter?
Here you go, both graphs operate independently of each other's drilldowns.
I simplified your code as well as you had a lot of observes and reactives that were not needed (in this example at least).
cate<-c("Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","drinks","drinks","groceries","groceries","groceries","dairy","dairy","dairy","dairy","groceries","technology","technology","technology","technology","technology","technology","technology","technology","groceries","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","drinks","drinks","groceries","groceries","groceries","dairy","dairy","dairy","dairy","groceries","technology","technology","technology","technology","technology","technology","technology","technology","groceries","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","drinks","drinks","groceries","groceries","groceries","dairy","dairy","dairy","dairy","groceries","technology","technology","technology","technology","technology","technology","technology","technology","groceries","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","Furniture","drinks","drinks","groceries","groceries","groceries","dairy","dairy","dairy","dairy","groceries","technology","technology","technology","technology","technology","technology","technology","technology","groceries")
Sub_Product<-c("nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","nov","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","oct","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","sept","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug","aug")
Main_Product<-c("outdoor","indoor","outdoor","indoor","indoor","outdoor","indoor","indoor","indoor","indoor","outdoor","outdoor","n&o","n&o","indoor","indoor","indoor","indoor","outdoor","indoor","outdoor","outdoor","outdoor","indoor","outdoor","indoor","outdoor","outdoor","indoor","outdoor","n&o","outdoor","indoor","outdoor","indoor","indoor","outdoor","indoor","indoor","indoor","indoor","outdoor","outdoor","n&o","n&o","indoor","indoor","indoor","indoor","outdoor","indoor","outdoor","outdoor","outdoor","indoor","outdoor","indoor","outdoor","outdoor","indoor","outdoor","n&o","outdoor","indoor","outdoor","indoor","indoor","outdoor","indoor","indoor","indoor","indoor","outdoor","outdoor","n&o","n&o","indoor","indoor","indoor","indoor","outdoor","indoor","outdoor","outdoor","outdoor","indoor","outdoor","indoor","outdoor","outdoor","indoor","outdoor","n&o","outdoor","indoor","outdoor","indoor","indoor","outdoor","indoor","indoor","indoor","indoor","outdoor","outdoor","n&o","n&o","indoor","indoor","indoor","indoor","outdoor","indoor","outdoor","outdoor","outdoor","indoor","outdoor","indoor","outdoor","outdoor","indoor","outdoor","n&o")
Product<-c("abc","def","ghh","hig","lmn","opk","cba","dfw","ewr","csad","wer","casd","were","csad","rt","hgf","qeq","hgf","qer","qer2","erqerq","qdq","dwqer","qerqe","erqererq","e2342","ererq","qewrw","qrerqr","qreqw","qerqe","abc","def","ghh","hig","lmn","opk","cba","dfw","ewr","csad","wer","casd","were","csad","rt","hgf","qeq","hgf","qer","qer2","erqerq","qdq","dwqer","qerqe","erqererq","e2342","ererq","qewrw","qrerqr","qreqw","qerqe","abc","def","ghh","hig","lmn","opk","cba","dfw","ewr","csad","wer","casd","were","csad","rt","hgf","qeq","hgf","qer","qer2","erqerq","qdq","dwqer","qerqe","erqererq","e2342","ererq","qewrw","qrerqr","qreqw","qerqe","abc","def","ghh","hig","lmn","opk","cba","dfw","ewr","csad","wer","casd","were","csad","rt","hgf","qeq","hgf","qer","qer2","erqerq","qdq","dwqer","qerqe","erqererq","e2342","ererq","qewrw","qrerqr","qreqw","qerqe")
sum1<-c(43,90,135,125,87,4,23,120,4,127,70,68,129,63,131,90,67,110,90,119,81,68,15,29,49,11,76,82,65,83,25,43,90,135,125,87,4,23,120,4,127,70,68,129,63,131,90,67,110,90,119,81,68,15,29,49,11,76,82,65,83,25,43,90,135,125,87,4,23,120,4,127,70,68,129,63,131,90,67,110,90,119,81,68,15,29,49,11,76,82,65,83,25,43,90,135,125,87,4,23,120,4,127,70,68,129,63,131,90,67,110,90,119,81,68,15,29,49,11,76,82,65,83,25)
sum2<-c(14567,11111,3287,3563,9633,11162,3044,8437,4382,11250,3932,5587,4175,9708,4970,8388,10673,4301,12475,13494,12519,5632,3898,12472,4381,14085,10041,4276,12953,11143,12905,14567,11111,3287,3563,9633,11162,3044,8437,4382,11250,3932,5587,4175,9708,4970,8388,10673,4301,12475,13494,12519,5632,3898,12472,4381,14085,10041,4276,12953,11143,12905,14567,11111,3287,3563,9633,11162,3044,8437,4382,11250,3932,5587,4175,9708,4970,8388,10673,4301,12475,13494,12519,5632,3898,12472,4381,14085,10041,4276,12953,11143,12905,14567,11111,3287,3563,9633,11162,3044,8437,4382,11250,3932,5587,4175,9708,4970,8388,10673,4301,12475,13494,12519,5632,3898,12472,4381,14085,10041,4276,12953,11143,12905)
avg1<-c(48,132,115,83,84,77,111,102,113,96,136,97,89,97,66,18,123,29,37,118,66,87,52,11,97,25,144,21,40,6,36,48,132,115,83,84,77,111,102,113,96,136,97,89,97,66,18,123,29,37,118,66,87,52,11,97,25,144,21,40,6,36,48,132,115,83,84,77,111,102,113,96,136,97,89,97,66,18,123,29,37,118,66,87,52,11,97,25,144,21,40,6,36,48,132,115,83,84,77,111,102,113,96,136,97,89,97,66,18,123,29,37,118,66,87,52,11,97,25,144,21,40,6,36)
avg2<-c(6775,3142,3916,12828,9889,4025,11374,10594,4263,8871,11229,4787,7478,5316,5299,14068,3981,12993,12435,13845,4320,7472,14285,10221,11883,7783,13980,11426,13120,8632,14540,6775,3142,3916,12828,9889,4025,11374,10594,4263,8871,11229,4787,7478,5316,5299,14068,3981,12993,12435,13845,4320,7472,14285,10221,11883,7783,13980,11426,13120,8632,14540,6775,3142,3916,12828,9889,4025,11374,10594,4263,8871,11229,4787,7478,5316,5299,14068,3981,12993,12435,13845,4320,7472,14285,10221,11883,7783,13980,11426,13120,8632,14540,6775,3142,3916,12828,9889,4025,11374,10594,4263,8871,11229,4787,7478,5316,5299,14068,3981,12993,12435,13845,4320,7472,14285,10221,11883,7783,13980,11426,13120,8632,14540)
dat<-data.frame(cate,Sub_Product,Main_Product,Product,sum1,sum2,avg1,avg2, stringsAsFactors = FALSE)
ACClist<-c("sum1","sum2")
AVGlist<-c("avg1","avg2")
library (shinyjs)
library (tidyr)
library (data.table)
library (highcharter)
library (dplyr)
library (shinydashboard)
library (shiny)
library (shinyWidgets)
header <-dashboardHeader()
body <- dashboardBody(fluidRow(
column(width = 12,
radioGroupButtons(
inputId = "l1PAD", label = NULL,size = "lg",
choices = unique(dat$cate), justified = TRUE,
individual = TRUE)
)),
fluidRow(
box(
title = "Summation of dataset", highchartOutput("accuPA",height = "300px")
),
box(
title = "Mean of dataset", highchartOutput("avgPA",height = "300px")
)
))
sidebar <- dashboardSidebar(collapsed = T,
radioGroupButtons(
"accuselectPA","sum",choices=ACClist,
direction = "vertical",width = "100%",justified = TRUE
),
br(),
radioGroupButtons(
"avgselectPA","Average ",choices=AVGlist,
direction = "vertical",width = "100%",justified = TRUE
))
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
#data set
dat_filtered <- reactive({
dat[dat$cate == input$l1PAD,]
})
#Acc/sum graph
output$accuPA<-renderHighchart({
#LEVEL 1
datSum <- dat_filtered() %>%
group_by(Main_Product) %>%
summarize(Quantity = mean(get(input$accuselectPA)))
datSum <- arrange(datSum,desc(Quantity))
Lvl1dfStatus <- tibble(name = datSum$Main_Product, y = datSum$Quantity, drilldown = tolower(name))
#LEVEL 2
Level_2_Drilldowns <- lapply(unique(dat_filtered()$Main_Product), function(x_level) {
datSum2 <- dat_filtered()[dat_filtered()$Main_Product == x_level,]
datSum2 <- datSum2 %>%
group_by(Product) %>%
summarize(Quantity = mean(get(input$accuselectPA)))
datSum2 <- arrange(datSum2,desc(Quantity))
Lvl2dfStatus <- tibble(name = datSum2$Product,y = datSum2$Quantity, drilldown = tolower(paste(x_level, name, sep = "_")))
list(id = tolower(x_level), type = "column", data = list_parse(Lvl2dfStatus))
})
#LEVEL 3
Level_3_Drilldowns <- lapply(unique(dat_filtered()$Main_Product), function(x_level) {
datSum2 <- dat_filtered()[dat_filtered()$Main_Product == x_level,]
lapply(unique(datSum2$Product), function(y_level) {
datSum3 <- datSum2[datSum2$Product == y_level,]
datSum3 <- datSum3 %>%
group_by(Sub_Product) %>%
summarize(Quantity = mean(get(input$accuselectPA)))
datSum3 <- arrange(datSum3,desc(Quantity))
Lvl3dfStatus <- tibble(name = datSum3$Sub_Product,y = datSum3$Quantity)
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)
)
})
#Avg/Avg graph
output$avgPA<-renderHighchart({
#LEVEL 1
datSum <- dat_filtered() %>%
group_by(Main_Product) %>%
summarize(Quantity = mean(get(input$avgselectPA)))
datSum <- arrange(datSum,desc(Quantity))
Lvl1dfStatus <- tibble(name = datSum$Main_Product, y = datSum$Quantity, drilldown = tolower(name))
#LEVEL 2
Level_2_Drilldowns <- lapply(unique(dat_filtered()$Main_Product), function(x_level) {
datSum2 <- dat_filtered()[dat_filtered()$Main_Product == x_level,]
datSum2 <- datSum2 %>%
group_by(Product) %>%
summarize(Quantity = mean(get(input$avgselectPA)))
datSum2 <- arrange(datSum2,desc(Quantity))
Lvl2dfStatus <- tibble(name = datSum2$Product,y = datSum2$Quantity, drilldown = tolower(paste(x_level, name, sep = "_")))
list(id = tolower(x_level), type = "column", data = list_parse(Lvl2dfStatus))
})
#LEVEL 3
Level_3_Drilldowns <- lapply(unique(dat_filtered()$Main_Product), function(x_level) {
datSum2 <- dat_filtered()[dat_filtered()$Main_Product == x_level,]
lapply(unique(datSum2$Product), function(y_level) {
datSum3 <- datSum2[datSum2$Product == y_level,]
datSum3 <- datSum3 %>%
group_by(Sub_Product) %>%
summarize(Quantity = mean(get(input$avgselectPA)))
datSum3 <- arrange(datSum3,desc(Quantity))
Lvl3dfStatus <- tibble(name = datSum3$Sub_Product,y = datSum3$Quantity)
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)
)
})
}
shinyApp(ui, server)
How to drill down to the third hierarchy using higherchart package in R?
After banging my head against the wall for last couple of days, I was able to debug and get the answer. Please find attached code. I would like to thank Kevin for this (source: R Highcharter: Multi-level drilldown with multiple series)
Test <- data.frame(Group = c("A", "A", "A", "A", "A", "A", "A", "A",
"B", "B", "B", "B", "B", "B", "B", "B"),
Group_Two = c("AA", "AAA", "AA", "AAA", "AAA", "AA",
"AA", "AAA", "BB", "BBB", "BB", "BBB",
"BB", "BBB", "BB", "BBB"),
Group_Three = c("AJX", "ABX", "AJX", "ABX", "APX", "ANX",
"ANX", "APX", "BJX", "BBX", "BJX", "BBX",
"BPX", "BNX", "BPX", "BNX"),
Group_Four = c("TH", "TH", "SW", "SW", "GC", "PB", "JB",
"NX", "TH", "TH", "SW", "SW", "GC", "PB",
"JB", "NX"),
Value = c(5293, 78225, 33235, 56022, 13056, 6160, 44067, 75529,
95679, 98172, 27159, 77475, 37838, 25897, 88400, 28484))
TestSum <- Test %>%
group_by(Group) %>%
summarize(Quantity = sum(Value)
)
TestSum <- arrange(TestSum,desc(Quantity))
Lvl1dfStatus <- tibble(name = TestSum$Group, y = TestSum$Quantity, drilldown = tolower(name))
Level_2_Drilldowns_Test <- lapply(unique(Test$Group), function(x_level) {
TestSum2 <- subset(Test, Test$Group %in% x_level)
#TestSum2 <- Test[Test$Group == x_level,]
TestSum2 <- TestSum2 %>%
group_by(Group_Two) %>%
summarize(Quantity = sum(Value)
)
TestSum2 <- arrange(TestSum2,desc(Quantity)) ###CHECK
Lvl2dfStatus <- tibble(name = TestSum2$Group_Two, y = TestSum2$Quantity, drilldown = tolower(paste(x_level, name, sep = "_")))
list(id = tolower(x_level), type = "column", data = list_parse(Lvl2dfStatus))
})
Level_3_Drilldowns_Test <- lapply(unique(Test$Group), function(x_level) {
TestSum2 <- subset(Test, Test$Group %in% x_level)
#TestSum2 <- Test[Test$Group == x_level,]
lapply(unique(TestSum2$Group_Two), function(y_level) {
TestSum3 <- subset(TestSum2, TestSum2$Group_Two %in% y_level)
#TestSum3 <- TestSum2[TestSum2$Group_Two == y_level,]
TestSum3 <- TestSum3 %>%
group_by(Group_Three) %>%
summarize(Quantity = sum(Value)
)
TestSum3 <- arrange(TestSum3,desc(Quantity))
Lvl3dfStatus <- tibble(name = TestSum3$Group_Three,y = TestSum3$Quantity, drilldown = tolower(paste(x_level, y_level, name, sep = "_")))
list(id = tolower(paste(x_level, y_level, sep = "_")), type = "column", data = list_parse(Lvl3dfStatus))
})
})%>% unlist(recursive = FALSE)
Level_4_Drilldowns <- lapply(unique(Test$Group), function(x_level) {
TestSum2 <- subset(Test, Test$Group %in% x_level)
#TestSum2 <- Test[Test$Group == x_level,]
lapply(unique(TestSum2$Group_Two), function(y_level) {
TestSum3 <- subset(TestSum2, TestSum2$Group_Two %in% y_level)
#TestSum3 <- TestSum2[TestSum2$Group_Two == y_level,]
lapply(unique(TestSum3$Group_Three), function(z_level) {
TestSum4 <- subset(TestSum3, TestSum3$Group_Three %in% z_level)
#TestSum4 <- TestSum3[TestSum3$Group_Three == z_level,]
TestSum4 <- TestSum4 %>%
group_by(Group_Four) %>%
summarize(Quantity = sum(Value)
)
TestSum4 <- arrange(TestSum4,desc(Quantity))
Lvl4dfStatus <- tibble(name = TestSum4$Group_Four,y = TestSum4$Quantity)
list(id = tolower(paste(x_level, y_level, z_level, sep = "_")), type = "column", data = list_parse2(Lvl4dfStatus))
})
})%>% unlist(recursive = FALSE)
}) %>% 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_Test, Level_3_Drilldowns_Test, Level_4_Drilldowns)
)
Rshiny Highcharter how can I create a piechart that drills down into another pie chart?
You can specify the type parameter in hc_drilldown() as shown by editing the example from the highcharter reference page.
library(highcharter)
library(dplyr)
library(purrr)
df <- tibble(
name = c("Animals", "Fruits"),
y = c(5, 2),
drilldown = tolower(name)
)
df
#> # A tibble: 2 x 3
#> name y drilldown
#> <chr> <dbl> <chr>
#> 1 Animals 5 animals
#> 2 Fruits 2 fruits
hc <- highchart() %>%
hc_title(text = "Basic drilldown") %>%
hc_xAxis(type = "category") %>%
hc_legend(enabled = FALSE) %>%
hc_plotOptions(
series = list(
boderWidth = 0,
dataLabels = list(enabled = TRUE)
)
) %>%
hc_add_series(
data = df,
type = "pie",
hcaes(name = name, y = y),
name = "Things",
colorByPoint = TRUE
)
dfan <- data.frame(
name = c("Cats", "Dogs", "Cows", "Sheep", "Pigs"),
value = c(4, 3, 1, 2, 1)
)
dffru <- data.frame(
name = c("Apple", "Organes"),
value = c(4, 2)
)
dsan <- list_parse2(dfan)
dsfru <- list_parse2(dffru)
hc <- hc %>%
hc_drilldown(
allowPointDrilldown = TRUE,
series = list(
list(
id = "animals",
type = "pie",
data = dsan
),
list(
id = "fruits",
type = "pie",
data = dsfru
)
)
)
print(hc)
R Highcharter: dynamic drilldown in Shiny on the fly
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)
R Package Highcharter: How do I drilldown to multiple series stacked column graph?
I needed to rebuild a little bit your code. You need to use chart.addSingleSeriesAsDrilldown() method in chart.events.drilldown event. This is your whole code:
hc <- highchart() %>%
hc_chart(
type = "column",
events = list(
drilldown = JS(
"function(e) {
if (!e.seriesOptions) {
var chart = this;
chart.addSingleSeriesAsDrilldown(e.point, {
color: Highcharts.getOptions().colors[0],
name: 'Completed',
data: [
['Job A1', 40],
['Job B1', 35]
]
});
chart.addSingleSeriesAsDrilldown(e.point, {
color: Highcharts.getOptions().colors[1],
name: 'No progress',
data: [
['Job A1', 60],
['Job B1', 65]
]
});
chart.applyDrilldown();
}
}"
)
)
) %>%
Related Topics
Merge by Range in R - Applying Loops
Use of Lapply .Sd in Data.Table R
Put a Break in the Y-Axis of a Histogram
Split Dataframe by Levels of a Factor and Name Dataframes by Those Levels
Create Empty Data Frame with Column Names by Assigning a String Vector
How to Draw the Boxplot with Significant Level
Rstudio Not Picking the Encoding I'm Telling It to Use When Reading a File
Embedded Nul in String' Error When Importing CSV with Fread
Differencebetween Parent.Frame() and Parent.Env() in R; How Do They Differ in Call by Reference
Marker Mouse Click Event in R Leaflet for Shiny
Get_Map Not Passing the API Key (Http Status Was '403 Forbidden')
Increase Resolution of Color Scale for Values Close to Zero