# Splitting a list into increasing sublists

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?

• How about showing what you've tried? (this is trivial to do...)
– ciao
Aug 28, 2015 at 16:46
• Well, the only thing I've tried is a complicated solution involving keeping track of the current sum and the tail of the list and using that to find the next greater head. Aug 28, 2015 at 16:54
• I still think it's worth putting in what you've tried. Some here (me included, actually, but not everyone) like to see the effort that people have put into solving their problem. It could be that what you've tried is the right way to do it, but it just needs a little tweak. In correcting it, a couple of things can happen: you can learn a little more about MMA syntax, you can learn some coding tricks, you can better prepare for [mathematica.stackexchange.com/questions/18393/…, other users can learn from the post, etc Aug 28, 2015 at 17:47
• @march Fair enough. To be honest, I was hoping I was just missing something in SplitBy, or that another primitive would do the trick, and I wouldn't have to write anything. Aug 28, 2015 at 18:30
• How big will the lists be? Is performance important (the methods so far can be handily beaten if it is), or will list be so small it does not matter?
– ciao
Aug 28, 2015 at 18:34

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

• Nice solution, thanks. That's along the lines of what I was thinking in my comment above, but done more elegantly than I would probably have written it. I was hoping for a solution that didn't involve explicit loops. Aug 28, 2015 at 17:18
• I think the Catch and inner While can be replaced by the following, which completely avoids an inner loop: While[Length@c > 0, d = Accumulate@c; n = Max@FirstPosition[d, x_ /; x > Total@Last@b, Length@d]; b = Append[b, Take[c, n]]; c = Drop[c, n]]; Aug 28, 2015 at 18:44
• @Xavier - quite right. I have updated my answer. Aug 28, 2015 at 20:48

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_] := InternalPartitionRagged[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 InternalPartitionRagged one could also use Mr.Wizard's dynP.

• @Xavier Thanks. Glad you liked it. You can search the site for dynP function of Mr.Wizard, which has comparable performance to InternalPartitionRagged, while being implemented purely in top-level code. Aug 29, 2015 at 1:45
• Neat, but fails when negatives present. +1 though. Interestingly, dramatic slowdown with reals.
– ciao
Aug 29, 2015 at 4:09
• @ciao Thanks. It does work with negative numbers, for me. Can you provide an example where it fails for you? Re: slowdown - indeed. Probably related to the auto-compilation, although I still don't understand why - by default the arguments of compiled function are anyway reals. Aug 29, 2015 at 13:35
• @ciao One guess would be that, for integers, the list of 4 elements produced at each iteration of Fold, can still be packed, and is packed since Fold auto-compiles. For reals, the list contains 2 integers and 2 reals, and so can't be packed. Not sure if I am right, but I can't see any better explanation at the moment. One thing that kind of confirms my guess is that if you use N@{0, 0, 0, 0} as a starting value in FoldList, instead of {0, 0, 0, 0}, then the performance on integers also degrades just like it does for reals. Aug 29, 2015 at 13:41
• @LeonidShifrin: Range[-3,3] trivial example - s/b 7 distinct sets, but output is just the range...
– ciao
Aug 29, 2015 at 19:20

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}]];

• Voted it up without testing, but I guess target should be list? Aug 29, 2015 at 0:18
• @LeonidShifrin : oops, yep, Fixing...
– ciao
Aug 29, 2015 at 1:14

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

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


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.

• The output starts {{1, 2} ...} but it should be {{1}, {2} ...}. Aug 28, 2015 at 21:07
• Thanks, I must have been asleep there. There's an irritating reason why that's true. Aug 28, 2015 at 21:11
• @Xavier, this whole approach is badly flawed because SplitBy evaluates the function once for every pair of adjacent elements. Under the hood, it's just calling Split, which is exactly what I wanted to avoid happening. I was expecting it just to evaluate the function at each element, and then split according to that list. Aug 28, 2015 at 21:14
• @Chris Algorithm now fixed. Slightly different method. Aug 28, 2015 at 21:28

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, {}}}}}}}}}


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

• … although de-linked-listing it is more than my tired brain wants to handle at the moment, since Flatten won't work, being a linked list of linked lists. Aug 28, 2015 at 17:12
• Here's a silly way: Flatten@*First /@ Drop[NestWhileList[Last@# &, output, Length@# == 2 &], -1] /. HoldPattern[Flatten[s_?AtomQ]] :> {s}. Aug 28, 2015 at 18:16
• Or: Drop[#, -1] & /@ Internal'PartitionRagged[#, Differences@Join[{0}, Flatten@Position[#, ll[]]]] &@ Flatten@(output /. {} -> ll[]) Aug 28, 2015 at 19:02
• This is better than the first (sorry if I'm being annoying; I'm just interested in how to do this): Flatten@*First /@ NestList[Last@# &, output, Count[output, {}, Infinity] - 1]/. HoldPattern[Flatten[s_?AtomQ]] :> {s} . Aug 28, 2015 at 19:30
• I have explained in a linked post, what to do when your elements are themselves lists - section named "Generalized linked lists". You have to use a symbolic container like ll (or any other symbol) instead of List, and then use Flatten with 3 args. I am a bit surprised that you didn't see that, given that you provided a link to that post. In any case, linked lists were the first thing that also came to my mind when I read the question. Aug 28, 2015 at 22:07

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

• I tested and it seems my solution performs slower than the others ... At least it is short code. Aug 30, 2015 at 17:57

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