In a list of points, how to efficiently delete points which are close to other points?

The following is a much faster, but not optimal, recursive solution:

pts = RandomReal[1, {10000, 2}];
f = Nearest[pts];

k[{}, r_] := r
k[ptsaux_, r_: {}] := Module[{x = RandomChoice[ptsaux]}, 
                      k[Complement[ptsaux, f[x, {Infinity, .05}]],  Append[r, x]]]

ListPlot@k[pts]

---

Some timings show this is two orders of magnitude faster than the OP's method:

ops[pts_] := Module[{pts2},
  pts2 = {pts[[1]]};
  Table[If[Min[Map[Norm[pts[[i]] - #] &, pts2]] > 0.05, 
    AppendTo[pts2, pts[[i]]]], {i, 2, Length[pts], 1}];
  pts2]

bobs[pts_] := Union[pts, SameTest -> (Norm[#1 - #2] < 0.05 &)]

belis[pts_] := Module[{f, k},
  f = Nearest[pts];
  k[{}, r_] := r;
  k[ptsaux_, r_: {}] := Module[{x = RandomChoice[ptsaux]}, 
                        k[Complement[ptsaux, f[x, {Infinity, .05}]], Append[r, x]]];
  k[pts]]


lens = {1000, 3000, 5000, 10000};
pts = RandomReal[1, {#, 2}] & /@ lens;
ls = First /@ {Timing[ops@#;], Timing[bobs@#;], Timing[belis@#;]} & /@  pts;
ListLogLinePlot[  MapThread[List, {ConstantArray[lens, 3], Transpose@ls}, 2], 
               PlotLegends -> {"OP", "BOB", "BELI"}, Joined ->True]

pts = Partition[RandomReal[1, 10000], 2];

ListPlot[pts]

Use SameTest option with Union

pts2 = Union[pts, SameTest -> (Norm[#1 - #2] < 0.05 &)];

Length[pts2]

326

ListPlot[pts2]

The following "solution" has the benefits of:

• making a very a uniform grid.

• being fast.

It has the (perhaps mortal) drawbacks of:

• not being automated.

• being pretty liberal about kicking out points.

Nonetheless, I wanted to play a little. Here's my take: generate a square grid of points and use Nearest to pick out the points nearest to the gridpoints:

pts = Partition[RandomReal[1, 10000], 2];
nearestOnGrid[points_, d_] := Nearest[points, Outer[List, Range[0, 1, d], Range[0, 1, d]]~Flatten~1]~Flatten~1
testDistances[grid_, leastD_] := Min[EuclideanDistance @@@ grid~Subsets~{2}] < leastD

Then, if we do

grid = nearestOnGrid[pts, 0.074]; // AbsoluteTiming
testDistances[grid, 0.05] // AbsoluteTiming
(* {0.000957, Null} *)
(* {0.016401, True} *)

Note that the choice of 0.074 was not automated. I used testDistances to find a value for the grid-spacing that made it True. However, since this takes 0.016 seconds, trying to automate the procedure with some sort of bracketing method will definitely make this slower than the rest of the options above.

Nonetheless, the results are:

GraphicsRow[{ListPlot[pts], ListPlot[grid]}, ImageSize -> 600]