(*********************************************************************** This file was generated automatically by the Mathematica front end. It contains Initialization cells from a Notebook file, which typically will have the same name as this file except ending in ".nb" instead of ".m". This file is intended to be loaded into the Mathematica kernel using the package loading commands Get or Needs. Doing so is equivalent to using the Evaluate Initialization Cells menu command in the front end. DO NOT EDIT THIS FILE. This entire file is regenerated automatically each time the parent Notebook file is saved in the Mathematica front end. Any changes you make to this file will be overwritten. ***********************************************************************) (*:Name: LabelContour *) (*:Title: LabelContour *) (*:Author: Tom Wickham-Jones. Updated by Dan Dubin 2002*) (*:Package Version: 1.00001 *) (*:Mathematica Version: 4.2 *) (*:Summary: This package provides functions to label contour plots. *) (*:History: Created summer 1993 by Tom Wickham-Jones. This package is described in the book Mathematica Graphics: Techniques and Applications. Tom Wickham-Jones, TELOS/Springer-Verlag 1994. *) (*:Warnings: *) BeginPackage[ "ExtendGraphics`LabelContour`", "Graphics`Legend`","Utilities`FilterOptions`"] LabelContourLines::usage = "LabelContourLines[ cont, opts] displays the contour plot cont with a label on each contour line giving its height." LabelPlacement::usage = "LabelPlacement is an option of LabelContourLines that determines how the labels are placed. A value of Center will use the mid-point of each contour line. A value of Automatic will attempt to find labels that are spaced away from each other." PointFactor::usage = "PointFactor is an option of LabelContourLines that is used when the LabelPlacement is set to Automatic. It takes a positive number that determines the weighting function that is used to find the points at which labels are placed. A value of 1 means that the same weight is given in the x and y directions. A value of less than 1 spreads labels in the x direction while a value of greater than 1 spreads them out in the y direction." PointSkip::usage = "PointSkip is an option of LabelContourLines that is used when the LabelPlacement is not set to be Automatic. It determines how many points are examined as candidates for placing labels. A setting of 4 will ensure that every fourth point along each line is examined." LabelContourLegend::usage = "LabelContourLegend[ cont, opts] displays the contour plot cont with a legend containing the values of the heights of the contours." HeightName::usage = "HeightName is an option of LabelContourLegend that determines the text label describing the name of the height." LegendSize::usage = "LegendSize is an option of various graphics functions that determines the size of the legend." LegendPosition::usage = "LegendPosition is an option of various graphics functions that determines the position of the legend." LabelFont::usage = "LabelFont is an option of LabelContourLines and LabelContourLegend that describes the font to be used for labels." LabelColor::usage = "LabelColor is an option of LabelContourLines that determines the color of the font to be used for labels." LabelSize::usage = "LabelSize is an option of LabelContourLines and LabelContourLegend that determines the size of the font to be used for labels." LabelWeight::usage = "LabelWeight is an option of LabelContourLines and LabelContourLegend that determines the weight of the font to be used for labels." LabelSlant::usage = "LabelWeight is an option of LabelContourLines and LabelContourLegend that determines the slant of the font to be used for labels." ContourDisplayFunction::usage = "ContourDisplayFunction is a display function for contour plots that causes automatic label placement." LabelContourLinePlot::usage = "LabelContourLinePlot is a function that creates a contour plot with labels on the contour lines, all in one step. It takes the same options as LabelContourLines and ContourPlot." LabelContourLegendPlot::usage = "LabelContourLegendPlot is a function that creates a contour plot with labels in an adjoining legend, all in one step. It takes the same options as LabelContourLegend and ContourPlot." Begin["`Private`"] LabelContourLinePlot[f_,{x_,a_,b_},{y_,c_,d_},opts___]:= Module[{optplot,optLabel,cplot},optplot=FilterOptions[ContourPlot,opts]; optLabel=FilterOptions[LabelContourLines,opts]; optplot=Sequence[optplot,DisplayFunction\[Rule]Identity]; cplot=ContourPlot[f,{x,a,b},{y,c,d},Evaluate[optplot]]; LabelContourLines[cplot,optLabel]] LabelContourLegendPlot[f_,{x_,a_,b_},{y_,c_,d_},opts___]:= Module[{optplot,plotLabel,cplot},optplot=FilterOptions[ContourPlot,opts]; optLabel=FilterOptions[LabelContourLegend,opts]; optplot=Sequence[optplot,DisplayFunction\[Rule]Identity]; cplot=ContourPlot[f,{x,a,b},{y,c,d},Evaluate[optplot]]; LabelContourLegend[cplot,optLabel]] ContourDisplayFunction[ g:ContourGraphics[ data_, opts___]] := Block[{shade, topts, copts, fun, lopts}, shade = ContourShading /. Flatten[ {opts}] /. Options[ ContourGraphics] ; topts = Flatten[ {opts}] ; copts = FilterOptions[ ContourGraphics, Apply[ Sequence, topts]] ; fun = If[ shade === True, LabelContourLegend, LabelContourLines] ; lopts = FilterOptions[ fun, Apply[ Sequence, topts]] ; fun[ ContourGraphics[ data, copts], lopts] ; g] textFun[ Text[ t_, {x_, y_, ang_}], font_, size_, color_,weight_,slant_] := Text[ t, {x,y}, TextStyle->{FontFamily->font, FontSize->size, FontColor->color,FontWeight->weight,FontSlant->slant}, Background -> None] Options[ LabelContourLines] = { LabelFont -> "Times-Roman", LabelSize-> 12, LabelColor->RGBColor[0,0,0], LabelWeight->"Plain", LabelSlant->"Plain", LabelPlacement -> Center, PointFactor -> 1, PointSkip -> 4 } GetFont[ {name_String, size_}, def_] := { name, CheckSize[ size]} GetFont[ name_String, def_] := If[ Length[ def] === 2, {name, CheckSize[ Last[ def]]}, {name, 6}] GetFont[ size_, def_] := If[ Length[ def] === 2, {First[ def], CheckSize[size]}, {"Courier", CheckSize[ size]}] CheckSize[ x_] := If[ Positive[ x], x, 6, 6] CheckPlace[ x_] := Switch[ x, Center, Center, Automatic, Automatic, _, Center] CheckFactor[ x_] := If[ NumberQ[x] && x > 0, x, 1] If[ Positive[ x], x, Automatic, Automatic] LabelContourLines[ g:ContourGraphics[ data_, opts___], lopts___] := Module[{conts,style,shade,factor,color, weight,slant, c,prims,opt,levs,text,font,size,ostyle, place,skip,fact,max}, Off[NumberForm::"sigz"]; opt = Join[ {lopts}, Options[ LabelContourLines]] ; font = LabelFont /. opt; size = LabelSize/.opt; color = LabelColor/.opt ; weight = LabelWeight /. opt; slant = LabelSlant /. opt; place = CheckPlace[ LabelPlacement /. opt] ; skip = PointSkip /. opt ; fact = CheckFactor[ PointFactor /. opt] ; opt = Join[ Flatten[{opts}], Options[ ContourGraphics]] ; ostyle = ContourStyle /. opt ; shade = ContourShading /. opt ; conts = Contours /. opt ; conts = FindContours[ conts, Last[ FullOptions[ g, PlotRange]]] ; max = Max[ Abs[ conts]] ; style = Table[ {AbsoluteThickness[ i]}, {i,Length[ conts]}] ; c = Show[ g, Contours -> conts, ContourStyle -> style, DisplayFunction -> Identity] ; c = Graphics[ c] ; prims = First[ c] ; opt = List @@ Rest[ c] ; levs = If[ shade, levs = Drop[ prims, 1] ; Map[ (# /. {__, {___, AbsoluteThickness[ t_], ___, Line[ pts_]}} -> {t, pts})&, levs] (* else *) , Map[ (# /. {___, AbsoluteThickness[ t_], ___, Line[ pts_]} -> {t, pts})&, prims]] ; ostyle = FixStyle[ ostyle, Length[ conts]] ; prims = Map[ (# /. AbsoluteThickness[ t_] :> Sequence @@ Part[ ostyle, t])&, prims] ; If[ place === Center, levs = Map[ { Part[conts, First[#]], Last[#]}&, levs] ; text = Map[ MidTextCalc[#,max]&, levs] , (* else *) levs = Map[ FixLevs[ #, skip]&, levs] ; text = Table[ TextCalc[ conts, levs, i, fact, max], {i, Length[ levs]}] ] ; text = Map[ textFun[#, font, size, color,weight,slant]&, text] ; opt = opt /. (DisplayFunction -> Identity) -> Options[ Graphics, DisplayFunction] ; Show[ Graphics[ {prims, text}, FilterOptions[ Graphics, lopts], opt]] ] (* MidTextCalc[ {cont_, line_}, max_] := Text[ NumberFunction[ cont, max], GetLinePosition[ line]] GetLinePosition[ line_] := If[ Length[ line] === 2, Apply[ Plus, line]/2, Part[ line, Ceiling[ Length[ line]/2.]]] *) MidTextCalc[ {cont_, line_}, max_] := Text[ NumberFunction[ cont, max], GetLinePosition[ line]] GetLinePosition[ line_] := Block[{pos}, If[ Length[ line] === 2, Append[ Apply[ Plus, line]/2, Apply[ AngCal, line]], pos = Ceiling[ Length[ line]/2.] ; Append[ Part[ line, pos], AngCal[ line[[pos-1]], line[[pos+1]]]] ] ] AngCal[ p1_, p2_] := N[ 2Pi - Apply[ ArcTan, p2-p1]] FixLevs[ {num_, lev_}, fact_] := Block[{len, nfact}, nfact = fact ; len = Length[ lev] ; If[ len < nfact*4, nfact = Floor[ len/4]] ; If[ Head[ nfact] =!= Integer || nfact < 1, nfact = 1] ; If[ len < 4, {num, lev}, {num, Map[ First, Partition[ Take[ lev, {2, -2}], nfact]]}] ] FindMin[ pt_, test_, wght_] := Min[ Map[ (tmp = (#-pt)*{1,wght}; tmp.tmp)&, test]] FixDists[ inp_List] := Block[{}, {coord, dists} = Transpose[ inp] ; If[ Not[True === SameQ @@ coord] , Print[ "Mess Up in FixDists"]] ; {Part[ coord, 1], Times @@ dists} ] TextCalc[ vals_, levs_, num_, wght_, cmax_] := Block[{test, cnum, dists, max, i, pos, cont, ang, rpos, lpos}, cont = Part[ levs, num] ; cnum = Part[ cont, 1] ; test = Select[ levs, (Abs[ Part[ #, 1]-cnum] === 1.)&] ; test = Map[ Part[ #, 2]&, test] ; cont = Part[ cont, 2] ; dists = Map[ Table[ { i, FindMin[ Part[ cont, i], #, wght] }, {i, Length[ cont]}]&, test] ; dists = Transpose[ dists] ; dists = Map[ FixDists, dists] ; dists = dists * Join[ {{1, 0.5}}, Table[ {1, 1}, {Length[dists]-2}], {{1, 0.5}}] ; max = Part[ dists, 1] ; Do[ If[ Part[ max, 2] < Part[ dists, i, 2], max = Part[ dists,i]], {i, 2, Length[ dists]}] ; pos = Part[ max, 1] ; If[ Length[ cont] < 3, ang = Apply[ AngCal, cont], lpos = If[ pos == 1, 1, pos-1] ; rpos = If[ pos == Length[ cont], pos, pos+1] ; ang = AngCal[ cont[[lpos]], cont[[rpos]]]] ; pos = Append[ Part[ cont, pos], ang] ; Text[ NumberFunction[ Part[ vals, cnum], cmax], pos] ] FixStyle[ Automatic, num_] := FixStyle[ Thickness[ 0.001], num] FixStyle[ style_, num_] := FixStyle[ {style}, num] FixStyle[ style_List, num_] := If[ ListQ[ style] && Length[ style] > 0 && ListQ[ First[ style]], Table[ First[ RotateLeft[ style, i-1]], {i,num}], Table[ style, {num}]] FindContours[ x_List, {z1_, z2_}] := x FindContours[ n_Integer /; n > 0, {z1_, z2_}] := Block[{zinc}, zinc = (z2 - z1)/ (n + 1) ; Table[ i, {i, z1 + zinc, z2 - zinc, zinc}] ] NumberFunction[x_, max_] := Block[{t,digs}, If[max == 0, t = 0., digs = Floor[Log[10, max]]; digs = N[10^digs]; t = x/digs; t = Floor[t 100]; t = t*digs/100]; ToString[NumberForm[t, 3]]] Options[ LabelContourLegend] = { LabelFont -> "Times-Roman", LabelSize->12, LabelColor->RGBColor[0,0,0], LabelWeight->"Plain", LabelSlant->"Plain", HeightName -> "z", LegendSize -> Automatic, LegendPosition -> Automatic } LabelContourLegend[ g:ContourGraphics[ data_, opts___], lopts___] := Block[{z1, z2, conts, cfun, shade, name, lsize, lpos, prims, text, font, size, color,weight,slant, opt}, opt = Join[ {lopts}, Options[ LabelContourLegend]] ; font = LabelFont /. opt; size = LabelSize/.opt; color = LabelColor/.opt ; weight = LabelWeight /. opt; slant = LabelSlant /. opt; name = HeightName /. opt ; lsize = LegendSize /. opt ; lpos = LegendPosition /. opt ; If[ !StringQ[ name], name = ToString[ name]] ; {z1,z2} = Last[ FullOptions[ g, PlotRange]] ; opt = Join[ Flatten[ {opts}], Options[ ContourGraphics]] ; conts = Contours /. opt ; cfun = ColorFunction /. opt ; If[ cfun === Automatic, cfun = GrayLevel] ; conts = FindContours[ conts, {z1, z2}] ; shade = ColorFunctionValues[ conts, z1, z2] ; shade = Map[ cfun, shade] ; max = Max[ Abs[ conts]] ; conts = Map[ NumberFunction[ #, max]&, conts] ; text = Table[ StyleForm[ StringJoin[ " < ", conts[[i]]], FontFamily->font, FontSize->size, FontColor->color,FontWeight->weight,FontSlant->slant], {i, Length[ conts]}] ; text = Append[ text, StyleForm[ StringJoin[ " > ", Last[ conts]], FontFamily->font, FontSize->size, FontColor->color,FontWeight->weight,FontSlant->slant]] ; prims = Graphics[ {{Rectangle[ {0,0}, {1,1}]}, Line[ {{0,0},{0,1},{1,1},{1,0},{0,0}}]}] ; prims = Table[ { Insert[ prims, shade[[i]], {1,1,1}], text[[i]] }, {i, Length[ shade]}] ; prims = Reverse[ prims] ; lsize = FixLSize[ lsize, Length[ conts]+1, size] ; lpos = FixLPos[ lpos, lsize] ; ShowLegend[g, { prims, LegendLabel -> StyleForm[ name, FontFamily->font, FontSize->size, FontColor->color,FontWeight->weight,FontSlant->slant], LegendPosition -> lpos, LegendSize -> lsize, LegendShadow -> {0,0}, LegendBorder -> {Thickness[0.0001],GrayLevel[0]}, LegendSpacing -> Automatic, LegendTextSpacing -> Automatic, FilterOptions[ Graphics, lopts] }] ] FixLPos[ {x_ /; NumberQ[x], y_ /; NumberQ[y]}, _] := {x, y} FixLPos[ _, {x_, y_}] := {1.1, -y/2.} FixLSize[ {x_ /; Positive[x], y_ /; Positive[ y]}, len_, size_] := {x, y} If[ BookPrint === True, FixLSize[ _, clen_, size_] := {0.11, 0.027 clen} size, FixLSize[ _, clen_, size_] := {0.06, 0.02 clen} size] ColorFunctionValues[ vals_List, z1_, z2_] := Block[{p1, p2, pf, res}, p1 = (z1 + First[ vals])/2. ; p2 = (z2 + Last[ vals])/2. ; pf = p2 - p1 ; res = Table[ ((Part[ vals, i] + Part[ vals, i+1])/2. - p1)/pf, {i,Length[ vals] - 1}] ; Join[ {0}, res, {1}] ] End[] EndPackage[] (* Examples: <Function[z,RGBColor[z,1-z,z]],PlotPoints->40, DisplayFunction->Identity]; LabelContourLines[d,LabelSize->10,LabelColor-> RGBColor[0,0,1], LabelFont->"Chicago",LabelWeight->"Bold"]; LabelContourLegend[d,LabelSize->15,HeightName->"Phi", LabelColor->RGBColor[1,0,.5],LabelFont->"Times"]; *)