Wolfram Research

Function Repository Resource:

ToDirectedAcyclicGraph (1.0.0) current version: 1.0.2 »

Source Notebook

Convert any undirected graph to a cycle-free directed graph

Contributed by: Bradley Klee  |  Brad Klee

ResourceFunction["ToDirectedAcyclicGraph"][graph,vertex]

updates undirected graph by assigning directions to every edge, such that directions point along shortest paths from any initial vertex to any other.

ResourceFunction["ToDirectedAcyclicGraph"][graph,vertices]

returns a directed acyclic graph indicating shortest paths, but accepts multiple starting points in a list of vertices.

Details

ResourceFunction["ToDirectedAcyclicGraph"] enables not only finding shortest paths, but also counting how many such paths exist.
ResourceFunction["ToDirectedAcyclicGraph"] takes the same options as Graph, with the additional option "ConflictedEdges" that specifies how to handle conflicted edges.
At time t=0 the algorithm starts to expand directed edges from an initial vertex or set of vertices.
Per increment of time t, more vertices and edges are recursively added on a growing front.
Eventually, this growth process assigns a turn-on time t to each vertex, which is also its graph distance either to vertex or to one or more of the vertices.
An edge is considered to be conflicted at time t if it goes between two vertices with the same turn-on time t.
With "ConflictedEdges"False, ResourceFunction["ToDirectedAcyclicGraph"] deletes conflicted edges.
With "ConflictedEdges"True, ResourceFunction["ToDirectedAcyclicGraph"] returns conflicted edges as undirected edges.

Examples

Basic Examples (2) 

Determine all shortest paths on a random graph:

In[1]:=
With[{g1 = (SeedRandom["SimpleTest"]; RandomGraph[{6, 12}, ImageSize -> 200])},
 Row[{g1, Style["\[LongRightArrow]", 32, Gray, Bold], ResourceFunction["ToDirectedAcyclicGraph"][g1, 1,
    VertexStyle -> {1 -> Orange}, VertexSize -> {1 -> 1/3}, ImageSize -> 200]},
  Spacer[10]]]
Out[1]=

Verify that the output above is indeed Directed and Acyclic:

