# How to exclude some points to make them more evenly distributed in a figure

If there are some points in a figure, how can I exclude some points to make them more evenly in the figure? 'Evenly' here can be defined as the number of points in each $0.01*0.01$ box is at most one. Without loss of generality, we can produce some random data to copy with (we can also give data directly, which is too long and tedious to present them here. So, we do not talk about how to produce the data but how to copy with the given data)

ListPlot[RandomReal[{-1, 1}, {10000, 2}]]


Any help or suggestion will be appreciated!

– rm -rf
Sep 16 '13 at 0:08
• The points look reasonalby uniformly distributed to me. The greater spread along x-axis in the plot is due to scale distortion. Try adding AspectRatio -> Automatic to your plot. Sep 16 '13 at 0:36
• ListPlot[Table[{x, y}, {x, -1, 1, 0.05}, {y, -1, 1, 0.05}]~Flatten~1] Sep 16 '13 at 0:42
• I'm marking this as a duplicate unless and until this question is edited to specifically differentiate it from the linked one. Sep 16 '13 at 1:22
• @Mr.Wizard Thanks! The question here is not about how to produce the data but how to copy with the given data. I update the question. Sep 16 '13 at 13:10

Starting with some data:

SeedRandom[1]
data = RandomReal[{-1, 1}, {10000, 2}];
ListPlot[data, AspectRatio -> Automatic]


We can gather points by their rounded positions and keep only the first:

data2 = First /@ GatherBy[data, Round[#, 0.02] &];


Producing this:

ListPlot[data2, AspectRatio -> Automatic]


Note that I rounded by 0.02 to better show the effect, but by your problem description this should have been 0.01. You could also use Floor or Ceiling in place of Round to control the position of the effective underlying grid.

I assumed that your specification "the number of points in each 0.01∗0.01 box is at most one," is describing a grid of boxes rather than infinitely many overlapping boxes. This means that at the margin of these boxes points may still crowd. It is possible with much slower processing to do a pairwise compare of all points and delete any that are too close:

data3 = DeleteDuplicates[data, EuclideanDistance[##] < 0.02 &];  (* slow *)

ListPlot[data3, AspectRatio -> Automatic]


See the bottom section of this answer for more examples and explanation of the slower behavior of the pairwise operation.

Inspired by ybeltukov's answer here is my own oversampling approach:

decimate[data_, grid_, steps_] :=
Module[{filter},
filter[d2_, jitter_] := First /@ GatherBy[d2, Round[# + jitter, grid] &];
Fold[filter, data, Most @ Range[0, grid, grid/steps]]
]


steps controls the oversampling factor. For example 25X:

decimate[data, 0.02, 25];

ListPlot[%, AspectRatio -> Automatic]


• I think this is pretty close to what the OP was expecting.
– rm -rf
Sep 16 '13 at 17:22
• Do I understand correctly that your oversampling applies only in the direction (1,1) not (1,-1)? Like my f3. I called this effect as "anisotropy". Sep 17 '13 at 0:30
• @ybeltukov I may not understand. The offset or "jitter" as I called it (on reflection that would be more appropriate of it were random I think) is added equally to x and y values before rounding, so e.g. {1, 2} becomes {1.1, 2.1}. I think this is what you mean. I do not see how this causes a problem if offsets cover an evenly spaced range across the grid size. Am I mistaken? Sep 17 '13 at 0:44
• @Mr.Wizard Even with infinite number of steps the lower bound of minimal distance is grid/Sqrt[2] not grid as expected (you can check it with my mindist). It is because the equal addition to x and y. I suggest to take different pairs of (jitterX, jitterY). Sep 17 '13 at 17:36
• @ybeltukov Okay, I see what you mean. Thanks for taking the time to point it out. Your method, with sufficient steps, would better approximate the pairwise Euclidean distance. My method follows the "0.01∗0.01 box" description, it just overlaps them. Sep 17 '13 at 22:27

I propose a compromise between rounding positions and pairwise comparisons of Mr.Wizard answer

data = RandomReal[{-1, 1}, {10000, 2}];
f1[data_, r_] := First /@ GatherBy[data, Round[#, r] &];
f2[data_, r_] := f1[# - ConstantArray[{r/2.0, 0.0}, Length[#]], r] &@
f1[# - ConstantArray[{0.0, r/2.0}, Length[#]], r] &@
f1[# + ConstantArray[{r/2.0, 0.0}, Length[#]], r] &@
f1[data + ConstantArray[{0.0, r/2.0}, Length[data]], r];
f3[data_, r_] := f1[# + r/3, r] &@f1[# + r/3, r] &@f1[data, r] - 2r/3;
data1 = f1[data, 0.02];
data2 = f2[data, 0.02];
data3 = f3[data, 0.02];


f3 is simpler than f2 but produce slight anisotropy. Now minimal pairwise distances are

mindist[data_] :=
Sqrt@Min@Array[
Min@Total[(data[[#]] - Transpose@data[[1 ;; # - 1]])^2] &,
Length[data] - 1, 2];
mindist /@ {data, data1, data2, data3}

{0.000165427, 0.000540778, 0.0102496, 0.00725789}


As you can see f2 and f3 give much greater minimal distance. The lower bound of minimal distance is 0 for f1, r/2 for f2, and r/3 for f3.

Visual comparison:

ListPlot[#, AspectRatio -> 1, ImageSize -> 350] & /@ {data, data1, data2, data3} // Row


• This is a natural extension of the rigid grid or window I used. +1 Sep 16 '13 at 23:53