15
$\begingroup$

Suppose we have 3 lists each with 18 numbers like this:

list1 = {7.49, 7.56, 7.98, 8.09, 8.16, 8.21,
         8.73, 8.64, 8.68, 8.46, 8.57, 8.29, 9.38, 9.43, 8.95, 9.04, 8.9, 9.07};
list2 = {21.08, 21.18, 21.35, 21.79, 21.92, 22.15, 22.38, 22.48, 22.48, 22.51, 22.64, 22.68, 22.75, 22.8, 23.01, 23.28, 23.5, 23.54};
list3 = {36.33, 37.1, 37.19, 37.31, 37.34, 37.61, 37.88, 38.32, 38.42, 38.9, 39.06, 39.12, 39.14, 39.31, 39.39, 39.41, 39.41, 39.43};

I need to partition it into six subsets:

  1. Each one with 3 numbers
  2. The mean of each one is as close as possible to the others.

For an example:

list = {1, 2, 3, 4, 5, 6};

Partition into 3 subsets: 1. Each one with equal size, it sould be Length[list]/3=2 2. The mean of each subset is as close as possible to the others,it should be {{1,6},{2,5},{3,4}} where each subset's mean is 3.5.

My objective is:

Minimize the MeanVariance of all the subsets.

Improve this question
$\endgroup$
14
  • 1
    $\begingroup$ Welcome to MMA.SE ! It would be interesting to provide a minimum working example, to actually show that you've searched and/or tried anything before asking the community. Moreover, its not clear to me what exactly do you mean with "the means of each onde are as close as possible." $\endgroup$
    – Rod
    Aug 31, 2013 at 18:13
  • 1
    $\begingroup$ In other words you are looking at a k-means clustering variant. Or I think so :D $\endgroup$
    – Sektor
    Aug 31, 2013 at 18:26
  • 2
    $\begingroup$ For the small example brute force would be : aux = {#, Variance[Mean[Transpose[#]]]} & /@ (Partition[#, 2, 2] & /@ Permutations[lst, {6}]) and SortBy[aux, #[[2]] &][[1]]. As hinted by @PlatoManiac, you need a better way for large lists. $\endgroup$
    – b.gates.you.know.what
    Aug 31, 2013 at 19:26
  • 1
    $\begingroup$ Not at all a general or optimal solution, but for your specific dataset this seems to work nicely: Transpose[FindClusters[list, 3]] For other data it can produce ragged uneven subdivision, so there should be an even-out-and-sort steps included. $\endgroup$
    – Vitaliy Kaurov
    Aug 31, 2013 at 19:47
  • 3
    $\begingroup$ Might be worth asking this on the Mathematics se $\endgroup$
    – DavidC
    Aug 31, 2013 at 22:59

3 Answers 3

Reset to default
5
$\begingroup$

A simple approximate version would work like this:

  • Sort data
  • Split on 3 sublists by 6 elements
  • Reverse order of sublist with Max Variance
  • Transpose to get 6 sublists by 3 elements

Here is the code:

subd[data_] := Transpose[MapAt[Reverse, Sort[Partition[Sort[data], 6], 
                   Variance[#1] < Variance[#2] &], -1]]

here is how it works

subd[list2]

{{22.38, 22.75, 22.15}, {22.48, 22.8, 21.92}, {22.48, 23.01, 21.79}, 
{22.51, 23.28, 21.35}, {22.64, 23.5, 21.18}, {22.68, 23.54, 21.08}}

and here are variances of mean values of sublists, which are pretty small:

Variance[Mean /@ subd[#]] & /@ {list1, list2, list3}

{0.00137222, 0.000527407, 0.0127885}
Improve this answer
$\endgroup$
5
$\begingroup$

The problem is to split a list of m*n numbers into m subsets of size n whose means are as equal as possible. Here is an iterative solution. First, partition the sorted list into n sublists of size m, then reverse the even-numbered sublists, and transpose the array to get m sublists of size n. This will give a reasonably good initial approximation.

Then iterate over pairs of subsets. For each pair, find the split of the 2n values that will make their means as equal as possible. Continue until the current split is best for m(m-1)/2 pairs in a row. This will not necessarily find the absolute best subsets, but it will find a very good set. Restarting the iterations from the initial approximation many times, but with the order of the numbers in each subset randomized each time, is a convenient way to increase the chance of finding the absolute best set. (There is no way to guarantee that a set is best, short of checking all possible sets.)

To facilitate repeated randomized starts, I have rewritten my earlier code as a function. The last argument is the number of repetitions. It may be omitted, in which case only one start is used. The returned list is {subsets, subset means, standard deviation of subset means}.

EDIT - This revision addresses again the problem (noted by incognito007) that the results are susceptible to floating-point roundoff error. One possible effect is that the While can loop forever; this actually happened when the previous code was used to partition list2 with m = 3, n = 6. The new code handles that case, but I can't guarantee that such looping can never occur when the data are Real. On the other hand, if all the data are exact then the arithmetic will be exact and the problem can not occur. One solution, exemplified below, is to scale and round the data, then undo the scaling at the end. Besides being safe, this will usually be faster, too.

funk[data_List?(VectorQ[#,NumericQ]&), m_Integer?Positive, n_Integer?Positive,
     r:(_Integer?Positive):1] /; Length@data == m*n :=
Module[{b,c,d,e,f,g,h,i,j,k,L, v = Infinity, w},
d = Transpose@MapAt[Reverse,Partition[Sort@data,m],List/@Range[2,n,2]];
c = Prepend[#,1]&/@Permutations@Join[ConstantArray[1,{n-1}],ConstantArray[-1,{n}]];
i = Flatten[Position[#, 1]]&/@c;
j = Flatten[Position[#,-1]]&/@c;
If[And@@ExactNumberQ/@data, w := c.f,
  w := Total[f*c,Method->"CompensatedSummation"]; d = N@d; c = N@Transpose@c];
c = Developer`ToPackedArray@c;
Do[g = h = 1; L = 0; e = RandomSample/@d;
  While[L < m(m-1)/2,
    If[++h > m, If[++g >= m, g = 1]; h = g+1];
    f = Developer`ToPackedArray@Flatten@e[[{g,h}]];
    k = Ordering[Abs@w,1][[1]];
    If[k > 1, e[[g]] = f[[i[[k]]]]; e[[h]] = f[[j[[k]]]]; L = 0]; L++];
  k = Variance@Total[e,{2}];
  If[k < v, v = k; b = e], {r}];
{b, Mean/@b, Sqrt@v/n}]

list1 = {7.49, 7.56, 7.98, 8.09, 8.16, 8.21, 8.73, 8.64, 8.68,
         8.46, 8.57, 8.29, 9.38, 9.43, 8.95, 9.04, 8.9, 9.07};
list2 = {21.08, 21.18, 21.35, 21.79, 21.92, 22.15, 22.38, 22.48, 22.48,
         22.51, 22.64, 22.68, 22.75, 22.8, 23.01, 23.28, 23.5, 23.54};
list3 = {36.33, 37.1, 37.19, 37.31, 37.34, 37.61, 37.88, 38.32, 38.42,
         38.9, 39.06, 39.12, 39.14, 39.31, 39.39, 39.41, 39.41, 39.43};

First some results with m = 6, n = 3, the parameters in the original request.

Timing@funk[list1,6,3,1000]

{3.97, {{{8.9, 8.57, 8.16}, {8.64, 8.68, 8.29}, {8.73, 7.49, 9.38},
         {7.56, 8.95, 9.07}, {9.43, 8.21, 7.98}, {8.09, 8.46, 9.04}},
        {8.54333, 8.53667, 8.53333, 8.52667, 8.54, 8.53}, 0.0062361}}

Timing[.01*funk[Round[100*list1],6,3,1000]]

{3.22, {{{8.9, 8.57, 8.16}, {8.64, 8.68, 8.29}, {8.73, 7.49, 9.38},
         {7.56, 8.95, 9.07}, {9.43, 8.21, 7.98}, {8.09, 8.46, 9.04}},
        {8.54333, 8.53667, 8.53333, 8.52667, 8.54, 8.53}, 0.0062361}}

Timing@funk[list2,6,3,1000]

{4.79, {{{22.75, 23.28, 21.18}, {21.08, 22.68, 23.5}, {21.92, 22.51, 22.8},
         {23.54, 22.38, 21.35}, {22.64, 22.48, 22.15}, {23.01, 21.79, 22.48}},
        {22.4033, 22.42, 22.41, 22.4233, 22.4233, 22.4267}, 0.0091084}}

Timing[.01*funk[Round[100*list2],6,3,1000]]

{3.61, {{{22.75, 23.28, 21.18}, {21.08, 22.68, 23.5}, {21.92, 22.51, 22.8},
         {23.54, 22.38, 21.35}, {22.64, 22.48, 22.15}, {23.01, 21.79, 22.48}},
        {22.4033, 22.42, 22.41, 22.4233, 22.4233, 22.4267}, 0.0091084}}

Timing@funk[list3,6,3,1000]

{1.83, {{{36.33, 39.31, 39.41}, {39.12, 37.1, 39.06}, {39.14, 37.19, 38.9},
         {39.39, 38.42, 37.31}, {38.32, 37.34, 39.41}, {39.43, 37.61, 37.88}},
        {38.35, 38.4267, 38.41, 38.3733, 38.3567, 38.3067}, 0.0433803}}

Timing[.01*funk[Round[100*list3],6,3,1000]]

{1.49, {{{39.12, 39.06, 37.1}, {37.19, 39.14, 38.9}, {36.33, 39.31, 39.41},
         {39.39, 38.42, 37.31}, {38.32, 37.34, 39.41}, {39.43, 37.61, 37.88}},
        {38.4267, 38.41, 38.35, 38.3733, 38.3567, 38.3067}, 0.0433803}}

Now the other way around: m = 3, n = 6.

Timing@funk[list1,3,6,1000]

{9.85, {{{7.49, 9.04, 8.09, 9.38, 8.64, 8.57},
         {8.68, 8.46, 8.29, 8.73, 7.98, 9.07},
         {9.43, 8.21, 8.95, 8.16, 8.9, 7.56}},
        {8.535, 8.535, 8.535}, 0.}}

Timing[.01*funk[Round[100*list1],3,6,1000]]

{2.45, {{{8.21, 8.29, 8.73, 9.43, 7.98, 8.57},
         {8.9, 8.09, 8.95, 7.56, 9.07, 8.64},
         {9.04, 8.68, 7.49, 8.16, 9.38, 8.46}},
        {8.535, 8.535, 8.535}, 0}}

Timing@funk[list2,3,6,1000] (* this used to hang *)

{8.02, {{{22.68, 23.54, 21.35, 21.18, 23.28, 22.48},
         {21.92, 22.48, 22.51, 21.08, 23.5, 23.01},
         {22.38, 22.75, 21.79, 22.15, 22.64, 22.8}},
        {22.4183,22.4167, 22.4183}, 0.00096225}}

Timing[.01*funk[Round[100*list2],3,6,1000]]

{2.03, {{{22.15, 22.51, 23.54, 22.48, 21.35, 22.48},
         {22.38, 22.64, 21.79, 23.01, 21.18, 23.5},
         {22.75, 21.92, 22.68, 21.08, 22.8, 23.28}},
        {22.4183,22.4167, 22.4183}, 0.00096225}}

Timing@funk[list3,3,6,1000]

{9.31, {{{39.43, 37.88, 39.14, 36.33, 38.32, 39.12},
         {37.34, 39.06, 39.31, 37.19, 38.9, 38.42},
         {37.1, 37.31, 39.39, 39.41, 39.41, 37.61}},
        {38.37, 38.37, 38.3717}, 0.00096225}}

Timing[.01*funk[Round[100*list3],3,6,1000]]

{2.52, {{{39.14, 37.88, 39.12, 36.33, 38.32, 39.43},
         {39.41, 39.31, 37.61, 37.19, 37.31, 39.39},
         {37.1, 37.34, 38.9, 38.42, 39.06, 39.41}},
        {38.37, 38.37, 38.3717}, 0.00096225}}
Improve this answer
$\endgroup$
2
  • $\begingroup$ Copying and running your code, I got the following result:{{7.49, 9.43, 8.68}, {8.9, 8.57, 8.16}, {7.56, 8.95, 9.07}, {9.38, 7.98, 8.29}, {8.64, 8.21, 8.73}, {9.04, 8.09, 8.46}};{8.53333, 8.54333, 8.52667, 8.55, 8.52667, 8.53};0.00960324. Why differs from your result? $\endgroup$
    – incognito007
    Sep 1, 2013 at 20:51
  • $\begingroup$ @incognito007 It may be a version problem. The posted results are from 5.2, but 6 gives your results, and 5.2 with the data multiplied by 100 and then rounded also gives your results. I'm working on it. $\endgroup$
    – Ray Koopman
    Sep 2, 2013 at 3:53
4
$\begingroup$

This may not be the optimal solution but may be satisfactory to your needs for these particular lists. Essentially, sort the list, partition into three groups of six. Mix the upper tertile with the lower tertile and then permute the middle till smallest variance obtained.

fun2[u_] := Module[
  {p, res, perm, mn, var, min, pos},
  p = Partition[Sort[u], 6];
  perm = Permutations[p[[2]]];
  res = MapThread[
      Append[#1, #2] &, {Thread[{p[[3]], Reverse[p[[1]]]}], #}] & /@ 
    perm;
  mn = Map[Mean, res, {2}];
  var = Variance /@ mn;
  min = Min[var];
  pos = Position[var, min];
  Thread[{Extract[var, pos], Extract[res, pos]}]
  ]

The results (sometimes not unique are presented as minimum variance of means of subssets and partition with minimum variance.

fun2[list1] yields

{{0.00112333, 
{{8.9, 8.21, 8.46}, {8.95, 8.16, 8.57}, {9.04, 8.09, 
    8.29}, {9.07, 7.98, 8.64}, {9.38, 7.56, 8.68}, {9.43, 7.49, 
    8.73}}}, 
{0.00112333, {{8.9, 8.21, 8.57}, {8.95, 8.16, 
    8.46}, {9.04, 8.09, 8.29}, {9.07, 7.98, 8.64}, {9.38, 7.56, 
    8.68}, {9.43, 7.49, 8.73}}}}

fun2[list2] yields:

{{0.000238519, {{22.75, 22.15, 22.38}, {22.8, 21.92, 22.48}, {23.01, 
    21.79, 22.48}, {23.28, 21.35, 22.64}, {23.5, 21.18, 
    22.51}, {23.54, 21.08, 22.68}}}}

fun2[list3] yields:

{{0.014593, {{39.14, 37.61, 37.88}, {39.31, 37.34, 38.42}, {39.39, 
    37.31, 38.32}, {39.41, 37.19, 38.9}, {39.41, 37.1, 39.06}, {39.43,
     36.33, 39.12}}}}
Improve this answer
$\endgroup$

Your Answer

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

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