2

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).

rogerl
  • 4,209
  • 3
  • 27
  • 42
  • 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... – ciao Sep 14 '16 at 22:04

2 Answers2

6
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]]
Jason B.
  • 68,381
  • 3
  • 139
  • 286
  • 2
    +1. This is a bit faster: list[[First /@ Tally@ FoldList[Max, Ordering@list]]]. – Michael E2 Sep 13 '16 at 14:52
  • @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. – Michael E2 Sep 13 '16 at 15:01
  • 1
    @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) – Jason B. Sep 13 '16 at 15:22
  • 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. – Michael E2 Sep 13 '16 at 15:41
0
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

corey979
  • 23,947
  • 7
  • 58
  • 101