如何在R的visNetwork中添加三级下拉菜单筛选城市路径？

核心逻辑 #

通过Shiny的联动下拉菜单实现三级筛选：先选北美出发城市，再选欧洲中转/目标城市，最后可选择亚洲终点；利用igraph计算节点可达性与路径，再用visNetwork渲染筛选后的子图。

完整代码示例 #

library(shiny)
library(igraph)
library(visNetwork)

# 1. 构建模拟城市网络数据
# 节点：包含城市名、所属大洲、区分颜色
nodes <- data.frame(
  id = 1:12,
  label = c("纽约", "洛杉矶", "多伦多",  # 北美
            "伦敦", "巴黎", "柏林",     # 欧洲
            "北京", "上海", "东京", "首尔", "孟买", "新加坡"),  # 亚洲
  continent = c(rep("北美",3), rep("欧洲",3), rep("亚洲",6)),
  color = c(rep("#4285F4",3), rep("#EA4335",3), rep("#FBBC05",6))
)

# 边：有向连接，模拟可通行路径
edges <- data.frame(
  from = c(1,1,2,3,4,4,5,6,7,8,9,10,11,12,1,4),
  to = c(4,7,5,6,5,8,9,10,12,11,4,5,7,6,5,8),
  label = "可通行"
)

# 创建igraph有向图对象
g <- graph_from_data_frame(d = edges, vertices = nodes, directed = TRUE)

# 2. Shiny应用定义
ui <- fluidPage(
  titlePanel("城市路径筛选系统"),
  sidebarLayout(
    sidebarPanel(
      # 第一级：选择北美出发城市
      selectInput("north_america_city", "选择北美出发城市",
                  choices = nodes$label[nodes$continent == "北美"],
                  selected = NULL),
      # 第二级：动态加载可达的欧洲城市
      uiOutput("europe_city_ui"),
      # 第三级：动态加载欧洲城市可达的亚洲城市（可选）
      uiOutput("asia_city_ui")
    ),
    mainPanel(
      visNetworkOutput("network_plot", height = "700px")
    )
  )
)

server <- function(input, output, session) {
  # 渲染欧洲城市下拉菜单（依赖北美城市选择）
  output$europe_city_ui <- renderUI({
    if(is.null(input$north_america_city)) return(NULL)
    na_node_id <- nodes$id[nodes$label == input$north_america_city]
    # 获取北美城市可达的所有节点，再筛选欧洲城市
    reachable_nodes <- subcomponent(g, na_node_id, mode = "out")
    reachable_europe <- nodes$label[nodes$id %in% reachable_nodes & nodes$continent == "欧洲"]
    selectInput("europe_city", "选择欧洲城市",
                choices = reachable_europe,
                selected = NULL)
  })
  
  # 渲染亚洲城市下拉菜单（依赖前两级选择）
  output$asia_city_ui <- renderUI({
    if(is.null(input$north_america_city) || is.null(input$europe_city)) return(NULL)
    eu_node_id <- nodes$id[nodes$label == input$europe_city]
    # 获取欧洲城市可达的所有节点，再筛选亚洲城市
    reachable_from_eu <- subcomponent(g, eu_node_id, mode = "out")
    reachable_asia <- nodes$label[nodes$id %in% reachable_from_eu & nodes$continent == "亚洲"]
    selectInput("asia_city", "选择最终亚洲城市（可选）",
                choices = c("全部", reachable_asia),
                selected = "全部")
  })
  
  # 动态生成筛选后的网络
  output$network_plot <- renderVisNetwork({
    if(is.null(input$north_america_city)) {
      # 初始状态显示全量网络
      visNetwork(nodes, edges) %>%
        visEdges(arrows = "to") %>%
        visOptions(highlightNearest = TRUE, nodesIdSelection = TRUE)
    } else {
      na_node_id <- nodes$id[nodes$label == input$north_america_city]
      reachable_from_na <- subcomponent(g, na_node_id, mode = "out")
      
      if(!is.null(input$europe_city)) {
        eu_node_id <- nodes$id[nodes$label == input$europe_city]
        # 若欧洲城市不在北美可达范围内，提示无路径
        if(!eu_node_id %in% reachable_from_na) {
          return(visNetwork() %>% visNodes(label = "无可用路径"))
        }
        # 合并北美到欧洲、欧洲出发的所有路径节点
        paths_na_to_eu <- all_simple_paths(g, from = na_node_id, to = eu_node_id, mode = "out")
        nodes_na_eu <- unique(unlist(paths_na_to_eu))
        paths_eu_out <- all_simple_paths(g, from = eu_node_id, mode = "out")
        nodes_eu_out <- unique(unlist(paths_eu_out))
        all_selected_nodes <- unique(c(nodes_na_eu, nodes_eu_out))
        
        # 若选择了亚洲城市，进一步筛选到该城市的路径
        if(!is.null(input$asia_city) && input$asia_city != "全部") {
          asia_node_id <- nodes$id[nodes$label == input$asia_city]
          if(!asia_node_id %in% nodes_eu_out) {
            return(visNetwork() %>% visNodes(label = "无可用路径"))
          }
          paths_final <- all_simple_paths(g, from = na_node_id, to = asia_node_id, mode = "out")
          all_selected_nodes <- unique(unlist(paths_final))
        }
        
        # 提取筛选后的节点和边
        filtered_nodes <- nodes[nodes$id %in% all_selected_nodes, ]
        filtered_edges <- edges[(edges$from %in% all_selected_nodes) & (edges$to %in% all_selected_nodes), ]
      } else {
        # 仅选北美城市时，显示其所有可达节点
        filtered_nodes <- nodes[nodes$id %in% reachable_from_na, ]
        filtered_edges <- edges[(edges$from %in% reachable_from_na) & (edges$to %in% reachable_from_na), ]
      }
      
      # 渲染筛选后的网络，固定布局避免混乱
      visNetwork(filtered_nodes, filtered_edges) %>%
        visEdges(arrows = "to") %>%
        visOptions(highlightNearest = TRUE) %>%
        visLayout(randomSeed = 123)
    }
  })
}

# 运行Shiny应用
shinyApp(ui = ui, server = server)

关键细节说明 #

• 联动下拉：第二、三级下拉菜单会根据上一级选择动态加载可选城市，避免无效选项。
• 路径筛选：利用igraph的subcomponent获取可达节点，all_simple_paths提取具体路径，确保只展示符合条件的子图。
• 交互优化：固定布局种子防止每次筛选后布局混乱，添加节点高亮功能提升用户体验。

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