TransWikia.com

Efficiently determining the K shortest paths in a graph

Mathematica Asked by delivery101 on December 6, 2020

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.

One Answer

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.

Answered by David G. Stork on December 6, 2020

Add your own answers!

Ask a Question

Get help from others!

© 2024 TransWikia.com. All rights reserved. Sites we Love: PCI Database, UKBizDB, Menu Kuliner, Sharing RPP