如何创建可筛选指定人员关联节点与链接的Shiny Sankey应用

我想要创建一个Shiny应用，实现选择某一人员后，仅显示与该人员相关的Sankey节点和链接。以下是使用的数据、Sankey绘图代码以及尝试但未成功运行的Shiny应用代码：

数据 #

df <- read.table(header = TRUE, stringsAsFactors = FALSE, text = '
name  year1           year2         year3           year4
Bob   Hilton          Sheraton      Westin          Hyatt
John  "Four Seasons"  Ritz-Carlton  Westin          Sheraton
Tom   Ritz-Carlton    Westin        Sheraton        Hyatt
Mary  Westin          Sheraton      "Four Seasons"  Ritz-Carlton
Sue   Hyatt           Ritz-Carlton  Hilton          Sheraton
Barb  Hilton          Sheraton      Ritz-Carlton    "Four Seasons"
')

原始Sankey绘图代码 #

library(networkD3)
links <-
  df %>%
  mutate(row = row_number()) %>%  # 添加行ID
  pivot_longer(-row, names_to = "column", values_to = "source") %>%  # 转换为长格式
  mutate(column = match(column, names(df))) %>%  # 将列名转换为列ID
  group_by(row) %>%
  mutate(target = lead(source, order_by = column)) %>%  # 获取每行下一个节点作为目标
  ungroup() %>% 
  filter(!is.na(target))  # 移除原始数据最后一列的链接
links <-
  links %>%
  mutate(source = paste0(source, '_', column)) %>%
  mutate(target = paste0(target, '_', column + 1)) %>%
  select(source, target)
nodes <- data.frame(name = unique(c(links$source, links$target)))
nodes$label <- sub('_[0-9]*$', '', nodes$name) # 移除节点名称中的列ID
links$source_id <- match(links$source, nodes$name) - 1
links$target_id <- match(links$target, nodes$name) - 1
links$value <- 1

sankeyNetwork(Links = links,
              Nodes = nodes,
              Source = 'source_id',
              Target = 'target_id',
              Value = 'value',
              NodeID = 'label',
              LinkGroup = "source",
              NodeGroup = "name",
              fontSize = 20,
              nodeWidth = 10)

未成功运行的Shiny应用代码 #

ui <- fluidPage(
  selectInput(inputId = "name",
              label   = "选择人员",
              choices =  c("Bob", "John","Tom","Mary","Sue","Barb")),
  
  sankeyNetworkOutput("diagram")
)

server <- function(input, output) {
  
  
  links <- links
  links
  nodes <- nodes
  nodes
  
  links2 <-reactive({
    links %>%
      filter(source ==df$name )
  })
  

  output$diagram <- renderSankeyNetwork({
    sankeyNetwork(
      Links = links2,
      Nodes = nodes,
      Source = 'source_id',
      Target = 'target_id',
      Value = 'value',
      NodeID = 'label',
      LinkGroup = "source",
      NodeGroup = "name",
      fontSize = 20,
      nodeWidth = 10,
      sinksRight = FALSE
    )
  })
}

shinyApp(ui = ui, server = server)

预期效果 #

选择“Tom”时，应呈现如下效果：

解决方案 #

原代码的问题在于过滤逻辑错误，没有正确关联选中人员的路径，且未重新生成对应人员的节点和链接数据。修正后的Shiny代码如下：

library(shiny)
library(networkD3)
library(dplyr)
library(tidyr)

# 原始数据
df <- read.table(header = TRUE, stringsAsFactors = FALSE, text = '
name  year1           year2         year3           year4
Bob   Hilton          Sheraton      Westin          Hyatt
John  "Four Seasons"  Ritz-Carlton  Westin          Sheraton
Tom   Ritz-Carlton    Westin        Sheraton        Hyatt
Mary  Westin          Sheraton      "Four Seasons"  Ritz-Carlton
Sue   Hyatt           Ritz-Carlton  Hilton          Sheraton
Barb  Hilton          Sheraton      Ritz-Carlton    "Four Seasons"
')

ui <- fluidPage(
  selectInput(inputId = "selected_name",
              label   = "选择人员",
              choices = df$name,
              selected = "Tom"),
  
  sankeyNetworkOutput("diagram")
)

server <- function(input, output) {
  
  # 根据选中的人员生成对应的链接和节点数据
  filtered_data <- reactive({
    # 提取选中人员的行
    selected_row <- df %>% filter(name == input$selected_name)
    
    # 重新生成该人员的链接数据
    links <- selected_row %>%
      mutate(row = row_number()) %>%
      pivot_longer(-row, names_to = "column", values_to = "source") %>%
      mutate(column = match(column, names(df))) %>%
      group_by(row) %>%
      mutate(target = lead(source, order_by = column)) %>%
      ungroup() %>%
      filter(!is.na(target)) %>%
      mutate(source = paste0(source, '_', column)) %>%
      mutate(target = paste0(target, '_', column + 1)) %>%
      select(source, target)
    
    # 生成对应的节点数据
    nodes <- data.frame(name = unique(c(links$source, links$target)))
    nodes$label <- sub('_[0-9]*$', '', nodes$name)
    
    # 补充节点ID
    links$source_id <- match(links$source, nodes$name) - 1
    links$target_id <- match(links$target, nodes$name) - 1
    links$value <- 1
    
    list(links = links, nodes = nodes)
  })
  
  output$diagram <- renderSankeyNetwork({
    sankeyNetwork(
      Links = filtered_data()$links,
      Nodes = filtered_data()$nodes,
      Source = 'source_id',
      Target = 'target_id',
      Value = 'value',
      NodeID = 'label',
      LinkGroup = "source",
      NodeGroup = "name",
      fontSize = 20,
      nodeWidth = 10,
      sinksRight = FALSE
    )
  })
}

shinyApp(ui = ui, server = server)

修正说明 #

1. 将选择框的选项直接从df$name读取，避免手动输入出错
2. 新增filtered_data响应式对象，根据选中人员重新生成对应的链接和节点数据，确保只保留该人员的路径
3. 调用响应式对象时添加()，正确获取其返回值
4. 确保所有数据处理逻辑都在响应式环境中，实现动态更新

内容的提问来源于stack exchange，提问作者Lily Nature