2
$\begingroup$

This is related (in my mind, but probably not in terms of solutions) to this question.

Given a list, I'd like to first find the minimum element (or the leftmost such if there are two); then, among the rest of the list to the right of the found element, the minimum of what remains. Continue until there is only one element left. Thus for example given {7,2,5,3,4,8} the result would be {2,3,4,8} (2 is the minimum. After removing 7 and 2, you are left with {5,3,4,8}, of which 3 is the minimum. Continue.) Given {4, 5, 3, 2, 4, 4, 6, 3, 7, 5, 5, 8} the result would be {2,3,5,5,8}.

It appears that I could use Min together with Position and iterate over the list, removing elements to the left of the last found peak, but is there a more efficient way? (These will be pretty long lists).

$\endgroup$
  • $\begingroup$ It would be nice to see your own effort(s) presented in the question. In general, this is not a "do this for me" site... $\endgroup$ – ciao Sep 14 '16 at 22:04
6
$\begingroup$
list = {4, 5, 3, 2, 4, 4, 6, 3, 7, 5, 5, 8};
Module[{x = 1, ord = Ordering@list},
 list[[
   Reap[
     Scan[
      If[# > x, Sow[x = #]] &,
      ord]
     ][[2, 1]]
   ]]
 ]
(* {2, 3, 5, 5, 8} *)

This code by Xavier works similarly (and with similar timing), by going through the elements one-by-one and keeping track of the current lowest-value, but uses Map instead of Scan, Reap, and Sow

Reverse@Map[x = list[[-1]]; If[# <= x, x = #, Nothing] &, Reverse@list]

The above methods are fairly quick, but for efficiency this method by MichaelE2 wins the prize:

list[[DeleteDuplicates@FoldList[Max, Ordering@list]]
$\endgroup$
  • 1
    $\begingroup$ +1. This is a bit faster: list[[First /@ Tally@ FoldList[Max, Ordering@list]]]. $\endgroup$ – Michael E2 Sep 13 '16 at 14:52
  • $\begingroup$ @Xavier In my mind, it is still Jason's algorithm, just with a fast Max replacing a slow If tossed with a bit of "immutability," if I understand that term correctly. My hope was that he'd include it in his answer. But if he doesn't want to, I will post it later. $\endgroup$ – Michael E2 Sep 13 '16 at 15:01
  • 1
    $\begingroup$ @MichaelE2 - I was going to say that the only similarity between yours and mine is the final call to Part, but then I really examined it and I can see the similarity more. I can add it here if you like (I have been slacking off here since I got a real job, my fake internet points tally is no longer growing like it used to) $\endgroup$ – Jason B. Sep 13 '16 at 15:22
  • $\begingroup$ This has the same speed, but it's clearer, imo: list[[DeleteDuplicates@FoldList[Max, Ordering@list]]]. I suppose it's arguable whether the idea for an algorithm or for the code refactoring should be considered more deserving of points on a site devoted to both. I've got enough f.i.p.s, so feel free to incorporate it, if you're comfortable with that. $\endgroup$ – Michael E2 Sep 13 '16 at 15:41
0
$\begingroup$
a = {4, 5, 3, 2, 4, 4, 6, 3, 7, 5, 5, 8};

minimas[list_] := Block[{a, out, f, min, pos},
  a = list;
  out = {};
  f := Module[{},
    min = First@TakeSmallest[a, 1];
    AppendTo[out, min];
    pos = First@Flatten@Position[a, min];
    a = Drop[a, pos]
    ];
  While[Length@a > 0, f];
  out
  ]

minimas[a]

{2, 3, 5, 5, 8}

The timing is also acceptable:

b = RandomInteger[100, 100000];
minb = minimas[b]; // RepeatedTiming

{1.69, Null}

Length @ minb

989


c = RandomInteger[1000, 100000];
minc = minimas[b]; // RepeatedTiming

{0.12, Null}

Length @ minc

86

$\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.