6
$\begingroup$

I want to select the new maximums from a random permutation. For example if RandomSample[Range[10], 10] returns {6, 9, 2, 4, 3, 10, 8, 1, 7, 5}

I want the list of elements that are greater than each of their predecessors. I want the list {6,9,10}.

$\endgroup$
  • 4
    $\begingroup$ DeleteDuplicates@FoldList[Max, {6, 9, 2, 4, 3, 10, 8, 1, 7, 5}]? $\endgroup$ – kglr Mar 25 '17 at 23:25
  • 2
    $\begingroup$ or lst={6, 9, 2, 4, 3, 10, 8, 1, 7, 5}; Union[Map[Max, Table[Take[lst, i], {i, 1, Length[lst]}]]] $\endgroup$ – user46676 Mar 25 '17 at 23:28
  • $\begingroup$ Yes! Thank you. $\endgroup$ – Geoffrey Critzer Mar 25 '17 at 23:38
6
$\begingroup$
direct[lst_] := Module[{n, max = -Infinity},
  Do[
    If[lst[[n]] > max,
       max = lst[[n]];
       Sow[max]
    ],
    {n, 1, Length@lst}
   ]
  ]

lst={6,9,2,4,3,10,8,1,7,5};
Last@Reap@direct[lst]

Mathematica graphics

Timings

Of all the above methods gives in answers and comments

ClearAll[f1,f2,f3,f4,g1]
f1=DeleteDuplicates@FoldList[Max,#]&;
f2=Module[{a=#,b=Range[Length@#]},a[[Pick[b,a[[#]]>=Max[a[[;;#]]]&/@b]]]]&;
f3=Module[{a=#},MapIndexed[If[#>=Max[a[[;;#2[[1]]]]],#,##&[]]&,a]]&;
f4=Module[{a=#,b={First@#}},While[(a=Rest@DeleteCases[a,_?(#<a[[1]]&)])=!={},AppendTo[b,First@a]];b]&;
g1[lst_]:=Module[{i},Union[Map[Max,Table[Take[lst,i],{i,1,Length[lst]}]]]];
lst=RandomSample[Range[44000],44000];

And

data={First@AbsoluteTiming[Last@Reap@direct[lst]],
    First@AbsoluteTiming[f1[lst]],
    First@AbsoluteTiming[f2[lst]],
    First@AbsoluteTiming[f3[lst]],
    First@AbsoluteTiming[f4[lst]],
    First@AbsoluteTiming[g1[lst]]};
Grid[{{"direct","f1","f2","f3","f4","g1"},data},Frame->All]

Mathematica graphics

Warning. do not run g1 method on more than 50,000. Mathematica will hang and the PC will hang as well. I have 16 GB and Mathematica always almost crash the PC when using something close to 50,000 with g1 method.

$\endgroup$
9
$\begingroup$
ClearAll[f1, f2, f3, f4]
f1 = DeleteDuplicates@FoldList[Max, #] &;
f2 = Module[{a = #, b = Range[Length@#]}, a[[Pick[b, a[[#]] >= Max[a[[;; #]]] & /@ b]]]] &;
f3 = Module[{a = #}, MapIndexed[If[# >= Max[a[[;; #2[[1]]]]], #, ## &[]] &, a]] &;
f4 = Module[{a = #, b = {First@#}}, 
     While[(a = Rest@DeleteCases[a, _?(# < a[[1]] &)])=!={}, AppendTo[b, First@a]]; b] &;

# @ {6, 9, 2, 4, 3, 10, 8, 1, 7, 5} & /@ {f1, f2, f3, f4}

{{6, 9, 10}, {6, 9, 10}, {6, 9, 10}, {6, 9, 10}}

$\endgroup$
4
$\begingroup$

It is efficient to do this in reverse. Find the maximum of the whole list, then everything to the right of that can be removed. Then repeat this process recursively.

f[x_] := With[{p = Ordering[x, -1][[1]]}, Sow[x[[p]]]; If[p > 1, f[x[[;; p - 1]]]]]
f[{x_}] := Sow[x]
maxes[x_] := Reverse[Reap[f[x]][[2, 1]]]

The speed compares favourably with kglr's f1:

x = RandomSample[Range[10^6]];

RepeatedTiming[a = f1[x];]
(* {0.164, Null} *)

RepeatedTiming[b = maxes[x];]
(* {0.00571, Null} *)

a == b
(* True *)
$\endgroup$

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.