# 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 Sep 20 '13 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. – RunnyKine Sep 20 '13 at 22:39
• That's why I havn't said dupicate :) isn't ManhattanDistance and Mod a fix? – Kuba Sep 20 '13 at 22:59
• @Kuba. That sounds like it might do it. Thanks. I'll look into that. – RunnyKine Sep 20 '13 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. – RunnyKine Sep 20 '13 at 22:57
• Now I'm using it in the second answer. – Murta Sep 20 '13 at 23:22