如何使用 Highcharter 创建两个独立的向下钻取图？

Posted 2023-03-24

技术标签:

【中文标题】如何使用 Highcharter 创建两个独立的向下钻取图？【英文标题】：how to create two independent drill down plot using Highcharter? 【发布时间】：2020-04-13 08:45:11 【问题描述】：

我正在开发包含两个向下钻取图表的闪亮应用程序，它们都从同一个数据文件中读取，唯一的区别是第一个图表执行求和，而第二个图表获得平均值，问题是我对两个图表进行的任何更改还是有冲突，这里是用到的代码

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)

只需复制并粘贴上面的代码，然后尝试在第一个图表中深入查看它不会响应的总计数细分，而图表 2 将响应点击图表一列

每列上的悬停文本显示两个图表之间的差异就像第一个显示总和而第二个显示平均值一样。

数据框可能很长，但它是我的数据集的一个样本

小要求，我只需要 两个图上的第 3 级作为折线图

更新另一个不成功的试用版------------------

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)
   )
   TYT<-reactive(
     datz()%>%select(1:4)
   )
   nont<-reactive(
     datz()%>%pull(input$avgselectPA)
   )
   print(datz())
   str(datz())
   
   print(nont())
   str(nont())
   urt<-reactive(
     data_frame(TYT(),nont())
   )
   print(urt())
   str(urt())
   
   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$avgPA<-renderHighchart(
     datSum <- urt() %>%
       group_by(Main_Product) %>%
       summarize(Quantity = mean('nont')
       )
     datSum <- arrange(datSum,desc(Quantity))
     Lvl1dfStatus <- tibble(name = datSum$Main_Product, 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(urt()$Main_Product), function(x_level) 
       # x_level is what you called 'input' earlier.
       datSum2 <- urt()[urt()$Main_Product == x_level,]
       
       datSum2 <- datSum2 %>%
         group_by(Product) %>%
         summarize(Quantity = mean('nont')
         )
       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$Product,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(urt()$Main_Product), function(x_level) 
       
       datSum2 <- urt()[urt()$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('nont')
           )
         datSum3 <- arrange(datSum3,desc(Quantity))
         
         Lvl3dfStatus <- tibble(name = datSum3$Sub_Product,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 = Product), color = "#E4551F") %>%
       hc_plotOptions(column = list(stacking = "normal")) %>%
       hc_drilldown(
         allowPointDrilldown = TRUE,
         series = c(Level_2_Drilldowns, Level_3_Drilldowns)
       )
   )
   #THE NEXT ) is for observe
   ) 

shinyApp(ui, server)

【问题讨论】：

嗨，约翰，对不起，我之前没有和 highcharter 合作过，但是你的问题和这个 ***.com/questions/17173271/… 类似吗不完全是，非常感谢您的支持 【参考方案1】：

在这里，两个图表独立于彼此的钻取操作。

我简化了你的代码，并且你有很多不需要的 observes 和 reactives（至少在这个例子中）。

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)

【讨论】：

以上是关于如何使用 Highcharter 创建两个独立的向下钻取图？的主要内容，如果未能解决你的问题，请参考以下文章

不使用 hchart() 的 Highcharter 堆叠列分组

Highcharter 中的超链接条形图

如何在 R 中将 Highcharter 图表保存为 gif？

如何获得 highcharter 来表示预测对象？

Highcharter - 单击事件以过滤图表中的数据

如何在highcharter中生成因子为y的散点图？