[Date Index] [Thread Index] [Author Index]

Contour plots with map style (rotated) labels

• To: mathgroup at smc.vnet.net
• Subject: [mg102765] Contour plots with map style (rotated) labels
• From: Jens Noeckel <noeckel at gmail.com>
• Date: Wed, 26 Aug 2009 07:45:12 -0400 (EDT)
• References: <c1a8326f-e0b4-4e6b-a8da-9b124861c2a8@z31g2000yqd.googlegroups.com>

Hi Steve,
thanks for notifying us of the Google Groups posting problems. I guess  
I was affected by that, as I haven't seen my last two posts appear on  
the list. Here is one that I kept a record of, and that I think is  
worth re-posting. It's a function to align contour labels tangentially  
to the contours in ContourPlot. It searches for two points on a  
contour line closest to each label, and applies a rotation to the  
label based on the direction defined by those two points. These  
searches rely on two applications of Nearest for each label: one to  
find the nearest contour, and a second one to find the nearest points  
on that contour. The first of these searches could be eliminated to  
make the function faster if I were able to assume that contour lines  
and contour labels are always sorted in an identical order in the  
output GraphicsComplex. However, I wasn't sure that that's always  
true, so I went with a slightly more laborious approach.

Regards,
Jens

Begin forwarded message:

> From: JUN <noeckel at gmail.com>
> Date: August 18, 2009 8:56:31 AM PDT
> To: noeckel at gmail.com
> Subject: Contour plots with map style (rotated) labels
>
> Hi,
> someone asked me about this, and there was some discussion earlier:
> http://groups.google.com/group/comp.soft-sys.math.mathematica/browse_thread/thread/6dcd75efd2f99f09
>
> For ContourPlot and ListContourPlot, it's sometimes nice to have
> labels rotated to be parallel to the iso-lines. So I made a function
> "rotateContourLabels" which post-processes Mathematica's contour plots
> to achieve this rotation, and am pasting the code below.
>
> As an example, try these plots:
>
> a = ContourPlot[Im[(x + I y)^(1/2)], {x, -1, 1}, {y, -1, 1},
>  Contours -> 20, ContourLabels -> All]
>
> b = ListContourPlot[Table[Sin[i+j^2],{i,0,3,0.1},{j,0,3,0.1}],\
> ContourLabels->All]
>
> Note that for the post-processing to work, you must set the option
> ContourLabels->All as shown above (I am not modifying the default
> plotting functions, just processing their output, so I have to make
> some assumptions about how contour labels appear in the output). The
> next step is to do call
> rotateContourLabels[a,Text[#3, {#1, #2}, Background -> White] &]
> rotateContourLabels[b,{Orange, Text[#3, {#1, #2}]} &]
>
> The second argument is optional - it's a function to style the plot
> labels (see documentation for ContourLabels for usage of the
> function).
>
> Hope someone finds this useful or sees a way to improve it. For
> example, one could change this into a replacement for ContourPlot
> which accepts all the Options and creates the plot from scratch. One
> of Mathematica's competitor products has this label rotation built in,
> and even allows interactive placement. That could be done here using
> Tooltip as well, but I didn't think it's worth the trouble...
>
> Here is the code (the comments take up more space than the actual
> program).
>
> Cheers,
> Jens
>
>
> 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. An optional \
> second argument 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}]&.";
>
> rotateContourLabels[plot_, labelFunc_: (Text[#3, {#1, #2}] &)] :=
> Module[{gc = plot[[1]] , pointList, rotatePoint,
>   labelCoordinatesIndexed},
>  Catch[
>   labelCoordinatesIndexed =
>    Quiet@Check[gc[[-1, -1, All, 2]], Throw[plot]];
>   valueList = Quiet@Check[gc[[-1, -1, All, 1]], Throw[plot]];
>   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[pt_] :=
>    Module[{extractSecant , allContourLines, contourPoints2D,
>      contourPointsIndexed , closestContourIndexed,
>      closestPointIndexed},
>     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 *)
>
>     extractSecant = (** Given the closest point to pt,
>      record it and its next neighbor on the same contour line.
>      The two points are reutrned 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[-pt]
>      ] (* 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[labelFunc, Append[Transpose[pointList], valueList]],
>       (**
>       What follows is the list of transformations for each contour \
> label: **)
>       Map[rotatePoint, pointList]}]]
>   ]]
>