2018/05/04

dataviz / R / economy

TODAY WAS JOBS FRIDAY. LET’s create a couple plots to show the trend in employment growth.

Each month the U.S. Bureau of Labor Statistics (BLS) releases its employment situation report. Let’s make a couple plots looking at trends in U.S. nonfarm payrolls.

Per usual, let’s make a graph with R.

Data

We can easily get the data via the Saint Louis Federal Reserve’s FRED database. If you followed my post from back in April of last year you know what we can do if we combine FRED with the quantmod package. It gets even easier if we use tidyquant like we did here.

In the United States, the National Bureau of Economic Research (NBER) dates expansions and recessions. See for example http://www.nber.org/cycles.html for a list of dates. We’ll use those dates like we did earlier.

#####################################################################################
## Load libraries ----
#####################################################################################
library(tidyquant)
library(sqldf)
library(ggridges)
library(data.table)

#####################################################################################
## Get employment data from FRED ----
#####################################################################################

df<- tq_get("PAYEMS",get="economic.data",from="1948-01-01") %>%
  mutate(jg=c(NA,diff(price))) # add monthly change


#####################################################################################
## Make Recession Data Frame ----
#####################################################################################

recessions.df = read.table(textConnection(
  "Peak, Trough
  1857-06-01, 1858-12-01
  1860-10-01, 1861-06-01
  1865-04-01, 1867-12-01
  1869-06-01, 1870-12-01
  1873-10-01, 1879-03-01
  1882-03-01, 1885-05-01
  1887-03-01, 1888-04-01
  1890-07-01, 1891-05-01
  1893-01-01, 1894-06-01
  1895-12-01, 1897-06-01
  1899-06-01, 1900-12-01
  1902-09-01, 1904-08-01
  1907-05-01, 1908-06-01
  1910-01-01, 1912-01-01
  1913-01-01, 1914-12-01
  1918-08-01, 1919-03-01
  1920-01-01, 1921-07-01
  1923-05-01, 1924-07-01
  1926-10-01, 1927-11-01
  1929-08-01, 1933-03-01
  1937-05-01, 1938-06-01
  1945-02-01, 1945-10-01
  1948-11-01, 1949-10-01
  1953-07-01, 1954-05-01
  1957-08-01, 1958-04-01
  1960-04-01, 1961-02-01
  1969-12-01, 1970-11-01
  1973-11-01, 1975-03-01
  1980-01-01, 1980-07-01
  1981-07-01, 1982-11-01
  1990-07-01, 1991-03-01
  2001-03-01, 2001-11-01
  2007-12-01, 2009-06-01
  2018-04-02, 2100-01-01"), sep=',',
  colClasses=c('Date', 'Date'), header=TRUE)


rdf <- recessions.df %>% 
  mutate(TroughLag  = lag(Trough),  # find last trough
         PeakLag    = lag(Peak)      # find last peak
  )

# Merge with sqldf
output <- sqldf("select * from df left join rdf
                on  (df.date>=rdf.Peak and df.date <= rdf.Trough or
                (df.date > rdf.TroughLag and df.date <= rdf.Peak)) ")

outdf <- mutate(output,
                expand=ifelse(date>=Peak, "Recession","Expansion"),
                d1=as.Date(ifelse(expand=="Recession",Peak, TroughLag %m+% months(1))),
                d2=as.Date(ifelse(expand=="Recession",Trough, Peak %m-% months(1)))) %>%
  mutate(name=paste0(expand, " ",
                     as.character(d1, format="%b %Y"), " : ",
                     as.character(d2, format="%b %Y")
  )) %>%
  # relabel the last row to say :present
  mutate(name=ifelse(name=="Expansion Jul 2009 : Mar 2018",
                     "Expansion Jul 2009 : Present", name)) %>%
  mutate(contraction = interval(Peak, Trough) %/% months(1),       # Peak to Trough
         expansion   = interval(TroughLag, Peak) %/% months(1),    # Previous Trough to this Peak
         cycle1      = interval(TroughLag, Trough) %/% months(1),  # Trough from previous Trough
         cycle2      = interval(PeakLag, Peak) %/% months(1))      # Peak from previous Peak

Now we can make our first plot:

#####################################################################################
## Make ridges Plot ----
#####################################################################################
ggplot(data = outdf %>% filter(!is.na(expand) & date>="1948-11-01" ),
       aes(x=jg,
           y=fct_reorder(name,date),  
           label=name,

           fill=expand,
           color=expand))+
  scale_fill_manual(name="Expansion or Recession", values= c("#4575b4", "#d73027"))+
  scale_color_manual(name="Expansion or Recession", values= c("#4575b4", "#d73027"))+
  scale_discrete_manual(name="Expansion or Recession",aesthetics = "point_color", values = c("#4575b4", "#d73027"))+
  #scale_color_manual(name="Expansion or Recession", values= c("#4575b4", "#d73027"), aesthetics=c("fill","point_color"))+
  geom_density_ridges(aes(point_color=expand),
                      rel_min_height=0.01,
                      #point_color="royalblue",
                      scale=0.9,
                      jittered_points = TRUE, position = "raincloud", alpha=0.5)  +

  
  theme_ridges(font_size=20)+
  theme(legend.position="top",
        plot.caption=element_text(hjust=0,size=12)  )+

    labs(x="Nonfarm payroll monthly change (1000s)",y="Expansion or recession",
       title="Expansions Expand, Recessions Contract",
       subtitle="Job growth in U.S. Expansions and Recesssions\n",
       caption="@lenkiefer Source: U.S. Bureau of Labor Statistics All Employees: Total Nonfarm Payrolls [PAYEMS],\nretrieved from FRED, Federal Reserve Bank of St. Louis; https://fred.stlouisfed.org/series/PAYEMS, May 4, 2018. NBER recession dates")

How does the current expansion stack up in terms of the number of consecutive months of job gains? Using the tip from this Stack Overflow answer, we can easily compute the number of consecutive months of positive job gains.

This chart is kind of fun. It sort of looks like a gruesome accident at the Stegosaurus farm.

#####################################################################################
## Stegosaurus chart ----
#####################################################################################

# uses 
#https://stackoverflow.com/questions/19998836/r-count-consecutive-occurrences-of-values-in-a-single-column

library(data.table)
dt<-data.table(outdf)[,trend:=sign(jg)][, counter := seq_len(.N), by=rleid(trend)][
  ,trend:=ifelse(jg>=0,">=0","<0")
]



ggplot(data=dt, aes(x=date, y=(counter)*sign(jg),
                    color=trend,
                    fill=trend))+
  geom_area(alpha=0.5, color=NA)+geom_line()+
  theme_minimal(base_size=20)+
  scale_color_manual(name="Employment Trend m/m changes", values= c("#d73027","#4575b4" ))+
  scale_fill_manual(name="Employment Trend m/m changes", values= c("#d73027","#4575b4"))+
  #geom_rug(sides='b')+
  guides(color=F)+
  theme(legend.position="top",
        plot.caption=element_text(hjust=0,size=12))+
  geom_hline(yintercept=0,linetype=2)+
  labs(x="date", y="Consecutive months of positive/negative employment growth",
       title="U.S. job growth trends",
       subtitle="Consecutive months of job gains/losses",
       caption="@lenkiefer Source: U.S. Bureau of Labor Statistics All Employees: Total Nonfarm Payrolls [PAYEMS],\nretrieved from FRED, Federal Reserve Bank of St. Louis; https://fred.stlouisfed.org/series/PAYEMS, May 4, 2018. NBER recession dates")+
  geom_text(data= dt[date==max(dt$date),], aes(label=paste0(as.character(date,"%B %Y"),":\n",counter," months\n")), fontface="bold")

Jobs Friday May 2018

A gruesome accident at the Stegosaurus farm? No, a chart of consecutive job gains?

Data

Share!