Problem performing a substitution in a multiple derivative - wolfram-mathematica

I have a basic problem in Mathematica which has puzzled me for a while. I want to take the m'th derivative of x*Exp[t*x], then evaluate this at x=0. But the following does not work correct. Please share your thoughts.
D[x*Exp[t*x], {x, m}] /. x -> 0
Also what does the error mean
General::ivar: 0 is not a valid variable.
Edit: my previous example (D[Exp[t*x], {x, m}] /. x -> 0) was trivial. So I made it harder. :)
My question is: how to force it to do the derivative evaluation first, then do substitution.

As pointed out by others, (in general) Mathematica does not know how to take the derivative an arbitrary number of times, even if you specify that number is a positive integer.
This means that the D[expr,{x,m}] command remains unevaluated and then when you set x->0, it's now trying to take the derivative with respect to a constant, which yields the error message.
In general, what you want is the m'th derivative of the function evaluated at zero.
This can be written as
Derivative[m][Function[x,x Exp[t x]]][0]
or
Derivative[m][# Exp[t #]&][0]
You then get the table of coefficients
In[2]:= Table[%, {m, 1, 10}]
Out[2]= {1, 2 t, 3 t^2, 4 t^3, 5 t^4, 6 t^5, 7 t^6, 8 t^7, 9 t^8, 10 t^9}
But a little more thought shows that you really just want the m'th term in the series, so SeriesCoefficient does what you want:
In[3]:= SeriesCoefficient[x*Exp[t*x], {x, 0, m}]
Out[3]= Piecewise[{{t^(-1 + m)/(-1 + m)!, m >= 1}}, 0]
The final output is the general form of the m'th derivative. The PieceWise is not really necessary, since the expression actually holds for all non-negative integers.

Thanks to your update, it's clear what's happening here. Mathematica doesn't actually calculate the derivative; you then replace x with 0, and it ends up looking at this:
D[Exp[t*0],{0,m}]
which obviously is going to run into problems, since 0 isn't a variable.

I'll assume that you want the mth partial derivative of that function w.r.t. x. The t variable suggests that it might be a second independent variable.
It's easy enough to do without Mathematica: D[Exp[t*x], {x, m}] = t^m Exp[t*x]
And if you evaluate the limit as x approaches zero, you get t^m, since lim(Exp[t*x]) = 1. Right?
Update: Let's try it for x*exp(t*x)
the mth partial derivative w.r.t. x is easily had from Wolfram Alpha:
t^(m-1)*exp(t*x)(t*x + m)
So if x = 0 you get m*t^(m-1).
Q.E.D.

Let's see what is happening with a little more detail:
When you write:
D[Sin[x], {x, 1}]
you get an expression in with x in it
Cos[x]
That is because the x in the {x,1} part matches the x in the Sin[x] part, and so Mma understands that you want to make the derivative for that symbol.
But this x, does NOT act as a Block variable for that statement, isolating its meaning from any other x you have in your program, so it enables the chain rule. For example:
In[85]:= z=x^2;
D[Sin[z],{x,1}]
Out[86]= 2 x Cos[x^2]
See? That's perfect! But there is a price.
The price is that the symbols inside the derivative get evaluated as the derivative is taken, and that is spoiling your code.
Of course there are a lot of tricks to get around this. Some have already been mentioned. From my point of view, one clear way to undertand what is happening is:
f[x_] := x*Exp[t*x];
g[y_, m_] := D[f[x], {x, m}] /. x -> y;
{g[p, 2], g[0, 1]}
Out:
{2 E^(p t) t + E^(p t) p t^2, 1}
HTH!

Related

How to preserve results from Maximize in Mathematica?

I aim to calculate and preserve the results from the maximization of a function with two arguments and one exogenous parameter, when the maximum can not be derived (in closed form) by maximize. For instance, let
f[x_,y_,a_]=Max[0,Min[a-y,1-x-y]
be the objective function where a is positive. The maximization shall take place over [0,1]^2, therefore I set
m[a_]=Maximize[{f[x, y, a], 0 <= x <= 1 && 0 <= y <= 1 && 0 <= a}, {x,y}]
Obviously m can be evaluated at any point a and it is therefore possible to plot the maximizing x by employing
Plot[x /. m[a][[2]], {a, 0.01, 1}]
As I need to do several plots and further derivations containing the optimal solutions x and y (which of course are functions of a), i would like to preserve/save the results from the optimization for further use. Is there an elegant way to do this, or do I have to write some kind of loop to extract the values myself?
Now that I've seen the full text of your comment on my original comment, I suspect that you do understand the differences between Set and SetDelayed well enough. I think what you may be looking for is memoisation, sometimes implemented a bit like this;
f[x_,y_] := f[x,y] = Max[0,Min[a-y,1-x-y]]
When you evaluate, for example f[3,4] for the first time it will evaluate to the entire expression to the right of the :=. The rhs is the assignment f[3,4] = Max[0,Min[a-y,1-x-y]]. Next time you evaluate f[3,4] Mathematica already has a value for it so doesn't need to recompute it, it just recalls it. In this example the stored value would be Max[0,Min[a-4,-6]] of course.
I remain a little uncertain of what you are trying to do so this answer may not be any use to you at all.
Simple approach
results = Table[{x, y, a} /. m[a][[2]], {a, 0.01, 1, .01}]
ListPlot[{#[[3]], #[[1]]} & /# results, Joined -> True]
(The Set = is ok here so long as 'a' is not previosly defined )
If you want to utilise Plot[]s automatic evaluation take a look at Reap[]/Sow[]
{p, data} = Reap[Plot[x /. Sow[m[a]][[2]], {a, 0.01, 1}]];
Show[p]
(this takes a few minutes as the function output is a mess..).
hmm try this again: assuming you want x,y,a and the minimum value:
{p, data} = Reap[Plot[x /. Sow[{a, m[a]}][[2, 2]], {a, 0.01, .1}]];
Show[p]
results = {#[[1]], x /. #[[2, 2]], y /. #[[2, 2]], #[[2, 1]]} & /# data[[1]]
BTW Your function appears to be independent of x over some ranges which is why the plot is a mess..

Find the 1st intersection of 2 PDF functions with Mathematica

With Mathematica 8.0.1.0, I have used FindRoot[] to identify the intersection of two 2 pdf functions.
But if I have pdf functions that intersect at more than one point, and I have the upper limit of the x axis range beyond the second intersection, FindRoot[] only returns the second intersection.
pdf1 = 1/x 0.5795367855565214` (E^(
11.170058830053032` (-1.525439351903338` - Log[x]))
Erfc[1.6962452696714152` (-0.5548887795964352` - Log[x])] +
E^(1.2932713057519` (2.60836043407439` + Log[x]))
Erfc[1.6962452696714152` (2.720730943938539` + Log[x])]);
pdf2 = 1/x 0.4648445097126269` (E^(
5.17560914275408` (-2.5500941338198615` - Log[x]))
Erfc[1.7747318880142482` (-2.139288893723375` - Log[x])] +
E^(1.1332542415053757` (3.050849516581922` + Log[x]))
Erfc[1.7747318880142482` (3.1407996592474956` + Log[x])]);
Plot[{pdf1, pdf2}, {x, 0, 0.5}, PlotRange -> All] (* Shows 1st intersection *)
Plot[{pdf1, pdf2}, {x, 0.4, 0.5}, PlotRange -> All] (* Shows 2nd intersection *)
{x /. FindRoot[pdf1 == pdf2, {x, 0.00001, 0.5}],
x /. FindRoot[pdf1 == pdf2, {x, 0.00001, 0.4}]}
The above plots show the issue. When plotted they intersect at two points:
{0.464719, 0.0452777}
respectively.
As I can't know before hand if I'll have a second intersection and I don't know where it might fall on the x axis if I did, can anyone suggest a way to have FindRoot[] only return the first intersection rather than the second?
If not, can anyone suggest another way to go about it?
With FindRoot[], you can only get a single root for a given starting point. Iterating through different options is cumbersome and you might not even get the desired result for certain edge cases unless you hit upon the right choice of starting point.
In this case, something like NSolve or Reduce might be a better option. If you know that your expressions decay, using a reasonable upper bound for possible values of x, you can use the following, which is pretty quick and will give you all roots.
NSolve[{pdf1 == pdf2, 0 < x < 1}, x] // Timing
Out[1]= {0.073495, {{x -> 0.0452777}, {x -> 0.464719}}}
How about the following:
First you have to find all roots in one step. I do this with
roots=Reduce[pdf1==pdf2&&0.000001<x<0.5,x]
And then you could take the minimum (first root on the x axis in your special case).
rootMin=Min[N[x/.{ToRules[roots]}]]

NIntegrate fails to converge near a point that is not inside my definite integral?

I am trying to calculate a definite integral. I write:
NIntegrate[expression, {x, 0, 1}, WorkingPrecision -> 100]
"expression" is described below. The WorkingPrecision was added in to help with another error.
I get an error:
"NIntegrate::ncvb: NIntegrate failed to converge to prescribed
accuracy after 9 recursive bisections in x near {x} = {<<156>>}.
NIntegrate obtained <<157>> and <<160>> for the integral and error
estimates. >>"
Why am I getting this error for near{x} = {<<156>>} when I am only looking at 0<x<1? And what do the double pointy brackets around the number mean?
The expression is really long, so I think it would be more meaningful to show how I generate it.This is a basic version (some of the exponents I need to be variables, but these are the lowest values, and I still get the error).
F[n_] := (1 - (1 - F[n-1])^2)^2;
F[0] = x;
Expr[n_]:= (1/(1-F[n]))Integrate[D[F[n],x]*x,{x,x,1}];
I get the error when I integrate Expr[3] or higher. Oddly, when I use regular Integrate and then //N at the end, I get a complex number for n=2.
The <<156>> does not mean that the integral is being evaluated at x=156. <<>> is called Skeleton and is used to indicate that a large output was suppressed. From the documentation:
Skeleton[n]
represents a sequence of n omitted elements in an expression printed with Short or Shallow. The standard print form for Skeleton is <<n>>.
Coming to your integral, here's the error that I get:
So you can see that this long number was suppressed in your case (depending on your preferences). The last >> is a link that takes you to the corresponding error message in the documentation.
If you try the advice in the document, which is to increase MaxRecursion, you'll eventually get a new error ::slwcon
So this now tells you that either your WorkingPrecision is too small or that you have a singularity (which is brought on by a small working precision). Increasing WorkingPrecision to 200 gives the following output:
You can look a little further into the nature of your expressions.
num = Numerator#Expr#3;
den = Denominator#Expr#3;
Plot[{num, den}, {x, 0, 1}, WorkingPrecision -> 100, PlotRange -> All]
So beyond 0.7ish, your expression has the potential for serious stability issues, resulting in singularities. It is the numerator rather than the denominator, that requires high precision to converge to the right value.
num /. x -> 0.99
num /. x -> 0.99`100
Out[1]= -0.015625
Out[2]= 1.2683685178049112809413795626911317545171610885215799438968\
06379991565*10^-14
den /. x -> 0.99
den /. x -> 0.99`100
Out[3]= 1.28786*10^-14
Out[4]= 1.279743968014714505561671861369465844697720803022743298030747945923286\
915425027352809730413954909*10^-14
You can see here the difference between the numerator and denominator when you don't have sufficient precision, causing a near singularity.

How do you interpret negative levels in Mathematica?

I am trying to gain a deeper understanding of how Mathematica expressions are represented internally, and am puzzled by the logic of the Level command in Mathematica. If we have the following input:
In[1]:= a = z*Sin[x + y] + z1*Cos[x1 + y1]
Out[1]= z1 Cos[x1 + y1] + z Sin[x + y]
In[2]:= FullForm[a]
Out[2]= Plus[Times[z1,Cos[Plus[x1,y1]]],Times[z,Sin[Plus[x,y]]]]
In[3]:= TreeForm[a]
We get the following tree:
If we ask Mathematica to return Level 4 only, we get:
In[4]:= Level[a,{4}]
Out[4]= {x1,y1,x,y}
I understand that we are 4 levels down from the "stem" (the Plus operator at Level 0). In fact, I think I understand that positive indexes are always in relation to the stem position of the tree. (I hope I'm correct about that??)
In contrast, when you ask for a negative level, there is no common reference point (like the stem above), because different branches of the tree are of varying lengths. So, if you ask Mathematica to provide only Level -1, we get:
In[6]:= Level[a,{-1}]
Out[6]= {z1,x1,y1,z,x,y}
I was surprised by this output, when I had guessed that I should get back {x1, y1, x, y} (without z1 & z). But ok, if I try to understand this, I take -1 to mean "the end of each branch". If this is so, then I would expect Level[a,{-2}] to return:
{z1*Cos[x1+y1],z*Sin[x+y],x1+y1,x+y}
But, this is not what I get back, Mathematica yields:
In[8]:= Level[a,{-2}]
Out[8]= {x1+y1,x+y}
So, now I am confused, and don't see a consistent way of understanding the output of negative levels.
Is there a consistent, easier way of understanding this topic? Is there a certain "correct" way I should be reading the structure of the tree?
Sorry for the "long-winded question", but I hope you understand what I am asking.
If you look at the docs, they say:
A negative level -n consists of all parts of expr with depth n.
So negative levels are not counted from a reference point, but are defined based on the depth of subexpressions. z1*Cos[x1+y1] is of depth 4, so it's not returned when you ask for Level[..., {-2}].

Mathematica: reconstruct an arbitrary nested list after Flatten

What is the simplest way to map an arbitrarily funky nested list expr to a function unflatten so that expr==unflatten##Flatten#expr?
Motivation:
Compile can only handle full arrays (something I just learned -- but not from the error message), so the idea is to use unflatten together with a compiled version of the flattened expression:
fPrivate=Compile[{x,y},Evaluate#Flatten#expr];
f[x_?NumericQ,y_?NumericQ]:=unflatten##fPrivate[x,y]
Example of a solution to a less general problem:
What I actually need to do is to calculate all the derivatives for a given multivariate function up to some order. For this case, I hack my way along like so:
expr=Table[D[x^2 y+y^3,{{x,y},k}],{k,0,2}];
unflatten=Module[{f,x,y,a,b,sslot,tt},
tt=Table[D[f[x,y],{{x,y},k}],{k,0,2}] /.
{Derivative[a_,b_][_][__]-> x[a,b], f[__]-> x[0,0]};
(Evaluate[tt/.MapIndexed[#1->sslot[#2[[1]]]&,
Flatten[tt]]/. sslot-> Slot]&) ]
Out[1]= {x^2 y + y^3, {2 x y, x^2 + 3 y^2}, {{2 y, 2 x}, {2 x, 6 y}}}
Out[2]= {#1, {#2, #3}, {{#4, #5}, {#5, #7}}} &
This works, but it is neither elegant nor general.
Edit: Here is the "job security" version of the solution provided by aaz:
makeUnflatten[expr_List]:=Module[{i=1},
Function#Evaluate#ReplaceAll[
If[ListQ[#1],Map[#0,#1],i++]&#expr,
i_Integer-> Slot[i]]]
It works a charm:
In[2]= makeUnflatten[expr]
Out[2]= {#1,{#2,#3},{{#4,#5},{#6,#7}}}&
You obviously need to save some information about list structure, because Flatten[{a,{b,c}}]==Flatten[{{a,b},c}].
If ArrayQ[expr], then the list structure is given by Dimensions[expr] and you can reconstruct it with Partition. E.g.
expr = {{a, b, c}, {d, e, f}};
dimensions = Dimensions[expr]
{2,3}
unflatten = Fold[Partition, #1, Reverse[Drop[dimensions, 1]]]&;
expr == unflatten # Flatten[expr]
(The Partition man page actually has a similar example called unflatten.)
If expr is not an array, you can try this:
expr = {a, {b, c}};
indexes = Module[{i=0}, If[ListQ[#1], Map[#0, #1], ++i]& #expr]
{1, {2, 3}}
slots = indexes /. {i_Integer -> Slot[i]}
{#1, {#2, #3}}
unflatten = Function[Release[slots]]
{#1, {#2, #3}} &
expr == unflatten ## Flatten[expr]
I am not sure what you are trying to do with Compile. It is used when you want to evaluate procedural or functional expressions very quickly on numerical values, so I don't think it is going to help here. If repeated calculations of D[f,...] are impeding your performance, you can precompute and store them with something like
Table[d[k]=D[f,{{x,y},k}],{k,0,kk}];
Then just call d[k] to get the kth derivative.
I just wanted to update the excellent solutions by aaz and Janus. It seems that, at least in Mathematica 9.0.1.0 on Mac OSX, the assignment (see aaz's solution)
{i_Integer -> Slot[i]}
fails. If, however, we use
{i_Integer :> Slot[i]}
instead, we succeed. The same holds, of course, for the ReplaceAll call in Janus's "job security" version.
For good measure, I include my own function.
unflatten[ex_List, exOriginal_List] :=
Module[
{indexes, slots, unflat},
indexes =
Module[
{i = 0},
If[ListQ[#1], Map[#0, #1], ++i] &#exOriginal
];
slots = indexes /. {i_Integer :> Slot[i]};
unflat = Function[Release[slots]];
unflat ## ex
];
(* example *)
expr = {a, {b, c}};
expr // Flatten // unflatten[#, expr] &
It might seem a little like a cheat to use the original expression in the function, but as aaz points out, we need some information from the original expression. While you don't need it all, in order to have a single function that can unflatten, all is necessary.
My application is similar to Janus's: I am parallelizing calls to Simplify for a tensor. Using ParallelTable I can significantly improve performance, but I wreck the tensor structure in the process. This gives me a quick way to reconstruct my original tensor, simplified.

Resources