· 6 years ago · Jan 15, 2020, 11:30 PM
1### Sahm's rule in R - by <Mathew.Binkley@Vanderbilt.edu>
2### based on Claudia Sahm's paper at:
3### https://www.hamiltonproject.org/assets/files/Sahm_web_20190506.pdf
4###
5### Sahm's law is a lagging indicator of a recession. It is based on the
6### difference between the three month moving average of unemployment and
7### the lowest unemployment over the last 12 months. If the difference
8### is > 0.5 (at the Federal level), then the US is or is about to be in
9### recession.
10
11### Set your FRED API key here. You may request an API key at:
12### https://research.stlouisfed.org/useraccount/apikeys
13api_key_fred <- "WHATEVER_YOUR_FRED_API_KEY_IS"
14
15### Specifiy the start/end date of the graph. 1948-01-01 is the
16### earliest possible time for UNRATE
17date_start <- "1948-01-01" %>% as.Date()
18date_end <- Sys.Date() %>% as.Date()
19
20####################################################################
21### Load necessary R packages and set the FRED API key
22####################################################################
23packages <- c("fredr", "lubridate", "tidyverse", "tsibble", "TTR")
24
25### Install packages if needed, then load them quietly
26new_packages <- packages[!(packages %in% installed.packages()[, "Package"])]
27if (length(new_packages)) install.packages(new_packages, quiet = TRUE)
28invisible(lapply(packages, "library", quietly = TRUE,
29 character.only = TRUE, warn.conflicts = FALSE))
30
31fredr_set_key(api_key_fred)
32
33####################################################################
34### Add recession bars to ggplot graphs
35####################################################################
36geom_recession_bars <- function (date_start, date_end) {
37
38 date_start <- date_start %>% as.Date(origin = "1970-01-01")
39 date_end <- date_end %>% as.Date(origin = "1970-01-01")
40
41 recessions_tibble <- tibble(
42
43 peak = c("1857-06-01", "1860-10-01", "1865-04-01", "1869-06-01",
44 "1873-10-01", "1882-03-01", "1887-03-01", "1890-07-01",
45 "1893-01-01", "1895-12-01", "1899-06-01", "1902-09-01",
46 "1907-05-01", "1910-01-01", "1913-01-01", "1918-08-01",
47 "1920-01-01", "1923-05-01", "1926-10-01", "1929-08-01",
48 "1937-05-01", "1945-02-01", "1948-11-01", "1953-07-01",
49 "1957-08-01", "1960-04-01", "1969-12-01", "1973-11-01",
50 "1980-01-01", "1981-07-01", "1990-07-01", "2001-03-01",
51 "2007-12-01") %>% as.Date(),
52
53 trough = c("1858-12-01", "1861-06-01", "1867-12-01", "1870-12-01",
54 "1879-03-01", "1885-05-01", "1888-04-01", "1891-05-01",
55 "1894-06-01", "1897-06-01", "1900-12-01", "1904-08-01",
56 "1908-06-01", "1912-01-01", "1914-12-01", "1919-03-01",
57 "1921-07-01", "1924-07-01", "1927-11-01", "1933-03-01",
58 "1938-06-01", "1945-10-01", "1949-10-01", "1954-05-01",
59 "1958-04-01", "1961-02-01", "1970-11-01", "1975-03-01",
60 "1980-07-01", "1982-11-01", "1991-03-01", "2001-11-01",
61 "2009-06-01") %>% as.Date()
62 )
63
64 recessions_trim <- recessions_tibble %>%
65 filter(peak >= min(date_start) & trough <= max(date_end))
66
67 if (nrow(recessions_trim) > 0) {
68 recession_bars = geom_rect(data = recessions_trim,
69 inherit.aes = F,
70 fill = "darkgray",
71 alpha = 0.25,
72 aes(xmin = as.Date(peak, origin="1970-01-01"),
73 xmax = as.Date(trough, origin="1970-01-01"),
74 ymin = -Inf, ymax = +Inf))
75 } else {
76 recession_bars = geom_blank()
77 }
78}
79
80##########################################################################
81### Fetch unemployment data from FRED and calculate Sahm Rule probability
82##########################################################################
83data <- fredr(series_id = "UNRATE", frequency = "m") %>%
84 as_tsibble(index = "date")
85
86date <- data %>% pull("date") %>% as.Date()
87unemployment <- data %>% pull("value")
88
89### Compute the moving average of unemployment over past 3 months
90unemployment_ma <- unemployment %>% SMA(n = 3)
91
92### Compute the minimum unemployment over the past 12 months
93unemployment_min <- vector(length = length(unemployment))
94for (i in (length(unemployment):(1 + 12))) {
95 unemployment_min[i] <- min(unemployment[(i - 13):(i)])
96}
97
98### Compute the difference between the 3 month average
99### and the 12 month minimum unemployment
100sahm_rule <- vector(length = (length(unemployment)))
101for (i in seq_len(length(unemployment))) {
102 sahm_rule[i] <- unemployment_ma[i] - unemployment_min[i]
103}
104
105### Strip off the first 14 months of data since it's junk
106### 2 months come from the 3-month moving average
107### 12 months come from the 12-month minimum window
108sahm_rule <- sahm_rule[(14):(length(sahm_rule))]
109date_diff <- date[(14):(length(date))]
110
111sahm_rule_df <- data.frame(date = date_diff, values = sahm_rule) %>%
112 filter(date >= date_start & date <= date_end)
113
114###################################################################
115### Graph 1: Search results with trend and seasonality
116###################################################################
117c1 <- "U.S. Bureau of Labor Statistics, Unemployment Rate [UNRATE]\n"
118c2 <- "retrieved from FRED, Federal Reserve Bank of St. Louis\n"
119c3 <- "https://fred.stlouisfed.org/series/UNRATE\n"
120c4 <- paste("Data retrieved on", format(Sys.time(), "%B %d, %Y at %I:%M %p %Z"))
121
122title <- "Sahm Rule for the United States"
123subtitle <- "Recessions marked with vertical bars"
124xlab <- "Year"
125ylab <- "Percent"
126caption <- paste(c1, c2, c3, c4)
127
128p <- ggplot(sahm_rule_df, aes(x = date, y = values)) +
129 theme_bw() +
130 theme(legend.position = "none") +
131 geom_line(data = sahm_rule_df, size = 1.3, color = "darkblue",
132 aes(y = sahm_rule, color = "Sahm Rule")) +
133 geom_recession_bars(min(sahm_rule_df$date), max(sahm_rule_df$date)) +
134 geom_hline(yintercept = 0.5, size = 1, linetype = "dotted",
135 color = "darkred", alpha = 0.5) +
136 labs(title = title, subtitle = subtitle, caption = caption,
137 x = xlab, y = ylab)
138print(p)