Logistic Map Bifurcation Diagrams

Math 242 Modern Computational Mathematics

Code from last time

First define the logistic map (Subscript[f, r])(x)=r x(1-x).

f[r_][x_]:=r*x(1-x)

We also have a module for drawing cobweb plots. The basic usage is cobwebPlot[ function, starting value, number of iterates ]. Optional parameters xmin and xmax specify the domain to be plotted.

cobwebPlot[f_,start_,numIter_,xmin_:0,xmax_:1]:=Module[{cob={{start,0}},prev=start,next,g1,g2},
(* build the list of points to plot *)
Do[
next=f[prev];
AppendTo[cob,{prev,next}];
AppendTo[cob,{next,next}];
prev=next,
numIter];

(* display the plot *)
g1=Graphics[{Purple,Opacity[0.2],Line[cob]}];
g2=Plot[{x,f[x]},{x,xmin,xmax},PlotStyle->{Blue,Black}];
Show[{g1,g2},Frame->True]
]

Interactive Visualization of Logistic Map Trajectories

The Manipulate function creates sliders to control the values of r and x, updating the trajectory plot in real time.

Manipulate[
ListPlot[NestList[f[r],x,50],PlotRange->{0,1},AxesLabel->{"iteration","value"},Joined->True,Mesh->All,AspectRatio->1/3],{x,0,1},{r,0,4}]

Bifurcation Diagrams

A bifurcation diagram visualizes the cycles that occur in logistic map trajectories over the range of parameter values 0<=r<=4. Here is how we create a bifurcation diagram. We will do some preliminary computations before putting everything together in a Module.

For fixed r, compute the trajectory of (Subscript[f, r]) for some number of iterations:

r=3.5; (* value of r for now *)
start=0.3; (* starting value (Subscript[x, 0]) *)
numIter=500; (* number of iterations to compute *)
traj=NestList[f[r],start,numIter]

Now select only the final portion of the trajectory, which we call the “tail.”

numTail=100; (* number of values to include in the tail *)
tail=traj[[-numTail;;]]

We want to plot the tail as points (r,x). To do this, make a list of points containing (r,x) for each x in the tail.

points=Table[{r,x},{x,tail}]

We will plot these points using the Graphics function and the following options.

Graphics[ {PointSize[0.01],Opacity[0.1], Point[points]}, AspectRatio->1/2,Frame->True]

Now we need to repeat the above for lots of value of r. The following module is helpful

bifurcationDiagram[f_,start_,rStart_,rStop_,rStep_,numIter_,numTail_]:=Module[{traj,tail,points,allPoints={}},
Do[
(* compute a trajectory of (Subscript[f, r]) *)
traj=NestList[f[r],start,numIter];

(* take only the tail of the trajectory *)
tail=traj[[-numTail;;]];

(* convert the tail to a list of points, and join them to the list of points *)
points=Table[{r,x},{x,tail}];
allPoints=Join[allPoints,points],

(* repeat for r from rStart to rStop in steps of rStep *)
{r,rStart,rStop,rStep}];

(* display the bifurcation diagram *)
Graphics[ {PointSize[0.001],Opacity[0.1], Point[allPoints]}, AspectRatio->1/2,Frame->True]
]

We can finally make a bifurcation diagram. You should experiment with different parameter values.

bifurcationDiagram[f,0.3,0,4,0.001,500,100]//Quiet

bifurcationDiagram[f,0.3,3.4,3.6,0.00001,500,100]//Quiet

bifurcationDiagram[f,0.3,3.5,4,0.0001,500,100]//Quiet

bifurcationDiagram[f,0.3,3.73,3.75,0.00001,500,100]//Quiet

Examine r=3.83

cobwebPlot[f[3.83],0.16,10000]

Examine r=4

We observe aperiodic (not periodic) behavior:

traj=NestList[f[4],0.3,500];
ListPlot[traj,Joined->True,Mesh->All]

Make a histogram of the values in the trajectory:

traj=NestList[f[4],0.5,50]
Histogram[traj,100]

traj=NestList[f[4],0.51,5000];
Histogram[traj,100]

cobwebPlot[f[4],.9999,20]

Sensitive dependence on initial conditions

traj1=NestList[f[4],0.52,50];
traj2=NestList[f[4],0.520001,50];
ListPlot[{traj1,traj2},Joined->True,Mesh->All]