Given a list of integers, find the largest sum of a contiguous subsequence

Question

Given a list of integers, find the largest sum of a contiguous sub-sequence.

{1, 2, 3, 4, 5, -1, 7, -4, -2}
(* 21 *)

And print the sub-array which is {1,2,3,4,5,-1,7}.

I am getting 15.

LargestContiguousSum[numbers_List] := 
  Module[{maxcurrent = numbers[[1]], maximumglobal = numbers[[1]], i},
    For[i = 2, i < Length[numbers], i++, 
    maxcurrent = Max[numbers[[i]], maxcurrent + numbers[[i]]];
    If[maxcurrent > maximumglobal, maximumglobal = maxcurrent]];
   maximumglobal];
LargestContiguousSum[{1, 2, 3, 4, 5, -1, 7}]

Answer 1

f[l_] := Module[{sl = Flatten@MaximalBy[Subsequences[l], Total]}, {Total[sl], sl}]
f[{1, 2, 3, 4, 5, -1, 7, -4, -2}]
(* {21, {1, 2, 3, 4, 5, -1, 7}} *)

Answer 2

Here is a brute force approach modeled after your initial approach but with Do rather than For:

LargestContiguousSum[numbers_List] := Module[{n, mSum, index, sum, y, accumulate},
  n = Length[numbers];
  accumulate = Accumulate[numbers];
  mSum = Max[accumulate];
  index = 1;
  Do[sum = Max[accumulate[[i ;; n]]] - accumulate[[i - 1]];
   If[sum > mSum, mSum = sum; index = i], {i, 2, n}];
  y = accumulate[[index ;; n]] - If[index == 1, 0, accumulate[[index - 1]]];
  {Max[y], numbers[[index ;; index + Position[y, Max[y]][[1, 1]] - 1]]}]

LargestContiguousSum[{1, 2, 3, 4, 5, -1, 7, -4, -2}]
(* {21,{1,2,3,4,5,-1,7}} *)

Answer 3

Here is a fairly fast method. It uses recursion but could, with work, be made to avoid it. The complexity in worst case is probably O(n^2) due to list copying in the recursion, but again, it could be made to avoid that.

The idea is to split into three sublists. Iterate from the left end, totaling, until the total becomes negative. Do same from the right end. The max sum of consecutives is the largest of:

(i) Accumulation from the left end, up to just preceding the position where the left side sum became negative.

(ii) Accumulation from the right end, up to just following the position where the right side sum became negative.

(iii) A recursive call to handle the subsequence between just after the right sum went negative to just before where the left sum went negative.

I am fairly certain there are further efficiencies to be found, but this seems to work fairly well as it is.

largestConsecSum2[ll_] := Module[
  {len = Length[ll], hi, lo, rtot, ltot, max = 0},
  hi = len;
  rtot = ll[[hi]];
  While[rtot > 0 && hi > 1,
   hi--;
   rtot += ll[[hi]];
   ];
  lo = 1;
  ltot = ll[[lo]];
  While[ltot > 0 && lo < len,
   lo++;
   ltot += ll[[lo]];
   ];
  If[hi == 1 && lo == len,
   max = Max[Accumulate[ll]],
   If[lo > 1, 
    max = Max[Prepend[Accumulate[ll[[1 ;; lo - 1]]], max]]];
   If[hi < len, 
    max = Max[Prepend[Accumulate[ll[[len ;; hi + 1 ;; -1]]], max]]];
   If[lo < hi - 1, 
    max = Max[{max, largestConsecSum2[ll[[lo + 1 ;; hi - 1]]]}]];
   ];
  max
  ]

It seems to give the right results, or at least is in agreement with what I believe is the fastest prior answer.

In[115]:= Table[
 llbig = RandomInteger[{-100, 100}, n]; 
 t1 = Timing[ls = LargestContiguousSum[llbig]];
 t2 = Timing[ls2 = largestConsecSum3[llbig]];
 {t1[[1]], t2[[1]], t1[[2, 1]], t2[[2]]}
 ,
 {n, 2^Range[12, 14]}]

(* Out[115]= {{0.032, 0.004, 3125, 3125}, {0.06, 0.012, 6308, 
  6308}, {0.208, 0.02, 8360, 8360}} *)

I'll give some thought to removing the recursion.

--- edit ---

Here is it made nonrecursive.

largestConsecSum2[ll_] := Module[
  {len = Length[ll], hi, lo, rtot, ltot,
     max = 0, oldlo = 1, oldhi},
  oldhi = len;
  j = 0;
  While[oldlo <= oldhi, j++;
   hi = oldhi;
   rtot = ll[[hi]];
   While[rtot > 0 && hi > oldlo,
    hi--;
    rtot += ll[[hi]];
    ];
   lo = oldlo;
   ltot = ll[[lo]];
   While[ltot > 0 && lo < oldhi,
    lo++;
    ltot += ll[[lo]];
    ];
   If[hi == oldlo && lo == oldhi,
    max = Max[{max, Total[ll[[oldlo ;; oldhi]]]}];
    Break[],
    If[lo > oldlo, 
     max = Max[Prepend[Accumulate[ll[[oldlo ;; lo - 1]]], max]]];
    If[hi < oldhi, 
     max =Max[Prepend[Accumulate[ll[[oldhi ;; hi + 1 ;; -1]]], max]]];
    If[lo < hi - 1, oldlo = lo + 1; oldhi = hi - 1;
     ,(*else*)Break[]
     ];
    ];
   ];
  max
  ]

