How to find the maximal paths of an acyclic directed graph?

Given an acyclic directed graph, say with

edges = {{1, 12}, {2, 3}, {3, 1}, {4, 5}, {7, 5}, {8, 10}, {9, 10}, {10, 11}};


the maximal paths (if that is the right term) can be found as

With[{pathfinder = FindShortestPath[DirectedEdge @@@ edges],
subgraphs = ConnectedComponents[UndirectedEdge @@@ edges],
begins = Complement[edges[[All, 1]], edges[[All, 2]]],
ends = Complement[edges[[All, 2]], edges[[All, 1]]]},

pathfinder @@@ Join @@ (Tuples[{begins ⋂ #, ends ⋂ #}] & /@ subgraphs)]


Out[]= {{2, 3, 1, 12}, {4, 5}, {7, 5}, {8, 10, 11}, {9, 10, 11}}

How to do this with graph functions so as to reduce the complexity?

• Can you explain the problem in plain English, in addition to your code? Commented Dec 19, 2017 at 16:42
• You can find the source and sink vertices using Pick[VertexList[g], VertexOutDegree[g], 0] and Pick[VertexList[g], VertexInDegree[g], 0] if g is a directed graph. Commented Dec 19, 2017 at 17:16

ClearAll[sstsp, shortestSourceToSinkPaths, highlightPaths]
sstsp = shortestSourceToSinkPaths = Module[{g = #,
sources = GraphComputationSourceVertexList @ #,
sinks = GraphComputationSinkVertexList @ #},
Join @@ (Module[{v = #, vsinks = Intersection[sinks, VertexOutComponent[g, #]]},
Join @@ (MinimalBy[Length][FindPath[g, v, #, Infinity, All] ]& /@ sinks)]&/@sources)]&;

highlightPaths = Module[{g = #},
HighlightGraph[g, Style[Subgraph[g, #], Thick] & /@ sstsp[g],
PlotLabel -> Style[sstsp[g], Black, 12, "Panel", Background -> None]]]&;


Examples:

edges = {{1, 12}, {2, 3}, {3, 1}, {4, 5}, {7, 5}, {8, 10}, {9, 10}, {10, 11}};
g = Graph[DirectedEdge @@@ edges, VertexShapeFunction->"Name"];

highlightPaths @ g


SeedRandom[123]
g2 =  RandomGraph[PriceGraphDistribution[10, 3, 2],
DirectedEdges -> True, VertexShapeFunction-> "Name", ImageSize->600];

highlightPaths @ g2


I'm assuming by "maximal" path you mean the maximum-length shortest path between two vertexes. (If not, you can always make a longer path by wandering around the graph... unhelpful.)

g = Graph[edges];
First@GroupBy[
Flatten[
Table[{i, j, Length@FindShortestPath[g, i, j]},
{i, Length[edges]}, {j, i - 1}], 1], #[[3]] &]


(* {{2,1,3}, {7, 4, 3}} *)

which means that the longest path is of length 3 and is between vertexes 2 an 1 and between vertexes 7 and 4.

This function is extremely fast, finding the longest paths in g = RandomGraph[{20000, 40000}]; in $0.014693$ seconds.

Try:

g = RandomGraph[{20000, 40000}];
Timing[First@
GroupBy[Flatten[
Table[{i, j, Length@FindShortestPath[g, i, j]},
{i, Length[edges]}, {j, i - 1}], 1], #[[3]] &]]