Graphics Examples
Dr. Robert P. Yerex, Ph.D., MBA
Salient Analytics
ryerex@robert-yerex.com

DateString[]

Background

This notebook contains a number of examples of graphics that I have been working on for the past couple of years. I was initially inspired by the work of Edward R. Tufte [1]. His ideas, many of them based on work already done by others in the past,are great but difficult to actually implement. The standard graph formats available in Excel and other tools product just the kind of Chartjunk that he rails against. These tools do not allow the user access to the graphics internals and primitives in order to make modifications to layout and style. Rather one must pick from a n ever increasing list of predefined formats where the only alternations possible are cosmetic.When I Chief Economist at Kronos Inc., I developed the Kronos Retail Labor Index [2]. I needed to be able to describe fairly complex economic concepts without the benefit of using jargon laden econometric descriptions and graphs because most of the readers of the report were not economists. The report was carried by most of the major newswires and I spent a good deal of time talking to reporters and analysts. In such discussions, I had 30 seconds to make my initial point, and if it got across, the discussion would proceed. Visual representations are , in my experience, best in these situations so I went about designing my own graphics. I will describe each in turn throughout this document.

1.	Tufte, E.R., The Visual Display of Quantitative Information. 2nd ed2001, Cheshire, CT: Graphics Press.

2.	Yerex, R.P., Kronos Retail Labor Index: Overview, in Kronos Retail Labor Index, R.P. Yerex, Editor 2009, Kronos, Inc: Beaverton, OR.

Data

In the production system I use to generate the report, all the data exists in a vast MS SQL database. I wrote Mathematica code that allowed me to directly access this data. I do not include that code here as it is only relevant to the Kronos data system, rather I have “hard-wired” the data as shown below.

Unemployment Rate

This is the US Unemployment rate from August, 2006 through February, 2011 as reported by the BLS

