Business cycle tools

Luci Ellis
Reserve Bank of Australia and Australian National University
 elisha@dot.net.au

Finding peaks in data

Clear[findPeaks]

findPeaks::usage = "findPeaks[data,consec] finds the points in data \
that are an increase from the previous point, and following which there are \
consec consecutive declines. This function can be used to identify recessions \
in macroeconomic data. The parameter consec is optional. If omitted, it takes \
the value 2. findPeaks[data,{consecups,consecdowns}] finds the points in data \
that complete a sequence of consecups consecutive rises and following which \
there are consecdowns consecutive falls."

Options[findPeaks] = {DataInLevels -> True};

findPeaks[data : {__?NumericQ}, consec_:  2, 
          opts___Rule] /;  (Head[consec] == Integer && 
            Length[data] > 4  &&  consec > 0  && 
            Length[data] > 
              consec + 2) := 
Module[{difffirst, ddata,  
          nested,  negtest, 
          posns},  
difffirst  =  DataInLevels /. {opts} /. Options[findPeaks]; 
ddata = 
          If[difffirst, ListCorrelate[{-1, 1}, data], data];   (* 
          differencing data if required *) 
nested = 
          Transpose[ Drop[#, -consec] &  /@  (RotateRight[
                      ddata, #] &  /@  
                  Range[consec - 
                      1, -1, -1])]; 
negtest = 
          Join[{_?Positive}, 
            Table[_?Negative, {consec}]]; 
posns = 
          Cases[Flatten[
                Position[nested, negtest, {1}, 
                  Heads -> False]] - (consec - 
                  If[difffirst, 2, 1]), _?
              Positive]; 
Transpose[{data[[posns]], posns}]]

findPeaks[
          data : {__?NumericQ}, {consecups_Integer?Positive, 
            consecdowns_Integer?Positive}, 
          opts___Rule] /;  (Length[data] > 4   && 
            Length[data] > 
              consecups + consecdowns + 
                2) := 
