# Counting consecutive units in nested lists

I have nested lists which consist of a series of 1s followed by a series of 0s.

p = Table[PerfectNumber[n], {n, 5}];
i = IntegerDigits[p, 2]


which results in:

{{1, 1, 0}, {1, 1, 1, 0, 0}, {1, 1, 1, 1, 1, 0, 0, 0, 0}, {1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0}, {1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}

Now I want a list which gives me the maximum number of consecutive 1s in each of the lists (yes, I realize that in the given example they're all consecutive, but I'm interested in a more generic solution):

{2, 3, 5, 7, 13}

How can I achieve this?

Using LongestCommonSubsequence

(* borrowing eldo's list *)

list =
{{1, 1, 2, 1},
{1, 1, 1, 0, 3, 1},
{4, 1, 1, 1, 1, 1, 0, 1, 1}};

Length@LongestCommonSubsequence[#, Cases[1]@#] & /@ list


{2, 3, 5}

list =
{{1, 1, 0}, {1, 1, 1, 0, 0}, {1, 1, 1, 1, 1, 0, 0, 0, 0}, {1, 1, 1,
1, 1, 1, 1, 0, 0, 0, 0, 0, 0}, {1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}};

Count[1] /@ list


{2, 3, 5, 7, 13}

To answer the appended question: Maximum number of consecutive 1s in each of the lists

list =
{{1, 1, 0, 1},
{1, 1, 1, 0, 0, 1},
{0, 1, 1, 1, 1, 1, 0, 1, 1}};

ones = SequenceSplit[#, {0}] & /@ list


{{{1, 1}, {1}}, {{1, 1, 1}, {1}}, {{1, 1, 1, 1, 1}, {1, 1}}}

Max /@ Map[Length, ones, {2}]


{2, 3, 5}

A more general solution using Except

list =
{{1, 1, 2, 1},
{1, 1, 1, 0, 3, 1},
{4, 1, 1, 1, 1, 1, 0, 1, 1}};

  Max /@ Map[Length, SequenceSplit[#, {Except[1]}] & /@ list, {2}]


{2, 3, 5}

– eldo
Commented May 18 at 6:26

You could also split on the 1-sequences:

Max[SequenceSplit[#, ones : {1 ..} :> Length[ones]]] & /@ list


Or SequenceCases:

Max[SequenceCases[#, ones : {1 ..} :> Length[ones]]] & /@ list


Or use a reducing pattern:

GroupBy[Split[#], First -> Length, Max][1] & /@ list

Max /@ Total[(Split /@ lst), {3}]

(* {2, 3, 5, 7, 13} *)

lst = {{1, 1, 0}, {1, 1, 1, 0, 0}, {1, 1, 1, 1, 1, 0, 0, 0, 0, 1,
1}, {1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0}, {1, 1, 1, 1, 1, 1, 1,
1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1,
1}}


If we look at your problem in a simplistic manner, we could see a function that increments by receiving 1 and resets by receiving 0 (like multiplying but with an increment). Since we need the result of the previous calculation the Fold family should come to mind:

p = Table[PerfectNumber[n], {n, 5}];
i = IntegerDigits[p, 2];

Function[x, Max[FoldList[(#1 + 1) * #2 &, x]]] /@ i

(* Out: {2, 3, 5, 7, 13} *)


If we enlarge the input, we could compare different solutions. Here we'll create 1000 lists of zeros and ones with variable lengths:

SeedRandom[4567];
i = Table[RandomInteger[1, RandomInteger[{10, 100}]], 1000];

(* Verifying each list has at least one 1 - some algorithm fail in the absence *)
Min[Total /@ i]
(* Out: 3 *)

Repeated Timing Max Memory Usage
FoldList[ ... 0.038378 66472
vindobona's Length[ LongestCommonSubsequence[ ... 0.018285 69088
user1066's Max /@ Total[ .... 0.046171 2110792
lericr's Max[ SequenceSplit[ ... 4.27892 279952
lericr's Max[ SequenceCases[ ... 4.553 350896
lericr's GroupBy[ Split[ ... 0.022229 70200
eldo's Max /@ Map[ ... 0.217163 3346872

All produce the same result.

Since we are using primitive operations, one would be tempted to see the possibilities of the new compiler (Version 12.0+ is required):

fn = FunctionCompile[
Function[Typed[x, "NumericArray"::["Integer64", 1]],
Max@FoldList[(#1 + 1)*#2 &, x]]];

fn /@ i; // MaxMemoryUsed // RepeatedTiming

(* Out: {0.00088907, 66240} *)


It's around 20 times faster than the previous fastest solution!

Benchmark was done on Mathematica 14.0.0 on Windows 11.