Find and number sublists

I implemented the following routine.

array1 = {12, -12, 14, 12, 1, -3, 1, 1, 2, 7, 8, 102, 2, 3, 3, 1, 332,
11, 23, 2, -2, 13, 12, 1, 1, 1, 1, 1, 1, -121, 131};


I want to find sublists which consist of consecutive numbers which absolute values are smaller than a certain treshold (Lim=5). I also want to have a parameter for the length of the sublists (Len=3).

Module[{Ar, Pos, Lim, Len},
Ar = #;
Lim = 5;
Len = 3;
Position[Ar, x_ /; Abs[x] < Lim] // Flatten[#] & // Set[Pos, #] &;
Select[Split[Pos, #2 - #1 == 1 &], Length[#] > Len &]
] &[array1] // Set[PosInt, #] &;


Now I have the positions of the sublists.

PosInt // Print;
{{5,6,7,8,9},{13,14,15,16},{24,25,26,27,28,29}}


The next thing I would like to have is an array which includes the number and the position of the sublists. I have the following solution.

array2 = ConstantArray[0, Length@array1];
Module[{IntNum, Num, Pos},
Pos = #;
MapIndexed[(
IntNum = First@#2;
Num = #1;
Map[(array2[[#]] = IntNum
) &, Num];
) &, Pos]
] &[PosInt];


The desired result is saved as array2.

array2 // Print;
{0,0,0,0,1,1,1,1,1,0,0,0,2,2,2,2,0,0,0,0,0,0,0,3,3,3,3,3,3,0,0}


My implementation yields the right result. Nevertheless I'm sure it is possible to find a more elegant solution. Do you have any suggestions?

• Are you aware that in Mathematica expression standing by itself on a line at top-level is essentially the same as expression // Print;? Commented Jan 14, 2019 at 8:12
• @m_goldberg Thx for your comment. You are right, that's superfluous.
– RMMA
Commented Jan 14, 2019 at 8:18
• But the first position smaller than 5 is for -12 which is 2 right then why it starts with 5 in the position list {5,6,7,8,9} Commented Jan 14, 2019 at 9:32
• @Hubble07 Thank you! The absolute Number Abs[] has to be smaller. I did edit the question.
– RMMA
Commented Jan 14, 2019 at 9:40
• One more doubt. What about position 20 and 21. I mean what if the after taking absolute value we get two same numbers. Commented Jan 14, 2019 at 9:45

Here is the CompiledFunction that I use; It goes linearly through the list and collects starting and ending index of each run in a InternalBag.

cf = Compile[{{a, _Integer, 1}, {Lim, _Integer}, {Len, _Integer}},
Block[{c, bag, x, α},
α = 0;
c = 0;
bag = InternalBag[Most[{0}]];
Do[
x = CompileGetElement[a, i];
If[Abs[x] < Lim,
If[c == 0, α = i;];
c++;
,
If[c > Len,
InternalStuffBag[bag, α];
InternalStuffBag[bag, i - 1];
];
c = 0;
],
{i, 1, Length[a]}];
Partition[InternalBagPart[bag, All], 2]
],
CompilationTarget -> "C",
RuntimeOptions -> "Speed"
];


Here is your method in a (IMHO) more legible form:

f = {a, Lim, Len} \[Function] Select[
Split[Flatten[Position[a, x_ /; Abs[x] < Lim]], #2 - #1 == 1 &],
Length[#] > Len &
];


Let's create a large array of pseudorandom integers and run the two functions on it:

a = RandomInteger[{-10, 10}, {1000000}];

PosInt = f[a, Lim, Len]; // AbsoluteTiming // First
PosInt2 = cf[a, Lim, Len]; // RepeatedTiming // First


The output of cf is slightly different from that of f; it returns only the first and last position index of each desired sublist. So we can compare the results in either of the two follwoing ways:

PosInt[[All, {1, -1}]] == PosInt2
PosInt == Range @@@ PosInt2


True

True

• Thank you for your answer. Until now I didn't use CompiledFunction at all. Maybe I should start using, your impelementation of AppendTo is very useful as well.
– RMMA
Commented Jan 14, 2019 at 13:05
• You're welcome. Commented Jan 14, 2019 at 13:35

The question is a good exercise to employ some of the newer functions.

list =
{12, -12, 14, 12, 1, -3, 1, 1, 2, 7, 8, 102, 2, 3, 3, 1, 332, 11,
23, 2, -2, 13, 12, 1, 1, 1, 1, 1, 1, -121, 131};

lim = 5;
len = 3;


The 2 following sequence-functions give a rather short solution of the problem, but get very slow with long lists. As a rule of thumb: I don't use them for lists with more than 1000 elements.

Using SequenceSplit to get runs of integers smaller than lim:

split = SequenceSplit[list, {a_} /; Abs[a] > lim]


{{1, -3, 1, 1, 2}, {2, 3, 3, 1}, {2, -2}, {1, 1, 1, 1, 1, 1}}

Using SequencePosition to get first and last positions of the runs:

pos =
Cases[{a_, b_} /; b - a >= len - 1] @
Map[Splice @ SequencePosition[list, #] &, split]


{{5, 9}, {13, 16}, {24, 29}}

Span and index the positions:

span = MapIndexed[{#2[[1]], #1} &] @ MapApply[Span] @ pos


{{1, 5 ;; 9}, {2, 13 ;; 16}, {3, 24 ;; 29}}

Using Fold and ReplaceAt to get the desired result:

Fold[
ReplaceAt[_ :> #2[[1]], #2[[2]]] @ #1 &,
Table[0, Length @ list],
span]


{0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0, 2, 2, 2, 2, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 0, 0}

• It is a superlative application and a tutorial for these functions.
– Syed
Commented Jan 30 at 2:58
Clear["Global*"];
array1 = {12, -12, 14, 12, 1, -3, 1, 1, 2, 7, 8, 102, 2, 3, 3, 1, 332,
11, 23, 2, -2, 13, 12, 1, 1, 1, 1, 1, 1, -121, 131};

lim = 5;
len = 3;

t = (Abs@#) < lim & /@ array1 // Boole //
SequenceReplace[#,
k : {0, Repeated[1, {1, len}], 0} :>
Sequence @@ Table[0, Length@k]] &;

(Split[t] // Map[First] // Accumulate) Split[t] // Flatten


{0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0, 2, 2, 2, 2, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 0, 0}

l1 = {12, -12, 14, 12, 1, -3, 1, 1, 2, 7, 8, 102, 2, 3, 3, 1,
332, 11, 23, 2, -2, 13, 12, 1, 1, 1, 1, 1, 1, -121, 131};

t = 5;

le = 3;


Using SplitBy and Select:

l2 = Thread[Range@Length@# -> #] &@l1;

conds = Length@# > le - 1 && And @@ Thread[#[[{1, -1}, 2]] < t] &;

sp = Select[SplitBy[l2, Abs[#[[2]]] < t &], conds];


We obtain the first and last positions of the sublists as follows:

pos = #[[{1, -1}, 1]] & /@ sp

(*{{5, 9}, {13, 16}, {24, 29}}*)


Using Range and index the positions:

rule = Splice@Thread[#1 -> ConstantArray[#2[[1]], Length@#1]] &;

rep = MapIndexed[rule]@MapApply[Range]@pos;


Finally, using ReplacePart:

ReplacePart[Table[0, Length@l1], rep]
`

{0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0, 2, 2, 2, 2, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 0, 0}