`IntegerPartitions` without duplicates

Question

I need to apply a function to integer partitions of many integers, but only the partitions without duplicate numbers. Select[IntegerPartitions[n], DuplicateFreeQ] is obviously too memory-consuming because it generates all partitions with duplicates first and then selects the partitions without any duplicates; it does not work for large n values (even 100 doesn't work).

Take a look at this:

Length@IntegerPartitions[85]
(* 30167357 *)

Length@Select[IntegerPartitions[85], DuplicateFreeQ]
(* 121792 *)

Only a small portion of the partitions have no duplicates. Is there a way to generate duplicate-free partitions without wasting so much memory?

Edit:

The purpose of this is to find the coefficient of any $x^n$ in: $$ \prod_{i\geq1} {(1+a_i x^i)} $$

The output of IntegerPartitions (without duplicates) is useful because it would simply be Plus @@ Times @@@ (parts[n] /. m_Integer :> a[m]). Coefficient was very slow.

Answer 1

This, based on stackoverflow iterative partitions lets you generate those partitions incrementally and will let you discard those which contain duplicates as you go.

First some test data to make sure this works

Length[IntegerPartitions[20]]

which returns 627 and

Length[Select[IntegerPartitions[20], DuplicateFreeQ]]

which returns 64.

Now a test case which does not discard the duplicates.

partition[target_, maxValue_, suffix_] :=
  If [target == 0, Sow[suffix],
    If [maxValue > 1, partition[target, maxValue-1, suffix]];
    If [maxValue <= target,
      partition[target-maxValue, maxValue, Join[{maxValue}, suffix]]]];
Length[Reap[partition[20, 20, {}]][[2, 1]]]

which returns 627 and finally the version which does discard duplicates

partition[target_, maxValue_, suffix_] :=
  If [target == 0, If[Length[suffix] == Length[Union[suffix]], Sow[suffix]],
    If [maxValue > 1, partition[target, maxValue-1, suffix]];
    If [maxValue <= target,
      partition[target-maxValue, maxValue, Join[{maxValue}, suffix]]]];
Length[Reap[partition[20, 20, {}]][[2, 1]]]

which returns 64.

So the translation into Mathematica looks like it might be working correctly. This also appears to work with substantially larger numbers without running out of memory, but for larger numbers it is going to take substantial time. This looks like it might be a candidate for Compile and it might be feasible to "turn this inside out" to create a generator which could be called repeatedly to generate NextIntegerPartition each time, but I'll leave those ideas for another question.

Can you either replace that Sow[suffix] with Sow[yourFunction[suffix]] or possibly just do your calculations on suffix without Sow[suffix], which should allow much larger n at the expense of likely stunning run times?

But this does appear to satisfy your requirement of generating integer partitions and discard duplicates possibly without needing to hold all of the results in memory at once.

Answer 2

I post this as a modest gain in efficiency. Consider the partition $N$ into distinct integers in ascending order. Let $T_n$ be the largest triangular numberless than $N$. So if there can be a partition of $m>n$ integers then $N=\sum_{j=1}^m a_j$. Now, $N=T_n+\delta<T_{n+1}$ where $0\leq\delta<n+1$. As $a_1\ge1$ and $a_{i+1}-a_i\ge1$ then $N\ge T_{n+1}$: a contradiction. Hence, the the search up to $n$ limits the search space, e.g. need only search up to partitions of length 12.

  ip[num_] := 
 Module[{t}, 
  t[n_] := Floor[x] /. NSolve[x^2 + x - 2 n == 0 && x > 0, x][[1]];
  Select[IntegerPartitions[num, t[num]], DuplicateFreeQ]]

Note:

• Length@ip[85] is 121792

• still exponential time

  res = {#, Timing[ip@#][[1]]} & /@ Range[85];
  ListPlot[res]
  

func[n_] := Select[IntegerPartitions[n], DuplicateFreeQ]
res2 = {#, Timing[func[#]][[1]]} & /@ Range[60];
ListPlot[{res, res2}, Joined -> True, PlotLegends -> {"ip", "func"}]

...only a modest gain....and for the record ip[85] == func[85] yields True.

The experts will not doubt have better constructive approaches.