# How to obtain a subset (of a 2-d set of points with random coordinates) having monotonically increasing ordinates

 points = {{4, 4}, {6, 4}, {8, 8}, {10, 8}, {12, 8}, {14, 12}, {16, 16},  {18, 12}, {20, 16}, {22, 20}, {24, 16}, {26, 24}, {28, 24}, {30, 16}, {32, 32}, {34, 32}, {36, 24}, {38, 36}, {40, 32}, {42, 24}, {44, 40}, {46, 44}, {48, 32}, {50, 40}, {52, 48}, {54, 36}, {56, 48}, {58, 56}, {60, 32}, {62, 60}, {64, 64}, {66,  40}, {68, 64}, {70, 48}, {72, 48}, {74, 72}, {76, 72}, {78, 48}, {80,64}, {82, 80}, {84, 48}, {86, 84}, {88, 80}, {90, 48}, {92, 88}, {94, 92}, {96, 64}, {98, 84}, {100, 80}}


how can I build the following subset with monotonically increasing ordinates:

{{4, 4}, {8, 8}, {14, 12}, {16, 16}, {22, 20}, {26, 24}, {32, 32}, {38, 36}, {44, 40}, {46, 44}, {52, 48}, {58, 56}, {62, 60}, {64, 64}, {74, 72}, {82, 80}, {86, 84}, {92, 88}, {94, 92}} ?

If points is your original list,

ReplaceRepeated[points,
{bef___,x:{x1_,x2_},y:{y1_,y2_},aft___}/;x2>=y2:>{bef,x,aft}
]
(* {{4, 4}, {8, 8}, {14, 12}, {16, 16}, {22, 20}, {26, 24}, {32,
32}, {38, 36}, {44, 40}, {46, 44}, {52, 48}, {58, 56}, {62,
60}, {64, 64}, {74, 72}, {82, 80}, {86, 84}, {92, 88}, {94, 92}} *)

