Using lists for creating a bifurcation diagram of an iterative map
Is this what you want?
ClearAll[list]
list[r_?NumericQ] :=
DeleteDuplicates[
RecurrenceTable[
{x[n] == r (x[n - 1] - x[n - 1]^3), x[1] == 0.5},
x, {n, 1, 200}
][[101 ;; 200]]
]
Manipulate[ListPlot[list[r]], {r, 0.01, 5}]
Note that for $r\ge3$, the computation overflows. You may want to decrease the number of iterations or increase the working precision.
If you want to plot all points together, as a function of r
(as in Chris K's answer), you can also use
ListPlot[Table[Sequence @@ Transpose[{r + 0 #, #} &@list[r]], {r, 0.1, 3, .01}]]
Here's one way, using Replace
to wrap your points x
with {r,x}
and Table
to iterate over r
.
res = Flatten[Table[
list = RecurrenceTable[{x[n] == r (x[n - 1] - x[n - 1]^3), x[1] == 0.5}, x, {n, 1, 200}];
Replace[DeleteDuplicates[Take[list, -100]], x_ -> {r, x}, 1]
, {r, 1.0, 3.0, 0.01}], 1]
ListPlot[res]
Note that r>3.0
doesn't seem to converge, so I stopped there.
Your approach has a drawback: it displays the points even if the recurrence relation does not converge to a cycle. The following approach is based on FindTransientRepeat
(from this answer) to detect cycles up to a precision controlled below with epsi
. You also control the max steps with nMax
. Another advantage is that it does not compute superfluous points: for instance, with r = 1.5
, it stops after 4 or 5 iterations instead of 200. Of course, the resulting diagram is not as nice, but the points that are displayed have a meaning (limit cycles).
epsi = 10^-3;
nMax = 1000;
searchPeriodicity[r_] := Block[{x = ConstantArray[0, nMax], n},
x[[1]] = 0.5;
x[[2]] = r (x[[1]] - x[[1]]^3);
n = 2;
While[n < nMax && Last@FindTransientRepeat[x[[;; n]], 2,
SameTest -> (Abs[#1 - #2] < epsi &)] == {},
n++; x[[n]] = r (x[[n - 1]] - x[[n - 1]]^3)];
rep = Last@FindTransientRepeat[x[[;; n]], 2,
SameTest -> (Abs[#1 - #2] < epsi &)];
{r, #} & /@ rep
]