Here is one way that gives you a proper Graphics expression without rasterization and rotated labels following the contours (code below):
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
]
]
