R Highcharter：Shiny中的动态多级深化

Question

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

以下是在R中有效的代码（仅从Farm向下追溯到Sheep）：

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

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

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

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


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

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

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

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

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

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

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

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

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拥有自己的机制来检测系列点击并可以自行查找和呈现明细。

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

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

我想您通过在子级别名称中使用术语“输入”来混淆自己，因为它们根本就没有输入（在闪亮的意义上）。要使向下钻取正常工作，要做的就是在创建Highcharts图表时 pre 定义向下钻取集。因此，您可以提前告诉插件将使用哪些细分，而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之外访问。