UnemploymentRate = {4.7`,4.5`,4.4`,4.5`,4.4`,4.6`,4.5`,4.4`,4.5`,4.4`,4.6`,4.6`,4.6`,4.7`,4.7`,4.7`,5.`,5.`,4.8`,
					5.1`,5.`,5.4`,5.5`,5.8`,6.1`,6.2`,6.6`,6.9`,7.4`,7.7`,8.2`,8.6`,8.9`,9.4`,9.5`,9.4`,9.7`,9.8`,
					10.1`,10.`,10.`,9.7`,9.7`,9.7`,9.9`,9.7`,9.5`,9.5`,9.6`,9.6`,9.6`,9.6`,9.8`,9.4`,9.4`};

US Dept. of Commerce - Retail Sales & Food Services (MARTS) , SA

This is the measure of US Retail Sales (in thousands of $ that is published monthly by the US Dept. of Commerce. This data is from August, 2006 through January 2011.

MARTS = { 360817.`,358416.`,359246.`,360660.`,366349.`,364654.`,365796.`,369515.`,367394.`,372224.`,368149.`,370082.`,
		  370183.`,373510.`,375199.`,379960.`,377616.`,377407.`,373295.`,374688.`,376064.`,377272.`,377687.`,376056.`,
		  373158.`,366950.`,355484.`,345704.`,335614.`,341617.`,341390.`,336207.`,336671.`,338785.`,343411.`,343518.`,
		  351128.`,343179.`,347880.`,351764.`,354098.`,355197.`,357272.`,364836.`,365997.`,362219.`,361170.`,362829.`,
	      365992.`,369440.`,375571.`,378706.`,380275.`,381565.`};

Federal Reserve - IPI (Industrial Production Index): Consumer goods; 2002=100; SA

This is the measure of US Industrial Production of Consumer Goods. It is an Index referred to as the IPI so the measures on a monthly basis are relative to 100 Which was the benchmark set several years ago.
This data set runs from August, 2006 through January, 2011.

IPI = { 99.7121`,99.3159`,99.4291`,99.3405`,99.5977`,99.1022`,100.9076`,100.09`,100.6119`,100.3709`,100.2245`,100.4875`,
		100.3044`,100.3976`,99.1968`,99.1989`,99.1078`,98.91`,98.9742`,97.7966`,97.115`,96.7823`,96.592`,96.3297`,94.4179`,
		93.7842`,94.2053`,93.3287`,91.8206`,89.749`,90.0275`,89.707`,89.1273`,88.1665`,87.905`,89.3107`,90.4813`,91.5103`,
		92.2283`,92.1196`,92.5963`,93.7058`,93.0163`,93.4395`,92.2956`,94.3887`,94.3946`,95.5698`,95.3285`,94.8779`,94.6934`,
		94.2015`,95.6785`,95.7672`};

Analysis

A note on seasonal adjustment: The data in this example are seasonally adjusted using a process specified by the US Census Bureau and implemented in their X-12a software which is publicly available. I initially recoded their algorithms in Mathematica which was time consuming and error prone. Whenever they made a change to the X12a software, I had to update my code to remain current. I finally realized that the best way to go about the adjustment process was to call out to the PC version of the X-12a software. I put together this code to make that call out. I presented this in the short workshops section of the Wolfram 2010 Tech Conference and include it here for anyone to use (and improve!). You will need to adapt it to your environment of course
SeriesAC = KronosHiresAC;
Export[StringJoin[WorkDirectory,”/MMAX12TMP.dat”],SeriesAC];
SpecFileString =
“series{
start=2006.8 
file=\”C:\\x12a\\work\\MMAX12TMP.DAT\”}
x11{ 
print = ( +ftestd8 +residualseasf +x11diag +qstat +specsa +specirr) 
save = ( D11) savelog = (q,q2,fb1,fd8,msf)}”;
Export[StringJoin[WorkDirectory,”/MMAX12TMP.spc”],SpecFileString,”String”];
Run[StringJoin[X12Directory,”/X12a -i “,WorkDirectory,”/MMAX12TMP -o “,WorkDirectory,”/MMAX12TMP”]];
SeriesSA = Take[Import[StringJoin[WorkDirectory,”/MMAX12TMP.D11”],”Table”][[All,2]],{3,(Dimensions[SeriesAC][[1]]+2)}];
KronosHires = Append[HiresSA,SeriesSA[[NKronosHiresAC]]]
Dimensions[KronosHires]

Analytical Design

This section contains default settings code as well as bring in in necessary libraries

Needs["PlotLegends`"]

(* Default Settings for plots that can be overridden as needed *)

lFrameLabel = FrameLabel -> {Style["X Axes Default", "AxesTitle"], Style["Y Axes Default", "AxesTitle"]};
 lPlotLabel = PlotLabel -> Style["Default Plot Label", "GraphTitle"]; 
lPlotStyle = PlotStyle -> Directive[Thickness[0.005], JoinForm["Round"]]; 
lFrameTicks = FrameTicks -> {None, Automatic}; 
WidthRange = 0.15; 
MinWidth = 0.02;

This first graph is nothing special, just a simple DateListPlot showing the trend in retail sales over time. Please note that the styles for the titles are set by “AxisTitle”, and “GraphTitle” which you can establish in the stylesheet of the notebook. Also note that I have used “Rescale[]” to make the graph relative to trend over the time period in question.

lPlotStyle = PlotStyle -> Directive[Thickness[0.005], JoinForm["Round"]]; 
lFrameLabel = FrameLabel -> {Style["", "AxesTitle"], Style["Normalized Level in Dollars", "AxesTitle"]};
lPlotLabel = PlotLabel -> Style["Trend in U.S. Dept. of Commerce Retail and Food Services Sales Survey Results", "GraphTitle"]; 
WidthRange = 0.15; 
MinWidth = 0.02;
DateListPlot[Rescale[MARTS],{2006,8},Joined -> True,InterpolationOrder -> 4,lFrameLabel, lPlotLabel, Axes -> {False, False},
lFrameTicks =FrameTicks->{{Automatic,None},{Automatic,None}}, 
lPlotStyle, ImageSize -> 900,AspectRatio -> 1/3]

The graph below is another simple DateListPlot, in this case of the US Unemployment Rate

lPlotStyle = PlotStyle -> Directive[Thickness[0.005], JoinForm["Round"]]; 
lFrameLabel = FrameLabel -> {Style["", "AxesTitle"], Style["US Unemployment Rate", "AxesTitle"]};
lPlotLabel = PlotLabel -> Style["Trend in U.S. Unemployment Rate", "GraphTitle"]; 
WidthRange = 0.15; 
MinWidth = 0.02;
DateListPlot[UnemploymentRate,{2006,8},Joined -> True,InterpolationOrder -> 4,lFrameLabel, lPlotLabel, Axes -> {False, False},
lFrameTicks =FrameTicks->{{Automatic,None},{Automatic,None}}, 
lPlotStyle, ImageSize -> 900,AspectRatio -> 1/3]

This third plot shows the trend in US Industrial Production of Consumer Goods, again in a simple DateListPlot

lPlotStyle = PlotStyle -> Directive[Thickness[0.005], JoinForm["Round"]];
 
lFrameLabel = FrameLabel -> {Style["", "AxesTitle"], Style["Normalized Level in Dollars", "AxesTitle"]};
lPlotLabel = PlotLabel -> Style["Trend in the Industrial Production Index for Consumer Goods (Federal Reserve Data)", "GraphTitle"]; 
WidthRange = 0.15; 
MinWidth = 0.02;
DateListPlot[Rescale[IPI],{2006,8},Joined -> True,InterpolationOrder -> 4,lFrameLabel, lPlotLabel, Axes -> {False, False},
lFrameTicks =FrameTicks->{{Automatic,None},{Automatic,None}}, 
lPlotStyle, ImageSize -> 900,AspectRatio -> 1/3]

Now, instead of looking at each of these trends individually, I could normalize them all and put them on the same plot as shown below, but while the major shift relationships are apparent, it is not intuitive

lPlotStyle = PlotStyle -> Directive[Thickness[0.005], JoinForm["Round"]]; 
lFrameLabel = FrameLabel -> {Style["", "AxesTitle"], Style["Unitized Trends", "AxesTitle"]};
lPlotLabel = PlotLabel -> Style["Unemployment Production, and Sales", "GraphTitle"]; 
WidthRange = 0.15; 
MinWidth = 0.02;
DateListPlot[{Rescale[UnemploymentRate],Rescale[IPI],Rescale[MARTS]},{2006,8},Joined -> True,InterpolationOrder -> 4,lFrameLabel, lPlotLabel, Axes -> {False, False},
lFrameTicks =FrameTicks->{{Automatic,None},{Automatic,None}}, 
lPlotStyle, ImageSize -> 900,AspectRatio -> 1/3]

The graph below shows all three trends together. The shape of the curve is the trend in IPI, the thickness of the line representing the curve is Retail Sales, and finally the color is scaled to the US Unemployment Rate. The actual graph is just a DateListPlot, the color and thickness are controlled by data that is not directly part of the dataset in the DateListPlot statement.

Before the code for the plot, there is a section that creates my “color legend”. I used several tricks (aka hacks) to get this to work. The ColorLegend is actually a small ListLinePlot where the line is so thick it fills the entire plot.

Below the graph I have listed the more generic code for the ColorLegend as a Module[], which is the way I actually run it. I do most of my development in Eclipse (aka Wolfram Workbench) and package as much reusable code in modules as possible. 
I broke it out in the example so that you could see just what is going on.

(* UnemploymentRateScaled *)
UnemploymentRateSmoothed = ExponentialMovingAverage[UnemploymentRate, 1/5];
Dimensions[UnemploymentRate]
UnemploymentRateScaled = Round[99*((UnemploymentRateSmoothed - Min[UnemploymentRateSmoothed])/(Max[UnemploymentRateSmoothed] - 
         	Min[UnemploymentRateSmoothed])) + 1];
(* UnemploymentRateTemp is a color scale I designed by blending over a range of 100 gradations *)
Temp1 = Table[{Blend[{Black, Gray}, x]}, {x, 0, 1, 1/10}];
Temp2 = Table[{Blend[{Gray, Orange}, x]}, {x, 0, 1, 1/52}];
Temp3 = Table[{Blend[{Orange, Red}, x]}, {x, 0, 1, 1/38}];
UnemploymentRateTemp = Join[Temp1,Temp2,Temp3];
(*  colorUnemploymentRate is a function that is passed to the Mathematica graphing engine and allows me to 
	dynamically change the color of the plot based on the value of a variable that is not on the x or y axes  
	The built in Mathematica color variation function such as what is seen in 3-D surface plots assumes that the
	color is set based on the value of x,y, or z.*)
ColorUnemploymentRate = Function[{x, y},UnemploymentRateTemp[[UnemploymentRateScaled[[Round[x+1]]]]]];

(*  The above function is used to control the color of the line in the plot. I also need to create my own Legend
	as the Graphics Engine has no idea what I'm doing! I create my own legend by building a small graphic that is
	essentially a horizontal bar-graph. The color with the bar transitions at a constant rate across the full scale 
	of values used in the graph. This is some complex dynamic coloring and scaling going on here so be careful making
	any changes!! *)
ColorUnemploymentRateLegend = Function[{x, y}, UnemploymentRateTemp[[x]]];
UnemploymentRateLegend = ListLinePlot[ConstantArray[0.1, 100], ColorFunction -> ColorUnemploymentRateLegend, 
   	ColorFunctionScaling -> False, Frame -> True, Axes -> {False, False}, 
   	FrameTicks -> {{None, None}, {{{1, Round[Min[UnemploymentRate], 0.1]}, 
       		{50, Round[Min[UnemploymentRate] + (Max[UnemploymentRate] - Min[UnemploymentRate])/2, 0.1]}, 
       		{100, Round[Max[UnemploymentRate], 0.1]}}, None}}, 
       FrameLabel -> {Style["Unemployment Rate Legend", "ScaleTitle"], None}, 
   	PlotStyle -> Directive[Thickness[1]], ImageSize -> 300, AspectRatio -> 1/15]

RetailSalesTemp = Table[{Blend[{Red, Green}, x]}, {x, 0, 1, 1/100}]; 
RetailSalesSmoothed = ExponentialMovingAverage[ Rescale[MARTS], 1/1];
RetailSalesScaled = Round[99*(( RetailSalesSmoothed - Min[ RetailSalesSmoothed])/(Max[ RetailSalesSmoothed] - Min[ RetailSalesSmoothed])) + 1];

(* Main plot uses KronosRetailIndex as the path and colors it with Federal Reserve IPI *)
WidthRange=.08;
MinWidth=.04;
IPIRelativeRange=Max[Rescale[IPI]]-Min[Rescale[IPI]];
Dimensions[IPIRelativeRange]
IPIRelativeU=Take[Rescale[IPI][[]],54]+((MinWidth*IPIRelativeRange)+((Take[RetailSalesScaled[[]],54]/100)*(WidthRange*IPIRelativeRange)));
IPIRelativeL=Take[Rescale[IPI][[]],54]-((MinWidth*IPIRelativeRange)+((Take[RetailSalesScaled[[]],54]/100)*(WidthRange*IPIRelativeRange)));
lPlotStyle = PlotStyle->Directive[Thickness[.0001],JoinForm["Round"]];
lFrameLabel=FrameLabel->{Style["","AxesTitle"],Style["Industrial Production","AxesTitle"]};
lPlotLabel=PlotLabel-> Style["Industrial Production, Sales, & Unemployment","GraphTitle"];
lFrameTicks =FrameTicks->{{Automatic,None},{{{0,"August 2006"},{5,"January 2007"},{11,"July 2007"},{17,"January 2008"},{23,"July 2008"},{29,"January 2009"},{35,"July 2009"},
	{41,"January 2010"},{47,"July 2010"},{53, "January 2011"}},
	None}};
lColorFunction = ColorFunction->ColorUnemploymentRate;
lEpilog=Epilog->Inset[ UnemploymentRateLegend ,Offset[{-800,-275},Scaled[{1,1}]],{Left,Bottom}];
DateListPlot[{IPIRelativeU,IPIRelativeL},{0,53},InterpolationOrder->3,Filling->{1->{2}},Joined -> True,lFrameLabel,lFrameTicks,lPlotLabel, 
Axes->{False,False}, lColorFunction,ColorFunctionScaling->False,lPlotStyle,ImageSize->900,lEpilog,AspectRatio->1/3]

(* Mathematica Package *)

BeginPackage["rlicharting`"]
(* Exported symbols added here with SymbolName::usage *)  

Begin["`Private`"] (* Begin Private Context *) 

ThermometerLegend[{series_, colorLow_ : Gray, colorHigh_ : Black , 
    label_ : "", smoothness_ : 5 , size_ : 300, aspect__ : 1/15 }] :=
    Module[{lseries = series, lcolorLow = colorLow,
    	lcolorHigh = colorHigh, llabel = label, lsmoothness = smoothness,
    	lsize = size, 
    laspect = aspect},
    Needs["PlotLegends`"];
    thermoColorBlend = 
    Table[{Blend[{lcolorLow, lcolorHigh}, z]}, {z, 0, 1, 1/100}];
   	seriesSmoothed = 
    ExponentialMovingAverage[lseries, (1/lsmoothness)];
   	seriesScaled = 
    	Round[99*((seriesSmoothed - 
        		Min[seriesSmoothed])/(Max[seriesSmoothed] - 
           		Min[seriesSmoothed])) + 1];
   	thermoColorScale  = 
    	Function[{x, y}, thermoColorBlend[[seriesScaled[[Round[x + 1]]]]]];
   	thermoColorFunction = Function[{x, y}, thermoColorBlend[[x]]]; 
   	RLIlegend = 
    	ListLinePlot[ConstantArray[0.1, 100], 
     	ColorFunction -> thermoColorFunction, 
        ColorFunctionScaling -> False, Frame -> True, 
     	Axes -> {False, False}, 
       	FrameTicks -> {{None,None}, 
       		{{{1, Round[Min[inputSeries], 0.1]},50,
       			  Round[Min[inputSeries] 
       			  	+ (Max[inputSeries] 
       			  	- Min[inputSeries])/2,1]},
       			  	{100, Round[Max[inputSeries], 1]}}, None}, 
         FrameLabel -> {Style[llabel, "ScaleTitle"], None}, 
     	PlotStyle -> Directive[Thickness[1]], ImageSize -> lsize, 
     	AspectRatio -> laspect];
   	RLIlegend
   ];
End[] (* End Private Context *)

EndPackage[]