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

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.

• Shortest subset? sublist? subsequence? Commented Jun 19 at 7:30

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


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


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

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

• Excellent ! Very nice and esthetic code. Thanks Commented Jun 22 at 22:16

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


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

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