I have an implicit function, and I'm trying to plot the derivative of the solution of this function.
The function is:
p = \[Phi]/(1/\[Beta]) + ((1 - \[Phi]) \[Phi] (1 - \[Lambda]) \
\[Beta])/(((W - A) 1/\[Beta] + \[Phi] A/
p) 1/\[Beta] + \[Phi]*(1 - \[Phi]) A/p)/(
1/\[Beta] (\[Lambda]/((W - A) 1/\[Beta] + \[Phi] (A/
p) ) + (1 - \[Lambda])/(((W - A) 1/\[Beta] + \[Phi] A/
p) 1/\[Beta] + \[Phi] (1 - \[Phi]) A/p)))
And I would like to plot the derivative of the following expression w.r.t \[Phi]
\[Phi]/p ((1-\[Phi]) A + 1/\[Beta] A )
I've been trying to first solve for p explicitly, and plug the solution into the expression above and plot the derivative of the expression, but kept getting an error. My code is :
Manipulate[
ans = p /.
Solve[p - \[Phi]/(
1/\[Beta]) - ((1 - \[Phi]) \[Phi] (1 - \[Lambda]) \[Beta])/(((W \
- A) 1/\[Beta] + \[Phi] A/p) 1/\[Beta] + \[Phi]*(1 - \[Phi]) A/p)/(
1/\[Beta] (\[Lambda]/((W - A) 1/\[Beta] + \[Phi] (A/
p) ) + (1 - \[Lambda])/(((W - A) 1/\[Beta] + \[Phi] A/
p) 1/\[Beta] + \[Phi] (1 - \[Phi]) A/p))) == 0, p],
Plot[Evaluate[
D[f[\[Phi]] == \[Phi]/
ans[[2]] ((1 - \[Phi]) A + 1/\[Beta] A), \[Phi]]], {\[Phi],
0.01, 1}], {A, 10, 500}, {\[Beta], 0.001, 1}, {W, 100,
10^9}, {\[Lambda], 0.01, 1}]
The error I'm getting is:
"Manipulate:Manipulate argument \
Plot[Evaluate[\!\(\*SubscriptBox[\(\[PartialD]\), \(\[Phi]\)]\((f[\
\[Phi]] == \((\[Phi]\\\ Power[<<2>>])\)\\\ \((Times[<<2>>] +
Times[<<2>>])\))\)\)],{\[Phi],0.01,1}] does not have the correct \
form for a variable specification"
What am I doing wrong?
Thank you!
Related
So I'm trying to create a graph of mu as a function of a variable A, where mu is part of a solution to the following system of 17 non-linear equations (with lambda, A, and r as parameters). However, I can't seem to find a way for Mathematica to solve this. Does anyone know how to solve a large system of non-linear equations? Have been researching methods for almost a month now but still no luck.
Also, to graph mu versus A, do I need Mathematica to solve this, or is there another method?
Solve[
mu*(yB - xB) = (1 - mu)*(xS - yS) &&
0 == -lambda*xB*yS - lambda*xB*(A - xS) + mu*(A*(1 - A - yB) - (1 - A)*xB) &&
0 == -lambda*yB*xS + lambda*(1 - A - yB)*yS + mu*((1 - A)*(A - xB) - A*yB) &&
0 == -lambda*xS*yB + lambda*(A - xS)*xB + (1 - mu)*(A*(1 - A - yS) - (1 - A)*xS) &&
0 == -lambda*yS*xB - lambda*yS*(1 - A - yB) + (1 - mu)*((1 - A)*(A - xS) - A*yS) &&
r*VBhn == lambda/mu*yS*(VBho - VBhn - PSB) + lambda/mu*(A - xS)*(VBho - VBhn - PACh) + (1 - A)*(VBln - VBhn) &&
r*VBlo == lambda/mu*xS*(VBln - VBlo + PBS) + A*(VBho - VBlo) + (1 - delta) &&
r*VBln == lambda/mu*yS*(VBlo - VBln - PACl) + A*(VBhn - VBln) &&
r*VBho == (1 - A)*(VBlo - VBho) + 1 &&
r*VShn == lambda/(1 - mu)*yB*(VSho - VShn - PBS) + (1 - A)*(VSln - VShn) &&
r*VSlo == lambda/(1 - mu)*xB*(VSln - VSlo + PSB) + lambda/(1 - mu)*(1 - A - yB)*(VSln - VSlo + PACl) + A*(VSho - VSlo) + (1 - delta) &&
r*VSln == A*(VShn - VSln) &&
r*VSho == lambda/(1 - mu)*xB*(VShn - VSho + PACh) + (1 - A)*(VSlo - VSho) + 1 &&
VBho - VBhn - PSB == VSln - VSlo + PSB &&
VBln - VBlo + PBS == VSho - VShn - PBS &&
VBho - VBhn - PACh == VShn - VSho + PACh &&
VBlo - VBln - PACl == VSln - VSlo + PACl,
{mu, xS, xB, yS, yB, VBhn, VBlo, VBln, VBho, VShn, VSlo, VSln, VSho, PSB, PBS, PACh, PACl}
]
Can I simply ask the logical flow of the below Mathematica code? What are the variables arg and abs doing? I have been searching for answers online and used ToMatlab but still cannot get the answer. Thank you.
Code:
PositiveCubicRoot[p_, q_, r_] :=
Module[{po3 = p/3, a, b, det, abs, arg},
b = ( po3^3 - po3 q/2 + r/2);
a = (-po3^2 + q/3);
det = a^3 + b^2;
If[det >= 0,
det = Power[Sqrt[det] - b, 1/3];
-po3 - a/det + det
,
(* evaluate real part, imaginary parts cancel anyway *)
abs = Sqrt[-a^3];
arg = ArcCos[-b/abs];
abs = Power[abs, 1/3];
abs = (abs - a/abs);
arg = -po3 + abs*Cos[arg/3]
]
]
abs and arg are being reused multiple times in the algorithm.
In a case where det > 0 the steps are
po3 = p/3;
b = (po3^3 - po3 q/2 + r/2);
a = (-po3^2 + q/3);
abs1 = Sqrt[-a^3];
arg1 = ArcCos[-b/abs1];
abs2 = Power[abs1, 1/3];
abs3 = (abs2 - a/abs2);
arg2 = -po3 + abs3*Cos[arg1/3]
abs3 can be identified as A in this answer: Using trig identity to a solve cubic equation
That is the most salient point of this answer.
Evaluating symbolically and numerically may provide some other insights.
Using demo inputs
{p, q, r} = {-2.52111798, -71.424692, -129.51520};
Copyable version of trig identity notes - NB a, b, p & q are used differently in this post
Plot[x^3 - 2.52111798 x^2 - 71.424692 x - 129.51520, {x, 0, 15}]
a = 1;
b = -2.52111798;
c = -71.424692;
d = -129.51520;
p = (3 a c - b^2)/3 a^2;
q = (2 b^3 - 9 a b c + 27 a^2 d)/27 a^3;
A = 2 Sqrt[-p/3]
A == abs3
-(b/3) + A Cos[1/3 ArcCos[
-((b/3)^3 - (b/3) c/2 + d/2)/Sqrt[-(-(b^2/9) + c/3)^3]]]
Edit
There is also a solution shown here
TRIGONOMETRIC SOLUTION TO THE CUBIC EQUATION, by Alvaro H. Salas
Clear[a, b, c]
1/3 (-a + 2 Sqrt[a^2 - 3 b] Cos[1/3 ArcCos[
(-2 a^3 + 9 a b - 27 c)/(2 (a^2 - 3 b)^(3/2))]]) /.
{a -> -2.52111798, b -> -71.424692, c -> -129.51520}
10.499
So I'm solving a set of four differential equations in mathematica using NDSolve. I also use ArcSin as a part of the equations. Now, my ArcSin value is insensitive to the value of y, causing the solution to get periodic.
For example, for x=1,y=1, I get ArcSin as pi/4. IF I make it x=1,y=-1, it still remains pi/4. How do I avoid the cyclic behavior? I know, that the condition should be like if y<0, add pi to the solution. I'm failing to write it correctly.
Any help appreciated.
ClearAll["Global`*"]
\[Alpha]1 = 0.5;
\[Sigma]1 = -1;
Subscript[\[CapitalTheta], N] = \[Pi]/2;
traceractive =
NDSolve[{x'[
t] == ((-\[Alpha]1*(x[t] -
X[t]))/((x[t] - X[t])^2 + (y[t] - Y[t])^2)^(3/
2)) - (2*
Cos[Subscript[\[CapitalTheta], N] -
ArcSin[(x[t] - X[t])/((x[t] - X[t])^2 + (y[t] - Y[t])^2)^(1/
2)]]*\[Alpha]1*\[Sigma]1)/((x[t] - X[t])^2 + (y[t] -
Y[t])^2)^(3/
2) + ((y[t] - Y[t])*
Sin[Subscript[\[CapitalTheta], N] -
ArcSin[(x[t] - X[t])/((x[t] - X[t])^2 + (y[t] - Y[t])^2)^(1/
2)]]*\[Alpha]1*\[Sigma]1)/((x[t] - X[t])^2 + (y[t] -
Y[t])^2)^2,
y'[t] == ((-\[Alpha]1*(y[t] -
Y[t]))/((x[t] - X[t])^2 + (y[t] - Y[t])^2)^(3/
2)) - (2*
Cos[Subscript[\[CapitalTheta], N] -
ArcSin[(x[t] - X[t])/((x[t] - X[t])^2 + (y[t] - Y[t])^2)^(1/
2)]]*\[Alpha]1*\[Sigma]1)/((x[t] - X[t])^2 + (y[t] -
Y[t])^2)^(3/
2) - ((x[t] - X[t])*
Sin[Subscript[\[CapitalTheta], N] -
ArcSin[(x[t] - X[t])/((x[t] - X[t])^2 + (y[t] - Y[t])^2)^(1/
2)]]*\[Alpha]1*\[Sigma]1)/((x[t] - X[t])^2 + (y[t] -
Y[t])^2)^2, X'[t] == 0, Y'[t] == 0, x[0] == 0.1,
y[0] == 0.02, X[0] == 0, Y[0] == 0}, {x, y, X, Y}, {t, 0, 1000}]
xlist = Flatten[Table[x[t] /. traceractive, {t, 0, 100}]];
ylist = Flatten[Table[y[t] /. traceractive, {t, 0, 100}]];
Xlist = Flatten[Table[X[t] /. traceractive, {t, 0, 100}]];
Ylist = Flatten[Table[Y[t] /. traceractive, {t, 0, 100}]];
Tracer = Transpose#{xlist, ylist};
Length[Tracer];
Activep = Transpose#{Xlist, Ylist};
P1 = ListPlot[Tracer, Joined -> True]
P2 = ListPlot[Activep, PlotMarkers -> Automatic]
Show [P1, P2, Graphics[{PointSize[0.025], Point[{Tracer[[1]]}]}],
Graphics[{PointSize[0.025], Red, Point[{Tracer[[Length[Tracer]]]}]}],
PlotRange -> All, AxesOrigin -> {0, 0}]
(*Black point: Tracer initial position, Red point: Tracer final \
position*)
I would like to know whats wrong with my code. I am trying to solve system of non-linear equations (initially in wolfram but the command was too long) in Mathematica:
Reduce[Pi*(h^2 + 2*R*(R - r))/sqrt (h^2 + (R - r)^2) - 2*x*Pi/3*h*R -
x*Pi/3*h*r == 0 &&
Pi*(h^2 + 2*r*(r - R))/sqrt (h^2 + (R - r)^2) + 2*Pi*r -
x*Pi/3*h*R - 2*x*Pi/3*h*r == 0 &&
Pi*h*(r + R)/sqrt (h^2 + (R - r)^2) - x*Pi/3*R^2 - x*Pi/3*R*r -
x*Pi/3*r^2 == 0 && -Pi/3*h*(R^2 + R*r + r^2) + 1 == 0, {R, r, h,
x}];
Do you know how to retype it and solve these equations? I tried to type it according to documentation, but I evidently made some mistake...
These are the original equations (in LaTeX, I dont know if they will show correctly here:
\begin{equation*}
\frac{\partial}{\partial R} L(R, r, h, \lambda) = \frac{\pi(h^2 + 2R(R-r))}{\sqrt{h^2 + (R - r)^2}} - 2\lambda \frac{\pi}{3}hR - \lambda \frac{\pi}{3}hr= 0
\end{equation*}
\begin{equation*}
\frac{\partial}{\partial r} L(R, r, h, \lambda) = \frac{\pi(h^2 + 2r(r-R))}{\sqrt{h^2 + (R - r)^2}} + 2\pi r - \lambda \frac{\pi}{3}hR - 2\lambda \frac{\pi}{3}hr= 0
\end{equation*}
\begin{equation*}
\frac{\partial}{\partial h} L(R, r, h, \lambda) = \frac{\pi h(r + R)}{\sqrt{h^2 + (R - r)^2}} - \lambda \frac{\pi}{3}R^2 - \lambda \frac{\pi}{3}Rr - \lambda \frac{\pi}{3}r^2= 0
\end{equation*}
\begin{equation*}
\frac{\partial}{\partial \lambda} L(R, r, h, \lambda) = - \frac{\pi}{3} h (R^2 + Rr + r^2) + 1 = 0
\end{equation*}
edit:
I corrected pi to PI, now it started evaluating so maybe it was the mistake...It just takes a very long time...
You have to learn at least the basics. Go to Help->Documentation Center and click on the book in the search bar. There is everything explained from the very start.
As already pointed out in the comments, all functions and built-in symbols start with a capital letter. Therefore your call should be
Reduce[Pi*(h^2 + 2*R*(R - r))/Sqrt[h^2 + (R - r)^2] - 2*x*Pi/3*h*R -
x*Pi/3*h*r == 0 &&
Pi*(h^2 + 2*r*(r - R))/Sqrt[h^2 + (R - r)^2] + 2*Pi*r -
x*Pi/3*h*R - 2*x*Pi/3*h*r == 0 &&
Pi*h*(r + R)/Sqrt[h^2 + (R - r)^2] - x*Pi/3*R^2 - x*Pi/3*R*r -
x*Pi/3*r^2 == 0 && -Pi/3*h*(R^2 + R*r + r^2) + 1 == 0, {R, r, h,
x}]
If I have time series data -- a list of {x,y} pairs -- and want to smooth it, I can use an Exponential Moving Average like so:
EMA[data_, alpha_:.1] :=
Transpose # {#1, ExponentialMovingAverage[#2, alpha]}& ## Transpose#data
How would you implement double exponential smoothing?
DEMA[data_, alpha_, gamma_] := (* unstub me! *)
If it figured out good values for alpha and gamma by itself, that would be extra nice.
Related question about how to handle the case that there are gaps in the time-series, ie, the samples are not uniformly spread out over time:
Exponential Moving Average Sampled at Varying Times
I am not sure this is the fastest code one can get, yet the following seems to do it:
DEMA[data_, alpha_, gamma_] :=
Module[{st = First[data], bt = data[[2]] - data[[1]], btnew, stnew},
Reap[
Sow[st];
Do[
stnew = alpha y + (1 - alpha) (st + bt);
btnew = gamma (stnew - st) + (1 - gamma) bt;
Sow[stnew];
st = stnew;
bt = btnew;
, {y, Rest#data}]][[-1, 1]
]]
This is almost direct from the page you referenced. You can modify the initial condition for b in the source code. Setting bt initially to zero recovers the singly exponential smoothing.
In[81]:= DEMA[{a, b, c, d}, alpha, gamma]
Out[81]= {a, (1 - alpha) b + alpha b,
alpha c + (1 - alpha) ((1 - alpha) b +
alpha b + (-a + b) (1 - gamma) + (-a + (1 - alpha) b +
alpha b) gamma),
alpha d + (1 -
alpha) (alpha c + (1 -
gamma) ((-a + b) (1 - gamma) + (-a + (1 - alpha) b +
alpha b) gamma) + (1 - alpha) ((1 - alpha) b +
alpha b + (-a + b) (1 - gamma) + (-a + (1 - alpha) b +
alpha b) gamma) +
gamma (-(1 - alpha) b - alpha b +
alpha c + (1 - alpha) ((1 - alpha) b +
alpha b + (-a + b) (1 - gamma) + (-a + (1 - alpha) b +
alpha b) gamma)))}
Here is my formulation:
DEMA[data_, alpha_, gamma_] :=
FoldList[
Module[{x, y},
x = #[[1]] + #[[2]];
y = #2 - alpha x;
{y + x, #[[2]] + gamma * y}
] &,
{data[[1]], data[[2]] - data[[1]]},
alpha * Rest#data
][[All, 1]]