The logistic map

Cobweb diagram, map iterates and orbit diagram (interactive)

Clear[r1,r2,x1,x2,dx,dr,n,r]
iter = 400;
x1=0;x2=1;dx=0.002;
r1=0;r2=4.;dr=0.005;
OrbitD=Rasterize[ListPlot[ParallelTable[Thread[{r,Nest[r # (1-#)&,Range[x1,x2,dx],iter]}],{r,r1,r2,dr}],
PlotStyle->{{Black,Opacity[0.08],AbsolutePointSize[0.001]},{Black,Opacity[0.08],AbsolutePointSize[0.001]}}
,Frame->True,FrameLabel->{"r","x"},AspectRatio->0.5,ImageSize->600,LabelStyle->20,PlotRange->{0,1}]]

Clear[r,x0,x,n]
Manipulate[
CobW=Show[Plot[{Nest[r# - r((#)^2) &, x,k],r x - r (x^2),x},{x,0,1},PlotStyle->{Blue,{Thickness[0.007],Red},Blue},Frame->True,PlotRange->{{0,1},{0,1}},AspectRatio->0.8,FrameLabel->{"(Subscript[x, n])","(Subscript[x, n + 1])"}],Graphics[Flatten[MapIndexed[{Opacity[0.39],Line[{{#,If[#==x0,0,#]},{#,r #-r ((#)^2)}}],Line[{{#,r #-r ((#)^2)},{r #-r ((#)^2),r #-r ((#)^2)}}]}& ,NestWhileList[r #-r ((#)^2)&,x0,#1≠r #2-r ((#2)^2)&,2,n]]]],ImageSize->{320,320},LabelStyle->18];
IterP=ListLinePlot[NestList[r #-r ((#)^2)&,x0,n],FrameLabel->{"n","(Subscript[x, n])"},DataRange->{0,n},PlotRange->{0,1},Frame->True,Mesh->All,MeshStyle->{PointSize[Large],Red},PlotStyle->Gray,AspectRatio->0.8,ImageSize->{320,320},LabelStyle->18];
LineP=Plot[2 Sign[ξ-r],{ξ,0,4},ExclusionsStyle->Blue,PlotRange->{0,1},Frame->True,FrameLabel->{"r","x"},AspectRatio->0.5,ImageSize->600,LabelStyle->20,Prolog->Inset[OrbitD]];
Grid[{{CobW,IterP},{LineP,SpanFromLeft}}],
{k,{1,2,3,4,5,6},ControlType->Setter},
{{n,30},1,150,1,ImageSize->Large,Appearance->"Labeled"}, 
{{r,3.6},0,4,ImageSize->Large,Appearance->"Labeled"},  
{{x0,0.15, "(Subscript[x, 0])"},0,1,ImageSize->Large,Appearance->"Labeled"},SaveDefinitions->True]

Orbit diagram and Lyapunov exponent λ(r), the logistic map

Manipulate[Module[{rg1,rg2},
Column[{
Quiet@ListPlot[Flatten[logisticMapOrbitCF[#,n]&/@Range[Max[-2,a[[1]]-.055/magH],Min[4,a[[1]]+.045/magH],ControlActive[.6,0.15]/magH/pts],1],PlotStyle->{Black,AbsolutePointSize[1]},PlotLabel->Style["Orbit diagram",20],PlotRange->{{a[[1]]-.055/magH,a[[1]]+.045/magH},{a[[2]]-.52/magV,a[[2]]+.5/magV}},AxesOrigin->{a[[1]]-.055/magH,Automatic},AspectRatio->.65,ImagePadding->{{50,13},{30,0}},ImageSize->500,Frame->True,FrameLabel->{None, "x"},LabelStyle->19],
Quiet@ListPlot[{#,lyapListCF[#,n]}&/@Range[Max[-2,a[[1]]-.055/magH],Min[4,a[[1]]+.045/magH],ControlActive[.6,0.15]/magH/pts],PlotLabel->Style["Lyapunov exponent λ",20],Joined->True,PlotRange->{{a[[1]]-.055/magH,a[[1]]+0.045/magH},Full},AxesOrigin->{a[[1]]-.055/magH,0},Ticks->{Automatic,{0}},ImagePadding->{{50,13},{50,0}},AspectRatio->.54,ImageSize->500,Frame->True,FrameLabel->{"r", "λ"},LabelStyle->19]
},Spacings->0]],
{{a,{3.55,0.5}},Locator,Appearance->Style["⊕",Red,Bold,18]},
Style["Zoom",Bold],
"horizontal",
{{magH,0.1,""},.1,10,.1,VerticalSlider},
Delimiter,
"vertical",
{{magV,1,""},.1,5,.05,VerticalSlider},
Delimiter,
{{n,1000,"number of iterates"},ControlType->None},
{{pts,2000,"number of r values"},ControlType->None},
Button["Reset",a={3.55,0.5};magH=.1;magV=1;n=1000;pts=2000],
Button["More detail",n=2000;pts=4000],
Button["Mode detail 2",n=4000;pts=8000],
ControlPlacement->Left,
TrackedSymbols:>{a,magH,magV,n,pts},
Initialization:>(
logisticMapOrbitCF=Compile[{{r,_Real},{n,_Integer}},{r,#}&/@Take[NestList[r #(1.-#)&,r/4,n],-24]];lyapListCF=Compile[{{r,_Real},{n,_Integer}},
Mean[Log[Abs[r-2 r #]]&/@NestList[r # (1.-#)&,r/4,n]]])]

Based on the code by  Erik Mahieu

Creation of this notebook was supported by IT Academy program of Information Technology Foundation for Education (HITSA).