# Conditional subset generation

I am trying to accomplish the following task: Given a list of coordinates of n points in the plane, I need to find subsets of all points that share the same x-coordinate OR same y-coordinate. For instance, for the list:

data = {{1,2},{3,1},{1,5},{6,2},{7,3},{4,4},{5,4},{0,0},{2,3},{6,7}}


I get:

set1 = {{1, 2}, {1, 5}, {6, 2}, {6, 7}}
set2 = {{0, 0}}
set3 = {{2, 3}, {7, 3}}
set4 = {{3, 1}}
set5 = {{4, 4}, {5, 4}}


Notice for example in set1 that {1, 5} and {6, 2} are in the same set linked indirectly. I have written some "naive implementation" consisting of the two modules shown below. I understand that the use of Append is not a good idea. The code below works, and produces good results for relatively small data sets, but obviously does not scale very well. A data set of 1000 points takes about 150 seconds to run on my computer...

findLinks[list_] := Module[{},
newList = {list[]};
xList = {list[[1, 1]]};
yList = {list[[1, 2]]};
For[i = 1., i <= Length[list], i++,
For[j = i, j <= Length[list], j++,
If[(list[[i, 1]] == list[[j, 1]] ||
list[[i, 2]] == list[[j, 2]]) && (MemberQ[xList,
list[[j, 1]]] || MemberQ[yList, list[[j, 2]]]),
newList = Append[newList, list[[i]]];
newList = Append[newList, list[[j]]];
xList = Append[xList, list[[i, 1]]];
yList = Append[yList, list[[i, 2]]];
xList = Append[xList, list[[j, 1]]];
yList = Append[yList, list[[j, 2]]];
];
];
];
DeleteDuplicates[newList]
];

getClusters[list_] := getClusters[list] = Module[{list1, list2},
finalClusters = {};
list1 = list;
While[Length[list1] >= 1,
finalClusters = Append[finalClusters, list2];
(*Deletes from list1 those elements of list2... *)
list1 = Complement[list1, list2];
];
finalClusters
];

getClusters[data]


I am trying to implement another solution using Select or linked lists, but so far I am not getting anywhere. Any ideas about how to speed up this task?

• Related: (4843) -- I think there is an even closer question but I cannot think of it at the moment. Jun 27, 2015 at 19:31
• Sektor, thanks for editing my post and making it look so much nicer. Jun 27, 2015 at 23:51

Just for fun:

data = {{1, 2}, {3, 1}, {1, 5}, {6, 2}, {7, 3}, {4, 4}, {5, 4}, {0,
0}, {2, 3}, {6, 7}};
g = Cases[
Subsets[data, {2}] /. {{{x_, a_}, {x_, b_}} :>
UndirectedEdge[{x, a}, {x, b}], {{a_, y_}, {b_, y_}} :>
UndirectedEdge[{a, y}, {b, y}]}, UndirectedEdge[_, _]];
gr = Graph[data, g, VertexLabels -> "Name"]
ConnectedComponents[gr] {{{6, 7}, {6, 2}, {1, 2}, {1, 5}},
{{4, 4}, {5, 4}},
{{7, 3}, {2,3}},
{{0, 0}},
{{3, 1}}}

• "Just for fun?" I think Graph functionality is the way to go. I seem to have a more efficient implementation leveraging GatherBy which I now included in my answer. Jun 28, 2015 at 9:55
• @Mr.Wizard this problem seemed like a 'barrel of monkeys' in my mind...a fun image from my childhood,,,I guess I was just using an alternative to other approaches...have not considered efficiency etc Jun 28, 2015 at 9:58
• Thank you. You also have my vote of course. Jun 28, 2015 at 10:01
• ubpdqn - what a nice way to show students about the collection of these points for small sets. Thanks for your input. Jun 28, 2015 at 11:42

### Update

On reflection I think using ConnectedComponents as referenced in the accepted answer to (4843) and used by ubpdqn in his answer is probably the best approach. Here is my implementation of that idea.

fn2[data_] :=
UndirectedEdge @@@ Partition[#, 2, 1, 1] & /@ GatherBy[data, #] & /@ {First, Last} //
Flatten // Graph // ConnectedComponents


Tested on Question example:

data = {{1, 2}, {3, 1}, {1, 5}, {6, 2}, {7, 3}, {4, 4}, {5, 4}, {0, 0}, {2, 3}, {6, 7}};

fn2[data] // Column

{{6, 7}, {6, 2}, {1, 2}, {1, 5}}
{{4, 4}, {5, 4}}
{{7, 3}, {2, 3}}
{{0, 0}}
{{3, 1}}


Speed on a large set:

SeedRandom
big = RandomInteger[25000, {50000, 2}];

fn2[big] // Length // RepeatedTiming

{0.407, 1356}


## Old idea

This is probably pretty rough but I am in a rush. Hopefully it is correct and serves as a basis for something that can be cleaned up.

data = {{1, 2}, {3, 1}, {1, 5}, {6, 2}, {7, 3}, {4, 4}, {5, 4}, {0, 0}, {2, 3}, {6, 7}};

asc1 = GroupBy[data, First];
asc2 = GroupBy[data, Last -> First];

Union @@@ Map[asc2] /@ asc1[[All, All, 2]];
Union @@@ Map[asc1] /@ Union @ Values @ %

{
{{0, 0}},
{{3, 1}},
{{1, 2}, {1, 5}, {6, 2}, {6, 7}},
{{2, 3}, {7, 3}},
{{4, 4}, {5, 4}}
}

• Mr. Wizard, Your solution is very good, and run so fast! However, as you mentioned, there is a bit of cleaning up that needs to be done to the final list. I am in the process of doing that. Thank you for sharing these ideas...I will post the additions I make. Jun 27, 2015 at 23:54
• @Miguel This needs further work. I shall try to find the time for it today. Jun 28, 2015 at 6:57
• This is such a humbling experience for me. Your updated version of the solution is so good and powerful. I need to learn about ConnectedComponents and spend some time understanding your beautiful solution. Thank you very much. Most definitely all you guys have my up vote! Jun 28, 2015 at 11:57
• @Miguel You're welcome; I am glad I could help. :-) Jun 28, 2015 at 13:09

I'm going with this, which tranposes the data, finds the unique values for X/Y using union and then selects X, and then Y, points which match each value:

With[{tr = Union /@ (data\[Transpose])}, {Cases[data, {#, _}] & /@
First@tr, Cases[data, {_, #}] & /@ Last@tr}]


{{{{0, 0}}, {{1, 2}, {1, 5}}, {{2, 3}}, {{3, 1}}, {{4, 4}}, {{5, 4}}, {{6, 2}, {6, 7}}, {{7, 3}}}, {{{0, 0}}, {{3, 1}}, {{1, 2}, {6, 2}}, {{7, 3}, {2, 3}}, {{4, 4}, {5, 4}}, {{1, 5}}, {{6, 7}}}}

• thanks for this reply: there is a lot in here for me to understand. Will look at the code carefully and comment... Jun 28, 2015 at 0:26