Shameless Mathematica - Reimplementing the NearestNeighborGraph Function
Hareem Naveed

May 2, 2016

One of most interesting functions in the Mathematica package is the “NearestNeighborGraph” function. A simple demonstration:

NearestNeighborGraph[RandomReal[1,{50,2}]]

Specifying a radius makes a connected random graph:

a = NearestNeighborGraph[RandomReal[1,{50,2}],{All,0.3}]

Can also extract the Adjacency Matrix from such a graph:

AdjacencyMatrix[a] // MatrixForm

Let us try and implement a similar function that will give us the same basic functionality as described above. This is an exercise to improve understanding of how this function is implemented. Also, we will implement the function for 3D data.

First, let us generate some sample data to work with. We will generate random integers from 1 to 1000 for 40 points in 3 dimensions.

data = RandomInteger[{1,1000},{40,3}];

Let us compute a distance matrix using the “Compile” function to build a distance matrix from an input “mat” for all of the inputs:

computedistance := Compile[{{mat,_Real,2},n},
Table[(mat[[i,1]]-mat[[j,1]])^2 + (mat[[i,2]]-mat[[j,2]])^2+(mat[[i,3]]-mat[[j,3]])^2,{i,1,n},{j,1,n}]];

dist = computedistance[data,40]

Now you want to get the minimum distances for each point to another point:

minDist = Table[Min[Select[dist[[i]],#≠0&]],{i,1,40}]

Now, we have to retrieve the index to which this is connecting. We can retrieve this from our distance matrix by using the Position function:

distIndex = Table[Position[dist[[i]],minDist[[i]]],{i,1,40}]

Reading the above table, it indicates that 1 is closest to point 32, 2 is closes to point 3, and so on and so forth. To visualize this, we make a vector plot between the two plots:

a = Flatten[distIndex]

Graphics3D [{Blue, Arrow @ Table[{data[[i]],data[[a[[i]]]]},{i,1,40}],Axes -> True}]

This implementation is not very beautiful, but it accomplishes essentially the same task as the NearestNeighbourGraph function in 3D. A two-headed arrow indicates that those two points are the nearest neighbours for each other. Using the same code, we can generate similar NearestNeighbourGraphs for other datasets.

n=100;
data = RandomInteger[{1,1000},{n,3}];
dist = computedistance[data,n];
minDist = Table[Min[Select[dist[[i]],#≠0&]],{i,1,n}];
distIndex = Table[Position[dist[[i]],minDist[[i]]],{i,1,n}];
a = Flatten[distIndex];
Graphics3D [{Red, Arrow @ Table[{data[[i]],data[[a[[i]]]]},{i,1,n}],Axes -> True}]

n=700;
data = RandomInteger[{1,1000},{n,3}];
dist = computedistance[data,n];
minDist = Table[Min[Select[dist[[i]],#≠0&]],{i,1,n}];
distIndex = Table[Position[dist[[i]],minDist[[i]]],{i,1,n}];
a = Flatten[distIndex];
Graphics3D [{Blue, Arrow @ Table[{data[[i]],data[[a[[i]]]]},{i,1,n}],Axes -> True}]

What about a 2D plot? The goal is that the output should resemble that of the NearestNeighborGraph function for some input data.

computedistance2D:=Compile[{{mat,_Real,2},n},
Table[(mat[[i,1]]-mat[[j,1]])^2 + (mat[[i,2]]-mat[[j,2]])^2,{i,1,n},{j,1,n}]];

n=50;
data = RandomInteger[{1,1000},{n,2}];
dist = computedistance2D[data,n];
minDist = Table[Min[Select[dist[[i]],#≠0&]],{i,1,n}];
distIndex = Table[Position[dist[[i]],minDist[[i]]],{i,1,n}];
a = Flatten[distIndex];
Graphics[{Purple, Arrow @ Table[{data[[i]],data[[a[[i]]]]},{i,1,n}],Axes -> True}]

With some simple matrix transforms, we could also retrieve the adjacency matrix from the above data.