# Remove 2D points where nearest neighbor exceeds certain distance

I have the following 2D points:

coords =
{{68.5909, 102.136}, {10.6, 101.3}, {103.5, 99.4091}, {49.5, 96.5},
{87.3182, 94.3182}, {28.8636, 87.4091}, {66.5, 84.}, {100.333, 78.5},
{48.5, 77.}, {82.1923, 76.4231}, {11.4167, 76.1667}, {29.5909, 68.1364},
{65., 64.}, {102., 61.7857}, {84.5, 60.3}, {47.5, 58.3}, {11.5, 54.},
{29.8846, 49.9615}, {75.5, 46.}, {94.5, 46.}, {111., 47.}, {58.5, 44.3},
{2.31818, 39.0455}, {42., 38.6}, {20.5909, 34.1364}, {105.25, 31.9167},
{87.2143, 31.3571}, {70.5, 29.7}, {53.3182, 26.3182}, {34.5, 22.3},
{13.5, 19.5}, {97.8636, 17.1364}, {80.7, 15.5}, {64.4, 12.8}, {46.5, 10.3},
{26.5, 7.7}, {6.16667, 4.38889}, {108.5, 3.7}, {92.5, 2.3}, {23., 0.5}, {75.5, 0.5}}


The sorted distances between next nearest neighbors are:

distances = Sort[EdgeList@NearestNeighborGraph[coords, 1] /.
UndirectedEdge -> EuclideanDistance, Greater]

{22.946, 19.8693, 19.5256, 19.2864, 18.7267, 18.4049, 18.2565,
18.1772, 17.8045, 17.5483, 17.4258, 17.0848, 16.9706, 16.9637,
16.8964, 16.7972, 16.7965, 16.7962, 16.7016, 16.6481, 16.6092,
16.5221, 16.3553, 16.2874, 16.2636, 16.1422, 16.0611, 15.8758,
15.7761, 8.00562}


How can I remove all 2d data points from the list coords of which the next neighbor distance is greater than the mean distance (Mean[distances] = 17.1175)?

Show[ListPlot[coords], NearestNeighborGraph[coords, 1],
AspectRatio -> 1]


f = Nearest[coords]
m = Mean[EuclideanDistance[#, Last@f[#, 2]] & /@ coords]
s = Select[f[#, {2, m}] & /@ coords, Length@# == 2 &]

ListPlot[{coords, Flatten[s, 1]},
PlotStyle -> Directive /@ {{PointSize[Large], Red}, Green},
Epilog -> Line /@ s]


• That is excellent ...
– mrz
Commented Mar 17, 2016 at 22:20
• I'm confuse the Nearest will result to a different mean distance.
– yode
Commented Mar 20, 2016 at 6:52
• Ok,I find out the NearestNeighborGraph[coords,1,DirectedEdges->True] will get a same result with you.
– yode
Commented Mar 20, 2016 at 6:57
• Do you see the same (yodes last plot) that in your code when the mean is calculated some distance are added twice. How would the solution for your code look like, when the distance between two points which are nearest to each other should only be counted once?
– mrz
Commented Mar 21, 2016 at 10:36
• @mrz The logic behind the "distances counted twice" looks right to me. What we are doing is the following: "Take one point. Sum up the distance to its nearest neighbor. At the end divide by the number of points". Sometimes point A is the nearest neighbor of point B, and point B is the nearest neighbor of point A, so that distance appears twice in the sum, but it looks OK to me. If you want another "logic" for calculating the mean distance please specify it. Commented Mar 21, 2016 at 10:47
nng = EdgeList@NearestNeighborGraph[coords, 1]
m = Mean[EuclideanDistance @@@ nng]
p = Pick[nng, EuclideanDistance @@ # < m & /@ nng]
Graph[p, VertexCoordinates -> VertexList[Graph@p], Axes -> True,
VertexSize -> 0.2, VertexStyle -> Red]


and for completeness:

d = Thread[p -> EuclideanDistance @@@ p];
Graph[p, VertexCoordinates -> VertexList[Graph@p], Axes -> True,
VertexSize -> 0.2, VertexStyle -> Red, EdgeLabels -> d]


edgelist = List @@@ EdgeList@NearestNeighborGraph[coords, 1];
meanDistance = EuclideanDistance @@@ edgelist // Mean;
pair = If[EuclideanDistance @@ # < meanDistance, #, Nothing] & /@
edgelist


{{{103.5, 99.4091}, {87.3182, 94.3182}}, {{100.333, 78.5}, {102., 61.7857}}, {{82.1923, 76.4231}, {84.5, 60.3}}, {{84.5, 60.3}, {75.5, 46.}}, {{29.8846, 49.9615}, {42., 38.6}}, {{75.5, 46.}, {58.5, 44.3}}, {{94.5, 46.}, {87.2143, 31.3571}}, {{111., 47.}, {105.25, 31.9167}}, {{42., 38.6}, {53.3182, 26.3182}}, {{20.5909, 34.1364}, {13.5, 19.5}}, {{87.2143, 31.3571}, {70.5, 29.7}}, {{34.5, 22.3}, {46.5, 10.3}}, {{34.5, 22.3}, {26.5, 7.7}}, {{13.5, 19.5}, {6.16667, 4.38889}}, {{97.8636, 17.1364}, {92.5, 2.3}}, {{80.7, 15.5}, {64.4, 12.8}}, {{80.7, 15.5}, {75.5, 0.5}}, {{26.5, 7.7}, {23., 0.5}}, {{108.5, 3.7}, {92.5, 2.3}}}

Then let's visulize it.

Graphics[{PointSize[0.02], Point[coords], Red, Line[pair], Blue,
Text[EuclideanDistance @@ #, Mean@#] & /@ pair},
PlotLabel -> StringForm["The Mean Distance is ", meanDistance],
LabelStyle -> Directive[Bold, Red, 18]]


Update:

The update just wanna alert the OP to noted your distances will lead to a difference result.As the vulgar understanding,I think the currently accepted answer is more reasonable.But in any case it's up to what you want.When we use the UndirectedEdge in default.It just count one time when two point is nearest each other.The graph is like following.

NearestNeighborGraph[coords, 1, VertexSize -> Large]


But when you use DirectedEdge to count it,it will count two times in every pair

NearestNeighborGraph[coords, 1, VertexSize -> Large,
DirectedEdges -> True,
EdgeShapeFunction -> GraphElementData["Arrow", "ArrowSize" -> .02]]


This is the reason there are some differences in our answer.

• Thank you very much for your investigation ... I was not aware of it. In the last plot I only want that each distance should be counted once ... to determine the mean next neighbor distance.
– mrz
Commented Mar 21, 2016 at 6:57