Reproducible Finance with R on R Views

State Unemployment Claims

Thu, 16 Apr 2020 00:00:00 +0000

In today’s Reproducible Finance post, we will explore state-level unemployment claims which get released every Thursday. The last few weeks have shown huge spikes in those claims, of course, due to the coronavirus and statewide lockdown orders, and it got me wondering how these times will look to data scientists in the future.

Let’s start by importing unemployment insurance claims data for Georgia. This is a data series that’s reported by all 50 states.

We can grab this data from FRED using tq_get() from the tidyquant package. The FRED code for Georgia unemployment claims is GAICLAIMS.

ga_claims <- 
  "GAICLAIMS" %>% 
  tq_get(get = "economic.data", 
         from = "1999-01-01") %>% 
  rename(claims = price) 

ga_claims %>% 
  slice(1, n())

# A tibble: 2 x 2
  date       claims
  <date>      <int>
1 1999-01-02   9674
2 2020-04-11 319581

For now, a quick visualization reveals what looks like a season pattern, with regular spikes in unemployment claims.

(
ga_claims %>% 
  ggplot(aes(x = date, y = claims)) +
  geom_line(color = "cornflowerblue")  +
  labs(
    x = "",
    y = "",
    title = "Georgia Unemployment Claims",
    subtitle = str_glue("{min(ga_claims$date)} through {max(ga_claims$date)}")
  ) +
  theme_minimal() +
  scale_y_continuous(labels = scales::comma)
) %>% ggplotly()

Let’s investigate this a bit further and look for a trend in average monthly claims by creating a series of faceted density plots. Notice how we can use str_glue() to pass in the dates for the subtitle, a nice trick learned from a Business Science Learning Lab that I use in almost all my plots now, either for titles, subtitles or hover text in plotly.

ga_claims %>%
  mutate(
    year = year(date),
    month =  month(date, label = T, abbr  = T),
    week = week(date)
  ) %>%
  group_by(year, month) %>%
  filter(n() >= 4) %>% 
  summarise(avg_claims = mean(claims)) %>%
  ggplot(aes(x = avg_claims)) +
  geom_density(aes(fill = as_factor(month))) +
  facet_grid(rows = vars(as_factor(month))) +
  guides(fill = guide_legend(title = "")) +
  labs(
    title = "Distribution of Avg Monthly Claims",
    subtitle = str_glue("{min(ga_claims$date)} through {max(ga_claims$date)}"),
    y = "",
    x = ""
  ) +
  theme(axis.text.y = element_blank(),
        axis.ticks.y = element_blank()) +
  scale_x_continuous(labels = scales::comma)

January and December appear to have the density distribution most skewed to the right, meaning those months that have tended to show the highest number of unemployment claims.

Now let’s build a heat map to investigate months by year.

We’ll first create a column to hold the year and month for each observation.

ga_claims %>% 
  mutate(year = year(date),
         month=  month(date, label = T, abbr  = T)) %>% 
  head()

# A tibble: 6 x 4
  date       claims  year month
  <date>      <int> <dbl> <ord>
1 1999-01-02   9674  1999 Jan  
2 1999-01-09  19455  1999 Jan  
3 1999-01-16  20506  1999 Jan  
4 1999-01-23  12932  1999 Jan  
5 1999-01-30  10871  1999 Jan  
6 1999-02-06   7997  1999 Feb

Next, we calculate the average number of claims for each month of each year. We start with a group_by(year, month) before a call to summarise().

ga_claims %>% 
  mutate(year = year(date),
         month=  month(date, label = T, abbr  = T)) %>%
  group_by(year, month) %>%
  summarise(avg_claims = mean(claims)) %>% 
  head()

# A tibble: 6 x 3
# Groups:   year [1]
   year month avg_claims
  <dbl> <ord>      <dbl>
1  1999 Jan       14688.
2  1999 Feb        7871.
3  1999 Mar        6095.
4  1999 Apr        6522.
5  1999 May        5451.
6  1999 Jun        5987.

That’s the data we want to chart but I want to add one more column with a slightly different format, one that uses a k for the thousands place, so we can stick these numbers into a chart. That is, instead of 14687.60, I’d like to display 14.7K.

We can use the number_format() function from the scales package to accomplish this. We set the accuracy to .1 to indicate that we want to round off and show the .1 decimal. We set scale to 1/1000 to indicate the scaling factor and choose k as the suffix.

ga_claims %>%
  mutate(year = year(date),
         month =  month(date, label = T, abbr  = T)) %>%
  group_by(year, month) %>% 
  summarise(avg_claims = mean(claims)) %>%
  mutate(
    avg_claims_labels = scales::number_format(
      accuracy = .1,
      scale = 1 / 1000,
      suffix = "k",
      big.mark = ","
    )(avg_claims)
  ) %>%
  head()

# A tibble: 6 x 4
# Groups:   year [1]
   year month avg_claims avg_claims_labels
  <dbl> <ord>      <dbl> <chr>            
1  1999 Jan       14688. 14.7k            
2  1999 Feb        7871. 7.9k             
3  1999 Mar        6095. 6.1k             
4  1999 Apr        6522. 6.5k             
5  1999 May        5451. 5.5k             
6  1999 Jun        5987. 6.0k

I called the new column avg_claims_labels because it’s a character column for display on the chart, not for any numerical use.

Here’s a first crack at the heat map. I’m going to put the months on the x-axis and years on the y-axis, and I want to fill according to avg_claims. Next we add a geom_tile().

ga_claims %>%
  mutate(year = year(date),
         month =  month(date, label = T, abbr  = T)) %>%
  group_by(year, month) %>%
  filter(n() >= 4) %>% 
  summarise(avg_claims = mean(claims)) %>%
  mutate(
    avg_claims_labels = scales::number_format(
      accuracy = 1,
      scale = 1 / 1000,
      suffix = "k",
      big.mark = ","
    )(avg_claims)
  ) %>%
  ggplot(aes(
    x = month,
    y = year,
    fill = avg_claims,
    label = avg_claims_labels
  )) +
  geom_tile()

That gives us a sense that January has been the worst month in most years, and that 2009 was no picnic coming off the financial crisis. Let’s do a bit more cleanup by adding
color = "white", size = .8, aes(height = 1) to geom_tile().

ga_claims %>%
  mutate(year = year(date),
         month =  month(date, label = T, abbr  = T)) %>%
  group_by(year, month) %>%
  filter(n() >= 4) %>% 
  summarise(avg_claims = mean(claims)) %>%
  mutate(
    avg_claims_labels = scales::number_format(
      accuracy = 1,
      scale = 1 / 1000,
      suffix = "k",
      big.mark = ","
    )(avg_claims)
  ) %>%
  ggplot(aes(
    x = month,
    y = year,
    fill = avg_claims,
    label = avg_claims_labels
  )) +
  geom_tile(color = "white", size = .8, aes(height = 1))