• It was the fastest of what I'd tried. Trouble is that all the methods listed here aren't equivalent. Try using SeedRandom[42]; points = RandomInteger[100, {50, 2}]; and then running the different methods - they don't all give the same result. The two methods by @rhermans give a different output on that list, and the LongestOrderedSequence a different result still. Would need clarification by OP about what exactly is needed. Is the input list always going to be already sorted? Commented Jul 25, 2018 at 19:03
• My answers are only different if the first coordinate is not ordered. The OP has ordered and regularly spaced first coordinate. Commented Jul 25, 2018 at 19:13
• @rhermans - it wasn't a criticism, there is some ambiguity in the OP that wasn't originally clear. I was just pointing out that a timing test is premature since it compares apples and oranges. Commented Jul 25, 2018 at 19:15
• It's fine, I'm just explaining the source of the difference. You could compare using SeedRandom[42]; points = SortBy[RandomInteger[100, {50, 2}], First] Commented Jul 25, 2018 at 19:16
• @rhermans - If the question were "How to obtain a subset (of a pre-sorted 2-d set of points with random coordinates) having monotonically increasing ordinates", then we'd have a well-posed question and could do timing comparison (and obviously throw out my answer completely). But that isn't how I read the question. That's what I meant when I said a timing test is premature - the given answers do different things. Commented Jul 26, 2018 at 12:07
LongestOrderedSequence[points, #[[2]] < #2[[2]]& ]


{{4, 4}, {8, 8}, {14, 12}, {16, 16}, {22, 20}, {26, 24}, {32, 32}, {38, 36}, {44, 40}, {46, 44}, {52, 48}, {58, 56}, {62, 60}, {64, 64}, {74, 72}, {82, 80}, {86, 84}, {92, 88}, {94, 92}}

In, general, if input list is not already sorted by the first column:

LongestOrderedSequence[points, And @@ Thread @ Less @ ## & ]


same result

Alternatively, we get the same result using a combination of FixedPoint and Split, or a combination of rhermans's and Bill's methods:

FixedPoint[First /@ Split[#, #[[1]] >= #2[[1]] || #[[2]] >= #2[[2]] &] &, points]
DeleteDuplicates @ FoldList[If[#2[[2]] > #[[2]], #2, #] &, points]


For points in OP all the methods posted so far are faster than ReplaceRepeated:

LongestOrderedSequence[points , #[[2]] < #2[[2]] & ] ; // RepeatedTiming // First


0.00021

FixedPoint[First /@ Split[#,  #[[2]] >= #2[[2]] &] &, points] ; // RepeatedTiming// First


0.00013

DeleteDuplicates @ FoldList[ First[MaximalBy[Last][{#1, #2}]] &, points]; //
RepeatedTiming // First


0.0024

  Union[points, SameTest -> (Last@#1 <= Last@#2 &)] ; //  RepeatedTiming // First


0.00019

 (p = {0, 0};
Map[If[p[[1]] < #[[1]] && p[[2]] < #[[2]], p = #, fail] &,  points] /.
fail -> Sequence[]); //  RepeatedTiming // First


0.00018

 DeleteDuplicates@FoldList[If[#2[[2]] > #[[2]], #2, #] &, points]  ; //


RepeatedTiming // First

0.000082

ReplaceRepeated[points,
{bef___, x : {x1_, x2_}, y : {y1_, y2_}, aft___} /;
x2 >= y2 :> {bef, x, aft}
]; // RepeatedTiming // First


0.00056

For general input, the LongestOrderedSequence and other methods do not produce the same results. LongestOrderedSequence does produce the longest monotone sequence which does not necessarily include the first pair in the input list. The monotone sequence produced by other methods starts with the first pair but the sequence produced is not necessarily the longest possible.

Timings:

f1 = LongestOrderedSequence[# , #[[2]] < #2[[2]] & ] &;
f2 = FixedPoint[First /@ Split[#, #[[2]] >= #2[[2]] &] &, #] & ;
f3 = DeleteDuplicates @ FoldList[If[#2[[2]] > #[[2]], #2, #] &, #] &;
f4 = (p = {0, 0}; Map[If[ p[[2]] < #[[2]], p = #, fail] &, #] /. fail -> Sequence[]) &;
f5 = DeleteDuplicates @ FoldList[First[MaximalBy[Last][{#1, #2}]] &, #] &;
f6 = Union[#, SameTest -> (Last@#1 <= Last@#2 &)] &;
f7 = ReplaceRepeated[# , {bef___, x : {x1_, x2_}, y : {y1_, y2_}, aft___} /;
x2 >= y2 :> {bef, x, aft}] &;


The function f4 is from Bill's answer, f5 and f6 are from rhermans' answer, and f7 from Jason B.'s.

SeedRandom[1]
pnts = SortBy[RandomInteger[100, {10000, 2}], First];
timings = Table[0, 7];
results = Table[0, 7];
functions = {f1, f2, f3, f4, f5, f6, f7};
labels = {"f1", "f2", "f3", "f4", "f5", "f6", "f7"} ;

timings = Table[First[RepeatedTiming[results[[i]] = functions[[i]]@pnts;]], {i, 7}];

Prepend[SortBy[Transpose[{labels, timings, Length /@ results, First /@ results}],
#[[2]] &], {"f", "timing", "Length@f@pnts", "First@f@pnts" }] /.
x_Real :> NumberForm[x, {2, 4}] //
Grid[#, Dividers -> All, Alignment -> {Right, Center} ] &


$$\begin{array}{|r|r|r|r|} \hline f & \text{timing} & \text{Length@f@pnts} & \text{First@f@pnts} \\ \hline \text{f3} & 0.0038 & 57 & \{0,3\} \\ \hline \text{f6} & 0.0130 & 57 & \{0,3\} \\ \hline \text{f4} & 0.0210 & 57 & \{0,3\} \\ \hline \text{f1} & 0.1100 & 101 & \{3,0\} \\ \hline \text{f2} & 0.3500 & 57 & \{0,3\} \\ \hline \text{f5} & 0.5400 & 57 & \{0,3\} \\ \hline \text{f7} & 24.0000 & 57 & \{0,3\} \\ \hline \end{array}$$

All methods except LongestOrderedSequence give the same output:

Equal @@ Rest[results]


True

• Point taken that ReplaceRepeated is much slower under these conditions (the list being already sorted, and with many duplicate values). Commented Jul 26, 2018 at 11:53
benchmark = {{4, 4}, {8, 8}, {14, 12}, {16, 16}, {22, 20}, {26,
24}, {32, 32}, {38, 36}, {44, 40}, {46, 44}, {52, 48}, {58,
56}, {62, 60}, {64, 64}, {74, 72}, {82, 80}, {86, 84}, {92,
88}, {94, 92}}


## f5

Not very good, but my first thought. End up been the second slowest in @kglr's test.

DeleteDuplicates@FoldList[
First[MaximalBy[Last][{#1, #2}]] &,
points
] == benchmark

(* True *)


## f6

I like the simplicity if this one, and end up been the second fastest in @kglr's test.

Union[points, SameTest -> (Last@#1 <= Last@#2 &)] == benchmark

(* True *)

• I think DeleteDuplicates[points, Last@#1 >= Last@#2 &] is better, Union[points,SameTest->...] isn't always correct. Commented Jul 31, 2018 at 2:53
• @chyanog got any examples of it failing? Commented Jul 31, 2018 at 11:39
• points=RandomInteger[100,{50,2}]; res1=DeleteDuplicates@FoldList[First[MaximalBy[Last][{#1,#2}]]&,points]; res2=DeleteDuplicates[points,Last@#1>=Last@#2&]; res3=Union[points,SameTest->(Last@#1<=Last@#2&)]; {res1==res2,res1==res3} Commented Aug 1, 2018 at 2:23
• @chyanog this was discussed already in other comments. My answers are only different if the first coordinate is not ordered. The OP has ordered and regularly spaced first coordinate. Commented Aug 1, 2018 at 10:53

Using more basic functions, test the each pair against the last success and either accept or leave a marker to reject. When done delete the markers.

p = {0, 0};
Map[If[p[[1]] < #[[1]] && p[[2]] < #[[2]], p = #, fail]&, points]/.fail->Sequence[]

(*{{4, 4}, {8, 8}, {14, 12}, {16, 16}, {22, 20}, {26, 24}, {32, 32}, {38, 36}, {44, 40},
{46, 44}, {52, 48}, {58, 56}, {62, 60}, {64, 64}, {74, 72}, {82, 80}, {86, 84},
{92, 88}, {94, 92}}*)


or

p = {0, 0};
DeleteCases[Map[If[p[[1]] < #[[1]] && p[[2]] < #[[2]], p = #, fail]&, points], fail]

• Amazing! Thank you all for your answers! This is a question for which I couldn't find a straight answer anywhere. Now, all these approaches are located nicely in one place for everyone's benefit. Commented Jul 25, 2018 at 18:15
• I suggest that you take each of the approaches, study the functions used and how they are put together and see if you can understand how the approach works. When you have done that then see if you could imagine using or modifying that method for other problems that you might have in the future. That may provide you with the most learning for your future use of Mathematica. If you can learn a few of the basic functions and how to apply those then that may help you solve lots of different kinds of problems.
– Bill
Commented Jul 25, 2018 at 22:04
• Thank you for your recommendation Bill. I spend considerable time comparing methods and approaches because that's when the real learning occurs. Commented Jul 26, 2018 at 19:28