Customizing the Sankey Chart to Cater Large Datasets

Customizing the sankey chart to cater large datasets

This should do it

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

Displaying the table details from sankey chart in R shiny

Hi I interpreted the output from event_data as such that pointNumber is the index of the link but I might be wrong here. Any way this is my Solution and it works for this data

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)

hope it helps!

Positioning of shiny widets like box and selectInputs in R

Is this somewhat what you want.

library(shiny)
library(shinydashboard)
ui <- dashboardPage(
  dashboardHeader(title = "Iris Chart"),
  dashboardSidebar(
    width = 0
  ),
  dashboardBody(
    tags$head(tags$style(HTML('.info-box {min-height: 45px;} .info-box-icon 
                              {height: 45px; line-height: 45px;} .info-box-content {padding-top: 0px; 
                              padding-bottom: 0px;} 
                              '))),
    fluidRow(
      column(
        width = 12,
        column(
          width = 2,
          selectInput("Position", "", 
                      c("User_Analyses","User_Activity_Analyses"),selected = "Median", width = 
                        "400"),
          conditionalPanel(
            condition = "input.Position == 'User_Analyses'",
            style = "margin-top:-22px;",
            selectInput("stats", "", c("Time","Cases"),selected = "Median", width = "400"))
        ),
        column(
          style = "padding-top:20px;",
          width = 10,
          infoBox("User1", paste0(10), icon = icon("credit-card"), width = "3"),
          infoBox("User2",paste0(10), icon = icon("credit-card"), width ="3"),

          infoBox("User3",paste0(10), icon = icon("credit-card"), width ="3"),
          infoBox("User4",paste0(16), icon = icon("credit-card"), width ="3"))
        ),
      column(
        width = 12,
        conditionalPanel(
          condition = "input.Position == 'User_Analyses'",
          box(title = "Plot1", status = "primary",height = "537" ,solidHeader = T,
              plotOutput("case_hist",height = "466")),
          box(title = "Plot2", status = "primary",height = "537" ,solidHeader = T,
              plotOutput("trace_hist",height = "466"))
        ),
        conditionalPanel(
          condition = "input.Position == 'User_Activity_Analyses'",
          box(title = "Plot3",status = "primary",solidHeader = T,height = "537",width = "6",
              plotOutput("sankey_plot")),
          box(title = "Plot4",status = "primary",solidHeader = T,height = "537",width = "6",
              plotOutput("sankey_table"))
        )      
      )
    )
    )
    )
server <- function(input, output) 
{
  output$case_hist <- renderPlot(
    plot(iris$Sepal.Length)

  )

  output$trace_hist <- renderPlot(
    plot(mtcars$mpg)

  )
  output$sankey_plot <- renderPlot({
    plot(diamonds$carat)
  })
  #Plot for Sankey Data table 
  output$sankey_table <- renderPlot({
    plot(iris$Petal.Length)
  })
}
shinyApp(ui, server)

---

Related Topics