Error in sankey plot variables in R shiny - r

Question

Please run the script below, there are two charts created using the patients dataset from the bupaR library, the chart on the left displays a sankey chart showing relationship between the resource("employee") and activities("handling") and the chart on the right displays the details of link between the resource and activities when we perform "on-click". Basically, we see a subset of data with corresponding values say "r1" and "Registration" values when we click the link connecting "r1" to "Registration" and so on. However, when I run code with any other resource and activity column, the sankey chart does not get created and I get the following error "non-numeric argument to binary operator". Please try the script with a simple dataset and help:
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

In order to make this "ready solution" with any dataset I think you need one character (cut and color were turned into character using as.character()) of column b for each character of column a. For example, in the patient dataset, there is only one possibility (registration) for r1; same for r2 to r7. Your app did not work with the full diamonds dataset. But using the same logic, the app works.
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)
and now running the shiny app with the diamonds_d dataset works:
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)