how to create two independent drill down plot using Highcharter?

john198809 · December 22, 2019, 2:29pm

I'm working on shiny app that contains two drill down charts, both read from same data file the only difference is the first chart excute summation, while the second one gets averages, the issue is whatever the change I make both charts still conflicting , here is the used code

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)
all_products<-c("Furniture","drinks","groceries","dairy","technology")

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 = all_products, justified = TRUE,
           individual = TRUE)
  )),
  fluidRow(
    
    highchartOutput("accuPA",height = "300px"),
    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) {
  observe({
    print(input$l1PAD)
    datz<-reactive({
      dat%>%filter(cate==input$l1PAD)
    })
    print(datz())
    str(datz())
    
    output$accuPA <- renderHighchart({
      summarized <- datz() %>%
        group_by(Main_Product) %>%
        summarize(Quantity = sum(!!sym(input$accuselectPA)))
      summarized <- arrange(summarized, desc(Quantity))
      tibbled <- tibble(name = summarized$Main_Product, y = summarized$Quantity)
      drilldownHandler <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.drilldown);}")
      installDrilldownReceiver <- JS("function() {
                                   var chart = this;
                                   Shiny.addCustomMessageHandler('drilldown', function(message) {
                                   var point = chart.get(message.point)
                                   chart.addSeriesAsDrilldown(point, message.series);
                                   });
  }")
      highchart() %>%
        hc_chart(events = list(load = installDrilldownReceiver, drilldown = drilldownHandler)) %>%
        hc_xAxis(type = "category") %>%
        hc_add_series(tibbled, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#e6b30a") %>%
        hc_plotOptions(column = list(stacking = "normal")) %>%
        hc_drilldown(allowPointDrilldown = TRUE)
    })
    observeEvent(input$ClickedInput, {
      levels <- strsplit(input$ClickedInput, "_", fixed = TRUE)[[1]]
      resemblences <- c("Main_Product", "Product", "Sub_Product")
      dataSubSet <- datz()
      for (i in 1:length(levels)) {
        dataSubSet <- datz()[datz()[[resemblences[i]]] == levels[i],]}
      print(dataSubSet)
      str(dataSubSet)
      normalized <- data.frame(category = dataSubSet[[resemblences[length(levels) + 1]]],amount= dataSubSet[, input$accuselectPA])
      print(normalized)
      str(normalized)
      summarized <- normalized %>%group_by(category) %>%  summarize(Quantity = sum(amount))
      summarized <- arrange(summarized, desc(Quantity))
      tibbled <- tibble(name = summarized$category, y = summarized$Quantity)
      nextLevelCodes = lapply(tibbled$name, function(fac) {paste(c(levels, as.character(fac)), collapse = "_")
      }) %>% unlist
      tibbled$id = nextLevelCodes
      if (length(levels) < length(resemblences) - 1) {
        tibbled$drilldown = nextLevelCodes
      }
      session$sendCustomMessage("drilldown", list(
        series = list(type = "column",name = paste(levels, sep = "_"),data = list_parse(tibbled)
        ),
        point = input$ClickedInput
      ))
    })
    output$trial <- renderText({input$ClickedInput})
    
  }) 
  
  observe({
    print(input$l1PAD)
    datz2<-reactive({
      dat%>%filter(cate==input$l1PAD)
    })
    print(datz2())
    str(datz2())
    output$avgPA <- renderHighchart({
    
      summarized2 <- datz2() %>%
        group_by(Main_Product) %>%
        summarize(Quantity2 = mean(!!sym(input$avgselectPA)))
      summarized2 <- arrange(summarized2, desc(Quantity2))
      tibbled2 <- tibble(name = summarized2$Main_Product, y = summarized2$Quantity2)
      drilldownHandler2 <- JS("function(event) {Shiny.onInputChange('ClickedInput2', event.point.drilldown);}")
      installDrilldownReceiver2 <- JS("function() {
                                   var chart = this;
                                   Shiny.addCustomMessageHandler('drilldown', function(message) {
                                   var point = chart.get(message.point)
                                   chart.addSeriesAsDrilldown(point, message.series);
                                   });
  }")
      highchart() %>%
        hc_chart(events = list(load = installDrilldownReceiver2, drilldown = drilldownHandler2)) %>%
        hc_xAxis(type = "category") %>%
        hc_add_series(tibbled2, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#e6b30a") %>%
        hc_plotOptions(column = list(stacking = "normal")) %>%
        hc_drilldown(allowPointDrilldown = TRUE)
    })
    observeEvent(input$ClickedInput2, {
      levels2 <- strsplit(input$ClickedInput2, "_", fixed = TRUE)[[1]]
      resemblences2 <- c("Main_Product", "Product", "Sub_Product")
      dataSubSet2 <- datz2()
      for (i in 1:length(levels2)) {
        dataSubSet2 <- datz2()[datz2()[[resemblences2[i]]] == levels2[i],]}
      print(dataSubSet2)
      str(dataSubSet2)
      normalized2 <- data.frame(category = dataSubSet2[[resemblences2[length(levels2) + 1]]],amount= dataSubSet2[, input$avgselectPA])
      print(normalized2)
      str(normalized2)
      summarized2 <- normalized2 %>%group_by(category) %>%  summarize(Quantity2 = mean(amount))
      summarized2 <- arrange(summarized2, desc(Quantity2))
      tibbled2 <- tibble(name = summarized2$category, y = summarized2$Quantity2)
      nextLevelCodes2 = lapply(tibbled2$name, function(fac) {paste(c(levels2, as.character(fac)), collapse = "_")
      }) %>% unlist
      tibbled2$id = nextLevelCodes2
      if (length(levels2) < length(resemblences2) - 1) {
        tibbled2$drilldown = nextLevelCodes2
      }
      session$sendCustomMessage("drilldown", list(
        series = list(type = "column",name = paste(levels2, sep = "_"),data = list_parse(tibbled2)
        ),
        point = input$ClickedInput2
      ))
    })
    output$trial <- renderText({input$ClickedInput2})
    
  }) 
}
shinyApp(ui, server)

