Nearest neighbor functions have multiple applications in computer science. Historically they were important in compiler construction for ferreting out paths of execution. In this use, if an element has multiple nearest neighbors (k=1) at the same distance then only one of them is returned. This is because it is not pragmatic (and historically not tractable) to pursue multiple nearest neighbor paths. The Wolfram NearestNeighborGraph[…] function is well-suited for these types of application. There is another application for which nearest neighbor analysis is important: clustering. In this use case the return of all nearest neighbors (k=1) at the same distance is important. Ignoring multiplicity -- especially in metric spaces will result in clustering errors. Presented here is a modest alternative to the Wolfram function(s). We begin with the following data:
In[]:=
points={{"A",{1,9}},{"B",{2,2}},{"C",{3,7}},{"D",{3,4}},{"E",{4,2}},{"F",{5,6}},{"G",{6,8}},{"H",{6,4}}};pointsCount=Length[points];pointPlot=ListPlot[(Callout[#[[2]],#[[1]],Above,LeaderSize->0]&/@points),AspectRatio->1,ImageSize->Small];Print[pointPlot];
From these compute metric “Edge Distances” for an undirected graph. Here the Euclidean Distance is used for the geometric points:
In[]:=
edgeDistances=Flatten[Table[Table[{points[[i,1]]points[[j,1]],EuclideanDistance[points[[i,2]],points[[j,2]]]},{j,i+1,pointsCount}],{i,1,pointsCount-1}],1];edgeDistancesCount=Length[edgeDistances];Print["size check: edgeDistancesCount = ",edgeDistancesCount," vs pointsCount*(pointsCount-1)/2 = ",pointsCount*(pointsCount-1)/2];
size check: edgeDistancesCount = 28 vs pointsCount*(pointsCount-1)/2 = 28
Now define:
In[]:=
NearestNeighborEdgesDistances1[edgeDs_]:=Block[(*LIMITATIONS:k=1,inputmustbeundirectededgedistancesforcorrectresults.*)(*localvariables*){vertices,distanceHash,nnEdgeDistancesDA,theseEdgeDs,h},(*code*)vertices=Union[Flatten[({#[[1,1]],#[[1,2]]}&/@edgeDs),1]];distanceHash=CreateDataStructure["HashTable"];distanceHash["Insert",{#[[1,1]],#[[1,2]]}#[[2]]]&/@edgeDs;distanceHash["Insert",{#[[1,2]],#[[1,1]]}#[[2]]]&/@edgeDs;nnEdgeDistancesDA=CreateDataStructure["DynamicArray"];Do[theseEdgeDs=SortBy[Table[If[i≠j,{ij,#,N[#]}&[distanceHash["Lookup",{i,j}]],Nothing],{j,vertices}],Last];h=1;While[theseEdgeDs[[h,3]]theseEdgeDs[[1,3]],nnEdgeDistancesDA["Append",theseEdgeDs[[h,1;;2]]];h++],{i,vertices}];Normal[nnEdgeDistancesDA]];
Use this function to produce the correct nearest neighbor relations:
In[]:=
nnEdgeDistances=NearestNeighborEdgesDistances1[edgeDistances];nnEDgraph=EdgeTaggedGraph[nnEdgeDistances[[;;,1]],BaseStyle->{Arrowheads[0.025],FontFamily"Helvetica",Black,11},VertexStyle->Black,VertexLabels->Placed[All,Above],EdgeStyle->RGBColor["#404040"],EdgeLabelStyle->10,EdgeLabels->(#[[1]]#[[2]]&/@nnEdgeDistances),AspectRatio->1/GoldenRatio,GraphLayout->{"VertexLayout""SpringEmbedding","PackingLayout""ClosestPacking"},ImageSize->{72*4,Automatic}];Print[Column[{nnEDgraph,pointPlot},Center,1]];
Compare with the “greedy” relations produced by the Wolfram function:
In[]:=
vertices=Union[Flatten[({#[[1,1]],#[[1,2]]}&/@edgeDistances),1]];δsup=Max[edgeDistances[[;;,2]]]*10^5;distanceHash=CreateDataStructure["HashTable"];distanceHash["Insert",{#[[1,1]],#[[1,2]]}#[[2]]]&/@edgeDistances;distanceHash["Insert",{#,#}δsup]&/@vertices;distanceHash["Insert",{#[[1,2]],#[[1,1]]}#[[2]]]&/@edgeDistances;nnWprepG=NearestNeighborGraph[vertices,1,DistanceFunction->(distanceHash["Lookup",{#1,#2}]&)];nnWedgeDistances=({#,distanceHash["Lookup",{#[[1]],#[[2]]}]}&/@EdgeList[nnWprepG]);nnWgraph=NearestNeighborGraph[vertices,1,DistanceFunction->(N[distanceHash["Lookup",{#1,#2}]]&),BaseStyle->{Arrowheads[0.025],FontFamily"Helvetica",Black,11},VertexStyle->Black,VertexLabels->Placed[All,Automatic],EdgeStyle->RGBColor["#404040"],EdgeLabelStyle->10,EdgeLabels->(#[[1]]#[[2]]&/@nnWedgeDistances),AspectRatio->1/GoldenRatio,GraphLayout->{"VertexLayout""SpringEmbedding","PackingLayout""ClosestPacking"},ImageSize->{72*4,Automatic}];Print[Column[{nnWgraph,pointPlot},Center,1]];
