# The longest run of at most k different elements in a list

I have a long list with ca. 500K elements. The list contains about 10K different elements.

For simplicity let’s assume the list is of the following form:

list={a,c,b,a,a,a,b,c,e,f,b,a,e,e,e,a}


I would like to construct a function f[k] which gives me the longest run(s) of at most k different elements. For example:

f[1]={{a,a,a},{e,e,e}},
f[2]={{b,a,a,a,b},{a,e,e,e,a}},
f[3]={{a,c,b,a,a,a,b,c}}


So far, I’ve just found this as the solution for k = 1, which give the longest run of one element. Can this solution be extended?

And also I would also like to construct a function g[n,k] which gives all runs with a length n of at most k different elements involved. For example:

g[3,2]={{b,a,a},{a,a,a},{a,a,b},{a,a,b},{b,b,a},{a,e,e},{e,e,e},{e,e,a}}
g[4,2]={{b,a,a,a},{a,a,a,b},{a,e,e,e},{e,e,e,a}}


How to construct a function h[n,k] which gives all runs with a length n involving at most k different elements, but without being part of a longer run?

I would like to answer the question: How many runs exists of length n or longer involving at most k different elements, but without multiple counting sub runs. For every element in g[n+1,k] there are 2 elements in g[n,k]. For example {{b,a,a,a},{a,a,a,b}}⊆g[4,2] are sub runs of the run {b,a,a,a,b} ∈ g[5,2].

• Would you share the code you are working one ? Besides the linked question – Sektor Jan 12 '15 at 21:42

Edit: My first implementation, using ListCorrelate, had unexpectedly poor computational complexity. Here is a second implementation of my original idea using a more basic procedural method to keep track of the counts. It performs significantly better and likely compilation would make it significantly faster still. It shall have to stand for now until I have more time.

