I am trying to fit a curve to this set of data, and nothing I've tried is working.
data = {{290, 3.3}, {300, 1.1*10}, {310, 2.9*10}, {320, 7.5*10}, {330, 1.8*10^2}, {340, 4.3*10^2}, {350, 8.3*10^2}, {360, 1.5*10^3}, {370, 3.7*10^3}, {380, 6.3*10^3}, {390, 1.2*10^4}, {400, 2.4*10^4}};
https://i.stack.imgur.com/W3Qd4.jpg
I've tried
FindFit[data, Exp[a*x + b], {a, b}, x],
NonlinearModelFit[data, {A*Exp[B*x + D]}, {A, B, D}, x],
and many other attempts.
I keep getting the error message
"Failed to converge to the requested accuracy or precision within 100
iterations"
. I am at a loss. Any ideas?
The problem is that the function being fitted does not model the data well.
ClearAll[a, b, c];
nlm = NonlinearModelFit[data, a Exp[b Sqrt[x]] + c, {a, b, c}, x, MaxIterations -> 1000]
Show[ListPlot#data, Plot[nlm[x], {x, 290, 400}]]
During times like this, it is always useful to take the logarithm of the y-axis values to obtain a better fit. Otherwise, the data points having smaller x-values will be neglected in the fit.
ClearAll["`*"];
Clear["Global`*"];
data = {{290, 3.3}, {300, 1.1*10}, {310, 2.9*10}, {320, 7.5*10}, {330, 1.8*10^2}, {340, 4.3*10^2}, {350, 8.3*10^2}, {360, 1.5*10^3}, {370, 3.7*10^3}, {380, 6.3*10^3}, {390, 1.2*10^4}, {400, 2.4*10^4}};
data[[All, 2]] = Log#data[[All, 2]];
nlm = NonlinearModelFit[data, a*x + b, {a, b}, x, MaxIterations -> Infinity]
Show[ListPlot#data, Plot[nlm[x], {x, 290, 400}]]
Plot of data and fit, with the y-axis scaled after taking the logarithm:
Related
I`ve seen several answers for quite similar topics with usage of ?NumericQ explained and still can not quite understand what is wrong with my implementation and could my example be evaluated at all the way I want it.
I have solution of differential equation in form of ParametricNDSolve (I believe that exact form of equation is irrelevant):
sol = ParametricNDSolve[{n'[t] == g/(1/(y - f*y) + b*t + g*t)^2 - a*n[t] - c*n[t]^2, n[0] == y*f}, {n}, {t, 0, 10}, {a, b, c, g, f, y}]
After that I am trying to construct a function for FindFit or similar procedure, Nintegrating over function n[a,b,c,g,f,y,t] I have got above with some multiplier (I have chosen Log[z] as multiplier for simplicity)
Func[z_, a_, b_, c_, g_, f_] :=
NIntegrate[
Log[z]*(n[a, b, c, g, f, y][t] /. sol), {t, 0, 10}, {y, 0, Log[z]}]
So I have NIntegrate over my function n[params,t] derived from ParametricNDSolve with multiplier introducing new variable (z) wich also present in the limits of integration (in the same form as in multiplier for simplicity of example)
I am able to evaluate the values of my function Func at any point (z) with given values of parameters (a,b,c,g,f): Func(0,1,2,3,4,5) could be evaluated.
But for some reasons I cannot use FindFit like that:
FindFit[data, Func[z, a, b, c, g, f], {a, b, c, g, f}, z]
The error is: NIntegrate::nlim: y = Log[z] is not a valid limit of integration.
I`ve tried a lot of different combinations of ?NumericQ usage and all seems to lead nowhere. Any help would be appreciated!
Thanks in advance and sorry for pure english in the problem explanation.
Here is a way to define your function:
sol = n /.
ParametricNDSolve[{n'[t] ==
g/(1/(y - f*y) + b*t + g*t)^2 - a*n[t] - c*n[t]^2,
n[0] == y*f}, {n}, {t, 0, 10}, {a, b, c, g, f, y}]
Func[z_?NumericQ, a_?NumericQ, b_?NumericQ, c_?NumericQ, g_?NumericQ,
f_?NumericQ] :=
NIntegrate[Log[z]*sol[a, b, c, g, f, y][t],
{t, 0, 10}, {y, 0, Log[z]}]
test: Func[2, .45, .5, .13, .12, .2] -> 0.106107
I'm not optimistic you will get good results from FindFit with a function with so many parameters and which is so computationally expensive.
I have a differential system like
dx/dt = A x(t) + B y(t)
dy/dt = C x(t) + D y(t)
where A, B, C, and D are real constants. Now I need to explore the behavior of the system if A, instead of being a constant number, is a random number uniformly distributed between a given range. I just need to check qualitatively. I have no background on stochastic integrals, therefore I do not know if this is actually something related with the Ito integral (and this question https://mathematica.stackexchange.com/questions/3141/how-can-you-compute-it-integrals-with-mathematica) . In any case, I do not know how to solve this differential equation.
Any guidance is highly appreciated.
The standard way to solve your system is
FullSimplify[
DSolve[{y'[t] == a x[t] + b y[t], x'[t] == c x[t] + d y[t]}, {y, x}, t]]
Now, you should think WHAT do you want to explore when {a, b, c, d} are random parameters.
Edit
Perhaps you want something like this:
s = FullSimplify[
DSolve[{y'[t] == #[[1]] x[t] + #[[2]] y[t], x'[t] == #[[3]] x[t] + #[[4]] y[t],
x[0] == 1, y[0] == 1}, {y, x}, t]] & /# RandomReal[{-1, 1}, {30, 4}];
ParametricPlot[Evaluate[{x[t], y[t]} /. s[[All, 1]]], {t, 0, 1}]
I asked this question a little while back that did help in reaching a solution. I've arrived at a somewhat acceptable approach but still not fully where I want it. Suppose there are two functions f1[x] and g1[y] that I want to determine the value of x and y for the common tangent(s). I can at least determine x and y for one of the tangents for example with the following:
f1[x_]:=(5513.12-39931.8x+23307.5x^2+(-32426.6+75662.x-43235.4x^2)Log[(1.-1.33333x)/(1.-1.x)]+x(-10808.9+10808.9x)Log[x/(1.-1.x)])/(-1.+x)
g1[y_]:=(3632.71+3806.87y-51143.6y^2+y(-10808.9+10808.9y)Log[y/(1.-1.y)]+(-10808.9+32426.6y-21617.7y^2)Log[1.-(1.y)/(1.-1.y)])/(-1.+y)
Show[
Plot[f1[x],{x,0,.75},PlotRange->All],
Plot[g1[y],{y,0,.75},PlotRange->All]
]
Chop[FindRoot[
{
(f1[x]-g1[y])/(x-y)==D[f1[x],x]==D[g1[y],y]
},
{x,0.0000001},{y,.00000001}
]
[[All,2]]
]
However, you'll notice from the plot that there exists another common tangent at slightly larger values of x and y (say x ~ 4 and y ~ 5). Now, interestingly if I slightly change the above expressions for f1[x] and g1[y] to something like the following:
f2[x_]:=(7968.08-59377.8x+40298.7x^2+(-39909.6+93122.4x-53212.8x^2)Log[(1.-1.33333x)/(1.-1.x)]+x(-13303.2+13303.2x)Log[x/(1.-1.x)])/(-1.+x)
g2[y_]:=(5805.16-27866.2y-21643.y^2+y(-13303.2+13303.2y)Log[y/(1.-1.y)]+(-13303.2+39909.6y-26606.4y^2)Log[1.-(1.y)/(1.-1.y)])/(-1.+y)
Show[
Plot[f2[x],{x,0,.75},PlotRange->All],
Plot[g2[y],{y,0,.75},PlotRange->All]
]
Chop[FindRoot[
{
(f2[x]-g2[y])/(x-y)==D[f2[x],x]==D[g2[y],y]
},
{x,0.0000001},{y,.00000001}
]
[[All,2]]
]
And use the same method to determine the common tangent, Mathematica chooses to find the larger values of x and y for the positive sloping tangent.
Finally, my question: is it possible to have Mathematica find both the high and low x and y values for the common tangent and store these values in a similar way that allows me to make a list plot? The functions f and g above are all complex functions of another variable, z, and I am currently using something like the following to plot the tangent points (should be two x and two y) as a function of z.
ex[z_]:=Chop[FindRoot[
{
(f[x,z]-g[y,z])/(x-y)==D[f[x],x]==D[g[y],y]
},
{x,0.0000001},{y,.00000001}
]
[[All,2]]
]
ListLinePlot[
Table[{ex[z][[i]],z},{i,1,2},{z,1300,1800,10}]
]
To find estimates for {x, y} that would solve your equations, you could plot them in ContourPlot and look for intersection points. For example
f1[x_]:=(5513.12-39931.8 x+23307.5 x^2+(-32426.6+75662. x-
43235.4 x^2)Log[(1.-1.33333 x)/(1.-1.x)]+
x(-10808.9+10808.9 x) Log[x/(1.-1.x)])/(-1.+x)
g1[y_]:=(3632.71+3806.87 y-51143.6 y^2+y (-10808.9+10808.9y) Log[y/(1.-1.y)]+
(-10808.9+32426.6 y-21617.7 y^2) Log[1.-(1.y)/(1.-1.y)])/(-1.+y)
plot = ContourPlot[{f1'[x] == g1'[y], f1[x] + f1'[x] (y - x) == g1[y]},
{x, 0, 1}, {y, 0, 1}, PlotPoints -> 40]
As you can see there are 2 intersection points in the interval (0,1). You could then read off the points from the graph and use these as starting values for FindRoot:
seeds = {{.6,.4}, {.05, .1}};
sol = FindRoot[{f1'[x] == g1'[y], f1[x] + f1'[x] (y - x) == g1[y]},
{x, #1}, {y, #2}] & ### seeds
To get the pairs of points from sol you can use ReplaceAll:
points = {{x, f1[x]}, {y, g1[y]}} /. sol
(*
==> {{{0.572412, 19969.9}, {0.432651, 4206.74}},
{{0.00840489, -5747.15}, {0.105801, -7386.68}}}
*)
To show that these are the correct points:
Show[Plot[{f1[x], g1[x]}, {x, 0, 1}],
{ParametricPlot[#1 t + (1 - t) #2, {t, -5, 5}, PlotStyle -> {Gray, Dashed}],
Graphics[{PointSize[Medium], Point[{##}]}]} & ### points]
OK, so let's quickly rewrite what you've done so far:
Using your f1 and g1, we have the plot
plot = Plot[{f1[x], g1[x]}, {x, 0, .75}]
and the first shared tangent at
sol1 = Chop[FindRoot[{(f1[x] - g1[y])/(x - y) == D[f1[x], x] == D[g1[y], y]},
{x, 0.0000001}, {y, .00000001}]]
(* {x -> 0.00840489, y -> 0.105801} *)
Define the function
l1[t_] = (1 - t) {x, f1[x]} + t {y, g1[y]} /. sol1
then, you can plot the tangents using
Show[plot, Graphics[Point[{l1[0], l1[1]}]],
ParametricPlot[l1[t], {t, -1, 2}],
PlotRange -> {{-.2, .4}, {-10000, 10000}}]
I briefly note (for my own sake) that the equations you used
(e.g., to generate sol1 above)
come from requiring that the tangent line for f1 at x
tangentially hits g1 at some point y, i.e.,
LogicalExpand[{x, f[x]} + t {1, f'[x]} == {y, g[y]} && f'[x] == g'[y]]
To investigate where the shared tangents lie, you can use a Manipulate:
Manipulate[Show[plot, ParametricPlot[{x, f1[x]} + t {1, f1'[x]}, {t, -1, 1}]],
{x, 0, .75, Appearance -> "Labeled"}]
which produces something like
Using the eyeballed values for x and y, you can get the actual solutions using
sol = Chop[Table[
FindRoot[{(f1[x] - g1[y])/(x - y) == D[f1[x], x] == D[g1[y], y]},
{x, xy[[1]]}, {y, xy[[2]]}], {xy, {{0.001, 0.01}, {0.577, 0.4}}}]]
define the two tangent lines using
l[t_] = (1 - t) {x, f1[x]} + t {y, g1[y]} /. sol
then
Show[plot, Graphics[Point[Flatten[{l[0], l[1]}, 1]]],
ParametricPlot[l[t], {t, -1, 2}, PlotStyle -> Dotted]]
This process could be automated, but I'm not sure how to do it efficiently.
I need to build a partial Inverted Index. Something like:
l = {{x, {h, a, b, c}}, {y, {c, d, e}}}
iI[l]
(*
-> {{a, {x}}, {b, {x}}, {c, {x, y}}, {d, {y}}, {e, {y}}, {h, {x}}}
*)
I think it is pretty clear what it does. In the input list, the {x, y ...} are unique, while the {a, b, c, ..} are not. The output ought to be ordered by #[[1]].
Right now, I am doing this:
iI[list_List] := {#, list[[Position[list, #][[All, 1]]]][[All, 1]]} & /#
(Union#Flatten#Last#Transpose#list)
But it looks too convoluted for such an easy task, seems too slow, and I should be able to cope with Legion.
A test drive to compare your results:
words = DictionaryLookup[];
abWords = DictionaryLookup["ab" ~~ ___];
l = {#, RandomChoice[abWords, RandomInteger[{1, 30}]]} & /# words[[1 ;; 3000]];
First#Timing#iI[l]
(*
-> 5.312
*)
So, any ideas for an speedup?
Seems a classic task for Reap-Sow (improvement in the final version due to #Heike):
iI[list_] := Sort[Reap[Sow ### list, _, List][[2]]]
Then,
iI[l]
{{a, {x}}, {b, {x}}, {c, {x, y}}, {d, {y}}, {e, {y}}, {h, {x}}}
and
In[22]:=
words=DictionaryLookup[];
abWords=DictionaryLookup["ab"~~___];
l={#,RandomChoice[abWords,RandomInteger[{1,30}]]}&/#words[[1;;3000]];
First#Timing#iI[l]
Out[25]= 0.047
EDIT
Here is an alternative version with a similar (slightly worse) performance:
iIAlt[list_] :=
Sort#Transpose[{#[[All, 1, 2]], #[[All, All, 1]]}] &#
GatherBy[Flatten[Thread /# list, 1], Last];
It is interesting that Reap - Sow here gives an even slightly faster solution than the one based on structural operations.
EDIT 2
Just for an illustration - for those who prefer rule-based solutions, here is one based on a combination of Dispatch and ReplaceList:
iIAlt1[list_] :=
With[{disp = Dispatch#Flatten[Thread[Rule[#2, #]] & ### list]},
Map[{#, ReplaceList[#, disp]} &, Union ## list[[All, 2]]]]
It is about 2-3 times slower than the other two, though.
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]
]]]