Finding Subsequences
First off, here's the code I used to verify my solutions:
Sort@DeleteDuplicates[
Select[Select[Reverse@Subsets[data, {3, ∞}],
Equal @@ Differences[#] &], Unequal @@ # &],
SubsetQ[##] && Equal @@ Sign@*First@*Differences /@ {##} &]
- First, we get all
Subsets
of data
that are no shorter than three elements long, and reverse them so that the larger subsets come first. Since Subsets
returns sets in the same order they are in the input, this effectively finds all subsequences for us.
- Next, we
Select
the subsequences that form arithmetic sequences by checking that their first-order Differences
are all Equal
.
- We then
Select
again to discard constant subsequences by checking that the elements are Unequal
.
- Finally we eliminate subsequences that are themselves subsequences of other subsequences, checking with
SubsetQ
(and also checking that both subsequences are increasing and decreasing.)
This function has exponential time and space complexity, due to the presence of Subsets
. We can, however, create a cubic-time algorithm that gives us the same result.
First I'll define a helper function subSequenceQ
that tests to see if one range specification (second argument) is a subsequence of another (first argument):
subSequenceQ[{s1_, e1_, t1_: 1}, {s2_, e2_, t2_: 1}] := (Divisible[t2, t1] &&
(s1 <= s2 <= e2 <= e1 || s1 >= s2 >= e2 >= e1) && Divisible[s2 - s1, t1])
Next, the function itself, which returns range specifications for all the discovered subsequences. (For example, if the subsequence {5, 3, 1, -1}
exists, {5, -1, -2}
would be returned.)
arithmeticSubSequences[data_] := With[{n = Length[data]},
Module[{seq = {}, count, start, end, step},
Do[
start = data[[i]];
If[MemberQ[seq, {start, _, _}], Continue[]];
Do[
step = data[[j]] - start;
If[step == 0, Continue[]];
count = 2;
Do[If[data[[k]] == start + step count, count++], {k, j + 1, n}];
end = start + step (count - 1);
If[count > 2 && !MemberQ[seq, r:{_, _, _} /; subSequenceQ[r, {start, end, step}]],
seq~AppendTo~{start, end, step}
];,
{j, i + 1, n}
];,
{i, n}
];
seq = Reverse@SortBy[seq, Abs[Subtract @@ Most[#]/Last[#]] + 1 &];
DeleteDuplicates[seq, subSequenceQ]]
]
seq
is a list of range specifications of subsequences found so far. i
loops over each element, testing it as a potential starting point for a subsequence. If there is already a sequence starting with data[[i]]
, then we won't find any new subsequences, so we skip to the next i
.
j
loops over the remaining elements, testing each one as a potential second element of a subsequence. We use it to determine the potential sequence's step size. We then loop k
over the rest of the array to see how many more elements would be part of this sequence. If the number of elements is greater than 2, and we haven't already found a sequence that is a subsequence of, we add it to seq
.
Finally we sort the ranges by length and delete subsequences that are themselves subsequences of others.
On your dataset:
data = {2, 4, 6, 8, 10, 11, 12, 14, 16, 18, 19, 20, 22, 24};
we get the output:
arithmeticSubSequences[data]
(* {{2, 24, 2}, {18, 20, 1}, {16, 22, 3}, {14, 24, 5}, {10, 12, 1},
{8, 14, 3}, {6, 16, 5}, {4, 18, 7}, {2, 20, 9}} *)
You can see which sequences these correspond to with Grid[{#, Range @@ #} & /@ %]
:
{2,24,2} {2,4,6,8,10,12,14,16,18,20,22,24}
{18,20,1} {18,19,20}
{16,22,3} {16,19,22}
{14,24,5} {14,19,24}
{10,12,1} {10,11,12}
{8,14,3} {8,11,14}
{6,16,5} {6,11,16}
{4,18,7} {4,11,18}
{2,20,9} {2,11,20}
Finding Substrings (original answer)
(First /@ #)~Append~Last[Last[#]] & /@
Select[SplitBy[Partition[data, 2, 1], Differences], Length[#] > 1 &]
- First we
Partition
the data
into a list of pairs of adjacent elements.
- Then we
Split
the pairs into runs where the Differences
are the same.
- We
Select
runs of length more than one.
- Finally we process the resulting lists of pairs to return them as lists of numbers.
We can go faster by getting the ranges instead:
With[{len = Length /@ Split[Differences[data]]}, {#2 - #1, #2} + 1 & @@@
Pick[Transpose[{len, Accumulate[len]}], Thread[len > 1]]]
- First we find the
Differences
between adjacent elements, Split
them into runs, then get the Length
of each run
- We use
Accumulate
to get the position of the end of each run, then Pick
runs longer than one pair.
- Then we use
{#2 - #1, #2} + 1
to get the position of the first and last element in each run.
FindSequenceFunction[ ]
$\endgroup$ – Dr. belisarius Apr 9 '15 at 16:14{2, 6, 10 ... 22}
,{6, 12, 18, 24}
, etc? What about{10, 11, 12}
and{8, 11, 14}
? $\endgroup$ – 2012rcampion Apr 9 '15 at 17:51{2, 6, 10 ... 22}
appears for sure: {2, 4, 6, 8, 10, 11, 12, 14, 16, 18,19, 20, 22, 24}. In your words, "there is the arithmetically increasing sequence of [4x+2] but there is also elements in the list that do not fit into the sequence." Seems to meet the criteria to me. $\endgroup$ – 2012rcampion Apr 9 '15 at 18:10