在 R Shiny 中显示 sankey 图表中的表格详细信息

Question

下面的脚本处理来自 bupaR 包的患者数据，并创建一个 sankey 图，列出“员工”列中的资源与患者数据中“处理”列中他参与的活动之间的关系。除了绘图之外，DT 还提供了一个数据表，单击该表可提供每个 sankey 绘图路径的详细信息。我想要一个功能，当我点击任何路径时，比如连接“r1”员工和“注册”处理活动的路径，我希望所有来自患者数据的行在图中都可用，此外，对于所有其他路径也是如此，这应该是动态的，因为我将在更大的数据集上应用该功能。附上快照以供参考。谢谢，请帮忙。

## app.R ##
library(shiny)
library(shinydashboard)
library(devtools)
library(ggplot2)
library(plotly)
library(proto)
library(RColorBrewer)
library(gapminder)
library(stringr)
library(broom)
library(mnormt)
library(DT)
library(bupaR)

ui <- dashboardPage(
dashboardHeader(title = "Sankey Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
box(title = "Sankey Chart", status = "primary",height = "455" ,solidHeader = T,
    plotlyOutput("sankey_plot")),

box( title = "Case Summary", status = "primary", height = "455",solidHeader = T, 
     dataTableOutput("sankey_table"))
 )
 )
 server <- function(input, output) 
 { 
 output$sankey_plot <- renderPlotly({
 sankeyData <- patients %>% 
  group_by(employee,handling) %>% 
  count()
 sankeyNodes <- list(label = c(sankeyData$employee,sankeyData$handling))
 trace2 <- list(
  domain = list(
    x = c(0, 1), 
    y = c(0, 1)
  ), 
  link = list(
    label = paste0("Case",1:nrow(sankeyData)), 
    source = sapply(sankeyData$employee,function(e) {which(e == 
  sankeyNodes$label) }, USE.NAMES = FALSE) - 1, 
    target = sapply(sankeyData$handling,function(e) {which(e == 
  sankeyNodes$label) }, USE.NAMES = FALSE) - 1, 
    value = sankeyData$n
  ), 
  node = list(label = sankeyNodes$label), 
  type = "sankey"
  )
  data2 <- list(trace2)
  p <- plot_ly()
  p <- add_trace(p, domain=trace2$domain, link=trace2$link, 
               node=trace2$node, type=trace2$type)
  p
  })
  output$sankey_table <- renderDataTable({
  d <- event_data("plotly_click")
  d
  })
  }
  shinyApp(ui, server)

Answer 1

您好，我将 event_data 的输出解释为 pointNumber 是链接的索引，但我在这里可能错了。无论如何，这是我的解决方案，它适用于这些数据

library(shiny)
library(shinydashboard)
library(devtools)
library(ggplot2)
library(plotly)
library(proto)
library(RColorBrewer)
library(gapminder)
library(stringr)
library(broom)
library(mnormt)
library(DT)
library(bupaR)
library(dplyr)

ui <- dashboardPage(
  dashboardHeader(title = "Sankey Chart"),
  dashboardSidebar(
    width = 0
  ),
  dashboardBody(
    box(title = "Sankey Chart", status = "primary",height = "455" ,solidHeader = T,
        plotlyOutput("sankey_plot")),

    box( title = "Case Summary", status = "primary", height = "455",solidHeader = T, 
         dataTableOutput("sankey_table"))
  )
)
server <- function(input, output) 
{ 
  sankeyData <- reactive({
    sankeyData <- patients %>% 
      group_by(employee,handling) %>% 
      count()
    sankeyNodes <- list(label = c(sankeyData$employee,sankeyData$handling) %>% unique())
    trace2 <- list(
      domain = list(
        x = c(0, 1), 
        y = c(0, 1)
      ), 
      link = list(
        label = paste0("Case",1:nrow(sankeyData)), 
        source = sapply(sankeyData$employee,function(e) {which(e == 
                                                                 sankeyNodes$label) }, USE.NAMES = FALSE) - 1, 
        target = sapply(sankeyData$handling,function(e) {which(e == 
                                                                 sankeyNodes$label) }, USE.NAMES = FALSE) - 1, 
        value = sankeyData$n
      ), 
      node = list(label = sankeyNodes$label), 
      type = "sankey"
    )
    trace2
  })

  output$sankey_plot <- renderPlotly({
    trace2 <- sankeyData()
    p <- plot_ly()
    p <- add_trace(p, domain=trace2$domain, link=trace2$link, 
                   node=trace2$node, type=trace2$type)
    p
  })
  output$sankey_table <- renderDataTable({
    d <- event_data("plotly_click")
    req(d)
    trace2 <- sankeyData()
    sIdx <-  trace2$link$source[d$pointNumber+1]
    Source <- trace2$node$label[sIdx + 1 ]
    tIdx <- trace2$link$target[d$pointNumber+1]
    Target <- trace2$node$label[tIdx+1]
    patients %>% filter(employee == Source & handling == Target)


  })
}
shinyApp(ui, server)

希望对你有帮助！