2
$\begingroup$

I have tried to manage my problem with the rich literature on this site, but I am failing...

I want to roughly reproduce this plot from a paper I am interested in: original image

What I've tried to do is the following:

mB=1000;

p1 = DensityPlot[(8/(3 Pi)*(2*T/mB)^(n/2)*Gamma[3/2 + n/4]*Gamma[5/2 + n/4])^-1, {T, 0.001, 1000}, {n, 0, 4}, 
ScalingFunctions -> {"Log10", Automatic, "Log10"}, PlotLegends -> Automatic, 
PlotRange -> {Automatic, Automatic, Automatic}, 
Ticks -> {ScientificForm[#], Automatic, ScientificForm[#]}, 
AxesLabel -> {T, n}, PlotPoints -> 100, ColorFunction -> "Rainbow",
MaxRecursion -> 1, AspectRatio -> 1/1.4, PlotRangePadding -> None,
FrameLabel -> {Style["\!\(\*SubscriptBox[\(T\), \(r\)]\) [GeV]", Black, 14], Style["n", Black, 14]}, 
FrameTicksStyle -> Directive[Black, 14], FrameStyle -> Black]

p2 = ContourPlot[1/(8/(3 Pi)*(2*T/mB)^(n/2)*Gamma[3/2 + n/4]*Gamma[5/2 + n/4]), {T,  0.001, 1000}, {n, 0, 4}, 
ScalingFunctions -> {"Log10", Automatic, "Log10"}, 
PlotLegends -> Automatic, PlotRange -> {Automatic, Automatic, Automatic},
Ticks -> {ScientificForm[#], Automatic, ScientificForm[#]}, 
AxesLabel -> {T, n}, PlotPoints -> 100, ContourShading -> None, 
Contours -> 11, ContourLabels -> (Text[Framed[#3], {#1, #2}, 
Background -> White] &), MaxRecursion -> 1, AspectRatio -> 1/1.4, PlotRangePadding -> None, 
FrameLabel -> {Style["\!\(\*SubscriptBox[\(T\), \(r\)]\) [GeV]", Black, 14], Style["n", Black, 14]}, 
FrameTicksStyle -> Directive[Black, 14], FrameStyle -> Black]

pBBN = RegionPlot[10^T < (15.4)^(1/n) 0.001, {T, -3, 3}, {n, 0, 4}, AxesLabel -> {T, n}, 
FrameTicks -> {Automatic, {Charting`ScaledTicks["Log10"],
Charting`ScaledFrameTicks[{Log10, 10^# &}]}}, PlotRange -> All, 
PlotStyle -> LightGray, BoundaryStyle -> {Thick, Gray}, 
PlotLabels -> Placed[Style["BBN Excluded", 14], {-2, 0.5}], 
AspectRatio -> 1/1.4, PlotRangePadding -> None]

Show[p1, p2, pBBN]

And I obtain this nice plot:

my image

However, there are some details that do not match:

  1. I want ContourLabels to display the numbers in a scientific form (and possibly inside the plot, not hidden...)
  2. I want the legend bar on the right with the nice scientific form displayed in the original picture
  3. Also, the x-axis does not show a scientific notation, even though I have explicitly written it in the options for Ticks.

Thank you for your help!

$\endgroup$
1
$\begingroup$

To get the ball rolling, I'll show you how to produce this plot:

Mathematica graphics

Which is very similar to the one that you are trying replicate:

Graphics to replicate

I've solved the problems in your question, and then some, but I also introduced a few artifacts:

  1. There's a problem with the $10^{10}$ label in bar legend (that I know the cause of, but don't have a solution to at the moment.)
  2. The logarithmic ticks disappeared from the x-axis

Generally, I don't like writing gigantic answers because it's hard to structure them in a readable way. When people come looking for how to plot a special kind of bar plot in the future, they won't find the information they're looking for because it's buried among other stuff. It's better to ask several small questions instead. So the problem with how to create the perfect bar legend can become one question, and the question of how to fix the axes ticks can become another. (But in those questions, a minimal example of the problem should be used. Also, this is my personal feeling, and others may address the issues regardless. I am only giving a recommendation for how to increase your chances of getting help.)

Here we go.

Change the color scaling and the ticks

One thing that I noticed was different between your plot and the other one is that the color scaling is different. I used in p1 this to fix that:

ColorFunction -> ColorData[{"Rainbow", {Log10@1, Log10[10^10]}}],
ColorFunctionScaling -> False,

I also changed the ticks in p1, but as I noted that was not a complete success:

xticks = {{0.001, Superscript[10, -3]}, {0.01, 
    Superscript[10, -2]}, {0.1, Superscript[10, -1]}, {1, 1}, {10, 
    Superscript[10, 2]}, {100, Superscript[10, 2]}, {1000, 
    Superscript[10, 3]}};
yticks = {{0.5, "0.5"}, {1, "1.0"}, {1.5, "1.5"}, {2, "2.0"}, {2.5, 
    "2.5"}, {3, "3.0"}, {3.5, "3.5"}, {4, "4.0"}};
ticks = {{yticks, None}, {xticks, None}};

Add the ticks using:

FrameTicks -> ticks,

Contour labels positioned in the middle of the curve

One problem in your original plot is that the contour labels are at the border of the plot and hardly visible. The built-in algorithm for determining the placement of the contour labels is a hit-or-miss kind of algorithm, there is no way to fix the placement by providing parameters to guide it. So we will implement the following heuristics ourselves: take the length of the contours, and place the labels in the middle.

We start by modifying p2 like this:

Contours -> {Log10 /@ {10^9, 10^8, 10^7, 10^6, 10^5, 10^4, 10^3, 10^2, 10^2, 10, 2},
(*ContourLabels\[Rule](Text[Framed[#3],{#1,#2},Background\[Rule]White]\
&),*)
RegionFunction -> (# > (15.4)^(1/(#2 + 0.01)) 0.001 &),

In words, specify contours manually so that they match the figure you're trying to replicate exactly, remove the ContourLabels option since we will not use it, and use RegionFunction to only draw the contours in the region corresponding to the non-grayed-out area.

The plot p2 should now look like this:

Mathematica graphics

In order to find the placements, we shall be looking into the Graphics expression generated by ContourPlot. In case you didn't know this is possible, try evaluating FullForm[p2] to see how the graphics in a notebook is actually nothing other than Wolfram Language code.

Now run this:

midPoint[l : Line[coords_]] := Part[
  coords,
  LengthWhile[
   Accumulate[Norm /@ Differences[coords]], # < ArcLength[l]/2 &]
  ]

lines = Cases[Normal[p2], _Line, Infinity];
midPoints = midPoint /@ lines;

label[T_, n_] := Module[{v, l},
  v = 1/(8/(3 Pi)*(2*10^T/mB)^(n/2)*Gamma[3/2 + n/4]*Gamma[5/2 + n/4]);
  l = If[v >= 10, Superscript[10, Round@Log10[N@v]], Round@v];
  Framed[l, Background -> White]
  ]

labels = Inset[label[#1, #2], {#1, #2}] & @@@ midPoints;
p3 = Show[
  p2,
  Graphics[labels]
  ]

Mathematica graphics

Note that instead of setting Background -> White in Inset (which serves the same purpose as Text in your code), I set it in Framed instead. This solves the issue that you have in your plot, where the white extends beyond the frame.

Fixing the bar legend

As I noted, this bar legend is not perfect, but I solved several issues so we can still learn from this.

I find it easier to build the legend separately and then put it together with the plot later, using Legended, so I will just focus on the BarLegend object for now.

This is what I came up with:

ticks = Join[{{1, 1}, {10, 10}}, {#, Superscript[10, #]} & /@ Range[2, 10]];
barLegend = BarLegend[{"Rainbow",{1, 10}},
   LegendMarkerSize -> 300,
   LegendMargins -> {{0, 0}, {20, 0}},
   Ticks -> ticks
   ];

Mathematica graphics

I placed it in the final figure using Legended like this:

Show[
 Legended[
  p1,
  Placed[barLegend, Right]
  ],
 p3,
 pBBN,
 ImageSize -> 600
 ]

where p3 is the plot created from p2 in the previous section.

All the code together

mB = 1000;

xticks = {{0.001, Superscript[10, -3]}, {0.01, 
    Superscript[10, -2]}, {0.1, Superscript[10, -1]}, {1, 1}, {10, 
    Superscript[10, 2]}, {100, Superscript[10, 2]}, {1000, 
    Superscript[10, 3]}};
yticks = {{0.5, "0.5"}, {1, "1.0"}, {1.5, "1.5"}, {2, "2.0"}, {2.5, 
    "2.5"}, {3, "3.0"}, {3.5, "3.5"}, {4, "4.0"}};
ticks = {{yticks, None}, {xticks, None}};

p1 = DensityPlot[
   (8/(3 Pi)*(2*T/mB)^(n/2)*Gamma[3/2 + n/4]*Gamma[5/2 + n/4])^-1,
   {T, 0.001, 1000},
   {n, 0, 4},
   ScalingFunctions -> {"Log10", Automatic, "Log10"},
   PlotRange -> {Automatic, Automatic, Automatic},
   FrameTicks -> ticks,
   AxesLabel -> {T, n},
   PlotPoints -> 100,
   ColorFunction -> ColorData[{"Rainbow", {Log10@1, Log10[10^10]}}],
   ColorFunctionScaling -> False,
   MaxRecursion -> 1,
   AspectRatio -> 1/1.4,
   PlotRangePadding -> None,
   FrameLabel -> {
     Style["\!\(\*SubscriptBox[\(T\), \(r\)]\) [GeV]", Black, 14],
     Style["n", Black, 14]
     },
   FrameTicksStyle -> Directive[Black, 14],
   FrameStyle -> Black
   ];

p2 = ContourPlot[
   1/(8/(3 Pi)*(2*T/mB)^(n/2)*Gamma[3/2 + n/4]*Gamma[5/2 + n/4]),
   {T, 0.001, 1000},
   {n, 0, 4},
   ScalingFunctions -> {"Log10", Automatic, "Log10"},
   PlotLegends -> Automatic,
   PlotRange -> {Automatic, Automatic, Automatic},
   AxesLabel -> {T, n},
   PlotPoints -> 100,
   ContourShading -> None,
   Contours -> 
    Log10 /@ {10^9, 10^8, 10^7, 10^6, 10^5, 10^4, 10^3, 10^2, 10^2, 
      10, 2},
   RegionFunction -> (# > (15.4)^(1/(#2 + 0.01)) 0.001 &),
   MaxRecursion -> 1,
   AspectRatio -> 1/1.4,
   PlotRangePadding -> None,
   FrameLabel -> {
     Style["\!\(\*SubscriptBox[\(T\), \(r\)]\) [GeV]", Black, 14],
     Style["n", Black, 14]
     },
   FrameTicksStyle -> Directive[Black, 14],
   FrameStyle -> Black,
   ImageSize -> 500
   ];

midPoint[l : Line[coords_]] := Part[
  coords,
  LengthWhile[
   Accumulate[Norm /@ Differences[coords]], # < ArcLength[l]/2 &]
  ]

lines = Cases[Normal[p2], _Line, Infinity];
midPoints = midPoint /@ lines;

label[T_, n_] := Module[{v, l},
  v = 1/(8/(3 Pi)*(2*10^T/mB)^(n/2)*Gamma[3/2 + n/4]*Gamma[5/2 + n/4]);
  l = If[v >= 10, Superscript[10, Round@Log10[N@v]], Round@v];
  Framed[l, Background -> White]
  ]

labels = Inset[label[#1, #2], {#1, #2}] & @@@ midPoints;
p3 = Show[p2, Graphics[labels]]

pBBN = RegionPlot[
  10^T < (15.4)^(1/n) 0.001,
  {T, -3, 3},
  {n, 0, 4},
  AxesLabel -> {T, n},
  FrameTicks -> {Automatic, {Charting`ScaledTicks["Log10"], 
     Charting`ScaledFrameTicks[{Log10, 10^# &}]}},
  PlotRange -> All,
  PlotStyle -> LightGray,
  BoundaryStyle -> {Thick, Gray},
  PlotLabels -> Placed[Style["BBN Excluded", 14], {-2, 0.5}],
  AspectRatio -> 1/1.4,
  PlotRangePadding -> None
  ]

ticks = Join[{{1, 1}, {10, 10}}, {#, Superscript[10, #]} & /@ 
    Range[2, 10]];
barLegend = BarLegend[{
    "Rainbow",
    {1, 10}},
   LegendMarkerSize -> 300,
   LegendMargins -> {{0, 0}, {20, 0}},
   Ticks -> ticks
   ];

Show[
 Legended[
  p1,
  Placed[barLegend, Right]
  ],
 p3,
 pBBN,
 ImageSize -> 600
 ]

Mathematica graphics

|improve this answer|||||
$\endgroup$
  • $\begingroup$ A-w-e-s-o-m-e answer! Thank you very much for your time and effort! I have tried to understand the issue for the legend and I have found that setting 0 instead of the first 10 in the second curly bracket of ticks = Join[{{1, 1}, {0, 10}}, {#, Superscript[10, #]} & /@Range[2, 10]]; solves the problem! I am trying to figuring out the minor logarithmic ticks... Thank you also for your comments and your suggestions! $\endgroup$ – Lele Nov 2 '19 at 15:45
  • $\begingroup$ @Lele ok, I'm glad it helped. $\endgroup$ – C. E. Nov 2 '19 at 21:19
  • $\begingroup$ Only a question. What should I do if I want to plot the Legend ticks every two powers of ten (e.g. 1, 10^3, 10^5, 10^7, 10^9,...)? $\endgroup$ – Lele Nov 4 '19 at 16:56
  • 1
    $\begingroup$ @Lele If I understand the question correctly, you only need to change to Range[3, 10, 2] in the definition of ticks in the bar legend code. $\endgroup$ – C. E. Nov 4 '19 at 17:35

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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