Fehler in Sankey-Plot-Variablen in R glänzend

Question

Bitte führen Sie das folgende Skript aus, es gibt zwei Diagramme mit dem Patienten-Datensatz aus der BupaR-Bibliothek, das Diagramm auf der linken Seite zeigt ein Sankey-Diagramm mit der Beziehung zwischen der Ressource ("Mitarbeiter") und Aktivitäten ("Handhabung") und das Diagramm auf der rechten Seite zeigt die Details der Verbindung zwischen der Ressource und Aktivitäten, wenn wir "On-Click" durchführen. Im Grunde sehen wir eine Teilmenge der Daten mit den entsprechenden Werten "r1" und "Registration", wenn wir auf den Link klicken, der "r1" mit "Registration" verbindet, und so weiter. Wenn ich jedoch Code mit einer anderen Ressourcen- und Aktivitätsspalte ausführe, wird das Sankey-Diagramm nicht erstellt, und ich erhalte den folgenden Fehler "nicht numerisches Argument für binären Operator". Bitte versuchen Sie das Skript mit einem einfachen Datenmenge und Hilfe:

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

Um diese „ready-Lösung“ mit jedem Datensatz zu machen Ich glaube, Sie ein Zeichen benötigen (Schnitt und Farbe wurden in Zeichen verwandelt as.character() mit) der Spalte b für jedes Zeichen der Spalte a. Zum Beispiel gibt es im Patienten-Datensatz nur eine Möglichkeit (Registrierung) für r1; Gleiches für r2 bis r7. Ihre App hat nicht mit dem vollständigen Datensatz diamonds funktioniert. Aber mit der gleichen Logik funktioniert die App.

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) 

und jetzt die glänzende App mit dem diamonds_d Inhaberdatensatz funktioniert:

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)