User-defined distance functions in FindClusters

Question

I am trying to use FindClusters to segment data points into two special parts

data

ListPlot[data, PlotRange -> All, AspectRatio -> Automatic]

It is clear that these points can be divided into two parts, each radial arm can be treated as one part. I've tried different DistanceFunctions but can not get what I want, and I don't know how to define a right distance functions.

Show[
  ListPlot[FindClusters[data, 2, DistanceFunction -> CosineDistance][[1]],  
    AspectRatio -> Automatic, PlotStyle -> Blue],
  ListPlot[FindClusters[data, 2, DistanceFunction -> CosineDistance][[2]], 
    AspectRatio -> Automatic, PlotStyle -> Red], 
  PlotRange -> All]    

Is there any way to solve this problem?

Answer 1

Here is one solution.

1. Find a small number of nearest neighbors (NN's) for each point.
2. Make a graph each node of which corresponds to a data point and each edge corresponds to a NN's pair.
3. Partition the graph into connected components, or communities, or cliques.

In order the last step to work well, it might be a good idea to remove the points in the center of the data of the question.

The question says the desired partition is for "two special parts," but I see four "special" parts in the plot. That is why my solution explanations show four parts. The solution also works if two parts are desired.

Here are the Mathematica commands.

1. Finding the NN's

   nf = Nearest[data];
   
   pointToIndexRules = Dispatch[Thread[data -> Range[Length[data]]]];
   
   numberOfNNs = 20;
   dataNNs = Map[{#, Complement[nf[#, numberOfNNs], #]} &, data];
   

2. Making the graph edges (pairs of connected nodes)

   graphPairs = 
   Flatten@Map[
    Function[{p}, # <-> p & /@ Complement[nf[p, numberOfNNs], p]], 
    data] /. pointToIndexRules;
   

3. Optionally remove points at the center

   indsToRemove = Select[data, #.# < 0.01 &] /. pointToIndexRules;
   
   graphPairs=Select[graphPairs,!(MemberQ[indsToRemove,#[[1]]] ||             MemberQ[indsToRemove,#[[2]]])&];
   

4. Make the graph object

   dataGraph = Graph[graphPairs];
   

5. Find partition of the graph and the data

   clsInds = FindGraphPartition[dataGraph, 4];
   
   cls = Map[data[[#]] &, clsInds];
   

6. Plot the clusters

   ListPlot[cls, AspectRatio -> Automatic]
   

Here is the result of step 6.

If the center points are removed (which I think is a more robust method) then it is better in step 5 to use

clsInds = KCoreComponents[dataGraph, 3] 

Here is the result using that option:

If we want to see the data as being made of two parts then in step 5 we can use

clsInds = FindGraphPartition[dataGraph, 2];

and what we get is this result: