7
$\begingroup$

In this question, we are asked to compute breaks in the contours of a ContourPlot so as to place contour labels (values) atop the colored boundaries rather than the individual contours themselves.

I solved that task with an admittedly kludgy approach that extracted pixel images of various components and assembled them through ImageMultiply. As the OP noted, and I here concur, this solution can be improved. Surely there must be some way to extract the individual components without rasterizing them (i.e. without converting them to an image) and then compose them, leading to a high-resolution final image that can be exported to e.g. .eps.

Alas, I have been unable to figure out how to do that.

$\endgroup$

2 Answers 2

8
$\begingroup$

Here is one way that gives you a proper Graphics expression without rasterization and rotated labels following the contours (code below):

enter image description here

The strategy is as follows:

  • Use the tricks from @CarlWoll's answer from here to get the plot range in plot coordinates and image coordinates, together with the bounding boxes of all the labels
  • Group labels together with their corresponding contours (using the fact that the contours have a tooltip with the contour value)
  • Convert the label bounding boxes to plot coordinates using the data from the previous step
  • Find the contours below the labels
  • Convert the contour below the label to image coordinates, and compute the angle of the contour in that region
  • Use this angle to rotate the label and the label bounding box
  • Reassemble the plot using the modified labels and contours:
    • Use the original plot with the labels and contours hidden
    • Use the rotate labels
    • For each contour, subtract all bounding boxes of all labels. During this, we take care not to remove the tooltips or styling

One complication is that the bounding boxes are given in image coordinates, while the contours are given in plot coordinates, so we have to take care to convert between the two where appropriate. Similarly, we want the angles in image coordinates, not plot coordinates (i.e. a line that appears to be at an angle of 45° does not necessarily have a slope of 1 in plot coordinates). For more details, see the comments in the code.

f[x_, y_] := x/Exp[x^2 + y^2];(*plug in your function*)plot = ContourPlot[f[x, y], {x, -2, 2}, {y, -2, 2}, ContourLabels -> All, Frame -> False];

