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