all needed is just copy and paste the code above and try to drill down in the first chart to see the breakdown of total count it will not respond while chart 2 will respond to the click on chart one column

the hover text on each column shows the difference between two charts
as how the first one show the summation while the second one shows the average value.

the data frame might be long but it is a sample of my dataset

minor request, I need only the 3rd level on both plots to be line chart

raytong · December 23, 2019, 9:28am

Hi @john198809. If I didn't get wrong, you want both plots in synchronize and plot line chart in 3rd levels. First, your sample data have somethings wrong, there are two indoor, one with space at the back and I correct it (you can change it back if the actual data should like this.) Moreover, I rename the input 11PAD to PAD which name started with number sometimes cause problem.

The main problem of the code is you name the handlers with the same name in Shiny.addCustomMessageHandler, so the lately added avgPA will cover the accuPA. Both plots give out the same input ClickedInput when clicked. And both plots update triggered by input$ClickedInput and constructs tables for accuPA and avgPA separately. Finally, pass the data tables to the charts by sendCustomMessage to correspondence handlers.

For line chart, just check update which levels and select different plot type.

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)
all_products<-c("Furniture","drinks","groceries","dairy","technology")

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 = "PAD", label = NULL,size = "lg",
               choices = all_products, justified = TRUE,
               individual = TRUE)
    )),
    fluidRow(
        
        highchartOutput("accuPA",height = "300px"),
        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) {
    
    datz<-reactive({
        dat%>%filter(cate==input$PAD)
    })
    
    output$accuPA <- renderHighchart({
        summarized <- datz() %>%
            group_by(Main_Product) %>%
            summarize(Quantity = sum(!!sym(input$accuselectPA)))
        # print(summarized)
        
        tibbled <- tibble(name = summarized$Main_Product, y = summarized$Quantity)
        
        drilldownHandler <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.drilldown);}")
        
        installDrilldownReceiver <- JS("function() {
                                   var chart = this;
                                   Shiny.addCustomMessageHandler('drilldownAccu', function(message) {
                                   var point = chart.get(message.point)
                                   chart.addSeriesAsDrilldown(point, message.series);
                                   });}")
        
        highchart() %>%
            hc_chart(events = list(load = installDrilldownReceiver, drilldown = drilldownHandler)) %>%
            hc_xAxis(type = "category") %>%
            hc_add_series(tibbled, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#e6b30a") %>%
            hc_plotOptions(column = list(stacking = "normal")) %>%
            hc_drilldown(allowPointDrilldown = TRUE)
    })
    
    output$avgPA <- renderHighchart({
        summarized <- datz() %>%
            group_by(Main_Product) %>%
            summarize(Quantity = mean(!!sym(input$avgselectPA)))
        print(summarized)
        
        tibbled <- tibble(name = summarized$Main_Product, y = summarized$Quantity)
        
        drilldownHandler <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.drilldown);}")
        
        installDrilldownReceiver <- JS("function() {
                                   var chart = this;
                                   Shiny.addCustomMessageHandler('drilldownAvg', function(message) {
                                   var point = chart.get(message.point)
                                   chart.addSeriesAsDrilldown(point, message.series);
                                   });}")
        
        highchart() %>%
            hc_chart(events = list(load = installDrilldownReceiver, drilldown = drilldownHandler)) %>%
            hc_xAxis(type = "category") %>%
            hc_add_series(tibbled, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#e6b30a") %>%
            hc_plotOptions(column = list(stacking = "normal")) %>%
            hc_drilldown(allowPointDrilldown = TRUE)
    })
    
    observeEvent(input$ClickedInput, {
        str(input$ClickedInput)
        levels <- strsplit(input$ClickedInput, "_", fixed = TRUE)[[1]]
        resemblences <- c("Main_Product", "Product", "Sub_Product")
        dataSubSet <- datz()
        for (i in 1:length(levels)) {
            dataSubSet <- datz()[datz()[[resemblences[i]]] == levels[i],]}
        print(dataSubSet)
        str(dataSubSet)
        normalizedAccu <- data.frame(category = dataSubSet[[resemblences[length(levels) + 1]]],amount= dataSubSet[, input$accuselectPA])
        normalizedAvg <- data.frame(category = dataSubSet[[resemblences[length(levels) + 1]]],amount= dataSubSet[, input$avgselectPA])
        summarizedAccu <- normalizedAccu %>%group_by(category) %>%  summarize(Quantity = sum(amount))
        summarizedAvg <- normalizedAvg %>%group_by(category) %>%  summarize(Quantity = mean(amount))
        summarizedAccu <- arrange(summarizedAccu, desc(Quantity))
        summarizedAvg <- arrange(summarizedAvg, desc(Quantity))
        tibbledAccu <- tibble(name = summarizedAccu$category, y = summarizedAccu$Quantity)
        tibbledAvg <- tibble(name = summarizedAvg$category, y = summarizedAvg$Quantity)
        nextLevelCodes = lapply(tibbledAccu$name, function(fac) {paste(c(levels, as.character(fac)), collapse = "_")
        }) %>% unlist
        tibbledAccu$id = nextLevelCodes
        tibbledAvg$id = nextLevelCodes
        if (length(levels) < length(resemblences) - 1) {
            tibbledAccu$drilldown = nextLevelCodes
            tibbledAvg$drilldown = nextLevelCodes
        }
        if(length(levels) == 2) {
            session$sendCustomMessage("drilldownAccu", list(
                series = list(type = "line",name = paste(levels, sep = "_"),data = list_parse(tibbledAccu)
                ),
                point = input$ClickedInput
            ))
            session$sendCustomMessage("drilldownAvg", list(
                series = list(type = "line",name = paste(levels, sep = "_"),data = list_parse(tibbledAvg)
                ),
                point = input$ClickedInput
            ))
        } else {
            session$sendCustomMessage("drilldownAccu", list(
                series = list(type = "column",name = paste(levels, sep = "_"),data = list_parse(tibbledAccu)
                ),
                point = input$ClickedInput
            ))
            session$sendCustomMessage("drilldownAvg", list(
                series = list(type = "column",name = paste(levels, sep = "_"),data = list_parse(tibbledAvg)
                ),
                point = input$ClickedInput
            ))
        }
    })
}
shinyApp(ui, server)

system · February 15, 2020, 1:28pm

This topic was automatically closed 54 days after the last reply. New replies are no longer allowed.