7
$\begingroup$

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?

$\endgroup$
  • $\begingroup$ Including a sample graph would increase the speed and likelihood of answers. $\endgroup$ – Mr.Wizard Feb 11 '15 at 16:52
  • 1
    $\begingroup$ related Q/A: How can I replace bi-directional DirectedEdge pairs in a Graph with a single UndirectedEdge? $\endgroup$ – kglr Feb 11 '15 at 17:21
  • $\begingroup$ @kguler From the title and a quick glance that seems like a duplicate. Is it not? $\endgroup$ – Mr.Wizard Feb 11 '15 at 17:23
  • $\begingroup$ @kguler I see that the Accepted answer using EdgeShapeFunction so it is more formatting that actual replacement. I guess not a duplicate after all? $\endgroup$ – Mr.Wizard Feb 11 '15 at 17:25
  • 1
    $\begingroup$ Mr.Wizard, the two questions are "almost" the same. However, because version 10 allows mixed graphs and version 9 did not, making explicit the requirement that the output is a mixed graph will make the current question truly different from the linked one. $\endgroup$ – kglr Feb 11 '15 at 17:58
4
$\begingroup$

A brute-force method using Gather.

Starting graph:

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

Graph[edges]

enter image description here

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]

enter image description here

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]

enter image description here

$\endgroup$
  • 3
    $\begingroup$ One mistake everyone has made in all the answers is that Graph[EdgeList[g]] will lose unconnected vertices. Graph[VertexList[g], EdgeList[g]] will keep them. This is not nitpicking. I've been bitten hard by this mistake. I know that you are constructing the example graph based purely on an edge list, but this is something that's still worth paying attention to ... $\endgroup$ – Szabolcs Feb 11 '15 at 18:28
  • $\begingroup$ Would you clarify how /. {{_[a_, b_], __} :> a <-> b, {x_} :> x} works? I don't fully understand _[a_, b_] but it seems to be an opaque variation of belisarius' Rule[a_,b_]. $\endgroup$ – DavidC Feb 11 '15 at 18:52
  • $\begingroup$ @Szabolcs Thanks for the caveat. $\endgroup$ – Mr.Wizard Feb 11 '15 at 18:58
  • 1
    $\begingroup$ @David _[a_, b_] is a pattern for an expression with any head and two arguments, therefore it will match Rule, DirectedEdge, UndirectedEdge, etc. This lets me collapse any of the sublists from Gather into a single UndirectedEdge without worrying about type. {x_} :> x strips the List from any singlets. $\endgroup$ – Mr.Wizard Feb 11 '15 at 19:00
2
$\begingroup$

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  *)

enter image description here

$\endgroup$
  • 1
    $\begingroup$ @Mr.Wizard, right. I missed the mixed graph requirement (which version 9 does not support except through using different EdgeShapeFunction properties for different edge types as in the linked Q/A). $\endgroup$ – kglr Feb 11 '15 at 17:47
  • $\begingroup$ Bloody hell, where did that come from? ;-p (I didn't see GatherBy until after posting my version.) +1 of course. *sigh* $\endgroup$ – Mr.Wizard Feb 11 '15 at 19:24
  • $\begingroup$ +1 for using Union instead of Sort and Union $\endgroup$ – DavidC Feb 11 '15 at 20:16
  • $\begingroup$ @David Out of curiosity are you comparing that to my answer? I have reason for what I wrote, or at least I think I do. $\endgroup$ – Mr.Wizard Feb 11 '15 at 20:21
  • $\begingroup$ Mr.Wizard You are indeed perceptive. Yes, I was. $\endgroup$ – DavidC Feb 11 '15 at 22:20
2
$\begingroup$

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]

enter image description here

mixedGraph@g

enter image description here

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.

$\endgroup$
  • $\begingroup$ +1 for use of some interesting functions, but at least in my testing this is several times slower than my naive brute-force method. I don't know if your output should be considered better or worse than mine; I purposely wanted to change the graph as little as possible but that may not be important to the OP. $\endgroup$ – Mr.Wizard Feb 11 '15 at 19:08
  • $\begingroup$ @Mr.Wizard It is not fine, I change the wording a bit. Also I add another approach with graph functions which works fine with multigraphs $\endgroup$ – ybeltukov Feb 11 '15 at 19:40
1
$\begingroup$

Another not-efficient alternative:

edges //. {a___, Rule[x_, y_], b___, Rule[y_, x_], c___} :> {a, b, c, UndirectedEdge[x, y]}
$\endgroup$
  • $\begingroup$ I'm afraid that's going to be significantly worse than Gather, based on earlier experimentation with multiple ___ patterns. I'll be happy to be proven wrong but until then I'm holding my vote as an edge list may be quite long. $\endgroup$ – Mr.Wizard Feb 11 '15 at 19:02
  • $\begingroup$ Seems I was wrong. The speed of this function depends greatly on the nature of the edge list. With little duplication it can be slightly faster than mine, but with more duplication it can be an order of magnitude slower. +1 for a pretty implementation. $\endgroup$ – Mr.Wizard Feb 11 '15 at 19:13
  • $\begingroup$ @Mr.Wizard As almost always, a repeated replacement rule can't beat a clever implementation in the general case. Thanks for your comments/experimentation. $\endgroup$ – Dr. belisarius Feb 11 '15 at 19:15

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.