Related
I am very new to Mathematica, and I am trying to solve the following problem.
I have a cubic equation of the form Z = aZ^3 + bZ^2 + a + b. The first thing I want to do is to get a function that solves this analytically for Z and chooses the minimal positive root for that, as a function of a and b.
I thought that in order to get the root I could use:
Z = Solve[z == az^3 + bz^2 + a + b, z];
It seems like I am not quite getting the roots, as I would expect using the general cubic equation solution formula.
I want to integrate the minimal positive root of Z over a and b (again, preferably analytically) from 0 to 1 for a and for a to 1 for b.
I tried
Y = Integrate[Z, {a, 0, 1}, {b, a, 1}];
and that does not seem to give any formula or numerical value, but just returns an integral. (Notice I am not even sure how to pick the minimal positive root, but I am playing around with Mathematica to try to figure it out.)
Any ideas on how to do this?
Spaces between a or b and z are important. You can get the roots by:
sol = z /. Solve[z == a z^3 + b z^2 + a + b, z]
However, are you sure this expression has a solution as you expect? For a=0.5 and b=0.5, the only real root is negative.
sol /. {a->0.5, b->0.5}
{-2.26953,0.634765-0.691601 I,0.634765+0.691601 I}
sol = z /. Solve[z == a z^3 + b z^2 + a + b, z];
zz[a0_ /; NumericQ[a0], b0_ /; NumericQ[b0]] :=
Min[Select[ sol /. {a -> a0, b -> b0} ,
Element[#, Reals] && # > 0 & ]]
This returns -infinty when there are no solutions. As sirintinga noted your example integration limits are not valid..
RegionPlot[NumericQ[zz[a, b] ] , {a, -1, .5}, {b, -.5, 1}]
but you can numerically integrate if you have a valid region..
NIntegrate[zz[a, b], {a, -.5, -.2}, {b, .8, .9}] ->> 0.0370076
Edit ---
there is a bug above Select in Reals is throwin away real solutions with an infinitesimal complex part.. fix as:..
zz[a0_ /; NumericQ[a0], b0_ /; NumericQ[b0]] :=
Min[Select[ Chop[ sol /. {a -> a0, b -> b0} ],
Element[#, Reals] && # > 0 & ]]
Edit2, a cleaner approach if you dont find Chop satisfyting..
zz[a0_ /; NumericQ[a0], b0_ /; NumericQ[b0]] :=
Module[{z, a, b},
Min[z /. Solve[
Reduce[(z > 0 && z == a z^3 + b z^2 + a + b /.
{ a -> a0, b -> b0}), {z}, Reals]]]]
RegionPlot[NumericQ[zz[a, b] ] , {a, -2, 2}, {b, -2, 2}]
NIntegrate[zz[a, b], {a, 0, .5}, {b, 0, .5 - a}] -> 0.0491321
Suppose I have this Mathematica code, whose output, a real number, depends on the input, say, x,y,z. How do I make a real-valued function in x,y,z based on the code?
If the code describes a simple relationship among x,y,z, I could define this function directly. The point here is that the given code is a very complicated block (or module).
For example, if the code simply sums x,y,z, I would simply define
f[x_,y_,z_]=x+y+z
What if I have a very complex example, like the one below:
s0[a_, b_, x_] :=
{1, 0, (a + b) x + (1 - a - b)}
s1[a_, b_, c_, d_, p_, q_, n_, x_] :=
Which[0 <= x <= c, {2, n - 1, x/c*q + p},
c <= x <= c + d, {2, n, (x - c)/d*p},
c + d <= x <= 1, {1, n + 1, (x - (c + d))/(1 - c - d)*(1 - a - b)}]
s2[s_, t_, c_, d_, p_, q_, n_, x_] :=
Which[0 <= x <= 1 - s - t, {2, n - 1,
x/(1 - s - t)*(1 - p - q) + p + q},
1 - s - t <= x <= 1 - s, {3,
n - 1, (x - (1 - s - t))/t*(1 - c - d) + c + d},
1 - s <= x <= 1, {3, n, (x - (1 - s))/s*d + c}]
s3[c_, a_, b_, s_, t_, n_, x_] :=
Which[0 <= x <= 1 - a - b, {4, n - 1, x/(1 - a - b)*t + 1 - s - t},
1 - a - b <= x <= 1 - a, {4, n, (x - (1 - a - b))/b*(1 - s - t)},
1 - a <= x <= 1, {3, n + 1, (x - (1 - a))/a*c}]
s4[p_, q_, s_, a_, b_, n_, x_] :=
Which[0 <= x <= p, {4, n - 1, x/p*s + 1 - s},
p <= x <= p + q, {5, n - 1, (x - p)/q*a/(a + b) + b/(a + b)},
p + q <= x <= 1, {5, n, (x - (p + q))/(1 - p - q)*b/(a + b)}]
F[{k_, n_, x_}] :=
Which[k == 0, s0[a, b, x],
k == 1, s1[a, b, c, d, p, q, n, x],
k == 2, s2[s, t, c, d, p, q, n, x],
k == 3, s3[c, a, b, s, t, n, x],
k == 4, s4[p, q, s, a, b, n, x]]
G[x_] := NestWhile[F, {0, 0, x}, Function[e, Extract[e, {1}] != 5]]
H[x_] := Extract[G[x], {2}] + Extract[G[x], {3}]
H[0]
For the above code to run, one needs to specify the list
{a,b,c,d,p,q,s,t}
And the output are real numbers. How does one define a function in a,b,c,d,p,q,s,t that spits out these real numbers?
Your essential problem is that you have a large number of parameters in your auxiliary functions, but your big-letter functions (F, G and H and by the way single-capital-letter function names in Mathematica are a bad idea) only take three parameters and your auxiliary functions (s0 etc) only return three values in the returned list.
You have two possible ways to fix this.
You can either redefine everything to require all the parameters required in the whole system - I'm assuming that common parameter names across the auxiliary functions really are common values - like this:
G[x_, a_, b_, c_, d_, p_, q_, s_, t_] :=
NestWhile[F, {0, 0, x, a, b, c, d, p, q, s, t},
Function[e, Extract[e, {1}] != 5]]
or
You can set some options that set these parameters globally for the whole system. Look up Options and OptionsPattern. You would do something like this:
First, define default options:
Options[mySystem] = {aa -> 0.2, bb -> 1., cc -> 2., dd -> 4.,
pp -> 0.2, qq -> 0.1, ss -> 10., tt -> 20.}
SetOptions[mySystem, {aa->0.2, bb->1., cc->2., dd->4., pp->0.2,
qq->0.1, ss->10., tt->20.}]
Then write your functions like this:
F[{k_, n_, x_}, OptionsPattern[mySystem]] :=
With[{a = OptionValue[aa], b = OptionValue[bb], c = OptionValue[cc],
d = OptionValue[dd], p = OptionValue[pp], q = OptionValue[qq],
s = OptionValue[ss], t = OptionValue[tt]},
Which[k == 0, s0[a, b, x], k == 1, s1[a, b, c, d, p, q, n, x],
k == 2, s2[s, t, c, d, p, q, n, x], k == 3,
s3[c, a, b, s, t, n, x], k == 4, s4[p, q, s, a, b, n, x]] ]
There is also something quite wrong with your use of Extract (you are assuming there are more parts in your list than are actually there in the first few iterations), but this answers your main issue.
Given the following list:
{a + b, c + d + e, - a + b, a - b, - c - d - e}
I would like to get as a result:
{a + b, a - b, c + d + e}
To clarify: I'd like to transform the first list in such a way that the first term in each element is normalized to a plus sign and throw away any elements that can be obtained from the final result by multiplying with -1.
I have tried Collect[] and FactorTerms[] and some other functions that look remotely like they would be able to do what I need, but they never touch minus signs ....
Any help is greatly appreciated.
Use FactoredTermsList:
In[5]:= FactorTermsList /# {a + b, c + d + e, -a + b,
a - b, -c - d - e}
Out[5]= {{1, a + b}, {1, c + d + e}, {-1, a - b}, {1, a - b}, {-1,
c + d + e}}
In[6]:= DeleteDuplicates[%[[All, 2]]]
Out[6]= {a + b, c + d + e, a - b}
Replace each by its negative if the syntactic sign of the first element is negative. Then take the union. Example:
ll = {a + b, c + d + e, -a + b, a - b, -c - d - e}
Out[444]= {a + b, c + d + e, -a + b, a - b, -c - d - e}
Union[Map[
If[Head[#] === Plus && Head[#[[1]]] === Times &&
NumberQ[#[[1, 1]]] && #[[1, 1]] < 0, Expand[-#], #] &, ll]]
{a - b, a + b, c + d + e}
Daniel Lichtblau
It looks like you want to eliminate the elements that are duplicate modulo an overall sign. At least in this particular case, the following will work:
In[13]:= Union[FullSimplify#Abs[{a + b, c + d + e, -a + b, a - b, -c - d - e}]] /.
Abs[x_] :> x
Out[13]= {a - b, a + b, c + d + e}
If the order of elements in the list matters, you can use DeleteDuplicates in place of Union.
Here's an attempt.
ClearAll[nTerm];
nTerm[t_] := If[MatchQ[t[[1]], Times[-1, _]], -t, t]
is intended to be mapped over a list; takes a single item (of the list) as input, replaces it by its negative if the first element has a negative sign. So nTerm[-a + b + c] gives a - b - c, which is left invariant by nTerm: nTerm[a - b - c] gives back its argument.
Next,
ClearAll[removeElements];
removeElements[lst_] :=
DeleteDuplicates[lst, (#1 \[Equal] #2) || (#1 \[Equal] -#2) &]
takes a list as argument, removes those list elements that might be obtained from another list element by negation: removeElements[{1, 2, 3, -2, a, -a, "GWB", -"GWB"}] gives {1, 2, 3, a, "GWB"} (!). Finally,
ClearAll[processList];
processList[lst_] := removeElements[nTerm /# lst]
applies the whole lot to an input list; thus, li = {a + b, c + d + e, -a + b, a - b, -c - d - e}; processList[li] gives {a + b, c + d + e, a - b}
I have here a complicated bit of code that is not pretty nor easy to follow, but it represents a simplification of a larger body of code I am working with. I am a Mathematica novice and have already received some help on this issue from stackoverflow but it is still not solving my problem. Here is the code for which I hope you can follow along and assume what I am trying to get it to do. Thanks to you programming whizzes for the help.
a[b_, c_] = -3*b + 2*c + d + e + f;
g[b_, c_] := If[a[b, c] < 0, -3*a[b, c], a[b, c]];
h[T_, b_, c_] = (T/g[b, c]);
i[h_, T_, b_, c_] := If[h[T, b, c] > 0, 4*h[T, b, c], -5*h[T, b, c]];
j[b_, c_] := If[a[b, c] < 0, 5*a[b, c], 20*a[b, c]];
XYZ[h_, T_, i_, g_, j_, b_, c_] = T*i[h, T, b, c]*g[b, c] + j[b, c]
rules = {a -> 1, b -> 2, c -> 3, d -> 4, e -> 5, f -> 6, T -> 10};
XYZ[h, T, i, g, j, b, c] //. rules
Preserving as much of your code as possible, it will work with just a few changes:
a[b_, c_] := -3*b + 2*c + d + e + f;
g[b_, c_] := If[# < 0, -3 #, #] & # a[b, c]
h[T_, b_, c_] := T / g[b, c]
i[h_, T_, b_, c_] := If[# > 0, 4 #, -5 #] & # h[T, b, c]
j[b_, c_] := If[# < 0, 5 #, 20 #] & # a[b, c]
XYZ[h_, T_, i_, g_, j_, b_, c_] := T*i[h, T, b, c]*g[b, c] + j[b, c]
rules = {a -> 1, b -> 2, c -> 3, d -> 4, e -> 5, f -> 6, T -> 10};
XYZ[h, T, i, g, j, b, c] /. rules
(* Out= 700 *)
If statements are again externalized, as in the last problem.
all definitions are made with SetDelayed (:=), as a matter of good practice.
The presumed error T - 10 in your rules is corrected to T -> 10
Notice that again ReplaceRepeated (//.) is not needed, and is changed to /.
We still have a nonsensical rule a -> 1 but it does not cause a failure.
Still early days with Mathematica so please forgive what is probably a very obvious question. I am trying to generate some parametric plots. I have:
ParametricPlot[{
(a + b) Cos[t] - h Cos[(a + b)/b t],
(a + b) Sin[t] - h Sin[(a + b)/b t]},
{t, 0, 2 \[Pi]}, PlotRange -> All] /. {a -> 2, b -> 1, h -> 1}
No joy: the replacement rules are not applied and a, b and h remain undefined.
If I instead do:
Hold#ParametricPlot[{
(a + b) Cos[t] - h Cos[(a + b)/b t],
(a + b) Sin[t] - h Sin[(a + b)/b t]},
{t, 0, 2 \[Pi]}, PlotRange -> All] /. {a -> 2, b -> 1, h -> 1}
it looks like the rules ARE working, as confirmed by the output:
Hold[ParametricPlot[{(2 + 1) Cos[t] -
1 Cos[(2 + 1) t], (2 + 1) Sin[t] - 1 Sin[(2 + 1) t]}, {t, 0,
2 \[Pi]}, PlotRange -> All]]
Which is what I'd expect. Take the Hold off, though, and the ParametricPlot doesn't work. There's nothing wrong with the equations or the ParametricPlot itself, though, because I tried setting values for a, b and h in a separate expression (a=2; b=1; h=1) and I get my pretty double cardoid out as expected.
So, what am I doing wrong with ReplaceAll and why are the transformation rules not working? This is another fundamentally important aspect of MMA that my OOP-ruined brain isn't understanding.
I tried reading up on ReplaceAll and ParametricPlot and the closest clue I found was that "ParametricPlot has attribute HoldAll and evaluates f only after assigning specific numerical values to variables" which didn't help much or I wouldn't be here.
Thanks.
Mathematica evaluates each head without holding attributes by first evaluating head of each subexpression. Since ReplaceAll doesn't have holding attributes, ParametricPlot becomes Graphics before replacement
To see the expression tree, do
ParametricPlot[{(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] -
h Sin[(a + b)/b t]}, {t, 0, 2 \[Pi]},
PlotRange -> All] /. {a -> 2, b -> 1, h -> 1} // Hold // TreeForm
From that tree you can see that your command is the same as doing
temp1=ParametricPlot[{(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] -
h Sin[(a + b)/b t]}, {t, 0, 2 \[Pi]},
PlotRange -> All]
temp2={a -> 2, b -> 1, h -> 1}
temp1/.temp2
Look at FullForm[temp1] to confirm that there's no a or b in that expression.
If you set ReplaceAll to HoldFirst, that prevents ParametricPlot from being evaluated before ReplaceAll, and result is what you expected. In this case, ReplaceAll evaluates to expression with head ParametricPlot, and only at that point ParametricPlot is evaluated. Make sure to reset the attributes back because changing behavior of built-in commands can have unexpected side-effects.
SetAttributes[ReplaceAll, HoldFirst];
ParametricPlot[{(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] -
h Sin[(a + b)/b t]}, {t, 0, 2 \[Pi]},
PlotRange -> All] /. {a -> 2, b -> 1, h -> 1}
ClearAttributes[ReplaceAll, HoldFirst]
A useful trick when needing to evaluate arguments passed to function with HoldAll is to do operations on an expression with List head, and substitute ParametricPlot in the end, for instance
ParametricPlot ## ({{(a + b) Cos[t] -
h Cos[(a + b)/b t], (a + b) Sin[t] - h Sin[(a + b)/b t]}, {t, 0,
2 \[Pi]}, PlotRange -> All} /. {a -> 2, b -> 1, h -> 1})
The best way for using local variables in Mathematica is Module[]:
Module[{a = 2, b = 1, h = 1},
ParametricPlot[{(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] - h Sin[(a + b)/b t]},
{t, 0, 2 \[Pi]},
PlotRange -> All]]
This way a, b, and h do not get assigned values in the Global context but only inside the Module. If you still want to use replacement rules you just have to ReleaseHold after you have done the replacement:
ReleaseHold[
Hold#ParametricPlot[{(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] - h Sin[(a + b)/b t]},
{t, 0, 2 \[Pi]},
PlotRange -> All] /. {a -> 2, b -> 1, h -> 1}]
EDIT: As to why this happens. The way I understand it, HoldAll prevents the arguments of the function from being modified by any rules (internal or explicit). What your Hold does, is place the entire function on hold (not just the arguments), and the replacement rule gets applied after the function has gone through evaluation (which it didn't so there is still something there to replace) and HoldAll is no longer valid.
In[1] := Hold[a /. a -> 5]
Out[1] := Hold[a /. a -> 5]
In[2] := Hold[a] /. a -> 5
Out[2] := Hold[5]
Of course, Hold also has HoldAll as an attribute, so this doen't explain why ParametricPlot's HoldAll is different. :-(
EDIT2: I used Trace to look at what happens, and it seems like ReplaceAll gets applied only at the very end, when ParametricPlot has already turned into a graphical object (and does not contain a, b, or h anymore). In the case of Hold[a] /. a -> 5 the hold evaluates to Hold[a] and the replacement rule can then be successfully applied.
That is the way ReplaceAll always work.
See for example:
In[10]:= (a/a) /. a -> 0
Out[10]= 1
Clearly the replacement is done AFTER the evaluation, because if you do:
In[11]:= a = 0; a/a
During evaluation of In[11]:= Power::infy: Infinite expression 1/0 encountered. >>
During evaluation of In[11]:= Infinity::indet: Indeterminate expression 0 ComplexInfinity encountered. >>
Out[12]= Indeterminate
Now, is a matter of inserting the replacement at the level you want it to operate. As the result of a Plot is basically an Image with the numeric coordinates already "solved", you want to put those coordinates in before the plot is calculated. In your case:
ParametricPlot[
{(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] - h Sin[(a + b)/b t]}
/. {a -> 2, b -> 1, h -> 1},
{t, 0, 2 \[Pi]},
PlotRange -> All
]
This is not an answer as such, just a comment on using Module with Plot.
If I proceed as follows
f[t_] := {(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] -
h Sin[(a + b)/b t]}
The following will NOT work
Method 1:
Module[{a = 2, b = 1, h = 1},
ParametricPlot[f[t], {t, 0, 2 \[Pi]}, PlotRange -> All]]
Method 2:
Module[{a = 2, b = 1, h = 1},
ParametricPlot[Evaluate[f[t]], {t, 0, 2 \[Pi]}, PlotRange -> All]]
The following does work (Method 3)
ParametricPlot[
Module[{a = 2, b = 1, h = 1}, Evaluate[f[t]]], {t, 0, 2 \[Pi]},
PlotRange -> All]
as does the method described above (method 4)
Module[{a = 2, b = 1, h = 1},
ParametricPlot[{(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] - h Sin[(a + b)/b t]},
{t, 0, 2 \[Pi]},
PlotRange -> All]]
Can anyone explain why method 4 works but method 2 doesn't? (The same applies to With, which I find more intuitive to Module).
For what its worth, I would generate the original parametric plot using replacement rules as follows:
ParametricPlot[
Evaluate[{(a + b) Cos[t] - h Cos[(a + b)/b t], (a + b) Sin[t] -
h Sin[(a + b)/b t]}] /. {a -> 2, b -> 1, h -> 1}, {t, 0,
2 \[Pi]}, PlotRange -> All]
EDIT
f[x_] := (a x)/(b + x);
With[{a = 10, b = 100}, Plot[Evaluate[f[x]], {x, 0, 100}]]
With[{a = 10, b = 100}, Plot[(a x)/(b + x), {x, 0, 100}]]
Plot[With[{a = 10, b = 100}, Evaluate[f[x]]], {x, 0, 100}]
Plot[Evaluate[f[x]] /. {a -> 10, b -> 100}, {x, 0, 100}]
Method 1 (of Edit) does not work (because 'Plot' treats the variable x as local, effectively using Block'?)
It seems to me that it is absolutely clear to anyone, even those with a rudimentary knowledge of Mathematica, what is going on with Method 2, showing the power and ease-of-use of Mathematica. When the equations become more complex, is it advantageous to define them separately. It is now not so clear that Method 3 must be used instead of Method 1. (Method 4, of course, is probably the best of all.)