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.
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
Get help from others!
Recent Answers
Recent Questions
© 2024 TransWikia.com. All rights reserved. Sites we Love: PCI Database, UKBizDB, Menu Kuliner, Sharing RPP