12
$\begingroup$

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}]
$\endgroup$

10 Answers 10

16
$\begingroup$
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}} *)
$\endgroup$
  • 1
    $\begingroup$ So compact! That should be the accepted answer. $\endgroup$ – JimB Sep 30 '18 at 17:39
  • $\begingroup$ @JimB And, yours is so fast! $\endgroup$ – bbgodfrey Sep 30 '18 at 17:45
  • 7
    $\begingroup$ No way, @JimB, this has exponential computational complexity and memory requirements. For lists of length 2000, your code is more than 2000 times faster on my machine. $\endgroup$ – Henrik Schumacher Sep 30 '18 at 17:46
  • 2
    $\begingroup$ Ok. I give up. But the code looks so elegant! $\endgroup$ – JimB Sep 30 '18 at 18:38
  • 3
    $\begingroup$ One can streamline the code even further with a construction like: f[l_] := {Total@#, #}& @ Flatten@MaximalBy[Subsequences[l], Total]. $\endgroup$ – Greg Martin Oct 2 '18 at 9:01
11
$\begingroup$

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}} *)
$\endgroup$
  • $\begingroup$ Thanks @HenrikSchumacher for the edit! $\endgroup$ – JimB Oct 1 '18 at 6:17
  • 1
    $\begingroup$ Always at your service! By the way, you should remove "brute force" from the post. The last time I checked, this was the fastest solution here. $\endgroup$ – Henrik Schumacher Oct 1 '18 at 6:28
  • 1
    $\begingroup$ @HenrikSchumacher If it's fastest, it's more dumb luck. I'm hoping that someday I'll be able to think more in terms of @@, Thread, Map, etc., like you super folks do. $\endgroup$ – JimB Oct 1 '18 at 6:45
  • 2
    $\begingroup$ If you replace the Do loop with With[{aux = Prepend[numbers, -1]}, Do[ If[aux[[i]] <= 0 && aux[[i + 1]] > 0, sum = Max[accumulate[[i ;; n]]] - accumulate[[i - 1]]; If[sum > mSum, mSum = sum; index = i]], {i, 2, n}]];, then your function becomes at least 50% faster, depending on the number of intervals with a maximal sum. I like your function a lot! $\endgroup$ – Fred Simons Oct 2 '18 at 11:32
  • $\begingroup$ Thanks @FredSimons. I'll add that in. And your suggestion suggests there might be another improvement. I wonder if first going through and reducing the original list to the cumulative sums of the runs of positive and negative numbers and then applying one of the multiple answers would speed things up. $\endgroup$ – JimB Oct 3 '18 at 4:20
11
$\begingroup$

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

$\endgroup$
  • $\begingroup$ This is by far the fastest solution! $\endgroup$ – Fred Simons Oct 2 '18 at 11:26
  • 2
    $\begingroup$ "Sometimes it's good to use pedestrian procedural code." - well said. $\endgroup$ – J. M. will be back soon Oct 2 '18 at 14:12
  • $\begingroup$ Daniel, I would like to know what you make of the second answer I posted. I am confident your method could retake the lead with compilation, but I wonder what you think of the approach I took, and if it has inherent merit or merely takes advantage of the speed of certain top-level functions. $\endgroup$ – Mr.Wizard Oct 7 '18 at 19:31
  • $\begingroup$ @Mr.Wizard As much as I liked the code elegance (of yours), I confess it would take me considerable time to understand the workings. Is it O(n)? Or maybe O(n) for average cases but worse on pathological? It certainly seems quite fast and that's a big plus independent of speed of the underlying functions. $\endgroup$ – Daniel Lichtblau Oct 7 '18 at 20:30
  • $\begingroup$ @Daniel Yeah, it wouldn't be fair of me to expect you to crawl through that. I'll try to make a rudimentary complexity analysis myself and report, when I get around to it. If you have your own idea about how to leverage the pattern I tried to illustrate with the ListLinePlot I'd love to see it. If that didn't make sense I'll try again. $\endgroup$ – Mr.Wizard Oct 7 '18 at 22:35
7
$\begingroup$

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).

timing tests

$\endgroup$
  • $\begingroup$ Would you kindly include my newly-added fn2 in your benchmark? Thanks! :-) edit: might as well make it fn3 $\endgroup$ – Mr.Wizard Oct 3 '18 at 3:36
  • 1
    $\begingroup$ FWIW this is faster when rewritten to use Ordering as follows: kcSum[u_] := Module[{s, best, m, t, k = 1}, s = Accumulate[u]; best = {m = s[[#]], k, k + # - 1} & @@ Ordering[s, -1]; While[Length[s] > 1, s = Rest[s - s[[1]]]; k += 1; t = {m = s[[#]], k, k + # - 1} & @@ Ordering[s, -1]; If[m > best[[1]], best = t]]; {#, Take[u, {##2}]} & @@ best ] $\endgroup$ – Mr.Wizard Oct 7 '18 at 18:41
  • $\begingroup$ Mr.Wizard: Always WI. And thanks for your refined approach! $\endgroup$ – KennyColnago Oct 15 '18 at 23:42
6
$\begingroup$

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}

$\endgroup$
  • $\begingroup$ I think I have a way to greatly speed up this process (beyond fn4) but I don't have time to implement it now. Fun for later! $\endgroup$ – Mr.Wizard Oct 3 '18 at 14:42
5
$\begingroup$
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}}

$\endgroup$
  • 1
    $\begingroup$ Doesn't print the sub-array, does it? $\endgroup$ – Cœur Sep 30 '18 at 17:38
  • 2
    $\begingroup$ Not it does not. But you can apply a[[Span@@pos]] afterwards. $\endgroup$ – Henrik Schumacher Sep 30 '18 at 17:41
4
$\begingroup$

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].

$\endgroup$
  • 4
    $\begingroup$ How is n determined? $\endgroup$ – bbgodfrey Sep 30 '18 at 20:55
3
$\begingroup$
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}}

$\endgroup$
3
$\begingroup$

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

enter image description here

$\endgroup$
2
$\begingroup$

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
]

enter image description here

  • 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}, #] &]

enter image description here

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

fastSS[big]            // AbsoluteTiming
largestConsecSum2[big] // AbsoluteTiming
{0.110151, {31748, 413638, 496790}}

{1.59653, 31748}
$\endgroup$
  • $\begingroup$ It certainly seems quite fast. So I guess O(n) with a much better constant than my code. (I got to be first to upvote.) $\endgroup$ – Daniel Lichtblau Oct 7 '18 at 20:27
  • $\begingroup$ Thanks, @Daniel ! $\endgroup$ – Mr.Wizard Oct 7 '18 at 22:27

Your Answer

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