(* compute bounding boxes and positions of labels, as well as plot range and plot size,
see https://mathematica.stackexchange.com/a/138907/36508 for details *)
{regions, pr} = Reap@Rasterize[
    Show[
     (* annotate all labels to get their BBs *)
     plot /. t : Text[lbl_, ___] :> Annotation[t, t, Text],
     (* add annotated rectangle to get entire plot range BB *)
     Epilog -> {Annotation[Rectangle[Scaled@{0, 0}, Scaled@{1, 1}], "pr", Region]},
     (* add grid lines to extract plot range *)
     GridLines -> {(Sow[{##}, "x"]; {}) &, (Sow[{##}, "y"]; {}) &}
     ],
    "Regions"
    ];
(* extract x/y plot ranges *)
pr = pr[[All, 1]];
(* extract plot BB *)
prbb = FirstCase[regions, ({"pr", Region} -> bb_) :> bb, "", All];

(* function to rescale image coordinates to plot coordinates *)
rescale[pts_] := Transpose@MapThread[Rescale, {Transpose@pts, MapAt[Reverse, 2]@Transpose@prbb, pr}]
(* function to expand a rectangle slightly to have some space around the labels *)
dilate[pts_] := Transpose[Mean@# + 0.7 {-1, 1} Subtract @@ # & /@ Transpose@pts]

(* rotate the labels and their bouding boxes by finding their corresponding contours & measuing the angle *)

{labels, bbs} = Transpose@Cases[
    regions,
    (* go through all labels *)
    ({Text[lbl_, _, rest___], Text} -> bb_) :> Module[
      {center, scaleFacs, cont, ang},
      (* center of the bounding box in plot coordinates *)
      center = Mean /@ Transpose@rescale@bb;
      (* scale factors to switch from image coordinates to plot coordinates and back *)
      scaleFacs = Subtract @@@ Transpose@prbb/Subtract @@@ pr;
      (* find the contour belonging to the label (identified using its Tooltip) & extract the part around the label *)
      cont = Quiet@RegionIntersection[
         (* extract all contours where the tooltip is the same as the label text *)
         RegionUnion @@ Append[
            (* adding a dummy line outside the plot seems to fix some issues with RegionIntersection *)
            Line@{pr[[All, 2]] + 0, pr[[All, 2]] + {1, 1}}
            ]@FirstCase[
            Normal@plot,
            Tooltip[prim_, lbl, ___] :> Cases[prim, _Line, All],
            EmptyRegion[2],
            All
            ],
         (* a circle in screen coordinates might be an ellipse in plot coordinates, so we compute the appropriate witdth/height of the ellipse *)
         DiscretizeRegion@Disk[center, Norm[Subtract @@ bb]/scaleFacs/2]
         ];
      (* the "mean angle" of the contour belonging to the label *)
      ang = Mod[
        Round[
         ArcTan @@ (
           (* we want angles in image coordinates *)
           scaleFacs*
            (Mean[
               (* this assembles the individual line segments into connected lines & extracts their end points*)
               Subtract @@@ ConnectedComponents[
                  Graph@Cases[
                    MeshPrimitives[cont, 1],
                    Line@pts_ :> UndirectedEdge @@ pts
                    ]
                  ][[All, {1, -1}]]
               ] /. Mean[{}] -> {1, 0})
           ),
         \[Pi]/20
         ],
        \[Pi],
        -\[Pi]/2
        ];
      {(* create the rotate label and (dilated) bounding box *)
       Text[Rotate[lbl, ang], center, rest],
       (* this creates the rectangle in image coodinates, rotates it and transforms it to plot coordinates afterwards *)
       Polygon@rescale@RotationTransform[-ang, Mean /@ Transpose@bb]@#[[{1, 2, 4, 3}]] &@Tuples@Transpose@dilate@bb
       }
      ]
    ];

lblReg = RegionUnion @@ bbs;
(* assemble the final plot *)
Show[
 (* remove labels and contours from the original plot *)
 plot /. {_Tooltip -> {}, _Text -> {}},
 Graphics@{
   (* add the rotated labels back *)
   labels,
   (* add the contour lines, taking care to preserve the tooltips *)
   Cases[
    Normal@plot,
    Tooltip[prim_, lbl_, rest___] :>
     Tooltip[
      (* subtract the bounding boxes from all lines *)
      prim /. l_Line :> MeshPrimitives[
         Quiet@RegionDifference[RegionUnion @@ DiscretizeRegion /@ {
              l,
              (* adding a dummy line outside the plot seems to fix some issues with RegionDifference *)
              Line@{pr[[All, 2]] + 0, pr[[All, 2]] + {1, 1}}
              }, lblReg],
         1
         ],
      lbl,
      rest
      ],
    All
    ]
   }
 ]

Original solution

f[x_, y_] := x/Exp[x^2 + y^2];(*plug in your function*)
plot = ContourPlot[f[x, y], {x, -2, 2}, {y, -2, 2}, 
  ContourLabels -> All, Frame -> False];

{regions, pr} = 
  Reap@Rasterize[
    Show[plot, 
      Epilog -> {Annotation[Rectangle[Scaled@{0, 0}, Scaled@{1, 1}], 
         "pr", Region]}, GridLines -> {
        (Sow[{##}, "x"]; {}) &,
        (Sow[{##}, "y"]; {}) &
        }
      ] /. t_Text :> Annotation[t, "label", Text], "Regions"];
pr = pr[[All, 1]];
prbb = FirstCase[regions, ({"pr", Region} -> bb_) :> bb, "", All];
rescale[pts_] := 
 Transpose@
  MapThread[
   Rescale, {Transpose@pts, MapAt[Reverse, 2]@Transpose@prbb, pr}]
dilate[pts_] := 
 Transpose[Mean@# + 0.7 {-1, 1} Subtract @@ # & /@ Transpose@pts]
Show[
 plot /. _Line -> {},
 Graphics@MeshPrimitives[
   RegionDifference[
    RegionUnion @@ Cases[Normal@plot, _Line, All],
    RegionUnion[
     Rectangle @@@ 
      dilate /@ rescale /@ Cases[regions, ({_, Text} -> bb_) :> bb]
     ]
    ],
   1
   ]
 ]

enter image description here

$\endgroup$
6
  • $\begingroup$ Thanks. I don't quite understand your method in full, but I do see that you rasterize the plot, and that the final image you post shows rasterized contours and text... right? But we're seeking .eps... not rasterized images. (Am I missing something?) $\endgroup$ Aug 2, 2021 at 22:12
  • $\begingroup$ @DavidG.Stork No, the end result is not rasterized (sorry, I should have stated that more clearly). Rasterize with "Regions" as second argument is merely used to compute the exact bounding boxes of the labels together with the plot range, as explained in the linked answer $\endgroup$
    – Lukas Lang
    Aug 2, 2021 at 22:14
  • $\begingroup$ Ah... that helps. (A bit confusing with all those Sows and Reaps.) So I guess this works. Thanks! ($\checkmark$) $\endgroup$ Aug 2, 2021 at 22:16
  • $\begingroup$ @DavidG.Stork Yeah, unfortunately it is. I would have used ResourceFunction["GraphicsInformation"] as a nicer wrapper around that trickery, but since I need also the bounding boxes of the labels, that wouldn't really work... $\endgroup$
    – Lukas Lang
    Aug 2, 2021 at 22:18
  • $\begingroup$ @DavidG.Stork I have added a second version of the code that rotates the labels along the contours & that includes a lot more comments $\endgroup$
    – Lukas Lang
    Aug 3, 2021 at 10:25
5
$\begingroup$

Does not like PostScript, we can not easy to clip the region in Mathematica.

Here we use the positions of the texts to split every contours into two contours and erase some neighborhood points.

SetOptions[ContourPlot, PlotPoints -> Automatic, Frame -> False, 
  ContourLabels -> All];
f[x_, y_] := x/Exp[x^2 + y^2];
plot = ContourPlot[f[x, y], {x, -2, 2}, {y, -2, 2}];
plot2 = ContourPlot[f[x, y], {x, -2, 2}, {y, -2, 2}, 
   ContourStyle -> None];
pts = Cases[plot, _GraphicsComplex, Infinity][[1, 1]];
contourspts = Cases[plot, Line[a_] :> a, Infinity];
texts = Cases[plot, Text[_, a_] :> a, Infinity];
newcontours[i_] := Module[{index, position, splitpts, remainpts},
  index = texts[[i]];
  position = 
   FirstPosition[contourspts, 
    First@FirstPosition[pts, pts[[index]]]];
  splitpts = 
   TakeDrop[contourspts[[position // First]], position // Last];
  remainpts = 
   DeleteCases[#, 
      p_ /; EuclideanDistance[pts[[p]], pts[[index]]] < .15] & /@ 
    splitpts;
  Graphics[Line[pts[[#]] & /@ remainpts]]]
Show[plot2, Table[newcontours[i], {i, 1, Length@texts}]]

enter image description here

$\endgroup$
1
  • $\begingroup$ Oooh... nice. Thanks. ($+1$) $\endgroup$ Aug 4, 2021 at 15:37

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.