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 🙂
