Re: Problem in plotting Bifurcation Diagram (ListPlot with
- To: mathgroup at smc.vnet.net
- Subject: [mg102203] Re: Problem in plotting Bifurcation Diagram (ListPlot with
- From: juan flores <juanfie at gmail.com>
- Date: Sat, 1 Aug 2009 04:00:10 -0400 (EDT)
- References: <200907290910.FAA19700@smc.vnet.net> <h4rpgo$lbf$1@smc.vnet.net>
On Jul 31, 4:52 am, AH <creativesolution... at gmail.com> wrote:
> On Jul 30, 6:35 pm, DrMajorBob <btre... at austin.rr.com> wrote:
>
>
>
> > MakeMapFunction is undefined, so of course the code doesn't work...
> > although I get a different error.
>
> > Also note, your semicolon after ListPlot will prevent display of the plot=
> .
>
> > Bobby
>
> > On Wed, 29 Jul 2009 04:10:48 -0500, AH <creativesolution... at gmail.com> =
> > wrote:
>
> > > Hi
> > > I have following piece of code:
> > > -----------------------------------------------------------------------=
>
> ---------------------------------
>
>
>
> > > In[1]:=BifurcationDiagram[f_, {r_, rmin_, rmax_, rstep_}, {x_, x0_},
> > > start_,
> > > combine_] :=
> > > Module[{R, temp, MapFunction},
> > > R = Table[r, {r, rmin, rmax, rstep}]; (* The r=
> ange
> > > of values of the parameter *)
> > > MapFunction = MakeMapFunction[{r, x}, f];(*
> > > Construct the iterating function *)
> > > temp = Nest[MapFunction[R, #] &, x0 + 0.R, sta=
> rt + 1];(* Starting
> > > iterates \
> > > *)
> > > temp = NestList[MapFunction[R, #] &, temp, com=
> bine - 1];(*
> > > Subsequent \
> > > iterates *)
> > > temp = Map[ Union, Transpose[
> > > temp] ]; (* Remove duplicate values from cycles *)
> > > Flatten[ MapThread[Thread[{#1, #2}] &, {R, temp}=
> ], 1]
> > > ];
>
> > > In[2]:=ListPlot[BifurcationDiagram[(1 - r) x + (r(2858.16)/(x - 500)
> > > ^0.82) - 30000r, \
> > > {r, 0.1, .2, .0001}, {x, 600}, 10000, 100], PlotStyle ->
> > > AbsolutePointSize[0.0001]];
> > > ------------------------------------------------------
> > > The following errors are produced:
> > > Graphics:: gptn : Coordiantes -30000.5+0.0169522 i {0.1,
> > > -30000.5+0.0169522 i }....is not a floating pont. Is there any
> > > possible solution to this problem ?
> > > Best regards.
> > > --------------------------------------------------------
>
> > --
> > DrMajor... at bigfoot.com
>
> You can ignore MakeMapFunction.
> In my case the only error is what that has been reported.
> May be you can list the errors that you have got.
>
> The main problem is that how to display deal with complex numbers while
> plotting bifurcation diagrams.....Any idea will be very much
> appreciated.
>
> Also, the following link tells that ListPlot cannot be used for
> complex numbers.http://www.stephenwolfram.com/publications/articles/computing/92-desi...
> ---------------------------------------------------------------------------=
> -------------------------------------------------------------
I find this post rather incomplete. Eventhough, I know what you are
talking about.
Complex roots of your ODE(s) correspond to double-period (or higher)
bifurcation points. Read Strogatz. Now, ploting real roots, you get
the usual bifurcation diagrams, just like the ones XppAuto produces.
I recently plotted these bifurcation diagrams for one and two-
parameter systems. You'll find the code at the end of the message
(not showing the results. Evaluted and running in M 7.0.0 for Mac).
I hope it helps.
Cheers,
Juan Flores
-----
one-parameter ODE
-----
f[x_, r_] := r x + x^3 - x^5
Clear[NotComplexQ];
NotComplexQ[c_Complex] := False;
NotComplexQ[c_] := True
CartProd[l_] := Outer[List, l[[1]], l[[2]]]
ArreglaLista[l_] := Select[Map[(x /. #) &, Flatten[l]], NotComplexQ]
Points = Flatten[
Map[CartProd,
Table[{{r}, ArreglaLista[NSolve[f[x, r] == 0, x]]}, {r, -1, 2,
0.05}]], 2]
ListPlot[Points]
-----
two-parameter ODE
Since the bifurcation diagram is not a funciont, ListPlot3D does not
work, so I produce a little sphere for each point, and plot those.
-----
cubic ODE
f[x_, r_, h_] := h + r x - x^3
Clear[NotComplexQ];
NotComplexQ[c_Complex] := False;
NotComplexQ[c_] := True
CartProd[l_] := Outer[List, l[[1]], l[[2]]]
ArreglaLista[l_] := Select[Map[(x /. #) &, Flatten[l]], NotComplexQ]
Arregla2[{l1_, l2_}] := Map[Join[l1, {#}] &, l2]
kk = Flatten[
Map[Arregla2,
Map[{#[[1]], ArreglaLista[Flatten[#[[2]]]]} &,
Flatten[Table[{{r, h}, NSolve[f[x, r, h] == 0, x]}, {r, -3, 3,
0.1}, {h, -3, 3, 0.1}], 1]]], 1]
makeSphere[l_] := Sphere[l, 0.03]
spheres = Map[makeSphere, kk]
Graphics3D[spheres]