Positions satisfying pattern and grouped

Question

I have a list of numbers and I am looking for a way to most efficiently find positions of values that satisfy a certain condition and group those positions that are sequential. To illustrate, a simple list can look like

x={1,2,4,6,2,3,4,5,7,9,1,3,4,1}

and I am interested in all numbers that are greater than 2 and so I expect the return to look like:

res={{3,4},{6,7,8,9,10},{12,13}}

Alternatively, I would also need the result being the values in x however grouped in the same manner.

The stress is also on effectivness, this will be applied on a number of 100 MB data files. My initial idea was: Position[x, n_ /; n > 50] // Flatten and then somehow go through the output and determined if the next position is previous plus 1 but I think this is not very effective (also I have no idea how to do it without complex loops).

Answer 1

You can use the BoolEval function from the BoolEval package. You can load it as follows, for example:

Import["https://bitbucket.org/szhorvat/booleval/raw/8e1eaf980500b5ff066b2b4bf3a61c1ad2e9c02d/BoolEval.m"]

Here is a function based on that:

ClearAll[getSplitPositions];
SetAttributes[getSplitPositions, HoldRest];
getSplitPositions[list_, crit_] :=
  With[{pos = Sort@Pick[Range[Length[list]], BoolEval[ crit], 1]},
    If[pos === {}, Return[{}]];
    Internal`PartitionRagged[
      pos,
      Composition[
        Append[#, Length[pos] - Total[#]] &,
        Differences,
        Prepend[0],
        Flatten,
        #["NonzeroPositions"] &,
        SparseArray,
        Unitize,
        Differences@# - 1 &
      ] @ pos
    ]
  ];

It does reproduce you desired output:

list = {1, 2, 4, 6, 2, 3, 4, 5, 7, 9, 1, 3, 4, 1};
getSplitPositions[list, list > 2]

(* {{3, 4}, {6, 7, 8, 9, 10}, {12, 13}} *)

And it can handle a list of million numbers in a fraction of a second:

lrgTest = RandomInteger[{1, 1000}, 1000000];
getSplitPositions[lrgTest, 250 < lrgTest < 300] // Length // AbsoluteTiming

(* {0.178297, 46292} *)

It does, however, have an issue - it unpacks, presumably due to certain subtleties of the BoolEval implementation. Here is a version of BoolEval that won't unpack:

ClearAll[BoolEval];
SetAttributes[BoolEval, HoldAll];
BoolEval[condition_] := 
  Replace[
    Unevaluated[condition], 
    BoolEval`Private`rules, 
    {0, Infinity}, 
    Heads -> True
  ]

In this particular case, the speed is the same, but the memory use should probably be better with this version.

Answer 2

list = {1, 2, 4, 6, 2, 3, 4, 5, 7, 9, 1, 3, 4, 1};

TakeList[
 First /@ SequencePosition[list, {x_ /; x > 2}],
 Length /@ SequenceSplit[list, {x_ /; x <= 2}]]

{{3, 4}, {6, 7, 8, 9, 10}, {12, 13}}

TakeList[
 First /@ SequencePosition[list, {x_ /; x > 4}],
 Length /@ SequenceSplit[list, {x_ /; x <= 4}]]

{{4}, {8, 9, 10}}

Answer 3

Using PositionIndex:

Clear["Global`*"];
x = {1, 2, 4, 6, 2, 3, 4, 5, 7, 9, 1, 3, 4, 1};
PositionIndex[x] // KeySelect[# > 2 &] // Values // Flatten // Union //
  Split[#, #2 - #1 == 1 &] &

{{3, 4}, {6, 7, 8, 9, 10}, {12, 13}}

Answer 4

Using SequenceCases and defining a ConsecutiveQ function:

ConsecutiveQ[list_List] := MatchQ[list, Range[Min[list], Max[list]]]

l = {1, 2, 4, 6, 2, 3, 4, 5, 7, 9, 1, 3, 4, 1};

SequenceCases[Flatten@Position[l, n_ /; n > 2], {__}?ConsecutiveQ]

(*{{3, 4}, {6, 7, 8, 9, 10}, {12, 13}}*)

Answer 5

Clear[g]
g[list_, limit_] := Module[{l, l2},
  l = (list - limit);
  l2 = Unitize[l] UnitStep[l] Range[Length[list]];
  Split[l2, #1 != 0 && #2 != 0 &] /. {0} -> Sequence[]];

g[x, 2]
(*{{3, 4}, {6, 7, 8, 9, 10}, {12, 13}}*)

Testing it with Leonid Shifrin (with only one limit):

g[lrgTest, 250] // Length // AbsoluteTiming
(*{1.25263, 187504}*)

Answer 6

list = {1, 2, 4, 6, 2, 3, 4, 5, 7, 9, 1, 3, 4, 1};

Using FindRanges by an Pöschko (Wolfram Research)

FindRanges = ResourceFunction["FindRanges"];

Range @@@ FindRanges[Flatten @ Position[list, x_ /; x > 2]]

{{3, 4}, {6, 7, 8, 9, 10}, {12, 13}}

Answer 7

x = {1, 2, 4, 6, 2, 3, 4, 5, 7, 9, 1, 3, 4, 1};
y = Flatten[Position[x, _?(# > 2 &)]];
z = SplitBy[
    Differences[y], # > 1 &] /. {a : {1, ___} :> 
     Total[a], {_?(# > 1 &)} :> Nothing};
FoldPairList[TakeDrop, y, z + 1]

-> {{3, 4}, {6, 7, 8, 9, 10}, {12, 13}}