4
$\begingroup$

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]

enter image description here

$\endgroup$

3 Answers 3

8
$\begingroup$
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]

Mathematica graphics

$\endgroup$
5
  • $\begingroup$ That is excellent ... $\endgroup$
    – mrz
    Mar 17, 2016 at 22:20
  • $\begingroup$ I'm confuse the Nearest will result to a different mean distance. $\endgroup$
    – yode
    Mar 20, 2016 at 6:52
  • $\begingroup$ Ok,I find out the NearestNeighborGraph[coords,1,DirectedEdges->True] will get a same result with you. $\endgroup$
    – yode
    Mar 20, 2016 at 6:57
  • $\begingroup$ 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? $\endgroup$
    – mrz
    Mar 21, 2016 at 10:36
  • $\begingroup$ @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. $\endgroup$ Mar 21, 2016 at 10:47
4
$\begingroup$
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]

enter image description here

and for completeness:

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

enter image description here

$\endgroup$
2
$\begingroup$
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]]

enter image description here


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]

enter image description here

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]]

enter image description here

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

$\endgroup$
1
  • $\begingroup$ 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. $\endgroup$
    – mrz
    Mar 21, 2016 at 6:57

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.