2

Possible Duplicate:
Computing the equivalence classes of the symmetric transitive closure of a relation

I am required to process sets consisting of 2-element subsets of integers by combining those subsets whose intersection is nonempty.

For example, given

X = {{1, 2}, {3, 4}, {7, 4}, {2, 5}}

my routine merge will output

merge[X] = {{3, 4, 7}, {1, 2, 5}} .

As all List elements are considered as sets, duplicate entries and list order are to be ignored.

In fact I have implemented such an algorithm in Mathematica, however I suspect it is horribly inefficient and am looking for any reasonable way to improve its performance.

My implementation uses FixedPoint and is broken into two parts :

merge0[x_] := Block[{x0 = x},
Do[
If[i != j && Intersection[x[[i]], x[[j]]] != {}, 
x0 = Join[Delete[x, {{i}, {j}}], {Union@Flatten[Join[x[[i]], x[[j]]]]}];
Break[]], 
{i, Length[x]}, {j, i}]; x0]

merge[x_] := FixedPoint[merge0, x]

Thanks and regards,

Daniel

Community
  • 1
Fermat A
  • 121
  • 5
  • What is the expected result of {{a,b},{b,c},{c,d}}? Seems your fuction returns {a,b,c,d} ... so the "intersection" is some kind of "transitive" property here – Dr. belisarius Sep 25 '12 at 03:31
  • 1
    Would Union @@@ FindClusters[{{1, 2}, {3, 4}, {7, 4}, {2, 5}}, DistanceFunction -> Composition[Abs, NeedlemanWunschSimilarity]] suit your needs? – J. M.'s missing motivation Sep 25 '12 at 03:44
  • I intend to close this as a duplicate of http://mathematica.stackexchange.com/q/7620/121 -- anyone disagree? – Mr.Wizard Sep 25 '12 at 06:14

2 Answers2

4

I remember helping someone else with a similar problem recently in chat. Anyway, here's a solution using //. or ReplaceRepeated. If your lists are very large, then you should look into alternative solutions, because the performance of //. along with ___ will degrade quickly. Otherwise, it's a fine solution and I'd use it if I had a similar problem.

list = {{1, 2}, {3, 4}, {7, 4}, {2, 5}}; (* your list *)
list //. {h___, a_List, m___, b_List, t___} :> {h, m, Union[a, b], t} /; 
    Intersection[a, b] =!= {}
(* {{3, 4, 7}, {1, 2, 5}} *)
rm -rf
  • 88,781
  • 21
  • 293
  • 472
2
pairs = {{1, 2}, {3, 4}, {7, 4}, {2, 5}, {5, 8}};

relativesF=ConnectedComponents[Graph[UndirectedEdge @@ # & /@ #]]&
relativesF@pairs
(* {{1, 2, 5, 8}, {3, 4, 7}} *)

or

relativesF2 = DeleteDuplicates/@ Flatten/@ Gather[#, (Intersection[#1, #2] !={} &)] &;
FixedPoint[relativesF2 , pairs]
(* {{1, 2, 5, 8}, {3, 4, 7}} *)

or

Nest[relativesF2, pairs, Length[pairs]]
(* {{1, 2, 5, 8}, {3, 4, 7}} *)
kglr
  • 394,356
  • 18
  • 477
  • 896
  • kguler, since you are here: do you disagree with my intention to close this question? (see comment above) – Mr.Wizard Sep 25 '12 at 06:30
  • @Mr.Wizard, not at all. Actually, just noticed your comment as I was trying to put together the links to other related questions to post a similar comment. – kglr Sep 25 '12 at 06:36