g2[list_, n_, k_] :=
Module[{x, a, c},
x = ArrayComponents[list, 1, 0 -> 1];
a = ConstantArray[0, Max@x];
Do[a[[ x[[p]] ]]++, {p, n}];
c = {Tr @ UnitStep[a - 1]} ~Join~
Table[
a[[ x[[p]] ]]--; a[[ x[[p + n]] ]]++; Tr @ UnitStep[a - 1],
{p, Length@x - n - 1}
];
list[[# ;; # + n - 1]] & /@ Join @@ Position[UnitStep[k - c], 1]
]


My first idea is to try to avoid checking each and every partition of length n, especially if n may be large. To that end I would make sure that list elements are non-numeric and then use a sliding sum to tally values. Here is an implementation of g following this idea.

g[list_, n_, k_] :=
Module[{x = ToString /@ list},
x = ListCorrelate[ConstantArray[1, n], x];
x = Replace[x, {p_Plus :> Length[p], _ -> 1}, {1}];
x = Join @@ Position[UnitStep[k - x], 1];
list[[# ;; # + n - 1]] & /@ x
]

list = {a, c, b, a, a, a, b, c, e, f, b, a, e, e, e, a};

g[list, 4, 2]

{{b, a, a, a}, {a, a, a, b}, {a, e, e, e}, {e, e, e, a}}

g[list, 5, 2]

{{b, a, a, a, b}, {a, e, e, e, a}}

g[list, 3, 1]

{{a, a, a}, {e, e, e}}


Note: Position is used in the code above. In version 10 this is adequately fast. In earlier versions, e.g. 7, for maximum performance it may be preferable to replace that line with:

x = Join @@ SparseArray[UnitStep[k - x]]["NonzeroPositions"];

• +1 nice one. instead of x = Join @@ SparseArray[UnitStep[k - x]]["NonzeroPositions"] why not just x=Flatten@Position[x, k]? Is it due to possible slowness of Position for 500K list? – Mike Honeychurch Jan 12 '15 at 22:59
• @Mike Thanks. First, it is "at most k different elements" so we either need a UnitStep or >= etc., and second I am still in the habit of using "NonzeroPositions" for speed; it may be that in v10 Position would be as or nearly as fast. – Mr.Wizard Jan 13 '15 at 11:38
• @Mr.Wizard Thanks a lot for your help. Your solution is really fast. How can it be modified to get the runs with a length n involving at most k different elements, but without being part of a longer run. I would like to exclude the overlappings. For example {{b,a,a,a},{a,a,a,b}} is an element of g[4,2], but are sub runs of the run {b,a,a,a,b} element of g[5,2]. The runs should not appear if they are part of a longer run. – stat_facts Jan 13 '15 at 17:08
• @stat_facts I'll think about it, and if I have time I shall revisit this question. I warn you now that I am often distracted by a newer problem and forget to return. Since your question is not yet fully answered you may wish to lift the Accept, as that may encourage more answers. Also be sure to try kguler's simpler code as it may be faster on your working set. – Mr.Wizard Jan 13 '15 at 18:57
• @Mr.Wizard Your first function g is actually faster than the solution of kguler. – stat_facts Jan 13 '15 at 19:25

brute force..

 getmax[list_, n_] := Module[{i,p={},lp},
i = n;
While[lp = p; Length[p = Select[ Partition[list, i, 1] ,
Length[Union[#]] <= n  &  ]] > 0 , ++i]; lp ];
list = {a, c, b, a, a, a, b, c, e, f, b, a, e, e, e, a}
getmax[list, 2]


{{b, a, a, a, b}, {a, e, e, e, a}}

 list = RandomChoice[Range[10000], 500000];

getmax[list, 3]

{{229, 5652, 4858, 5652}, {5652, 4858, 5652, 6371}, {9287, 6906, 1022, 9287}, ...


If your list is not random and actually has long runs this is really going to bog down though.

Note is speeds it up a good bit to select only the first match:

  Select[ Partition[list, i, 1] , Length[Union[#]] <= n  & , 1 ]


## edit faster version

an example of the requested size with a long run burried in the middle:

 list = RandomChoice[Range[10000], 250000] ~Join~
RandomChoice[Range[10], 500]~Join~
RandomChoice[Range[10000], 250000];
getmax[list_, n_] := Module[{ipos= Range[Length[list]], i=n, last},
While[ Length@ipos > 0 ,
last = {i, ipos};
ipos = Select[ ipos , (# + i <
Length[list] &&  (Length[Union[ list[[ # ;; # + i ]] ]] <=
n) ) & ]; ++i  ];
list[[last[[-1, 1]] ;; last[[-1, 1]] + last[[1]] - 1]] ]
getmax[list, 10] // Timing


{6.505242, {8, 4, 9, 2, 4, 9, 2, 5, 1, 8, 7, 7, 3, 1, 2, 9, 4, 2, 4, 7, 5, 3, 8, 10, 4, 5, 7, 4, 5, 3, 6, 1, 4, 5, 7, 6, 5, 5, 8, 8, 9, 4, 10, 10, 10, 2, 3, 10, 9, 6, 6, 7, 3, 5, 5, 2, 7, 9, 1, 1, 10, 7, 7, 8, 10, 5, 7, 4, 1, 1, 7, 9, 9, 9, 1 ... (* 500 elements *)

Pattern-based (also brute force)

f[k_] := MaximalBy[ReplaceList[list, {___, x__ /; CountDistinct@{x} <= k, ___} :> {x}],
Length]

f[1]
(* {{a, a, a}, {e, e, e}} *)

f[2]
(* {{b, a, a, a, b}, {a, e, e, e, a}} *)

f[3]
(* {{a, c, b, a, a, a, b, c}} *)


A more intelligent approach (take while the number of distinct elements is not greater then k starting from each element)

f[k_] := MaximalBy[Table[Module[{x = {}},
TakeWhile[list[[i ;;]], (x = x ⋃ {#}; Length@x <= k) &]], {i, Length@list}], Length]

f[1]
(* {{a, a, a}, {e, e, e}} *)

f[2]
(* {{b, a, a, a, b}, {a, e, e, e, a}} *)

f[3]
(* {{a, c, b, a, a, a, b, c}} *)

ClearAll[f1]
f1[lst_, n_, k_] := DeveloperPartitionMap[If[CountDistinct@# <= k, #, ##&[]]&, lst, n, 1]


Examples:

list = {a, c, b, a, a, a, b, c, e, f, b, a, e, e, e, a};

f1[list,4,2]
(* {{b,a,a,a}, {a,a,a,b}, {a,e,e,e}, {e,e,e,a}} *)

f1[list,3,1]
(* {{a,a,a}, {e,e,e}} *)

f1[list,5,2]
(* {{b,a,a,a,b}, {a,e,e,e,a}} *)

• This does not behave as I expected. Edit: Yes, this seems to have better computational complexity than my method relative to n, therefore my premise appears to have been misguided. Note: you probably want CountDistinct@# <= k. – Mr.Wizard Jan 13 '15 at 14:00
• My method seems to be faster up to about n = 25, yours gains an increasing advantage. That's rather disappointing for me as I specifically thought my method would have better performance with large n. – Mr.Wizard Jan 13 '15 at 14:12
• @Mr.Wizard, I haven't attempted to do any timing experiments (cannot do much on the free cloud version without exceeding session limits)... but I did not expect this to perform better than your method. – kglr Jan 13 '15 at 16:34
• There were poor assumptions on my part regarding the performance of symbolic manipulation. And I made another poor choice in light of the OP's "10K different elements" as my g2 will not work well there I fear. But I have no more time for this right now. – Mr.Wizard Jan 13 '15 at 16:45

This solution (in Java, you could translate it) runs in O(N.M), where N is the size of the input and M is the length of the longest contiguous sequence with at most k unique characters. The time complexity does not depend directly on k.

public class MaxRun {

public static class Run {
HashSet<String> uniqueItems = new HashSet<>();
int startIdx;
Run next;

public Run(String item, int startIdx, Run next) {
this.startIdx = startIdx;
this.next = next;
}
}

public static void main(String[] args) {
String itemStr = "a,c,b,a,a,a,b,c,e,f,b,a,e,e,e,a";
String[] items = itemStr.split(",");
int k = 3;

int longestRunLen = 0;
ArrayList<Run> longestRuns = new ArrayList<>();
for (int i = 0; i < items.length; i++) {
String item = items[i];
for (Run curr = head, prev = null; curr != null;) {
int runLen = i - curr.startIdx + 1;
boolean addCurr = i == items.length - 1;
if (curr.uniqueItems.size() > k) {
curr.uniqueItems.remove(item);
runLen--;
}
if (runLen > longestRunLen) {
longestRuns.clear();
longestRunLen = runLen;
}
if (runLen == longestRunLen) {
}
prev = null;
} else {
prev.next = curr.next;
}
Run removed = curr;
curr = curr.next;
removed.next = null;
} else {
prev = curr;
curr = curr.next;
}
}
}

// Remove duplicate run sequences
HashSet<String> uniqueRuns = new HashSet<>();
for (Run longestRun : longestRuns) {
StringBuilder buf = new StringBuilder();
for (int i = longestRun.startIdx, i2 = i + longestRunLen; i < i2; i++) {
buf.append((buf.length() == 0 ? "" : ",") + items[i]);
}
}

System.out.println("Longest run" + (uniqueRuns.size() == 1 ? "" : "s")
+ " containing no more than " + k
+ " different character" + (k == 1 ? "" : "s") + ":");
for (String uniqueRun : uniqueRuns) {
System.out.println("  " + uniqueRun);
}
}
}
`
• Luke, since this is not Mathematica code, and since not all of us are fluent in Java, it would be helpful if you would give written description of the algorithm you propose. Otherwise I fear this answer is only marginally on-topic. – Mr.Wizard Jan 14 '15 at 10:11

I have an algorithm that should work for $f$, but I don't have access to Mathematica right now, so you'll have to settle for a description of how it would work.

Other than the greatest run-length and where those runs are, you need to keep track of three things: Where the current run begins, where it ends, and a list (or association if that would work better) of the unique elements the run is composed of, and where the last of each of those elements are in the run.

Initially, you start with a en empty run starting at the beginning of the list.
Advance the end of the run, populating and updating the list of elements as you go, until it contains exactly $n$ elements (or you run out of list).

From here you start a loop. Advance the end of the run while updating the list of elements until you encounter an element not in the list.
At this point you check whether the current run is as long as the recorded maximal length (or more) and keep records accordingly.
Regardless, choose from list of elements the one who has the first occurring last element. (probably just by a minimum).
Advance the beginning of the run to after that last element and discard the element from the list.
Add the element that you just encountered to take it's place and repeat until you run out of list.

For simplicities sake you only need to record the maximal length and where the runs begin, but others have already gone through that.

Hopefully, someone who can actually run Mathematica can find the best implementation of this (or any at all).