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
  • 1
    $\begingroup$ Perhaps you could consider MultiedgeStyle-> None? For example: GraphPlot[list, VertexLabeling -> True, MultiedgeStyle -> None] $\endgroup$
    – user1066
    Feb 4, 2012 at 23:01

8 Answers 8

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$
3
  • $\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$ Feb 4, 2012 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$ Feb 4, 2012 at 14:07
  • 1
    $\begingroup$ It's seem Union[Sort /@ rules] work,too. $\endgroup$
    – yode
    Dec 26, 2016 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$
2
  • 1
    $\begingroup$ "...do not mind changing your edge directions..." - as he wants to draw an undirected graph, he certainly doesn't. $\endgroup$ Feb 4, 2012 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, 2012 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$
2
  • 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$ Feb 4, 2012 at 17:01
  • $\begingroup$ Thank you for the corrected function. Embarrassingly I didn't test my version with a False case. $\endgroup$ Feb 5, 2012 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$
2
  • $\begingroup$ I don't think TransitiveReductionGraph does what the OP has asked (unless I misunderstood something). $\endgroup$
    – Szabolcs
    Feb 19, 2018 at 19:48
  • $\begingroup$ @Szabolcs, deleted that part. $\endgroup$
    – kglr
    Feb 21, 2018 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 and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.