How to obtain a subset (of a 2-d set of points with random coordinates) having monotonically increasing ordinates
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}} *)
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
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 *)