1
$\begingroup$

Let's say I have a weakly connected graph like:

vertices = Range[8];
g = Graph[vertices, { 2 -> 1, 3 -> 2,  4 -> 3, 5 ->6 , 7 -> 6, 6-> 2, 2 -> 8}, VertexLabels -> "Name"]

enter image description here

On the right you can see the adjacency matrix of the graph.

want

  • I want to have an algorithm that finds a causally consistent path for a given graph.

For the graph shown above, the following are all examples of acceptable paths:

   { {4 -> 3 -> 2}, {5 -> 6}, {7 -> 6}, {6 -> 2}, {2 -> 1} }
   { {4 -> 3 -> 2}, {7 -> 6}, {5 -> 6}, {6 -> 2}, {2 -> 1} }
   { {7 -> 6}, {5 -> 6}, {6 -> 2}, {4 -> 3 -> 2}, {2 -> 1} }
   { {5 -> 6}, {7 -> 6}, {6 -> 2}, {4 -> 3 -> 2}, {2 -> 1} }

ie {2 -> 1} happens after {6 -> 2} and {3 -> 2} and so on.

  • Having discovered such a path, I then want to animate the traversal of this path on the graph and animate/manipulate it.

observations

  • it's easy to find the "destinations" of this graph. it's the one with a row of all 0s, ie. row 1 and 8 in the matrix.

  • it's easy to find the "origins" of this graph. it's the ones with associated column of all zeros. ie 4,5 or 7 in the matrix.

  • in general, we can get them with:

