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.
Because PolarPlot should type r=... type of command.
But y=x will cause r to disappear.
How to draw that line with PolarPlot?
First, consider Plot[] which "generates a plot of f as a function of x from xmin to xmax" (I'm quoting the Mathematica documentation). You can't use it to plot a vertical line satisfying the equation x = x0, because the latter is not a function of x: instead of being single-valued, it has infinitely many values at x0.
Similarly, PolarPlot[] cannot be used to draw a straight line that passes through the origin, because its equation is not a function of θ: it has infinitely many values at a particular θ (equal to Pi/4 in the case requested), but none at all elsewhere. (Well, one could also allow the complementary angle 3Pi/4 as well.)
So I maintain it can't be done using the tools specified, short of the cheat
PolarPlot[0, {\[Theta], 0, 1},
Epilog -> Line[{Scaled[{1, 1}], Scaled[{0, 0}]}]]
I suggest you use a new function for things like this.
PolarParametricPlot[
{rT : {_, _} ..} | rT : {_, _},
uv : {_, _, _} ..,
opts : OptionsPattern[]
] :=
ParametricPlot[
Evaluate[# {Cos##2, Sin##2} & ### {rT}],
uv,
opts
]
Usage:
PolarParametricPlot[{t, 45 Degree}, {t, -10, 10}]
Here is the general polar form for a line of the form y = m x + b:
In[155]:= r /.
Solve[Eliminate[{x == r Cos[t], y == r Sin[t], y == m x + b}, {x,
y}], r]
Out[155]= {-(b/(m Cos[t] - Sin[t]))}
The solution vanishes when the y-intercept b is zero. This makes sense, since such lines are drawn at a constant angle, which is problematic since PolarPlot works by varying the angle.
You could approximate such a line by using a very small value for b, but there are probably better approaches.
You could draw the line using ListPolatPlot:
ListPolarPlot[{{Pi/4, 5}, {5 Pi/4, 5}}, Joined -> True]
Is it possible to work out the probability of 3 or more Head from 4 coin tosses using the Probability or NProbability functions.
This is not a question about the trivial answer to this problem, it is more to get an understanding of how to solve this kind of problem with Mathematica using distributions.
So using 4 random variables from Distribution P
I was hoping something like this would do the trick, but it does not work. I get 0.
P = BernoulliDistribution[0.5];
vars = List[Distributed[a,P],Distributed[b,P],Distributed[c,P],Distributed[c,P]];
NProbability[Count[ {a,b,c,d}, 1] >= 3, vars]
Any ideas would be greatly appreciated.
Not an expert using Mma for statistics here, but this seems to work:
l = TransformedDistribution[
x + y + w + z, {x \[Distributed] BernoulliDistribution[0.5],
y \[Distributed] BernoulliDistribution[0.5],
z \[Distributed] BernoulliDistribution[0.5],
w \[Distributed] BernoulliDistribution[0.5]}];
Table[NProbability[x > i, x \[Distributed] l], {i, -1, 4}]
(*
{1, 0.9375, 0.6875, 0.3125, 0.0625, 0.}
*)
In[10]:= Probability[a + b + c + d >= 3, vars]
Out[10]= 0.3125
Coin flipping is easier described with a BinomialDistribution:
In[12]:= Probability[m >= 3, m \[Distributed] BinomialDistribution[4, 0.5]]
Out[12]= 0.3125
I have a system of ODE's. One of the ODE's has a constant parameter which I want to alter between two different values depending on one of the ODE solutions.
So for example let's say that I have the following equations:
{
A'[x] == -q A[x]B[x],
B'[x] == q A[x]B[x] - g B[x],
C'[x] == g B[x]
}
Now I can solve them easily using the NDSolve function when q and g are constant values. What I want to do though is vary the value of q so that it has one value when B[x] is below a certain threshold but then changes in value when B[x] rises above this threshold value.
I've tried using If statements and Piecewise functions outside of the NDSolve but I haven't managed to get it working.
This might do something like what you want. I left out the third equation, which seems superfluous.
Clear[f, g, s, t, x];
s[a_, b_] = Piecewise[{{a*b - b, b < 1}, {2 a*b - b, b >= 1}}];
t[a_, b_] = Piecewise[{{-a*b, b < 1}, {-2 a*b, b >= 1}}];
{f[x_], g[x_]} = {f[x], g[x]} /.
First[NDSolve[{
f'[x] == t[f[x], g[x]],
g'[x] == s[f[x], g[x]],
f[0] == 10, g[0] == 1},
{f[x], g[x]}, {x, 0, 2}]]
I am doing a brute force search for "gradient extremals" on the following example function
fv[{x_, y_}] = ((y - (x/4)^2)^2 + 1/(4 (1 + (x - 1)^2)))/2;
This involves finding the following zeros
gecond = With[{g = D[fv[{x, y}], {{x, y}}], h = D[fv[{x, y}], {{x, y}, 2}]},
g.RotationMatrix[Pi/2].h.g == 0]
Which Reduce happily does for me:
geyvals = y /. Cases[List#ToRules#Reduce[gecond, {x, y}], {y -> _}];
geyvals is the three roots of a cubic polynomial, but the expression is a bit large to put here.
Now to my question: For different values of x, different numbers of these roots are real, and I would like to pick out the values of x where the solutions branch in order to piece together the gradient extremals along the valley floor (of fv). In the present case, since the polynomial is only cubic, I could probably do it by hand -- but I am looking for a simple way of having Mathematica do it for me?
Edit: To clarify: The gradient extremals stuff is just background -- and a simple way to set up a hard problem. I am not so interested in the specific solution to this problem as in a general hand-off way of spotting the branch points for polynomial roots. Have added an answer below with a working approach.
Edit 2: Since it seems that the actual problem is much more fun than root branching: rcollyer suggests using ContourPlot directly on gecond to get the gradient extremals. To make this complete we need to separate valleys and ridges, which is done by looking at the eigenvalue of the Hessian perpendicular to the gradient. Putting a check for "valleynes" in as a RegionFunction we are left with only the valley line:
valleycond = With[{
g = D[fv[{x, y}], {{x, y}}],
h = D[fv[{x, y}], {{x, y}, 2}]},
g.RotationMatrix[Pi/2].h.RotationMatrix[-Pi/2].g >= 0];
gbuf["gevalley"]=ContourPlot[gecond // Evaluate, {x, -2, 4}, {y, -.5, 1.2},
RegionFunction -> Function[{x, y}, Evaluate#valleycond],
PlotPoints -> 41];
Which gives just the valley floor line. Including some contours and the saddle point:
fvSaddlept = {x, y} /. First#Solve[Thread[D[fv[{x, y}], {{x, y}}] == {0, 0}]]
gbuf["contours"] = ContourPlot[fv[{x, y}],
{x, -2, 4}, {y, -.7, 1.5}, PlotRange -> {0, 1/2},
Contours -> fv#fvSaddlept (Range[6]/3 - .01),
PlotPoints -> 41, AspectRatio -> Automatic, ContourShading -> None];
gbuf["saddle"] = Graphics[{Red, Point[fvSaddlept]}];
Show[gbuf /# {"contours", "saddle", "gevalley"}]
We end up with a plot like this:
Not sure if this (belatedly) helps, but it seems you are interested in discriminant points, that is, where both polynomial and derivative (wrt y) vanish. You can solve this system for {x,y} and throw away complex solutions as below.
fv[{x_, y_}] = ((y - (x/4)^2)^2 + 1/(4 (1 + (x - 1)^2)))/2;
gecond = With[{g = D[fv[{x, y}], {{x, y}}],
h = D[fv[{x, y}], {{x, y}, 2}]}, g.RotationMatrix[Pi/2].h.g]
In[14]:= Cases[{x, y} /.
NSolve[{gecond, D[gecond, y]} == 0, {x, y}], {_Real, _Real}]
Out[14]= {{-0.0158768, -15.2464}, {1.05635, -0.963629}, {1.,
0.0625}, {1., 0.0625}}
If you only want to plot the result then use StreamPlot[] on the gradients:
grad = D[fv[{x, y}], {{x, y}}];
StreamPlot[grad, {x, -5, 5}, {y, -5, 5},
RegionFunction -> Function[{x, y}, fv[{x, y}] < 1],
StreamScale -> 1]
You may have to fiddle around with the plot's precision, StreamStyle, and the RegionFunction to get it perfect. Especially useful would be using the solution for the valley floor to seed StreamPoints programmatically.
Updated: see below.
I'd approach this first by visualizing the imaginary parts of the roots:
This tells you three things immediately: 1) the first root is always real, 2) the second two are the conjugate pairs, and 3) there is a small region near zero in which all three are real. Additionally, note that the exclusions only got rid of the singular point at x=0, and we can see why when we zoom in:
We can then use the EvalutionMonitor to generate the list of roots directly:
Map[Module[{f, fcn = #1},
f[x_] := Im[fcn];
Reap[Plot[f[x], {x, 0, 1.5},
Exclusions -> {True, f[x] == 1, f[x] == -1},
EvaluationMonitor :> Sow[{x, f[x]}][[2, 1]] //
SortBy[#, First] &];]
]&, geyvals]
(Note, the Part specification is a little odd, Reap returns a List of what is sown as the second item in a List, so this results in a nested list. Also, Plot doesn't sample the points in a straightforward manner, so SortBy is needed.) There may be a more elegant route to determine where the last two roots become complex, but since their imaginary parts are piecewise continuous, it just seemed easier to brute force it.
Edit: Since you've mentioned that you want an automatic method for generating where some of the roots become complex, I've been exploring what happens when you substitute in y -> p + I q. Now this assumes that x is real, but you've already done that in your solution. Specifically, I do the following
In[1] := poly = g.RotationMatrix[Pi/2].h.g /. {y -> p + I q} // ComplexExpand;
In[2] := {pr,pi} = poly /. Complex[a_, b_] :> a + z b & // CoefficientList[#, z] & //
Simplify[#, {x, p, q} \[Element] Reals]&;
where the second step allows me to isolate the real and imaginary parts of the equation and simplify them independent of each other. Doing this same thing with the generic 2D polynomial, f + d x + a x^2 + e y + 2 c x y + b y^2, but making both x and y complex; I noted that Im[poly] = Im[x] D[poly, Im[x]] + Im[y] D[poly,[y]], and this may hold for your equation, also. By making x real, the imaginary part of poly becomes q times some function of x, p, and q. So, setting q=0 always gives Im[poly] == 0. But, that does not tell us anything new. However, if we
In[3] := qvals = Cases[List#ToRules#RReduce[ pi == 0 && q != 0, {x,p,q}],
{q -> a_}:> a];
we get several formulas for q involving x and p. For some values of x and p, those formulas may be imaginary, and we can use Reduce to determine where Re[qvals] == 0. In other words, we want the "imaginary" part of y to be real and this can be accomplished by allowing q to be zero or purely imaginary. Plotting the region where Re[q]==0 and overlaying the gradient extremal lines via
With[{rngs = Sequence[{x,-2,2},{y,-10,10}]},
Show#{
RegionPlot[Evaluate[Thread[Re[qvals]==0]/.p-> y], rngs],
ContourPlot[g.RotationMatrix[Pi/2].h.g==0,rngs
ContourStyle -> {Darker#Red,Dashed}]}]
gives
which confirms the regions in the first two plots showing the 3 real roots.
Ended up trying myself since the goal really was to do it 'hands off'. I'll leave the question open for a good while to see if anybody finds a better way.
The code below uses bisection to bracket the points where CountRoots changes value. This works for my case (spotting the singularity at x=0 is pure luck):
In[214]:= findRootBranches[Function[x, Evaluate#geyvals[[1, 1]]], {-5, 5}]
Out[214]= {{{-5., -0.0158768}, 1}, {{-0.0158768, -5.96046*10^-9}, 3}, {{0., 0.}, 2}, {{5.96046*10^-9, 1.05635}, 3}, {{1.05635, 5.}, 1}}
Implementation:
Options[findRootBranches] = {
AccuracyGoal -> $MachinePrecision/2,
"SamplePoints" -> 100};
findRootBranches::usage =
"findRootBranches[f,{x0,x1}]: Find the the points in [x0,x1] \
where the number of real roots of a polynomial changes.
Returns list of {<interval>,<root count>} pairs.
f: Real -> Polynomial as pure function, e.g f=Function[x,#^2-x&]." ;
findRootBranches[f_, {xa_, xb_}, OptionsPattern[]] := Module[
{bisect, y, rootCount, acc = 10^-OptionValue[AccuracyGoal]},
rootCount[x_] := {x, CountRoots[f[x][y], y]};
(* Define a ecursive bisector w/ automatic subdivision *)
bisect[{{x1_, n1_}, {x2_, n2_}} /; Abs[x1 - x2] > acc] :=
Module[{x3, n3},
{x3, n3} = rootCount[(x1 + x2)/2];
Which[
n1 == n3, bisect[{{x3, n3}, {x2, n2}}],
n2 == n3, bisect[{{x1, n1}, {x3, n3}}],
True, {bisect[{{x1, n1}, {x3, n3}}],
bisect[{{x3, n3}, {x2, n2}}]}]];
(* Find initial brackets and bisect *)
Module[{xn, samplepoints, brackets},
samplepoints = N#With[{sp = OptionValue["SamplePoints"]},
If[NumberQ[sp], xa + (xb - xa) Range[0, sp]/sp, Union[{xa, xb}, sp]]];
(* Start by counting roots at initial sample points *)
xn = rootCount /# samplepoints;
(* Then, identify and refine the brackets *)
brackets = Flatten[bisect /#
Cases[Partition[xn, 2, 1], {{_, a_}, {_, b_}} /; a != b]];
(* Reinclude the endpoints and partition into same-rootcount segments: *)
With[{allpts = Join[{First#xn},
Flatten[brackets /. bisect -> List, 2], {Last#xn}]},
{#1, Last[#2]} & ### Transpose /# Partition[allpts, 2]
]]]