Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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]]]

enter image description here

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}

share|improve this question
    
Your plotted graph is not the one specified by egdes (also note the typo). –  István Zachar Oct 16 '13 at 14:43
add comment

3 Answers

up vote 4 down vote accepted

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]

Mathematica graphics

pathWeights = Map[Rule @@@ Partition[#, 2, 1] &, paths, {2}] /. weights
Total /@ Apply[Times, pathWeights, {2}]
{3/8, 1/4, 3/8}
share|improve this answer
    
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
    
Thank you! Cool! –  Филипп Цветков Oct 16 '13 at 17:01
add comment

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]

enter image description here

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[8] -> Range[8] - 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]]]]

enter image description here

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}
share|improve this answer
    
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
add comment

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}]

enter image description here

share|improve this answer
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.