PART I: SETUP, DATA LOADING, AND PERIOD DEFINITIONS
1.1 Package Installation and Loading
# ==========================================================================
# SETUP AND PACKAGES
# ==========================================================================
BASE_PATH <- "C:/Users/mohua/OneDrive - Louisiana State University/Finance_PhD/DW_Stigma_paper/Liquidity_project_2025"
knitr::opts_knit$set(root.dir = BASE_PATH)
options(repos = c(CRAN = "https://cloud.r-project.org"))
options(scipen = 999)
set.seed(20230313)
# Required packages
required_packages <- c(
"data.table", "dplyr", "tidyr", "tibble", "lubridate", "stringr", "readr",
"fixest", "sandwich", "lmtest", "broom",
"ggplot2", "ggthemes", "scales", "patchwork", "gridExtra",
"knitr", "kableExtra", "modelsummary",
"DescTools", "moments", "psych", "tidyverse"
)
# Install missing packages
missing <- required_packages[!required_packages %in% installed.packages()[,"Package"]]
if(length(missing) > 0) install.packages(missing)
# Load packages
suppressPackageStartupMessages({
library(data.table)
library(dplyr)
library(tidyr)
library(tibble)
library(lubridate)
library(stringr)
library(readr)
library(fixest)
library(sandwich)
library(lmtest)
library(broom)
library(ggplot2)
library(ggthemes)
library(scales)
library(patchwork)
library(gridExtra)
library(knitr)
library(kableExtra)
library(modelsummary)
library(DescTools)
library(moments)
library(psych)
library(tidyverse)
})
cat("✓ All packages loaded successfully\n")
#> ✓ All packages loaded successfully
1.2 Configure Paths
# ==========================================================================
# CONFIGURE PATHS
# ==========================================================================
DATA_RAW <- file.path(BASE_PATH, "01_data/raw")
DATA_PROC <- file.path(BASE_PATH, "01_data/processed")
DATA_OUT <- file.path(BASE_PATH, "01_data/output")
DOC_PATH <- file.path(BASE_PATH, "03_documentation")
TABLE_PATH <- file.path(DOC_PATH, "regression_tables/btfp_analysis_v06")
FIG_PATH <- file.path(DOC_PATH, "figures/btfp_analysis_v06")
# Create output directories
dir.create(TABLE_PATH, recursive = TRUE, showWarnings = FALSE)
dir.create(FIG_PATH, recursive = TRUE, showWarnings = FALSE)
cat("✓ Paths configured\n")
#> ✓ Paths configured
cat(" Data (raw):", DATA_RAW, "\n")
#> Data (raw): C:/Users/mohua/OneDrive - Louisiana State University/Finance_PhD/DW_Stigma_paper/Liquidity_project_2025/01_data/raw
cat(" Data (processed):", DATA_PROC, "\n")
#> Data (processed): C:/Users/mohua/OneDrive - Louisiana State University/Finance_PhD/DW_Stigma_paper/Liquidity_project_2025/01_data/processed
cat(" Tables:", TABLE_PATH, "\n")
#> Tables: C:/Users/mohua/OneDrive - Louisiana State University/Finance_PhD/DW_Stigma_paper/Liquidity_project_2025/03_documentation/regression_tables/btfp_analysis_v06
cat(" Figures:", FIG_PATH, "\n")
#> Figures: C:/Users/mohua/OneDrive - Louisiana State University/Finance_PhD/DW_Stigma_paper/Liquidity_project_2025/03_documentation/figures/btfp_analysis_v06
1.3 Period Definitions
# ==========================================================================
# PERIOD DEFINITIONS
# ==========================================================================
#
# TWO PERIOD CLASSIFICATION SYSTEMS:
#
# SYSTEM 1 (OLD): Three broad periods
# - Acute: Mar 13 - May 1, 2023
# - Post-Acute: May 2 - Oct 31, 2023
# - Arbitrage: Nov 1, 2023 - Jan 24, 2024
#
# SYSTEM 2 (NEW): Seven granular periods
# - P0 (Pre-BTFP): Oct 1, 2022 - Mar 12, 2023
# - P1 (Week 1): Mar 13-19, 2023
# - P2 (Crisis Month): Mar 20 - Apr 30, 2023
# - P3 (FRC May): May 1-31, 2023
# - P4 (Stabilization): Jun 1 - Sep 30, 2023
# - P5 (Arbitrage): Nov 1, 2023 - Jan 24, 2024
# - P6 (Wind-down): Jan 25 - Mar 11, 2024
#
# NOTE: DW data ends September 30, 2023
# ==========================================================================
## Key Crisis Dates
PRE_BTFP_START <- as.Date("2022-10-01")
SVB_FAIL <- as.Date("2023-03-10") # Friday
SIGNATURE_FAIL <- as.Date("2023-03-12") # Sunday
PRE_BTFP_END <- as.Date("2023-03-12")
CRISIS_START <- as.Date("2023-03-13") # Monday - BTFP operational
WEEK1_END <- as.Date("2023-03-19") # End of first week
WEEK2_END <- as.Date("2023-03-26") # End of second week
MARCH_END <- as.Date("2023-03-31")
APRIL_END <- as.Date("2023-04-30")
FRC_FAIL <- as.Date("2023-05-01") # First Republic fails
MAY_END <- as.Date("2023-05-31")
SUMMER_START <- as.Date("2023-06-01")
DW_DATA_END <- as.Date("2023-09-30") # CRITICAL: Last DW data
DW_HAIRCUT_RETURN <- as.Date("2023-10-31") # DW haircuts return
ARBITRAGE_START <- as.Date("2023-11-01")
ARB_WINDOW_OPEN <- as.Date("2023-11-06") # BTFP rate < IORB
ARBITRAGE_END <- as.Date("2024-01-24") # Fed closes new BTFP
BTFP_CLOSE <- as.Date("2024-03-11") # BTFP fully closes
## Old Period Definitions (Legacy)
PERIOD_1_END <- as.Date("2023-05-01") # Acute ends
PERIOD_2_END <- as.Date("2023-10-31") # Post-Acute ends
PERIOD_3_END <- as.Date("2024-01-24") # Arbitrage ends
## New Period Definitions
WEEK_1_END <- WEEK1_END
CRISIS_MONTH_END <- APRIL_END
BASELINE_QUARTER <- "2022Q4"
BASELINE_DATE <- "2022Q4"
cat("✓ Period definitions established\n")
#> ✓ Period definitions established
cat("\n=== OLD PERIOD SYSTEM ===\n")
#>
#> === OLD PERIOD SYSTEM ===
cat("Acute: ", format(CRISIS_START), "to", format(PERIOD_1_END), "\n")
#> Acute: 2023-03-13 to 2023-05-01
cat("Post-Acute: ", format(PERIOD_1_END + 1), "to", format(PERIOD_2_END), "\n")
#> Post-Acute: 2023-05-02 to 2023-10-31
cat("Arbitrage: ", format(PERIOD_2_END + 1), "to", format(PERIOD_3_END), "\n")
#> Arbitrage: 2023-11-01 to 2024-01-24
cat("\n=== NEW PERIOD SYSTEM ===\n")
#>
#> === NEW PERIOD SYSTEM ===
cat("P0 (Pre-BTFP): ", format(PRE_BTFP_START), "to", format(PRE_BTFP_END), "\n")
#> P0 (Pre-BTFP): 2022-10-01 to 2023-03-12
cat("P1 (Week 1): ", format(CRISIS_START), "to", format(WEEK1_END), "\n")
#> P1 (Week 1): 2023-03-13 to 2023-03-19
cat("P2 (Crisis Month): ", format(WEEK1_END + 1), "to", format(APRIL_END), "\n")
#> P2 (Crisis Month): 2023-03-20 to 2023-04-30
cat("P3 (FRC May): ", format(FRC_FAIL), "to", format(MAY_END), "\n")
#> P3 (FRC May): 2023-05-01 to 2023-05-31
cat("P4 (Stabilization): ", format(SUMMER_START), "to", format(DW_DATA_END), "\n")
#> P4 (Stabilization): 2023-06-01 to 2023-09-30
cat("P5 (Arbitrage): ", format(ARBITRAGE_START), "to", format(ARBITRAGE_END), "\n")
#> P5 (Arbitrage): 2023-11-01 to 2024-01-24
cat("P6 (Wind-down): ", format(ARBITRAGE_END + 1), "to", format(BTFP_CLOSE), "\n")
#> P6 (Wind-down): 2024-01-25 to 2024-03-11
cat("\n*** NOTE: DW data ends", format(DW_DATA_END), "***\n")
#>
#> *** NOTE: DW data ends 2023-09-30 ***
1.4 Helper Functions
# ==========================================================================
# HELPER FUNCTIONS
# ==========================================================================
## Data Manipulation Functions
winsorize <- function(x, probs = c(0.01, 0.99)) {
if (all(is.na(x))) return(x)
q <- quantile(x, probs = probs, na.rm = TRUE, names = FALSE)
pmax(pmin(x, q[2]), q[1])
}
safe_div <- function(num, denom) {
ifelse(is.na(denom) | denom == 0, NA_real_, num / denom)
}
parse_date_safe <- function(x) {
if (inherits(x, "Date")) return(x)
x_char <- as.character(x)
result <- suppressWarnings(mdy(x_char))
if (all(is.na(result))) result <- suppressWarnings(ymd(x_char))
if (all(is.na(result))) result <- suppressWarnings(dmy(x_char))
return(result)
}
## Period Assignment Functions
# Assign OLD period (Acute, Post-Acute, Arbitrage)
assign_period_old <- function(date) {
case_when(
date >= CRISIS_START & date <= PERIOD_1_END ~ "Acute",
date > PERIOD_1_END & date <= PERIOD_2_END ~ "Post-Acute",
date > PERIOD_2_END & date <= PERIOD_3_END ~ "Arbitrage",
date < CRISIS_START ~ "Pre-BTFP",
TRUE ~ NA_character_
)
}
# Assign NEW period (P0-P6)
assign_period_new <- function(date) {
case_when(
date >= PRE_BTFP_START & date <= PRE_BTFP_END ~ "P0_PreBTFP",
date >= CRISIS_START & date <= WEEK1_END ~ "P1_Week1",
date > WEEK1_END & date <= CRISIS_MONTH_END ~ "P2_CrisisMonth",
date > CRISIS_MONTH_END & date <= MAY_END ~ "P3_FRCMay",
date > MAY_END & date <= DW_DATA_END ~ "P4_Stabilization",
date >= ARBITRAGE_START & date <= ARBITRAGE_END ~ "P5_Arbitrage",
date > ARBITRAGE_END & date <= BTFP_CLOSE ~ "P6_WindDown",
TRUE ~ NA_character_
)
}
# Get call report quarter for a given date
get_call_quarter <- function(loan_date) {
case_when(
loan_date <= as.Date("2023-03-31") ~ "2022Q4",
loan_date <= as.Date("2023-06-30") ~ "2023Q1",
loan_date <= as.Date("2023-09-30") ~ "2023Q2",
loan_date <= as.Date("2023-12-31") ~ "2023Q3",
TRUE ~ "2023Q4"
)
}
## Significance Functions
add_stars <- function(p_val) {
if (is.na(p_val)) return("")
if (p_val < 0.01) return("***")
if (p_val < 0.05) return("**")
if (p_val < 0.10) return("*")
return("")
}
cat("✓ Helper functions defined\n")
#> ✓ Helper functions defined
1.5 Theme and Color Schemes
# ==========================================================================
# THEME AND COLOR SCHEMES
# ==========================================================================
## Publication-quality theme
theme_pub <- function(base_size = 11) {
theme_minimal(base_size = base_size) +
theme(
plot.title = element_text(face = "bold", size = rel(1.2), hjust = 0),
plot.subtitle = element_text(size = rel(0.9), hjust = 0, color = "gray40"),
plot.caption = element_text(size = rel(0.7), hjust = 1, color = "gray50"),
panel.grid.minor = element_blank(),
panel.grid.major = element_line(color = "gray90", linewidth = 0.3),
axis.title = element_text(face = "bold", size = rel(0.9)),
legend.position = "bottom",
strip.text = element_text(face = "bold"),
plot.margin = margin(10, 10, 10, 10)
)
}
## Color schemes
crisis_colors <- c(
"P0_PreBTFP" = "#636363",
"P1_Week1" = "#d73027",
"P2_CrisisMonth" = "#fc8d59",
"P3_FRCMay" = "#fee08b",
"P4_Stabilization" = "#d9ef8b",
"P5_Arbitrage" = "#91bfdb",
"P6_WindDown" = "#4575b4",
"Acute" = "#d73027",
"Post-Acute" = "#fee08b",
"Arbitrage" = "#91bfdb"
)
facility_colors <- c(
"BTFP" = "#2166ac",
"DW" = "#b2182b",
"Both" = "#762a83",
"None" = "#d9d9d9"
)
cat("✓ Themes and colors configured\n")
#> ✓ Themes and colors configured
1.6 Load Data
# ==========================================================================
# LOAD DATA
# ==========================================================================
cat("\n=== LOADING DATA ===\n")
#>
#> === LOADING DATA ===
## Load Call Reports
call_q <- read_csv(file.path(DATA_PROC, "final_call_gsib.csv"), show_col_types = FALSE) %>%
mutate(idrssd = as.character(idrssd))
cat("✓ Call reports loaded:", nrow(call_q), "observations\n")
#> ✓ Call reports loaded: 61002 observations
## Load BTFP Loans
btfp_raw <- read_csv(file.path(DATA_PROC, "btfp_loan_bank_only.csv"), show_col_types = FALSE) %>%
mutate(
rssd_id = as.character(rssd_id),
btfp_loan_date = parse_date_safe(btfp_loan_date),
btfp_maturity_date = parse_date_safe(btfp_maturity_date),
btfp_repayment_date = parse_date_safe(btfp_repayment_date)
)
cat("✓ BTFP loans loaded:", nrow(btfp_raw), "records\n")
#> ✓ BTFP loans loaded: 6734 records
## Load DW Loans
dw_raw <- read_csv(file.path(DATA_PROC, "dw_loan_bank_2023.csv"), show_col_types = FALSE) %>%
mutate(
rssd_id = as.character(rssd_id),
dw_loan_date = parse_date_safe(dw_loan_date),
dw_maturity_date = parse_date_safe(dw_maturity_date),
dw_repayment_date = parse_date_safe(dw_repayment_date)
)
cat("✓ DW loans loaded:", nrow(dw_raw), "records\n")
#> ✓ DW loans loaded: 20219 records
cat("\n✓ All data loaded successfully\n")
#>
#> ✓ All data loaded successfully
1.7 Create Loan-Level Datasets with Period Assignments
# ==========================================================================
# CREATE LOAN-LEVEL DATASETS WITH PERIOD ASSIGNMENTS
# ==========================================================================
cat("\n=== CREATING LOAN-LEVEL DATASETS ===\n")
#>
#> === CREATING LOAN-LEVEL DATASETS ===
## BTFP Loans with both period systems
btfp_loans <- btfp_raw %>%
mutate(
period_old = assign_period_old(btfp_loan_date),
period_new = assign_period_new(btfp_loan_date),
facility = "BTFP"
) %>%
filter(!is.na(period_old) | !is.na(period_new))
cat("✓ BTFP loans with periods:", nrow(btfp_loans), "\n")
#> ✓ BTFP loans with periods: 6734
cat(" Old periods:", table(btfp_loans$period_old), "\n")
#> Old periods: 1087 3279 1972
cat(" New periods:", table(btfp_loans$period_new), "\n")
#> New periods: 104 958 762 1033 3279 396
## DW Loans with both period systems
dw_loans <- dw_raw %>%
mutate(
period_old = assign_period_old(dw_loan_date),
period_new = assign_period_new(dw_loan_date),
facility = "DW"
) %>%
filter(!is.na(period_old) | !is.na(period_new))
cat("✓ DW loans with periods:", nrow(dw_loans), "\n")
#> ✓ DW loans with periods: 20219
cat(" Old periods:", table(dw_loans$period_old), "\n")
#> Old periods: 1619 4237 14363
cat(" New periods:", table(dw_loans$period_new), "\n")
#> New periods: 4189 336 1241 878 3401
1.8 Create Dual Baselines
# ==========================================================================
# CREATE DUAL BASELINES
# ==========================================================================
#
# BASELINE 1 (Restricted):
# - Exclude failed banks (failed_bank == 1)
# - Exclude GSIBs (gsib == 1)
# - Require OMO-eligible assets > 0
# - Focus on "regular" banks that could meaningfully choose BTFP
#
# BASELINE 2 (Full):
# - Include all banks with valid data
# - No filtering except valid total_asset > 0
# - Broader sample for robustness
# ==========================================================================
cat("\n=== CREATING DUAL BASELINES ===\n")
#>
#> === CREATING DUAL BASELINES ===
## Common transformation function
prepare_baseline_vars <- function(data) {
# --- FIX: Ensure columns exist before the pipe ---
# We check the schema first. If columns are missing, we create them
# with the correct default values (0 for flags, NA for categories).
if (!"failed_bank" %in% names(data)) data$failed_bank <- 0
if (!"gsib" %in% names(data)) data$gsib <- 0
if (!"size_bin" %in% names(data)) data$size_bin <- NA_character_
data %>%
transmute(
idrssd = as.character(idrssd),
failed_bank, # Safe to select now because we ensured it exists above
gsib,
size_bin,
# Assets and liabilities
total_asset, total_liability, total_equity, total_deposit,
uninsured_deposit,
insured_deposit = pmax(insured_deposit, 1),
uninsured_deposit_to_total_asset,
# Size
ln_assets = log(pmax(total_asset, 1)),
assets = total_asset,
# Liquid assets
cash, fed_fund_sold, rerepo,
# Securities
security, omo_eligible, non_omo_eligible,
omo_eligible_to_total_asset, non_omo_eligible_to_total_asset,
# Loans and profitability
total_loan, roa,
# Market value and MTM
mv_asset = mm_asset,
mtm_total_loss, mtm_loss_to_total_asset, equity_after_mtm,
mtm_loss_omo_eligible, mtm_loss_omo_eligible_to_total_asset,
mtm_loss_omo_eligible_to_omo_eligible,
mtm_loss_non_omo_eligible, mtm_loss_non_omo_eligible_to_total_asset,
# Funding
repo, fed_fund_purchase, other_borr, other_borrowed_less_than_1yr,
fhlb_adv, fhlb_to_total_asset,
# Ratios
cash_to_total_asset, security_to_total_asset,
book_equity_to_total_asset, loan_to_deposit
)
}
cat("\n=== CREATING DUAL BASELINES (FIXED) ===\n")
#>
#> === CREATING DUAL BASELINES (FIXED) ===
## BASELINE 1: Restricted
baseline_1 <- call_q %>%
filter(quarter == BASELINE_DATE) %>%
prepare_baseline_vars() %>%
filter(
(gsib == 0 | is.na(gsib)),
(failed_bank == 0 | is.na(failed_bank)),
!is.na(omo_eligible) & omo_eligible > 0
)
cat("✓ BASELINE 1 (Restricted) created\n")
#> ✓ BASELINE 1 (Restricted) created
cat(" Sample size:", nrow(baseline_1), "banks\n")
#> Sample size: 4292 banks
## BASELINE 2: Full
baseline_2 <- call_q %>%
filter(quarter == BASELINE_DATE) %>%
prepare_baseline_vars() %>%
filter(!is.na(total_asset) & total_asset > 0)
cat("✓ BASELINE 2 (Full) created\n")
#> ✓ BASELINE 2 (Full) created
cat(" Sample size:", nrow(baseline_2), "banks\n")
#> Sample size: 4737 banks
cat(" Includes:\n")
#> Includes:
cat(" - GSIBs:", sum(baseline_2$gsib == 1, na.rm = TRUE), "\n")
#> - GSIBs: 33
cat(" - Failed banks:", sum(baseline_2$failed_bank == 1, na.rm = TRUE), "\n")
#> - Failed banks: 8
cat("\n✓ Dual baselines created successfully\n")
#>
#> ✓ Dual baselines created successfully
1.9 Construct Analysis Variables
# ==========================================================================
# CONSTRUCT ANALYSIS VARIABLES - Apply to both baselines
# ==========================================================================
cat("\n=== CONSTRUCTING ANALYSIS VARIABLES ===\n")
#>
#> === CONSTRUCTING ANALYSIS VARIABLES ===
construct_analysis_vars <- function(data) {
data %>%
mutate(
# Core selection variables
mtm_btfp = mtm_loss_omo_eligible_to_total_asset,
mtm_other = mtm_loss_non_omo_eligible_to_total_asset,
uninsured_lev = uninsured_deposit_to_total_asset,
eligible_collateral = omo_eligible_to_total_asset,
borrowing_subsidy = mtm_loss_omo_eligible_to_omo_eligible,
pct_uninsured = safe_div(uninsured_deposit, total_deposit) * 100,
pct_wholesale_liability = safe_div(fed_fund_purchase + repo + other_borrowed_less_than_1yr, total_liability) * 100,
pct_runable_liability = safe_div(uninsured_deposit + fed_fund_purchase + repo + other_borrowed_less_than_1yr, total_liability) * 100,
pct_liquidity_available = safe_div(cash + rerepo + fed_fund_sold, total_asset) * 100,
pct_mtm_loss = mtm_loss_to_total_asset,
cash_ratio = cash_to_total_asset,
securities_ratio = security_to_total_asset,
equity_ratio = safe_div(total_equity, total_asset) * 100,
book_equity_ratio = book_equity_to_total_asset,
fhlb_ratio = fhlb_to_total_asset,
loan_to_deposit = loan_to_deposit,
run_risk_1 = pct_uninsured * pct_mtm_loss,
run_risk_2 = pct_runable_liability * pct_mtm_loss
) %>%
# Calculate medians for dummy variables
mutate(
median_pct_uninsured = median(pct_uninsured, na.rm = TRUE),
median_pct_mtm_loss = median(pct_mtm_loss, na.rm = TRUE),
median_pct_runable = median(pct_runable_liability, na.rm = TRUE),
run_risk_1_dummy = as.integer(pct_uninsured > median_pct_uninsured & pct_mtm_loss > median_pct_mtm_loss),
run_risk_2_dummy = as.integer(pct_runable_liability > median_pct_runable & pct_mtm_loss > median_pct_mtm_loss)
) %>%
# Jiang insolvency measures
mutate(
mv_adjustment = if_else(mv_asset == 0 | is.na(mv_asset), NA_real_, (total_asset / mv_asset) - 1),
idcr_1 = safe_div(mv_asset - 0.5 * uninsured_deposit - insured_deposit, insured_deposit),
idcr_2 = safe_div(mv_asset - 1.0 * uninsured_deposit - insured_deposit, insured_deposit),
insolvency_1 = safe_div((total_asset - total_liability) - 0.5 * uninsured_deposit * mv_adjustment, total_asset),
insolvency_2 = safe_div((total_asset - total_liability) - 1.0 * uninsured_deposit * mv_adjustment, total_asset),
adjusted_equity = equity_ratio - mtm_loss_to_total_asset,
mtm_insolvent = as.integer(adjusted_equity < 0) * 100,
insolvent_idcr_s50 = as.integer(idcr_1 < 0),
insolvent_idcr_s100 = as.integer(idcr_2 < 0),
insolvent_cap_s50 = as.integer(insolvency_1 < 0),
insolvent_cap_s100 = as.integer(insolvency_2 < 0)
) %>%
# Interaction terms
mutate(
mtm_btfp_x_uninsured = mtm_btfp * uninsured_lev,
adj_equity_x_uninsured = adjusted_equity * uninsured_lev
)
}
## Apply to both baselines
baseline_1 <- construct_analysis_vars(baseline_1)
baseline_2 <- construct_analysis_vars(baseline_2)
baseline <- baseline_1 # Default
cat("✓ Analysis variables constructed\n")
#> ✓ Analysis variables constructed
cat(" Baseline 1:", nrow(baseline_1), "banks with", ncol(baseline_1), "variables\n")
#> Baseline 1: 4292 banks with 77 variables
cat(" Baseline 2:", nrow(baseline_2), "banks with", ncol(baseline_2), "variables\n")
#> Baseline 2: 4737 banks with 77 variables
1.10 Aggregate Facility Usage
# ==========================================================================
# AGGREGATE FACILITY USAGE BY BANK
# ==========================================================================
cat("\n=== AGGREGATING FACILITY USAGE ===\n")
#>
#> === AGGREGATING FACILITY USAGE ===
## Full program period (post-BTFP launch)
btfp_full <- btfp_raw %>%
filter(btfp_loan_date >= CRISIS_START, btfp_loan_date <= BTFP_CLOSE) %>%
group_by(rssd_id) %>%
summarise(
btfp = 1L,
btfp_amount = sum(btfp_loan_amount, na.rm = TRUE),
btfp_first_date = min(btfp_loan_date),
btfp_n_loans = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
dw_full <- dw_raw %>%
filter(dw_loan_date >= CRISIS_START, dw_loan_date <= BTFP_CLOSE) %>%
group_by(rssd_id) %>%
summarise(
dw = 1L,
dw_amount = sum(dw_loan_amount, na.rm = TRUE),
dw_first_date = min(dw_loan_date),
dw_n_loans = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
## Pre-BTFP period (baseline DW usage)
dw_pre_btfp <- dw_raw %>%
filter(dw_loan_date >= PRE_BTFP_START, dw_loan_date <= PRE_BTFP_END) %>%
group_by(rssd_id) %>%
summarise(
dw_pre_btfp = 1L,
dw_pre_btfp_amount = sum(dw_loan_amount, na.rm = TRUE),
dw_pre_btfp_first = min(dw_loan_date),
dw_pre_btfp_n = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
cat("✓ Facility usage aggregated\n")
#> ✓ Facility usage aggregated
cat(" BTFP users (full program):", nrow(btfp_full), "banks\n")
#> BTFP users (full program): 1327 banks
cat(" DW users (post-BTFP):", nrow(dw_full), "banks\n")
#> DW users (post-BTFP): 1092 banks
cat(" DW users (pre-BTFP):", nrow(dw_pre_btfp), "banks\n")
#> DW users (pre-BTFP): 633 banks
1.11 Aggregate by OLD Period Definitions
# ==========================================================================
# AGGREGATE FACILITY USAGE BY OLD PERIOD DEFINITIONS
# (Acute, Post-Acute, Arbitrage)
# ==========================================================================
cat("\n=== AGGREGATING BY OLD PERIODS ===\n")
#>
#> === AGGREGATING BY OLD PERIODS ===
## BTFP by old periods
btfp_acute_old <- btfp_raw %>%
filter(btfp_loan_date >= CRISIS_START, btfp_loan_date <= PERIOD_1_END) %>%
group_by(rssd_id) %>%
summarise(
btfp_acute = 1L,
btfp_acute_amount = sum(btfp_loan_amount, na.rm = TRUE),
btfp_acute_first = min(btfp_loan_date),
btfp_acute_n = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
btfp_post_old <- btfp_raw %>%
filter(btfp_loan_date > PERIOD_1_END, btfp_loan_date <= PERIOD_2_END) %>%
group_by(rssd_id) %>%
summarise(
btfp_post = 1L,
btfp_post_amount = sum(btfp_loan_amount, na.rm = TRUE),
btfp_post_first = min(btfp_loan_date),
btfp_post_n = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
btfp_arb_old <- btfp_raw %>%
filter(btfp_loan_date > PERIOD_2_END, btfp_loan_date <= PERIOD_3_END) %>%
group_by(rssd_id) %>%
summarise(
btfp_arb = 1L,
btfp_arb_amount = sum(btfp_loan_amount, na.rm = TRUE),
btfp_arb_first = min(btfp_loan_date),
btfp_arb_n = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
## DW by old periods
dw_acute_old <- dw_raw %>%
filter(dw_loan_date >= CRISIS_START, dw_loan_date <= PERIOD_1_END) %>%
group_by(rssd_id) %>%
summarise(
dw_acute = 1L,
dw_acute_amount = sum(dw_loan_amount, na.rm = TRUE),
dw_acute_first = min(dw_loan_date),
dw_acute_n = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
dw_post_old <- dw_raw %>%
filter(dw_loan_date > PERIOD_1_END, dw_loan_date <= PERIOD_2_END) %>%
group_by(rssd_id) %>%
summarise(
dw_post = 1L,
dw_post_amount = sum(dw_loan_amount, na.rm = TRUE),
dw_post_first = min(dw_loan_date),
dw_post_n = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
cat("✓ Old period aggregation complete\n")
#> ✓ Old period aggregation complete
cat(" BTFP Acute:", nrow(btfp_acute_old), "| Post-Acute:", nrow(btfp_post_old), "| Arbitrage:", nrow(btfp_arb_old), "\n")
#> BTFP Acute: 492 | Post-Acute: 816 | Arbitrage: 801
cat(" DW Acute:", nrow(dw_acute_old), "| Post-Acute:", nrow(dw_post_old), "\n")
#> DW Acute: 424 | Post-Acute: 846
1.12 Aggregate by NEW Period Definitions
# ==========================================================================
# AGGREGATE FACILITY USAGE BY NEW PERIOD DEFINITIONS
# (P0-P6)
# ==========================================================================
cat("\n=== AGGREGATING BY NEW PERIODS ===\n")
#>
#> === AGGREGATING BY NEW PERIODS ===
## BTFP by new periods
btfp_p1 <- btfp_raw %>%
filter(btfp_loan_date >= CRISIS_START, btfp_loan_date <= WEEK1_END) %>%
group_by(rssd_id) %>%
summarise(
btfp_p1 = 1L,
btfp_p1_amount = sum(btfp_loan_amount, na.rm = TRUE),
btfp_p1_first = min(btfp_loan_date),
btfp_p1_n = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
btfp_p2 <- btfp_raw %>%
filter(btfp_loan_date > WEEK1_END, btfp_loan_date <= CRISIS_MONTH_END) %>%
group_by(rssd_id) %>%
summarise(
btfp_p2 = 1L,
btfp_p2_amount = sum(btfp_loan_amount, na.rm = TRUE),
btfp_p2_first = min(btfp_loan_date),
btfp_p2_n = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
btfp_p3 <- btfp_raw %>%
filter(btfp_loan_date >= FRC_FAIL, btfp_loan_date <= MAY_END) %>%
group_by(rssd_id) %>%
summarise(
btfp_p3 = 1L,
btfp_p3_amount = sum(btfp_loan_amount, na.rm = TRUE),
btfp_p3_first = min(btfp_loan_date),
btfp_p3_n = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
btfp_p4 <- btfp_raw %>%
filter(btfp_loan_date >= SUMMER_START, btfp_loan_date <= DW_DATA_END) %>%
group_by(rssd_id) %>%
summarise(
btfp_p4 = 1L,
btfp_p4_amount = sum(btfp_loan_amount, na.rm = TRUE),
btfp_p4_first = min(btfp_loan_date),
btfp_p4_n = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
btfp_p5 <- btfp_raw %>%
filter(btfp_loan_date >= ARBITRAGE_START, btfp_loan_date <= ARBITRAGE_END) %>%
group_by(rssd_id) %>%
summarise(
btfp_p5 = 1L,
btfp_p5_amount = sum(btfp_loan_amount, na.rm = TRUE),
btfp_p5_first = min(btfp_loan_date),
btfp_p5_n = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
btfp_p6 <- btfp_raw %>%
filter(btfp_loan_date > ARBITRAGE_END, btfp_loan_date <= BTFP_CLOSE) %>%
group_by(rssd_id) %>%
summarise(
btfp_p6 = 1L,
btfp_p6_amount = sum(btfp_loan_amount, na.rm = TRUE),
btfp_p6_first = min(btfp_loan_date),
btfp_p6_n = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
## DW by new periods (only P1-P4, no data after Sep 30)
dw_p1 <- dw_raw %>%
filter(dw_loan_date >= CRISIS_START, dw_loan_date <= WEEK1_END) %>%
group_by(rssd_id) %>%
summarise(
dw_p1 = 1L,
dw_p1_amount = sum(dw_loan_amount, na.rm = TRUE),
dw_p1_first = min(dw_loan_date),
dw_p1_n = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
dw_p2 <- dw_raw %>%
filter(dw_loan_date > WEEK1_END, dw_loan_date <= CRISIS_MONTH_END) %>%
group_by(rssd_id) %>%
summarise(
dw_p2 = 1L,
dw_p2_amount = sum(dw_loan_amount, na.rm = TRUE),
dw_p2_first = min(dw_loan_date),
dw_p2_n = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
dw_p3 <- dw_raw %>%
filter(dw_loan_date >= FRC_FAIL, dw_loan_date <= MAY_END) %>%
group_by(rssd_id) %>%
summarise(
dw_p3 = 1L,
dw_p3_amount = sum(dw_loan_amount, na.rm = TRUE),
dw_p3_first = min(dw_loan_date),
dw_p3_n = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
dw_p4 <- dw_raw %>%
filter(dw_loan_date >= SUMMER_START, dw_loan_date <= DW_DATA_END) %>%
group_by(rssd_id) %>%
summarise(
dw_p4 = 1L,
dw_p4_amount = sum(dw_loan_amount, na.rm = TRUE),
dw_p4_first = min(dw_loan_date),
dw_p4_n = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
cat("✓ New period aggregation complete\n")
#> ✓ New period aggregation complete
cat(" BTFP: P1=", nrow(btfp_p1), "| P2=", nrow(btfp_p2), "| P3=", nrow(btfp_p3),
"| P4=", nrow(btfp_p4), "| P5=", nrow(btfp_p5), "| P6=", nrow(btfp_p6), "\n")
#> BTFP: P1= 87 | P2= 451 | P3= 424 | P4= 482 | P5= 801 | P6= 240
cat(" DW: P1=", nrow(dw_p1), "| P2=", nrow(dw_p2), "| P3=", nrow(dw_p3), "| P4=", nrow(dw_p4), "\n")
#> DW: P1= 169 | P2= 319 | P3= 246 | P4= 728
cat(" (Note: No DW data for P5-P6)\n")
#> (Note: No DW data for P5-P6)
1.13 Create Final Analysis Datasets
# ==========================================================================
# MERGE ALL DATA TO CREATE FINAL ANALYSIS DATASETS
# ==========================================================================
cat("\n=== CREATING FINAL ANALYSIS DATASETS ===\n")
#>
#> === CREATING FINAL ANALYSIS DATASETS ===
## Function to create complete analysis dataset from baseline
create_analysis_dataset <- function(baseline_data, baseline_name) {
result <- baseline_data %>%
# Merge full program usage
left_join(btfp_full, by = "idrssd") %>%
left_join(dw_full, by = "idrssd") %>%
left_join(dw_pre_btfp, by = "idrssd") %>%
# Merge old period definitions
left_join(btfp_acute_old, by = "idrssd") %>%
left_join(btfp_post_old, by = "idrssd") %>%
left_join(btfp_arb_old, by = "idrssd") %>%
left_join(dw_acute_old, by = "idrssd") %>%
left_join(dw_post_old, by = "idrssd") %>%
# Merge new period definitions
left_join(btfp_p1, by = "idrssd") %>%
left_join(btfp_p2, by = "idrssd") %>%
left_join(btfp_p3, by = "idrssd") %>%
left_join(btfp_p4, by = "idrssd") %>%
left_join(btfp_p5, by = "idrssd") %>%
left_join(btfp_p6, by = "idrssd") %>%
left_join(dw_p1, by = "idrssd") %>%
left_join(dw_p2, by = "idrssd") %>%
left_join(dw_p3, by = "idrssd") %>%
left_join(dw_p4, by = "idrssd") %>%
# Replace NA with 0 for binary indicators
mutate(across(c(btfp, dw, dw_pre_btfp,
btfp_acute, btfp_post, btfp_arb, dw_acute, dw_post,
btfp_p1, btfp_p2, btfp_p3, btfp_p4, btfp_p5, btfp_p6,
dw_p1, dw_p2, dw_p3, dw_p4),
~coalesce(as.integer(.), 0L))) %>%
# Create facility choice variables
mutate(
both = as.integer(btfp == 1 & dw == 1),
btfp_only = as.integer(btfp == 1 & dw == 0),
dw_only = as.integer(btfp == 0 & dw == 1),
neither = as.integer(btfp == 0 & dw == 0),
any_fed = as.integer(btfp == 1 | dw == 1),
facility = case_when(
both == 1 ~ "Both",
btfp_only == 1 ~ "BTFP Only",
dw_only == 1 ~ "DW Only",
TRUE ~ "Neither"
),
facility = factor(facility, levels = c("BTFP Only", "DW Only", "Both", "Neither"))
) %>%
# Add period-specific both indicators (OLD periods)
mutate(
both_acute = as.integer(btfp_acute == 1 & dw_acute == 1),
both_post = as.integer(btfp_post == 1 & dw_post == 1),
both_arb = as.integer((btfp_arb == 1 | btfp_p5 == 1 | btfp_p6 == 1) & dw_post == 1),
# NEW period both indicators
both_p1 = as.integer(btfp_p1 == 1 & dw_p1 == 1),
both_p2 = as.integer(btfp_p2 == 1 & dw_p2 == 1),
both_p3 = as.integer(btfp_p3 == 1 & dw_p3 == 1),
both_p4 = as.integer(btfp_p4 == 1 & dw_p4 == 1)
) %>%
# Borrowing amounts and percentages
mutate(
d_assets = assets * 1000,
btfp_amount_pct = safe_div(btfp_amount, d_assets) * 100,
dw_amount_pct = safe_div(dw_amount, d_assets) * 100,
total_borrowed = btfp_amount + dw_amount,
total_borrowed_pct = safe_div(total_borrowed, d_assets) * 100,
# OLD period amounts
btfp_acute_amount_pct = safe_div(btfp_acute_amount, d_assets) * 100,
btfp_post_amount_pct = safe_div(btfp_post_amount, d_assets) * 100,
btfp_arb_amount_pct = safe_div(btfp_arb_amount, d_assets) * 100,
dw_acute_amount_pct = safe_div(dw_acute_amount, d_assets) * 100,
dw_post_amount_pct = safe_div(dw_post_amount, d_assets) * 100,
dw_pre_btfp_amount_pct = safe_div(dw_pre_btfp_amount, d_assets) * 100,
# NEW period amounts (P1-P6)
btfp_p1_amount_pct = safe_div(btfp_p1_amount, d_assets) * 100,
btfp_p2_amount_pct = safe_div(btfp_p2_amount, d_assets) * 100,
btfp_p3_amount_pct = safe_div(btfp_p3_amount, d_assets) * 100,
btfp_p4_amount_pct = safe_div(btfp_p4_amount, d_assets) * 100,
btfp_p5_amount_pct = safe_div(btfp_p5_amount, d_assets) * 100,
btfp_p6_amount_pct = safe_div(btfp_p6_amount, d_assets) * 100,
dw_p1_amount_pct = safe_div(dw_p1_amount, d_assets) * 100,
dw_p2_amount_pct = safe_div(dw_p2_amount, d_assets) * 100,
dw_p3_amount_pct = safe_div(dw_p3_amount, d_assets) * 100,
# OLD period shares
btfp_share_acute = ifelse(both_acute == 1,
safe_div(btfp_acute_amount, btfp_acute_amount + dw_acute_amount) * 100,
NA_real_),
btfp_share_post = ifelse(both_post == 1,
safe_div(btfp_post_amount, btfp_post_amount + dw_post_amount) * 100,
NA_real_),
# NEW period shares
btfp_share_p1 = ifelse(both_p1 == 1,
safe_div(btfp_p1_amount, btfp_p1_amount + dw_p1_amount) * 100,
NA_real_),
btfp_share_p2 = ifelse(both_p2 == 1,
safe_div(btfp_p2_amount, btfp_p2_amount + dw_p2_amount) * 100,
NA_real_),
btfp_share_p3 = ifelse(both_p3 == 1,
safe_div(btfp_p3_amount, btfp_p3_amount + dw_p3_amount) * 100,
NA_real_),
# Utilization Calculations
collateral_capacity = (eligible_collateral / 100) * d_assets,
# Overall Utilization
btfp_utilization = safe_div(btfp_amount, collateral_capacity),
maxed_out_btfp = as.integer(btfp_utilization > 0.90),
# Period Utilization (OLD)
btfp_util_acute = safe_div(btfp_acute_amount, collateral_capacity),
btfp_util_post = safe_div(btfp_post_amount, collateral_capacity),
btfp_util_arb = safe_div(btfp_arb_amount, collateral_capacity),
# Period Utilization (NEW)
btfp_util_p1 = safe_div(btfp_p1_amount, collateral_capacity),
btfp_util_p2 = safe_div(btfp_p2_amount, collateral_capacity),
btfp_util_p3 = safe_div(btfp_p3_amount, collateral_capacity),
btfp_util_p4 = safe_div(btfp_p4_amount, collateral_capacity),
btfp_util_p5 = safe_div(btfp_p5_amount, collateral_capacity),
btfp_util_p6 = safe_div(btfp_p6_amount, collateral_capacity)
)
return(result)
}
## Create both datasets
df_1 <- create_analysis_dataset(baseline_1, "Baseline 1")
df_2 <- create_analysis_dataset(baseline_2, "Baseline 2")
df <- df_1 # Default dataset
cat("✓ Final analysis datasets created\n")
#> ✓ Final analysis datasets created
cat(" df_1 (Baseline 1):", nrow(df_1), "banks\n")
#> df_1 (Baseline 1): 4292 banks
cat(" df_2 (Baseline 2):", nrow(df_2), "banks\n")
#> df_2 (Baseline 2): 4737 banks
cat("\n")
cat("Facility usage summary (Baseline 1):\n")
#> Facility usage summary (Baseline 1):
print(table(df_1$facility))
#>
#> BTFP Only DW Only Both Neither
#> 846 591 413 2442
cat("\n")
cat("Facility usage summary (Baseline 2):\n")
#> Facility usage summary (Baseline 2):
print(table(df_2$facility))
#>
#> BTFP Only DW Only Both Neither
#> 881 647 435 2774
cat("\n")
cat(strrep("=", 80), "\n")
#> ================================================================================
cat("✓✓✓ PART I COMPLETE: Setup, Data Loading, and Period Definitions ✓✓✓\n")
#> ✓✓✓ PART I COMPLETE: Setup, Data Loading, and Period Definitions ✓✓✓
cat(strrep("=", 80), "\n")
#> ================================================================================
Descriptive Statistics: Asset and Liability Composition
################################################################################
# ASSET AND LIABILITY COMPOSITION TABLES
################################################################################
cat("\n")
cat(strrep("=", 80), "\n", sep = "")
#> ================================================================================
cat("ASSET AND LIABILITY COMPOSITION TABLES\n")
#> ASSET AND LIABILITY COMPOSITION TABLES
cat(strrep("=", 80), "\n", sep = "")
#> ================================================================================
cat("\nGenerating descriptive tables for 2022Q4 and 2023Q1\n\n")
#>
#> Generating descriptive tables for 2022Q4 and 2023Q1
# Helper function for winsorization at 5-95 percentiles
winsorize_5_95 <- function(x) {
if (all(is.na(x))) return(x)
q <- quantile(x, probs = c(0.05, 0.95), na.rm = TRUE, names = FALSE)
# Clip values outside the 5th-95th range
pmax(pmin(x, q[2]), q[1])
}
# Helper to safely sum columns (treating NA as 0)
safe_sum <- function(...) {
rowSums(cbind(...), na.rm = TRUE)
}
# Asset Configuration
ASSET_CONFIG <- list(
list("Cash", "cash"),
list("Securities", "security"),
list("\\quad Treasury", "treasury"),
list("\\quad RMBS", "total_rmbs"),
list("\\quad CMBS", "total_cmbs"),
list("\\quad ABS", "abs"),
list("\\quad Other Securities", "other_security"), # Residual
list("Total Loans", "total_loan"),
list("\\quad Real Estate Loans", "reloan"),
list("\\quad\\quad Residential Mortgage", "reloan_residential1to4"),
list("\\quad\\quad Commercial Mortgage", "reloan_residential5"),
list("\\quad\\quad Other Real Estate", "other_re_residual"), # Residual
list("\\quad Agricultural Loans", "agloan"),
list("\\quad Commercial & Industrial", "ciloan"),
list("\\quad Consumer Loans", "hhloan"),
list("\\quad Loans to Non-Depositories", "loans_to_nonbank"),
list("Fed Funds Sold", "fed_fund_sold"),
list("Reverse Repo", "rerepo")
)
# Liability Configuration
LIAB_CONFIG <- list(
list("Total Liabilities", "r_total_liability"),
list("Domestic Deposits", "r_dom_deposit"),
list("\\quad Insured Deposits", "r_insured_deposit"),
list("\\quad Uninsured Deposits", "r_uninsured_deposit"),
list("\\quad\\quad Uninsured Time Deposits (Total)", "r_uninsured_tot_time_deposit"),
list("\\quad\\quad\\quad Long-term Time Deposits", "r_uninsured_long_time_account"),
list("\\quad\\quad\\quad Short-term Time Deposits", "r_uninsured_short_time_deposit"),
list("Foreign Deposits", "r_foreign_deposit"),
list("Fed Funds Purchased", "r_fed_fund_purchase"),
list("Repo", "r_repo"),
list("Other Liabilities", "r_other_liab"),
list("Total Equity", "r_total_equity"),
list("\\quad Common Stock", "r_common_stock"),
list("\\quad Preferred Stock", "r_preferred_stock"),
list("\\quad Retained Earnings", "r_retained_earning")
)
# Function to prepare data (calculate residuals and ensure grouping)
prepare_data <- function(df) {
# --- 1. Pre-calculation helpers ---
# Get column or 0 if missing
get_col <- function(var) if(var %in% names(df)) df[[var]] else 0
# --- 2. Create Raw Components needed for Residuals ---
# These sums match the "Strict Jiang" definition in the Python notebook
# ABS = HTM Amortized + HFS Fair
abs_val <- safe_sum(get_col("abs_htm_amortize"), get_col("abs_hfs_fair"))
# RMBS = Agency (HTM+HFS) + Other (HTM+HFS)
rmbs_val <- safe_sum(get_col("agency_rmbs_htm_amortize"), get_col("agency_rmbs_hfs_fair"),
get_col("other_rmbs_htm_amortize"), get_col("other_rmbs_hfs_fair"))
# CMBS = Agency (HTM+HFS) + Other (HTM+HFS)
cmbs_val <- safe_sum(get_col("agency_cmbs_htm_amortize"), get_col("agency_cmbs_hfs_fair"),
get_col("other_cmbs_htm_amortize"), get_col("other_cmbs_hfs_fair"))
df %>%
mutate(
# --- Categories ---
bank_category = case_when(
size_bin == "small" ~ "Small",
size_bin == "large" ~ "Large",
size_bin == "gsib" ~ "GSIB",
TRUE ~ NA_character_
),
# --- Assign Constructed Variables ---
abs = abs_val,
total_rmbs = rmbs_val,
total_cmbs = cmbs_val,
# --- Calculate Asset Residuals ---
# Other Securities = Security - (Treasury + RMBS + CMBS + ABS)
other_security = security - safe_sum(treasury, rmbs_val, cmbs_val, abs_val),
# Other Real Estate = Reloan - (Res + Comm)
other_re_residual = reloan - safe_sum(reloan_residential1to4, reloan_residential5),
# --- Calculate Missing Liability Ratios (r_*) ---
# If these columns are missing, calculate them as: 100 * Raw / Total Assets
r_uninsured_long_time_account = if("r_uninsured_long_time_account" %in% names(.))
r_uninsured_long_time_account
else
100 * get_col("uninsured_long_time_account") / total_asset,
r_uninsured_short_time_deposit = if("r_uninsured_short_time_deposit" %in% names(.))
r_uninsured_short_time_deposit
else
100 * get_col("uninsured_short_time_deposit") / total_asset,
r_uninsured_tot_time_deposit = if("r_uninsured_tot_time_deposit" %in% names(.))
r_uninsured_tot_time_deposit
else
100 * safe_sum(get_col("uninsured_long_time_account"), get_col("uninsured_short_time_deposit")) / total_asset
)
}
# Apply preparation
df_2022Q4 <- prepare_data(call_q %>% filter(quarter == "2022Q4"))
df_2023Q1 <- prepare_data(call_q %>% filter(quarter == "2023Q1"))
cat("✓ Data Prepared successfully.\n")
#> ✓ Data Prepared successfully.
generate_jiang_table <- function(df, config, type = "asset") {
# --- 1. Calculate N (Counts) ---
n_total <- nrow(df)
n_small <- sum(df$bank_category == "Small", na.rm = TRUE)
n_large <- sum(df$bank_category == "Large", na.rm = TRUE)
n_gsib <- sum(df$bank_category == "GSIB", na.rm = TRUE)
# Initialize DataFrame with N row
stats_df <- data.frame(
Component = "Number of Banks",
Agg = format(n_total, big.mark=","),
Full = format(n_total, big.mark=","),
Small = format(n_small, big.mark=","),
Large = format(n_large, big.mark=","),
GSIB = format(n_gsib, big.mark=","),
stringsAsFactors = FALSE
)
total_asset_sum <- sum(df$total_asset, na.rm = TRUE)
# --- 2. Process Components ---
for (item in config) {
label <- item[[1]]
var_name <- item[[2]]
# Get Data
if (!var_name %in% names(df)) {
vals <- rep(0, nrow(df))
} else {
vals <- df[[var_name]]
}
# Standardize to Percentage
if (type == "asset") {
bank_ratios <- 100 * vals / df$total_asset
agg_val <- 100 * sum(vals, na.rm = TRUE) / total_asset_sum
} else {
bank_ratios <- vals
agg_val <- sum(vals * df$total_asset, na.rm = TRUE) / total_asset_sum
}
# GLOBAL WINSORIZATION
winsorized_ratios <- winsorize_5_95(bank_ratios)
# Calculate Stats on Winsorized Vector
calc_stat <- function(data_vec) {
if (length(data_vec) == 0) return(c(0, 0))
return(c(mean(data_vec, na.rm = TRUE), sd(data_vec, na.rm = TRUE)))
}
full_stats <- calc_stat(winsorized_ratios)
small_stats <- calc_stat(winsorized_ratios[df$bank_category == "Small"])
large_stats <- calc_stat(winsorized_ratios[df$bank_category == "Large"])
gsib_stats <- calc_stat(winsorized_ratios[df$bank_category == "GSIB"])
# Format Row
fmt <- function(s) sprintf("%.1f\n(%.1f)", s[1], s[2])
stats_df[nrow(stats_df) + 1, ] <- list(
Component = label,
Agg = sprintf("%.1f", agg_val),
Full = fmt(full_stats),
Small = fmt(small_stats),
Large = fmt(large_stats),
GSIB = fmt(gsib_stats)
)
}
return(stats_df)
}
render_table <- function(stats_df, title) {
stats_df %>%
kbl(caption = title,
col.names = c("", "Aggregate", "Full Sample", "Small", "Large", "GSIB"),
align = c("l", "c", "c", "c", "c", "c"),
escape = FALSE) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"), full_width = F) %>%
add_header_above(c(" " = 1, "(1)" = 1, "(2)" = 1, "(3)" = 1, "(4)" = 1, "(5)" = 1)) %>%
row_spec(0, bold = TRUE) %>%
# Add a line after the N row (row 1)
row_spec(1, hline_after = TRUE) %>%
footnote(general = "Values are percentages of total assets. Row 1 shows number of banks. Column (1) is aggregate. Columns (2)-(5) are bank-level averages. Standard deviations in parentheses. All bank-level statistics (Cols 2-5) are winsorized at the 5th and 95th percentiles.")
}
# --- 2022Q4 ---
asset_stats_22q4 <- generate_jiang_table(df_2022Q4, ASSET_CONFIG, type = "asset")
render_table(asset_stats_22q4, "Bank Asset Composition, 2022Q4")
Bank Asset Composition, 2022Q4
|
|
(1)
|
(2)
|
(3)
|
(4)
|
(5)
|
|
|
Aggregate
|
Full Sample
|
Small
|
Large
|
GSIB
|
|
Number of Banks
|
4,737
|
4,737
|
3,967
|
737
|
33
|
|
Cash
|
11.0
|
8.1 (7.4)
|
8.5 (7.5)
|
5.2 (5.6)
|
18.7 (10.1)
|
|
Securities
|
24.0
|
24.0 (14.9)
|
24.7 (15.2)
|
20.5 (12.2)
|
17.4 (17.4)
|
|
Treasury
|
6.0
|
3.3 (4.8)
|
3.5 (5.0)
|
2.3 (3.7)
|
5.1 (6.1)
|
|
RMBS
|
11.2
|
3.0 (4.3)
|
2.4 (3.9)
|
6.1 (5.1)
|
4.9 (6.1)
|
|
CMBS
|
1.8
|
0.8 (1.4)
|
0.6 (1.3)
|
1.3 (1.6)
|
0.8 (1.4)
|
|
ABS
|
3.1
|
1.0 (1.7)
|
0.9 (1.6)
|
1.5 (1.9)
|
1.4 (2.3)
|
|
Other Securities
|
1.9
|
14.5 (12.2)
|
15.9 (12.4)
|
7.4 (7.7)
|
2.3 (5.9)
|
|
Total Loans
|
51.0
|
60.8 (16.5)
|
59.7 (16.6)
|
67.4 (13.6)
|
43.6 (18.9)
|
|
Real Estate Loans
|
24.2
|
45.9 (18.3)
|
45.4 (18.2)
|
49.7 (17.4)
|
22.0 (18.6)
|
|
Residential Mortgage
|
11.7
|
17.3 (12.8)
|
17.7 (13.0)
|
15.6 (11.7)
|
11.8 (15.4)
|
|
Commercial Mortgage
|
2.5
|
2.3 (2.8)
|
2.0 (2.6)
|
4.0 (3.1)
|
1.1 (2.1)
|
|
Other Real Estate
|
10.0
|
24.8 (12.9)
|
24.5 (12.7)
|
27.9 (12.8)
|
4.3 (6.2)
|
|
Agricultural Loans
|
0.3
|
3.0 (4.8)
|
3.4 (5.1)
|
0.8 (2.1)
|
0.1 (0.4)
|
|
Commercial & Industrial
|
9.8
|
7.2 (5.4)
|
6.8 (5.1)
|
9.4 (6.4)
|
4.4 (5.9)
|
|
Consumer Loans
|
8.6
|
2.4 (2.7)
|
2.3 (2.5)
|
2.5 (3.4)
|
3.5 (4.3)
|
|
Loans to Non-Depositories
|
3.2
|
0.1 (0.2)
|
0.0 (0.2)
|
0.2 (0.3)
|
0.4 (0.4)
|
|
Fed Funds Sold
|
0.1
|
0.8 (1.8)
|
0.9 (1.9)
|
0.1 (0.6)
|
0.6 (1.9)
|
|
Reverse Repo
|
1.3
|
0.0 (0.0)
|
0.0 (0.0)
|
0.0 (0.0)
|
0.0 (0.0)
|
|
Note:
|
|
Values are percentages of total assets. Row 1 shows number
of banks. Column (1) is aggregate. Columns (2)-(5) are bank-level
averages. Standard deviations in parentheses. All bank-level statistics
(Cols 2-5) are winsorized at the 5th and 95th percentiles.
|
liab_stats_22q4 <- generate_jiang_table(df_2022Q4, LIAB_CONFIG, type = "liability")
render_table(liab_stats_22q4, "Bank Liability Composition, 2022Q4")
Bank Liability Composition, 2022Q4
|
|
(1)
|
(2)
|
(3)
|
(4)
|
(5)
|
|
|
Aggregate
|
Full Sample
|
Small
|
Large
|
GSIB
|
|
Number of Banks
|
4,737
|
4,737
|
3,967
|
737
|
33
|
|
Total Liabilities
|
90.6
|
90.3 (3.7)
|
90.3 (3.8)
|
90.4 (2.9)
|
86.9 (4.7)
|
|
Domestic Deposits
|
75.1
|
85.7 (6.4)
|
86.1 (6.4)
|
83.6 (5.7)
|
77.0 (7.9)
|
|
Insured Deposits
|
42.1
|
61.8 (12.7)
|
63.6 (11.9)
|
52.8 (12.0)
|
46.9 (18.4)
|
|
Uninsured Deposits
|
35.8
|
23.0 (11.0)
|
21.7 (10.4)
|
30.2 (11.0)
|
23.1 (17.0)
|
|
Uninsured Time Deposits (Total)
|
2.2
|
4.1 (3.4)
|
4.3 (3.4)
|
3.4 (3.0)
|
1.5 (2.4)
|
|
Long-term Time Deposits
|
0.3
|
1.1 (1.2)
|
1.1 (1.2)
|
0.8 (0.9)
|
0.1 (0.3)
|
|
Short-term Time Deposits
|
1.9
|
2.9 (2.6)
|
3.0 (2.6)
|
2.6 (2.4)
|
1.3 (2.2)
|
|
Foreign Deposits
|
6.3
|
0.0 (0.0)
|
0.0 (0.0)
|
0.0 (0.0)
|
0.0 (0.0)
|
|
Fed Funds Purchased
|
0.2
|
0.2 (0.5)
|
0.2 (0.5)
|
0.1 (0.4)
|
0.0 (0.0)
|
|
Repo
|
0.6
|
0.2 (0.7)
|
0.2 (0.6)
|
0.5 (0.9)
|
0.2 (0.6)
|
|
Other Liabilities
|
7.2
|
3.6 (4.0)
|
3.2 (3.9)
|
5.5 (4.1)
|
6.2 (4.4)
|
|
Total Equity
|
9.4
|
9.7 (3.7)
|
9.7 (3.8)
|
9.6 (2.9)
|
13.1 (4.7)
|
|
Common Stock
|
0.2
|
0.4 (0.6)
|
0.4 (0.6)
|
0.2 (0.6)
|
0.7 (1.0)
|
|
Preferred Stock
|
0.1
|
0.0 (0.0)
|
0.0 (0.0)
|
0.0 (0.0)
|
0.0 (0.0)
|
|
Retained Earnings
|
4.4
|
7.2 (4.2)
|
7.4 (4.3)
|
6.1 (3.2)
|
7.4 (5.3)
|
|
Note:
|
|
Values are percentages of total assets. Row 1 shows number
of banks. Column (1) is aggregate. Columns (2)-(5) are bank-level
averages. Standard deviations in parentheses. All bank-level statistics
(Cols 2-5) are winsorized at the 5th and 95th percentiles.
|
PART V: VISUALIZATIONS
This section contains all key figures and visualizations: -
Section 5.1: Historic DW Borrowing Pattern -
Section 5.2: March 2023 Daily Analysis -
Section 5.3: Daily Borrowing with Period Shading -
Section 5.4: Interest Rate Dynamics - Section
5.5: User Group Analysis - Section 5.6:
Collateral and Utilization Analysis - Section 5.7:
Regression-Related Visualizations
5.1 Figure 1: Historic DW Borrowing Pattern (Mar 2022 - Sep
2023)
# ==========================================================================
# FIGURE 1: HISTORIC DW BORROWING (MONTHLY, ALL BANKS)
# March 2022 to September 2023 - LINE GRAPH
# ==========================================================================
cat("\n=== PART V: VISUALIZATIONS ===\n")
#>
#> === PART V: VISUALIZATIONS ===
## Aggregate DW loans monthly (all banks)
dw_monthly <- dw_raw %>%
filter(dw_loan_date >= as.Date("2022-03-01"),
dw_loan_date <= as.Date("2023-09-30")) %>%
mutate(month = floor_date(dw_loan_date, "month")) %>%
group_by(month) %>%
summarise(
total_amount = sum(dw_loan_amount, na.rm = TRUE) / 1e9,
n_loans = n(),
n_banks = n_distinct(rssd_id),
avg_rate = weighted.mean(dw_interest_rate, dw_loan_amount, na.rm = TRUE),
.groups = "drop"
)
p_fig01 <- ggplot(dw_monthly, aes(x = month)) +
# Amount line
geom_line(aes(y = total_amount), color = facility_colors["DW"], linewidth = 1.2) +
geom_point(aes(y = total_amount), color = facility_colors["DW"], size = 2.5) +
# BTFP launch event
geom_vline(xintercept = as.Date("2023-03-13"), linetype = "dashed", color = "#2166ac", linewidth = 0.8) +
annotate("text", x = as.Date("2023-03-13"), y = max(dw_monthly$total_amount) * 0.95,
label = "BTFP Launch", hjust = -0.1, size = 3.5, fontface = "bold") +
scale_x_date(date_breaks = "2 months", date_labels = "%b %Y") +
scale_y_continuous(labels = scales::dollar_format(suffix = "B")) +
labs(
title = "Figure 1: Historic Discount Window Borrowing",
subtitle = "Monthly total borrowing volume (March 2022 - September 2023)",
x = NULL, y = "Total DW Borrowing"
) +
theme_pub()
print(p_fig01)
ggsave(file.path(FIG_PATH, "fig01_historic_dw_monthly.png"), p_fig01, width = 14, height = 8, dpi = 300, bg = "white")
5.2 Figure 2: Daily Loans in March 2023
# ==========================================================================
# FIGURE 2: DAILY LOANS FOR MARCH 2023 (ALL 31 DAYS)
# LINE GRAPH with event markers
# ==========================================================================
march_start <- as.Date("2023-03-01")
march_end <- as.Date("2023-03-31")
## BTFP daily
btfp_march <- btfp_raw %>%
filter(btfp_loan_date >= march_start, btfp_loan_date <= march_end) %>%
group_by(date = btfp_loan_date) %>%
summarise(amount = sum(btfp_loan_amount, na.rm = TRUE) / 1e9, .groups = "drop") %>%
mutate(facility = "BTFP")
## DW daily
dw_march <- dw_raw %>%
filter(dw_loan_date >= march_start, dw_loan_date <= march_end) %>%
group_by(date = dw_loan_date) %>%
summarise(amount = sum(dw_loan_amount, na.rm = TRUE) / 1e9, .groups = "drop") %>%
mutate(facility = "DW")
## Combine and complete dates
all_march_dates <- tibble(date = seq(march_start, march_end, by = "day"))
march_daily <- bind_rows(btfp_march, dw_march) %>%
complete(date = all_march_dates$date, facility, fill = list(amount = 0)) %>%
filter(!is.na(facility))
## Events
march_events <- tibble(
date = as.Date(c("2023-03-10", "2023-03-12", "2023-03-13")),
label = c("SVB Fails", "Signature Fails", "BTFP Launch")
)
p_fig02 <- ggplot(march_daily, aes(x = date, y = amount, color = facility)) +
geom_line(linewidth = 1.2) +
geom_point(size = 2) +
# Event lines
geom_vline(data = march_events, aes(xintercept = date),
linetype = "dashed", color = "gray40", linewidth = 0.7) +
geom_label(data = march_events, aes(x = date, y = max(march_daily$amount) * 0.9, label = label),
inherit.aes = FALSE, size = 3, hjust = 0, label.size = 0, fill = "white") +
scale_color_manual(values = facility_colors[c("BTFP", "DW")]) +
scale_x_date(date_breaks = "3 days", date_labels = "%b %d") +
scale_y_continuous(labels = scales::dollar_format(suffix = "B")) +
labs(
title = "Figure 2: Daily Emergency Borrowing in March 2023",
subtitle = "All banks | Key crisis events marked",
x = NULL, y = "Daily Borrowing Volume", color = "Facility"
) +
theme_pub() +
theme(legend.position = c(0.85, 0.85))
print(p_fig02)
ggsave(file.path(FIG_PATH, "fig02_march_daily.png"), p_fig02, width = 14, height = 8, dpi = 300, bg = "white")
5.3 Figure 3: Daily Borrowing with Period Shading (Mar 2023 - Mar
2024)
# ==========================================================================
# FIGURE 3: DAILY BORROWING (MAR 1, 2023 - MAR 11, 2024)
# Excluding failed banks and GSIBs
# NEW period definition shading, event lines
# ==========================================================================
## Get valid bank IDs (exclude failed and GSIB)
valid_banks <- baseline_1$idrssd
## BTFP daily
btfp_daily <- btfp_raw %>%
filter(btfp_loan_date >= as.Date("2023-03-01"),
btfp_loan_date <= BTFP_CLOSE,
rssd_id %in% valid_banks) %>%
group_by(date = btfp_loan_date) %>%
summarise(amount = sum(btfp_loan_amount, na.rm = TRUE) / 1e9, .groups = "drop") %>%
mutate(facility = "BTFP")
## DW daily
dw_daily <- dw_raw %>%
filter(dw_loan_date >= as.Date("2023-03-01"),
dw_loan_date <= DW_DATA_END,
rssd_id %in% valid_banks) %>%
group_by(date = dw_loan_date) %>%
summarise(amount = sum(dw_loan_amount, na.rm = TRUE) / 1e9, .groups = "drop") %>%
mutate(facility = "DW")
daily_combined <- bind_rows(btfp_daily, dw_daily)
## NEW Period rectangles
period_shading <- tibble(
xmin = as.Date(c("2023-03-13", "2023-03-20", "2023-05-01", "2023-06-01", "2023-11-01", "2024-01-25")),
xmax = as.Date(c("2023-03-19", "2023-04-30", "2023-05-31", "2023-09-30", "2024-01-24", "2024-03-11")),
period = c("P1: Week 1", "P2: Crisis Month", "P3: FRC May",
"P4: Stabilization", "P5: Arbitrage", "P6: Wind-down"),
fill = c("#d73027", "#fc8d59", "#fee08b", "#d9ef8b", "#91bfdb", "#4575b4")
)
## Key events
key_events <- tibble(
date = as.Date(c("2023-03-10", "2023-05-01", "2023-09-30", "2023-11-06", "2024-01-24")),
label = c("SVB Fails", "FRC Fails", "DW Data Ends", "Arb Window Opens", "BTFP Closes")
)
p_fig03 <- ggplot() +
# Period shading (use annotate for cleaner approach)
annotate("rect", xmin = period_shading$xmin, xmax = period_shading$xmax,
ymin = 0, ymax = Inf, fill = period_shading$fill, alpha = 0.25) +
# Daily borrowing lines
geom_line(data = daily_combined, aes(x = date, y = amount, color = facility), linewidth = 0.8) +
# Event lines
geom_vline(data = key_events, aes(xintercept = date),
linetype = "dashed", color = "gray30", linewidth = 0.5) +
# Event labels
geom_text(data = key_events, aes(x = date, y = max(daily_combined$amount, na.rm = TRUE) * 1.05, label = label),
angle = 90, hjust = 0, vjust = 0.5, size = 2.8) +
scale_color_manual(values = facility_colors[c("BTFP", "DW")], name = "Facility") +
scale_x_date(date_breaks = "1 month", date_labels = "%b\n%Y",
limits = c(as.Date("2023-03-01"), BTFP_CLOSE)) +
scale_y_continuous(labels = scales::dollar_format(suffix = "B"), expand = expansion(mult = c(0, 0.15))) +
labs(
title = "Figure 3: Daily Emergency Borrowing by Crisis Period",
subtitle = "March 2023 - March 2024 | Excludes GSIBs and failed banks | Shading = NEW period definitions",
x = NULL, y = "Daily Borrowing Volume",
caption = "Periods: P1=Week 1 (red), P2=Crisis Month (orange), P3=FRC May (yellow), P4=Stabilization (green), P5=Arbitrage (blue), P6=Wind-down (dark blue)"
) +
theme_pub() +
theme(legend.position = "bottom")
print(p_fig03)
ggsave(file.path(FIG_PATH, "fig03_daily_with_periods.png"), p_fig03, width = 16, height = 9, dpi = 300, bg = "white")
5.4 Figure 4: Interest Rate Dynamics (Mar 2023 - Mar 2024)
# ==========================================================================
# FIGURE 4: INTEREST RATE DIFFERENCES
# March 1, 2023 - March 11, 2024
# NEW period shading, event lines
# ==========================================================================
## Weekly average rates for BTFP
btfp_rates <- btfp_raw %>%
filter(btfp_loan_date >= as.Date("2023-03-01"),
btfp_loan_date <= BTFP_CLOSE) %>%
mutate(week = floor_date(btfp_loan_date, "week")) %>%
group_by(week) %>%
summarise(
avg_rate = weighted.mean(btfp_interest_rate, btfp_loan_amount, na.rm = TRUE),
.groups = "drop"
) %>%
mutate(facility = "BTFP")
## Weekly average rates for DW
dw_rates <- dw_raw %>%
filter(dw_loan_date >= as.Date("2023-03-01"),
dw_loan_date <= DW_DATA_END) %>%
mutate(week = floor_date(dw_loan_date, "week")) %>%
group_by(week) %>%
summarise(
avg_rate = weighted.mean(dw_interest_rate, dw_loan_amount, na.rm = TRUE),
.groups = "drop"
) %>%
mutate(facility = "DW")
weekly_rates <- bind_rows(btfp_rates, dw_rates)
## Rate events
rate_events <- tibble(
date = as.Date(c("2023-03-13", "2023-05-01", "2023-11-06")),
label = c("BTFP Launch", "FRC Fails", "Arb Window Opens")
)
p_fig04 <- ggplot() +
# Period shading using annotate
annotate("rect",
xmin = (period_shading %>% filter(xmax <= as.Date("2024-03-11")))$xmin,
xmax = (period_shading %>% filter(xmax <= as.Date("2024-03-11")))$xmax,
ymin = -Inf, ymax = Inf,
fill = (period_shading %>% filter(xmax <= as.Date("2024-03-11")))$fill,
alpha = 0.2) +
# Rate lines
geom_line(data = weekly_rates, aes(x = week, y = avg_rate, color = facility), linewidth = 1.2) +
geom_point(data = weekly_rates, aes(x = week, y = avg_rate, color = facility), size = 2) +
# Event lines
geom_vline(data = rate_events, aes(xintercept = date),
linetype = "dashed", color = "gray30", linewidth = 0.5) +
geom_text(data = rate_events, aes(x = date, y = max(weekly_rates$avg_rate, na.rm = TRUE) * 1.02, label = label),
angle = 90, hjust = 0, vjust = 0.5, size = 2.8) +
scale_color_manual(values = facility_colors[c("BTFP", "DW")], name = "Facility") +
scale_x_date(date_breaks = "1 month", date_labels = "%b\n%Y") +
scale_y_continuous(labels = function(x) paste0(x, "%")) +
labs(
title = "Figure 4: Weekly Average Interest Rates by Facility",
subtitle = "Weighted by loan amount | March 2023 - March 2024",
x = NULL, y = "Average Interest Rate",
caption = "Shading: P1=Week 1, P2=Crisis Month, P3=FRC May, P4=Stabilization, P5=Arbitrage, P6=Wind-down"
) +
theme_pub() +
theme(legend.position = "bottom")
print(p_fig04)
ggsave(file.path(FIG_PATH, "fig04_rate_dynamics.png"), p_fig04, width = 16, height = 9, dpi = 300, bg = "white")
5.5 Figure 5: Borrowing by User Group (Jan - Sep 2023)
# ==========================================================================
# FIGURE 5: BORROWING BY USER GROUP (DW Only, BTFP Only, Both)
# January 1, 2023 - September 30, 2023
# NEW period shading, event lines
# ==========================================================================
## Classify banks by facility usage (from df_1)
bank_groups <- df_1 %>%
select(idrssd, facility) %>%
filter(facility != "Neither")
## Weekly BTFP by user group
btfp_by_group <- btfp_raw %>%
filter(btfp_loan_date >= as.Date("2023-01-01"),
btfp_loan_date <= as.Date("2023-09-30"),
rssd_id %in% valid_banks) %>%
left_join(bank_groups %>% rename(rssd_id = idrssd), by = "rssd_id") %>%
filter(!is.na(facility)) %>%
mutate(week = floor_date(btfp_loan_date, "week")) %>%
group_by(week, facility) %>%
summarise(amount = sum(btfp_loan_amount, na.rm = TRUE) / 1e9, .groups = "drop") %>%
mutate(loan_type = "BTFP Loans")
## Weekly DW by user group
dw_by_group <- dw_raw %>%
filter(dw_loan_date >= as.Date("2023-01-01"),
dw_loan_date <= as.Date("2023-09-30"),
rssd_id %in% valid_banks) %>%
left_join(bank_groups %>% rename(rssd_id = idrssd), by = "rssd_id") %>%
filter(!is.na(facility)) %>%
mutate(week = floor_date(dw_loan_date, "week")) %>%
group_by(week, facility) %>%
summarise(amount = sum(dw_loan_amount, na.rm = TRUE) / 1e9, .groups = "drop") %>%
mutate(loan_type = "DW Loans")
## Combine
group_weekly <- bind_rows(btfp_by_group, dw_by_group) %>%
mutate(group_label = paste(facility, "-", loan_type))
## Subset period shading for this date range
period_shading_sub <- period_shading %>%
filter(xmin >= as.Date("2023-01-01"), xmax <= as.Date("2023-09-30"))
## Events
group_events <- tibble(
date = as.Date(c("2023-03-13", "2023-05-01")),
label = c("BTFP Launch", "FRC Fails")
)
p_fig05 <- ggplot() +
# Period shading using annotate
annotate("rect", xmin = period_shading_sub$xmin, xmax = period_shading_sub$xmax,
ymin = 0, ymax = Inf, fill = period_shading_sub$fill, alpha = 0.2) +
# Lines by group
geom_line(data = group_weekly,
aes(x = week, y = amount, color = facility, linetype = loan_type),
linewidth = 1) +
# Event lines
geom_vline(data = group_events, aes(xintercept = date),
linetype = "dashed", color = "gray30", linewidth = 0.5) +
geom_text(data = group_events,
aes(x = date, y = max(group_weekly$amount, na.rm = TRUE) * 1.05, label = label),
angle = 90, hjust = 0, vjust = 0.5, size = 3) +
scale_color_manual(values = c("BTFP Only" = "#2166ac", "DW Only" = "#b2182b", "Both" = "#762a83"),
name = "User Group") +
scale_linetype_manual(values = c("BTFP Loans" = "solid", "DW Loans" = "dashed"), name = "Loan Type") +
scale_x_date(date_breaks = "1 month", date_labels = "%b\n%Y",
limits = c(as.Date("2023-01-01"), as.Date("2023-09-30"))) +
scale_y_continuous(labels = scales::dollar_format(suffix = "B"), expand = expansion(mult = c(0, 0.15))) +
labs(
title = "Figure 5: Weekly Borrowing by User Group",
subtitle = "January - September 2023 | Banks classified by full-period facility usage",
x = NULL, y = "Weekly Borrowing Volume"
) +
theme_pub() +
theme(legend.position = "bottom", legend.box = "horizontal")
print(p_fig05)
ggsave(file.path(FIG_PATH, "fig05_user_groups.png"), p_fig05, width = 16, height = 9, dpi = 300, bg = "white")
5.6 Figure 6: Collateral and Utilization Analysis
# ==========================================================================
# FIGURE 6: PLEDGED COLLATERAL TYPES VS UTILIZATION
# January 1, 2023 - March 11, 2024
#
# Collateral variables:
# btfp_total_collateral = BTFP-eligible (OMO)
# dw_omo_eligible = BTFP-eligible pledged at DW
# dw_non_omo_eligible = Other collateral (DW only, subject to haircut)
#
# Par value, no haircut applied
# ==========================================================================
## Panel A: DW Collateral Composition (OMO vs Non-OMO)
dw_coll_weekly <- dw_raw %>%
filter(dw_loan_date >= as.Date("2023-01-01"),
dw_loan_date <= DW_DATA_END) %>%
mutate(week = floor_date(dw_loan_date, "week")) %>%
group_by(week) %>%
summarise(
omo_eligible = sum(dw_omo_eligible, na.rm = TRUE) / 1e9,
non_omo_eligible = sum(dw_non_omo_eligible, na.rm = TRUE) / 1e9,
total_collateral = sum(dw_total_collateral, na.rm = TRUE) / 1e9,
loan_amount = sum(dw_loan_amount, na.rm = TRUE) / 1e9,
.groups = "drop"
) %>%
mutate(utilization = loan_amount / total_collateral * 100)
## Reshape for stacked area
dw_coll_long <- dw_coll_weekly %>%
select(week, omo_eligible, non_omo_eligible) %>%
pivot_longer(cols = c(omo_eligible, non_omo_eligible),
names_to = "collateral_type", values_to = "amount") %>%
mutate(collateral_type = factor(collateral_type,
levels = c("non_omo_eligible", "omo_eligible"),
labels = c("Non-OMO (DW Only, w/ Haircut)", "OMO-Eligible (BTFP-Eligible)")))
p_coll_a <- ggplot(dw_coll_long, aes(x = week, y = amount, fill = collateral_type)) +
geom_area(alpha = 0.8) +
geom_vline(xintercept = as.Date("2023-03-13"), linetype = "dashed", color = "gray30") +
annotate("text", x = as.Date("2023-03-13"), y = max(dw_coll_weekly$total_collateral) * 0.9,
label = "BTFP Launch", hjust = -0.1, size = 3.5) +
scale_fill_manual(values = c("OMO-Eligible (BTFP-Eligible)" = "#2166ac",
"Non-OMO (DW Only, w/ Haircut)" = "#b2182b")) +
scale_x_date(date_breaks = "1 month", date_labels = "%b %Y") +
scale_y_continuous(labels = scales::dollar_format(suffix = "B")) +
labs(
title = "A: DW Collateral Composition (Par Value)",
subtitle = "Weekly pledged collateral by type | No haircuts applied",
x = NULL, y = "Collateral Pledged", fill = "Collateral Type"
) +
theme_pub() +
theme(legend.position = "bottom")
## Panel B: BTFP Collateral and Utilization
btfp_coll_weekly <- btfp_raw %>%
filter(btfp_loan_date >= as.Date("2023-01-01"),
btfp_loan_date <= BTFP_CLOSE) %>%
mutate(week = floor_date(btfp_loan_date, "week")) %>%
group_by(week) %>%
summarise(
collateral = sum(btfp_total_collateral, na.rm = TRUE) / 1e9,
loan_amount = sum(btfp_loan_amount, na.rm = TRUE) / 1e9,
.groups = "drop"
) %>%
mutate(utilization = loan_amount / collateral * 100)
p_coll_b <- ggplot(btfp_coll_weekly, aes(x = week)) +
# Collateral line
geom_line(aes(y = collateral, color = "Collateral Pledged"), linewidth = 1.2) +
geom_point(aes(y = collateral, color = "Collateral Pledged"), size = 2) +
# Loan amount line
geom_line(aes(y = loan_amount, color = "Loan Amount"), linewidth = 1.2) +
geom_point(aes(y = loan_amount, color = "Loan Amount"), size = 2) +
# Arbitrage window
geom_vline(xintercept = ARB_WINDOW_OPEN, linetype = "dashed", color = "#762a83", linewidth = 0.8) +
annotate("text", x = ARB_WINDOW_OPEN, y = max(btfp_coll_weekly$collateral) * 0.95,
label = "Arbitrage Window Opens", hjust = -0.05, size = 3.5, color = "#762a83") +
scale_color_manual(values = c("Collateral Pledged" = "#2166ac", "Loan Amount" = "#d73027")) +
scale_x_date(date_breaks = "2 months", date_labels = "%b %Y") +
scale_y_continuous(labels = scales::dollar_format(suffix = "B")) +
labs(
title = "B: BTFP Collateral and Borrowing (Par Value)",
subtitle = "Weekly pledged collateral vs loan amounts",
x = NULL, y = "Amount", color = NULL
) +
theme_pub() +
theme(legend.position = "bottom")
## Panel C: Utilization Rates by Facility
util_combined <- bind_rows(
btfp_coll_weekly %>% select(week, utilization) %>% mutate(facility = "BTFP"),
dw_coll_weekly %>% select(week, utilization) %>% mutate(facility = "DW")
)
p_coll_c <- ggplot(util_combined, aes(x = week, y = utilization, color = facility)) +
geom_line(linewidth = 1.2) +
geom_point(size = 2) +
geom_hline(yintercept = 100, linetype = "dotted", color = "gray50") +
annotate("text", x = min(util_combined$week), y = 102, label = "100% Utilization",
hjust = 0, size = 3, color = "gray50") +
# Arbitrage window
geom_vline(xintercept = ARB_WINDOW_OPEN, linetype = "dashed", color = "#762a83", linewidth = 0.8) +
scale_color_manual(values = facility_colors[c("BTFP", "DW")]) +
scale_x_date(date_breaks = "2 months", date_labels = "%b %Y") +
scale_y_continuous(labels = function(x) paste0(x, "%"), limits = c(0, NA)) +
labs(
title = "C: Collateral Utilization Rates",
subtitle = "Loan Amount / Collateral Pledged",
x = NULL, y = "Utilization Rate", color = "Facility"
) +
theme_pub() +
theme(legend.position = "bottom")
## Combine panels
p_fig06 <- (p_coll_a / p_coll_b / p_coll_c) +
plot_annotation(
title = "Figure 6: Collateral Analysis by Facility",
subtitle = "January 2023 - March 2024 | Par value (no haircuts)",
theme = theme(plot.title = element_text(face = "bold", size = 14),
plot.subtitle = element_text(size = 11))
)
print(p_fig06)
ggsave(file.path(FIG_PATH, "fig06_collateral_analysis.png"), p_fig06, width = 16, height = 12, dpi = 300, bg = "white")
5.7 Regression-Related Visualizations
5.7.3 Figure 9: Coefficient Comparison (BTFP vs DW)
# ==========================================================================
# FIGURE 9: COEFFICIENT COMPARISON
# From extensive margin regressions (BTFP vs DW)
# ==========================================================================
## Run models
base_formula <- "mtm_btfp + mtm_other + uninsured_lev + I(mtm_btfp * uninsured_lev) +
eligible_collateral + borrowing_subsidy + ln_assets + cash_ratio +
securities_ratio + roa + loan_to_deposit + book_equity_ratio"
lpm_btfp <- feols(as.formula(paste("btfp ~", base_formula)), data = df_1, vcov = "hetero")
lpm_dw <- feols(as.formula(paste("dw ~", base_formula)), data = df_1, vcov = "hetero")
## Extract and combine
coef_df <- bind_rows(
tidy(lpm_btfp, conf.int = TRUE) %>% mutate(model = "BTFP"),
tidy(lpm_dw, conf.int = TRUE) %>% mutate(model = "DW")
) %>%
filter(term != "(Intercept)") %>%
mutate(term_label = case_when(
term == "mtm_btfp" ~ "MTM Loss (BTFP-Eligible)",
term == "mtm_other" ~ "MTM Loss (Other)",
term == "uninsured_lev" ~ "Uninsured Deposits",
term == "I(mtm_btfp * uninsured_lev)" ~ "MTM × Uninsured",
term == "eligible_collateral" ~ "Eligible Collateral",
term == "borrowing_subsidy" ~ "Borrowing Subsidy",
term == "ln_assets" ~ "Log(Assets)",
term == "cash_ratio" ~ "Cash Ratio",
term == "securities_ratio" ~ "Securities Ratio",
term == "roa" ~ "ROA",
term == "loan_to_deposit" ~ "Loan-to-Deposit",
term == "book_equity_ratio" ~ "Equity Ratio",
TRUE ~ term
))
p_fig09 <- ggplot(coef_df, aes(x = estimate, y = reorder(term_label, estimate), color = model)) +
geom_vline(xintercept = 0, linetype = "dashed", color = "gray50") +
geom_errorbarh(aes(xmin = conf.low, xmax = conf.high), height = 0.2,
position = position_dodge(0.4), linewidth = 0.8) +
geom_point(size = 2.5, position = position_dodge(0.4)) +
scale_color_manual(values = facility_colors[c("BTFP", "DW")]) +
labs(
title = "Figure 9: Coefficient Comparison - Extensive Margin",
subtitle = "BTFP vs DW selection | 95% CI | Baseline 1",
x = "Coefficient Estimate", y = NULL, color = "Dependent Variable"
) +
theme_pub() +
theme(legend.position = "bottom")
print(p_fig09)
ggsave(file.path(FIG_PATH, "fig09_coef_comparison.png"), p_fig09, width = 12, height = 9, dpi = 300, bg = "white")
5.7.4 Figure 10: Temporal Coefficient Evolution
# ==========================================================================
# FIGURE 10: TEMPORAL COEFFICIENT EVOLUTION
# MTM Loss coefficient across crisis periods
# ==========================================================================
period_formula <- "mtm_btfp + mtm_other + uninsured_lev + ln_assets + cash_ratio"
## Period-specific regressions
lpm_acute <- feols(as.formula(paste("btfp_acute ~", period_formula)), data = df_1, vcov = "hetero")
lpm_post <- feols(as.formula(paste("btfp_post ~", period_formula)), data = df_1, vcov = "hetero")
lpm_arb <- feols(as.formula(paste("btfp_arb ~", period_formula)), data = df_1, vcov = "hetero")
## Extract MTM coefficients
temporal_coefs <- tibble(
period = factor(c("Acute", "Post-Acute", "Arbitrage"),
levels = c("Acute", "Post-Acute", "Arbitrage")),
estimate = c(coef(lpm_acute)["mtm_btfp"], coef(lpm_post)["mtm_btfp"], coef(lpm_arb)["mtm_btfp"]),
se = c(sqrt(vcov(lpm_acute)["mtm_btfp", "mtm_btfp"]),
sqrt(vcov(lpm_post)["mtm_btfp", "mtm_btfp"]),
sqrt(vcov(lpm_arb)["mtm_btfp", "mtm_btfp"]))
) %>%
mutate(conf.low = estimate - 1.96 * se, conf.high = estimate + 1.96 * se)
p_fig10 <- ggplot(temporal_coefs, aes(x = period, y = estimate, color = period)) +
geom_hline(yintercept = 0, linetype = "dashed", color = "gray50") +
geom_errorbar(aes(ymin = conf.low, ymax = conf.high), width = 0.15, linewidth = 1) +
geom_point(size = 4) +
scale_color_manual(values = crisis_colors[c("Acute", "Post-Acute", "Arbitrage")]) +
labs(
title = "Figure 10: MTM Loss Coefficient Across Crisis Periods",
subtitle = "Effect of BTFP-eligible MTM loss on BTFP usage | 95% CI",
x = "Crisis Period", y = "Coefficient on MTM Loss"
) +
theme_pub() +
theme(legend.position = "none")
print(p_fig10)
ggsave(file.path(FIG_PATH, "fig10_temporal_coef.png"), p_fig10, width = 12, height = 8, dpi = 300, bg = "white")
cat("\n")
cat(strrep("=", 80), "\n")
#> ================================================================================
cat("✓✓✓ PART V COMPLETE: Visualizations ✓✓✓\n")
#> ✓✓✓ PART V COMPLETE: Visualizations ✓✓✓
cat(strrep("=", 80), "\n")
#> ================================================================================
PART VI: FACILITY DESIGN CHOICE MODELS
This section tests whether facility design features drive bank
selection behavior.
| Maximum Term |
1 year (365 days) |
Typically 90 days |
| Collateral Valuation |
Par value |
Market value (with haircuts) |
| Rate |
OIS + 10bp (fixed) |
Primary Credit Rate |
| Stigma |
Lower (new program) |
Higher (traditional) |
6.1 Aggregate Facility Design Variables
# ==========================================================================
# AGGREGATE FACILITY DESIGN VARIABLES FROM LOAN-LEVEL TO BANK-LEVEL
#
# Loan-level variables (exact names):
# BTFP: btfp_loan_date, btfp_maturity_date, btfp_term, btfp_repayment_date,
# btfp_loan_amount, btfp_interest_rate, btfp_total_collateral,
# btfp_effective_maturity_days
#
# DW: dw_loan_date, dw_maturity_date, dw_term, dw_repayment_date,
# dw_interest_rate, dw_loan_amount, dw_total_collateral,
# dw_effective_maturity_days, dw_omo_eligible, dw_non_omo_eligible
# ==========================================================================
cat("\n=== PART VI: FACILITY DESIGN CHOICE MODELS ===\n")
#>
#> === PART VI: FACILITY DESIGN CHOICE MODELS ===
cat("\n=== Aggregating Facility Design Variables ===\n")
#>
#> === Aggregating Facility Design Variables ===
## BTFP Design Aggregation
btfp_design <- btfp_raw %>%
filter(btfp_loan_date >= CRISIS_START, btfp_loan_date <= BTFP_CLOSE) %>%
group_by(rssd_id) %>%
summarise(
# Term
btfp_avg_term = weighted.mean(btfp_term, btfp_loan_amount, na.rm = TRUE),
btfp_max_term = max(btfp_term, na.rm = TRUE),
btfp_min_term = min(btfp_term, na.rm = TRUE),
# Rate
btfp_avg_rate = weighted.mean(btfp_interest_rate, btfp_loan_amount, na.rm = TRUE),
btfp_max_rate = max(btfp_interest_rate, na.rm = TRUE),
# Effective maturity
btfp_avg_eff_mat = weighted.mean(btfp_effective_maturity_days, btfp_loan_amount, na.rm = TRUE),
# Collateral
btfp_total_coll = sum(btfp_total_collateral, na.rm = TRUE),
# Counts
btfp_n_loans = n(),
btfp_total_amt = sum(btfp_loan_amount, na.rm = TRUE),
# Term choice
btfp_used_full_term = as.integer(any(btfp_term >= 360, na.rm = TRUE)),
btfp_pct_early_repay = mean(btfp_effective_maturity_days < btfp_term, na.rm = TRUE) * 100,
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
cat("✓ BTFP design aggregated:", nrow(btfp_design), "banks\n")
#> ✓ BTFP design aggregated: 1327 banks
## DW Design Aggregation
dw_design <- dw_raw %>%
filter(dw_loan_date >= PRE_BTFP_START, dw_loan_date <= DW_DATA_END) %>%
group_by(rssd_id) %>%
summarise(
# Term
dw_avg_term = weighted.mean(dw_term, dw_loan_amount, na.rm = TRUE),
dw_max_term = max(dw_term, na.rm = TRUE),
# Rate
dw_avg_rate = weighted.mean(dw_interest_rate, dw_loan_amount, na.rm = TRUE),
dw_max_rate = max(dw_interest_rate, na.rm = TRUE),
# Effective maturity
dw_avg_eff_mat = weighted.mean(dw_effective_maturity_days, dw_loan_amount, na.rm = TRUE),
# Collateral
dw_total_coll = sum(dw_total_collateral, na.rm = TRUE),
dw_omo_coll = sum(dw_omo_eligible, na.rm = TRUE),
dw_non_omo_coll = sum(dw_non_omo_eligible, na.rm = TRUE),
dw_pct_omo_coll = dw_omo_coll / dw_total_coll * 100,
# Counts
dw_n_loans = n(),
dw_total_amt = sum(dw_loan_amount, na.rm = TRUE),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
cat("✓ DW design aggregated:", nrow(dw_design), "banks\n")
#> ✓ DW design aggregated: 1384 banks
## Merge into df_1 and df_2
df_1 <- df_1 %>%
left_join(btfp_design, by = "idrssd") %>%
left_join(dw_design, by = "idrssd")
df_2 <- df_2 %>%
left_join(btfp_design, by = "idrssd") %>%
left_join(dw_design, by = "idrssd")
## Create facility design choice indicators
df_1 <- df_1 %>%
mutate(
high_uninsured = as.integer(uninsured_lev > median(uninsured_lev, na.rm = TRUE)),
high_wholesale = as.integer(pct_wholesale_liability > median(pct_wholesale_liability, na.rm = TRUE)),
funding_stability_need = high_uninsured + high_wholesale,
collateral_constrained = as.integer(eligible_collateral < median(eligible_collateral, na.rm = TRUE)),
low_liquidity = as.integer(pct_liquidity_available < median(pct_liquidity_available, na.rm = TRUE)),
high_mtm = as.integer(mtm_btfp > median(mtm_btfp, na.rm = TRUE)),
stress_indicator = high_uninsured * high_mtm,
rate_diff = dw_avg_rate - btfp_avg_rate
)
df_2 <- df_2 %>%
mutate(
high_uninsured = as.integer(uninsured_lev > median(uninsured_lev, na.rm = TRUE)),
high_wholesale = as.integer(pct_wholesale_liability > median(pct_wholesale_liability, na.rm = TRUE)),
funding_stability_need = high_uninsured + high_wholesale,
collateral_constrained = as.integer(eligible_collateral < median(eligible_collateral, na.rm = TRUE)),
low_liquidity = as.integer(pct_liquidity_available < median(pct_liquidity_available, na.rm = TRUE)),
high_mtm = as.integer(mtm_btfp > median(mtm_btfp, na.rm = TRUE)),
stress_indicator = high_uninsured * high_mtm,
rate_diff = dw_avg_rate - btfp_avg_rate
)
df <- df_1
cat("✓ Design variables merged and indicators created\n")
#> ✓ Design variables merged and indicators created
6.2 Facility Design Summary Statistics
cat("\n=== FACILITY DESIGN SUMMARY STATISTICS ===\n")
#>
#> === FACILITY DESIGN SUMMARY STATISTICS ===
cat("\n=== PART VI: FACILITY DESIGN CHOICE MODELS ===\n")
#>
#> === PART VI: FACILITY DESIGN CHOICE MODELS ===
# 1. AGGREGATE BTFP DESIGN VARIABLES
cat("-> Aggregating BTFP design variables...\n")
#> -> Aggregating BTFP design variables...
btfp_design <- btfp_raw %>%
filter(btfp_loan_date >= as.Date("2023-03-13"), btfp_loan_date <= BTFP_CLOSE) %>%
group_by(rssd_id) %>%
summarise(
btfp_avg_term = weighted.mean(btfp_term, btfp_loan_amount, na.rm = TRUE),
btfp_avg_rate = weighted.mean(btfp_interest_rate, btfp_loan_amount, na.rm = TRUE),
btfp_avg_eff_mat = weighted.mean(btfp_effective_maturity_days, btfp_loan_amount, na.rm = TRUE),
btfp_used_full_term = as.integer(any(btfp_term >= 360, na.rm = TRUE)),
btfp_pct_early_repay = mean(btfp_effective_maturity_days < btfp_term, na.rm = TRUE) * 100,
btfp_n_loans = n(), # This is the variable that was missing
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
# 2. AGGREGATE DW DESIGN VARIABLES
cat("-> Aggregating DW design variables...\n")
#> -> Aggregating DW design variables...
dw_design <- dw_raw %>%
filter(dw_loan_date >= as.Date("2022-10-01"), dw_loan_date <= DW_DATA_END) %>%
group_by(rssd_id) %>%
summarise(
dw_avg_term = weighted.mean(dw_term, dw_loan_amount, na.rm = TRUE),
dw_avg_rate = weighted.mean(dw_interest_rate, dw_loan_amount, na.rm = TRUE),
dw_avg_eff_mat = weighted.mean(dw_effective_maturity_days, dw_loan_amount, na.rm = TRUE),
dw_pct_omo_coll = sum(dw_omo_eligible, na.rm = TRUE) / sum(dw_total_collateral, na.rm = TRUE) * 100,
dw_n_loans = n(),
.groups = "drop"
) %>%
rename(idrssd = rssd_id)
# 3. MERGE DESIGN VARIABLES INTO DF_1 (Re-running to ensure columns exist)
cat("-> Merging design variables into df_1...\n")
#> -> Merging design variables into df_1...
# Remove columns if they already exist to avoid .x/.y duplicates
cols_to_remove <- c(names(btfp_design)[names(btfp_design) != "idrssd"],
names(dw_design)[names(dw_design) != "idrssd"])
df_1 <- df_1 %>% select(-any_of(cols_to_remove))
df_1 <- df_1 %>%
left_join(btfp_design, by = "idrssd") %>%
left_join(dw_design, by = "idrssd") %>%
mutate(
rate_diff = dw_avg_rate - btfp_avg_rate,
# Ensure binary flags are 0 if NA (for logic checks), keep means as NA
btfp_used_full_term = coalesce(btfp_used_full_term, 0L)
)
# 4. GENERATE SUMMARIES
cat("\n=== FACILITY DESIGN SUMMARY STATISTICS ===\n")
#>
#> === FACILITY DESIGN SUMMARY STATISTICS ===
## BTFP Users Summary
btfp_summary <- df_1 %>%
filter(btfp == 1) %>%
summarise(
n = n(),
avg_term = mean(btfp_avg_term, na.rm = TRUE),
avg_rate = mean(btfp_avg_rate, na.rm = TRUE),
avg_eff_mat = mean(btfp_avg_eff_mat, na.rm = TRUE),
pct_full_term = mean(btfp_used_full_term == 1, na.rm = TRUE) * 100,
avg_n_loans = mean(btfp_n_loans, na.rm = TRUE),
pct_early_repay = mean(btfp_pct_early_repay, na.rm = TRUE)
)
## DW Users Summary
dw_summary <- df_1 %>%
filter(dw == 1) %>%
summarise(
n = n(),
avg_term = mean(dw_avg_term, na.rm = TRUE),
avg_rate = mean(dw_avg_rate, na.rm = TRUE),
avg_eff_mat = mean(dw_avg_eff_mat, na.rm = TRUE),
pct_omo_coll = mean(dw_pct_omo_coll, na.rm = TRUE),
avg_n_loans = mean(dw_n_loans, na.rm = TRUE)
)
## Both Users Summary
both_summary <- df_1 %>%
filter(both == 1) %>%
summarise(
n = n(),
btfp_avg_term = mean(btfp_avg_term, na.rm = TRUE),
dw_avg_term = mean(dw_avg_term, na.rm = TRUE),
btfp_avg_rate = mean(btfp_avg_rate, na.rm = TRUE),
dw_avg_rate = mean(dw_avg_rate, na.rm = TRUE),
avg_rate_diff = mean(rate_diff, na.rm = TRUE)
)
# 5. PRINT REPORT
cat("\n[A] BTFP Users (n =", btfp_summary$n, "):\n")
#>
#> [A] BTFP Users (n = 1259 ):
cat(" Avg Term: ", round(btfp_summary$avg_term, 1), "days\n")
#> Avg Term: 301.4 days
cat(" Avg Rate: ", round(btfp_summary$avg_rate, 2), "%\n")
#> Avg Rate: 4.99 %
cat(" Avg Effective Maturity: ", round(btfp_summary$avg_eff_mat, 1), "days\n")
#> Avg Effective Maturity: 161.3 days
cat(" % Using Full Term: ", round(btfp_summary$pct_full_term, 1), "%\n")
#> % Using Full Term: 83.3 %
cat(" Avg # Loans: ", round(btfp_summary$avg_n_loans, 1), "\n")
#> Avg # Loans: 5.1
cat(" % Early Repayment: ", round(btfp_summary$pct_early_repay, 1), "%\n")
#> % Early Repayment: 67.7 %
cat("\n[B] DW Users (n =", dw_summary$n, "):\n")
#>
#> [B] DW Users (n = 1004 ):
cat(" Avg Term: ", round(dw_summary$avg_term, 1), "days\n")
#> Avg Term: 5 days
cat(" Avg Rate: ", round(dw_summary$avg_rate, 2), "%\n")
#> Avg Rate: 5.08 %
cat(" Avg Effective Maturity: ", round(dw_summary$avg_eff_mat, 1), "days\n")
#> Avg Effective Maturity: 3.6 days
cat(" % OMO-Eligible Coll: ", round(dw_summary$pct_omo_coll, 1), "%\n")
#> % OMO-Eligible Coll: 34.3 %
cat(" Avg # Loans: ", round(dw_summary$avg_n_loans, 1), "\n")
#> Avg # Loans: 8.9
cat("\n[C] Banks Using Both (n =", both_summary$n, "):\n")
#>
#> [C] Banks Using Both (n = 413 ):
cat(" BTFP Avg Term: ", round(both_summary$btfp_avg_term, 1), "days\n")
#> BTFP Avg Term: 279.2 days
cat(" DW Avg Term: ", round(both_summary$dw_avg_term, 1), "days\n")
#> DW Avg Term: 6.2 days
cat(" BTFP Avg Rate: ", round(both_summary$btfp_avg_rate, 2), "%\n")
#> BTFP Avg Rate: 4.98 %
cat(" DW Avg Rate: ", round(both_summary$dw_avg_rate, 2), "%\n")
#> DW Avg Rate: 5.05 %
cat(" Avg Rate Diff (DW-BTFP):", round(both_summary$avg_rate_diff, 2), "pp\n")
#> Avg Rate Diff (DW-BTFP): 0.07 pp
6.3 Model 1: Funding Stability Need and Term Choice
# ==========================================================================
# MODEL 1: FUNDING STABILITY NEED → TERM PREFERENCE
# ==========================================================================
cat("\n=== MODEL 1: FUNDING STABILITY AND FACILITY CHOICE ===\n")
#>
#> === MODEL 1: FUNDING STABILITY AND FACILITY CHOICE ===
model1_btfp <- feols(
btfp ~ funding_stability_need + mtm_btfp + eligible_collateral + ln_assets + cash_ratio,
data = df_1, vcov = "hetero"
)
model1_dw <- feols(
dw ~ funding_stability_need + mtm_btfp + eligible_collateral + ln_assets + cash_ratio,
data = df_1, vcov = "hetero"
)
btfp_users_design <- df_1 %>% filter(btfp == 1, !is.na(btfp_avg_term))
model1_term <- feols(
btfp_avg_term ~ funding_stability_need + mtm_btfp + eligible_collateral + borrowing_subsidy + ln_assets,
data = btfp_users_design, vcov = "hetero"
)
model1_fullterm <- feols(
btfp_used_full_term ~ funding_stability_need + mtm_btfp + eligible_collateral + borrowing_subsidy + ln_assets,
data = btfp_users_design, vcov = "hetero"
)
modelsummary(
list("BTFP Selection" = model1_btfp, "DW Selection" = model1_dw,
"BTFP Term" = model1_term, "Full Term (365d)" = model1_fullterm),
stars = c('*' = 0.1, '**' = 0.05, '***' = 0.01),
coef_rename = c(
"funding_stability_need" = "Funding Stability Need (0-2)",
"mtm_btfp" = "MTM Loss (BTFP-Eligible)",
"eligible_collateral" = "Eligible Collateral",
"borrowing_subsidy" = "Borrowing Subsidy"
),
gof_map = list(list("raw" = "nobs", "clean" = "N", "fmt" = 0),
list("raw" = "r.squared", "clean" = "R²", "fmt" = 3)),
title = "Table 6.1: Funding Stability Need and Facility Design Choice"
)
Table 6.1: Funding Stability Need and Facility Design Choice
| |
BTFP Selection |
DW Selection |
BTFP Term |
Full Term (365d) |
| * p < 0.1, ** p < 0.05, *** p < 0.01 |
| (Intercept) |
-0.357*** |
-0.920*** |
448.750*** |
1.216*** |
|
(0.069) |
(0.064) |
(40.309) |
(0.116) |
| Funding Stability Need (0-2) |
0.030*** |
0.022** |
8.559 |
0.018 |
|
(0.011) |
(0.010) |
(5.600) |
(0.016) |
| MTM Loss (BTFP-Eligible) |
0.060*** |
0.016* |
3.488 |
-0.001 |
|
(0.013) |
(0.009) |
(6.543) |
(0.019) |
| Eligible Collateral |
-0.001 |
-0.002** |
-0.073 |
0.001 |
|
(0.001) |
(0.001) |
(0.581) |
(0.002) |
| ln_assets |
0.050*** |
0.089*** |
-11.797*** |
-0.030*** |
|
(0.005) |
(0.005) |
(3.105) |
(0.009) |
| cash_ratio |
-0.007*** |
-0.001 |
|
|
|
(0.001) |
(0.001) |
|
|
| Borrowing Subsidy |
|
|
0.005*** |
0.000*** |
|
|
|
(0.001) |
(0.000) |
| N |
4282 |
4282 |
1259 |
1259 |
| R² |
0.082 |
0.118 |
0.015 |
0.013 |
6.4 Model 2: Collateral Constraints and Dual Usage
# ==========================================================================
# MODEL 2: COLLATERAL CONSTRAINTS → DUAL FACILITY USAGE
# ==========================================================================
cat("\n=== MODEL 2: COLLATERAL CONSTRAINTS AND DUAL USAGE ===\n")
#>
#> === MODEL 2: COLLATERAL CONSTRAINTS AND DUAL USAGE ===
btfp_users <- df_1 %>% filter(btfp == 1)
model2a <- feols(
dw ~ collateral_constrained + mtm_btfp + uninsured_lev + ln_assets + cash_ratio,
data = btfp_users, vcov = "hetero"
)
model2b <- feols(
dw ~ btfp_utilization + mtm_btfp + uninsured_lev + ln_assets + cash_ratio,
data = btfp_users %>% filter(!is.na(btfp_utilization)), vcov = "hetero"
)
model2c <- feols(
dw ~ maxed_out_btfp + mtm_btfp + uninsured_lev + ln_assets,
data = btfp_users, vcov = "hetero"
)
modelsummary(
list("DW | Collateral Constrained" = model2a, "DW | Utilization" = model2b, "DW | Maxed Out" = model2c),
stars = c('*' = 0.1, '**' = 0.05, '***' = 0.01),
coef_rename = c(
"collateral_constrained" = "Collateral Constrained",
"btfp_utilization" = "BTFP Utilization",
"maxed_out_btfp" = "Maxed Out BTFP (>90%)"
),
gof_map = list(list("raw" = "nobs", "clean" = "N", "fmt" = 0),
list("raw" = "r.squared", "clean" = "R²", "fmt" = 3)),
title = "Table 6.2: Collateral Constraints and DW Usage (BTFP Users)"
)
Table 6.2: Collateral Constraints and DW Usage (BTFP Users)
| |
DW | Collateral Constrained |
DW | Utilization |
DW | Maxed Out |
| * p < 0.1, ** p < 0.05, *** p < 0.01 |
| (Intercept) |
-0.917*** |
-0.917*** |
-0.939*** |
|
(0.127) |
(0.125) |
(0.117) |
| Collateral Constrained |
0.002 |
|
|
|
(0.031) |
|
|
| mtm_btfp |
0.007 |
0.007 |
0.005 |
|
(0.018) |
(0.015) |
(0.015) |
| uninsured_lev |
0.003** |
0.003** |
0.003** |
|
(0.001) |
(0.001) |
(0.001) |
| ln_assets |
0.088*** |
0.087*** |
0.090*** |
|
(0.010) |
(0.010) |
(0.010) |
| cash_ratio |
-0.002 |
-0.002 |
|
|
(0.002) |
(0.002) |
|
| BTFP Utilization |
|
0.000 |
|
|
|
(0.000) |
|
| Maxed Out BTFP (>90%) |
|
|
-0.013 |
|
|
|
(0.026) |
| N |
1259 |
1259 |
1259 |
| R² |
0.097 |
0.098 |
0.097 |
6.5 Model 3: Stress and Term/Maturity Choice
# ==========================================================================
# MODEL 3: BANK STRESS → TERM AND EFFECTIVE MATURITY
# ==========================================================================
cat("\n=== MODEL 3: STRESS AND TERM/MATURITY CHOICE ===\n")
#>
#> === MODEL 3: STRESS AND TERM/MATURITY CHOICE ===
model3_term <- feols(
btfp_avg_term ~ stress_indicator + run_risk_1_dummy + mtm_btfp + uninsured_lev + eligible_collateral + ln_assets,
data = btfp_users_design, vcov = "hetero"
)
model3_effmat <- feols(
btfp_avg_eff_mat ~ stress_indicator + run_risk_1_dummy + mtm_btfp + uninsured_lev + eligible_collateral + ln_assets,
data = btfp_users_design, vcov = "hetero"
)
model3_early <- feols(
btfp_pct_early_repay ~ stress_indicator + run_risk_1_dummy + mtm_btfp + uninsured_lev + eligible_collateral + ln_assets,
data = btfp_users_design, vcov = "hetero"
)
modelsummary(
list("Avg Term" = model3_term, "Avg Eff. Maturity" = model3_effmat, "% Early Repay" = model3_early),
stars = c('*' = 0.1, '**' = 0.05, '***' = 0.01),
coef_rename = c(
"stress_indicator" = "Stress (High Unins. × High MTM)",
"run_risk_1_dummy" = "Run Risk Dummy"
),
gof_map = list(list("raw" = "nobs", "clean" = "N", "fmt" = 0),
list("raw" = "r.squared", "clean" = "R²", "fmt" = 3)),
title = "Table 6.3: Bank Stress and Term/Maturity Choices (BTFP Users)"
)
Table 6.3: Bank Stress and Term/Maturity Choices (BTFP Users)
| |
Avg Term |
Avg Eff. Maturity |
% Early Repay |
| * p < 0.1, ** p < 0.05, *** p < 0.01 |
| (Intercept) |
434.343*** |
314.439*** |
96.454*** |
|
(41.427) |
(31.827) |
(11.617) |
| Stress (High Unins. × High MTM) |
13.003 |
-3.240 |
6.479** |
|
(10.011) |
(8.885) |
(3.031) |
| Run Risk Dummy |
14.736 |
7.186 |
3.389 |
|
(9.295) |
(7.978) |
(2.774) |
| mtm_btfp |
-1.749 |
2.549 |
-0.933 |
|
(6.539) |
(5.479) |
(1.916) |
| uninsured_lev |
-1.252*** |
-0.546 |
-0.198 |
|
(0.459) |
(0.343) |
(0.127) |
| eligible_collateral |
0.109 |
-0.199 |
0.081 |
|
(0.590) |
(0.502) |
(0.162) |
| ln_assets |
-8.191** |
-10.456*** |
-2.027** |
|
(3.265) |
(2.430) |
(0.901) |
| N |
1259 |
1259 |
1259 |
| R² |
0.022 |
0.025 |
0.012 |
6.6 Model 4: Multinomial Logit for Facility Choice
# ==========================================================================
# MODEL 4: MULTINOMIAL LOGIT - FACILITY CHOICE
# ==========================================================================
cat("\n=== MODEL 4: MULTINOMIAL LOGIT FOR FACILITY CHOICE ===\n")
#>
#> === MODEL 4: MULTINOMIAL LOGIT FOR FACILITY CHOICE ===
if (!require(nnet)) install.packages("nnet")
library(nnet)
df_mlogit <- df_1 %>%
filter(!is.na(mtm_btfp), !is.na(uninsured_lev), !is.na(eligible_collateral),
!is.na(ln_assets), !is.na(cash_ratio)) %>%
mutate(facility = relevel(facility, ref = "Neither"))
mlogit_model <- multinom(
facility ~ mtm_btfp + uninsured_lev + eligible_collateral + funding_stability_need + ln_assets + cash_ratio,
data = df_mlogit, trace = FALSE
)
cat("\nMultinomial Logit Results (Reference: Neither):\n")
#>
#> Multinomial Logit Results (Reference: Neither):
print(summary(mlogit_model))
#> Call:
#> multinom(formula = facility ~ mtm_btfp + uninsured_lev + eligible_collateral +
#> funding_stability_need + ln_assets + cash_ratio, data = df_mlogit,
#> trace = FALSE)
#>
#> Coefficients:
#> (Intercept) mtm_btfp uninsured_lev eligible_collateral
#> BTFP Only -4.568874 0.3136218 0.0080306032 -0.006481950
#> DW Only -8.773128 0.1646314 0.0002652848 -0.025848569
#> Both -10.128033 0.3297974 0.0147357934 -0.009594671
#> funding_stability_need ln_assets cash_ratio
#> BTFP Only 0.01800539 0.2820642 -0.060485770
#> DW Only 0.06728990 0.5783067 -0.007308258
#> Both 0.19991405 0.6186839 -0.072490960
#>
#> Std. Errors:
#> (Intercept) mtm_btfp uninsured_lev eligible_collateral
#> BTFP Only 0.4695262 0.06555722 0.004574210 0.005680018
#> DW Only 0.5076211 0.09240597 0.004959264 0.007927640
#> Both 0.5795077 0.09766161 0.005717036 0.008811688
#> funding_stability_need ln_assets cash_ratio
#> BTFP Only 0.07408564 0.03744553 0.007537367
#> DW Only 0.08562735 0.03981974 0.006041057
#> Both 0.09883437 0.04474933 0.012172308
#>
#> Residual Deviance: 8900.338
#> AIC: 8942.338
6.7 Facility Design Visualizations
# ==========================================================================
# FIGURE 11: TERM CHOICE BY BANK STRESS LEVEL
# ==========================================================================
term_stress_data <- df_1 %>%
filter(btfp == 1, !is.na(btfp_avg_term)) %>%
mutate(
stress_level = case_when(
stress_indicator == 1 ~ "High Stress",
run_risk_1_dummy == 1 ~ "Moderate Stress",
TRUE ~ "Low Stress"
),
stress_level = factor(stress_level, levels = c("Low Stress", "Moderate Stress", "High Stress"))
)
p_fig11 <- ggplot(term_stress_data, aes(x = btfp_avg_term, fill = stress_level)) +
geom_density(alpha = 0.6) +
geom_vline(xintercept = 365, linetype = "dashed", color = "gray30") +
annotate("text", x = 365, y = Inf, label = "Full Term (1 Year)", vjust = 2, hjust = -0.1, size = 3.5) +
scale_fill_manual(values = c("Low Stress" = "#91bfdb", "Moderate Stress" = "#fee08b", "High Stress" = "#d73027")) +
labs(
title = "Figure 11: BTFP Term Choice by Bank Stress Level",
x = "Average Loan Term (Days)", y = "Density", fill = "Stress Level"
) +
theme_pub() +
theme(legend.position = "bottom")
print(p_fig11)
ggsave(file.path(FIG_PATH, "fig11_term_stress.png"), p_fig11, width = 12, height = 8, dpi = 300, bg = "white")
# ==========================================================================
# FIGURE 12: DW USAGE BY BTFP UTILIZATION
# ==========================================================================
util_data <- df_1 %>%
filter(btfp == 1, !is.na(btfp_utilization)) %>%
mutate(
util_bin = cut(btfp_utilization,
breaks = c(0, 0.25, 0.5, 0.75, 0.9, Inf),
labels = c("0-25%", "25-50%", "50-75%", "75-90%", ">90%"),
include.lowest = TRUE)
) %>%
group_by(util_bin) %>%
summarise(pct_also_dw = mean(dw, na.rm = TRUE) * 100, n = n(), .groups = "drop")
p_fig12 <- ggplot(util_data, aes(x = util_bin, y = pct_also_dw)) +
geom_col(fill = "#2166ac", alpha = 0.8) +
geom_text(aes(label = sprintf("%.1f%%\n(n=%d)", pct_also_dw, n)), vjust = -0.3, size = 3.5) +
scale_y_continuous(expand = expansion(mult = c(0, 0.15))) +
labs(
title = "Figure 12: DW Usage by BTFP Collateral Utilization",
subtitle = "Among BTFP users",
x = "BTFP Utilization Rate", y = "% Also Using DW"
) +
theme_pub()
print(p_fig12)
ggsave(file.path(FIG_PATH, "fig12_utilization_dw.png"), p_fig12, width = 10, height = 8, dpi = 300, bg = "white")
# ==========================================================================
# FIGURE 13: RATE COMPARISON (BANKS USING BOTH)
# ==========================================================================
both_users <- df_1 %>%
filter(both == 1, !is.na(btfp_avg_rate), !is.na(dw_avg_rate))
if (nrow(both_users) > 5) {
p_fig13 <- ggplot(both_users, aes(x = btfp_avg_rate, y = dw_avg_rate)) +
geom_abline(slope = 1, intercept = 0, linetype = "dashed", color = "gray50") +
geom_point(aes(color = rate_diff), size = 3, alpha = 0.7) +
scale_color_gradient2(low = "#2166ac", mid = "gray80", high = "#b2182b",
midpoint = 0, name = "DW - BTFP") +
labs(
title = "Figure 13: Interest Rate Comparison (Banks Using Both)",
subtitle = "Points above diagonal = DW rate > BTFP rate",
x = "BTFP Avg Rate (%)", y = "DW Avg Rate (%)"
) +
theme_pub()
print(p_fig13)
ggsave(file.path(FIG_PATH, "fig13_rate_comparison.png"), p_fig13, width = 10, height = 8, dpi = 300, bg = "white")
} else {
cat("Insufficient banks using both facilities for rate comparison.\n")
}
cat("\n")
cat(strrep("=", 80), "\n")
#> ================================================================================
cat("✓✓✓ PART VI COMPLETE: Facility Design Choice Models ✓✓✓\n")
#> ✓✓✓ PART VI COMPLETE: Facility Design Choice Models ✓✓✓
cat(strrep("=", 80), "\n")
#> ================================================================================
