Skip to main content

plotting - Scale coloring of ContourPlot


The answer given here solved how to use the same color scale across multiple plots within the function ListContourPlot. I can't for the life of me map this solution onto the function ContourPlot that I am using.


Say for example I have the code


r = Norm[{x, y}];
plot1 = Plot3D[{r^2, -r^2}, {x, -Pi, Pi}, {y, -Pi, Pi}, 
   ColorFunction -> "ThermometerColors", BoxRatios -> {2, 2, 3}];
plot2 = ContourPlot[r^2, {x, -Pi, Pi}, {y, -Pi, Pi}, 
   ColorFunction -> "ThermometerColors"];
GraphicsRow[{plot1, plot2}]


which gives me the plots. If you look at the code you will see that in the contour plot I am only plotting the positive solutions and so for consistency my plot should be contours that are shades of red.


How can I achieve this?



*****EDIT 1*****


kguler submitted an answer that solved this example question, but for a reason I can't understand it doesn't work in the actual system that I'm using. Here is my full code:


    Clear["Global`*"];
DynamicEvaluationTimeout -> Infinity;

(*Nearest neighbour vectors*)
{e1, e2, 

   e3} = # & /@ {{0, -1}, {Sqrt[3]/2, 1/2}, {-Sqrt[3]/2, 1/2}};

(*dispersion*)
w[theta_, phi_] := Module[{c1, c2, c3, fq},
  {c1, c2, c3} = 
   1 - 3 Sin[theta]^2 Cos[phi - 2 Pi (# - 1)/3]^2 & /@ {1, 2, 3};
  fq = Total[#[[1]] Exp[I q.#[[2]]] & /@ {{c1, e1}, {c2, e2}, {c3, 
       e3}}];
  Sqrt[1 + 2 # Omega Norm[fq]] & /@ {1, -1}
  ]




Omega = 0.01; 
q = {qx, qy};



(***Figure3a***)
{theta, phi} = {Pi/2, Pi/2};

dirac3a = {(2/Sqrt[3]) ArcCos[2/5], 4 Pi/3};
zoom = 0.005 Pi;

With[
 {plotopts = {Mesh -> None, PlotStyle -> Opacity[0.7], 
    Ticks -> {{1.33, 1.34, 1.35}, {4.18, 4.19, 4.20}, Automatic}, 
    BoxRatios -> {2, 2, 2}, PlotPoints -> 50, MaxRecursion -> 2, 
    AxesEdge -> {{-1, -1}, {1, -1}, {-1, -1}}, 
    ColorFunction -> "ThermometerColors", LabelStyle -> Large, 
    ClippingStyle -> None, BoxStyle -> Opacity[0.5], 

    ViewPoint -> {1.43, -2.84, 1.13}, ViewVertical -> {0., 0., 1.}}},
 figure3a = Plot3D[w[theta, phi],
   {qx, dirac3a[[1]] - zoom, dirac3a[[1]] + zoom}, {qy, 
    dirac3a[[2]] - zoom, dirac3a[[2]] + zoom}, plotopts]
 ]


(***Figure3b***)
With[{plotopts = {Frame -> True, 
    FrameTicks -> {{{4.18, 4.19, 4.20}, None}, {{1.33, 1.34, 1.35}, 

       None}}, ColorFunction -> "ThermometerColors", 
    LabelStyle -> Large, PlotRangePadding -> None, 
    ColorFunctionScaling -> False, 
    ColorFunction -> ColorData[{"ThermometerColors", {0.9996, 1.0004}}]
    }
  },
 figure3b = ContourPlot[w[theta, phi][[1]],
   {qx, dirac3a[[1]] - zoom, dirac3a[[1]] + zoom}, {qy, 
    dirac3a[[2]] - zoom, dirac3a[[2]] + zoom}, plotopts]
 ]


(***Figure3b legend***)

legend = {0.9996 + 0.0001 #, 0.9996 + 0.0001 #} & /@ {0, 1, 2, 3, 4, 
    5, 6, 7, 8};
figure3bLegend = 
 ArrayPlot[legend, ColorFunction -> "ThermometerColors", 
  DataRange -> {{0, 1}, {0.9996, 1.0004}}, 
  FrameTicks -> {{0.9996, 0.9997, 0.9998, 0.9999, {1.0000, "1.0000"}, 
     1.0001, 1.0002, 1.0003, 1.0004}, None}, AspectRatio -> 7, 

  LabelStyle -> Large]

where I have incorporated the suggestion, but it gives me a plot that is monochrome. The values 0.9996 and 1.0004 correspond to the maxima and minima.



What is going on here?



Answer



plot1 = Plot3D[{r^2, -r^2}, {x, -Pi, Pi}, {y, -Pi, Pi}, 
   ColorFunctionScaling -> False, 
   ColorFunction -> ColorData[{"ThermometerColors", {-20, 20}}], 
   BoxRatios -> {2, 2, 3}];

plot2 = ContourPlot[r^2, {x, -Pi, Pi}, {y, -Pi, Pi}, 
   ColorFunctionScaling -> False, 
   ColorFunction -> ColorData[{"ThermometerColors", {-20, 20}}]];

Legended[GraphicsRow[{plot1, plot2}], BarLegend[{"ThermometerColors", {-20, 20}}, 20]]

enter image description here


Update: For the specific example in OP's updated question, the following changes produce the desired result:


Change plotops appearing in the part generating figure3b to


plotopts = {Frame -> True, 

  FrameTicks -> {{{4.18, 4.19, 4.20}, None}, {{1.33, 1.34, 1.35}, 
     None}}, LabelStyle -> Large, ImageSize -> 400, 
  PlotRangePadding -> None, ColorFunctionScaling -> False, 
  ColorFunction -> ColorData[{"ThermometerColors", {0.9996, 1.0004}}]}

and use the same scaled colors in the ArrayPlot that generates the legend:


figure3bLegend = 
 ArrayPlot[legend, ColorFunctionScaling -> False, 
  ImageSize -> {200, 350}, 
  ColorFunction -> ColorData[{"ThermometerColors", {0.9996, 1.0004}}],

   DataRange -> {{0, 1}, {0.9996, 1.0004}}, 
  FrameTicks -> {{0.9996, 0.9997, 0.9998, 0.9999, {1.0000, "1.0000"}, 
     1.0001, 1.0002, 1.0003, 1.0004}, None}, AspectRatio -> 7, 
  LabelStyle -> Large]

and add the option ImageSize->400 in plotops used in generation of figure3a.


With these changes


Row[{figure3a, figure3b, figure3bLegend}, Spacer[5]]

gives enter image description here



Comments

Post a Comment

Popular posts from this blog

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...
Post a Comment
Read more

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...
Post a Comment
Read more

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...
Post a Comment
Read more