1
$\begingroup$

I have these contour plots:

ContourPlot[
 TC, {y, 0.02, 5}, {\[ScriptCapitalA], 0, 0.3},
  PlotRange -> All, 
 FrameLabel -> {Style[y, FontSize -> 14, Blue], 
   Style[\[ScriptCapitalA], FontSize -> 14, Blue]}, 
 ContourStyle -> {Dashed}, BaseStyle -> {FontSize -> 9}, 
 ContourShading -> {White, Lighter[Blue, 0.9], Lighter[Blue, 0.7], 
   Lighter[Blue, 0.5], Lighter[Blue, 0.3], Lighter[Blue, 0.1], 
   Darker[Blue, 0.2], Darker[Blue, 0.4], Black}, 
 ContourLabels -> (Text[Framed[#3], {#1, #2}, Background -> White] &)]

and

ContourPlot[
TC, {y, 0.02, 5}, {\[ScriptCapitalA], -0.3, 
  0}, PlotRange -> All, 
 FrameLabel -> {Style[y, FontSize -> 14, Blue], 
   Style[\[ScriptCapitalA], FontSize -> 14, Blue]}, 
 ContourStyle -> {Dashed}, BaseStyle -> {FontSize -> 9}, 
 ContourShading -> {White, Lighter[Blue, 0.9], Lighter[Blue, 0.7], 
   Lighter[Blue, 0.5], Lighter[Blue, 0.3], Lighter[Blue, 0.1], 
   Darker[Blue, 0.2], Darker[Blue, 0.4], Black}, 
 ContourLabels -> (Text[Framed[#3], {#1, #2}, Background -> White] &)]

where

TC=-1 + 0.18240901220588282*E^y*
   Sqrt[(-0.042 + 0.028*y)/(E^(2*y)*y) + 
     1.742955604211617*(2*BesselI[0, y] + y*BesselI[1, y])*
      BesselK[0, y] - 1.742955604211617*(y*BesselI[0, y] + 
       BesselI[1, y])*BesselK[1, y]] - 
  (0.05450511749722444*(0.042 - 0.028*y + (3 - 2*y)*\[ScriptCapitalA] + 
     ((-0.168 + 0.112*y)*\[ScriptCapitalA])/E^(2*y) - 1.834690109696439*
      E^(2*y)*y*BesselI[1, y]*(y*BesselK[0, y] - 
       1.*BesselK[1, y]) + 7.338760438785756*y*\[ScriptCapitalA]*
      BesselI[1, y]*(y*BesselK[0, y] - 1.*BesselK[1, y]) + 
     1.834690109696439*E^(2*y)*y*BesselI[0, y]*
      (-2.*BesselK[0, y] + y*BesselK[1, y]) - 
     7.338760438785756*y*\[ScriptCapitalA]*BesselI[0, y]*
      (-2.*BesselK[0, y] + y*BesselK[1, y]) - 
     7.338760438785756*E^(2*y)*y*\[ScriptCapitalA]*
      (2*(BesselI[0, 2*y] + y*BesselI[1, 2*y])*
        BesselK[0, 2*y] - (2*y*BesselI[0, 2*y] + 
         BesselI[1, 2*y])*BesselK[1, 2*y])))/y + 
  (6.514607578781529*E^(3*y)*\[ScriptCapitalA]*
    ((2*(0.042 - 0.028*y + E^(2*y)*y*BesselI[1, y]*
         (-1.834690109696439*y*BesselK[0, y] + 
          1.834690109696439*BesselK[1, y]) + 
        E^(2*y)*y*BesselI[0, y]*(-3.669380219392878*
           BesselK[0, y] + 1.834690109696439*y*
           BesselK[1, y]))*(0.0023520000000000004 - 
        0.042*E^(2*y) - 0.0015680000000000002*y + 
        0.028*E^(2*y)*y + 0.9173450548482195*E^(2*y)*
         (-0.112 + E^(2*y))*y*BesselI[1, y]*
         (y*BesselK[0, y] - 1.*BesselK[1, y]) - 
        0.9173450548482195*E^(2*y)*(-0.112 + E^(2*y))*y*
         BesselI[0, y]*(-2.*BesselK[0, y] + 
          y*BesselK[1, y]) + 0.051371323071500295*E^(4*y)*y*
         BesselI[1, 2*y]*(2*y*BesselK[0, 2*y] - 
          BesselK[1, 2*y]) - 0.10274264614300059*E^(4*y)*y*
         BesselI[0, 2*y]*(-1.*BesselK[0, 2*y] + 
          y*BesselK[1, 2*y])))/E^(8*y) + 
     (0.09173450548482195*y*
       (-((BesselI[1, y]*(y*BesselK[0, y] - BesselK[1, y]) + 
           BesselI[0, y]*(2*BesselK[0, y] - 
             y*BesselK[1, y]))*(0.0023520000000000004 - 
           0.042*E^(2*y) - 0.0015680000000000002*y + 
           0.028*E^(2*y)*y + 0.9173450548482195*E^(2*y)*
            (-0.112 + E^(2*y))*y*BesselI[1, y]*
            (y*BesselK[0, y] - 1.*BesselK[1, y]) - 
           0.9173450548482195*E^(2*y)*(-0.112 + E^(2*y))*y*
            BesselI[0, y]*(-2.*BesselK[0, y] + 
             y*BesselK[1, y]) + 0.051371323071500295*E^(4*y)*
            y*BesselI[1, 2*y]*(2*y*BesselK[0, 2*y] - 
             BesselK[1, 2*y]) - 0.10274264614300059*E^(4*y)*
            y*BesselI[0, 2*y]*(-1.*BesselK[0, 2*y] + 
             y*BesselK[1, 2*y]))) + 
        (0.042 - 0.028*y + E^(2*y)*y*BesselI[1, y]*
           (-1.834690109696439*y*BesselK[0, y] + 
            1.834690109696439*BesselK[1, y]) + 
          E^(2*y)*y*BesselI[0, y]*(-3.669380219392878*
             BesselK[0, y] + 1.834690109696439*y*
             BesselK[1, y]))*(-1.*(-0.112 + E^(2*y))*
           BesselI[1, y]*(y*BesselK[0, y] - 
            1.*BesselK[1, y]) - (-0.112 + E^(2*y))*
           BesselI[0, y]*(2*BesselK[0, y] - 
            y*BesselK[1, y]) - 0.112*E^(2*y)*
           (BesselI[1, 2*y]*(2*y*BesselK[0, 2*y] - 
              BesselK[1, 2*y]) + 2*BesselI[0, 2*y]*
             (BesselK[0, 2*y] - y*BesselK[1, 2*y])))))/
      E^(6*y)))/(y*Sqrt[(-0.042 + 0.028*y)/(E^(2*y)*y) + 
      BesselI[1, y]*(1.834690109696439*y*BesselK[0, y] - 
        1.834690109696439*BesselK[1, y]) + 
      BesselI[0, y]*(3.669380219392878*BesselK[0, y] - 
        1.834690109696439*y*BesselK[1, y])]*
    ((0.042 - 0.028*y)/E^(2*y) - 1.834690109696439*y*
      BesselI[1, y]*(y*BesselK[0, y] - 1.*BesselK[1, y]) + 
     1.834690109696439*y*BesselI[0, y]*(-2.*BesselK[0, y] + 
       y*BesselK[1, y])))

Now, the question is, how can I merge the $y$-axis? Moreover, is it possible to add a bar-legend including the same colors as above plots?

Note that, this question is edited after adding a comment and an answer. In fact, here I have brought the original form of the function which should be plotted (i.e. $TC$). Sorry for these complicated inputs.

Improve this question
$\endgroup$
1
  • 1
    $\begingroup$ Why not use a single ContourPlot call? Just set ContourStyle appropriately, and use Contours to set the correct amount of contours $\endgroup$
    – Lukas Lang
    Aug 12, 2019 at 8:03

2 Answers 2

Reset to default
2
$\begingroup$

Here is one way the two contour plots can be combined and given a bar legend.

With[{n = 15},
  Module[{colors},
    colors = 
      Join[{White}, (Lighter[Blue, #] & /@ Subdivide[1, 0, n])[[3 ;; -3]], {Black}];
    ContourPlot[1 + \[ScriptCapitalA] (η y + μ η y^2 + 1) /. {η -> 0.01, μ -> 0.014},
      {y, 0.02, 5}, {\[ScriptCapitalA], -.3, .3},
      AspectRatio -> 1.5,
      BaseStyle -> {FontSize -> 9},
      FrameLabel -> 
         {Style[y, FontSize -> 14, Blue], Style[\[ScriptCapitalA], 
          FontSize -> 14, Blue]},
      Contours -> 
        Function[{min, max}, Range[Floor[min, .05], Ceiling[max, .05], .05]],
      ContourStyle -> {Dashed},
      ContourShading -> colors, 
      ContourLabels -> 
        (Text[Framed[Round[#3, .01]], {#1, #2}, Background -> White]&),
      PlotLegends -> Automatic,
      ImageSize -> {Automatic, 600}]]]

plot

Update

Decorating plots is more an art than a science. When you change the content of a plot you should always expect to tweak the decorations.

For your expression, TC, you need to adjust the parameters controlling the plotting of the contours. Here is how I did it. Basically all I did was increase the size of interval between contours to something reasonable for TC.

With[{n = 18}, 
  Module[{colors}, 
    colors =
      Join[{White}, (Lighter[Blue, #] & /@ Subdivide[1, 0, n])[[3 ;; -3]], {Black}];
    ContourPlot[TC, {y, 0.02, 5}, {\[ScriptCapitalA], -.3, .3},
      AspectRatio -> 1.5,
      BaseStyle -> {FontSize -> 9}, 
      FrameLabel -> 
        {Style[y, FontSize -> 14, Blue], Style[\[ScriptCapitalA], 
         FontSize -> 14, Blue]}, 
      Contours -> 
       Function[{min, max}, Range[Floor[min, 1.5], Ceiling[max, 1.5], 1.5]], 
      ContourStyle -> {Dashed},
      ContourShading -> colors,
      PlotLegends -> Automatic,
      ImageSize -> {Automatic, 600}]]]

plot

Notes

  1. It may look as if full range of colors does not appear, but it does. Look very carefully at the upper-right corner to see the bit of black that appears there.

  2. I have removed the contour labeling because Mathematica's automatic positioning of such labels is very ugly on this plot. Even manual positioning of the labels would be difficult for these contours because of the way the they bunch up at the upper-right and lower-right corners. The default tooltip labeling takes over, but of course won't work if the plot is posted or printed. You might choose install custom labels at only those contours that have plenty of room for them, but don't ask me to write the code for that.

  3. As for "more distinguishable colors", that is an aesthetic or psychological question, not a Mathematica question. I will point out, however, that the variable colors can be any list of colors, so experimenting with alternative colors is not difficult.

Improve this answer
$\endgroup$
4
  • $\begingroup$ Dear m, sorry, this solution didn't work out for the original form of the function. Would you please kindly recheck for $TC$? Thanks. Moreover, I need more distinguishable colors :( $\endgroup$
    – Perfect Fluid
    Aug 12, 2019 at 20:17
  • $\begingroup$ @PerfectFluid. I have made an update that shows adjustments that accommodate TC. $\endgroup$
    – m_goldberg
    Aug 13, 2019 at 0:17
  • $\begingroup$ Thank you. Why "psychological" :)) The point is, I want the colors to be more different in each contour in order to be more distinguishable in a black and white print. I think it is a technical task and may be possible. By the way, thanks for the answer. $\endgroup$
    – Perfect Fluid
    Aug 13, 2019 at 5:28
  • $\begingroup$ @PerfectFluid. I meant that different people see colors differently. Maybe "psychological" was the wrong word, perhaps "physiological" would be better. If your final reproduction is to be in B&W, I suggest experimenting with GrayLevel for the contour shading. $\endgroup$
    – m_goldberg
    Aug 13, 2019 at 22:40
0
$\begingroup$

To have more distinguishable colors, the updated version of m_goldberg's answer maybe

With[{n = 18}, 
 Module[{colors}, 
  colors = Join[{White}, (Lighter[Blue, #] & /@ 
       Subdivide[1, 0, n])[[3 ;; -3]], {Black}];
  ContourPlot[TC, {y, 0.02, 5}, {\[ScriptCapitalA], -.3, .3}, 
   AspectRatio -> 1.5, BaseStyle -> {FontSize -> 9}, 
   FrameLabel -> {Style[y, FontSize -> 14, Blue], 
     Style[\[ScriptCapitalA], FontSize -> 14, Blue]}, 
   Contours -> 
    Function[{min, max}, 
     Range[Floor[min, 1.5], Ceiling[max, 1.5], 1.5]], 
   ContourStyle -> {Dashed}, 
   ContourShading -> {Black, Darker[Red, 0.6], Darker[Red, 0.4], 
     Darker[Red, 0.2], Lighter[Red, 0.4], Lighter[Red, 0.75], 
     Lighter[Red, 0.9], Lighter[Blue, 0.9], Lighter[Blue, 0.75], 
     Lighter[Blue, 0.6], Lighter[Blue, 0.4], Lighter[Blue, 0.2], Blue,
      Darker[Blue, 0.2], Darker[Blue, 0.4], Darker[Blue, 0.6], 
     Darker[Blue, 0.8]}, PlotLegends -> Automatic, 
   ImageSize -> {Automatic, 600}]]]

The output is like that.

Improve this answer
$\endgroup$

Your Answer

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

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