Exercises 3.1.a

For:

x
=r+x-log(1+x)
i) Sketch the different vector field types that appear when you vary
r
. We’re actually going to do this first the hard way, then the easier way.
​
Looking at the phase portrait for different values of
r
we get the following.
​
In[]:=
finsol[r_]:=Select[(x/.NSolve[r+x-Log[1+x]0,x]),Head[#]Real&];GraphicsGridPartitionShowPlot[#+x-Log[1+x],{x,-5,6},AxesLabelEvaluate[Style[#,14]&/@{"x","

x
"}],PlotLabel"r = "<>ToString[#],AxesOrigin{0,0}],Iffinsol[#]==={},ListPlot[{{10,10}}],IfMin[finsol[#]]<10,If#0,ShowGraphics[Circle[{0,0},0.2]],GraphicsDisk{0,0},0.2,
π
2
,
-π
2
,Show[{Graphics[Disk[{finsol[#][[1]],0},0.2]],Graphics[Circle[{finsol[#][[2]],0},0.2]]}],Show[{Graphics[Disk[{finsol[#][[1]],0},0.2]],Graphics[Circle[{finsol[#][[2]],0},0.2]]}],If[finsol[#]==={},Graphics[{Thick,Arrow[{{-3,0},{3,0}}]}],{Graphics[{Thick,Arrow[{{-3,0},{Min[finsol[#]]-0.2,0}}],Arrow[{{Max[finsol[#]]-0.2,0},{Min[finsol[#]]+0.2,0}}],Arrow[{{Max[finsol[#]]+0.2,0},{3,0}}]}]}],PlotRange{{-3,3},{-3,3}},AspectRatio1&/@Range[-1,0.25,0.25],3,ImageSize1200,Spacings{-10,0},FrameAll//Quiet
Out[]=
​
Now taking the arrows and fixed points alone and plotting them as a vector field:
In[]:=
rv=Range[-1.75,0.25,0.25]​​vfp=ShowShowIffinsol[#]==={},ListPlot[{{10,10}}],IfMin[finsol[#]]<10,If#0,ShowGraphics[Circle[{0,#},0.2]],GraphicsDisk{0,#},0.2,
π
2
,
-π
2
,Show[{Graphics[Disk[{finsol[#][[1]],#},0.2]],Graphics[Circle[{finsol[#][[2]],#},0.2]]}],Show[{Graphics[Disk[{finsol[#][[1]],#},0.2]],Graphics[Circle[{finsol[#][[2]],#},0.2]]}],If[finsol[#]==={},Graphics[{Thick,Red,Arrow[{{-3,#},{3.5,#}}]}],{Graphics[{Thick,Red,Arrow[{{-3,#},{Min[finsol[#]]-0.2,#}}],Arrow[{{Max[finsol[#]]-0.2,#},{Min[finsol[#]]+0.2,#}}],Arrow[{{Max[finsol[#]]+0.2,#},{3.5,#}}]}]}],AspectRatio1&/@rv,PlotRange{{-2,3.5},{-2.5,1.5}},AspectRatio1,AxesLabelEvaluate[Style[#,14]&/@{"x","r"}],AxesTrue//Quiet
Out[]=
{-1.75,-1.5,-1.25,-1.,-0.75,-0.5,-0.25,0.,0.25}
Out[]=
We get the bifurcation diagram by rotating this whole plot above:
In[]:=
Show[vfp/.Arrow[{{a_,b_},{c_,d_}}]Arrow[{{b,a},{d,c}}]/.Circle[{a_,b_},c_]Circle[{b,a},c]/.Disk[{a_,b_},c__]Disk[{b,a},c],PlotRange{{-2.5,1.5},{-2,3.5}}]/.{"x""r","r""x"}
Out[]=
We can actually find these fixed points and thus the bifurcation diagram more simply. We need to solve

x
=r+x-ln(1+x)=0.
We can only do this numerically though.
In[]:=
finsol[r_]:=Select[(x/.NSolve[r+x-Log[1+x]0,x]),Head[#]Real&]//Quiet​​finsol[-2]
Out[]=
{-0.947531,3.50524}
We can plot these fixed points and this gives us
In[]:=
Reverse[#]&/@Sort[Flatten[Partition[Join[Riffle[#[[2]],#[[1]]],{#[[1]]}],2]&/@DeleteCases[{#,finsol[#]}&/@Range[-1,0,0.0025],{_,{}}|{0.,{0.}}],1]];​​pl1=Show[ListLinePlot[Select[%,#[[2]]>0&],PlotStyle{Dashed,Blue}],ListLinePlot[Select[%,#[[2]]<0&],PlotStyleBlue],PlotRangeAll,AxesLabelEvaluate[Style[#,16]&/@{"r","x"}]]
Out[]=
The critical point is when the there is only a single solution. This occurs when r=0, x=0:
Critical point at
r=1
, and this occurs at:
x=0
:
In[]:=
​​Show[pl1,ListPlot[{{0,0}},PlotStyle{Red,PointSize[0.02]}],AxesLabelEvaluate[Style[#,16]&/@{"r","x"}]]
Out[]=
Homepage