In[2]:=
With[{g1 = (SeedRandom["SimpleTest"]; RandomGraph[{10, 20}, ImageSize -> 200])},
 And[AcyclicGraphQ[#], DirectedGraphQ[#]] &@
  ResourceFunction["ToDirectedAcyclicGraph"][g1, 1]]
Out[2]=

Scope (3) 

Explore traversal maps of a Petersen graph:

In[3]:=
Grid[{Text /@ {"Input", "Output", "Output"},
  Prepend[
   ResourceFunction["ToDirectedAcyclicGraph"][PetersenGraph[6, 2], #,
      VertexStyle -> {# -> Orange}, VertexSize -> {# -> 1/4}] & /@ {1,
      7},
   PetersenGraph[6, 2]]}, Frame -> All, FrameStyle -> Lighter[Gray],
 Spacings -> {2, 2}]
Out[3]=

Add another Graph-exploring reference point and compare possible pairwise dance moves:

In[4]:=
Grid[Partition[Show[#, ImageSize -> 100] & /@ ReplacePart[Map[
     ResourceFunction["ToDirectedAcyclicGraph"][
       PetersenGraph[6, 2], {1, #},
       VertexStyle -> {1 -> Magenta, # -> Orange},
       VertexSize -> {1 -> 1/4, # -> 1/4},
       "ConflictedEdges" -> True,
       EdgeStyle -> {UndirectedEdge[_, _] -> LightGray,
         DirectedEdge[_, _] -> Gray}] &, Range[12]],
    {1 -> Graph[{}]}], 6]]
Out[4]=

Check to see that edges are lost only on odd cycles:

In[5]:=
Grid[Prepend[{CycleGraph[#],
     ResourceFunction["ToDirectedAcyclicGraph"][CycleGraph[#], 1,
      VertexStyle -> {1 -> Orange}, VertexSize -> {1 -> 1/16}]} & /@ {3, 4, 5},
  Text /@ {"Input", "Output"}], Frame -> All,
 FrameStyle -> Lighter[Gray], Spacings -> {2, 2}]
Out[5]=

Compare what happens when different initial conditions are chosen:

In[6]:=
With[{graph0 = Last[SortBy[
     ConnectedGraphComponents[
      SeedRandom["GraphTest"];
      RandomGraph[{30, 30}]],
     VertexCount]]}, Grid[Partition[
   Show[#, ImageSize -> 250] & /@ Prepend[
     ResourceFunction["ToDirectedAcyclicGraph"][graph0, #,
          VertexStyle -> {# -> Orange},
          VertexSize -> {# -> 1/2},
          "ConflictedEdges" -> True,
          EdgeStyle -> {UndirectedEdge[_, _] -> Lighter@Gray,
            DirectedEdge[_, _] -> Arrowheads[1/25]}
          ] &@# & /@ RandomSample[
        VertexList[graph0]][[{1, 3, 5}]],
     graph0], 2], Frame -> All,
  FrameStyle -> Lighter[Gray],
  Spacings -> {2, 2}]]
Out[6]=

Options (2) 

Acyclic directed graphs can be plotted as causal graphs by setting VertexCoordinates to Automatic:

In[7]:=
Grid[{Text /@ {"Input", "Output", "Output"},
  Prepend[
   ResourceFunction["ToDirectedAcyclicGraph"][PetersenGraph[8, 2], #,
      VertexStyle -> {# -> Orange}, VertexSize -> {# -> 1/4},
      VertexCoordinates -> Automatic
      ] & /@ {1, 9}, PetersenGraph[8, 2]]},
 Frame -> All, FrameStyle -> Lighter[Gray],
 Spacings -> {2, 2}]
Out[7]=

Plot a few more causal graphs:

In[8]:=
With[{graph0 = Last[SortBy[
     ConnectedGraphComponents[
      SeedRandom["GraphTest"];
      RandomGraph[{30, 30}]],
     VertexCount]]}, Grid[Partition[
   Show[#, ImageSize -> 250] & /@ Prepend[
     ResourceFunction["ToDirectedAcyclicGraph"][graph0, #,
          VertexStyle -> {# -> Orange},
          VertexSize -> {# -> 1/4},
          VertexCoordinates -> Automatic,
          GraphLayout -> "LayeredDigraphEmbedding",
          "ConflictedEdges" -> True,
          EdgeStyle -> {UndirectedEdge[_, _] -> LightGray,
            DirectedEdge[_, _] -> Arrowheads[1/25]}
          ] &@# & /@ RandomSample[
        VertexList[graph0]][[{1, 4, 5}]],
     graph0], 2], Frame -> All,
  FrameStyle -> Lighter[Gray],
  Spacings -> {2, 2}]]
Out[8]=

Properties and Relations (1) 

The transformation acts as the identity on rows of the GraphDistanceMatrix:

In[9]:=
With[{graph0 = Last[SortBy[
     ConnectedGraphComponents[RandomGraph[{30, 30}]],
     VertexCount]]}, SameQ[Outer[GraphDistance[
     ResourceFunction["ToDirectedAcyclicGraph"][graph0, #1], #1, #2] &,
   VertexList[graph0], VertexList[graph0], 1],
  GraphDistanceMatrix[graph0]]]
Out[9]=

Possible Issues (2) 

Specifying multiple reference points can divide the graph into disconnected components:

In[10]:=
ResourceFunction["ToDirectedAcyclicGraph"][CycleGraph[6], {1, 4},
 "ConflictedEdges" -> True,
 VertexStyle -> {1 -> Red, 4 -> Blue, 2 | 3 | 5 | 6 -> Green},
 VertexSize -> {1 -> 1/10, 4 -> 1/10},
 EdgeStyle -> {UndirectedEdge[_, _] -> LightGray,
   DirectedEdge[_, _] -> Darker@Gray}]
Out[10]=

The function will balk at nonsense inputs:

In[11]:=
ResourceFunction["ToDirectedAcyclicGraph"][
 Graph[{DirectedEdge[1, 2]}], {}]
Out[11]=
In[12]:=
ResourceFunction["ToDirectedAcyclicGraph"][
 Graph[{UndirectedEdge[1, 2]}], {}]
Out[12]=

Neat Examples (5) 

Count possible walks on all Petersen graph outputs:

In[13]:=
CountWalks[graph0_, loc_] := CountWalks[graph0, loc
    ] = If[loc == 1, 1, Total[Cases[EdgeList[graph0],
      DirectedEdge[pre_, loc
        ] :> CountWalks[graph0, pre]]]];
In[14]:=
TableForm[countWalksTable = Table[With[
    {graph0 = ResourceFunction["ToDirectedAcyclicGraph"][PetersenGraph[i, j], 1]},
    Total[CountWalks[graph0, #] & /@ Select[VertexList[graph0],
       SameQ[Cases[EdgeList[graph0], DirectedEdge[#, _]], {}] &]]],
   {i, 3, 20}, {j, 1, i}]]
Out[14]=

List a sequence that does not have an entry in the OEIS:

In[15]:=
countWalksTable[[All, 2]]
Out[15]=

Plot the possibly new sequence:

In[16]:=
ListPlot[countWalksTable[[All, 2]]]
Out[16]=

Conjecture the form of a linear recurrence:

In[17]:=
FindLinearRecurrence[countWalksTable[[5 ;; -1, 2]]]
Out[17]=

Compare with depictions to try and formulate a proof argument:

In[18]:=
Grid[Riffle[Partition[
   ResourceFunction["ToDirectedAcyclicGraph"][PetersenGraph[#, 2], 1,
      VertexStyle -> {1 -> Orange}, VertexSize -> {1 -> 1/4},
      "ConflictedEdges" -> True,
      EdgeStyle -> {UndirectedEdge[_, _] -> LightGray}]
     & /@ Range[5, 10], 3], Partition[countWalksTable[[3 ;; 9, 2]], 3]]]
Out[18]=

Version History

  • 1.0.2 – 13 May 2022
  • 1.0.1 – 26 April 2022
  • 1.0.0 – 08 April 2022

License Information