Skip to main content

performance tuning - Improving speed of code computing number of nonrepeating partitions


I need to answer the following for a number of parameters: How many ways can the integer $k$ be written as a sum of $n$ different integers ranging from $1$ to $m$?


My initial attempt was the following function:


NumberOfWays[k_, n_, m_] := 
Count[Map[Length,
Map[DeleteDuplicates,
IntegerPartitions[k, {n}, Range[m]]]],
n];


This works, but becomes very slow as the parameters get big. I then thought I might do it using a generating function and attempted the following:


GenFuncy[m_] := Product[1 + y*x^j, {j, 1, m}];
NumberOfWays2[k_, n_, m_] := Coefficient[GenFuncy[m], x^k*y^n];

Again this works, but surprisingly (to me) it is even slower.


Is there any way I can speed these functions up, or maybe another faster way to do the calculation altogether?



Answer



This seems pretty quick, particularly on larger cases / larger k, e.g. 451, 29, 101 finishes in a few seconds on the loungebook.


N.B. - I have not tested this exhaustively, just thrown together from ideas...



If[Min[#3, #1 - Tr@Range@(#2 - 1)] < 0, 0, 
SeriesCoefficient[QPochhammer[-x y, x, Min[#3, #1 - Tr@Range@(#2 - 1)]],
{x , 0, #1}, {y, 0, #2}]] &[n, k, m]

UPDATE:


This seems to be very fast, particularly on larger cases. n.b.: posted with testing in progress, I'd like to prove correctness, but so far empirical testing matches prior methods, and appears faster than answers prior on large cases...


myDP[n_, k_, m_] := If[n < Binomial[k + 1, 2] || m < k, 0, 
SeriesCoefficient[QBinomial[m, k, q], {q, 0, n - Binomial[k + 1, 2]}]]

For a huge case of {n, k, m} = {5050, 100, 5050} this took a fraction of a second on the loungebook to return the result of 1 (for this case, there would be ~$2.74235\times 10^{68}$ partitions generated for any of the partition massaging methods like the OP's NumberOfWays, making use of these absurd for anything other than minimal cases.) The neat follow-up solution from KennyColnago took (unsure - aborted it after 5 minutes, monitoring progress indicated over an hour would be needed, figure 10X faster or so for both on a workstation...) for the same case - but I'd prefer to perhaps have his benchmark post extended with results on his hardware for a fair comparison.



Update 2: A further optimization, taking advantage of the symmetry of the gaussian polynomial:


myDPc[n_, k_, m_] := 
Module[{mn = Binomial[k + 1, 2], mx = (k - k^2 + 2 k m)/2},
If[mn <= n <= mx && m >= k,
SeriesCoefficient[QBinomial[Min[n - Binomial[k, 2], m], k, q],
{q, 0, If[n > (mn + mx)/2, mx - n, n - mn]}],0]];

On an exhaustive search for all valid n for {k,m}={45,60} this was over 4X faster than myDP, and for large cases (e.g., {n,k,m}={18775, 50, 400} it was over 20,000X faster than myDP.


There's an additional optimization possible that might be advantageous when searching ranges of {n,k,m}: for any given {n,k,m}, by symmetry of the Q-Binomial, there's a dual of {n', k',m} where n' and k' are simple transformations of n and k that has precisely the same polynomial. Memoization on that can about double the performance for such searches.


Update 3 2015/08/20: Added an optimization (in edited myDPc above) for larger k, resulting in over 2 orders of magnitude performance boost to e.g. {n,k,m}={5100,100,5100} and about three orders of magnitude boost to {n,k,m}={12000,154,12000}.



I think I've run out of ideas...


Comments

Popular posts from this blog

plotting - Filling between two spheres in SphericalPlot3D

Manipulate[ SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, Mesh -> None, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], {n, 0, 1}] I cant' seem to be able to make a filling between two spheres. I've already tried the obvious Filling -> {1 -> {2}} but Mathematica doesn't seem to like that option. Is there any easy way around this or ... Answer There is no built-in filling in SphericalPlot3D . One option is to use ParametricPlot3D to draw the surfaces between the two shells: Manipulate[ Show[SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], ParametricPlot3D[{ r {Sin[t] Cos[1.5 Pi], Sin[t] Sin[1.5 Pi], Cos[t]}, r {Sin[t] Cos[0 Pi], Sin[t] Sin[0 Pi], Cos[t]}}, {r, 1, 2 - n}, {t, 0, Pi}, PlotStyle -> Yellow, Mesh -> {2, 15}]], {n, 0, 1}]

plotting - Plot 4D data with color as 4th dimension

I have a list of 4D data (x position, y position, amplitude, wavelength). I want to plot x, y, and amplitude on a 3D plot and have the color of the points correspond to the wavelength. I have seen many examples using functions to define color but my wavelength cannot be expressed by an analytic function. Is there a simple way to do this? Answer Here a another possible way to visualize 4D data: data = Flatten[Table[{x, y, x^2 + y^2, Sin[x - y]}, {x, -Pi, Pi,Pi/10}, {y,-Pi,Pi, Pi/10}], 1]; You can use the function Point along with VertexColors . Now the points are places using the first three elements and the color is determined by the fourth. In this case I used Hue, but you can use whatever you prefer. Graphics3D[ Point[data[[All, 1 ;; 3]], VertexColors -> Hue /@ data[[All, 4]]], Axes -> True, BoxRatios -> {1, 1, 1/GoldenRatio}]

plotting - Mathematica: 3D plot based on combined 2D graphs

I have several sigmoidal fits to 3 different datasets, with mean fit predictions plus the 95% confidence limits (not symmetrical around the mean) and the actual data. I would now like to show these different 2D plots projected in 3D as in but then using proper perspective. In the link here they give some solutions to combine the plots using isometric perspective, but I would like to use proper 3 point perspective. Any thoughts? Also any way to show the mean points per time point for each series plus or minus the standard error on the mean would be cool too, either using points+vertical bars, or using spheres plus tubes. Below are some test data and the fit function I am using. Note that I am working on a logit(proportion) scale and that the final vertical scale is Log10(percentage). (* some test data *) data = Table[Null, {i, 4}]; data[[1]] = {{1, -5.8}, {2, -5.4}, {3, -0.8}, {4, -0.2}, {5, 4.6}, {1, -6.4}, {2, -5.6}, {3, -0.7}, {4, 0.04}, {5, 1.0}, {1, -6.8}, {2, -4.7}, {3, -1.