8
$\begingroup$

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

$\endgroup$
6
  • 7
    $\begingroup$ Strongly suspect that in general, your problem is NP-complete (en.wikipedia.org/wiki/NP-completeness) $\endgroup$
    – yarchik
    Jan 25, 2023 at 15:21
  • 3
    $\begingroup$ It is related to the Knapsack problem en.wikipedia.org/wiki/Knapsack_problem. $\endgroup$
    – yarchik
    Jan 25, 2023 at 15:23
  • $\begingroup$ 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. $\endgroup$
    – bmf
    Jan 25, 2023 at 15:27
  • $\begingroup$ @bmf It is asked to be "most similar", not "the same" $\endgroup$
    – yarchik
    Jan 25, 2023 at 15:28
  • 2
    $\begingroup$ 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. $\endgroup$
    – kirma
    Jan 25, 2023 at 16:09

2 Answers 2

8
$\begingroup$
Clear["Global`*"]

A non-rigorous approach.

Start with a sorted list

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 *)
$\endgroup$
2
  • $\begingroup$ (+) A good starting point for iterative refinement. $\endgroup$
    – yarchik
    Jan 25, 2023 at 16:08
  • $\begingroup$ I think this is good enough for what I need. Thank you! $\endgroup$
    – Vrangone
    Jan 26, 2023 at 10:18
9
$\begingroup$

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.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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