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?

$\endgroup$
  • $\begingroup$ How about showing what you've tried? (this is trivial to do...) $\endgroup$ – ciao Aug 28 '15 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$ – rogerl Aug 28 '15 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$ – march Aug 28 '15 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$ – rogerl Aug 28 '15 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$ – ciao Aug 28 '15 at 18:34
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}}

$\endgroup$
  • $\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$ – rogerl Aug 28 '15 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$ – rogerl Aug 28 '15 at 18:44
  • $\begingroup$ @Xavier - quite right. I have updated my answer. $\endgroup$ – Chris Degnen Aug 28 '15 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.

$\endgroup$
  • $\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$ – Leonid Shifrin Aug 29 '15 at 1:45
  • $\begingroup$ Neat, but fails when negatives present. +1 though. Interestingly, dramatic slowdown with reals. $\endgroup$ – ciao Aug 29 '15 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$ – Leonid Shifrin Aug 29 '15 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$ – Leonid Shifrin Aug 29 '15 at 13:41
  • $\begingroup$ @LeonidShifrin: Range[-3,3] trivial example - s/b 7 distinct sets, but output is just the range... $\endgroup$ – ciao Aug 29 '15 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}]];
$\endgroup$
  • $\begingroup$ Voted it up without testing, but I guess target should be list? $\endgroup$ – Leonid Shifrin Aug 29 '15 at 0:18
  • $\begingroup$ @LeonidShifrin : oops, yep, Fixing... $\endgroup$ – ciao Aug 29 '15 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.

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

$\endgroup$
  • 1
    $\begingroup$ The output starts {{1, 2} ...} but it should be {{1}, {2} ...}. $\endgroup$ – Chris Degnen Aug 28 '15 at 21:07
  • $\begingroup$ Thanks, I must have been asleep there. There's an irritating reason why that's true. $\endgroup$ – Patrick Stevens Aug 28 '15 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$ – Patrick Stevens Aug 28 '15 at 21:14
  • $\begingroup$ @Chris Algorithm now fixed. Slightly different method. $\endgroup$ – Patrick Stevens Aug 28 '15 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}}
$\endgroup$
  • $\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$ – Patrick Stevens Aug 28 '15 at 17:12
  • $\begingroup$ Here's a silly way: Flatten@*First /@ Drop[NestWhileList[Last@# &, output, Length@# == 2 &], -1] /. HoldPattern[Flatten[s_?AtomQ]] :> {s}. $\endgroup$ – march Aug 28 '15 at 18:16
  • $\begingroup$ Or: Drop[#, -1] & /@ Internal'PartitionRagged[#, Differences@Join[{0}, Flatten@Position[#, ll[]]]] &@ Flatten@(output /. {} -> ll[]) $\endgroup$ – march Aug 28 '15 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$ – march Aug 28 '15 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$ – Leonid Shifrin Aug 28 '15 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}}

$\endgroup$
  • $\begingroup$ I tested and it seems my solution performs slower than the others ... At least it is short code. $\endgroup$ – SquareOne Aug 30 '15 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}}

$\endgroup$

Your Answer

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

Not the answer you're looking for? Browse other questions tagged or ask your own question.