Related
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'm a beginner in Mathematica programming. My code is not running as expected. I wonder if anyone could examine what goes wrong? Here is part of the code.
F[{k_, n_, x_}] =
Which[k == 0, f[a, b, x],
k == 1, g[a, b, n, x],
k == 2, h[c, d, n, x]]
G[x_] = F[{0, 0, x}]
While[Extract[G[x], 1] != 3, G[x_] = F[G[x]]]
The functions f, g and h are defined by Which as is F, and they are all vector-valued so that it makes sense to iterate F. What I want to achieve is: given initial value {0,0,x}, keep iterating F until the first component of F becomes 3. Is there anything, e.g. syntax, wrong in the above code?
Thanks!
You need to use SetDelayed (:=) for function definitions like: F[x_]:=x. When you use Set (=) like F[x_]=x, the it is essentially the same as F[_]=x since the definition isn't delayed until evaluation, so there is no way to transfer the matched pattern on the left hand side into the evaluation of the right hand side.
As jVincent mentioned, I would use := instead of = while defining F.
I would also use the built in NestWhile instead of manually iterating.
NestWhile[F, {0, 0, x}, Function[e, Extract[e, 1] != 3]]
I can't quite comment on how to correct the code as written because I'm not entirely sure how reassigning G in the While works.
Any easy question for the Mathematica experts here:
Given a list, say
Clear[a, b, c];
data = {a, b, c};
and I want to get back all lists of length 1,2,3,...Length[data] starting from the start to the end, so that I get the following for the above
out = {{a}, {a, b}, {a, b, c}}
I looked at the commands in M to find a ready one to use, and I could (looked at all the Map's and Nest* functions, but not that I can see how to use for this). I am sure it is there, but I am not seeing it now.
now I do this silly Do loop to build it
m=Length[data];
First#Reap[Do[Sow[data[[1;;i]]],{i,1,m}]][[2]]
{{a},{a,b},{a,b,c}}
question is: does Mathematica have a build-in command to do the above?
update 8 am
I've deleted the tests I've done an hr ago and will be reposting them again soon. I need to run them few times and take an average as that is the better way to do this performance test.
update 9 am
Ok, I've re-run the performance tests on all solutions shown below. 8 methods.
For each method, I run it 5 times and took the mean.
I did this for n={1000, 5000, 10000, 15000, 25000, 30000} where n is the length of the original list to process.
can't go much over 30,000, will run out of ram. I only have 4 GB ram.
I made a small function called makeTable[n, methods] which generate performance table for specific n. test code is below (written quickly so not the most clean code, not very functional, as I have to go :), but it is below and any one can change/clean it, etc... if they want
conclusion: Kguler method was the fastest, with Thies method almost the same for large n, (30,000), so for all practical purposes, may be Thies and Kguler methods can be declared as the winners for large n? But since Kguler is also fastest for small n, so far, he gets the clear edge.
Again, test code is below for any one to check and run to see if I might made an error somewhere. As correctly predicted by Leonid, the linked list method did not fare too well for large n.
I think more tests are needed, as only taking the mean of 5 might not be enough, also other considerations I might have missed. This is not an exact test, just a rough one to get an idea.
I tried not to use the pc much while running the tests. I used AbsoluteTiming[] to measure cpu.
Here is screen shot of the tables generated
Here is the test code:
methods = {nasser, wizard1, wizard2, wizard3, kguler, leonid1,
leonid2, thies};
AppendTo[$ContextPath, "Internal`"];
ClearAll[linkedList, leonid2];
SetAttributes[linkedList, HoldAllComplete];
nasser[lst_] := Module[{m = Length[lst]},
First#Reap[Do[Sow[lst[[1 ;; i]]], {i, 1, m}]][[2]]
];
wizard1[lst_] := Module[{},
Take[lst, #] & /# Range#Length#lst
];
wizard2[lst_] := Module[{},
Table[Take[#, i], {i, Length##}] & #lst
];
wizard3[lst_] := Module[{},
Rest#FoldList[Append, {}, #] & #lst
];
kguler[lst_] := Module[{},
Reverse#NestList[Most, #, Length[#] - 1] & #lst
];
leonid1[lst_] := Module[{b = Bag[{}]},
Map[(StuffBag[b, #]; BagPart[b, All]) &, lst]
];
leonid2[lst_] := Module[{},
Map[List ## Flatten[#, Infinity, linkedList] &,
FoldList[linkedList, linkedList[First#lst], Rest#lst]]
];
thies[lst_] :=
Module[{},
Drop[Reverse#
FixedPointList[If[Length[#] > 0, Most, Identity][#] &, lst], 2]
];
makeTable[n_, methods_] :=
Module[{nTests = Length[methods], nTries = 5, i, j, tests, lst},
lst = Table[RandomReal[], {n}];
tests = Table[0, {nTests}, {nTries}];
For[i = 1, i <= nTests, i++,
For[j = 1, j <= nTries, j++,
tests[[i, j]] = First#AbsoluteTiming[methods[[i]][lst] ]
]
];
tbl = Table[{ToString[methods[[i]]], Mean[ tests[[i, All]] ]}, {i,
nTests}] ;
Grid[Join[{{"method", "cpu"}}, tbl],
Frame -> All, FrameStyle -> Directive[Thickness[.005], Gray],
Spacings -> {0.5, 1}
]
];
Now to run, do
makeTable[1000, methods]
Warning, do not try something over 30,000 unless you have zillion GB, else M might not return. It happened to me, and had to reboot the PC.
update 12/26/11 3:30PM
I see that Thies has a newer version of this algorithm (I called it thies2 in the methods table), so I re-run everything again, here is the updated table, I removed the linked list version since it is known in advance not to be fast for large n, and this time, I run them each for 10 times (not 5 as above) and then took the mean). I also started M fresh using factory setting (restarted it holding alt-shift keys so that all setting are back to original settings just in case)
conclusion so far
Kugler is fastest for smaller n, i.e. n<20,000.
For larger n, now Thies second version is faster than Thies version 1 and now it edges ahead ever so slightly ahead of Kugler method for large n. Congratulation to Thies, the current lead in this performance test. But for all practical purposes, I would say both Thies and Kugler methods are the fastest for large n, and Kugler remain the fastest for smaller n.
Below are tables and the updated test code below them. Any one is free to run the tests for themselves, just in case I might overlooked something.
The current test code:
$MinPrecision = $MachinePrecision;
$MaxPrecision = $MachinePrecision;
methods = {nasser, wizard1, wizard2, wizard3, kguler, leonid, thies1,
thies2};
AppendTo[$ContextPath, "Internal`"];
nasser[lst_] := Module[{m = Length[lst]},
First#Reap[Do[Sow[lst[[1 ;; i]]], {i, 1, m}]][[2]]
];
wizard1[lst_] := Module[{},
Take[lst, #] & /# Range#Length#lst
];
wizard2[lst_] := Module[{},
Table[Take[#, i], {i, Length##}] & #lst
];
wizard3[lst_] := Module[{},
Rest#FoldList[Append, {}, #] & #lst
];
kguler[lst_] := Module[{},
Reverse#NestList[Most, #, Length[#] - 1] & #lst
];
leonid[lst_] := Module[{b = Bag[{}]},
Map[(StuffBag[b, #]; BagPart[b, All]) &, lst]
];
thies1[lst_] :=
Module[{},
Drop[Reverse#
FixedPointList[If[Length[#] > 0, Most, Identity][#] &, lst], 2]
];
thies2[lst_] :=
Module[{},
Drop[Reverse#
FixedPointList[If[# =!= {}, Most, Identity][#] &, lst], 2]
];
makeTable[n_Integer, methods_List] :=
Module[{nTests = Length[methods], nTries = 10, i, j, tests, lst},
lst = Table[RandomReal[], {n}];
tests = Table[0, {nTests}, {nTries}];
For[i = 1, i <= nTests, i++,
For[j = 1, j <= nTries, j++,
tests[[i, j]] = First#AbsoluteTiming[methods[[i]][lst] ]
]
];
tbl = Table[{ToString[methods[[i]]], Mean[ tests[[i, All]] ]}, {i,
nTests}] ;
Grid[Join[{{"method", "cpu"}}, tbl],
Frame -> All, FrameStyle -> Directive[Thickness[.005], Gray],
Spacings -> {0.5, 1}
]
];
To run type
n=1000
makeTable[n, methods]
Thanks for everyone for their answers, I learned from all of them.
You can use
f = Reverse#NestList[Most, #, Length[#] - 1] &
f#{a,b,c,d,e} gives {{a}, {a, b}, {a, b, c}, {a, b, c, d}, {a, b, c, d, e}}.
An alternative using ReplaceList -- much slower than f, but ... why not?:
g = ReplaceList[#, {x__, ___} -> {x}] &
I propose this:
runs[lst_] := Take[lst, #] & /# Range#Length#lst
Or this:
runs2 = Table[Take[#, i], {i, Length##}] &;
kguler's answer inspired me to write this:
Rest#FoldList[Append, {}, #] &
But this is slower than his method because of Mathematica's slow appends.
Here is another method which is roughly as efficient as the one involving Take, but uses the Internal`Bag functionality:
AppendTo[$ContextPath, "Internal`"];
runsB[lst_] :=
Module[{b = Bag[{}]}, Map[(StuffBag[b, #]; BagPart[b, All]) &, lst]];
I don't claim that it is simpler than the one based on Take, but it seems to be a simple example of Internal`Bag at work - since this is exactly the type of problem for which these can be successfully used (and there might be cases where lists of explicit positions would either not be available or expensive to compute).
Just to compare, the solution based on linked lists:
ClearAll[linkedList, runsLL];
SetAttributes[linkedList, HoldAllComplete];
runsLL[lst_] :=
Map[List ## Flatten[#, Infinity, linkedList] &,
FoldList[linkedList, linkedList[First#lst], Rest#lst]]
will be an order of magnitude slower on large lists.
Another idea:
Inits[l_] := Drop[Reverse#FixedPointList[
If[Length[#] > 0, Most, Identity][#] &,
l
], 2];
Update:
This version is a bit faster by omitting computing the length each time:
Inits2[l_] := Drop[Reverse#FixedPointList[
If[# =!= {}, Most, Identity][#] &,
l
], 2];
Probably not the most efficient, but another approach:
dow[lst_] := lst[[1 ;; #]] & /# Range#Length#lst
For example:
dow[{a, b, c, d, ee}]
gives:
{{a}, {a, b}, {a, b, c}, {a, b, c, d}, {a, b, c, d, ee}}
Applying Orthogonalize[] once:
v1 = PolyhedronData["Dodecahedron", "VertexCoordinates"][[1]];
Graphics3D[Line[{{0, 0, 0}, #}] & /#
Orthogonalize[{a, b, c} /.
FindInstance[{a, b, c}.v1 == 0 && (Chop#a != 0.||Chop#b != 0.||Chop#c != 0.),
{a, b, c}, Reals, 4]], Boxed -> False]
And now twice:
Graphics3D[Line[{{0, 0, 0}, #}] & /#
Orthogonalize#Orthogonalize[{a, b, c} /.
FindInstance[{a, b, c}.v1 == 0 && (Chop#a != 0.||Chop#b != 0.||Chop#c != 0.),
{a, b, c}, Reals, 4]], Boxed -> False]
Errr ... Why?
I think the first result is due to numerical error, taking
sys = {a,b,c}/.FindInstance[
{a, b, c}.v1 == 0 && (Chop#a != 0. || Chop#b != 0. || Chop#c !=0.),
{a, b, c}, Reals, 4];
then MatrixRank#sys returns 2, therefor the system itself is only two dimensional. To me, this implies that the first instance of Orthogonalize is generating a numerical error, and the second instance is using the out of plane error to give you your three vectors. Removing the Chop conditions fixes this,
Orthogonalize[{a, b, c} /.
N#FindInstance[{a, b, c}.v1 == 0,{a, b, c}, Reals, 4]]
where N is necessary to get rid of the Root terms that appear. This gives you a two-dimensional system, but you can get a third by taking the cross product.
Edit: Here's further evidence that its numerical error due to Chop.
With Chop, FindInstance gives me
{{64., 3.6, 335.108}, {-67., -4.3, -350.817}, {0, 176., 0},
{-2., -4.3, -10.4721}}
Without Chop, I get
{{-16.8, 3.9, -87.9659}, {6.6, -1.7, 34.558}, {13.4, -4.3, 70.1633},
{19.9, -4.3, 104.198}}
which is a significant difference between the two.
I also assumed it would be a numerical error, but didn't quite understand why, so I tried to implement Gram-Schmidt orthogonalization myself, hoping to understand the problem on the way:
(* projects onto a unit vector *)
proj[u_][v_] := (u.v) u
Clear[gm, gramSchmidt]
gm[finished_, {next_, rest___}] :=
With[{v = next - Plus ## Through[(proj /# finished)[next]]},
gm[Append[finished, Normalize#Chop[v]], {rest}]
]
gm[finished_, {}] := finished
gramSchmidt[vectors_] := gm[{}, vectors]
(Included for illustration only, I simply couldn't quite figure out what's going on before I reimplemented it myself.)
A critical step here, which I didn't realize before, is deciding whether a vector we get is zero or not before the normalization step (see Chop in my code). Otherwise we might get something tiny, possibly a mere numerical error, which is then normalized back into a large value.
This seems to be controlled by the Tolerance option of Orthogonalize, and indeed, raising the tolerance, and forcing it to discard tiny vectors fixes the problem you describe. Orthogonalize[ ... , Tolerance -> 1*^-10] works in a single step.
Perhaps it is a characteristic of the default GramSchmidt method?
Try: Method -> "Reorthogonalization" or Method -> "Householder".
I'm trying to plot points that I've created in a table in mathematica but for some reason one component of my points seems to have double braces around it while the other only has one as below:
{{x},y},{{x1},y1}....{{xn},yn}
and list plot will not recognize these as points and will not plot them.
Here is my mathematica code:
Remove["Global`*"]
b = .1;
w = 1;
Period = 1;
tstep = 2 Pi/Period;
s = NDSolve[{x''[t] + b x'[t] - x[t] + x[t]^3 - .5 Cos[w t] == 0,
x'[0] == 0, x[0] == 0}, x[t], {t, 0, 1000}, MaxSteps -> Infinity];
x[t_] = x[t] /. s
data = Table[Evaluate[{x'[t], .5}], {t, 0, 1000, tstep}]
ListPlot[data]
I've also tried using the command
ListPlot[Flatten[Table[Evaluate[{x'[t], .5}], {t, 0, 1000, tstep}]]]
to no avail as well as
ListPlot[Table[Evaluate[{Flatten[x'[t]], .5}], {t, 0, 1000, tstep}]]]
How can I remove the {}?
You may try something along these lines:
Clear["Global`*"]
b = .1;
w = 1;
s = NDSolve[{x''[t] + b x'[t] - x[t] + x[t]^3 - .5 Cos[w t] == 0,
x'[0] == 0, x[0] == 0}, x[t], {t, 0, 1000}, MaxSteps -> Infinity];
xr[u_] := ((x[t] /. s[[1]]) /. t -> u)
Plot[(xr'[u]), {u, 0, 30}]
But I am not sure what are you trying to get from the {x'[t], .5} part
My colleagues are correct, but I think there is more that can be said. First, to your actual question. The output of NDSolve is a list of the form
{{x[t]->InterpolatingFunction[...]}, {x[t]->InterpolatingFunction[...]}, ...}
where the second and subsequent replacement rules are only there if more than one solution is present. I have never encountered a case using NDSolve where that is true, but it makes the answer consistent with Solve, where multiple solutions is not uncommon. Therefor, with only one solution, you have a double list, i.e.
{{x[t]->InterpolatingFunction[...]}}
As per Mr. Wizard, you can use First, or you can use Part, i.e.
NDSolve[ ... ][[ 1 ]]
which is my preferred method, although it is slightly more difficult to read and may obscure your intent. You should be aware that the InterpolatingFunction that NDSolve returns is a function, and it will accept variables directly. So, the variables on the left hand side of the declarations
x[t_] = x[t] /. s
and from Belisarius
xr[u_] := ((x[t] /. s[[1]]) /. t -> u)
are superfluous at best, and the second one requires the replacement to occur every time xr is used. Instead, you can declare
x = x[t] /. s
and then writing x[t] afterwards will return IntepolatingFunction[t], exactly like you want. Then, as Belisarius points out, you can use it, or its derivative, in Plot directly, instead of first building a table of values and feeding them into ListPlot.
Edit: when I first posted this, I didn't notice a quirk with NDSolve. If you explicitly solve for x[t] not x, then NDSolve returns InterpolatingFunction[...][t], but if you just solve for x you get what I posted. This quirk allows both the OP's and Belisarius's solutions to function, otherwise the replacement shouldn't occur.
It is most likely that x'[t] is returning something of the form {x_i}. Try replacing the data=Table... line with this
data = Table[Evaluate[{First[x'[t]], .5}], {t, 0, 1000, tstep}]
An alternative would be to do
data=data /. {{x_}, y_} :> {x, y};
which uses ReplaceAll (/.) to replace every occurrence of {{x_i},y_i} with {x_i,y_i}
Example:
There are arguably better ways to accomplish what you are doing, but that is not what you asked.
To remove the extra {} recognize this comes from the result of NDSolve, and therefore use:
s = First # NDSolve[{x''[t] + b x'[t] - x[t] + x[t]^3 - .5 Cos[w t] == 0,
x'[0] == 0, x[0] == 0}, x[t], {t, 0, 1000}, MaxSteps -> Infinity];