R Highcharter：“動態”中的“動態”深入分析

Question

我試圖創建一個使用多層明細圖highcharter與動態數據shiny 。 在SO社區的幫助下（對@K。Rohde的大喊），可以通過遍歷所有可能的向下鑽取來解決問題。 我實際的閃亮應用程序將關閉數百個可能的向下鑽取，並且我不想將額外的時間添加到應用程序中，而是使用addSingleSeriesAsDrilldown即時創建向下鑽取。 不確定如何在R中使用它。

以下是我的問題遍歷所有向下鑽取可能性的工作示例：

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)

以下是使用addSingleSeriesAsDrilldown的R代碼示例，但我不確定如何應用它。 我需要動態更改JS字符串。

library(highcharter)
highchart() %>%
  hc_chart(
    events = list(
      drilldown = JS("function(e) {
        var chart = this,
        newSeries = [{
          color: 'red',
          type: 'column',
          stacking: 'normal',
          data: [1, 5, 3, 4]
        }, {
          type: 'column',
          stacking: 'normal',
          data: [3, 4, 5, 1]
        }]
        chart.addSingleSeriesAsDrilldown(e.point, newSeries[0]);
        chart.addSingleSeriesAsDrilldown(e.point, newSeries[1]);
        chart.applyDrilldown();
      }")
    )
  ) %>%
  hc_add_series(type = "pie", data= list(list(y = 3, drilldown = TRUE), list(y = 2, drilldown = TRUE))) %>%
  hc_drilldown(
    series = list()
  )

Answer 1

您對此有一個雙重答案。 有兩種基本方法可以實現您想要的。 一種是使用Highcharts提供的向下鑽取，即使您必須從R后端收集子系列。 另一種方法是僅使用Highcharts進行渲染，而僅替換Highcharts向下鑽取並實施R驅動的向下鑽取。

因為它可能更容易消化，所以我將從后者開始。

Shiny的追溯功能

只是忘了Highcharts可以進行深入分析。 您已經擁有了所需的一切，因為您知道如何添加事件廣播器，該廣播器會告訴您單擊圖形上的點的時間。

為此，您確實使用了renderHighcharts的反應性，並使用代表當前向下鑽取的不同數據集重新渲染了圖表。 過程如下：單擊“ Farm”列，現在使用“ Farm”子集呈現圖表。 單擊下一列，您將構建更深層的嵌套子集並進行渲染。 Highcharts唯一要提供的，您必須自己做的，就是添加一個“后退”按鈕以再次展開。

首先，下面的解決方案可能會令人困惑，因為它由一些反應式表達式組成，這些表達式收斂到一個包含當前鑽取狀態的反應式數據集中。 請注意，我們必須將當前鑽取狀態存儲在后端中，以便能夠進行回鑽並鑽取更深的層次。

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(
  actionButton("Back", "Back"),
  highchartOutput("Working"),
  verbatimTextOutput("trial")

)
sidebar <- dashboardSidebar()

ui <- dashboardPage(header, sidebar, body)

server <- function(input, output, session) {
  # To hold the current drilldown status as list, i.e. list("Farm", "Sheep")
  state <- reactiveValues(drills = list())

  # Reactive reacting to the above drill list, giving out a normalized data.frame (category, amount)
  filtered <- reactive({
    if (length(state$drills) == 0) {
      # Case no drills are present.
      data.frame(category = dat$x, amount = dat$a)

    } else if (length(state$drills) == 1) {
      # Case only x_level drill is present.
      x_level = state$drills[[1]]
      sub <- dat[dat$x == x_level,]
      data.frame(category = sub$y, amount = sub$a)

    } else if (length(state$drills) == 2) {
      # Case x_level and y_level drills are present.

      x_level = state$drills[[1]]
      y_level = state$drills[[2]]
      sub <- dat[dat$x == x_level & dat$y == y_level,]
      data.frame(category = sub$z, amount = sub$a)
    }
  })

  # Since Drilldown from Highcharts is not used: Install own click handler that builds up the drill list.
  observeEvent(input$ClickedInput, {
    if (length(state$drills) < 2) {
      # Push drill name.
      state$drills <<- c(state$drills, input$ClickedInput)
    }
  })

  # Since Drilldown from Highcharts is not used: Back button is manually inserted.
  observeEvent(input$Back, {
    if (length(state$drills) > 0) {
      # Pop drill name.
      state$drills <<- state$drills[-length(state$drills)]
    }
  })

  output$Working <- renderHighchart({

    # Using normalized names from above.
    summarized <- filtered() %>%
      group_by(category) %>%
      summarize(Quantity = sum(amount))

    summarized <- arrange(summarized, desc(Quantity))
    tibbled <- tibble(name = summarized$category, y = summarized$Quantity)

    # This time, click handler is needed.
    pointClickFunction <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.name);}")

    highchart() %>%
      hc_xAxis(type = "category") %>%
      hc_add_series(tibbled, "column", hcaes(x = name, y = y), color = "#E4551F") %>%
      hc_plotOptions(column = list(stacking = "normal", events = list(click = pointClickFunction)))
  })

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

