单击R Shiny中的Sankey Chart线时添加附加标签值 [英] Adding additional label value when clicked on Sankey Chart lines in R shiny

问题描述

以下R闪亮脚本将创建一个sankey图表，如下面的快照所示.我的要求是，当我单击左右节点之间的任何链接时，即"a1"和"a2"，我希望相应的"a3"的总和出现在标签中.例如，a1中的"A"和a2中的"E"的值分别为50和32.因此，我想在标签上单击链接时看到82，请帮忙，谢谢.所有其他a1，a2对相似.下面的服务器代码中的list()函数中需要进行一些调整.附加快照.

The following R shiny script creates a sankey chart as in the snapshot below. My requirement is that when I click on any link between the nodes on left and right i.e. "a1" and "a2", I want the total sum of corresponding "a3" to be present in the label. For Illustration, "A" in a1 and "E" in a2 together have value 50 and 32. So, I want to see 82 in the label when clicked on link, please help and thanks. Similary for all other a1,a2 pairs. Some tweak is needed in the list() function in server code below. Attaching the snapshot.

library(shiny)
library(shinydashboard)
library(plotly)
library(DT)
library(dplyr)
a1 = c("A","B","C","A","C","C","B")
a2 = c("E","F","G","E","G","G","F")
a3 = c(50,45,64,32,45,65,75)
a12 = data.frame(a1,a2,a3,stringsAsFactors = FALSE)
a12$a1 = as.character(a12$a1)
a12$a2 = as.character(a12$a2)
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 <- a12 %>% 
  group_by(a1,a2) %>% 
  count()
sankeyNodes <- list(label = c(sankeyData$a1,sankeyData$a2) %>% unique())
trace2 <- list(
  domain = list(
    x = c(0, 1), 
    y = c(0, 1)
  ), 
  link = list(
    label = paste0("Case",1:nrow(sankeyData)), 
    source = sapply(sankeyData$a1,function(e) {which(e == 
                                                       sankeyNodes$label) }, 
   USE.NAMES = FALSE) - 1, 
    target = sapply(sankeyData$a2,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]
  a12 %>% filter(a1 == Source & a2 == Target)
  })
  }
  shinyApp(ui, server)

推荐答案

我想您需要的解决方案是

I guess the solution you need is

value = apply(t(sankeyData),2, function(e, Vals){
           e <- data.frame(t(e), stringsAsFactors = FALSE)
           sum(Vals[which(e$a1 == Vals$a1 & e$a2 == Vals$a2),3])
         }, Vals = a12)

代替

value = sankeyData$n

有了这个，你会得到这样的东西:

With this you get something like this:

希望有帮助！

这篇关于单击R Shiny中的Sankey Chart线时添加附加标签值的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！