I want the positions of the (sequential) running minima in a list, that is, the positions of entries that have the minimum value of all the elements in that list, up to and including that entry. For instance, given the list {3,4,4,2,5,5,1}
, the output should be {1,4,7}
.
4 Answers
lst = {3, 4, 4, 2, 5, 5, 1};
Assuming by "new minimum" you mean "running minima", you can use
Accumulate@Most@Join[{1}, Length /@ Split[FoldList[Min, First@lst, Rest@lst]]]
(* {1, 4, 7} *)
We get the same results with:
Accumulate@Most@Join[{1}, Length /@ Split[FoldList[Min, lst]]] (* thanks: Mr. Wizard *)
and
ReplacePart[#, p : _ :> If[p == 1 || #[[p]] < Min[#[[;; p - 1]]], p, ## &[]]] &[lst]
-
1$\begingroup$ At least the first of these answers is incorrect. For input
lst = {3, 4, 4, 2, 5, 5, 1, 6, 9, 2}
, the output is{1, 4, 7, 10}
but note that the final2
inlst
is not a true running minimum (there is a lower1
earlier inlst
) and hence there should be no position10
in the output. $\endgroup$ Mar 1, 2015 at 0:58 -
$\begingroup$ Thanks @DavidG.Stork. You are right; only the last one gives the sequential minima (I hope :)). I will delete the first four. $\endgroup$– kglrMar 1, 2015 at 1:18
-
-
$\begingroup$ Thank you @Mr.Wizard. The two-argument form also works in version 9.0.1.0 despite the syntax highlighting that suggest missing argument. $\endgroup$– kglrMar 1, 2015 at 3:10
-
$\begingroup$ @kguler My self-answer to the linked question above explains how to resolve that. :-) $\endgroup$ Mar 1, 2015 at 3:13
Despite there already being an accepted answer, my entry:
Update: Something else I came up with, cleaner and generally faster by a goodly margin than below and much faster in my tests against other answers I tested:
f3 = Module[{mp = First@Pick[Range@Length@#,
If[VectorQ[#, IntegerQ], Subtract[#, Min@#],
Unitize@Subtract[#, Min@#]], 0] &, lst = #},
NestWhileList[mp[lst[[;; # - 1]]] &, mp[lst], # != 1 &][[-1 ;; 1 ;; -1]]] &;
I'll leave the earlier attempts for reference.
f = Module[{lst = #,nextpos = 1,
minpos = First@Pick[Range@Length@#,
If[VectorQ[#, IntegerQ], Subtract[#, Min@#],
Unitize@Subtract[#, Min@#]], 0],
rec = First@# + 1, min, v1, v2},
min = lst[[minpos]];
{v1, v2} =
Reap@NestWhileList[lst[[Sow[ nextpos = First@Pick[Range[nextpos, minpos],
UnitStep@Subtract[lst[[nextpos ;; minpos]], #], 0]]]] &,
rec, # != min &];
{Rest@v1, First@v2}] &;
f[{20,30,50,4,5,6,8,2,3,1,0,4}]
(* {{20, 4, 2, 1, 0}, {1, 4, 8, 10, 11}} *)
Returns record values and positions.
Should be order+ magnitude faster on integer lists with duplication, competitive on sparse and/or non-integer ones.
The same short-circuiting can be used to dramatically improve the performance of kguler's answer by simply adding the restriction:
Accumulate@
Most@Join[{1}, Length /@ Split[FoldList[Min, First@lst,
Rest@(lst[[;; First@Pick[Range@Length@lst,
If[VectorQ[#, IntegerQ], Subtract[lst, Min@lst],
Unitize@Subtract[lst, Min@lst]], 0]]])]]]
N.b. - when I checked, a few of the earlier answers appear to return incorrect results...
-
$\begingroup$
f3
tests slow for me. I am using:SeedRandom[1]; list = RandomInteger[9999999, 500000]; list -= Accumulate@RandomInteger[1, 500000];
$\endgroup$ Mar 1, 2015 at 8:51 -
$\begingroup$ Hm... wait, now your older
f
also seems slower even after a restart. Would you test my new method please? $\endgroup$ Mar 1, 2015 at 8:53 -
$\begingroup$ @Mr.Wizard: Sure, give me a few minutes. Just did quick bmark against accepted on 1M integer lists with 1k,10k,100k,1M distincts, was 16-40X faster. Testing yours now... $\endgroup$– ciaoMar 1, 2015 at 8:55
-
$\begingroup$ I swear yours was testing faster for me ten minutes ago but now it seems slower; I guess I changed
list
but I cannot remember how. $\endgroup$ Mar 1, 2015 at 8:56 -
1$\begingroup$ @Mr.Wizard: Yes. If the lists are structured specifically in the form you make, there are more efficient methods (like yours, pretty BTW, and +1 inbound), but those methods suffer over other cases... $\endgroup$– ciaoMar 1, 2015 at 9:06
Update: here is a more efficient method also using Min
and FoldList
(from kguler) but with my own style. It is significantly faster than his code and far more efficient that my earlier attempts below.
If the input list has a decreasing trend this method is the fastest yet posted. However if the data is uniformly distributed rasher's optimization will on average be considerably faster.
list = {3, 4, 4, 2, 5, 5, 1, 6, 9, 2};
SparseArray[Differences@# ~Prepend~ 1]["AdjacencyLists"] & @ FoldList[Min, list]
{1, 4, 7}
Not highly efficient but rather direct:
list = {3, 4, 4, 2, 5, 5, 1, 6, 9, 2};
f[{min_, pos_}, new_] :=
{If[new < min, Sow[pos]; new, min], pos + 1}
Reap[Fold[f, {∞, 1}, list]][[2, 1]]
{1, 4, 7}
An adaptation of Simon's method from How to pick increasing numbers from the list:
Module[{i = ∞},
Join @@ Position[list, x_ /; x < i && (i = x; True), Heads -> False]
]
{1, 4, 7}
-
2$\begingroup$ Just a note - sparse solutions fail if lists are non-decreasing, returning {} instead of first ele. $\endgroup$– ciaoMar 2, 2015 at 9:22
-
$\begingroup$ @rasher I forgot about that case; thanks! $\endgroup$ Mar 2, 2015 at 19:15
-
$\begingroup$ No worries - it popped up in a check when I was benching various methods - I thought "WTF? no way MW's was wrong...". An unimaginably small probability that the test lists generated would contain such a list... time go to Monte Carlo and hit the tables ;-) $\endgroup$– ciaoMar 2, 2015 at 22:38
Length /@ Select[Table[Take[lst, i], {i, Length[lst]}], Last[#] == Min[#] &]
(* {1,4,7} *)
Split
. $\endgroup$