Wolfram Function Repository

Instant-use add-on functions for the Wolfram Language

Function Repository Resource:

 ToDirectedAcyclicGraph

Source Notebook

Convert any undirected graph to a cycle-free directed graph

Contributed by: Bradley Klee

ResourceFunction["ToDirectedAcyclicGraph"][g,v0]

updates undirected graph g by assigning directions to edges, such that directions point along shortest paths from any one initial vertex v0 to all others.

ResourceFunction["ToDirectedAcyclicGraph"][g,{v1,v2,…}]

returns a directed acyclic conversion of graph g with directions indicating shortest paths from the nearest initial vertex vi.

Details

ResourceFunction["ToDirectedAcyclicGraph"] takes at least the same options as Graph.
ResourceFunction["ToDirectedAcyclicGraph"] enables finding shortest paths and counting them.
This is accomplished as follows: First associate every vertex vi with a graph distance di. Then when an edge goes between vertices vi and vj, so long as di<dj, the assigned direction is from vi to vj.
Distance di is defined using GraphDistance as follows:
for one initial vertex v0di=GraphDistance[g,v0,vi]
for many initial vertices {v1,v2 , …}di=Min[GraphDistance[g,#,vi]&/@{v1,v2,…}]
A difficulty arises with conflicted edges, which join two vertices vi and vj with di==dj.
ResourceFunction["ToDirectedAcyclicGraph"] takes two additional options specifying how to handle conflicted edges.
An optional "CollisionFunction"→cfun specifies a SortBy condition for vertices on a conflicted edge so that is converted to DirectedEdge@@SortBy[{v1,v2},cfun].
Default assignment "CollisionFunction"→None passes collision handling to a second conditional.
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 (3) 

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

Resolve conflicted edges by specifying a CollisionFunction:

In[9]:=
SeedRandom["GraphTest"]; gResolved = ResourceFunction["ToDirectedAcyclicGraph"][RandomGraph[{30, 30}], 1, "CollisionFunction" -> (# &), GraphLayout -> "LayeredDigraphEmbedding", VertexCoordinates -> Automatic]
Out[4]=

Check non-uniqueness of path lengths:

In[10]:=
Length[Union[(Length /@ FindPath[ gResolved, 1, #, Infinity, All])] ] & /@ VertexList[gResolved]
Out[10]=

Properties and Relations (2) 

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

In[11]:=
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[11]=

Using Identity as the CollisionFunction returns the same output as DirectedGraph with "Acyclic" conversion:

In[12]:=
SeedRandom["GraphTest"]; With[{graph0 = RandomGraph[{100, 200}]}, IsomorphicGraphQ[ ResourceFunction["ToDirectedAcyclicGraph"][graph0, 1, "CollisionFunction" -> Identity], DirectedGraph[Graph[SortBy[VertexList[graph0], GraphDistance[graph0, 1, #] &], EdgeList[graph0] ], "Acyclic"]]]
Out[4]=

Possible Issues (3) 

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

In[13]:=
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[13]=

Inputs with disconnected components may return only one component:

In[14]:=
With[{g1 = GraphUnion[CycleGraph[4], VertexReplace[CycleGraph[3], x_ :> x + 4]]}, Row[{g1, Style["\[LongRightArrow]", 32, Gray, Bold], ResourceFunction["ToDirectedAcyclicGraph"][g1, 1, VertexStyle -> {1 -> Orange}, VertexSize -> {1 -> 1/4}, ImageSize -> 200]}, Spacer[10]]]
Out[14]=

This can be fixed by specifying initial vertices on each component:

In[15]:=
With[{g1 = GraphUnion[CycleGraph[4], VertexReplace[CycleGraph[3], x_ :> x + 4]]}, Row[{g1, Style["\[LongRightArrow]", 32, Gray, Bold], ResourceFunction["ToDirectedAcyclicGraph"][g1, {1, 5}, VertexStyle -> {1 -> Orange, 5 -> Magenta}, VertexSize -> {1 -> 1/4, 5 -> 1/4}, ImageSize -> 200]}, Spacer[10]]]
Out[15]=

The function will balk at nonsense inputs:

In[16]:=
ResourceFunction["ToDirectedAcyclicGraph"][Graph[{1, 2}, {}], 1]
Out[16]=
In[17]:=
ResourceFunction["ToDirectedAcyclicGraph"][ Graph[{DirectedEdge[1, 2]}], {}]
Out[17]=
In[18]:=
ResourceFunction["ToDirectedAcyclicGraph"][ Graph[{UndirectedEdge[1, 2]}], {}]
Out[18]=

Neat Examples (2) 

Count possible walks on all Petersen graph outputs:

In[19]:=
CountWalks[graph0_, loc_] := CountWalks[graph0, loc ] = If[MemberQ[{1, {1, 1}}, loc], 1, Total[Cases[EdgeList[graph0], DirectedEdge[pre_, loc ] :> CountWalks[graph0, pre]]]];
In[20]:=
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[20]=

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

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

Plot the possibly new sequence:

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

Conjecture the form of a linear recurrence:

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

Compare with depictions to try and formulate a proof argument:

In[24]:=
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[24]=

Resolve conflicted edges in a square grid:

In[25]:=
unusualGridGraph = ResourceFunction["ToDirectedAcyclicGraph"][With[ {g1 = NearestNeighborGraph[Position[Array[1 &, {5, 5}], 1]]}, EdgeAdd[g1, Flatten@Outer[If[SameQ[#2 - #1, {1, 1}], UndirectedEdge[#1, #2], {}] &, #, #, 1]] &@ VertexList[g1]], {1, 1}, "CollisionFunction" -> (-# &)]
Out[25]=

Calculate part of a numerical triangle associated with the Schroeder numbers (cf. OEIS A033877):

In[26]:=
CountWalks[graph0_, loc_] := CountWalks[graph0, loc ] = If[MemberQ[{1, {1, 1}}, loc], 1, Total[Cases[EdgeList[graph0], DirectedEdge[pre_, loc ] :> CountWalks[graph0, pre]]]];
In[27]:=
Graph[unusualGridGraph, VertexLabels -> ( # -> Placed[CountWalks[unusualGridGraph, #], Center] & /@ VertexList[unusualGridGraph]), VertexSize -> 1/3, VertexStyle -> Directive[White, EdgeForm[LightGray]], EdgeStyle -> Gray]
Out[27]=

Publisher

Brad Klee

Version History

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

License Information