Finding all shortest paths between two vertices

Question

The built-in FindShortestPath and GraphDistance functions find the shortest path between two particular vertices in a graph. I can't think of a simple way to finding all shortest paths between two vertices. Any ideas?

My graph has weighted edges and the weights are arbitrarily large, so I'm dead against mapping weighted edges to many unweighted edges.

Motivation: I have a graph of city traffic routes from point A to point B. I'd like to take the union of shortest paths from A to B to get a subgraph that, I posit, contains (many of) the most frequented intersections.

Answer 1

Directed Shortest Paths

Here's a friendly amendment to Heike's solution that shows the distance remaining to the finish vertex (in white). The starting vertex is green. Edges are directed to show the appropriate direction toward the finish. According to the documentation on GraphDistance, "For a weighted graph, the distance is the minimum of the sum of weights along any path between s and t." So it should automatically work with weighted graphs.

First, here's Heike's routine, which does most of the heavy lifting, with a simple tweak to produce directed edges:

paths[gr_, {i_, j_}] := 
  Module[{sub, dist, indices, dd, nbrs}, dist = GraphDistance[gr, i, j];
  indices = {};
  dd = dist;
  Reap[Nest[Function[{vv}, dd -= 1;
  nbrs = VertexList[NeighborhoodGraph[gr, #]] & /@ vv;
  nbrs = Pick[#, GraphDistance[gr, #, j] & /@ #, dd] & /@ nbrs;
  Sow /@ Flatten[Thread /@ Thread[vv \[DirectedEdge] nbrs]];
  Union[Flatten[nbrs]]], {i}, dist]][[2, 1]]]

The following produces the directional routes. Numbers refer to GraphDistance from the current vertex to the finish vertex.

gr = RandomGraph[{30, 40}];
ends = {1, 30};
sub = paths[gr, ends];
e = EdgeList[gr] /. {x_ \[UndirectedEdge] y_ /; 
 GraphDistance[gr, x, 30] < GraphDistance[gr, y, 30] :> y \[DirectedEdge] x, 
   x_ \[UndirectedEdge] y_ /; 
 GraphDistance[gr, y, 30] <= GraphDistance[gr, x, 30] :>  x \[DirectedEdge] y}
gr1 = Graph[e, ImagePadding -> 15];

HighlightGraph[gr1, {Graph[sub], Style[1, Green], Style[30, White]}, 
 VertexLabels ->  Table[i -> Style[GraphDistance[gr1, i, 30], 16], {i, 
    Union[Level[sub, {-1}]]}], 
    VertexSize -> {1 -> Large, 30 -> Large}, 
    GraphHighlightStyle -> "Thick", ImagePadding -> 15]

---

Below is a variant that displays (a) the vertex indices (small font size) and the distance from the finish vertex on the EdgeLabel (large font).

HighlightGraph[gr1, {Graph[sub], Style[1, Green], Style[30, White]}, 
   VertexLabels -> (v = Union[Level[sub, {-1}]]) /. {i_Integer :> (i -> i)},
   EdgeLabels -> sub /. {x_ \[DirectedEdge] y_ :> (x \[DirectedEdge] y) -> 
   Style[ GraphDistance[gr, x, 30], 14, Background -> White]},
   VertexSize -> {1 -> Large, 30 -> Large}, 
   GraphHighlightStyle -> "Thick", ImagePadding -> 15, ImageSize -> 600]

Answer 2

To get the union of the shortest paths from i to j in graph gr you could do something like this

paths[gr_, {i_, j_}] := Module[{sub, dist, indices, dd, nbrs},
  dist = GraphDistance[gr, i, j];
  indices = {};
  dd = dist;
  Reap[Nest[
     Function[{vv},
      dd -= 1;
      nbrs = VertexList[NeighborhoodGraph[gr, #]] & /@ vv;
      nbrs = Pick[#, GraphDistance[gr, #, j] & /@ #, dd] & /@ nbrs;
      Sow /@ Flatten[Thread /@ Thread[vv \[UndirectedEdge] nbrs]];
      Union[Flatten[nbrs]]
      ], {i}, dist]][[2, 1]]]

This method works by selecting all neighbours of i whose distance to j is one less than the minimal distance from i to j. For each vertex in this list we then select the neighbours whose distance to j is two less than the minimal distance, etc. until we reach j.

Usage

gr = RandomGraph[{30, 50}];
ends = {1, 30};
sub = paths[gr, ends];
HighlightGraph[gr, {Graph[sub], Style[ends, Green]}]

Answer 3

findMinPathsPoints[k_, ends_] := Module[{dist},
   dist = (GraphDistance[k, #[[1]]] + GraphDistance[k, #[[2]]]) &@ends;
   Complement[Flatten@Position[dist, Min[dist]], ends]];

(*Usage*)

n = 50;
points = {1, 10};
k = PetersenGraph[n, IntegerPart[n/4]]

Subgraph[k, Range@VertexCount@k, VertexStyle -> 
          Join[
              (# -> Red &)    /@ points, 
              (# -> Yellow &) /@ findMinPathsPoints[k, points]]]

Answer 4

With V10, you can use a combination of FindPath and GraphDistance. A (hopefully) self-explanatory example:

g = RandomGraph[{15, 44}, VertexLabels -> "Name"];
s = 1;
t = 2;
FindPath[g, s, t, {GraphDistance[g, s, t]}, All]
HighlightGraph[g, %]

In short, we find all paths between $s$ and $t$ of distance $d(s,t)$.