R Highcharter：Shiny 中的动态多级钻取

Question

我正在尝试使用highcharter 和shiny 中的动态数据创建一个多层钻取图。我可以使用带有一组 input 的 R 代码来完成此操作，但是当我将它放入一个闪亮的应用程序并尝试让它动态地对数据进行子集时，它会失败。

以下是在R 中工作的代码（仅从农场向下钻取到绵羊）：

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

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

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

input <- "Farm"
input2 <- "Sheep"


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

    #Second Tier
    datSum2 <- dat[dat$x == input,]

    datSum2 <- datSum2 %>%
      group_by(y) %>%
      summarize(Quantity = sum(a)
      )
    datSum2 <- arrange(datSum2,desc(Quantity))
    Lvl2dfStatus <- tibble(name = datSum2$y,y = datSum2$Quantity, drilldown = tolower(name))

    #Third Tier
    datSum2 <- dat[dat$x == input,]
    datSum3 <- datSum2[datSum2$y == input2,]

    datSum3 <- datSum3 %>%
      group_by(z) %>%
      summarize(Quantity = sum(a)
      )
    datSum3 <- arrange(datSum3,desc(Quantity))
    Lvl3dfStatus <- tibble(name = datSum3$z,y = datSum3$Quantity)

    #Graph
    ClickedTest <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.name);}")

    highchart() %>%
      hc_xAxis(type = "category") %>%
      hc_add_series(Lvl1dfStatus, "column", hcaes(x = name, y = y), color = "#E4551F") %>%
      hc_plotOptions(column = list(stacking = "normal",
                                   events = list(click = ClickedTest))) %>%
      hc_drilldown(
        allowPointDrilldown = TRUE,
        series = list(
          list(id = tolower(input), type = "column", data = list_parse(Lvl2dfStatus)),
          list(id = tolower(input2), type = "column", data = list_parse2(Lvl3dfStatus))
        )
      )

以下是将input 更改为动态时在Shiny 中失败的代码：

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

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

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

# input <- "Farm"
# input2 <- "Sheep"

header <- dashboardHeader()
body <- dashboardBody(

  highchartOutput("Test"),
  verbatimTextOutput("trial")

)
sidebar <- dashboardSidebar()

ui <- dashboardPage(header, sidebar, body)

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

Lvl1ClickHardCoded <- ""

  output$Test <- renderHighchart({

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

      #Second Tier
      rowcheck <- dat[dat$x == input$ClickedInput,]
      if (nrow(rowcheck)!=0){

        datSum2 <- dat[dat$x == input$ClickedInput,]
        datSum2 <- datSum2 %>%
          group_by(y) %>%
          summarize(Quantity = sum(a)
          )
        datSum2 <- arrange(datSum2,desc(Quantity))
        Lvl2dfStatus <- tibble(name = datSum2$y,y = datSum2$Quantity, drilldown = tolower(name))

        Lvl1ClickHardCoded <<- input$ClickedInput
        Lvl1id <<- tolower(input$ClickedInput)
      } 
      else{
        Lvl2dfStatus <- data.table(Group.1=numeric(), x=numeric())
        Lvl2dfStatus <- tibble(name = Lvl2dfStatus$Group.1,y = Lvl2dfStatus$x)
        Lvl1id <- ""
      }

      #Third Tier
      rowcheck <- dat[dat$x == Lvl1ClickHardCoded,]
      rowcheck <- rowcheck[rowcheck$y == input$ClickedInput,]
      if (nrow(rowcheck)!=0){
        datSum2 <- dat[dat$x == Lvl1ClickHardCoded,]
        datSum3 <- datSum2[datSum2$y == input$ClickedInput,]

        datSum3 <- datSum3 %>%
          group_by(z) %>%
          summarize(Quantity = sum(a)
          )
        datSum3 <- arrange(datSum3,desc(Quantity))
        Lvl3dfStatus <- tibble(name = datSum3$z,y = datSum3$Quantity)

        Lvl2id <<- tolower(input$ClickedInput)
      } 
      else{
        Lvl3dfStatus <- data.table(Group.1=numeric(), x=numeric())
        Lvl3dfStatus <- tibble(name = Lvl3dfStatus$Group.1,y = Lvl3dfStatus$x)
        Lvl2id <- ""
      }

      #Graph
      ClickedTest <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.name);}")

      highchart() %>%
        hc_xAxis(type = "category") %>%
        hc_add_series(Lvl1dfStatus, "column", hcaes(x = name, y = y), color = "#E4551F") %>%
        hc_plotOptions(column = list(stacking = "normal",
                                     events = list(click = ClickedTest))) %>%
        hc_drilldown(
          allowPointDrilldown = TRUE,
          series = list(
            list(id = Lvl1id, type = "column", data = list_parse(Lvl2dfStatus)),
            list(id = Lvl2id, type = "column", data = list_parse2(Lvl3dfStatus))
          )
        )
  })

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

}


shinyApp(ui, server)

Answer 1

您的方法有点被点击功能误导了。这是完全没有必要的，因为（从不闪亮的示例中可以看出）Highcharts 有自己的机制来检测系列点击，并且可以自己查找和呈现向下钻取。

您试图捕捉点击事件使得 Highcharts 图表构建功能每次都重新呈现（重置任何向下钻取），因此您根本看不到任何向下钻取事件。

解决方案是将您的工作 Highcharts 示例复制到 renderHighchart 函数中。您会立即看到“农场”和“绵羊”下拉菜单正常工作。

我想您对子级别名称使用术语“输入”感到困惑，因为它们根本没有输入（在闪亮的意义上）。要使向下钻取正常工作，您必须在创建 Highcharts 图表时预定义向下钻取集。因此，您提前告诉插件将使用哪些向下钻取，Highchart 仅根据您指定的 ID 向下钻取。

我编辑了您的代码，以便在循环中创建所有可能的向下钻取并且一切正常：

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

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

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

header <- dashboardHeader()
body <- dashboardBody(

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

)
sidebar <- dashboardSidebar()

ui <- dashboardPage(header, sidebar, body)

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

}


shinyApp(ui, server)

如果出于任何原因，您不应该满足于预先收集所有明细，则有一个用于即时添加明细的 api。尝试搜索 Highcharts 和“addSeriesAsDrilldown”。但是，我不确定这是否可以在 JavaScript 之外访问。