Counting consecutive units in nested lists

Question

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?

Answer 1

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}

Answer 2

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}

Answer 3

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

Answer 4

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}}

Answer 5

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.}