2
$\begingroup$

(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?

$\endgroup$
6
  • 1
    $\begingroup$ try z = 1; Select[EqualTo[z]@*Max@*Counts]@y? $\endgroup$
    – kglr
    Oct 6, 2022 at 12:34
  • $\begingroup$ 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 $\endgroup$ Oct 6, 2022 at 12:50
  • $\begingroup$ Yes thanks I added 4,6 $\endgroup$
    – Jamie M
    Oct 6, 2022 at 12:53
  • $\begingroup$ Is there a way to calculate this without using Subsequence[]? For larger sequences, my PC can't calculate this $\endgroup$
    – Jamie M
    Oct 6, 2022 at 13:06
  • 1
    $\begingroup$ 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}} $\endgroup$ Oct 6, 2022 at 15:26

5 Answers 5

2
$\begingroup$

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}}*)
$\endgroup$
3
  • $\begingroup$ 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. $\endgroup$ Oct 6, 2022 at 17:31
  • $\begingroup$ 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} $\endgroup$ Oct 6, 2022 at 18:51
  • $\begingroup$ @DanielHuber, the missing sequences you highlight violate the constraint of z=2, ie at most 2 repeated values $\endgroup$ Oct 6, 2022 at 19:06
3
$\begingroup$
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, # != {} &]
$\endgroup$
1
  • $\begingroup$ 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. $\endgroup$
    – Jamie M
    Oct 6, 2022 at 12:31
3
$\begingroup$
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}}

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

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

$\endgroup$
2
$\begingroup$

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[1];
x=RandomChoice[Range[6],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.

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

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.