Create sublists whose totals exceed a certain threshold and that are as short as possible

Question

list = {2, 1, 8, 10, 1, 4, 4, 5, 3, 4, 4, 11, 12};

th = 10;

It is easy to create sublists whose totals don't exceed th:

SequenceCases[list, a : {___} /; Total[a] <= th :> a]

{{2, 1}, {8}, {10}, {1, 4, 4}, {5, 3}, {4, 4}, {}, {}}

But how can we include the exceeding element to get

{{2, 1, 8}, {10, 1}, {4, 4, 5}, {3, 4, 4}, {11}, {12}}

I tried many combinations like for example:

SequenceCases[list, a : {Shortest[__]} /; Total[a] > th :> a]

{{2, 1, 8, 10, 1, 4, 4, 5, 3, 4, 4, 11, 12}}

To see what went wrong with this and other attempts I would like to get a solution, if possible, with one of the Sequence- or Replace-functions.

Answer 1

Why not just use Most:

list = {2, 1, 8, 10, 1, 4, 4, 5, 3, 4, 4, 11, 12};
th = 10;

SequenceCases[list, a : {___} /; Total[Most[a]] <= th :> a]

(*{{2, 1, 8}, {10, 1}, {4, 4, 5}, {3, 4, 4}, {11}, {12}}*)

Answer 2

I may have misunderstood but this finds shortest subset satisfying constraint:

list = {2, 1, 8, 10, 1, 4, 4, 5, 3, 4, 4, 11, 12};
fun[u_] := 
 Module[{j = 1, a = {}}, 
  While[Length[a] == 0, a = Select[Subsets[list, {j}], Total@# > u &];
    j++]; a]
Table[{j, fun[j][[1]]}, {j, {5, 13, 29, 40}}] // Grid

Answer 3

list = {2, 1, 8, 10, 1, 4, 4, 5, 3, 4, 4, 11, 12};
th = 10;

f = SequenceCases[#, {a___, e_} /; ! Max@Accumulate@{a} > th :> {a, e}] &;
f@list

{{2, 1, 8}, {10, 1}, {4, 4, 5}, {3, 4, 4}, {11}, {12}}

list2 = {2, 9, -8, 10, 1, 4, 4, 5, 3, 4, 4, 11, 12};
f@list2

{{2, 9}, {-8, 10, 1, 4, 4}, {5, 3, 4}, {4, 11}, {12}}

Answer 4

split[lst_, th_] := Module[{t = 0}, Split[lst, Or[(t += #) <= th, t = 0] &]];

Examples:

list = {2, 1, 8, 10, 1, 4, 4, 5, 3, 4, 4, 11, 12};

split[list, 10]

 {{2, 1, 8}, {10, 1}, {4, 4, 5}, {3, 4, 4}, {11}, {12}}

split[list, 11]

{{2, 1, 8, 10}, {1, 4, 4, 5}, {3, 4, 4, 11}, {12}}

Answer 5

Assume what you want is just one instance of shortest consecutive sequence of the elements in the list. Then following pattern matching will help you:

th=10;

list /. {___, Shortest[a___ /; Total[{a}] > th], ___} :> {a}

(* {11} *)

th=40;

list /. {___, Shortest[a___ /; Total[{a}] > th], ___} :> {a}

(* {4, 5, 3, 4, 4, 11, 12} *)

If you need more instances,

 ReplaceList[list, {___, Shortest[a___ /; Total[{a}] > th], ___} :> {a}]

will give you more, and you can select what you want. For example,

 th=10;
 ReplaceList[list, {___, Shortest[a___ /; Total[{a}] > th], ___} :> {a}]

Answer 6

list = {2, 1, 8, 10, 1, 4, 4, 5, 3, 4, 4, 11, 12};
th = 10;

---

A more programmatic way to do it is the following:

 fun[list_, th_] := Module[{sum = 0, sublist = {}, res = {}, i = 1},
    While[i <= Length[list], sum += list[[i]];
    AppendTo[sublist, list[[i]]];
    If[sum > th, AppendTo[res, sublist];
    sublist = {};sum = 0;]; i++;];
    If[sublist =!= {}, AppendTo[res, sublist]]; res];

 fun[list, th]

{{2, 1, 8}, {10, 1}, {4, 4, 5}, {3, 4, 4}, {11}, {12}}

Answer 7

Other way with AppendTo :

list = {2, 1, 8, 10, 1, 4, 4, 5, 3, 4, 4, 11, 12};
th = 10;

t=s={};(AppendTo[t,#];
If[Total[t]>th,AppendTo[s,t];
t={}])&/@list;s

{{2, 1, 8}, {10, 1}, {4, 4, 5}, {3, 4, 4}, {11}, {12}}