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

Question

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

Answer 1

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"];

Answer 2

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 *)

Answer 3

ClearAll[f1]
f1[lst_, n_, k_] := Developer`PartitionMap[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}} *)

Answer 4

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

Answer 5

My attempt using Table and Select:

g[list_, n_, k_] := Module[{sublists, validRuns}, 
sublists = Table[list[[i ;; i + n - 1]], {i, 1, Length[list] - n + 1}];
validRuns = Select[sublists, Length[Union[#]] <= k &];
validRuns]

Testing g:

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

g[list, 4, 2] // AbsoluteTiming

(*{0.0001359, {{b, a, a, a}, {a, a, a, b}, {a, e, e, e}, {e, e, e, a}}}*)

Taking a huge list of data as @george2079 did, we can compare this proposal with @Mr.Wizard's proposal:

list2 = RandomChoice[Range[10000], 250000]~Join~
        RandomChoice[Range[10], 500]~Join~
        RandomChoice[Range[10000], 250000];

g[list2, 4, 2] // AbsoluteTiming // First (*Mr. Wizard*)

(*3.08983*)

g[list2, 4, 2] // AbsoluteTiming // First (*E. Chan-López*)
(*1.91819*)

Answer 6

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.uniqueItems.add(item);
            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;

        Run head = null;
        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;
                curr.uniqueItems.add(item);
                if (curr.uniqueItems.size() > k) {
                    curr.uniqueItems.remove(item);
                    runLen--;
                    addCurr = true;
                }
                if (addCurr) {
                    if (runLen > longestRunLen) {
                        longestRuns.clear();
                        longestRunLen = runLen;
                    }
                    if (runLen == longestRunLen) {
                        longestRuns.add(curr);
                    }
                    if (curr == head) {
                        head = curr.next;
                        prev = null;
                    } else {
                        prev.next = curr.next;
                    }
                    Run removed = curr;
                    curr = curr.next;
                    removed.next = null;
                } else {
                    prev = curr;
                    curr = curr.next;
                }
            }
            head = new Run(item, i, head);
        }

        // 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]);
            }
            uniqueRuns.add(buf.toString());
        }

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

Answer 7

Since V 10.1 there is SequenceCases - but please don't try this with 500k elements

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

seq[dt_, {le_, cd_}] :=
 SequenceCases[dt, _?(Length[#] == le && CountDistinct[#] == cd &), Overlaps -> True]

seq[list, {4, 2}]

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

seq[list, {3, 1}]

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

seq[list, {5, 2}]

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

Answer 8

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