Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

I have a set of 2D points in the square defined by {-1, -1} and {1, 1}. These points typically form compact groups. I need to break them into clusters in such a way that the rectangular bounding boxes of the clusters will not overlap. The bounding boxes are expanded by a pre-specified margin, denoted dist.

I managed to implement this by computing the pairwise Manhattan distance, building a corresponding graph and taking the connected components of the graph (see attached code).

I was hoping that there would be a simper solution which avoids computing the complete pairwise distance matrix. I tried using FindClusters, but not having any experience with the underlying methods I did not manage to get it to return the appropriate number of clusters (it typically lumps everything together, even when points are "visually" separate). So the question is: Is it possible to implement this using FindClusters? The key is in choosing the correct Method option for FindClusters, which is unfortunately not documented in a way that's easy to understand for someone not familiar with these methods.

Requirements: The clustering does not need to be precise. If the method returns a bit fewer clusters than what I show in the image below, that's okay. I need the results for a heuristic decision anyway. But it should not lump together things which are rather far compared to the size of the visually perceived clusters. It is very easy for us humans to recognize these clusters, and I'd like to get the computer to give me same output one would naturally construct by hand after looking at the image. All points sets I have have a very similar structure to the one I show below, but the groups may have different size scales. This is why it makes sense to ask "I'd like to have the clusters similar to what I perceive visually". The method must work without any user intervention (manual estimation of parameters).


pts = Import["http://ge.tt/api/1/files/7sHEVob/0/blob?download", "WDX"];

dist = 0.01;

comp = ConnectedComponents@
   AdjacencyGraph[
    UnitStep[2 dist - Outer[ManhattanDistance, pts, pts, 1]]];

