R闪亮的sankey绘图变量出错

Question

请运行下面的脚本，使用来自bupaR库的患者数据集创建两个图表，左边的图表显示一个显示资源（“员工”）和活动（“处理”）之间关系的sankey图表和图表当我们执行“点击”时，右侧显示资源和活动之间的链接的详细信息。基本上，当我们点击连接“r1”到“Registration”的链接等时，我们会看到一个数据子集，其中相应的值表示“r1”和“Registration”值。但是，当我使用任何其他资源和活动列运行代码时，不会创建sankey图表，并且我得到以下错误“二进制运算符的非数字参数”。请使用简单的数据集尝试脚本并提供帮助：

a1 = c("A","B","C","A","B","B")
a2 = c("D","E","D","E","D","F")
a12 = data.frame(a1,a2)   

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))
  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)

Answer 1

为了使用任何数据集制作这个“现成的解决方案”，我认为你需要为列a的每个字符使用b列的一个字符（使用as.character()将剪切和颜色变成字符）。例如，在患者数据集中，r1只有一种可能性（注册）;对于r2到r7也是如此。您的应用无法使用完整的diamonds数据集。但使用相同的逻辑，应用程序工作。

diamonds_b <- diamonds %>% filter(cut == "Ideal" & color == "D")
diamonds_c <- diamonds %>% filter(cut == "Fair" & color == "E")
diamonds_d <- rbind(diamonds_b, diamonds_c)
diamonds_d$cut <- as.character(diamonds_d$cut)
diamonds_d$color <- as.character(diamonds_d$color)

现在使用diamonds_d数据集运行闪亮的应用程序：

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 <- diamonds_d %>% 
      group_by(cut,color) %>% 
      count()
    sankeyNodes <- list(label = c(sankeyData$cut,sankeyData$color))
    trace2 <- list(
      domain = list(
        x = c(0, 1), 
        y = c(0, 1)
      ), 
      link = list(
        label = paste0("Case",1:nrow(sankeyData)), 
        source = sapply(sankeyData$cut,function(e) {which(e == sankeyNodes$label) }, USE.NAMES = FALSE) - 1, 
        target = sapply(sankeyData$color,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]
    diamonds %>% filter(cut == Source & color == Target)
  })
}
shinyApp(ui, server)