Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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

enter image description here

Any help or suggestion will be appreciated!

share|improve this question
3  
Please define "more evenly" –  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. –  m_goldberg Sep 16 '13 at 0:36
    
ListPlot[Table[{x, y}, {x, -1, 1, 0.05}, {y, -1, 1, 0.05}]~Flatten~1] –  s0rce 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. –  Mr.Wizard 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. –  Eden Harder Sep 16 '13 at 13:10
add comment

2 Answers

up vote 4 down vote accepted

Starting with some data:

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

enter image description here

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]

enter image description here

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]

enter image description here

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]

enter image description here

share|improve this answer
    
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". –  ybeltukov 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? –  Mr.Wizard 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). –  ybeltukov 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. –  Mr.Wizard Sep 17 '13 at 22:27
add comment

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

enter image description here

share|improve this answer
    
This is a natural extension of the rigid grid or window I used. +1 –  Mr.Wizard Sep 16 '13 at 23:53
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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