Mathematica exponentiation and finding a specified coefficient - optimization

Question

I have the following code, and it does exactly what I want it to do, except that it is ridiculously slow. I would not be so bothered, except that when I process the code "manually", i.e., I break it into parts and do them individually, it's near instantaneous.
Here is my code:
Coefficient[Product[Sum[x^(j*Prime[i]), {j, 0, Floor[q/Prime[i]]}],
{i, 1, PrimePi[q]}], x, q]
Picture added for clarity:
I think it is trying to optimize the sum, but am not sure. Is there a way to stop that?
In addition, since all my coefficients are positive, and I only want the x^qth one, is there a way to get Mathematica to discard all exponents that are larger than that and not do all the multiplication with those?

Answer 1

I may be misunderstanding what you want but, as the coefficient will depend on q, I assume you want it evaluated for specific q. Since I suspected (like you) that the time is taken to optimise the produt and sum, I rewrote it. You had something like:
With[{q = 80}, Coefficient[\!\(
\*UnderoverscriptBox[\(\[Product]\), \(i = 1\), \(PrimePi[q]\)]\((
\*UnderoverscriptBox[\(\[Sum]\), \(j = 0\), \(\[LeftFloor]
\*FractionBox[\(q\), \(Prime[i]\)]\[RightFloor]\)]
\*SuperscriptBox[\(x\), \(j*Prime[i]\)])\)\), x, q]] // Timing
(*
-> {8.36181, 10003}
*)
which I rewrote with purely structural operations as
With[{q = 80},
Coefficient[Times ##
Table[Plus ## Table[x^(j*Prime[i]), {j, 0, Floor[q/Prime[i]]}],
{i, 1, PrimePi[q]}], x, q]] // Timing
(*
-> {8.36357, 10003}
*)
(this just builds up a list of the terms and then multiplies them, so no symbolic analysis is performed).
Just building up the polynomial is instantaneous, but it has a few thousand terms, so what is probably happening is that Coefficient spends a lot of time to make sure it has the right coefficient. Actually you can solve this by Expanding the polynomial. Thus:
With[{q = 80}, Coefficient[Expand[\!\(
\*UnderoverscriptBox[\(\[Product]\), \(i = 1\), \(PrimePi[q]\)]\((
\*UnderoverscriptBox[\(\[Sum]\), \(j = 0\), \(\[LeftFloor]
\*FractionBox[\(q\), \(Prime[i]\)]\[RightFloor]\)]
\*SuperscriptBox[\(x\), \(j*Prime[i]\)])\)\)], x, q]] // Timing
(*
-> {0.240862, 10003}
*)
and it also works for my method.
So to summarise, just stick Expand in front of the expression and before you take the coefficient.

Answer 2

I think that the reason that the original code is slow is because Coefficient is made to work even with very large expressions - ones that would not fit into the memory if naively expanded.
Here's the original polynomial:
poly[q_, x_] := Product[Sum[ x^(j*Prime[i]),
{j, 0, Floor[q/Prime[i]]}], {i, 1, PrimePi[q]}]
See how for not too large q, expanding the polynomial takes up a lot more memory and becomes fairly slow:
In[2]:= Through[{LeafCount, ByteCount}[poly[300, x]]] // Timing
Through[{LeafCount, ByteCount}[Expand#poly[300, x]]] // Timing
Out[2]= { 0.01, { 1859, 55864}}
Out[3]= {25.27, {77368, 3175840}}
Now let's define the coefficient in 3 different ways and time them
coeff[q_] := Module[{x}, Coefficient[poly[q, x], x, q]]
exCoeff[q_] := Module[{x}, Coefficient[Expand#poly[q, x], x, q]]
serCoeff[q_] := Module[{x}, SeriesCoefficient[poly[q, x], {x, 0, q}]]
In[7]:= Table[ coeff[q],{q,1,30}]//Timing
Table[ exCoeff[q],{q,1,30}]//Timing
Table[serCoeff[q],{q,1,30}]//Timing
Out[7]= {0.37,{0,1,1,1,2,2,3,3,4,5,6,7,9,10,12,14,17,19,23,26,30,35,40,46,52,60,67,77,87,98}}
Out[8]= {0.12,{0,1,1,1,2,2,3,3,4,5,6,7,9,10,12,14,17,19,23,26,30,35,40,46,52,60,67,77,87,98}}
Out[9]= {0.06,{0,1,1,1,2,2,3,3,4,5,6,7,9,10,12,14,17,19,23,26,30,35,40,46,52,60,67,77,87,98}}
In[10]:= coeff[100]//Timing
exCoeff[100]//Timing
serCoeff[100]//Timing
Out[10]= {56.28,40899}
Out[11]= { 0.84,40899}
Out[12]= { 0.06,40899}
So SeriesCoefficient is definitely the way to go. Unless of course you're
a bit better at combinatorics than me and you know the following prime partition formulae
(oeis)
In[13]:= CoefficientList[Series[1/Product[1-x^Prime[i],{i,1,30}],{x,0,30}],x]
Out[13]= {1,0,1,1,1,2,2,3,3,4,5,6,7,9,10,12,14,17,19,23,26,30,35,40,46,52,60,67,77,87,98}
In[14]:= f[n_]:=Length#IntegerPartitions[n,All,Prime#Range#PrimePi#n]; Array[f,30]
Out[14]= {0,1,1,1,2,2,3,3,4,5,6,7,9,10,12,14,17,19,23,26,30,35,40,46,52,60,67,77,87,98}