17
$\begingroup$

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?

Improve this question
$\endgroup$
7
  • $\begingroup$ How about showing what you've tried? (this is trivial to do...) $\endgroup$ Commented Aug 28, 2015 at 16:46
  • 2
    $\begingroup$ 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. $\endgroup$ Commented Aug 28, 2015 at 16:54
  • $\begingroup$ 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 $\endgroup$ Commented Aug 28, 2015 at 17:47
  • $\begingroup$ @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. $\endgroup$ Commented Aug 28, 2015 at 18:30
  • $\begingroup$ 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? $\endgroup$ Commented Aug 28, 2015 at 18:34

9 Answers 9

Reset to default
5
$\begingroup$ 
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}}

Improve this answer
$\endgroup$
3
  • $\begingroup$ 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. $\endgroup$ Commented Aug 28, 2015 at 17:18
  • $\begingroup$ 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]]; $\endgroup$ Commented Aug 28, 2015 at 18:44
  • $\begingroup$ @Xavier - quite right. I have updated my answer. $\endgroup$ Commented Aug 28, 2015 at 20:48
9
$\begingroup$

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.

Improve this answer
$\endgroup$
11
  • $\begingroup$ @Xavier Thanks. Glad you liked it. You can search the site for dynP function of Mr.Wizard, which has comparable performance to Internal`PartitionRagged, while being implemented purely in top-level code. $\endgroup$ Commented Aug 29, 2015 at 1:45
  • $\begingroup$ Neat, but fails when negatives present. +1 though. Interestingly, dramatic slowdown with reals. $\endgroup$ Commented Aug 29, 2015 at 4:09
  • $\begingroup$ @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. $\endgroup$ Commented Aug 29, 2015 at 13:35
  • $\begingroup$ @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. $\endgroup$ Commented Aug 29, 2015 at 13:41
  • $\begingroup$ @LeonidShifrin: Range[-3,3] trivial example - s/b 7 distinct sets, but output is just the range... $\endgroup$ Commented Aug 29, 2015 at 19:20
5
$\begingroup$

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}]];
Improve this answer
$\endgroup$
2
  • $\begingroup$ Voted it up without testing, but I guess target should be list? $\endgroup$ Commented Aug 29, 2015 at 0:18
  • $\begingroup$ @LeonidShifrin : oops, yep, Fixing... $\endgroup$ Commented Aug 29, 2015 at 1:14
5
$\begingroup$

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.

Improve this answer
$\endgroup$
3
$\begingroup$

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}}
Improve this answer
$\endgroup$
0
3
$\begingroup$

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.

Improve this answer
$\endgroup$
4
  • 1
    $\begingroup$ The output starts {{1, 2} ...} but it should be {{1}, {2} ...}. $\endgroup$ Commented Aug 28, 2015 at 21:07
  • $\begingroup$ Thanks, I must have been asleep there. There's an irritating reason why that's true. $\endgroup$ Commented Aug 28, 2015 at 21:11
  • $\begingroup$ @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. $\endgroup$ Commented Aug 28, 2015 at 21:14
  • $\begingroup$ @Chris Algorithm now fixed. Slightly different method. $\endgroup$ Commented Aug 28, 2015 at 21:28
2
$\begingroup$

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}}
Improve this answer
$\endgroup$
7
  • $\begingroup$ … 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. $\endgroup$ Commented Aug 28, 2015 at 17:12
  • $\begingroup$ Here's a silly way: Flatten@*First /@ Drop[NestWhileList[Last@# &, output, Length@# == 2 &], -1] /. HoldPattern[Flatten[s_?AtomQ]] :> {s}. $\endgroup$ Commented Aug 28, 2015 at 18:16
  • $\begingroup$ Or: Drop[#, -1] & /@ Internal'PartitionRagged[#, Differences@Join[{0}, Flatten@Position[#, ll[]]]] &@ Flatten@(output /. {} -> ll[]) $\endgroup$ Commented Aug 28, 2015 at 19:02
  • 2
    $\begingroup$ 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} . $\endgroup$ Commented Aug 28, 2015 at 19:30
  • $\begingroup$ 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. $\endgroup$ Commented Aug 28, 2015 at 22:07
2
$\begingroup$

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

Improve this answer
$\endgroup$
1
  • $\begingroup$ I tested and it seems my solution performs slower than the others ... At least it is short code. $\endgroup$ Commented Aug 30, 2015 at 17:57
2
$\begingroup$

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

Improve this answer
$\endgroup$

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.