# Split a list of numbers into lists of five with roughly the same sum

I have a list of ~50 numbers (they’re all whole, but I don’t know if it matters) and I’d like to split it into lists of exactly five entries so that the sum of each group of five is the most similar to the others.

For example, if my list was like {1, 1, 2, 2, 3, 3, 4, 4, 5, 6}, I’d like to get {{1, 2, 3, 4, 5}, {1, 2, 3, 4, 6}}.

• Strongly suspect that in general, your problem is NP-complete (en.wikipedia.org/wiki/NP-completeness) Commented Jan 25, 2023 at 15:21
• It is related to the Knapsack problem en.wikipedia.org/wiki/Knapsack_problem. Commented Jan 25, 2023 at 15:23
• In addition to what @yarchik commented, there must be something missing in the description. For instance, if I naively run Total /@ DeleteDuplicates[Subsets[list, {5}]] then every pair of the sums differs only by 1.
– bmf
Commented Jan 25, 2023 at 15:27
• @bmf It is asked to be "most similar", not "the same" Commented Jan 25, 2023 at 15:28
• You probably have to define a similarity measure to get an answer you want. As @yarchik stated, this is likely to be an NP-complete problem. Commented Jan 25, 2023 at 16:09

Clear["Global*"]


A non-rigorous approach.

SeedRandom[1234];

list1 = RandomInteger[100, 52] // Sort

(* {2, 2, 5, 5, 6, 8, 9, 11, 12, 13, 17, 18, 19, 21, 22, 22, 26, 29, 32, 33, 36, \
38, 44, 44, 44, 45, 45, 47, 47, 47, 47, 51, 52, 53, 56, 59, 60, 60, 61, 66, \
66, 66, 68, 68, 72, 76, 86, 88, 88, 93, 97, 98} *)


Partition into five groups (discarding any extras)

list2 = Partition[list1, Floor[Length[list1]/5]]

(* {{2, 2, 5, 5, 6, 8, 9, 11, 12, 13}, {17, 18, 19, 21, 22, 22, 26, 29, 32,
33}, {36, 38, 44, 44, 44, 45, 45, 47, 47, 47}, {47, 51, 52, 53, 56, 59, 60,
60, 61, 66}, {66, 66, 68, 68, 72, 76, 86, 88, 88, 93}} *)


Reverse every other partition

list3 = Riffle[list2[[1 ;; ;; 2]], Reverse /@ list2[[2 ;; ;; 2]]]

(* {{2, 2, 5, 5, 6, 8, 9, 11, 12, 13}, {33, 32, 29, 26, 22, 22, 21, 19, 18,
17}, {36, 38, 44, 44, 44, 45, 45, 47, 47, 47}, {66, 61, 60, 60, 59, 56, 53,
52, 51, 47}, {66, 66, 68, 68, 72, 76, 86, 88, 88, 93}} *)


Transpose into groups of five

list4 = Transpose[list3]

(* {{2, 33, 36, 66, 66}, {2, 32, 38, 61, 66}, {5, 29, 44, 60, 68}, {5, 26, 44,
60, 68}, {6, 22, 44, 59, 72}, {8, 22, 45, 56, 76}, {9, 21, 45, 53, 86}, {11,
19, 47, 52, 88}, {12, 18, 47, 51, 88}, {13, 17, 47, 47, 93}} *)


The sums of each group are

sums = Total /@ list4

(* {203, 199, 206, 203, 203, 207, 214, 217, 216, 217} *)

MinMax@sums

(* {199, 217} *)


The variance of the sums are

var = Variance[sums] // N

(* 46.7222 *)

• (+) A good starting point for iterative refinement. Commented Jan 25, 2023 at 16:08
• I think this is good enough for what I need. Thank you! Commented Jan 26, 2023 at 10:18

I'll use the same example as from @BobHanlon. We can set this up as a 0-1 integer linear programming problem. We require a matrix of variables indexed by subset and list element. Each row will give a subset sum and each column will denote a list element position. If subsets have length 5 and the list has length 52 (as in this case), then there will be Floor[52/5]=10 sublists. Constraints are that all variables are 0 or 1, row sums in this matrix are all 5 and column sums are all 1 or 0, that latter being the case for the leftover (unused) elements.

We take all differences of our subset sums, and minimize the maximum of these. Easy enough: just constrain a new variable to be greater-equal to all those differences, and minimize it.

SeedRandom[1234];
llen = 52;
list1 = RandomInteger[100, llen]
sublen = 5;
nsublists = Floor[llen/sublen];
vars = Array[x, {nsublists, llen}];
fvars = Flatten[vars];
subsums = vars . list1;
c1 = Map[0 <= # <= 1 &, fvars];
c2 = Map[Total[#] <= 1 &, Transpose@vars];
c3 = Map[Total[#] == sublen &, vars];
diffs = Flatten[Outer[Subtract, subsums, subsums]];
c4 = Map[min >= # &, diffs];


Now minimize, and reconstruct the subsets.

constraintsI = Join[c1, c2, c3, c4, {Element[fvars, Integers]}];
Timing[{diffmin, vals} =
FindMinimum[{min, constraintsI}, Join[{min}, fvars]];]
solmat = vars /. vals;
subsets = Table[Pick[list1, solmat[[j]], 1], {j, Length[solmat]}];
{diffmin, subsets}
(* Out[263]= {122.351, Null}

Out[266]= {0., {{5, 52, 36, 61, 68}, {44, 12, 13, 60, 93}, {47, 33,
29, 66, 47}, {45, 32, 6, 51, 88}, {26, 22, 86, 44, 44}, {5, 66, 18,
88, 45}, {2, 72, 59, 21, 68}, {56, 2, 98, 47, 19}, {8, 17, 97, 53,
47}, {9, 76, 11, 60, 66}}} *)


Interestingly, in this case the subset sums are all identical.

Map[Total, subsets]

(* Out[267]= {222, 222, 222, 222, 222, 222, 222, 222, 222, 222} *)
`

An allusion to Baker Street? Lucifer over three? A schoolroom from an early 70's TV show? I've no idea.