在 R 中编写 Javascript 函数

Question

我正在使用 R 编程语言。

我有一个城市和旅行路线的数据框架（所有路线：拉丁美洲 -> 北美 -> 欧洲 -> 亚洲） - 我制作了该数据的图形网络：

library(igraph)

north_american_cities <- c("New York", "Los Angeles", "Chicago", "Houston", "Phoenix")
european_cities <- c("London", "Berlin", "Madrid", "Rome", "Paris")
asian_cities <- c("Tokyo", "Delhi", "Shanghai", "Beijing", "Mumbai")
latin_american_cities <- c("Lima", "Bogota", "Buenos Aires", "Sao Paulo", "Mexico City")

set.seed(123)
n <- 30
la_cities_sample <- sample(latin_american_cities, n, replace = TRUE)
na_cities_sample <- sample(north_american_cities, n, replace = TRUE)
eu_cities_sample <- sample(european_cities, n, replace = TRUE)
as_cities_sample <- sample(asian_cities, n, replace = TRUE)

df <- data.frame(LatinAmerica = la_cities_sample,
                 NorthAmerica = na_cities_sample,
                 Europe = eu_cities_sample,
                 Asia = as_cities_sample,
                 stringsAsFactors = FALSE)

df <- df[!duplicated(df), ]

edges_df <- data.frame(from = c(df$LatinAmerica, df$NorthAmerica, df$Europe),
                       to = c(df$NorthAmerica, df$Europe, df$Asia))

edge_list <- as.matrix(edges_df)

g <- graph_from_edgelist(edge_list, directed = TRUE)
plot(g)

从这里开始，我编写了一个函数，可以获取任何城市，并找到从开始到结束经过该城市的所有可能的旅行路线：

find_paths_through_city <- function(graph, target_city, path_length = 4) {
    all_paths <- all_simple_paths(graph, V(graph))
    
    valid_paths <- list()
    
    for (path in all_paths) {
        path_cities <- V(graph)[path]$name
        if (target_city %in% path_cities && length(path_cities) == path_length) {
            valid_paths <- append(valid_paths, list(path_cities))
        }
    }
    
    if (length(valid_paths) > 0) {
        paths_df <- do.call(rbind, lapply(valid_paths, function(x) as.data.frame(t(x), stringsAsFactors = FALSE)))
        colnames(paths_df) <- paste0("City", 1:path_length)
    } else {
        paths_df <- data.frame(matrix(ncol = path_length, nrow = 0))
        colnames(paths_df) <- paste0("City", 1:path_length)
    }
    
    return(paths_df)
}

这里，我针对特定城市测试了此功能：

city <- "New York"  
paths_through_city <- find_paths_through_city(g, target_city = city, path_length = 4)
unique_cities <- unique(as.vector(as.matrix(paths_through_city)))
subgraph <- induced_subgraph(g, vids = unique_cities)
plot(subgraph, vertex.size=10, vertex.label.cex=0.8, edge.arrow.size=0.5, main=paste("Subgraph of Paths Passing Through", city))

我的问题：从这里开始，我想制作一个交互式图表，允许用户使用 Visnetwork 单击图表中的给定节点，然后突出显示经过该节点的所有可能的旅行路线。

我和我的朋友今天尝试了解如何执行此操作 - 我们尝试编写一个 javascript 函数来执行此操作并完成了一半：

library(visNetwork)
nodes <- data.frame(id = V(g)$name, label = V(g)$name, stringsAsFactors = FALSE)
edges <- data.frame(from = edges_df$from, to = edges_df$to, stringsAsFactors = FALSE)

highlight_js <- '
function(params) {
  if (params.nodes.length == 0) return;

  var selectedNode = params.nodes[0];
  var pathLength = 4; 

  var graph = this.body.data;
  var allNodes = graph.nodes.get();
  var allEdges = graph.edges.get();

  var validPaths = [];
  function findPaths(currentPath, currentNode, depth) {
    if (depth == pathLength) {
      validPaths.push(currentPath.slice());
      return;
    }

    var connectedEdges = allEdges.filter(function(edge) {
      return edge.from == currentNode;
    });

    connectedEdges.forEach(function(edge) {
      findPaths(currentPath.concat(edge.to), edge.to, depth + 1);
    });
  }

  findPaths([selectedNode], selectedNode, 1);

  var nodesToUpdate = {};
  var edgesToUpdate = {};

  validPaths.forEach(function(path) {
    path.forEach(function(nodeId, index) {
      nodesToUpdate[nodeId] = {
        id: nodeId,
        color: "red",
        label: allNodes.find(node => node.id == nodeId).label
      };

      if (index < path.length - 1) {
        var fromNode = nodeId;
        var toNode = path[index + 1];
        var edge = allEdges.find(edge => edge.from == fromNode && edge.to == toNode);
        if (edge) {
          edgesToUpdate[edge.id] = {
            id: edge.id,
            color: "red"
          };
        }
      }
    });
  });

  graph.nodes.update(Object.values(nodesToUpdate));
  graph.edges.update(Object.values(edgesToUpdate));
}
'

