skip to Main Content

I am working with the R programming language.

I have a data frame of cities and travel routes (all routes: latin america -> north america -> europe -> asia) – I made a graph network of this data:

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)

enter image description here

From here, I wrote a function that takes any city, and finds all possible travel routes that go through this city from start to finish:

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)
}

Here, I tested this function for a specific city:

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))

enter image description here

My Question: From here, I want to make an interactive graph that allows the user to click on a given node in the graph using Visnetwork, and then highlights all possible travel routes passing through that node.

My friends and I tried to learn about how to do this today – we tried to write a javascript function to do this and got partway through:

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)

enter image description here

As can be seen here, even though an Asian city is selected (Tokyo), no Latin American cities are highlighted.

In the original dataset, it looks like this:

> 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

Can someone please show us how to fix this?

Thanks!

3

Answers


  1. I update the js function to identify and highlight all possible travel routes that pass through a selected node. The main changes include ensuring that paths are found correctly and that nodes and edges are updated to reflect the correct paths, including a check to ensure that the path includes the selected node. Now, when you click on a node, the routes passing through it should be highlighted properly…please validate

    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)
    
    
    Login or Signup to reply.
  2. Assuming that you really want to retrieve all paths of a certain length which pass through a city, you can do the following:

    N.B. For nicer code decoration I typeset the following Javascript codes as JavaScript. For the usage in R you should define those of course as strings (escaped by JS) and pass them to the respective functions,

    Idea

    1. On startup of the widget, I first visit each node and walk to all neighbors, which are not further away than 4 nodes. In this way I obtain a set of all simple paths, which I store as a global object ( window.routes).
    2. On click, I filter all the paths down to the list of paths which contain the selected node, extract all cities on these paths and all edges and color them (N.B. for the sake of verbosity, I created array of ids and looped through those again, instead of doing just one loop, but this is done on purpose to allow for a better understanding of the idea).
    3. Finally I added a deselect script to set the color back to the defaults as soon as a node is deselected.

    A network where a click on a node colors all path of length 4 which contain this node.

    Codes

    store_all_paths

    // store_all_paths <- JS("
    function(el, data) {
      const network = this.network;
      function visit_node(network, city, path, path_list, max_length) {
        if (!path.includes(city)) {
          path.push(city);
          if (path.length === max_length) {
            // need to stringify because unique contraint does not work on array objects
            path_list.add(JSON.stringify(path))
          } else {
            const neighbors = network.getConnectedNodes(city, 'to');
            neighbors.forEach((nb) => visit_node(network, nb, [...path], path_list, 
                                                 max_length));
          }
        }
      }
      const max_length = 4;
      const path_list = new Set();
      data.nodes.id.forEach((city) => visit_node(network, city, [], path_list, max_length));
      window.routes = [...path_list].map((rt) => JSON.parse(rt));
    }
    //")
    

    handle_click

    // handle_click <- JS("
    function(params) {
      params.event.preventDefault();
      if (params.nodes.length > 0) {
        // 1. Find all routes including the selected nodes
        const routes = params.nodes.map(node => 
          window.routes.filter(route => route.includes(node))).flat();
        // 2. From these routes extract all involved cities and all involved edges
        const cities_on_route = [...new Set(routes.flat(2))];
        const all_edges = this.body.data.edges;
        const edges_on_route = [...new Set(routes.map(function(route) {
          const edges = [];
          for(let i = 0; i < route.length - 1; i++) {
            const edge = all_edges.get({
              filter: (item) => item.from === route[i] & item.to === route[i + 1]
            })
            edges.push(...edge)
          }
          return edges.map((e) => e.id);
        }).flat())];
        // 3. Color Edges and Nodes 
        // N.B. we could do that immediately instead of first saving all ids
        // but for illustrative purposes i made this performance wise not os smart split
        this.body.data.nodes.updateOnly(
          cities_on_route.map((id) => (
            {
              id: id, 
              color: {
                background: 'red', 
                border: 'red',
                highlight: {
                  background: 'red',
                  border: 'red'
                }}, 
              label: this.body.data.nodes.get(id).label
            }
          ))
        );
        this.body.data.edges.updateOnly(
          edges_on_route.map((id) => (
            {
              id: id,
              color: {
                color: 'red', 
                highlight: 'red'
              }
            }
          ))
        );
        console.log({routes: routes, edges: edges_on_route})
      }
    }
    //")
    

    handle_deselect

    // handle_deselect <- JS("
    function(params) {
      this.body.data.nodes.updateOnly(this.body.data.nodes.get().map((node) => 
        ({
          id: node.id, 
            color: {
              background: '#D2E5FF', 
              border: '#2B7CE9',
              highlight: {
                background: '#D2E5FF',
                border: '#2B7CE9'
              }
            }
          })
        ));
      this.body.data.edges.updateOnly(this.body.data.edges.get().map((edge) => 
        ({
          id: edge.id, 
          color: {
            color: '#848484',
            highlight: '#848484',
            inherit: false
          }
        })
        )
        );  
    }
    //")
    

    visNetwork

    visNetwork(nodes, edges) %>%
      visOptions(nodesIdSelection = TRUE) %>%
      visPhysics(stabilization = list(iterations = 2000), solver = "barnesHut",
                 minVelocity = 0.75) %>% 
      visEvents(selectNode = handle_click, deselectNode = handle_deselect) %>% 
      onRender(store_all_paths)
    
    Login or Signup to reply.
  3. I think visnetwork library is your best option – recreated it with just the following code:

    library(visNetwork)
    
    # Define nodes and edges
    nodes <- data.frame(id = 1:6, label = paste("Node", 1:6))
    edges <- data.frame(from = c(1, 1, 2, 3, 4, 4), to = c(2, 3, 4, 5, 5, 6))
    
    # Create the network graph
    visNetwork(nodes, edges) %>%
      visNodes(
        shape = "dot",
        size = 10
      ) %>%
      visEdges(
        arrows = "to"
      ) %>%
      visInteraction(
        navigationButtons = TRUE
      )
    
    Login or Signup to reply.
Please signup or login to give your own answer.
Back To Top
Search