6
$\begingroup$

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[[1]]};
   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,
     list2 = findLinks[list1];
     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?

Improve this question
$\endgroup$
2
  • $\begingroup$ Related: (4843) -- I think there is an even closer question but I cannot think of it at the moment. $\endgroup$
    – Mr.Wizard
    Commented Jun 27, 2015 at 19:31
  • 1
    $\begingroup$ Sektor, thanks for editing my post and making it look so much nicer. $\endgroup$
    – Miguel
    Commented Jun 27, 2015 at 23:51

3 Answers 3

Reset to default
5
$\begingroup$

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]

enter image description here

{{{6, 7}, {6, 2}, {1, 2}, {1, 5}},
{{4, 4}, {5, 4}},
{{7, 3}, {2,3}},
{{0, 0}},
{{3, 1}}}
Improve this answer
$\endgroup$
6
  • $\begingroup$ "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. $\endgroup$
    – Mr.Wizard
    Commented Jun 28, 2015 at 9:55
  • $\begingroup$ @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 $\endgroup$
    – ubpdqn
    Commented Jun 28, 2015 at 9:58
  • $\begingroup$ @Mr.Wizard just looked at your implementation,,,as usual I learn a lot but I had already upvoted your answer :) $\endgroup$
    – ubpdqn
    Commented Jun 28, 2015 at 10:00
  • $\begingroup$ Thank you. You also have my vote of course. $\endgroup$
    – Mr.Wizard
    Commented Jun 28, 2015 at 10:01
  • $\begingroup$ ubpdqn - what a nice way to show students about the collection of these points for small sets. Thanks for your input. $\endgroup$
    – Miguel
    Commented Jun 28, 2015 at 11:42
3
$\begingroup$

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[1]
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}}
}
Improve this answer
$\endgroup$
4
  • $\begingroup$ 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. $\endgroup$
    – Miguel
    Commented Jun 27, 2015 at 23:54
  • $\begingroup$ @Miguel This needs further work. I shall try to find the time for it today. $\endgroup$
    – Mr.Wizard
    Commented Jun 28, 2015 at 6:57
  • $\begingroup$ 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! $\endgroup$
    – Miguel
    Commented Jun 28, 2015 at 11:57
  • $\begingroup$ @Miguel You're welcome; I am glad I could help. :-) $\endgroup$
    – Mr.Wizard
    Commented Jun 28, 2015 at 13:09
1
$\begingroup$

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}}}}

Improve this answer
$\endgroup$
1
  • $\begingroup$ thanks for this reply: there is a lot in here for me to understand. Will look at the code carefully and comment... $\endgroup$
    – Miguel
    Commented Jun 28, 2015 at 0:26

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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