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}]

enter image description here

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}]]

enter image description here


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]

Mathematica graphics

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
  ]

enter image description here