Is there a way to search for Arithmetic Progressions in a list?

Question

If you have a list of integers is there a way of searching that list to see if there is a trend of Ax+B in the list? Not using all of the numbers, just seeing what trends like that are embedded in a list.

Such as with data={2, 4, 6, 8, 10, 11, 12, 14, 16, 18,19, 20, 22, 24} there is the arithmetically increasing sequence of 2x+0 but there is also elements in the list that do not fit into the sequence. That is what i meant by "Not using all the numbers"

Answer 1

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.

Answer 2

This will kludge it up:

c = Cases[{#, Chop@FindFit[#, a x + b, {a, b}, x]} & /@ 
    Subsets[data, {4, Length@data}], {_, {a -> aa_, b -> bb_}} /; 
    FractionalPart[Round[aa, .0001]] == 0 && 
     FractionalPart[Round[bb, .0001]] == 0];
Last@SortBy[c, Length]

(* {{2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24}, {a -> 2., b -> 0}} *)

It's no sure-fire mechanism, but it's reasonably quick. Fiddle with parameters (subset size limits, rounding) to tune specificity.