# Efficiently determining the K shortest paths in a graph

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, WAmatrix, dirgraph},    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 🙂