Working with Paycheck Protection Program data in R

Loan amount

The first step is to split the data into 2 buckets. For loans above $150k, the SBA binned the loan amount instead of reporting the actual value.

ppp_under_150 <- ppp %>% 
  filter(!str_detect(file_name, "150k plus"))

ppp_over_150 <- ppp %>% 
  filter(str_detect(file_name, "150k plus")) %>%
  mutate(loan_range = fct_infreq(loan_range))

Among loans less than 150k, most are less than 21k, and the distribution is very heavily skewed to the right.

quantiles <- ppp_under_150 %>% 
  summarize(quantiles = quantile(loan_amount, probs = c(.25, .50, .75)), 
            probability = c("25th", "50th", "75th")) %>% 
  mutate(probability = as.factor(probability))

ppp_under_150 %>% 
  ggplot(aes(loan_amount)) +
  geom_histogram() +
  geom_vline(data = quantiles, aes(xintercept = quantiles, color = probability)) +
  scale_y_comma() +
  scale_x_comma(labels = scales::dollar) +
  labs(title = "SBA PPP Loans",
       subtitle = "Among loans less than $150k",
       x = "Loan amount",
       y = "Number of loans",
       color = "Quantile")

Loans under $150k make up the vast majority of all PPP loans.

ppp %>% 
  count(loan_range) %>%   
  mutate(loan_range = fct_reorder(loan_range, n)) %>% 
  ggplot(aes(n, loan_range)) +
  geom_col() +
  labs(title = "SBA PPP Loans",
       subtitle = "All loans",
       x = "Number of loans",
       y = "Loan range") +
  scale_x_comma()

Loan approvals peaked in late April 2020 when the program began accepting applications for the second round, and picked up in July. There is extreme weekday-weekend seasonality in the data after April. The “U” shape from May to July generally coincides with the effort to “reopen” economies nationwide.

ppp %>% 
  count(date_approved) %>% 
  ggplot(aes(date_approved, n)) +
  geom_point() +
  geom_vline(xintercept = ymd("2020-04-16"), linetype = 2) +
  labs(title = "SBA PPP Loans",
       x = NULL,
       y = "Number of loans") +
  scale_y_comma()

This shows that bigger loans tended to be approved earlier in the program, which was a major criticism.

ppp %>% 
  count(date_approved, loan_range) %>% 
  mutate(loan_range = fct_reorder(loan_range, n) %>% fct_rev) %>% 
  group_by(date_approved) %>% 
  mutate(pct_of_loans = n / sum(n)) %>% 
  ungroup() %>% 
  ggplot(aes(date_approved, pct_of_loans, fill = loan_range)) +
  geom_area() +
  scale_x_date(expand = c(0,0)) +
  scale_y_percent(expand = c(0,0)) +
  scale_fill_viridis_d() +
  labs(title = "SBA PPP Loans",
       subtitle = "% of loans approved on a date",
       x = NULL,
       y = "% of loans",
       fill = "Loan range") +
  theme(legend.position = "bottom")

Most states received similar proportions of small and large loans. Territories received more small loans and fewer large loans.

ppp %>% 
  mutate(loan_range = fct_inorder(loan_range)) %>% 
  count(state, loan_range) %>% 
  group_by(state) %>% 
  mutate(pct_of_loans = n / sum(n)) %>% 
  ungroup() %>% 
  filter(!is.na(state)) %>% 
  mutate(state = fct_reorder(state, n, .fun = sum)) %>% 
  ggplot(aes(pct_of_loans, state, fill = loan_range)) +
  geom_col() +
  scale_fill_viridis_d(direction = -1) +
  scale_x_percent() +
  labs(title = "SBA PPP Loans",
       subtitle = "% of loan range by state",
       x = "% of loans",
       y = NULL,
       fill = "Loan range") +
  theme(legend.position = "bottom")

Jobs

Bigger loans tended to retain more jobs.

