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}]
To illustrate my problem here is a toy example:
F[x_] := Module[{out},
If[x > 1,
out = 1/2,
out = 1
];
out
];
The function can be evaluated and plotted. However when I try to numerically integrate it I get an error
NIntegrate[F[x], {x, 0, 2}]
NIntegrate::inumr: The integrand out$831 has evaluated to non-numerical values for all sampling points in the region with boundaries {{0,2}}. >>
Integrate and some other functions will do some probing with symbolic values first. Your Module when given only the symbol x will return only the (aliased) out.
Fix this by defining your F only for numeric values. NIntegrate will discover this and then use numeric values.
In[1]:= F[x_?NumericQ] := Module[{out},
If[x > 1, out = 1/2, out = 1]; out];
NIntegrate[F[x], {x, 0, 2}]
Out[2]= 1.5
This is a fun little problem, and I wanted to check with the experts here if there is a better functional/Mathematica way to approach solving it than what I did. I am not too happy with my solution since I use big IF THEN ELSE in it, but could not find a Mathematica command to use easily to do it (such as Select, Cases, Sow/Reap, Map.. etc...)
Here is the problem, given a list values (numbers or symbols), but for simplicity, lets assume a list of numbers for now. The list can contain zeros and the goal is replace the each zero with the element seen before it.
At the end, the list should contain no zeros in it.
Here is an example, given
a = {1, 0, 0, -1, 0, 0, 5, 0};
the result should be
a = {1, 1, 1, -1, -1, -1, 5, 5}
It should ofcourse be done in the most efficient way.
This is what I could come up with
Scan[(a[[#]] = If[a[[#]] == 0, a[[#-1]], a[[#]]]) &, Range[2, Length[a]]];
I wanted to see if I can use Sow/Reap on this, but did not know how.
question: can this be solved in a more functional/Mathematica way? The shorter the better ofcourse :)
update 1
Thanks everyone for the answer, all are very good to learn from. This is the result of speed test, on V 8.04, using windows 7, 4 GB Ram, intel 930 #2.8 Ghz:
I've tested the methods given for n from 100,000 to 4 million. The ReplaceRepeated method does not do well for large lists.
update 2
Removed earlier result that was shown above in update1 due to my error in copying one of the tests.
The updated results are below. Leonid method is the fastest. Congratulation Leonid. A very fast method.
The test program is the following:
(*version 2.0 *)
runTests[sizeOfList_?(IntegerQ[#] && Positive[#] &)] :=
Module[{tests, lst, result, nasser, daniel, heike, leonid, andrei,
sjoerd, i, names},
nasser[lst_List] := Module[{a = lst},
Scan[(a[[#]] = If[a[[#]] == 0, a[[# - 1]], a[[#]]]) &,
Range[2, Length[a]]]
];
daniel[lst_List] := Module[{replaceWithPrior},
replaceWithPrior[ll_, n_: 0] :=
Module[{prev}, Map[If[# == 0, prev, prev = #] &, ll]
];
replaceWithPrior[lst]
];
heike[lst_List] := Flatten[Accumulate /# Split[lst, (#2 == 0) &]];
andrei[lst_List] := Module[{x, y, z},
ReplaceRepeated[lst, {x___, y_, 0, z___} :> {x, y, y, z},
MaxIterations -> Infinity]
];
leonid[lst_List] :=
FoldList[If[#2 == 0, #1, #2] &, First##, Rest##] & #lst;
sjoerd[lst_List] :=
FixedPoint[(1 - Unitize[#]) RotateRight[#] + # &, lst];
lst = RandomChoice[Join[ConstantArray[0, 10], Range[-1, 5]],
sizeOfList];
tests = {nasser, daniel, heike, leonid, sjoerd};
names = {"Nasser","Daniel", "Heike", "Leonid", "Sjoerd"};
result = Table[0, {Length[tests]}, {2}];
Do[
result[[i, 1]] = names[[i]];
Block[{j, r = Table[0, {5}]},
Do[
r[[j]] = First#Timing[tests[[i]][lst]], {j, 1, 5}
];
result[[i, 2]] = Mean[r]
],
{i, 1, Length[tests]}
];
result
]
To run the tests for length 1000 the command is:
Grid[runTests[1000], Frame -> All]
Thanks everyone for the answers.
Much (order of magnitude) faster than other solutions still:
FoldList[If[#2 == 0, #1, #2] &, First##, Rest##] &
The speedup is due to Fold autocompiling. Will not be so dramatic for non-packed arrays. Benchmarks:
In[594]:=
a=b=c=RandomChoice[Join[ConstantArray[0,10],Range[-1,5]],150000];
(b=Flatten[Accumulate/#Split[b,(#2==0)&]]);//Timing
Scan[(a[[#]]=If[a[[#]]==0,a[[#-1]],a[[#]]])&,Range[2,Length[a]]]//Timing
(c=FoldList[If[#2==0,#1,#2]&,First##,Rest##]&#c);//Timing
SameQ[a,b,c]
Out[595]= {0.187,Null}
Out[596]= {0.625,Null}
Out[597]= {0.016,Null}
Out[598]= True
This seems to be a factor 4 faster on my machine:
a = Flatten[Accumulate /# Split[a, (#2 == 0) &]]
The timings I get are
a = b = RandomChoice[Join[ConstantArray[0, 10], Range[-1, 5]], 10000];
(b = Flatten[Accumulate /# Split[b, (#2 == 0) &]]); // Timing
Scan[(a[[#]] = If[a[[#]] == 0, a[[# - 1]], a[[#]]]) &,
Range[2, Length[a]]] // Timing
SameQ[a, b]
(* {0.015815, Null} *)
(* {0.061929, Null} *)
(* True *)
FixedPoint[(1 - Unitize[#]) RotateRight[#] + # &, d]
is about 10 and 2 times faster than Heike's solutions but slower than Leonid's.
You question looks exactly like a task for ReplaceRepeated function. What it does basically is that it applies the same set of rules to the expression until no more rules are applicable. In your case the expression is a list, and the rule is to replace 0 with its predecessor whenever occurs in a list. So here is the solution:
a = {1, 0, 0, -1, 0, 0, 5, 0};
a //. {x___, y_, 0, z___} -> {x, y, y, z};
The pattern for the rule here is the following:
x___ - any symbol, zero or more repetitions, the beginning of the list
y_ - exactly one element before zero
0 - zero itself, this element will be replaced with y later
z___ - any symbol, zero or more repetitions, the end of the list
In answering a physics forum question this morning, I ran into really bad performance of DifferenceRoot and RecurrenceTable compared to calculating the expressions by naively taking derivatives of an exponential generating functional. A very small amount of digging showed that DifferenceRoot and RecurrenceTable do not simplify expressions as they go.
For example, look at the following output of RecurrenceTable and how it simplifies by just Expanding the result:
In[1]:= RecurrenceTable[f[n] == a f[n - 1] + (a - 1) f[n - 2] &&
f[0] == 0 && f[1] == 1,
f, {n, 6}]
% // Expand
Out[1]= {0, 1, a, -1+a+a^2, -a+a^2+a (-1+a+a^2), 1-a-a^2+a (-1+a+a^2)+a (-a+a^2+a (-1+a+a^2))}
Out[2]= {0, 1, a, -1+a+a^2, -2 a+2 a^2+a^3, 1-2 a-2 a^2+3 a^3+a^4}
This quickly gets out of hand, as the leaf count of the 20th iteration (calculated using DifferenceRoot) shows:
dr[k_] := DifferenceRoot[Function[{f, n},
{f[n] == a f[n - 1] + (a - 1) f[n - 2], f[0] == 0, f[1] == 1}]][k]
In[2]:= dr20 = dr[20]; // Timing
dr20Exp = Expand[dr20]; // Timing
Out[2]= {0.26, Null}
Out[3]= {2.39, Null}
In[4]:= {LeafCount[dr20], LeafCount[dr20Exp]}
Out[4]= {1188383, 92}
Which can be compared to the memoized implementation
In[1]:= mem[n_] := a mem[n-1] + (a-1) mem[n-2] // Expand
mem[0] = 0; mem[1] = 1;
In[3]:= mem20 = mem[20];//Timing
LeafCount[mem20]
Out[3]= {0.48, Null}
Out[4]= 92
So my question is:
Are there any options/tricks to get DifferenceRoot and RecurrenceTable to apply a (simplifying) function as they go and thus make them useful for non-numeric work?
Edit: A Sjoerd pointed out below, I foolishly chose an example with a RSolveable closed form solution. In this question I'm primarily concerned with the behaviour of DifferenceRoot and RecurrenceTable. If it helps, imagine the the f[n-2] term is multiplied by n, so that there is no simple closed form solution.
I can't really help with your question as I haven't used those functions until now, and the docs don't give a clue. But why don't you just use RSolve here? It gives a closed form solution for each of the table's elements:
sol = f /. RSolve[f[n] == a f[n - 1] + (a - 1) f[n - 2] &&
f[0] == 0 && f[1] == 1, f, n
][[1, 1]]
sol#Range[6] // Simplify
I would like to get a List (ideally a set -- discarding repetition -- but assuming there's no direct way to do this I'll just use Union) of the leaves from a given expression.
For example, the expression
ArcTan[(-1 + 2*x)/Sqrt[3]]/Sqrt[3]
has a LeafCount of 18:
-1 (3)
2 (3)
3 (2)
x
ArcTan
Plus
Power (2)
Rational (2)
Times (3)
so I would like something like
{-1, 2, 3, x, ArcTan, Plus, Power, Rational, Times}
Actually, I really just want the functions so
{ArcTan, Plus, Power, Rational, Times}
would be ideal -- but presumably there's some not-too-difficult way to filter these when I have them.
I've had some luck with
H[s_] := If[LeafCount[s] == 1, s, Head[s]]
H /# Level[expr, 1, Heads -> True]
H /# Level[expr, 2, Heads -> True]
(* ... *)
but I feel like there must be a better way.
You could use Cases for this:
In[176]:=
Cases[ArcTan[(-1 + 2*x)/Sqrt[3]]/Sqrt[3], h_[___] :> h,
{0,Infinity}] // DeleteDuplicates
Out[176]= {Rational, Power, Times, Plus, ArcTan}
Your own solution does not seem bad:
expr = ArcTan[(-1 + 2*x)/Sqrt[3]]/Sqrt[3];
H[s_] := If[LeafCount[s] == 1, s, Head[s]]
H /# Level[exp, -1, Heads -> True] // Union
{-1, 2, 3, ArcTan, Plus, Power, Rational, Times, x}
Brett Champion's method is more streamlined, but I would change it a little:
Union#Cases[expr, h_[___] :> h, {0, -1}]
This way you pick up a top level head, such as ArcTan in:
expr = ArcTan[(-1 + 2*x)/Sqrt[3]];
For the original question, one can get all leaves via Level with level spec of {-1} and allowing for heads.
In[87]:= Level[ArcTan[(-1 + 2*x)/Sqrt[3]]/Sqrt[3], {-1}, Heads -> True]
Out[87]= {Times, Power, 3, -(1/2), ArcTan, Times, Power, 3, -(1/
2), Plus, -1, Times, 2, x}
Daniel Lichtblau
Here's what I came up with...
In[92]:= f[e_] := DeleteDuplicates[Prepend[Head[#] & /# Level[e, Depth[e]], Head[e]]]
In[93]:= f[ArcTan[(-1 + 2*x)/Sqrt[3]]/Sqrt[3]]
Out[93]= {Times, Integer, Rational, Power, Symbol, Plus, ArcTan}
You can then easily remove Integer and Symbol.
Edit:
Now let's wrap the expression in a list to make sure we're getting the uppermost head. (The original expression had Times as its head but it was also twice inside.
In[139]:= a = {ArcTan[(-1 + 2*x)/Sqrt[3]]/Sqrt[3]}
In[140]:= TreeForm[a, AspectRatio -> .7]
In[142]:= f[a]
Out[142]= {List, Integer, Rational, Power, Symbol, Times, Plus, ArcTan}