Quite fast now (as in linear time). Sometimes it's good to use pedestrian procedural code.

(* In[195]:= Table[
 llbig = RandomInteger[{-100, 100}, n];
 Timing[ls2 = largestConsecSum5[llbig]]
 ,
 {n, 2^Range[10, 18]}]

Out[195]= {{0., 1749}, {0.004, 2065}, {0.004, 5653}, {0.012, 
  4145}, {0.016, 9293}, {0.04, 15855}, {0.08, 15299}, {0.156, 
  21753}, {0.304, 32417}} *)

--- end edit ---

Answer 4

This question is analogous to a Project Euler question, where a fast method on long sequences is required. I wrote the following, which seems to use a similar idea to the answer by @Mr.Wizard.

MaxContiguousSubseqSum[u_] :=
   Block[{s, best, m, t, k = 1},
      s = Accumulate[u];
      best = {m = Max[s], k, k + FirstPosition[s, m][[1]] - 1};
      While[Length[s] > 1,
         s = Rest[s - s[[1]]];
         k += 1;
         t = {m = Max[s], k, k + FirstPosition[s, m][[1]] - 1};
         If[m > best[[1]], best = t]
      ];
      {best[[1]], Take[u, best[[{2, 3}]]]}
   ]

Note that the answer by @bbgodfrey should be modified to the following.

f1[l_] :=
   Module[{sl = Flatten[MaximalBy[Subsequences[l], Total][[1]]]},
          {Total[sl], sl}
   ]

Otherwise, it fails when there is more than one subsequence with the same total. For instance, the input sequence {41,-45,88,59,59,-9,97,0,-1,1} has 3 subsequences with the same total.

The method by @ThatGravityGuy also fails with "Options expected (instead of {3,10}) beyond position 3 in Apply[Span,{3,7},{3,8},{3,10}]. An option must be a rule or a list of rules" when more than one subsequence has the same total.

The method by @kglr works on these special cases, but gives different answers sometimes(?). For instance, test the sequence {-33,87,-43,-29,-42,-8}.

The solution by @JimB is very fast, but @DanielLichtblau takes the cake with the linear time dependence of largestConsecSum2.

The graph shows RepeatedTimings of the top 4 fastest solutions for long sequences, along with an arbitrary linear dependence. (Updated to include fn4 from Mr.Wizard).

Answer 5

Apologies if this duplicates any other answer, I didn't take time to read them all but I wanted to post this.