Destinations[g_? GraphQ]:= Flatten[Position[AdjacencyMatrix[g] //Normal, ConstantArray[0,Length[VertexList[g]]]]];
Origins[g_? GraphQ]:= Flatten[Position[AdjacencyMatrix[g] // Transpose //Normal, ConstantArray[0,Length[VertexList[g]]]]];
  • we can get the paths from origins to a destination of interest using:
path1 = FindPath[g, 4, 1, Infinity, All]
path2 = FindPath[g, 5, 1, Infinity, All]
path3 = FindPath[g, 7, 1, Infinity, All]

but these paths will intersect and upon intersection we should only proceed if other edge is already traversed. how can we check that?

  • If constructing the path backwards, the last step can be found by looking at the its associated column and seeing the cells with 1 in them. with an endpoint of 1, the last step is 2->1.

  • For 2, it's 3->2 and 6->2. and so on. in general, it's a function of the form:

InwardEdges[g_,v_]:= Cases[EdgeList[g],v \[DirectedEdge] _]
  • similarly we can go forward by:
OutwardEdges[g_,v_]:= Cases[EdgeList[g],v \[DirectedEdge] _]
  • for it to be easier to follow the sequence of events, i would like to disallow the following paths:
  { {5 -> 6}, {4 -> 3 -> 2}, {7 -> 6}, {6 -> 2}, {2 -> 1} }
  { {7 -> 6}, {4 -> 3 -> 2}, {5 -> 6}, {6 -> 2}, {2 -> 1} }

though they are perfectly valid casual paths.

potential strategy

  • make explicit all the assumptions about the graph in our solution. ie, a causal graph can't be cyclic, should have at least one endpoint, etc.

  • We have to make the decision whether to construct the path backwards or forwards.

  • We could try analysing the paths returned by findPath calls: we can define a recursive function with the following pseudo-code:

findPath[paths_]:= Module[ {...},
findPathRec[{}, p_] :=p
findPathRec[remainingPaths_, {}]:=  (
//pick the head edge, in one of the paths 
findPathRec[headDropped, {head}]
)
findPathRec[remainingPaths_, traversed_]:=  (
//look at the edge sitting at the head of the traversed path, see if there is any path that has the "end" of the edge in it. if so, drop it from the remaining paths, prepend that to traversed and make an iterative call to findPathRec
)

findPathRec[paths, {}]
]

where we call it with {path1, path2, path3} as described earlier.

  • alternatively we could use the adjacency matrix of the graph directly and use previousEdges/nextEdges to construct the path based on the graph

  • once we have a valid causally-consistent path, we can show the vertices by:

path =  { 5 -> 6, 7 -> 6, 6 -> 2, 4 -> 3, 3 -> 2, 2 -> 1 };
Animate[HighlightGraph[g, Subgraph[g, Take[path, k]]], {k, 0,Length[path],1}]

where we would evaluate the path instead of hard-coding it as demonstrated above.

$\endgroup$
16
  • 1
    $\begingroup$ How would you want to draw this one? Graph[{1 -> 2, 2 -> 3, 3 -> 4, 1 -> 5, 5 -> 4, 6 -> 5}, VertexShapeFunction -> "Name", PerformanceGoal -> "Quality"] Here the levels where each vertex is drawn are not uniquely defined. Mathematica draws 1 higher than 6, but it doesn't have to be so. $\endgroup$ – Szabolcs Apr 24 '20 at 17:47
  • 1
    $\begingroup$ So you just want a topological sort? TopologicalSort. This orders vertices so that the causal order is respected $\endgroup$ – Szabolcs Apr 24 '20 at 17:59
  • 1
    $\begingroup$ Note that those are vertices, not edges. You are confusing the terms. $\endgroup$ – Szabolcs Apr 24 '20 at 18:08
  • 1
    $\begingroup$ Teeny suggestion: Range[7] (not Range[1,7]). $\endgroup$ – David G. Stork Apr 24 '20 at 18:55
  • 1
    $\begingroup$ @Shb: Computational efficiency is ABSOLUTELY IRRELEVANT to this problem. You can draw graphs with $100000$ nodes and $1000000$ edges in 0.45 seconds. (Timing[RandomGraph[{100000, 1000000}];]). You are completely off the mark if you care at all about computational efficiency. Completely off the mark. And the differences between algorithms are even more irrelevant. Over and out. $\endgroup$ – David G. Stork Apr 25 '20 at 1:43
2
$\begingroup$

A start:

Here is how you color the edges:

Graph[Range[8],
 {2 -> 1, 3 -> 2, 4 -> 3, 5 -> 6, 7 -> 6, 6 -> 2, 2 -> 8},
 EdgeStyle -> {
   (2 -> 1) -> Red, 
   (3 -> 2) -> Blue, 
   (4 -> 3) -> Green, 
   (5 -> 6) -> Orange, 
   (7 -> 6) -> Purple, 
   (6 -> 2) -> Black, 
   (2 -> 8) -> Yellow}]

enter image description here

So define two colors for edges that are unhighlighted (blue) and highlighted (red). Then use the sequences to replace the colors listed above (algorithmically). That is, replace the spectral colors above with col21, col32, etc. Then, outside the graph plotting, assign the colors based on the desired sequence of highlighting.

Graph[Range[8],
 {2 -> 1, 3 -> 2, 4 -> 3, 5 -> 6, 7 -> 6, 6 -> 2, 2 -> 8},
 EdgeStyle -> {
   (2 -> 1) -> col21, 
   (3 -> 2) -> col32, 
   (4 -> 3) -> col43, 
   (5 -> 6) -> col56, 
   (7 -> 6) -> col76, 
   (6 -> 2) -> col62, 
   (2 -> 8) -> col28}]

To highlight the graph set:

col43 = col32 = Red;
col21 = col56 = col76 = col62 = col28 = Blue;

and then render the graph.

This can be done far more efficiently with List manipulation reading the sequence of edges you wish to render, but I think this approach will work.

$\endgroup$
6
  • $\begingroup$ Thanks! unfortunate I got myself confused. what I really meant was plotting the edges sequentially not vertices. $\endgroup$ – Shb Apr 24 '20 at 18:55
  • $\begingroup$ Thank you. I think HighlightGraph, as suggested by @szabolcs does a good enough job of doing it automatically though, don't you think? $\endgroup$ – Shb Apr 24 '20 at 23:45
  • $\begingroup$ anyhow, my main problem is actually arriving at the path to show as I don't want to have to hardcode it. $\endgroup$ – Shb Apr 24 '20 at 23:47
  • $\begingroup$ @Shb: But that is not at all the question you asked us. You gave us the edges and the order you wanted them highlighted. $\endgroup$ – David G. Stork Apr 25 '20 at 1:20
  • $\begingroup$ I apologies for being vague. i have iteratively improved the question now. I need both the path and a way to draw this path sequentially. please feel free to suggest edits. $\endgroup$ – Shb Apr 25 '20 at 1:22
0
$\begingroup$

Here is my attempt at the solution:

Destinations[g_? GraphQ]:= Flatten[Position[AdjacencyMatrix[g] //Normal, ConstantArray[0,Length[VertexList[g]]]]];
Origins[g_? GraphQ]:= Flatten[Position[AdjacencyMatrix[g] // Transpose //Normal, ConstantArray[0,Length[VertexList[g]]]]];

FindCausalPath[graph_?GraphQ, edge_] /; MemberQ[VertexList[graph], edge] :=  Block[ 
{ 
  m = AdjacencyMatrix[graph] // Normal,
  path = {},
  from,
  to,
  verticesBeforeFrom,
  verticesBeforeTo,
  forward,
  backward,
  next
},
  (*sub-routines*)
  verticesBeforeFrom := Flatten[Position[m[[All, from]], 1]];
  verticesBeforeTo := Flatten[Position[m[[All, to]], 1]];
  forward:= Switch[verticesBeforeTo, 
    {from}|{}, {to, If[m[[to, edge]] == 1, edge, First[FirstPosition[m[[to]], 1|-1]]]},
    _, {SelectFirst[#!=from&][verticesBeforeTo], to}
  ];
  backward := {verticesBeforeFrom[[1]], from};

  (*initialisation*)
  from = SelectFirst[Origins[g], FindPath[g,#, edge]!={}&];
  to = First[FirstPosition[m[[from]], 1]];

  While[True,
    If[to == edge,  AppendTo[path, from \[DirectedEdge] to];Break[]];
    {from, to} = Switch[verticesBeforeFrom,
      {}, (next = forward; m[[from, to]]=0; AppendTo[path, from \[DirectedEdge] to]; next),
      _,  (next = backward; m[[from, to]]= -1; next)
    ];
  ];

 path
]

and I can show the results with:

path = findPath[g,1];
style[n_]:=  If[MemberQ[Take[path,n],#],#-> {Blue, Thick},# -> {Dotted, Thick, Red}]& /@ EdgeList[g];
Animate[
  Graph[VertexList[g],EdgeList[g], EdgeStyle -> style[k]],
  {k, 0,Length[path],1}
]
  • It's a bit verbose and imperative.

  • I'd be interested to know if there is a way of doing this without the adjacency matrix.

  • I don't write mathematica code often, so I'd be keen to know how readable people find it.

  • I am not sure if there are edge-cases it won't cover.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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