Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

I am attempting to plot the bifurcation diagram of the tent map $$ f(x):=2\alpha \begin{cases} x, & 0<x<1/2\\ 1-x, &1/2<x<1, \end{cases} $$ i.e., the plot $\alpha$ vs. the limit points of the sequence $x_{n}:=f(x_{n-1})$. I found the following code online to plot the bifurcation diagram of the related logistic map:

ListPlot[ParallelTable[Thread[{r, Nest[r # (1 - #) &, 
Range[0, 1, 0.01], 1000]}], {r, 0, 4, 0.01}], PlotStyle -> PointSize[0]]

So naturally, I figured that I could make a simple change to get the bifurcation diagram of the tent map:

ListPlot[ParallelTable[Thread[{r, Nest[2*r*If[0<#<0.5,#, (1 - #)] &, 
Range[0, 1, 0.01], 1000]}], {r, 0, 1, 0.01}], PlotStyle -> PointSize[0]]

But it doesn't work! Is there a simple change I can make to get this guy to work?

share|improve this question
    
Just in case you need it, I gave a visually better solution. –  Vitaliy Kaurov Oct 27 '12 at 8:35
    
I love it. It is stunning. –  Nick Thompson Oct 27 '12 at 20:31

1 Answer 1

up vote 9 down vote accepted
f[x_] := Piecewise[{{x, x < .5}, {1 - x, x > .5}}]

SetAttributes[f, Listable]

data = ParallelTable[Thread[{r, Nest[r*f[#]&, Range[0, 1, 0.005], 200]}],{r, 0, 2, .005}];

ListPlot[Flatten[data, 1], 
 PlotStyle -> Directive[PointSize[0], Opacity[.2], Black], 
 PlotRange -> {{1, 2}, {0, 1}}, AspectRatio -> 1, Frame -> True]

enter image description here

Below is a bit better method:

k = 1000; r = Range[1., 2., 1/(k - 1)];

f[x_] := Piecewise[{{x, x < .5}, {1 - x, x > .5}}]

SetAttributes[f, Listable]

rhs[x_?VectorQ] := r f[x];

iterates = RecurrenceTable[{x[n + 1] == rhs[x[n]], 
    x[0] == ConstantArray[1./\[Pi], k]}, x, {n, 10^4, 2 10^4}];

data = Transpose[Ceiling[iterates k]];

count[data_, i_] := Module[{c, j}, {j, c} = Transpose[Tally[data]];
   Transpose[{j, ConstantArray[i, Length[j]]}] -> Log[N[c]]];

S = SparseArray[DeleteCases[Table[count[data[[i]], i], {i, k}],{{_ , _}} -> {_}], k];

ArrayPlot[Reverse[S], ColorFunction -> "SunsetColors", Frame -> False]

enter image description here

share|improve this answer
    
Your help is greatly appreciated. Thank you. –  Nick Thompson Oct 27 '12 at 8:07

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.