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]}]] > ]] >