# Subsequences with distinct values

(this question was modified after initial answers)

For a sequence

x = {6,4,2,4,2,4,6}

y = Subsequences[x]


gives the list of all subsequences, I would like to find the subset m of these subsequences which have distinct values, where each subsequence is composed of consecutive values in x. Or at most z repeat values.

subset m of subsequences of x with distinct values:

6
6,4
6,4,2
4
4,2
2
2,4
2,4,6
4,6


How can I remove the subsequences with duplicate values?

Is it possible to give the starting list position in x for each of the m?

• try z = 1; Select[EqualTo[z]@*Max@*Counts]@y?
– kglr
Oct 6, 2022 at 12:34
• Should 4,6 be part of your subsequence? If so then just add DeleteDuplicates to @kglr 's code ie DeleteDuplicates@*Select[EqualTo[z]@*Max@*Counts]@y Oct 6, 2022 at 12:50
• Yes thanks I added 4,6 Oct 6, 2022 at 12:53
• Is there a way to calculate this without using Subsequence[]? For larger sequences, my PC can't calculate this Oct 6, 2022 at 13:06
• if z=2 is this the desired output ? {{6}, {6, 4}, {6, 4, 2}, {6, 4, 2, 4}, {6, 4, 2, 4, 2}, {4}, {4, 2}, {4, 2, 4}, {4, 2, 4, 2}, {2}, {2, 4}, {2, 4, 2}, {2, 4, 2, 4}, {2, 4, 2, 4, 6}, {4, 2, 4, 6}, {2, 4, 6}, {4, 6}} Oct 6, 2022 at 15:26

This is an iterative approach:

(*input*)
x = {6, 4, 2, 4, 2, 4, 6};
z = 2;

$$sizeOfSetX = Length[x];$$subsetM = {};

Do[
maximumSubsequenceLength = $sizeOfSetX - startOfSubsequence + 1; Do[ endOfSubsequence = startOfSubsequence + lengthOfSubsequence - 1; candidateSubsequence = x[[startOfSubsequence ;; endOfSubsequence]]; (* check constraint of max repeated values*) If[ Count[candidateSubsequence, x[[endOfSubsequence]]] > z , Break[] ]; (* check constraint of uniqueness*) If[ Not@MemberQ[$$subsetM, candidateSubsequence] , AppendTo[$$subsetM, candidateSubsequence] ] , {lengthOfSubsequence, maximumSubsequenceLength} ] , {startOfSubsequence,$sizeOfSetX}
];

$subsetM (*{{6}, {6, 4}, {6, 4, 2}, {6, 4, 2, 4}, {6, 4, 2, 4, 2}, {4}, {4, 2}, {4, 2, 4}, {4, 2, 4, 2}, {2}, {2, 4}, {2, 4, 2}, {2, 4, 2, 4}, {2, 4, 2, 4, 6}, {4, 2, 4, 6}, {2, 4, 6}, {4, 6}}*)  • I was hoping I could Compile this but am struggling. I suspect it is because $subsetM is a list of lists of differing lengths. Would be very appreciative if anyone could post a compiled answer. Oct 6, 2022 at 17:31
• I think there are sequences missing, namely: {4, 2, 4, 2, 4}, {4, 2, 4, 2, 4, 6}, {6, 4, 2, 4, 2, 4}, {6, 4, 2, 4, 2, 4, 6} Oct 6, 2022 at 18:51
• @DanielHuber, the missing sequences you highlight violate the constraint of z=2, ie at most 2 repeated values Oct 6, 2022 at 19:06
x = {6, 4, 2, 4, 2, 4, 6};
subs = Subsequences[Union[x]]

{{}, {2}, {4}, {6}, {2, 4}, {4, 6}, {2, 4, 6}}


You can remove the empty set by selecting the nonempty elements

Select[subs, # != {} &]

• That isn't quite what I was trying to find, I'd like to find subsequences that exist as consecutive values in x. I edited the question to indicate this. Oct 6, 2022 at 12:31
x = {6, 4, 2, 4, 2, 4, 6}


uniqueElemsQ is a helper function that returns True if all list elements are distinct.

uniqueElemsQ[k_List] := Not@(Union[(Last /@ Tally[k])] != {1})


The ReplaceList command generates all consecutive non-empty sublists.

Select[ReplaceList[x, {___, a__, ___} :> {a}],
uniqueElemsQ] // DeleteDuplicates


{{6}, {6, 4}, {6, 4, 2}, {4}, {4, 2}, {2}, {2, 4}, {2, 4, 6}, {4, 6}}

• Does this only work for the case z=1 ? Oct 6, 2022 at 14:29
• Yes, when there are no duplicates in the list.
– Syed
Oct 6, 2022 at 14:31
• Hi Syed, I think your uniqueElemsQ is the same as DuplicateFreeQ. Oct 7, 2022 at 3:21
• I was on my to making something more based on Tally but then I realized that the problem was more complicated.
– Syed
Oct 7, 2022 at 4:19
Subsequences[x]//Select[DuplicateFreeQ]//Union


Also, SequencePosition will give you the location of a subsequence.

Yet another solution:

subseqs[x_,z_]:=Flatten[Rest[FoldWhileList[Select[
DeleteDuplicates[Subsequences[x,{#2}]],
(Max[Values[Counts[#]]]<=z)&]&,0,Range[Length[x]],(#=!={})&]],1];


Example:

subseqs[{6,4,2,4,2,4,6},2]
(* {{6},{4},{2},
{6,4},{4,2},{2,4},{4,6},
{6,4,2},{4,2,4},{2,4,2},{2,4,6},
{6,4,2,4},{4,2,4,2},{2,4,2,4},{4,2,4,6},
{6,4,2,4,2},{2,4,2,4,6}} *)


Note. The goal was to be somewhat efficient in the case when x is a long list, but contains only a small number of distinct elements. This situation was mentioned by OP in a previous version of the question. An artificial example is:

SeedRandom;
x=RandomChoice[Range,1000000];

AbsoluteTiming[Length[subseqs[x,1]]]
{9.8393, 1956}

AbsoluteTiming[Length[subseqs[x,2]]]
{52.5905, 622610}


For comparison, the current version of the currently accepted answer takes 45 seconds in the first case on my machine, and $$>360$$ seconds in the second case.

• (+1) For your solution. Oct 7, 2022 at 2:05
• Nice answer and some things to learn for me: I have not seen FoldWhileList or =!= before. Oct 11, 2022 at 8:51