Fan Charts

Improved version, May 2010

For a reference, see the working paper "Asymmetric Density Functions and the Bank of England's Fan Chart" by Prof.  Ken Wallis of Warwick University.
Note that this implementation shows the median as the central forecast (Professor Wallis' preferred approach) and not the mode, as the Bank of England actually does it.

This version of the notebook allows users to specify the base colours to be used in drawing the fan, and whether the mean, median or mode of the distribution should be used to draw the line in the forecast region.

1. The Two-piece Normal Distribution

Note the use of upvalues. See http://www.bankofengland.co.uk/publications/quarterlybulletin/qb980101.pdf or http://www.riksbank.com/upload/Dokument_riksbank/Kat_publicerat/Artiklar_PV/qr99_2_artikel2.pdf

TwoPieceNormalDistribution/:PDF[TwoPieceNormalDistribution[μ_,σ1_,σ2_],x_]:=With[{A=(2/((Sqrt[2π])(σ1+σ2)))},If[x≤μ,A Exp[-(((x-μ))^2)/2((σ1)^2)],A Exp[-(((x-μ))^2)/2((σ2)^2)]]]

TwoPieceNormalDistribution/:CDF[TwoPieceNormalDistribution[μ_,σ1_,σ2_],x_]:=If[x<μ,((σ1 σ2 (1+Erf[(((x-μ) (Sqrt[((σ1)^2)]))/(Sqrt[2]))]))/((Sqrt[((σ1)^2)]) (σ1+σ2))),((σ1 σ2)/((Sqrt[((σ1)^2)]) (σ1+σ2)))+((σ1 Erf[(((x-μ) σ2)/(Sqrt[2]))])/(σ1+σ2))]

Manipulate[Plot[PDF[TwoPieceNormalDistribution[0.,σ1,σ2],x],{x,-3,3}],{σ1,0.00005,5},{σ2,0,5}]

Manipulate[Plot[CDF[TwoPieceNormalDistribution[0.,σ1,σ2],x],{x,-3,3}],{σ1,0.0001,5},{σ2,0.0001,5}]

TwoPieceNormalDistribution/:Mean[TwoPieceNormalDistribution[μ_,σ1_,σ2_]]:=μ+(Sqrt[(2/π)])(σ2-σ1)

TwoPieceNormalDistribution/:Variance[TwoPieceNormalDistribution[μ_,σ1_,σ2_]]:=(1-(2/π))(((σ2-σ1))^2)+σ1 σ2

TwoPieceNormalDistribution/:Quantile[TwoPieceNormalDistribution[μ_,σ1_,σ2_],q_]/;(q<1 && q>0):=x/.FindRoot[If[x<((σ1 σ2)/((Sqrt[((σ1)^2)]) (σ1+σ2))),((σ1 σ2 (1+Erf[(((x-μ) (Sqrt[((σ1)^2)]))/(Sqrt[2]))]))/((Sqrt[((σ1)^2)]) (σ1+σ2)))-q,((σ1 σ2)/((Sqrt[((σ1)^2)]) (σ1+σ2)))+((σ1 Erf[(((x-μ) σ2)/(Sqrt[2]))])/(σ1+σ2))-q],{x,0.}]

ListPlot[Table[{i,Quantile[TwoPieceNormalDistribution[0,0.5,1.2],i]},{i,0.05,0.95,0.05}] ]

TwoPieceNormalDistribution/:Median[TwoPieceNormalDistribution[μ_,σ1_,σ2_]]:=If[σ2>σ1,σ2 Quantile[NormalDistribution[0,1],1-((σ1+σ2)/(4σ2))]+μ,  Quantile[TwoPieceNormalDistribution[μ,σ1,σ2],0.5]]

TwoPieceNormalDistribution/:Skewness[TwoPieceNormalDistribution[μ_,σ1_,σ2_]]:=(Sqrt[2/π])(σ2-σ1)((2 ((((Sqrt[2/π])))^2)-1)(((σ2-σ1))^2)+σ1 σ2)

Skewness[TwoPieceNormalDistribution[0.,1.2,1.0]]

The Fan Chart

Note: this fan chart is centred on the median, not the mean. So the black area is not going to be in the same place as the μ you specify, because it's the mode. Secondly, the way the Two-piece Normal distribution works, the

Clear[FanChartPlot]

Options[FanChartPlot]={CenterColor->RGBColor[0.,0.,0.],CentralForecast->Mode};

FanChartPlot[dists:{{_Real,_?Positive,_?Positive}..},n_:9,tail_:0.05`,opts___Rule]/;Evaluate[Positive[n]&&Head[n]==Integer&&Positive[tail]&&tail<1.`&&tail>0]:=
Module[{cc=CenterColor/.{opts}/.Options[FanChartPlot],cf= CentralForecast/.{opts}/.Options[FanChartPlot],𝕋=Length[dists],colors,quantilepoints,distdefs,points,fillingrules},colors=Reverse@Table[Lighter[cc,i],{i,0.1`,0.9`,((0.8`)/(n-1))}];quantilepoints=Reverse@Table[{0.5`-α,0.5`+α},{α,((0.5`-0.5` tail)/n),0.5`-0.5` tail,((0.5`-0.5` tail)/n)}];distdefs=Apply[TwoPieceNormalDistribution,dists,{1}];points=Join@@Map[MapThread[Quantile,{distdefs,Table[#1,{𝕋}]}]&,quantilepoints,{2}];
fillingrules=Table[{i->{{i+1},colors[[i/2]]}},{i,2,2n,2}];
ListLinePlot[Join[{Switch[cf,Mode,First/@dists,Mean,Mean/@distdefs,Median,Median/@distdefs]},points],Filling->fillingrules,PlotStyle->Join[{Directive[Black,Thick]},Table[None,{2 n}]],Sequence@@FilterRules[Flatten[{opts}],Options[Graphics]]]]

FanChartPlot[data:{___Real,{_Real,_?Positive,_?Positive}..},n_:9,tail_:0.05`,opts___Rule]/;Evaluate[Positive[n]&&Head[n]==Integer&&Positive[tail]&&tail<1.`&&tail>0]:=
Module[{cc=CenterColor/.{opts}/.Options[FanChartPlot],cf= CentralForecast/.{opts}/.Options[FanChartPlot],histdata,dists,𝕋,colors,quantilepoints,distdefs,points,fillingrules},

{histdata,dists}=SplitBy[data,Head];𝕋=Length[dists];
colors=Reverse@Table[Lighter[cc,i],{i,0.1`,0.9`,((0.8`)/(n-1))}];quantilepoints=Reverse@Table[{0.5`-α,0.5`+α},{α,((0.5`-0.5` tail)/n),0.5`-0.5` tail,((0.5`-0.5` tail)/n)}];distdefs=Apply[TwoPieceNormalDistribution,dists,{1}];points=Join@@Map[MapThread[Quantile,{distdefs,Table[#1,{𝕋}]}]&,quantilepoints,{2}];
fillingrules=Table[{i->{{i+1},colors[[i/2]]}},{i,2,2n,2}];
ListLinePlot[Join[histdata,#]&/@Join[{Switch[cf,Mode,First/@dists,Mean,Mean/@distdefs,Median,Median/@distdefs]},points],Filling->fillingrules,PlotStyle->Join[{Directive[Black,Thick]},Table[None,{2 n}]],Sequence@@FilterRules[Flatten[{opts}],Options[Graphics]]]]

forecast={{1.,0.8,0.6},{2.,0.6,0.5},{0.1,0.8,0.4},{-0.2,0.3,0.4},{-0.4,0.28,0.35}};

FanChartPlot[forecast,8,0.05,Frame->True,CenterColor->Darker@Green]

FanChartPlot[forecast,8,0.05,Frame->True,CenterColor->Darker@Green,CentralForecast->Median]

FanChartPlot[forecast,8,0.05,Frame->True,CenterColor->Darker@Red,CentralForecast->Mean]

forecast2={2.,1.8,1.6,{1.,0.8,0.6},{2.,0.6,0.5},{0.1,0.8,0.4},{-0.2,0.3,0.4},{-0.4,0.28,0.35}};

FanChartPlot[forecast2,8,0.05,Frame->True,CenterColor->RGBColor[0.2,0,0.9],PlotRange->All]