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?

$\endgroup$
  • $\begingroup$ Related: (4843) -- I think there is an even closer question but I cannot think of it at the moment. $\endgroup$ – Mr.Wizard Jun 27 '15 at 19:31
  • 1
    $\begingroup$ Sektor, thanks for editing my post and making it look so much nicer. $\endgroup$ – Miguel Jun 27 '15 at 23:51
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}}}
$\endgroup$
  • $\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 Jun 28 '15 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 Jun 28 '15 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 Jun 28 '15 at 10:00
  • $\begingroup$ Thank you. You also have my vote of course. $\endgroup$ – Mr.Wizard Jun 28 '15 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 Jun 28 '15 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}}
}
$\endgroup$
  • $\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 Jun 27 '15 at 23:54
  • $\begingroup$ @Miguel This needs further work. I shall try to find the time for it today. $\endgroup$ – Mr.Wizard Jun 28 '15 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 Jun 28 '15 at 11:57
  • $\begingroup$ @Miguel You're welcome; I am glad I could help. :-) $\endgroup$ – Mr.Wizard Jun 28 '15 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}}}}

$\endgroup$
  • $\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 Jun 28 '15 at 0:26

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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