Shortest Paths based on edge attribute with igraph

Question

I'm trying to get the shortest paths of a graph but based on its edge ids. So having the following graph:

library(igraph)

set.seed(45)
g <- erdos.renyi.game(25, 1/10, directed = TRUE)
E(g)$id <- sample(1:3, length(E(g)), replace = TRUE)

The shortest_paths(g, 1, V(g)) function finds all the shortest paths from node 1 to all the other nodes. However, I would like to calculate this, not just by following the geodesic distance, but a mix between the geodesic distance, and the minimum of edge id changes. For example if this would be a train network, and the edge ids would represent trains. I would like to calculate how to get from node A to all the other nodes using the shortest path, but while changing the least amount of time of trains.

Answer 1

OK I think I have a working solution, although the code is a little ugly. The basic algorithm (lets call it gs(i, j)) goes like this: If we want to find the shortest train journey from i to j (gs(i, j)) we:

1. find the shortest path from i to j considering all trains. if this path is length 0 or 1 return it (there is either no path or a path on 1 train)
2. split the graph up by 'trains' (subset graph by edges) so as to consider each train network separately, and find the shortest path between i and j in each individual train network
3. if a single train will get you from i to j, return the train route with the fewest stops between i and j, else
4. if no single train runs from i to j then call gs(i, j-1) where (j-1) is the stop before j in the shortest path between i and j on the full network.

So basically, we look to see if a single train can do it, and if it can't we call the function recursively looking if a single train can get you to the stop before the last stop, etc. etc.

library(igraph)

# First your data
set.seed(45)
g <- erdos.renyi.game(25, 1/10, directed = TRUE)
E(g)$id <- sample(1:3, length(E(g)), replace = TRUE)

plot(g, edge.color = E(g)$id)

# The function takes as arguments the graph, and the id of the vertex
# you want to go from/to. It should work for a vector of 
# destinations but I have not rigorously tested it so proceed with
# caution!
get.shortest.routes <- function(g, from, to){
  train.routes <- lapply(unique(E(g)$id), function(id){subgraph.edges(g, eids = which(E(g)$id==id), delete.vertices = F)})
  target.sp <- shortest_paths(g, from = from, to = to, output = 'vpath')$vpath
  single.train.paths <- lapply(train.routes, function(gs){shortest_paths(gs, from = from, to = to, output = 'vpath')$vpath})
  for (i in length(target.sp)){
    if (length(target.sp[[i]]>1)) {
      cands <- lapply(single.train.paths, function(l){l[[i]]})
      if (sum(unlist(lapply(cands, length)))!=0) {
        cands <- cands[lapply(cands, length)!=0]
        cands <- cands[lapply(cands, length)==min(unlist(lapply(cands, length)))]
        target.sp[[i]] <- cands[[1]]
      } else {
        target.sp[[i]] <- c(get.shortest.routes(g, from = as.numeric(target.sp[[i]][1]),
                                              to = as.numeric(target.sp[[i]][(length(target.sp[[i]]) - 1)]))[[1]],
                            get.shortest.routes(g, from = as.numeric(target.sp[[i]][(length(target.sp[[i]]) - 1)]),
                                                to = as.numeric(target.sp[[i]][length(target.sp[[i]])]))[[1]][-1])
      }
    }
  }
  target.sp
}

OK now lets run some tests. If you squint at the graph above you can see that the path from vertex 5 to vertex 21 is length-2 if you take two trains, but that you can get there on 1 train if you pass through an extra station. Our new function should return the longer path:

shortest_paths(g, 5, 21)$vpath
#> [[1]]
#> + 3/25 vertices, from b014eb9:
#> [1]  5 13 21
get.shortest.routes(g, 5, 21)
#> Warning in shortest_paths(gs, from = from, to = to, output = "vpath"): At
#> structural_properties.c:745 :Couldn't reach some vertices

#> Warning in shortest_paths(gs, from = from, to = to, output = "vpath"): At
#> structural_properties.c:745 :Couldn't reach some vertices
#> [[1]]
#> + 4/25 vertices, from c22246c:
#> [1]  5 13 15 21

Lets make a really easy graph where we are sure what we want to see: here we should get 1-2-4-5 instead of 1-3-5:

df <- data.frame(from = c(1, 1, 2, 3, 4), to = c(2, 3, 4, 5, 5))
g1 <- graph_from_data_frame(df)
E(g1)$id <- c(1, 2, 1, 3, 1)
plot(g1, edge.color = E(g1)$id)

get.shortest.routes(g1, 1, 5)
#> Warning in shortest_paths(gs, from = from, to = to, output = "vpath"): At
#> structural_properties.c:745 :Couldn't reach some vertices

#> Warning in shortest_paths(gs, from = from, to = to, output = "vpath"): At
#> structural_properties.c:745 :Couldn't reach some vertices
#> [[1]]
#> + 4/5 vertices, named, from c406649:
#> [1] 1 2 4 5

I'm sure there is a more rigorous solution, and you'll probably want to optimize the code a bit. For instance, I just realized that I don't stop the function immediately if the shortest path on the full graph has only two nodes -- doing so would avoid some needless computations! This was a fun problem, I hope some other answers gets posted.

Created on 2018-05-11 by the reprex package (v0.2.0).

Answer 2

Here is my take on the problem. A few notes:

1) all_simple_paths will not scale well with large or highly connected graphs
2) I favored fewest changes above all else, which means a path with two changes and a dist of 40 will beat a path with three changes and a dist of 3.
4) I can imagine an even faster approach if # of changes and distance change priority if there is no path on one id

library(igraph)

# First your data
set.seed(45)
g <- erdos.renyi.game(25, 1/10, directed = TRUE)
E(g)$id <- sample(1:3, length(E(g)), replace = TRUE)

plot(g, edge.color = E(g)$id)


##Option 1:
rst <- all_simple_paths(g, from = 1, to = 18, mode = "out")
rst <- lapply(rst, as_ids)
rst1 <- lapply(rst, function(x) c(x[1], rep(x[2:(length(x)-1)],
                                            each=2), x[length(x)]))
rst2 <- lapply(rst1, function(x) data.frame(eid = get.edge.ids(graph=g, vp = x),
                                    train=E(g)$id[get.edge.ids(graph=g, vp = x)]))

rst3 <- data.frame(pathID=seq_along(rst), 
                   changes=sapply(rst2, function(x) length(rle(x$train)$lengths)), 
                   dist=sapply(rst2, nrow))

spath <- rst3[order(rst3$changes, rst3$dist), ][1,1]

#Vertex IDs
rst[[spath]]
#[1]  1 23  8 18

plot(g, edge.color = E(g)$id, vertex.color=ifelse(V(g) %in% rst[[spath]], "firebrick", "gray80"), 
     edge.arrow.size=0.5)