ppp %>% 
  filter(!is.na(jobs_retained)) %>% 
  mutate(loan_range = fct_inorder(loan_range) %>% fct_rev()) %>% 
  ggplot(aes(jobs_retained, fill = loan_range)) +
  #geom_histogram(bins = 200) +
  geom_density() +
  facet_wrap(~loan_range, ncol = 2, scales = "free") +
  scale_x_comma() +
  #scale_y_comma() +
  scale_fill_viridis_d() +
  labs(title = "SBA PPP Loan Program",
       subtitle = "Jobs retained",
       x = "Number of jobs retained",
       y = "Density",
       fill = "Loan range")

The timeline of jobs_retained closely matches the trend of when loans were approved.

ppp %>% 
  filter(!is.na(jobs_retained)) %>% 
  group_by(date_approved) %>% 
  summarize(jobs_retained = sum(jobs_retained)) %>% 
  ungroup() %>% 
  ggplot(aes(date_approved, jobs_retained)) +
  geom_point() +
  scale_y_comma() +
  labs(title = "SBA PPP Loan Program",
       subtitle = "Jobs Retained",
       x = NULL,
       y = "Jobs retained")

Among loans less than 150k and where the data was reported, the median loan retained 6 jobs per 50k spent. Systemic reporting bias probably makes this number less reliable.

ppp %>% 
  filter(loan_range == "Under $150k",
         !is.na(jobs_retained),
         !is.na(loan_amount)) %>% 
  select(jobs_retained, loan_amount) %>% 
  mutate(jobs_retained_per_50k = (jobs_retained / loan_amount) * 50000) %>% 
  summarize(jobs_retained_per_50k = median(jobs_retained_per_50k))

## # A tibble: 1 x 1
##   jobs_retained_per_50k
##                   <dbl>
## 1                  6.21

In the same loan range, bigger loans generally meant more jobs retained.

test <- ppp %>% 
  filter(loan_range == "Under $150k") %>% 
  count(loan_amount, jobs_retained, sort = TRUE) %>%
  slice(1:5000)

test %>% 
  ggplot(aes(loan_amount, jobs_retained, color = n)) +
  geom_density_2d_filled() +
  scale_x_comma(labels = scales::dollar) +
  labs(title = "SBA PPP Loan Program",
       subtitle = NULL,
       x = "Loan amount",
       y = "Jobs retained",
       fill = "Density of observations")

Mapping the data

The dataset identifies which federal congressional district the applicant is from. I use tigris to retrieve the shapefiles for the most recent districts.

congress_districts <- suppressMessages(congressional_districts(cb = TRUE, resolution = "500k", year = 2018)) %>% 
  st_as_sf() %>% 
  clean_names() %>% 
  filter(statefp == 42)

This counts how many of each loan_range a district received. Note that there are missing values and what appear to be defunct district IDs in the district column.

ppp_pa_districts_loan_range <- ppp %>% 
  filter(state == "PA") %>% 
  count(district, loan_range, sort = TRUE)

ppp_pa_districts_loan_range %>% 
  mutate(district = fct_explicit_na(district),
         district = fct_reorder(district, n, .fun = sum),
         loan_range = fct_rev(loan_range)) %>% 
  ggplot(aes(n, district, fill = loan_range)) +
  geom_col() +
  scale_x_comma() +
  scale_fill_viridis_d() +
  labs(title = "SBA PPP Loan Program",
       subtitle = "Pennsylvania",
       x = "Number of loans",
       y = "Congressional District",
       fill =  "Loan range")

Districts in eastern Pennsylvania near Philadelphia received more loans from the program.

ppp_pa_districts <- ppp %>% 
  filter(state == "PA") %>% 
  count(district, sort = TRUE)

congress_districts %>% 
  right_join(ppp_pa_districts, by = c("cd116fp" = "district")) %>% 
  ggplot() +
  geom_sf(aes(fill = n)) +
  scale_fill_viridis_c(option = "A", labels = scales::comma) +
  labs(title = "SBA PPP Loan Program",
       subtitle = "Pennsylvania",
       fill = "Number of loans") +
  theme_void()