# Colouring Bifurcation Diagram

I need to plot the bifurcation diagram for the function given below.

g[x_, r_] := 6 x^2 + r x^4 + x^6

Plot[g[x, -4.9], {x, -2, 2}]


## Bifurcation

Code for bifurcation is burrowed from Coloring Bifurcation Diagram question:

CClear[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[g2[x, r] == 0, x]]}, {r, -20, 10,
0.01}]], 2];
ListPlot[Points]


## Colouring

I've also borrowed the code from the answer by @Kuba to the above-mentioned question, however, it does not work for my problem. How to modify it to get the desired result?

unstable = Select[Points, First@# >= 0 && Last@# == 0 &];
stable =
SortBy[#,
First] & /@ (Append[#, {0, 0}] & /@ (GatherBy[
Complement[Points, unstable], Sign@Last@# &]));

ListPlot[stable~Join~{unstable},
PlotStyle -> {Directive[Red, Dashing[0.01]],
Directive[ Blue, Dashing[0.01]],
Directive[ Red, Dashing[0.008]],
Directive[ Blue, Dashing[0.1]]}]


I want the stable line for r>0 to be solid blue, the stable lines for r<0 to be in dashed blue line and the unstable lines to be red dashed.

Is there any general method to do it?

You can use ContourPlot to make such 1D bifurcation diagrams easily as in this answer, using ConditionalExpression to handle the stability analysis. I assume g[x, r] is some kind of potential, not x'[t], so that an equilibrium is where D[g[x, r], x]==0 and is stable if D[g[x, r], {x, 2}]>0.

g[x_, r_] = 6  x^2 + r  x^4 + x^6;
dg[x_, r_] = D[g[x, r], x];
dg2[x_, r_] = D[g[x, r], {x, 2}];

ContourPlot[{
ConditionalExpression[dg[x, r], dg2[x, r] > 0 && r > 0] == 0,
ConditionalExpression[dg[x, r], dg2[x, r] > 0 && r < 0] == 0,
ConditionalExpression[dg[x, r], dg2[x, r] < 0] == 0
}, {r, -20, 10}, {x, -5, 5},
ContourStyle -> {{Blue}, {Blue, Dashed}, {Red, Dashed}}, MaxRecursion -> 3, FrameLabel -> {"r", "x"}]


This matches your description but I suspect it isn't what you want. Maybe this is more like it?

ContourPlot[{
ConditionalExpression[dg[x, r], dg2[x, r] > 0 && Abs[x] < 0.1] == 0,
ConditionalExpression[dg[x, r], dg2[x, r] > 0 && Abs[x] > 0.1] == 0,
ConditionalExpression[dg[x, r], dg2[x, r] < 0] == 0
}, {r, -20, 10}, {x, -5, 5},
ContourStyle -> {{Blue}, {Blue, Dashed}, {Red, Dashed}}, MaxRecursion -> 3, FrameLabel -> {"r", "x"}]


• Thank you @ChrisK Commented Feb 20 at 3:35
• Just one question, Why do you have taken && Abs[x] < 0.1] and && Abs[x] >0.1]?? Why 0.1 and how is it different from $r>0$ and $r<0$???? Commented Feb 20 at 3:49
• @user444 I was just guessing that you wanted a graph like the second one, not the first - if that's not correct I can remove the second Commented Feb 20 at 4:09
• It's alright. I was just curious to know how is different is it from what I asked. Commented Feb 20 at 4:46
• The middle line can be defined by Abs[x] < 0.1 whereas r > 0 makes the left half of the middle line dashed and the right half solid. Commented Feb 20 at 4:48