TransWikia.com

Scaling contour plot according to domain shape/dimension AND bringing labels inside the domain

Mathematica Asked by Indrasis Mitra on November 4, 2020

I am plotting temperature over a rectangular region of length $L$ and width $d$. $L>d$. The output of the contour plot is on a square.

(1) Can it be somehow adjusted to reflect the relative dimension of the domain? In other words can the plot be on a rectangle as the actual domain is.

(2) Can the contour labels be adjusted to fall inside the domain and not near the edges ?

I am including the code

ww = 0.095 10^-3; wc = 
 1.4 10^-3; d = 0.002; L = 0.030; u = 0.0104; cp = 4178; ks = 16; tfi = 300; q = 0.30005/2; rho = 997; h = 1931.39; 
m = Sqrt[(h (2 (L + 0.5 ww)))/(ks 0.5 ww L)]; α = (2*h)/(cp*rho*u*wc); β = (2*h)/(ks*ww); p = Sqrt[α^2 + 4*β]; eta = Tanh[d*m]/(d*m); σ = d/wc;
qflux = 8603;
γ = (qflux*2*eta*σ*(wc + ww))/((2*eta*σ + 1)*ks*ww); 
ζ1 = (qflux*(wc + ww))/(wc*(cp*d*rho*u)); 

TwnoAC[x_, y_] = (γ/m)*((Cosh[m (d - y)]/Sinh[m d])) + tfi + ζ1 x ;

ContourPlot[TwnoAC[x, y], {x, 0, L}, {y, 0, d}, ColorFunction -> "TemperatureMap", PlotLegends -> Automatic, PlotRange -> All, ContourLabels -> Function[{x, y, z}, Text[Framed[z], {x, y}, Background -> White]]]

The output is

enter image description here


After using flinty’s recommendation but using AspectRatio->0.50, I got this (but the labels are still on the edges):

enter image description here

2 Answers

$Version

(* "12.1.1 for Mac OS X x86 (64-bit) (June 19, 2020)" *)

Clear["Global`*"]

ww = 95 10^-6;
wc = 14 10^-4;
d = 1/500;
L = 3/100;
u = 13/1250;
cp = 4178;
ks = 16;
tfi = 300;
q = 6001/40000;
rho = 997;
h = 193139/100;
m = Sqrt[(h (2 (L + ww/2)))/(ks ww L/2)];
α = (2*h)/(cp*rho*u*wc);
β = (2*h)/(ks*ww);
p = Sqrt[α^2 + 4*β]; eta = Tanh[d*m]/(d*m);
σ = d/wc;
qflux = 8603;
γ = (qflux*2*eta*σ*(wc + ww))/
   ((2*eta*σ + 1)*ks*ww);
ζ1 = (qflux*(wc + ww))/(wc*(cp*d*rho*u));

TwnoAC[x_, y_] = ((γ/m)*((Cosh[m (d - y)]/Sinh[m d])) +
     tfi + ζ1 x // Simplify) /. r_Rational :> N[r]

(* 300 + 106.032 x + 0.0319017 Cosh[2256.25 (0.002 - y)] *)

The min and max values of the function are

{zMin, zMax} =
 (#[{TwnoAC[x, y], 0 <= x <= L, 0 <= y <= d}, {x, y}] & /@
   {MinValue, 
    MaxValue})

(* {300.032, 304.635} *)

midPt[z_?NumericQ] := midPt[z] = Module[{xc, yc},
    yc = Mean[#[{y, TwnoAC[x, y] == z, 0 <= x <= L, 0 <= y <= d}, {x, 
          y}] & /@
       {NMinValue, NMaxValue}];
    xc = x /. Solve[{TwnoAC[x, yc] == z, 0 <= x <= L}, x][[1]];
    {xc, yc}];

Pre-calculate midPt for labels

midPt /@
   (Range[300 + 1/2, 304 + 1/2, 1/2] /. r_Rational :> N[r]) // 
  Quiet; 

Plot with the ColorFunction rescaled and the ContourLabels relocated

ContourPlot[TwnoAC[x, y], {x, 0, L}, {y, 0, d},
 ColorFunction -> (ColorData["TemperatureMap"][Rescale[#, {zMin, zMax}]] &),
 ColorFunctionScaling -> False,
 PlotLegends -> Automatic,
 PlotRange -> All,
 ContourLabels -> Function[{x, y, z},
   Text[If[z <= 304,
     Framed[z], ""], midPt[z],
    Background -> White]],
 AspectRatio -> 0.5,
 ImageSize -> Medium]

enter image description here

Correct answer by Bob Hanlon on November 4, 2020

cp = ContourPlot[TwnoAC[x, y], {x, 0, L}, {y, 0, d}, 
  ColorFunction -> "TemperatureMap", 
  PlotLegends -> Placed[Automatic, Right], PlotRange -> All,  
  ImageSize -> Large, AspectRatio -> 1/2]

enter image description here

Post-process cp to extract tooltips and contruct a graphics object with framed labels in the middle of the associated lines:

labels = Graphics @ Cases[Normal[cp], 
    Tooltip[{___, Line[x_], ___}, t_] :> 
     Text[Framed[t, Background -> White], BSplineFunction[x]@.5], All];

Show the two together:

Show[cp, labels, PlotRangeClipping -> False]

enter image description here

You can also rotate the labels based on curvature of the contour line using contour labels as custom Arrowheads:

arrows = Graphics@ Cases[Normal[cp], 
    Tooltip[{style___, Line[x_], ___}, t_] :> {style, 
      FontColor -> Black, FontOpacity -> 1, 
      Arrowheads[{{.5, .5, Graphics@Text[Framed[t, Background -> White, 
         FrameStyle -> None]]}}], Arrow[SortBy[First]@x]}, All];

Show[cp, arrows, PlotRangeClipping -> False]

enter image description here

Answered by kglr on November 4, 2020

Add your own answers!

Ask a Question

Get help from others!

© 2024 TransWikia.com. All rights reserved. Sites we Love: PCI Database, UKBizDB, Menu Kuliner, Sharing RPP