Module[{difffirst, ddata,  
          nested,  negtest, 
          posns},  
difffirst  =  DataInLevels /. {opts} /. Options[findPeaks]; 
ddata = 
          If[difffirst, ListCorrelate[{-1, 1}, data], data];   (* 
          differencing data if required *) 
nested = 
          Transpose[ Drop[#, -consecups - 
                    consecdowns] &  /@  (RotateRight[
                      ddata, #] &  /@  
                  Range[consecdowns - 
                      1, -consecups, -1])]; 
negtest = 
          Join[Table[_?Positive, {consecups}], 
            Table[_?Negative, {consecdowns}]]; 
posns = 
          Cases[Flatten[
                Position[nested, negtest, {1}, Heads -> False]] + 
              consecups - 1 - (+consecdowns - If[difffirst, 2, 1]), _?
              Positive]; 
Transpose[{data[[posns]], posns}]]

Error cases

findPeaks::negcon = "The second parameter to this function must be \
positive."

findPeaks::conlen  =  "The number of consecutive falls to be found \
`1` is larger than the length of the data series, `2`."

findPeaks[data : {__?NumericQ}, consec_, opts___Rule] /; consec < 1 := 
      Message[findPeaks::negcon]

findPeaks[data : {__?NumericQ}, consec_, 
          opts___Rule] /; (consec + 2) > Length[data] := 
      Message[findPeaks::conlen, consec, Length[data]]

Demonstration

testdata = 
        NestList[# 0.95  - 0.5  + Random[] &, 0.3, 200];

Show[
      ListPlot[Reverse /@  findPeaks[testdata, 3], Frame -> True, 
        PlotStyle -> {Hue[0], AbsolutePointSize[6]}, 
        DisplayFunction -> Identity], 
      ListPlot[testdata, PlotJoined -> True, 
        DisplayFunction -> Identity], 
      DisplayFunction -> $DisplayFunction]

Assymmetric smoothing

Reference: Julian Allwood and  David Shepherd (1999), "Alternative Detrending Procedures for Macroeconomic Time Series", University of Melbourne Department of Economics Research Paper Number 698, June 1999

Needs["NumericalMath`SplineFit`"]

assymetricDetrending[data : {__?NumericQ}, 
          consec_Integer?Positive] /; ( 
          Head[consec] == Integer && Length[data] > 4  &&  
            consec > 0  && 
            Length[data] > consec + 2) := 
With[{points = 
            findPeaks[data, consec]}, SplineFit[points, Cubic]]

assymetricDetrending[
          data : {__?NumericQ}, {consecups_Integer?Positive, 
            consecdowns_Integer?Positive}]  /; ( 
          Length[data] > 4  && 
            Length[data] > 
              consecups  + consecdowns + 
                2) := 
With[{points = 
            findPeaks[data, {consecups, consecdowns}]}, 
        SplineFit[points, Cubic]]

Demonstration

assDTtest = assymetricDetrending[testdata, 2]

Note that you different time series result in SplineFunctions with different ranges, so you may have to tweak the number in blue in the next cell.

Show[ListPlot[Reverse /@  findPeaks[testdata, 2], 
          PlotStyle -> {Hue[0], AbsolutePointSize[6]}, 
          DisplayFunction -> Identity],ListPlot[testdata, PlotJoined -> True, 
          DisplayFunction -> Identity],ListPlot[Reverse/@Table[assDTtest[x],{x,0,21,0.2}],PlotJoined -> True,PlotStyle -> Hue[0.6],DisplayFunction -> Identity],DisplayFunction -> $DisplayFunction]

This suggests a further possible function:

plotAssymetricDetrendedData[data : {__?NumericQ}, 
          consec_:  Integer] /; ( 
          Head[consec] == Integer && Length[data] > 4  &&  
            consec > 0  && 
            Length[data] > 
              consec + 2) := 
With[{spliner = 
            assymetricDetrending[data, consec], 
          dots = Reverse /@  findPeaks[data, consec], 
          T = Length[data]}, 
With[{splinedots = 
              Reverse /@ 
                Table[spliner[x], 
                  Evaluate[
                    Join[{x}, 
                      spliner[[2]], {spliner[[2, 2]]/
                          T}]]]}, 
Show[
            ListPlot[dots, PlotStyle -> {Hue[0], AbsolutePointSize[6]}, 
              Frame -> True, DisplayFunction -> Identity], 
            ListPlot[data, PlotJoined -> True, Frame -> True, 
              DisplayFunction -> Identity], 
            ListPlot[splinedots, PlotJoined -> True, 
              PlotStyle -> Hue[0.6], Frame -> True, 
              DisplayFunction -> Identity], 
            DisplayFunction -> $DisplayFunction] ]]

plotAssymetricDetrendedData[
          data : {__?NumericQ}, {consecups_Integer?Positive, 
            consecdowns_Integer?Positive}] /; ( 
          Length[data] > 4  &&  
            Length[data] > 
              consecups + consecdowns + 
                2) := 
With[{spliner = 
            assymetricDetrending[data, {consecups, consecdowns}], 
          dots = Reverse /@  findPeaks[data, {consecups, consecdowns}], 
          T = Length[data]}, 
With[{splinedots = 
              Reverse /@ 
                Table[spliner[x], 
                  Evaluate[
                    Join[{x}, 
                      spliner[[2]], {spliner[[2, 2]]/
                          T}]]]}, 
Show[
            ListPlot[dots, PlotStyle -> {Hue[0], AbsolutePointSize[6]}, 
              Frame -> True, DisplayFunction -> Identity], 
            ListPlot[data, PlotJoined -> True, Frame -> True, 
              DisplayFunction -> Identity], 
            ListPlot[splinedots, PlotJoined -> True, 
              PlotStyle -> Hue[0.6], Frame -> True, 
              DisplayFunction -> Identity], 
            DisplayFunction -> $DisplayFunction] ]]

plotAssymetricDetrendedData[testdata, {2, 2}] // Timing