15
$\begingroup$

Say I have an integer $M$. Is there a one-line command to create a partition of $M$ into $k$ integers s.t. the difference between any two integers is as small as possible?

For example, with $M = 100$ and $k = 10$, we would create the partition: {10,10,10,10,10,10,10,10,10,10}. However, for $k = 7$, we might have the partition: {14,14,14,14,14,14,16}, or better {14,14,14,14,14,15,15}.

For a partial solution, you can of course write:

M = 100;
k = 7;
BalancedPartition = Array[Floor[M/k] &, k];
BalancedPartition[[k]] += M - k*Floor[M/k];
BalancedPartition

{14, 14, 14, 14, 14, 14, 16}

$\endgroup$

6 Answers 6

10
$\begingroup$

I do not know single command to do this (it does not imply it does not exist:)). But it is two-line command:

dec[val_, par_] :=With[{ip = IntegerPart[val/par], md = Mod[val, par]}, 
                       ConstantArray[ip, par-md]~Join~ConstantArray[ip+1, md]]

dec[100, 10]

{10, 10, 10, 10, 10, 10, 10, 10, 10, 10}

dec[100, 7]

{14, 14, 14, 14, 14, 15, 15}

This is straightforward method: for k-integer components md=Mod[val,k] ε [0, k-1] so it is adding 1 to md last positions of final list.

One could use Quotient[val,par] or Floor[val/par] insted of IntegerPart.

Edit. Also:

ConstantArray in place of Table will make this faster. – Michael E2

So I swapped them.

$\endgroup$
2
  • 1
    $\begingroup$ (+1). ConstantArray in place of Table will make this faster. $\endgroup$
    – Michael E2
    Commented Jul 2, 2013 at 20:51
  • $\begingroup$ @MichaelE2 thanks for pointing it out. $\endgroup$
    – Kuba
    Commented Jul 2, 2013 at 21:28
11
$\begingroup$

I like the idea of using IntegerPartitions as that is after all what we are doing. We can use it much more efficiently than Jonathan's answer by restricting the set of integers from which the elements are chosen using the third parameter.

f[m_, k_] := First @ IntegerPartitions[m, {k}, {0,1} + ⌊m/k⌋]

f[100, 7]
{15, 15, 14, 14, 14, 14, 14}

As a fan of terse code I also quite like this fractional carry method using FoldList:

EDIT: I forgot I was using my customized FoldList syntax.. The code below will require it.

EDIT 2: my customized FoldList syntax has been made standard, though undocumented. Hurrah!

f2[m_, k_] := ⌊FoldList[## - ⌊#⌋ &, Table[m/k, {k}]]⌋

f2[100, 7]
 {14, 14, 14, 15, 14, 14, 15}

(Note: ## - ⌊#⌋ is a "clever" way to write # + #2 - ⌊#⌋.)

Or taking a different approach:

f2[m_, k_] := ⌊FoldList[# - ⌊#⌋ + m/k &, m/k, Range[k-1]]⌋
$\endgroup$
5
$\begingroup$

We need a function that produces a list of k elements equal to Quotient[m,k], and then increments Mod[m,k] of them by 1. This seems to be the rationale underlying Kuba's answer ,by the way.

That can be represented by:

   f[m_, k_] := Table[Quotient[m, k], {k}] + PadLeft[Table[1, {Mod[m, k]}], k]

You can retrieve Quotient and Mod from the function QuotientRemainder. The code is a tad longer, but it shows that the key work is being done by a single function.

   f[m_, k_] := Table[#, {k}] + PadLeft[Table[1, {#2}], k] & @@ QuotientRemainder[m, k]

Testing

f[100, #] & /@ Range[29] // Column

table

$\endgroup$
1
  • $\begingroup$ It is the same idea but the shorter the better :) +1 $\endgroup$
    – Kuba
    Commented Jul 2, 2013 at 13:58
4
$\begingroup$

You can use IntegerPartition and set up the following:

With[{x = IntegerPartitions[100, {7}]},With[{y = Max[#] - Min[#] & /@ x}, 
x[[Position[y, Min[y]] // Flatten]]]]

This will take the difference between the max and min values and take those partitions which have the minimum value for that.

$\endgroup$
4
  • $\begingroup$ this will be rather slow for "large" n...? $\endgroup$ Commented Jul 2, 2013 at 9:07
  • $\begingroup$ Yes, you're right, it would be. $\endgroup$ Commented Jul 2, 2013 at 9:26
  • 1
    $\begingroup$ +1 for inspiration. FWIW this can be made much faster (see my answer). $\endgroup$
    – Mr.Wizard
    Commented Jul 2, 2013 at 16:10
  • $\begingroup$ ah, I wasn't really aware of the third argument of IntegerPartions, thanks for pointing that out, @Mr.Wizard! $\endgroup$ Commented Jul 2, 2013 at 16:17
4
$\begingroup$

An approximate table of k lots of M/k rounded down plus a correction. O(k) in speed I think.

f[M_Integer,k_Integer]:=Apply[#+Table[If[i <= M-Total[#],1,0],{i,1,k}]&,{Table[IntegerPart[M/k],{k}]}];

f[100,7]
{15,15,14,14,14,14,14}

The correction can be done in-line too...

f[M_Integer,k_Integer]:=Table[IntegerPart[M/k]+If[i <= M-k*IntegerPart[M/k],1,0],{i,1,k}];

f[100,7]
{15,15,14,14,14,14,14}

Marginally more compact...

f[M_Integer,k_Integer]:=Apply[Table[If[i<=M-k #,#+1,#],{i,1,k}]&,{IntegerPart[M/k]}];
$\endgroup$
4
$\begingroup$

Using basic math:

f[m_, k_] := Floor[Table[m + i - 1, {i, k}] / k];
f[100, 7]

{14, 14, 14, 14, 14, 15, 15}
$\endgroup$
3
  • $\begingroup$ It is going to be slow but I like the compactness of the code. :) $\endgroup$
    – Kuba
    Commented Jul 3, 2013 at 6:03
  • $\begingroup$ Thanks @Kuba. I'm curious about what makes it slow (being a novice at Mathematica). Would it be notably faster with the operations inside the Table? I.e., Table[Floor[(m + i - 1)/k], {i, k}] $\endgroup$
    – xan
    Commented Jul 3, 2013 at 17:21
  • $\begingroup$ Very nice! I feel foolish for not seeing this simple solution. You could also write this f = Quotient[# + Range@#2 - 1, #2] & which is shorter and should also be faster. $\endgroup$
    – Mr.Wizard
    Commented Jul 3, 2013 at 18:19

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.