Flow in pipeline graph

I have pipeline directed graph which has one source and several sinks

getWeights = Function[{g},
res = {};
s = Flatten[{#1} & @@@ g, 1];
For[i = 1, i <= Length[s], i++,
AppendTo[res, 1/Count[Flatten[{#1} & @@@ g, 1], s[[i]]]];];
res
];

egdes = {0 -> 1, 0 -> 2, 0 -> 3, 1 -> 4, 1 -> 5, 1 -> 6, 3 -> 6,
3 -> 7 , 2 -> 5, 2 -> 6, 4 -> 8, 5 -> 8, 5 -> 9, 6 -> 9, 7 -> 9,
5 -> 10, 7 -> 10};
wghts = getWeights[egdes]
Graph[egdes, EdgeWeight -> wghts,
VertexLabels -> Placed["Name", Center], VertexSize -> Medium,
EdgeLabels -> Table[egdes[[i]] -> wghts[[i]], {i, Length[egdes]}]]
sinks = Complement[DeleteDuplicates[Flatten[{#2} & @@@ egdes, 1]],
DeleteDuplicates[Flatten[{#1} & @@@ egdes, 1]]]
sources= Complement[DeleteDuplicates[Flatten[{#1} & @@@ egdes, 1]],
DeleteDuplicates[Flatten[{#2} & @@@ egdes, 1]]] Now I would like to calculate the the flow in sinks assuming the flow at source is equal to 1. I did it by finding all paths from source to sink and then summing the products of all edges weight in the path for all paths. My code is rather ugly and slow for large graphs so I do not put it here. I hope that someone could help me to find more elegant and fast decision. For the case in the figure there are three sinks {5,6,7} I found flows {3/8,1/4,3/8}

• Your plotted graph is not the one specified by egdes (also note the typo). – István Zachar Oct 16 '13 at 14:43

The following algorithm finds all paths from vertex s to vertex t in a directed graph represented by the adjacency matrix a (note that here s and t are for vertex positions and not vertex names!).

findPaths[a_?MatrixQ, s_Integer, t_Integer] := Module[{child, find},
child[v_] := Flatten@Position[a[[v]], Except@0, 1, Heads -> False];
find[v_, list_] := Scan[If[# === t, Sow[Append[list, #]],
If[FreeQ[list, #], find[#, Append[list, #]]]] &, child@v];
If[# =!= {}, First@#, {}] &@Last@Reap@find[s, {s}]
];

First, collect all the sources and sinks in a more functional way:

edges = {0->1, 1->5, 1->6, 0->2, 2->7, 0->3, 3->5, 0->4, 4->6, 4->7};
weights = Thread[edges -> Block[{s = First /@ edges}, 1/Count[s, #] & /@ s]];
g = Graph[edges, EdgeWeight -> weights];
nodes = VertexList@g;
{sources, sinks} = Pick[nodes, #@g, 0] & /@ {VertexInDegree, VertexOutDegree}
{{0}, {5, 6, 7}}

Now apply findPaths to the graph's adjacency matrix (with properly converting vertex labels to vertex positions according to VertexList@g):

convert = Thread[nodes -> Range@Length@nodes];
paths = First@Outer[findPaths[Normal@AdjacencyMatrix@g, #1, #2] &,
sources /. convert, sinks /. convert] /. Reverse/@convert;

Grid@Partition[HighlightGraph[g, #, PlotLabel -> #] & /@
Flatten[Map[Rule @@@ Partition[#, 2, 1] &, paths, {2}], 1], 3] pathWeights = Map[Rule @@@ Partition[#, 2, 1] &, paths, {2}] /. weights
Total /@ Apply[Times, pathWeights, {2}]
{3/8, 1/4, 3/8}
• Cool! Thank you! Paths finding works good, but there is problems with flow calculations. If we complicate the graph edges = {0 -> 1, 1 -> 5, 1 -> 6, 0 -> 2, 2 -> 7, 0 -> 3, 3 -> 5, 0 -> 4, 4 -> 6, 4 -> 7, 2 -> 6, 2 -> 8, 6 -> 9, 7 -> 9, 9 -> 10, 8 -> 10}; the output will be {3/8, {{1/4, 1/2, 1, 1}, {1/4, 1/3, 1, 1}, {1/4, 1/3, 1, 1}, {1/4, 1/3, 1}, {1/4, 1/2, 1, 1}, {1/4, 1/2, 1, 1}}} – Филипп Цветков Oct 16 '13 at 15:55
• @Филипп Corrected flow calculation, and also edited findPaths so that it can handle cyclic directed graphs as well. – István Zachar Oct 16 '13 at 16:34

You can try with FindMaximumFlow:

g = Graph[egdes, EdgeWeight -> wghts, VertexLabels -> Placed["Name", Center],
VertexSize -> Medium]

op = FindMaximumFlow[g, sources, sinks, "OptimumFlowData", EdgeCapacity -> EdgeWeight];

elabels = # -> Framed[Row[{PropertyValue[{g, #}, EdgeWeight], " / ",
NumberForm[op[#], 2]}], Background -> White] & /@ op["EdgeList"];

SetProperty[op["FlowGraph"], {EdgeLabels -> elabels, ImagePadding -> 10}]ImagePadding -> 10}] I accept this question is answered. I just observe that this question could be formulated as A discrete Markov process (sinks as absorbing states):

edges = {0 -> 1, 1 -> 5, 1 -> 6, 0 -> 2, 2 -> 7, 0 -> 3, 3 -> 5,
0 -> 4, 4 -> 6, 4 -> 7, 7 -> 7, 5 -> 5, 6 -> 6};
g = Graph[Range[0, 7, 1], edges,
VertexLabels -> Placed["Name", Center], VertexLabelStyle -> 20,
VertexSize -> 0.4] Setting up:

ma = DiscreteMarkovProcess[{1, 0, 0, 0, 0, 0, 0, 0},
Normal[#/Total[#] & /@ AdjacencyMatrix[g]]];
Graph[ma,
VertexLabels -> (#1 -> Placed[#2, Center] & @@@ (Thread[
Range -> Range - 1])), VertexSize -> 0.5,
VertexLabelStyle -> 20,
EdgeLabels ->
With[{sm = MarkovProcessProperties[ma, "TransitionMatrix"]},
Cases[Flatten@
Table[DirectedEdge[i, j] -> sm[[i, j]], {i, 8}, {j, 8}],
Except[_ -> 0]]]] Stationary distribution can determine "flow":

stat = StationaryDistribution[ma]

Note distribution is consistent with desired result (vertex label=vertex-1):

ProbabilityDistribution[
3/8 Boole[\[FormalX] == 6] + 1/4 Boole[\[FormalX] == 7] +
3/8 Boole[\[FormalX] == 8], {\[FormalX], 1, 8, 1}]

Directly:

Probability[x == #, x \[Distributed] stat] & /@ {6, 7, 8}

yields:

{3/8, 1/4, 3/8}
• answered yes... still proposed solutions works with small graphs. And if I have graph with thousands nodes, and hundreds sinks it works very slow. I cann't chek your code since I have no access to Mathematica 9 for a moment. Maybe it works faster. So thank you in any case! I voted. – Филипп Цветков Oct 17 '13 at 11:19