Splitting a list into increasing sublists

Question

I have a list of numbers (say, for example, {1,2,3,4,3,2,1,2,3,4,3,2}), and I want to split it into sublists so that each sublist is the (smallest) sublist whose sum is larger than the preceding one. For the above example, my desired output is {{1},{2},{3},{4},{3,2},{1,2,3},{4,3},{2}} (the sums are 1, 2, 3, 4, 5, 6, 7, and the {2} at the end just uses the remaining leftover elements).

Neither Split nor SplitBy seems to be able to do what I need. Is there a primitive to do this, or would someone care to invent a clever function?

Answer 1

a = {1, 2, 3, 4, 3, 2, 1, 2, 3, 4, 3, 2};

f = Module[{b, c, d, n},
    b = {{First[#]}};
    c = Rest[#];
    Catch[
     While[True,
      n = 1; While[Total[d = Quiet@Check[Take[c, n],
            Throw[AppendTo[b, c]]]] <= Total@Last[b], n++];
      AppendTo[b, d];
      c = Drop[c, n]]];
    b] &;

f[a]

{{1}, {2}, {3}, {4}, {3, 2}, {1, 2, 3}, {4, 3}, {2}}

Answer 2

Here is a purely functional solution (i.e. not using mutable state), based in FoldList (since the one based on linked lists has been already taken):

stepF = 
  Function @ With[{sum = First @ #1 + #2, len = #[[2]], prevsum = #1[[3]]},
    If[sum > prevsum, {0, 0, sum, len + 1}, {sum, len + 1, prevsum, 0}]
  ];

getLengths[lst_List] :=
  DeleteCases[0] @ Append[#, Length[lst] - Total[#]] & @
     FoldList[stepF, {0, 0, 0, 0}, lst][[All, -1]];

splitInc[lst_] := Internal`PartitionRagged[lst, getLengths[lst]]

For example:

splitInc[lst]

(* {{1}, {2}, {3}, {4}, {3, 2}, {1, 2, 3}, {4, 3}, {2}} *)

The idea is to use FoldList to determine the lengths of all sublists, and then split. At every iteration in FoldList the function stepF takes a list of 4 elements {currentSum, currentLength, previousSum, splitLengthOrZero} as a first argument, and a next element of the original list as a second argument, and returns a modified list of 4 elements - working basically as a state machine. We then just have to pick those states where the last element (splitLengthOrZero) is non-zero, and we get a list of lengths. In place of Internal`PartitionRagged one could also use Mr.Wizard's dynP.

Answer 3

A bit more concise, seems at least as fast as those posted so far:

setter[list_] := Module[{fs = 0, t = First@list - 1, f, u},
   f[x_] := If[(fs += x) > t, t = fs; fs = 0; True, False];
   u = Union[Pick[Range@Length@list, f /@ list], {Length@list}];
   MapThread[list[[#1 ;; #2]] &, {Prepend[Most@u, 0] + 1, u}]];

Answer 4

Split

With a special test function as the second argument Split does give the desired result:

ClearAll[f]
f = Module[{s = 0, t = 0}, Split[#, Or[(s += #) < t, t = s; s = 0] &]] &;

Examples:

f @ {1, 2, 3, 4, 3, 2, 1, 2, 3, 4, 3, 2}

{{1}, {2}, {3}, {4}, {3, 2}, {1, 2, 3}, {4, 3}, {2}}

lst = RandomInteger[9, 10]

{{1, 0, 8, 7, 7, 5, 3, 6, 8, 0}

f @ lst

{{1}, {0, 8}, {7, 7}, {5, 3, 6}, {8, 0}}}

See this and this for the origin of Or trick.

Answer 5

Here is another possible solution:

mySorting[{}, _] := {};

mySorting[list_, sum_] := 
  Block[{firstelem = First@list, listlength = Length@list,tempsum, poselem = 1},
   tempsum = firstelem;
   While[tempsum <= sum && poselem + 1 <= listlength, 
        tempsum = tempsum + list[[poselem++ + 1]]];
   {list[[Range@poselem]], Sequence @@ mySorting[Drop[list, poselem], tempsum]}];

mySorting[list_] := 
  With[{firstelem = First@list}, 
  {{firstelem}, Sequence @@ mySorting[Rest@list, firstelem]}];

For your example list = {1,2,3,4,3,2,1,2,3,4,3,2} we get

mySorting[list]
{{1}, {2}, {3}, {4}, {3, 2}, {1, 2, 3}, {4, 3}, {2}}

Answer 6

Yet another answer:

pos[list_] := Module[{currcounter = 0, currmax = 0},
   Map[(
    currcounter += #;
    If[currcounter > currmax, 
        currmax = currcounter; 
        currcounter = 0;
        False,
      currcounter += #;
       True]) &, 
    list]]

g[list_] := 
 With[{arr = pos[list]},
  With[{splitpos = Split[arr, #1 == True &]},
   ReplacePart[splitpos, 
    Rule @@@ Transpose@{Position[splitpos, True | False], list}]
  ]]

pos[{1,2,3,4,3,2,1}] is {False, False, False, False, True, False, True}, with True in any position that is not the end of a required sub-list. The function g then Splits that list, so as to get a resulting list of exactly the right shape but with False and True instead of the required list elements. Finally, we insert the list elements.

Answer 7

I've made a very rough-and-ready one which uses linked lists:

toLinkedList = Fold[{#2, #1} &, {}, Reverse@#]&;
r[list_, currval_, currans_, curransval_] := 
 r[list[[2]], currval, {list[[1]], currans}, curransval + list[[1]]]
r[{}, c_, a_, v_] := a
r[list_, currval_, currans_, curransval_] /; curransval > currval := 
 {currans, r[list, curransval, {}, 0]}

partition[list_] := r[toLinkedList[list], 0, {}, 0]

Output:

{{1, {}}, {{2, {}}, {{3, {}}, {{4, {}}, {{2, {3, {}}}, {{3, {2, {1, {}}}}, {{3, {4, {}}}, {2, {}}}}}}}}}

which is linked-list speak for

{{1}, {2}, {3}, {4}, {3,2}, {1,2,3}, {4,3}, {2}}

Answer 8

I also thought immediatly about the Fold function using the #1 and #2 arguments of it. Here is my try:

Given the OP list:

mylist = {1, 2, 3, 4, 3, 2, 1, 2, 3, 4, 3, 2}

then:

(for versions<10.2 replace Nothing with Sequence[]):

foo = (If[(sn = #2 + Tr@Last@#1) > s, s = sn; lst = {}, 
     lst = Nothing]; {Sequence @@ Most@#1, Join[Last@#1, {#2}], lst}) &;

Fold[foo, {{s = First@mylist}, {}}, Rest@mylist]

{{1}, {2}, {3}, {4}, {3, 2}, {1, 2, 3}, {4, 3}, {2}}

Answer 9

Here is an option using Reap and Sow:

splitInc[list_List]:=Block[{i=0,previousTotal=0,current={}},
    Last@Reap@Scan[
        (
        AppendTo[current,#];
        If[Total[current] > previousTotal
            ,Sow[#,i];previousTotal=Total[current];current={};i++
            ,Sow[#,i]]
        )&
        , list
    ]
]
splitInc[list]

{{1},{2},{3},{4},{3,2},{1,2,3},{4,3},{2}}