We’re not done yet! I don’t love the shades of blue contrast here as it doesn’t really hammer home how bad a month March of 2020 was (Did your eye even get drawn to it? Mine didn’t initially), and we have not made use of our labels created with number_format().

Let’s add our own fill colors with scale_fill_gradient(low = "blue", high = "red", labels = scales::comma). If you’re wondering why I included labels = scales::comma when creating a gradient, it’s because I want the commas to show up in the legend.

We add our text labels with geom_text(), which picks up our lable = avg_claims_labels aesthetic. Let’s also add a text() aesthetic with str_glue() and pass the object to ggplotly() for interactivity.

(
  ga_claims %>%
    mutate(
      year = year(date),
      month =  month(date, label = T, abbr  = T)
    ) %>%
    group_by(year, month) %>%
    filter(n() >= 4) %>% 
    summarise(avg_claims = mean(claims)) %>%
    mutate(
      avg_claims_labels = scales::number_format(
        accuracy = 1,
        scale = 1 / 1000,
        suffix = "k",
        big.mark = ","
      )(avg_claims)
    ) %>%
    ggplot(
      aes(
        x = month,
        y = year,
        fill = avg_claims,
        label = avg_claims_labels,
        text = str_glue("average claims:
                        {scales::comma(avg_claims)}")
      )
    ) +
    geom_tile(color = "white", size = .8, aes(height = 1)) +
    scale_fill_gradient(
      low = "blue",
      high = "red",
      labels = scales::comma
    ) +
    geom_text(color = "white" , size = 3.5) +
    theme_minimal() +
    theme(
      plot.caption = element_text(hjust = 0),
      panel.grid.major.y = element_blank(),
      legend.key.width = unit(1, "cm"),
      panel.grid = element_blank()
    ) +
    labs(
      y  = "",
      title = "Heatmap of Monthly Avg Unemployment Insurance Claims",
      fill = "Avg Claims",
      x = ""
    ) +
    scale_y_continuous(breaks =  scales::pretty_breaks(n = 18))
) %>% ggplotly(tooltip = "text")

We can see that January is a terrible month, but March of 2020 is the worst month we’ve had in 20 years (though note I’m not adjusting for population growth in Georgia). We can use that hover text to embed whatever data we wish - for me, the magic of str_glue() has been a game changer.

We have done some work on monthly averages, but our recent experience might motivate us to dig in at the weekly level. For example, in each year since 1999, what has been the worst week of the year for unemployment claims? In the chart below, we’ll grab the worst week for each year, plotting it as a column whose height is equal to the number of claims, and coloring it by month.

(
  ga_claims %>%
    mutate(
      month = month(date, label = TRUE, abbr = FALSE),
      year = year(date)
    ) %>%
    group_by(year) %>%
    mutate(
      max_claims = max(claims),
      max_week_color = case_when(claims == max_claims ~ as.character(date),
                                 TRUE ~ "NA")
    ) %>%
    filter(max_week_color != "NA") %>%
    ggplot(aes(
      x = max_week_color,
      y = claims,
      fill = month,
      text = str_glue("{date}
                      claims: {scales::comma(claims)}")
    )) +
    geom_col(width = .5) +
    labs(
      x = "",
      title = str_glue("Highest Unemployment Claims Week, by Year
                                in Georgia"),
      y = ""
    ) +
    scale_y_continuous(
      labels = scales::comma,
      limits = c(0, NA),
      breaks = scales::pretty_breaks(n = 6)
    ) +
    scale_fill_brewer(palette = "Dark2") +
    theme_minimal() +
    theme(
      axis.text.x = element_text(angle = 45),
      plot.title = element_text(hjust = .5)
    )
) %>% ggplotly(tooltip = "text")

2020 is the only year in which we see a month other than January or December as the worst week of the year. That surprised me, as I thought we might see unusual behavior during the Global Financial Crisis that spanned roughly mid-2007 to early-2009. Here’s a chart of that period, with the worst unemployment claims of each month displayed.

(
  ga_claims %>%
    mutate(
      month = month(date, label = TRUE, abbr = FALSE),
      year = year(date)
    ) %>%
    filter(between(
      date, ymd("2007-05-01"), ymd("2009-05-01")
    )) %>%
    group_by(year, month) %>%
    mutate(
      max_claims = max(claims),
      max_week_color = case_when(claims == max_claims ~ as.character(date),
                                 TRUE ~ "NA")
    ) %>%
    filter(max_week_color != "NA") %>%
    ggplot(aes(
      x = max_week_color,
      y = claims,
      fill = month,
      text = str_glue("{date}
                      claims: {scales::comma(claims)}")
    )) +
    geom_col(width = .5) +
    labs(
      x = "",
      title = str_glue("Worst Unemployment Claims Week of Each Month
                                mid-2007 to mid-2009"),
      y = "",
      fill = ""
    ) +
    scale_y_continuous(
      labels = scales::comma,
      limits = c(0, NA),
      breaks = scales::pretty_breaks(n = 6)
    ) +
    theme_minimal() +
    theme(
      axis.text.x = element_text(angle = 45),
      plot.title  = element_text(hjust = .5)
    )
) %>% ggplotly(tooltip = "text")

The worst weeks during this period were December and January of 2008 and 2009, with 35,000 and 41,000 claims. As if we needed more evidence, we are currently living strange times, here’s that same chart for the last 2 years.

(
  ga_claims %>%
    mutate(
      month = month(date, label = TRUE, abbr = FALSE),
      year = year(date)
    ) %>%
    filter(between(
      date, ymd("2018-04-01"), ymd("2020-05-01")
    )) %>%
    group_by(year, month) %>%
    mutate(
      max_claims = max(claims),
      max_week_color = case_when(claims == max_claims ~ as.character(date),
                                 TRUE ~ "NA")
    ) %>%
    filter(max_week_color != "NA") %>%
    ggplot(aes(
      x = max_week_color,
      y = claims,
      fill = month,
      text = str_glue("{date}
                      claims: {scales::comma(claims)}")
    )) +
    geom_col(width = .5) +
    labs(
      x = "",
      title = str_glue("Worst Unemployment Claims Week of Each Month
                                mid-2018 to mid-2020"),
      y = "",
      fill = ""
    ) +
    scale_y_continuous(
      labels = scales::comma,
      limits = c(0, NA),
      breaks = scales::pretty_breaks(n = 6)
    ) +
    theme_minimal() +
    theme(
      axis.text.x = element_text(angle = 45),
      plot.title  = element_text(hjust = .5)
    )
) %>% ggplotly(tooltip = "text")

The last week of March 2020 comes in at 133,000 claims for Georgia, a number we never even got close to approaching during the financial crisis. And the first week of April is at 390,000.

If we like some of these visualizations, we can expand our analysis out to all 50 states.

Just as Georgia’s data is available from FRED using the code GAICLAIMS, any state’s data can be access with the state’s abbreviation appended to ICLAIMS. Luckily, the core R datasets package comes with a data set of abbreviations called state.abb.

datasets::state.abb %>% 
  head()

[1] "AL" "AK" "AZ" "AR" "CA" "CO"

We want to write a function that loops through these 50 abbreviations, pulls data from FRED for each state and saves them as a tibble. We can use str_glue() inside a custom function and map_dfr as the looping engine to accomplish this.

First, let’s create the function and just test the creation of the FRED code.

all_state_claims_importer <- function(state_abbreviation){
  fred_code <- str_glue("{state_abbreviation}ICLAIMS")
  
  fred_code %>% 
    tibble()
}

all_state_claims_importer("GA")

# A tibble: 1 x 1
  .        
  <glue>   
1 GAICLAIMS

What happens when we apply this to the state.abb data set.

map_dfr(state.abb, all_state_claims_importer) %>% 
  head()

# A tibble: 6 x 1
  .        
  <chr>    
1 ALICLAIMS
2 AKICLAIMS
3 AZICLAIMS
4 ARICLAIMS
5 CAICLAIMS
6 COICLAIMS

We get the FRED code for all fifty states.

The hard part is done. Now we pass those codes to tq_get(), and use map_dfr() to iteratively pass each abbreviation to FRED. the _dfr will bind our results together, row wise, into a `tibble.

all_state_claims_importer <- function(state_abbrevation) {
  fred_code <- str_glue("{state_abbrevation}ICLAIMS")
  
  fred_code %>%
    tq_get(get = "economic.data",
           from = "1999-01-01") %>%
    mutate(state = state_abbrevation) %>%
    rename(claims = price) %>%
    select(date, state, claims)
}

all_state_claims_tibble <-
map_dfr(state.abb, all_state_claims_importer) 


all_state_claims_tibble %>% 
  group_by(state) %>% 
  slice(1, n())

# A tibble: 100 x 3
# Groups:   state [50]
   date       state claims
   <date>     <chr>  <int>
 1 1999-01-02 AK      2234
 2 2020-04-11 AK     12007
 3 1999-01-02 AL      9899
 4 2020-04-11 AL     77515
 5 1999-01-02 AR      9477
 6 2020-04-11 AR     35629
 7 1999-01-02 AZ      1534
 8 2020-04-11 AZ     98531
 9 1999-01-02 CA     47297
10 2020-04-11 CA    655472
# … with 90 more rows

We can recreate any of those previous visualizations for the state of our choice, by using filter(state == "state of choice"). Let’s take a look at one of the charts for Florida.

(
  all_state_claims_tibble %>%
    filter(state == "FL") %>%
    mutate(
      month = month(date, label = TRUE, abbr = FALSE),
      year = year(date)
    ) %>%
    group_by(year) %>%
    mutate(
      max_claims = max(claims),
      max_week_color = case_when(claims == max_claims ~ as.character(date),
                                 TRUE ~ "NA")
    ) %>%
    filter(max_week_color != "NA") %>%
    ggplot(aes(
      x = max_week_color,
      y = claims,
      fill = month,
      text = str_glue("{date}
                      claims: {scales::comma(claims)}")
    )) +
    geom_col(width = .5) +
    labs(
      x = "",
      title = str_glue("Highest Unemployment Claims Week, by Year
                                in Florida"),
      y = ""
    ) +
    scale_y_continuous(
      labels = scales::comma,
      limits = c(0, NA),
      breaks = scales::pretty_breaks(n = 6)
    ) +
    scale_fill_brewer(palette = "Dark2") +
    theme_minimal() +
    theme(
      axis.text.x = element_text(angle = 45),
      plot.title = element_text(hjust = .5)
    )
) %>% ggplotly(tooltip = "text")

Interesting to see that Florida does not display that same concentration of high unemployment weeks in January. July is the month that most frequently has the worst week for unemployment claims. I imagine that’s because summer is the big tourist season in Florida and things start to slow down after July. Whatever the explanation, this has some big implications as we hopefully emerge from our crisis. We can imagine Georgia and Florida having very different recovery paths as we are already approaching what is traditionally Florida’s big tourist season. Summer in Georgia is not the same as summer in Florida when it comes to employment trends.

Let’s end on a more positive note and examine the months in Florida when claims are at their lowest, which is the most positive for the employment situation. We can tweak the code flow above by replacing max with min in a few places.

(
  all_state_claims_tibble %>%
    filter(state == "FL") %>%
    mutate(
      month = month(date, label = TRUE, abbr = FALSE),
      year = year(date)
    ) %>%
    group_by(year) %>%
    mutate(
      min_claims = min(claims),
      min_week_color = case_when(claims == min_claims ~ as.character(date),
                                 TRUE ~ "NA")
    ) %>%
    filter(min_week_color != "NA") %>%
    ggplot(aes(
      x = min_week_color,
      y = claims,
      fill = month,
      text = str_glue("{date}
                      claims: {scales::comma(round(claims, digits = 0))}")
    )) +
    geom_col(width = .5) +
    labs(
      x = "",
      title = str_glue("Lowest Unemployment Claims Week, by Year
                                in Florida"),
      y = ""
    ) +
    scale_y_continuous(
      labels = scales::comma,
      limits = c(0, NA),
      breaks = scales::pretty_breaks(n = 6)
    ) +
    scale_fill_brewer(palette = "Dark2") +
    theme_minimal() +
    theme(
      axis.text.x = element_text(angle = 45),
      plot.title = element_text(hjust = .5)
    )
) %>% ggplotly(tooltip = "text")

November, December and January tend to contain the best week in each year in Florida, yet we still saw that summer tendency for the max claims.

That’s all for today, thanks for reading the latest Reproducible Finance post. Next time we’ll move on to part 2 and explore how some social data can be layered onto these charts. In the future, we can hope to extend this work to look at how quickly we have recovered and started to see unemployment claims drop there.

Stay safe out there!

Outlier Days with R and Python

Mon, 16 Mar 2020 00:00:00 +0000

Welcome to another installment of Reproducible Finance. Today’s post will be topical as we look at the historical behavior of the stock market after days of extreme returns and it will also explore one of my favorite coding themes of 2020 - the power of RMarkdown as an R/Python collaboration tool.

This post originated when Rishi Singh, the founder of tiingo and one of the nicest people I have encountered in this crazy world, sent over a note about recent market volatility along with some Python code for analyzing that volatility. We thought it would be a nice project to post that Python code along with the equivalent R code for reproducing the same results. For me, it’s a great opportunity to use RMarkdown's R and Python interoperability superpowers, fueled by the reticulate package. If you are an R coder and someone sends you Python code as part of a project, RMarkdown + reticulate makes it quite smooth to incorporate that Python code into your work. It was interesting to learn how a very experienced Python coder might tackle a problem and then think about how to tackle that problem with R. Unsurprisingly, I couldn’t resist adding a few elements of data visualization.

Before we get started, if you’re unfamiliar with using R and Python chunks throughout an RMarkdown file, have a quick look at the reticulate documentation here.

Let’s get to it. Since we’ll be working with R and Python, we start with our usual R setup code chunk to load R packages, but we’ll also load the reticulate package and source a Python script. Here’s what that looks like.

library(tidyverse)
library(tidyquant)
library(riingo)
library(timetk)
library(plotly)
library(roll)
library(slider)
library(reticulate)

riingo_set_token("your tiingo token here")

# Python file that holds my tiingo token
reticulate::source_python("credentials.py")

knitr::opts_chunk$set(message = FALSE, warning = FALSE, comment = NA)

Note that I set my tiingo token twice: first using riingo_set_token() so I can use the riingo package in R chunks and then by sourcing the credentials.py file, where I have put tiingoToken = 'my token'. Now I can use the tiingoToken variable in my Python chunks. This is necessary because we will use both R and Python to pull in data from Tiingo.

Next we will use a Python chunk to load the necessary Python libraries. If you haven’t installed these yet, you can open the RStudio terminal and run pip install. Since we’ll be interspersing R and Python code chunks throughout, I will add a # Python Chunk to each Python chunk and, um, # R Chunk to each R chunk.

# Python chunk
import pandas as pd
import numpy as np
import tiingo

Let’s get to the substance. The goal today is look back at the last 43 years of S&P 500 price history and analyze how the market has performed following a day that sees an extreme return. We will also take care with how we define an extreme return, using rolling volatility to normalize percentage moves.

We will use the mutual fund VFINX as a tradeable proxy for the S&P 500 because it has a much longer history than other funds like SPY or VOO.

Let’s start by passing a URL string from tiingo to the pandas function read_csv, along with our tiingoToken.

# Python chunk 
pricesDF = pd.read_csv("https://api.tiingo.com/tiingo/daily/vfinx/prices?startDate=1976-1-1&format=csv&token=" + tiingoToken)

We just created a Python object called pricesDF. We can look at that object in an R chunk by calling py$pricesDF.

# R chunk
py$pricesDF %>% 
  head()

We just created a Python object called pricesDF. Let’s reformat the date column becomes the index, in date time format.

# Python chunk 
pricesDF = pricesDF.set_index(['date'])
pricesDF.index = pd.DatetimeIndex(pricesDF.index)

Heading back to R for viewing, we see that the date column is no longer a column - it is the index of the data frame and in pandas the index is more like a label than a new column. In fact, here’s what happens when call the row names of this data frame.

# R chunk
py$pricesDF %>% 
  head() %>% 
  rownames()

We now have our prices, indexed by date. Let’s convert adjusted closing prices to log returns and save the results in a new column called returns. Note the use of the shift(1) operator here. That is analogous to the lag(..., 1) function in dplyr.

# Python chunk
pricesDF['returns'] = np.log(pricesDF['adjClose']/pricesDF['adjClose'].shift(1))

Next, we want to calculate the 3-month rolling standard deviation of these daily log returns, and then divide daily returns by the previous rolling 3-month volatility in order to prevent look-ahead error. We can think of this as normalizing today’s return by the previous 3-months’ rolling volatility and will label it as stdDevMove.

# Python chunk
pricesDF['rollingVol'] = pricesDF['returns'].rolling(63).std()
pricesDF['stdDevMove'] = pricesDF['returns'] / pricesDF['rollingVol'].shift(1)

Finally, we eventually want to calculate how the market has performed on the day following a large negative move. To prepare for that, let’s create a column of next day returns using shift(-1).

# Python chunk
pricesDF['nextDayReturns'] = pricesDF.returns.shift(-1)

Now, we can filter by the size of the stdDevMove column and the returns column, to isolate days where the standard deviation move was at least 3 and the returns was less than -3%. We use mean() to find the mean next day return following such large events.

# Python chunk
nextDayPerformanceSeries = pricesDF.loc[(pricesDF['stdDevMove'] < -3) & (pricesDF['returns'] < -.03), ['nextDayReturns']].mean()

Finally, let’s loop through and see how the mean next day return changes as we filter on different extreme negative returns or we can call drop tolerances. We will label the drop tolerance as i, set it at -.03 and then run a while loop that decrements down i by .0025 at each pass. In this way we can look at the mean next return following different levels of negative returns.

# Python chunk
i = -.03
while i >= -.0525:
    nextDayPerformanceSeries = pricesDF.loc[(pricesDF['stdDevMove'] < -3) & (pricesDF['returns'] < i), ['nextDayReturns']]
    print(str(round(i, 5)) + ': ' + str(round(nextDayPerformanceSeries['nextDayReturns'].mean(), 6)))

    i -= .0025

It appears that as the size of the drop gets larger and more negative, the mean bounce back tends to get larger.

Let’s reproduce these results in R.

First, we import prices using the riingo_prices() function from the riingo.

# R chunk
sp_500_prices <- 
  "VFINX" %>% 
  riingo_prices(start_date = "1976-01-01", end_date = today())

We can use mutate() to add a column of daily returns, rolling volatility, standard deviation move and next day returns.

# R chunk
sp_500_returns <- 
  sp_500_prices %>%
  select(date, adjClose) %>% 
  mutate(daily_returns_log = log(adjClose/lag(adjClose)),
         rolling_vol = roll_sd(as.matrix(daily_returns_log), 63),
         sd_move = daily_returns_log/lag(rolling_vol),
         next_day_returns = lead(daily_returns_log))

Now let’s filter() on an sd_move greater than 3 and daily_returns_log less than a drop tolerance of -.03.

# R chunk

sp_500_returns %>% 
  na.omit() %>% 
  filter(sd_move < -3 & daily_returns_log < -.03) %>% 
  select(date, daily_returns_log, sd_move, next_day_returns) %>% 
  summarise(mean_return = mean(next_day_returns)) %>% 
  add_column(drop_tolerance = scales::percent(.03), .before = 1)

# A tibble: 1 x 2
  drop_tolerance mean_return
  <chr>                <dbl>
1 3%                 0.00625

We used a while() loop to iterate across different drop tolerances in Python, let’s see how to implement that using map_dfr() from the purrr package.

First, we will define a sequence of drop tolerances using the seq() function.

# R chunk
drop_tolerance <- seq(.03, .05, .0025)

drop_tolerance

[1] 0.0300 0.0325 0.0350 0.0375 0.0400 0.0425 0.0450 0.0475 0.0500

Next, we will create a function called outlier_mov_fun that takes a data frame of returns, filters on a drop tolerance and gives us the mean return following large negative moves.

# R chunk
outlier_mov_fun <- function(drop_tolerance, returns) {
returns %>%  
  na.omit() %>% 
  filter(sd_move < -3 & daily_returns_log < -drop_tolerance) %>% 
  select(date, daily_returns_log, sd_move, next_day_returns) %>% 
  summarise(mean_return = mean(next_day_returns) %>% round(6)) %>%
  add_column(drop_tolerance = scales::percent(drop_tolerance), .before = 1) %>% 
  add_column(drop_tolerance_raw = drop_tolerance, .before = 1)
}

Notice how that function takes two arguments: a drop tolerance and data frame of returns.

Next, we pass our sequence of drop tolerances, stored in a variable called drop_tolerance to map_dfr(), along with our function and our sp_500_returns object. map_dfr will iterate through our sequence of drops and apply our function to each one.

# R chunk
map_dfr(drop_tolerance, outlier_mov_fun, sp_500_returns) %>% 
  select(-drop_tolerance_raw)

# A tibble: 9 x 2
  drop_tolerance mean_return
  <chr>                <dbl>
1 3%                 0.00625
2 3%                 0.00700
3 3%                 0.00967
4 4%                 0.0109 
5 4%                 0.0122 
6 4%                 0.0132 
7 4%                 0.0149 
8 5%                 0.0149 
9 5%                 0.0162

Have a quick glance up that the results of our Python while() and we should see that the results are consistent.

Alright, let’s have some fun and get to visualizing these results with ggplot and plotly.

# R chunk
(
sp_500_returns %>% 
map_dfr(drop_tolerance, outlier_mov_fun, .) %>% 
  ggplot(aes(x = drop_tolerance_raw, y = mean_return, text = str_glue("drop tolerance: {drop_tolerance}
                                                                      mean next day return: {mean_return * 100}%"))) +
  geom_point(color = "cornflowerblue") +
  labs(title = "Mean Return after Large Daily Drop", y = "mean return", x = "daily drop") +
  scale_x_continuous(labels = scales::percent) +
  scale_y_continuous(labels = scales::percent) + 
  theme_minimal()
) %>% ggplotly(tooltip = "text")

Here’s what happens when we expand the upper bound to a drop tolerance of -2% and make our intervals smaller, moving from .25% increments to .125% increments.

# R chunk
drop_tolerance_2 <- seq(.02, .05, .00125)

(
sp_500_returns %>% 
map_dfr(drop_tolerance_2, outlier_mov_fun, .) %>% 
  ggplot(aes(x = drop_tolerance_raw, y = mean_return, text = str_glue("drop tolerance: {drop_tolerance}
                                                                      mean next day return: {mean_return * 100}%"))) +
  geom_point(color = "cornflowerblue") +
  labs(title = "Mean Return after Large Daily Drop", y = "mean return", x = "daily drop") +
  scale_x_continuous(labels = scales::percent) +
  scale_y_continuous(labels = scales::percent) + 
  theme_minimal()
) %>% ggplotly(tooltip = "text")

Check out what happens when we expand the lower bound, to a -6% drop tolerance.

# R chunk
drop_tolerance_3 <- seq(.02, .06, .00125)

(
sp_500_returns %>% 
map_dfr(drop_tolerance_3, outlier_mov_fun, .) %>% 
  ggplot(aes(x = drop_tolerance_raw, y = mean_return, text = str_glue("drop tolerance: {drop_tolerance}
                                                                      mean next day return: {mean_return * 100}%"))) +
  geom_point(color = "cornflowerblue") +
  labs(title = "Mean Return after Large Daily Drop", y = "mean return", x = "daily drop") +
  scale_x_continuous(labels = scales::percent) +
  scale_y_continuous(labels = scales::percent) + 
  theme_minimal()
) %>% ggplotly(tooltip = "text")

I did not expect that gap upward when the daily drop passes 5.25%.

A quick addendum that if I had gotten my act together and finished this 4 days ago I would not have included, but I’m curious how this last week has compared with other weeks in terms of volatility. I have in mind to visualize weekly return dispersion and that seemed a mighty tall task, until the brand new slider package came to the rescue! slider has a function called slide_period() that, among other things, allows us to break up time series according to different periodicities.

To break up our returns by week, we call slide_period_dfr(., .$date, "week", ~ .x, .origin = first_monday_december, .names_to = "week"), where first_monday_december is a date that falls on a Monday. We could use our eyeballs to check a calendar and find a date that’s a Monday or we could use some good ol’ code. Let’s assume we want to find the first Monday in December of 2016.

We first filter our data with filter(between(date, as_date("2016-12-01"), as_date("2016-12-31"))). Then create a column of weekday names with wday(date, label = TRUE, abbr = FALSE) and filter to our first value of “Monday”.

# R Chunk
first_monday_december <- 
  sp_500_returns %>%
  mutate(date = ymd(date)) %>% 
  filter(between(date, as_date("2016-12-01"), as_date("2016-12-31"))) %>% 
  mutate(day_week = wday(date, label = TRUE, abbr = FALSE)) %>% 
  filter(day_week == "Monday") %>% 
  slice(1) %>% 
  pull(date)

Now we run our slide_period_dfr() code and it will start on the first Monday in December of 2016, and break our returns into weeks. Since we set .names_to = "week", the function will create a new column called week and give a unique number to each of our weeks.

# R chunk

sp_500_returns %>%
  select(date, daily_returns_log) %>%
  filter(date >= first_monday_december) %>%
  slide_period_dfr(.,
                   .$date,
                   "week",
                   ~ .x,
                   .origin = first_monday_december,
                   .names_to = "week") %>% 
  head(10)

# A tibble: 10 x 3
    week date                daily_returns_log
   <int> <dttm>                          <dbl>
 1     1 2016-12-05 00:00:00           0.00589
 2     1 2016-12-06 00:00:00           0.00342
 3     1 2016-12-07 00:00:00           0.0133 
 4     1 2016-12-08 00:00:00           0.00226
 5     1 2016-12-09 00:00:00           0.00589
 6     2 2016-12-12 00:00:00          -0.00105
 7     2 2016-12-13 00:00:00           0.00667
 8     2 2016-12-14 00:00:00          -0.00810
 9     2 2016-12-15 00:00:00           0.00392
10     2 2016-12-16 00:00:00          -0.00172

From here, we can group_by that week column and treat each week as a discrete time period. Let’s use ggplotly to plot each week on the x-axis and the daily returns of each week on the y-axis, so that the vertical dispersion shows us the dispersion of weekly returns. Hover on the point to see the exact date of the return.

# R chunk
(
sp_500_returns %>%
  select(date, daily_returns_log) %>%
  filter(date >= first_monday_december) %>%
  slide_period_dfr(.,
                   .$date,
                   "week",
                   ~ .x,
                   .origin = first_monday_december,
                   .names_to = "week") %>%
  group_by(week) %>%
  mutate(start_week = ymd(min(date))) %>%
  ggplot(aes(x = start_week, y = daily_returns_log, text = str_glue("date: {date}"))) +
  geom_point(color = "cornflowerblue", alpha = .5) +
  scale_y_continuous(labels = scales::percent,
                     breaks = scales::pretty_breaks(n = 8)) +
  scale_x_date(breaks = scales::pretty_breaks(n = 10)) +
  labs(y = "", x = "", title = "Weekly Daily Returns") +
  theme_minimal()
) %>% ggplotly(tooltip = "text")

We can also plot the standard deviation of returns for each week.

# R chunk

(
sp_500_returns %>%
  select(date, daily_returns_log) %>%
  filter(date >= first_monday_december) %>%
  slide_period_dfr(.,
                   .$date,
                   "week",
                   ~ .x,
                   .origin = first_monday_december,
                   .names_to = "week") %>%
  group_by(week) %>%
  summarise(first_of_week = first(date),
            sd = sd(daily_returns_log)) %>%
  ggplot(aes(x = first_of_week, y = sd, text = str_glue("week: {first_of_week}"))) +
  geom_point(aes(color = sd)) +
  labs(x = "", title = "Weekly Standard Dev of Returns", y = "") +
  theme_minimal()
) %>% ggplotly(tooltip = "text")

That’s all for today! Thanks for reading and stay safe out there.

Daily Volumes, Holidays and BLS Reports

Mon, 06 Jan 2020 00:00:00 +0000

Welcome to another installment of Reproducible Finance with R - the blog series that never seems to stop reproducing itself. Today we will explore the new almanac package for working with dates, which sprang forth courtesy of the mad genius behind riingo and furrr. We will be examining rolling returns and daily trading volumes from several ETFs over the past few years and we will use almanac to flag certain dates of interest. This post post inspired by curiosity about holidays and major news announcements, and their effect on daily trading volumes.

Let’s get to it!

First, let’s load our packages for the day. almanac is not on CRAN yet, so we’ll install the github version.

remotes::install_github("DavisVaughan/almanac")

library(tidyverse)
library(riingo)
library(almanac)
library(lubridate)
library(roll)
library(plotly)

Next, we’ll create a tibble of ETF tickers and sectors. I’ll stick with my usual iShares funds and SPY for the overall market.

etf_ticker_sector <- tibble(
  ticker = c("XLY", "XLP", "XLE",   
          "XLF", "XLV", "XLI", "XLB", 
          "XLK", "XLU", "XLRE", 
          "SPY"),   
  sector = c("Consumer Discretionary", "Consumer Staples", "Energy", 
          "Financials", "Health Care", "Industrials", "Materials", 
          "Information Technology", "Utilities", "Real Estate",
          "Market")
)

etf_ticker_sector

# A tibble: 11 x 2
   ticker sector                
   <chr>  <chr>                 
 1 XLY    Consumer Discretionary
 2 XLP    Consumer Staples      
 3 XLE    Energy                
 4 XLF    Financials            
 5 XLV    Health Care           
 6 XLI    Industrials           
 7 XLB    Materials             
 8 XLK    Information Technology
 9 XLU    Utilities             
10 XLRE   Real Estate           
11 SPY    Market

We are going to use tiingo via the riingo package to import daily prices for these tickers. That means we need an API key and then we need to pass our tickers to riingo_prices().

# Need an API key for tiingo

riingo_set_token("your API key here")

etf_prices <-
  etf_ticker_sector %>%
  pull(ticker) %>% 
  riingo_prices(., 
                start_date = "2010-01-01",
                end_date = Sys.Date()) %>% 
  mutate(date = ymd(date))

etf_prices %>% 
  group_by(ticker) %>% 
  slice(1:3)

# A tibble: 33 x 14
# Groups:   ticker [11]
   ticker date       close  high   low  open volume adjClose adjHigh adjLow
   <chr>  <date>     <dbl> <dbl> <dbl> <dbl>  <int>    <dbl>   <dbl>  <dbl>
 1 SPY    2010-01-04 113.  113.  112.  112.  1.19e8     92.8    92.8  91.3 
 2 SPY    2010-01-05 114.  114.  113.  113.  1.12e8     93.0    93.1  92.4 
 3 SPY    2010-01-06 114.  114.  113.  114.  1.16e8     93.1    93.3  92.9 
 4 XLB    2010-01-04  34.0  34.0  33.4  33.6 7.57e6     27.2    27.2  26.8 
 5 XLB    2010-01-05  34.1  34.2  33.8  34.1 8.84e6     27.3    27.4  27.1 
 6 XLB    2010-01-06  34.7  34.8  34.1  34.1 8.09e6     27.8    27.9  27.3 
 7 XLE    2010-01-04  58.8  58.8  57.8  57.9 1.69e7     44.8    44.8  44.0 
 8 XLE    2010-01-05  59.3  59.4  58.6  58.9 1.74e7     45.2    45.2  44.6 
 9 XLE    2010-01-06  60    60.2  59.2  59.3 2.43e7     45.7    45.8  45.1 
10 XLF    2010-01-04  14.7  14.7  14.5  14.5 7.55e7     10.0    10.1   9.91
# … with 23 more rows, and 4 more variables: adjOpen <dbl>,
#   adjVolume <int>, divCash <dbl>, splitFactor <dbl>

Let’s calculate rolling 50-day and 200-day average for SPY using the blazing fast roll package for rolling calculations. It has a built-in rolling mean function called roll_mean and is running C under the hood. Did I mention it’s fast? It’s super fast.

  etf_prices %>% 
  group_by(ticker) %>% 
  filter(ticker == "SPY") %>% 
  mutate(sma_50 = roll_mean(as.matrix(close), width = 50, complete_obs = T),
         sma_200 = roll_mean(as.matrix(close), width = 200, complete_obs = T)) %>%
  select(date, sma_50, sma_200) %>% 
  filter(!is.na(sma_200)) %>% 
  head()

# A tibble: 6 x 4
# Groups:   ticker [1]
  ticker date       sma_50 sma_200
  <chr>  <date>      <dbl>   <dbl>
1 SPY    2010-10-18   112.    112.
2 SPY    2010-10-19   112.    112.
3 SPY    2010-10-20   112.    112.
4 SPY    2010-10-21   112.    112.
5 SPY    2010-10-22   112.    112.
6 SPY    2010-10-25   113.    112.

Notice that we are filtering to show just “SPY” for now. When we get to shiny we’ll replace filter(ticker == "SPY") with filter(ticker == input$ticker) - that will allow an end user run these moving average calculations on any ticker we have in our data set.

Let’s plot the moving averages and use different colors and line types for the price, 50-day moving average and 200-day moving average.

rolling_average_plot <- 
etf_prices %>% 
  group_by(ticker) %>% 
  filter(ticker == "SPY") %>% 
  mutate(sma_50 = roll_mean(as.matrix(close), width = 50, complete_obs = T),
         sma_200 = roll_mean(as.matrix(close), width = 200, complete_obs = T)) %>% 
  select(date, close, sma_50, sma_200) %>% 
  ggplot(aes(x = date)) + 
  geom_line(aes(y = close), color = "purple", linetype = "dotted") +
  geom_line(aes(y = sma_50), color = "cornflowerblue", linetype = "solid") + 
  geom_line(aes(y = sma_200), color = "green", linetype = "solid") +
  scale_x_date(breaks = scales::pretty_breaks(n = 10)) +
  scale_y_continuous(label = scales::dollar) +
  labs(title = "Price, SMA 50 and SMA 200", y = "", x = "") +
  theme_minimal() +
  theme(plot.title  = element_text(hjust = .5))

ggplotly(rolling_average_plot)

How have volumes behaved throughout this time period?

volume_plot <- 
ggplotly(
etf_prices %>% 
  group_by(ticker) %>% 
  filter(ticker == "SPY") %>% 
  ggplot(aes(x = date)) + 
  geom_col(aes(y = volume), color = "pink", alpha = .5) +
  scale_x_date(breaks = scales::pretty_breaks(n = 10)) +
  scale_y_continuous(labels = scales::number_format(accuracy = 1,
                                   scale = 1/1000000,
                                   suffix = "M")) +
  theme_minimal() +
  theme(plot.title = element_text(hjust = .5)) +
  labs(y = "", title = "Daily Volume")
)

ggplotly(volume_plot)

Nothing crazy so far, how can the almanac package help us get creative?

I’m curious if BLS reports or holidays affect volumes and want to add a flag to the charts on the day of BLS reports and the day after any market holidays. That would have been very painful before the arrival of almanac!

Let’s start with the BLS.

The BLS reports on the employment situation on the first Friday of each month unless that first Friday is a national holiday.

Here’s how to quickly print the first Friday of each month since January 2010, using recur_on_wday("Friday", nth = 1).

monthly(since = "2010-01-01") %>%
  recur_on_interval(1) %>%
  recur_on_wday("Friday", nth = 1) %>% 
  alma_seq("2010-01-01", "2020-03-01", .)

  [1] "2010-01-01" "2010-02-05" "2010-03-05" "2010-04-02" "2010-05-07"
  [6] "2010-06-04" "2010-07-02" "2010-08-06" "2010-09-03" "2010-10-01"
 [11] "2010-11-05" "2010-12-03" "2011-01-07" "2011-02-04" "2011-03-04"
 [16] "2011-04-01" "2011-05-06" "2011-06-03" "2011-07-01" "2011-08-05"
 [21] "2011-09-02" "2011-10-07" "2011-11-04" "2011-12-02" "2012-01-06"
 [26] "2012-02-03" "2012-03-02" "2012-04-06" "2012-05-04" "2012-06-01"
 [31] "2012-07-06" "2012-08-03" "2012-09-07" "2012-10-05" "2012-11-02"
 [36] "2012-12-07" "2013-01-04" "2013-02-01" "2013-03-01" "2013-04-05"
 [41] "2013-05-03" "2013-06-07" "2013-07-05" "2013-08-02" "2013-09-06"
 [46] "2013-10-04" "2013-11-01" "2013-12-06" "2014-01-03" "2014-02-07"
 [51] "2014-03-07" "2014-04-04" "2014-05-02" "2014-06-06" "2014-07-04"
 [56] "2014-08-01" "2014-09-05" "2014-10-03" "2014-11-07" "2014-12-05"
 [61] "2015-01-02" "2015-02-06" "2015-03-06" "2015-04-03" "2015-05-01"
 [66] "2015-06-05" "2015-07-03" "2015-08-07" "2015-09-04" "2015-10-02"
 [71] "2015-11-06" "2015-12-04" "2016-01-01" "2016-02-05" "2016-03-04"
 [76] "2016-04-01" "2016-05-06" "2016-06-03" "2016-07-01" "2016-08-05"
 [81] "2016-09-02" "2016-10-07" "2016-11-04" "2016-12-02" "2017-01-06"
 [86] "2017-02-03" "2017-03-03" "2017-04-07" "2017-05-05" "2017-06-02"
 [91] "2017-07-07" "2017-08-04" "2017-09-01" "2017-10-06" "2017-11-03"
 [96] "2017-12-01" "2018-01-05" "2018-02-02" "2018-03-02" "2018-04-06"
[101] "2018-05-04" "2018-06-01" "2018-07-06" "2018-08-03" "2018-09-07"
[106] "2018-10-05" "2018-11-02" "2018-12-07" "2019-01-04" "2019-02-01"
[111] "2019-03-01" "2019-04-05" "2019-05-03" "2019-06-07" "2019-07-05"
[116] "2019-08-02" "2019-09-06" "2019-10-04" "2019-11-01" "2019-12-06"
[121] "2020-01-03" "2020-02-07"

Are any of these national holidays?

Well, the first Friday at some point probably fell on January 1st or July 4th. We can hunt for those dates using str_subset() to keep only the subset of our date strings containing either “01-01” (for January 1) or “07-04” (for July 4).

monthly(since = "2010-01-01") %>%
  recur_on_interval(1) %>%
  recur_on_wday("Friday", nth = 1) %>% 
  alma_seq("2010-01-01", "2020-03-01", .) %>% 
  str_subset(paste(c("01-01", "07-04"), collapse = '|'))

[1] "2010-01-01" "2014-07-04" "2016-01-01"

It looks like we have three problematic dates to handle. Now we must make a provision for these dates, but the provision is different for each scenario. For July 4th, the BLS reports the day before, July 3rd, a Thursday. For January 1st, the BLS doesn’t shift to December 31st because that would be shifting into the previous year. Instead it shifts to the following Friday, January 8th! Encoding that logic would be quite cumbersome, indeed, and here the magic of almanac saves us some time.

The package contains a prebuilt object called hldy_independence_day() and another called hldy_new_years_day(). We can create a calendar that skips ahead seven days whenever it sees January 1st, and steps back 1 day whenever it sees July 4th in our schedule.

We do that with alma_adjust(hldy_new_years_day(), adjustment = 7), to skip 7 days from New Year’s Day and then alma_adjust(hldy_independence_day(), adjustment = -1) to move back from July 4th.

Here’s what it does to just the Independence Day and New Year’s Days we wish to adjust.

monthly(since = "2010-01-01") %>%
  recur_on_interval(1) %>%
  recur_on_wday("Friday", nth = 1) %>% 
  alma_seq("2010-01-01", "2020-03-01", .) %>% 
  str_subset(paste(c("01-01", "07-04"),collapse = '|')) %>% 
  alma_adjust(hldy_new_years_day(), adjustment = 7) %>% 
  alma_adjust(hldy_independence_day(), adjustment = -1)

[1] "2010-01-08" "2014-07-03" "2016-01-08"

Let’s add our adjusters to the original schedule creation flow and save as an object called bls_reports. I eventually want to access this as a data frame so will convert to a tibble as the final step.

bls_reports <- 
monthly(since = "2010-01-01") %>%
  recur_on_interval(1) %>%
  recur_on_wday("Friday", nth = 1) %>% 
  alma_seq("2010-01-01", "2020-03-01", .) %>% 
  alma_adjust(hldy_new_years_day(), adjustment = 7) %>% 
  alma_adjust(hldy_independence_day(), adjustment = -1) %>% 
  tibble(nfp_release_dates = .,
         bls_flag = 1)

We also want to investigate volume on the day after a market holiday. To create a list of the days after market holidays, we’ll start with calendar_usa_federal() and then use alma_jump(days(1)) to move to the following day. But, we need to make sure we don’t jump off of a holiday and onto a weekend. Let’s create a list of weekends with on_weekends <- weekly(since = "2010-01-01") %>% recur_on_weekends(), and then add it to sq_jump so that we move to the day following the holiday and then jump over any weekends. The full call below will look for holidays, then skip one day, then check to make sure we haven’t landed on a weekend and if so, move to Monday.

on_weekends <- weekly(since = "2010-01-01") %>% 
  recur_on_weekends()

post_holiday <- 
alma_seq("2010-01-01", "2019-10-01", calendar_usa_federal())  %>% 
alma_jump(days(1), on_weekends)

day_after <- 
tibble(
  post_holiday = post_holiday,
  holiday_flag = 1
)

Now we can add those date flags to our etf data with calls to left_join(bls_reports) and left_join(day_after, by = c("date" = "post_holiday"))

etf_prices_date_flags <- 
etf_prices %>% 
  group_by(ticker) %>% 
  mutate(sma_50 = roll_mean(as.matrix(close), width = 50, complete_obs = T),
         sma_200 = roll_mean(as.matrix(close), width = 200, complete_obs = T)) %>%
  filter(!is.na(sma_200)) %>% 
  select(ticker, date, close, volume, sma_50, sma_200) %>% 
  left_join(bls_reports, by = c("date" = "nfp_release_dates")) %>% 
  left_join(day_after, by = c("date" = "post_holiday"))

Let’s save that as an RDS object for use in a Shiny app later.

write_rds(etf_prices_date_flags, "etf_prices_date_flags.RDS")

Before building the app, let’s plot the daily volumes of SPY as pink bars, adding an orange dot for BLS release dates and a black dot for the day after market holidays.

volume_plot_flags <-
(
etf_prices_date_flags %>% 
  filter(ticker ==  "SPY") %>% 
  ggplot(aes(x = date)) + 
  geom_col(aes(y = volume), color = "pink", alpha = .5) +
  geom_point(data = etf_prices_date_flags %>% filter(ticker == "SPY" & bls_flag == 1), aes(date, volume, text = paste("Jobs Report", "<br>date:", date, "<br> volume:", volume)), color = "orange") +
  geom_point(data = etf_prices_date_flags %>% filter(ticker == "SPY" & holiday_flag == 1), aes(date, volume, text = paste("Post Holiday", "<br>date:", date, "<br> volume:", volume)), color = "black") +
  scale_x_date(breaks = scales::pretty_breaks(n = 10)) +
  scale_y_continuous(labels = scales::number_format(accuracy = 1,
                                   scale = 1/1000000,
                                   suffix = "M")) +
  theme_minimal() +
  theme(plot.title = element_text(hjust = .5)) +
  labs(y = "")
) %>% 
  ggplotly(tooltip = "text") %>%
  layout(title = "Daily Volume")

volume_plot_flags

Here’s a quick look at the price and moving daily averages.

rolling_average_plot <- 
(
  etf_prices_date_flags %>% 
  filter(ticker ==  "SPY") %>% 
  ggplot(aes(x = date)) + 
  geom_line(aes(y = close), color = "purple", linetype = "dotted") +
  geom_line(aes(y = sma_50), color = "cornflowerblue", linetype = "solid") + 
  geom_line(aes(y = sma_200), color = "green", linetype = "solid") +
  scale_y_continuous(labels = scales::dollar) +
  scale_x_date(breaks = scales::pretty_breaks(n = 10)) +
  theme_minimal() +
  theme(plot.title = element_text(hjust = .5)) +
  labs(x = "date", title = "SMA 50 v. SMA 200", y = "", x= "")
) %>% 
  ggplotly() 

rolling_average_plot

Those two charts look close to what we want, but for fun let’s give our end user the ability to toggle different aesthetics onto and off of the charts. plotly has a nifty updatemenus argument for it’s layout() function that allows us to customize buttons.

We first create a list of buttons with the following code.

price_update_menus <- list(
  
  list(
    active = -1,
    type= 'buttons',
    buttons = list(
      list(
        label = "All",
        method = "update",
        args = list(list(visible = c(TRUE, TRUE, TRUE)),
                    list(title = "Price, SMA 50 & SMA 200"))),
       list(
        label = "price",
        method = "update",
        args = list(list(visible = c(TRUE, FALSE, FALSE)),
                    list(title = "Current Price"))),
      list(
        label = "sma 50",
        method = "update",
        args = list(list(visible = c(FALSE, TRUE, FALSE)),
                    list(title = "SMA 50"))),
      list(
        label = "sma 200",
        method = "update",
        args = list(list(visible = c(FALSE, FALSE, TRUE)),
                    list(title = "SMA 200"))))
  )
)

Then add to the chart with layout(updatemenus = price_update_menus).

  rolling_average_plot %>% 
  layout(updatemenus = price_update_menus)

Try clicking on the buttons to see how the chart responds.

We can do the same with the BLS reports flags.

volume_update_menus <- list(
  
  list(
    active = -1,
    type= 'buttons',
    buttons = list(
      list(
        label = "All",
        method = "update",
        args = list(list(visible = c(TRUE, TRUE, TRUE)),
                    list(title = "BLS Reports and Day after Holidays Flagged"))),
      list(
        label = "BLS",
        method = "update",
        args = list(list(visible = c(TRUE, TRUE, FALSE)),
                    list(title = "BLS Reports"))),
      list(
        label = "Holidays",
        method = "update",
        args = list(list(visible = c(TRUE, FALSE, TRUE)),
                    list(title = "Day after Holidays"))))
  )
)

volume_plot_flags %>% 
  layout(updatemenus = volume_update_menus)

Remember way back in the beginning of this post, we imported prices for several ETFs, but thus far we have been working with SPY data. If we want to apply this work with flagged dates to others, we can use a Shiny application, which we will construct next time.

That’s all for today!

Shameless book plug for those who read to the end: if you like this sort of thing, check out my book Reproducible Finance with R!

Thanks for reading and see you next time.