6
$\begingroup$

For example, given

{57, 3, 40, 94, 9, 84, 81, 93, 76, 5, 7, 76, 38, 9, 23, 95, 49, 0, 30, 3}

I'd like to get all the indices at which the elements cross from below 80 to above (or equal to) 80:

{4, 6, 16}

To do so I need the previous element at each current element of the condition.

All the examples for Position seem to use a single Slot, or higher Slots for nested lists, which makes me think maybe there's not a direct way. Do I have to use something like Partition to generate pairs, first? (If so, then I can take it from there; I just wanted to know if Position could do it with some syntax I don't know how to use, e.g. BlankSequence and such.)

$\endgroup$
4
  • 1
    $\begingroup$ Yes, I believe you need to break it up using Partition. It's not unreasonable to wonder if Position works with patterns such as __ or ___, but I believe it looks at elements one by one, and matches them against the pattern one by one. __ would require a global match. I think Positon[arr, pattern] does an equivalent of Do[If[MatchQ[arr[[i]], pattern], Sow[i]], {i, Length[arr]}]. $\endgroup$
    – Szabolcs
    Mar 27, 2015 at 1:07
  • $\begingroup$ By Slot, did you mean Blank? $\endgroup$
    – Szabolcs
    Mar 27, 2015 at 1:11
  • $\begingroup$ Do take a look at this though. $\endgroup$
    – Szabolcs
    Mar 27, 2015 at 1:15
  • $\begingroup$ see also: Finding zero-crossing in a list $\endgroup$
    – kglr
    Mar 27, 2015 at 1:20

5 Answers 5

10
$\begingroup$

Just a quick-n-dirty, for huge lists there's faster ways, will update when time permits.

f = With[{s = Split[#, #1 < 80 && #2 >= 80 &]}, 
    Pick[Accumulate@(Length /@ s), Length /@ s, 2]] &;

f@{57, 3, 40, 94, 9, 84, 81, 93, 76, 5, 7, 76, 38, 9, 23, 95, 49, 0, 30, 3}

(* {4, 6, 16} *)

For large lists, this should be quite snappy:

f4 = With[{p = Partition[#, 2, 1]},
    Pick[Range@Length@p + 1, UnitStep@Subtract[p, 80], {0, 1}]] &;

Even faster:

f5 = Module[{o = Ordering[Join[{80}, #]], c},
    c = First@Pick[Range@Length@o, o, 1];
    Subtract[Intersection[o[[;; c - 1]] + 1, o[[c + 1 ;;]]], 1]] &;

And speedier yet:

f3 = Module[{p},
    p = Pick[Range@Length@#, UnitStep[Subtract[#, 80]], 1];
    If[p =!= {} && p[[1]] == 1, p = Rest@p];
    p[[Pick[Range@Length@p, 
       UnitStep@Subtract[#[[Subtract[p, 1]]], 80], 0]]]] &;

As a comparison, the other answers (so far):

sza = ReplaceList[#, {pre___, x_, y_, ___} /; x < 80 <= y :> 
     Length[{pre}] + 2] &;

kug1 = With[{lst = #}, 
    Select[Range[2, Length@lst], lst[[# - 1]] < 80 <= lst[[#]] &]] &;

kug2 = With[{lst = #}, 
    Pick[Range[2, Length@lst], 
     lst[[# - 1]] < 80 <= lst[[#]] & /@ Range[2, Length@lst]]] &;

ubp = (Flatten@Position[Partition[Sign[# - 80], 2, 1], {-1, 1 | 0}] + 
     1) &;

N.B.: The first three have been fixed to return results as in OP - as written they were not. The 0 alternative was added to ubpdqn`s solution to handle equality.

Using test = RandomInteger[{0, 160}, 110000]; as a test list that will have many transitions, and incrementally increasing the amount of it used:

enter image description here

It can be seen the Replace based solution quickly becomes unusably slow, Kguler's both perform well (and remarkably similarly), f leads those by roughly 50%, f4 is about 4X faster yet, ubpdqn's Sign-based solution falls neatly between f and f4, f5 beats those, and f3 handily beats all (it's buried in the noise of the plot). As usual, all timings on the loungebook.

$\endgroup$
1
  • $\begingroup$ +1 But please change the color of the f3 curve $\endgroup$ Mar 27, 2015 at 4:27
6
$\begingroup$

There is no way to do this with Position without breaking the list up using Partition[list, 2, 1] first. Position looks at elements one by one, and tests each for a match against the pattern. While we can use a pattern such as __ (BlankSequence[]), it won't behave any differently from _ (Blank[]) in Position because it will never be tested against the full list, only against individual list elements.

A trick to use a single pattern matching to find positions of correlated elements is described here, but it doesn't use Position. Applied to your problem, we get:

ReplaceList[list, {pre___, x_, y_, ___} /; x < 80 <= y :> Length[{pre}] + 1]

This is probably not the best way to solve the problem, but it is interesting in that it fully relies on pattern matching, just like Position.

$\endgroup$
4
$\begingroup$

Perhaps:

test = {57, 3, 40, 94, 9, 84, 81, 93, 76, 5, 7, 76, 38, 9, 23, 95, 49,
    0, 30, 3};
Position[Partition[Sign[test - 80], 2, 1], {-1, 1}] + 1

The +1, to get when crossed, would have to modify for equality cases, eg using Alternatives`

$\endgroup$
3
$\begingroup$
lst = {57, 3, 40, 94, 9, 84, 81, 93, 76, 5, 7, 76, 38, 9, 23, 95, 49,  0, 30, 3}
Select[Range[2, Length@lst], lst[[# - 1]] < 80 < lst[[#]] &]
(* {4, 6, 16} *)

Pick[Range[2, Length@lst], lst[[# - 1]] < 80 < lst[[#]] & /@ Range[2, Length@lst]]
(* {4, 6, 16} *)
$\endgroup$
2
$\begingroup$

Just using a chisel to drive a screw:

l = {57, 3, 40, 94, 9, 84, 81, 93, 76, 5, 7, 76, 38, 9, 23, 95, 49, 0,  30, 3};
f = Interpolation[l, InterpolationOrder -> 1]
NDSolve[{k'[x] == f'@x, k[1] == f[1], 
         WhenEvent[k[x] == 80, If[f'[x] >= 0, Print[Ceiling@x]]]},
         k[x], {x, 1, Length@l}]

(* 4,6,16 *)
$\endgroup$
2
  • 2
    $\begingroup$ This made me giggle, +1. $\endgroup$
    – ciao
    Mar 27, 2015 at 4:23
  • 1
    $\begingroup$ @rasher That was the (not) hidden intention :) $\endgroup$ Mar 27, 2015 at 4:24

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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