visNetwork(nodes, edges) %>%
    visOptions(highlightNearest = TRUE, nodesIdSelection = TRUE) %>%
    visPhysics(stabilization = list(iterations = 2000), solver = "barnesHut", minVelocity = 0.75) %>%
    visEvents(selectNode = highlight_js)

从这里可以看出，尽管选择了亚洲城市（东京），但没有突出显示拉丁美洲城市。

在原始数据集中，它看起来像这样：

> df[df$Asia == "Tokyo",]
   LatinAmerica NorthAmerica Europe  Asia
13 Buenos Aires      Houston Madrid Tokyo
15    Sao Paulo  Los Angeles  Paris Tokyo
21       Bogota     New York   Rome Tokyo
23 Buenos Aires      Houston Berlin Tokyo

有人可以告诉我们如何解决这个问题吗？

谢谢！

Answer 1

我更新了 js 函数来识别并突出显示经过选定节点的所有可能的旅行路线。主要更改包括确保正确找到路径以及更新节点和边以反映正确的路径，包括检查以确保路径包含所选节点。现在，当您单击某个节点时，经过该节点的路由应该正确突出显示...请验证

library(igraph)
library(visNetwork)

# Sample data creation (same as provided)
north_american_cities <- c("New York", "Los Angeles", "Chicago", "Houston", "Phoenix")
european_cities <- c("London", "Berlin", "Madrid", "Rome", "Paris")
asian_cities <- c("Tokyo", "Delhi", "Shanghai", "Beijing", "Mumbai")
latin_american_cities <- c("Lima", "Bogota", "Buenos Aires", "Sao Paulo", "Mexico City")

set.seed(123)
n <- 30
la_cities_sample <- sample(latin_american_cities, n, replace = TRUE)
na_cities_sample <- sample(north_american_cities, n, replace = TRUE)
eu_cities_sample <- sample(european_cities, n, replace = TRUE)
as_cities_sample <- sample(asian_cities, n, replace = TRUE)

df <- data.frame(LatinAmerica = la_cities_sample,
                 NorthAmerica = na_cities_sample,
                 Europe = eu_cities_sample,
                 Asia = as_cities_sample,
                 stringsAsFactors = FALSE)

df <- df[!duplicated(df), ]

edges_df <- data.frame(from = c(df$LatinAmerica, df$NorthAmerica, df$Europe),
                       to = c(df$NorthAmerica, df$Europe, df$Asia))

edge_list <- as.matrix(edges_df)

g <- graph_from_edgelist(edge_list, directed = TRUE)

# Create nodes and edges data frame for visNetwork
nodes <- data.frame(id = V(g)$name, label = V(g)$name, stringsAsFactors = FALSE)
edges <- data.frame(from = edges_df$from, to = edges_df$to, stringsAsFactors = FALSE)

highlight_js <- '
function(params) {
  if (params.nodes.length == 0) return;

  var selectedNode = params.nodes[0];
  var pathLength = 4; 

  var graph = this.body.data;
  var allNodes = graph.nodes.get();
  var allEdges = graph.edges.get();

  var validPaths = [];
  
  function findPaths(currentPath, currentNode, depth) {
    if (depth == pathLength) {
      validPaths.push(currentPath.slice());
      return;
    }

    var connectedEdges = allEdges.filter(function(edge) {
      return edge.from == currentNode;
    });

    connectedEdges.forEach(function(edge) {
      findPaths(currentPath.concat(edge.to), edge.to, depth + 1);
    });
  }

  allNodes.forEach(function(node) {
    findPaths([selectedNode], selectedNode, 1);
  });

  var nodesToUpdate = {};
  var edgesToUpdate = {};

  validPaths.forEach(function(path) {
    if (path.includes(selectedNode)) {
      path.forEach(function(nodeId, index) {
        nodesToUpdate[nodeId] = {
          id: nodeId,
          color: "red",
          label: allNodes.find(node => node.id == nodeId).label
        };

        if (index < path.length - 1) {
          var fromNode = nodeId;
          var toNode = path[index + 1];
          var edge = allEdges.find(edge => edge.from == fromNode && edge.to == toNode);
          if (edge) {
            edgesToUpdate[edge.id] = {
              id: edge.id,
              color: "red"
            };
          }
        }
      });
    }
  });

  graph.nodes.update(Object.values(nodesToUpdate));
  graph.edges.update(Object.values(edgesToUpdate));
}
'

visNetwork(nodes, edges) %>%
  visOptions(highlightNearest = TRUE, nodesIdSelection = TRUE) %>%
  visPhysics(stabilization = list(iterations = 2000), solver = "barnesHut", minVelocity = 0.75) %>%
  visEvents(selectNode = highlight_js)