# Clustering 3D Data Points on a Periodic Cubic Grid

I have a set of 3D data points on a cubic grid. The data can be downloaded from here https://skydrive.live.com/redir?resid=F96524B72DCD75FB!14240 and read into a variable lis using

lis = ReadList["filename", {Number, Number, Number}].

How can one cluster the points into groups such that the points in each group are related by the fact that they are only one grid point away from their nearest neighbor in all directions (taking periodic boundaries in all directions into account). By all directions I mean the six faces of a cube. The EuclideanDistance between grid points is 0.055089 .

Here is a plot of the data (well solution, see below).

Actually, I was able to solve this problem using object-oriented programming in C#, but I've come up short trying to reproduce it in Mathematica. I've tried a combination of FindClusters and Nearest with no success. Any help will be much appreciated. I have tried to include as much information as I think is needed to solve this problem but if more information is needed I'll gladly provide it.

Note: In the plot above, I've removed groups that has less than 20 points.

• It seems to be closely related to make specific cluster.
– Kuba
Commented Sep 20, 2013 at 22:32
• @Kuba, I did see that question. Doesn't include periodic boundaries though. And the criteria seems to be just the EuclideanDistance in any direction. Commented Sep 20, 2013 at 22:39
• That's why I havn't said dupicate :) isn't ManhattanDistance and Mod a fix?
– Kuba
Commented Sep 20, 2013 at 22:59
• @Kuba. That sounds like it might do it. Thanks. I'll look into that. Commented Sep 20, 2013 at 23:03

As a first simple way:

data=ReadList["points.txt",{Number,Number,Number}];
dataG=Gather[data,EuclideanDistance[#1,#2]<0.5&]
ListPointPlot3D[dataG,PlotStyle->Directive[PointSize[0.01]] ,BoxRatios->{1,1,1}]


But this do not consider the grid structure. And later I discovered here why this is not a good way.

Another more precise one is:

dataS=SparseArray[Thread[Map[IntegerPart,data/0.055088983050847+1,{-1}]->1]];
img=Image3D[Raster3D[Normal@dataS]];
(img=MorphologicalComponents[img])//Colorize


You can get image clustered points with.

pointsCluster=MapAt[0.055088983050847 # &, ArrayRules@MorphologicalComponents[dataS], {All, 1}]


Ploting again now we have:

ListPointPlot3D[GatherBy[pointsClusters[[;;-2]],Last][[All,All,1]],BoxRatios->{1,1,1}]


• It's close but not quite. I still see points joined that shouldn't be. And I don't see where you've taken periodic boundary into account. Commented Sep 20, 2013 at 22:57
• Now I'm using it in the second answer. Commented Sep 20, 2013 at 23:22