How to automatically have ContourLabels in middle of Contour lines if specific levels are not specified?
This is a good question which I had tried to work on several years ago, and I just revisited it to see if the code could be useful.
I had initially only worked on rotating the contour labels to be tangential with the contours, but in the code it turned out to be quite easy to add a line that also attempts to center the labels along the contour. My simple approach is to estimate the center of the contour by just choosing the midpoint in the Line specification defining that particular contour.
The code comes with comments, but it's quite lengthy:
Clear[rotateContourLabels];
rotateContourLabels::usage =
"The function rotateContourLabels accepts the output of ContourPlot \
or ListContourPlot, assuming they were made with the option \
ContourLabel-> All. The plot is passed via the required first \
argument. The function rotates the labels of all contours to be \
approximately parallel to the iso-lines. The optional LabelFunction \
can specify a custom label style in the form of a function f[#1, #2, \
#3], where {#1, #2} is the 2D location vector of the label, and #3 \
the value of the plotted function at that location. For examples see \
the documentation on ContourLabels. The default label style is given \
by the function Text[#3,{#1,#2}]&. A second option, Alignment, \
influences the placement of the labels along the contour. The default \
Alignment -> Automatic leaves the original placement intact, any \
other value will shift the labels to an estimated center position \
along the contour.";
Options[rotateContourLabels] = {LabelingFunction -> (Text[#3, {#1, \
#2}] &), Alignment -> Automatic};
rotateContourLabels[plot_, OptionsPattern[]] :=
Module[{gc = plot[[1]] , valueList, pointList, rotatePoint,
labelCoordinatesIndexed, directionVector},
(******* Created by Jens U. Nöckel, August 17, 2009,
last modified May 16, 2017 *******)
Catch[
labelCoordinatesIndexed =
Quiet@Check[gc[[-1, -1, All, 2]], Throw[plot]];
valueList = Quiet@Check[gc[[-1, -1, All, 1]], Throw[plot]];
If[Last[Dimensions[labelCoordinatesIndexed]]==2,
pointList = labelCoordinatesIndexed,
pointList = Quiet@Check[gc[[1, labelCoordinatesIndexed]],
Throw[{"The plot must have the option ContourLabels->All !!!",
plot}]]];
(** gc is the GraphicComplex, gc[[1]] a list of 2D points.
The list of contour labels is contained in plot[[1,-1,-1]] =
gc[[-1,-1]] and we want to replace this list. **)
(* Local function definition: *)
rotatePoint[labelPoint_] :=
Module[{pt, extractSecant , allContourLines, contourPoints2D,
contourPointsIndexed , closestContourIndexed,
closestPointIndexed},
pt = labelPoint;
allContourLines =
Map[First,(**
The First extracts the list of line points from the Line \
expressions collected in the next line: **)
Cases[Flatten@
MapAll[If[SameQ[Head[#], Line], #, Apply[List, #]] &,
gc[[-1]]], _Line]];
(** Line can be nested inside other non-
list expressions such as Tooltip,
so the above flattens all levels of the expression except for \
subexpressions with head Line,
before it proceeds to collect the Lines using Cases. **)
{contourPoints2D, contourPointsIndexed} =
(** Given a point pt,
find out for each contour what is its closest point to pt.
Return this information both as 2D points and as a list of \
indices counted within each contour. **)
Transpose[
Map[
First@Nearest[
# -> Transpose[{#, Range[Length[#]]}],
pt
] (** End First@Nearest **)&,
Map[gc[[1, #]] &, allContourLines]
](* End Map *)
] (* End Transpose *);
{closestContourIndexed, closestPointIndexed} =
(** Given a point pt, find closest contour.
Give its index in the list of contours,
and the index of the closest point within this contour. **)
First[Nearest[
contourPoints2D ->
Transpose[{Range[Length[contourPoints2D]],
contourPointsIndexed}],
pt
]];(* End First@Nearest *)
If[OptionValue[Alignment] =!= Automatic,
(* Alignment refers to the placement of labels on contours.
If not Automatic,
try to approximately center the labels according to contour \
length, measured by points in their line: *)
closestPointIndexed =
Floor[Length[allContourLines[[closestContourIndexed]]]/2];
pt = Part[gc[[1]],
allContourLines[[closestContourIndexed,
closestPointIndexed]]]];
extractSecant = (** Given the closest point to pt,
record it and its next neighbor on the same contour line.
The two points are returned as real 2D points,
determined from their indices. **)
{
allContourLines[[closestContourIndexed, closestPointIndexed]] (*
The first point *),
Quiet@
Check[allContourLines[[closestContourIndexed,
closestPointIndexed + 1]],
allContourLines[[closestContourIndexed,
closestPointIndexed - 1]]] (*
The second sequential point -
here I want to avoid falling outside the range of the contour \
point list. *)
};
(* The rotation aims to make this vector parallel to the \
contour. We approximate the contour direction by taking two points on \
the contour and forming their difference: *)
directionVector = Apply[Subtract,
(** The two required points are found from the list gc[[1]] : **)
Part[gc[[1]],
(*
The Part of gc[[1]] we're looking for is a set of two points \
that define the secant closest to the contour label: *)
extractSecant]
];
(** Here starts the body of rotatePoint: **)
Composition[
(* The composition sandwiches a rotation around the origin \
between a translation to the origin and its inverse: *)
TranslationTransform[pt],
Quiet@Check[RotationTransform[{
{1, 0}, (*
The reference direction for the rotation is the horizontal: \
*)
(Sign[directionVector[[1]]] directionVector)
(*
To avoid rotations outside [-Pi,Pi] the above \
statement places the direction vector into the first or fourth \
quadrant. *)
}] (* End RotationTransform *)
, Identity (*
No rotation happens if for some reason we can't get a valid \
direction vector *)],
TranslationTransform[-labelPoint]
] (* End Composition *)
] ;(** End function rotatePoint **)
(**** Main function body: *****)
ReplacePart[plot, {1, -1, -1} ->
(** the replacement is a geometric transformation of the \
original list gc[[-1,-1]]: **)
MapThread[GeometricTransformation,
{MapThread[OptionValue[LabelingFunction],
Append[Transpose[pointList], valueList]],
(**
What follows is the list of transformations for each contour \
label: **)
Map[rotatePoint, pointList]}]]
]]
This defines a function rotateContourLabels which takes an existing plot and post-processes it. As always with post-processing, I have to make some assumptions about how the input was prepared:
In the ContourPlot or ListContourPlot that serves as the input, you must set either the option
ContourLabels -> True or ContourLabels -> All.
With this assumption, you can then use the function as follows:
a = ContourPlot[Im[(x + I y)^(1/2)], {x, -1, 1}, {y, -1, 1},
Contours -> 20, ContourLabels -> True]
This is the original output in Mathematica 10.2.
Now the usage example:
rotateContourLabels[a, Alignment -> Center,
LabelingFunction -> (Text[#3, {#1, #2},
Background -> Directive[Opacity[.5], White]] &)]
I think this result is an improvement (given that it's fully automatic), although of course the centering is not perfect.
Edit
For completeness, here is the OP's minimum working example:
Clear[x, y]
f = (11 - x - y)^2 + (1 + x + 10 y - x y)^2;
b = ContourPlot[f, {x, 0, 20}, {y, 0, 15}, Contours -> 7,
ContourShading -> None, ContourLabels -> True,
AspectRatio -> Automatic, PlotRangePadding -> 2];
rotateContourLabels[b, Alignment -> Center,
LabelingFunction -> Function[{x, y, z}, Text[z, {x, y}]]]
Note that I added the label function as an option to rotateContourLabels instead of the original plot (which I called b). I also decreased the number of contours to 7 so the labels are more readable. The placement of the labels is obviously much better than the original. The background I chose in the first example would probably also make this plot look a little better.
Finally, here is my automatic version of the book example in the question:
c = ContourPlot[x y, {x, -2, 2}, {y, -2, 2}, ContourShading -> False,
Contours -> 10, ContourLabels -> All];
rotateContourLabels[c, Alignment -> Center,
LabelingFunction -> (Text[#3, {#1, #2}, Background -> White] &)]
One could probably also add an option to place the labels at the ends of the contours instead of the center, but I haven't done that yet (because it usually looks ugly, even though Mathematica seems to like doing that by default...).
The software is located at http://library.wolfram.com/infocenter/Books/3753/ as a .tar and a .zip file.
Update
How about a shameless lifting of one of the references you mention and adding a Rotate function?
ContourPlot[x y, {x, -2, 2}, {y, -2, 2}, ContourShading -> False,
Contours -> 10,
ContourLabels -> (Rotate[Text[" " <> ToString[#3] <> " ", {#1, #2},
Background -> White], -ArcTan[#2/#1]] &)]
For other curves one would need to determine the tangent to the curve at point {#1, #2}.