Question about TransitiveReductionGraph

It's a bug.

I have reported it to WRI. The case ID is 3345230. And the Wolfram Technical Support has confirmed it as "a known issue", but no workaround is given.

It seems that this bug has been known to Wolfram for nearly 3 years, yet very disappointingly it is still unfixed in M11.2.

---

Introduction

Here I give a re-implementation of transitive reduction. The single function IGVertexContract is used from IGraph/M for convenience (to contract multiple vertex sets simultaneaously). This can be re-implemented with builtins, of course.

This implementation treats these cases separately:

• If the graph is undirected, it uses the minimum spanning tree.
• If the graph is directed and acyclic, it will remove an edge $i \rightarrow j$ if there is any path longer than 1 also connecting $i$ and $j$. Since the graph is acyclic, any such longer path cannot include $i \rightarrow j$ itself, therefore the removal of $i \rightarrow j$ won't affect it, or the transitivity structure of the graph.
• If the graph is directed and has cycles, then it will first break it into connected components, and contract these components into single vertices, thus obtaining an acyclic graph. The transitive reduction of this acyclic graph is computed. Finally, the vertices of each component are re-added as simple cycle graphs.

g = Graph[{1 -> 4, 1 -> 2, 2 -> 3, 3 -> 4}, VertexLabels -> "Name"]

transitiveReductionGraph[g, VertexLabels -> "Name"]

---

Testing

Here's a small test to show that the results are reasonable:

Table[
 With[{g = DirectedGraph[RandomGraph[{10, 20}], "Acyclic"]},
  IsomorphicGraphQ[
   TransitiveClosureGraph@transitiveReductionGraph[g],
   TransitiveClosureGraph[g]
  ]
 ], {10}]
(* {True, True, True, True, True, True, True, True, True, True} *)

Table[
 With[{g = RandomGraph[{10, 20}, DirectedEdges -> True]},
  IsomorphicGraphQ[
   TransitiveClosureGraph@transitiveReductionGraph[g],
   TransitiveClosureGraph[g]
  ]
 ], {10}]
(* {True, True, True, True, True, True, True, True, True, True} *)

Here's another test to show that TransitiveReductionGraph will frequently return wrong results and is not to be trusted.

Table[
 With[{g = DirectedGraph[RandomGraph[{10, 20}], "Acyclic"]}, 
  EdgeCount /@ {transitiveReductionGraph[g], TransitiveReductionGraph[g]}
 ],
 {10}
]
(* {{11, 12}, {9, 12}, {10, 11}, {10, 10}, {13, 13}, {14, 14}, {11, 13}, {10, 12}, {10, 12}, {9, 12}} *)

---

The code

ClearAll[transitiveReductionGraph]

(* undirected *)

transitiveReductionGraph[g_?UndirectedGraphQ, opt : OptionsPattern[]] :=
  FindSpanningTree[IGUnweighted[g], opt]

(* directed acyclic *)

transitiveReductionGraph[g_?AcyclicGraphQ, opt : OptionsPattern[]] :=    
  AdjacencyGraph[
   VertexList[g],
   With[{a = Unitize@AdjacencyMatrix[g], b = AdjacencyMatrix@TransitiveClosureGraph[g]},
    (1 - Unitize[a.b]) a
   ],
   opt
  ]

(* directed non-acyclic *)

ClearAll[namedCycle]
namedCycle[{v_}] := Graph[{v}, {}]
namedCycle[verts_] := Graph[verts, DirectedEdge @@@ Partition[verts, 2, 1, {1, 1}]]

transitiveReductionGraph[g_?DirectedGraphQ, opt : OptionsPattern[]] :=
  Module[{comps = ConnectedComponents[g], gt},
   gt = transitiveReductionGraph@IGVertexContract[g, comps];
   Graph[GraphUnion @@ Prepend[namedCycle /@ comps, gt], opt]
  ]

(* other cases, e.g. mixed graphs *)
transitiveReductionGraph[g_, OptionsPattern[]] := $Failed

The following code should work for not-too-big graphs:

ClearAll[MyTransitiveReductionGraph];

MyTransitiveReductionGraph[g0_Graph, opt___] := 
Module[{g, vertices, edges, newedges, s, t},
g = TransitiveReductionGraph[g0];
vertices = VertexList[g];
edges = EdgeList[g];
newedges = Pick[edges,
 Table[{s, t} = List @@ x; 
  Length[FindShortestPath[EdgeDelete[g, x], s, t]] == 0, {x, 
   edges}]
 ];
Graph[vertices, newedges, opt]
];

For example,

g = Graph[{1 -> 4, 1 -> 2, 2 -> 3, 3 -> 4}, VertexLabels -> "Name"]

MyTransitiveReductionGraph[g, VertexLabels -> "Name"]