fn[s_] :=
  FoldList[Rest@# - #2 &, Accumulate[s], Most@s] // FirstPosition[PadLeft@#, Max@#] &

Use:

s = {1, 2, 3, 4, 5, -1, 7, -4, -2};
fn[s]
Take[s, %]

{1, 7}

{1, 2, 3, 4, 5, -1, 7}

---

Rewrite

It took me a few tries to get here, but rather than clutter this answer with incremental improvements I choose to keep only the best version. If you wish to see the development please look at the edit history.

fn4[s_] :=
  Module[{r = 0, c, f, best = {-∞}},
    f = (++r; 
      If[Max@# > best[[1]], 
       best = {#[[c = Ordering[#, -1][[1]]]], r, c + r - 1}]; #) &;
    Fold[f[Rest@# - #2] &, f @ Accumulate @ s, Most @ s];
    best
  ];

SeedRandom[0];
big = RandomInteger[{-10, 10}, 20000];

fn4[big] // AbsoluteTiming

{0.54202, {1131, 12963, 15380}}

Output is in the form {sum, start, end}

Answer 6

f = a \[Function] 
   With[{A = UpperTriangularize[Outer[Plus, Join[{0}, -Most[#]], #, 1] &[Accumulate[a]]]},
    MaximalBy[
      Flatten[MapIndexed[{x, i} \[Function] {x, i}, A, {2}], 1], 
      First
      ][[1]]
    ];

{sum, pos} = f[{1, 2, 3, 4, 5, -1, 7, -4, -2}]

{21, {1, 7}}

Answer 7

Another approach is to recognize that the process of summing sequential elements of a list is the same as taking a moving average of the data. Hence we can use MovingAverage to take all the sums:

list = {1, 2, 3, 4, 5, -1, 7, -4, -2};
n = 7;
pos = First@First@Position[c = n MovingAverage[list, n], Max[c]];
{Max[c], list[[pos ;; pos + n - 1]]}

{21, {1, 2, 3, 4, 5, -1, 7}}

ListConvolve and ListCorrelate will also do the same thing, using a kernel of ConstantArray[1,n].

Answer 8

f0[x_] := Module[{span = Span @@ MaximalBy[Subsets[Range[Length@x], {2} ], 
       Total[x[[#[[1]] ;; #[[2]]]]] &, 1][[1]]  }, {Total@#, #} &@ x[[span]]]

f0 @ list

 {21, {1, 2, 3, 4, 5, -1, 7}}

Answer 9

Thanks to @KennyColnago for pointing out that the previous code did not work for sets that have multiple subsequences that generate the same total. I think I've fixed it now, and added @KennyColnago's example of the aforementioned.

LargestContiguousSum[nums_List] := With[
    {sums = Array[Sum[nums[[k]], {k, ##}] &, Length@nums {1, 1}]},
    {Max@sums, nums[[Span @ ##]]} & @@@ Position[sums, Max@sums]
]

LargestContiguousSum@{1, 2, 3, 4, 5, -1, 7, -4, -2}

{{21, {1, 2, 3, 4, 5, -1, 7}}}

LargestContiguousSum@{-4, 1, 2, 3, 4, 5, -1, 7, -2}

{{21, {1, 2, 3, 4, 5, -1, 7}}}

LargestContiguousSum@{-4, 1, 2, 3, 4, 5, 7, -1, -2}

{{22, {1, 2, 3, 4, 5, 7}}}

LargestContiguousSum@{41, -45, 88, 59, 59, -9, 97, 0, -1, 1} (*@KennyColnago's example*)

{{294, {88, 59, 59, -9, 97}}, {294, {88, 59, 59, -9, 97, 0}}, {294, {88, 59, 59, -9, 97, 0, -1, 1}}}

Another method

Here we neglect to calculate the terms in the above sum where the initial index was greater than the final index (i.e. Cases of $\sum_j^k$ where $j > k$) because such sums result in zero from not actually summing any of the terms. Thus the sums table doesn't have these vacuous zeros, and becomes ragged, thus reducing the number of summations and elements to look at when finding the position of the maximum.

LargestContiguousSum2[nums_List] := Block[
  {sums = Table[Total@nums[[j ;; k]], {j, #}, {k, j, #}] &@Length@nums, maxsums},
  maxsums = Max@sums;
  {maxsums, nums[[Span@##]]} & @@@ Replace[Position[sums, maxsums], {a_, b_} :> {a, b + a - 1}, {-2}]
  ]

Timing Comparison

Answer 10

Refined approach

I believe I have a method that is an order of magnitude faster than previously posted code.

While working on my first answer I realized that there was a pattern to the step-by-step result when applied to random data. Illustrated here:

fnAA[s_] :=
  Module[{f, a = Accumulate@s},
    f[{_, c_}, si_] := {a[[#]], #} & @@ Ordering[a = Rest[a] - si, -1];
    FoldList[f, {Max@s, 0}, Most@s]
  ];

SeedRandom[1]
test = RandomInteger[{-9, 9}, 1500];

ListLinePlot[
  Append[fnAA[test]\[Transpose], Prepend[Accumulate@test, 0]]
  , PlotRange -> All
]

• The green line is the cumulative sum for the entire set
• the blue line is the maximum within a "row"
• the orange line is the distance to that maximum

From this I surmised that the data could be processed in blocks, separated by the saw-tooth of the orange line. Here is my attempt to realize that idea.

Code

I am only somewhat confident that I have this right, with significant chance of edge cases I forgot to address. If you find cases where this fails please let me know and I shall try to fix it.

fastSS[set_] :=
   Module[{a, fl, ap, p, q, r, sums},
     a = Accumulate@set;
     fl = FoldList[If[#2 > #, #2, #] &, Last[a] - 1, Reverse @ a];
     ap = SparseArray[Reverse @ Unitize @ Differences @ fl]["AdjacencyLists"];
     p = Differences[ap ~Prepend~ 0];
     q = Ordering[#, 1][[1]] & /@ Internal`PartitionRagged[a, p];
     If[q[[1]] == 1 && set[[1]] > 0, q[[1]]--];
     r = ap - Clip[p - q - 1, {0, ∞}];
     sums = a[[ap]] - Prepend[a, 0][[r]];
     {sums, r, ap}[[ All, Ordering[sums, -1][[1]] ]]
   ];

Performance

I shall use Daniel's largestConsecSum2 as my reference method. I shall also include fn4 from my first answer, and a modified (faster) version of Kenny Colnago's function I have named kcSum.

Needs["GeneralUtilities`"]
SeedRandom[1]

BenchmarkPlot[{largestConsecSum2, fastSS, fn4, kcSum}, RandomInteger[{-99, 99}, #] &]

SeedRandom[1]
big = RandomInteger[{-99, 99}, 1*^6];

fastSS[big]            // AbsoluteTiming
largestConsecSum2[big] // AbsoluteTiming

{0.110151, {31748, 413638, 496790}}

{1.59653, 31748}