7
$\begingroup$

If I start with a 2-d set of points:

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

$\endgroup$
  • 1
    $\begingroup$ @kglr : I always thank everyone for their contributions and this is my acceptance. I leave accepting "open" to get maximum contributions. Thank you for your comment kglr. $\endgroup$ – Gilmar Rodriguez Pierluissi Jul 26 '18 at 19:24
5
$\begingroup$

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}} *)
$\endgroup$
  • 1
    $\begingroup$ 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? $\endgroup$ – Jason B. Jul 25 '18 at 19:03
  • $\begingroup$ My answers are only different if the first coordinate is not ordered. The OP has ordered and regularly spaced first coordinate. $\endgroup$ – rhermans Jul 25 '18 at 19:13
  • $\begingroup$ @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. $\endgroup$ – Jason B. Jul 25 '18 at 19:15
  • 1
    $\begingroup$ 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] $\endgroup$ – rhermans Jul 25 '18 at 19:16
  • 1
    $\begingroup$ @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. $\endgroup$ – Jason B. Jul 26 '18 at 12:07
5
$\begingroup$
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

$\endgroup$
  • $\begingroup$ Point taken that ReplaceRepeated is much slower under these conditions (the list being already sorted, and with many duplicate values). $\endgroup$ – Jason B. Jul 26 '18 at 11:53
4
$\begingroup$
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 *)
$\endgroup$
  • $\begingroup$ I think DeleteDuplicates[points, Last@#1 >= Last@#2 &] is better, Union[points,SameTest->...] isn't always correct. $\endgroup$ – chyanog Jul 31 '18 at 2:53
  • $\begingroup$ @chyanog got any examples of it failing? $\endgroup$ – rhermans Jul 31 '18 at 11:39
  • $\begingroup$ 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} $\endgroup$ – chyanog Aug 1 '18 at 2:23
  • $\begingroup$ @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. $\endgroup$ – rhermans Aug 1 '18 at 10:53
3
$\begingroup$

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]
$\endgroup$
  • $\begingroup$ 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. $\endgroup$ – Gilmar Rodriguez Pierluissi Jul 25 '18 at 18:15
  • 1
    $\begingroup$ 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. $\endgroup$ – Bill Jul 25 '18 at 22:04
  • $\begingroup$ Thank you for your recommendation Bill. I spend considerable time comparing methods and approaches because that's when the real learning occurs. $\endgroup$ – Gilmar Rodriguez Pierluissi Jul 26 '18 at 19:28

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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