6
$\begingroup$

My goal is to efficiently find the $k$ shortest paths between a source and a destination in an undirected graph. I implemented two solutions of this problem myself, but, as I am very interesting in efficiency, was wondering if there might be a more efficient solution to this problem.

The first solution is based on Yen's algorithm (https://en.wikipedia.org/wiki/Yen%27s_algorithm):

yen[graph_, source_, destination_, k_] := 
  Module[{a, b, gtemp, spurnode, roothpath, sp, roothminusspur, 
    double},
   a = {FindShortestPath[graph, source, destination]};
   b = {};
   Do[
    Do[
     gtemp = graph;
     roothpath = a[[-1]][[1 ;; i + 1]];
     roothminusspur = Drop[roothpath, -1];
     double = 
      Table[If[
        a[[l]][[1 ;; Min[i + 1, Length[a[[l]]]]]] == roothpath, 
        a[[l]][[i + 1]] \[UndirectedEdge] a[[l]][[i + 2]], {}], {l, 1,
         Length[a]}];
     gtemp = EdgeDelete[gtemp, Union[Flatten@double]];
     gtemp = VertexDelete[gtemp, roothminusspur];
     sp = FindShortestPath[gtemp, roothpath[[-1]], destination];
     If[Length[sp] > 0, 
      AppendTo[
       b, {GraphDistance[gtemp, roothpath[[-1]], destination], 
        Flatten@{roothminusspur, sp}}]];
     , {i, 0, Length[a[[-1]]] - 2}];
    If[Length[b] == 0, Break[], 
     b = SortBy[Union[b], First];
     AppendTo[a, b[[1]][[2]]];
     b = Drop[b, 1]];
    , {j, 1, k - 1}];
   Return[a]
   ];

The second solution is a bit ugly and can be arbitrary slow, but works quite well on graphs that have a lot of arcs and the weights between these arcs do not differ that much. The idea is to use the build-in FindPath function of Mathematica and increase the costs, until you have indeed found $k$ or more paths. If you have found more than $k$ paths, you delete the paths with the most costs:

nmatrix = WeightedAdjacencyMatrix[graph];
maxcosts = Total[nmatrix, 2];
costs = GraphDistance[graph, source, destination];
Do[
 paths = FindPath[graph, source, destination, costs + l, All];
 If[Length[paths] >= k, costest = costs + l - 1; Break[]], 
 {l, 0, Round[maxcosts - costs]}];
If[Length[paths] > k, 
 defpaths = FindPath[graph, source, destination, costest, All];
 possiblepaths = Complement[paths, defpaths];
 costpaths = 
  Table[Sum[
    nmatrix[[possiblepaths[[j]][[i]]]][[possiblepaths[[j]][[i + 
         1]]]], {i, Length[possiblepaths[[j]]] - 1}], {j, 
    Length[possiblepaths]}];
 paths = Join[defpaths, 
   possiblepaths[[Ordering[costpaths][[1 ;; k - Length[defpaths]]]]]];
 ];

Any hints/suggestions for speed-up techniques or more elegant solutions are more than welcome :)

Edit: the graphs I am working with are graphs with approximately 100 vertices and undirected 150 edges (thus 300 directed edges), that might be good to know as well.

Improve this question
$\endgroup$
9
  • $\begingroup$ Do you know the function: FindShortestPath ? introduced in MMA in 2010) $\endgroup$
    – Daniel Huber
    Dec 1, 2020 at 12:47
  • 3
    $\begingroup$ @DanielHuber FindShortestPath only finds the shortest path between two vertices. OP then wants to find the 2nd shortest, 3rd shortest, etc. between the same two vertices. $\endgroup$
    – Szabolcs
    Dec 1, 2020 at 13:03
  • $\begingroup$ @DanielHuber I did indeed find this function, and have also used it in my implementation. But as Szabolcs correctly points out, this function cannot do the trick here (as far as I am concerned it can only find the shortest path itself, not the $k$ shortest paths) $\endgroup$
    – delivery101
    Dec 1, 2020 at 13:54
  • 2
    $\begingroup$ FindShortestPath can be called as FindShortestPath[g,All,All] which gives you a re-usable ShortestPathFunction. You cannot use this feature in your algorithm because you're deleting edges. But maybe if you do things differently: find all shortest paths START -> MIDDLE -> END where middle varies - that is you find a shortest paths from START to MIDDLE, then get the shortest path from MIDDLE to END. Vary the MIDDLE vertex on each iteration (distinct from START/END vertices). This way you're not deleting edges and can call FindShortestPath just once and make use of ShortestPathFunction $\endgroup$
    – flinty
    Dec 1, 2020 at 16:33
  • 1
    $\begingroup$ @delivery101 Yen's algorithm is something I wanted to implement for igraph for a while. Once that is done, I will also expose it in IGraph/M, so it can be used from Mathematica. However, I certainly won't have time for this for many months. If you can program in C, and are up to the task, contributions are very welcome! Ping me if you're interested. $\endgroup$
    – Szabolcs
    Dec 2, 2020 at 13:43

1 Answer 1

Reset to default
3
$\begingroup$ 
g = RandomGraph[{30,50}];

l = Length[FindShortestPath[g, 5, 9];

(l is the length of shortest path between vertex 5 and vertex 9)

Table[FindPath[g,5,9,{i}],{i,l,l+3}]

A table of individual paths of length l, l+1, l+2, l+3

As @Szabolc points out, if your want to include paths that happen to have the same length, use:

Table[FindPath[g,5,9,{i}, All],{i,l,l+3}]

You can SortBy these by length and then select the $k$ shortest.

Improve this answer
$\endgroup$
2
  • 1
    $\begingroup$ There may be more than one path of the same length. They can be found by adding All as the 5th argument to FindPath $\endgroup$
    – Szabolcs
    Dec 2, 2020 at 21:48
  • $\begingroup$ @Szabolcs: Yes. I'll add that to the solution, so more people see it. $\endgroup$
    – David G. Stork
    Dec 2, 2020 at 22:07

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.