Graphics@MapIndexed[
  With[{p = pts[[#1]]}, {{GrayLevel[.9], 
      Rectangle[{Min[p[[All, 1]]], Min[p[[All, 2]]]} - 
        dist, {Max[p[[All, 1]]], Max[p[[All, 2]]]} + 
        dist]}, {ColorData[3][First[#2]], Point[p]}}] &, comp]

Click for a larger image:

share|improve this question
    
Could you post links to a few more training sets? –  belisarius Mar 22 '13 at 5:47
    
@belisarius You're right, I'll post some more, but give me a few hours so I'll be able to post a truly varied set. –  Szabolcs Mar 22 '13 at 14:36

4 Answers 4

up vote 7 down vote accepted

This is roughly 30 times faster than your approach and can be tuned easier than FindClusters[]:

getOneCluster[pts_List, maxDist_?NumericQ] :=(*Returns a cluster*)
 Module[{f},
  f = Nearest[pts];
  FixedPoint[Union@Flatten[f[#, {Infinity, maxDist}] & /@ #, 1] &, {First@pts}]]
clusters[data_] := Module[{f, dist},
  (* Some Characteristic Distance, assuming no isolated points*)
  f = Nearest[data];
  dist = 3 Max[EuclideanDistance[Last@f[#, 2], #] & /@ data];
  Flatten[Reap[NestWhile[Complement[#, Sow@getOneCluster[#, dist]] &, data, 
                         # != {} &]][[2]], 1]
  ]

(* Gen some data *)

SeedRandom[42];
numberOfClusters = 42;
clustersCenters = RandomReal[{0, 1}, {numberOfClusters, 2}];
data = Flatten[RandomVariate[BinormalDistribution[#, .002 {1, 1}, .1], 100] & /@ 
                            clustersCenters, 1];
pad = .01;

Plotting the results:

Graphics[MapIndexed[With[{p = #1}, {{GrayLevel[.9], 
                   Rectangle[{Min[p[[All, 1]]], Min[p[[All, 2]]]} - pad, 
                             {Max[p[[All, 1]]], Max[p[[All, 2]]]} + pad]}, 
                             {ColorData[3][First[#2]], Point[p]}}] &, clusters[data]], 
         Axes -> True]

Mathematica graphics

The problem with "merging" those clusters so that the bounding boxes don't overlap needs some heuristic and I think it should better be done as a post-processing step. The caveat is that the merging process done blindly (and worst, recursively) can aggregate much more points than seems reasonable. Take a look:

Mathematica graphics

share|improve this answer
    
It is possible to improve on this so that the boxes will never overlap? Boxes that would overlap can be merged. I get overlapping boxes with the original data I posted and dist = 0.01. I'll need some time to go through your code ... –  Szabolcs Feb 17 at 15:34
    
@Szabolcs The problem is that the points' scale and the boxes' scale could be very different. I think the merging ought to be done at a post-processing stage !Mathematica graphics –  belisarius Feb 17 at 15:47
    
OK, that's acceptable. –  Szabolcs Feb 17 at 15:51
    
It's okay to do the merging as a post processing step and it's also fine to merge those three clusters in your last example (it seems it's simply not possible to avoid merging them). I strictly needed non-overlapping rectangles for my application (though at this moment I'm not working on that project, I plan to return to it). –  Szabolcs Feb 18 at 15:14
    
@Szabolcs Remember you have MorphologicalComponents[Import["http://i.stack.imgur.com/q7gw5.png"], Method -> "BoundingBox"] // Colorize at hand :) –  belisarius Feb 18 at 15:24

You can get the same results with:

FindClusters[pts, Method -> {"Agglomerate", "Linkage" -> "Complete", 
                             "SignificanceTest" -> {"Gap", "Tolerance" -> 3}}]

But it is impossible to test its significance until you post more point sets.

share|improve this answer
    
How would you plot the result? Im having trouble understanding what the output of FindClusters here is –  AimForClarity Feb 17 at 1:48
    
@AimForClarity ListPlot[FindClusters[pts, Method -> {"Agglomerate", "Linkage" -> "Complete", "SignificanceTest" -> {"Gap", "Tolerance" -> 3}}], PlotRange -> All, AspectRatio -> 2] –  belisarius Feb 17 at 1:57
    
But there is no way to finetune max distance no? –  Murta Jul 31 at 23:26
    
@Murta I tried all I could think of back then when I wrote the answer and nothing worked. –  belisarius Jul 31 at 23:35

If you don't want to compute every pair-wise distance, one thing is to compute the Delaunay triangulation of all the points in the sets, this tends to be only ${\cal{O}}(n \log n )$ computation intesive.

We will use the ComputationalGeometry package for the Delauny triangulation. There are other faster options described in this site, also this package does not do 3-dimensional points triangulation, there are some alternatives also described on the site.

Clustering is usually done by setting a minimal distance between points. This tend however to cause problems, for the case of clusters that are connected by single/few points etc. One way to deal with this is to cluster based on density.

DBSCAN

This is an implementation of the DBSCAN. Here, the idea is to give a minimum distance and a minimal number of points in that distance. Hence you give a density. Any locations that have a density lower than that, will remain unclustered, and are considered noise. So it could also be a problem if you don't want to "lose" any points.

The first part is an implementation of a Breath-First Scan code, probably using mathematica's own BFS might be faster. All parts of the code could make due with a rewriting for efficiency, this was manly written for my education than anything else. So if you find a way to make it faster, do let me know!! please.

MyDistance[x_, y_, points_] := 
  Sqrt[ #[[1]]^2 + #[[2]]^2] &@(points[[x]] - points[[y]]);
CountBreadthFirst2[adjgraph_List, point_Integer, dmax_Real, allpoints_] := 
    Module[{queue = {point},marked = ConstantArray[False, Length[adjgraph]],
             visit, dis,a},
a = Last@Reap[
  While[Length[queue] != 0,
    visit = First@queue;
    marked[[point]] = True;
    Scan[Function[{fx},
      If[! marked[[fx]],
                   marked[[fx]] = True;
                   dis = MyDistance[fx, point, allpoints];
                   If[dis <= dmax,
                             Sow[fx];
                 queue = Append[queue, fx];
                ];      
        ];
      ], adjgraph[[visit]][[2]]];
    queue = Delete[queue, 1];
    ];];
 If[Length[a] == 0, Return[{}];, Return[First@a];];
  ];

The second part is the actual DBSCAN code, where eps is minimal distance, and npoints is the minimal number of points that need to be found within that distance.

 DBSCAN[allpoints_, eps_, npoints_, adjgraph_] := 
     Module[{marked,clustered,clustcount,neighborp,visit,neighborpprime, i},

     marked = ConstantArray[False, Length[adjgraph]];
     clustered = ConstantArray[False, Length[adjgraph]];
     clustcount = 0;
  Return[Last@Reap[
  For[i = 1, i <= Length@allpoints, i++,
    If[marked[[i]], Continue[];,

      marked[[i]] = True;

      neighborp = 
       CountBreadthFirst2[adjgraph, i, eps, allpoints];
      If[Length[neighborp] < npoints,
         Sow[allpoints[[i]], "Noise"];,
       clustcount++;
       Sow[allpoints[[i]], clustcount];
       clustered[[i]] = True;

       While[Length@neighborp > 0,
        visit = First@neighborp;
         If[! marked[[visit]],
         marked[[visit]] = True;

         neighborpprime = 
          CountBreadthFirst2[adjgraph, visit, eps, allpoints];
            If[Length[neighborpprime] >= npoints,

          neighborp = 
            DeleteDuplicates@Join[neighborp, neighborpprime];
                   ];
           ];

        If[! clustered[[visit]], 
         Sow[allpoints[[visit]], clustcount]; 
         clustered[[visit]] = True;];
        neighborp = Delete[neighborp, 1];
        ];

       ];
      ];
    ];
  ]];
 ];   

We then apply the Delaunay triangulation, with a visualization.

points=Import["http://ge.tt/api/1/files/7sHEVob/0/blob?download", "WDX"];
myadj = DelaunayTriangulation[points];

ee = DeleteDuplicates[Sort[#] & /@ ((#[[1]] -> #[[2]]) & /@ (Flatten[
    Thread[#] & /@ myadj, 1]))];
GraphPlot[ee,VertexCoordinateRules -> MapIndexed[Last@#2 -> #1 &, pts], 
           Frame -> True, FrameTicks->True]

enter image description here

Then apply the DBSCAN code, with say at least 5 points within 0.001:

clustersp = DBSCAN[pts, 0.001, 5, myadj];
Length[clustersp]-1

>14

We actually find some extra clusters! The periphery points remain unclustered. Note that the current code, puts all the "noise" points in the first part of the output of clustersp. Also note that npoints=2 is just the specific case you had before.

Graphics[MapIndexed[
   With[{p = #1}, {{GrayLevel[.9], Opacity[0.05], 
  Rectangle[{Min[p[[All, 1]]], Min[p[[All, 2]]]} - 
    0.01, {Max[p[[All, 1]]], Max[p[[All, 2]]]} + 
    0.01]}, {ColorData[3][First[#2]], Point[p]}}] &, 
    clustersp[[2 ;;]]], Axes -> True, Frame -> True]

enter image description here

share|improve this answer
    
This is a very nice one. BTW, the native BreathFirstScan[] in its current incarnation seems to lack control flow, so once it's started, it'll always visit every connected node of the graph, but there are some good alternatives already posted in this site. –  belisarius Feb 19 at 14:03
    
@belisarius Thanks, and double thanks for the heads up! I will search the site and see what I can find. –  lalmei Feb 22 at 16:32

Another way to approach this is to use some of the image processing tools. For example:

pts = Import["http://ge.tt/api/1/files/7sHEVob/0/blob?download", "WDX"];
img = Rasterize[ListPlot[pts, AspectRatio -> 1, Axes -> False], ImageSize -> 1000];
blocks = ColorNegate[Erosion[img, 10]];
ComponentMeasurements[blocks, "BoundingBox"]

{1 -> {{563., 792.}, {596., 817.}}, 2 -> {{678., 789.}, {712., 813.}},
 3 -> {{433., 729.}, {492., 758.}}, 4 -> {{577., 723.}, {632., 751.}}, 
 5 -> {{364., 663.}, {409., 699.}}, 6 -> {{503., 624.}, {562., 669.}}, 
 7 -> {{774., 356.}, {808., 382.}}}

provides a list of the locations of the various clusters. The method is simple enough. The first line makes a rasterized image of the points. The individual separated points are collected into blocks using the Erosion command. This can be easily visualized:

MorphologicalComponents[blocks] // Colorize 

enter image description here

The locations of the bounding boxes are then found using the ComponentMeasurements command.

Since the OP isn't looking for a precise answer but rather something "similar to what I perceive visually," using the image processing tools might be sensible. The two parameters at play are the size of the rasterization (I chose to make the image 1000-by-1000) and the amount of erosion (smaller will tend to detect more blocks, greater will tend to merge blocks if they are close).

share|improve this answer
    
Unfortunately I probably can't use this in practice for reasons I didn't mention in the question (sometimes it would need very high resolution images because the clusters might be tiny and the whole domain may be large), but otherwise it's a good and creative solution! One thing I like about Mathematica is how easy it is to mix completely different areas of functionality. I'll give it a try when I return to this project. –  Szabolcs Feb 18 at 16:31
    
@Szabolcs - I guess your "square defined by {-1, -1} and {1, 1}" must be larger than mine! –  bill s Feb 18 at 16:37
    
What I wanted to use this for originally (when I asked the question) was something like: "zoom in" on the interesting parts of a fractal structure and refine it only there. After a number of refinement steps these interesting parts may become tiny in that square. –  Szabolcs Feb 18 at 16:43
    
@Szabolcs - Sounds like an interesting project -- hope it works out. –  bill s Feb 18 at 16:45

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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