0
$\begingroup$

I'm fairly new to Mathematica so I'm not sure how I can achieve this, I've tried a number of ways but nothing has worked so far. I basically want to plot a function r against n for different parameter values of f but with the line segmented into f dependent regions of different colours,

Mp = UnitConvert[Quantity[1, "PlanckMass"], "Gigaelectronvolts/c^2"];
\[HBar] = UnitConvert[Quantity["PlanckConstant"], "SI"];
As = 2.196*10^(-9);
T0 = Quantity[6.626*10^(-13), "GeV/c^2"];
gre = 100;
k0 = UnitConvert[
    UnitConvert[ Quantity[0.05, 1/"Megaparsecs"], "SI"]*\[HBar]*
     UnitConvert[Quantity["SpeedOfLight"], "SI"], 
    "Gigaelectronvolts"]/Quantity["SpeedOfLight"]^2;

Nk[f_, n_] := -(f/
     Mp)^2 Log[(1 + Mp^2/(2 f^2)) (((1 - n) - Mp^2/f^2)/((1 - n) + 
      Mp^2/f^2))]
H[f_, n_] := \[Pi] Mp Sqrt[2 As ((1 - n) - Mp^2/f^2)]
Ve[f_, n_] := 
 3 H[f, n]^2 Mp^2 *((1 + (1 - n) (f/Mp)^2)/(2 + 4 (f/Mp)^2))

Nr[n_, wre_, f_] := 
 4/(1 - 3*wre) (61.6 - Log[Ve[f, n]^(1/4)/H[f, n]] - Nk[f, n]);
Tre[n_, wre_, 
   f_] := ((43/(11*gre))^(1/3)*T0/k0*H[f, n]*
     Exp[-Nk[f, n]]*((3^2*5 Ve[f, n])/(\[Pi]^2*gre))^(-1/(
       3 (1 + wre))))^((3 (1 + wre))/(3 wre - 1));

r[f_,n_]:= 4 ((1 - n) - Mp^2/f^2)


However, I want to colour the regions between these values different colours

nr0[f_] := Re[n /. FindRoot[Nr[n, 0, f] == 70, {n, 0.97}]]
nr1[f_] := Re[n /. FindRoot[Nr[n, 1, f] == 70, {n, 0.97}]]
nr13[f_] := 
 Re[n /. FindRoot[
    Log[Ve[f, n]^(1/4)/H[f, n]] + Nk[f, n] == 61.6 , {n, 0.95}]]

I then made four functions with the ranges given above,

g1[f_] := 
 Plot[r[f, n], {n, 0.93, nr0[f]}, PlotRange -> {{0.93, 1}, {0, 0.25}},
   PlotStyle -> {Orange, Thickness[0.02]}]
g2[f_] := Plot[r[f, n], {n, nr0[f], nr13[f]}, 
  PlotRange -> {{0.93, 1}, {0, 0.25}}, 
  PlotStyle -> {Red, Thickness[0.02]}]
g3[f_] := Plot[r[f, n], {n, nr13[f], nr1[f]}, 
  PlotRange -> {{0.93, 1}, {0, 0.25}}, 
  PlotStyle -> {Yellow, Thickness[0.02]}]
g4[f_] := Plot[r[f, n], {n, nr1[f], 1}, 
  PlotRange -> {{0.93, 1}, {0, 0.25}}, 
  PlotStyle -> {Green, Thickness[0.02]}]

For a fixed value of f I used the Show function to give:

Mp = UnitConvert[Quantity[1, "PlanckMass"], "Gigaelectronvolts/c^2"];

Show[g1[100 Mp], g2[100 Mp], g3[100 Mp], g4[100 Mp]]

enter image description here

However, I want to be able to plot this for different values of f where the colour range depends on the value of f. In particular I want to plot a range of f from say 10 Mp to 100 Mp. Any help would be greatly appreciated

$\endgroup$
4
  • 1
    $\begingroup$ Edit your question to include the definitions for your functions (e.g., Nr, Ve, H, Nk). Always include all code and data for a minimal working example so that we can reproduce the problem. $\endgroup$
    – Bob Hanlon
    May 9, 2022 at 17:24
  • $\begingroup$ @BobHanlon Thanks, just edited in the missing code $\endgroup$
    – Sputnik
    May 9, 2022 at 18:45
  • $\begingroup$ The function Nr is still undefined. $\endgroup$
    – Bob Hanlon
    May 9, 2022 at 19:35
  • $\begingroup$ @BobHanlon Ah yes sorry about that. It's all complete now $\endgroup$
    – Sputnik
    May 9, 2022 at 19:41

1 Answer 1

0
$\begingroup$
fValues = {"100Mp", "30Mp", "20Mp", "15Mp", "12Mp", "10Mp"};

Plot[Evaluate@
  Table[r[f, n], {f, ToExpression@fValues}],
 {n, 0.93, 1},
 PlotRange -> {{0.93, 1}, {0, 0.25}},
 Frame -> True,
 FrameLabel -> (Style[#, 14] & /@ {n, HoldForm@r[f, n]}),
 GridLines -> Automatic,
 AspectRatio -> 1,
 PlotLegends -> Placed[
   LineLegend[fValues,
    LegendLabel -> Style[f, 14],
    LegendFunction ->
     (Framed[#, RoundingRadius -> 4,
        FrameStyle -> Gray,
        Background -> White] &)], 
   {.847, .659}],
 ImageSize -> Medium]

enter image description here

EDIT: For segmented lines

funcs =
  Flatten[
   Table[
    With[{fv = ToExpression[f]},
     Tooltip[ConditionalExpression[r[fv, n], #], f] & /@
      {0.93 < n < 
        nr0[fv],
       nr0[fv] < n < nr13[fv],
       nr13[fv] < n < nr1[fv],
       nr1[fv] < n < 1}],
    {f, fValues}],
   1];

Plot[Evaluate@funcs, {n, 0.93, 1},
 PlotStyle -> {Orange, Red, Yellow, Green},
 PlotRange -> {{0.93, 1}, {0, 0.25}},
 Frame -> True,
 FrameLabel -> (Style[#, 14] & /@ {n, HoldForm@r[f, n]}),
 ImageSize -> 400,
 Epilog -> {Arrow[{{.99, .1}, {.99, .13}}],
   Text["increasing f", {.99, .09}]}]

enter image description here

$\endgroup$
1
  • $\begingroup$ Thanks for the help. Now I want to be able to plot that but have each line segmented into Orange, Red, Yellow and Green by the values nr0[f], nr13[f], nr1[f]. $\endgroup$
    – Sputnik
    May 10, 2022 at 8:39

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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