delete i->j if j->i exists?

Question

What is a nice way to delete cases of i -> j if j -> i exists?

It does not matter which one of each pair is deleted as long as one of them is.

Input

 {1 -> 4, 4 -> 1, 2 -> 3, 3 -> 2}

Output

{1 -> 4, 2 -> 3}

the application

In

l = {{1 -> 4, 3, 0}, {4 -> 1, 4, 0},  {3 -> 2, 9, 0}, {2 -> 3, 1, 0}}

Out

{{1 -> 4, 3, 0}, {2 -> 3, 9, 0}}

can this be done a simple way with Pattern Matching?

Thanks for the answers:) I explored Ford–Fulkerson algorithm in Mathematica. It finds the maximum flow through a flow network.

I think your desired output should be {4 -> 1, 3 -> 2} and not {1 -> 4, 2 -> 3} ? — Nasser, Sep 10 '16 at 07:38
DeleteDuplicates[list, # == Reverse@#2 &] is the simple way. If list is huge, faster ways to do it... — ciao, Sep 10 '16 at 07:40
After your edits and additions, I'm now befuddled. What is the definition of a "duplicate" here - the second example output is not consistent with that of the first example output. We need to know what kind of frickin' laser beams are to be used for the cutting here... — ciao, Sep 10 '16 at 07:53
Sorry! You solved my problem perfectly. DeleteDuplicates[l, #[[1]] == Reverse@#2[[1]] &] thank you @ciao — Conor, Sep 10 '16 at 08:26
@ConorCosnett Thank you for accepting my answer despite it being not necessarily the most straight forward one. Do you want to add the [tag:graphs-and-networks]-tag in light of your accepted answer? — Sascha, Sep 10 '16 at 16:32
Are you building a graph? Is it undirected? If so, use SimpleGraph. — Szabolcs, Sep 10 '16 at 17:20

Michael E2 · Answer 1 · 2016-09-10T16:25:04.253

If the order of i and j does not matter (or if you want them sorted), then the following will work:

DeleteDuplicates@ Block[{Rule},
  SetAttributes[Rule, Orderless];
  {1 -> 4, 4 -> 1, 2 -> 3, 3 -> 2}
  ]
(*  {1 -> 4, 2 -> 3}  *)

l = {{1 -> 4, 3, 0}, {4 -> 1, 4, 0}, {3 -> 2, 9, 0}, {2 -> 3, 1, 0}};
DeleteDuplicatesBy[First]@ Block[{Rule},
  SetAttributes[Rule, Orderless];
  l
  ]
(*  {{1 -> 4, 3, 0}, {2 -> 3, 9, 0}}  *)

It's probably important that only the list l is evaluated inside the Block. One probably does not want to evaluate any built-in functions while Rule is Orderless.

The method above is pretty fast. Some timings:

SeedRandom[0];
ll = Rule @@@ RandomInteger[200, {100000, 2}];
DeleteDuplicates@Block[{Rule}, SetAttributes[Rule, Orderless]; ll] // Length // AbsoluteTiming
DeleteDuplicatesBy[Sort]@ll // Length // AbsoluteTiming
Values[GroupBy[ll, Sort, First]] // Length // AbsoluteTiming
(*
  {0.084336, 20152}  M e2
  {0.17234, 20152}   kglr
  {0.178762, 20152}  ubpdqn
*)

The two-argument DeleteDuplicates[ll, # == Reverse@#2 &], as ciao remarks in a comment, will be a bit slower as the list grow in size (because it uses pairwise comparison that is of quadratic complexity); it takes 0.18 sec. on a list of only 750 rules. Sascha's takes 3+ sec. on the input ll = Rule @@@ RandomInteger[15, {150, 2}], but it is interesting for other reasons.

thank you got the timing. I have always been 'afraid' of SetAttributes...the eternal lesson of terse not necessarily efficient still not sufficiently penetrated my skull but fun to learn from answers:) — ubpdqn, Sep 11 '16 at 04:35

kglr · Answer 2 · 2016-09-10T13:18:59.497

5

DeleteDuplicatesBy[Sort]@ {1 -> 4, 4 -> 1, 2 -> 3, 3 -> 2}

{1 -> 4, 2 -> 3}

DeleteDuplicatesBy[Sort@First@#&]@
  {{1 -> 4, 3, 0}, {4 -> 1, 4, 0}, {3 -> 2, 9, 0}, {2 -> 3, 1, 0}}

or (thanks: @Michael E2)

DeleteDuplicatesBy[Sort @* First] @
  {{1 -> 4, 3, 0}, {4 -> 1, 4, 0}, {3 -> 2, 9, 0}, {2 -> 3, 1, 0}}

{{1 -> 4, 3, 0}, {3 -> 2, 9, 0}}

edited Sep 10 '16 at 13:18

answered Sep 10 '16 at 11:54

kglr

394,356
18
477
896

2

Nice. The second form could be in V10+ DeleteDuplicatesBy[Sort @* First]... or more verbosely in earlier versions DeleteDuplicatesBy[Composition[Sort, First]].... – Michael E2 Sep 10 '16 at 12:56
Thank you @Michael. Updated with your suggestion. – kglr Sep 10 '16 at 13:20

Sascha · Accepted Answer · 2016-09-10T14:49:14.720

You could also use Graph and friends if your list is small (otherwise this solution does not make much sense regarding both visualization and performance).

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

to find cycles of the form $i \rightarrow j \space ,\space j \rightarrow i$ you can use FindCycle as in

FindCycle[g, 2, All] (* yields {{2 -> 3, 3 -> 2}, {1 -> 4, 4 -> 1}} *)

together with EdgeDelete

g2 = EdgeDelete[g, First /@ FindCycle[g, 2, All]]

A more complex example showcases the visualization benefits of this solution:

Original graph:

exampleGraph = Graph@Table[RandomInteger[10] -> RandomInteger[10], 20]

Graph with same layout but resolved cycles

Graph[EdgeDelete[exampleGraph, First /@ FindCycle[exampleGraph, 2, All]], 
(exampleGraph //AbsoluteOptions[#, VertexCoordinates] & // First)]

Highlighted cycles in original graph

HighlightGraph[exampleGraph, 
FindCycle[exampleGraph, 2, All], (exampleGraph // AbsoluteOptions[#, VertexCoordinates] & // First)]

score 4 · Answer 4 · answered Sep 10 '16 at 11:51

4

If the order of the rule doesn't matter in output:

Values[GroupBy[l, Sort[#[[1]]] &, First]]

answered Sep 10 '16 at 11:51

ubpdqn

60,617
3
59
148

delete i->j if j->i exists?

Input

Output

In

Out

4 Answers4