Related
I am trying to compute an equation x = (a/(1+r)^1) + (a/(1+r)^2) + (a/(1+r)^3) ... (to infinity); (or to some point like ... +(a/(1+r)^10)
How to input those dots which matheamtica can understand?
Also, how can it, using same or somewhat similar technique understand the input for some simpler expression like 1+3+5+7...+113 (which should be sum of first 114/2 odd numbers)
Thank you
Try these
x = Sum[a/(1 + r)^i, {i, 1, Infinity}]
x = Sum[a/(1 + r)^i, {i, 1, 10}]
x = Sum[2*i - 1, {i, 1, 114/2}]
Currently I am working with some Mathematica code to do a Picard Iteration. The code itself works fine but I am trying to make it more efficient. I have had some success but am looking for suggestions. It may not be possible to speed it up anymore but I have run out of ideas and am hoping people with more experience with programming/Mathematica than me might be able to make some suggestions. I am only posting the Iteration itself but can supply additional information as needed.
The code below was edited to be a fully executable as requested
Also I changed it from a While to a Do loop to make testing easier as convergence is not required.
Clear["Global`*"]
ngrid = 2048;
delr = 4/100;
delk = \[Pi]/delr/ngrid;
rvalues = Table[(i - 1/2) delr, {i, 1, ngrid}];
kvalues = Table[(i - 1/2) delk, {i, 1, ngrid}];
wa[x_] := (19 + .5 x) Exp[-.7 x] + 1
wb[x_] := (19 + .1 x) Exp[-.2 x] + 1
wd = SetPrecision[
Table[{{wa[(i - 1/2) delk], 0}, {0, wb[(i - 1/2) delk]}}, {i, 1,
ngrid}], 26];
sigmaAA = 1;
hcloseAA = {};
i = 1;
While[(i - 1/2)*delr < sigmaAA, hcloseAA = Append[hcloseAA, -1]; i++]
hcloselenAA = Length[hcloseAA];
hcloseAB = hcloseAA;
hcloselenAB = hcloselenAA;
hcloseBB = hcloseAA;
hcloselenBB = hcloselenAA;
ccloseAA = {};
i = ngrid;
While[(i - 1/2)*delr >= sigmaAA, ccloseAA = Append[ccloseAA, 0]; i--]
ccloselenAA = Length[ccloseAA];
ccloselenAA = Length[ccloseAA];
ccloseAB = ccloseAA;
ccloselenAB = ccloselenAA;
ccloseBB = ccloseAA;
ccloselenBB = ccloselenAA;
na = 20;
nb = 20;
pa = 27/(1000 \[Pi]);
pb = 27/(1000 \[Pi]);
p = {{na pa, 0}, {0, nb pb}};
id = {{1, 0}, {0, 1}};
AFD = 1;
AFDList = {};
timelist = {};
gammainitial = Table[{{0, 0}, {0, 0}}, {ngrid}];
gammafirst = gammainitial;
step = 1;
tol = 10^-7;
old = 95/100;
new = 1 - old;
Do[
t = AbsoluteTime[];
extractgAA = Table[Extract[gammafirst, {i, 1, 1}], {i, hcloselenAA}];
extractgBB = Table[Extract[gammafirst, {i, 2, 2}], {i, hcloselenBB}];
extractgAB = Table[Extract[gammafirst, {i, 1, 2}], {i, hcloselenAB}];
csolutionAA = (Join[hcloseAA - extractgAA, ccloseAA]) rvalues;
csolutionBB = (Join[hcloseBB - extractgBB, ccloseBB]) rvalues;
csolutionAB = (Join[hcloseAB - extractgAB, ccloseAB]) rvalues;
chatAA = FourierDST[SetPrecision[csolutionAA, 32], 4];
chatBB = FourierDST[SetPrecision[csolutionBB, 32], 4];
chatAB = FourierDST[SetPrecision[csolutionAB, 32], 4];
chatmatrix =
2 \[Pi] delr Sqrt[2*ngrid]*
Transpose[{Transpose[{chatAA, chatAB}],
Transpose[{chatAB, chatBB}]}]/kvalues;
gammahat =
Table[(wd[[i]].chatmatrix[[i]].(Inverse[
id - p.wd[[i]].chatmatrix[[i]]]).wd[[i]] -
chatmatrix[[i]]) kvalues[[i]], {i, ngrid}];
gammaAA =
FourierDST[SetPrecision[Table[gammahat[[i, 1, 1]], {i, ngrid}], 32],
4];
gammaBB =
FourierDST[SetPrecision[Table[gammahat[[i, 2, 2]], {i, ngrid}], 32],
4];
gammaAB =
FourierDST[SetPrecision[Table[gammahat[[i, 1, 2]], {i, ngrid}], 32],
4];
gammasecond =
Transpose[{Transpose[{gammaAA, gammaAB}],
Transpose[{gammaAB, gammaBB}]}]/(rvalues 2 \[Pi] delr Sqrt[
2*ngrid]);
AFD = Sqrt[
1/ngrid Sum[((gammafirst[[i, 1, 1]] -
gammasecond[[i, 1, 1]])/(gammafirst[[i, 1, 1]] +
gammasecond[[i, 1, 1]]))^2 + ((gammafirst[[i, 2, 2]] -
gammasecond[[i, 2, 2]])/(gammafirst[[i, 2, 2]] +
gammasecond[[i, 2, 2]]))^2 + ((gammafirst[[i, 1, 2]] -
gammasecond[[i, 1, 2]])/(gammafirst[[i, 1, 2]] +
gammasecond[[i, 1, 2]]))^2 + ((gammafirst[[i, 2, 1]] -
gammasecond[[i, 2, 1]])/(gammafirst[[i, 2, 1]] +
gammasecond[[i, 2, 1]]))^2, {i, 1, ngrid}]];
gammafirst = old gammafirst + new gammasecond;
time2 = AbsoluteTime[] - t;
timelist = Append[timelist, time2], {1}]
Print["Mean time per calculation = ", Mean[timelist]]
Print["STD time per calculation = ", StandardDeviation[timelist]]
Just some notes on things
ngrid,delr, delk, rvalues, kvalues are just the values used in making the problem discrete. Typically they are
ngrid = 2048;
delr = 4/100;
delk = \[Pi]/delr/ngrid;
rvalues = Table[(i - 1/2) delr, {i, 1, ngrid}];
kvalues = Table[(i - 1/2) delk, {i, 1, ngrid}];
All matrices being used are 2 x 2 with identical off-diagonals
The identity matrix and the P matrix(it is actually for the density) are
p = {{na pa, 0}, {0, nb pb}};
id = {{1, 0}, {0, 1}};
The major slow spots in the calculation I have identified are the FourierDST calculations (the forward and back transforms account for close to 40% of the calculation time) The gammahat calculation accounts for 40% of the time with the remaining time dominated by the AFD calculation.)
On my i7 Processor the average calculation time per cycle is 1.52 seconds. My hope is to get it under a second but that may not be possible.
My hope had been to introduce some parallel computation this was tried with both ParallelTable commands as well as using the ParallelSubmit WaitAll. However, I found that any speedup from the parallel calculation was offset by the communication time from the Master Kernel to the the other Kernels.(at least that is my assumption as calculations on new data takes twice as long as just recalculating the existing data. I assumed this meant that the slowdown was in disseminating the new lists) I played around with DistributDefinitions as well as SetSharedVariable, however, was unable to get that to do anything.
One thing I am wondering is if using Table for doing my discrete calculations is the best way to do this?
I had also thought I could possibly rewrite this in such a manner as to be able to compile it but my understanding is that only will work if you are dealing with machine precision where I am needing to working with higher precision to get convergence.
Thank you in advance for any suggestions.
I will wait for the code acl suggests, but off the top, I suspect that this construct:
Table[Extract[gammafirst, {i, 1, 1}], {i, hcloselenAA}]
may be written, and will execute faster, as:
gammafirst[[hcloselenAA, 1, 1]]
But I am forced to guess the shape of your data.
In the several lines using:
FourierDST[SetPrecision[Table[gammahat[[i, 1, 1]], {i, ngrid}], 32], 4];
you could remove the Table:
FourierDST[SetPrecision[gammahat[[All, 1, 1]], 32], 4];
And, if you really, really need this SetPrecision, couldn't you do it at once in the calculation of gammahat?
AFAI can see, all numbers used in the calculations of gammahat are exact. This may be on purpose but it is slow. You might consider using approximate numbers instead.
EDIT
With the complete code in your latest edit just adding an //N to your 2nd and 3rd line cuts timing at least in half without reducing numerical accuracy much. If I compare all the numbers in res={gammafirst, gammasecond, AFD} the difference between the original and with //N added is res1 - res2 // Flatten // Total ==> 1.88267*10^-13
Removing all the SetPrecision stuff speeds up the code by a factor of 7 and the results seem to be of similar accuracy.
Inspired by Mike Bantegui's question on constructing a matrix defined as a recurrence relation, I wonder if there is any general guidance that could be given on setting up large block matrices in the least computation time. In my experience, constructing the blocks and then putting them together can be quite inefficient (thus my answer was actually slower than Mike's original code). Join and possibly ArrayFlatten are possibly less efficient than they could be.
Obviously if the matrix is sparse, one can use SparseMatrix constructs, but there will be times when the block matrix you are constructing is not sparse.
What is best practice for this kind of problem? I am assuming the elements of the matrix are numeric.
The code shown below is available here: http://pastebin.com/4PWWxGhB. Just copy and paste it into a notebook to test it out.
I was actually trying to do several functional ways of calculating matrices, since I
figured the functional way (which is typically idiomatic in Mathematica) is more efficient.
As one example, I had this matrix which was composed of two lists:
In: L = 1200;
e = Table[..., {2L}];
f = Table[..., {2L}];
h = Table[0, {2L}, {2L}];
Do[h[[i, i]] = e[[i]], {i, 1, L}];
Do[h[[i, i]] = e[[i-L]], {i, L+1, 2L}];
Do[h[[i, j]] = f[[i]]f[[j-L]], {i, 1, L}, {j, L+1, 2L}];
Do[h[[i, j]] = h[[j, i]], {i, 1, 2 L}, {j, 1, i}];
My first step was to time everything.
In: h = Table[0, {2 L}, {2 L}];
AbsoluteTiming[Do[h[[i, i]] = e[[i]], {i, 1, L}];]
AbsoluteTiming[Do[h[[i, i]] = e[[i - L]], {i, L + 1, 2 L}];]
AbsoluteTiming[
Do[h[[i, j]] = f[[i]] f[[j - L]], {i, 1, L}, {j, L + 1, 2 L}];]
AbsoluteTiming[Do[h[[i, j]] = h[[j, i]], {i, 1, 2 L}, {j, 1, i}];]
Out: {0.0020001, Null}
{0.0030002, Null}
{5.0012861, Null}
{4.0622324, Null}
DiagonalMatrix[...] was slower than the do loops, so I decided to just use Do loops on the last step. As you can see, using Outer[Times, f, f] was much faster in this case.
I then wrote the equivalent using Outer for the blocks in the upper right and bottom left of the matrix, and DiagonalMatrix for the diagonal:
AbsoluteTiming[h1 = ArrayPad[Outer[Times, f, f], {{0, L}, {L, 0}}];]
AbsoluteTiming[h1 += Transpose[h1];]
AbsoluteTiming[h1 += DiagonalMatrix[Join[e, e]];]
Out: {0.9960570, Null}
{0.3770216, Null}
{0.0160009, Null}
The DiagonalMatrix was actually slower. I could replace this with just the Do loops, but I kept it because it was cleaner looking.
The current tally is 9.06 seconds for the naive Do loop, and 1.389 seconds for my next version using Outer and DiagonalMatrix. About a 6.5 times speedup, not too bad.
Sounds a lot faster, now doesn't it? Let's try using Compile now.
In: cf = Compile[{{L, _Integer}, {e, _Real, 1}, {f, _Real, 1}},
Module[{h},
h = Table[0.0, {2 L}, {2 L}];
Do[h[[i, i]] = e[[i]], {i, 1, L}];
Do[h[[i, i]] = e[[i - L]], {i, L + 1, 2 L}];
Do[h[[i, j]] = f[[i]] f[[j - L]], {i, 1, L}, {j, L + 1, 2 L}];
Do[h[[i, j]] = h[[j, i]], {i, 1, 2 L}, {j, 1, i}];
h]];
AbsoluteTiming[cf[L, e, f];]
Out: {0.3940225, Null}
Now it's running 3.56 times faster than my last version, and 23.23 times faster than the first one. Next version:
In: cf = Compile[{{L, _Integer}, {e, _Real, 1}, {f, _Real, 1}},
Module[{h},
h = Table[0.0, {2 L}, {2 L}];
Do[h[[i, i]] = e[[i]], {i, 1, L}];
Do[h[[i, i]] = e[[i - L]], {i, L + 1, 2 L}];
Do[h[[i, j]] = f[[i]] f[[j - L]], {i, 1, L}, {j, L + 1, 2 L}];
Do[h[[i, j]] = h[[j, i]], {i, 1, 2 L}, {j, 1, i}];
h], CompilationTarget->"C", RuntimeOptions->"Speed"];
AbsoluteTiming[cf[L, e, f];]
Out: {0.1370079, Null}
Most of the speed came from CompilationTarget->"C". Here I got another 2.84 speedup over the fastest version, and 66.13 times speedup over the first version. But all I did was just compile it!
Now, this is a very simple example. But this is real code I'm using to solve a problem in condensed matter physics. So don't dismiss it as possibly being a "toy example."
How's about another example of a technique we can use? I have a relatively simple matrix I have to build up. I have a matrix that's composed of nothing but ones from the start to some arbitrary point. The naive way may look something like this:
In: k = L;
AbsoluteTiming[p = Table[If[i == j && j <= k, 1, 0], {i, 2L}, {j, 2L}];]
Out: {5.5393168, Null}
Instead, let's build it up using ArrayPad and IdentityMatrix:
In: AbsoluteTiming[ArrayPad[IdentityMatrix[k], {{0, 2L-k}, {0, 2L-k}}
Out: {0.0140008, Null}
This actually doesn't work for k = 0, but you can special case that if you need that. Furthermore, depending on the size of k, this can be faster or slower. It's always faster than the Table[...] version though.
You could even write this using SparseArray:
In: AbsoluteTiming[SparseArray[{i_, i_} /; i <= k -> 1, {2 L, 2 L}];]
Out: {0.0040002, Null}
I could go on about some other things, but I'm afraid if I do I'll make this answer unreasonably large. I've accumulated a number of techniques for forming these various matrices and lists in the time I spent trying to optimize some code. The base code I worked with took over 6 days for one calculation to run, and now it takes only 6 hours to do the same thing.
I'll see if I can pick out the general techniques I've come up with and just stick them in a notebook to use.
TL;DR: It seems like for these cases, the functional way outperforms the procedural way. But when compiled, the procedural code outperforms the functional code.
Looking at what Compile does to Do loops is instructive. Consider this:
L=1200;
Do[.7, {i, 1, 2 L}, {j, 1, i}] // Timing
Do[.3 + .4, {i, 1, 2 L}, {j, 1, i}] // Timing
Do[.3 + .4 + .5, {i, 1, 2 L}, {j, 1, i}] // Timing
Do[.3 + .4 + .5 + .8, {i, 1, 2 L}, {j, 1, i}] // Timing
(*
{0.390163, Null}
{1.04115, Null}
{1.95333, Null}
{2.42332, Null}
*)
First, it seems safe to assume that Do does not automatically compile its argument if it's over some length (as Map, Nest etc do): you can keep adding constants and the derivative of time taken vs number of constants is constant. This is further supported by the nonexistence of such an option in SystemOptions["CompileOptions"].
Next, since this loops around n(n-1)/2 times with n=2*L, so around 3*10^6 times for our L=1200, the time taken for each addition indicates that there is a lot more going on than is necessary.
Next let us try
Compile[{{L,_Integer}},Do[.7,{i,1,2 L},{j,1,i}]]#1200//Timing
Compile[{{L,_Integer}},Do[.7+.7,{i,1,2 L},{j,1,i}]]#1200//Timing
Compile[{{L,_Integer}},Do[.7+.7+.7+.7,{i,1,2 L},{j,1,i}]]#1200//Timing
(*
{0.032081, Null}
{0.032857, Null}
{0.032254, Null}
*)
So here things are more reasonable. Let's take a look:
Needs["CompiledFunctionTools`"]
f1 = Compile[{{L, _Integer}},
Do[.7 + .7 + .7 + .7, {i, 1, 2 L}, {j, 1, i}]];
f2 = Compile[{{L, _Integer}}, Do[2.8, {i, 1, 2 L}, {j, 1, i}]];
CompilePrint[f1]
CompilePrint[f2]
the two CompilePrints give the same output, namely,
1 argument
9 Integer registers
Underflow checking off
Overflow checking off
Integer overflow checking on
RuntimeAttributes -> {}
I0 = A1
I5 = 0
I2 = 2
I1 = 1
Result = V255
1 I4 = I2 * I0
2 I6 = I5
3 goto 8
4 I7 = I6
5 I8 = I5
6 goto 7
7 if[ ++ I8 < I7] goto 7
8 if[ ++ I6 < I4] goto 4
9 Return
f1==f2 returns True.
Now, do
f5 = Compile[{{L, _Integer}}, Block[{t = 0.},
Do[t = Sin[i*j], {i, 1, 2 L}, {j, 1, i}]; t]];
f6 = Compile[{{L, _Integer}}, Block[{t = 0.},
Do[t = Sin[.45], {i, 1, 2 L}, {j, 1, i}]; t]];
CompilePrint[f5]
CompilePrint[f6]
I won't show the full listings, but in the first there is a line R3 = Sin[ R1] while in the second there is an assignment to a register R1 = 0.43496553411123023 (which, however, is reassigned in the innermost part of the loop by R2 = R1; perhaps if we output to C this will be optimized by gcc eventually).
So, in these very simple cases, uncompiled Do just blindly executes the body without inspecting it, while Compile does do various simple optimizations (in addition to outputing byte code). While here I am choosing examples that exaggerate how literally Do interprets its argument, this kind of thing partly explains the large speedup after compiling.
As for the huge speedup in Mike Bantegui's question yesterday, I think the speedup in such simple problems (just looping and multiplying things) is because there is no reason that automatically produced C code can't be optimized by the compiler to get things running as fast as possible. The C code produced is too hard to understand for me, but the bytecode is readable and I don't think that there is anything all that wasteful. So it is not that shocking that it is so fast when compiled to C. Using built-in functions shouldn't be any faster than that, since there shouldn't be any difference in the algorithm (if there is, the Do loop shouldn't have been written that way).
All this should be checked case by case, of course. In my experience, Do loops usually are the fastest way to go for this kind of operation. However, compilation has its limits: if you are producing large objects and trying to pass them around between two compiled functions (as arguments), the bottleneck can be this transfer. One solution is to simply put everything into one giant function and compile that; this ends up being harder and harder to do (you are forced to write C in mma, so to speak). Or you can try compiling the individual functions and using CompilationOptions -> {"InlineCompiledFunctions" -> True}] in the Compile. Things can get tricky very fast, though.
But this is getting too long.
This is an example. I want to know if there is a general way to deal with this kind of problems.
Suppose I have a function (a ε ℜ) :
f[a_, n_Integer, m_Integer] := Sum[a^i k[i],{i,0,n}]^m
And I need a closed form for the coefficient a^p. What is the better way to proceed?
Note 1:In this particular case, one could go manually trying to represent the sum through Multinomial[ ], but it seems difficult to write down the Multinomial terms for a variable number of arguments, and besides, I want Mma to do it.
Note 2: Of course
Collect[f[a, 3, 4], a]
Will do, but only for a given m and n.
Note 3: This question is related to this other one. My application is different, but probably the same methods apply. So, feel free to answer both with a single shot.
Note 4:
You can model the multinomial theorem with a function like:
f[n_, m_] :=
Sum[KroneckerDelta[m - Sum[r[i], {i, n}]]
(Multinomial ## Sequence#Array[r, n])
Product[x[i]^r[i], {i, n}],
Evaluate#(Sequence ## Table[{r[i], 0, m}, {i, 1, n}])];
So, for example
f[2,3]
is the cube of a binomial
x[1]^3+ 3 x[1]^2 x[2]+ 3 x[1] x[2]^2+ x[2]^3
The coefficient by a^k can be viewed as derivative of order k at zero divided by k!. In version 8, there is a function BellY, which allows to construct a derivative at a point for composition of functions, out of derivatives of individual components. Basically, for f[g[x]] and expanding around x==0 we find Derivative[p][Function[x,f[g[x]]][0] as
BellY[ Table[ { Derivative[k][f][g[0]], Derivative[k][g][0]}, {k, 1, p} ] ]/p!
This is also known as generalized Bell polynomial, see wiki.
In the case at hand:
f[a_, n_Integer, m_Integer] := Sum[a^i k[i], {i, 0, n}]^m
With[{n = 3, m = 4, p = 7},
BellY[ Table[{FactorialPower[m, s] k[0]^(m - s),
If[s <= n, s! k[s], 0]}, {s, 1, p}]]/p!] // Distribute
(*
Out[80]= 4 k[1] k[2]^3 + 12 k[1]^2 k[2] k[3] + 12 k[0] k[2]^2 k[3] +
12 k[0] k[1] k[3]^2
*)
With[{n = 3, m = 4, p = 7}, Coefficient[f[a, n, m], a, p]]
(*
Out[81]= 4 k[1] k[2]^3 + 12 k[1]^2 k[2] k[3] + 12 k[0] k[2]^2 k[3] +
12 k[0] k[1] k[3]^2
*)
Doing it this way is more computationally efficient than building the entire expression and extracting coefficients.
EDIT The approach here outlined will work for symbolic orders n and m, but requires explicit value for p. When using it is this circumstances, it is better to replace If with its Piecewise analog, e.g. Boole:
With[{p = 2},
BellY[Table[{FactorialPower[m, s] k[0]^(m - s),
Boole[s <= n] s! k[s]}, {s, 1, p}]]/p!]
(* 1/2 (Boole[1 <= n]^2 FactorialPower[m, 2] k[0]^(-2 + m)
k[1]^2 + 2 m Boole[2 <= n] k[0]^(-1 + m) k[2]) *)
For example, I have the following recursion and I want to get f[3,n]:
f[m_, n_] := Module[{}, If[m < 0, Return[0];];
If[m == 0, Return[1];];
If[2*m - 1 >= n, Return[0];];
If[2*m == n, Return[2];];
If[m == 1, Return[n];];
Return[f[m, n - 1] + f[m - 1, n - 2]];]
f[3, n]
The code does not seem to work. Please help. Many thanks!
You have an infinite recursion because when m is not initialized, none of the boundary cases match.
Instead of using Return you'll get more predictable behavior if you use functional programming, ie
f[m_, n_] := Which[
m < 0, 0,
2 m - 1 >= n, 0,
2 m == n, 2,
m == 1, n,
True, f[m, n - 1] + f[m - 1, n - 2]
]
In this case Which can not decide which option to take with n not initialized, so f[3, n] will return an expression.
One way to get a formula is with RSolve. Doesn't look like it can solve this equation in full generality, but you can try it with one variable fixed using something like this
Block[{m = 3},
RSolve[f[m, n] == f[m, n - 1] + f[m - 1, n - 2], f[m, n], {n}]
]
In the result you will see K[1] which is an arbitrary iteration variable and C[1] which is a free constant. It's there because boundary case is not specified