Automatically convert pairs of directed edges to an undirected edge?

Question

I have a directed graph, which for some pairs of vertices, has a directed edge between them in each direction. I would like to replace such pairs of directed edges between the same vertices but in opposite directions, by a single undirected edge. What's a simple way to do this?

Answer 1

A brute-force method using Gather.

Starting graph:

SeedRandom[0]
edges = Rule @@@ RandomInteger[{1, 5}, {12, 2}]

Graph[edges]

Processing and new graph (this will work with both Rule and DirectedEdge:

new = 
  Gather[edges, #[[1]] == #2[[2]] && #[[2]] == #2[[1]] &] /.
    {{_[a_, b_], __} :> a <-> b, {x_} :> x};

Graph[new]

Update

Seeking a more efficient implementation, if:

• All edges in the original graph are either Rule or UndirectedEdge at the outset

• You do not mind losing multiple (directed) edges between vertices

I believe we can use the much more efficient GatherBy as follows:

new2 =
  Union /@ GatherBy[edges, Sort] /.
    {{_[a_, b_], __} :> a <-> b, {x_} :> x};

Graph[new2]

Answer 2

An alternative way to use GatherBy

bidirectedToUndirected=Join@@(GatherBy[EdgeList@#,Union] /. {x_, y_} :> {UndirectedEdge @@ x}) &;

Example (from here):

words = DictionaryLookup["wol*"];
edges = Flatten[Map[(Thread[# ->  DeleteCases[Nearest[words, #, 3], #]]) &, words]];
opts = {VertexLabels -> "Name", ImagePadding -> 60, ImageSize -> 500};
g = Graph[edges, opts];

Row[{g, Graph[VertexList[g], bidirectedToUndirected@g, opts]}]  (* thanks: @Szabolcs  *)

Answer 3

One can do it quite fast with AdjacencyMatrix

graphSum[graphs__, opts___?OptionQ] /; VectorQ[{graphs}, GraphQ] :=
  Graph[Union @@ VertexList /@ {graphs}, Join @@ EdgeList /@ {graphs}, opts];

pairwiseMin[a_, b_, dom_: Reals] := 
  If[dom === Integers, Quotient, Divide][a + b - Abs[a - b], 2];

mixedGraph[g_Graph] := graphSum @@ Map[AdjacencyGraph[VertexList@g, #] &, {# - #2, #2}] &[#,
     pairwiseMin[#, Transpose@#, Integers]] &@AdjacencyMatrix@g

Here graphSum is analog of GraphSum which was in old Combinatorica package. There is built-in GraphComputation`GraphSum in V10, but it doesn't work for mixed graphs (one can fix it, see the previous revision of this answer).

SeedRandom[0]
edges = Rule @@@ RandomInteger[{1, 5}, {12, 2}];
g = Graph[Range@7, edges]

mixedGraph@g

It also converts directed loops to undirected loops, but they have the same meaning.

Timing for a big graph:

SeedRandom[0]
edges = Rule @@@ RandomInteger[{1, 10000}, {20000, 2}];
g = Graph[edges];
mixedGraph@g; // AbsoluteTiming
(* {0.213162, Null} *)

It is comparable with Mr.Wizards new2 but it takes into account multiple edges.

---

Also one can do it purely with graph functions

mixedGraph[g_Graph] := 
 GraphUnion[GraphDifference@##, UndirectedGraph@GraphIntersection@##] &[g, ReverseGraph@g]

However, it is slow and simplifies multiple edges.

Answer 4

Another not-efficient alternative:

edges //. {a___, Rule[x_, y_], b___, Rule[y_, x_], c___} :> {a, b, c, UndirectedEdge[x, y]}