shinyApp(ui, server)

Highcharts的追溯功能

在這種情況下，您需要將數據從后端發送到JavaScript，以利用圖表庫中的addSeriesAsDrilldown方法。 這以一種異步方式工作：Highcharts發出警報，要求某點向下鑽取（通過單擊它）。 然后，后端必須計算相應的數據集，然后將數據集報告回Highcharts，以便可以對其進行渲染。 為此，我們使用CustomMessageHandler。

我們不會在原始Highcharts中添加任何向下鑽取系列，但會告訴Highcharts當請求向下鑽取（drilldown-event）時必須發送什么關鍵字。 請注意，這不是單擊事件，而是更專門的事件（僅在有向下鑽取的情況下）。

我們發送回的數據必須正確格式化，因此在這里您需要對Highcharts（JS，而不是highcharter）的api有所了解。

創建向下鑽取數據的方法有很多，因此我在這里編寫了另一個函數，它甚至可以更廣泛地執行此操作。 但是，最重要的是，您使用的級別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({
    # Make the initial data.
    summarized <- dat %>%
      group_by(x) %>%
      summarize(Quantity = sum(a))

    summarized <- arrange(summarized, desc(Quantity))
    tibbled <- tibble(name = summarized$x, y = summarized$Quantity)

    # This time, click handler is needed.
    drilldownHandler <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.drilldown);}")

    # Also a message receiver for later async drilldown data has to be set.
    # Note in the JS: message.point is going to be the point ID. Highcharts addSeriesAsDrilldown need a point to attach
    #   the drilldown series to. This is retrieved via chart.get which takes the ID of any Highcharts Element.
    #   This means: IDs are kind of important here, so keep track of what you assign.
    installDrilldownReceiver <- JS("function() {
      var chart = this;
      Shiny.addCustomMessageHandler('drilldown', function(message) {
        var point = chart.get(message.point)
        chart.addSeriesAsDrilldown(point, message.series);
      });
    }")

    highchart() %>%
      # Both events are on the chart layer, not by series. 
      hc_chart(events = list(load = installDrilldownReceiver, drilldown = drilldownHandler)) %>%
      hc_xAxis(type = "category") %>%
      # Note: We add a drilldown directive (= name) to tell Highcharts that this has a drilldown functionality.
      hc_add_series(tibbled, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#E4551F") %>%
      hc_plotOptions(column = list(stacking = "normal")) %>%
      hc_drilldown(allowPointDrilldown = TRUE)
  })

  # Drilldown handler to calculate the correct drilldown
  observeEvent(input$ClickedInput, {
    # We will code the drill levels to be i.e. Farm_Car. By that we calculate the next Sub-Chart.
    levels <- strsplit(input$ClickedInput, "_", fixed = TRUE)[[1]]
    # This is just for generalizing this function to work in all the levels and even be expandable to further more levels.
    resemblences <- c("x", "y", "z")

    dataSubSet <- dat

    # We subsequently narrow down the original dataset by walking through the drilled levels
    for (i in 1:length(levels)) {
      dataSubSet <- dat[dat[[resemblences[i]]] == levels[i],]
    }

    # Create a common data.frame for all level names.
    normalized <- data.frame(category = dataSubSet[[resemblences[length(levels) + 1]]], amount = dataSubSet$a)

    summarized <- normalized %>%
      group_by(category) %>%
      summarize(Quantity = sum(amount))

    summarized <- arrange(summarized, desc(Quantity))

    tibbled <- tibble(name = summarized$category, y = summarized$Quantity)

    # Preparing the names and drilldown directives for the next level below.
    # If already in "Farm_Car", the name for column "Bob" will be "Farm_Car_Bob"
    nextLevelCodes = lapply(tibbled$name, function(fac) {
      paste(c(levels, as.character(fac)), collapse = "_")
    }) %>% unlist

    tibbled$id = nextLevelCodes

    # This is dynamic handling for when there is no further drilldown possible.
    # If no "drilldown" property is set in the data object, Highcharts will not let further drilldowns be triggered.
    if (length(levels) < length(resemblences) - 1) {
      tibbled$drilldown = nextLevelCodes
    }

    # Sending data to the installed Drilldown Data listener.
    session$sendCustomMessage("drilldown", list(
      series = list(
        type = "column",
        name = paste(levels, sep = "_"),
        data = list_parse(tibbled)
      ),
      # Here, point is, as mentioned above, the ID of the point that triggered the drilldown.
      point = input$ClickedInput
    ))
  })

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

shinyApp(ui, server)