19
$\begingroup$

I have a list of transformations like this:

list = {"A" -> "B", "B" -> "A", "C" -> "D"}

As this is used to plot an undirected graph with GraphPlot, I don't want to have an Edge between the vertices A-B and B-A. I just want one of them.

How do I remove either A -> B or B -> A from this list? In the end, I want the list to look like this:

{"A" -> "B", "C" -> "D"}

I've tried using DeleteDuplicates, but I don't think I understand the testing part of that function (I should add that I'm a Mathematica beginner ... )

I made a function that can compare two transformations:

CmpTrans[x_,y_] := (x[[1]]/.x) == y[[1]]

It returns True for CmpTrans[A->B, B->A], but I can't seem to use this is the testing part of DeleteDuplicates.

$\endgroup$
  • 1
    $\begingroup$ Perhaps you could consider MultiedgeStyle-> None? For example: GraphPlot[list, VertexLabeling -> True, MultiedgeStyle -> None] $\endgroup$ – user1066 Feb 4 '12 at 23:01
17
$\begingroup$

This seems to do what you want:

rules = {"A" -> "B", "B" -> "A", "C" -> "D"};

Rule @@@ Union[Composition[Sort, List] @@@ rules]
(* {"A" -> "B", "C" -> "D"} *)
$\endgroup$
  • $\begingroup$ Wow! Thanks a lot! That works perfectly. I'm not sure I really understand how it works, but figuring that out is good practice for me. $\endgroup$ – Erik Tjernlund Feb 4 '12 at 14:04
  • 2
    $\begingroup$ It's not too hard; I temporarily turn all your Rule[]s to List[]s with Apply[] (that is, @@@), sort those List[]s, delete duplicates with Union[], and then change the List[]s back to Rule[]s. $\endgroup$ – J. M. will be back soon Feb 4 '12 at 14:07
  • 1
    $\begingroup$ It's seem Union[Sort /@ rules] work,too. $\endgroup$ – yode Dec 26 '16 at 3:22
25
$\begingroup$

If you do not mind changing your edge directions and order, as J.M.'s answer does, this can be done much more simply since Sort works on arbitrary expressions:

Union[Sort /@ rules]

If you do not want to change the directions or order, you can use this:

First /@ GatherBy[rules, Sort]

Mathematica 10 introduced DeleteDuplicatesBy which may also be used:

DeleteDuplicatesBy[list, Sort]
{"A" -> "B", "C" -> "D"}
$\endgroup$
  • 1
    $\begingroup$ "...do not mind changing your edge directions..." - as he wants to draw an undirected graph, he certainly doesn't. $\endgroup$ – J. M. will be back soon Feb 4 '12 at 23:25
  • $\begingroup$ @J.M. I actually did notice that, but I thought it best to include that anyway. Questions do change themselves sometimes. ;-) $\endgroup$ – Mr.Wizard Feb 4 '12 at 23:29
10
$\begingroup$

Using Mathematica 7

Needs["GraphUtilities`"];
Rule @@@ DeleteDuplicates[Sort /@ EdgeList[list]]

giving

{"A" -> "B", "C" -> "D"}

$\endgroup$
10
$\begingroup$

Note that CmpTrans that you wrote isn't the correct test. Here's an example where it gives the wrong result:

CmpTrans["A" -> "B", "B" -> "C"]

(*
==> True
*)

Once we fix that, maybe with something like:

CmpTrans[x_, y_] := x === Reverse[y]

CmpTrans["A" -> "B", "B" -> "C"]

(*
==> False
*)

CmpTrans["A" -> "B", "B" -> "A"]

(*
==> True
*)

then we can simply use CmpTrans as the second argument to DeleteDuplicates:

list = {"A" -> "B", "B" -> "A", "B" -> "C", "C" -> "D"};

DeleteDuplicates[list, CmpTrans]

(*
==> {"A" -> "B", "B" -> "C", "C" -> "D"}
*)
$\endgroup$
  • 3
    $\begingroup$ One possibly problematic thing about this method is that DeleteDuplicates with explicit comparison function will switch to the quadratic-time pairwise-comparison-based algorithm, making this impractical even for moderately sized graphs. For example: DeleteDuplicates[Flatten@Outer[Rule, Range[50], Range[50]], CmpTrans] takes about 5 seconds on my machine. $\endgroup$ – Leonid Shifrin Feb 4 '12 at 17:01
  • $\begingroup$ Thank you for the corrected function. Embarrassingly I didn't test my version with a False case. $\endgroup$ – Erik Tjernlund Feb 5 '12 at 17:05
9
$\begingroup$

You can use UndirectedGraph directly for your graph problem

list = {"A" -> "B", "B" -> "A", "C" -> "D"};

Graph[list, VertexLabels -> "Name"]

enter image description here

g = UndirectedGraph[Graph[list], VertexLabels -> "Name"]

enter image description here

EdgeList[g]

enter image description here

$\endgroup$
3
$\begingroup$

Update: For versions 10+ there is DeleteDuplicatesBy:

DeleteDuplicatesBy[Sort] @ list

{"A" -> "B", "B" -> "C", "C" -> "D"}

Original post:

You can also use an Orderless function foo.

In matching patterns with Orderless functions, all possible orders of arguments are tried.

list = {"A" -> "B", "B" -> "A", "C" -> "D"};

SetAttributes[foo, Orderless];

Rule @@@ DeleteDuplicates[foo @@@ list]   
(* or  DeleteDuplicates[bar @@@ list] /. bar-> Rule *)
(* or DeleteDuplicates[list /. Rule -> bar] /. bar -> Rule *)

{"A" -> "B","C" -> "D"}

$\endgroup$
  • $\begingroup$ I don't think TransitiveReductionGraph does what the OP has asked (unless I misunderstood something). $\endgroup$ – Szabolcs Feb 19 '18 at 19:48
  • $\begingroup$ @Szabolcs, deleted that part. $\endgroup$ – kglr Feb 21 '18 at 23:27
1
$\begingroup$

Another approach is using pure pattern matching

{"A" -> "B", "B" -> "A", "C" -> "D"}
/. {before___, a_ -> b_, between___, b_ -> a_, after___} 
:> {before, a -> b, between, after}

which leaves the list in its original order.

If there are multiple duplicate entries one can use ReplaceRepeated (//.) instead of ReplaceAll(/.) to sweep the list until all duplicates are cleared

{"A" -> "B", "B" -> "A", "C" -> "D", "B" -> "A"} 
//. {before___, a_ -> b_, between___, b_ -> a_, after___}
:> {before, a -> b, between, after}
$\endgroup$
1
$\begingroup$

Yet another proposal. Short but probably not very efficient.

list = {"A" -> "B", "B" -> "A", "C" -> "D"}
DeleteDuplicates[list,  Function[{x, y} , x == Reverse[y]]]
$\endgroup$

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.