R Highcharter: динамическое многоуровневое развертывание в Shiny - PullRequest
Новая
       14

R Highcharter: динамическое многоуровневое развертывание в Shiny

0 голосов
/ 13 марта 2019

Я пытаюсь создать многослойный детализированный график, используя highcharter с динамическими данными в shiny.Я могу сделать это, используя только R-код с набором input, но когда я помещаю его в блестящее приложение и пытаюсь создать динамическое подмножество данных, происходит сбой.

Ниже приведен код, которыйработает в 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))
        )
      )

Ниже приведен код, который не срабатывает в 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)

1 Ответ

1 голос
/ 14 марта 2019

Ваш подход был введен в заблуждение функцией щелчка. Это совершенно не нужно, поскольку (как видно из не блестящего примера) Highcharts имеет свои собственные механизмы для обнаружения последовательных щелчков и может самостоятельно находить и отображать детализацию.

Вы пытались отловить событие click, заставляя функцию построения диаграммы Highcharts каждый раз перерисовываться (сбрасывая все детализации), поэтому вы не могли видеть никаких событий детализации вообще.

Решение состоит в том, чтобы просто скопировать ваш рабочий пример Highcharts в функцию renderHighchart. Вы сразу увидите, что выпадающие списки «Ферма» и «Овцы» работают.

Я полагаю, что вы вводили себя в заблуждение, используя термины "вход" для имен подуровней, поскольку они вообще не вводятся (в блестящем смысле). Для правильной работы детализации необходимо pre определить наборы детализации при создании диаграммы Highcharts. Таким образом, вы заранее сообщаете плагину, какие развертки будут использоваться, а Highchart - только по указанным вами идентификаторам.

Я отредактировал ваш код так, чтобы все возможные развертки создавались в цикле и все работало: 

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.

...