Related
So I have the below code
perturb1 =
x'[t] == mu1*x[t] + x[t]*(a*x[t] + b*y[t] + c*z[t]) +
x[t]*eps1 * (UnitStep[t - 1.5] - UnitStep[t - 2.5]);
perturb2 =
y'[t] == mu2*y[t] + y[t]*(d*x[t] + e*y[t] + f*z[t]) +
y[t]*eps2 * (UnitStep[t - 1.5] - UnitStep[t - 2.5]);
perturb3 =
z'[t] == mu3*z[t] + z[t]*(g*x[t] + h*y[t] + i*z[t]) +
z[t]*eps3 * (UnitStep[t - 1.5] - UnitStep[t - 2.5]);
perturbSol = ParametricNDSolve[
{perturb1, perturb2, perturb3, x[0] == 0.25, y[0] == 0.4,
z[0] == 0.35},
{x[t], y[t], z[t]},
{t, 0, 500},
{mu1, mu2, mu3, a, b, c, d, e, f, g, h, i, eps1, eps2, eps3}
];
Evaluate[x[t][#] /. perturbSol] & /# parameterSets
parameterSets is a list of 5000+ elements of the form {mu1, mu2, mu3, a, b, c, d, e, f, g, h, i, eps1, eps2, eps3} (but with numerical values). What I'm trying to do is to evaluate the parametric function using each parameter set. When I do as above, I get the error
ParametricNDSolve: Too many parameters in {mu1,mu2,mu3,a,b,c,d,e,f,g,h,i,eps1,eps2,eps3} to be filled from {{0.9,0.9,0.9,-2,-1,-1,-1,-2,-1,-1,-1,-2,-2,-2,-2}}.
So it seems that it's because, with a single value, you would evaluate the function as follows:
Evaluate[x[t][0.9,0.9,0.9,-2,-1,-1,-1,-2,-1,-1,-1,-2,-2,-2,-2]/.perturbSol]
Whereas when using Map on parameterSets, it does this:
Evaluate[x[t][{0.9,0.9,0.9,-2,-1,-1,-1,-2,-1,-1,-1,-2,-2,-2,-2}]/.perturbSol]
i.e. it's applying the function to a list of 15 parameters, rather than to the 15 parameters separated by commas.
Is there any elegant solution to this? I tried flatten around the #, which didn't do anything (as I sort of expected). I guess one way is to write #1,#2,#3 etc in the square brackets but that's pretty messy.
Any better way to do this?
Many thanks,
H
Probably, you want something along the lines of
u = ParametricNDSolveValue[{perturb1, perturb2, perturb3,
x[0] == 0.25, y[0] == 0.4, z[0] == 0.35}, {x, y, z}, {t, 0,
500}, {mu1, mu2, mu3, a, b, c, d, e, f, g, h, i, eps1, eps2,
eps3}];
parameterSets = RandomReal[{-1, 1}, {3, 15}];
(u[##])[[1]][t] & ### parameterSets
I need to use NDSolve which in turn uses the solution from another ODE as function in terms of output from another NDSolve.
If I use the exact solution from the first differential equation inside the NDSolve, it's OK. But when I use the same solution in the form of function (which uses InterpolatingFunction) it does not work.
I believe, it's got to do with the structure of NDSolve output. Could anyone please enlighten me on this. Will be of great help!
The code is:
feq = 2 V alpha fip F''[fi] - (V^2 - (V^2 + sigma - 2 fi) (F'[fi])^2 + (F'[fi])^4
Frange[lo_, hi_] :=
Module[{fii, sol},
sol = NDSolve[{(feq == 0 /.fi -> fii), F[0] == 0}, F, {fii, lo, hi}]]
eqpois = fi''[x] == ne[x] - F[fi[x]]/.sol
NDSolve[{eqpois, fi'[0] == 0, fi[0] == 0}, fi, {x,0,1}]
Here in order to find F[phi], I need to solve the 1st diff eq that is feq, which is solved by NDSolve inside the function Frange[lo,hi]. The solution is then used inside the second equation eqpois, which has to be solved using NDSolve again. The problem comes up in the second NDSolve, which does not produce the result. If I use the analytical solution of F[phi] in eqopis, then there is no problem.
Example Problem
I have done a little experiment with this. Let's take an example of coupled ODEs
1st eqn : dg/dx = 2f(g) with initial condition g(0) = 1
The function f(y) is a solution from another ODE, say,
2nd eqn : df/dy = 2y with IC f(0) = 0
The solution of the 2nd ODE is f(y) = y^2 which when put into the the 1st ODE becomes
dg/dx = 2 g^2 and the final solution is g(x) = 1/(1-2x)
The issue:
When I use DSolve, it finds the answer correctly
In[39]:= s = DSolve[{f'[y] == 2 y, f[0] == 0}, f, y]
Out[39]= {{f -> Function[{y}, y^2]}}
In[40]:= ss = DSolve[{g'[x] == 2 (f[g[x]]/.First#s), g[0] == 1}, g, x]
Out[40]= {{g -> Function[{y}, 1/(1 - 2 x)]}}
The problem comes when I use NDSolve
In[41]:= s = NDSolve[{f'[y] == 2 y, f[0] == 0}, f, {y, 1, 5}]
Out[41]= {{f -> InterpolatingFunction[{{1., 5.}}, <>]}}
In[42]:= ss1 = NDSolve[{g'[x] == 2 (Evaluate[f[g[x]]/.First#s1]), g[0] == 1}, g, {x, 1, 2}]
Out[42]= {}
The erros are:
During evaluation of In[41]:= InterpolatingFunction::dmval: Input value {2.01726} lies outside the range of data in the interpolating function. Extrapolation will be used. >>
During evaluation of In[41]:= InterpolatingFunction::dmval: Input value {2.01726} lies outside the range of data in the interpolating function. Extrapolation will be used. >>
During evaluation of In[41]:= InterpolatingFunction::dmval: Input value {2.04914} lies outside the range of data in the interpolating function. Extrapolation will be used. >>
During evaluation of In[41]:= General::stop: Further output of InterpolatingFunction::dmval will be suppressed during this calculation. >>
During evaluation of In[41]:= NDSolve::ndsz: At y == 0.16666654771477857, step size is effectively zero; singularity or stiff system suspected. >>
During evaluation of In[41]:= NDSolve::ndsz: At y == 0.16666654771477857, step size is effectively zero; singularity or stiff system suspected. >>
Any help in this regard will be highly appreciated!
--- Madhurjya
I got your simple example to work with a little mod ..
f0 = First#First#DSolve[{f'[y] == 2 y, f[0] == 0}, f, y]
g0 = g /.
First#First#DSolve[{g'[x] == 2 (f[g[x]] /. f0), g[0] == 1}, g, x]
fn = f /. First#First#NDSolve[{f'[y] == 2 y, f[0] == 0}, f, {y, 0, 10}]
gn = g /.
First#First#
NDSolve[{g'[x] == 2 (fn[g[x]]), g[0] == 1}, g, {x, 0, 9/20}]
GraphicsRow[{
Plot[{g0#x, gn#x}, {x, 0, 9/20},
PlotStyle -> {{Thick, Black}, {Thin, Red, Dashed}}],
Plot[{f#x /. f0, fn#x}, {x, 0, 2},
PlotStyle -> {{Thick, Black}, {Thin, Red, Dashed}}]}]
note we need to ensure the y range in the first NDSolve is sufficient to cover the expected range of g from the second. That is where all those interpolation range errors come from.
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
I am trying to plot a function in Mathematica that is defined over the unit simplex. To take a random example, suppose I want to plot sin(x1*x2*x3) over all x1, x2, x3 such that x1, x2, x3 >= 0 and x1 + x2 + x3 = 1.
Is there a neat way of doing so, other than the obvious way of writing something like
Plot3D[If[x+y<=1,Sin[x y(1-x-y)]],{x,0,1},{y,0,1}]
?
What I want, ideally, is a way of plotting only over the simplex. I found the website http://octavia.zoology.washington.edu/Mathematica/ which has an old package, but it doesn't work on my up-to-date version of Mathematica.
If you want to get symmetric looking plots like in that package you linked, you need to figure out rotation matrix that puts the simplex into x/y plane. You can use this function below. It's kind of long because I left in the calculations to figure out simplex centering. Ironically, transformation for 4d simplex plot is much simpler. Modify e variable to get different margin
simplexPlot[func_, plotFunc_] :=
Module[{A, B, p2r, r2p, p1, p2, p3, e, x1, x2, w, h, marg, y1, y2,
valid},
A = Sqrt[2/3] {Cos[#], Sin[#], Sqrt[1/2]} & /#
Table[Pi/2 + 2 Pi/3 + 2 k Pi/3, {k, 0, 2}] // Transpose;
B = Inverse[A];
(* map 3d probability vector into 2d vector *)
p2r[{x_, y_, z_}] := Most[A.{x, y, z}];
(* map 2d vector in 3d probability vector *)
r2p[{u_, v_}] := B.{u, v, Sqrt[1/3]};
(* Bounds to center the simplex *)
{p1, p2, p3} = Transpose[A];
(* extra padding to use *)
e = 1/20;
x1 = First[p1] - e/2;
x2 = First[p2] + e/2;
w = x2 - x1;
h = p3[[2]] - p2[[2]];
marg = (w - h + e)/2;
y1 = p2[[2]] - marg;
y2 = p3[[2]] + marg;
valid =
Function[{x, y}, Min[r2p[{x, y}]] >= 0 && Max[r2p[{x, y}]] <= 1];
plotFunc[func ## r2p[{x, y}], {x, x1, x2}, {y, y1, y2},
RegionFunction -> valid]
]
Here's how to use it
simplexPlot[Sin[#1 #2 #3] &, Plot3D]
(source: yaroslavvb.com)
simplexPlot[Sin[#1 #2 #3] &, DensityPlot]
(source: yaroslavvb.com)
If you want to see domain in the original coordinate system, you could rotate the plot back to the simplex
t = AffineTransform[{{{-(1/Sqrt[2]), -(1/Sqrt[6]), 1/Sqrt[3]}, {1/
Sqrt[2], -(1/Sqrt[6]), 1/Sqrt[3]}, {0, Sqrt[2/3], 1/Sqrt[
3]}}, {1/3, 1/3, 1/3}}];
graphics = simplexPlot[5 Sin[#1 #2 #3] &, Plot3D];
shape = Cases[graphics, _GraphicsComplex];
Graphics3D[{Opacity[.5], GeometricTransformation[shape, t]},
Axes -> True]
(source: yaroslavvb.com)
Here's another simplex plot, using traditional 3d axes from here and MeshFunctions->{#3&}, complete code here
(source: yaroslavvb.com)
Try:
Plot3D[Sin[x y (1 - x - y)], {x, 0, 1}, {y, 0, 1 - x}]
But you can also use Piecewise and RegionFunction:
Plot3D[Piecewise[{{Sin[x y (1 - x - y)],
x >= 0 && y >= 0 && x + y <= 1}}], {x, 0, 1}, {y, 0, 1},
RegionFunction -> Function[{x, y}, x + y <= 1]]
I want to do the following in Mma. Suppose I have three expressions, x1, 3 x1-x2, x2-x1 where 0<=x1,x2<=1). I want to have another one which specifies the largest among the three is at least twice of the smallest. So there are some permutation of the three in terms of their order:
x1<=3 x1-x2<=x2-x1 && 2 x1<=x2-x1
3 x1-x2<=x1<=x2-x1 && 2 (3 x1-x2)<=x2-x1
....
with the rest 4 similar conditions.
How do I form these conditions automatically (together with 0<=x1,x2<=1), and then feed them into Reduce one-by-one, and solve for x2 in terms of x1?
Many thanks!
eqs = {x1, 3 x1 - x2, x2 - x1};
Reduce[Max[eqs] >= 2 Min[eqs], {x1, x2}, Reals]
If you want to do comparisons with second-largest or third largest/smallest then can use RankedMax
As far as solving it for x2 -- there are many different values of x2 corresponding to each x1 so you can't solve it in the conventional sense, you can see it from RegionPlot
RegionPlot[Max[eqs] >= 2 Min[eqs], {x1, 0, 1}, {x2, 0, 1}, PlotPoints -> 100]
Use Max and Min and specify x2 before x1 in the variable list, as follows
In[1]:= Reduce[
Max[x1, 3 x1 - x2, x2 - x1] >= 2 Min[x1, 3 x1 - x2, x2 - x1] &&
0 <= x1 && x2 <= 1,
{x2, x1}]