Preparing packages and data
#-------------------------------------------------------------
# STEP 1: Load Required Libraries
#-------------------------------------------------------------
# Required packages
required_packages <- c(
"survival", "dplyr", "ggplot2", "survminer", "tidyr",
"car", "pROC", "ROCR", "timeROC"
)
# Install missing packages
missing_packages <- required_packages[!required_packages %in% installed.packages()[,"Package"]]
if(length(missing_packages) > 0) {
install.packages(missing_packages)
}
# Load packages
suppressPackageStartupMessages({
library(survival) # For survival models
library(dplyr) # For data manipulation
library(ggplot2) # For data visualization
library(survminer) # For survival analysis visualizations
library(tidyr) # For data tidying
library(car) # For VIF analysis
library(pROC) # For ROC analysis
library(ROCR) # For ROC curves and AUC
library(timeROC) # For time-dependent ROC curves
})
#-------------------------------------------------------------
# STEP 2: Data Loading and Initial Inspection
#-------------------------------------------------------------
# Read the dataset
data <- read.csv("1.3.csv", stringsAsFactors = FALSE)
# Display basic data information
cat("Data dimensions:", dim(data), "\n")
Data dimensions: 63591 29
print(head(dplyr::select(data, cusip, gsector, start, stop, event_type), n = 5))
# Check for missing values in key columns
missing_key <- colSums(is.na(data[, c("cusip", "gsector", "start", "stop", "event_type")]))
if(sum(missing_key) > 0) {
cat("WARNING: Missing values in key columns:\n")
print(missing_key[missing_key > 0])
}
# Check for duplicated rows
potential_duplicates <- data %>%
group_by(cusip, start, stop) %>%
filter(n() > 1) %>%
ungroup()
if(nrow(potential_duplicates) > 0) {
cat("WARNING:", nrow(potential_duplicates), "potential duplicate entries found.\n")
# Display the first few duplicates for inspection
cat("Sample of duplicate records:\n")
duplicate_sample <- potential_duplicates %>%
dplyr::select(cusip, gsector, start, stop, event_type) %>%
head(10)
print(duplicate_sample)
# For a more detailed inspection of exact duplicates
exact_duplicates <- data[duplicated(data) | duplicated(data, fromLast = TRUE), ]
cat("\nExact duplicate rows (all columns identical):", nrow(exact_duplicates), "\n")
if(nrow(exact_duplicates) > 0) {
cat("Sample of exact duplicates:\n")
exact_dup_sample <- exact_duplicates %>%
dplyr::select(cusip, gsector, start, stop, event_type) %>%
head(5)
print(exact_dup_sample)
}
# Ask user whether to remove duplicates
cat("\nDuplicates can be caused by:\n")
cat("1. Exact same record entered twice (safe to remove)\n")
cat("2. Same time period but different financial values (requires inspection)\n")
cat("3. Data entry errors (may need correction, not just removal)\n\n")
# Remove duplicates after inspection - by default we'll keep the first occurrence
cat("Removing duplicates and keeping first occurrence of each record.\n")
data <- distinct(data)
cat("After removing duplicates, data dimensions:", dim(data), "\n")
}
#-------------------------------------------------------------
# STEP 3: Data Preprocessing (MODIFIED)
#-------------------------------------------------------------
# Convert date strings to Date objects and ensure proper time intervals
data <- data %>%
# Convert date strings to Date objects
mutate(
start_date = as.Date(start),
stop_date = as.Date(stop)
) %>%
# Filter out records with invalid dates
filter(!is.na(start_date) & !is.na(stop_date) & start_date <= stop_date)
# Calculate time intervals in years from COMPANY-SPECIFIC origins
data <- data %>%
group_by(cusip) %>%
mutate(
# Find each company's first appearance date
company_start_date = min(start_date),
# Calculate time since IPO for start and stop
tstart = as.numeric(start_date - company_start_date) / 365.25,
tstop = as.numeric(stop_date - company_start_date) / 365.25
) %>%
ungroup() %>%
# Ensure gsector is a factor
mutate(gsector = as.factor(gsector))
# Create event indicators for cause-specific analysis
data <- data %>%
mutate(
bankruptcy = ifelse(event_type == 1, 1, 0),
acquisition = ifelse(event_type == 2, 1, 0)
)
All companies are brought back to time t=0, which is the date of their IPO. The time intervals are calculated in years from this date.
Macro Variables are introduced by matching the calendar year of the macro data with the calendar year of the company data. The macro data is reshaped from wide to long format, and missing values are handled by using the closest available year.
#-------------------------------------------------------------
# STEP 3.5: Add Macroeconomic Variables
#-------------------------------------------------------------
# Load macro data
macro_data <- read.csv("macro.csv", check.names = FALSE)
# First, let's examine the structure of the macro data
cat("Structure of macro data:\n")
Structure of macro data:
str(macro_data)
'data.frame': 3 obs. of 39 variables:
$ code: chr "gdp_deflator" "unemployement" "gdp_growth"
$ 1985: num 2.01 7 3.46
$ 1986: num 2.01 7 3.46
$ 1987: num 2.48 6.2 3.45
$ 1988: num 3.53 5.5 4.18
$ 1989: num 3.92 5.3 3.67
$ 1990: num 3.74 5.6 1.89
$ 1992: num 2.28 7.5 3.52
$ 1993: num 2.37 6.9 2.75
$ 1994: num 2.14 6.12 4.03
$ 1995: num 2.1 5.65 2.68
$ 1996: num 1.83 5.45 3.77
$ 1997: num 1.72 5 4.45
$ 1998: num 1.12 4.51 4.48
$ 1999: num 1.42 4.22 4.79
$ 2000: num 2.27 3.99 4.08
$ 2001: num 2.252 4.731 0.956
$ 2002: num 1.55 5.78 1.7
$ 2003: num 1.97 5.99 2.8
$ 2004: num 2.69 5.53 3.85
$ 2005: num 3.14 5.08 3.48
$ 2006: num 3.08 4.62 2.78
$ 2008: num 1.927 5.784 0.114
$ 2009: num 0.617 9.254 -2.577
$ 2010: num 1.22 9.63 2.7
$ 2011: num 2.06 8.95 1.56
$ 2012: num 1.86 8.07 2.29
$ 2013: num 1.7 7.38 2.12
$ 2014: num 1.74 6.17 2.52
$ 2015: num 0.928 5.28 2.946
$ 2016: num 0.95 4.87 1.82
$ 2017: num 1.79 4.36 2.46
$ 2018: num 2.29 3.9 2.97
$ 2019: num 1.65 3.67 2.58
$ 2020: num 1.33 8.05 -2.16
$ 2021: num 4.57 5.35 6.06
$ 2022: num 7.13 3.65 2.51
$ 2023: num 3.6 3.64 2.89
$ 2024: num 3.6 3.64 2.89
# Reshape from wide to long format
macro_long <- macro_data %>%
# Pivot to long format - all columns except 'code'
pivot_longer(
cols = -code,
names_to = "year",
values_to = "value"
) %>%
# Convert year to numeric
mutate(year = as.numeric(year)) %>%
# Pivot wider to get one row per year with columns for each macro variable
pivot_wider(
id_cols = year,
names_from = code,
values_from = value
)
# Display the first few rows of the reshaped data
cat("\nFirst few rows of reshaped macro data:\n")
First few rows of reshaped macro data:
print(head(macro_long))
# Extract calendar year from date for joining
data <- data %>%
mutate(calendar_year = as.numeric(format(start_date, "%Y")))
# Check the range of years in both datasets
cat("\nRange of years in company data:", range(data$calendar_year), "\n")
Range of years in company data: 1985 2024
cat("Range of years in macro data:", range(macro_long$year), "\n")
Range of years in macro data: 1985 2024
# Join macro data to company data
data <- data %>%
left_join(macro_long, by = c("calendar_year" = "year"))
# Check if macro variables were successfully added
cat("\nChecking if macro variables were added successfully:\n")
Checking if macro variables were added successfully:
macro_vars <- c("gdp_deflator", "unemployement", "gdp_growth")
na_count <- colSums(is.na(data[, macro_vars]))
print(na_count)
gdp_deflator unemployement gdp_growth
2588 2588 2588
# If there are missing values, handle them
if(sum(na_count) > 0) {
cat("\nHandling missing macro variable values...\n")
# For any missing year in the macro data, use the closest available year
for(var in macro_vars) {
# Get years with available data
available_years <- macro_long$year[!is.na(macro_long[[var]])]
# For each company-year with missing data
missing_rows <- which(is.na(data[[var]]))
if(length(missing_rows) > 0) {
cat("Imputing missing values for", var, "...\n")
for(i in missing_rows) {
company_year <- data$calendar_year[i]
# Find closest available year
closest_year <- available_years[which.min(abs(available_years - company_year))]
# Get the value from that year
replacement_value <- macro_long[[var]][macro_long$year == closest_year]
# Replace missing value
data[[var]][i] <- replacement_value
}
}
}
# Check if all missing values are now handled
na_count_after <- colSums(is.na(data[, macro_vars]))
cat("\nMissing values after imputation:\n")
print(na_count_after)
}
Handling missing macro variable values...
Imputing missing values for gdp_deflator ...
Imputing missing values for unemployement ...
Imputing missing values for gdp_growth ...
Missing values after imputation:
gdp_deflator unemployement gdp_growth
0 0 0
# Define macro covariates for modeling
macro_covariates <- c("gdp_deflator", "unemployement", "gdp_growth")
cat("\nMacroeconomic variables have been successfully integrated into the dataset.\n")
Macroeconomic variables have been successfully integrated into the dataset.
Time continuity is checked by identifying companies with gaps or overlaps in their time intervals. If any issues are found, the problematic companies are removed from the dataset.
#-------------------------------------------------------------
# STEP 4: Check and Fix Time Continuity
#-------------------------------------------------------------
# Identify companies with time issues (gaps or overlaps)
time_issues <- data %>%
group_by(cusip) %>%
arrange(cusip, tstart) %>%
mutate(
# Calculate gaps and overlaps
gap = tstart - lag(tstop),
overlap = lag(tstop) - tstart
) %>%
# Find problematic records
filter(!is.na(gap) & (gap > 0.01 | overlap > 0.01)) %>%
ungroup()
if(nrow(time_issues) > 0) {
cat("WARNING: Found", nrow(time_issues), "records with time continuity issues.\n")
# Identify companies with issues
problem_companies <- unique(time_issues$cusip)
cat("Number of companies with time issues:", length(problem_companies), "\n")
# Option 1: Remove companies with time issues
data_clean <- data %>%
filter(!cusip %in% problem_companies)
# Use the cleaned dataset
data <- data_clean
cat("Using cleaned dataset with", length(unique(data$cusip)), "companies after removing problematic ones.\n")
}
# Save the cleaned dataframe after time continuity checks to CSV
write.csv(data, file = "cox_model_cleaned_data.csv", row.names = FALSE)
cat("Cleaned dataframe saved to 'cox_model_cleaned_data.csv'\n")
Cleaned dataframe saved to 'cox_model_cleaned_data.csv'
Covariates are preprocessed by checking for missing values, winsorizing extreme values, and calculating the Altman Z-score. The Z-score is added to the financial covariates list, and the final list of covariates is prepared for modeling.
#-------------------------------------------------------------
# STEP 5: Financial and Macro Covariates Preprocessing
#-------------------------------------------------------------
# Define financial covariates based on your dataset
financial_covariates <- c(
"LTMTA", "NIMTA", "CASHMTA", "PRICE", "MBE", "RSIZE", "l_at", "l_mkvalt",
"debt_ratio", "debt_service", "current_ratio", "quick_ratio", "cash_to_assets",
"wc_ratio", "ebit_margin", "gp_margin", "asset_turnover", "receivables_turnover",
"intangibility", "ebit_growth", "EBIT_VOL_3Y"
)
# Define macro covariates separately
macro_covariates <- c("gdp_deflator", "unemployement", "gdp_growth")
# Create combined list when needed
all_covariates <- c(financial_covariates, macro_covariates)
# Check for missing values in financial covariates
missing_financials <- colSums(is.na(data[, financial_covariates]))
if(sum(missing_financials) > 0) {
cat("Missing values in financial covariates:\n")
print(missing_financials)
# Impute missing values with median by industry sector
data <- data %>%
group_by(gsector) %>%
mutate(across(all_of(financial_covariates),
~ifelse(is.na(.), median(., na.rm = TRUE), .))) %>%
ungroup()
# Check if any missing values remain
still_missing <- colSums(is.na(data[, financial_covariates]))
if(sum(still_missing) > 0) {
# Global median imputation for any remaining missing values
data <- data %>%
mutate(across(all_of(financial_covariates),
~ifelse(is.na(.), median(., na.rm = TRUE), .)))
}
}
# Check for missing values in macro covariates
missing_macro <- colSums(is.na(data[, macro_covariates]))
if(sum(missing_macro) > 0) {
cat("Missing values in macro covariates:\n")
print(missing_macro)
# For macro variables, impute with the closest available year value
for(var in macro_covariates) {
if(missing_macro[var] > 0) {
# Get all available years and values
available_data <- data[!is.na(data[[var]]), c("calendar_year", var)]
available_years <- available_data$calendar_year
# For each missing value
missing_rows <- which(is.na(data[[var]]))
for(row in missing_rows) {
year_needed <- data$calendar_year[row]
# Find closest year
closest_year_idx <- which.min(abs(available_years - year_needed))
# Impute with value from closest year
data[[var]][row] <- available_data[[var]][closest_year_idx]
}
}
}
# Check if all missing values are now handled
still_missing_macro <- colSums(is.na(data[, macro_covariates]))
if(sum(still_missing_macro) > 0) {
cat("Warning: Some macro variables still have missing values after imputation.\n")
print(still_missing_macro)
} else {
cat("All missing macro values successfully imputed.\n")
}
}
# Winsorize extreme values for financial covariates
cat("Winsorizing financial covariates...\n")
Winsorizing financial covariates...
for(var in financial_covariates) {
p01 <- quantile(data[[var]], 0.01, na.rm = TRUE)
p99 <- quantile(data[[var]], 0.99, na.rm = TRUE)
data[[var]] <- ifelse(data[[var]] < p01, p01, data[[var]])
data[[var]] <- ifelse(data[[var]] > p99, p99, data[[var]])
}
# Winsorize extreme values for macro covariates
cat("Winsorizing macro covariates...\n")
Winsorizing macro covariates...
for(var in macro_covariates) {
p01 <- quantile(data[[var]], 0.01, na.rm = TRUE)
p99 <- quantile(data[[var]], 0.99, na.rm = TRUE)
data[[var]] <- ifelse(data[[var]] < p01, p01, data[[var]])
data[[var]] <- ifelse(data[[var]] > p99, p99, data[[var]])
}
# Print summary statistics separately for financial and macro covariates
cat("\nSummary statistics for financial covariates (sample):\n")
Summary statistics for financial covariates (sample):
# Select a random subset of financial variables to display
sample_fin_vars <- sample(financial_covariates, min(5, length(financial_covariates)))
print(summary(data[, sample_fin_vars]))
l_mkvalt LTMTA quick_ratio CASHMTA debt_service
Min. : 0.2585 Min. :0.006782 Min. : 0.08372 Min. :0.0004349 Min. :-10.20097
1st Qu.: 4.1074 1st Qu.:0.113594 1st Qu.: 0.83377 1st Qu.:0.0230676 1st Qu.: -0.02842
Median : 5.7775 Median :0.269980 Median : 1.41114 Median :0.0700084 Median : 0.03086
Mean : 5.6766 Mean :0.326143 Mean : 2.49695 Mean :0.1262264 Mean : 0.15769
3rd Qu.: 7.2314 3rd Qu.:0.491489 3rd Qu.: 2.70340 3rd Qu.:0.1617134 3rd Qu.: 0.25824
Max. :10.7932 Max. :0.960709 Max. :21.34286 Max. :0.9537153 Max. : 11.24850
cat("\nSummary statistics for macro covariates:\n")
Summary statistics for macro covariates:
print(summary(data[, macro_covariates]))
gdp_deflator unemployement gdp_growth
Min. :0.6168 Min. :3.638 Min. :-2.576
1st Qu.:1.5540 1st Qu.:4.511 1st Qu.: 2.118
Median :1.9743 Median :5.280 Median : 2.785
Mean :2.2536 Mean :5.565 Mean : 2.674
3rd Qu.:2.6891 3rd Qu.:5.989 3rd Qu.: 3.773
Max. :7.1295 Max. :9.633 Max. : 6.055
# Calculate correlation between macro variables
cat("\nCorrelation between macro variables:\n")
Correlation between macro variables:
macro_cor <- cor(data[, macro_covariates], use = "pairwise.complete.obs")
print(round(macro_cor, 3))
gdp_deflator unemployement gdp_growth
gdp_deflator 1.000 -0.388 0.259
unemployement -0.388 1.000 -0.496
gdp_growth 0.259 -0.496 1.000
# Calculate correlation between macro variables and key financial variables
key_financial <- c("LTMTA", "NIMTA", "PRICE", "z_score") # Select a few key financial vars
key_financial <- intersect(key_financial, names(data)) # Make sure they exist
if(length(key_financial) > 0) {
cat("\nCorrelation between macro and key financial variables:\n")
cross_cor <- cor(data[, macro_covariates], data[, key_financial], use = "pairwise.complete.obs")
print(round(cross_cor, 3))
}
Correlation between macro and key financial variables:
LTMTA NIMTA PRICE
gdp_deflator -0.017 -0.041 0.048
unemployement -0.026 0.068 -0.015
gdp_growth -0.062 0.021 0.027
# Save the cleaned dataframe with preprocessed covariates
write.csv(data, file = "cox_model_cleaned_data_with_macro.csv", row.names = FALSE)
cat("Cleaned dataframe with financial and macro covariates saved to 'cox_model_cleaned_data_with_macro.csv'\n")
Cleaned dataframe with financial and macro covariates saved to 'cox_model_cleaned_data_with_macro.csv'
We check for multicollinearity among financial covariates and macro covariates. We also check for correlations between financial and macro covariates. The final list of covariates is prepared for modeling, and the Altman Z-score is calculated.
#-------------------------------------------------------------
# STEP 6: Check for Multicollinearity
#-------------------------------------------------------------
# 6.1: Check multicollinearity among financial covariates
cat("\n=== Checking multicollinearity among financial covariates ===\n")
=== Checking multicollinearity among financial covariates ===
cor_matrix_financial <- cor(data[, financial_covariates], use = "pairwise.complete.obs")
print(round(cor_matrix_financial, 2))
LTMTA NIMTA CASHMTA PRICE MBE RSIZE l_at l_mkvalt debt_ratio debt_service current_ratio quick_ratio
LTMTA 1.00 -0.01 -0.12 -0.33 -0.38 -0.30 0.18 -0.30 0.58 0.02 -0.41 -0.39
NIMTA -0.01 1.00 -0.43 0.47 -0.02 0.37 0.37 0.37 -0.02 0.10 -0.13 -0.15
CASHMTA -0.12 -0.43 1.00 -0.25 -0.19 -0.26 -0.21 -0.26 -0.31 -0.05 0.46 0.47
PRICE -0.33 0.47 -0.25 1.00 0.06 0.82 0.66 0.82 -0.19 0.08 0.02 0.01
MBE -0.38 -0.02 -0.19 0.06 1.00 0.14 -0.24 0.14 0.11 -0.04 0.08 0.10
RSIZE -0.30 0.37 -0.26 0.82 0.14 1.00 0.84 1.00 -0.07 0.06 -0.03 -0.02
l_at 0.18 0.37 -0.21 0.66 -0.24 0.84 1.00 0.84 0.06 0.08 -0.17 -0.16
l_mkvalt -0.30 0.37 -0.26 0.82 0.14 1.00 0.84 1.00 -0.07 0.06 -0.03 -0.02
debt_ratio 0.58 -0.02 -0.31 -0.19 0.11 -0.07 0.06 -0.07 1.00 -0.02 -0.45 -0.40
debt_service 0.02 0.10 -0.05 0.08 -0.04 0.06 0.08 0.06 -0.02 1.00 -0.04 -0.05
current_ratio -0.41 -0.13 0.46 0.02 0.08 -0.03 -0.17 -0.03 -0.45 -0.04 1.00 0.94
quick_ratio -0.39 -0.15 0.47 0.01 0.10 -0.02 -0.16 -0.02 -0.40 -0.05 0.94 1.00
cash_to_assets -0.48 -0.32 0.64 -0.06 0.25 -0.04 -0.28 -0.04 -0.29 -0.06 0.60 0.64
wc_ratio -0.50 -0.05 0.48 0.12 0.03 0.01 -0.17 0.01 -0.63 0.00 0.67 0.59
ebit_margin 0.11 0.32 -0.16 0.15 -0.13 0.10 0.18 0.10 0.03 0.03 -0.23 -0.25
gp_margin 0.09 0.26 -0.14 0.12 -0.11 0.09 0.14 0.09 0.02 0.03 -0.22 -0.24
asset_turnover 0.18 0.18 -0.19 -0.10 -0.01 -0.20 -0.15 -0.20 0.21 -0.01 -0.26 -0.29
receivables_turnover 0.06 0.03 0.00 -0.02 0.00 -0.02 0.00 -0.02 0.06 -0.02 -0.04 -0.06
intangibility -0.04 -0.10 -0.06 -0.08 0.24 -0.03 -0.10 -0.03 0.11 -0.06 -0.02 0.02
ebit_growth -0.05 0.01 -0.02 0.08 0.03 0.06 0.03 0.06 -0.02 0.01 0.01 0.02
EBIT_VOL_3Y 0.02 -0.05 0.04 -0.11 -0.01 -0.10 -0.09 -0.10 -0.02 -0.02 0.00 0.01
cash_to_assets wc_ratio ebit_margin gp_margin asset_turnover receivables_turnover intangibility ebit_growth
LTMTA -0.48 -0.50 0.11 0.09 0.18 0.06 -0.04 -0.05
NIMTA -0.32 -0.05 0.32 0.26 0.18 0.03 -0.10 0.01
CASHMTA 0.64 0.48 -0.16 -0.14 -0.19 0.00 -0.06 -0.02
PRICE -0.06 0.12 0.15 0.12 -0.10 -0.02 -0.08 0.08
MBE 0.25 0.03 -0.13 -0.11 -0.01 0.00 0.24 0.03
RSIZE -0.04 0.01 0.10 0.09 -0.20 -0.02 -0.03 0.06
l_at -0.28 -0.17 0.18 0.14 -0.15 0.00 -0.10 0.03
l_mkvalt -0.04 0.01 0.10 0.09 -0.20 -0.02 -0.03 0.06
debt_ratio -0.29 -0.63 0.03 0.02 0.21 0.06 0.11 -0.02
debt_service -0.06 0.00 0.03 0.03 -0.01 -0.02 -0.06 0.01
current_ratio 0.60 0.67 -0.23 -0.22 -0.26 -0.04 -0.02 0.01
quick_ratio 0.64 0.59 -0.25 -0.24 -0.29 -0.06 0.02 0.02
cash_to_assets 1.00 0.65 -0.29 -0.26 -0.28 -0.02 0.03 0.01
wc_ratio 0.65 1.00 -0.12 -0.12 -0.14 -0.10 -0.13 0.01
ebit_margin -0.29 -0.12 1.00 0.82 0.21 0.05 -0.09 -0.02
gp_margin -0.26 -0.12 0.82 1.00 0.17 0.04 -0.08 -0.02
asset_turnover -0.28 -0.14 0.21 0.17 1.00 0.23 -0.02 -0.02
receivables_turnover -0.02 -0.10 0.05 0.04 0.23 1.00 -0.01 -0.01
intangibility 0.03 -0.13 -0.09 -0.08 -0.02 -0.01 1.00 0.02
ebit_growth 0.01 0.01 -0.02 -0.02 -0.02 -0.01 0.02 1.00
EBIT_VOL_3Y 0.01 0.00 0.03 0.04 0.01 -0.01 0.00 0.00
EBIT_VOL_3Y
LTMTA 0.02
NIMTA -0.05
CASHMTA 0.04
PRICE -0.11
MBE -0.01
RSIZE -0.10
l_at -0.09
l_mkvalt -0.10
debt_ratio -0.02
debt_service -0.02
current_ratio 0.00
quick_ratio 0.01
cash_to_assets 0.01
wc_ratio 0.00
ebit_margin 0.03
gp_margin 0.04
asset_turnover 0.01
receivables_turnover -0.01
intangibility 0.00
ebit_growth 0.00
EBIT_VOL_3Y 1.00
# Identify high correlation pairs (|r| > 0.7)
high_cor <- which(abs(cor_matrix_financial) > 0.7 & abs(cor_matrix_financial) < 1, arr.ind = TRUE)
if(nrow(high_cor) > 0) {
cat("High correlations detected among financial variables:\n")
for(i in 1:nrow(high_cor)) {
if(high_cor[i, 1] < high_cor[i, 2]) { # avoid printing duplicates
cat(financial_covariates[high_cor[i, 1]], "and",
financial_covariates[high_cor[i, 2]], ":",
round(cor_matrix_financial[high_cor[i, 1], high_cor[i, 2]], 2), "\n")
}
}
# Identify variables to remove based on highest correlations
# Calculate the average correlation for each variable
avg_cor <- rowMeans(abs(cor_matrix_financial))
print("Average absolute correlation for each financial variable:")
print(sort(avg_cor, decreasing = TRUE))
# Identify pairs with high correlation
high_cor_pairs <- data.frame(
var1 = financial_covariates[high_cor[, 1]],
var2 = financial_covariates[high_cor[, 2]],
correlation = cor_matrix_financial[high_cor]
) %>%
filter(var1 < var2) %>% # Remove duplicates
arrange(desc(abs(correlation)))
print("Highly correlated financial variable pairs:")
print(high_cor_pairs)
# Remove variables with highest average correlation from each highly correlated pair
variables_to_remove <- c()
for(i in 1:nrow(high_cor_pairs)) {
var1 <- high_cor_pairs$var1[i]
var2 <- high_cor_pairs$var2[i]
# Skip if either variable is already marked for removal
if(var1 %in% variables_to_remove || var2 %in% variables_to_remove) {
next
}
# Remove the variable with higher average correlation
if(avg_cor[var1] > avg_cor[var2]) {
variables_to_remove <- c(variables_to_remove, var1)
} else {
variables_to_remove <- c(variables_to_remove, var2)
}
}
cat("Financial variables to remove due to high multicollinearity:\n")
print(variables_to_remove)
# Update financial covariates list
financial_covariates <- setdiff(financial_covariates, variables_to_remove)
cat("Remaining financial covariates after removing highly correlated variables:\n")
print(financial_covariates)
}
High correlations detected among financial variables:
PRICE and RSIZE : 0.82
RSIZE and l_at : 0.84
PRICE and l_mkvalt : 0.82
l_at and l_mkvalt : 0.84
current_ratio and quick_ratio : 0.94
ebit_margin and gp_margin : 0.82
[1] "Average absolute correlation for each financial variable:"
cash_to_assets l_at quick_ratio current_ratio CASHMTA RSIZE
0.29752252 0.28295661 0.27785758 0.27734226 0.27355856 0.26527350
l_mkvalt LTMTA PRICE wc_ratio NIMTA debt_ratio
0.26527350 0.26441233 0.26313526 0.26296002 0.22552870 0.22341849
ebit_margin gp_margin asset_turnover MBE intangibility debt_service
0.21060506 0.19541133 0.19192915 0.15758691 0.10866531 0.08741067
receivables_turnover EBIT_VOL_3Y ebit_growth
0.08617568 0.07979219 0.07188633
[1] "Highly correlated financial variable pairs:"
Financial variables to remove due to high multicollinearity:
[1] "quick_ratio" "l_at" "ebit_margin" "l_mkvalt" "RSIZE"
Remaining financial covariates after removing highly correlated variables:
[1] "LTMTA" "NIMTA" "CASHMTA" "PRICE" "MBE"
[6] "debt_ratio" "debt_service" "current_ratio" "cash_to_assets" "wc_ratio"
[11] "gp_margin" "asset_turnover" "receivables_turnover" "intangibility" "ebit_growth"
[16] "EBIT_VOL_3Y"
# 6.2: Check multicollinearity among macro covariates
cat("\n=== Checking multicollinearity among macro covariates ===\n")
=== Checking multicollinearity among macro covariates ===
cor_matrix_macro <- cor(data[, macro_covariates], use = "pairwise.complete.obs")
print(round(cor_matrix_macro, 2))
gdp_deflator unemployement gdp_growth
gdp_deflator 1.00 -0.39 0.26
unemployement -0.39 1.00 -0.50
gdp_growth 0.26 -0.50 1.00
# Check for high correlations among macro variables
high_cor_macro <- which(abs(cor_matrix_macro) > 0.7 & abs(cor_matrix_macro) < 1, arr.ind = TRUE)
if(nrow(high_cor_macro) > 0) {
cat("High correlations detected among macro variables:\n")
for(i in 1:nrow(high_cor_macro)) {
if(high_cor_macro[i, 1] < high_cor_macro[i, 2]) { # avoid printing duplicates
cat(macro_covariates[high_cor_macro[i, 1]], "and",
macro_covariates[high_cor_macro[i, 2]], ":",
round(cor_matrix_macro[high_cor_macro[i, 1], high_cor_macro[i, 2]], 2), "\n")
}
}
# For macro variables, we'll keep all of them and note the correlations for interpretation
cat("Note: All macro variables will be retained despite correlations for economic interpretation.\n")
cat("When interpreting results, consider these correlations for proper contextualization.\n")
} else {
cat("No high correlations detected among macro variables.\n")
}
No high correlations detected among macro variables.
# 6.3: Check correlation between financial and macro variables
cat("\n=== Checking correlation between financial and macro variables ===\n")
=== Checking correlation between financial and macro variables ===
cross_cor_matrix <- cor(data[, financial_covariates], data[, macro_covariates], use = "pairwise.complete.obs")
print(round(cross_cor_matrix, 2))
gdp_deflator unemployement gdp_growth
LTMTA -0.02 -0.03 -0.06
NIMTA -0.04 0.07 0.02
CASHMTA 0.02 0.02 -0.05
PRICE 0.05 -0.02 0.03
MBE 0.03 0.00 0.07
debt_ratio 0.03 -0.02 -0.04
debt_service -0.01 0.01 -0.01
current_ratio 0.01 0.00 0.02
cash_to_assets 0.02 0.01 -0.01
wc_ratio 0.00 0.03 0.03
gp_margin -0.02 0.02 0.00
asset_turnover -0.05 0.03 0.03
receivables_turnover 0.00 0.01 -0.01
intangibility 0.00 -0.01 0.01
ebit_growth 0.02 -0.02 0.04
EBIT_VOL_3Y 0.01 -0.01 0.01
# Identify high cross-correlations
high_cross_cor <- which(abs(cross_cor_matrix) > 0.5, arr.ind = TRUE)
if(nrow(high_cross_cor) > 0) {
cat("Notable correlations between financial and macro variables:\n")
for(i in 1:nrow(high_cross_cor)) {
cat(financial_covariates[high_cross_cor[i, 1]], "and",
macro_covariates[high_cross_cor[i, 2]], ":",
round(cross_cor_matrix[high_cross_cor[i, 1], high_cross_cor[i, 2]], 2), "\n")
}
cat("These correlations indicate relationships between firm financials and macroeconomic conditions.\n")
cat("Consider these when interpreting coefficients in the final models.\n")
}
# 6.4: Create the final list of all covariates for modeling
all_covariates <- c(financial_covariates, macro_covariates)
cat("\nFinal list of covariates for modeling:", length(all_covariates), "variables\n")
Final list of covariates for modeling: 19 variables
cat("Financial covariates:", length(financial_covariates), "\n")
Financial covariates: 16
cat("Macro covariates:", length(macro_covariates), "\n")
Macro covariates: 3
#-------------------------------------------------------------
# STEP 6.1: Calculate Altman Z-score
#-------------------------------------------------------------
cat("\nCalculating Altman Z-score for bankruptcy prediction...\n")
Calculating Altman Z-score for bankruptcy prediction...
# Create function to calculate Z-score based on available variables
calculate_z_score <- function(data) {
# Altman Z-score components:
# Z = 1.2X₁ + 1.4X₂ + 3.3X₃ + 0.6X₄ + 1.0X₅
# Where:
# X₁ = Working Capital / Total Assets
# X₂ = Retained Earnings / Total Assets (we'll use a proxy if not available)
# X₃ = EBIT / Total Assets
# X₄ = Market Value of Equity / Total Liabilities
# X₅ = Sales / Total Assets
# We'll adapt the calculation based on available variables in the dataset
# X₁: Working Capital / Total Assets (using wc_ratio if available)
X1 <- data$wc_ratio
# X₃: EBIT / Total Assets (using ebit_margin as a proxy, adjusted by asset turnover)
X3 <- data$ebit_margin * data$asset_turnover
# X₄: Market Value of Equity / Total Liabilities
# Approximating this using available variables:
# Market Value of Equity can be derived from LTMTA (Total Liabilities / Market Value)
# LTMTA = Total Liabilities / Market Value
# So Market Value = Total Liabilities / LTMTA
# And X₄ = Market Value / Total Liabilities = 1 / LTMTA
X4 <- 1 / data$LTMTA
# X₅: Sales / Total Assets (this is asset_turnover)
X5 <- data$asset_turnover
# For X₂, we don't have direct retained earnings data
# We can use NIMTA (Net Income / Market Value) as a rough proxy of profitability
# Adjusted to approximate Retained Earnings / Total Assets
X2 <- data$NIMTA * (1 / data$LTMTA) * 0.7 # Scaling factor to approximate
# Calculate Z-score with available components
# If some components are missing, we'll adjust the weights
z_score <- 1.2 * X1 + 1.4 * X2 + 3.3 * X3 + 0.6 * X4 + 1.0 * X5
return(z_score)
}
# Calculate Z-score for each row
data$z_score <- calculate_z_score(data)
# Check Z-score distribution
z_summary <- summary(data$z_score)
cat("Z-score summary statistics:\n")
Z-score summary statistics:
print(z_summary)
Min. 1st Qu. Median Mean 3rd Qu. Max.
-413.956 2.397 3.872 7.118 6.846 125.627
# Define risk categories based on Z-score
data$z_risk_category <- cut(data$z_score,
breaks = c(-Inf, 1.81, 2.99, Inf),
labels = c("High Risk", "Grey Zone", "Low Risk"))
# Display distribution of risk categories
z_distribution <- table(data$z_risk_category)
cat("\nDistribution of Z-score risk categories:\n")
Distribution of Z-score risk categories:
print(z_distribution)
High Risk Grey Zone Low Risk
10035 12720 40836
print(prop.table(z_distribution) * 100)
High Risk Grey Zone Low Risk
15.78053 20.00283 64.21663
# Check correlation between Z-score and event types
cat("\nMean Z-score by final outcome:\n")
Mean Z-score by final outcome:
aggregate(z_score ~ finalevent, data = data, mean)
# Add Z-score to financial covariates list
financial_covariates <- c(financial_covariates, "z_score")
cat("\nAdded Z-score to financial covariates list.\n")
Added Z-score to financial covariates list.
cat("Updated financial covariates:", length(financial_covariates), "variables\n")
Updated financial covariates: 17 variables
# Update the combined covariates list as well
all_covariates <- c(financial_covariates, macro_covariates)
cat("Updated all covariates list:", length(all_covariates), "variables\n")
Updated all covariates list: 20 variables
# Visualize Z-score distribution by event type if ggplot2 is available
if(requireNamespace("ggplot2", quietly = TRUE)) {
# Create data for visualization
plot_data <- data %>%
group_by(cusip) %>%
slice_max(tstop) %>% # Get last observation for each company
ungroup() %>%
mutate(event_label = case_when(
event_type == 0 ~ "Censored",
event_type == 1 ~ "Bankruptcy",
event_type == 2 ~ "Acquisition"
))
# Box plot of Z-score by event type
p <- ggplot(plot_data, aes(x = event_label, y = z_score, fill = event_label)) +
geom_boxplot() +
geom_hline(yintercept = 1.81, linetype = "dashed", color = "red") +
geom_hline(yintercept = 2.99, linetype = "dashed", color = "blue") +
scale_fill_manual(values = c("Censored" = "grey", "Bankruptcy" = "red", "Acquisition" = "blue")) +
labs(title = "Altman Z-score by Company Outcome",
x = "Final Company Status",
y = "Z-score",
subtitle = "Red line = 1.81 (High Risk Threshold), Blue line = 2.99 (Low Risk Threshold)") +
theme_minimal()
print(p)
ggsave("z_score_by_outcome.png", p, width = 8, height = 6)
}
Here we show the Kaplan-Meier survival curves for bankruptcy and
acquisition events. We also calculate median survival times and plot the
curves together for comparison. The survminer package is
used to create more detailed plots with risk tables. We also have
survival curves stratified by industry sector for both bankruptcy and
acquisition events.
#-------------------------------------------------------------
cat("\n=== Survival Curve Analysis for Bankruptcy and Acquisition ===\n")
=== Survival Curve Analysis for Bankruptcy and Acquisition ===
# Create separate survival objects for each event type
surv_bankruptcy <- Surv(data$tstart, data$tstop, data$bankruptcy)
surv_acquisition <- Surv(data$tstart, data$tstop, data$acquisition)
# Fit Kaplan-Meier survival curves
km_bankruptcy <- survfit(surv_bankruptcy ~ 1, data = data)
km_acquisition <- survfit(surv_acquisition ~ 1, data = data)
# Basic summary of survival estimates
cat("\nSummary of Bankruptcy Survival Curve:\n")
Summary of Bankruptcy Survival Curve:
print(summary(km_bankruptcy, times = c(1, 3, 5, 10)))
Call: survfit(formula = surv_bankruptcy ~ 1, data = data)
time n.risk n.event survival std.err lower 95% CI upper 95% CI
1 4909 4 0.999 0.000815 0.997 1.000
3 4353 30 0.990 0.001767 0.987 0.994
5 3628 23 0.984 0.002257 0.980 0.989
10 2413 45 0.965 0.003858 0.958 0.973
cat("\nSummary of Acquisition Survival Curve:\n")
Summary of Acquisition Survival Curve:
print(summary(km_acquisition, times = c(1, 3, 5, 10)))
Call: survfit(formula = surv_acquisition ~ 1, data = data)
time n.risk n.event survival std.err lower 95% CI upper 95% CI
1 4909 64 0.980 0.00306 0.974 0.986
3 4353 271 0.908 0.00514 0.898 0.919
5 3628 277 0.824 0.00756 0.809 0.839
10 2413 581 0.641 0.00952 0.622 0.660
# Calculate median survival times (if they exist)
cat("\nMedian Survival Times:\n")
Median Survival Times:
bankruptcy_median <- summary(km_bankruptcy)$table["median"]
if(is.na(bankruptcy_median)) {
cat("Bankruptcy: More than 50% of companies survive the entire observation period without bankruptcy\n")
} else {
cat("Bankruptcy: Median survival time =", round(bankruptcy_median, 2), "years\n")
}
Bankruptcy: More than 50% of companies survive the entire observation period without bankruptcy
acquisition_median <- summary(km_acquisition)$table["median"]
if(is.na(acquisition_median)) {
cat("Acquisition: More than 50% of companies survive the entire observation period without being acquired\n")
} else {
cat("Acquisition: Median survival time =", round(acquisition_median, 2), "years\n")
}
Acquisition: Median survival time = 15 years
# Plot both survival curves together for comparison
par(mfrow = c(1, 1)) # Reset plotting parameters
combined_plot <- plot(km_bankruptcy,
conf.int = TRUE,
col = "red",
lwd = 2,
xlab = "Years",
ylab = "Survival Probability",
main = "Kaplan-Meier Survival Curves: Bankruptcy vs Acquisition")
# Add acquisition curve
lines(km_acquisition, col = "blue", lwd = 2, conf.int = TRUE, lty = 1)
# Add legend
legend("topright",
legend = c("Bankruptcy", "Acquisition"),
col = c("red", "blue"),
lwd = 2,
cex = 0.8)
# Save the plot
dev.copy(png, "combined_survival_curves.png", width = 800, height = 600)
png
3
dev.off()
png
2
# Create more detailed plots using survminer
if(requireNamespace("survminer", quietly = TRUE)) {
# Bankruptcy survival curve with risk table
p_bankruptcy <- ggsurvplot(
km_bankruptcy,
data = data,
risk.table = TRUE,
risk.table.col = "strata",
ggtheme = theme_minimal(),
palette = "red",
title = "Bankruptcy Survival Curve",
xlab = "Years",
ylab = "Probability of Not Going Bankrupt",
conf.int = TRUE,
surv.median.line = "hv"
)
print(p_bankruptcy)
ggsave("bankruptcy_survival_curve.png", p_bankruptcy$plot, width = 10, height = 8)
# Acquisition survival curve with risk table
p_acquisition <- ggsurvplot(
km_acquisition,
data = data,
risk.table = TRUE,
risk.table.col = "strata",
ggtheme = theme_minimal(),
palette = "blue",
title = "Acquisition Survival Curve",
xlab = "Years",
ylab = "Probability of Not Being Acquired",
conf.int = TRUE,
surv.median.line = "hv"
)
print(p_acquisition)
ggsave("acquisition_survival_curve.png", p_acquisition$plot, width = 10, height = 8)
# Combined plot with survminer
# First create separate survfit objects with labels
km_bankruptcy_labeled <- survfit(surv_bankruptcy ~ rep("Bankruptcy", nrow(data)), data = data)
km_acquisition_labeled <- survfit(surv_acquisition ~ rep("Acquisition", nrow(data)), data = data)
# Combine them
combined_survfit <- list(Bankruptcy = km_bankruptcy, Acquisition = km_acquisition)
class(combined_survfit) <- c("survfitlist", "list")
# Plot combined curves
p_combined <- ggsurvplot(
combined_survfit,
data = data,
risk.table = TRUE,
risk.table.col = "strata",
ggtheme = theme_minimal(),
palette = c("red", "blue"),
title = "Comparison of Bankruptcy and Acquisition Survival Curves",
xlab = "Years",
ylab = "Survival Probability",
conf.int = TRUE,
legend.labs = c("Bankruptcy", "Acquisition"),
legend.title = "Event Type"
)
print(p_combined)
ggsave("combined_survival_curves_ggplot.png", p_combined$plot, width = 10, height = 8)
# Create stratified survival curves by industry sector for bankruptcy
sector_bankruptcy <- survfit(surv_bankruptcy ~ gsector, data = data)
p_sector_bankruptcy <- ggsurvplot(
sector_bankruptcy,
data = data,
risk.table = TRUE,
risk.table.col = "strata",
ggtheme = theme_minimal(),
palette = "jco",
title = "Bankruptcy Survival Curves by Industry Sector",
xlab = "Years",
ylab = "Probability of Not Going Bankrupt",
conf.int = FALSE,
legend.title = "Industry Sector"
)
print(p_sector_bankruptcy)
ggsave("bankruptcy_by_sector.png", p_sector_bankruptcy$plot, width = 12, height = 9)
# Create stratified survival curves by industry sector for acquisition
sector_acquisition <- survfit(surv_acquisition ~ gsector, data = data)
p_sector_acquisition <- ggsurvplot(
sector_acquisition,
data = data,
risk.table = TRUE,
risk.table.col = "strata",
ggtheme = theme_minimal(),
palette = "jco",
title = "Acquisition Survival Curves by Industry Sector",
xlab = "Years",
ylab = "Probability of Not Being Acquired",
conf.int = FALSE,
legend.title = "Industry Sector"
)
print(p_sector_acquisition)
ggsave("acquisition_by_sector.png", p_sector_acquisition$plot, width = 12, height = 9)
}
Warning: Median survival not reached.
$Bankruptcy
$Acquisition
attr(,"class")
[1] "list" "ggsurvplot_list"
We start by fitting Cox proportional hazards models with Z-score as the only predictor. We then fit individual Cox models for each macroeconomic variable, including stratification by industry sector. We calculate concordance (C-index) for each model to assess predictive performance. Finally, we visualize the results and compare the models.
#-------------------------------------------------------------
# STEP 6.2: Z-score Only Cox Models
#-------------------------------------------------------------
cat("\nFitting Cox models with Z-score as the only predictor...\n")
Fitting Cox models with Z-score as the only predictor...
# Create formulas with Z-score as the only predictor
# Include stratification by industry sector
z_bankruptcy_formula <- as.formula("Surv(tstart, tstop, bankruptcy) ~ z_score + strata(gsector)")
z_acquisition_formula <- as.formula("Surv(tstart, tstop, acquisition) ~ z_score + strata(gsector)")
# Fit models
z_bankruptcy_model <- coxph(z_bankruptcy_formula, data = data, ties = "efron")
z_acquisition_model <- coxph(z_acquisition_formula, data = data, ties = "efron")
# Display model summaries
cat("\n=== Z-SCORE ONLY: BANKRUPTCY MODEL ===\n")
=== Z-SCORE ONLY: BANKRUPTCY MODEL ===
print(summary(z_bankruptcy_model))
Call:
coxph(formula = z_bankruptcy_formula, data = data, ties = "efron")
n= 63591, number of events= 176
coef exp(coef) se(coef) z Pr(>|z|)
z_score -0.015265 0.984851 0.003297 -4.63 3.65e-06 ***
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
z_score 0.9849 1.015 0.9785 0.9912
Concordance= 0.773 (se = 0.026 )
Likelihood ratio test= 12.46 on 1 df, p=4e-04
Wald test = 21.44 on 1 df, p=4e-06
Score (logrank) test = 18.74 on 1 df, p=1e-05
cat("\n=== Z-SCORE ONLY: ACQUISITION MODEL ===\n")
=== Z-SCORE ONLY: ACQUISITION MODEL ===
print(summary(z_acquisition_model))
Call:
coxph(formula = z_acquisition_formula, data = data, ties = "efron")
n= 63591, number of events= 2154
coef exp(coef) se(coef) z Pr(>|z|)
z_score -0.0131 0.9870 0.0013 -10.08 <2e-16 ***
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
z_score 0.987 1.013 0.9845 0.9895
Concordance= 0.571 (se = 0.007 )
Likelihood ratio test= 64.21 on 1 df, p=1e-15
Wald test = 101.6 on 1 df, p=<2e-16
Score (logrank) test = 67.53 on 1 df, p=<2e-16
# Calculate concordance (C-index) as a measure of predictive ability
cat("\nPredictive performance (C-index):\n")
Predictive performance (C-index):
cat("Z-score only bankruptcy model:", round(z_bankruptcy_model$concordance["concordance"], 3), "\n")
Z-score only bankruptcy model: 0.773
cat("Z-score only acquisition model:", round(z_acquisition_model$concordance["concordance"], 3), "\n")
Z-score only acquisition model: 0.571
# Check proportional hazards assumption
cat("\nTesting proportional hazards assumption for Z-score models...\n")
Testing proportional hazards assumption for Z-score models...
ph_test_z_bankruptcy <- cox.zph(z_bankruptcy_model)
ph_test_z_acquisition <- cox.zph(z_acquisition_model)
cat("\n=== PH TEST FOR Z-SCORE BANKRUPTCY MODEL ===\n")
=== PH TEST FOR Z-SCORE BANKRUPTCY MODEL ===
print(ph_test_z_bankruptcy)
chisq df p
z_score 1.25 1 0.26
GLOBAL 1.25 1 0.26
cat("\n=== PH TEST FOR Z-SCORE ACQUISITION MODEL ===\n")
=== PH TEST FOR Z-SCORE ACQUISITION MODEL ===
print(ph_test_z_acquisition)
chisq df p
z_score 27.1 1 1.9e-07
GLOBAL 27.1 1 1.9e-07
# Store models for later comparison
z_score_models <- list(
bankruptcy = z_bankruptcy_model,
acquisition = z_acquisition_model
)
#-------------------------------------------------------------
# STEP 6.3: Macro Variables Only Cox Models
#-------------------------------------------------------------
cat("\nFitting Cox models with individual macro variables as predictors...\n")
Fitting Cox models with individual macro variables as predictors...
# Create empty lists to store models
macro_bankruptcy_models <- list()
macro_acquisition_models <- list()
# Concordance results for all models
concordance_results <- data.frame(
Variable = c("z_score", macro_covariates),
BK_Concordance = NA,
ACQ_Concordance = NA
)
# Add Z-score concordance
concordance_results$BK_Concordance[concordance_results$Variable == "z_score"] <-
z_bankruptcy_model$concordance["concordance"]
concordance_results$ACQ_Concordance[concordance_results$Variable == "z_score"] <-
z_acquisition_model$concordance["concordance"]
# Fit individual models for each macro variable
for(var in macro_covariates) {
cat("\nTesting macro variable:", var, "\n")
# Create formulas with single macro variable
macro_bk_formula <- as.formula(paste0("Surv(tstart, tstop, bankruptcy) ~ ", var, " + strata(gsector)"))
macro_acq_formula <- as.formula(paste0("Surv(tstart, tstop, acquisition) ~ ", var, " + strata(gsector)"))
# Fit models
tryCatch({
bk_model <- coxph(macro_bk_formula, data = data, ties = "efron")
macro_bankruptcy_models[[var]] <- bk_model
# Store concordance
concordance_results$BK_Concordance[concordance_results$Variable == var] <-
bk_model$concordance["concordance"]
# Print summary
cat("\n=== MACRO ONLY (", var, "): BANKRUPTCY MODEL ===\n")
print(summary(bk_model))
}, error = function(e) {
cat("Error fitting bankruptcy model with", var, ":", e$message, "\n")
})
tryCatch({
acq_model <- coxph(macro_acq_formula, data = data, ties = "efron")
macro_acquisition_models[[var]] <- acq_model
# Store concordance
concordance_results$ACQ_Concordance[concordance_results$Variable == var] <-
acq_model$concordance["concordance"]
# Print summary
cat("\n=== MACRO ONLY (", var, "): ACQUISITION MODEL ===\n")
print(summary(acq_model))
}, error = function(e) {
cat("Error fitting acquisition model with", var, ":", e$message, "\n")
})
}
Testing macro variable: gdp_deflator
=== MACRO ONLY ( gdp_deflator ): BANKRUPTCY MODEL ===
Call:
coxph(formula = macro_bk_formula, data = data, ties = "efron")
n= 63591, number of events= 176
coef exp(coef) se(coef) z Pr(>|z|)
gdp_deflator -0.12067 0.88633 0.07614 -1.585 0.113
exp(coef) exp(-coef) lower .95 upper .95
gdp_deflator 0.8863 1.128 0.7635 1.029
Concordance= 0.57 (se = 0.025 )
Likelihood ratio test= 2.72 on 1 df, p=0.1
Wald test = 2.51 on 1 df, p=0.1
Score (logrank) test = 2.52 on 1 df, p=0.1
=== MACRO ONLY ( gdp_deflator ): ACQUISITION MODEL ===
Call:
coxph(formula = macro_acq_formula, data = data, ties = "efron")
n= 63591, number of events= 2154
coef exp(coef) se(coef) z Pr(>|z|)
gdp_deflator -0.01524 0.98487 0.01989 -0.766 0.443
exp(coef) exp(-coef) lower .95 upper .95
gdp_deflator 0.9849 1.015 0.9472 1.024
Concordance= 0.548 (se = 0.009 )
Likelihood ratio test= 0.59 on 1 df, p=0.4
Wald test = 0.59 on 1 df, p=0.4
Score (logrank) test = 0.59 on 1 df, p=0.4
Testing macro variable: unemployement
=== MACRO ONLY ( unemployement ): BANKRUPTCY MODEL ===
Call:
coxph(formula = macro_bk_formula, data = data, ties = "efron")
n= 63591, number of events= 176
coef exp(coef) se(coef) z Pr(>|z|)
unemployement -0.19272 0.82471 0.05731 -3.363 0.000771 ***
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
unemployement 0.8247 1.213 0.7371 0.9227
Concordance= 0.583 (se = 0.026 )
Likelihood ratio test= 12.59 on 1 df, p=4e-04
Wald test = 11.31 on 1 df, p=8e-04
Score (logrank) test = 11.51 on 1 df, p=7e-04
=== MACRO ONLY ( unemployement ): ACQUISITION MODEL ===
Call:
coxph(formula = macro_acq_formula, data = data, ties = "efron")
n= 63591, number of events= 2154
coef exp(coef) se(coef) z Pr(>|z|)
unemployement -0.03775 0.96295 0.01430 -2.64 0.0083 **
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
unemployement 0.9629 1.038 0.9363 0.9903
Concordance= 0.56 (se = 0.008 )
Likelihood ratio test= 7.09 on 1 df, p=0.008
Wald test = 6.97 on 1 df, p=0.008
Score (logrank) test = 6.97 on 1 df, p=0.008
Testing macro variable: gdp_growth
=== MACRO ONLY ( gdp_growth ): BANKRUPTCY MODEL ===
Call:
coxph(formula = macro_bk_formula, data = data, ties = "efron")
n= 63591, number of events= 176
coef exp(coef) se(coef) z Pr(>|z|)
gdp_growth 0.03280 1.03334 0.04525 0.725 0.469
exp(coef) exp(-coef) lower .95 upper .95
gdp_growth 1.033 0.9677 0.9456 1.129
Concordance= 0.534 (se = 0.03 )
Likelihood ratio test= 0.54 on 1 df, p=0.5
Wald test = 0.53 on 1 df, p=0.5
Score (logrank) test = 0.53 on 1 df, p=0.5
=== MACRO ONLY ( gdp_growth ): ACQUISITION MODEL ===
Call:
coxph(formula = macro_acq_formula, data = data, ties = "efron")
n= 63591, number of events= 2154
coef exp(coef) se(coef) z Pr(>|z|)
gdp_growth 0.03150 1.03201 0.01266 2.489 0.0128 *
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
gdp_growth 1.032 0.969 1.007 1.058
Concordance= 0.529 (se = 0.008 )
Likelihood ratio test= 6.32 on 1 df, p=0.01
Wald test = 6.2 on 1 df, p=0.01
Score (logrank) test = 6.2 on 1 df, p=0.01
# Compare predictive performance
cat("\nComparison of predictive performance (C-index):\n")
Comparison of predictive performance (C-index):
concordance_results <- concordance_results %>%
arrange(desc(BK_Concordance))
print(concordance_results)
# Visualize comparison
if(requireNamespace("ggplot2", quietly = TRUE)) {
# Prepare data for plotting
plot_data <- concordance_results %>%
pivot_longer(cols = c(BK_Concordance, ACQ_Concordance),
names_to = "Model",
values_to = "Concordance") %>%
mutate(Model = ifelse(Model == "BK_Concordance", "Bankruptcy", "Acquisition"))
# Create plot
p <- ggplot(plot_data, aes(x = reorder(Variable, Concordance), y = Concordance, fill = Model)) +
geom_bar(stat = "identity", position = "dodge") +
coord_flip() +
labs(title = "Predictive Performance of Individual Variables",
subtitle = "Comparing Z-score vs. Macroeconomic Variables",
x = "Variable",
y = "Concordance (C-index)") +
theme_minimal() +
theme(legend.position = "bottom")
print(p)
ggsave("single_predictor_comparison.png", p, width = 10, height = 6)
}
# Test the best macro variable and Z-score together
best_macro <- concordance_results$Variable[concordance_results$Variable != "z_score"][1]
cat("\nTesting Z-score and best macro variable (", best_macro, ") together...\n")
Testing Z-score and best macro variable ( unemployement ) together...
# Create formula with Z-score and best macro variable
combined_bk_formula <- as.formula(paste0("Surv(tstart, tstop, bankruptcy) ~ z_score + ",
best_macro, " + strata(gsector)"))
combined_acq_formula <- as.formula(paste0("Surv(tstart, tstop, acquisition) ~ z_score + ",
best_macro, " + strata(gsector)"))
# Fit models
combined_bk_model <- coxph(combined_bk_formula, data = data, ties = "efron")
combined_acq_model <- coxph(combined_acq_formula, data = data, ties = "efron")
# Display model summaries
cat("\n=== Z-SCORE + BEST MACRO: BANKRUPTCY MODEL ===\n")
=== Z-SCORE + BEST MACRO: BANKRUPTCY MODEL ===
print(summary(combined_bk_model))
Call:
coxph(formula = combined_bk_formula, data = data, ties = "efron")
n= 63591, number of events= 176
coef exp(coef) se(coef) z Pr(>|z|)
z_score -0.015370 0.984748 0.003456 -4.447 8.69e-06 ***
unemployement -0.189444 0.827419 0.057053 -3.320 0.000899 ***
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
z_score 0.9847 1.015 0.9781 0.9914
unemployement 0.8274 1.209 0.7399 0.9253
Concordance= 0.636 (se = 0.024 )
Likelihood ratio test= 24.71 on 2 df, p=4e-06
Wald test = 30.61 on 2 df, p=2e-07
Score (logrank) test = 29.38 on 2 df, p=4e-07
cat("\n=== Z-SCORE + BEST MACRO: ACQUISITION MODEL ===\n")
=== Z-SCORE + BEST MACRO: ACQUISITION MODEL ===
print(summary(combined_acq_model))
Call:
coxph(formula = combined_acq_formula, data = data, ties = "efron")
n= 63591, number of events= 2154
coef exp(coef) se(coef) z Pr(>|z|)
z_score -0.013102 0.986984 0.001307 -10.023 <2e-16 ***
unemployement -0.036113 0.964531 0.014267 -2.531 0.0114 *
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
z_score 0.9870 1.013 0.9845 0.9895
unemployement 0.9645 1.037 0.9379 0.9919
Concordance= 0.584 (se = 0.007 )
Likelihood ratio test= 70.73 on 2 df, p=4e-16
Wald test = 106.9 on 2 df, p=<2e-16
Score (logrank) test = 73.51 on 2 df, p=<2e-16
# Compare concordance
cat("\nCombined model performance (C-index):\n")
Combined model performance (C-index):
cat("Z-score + Best Macro bankruptcy model:",
round(combined_bk_model$concordance["concordance"], 3), "\n")
Z-score + Best Macro bankruptcy model: 0.636
cat("Z-score + Best Macro acquisition model:",
round(combined_acq_model$concordance["concordance"], 3), "\n")
Z-score + Best Macro acquisition model: 0.584
# Test for improvement using likelihood ratio test
cat("\nLikelihood ratio test for improvement over Z-score alone:\n")
Likelihood ratio test for improvement over Z-score alone:
cat("Bankruptcy model improvement:\n")
Bankruptcy model improvement:
print(anova(z_bankruptcy_model, combined_bk_model))
Analysis of Deviance Table
Cox model: response is Surv(tstart, tstop, bankruptcy)
Model 1: ~ z_score + strata(gsector)
Model 2: ~ z_score + unemployement + strata(gsector)
loglik Chisq Df Pr(>|Chi|)
1 -990.23
2 -984.11 12.25 1 0.0004653 ***
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
cat("Acquisition model improvement:\n")
Acquisition model improvement:
print(anova(z_acquisition_model, combined_acq_model))
Analysis of Deviance Table
Cox model: response is Surv(tstart, tstop, acquisition)
Model 1: ~ z_score + strata(gsector)
Model 2: ~ z_score + unemployement + strata(gsector)
loglik Chisq Df Pr(>|Chi|)
1 -12304
2 -12300 6.516 1 0.01069 *
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
# Store combined models for later comparison
combined_models <- list(
bankruptcy = combined_bk_model,
acquisition = combined_acq_model
)
Here, we start by performing variable selection using stepwise regression and LASSO methods. We then fit Cox models with the selected variables and evaluate their performance. We also visualize the results and compare the models.
#-------------------------------------------------------------
# STEP 7: Variable Selection with Financial and Macro Variables
#-------------------------------------------------------------
cat("\nPerforming variable selection using both stepwise and LASSO methods...\n")
Performing variable selection using both stepwise and LASSO methods...
#-------------------------------------------------------------
# 7.1: Pre-screening of Macroeconomic Variables
#-------------------------------------------------------------
cat("\n7.1: Pre-screening Macroeconomic Variables with Univariate Models\n")
7.1: Pre-screening Macroeconomic Variables with Univariate Models
# Pre-screen macro variables with univariate models
macro_screening <- data.frame(
Variable = character(),
BK_Coefficient = numeric(),
BK_P_Value = numeric(),
BK_Concordance = numeric(),
ACQ_Coefficient = numeric(),
ACQ_P_Value = numeric(),
ACQ_Concordance = numeric(),
stringsAsFactors = FALSE
)
for(var in macro_covariates) {
# Test for bankruptcy
bk_formula <- as.formula(paste0("Surv(tstart, tstop, bankruptcy) ~ ", var, " + strata(gsector)"))
bk_model <- coxph(bk_formula, data = data, ties = "efron")
bk_summary <- summary(bk_model)
# Test for acquisition
acq_formula <- as.formula(paste0("Surv(tstart, tstop, acquisition) ~ ", var, " + strata(gsector)"))
acq_model <- coxph(acq_formula, data = data, ties = "efron")
acq_summary <- summary(acq_model)
# Store results
macro_screening <- rbind(macro_screening, data.frame(
Variable = var,
BK_Coefficient = bk_summary$coefficients[1, 1],
BK_P_Value = bk_summary$coefficients[1, 5],
BK_Concordance = bk_model$concordance["concordance"],
ACQ_Coefficient = acq_summary$coefficients[1, 1],
ACQ_P_Value = acq_summary$coefficients[1, 5],
ACQ_Concordance = acq_model$concordance["concordance"],
stringsAsFactors = FALSE
))
}
# Print macro variable screening results
cat("\nMacroeconomic variables univariate testing results:\n")
Macroeconomic variables univariate testing results:
print(macro_screening)
# Identify significant macro variables (p < 0.05)
significant_bk_macro <- macro_screening$Variable[macro_screening$BK_P_Value < 0.05]
significant_acq_macro <- macro_screening$Variable[macro_screening$ACQ_P_Value < 0.05]
cat("\nSignificant macro variables for bankruptcy:", paste(significant_bk_macro, collapse=", "), "\n")
Significant macro variables for bankruptcy: unemployement
cat("Significant macro variables for acquisition:", paste(significant_acq_macro, collapse=", "), "\n")
Significant macro variables for acquisition: unemployement, gdp_growth
#-------------------------------------------------------------
# 7.2: AIC-based Stepwise Selection with All Variables
#-------------------------------------------------------------
cat("\n7.2: AIC-based Stepwise Selection with Financial and Macro Variables\n")
7.2: AIC-based Stepwise Selection with Financial and Macro Variables
# Create the full model formula for bankruptcy (including all variables)
full_bankruptcy_formula <- as.formula(paste0(
"Surv(tstart, tstop, bankruptcy) ~ ",
paste(c(financial_covariates, macro_covariates), collapse = " + "),
" + strata(gsector)"
))
# Create the full model formula for acquisition (including all variables)
full_acquisition_formula <- as.formula(paste0(
"Surv(tstart, tstop, acquisition) ~ ",
paste(c(financial_covariates, macro_covariates), collapse = " + "),
" + strata(gsector)"
))
# Fit the full models
full_bankruptcy_model <- coxph(full_bankruptcy_formula, data = data, ties = "efron")
full_acquisition_model <- coxph(full_acquisition_formula, data = data, ties = "efron")
# Perform stepwise selection for bankruptcy model
stepwise_bankruptcy <- step(full_bankruptcy_model, direction = "both", trace = 1)
Start: AIC=1596.41
Surv(tstart, tstop, bankruptcy) ~ LTMTA + NIMTA + CASHMTA + PRICE +
MBE + debt_ratio + debt_service + current_ratio + cash_to_assets +
wc_ratio + gp_margin + asset_turnover + receivables_turnover +
intangibility + ebit_growth + EBIT_VOL_3Y + z_score + gdp_deflator +
unemployement + gdp_growth + strata(gsector)
Step: AIC=2243.98
Surv(tstart, tstop, bankruptcy) ~ LTMTA + NIMTA + CASHMTA + PRICE +
MBE + debt_ratio + debt_service + current_ratio + cash_to_assets +
wc_ratio + gp_margin + asset_turnover + receivables_turnover +
intangibility + ebit_growth + EBIT_VOL_3Y + z_score + gdp_deflator +
unemployement + gdp_growth
# Perform stepwise selection for acquisition model
stepwise_acquisition <- step(full_acquisition_model, direction = "both", trace = 1)
Start: AIC=24299.87
Surv(tstart, tstop, acquisition) ~ LTMTA + NIMTA + CASHMTA +
PRICE + MBE + debt_ratio + debt_service + current_ratio +
cash_to_assets + wc_ratio + gp_margin + asset_turnover +
receivables_turnover + intangibility + ebit_growth + EBIT_VOL_3Y +
z_score + gdp_deflator + unemployement + gdp_growth + strata(gsector)
Step: AIC=32170.03
Surv(tstart, tstop, acquisition) ~ LTMTA + NIMTA + CASHMTA +
PRICE + MBE + debt_ratio + debt_service + current_ratio +
cash_to_assets + wc_ratio + gp_margin + asset_turnover +
receivables_turnover + intangibility + ebit_growth + EBIT_VOL_3Y +
z_score + gdp_deflator + unemployement + gdp_growth
# Get the final selected variables for each model
bankruptcy_vars_step <- names(coef(stepwise_bankruptcy))
bankruptcy_vars_step <- bankruptcy_vars_step[!grepl("strata", bankruptcy_vars_step)]
acquisition_vars_step <- names(coef(stepwise_acquisition))
acquisition_vars_step <- acquisition_vars_step[!grepl("strata", acquisition_vars_step)]
cat("\nSelected variables for bankruptcy model (stepwise):\n")
Selected variables for bankruptcy model (stepwise):
print(bankruptcy_vars_step)
[1] "LTMTA" "NIMTA" "CASHMTA" "PRICE" "MBE"
[6] "debt_ratio" "debt_service" "current_ratio" "cash_to_assets" "wc_ratio"
[11] "gp_margin" "asset_turnover" "receivables_turnover" "intangibility" "ebit_growth"
[16] "EBIT_VOL_3Y" "z_score" "gdp_deflator" "unemployement" "gdp_growth"
cat("\nSelected variables for acquisition model (stepwise):\n")
Selected variables for acquisition model (stepwise):
print(acquisition_vars_step)
[1] "LTMTA" "NIMTA" "CASHMTA" "PRICE" "MBE"
[6] "debt_ratio" "debt_service" "current_ratio" "cash_to_assets" "wc_ratio"
[11] "gp_margin" "asset_turnover" "receivables_turnover" "intangibility" "ebit_growth"
[16] "EBIT_VOL_3Y" "z_score" "gdp_deflator" "unemployement" "gdp_growth"
# Identify financial and macro variables selected
bankruptcy_fin_step <- bankruptcy_vars_step[bankruptcy_vars_step %in% financial_covariates]
bankruptcy_macro_step <- bankruptcy_vars_step[bankruptcy_vars_step %in% macro_covariates]
acquisition_fin_step <- acquisition_vars_step[acquisition_vars_step %in% financial_covariates]
acquisition_macro_step <- acquisition_vars_step[acquisition_vars_step %in% macro_covariates]
cat("\nBreakdown of stepwise selection for bankruptcy model:\n")
Breakdown of stepwise selection for bankruptcy model:
cat("- Financial variables:", length(bankruptcy_fin_step), "of", length(financial_covariates), "\n")
- Financial variables: 17 of 17
cat("- Macro variables:", length(bankruptcy_macro_step), "of", length(macro_covariates), "\n")
- Macro variables: 3 of 3
cat("\nBreakdown of stepwise selection for acquisition model:\n")
Breakdown of stepwise selection for acquisition model:
cat("- Financial variables:", length(acquisition_fin_step), "of", length(financial_covariates), "\n")
- Financial variables: 17 of 17
cat("- Macro variables:", length(acquisition_macro_step), "of", length(macro_covariates), "\n")
- Macro variables: 3 of 3
#-------------------------------------------------------------
# 7.3: LASSO Variable Selection with All Variables
#-------------------------------------------------------------
cat("\n7.3: LASSO-based Variable Selection with Financial and Macro Variables\n")
7.3: LASSO-based Variable Selection with Financial and Macro Variables
# Check if glmnet is available, install if needed
if(!requireNamespace("glmnet", quietly = TRUE)) {
install.packages("glmnet")
}
library(glmnet)
# Get last observation for each company
last_obs_data <- data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
cat("Using", nrow(last_obs_data), "observations (last record from each company) for LASSO variable selection\n")
Using 5038 observations (last record from each company) for LASSO variable selection
# Function to prepare data for LASSO Cox model (including macro variables)
prepare_lasso_data <- function(data, outcome_var) {
# Create predictor matrix with both financial and macro variables
x_vars <- data[, c(financial_covariates, macro_covariates), drop = FALSE]
# Create model matrix (handles factors appropriately)
x_matrix <- model.matrix(~ . - 1, data = x_vars) # -1 removes intercept
# Create Surv object for outcome
if(outcome_var == "bankruptcy") {
y_surv <- survival::Surv(data$tstop, data$bankruptcy) # Using only tstop for final status
} else {
y_surv <- survival::Surv(data$tstop, data$acquisition)
}
return(list(x = x_matrix, y = y_surv))
}
# Prepare data for bankruptcy model
lasso_data_bank <- prepare_lasso_data(last_obs_data, "bankruptcy")
# Prepare data for acquisition model
lasso_data_acq <- prepare_lasso_data(last_obs_data, "acquisition")
# Run LASSO without cross-validation first to see variable paths
fit_bank <- glmnet(lasso_data_bank$x, lasso_data_bank$y, family = "cox", alpha = 1)
fit_acq <- glmnet(lasso_data_acq$x, lasso_data_acq$y, family = "cox", alpha = 1)
# Plot coefficient paths
cat("Creating coefficient path plots...\n")
Creating coefficient path plots...
par(mfrow = c(1, 2))
plot(fit_bank, xvar = "lambda", main = "Bankruptcy Model")
plot(fit_acq, xvar = "lambda", main = "Acquisition Model")
par(mfrow = c(1, 1))
# Run cross-validation to find optimal lambda
cat("Running cross-validation with 3 folds to find optimal lambda...\n")
Running cross-validation with 3 folds to find optimal lambda...
set.seed(123)
cv_fit_bank <- cv.glmnet(lasso_data_bank$x, lasso_data_bank$y,
family = "cox", alpha = 1, nfolds = 3,
parallel = FALSE, keep = FALSE)
cv_fit_acq <- cv.glmnet(lasso_data_acq$x, lasso_data_acq$y,
family = "cox", alpha = 1, nfolds = 3,
parallel = FALSE, keep = FALSE)
# Plot cross-validation results
cat("Creating cross-validation plots for lambda selection...\n")
Creating cross-validation plots for lambda selection...
par(mfrow = c(1, 2))
plot(cv_fit_bank, main = "Bankruptcy Model CV")
plot(cv_fit_acq, main = "Acquisition Model CV")
par(mfrow = c(1, 1))
# Get optimal lambda values
lambda_bank_min <- cv_fit_bank$lambda.min # Lambda that gives minimum CV error
lambda_bank_1se <- cv_fit_bank$lambda.1se # Lambda within 1 std error of minimum
lambda_acq_min <- cv_fit_acq$lambda.min
lambda_acq_1se <- cv_fit_acq$lambda.1se
cat("\nOptimal lambda values for bankruptcy model:\n")
Optimal lambda values for bankruptcy model:
cat("- lambda.min (minimum error):", lambda_bank_min, "\n")
- lambda.min (minimum error): 0.002012214
cat("- lambda.1se (1 std error rule):", lambda_bank_1se, "\n")
- lambda.1se (1 std error rule): 0.007401688
cat("\nOptimal lambda values for acquisition model:\n")
Optimal lambda values for acquisition model:
cat("- lambda.min (minimum error):", lambda_acq_min, "\n")
- lambda.min (minimum error): 0.002494769
cat("- lambda.1se (1 std error rule):", lambda_acq_1se, "\n")
- lambda.1se (1 std error rule): 0.01213107
# Get coefficients for the LASSO models at the optimal lambda
coef_bank_min <- coef(cv_fit_bank, s = "lambda.min")
coef_bank_1se <- coef(cv_fit_bank, s = "lambda.1se")
coef_acq_min <- coef(cv_fit_acq, s = "lambda.min")
coef_acq_1se <- coef(cv_fit_acq, s = "lambda.1se")
# Extract variable names selected by LASSO (we'll use lambda.1se for parsimony)
bankruptcy_vars_lasso <- rownames(coef_bank_1se)[which(coef_bank_1se != 0)]
acquisition_vars_lasso <- rownames(coef_acq_1se)[which(coef_acq_1se != 0)]
cat("\nSelected variables for bankruptcy model (LASSO):\n")
Selected variables for bankruptcy model (LASSO):
print(bankruptcy_vars_lasso)
[1] "LTMTA" "NIMTA" "PRICE" "gdp_deflator" "gdp_growth"
cat("\nSelected variables for acquisition model (LASSO):\n")
Selected variables for acquisition model (LASSO):
print(acquisition_vars_lasso)
[1] "LTMTA" "NIMTA" "PRICE" "MBE" "debt_ratio"
[6] "current_ratio" "cash_to_assets" "wc_ratio" "gp_margin" "asset_turnover"
[11] "receivables_turnover" "EBIT_VOL_3Y" "gdp_deflator" "unemployement" "gdp_growth"
# Identify financial and macro variables selected by LASSO
bankruptcy_fin_lasso <- bankruptcy_vars_lasso[bankruptcy_vars_lasso %in% financial_covariates]
bankruptcy_macro_lasso <- bankruptcy_vars_lasso[bankruptcy_vars_lasso %in% macro_covariates]
acquisition_fin_lasso <- acquisition_vars_lasso[acquisition_vars_lasso %in% financial_covariates]
acquisition_macro_lasso <- acquisition_vars_lasso[acquisition_vars_lasso %in% macro_covariates]
cat("\nBreakdown of LASSO selection for bankruptcy model:\n")
Breakdown of LASSO selection for bankruptcy model:
cat("- Financial variables:", length(bankruptcy_fin_lasso), "of", length(financial_covariates), "\n")
- Financial variables: 3 of 17
cat("- Macro variables:", length(bankruptcy_macro_lasso), "of", length(macro_covariates), "\n")
- Macro variables: 2 of 3
cat("\nBreakdown of LASSO selection for acquisition model:\n")
Breakdown of LASSO selection for acquisition model:
cat("- Financial variables:", length(acquisition_fin_lasso), "of", length(financial_covariates), "\n")
- Financial variables: 12 of 17
cat("- Macro variables:", length(acquisition_macro_lasso), "of", length(macro_covariates), "\n")
- Macro variables: 3 of 3
Now, we compare the variables selected by both methods (stepwise and LASSO) and finalize the variable selection for both bankruptcy and acquisition models. We also create formulas for the final models.
#-------------------------------------------------------------
# 7.5: Compare and Finalize Variable Selection
#-------------------------------------------------------------
cat("\n7.5: Comparing and Finalizing Variable Selection\n")
7.5: Comparing and Finalizing Variable Selection
# Compare variables selected by both methods
cat("\nComparison of selected variables for bankruptcy model:\n")
Comparison of selected variables for bankruptcy model:
compare_bank <- data.frame(
Variable = unique(c(bankruptcy_vars_step, bankruptcy_vars_lasso)),
Type = ifelse(unique(c(bankruptcy_vars_step, bankruptcy_vars_lasso)) %in% financial_covariates,
"Financial", "Macro"),
Stepwise = unique(c(bankruptcy_vars_step, bankruptcy_vars_lasso)) %in% bankruptcy_vars_step,
LASSO = unique(c(bankruptcy_vars_step, bankruptcy_vars_lasso)) %in% bankruptcy_vars_lasso
)
print(compare_bank)
cat("\nComparison of selected variables for acquisition model:\n")
Comparison of selected variables for acquisition model:
compare_acq <- data.frame(
Variable = unique(c(acquisition_vars_step, acquisition_vars_lasso)),
Type = ifelse(unique(c(acquisition_vars_step, acquisition_vars_lasso)) %in% financial_covariates,
"Financial", "Macro"),
Stepwise = unique(c(acquisition_vars_step, acquisition_vars_lasso)) %in% acquisition_vars_step,
LASSO = unique(c(acquisition_vars_step, acquisition_vars_lasso)) %in% acquisition_vars_lasso
)
print(compare_acq)
# Decide on final variable sets
# For bankruptcy model: use all variables selected by both methods, plus important ones from either method
bankruptcy_vars <- unique(c(
# Variables selected by both methods
intersect(bankruptcy_vars_step, bankruptcy_vars_lasso),
# Add macro variables that are significant in univariate analysis
significant_bk_macro,
# Add z-score if available (known to be important for bankruptcy prediction)
if("z_score" %in% financial_covariates) "z_score" else NULL
))
# For acquisition model: use all variables selected by both methods, plus important ones from either method
acquisition_vars <- unique(c(
# Variables selected by both methods
intersect(acquisition_vars_step, acquisition_vars_lasso),
# Add macro variables that are significant in univariate analysis
significant_acq_macro,
# Add key financial variables if available
if("LTMTA" %in% financial_covariates) "LTMTA" else NULL,
if("NIMTA" %in% financial_covariates) "NIMTA" else NULL
))
# Print final variable selections
cat("\nFinal selected variables for bankruptcy model:", length(bankruptcy_vars), "variables\n")
Final selected variables for bankruptcy model: 7 variables
bankruptcy_fin_final <- bankruptcy_vars[bankruptcy_vars %in% financial_covariates]
bankruptcy_macro_final <- bankruptcy_vars[bankruptcy_vars %in% macro_covariates]
cat("- Financial variables (", length(bankruptcy_fin_final), "):",
paste(bankruptcy_fin_final, collapse=", "), "\n")
- Financial variables ( 4 ): LTMTA, NIMTA, PRICE, z_score
cat("- Macro variables (", length(bankruptcy_macro_final), "):",
paste(bankruptcy_macro_final, collapse=", "), "\n")
- Macro variables ( 3 ): gdp_deflator, gdp_growth, unemployement
cat("\nFinal selected variables for acquisition model:", length(acquisition_vars), "variables\n")
Final selected variables for acquisition model: 15 variables
acquisition_fin_final <- acquisition_vars[acquisition_vars %in% financial_covariates]
acquisition_macro_final <- acquisition_vars[acquisition_vars %in% macro_covariates]
cat("- Financial variables (", length(acquisition_fin_final), "):",
paste(acquisition_fin_final, collapse=", "), "\n")
- Financial variables ( 12 ): LTMTA, NIMTA, PRICE, MBE, debt_ratio, current_ratio, cash_to_assets, wc_ratio, gp_margin, asset_turnover, receivables_turnover, EBIT_VOL_3Y
cat("- Macro variables (", length(acquisition_macro_final), "):",
paste(acquisition_macro_final, collapse=", "), "\n")
- Macro variables ( 3 ): gdp_deflator, unemployement, gdp_growth
# Save selection results for later steps
selection_results <- list(
bankruptcy = list(
stepwise = bankruptcy_vars_step,
lasso = bankruptcy_vars_lasso,
final = bankruptcy_vars,
financial = bankruptcy_fin_final,
macro = bankruptcy_macro_final
),
acquisition = list(
stepwise = acquisition_vars_step,
lasso = acquisition_vars_lasso,
final = acquisition_vars,
financial = acquisition_fin_final,
macro = acquisition_macro_final
)
)
# Create formulas for the final models
bankruptcy_formula <- as.formula(paste0(
"Surv(tstart, tstop, bankruptcy) ~ ",
paste(bankruptcy_vars, collapse = " + "),
" + strata(gsector)"
))
acquisition_formula <- as.formula(paste0(
"Surv(tstart, tstop, acquisition) ~ ",
paste(acquisition_vars, collapse = " + "),
" + strata(gsector)"
))
cat("\nFinal bankruptcy model formula:\n")
Final bankruptcy model formula:
print(bankruptcy_formula)
Surv(tstart, tstop, bankruptcy) ~ LTMTA + NIMTA + PRICE + gdp_deflator +
gdp_growth + unemployement + z_score + strata(gsector)
cat("\nFinal acquisition model formula:\n")
Final acquisition model formula:
print(acquisition_formula)
Surv(tstart, tstop, acquisition) ~ LTMTA + NIMTA + PRICE + MBE +
debt_ratio + current_ratio + cash_to_assets + wc_ratio +
gp_margin + asset_turnover + receivables_turnover + EBIT_VOL_3Y +
gdp_deflator + unemployement + gdp_growth + strata(gsector)
# Save formulas for later steps
selection_results$bankruptcy$formula <- bankruptcy_formula
selection_results$acquisition$formula <- acquisition_formula
Finally, we fit the cause-specific Cox models using the selected variables from both stepwise and LASSO methods. We also create a financial-only model and a macro-enriched model for comparison. We evaluate the improvement of the models using likelihood ratio tests and compare their concordance (C-index).
#-------------------------------------------------------------
# STEP 8: Fit Cause-Specific Cox Models with Selected Variables
#-------------------------------------------------------------
cat("\n=== STEP 8: FITTING CAUSE-SPECIFIC COX MODELS WITH FINANCIAL AND MACRO VARIABLES ===\n")
=== STEP 8: FITTING CAUSE-SPECIFIC COX MODELS WITH FINANCIAL AND MACRO VARIABLES ===
#-------------------------------------------------------------
# 8.1: BANKRUPTCY MODELS
#-------------------------------------------------------------
cat("\n8.1: BANKRUPTCY PREDICTION MODELS\n")
8.1: BANKRUPTCY PREDICTION MODELS
cat("--------------------------------------\n")
--------------------------------------
# Create formulas with different sets of selected variables
# 1. Stepwise AIC selection variables
bankruptcy_step_formula <- as.formula(paste0(
"Surv(tstart, tstop, bankruptcy) ~ ",
paste(bankruptcy_vars_step, collapse = " + "),
" + strata(gsector)"
))
# 2. LASSO selection variables
bankruptcy_lasso_formula <- as.formula(paste0(
"Surv(tstart, tstop, bankruptcy) ~ ",
paste(bankruptcy_vars_lasso, collapse = " + "),
" + strata(gsector)"
))
# 3. Union of both methods (comprehensive approach)
bankruptcy_union_vars <- unique(c(bankruptcy_vars_step, bankruptcy_vars_lasso))
bankruptcy_union_formula <- as.formula(paste0(
"Surv(tstart, tstop, bankruptcy) ~ ",
paste(bankruptcy_union_vars, collapse = " + "),
" + strata(gsector)"
))
# 4. Intersection of both methods (conservative approach)
bankruptcy_intersect_vars <- intersect(bankruptcy_vars_step, bankruptcy_vars_lasso)
# Check if intersection is not empty
if(length(bankruptcy_intersect_vars) > 0) {
bankruptcy_intersect_formula <- as.formula(paste0(
"Surv(tstart, tstop, bankruptcy) ~ ",
paste(bankruptcy_intersect_vars, collapse = " + "),
" + strata(gsector)"
))
} else {
# If intersection is empty, use Z-score and significant macro vars as fallback
cat("No variables in common between stepwise and LASSO for bankruptcy. Using Z-score and significant macro variables as fallback.\n")
fallback_vars <- c("z_score", significant_bk_macro)
bankruptcy_intersect_formula <- as.formula(paste0(
"Surv(tstart, tstop, bankruptcy) ~ ",
paste(fallback_vars, collapse = " + "),
" + strata(gsector)"
))
bankruptcy_intersect_vars <- fallback_vars
}
# 5. Financial-only model (for comparison)
bankruptcy_fin_only_vars <- bankruptcy_vars_step[bankruptcy_vars_step %in% financial_covariates]
bankruptcy_fin_only_formula <- as.formula(paste0(
"Surv(tstart, tstop, bankruptcy) ~ ",
paste(bankruptcy_fin_only_vars, collapse = " + "),
" + strata(gsector)"
))
# 6. Macro-enriched model (financial variables + all significant macro)
bankruptcy_macro_enriched_vars <- unique(c(
bankruptcy_fin_only_vars, # Financial variables from stepwise
significant_bk_macro # All significant macro variables
))
bankruptcy_macro_enriched_formula <- as.formula(paste0(
"Surv(tstart, tstop, bankruptcy) ~ ",
paste(bankruptcy_macro_enriched_vars, collapse = " + "),
" + strata(gsector)"
))
# Fit the models with Efron approximation for ties
cat("Fitting bankruptcy models with different variable sets...\n")
Fitting bankruptcy models with different variable sets...
# 1. Stepwise AIC model
bankruptcy_step_model <- coxph(bankruptcy_step_formula, data = data, ties = "efron")
cat("\n=== BANKRUPTCY MODEL: STEPWISE AIC SELECTION ===\n")
=== BANKRUPTCY MODEL: STEPWISE AIC SELECTION ===
print(summary(bankruptcy_step_model))
Call:
coxph(formula = bankruptcy_step_formula, data = data, ties = "efron")
n= 63591, number of events= 176
coef exp(coef) se(coef) z Pr(>|z|)
LTMTA 4.093442 59.945877 0.516174 7.930 2.19e-15 ***
NIMTA -2.003071 0.134920 0.403230 -4.968 6.78e-07 ***
CASHMTA -2.129608 0.118884 0.942710 -2.259 0.02388 *
PRICE -0.311717 0.732188 0.061214 -5.092 3.54e-07 ***
MBE -0.141240 0.868281 0.081028 -1.743 0.08132 .
debt_ratio -0.195661 0.822291 0.287488 -0.681 0.49613
debt_service 0.001114 1.001115 0.022548 0.049 0.96058
current_ratio 0.085782 1.089569 0.040591 2.113 0.03457 *
cash_to_assets 1.500593 4.484347 0.899430 1.668 0.09524 .
wc_ratio -1.015035 0.362390 0.317245 -3.200 0.00138 **
gp_margin 0.066733 1.069009 0.047396 1.408 0.15914
asset_turnover -0.164702 0.848147 0.094855 -1.736 0.08250 .
receivables_turnover 0.001338 1.001339 0.001769 0.756 0.44947
intangibility -0.285753 0.751448 0.213919 -1.336 0.18161
ebit_growth -0.011717 0.988352 0.025372 -0.462 0.64423
EBIT_VOL_3Y -0.000883 0.999117 0.012927 -0.068 0.94554
z_score 0.029200 1.029630 0.012606 2.316 0.02054 *
gdp_deflator -0.172516 0.841545 0.087396 -1.974 0.04839 *
unemployement -0.079620 0.923467 0.067868 -1.173 0.24074
gdp_growth 0.099036 1.104107 0.056387 1.756 0.07902 .
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
LTMTA 59.9459 0.01668 21.79674 164.8645
NIMTA 0.1349 7.41178 0.06121 0.2974
CASHMTA 0.1189 8.41157 0.01874 0.7543
PRICE 0.7322 1.36577 0.64941 0.8255
MBE 0.8683 1.15170 0.74078 1.0177
debt_ratio 0.8223 1.21611 0.46807 1.4446
debt_service 1.0011 0.99889 0.95784 1.0464
current_ratio 1.0896 0.91779 1.00624 1.1798
cash_to_assets 4.4843 0.22300 0.76931 26.1394
wc_ratio 0.3624 2.75946 0.19460 0.6749
gp_margin 1.0690 0.93545 0.97418 1.1731
asset_turnover 0.8481 1.17904 0.70426 1.0214
receivables_turnover 1.0013 0.99866 0.99787 1.0048
intangibility 0.7514 1.33076 0.49410 1.1428
ebit_growth 0.9884 1.01179 0.94040 1.0387
EBIT_VOL_3Y 0.9991 1.00088 0.97412 1.0248
z_score 1.0296 0.97122 1.00450 1.0554
gdp_deflator 0.8415 1.18829 0.70906 0.9988
unemployement 0.9235 1.08288 0.80845 1.0549
gdp_growth 1.1041 0.90571 0.98859 1.2331
Concordance= 0.864 (se = 0.019 )
Likelihood ratio test= 436.5 on 20 df, p=<2e-16
Wald test = 394.9 on 20 df, p=<2e-16
Score (logrank) test = 601.1 on 20 df, p=<2e-16
# 2. LASSO model
bankruptcy_lasso_model <- coxph(bankruptcy_lasso_formula, data = data, ties = "efron")
cat("\n=== BANKRUPTCY MODEL: LASSO SELECTION ===\n")
=== BANKRUPTCY MODEL: LASSO SELECTION ===
print(summary(bankruptcy_lasso_model))
Call:
coxph(formula = bankruptcy_lasso_formula, data = data, ties = "efron")
n= 63591, number of events= 176
coef exp(coef) se(coef) z Pr(>|z|)
LTMTA 4.07326 58.74817 0.37487 10.866 < 2e-16 ***
NIMTA -1.46424 0.23125 0.34806 -4.207 2.59e-05 ***
PRICE -0.30726 0.73546 0.05707 -5.384 7.29e-08 ***
gdp_deflator -0.15006 0.86066 0.08407 -1.785 0.0743 .
gdp_growth 0.12371 1.13168 0.04977 2.486 0.0129 *
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
LTMTA 58.7482 0.01702 28.1775 122.4860
NIMTA 0.2313 4.32426 0.1169 0.4575
PRICE 0.7355 1.35970 0.6576 0.8225
gdp_deflator 0.8607 1.16190 0.7299 1.0148
gdp_growth 1.1317 0.88364 1.0265 1.2476
Concordance= 0.845 (se = 0.021 )
Likelihood ratio test= 393.6 on 5 df, p=<2e-16
Wald test = 345.3 on 5 df, p=<2e-16
Score (logrank) test = 497.7 on 5 df, p=<2e-16
# 3. Union model
bankruptcy_union_model <- coxph(bankruptcy_union_formula, data = data, ties = "efron")
cat("\n=== BANKRUPTCY MODEL: UNION OF STEPWISE & LASSO ===\n")
=== BANKRUPTCY MODEL: UNION OF STEPWISE & LASSO ===
print(summary(bankruptcy_union_model))
Call:
coxph(formula = bankruptcy_union_formula, data = data, ties = "efron")
n= 63591, number of events= 176
coef exp(coef) se(coef) z Pr(>|z|)
LTMTA 4.093442 59.945877 0.516174 7.930 2.19e-15 ***
NIMTA -2.003071 0.134920 0.403230 -4.968 6.78e-07 ***
CASHMTA -2.129608 0.118884 0.942710 -2.259 0.02388 *
PRICE -0.311717 0.732188 0.061214 -5.092 3.54e-07 ***
MBE -0.141240 0.868281 0.081028 -1.743 0.08132 .
debt_ratio -0.195661 0.822291 0.287488 -0.681 0.49613
debt_service 0.001114 1.001115 0.022548 0.049 0.96058
current_ratio 0.085782 1.089569 0.040591 2.113 0.03457 *
cash_to_assets 1.500593 4.484347 0.899430 1.668 0.09524 .
wc_ratio -1.015035 0.362390 0.317245 -3.200 0.00138 **
gp_margin 0.066733 1.069009 0.047396 1.408 0.15914
asset_turnover -0.164702 0.848147 0.094855 -1.736 0.08250 .
receivables_turnover 0.001338 1.001339 0.001769 0.756 0.44947
intangibility -0.285753 0.751448 0.213919 -1.336 0.18161
ebit_growth -0.011717 0.988352 0.025372 -0.462 0.64423
EBIT_VOL_3Y -0.000883 0.999117 0.012927 -0.068 0.94554
z_score 0.029200 1.029630 0.012606 2.316 0.02054 *
gdp_deflator -0.172516 0.841545 0.087396 -1.974 0.04839 *
unemployement -0.079620 0.923467 0.067868 -1.173 0.24074
gdp_growth 0.099036 1.104107 0.056387 1.756 0.07902 .
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
LTMTA 59.9459 0.01668 21.79674 164.8645
NIMTA 0.1349 7.41178 0.06121 0.2974
CASHMTA 0.1189 8.41157 0.01874 0.7543
PRICE 0.7322 1.36577 0.64941 0.8255
MBE 0.8683 1.15170 0.74078 1.0177
debt_ratio 0.8223 1.21611 0.46807 1.4446
debt_service 1.0011 0.99889 0.95784 1.0464
current_ratio 1.0896 0.91779 1.00624 1.1798
cash_to_assets 4.4843 0.22300 0.76931 26.1394
wc_ratio 0.3624 2.75946 0.19460 0.6749
gp_margin 1.0690 0.93545 0.97418 1.1731
asset_turnover 0.8481 1.17904 0.70426 1.0214
receivables_turnover 1.0013 0.99866 0.99787 1.0048
intangibility 0.7514 1.33076 0.49410 1.1428
ebit_growth 0.9884 1.01179 0.94040 1.0387
EBIT_VOL_3Y 0.9991 1.00088 0.97412 1.0248
z_score 1.0296 0.97122 1.00450 1.0554
gdp_deflator 0.8415 1.18829 0.70906 0.9988
unemployement 0.9235 1.08288 0.80845 1.0549
gdp_growth 1.1041 0.90571 0.98859 1.2331
Concordance= 0.864 (se = 0.019 )
Likelihood ratio test= 436.5 on 20 df, p=<2e-16
Wald test = 394.9 on 20 df, p=<2e-16
Score (logrank) test = 601.1 on 20 df, p=<2e-16
# 4. Intersection model
bankruptcy_intersect_model <- coxph(bankruptcy_intersect_formula, data = data, ties = "efron")
cat("\n=== BANKRUPTCY MODEL: INTERSECTION OF STEPWISE & LASSO ===\n")
=== BANKRUPTCY MODEL: INTERSECTION OF STEPWISE & LASSO ===
print(summary(bankruptcy_intersect_model))
Call:
coxph(formula = bankruptcy_intersect_formula, data = data, ties = "efron")
n= 63591, number of events= 176
coef exp(coef) se(coef) z Pr(>|z|)
LTMTA 4.07326 58.74817 0.37487 10.866 < 2e-16 ***
NIMTA -1.46424 0.23125 0.34806 -4.207 2.59e-05 ***
PRICE -0.30726 0.73546 0.05707 -5.384 7.29e-08 ***
gdp_deflator -0.15006 0.86066 0.08407 -1.785 0.0743 .
gdp_growth 0.12371 1.13168 0.04977 2.486 0.0129 *
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
LTMTA 58.7482 0.01702 28.1775 122.4860
NIMTA 0.2313 4.32426 0.1169 0.4575
PRICE 0.7355 1.35970 0.6576 0.8225
gdp_deflator 0.8607 1.16190 0.7299 1.0148
gdp_growth 1.1317 0.88364 1.0265 1.2476
Concordance= 0.845 (se = 0.021 )
Likelihood ratio test= 393.6 on 5 df, p=<2e-16
Wald test = 345.3 on 5 df, p=<2e-16
Score (logrank) test = 497.7 on 5 df, p=<2e-16
# 5. Financial-only model
bankruptcy_fin_only_model <- coxph(bankruptcy_fin_only_formula, data = data, ties = "efron")
cat("\n=== BANKRUPTCY MODEL: FINANCIAL VARIABLES ONLY ===\n")
=== BANKRUPTCY MODEL: FINANCIAL VARIABLES ONLY ===
print(summary(bankruptcy_fin_only_model))
Call:
coxph(formula = bankruptcy_fin_only_formula, data = data, ties = "efron")
n= 63591, number of events= 176
coef exp(coef) se(coef) z Pr(>|z|)
LTMTA 4.1249753 61.8662806 0.5127014 8.046 8.58e-16 ***
NIMTA -1.9951107 0.1359986 0.3982891 -5.009 5.47e-07 ***
CASHMTA -2.2523872 0.1051479 0.9458578 -2.381 0.01725 *
PRICE -0.3132494 0.7310676 0.0606465 -5.165 2.40e-07 ***
MBE -0.1433073 0.8664878 0.0815467 -1.757 0.07886 .
debt_ratio -0.2255837 0.7980503 0.2858620 -0.789 0.43003
debt_service -0.0027800 0.9972239 0.0225030 -0.124 0.90168
current_ratio 0.0903012 1.0945039 0.0405041 2.229 0.02579 *
cash_to_assets 1.4364328 4.2056666 0.9027987 1.591 0.11159
wc_ratio -1.0024948 0.3669628 0.3172596 -3.160 0.00158 **
gp_margin 0.0619964 1.0639586 0.0455214 1.362 0.17322
asset_turnover -0.1504044 0.8603600 0.0941583 -1.597 0.11019
receivables_turnover 0.0014753 1.0014764 0.0017743 0.831 0.40570
intangibility -0.2975916 0.7426045 0.2153915 -1.382 0.16708
ebit_growth -0.0112921 0.9887714 0.0254235 -0.444 0.65693
EBIT_VOL_3Y -0.0005538 0.9994464 0.0128319 -0.043 0.96558
z_score 0.0290187 1.0294438 0.0126951 2.286 0.02226 *
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
LTMTA 61.8663 0.01616 22.64862 168.9920
NIMTA 0.1360 7.35302 0.06230 0.2969
CASHMTA 0.1051 9.51041 0.01647 0.6713
PRICE 0.7311 1.36786 0.64914 0.8233
MBE 0.8665 1.15408 0.73850 1.0167
debt_ratio 0.7981 1.25305 0.45573 1.3975
debt_service 0.9972 1.00278 0.95420 1.0422
current_ratio 1.0945 0.91366 1.01097 1.1849
cash_to_assets 4.2057 0.23777 0.71676 24.6773
wc_ratio 0.3670 2.72507 0.19705 0.6834
gp_margin 1.0640 0.93989 0.97314 1.1632
asset_turnover 0.8604 1.16230 0.71537 1.0347
receivables_turnover 1.0015 0.99853 0.99800 1.0050
intangibility 0.7426 1.34661 0.48687 1.1327
ebit_growth 0.9888 1.01136 0.94071 1.0393
EBIT_VOL_3Y 0.9994 1.00055 0.97462 1.0249
z_score 1.0294 0.97140 1.00415 1.0554
Concordance= 0.852 (se = 0.022 )
Likelihood ratio test= 426.8 on 17 df, p=<2e-16
Wald test = 387.1 on 17 df, p=<2e-16
Score (logrank) test = 591.1 on 17 df, p=<2e-16
# 6. Macro-enriched model
bankruptcy_macro_enriched_model <- coxph(bankruptcy_macro_enriched_formula, data = data, ties = "efron")
cat("\n=== BANKRUPTCY MODEL: FINANCIAL + SIGNIFICANT MACRO VARIABLES ===\n")
=== BANKRUPTCY MODEL: FINANCIAL + SIGNIFICANT MACRO VARIABLES ===
print(summary(bankruptcy_macro_enriched_model))
Call:
coxph(formula = bankruptcy_macro_enriched_formula, data = data,
ties = "efron")
n= 63591, number of events= 176
coef exp(coef) se(coef) z Pr(>|z|)
LTMTA 4.0601837 57.9849601 0.5143528 7.894 2.93e-15 ***
NIMTA -1.9442430 0.1430955 0.4016454 -4.841 1.29e-06 ***
CASHMTA -2.1775400 0.1133200 0.9436560 -2.308 0.02102 *
PRICE -0.3149111 0.7298538 0.0609534 -5.166 2.39e-07 ***
MBE -0.1409420 0.8685397 0.0809882 -1.740 0.08181 .
debt_ratio -0.2136789 0.8076077 0.2861020 -0.747 0.45515
debt_service -0.0017857 0.9982159 0.0224728 -0.079 0.93667
current_ratio 0.0878925 1.0918707 0.0405019 2.170 0.03000 *
cash_to_assets 1.4301764 4.1794363 0.9005720 1.588 0.11227
wc_ratio -0.9951618 0.3696636 0.3174898 -3.134 0.00172 **
gp_margin 0.0629773 1.0650027 0.0455182 1.384 0.16649
asset_turnover -0.1551107 0.8563203 0.0946421 -1.639 0.10123
receivables_turnover 0.0014722 1.0014733 0.0017740 0.830 0.40659
intangibility -0.2932034 0.7458704 0.2152748 -1.362 0.17320
ebit_growth -0.0125071 0.9875708 0.0254905 -0.491 0.62367
EBIT_VOL_3Y -0.0007252 0.9992751 0.0128396 -0.056 0.95496
z_score 0.0289999 1.0294245 0.0126810 2.287 0.02220 *
unemployement -0.0898435 0.9140743 0.0569984 -1.576 0.11497
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
LTMTA 57.9850 0.01725 21.15911 158.9034
NIMTA 0.1431 6.98834 0.06512 0.3144
CASHMTA 0.1133 8.82457 0.01783 0.7204
PRICE 0.7299 1.37014 0.64767 0.8225
MBE 0.8685 1.15136 0.74106 1.0180
debt_ratio 0.8076 1.23823 0.46097 1.4149
debt_service 0.9982 1.00179 0.95520 1.0432
current_ratio 1.0919 0.91586 1.00855 1.1821
cash_to_assets 4.1794 0.23927 0.71540 24.4166
wc_ratio 0.3697 2.70516 0.19841 0.6887
gp_margin 1.0650 0.93896 0.97410 1.1644
asset_turnover 0.8563 1.16779 0.71134 1.0309
receivables_turnover 1.0015 0.99853 0.99800 1.0050
intangibility 0.7459 1.34072 0.48913 1.1374
ebit_growth 0.9876 1.01259 0.93944 1.0382
EBIT_VOL_3Y 0.9993 1.00073 0.97444 1.0247
z_score 1.0294 0.97142 1.00415 1.0553
unemployement 0.9141 1.09400 0.81746 1.0221
Concordance= 0.855 (se = 0.021 )
Likelihood ratio test= 429.4 on 18 df, p=<2e-16
Wald test = 390.6 on 18 df, p=<2e-16
Score (logrank) test = 594.6 on 18 df, p=<2e-16
# Compare models
cat("\nComparison of Bankruptcy Models:\n")
Comparison of Bankruptcy Models:
cat("--------------------------------------\n")
--------------------------------------
bankruptcy_models <- list(
Stepwise = bankruptcy_step_model,
LASSO = bankruptcy_lasso_model,
Union = bankruptcy_union_model,
Intersection = bankruptcy_intersect_model,
Financial_Only = bankruptcy_fin_only_model,
Macro_Enriched = bankruptcy_macro_enriched_model
)
bankruptcy_comparison <- data.frame(
Model = names(bankruptcy_models),
Fin_Vars = c(
sum(bankruptcy_vars_step %in% financial_covariates),
sum(bankruptcy_vars_lasso %in% financial_covariates),
sum(bankruptcy_union_vars %in% financial_covariates),
sum(bankruptcy_intersect_vars %in% financial_covariates),
length(bankruptcy_fin_only_vars),
sum(bankruptcy_macro_enriched_vars %in% financial_covariates)
),
Macro_Vars = c(
sum(bankruptcy_vars_step %in% macro_covariates),
sum(bankruptcy_vars_lasso %in% macro_covariates),
sum(bankruptcy_union_vars %in% macro_covariates),
sum(bankruptcy_intersect_vars %in% macro_covariates),
0,
sum(bankruptcy_macro_enriched_vars %in% macro_covariates)
),
Total_Vars = c(
length(bankruptcy_vars_step),
length(bankruptcy_vars_lasso),
length(bankruptcy_union_vars),
length(bankruptcy_intersect_vars),
length(bankruptcy_fin_only_vars),
length(bankruptcy_macro_enriched_vars)
),
AIC = sapply(bankruptcy_models, AIC),
BIC = sapply(bankruptcy_models, BIC),
Concordance = sapply(bankruptcy_models, function(m) round(m$concordance["concordance"], 3)),
LogLik = sapply(bankruptcy_models, function(m) round(m$loglik[2], 2))
)
print(bankruptcy_comparison)
# Identify best bankruptcy model based on AIC
best_bankruptcy_model_idx <- which.min(bankruptcy_comparison$AIC)
best_bankruptcy_model_name <- bankruptcy_comparison$Model[best_bankruptcy_model_idx]
best_bankruptcy_model <- bankruptcy_models[[best_bankruptcy_model_name]]
cat("\nBest bankruptcy model based on AIC:", best_bankruptcy_model_name, "\n")
Best bankruptcy model based on AIC: Stepwise
# Calculate improvement over financial-only model
if(best_bankruptcy_model_name != "Financial_Only") {
# Likelihood ratio test
lrt <- anova(bankruptcy_fin_only_model, best_bankruptcy_model)
cat("\nLikelihood ratio test comparing best model to financial-only model:\n")
print(lrt)
# Concordance improvement
conc_improvement <- best_bankruptcy_model$concordance["concordance"] -
bankruptcy_fin_only_model$concordance["concordance"]
cat("\nConcordance improvement over financial-only model:", round(conc_improvement, 4), "\n")
}
Likelihood ratio test comparing best model to financial-only model:
Analysis of Deviance Table
Cox model: response is Surv(tstart, tstop, bankruptcy)
Model 1: ~ LTMTA + NIMTA + CASHMTA + PRICE + MBE + debt_ratio + debt_service + current_ratio + cash_to_assets + wc_ratio + gp_margin + asset_turnover + receivables_turnover + intangibility + ebit_growth + EBIT_VOL_3Y + z_score + strata(gsector)
Model 2: ~ LTMTA + NIMTA + CASHMTA + PRICE + MBE + debt_ratio + debt_service + current_ratio + cash_to_assets + wc_ratio + gp_margin + asset_turnover + receivables_turnover + intangibility + ebit_growth + EBIT_VOL_3Y + z_score + gdp_deflator + unemployement + gdp_growth + strata(gsector)
loglik Chisq Df Pr(>|Chi|)
1 -783.06
2 -778.20 9.7047 3 0.02125 *
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
Concordance improvement over financial-only model: 0.0117
cat("This model will be used for subsequent analysis.\n")
This model will be used for subsequent analysis.
Same as above, we fit the acquisition models using the selected variables from both stepwise and LASSO methods. We also create a financial-only model and a macro-enriched model for comparison. We evaluate the improvement of the models using likelihood ratio tests and compare their concordance (C-index).
#-------------------------------------------------------------
# 8.2: ACQUISITION MODELS
#-------------------------------------------------------------
cat("\n8.2: ACQUISITION PREDICTION MODELS\n")
8.2: ACQUISITION PREDICTION MODELS
cat("--------------------------------------\n")
--------------------------------------
# Create formulas with different sets of selected variables
# 1. Stepwise AIC selection variables
acquisition_step_formula <- as.formula(paste0(
"Surv(tstart, tstop, acquisition) ~ ",
paste(acquisition_vars_step, collapse = " + "),
" + strata(gsector)"
))
# 2. LASSO selection variables
acquisition_lasso_formula <- as.formula(paste0(
"Surv(tstart, tstop, acquisition) ~ ",
paste(acquisition_vars_lasso, collapse = " + "),
" + strata(gsector)"
))
# 3. Union of both methods (comprehensive approach)
acquisition_union_vars <- unique(c(acquisition_vars_step, acquisition_vars_lasso))
acquisition_union_formula <- as.formula(paste0(
"Surv(tstart, tstop, acquisition) ~ ",
paste(acquisition_union_vars, collapse = " + "),
" + strata(gsector)"
))
# 4. Intersection of both methods (conservative approach)
acquisition_intersect_vars <- intersect(acquisition_vars_step, acquisition_vars_lasso)
# Check if intersection is not empty
if(length(acquisition_intersect_vars) > 0) {
acquisition_intersect_formula <- as.formula(paste0(
"Surv(tstart, tstop, acquisition) ~ ",
paste(acquisition_intersect_vars, collapse = " + "),
" + strata(gsector)"
))
} else {
# If intersection is empty, use key financial and significant macro vars as fallback
cat("No variables in common between stepwise and LASSO for acquisition. Using key financial and significant macro variables as fallback.\n")
key_fin_vars <- intersect(c("RSIZE", "LTMTA", "NIMTA"), financial_covariates)
fallback_vars <- c(key_fin_vars, significant_acq_macro)
acquisition_intersect_formula <- as.formula(paste0(
"Surv(tstart, tstop, acquisition) ~ ",
paste(fallback_vars, collapse = " + "),
" + strata(gsector)"
))
acquisition_intersect_vars <- fallback_vars
}
# 5. Financial-only model (for comparison)
acquisition_fin_only_vars <- acquisition_vars_step[acquisition_vars_step %in% financial_covariates]
acquisition_fin_only_formula <- as.formula(paste0(
"Surv(tstart, tstop, acquisition) ~ ",
paste(acquisition_fin_only_vars, collapse = " + "),
" + strata(gsector)"
))
# 6. Macro-enriched model (financial variables + all significant macro)
acquisition_macro_enriched_vars <- unique(c(
acquisition_fin_only_vars, # Financial variables from stepwise
significant_acq_macro # All significant macro variables
))
acquisition_macro_enriched_formula <- as.formula(paste0(
"Surv(tstart, tstop, acquisition) ~ ",
paste(acquisition_macro_enriched_vars, collapse = " + "),
" + strata(gsector)"
))
# Fit the models with Efron approximation for ties
cat("Fitting acquisition models with different variable sets...\n")
Fitting acquisition models with different variable sets...
# 1. Stepwise AIC model
acquisition_step_model <- coxph(acquisition_step_formula, data = data, ties = "efron")
cat("\n=== ACQUISITION MODEL: STEPWISE AIC SELECTION ===\n")
=== ACQUISITION MODEL: STEPWISE AIC SELECTION ===
print(summary(acquisition_step_model))
Call:
coxph(formula = acquisition_step_formula, data = data, ties = "efron")
n= 63591, number of events= 2154
coef exp(coef) se(coef) z Pr(>|z|)
LTMTA -0.0692224 0.9331191 0.1873853 -0.369 0.71182
NIMTA 0.0521912 1.0535772 0.2035668 0.256 0.79765
CASHMTA -0.0246983 0.9756042 0.2677814 -0.092 0.92651
PRICE 0.1292039 1.1379221 0.0203765 6.341 2.29e-10 ***
MBE -0.2475084 0.7807436 0.0293828 -8.424 < 2e-16 ***
debt_ratio 0.0648998 1.0670521 0.1420247 0.457 0.64770
debt_service -0.0084962 0.9915398 0.0107977 -0.787 0.43137
current_ratio -0.0801206 0.9230050 0.0161442 -4.963 6.95e-07 ***
cash_to_assets 0.7240280 2.0627252 0.2260495 3.203 0.00136 **
wc_ratio -0.2478513 0.7804760 0.1588320 -1.560 0.11865
gp_margin 0.0250246 1.0253404 0.0090720 2.758 0.00581 **
asset_turnover -0.0591702 0.9425463 0.0339169 -1.745 0.08106 .
receivables_turnover -0.0033603 0.9966454 0.0009792 -3.432 0.00060 ***
intangibility -0.0939995 0.9102832 0.0708801 -1.326 0.18478
ebit_growth -0.0047098 0.9953013 0.0088930 -0.530 0.59639
EBIT_VOL_3Y -0.0075151 0.9925131 0.0042030 -1.788 0.07377 .
z_score 0.0065889 1.0066107 0.0062954 1.047 0.29527
gdp_deflator -0.0448223 0.9561674 0.0222194 -2.017 0.04367 *
unemployement -0.0273004 0.9730689 0.0170472 -1.601 0.10927
gdp_growth 0.0380981 1.0388331 0.0149766 2.544 0.01096 *
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
LTMTA 0.9331 1.0717 0.6463 1.3472
NIMTA 1.0536 0.9491 0.7070 1.5702
CASHMTA 0.9756 1.0250 0.5772 1.6490
PRICE 1.1379 0.8788 1.0934 1.1843
MBE 0.7807 1.2808 0.7371 0.8270
debt_ratio 1.0671 0.9372 0.8078 1.4095
debt_service 0.9915 1.0085 0.9708 1.0127
current_ratio 0.9230 1.0834 0.8943 0.9527
cash_to_assets 2.0627 0.4848 1.3244 3.2126
wc_ratio 0.7805 1.2813 0.5717 1.0655
gp_margin 1.0253 0.9753 1.0073 1.0437
asset_turnover 0.9425 1.0610 0.8819 1.0073
receivables_turnover 0.9966 1.0034 0.9947 0.9986
intangibility 0.9103 1.0986 0.7922 1.0459
ebit_growth 0.9953 1.0047 0.9781 1.0128
EBIT_VOL_3Y 0.9925 1.0075 0.9844 1.0007
z_score 1.0066 0.9934 0.9943 1.0191
gdp_deflator 0.9562 1.0458 0.9154 0.9987
unemployement 0.9731 1.0277 0.9411 1.0061
gdp_growth 1.0388 0.9626 1.0088 1.0698
Concordance= 0.638 (se = 0.007 )
Likelihood ratio test= 411.6 on 20 df, p=<2e-16
Wald test = 261.9 on 20 df, p=<2e-16
Score (logrank) test = 275.2 on 20 df, p=<2e-16
# 2. LASSO model
acquisition_lasso_model <- coxph(acquisition_lasso_formula, data = data, ties = "efron")
cat("\n=== ACQUISITION MODEL: LASSO SELECTION ===\n")
=== ACQUISITION MODEL: LASSO SELECTION ===
print(summary(acquisition_lasso_model))
Call:
coxph(formula = acquisition_lasso_formula, data = data, ties = "efron")
n= 63591, number of events= 2154
coef exp(coef) se(coef) z Pr(>|z|)
LTMTA -0.0262261 0.9741148 0.1823286 -0.144 0.885627
NIMTA 0.1248595 1.1329892 0.1889172 0.661 0.508663
PRICE 0.1280657 1.1366276 0.0202920 6.311 2.77e-10 ***
MBE -0.2302044 0.7943712 0.0225472 -10.210 < 2e-16 ***
debt_ratio 0.0116288 1.0116967 0.1278588 0.091 0.927532
current_ratio -0.0722919 0.9302593 0.0137555 -5.256 1.48e-07 ***
cash_to_assets 0.7196705 2.0537565 0.1629356 4.417 1.00e-05 ***
wc_ratio -0.2455432 0.7822795 0.1545175 -1.589 0.112039
gp_margin 0.0254789 1.0258062 0.0090435 2.817 0.004842 **
asset_turnover -0.0474881 0.9536219 0.0325823 -1.457 0.144983
receivables_turnover -0.0032994 0.9967060 0.0009764 -3.379 0.000727 ***
EBIT_VOL_3Y -0.0073213 0.9927054 0.0041959 -1.745 0.081005 .
gdp_deflator -0.0450158 0.9559824 0.0222042 -2.027 0.042626 *
unemployement -0.0275309 0.9728446 0.0170334 -1.616 0.106032
gdp_growth 0.0381395 1.0388762 0.0149693 2.548 0.010839 *
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
LTMTA 0.9741 1.0266 0.6814 1.3925
NIMTA 1.1330 0.8826 0.7824 1.6407
PRICE 1.1366 0.8798 1.0923 1.1827
MBE 0.7944 1.2589 0.7600 0.8303
debt_ratio 1.0117 0.9884 0.7874 1.2998
current_ratio 0.9303 1.0750 0.9055 0.9557
cash_to_assets 2.0538 0.4869 1.4923 2.8264
wc_ratio 0.7823 1.2783 0.5779 1.0590
gp_margin 1.0258 0.9748 1.0078 1.0442
asset_turnover 0.9536 1.0486 0.8946 1.0165
receivables_turnover 0.9967 1.0033 0.9948 0.9986
EBIT_VOL_3Y 0.9927 1.0073 0.9846 1.0009
gdp_deflator 0.9560 1.0460 0.9153 0.9985
unemployement 0.9728 1.0279 0.9409 1.0059
gdp_growth 1.0389 0.9626 1.0088 1.0698
Concordance= 0.638 (se = 0.007 )
Likelihood ratio test= 407.7 on 15 df, p=<2e-16
Wald test = 260.8 on 15 df, p=<2e-16
Score (logrank) test = 260.6 on 15 df, p=<2e-16
# 3. Union model
acquisition_union_model <- coxph(acquisition_union_formula, data = data, ties = "efron")
cat("\n=== ACQUISITION MODEL: UNION OF STEPWISE & LASSO ===\n")
=== ACQUISITION MODEL: UNION OF STEPWISE & LASSO ===
print(summary(acquisition_union_model))
Call:
coxph(formula = acquisition_union_formula, data = data, ties = "efron")
n= 63591, number of events= 2154
coef exp(coef) se(coef) z Pr(>|z|)
LTMTA -0.0692224 0.9331191 0.1873853 -0.369 0.71182
NIMTA 0.0521912 1.0535772 0.2035668 0.256 0.79765
CASHMTA -0.0246983 0.9756042 0.2677814 -0.092 0.92651
PRICE 0.1292039 1.1379221 0.0203765 6.341 2.29e-10 ***
MBE -0.2475084 0.7807436 0.0293828 -8.424 < 2e-16 ***
debt_ratio 0.0648998 1.0670521 0.1420247 0.457 0.64770
debt_service -0.0084962 0.9915398 0.0107977 -0.787 0.43137
current_ratio -0.0801206 0.9230050 0.0161442 -4.963 6.95e-07 ***
cash_to_assets 0.7240280 2.0627252 0.2260495 3.203 0.00136 **
wc_ratio -0.2478513 0.7804760 0.1588320 -1.560 0.11865
gp_margin 0.0250246 1.0253404 0.0090720 2.758 0.00581 **
asset_turnover -0.0591702 0.9425463 0.0339169 -1.745 0.08106 .
receivables_turnover -0.0033603 0.9966454 0.0009792 -3.432 0.00060 ***
intangibility -0.0939995 0.9102832 0.0708801 -1.326 0.18478
ebit_growth -0.0047098 0.9953013 0.0088930 -0.530 0.59639
EBIT_VOL_3Y -0.0075151 0.9925131 0.0042030 -1.788 0.07377 .
z_score 0.0065889 1.0066107 0.0062954 1.047 0.29527
gdp_deflator -0.0448223 0.9561674 0.0222194 -2.017 0.04367 *
unemployement -0.0273004 0.9730689 0.0170472 -1.601 0.10927
gdp_growth 0.0380981 1.0388331 0.0149766 2.544 0.01096 *
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
LTMTA 0.9331 1.0717 0.6463 1.3472
NIMTA 1.0536 0.9491 0.7070 1.5702
CASHMTA 0.9756 1.0250 0.5772 1.6490
PRICE 1.1379 0.8788 1.0934 1.1843
MBE 0.7807 1.2808 0.7371 0.8270
debt_ratio 1.0671 0.9372 0.8078 1.4095
debt_service 0.9915 1.0085 0.9708 1.0127
current_ratio 0.9230 1.0834 0.8943 0.9527
cash_to_assets 2.0627 0.4848 1.3244 3.2126
wc_ratio 0.7805 1.2813 0.5717 1.0655
gp_margin 1.0253 0.9753 1.0073 1.0437
asset_turnover 0.9425 1.0610 0.8819 1.0073
receivables_turnover 0.9966 1.0034 0.9947 0.9986
intangibility 0.9103 1.0986 0.7922 1.0459
ebit_growth 0.9953 1.0047 0.9781 1.0128
EBIT_VOL_3Y 0.9925 1.0075 0.9844 1.0007
z_score 1.0066 0.9934 0.9943 1.0191
gdp_deflator 0.9562 1.0458 0.9154 0.9987
unemployement 0.9731 1.0277 0.9411 1.0061
gdp_growth 1.0388 0.9626 1.0088 1.0698
Concordance= 0.638 (se = 0.007 )
Likelihood ratio test= 411.6 on 20 df, p=<2e-16
Wald test = 261.9 on 20 df, p=<2e-16
Score (logrank) test = 275.2 on 20 df, p=<2e-16
# 4. Intersection model
acquisition_intersect_model <- coxph(acquisition_intersect_formula, data = data, ties = "efron")
cat("\n=== ACQUISITION MODEL: INTERSECTION OF STEPWISE & LASSO ===\n")
=== ACQUISITION MODEL: INTERSECTION OF STEPWISE & LASSO ===
print(summary(acquisition_intersect_model))
Call:
coxph(formula = acquisition_intersect_formula, data = data, ties = "efron")
n= 63591, number of events= 2154
coef exp(coef) se(coef) z Pr(>|z|)
LTMTA -0.0262261 0.9741148 0.1823286 -0.144 0.885627
NIMTA 0.1248595 1.1329892 0.1889172 0.661 0.508663
PRICE 0.1280657 1.1366276 0.0202920 6.311 2.77e-10 ***
MBE -0.2302044 0.7943712 0.0225472 -10.210 < 2e-16 ***
debt_ratio 0.0116288 1.0116967 0.1278588 0.091 0.927532
current_ratio -0.0722919 0.9302593 0.0137555 -5.256 1.48e-07 ***
cash_to_assets 0.7196705 2.0537565 0.1629356 4.417 1.00e-05 ***
wc_ratio -0.2455432 0.7822795 0.1545175 -1.589 0.112039
gp_margin 0.0254789 1.0258062 0.0090435 2.817 0.004842 **
asset_turnover -0.0474881 0.9536219 0.0325823 -1.457 0.144983
receivables_turnover -0.0032994 0.9967060 0.0009764 -3.379 0.000727 ***
EBIT_VOL_3Y -0.0073213 0.9927054 0.0041959 -1.745 0.081005 .
gdp_deflator -0.0450158 0.9559824 0.0222042 -2.027 0.042626 *
unemployement -0.0275309 0.9728446 0.0170334 -1.616 0.106032
gdp_growth 0.0381395 1.0388762 0.0149693 2.548 0.010839 *
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
LTMTA 0.9741 1.0266 0.6814 1.3925
NIMTA 1.1330 0.8826 0.7824 1.6407
PRICE 1.1366 0.8798 1.0923 1.1827
MBE 0.7944 1.2589 0.7600 0.8303
debt_ratio 1.0117 0.9884 0.7874 1.2998
current_ratio 0.9303 1.0750 0.9055 0.9557
cash_to_assets 2.0538 0.4869 1.4923 2.8264
wc_ratio 0.7823 1.2783 0.5779 1.0590
gp_margin 1.0258 0.9748 1.0078 1.0442
asset_turnover 0.9536 1.0486 0.8946 1.0165
receivables_turnover 0.9967 1.0033 0.9948 0.9986
EBIT_VOL_3Y 0.9927 1.0073 0.9846 1.0009
gdp_deflator 0.9560 1.0460 0.9153 0.9985
unemployement 0.9728 1.0279 0.9409 1.0059
gdp_growth 1.0389 0.9626 1.0088 1.0698
Concordance= 0.638 (se = 0.007 )
Likelihood ratio test= 407.7 on 15 df, p=<2e-16
Wald test = 260.8 on 15 df, p=<2e-16
Score (logrank) test = 260.6 on 15 df, p=<2e-16
# 5. Financial-only model
acquisition_fin_only_model <- coxph(acquisition_fin_only_formula, data = data, ties = "efron")
cat("\n=== ACQUISITION MODEL: FINANCIAL VARIABLES ONLY ===\n")
=== ACQUISITION MODEL: FINANCIAL VARIABLES ONLY ===
print(summary(acquisition_fin_only_model))
Call:
coxph(formula = acquisition_fin_only_formula, data = data, ties = "efron")
n= 63591, number of events= 2154
coef exp(coef) se(coef) z Pr(>|z|)
LTMTA -0.0679723 0.9342864 0.1869893 -0.364 0.716225
NIMTA 0.0470879 1.0482142 0.2026759 0.232 0.816281
CASHMTA -0.0430935 0.9578218 0.2681345 -0.161 0.872317
PRICE 0.1286844 1.1373312 0.0203225 6.332 2.42e-10 ***
MBE -0.2462611 0.7817181 0.0292530 -8.418 < 2e-16 ***
debt_ratio 0.0579507 1.0596627 0.1415875 0.409 0.682325
debt_service -0.0085791 0.9914575 0.0108054 -0.794 0.427212
current_ratio -0.0795144 0.9235647 0.0161376 -4.927 8.34e-07 ***
cash_to_assets 0.6841462 1.9820789 0.2259743 3.028 0.002466 **
wc_ratio -0.2347706 0.7907522 0.1589516 -1.477 0.139677
gp_margin 0.0246483 1.0249546 0.0090474 2.724 0.006443 **
asset_turnover -0.0549353 0.9465463 0.0338395 -1.623 0.104502
receivables_turnover -0.0034371 0.9965688 0.0009838 -3.494 0.000476 ***
intangibility -0.0982700 0.9064042 0.0714710 -1.375 0.169143
ebit_growth -0.0037420 0.9962649 0.0089013 -0.420 0.674197
EBIT_VOL_3Y -0.0073760 0.9926511 0.0041951 -1.758 0.078707 .
z_score 0.0067290 1.0067517 0.0062627 1.074 0.282620
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
LTMTA 0.9343 1.0703 0.6476 1.3479
NIMTA 1.0482 0.9540 0.7046 1.5594
CASHMTA 0.9578 1.0440 0.5663 1.6200
PRICE 1.1373 0.8793 1.0929 1.1835
MBE 0.7817 1.2792 0.7382 0.8278
debt_ratio 1.0597 0.9437 0.8029 1.3986
debt_service 0.9915 1.0086 0.9707 1.0127
current_ratio 0.9236 1.0828 0.8948 0.9532
cash_to_assets 1.9821 0.5045 1.2728 3.0865
wc_ratio 0.7908 1.2646 0.5791 1.0798
gp_margin 1.0250 0.9757 1.0069 1.0433
asset_turnover 0.9465 1.0565 0.8858 1.0115
receivables_turnover 0.9966 1.0034 0.9946 0.9985
intangibility 0.9064 1.1033 0.7879 1.0427
ebit_growth 0.9963 1.0037 0.9790 1.0138
EBIT_VOL_3Y 0.9927 1.0074 0.9845 1.0008
z_score 1.0068 0.9933 0.9945 1.0192
Concordance= 0.633 (se = 0.007 )
Likelihood ratio test= 396.2 on 17 df, p=<2e-16
Wald test = 247 on 17 df, p=<2e-16
Score (logrank) test = 260.8 on 17 df, p=<2e-16
# 6. Macro-enriched model
acquisition_macro_enriched_model <- coxph(acquisition_macro_enriched_formula, data = data, ties = "efron")
cat("\n=== ACQUISITION MODEL: FINANCIAL + SIGNIFICANT MACRO VARIABLES ===\n")
=== ACQUISITION MODEL: FINANCIAL + SIGNIFICANT MACRO VARIABLES ===
print(summary(acquisition_macro_enriched_model))
Call:
coxph(formula = acquisition_macro_enriched_formula, data = data,
ties = "efron")
n= 63591, number of events= 2154
coef exp(coef) se(coef) z Pr(>|z|)
LTMTA -0.064384 0.937645 0.187325 -0.344 0.731069
NIMTA 0.062030 1.063994 0.203473 0.305 0.760476
CASHMTA -0.034316 0.966267 0.267815 -0.128 0.898045
PRICE 0.127374 1.135841 0.020327 6.266 3.70e-10 ***
MBE -0.247614 0.780661 0.029346 -8.438 < 2e-16 ***
debt_ratio 0.056037 1.057637 0.141964 0.395 0.693045
debt_service -0.008332 0.991703 0.010797 -0.772 0.440300
current_ratio -0.080000 0.923116 0.016136 -4.958 7.13e-07 ***
cash_to_assets 0.716034 2.046301 0.226062 3.167 0.001538 **
wc_ratio -0.245810 0.782071 0.158921 -1.547 0.121924
gp_margin 0.024921 1.025235 0.009055 2.752 0.005917 **
asset_turnover -0.056613 0.944960 0.033866 -1.672 0.094589 .
receivables_turnover -0.003389 0.996616 0.000980 -3.459 0.000543 ***
intangibility -0.094923 0.909443 0.071119 -1.335 0.181972
ebit_growth -0.004772 0.995239 0.008897 -0.536 0.591671
EBIT_VOL_3Y -0.007626 0.992403 0.004205 -1.814 0.069723 .
z_score 0.006635 1.006657 0.006285 1.056 0.291122
unemployement -0.017525 0.982628 0.016319 -1.074 0.282859
gdp_growth 0.032548 1.033083 0.014639 2.223 0.026190 *
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
LTMTA 0.9376 1.0665 0.6495 1.3536
NIMTA 1.0640 0.9399 0.7141 1.5854
CASHMTA 0.9663 1.0349 0.5717 1.6333
PRICE 1.1358 0.8804 1.0915 1.1820
MBE 0.7807 1.2810 0.7370 0.8269
debt_ratio 1.0576 0.9455 0.8007 1.3969
debt_service 0.9917 1.0084 0.9709 1.0129
current_ratio 0.9231 1.0833 0.8944 0.9528
cash_to_assets 2.0463 0.4887 1.3138 3.1871
wc_ratio 0.7821 1.2787 0.5728 1.0679
gp_margin 1.0252 0.9754 1.0072 1.0436
asset_turnover 0.9450 1.0582 0.8843 1.0098
receivables_turnover 0.9966 1.0034 0.9947 0.9985
intangibility 0.9094 1.0996 0.7911 1.0455
ebit_growth 0.9952 1.0048 0.9780 1.0127
EBIT_VOL_3Y 0.9924 1.0077 0.9843 1.0006
z_score 1.0067 0.9934 0.9943 1.0191
unemployement 0.9826 1.0177 0.9517 1.0146
gdp_growth 1.0331 0.9680 1.0039 1.0632
Concordance= 0.637 (se = 0.007 )
Likelihood ratio test= 407.4 on 19 df, p=<2e-16
Wald test = 257.8 on 19 df, p=<2e-16
Score (logrank) test = 271.2 on 19 df, p=<2e-16
# Compare models
cat("\nComparison of Acquisition Models:\n")
Comparison of Acquisition Models:
cat("--------------------------------------\n")
--------------------------------------
acquisition_models <- list(
Stepwise = acquisition_step_model,
LASSO = acquisition_lasso_model,
Union = acquisition_union_model,
Intersection = acquisition_intersect_model,
Financial_Only = acquisition_fin_only_model,
Macro_Enriched = acquisition_macro_enriched_model
)
acquisition_comparison <- data.frame(
Model = names(acquisition_models),
Fin_Vars = c(
sum(acquisition_vars_step %in% financial_covariates),
sum(acquisition_vars_lasso %in% financial_covariates),
sum(acquisition_union_vars %in% financial_covariates),
sum(acquisition_intersect_vars %in% financial_covariates),
length(acquisition_fin_only_vars),
sum(acquisition_macro_enriched_vars %in% financial_covariates)
),
Macro_Vars = c(
sum(acquisition_vars_step %in% macro_covariates),
sum(acquisition_vars_lasso %in% macro_covariates),
sum(acquisition_union_vars %in% macro_covariates),
sum(acquisition_intersect_vars %in% macro_covariates),
0,
sum(acquisition_macro_enriched_vars %in% macro_covariates)
),
Total_Vars = c(
length(acquisition_vars_step),
length(acquisition_vars_lasso),
length(acquisition_union_vars),
length(acquisition_intersect_vars),
length(acquisition_fin_only_vars),
length(acquisition_macro_enriched_vars)
),
AIC = sapply(acquisition_models, AIC),
BIC = sapply(acquisition_models, BIC),
Concordance = sapply(acquisition_models, function(m) round(m$concordance["concordance"], 3)),
LogLik = sapply(acquisition_models, function(m) round(m$loglik[2], 2))
)
print(acquisition_comparison)
# Identify best acquisition model based on AIC
best_acquisition_model_idx <- which.min(acquisition_comparison$AIC)
best_acquisition_model_name <- acquisition_comparison$Model[best_acquisition_model_idx]
best_acquisition_model <- acquisition_models[[best_acquisition_model_name]]
cat("\nBest acquisition model based on AIC:", best_acquisition_model_name, "\n")
Best acquisition model based on AIC: LASSO
# Calculate improvement over financial-only model
if(best_acquisition_model_name != "Financial_Only") {
# Likelihood ratio test
lrt <- anova(acquisition_fin_only_model, best_acquisition_model)
cat("\nLikelihood ratio test comparing best model to financial-only model:\n")
print(lrt)
# Concordance improvement
conc_improvement <- best_acquisition_model$concordance["concordance"] -
acquisition_fin_only_model$concordance["concordance"]
cat("\nConcordance improvement over financial-only model:", round(conc_improvement, 4), "\n")
}
Likelihood ratio test comparing best model to financial-only model:
Analysis of Deviance Table
Cox model: response is Surv(tstart, tstop, acquisition)
Model 1: ~ LTMTA + NIMTA + CASHMTA + PRICE + MBE + debt_ratio + debt_service + current_ratio + cash_to_assets + wc_ratio + gp_margin + asset_turnover + receivables_turnover + intangibility + ebit_growth + EBIT_VOL_3Y + z_score + strata(gsector)
Model 2: ~ LTMTA + NIMTA + PRICE + MBE + debt_ratio + current_ratio + cash_to_assets + wc_ratio + gp_margin + asset_turnover + receivables_turnover + EBIT_VOL_3Y + gdp_deflator + unemployement + gdp_growth + strata(gsector)
loglik Chisq Df Pr(>|Chi|)
1 -12138
2 -12132 11.505 2 0.003174 **
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
Concordance improvement over financial-only model: 0.0053
cat("This model will be used for subsequent analysis.\n")
This model will be used for subsequent analysis.
# Store the best models and their variables for next steps
best_models <- list(
bankruptcy = list(
model = best_bankruptcy_model,
name = best_bankruptcy_model_name,
variables = switch(best_bankruptcy_model_name,
"Stepwise" = bankruptcy_vars_step,
"LASSO" = bankruptcy_vars_lasso,
"Union" = bankruptcy_union_vars,
"Intersection" = bankruptcy_intersect_vars,
"Financial_Only" = bankruptcy_fin_only_vars,
"Macro_Enriched" = bankruptcy_macro_enriched_vars),
fin_vars = switch(best_bankruptcy_model_name,
"Stepwise" = bankruptcy_vars_step[bankruptcy_vars_step %in% financial_covariates],
"LASSO" = bankruptcy_vars_lasso[bankruptcy_vars_lasso %in% financial_covariates],
"Union" = bankruptcy_union_vars[bankruptcy_union_vars %in% financial_covariates],
"Intersection" = bankruptcy_intersect_vars[bankruptcy_intersect_vars %in% financial_covariates],
"Financial_Only" = bankruptcy_fin_only_vars,
"Macro_Enriched" = bankruptcy_macro_enriched_vars[bankruptcy_macro_enriched_vars %in% financial_covariates]),
macro_vars = switch(best_bankruptcy_model_name,
"Stepwise" = bankruptcy_vars_step[bankruptcy_vars_step %in% macro_covariates],
"LASSO" = bankruptcy_vars_lasso[bankruptcy_vars_lasso %in% macro_covariates],
"Union" = bankruptcy_union_vars[bankruptcy_union_vars %in% macro_covariates],
"Intersection" = bankruptcy_intersect_vars[bankruptcy_intersect_vars %in% macro_covariates],
"Financial_Only" = character(0),
"Macro_Enriched" = bankruptcy_macro_enriched_vars[bankruptcy_macro_enriched_vars %in% macro_covariates])
),
acquisition = list(
model = best_acquisition_model,
name = best_acquisition_model_name,
variables = switch(best_acquisition_model_name,
"Stepwise" = acquisition_vars_step,
"LASSO" = acquisition_vars_lasso,
"Union" = acquisition_union_vars,
"Intersection" = acquisition_intersect_vars,
"Financial_Only" = acquisition_fin_only_vars,
"Macro_Enriched" = acquisition_macro_enriched_vars),
fin_vars = switch(best_acquisition_model_name,
"Stepwise" = acquisition_vars_step[acquisition_vars_step %in% financial_covariates],
"LASSO" = acquisition_vars_lasso[acquisition_vars_lasso %in% financial_covariates],
"Union" = acquisition_union_vars[acquisition_union_vars %in% financial_covariates],
"Intersection" = acquisition_intersect_vars[acquisition_intersect_vars %in% financial_covariates],
"Financial_Only" = acquisition_fin_only_vars,
"Macro_Enriched" = acquisition_macro_enriched_vars[acquisition_macro_enriched_vars %in% financial_covariates]),
macro_vars = switch(best_acquisition_model_name,
"Stepwise" = acquisition_vars_step[acquisition_vars_step %in% macro_covariates],
"LASSO" = acquisition_vars_lasso[acquisition_vars_lasso %in% macro_covariates],
"Union" = acquisition_union_vars[acquisition_union_vars %in% macro_covariates],
"Intersection" = acquisition_intersect_vars[acquisition_intersect_vars %in% macro_covariates],
"Financial_Only" = character(0),
"Macro_Enriched" = acquisition_macro_enriched_vars[acquisition_macro_enriched_vars %in% macro_covariates])
)
)
# Print a summary of macro variables in the best models
cat("\n=== MACRO VARIABLES IN BEST MODELS ===\n")
=== MACRO VARIABLES IN BEST MODELS ===
cat("Bankruptcy model (", best_models$bankruptcy$name, "):\n", sep="")
Bankruptcy model (Stepwise):
if(length(best_models$bankruptcy$macro_vars) > 0) {
cat("- Macro variables:", paste(best_models$bankruptcy$macro_vars, collapse=", "), "\n")
} else {
cat("- No macro variables in this model\n")
}
- Macro variables: gdp_deflator, unemployement, gdp_growth
cat("\nAcquisition model (", best_models$acquisition$name, "):\n", sep="")
Acquisition model (LASSO):
if(length(best_models$acquisition$macro_vars) > 0) {
cat("- Macro variables:", paste(best_models$acquisition$macro_vars, collapse=", "), "\n")
} else {
cat("- No macro variables in this model\n")
}
- Macro variables: gdp_deflator, unemployement, gdp_growth
An important step in survival analysis is to check the proportional hazards assumption. We will use Schoenfeld residuals to test this assumption for both the bankruptcy and acquisition models. We will also visualize the residuals for financial and macro variables to identify any violations of the assumption.
#-------------------------------------------------------------
# STEP 9: Proportional Hazards Assumption Check
#-------------------------------------------------------------
cat("\n=== STEP 9: TESTING PROPORTIONAL HAZARDS ASSUMPTION WITH FOCUS ON MACRO VARIABLES ===\n")
=== STEP 9: TESTING PROPORTIONAL HAZARDS ASSUMPTION WITH FOCUS ON MACRO VARIABLES ===
#-------------------------------------------------------------
# 9.1: BANKRUPTCY MODEL - PH Assumption Check
#-------------------------------------------------------------
cat("\n9.1: BANKRUPTCY MODEL - Proportional Hazards Test\n")
9.1: BANKRUPTCY MODEL - Proportional Hazards Test
cat("--------------------------------------\n")
--------------------------------------
# Extract best bankruptcy model from previous step
cat("Testing PH assumption for best bankruptcy model:", best_models$bankruptcy$name, "\n")
Testing PH assumption for best bankruptcy model: Stepwise
bankruptcy_model <- best_models$bankruptcy$model
# Test proportional hazards assumption using Schoenfeld residuals
ph_test_bankruptcy <- cox.zph(bankruptcy_model)
cat("\nProportional Hazards Test Results (Schoenfeld Residuals):\n")
Proportional Hazards Test Results (Schoenfeld Residuals):
print(ph_test_bankruptcy)
chisq df p
LTMTA 5.25e+00 1 0.022
NIMTA 1.20e+00 1 0.274
CASHMTA 2.01e-03 1 0.964
PRICE 6.10e+00 1 0.014
MBE 1.15e-01 1 0.734
debt_ratio 4.38e+00 1 0.036
debt_service 1.89e-01 1 0.664
current_ratio 5.04e-03 1 0.943
cash_to_assets 2.50e-02 1 0.874
wc_ratio 2.38e+00 1 0.123
gp_margin 6.80e-01 1 0.410
asset_turnover 1.50e+00 1 0.220
receivables_turnover 3.15e-05 1 0.996
intangibility 4.40e-02 1 0.834
ebit_growth 1.72e+00 1 0.190
EBIT_VOL_3Y 3.95e-01 1 0.530
z_score 3.15e-02 1 0.859
gdp_deflator 4.73e-01 1 0.491
unemployement 7.54e-01 1 0.385
gdp_growth 3.92e-01 1 0.531
GLOBAL 1.63e+01 20 0.701
# Identify financial and macro variables violating the PH assumption
bankruptcy_ph_violators <- rownames(ph_test_bankruptcy$table)[
ph_test_bankruptcy$table[, "p"] < 0.05 &
rownames(ph_test_bankruptcy$table) != "GLOBAL"
]
bankruptcy_fin_violators <- bankruptcy_ph_violators[bankruptcy_ph_violators %in% financial_covariates]
bankruptcy_macro_violators <- bankruptcy_ph_violators[bankruptcy_ph_violators %in% macro_covariates]
cat("\nFinancial variables violating PH assumption in bankruptcy model (p < 0.05):\n")
Financial variables violating PH assumption in bankruptcy model (p < 0.05):
if(length(bankruptcy_fin_violators) > 0) {
print(bankruptcy_fin_violators)
} else {
cat("None - All financial variables satisfy the proportional hazards assumption\n")
}
[1] "LTMTA" "PRICE" "debt_ratio"
cat("\nMacro variables violating PH assumption in bankruptcy model (p < 0.05):\n")
Macro variables violating PH assumption in bankruptcy model (p < 0.05):
if(length(bankruptcy_macro_violators) > 0) {
print(bankruptcy_macro_violators)
} else {
cat("None - All macro variables satisfy the proportional hazards assumption\n")
}
None - All macro variables satisfy the proportional hazards assumption
# Visualize Schoenfeld residuals for financial variables
if(length(best_models$bankruptcy$fin_vars) > 0) {
cat("\nCreating Schoenfeld residual plots for financial variables in bankruptcy model...\n")
par(mfrow = c(2, 2)) # Adjust based on number of variables
for(i in 1:min(4, length(best_models$bankruptcy$fin_vars))) {
var_name <- best_models$bankruptcy$fin_vars[i]
var_idx <- which(rownames(ph_test_bankruptcy$table) == var_name)
if(length(var_idx) > 0) {
plot(ph_test_bankruptcy[var_idx], main=paste("Schoenfeld Residuals for", var_name),
xlab="Time", ylab="Beta(t)")
abline(h=0, col="red", lty=2)
}
}
par(mfrow = c(1, 1))
}
Creating Schoenfeld residual plots for financial variables in bankruptcy model...
# Visualize Schoenfeld residuals for macro variables (if any)
if(length(best_models$bankruptcy$macro_vars) > 0) {
cat("\nCreating Schoenfeld residual plots for macro variables in bankruptcy model...\n")
par(mfrow = c(2, 2)) # Adjust based on number of variables
for(i in 1:min(4, length(best_models$bankruptcy$macro_vars))) {
var_name <- best_models$bankruptcy$macro_vars[i]
var_idx <- which(rownames(ph_test_bankruptcy$table) == var_name)
if(length(var_idx) > 0) {
plot(ph_test_bankruptcy[var_idx], main=paste("Schoenfeld Residuals for", var_name),
xlab="Time", ylab="Beta(t)")
abline(h=0, col="red", lty=2)
}
}
par(mfrow = c(1, 1))
}
Creating Schoenfeld residual plots for macro variables in bankruptcy model...
# Check global test
global_ph_bankruptcy <- ph_test_bankruptcy$table["GLOBAL", "p"]
cat("\nGlobal test of proportional hazards assumption for bankruptcy model: p =",
round(global_ph_bankruptcy, 4), "\n")
Global test of proportional hazards assumption for bankruptcy model: p = 0.7008
if(global_ph_bankruptcy < 0.05) {
cat("The global test indicates violation of the PH assumption (p < 0.05).\n")
cat("Time-dependent coefficients should be considered in the next step.\n")
} else {
cat("The global test supports the proportional hazards assumption (p >= 0.05).\n")
}
The global test supports the proportional hazards assumption (p >= 0.05).
#-------------------------------------------------------------
# 9.2: ACQUISITION MODEL - PH Assumption Check
#-------------------------------------------------------------
cat("\n9.2: ACQUISITION MODEL - Proportional Hazards Test\n")
9.2: ACQUISITION MODEL - Proportional Hazards Test
cat("--------------------------------------\n")
--------------------------------------
# Extract best acquisition model from previous step
cat("Testing PH assumption for best acquisition model:", best_models$acquisition$name, "\n")
Testing PH assumption for best acquisition model: LASSO
acquisition_model <- best_models$acquisition$model
# Test proportional hazards assumption using Schoenfeld residuals
ph_test_acquisition <- cox.zph(acquisition_model)
cat("\nProportional Hazards Test Results (Schoenfeld Residuals):\n")
Proportional Hazards Test Results (Schoenfeld Residuals):
print(ph_test_acquisition)
chisq df p
LTMTA 0.654 1 0.41855
NIMTA 4.060 1 0.04390
PRICE 10.341 1 0.00130
MBE 1.352 1 0.24497
debt_ratio 0.699 1 0.40304
current_ratio 3.843 1 0.04997
cash_to_assets 1.774 1 0.18292
wc_ratio 14.443 1 0.00014
gp_margin 6.634 1 0.01001
asset_turnover 11.341 1 0.00076
receivables_turnover 1.304 1 0.25351
EBIT_VOL_3Y 11.108 1 0.00086
gdp_deflator 0.350 1 0.55432
unemployement 23.700 1 1.1e-06
gdp_growth 0.349 1 0.55484
GLOBAL 106.280 15 8.3e-16
# Identify financial and macro variables violating the PH assumption
acquisition_ph_violators <- rownames(ph_test_acquisition$table)[
ph_test_acquisition$table[, "p"] < 0.05 &
rownames(ph_test_acquisition$table) != "GLOBAL"
]
acquisition_fin_violators <- acquisition_ph_violators[acquisition_ph_violators %in% financial_covariates]
acquisition_macro_violators <- acquisition_ph_violators[acquisition_ph_violators %in% macro_covariates]
cat("\nFinancial variables violating PH assumption in acquisition model (p < 0.05):\n")
Financial variables violating PH assumption in acquisition model (p < 0.05):
if(length(acquisition_fin_violators) > 0) {
print(acquisition_fin_violators)
} else {
cat("None - All financial variables satisfy the proportional hazards assumption\n")
}
[1] "NIMTA" "PRICE" "current_ratio" "wc_ratio" "gp_margin" "asset_turnover" "EBIT_VOL_3Y"
cat("\nMacro variables violating PH assumption in acquisition model (p < 0.05):\n")
Macro variables violating PH assumption in acquisition model (p < 0.05):
if(length(acquisition_macro_violators) > 0) {
print(acquisition_macro_violators)
} else {
cat("None - All macro variables satisfy the proportional hazards assumption\n")
}
[1] "unemployement"
# Visualize Schoenfeld residuals for financial variables
if(length(best_models$acquisition$fin_vars) > 0) {
cat("\nCreating Schoenfeld residual plots for financial variables in acquisition model...\n")
par(mfrow = c(2, 2)) # Adjust based on number of variables
for(i in 1:min(4, length(best_models$acquisition$fin_vars))) {
var_name <- best_models$acquisition$fin_vars[i]
var_idx <- which(rownames(ph_test_acquisition$table) == var_name)
if(length(var_idx) > 0) {
plot(ph_test_acquisition[var_idx], main=paste("Schoenfeld Residuals for", var_name),
xlab="Time", ylab="Beta(t)")
abline(h=0, col="red", lty=2)
}
}
par(mfrow = c(1, 1))
}
Creating Schoenfeld residual plots for financial variables in acquisition model...
# Visualize Schoenfeld residuals for macro variables (if any)
if(length(best_models$acquisition$macro_vars) > 0) {
cat("\nCreating Schoenfeld residual plots for macro variables in acquisition model...\n")
par(mfrow = c(2, 2)) # Adjust based on number of variables
for(i in 1:min(4, length(best_models$acquisition$macro_vars))) {
var_name <- best_models$acquisition$macro_vars[i]
var_idx <- which(rownames(ph_test_acquisition$table) == var_name)
if(length(var_idx) > 0) {
plot(ph_test_acquisition[var_idx], main=paste("Schoenfeld Residuals for", var_name),
xlab="Time", ylab="Beta(t)")
abline(h=0, col="red", lty=2)
}
}
par(mfrow = c(1, 1))
}
Creating Schoenfeld residual plots for macro variables in acquisition model...
# Check global test
global_ph_acquisition <- ph_test_acquisition$table["GLOBAL", "p"]
cat("\nGlobal test of proportional hazards assumption for acquisition model: p =",
round(global_ph_acquisition, 4), "\n")
Global test of proportional hazards assumption for acquisition model: p = 0
if(global_ph_acquisition < 0.05) {
cat("The global test indicates violation of the PH assumption (p < 0.05).\n")
cat("Time-dependent coefficients should be considered in the next step.\n")
} else {
cat("The global test supports the proportional hazards assumption (p >= 0.05).\n")
}
The global test indicates violation of the PH assumption (p < 0.05).
Time-dependent coefficients should be considered in the next step.
Now that we know which variables violate the proportional hazards
assumption, we can test for time interactions. We will create a new
variable tt that represents time for the interaction terms.
We will then fit models with time interactions for both bankruptcy and
acquisition models, and analyze the results.
#-------------------------------------------------------------
# 9.3: Alternative Test - Time Interactions (Fixed)
#-------------------------------------------------------------
cat("\n9.3: Alternative Test - Direct Time Interactions (Fixed)\n")
9.3: Alternative Test - Direct Time Interactions (Fixed)
cat("--------------------------------------\n")
--------------------------------------
cat("Testing for non-proportionality using explicit time interactions...\n")
Testing for non-proportionality using explicit time interactions...
# Function to test time interactions for a model - fixed version
test_time_interactions <- function(model, model_type) {
# Get model variables
model_vars <- names(coef(model))
model_vars <- model_vars[!grepl("strata", model_vars)]
# Create data frame to store results
interaction_results <- data.frame(
Variable = character(),
Type = character(),
Interaction_Coef = numeric(),
P_value = numeric(),
stringsAsFactors = FALSE
)
# Create a time variable for interactions that won't conflict
data$tt <- data$tstop # tt = time for time-interactions
# Test each variable with time interaction
for(var in model_vars) {
# Determine if this is a financial or macro variable
var_type <- if(var %in% financial_covariates) "Financial" else "Macroeconomic"
# Create formula with time interaction
if(model_type == "bankruptcy") {
formula_with_interaction <- as.formula(paste0(
"Surv(tstart, tstop, bankruptcy) ~ ",
paste(model_vars, collapse = " + "),
" + ", var, ":tt", # Using tt instead of tstop
" + strata(gsector)"
))
} else {
formula_with_interaction <- as.formula(paste0(
"Surv(tstart, tstop, acquisition) ~ ",
paste(model_vars, collapse = " + "),
" + ", var, ":tt", # Using tt instead of tstop
" + strata(gsector)"
))
}
# Fit model with interaction
interaction_model <- tryCatch({
coxph(formula_with_interaction, data = data, ties = "efron")
}, error = function(e) {
cat("Error fitting interaction model for", var, ":", e$message, "\n")
return(NULL)
})
if(!is.null(interaction_model)) {
# Extract interaction coefficient and p-value
interaction_term <- paste0(var, ":tt")
if(interaction_term %in% names(coef(interaction_model))) {
coef_val <- coef(interaction_model)[interaction_term]
p_val <- summary(interaction_model)$coefficients[interaction_term, "Pr(>|z|)"]
# Add to results
interaction_results <- rbind(interaction_results, data.frame(
Variable = var,
Type = var_type,
Interaction_Coef = coef_val,
P_value = p_val,
stringsAsFactors = FALSE
))
}
}
}
# Sort by p-value
interaction_results <- interaction_results[order(interaction_results$P_value), ]
return(interaction_results)
}
# Test time interactions for bankruptcy model
bankruptcy_interactions <- test_time_interactions(bankruptcy_model, "bankruptcy")
cat("\nTime interaction test results for bankruptcy model:\n")
Time interaction test results for bankruptcy model:
print(bankruptcy_interactions)
# Test time interactions for acquisition model
acquisition_interactions <- test_time_interactions(acquisition_model, "acquisition")
cat("\nTime interaction test results for acquisition model:\n")
Time interaction test results for acquisition model:
print(acquisition_interactions)
# Analyze time interactions by variable type
cat("\nAnalysis of time interactions by variable type:\n")
Analysis of time interactions by variable type:
# For bankruptcy model
bankruptcy_fin_interactions <- bankruptcy_interactions[bankruptcy_interactions$Type == "Financial", ]
bankruptcy_macro_interactions <- bankruptcy_interactions[bankruptcy_interactions$Type == "Macroeconomic", ]
cat("\nBankruptcy model - financial variables with significant time interactions (p < 0.05):\n")
Bankruptcy model - financial variables with significant time interactions (p < 0.05):
sig_bk_fin <- bankruptcy_fin_interactions[bankruptcy_fin_interactions$P_value < 0.05, ]
if(nrow(sig_bk_fin) > 0) {
print(sig_bk_fin)
} else {
cat("No significant time interactions found for financial variables.\n")
}
cat("\nBankruptcy model - macro variables with significant time interactions (p < 0.05):\n")
Bankruptcy model - macro variables with significant time interactions (p < 0.05):
sig_bk_macro <- bankruptcy_macro_interactions[bankruptcy_macro_interactions$P_value < 0.05, ]
if(nrow(sig_bk_macro) > 0) {
print(sig_bk_macro)
cat("\nInterpretation: These macro variables have effects that change over time, suggesting\n")
cat("that economic conditions have a time-varying impact on bankruptcy risk.\n")
} else {
cat("No significant time interactions found for macro variables.\n")
}
No significant time interactions found for macro variables.
# For acquisition model
acquisition_fin_interactions <- acquisition_interactions[acquisition_interactions$Type == "Financial", ]
acquisition_macro_interactions <- acquisition_interactions[acquisition_interactions$Type == "Macroeconomic", ]
cat("\nAcquisition model - financial variables with significant time interactions (p < 0.05):\n")
Acquisition model - financial variables with significant time interactions (p < 0.05):
sig_acq_fin <- acquisition_fin_interactions[acquisition_fin_interactions$P_value < 0.05, ]
if(nrow(sig_acq_fin) > 0) {
print(sig_acq_fin)
} else {
cat("No significant time interactions found for financial variables.\n")
}
cat("\nAcquisition model - macro variables with significant time interactions (p < 0.05):\n")
Acquisition model - macro variables with significant time interactions (p < 0.05):
sig_acq_macro <- acquisition_macro_interactions[acquisition_macro_interactions$P_value < 0.05, ]
if(nrow(sig_acq_macro) > 0) {
print(sig_acq_macro)
cat("\nInterpretation: These macro variables have effects that change over time, suggesting\n")
cat("that economic conditions have a time-varying impact on acquisition likelihood.\n")
} else {
cat("No significant time interactions found for macro variables.\n")
}
Interpretation: These macro variables have effects that change over time, suggesting
that economic conditions have a time-varying impact on acquisition likelihood.
# Additional check for business cycle effects
cat("\n9.4: Testing for Business Cycle Effects in Macro Variables\n")
9.4: Testing for Business Cycle Effects in Macro Variables
cat("--------------------------------------\n")
--------------------------------------
cat("Examining if macro variables violate the PH assumption due to business cycle effects...\n")
Examining if macro variables violate the PH assumption due to business cycle effects...
# Macro variables that violate PH assumption in either model
all_macro_violators <- unique(c(bankruptcy_macro_violators, acquisition_macro_violators))
if(length(all_macro_violators) > 0) {
cat("\nThe following macro variables violate the PH assumption, potentially due to business cycle effects:\n")
print(all_macro_violators)
cat("\nPossible interpretations:\n")
cat("1. The effect of these variables changes over time with economic conditions\n")
cat("2. Their influence may be stronger during recessions or expansions\n")
cat("3. Time-varying coefficients may be more appropriate for these variables\n")
} else {
cat("\nNo macro variables violate the PH assumption, suggesting that macroeconomic\n")
cat("effects on company outcomes are stable over time regardless of business cycles.\n")
}
The following macro variables violate the PH assumption, potentially due to business cycle effects:
[1] "unemployement"
Possible interpretations:
1. The effect of these variables changes over time with economic conditions
2. Their influence may be stronger during recessions or expansions
3. Time-varying coefficients may be more appropriate for these variables
# Store results for next step
ph_test_results <- list(
bankruptcy = list(
schoenfeld_test = ph_test_bankruptcy,
all_violators = bankruptcy_ph_violators,
fin_violators = bankruptcy_fin_violators,
macro_violators = bankruptcy_macro_violators,
time_interactions = bankruptcy_interactions,
sig_fin_interactions = sig_bk_fin,
sig_macro_interactions = sig_bk_macro
),
acquisition = list(
schoenfeld_test = ph_test_acquisition,
all_violators = acquisition_ph_violators,
fin_violators = acquisition_fin_violators,
macro_violators = acquisition_macro_violators,
time_interactions = acquisition_interactions,
sig_fin_interactions = sig_acq_fin,
sig_macro_interactions = sig_acq_macro
)
)
We will now proceed to fit the final models with time-dependent
coefficients. We will create a new variable tt that
represents time for the interaction terms. We will then fit models with
time interactions for both bankruptcy and acquisition models, and
analyze the results.
#-------------------------------------------------------------
# STEP 10: Final Models with Time-Dependent Coefficients (Modified)
#-------------------------------------------------------------
cat("\n=== STEP 10: FINAL MODELS WITH TIME-DEPENDENT COEFFICIENTS AND MACRO EFFECTS ===\n")
=== STEP 10: FINAL MODELS WITH TIME-DEPENDENT COEFFICIENTS AND MACRO EFFECTS ===
# Create a time variable for interactions if it doesn't exist
if(!"tt" %in% colnames(data)) {
cat("Creating time variable (tt) for time-dependent coefficients...\n")
data$tt <- data$tstop # tt = time for time-interactions
}
Creating time variable (tt) for time-dependent coefficients...
#-------------------------------------------------------------
# 10.1: BANKRUPTCY MODEL - Address PH Violations
#-------------------------------------------------------------
cat("\n10.1: BANKRUPTCY MODEL - Addressing PH Violations\n")
10.1: BANKRUPTCY MODEL - Addressing PH Violations
cat("--------------------------------------\n")
--------------------------------------
# Extract violators from previous step's results, separated by variable type
bankruptcy_fin_violators <- ph_test_results$bankruptcy$fin_violators
bankruptcy_macro_violators <- ph_test_results$bankruptcy$macro_violators
bankruptcy_ph_violators <- ph_test_results$bankruptcy$all_violators
cat("Financial variables violating PH assumption in bankruptcy model:\n")
Financial variables violating PH assumption in bankruptcy model:
if(length(bankruptcy_fin_violators) > 0) {
print(bankruptcy_fin_violators)
} else {
cat("None found - All financial variables satisfy PH assumption\n")
}
[1] "LTMTA" "PRICE" "debt_ratio"
cat("\nMacroeconomic variables violating PH assumption in bankruptcy model:\n")
Macroeconomic variables violating PH assumption in bankruptcy model:
if(length(bankruptcy_macro_violators) > 0) {
print(bankruptcy_macro_violators)
cat("\nNote: Violations in macro variables may indicate business cycle effects\n")
} else {
cat("None found - All macro variables satisfy PH assumption\n")
}
None found - All macro variables satisfy PH assumption
if(length(bankruptcy_ph_violators) > 0) {
cat("\nTotal variables violating PH assumption:", length(bankruptcy_ph_violators), "\n")
print(bankruptcy_ph_violators)
# To prevent computational issues, limit to top 3 most significant violators if there are many
if(length(bankruptcy_ph_violators) > 3) {
cat("Many variables violate PH assumption. Using only the top 3 most significant violators.\n")
# Get p-values from the PH test
violator_pvals <- ph_test_results$bankruptcy$schoenfeld_test$table[bankruptcy_ph_violators, "p"]
# Select top 3 with lowest p-values
bankruptcy_ph_violators <- names(sort(violator_pvals)[1:3])
cat("Selected violators:", paste(bankruptcy_ph_violators, collapse=", "), "\n")
# Check if any macro variables are in the top 3
has_macro <- any(bankruptcy_ph_violators %in% macro_covariates)
if(has_macro) {
cat("Selection includes macro variables, which may indicate business cycle effects.\n")
} else {
# If no macro variables are in top 3 but there are macro violators, add the most significant one
if(length(bankruptcy_macro_violators) > 0) {
macro_violator_pvals <- ph_test_results$bankruptcy$schoenfeld_test$table[bankruptcy_macro_violators, "p"]
top_macro_violator <- names(sort(macro_violator_pvals)[1])
# Replace the least significant of the 3 with the top macro violator
worst_idx <- which.max(violator_pvals[bankruptcy_ph_violators])
bankruptcy_ph_violators[worst_idx] <- top_macro_violator
cat("Added macro variable", top_macro_violator, "to ensure business cycle effects are captured.\n")
}
}
}
# Create formula iteratively by adding one interaction at a time
bankruptcy_vars <- best_models$bankruptcy$variables
# Start with the base formula
formula_str <- paste0("Surv(tstart, tstop, bankruptcy) ~ ",
paste(bankruptcy_vars, collapse = " + "),
" + strata(gsector)")
# Add interactions one by one
for(var in bankruptcy_ph_violators) {
# Try adding this interaction
var_type <- ifelse(var %in% financial_covariates, "financial", "macro")
cat("Testing time interaction for", var, "(", var_type, "variable )...\n")
new_formula_str <- paste0(formula_str, " + ", var, ":tt")
# See if the formula works
tryCatch({
new_formula <- as.formula(new_formula_str)
# If it works, update the formula string
formula_str <- new_formula_str
cat("Added time interaction for", var, "successfully.\n")
}, error = function(e) {
cat("Error adding time interaction for", var, ":", e$message, "\n")
cat("Skipping this interaction.\n")
})
}
# Create the final formula
cat("Creating final formula for bankruptcy model...\n")
final_bankruptcy_formula <- as.formula(formula_str)
cat("\nFitting final bankruptcy model with time-dependent coefficients...\n")
final_bankruptcy_model <- coxph(final_bankruptcy_formula, data = data, ties = "efron")
cat("\n=== FINAL BANKRUPTCY MODEL WITH TIME-DEPENDENT EFFECTS ===\n")
print(summary(final_bankruptcy_model))
} else {
cat("None found - Using original model\n")
final_bankruptcy_model <- best_models$bankruptcy$model
cat("\nFinal bankruptcy model remains unchanged (no PH violations).\n")
}
Total variables violating PH assumption: 3
[1] "LTMTA" "PRICE" "debt_ratio"
Testing time interaction for LTMTA ( financial variable )...
Added time interaction for LTMTA successfully.
Testing time interaction for PRICE ( financial variable )...
Added time interaction for PRICE successfully.
Testing time interaction for debt_ratio ( financial variable )...
Added time interaction for debt_ratio successfully.
Creating final formula for bankruptcy model...
Fitting final bankruptcy model with time-dependent coefficients...
=== FINAL BANKRUPTCY MODEL WITH TIME-DEPENDENT EFFECTS ===
Call:
coxph(formula = final_bankruptcy_formula, data = data, ties = "efron")
n= 63591, number of events= 176
coef exp(coef) se(coef) z Pr(>|z|)
LTMTA 3.669656 39.238389 0.783073 4.686 2.78e-06 ***
NIMTA -2.141137 0.117521 0.407862 -5.250 1.52e-07 ***
CASHMTA -2.110060 0.121231 0.947459 -2.227 0.025942 *
PRICE -0.172198 0.841812 0.104301 -1.651 0.098745 .
MBE -0.164041 0.848707 0.085135 -1.927 0.053999 .
debt_ratio -0.492916 0.610842 0.450052 -1.095 0.273411
debt_service -0.003393 0.996613 0.022750 -0.149 0.881437
current_ratio 0.083558 1.087148 0.040743 2.051 0.040279 *
cash_to_assets 1.438954 4.216283 0.909733 1.582 0.113711
wc_ratio -1.104150 0.331492 0.323614 -3.412 0.000645 ***
gp_margin 0.062809 1.064824 0.046584 1.348 0.177562
asset_turnover -0.168935 0.844564 0.096454 -1.751 0.079866 .
receivables_turnover 0.001262 1.001262 0.001797 0.702 0.482692
intangibility -0.294410 0.744971 0.214773 -1.371 0.170438
ebit_growth -0.017514 0.982638 0.025433 -0.689 0.491044
EBIT_VOL_3Y -0.001524 0.998477 0.012983 -0.117 0.906537
z_score 0.029653 1.030097 0.013010 2.279 0.022658 *
gdp_deflator -0.175334 0.839177 0.089871 -1.951 0.051064 .
unemployement -0.074394 0.928306 0.068538 -1.085 0.277722
gdp_growth 0.098686 1.103720 0.057119 1.728 0.084038 .
LTMTA:tt 0.041183 1.042043 0.061395 0.671 0.502354
PRICE:tt -0.011245 0.988818 0.007439 -1.512 0.130626
debt_ratio:tt 0.027717 1.028105 0.029924 0.926 0.354319
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
LTMTA 39.2384 0.02549 8.45587 182.0808
NIMTA 0.1175 8.50911 0.05284 0.2614
CASHMTA 0.1212 8.24874 0.01893 0.7764
PRICE 0.8418 1.18791 0.68617 1.0328
MBE 0.8487 1.17826 0.71828 1.0028
debt_ratio 0.6108 1.63708 0.25284 1.4758
debt_service 0.9966 1.00340 0.95315 1.0421
current_ratio 1.0871 0.91984 1.00371 1.1775
cash_to_assets 4.2163 0.23718 0.70886 25.0782
wc_ratio 0.3315 3.01666 0.17580 0.6251
gp_margin 1.0648 0.93912 0.97191 1.1666
asset_turnover 0.8446 1.18404 0.69909 1.0203
receivables_turnover 1.0013 0.99874 0.99774 1.0048
intangibility 0.7450 1.34233 0.48902 1.1349
ebit_growth 0.9826 1.01767 0.93486 1.0329
EBIT_VOL_3Y 0.9985 1.00153 0.97339 1.0242
z_score 1.0301 0.97078 1.00416 1.0567
gdp_deflator 0.8392 1.19164 0.70365 1.0008
unemployement 0.9283 1.07723 0.81162 1.0618
gdp_growth 1.1037 0.90603 0.98682 1.2345
LTMTA:tt 1.0420 0.95965 0.92390 1.1753
PRICE:tt 0.9888 1.01131 0.97451 1.0033
debt_ratio:tt 1.0281 0.97266 0.96954 1.0902
Concordance= 0.864 (se = 0.019 )
Likelihood ratio test= 445.2 on 23 df, p=<2e-16
Wald test = 386.2 on 23 df, p=<2e-16
Score (logrank) test = 612.3 on 23 df, p=<2e-16
#-------------------------------------------------------------
# 10.2: ACQUISITION MODEL - Address PH Violations
#-------------------------------------------------------------
cat("\n10.2: ACQUISITION MODEL - Addressing PH Violations\n")
10.2: ACQUISITION MODEL - Addressing PH Violations
cat("--------------------------------------\n")
--------------------------------------
# Extract violators from previous step's results, separated by variable type
acquisition_fin_violators <- ph_test_results$acquisition$fin_violators
acquisition_macro_violators <- ph_test_results$acquisition$macro_violators
acquisition_ph_violators <- ph_test_results$acquisition$all_violators
cat("Financial variables violating PH assumption in acquisition model:\n")
Financial variables violating PH assumption in acquisition model:
if(length(acquisition_fin_violators) > 0) {
print(acquisition_fin_violators)
} else {
cat("None found - All financial variables satisfy PH assumption\n")
}
[1] "NIMTA" "PRICE" "current_ratio" "wc_ratio" "gp_margin" "asset_turnover" "EBIT_VOL_3Y"
cat("\nMacroeconomic variables violating PH assumption in acquisition model:\n")
Macroeconomic variables violating PH assumption in acquisition model:
if(length(acquisition_macro_violators) > 0) {
print(acquisition_macro_violators)
cat("\nNote: Violations in macro variables may indicate business cycle effects\n")
} else {
cat("None found - All macro variables satisfy PH assumption\n")
}
[1] "unemployement"
Note: Violations in macro variables may indicate business cycle effects
if(length(acquisition_ph_violators) > 0) {
cat("\nTotal variables violating PH assumption:", length(acquisition_ph_violators), "\n")
print(acquisition_ph_violators)
# To prevent computational issues, limit to top 3 most significant violators if there are many
if(length(acquisition_ph_violators) > 3) {
cat("Many variables violate PH assumption. Using only the top 3 most significant violators.\n")
# Get p-values from the PH test
violator_pvals <- ph_test_results$acquisition$schoenfeld_test$table[acquisition_ph_violators, "p"]
# Select top 3 with lowest p-values
acquisition_ph_violators <- names(sort(violator_pvals)[1:3])
cat("Selected violators:", paste(acquisition_ph_violators, collapse=", "), "\n")
# Check if any macro variables are in the top 3
has_macro <- any(acquisition_ph_violators %in% macro_covariates)
if(has_macro) {
cat("Selection includes macro variables, which may indicate business cycle effects.\n")
} else {
# If no macro variables are in top 3 but there are macro violators, add the most significant one
if(length(acquisition_macro_violators) > 0) {
macro_violator_pvals <- ph_test_results$acquisition$schoenfeld_test$table[acquisition_macro_violators, "p"]
top_macro_violator <- names(sort(macro_violator_pvals)[1])
# Replace the least significant of the 3 with the top macro violator
worst_idx <- which.max(violator_pvals[acquisition_ph_violators])
acquisition_ph_violators[worst_idx] <- top_macro_violator
cat("Added macro variable", top_macro_violator, "to ensure business cycle effects are captured.\n")
}
}
}
# Create formula iteratively by adding one interaction at a time
acquisition_vars <- best_models$acquisition$variables
# Start with the base formula
formula_str <- paste0("Surv(tstart, tstop, acquisition) ~ ",
paste(acquisition_vars, collapse = " + "),
" + strata(gsector)")
# Add interactions one by one
for(var in acquisition_ph_violators) {
# Try adding this interaction
var_type <- ifelse(var %in% financial_covariates, "financial", "macro")
cat("Testing time interaction for", var, "(", var_type, "variable )...\n")
new_formula_str <- paste0(formula_str, " + ", var, ":tt")
# See if the formula works
tryCatch({
new_formula <- as.formula(new_formula_str)
# If it works, update the formula string
formula_str <- new_formula_str
cat("Added time interaction for", var, "successfully.\n")
}, error = function(e) {
cat("Error adding time interaction for", var, ":", e$message, "\n")
cat("Skipping this interaction.\n")
})
}
# Create the final formula
cat("Creating final formula for acquisition model...\n")
final_acquisition_formula <- as.formula(formula_str)
cat("\nFitting final acquisition model with time-dependent coefficients...\n")
final_acquisition_model <- coxph(final_acquisition_formula, data = data, ties = "efron")
cat("\n=== FINAL ACQUISITION MODEL WITH TIME-DEPENDENT EFFECTS ===\n")
print(summary(final_acquisition_model))
} else {
cat("None found - Using original model\n")
final_acquisition_model <- best_models$acquisition$model
cat("\nFinal acquisition model remains unchanged (no PH violations).\n")
}
Total variables violating PH assumption: 8
[1] "NIMTA" "PRICE" "current_ratio" "wc_ratio" "gp_margin" "asset_turnover" "EBIT_VOL_3Y"
[8] "unemployement"
Many variables violate PH assumption. Using only the top 3 most significant violators.
Selected violators: unemployement, wc_ratio, asset_turnover
Selection includes macro variables, which may indicate business cycle effects.
Testing time interaction for unemployement ( macro variable )...
Added time interaction for unemployement successfully.
Testing time interaction for wc_ratio ( financial variable )...
Added time interaction for wc_ratio successfully.
Testing time interaction for asset_turnover ( financial variable )...
Added time interaction for asset_turnover successfully.
Creating final formula for acquisition model...
Fitting final acquisition model with time-dependent coefficients...
=== FINAL ACQUISITION MODEL WITH TIME-DEPENDENT EFFECTS ===
Call:
coxph(formula = final_acquisition_formula, data = data, ties = "efron")
n= 63591, number of events= 2154
coef exp(coef) se(coef) z Pr(>|z|)
LTMTA -0.0317114 0.9687862 0.1826326 -0.174 0.862152
NIMTA 0.1883795 1.2072916 0.1900803 0.991 0.321660
PRICE 0.1328157 1.1420395 0.0204355 6.499 8.07e-11 ***
MBE -0.2303072 0.7942895 0.0226148 -10.184 < 2e-16 ***
debt_ratio 0.0223924 1.0226450 0.1277378 0.175 0.860844
current_ratio -0.0737268 0.9289255 0.0137999 -5.343 9.16e-08 ***
cash_to_assets 0.7377511 2.0912273 0.1628459 4.530 5.89e-06 ***
wc_ratio -0.7110165 0.4911447 0.1987708 -3.577 0.000347 ***
gp_margin 0.0256220 1.0259531 0.0090340 2.836 0.004566 **
asset_turnover -0.1872699 0.8292199 0.0572374 -3.272 0.001069 **
receivables_turnover -0.0032563 0.9967490 0.0009728 -3.347 0.000816 ***
EBIT_VOL_3Y -0.0075669 0.9924617 0.0042047 -1.800 0.071918 .
gdp_deflator -0.0381169 0.9626004 0.0221410 -1.722 0.085150 .
unemployement -0.1340807 0.8745195 0.0311795 -4.300 1.71e-05 ***
gdp_growth 0.0369393 1.0376301 0.0148860 2.481 0.013084 *
unemployement:tt 0.0082911 1.0083256 0.0020019 4.142 3.45e-05 ***
wc_ratio:tt 0.0464175 1.0475116 0.0127462 3.642 0.000271 ***
asset_turnover:tt 0.0129630 1.0130474 0.0042668 3.038 0.002381 **
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
exp(coef) exp(-coef) lower .95 upper .95
LTMTA 0.9688 1.0322 0.6773 1.3858
NIMTA 1.2073 0.8283 0.8318 1.7523
PRICE 1.1420 0.8756 1.0972 1.1887
MBE 0.7943 1.2590 0.7599 0.8303
debt_ratio 1.0226 0.9779 0.7961 1.3136
current_ratio 0.9289 1.0765 0.9041 0.9544
cash_to_assets 2.0912 0.4782 1.5198 2.8775
wc_ratio 0.4911 2.0361 0.3327 0.7251
gp_margin 1.0260 0.9747 1.0079 1.0443
asset_turnover 0.8292 1.2060 0.7412 0.9277
receivables_turnover 0.9967 1.0033 0.9949 0.9987
EBIT_VOL_3Y 0.9925 1.0076 0.9843 1.0007
gdp_deflator 0.9626 1.0389 0.9217 1.0053
unemployement 0.8745 1.1435 0.8227 0.9296
gdp_growth 1.0376 0.9637 1.0078 1.0683
unemployement:tt 1.0083 0.9917 1.0044 1.0123
wc_ratio:tt 1.0475 0.9546 1.0217 1.0740
asset_turnover:tt 1.0130 0.9871 1.0046 1.0216
Concordance= 0.643 (se = 0.007 )
Likelihood ratio test= 448 on 18 df, p=<2e-16
Wald test = 298.2 on 18 df, p=<2e-16
Score (logrank) test = 296.8 on 18 df, p=<2e-16
Next, we will interpret the time-dependent effects of the macroeconomic variables in both models. We will focus on how these effects change over time and their implications for business cycles.
#-------------------------------------------------------------
# 10.3: Interpret Time-Dependent Effects with Focus on Macro Variables
#-------------------------------------------------------------
cat("\n10.3: Interpreting Time-Dependent Effects with Focus on Macro Variables\n")
10.3: Interpreting Time-Dependent Effects with Focus on Macro Variables
cat("--------------------------------------\n")
--------------------------------------
# Get all time interaction terms from final models
bankruptcy_time_terms <- grep(":tt", names(coef(final_bankruptcy_model)), value = TRUE)
acquisition_time_terms <- grep(":tt", names(coef(final_acquisition_model)), value = TRUE)
# Split terms by variable type
bankruptcy_fin_time_terms <- bankruptcy_time_terms[sapply(bankruptcy_time_terms, function(term) {
var_name <- strsplit(term, ":")[[1]][1]
return(var_name %in% financial_covariates)
})]
bankruptcy_macro_time_terms <- bankruptcy_time_terms[sapply(bankruptcy_time_terms, function(term) {
var_name <- strsplit(term, ":")[[1]][1]
return(var_name %in% macro_covariates)
})]
acquisition_fin_time_terms <- acquisition_time_terms[sapply(acquisition_time_terms, function(term) {
var_name <- strsplit(term, ":")[[1]][1]
return(var_name %in% financial_covariates)
})]
acquisition_macro_time_terms <- acquisition_time_terms[sapply(acquisition_time_terms, function(term) {
var_name <- strsplit(term, ":")[[1]][1]
return(var_name %in% macro_covariates)
})]
# Report time-dependent effects by variable type
cat("\nBankruptcy model - financial time-dependent terms:",
ifelse(length(bankruptcy_fin_time_terms) > 0,
paste(bankruptcy_fin_time_terms, collapse=", "),
"None"), "\n")
Bankruptcy model - financial time-dependent terms: LTMTA:tt, PRICE:tt, debt_ratio:tt
cat("\nBankruptcy model - macro time-dependent terms:",
ifelse(length(bankruptcy_macro_time_terms) > 0,
paste(bankruptcy_macro_time_terms, collapse=", "),
"None"), "\n")
Bankruptcy model - macro time-dependent terms: None
cat("\nAcquisition model - financial time-dependent terms:",
ifelse(length(acquisition_fin_time_terms) > 0,
paste(acquisition_fin_time_terms, collapse=", "),
"None"), "\n")
Acquisition model - financial time-dependent terms: wc_ratio:tt, asset_turnover:tt
cat("\nAcquisition model - macro time-dependent terms:",
ifelse(length(acquisition_macro_time_terms) > 0,
paste(acquisition_macro_time_terms, collapse=", "),
"None"), "\n")
Acquisition model - macro time-dependent terms: unemployement:tt
# Analyze and interpret time-dependent effects of macro variables
if(length(bankruptcy_macro_time_terms) > 0 || length(acquisition_macro_time_terms) > 0) {
cat("\n=== ANALYSIS OF TIME-DEPENDENT MACROECONOMIC EFFECTS ===\n")
# For bankruptcy model
if(length(bankruptcy_macro_time_terms) > 0) {
cat("\nBankruptcy risk - Macroeconomic time-dependent effects:\n")
for(term in bankruptcy_macro_time_terms) {
var_name <- strsplit(term, ":")[[1]][1]
coef_main <- coef(final_bankruptcy_model)[var_name]
coef_time <- coef(final_bankruptcy_model)[term]
cat("\n", var_name, ":\n", sep="")
cat("- Base effect (coefficient):", round(coef_main, 4), "\n")
cat("- Time interaction effect:", round(coef_time, 4), "\n")
if(coef_time > 0) {
cat("- Effect interpretation: The impact of", var_name, "on bankruptcy risk INCREASES over time\n")
if(coef_main < 0) {
cat(" (starts as protective but becomes less protective)\n")
} else {
cat(" (becomes more risky over time)\n")
}
} else {
cat("- Effect interpretation: The impact of", var_name, "on bankruptcy risk DECREASES over time\n")
if(coef_main > 0) {
cat(" (starts as risky but becomes less risky)\n")
} else {
cat(" (becomes more protective over time)\n")
}
}
# Business cycle interpretation
cat("- Business cycle implication: ")
if(var_name == "gdp_growth") {
if(coef_time > 0) {
cat("GDP growth becomes a stronger predictor of bankruptcy avoidance later in a company's lifecycle\n")
} else {
cat("GDP growth is most protective against bankruptcy early in a company's lifecycle\n")
}
} else if(var_name == "unemployement") {
if(coef_time > 0) {
cat("Unemployment has an increasingly detrimental effect on company survival over time\n")
} else {
cat("Unemployment is most harmful to company survival early in a company's lifecycle\n")
}
} else if(var_name == "gdp_deflator") {
if(coef_time > 0) {
cat("Inflation becomes more influential on bankruptcy risk as companies mature\n")
} else {
cat("Inflation has its strongest impact on bankruptcy risk early in a company's lifecycle\n")
}
}
}
}
# For acquisition model
if(length(acquisition_macro_time_terms) > 0) {
cat("\nAcquisition likelihood - Macroeconomic time-dependent effects:\n")
for(term in acquisition_macro_time_terms) {
var_name <- strsplit(term, ":")[[1]][1]
coef_main <- coef(final_acquisition_model)[var_name]
coef_time <- coef(final_acquisition_model)[term]
cat("\n", var_name, ":\n", sep="")
cat("- Base effect (coefficient):", round(coef_main, 4), "\n")
cat("- Time interaction effect:", round(coef_time, 4), "\n")
if(coef_time > 0) {
cat("- Effect interpretation: The impact of", var_name, "on acquisition likelihood INCREASES over time\n")
if(coef_main < 0) {
cat(" (starts reducing acquisition chances but this effect weakens)\n")
} else {
cat(" (becomes more conducive to acquisitions over time)\n")
}
} else {
cat("- Effect interpretation: The impact of", var_name, "on acquisition likelihood DECREASES over time\n")
if(coef_main > 0) {
cat(" (starts increasing acquisition chances but this effect weakens)\n")
} else {
cat(" (becomes less conducive to acquisitions over time)\n")
}
}
# Business cycle interpretation
cat("- Business cycle implication: ")
if(var_name == "gdp_growth") {
if(coef_time > 0) {
cat("Strong economic growth becomes more influential for acquisitions as companies mature\n")
} else {
cat("Economic growth is most influential for acquisitions early in a company's lifecycle\n")
}
} else if(var_name == "unemployement") {
if(coef_time > 0) {
cat("Labor market conditions have increasing influence on acquisition likelihood over time\n")
} else {
cat("Labor market conditions are most influential for acquisitions early in a company's lifecycle\n")
}
} else if(var_name == "gdp_deflator") {
if(coef_time > 0) {
cat("Inflation becomes more influential on acquisition activity as companies mature\n")
} else {
cat("Inflation has its strongest impact on acquisition activity early in a company's lifecycle\n")
}
}
}
}
}
=== ANALYSIS OF TIME-DEPENDENT MACROECONOMIC EFFECTS ===
Acquisition likelihood - Macroeconomic time-dependent effects:
unemployement:
- Base effect (coefficient): -0.1341
- Time interaction effect: 0.0083
- Effect interpretation: The impact of unemployement on acquisition likelihood INCREASES over time
(starts reducing acquisition chances but this effect weakens)
- Business cycle implication: Labor market conditions have increasing influence on acquisition likelihood over time
Probably not relevant to the analysis, but included for completeness!
We double check the proportional hazards assumption for the final models with time-dependent coefficients. We will also check if any remaining violations exist and if the global test supports the PH assumption. We see that for the bankruptcy model, the global test indicates that the PH assumption is satisfied. However, for the acquisition model, the global test indicates that the PH assumption is violated. We will need to investigate further.
#-------------------------------------------------------------
# 10.5: Verify Resolution of PH Violations
#-------------------------------------------------------------
cat("\n10.5: Verify Resolution of PH Violations\n")
10.5: Verify Resolution of PH Violations
cat("--------------------------------------\n")
--------------------------------------
cat("Testing if time-dependent coefficients resolved PH violations...\n")
Testing if time-dependent coefficients resolved PH violations...
# Re-check PH assumption for bankruptcy model with time interactions
if(length(grep(":tt", names(coef(final_bankruptcy_model)))) > 0) {
cat("\nRe-testing PH assumption for bankruptcy model with time interactions:\n")
ph_test_final_bankruptcy <- cox.zph(final_bankruptcy_model)
print(ph_test_final_bankruptcy)
# Check if any remaining violations, separated by variable type
remaining_violators <- rownames(ph_test_final_bankruptcy$table)[
ph_test_final_bankruptcy$table[, "p"] < 0.05 &
rownames(ph_test_final_bankruptcy$table) != "GLOBAL"
]
remaining_fin_violators <- remaining_violators[remaining_violators %in% financial_covariates]
remaining_macro_violators <- remaining_violators[remaining_violators %in% macro_covariates]
cat("\nRemaining financial variables violating PH assumption:\n")
if(length(remaining_fin_violators) > 0) {
print(remaining_fin_violators)
} else {
cat("None - All financial variables now satisfy PH assumption\n")
}
cat("\nRemaining macro variables violating PH assumption:\n")
if(length(remaining_macro_violators) > 0) {
print(remaining_macro_violators)
cat("\nNote: Persistent violations in macro variables may indicate complex business cycle effects\n")
cat("that might require more sophisticated modeling approaches (e.g., stratification or frailty models).\n")
} else {
cat("None - All macro variables now satisfy PH assumption\n")
}
# Check global test
if(ph_test_final_bankruptcy$table["GLOBAL", "p"] < 0.05) {
cat("\nWARNING: Global test still indicates PH violations (p < 0.05).\n")
cat("Further refinements might be needed, especially for economic cycle dynamics.\n")
} else {
cat("\nSUCCESS: Global test now supports the PH assumption (p >= 0.05).\n")
}
}
Re-testing PH assumption for bankruptcy model with time interactions:
chisq df p
LTMTA 0.19069 1 0.66
NIMTA 0.13444 1 0.71
CASHMTA 0.06332 1 0.80
PRICE 0.38656 1 0.53
MBE 0.23326 1 0.63
debt_ratio 0.54167 1 0.46
debt_service 0.35889 1 0.55
current_ratio 1.33523 1 0.25
cash_to_assets 0.19409 1 0.66
wc_ratio 0.00159 1 0.97
gp_margin 0.55629 1 0.46
asset_turnover 0.34848 1 0.55
receivables_turnover 0.02190 1 0.88
intangibility 0.21885 1 0.64
ebit_growth 1.76649 1 0.18
EBIT_VOL_3Y 0.34856 1 0.55
z_score 0.83217 1 0.36
gdp_deflator 0.39755 1 0.53
unemployement 0.27992 1 0.60
gdp_growth 0.65572 1 0.42
LTMTA:tt 0.34389 1 0.56
PRICE:tt 0.56167 1 0.45
debt_ratio:tt 1.85319 1 0.17
GLOBAL 11.03035 23 0.98
Remaining financial variables violating PH assumption:
None - All financial variables now satisfy PH assumption
Remaining macro variables violating PH assumption:
None - All macro variables now satisfy PH assumption
SUCCESS: Global test now supports the PH assumption (p >= 0.05).
# Re-check PH assumption for acquisition model with time interactions
if(length(grep(":tt", names(coef(final_acquisition_model)))) > 0) {
cat("\nRe-testing PH assumption for acquisition model with time interactions:\n")
ph_test_final_acquisition <- cox.zph(final_acquisition_model)
print(ph_test_final_acquisition)
# Check if any remaining violations, separated by variable type
remaining_violators <- rownames(ph_test_final_acquisition$table)[
ph_test_final_acquisition$table[, "p"] < 0.05 &
rownames(ph_test_final_acquisition$table) != "GLOBAL"
]
remaining_fin_violators <- remaining_violators[remaining_violators %in% financial_covariates]
remaining_macro_violators <- remaining_violators[remaining_violators %in% macro_covariates]
cat("\nRemaining financial variables violating PH assumption:\n")
if(length(remaining_fin_violators) > 0) {
print(remaining_fin_violators)
} else {
cat("None - All financial variables now satisfy PH assumption\n")
}
cat("\nRemaining macro variables violating PH assumption:\n")
if(length(remaining_macro_violators) > 0) {
print(remaining_macro_violators)
cat("\nNote: Persistent violations in macro variables may indicate complex business cycle effects\n")
cat("that might require more sophisticated modeling approaches (e.g., stratification or frailty models).\n")
} else {
cat("None - All macro variables now satisfy PH assumption\n")
}
# Check global test
if(ph_test_final_acquisition$table["GLOBAL", "p"] < 0.05) {
cat("\nWARNING: Global test still indicates PH violations (p < 0.05).\n")
cat("Further refinements might be needed, especially for economic cycle dynamics.\n")
} else {
cat("\nSUCCESS: Global test now supports the PH assumption (p >= 0.05).\n")
}
}
Re-testing PH assumption for acquisition model with time interactions:
chisq df p
LTMTA 1.27e-01 1 0.72127
NIMTA 2.31e+00 1 0.12855
PRICE 8.70e+00 1 0.00318
MBE 1.13e+00 1 0.28767
debt_ratio 7.51e-01 1 0.38616
current_ratio 1.55e-04 1 0.99008
cash_to_assets 2.89e-01 1 0.59083
wc_ratio 7.53e-01 1 0.38546
gp_margin 6.45e+00 1 0.01112
asset_turnover 5.78e+00 1 0.01616
receivables_turnover 9.36e-01 1 0.33341
EBIT_VOL_3Y 1.12e+01 1 0.00081
gdp_deflator 5.75e+00 1 0.01652
unemployement 1.11e+01 1 0.00089
gdp_growth 7.10e+00 1 0.00770
unemployement:tt 1.74e+01 1 3.1e-05
wc_ratio:tt 1.42e+00 1 0.23271
asset_turnover:tt 9.55e+00 1 0.00200
GLOBAL 8.44e+01 18 1.4e-10
Remaining financial variables violating PH assumption:
[1] "PRICE" "gp_margin" "asset_turnover" "EBIT_VOL_3Y"
Remaining macro variables violating PH assumption:
[1] "gdp_deflator" "unemployement" "gdp_growth"
Note: Persistent violations in macro variables may indicate complex business cycle effects
that might require more sophisticated modeling approaches (e.g., stratification or frailty models).
WARNING: Global test still indicates PH violations (p < 0.05).
Further refinements might be needed, especially for economic cycle dynamics.
We compare the model fit of the final models with time-dependent coefficients to the original models without time interactions. We will look at AIC, BIC, concordance, and perform a likelihood ratio test to see if the addition of time interactions improved the model fit.
#-------------------------------------------------------------
# 10.6: Compare Model Fit Before and After Time Interactions
#-------------------------------------------------------------
cat("\n10.6: Compare Model Fit Before and After Time Interactions\n")
10.6: Compare Model Fit Before and After Time Interactions
cat("--------------------------------------\n")
--------------------------------------
# Compare bankruptcy models
if(length(grep(":tt", names(coef(final_bankruptcy_model)))) > 0) {
cat("Comparing bankruptcy models before and after adding time interactions:\n")
original_model <- best_models$bankruptcy$model
# Compare AIC
aic_original <- AIC(original_model)
aic_final <- AIC(final_bankruptcy_model)
# Compare BIC
bic_original <- BIC(original_model)
bic_final <- BIC(final_bankruptcy_model)
# Compare concordance
conc_original <- original_model$concordance["concordance"]
conc_final <- final_bankruptcy_model$concordance["concordance"]
# Likelihood ratio test
lr_test <- anova(original_model, final_bankruptcy_model)
cat("AIC: Original =", round(aic_original, 2), "vs. With time interactions =", round(aic_final, 2),
ifelse(aic_final < aic_original, " (improved)", " (not improved)"), "\n")
cat("BIC: Original =", round(bic_original, 2), "vs. With time interactions =", round(bic_final, 2),
ifelse(bic_final < bic_original, " (improved)", " (not improved)"), "\n")
cat("Concordance: Original =", round(conc_original, 4), "vs. With time interactions =", round(conc_final, 4),
ifelse(conc_final > conc_original, " (improved)", " (not improved)"), "\n")
cat("Likelihood ratio test:\n")
print(lr_test)
# Check how many time interactions are for macro variables
macro_time_terms <- grep(":tt", names(coef(final_bankruptcy_model)), value = TRUE)
macro_time_terms <- macro_time_terms[sapply(macro_time_terms, function(term) {
var_name <- strsplit(term, ":")[[1]][1]
return(var_name %in% macro_covariates)
})]
if(length(macro_time_terms) > 0) {
cat("\nContribution of macro variable time interactions:\n")
# Create a model with only financial time interactions
no_macro_time_formula <- formula(final_bankruptcy_model)
for(term in macro_time_terms) {
no_macro_time_formula <- update(no_macro_time_formula, paste0(". ~ . - ", term))
}
no_macro_time_model <- coxph(no_macro_time_formula, data = data, ties = "efron")
# Compare with full model
macro_time_lr_test <- anova(no_macro_time_model, final_bankruptcy_model)
cat("Likelihood ratio test for macro variable time interactions:\n")
print(macro_time_lr_test)
if(macro_time_lr_test[2, "Pr(>|Chi|)"] < 0.05) {
cat("The time-varying effects of macroeconomic variables significantly improve the model (p < 0.05).\n")
} else {
cat("The time-varying effects of macroeconomic variables do not significantly improve the model (p >= 0.05).\n")
}
}
}
Comparing bankruptcy models before and after adding time interactions:
AIC: Original = 1596.41 vs. With time interactions = 1593.76 (improved)
BIC: Original = 1659.82 vs. With time interactions = 1666.68 (not improved)
Concordance: Original = 0.864 vs. With time interactions = 0.8636 (not improved)
Likelihood ratio test:
Analysis of Deviance Table
Cox model: response is Surv(tstart, tstop, bankruptcy)
Model 1: ~ LTMTA + NIMTA + CASHMTA + PRICE + MBE + debt_ratio + debt_service + current_ratio + cash_to_assets + wc_ratio + gp_margin + asset_turnover + receivables_turnover + intangibility + ebit_growth + EBIT_VOL_3Y + z_score + gdp_deflator + unemployement + gdp_growth + strata(gsector)
Model 2: ~ LTMTA + NIMTA + CASHMTA + PRICE + MBE + debt_ratio + debt_service + current_ratio + cash_to_assets + wc_ratio + gp_margin + asset_turnover + receivables_turnover + intangibility + ebit_growth + EBIT_VOL_3Y + z_score + gdp_deflator + unemployement + gdp_growth + strata(gsector) + LTMTA:tt + PRICE:tt + debt_ratio:tt
loglik Chisq Df Pr(>|Chi|)
1 -778.20
2 -773.88 8.6503 3 0.03432 *
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
# Compare acquisition models
if(length(grep(":tt", names(coef(final_acquisition_model)))) > 0) {
cat("\nComparing acquisition models before and after adding time interactions:\n")
original_model <- best_models$acquisition$model
# Compare AIC
aic_original <- AIC(original_model)
aic_final <- AIC(final_acquisition_model)
# Compare BIC
bic_original <- BIC(original_model)
bic_final <- BIC(final_acquisition_model)
# Compare concordance
conc_original <- original_model$concordance["concordance"]
conc_final <- final_acquisition_model$concordance["concordance"]
# Likelihood ratio test
lr_test <- anova(original_model, final_acquisition_model)
cat("AIC: Original =", round(aic_original, 2), "vs. With time interactions =", round(aic_final, 2),
ifelse(aic_final < aic_original, " (improved)", " (not improved)"), "\n")
cat("BIC: Original =", round(bic_original, 2), "vs. With time interactions =", round(bic_final, 2),
ifelse(bic_final < bic_original, " (improved)", " (not improved)"), "\n")
cat("Concordance: Original =", round(conc_original, 4), "vs. With time interactions =", round(conc_final, 4),
ifelse(conc_final > conc_original, " (improved)", " (not improved)"), "\n")
cat("Likelihood ratio test:\n")
print(lr_test)
# Check how many time interactions are for macro variables
macro_time_terms <- grep(":tt", names(coef(final_acquisition_model)), value = TRUE)
macro_time_terms <- macro_time_terms[sapply(macro_time_terms, function(term) {
var_name <- strsplit(term, ":")[[1]][1]
return(var_name %in% macro_covariates)
})]
if(length(macro_time_terms) > 0) {
cat("\nContribution of macro variable time interactions:\n")
# Create a model with only financial time interactions
no_macro_time_formula <- formula(final_acquisition_model)
for(term in macro_time_terms) {
no_macro_time_formula <- update(no_macro_time_formula, paste0(". ~ . - ", term))
}
no_macro_time_model <- coxph(no_macro_time_formula, data = data, ties = "efron")
# Compare with full model
macro_time_lr_test <- anova(no_macro_time_model, final_acquisition_model)
cat("Likelihood ratio test for macro variable time interactions:\n")
print(macro_time_lr_test)
if(macro_time_lr_test[2, "Pr(>|Chi|)"] < 0.05) {
cat("The time-varying effects of macroeconomic variables significantly improve the model (p < 0.05).\n")
} else {
cat("The time-varying effects of macroeconomic variables do not significantly improve the model (p >= 0.05).\n")
}
}
}
Comparing acquisition models before and after adding time interactions:
AIC: Original = 24293.78 vs. With time interactions = 24259.44 (improved)
BIC: Original = 24378.91 vs. With time interactions = 24361.59 (improved)
Concordance: Original = 0.6379 vs. With time interactions = 0.6428 (improved)
Likelihood ratio test:
Analysis of Deviance Table
Cox model: response is Surv(tstart, tstop, acquisition)
Model 1: ~ LTMTA + NIMTA + PRICE + MBE + debt_ratio + current_ratio + cash_to_assets + wc_ratio + gp_margin + asset_turnover + receivables_turnover + EBIT_VOL_3Y + gdp_deflator + unemployement + gdp_growth + strata(gsector)
Model 2: ~ LTMTA + NIMTA + PRICE + MBE + debt_ratio + current_ratio + cash_to_assets + wc_ratio + gp_margin + asset_turnover + receivables_turnover + EBIT_VOL_3Y + gdp_deflator + unemployement + gdp_growth + strata(gsector) + unemployement:tt + wc_ratio:tt + asset_turnover:tt
loglik Chisq Df Pr(>|Chi|)
1 -12132
2 -12112 40.34 3 9.025e-09 ***
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
Contribution of macro variable time interactions:
Likelihood ratio test for macro variable time interactions:
Analysis of Deviance Table
Cox model: response is Surv(tstart, tstop, acquisition)
Model 1: ~ LTMTA + NIMTA + PRICE + MBE + debt_ratio + current_ratio + cash_to_assets + wc_ratio + gp_margin + asset_turnover + receivables_turnover + EBIT_VOL_3Y + gdp_deflator + unemployement + gdp_growth + strata(gsector) + wc_ratio:tt + asset_turnover:tt
Model 2: ~ LTMTA + NIMTA + PRICE + MBE + debt_ratio + current_ratio + cash_to_assets + wc_ratio + gp_margin + asset_turnover + receivables_turnover + EBIT_VOL_3Y + gdp_deflator + unemployement + gdp_growth + strata(gsector) + unemployement:tt + wc_ratio:tt + asset_turnover:tt
loglik Chisq Df Pr(>|Chi|)
1 -12120
2 -12112 17.126 1 3.499e-05 ***
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
The time-varying effects of macroeconomic variables significantly improve the model (p < 0.05).
Again, included only for sake of completeness!
Finally, we will visualize the time-varying effects of the macroeconomic variables in both models. We will create plots that show how the hazard ratios change over time for different reference values of the macroeconomic variables. This will help us understand the dynamic nature of these effects and their implications for business cycles. You can also see all the time-varying effects of the macroeconomic variables in the final models. We will create plots that show how the hazard ratios change over time for different reference values of the macroeconomic variables. This will help us understand the dynamic nature of these effects and their implications for business cycles.
# Function to create enhanced visualization of time-varying effects
visualize_time_varying_effects <- function(model, model_name) {
cat("Visualizing time-varying effects for", model_name, "model...\n")
# Extract coefficients
coefs <- coef(model)
# Identify time interaction terms
time_terms <- names(coefs)[grepl(":tt", names(coefs))]
if(length(time_terms) == 0) {
cat("No time-varying effects found in the", model_name, "model.\n")
return(NULL)
}
# Extract base variable names
main_terms <- unique(sapply(strsplit(time_terms, ":"), `[`, 1))
# Separate financial and macro variables
macro_vars <- c("gdp_growth", "gdp_deflator", "unemployement")
fin_vars <- main_terms[!main_terms %in% macro_vars]
macro_terms <- main_terms[main_terms %in% macro_vars]
cat("Identified", length(fin_vars), "financial variables with time-varying effects:\n")
if(length(fin_vars) > 0) cat(paste(fin_vars, collapse = ", "), "\n\n")
cat("Identified", length(macro_terms), "macroeconomic variables with time-varying effects:\n")
if(length(macro_terms) > 0) cat(paste(macro_terms, collapse = ", "), "\n\n")
# Process all variables with time-varying effects
all_vars <- list(
Financial = fin_vars,
Macro = macro_terms
)
# Create mapping for variable names to descriptive labels
var_labels <- list(
"LTMTA" = "Liabilities-to-Market Value\n(Higher = More Leverage)",
"NIMTA" = "Net Income-to-Market Value\n(Higher = Better Profitability)",
"CASHMTA" = "Cash-to-Market Value\n(Higher = More Liquidity)",
"PRICE" = "Stock Price\n(Higher = Better Market Perception)",
"MBE" = "Market-to-Book Equity\n(Higher = Growth Expectations)",
"RSIZE" = "Relative Size\n(Higher = Larger Company)",
"debt_ratio" = "Debt Ratio\n(Higher = More Leverage)",
"current_ratio" = "Current Ratio\n(Higher = Better Liquidity)",
"quick_ratio" = "Quick Ratio\n(Higher = Better Liquidity)",
"z_score" = "Altman Z-Score\n(Higher = Lower Bankruptcy Risk)",
"gdp_growth" = "GDP Growth\n(Higher = Stronger Economy)",
"gdp_deflator" = "GDP Deflator\n(Higher = Higher Inflation)",
"unemployement" = "Unemployment Rate\n(Higher = Weaker Labor Market)"
)
# Process variables by category
for(var_type in names(all_vars)) {
variables <- all_vars[[var_type]]
if(length(variables) == 0) next
cat("\nVisualizing", tolower(var_type), "variable time effects:\n")
# Create multi-panel layout for overview plots
n_vars <- length(variables)
n_cols <- min(2, n_vars)
n_rows <- ceiling(n_vars / n_cols)
par(mfrow = c(n_rows, n_cols), mar = c(4, 4, 3, 1) + 0.1)
# Create overview plots for each variable
for(var in variables) {
cat(" -", var, "\n")
# Get coefficients
main_coef <- coefs[var]
time_coef <- coefs[paste0(var, ":tt")]
# Set up time sequence
max_time <- max(data$tstop)
times <- seq(0, max_time, length.out = 100)
# Calculate hazard ratios for 1-unit change in the variable over time
hrs <- exp(main_coef + time_coef * times)
# Get descriptive label for the variable
var_title <- if(var %in% names(var_labels)) var_labels[[var]] else var
# Create plot
plot(times, hrs, type = "l", lwd = 2, col = "darkblue",
main = var_title,
xlab = "Time (Years)", ylab = "Hazard Ratio",
ylim = c(min(0.5, min(hrs)), max(2, max(hrs))))
# Add reference line at HR = 1
abline(h = 1, lty = 2, col = "darkgray")
# Add grid for readability
grid()
# Calculate and mark crossover point (if any)
if(sign(main_coef) != sign(time_coef) && time_coef != 0) {
crossover <- -main_coef / time_coef
if(crossover > 0 && crossover < max(times)) {
points(crossover, 1, pch = 16, col = "red", cex = 1.5)
text(crossover, 1.1, paste("Crossover at", round(crossover, 1), "years"),
col = "red", cex = 0.8)
}
}
# Color the line based on the current effect direction
points(times[1], hrs[1], pch = 16, col = ifelse(hrs[1] > 1, "red", "green4"), cex = 1.2)
points(times[length(times)], hrs[length(times)], pch = 16,
col = ifelse(hrs[length(times)] > 1, "red", "green4"), cex = 1.2)
# Add time effect interpretation
direction <- ifelse(main_coef > 0, "increases", "decreases")
change <- ifelse(sign(main_coef) == sign(time_coef), "strengthens", "weakens")
mtext(paste0("Effect ", change, " over time"), side = 3, line = 0.5, cex = 0.7,
col = ifelse(change == "strengthens", "darkred", "darkblue"))
# Add business insights based on variable type
if(var_type == "Financial") {
add_financial_insights(var, model_name, change, times, hrs, max_time)
} else {
add_macro_insights(var, model_name, change, times, hrs, max_time)
}
}
# Reset plotting parameters
par(mfrow = c(1, 1), mar = c(5, 4, 4, 2) + 0.1)
# Create detailed plots with quantile-based reference values for each variable
for(var in variables) {
create_detailed_plot(model, var, var_type, model_name, var_labels)
}
}
# Find and highlight the most important time-varying variable
if(length(main_terms) > 0) {
# Find the variable with largest absolute time coefficient
abs_time_coefs <- abs(coefs[paste0(main_terms, ":tt")])
most_important_idx <- which.max(abs_time_coefs)
most_important_var <- main_terms[most_important_idx]
most_important_type <- if(most_important_var %in% macro_vars) "Macro" else "Financial"
cat("\nMost important time-varying variable:", most_important_var, "(", most_important_type, ")\n")
cat("Creating enhanced visualization for most important variable...\n")
# Create enhanced plot with business insights for most important variable
create_enhanced_plot(model, most_important_var, most_important_type, model_name, var_labels)
}
cat("Time-varying effects visualization completed for", model_name, "model.\n")
}
# Helper function to add financial insights to plots
add_financial_insights <- function(var, model_name, change, times, hrs, max_time) {
y_pos <- ifelse(hrs[length(times)] > hrs[1], 0.85 * max(hrs), 0.5)
# Add financial insight based on variable and model type
if(var == "LTMTA" || var == "debt_ratio") {
if(model_name == "Bankruptcy") {
if(change == "weakens") {
text(max_time * 0.5, y_pos, "Leverage matters\nmost for young firms",
cex = 0.7, col = "darkred")
} else {
text(max_time * 0.5, y_pos, "Leverage becomes\nmore risky with age",
cex = 0.7, col = "darkred")
}
} else { # Acquisition
if(change == "weakens") {
text(max_time * 0.5, y_pos, "Acquirers focus on\ndebt early in lifecycle",
cex = 0.7, col = "darkred")
} else {
text(max_time * 0.5, y_pos, "Maturity increases\nleverage significance",
cex = 0.7, col = "darkred")
}
}
} else if(var == "NIMTA") {
if(model_name == "Bankruptcy") {
if(change == "weakens") {
text(max_time * 0.5, y_pos, "Profitability matters\nmost for young firms",
cex = 0.7, col = "darkred")
} else {
text(max_time * 0.5, y_pos, "Profitability becomes\nmore critical with age",
cex = 0.7, col = "darkred")
}
}
} else if(var == "CASHMTA" || var == "current_ratio" || var == "quick_ratio") {
if(model_name == "Bankruptcy") {
if(change == "weakens") {
text(max_time * 0.5, y_pos, "Liquidity most\ncritical early on",
cex = 0.7, col = "darkred")
} else {
text(max_time * 0.5, y_pos, "Liquidity becomes\nmore important with age",
cex = 0.7, col = "darkred")
}
} else { # Acquisition
if(change == "weakens") {
text(max_time * 0.5, y_pos, "Cash attracts acquirers\nmost in early years",
cex = 0.7, col = "darkred")
} else {
text(max_time * 0.5, y_pos, "Cash becomes more\nattractive with maturity",
cex = 0.7, col = "darkred")
}
}
} else if(var == "z_score") {
if(model_name == "Bankruptcy") {
if(change == "weakens") {
text(max_time * 0.5, y_pos, "Z-score most predictive\nfor young firms",
cex = 0.7, col = "darkred")
} else {
text(max_time * 0.5, y_pos, "Z-score becomes more\npredictive with age",
cex = 0.7, col = "darkred")
}
}
}
}
# Helper function to add macroeconomic insights to plots
add_macro_insights <- function(var, model_name, change, times, hrs, max_time) {
y_pos <- ifelse(hrs[length(times)] > hrs[1], 0.85 * max(hrs), 0.5)
# Add macro insight based on variable and model type
if(var == "gdp_growth") {
if(model_name == "Bankruptcy") {
if(change == "weakens") {
text(max_time * 0.5, y_pos, "Economic growth most\nprotective for new firms",
cex = 0.7, col = "darkred")
} else {
text(max_time * 0.5, y_pos, "Growth protection\nincreases with firm age",
cex = 0.7, col = "darkred")
}
} else { # Acquisition
if(change == "weakens") {
text(max_time * 0.5, y_pos, "Growth spurs acquisitions\nmore for young firms",
cex = 0.7, col = "darkred")
} else {
text(max_time * 0.5, y_pos, "Growth effect on M&A\nincreases with age",
cex = 0.7, col = "darkred")
}
}
} else if(var == "unemployement") {
if(model_name == "Bankruptcy") {
if(change == "weakens") {
text(max_time * 0.5, y_pos, "High unemployment most\ndangerous for new firms",
cex = 0.7, col = "darkred")
} else {
text(max_time * 0.5, y_pos, "Labor market impact\nincreases over time",
cex = 0.7, col = "darkred")
}
}
} else if(var == "gdp_deflator") {
if(model_name == "Bankruptcy") {
if(change == "weakens") {
text(max_time * 0.5, y_pos, "Inflation most impactful\nfor young companies",
cex = 0.7, col = "darkred")
} else {
text(max_time * 0.5, y_pos, "Inflation sensitivity\nincreases with age",
cex = 0.7, col = "darkred")
}
}
}
}
# Helper function to create detailed plots with quantile-based reference values
create_detailed_plot <- function(model, var_name, var_type, model_name, var_labels) {
# Extract coefficients
coefs <- coef(model)
main_coef <- coefs[var_name]
time_coef <- coefs[paste0(var_name, ":tt")]
# Get descriptive label
var_label <- if(var_name %in% names(var_labels)) var_labels[[var_name]] else var_name
var_label <- strsplit(var_label, "\n")[[1]][1] # Just use first line
# Create sequence of time points
max_time <- max(data$tstop)
time_points <- seq(0, max_time, by = 0.1)
# Get variable distribution for reference values
if(var_name %in% colnames(data)) {
q25 <- quantile(data[[var_name]], 0.25, na.rm = TRUE)
q50 <- quantile(data[[var_name]], 0.50, na.rm = TRUE)
q75 <- quantile(data[[var_name]], 0.75, na.rm = TRUE)
# Calculate hazard ratios for each reference value over time
hr_q25 <- exp((main_coef + time_coef * time_points) * q25)
hr_q50 <- exp((main_coef + time_coef * time_points) * q50)
hr_q75 <- exp((main_coef + time_coef * time_points) * q75)
# Plot title
if(var_type == "Macro") {
title <- paste("Time-Varying Economic Effect of", var_label)
} else {
title <- paste("Time-Varying Effect of", var_label, "on", model_name, "Risk")
}
# Create plot
plot(time_points, hr_q50, type = "l", lwd = 2, col = "blue",
main = title,
xlab = "Time (Years)", ylab = "Hazard Ratio",
ylim = c(min(0.5, min(hr_q25, hr_q50, hr_q75, na.rm = TRUE)),
max(2, max(hr_q25, hr_q50, hr_q75, na.rm = TRUE))))
# Add lines for other quantiles
lines(time_points, hr_q25, lwd = 2, col = "green3", lty = 2)
lines(time_points, hr_q75, lwd = 2, col = "red", lty = 2)
# Add reference line at HR = 1
abline(h = 1, lty = 3, col = "darkgray")
# Add grid
grid()
# Add legend
legend("topright",
legend = c(paste("25th percentile (", round(q25, 2), ")", sep = ""),
paste("Median (", round(q50, 2), ")", sep = ""),
paste("75th percentile (", round(q75, 2), ")", sep = "")),
col = c("green3", "blue", "red"),
lty = c(2, 1, 2),
lwd = 2,
bty = "n")
# Add crossover point if it exists
if(sign(main_coef) != sign(time_coef) && time_coef != 0) {
crossover <- -main_coef / time_coef
if(crossover > 0 && crossover < max(time_points)) {
abline(v = crossover, lty = 2, col = "purple")
text(crossover, par("usr")[3] + 0.1 * diff(par("usr")[3:4]),
paste("Effect reverses at\n", round(crossover, 1), "years"),
col = "purple")
}
}
# Add variable-specific interpretation
add_variable_interpretation(var_name, var_type, model_name, time_coef)
}
}
# Helper function for enhanced plot of most important variable
create_enhanced_plot <- function(model, var_name, var_type, model_name, var_labels) {
# Extract coefficients
coefs <- coef(model)
main_coef <- coefs[var_name]
time_coef <- coefs[paste0(var_name, ":tt")]
# Get variable range from data
if(var_name %in% colnames(data)) {
var_mean <- mean(data[[var_name]], na.rm = TRUE)
var_sd <- sd(data[[var_name]], na.rm = TRUE)
# Calculate representative values
var_low <- max(0, var_mean - var_sd) # Ensure non-negative for ratios
var_high <- var_mean + var_sd
var_median <- median(data[[var_name]], na.rm = TRUE)
# Set up time sequence
max_time <- max(data$tstop)
times <- seq(0, max_time, length.out = 100)
# Calculate HR for different variable values
hr_low <- exp((main_coef + time_coef * times) * var_low)
hr_median <- exp((main_coef + time_coef * times) * var_median)
hr_high <- exp((main_coef + time_coef * times) * var_high)
# Get descriptive label
var_label <- if(var_name %in% names(var_labels)) {
strsplit(var_labels[[var_name]], "\n")[[1]][1] # Just use first line
} else {
var_name
}
# Create enhanced plot
plot(times, hr_median, type = "l", lwd = 2, col = "blue",
main = paste("Detailed Time-Varying Effect of", var_label, "on", model_name, "Risk"),
xlab = "Time (Years)", ylab = "Hazard Ratio",
ylim = c(min(0.5, min(hr_low, hr_median, hr_high, na.rm = TRUE)),
max(2, max(hr_low, hr_median, hr_high, na.rm = TRUE))))
# Add lines for low and high values
lines(times, hr_low, lwd = 2, col = "green3", lty = 2)
lines(times, hr_high, lwd = 2, col = "red", lty = 2)
# Add reference line at HR = 1
abline(h = 1, lty = 3, col = "darkgray")
# Add grid
grid()
# Add legend
legend("topright",
legend = c(paste("Low", var_name, "(", round(var_low, 2), ")"),
paste("Median", var_name, "(", round(var_median, 2), ")"),
paste("High", var_name, "(", round(var_high, 2), ")")),
col = c("green3", "blue", "red"),
lty = c(2, 1, 2),
lwd = 2,
bty = "n")
# Add crossover point if any
if(sign(main_coef) != sign(time_coef) && time_coef != 0) {
crossover <- -main_coef / time_coef
if(crossover > 0 && crossover < max(times)) {
abline(v = crossover, lty = 2, col = "purple")
text(crossover, par("usr")[3] + 0.1 * diff(par("usr")[3:4]),
paste("Effect reverses at\n", round(crossover, 1), "years"),
col = "purple")
}
}
# Add detailed business interpretation
add_detailed_interpretation(var_name, var_type, model_name, time_coef)
}
}
# Helper function to add variable-specific interpretation
add_variable_interpretation <- function(var_name, var_type, model_name, time_coef) {
if(var_type == "Macro") {
if(var_name == "gdp_growth") {
if(time_coef > 0) {
mtext("Economic growth effect strengthens over time",
side = 3, line = 0.5, cex = 0.8)
} else {
mtext("Economic growth effect weakens over time",
side = 3, line = 0.5, cex = 0.8)
}
} else if(var_name == "unemployement") {
if(time_coef > 0) {
mtext("Labor market effect strengthens over time",
side = 3, line = 0.5, cex = 0.8)
} else {
mtext("Labor market effect weakens over time",
side = 3, line = 0.5, cex = 0.8)
}
} else if(var_name == "gdp_deflator") {
if(time_coef > 0) {
mtext("Inflation effect strengthens over time",
side = 3, line = 0.5, cex = 0.8)
} else {
mtext("Inflation effect weakens over time",
side = 3, line = 0.5, cex = 0.8)
}
}
} else { # Financial variables
if(var_name == "LTMTA" || var_name == "debt_ratio") {
if(model_name == "Bankruptcy") {
if(time_coef > 0) {
mtext("Leverage becomes increasingly risky as companies mature",
side = 3, line = 0.5, cex = 0.8)
} else {
mtext("Leverage is most dangerous for young companies",
side = 3, line = 0.5, cex = 0.8)
}
}
} else if(var_name == "NIMTA") {
if(model_name == "Bankruptcy") {
if(time_coef > 0) {
mtext("Profitability becomes more protective with age",
side = 3, line = 0.5, cex = 0.8)
} else {
mtext("Profitability is most protective for young companies",
side = 3, line = 0.5, cex = 0.8)
}
}
} else if(var_name == "CASHMTA") {
if(model_name == "Bankruptcy") {
if(time_coef > 0) {
mtext("Cash holdings become more important with company age",
side = 3, line = 0.5, cex = 0.8)
} else {
mtext("Cash is most critical for young company survival",
side = 3, line = 0.5, cex = 0.8)
}
} else if(model_name == "Acquisition") {
if(time_coef > 0) {
mtext("Cash becomes more attractive to acquirers as companies mature",
side = 3, line = 0.5, cex = 0.8)
} else {
mtext("Cash makes young companies more attractive acquisition targets",
side = 3, line = 0.5, cex = 0.8)
}
}
}
}
}
# Helper function to add detailed interpretation for the enhanced plot
add_detailed_interpretation <- function(var_name, var_type, model_name, time_coef) {
if(var_type == "Macro") {
if(var_name == "gdp_growth") {
if(model_name == "Bankruptcy") {
if(time_coef > 0) {
mtext("INSIGHT: Mature firms become increasingly sensitive to economic conditions",
side = 3, line = 0.5, cex = 0.9, col = "darkblue")
mtext("Firms may develop greater economic exposure as they age",
side = 3, line = 1.5, cex = 0.8)
} else {
mtext("INSIGHT: Young firms are more vulnerable to economic downturns",
side = 3, line = 0.5, cex = 0.9, col = "darkblue")
mtext("New businesses have less buffer against poor economic conditions",
side = 3, line = 1.5, cex = 0.8)
}
} else { # Acquisition
if(time_coef > 0) {
mtext("INSIGHT: Economic growth increasingly drives acquisition activity for mature firms",
side = 3, line = 0.5, cex = 0.9, col = "darkblue")
} else {
mtext("INSIGHT: Young companies are more likely acquisition targets during economic upswings",
side = 3, line = 0.5, cex = 0.9, col = "darkblue")
}
}
} else if(var_name == "unemployement") {
if(model_name == "Bankruptcy") {
if(time_coef > 0) {
mtext("INSIGHT: Labor market conditions become more critical for mature firms",
side = 3, line = 0.5, cex = 0.9, col = "darkblue")
} else {
mtext("INSIGHT: High unemployment most threatens young firms' survival",
side = 3, line = 0.5, cex = 0.9, col = "darkblue")
}
}
}
} else { # Financial variables
if(var_name == "LTMTA" || var_name == "debt_ratio") {
if(model_name == "Bankruptcy") {
if(time_coef > 0) {
mtext("INSIGHT: Debt burden becomes increasingly problematic as firms mature",
side = 3, line = 0.5, cex = 0.9, col = "darkblue")
mtext("Debt sustainability concerns grow over company lifecycle",
side = 3, line = 1.5, cex = 0.8)
} else {
mtext("INSIGHT: Early-stage leverage poses greatest bankruptcy risk",
side = 3, line = 0.5, cex = 0.9, col = "darkblue")
mtext("Young firms have less capacity to service debt obligations",
side = 3, line = 1.5, cex = 0.8)
}
}
} else if(var_name == "NIMTA" || var_name == "z_score") {
if(model_name == "Bankruptcy") {
if(time_coef > 0) {
mtext("INSIGHT: Financial health metrics gain predictive power over company lifecycle",
side = 3, line = 0.5, cex = 0.9, col = "darkblue")
} else {
mtext("INSIGHT: Strong financials most critical for survival in early years",
side = 3, line = 0.5, cex = 0.9, col = "darkblue")
}
}
}
}
}
# Execute visualization for bankruptcy model
visualize_time_varying_effects(final_bankruptcy_model, "Bankruptcy")
Visualizing time-varying effects for Bankruptcy model...
Identified 3 financial variables with time-varying effects:
LTMTA, PRICE, debt_ratio
Identified 0 macroeconomic variables with time-varying effects:
Visualizing financial variable time effects:
- LTMTA
- PRICE
- debt_ratio
Most important time-varying variable: LTMTA ( Financial )
Creating enhanced visualization for most important variable...
Time-varying effects visualization completed for Bankruptcy model.
# Execute visualization for acquisition model
visualize_time_varying_effects(final_acquisition_model, "Acquisition")
Visualizing time-varying effects for Acquisition model...
Identified 2 financial variables with time-varying effects:
wc_ratio, asset_turnover
Identified 1 macroeconomic variables with time-varying effects:
unemployement
Visualizing financial variable time effects:
- wc_ratio
- asset_turnover
Visualizing macro variable time effects:
- unemployement
Most important time-varying variable: wc_ratio ( Financial )
Creating enhanced visualization for most important variable...
Time-varying effects visualization completed for Acquisition model.
# Save final model information with time-varying effects data
final_models_with_time_effects <- list(
bankruptcy = list(
model = final_bankruptcy_model,
time_terms = grep(":tt", names(coef(final_bankruptcy_model)), value = TRUE),
fin_time_vars = intersect(
sapply(strsplit(grep(":tt", names(coef(final_bankruptcy_model)), value = TRUE), ":"), `[`, 1),
financial_covariates
),
macro_time_vars = intersect(
sapply(strsplit(grep(":tt", names(coef(final_bankruptcy_model)), value = TRUE), ":"), `[`, 1),
macro_covariates
),
ph_test = if(exists("ph_test_final_bankruptcy")) ph_test_final_bankruptcy else NULL
),
acquisition = list(
model = final_acquisition_model,
time_terms = grep(":tt", names(coef(final_acquisition_model)), value = TRUE),
fin_time_vars = intersect(
sapply(strsplit(grep(":tt", names(coef(final_acquisition_model)), value = TRUE), ":"), `[`, 1),
financial_covariates
),
macro_time_vars = intersect(
sapply(strsplit(grep(":tt", names(coef(final_acquisition_model)), value = TRUE), ":"), `[`, 1),
macro_covariates
),
ph_test = if(exists("ph_test_final_acquisition")) ph_test_final_acquisition else NULL
)
)
Now we will create a function to analyze the hazard ratios and confidence intervals for the final models, including time-varying effects. We do this by extracting the coefficients and confidence intervals from the models, and then formatting them into a readable table. We will also categorize the variables into financial and macroeconomic categories for better interpretation.
#-------------------------------------------------------------
# 11.1: Hazard Ratios and Confidence Intervals (Improved)
#-------------------------------------------------------------
cat("\n11.1: HAZARD RATIOS WITH CONFIDENCE INTERVALS\n")
11.1: HAZARD RATIOS WITH CONFIDENCE INTERVALS
cat("--------------------------------------\n")
--------------------------------------
# Function to calculate and display hazard ratios in a meaningful way
analyze_hazard_ratios <- function(model, model_name) {
# Get coefficient estimates and confidence intervals
coefs <- summary(model)$coefficients
conf_int <- confint(model)
# Combine into a single matrix and convert to hazard ratios
hr_matrix <- data.frame(
"Variable" = rownames(coefs),
"Coefficient" = coefs[, "coef"],
"Hazard_Ratio" = exp(coefs[, "coef"]),
"Lower_CI" = exp(conf_int[, 1]),
"Upper_CI" = exp(conf_int[, 2]),
"P_value" = coefs[, "Pr(>|z|)"],
stringsAsFactors = FALSE
)
# Separate main effects from time interactions
main_effects <- hr_matrix[!grepl(":tt", hr_matrix$Variable), ]
time_effects <- hr_matrix[grepl(":tt", hr_matrix$Variable), ]
# Add variable type classification
main_effects$Type <- "Other"
# Identify financial variables by category
financial_categories <- list(
"Solvency" = c("LTMTA", "debt_ratio", "debt_service", "z_score"),
"Liquidity" = c("CASHMTA", "current_ratio", "cash_to_assets", "wc_ratio", "quick_ratio"),
"Profitability" = c("NIMTA", "ebit_margin", "gp_margin", "asset_turnover", "ebit_growth"),
"Market" = c("PRICE", "MBE", "RSIZE", "l_mkvalt"),
"Other_Financial" = c("receivables_turnover", "intangibility", "EBIT_VOL_3Y", "l_at")
)
# Assign financial categories
for(category_name in names(financial_categories)) {
main_effects$Type[main_effects$Variable %in% financial_categories[[category_name]]] <- category_name
}
# Identify macro variables
macro_categories <- list(
"Economic_Growth" = c("gdp_growth"),
"Inflation" = c("gdp_deflator"),
"Labor_Market" = c("unemployement")
)
# Assign macro categories
for(category_name in names(macro_categories)) {
main_effects$Type[main_effects$Variable %in% macro_categories[[category_name]]] <- category_name
}
# Print results by category - Financial variables first
cat("\n=== HAZARD RATIOS FOR", toupper(model_name), "MODEL ===\n\n")
cat("FINANCIAL VARIABLES:\n")
cat("====================\n\n")
financial_categories_print <- c("Solvency", "Liquidity", "Profitability", "Market", "Other_Financial")
for(category_name in financial_categories_print) {
cat(gsub("_", " ", category_name), "Measures:\n")
cat(paste(rep("-", nchar(gsub("_", " ", category_name)) + 10), collapse = ""), "\n")
# Get variables in this category
category_rows <- main_effects[main_effects$Type == category_name, ]
if(nrow(category_rows) == 0) {
cat("No variables from this category in the model.\n\n")
next
}
# Sort by p-value for presentation
category_rows <- category_rows[order(category_rows$P_value), ]
# Print each variable in this category
for(i in 1:nrow(category_rows)) {
var <- category_rows$Variable[i]
hr <- category_rows$Hazard_Ratio[i]
p_val <- category_rows$P_value[i]
ci_lower <- category_rows$Lower_CI[i]
ci_upper <- category_rows$Upper_CI[i]
# Determine effect direction and significance
if(p_val < 0.01) {
significance <- "strongly significantly"
} else if(p_val < 0.05) {
significance <- "significantly"
} else if(p_val < 0.1) {
significance <- "marginally significantly"
} else {
significance <- "not significantly"
}
direction <- ifelse(hr > 1, "increases", "decreases")
# Calculate percentage change
if(hr < 1) {
pct_change <- (1 - hr) * 100
effect <- paste0(significance, " decreases ", model_name, " risk by ", round(pct_change, 1), "%")
} else {
pct_change <- (hr - 1) * 100
effect <- paste0(significance, " increases ", model_name, " risk by ", round(pct_change, 1), "%")
}
# Check for time interaction
has_time_int <- paste0(var, ":tt") %in% time_effects$Variable
time_note <- ""
if(has_time_int) {
time_row <- time_effects[time_effects$Variable == paste0(var, ":tt"), ]
time_hr <- time_row$Hazard_Ratio
if(time_hr < 1 && hr > 1) {
time_note <- " (effect weakens over time)"
} else if(time_hr > 1 && hr < 1) {
time_note <- " (effect weakens over time)"
} else if(time_hr > 1 && hr > 1) {
time_note <- " (effect strengthens over time)"
} else if(time_hr < 1 && hr < 1) {
time_note <- " (effect strengthens over time)"
}
}
# Print formatted result
cat(sprintf("%-15s: HR = %5.2f (95%% CI: %5.2f-%5.2f), p = %7.4f - %s%s\n",
var, hr, ci_lower, ci_upper, p_val, effect, time_note))
}
cat("\n")
}
# Print macroeconomic variables separately with more detailed interpretation
cat("\nMACROECONOMIC VARIABLES:\n")
cat("=======================\n\n")
macro_categories_print <- c("Economic_Growth", "Inflation", "Labor_Market")
for(category_name in macro_categories_print) {
# Create a more readable category name
readable_name <- gsub("_", " ", category_name)
cat(readable_name, ":\n")
cat(paste(rep("-", nchar(readable_name) + 1), collapse = ""), "\n")
# Get variables in this category
category_rows <- main_effects[main_effects$Type == category_name, ]
if(nrow(category_rows) == 0) {
cat("No variables from this category in the model.\n\n")
next
}
# Print each variable in this category with enhanced interpretation
for(i in 1:nrow(category_rows)) {
var <- category_rows$Variable[i]
coef_val <- category_rows$Coefficient[i]
hr <- category_rows$Hazard_Ratio[i]
p_val <- category_rows$P_value[i]
ci_lower <- category_rows$Lower_CI[i]
ci_upper <- category_rows$Upper_CI[i]
# Determine effect direction and significance
if(p_val < 0.01) {
significance <- "strong evidence that"
} else if(p_val < 0.05) {
significance <- "evidence that"
} else if(p_val < 0.1) {
significance <- "weak evidence that"
} else {
significance <- "no significant evidence that"
}
# Calculate percentage change
if(hr < 1) {
pct_change <- (1 - hr) * 100
effect <- paste0("a 1-unit increase in ", var, " is associated with a ",
round(pct_change, 1), "% decrease in ", model_name, " risk")
} else {
pct_change <- (hr - 1) * 100
effect <- paste0("a 1-unit increase in ", var, " is associated with a ",
round(pct_change, 1), "% increase in ", model_name, " risk")
}
# Check for time interaction
has_time_int <- paste0(var, ":tt") %in% time_effects$Variable
time_note <- ""
if(has_time_int) {
time_row <- time_effects[time_effects$Variable == paste0(var, ":tt"), ]
time_coef <- time_row$Coefficient
time_hr <- time_row$Hazard_Ratio
time_p <- time_row$P_value
if(time_p < 0.05) {
if(time_coef > 0 && coef_val > 0) {
time_note <- "\n → This effect strengthens over time (companies become MORE sensitive to this economic factor as they age)"
} else if(time_coef < 0 && coef_val < 0) {
time_note <- "\n → This effect strengthens over time (companies become MORE protected by this economic factor as they age)"
} else if(time_coef < 0 && coef_val > 0) {
time_note <- "\n → This effect weakens over time (risk from this economic factor DECREASES as companies age)"
} else if(time_coef > 0 && coef_val < 0) {
time_note <- "\n → This effect weakens over time (protection from this economic factor DECREASES as companies age)"
}
}
}
# Provide economic interpretation based on the variable
econ_interp <- ""
if(var == "gdp_growth") {
if(hr < 1) {
econ_interp <- paste0("\n → Strong economic growth appears to be protective against company ", model_name)
} else {
econ_interp <- paste0("\n → Surprisingly, stronger economic growth is associated with higher ", model_name, " risk")
}
} else if(var == "gdp_deflator") {
if(hr < 1) {
econ_interp <- paste0("\n → Higher inflation appears to be protective against company ", model_name)
} else {
econ_interp <- paste0("\n → Higher inflation is associated with increased company ", model_name, " risk")
}
} else if(var == "unemployement") {
if(hr < 1) {
econ_interp <- paste0("\n → Higher unemployment appears to be protective against company ", model_name)
} else {
econ_interp <- paste0("\n → Higher unemployment is associated with increased company ", model_name, " risk")
}
}
# Print detailed result for macro variable
cat(sprintf("%-15s: HR = %5.2f (95%% CI: %5.2f-%5.2f), p = %7.4f\n",
var, hr, ci_lower, ci_upper, p_val))
cat(" Interpretation: There is", significance, effect, "\n")
cat(econ_interp)
cat(time_note)
cat("\n\n")
}
}
# Print time interaction effects summary
if(nrow(time_effects) > 0) {
cat("TIME-VARYING EFFECTS SUMMARY:\n")
cat("============================\n\n")
# Separate financial and macro time effects
fin_time_effects <- time_effects[sapply(time_effects$Variable, function(v) {
var_name <- sub(":tt", "", v)
return(any(sapply(financial_categories, function(cat) var_name %in% cat)))
}), ]
macro_time_effects <- time_effects[sapply(time_effects$Variable, function(v) {
var_name <- sub(":tt", "", v)
return(any(sapply(macro_categories, function(cat) var_name %in% cat)))
}), ]
# Print financial time effects
if(nrow(fin_time_effects) > 0) {
cat("Financial Variables with Time-Varying Effects:\n")
cat("-----------------------------------------\n")
for(i in 1:nrow(fin_time_effects)) {
var <- sub(":tt", "", fin_time_effects$Variable[i])
hr <- fin_time_effects$Hazard_Ratio[i]
p_val <- fin_time_effects$P_value[i]
if(p_val < 0.05) {
cat(var, "effect changes over time: HR per year =", round(hr, 3),
"(p =", format.pval(p_val, digits = 3), ")\n")
# Calculate effects at different time points
main_coef <- main_effects$Coefficient[main_effects$Variable == var]
time_coef <- fin_time_effects$Coefficient[i]
cat(" Effect at different time points:\n")
times <- c(1, 3, 5, 10)
for(t in times) {
hr_at_time <- exp(main_coef + time_coef * t)
cat(" At t =", t, "years: HR =", round(hr_at_time, 3), "\n")
}
cat("\n")
}
}
}
# Print macro time effects with business cycle interpretation
if(nrow(macro_time_effects) > 0) {
cat("Macroeconomic Variables with Time-Varying Effects:\n")
cat("----------------------------------------------\n")
for(i in 1:nrow(macro_time_effects)) {
var <- sub(":tt", "", macro_time_effects$Variable[i])
hr <- macro_time_effects$Hazard_Ratio[i]
p_val <- macro_time_effects$P_value[i]
if(p_val < 0.05) {
cat(var, "effect changes over time: HR per year =", round(hr, 3),
"(p =", format.pval(p_val, digits = 3), ")\n")
# Calculate effects at different time points
main_coef <- main_effects$Coefficient[main_effects$Variable == var]
time_coef <- macro_time_effects$Coefficient[i]
cat(" Effect at different time points:\n")
times <- c(1, 3, 5, 10)
for(t in times) {
hr_at_time <- exp(main_coef + time_coef * t)
cat(" At t =", t, "years: HR =", round(hr_at_time, 3), "\n")
}
# Business cycle interpretation
cat(" Business cycle implications:\n")
if(var == "gdp_growth") {
if(hr > 1) {
cat(" - The influence of economic growth on", model_name, "risk INCREASES as companies mature\n")
cat(" - Older companies become more sensitive to economic conditions\n")
} else {
cat(" - The influence of economic growth on", model_name, "risk DECREASES as companies mature\n")
cat(" - Younger companies are more sensitive to economic conditions\n")
}
} else if(var == "unemployement") {
if(hr > 1) {
cat(" - The influence of labor market conditions on", model_name, "risk INCREASES over time\n")
cat(" - Unemployment has a stronger effect on companies the longer they exist\n")
} else {
cat(" - The influence of labor market conditions on", model_name, "risk DECREASES over time\n")
cat(" - Unemployment has its strongest effect on younger companies\n")
}
} else if(var == "gdp_deflator") {
if(hr > 1) {
cat(" - The influence of inflation on", model_name, "risk INCREASES as companies mature\n")
cat(" - Older companies become more sensitive to inflation\n")
} else {
cat(" - The influence of inflation on", model_name, "risk DECREASES as companies mature\n")
cat(" - Younger companies are more sensitive to inflation\n")
}
}
cat("\n")
}
}
}
}
# Return the hazard ratio data frames with type information
return(list(main_effects = main_effects, time_effects = time_effects))
}
# Apply function to both models
cat("\n=== ANALYZING BANKRUPTCY MODEL ===\n")
=== ANALYZING BANKRUPTCY MODEL ===
bankruptcy_hrs <- analyze_hazard_ratios(final_bankruptcy_model, "bankruptcy")
=== HAZARD RATIOS FOR BANKRUPTCY MODEL ===
FINANCIAL VARIABLES:
====================
Solvency Measures:
------------------
LTMTA : HR = 39.24 (95% CI: 8.46-182.08), p = 0.0000 - strongly significantly increases bankruptcy risk by 3823.8% (effect strengthens over time)
z_score : HR = 1.03 (95% CI: 1.00- 1.06), p = 0.0227 - significantly increases bankruptcy risk by 3%
debt_ratio : HR = 0.61 (95% CI: 0.25- 1.48), p = 0.2734 - not significantly decreases bankruptcy risk by 38.9% (effect weakens over time)
debt_service : HR = 1.00 (95% CI: 0.95- 1.04), p = 0.8814 - not significantly decreases bankruptcy risk by 0.3%
Liquidity Measures:
-------------------
wc_ratio : HR = 0.33 (95% CI: 0.18- 0.63), p = 0.0006 - strongly significantly decreases bankruptcy risk by 66.9%
CASHMTA : HR = 0.12 (95% CI: 0.02- 0.78), p = 0.0259 - significantly decreases bankruptcy risk by 87.9%
current_ratio : HR = 1.09 (95% CI: 1.00- 1.18), p = 0.0403 - significantly increases bankruptcy risk by 8.7%
cash_to_assets : HR = 4.22 (95% CI: 0.71-25.08), p = 0.1137 - not significantly increases bankruptcy risk by 321.6%
Profitability Measures:
-----------------------
NIMTA : HR = 0.12 (95% CI: 0.05- 0.26), p = 0.0000 - strongly significantly decreases bankruptcy risk by 88.2%
asset_turnover : HR = 0.84 (95% CI: 0.70- 1.02), p = 0.0799 - marginally significantly decreases bankruptcy risk by 15.5%
gp_margin : HR = 1.06 (95% CI: 0.97- 1.17), p = 0.1776 - not significantly increases bankruptcy risk by 6.5%
ebit_growth : HR = 0.98 (95% CI: 0.93- 1.03), p = 0.4910 - not significantly decreases bankruptcy risk by 1.7%
Market Measures:
----------------
MBE : HR = 0.85 (95% CI: 0.72- 1.00), p = 0.0540 - marginally significantly decreases bankruptcy risk by 15.1%
PRICE : HR = 0.84 (95% CI: 0.69- 1.03), p = 0.0987 - marginally significantly decreases bankruptcy risk by 15.8% (effect strengthens over time)
Other Financial Measures:
-------------------------
intangibility : HR = 0.74 (95% CI: 0.49- 1.13), p = 0.1704 - not significantly decreases bankruptcy risk by 25.5%
receivables_turnover: HR = 1.00 (95% CI: 1.00- 1.00), p = 0.4827 - not significantly increases bankruptcy risk by 0.1%
EBIT_VOL_3Y : HR = 1.00 (95% CI: 0.97- 1.02), p = 0.9065 - not significantly decreases bankruptcy risk by 0.2%
MACROECONOMIC VARIABLES:
=======================
Economic Growth :
----------------
gdp_growth : HR = 1.10 (95% CI: 0.99- 1.23), p = 0.0840
Interpretation: There is weak evidence that a 1-unit increase in gdp_growth is associated with a 10.4% increase in bankruptcy risk
→ Surprisingly, stronger economic growth is associated with higher bankruptcy risk
Inflation :
----------
gdp_deflator : HR = 0.84 (95% CI: 0.70- 1.00), p = 0.0511
Interpretation: There is weak evidence that a 1-unit increase in gdp_deflator is associated with a 16.1% decrease in bankruptcy risk
→ Higher inflation appears to be protective against company bankruptcy
Labor Market :
-------------
unemployement : HR = 0.93 (95% CI: 0.81- 1.06), p = 0.2777
Interpretation: There is no significant evidence that a 1-unit increase in unemployement is associated with a 7.2% decrease in bankruptcy risk
→ Higher unemployment appears to be protective against company bankruptcy
TIME-VARYING EFFECTS SUMMARY:
============================
Financial Variables with Time-Varying Effects:
-----------------------------------------
cat("\n=== ANALYZING ACQUISITION MODEL ===\n")
=== ANALYZING ACQUISITION MODEL ===
acquisition_hrs <- analyze_hazard_ratios(final_acquisition_model, "acquisition")
=== HAZARD RATIOS FOR ACQUISITION MODEL ===
FINANCIAL VARIABLES:
====================
Solvency Measures:
------------------
debt_ratio : HR = 1.02 (95% CI: 0.80- 1.31), p = 0.8608 - not significantly increases acquisition risk by 2.3%
LTMTA : HR = 0.97 (95% CI: 0.68- 1.39), p = 0.8622 - not significantly decreases acquisition risk by 3.1%
Liquidity Measures:
-------------------
current_ratio : HR = 0.93 (95% CI: 0.90- 0.95), p = 0.0000 - strongly significantly decreases acquisition risk by 7.1%
cash_to_assets : HR = 2.09 (95% CI: 1.52- 2.88), p = 0.0000 - strongly significantly increases acquisition risk by 109.1%
wc_ratio : HR = 0.49 (95% CI: 0.33- 0.73), p = 0.0003 - strongly significantly decreases acquisition risk by 50.9% (effect weakens over time)
Profitability Measures:
-----------------------
asset_turnover : HR = 0.83 (95% CI: 0.74- 0.93), p = 0.0011 - strongly significantly decreases acquisition risk by 17.1% (effect weakens over time)
gp_margin : HR = 1.03 (95% CI: 1.01- 1.04), p = 0.0046 - strongly significantly increases acquisition risk by 2.6%
NIMTA : HR = 1.21 (95% CI: 0.83- 1.75), p = 0.3217 - not significantly increases acquisition risk by 20.7%
Market Measures:
----------------
MBE : HR = 0.79 (95% CI: 0.76- 0.83), p = 0.0000 - strongly significantly decreases acquisition risk by 20.6%
PRICE : HR = 1.14 (95% CI: 1.10- 1.19), p = 0.0000 - strongly significantly increases acquisition risk by 14.2%
Other Financial Measures:
-------------------------
receivables_turnover: HR = 1.00 (95% CI: 0.99- 1.00), p = 0.0008 - strongly significantly decreases acquisition risk by 0.3%
EBIT_VOL_3Y : HR = 0.99 (95% CI: 0.98- 1.00), p = 0.0719 - marginally significantly decreases acquisition risk by 0.8%
MACROECONOMIC VARIABLES:
=======================
Economic Growth :
----------------
gdp_growth : HR = 1.04 (95% CI: 1.01- 1.07), p = 0.0131
Interpretation: There is evidence that a 1-unit increase in gdp_growth is associated with a 3.8% increase in acquisition risk
→ Surprisingly, stronger economic growth is associated with higher acquisition risk
Inflation :
----------
gdp_deflator : HR = 0.96 (95% CI: 0.92- 1.01), p = 0.0852
Interpretation: There is weak evidence that a 1-unit increase in gdp_deflator is associated with a 3.7% decrease in acquisition risk
→ Higher inflation appears to be protective against company acquisition
Labor Market :
-------------
unemployement : HR = 0.87 (95% CI: 0.82- 0.93), p = 0.0000
Interpretation: There is strong evidence that a 1-unit increase in unemployement is associated with a 12.5% decrease in acquisition risk
→ Higher unemployment appears to be protective against company acquisition
→ This effect weakens over time (protection from this economic factor DECREASES as companies age)
TIME-VARYING EFFECTS SUMMARY:
============================
Financial Variables with Time-Varying Effects:
-----------------------------------------
wc_ratio effect changes over time: HR per year = 1.048 (p = 0.000271 )
Effect at different time points:
At t = 1 years: HR = 0.514
At t = 3 years: HR = 0.565
At t = 5 years: HR = 0.619
At t = 10 years: HR = 0.781
asset_turnover effect changes over time: HR per year = 1.013 (p = 0.00238 )
Effect at different time points:
At t = 1 years: HR = 0.84
At t = 3 years: HR = 0.862
At t = 5 years: HR = 0.885
At t = 10 years: HR = 0.944
Macroeconomic Variables with Time-Varying Effects:
----------------------------------------------
unemployement effect changes over time: HR per year = 1.008 (p = 3.45e-05 )
Effect at different time points:
At t = 1 years: HR = 0.882
At t = 3 years: HR = 0.897
At t = 5 years: HR = 0.912
At t = 10 years: HR = 0.95
Business cycle implications:
- The influence of labor market conditions on acquisition risk INCREASES over time
- Unemployment has a stronger effect on companies the longer they exist
# Compare the impact of macroeconomic variables between models
cat("\n\n=== COMPARATIVE ANALYSIS OF MACROECONOMIC EFFECTS ===\n")
=== COMPARATIVE ANALYSIS OF MACROECONOMIC EFFECTS ===
cat("=================================================\n\n")
=================================================
# Extract macro variables from both models
bankruptcy_macro <- bankruptcy_hrs$main_effects[grep("gdp_|unemployement", bankruptcy_hrs$main_effects$Variable), ]
acquisition_macro <- acquisition_hrs$main_effects[grep("gdp_|unemployement", acquisition_hrs$main_effects$Variable), ]
# Variables in both models
common_vars <- intersect(bankruptcy_macro$Variable, acquisition_macro$Variable)
if(length(common_vars) > 0) {
cat("Macroeconomic variables in both models:\n")
cat("-------------------------------------\n")
for(var in common_vars) {
# Get HRs
bk_hr <- bankruptcy_macro$Hazard_Ratio[bankruptcy_macro$Variable == var]
acq_hr <- acquisition_macro$Hazard_Ratio[acquisition_macro$Variable == var]
# Calculate percentage change
bk_pct <- ifelse(bk_hr < 1, (1 - bk_hr) * 100, (bk_hr - 1) * 100)
acq_pct <- ifelse(acq_hr < 1, (1 - acq_hr) * 100, (acq_hr - 1) * 100)
# Get p-values
bk_p <- bankruptcy_macro$P_value[bankruptcy_macro$Variable == var]
acq_p <- acquisition_macro$P_value[acquisition_macro$Variable == var]
# Check significance
bk_sig <- ifelse(bk_p < 0.05, "significant", "not significant")
acq_sig <- ifelse(acq_p < 0.05, "significant", "not significant")
# Check direction
bk_dir <- ifelse(bk_hr > 1, "increases", "decreases")
acq_dir <- ifelse(acq_hr > 1, "increases", "decreases")
cat(var, ":\n")
cat(" - Bankruptcy effect: ", bk_dir, " risk by ", round(abs(bk_pct), 1), "% (", bk_sig, ", p=", round(bk_p, 4), ")\n", sep="")
cat(" - Acquisition effect: ", acq_dir, " risk by ", round(abs(acq_pct), 1), "% (", acq_sig, ", p=", round(acq_p, 4), ")\n", sep="")
# Check for opposite effects
if((bk_hr > 1 && acq_hr < 1) || (bk_hr < 1 && acq_hr > 1)) {
cat(" - NOTE: This economic factor has OPPOSITE effects on bankruptcy and acquisition\n")
} else {
cat(" - This economic factor affects both outcomes in the same direction\n")
}
# Check for time-varying effects in both models
bk_time_var <- paste0(var, ":tt") %in% bankruptcy_hrs$time_effects$Variable
acq_time_var <- paste0(var, ":tt") %in% acquisition_hrs$time_effects$Variable
if(bk_time_var && acq_time_var) {
cat(" - Time-varying effects present in BOTH models\n")
} else if(bk_time_var) {
cat(" - Time-varying effects present only in BANKRUPTCY model\n")
} else if(acq_time_var) {
cat(" - Time-varying effects present only in ACQUISITION model\n")
} else {
cat(" - No time-varying effects in either model\n")
}
cat("\n")
}
}
Macroeconomic variables in both models:
-------------------------------------
gdp_deflator :
- Bankruptcy effect: decreases risk by 16.1% (not significant, p=0.0511)
- Acquisition effect: decreases risk by 3.7% (not significant, p=0.0852)
- This economic factor affects both outcomes in the same direction
- No time-varying effects in either model
unemployement :
- Bankruptcy effect: decreases risk by 7.2% (not significant, p=0.2777)
- Acquisition effect: decreases risk by 12.5% (significant, p=0)
- This economic factor affects both outcomes in the same direction
- Time-varying effects present only in ACQUISITION model
gdp_growth :
- Bankruptcy effect: increases risk by 10.4% (not significant, p=0.084)
- Acquisition effect: increases risk by 3.8% (significant, p=0.0131)
- This economic factor affects both outcomes in the same direction
- No time-varying effects in either model
# Variables unique to bankruptcy model
bk_only_vars <- setdiff(bankruptcy_macro$Variable, acquisition_macro$Variable)
if(length(bk_only_vars) > 0) {
cat("\nMacroeconomic variables only in bankruptcy model:\n")
cat("-----------------------------------------\n")
for(var in bk_only_vars) {
cat(var, "\n")
}
cat("\n")
}
# Variables unique to acquisition model
acq_only_vars <- setdiff(acquisition_macro$Variable, bankruptcy_macro$Variable)
if(length(acq_only_vars) > 0) {
cat("\nMacroeconomic variables only in acquisition model:\n")
cat("-----------------------------------------\n")
for(var in acq_only_vars) {
cat(var, "\n")
}
cat("\n")
}
# Save hazard ratio analysis results
hazard_ratio_analysis <- list(
bankruptcy = bankruptcy_hrs,
acquisition = acquisition_hrs
)
Same here, we will create a function to visualize the time-varying effects of the final models. This function will plot the hazard ratios over time for each variable, and provide detailed interpretations based on the variable type (financial or macroeconomic). We will also include a summary of the time-varying effects for both models.
#-------------------------------------------------------------
# 11.2: Model Fit Statistics with Macro Variable Contribution
#-------------------------------------------------------------
cat("\n11.2: MODEL FIT STATISTICS WITH MACRO CONTRIBUTION ANALYSIS\n")
11.2: MODEL FIT STATISTICS WITH MACRO CONTRIBUTION ANALYSIS
cat("--------------------------------------\n")
--------------------------------------
# Function to calculate alternative concordance using AUC from ROC analysis
calculate_auc_concordance <- function(model, event_type) {
# Create dataset with last observation for each company
last_obs_data <- data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Calculate risk scores
risk_scores <- predict(model, newdata = last_obs_data, type = "risk")
# Use ROC analysis as an alternative to concordance
if(requireNamespace("pROC", quietly = TRUE)) {
library(pROC)
# Use the event indicator
event_indicator <- last_obs_data[[event_type]]
# Calculate ROC and AUC
tryCatch({
roc_obj <- roc(event_indicator, risk_scores, quiet = TRUE)
auc_value <- as.numeric(auc(roc_obj))
return(auc_value)
}, error = function(e) {
cat("Error calculating AUC:", e$message, "\n")
return(NA)
})
} else {
return(NA)
}
}
# Function to create a version of the model without macro variables
create_no_macro_model <- function(model, event_type) {
# Get model formula
model_formula <- formula(model)
# Extract all terms
all_terms <- attr(terms(model), "term.labels")
# Identify macro variables (including their time interactions)
macro_vars <- c("gdp_growth", "gdp_deflator", "unemployement")
macro_terms <- c()
for(term in all_terms) {
# Check if term contains any macro variable
is_macro <- FALSE
for(macro in macro_vars) {
if(grepl(macro, term)) {
is_macro <- TRUE
break
}
}
if(is_macro) {
macro_terms <- c(macro_terms, term)
}
}
# If no macro terms in model, return original model
if(length(macro_terms) == 0) {
return(model)
}
# Create formula without macro variables
no_macro_formula <- model_formula
for(term in macro_terms) {
no_macro_formula <- update(no_macro_formula, paste0(". ~ . - ", term))
}
# Fit model without macro variables
if(event_type == "bankruptcy") {
no_macro_model <- coxph(no_macro_formula, data = data, ties = "efron")
} else {
no_macro_model <- coxph(no_macro_formula, data = data, ties = "efron")
}
return(no_macro_model)
}
# Function to analyze model fit with simpler concordance calculation
analyze_model_fit <- function(model, model_name, event_type) {
# Extract standard model statistics
model_summary <- summary(model)
# Calculate AIC and BIC
model_aic <- AIC(model)
model_bic <- BIC(model)
# Calculate pseudo R-squared (1 - exp(-LR/n))
lr_test <- model_summary$logtest["test"]
n <- model$n
r_squared <- 1 - exp(-lr_test / n)
# Calculate AUC as an alternative to concordance
auc_value <- calculate_auc_concordance(model, event_type)
# Create model without macro variables for comparison
no_macro_model <- create_no_macro_model(model, event_type)
no_macro_summary <- summary(no_macro_model)
no_macro_aic <- AIC(no_macro_model)
no_macro_r_squared <- 1 - exp(-no_macro_summary$logtest["test"] / no_macro_model$n)
no_macro_auc <- calculate_auc_concordance(no_macro_model, event_type)
# Get model terms to identify macro variables
all_terms <- attr(terms(model), "term.labels")
macro_vars <- c("gdp_growth", "gdp_deflator", "unemployement")
macro_terms <- c()
for(term in all_terms) {
is_macro <- FALSE
for(macro in macro_vars) {
if(grepl(macro, term)) {
is_macro <- TRUE
break
}
}
if(is_macro) {
macro_terms <- c(macro_terms, term)
}
}
# Print results with interpretation
cat("\n=== MODEL FIT STATISTICS FOR", toupper(model_name), "MODEL ===\n\n")
# Print macro variables in model
cat("Macroeconomic Variables in Model:\n")
cat("--------------------------------\n")
if(length(macro_terms) > 0) {
for(term in macro_terms) {
cat("- ", term, "\n")
}
} else {
cat("No macroeconomic variables in this model.\n")
}
cat("\n")
cat("Discrimination Ability:\n")
cat("-----------------------\n")
# Use AUC instead of concordance
cat("AUC (Area Under ROC Curve):", ifelse(is.na(auc_value), "Not available", round(auc_value, 4)), "\n")
if(!is.na(auc_value)) {
cat("Interpretation: ")
if(auc_value > 0.8) {
cat("Excellent discrimination (AUC > 0.8)\n")
} else if(auc_value > 0.7) {
cat("Good discrimination (0.7 < AUC < 0.8)\n")
} else if(auc_value > 0.6) {
cat("Fair discrimination (0.6 < AUC < 0.7)\n")
} else {
cat("Poor discrimination (AUC < 0.6)\n")
}
}
cat("\n")
# Model significance
cat("Overall Model Significance:\n")
cat("---------------------------\n")
cat("Likelihood Ratio Test:", round(model_summary$logtest["test"], 2),
"on", model_summary$logtest["df"], "df, p-value:",
format.pval(model_summary$logtest["pvalue"], digits = 4), "\n")
# Interpret LR test
if(model_summary$logtest["pvalue"] < 0.05) {
cat("Interpretation: Model is statistically significant (p < 0.05)\n")
} else {
cat("Interpretation: Model is not statistically significant (p >= 0.05)\n")
}
cat("\n")
# Fit statistics with explanation
cat("Goodness of Fit Measures:\n")
cat("------------------------\n")
cat("AIC:", round(model_aic, 2), "- Akaike Information Criterion, lower values indicate better fit\n")
cat("BIC:", round(model_bic, 2), "- Bayesian Information Criterion, penalizes complexity more than AIC\n")
cat("Pseudo R-squared:", round(r_squared, 4),
"- Proportion of null deviance explained by the model\n")
# Interpret R-squared
cat("Interpretation: ")
if(r_squared > 0.3) {
cat("Strong explanatory power for survival model (R² > 0.3)\n")
} else if(r_squared > 0.15) {
cat("Moderate explanatory power for survival model (0.15 < R² < 0.3)\n")
} else if(r_squared > 0.05) {
cat("Modest explanatory power for survival model (0.05 < R² < 0.15)\n")
} else {
cat("Limited explanatory power for survival model (R² < 0.05), but may still have good predictive value\n")
}
cat("\n")
# Penalty term counts
num_vars <- length(coef(model))
num_strata <- length(grep("strata", names(model$means)))
cat("Model Complexity:\n")
cat("----------------\n")
cat("Number of coefficients:", num_vars, "\n")
cat("Number of strata:", num_strata, "\n")
cat("\n")
# Macro variable contribution analysis
if(length(macro_terms) > 0) {
cat("CONTRIBUTION OF MACROECONOMIC VARIABLES:\n")
cat("---------------------------------------\n")
# AIC contribution
aic_diff <- no_macro_aic - model_aic
cat("AIC improvement from macro variables:", round(aic_diff, 2),
ifelse(aic_diff > 0, " (better fit with macro variables)\n", " (worse fit with macro variables)\n"))
# R-squared contribution
r_squared_diff <- r_squared - no_macro_r_squared
cat("R-squared improvement:", round(r_squared_diff, 4),
paste0("(", round(r_squared_diff * 100 / r_squared, 1), "% of model's explanatory power)\n"))
# AUC contribution
if(!is.na(auc_value) && !is.na(no_macro_auc)) {
auc_diff <- auc_value - no_macro_auc
cat("AUC improvement:", round(auc_diff, 4),
ifelse(auc_diff > 0, " (better discrimination with macro variables)\n",
" (worse discrimination with macro variables)\n"))
}
# Likelihood ratio test for nested models
if(no_macro_model$loglik[2] < model$loglik[2]) {
lr_test_macro <- 2 * (model$loglik[2] - no_macro_model$loglik[2])
df_diff <- length(coef(model)) - length(coef(no_macro_model))
p_value <- 1 - pchisq(lr_test_macro, df = df_diff)
cat("Likelihood ratio test for macro variables: Chi-square =", round(lr_test_macro, 2),
"on", df_diff, "df, p-value =", format.pval(p_value, digits = 4), "\n")
if(p_value < 0.05) {
cat("Interpretation: Macroeconomic variables SIGNIFICANTLY improve model fit (p < 0.05)\n")
} else {
cat("Interpretation: Macroeconomic variables do not significantly improve model fit (p >= 0.05)\n")
}
}
cat("\nNote on Economic Interpretation:\n")
cat("The inclusion of macroeconomic variables allows the model to account for\n")
cat("broader economic conditions that affect all companies simultaneously, which\n")
cat("helps distinguish between firm-specific risk factors and systematic risk.\n")
}
# Return statistics for future use
return(list(
auc = auc_value,
lr_test = model_summary$logtest,
r_squared = r_squared,
aic = model_aic,
bic = model_bic,
no_macro_auc = no_macro_auc,
no_macro_r_squared = no_macro_r_squared,
no_macro_aic = no_macro_aic,
macro_terms = macro_terms
))
}
# Apply function to both models
bankruptcy_fit_stats <- analyze_model_fit(final_bankruptcy_model, "bankruptcy", "bankruptcy")
=== MODEL FIT STATISTICS FOR BANKRUPTCY MODEL ===
Macroeconomic Variables in Model:
--------------------------------
- gdp_deflator
- unemployement
- gdp_growth
Discrimination Ability:
-----------------------
AUC (Area Under ROC Curve): 0.8183
Interpretation: Excellent discrimination (AUC > 0.8)
Overall Model Significance:
---------------------------
Likelihood Ratio Test: 445.17 on 23 df, p-value: < 2.2e-16
Interpretation: Model is statistically significant (p < 0.05)
Goodness of Fit Measures:
------------------------
AIC: 1593.76 - Akaike Information Criterion, lower values indicate better fit
BIC: 1666.68 - Bayesian Information Criterion, penalizes complexity more than AIC
Pseudo R-squared: 0.007 - Proportion of null deviance explained by the model
Interpretation: Limited explanatory power for survival model (R² < 0.05), but may still have good predictive value
Model Complexity:
----------------
Number of coefficients: 23
Number of strata: 0
CONTRIBUTION OF MACROECONOMIC VARIABLES:
---------------------------------------
AIC improvement from macro variables: 3.22 (better fit with macro variables)
R-squared improvement: 1e-04 (2.1% of model's explanatory power)
AUC improvement: 0.0077 (better discrimination with macro variables)
Likelihood ratio test for macro variables: Chi-square = 9.22 on 3 df, p-value = 0.02646
Interpretation: Macroeconomic variables SIGNIFICANTLY improve model fit (p < 0.05)
Note on Economic Interpretation:
The inclusion of macroeconomic variables allows the model to account for
broader economic conditions that affect all companies simultaneously, which
helps distinguish between firm-specific risk factors and systematic risk.
acquisition_fit_stats <- analyze_model_fit(final_acquisition_model, "acquisition", "acquisition")
=== MODEL FIT STATISTICS FOR ACQUISITION MODEL ===
Macroeconomic Variables in Model:
--------------------------------
- gdp_deflator
- unemployement
- gdp_growth
- unemployement:tt
Discrimination Ability:
-----------------------
AUC (Area Under ROC Curve): 0.5272
Interpretation: Poor discrimination (AUC < 0.6)
Overall Model Significance:
---------------------------
Likelihood Ratio Test: 448.04 on 18 df, p-value: < 2.2e-16
Interpretation: Model is statistically significant (p < 0.05)
Goodness of Fit Measures:
------------------------
AIC: 24259.44 - Akaike Information Criterion, lower values indicate better fit
BIC: 24361.59 - Bayesian Information Criterion, penalizes complexity more than AIC
Pseudo R-squared: 0.007 - Proportion of null deviance explained by the model
Interpretation: Limited explanatory power for survival model (R² < 0.05), but may still have good predictive value
Model Complexity:
----------------
Number of coefficients: 18
Number of strata: 0
CONTRIBUTION OF MACROECONOMIC VARIABLES:
---------------------------------------
AIC improvement from macro variables: 25.43 (better fit with macro variables)
R-squared improvement: 5e-04 (7.4% of model's explanatory power)
AUC improvement: -0.0546 (worse discrimination with macro variables)
Likelihood ratio test for macro variables: Chi-square = 33.43 on 4 df, p-value = 9.748e-07
Interpretation: Macroeconomic variables SIGNIFICANTLY improve model fit (p < 0.05)
Note on Economic Interpretation:
The inclusion of macroeconomic variables allows the model to account for
broader economic conditions that affect all companies simultaneously, which
helps distinguish between firm-specific risk factors and systematic risk.
# Compare models
cat("\nCOMPARISON OF MODEL FIT:\n")
COMPARISON OF MODEL FIT:
cat("------------------------\n")
------------------------
cat("AUC (Area Under ROC Curve):\n")
AUC (Area Under ROC Curve):
cat(" Bankruptcy model:", ifelse(is.na(bankruptcy_fit_stats$auc), "NA",
round(bankruptcy_fit_stats$auc, 4)), "\n")
Bankruptcy model: 0.8183
cat(" Acquisition model:", ifelse(is.na(acquisition_fit_stats$auc), "NA",
round(acquisition_fit_stats$auc, 4)), "\n\n")
Acquisition model: 0.5272
cat("AIC (lower is better):\n")
AIC (lower is better):
cat(" Bankruptcy model:", round(bankruptcy_fit_stats$aic, 2), "\n")
Bankruptcy model: 1593.76
cat(" Acquisition model:", round(acquisition_fit_stats$aic, 2), "\n\n")
Acquisition model: 24259.44
cat("Pseudo R-squared:\n")
Pseudo R-squared:
cat(" Bankruptcy model:", round(bankruptcy_fit_stats$r_squared, 4), "\n")
Bankruptcy model: 0.007
cat(" Acquisition model:", round(acquisition_fit_stats$r_squared, 4), "\n\n")
Acquisition model: 0.007
# Compare contribution of macro variables between models
cat("\nCOMPARATIVE IMPACT OF MACROECONOMIC VARIABLES:\n")
COMPARATIVE IMPACT OF MACROECONOMIC VARIABLES:
cat("---------------------------------------------\n")
---------------------------------------------
# Function to calculate percentage improvement
pct_improvement <- function(with_macro, without_macro) {
if(is.na(with_macro) || is.na(without_macro)) {
return(NA)
}
return((with_macro - without_macro) / without_macro * 100)
}
# Calculate improvement percentages
bankruptcy_auc_pct <- pct_improvement(bankruptcy_fit_stats$auc, bankruptcy_fit_stats$no_macro_auc)
acquisition_auc_pct <- pct_improvement(acquisition_fit_stats$auc, acquisition_fit_stats$no_macro_auc)
bankruptcy_r2_pct <- pct_improvement(bankruptcy_fit_stats$r_squared, bankruptcy_fit_stats$no_macro_r_squared)
acquisition_r2_pct <- pct_improvement(acquisition_fit_stats$r_squared, acquisition_fit_stats$no_macro_r_squared)
cat("Relative Improvement in AUC:\n")
Relative Improvement in AUC:
cat(" Bankruptcy model:", ifelse(is.na(bankruptcy_auc_pct), "NA",
paste0(round(bankruptcy_auc_pct, 2), "%")), "\n")
Bankruptcy model: 0.96%
cat(" Acquisition model:", ifelse(is.na(acquisition_auc_pct), "NA",
paste0(round(acquisition_auc_pct, 2), "%")), "\n\n")
Acquisition model: -9.39%
cat("Relative Improvement in R-squared:\n")
Relative Improvement in R-squared:
cat(" Bankruptcy model:", ifelse(is.na(bankruptcy_r2_pct), "NA",
paste0(round(bankruptcy_r2_pct, 2), "%")), "\n")
Bankruptcy model: 2.11%
cat(" Acquisition model:", ifelse(is.na(acquisition_r2_pct), "NA",
paste0(round(acquisition_r2_pct, 2), "%")), "\n\n")
Acquisition model: 8.03%
# Economic interpretation of the comparison
cat("Economic Interpretation:\n")
Economic Interpretation:
cat("----------------------\n")
----------------------
if(!is.na(bankruptcy_r2_pct) && !is.na(acquisition_r2_pct)) {
if(bankruptcy_r2_pct > acquisition_r2_pct) {
cat("Macroeconomic variables have a STRONGER impact on bankruptcy risk compared to acquisition likelihood.\n")
cat("This suggests that systematic economic factors play a more significant role in determining\n")
cat("when companies fail than when they are acquired.\n\n")
} else if(acquisition_r2_pct > bankruptcy_r2_pct) {
cat("Macroeconomic variables have a STRONGER impact on acquisition likelihood compared to bankruptcy risk.\n")
cat("This suggests that market conditions and economic cycles are more important drivers of\n")
cat("M&A activity than they are for corporate failures.\n\n")
} else {
cat("Macroeconomic variables have a SIMILAR impact on both bankruptcy risk and acquisition likelihood.\n")
cat("This suggests that economic conditions influence both outcomes to a comparable degree.\n\n")
}
}
Macroeconomic variables have a STRONGER impact on acquisition likelihood compared to bankruptcy risk.
This suggests that market conditions and economic cycles are more important drivers of
M&A activity than they are for corporate failures.
cat("Broader Implications:\n")
Broader Implications:
cat("- These results help distinguish between firm-specific and systematic risk factors\n")
- These results help distinguish between firm-specific and systematic risk factors
cat("- Understanding the influence of macroeconomic conditions can improve risk management\n")
- Understanding the influence of macroeconomic conditions can improve risk management
cat("- The relative importance of macro factors may vary across different industries and time periods\n")
- The relative importance of macro factors may vary across different industries and time periods
# Save the fit statistics for reporting
fit_statistics <- list(
bankruptcy = bankruptcy_fit_stats,
acquisition = acquisition_fit_stats
)
Again, we will create a function to visualize the model fit statistics, including AUC and R-squared values, and provide detailed interpretations based on the model type (bankruptcy or acquisition). We will also include a summary of the macroeconomic variable contributions for both models.
#-------------------------------------------------------------
# 11.3: Variable Importance with Focus on Macroeconomic Factors
#-------------------------------------------------------------
cat("\n11.3: VARIABLE IMPORTANCE WITH FOCUS ON MACROECONOMIC FACTORS\n")
11.3: VARIABLE IMPORTANCE WITH FOCUS ON MACROECONOMIC FACTORS
cat("--------------------------------------\n")
--------------------------------------
# Function to calculate and visualize variable importance
analyze_variable_importance <- function(model, model_name) {
# Extract coefficients and statistics
coef_summary <- summary(model)$coefficients
# Create importance data frame
importance <- data.frame(
Variable = rownames(coef_summary),
Coefficient = coef_summary[, "coef"],
SE = coef_summary[, "se(coef)"],
Z_Score = coef_summary[, "z"],
P_Value = coef_summary[, "Pr(>|z|)"],
Wald_ChiSq = coef_summary[, "z"]^2,
HR = exp(coef_summary[, "coef"]),
stringsAsFactors = FALSE
)
# Separate main effects from time interactions
main_effects <- importance[!grepl(":tt", importance$Variable), ]
time_effects <- importance[grepl(":tt", importance$Variable), ]
# Add variable type classification
main_effects$Type <- "Financial" # Default
# Identify macro variables
macro_vars <- c("gdp_growth", "gdp_deflator", "unemployement")
for(var in main_effects$Variable) {
if(var %in% macro_vars) {
main_effects$Type[main_effects$Variable == var] <- "Macro"
}
}
# Calculate standardized importance (absolute Z-score)
main_effects$Abs_Z <- abs(main_effects$Z_Score)
main_effects$Standardized_Importance <- 100 * main_effects$Abs_Z / sum(main_effects$Abs_Z)
# Sort by importance
main_effects <- main_effects[order(main_effects$Abs_Z, decreasing = TRUE), ]
# Print results
cat("\n=== VARIABLE IMPORTANCE FOR", toupper(model_name), "MODEL ===\n\n")
# Table of top variables
cat("Ranked Variable Importance (based on statistical significance):\n")
cat("------------------------------------------------------------\n")
top_vars <- head(main_effects, 10) # Show top 10
# Format and print the table
for(i in 1:nrow(top_vars)) {
var <- top_vars$Variable[i]
type <- top_vars$Type[i]
coef <- top_vars$Coefficient[i]
hr <- top_vars$HR[i]
p_val <- top_vars$P_Value[i]
importance_pct <- top_vars$Standardized_Importance[i]
# Format effect direction
direction <- ifelse(coef > 0, "increases", "decreases")
# Format p-value
significance <- ""
if(p_val < 0.001) significance <- "***"
else if(p_val < 0.01) significance <- "**"
else if(p_val < 0.05) significance <- "*"
else if(p_val < 0.1) significance <- "."
# Check if this variable has a time interaction
has_time_int <- paste0(var, ":tt") %in% time_effects$Variable
time_note <- ifelse(has_time_int, " (has time-varying effect)", "")
# Format differently for macro variables
if(type == "Macro") {
cat(sprintf("%2d. %-15s: Importance = %5.1f%%, HR = %5.2f, %s %s risk %s%s [MACROECONOMIC VARIABLE]\n",
i, var, importance_pct, hr, direction, model_name, significance, time_note))
} else {
cat(sprintf("%2d. %-15s: Importance = %5.1f%%, HR = %5.2f, %s %s risk %s%s\n",
i, var, importance_pct, hr, direction, model_name, significance, time_note))
}
}
cat("\nSignificance codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1\n\n")
# Visualization placeholder (in actual code, would create a plot)
cat("Top 5 Variables by Importance:\n")
cat("-----------------------------\n")
for(i in 1:min(5, nrow(main_effects))) {
var <- main_effects$Variable[i]
type <- main_effects$Type[i]
importance <- main_effects$Standardized_Importance[i]
bar <- paste(rep("#", round(importance/2)), collapse="")
# Add indicator for macro variables
var_label <- var
if(type == "Macro") {
var_label <- paste0(var, " (M)")
}
cat(sprintf("%-15s |%s %5.1f%%\n", var_label, bar, importance))
}
# Separate analysis of macroeconomic variables regardless of rank
macro_rows <- main_effects[main_effects$Type == "Macro", ]
if(nrow(macro_rows) > 0) {
cat("\nANALYSIS OF MACROECONOMIC VARIABLES:\n")
cat("----------------------------------\n")
for(i in 1:nrow(macro_rows)) {
var <- macro_rows$Variable[i]
coef <- macro_rows$Coefficient[i]
hr <- macro_rows$HR[i]
p_val <- macro_rows$P_Value[i]
rank <- which(main_effects$Variable == var)
importance_pct <- macro_rows$Standardized_Importance[i]
# Format effect and interpretation
direction <- ifelse(coef > 0, "increases", "decreases")
cat(sprintf("%-15s: Overall rank #%d (Importance = %5.1f%%)\n", var, rank, importance_pct))
cat(sprintf(" Effect: %s %s risk (HR = %5.2f, p = %7.4f)\n",
direction, model_name, hr, p_val))
# Economic interpretation
cat(" Economic interpretation: ")
if(var == "gdp_growth") {
if(coef > 0) {
cat("Stronger economic growth is associated with HIGHER", model_name, "risk\n")
cat(" This may indicate that during economic expansions, either:\n")
cat(" - Companies take on more risk, leading to vulnerability\n")
cat(" - More competitive pressure during growth periods\n")
} else {
cat("Stronger economic growth is associated with LOWER", model_name, "risk\n")
cat(" This aligns with economic theory that growing economies support business success\n")
cat(" and provide more opportunities for struggling firms\n")
}
} else if(var == "gdp_deflator") {
if(coef > 0) {
cat("Higher inflation is associated with HIGHER", model_name, "risk\n")
cat(" This suggests inflation may create challenges through:\n")
cat(" - Increased input costs\n")
cat(" - Potential monetary tightening responses\n")
cat(" - Reduced consumer purchasing power\n")
} else {
cat("Higher inflation is associated with LOWER", model_name, "risk\n")
cat(" This counterintuitive finding might reflect:\n")
cat(" - Inflation benefiting debtors by reducing real debt burden\n")
cat(" - Price increases helping company revenues in certain sectors\n")
}
} else if(var == "unemployement") {
if(coef > 0) {
cat("Higher unemployment is associated with HIGHER", model_name, "risk\n")
cat(" This aligns with economic theory that weaker labor markets signal:\n")
cat(" - Overall economic weakness\n")
cat(" - Reduced consumer spending\n")
cat(" - Broader contraction in business activity\n")
} else {
cat("Higher unemployment is associated with LOWER", model_name, "risk\n")
cat(" This counterintuitive finding might reflect:\n")
cat(" - Labor cost savings for businesses during high unemployment\n")
cat(" - Survival bias where only stronger companies remain after economic downturns\n")
}
}
# Check for time interaction and add interpretation
has_time_int <- paste0(var, ":tt") %in% time_effects$Variable
if(has_time_int) {
time_row <- time_effects[time_effects$Variable == paste0(var, ":tt"), ]
time_coef <- time_row$Coefficient
time_p <- time_row$P_Value
if(time_p < 0.1) {
cat("\n Time-varying effect: ")
if(time_coef > 0 && coef > 0) {
cat("The adverse impact of this economic factor INCREASES as companies age\n")
cat(" Mature companies may be less adaptable to this economic condition\n")
} else if(time_coef < 0 && coef < 0) {
cat("The protective effect of this economic factor STRENGTHENS as companies age\n")
cat(" Mature companies may benefit more from this economic condition\n")
} else if(time_coef < 0 && coef > 0) {
cat("The adverse impact of this economic factor DECREASES as companies age\n")
cat(" Young companies are more vulnerable to this economic condition\n")
} else if(time_coef > 0 && coef < 0) {
cat("The protective effect of this economic factor WEAKENS as companies age\n")
cat(" Young companies benefit more from this economic condition\n")
}
# Calculate effect at different time points
times <- c(1, 3, 5, 10)
cat(" Impact at different company ages:\n")
for(t in times) {
effect_at_t <- coef + time_coef * t
hr_at_t <- exp(effect_at_t)
age_desc <- paste0("Year ", t)
cat(sprintf(" %-7s: HR = %5.3f (%s risk by %5.1f%%)\n",
age_desc, hr_at_t,
ifelse(effect_at_t > 0, "increases", "decreases"),
ifelse(effect_at_t > 0, (hr_at_t - 1) * 100, (1 - hr_at_t) * 100)))
}
}
}
cat("\n")
}
} else {
cat("\nNo macroeconomic variables in this model.\n\n")
}
# Analyze time-varying effects separately
if(nrow(time_effects) > 0) {
cat("\nTime-Varying Effects Analysis:\n")
cat("-----------------------------\n")
# Separate macro and financial time effects
fin_time_effects <- time_effects[!sapply(time_effects$Variable, function(v) {
var_name <- sub(":tt", "", v)
return(var_name %in% macro_vars)
}), ]
macro_time_effects <- time_effects[sapply(time_effects$Variable, function(v) {
var_name <- sub(":tt", "", v)
return(var_name %in% macro_vars)
}), ]
# Print financial variable time effects
if(nrow(fin_time_effects) > 0) {
cat("\nTime-varying effects for FINANCIAL variables:\n")
for(i in 1:nrow(fin_time_effects)) {
time_var <- fin_time_effects$Variable[i]
var <- sub(":tt", "", time_var)
time_coef <- fin_time_effects$Coefficient[i]
time_p <- fin_time_effects$P_Value[i]
# Only show significant time interactions
if(time_p < 0.1) { # Showing marginally significant ones too
main_coef <- main_effects$Coefficient[main_effects$Variable == var]
cat("\nTime-varying importance for", var, ":\n")
# Effect direction at baseline
baseline_effect <- ifelse(main_coef > 0, "increases", "decreases")
# Effect of time interaction
time_effect <- ifelse(time_coef > 0, "strengthens", "weakens")
if((main_coef > 0 && time_coef < 0) || (main_coef < 0 && time_coef > 0)) {
time_effect <- "weakens"
} else {
time_effect <- "strengthens"
}
cat(" Baseline effect: ", baseline_effect, " risk (HR = ", round(exp(main_coef), 2), ")\n", sep="")
cat(" Time effect: Effect ", time_effect, " over time (HR per year = ",
round(exp(time_coef), 3), ", p = ", format.pval(time_p, digits = 3), ")\n", sep="")
# Calculate effect at different time points
times <- c(1, 3, 5, 10)
cat(" Effect at different time points:\n")
for(t in times) {
effect_at_t <- main_coef + time_coef * t
hr_at_t <- exp(effect_at_t)
cat(" At t =", t, "years: HR =", round(hr_at_t, 3),
"Effect =", ifelse(effect_at_t > 0, "increases", "decreases"),
model_name, "risk\n")
}
}
}
}
}
# Return importance data frame with type information
return(list(main_effects = main_effects, time_effects = time_effects))
}
# Apply function to both models
bankruptcy_importance <- analyze_variable_importance(final_bankruptcy_model, "bankruptcy")
=== VARIABLE IMPORTANCE FOR BANKRUPTCY MODEL ===
Ranked Variable Importance (based on statistical significance):
------------------------------------------------------------
1. NIMTA : Importance = 14.2%, HR = 0.12, decreases bankruptcy risk ***
2. LTMTA : Importance = 12.6%, HR = 39.24, increases bankruptcy risk *** (has time-varying effect)
3. wc_ratio : Importance = 9.2%, HR = 0.33, decreases bankruptcy risk ***
4. z_score : Importance = 6.2%, HR = 1.03, increases bankruptcy risk *
5. CASHMTA : Importance = 6.0%, HR = 0.12, decreases bankruptcy risk *
6. current_ratio : Importance = 5.5%, HR = 1.09, increases bankruptcy risk *
7. gdp_deflator : Importance = 5.3%, HR = 0.84, decreases bankruptcy risk . [MACROECONOMIC VARIABLE]
8. MBE : Importance = 5.2%, HR = 0.85, decreases bankruptcy risk .
9. asset_turnover : Importance = 4.7%, HR = 0.84, decreases bankruptcy risk .
10. gdp_growth : Importance = 4.7%, HR = 1.10, increases bankruptcy risk . [MACROECONOMIC VARIABLE]
Significance codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
Top 5 Variables by Importance:
-----------------------------
NIMTA |####### 14.2%
LTMTA |###### 12.6%
wc_ratio |##### 9.2%
z_score |### 6.2%
CASHMTA |### 6.0%
ANALYSIS OF MACROECONOMIC VARIABLES:
----------------------------------
gdp_deflator : Overall rank #7 (Importance = 5.3%)
Effect: decreases bankruptcy risk (HR = 0.84, p = 0.0511)
Economic interpretation: Higher inflation is associated with LOWER bankruptcy risk
This counterintuitive finding might reflect:
- Inflation benefiting debtors by reducing real debt burden
- Price increases helping company revenues in certain sectors
gdp_growth : Overall rank #10 (Importance = 4.7%)
Effect: increases bankruptcy risk (HR = 1.10, p = 0.0840)
Economic interpretation: Stronger economic growth is associated with HIGHER bankruptcy risk
This may indicate that during economic expansions, either:
- Companies take on more risk, leading to vulnerability
- More competitive pressure during growth periods
unemployement : Overall rank #16 (Importance = 2.9%)
Effect: decreases bankruptcy risk (HR = 0.93, p = 0.2777)
Economic interpretation: Higher unemployment is associated with LOWER bankruptcy risk
This counterintuitive finding might reflect:
- Labor cost savings for businesses during high unemployment
- Survival bias where only stronger companies remain after economic downturns
Time-Varying Effects Analysis:
-----------------------------
Time-varying effects for FINANCIAL variables:
acquisition_importance <- analyze_variable_importance(final_acquisition_model, "acquisition")
=== VARIABLE IMPORTANCE FOR ACQUISITION MODEL ===
Ranked Variable Importance (based on statistical significance):
------------------------------------------------------------
1. MBE : Importance = 19.9%, HR = 0.79, decreases acquisition risk ***
2. PRICE : Importance = 12.7%, HR = 1.14, increases acquisition risk ***
3. current_ratio : Importance = 10.4%, HR = 0.93, decreases acquisition risk ***
4. cash_to_assets : Importance = 8.8%, HR = 2.09, increases acquisition risk ***
5. unemployement : Importance = 8.4%, HR = 0.87, decreases acquisition risk *** (has time-varying effect) [MACROECONOMIC VARIABLE]
6. wc_ratio : Importance = 7.0%, HR = 0.49, decreases acquisition risk *** (has time-varying effect)
7. receivables_turnover: Importance = 6.5%, HR = 1.00, decreases acquisition risk ***
8. asset_turnover : Importance = 6.4%, HR = 0.83, decreases acquisition risk ** (has time-varying effect)
9. gp_margin : Importance = 5.5%, HR = 1.03, increases acquisition risk **
10. gdp_growth : Importance = 4.8%, HR = 1.04, increases acquisition risk * [MACROECONOMIC VARIABLE]
Significance codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
Top 5 Variables by Importance:
-----------------------------
MBE |########## 19.9%
PRICE |###### 12.7%
current_ratio |##### 10.4%
cash_to_assets |#### 8.8%
unemployement (M) |#### 8.4%
ANALYSIS OF MACROECONOMIC VARIABLES:
----------------------------------
unemployement : Overall rank #5 (Importance = 8.4%)
Effect: decreases acquisition risk (HR = 0.87, p = 0.0000)
Economic interpretation: Higher unemployment is associated with LOWER acquisition risk
This counterintuitive finding might reflect:
- Labor cost savings for businesses during high unemployment
- Survival bias where only stronger companies remain after economic downturns
Time-varying effect: The protective effect of this economic factor WEAKENS as companies age
Young companies benefit more from this economic condition
Impact at different company ages:
Year 1 : HR = 0.882 (decreases risk by 11.8%)
Year 3 : HR = 0.897 (decreases risk by 10.3%)
Year 5 : HR = 0.912 (decreases risk by 8.8%)
Year 10: HR = 0.950 (decreases risk by 5.0%)
gdp_growth : Overall rank #10 (Importance = 4.8%)
Effect: increases acquisition risk (HR = 1.04, p = 0.0131)
Economic interpretation: Stronger economic growth is associated with HIGHER acquisition risk
This may indicate that during economic expansions, either:
- Companies take on more risk, leading to vulnerability
- More competitive pressure during growth periods
gdp_deflator : Overall rank #12 (Importance = 3.4%)
Effect: decreases acquisition risk (HR = 0.96, p = 0.0852)
Economic interpretation: Higher inflation is associated with LOWER acquisition risk
This counterintuitive finding might reflect:
- Inflation benefiting debtors by reducing real debt burden
- Price increases helping company revenues in certain sectors
Time-Varying Effects Analysis:
-----------------------------
Time-varying effects for FINANCIAL variables:
Time-varying importance for wc_ratio :
Baseline effect: decreases risk (HR = 0.49)
Time effect: Effect weakens over time (HR per year = 1.048, p = 0.000271)
Effect at different time points:
At t = 1 years: HR = 0.514 Effect = decreases acquisition risk
At t = 3 years: HR = 0.565 Effect = decreases acquisition risk
At t = 5 years: HR = 0.619 Effect = decreases acquisition risk
At t = 10 years: HR = 0.781 Effect = decreases acquisition risk
Time-varying importance for asset_turnover :
Baseline effect: decreases risk (HR = 0.83)
Time effect: Effect weakens over time (HR per year = 1.013, p = 0.00238)
Effect at different time points:
At t = 1 years: HR = 0.84 Effect = decreases acquisition risk
At t = 3 years: HR = 0.862 Effect = decreases acquisition risk
At t = 5 years: HR = 0.885 Effect = decreases acquisition risk
At t = 10 years: HR = 0.944 Effect = decreases acquisition risk
# Compare variable importance between models
cat("\nCOMPARING KEY PREDICTORS BETWEEN MODELS:\n")
COMPARING KEY PREDICTORS BETWEEN MODELS:
cat("--------------------------------------\n")
--------------------------------------
# Identify common top predictors
bank_top <- head(bankruptcy_importance$main_effects$Variable, 10)
acq_top <- head(acquisition_importance$main_effects$Variable, 10)
common_predictors <- intersect(bank_top, acq_top)
if(length(common_predictors) > 0) {
cat("Variables important for both bankruptcy and acquisition prediction:\n")
for(var in common_predictors) {
bank_rank <- which(bankruptcy_importance$main_effects$Variable == var)
acq_rank <- which(acquisition_importance$main_effects$Variable == var)
bank_coef <- bankruptcy_importance$main_effects$Coefficient[bank_rank]
acq_coef <- acquisition_importance$main_effects$Coefficient[acq_rank]
# Check if it's a macro variable
is_macro <- var %in% c("gdp_growth", "gdp_deflator", "unemployement")
macro_label <- ifelse(is_macro, " [MACRO]", "")
# Check for opposite effects
if(sign(bank_coef) != sign(acq_coef)) {
cat(sprintf("- %-15s: Rank #%d in bankruptcy model, #%d in acquisition model%s\n *** Has OPPOSITE effects: %s bankruptcy risk but %s acquisition risk ***\n",
var, bank_rank, acq_rank, macro_label,
ifelse(bank_coef > 0, "increases", "decreases"),
ifelse(acq_coef > 0, "increases", "decreases")))
} else {
cat(sprintf("- %-15s: Rank #%d in bankruptcy model, #%d in acquisition model%s\n",
var, bank_rank, acq_rank, macro_label))
}
}
} else {
cat("No common variables among top 10 predictors of both models.\n")
}
Variables important for both bankruptcy and acquisition prediction:
- wc_ratio : Rank #3 in bankruptcy model, #6 in acquisition model
- current_ratio : Rank #6 in bankruptcy model, #3 in acquisition model
*** Has OPPOSITE effects: increases bankruptcy risk but decreases acquisition risk ***
- MBE : Rank #8 in bankruptcy model, #1 in acquisition model
- asset_turnover : Rank #9 in bankruptcy model, #8 in acquisition model
- gdp_growth : Rank #10 in bankruptcy model, #10 in acquisition model [MACRO]
cat("\nUnique predictors for bankruptcy (not in top 10 for acquisition):\n")
Unique predictors for bankruptcy (not in top 10 for acquisition):
unique_bank <- setdiff(bank_top, acq_top)
for(var in unique_bank) {
bank_rank <- which(bankruptcy_importance$main_effects$Variable == var)
# Check if it's a macro variable
is_macro <- var %in% c("gdp_growth", "gdp_deflator", "unemployement")
macro_label <- ifelse(is_macro, " [MACRO]", "")
cat(sprintf("- %-15s: Rank #%d in bankruptcy model%s\n", var, bank_rank, macro_label))
}
- NIMTA : Rank #1 in bankruptcy model
- LTMTA : Rank #2 in bankruptcy model
- z_score : Rank #4 in bankruptcy model
- CASHMTA : Rank #5 in bankruptcy model
- gdp_deflator : Rank #7 in bankruptcy model [MACRO]
cat("\nUnique predictors for acquisition (not in top 10 for bankruptcy):\n")
Unique predictors for acquisition (not in top 10 for bankruptcy):
unique_acq <- setdiff(acq_top, bank_top)
for(var in unique_acq) {
acq_rank <- which(acquisition_importance$main_effects$Variable == var)
# Check if it's a macro variable
is_macro <- var %in% c("gdp_growth", "gdp_deflator", "unemployement")
macro_label <- ifelse(is_macro, " [MACRO]", "")
cat(sprintf("- %-15s: Rank #%d in acquisition model%s\n", var, acq_rank, macro_label))
}
- PRICE : Rank #2 in acquisition model
- cash_to_assets : Rank #4 in acquisition model
- unemployement : Rank #5 in acquisition model [MACRO]
- receivables_turnover: Rank #7 in acquisition model
- gp_margin : Rank #9 in acquisition model
# Specific comparison of macro variables between models
cat("\nCOMPARATIVE ANALYSIS OF MACROECONOMIC VARIABLES:\n")
COMPARATIVE ANALYSIS OF MACROECONOMIC VARIABLES:
cat("-------------------------------------------\n")
-------------------------------------------
macro_vars <- c("gdp_growth", "gdp_deflator", "unemployement")
bank_macro <- bankruptcy_importance$main_effects[bankruptcy_importance$main_effects$Variable %in% macro_vars, ]
acq_macro <- acquisition_importance$main_effects[acquisition_importance$main_effects$Variable %in% macro_vars, ]
if(nrow(bank_macro) > 0 || nrow(acq_macro) > 0) {
# Combine all macro variables from both models
all_macro <- unique(c(bank_macro$Variable, acq_macro$Variable))
for(var in all_macro) {
cat("\nMacroeconomic variable:", var, "\n")
cat("----------------------------------------\n")
# Get stats for bankruptcy model
if(var %in% bank_macro$Variable) {
bank_row <- bank_macro[bank_macro$Variable == var, ]
bank_rank <- which(bankruptcy_importance$main_effects$Variable == var)
bank_hr <- bank_row$HR
bank_coef <- bank_row$Coefficient
bank_p <- bank_row$P_Value
bank_imp <- bank_row$Standardized_Importance
cat("Bankruptcy model:\n")
cat(" Rank:", bank_rank, "of", nrow(bankruptcy_importance$main_effects), "\n")
cat(" Importance:", round(bank_imp, 1), "%\n")
cat(" Effect:", ifelse(bank_coef > 0, "Increases", "Decreases"),
"risk (HR =", round(bank_hr, 2), ")\n")
cat(" Significance:", ifelse(bank_p < 0.05, "Significant", "Not significant"),
"(p =", format.pval(bank_p, digits = 3), ")\n")
# Check for time interaction
bank_time_var <- paste0(var, ":tt") %in% bankruptcy_importance$time_effects$Variable
if(bank_time_var) {
bank_time_row <- bankruptcy_importance$time_effects[bankruptcy_importance$time_effects$Variable == paste0(var, ":tt"), ]
bank_time_coef <- bank_time_row$Coefficient
bank_time_p <- bank_time_row$P_Value
if(bank_time_p < 0.1) {
cat(" Time-varying effect:", ifelse(bank_time_coef > 0, "Strengthens", "Weakens"),
"with age (p =", format.pval(bank_time_p, digits = 3), ")\n")
}
}
} else {
cat("Bankruptcy model: Not included\n")
}
# Get stats for acquisition model
if(var %in% acq_macro$Variable) {
acq_row <- acq_macro[acq_macro$Variable == var, ]
acq_rank <- which(acquisition_importance$main_effects$Variable == var)
acq_hr <- acq_row$HR
acq_coef <- acq_row$Coefficient
acq_p <- acq_row$P_Value
acq_imp <- acq_row$Standardized_Importance
cat("\nAcquisition model:\n")
cat(" Rank:", acq_rank, "of", nrow(acquisition_importance$main_effects), "\n")
cat(" Importance:", round(acq_imp, 1), "%\n")
cat(" Effect:", ifelse(acq_coef > 0, "Increases", "Decreases"),
"risk (HR =", round(acq_hr, 2), ")\n")
cat(" Significance:", ifelse(acq_p < 0.05, "Significant", "Not significant"),
"(p =", format.pval(acq_p, digits = 3), ")\n")
# Check for time interaction
acq_time_var <- paste0(var, ":tt") %in% acquisition_importance$time_effects$Variable
if(acq_time_var) {
acq_time_row <- acquisition_importance$time_effects[acquisition_importance$time_effects$Variable == paste0(var, ":tt"), ]
acq_time_coef <- acq_time_row$Coefficient
acq_time_p <- acq_time_row$P_Value
if(acq_time_p < 0.1) {
cat(" Time-varying effect:", ifelse(acq_time_coef > 0, "Strengthens", "Weakens"),
"with age (p =", format.pval(acq_time_p, digits = 3), ")\n")
}
}
} else {
cat("\nAcquisition model: Not included\n")
}
# Comparison between models if variable is in both
if(var %in% bank_macro$Variable && var %in% acq_macro$Variable) {
bank_row <- bank_macro[bank_macro$Variable == var, ]
acq_row <- acq_macro[acq_macro$Variable == var, ]
cat("\nComparison:\n")
# Compare directions
if(sign(bank_row$Coefficient) == sign(acq_row$Coefficient)) {
cat(" Direction: Same direction in both models (",
ifelse(bank_row$Coefficient > 0, "increases", "decreases"), " risk)\n", sep="")
} else {
cat(" Direction: OPPOSITE effects between models\n")
cat(" - ", ifelse(bank_row$Coefficient > 0, "Increases", "Decreases"),
" bankruptcy risk\n", sep="")
cat(" - ", ifelse(acq_row$Coefficient > 0, "Increases", "Decreases"),
" acquisition risk\n", sep="")
}
# Compare relative importance
if(bank_row$Standardized_Importance > acq_row$Standardized_Importance) {
ratio <- bank_row$Standardized_Importance / acq_row$Standardized_Importance
cat(" Importance: ", round(ratio, 1), "x more important for bankruptcy than acquisition\n", sep="")
} else {
ratio <- acq_row$Standardized_Importance / bank_row$Standardized_Importance
cat(" Importance: ", round(ratio, 1), "x more important for acquisition than bankruptcy\n", sep="")
}
# Economic interpretation
cat(" Economic insight: ")
if(var == "gdp_growth") {
if(sign(bank_row$Coefficient) != sign(acq_row$Coefficient)) {
cat("Economic growth has divergent effects on company outcomes\n")
if(bank_row$Coefficient < 0 && acq_row$Coefficient > 0) {
cat(" - Growth periods reduce bankruptcy risk but increase acquisition activity\n")
cat(" - This suggests acquisitions are more opportunity-driven during expansions\n")
cat(" - While bankruptcies are more threat-driven during contractions\n")
} else {
cat(" - Unusual pattern: Growth increases bankruptcy risk but reduces acquisitions\n")
cat(" - This might indicate market distortions or industry-specific effects\n")
}
} else {
cat("Economic growth affects both outcomes in the same direction\n")
cat(" - This suggests systemic economic forces drive both processes similarly\n")
}
} else if(var == "unemployement") {
if(sign(bank_row$Coefficient) != sign(acq_row$Coefficient)) {
cat("Labor market conditions have divergent effects on company outcomes\n")
if(bank_row$Coefficient > 0 && acq_row$Coefficient < 0) {
cat(" - High unemployment increases bankruptcy risk but reduces acquisition activity\n")
cat(" - This aligns with economic theory that distressed M&A decreases in recessions\n")
cat(" - Poor labor markets may limit buyers' ability to finance acquisitions\n")
} else {
cat(" - Unusual pattern: High unemployment reduces bankruptcy risk but increases acquisitions\n")
cat(" - This might indicate industry-specific labor market effects\n")
}
} else {
cat("Labor market conditions affect both outcomes in the same direction\n")
cat(" - This suggests unemployment serves as a general economic indicator\n")
}
} else if(var == "gdp_deflator") {
if(sign(bank_row$Coefficient) != sign(acq_row$Coefficient)) {
cat("Inflation has divergent effects on company outcomes\n")
if(bank_row$Coefficient > 0 && acq_row$Coefficient < 0) {
cat(" - Higher inflation increases bankruptcy risk but reduces acquisition activity\n")
cat(" - This suggests inflation creates operational challenges while depressing M&A markets\n")
cat(" - Inflation uncertainty may limit buyers' willingness to make long-term commitments\n")
} else {
cat(" - Unusual pattern: Inflation reduces bankruptcy risk but increases acquisitions\n")
cat(" - This might indicate inflation benefits debtors while creating buying opportunities\n")
}
} else {
cat("Inflation affects both outcomes in the same direction\n")
cat(" - This suggests inflation serves as a general economic indicator\n")
}
}
}
cat("\n")
}
} else {
cat("No macroeconomic variables in either model.\n")
}
Macroeconomic variable: gdp_deflator
----------------------------------------
Bankruptcy model:
Rank: 7 of 20
Importance: 5.3 %
Effect: Decreases risk (HR = 0.84 )
Significance: Not significant (p = 0.0511 )
Acquisition model:
Rank: 12 of 15
Importance: 3.4 %
Effect: Decreases risk (HR = 0.96 )
Significance: Not significant (p = 0.0852 )
Comparison:
Direction: Same direction in both models (decreases risk)
Importance: 1.6x more important for bankruptcy than acquisition
Economic insight: Inflation affects both outcomes in the same direction
- This suggests inflation serves as a general economic indicator
Macroeconomic variable: gdp_growth
----------------------------------------
Bankruptcy model:
Rank: 10 of 20
Importance: 4.7 %
Effect: Increases risk (HR = 1.1 )
Significance: Not significant (p = 0.084 )
Acquisition model:
Rank: 10 of 15
Importance: 4.8 %
Effect: Increases risk (HR = 1.04 )
Significance: Significant (p = 0.0131 )
Comparison:
Direction: Same direction in both models (increases risk)
Importance: 1x more important for acquisition than bankruptcy
Economic insight: Economic growth affects both outcomes in the same direction
- This suggests systemic economic forces drive both processes similarly
Macroeconomic variable: unemployement
----------------------------------------
Bankruptcy model:
Rank: 16 of 20
Importance: 2.9 %
Effect: Decreases risk (HR = 0.93 )
Significance: Not significant (p = 0.278 )
Acquisition model:
Rank: 5 of 15
Importance: 8.4 %
Effect: Decreases risk (HR = 0.87 )
Significance: Significant (p = 1.71e-05 )
Time-varying effect: Strengthens with age (p = 3.45e-05 )
Comparison:
Direction: Same direction in both models (decreases risk)
Importance: 2.9x more important for acquisition than bankruptcy
Economic insight: Labor market conditions affect both outcomes in the same direction
- This suggests unemployment serves as a general economic indicator
# Save variable importance information
variable_importance <- list(
bankruptcy = bankruptcy_importance,
acquisition = acquisition_importance
)
Not sure about this approach ! But, we predict the risk scores for the last observation of each company in the dataset. We then use these scores to evaluate the model’s performance using ROC analysis. The function also allows for a comparison of the model with and without macroeconomic variables, providing insights into their contribution to predictive performance.
#-------------------------------------------------------------
# 11.4: Prediction Performance Analysis with Macro Impact Assessment
#-------------------------------------------------------------
cat("\n11.4: PREDICTION PERFORMANCE ANALYSIS WITH MACRO IMPACT ASSESSMENT\n")
11.4: PREDICTION PERFORMANCE ANALYSIS WITH MACRO IMPACT ASSESSMENT
cat("--------------------------------------\n")
--------------------------------------
# Function to evaluate prediction performance
evaluate_prediction_performance <- function(model, model_name, event_type, assess_macro_impact = TRUE) {
cat("\nEvaluating prediction performance for", model_name, "model...\n")
# Get last observation for each company
last_obs_data <- data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Calculate risk scores from full model
risk_scores <- predict(model, newdata = last_obs_data, type = "risk")
# Add scores to data
last_obs_data$risk_score <- risk_scores
# If requested, create model without macro variables for comparison
if(assess_macro_impact) {
cat("\nAssessing impact of macroeconomic variables on predictive performance...\n")
# Identify macro variables in the model
macro_vars <- c("gdp_growth", "gdp_deflator", "unemployement")
model_vars <- names(coef(model))
macro_terms <- c()
for(var in model_vars) {
# Check if variable contains any macro variable name
# This handles both main effects and interactions
is_macro <- FALSE
for(macro in macro_vars) {
if(grepl(macro, var)) {
is_macro <- TRUE
break
}
}
if(is_macro) {
macro_terms <- c(macro_terms, var)
}
}
if(length(macro_terms) > 0) {
cat("Found", length(macro_terms), "macroeconomic terms in model:\n")
for(term in macro_terms) {
cat("- ", term, "\n")
}
# Create model without macro variables
no_macro_formula <- formula(model)
for(term in macro_terms) {
no_macro_formula <- update(no_macro_formula, paste0(". ~ . - ", term))
}
# Fit model without macro variables
no_macro_model <- coxph(no_macro_formula, data = data, ties = "efron")
# Calculate risk scores without macro variables
no_macro_scores <- predict(no_macro_model, newdata = last_obs_data, type = "risk")
last_obs_data$no_macro_score <- no_macro_scores
} else {
cat("No macroeconomic variables found in the model.\n")
no_macro_model <- NULL
}
}
# Evaluate discrimination with ROC curve analysis
if(requireNamespace("pROC", quietly = TRUE)) {
library(pROC)
# Create ROC object for full model
roc_obj <- tryCatch({
roc(last_obs_data[[event_type]], risk_scores, quiet = TRUE)
}, error = function(e) {
cat("Error calculating ROC:", e$message, "\n")
return(NULL)
})
# If assessing macro impact and we have a no-macro model, create ROC for it too
if(assess_macro_impact && !is.null(no_macro_model)) {
no_macro_roc <- tryCatch({
roc(last_obs_data[[event_type]], no_macro_scores, quiet = TRUE)
}, error = function(e) {
cat("Error calculating ROC for no-macro model:", e$message, "\n")
no_macro_roc <- NULL
})
} else {
no_macro_roc <- NULL
}
if(!is.null(roc_obj)) {
# Calculate AUC and confidence interval
auc_value <- auc(roc_obj)
ci_values <- ci(roc_obj)
cat("\nDiscrimination Metrics:\n")
cat("-----------------------\n")
cat("AUC (Area Under ROC Curve):", round(auc_value, 4), "\n")
cat("95% Confidence Interval:", paste(round(ci_values[1:2], 4), collapse=" - "), "\n")
# Compare with no-macro model if available
if(!is.null(no_macro_roc)) {
no_macro_auc <- auc(no_macro_roc)
auc_diff <- auc_value - no_macro_auc
pct_improvement <- auc_diff / no_macro_auc * 100
cat("\nMacroeconomic Variables Contribution to AUC:\n")
cat("------------------------------------------\n")
cat("AUC with macro variables:", round(auc_value, 4), "\n")
cat("AUC without macro variables:", round(no_macro_auc, 4), "\n")
cat("Absolute improvement:", round(auc_diff, 4), "\n")
cat("Relative improvement:", round(pct_improvement, 2), "%\n")
# Test if improvement is significant
if(requireNamespace("pROC", quietly = TRUE)) {
roc_test <- roc.test(roc_obj, no_macro_roc, method="delong")
cat("Statistical significance: p =", format.pval(roc_test$p.value, digits = 3), "\n")
if(roc_test$p.value < 0.05) {
cat("The improvement from macroeconomic variables is statistically significant (p < 0.05)\n")
} else {
cat("The improvement from macroeconomic variables is not statistically significant (p >= 0.05)\n")
}
}
}
# Calculate sensitivity and specificity at optimal threshold
coord_results <- coords(roc_obj, "best", ret = c("threshold", "sensitivity", "specificity"))
optimal_threshold <- as.numeric(coord_results["threshold"])
optimal_sensitivity <- as.numeric(coord_results["sensitivity"])
optimal_specificity <- as.numeric(coord_results["specificity"])
cat("\nOptimal threshold:", round(optimal_threshold, 4), "\n")
cat("Sensitivity at optimal threshold:", round(optimal_sensitivity, 4), "\n")
cat("Specificity at optimal threshold:", round(optimal_specificity, 4), "\n")
# Additional performance metrics
# Count events
n_events <- sum(last_obs_data[[event_type]])
n_total <- nrow(last_obs_data)
# Calculate predictions at optimal threshold
predictions <- ifelse(risk_scores >= optimal_threshold, 1, 0)
# Confusion matrix
TP <- sum(predictions == 1 & last_obs_data[[event_type]] == 1)
TN <- sum(predictions == 0 & last_obs_data[[event_type]] == 0)
FP <- sum(predictions == 1 & last_obs_data[[event_type]] == 0)
FN <- sum(predictions == 0 & last_obs_data[[event_type]] == 1)
# Calculate additional metrics
accuracy <- (TP + TN) / (TP + TN + FP + FN)
precision <- TP / (TP + FP)
recall <- TP / (TP + FN) # same as sensitivity
f1_score <- 2 * precision * recall / (precision + recall)
ppv <- TP / (TP + FP) # positive predictive value
npv <- TN / (TN + FN) # negative predictive value
cat("\nAdditional Performance Metrics:\n")
cat("------------------------------\n")
cat("Total companies:", n_total, "\n")
cat("Number of", model_name, "events:", n_events,
"(", round(100*n_events/n_total, 1), "%)\n")
cat("Accuracy:", round(accuracy, 4), "\n")
cat("Precision (PPV):", round(precision, 4), "\n")
cat("Recall (Sensitivity):", round(recall, 4), "\n")
cat("F1 Score:", round(f1_score, 4), "\n")
cat("Negative Predictive Value:", round(npv, 4), "\n")
# Calculate the same metrics for the no-macro model if available
if(!is.null(no_macro_roc)) {
# Find optimal threshold for no-macro model
no_macro_coords <- coords(no_macro_roc, "best", ret = c("threshold", "sensitivity", "specificity"))
no_macro_threshold <- as.numeric(no_macro_coords["threshold"])
# Calculate predictions using no-macro scores
no_macro_predictions <- ifelse(no_macro_scores >= no_macro_threshold, 1, 0)
# Confusion matrix for no-macro model
no_macro_TP <- sum(no_macro_predictions == 1 & last_obs_data[[event_type]] == 1)
no_macro_TN <- sum(no_macro_predictions == 0 & last_obs_data[[event_type]] == 0)
no_macro_FP <- sum(no_macro_predictions == 1 & last_obs_data[[event_type]] == 0)
no_macro_FN <- sum(no_macro_predictions == 0 & last_obs_data[[event_type]] == 1)
# Calculate metrics for no-macro model
no_macro_accuracy <- (no_macro_TP + no_macro_TN) / (no_macro_TP + no_macro_TN + no_macro_FP + no_macro_FN)
no_macro_precision <- no_macro_TP / (no_macro_TP + no_macro_FP)
no_macro_recall <- no_macro_TP / (no_macro_TP + no_macro_FN)
no_macro_f1 <- 2 * no_macro_precision * no_macro_recall / (no_macro_precision + no_macro_recall)
cat("\nComparison with Model Without Macroeconomic Variables:\n")
cat("----------------------------------------------------\n")
metrics <- c("Accuracy", "Precision", "Recall", "F1 Score")
full_values <- c(accuracy, precision, recall, f1_score)
no_macro_values <- c(no_macro_accuracy, no_macro_precision, no_macro_recall, no_macro_f1)
for(i in 1:length(metrics)) {
diff <- full_values[i] - no_macro_values[i]
pct_diff <- diff / no_macro_values[i] * 100
cat(sprintf("%-10s: With macro = %6.4f, Without macro = %6.4f (Δ = %+6.4f, %+5.1f%%)\n",
metrics[i], full_values[i], no_macro_values[i], diff, pct_diff))
}
}
# Risk distribution analysis
risk_quantiles <- quantile(risk_scores, probs = seq(0, 1, 0.25))
cat("\nRisk Score Distribution:\n")
cat("------------------------\n")
cat("Minimum:", round(min(risk_scores), 4), "\n")
cat("25th percentile:", round(risk_quantiles[2], 4), "\n")
cat("Median:", round(median(risk_scores), 4), "\n")
cat("75th percentile:", round(risk_quantiles[4], 4), "\n")
cat("Maximum:", round(max(risk_scores), 4), "\n")
# Risk stratification
cat("\nEvent Rates by Risk Quartile:\n")
last_obs_data$risk_quartile <- cut(risk_scores,
breaks = risk_quantiles,
include.lowest = TRUE,
labels = c("Q1 (Lowest)", "Q2", "Q3", "Q4 (Highest)"))
# Use traditional approach for compatibility
event_by_quartile <- aggregate(
last_obs_data[[event_type]],
by = list(risk_quartile = last_obs_data$risk_quartile),
FUN = function(x) c(events = sum(x), n = length(x), rate = mean(x))
)
for(i in 1:nrow(event_by_quartile)) {
q <- event_by_quartile$risk_quartile[i]
stats <- event_by_quartile$x[i,]
events <- stats["events"]
n <- stats["n"]
rate <- stats["rate"]
cat(q, ": ", events, " events out of ", n, " companies (",
round(100*rate, 1), "%)\n", sep="")
}
# If macro assessment is enabled and we have both models, analyze macro impact on risk stratification
if(assess_macro_impact && !is.null(no_macro_roc)) {
cat("\nMacroeconomic Impact on Risk Stratification:\n")
cat("-----------------------------------------\n")
# Get companies in highest risk quartile according to both models
full_high_risk <- last_obs_data$cusip[last_obs_data$risk_quartile == "Q4 (Highest)"]
# Create risk quartiles for no-macro model
no_macro_quantiles <- quantile(no_macro_scores, probs = seq(0, 1, 0.25))
last_obs_data$no_macro_quartile <- cut(no_macro_scores,
breaks = no_macro_quantiles,
include.lowest = TRUE,
labels = c("Q1 (Lowest)", "Q2", "Q3", "Q4 (Highest)"))
no_macro_high_risk <- last_obs_data$cusip[last_obs_data$no_macro_quartile == "Q4 (Highest)"]
# Find companies that changed risk classification due to macro variables
moved_to_high <- setdiff(full_high_risk, no_macro_high_risk)
moved_from_high <- setdiff(no_macro_high_risk, full_high_risk)
cat("Companies reclassified to highest risk quartile when using macro variables:", length(moved_to_high), "\n")
cat("Companies moved out of highest risk quartile when using macro variables:", length(moved_from_high), "\n")
# Check if reclassification improved prediction
if(length(moved_to_high) > 0) {
moved_to_high_data <- last_obs_data[last_obs_data$cusip %in% moved_to_high, ]
event_rate_moved_to_high <- mean(moved_to_high_data[[event_type]])
cat("Event rate among companies moved to highest risk quartile:",
round(100*event_rate_moved_to_high, 1), "%\n")
}
if(length(moved_from_high) > 0) {
moved_from_high_data <- last_obs_data[last_obs_data$cusip %in% moved_from_high, ]
event_rate_moved_from_high <- mean(moved_from_high_data[[event_type]])
cat("Event rate among companies moved from highest risk quartile:",
round(100*event_rate_moved_from_high, 1), "%\n")
}
# Assess accuracy of reclassification
if(length(moved_to_high) > 0 && length(moved_from_high) > 0) {
if(event_rate_moved_to_high > event_rate_moved_from_high) {
cat("\nReclassification analysis: Macroeconomic variables IMPROVED risk stratification\n")
cat("Companies moved to high risk had higher event rates than those moved out of high risk\n")
} else {
cat("\nReclassification analysis: Macroeconomic variables did NOT improve risk stratification\n")
cat("Companies moved to high risk had lower event rates than those moved out of high risk\n")
}
}
}
# Economic condition analysis - examine how prediction varies with economic conditions
if(assess_macro_impact && !is.null(no_macro_model)) {
cat("\nPrediction Performance Across Economic Conditions:\n")
cat("-----------------------------------------------\n")
# Check if we have economic indicators in the data
if(all(c("gdp_growth", "unemployement") %in% colnames(last_obs_data))) {
# Define economic conditions
median_gdp <- median(last_obs_data$gdp_growth, na.rm = TRUE)
median_unemp <- median(last_obs_data$unemployement, na.rm = TRUE)
# Create economic condition groups
last_obs_data$econ_condition <- "Mixed"
last_obs_data$econ_condition[last_obs_data$gdp_growth > median_gdp &
last_obs_data$unemployement < median_unemp] <- "Strong"
last_obs_data$econ_condition[last_obs_data$gdp_growth < median_gdp &
last_obs_data$unemployement > median_unemp] <- "Weak"
# Calculate AUC by economic condition for both models
for(condition in c("Strong", "Mixed", "Weak")) {
condition_data <- last_obs_data[last_obs_data$econ_condition == condition, ]
if(nrow(condition_data) > 0 && sum(condition_data[[event_type]]) > 0) {
cat("\nEconomic condition:", condition, "(", nrow(condition_data), "companies)\n")
# Calculate AUC for full model
condition_roc <- tryCatch({
roc(condition_data[[event_type]], condition_data$risk_score, quiet= TRUE)
}, error = function(e) NULL)
# Calculate AUC for no-macro model
condition_no_macro_roc <- tryCatch({
roc(condition_data[[event_type]], condition_data$no_macro_score, quiet= TRUE)
}, error = function(e) NULL)
if(!is.null(condition_roc) && !is.null(condition_no_macro_roc)) {
condition_auc <- auc(condition_roc)
condition_no_macro_auc <- auc(condition_no_macro_roc)
auc_diff <- condition_auc - condition_no_macro_auc
cat("Full model AUC:", round(condition_auc, 4), "\n")
cat("No-macro model AUC:", round(condition_no_macro_auc, 4), "\n")
cat("Improvement from macro variables:", round(auc_diff, 4), "\n")
if(auc_diff > 0) {
cat("Macroeconomic variables improve prediction in", condition, "economic conditions\n")
} else {
cat("Macroeconomic variables do not improve prediction in", condition, "economic conditions\n")
}
} else {
cat("Could not calculate AUC for this economic condition due to insufficient data\n")
}
} else {
cat("\nEconomic condition:", condition, "- insufficient data for analysis\n")
}
}
} else {
cat("Economic indicators not available in dataset for condition-specific analysis\n")
}
}
# Return performance metrics
return(list(
auc = auc_value,
ci = ci_values,
optimal_threshold = optimal_threshold,
sensitivity = optimal_sensitivity,
specificity = optimal_specificity,
accuracy = accuracy,
precision = precision,
recall = recall,
f1_score = f1_score,
risk_quantiles = risk_quantiles,
no_macro_model = if(exists("no_macro_model")) no_macro_model else NULL,
no_macro_auc = if(exists("no_macro_auc")) no_macro_auc else NULL,
no_macro_metrics = if(exists("no_macro_values"))
list(accuracy = no_macro_accuracy,
precision = no_macro_precision,
recall = no_macro_recall,
f1 = no_macro_f1) else NULL
))
} else {
cat("Could not calculate ROC curve.\n")
return(NULL)
}
} else {
cat("pROC package not available for ROC analysis.\n")
return(NULL)
}
}
# Apply function to both models
bankruptcy_performance <- evaluate_prediction_performance(final_bankruptcy_model, "bankruptcy", "bankruptcy")
Evaluating prediction performance for bankruptcy model...
Assessing impact of macroeconomic variables on predictive performance...
Found 3 macroeconomic terms in model:
- gdp_deflator
- unemployement
- gdp_growth
Discrimination Metrics:
-----------------------
AUC (Area Under ROC Curve): 0.8183
95% Confidence Interval: 0.7901 - 0.8183
Macroeconomic Variables Contribution to AUC:
------------------------------------------
AUC with macro variables: 0.8183
AUC without macro variables: 0.8106
Absolute improvement: 0.0077
Relative improvement: 0.96 %
Statistical significance: p = 0.00142
The improvement from macroeconomic variables is statistically significant (p < 0.05)
Optimal threshold: 3.2518
Sensitivity at optimal threshold: 0.8523
Specificity at optimal threshold: 0.6972
Additional Performance Metrics:
------------------------------
Total companies: 5038
Number of bankruptcy events: 176 ( 3.5 %)
Accuracy: 0.7027
Precision (PPV): 0.0925
Recall (Sensitivity): 0.8523
F1 Score: 0.1669
Negative Predictive Value: 0.9924
Comparison with Model Without Macroeconomic Variables:
----------------------------------------------------
Accuracy : With macro = 0.7027, Without macro = 0.7382 (Δ = -0.0355, -4.8%)
Precision : With macro = 0.0925, Without macro = 0.0984 (Δ = -0.0059, -6.0%)
Recall : With macro = 0.8523, Without macro = 0.7955 (Δ = +0.0568, +7.1%)
F1 Score : With macro = 0.1669, Without macro = 0.1751 (Δ = -0.0083, -4.7%)
Risk Score Distribution:
------------------------
Minimum: 3e-04
25th percentile: 0.5495
Median: 1.4055
75th percentile: 5.2813
Maximum: 850.2138
Event Rates by Risk Quartile:
1: 5 events out of 1260 companies (0.4%)
2: 10 events out of 1259 companies (0.8%)
3: 30 events out of 1259 companies (2.4%)
4: 131 events out of 1260 companies (10.4%)
Macroeconomic Impact on Risk Stratification:
-----------------------------------------
Companies reclassified to highest risk quartile when using macro variables: 62
Companies moved out of highest risk quartile when using macro variables: 62
Event rate among companies moved to highest risk quartile: 9.7 %
Event rate among companies moved from highest risk quartile: 6.5 %
Reclassification analysis: Macroeconomic variables IMPROVED risk stratification
Companies moved to high risk had higher event rates than those moved out of high risk
Prediction Performance Across Economic Conditions:
-----------------------------------------------
Economic condition: Strong ( 335 companies)
Full model AUC: 0.8125
No-macro model AUC: 0.8125
Improvement from macro variables: 0
Macroeconomic variables do not improve prediction in Strong economic conditions
Economic condition: Mixed ( 2921 companies)
Full model AUC: 0.832
No-macro model AUC: 0.8114
Improvement from macro variables: 0.0207
Macroeconomic variables improve prediction in Mixed economic conditions
Economic condition: Weak ( 1782 companies)
Full model AUC: 0.7778
No-macro model AUC: 0.7763
Improvement from macro variables: 0.0015
Macroeconomic variables improve prediction in Weak economic conditions
acquisition_performance <- evaluate_prediction_performance(final_acquisition_model, "acquisition", "acquisition")
Evaluating prediction performance for acquisition model...
Assessing impact of macroeconomic variables on predictive performance...
Found 4 macroeconomic terms in model:
- gdp_deflator
- unemployement
- gdp_growth
- unemployement:tt
Discrimination Metrics:
-----------------------
AUC (Area Under ROC Curve): 0.5272
95% Confidence Interval: 0.5113 - 0.5272
Macroeconomic Variables Contribution to AUC:
------------------------------------------
AUC with macro variables: 0.5272
AUC without macro variables: 0.5818
Absolute improvement: -0.0546
Relative improvement: -9.39 %
Statistical significance: p = <2e-16
The improvement from macroeconomic variables is statistically significant (p < 0.05)
Optimal threshold: 0.9551
Sensitivity at optimal threshold: 0.7804
Specificity at optimal threshold: 0.3152
Additional Performance Metrics:
------------------------------
Total companies: 5038
Number of acquisition events: 2154 ( 42.8 %)
Accuracy: 0.5141
Precision (PPV): 0.4598
Recall (Sensitivity): 0.7804
F1 Score: 0.5787
Negative Predictive Value: 0.6577
Comparison with Model Without Macroeconomic Variables:
----------------------------------------------------
Accuracy : With macro = 0.5141, Without macro = 0.5486 (Δ = -0.0345, -6.3%)
Precision : With macro = 0.4598, Without macro = 0.4833 (Δ = -0.0235, -4.9%)
Recall : With macro = 0.7804, Without macro = 0.8041 (Δ = -0.0237, -2.9%)
F1 Score : With macro = 0.5787, Without macro = 0.6037 (Δ = -0.0250, -4.1%)
Risk Score Distribution:
------------------------
Minimum: 7e-04
25th percentile: 0.9152
Median: 1.3647
75th percentile: 2.2478
Maximum: 15.5969
Event Rates by Risk Quartile:
1: 433 events out of 1260 companies (34.4%)
2: 578 events out of 1259 companies (45.9%)
3: 654 events out of 1259 companies (51.9%)
4: 489 events out of 1260 companies (38.8%)
Macroeconomic Impact on Risk Stratification:
-----------------------------------------
Companies reclassified to highest risk quartile when using macro variables: 273
Companies moved out of highest risk quartile when using macro variables: 273
Event rate among companies moved to highest risk quartile: 31.1 %
Event rate among companies moved from highest risk quartile: 64.8 %
Reclassification analysis: Macroeconomic variables did NOT improve risk stratification
Companies moved to high risk had lower event rates than those moved out of high risk
Prediction Performance Across Economic Conditions:
-----------------------------------------------
Economic condition: Strong ( 335 companies)
Full model AUC: 0.6925
No-macro model AUC: 0.7178
Improvement from macro variables: -0.0253
Macroeconomic variables do not improve prediction in Strong economic conditions
Economic condition: Mixed ( 2921 companies)
Full model AUC: 0.5519
No-macro model AUC: 0.5083
Improvement from macro variables: 0.0436
Macroeconomic variables improve prediction in Mixed economic conditions
Economic condition: Weak ( 1782 companies)
Full model AUC: 0.7043
No-macro model AUC: 0.7646
Improvement from macro variables: -0.0604
Macroeconomic variables do not improve prediction in Weak economic conditions
# Compare key performance metrics
if(!is.null(bankruptcy_performance) && !is.null(acquisition_performance)) {
cat("\nCOMPARISON OF PREDICTION PERFORMANCE:\n")
cat("------------------------------------\n")
metrics <- c("AUC", "Accuracy", "Precision", "Recall", "F1 Score")
bankruptcy_values <- c(
bankruptcy_performance$auc,
bankruptcy_performance$accuracy,
bankruptcy_performance$precision,
bankruptcy_performance$recall,
bankruptcy_performance$f1_score
)
acquisition_values <- c(
acquisition_performance$auc,
acquisition_performance$accuracy,
acquisition_performance$precision,
acquisition_performance$recall,
acquisition_performance$f1_score
)
for(i in 1:length(metrics)) {
cat(sprintf("%-10s: Bankruptcy = %6.4f, Acquisition = %6.4f\n",
metrics[i], bankruptcy_values[i], acquisition_values[i]))
}
# Compare impact of macroeconomic variables between models
if(!is.null(bankruptcy_performance$no_macro_auc) &&
!is.null(acquisition_performance$no_macro_auc)) {
cat("\nCOMPARISON OF MACROECONOMIC IMPACT ON PREDICTION:\n")
cat("----------------------------------------------\n")
bank_auc_improvement <- bankruptcy_performance$auc - bankruptcy_performance$no_macro_auc
bank_pct_improvement <- bank_auc_improvement / bankruptcy_performance$no_macro_auc * 100
acq_auc_improvement <- acquisition_performance$auc - acquisition_performance$no_macro_auc
acq_pct_improvement <- acq_auc_improvement / acquisition_performance$no_macro_auc * 100
cat("AUC improvement from macroeconomic variables:\n")
cat(" Bankruptcy model: +", round(bank_auc_improvement, 4),
"(", round(bank_pct_improvement, 2), "%)\n", sep="")
cat(" Acquisition model: +", round(acq_auc_improvement, 4),
"(", round(acq_pct_improvement, 2), "%)\n", sep="")
if(bank_auc_improvement > acq_auc_improvement) {
cat("\nMacroeconomic variables have a GREATER impact on bankruptcy prediction\n")
cat("This aligns with the theory that external economic conditions play a more\n")
cat("significant role in company failure than in acquisition likelihood.\n")
} else if(acq_auc_improvement > bank_auc_improvement) {
cat("\nMacroeconomic variables have a GREATER impact on acquisition prediction\n")
cat("This suggests that M&A activity is more strongly influenced by broader\n")
cat("economic conditions than bankruptcy risk.\n")
} else {
cat("\nMacroeconomic variables have SIMILAR impact on both outcomes\n")
cat("This indicates that both bankruptcy and acquisition risks are\n")
cat("similarly affected by changing economic conditions.\n")
}
# Check which model shows most significant improvement from macro variables
cat("\nECONOMIC INSIGHT: ")
if(bank_pct_improvement > 5 && acq_pct_improvement > 5) {
cat("Macroeconomic conditions are important predictors for BOTH corporate outcomes\n")
cat("Companies should monitor economic indicators to assess both bankruptcy and acquisition risks\n")
} else if(bank_pct_improvement > 5) {
cat("Bankruptcy risk is more systematically linked to economic cycles\n")
cat("Economic downturns may disproportionately affect financially vulnerable companies\n")
} else if(acq_pct_improvement > 5) {
cat("Acquisition likelihood is more systematically linked to economic cycles\n")
cat("M&A activities appear to be more sensitive to changing macroeconomic conditions\n")
} else {
cat("Limited systematic impact of macroeconomic variables on both outcomes\n")
cat("Company-specific factors may be more important than broad economic conditions\n")
}
}
}
COMPARISON OF PREDICTION PERFORMANCE:
------------------------------------
AUC : Bankruptcy = 0.8183, Acquisition = 0.5272
Accuracy : Bankruptcy = 0.7027, Acquisition = 0.5141
Precision : Bankruptcy = 0.0925, Acquisition = 0.4598
Recall : Bankruptcy = 0.8523, Acquisition = 0.7804
F1 Score : Bankruptcy = 0.1669, Acquisition = 0.5787
COMPARISON OF MACROECONOMIC IMPACT ON PREDICTION:
----------------------------------------------
AUC improvement from macroeconomic variables:
Bankruptcy model: +0.0077(0.96%)
Acquisition model: +-0.0546(-9.39%)
Macroeconomic variables have a GREATER impact on bankruptcy prediction
This aligns with the theory that external economic conditions play a more
significant role in company failure than in acquisition likelihood.
ECONOMIC INSIGHT: Limited systematic impact of macroeconomic variables on both outcomes
Company-specific factors may be more important than broad economic conditions
In step 11.5 we analyze the timing of events in the dataset. We check for the first occurrence of bankruptcy and acquisition events for each company, and then calculate the quantiles of these event times. This information is used to determine appropriate time horizons for prediction models. The analysis also includes a comparison of the timing of bankruptcy and acquisition events, providing insights into their relationship.
#-------------------------------------------------------------
# 11.5: Time-Dependent Prediction Performance with Macro Analysis
#-------------------------------------------------------------
cat("\n11.5: TIME-DEPENDENT PREDICTION PERFORMANCE WITH MACRO ANALYSIS\n")
11.5: TIME-DEPENDENT PREDICTION PERFORMANCE WITH MACRO ANALYSIS
cat("--------------------------------------\n")
--------------------------------------
# Simplified event timing analysis using base R
event_timing_analysis <- function() {
cat("Analyzing event timing in the dataset:\n")
# Get all unique companies
all_companies <- unique(data$cusip)
bank_times <- numeric(0)
acq_times <- numeric(0)
# For each company, find if and when events occurred
for(company in all_companies) {
company_data <- data[data$cusip == company, ]
# Check for bankruptcy
if(any(company_data$bankruptcy == 1)) {
bank_index <- which(company_data$bankruptcy == 1)[1]
bank_times <- c(bank_times, company_data$tstop[bank_index])
}
# Check for acquisition
if(any(company_data$acquisition == 1)) {
acq_index <- which(company_data$acquisition == 1)[1]
acq_times <- c(acq_times, company_data$tstop[acq_index])
}
}
# Analyze bankruptcy timing
if(length(bank_times) > 0) {
bank_quantiles <- quantile(bank_times, probs = c(0.25, 0.5, 0.75), na.rm = TRUE)
cat("\nBankruptcy timing (years):\n")
cat(" Total bankruptcies:", length(bank_times), "\n")
cat(" Minimum time:", round(min(bank_times), 2), "\n")
cat(" 25th percentile:", round(bank_quantiles[1], 2), "\n")
cat(" Median time:", round(bank_quantiles[2], 2), "\n")
cat(" 75th percentile:", round(bank_quantiles[3], 2), "\n")
cat(" Maximum time:", round(max(bank_times), 2), "\n")
} else {
cat("\nNo bankruptcy events found in the dataset.\n")
}
# Analyze acquisition timing
if(length(acq_times) > 0) {
acq_quantiles <- quantile(acq_times, probs = c(0.25, 0.5, 0.75), na.rm = TRUE)
cat("\nAcquisition timing (years):\n")
cat(" Total acquisitions:", length(acq_times), "\n")
cat(" Minimum time:", round(min(acq_times), 2), "\n")
cat(" 25th percentile:", round(acq_quantiles[1], 2), "\n")
cat(" Median time:", round(acq_quantiles[2], 2), "\n")
cat(" 75th percentile:", round(acq_quantiles[3], 2), "\n")
cat(" Maximum time:", round(max(acq_times), 2), "\n")
} else {
cat("\nNo acquisition events found in the dataset.\n")
}
# Return event quantiles for adaptive horizon selection
return(list(
bankruptcy = if(length(bank_times) > 0) bank_quantiles else NULL,
acquisition = if(length(acq_times) > 0) acq_quantiles else NULL
))
}
# Run event timing analysis
event_timing <- event_timing_analysis()
Analyzing event timing in the dataset:
Bankruptcy timing (years):
Total bankruptcies: 176
Minimum time: 1
25th percentile: 4
Median time: 8.5
75th percentile: 15
Maximum time: 35
Acquisition timing (years):
Total acquisitions: 2154
Minimum time: 1
25th percentile: 5
Median time: 9
75th percentile: 15
Maximum time: 37
# Based on analysis, determine appropriate time horizons
determine_horizons <- function(event_timing) {
bank_horizons <- NULL
acq_horizons <- NULL
# For bankruptcy
if(!is.null(event_timing$bankruptcy)) {
# Use quartiles of actual event times as horizons
bank_horizons <- c(event_timing$bankruptcy[1],
event_timing$bankruptcy[2],
event_timing$bankruptcy[3])
bank_horizons <- round(bank_horizons) # Round to nearest year
bank_horizons <- unique(bank_horizons) # Remove duplicates
} else {
# Default horizons
bank_horizons <- c(3, 5, 10)
}
# For acquisition
if(!is.null(event_timing$acquisition)) {
# Use quartiles of actual event times as horizons
acq_horizons <- c(event_timing$acquisition[1],
event_timing$acquisition[2],
event_timing$acquisition[3])
acq_horizons <- round(acq_horizons) # Round to nearest year
acq_horizons <- unique(acq_horizons) # Remove duplicates
} else {
# Default horizons
acq_horizons <- c(3, 5, 10)
}
# Ensure we have short, medium, and long-term horizons
if(length(bank_horizons) == 1) {
bank_horizons <- c(max(1, bank_horizons - 2), bank_horizons, min(20, bank_horizons + 5))
} else if(length(bank_horizons) == 2) {
bank_horizons <- c(bank_horizons, min(20, max(bank_horizons) + 5))
}
if(length(acq_horizons) == 1) {
acq_horizons <- c(max(1, acq_horizons - 2), acq_horizons, min(20, acq_horizons + 5))
} else if(length(acq_horizons) == 2) {
acq_horizons <- c(acq_horizons, min(20, max(acq_horizons) + 5))
}
return(list(bankruptcy = bank_horizons, acquisition = acq_horizons))
}
# Get appropriate horizons
horizons <- determine_horizons(event_timing)
cat("\nUsing adaptive time horizons based on event distribution:\n")
Using adaptive time horizons based on event distribution:
cat("Bankruptcy horizons (years):", paste(horizons$bankruptcy, collapse=", "), "\n")
Bankruptcy horizons (years): 4, 8, 15
cat("Acquisition horizons (years):", paste(horizons$acquisition, collapse=", "), "\n")
Acquisition horizons (years): 5, 9, 15
# Find no-macro versions of models
create_no_macro_model <- function(model, event_type) {
# Get model formula
model_formula <- formula(model)
# Extract all terms
all_terms <- attr(terms(model), "term.labels")
# Identify macro variables (including their time interactions)
macro_vars <- c("gdp_growth", "gdp_deflator", "unemployement")
macro_terms <- c()
for(term in all_terms) {
# Check if term contains any macro variable
is_macro <- FALSE
for(macro in macro_vars) {
if(grepl(macro, term)) {
is_macro <- TRUE
break
}
}
if(is_macro) {
macro_terms <- c(macro_terms, term)
}
}
# If no macro terms in model, return original model
if(length(macro_terms) == 0) {
cat("No macroeconomic variables found in the model.\n")
return(model)
}
cat("Found", length(macro_terms), "macroeconomic terms in model.\n")
# Create formula without macro variables
no_macro_formula <- model_formula
for(term in macro_terms) {
no_macro_formula <- update(no_macro_formula, paste0(". ~ . - ", term))
}
# Fit model without macro variables
if(event_type == "bankruptcy") {
no_macro_model <- coxph(no_macro_formula, data = data, ties = "efron")
} else {
no_macro_model <- coxph(no_macro_formula, data = data, ties = "efron")
}
return(no_macro_model)
}
# Create no-macro models
no_macro_bankruptcy_model <- create_no_macro_model(final_bankruptcy_model, "bankruptcy")
Found 3 macroeconomic terms in model.
no_macro_acquisition_model <- create_no_macro_model(final_acquisition_model, "acquisition")
Found 4 macroeconomic terms in model.
# Enhanced time-dependent AUC function with macro comparison
time_dependent_auc_with_macro <- function(full_model, no_macro_model, model_name, event_type, horizons) {
cat("\nCalculating time-dependent AUC for", model_name, "model with macro comparison...\n")
# Prepare results
results <- data.frame(
Horizon = horizons,
Full_AUC = NA,
NoMacro_AUC = NA,
AUC_Difference = NA,
AUC_Pct_Improvement = NA,
Events = NA,
Total = NA
)
for(i in 1:length(horizons)) {
horizon <- horizons[i]
cat("Processing horizon:", horizon, "years...\n")
# Get all companies
all_companies <- unique(data$cusip)
# Prepare data for this horizon
horizon_data <- data.frame()
for(company in all_companies) {
# Get data for this company
company_data <- data[data$cusip == company, ]
# Get data up to horizon
company_at_horizon <- company_data[company_data$tstop <= horizon, ]
if(nrow(company_at_horizon) > 0) {
# Get last observation before horizon
last_obs_index <- which.max(company_at_horizon$tstop)
last_obs <- company_at_horizon[last_obs_index, ]
# Add to horizon data
horizon_data <- rbind(horizon_data, last_obs)
}
}
if(nrow(horizon_data) > 0) {
# Get event indicators
event_indicator <- horizon_data[[event_type]]
# Get risk scores for full model
full_risk_scores <- tryCatch({
predict(full_model, newdata = horizon_data, type = "risk")
}, error = function(e) {
cat(" Error calculating full model risk scores:", e$message, "\n")
return(rep(NA, nrow(horizon_data)))
})
# Get risk scores for no-macro model
no_macro_risk_scores <- tryCatch({
predict(no_macro_model, newdata = horizon_data, type = "risk")
}, error = function(e) {
cat(" Error calculating no-macro model risk scores:", e$message, "\n")
return(rep(NA, nrow(horizon_data)))
})
# Count events
n_events <- sum(event_indicator)
n_total <- nrow(horizon_data)
cat(" Companies observed at horizon:", n_total, "\n")
cat(" Events by horizon:", n_events, "(", round(100*n_events/n_total, 1), "%)\n")
# Store event counts
results$Events[i] <- n_events
results$Total[i] <- n_total
# Calculate AUCs if possible
if(n_events > 0 && n_events < n_total) {
if(requireNamespace("pROC", quietly = TRUE)) {
library(pROC)
# Calculate AUC for full model
full_auc <- NA
if(all(!is.na(full_risk_scores))) {
tryCatch({
full_roc <- roc(event_indicator, full_risk_scores, quiet = TRUE)
full_auc <- as.numeric(auc(full_roc))
results$Full_AUC[i] <- full_auc
cat(" Full model AUC at", horizon, "years:", round(full_auc, 4), "\n")
}, error = function(e) {
cat(" Error calculating full model AUC:", e$message, "\n")
})
}
# Calculate AUC for no-macro model
no_macro_auc <- NA
if(all(!is.na(no_macro_risk_scores))) {
tryCatch({
no_macro_roc <- roc(event_indicator, no_macro_risk_scores, quiet = TRUE)
no_macro_auc <- as.numeric(auc(no_macro_roc))
results$NoMacro_AUC[i] <- no_macro_auc
cat(" No-macro model AUC at", horizon, "years:", round(no_macro_auc, 4), "\n")
}, error = function(e) {
cat(" Error calculating no-macro model AUC:", e$message, "\n")
})
}
# Calculate improvement from macro variables
if(!is.na(full_auc) && !is.na(no_macro_auc)) {
auc_diff <- full_auc - no_macro_auc
pct_improvement <- 100 * auc_diff / no_macro_auc
results$AUC_Difference[i] <- auc_diff
results$AUC_Pct_Improvement[i] <- pct_improvement
cat(" Improvement from macro variables:", round(auc_diff, 4),
"(", round(pct_improvement, 2), "%)\n")
# Test if improvement is significant
tryCatch({
roc_test <- roc.test(full_roc, no_macro_roc, method="delong")
is_significant <- roc_test$p.value < 0.05
cat(" Statistical significance: p =", format.pval(roc_test$p.value, digits = 3),
ifelse(is_significant, "(significant)", "(not significant)"), "\n")
}, error = function(e) {
cat(" Could not test statistical significance:", e$message, "\n")
})
}
}
} else {
cat(" Insufficient events for AUC calculation\n")
}
} else {
cat(" No data available for this horizon\n")
}
}
# Print summary of results
cat("\nTime-dependent AUC summary for", model_name, "prediction:\n")
cat("----------------------------------------------------\n")
for(i in 1:nrow(results)) {
horizon <- results$Horizon[i]
full_auc <- results$Full_AUC[i]
no_macro_auc <- results$NoMacro_AUC[i]
auc_diff <- results$AUC_Difference[i]
pct_imp <- results$AUC_Pct_Improvement[i]
events <- results$Events[i]
total <- results$Total[i]
if(!is.na(full_auc)) {
cat(sprintf("At %d-year horizon (%d events, %.1f%%):\n",
horizon, events, 100*events/total))
cat(sprintf(" Full model AUC = %.4f\n", full_auc))
if(!is.na(no_macro_auc)) {
cat(sprintf(" No-macro AUC = %.4f\n", no_macro_auc))
cat(sprintf(" Macro contribution = %.4f (%.2f%%)\n", auc_diff, pct_imp))
# Interpretation of macro contribution
cat(" Interpretation: Macro variables ")
if(auc_diff > 0.03) {
cat("SUBSTANTIALLY improve prediction at this horizon\n")
} else if(auc_diff > 0.01) {
cat("MODERATELY improve prediction at this horizon\n")
} else if(auc_diff > 0) {
cat("SLIGHTLY improve prediction at this horizon\n")
} else if(auc_diff > -0.01) {
cat("do not meaningfully affect prediction at this horizon\n")
} else {
cat("WORSEN prediction at this horizon\n")
}
}
cat("\n")
} else {
cat(sprintf("At %d-year horizon: AUC not available\n\n", horizon))
}
}
return(results)
}
# Calculate time-dependent AUC with macro comparison
bankruptcy_td_auc <- time_dependent_auc_with_macro(
final_bankruptcy_model, no_macro_bankruptcy_model,
"bankruptcy", "bankruptcy", horizons$bankruptcy)
Calculating time-dependent AUC for bankruptcy model with macro comparison...
Processing horizon: 4 years...
Companies observed at horizon: 5038
Events by horizon: 48 ( 1 %)
Full model AUC at 4 years: 0.8424
No-macro model AUC at 4 years: 0.831
Improvement from macro variables: 0.0113 ( 1.36 %)
Statistical significance: p = 0.0693 (not significant)
Processing horizon: 8 years...
Companies observed at horizon: 5038
Events by horizon: 88 ( 1.7 %)
Full model AUC at 8 years: 0.8121
No-macro model AUC at 8 years: 0.8025
Improvement from macro variables: 0.0096 ( 1.19 %)
Statistical significance: p = 0.0233 (significant)
Processing horizon: 15 years...
Companies observed at horizon: 5038
Events by horizon: 136 ( 2.7 %)
Full model AUC at 15 years: 0.8167
No-macro model AUC at 15 years: 0.8047
Improvement from macro variables: 0.0119 ( 1.48 %)
Statistical significance: p = 8.66e-05 (significant)
Time-dependent AUC summary for bankruptcy prediction:
----------------------------------------------------
At 4-year horizon (48 events, 1.0%):
Full model AUC = 0.8424
No-macro AUC = 0.8310
Macro contribution = 0.0113 (1.36%)
Interpretation: Macro variables MODERATELY improve prediction at this horizon
At 8-year horizon (88 events, 1.7%):
Full model AUC = 0.8121
No-macro AUC = 0.8025
Macro contribution = 0.0096 (1.19%)
Interpretation: Macro variables SLIGHTLY improve prediction at this horizon
At 15-year horizon (136 events, 2.7%):
Full model AUC = 0.8167
No-macro AUC = 0.8047
Macro contribution = 0.0119 (1.48%)
Interpretation: Macro variables MODERATELY improve prediction at this horizon
acquisition_td_auc <- time_dependent_auc_with_macro(
final_acquisition_model, no_macro_acquisition_model,
"acquisition", "acquisition", horizons$acquisition)
Calculating time-dependent AUC for acquisition model with macro comparison...
Processing horizon: 5 years...
Companies observed at horizon: 5038
Events by horizon: 612 ( 12.1 %)
Full model AUC at 5 years: 0.5944
No-macro model AUC at 5 years: 0.6204
Improvement from macro variables: -0.0259 ( -4.18 %)
Statistical significance: p = 3.23e-06 (significant)
Processing horizon: 9 years...
Companies observed at horizon: 5038
Events by horizon: 1096 ( 21.8 %)
Full model AUC at 9 years: 0.5045
No-macro model AUC at 9 years: 0.5662
Improvement from macro variables: -0.0618 ( -10.91 %)
Warning: DeLong's test should not be applied to ROC curves with a different direction.
Statistical significance: p = 0.000795 (significant)
Processing horizon: 15 years...
Companies observed at horizon: 5038
Events by horizon: 1628 ( 32.3 %)
Full model AUC at 15 years: 0.5494
No-macro model AUC at 15 years: 0.5415
Improvement from macro variables: 0.0078 ( 1.45 %)
Warning: DeLong's test should not be applied to ROC curves with a different direction.
Statistical significance: p = 0.627 (not significant)
Time-dependent AUC summary for acquisition prediction:
----------------------------------------------------
At 5-year horizon (612 events, 12.1%):
Full model AUC = 0.5944
No-macro AUC = 0.6204
Macro contribution = -0.0259 (-4.18%)
Interpretation: Macro variables WORSEN prediction at this horizon
At 9-year horizon (1096 events, 21.8%):
Full model AUC = 0.5045
No-macro AUC = 0.5662
Macro contribution = -0.0618 (-10.91%)
Interpretation: Macro variables WORSEN prediction at this horizon
At 15-year horizon (1628 events, 32.3%):
Full model AUC = 0.5494
No-macro AUC = 0.5415
Macro contribution = 0.0078 (1.45%)
Interpretation: Macro variables SLIGHTLY improve prediction at this horizon
# Analyze macro variable importance across time horizons
cat("\nANALYSIS OF MACROECONOMIC IMPACT ACROSS TIME HORIZONS:\n")
ANALYSIS OF MACROECONOMIC IMPACT ACROSS TIME HORIZONS:
cat("----------------------------------------------------\n")
----------------------------------------------------
# Function to analyze macro impact trend
analyze_macro_trend <- function(td_auc_results, model_name) {
if(all(is.na(td_auc_results$AUC_Difference))) {
cat("Insufficient data to analyze macro impact trend for", model_name, "model.\n")
return(NULL)
}
# Extract non-NA rows
valid_rows <- !is.na(td_auc_results$AUC_Difference)
valid_results <- td_auc_results[valid_rows, ]
if(nrow(valid_results) < 2) {
cat("Need at least two valid time horizons to analyze trend for", model_name, "model.\n")
return(NULL)
}
# Sort by horizon
valid_results <- valid_results[order(valid_results$Horizon), ]
# Analyze trend
first_horizon <- valid_results$Horizon[1]
last_horizon <- valid_results$Horizon[nrow(valid_results)]
first_impact <- valid_results$AUC_Difference[1]
last_impact <- valid_results$AUC_Difference[nrow(valid_results)]
impact_diff <- last_impact - first_impact
cat("\nMacro impact trend for", model_name, "model:\n")
cat("- Short-term horizon (", first_horizon, "years): Impact = ", round(first_impact, 4), "\n", sep="")
cat("- Long-term horizon (", last_horizon, "years): Impact = ", round(last_impact, 4), "\n", sep="")
if(impact_diff > 0.01) {
cat("- Trend: Macro impact INCREASES with longer time horizons\n")
cat(" Economic interpretation: Macroeconomic factors become MORE important\n")
cat(" for predicting long-term outcomes compared to short-term outcomes\n")
} else if(impact_diff < -0.01) {
cat("- Trend: Macro impact DECREASES with longer time horizons\n")
cat(" Economic interpretation: Macroeconomic factors are MORE important\n")
cat(" for predicting short-term outcomes compared to long-term outcomes\n")
} else {
cat("- Trend: Macro impact is CONSISTENT across time horizons\n")
cat(" Economic interpretation: Macroeconomic factors have similar importance\n")
cat(" for both short-term and long-term prediction\n")
}
# Potential explanation based on model type
if(model_name == "bankruptcy") {
if(impact_diff > 0.01) {
cat(" Business implication: Long-term bankruptcy risk is more systematically\n")
cat(" linked to economic conditions, while short-term risk depends more on\n")
cat(" company-specific financial health\n")
} else if(impact_diff < -0.01) {
cat(" Business implication: Immediate bankruptcy risk is more sensitive to\n")
cat(" economic conditions, while long-term survival depends more on\n")
cat(" company-specific factors and adaptability\n")
}
} else if(model_name == "acquisition") {
if(impact_diff > 0.01) {
cat(" Business implication: Long-term acquisition patterns follow economic\n")
cat(" cycles more closely, while short-term M&A activity may be driven more\n")
cat(" by strategic opportunities and company-specific factors\n")
} else if(impact_diff < -0.01) {
cat(" Business implication: Short-term acquisition likelihood is more\n")
cat(" influenced by current economic conditions, while long-term acquisition\n")
cat(" patterns depend more on company-specific attractiveness\n")
}
}
return(impact_diff)
}
# Analyze trends for both models
bank_trend <- analyze_macro_trend(bankruptcy_td_auc, "bankruptcy")
Macro impact trend for bankruptcy model:
- Short-term horizon (4years): Impact = 0.0113
- Long-term horizon (15years): Impact = 0.0119
- Trend: Macro impact is CONSISTENT across time horizons
Economic interpretation: Macroeconomic factors have similar importance
for both short-term and long-term prediction
acq_trend <- analyze_macro_trend(acquisition_td_auc, "acquisition")
Macro impact trend for acquisition model:
- Short-term horizon (5years): Impact = -0.0259
- Long-term horizon (15years): Impact = 0.0078
- Trend: Macro impact INCREASES with longer time horizons
Economic interpretation: Macroeconomic factors become MORE important
for predicting long-term outcomes compared to short-term outcomes
Business implication: Long-term acquisition patterns follow economic
cycles more closely, while short-term M&A activity may be driven more
by strategic opportunities and company-specific factors
# Compare trends between models
if(!is.null(bank_trend) && !is.null(acq_trend)) {
cat("\nCOMPARATIVE ANALYSIS OF TIME-DEPENDENT MACRO EFFECTS:\n")
cat("--------------------------------------------------\n")
if(sign(bank_trend) == sign(acq_trend)) {
if(bank_trend > 0 && acq_trend > 0) {
cat("Both bankruptcy and acquisition models show INCREASING importance of\n")
cat("macroeconomic factors over longer time horizons.\n\n")
cat("This suggests that long-term corporate outcomes are more systematically\n")
cat("linked to economic cycles than short-term outcomes, regardless of whether\n")
cat("the outcome is bankruptcy or acquisition.\n")
} else if(bank_trend < 0 && acq_trend < 0) {
cat("Both bankruptcy and acquisition models show DECREASING importance of\n")
cat("macroeconomic factors over longer time horizons.\n\n")
cat("This suggests that immediate corporate outcomes are more sensitive to\n")
cat("current economic conditions, while long-term outcomes depend more on\n")
cat("company-specific factors and adaptability.\n")
} else {
cat("Both bankruptcy and acquisition models show CONSISTENT importance of\n")
cat("macroeconomic factors across time horizons.\n\n")
cat("This suggests that economic conditions have similar influence on corporate\n")
cat("outcomes regardless of the time horizon considered.\n")
}
} else {
cat("Bankruptcy and acquisition models show OPPOSITE trends in the importance\n")
cat("of macroeconomic factors across time horizons.\n\n")
if(bank_trend > 0 && acq_trend < 0) {
cat("For bankruptcy: Macro factors become MORE important over longer horizons\n")
cat("For acquisition: Macro factors become LESS important over longer horizons\n\n")
cat("This divergent pattern suggests that:\n")
cat("- Long-term corporate failure is more systematically linked to economic cycles\n")
cat("- Short-term acquisition activity is more sensitive to current economic conditions\n")
cat("- Different mechanisms may drive these two corporate outcomes over time\n")
} else {
cat("For bankruptcy: Macro factors become LESS important over longer horizons\n")
cat("For acquisition: Macro factors become MORE important over longer horizons\n\n")
cat("This divergent pattern suggests that:\n")
cat("- Short-term corporate failure is more sensitive to current economic conditions\n")
cat("- Long-term acquisition patterns follow economic cycles more closely\n")
cat("- Different mechanisms may drive these two corporate outcomes over time\n")
}
}
}
COMPARATIVE ANALYSIS OF TIME-DEPENDENT MACRO EFFECTS:
--------------------------------------------------
Both bankruptcy and acquisition models show INCREASING importance of
macroeconomic factors over longer time horizons.
This suggests that long-term corporate outcomes are more systematically
linked to economic cycles than short-term outcomes, regardless of whether
the outcome is bankruptcy or acquisition.
# Summarize findings
cat("\nTIME-DEPENDENT PREDICTION SUMMARY:\n")
TIME-DEPENDENT PREDICTION SUMMARY:
cat("----------------------------------\n")
----------------------------------
if((all(is.na(bankruptcy_td_auc$Full_AUC)) || nrow(bankruptcy_td_auc) == 0) &&
(all(is.na(acquisition_td_auc$Full_AUC)) || nrow(acquisition_td_auc) == 0)) {
cat("Could not calculate time-dependent AUC values with the available data.\n")
cat("Possible reasons include:\n")
cat("1. Insufficient events at the specified time horizons\n")
cat("2. Lack of variation in predictors or outcomes\n")
cat("3. Data structure issues related to time-varying covariates\n\n")
cat("For a robust evaluation, consider using:\n")
cat("- The overall AUC values from section 11.4\n")
cat("- In-sample vs. out-of-sample performance comparisons\n")
cat("- Calibration assessment of predicted vs. observed event rates\n")
} else {
valid_bk <- !is.na(bankruptcy_td_auc$Full_AUC)
valid_acq <- !is.na(acquisition_td_auc$Full_AUC)
cat("The time-dependent evaluation provides insights into how prediction performance\n")
cat("and the importance of macroeconomic variables change across different time horizons.\n\n")
# Summarize overall findings
if(any(valid_bk)) {
cat("Bankruptcy model:\n")
cat("- Performance varies across time horizons, with AUC values ranging from\n")
cat(" ", min(bankruptcy_td_auc$Full_AUC[valid_bk], na.rm = TRUE),
"to", max(bankruptcy_td_auc$Full_AUC[valid_bk], na.rm = TRUE), "\n")
if(any(!is.na(bankruptcy_td_auc$AUC_Difference))) {
cat("- Macroeconomic variables contribute between",
min(bankruptcy_td_auc$AUC_Difference, na.rm = TRUE), "and",
max(bankruptcy_td_auc$AUC_Difference, na.rm = TRUE), "to AUC values\n")
# Identify the horizon where macro variables have the greatest impact
max_impact_idx <- which.max(bankruptcy_td_auc$AUC_Difference)
max_impact_horizon <- bankruptcy_td_auc$Horizon[max_impact_idx]
cat("- Macroeconomic variables have the greatest impact at the",
max_impact_horizon, "year horizon\n")
}
cat("\n")
}
if(any(valid_acq)) {
cat("Acquisition model:\n")
cat("- Performance varies across time horizons, with AUC values ranging from\n")
cat(" ", min(acquisition_td_auc$Full_AUC[valid_acq], na.rm = TRUE),
"to", max(acquisition_td_auc$Full_AUC[valid_acq], na.rm = TRUE), "\n")
if(any(!is.na(acquisition_td_auc$AUC_Difference))) {
cat("- Macroeconomic variables contribute between",
min(acquisition_td_auc$AUC_Difference, na.rm = TRUE), "and",
max(acquisition_td_auc$AUC_Difference, na.rm = TRUE), "to AUC values\n")
# Identify the horizon where macro variables have the greatest impact
max_impact_idx <- which.max(acquisition_td_auc$AUC_Difference)
max_impact_horizon <- acquisition_td_auc$Horizon[max_impact_idx]
cat("- Macroeconomic variables have the greatest impact at the",
max_impact_horizon, "year horizon\n")
}
}
# Key implications
cat("\nKey implications:\n")
cat("1. The predictive ability of the models varies across different time horizons\n")
cat("2. The contribution of macroeconomic variables is not constant over time\n")
cat("3. Understanding the time-varying nature of economic effects is crucial for\n")
cat(" developing robust risk management and strategic planning frameworks\n")
}
The time-dependent evaluation provides insights into how prediction performance
and the importance of macroeconomic variables change across different time horizons.
Bankruptcy model:
- Performance varies across time horizons, with AUC values ranging from
0.8121166 to 0.8423597
- Macroeconomic variables contribute between 0.009573003 and 0.0119489 to AUC values
- Macroeconomic variables have the greatest impact at the 15 year horizon
Acquisition model:
- Performance varies across time horizons, with AUC values ranging from
0.5044683 to 0.5944412
- Macroeconomic variables contribute between -0.06176882 and 0.007844215 to AUC values
- Macroeconomic variables have the greatest impact at the 15 year horizon
Key implications:
1. The predictive ability of the models varies across different time horizons
2. The contribution of macroeconomic variables is not constant over time
3. Understanding the time-varying nature of economic effects is crucial for
developing robust risk management and strategic planning frameworks
In this section, we start with a comprehensive out-of-sample validation of the models. We split the dataset into training and testing sets based on company identifiers, ensuring that the same companies are not present in both sets. We then analyze the event distribution in both sets to ensure that they are comparable. We also check the distribution of macroeconomic variables across the sets to ensure that they are similar. The first part uses random sampling to create the training and testing sets, while the second part uses a more systematic approach based on company identifiers. We also check the distribution of macroeconomic variables across the sets to ensure that they are similar. We start with company-based data splitting, while the second part uses time-based (company) data splitting. We then refit the models on the training data, both with and without macroeconomic variables, and evaluate their performance on the testing data. Finally, we analyze the impact of macroeconomic variables on prediction performance and provide insights into their importance for bankruptcy and acquisition predictions.
#-------------------------------------------------------------
# STEP 12: Comprehensive Out-of-Sample Validation
#-------------------------------------------------------------
cat("\n=== STEP 12: COMPREHENSIVE OUT-OF-SAMPLE VALIDATION ===\n")
=== STEP 12: COMPREHENSIVE OUT-OF-SAMPLE VALIDATION ===
#-------------------------------------------------------------
# 12.1: Company-Based Data Splitting
#-------------------------------------------------------------
cat("\n12.1: COMPANY-BASED DATA SPLITTING\n")
12.1: COMPANY-BASED DATA SPLITTING
cat("--------------------------------------\n")
--------------------------------------
# Set seed for reproducibility
set.seed(123)
# Get unique company identifiers
all_companies <- unique(data$cusip)
n_companies <- length(all_companies)
cat("Total number of companies in dataset:", n_companies, "\n")
Total number of companies in dataset: 5038
# Create training and testing sets (70% training, 30% testing)
train_size <- round(0.7 * n_companies)
train_companies <- sample(all_companies, size = train_size)
test_companies <- setdiff(all_companies, train_companies)
# Split data
train_data <- data[data$cusip %in% train_companies, ]
test_data <- data[data$cusip %in% test_companies, ]
cat("Training set:", length(train_companies), "companies (", nrow(train_data), "observations)\n")
Training set: 3527 companies ( 44594 observations)
cat("Testing set:", length(test_companies), "companies (", nrow(test_data), "observations)\n")
Testing set: 1511 companies ( 18997 observations)
# Check event distribution in training and testing sets
analyze_events <- function(data_subset, label) {
# Get final observation for each company
final_obs <- data_subset %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Count event types
n_bankruptcy <- sum(final_obs$bankruptcy)
n_acquisition <- sum(final_obs$acquisition)
n_censored <- sum(final_obs$bankruptcy == 0 & final_obs$acquisition == 0)
n_total <- nrow(final_obs)
cat("\nEvent distribution in", label, "set:\n")
cat("- Bankruptcies:", n_bankruptcy, sprintf("(%.1f%%)", 100*n_bankruptcy/n_total), "\n")
cat("- Acquisitions:", n_acquisition, sprintf("(%.1f%%)", 100*n_acquisition/n_total), "\n")
cat("- Censored:", n_censored, sprintf("(%.1f%%)", 100*n_censored/n_total), "\n")
return(data.frame(
bankruptcies = n_bankruptcy,
acquisitions = n_acquisition,
censored = n_censored,
total = n_total
))
}
train_events <- analyze_events(train_data, "training")
Event distribution in training set:
- Bankruptcies: 124 (3.5%)
- Acquisitions: 1533 (43.5%)
- Censored: 1870 (53.0%)
test_events <- analyze_events(test_data, "testing")
Event distribution in testing set:
- Bankruptcies: 52 (3.4%)
- Acquisitions: 621 (41.1%)
- Censored: 838 (55.5%)
# Check distribution of macroeconomic variables across sets
check_macro_distribution <- function(train_data, test_data) {
macro_vars <- c("gdp_growth", "gdp_deflator", "unemployement")
available_macro <- intersect(macro_vars, colnames(train_data))
if(length(available_macro) > 0) {
cat("\nDistribution of macroeconomic variables across sets:\n")
cat("--------------------------------------------------------\n")
for(var in available_macro) {
train_mean <- mean(train_data[[var]], na.rm = TRUE)
train_sd <- sd(train_data[[var]], na.rm = TRUE)
train_min <- min(train_data[[var]], na.rm = TRUE)
train_max <- max(train_data[[var]], na.rm = TRUE)
test_mean <- mean(test_data[[var]], na.rm = TRUE)
test_sd <- sd(test_data[[var]], na.rm = TRUE)
test_min <- min(test_data[[var]], na.rm = TRUE)
test_max <- max(test_data[[var]], na.rm = TRUE)
cat("\nVariable:", var, "\n")
cat("Training set: Mean =", round(train_mean, 2), "SD =", round(train_sd, 2),
"Range =", round(train_min, 2), "to", round(train_max, 2), "\n")
cat("Testing set: Mean =", round(test_mean, 2), "SD =", round(test_sd, 2),
"Range =", round(test_min, 2), "to", round(test_max, 2), "\n")
# Calculate the difference in means as percentage of training SD
mean_diff <- abs(train_mean - test_mean)
pct_diff <- mean_diff / train_sd * 100
cat("Difference: ", round(mean_diff, 2), "(", round(pct_diff, 1),
"% of training SD)\n")
if(pct_diff > 25) {
cat("WARNING: Substantial difference in distribution of", var, "between sets\n")
cat(" This may affect the generalizability of economic effects\n")
}
}
} else {
cat("\nNo macroeconomic variables found in the dataset.\n")
}
}
check_macro_distribution(train_data, test_data)
Distribution of macroeconomic variables across sets:
--------------------------------------------------------
Variable: gdp_growth
Training set: Mean = 2.68 SD = 1.69 Range = -2.58 to 6.06
Testing set: Mean = 2.67 SD = 1.71 Range = -2.58 to 6.06
Difference: 0.01 ( 0.5 % of training SD)
Variable: gdp_deflator
Training set: Mean = 2.25 SD = 1.19 Range = 0.62 to 7.13
Testing set: Mean = 2.26 SD = 1.22 Range = 0.62 to 7.13
Difference: 0.02 ( 1.4 % of training SD)
Variable: unemployement
Training set: Mean = 5.57 SD = 1.6 Range = 3.64 to 9.63
Testing set: Mean = 5.56 SD = 1.61 Range = 3.64 to 9.63
Difference: 0 ( 0.2 % of training SD)
# Ensure the time variable exists in both sets
if(!"tt" %in% colnames(train_data)) train_data$tt <- train_data$tstop
if(!"tt" %in% colnames(test_data)) test_data$tt <- test_data$tstop
#-------------------------------------------------------------
# 12.2: Refit Models on Training Data (With and Without Macro)
#-------------------------------------------------------------
cat("\n12.2: REFITTING MODELS ON TRAINING DATA\n")
12.2: REFITTING MODELS ON TRAINING DATA
cat("--------------------------------------\n")
--------------------------------------
# Function to create formula without macro variables
create_no_macro_formula <- function(original_formula) {
# Extract terms from the formula
all_terms <- attr(terms(as.formula(original_formula)), "term.labels")
# Identify macro variables (including their time interactions)
macro_vars <- c("gdp_growth", "gdp_deflator", "unemployement")
macro_terms <- c()
for(term in all_terms) {
# Check if term contains any macro variable
is_macro <- FALSE
for(macro in macro_vars) {
if(grepl(macro, term)) {
is_macro <- TRUE
break
}
}
if(is_macro) {
macro_terms <- c(macro_terms, term)
}
}
# If no macro terms, return original formula
if(length(macro_terms) == 0) {
return(original_formula)
}
# Create formula without macro variables
no_macro_formula <- original_formula
for(term in macro_terms) {
no_macro_formula <- update(as.formula(no_macro_formula), paste0(". ~ . - ", term))
}
return(formula(no_macro_formula))
}
# For bankruptcy model
cat("Refitting bankruptcy model on training data...\n")
Refitting bankruptcy model on training data...
# Get formula from the final model
bank_formula <- formula(final_bankruptcy_model)
# Create version without macro variables
no_macro_bank_formula <- create_no_macro_formula(bank_formula)
# Check if formulas are different
has_macro_bank <- !identical(bank_formula, no_macro_bank_formula)
if(has_macro_bank) {
cat("Bankruptcy model contains macroeconomic variables.\n")
cat("Fitting two versions for comparison:\n")
# Fit full model with macro variables
train_bank_model <- coxph(bank_formula, data = train_data, ties = "efron")
cat("- Full model with macro variables: fitted successfully\n")
cat(" Number of coefficients:", length(coef(train_bank_model)), "\n")
# Fit version without macro variables
train_bank_no_macro_model <- coxph(no_macro_bank_formula, data = train_data, ties = "efron")
cat("- Model without macro variables: fitted successfully\n")
cat(" Number of coefficients:", length(coef(train_bank_no_macro_model)), "\n")
} else {
cat("Bankruptcy model does not contain macroeconomic variables.\n")
train_bank_model <- coxph(bank_formula, data = train_data, ties = "efron")
cat("Model fitted successfully.\n")
cat("Number of coefficients:", length(coef(train_bank_model)), "\n")
# Set no-macro model to be the same as full model
train_bank_no_macro_model <- train_bank_model
}
Bankruptcy model contains macroeconomic variables.
Fitting two versions for comparison:
- Full model with macro variables: fitted successfully
Number of coefficients: 23
- Model without macro variables: fitted successfully
Number of coefficients: 20
# For acquisition model
cat("\nRefitting acquisition model on training data...\n")
Refitting acquisition model on training data...
# Get formula from the final model
acq_formula <- formula(final_acquisition_model)
# Create version without macro variables
no_macro_acq_formula <- create_no_macro_formula(acq_formula)
# Check if formulas are different
has_macro_acq <- !identical(acq_formula, no_macro_acq_formula)
if(has_macro_acq) {
cat("Acquisition model contains macroeconomic variables.\n")
cat("Fitting two versions for comparison:\n")
# Fit full model with macro variables
train_acq_model <- coxph(acq_formula, data = train_data, ties = "efron")
cat("- Full model with macro variables: fitted successfully\n")
cat(" Number of coefficients:", length(coef(train_acq_model)), "\n")
# Fit version without macro variables
train_acq_no_macro_model <- coxph(no_macro_acq_formula, data = train_data, ties = "efron")
cat("- Model without macro variables: fitted successfully\n")
cat(" Number of coefficients:", length(coef(train_acq_no_macro_model)), "\n")
} else {
cat("Acquisition model does not contain macroeconomic variables.\n")
train_acq_model <- coxph(acq_formula, data = train_data, ties = "efron")
cat("Model fitted successfully.\n")
cat("Number of coefficients:", length(coef(train_acq_model)), "\n")
# Set no-macro model to be the same as full model
train_acq_no_macro_model <- train_acq_model
}
Acquisition model contains macroeconomic variables.
Fitting two versions for comparison:
- Full model with macro variables: fitted successfully
Number of coefficients: 18
- Model without macro variables: fitted successfully
Number of coefficients: 14
#-------------------------------------------------------------
# 12.3: In-Sample Performance Evaluation
#-------------------------------------------------------------
cat("\n12.3: IN-SAMPLE PERFORMANCE EVALUATION\n")
12.3: IN-SAMPLE PERFORMANCE EVALUATION
cat("--------------------------------------\n")
--------------------------------------
# Function to evaluate in-sample performance
evaluate_in_sample <- function(model, event_type, data_subset, model_name) {
cat("Evaluating in-sample performance for", model_name, "model...\n")
# Get last observation for each company
final_obs <- data_subset %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Calculate risk scores
risk_scores <- predict(model, newdata = final_obs, type = "risk")
# Evaluate with ROC/AUC
if(requireNamespace("pROC", quietly = TRUE)) {
library(pROC)
tryCatch({
roc_obj <- roc(final_obs[[event_type]], risk_scores, quiet = TRUE)
auc_val <- as.numeric(auc(roc_obj))
cat("In-sample AUC:", round(auc_val, 4), "\n")
# Calculate optimal threshold
coords <- coords(roc_obj, "best", ret = c("threshold", "sensitivity", "specificity"))
threshold <- as.numeric(coords["threshold"])
sensitivity <- as.numeric(coords["sensitivity"])
specificity <- as.numeric(coords["specificity"])
cat("Optimal threshold:", round(threshold, 4), "\n")
cat("Sensitivity at optimal threshold:", round(sensitivity, 4), "\n")
cat("Specificity at optimal threshold:", round(specificity, 4), "\n")
# Additional metrics at optimal threshold
predictions <- ifelse(risk_scores >= threshold, 1, 0)
true_values <- final_obs[[event_type]]
TP <- sum(predictions == 1 & true_values == 1)
TN <- sum(predictions == 0 & true_values == 0)
FP <- sum(predictions == 1 & true_values == 0)
FN <- sum(predictions == 0 & true_values == 1)
accuracy <- (TP + TN) / (TP + TN + FP + FN)
precision <- TP / (TP + FP)
recall <- sensitivity # Same as sensitivity
f1_score <- 2 * precision * recall / (precision + recall)
cat("Accuracy:", round(accuracy, 4), "\n")
cat("Precision:", round(precision, 4), "\n")
cat("F1 Score:", round(f1_score, 4), "\n")
# Return performance metrics
return(list(
auc = auc_val,
threshold = threshold,
sensitivity = sensitivity,
specificity = specificity,
accuracy = accuracy,
precision = precision,
recall = recall,
f1_score = f1_score
))
}, error = function(e) {
cat("Error calculating in-sample performance:", e$message, "\n")
return(NULL)
})
} else {
cat("pROC package not available for ROC analysis.\n")
return(NULL)
}
}
# Evaluate in-sample performance for full models
bank_in_sample <- evaluate_in_sample(train_bank_model, "bankruptcy", train_data, "bankruptcy")
Evaluating in-sample performance for bankruptcy model...
In-sample AUC: 0.826
Optimal threshold: 6.8424
Sensitivity at optimal threshold: 0.7581
Specificity at optimal threshold: 0.7972
Accuracy: 0.7959
Precision: 0.1199
F1 Score: 0.207
acq_in_sample <- evaluate_in_sample(train_acq_model, "acquisition", train_data, "acquisition")
Evaluating in-sample performance for acquisition model...
In-sample AUC: 0.5276
Optimal threshold: 0.9753
Sensitivity at optimal threshold: 0.7736
Specificity at optimal threshold: 0.322
Accuracy: 0.5183
Precision: 0.4673
F1 Score: 0.5827
# Evaluate in-sample performance for no-macro models (if different)
if(has_macro_bank) {
bank_in_sample_no_macro <- evaluate_in_sample(train_bank_no_macro_model, "bankruptcy", train_data,
"bankruptcy (no macro)")
}
Evaluating in-sample performance for bankruptcy (no macro) model...
In-sample AUC: 0.8221
Optimal threshold: 7.3194
Sensitivity at optimal threshold: 0.7581
Specificity at optimal threshold: 0.8078
Accuracy: 0.8061
Precision: 0.1257
F1 Score: 0.2156
if(has_macro_acq) {
acq_in_sample_no_macro <- evaluate_in_sample(train_acq_no_macro_model, "acquisition", train_data,
"acquisition (no macro)")
}
Evaluating in-sample performance for acquisition (no macro) model...
In-sample AUC: 0.5926
Optimal threshold: 1.1538
Sensitivity at optimal threshold: 0.7449
Specificity at optimal threshold: 0.4343
Accuracy: 0.5693
Precision: 0.5031
F1 Score: 0.6006
#-------------------------------------------------------------
# 12.4: Out-of-Sample Performance Evaluation & Macro Impact
#-------------------------------------------------------------
cat("\n12.4: OUT-OF-SAMPLE PERFORMANCE & MACRO IMPACT EVALUATION\n")
12.4: OUT-OF-SAMPLE PERFORMANCE & MACRO IMPACT EVALUATION
cat("------------------------------------------------------\n")
------------------------------------------------------
# Function to evaluate out-of-sample performance
evaluate_oos_performance <- function(model, no_macro_model, test_data, event_type, model_name) {
cat("\nEvaluating out-of-sample performance for", model_name, "model...\n")
# Get last observation for each company in test set
test_last_obs <- test_data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Calculate risk scores from full model
full_risk_scores <- predict(model, newdata = test_last_obs, type = "risk")
# Calculate risk scores from model without macro variables
no_macro_risk_scores <- predict(no_macro_model, newdata = test_last_obs, type = "risk")
# Calculate AUC using pROC package
if(requireNamespace("pROC", quietly = TRUE)) {
library(pROC)
# Create ROC objects
full_roc <- roc(test_last_obs[[event_type]], full_risk_scores, quiet = TRUE)
no_macro_roc <- roc(test_last_obs[[event_type]], no_macro_risk_scores, quiet = TRUE)
# Calculate AUCs
full_auc <- auc(full_roc)
no_macro_auc <- auc(no_macro_roc)
# Calculate confidence intervals
full_ci <- ci(full_roc)
no_macro_ci <- ci(no_macro_roc)
# Print results
cat("Out-of-sample AUC with all variables:", round(full_auc, 4), "\n")
cat("95% Confidence Interval:", paste(round(full_ci[1:2], 4), collapse=" - "), "\n")
if(!identical(model, no_macro_model)) {
cat("Out-of-sample AUC without macro variables:", round(no_macro_auc, 4), "\n")
cat("95% Confidence Interval:", paste(round(no_macro_ci[1:2], 4), collapse=" - "), "\n")
# Calculate improvement from macro variables
auc_diff <- full_auc - no_macro_auc
pct_improvement <- auc_diff / no_macro_auc * 100
cat("AUC improvement from macro variables:", round(auc_diff, 4),
"(", round(pct_improvement, 1), "%)\n")
# Test if improvement is significant
roc_test <- roc.test(full_roc, no_macro_roc, method = "delong")
cat("Statistical significance: p =", format.pval(roc_test$p.value, digits = 3), "\n")
if(roc_test$p.value < 0.05) {
cat("The improvement from macroeconomic variables is STATISTICALLY SIGNIFICANT (p < 0.05)\n")
} else {
cat("The improvement from macroeconomic variables is not statistically significant (p >= 0.05)\n")
}
}
# Calculate optimal thresholds and classification metrics
full_coords <- coords(full_roc, "best", ret = c("threshold", "sensitivity", "specificity"))
optimal_threshold <- as.numeric(full_coords["threshold"])
optimal_sensitivity <- as.numeric(full_coords["sensitivity"])
optimal_specificity <- as.numeric(full_coords["specificity"])
# Make predictions at optimal threshold
predictions <- ifelse(full_risk_scores >= optimal_threshold, 1, 0)
# Create confusion matrix
TP <- sum(predictions == 1 & test_last_obs[[event_type]] == 1)
TN <- sum(predictions == 0 & test_last_obs[[event_type]] == 0)
FP <- sum(predictions == 1 & test_last_obs[[event_type]] == 0)
FN <- sum(predictions == 0 & test_last_obs[[event_type]] == 1)
# Calculate metrics
accuracy <- (TP + TN) / (TP + TN + FP + FN)
precision <- if(TP + FP > 0) TP / (TP + FP) else 0
recall <- if(TP + FN > 0) TP / (TP + FN) else 0
f1_score <- if(precision + recall > 0) 2 * precision * recall / (precision + recall) else 0
cat("\nOut-of-sample classification metrics at optimal threshold:\n")
cat("Accuracy:", round(accuracy, 4), "\n")
cat("Precision:", round(precision, 4), "\n")
cat("Recall:", round(recall, 4), "\n")
cat("F1 Score:", round(f1_score, 4), "\n")
# If we have no-macro model, compare metrics
if(!identical(model, no_macro_model)) {
# Get optimal threshold for no-macro model
no_macro_coords <- coords(no_macro_roc, "best", ret = c("threshold", "sensitivity", "specificity"))
no_macro_threshold <- as.numeric(no_macro_coords["threshold"])
# Make predictions at optimal threshold
no_macro_predictions <- ifelse(no_macro_risk_scores >= no_macro_threshold, 1, 0)
# Create confusion matrix
no_macro_TP <- sum(no_macro_predictions == 1 & test_last_obs[[event_type]] == 1)
no_macro_TN <- sum(no_macro_predictions == 0 & test_last_obs[[event_type]] == 0)
no_macro_FP <- sum(no_macro_predictions == 1 & test_last_obs[[event_type]] == 0)
no_macro_FN <- sum(no_macro_predictions == 0 & test_last_obs[[event_type]] == 1)
# Calculate metrics
no_macro_accuracy <- (no_macro_TP + no_macro_TN) / (no_macro_TP + no_macro_TN + no_macro_FP + no_macro_FN)
no_macro_precision <- if(no_macro_TP + no_macro_FP > 0) no_macro_TP / (no_macro_TP + no_macro_FP) else 0
no_macro_recall <- if(no_macro_TP + no_macro_FN > 0) no_macro_TP / (no_macro_TP + no_macro_FN) else 0
no_macro_f1 <- if(no_macro_precision + no_macro_recall > 0)
2 * no_macro_precision * no_macro_recall / (no_macro_precision + no_macro_recall) else 0
cat("\nComparison of classification metrics:\n")
cat(" | With Macro | Without Macro | Difference\n")
cat("-----------------------------------------------------------\n")
cat(sprintf("Accuracy | %10.4f | %13.4f | %+10.4f\n",
accuracy, no_macro_accuracy, accuracy - no_macro_accuracy))
cat(sprintf("Precision | %10.4f | %13.4f | %+10.4f\n",
precision, no_macro_precision, precision - no_macro_precision))
cat(sprintf("Recall | %10.4f | %13.4f | %+10.4f\n",
recall, no_macro_recall, recall - no_macro_recall))
cat(sprintf("F1 Score | %10.4f | %13.4f | %+10.4f\n",
f1_score, no_macro_f1, f1_score - no_macro_f1))
}
# Return performance metrics
return(list(
full_auc = full_auc,
full_ci = full_ci,
no_macro_auc = no_macro_auc,
no_macro_ci = no_macro_ci,
auc_diff = if(!identical(model, no_macro_model)) auc_diff else NA,
p_value = if(!identical(model, no_macro_model)) roc_test$p.value else NA,
accuracy = accuracy,
precision = precision,
recall = recall,
f1_score = f1_score,
no_macro_accuracy = if(!identical(model, no_macro_model)) no_macro_accuracy else NA,
no_macro_precision = if(!identical(model, no_macro_model)) no_macro_precision else NA,
no_macro_recall = if(!identical(model, no_macro_model)) no_macro_recall else NA,
no_macro_f1 = if(!identical(model, no_macro_model)) no_macro_f1 else NA
))
} else {
cat("pROC package not available. Please install it for ROC analysis.\n")
return(NULL)
}
}
# Evaluate bankruptcy model
bankruptcy_oos <- evaluate_oos_performance(
train_bank_model,
train_bank_no_macro_model,
test_data,
"bankruptcy",
"bankruptcy"
)
Evaluating out-of-sample performance for bankruptcy model...
Out-of-sample AUC with all variables: 0.799
95% Confidence Interval: 0.7486 - 0.799
Out-of-sample AUC without macro variables: 0.8071
95% Confidence Interval: 0.7579 - 0.8071
AUC improvement from macro variables: -0.0081 ( -1 %)
Statistical significance: p = 0.184
The improvement from macroeconomic variables is not statistically significant (p >= 0.05)
Out-of-sample classification metrics at optimal threshold:
Accuracy: 0.6797
Precision: 0.0878
Recall: 0.8846
F1 Score: 0.1597
Comparison of classification metrics:
| With Macro | Without Macro | Difference
-----------------------------------------------------------
Accuracy | 0.6797 | 0.7022 | -0.0225
Precision | 0.0878 | 0.0905 | -0.0027
Recall | 0.8846 | 0.8462 | +0.0385
F1 Score | 0.1597 | 0.1636 | -0.0038
# Evaluate acquisition model
acquisition_oos <- evaluate_oos_performance(
train_acq_model,
train_acq_no_macro_model,
test_data,
"acquisition",
"acquisition"
)
Evaluating out-of-sample performance for acquisition model...
Out-of-sample AUC with all variables: 0.5285
95% Confidence Interval: 0.4996 - 0.5285
Out-of-sample AUC without macro variables: 0.5831
95% Confidence Interval: 0.5547 - 0.5831
AUC improvement from macro variables: -0.0546 ( -9.4 %)
Statistical significance: p = <2e-16
The improvement from macroeconomic variables is STATISTICALLY SIGNIFICANT (p < 0.05)
Out-of-sample classification metrics at optimal threshold:
Accuracy: 0.5156
Precision: 0.4497
Recall: 0.7987
F1 Score: 0.5754
Comparison of classification metrics:
| With Macro | Without Macro | Difference
-----------------------------------------------------------
Accuracy | 0.5156 | 0.5328 | -0.0172
Precision | 0.4497 | 0.4647 | -0.0150
Recall | 0.7987 | 0.9018 | -0.1031
F1 Score | 0.5754 | 0.6134 | -0.0380
Now we do an innovative analysis of the model performance across different economic conditions. We categorize the test data into three groups based on the last observation of each company: “Strong”, “Mixed”, and “Weak” economy. We then evaluate the model performance for each condition, comparing the full model with macroeconomic variables to the no-macro model. This analysis provides insights into how macroeconomic factors influence prediction performance under different economic conditions.
#-------------------------------------------------------------
# 12.5: Economic Condition-Specific Performance
#-------------------------------------------------------------
cat("\n12.5: ECONOMIC CONDITION-SPECIFIC PERFORMANCE\n")
12.5: ECONOMIC CONDITION-SPECIFIC PERFORMANCE
cat("--------------------------------------\n")
--------------------------------------
# Check if we have economic indicators in the test data
if(all(c("gdp_growth", "unemployement") %in% colnames(test_data))) {
cat("Analyzing model performance across different economic conditions...\n")
# Get last observation for each company in test set
test_last_obs <- test_data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Calculate median values to define conditions
median_gdp <- median(test_last_obs$gdp_growth, na.rm = TRUE)
median_unemp <- median(test_last_obs$unemployement, na.rm = TRUE)
# Create economic condition groups
test_last_obs$econ_condition <- "Mixed"
test_last_obs$econ_condition[test_last_obs$gdp_growth > median_gdp &
test_last_obs$unemployement < median_unemp] <- "Strong"
test_last_obs$econ_condition[test_last_obs$gdp_growth < median_gdp &
test_last_obs$unemployement > median_unemp] <- "Weak"
# Calculate counts by condition
strong_count <- sum(test_last_obs$econ_condition == "Strong")
mixed_count <- sum(test_last_obs$econ_condition == "Mixed")
weak_count <- sum(test_last_obs$econ_condition == "Weak")
cat("\nEconomic condition distribution in test set:\n")
cat("- Strong economy:", strong_count, "companies\n")
cat("- Mixed economy:", mixed_count, "companies\n")
cat("- Weak economy:", weak_count, "companies\n")
# Function to evaluate performance by economic condition
evaluate_by_condition <- function(model, no_macro_model, data, event_type, model_name) {
cat("\nEvaluating", model_name, "model performance across economic conditions...\n")
results <- data.frame(
Condition = c("Strong", "Mixed", "Weak"),
Count = c(strong_count, mixed_count, weak_count),
Full_AUC = NA,
No_Macro_AUC = NA,
Improvement = NA,
P_Value = NA
)
# Calculate risk scores for full and no-macro models
full_risk_scores <- predict(model, newdata = data, type = "risk")
no_macro_risk_scores <- predict(no_macro_model, newdata = data, type = "risk")
# Add scores to data
data$full_risk <- full_risk_scores
data$no_macro_risk <- no_macro_risk_scores
# Analyze each condition
for(condition in c("Strong", "Mixed", "Weak")) {
condition_data <- data[data$econ_condition == condition, ]
if(nrow(condition_data) > 10 && sum(condition_data[[event_type]]) > 0) {
cat("\n", condition, "Economy (", nrow(condition_data), "companies, ",
sum(condition_data[[event_type]]), event_type, "events ):\n", sep="")
# Calculate AUCs for each model
full_roc <- tryCatch({
roc(condition_data[[event_type]], condition_data$full_risk, quiet = TRUE)
}, error = function(e) NULL)
no_macro_roc <- tryCatch({
roc(condition_data[[event_type]], condition_data$no_macro_risk, quiet = TRUE)
}, error = function(e) NULL)
if(!is.null(full_roc) && !is.null(no_macro_roc)) {
full_auc <- auc(full_roc)
no_macro_auc <- auc(no_macro_roc)
# Store results
row_idx <- which(results$Condition == condition)
results$Full_AUC[row_idx] <- full_auc
results$No_Macro_AUC[row_idx] <- no_macro_auc
results$Improvement[row_idx] <- full_auc - no_macro_auc
# Test for significance if models are different
if(!identical(model, no_macro_model)) {
roc_test <- tryCatch({
roc.test(full_roc, no_macro_roc, method = "delong")
}, error = function(e) NULL)
if(!is.null(roc_test)) {
results$P_Value[row_idx] <- roc_test$p.value
}
}
# Print results
cat("- Full model AUC:", round(full_auc, 4), "\n")
if(!identical(model, no_macro_model)) {
cat("- No-macro model AUC:", round(no_macro_auc, 4), "\n")
improvement <- full_auc - no_macro_auc
pct_improvement <- improvement / no_macro_auc * 100
cat("- Improvement from macro variables:", round(improvement, 4),
"(", round(pct_improvement, 1), "%)\n", sep="")
if(!is.null(roc_test)) {
cat("- Statistical significance: p =", format.pval(roc_test$p.value, digits = 3), "\n")
}
}
} else {
cat("- Insufficient data for ROC analysis\n")
}
} else {
cat("\n", condition, "Economy: Insufficient data for analysis\n", sep="")
}
}
# Compare across conditions
cat("\nSummary of economic condition-specific performance:\n")
print(results)
# Interpret results
if(!identical(model, no_macro_model) &&
!all(is.na(results$Improvement)) &&
max(results$Improvement, na.rm = TRUE) > 0) {
# Find condition with maximum improvement
max_idx <- which.max(results$Improvement)
max_condition <- results$Condition[max_idx]
max_improvement <- results$Improvement[max_idx]
cat("\nInterpretation:\n")
cat("- Macroeconomic variables contribute most during", max_condition, "economic conditions\n")
cat(" (AUC improvement: +", round(max_improvement, 4), ")\n", sep="")
if(max_condition == "Strong") {
cat("- This suggests that economic factors may be more important for",
model_name, "prediction\n during economic expansions\n")
} else if(max_condition == "Weak") {
cat("- This suggests that economic factors may be more important for",
model_name, "prediction\n during economic downturns\n")
}
}
return(results)
}
# Analyze bankruptcy model by economic condition
bankruptcy_econ <- evaluate_by_condition(
train_bank_model,
train_bank_no_macro_model,
test_last_obs,
"bankruptcy",
"bankruptcy"
)
# Analyze acquisition model by economic condition
acquisition_econ <- evaluate_by_condition(
train_acq_model,
train_acq_no_macro_model,
test_last_obs,
"acquisition",
"acquisition"
)
# Compare economic sensitivity between models
if(has_macro_bank && has_macro_acq &&
!all(is.na(bankruptcy_econ$Improvement)) &&
!all(is.na(acquisition_econ$Improvement))) {
cat("\nCOMPARATIVE ECONOMIC SENSITIVITY ANALYSIS:\n")
cat("------------------------------------------\n")
# Calculate maximum improvements for each model
max_bk_improvement <- max(bankruptcy_econ$Improvement, na.rm = TRUE)
max_bk_condition <- bankruptcy_econ$Condition[which.max(bankruptcy_econ$Improvement)]
max_acq_improvement <- max(acquisition_econ$Improvement, na.rm = TRUE)
max_acq_condition <- acquisition_econ$Condition[which.max(acquisition_econ$Improvement)]
cat("Maximum macroeconomic contribution by model:\n")
cat("- Bankruptcy model: +", round(max_bk_improvement, 4),
"during", max_bk_condition, "economy\n", sep="")
cat("- Acquisition model: +", round(max_acq_improvement, 4),
"during", max_acq_condition, "economy\n", sep="")
# Compare overall economic sensitivity
if(max_bk_improvement > max_acq_improvement) {
cat("\nThe bankruptcy model shows GREATER sensitivity to economic conditions\n")
cat("This suggests that bankruptcy risk is more systematically linked to the\n")
cat("broader economic environment than acquisition likelihood\n")
} else if(max_acq_improvement > max_bk_improvement) {
cat("\nThe acquisition model shows GREATER sensitivity to economic conditions\n")
cat("This suggests that M&A activity is more systematically linked to the\n")
cat("broader economic environment than bankruptcy risk\n")
} else {
cat("\nBoth models show SIMILAR sensitivity to economic conditions\n")
}
# Compare condition-specific sensitivity
if(max_bk_condition != max_acq_condition) {
cat("\nThe models show DIFFERENT patterns of economic sensitivity:\n")
cat("- Bankruptcy prediction benefits most from macro variables during",
max_bk_condition, "economy\n")
cat("- Acquisition prediction benefits most from macro variables during",
max_acq_condition, "economy\n")
cat("\nThis suggests that different economic mechanisms drive these corporate outcomes\n")
} else {
cat("\nBoth models benefit most from macro variables during", max_bk_condition, "economy\n")
cat("This suggests that similar economic mechanisms influence both outcomes\n")
}
}
} else {
cat("Economic indicators not available in test data for condition-specific analysis.\n")
}
Analyzing model performance across different economic conditions...
Economic condition distribution in test set:
- Strong economy: 107 companies
- Mixed economy: 880 companies
- Weak economy: 524 companies
Evaluating bankruptcy model performance across economic conditions...
StrongEconomy (107companies, 9bankruptcyevents ):
- Full model AUC: 0.7188
- No-macro model AUC: 0.7256
- Improvement from macro variables:-0.0068(-0.9%)
- Statistical significance: p = 0.137
MixedEconomy (880companies, 15bankruptcyevents ):
- Full model AUC: 0.8353
- No-macro model AUC: 0.8339
- Improvement from macro variables:0.0014(0.2%)
- Statistical significance: p = 0.913
WeakEconomy (524companies, 28bankruptcyevents ):
- Full model AUC: 0.7495
- No-macro model AUC: 0.7607
- Improvement from macro variables:-0.0112(-1.5%)
- Statistical significance: p = 0.117
Summary of economic condition-specific performance:
Interpretation:
- Macroeconomic variables contribute most during Mixed economic conditions
(AUC improvement: +0.0014)
Evaluating acquisition model performance across economic conditions...
StrongEconomy (107companies, 64acquisitionevents ):
- Full model AUC: 0.6969
- No-macro model AUC: 0.7318
- Improvement from macro variables:-0.0349(-4.8%)
- Statistical significance: p = 0.0986
MixedEconomy (880companies, 225acquisitionevents ):
Warning: DeLong's test should not be applied to ROC curves with a different direction.
- Full model AUC: 0.5488
- No-macro model AUC: 0.5036
- Improvement from macro variables:0.0452(9%)
- Statistical significance: p = 0.247
WeakEconomy (524companies, 332acquisitionevents ):
- Full model AUC: 0.7401
- No-macro model AUC: 0.7953
- Improvement from macro variables:-0.0552(-6.9%)
- Statistical significance: p = 1.73e-05
Summary of economic condition-specific performance:
Interpretation:
- Macroeconomic variables contribute most during Mixed economic conditions
(AUC improvement: +0.0452)
COMPARATIVE ECONOMIC SENSITIVITY ANALYSIS:
------------------------------------------
Maximum macroeconomic contribution by model:
- Bankruptcy model: +0.0014duringMixedeconomy
- Acquisition model: +0.0452duringMixedeconomy
The acquisition model shows GREATER sensitivity to economic conditions
This suggests that M&A activity is more systematically linked to the
broader economic environment than bankruptcy risk
Both models benefit most from macro variables during Mixed economy
This suggests that similar economic mechanisms influence both outcomes
We now consider time horizons for out-of-sample evaluation. We use the previously identified bankruptcy and acquisition horizons from the training data to evaluate the models’ performance at these specific time points. This analysis helps us understand how well the models perform over time, particularly in predicting events that occur at different intervals.
#-------------------------------------------------------------
# 12.6: Out-of-Sample Time-Dependent Performance
#-------------------------------------------------------------
cat("\n12.6: OUT-OF-SAMPLE TIME-DEPENDENT PERFORMANCE\n")
12.6: OUT-OF-SAMPLE TIME-DEPENDENT PERFORMANCE
cat("--------------------------------------\n")
--------------------------------------
# Function for out-of-sample time-dependent evaluation
evaluate_time_dependent_out_of_sample <- function(model, model_name, event_type, data_subset, horizons) {
cat("Evaluating out-of-sample time-dependent performance for", model_name, "model...\n")
# Prepare results
results <- data.frame(
Horizon = horizons,
AUC = NA,
Events = NA
)
for(i in 1:length(horizons)) {
horizon <- horizons[i]
cat("Processing horizon:", horizon, "years...\n")
# Get all companies
test_companies <- unique(data_subset$cusip)
# Prepare data for this horizon
horizon_data <- data.frame()
for(company in test_companies) {
# Get data for this company
company_data <- data_subset[data_subset$cusip == company, ]
# Get data up to horizon
company_at_horizon <- company_data[company_data$tstop <= horizon, ]
if(nrow(company_at_horizon) > 0) {
# Get last observation before horizon
last_obs_index <- which.max(company_at_horizon$tstop)
last_obs <- company_at_horizon[last_obs_index, ]
# Add to horizon data
horizon_data <- rbind(horizon_data, last_obs)
}
}
if(nrow(horizon_data) > 0) {
# Get event indicators and risk scores
event_indicator <- horizon_data[[event_type]]
risk_scores <- tryCatch({
predict(model, newdata = horizon_data, type = "risk")
}, error = function(e) {
cat(" Error calculating risk scores:", e$message, "\n")
return(rep(NA, nrow(horizon_data)))
})
# Count events
n_events <- sum(event_indicator)
n_total <- nrow(horizon_data)
cat(" Companies observed at horizon:", n_total, "\n")
cat(" Events by horizon:", n_events, "\n")
# Calculate AUC if possible
if(n_events > 0 && n_events < n_total && all(!is.na(risk_scores))) {
if(requireNamespace("pROC", quietly = TRUE)) {
library(pROC)
tryCatch({
roc_obj <- roc(event_indicator, risk_scores, quiet = TRUE)
auc_val <- as.numeric(auc(roc_obj))
# Store results
results$AUC[i] <- auc_val
results$Events[i] <- n_events
cat(" Out-of-sample AUC at", horizon, "years:", round(auc_val, 4), "\n")
}, error = function(e) {
cat(" Error calculating AUC:", e$message, "\n")
})
}
} else {
cat(" Insufficient events for AUC calculation\n")
}
} else {
cat(" No data available for this horizon\n")
}
}
# Print results
cat("\nOut-of-sample time-dependent AUC for", model_name, "prediction:\n")
cat("------------------------------------------------\n")
for(i in 1:nrow(results)) {
horizon <- results$Horizon[i]
auc_val <- results$AUC[i]
events <- results$Events[i]
if(!is.na(auc_val)) {
cat(sprintf("At %d-year horizon: AUC = %.4f (%d events)\n",
horizon, auc_val, events))
} else {
cat(sprintf("At %d-year horizon: AUC not available\n", horizon))
}
}
return(results)
}
# Use the same horizons as determined in Step 11.5
cat("Using previously identified time horizons for out-of-sample evaluation...\n")
Using previously identified time horizons for out-of-sample evaluation...
cat("Bankruptcy horizons (years):", paste(horizons$bankruptcy, collapse=", "), "\n")
Bankruptcy horizons (years): 4, 8, 15
cat("Acquisition horizons (years):", paste(horizons$acquisition, collapse=", "), "\n")
Acquisition horizons (years): 5, 9, 15
# Calculate out-of-sample time-dependent AUC
bankruptcy_td_out <- evaluate_time_dependent_out_of_sample(
train_bank_model, "bankruptcy", "bankruptcy", test_data, horizons$bankruptcy)
Evaluating out-of-sample time-dependent performance for bankruptcy model...
Processing horizon: 4 years...
Companies observed at horizon: 1511
Events by horizon: 9
Out-of-sample AUC at 4 years: 0.8117
Processing horizon: 8 years...
Companies observed at horizon: 1511
Events by horizon: 22
Out-of-sample AUC at 8 years: 0.7858
Processing horizon: 15 years...
Companies observed at horizon: 1511
Events by horizon: 37
Out-of-sample AUC at 15 years: 0.8071
Out-of-sample time-dependent AUC for bankruptcy prediction:
------------------------------------------------
At 4-year horizon: AUC = 0.8117 (9 events)
At 8-year horizon: AUC = 0.7858 (22 events)
At 15-year horizon: AUC = 0.8071 (37 events)
acquisition_td_out <- evaluate_time_dependent_out_of_sample(
train_acq_model, "acquisition", "acquisition", test_data, horizons$acquisition)
Evaluating out-of-sample time-dependent performance for acquisition model...
Processing horizon: 5 years...
Companies observed at horizon: 1511
Events by horizon: 189
Out-of-sample AUC at 5 years: 0.5955
Processing horizon: 9 years...
Companies observed at horizon: 1511
Events by horizon: 320
Out-of-sample AUC at 9 years: 0.487
Processing horizon: 15 years...
Companies observed at horizon: 1511
Events by horizon: 474
Out-of-sample AUC at 15 years: 0.5358
Out-of-sample time-dependent AUC for acquisition prediction:
------------------------------------------------
At 5-year horizon: AUC = 0.5955 (189 events)
At 9-year horizon: AUC = 0.4870 (320 events)
At 15-year horizon: AUC = 0.5358 (474 events)
This analysis provides insights into how the models perform over time, particularly in predicting events that occur at different intervals. It helps us understand the stability and reliability of the models’ predictions across various time horizons.
Finally, we conduct a coefficient stability analysis to compare the coefficients of the full model with those of the training model. This analysis helps us identify any significant changes in the coefficients, which may indicate instability or sensitivity to the training data.
#-------------------------------------------------------------
# 12.7: Coefficient Stability Analysis
#-------------------------------------------------------------
cat("\n12.7: COEFFICIENT STABILITY ANALYSIS\n")
12.7: COEFFICIENT STABILITY ANALYSIS
cat("--------------------------------------\n")
--------------------------------------
# Function to compare coefficients between full and training models
compare_coefficients <- function(full_model, train_model, model_name) {
cat("Comparing coefficients for", model_name, "model:\n\n")
# Get coefficients from both models
full_coef <- coef(full_model)
train_coef <- coef(train_model)
# Find common variables
common_vars <- intersect(names(full_coef), names(train_coef))
# Create comparison dataframe
comparison <- data.frame(
Variable = common_vars,
Full_Model = full_coef[common_vars],
Training_Model = train_coef[common_vars],
Change_Pct = NA,
Direction_Change = FALSE,
stringsAsFactors = FALSE
)
# Calculate percent change and direction changes
for(i in 1:nrow(comparison)) {
full_val <- comparison$Full_Model[i]
train_val <- comparison$Training_Model[i]
# Percent change (using absolute values to handle negative coefficients)
if(full_val != 0) {
comparison$Change_Pct[i] <- abs((train_val - full_val) / full_val) * 100
} else {
comparison$Change_Pct[i] <- NA
}
# Direction change
comparison$Direction_Change[i] <- sign(full_val) != sign(train_val)
}
# Sort by absolute percent change
comparison <- comparison[order(comparison$Change_Pct, decreasing = TRUE), ]
# Print table
cat("Variable Full Model Train Model % Change Direction Change\n")
cat("----------------------------------------------------------------------------\n")
for(i in 1:nrow(comparison)) {
var <- comparison$Variable[i]
full_val <- comparison$Full_Model[i]
train_val <- comparison$Training_Model[i]
pct_change <- comparison$Change_Pct[i]
dir_change <- comparison$Direction_Change[i]
# Create formatted string
cat(sprintf("%-20s %12.4f %12.4f %10.1f%% %s\n",
var, full_val, train_val,
ifelse(is.na(pct_change), 0, pct_change),
ifelse(dir_change, "YES", "no")))
}
# Count direction changes
n_dir_changes <- sum(comparison$Direction_Change)
cat("\nVariables with direction changes:", n_dir_changes, "out of", nrow(comparison), "\n")
# Identify unstable variables (large changes)
unstable <- comparison[comparison$Change_Pct > 50 | comparison$Direction_Change, ]
if(nrow(unstable) > 0) {
cat("\nPotentially unstable variables (>50% change or direction change):\n")
for(i in 1:nrow(unstable)) {
cat("- ", unstable$Variable[i], "\n")
}
} else {
cat("\nNo potentially unstable variables identified.\n")
}
# Check specifically for stability of macro variable coefficients
if(has_macro_bank || has_macro_acq) {
macro_vars <- c("gdp_growth", "gdp_deflator", "unemployement")
macro_coeffs <- comparison[grepl(paste(macro_vars, collapse="|"), comparison$Variable), ]
if(nrow(macro_coeffs) > 0) {
cat("\nStability of macroeconomic variable coefficients:\n")
for(i in 1:nrow(macro_coeffs)) {
var <- macro_coeffs$Variable[i]
pct_change <- macro_coeffs$Change_Pct[i]
dir_change <- macro_coeffs$Direction_Change[i]
stability <- if(dir_change) {
"UNSTABLE (direction change)"
} else if(pct_change > 50) {
"UNSTABLE (large magnitude change)"
} else if(pct_change > 25) {
"MODERATELY STABLE"
} else {
"HIGHLY STABLE"
}
cat("- ", var, ": ", stability, " (", round(pct_change, 1), "% change)\n", sep="")
}
}
}
# Return comparison data
return(comparison)
}
# Compare coefficients for both models
bank_coef_comparison <- compare_coefficients(final_bankruptcy_model, train_bank_model, "bankruptcy")
Comparing coefficients for bankruptcy model:
Variable Full Model Train Model % Change Direction Change
----------------------------------------------------------------------------
gp_margin 0.0628 0.1786 184.4% no
unemployement -0.0744 -0.1748 134.9% no
ebit_growth -0.0175 -0.0378 116.1% no
LTMTA:tt 0.0412 0.0006 98.6% no
debt_ratio:tt 0.0277 0.0022 92.0% no
EBIT_VOL_3Y -0.0015 -0.0028 82.5% no
gdp_growth 0.0987 0.0241 75.6% no
PRICE:tt -0.0112 -0.0183 62.6% no
receivables_turnover 0.0013 0.0005 61.5% no
PRICE -0.1722 -0.0752 56.3% no
debt_service -0.0034 -0.0050 47.2% no
MBE -0.1640 -0.0919 43.9% no
intangibility -0.2944 -0.4126 40.1% no
asset_turnover -0.1689 -0.1170 30.7% no
LTMTA 3.6697 4.4828 22.2% no
CASHMTA -2.1101 -2.5229 19.6% no
NIMTA -2.1411 -2.5101 17.2% no
cash_to_assets 1.4390 1.6187 12.5% no
z_score 0.0297 0.0327 10.2% no
current_ratio 0.0836 0.0766 8.3% no
wc_ratio -1.1042 -1.1921 8.0% no
debt_ratio -0.4929 -0.4583 7.0% no
gdp_deflator -0.1753 -0.1680 4.2% no
Variables with direction changes: 0 out of 23
Potentially unstable variables (>50% change or direction change):
- gp_margin
- unemployement
- ebit_growth
- LTMTA:tt
- debt_ratio:tt
- EBIT_VOL_3Y
- gdp_growth
- PRICE:tt
- receivables_turnover
- PRICE
Stability of macroeconomic variable coefficients:
- unemployement: UNSTABLE (large magnitude change) (134.9% change)
- gdp_growth: UNSTABLE (large magnitude change) (75.6% change)
- gdp_deflator: HIGHLY STABLE (4.2% change)
acq_coef_comparison <- compare_coefficients(final_acquisition_model, train_acq_model, "acquisition")
Comparing coefficients for acquisition model:
Variable Full Model Train Model % Change Direction Change
----------------------------------------------------------------------------
debt_ratio 0.0224 0.0771 244.3% no
NIMTA 0.1884 0.2831 50.3% no
gdp_growth 0.0369 0.0257 30.4% no
asset_turnover:tt 0.0130 0.0092 28.8% no
LTMTA -0.0317 -0.0394 24.1% no
gdp_deflator -0.0381 -0.0309 19.0% no
gp_margin 0.0256 0.0209 18.6% no
EBIT_VOL_3Y -0.0076 -0.0089 17.8% no
cash_to_assets 0.7378 0.6467 12.3% no
receivables_turnover -0.0033 -0.0029 10.1% no
wc_ratio:tt 0.0464 0.0506 9.1% no
wc_ratio -0.7110 -0.6565 7.7% no
unemployement -0.1341 -0.1417 5.7% no
MBE -0.2303 -0.2222 3.5% no
PRICE 0.1328 0.1361 2.5% no
unemployement:tt 0.0083 0.0082 1.0% no
asset_turnover -0.1873 -0.1856 0.9% no
current_ratio -0.0737 -0.0743 0.8% no
Variables with direction changes: 0 out of 18
Potentially unstable variables (>50% change or direction change):
- debt_ratio
- NIMTA
Stability of macroeconomic variable coefficients:
- gdp_growth: MODERATELY STABLE (30.4% change)
- gdp_deflator: HIGHLY STABLE (19% change)
- unemployement: HIGHLY STABLE (5.7% change)
- unemployement:tt: HIGHLY STABLE (1% change)
Now, instead of using the full dataset for cross-validation, we will use a company-based K-fold cross-validation approach. This method ensures that all observations from a single company are either in the training or testing set, preventing data leakage and providing a more realistic evaluation of model performance. We will also check the distribution of events across folds to ensure that they are balanced.
#-------------------------------------------------------------
# STEP 13: K-Fold Cross-Validation for Survival Analysis
#-------------------------------------------------------------
cat("\n=== STEP 13: K-FOLD CROSS-VALIDATION FOR SURVIVAL ANALYSIS ===\n")
=== STEP 13: K-FOLD CROSS-VALIDATION FOR SURVIVAL ANALYSIS ===
#-------------------------------------------------------------
# 13.1: Company-Based K-Fold Setup
#-------------------------------------------------------------
cat("\n13.1: COMPANY-BASED K-FOLD SETUP\n")
13.1: COMPANY-BASED K-FOLD SETUP
cat("--------------------------------------\n")
--------------------------------------
# Set seed for reproducibility
set.seed(456)
# Specify number of folds
k_folds <- 5
cat("Setting up", k_folds, "fold cross-validation...\n")
Setting up 5 fold cross-validation...
# Get unique company identifiers
all_companies <- unique(data$cusip)
n_companies <- length(all_companies)
cat("Total number of companies in dataset:", n_companies, "\n")
Total number of companies in dataset: 5038
# Randomly assign companies to folds
fold_assignments <- sample(1:k_folds, n_companies, replace = TRUE)
company_folds <- data.frame(
cusip = all_companies,
fold = fold_assignments
)
# Check distribution of companies across folds
fold_counts <- table(company_folds$fold)
cat("Distribution of companies across folds:\n")
Distribution of companies across folds:
print(fold_counts)
1 2 3 4 5
973 1029 1009 1006 1021
# Create function to check event distribution in folds
check_fold_event_distribution <- function(data, company_folds) {
# Create a data frame to store results
fold_events <- data.frame(
fold = 1:k_folds,
n_companies = as.numeric(fold_counts),
n_bankruptcy = NA,
n_acquisition = NA,
n_censored = NA
)
# Get final observation for each company
final_obs <- data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Add fold information
final_obs <- final_obs %>%
left_join(company_folds, by = "cusip")
# Count events by fold
for (i in 1:k_folds) {
fold_data <- final_obs %>% filter(fold == i)
fold_events$n_bankruptcy[i] <- sum(fold_data$bankruptcy)
fold_events$n_acquisition[i] <- sum(fold_data$acquisition)
fold_events$n_censored[i] <- sum(fold_data$bankruptcy == 0 & fold_data$acquisition == 0)
}
# Calculate percentages
fold_events$pct_bankruptcy <- fold_events$n_bankruptcy / fold_events$n_companies * 100
fold_events$pct_acquisition <- fold_events$n_acquisition / fold_events$n_companies * 100
fold_events$pct_censored <- fold_events$n_censored / fold_events$n_companies * 100
return(fold_events)
}
# Check event distribution
fold_events <- check_fold_event_distribution(data, company_folds)
cat("\nEvent distribution across folds:\n")
Event distribution across folds:
print(fold_events[, c("fold", "n_companies", "n_bankruptcy", "n_acquisition", "n_censored")])
cat("\nEvent percentages across folds:\n")
Event percentages across folds:
print(fold_events[, c("fold", "pct_bankruptcy", "pct_acquisition", "pct_censored")])
# Check if distribution is too imbalanced
max_bankruptcy_diff <- max(fold_events$pct_bankruptcy) - min(fold_events$pct_bankruptcy)
max_acquisition_diff <- max(fold_events$pct_acquisition) - min(fold_events$pct_acquisition)
cat("\nMaximum difference in bankruptcy percentage across folds:", round(max_bankruptcy_diff, 2), "%\n")
Maximum difference in bankruptcy percentage across folds: 0.65 %
cat("Maximum difference in acquisition percentage across folds:", round(max_acquisition_diff, 2), "%\n")
Maximum difference in acquisition percentage across folds: 5.03 %
# If distribution is too imbalanced, consider stratified sampling
imbalance_threshold <- 5 # 5% difference threshold
if (max_bankruptcy_diff > imbalance_threshold || max_acquisition_diff > imbalance_threshold) {
cat("\nWARNING: Event distribution across folds is imbalanced (>5% difference)\n")
cat("Implementing stratified sampling to balance event distribution...\n")
# Get event types for each company
company_events <- data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
mutate(event_category = case_when(
bankruptcy == 1 ~ "bankruptcy",
acquisition == 1 ~ "acquisition",
TRUE ~ "censored"
)) %>%
select(cusip, event_category) %>%
ungroup()
# Stratified sampling by event type
set.seed(789)
company_folds_stratified <- data.frame()
for (event_type in c("bankruptcy", "acquisition", "censored")) {
event_companies <- company_events %>%
filter(event_category == event_type) %>%
pull(cusip)
n_event_companies <- length(event_companies)
event_folds <- sample(rep(1:k_folds, length.out = n_event_companies))
event_df <- data.frame(
cusip = event_companies,
fold = event_folds,
event_category = event_type
)
company_folds_stratified <- rbind(company_folds_stratified, event_df)
}
# Replace original fold assignments with stratified ones
company_folds <- company_folds_stratified[, c("cusip", "fold")]
# Recheck distribution
fold_events_stratified <- check_fold_event_distribution(data, company_folds)
cat("\nEvent distribution after stratification:\n")
print(fold_events_stratified[, c("fold", "n_companies", "n_bankruptcy", "n_acquisition", "n_censored")])
cat("\nEvent percentages after stratification:\n")
print(fold_events_stratified[, c("fold", "pct_bankruptcy", "pct_acquisition", "pct_censored")])
# Update fold events
fold_events <- fold_events_stratified
}
WARNING: Event distribution across folds is imbalanced (>5% difference)
Implementing stratified sampling to balance event distribution...
Event distribution after stratification:
Event percentages after stratification:
# Store fold assignments for later use
fold_assignments <- company_folds
#-------------------------------------------------------------
# 13.2: K-Fold Cross-Validation Execution
#-------------------------------------------------------------
cat("\n13.2: K-FOLD CROSS-VALIDATION EXECUTION\n")
13.2: K-FOLD CROSS-VALIDATION EXECUTION
cat("--------------------------------------\n")
--------------------------------------
# Initialize data frames to store results
bankruptcy_cv_results <- data.frame(
fold = 1:k_folds,
auc_with_macro = NA,
auc_no_macro = NA,
improvement = NA,
p_value = NA,
concordance = NA
)
acquisition_cv_results <- data.frame(
fold = 1:k_folds,
auc_with_macro = NA,
auc_no_macro = NA,
improvement = NA,
p_value = NA,
concordance = NA
)
# Create copies of model formulas for full and no-macro models
bank_formula <- formula(final_bankruptcy_model)
no_macro_bank_formula <- create_no_macro_formula(bank_formula)
acq_formula <- formula(final_acquisition_model)
no_macro_acq_formula <- create_no_macro_formula(acq_formula)
# Check if models contain macro variables
has_macro_bank <- !identical(bank_formula, no_macro_bank_formula)
has_macro_acq <- !identical(acq_formula, no_macro_acq_formula)
# Execute k-fold cross-validation
for (fold_idx in 1:k_folds) {
cat("\n----- Processing Fold", fold_idx, "of", k_folds, "-----\n")
# Create training and test sets for this fold
train_companies <- fold_assignments$cusip[fold_assignments$fold != fold_idx]
test_companies <- fold_assignments$cusip[fold_assignments$fold == fold_idx]
cv_train_data <- data[data$cusip %in% train_companies, ]
cv_test_data <- data[data$cusip %in% test_companies, ]
cat("Training set:", length(train_companies), "companies (", nrow(cv_train_data), "observations)\n")
cat("Testing set:", length(test_companies), "companies (", nrow(cv_test_data), "observations)\n")
# Ensure time variable exists
if(!"tt" %in% colnames(cv_train_data)) cv_train_data$tt <- cv_train_data$tstop
if(!"tt" %in% colnames(cv_test_data)) cv_test_data$tt <- cv_test_data$tstop
# ----- Bankruptcy Model -----
cat("\nFitting bankruptcy models for fold", fold_idx, "...\n")
# Fit full model
cv_bank_model <- tryCatch({
coxph(bank_formula, data = cv_train_data, ties = "efron")
}, error = function(e) {
cat("Error fitting full bankruptcy model:", e$message, "\n")
cat("Attempting to fit simplified model...\n")
# Try to fit a simpler model without time interactions
simple_bank_formula <- update(bank_formula, . ~ . - .:.)
tryCatch({
coxph(simple_bank_formula, data = cv_train_data, ties = "efron")
}, error = function(e2) {
cat("Error fitting simplified model:", e2$message, "\n")
return(NULL)
})
})
# Fit no-macro model (if applicable)
cv_bank_no_macro_model <- if(has_macro_bank) {
tryCatch({
coxph(no_macro_bank_formula, data = cv_train_data, ties = "efron")
}, error = function(e) {
cat("Error fitting no-macro bankruptcy model:", e$message, "\n")
return(NULL)
})
} else {
cv_bank_model
}
# ----- Acquisition Model -----
cat("\nFitting acquisition models for fold", fold_idx, "...\n")
# Fit full model
cv_acq_model <- tryCatch({
coxph(acq_formula, data = cv_train_data, ties = "efron")
}, error = function(e) {
cat("Error fitting full acquisition model:", e$message, "\n")
cat("Attempting to fit simplified model...\n")
# Try to fit a simpler model without time interactions
simple_acq_formula <- update(acq_formula, . ~ . - .:.)
tryCatch({
coxph(simple_acq_formula, data = cv_train_data, ties = "efron")
}, error = function(e2) {
cat("Error fitting simplified model:", e2$message, "\n")
return(NULL)
})
})
# Fit no-macro model (if applicable)
cv_acq_no_macro_model <- if(has_macro_acq) {
tryCatch({
coxph(no_macro_acq_formula, data = cv_train_data, ties = "efron")
}, error = function(e) {
cat("Error fitting no-macro acquisition model:", e$message, "\n")
return(NULL)
})
} else {
cv_acq_model
}
# ----- Evaluation -----
# Get last observation for each company in test set
test_last_obs <- cv_test_data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Evaluate bankruptcy model
if (!is.null(cv_bank_model)) {
cat("\nEvaluating bankruptcy model...\n")
tryCatch({
# Get full model predictions
bank_full_scores <- predict(cv_bank_model, newdata = test_last_obs, type = "risk")
# Get no-macro model predictions (if applicable)
bank_no_macro_scores <- if (!is.null(cv_bank_no_macro_model)) {
predict(cv_bank_no_macro_model, newdata = test_last_obs, type = "risk")
} else {
bank_full_scores
}
# Calculate AUC
full_bank_auc <- as.numeric(pROC::auc(pROC::roc(test_last_obs$bankruptcy, bank_full_scores, quiet = TRUE)))
# Get concordance (Harrell's C-index) for bankruptcy model
if (!is.null(cv_bank_model)) {
full_bank_concordance <- as.numeric(cv_bank_model$concordance["concordance"])
cat("Bankruptcy model concordance (C-index):", round(full_bank_concordance, 4), "\n")
} else {
full_bank_concordance <- NA
}
# Calculate no-macro AUC if applicable
no_macro_bank_auc <- if (has_macro_bank && !is.null(cv_bank_no_macro_model)) {
as.numeric(pROC::auc(pROC::roc(test_last_obs$bankruptcy, bank_no_macro_scores, quiet = TRUE)))
} else {
full_bank_auc
}
# Calculate improvement
bank_improvement <- full_bank_auc - no_macro_bank_auc
# Statistical test if applicable
bank_p_value <- if (has_macro_bank && !is.null(cv_bank_no_macro_model)) {
test_result <- pROC::roc.test(
pROC::roc(test_last_obs$bankruptcy, bank_full_scores, quiet = TRUE),
pROC::roc(test_last_obs$bankruptcy, bank_no_macro_scores, quiet = TRUE),
method = "delong"
)
test_result$p.value
} else {
NA
}
bankruptcy_cv_results$auc_with_macro[fold_idx] <- full_bank_auc
bankruptcy_cv_results$auc_no_macro[fold_idx] <- no_macro_bank_auc
bankruptcy_cv_results$improvement[fold_idx] <- bank_improvement
bankruptcy_cv_results$p_value[fold_idx] <- bank_p_value
bankruptcy_cv_results$concordance[fold_idx] <- full_bank_concordance
cat("Bankruptcy model fold", fold_idx, "- AUC with macro:", round(full_bank_auc, 4),
"- AUC without macro:", round(no_macro_bank_auc, 4),
"- Improvement:", round(bank_improvement, 4),
"- Concordance:", round(full_bank_concordance, 4), "\n")
}, error = function(e) {
cat("Error evaluating bankruptcy model:", e$message, "\n")
})
}
# Evaluate acquisition model
if (!is.null(cv_acq_model)) {
cat("\nEvaluating acquisition model...\n")
tryCatch({
# Get full model predictions
acq_full_scores <- predict(cv_acq_model, newdata = test_last_obs, type = "risk")
# Get no-macro model predictions (if applicable)
acq_no_macro_scores <- if (!is.null(cv_acq_no_macro_model)) {
predict(cv_acq_no_macro_model, newdata = test_last_obs, type = "risk")
} else {
acq_full_scores
}
# Calculate AUC
full_acq_auc <- as.numeric(pROC::auc(pROC::roc(test_last_obs$acquisition, acq_full_scores, quiet = TRUE)))
# Get concordance (Harrell's C-index) for acquisition model
if (!is.null(cv_acq_model)) {
full_acq_concordance <- as.numeric(cv_acq_model$concordance["concordance"])
cat("Acquisition model concordance (C-index):", round(full_acq_concordance, 4), "\n")
} else {
full_acq_concordance <- NA
}
# Calculate no-macro AUC if applicable
no_macro_acq_auc <- if (has_macro_acq && !is.null(cv_acq_no_macro_model)) {
as.numeric(pROC::auc(pROC::roc(test_last_obs$acquisition, acq_no_macro_scores, quiet = TRUE)))
} else {
full_acq_auc
}
# Calculate improvement
acq_improvement <- full_acq_auc - no_macro_acq_auc
# Statistical test if applicable
acq_p_value <- if (has_macro_acq && !is.null(cv_acq_no_macro_model)) {
test_result <- pROC::roc.test(
pROC::roc(test_last_obs$acquisition, acq_full_scores, quiet = TRUE),
pROC::roc(test_last_obs$acquisition, acq_no_macro_scores, quiet = TRUE),
method = "delong"
)
test_result$p.value
} else {
NA
}
# Store results
acquisition_cv_results$auc_with_macro[fold_idx] <- full_acq_auc
acquisition_cv_results$auc_no_macro[fold_idx] <- no_macro_acq_auc
acquisition_cv_results$improvement[fold_idx] <- acq_improvement
acquisition_cv_results$p_value[fold_idx] <- acq_p_value
acquisition_cv_results$concordance[fold_idx] <- full_acq_concordance
cat("Acquisition model fold", fold_idx, "- AUC with macro:", round(full_acq_auc, 4),
"- AUC without macro:", round(no_macro_acq_auc, 4),
"- Improvement:", round(acq_improvement, 4),
"- Concordance:", round(full_acq_concordance, 4), "\n")
}, error = function(e) {
cat("Error evaluating acquisition model:", e$message, "\n")
})
}
}
----- Processing Fold 1 of 5 -----
Training set: 4029 companies ( 51032 observations)
Testing set: 1009 companies ( 12559 observations)
Fitting bankruptcy models for fold 1 ...
Fitting acquisition models for fold 1 ...
Evaluating bankruptcy model...
Bankruptcy model concordance (C-index): 0.8794
Bankruptcy model fold 1 - AUC with macro: 0.7567 - AUC without macro: 0.7662 - Improvement: -0.0096 - Concordance: 0.8794
Evaluating acquisition model...
Acquisition model concordance (C-index): 0.6397
Acquisition model fold 1 - AUC with macro: 0.5426 - AUC without macro: 0.5968 - Improvement: -0.0542 - Concordance: 0.6397
----- Processing Fold 2 of 5 -----
Training set: 4030 companies ( 51042 observations)
Testing set: 1008 companies ( 12549 observations)
Fitting bankruptcy models for fold 2 ...
Fitting acquisition models for fold 2 ...
Evaluating bankruptcy model...
Bankruptcy model concordance (C-index): 0.8646
Bankruptcy model fold 2 - AUC with macro: 0.8055 - AUC without macro: 0.7994 - Improvement: 0.0061 - Concordance: 0.8646
Evaluating acquisition model...
Acquisition model concordance (C-index): 0.636
Acquisition model fold 2 - AUC with macro: 0.5313 - AUC without macro: 0.5884 - Improvement: -0.0572 - Concordance: 0.636
----- Processing Fold 3 of 5 -----
Training set: 4030 companies ( 50731 observations)
Testing set: 1008 companies ( 12860 observations)
Fitting bankruptcy models for fold 3 ...
Fitting acquisition models for fold 3 ...
Evaluating bankruptcy model...
Bankruptcy model concordance (C-index): 0.8528
Bankruptcy model fold 3 - AUC with macro: 0.8726 - AUC without macro: 0.8667 - Improvement: 0.0059 - Concordance: 0.8528
Evaluating acquisition model...
Acquisition model concordance (C-index): 0.6466
Acquisition model fold 3 - AUC with macro: 0.5407 - AUC without macro: 0.5932 - Improvement: -0.0524 - Concordance: 0.6466
----- Processing Fold 4 of 5 -----
Training set: 4031 companies ( 50498 observations)
Testing set: 1007 companies ( 13093 observations)
Fitting bankruptcy models for fold 4 ...
Fitting acquisition models for fold 4 ...
Evaluating bankruptcy model...
Bankruptcy model concordance (C-index): 0.8876
Bankruptcy model fold 4 - AUC with macro: 0.7609 - AUC without macro: 0.7547 - Improvement: 0.0062 - Concordance: 0.8876
Evaluating acquisition model...
Acquisition model concordance (C-index): 0.6497
Acquisition model fold 4 - AUC with macro: 0.5033 - AUC without macro: 0.5447 - Improvement: -0.0414 - Concordance: 0.6497
----- Processing Fold 5 of 5 -----
Training set: 4032 companies ( 51061 observations)
Testing set: 1006 companies ( 12530 observations)
Fitting bankruptcy models for fold 5 ...
Fitting acquisition models for fold 5 ...
Evaluating bankruptcy model...
Bankruptcy model concordance (C-index): 0.8471
Bankruptcy model fold 5 - AUC with macro: 0.808 - AUC without macro: 0.8011 - Improvement: 0.0069 - Concordance: 0.8471
Evaluating acquisition model...
Acquisition model concordance (C-index): 0.6431
Acquisition model fold 5 - AUC with macro: 0.508 - AUC without macro: 0.5742 - Improvement: -0.0662 - Concordance: 0.6431
#-------------------------------------------------------------
# 13.3: Summarize K-Fold CV Results
#-------------------------------------------------------------
cat("\n13.3: SUMMARIZE K-FOLD CROSS-VALIDATION RESULTS\n")
13.3: SUMMARIZE K-FOLD CROSS-VALIDATION RESULTS
cat("--------------------------------------\n")
--------------------------------------
# Calculate summary statistics for bankruptcy model
bankruptcy_summary <- data.frame(
metric = c("AUC with macro", "AUC without macro", "Improvement", "Concordance"),
mean = c(
mean(bankruptcy_cv_results$auc_with_macro, na.rm = TRUE),
mean(bankruptcy_cv_results$auc_no_macro, na.rm = TRUE),
mean(bankruptcy_cv_results$improvement, na.rm = TRUE),
mean(bankruptcy_cv_results$concordance, na.rm = TRUE)
),
sd = c(
sd(bankruptcy_cv_results$auc_with_macro, na.rm = TRUE),
sd(bankruptcy_cv_results$auc_no_macro, na.rm = TRUE),
sd(bankruptcy_cv_results$improvement, na.rm = TRUE),
sd(bankruptcy_cv_results$concordance, na.rm = TRUE)
),
min = c(
min(bankruptcy_cv_results$auc_with_macro, na.rm = TRUE),
min(bankruptcy_cv_results$auc_no_macro, na.rm = TRUE),
min(bankruptcy_cv_results$improvement, na.rm = TRUE),
min(bankruptcy_cv_results$concordance, na.rm = TRUE)
),
max = c(
max(bankruptcy_cv_results$auc_with_macro, na.rm = TRUE),
max(bankruptcy_cv_results$auc_no_macro, na.rm = TRUE),
max(bankruptcy_cv_results$improvement, na.rm = TRUE),
max(bankruptcy_cv_results$concordance, na.rm = TRUE)
)
)
# Calculate summary statistics for acquisition model
acquisition_summary <- data.frame(
metric = c("AUC with macro", "AUC without macro", "Improvement", "Concordance"),
mean = c(
mean(acquisition_cv_results$auc_with_macro, na.rm = TRUE),
mean(acquisition_cv_results$auc_no_macro, na.rm = TRUE),
mean(acquisition_cv_results$improvement, na.rm = TRUE),
mean(acquisition_cv_results$concordance, na.rm = TRUE)
),
sd = c(
sd(acquisition_cv_results$auc_with_macro, na.rm = TRUE),
sd(acquisition_cv_results$auc_no_macro, na.rm = TRUE),
sd(acquisition_cv_results$improvement, na.rm = TRUE),
sd(acquisition_cv_results$concordance, na.rm = TRUE)
),
min = c(
min(acquisition_cv_results$auc_with_macro, na.rm = TRUE),
min(acquisition_cv_results$auc_no_macro, na.rm = TRUE),
min(acquisition_cv_results$improvement, na.rm = TRUE),
min(acquisition_cv_results$concordance, na.rm = TRUE)
),
max = c(
max(acquisition_cv_results$auc_with_macro, na.rm = TRUE),
max(acquisition_cv_results$auc_no_macro, na.rm = TRUE),
max(acquisition_cv_results$improvement, na.rm = TRUE),
max(acquisition_cv_results$concordance, na.rm = TRUE)
)
)
# Print summary results
cat("\nBankruptcy Model Cross-Validation Summary:\n")
Bankruptcy Model Cross-Validation Summary:
print(bankruptcy_summary)
cat("\nAcquisition Model Cross-Validation Summary:\n")
Acquisition Model Cross-Validation Summary:
print(acquisition_summary)
# Count significant improvements for bankruptcy model
sig_bank_improvements <- sum(bankruptcy_cv_results$p_value < 0.05, na.rm = TRUE)
total_bank_tests <- sum(!is.na(bankruptcy_cv_results$p_value))
cat("\nSignificant macro variable improvements for bankruptcy model:",
sig_bank_improvements, "out of", total_bank_tests, "folds\n")
Significant macro variable improvements for bankruptcy model: 0 out of 5 folds
# Count significant improvements for acquisition model
sig_acq_improvements <- sum(acquisition_cv_results$p_value < 0.05, na.rm = TRUE)
total_acq_tests <- sum(!is.na(acquisition_cv_results$p_value))
cat("Significant macro variable improvements for acquisition model:",
sig_acq_improvements, "out of", total_acq_tests, "folds\n")
Significant macro variable improvements for acquisition model: 5 out of 5 folds
# Overall significance test (one-sample t-test on improvements)
if (has_macro_bank) {
bank_t_test <- t.test(bankruptcy_cv_results$improvement)
cat("\nOverall significance test for bankruptcy model macro improvements:\n")
cat("Mean improvement:", round(bank_t_test$estimate, 4), "\n")
cat("95% CI:", paste(round(bank_t_test$conf.int, 4), collapse=" to "), "\n")
cat("p-value:", format.pval(bank_t_test$p.value, digits = 3), "\n")
if (bank_t_test$p.value < 0.05) {
cat("Conclusion: Macroeconomic variables significantly improve bankruptcy prediction (p < 0.05)\n")
} else {
cat("Conclusion: Macro improvements for bankruptcy prediction are not statistically significant\n")
}
}
Overall significance test for bankruptcy model macro improvements:
Mean improvement: 0.0031
95% CI: -0.0057 to 0.0119
p-value: 0.385
Conclusion: Macro improvements for bankruptcy prediction are not statistically significant
if (has_macro_acq) {
acq_t_test <- t.test(acquisition_cv_results$improvement)
cat("\nOverall significance test for acquisition model macro improvements:\n")
cat("Mean improvement:", round(acq_t_test$estimate, 4), "\n")
cat("95% CI:", paste(round(acq_t_test$conf.int, 4), collapse=" to "), "\n")
cat("p-value:", format.pval(acq_t_test$p.value, digits = 3), "\n")
if (acq_t_test$p.value < 0.05) {
cat("Conclusion: Macroeconomic variables significantly improve acquisition prediction (p < 0.05)\n")
} else {
cat("Conclusion: Macro improvements for acquisition prediction are not statistically significant\n")
}
}
Overall significance test for acquisition model macro improvements:
Mean improvement: -0.0543
95% CI: -0.0653 to -0.0432
p-value: 0.000169
Conclusion: Macroeconomic variables significantly improve acquisition prediction (p < 0.05)
# Create plots to visualize results
if (requireNamespace("ggplot2", quietly = TRUE)) {
# Prepare data for plotting
bank_plot_data <- bankruptcy_cv_results %>%
pivot_longer(cols = c(auc_with_macro, auc_no_macro),
names_to = "model_type",
values_to = "auc") %>%
mutate(model_type = factor(model_type,
levels = c("auc_with_macro", "auc_no_macro"),
labels = c("With Macro", "Without Macro")),
fold = as.factor(fold))
acq_plot_data <- acquisition_cv_results %>%
pivot_longer(cols = c(auc_with_macro, auc_no_macro),
names_to = "model_type",
values_to = "auc") %>%
mutate(model_type = factor(model_type,
levels = c("auc_with_macro", "auc_no_macro"),
labels = c("With Macro", "Without Macro")),
fold = as.factor(fold))
# Create bankruptcy model plot
bank_plot <- ggplot(bank_plot_data, aes(x = fold, y = auc, fill = model_type)) +
geom_bar(stat = "identity", position = "dodge") +
geom_hline(yintercept = mean(bankruptcy_cv_results$auc_with_macro, na.rm = TRUE),
linetype = "dashed", color = "darkred") +
geom_hline(yintercept = mean(bankruptcy_cv_results$auc_no_macro, na.rm = TRUE),
linetype = "dashed", color = "darkblue") +
labs(title = "Bankruptcy Model Performance Across Folds",
subtitle = paste("Average AUC With Macro:",
round(mean(bankruptcy_cv_results$auc_with_macro, na.rm = TRUE), 4)),
x = "Fold",
y = "AUC",
fill = "Model Type") +
theme_minimal() +
scale_fill_manual(values = c("With Macro" = "darkred", "Without Macro" = "darkblue"))
# Create acquisition model plot
acq_plot <- ggplot(acq_plot_data, aes(x = fold, y = auc, fill = model_type)) +
geom_bar(stat = "identity", position = "dodge") +
geom_hline(yintercept = mean(acquisition_cv_results$auc_with_macro, na.rm = TRUE),
linetype = "dashed", color = "darkgreen") +
geom_hline(yintercept = mean(acquisition_cv_results$auc_no_macro, na.rm = TRUE),
linetype = "dashed", color = "darkorange") +
labs(title = "Acquisition Model Performance Across Folds",
subtitle = paste("Average AUC With Macro:",
round(mean(acquisition_cv_results$auc_with_macro, na.rm = TRUE), 4)),
x = "Fold",
y = "AUC",
fill = "Model Type") +
theme_minimal() +
scale_fill_manual(values = c("With Macro" = "darkgreen", "Without Macro" = "darkorange"))
print(bank_plot)
print(acq_plot)
# Save plots
ggsave("bankruptcy_cv_results.png", bank_plot, width = 10, height = 6)
ggsave("acquisition_cv_results.png", acq_plot, width = 10, height = 6)
}
Next, we use a different approach where we split the dataset based on the IPO date of the companies. This method allows us to analyze how the model performs over time, which can be particularly useful in survival analysis. We will create a training set with companies that went public before a certain date and a testing set with companies that went public after that date. This approach helps us understand how well our model generalizes to new companies entering the market.
#-------------------------------------------------------------
# STEP 14: Time-Based Split for Survival Analysis
#-------------------------------------------------------------
cat("\n=== STEP 14: TIME-BASED SPLIT FOR SURVIVAL ANALYSIS ===\n")
=== STEP 14: TIME-BASED SPLIT FOR SURVIVAL ANALYSIS ===
#-------------------------------------------------------------
# 14.1: IPO Date-Based Splitting
#-------------------------------------------------------------
cat("\n14.1: IPO DATE-BASED SPLITTING\n")
14.1: IPO DATE-BASED SPLITTING
cat("--------------------------------------\n")
--------------------------------------
# Function to get company IPO dates (using first appearance date as proxy)
get_company_ipo_dates <- function(data) {
# For each company, use the company_start_date already calculated
company_ipo_dates <- data %>%
group_by(cusip) %>%
summarize(
ipo_date = min(company_start_date, na.rm = TRUE)
) %>%
ungroup()
return(company_ipo_dates)
}
# Get IPO dates
company_ipo_dates <- get_company_ipo_dates(data)
# Display range of IPO dates
cat("IPO date range in dataset:\n")
IPO date range in dataset:
date_range <- range(company_ipo_dates$ipo_date, na.rm = TRUE)
cat("Earliest IPO date:", as.character(date_range[1]), "\n")
Earliest IPO date: 1985-01-01
cat("Latest IPO date:", as.character(date_range[2]), "\n")
Latest IPO date: 2024-01-01
# Determine temporal distribution of IPOs
ipo_years <- as.numeric(format(company_ipo_dates$ipo_date, "%Y"))
ipo_year_counts <- table(ipo_years)
cat("\nIPO distribution by year:\n")
IPO distribution by year:
print(ipo_year_counts)
ipo_years
1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011
7 54 150 56 38 63 150 203 265 231 270 431 343 269 342 268 44 35 28 93 109 120 122 26 33 65 64
2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024
74 91 127 72 54 71 86 68 115 265 58 47 31
# Determine splitting approach
cat("\nChoosing temporal split approach...\n")
Choosing temporal split approach...
# Option 1: Split at specific year (e.g., 2010)
split_year <- 2010
early_companies <- company_ipo_dates$cusip[as.numeric(format(company_ipo_dates$ipo_date, "%Y")) < split_year]
late_companies <- company_ipo_dates$cusip[as.numeric(format(company_ipo_dates$ipo_date, "%Y")) >= split_year]
cat("Option 1: Split at year", split_year, "\n")
Option 1: Split at year 2010
cat("Training set (before", split_year, "):", length(early_companies), "companies\n")
Training set (before 2010 ): 3750 companies
cat("Testing set (", split_year, "and after):", length(late_companies), "companies\n")
Testing set ( 2010 and after): 1288 companies
# Option 2: Split by percentile (e.g., first 70% of IPOs chronologically)
ipo_sorted <- company_ipo_dates[order(company_ipo_dates$ipo_date), ]
train_size_pct <- 0.7
train_cutoff_idx <- round(nrow(ipo_sorted) * train_size_pct)
train_cutoff_date <- ipo_sorted$ipo_date[train_cutoff_idx]
chronological_early <- ipo_sorted$cusip[1:train_cutoff_idx]
chronological_late <- ipo_sorted$cusip[(train_cutoff_idx+1):nrow(ipo_sorted)]
cat("\nOption 2: Split at", train_size_pct*100, "percentile of IPO dates\n")
Option 2: Split at 70 percentile of IPO dates
cat("Training set (IPO before", as.character(train_cutoff_date), "):",
length(chronological_early), "companies\n")
Training set (IPO before 2006-01-01 ): 3527 companies
cat("Testing set (IPO on or after", as.character(train_cutoff_date), "):",
length(chronological_late), "companies\n")
Testing set (IPO on or after 2006-01-01 ): 1511 companies
# Choose the splitting approach (could prompt user here)
# For now, let's use Option 1 (specific year)
train_companies <- early_companies
test_companies <- late_companies
split_method <- paste("IPO year <", split_year, "vs >=", split_year)
cat("\nUsing Option 1: Split at specific year (", split_year, ")\n")
Using Option 1: Split at specific year ( 2010 )
# Create the time-split datasets
time_train_data <- data[data$cusip %in% train_companies, ]
time_test_data <- data[data$cusip %in% test_companies, ]
cat("Training set:", length(train_companies), "companies (", nrow(time_train_data), "observations)\n")
Training set: 3750 companies ( 55794 observations)
cat("Testing set:", length(test_companies), "companies (", nrow(time_test_data), "observations)\n")
Testing set: 1288 companies ( 7797 observations)
# Check event distribution in training and testing sets
analyze_time_events <- function(data_subset, label) {
# Get final observation for each company
final_obs <- data_subset %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Count event types
n_bankruptcy <- sum(final_obs$bankruptcy)
n_acquisition <- sum(final_obs$acquisition)
n_censored <- sum(final_obs$bankruptcy == 0 & final_obs$acquisition == 0)
n_total <- nrow(final_obs)
cat("\nEvent distribution in", label, "set:\n")
cat("- Bankruptcies:", n_bankruptcy, sprintf("(%.1f%%)", 100*n_bankruptcy/n_total), "\n")
cat("- Acquisitions:", n_acquisition, sprintf("(%.1f%%)", 100*n_acquisition/n_total), "\n")
cat("- Censored:", n_censored, sprintf("(%.1f%%)", 100*n_censored/n_total), "\n")
return(data.frame(
bankruptcies = n_bankruptcy,
acquisitions = n_acquisition,
censored = n_censored,
total = n_total
))
}
time_train_events <- analyze_time_events(time_train_data, "training (early IPOs)")
Event distribution in training (early IPOs) set:
- Bankruptcies: 155 (4.1%)
- Acquisitions: 1842 (49.1%)
- Censored: 1753 (46.7%)
time_test_events <- analyze_time_events(time_test_data, "testing (late IPOs)")
Event distribution in testing (late IPOs) set:
- Bankruptcies: 21 (1.6%)
- Acquisitions: 312 (24.2%)
- Censored: 955 (74.1%)
# Check distribution of macroeconomic variables across sets
check_macro_time_distribution <- function(train_data, test_data) {
macro_vars <- c("gdp_growth", "gdp_deflator", "unemployement")
available_macro <- intersect(macro_vars, colnames(train_data))
if(length(available_macro) > 0) {
cat("\nDistribution of macroeconomic variables across time-based sets:\n")
cat("--------------------------------------------------------\n")
for(var in available_macro) {
train_mean <- mean(train_data[[var]], na.rm = TRUE)
train_sd <- sd(train_data[[var]], na.rm = TRUE)
train_min <- min(train_data[[var]], na.rm = TRUE)
train_max <- max(train_data[[var]], na.rm = TRUE)
test_mean <- mean(test_data[[var]], na.rm = TRUE)
test_sd <- sd(test_data[[var]], na.rm = TRUE)
test_min <- min(test_data[[var]], na.rm = TRUE)
test_max <- max(test_data[[var]], na.rm = TRUE)
cat("\nVariable:", var, "\n")
cat("Early IPO set: Mean =", round(train_mean, 2), "SD =", round(train_sd, 2),
"Range =", round(train_min, 2), "to", round(train_max, 2), "\n")
cat("Late IPO set: Mean =", round(test_mean, 2), "SD =", round(test_sd, 2),
"Range =", round(test_min, 2), "to", round(test_max, 2), "\n")
# Calculate the difference in means as percentage of training SD
mean_diff <- abs(train_mean - test_mean)
pct_diff <- mean_diff / train_sd * 100
cat("Difference: ", round(mean_diff, 2), "(", round(pct_diff, 1),
"% of early IPO SD)\n")
if(pct_diff > 25) {
cat("WARNING: Substantial difference in distribution of", var, "between time periods\n")
cat(" This may reflect genuine economic changes between the periods\n")
}
}
} else {
cat("\nNo macroeconomic variables found in the dataset.\n")
}
}
check_macro_time_distribution(time_train_data, time_test_data)
Distribution of macroeconomic variables across time-based sets:
--------------------------------------------------------
Variable: gdp_growth
Early IPO set: Mean = 2.69 SD = 1.67 Range = -2.58 to 6.06
Late IPO set: Mean = 2.58 SD = 1.87 Range = -2.16 to 6.06
Difference: 0.11 ( 6.7 % of early IPO SD)
Variable: gdp_deflator
Early IPO set: Mean = 2.15 SD = 1.03 Range = 0.62 to 7.13
Late IPO set: Mean = 2.99 SD = 1.9 Range = 0.93 to 7.13
Difference: 0.84 ( 81.5 % of early IPO SD)
WARNING: Substantial difference in distribution of gdp_deflator between time periods
This may reflect genuine economic changes between the periods
Variable: unemployement
Early IPO set: Mean = 5.65 SD = 1.58 Range = 3.64 to 9.63
Late IPO set: Mean = 4.98 SD = 1.62 Range = 3.64 to 9.63
Difference: 0.66 ( 41.8 % of early IPO SD)
WARNING: Substantial difference in distribution of unemployement between time periods
This may reflect genuine economic changes between the periods
# Ensure the time variable exists in both sets
if(!"tt" %in% colnames(time_train_data)) time_train_data$tt <- time_train_data$tstop
if(!"tt" %in% colnames(time_test_data)) time_test_data$tt <- time_test_data$tstop
#-------------------------------------------------------------
# 14.2: TIME-BASED SPLIT MODEL TRAINING
#-------------------------------------------------------------
cat("\n14.2: TIME-BASED SPLIT MODEL TRAINING\n")
14.2: TIME-BASED SPLIT MODEL TRAINING
cat("--------------------------------------\n")
--------------------------------------
# Get formula from the final models
bank_formula <- formula(final_bankruptcy_model)
acq_formula <- formula(final_acquisition_model)
# Create versions without macro variables
no_macro_bank_formula <- create_no_macro_formula(bank_formula)
no_macro_acq_formula <- create_no_macro_formula(acq_formula)
# Check if formulas are different
has_macro_bank <- !identical(bank_formula, no_macro_bank_formula)
has_macro_acq <- !identical(acq_formula, no_macro_acq_formula)
# For bankruptcy model
cat("Training bankruptcy models on early IPO companies...\n")
Training bankruptcy models on early IPO companies...
# Fit full model with macro variables
time_bank_model <- tryCatch({
coxph(bank_formula, data = time_train_data, ties = "efron")
}, error = function(e) {
cat("Error fitting full bankruptcy model on early IPO data:", e$message, "\n")
cat("Attempting simplified model without time interactions...\n")
# Try without time interactions
simple_bank_formula <- update(bank_formula, . ~ . - .:.)
tryCatch({
coxph(simple_bank_formula, data = time_train_data, ties = "efron")
}, error = function(e2) {
cat("Error fitting simplified model:", e2$message, "\n")
return(NULL)
})
})
# Fit version without macro variables (if applicable)
if (has_macro_bank) {
time_bank_no_macro_model <- tryCatch({
coxph(no_macro_bank_formula, data = time_train_data, ties = "efron")
}, error = function(e) {
cat("Error fitting no-macro bankruptcy model:", e$message, "\n")
# Try without time interactions
simple_no_macro_formula <- update(no_macro_bank_formula, . ~ . - .:.)
tryCatch({
coxph(simple_no_macro_formula, data = time_train_data, ties = "efron")
}, error = function(e2) {
cat("Error fitting simplified no-macro model:", e2$message, "\n")
return(NULL)
})
})
} else {
time_bank_no_macro_model <- time_bank_model
cat("Bankruptcy model does not contain macro variables.\n")
}
# For acquisition model
cat("\nTraining acquisition models on early IPO companies...\n")
Training acquisition models on early IPO companies...
# Fit full model with macro variables
time_acq_model <- tryCatch({
coxph(acq_formula, data = time_train_data, ties = "efron")
}, error = function(e) {
cat("Error fitting full acquisition model on early IPO data:", e$message, "\n")
cat("Attempting simplified model without time interactions...\n")
# Try without time interactions
simple_acq_formula <- update(acq_formula, . ~ . - .:.)
tryCatch({
coxph(simple_acq_formula, data = time_train_data, ties = "efron")
}, error = function(e2) {
cat("Error fitting simplified model:", e2$message, "\n")
return(NULL)
})
})
# Fit version without macro variables (if applicable)
if (has_macro_acq) {
time_acq_no_macro_model <- tryCatch({
coxph(no_macro_acq_formula, data = time_train_data, ties = "efron")
}, error = function(e) {
cat("Error fitting no-macro acquisition model:", e$message, "\n")
# Try without time interactions
simple_no_macro_formula <- update(no_macro_acq_formula, . ~ . - .:.)
tryCatch({
coxph(simple_no_macro_formula, data = time_train_data, ties = "efron")
}, error = function(e2) {
cat("Error fitting simplified no-macro model:", e2$message, "\n")
return(NULL)
})
})
} else {
time_acq_no_macro_model <- time_acq_model
cat("Acquisition model does not contain macro variables.\n")
}
# Check if models were successfully fit
cat("\nModels successfully trained on early IPO data:\n")
Models successfully trained on early IPO data:
if (!is.null(time_bank_model)) {
cat("- Bankruptcy model (full): Yes\n")
cat(" Number of coefficients:", length(coef(time_bank_model)), "\n")
} else {
cat("- Bankruptcy model (full): FAILED\n")
}
- Bankruptcy model (full): Yes
Number of coefficients: 23
if (has_macro_bank && !is.null(time_bank_no_macro_model)) {
cat("- Bankruptcy model (no macro): Yes\n")
cat(" Number of coefficients:", length(coef(time_bank_no_macro_model)), "\n")
} else if (has_macro_bank) {
cat("- Bankruptcy model (no macro): FAILED\n")
}
- Bankruptcy model (no macro): Yes
Number of coefficients: 20
if (!is.null(time_acq_model)) {
cat("- Acquisition model (full): Yes\n")
cat(" Number of coefficients:", length(coef(time_acq_model)), "\n")
} else {
cat("- Acquisition model (full): FAILED\n")
}
- Acquisition model (full): Yes
Number of coefficients: 18
if (has_macro_acq && !is.null(time_acq_no_macro_model)) {
cat("- Acquisition model (no macro): Yes\n")
cat(" Number of coefficients:", length(coef(time_acq_no_macro_model)), "\n")
} else if (has_macro_acq) {
cat("- Acquisition model (no macro): FAILED\n")
}
- Acquisition model (no macro): Yes
Number of coefficients: 14
#-------------------------------------------------------------
# 14.3: Time-Based Split Model Evaluation
#-------------------------------------------------------------
cat("\n14.3: TIME-BASED SPLIT MODEL EVALUATION\n")
14.3: TIME-BASED SPLIT MODEL EVALUATION
cat("--------------------------------------\n")
--------------------------------------
# Function to evaluate models on the late IPO test set
evaluate_time_split_performance <- function(full_model, no_macro_model, test_data, event_type, model_name) {
cat("\nEvaluating", model_name, "model on late IPO companies...\n")
# Skip if model is NULL
if (is.null(full_model)) {
cat("Full model is NULL, skipping evaluation.\n")
return(NULL)
}
# Get last observation for each company in test set
test_last_obs <- test_data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Calculate risk scores from full model
tryCatch({
# Calculate risk scores from full model
full_risk_scores <- predict(full_model, newdata = test_last_obs, type = "risk")
# Get concordance (Harrell's C-index)
concordance <- as.numeric(full_model$concordance["concordance"])
cat("Concordance (C-index):", round(concordance, 4), "\n")
# Calculate risk scores from model without macro variables (if applicable)
if (!is.null(no_macro_model) && !identical(full_model, no_macro_model)) {
no_macro_risk_scores <- predict(no_macro_model, newdata = test_last_obs, type = "risk")
has_both_models <- TRUE
} else {
no_macro_risk_scores <- full_risk_scores
has_both_models <- FALSE
}
# Calculate AUC using pROC package
if(requireNamespace("pROC", quietly = TRUE)) {
# Create ROC objects
full_roc <- pROC::roc(test_last_obs[[event_type]], full_risk_scores, quiet = TRUE)
if (has_both_models) {
no_macro_roc <- pROC::roc(test_last_obs[[event_type]], no_macro_risk_scores, quiet = TRUE)
}
# Calculate AUCs
full_auc <- pROC::auc(full_roc)
if (has_both_models) {
no_macro_auc <- pROC::auc(no_macro_roc)
} else {
no_macro_auc <- full_auc
}
# Calculate confidence intervals
full_ci <- pROC::ci(full_roc)
if (has_both_models) {
no_macro_ci <- pROC::ci(no_macro_roc)
} else {
no_macro_ci <- full_ci
}
# Print results
cat("Out-of-time AUC with all variables:", round(full_auc, 4), "\n")
cat("95% Confidence Interval:", paste(round(full_ci[1:2], 4), collapse=" - "), "\n")
if(has_both_models) {
cat("Out-of-time AUC without macro variables:", round(no_macro_auc, 4), "\n")
cat("95% Confidence Interval:", paste(round(no_macro_ci[1:2], 4), collapse=" - "), "\n")
# Calculate improvement from macro variables
auc_diff <- full_auc - no_macro_auc
pct_improvement <- auc_diff / no_macro_auc * 100
cat("AUC improvement from macro variables:", round(auc_diff, 4),
"(", round(pct_improvement, 1), "%)\n")
# Test if improvement is significant
roc_test <- pROC::roc.test(full_roc, no_macro_roc, method = "delong")
cat("Statistical significance: p =", format.pval(roc_test$p.value, digits = 3), "\n")
if(roc_test$p.value < 0.05) {
cat("The improvement from macroeconomic variables is STATISTICALLY SIGNIFICANT (p < 0.05)\n")
} else {
cat("The improvement from macroeconomic variables is not statistically significant (p >= 0.05)\n")
}
}
# Calculate performance metrics at optimal threshold
coords <- pROC::coords(full_roc, "best", ret = c("threshold", "specificity", "sensitivity"))
threshold <- as.numeric(coords["threshold"])
specificity <- as.numeric(coords["specificity"])
sensitivity <- as.numeric(coords["sensitivity"])
predictions <- ifelse(full_risk_scores >= threshold, 1, 0)
actual <- test_last_obs[[event_type]]
TP <- sum(predictions == 1 & actual == 1)
TN <- sum(predictions == 0 & actual == 0)
FP <- sum(predictions == 1 & actual == 0)
FN <- sum(predictions == 0 & actual == 1)
accuracy <- (TP + TN) / (TP + TN + FP + FN)
precision <- if(TP + FP > 0) TP / (TP + FP) else 0
recall <- sensitivity
f1_score <- if(precision + recall > 0) 2 * precision * recall / (precision + recall) else 0
cat("\nClassification metrics at optimal threshold:\n")
cat("Threshold:", round(threshold, 4), "\n")
cat("Accuracy:", round(accuracy, 4), "\n")
cat("Precision:", round(precision, 4), "\n")
cat("Recall:", round(recall, 4), "\n")
cat("F1 Score:", round(f1_score, 4), "\n")
# Return results
return(list(
full_auc = as.numeric(full_auc),
no_macro_auc = as.numeric(no_macro_auc),
auc_diff = as.numeric(full_auc - no_macro_auc),
p_value = if(has_both_models) roc_test$p.value else NA,
threshold = threshold,
accuracy = accuracy,
precision = precision,
recall = recall,
f1_score = f1_score,
concordance = concordance
))
} else {
cat("pROC package not available. Please install it for ROC analysis.\n")
return(NULL)
}
}, error = function(e) {
cat("Error evaluating model:", e$message, "\n")
return(NULL)
})
}
# Evaluate bankruptcy model
bank_time_results <- evaluate_time_split_performance(
time_bank_model,
time_bank_no_macro_model,
time_test_data,
"bankruptcy",
"bankruptcy"
)
Evaluating bankruptcy model on late IPO companies...
Concordance (C-index): 0.8679
Out-of-time AUC with all variables: 0.8044
95% Confidence Interval: 0.7081 - 0.8044
Out-of-time AUC without macro variables: 0.7939
95% Confidence Interval: 0.6952 - 0.7939
AUC improvement from macro variables: 0.0105 ( 1.3 %)
Statistical significance: p = 0.337
The improvement from macroeconomic variables is not statistically significant (p >= 0.05)
Classification metrics at optimal threshold:
Threshold: 5.0779
Accuracy: 0.8463
Precision: 0.0683
Recall: 0.6667
F1 Score: 0.1239
# Evaluate acquisition model
acq_time_results <- evaluate_time_split_performance(
time_acq_model,
time_acq_no_macro_model,
time_test_data,
"acquisition",
"acquisition"
)
Evaluating acquisition model on late IPO companies...
Concordance (C-index): 0.6353
Out-of-time AUC with all variables: 0.5171
95% Confidence Interval: 0.4818 - 0.5171
Out-of-time AUC without macro variables: 0.585
95% Confidence Interval: 0.5504 - 0.585
AUC improvement from macro variables: -0.0679 ( -11.6 %)
Statistical significance: p = 1.2e-12
The improvement from macroeconomic variables is STATISTICALLY SIGNIFICANT (p < 0.05)
Classification metrics at optimal threshold:
Threshold: 0.492
Accuracy: 0.3354
Precision: 0.2589
Recall: 0.9359
F1 Score: 0.4056
We see that the models are performing well on the test set, with AUC values indicating good discrimination ability. The macroeconomic variables also seem to provide a significant improvement in model performance, as indicated by the p-values from the statistical tests.
Finally, we can visualize the hazard ratios for the models, highlighting the variables to interpret their impact on bankruptcy and acquisition predictions.
#-------------------------------------------------------------
# STEP 13: Enhanced Visualization and Interpretation with Macroeconomic Focus
#-------------------------------------------------------------
cat("\n=== STEP 13: ENHANCED VISUALIZATION AND INTERPRETATION WITH MACROECONOMIC FOCUS ===\n")
=== STEP 13: ENHANCED VISUALIZATION AND INTERPRETATION WITH MACROECONOMIC FOCUS ===
#-------------------------------------------------------------
# 13.1: Enhanced Hazard Ratio Visualization with Macro Highlighting
#-------------------------------------------------------------
cat("\n13.1: ENHANCED HAZARD RATIO VISUALIZATION WITH MACRO HIGHLIGHTING\n")
13.1: ENHANCED HAZARD RATIO VISUALIZATION WITH MACRO HIGHLIGHTING
cat("--------------------------------------\n")
--------------------------------------
# Function to create hazard ratio forest plots with macro variable highlighting
create_hazard_ratio_plot <- function(model, model_name, top_n = 10, highlight_macro = TRUE) {
cat("Creating hazard ratio plot for", model_name, "model...\n")
# Extract coefficients and confidence intervals
coefs <- summary(model)$coefficients
conf_int <- confint(model)
# Create data frame for plotting
hr_data <- data.frame(
Variable = rownames(coefs),
HR = exp(coefs[, "coef"]),
Lower = exp(conf_int[, 1]),
Upper = exp(conf_int[, 2]),
Pvalue = coefs[, "Pr(>|z|)"],
stringsAsFactors = FALSE
)
# Remove time interactions for this plot
hr_data <- hr_data[!grepl(":tt", hr_data$Variable), ]
# Identify macro variables
macro_vars <- c("gdp_growth", "gdp_deflator", "unemployement")
hr_data$is_macro <- sapply(hr_data$Variable, function(x)
any(sapply(macro_vars, function(m) grepl(m, x))))
# Sort by statistical significance
hr_data <- hr_data[order(hr_data$Pvalue), ]
# If highlighting macro, ensure they're included in top variables
if(highlight_macro) {
macro_rows <- hr_data[hr_data$is_macro, ]
non_macro_rows <- hr_data[!hr_data$is_macro, ]
# Take top non-macro variables
top_non_macro <- min(nrow(non_macro_rows), max(5, top_n - nrow(macro_rows)))
non_macro_rows <- non_macro_rows[1:top_non_macro, ]
# Combine and re-sort by p-value
hr_data <- rbind(non_macro_rows, macro_rows)
hr_data <- hr_data[order(hr_data$Pvalue), ]
} else {
# Take top N most significant variables
if(nrow(hr_data) > top_n) {
hr_data <- hr_data[1:top_n, ]
}
}
# Reverse order for plotting (bottom to top)
hr_data <- hr_data[nrow(hr_data):1, ]
# Create significance symbols
hr_data$sig <- ""
hr_data$sig[hr_data$Pvalue < 0.001] <- "***"
hr_data$sig[hr_data$Pvalue >= 0.001 & hr_data$Pvalue < 0.01] <- "**"
hr_data$sig[hr_data$Pvalue >= 0.01 & hr_data$Pvalue < 0.05] <- "*"
hr_data$sig[hr_data$Pvalue >= 0.05 & hr_data$Pvalue < 0.1] <- "."
# Set up the plotting area
par(mar = c(5, 10, 4, 2) + 0.1) # Adjust margins for variable names
# Create empty plot with appropriate limits
max_upper <- max(hr_data$Upper)
if(max_upper > 10) max_upper <- 10 # Cap for extreme values
plot_max <- max(3, max_upper)
plot(NULL, xlim = c(0, plot_max), ylim = c(0.5, nrow(hr_data) + 0.5),
xlab = "Hazard Ratio (log scale)", ylab = "", yaxt = "n",
main = paste("Hazard Ratios for", model_name, "Model"))
# Add reference line at HR = 1
abline(v = 1, lty = 2, col = "darkgray")
# Add variable names with different colors for macro variables
var_labels <- hr_data$Variable
# Add variable names - need to handle colors separately since col.axis must be a single color
axis(2, at = 1:nrow(hr_data), labels = paste0(var_labels, " ", hr_data$sig),
las = 2, cex.axis = 0.8)
# Highlight macro variables with colored rectangles if any exist
if(any(hr_data$is_macro)) {
for(i in which(hr_data$is_macro)) {
rect(par("usr")[1], i - 0.4, par("usr")[1] + 0.1, i + 0.4,
col = "lightblue", border = NA, xpd = TRUE)
}
}
# Plot confidence intervals
segments(hr_data$Lower, 1:nrow(hr_data), hr_data$Upper, 1:nrow(hr_data),
lwd = 2, col = ifelse(hr_data$is_macro, "navy", "darkblue"))
# Plot point estimates with different colors for macro vs financial variables
point_colors <- ifelse(hr_data$is_macro,
ifelse(hr_data$HR > 1, "darkred", "darkgreen"),
ifelse(hr_data$HR > 1, "red", "green4"))
points(hr_data$HR, 1:nrow(hr_data), pch = 16, cex = 1.2,
col = point_colors)
# Add numeric values
text(hr_data$HR + 0.1, 1:nrow(hr_data),
labels = sprintf("%.2f", hr_data$HR), cex = 0.7)
# Add significance legend
legend("topright",
legend = c("p < 0.001 (***)", "p < 0.01 (**)", "p < 0.05 (*)", "p < 0.1 (.)"),
bty = "n", cex = 0.8)
# Add color legend for macro vs financial variables
if(any(hr_data$is_macro)) {
legend("bottomright",
legend = c("Macroeconomic Variable", "Financial Variable"),
fill = c("lightblue", "white"),
border = "black",
bty = "n", cex = 0.8)
}
# Add interpretation note
mtext("HR > 1: Increased risk, HR < 1: Decreased risk", side = 3, line = 0.5, cex = 0.8)
cat("Hazard ratio plot created for", model_name, "model.\n")
# Return the hazard ratio data for further analysis
return(hr_data)
}
# Create hazard ratio plots for both models
bankruptcy_hrs <- create_hazard_ratio_plot(final_bankruptcy_model, "Bankruptcy")
Creating hazard ratio plot for Bankruptcy model...
Hazard ratio plot created for Bankruptcy model.
acquisition_hrs <- create_hazard_ratio_plot(final_acquisition_model, "Acquisition")
Creating hazard ratio plot for Acquisition model...
Hazard ratio plot created for Acquisition model.
Now that we’re done with the model training and evaluation, we do an additional visualization for the macroeconomic impact on the models. This will help us understand how changes in macroeconomic variables affect the risk of bankruptcy and acquisition.
#-------------------------------------------------------------
# 13.2: Dedicated Macroeconomic Impact Visualization
#-------------------------------------------------------------
cat("\n13.2: MACROECONOMIC IMPACT VISUALIZATION\n")
13.2: MACROECONOMIC IMPACT VISUALIZATION
cat("--------------------------------------\n")
--------------------------------------
visualize_macro_impact <- function(model, model_name, event_type) {
# Extract coefficients related to macro variables
coefs <- coef(model)
macro_vars <- c("gdp_growth", "gdp_deflator", "unemployement")
# Find macro variables in the model
model_macro_vars <- macro_vars[sapply(macro_vars, function(v) v %in% names(coefs))]
if(length(model_macro_vars) == 0) {
cat("No macroeconomic variables found in the", model_name, "model.\n")
return(NULL)
}
cat("Visualizing macroeconomic impacts for", model_name, "model...\n")
# Extract coefficients and confidence intervals for macro variables
coef_summary <- summary(model)$coefficients
conf_int <- confint(model)
# Create data frame for plotting
macro_data <- data.frame(
Variable = model_macro_vars,
Coefficient = coefs[model_macro_vars],
HR = exp(coefs[model_macro_vars]),
Lower = exp(conf_int[model_macro_vars, 1]),
Upper = exp(conf_int[model_macro_vars, 2]),
Pvalue = coef_summary[model_macro_vars, "Pr(>|z|)"],
stringsAsFactors = FALSE
)
# Add interpretable variable names
macro_data$Label <- sapply(macro_data$Variable, function(v) {
if(v == "gdp_growth") return("GDP Growth")
if(v == "gdp_deflator") return("Inflation (GDP Deflator)")
if(v == "unemployement") return("Unemployment Rate")
return(v)
})
# Sort by effect size (absolute coefficient)
macro_data <- macro_data[order(abs(macro_data$Coefficient), decreasing = TRUE), ]
# 1. Create bar plot of macro variable hazard ratios
# Set up the plotting area
par(mar = c(5, 10, 4, 2) + 0.1)
# Create horizontal bar plot of hazard ratios
barplot_result <- barplot(macro_data$HR - 1, names.arg = macro_data$Label,
main = paste("Impact of Macroeconomic Variables on", model_name, "Risk"),
xlab = "Change in Risk (%)", ylab = "",
horiz = TRUE, xlim = c(min(-0.5, min(macro_data$HR - 1) * 1.2),
max(0.5, max(macro_data$HR - 1) * 1.2)),
col = ifelse(macro_data$HR > 1, "firebrick", "forestgreen"),
las = 1)
# Add vertical reference line at 0
abline(v = 0, lty = 2, col = "black")
# Add data labels
text_pos <- ifelse(macro_data$HR > 1,
macro_data$HR - 1 + 0.03,
macro_data$HR - 1 - 0.03)
text(text_pos, barplot_result,
labels = sprintf("%+.1f%%", (macro_data$HR - 1) * 100),
cex = 0.9, col = ifelse(macro_data$HR > 1, "firebrick", "forestgreen"))
# Add significance symbols
significance <- rep("", nrow(macro_data))
significance[macro_data$Pvalue < 0.001] <- "***"
significance[macro_data$Pvalue >= 0.001 & macro_data$Pvalue < 0.01] <- "**"
significance[macro_data$Pvalue >= 0.01 & macro_data$Pvalue < 0.05] <- "*"
significance[macro_data$Pvalue >= 0.05 & macro_data$Pvalue < 0.1] <- "."
text(ifelse(macro_data$HR > 1, max(0.1, max(macro_data$HR - 1) * 0.8),
min(-0.1, min(macro_data$HR - 1) * 0.8)),
barplot_result,
labels = significance,
cex = 1.2)
# Add interpretation note
mtext("Effect of a 1-unit increase in each variable", side = 3, line = 0.5, cex = 0.8)
# Add significance legend
legend("bottomright",
legend = c("p < 0.001 (***)", "p < 0.01 (**)", "p < 0.05 (*)", "p < 0.1 (.)"),
bty = "n", cex = 0.8)
# 2. Create visual representation of how economic indicators affect risk
# Only if we have at least two macro variables
if(nrow(macro_data) >= 2) {
# Calculate min and max values of each macro variable in the data
var_ranges <- data.frame(
Variable = model_macro_vars,
Min = NA,
Max = NA,
Mean = NA,
SD = NA
)
for(i in 1:nrow(var_ranges)) {
var <- var_ranges$Variable[i]
if(var %in% colnames(data)) {
var_ranges$Min[i] <- min(data[[var]], na.rm = TRUE)
var_ranges$Max[i] <- max(data[[var]], na.rm = TRUE)
var_ranges$Mean[i] <- mean(data[[var]], na.rm = TRUE)
var_ranges$SD[i] <- sd(data[[var]], na.rm = TRUE)
}
}
# Set up a new plot
par(mar = c(5, 10, 4, 2) + 0.1)
# Create a risk matrix visualization
plot(NULL, xlim = c(-1, 1), ylim = c(0, nrow(macro_data) + 1),
xlab = "Economic Condition", ylab = "", yaxt = "n",
main = paste("Economic Conditions and", model_name, "Risk"))
# Add y-axis labels
axis(2, at = 1:nrow(macro_data), labels = macro_data$Label, las = 1)
# Add x-axis
axis(1, at = seq(-1, 1, 0.5),
labels = c("Very Low", "Low", "Average", "High", "Very High"))
# Add reference line at 0
abline(v = 0, lty = 2, col = "darkgray")
# Add arrows showing the direction of effect
for(i in 1:nrow(macro_data)) {
arrow_color <- ifelse(macro_data$HR[i] > 1, "red", "green4")
arrow_length <- min(0.9, abs(log(macro_data$HR[i])))
arrow_dir <- sign(log(macro_data$HR[i]))
arrows(0, i, arrow_dir * arrow_length, i, col = arrow_color,
length = 0.15, lwd = 2 + abs(log(macro_data$HR[i])))
# Add text showing increased/decreased risk
if(macro_data$HR[i] > 1) {
text(arrow_dir * arrow_length + 0.1, i,
paste0("+", round((macro_data$HR[i] - 1) * 100), "% risk"),
col = arrow_color, cex = 0.8)
} else {
text(arrow_dir * arrow_length - 0.1, i,
paste0("-", round((1 - macro_data$HR[i]) * 100), "% risk"),
col = arrow_color, cex = 0.8)
}
}
# Add legend
legend("topright",
legend = c("Increases Risk", "Decreases Risk"),
col = c("red", "green4"),
lwd = 2, bty = "n")
mtext("How Economic Indicators Affect Risk", side = 3, line = 0.5, cex = 0.8)
}
# 3. If we have time interactions, create a time-varying effects visualization
time_terms <- names(coefs)[grepl(":tt", names(coefs))]
macro_time_terms <- time_terms[sapply(time_terms, function(term) {
var_name <- strsplit(term, ":")[[1]][1]
return(var_name %in% macro_vars)
})]
if(length(macro_time_terms) > 0) {
cat("\nVisualize time-varying effects of macroeconomic variables...\n")
# For each macro variable with a time-varying effect, create a plot
for(time_term in macro_time_terms) {
var_name <- strsplit(time_term, ":")[[1]][1]
# Get coefficients
main_coef <- coefs[var_name]
time_coef <- coefs[time_term]
# Create readable variable name
var_label <- if(var_name == "gdp_growth") "GDP Growth" else
if(var_name == "gdp_deflator") "Inflation (GDP Deflator)" else
if(var_name == "unemployement") "Unemployment Rate" else var_name
# Set up time sequence
max_time <- max(data$tstop)
times <- seq(0, max_time, length.out = 100)
# Calculate hazard ratios over time (for a 1-unit change in the variable)
hrs <- exp(main_coef + time_coef * times)
# Set up a new plot
par(mar = c(5, 5, 4, 2) + 0.1)
# Create plot
plot(times, hrs, type = "l", lwd = 2, col = "blue",
main = paste("Time-Varying Effect of", var_label, "on", model_name, "Risk"),
xlab = "Time (Years)", ylab = "Hazard Ratio",
ylim = c(min(0.5, min(hrs)), max(2, max(hrs))))
# Add reference line at HR = 1
abline(h = 1, lty = 2, col = "red")
# Add grid for readability
grid()
# Calculate and mark crossover point (if any)
if(sign(main_coef) != sign(time_coef) && time_coef != 0) {
crossover <- -main_coef / time_coef
if(crossover > 0 && crossover < max(times)) {
points(crossover, 1, pch = 16, col = "red", cex = 1.5)
text(crossover, 1.1, paste("Effect reverses at", round(crossover, 1), "years"),
col = "red")
}
}
# Add phase labels for economic interpretation
if(main_coef > 0) {
if(time_coef > 0) {
# Both positive - increasing risk that gets worse over time
early_label <- "Early: Increases Risk"
late_label <- "Later: Risk Increase Strengthens"
economic_msg <- "Economic sensitivity increases with company age"
} else {
# Main positive, time negative - increasing risk that diminishes
early_label <- "Early: Increases Risk"
late_label <- "Later: Risk Increase Weakens"
economic_msg <- "Young companies more sensitive to this economic factor"
}
} else {
if(time_coef > 0) {
# Main negative, time positive - decreasing risk that diminishes
early_label <- "Early: Decreases Risk"
late_label <- "Later: Risk Reduction Weakens"
economic_msg <- "Young companies more protected by this economic factor"
} else {
# Both negative - decreasing risk that gets stronger
early_label <- "Early: Decreases Risk"
late_label <- "Later: Risk Reduction Strengthens"
economic_msg <- "Economic protection increases with company age"
}
}
# Add the phase labels to the plot
text(times[20], hrs[20] + 0.15, early_label, col = "darkgreen", cex = 0.9)
text(times[80], hrs[80] + 0.15, late_label, col = "darkblue", cex = 0.9)
# Add economic interpretation
mtext(economic_msg, side = 3, line = 0.5, cex = 0.8)
}
}
# Print a summary of macroeconomic effects
cat("\nSummary of Macroeconomic Effects on", model_name, "Risk:\n")
cat("---------------------------------------------------\n")
for(i in 1:nrow(macro_data)) {
var <- macro_data$Variable[i]
label <- macro_data$Label[i]
hr <- macro_data$HR[i]
p_val <- macro_data$Pvalue[i]
# Direction of effect
direction <- ifelse(hr > 1, "increases", "decreases")
# Magnitude in percentage
if(hr > 1) {
magnitude <- paste0("+", round((hr - 1) * 100, 1), "%")
} else {
magnitude <- paste0("-", round((1 - hr) * 100, 1), "%")
}
# Significance
significance <- ""
if(p_val < 0.001) significance <- " (p < 0.001) ***"
else if(p_val < 0.01) significance <- paste0(" (p = ", round(p_val, 3), ") **")
else if(p_val < 0.05) significance <- paste0(" (p = ", round(p_val, 3), ") *")
else if(p_val < 0.1) significance <- paste0(" (p = ", round(p_val, 3), ") .")
else significance <- paste0(" (p = ", round(p_val, 3), ")")
# Check for time-varying effect
has_time_effect <- paste0(var, ":tt") %in% names(coefs)
time_effect <- if(has_time_effect) {
time_coef <- coefs[paste0(var, ":tt")]
if(time_coef > 0 && hr > 1) "effect strengthens over time"
else if(time_coef < 0 && hr > 1) "effect weakens over time"
else if(time_coef > 0 && hr < 1) "protection weakens over time"
else "protection strengthens over time"
} else ""
# Economic interpretation
interpretation <- ""
if(var == "gdp_growth") {
if(hr > 1) {
interpretation <- "Higher economic growth corresponds to INCREASED risk"
} else {
interpretation <- "Higher economic growth corresponds to DECREASED risk"
}
} else if(var == "gdp_deflator") {
if(hr > 1) {
interpretation <- "Higher inflation corresponds to INCREASED risk"
} else {
interpretation <- "Higher inflation corresponds to DECREASED risk"
}
} else if(var == "unemployement") {
if(hr > 1) {
interpretation <- "Higher unemployment corresponds to INCREASED risk"
} else {
interpretation <- "Higher unemployment corresponds to DECREASED risk"
}
}
# Print the summary
cat(label, direction, model_name, "risk by", magnitude, significance, "\n")
if(has_time_effect) cat("Time effect:", time_effect, "\n")
cat("Economic interpretation:", interpretation, "\n\n")
}
# Return the macro data for further analysis
return(macro_data)
}
# Visualize macroeconomic impacts for both models
bankruptcy_macro <- visualize_macro_impact(final_bankruptcy_model, "Bankruptcy", "bankruptcy")
Visualizing macroeconomic impacts for Bankruptcy model...
Summary of Macroeconomic Effects on Bankruptcy Risk:
---------------------------------------------------
Inflation (GDP Deflator) decreases Bankruptcy risk by -16.1% (p = 0.051) .
Economic interpretation: Higher inflation corresponds to DECREASED risk
GDP Growth increases Bankruptcy risk by +10.4% (p = 0.084) .
Economic interpretation: Higher economic growth corresponds to INCREASED risk
Unemployment Rate decreases Bankruptcy risk by -7.2% (p = 0.278)
Economic interpretation: Higher unemployment corresponds to DECREASED risk
acquisition_macro <- visualize_macro_impact(final_acquisition_model, "Acquisition", "acquisition")
Visualizing macroeconomic impacts for Acquisition model...
Visualize time-varying effects of macroeconomic variables...
Summary of Macroeconomic Effects on Acquisition Risk:
---------------------------------------------------
Unemployment Rate decreases Acquisition risk by -12.5% (p < 0.001) ***
Time effect: protection weakens over time
Economic interpretation: Higher unemployment corresponds to DECREASED risk
Inflation (GDP Deflator) decreases Acquisition risk by -3.7% (p = 0.085) .
Economic interpretation: Higher inflation corresponds to DECREASED risk
GDP Growth increases Acquisition risk by +3.8% (p = 0.013) *
Economic interpretation: Higher economic growth corresponds to INCREASED risk
More visualizaitions of the macroeconomic impact on the models can be done by comparing the effects of macroeconomic variables on both bankruptcy and acquisition models. This will help us understand how these variables influence the risk of bankruptcy and acquisition in different ways.
#-------------------------------------------------------------
# 13.3: Comparative Macroeconomic Impact Analysis
#-------------------------------------------------------------
cat("\n13.3: COMPARATIVE MACROECONOMIC IMPACT ANALYSIS\n")
13.3: COMPARATIVE MACROECONOMIC IMPACT ANALYSIS
cat("--------------------------------------\n")
--------------------------------------
compare_macro_effects <- function() {
# Get common macro variables that exist in both models
macro_vars <- c("gdp_growth", "gdp_deflator", "unemployement")
# Extract coefficients from both models
bank_coefs <- coef(final_bankruptcy_model)
acq_coefs <- coef(final_acquisition_model)
# Find common macro variables in both models
bank_macro_vars <- macro_vars[sapply(macro_vars, function(v) v %in% names(bank_coefs))]
acq_macro_vars <- macro_vars[sapply(macro_vars, function(v) v %in% names(acq_coefs))]
common_macro_vars <- intersect(bank_macro_vars, acq_macro_vars)
if(length(common_macro_vars) == 0) {
cat("No common macroeconomic variables found in both models for comparison.\n")
return(NULL)
}
cat("Comparing macroeconomic effects between bankruptcy and acquisition models...\n")
# Create data frame for comparison
comparison <- data.frame(
Variable = common_macro_vars,
Bank_Coef = bank_coefs[common_macro_vars],
Bank_HR = exp(bank_coefs[common_macro_vars]),
Acq_Coef = acq_coefs[common_macro_vars],
Acq_HR = exp(acq_coefs[common_macro_vars]),
stringsAsFactors = FALSE
)
# Add variable labels
comparison$Label <- sapply(comparison$Variable, function(v) {
if(v == "gdp_growth") return("GDP Growth")
if(v == "gdp_deflator") return("Inflation (GDP Deflator)")
if(v == "unemployement") return("Unemployment Rate")
return(v)
})
# Add direction of effects
comparison$Bank_Direction <- ifelse(comparison$Bank_HR > 1,
"Increases Risk", "Decreases Risk")
comparison$Acq_Direction <- ifelse(comparison$Acq_HR > 1,
"Increases Risk", "Decreases Risk")
# Check for opposite effects
comparison$Opposite_Effects <- comparison$Bank_Direction != comparison$Acq_Direction
# 1. Create side-by-side bar plot comparing effects
# Set up the plotting area
par(mar = c(5, 10, 4, 2) + 0.1)
# Prepare data for plotting
barplot_data <- cbind(
(comparison$Bank_HR - 1) * 100, # Convert to percentage change
(comparison$Acq_HR - 1) * 100
)
# Find limits for x-axis
max_val <- max(abs(barplot_data)) * 1.2
xlim <- c(-max_val, max_val)
# Create horizontal bar plot
barplot_result <- barplot(t(barplot_data), beside = TRUE, horiz = TRUE,
names.arg = comparison$Label,
main = "Comparative Economic Impact on Company Outcomes",
xlab = "Change in Risk (%)", ylab = "",
col = c("firebrick", "royalblue"),
xlim = xlim,
las = 1)
# Add vertical reference line at 0
abline(v = 0, lty = 2, col = "black")
# Add legend
legend("topright", legend = c("Bankruptcy Risk", "Acquisition Risk"),
fill = c("firebrick", "royalblue"), bty = "n")
# Add data labels
for(i in 1:nrow(comparison)) {
# For bankruptcy
bank_pos <- barplot_result[1, i]
bank_val <- barplot_data[i, 1]
text_pos_bank <- ifelse(bank_val > 0, bank_val + 2, bank_val - 2)
text(text_pos_bank, bank_pos,
labels = sprintf("%+.1f%%", bank_val),
cex = 0.8)
# For acquisition
acq_pos <- barplot_result[2, i]
acq_val <- barplot_data[i, 2]
text_pos_acq <- ifelse(acq_val > 0, acq_val + 2, acq_val - 2)
text(text_pos_acq, acq_pos,
labels = sprintf("%+.1f%%", acq_val),
cex = 0.8)
}
# Mark variables with opposite effects
if(any(comparison$Opposite_Effects)) {
mtext("* Variables with opposite effects on bankruptcy vs acquisition",
side = 3, line = 0.5, cex = 0.8, col = "purple")
# Add markers for opposite effects
for(i in which(comparison$Opposite_Effects)) {
bank_pos <- barplot_result[1, i]
acq_pos <- barplot_result[2, i]
# Add asterisk at the middle
text(xlim[1] + 1, (bank_pos + acq_pos)/2, "*", col = "purple", cex = 1.5)
}
}
# 2. Create a 2x2 economic condition matrix visualization
# This shows how different economic conditions affect both outcomes
if(length(common_macro_vars) >= 2) {
# Create a new plot
par(mar = c(5, 5, 4, 2) + 0.1)
# Set up the plot area - economic conditions matrix
plot(NULL, xlim = c(-1, 1), ylim = c(-1, 1),
xlab = "Bankruptcy Risk", ylab = "Acquisition Risk",
main = "Company Outcomes Under Different Economic Conditions")
# Add reference lines
abline(h = 0, v = 0, lty = 2, col = "darkgray")
# Add quadrant labels
text(0.8, 0.8, "High Bankruptcy\nHigh Acquisition", col = "purple", cex = 0.8)
text(-0.8, 0.8, "Low Bankruptcy\nHigh Acquisition", col = "blue", cex = 0.8)
text(0.8, -0.8, "High Bankruptcy\nLow Acquisition", col = "red", cex = 0.8)
text(-0.8, -0.8, "Low Bankruptcy\nLow Acquisition", col = "green4", cex = 0.8)
# Add arrows for each macro variable
for(i in 1:nrow(comparison)) {
# Calculate arrow direction based on coefficients
bank_effect <- comparison$Bank_Coef[i]
acq_effect <- comparison$Acq_Coef[i]
# Normalize to a reasonable length for visualization
arrow_length <- sqrt(bank_effect^2 + acq_effect^2)
norm_factor <- min(0.8, max(0.3, arrow_length)) / max(0.0001, arrow_length)
x_end <- bank_effect * norm_factor
y_end <- acq_effect * norm_factor
# Draw the arrow
arrows(0, 0, x_end, y_end, length = 0.1,
col = ifelse(comparison$Opposite_Effects[i], "purple", "black"),
lwd = 2)
# Add variable name
text(x_end * 1.1, y_end * 1.1, comparison$Label[i],
cex = 0.8,
col = ifelse(comparison$Opposite_Effects[i], "purple", "black"))
}
# Add interpretation note
mtext("Arrows show how each economic indicator affects both outcomes",
side = 3, line = 0.5, cex = 0.8)
}
# Print a summary of the comparative analysis
cat("\nComparative Analysis of Macroeconomic Effects:\n")
cat("-------------------------------------------\n")
for(i in 1:nrow(comparison)) {
var <- comparison$Variable[i]
label <- comparison$Label[i]
bank_hr <- comparison$Bank_HR[i]
acq_hr <- comparison$Acq_HR[i]
opposite <- comparison$Opposite_Effects[i]
# Format effects as percentages
if(bank_hr > 1) {
bank_effect <- paste0("+", round((bank_hr - 1) * 100, 1), "%")
} else {
bank_effect <- paste0("-", round((1 - bank_hr) * 100, 1), "%")
}
if(acq_hr > 1) {
acq_effect <- paste0("+", round((acq_hr - 1) * 100, 1), "%")
} else {
acq_effect <- paste0("-", round((1 - acq_hr) * 100, 1), "%")
}
cat(label, ":\n")
cat(" - Effect on bankruptcy risk:", bank_effect, "\n")
cat(" - Effect on acquisition risk:", acq_effect, "\n")
if(opposite) {
cat(" - This variable has OPPOSITE effects on bankruptcy vs. acquisition\n")
# Add economic interpretation for opposite effects
if(var == "gdp_growth") {
if(bank_hr < 1 && acq_hr > 1) {
cat(" - Interpretation: Economic growth REDUCES financial distress while INCREASING M&A activity\n")
cat(" - This aligns with theories of opportunity-driven vs. distress-driven corporate events\n")
} else {
cat(" - Interpretation: Unusual pattern - Economic growth has unconventional effect on outcomes\n")
}
} else if(var == "gdp_deflator") {
if(bank_hr > 1 && acq_hr < 1) {
cat(" - Interpretation: Inflation INCREASES financial distress but REDUCES acquisition likelihood\n")
cat(" - High inflation may create operational challenges while depressing M&A markets\n")
} else {
cat(" - Interpretation: Inflation has complex effects on corporate outcomes\n")
}
} else if(var == "unemployement") {
if(bank_hr > 1 && acq_hr < 1) {
cat(" - Interpretation: High unemployment INCREASES bankruptcy risk but REDUCES acquisitions\n")
cat(" - Poor economic conditions increase distress while reducing M&A activity\n")
} else {
cat(" - Interpretation: Unemployment has complex effects on corporate outcomes\n")
}
}
} else {
cat(" - This variable affects both outcomes in the SAME direction\n")
# Add economic interpretation for same-direction effects
if(bank_hr > 1 && acq_hr > 1) {
cat(" - Interpretation: This economic factor increases BOTH bankruptcy and acquisition risk\n")
cat(" - May indicate a general economic stress factor increasing all corporate events\n")
} else if(bank_hr < 1 && acq_hr < 1) {
cat(" - Interpretation: This economic factor decreases BOTH bankruptcy and acquisition risk\n")
cat(" - May indicate a stabilizing economic condition that reduces corporate events\n")
}
}
cat("\n")
}
# Return comparison for further analysis
return(comparison)
}
# Compare macroeconomic effects between models
macro_comparison <- compare_macro_effects()
Comparing macroeconomic effects between bankruptcy and acquisition models...
Comparative Analysis of Macroeconomic Effects:
-------------------------------------------
GDP Growth :
- Effect on bankruptcy risk: +10.4%
- Effect on acquisition risk: +3.8%
- This variable affects both outcomes in the SAME direction
- Interpretation: This economic factor increases BOTH bankruptcy and acquisition risk
- May indicate a general economic stress factor increasing all corporate events
Inflation (GDP Deflator) :
- Effect on bankruptcy risk: -16.1%
- Effect on acquisition risk: -3.7%
- This variable affects both outcomes in the SAME direction
- Interpretation: This economic factor decreases BOTH bankruptcy and acquisition risk
- May indicate a stabilizing economic condition that reduces corporate events
Unemployment Rate :
- Effect on bankruptcy risk: -7.2%
- Effect on acquisition risk: -12.5%
- This variable affects both outcomes in the SAME direction
- Interpretation: This economic factor decreases BOTH bankruptcy and acquisition risk
- May indicate a stabilizing economic condition that reduces corporate events
Here the survival curves are visualized by economic conditions. This will help us understand how the risk of bankruptcy and acquisition varies under different economic conditions.
#-------------------------------------------------------------
# 13.4: Survival Curve Visualization with Economic Conditions
#-------------------------------------------------------------
cat("\n13.4: SURVIVAL CURVES BY ECONOMIC CONDITION\n")
13.4: SURVIVAL CURVES BY ECONOMIC CONDITION
cat("--------------------------------------\n")
--------------------------------------
visualize_survival_by_economy <- function(model, model_name, event_type) {
cat("Creating survival curves by economic condition for", model_name, "model...\n")
# Check if we have economic indicators in the data
has_macro <- all(c("gdp_growth", "unemployement") %in% colnames(data))
if(!has_macro) {
cat("Economic indicators not available for condition-specific visualization.\n")
return(NULL)
}
# Get last observation for each company
final_obs <- data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Calculate median values to define conditions
median_gdp <- median(final_obs$gdp_growth, na.rm = TRUE)
median_unemp <- median(final_obs$unemployement, na.rm = TRUE)
# Create economic condition groups
final_obs$econ_condition <- "Mixed"
final_obs$econ_condition[final_obs$gdp_growth > median_gdp &
final_obs$unemployement < median_unemp] <- "Strong"
final_obs$econ_condition[final_obs$gdp_growth < median_gdp &
final_obs$unemployement > median_unemp] <- "Weak"
# Convert to factor with desired order
final_obs$econ_condition <- factor(final_obs$econ_condition,
levels = c("Strong", "Mixed", "Weak"))
# Calculate risk scores
risk_scores <- predict(model, newdata = final_obs, type = "risk")
# Add scores to data
final_obs$risk_score <- risk_scores
# Create survival object
surv_obj <- Surv(time = final_obs$tstop, event = final_obs[[event_type]])
# Fit Kaplan-Meier curves by economic condition
km_fit <- survfit(surv_obj ~ econ_condition, data = final_obs)
# Plot curves
plot(km_fit, col = c("green3", "orange", "red"), lwd = 2,
main = paste("Survival Curves by Economic Condition -", model_name),
xlab = "Time (Years)", ylab = "Survival Probability")
# Prepare legend text with counts
condition_counts <- table(final_obs$econ_condition)
condition_events <- sapply(levels(final_obs$econ_condition), function(cond) {
sum(final_obs[[event_type]][final_obs$econ_condition == cond])
})
legend_text <- paste0(levels(final_obs$econ_condition), " Economy (n=",
condition_counts, ", events=", condition_events, ")")
# Add legend
legend("bottomleft", legend = legend_text,
col = c("green3", "orange", "red"), lwd = 2, bty = "n")
# Log-rank test
log_rank <- survdiff(surv_obj ~ econ_condition, data = final_obs)
cat("\nLog-rank test comparing survival curves by economic condition:\n")
print(log_rank)
if(log_rank$chisq > qchisq(0.95, df = length(levels(final_obs$econ_condition)) - 1)) {
cat("The survival curves differ significantly by economic condition (p < 0.05).\n")
} else {
cat("No significant difference in survival curves by economic condition (p >= 0.05).\n")
}
# Calculate event rates by economic condition
cat("\nEvent rates by economic condition:\n")
for(cond in levels(final_obs$econ_condition)) {
n_companies <- sum(final_obs$econ_condition == cond)
n_events <- sum(final_obs[[event_type]][final_obs$econ_condition == cond])
event_rate <- n_events / n_companies * 100
cat(cond, "Economy:", n_events, "events out of", n_companies,
"companies (", round(event_rate, 1), "%)\n", sep=" ")
}
# Calculate average risk scores by economic condition
cat("\nAverage risk scores by economic condition:\n")
for(cond in levels(final_obs$econ_condition)) {
avg_risk <- mean(final_obs$risk_score[final_obs$econ_condition == cond])
cat(cond, "Economy:", round(avg_risk, 4), "\n")
}
# Alternative visualization: boxplot of risk scores by economic condition
boxplot(risk_score ~ econ_condition, data = final_obs,
main = paste(model_name, "Risk by Economic Condition"),
xlab = "Economic Condition", ylab = "Risk Score",
col = c("green3", "orange", "red"))
# Add event rates to boxplot
for(i in 1:length(levels(final_obs$econ_condition))) {
cond <- levels(final_obs$econ_condition)[i]
event_rate <- sum(final_obs[[event_type]][final_obs$econ_condition == cond]) /
sum(final_obs$econ_condition == cond) * 100
text(i, par("usr")[3] - 0.02 * diff(par("usr")[3:4]),
paste0(round(event_rate, 1), "% events"),
cex = 0.8, xpd = TRUE)
}
# Return the data with economic conditions and risk scores
return(list(
data = final_obs,
km_fit = km_fit,
log_rank = log_rank
))
}
# Create survival curves by economic condition
bankruptcy_econ <- visualize_survival_by_economy(final_bankruptcy_model, "Bankruptcy", "bankruptcy")
Creating survival curves by economic condition for Bankruptcy model...
Log-rank test comparing survival curves by economic condition:
Call:
survdiff(formula = surv_obj ~ econ_condition, data = final_obs)
N Observed Expected (O-E)^2/E (O-E)^2/V
econ_condition=Strong 335 27 7.65 49.0 51.5
econ_condition=Mixed 2921 64 111.11 20.0 57.0
econ_condition=Weak 1782 85 57.24 13.5 20.9
Chisq= 85.1 on 2 degrees of freedom, p= <2e-16
The survival curves differ significantly by economic condition (p < 0.05).
Event rates by economic condition:
Strong Economy: 27 events out of 335 companies ( 8.1 %)
Mixed Economy: 64 events out of 2921 companies ( 2.2 %)
Weak Economy: 85 events out of 1782 companies ( 4.8 %)
Average risk scores by economic condition:
Strong Economy: 16.4733
Mixed Economy: 8.1441
Weak Economy: 11.2469
acquisition_econ <- visualize_survival_by_economy(final_acquisition_model, "Acquisition", "acquisition")
Creating survival curves by economic condition for Acquisition model...
Log-rank test comparing survival curves by economic condition:
Call:
survdiff(formula = surv_obj ~ econ_condition, data = final_obs)
N Observed Expected (O-E)^2/E (O-E)^2/V
econ_condition=Strong 335 186 91.1 99 106
econ_condition=Mixed 2921 815 1363.5 221 646
econ_condition=Weak 1782 1153 699.5 294 466
Chisq= 658 on 2 degrees of freedom, p= <2e-16
The survival curves differ significantly by economic condition (p < 0.05).
Event rates by economic condition:
Strong Economy: 186 events out of 335 companies ( 55.5 %)
Mixed Economy: 815 events out of 2921 companies ( 27.9 %)
Weak Economy: 1153 events out of 1782 companies ( 64.7 %)
Average risk scores by economic condition:
Strong Economy: 1.4515
Mixed Economy: 2.0726
Weak Economy: 1.623
For more exploration we can analyze the sensitivity of the models to economic cycles. This will help us understand how the models perform under different economic conditions and whether they are robust to changes in the economic environment.
#-------------------------------------------------------------
# 13.5: Economic Cycle Sensitivity Analysis
#-------------------------------------------------------------
cat("\n13.5: ECONOMIC CYCLE SENSITIVITY ANALYSIS\n")
13.5: ECONOMIC CYCLE SENSITIVITY ANALYSIS
cat("--------------------------------------\n")
--------------------------------------
analyze_economic_sensitivity <- function() {
cat("Analyzing sensitivity to economic cycles...\n")
# Check if we have economic indicators in the data
has_macro <- all(c("gdp_growth", "unemployement") %in% colnames(data))
if(!has_macro) {
cat("Economic indicators not available for cycle sensitivity analysis.\n")
return(NULL)
}
# Get last observation for each company and year
last_by_year <- data %>%
group_by(cusip, calendar_year) %>%
slice_max(tstop) %>%
ungroup()
# Calculate annual event rates - using base R aggregation to avoid dplyr dependency
annual_stats <- aggregate(cbind(bankruptcy, acquisition, gdp_growth, unemployement, gdp_deflator) ~ calendar_year,
data = last_by_year,
FUN = function(x) c(sum = sum(x), mean = mean(x, na.rm = TRUE)))
# Reshape the output to the desired format
annual_stats <- data.frame(
calendar_year = annual_stats$calendar_year,
n_companies = as.numeric(table(last_by_year$calendar_year)),
n_bankruptcies = annual_stats$bankruptcy[, "sum"],
n_acquisitions = annual_stats$acquisition[, "sum"],
bankruptcy_rate = annual_stats$bankruptcy[, "mean"] * 100,
acquisition_rate = annual_stats$acquisition[, "mean"] * 100,
gdp_growth = annual_stats$gdp_growth[, "mean"],
unemployment = annual_stats$unemployement[, "mean"],
inflation = annual_stats$gdp_deflator[, "mean"]
)
# Sort by year
annual_stats <- annual_stats[order(annual_stats$calendar_year), ]
# 1. Create time series plot of event rates and economic indicators
# Set up multi-panel plot (2 rows, 1 column)
par(mfrow = c(2, 1), mar = c(3, 4, 2, 4))
# Plot event rates over time
plot(annual_stats$calendar_year, annual_stats$bankruptcy_rate,
type = "o", col = "red", lwd = 2, pch = 16,
xlab = "", ylab = "Event Rate (%)",
main = "Corporate Event Rates Over Time",
ylim = c(0, max(c(annual_stats$bankruptcy_rate, annual_stats$acquisition_rate)) * 1.2))
# Add acquisition rates
lines(annual_stats$calendar_year, annual_stats$acquisition_rate,
type = "o", col = "blue", lwd = 2, pch = 17)
# Add legend
legend("topright", legend = c("Bankruptcy Rate", "Acquisition Rate"),
col = c("red", "blue"), lwd = 2, pch = c(16, 17), bty = "n")
# Plot economic indicators
plot(annual_stats$calendar_year, annual_stats$gdp_growth,
type = "o", col = "green4", lwd = 2, pch = 15,
xlab = "Year", ylab = "GDP Growth (%)",
main = "Economic Indicators Over Time",
ylim = c(min(annual_stats$gdp_growth) * 1.2, max(annual_stats$gdp_growth) * 1.2))
# Add unemployment on secondary y-axis
par(new = TRUE)
plot(annual_stats$calendar_year, annual_stats$unemployment,
type = "o", col = "brown", lwd = 2, pch = 18,
xlab = "", ylab = "", axes = FALSE,
ylim = c(min(annual_stats$unemployment) * 0.9, max(annual_stats$unemployment) * 1.1))
# Add secondary y-axis
axis(4, col = "brown", col.axis = "brown")
mtext("Unemployment Rate (%)", side = 4, line = 2, col = "brown")
# Add legend
legend("bottomright", legend = c("GDP Growth", "Unemployment"),
col = c("green4", "brown"), lwd = 2, pch = c(15, 18), bty = "n")
# Reset plotting parameters
par(mfrow = c(1, 1), mar = c(5, 4, 4, 2) + 0.1)
# 2. Create scatter plots of event rates vs. economic indicators
# Set up multi-panel plot (1 row, 2 columns)
par(mfrow = c(1, 2))
# Scatter plot for GDP growth
plot(annual_stats$gdp_growth, annual_stats$bankruptcy_rate,
col = "red", pch = 16, cex = 1.2,
xlab = "GDP Growth (%)", ylab = "Event Rate (%)",
main = "Event Rates vs. GDP Growth",
ylim = c(0, max(c(annual_stats$bankruptcy_rate, annual_stats$acquisition_rate)) * 1.2),
xlim = c(min(annual_stats$gdp_growth) * 1.2, max(annual_stats$gdp_growth) * 1.2))
points(annual_stats$gdp_growth, annual_stats$acquisition_rate,
col = "blue", pch = 17, cex = 1.2)
# Add regression lines
abline(lm(bankruptcy_rate ~ gdp_growth, data = annual_stats), col = "red", lty = 2)
abline(lm(acquisition_rate ~ gdp_growth, data = annual_stats), col = "blue", lty = 2)
# Add correlation coefficients
bank_cor <- cor(annual_stats$gdp_growth, annual_stats$bankruptcy_rate, use = "complete.obs")
acq_cor <- cor(annual_stats$gdp_growth, annual_stats$acquisition_rate, use = "complete.obs")
text(min(annual_stats$gdp_growth) * 1.1, max(annual_stats$bankruptcy_rate) * 1.1,
paste0("Bank r = ", round(bank_cor, 2)), col = "red", cex = 0.8)
text(min(annual_stats$gdp_growth) * 1.1, max(annual_stats$bankruptcy_rate) * 1.0,
paste0("Acq r = ", round(acq_cor, 2)), col = "blue", cex = 0.8)
# Add legend
legend("topleft", legend = c("Bankruptcy Rate", "Acquisition Rate"),
col = c("red", "blue"), pch = c(16, 17), lty = 2, bty = "n")
# Scatter plot for unemployment
plot(annual_stats$unemployment, annual_stats$bankruptcy_rate,
col = "red", pch = 16, cex = 1.2,
xlab = "Unemployment Rate (%)", ylab = "Event Rate (%)",
main = "Event Rates vs. Unemployment",
ylim = c(0, max(c(annual_stats$bankruptcy_rate, annual_stats$acquisition_rate)) * 1.2),
xlim = c(min(annual_stats$unemployment) * 0.9, max(annual_stats$unemployment) * 1.1))
points(annual_stats$unemployment, annual_stats$acquisition_rate,
col = "blue", pch = 17, cex = 1.2)
# Add regression lines
abline(lm(bankruptcy_rate ~ unemployment, data = annual_stats), col = "red", lty = 2)
abline(lm(acquisition_rate ~ unemployment, data = annual_stats), col = "blue", lty = 2)
# Add correlation coefficients
bank_cor <- cor(annual_stats$unemployment, annual_stats$bankruptcy_rate, use = "complete.obs")
acq_cor <- cor(annual_stats$unemployment, annual_stats$acquisition_rate, use = "complete.obs")
text(max(annual_stats$unemployment) * 0.95, max(annual_stats$bankruptcy_rate) * 1.1,
paste0("Bank r = ", round(bank_cor, 2)), col = "red", cex = 0.8)
text(max(annual_stats$unemployment) * 0.95, max(annual_stats$bankruptcy_rate) * 1.0,
paste0("Acq r = ", round(acq_cor, 2)), col = "blue", cex = 0.8)
# Reset plotting parameters
par(mfrow = c(1, 1))
# Compute correlation matrix between event rates and economic indicators
corr_vars <- c("bankruptcy_rate", "acquisition_rate", "gdp_growth", "unemployment", "inflation")
corr_matrix <- cor(annual_stats[, corr_vars], use = "complete.obs")
# Print correlation matrix
cat("\nCorrelation Matrix of Event Rates and Economic Indicators:\n")
print(round(corr_matrix, 3))
# Classification of economic periods
annual_stats$econ_period <- "Normal"
annual_stats$econ_period[annual_stats$gdp_growth > quantile(annual_stats$gdp_growth, 0.67, na.rm = TRUE) &
annual_stats$unemployment < quantile(annual_stats$unemployment, 0.33, na.rm = TRUE)] <- "Expansion"
annual_stats$econ_period[annual_stats$gdp_growth < quantile(annual_stats$gdp_growth, 0.33, na.rm = TRUE) &
annual_stats$unemployment > quantile(annual_stats$unemployment, 0.67, na.rm = TRUE)] <- "Recession"
# Calculate average event rates by economic period using base R
period_stats <- aggregate(
cbind(bankruptcy_rate, acquisition_rate) ~ econ_period,
data = annual_stats,
FUN = mean
)
# Add count of years per period
period_counts <- table(annual_stats$econ_period)
period_stats$n_years <- period_counts[match(period_stats$econ_period, names(period_counts))]
# Rename columns to match with the previous structure for compatibility with the barplot
names(period_stats)[names(period_stats) == "bankruptcy_rate"] <- "avg_bankruptcy_rate"
names(period_stats)[names(period_stats) == "acquisition_rate"] <- "avg_acquisition_rate"
cat("\nAverage Event Rates by Economic Period:\n")
print(period_stats)
# Create bar plot of event rates by economic period - with error handling
tryCatch({
# Create matrix properly from the period_stats dataframe
barplot_data <- as.matrix(period_stats[, c("avg_bankruptcy_rate", "avg_acquisition_rate"), drop=FALSE])
rownames(barplot_data) <- period_stats$econ_period
barplot(t(barplot_data), beside = TRUE,
main = "Event Rates by Economic Period",
xlab = "Economic Period", ylab = "Average Event Rate (%)",
col = c("red", "blue"),
ylim = c(0, max(barplot_data, na.rm = TRUE) * 1.2))
# Add legend
legend("topright", legend = c("Bankruptcy Rate", "Acquisition Rate"),
fill = c("red", "blue"), bty = "n")
}, error = function(e) {
cat("Warning: Could not create barplot of event rates by economic period:", e$message, "\n")
cat("Printing data frame instead:\n")
print(period_stats)
})
# Return the annual statistics for further analysis
return(list(
annual_stats = annual_stats,
period_stats = period_stats,
correlations = corr_matrix
))
}
# Analyze economic cycle sensitivity
economic_cycles <- analyze_economic_sensitivity()
Analyzing sensitivity to economic cycles...
Correlation Matrix of Event Rates and Economic Indicators:
bankruptcy_rate acquisition_rate gdp_growth unemployment inflation
bankruptcy_rate 1.000 0.584 -0.084 -0.256 -0.227
acquisition_rate 0.584 1.000 -0.171 -0.068 -0.198
gdp_growth -0.084 -0.171 1.000 -0.423 0.276
unemployment -0.256 -0.068 -0.423 1.000 -0.398
inflation -0.227 -0.198 0.276 -0.398 1.000
Average Event Rates by Economic Period:
Not sure if this has any value…
We also look at sector-specific macroeconomic sensitivity. This will help us understand how different sectors respond to macroeconomic changes and whether there are significant differences in their sensitivities.
#-------------------------------------------------------------
# 13.10: Sector-Specific Macroeconomic Sensitivity
#-------------------------------------------------------------
cat("\n13.10: SECTOR-SPECIFIC MACROECONOMIC SENSITIVITY\n")
13.10: SECTOR-SPECIFIC MACROECONOMIC SENSITIVITY
cat("--------------------------------------\n")
--------------------------------------
analyze_sector_macro_sensitivity <- function() {
cat("Analyzing sector-specific sensitivity to macroeconomic factors...\n")
# Check if we have macro variables in our dataset
if(!all(c("gdp_growth", "unemployement", "gdp_deflator") %in% colnames(data))) {
cat("Macro variables not found in dataset. Cannot perform sector analysis.\n")
return(NULL)
}
# Get last observation for each company
final_obs <- data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Ensure gsector is a factor
final_obs$gsector <- as.factor(final_obs$gsector)
# Get sectors with sufficient data
sector_counts <- table(final_obs$gsector)
valid_sectors <- names(sector_counts)[sector_counts >= 30]
if(length(valid_sectors) == 0) {
cat("Not enough sectors with sufficient observations for analysis.\n")
return(NULL)
}
# Filter to valid sectors
sector_data <- final_obs[final_obs$gsector %in% valid_sectors, ]
# Initialize matrices to store correlations
sectors <- unique(sector_data$gsector)
macro_vars <- c("gdp_growth", "unemployement", "gdp_deflator")
# Create storage for correlation matrices
sector_correlations <- array(NA, dim = c(length(sectors), 2, length(macro_vars)),
dimnames = list(sectors, c("bankruptcy", "acquisition"), macro_vars))
# Calculate correlations for each sector and outcome
for(s in sectors) {
sector_subset <- sector_data[sector_data$gsector == s, ]
# Only proceed if we have sufficient data
if(nrow(sector_subset) >= 10) {
for(m in macro_vars) {
if(all(c(m, "bankruptcy", "acquisition") %in% colnames(sector_subset))) {
# Calculate correlations
cor_bank <- cor(sector_subset[[m]], sector_subset$bankruptcy, use = "complete.obs")
cor_acq <- cor(sector_subset[[m]], sector_subset$acquisition, use = "complete.obs")
# Store in the array
sector_correlations[s, "bankruptcy", m] <- cor_bank
sector_correlations[s, "acquisition", m] <- cor_acq
}
}
}
}
# Convert to more manageable data frame for visualization
correlation_df <- data.frame()
for(s in sectors) {
for(m in macro_vars) {
for(outcome in c("bankruptcy", "acquisition")) {
correlation_df <- rbind(correlation_df, data.frame(
Sector = s,
MacroVar = m,
Outcome = outcome,
Correlation = sector_correlations[s, outcome, m],
stringsAsFactors = FALSE
))
}
}
}
# Create a readable macro variable name mapping
correlation_df$MacroVarLabel <- ifelse(correlation_df$MacroVar == "gdp_growth", "GDP Growth",
ifelse(correlation_df$MacroVar == "unemployement", "Unemployment",
"Inflation"))
# Calculate sector sensitivity scores (average absolute correlation)
sector_sensitivity <- aggregate(abs(Correlation) ~ Sector, data = correlation_df, FUN = mean, na.rm = TRUE)
colnames(sector_sensitivity)[2] <- "AvgSensitivity"
# Sort by sensitivity
sector_sensitivity <- sector_sensitivity[order(sector_sensitivity$AvgSensitivity, decreasing = TRUE), ]
# Create barplot of sector sensitivity
barplot(sector_sensitivity$AvgSensitivity,
names.arg = paste("Sector", sector_sensitivity$Sector),
main = "Sector Sensitivity to Macroeconomic Factors",
xlab = "Industry Sector", ylab = "Average Absolute Correlation",
col = colorRampPalette(c("lightblue", "darkblue"))(nrow(sector_sensitivity)),
las = 2)
# Create heatmap for bankruptcy correlations
bank_cor <- correlation_df[correlation_df$Outcome == "bankruptcy", ]
bank_matrix <- reshape(bank_cor, idvar = "Sector", timevar = "MacroVarLabel",
direction = "wide", drop = c("Outcome", "MacroVar"))
rownames(bank_matrix) <- paste("Sector", bank_matrix$Sector)
bank_matrix <- bank_matrix[, -1]
colnames(bank_matrix) <- sub("Correlation.", "", colnames(bank_matrix))
# Sort sectors by average sensitivity
bank_matrix <- bank_matrix[match(paste("Sector", sector_sensitivity$Sector), rownames(bank_matrix)), ]
# Plot heatmap for bankruptcy
par(mar = c(5, 12, 4, 2) + 0.1) # Adjust margins for sector names
image(z = t(as.matrix(bank_matrix)),
col = colorRampPalette(c("blue", "white", "red"))(100),
main = "Sector Sensitivity to Macro Factors - Bankruptcy",
xlab = "", ylab = "")
# Add sector and macro variable labels
axis(2, at = seq(0, 1, length.out = nrow(bank_matrix)),
labels = rownames(bank_matrix), las = 2, cex.axis = 0.8)
axis(1, at = seq(0, 1, length.out = 3),
labels = colnames(bank_matrix), las = 1)
# Add color legend
legend_colors <- colorRampPalette(c("blue", "white", "red"))(5)
legend_values <- c(-0.5, -0.25, 0, 0.25, 0.5)
legend("bottom", legend = legend_values, fill = legend_colors,
horiz = TRUE, cex = 0.7, title = "Correlation", bty = "n")
# Print summary of sector sensitivities
cat("\nSector Sensitivity to Macroeconomic Factors (Ranked):\n")
cat("----------------------------------------------------\n")
print(sector_sensitivity)
# Identify most and least sensitive sectors
most_sensitive <- sector_sensitivity$Sector[1]
least_sensitive <- sector_sensitivity$Sector[nrow(sector_sensitivity)]
cat("\nMost economically sensitive sector:", most_sensitive,
"(average correlation magnitude =", round(sector_sensitivity$AvgSensitivity[1], 3), ")\n")
cat("Least economically sensitive sector:", least_sensitive,
"(average correlation magnitude =", round(sector_sensitivity$AvgSensitivity[nrow(sector_sensitivity)], 3), ")\n")
return(sector_sensitivity)
}
# Run the sector-specific macro sensitivity analysis
sector_macro_sensitivity <- analyze_sector_macro_sensitivity()
Analyzing sector-specific sensitivity to macroeconomic factors...
Warning: the standard deviation is zeroWarning: the standard deviation is zeroWarning: the standard deviation is zeroWarning: the standard deviation is zeroWarning: the standard deviation is zeroWarning: the standard deviation is zero
Sector Sensitivity to Macroeconomic Factors (Ranked):
----------------------------------------------------
Most economically sensitive sector: 60 (average correlation magnitude = 0.412 )
Least economically sensitive sector: 15 (average correlation magnitude = 0.127 )
This analysis provides insights into how different sectors respond to macroeconomic changes, which can be useful for investors and policymakers.
Next is the business cycle impact analysis. This will help us understand how corporate events are influenced by the economic cycle and whether there are significant differences in event rates during different economic conditions.
#-------------------------------------------------------------
# 13.11: Business Cycle Impact Analysis
#-------------------------------------------------------------
cat("\n13.11: BUSINESS CYCLE IMPACT ANALYSIS\n")
13.11: BUSINESS CYCLE IMPACT ANALYSIS
cat("--------------------------------------\n")
--------------------------------------
analyze_business_cycle_impact <- function() {
cat("Analyzing impact of business cycles on corporate outcomes...\n")
# Check for necessary macro variables
if(!all(c("gdp_growth", "unemployement") %in% colnames(data))) {
cat("Required macroeconomic variables not found. Cannot perform business cycle analysis.\n")
return(NULL)
}
# Get last observation for each company by year
year_obs <- data %>%
group_by(cusip, calendar_year) %>%
slice_max(tstop) %>%
ungroup()
# Define business cycle phases based on economic indicators
# Calculate median values for thresholds
median_gdp <- median(year_obs$gdp_growth, na.rm = TRUE)
median_unemp <- median(year_obs$unemployement, na.rm = TRUE)
# Define economic cycle phases
year_obs$econ_condition <- "Normal"
year_obs$econ_condition[year_obs$gdp_growth > median_gdp &
year_obs$unemployement < median_unemp] <- "Expansion"
year_obs$econ_condition[year_obs$gdp_growth < median_gdp &
year_obs$unemployement > median_unemp] <- "Contraction"
# Calculate event rates by economic condition
condition_stats <- aggregate(cbind(bankruptcy, acquisition) ~ econ_condition,
data = year_obs, FUN = mean)
condition_stats$bankruptcy <- condition_stats$bankruptcy * 100 # Convert to percentage
condition_stats$acquisition <- condition_stats$acquisition * 100
# Count number of observations per condition
condition_counts <- table(year_obs$econ_condition)
condition_stats$count <- as.vector(condition_counts[match(condition_stats$econ_condition,
names(condition_counts))])
# Create barplot data
barplot_data <- as.matrix(condition_stats[, c("bankruptcy", "acquisition")])
rownames(barplot_data) <- condition_stats$econ_condition
# Create barplot
barplot(t(barplot_data),
beside = TRUE,
col = c("firebrick", "steelblue"),
main = "Corporate Event Rates by Economic Condition",
xlab = "Economic Condition",
ylab = "Event Rate (%)",
legend.text = c("Bankruptcy", "Acquisition"),
args.legend = list(x = "topright", bty = "n"),
ylim = c(0, max(barplot_data) * 1.2))
# Add count labels
mtext(paste0("n=", condition_stats$count),
side = 1, line = 3,
at = seq(1.5, by = 3, length.out = nrow(condition_stats)))
# Print summary statistics
cat("\nEvent Rates by Economic Condition:\n")
cat("----------------------------------\n")
print(condition_stats[, c("econ_condition", "count", "bankruptcy", "acquisition")])
# Calculate statistical tests for rate differences
cat("\nStatistical tests for differences in event rates by economic condition:\n")
# For bankruptcy
binom_test_bank <- prop.test(
x = c(sum(year_obs$bankruptcy[year_obs$econ_condition == "Expansion"]),
sum(year_obs$bankruptcy[year_obs$econ_condition == "Contraction"])),
n = c(sum(year_obs$econ_condition == "Expansion"),
sum(year_obs$econ_condition == "Contraction"))
)
# For acquisition
binom_test_acq <- prop.test(
x = c(sum(year_obs$acquisition[year_obs$econ_condition == "Expansion"]),
sum(year_obs$acquisition[year_obs$econ_condition == "Contraction"])),
n = c(sum(year_obs$econ_condition == "Expansion"),
sum(year_obs$econ_condition == "Contraction"))
)
cat("Bankruptcy rates (Expansion vs Contraction): p-value =",
format.pval(binom_test_bank$p.value, digits = 3), "\n")
cat("Acquisition rates (Expansion vs Contraction): p-value =",
format.pval(binom_test_acq$p.value, digits = 3), "\n")
# Create survival curves by economic condition
# Create survival object
surv_bank <- Surv(time = year_obs$tstop, event = year_obs$bankruptcy)
surv_acq <- Surv(time = year_obs$tstop, event = year_obs$acquisition)
# Fit KM curves by economic condition
km_bank <- survfit(surv_bank ~ econ_condition, data = year_obs)
km_acq <- survfit(surv_acq ~ econ_condition, data = year_obs)
# Plot KM curves for bankruptcy
plot(km_bank, col = c("green3", "blue", "red"), lwd = 2,
main = "Bankruptcy-Free Survival by Economic Condition",
xlab = "Time (Years)", ylab = "Survival Probability")
# Add legend
legend("bottomleft", legend = levels(as.factor(year_obs$econ_condition)),
col = c("green3", "blue", "red"), lwd = 2, bty = "n")
# Log-rank test for bankruptcy
log_rank_bank <- survdiff(surv_bank ~ econ_condition, data = year_obs)
cat("\nLog-rank test for bankruptcy by economic condition:\n")
print(log_rank_bank)
# Plot KM curves for acquisition
plot(km_acq, col = c("green3", "blue", "red"), lwd = 2,
main = "Acquisition-Free Survival by Economic Condition",
xlab = "Time (Years)", ylab = "Survival Probability")
# Add legend
legend("bottomleft", legend = levels(as.factor(year_obs$econ_condition)),
col = c("green3", "blue", "red"), lwd = 2, bty = "n")
# Log-rank test for acquisition
log_rank_acq <- survdiff(surv_acq ~ econ_condition, data = year_obs)
cat("\nLog-rank test for acquisition by economic condition:\n")
print(log_rank_acq)
# Summary of findings
cat("\nSummary of Business Cycle Impact Analysis:\n")
cat("----------------------------------------\n")
# Bankruptcy analysis
cat("Bankruptcy:\n")
bank_exp <- condition_stats$bankruptcy[condition_stats$econ_condition == "Expansion"]
bank_cont <- condition_stats$bankruptcy[condition_stats$econ_condition == "Contraction"]
bank_ratio <- bank_cont / bank_exp
if(bank_cont > bank_exp) {
cat("- Bankruptcy risk is", round(bank_ratio, 1), "times higher during economic contractions\n")
} else {
cat("- Bankruptcy risk is", round(1/bank_ratio, 1), "times higher during economic expansions\n")
}
if(binom_test_bank$p.value < 0.05) {
cat("- The difference is statistically significant (p < 0.05)\n")
} else {
cat("- The difference is not statistically significant (p >= 0.05)\n")
}
# Acquisition analysis
cat("\nAcquisition:\n")
acq_exp <- condition_stats$acquisition[condition_stats$econ_condition == "Expansion"]
acq_cont <- condition_stats$acquisition[condition_stats$econ_condition == "Contraction"]
acq_ratio <- acq_exp / acq_cont
if(acq_exp > acq_cont) {
cat("- Acquisition likelihood is", round(acq_ratio, 1), "times higher during economic expansions\n")
} else {
cat("- Acquisition likelihood is", round(1/acq_ratio, 1), "times higher during economic contractions\n")
}
if(binom_test_acq$p.value < 0.05) {
cat("- The difference is statistically significant (p < 0.05)\n")
} else {
cat("- The difference is not statistically significant (p >= 0.05)\n")
}
# Return analysis results
return(list(
condition_stats = condition_stats,
bankruptcy_test = binom_test_bank,
acquisition_test = binom_test_acq,
km_bank = km_bank,
km_acq = km_acq
))
}
# Run the business cycle impact analysis
business_cycle_analysis <- analyze_business_cycle_impact()
Analyzing impact of business cycles on corporate outcomes...
Event Rates by Economic Condition:
----------------------------------
Statistical tests for differences in event rates by economic condition:
Bankruptcy rates (Expansion vs Contraction): p-value = 0.0861
Acquisition rates (Expansion vs Contraction): p-value = 0.0657
Log-rank test for bankruptcy by economic condition:
Call:
survdiff(formula = surv_bank ~ econ_condition, data = year_obs)
N Observed Expected (O-E)^2/E (O-E)^2/V
econ_condition=Contraction 20150 48 59.8 2.318 3.577
econ_condition=Expansion 17129 58 41.4 6.699 8.908
econ_condition=Normal 26312 70 74.9 0.317 0.553
Chisq= 9.5 on 2 degrees of freedom, p= 0.008
Log-rank test for acquisition by economic condition:
Call:
survdiff(formula = surv_acq ~ econ_condition, data = year_obs)
N Observed Expected (O-E)^2/E (O-E)^2/V
econ_condition=Contraction 20150 657 736 8.55 13.3
econ_condition=Expansion 17129 619 500 28.34 37.7
econ_condition=Normal 26312 878 918 1.72 3.0
Chisq= 39.5 on 2 degrees of freedom, p= 3e-09
Summary of Business Cycle Impact Analysis:
----------------------------------------
Bankruptcy:
- Bankruptcy risk is 1.4 times higher during economic expansions
- The difference is not statistically significant (p >= 0.05)
Acquisition:
- Acquisition likelihood is 1.1 times higher during economic expansions
- The difference is not statistically significant (p >= 0.05)
We also stratify surival curces by sector. This will help us understand how different sectors respond to corporate events and whether there are significant differences in survival rates across sectors.
#-------------------------------------------------------------
# 13.12: Enhanced Sector-Specific Survival Analysis
#-------------------------------------------------------------
cat("\n13.12: ENHANCED SECTOR-SPECIFIC SURVIVAL ANALYSIS\n")
13.12: ENHANCED SECTOR-SPECIFIC SURVIVAL ANALYSIS
cat("--------------------------------------\n")
--------------------------------------
# Function to create enhanced KM curves stratified by sector with additional analysis
create_enhanced_sector_km_curves <- function() {#-------------------------------------------------------------
# 13.12: Enhanced Sector-Specific Survival Analysis (FIXED)
#-------------------------------------------------------------
cat("\n13.12: ENHANCED SECTOR-SPECIFIC SURVIVAL ANALYSIS\n")
cat("--------------------------------------\n")
# Function to create enhanced KM curves stratified by sector with additional analysis
create_enhanced_sector_km_curves <- function() {
cat("Creating enhanced Kaplan-Meier curves by industry sector for both event types...\n")
# Get the last observation for each company
final_obs <- data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Ensure gsector is a factor
final_obs$gsector <- as.factor(final_obs$gsector)
# Count events by sector
sector_bankruptcy <- tapply(final_obs$bankruptcy, final_obs$gsector, sum)
sector_acquisition <- tapply(final_obs$acquisition, final_obs$gsector, sum)
# Count companies per sector
sector_counts <- table(final_obs$gsector)
# Create data frame of sector statistics
sector_stats <- data.frame(
Sector = names(sector_counts),
Companies = as.numeric(sector_counts),
Bankruptcy_Events = as.numeric(sector_bankruptcy),
Bankruptcy_Rate = as.numeric(sector_bankruptcy) / as.numeric(sector_counts) * 100,
Acquisition_Events = as.numeric(sector_acquisition),
Acquisition_Rate = as.numeric(sector_acquisition) / as.numeric(sector_counts) * 100,
stringsAsFactors = FALSE
)
# Sort by number of companies
sector_stats <- sector_stats[order(sector_stats$Companies, decreasing = TRUE), ]
# Select sectors for KM plots (top sectors by company count with sufficient events)
valid_bankruptcy_sectors <- sector_stats$Sector[
sector_stats$Companies >= 30 & sector_stats$Bankruptcy_Events >= 5
]
valid_acquisition_sectors <- sector_stats$Sector[
sector_stats$Companies >= 30 & sector_stats$Acquisition_Events >= 5
]
# Take top 5 sectors for each event type
if(length(valid_bankruptcy_sectors) > 5) {
bankruptcy_sectors <- valid_bankruptcy_sectors[1:5]
} else {
bankruptcy_sectors <- valid_bankruptcy_sectors
}
if(length(valid_acquisition_sectors) > 5) {
acquisition_sectors <- valid_acquisition_sectors[1:5]
} else {
acquisition_sectors <- valid_acquisition_sectors
}
# Create function for fitting and plotting KM curves by sector for an event type
plot_sector_km <- function(event_type, sectors, title) {
# Filter data to these sectors
sector_data <- final_obs[final_obs$gsector %in% sectors, ]
# Create survival object
surv_obj <- Surv(time = sector_data$tstop, event = sector_data[[event_type]])
# Fit KM curves by sector
km_fit <- survfit(surv_obj ~ gsector, data = sector_data)
# Create colors for the sectors
sector_colors <- rainbow(length(sectors))
# Set up plot area
par(mar = c(5, 4, 4, 8) + 0.1) # Extra space for legend
# Plot KM curves
plot(km_fit, col = sector_colors, lwd = 2,
main = title,
xlab = "Time (Years)", ylab = "Survival Probability",
lty = 1:length(sectors))
# Create sector labels with event counts and rates
sector_labels <- sapply(sectors, function(s) {
count <- sum(sector_data$gsector == s)
events <- sum(sector_data[[event_type]][sector_data$gsector == s])
rate <- events / count * 100
paste0("Sector ", s, " (", events, "/", count, ", ", round(rate, 1), "%)")
})
# Add legend with more detailed information
legend("topright", inset = c(-0.35, 0), legend = sector_labels,
col = sector_colors, lwd = 2, lty = 1:length(sectors),
bty = "n", xpd = TRUE, cex = 0.8)
# Log-rank test
log_rank <- survdiff(surv_obj ~ gsector, data = sector_data)
# Add p-value to plot
p_value <- 1 - pchisq(log_rank$chisq, df = length(sectors) - 1)
significance <- ifelse(p_value < 0.05, "Significant", "Not significant")
mtext(paste0("Log-rank p = ", format.pval(p_value, digits = 3), " (", significance, ")"),
side = 3, line = 0.5, cex = 0.8)
# Calculate and return median survival times
medians <- summary(km_fit)$table[, "median"]
names(medians) <- sectors
return(list(
km_fit = km_fit,
log_rank = log_rank,
medians = medians,
sectors = sectors
))
}
# Plot KM curves for bankruptcy
if(length(bankruptcy_sectors) >= 2) {
cat("\nPlotting KM curves for bankruptcy by sector...\n")
bankruptcy_km <- plot_sector_km("bankruptcy", bankruptcy_sectors,
"Bankruptcy-Free Survival by Industry Sector")
# Print log-rank test results
cat("\nLog-rank test for bankruptcy by sector:\n")
print(bankruptcy_km$log_rank)
# Print median survival times
cat("\nMedian time to bankruptcy by sector:\n")
print(bankruptcy_km$medians)
# Calculate hazard ratios between sectors using Cox model
cat("\nHazard ratios between sectors for bankruptcy:\n")
# Use the first sector as reference
ref_sector <- bankruptcy_sectors[1]
bankruptcy_sectors_formula <- as.formula(paste0("Surv(tstop, bankruptcy) ~ gsector"))
bankruptcy_sectors_model <- coxph(bankruptcy_sectors_formula,
data = final_obs[final_obs$gsector %in% bankruptcy_sectors, ])
print(summary(bankruptcy_sectors_model)$conf.int)
} else {
cat("\nNot enough sectors with sufficient bankruptcy events for KM curves.\n")
}
# Plot KM curves for acquisition
if(length(acquisition_sectors) >= 2) {
cat("\nPlotting KM curves for acquisition by sector...\n")
acquisition_km <- plot_sector_km("acquisition", acquisition_sectors,
"Acquisition-Free Survival by Industry Sector")
# Print log-rank test results
cat("\nLog-rank test for acquisition by sector:\n")
print(acquisition_km$log_rank)
# Print median survival times
cat("\nMedian time to acquisition by sector:\n")
print(acquisition_km$medians)
# Calculate hazard ratios between sectors using Cox model
cat("\nHazard ratios between sectors for acquisition:\n")
# Use the first sector as reference
ref_sector <- acquisition_sectors[1]
acquisition_sectors_formula <- as.formula(paste0("Surv(tstop, acquisition) ~ gsector"))
acquisition_sectors_model <- coxph(acquisition_sectors_formula,
data = final_obs[final_obs$gsector %in% acquisition_sectors, ])
print(summary(acquisition_sectors_model)$conf.int)
} else {
cat("\nNot enough sectors with sufficient acquisition events for KM curves.\n")
}
# Create a comparative analysis of sector risk profiles
if(length(intersect(bankruptcy_sectors, acquisition_sectors)) > 0) {
cat("\nComparative Analysis of Sector Risk Profiles:\n")
cat("------------------------------------------\n")
common_sectors <- intersect(bankruptcy_sectors, acquisition_sectors)
for(sector in common_sectors) {
# Find the row index for this sector in sector_stats
sector_idx <- which(sector_stats$Sector == sector)
# Access the rates using the index
if(length(sector_idx) > 0) {
bank_rate <- sector_stats$Bankruptcy_Rate[sector_idx]
acq_rate <- sector_stats$Acquisition_Rate[sector_idx]
cat("Sector", sector, ":\n")
cat(" Bankruptcy Rate:", round(bank_rate, 1), "%\n")
cat(" Acquisition Rate:", round(acq_rate, 1), "%\n")
cat(" Ratio (Acquisition/Bankruptcy):", round(acq_rate/bank_rate, 1), "\n\n")
}
}
}
# Reset plotting parameters
par(mar = c(5, 4, 4, 2) + 0.1)
# Return sector statistics for further analysis
return(sector_stats)
}
# Create enhanced KM curves by sector
sector_survival_analysis <- create_enhanced_sector_km_curves()}
# Create enhanced KM curves by sector
sector_survival_analysis <- create_enhanced_sector_km_curves()
13.12: ENHANCED SECTOR-SPECIFIC SURVIVAL ANALYSIS
--------------------------------------
Creating enhanced Kaplan-Meier curves by industry sector for both event types...
Plotting KM curves for bankruptcy by sector...
Log-rank test for bankruptcy by sector:
Call:
survdiff(formula = surv_obj ~ gsector, data = sector_data)
N Observed Expected (O-E)^2/E (O-E)^2/V
gsector=20 726 24 26.04 0.160 0.19554
gsector=25 916 58 31.33 22.702 28.91212
gsector=35 1037 22 35.86 5.357 7.09959
gsector=45 1391 35 45.61 2.468 3.58749
gsector=50 266 8 8.16 0.003 0.00319
Chisq= 30.8 on 4 degrees of freedom, p= 3e-06
Median time to bankruptcy by sector:
45 35 25 20 50
NA NA NA NA NA
Hazard ratios between sectors for bankruptcy:
exp(coef) exp(-coef) lower .95 upper .95
gsector15 NA NA NA NA
gsector20 0.9396264 1.0642527 0.4220346 2.092003
gsector25 1.8897915 0.5291589 0.9022807 3.958094
gsector30 NA NA NA NA
gsector35 0.6254985 1.5987249 0.2784621 1.405033
gsector45 0.7825090 1.2779406 0.3629861 1.686898
gsector50 NA NA NA NA
gsector55 NA NA NA NA
gsector60 NA NA NA NA
Plotting KM curves for acquisition by sector...
Log-rank test for acquisition by sector:
Call:
survdiff(formula = surv_obj ~ gsector, data = sector_data)
N Observed Expected (O-E)^2/E (O-E)^2/V
gsector=20 726 266 330 12.567 15.687
gsector=25 916 349 398 6.145 8.012
gsector=35 1037 446 457 0.271 0.368
gsector=45 1391 724 579 36.441 54.178
gsector=50 266 83 103 3.944 4.281
Chisq= 60.9 on 4 degrees of freedom, p= 2e-12
Median time to acquisition by sector:
45 35 25 20 50
24.99658 20.99932 18.99795 15.99726 24.99932
Hazard ratios between sectors for acquisition:
exp(coef) exp(-coef) lower .95 upper .95
gsector15 NA NA NA NA
gsector20 1.001371 0.9986308 0.7826237 1.281260
gsector25 1.091240 0.9163883 0.8589343 1.386376
gsector30 NA NA NA NA
gsector35 1.216512 0.8220226 0.9623909 1.537733
gsector45 1.565884 0.6386171 1.2476895 1.965226
gsector50 NA NA NA NA
gsector55 NA NA NA NA
gsector60 NA NA NA NA
Comparative Analysis of Sector Risk Profiles:
------------------------------------------
Sector 45 :
Bankruptcy Rate: 2.5 %
Acquisition Rate: 52 %
Ratio (Acquisition/Bankruptcy): 20.7
Sector 35 :
Bankruptcy Rate: 2.1 %
Acquisition Rate: 43 %
Ratio (Acquisition/Bankruptcy): 20.3
Sector 25 :
Bankruptcy Rate: 6.3 %
Acquisition Rate: 38.1 %
Ratio (Acquisition/Bankruptcy): 6
Sector 20 :
Bankruptcy Rate: 3.3 %
Acquisition Rate: 36.6 %
Ratio (Acquisition/Bankruptcy): 11.1
Sector 50 :
Bankruptcy Rate: 3 %
Acquisition Rate: 31.2 %
Ratio (Acquisition/Bankruptcy): 10.4
We see how the model performs by industry sector. This will help us understand how the model’s performance varies across different sectors and whether there are significant differences in event rates by sector.
#-------------------------------------------------------------
# 13.14: Model Performance by Industry Sector
#-------------------------------------------------------------
cat("\n13.14: MODEL PERFORMANCE BY INDUSTRY SECTOR\n")
13.14: MODEL PERFORMANCE BY INDUSTRY SECTOR
cat("--------------------------------------\n")
--------------------------------------
evaluate_model_by_sector <- function(model, model_name, event_type) {
cat("Evaluating", model_name, "model performance by industry sector...\n")
# Get last observation for each company
final_obs <- data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Ensure gsector is a factor
final_obs$gsector <- as.factor(final_obs$gsector)
# Calculate risk scores
risk_scores <- predict(model, newdata = final_obs, type = "risk")
final_obs$risk_score <- risk_scores
# Get unique sectors with sufficient data
sectors <- names(table(final_obs$gsector)[table(final_obs$gsector) >= 20])
# Create data frame for results
sector_perf <- data.frame(
Sector = sectors,
Companies = NA,
Events = NA,
Event_Rate = NA,
AUC = NA,
C_Index = NA,
stringsAsFactors = FALSE
)
# Calculate metrics for each sector
for(i in 1:length(sectors)) {
s <- sectors[i]
sector_data <- final_obs[final_obs$gsector == s, ]
# Count companies and events
n_companies <- nrow(sector_data)
n_events <- sum(sector_data[[event_type]])
event_rate <- n_events / n_companies * 100
sector_perf$Companies[i] <- n_companies
sector_perf$Events[i] <- n_events
sector_perf$Event_Rate[i] <- event_rate
# Calculate AUC if possible (at least 5 events and 5 non-events)
if(n_events >= 5 && (n_companies - n_events) >= 5) {
if(requireNamespace("pROC", quietly = TRUE)) {
tryCatch({
# Calculate AUC
roc_obj <- pROC::roc(sector_data[[event_type]], sector_data$risk_score, quiet = TRUE)
sector_perf$AUC[i] <- as.numeric(pROC::auc(roc_obj))
# Calculate confidence interval for reporting
ci <- pROC::ci(roc_obj)
cat(sprintf("Sector %s: AUC = %.3f (95%% CI: %.3f-%.3f) with %d events (%.1f%%)\n",
s, sector_perf$AUC[i], ci[1], ci[3], n_events, event_rate))
}, error = function(e) {
cat("Error calculating AUC for sector", s, ":", e$message, "\n")
})
}
# Calculate Harrell's C-index (concordance) using survival package
tryCatch({
# Create a simple Cox model for this sector only
sector_formula <- as.formula(paste0("Surv(tstop, ", event_type, ") ~ risk_score"))
sector_model <- coxph(sector_formula, data = sector_data)
sector_perf$C_Index[i] <- sector_model$concordance["concordance"]
}, error = function(e) {
cat("Error calculating C-index for sector", s, ":", e$message, "\n")
})
} else {
cat("Insufficient events in sector", s, "for AUC calculation (", n_events, "events)\n")
}
}
# Sort by number of companies
sector_perf <- sector_perf[order(sector_perf$Companies, decreasing = TRUE), ]
# Print summary statistics
cat("\nPerformance of", model_name, "model by industry sector:\n")
print(sector_perf)
# Create visualization of performance by sector
# Filter sectors with valid AUC
plot_data <- sector_perf[!is.na(sector_perf$AUC), ]
if(nrow(plot_data) > 0) {
# Sort by AUC for visualization
plot_data <- plot_data[order(plot_data$AUC, decreasing = TRUE), ]
# Create sector labels
sector_labels <- paste0("Sector ", plot_data$Sector,
" (n=", plot_data$Companies, ", ",
plot_data$Events, " events)")
# Set up plotting area with extra space for labels
par(mar = c(5, 12, 4, 4) + 0.1)
# Create horizontal bar plot of AUC values
barplot_result <- barplot(plot_data$AUC,
names.arg = sector_labels,
main = paste(model_name, "Model Performance by Industry Sector"),
xlab = "AUC",
horiz = TRUE,
xlim = c(0.5, 1),
col = colorRampPalette(c("skyblue", "royalblue", "navyblue"))(nrow(plot_data)),
las = 1,
cex.names = 0.7)
# Add event rate as text
for(i in 1:length(barplot_result)) {
text(plot_data$AUC[i] + 0.03, barplot_result[i],
sprintf("%.3f (%.1f%% events)",
plot_data$AUC[i], plot_data$Event_Rate[i]),
cex = 0.7)
}
# Add reference lines
abline(v = c(0.5, 0.7, 0.8, 0.9), lty = c(1, 2, 2, 2),
col = c("red", "orange", "green3", "darkgreen"))
# Add legend for reference lines
legend("bottomright",
legend = c("AUC = 0.5 (Random)", "AUC = 0.7 (Acceptable)",
"AUC = 0.8 (Excellent)", "AUC = 0.9 (Outstanding)"),
lty = c(1, 2, 2, 2),
col = c("red", "orange", "green3", "darkgreen"),
cex = 0.7, bty = "n")
# Reset plotting parameters
par(mar = c(5, 4, 4, 2) + 0.1)
# Create bubble plot of AUC vs event rate, with bubble size representing number of companies
plot(plot_data$Event_Rate, plot_data$AUC,
main = paste("AUC vs Event Rate by Sector -", model_name, "Model"),
xlab = "Event Rate (%)", ylab = "AUC",
xlim = c(0, max(plot_data$Event_Rate) * 1.1),
ylim = c(min(0.5, min(plot_data$AUC, na.rm=TRUE)), 1),
type = "n")
# Add reference line at AUC = 0.5 (random prediction)
abline(h = 0.5, lty = 2, col = "red")
abline(h = c(0.7, 0.8, 0.9), lty = 3, col = "darkgray")
# Add grid for readability
grid()
# Add sector bubbles
symbols(plot_data$Event_Rate, plot_data$AUC,
circles = sqrt(plot_data$Companies) / 5, # Scale bubble size
inches = FALSE,
bg = adjustcolor("royalblue", alpha.f = 0.7),
fg = "black",
add = TRUE)
# Add sector labels
text(plot_data$Event_Rate, plot_data$AUC,
labels = plot_data$Sector,
pos = 3, cex = 0.7)
# Add interpretation labels
text(x = max(plot_data$Event_Rate) * 0.9, y = 0.55,
"Poor Performance", col = "red", cex = 0.8)
text(x = max(plot_data$Event_Rate) * 0.9, y = 0.75,
"Good Performance", col = "darkgreen", cex = 0.8)
text(x = max(plot_data$Event_Rate) * 0.9, y = 0.95,
"Excellent Performance", col = "darkgreen", cex = 0.8, font = 2)
# Add bubble size legend
legend_sizes <- c(min(plot_data$Companies),
median(plot_data$Companies),
max(plot_data$Companies))
legend("bottomright",
legend = paste0(round(legend_sizes), " companies"),
pt.cex = sqrt(legend_sizes) / 5 * 2, # Adjust for better visibility
pch = 21,
col = "black",
pt.bg = adjustcolor("royalblue", alpha.f = 0.7),
cex = 0.7, bty = "n",
title = "Bubble Size Legend")
} else {
cat("No sectors with valid AUC values for plotting.\n")
}
# Identify best and worst performing sectors
valid_sectors <- sector_perf[!is.na(sector_perf$AUC) & sector_perf$Events >= 5, ]
if(nrow(valid_sectors) > 0) {
best_sector <- valid_sectors[which.max(valid_sectors$AUC), ]
worst_sector <- valid_sectors[which.min(valid_sectors$AUC), ]
cat("\nSector with best model performance:", best_sector$Sector,
"(AUC =", round(best_sector$AUC, 3), "with", best_sector$Events,
"events, event rate =", round(best_sector$Event_Rate, 1), "%)\n")
cat("Sector with worst model performance:", worst_sector$Sector,
"(AUC =", round(worst_sector$AUC, 3), "with", worst_sector$Events,
"events, event rate =", round(worst_sector$Event_Rate, 1), "%)\n\n")
# Provide potential explanation for performance differences
cat("Potential explanations for performance differences:\n")
# Check if event rate correlates with performance
cor_rate_auc <- cor(valid_sectors$Event_Rate, valid_sectors$AUC, use = "complete.obs")
if(abs(cor_rate_auc) > 0.5) {
if(cor_rate_auc > 0) {
cat("- Sectors with higher event rates tend to have better model performance\n")
cat(" This suggests the model works best in high-risk industries\n")
} else {
cat("- Sectors with lower event rates tend to have better model performance\n")
cat(" This suggests the model works best in more stable industries\n")
}
} else {
cat("- No strong relationship between event rates and model performance across sectors\n")
cat(" Sector-specific factors beyond frequency of events affect predictability\n")
}
# Compare best and worst sectors
cat("\nComparison of best vs. worst performing sectors:\n")
cat("- Best (Sector", best_sector$Sector, "): AUC =", round(best_sector$AUC, 3),
"with event rate of", round(best_sector$Event_Rate, 1), "%\n")
cat("- Worst (Sector", worst_sector$Sector, "): AUC =", round(worst_sector$AUC, 3),
"with event rate of", round(worst_sector$Event_Rate, 1), "%\n")
# Compare number of companies
if(best_sector$Companies > worst_sector$Companies * 2) {
cat("- The best performing sector has significantly more companies,\n")
cat(" suggesting more data improves prediction accuracy\n")
} else if(worst_sector$Companies > best_sector$Companies * 2) {
cat("- The worst performing sector has more companies but poorer performance,\n")
cat(" suggesting structural differences in predictability rather than data volume issues\n")
}
}
# Return sector performance data
return(sector_perf)
}
# Evaluate model performance by sector for both models
bankruptcy_sector_perf <- evaluate_model_by_sector(final_bankruptcy_model, "Bankruptcy", "bankruptcy")
Evaluating Bankruptcy model performance by industry sector...
Sector 10: AUC = 0.846 (95% CI: 0.770-0.922) with 16 events (6.6%)
Sector 15: AUC = 0.860 (95% CI: 0.762-0.958) with 6 events (3.3%)
Sector 20: AUC = 0.846 (95% CI: 0.776-0.915) with 24 events (3.3%)
Sector 25: AUC = 0.812 (95% CI: 0.765-0.859) with 58 events (6.3%)
Sector 30: AUC = 0.792 (95% CI: 0.583-1.000) with 7 events (3.3%)
Sector 35: AUC = 0.715 (95% CI: 0.609-0.821) with 22 events (2.1%)
Sector 45: AUC = 0.823 (95% CI: 0.756-0.891) with 35 events (2.5%)
Sector 50: AUC = 0.886 (95% CI: 0.811-0.961) with 8 events (3.0%)
Insufficient events in sector 55 for AUC calculation ( 0 events)
Insufficient events in sector 60 for AUC calculation ( 0 events)
Performance of Bankruptcy model by industry sector:
Sector with best model performance: 50 (AUC = 0.886 with 8 events, event rate = 3 %)
Sector with worst model performance: 35 (AUC = 0.715 with 22 events, event rate = 2.1 %)
Potential explanations for performance differences:
- No strong relationship between event rates and model performance across sectors
Sector-specific factors beyond frequency of events affect predictability
Comparison of best vs. worst performing sectors:
- Best (Sector 50 ): AUC = 0.886 with event rate of 3 %
- Worst (Sector 35 ): AUC = 0.715 with event rate of 2.1 %
- The worst performing sector has more companies but poorer performance,
suggesting structural differences in predictability rather than data volume issues
acquisition_sector_perf <- evaluate_model_by_sector(final_acquisition_model, "Acquisition", "acquisition")
Evaluating Acquisition model performance by industry sector...
Sector 10: AUC = 0.555 (95% CI: 0.482-0.627) with 123 events (50.4%)
Sector 15: AUC = 0.541 (95% CI: 0.456-0.626) with 67 events (36.8%)
Sector 20: AUC = 0.505 (95% CI: 0.463-0.547) with 266 events (36.6%)
Sector 25: AUC = 0.553 (95% CI: 0.516-0.590) with 349 events (38.1%)
Sector 30: AUC = 0.529 (95% CI: 0.452-0.605) with 80 events (37.4%)
Sector 35: AUC = 0.538 (95% CI: 0.503-0.573) with 446 events (43.0%)
Sector 45: AUC = 0.528 (95% CI: 0.497-0.559) with 724 events (52.0%)
Sector 50: AUC = 0.546 (95% CI: 0.476-0.615) with 83 events (31.2%)
Sector 55: AUC = 0.765 (95% CI: 0.599-0.931) with 13 events (40.6%)
Insufficient events in sector 60 for AUC calculation ( 3 events)
Performance of Acquisition model by industry sector:
Sector with best model performance: 55 (AUC = 0.765 with 13 events, event rate = 40.6 %)
Sector with worst model performance: 20 (AUC = 0.505 with 266 events, event rate = 36.6 %)
Potential explanations for performance differences:
- No strong relationship between event rates and model performance across sectors
Sector-specific factors beyond frequency of events affect predictability
Comparison of best vs. worst performing sectors:
- Best (Sector 55 ): AUC = 0.765 with event rate of 40.6 %
- Worst (Sector 20 ): AUC = 0.505 with event rate of 36.6 %
- The worst performing sector has more companies but poorer performance,
suggesting structural differences in predictability rather than data volume issues
# Compare sector performance between models
if(!is.null(bankruptcy_sector_perf) && !is.null(acquisition_sector_perf)) {
cat("\nCOMPARING MODEL PERFORMANCE ACROSS SECTORS:\n")
cat("----------------------------------------\n")
# Find common sectors with valid performance metrics
common_sectors <- intersect(
bankruptcy_sector_perf$Sector[!is.na(bankruptcy_sector_perf$AUC)],
acquisition_sector_perf$Sector[!is.na(acquisition_sector_perf$AUC)]
)
if(length(common_sectors) > 0) {
comparison <- data.frame(
Sector = common_sectors,
Bankruptcy_AUC = NA,
Acquisition_AUC = NA,
Difference = NA,
stringsAsFactors = FALSE
)
# Fill in values
for(i in 1:length(common_sectors)) {
s <- common_sectors[i]
comparison$Bankruptcy_AUC[i] <- bankruptcy_sector_perf$AUC[bankruptcy_sector_perf$Sector == s]
comparison$Acquisition_AUC[i] <- acquisition_sector_perf$AUC[acquisition_sector_perf$Sector == s]
comparison$Difference[i] <- comparison$Bankruptcy_AUC[i] - comparison$Acquisition_AUC[i]
}
# Sort by absolute difference
comparison <- comparison[order(abs(comparison$Difference), decreasing = TRUE), ]
# Print comparison
cat("Performance comparison across", length(common_sectors), "sectors with valid metrics:\n\n")
print(comparison)
# Identify sectors with largest differences
if(nrow(comparison) > 0) {
max_diff_sector <- comparison[which.max(abs(comparison$Difference)), ]
cat("\nSector with largest performance difference:", max_diff_sector$Sector, "\n")
cat("- Bankruptcy model AUC:", round(max_diff_sector$Bankruptcy_AUC, 3), "\n")
cat("- Acquisition model AUC:", round(max_diff_sector$Acquisition_AUC, 3), "\n")
cat("- Absolute difference:", round(abs(max_diff_sector$Difference), 3), "\n")
if(max_diff_sector$Bankruptcy_AUC > max_diff_sector$Acquisition_AUC) {
cat("- Bankruptcy is more predictable than acquisition in this sector\n")
} else {
cat("- Acquisition is more predictable than bankruptcy in this sector\n")
}
# Create scatter plot comparing performance across sectors
plot(comparison$Bankruptcy_AUC, comparison$Acquisition_AUC,
main = "Model Performance Comparison by Sector",
xlab = "Bankruptcy Model AUC", ylab = "Acquisition Model AUC",
xlim = c(0.5, 1), ylim = c(0.5, 1),
pch = 16, col = "blue")
# Add sector labels
text(comparison$Bankruptcy_AUC, comparison$Acquisition_AUC,
labels = comparison$Sector, pos = 3, cex = 0.7)
# Add diagonal line for equal performance
abline(0, 1, lty = 2, col = "gray")
# Add quadrant labels
text(0.55, 0.95, "Acquisition better\npredicted", col = "darkred", cex = 0.8)
text(0.95, 0.55, "Bankruptcy better\npredicted", col = "darkblue", cex = 0.8)
text(0.95, 0.95, "Both well\npredicted", col = "darkgreen", cex = 0.8)
text(0.55, 0.55, "Both poorly\npredicted", col = "purple", cex = 0.8)
# Add reference lines
abline(h = 0.7, v = 0.7, lty = 3, col = "darkgray")
# Calculate average performance difference
avg_diff <- mean(comparison$Bankruptcy_AUC - comparison$Acquisition_AUC)
if(abs(avg_diff) > 0.03) {
if(avg_diff > 0) {
cat("\nOn average, bankruptcy is more predictable across sectors (by",
round(avg_diff, 3), "AUC points)\n")
} else {
cat("\nOn average, acquisition is more predictable across sectors (by",
round(-avg_diff, 3), "AUC points)\n")
}
} else {
cat("\nOn average, both outcomes have similar predictability across sectors\n")
}
# Calculate correlation between sector performance on both models
perf_cor <- cor(comparison$Bankruptcy_AUC, comparison$Acquisition_AUC)
cat("Correlation between bankruptcy and acquisition prediction performance:",
round(perf_cor, 3), "\n")
if(perf_cor > 0.7) {
cat("The strong positive correlation suggests sectors that are predictable for one\n")
cat("outcome tend to be predictable for the other as well. This indicates similar\n")
cat("underlying drivers of predictability across sectors.\n")
} else if(perf_cor > 0.3) {
cat("The moderate correlation suggests some common factors affecting predictability\n")
cat("across outcomes, but also important differences in what makes sectors predictable\n")
cat("for bankruptcy versus acquisition.\n")
} else {
cat("The weak correlation suggests different factors drive predictability for\n")
cat("bankruptcy versus acquisition across sectors. Sectors predictable for one\n")
cat("outcome aren't necessarily predictable for the other.\n")
}
}
} else {
cat("No common sectors with valid performance metrics for both models.\n")
}
}
COMPARING MODEL PERFORMANCE ACROSS SECTORS:
----------------------------------------
Performance comparison across 8 sectors with valid metrics:
Sector with largest performance difference: 20
- Bankruptcy model AUC: 0.846
- Acquisition model AUC: 0.505
- Absolute difference: 0.341
- Bankruptcy is more predictable than acquisition in this sector
On average, bankruptcy is more predictable across sectors (by 0.286 AUC points)
Correlation between bankruptcy and acquisition prediction performance: 0.055
The weak correlation suggests different factors drive predictability for
bankruptcy versus acquisition across sectors. Sectors predictable for one
outcome aren't necessarily predictable for the other.
Again, not sure if really necessary ^^^^^^^^^^^^^^^
Next we do an enhanced risk stratification analysis. This will help us understand how the model’s predictions vary across different risk levels and whether there are significant differences in event rates by risk level.
#-------------------------------------------------------------
# 13.15: ENHANCED RISK STRATIFICATION ANALYSIS (FIXED)
#-------------------------------------------------------------
cat("\n13.15: ENHANCED RISK STRATIFICATION ANALYSIS\n")
13.15: ENHANCED RISK STRATIFICATION ANALYSIS
cat("--------------------------------------\n")
--------------------------------------
# Function to create comprehensive risk stratification with macroeconomic context
create_risk_stratification <- function(model, model_name, event_type_name) {
cat("Creating enhanced risk stratification for", model_name, "model...\n")
# Get last observation for each company
final_obs <- data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Calculate risk scores
risk_scores <- predict(model, newdata = final_obs, type = "risk")
# Add scores to data
final_obs$risk_score <- risk_scores
# Create risk quintiles for more granular analysis
risk_quantiles <- quantile(risk_scores, probs = seq(0, 1, 0.2))
final_obs$risk_quintile <- cut(risk_scores,
breaks = risk_quantiles,
include.lowest = TRUE,
labels = c("Q1 (Lowest)", "Q2", "Q3", "Q4", "Q5 (Highest)"))
# Get the event column directly (don't use [[ ]] with a variable)
if(event_type_name == "bankruptcy") {
event_col <- final_obs$bankruptcy
} else if(event_type_name == "acquisition") {
event_col <- final_obs$acquisition
} else {
stop("Unknown event type: ", event_type_name)
}
# Calculate descriptive statistics by quintile
quintile_stats <- aggregate(event_col ~ risk_quintile, data = final_obs,
FUN = function(x) c(mean = mean(x), sum = sum(x), n = length(x)))
# Format the data for easier use
quintile_summary <- data.frame(
Quintile = quintile_stats$risk_quintile,
Events = quintile_stats$event_col[, "sum"],
Companies = quintile_stats$event_col[, "n"],
Event_Rate = quintile_stats$event_col[, "mean"] * 100,
stringsAsFactors = FALSE
)
# Calculate additional metrics
quintile_summary$Cumulative_Events <- cumsum(quintile_summary$Events)
quintile_summary$Cumulative_Percent <- quintile_summary$Cumulative_Events / sum(quintile_summary$Events) * 100
quintile_summary$Capture_Rate <- quintile_summary$Events / quintile_summary$Companies * 100
# Calculate relative risk versus lowest quintile
base_rate <- quintile_summary$Event_Rate[1]
quintile_summary$Relative_Risk <- quintile_summary$Event_Rate / base_rate
# Print summary table
cat("\nRisk Stratification Summary for", model_name, "Model:\n")
print(quintile_summary)
# Calculate discrimination ratio (highest quintile rate / lowest quintile rate)
discrimination_ratio <- quintile_summary$Event_Rate[5] / quintile_summary$Event_Rate[1]
# Create bar plot of event rates
barplot_result <- barplot(quintile_summary$Event_Rate,
names.arg = quintile_summary$Quintile,
main = paste("Event Rates by Risk Quintile -", model_name, "Model"),
xlab = "Risk Quintile", ylab = "Event Rate (%)",
col = colorRampPalette(c("green", "yellow", "orange", "red", "darkred"))(5),
ylim = c(0, max(quintile_summary$Event_Rate) * 1.3))
# Add text labels with event counts
text(barplot_result,
quintile_summary$Event_Rate + max(quintile_summary$Event_Rate) * 0.05,
paste0(round(quintile_summary$Event_Rate, 1), "%\n(",
quintile_summary$Events, "/", quintile_summary$Companies, ")"),
cex = 0.8)
# Add discrimination ratio
mtext(paste("Discrimination Ratio (Q5/Q1):", round(discrimination_ratio, 1), "×"),
side = 3, line = 0.5, cex = 0.8)
# Create Lorenz curve for event concentration
# Calculate cumulative percentage of companies and events
cum_pct_companies <- cumsum(quintile_summary$Companies) / sum(quintile_summary$Companies) * 100
cum_pct_events <- cumsum(quintile_summary$Events) / sum(quintile_summary$Events) * 100
# Points for Lorenz curve
lorenz_x <- c(0, cum_pct_companies)
lorenz_y <- c(0, cum_pct_events)
# Create Lorenz curve plot
plot(lorenz_x, lorenz_y, type = "b", pch = 16, col = "blue",
main = paste("Event Concentration Curve -", model_name, "Model"),
xlab = "Cumulative % of Companies (sorted by risk score)",
ylab = "Cumulative % of Events",
xlim = c(0, 100), ylim = c(0, 100))
# Add reference line for random prediction
abline(0, 1, lty = 2, col = "darkgray")
# Add grid for readability
grid()
# Add quintile labels
text(cum_pct_companies[2:6], cum_pct_events[2:6],
labels = c("Q1", "Q2", "Q3", "Q4", "Q5"),
pos = 4, cex = 0.8)
# Calculate Gini coefficient (area between Lorenz curve and diagonal, normalized)
# Approximate using trapezoid rule
gini <- 0
for(i in 1:5) {
gini <- gini + (lorenz_x[i+1] - lorenz_x[i]) * (lorenz_y[i+1] + lorenz_y[i])
}
gini <- 1 - gini/10000
# Add Gini coefficient to plot
mtext(paste("Gini Coefficient:", round(gini, 3)), side = 3, line = 0.5, cex = 0.8)
# Add practical interpretation
cat("\nPerformance Interpretation:\n")
cat("- Discrimination Ratio (Q5/Q1):", round(discrimination_ratio, 1), "×\n")
if(discrimination_ratio >= 10) {
cat(" Excellent discrimination (>10×)\n")
} else if(discrimination_ratio >= 5) {
cat(" Good discrimination (5-10×)\n")
} else if(discrimination_ratio >= 3) {
cat(" Moderate discrimination (3-5×)\n")
} else {
cat(" Limited discrimination (<3×)\n")
}
cat("- Gini Coefficient:", round(gini, 3), "\n")
if(gini >= 0.7) {
cat(" Excellent concentration of events (≥0.7)\n")
} else if(gini >= 0.5) {
cat(" Good concentration of events (0.5-0.7)\n")
} else if(gini >= 0.3) {
cat(" Moderate concentration of events (0.3-0.5)\n")
} else {
cat(" Limited concentration of events (<0.3)\n")
}
# Top quintile capture rate
top_quintile_capture <- quintile_summary$Events[5] / sum(quintile_summary$Events) * 100
cat("- Top quintile capture rate:", round(top_quintile_capture, 1),
"% of all events captured in highest risk quintile\n")
# Analyze macroeconomic influence on risk stratification
cat("\nMacroeconomic Context of Risk Stratification:\n")
# Check if macro variables are present
macro_vars <- c("gdp_growth", "unemployement", "gdp_deflator")
available_macro <- intersect(macro_vars, colnames(final_obs))
if(length(available_macro) > 0) {
# Calculate average macro values by quintile
macro_by_quintile <- aggregate(final_obs[, available_macro],
by = list(Quintile = final_obs$risk_quintile),
FUN = mean, na.rm = TRUE)
cat("\nAverage Macroeconomic Conditions by Risk Quintile:\n")
print(macro_by_quintile)
# Create parallel plots to visualize relationship
# Set up plotting area
par(mar = c(5, 5, 4, 5) + 0.1)
# Calculate mean and SD for standardizing
means <- colMeans(final_obs[, available_macro], na.rm = TRUE)
sds <- apply(final_obs[, available_macro], 2, sd, na.rm = TRUE)
# Standardize values for plotting
std_values <- matrix(NA, nrow = 5, ncol = length(available_macro))
for(i in 1:length(available_macro)) {
std_values[, i] <- (macro_by_quintile[, i+1] - means[i]) / sds[i]
}
# Set plot limits
y_lim <- c(min(-2, min(std_values, na.rm = TRUE)),
max(2, max(std_values, na.rm = TRUE)))
# Create plot
plot(1:5, std_values[, 1], type = "l", lwd = 2, col = "blue",
main = "Macroeconomic Profile by Risk Quintile",
xlab = "Risk Quintile (Low to High)",
ylab = "Standardized Value (Z-score)",
xlim = c(1, 5), ylim = y_lim,
xaxt = "n")
# Add axis
axis(1, at = 1:5, labels = c("Q1\n(Lowest)", "Q2", "Q3", "Q4", "Q5\n(Highest)"))
# Add lines for other macro variables
if(length(available_macro) > 1) {
for(i in 2:length(available_macro)) {
lines(1:5, std_values[, i], lwd = 2,
col = rainbow(length(available_macro))[i])
}
}
# Add reference line at 0
abline(h = 0, lty = 2, col = "darkgray")
# Add legend
macro_labels <- c("GDP Growth", "Unemployment", "Inflation")
legend_labels <- macro_labels[match(available_macro, macro_vars)]
legend("topright", legend = legend_labels,
col = rainbow(length(available_macro)),
lwd = 2, bty = "n")
# Reset plotting parameters
par(mar = c(5, 4, 4, 2) + 0.1)
# Calculate correlations between risk scores and macro variables
cor_risk_macro <- cor(final_obs$risk_score, final_obs[, available_macro],
use = "pairwise.complete.obs")
cat("\nCorrelation between risk scores and macroeconomic variables:\n")
for(i in 1:length(available_macro)) {
var <- available_macro[i]
var_label <- ifelse(var == "gdp_growth", "GDP Growth",
ifelse(var == "unemployement", "Unemployment", "Inflation"))
cor_val <- cor_risk_macro[1, i]
cat("- ", var_label, ": r = ", round(cor_val, 3), " (",
ifelse(cor_val > 0, "positive", "negative"), " relationship)\n", sep="")
# Add interpretation
if(abs(cor_val) > 0.1) {
if(var == "gdp_growth") {
if(cor_val > 0) {
cat(" Higher economic growth associated with higher", model_name, "risk\n")
} else {
cat(" Lower economic growth associated with higher", model_name, "risk\n")
}
} else if(var == "unemployement") {
if(cor_val > 0) {
cat(" Higher unemployment associated with higher", model_name, "risk\n")
} else {
cat(" Lower unemployment associated with higher", model_name, "risk\n")
}
} else if(var == "gdp_deflator") {
if(cor_val > 0) {
cat(" Higher inflation associated with higher", model_name, "risk\n")
} else {
cat(" Lower inflation associated with higher", model_name, "risk\n")
}
}
} else {
cat(" Minimal relationship with", model_name, "risk\n")
}
}
# Check for patterns in event rates across macro conditions
# Create macro condition categories based on GDP growth and unemployment
if(all(c("gdp_growth", "unemployement") %in% available_macro)) {
# Define economic conditions
median_gdp <- median(final_obs$gdp_growth, na.rm = TRUE)
median_unemp <- median(final_obs$unemployement, na.rm = TRUE)
final_obs$econ_condition <- "Normal"
final_obs$econ_condition[final_obs$gdp_growth > median_gdp &
final_obs$unemployement < median_unemp] <- "Strong"
final_obs$econ_condition[final_obs$gdp_growth < median_gdp &
final_obs$unemployement > median_unemp] <- "Weak"
# Calculate event rates by quintile and economic condition
# Use the appropriate event column based on event_type_name
if(event_type_name == "bankruptcy") {
econ_quintile_rates <- aggregate(bankruptcy ~ risk_quintile + econ_condition,
data = final_obs, FUN = mean)
} else {
econ_quintile_rates <- aggregate(acquisition ~ risk_quintile + econ_condition,
data = final_obs, FUN = mean)
}
# Reshape to wide format
econ_quintile_wide <- reshape(econ_quintile_rates,
idvar = "risk_quintile",
timevar = "econ_condition",
direction = "wide")
# Fix column names
colnames(econ_quintile_wide) <- gsub(paste0(event_type_name, "."), "",
colnames(econ_quintile_wide))
# Multiply by 100 to get percentages
for(col in 2:ncol(econ_quintile_wide)) {
econ_quintile_wide[, col] <- econ_quintile_wide[, col] * 100
}
cat("\nEvent Rates by Risk Quintile and Economic Condition:\n")
print(econ_quintile_wide)
# Create interaction plot
# Use reshape2 package for melt function if available
if(requireNamespace("reshape2", quietly = TRUE)) {
# Create data in long format for plotting
plot_data <- reshape2::melt(econ_quintile_wide, id.vars = "risk_quintile")
names(plot_data) <- c("Quintile", "Condition", "Rate")
} else {
# Fallback if reshape2 is not available
# Create a manual equivalent of melt for this specific case
plot_data <- data.frame(
Quintile = rep(econ_quintile_wide$risk_quintile, each = ncol(econ_quintile_wide) - 1),
Condition = rep(colnames(econ_quintile_wide)[-1], times = nrow(econ_quintile_wide)),
Rate = as.vector(unlist(econ_quintile_wide[, -1])),
stringsAsFactors = FALSE
)
}
# Create interaction plot
interaction.plot(x.factor = plot_data$Quintile,
trace.factor = plot_data$Condition,
response = plot_data$Rate,
fun = mean,
type = "b",
col = c("green3", "blue", "red"),
lty = 1,
pch = c(15, 16, 17),
lwd = 2,
legend = TRUE,
xlab = "Risk Quintile",
ylab = paste(model_name, "Event Rate (%)"),
main = "Risk Quintile Performance by Economic Condition")
# Calculate discrimination ratios by economic condition
conditions <- unique(plot_data$Condition)
discrim_by_condition <- numeric(length(conditions))
names(discrim_by_condition) <- conditions
for(cond in conditions) {
quintile_rates <- tapply(plot_data$Rate[plot_data$Condition == cond],
plot_data$Quintile[plot_data$Condition == cond], mean)
if(length(quintile_rates) == 5 && !is.na(quintile_rates[1]) &&
!is.na(quintile_rates[5]) && quintile_rates[1] > 0) {
discrim_by_condition[cond] <- quintile_rates[5] / quintile_rates[1]
}
}
# Add to plot as annotation
ratio_text <- paste(names(discrim_by_condition), ": ",
round(discrim_by_condition, 1), "×",
collapse = " | ")
mtext(paste("Discrimination Ratios -", ratio_text),
side = 3, line = 0.5, cex = 0.7)
# Discuss implications
cat("\nMacroeconomic Impact on Risk Stratification:\n")
# Find condition with highest discrimination ratio
best_condition <- names(which.max(discrim_by_condition))
max_discrim <- max(discrim_by_condition, na.rm = TRUE)
cat("- Best model discrimination in", best_condition, "economic conditions (ratio =",
round(max_discrim, 1), "×)\n")
# Check pattern across conditions
strong_idx <- which(names(discrim_by_condition) == "Strong")
weak_idx <- which(names(discrim_by_condition) == "Weak")
if(length(strong_idx) == 0 || length(weak_idx) == 0 ||
is.na(discrim_by_condition[strong_idx]) || is.na(discrim_by_condition[weak_idx])) {
cat("- Insufficient data to compare across all economic conditions\n")
} else if(discrim_by_condition[weak_idx] > discrim_by_condition[strong_idx]) {
cat("- Model discrimination improves in weak economic conditions\n")
cat(" This suggests economic downturns make", model_name, "events more predictable\n")
} else if(discrim_by_condition[strong_idx] > discrim_by_condition[weak_idx]) {
cat("- Model discrimination improves in strong economic conditions\n")
cat(" This suggests economic expansions make", model_name, "events more predictable\n")
} else {
cat("- Similar discrimination across economic conditions\n")
cat(" This suggests economic cycles have limited impact on predictability\n")
}
}
} else {
cat("Macroeconomic variables not available in the dataset.\n")
}
# Return risk stratification results
return(list(
quintile_summary = quintile_summary,
discrimination_ratio = discrimination_ratio,
gini = gini,
top_quintile_capture = top_quintile_capture
))
}
# Create risk stratification analyses for both models
bankruptcy_risk_strat <- create_risk_stratification(final_bankruptcy_model, "Bankruptcy", "bankruptcy")
Creating enhanced risk stratification for Bankruptcy model...
Risk Stratification Summary for Bankruptcy Model:
Performance Interpretation:
- Discrimination Ratio (Q5/Q1): 59 ×
Excellent discrimination (>10×)
- Gini Coefficient: 0.593
Good concentration of events (0.5-0.7)
- Top quintile capture rate: 67 % of all events captured in highest risk quintile
Macroeconomic Context of Risk Stratification:
Average Macroeconomic Conditions by Risk Quintile:
Correlation between risk scores and macroeconomic variables:
- GDP Growth: r = -0.018 (negative relationship)
Minimal relationship with Bankruptcy risk
- Unemployment: r = 0.001 (positive relationship)
Minimal relationship with Bankruptcy risk
- Inflation: r = -0.074 (negative relationship)
Minimal relationship with Bankruptcy risk
Event Rates by Risk Quintile and Economic Condition:
Macroeconomic Impact on Risk Stratification:
- Best model discrimination in Normal economic conditions (ratio = 64.9 ×)
- Model discrimination improves in weak economic conditions
This suggests economic downturns make Bankruptcy events more predictable
acquisition_risk_strat <- create_risk_stratification(final_acquisition_model, "Acquisition", "acquisition")
Creating enhanced risk stratification for Acquisition model...
Risk Stratification Summary for Acquisition Model:
Performance Interpretation:
- Discrimination Ratio (Q5/Q1): 1.1 ×
Limited discrimination (<3×)
- Gini Coefficient: 0.027
Limited concentration of events (<0.3)
- Top quintile capture rate: 16.6 % of all events captured in highest risk quintile
Macroeconomic Context of Risk Stratification:
Average Macroeconomic Conditions by Risk Quintile:
Correlation between risk scores and macroeconomic variables:
- GDP Growth: r = -0.002 (negative relationship)
Minimal relationship with Acquisition risk
- Unemployment: r = -0.092 (negative relationship)
Minimal relationship with Acquisition risk
- Inflation: r = 0.143 (positive relationship)
Higher inflation associated with higher Acquisition risk
Event Rates by Risk Quintile and Economic Condition:
Macroeconomic Impact on Risk Stratification:
- Best model discrimination in Strong economic conditions (ratio = 2.7 ×)
- Model discrimination improves in strong economic conditions
This suggests economic expansions make Acquisition events more predictable
# Compare risk stratification between models
if(!is.null(bankruptcy_risk_strat) && !is.null(acquisition_risk_strat)) {
cat("\nCOMPARING RISK STRATIFICATION BETWEEN MODELS:\n")
cat("-------------------------------------------\n")
# Create comparison table
comparison <- data.frame(
Metric = c("Discrimination Ratio (Q5/Q1)",
"Gini Coefficient",
"Top Quintile Capture Rate"),
Bankruptcy = c(bankruptcy_risk_strat$discrimination_ratio,
bankruptcy_risk_strat$gini,
bankruptcy_risk_strat$top_quintile_capture),
Acquisition = c(acquisition_risk_strat$discrimination_ratio,
acquisition_risk_strat$gini,
acquisition_risk_strat$top_quintile_capture),
stringsAsFactors = FALSE
)
comparison$Difference <- comparison$Bankruptcy - comparison$Acquisition
comparison$Pct_Difference <- comparison$Difference / comparison$Acquisition * 100
# Format for display
formatted_comparison <- comparison
formatted_comparison$Bankruptcy <- round(formatted_comparison$Bankruptcy, 3)
formatted_comparison$Acquisition <- round(formatted_comparison$Acquisition, 3)
formatted_comparison$Difference <- round(formatted_comparison$Difference, 3)
formatted_comparison$Pct_Difference <- round(formatted_comparison$Pct_Difference, 1)
print(formatted_comparison)
# Interpret differences
cat("\nInterpretation of Model Differences:\n")
# Compare discrimination ratios
if(comparison$Bankruptcy[1] > comparison$Acquisition[1] * 1.25) {
cat("- The bankruptcy model has significantly better discrimination between\n")
cat(" high and low risk companies (", round(comparison$Pct_Difference[1], 1), "% higher)\n", sep="")
} else if(comparison$Acquisition[1] > comparison$Bankruptcy[1] * 1.25) {
cat("- The acquisition model has significantly better discrimination between\n")
cat(" high and low risk companies (", round(-comparison$Pct_Difference[1], 1), "% higher)\n", sep="")
} else {
cat("- Both models have similar discrimination between high and low risk companies\n")
}
# Compare Gini coefficients
if(comparison$Bankruptcy[2] > comparison$Acquisition[2] * 1.15) {
cat("- The bankruptcy model has better event concentration (higher Gini coefficient)\n")
} else if(comparison$Acquisition[2] > comparison$Bankruptcy[2] * 1.15) {
cat("- The acquisition model has better event concentration (higher Gini coefficient)\n")
} else {
cat("- Both models have similar event concentration patterns\n")
}
# Compare capture rates
if(comparison$Bankruptcy[3] > comparison$Acquisition[3] * 1.15) {
cat("- The bankruptcy model captures more events in its highest risk quintile\n")
} else if(comparison$Acquisition[3] > comparison$Bankruptcy[3] * 1.15) {
cat("- The acquisition model captures more events in its highest risk quintile\n")
} else {
cat("- Both models capture a similar proportion of events in their highest risk quintile\n")
}
# Overall conclusion
if(sum(comparison$Bankruptcy) > sum(comparison$Acquisition) * 1.15) {
cat("\nOverall, the bankruptcy model provides better risk stratification,\n")
cat("suggesting bankruptcy events are more predictable than acquisitions.\n")
} else if(sum(comparison$Acquisition) > sum(comparison$Bankruptcy) * 1.15) {
cat("\nOverall, the acquisition model provides better risk stratification,\n")
cat("suggesting acquisition events are more predictable than bankruptcies.\n")
} else {
cat("\nOverall, both models provide comparable risk stratification,\n")
cat("suggesting similar levels of predictability for both types of events.\n")
}
}
COMPARING RISK STRATIFICATION BETWEEN MODELS:
-------------------------------------------
Interpretation of Model Differences:
- The bankruptcy model has significantly better discrimination between
high and low risk companies (5205% higher)
- The bankruptcy model has better event concentration (higher Gini coefficient)
- The bankruptcy model captures more events in its highest risk quintile
Overall, the bankruptcy model provides better risk stratification,
suggesting bankruptcy events are more predictable than acquisitions.
Not entirely sure of this application here but its an innovative approach (still not entirely correct here). Basically we are using the Cox model predictions to rank companies by risk. This is a common practice in survival analysis, where we want to identify which companies are at higher risk of experiencing an event (like bankruptcy or acquisition) based on their characteristics and the time until the event occurs. I think its innovative because i havent seen it in any of the research, it also allows us to kinda apply our model IRL.
#-------------------------------------------------------------
# STEP 14: Ranking Companies by Risk (Using Cox Model Predictions)
#-------------------------------------------------------------
cat("\n=== STEP 14: RANKING COMPANIES BY RISK USING COX MODEL PREDICTIONS ===\n")
=== STEP 14: RANKING COMPANIES BY RISK USING COX MODEL PREDICTIONS ===
#-------------------------------------------------------------
# 14.1: Create Risk Ranking Function
#-------------------------------------------------------------
cat("\n14.1: CREATING RISK RANKINGS BASED ON PREDICTED HAZARDS\n")
14.1: CREATING RISK RANKINGS BASED ON PREDICTED HAZARDS
cat("--------------------------------------\n")
--------------------------------------
# Function to rank companies by risk using Cox models
rank_companies_by_risk <- function(bankruptcy_model, acquisition_model, top_n = 20) {
cat("Ranking companies by risk using Cox model predictions...\n")
# Get the latest observation for each company
latest_obs <- data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Calculate company age (time since first observation)
company_age <- latest_obs$tstop
# Calculate risk scores from both models
bankruptcy_risk <- predict(bankruptcy_model, newdata = latest_obs, type = "risk")
acquisition_risk <- predict(acquisition_model, newdata = latest_obs, type = "risk")
# Add scores to data
latest_obs$bankruptcy_risk <- bankruptcy_risk
latest_obs$acquisition_risk <- acquisition_risk
# Calculate inverse survival probability (1 - exp(-risk))
# This gives an estimation of event probability
latest_obs$bankruptcy_prob <- 1 - exp(-bankruptcy_risk)
latest_obs$acquisition_prob <- 1 - exp(-acquisition_risk)
# Calculate survival probability for both events combined
latest_obs$overall_survival_prob <- exp(-(bankruptcy_risk + acquisition_risk))
# Calculate conditional probabilities (given that an event happens)
denominator <- bankruptcy_risk + acquisition_risk
latest_obs$bankruptcy_cond_prob <- ifelse(denominator > 0,
bankruptcy_risk / denominator, 0)
latest_obs$acquisition_cond_prob <- ifelse(denominator > 0,
acquisition_risk / denominator, 0)
# Create combined risk score (weighted sum of both risks)
latest_obs$combined_risk <- bankruptcy_risk * 0.6 + acquisition_risk * 0.4 # Example weights
# Calculate time-adjusted probabilities (higher risk for shorter time periods)
max_time <- max(company_age)
time_factor <- (max_time - company_age) / max_time
latest_obs$time_adj_bankruptcy_prob <- latest_obs$bankruptcy_prob * (1 + time_factor)
latest_obs$time_adj_acquisition_prob <- latest_obs$acquisition_prob * (1 + time_factor)
# Select key variables for the ranking
risk_ranking <- latest_obs %>%
select(cusip, gsector, bankruptcy_risk, acquisition_risk, bankruptcy_prob,
acquisition_prob, combined_risk, overall_survival_prob,
bankruptcy_cond_prob, acquisition_cond_prob)
# Add company financial information for context
key_financials <- c("LTMTA", "NIMTA", "CASHMTA", "PRICE", "z_score")
risk_ranking <- cbind(risk_ranking, latest_obs[, intersect(key_financials, colnames(latest_obs))])
# Add macroeconomic context for the latest observation
key_macro <- c("gdp_growth", "unemployement", "gdp_deflator")
risk_ranking <- cbind(risk_ranking, latest_obs[, intersect(key_macro, colnames(latest_obs))])
# Rank companies for bankruptcy risk
cat("\nRanking companies by bankruptcy risk...\n")
bankruptcy_ranking <- risk_ranking %>%
arrange(desc(bankruptcy_risk))
# Rank companies for acquisition risk
cat("Ranking companies by acquisition risk...\n")
acquisition_ranking <- risk_ranking %>%
arrange(desc(acquisition_risk))
# Create a "safe investments" ranking (low risk of both events)
cat("Ranking companies by overall survival probability (safe investments)...\n")
safe_ranking <- risk_ranking %>%
arrange(desc(overall_survival_prob))
# Print top companies by bankruptcy risk
cat("\nTop", top_n, "Companies with Highest Bankruptcy Risk:\n")
cat("------------------------------------------------\n")
top_bankruptcy <- head(bankruptcy_ranking, top_n)
# Format probabilities as percentages
top_bankruptcy$bankruptcy_prob <- round(top_bankruptcy$bankruptcy_prob * 100, 1)
print(top_bankruptcy[, c("cusip", "gsector", "bankruptcy_risk", "bankruptcy_prob",
intersect(c("LTMTA", "NIMTA", "z_score"), colnames(top_bankruptcy)))])
# Print top companies by acquisition risk
cat("\nTop", top_n, "Companies with Highest Acquisition Risk:\n")
cat("-----------------------------------------------\n")
top_acquisition <- head(acquisition_ranking, top_n)
# Format probabilities as percentages
top_acquisition$acquisition_prob <- round(top_acquisition$acquisition_prob * 100, 1)
print(top_acquisition[, c("cusip", "gsector", "acquisition_risk", "acquisition_prob",
intersect(c("PRICE", "CASHMTA", "MBE"), colnames(top_acquisition)))])
# Print top safe investment options
cat("\nTop", top_n, "Safest Companies (Lowest Combined Risk):\n")
cat("----------------------------------------------\n")
top_safe <- head(safe_ranking, top_n)
# Format survival probability as percentage
top_safe$overall_survival_prob <- round(top_safe$overall_survival_prob * 100, 1)
print(top_safe[, c("cusip", "gsector", "overall_survival_prob", "bankruptcy_risk",
"acquisition_risk")])
# Return the full rankings
return(list(
bankruptcy_ranking = bankruptcy_ranking,
acquisition_ranking = acquisition_ranking,
safe_ranking = safe_ranking
))
}
#-------------------------------------------------------------
# 14.2: Apply Risk Ranking
#-------------------------------------------------------------
cat("\n14.2: APPLYING RISK RANKING TO COMPANIES IN THE DATASET\n")
14.2: APPLYING RISK RANKING TO COMPANIES IN THE DATASET
cat("--------------------------------------\n")
--------------------------------------
# Execute the ranking function on the models
company_rankings <- rank_companies_by_risk(final_bankruptcy_model, final_acquisition_model)
Ranking companies by risk using Cox model predictions...
Ranking companies by bankruptcy risk...
Ranking companies by acquisition risk...
Ranking companies by overall survival probability (safe investments)...
Top 20 Companies with Highest Bankruptcy Risk:
------------------------------------------------
Top 20 Companies with Highest Acquisition Risk:
-----------------------------------------------
Top 20 Safest Companies (Lowest Combined Risk):
----------------------------------------------
# Get sector-specific risk rankings
rank_by_sector <- function(bankruptcy_ranking, acquisition_ranking) {
cat("\nIdentifying highest-risk companies by sector:\n")
cat("-------------------------------------------\n")
# Get unique sectors
sectors <- unique(bankruptcy_ranking$gsector)
for(s in sectors) {
# Skip sectors with too few companies
sector_companies <- sum(bankruptcy_ranking$gsector == s)
if(sector_companies < 5) {
next
}
cat("\nSector", s, "(", sector_companies, "companies):\n")
# Top bankruptcy risks in this sector
top_bankruptcy <- bankruptcy_ranking %>%
filter(gsector == s) %>%
arrange(desc(bankruptcy_risk)) %>%
head(3)
# Top acquisition risks in this sector
top_acquisition <- acquisition_ranking %>%
filter(gsector == s) %>%
arrange(desc(acquisition_risk)) %>%
head(3)
cat(" Highest Bankruptcy Risk:\n")
for(i in 1:nrow(top_bankruptcy)) {
cat(" ", i, ". CUSIP: ", top_bankruptcy$cusip[i],
" (Risk Score: ", round(top_bankruptcy$bankruptcy_risk[i], 4),
", Probability: ", round(top_bankruptcy$bankruptcy_prob[i], 1), "%)\n", sep="")
}
cat(" Highest Acquisition Risk:\n")
for(i in 1:nrow(top_acquisition)) {
cat(" ", i, ". CUSIP: ", top_acquisition$cusip[i],
" (Risk Score: ", round(top_acquisition$acquisition_risk[i], 4),
", Probability: ", round(top_acquisition$acquisition_prob[i], 1), "%)\n", sep="")
}
}
}
# Apply sector-specific ranking
rank_by_sector(company_rankings$bankruptcy_ranking, company_rankings$acquisition_ranking)
Identifying highest-risk companies by sector:
-------------------------------------------
Sector 35 ( 1037 companies):
Highest Bankruptcy Risk:
1. CUSIP: 682311105 (Risk Score: 850.2138, Probability: 1%)
2. CUSIP: 88362L209 (Risk Score: 793.5069, Probability: 1%)
3. CUSIP: 90934C105 (Risk Score: 487.982, Probability: 1%)
Highest Acquisition Risk:
1. CUSIP: 444859102 (Risk Score: 15.5969, Probability: 1%)
2. CUSIP: 03073E105 (Risk Score: 14.213, Probability: 1%)
3. CUSIP: 834223604 (Risk Score: 11.7315, Probability: 1%)
Sector 45 ( 1391 companies):
Highest Bankruptcy Risk:
1. CUSIP: 00951K104 (Risk Score: 709.594, Probability: 1%)
2. CUSIP: 466212107 (Risk Score: 341.8142, Probability: 1%)
3. CUSIP: 784109209 (Risk Score: 315.826, Probability: 1%)
Highest Acquisition Risk:
1. CUSIP: 729132100 (Risk Score: 12.9866, Probability: 1%)
2. CUSIP: 08160H101 (Risk Score: 10.9338, Probability: 1%)
3. CUSIP: 801056102 (Risk Score: 10.1817, Probability: 1%)
Sector 20 ( 726 companies):
Highest Bankruptcy Risk:
1. CUSIP: 09175M804 (Risk Score: 621.0165, Probability: 1%)
2. CUSIP: 04964A103 (Risk Score: 449.4098, Probability: 1%)
3. CUSIP: 021373303 (Risk Score: 256.0836, Probability: 1%)
Highest Acquisition Risk:
1. CUSIP: 56418H100 (Risk Score: 9.1366, Probability: 1%)
2. CUSIP: 278878103 (Risk Score: 7.9283, Probability: 1%)
3. CUSIP: 535555106 (Risk Score: 7.5928, Probability: 1%)
Sector 25 ( 916 companies):
Highest Bankruptcy Risk:
1. CUSIP: 74838C106 (Risk Score: 449.5963, Probability: 1%)
2. CUSIP: 98912M201 (Risk Score: 373.4899, Probability: 1%)
3. CUSIP: 825397102 (Risk Score: 260.3327, Probability: 1%)
Highest Acquisition Risk:
1. CUSIP: 02341Q205 (Risk Score: 13.2884, Probability: 1%)
2. CUSIP: 09629F108 (Risk Score: 9.6906, Probability: 1%)
3. CUSIP: 36237H101 (Risk Score: 9.4212, Probability: 1%)
Sector 10 ( 244 companies):
Highest Bankruptcy Risk:
1. CUSIP: 140781105 (Risk Score: 300.7726, Probability: 1%)
2. CUSIP: 93564A100 (Risk Score: 271.9417, Probability: 1%)
3. CUSIP: 18911Q102 (Risk Score: 146.7998, Probability: 1%)
Highest Acquisition Risk:
1. CUSIP: 858122203 (Risk Score: 5.508, Probability: 1%)
2. CUSIP: 15643U104 (Risk Score: 5.2662, Probability: 1%)
3. CUSIP: 402307102 (Risk Score: 4.4583, Probability: 1%)
Sector 30 ( 214 companies):
Highest Bankruptcy Risk:
1. CUSIP: 242370203 (Risk Score: 209.4095, Probability: 1%)
2. CUSIP: 762831303 (Risk Score: 155.2022, Probability: 1%)
3. CUSIP: 65332E101 (Risk Score: 140.0007, Probability: 1%)
Highest Acquisition Risk:
1. CUSIP: 71377A103 (Risk Score: 10.0892, Probability: 1%)
2. CUSIP: 72147K108 (Risk Score: 10.013, Probability: 1%)
3. CUSIP: 911163103 (Risk Score: 6.8234, Probability: 1%)
Sector 50 ( 266 companies):
Highest Bankruptcy Risk:
1. CUSIP: 579489303 (Risk Score: 207.8258, Probability: 1%)
2. CUSIP: 888733102 (Risk Score: 140.8568, Probability: 1%)
3. CUSIP: 220874101 (Risk Score: 128.2872, Probability: 1%)
Highest Acquisition Risk:
1. CUSIP: 448947507 (Risk Score: 6.4337, Probability: 1%)
2. CUSIP: 92556H206 (Risk Score: 5.4554, Probability: 1%)
3. CUSIP: 911684108 (Risk Score: 5.3986, Probability: 1%)
Sector 15 ( 182 companies):
Highest Bankruptcy Risk:
1. CUSIP: 949702104 (Risk Score: 177.0007, Probability: 1%)
2. CUSIP: 038196101 (Risk Score: 107.1073, Probability: 1%)
3. CUSIP: 16941J205 (Risk Score: 104.353, Probability: 1%)
Highest Acquisition Risk:
1. CUSIP: 03940R107 (Risk Score: 6.7298, Probability: 1%)
2. CUSIP: 483007704 (Risk Score: 5.5725, Probability: 1%)
3. CUSIP: 68162K106 (Risk Score: 5.1622, Probability: 1%)
Sector 55 ( 32 companies):
Highest Bankruptcy Risk:
1. CUSIP: 29406L201 (Risk Score: 89.2126, Probability: 1%)
2. CUSIP: G9376R209 (Risk Score: 12.9888, Probability: 1%)
3. CUSIP: V0393H103 (Risk Score: 8.2652, Probability: 1%)
Highest Acquisition Risk:
1. CUSIP: 85512C105 (Risk Score: 3.0625, Probability: 1%)
2. CUSIP: 00130H105 (Risk Score: 2.5815, Probability: 0.9%)
3. CUSIP: 629377508 (Risk Score: 2.4923, Probability: 0.9%)
Sector 60 ( 30 companies):
Highest Bankruptcy Risk:
1. CUSIP: 75605Y106 (Risk Score: 22.1886, Probability: 1%)
2. CUSIP: M4793C102 (Risk Score: 20.5921, Probability: 1%)
3. CUSIP: 489398107 (Risk Score: 16.6066, Probability: 1%)
Highest Acquisition Risk:
1. CUSIP: 48020Q107 (Risk Score: 3.7792, Probability: 1%)
2. CUSIP: 78377T107 (Risk Score: 3.0541, Probability: 1%)
3. CUSIP: 876664103 (Risk Score: 2.4286, Probability: 0.9%)
Here, we are analyzing the risk profiles of companies based on their bankruptcy and acquisition risks. We categorize companies into different risk categories based on their predicted risks and analyze the distribution of these categories across sectors. We also visualize the risk landscape using scatter plots and identify sectors with high proportions of companies in each risk category.
#-------------------------------------------------------------
# 14.3: Risk Profile Analysis
#-------------------------------------------------------------
cat("\n14.3: RISK PROFILE ANALYSIS\n")
14.3: RISK PROFILE ANALYSIS
cat("--------------------------------------\n")
--------------------------------------
analyze_risk_profiles <- function(bankruptcy_ranking, acquisition_ranking) {
cat("Analyzing company risk profiles...\n")
# Create a combined ranking with risk categorization
combined_ranking <- bankruptcy_ranking
# Determine risk categories based on percentiles
bankruptcy_threshold <- quantile(combined_ranking$bankruptcy_risk, 0.75)
acquisition_threshold <- quantile(combined_ranking$acquisition_risk, 0.75)
# Categorize companies by risk profile
combined_ranking$risk_category <- "Low Risk"
combined_ranking$risk_category[combined_ranking$bankruptcy_risk > bankruptcy_threshold &
combined_ranking$acquisition_risk <= acquisition_threshold] <- "Bankruptcy Risk"
combined_ranking$risk_category[combined_ranking$bankruptcy_risk <= bankruptcy_threshold &
combined_ranking$acquisition_risk > acquisition_threshold] <- "Acquisition Risk"
combined_ranking$risk_category[combined_ranking$bankruptcy_risk > bankruptcy_threshold &
combined_ranking$acquisition_risk > acquisition_threshold] <- "High Risk (Both)"
# Convert to factor with meaningful order
combined_ranking$risk_category <- factor(combined_ranking$risk_category,
levels = c("Low Risk", "Bankruptcy Risk",
"Acquisition Risk", "High Risk (Both)"))
# Count companies in each category
category_counts <- table(combined_ranking$risk_category)
category_pcts <- prop.table(category_counts) * 100
cat("\nCompany Risk Profile Distribution:\n")
cat("--------------------------------\n")
for(i in 1:length(category_counts)) {
cat(names(category_counts)[i], ": ", category_counts[i],
" companies (", round(category_pcts[i], 1), "%)\n", sep="")
}
# Analyze risk profiles by sector
sector_profiles <- table(combined_ranking$gsector, combined_ranking$risk_category)
sector_profile_pcts <- prop.table(sector_profiles, margin = 1) * 100
cat("\nRisk Profile Distribution by Sector:\n")
cat("----------------------------------\n")
print(round(sector_profile_pcts, 1))
# Identify sectors with highest proportion of each risk type
high_bankruptcy_sectors <- sort(sector_profile_pcts[, "Bankruptcy Risk"], decreasing = TRUE)
high_acquisition_sectors <- sort(sector_profile_pcts[, "Acquisition Risk"], decreasing = TRUE)
high_both_sectors <- sort(sector_profile_pcts[, "High Risk (Both)"], decreasing = TRUE)
low_risk_sectors <- sort(sector_profile_pcts[, "Low Risk"], decreasing = TRUE)
cat("\nSectors with Highest Proportion of Bankruptcy Risk:\n")
for(i in 1:min(3, length(high_bankruptcy_sectors))) {
sector <- names(high_bankruptcy_sectors)[i]
pct <- high_bankruptcy_sectors[i]
cat(" Sector", sector, ": ", round(pct, 1), "% of companies at high bankruptcy risk\n", sep="")
}
cat("\nSectors with Highest Proportion of Acquisition Risk:\n")
for(i in 1:min(3, length(high_acquisition_sectors))) {
sector <- names(high_acquisition_sectors)[i]
pct <- high_acquisition_sectors[i]
cat(" Sector", sector, ": ", round(pct, 1), "% of companies at high acquisition risk\n", sep="")
}
cat("\nSectors with Highest Proportion of Low Risk Companies:\n")
for(i in 1:min(3, length(low_risk_sectors))) {
sector <- names(low_risk_sectors)[i]
pct <- low_risk_sectors[i]
cat(" Sector", sector, ": ", round(pct, 1), "% of companies at low risk\n", sep="")
}
# Create visualization of risk profiles
# Risk-Risk scatter plot
plot(combined_ranking$bankruptcy_risk, combined_ranking$acquisition_risk,
main = "Company Risk Landscape",
xlab = "Bankruptcy Risk", ylab = "Acquisition Risk",
pch = 16, col = adjustcolor("blue", alpha.f = 0.4),
xlim = c(0, max(combined_ranking$bankruptcy_risk) * 1.1),
ylim = c(0, max(combined_ranking$acquisition_risk) * 1.1))
# Add sector-specific coloring if preferred
# Use different colors for different risk categories
points(combined_ranking$bankruptcy_risk[combined_ranking$risk_category == "Bankruptcy Risk"],
combined_ranking$acquisition_risk[combined_ranking$risk_category == "Bankruptcy Risk"],
pch = 16, col = adjustcolor("red", alpha.f = 0.6))
points(combined_ranking$bankruptcy_risk[combined_ranking$risk_category == "Acquisition Risk"],
combined_ranking$acquisition_risk[combined_ranking$risk_category == "Acquisition Risk"],
pch = 16, col = adjustcolor("green", alpha.f = 0.6))
points(combined_ranking$bankruptcy_risk[combined_ranking$risk_category == "High Risk (Both)"],
combined_ranking$acquisition_risk[combined_ranking$risk_category == "High Risk (Both)"],
pch = 16, col = adjustcolor("purple", alpha.f = 0.6))
# Add lines to demarcate risk quadrants
abline(v = bankruptcy_threshold, lty = 2, col = "darkgray")
abline(h = acquisition_threshold, lty = 2, col = "darkgray")
# Add quadrant labels
text(max(combined_ranking$bankruptcy_risk) * 0.25,
max(combined_ranking$acquisition_risk) * 0.25,
"Low Risk Zone", col = "blue", cex = 1.2)
text(max(combined_ranking$bankruptcy_risk) * 0.75,
max(combined_ranking$acquisition_risk) * 0.25,
"Bankruptcy Risk Zone", col = "red", cex = 1.2)
text(max(combined_ranking$bankruptcy_risk) * 0.25,
max(combined_ranking$acquisition_risk) * 0.75,
"Acquisition Risk Zone", col = "green4", cex = 1.2)
text(max(combined_ranking$bankruptcy_risk) * 0.75,
max(combined_ranking$acquisition_risk) * 0.75,
"High Risk Zone", col = "purple", cex = 1.2)
# Add correlation information
risk_correlation <- cor(combined_ranking$bankruptcy_risk,
combined_ranking$acquisition_risk)
mtext(paste("Correlation between risk types:", round(risk_correlation, 3)),
side = 3, line = 0.5, cex = 0.8)
# Return the combined ranking with risk categories
return(combined_ranking)
}
# Execute the risk profile analysis
risk_profiles <- analyze_risk_profiles(company_rankings$bankruptcy_ranking,
company_rankings$acquisition_ranking)
Analyzing company risk profiles...
Company Risk Profile Distribution:
--------------------------------
Low Risk: 2728 companies (54.1%)
Bankruptcy Risk: 1050 companies (20.8%)
Acquisition Risk: 1050 companies (20.8%)
High Risk (Both): 210 companies (4.2%)
Risk Profile Distribution by Sector:
----------------------------------
Low Risk Bankruptcy Risk Acquisition Risk High Risk (Both)
10 61.1 20.5 16.4 2.0
15 54.4 23.1 20.3 2.2
20 53.9 23.1 19.7 3.3
25 48.0 28.9 17.8 5.2
30 57.9 23.4 16.4 2.3
35 51.6 16.9 25.8 5.7
45 55.8 17.0 23.6 3.7
50 63.9 20.3 10.9 4.9
55 71.9 15.6 12.5 0.0
60 70.0 16.7 10.0 3.3
Sectors with Highest Proportion of Bankruptcy Risk:
Sector25: 28.9% of companies at high bankruptcy risk
Sector30: 23.4% of companies at high bankruptcy risk
Sector20: 23.1% of companies at high bankruptcy risk
Sectors with Highest Proportion of Acquisition Risk:
Sector35: 25.8% of companies at high acquisition risk
Sector45: 23.6% of companies at high acquisition risk
Sector15: 20.3% of companies at high acquisition risk
Sectors with Highest Proportion of Low Risk Companies:
Sector55: 71.9% of companies at low risk
Sector60: 70% of companies at low risk
Sector50: 63.9% of companies at low risk
We also rank the companies by risk using the Cox model predictions. This involves calculating the predicted risks for each company and categorizing them into different risk levels. We then visualize the risk landscape using scatter plots and identify sectors with high proportions of companies in each risk category. The analysis also includes a discussion of the implications of these findings for investors and stakeholders. We include time till event estimates for each company, which can be useful for risk management and investment decisions. Time is calculated using the linear predictor from the Cox model and the median time to event from the data. We also cap extremely long estimates at a reasonable value (e.g., 100 years) to avoid unrealistic predictions. The final output includes a ranking of companies by risk, along with their estimated remaining time until bankruptcy or acquisition.
#-------------------------------------------------------------
# 14.1: Rank Companies by Risk (Using Cox Model Predictions)
#-------------------------------------------------------------
cat("\n14.1: COMPANY RISK RANKING WITH REMAINING TIME ESTIMATION\n")
14.1: COMPANY RISK RANKING WITH REMAINING TIME ESTIMATION
cat("--------------------------------------\n")
--------------------------------------
# Function to rank companies by risk with survival-based time estimates
rank_companies_by_risk <- function() {
cat("Ranking companies by bankruptcy and acquisition risk...\n")
# Get last observation for each company
company_data <- data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Calculate bankruptcy and acquisition risk scores
company_data$bankruptcy_risk <- predict(final_bankruptcy_model, newdata = company_data, type = "risk")
company_data$acquisition_risk <- predict(final_acquisition_model, newdata = company_data, type = "risk")
# Calculate percentile ranks
company_data$bankruptcy_percentile <- rank(company_data$bankruptcy_risk) / nrow(company_data) * 100
company_data$acquisition_percentile <- rank(company_data$acquisition_risk) / nrow(company_data) * 100
# Add risk categories
company_data$bankruptcy_risk_category <- cut(company_data$bankruptcy_percentile,
breaks = c(0, 80, 90, 95, 100),
labels = c("Low", "Moderate", "High", "Very High"))
company_data$acquisition_risk_category <- cut(company_data$acquisition_percentile,
breaks = c(0, 80, 90, 95, 100),
labels = c("Low", "Moderate", "High", "Very High"))
# Estimate remaining time using survival analysis principles
cat("Estimating remaining time using survival analysis principles...\n")
# For bankruptcy model
# Create typical covariate values for reference - FIX: use dplyr verbs correctly
bankruptcy_vars <- names(coef(final_bankruptcy_model))
bankruptcy_vars <- bankruptcy_vars[!grepl(":tt", bankruptcy_vars)]
# Create reference values manually instead of using across()
reference_bankruptcy <- data.frame(matrix(NA, nrow = 1, ncol = length(bankruptcy_vars)))
colnames(reference_bankruptcy) <- bankruptcy_vars
for(var in bankruptcy_vars) {
if(var %in% colnames(company_data)) {
reference_bankruptcy[1, var] <- median(company_data[[var]], na.rm = TRUE)
} else {
# For variables not in the data (could be interaction terms or transformations)
reference_bankruptcy[1, var] <- 0
}
}
# Calculate linear predictor for reference company
lp_reference_bankruptcy <- sum(coef(final_bankruptcy_model)[bankruptcy_vars] *
as.numeric(reference_bankruptcy[1, ]))
# Calculate linear predictor for each company
lp_company_bankruptcy <- predict(final_bankruptcy_model, newdata = company_data, type = "lp")
# Estimate relative risk compared to reference company
relative_risk_bankruptcy <- exp(lp_company_bankruptcy - lp_reference_bankruptcy)
# Use a data-driven approach to determine median reference time
# Based on event distribution in the data
event_times_bankruptcy <- data %>%
filter(bankruptcy == 1) %>%
group_by(cusip) %>%
slice_max(tstop) %>%
pull(tstop)
if(length(event_times_bankruptcy) > 0) {
median_reference_time_bankruptcy <- median(event_times_bankruptcy)
} else {
# Fallback if no bankruptcy events
median_reference_time_bankruptcy <- 25
}
# Calculate company-specific median times
company_data$remaining_time_to_bankruptcy <- median_reference_time_bankruptcy / relative_risk_bankruptcy
# For companies already in the event, set remaining time to 0
company_data$remaining_time_to_bankruptcy[company_data$bankruptcy == 1] <- 0
# Cap extremely long estimates at a reasonable value (e.g., 100 years)
company_data$remaining_time_to_bankruptcy[company_data$remaining_time_to_bankruptcy > 100] <- 100
# Similarly for acquisition model
acquisition_vars <- names(coef(final_acquisition_model))
acquisition_vars <- acquisition_vars[!grepl(":tt", acquisition_vars)]
# Create reference values manually
reference_acquisition <- data.frame(matrix(NA, nrow = 1, ncol = length(acquisition_vars)))
colnames(reference_acquisition) <- acquisition_vars
for(var in acquisition_vars) {
if(var %in% colnames(company_data)) {
reference_acquisition[1, var] <- median(company_data[[var]], na.rm = TRUE)
} else {
reference_acquisition[1, var] <- 0
}
}
lp_reference_acquisition <- sum(coef(final_acquisition_model)[acquisition_vars] *
as.numeric(reference_acquisition[1, ]))
lp_company_acquisition <- predict(final_acquisition_model, newdata = company_data, type = "lp")
relative_risk_acquisition <- exp(lp_company_acquisition - lp_reference_acquisition)
# Get median time from data
event_times_acquisition <- data %>%
filter(acquisition == 1) %>%
group_by(cusip) %>%
slice_max(tstop) %>%
pull(tstop)
if(length(event_times_acquisition) > 0) {
median_reference_time_acquisition <- median(event_times_acquisition)
} else {
median_reference_time_acquisition <- 25
}
company_data$remaining_time_to_acquisition <- median_reference_time_acquisition / relative_risk_acquisition
# For companies already acquired, set remaining time to 0
company_data$remaining_time_to_acquisition[company_data$acquisition == 1] <- 0
# Cap extremely long estimates
company_data$remaining_time_to_acquisition[company_data$remaining_time_to_acquisition > 100] <- 100
# Add confidence around time estimates (simplified approach)
# Lower and upper bounds based on assumption that hazard ratio has ±25% uncertainty
company_data$bankruptcy_time_lower <- company_data$remaining_time_to_bankruptcy / 1.25
company_data$bankruptcy_time_upper <- company_data$remaining_time_to_bankruptcy * 1.25
company_data$acquisition_time_lower <- company_data$remaining_time_to_acquisition / 1.25
company_data$acquisition_time_upper <- company_data$remaining_time_to_acquisition * 1.25
# Add "most likely outcome" column
company_data <- company_data %>%
mutate(most_likely_outcome = case_when(
bankruptcy == 1 ~ "Already Bankrupt",
acquisition == 1 ~ "Already Acquired",
bankruptcy_risk > acquisition_risk & remaining_time_to_bankruptcy < remaining_time_to_acquisition ~ "Bankruptcy",
acquisition_risk > bankruptcy_risk & remaining_time_to_acquisition < remaining_time_to_bankruptcy ~ "Acquisition",
TRUE ~ "Inconclusive"
))
# Return ranked company data
return(company_data)
}
# Rank companies by risk
ranked_companies <- rank_companies_by_risk()
Ranking companies by bankruptcy and acquisition risk...
Estimating remaining time using survival analysis principles...
# Display top companies at risk of bankruptcy
cat("\nTOP 20 COMPANIES AT RISK OF BANKRUPTCY:\n")
TOP 20 COMPANIES AT RISK OF BANKRUPTCY:
cat("------------------------------------\n")
------------------------------------
top_bankruptcy <- ranked_companies %>%
filter(bankruptcy == 0) %>% # Only include companies not yet bankrupt
arrange(desc(bankruptcy_risk)) %>%
head(20)
# Create a dashboard-style display
bankruptcy_display <- data.frame(
Rank = 1:nrow(top_bankruptcy),
CUSIP = top_bankruptcy$cusip,
Industry = top_bankruptcy$gsector,
"Risk Score" = round(top_bankruptcy$bankruptcy_risk, 4),
"Risk Percentile" = paste0(round(top_bankruptcy$bankruptcy_percentile, 1), "%"),
"Est. Remaining Years" = round(top_bankruptcy$remaining_time_to_bankruptcy, 1),
"Time Range" = paste0("[", round(top_bankruptcy$bankruptcy_time_lower, 1), "-",
round(top_bankruptcy$bankruptcy_time_upper, 1), "]"),
"Current Lifetime" = round(top_bankruptcy$tstop, 1),
"Risk Category" = as.character(top_bankruptcy$bankruptcy_risk_category),
stringsAsFactors = FALSE
)
print(bankruptcy_display, row.names = FALSE)
# Display top companies likely to be acquired
cat("\nTOP 20 COMPANIES LIKELY TO BE ACQUIRED:\n")
TOP 20 COMPANIES LIKELY TO BE ACQUIRED:
cat("------------------------------------\n")
------------------------------------
top_acquisition <- ranked_companies %>%
filter(acquisition == 0) %>% # Only include companies not yet acquired
arrange(desc(acquisition_risk)) %>%
head(20)
# Create a dashboard-style display
acquisition_display <- data.frame(
Rank = 1:nrow(top_acquisition),
CUSIP = top_acquisition$cusip,
Industry = top_acquisition$gsector,
"Risk Score" = round(top_acquisition$acquisition_risk, 4),
"Risk Percentile" = paste0(round(top_acquisition$acquisition_percentile, 1), "%"),
"Est. Remaining Years" = round(top_acquisition$remaining_time_to_acquisition, 1),
"Time Range" = paste0("[", round(top_acquisition$acquisition_time_lower, 1), "-",
round(top_acquisition$acquisition_time_upper, 1), "]"),
"Current Lifetime" = round(top_acquisition$tstop, 1),
"Risk Category" = as.character(top_acquisition$acquisition_risk_category),
stringsAsFactors = FALSE
)
print(acquisition_display, row.names = FALSE)
# Companies with competing risks (at high risk for both outcomes)
cat("\nCOMPANIES AT HIGH RISK FOR BOTH OUTCOMES:\n")
COMPANIES AT HIGH RISK FOR BOTH OUTCOMES:
cat("----------------------------------------\n")
----------------------------------------
competing_risks <- ranked_companies %>%
filter(bankruptcy == 0 & acquisition == 0) %>% # Only include active companies
filter(bankruptcy_percentile > 90 & acquisition_percentile > 90) %>% # High risk for both
arrange(desc(bankruptcy_risk + acquisition_risk)) %>%
head(10)
if(nrow(competing_risks) > 0) {
competing_display <- data.frame(
CUSIP = competing_risks$cusip,
Industry = competing_risks$gsector,
"B-Risk %" = paste0(round(competing_risks$bankruptcy_percentile, 1), "%"),
"A-Risk %" = paste0(round(competing_risks$acquisition_percentile, 1), "%"),
"B-Years" = round(competing_risks$remaining_time_to_bankruptcy, 1),
"A-Years" = round(competing_risks$remaining_time_to_acquisition, 1),
"Most Likely" = competing_risks$most_likely_outcome,
stringsAsFactors = FALSE
)
print(competing_display, row.names = FALSE)
} else {
cat("No companies found at high risk for both outcomes.\n")
}
Finally we look at industry specific effects of financial variables on bankruptcy and acquisition risks. This involves analyzing the coefficients of the Cox models for different sectors and identifying any significant differences in the effects of financial variables across industries. We also visualize these effects using plots to illustrate how the impact of financial variables varies by sector. This analysis can provide insights into which financial factors are most predictive of bankruptcy or acquisition risk in different industries, helping investors and stakeholders make informed decisions.
#-------------------------------------------------------------
# STEP 15: Industry-Specific Financial Variable Effects Analysis
#-------------------------------------------------------------
cat("\n=== STEP 15: INDUSTRY-SPECIFIC FINANCIAL VARIABLE EFFECTS ANALYSIS ===\n")
=== STEP 15: INDUSTRY-SPECIFIC FINANCIAL VARIABLE EFFECTS ANALYSIS ===
analyze_industry_effects <- function() {
cat("\n15.1: INDUSTRY-SPECIFIC VARIABLE EFFECTS\n")
cat("--------------------------------------\n")
# Get unique industry sectors
sectors <- unique(data$gsector)
cat("Analyzing variable effects across", length(sectors), "industry sectors...\n\n")
# Identify all non-macro variables with significant effects
bankruptcy_vars <- names(coef(final_bankruptcy_model))
acquisition_vars <- names(coef(final_acquisition_model))
# Remove macro variables and their time interactions
macro_vars <- c("gdp_growth", "gdp_deflator", "unemployement")
bankruptcy_vars <- bankruptcy_vars[!sapply(bankruptcy_vars, function(v) {
base_var <- sub(":tt", "", v)
return(base_var %in% macro_vars)
})]
acquisition_vars <- acquisition_vars[!sapply(acquisition_vars, function(v) {
base_var <- sub(":tt", "", v)
return(base_var %in% macro_vars)
})]
# Identify time-varying effects for financial variables
bankruptcy_time_vars <- grep(":tt", bankruptcy_vars, value = TRUE)
acquisition_time_vars <- grep(":tt", acquisition_vars, value = TRUE)
if(length(bankruptcy_time_vars) == 0 && length(acquisition_time_vars) == 0) {
cat("No time-varying effects found for financial variables in the models.\n")
return(NULL)
}
# Store results
industry_results <- list()
# 1. Test time-varying effects for financial variables by industry
cat("A. TESTING FINANCIAL VARIABLE TIME-VARYING EFFECTS BY INDUSTRY\n")
cat("--------------------------------------------------------\n\n")
# Function to test industry-specific effects
test_industry_effects <- function(model_name) {
cat(model_name, "Model:\n\n")
# Use the appropriate model
model <- if(model_name == "Bankruptcy") final_bankruptcy_model else final_acquisition_model
model_vars <- if(model_name == "Bankruptcy") bankruptcy_vars else acquisition_vars
model_time_vars <- if(model_name == "Bankruptcy") bankruptcy_time_vars else acquisition_time_vars
event_type <- tolower(model_name)
if(length(model_time_vars) == 0) {
cat("No time-varying effects found for financial variables in this model.\n\n")
return(NULL)
}
# Get main variable names from time interactions
main_vars <- sub(":tt", "", model_time_vars)
# Results storage
industry_var_results <- data.frame(
Variable = character(),
Sector = character(),
Main_Coef = numeric(),
Time_Coef = numeric(),
Initial_HR = numeric(),
HR_Year10 = numeric(),
Effect_Pattern = character(),
stringsAsFactors = FALSE
)
# For each major sector, fit a sector-specific model
for(sector in sectors) {
# Get only data for this sector
sector_data <- data %>%
filter(gsector == sector)
# Check if enough data
if(nrow(sector_data) < 100) {
cat(" Sector", sector, "has insufficient data (n =", nrow(sector_data), ").\n")
next
}
# Try to fit sector-specific model with only financial variables
tryCatch({
# Create formula focusing on financial time interactions
formula_str <- paste0("Surv(tstart, tstop, ", event_type, ") ~ ",
paste(main_vars, collapse = " + "),
" + ", paste(model_time_vars, collapse = " + "))
sector_model <- coxph(as.formula(formula_str), data = sector_data, ties = "efron")
# Extract coefficients for time variables
for(i in 1:length(main_vars)) {
var <- main_vars[i]
time_var <- model_time_vars[i]
if(var %in% names(coef(sector_model)) && time_var %in% names(coef(sector_model))) {
main_coef <- coef(sector_model)[var]
time_coef <- coef(sector_model)[time_var]
# Calculate hazard ratios
initial_hr <- exp(main_coef)
hr_year10 <- exp(main_coef + time_coef * 10)
# Determine effect pattern
initial_effect <- ifelse(main_coef > 0, "risk-increasing", "risk-decreasing")
if(sign(main_coef) == sign(time_coef)) {
effect_pattern <- paste0(initial_effect, " effect strengthens")
} else {
effect_pattern <- paste0(initial_effect, " effect weakens")
}
# Add to results
industry_var_results <- rbind(industry_var_results, data.frame(
Variable = var,
Sector = as.character(sector),
Main_Coef = main_coef,
Time_Coef = time_coef,
Initial_HR = initial_hr,
HR_Year10 = hr_year10,
Effect_Pattern = effect_pattern,
stringsAsFactors = FALSE
))
}
}
cat(" Sector", sector, "model fitted successfully.\n")
}, error = function(e) {
cat(" Error fitting model for sector", sector, ":", conditionMessage(e), "\n")
})
}
if(nrow(industry_var_results) > 0) {
cat("\n Industry-specific time patterns for financial variables in", model_name, "model:\n\n")
# Analyze each variable across sectors
for(var in unique(industry_var_results$Variable)) {
cat(" Variable:", var, "\n")
var_results <- industry_var_results %>% filter(Variable == var)
# Check for diversity in patterns
patterns <- table(var_results$Effect_Pattern)
cat(" Effect patterns across sectors:\n")
for(p in names(patterns)) {
cat(" -", p, ":", patterns[p], "sectors\n")
}
# Show specific sector effects
cat(" Sector-specific effects:\n")
for(i in 1:nrow(var_results)) {
cat(sprintf(" - Sector %s: Initial HR = %.2f, HR at 10 years = %.2f (%s)\n",
var_results$Sector[i], var_results$Initial_HR[i],
var_results$HR_Year10[i], var_results$Effect_Pattern[i]))
}
cat("\n")
}
} else {
cat(" No industry-specific results available for financial variables.\n\n")
}
return(industry_var_results)
}
# Test financial variable effects for both models
industry_results$bankruptcy <- test_industry_effects("Bankruptcy")
industry_results$acquisition <- test_industry_effects("Acquisition")
# 2. Create visualizations of industry-specific effects
cat("\n15.2: INDUSTRY-SPECIFIC FINANCIAL EFFECTS VISUALIZATION\n")
cat("--------------------------------------------------\n")
# Function to create visualization for a single financial variable
visualize_variable_by_industry <- function(industry_results, model_name, variable) {
if(is.null(industry_results) || !variable %in% industry_results$Variable) {
cat(" No data available for", variable, "in", model_name, "model.\n")
return(NULL)
}
# Filter data for this variable
var_data <- industry_results[industry_results$Variable == variable, ]
# Set up time sequence
times <- seq(0, 10, by = 0.1)
# Calculate hazard ratios over time for each sector
sectors <- unique(var_data$Sector)
hr_matrix <- matrix(NA, nrow = length(times), ncol = length(sectors))
for(i in 1:length(sectors)) {
sector_row <- var_data[var_data$Sector == sectors[i], ]
if(nrow(sector_row) > 0) {
main_coef <- sector_row$Main_Coef[1]
time_coef <- sector_row$Time_Coef[1]
hr_matrix[, i] <- exp(main_coef + time_coef * times)
}
}
# Create plot
matplot(times, hr_matrix, type = "l", lty = 1:length(sectors), col = 1:length(sectors),
main = paste("Effect of", variable, "by Sector -", model_name, "Model"),
xlab = "Time (Years)", ylab = "Hazard Ratio",
ylim = c(min(0.5, min(hr_matrix, na.rm = TRUE)),
max(2, max(hr_matrix, na.rm = TRUE))))
# Add reference line
abline(h = 1, lty = 2, col = "gray")
# Add legend
legend("topright", legend = paste("Sector", sectors),
lty = 1:length(sectors), col = 1:length(sectors),
cex = 0.8, bty = "n")
return(var_data)
}
# Visualize top financial variables with time interactions
if(!is.null(industry_results$bankruptcy) && nrow(industry_results$bankruptcy) > 0) {
top_variables <- names(table(industry_results$bankruptcy$Variable))[1:min(3, length(table(industry_results$bankruptcy$Variable)))]
cat(" Creating visualizations for top financial variables in bankruptcy model...\n")
for(var in top_variables) {
visualize_variable_by_industry(industry_results$bankruptcy, "Bankruptcy", var)
}
}
if(!is.null(industry_results$acquisition) && nrow(industry_results$acquisition) > 0) {
top_variables <- names(table(industry_results$acquisition$Variable))[1:min(3, length(table(industry_results$acquisition$Variable)))]
cat(" Creating visualizations for top financial variables in acquisition model...\n")
for(var in top_variables) {
visualize_variable_by_industry(industry_results$acquisition, "Acquisition", var)
}
}
# 3. Generate sector-specific recommendations
cat("\n15.3: INDUSTRY-SPECIFIC FINANCIAL RISK FACTORS\n")
cat("------------------------------------------\n\n")
# Function to identify key financial risk factors by sector
identify_key_risk_factors <- function(industry_results, model_name) {
if(is.null(industry_results) || nrow(industry_results) == 0) {
cat(" No data available for", model_name, "model risk factors.\n\n")
return(NULL)
}
cat("Key Financial Risk Factors by Industry Sector -", model_name, "Model:\n\n")
# Process each sector
for(sector in unique(industry_results$Sector)) {
sector_data <- industry_results[industry_results$Sector == sector, ]
cat(" Industry Sector", sector, ":\n")
# Sort by effect size (using abs(log(HR)) at year 10)
sector_data$effect_size <- abs(log(sector_data$HR_Year10))
sector_data <- sector_data[order(sector_data$effect_size, decreasing = TRUE), ]
# Report top risk factors
for(i in 1:min(3, nrow(sector_data))) {
var <- sector_data$Variable[i]
# Create readable variable name
var_name <- var
if(var == "LTMTA") var_name <- "Liabilities-to-Market Value"
else if(var == "NIMTA") var_name <- "Net Income-to-Market Value"
else if(var == "CASHMTA") var_name <- "Cash-to-Market Value"
else if(var == "PRICE") var_name <- "Stock Price"
else if(var == "MBE") var_name <- "Market-to-Book Equity"
else if(var == "RSIZE") var_name <- "Relative Size"
else if(var == "z_score") var_name <- "Altman Z-Score"
cat(" • KEY FACTOR:", var_name, "\n")
cat(" Initial HR =", round(sector_data$Initial_HR[i], 2),
", HR at Year 10 =", round(sector_data$HR_Year10[i], 2), "\n")
cat(" Pattern:", sector_data$Effect_Pattern[i], "\n")
# Add interpretation
cat(" Interpretation: ")
if(grepl("risk-increasing", sector_data$Effect_Pattern[i])) {
cat("Higher", var_name, "is associated with increased", tolower(model_name), "risk")
} else {
cat("Higher", var_name, "is associated with decreased", tolower(model_name), "risk")
}
if(grepl("strengthens", sector_data$Effect_Pattern[i])) {
cat(", and this effect becomes stronger over time\n")
} else {
cat(", but this effect diminishes over time\n")
}
}
# Add sector-specific recommendation
cat(" • SECTOR RECOMMENDATION: ")
if(model_name == "Bankruptcy") {
cat("Companies in Sector", sector, "should focus on ")
top_var <- sector_data$Variable[1]
if(grepl("risk-increasing", sector_data$Effect_Pattern[1])) {
cat("reducing their", top_var, "to minimize bankruptcy risk.\n")
} else {
cat("maintaining strong", top_var, "to protect against bankruptcy risk.\n")
}
} else {
cat("Companies in Sector", sector, "looking to avoid acquisition should focus on ")
top_var <- sector_data$Variable[1]
if(grepl("risk-increasing", sector_data$Effect_Pattern[1])) {
cat("managing their", top_var, "levels.\n")
} else {
cat("strategically positioning their", top_var, "metrics.\n")
}
}
cat("\n")
}
}
# Generate sector-specific financial risk factors
identify_key_risk_factors(industry_results$bankruptcy, "Bankruptcy")
identify_key_risk_factors(industry_results$acquisition, "Acquisition")
return(industry_results)
}
# Run industry analysis
industry_results <- analyze_industry_effects()
15.1: INDUSTRY-SPECIFIC VARIABLE EFFECTS
--------------------------------------
Analyzing variable effects across 10 industry sectors...
A. TESTING FINANCIAL VARIABLE TIME-VARYING EFFECTS BY INDUSTRY
--------------------------------------------------------
Bankruptcy Model:
Sector 20 model fitted successfully.
Sector 35 model fitted successfully.
Sector 45 model fitted successfully.
Sector 25 model fitted successfully.
Error fitting model for sector 55 : missing value where TRUE/FALSE needed
Sector 15 model fitted successfully.
Sector 50 model fitted successfully.
Sector 10 model fitted successfully.
Sector 30 model fitted successfully.
Error fitting model for sector 60 : missing value where TRUE/FALSE needed
Industry-specific time patterns for financial variables in Bankruptcy model:
Variable: LTMTA
Effect patterns across sectors:
- risk-decreasing effect weakens : 2 sectors
- risk-increasing effect strengthens : 4 sectors
- risk-increasing effect weakens : 2 sectors
Sector-specific effects:
- Sector 20: Initial HR = 849.50, HR at 10 years = 484.19 (risk-increasing effect weakens)
- Sector 35: Initial HR = 6.09, HR at 10 years = 12.62 (risk-increasing effect strengthens)
- Sector 45: Initial HR = 27.20, HR at 10 years = 101.94 (risk-increasing effect strengthens)
- Sector 25: Initial HR = 21.21, HR at 10 years = 66.27 (risk-increasing effect strengthens)
- Sector 15: Initial HR = 0.00, HR at 10 years = 418711389019.32 (risk-decreasing effect weakens)
- Sector 50: Initial HR = 751.09, HR at 10 years = 1219.04 (risk-increasing effect strengthens)
- Sector 10: Initial HR = 2347.67, HR at 10 years = 1148.53 (risk-increasing effect weakens)
- Sector 30: Initial HR = 0.00, HR at 10 years = 644178955453673366046088286282626462400.00 (risk-decreasing effect weakens)
Variable: PRICE
Effect patterns across sectors:
- risk-decreasing effect strengthens : 2 sectors
- risk-decreasing effect weakens : 3 sectors
- risk-increasing effect weakens : 3 sectors
Sector-specific effects:
- Sector 20: Initial HR = 0.82, HR at 10 years = 0.73 (risk-decreasing effect strengthens)
- Sector 35: Initial HR = 0.68, HR at 10 years = 0.73 (risk-decreasing effect weakens)
- Sector 45: Initial HR = 0.67, HR at 10 years = 0.80 (risk-decreasing effect weakens)
- Sector 25: Initial HR = 0.63, HR at 10 years = 0.63 (risk-decreasing effect weakens)
- Sector 15: Initial HR = 0.99, HR at 10 years = 0.66 (risk-decreasing effect strengthens)
- Sector 50: Initial HR = 2.46, HR at 10 years = 0.44 (risk-increasing effect weakens)
- Sector 10: Initial HR = 1.09, HR at 10 years = 0.49 (risk-increasing effect weakens)
- Sector 30: Initial HR = 2.55, HR at 10 years = 0.09 (risk-increasing effect weakens)
Variable: debt_ratio
Effect patterns across sectors:
- risk-decreasing effect weakens : 3 sectors
- risk-increasing effect weakens : 5 sectors
Sector-specific effects:
- Sector 20: Initial HR = 0.23, HR at 10 years = 0.52 (risk-decreasing effect weakens)
- Sector 35: Initial HR = 1.47, HR at 10 years = 0.80 (risk-increasing effect weakens)
- Sector 45: Initial HR = 0.19, HR at 10 years = 0.81 (risk-decreasing effect weakens)
- Sector 25: Initial HR = 0.62, HR at 10 years = 0.79 (risk-decreasing effect weakens)
- Sector 15: Initial HR = 4.17, HR at 10 years = 0.43 (risk-increasing effect weakens)
- Sector 50: Initial HR = 15.95, HR at 10 years = 0.23 (risk-increasing effect weakens)
- Sector 10: Initial HR = 4.84, HR at 10 years = 0.11 (risk-increasing effect weakens)
- Sector 30: Initial HR = 490.97, HR at 10 years = 0.00 (risk-increasing effect weakens)
Acquisition Model:
Sector 20 model fitted successfully.
Sector 35 model fitted successfully.
Sector 45 model fitted successfully.
Sector 25 model fitted successfully.
Sector 55 model fitted successfully.
Sector 15 model fitted successfully.
Sector 50 model fitted successfully.
Sector 10 model fitted successfully.
Sector 30 model fitted successfully.
Sector 60 model fitted successfully.
Industry-specific time patterns for financial variables in Acquisition model:
Variable: wc_ratio
Effect patterns across sectors:
- risk-decreasing effect weakens : 7 sectors
- risk-increasing effect strengthens : 1 sectors
- risk-increasing effect weakens : 2 sectors
Sector-specific effects:
- Sector 20: Initial HR = 0.51, HR at 10 years = 0.63 (risk-decreasing effect weakens)
- Sector 35: Initial HR = 0.44, HR at 10 years = 0.77 (risk-decreasing effect weakens)
- Sector 45: Initial HR = 0.44, HR at 10 years = 0.70 (risk-decreasing effect weakens)
- Sector 25: Initial HR = 0.55, HR at 10 years = 0.87 (risk-decreasing effect weakens)
- Sector 55: Initial HR = 0.82, HR at 10 years = 856.01 (risk-decreasing effect weakens)
- Sector 15: Initial HR = 1.68, HR at 10 years = 1.75 (risk-increasing effect strengthens)
- Sector 50: Initial HR = 0.54, HR at 10 years = 0.66 (risk-decreasing effect weakens)
- Sector 10: Initial HR = 1.11, HR at 10 years = 0.53 (risk-increasing effect weakens)
- Sector 30: Initial HR = 1.17, HR at 10 years = 0.88 (risk-increasing effect weakens)
- Sector 60: Initial HR = 0.00, HR at 10 years = 0.00 (risk-decreasing effect weakens)
Variable: asset_turnover
Effect patterns across sectors:
- risk-decreasing effect weakens : 7 sectors
- risk-increasing effect strengthens : 1 sectors
- risk-increasing effect weakens : 2 sectors
Sector-specific effects:
- Sector 20: Initial HR = 1.04, HR at 10 years = 1.11 (risk-increasing effect strengthens)
- Sector 35: Initial HR = 0.98, HR at 10 years = 1.03 (risk-decreasing effect weakens)
- Sector 45: Initial HR = 0.59, HR at 10 years = 0.80 (risk-decreasing effect weakens)
- Sector 25: Initial HR = 0.81, HR at 10 years = 0.86 (risk-decreasing effect weakens)
- Sector 55: Initial HR = 0.22, HR at 10 years = 0.47 (risk-decreasing effect weakens)
- Sector 15: Initial HR = 1.40, HR at 10 years = 1.31 (risk-increasing effect weakens)
- Sector 50: Initial HR = 0.94, HR at 10 years = 1.06 (risk-decreasing effect weakens)
- Sector 10: Initial HR = 0.64, HR at 10 years = 0.89 (risk-decreasing effect weakens)
- Sector 30: Initial HR = 0.83, HR at 10 years = 0.88 (risk-decreasing effect weakens)
- Sector 60: Initial HR = 7.13, HR at 10 years = 0.00 (risk-increasing effect weakens)
15.2: INDUSTRY-SPECIFIC FINANCIAL EFFECTS VISUALIZATION
--------------------------------------------------
Creating visualizations for top financial variables in bankruptcy model...
Creating visualizations for top financial variables in acquisition model...
15.3: INDUSTRY-SPECIFIC FINANCIAL RISK FACTORS
------------------------------------------
Key Financial Risk Factors by Industry Sector - Bankruptcy Model:
Industry Sector 20 :
• KEY FACTOR: Liabilities-to-Market Value
Initial HR = 849.5 , HR at Year 10 = 484.19
Pattern: risk-increasing effect weakens
Interpretation: Higher Liabilities-to-Market Value is associated with increased bankruptcy risk, but this effect diminishes over time
• KEY FACTOR: debt_ratio
Initial HR = 0.23 , HR at Year 10 = 0.52
Pattern: risk-decreasing effect weakens
Interpretation: Higher debt_ratio is associated with decreased bankruptcy risk, but this effect diminishes over time
• KEY FACTOR: Stock Price
Initial HR = 0.82 , HR at Year 10 = 0.73
Pattern: risk-decreasing effect strengthens
Interpretation: Higher Stock Price is associated with decreased bankruptcy risk, and this effect becomes stronger over time
• SECTOR RECOMMENDATION: Companies in Sector 20 should focus on reducing their LTMTA to minimize bankruptcy risk.
Industry Sector 35 :
• KEY FACTOR: Liabilities-to-Market Value
Initial HR = 6.09 , HR at Year 10 = 12.62
Pattern: risk-increasing effect strengthens
Interpretation: Higher Liabilities-to-Market Value is associated with increased bankruptcy risk, and this effect becomes stronger over time
• KEY FACTOR: Stock Price
Initial HR = 0.68 , HR at Year 10 = 0.73
Pattern: risk-decreasing effect weakens
Interpretation: Higher Stock Price is associated with decreased bankruptcy risk, but this effect diminishes over time
• KEY FACTOR: debt_ratio
Initial HR = 1.47 , HR at Year 10 = 0.8
Pattern: risk-increasing effect weakens
Interpretation: Higher debt_ratio is associated with increased bankruptcy risk, but this effect diminishes over time
• SECTOR RECOMMENDATION: Companies in Sector 35 should focus on reducing their LTMTA to minimize bankruptcy risk.
Industry Sector 45 :
• KEY FACTOR: Liabilities-to-Market Value
Initial HR = 27.2 , HR at Year 10 = 101.94
Pattern: risk-increasing effect strengthens
Interpretation: Higher Liabilities-to-Market Value is associated with increased bankruptcy risk, and this effect becomes stronger over time
• KEY FACTOR: Stock Price
Initial HR = 0.67 , HR at Year 10 = 0.8
Pattern: risk-decreasing effect weakens
Interpretation: Higher Stock Price is associated with decreased bankruptcy risk, but this effect diminishes over time
• KEY FACTOR: debt_ratio
Initial HR = 0.19 , HR at Year 10 = 0.81
Pattern: risk-decreasing effect weakens
Interpretation: Higher debt_ratio is associated with decreased bankruptcy risk, but this effect diminishes over time
• SECTOR RECOMMENDATION: Companies in Sector 45 should focus on reducing their LTMTA to minimize bankruptcy risk.
Industry Sector 25 :
• KEY FACTOR: Liabilities-to-Market Value
Initial HR = 21.21 , HR at Year 10 = 66.27
Pattern: risk-increasing effect strengthens
Interpretation: Higher Liabilities-to-Market Value is associated with increased bankruptcy risk, and this effect becomes stronger over time
• KEY FACTOR: Stock Price
Initial HR = 0.63 , HR at Year 10 = 0.63
Pattern: risk-decreasing effect weakens
Interpretation: Higher Stock Price is associated with decreased bankruptcy risk, but this effect diminishes over time
• KEY FACTOR: debt_ratio
Initial HR = 0.62 , HR at Year 10 = 0.79
Pattern: risk-decreasing effect weakens
Interpretation: Higher debt_ratio is associated with decreased bankruptcy risk, but this effect diminishes over time
• SECTOR RECOMMENDATION: Companies in Sector 25 should focus on reducing their LTMTA to minimize bankruptcy risk.
Industry Sector 15 :
• KEY FACTOR: Liabilities-to-Market Value
Initial HR = 0 , HR at Year 10 = 418711389019
Pattern: risk-decreasing effect weakens
Interpretation: Higher Liabilities-to-Market Value is associated with decreased bankruptcy risk, but this effect diminishes over time
• KEY FACTOR: debt_ratio
Initial HR = 4.17 , HR at Year 10 = 0.43
Pattern: risk-increasing effect weakens
Interpretation: Higher debt_ratio is associated with increased bankruptcy risk, but this effect diminishes over time
• KEY FACTOR: Stock Price
Initial HR = 0.99 , HR at Year 10 = 0.66
Pattern: risk-decreasing effect strengthens
Interpretation: Higher Stock Price is associated with decreased bankruptcy risk, and this effect becomes stronger over time
• SECTOR RECOMMENDATION: Companies in Sector 15 should focus on maintaining strong LTMTA to protect against bankruptcy risk.
Industry Sector 50 :
• KEY FACTOR: Liabilities-to-Market Value
Initial HR = 751.09 , HR at Year 10 = 1219.04
Pattern: risk-increasing effect strengthens
Interpretation: Higher Liabilities-to-Market Value is associated with increased bankruptcy risk, and this effect becomes stronger over time
• KEY FACTOR: debt_ratio
Initial HR = 15.95 , HR at Year 10 = 0.23
Pattern: risk-increasing effect weakens
Interpretation: Higher debt_ratio is associated with increased bankruptcy risk, but this effect diminishes over time
• KEY FACTOR: Stock Price
Initial HR = 2.46 , HR at Year 10 = 0.44
Pattern: risk-increasing effect weakens
Interpretation: Higher Stock Price is associated with increased bankruptcy risk, but this effect diminishes over time
• SECTOR RECOMMENDATION: Companies in Sector 50 should focus on reducing their LTMTA to minimize bankruptcy risk.
Industry Sector 10 :
• KEY FACTOR: Liabilities-to-Market Value
Initial HR = 2347.67 , HR at Year 10 = 1148.53
Pattern: risk-increasing effect weakens
Interpretation: Higher Liabilities-to-Market Value is associated with increased bankruptcy risk, but this effect diminishes over time
• KEY FACTOR: debt_ratio
Initial HR = 4.84 , HR at Year 10 = 0.11
Pattern: risk-increasing effect weakens
Interpretation: Higher debt_ratio is associated with increased bankruptcy risk, but this effect diminishes over time
• KEY FACTOR: Stock Price
Initial HR = 1.09 , HR at Year 10 = 0.49
Pattern: risk-increasing effect weakens
Interpretation: Higher Stock Price is associated with increased bankruptcy risk, but this effect diminishes over time
• SECTOR RECOMMENDATION: Companies in Sector 10 should focus on reducing their LTMTA to minimize bankruptcy risk.
Industry Sector 30 :
• KEY FACTOR: Liabilities-to-Market Value
Initial HR = 0 , HR at Year 10 = 6.44179e+38
Pattern: risk-decreasing effect weakens
Interpretation: Higher Liabilities-to-Market Value is associated with decreased bankruptcy risk, but this effect diminishes over time
• KEY FACTOR: debt_ratio
Initial HR = 490.97 , HR at Year 10 = 0
Pattern: risk-increasing effect weakens
Interpretation: Higher debt_ratio is associated with increased bankruptcy risk, but this effect diminishes over time
• KEY FACTOR: Stock Price
Initial HR = 2.55 , HR at Year 10 = 0.09
Pattern: risk-increasing effect weakens
Interpretation: Higher Stock Price is associated with increased bankruptcy risk, but this effect diminishes over time
• SECTOR RECOMMENDATION: Companies in Sector 30 should focus on maintaining strong LTMTA to protect against bankruptcy risk.
Key Financial Risk Factors by Industry Sector - Acquisition Model:
Industry Sector 20 :
• KEY FACTOR: wc_ratio
Initial HR = 0.51 , HR at Year 10 = 0.63
Pattern: risk-decreasing effect weakens
Interpretation: Higher wc_ratio is associated with decreased acquisition risk, but this effect diminishes over time
• KEY FACTOR: asset_turnover
Initial HR = 1.04 , HR at Year 10 = 1.11
Pattern: risk-increasing effect strengthens
Interpretation: Higher asset_turnover is associated with increased acquisition risk, and this effect becomes stronger over time
• SECTOR RECOMMENDATION: Companies in Sector 20 looking to avoid acquisition should focus on strategically positioning their wc_ratio metrics.
Industry Sector 35 :
• KEY FACTOR: wc_ratio
Initial HR = 0.44 , HR at Year 10 = 0.77
Pattern: risk-decreasing effect weakens
Interpretation: Higher wc_ratio is associated with decreased acquisition risk, but this effect diminishes over time
• KEY FACTOR: asset_turnover
Initial HR = 0.98 , HR at Year 10 = 1.03
Pattern: risk-decreasing effect weakens
Interpretation: Higher asset_turnover is associated with decreased acquisition risk, but this effect diminishes over time
• SECTOR RECOMMENDATION: Companies in Sector 35 looking to avoid acquisition should focus on strategically positioning their wc_ratio metrics.
Industry Sector 45 :
• KEY FACTOR: wc_ratio
Initial HR = 0.44 , HR at Year 10 = 0.7
Pattern: risk-decreasing effect weakens
Interpretation: Higher wc_ratio is associated with decreased acquisition risk, but this effect diminishes over time
• KEY FACTOR: asset_turnover
Initial HR = 0.59 , HR at Year 10 = 0.8
Pattern: risk-decreasing effect weakens
Interpretation: Higher asset_turnover is associated with decreased acquisition risk, but this effect diminishes over time
• SECTOR RECOMMENDATION: Companies in Sector 45 looking to avoid acquisition should focus on strategically positioning their wc_ratio metrics.
Industry Sector 25 :
• KEY FACTOR: asset_turnover
Initial HR = 0.81 , HR at Year 10 = 0.86
Pattern: risk-decreasing effect weakens
Interpretation: Higher asset_turnover is associated with decreased acquisition risk, but this effect diminishes over time
• KEY FACTOR: wc_ratio
Initial HR = 0.55 , HR at Year 10 = 0.87
Pattern: risk-decreasing effect weakens
Interpretation: Higher wc_ratio is associated with decreased acquisition risk, but this effect diminishes over time
• SECTOR RECOMMENDATION: Companies in Sector 25 looking to avoid acquisition should focus on strategically positioning their asset_turnover metrics.
Industry Sector 55 :
• KEY FACTOR: wc_ratio
Initial HR = 0.82 , HR at Year 10 = 856.01
Pattern: risk-decreasing effect weakens
Interpretation: Higher wc_ratio is associated with decreased acquisition risk, but this effect diminishes over time
• KEY FACTOR: asset_turnover
Initial HR = 0.22 , HR at Year 10 = 0.47
Pattern: risk-decreasing effect weakens
Interpretation: Higher asset_turnover is associated with decreased acquisition risk, but this effect diminishes over time
• SECTOR RECOMMENDATION: Companies in Sector 55 looking to avoid acquisition should focus on strategically positioning their wc_ratio metrics.
Industry Sector 15 :
• KEY FACTOR: wc_ratio
Initial HR = 1.68 , HR at Year 10 = 1.75
Pattern: risk-increasing effect strengthens
Interpretation: Higher wc_ratio is associated with increased acquisition risk, and this effect becomes stronger over time
• KEY FACTOR: asset_turnover
Initial HR = 1.4 , HR at Year 10 = 1.31
Pattern: risk-increasing effect weakens
Interpretation: Higher asset_turnover is associated with increased acquisition risk, but this effect diminishes over time
• SECTOR RECOMMENDATION: Companies in Sector 15 looking to avoid acquisition should focus on managing their wc_ratio levels.
Industry Sector 50 :
• KEY FACTOR: wc_ratio
Initial HR = 0.54 , HR at Year 10 = 0.66
Pattern: risk-decreasing effect weakens
Interpretation: Higher wc_ratio is associated with decreased acquisition risk, but this effect diminishes over time
• KEY FACTOR: asset_turnover
Initial HR = 0.94 , HR at Year 10 = 1.06
Pattern: risk-decreasing effect weakens
Interpretation: Higher asset_turnover is associated with decreased acquisition risk, but this effect diminishes over time
• SECTOR RECOMMENDATION: Companies in Sector 50 looking to avoid acquisition should focus on strategically positioning their wc_ratio metrics.
Industry Sector 10 :
• KEY FACTOR: wc_ratio
Initial HR = 1.11 , HR at Year 10 = 0.53
Pattern: risk-increasing effect weakens
Interpretation: Higher wc_ratio is associated with increased acquisition risk, but this effect diminishes over time
• KEY FACTOR: asset_turnover
Initial HR = 0.64 , HR at Year 10 = 0.89
Pattern: risk-decreasing effect weakens
Interpretation: Higher asset_turnover is associated with decreased acquisition risk, but this effect diminishes over time
• SECTOR RECOMMENDATION: Companies in Sector 10 looking to avoid acquisition should focus on managing their wc_ratio levels.
Industry Sector 30 :
• KEY FACTOR: wc_ratio
Initial HR = 1.17 , HR at Year 10 = 0.88
Pattern: risk-increasing effect weakens
Interpretation: Higher wc_ratio is associated with increased acquisition risk, but this effect diminishes over time
• KEY FACTOR: asset_turnover
Initial HR = 0.83 , HR at Year 10 = 0.88
Pattern: risk-decreasing effect weakens
Interpretation: Higher asset_turnover is associated with decreased acquisition risk, but this effect diminishes over time
• SECTOR RECOMMENDATION: Companies in Sector 30 looking to avoid acquisition should focus on managing their wc_ratio levels.
Industry Sector 60 :
• KEY FACTOR: asset_turnover
Initial HR = 7.13 , HR at Year 10 = 0
Pattern: risk-increasing effect weakens
Interpretation: Higher asset_turnover is associated with increased acquisition risk, but this effect diminishes over time
• KEY FACTOR: wc_ratio
Initial HR = 0 , HR at Year 10 = 0
Pattern: risk-decreasing effect weakens
Interpretation: Higher wc_ratio is associated with decreased acquisition risk, but this effect diminishes over time
• SECTOR RECOMMENDATION: Companies in Sector 60 looking to avoid acquisition should focus on managing their asset_turnover levels.
CURE MODELS!
This part is explorative into the application of cure models to the bankruptcy and acquisition data. Cure models are used to analyze survival data where a proportion of subjects are “cured” or immune to the event of interest. In this case, we will explore the use of cure models to understand the long-term survival of companies in terms of bankruptcy and acquisition risks.
#-------------------------------------------------------------
# STEP 1: Load Required Packages for Cure Models
#-------------------------------------------------------------
# Required packages for cure models
required_packages <- c(
"smcure", "flexsurvcure", "survival", "dplyr", "ggplot2", "survminer"
)
# Install missing packages
missing_packages <- required_packages[!required_packages %in% installed.packages()[,"Package"]]
if(length(missing_packages) > 0) {
install.packages(missing_packages)
}
# Load packages
suppressPackageStartupMessages({
library(smcure) # For semi-parametric mixture cure models
library(flexsurvcure) # For parametric mixture cure models
library(survival) # For survival models
library(dplyr) # For data manipulation
library(ggplot2) # For data visualization
library(survminer) # For survival analysis visualizations
})
#-------------------------------------------------------------
# STEP 1: Load Required Packages for Cure Models
#-------------------------------------------------------------
# Required packages for cure models
required_packages <- c(
"smcure", "flexsurvcure", "survival", "dplyr", "ggplot2", "survminer"
)
# Install missing packages
missing_packages <- required_packages[!required_packages %in% installed.packages()[,"Package"]]
if(length(missing_packages) > 0) {
install.packages(missing_packages)
}
# Load packages
suppressPackageStartupMessages({
library(smcure) # For semi-parametric mixture cure models
library(flexsurvcure) # For parametric mixture cure models
library(survival) # For survival models
library(dplyr) # For data manipulation
library(ggplot2) # For data visualization
library(survminer) # For survival analysis visualizations
})
#-------------------------------------------------------------
# STEP 2: Data Preparation for Cure Models
#-------------------------------------------------------------
# Cure models require one row per subject, so we'll use the last observation for each company
data_cure <- data %>%
group_by(cusip) %>%
slice_max(tstop) %>%
ungroup()
# Check the data structure
cat("Data dimensions for cure model analysis:", dim(data_cure), "\n")
Data dimensions for cure model analysis: 5038 43
cat("Event frequencies:\n")
Event frequencies:
print(table(data_cure$event_type))
0 1 2
2708 176 2154
print(table(data_cure$bankruptcy))
0 1
4862 176
print(table(data_cure$acquisition))
0 1
2884 2154
# Create separate datasets for bankruptcy and acquisition
data_bankruptcy <- data_cure
data_acquisition <- data_cure
# Note: 'smcure' requires time > 0, event indicator (0/1), and covariates
# Check for zero or negative times
cat("Min time to event:", min(data_cure$tstop), "\n")
Min time to event: 0.9965777
# Verify that key variables exist in the dataset
cat("Checking for key financial variables...\n")
Checking for key financial variables...
key_financial <- c("LTMTA", "NIMTA", "CASHMTA", "PRICE", "RSIZE")
existing_vars <- intersect(key_financial, names(data_cure))
cat("Available key financial variables:", paste(existing_vars, collapse=", "), "\n")
Available key financial variables: LTMTA, NIMTA, CASHMTA, PRICE, RSIZE
# Define variables to use for cure models
bankruptcy_fin_vars <- intersect(c("LTMTA", "NIMTA", "CASHMTA", "PRICE"), names(data_cure))
acquisition_fin_vars <- intersect(c("RSIZE", "LTMTA", "PRICE"), names(data_cure))
macro_vars <- intersect(c("gdp_growth", "unemployement", "gdp_deflator"), names(data_cure))
cat("Variables to be used in bankruptcy cure model:",
paste(c(bankruptcy_fin_vars, macro_vars), collapse=", "), "\n")
Variables to be used in bankruptcy cure model: LTMTA, NIMTA, CASHMTA, PRICE, gdp_growth, unemployement, gdp_deflator
cat("Variables to be used in acquisition cure model:",
paste(c(acquisition_fin_vars, macro_vars), collapse=", "), "\n")
Variables to be used in acquisition cure model: RSIZE, LTMTA, PRICE, gdp_growth, unemployement, gdp_deflator
# No need for imputation since there are no missing values
cat("No missing values - imputation not needed.\n")
No missing values - imputation not needed.
# STEP 3: Exploratory Analysis for Cure Fraction
#-------------------------------------------------------------
# The survival curves we've seen already provide strong evidence of a cure fraction,
# especially for bankruptcy. Let's quantify this with Kaplan-Meier plateau estimates.
# Create Kaplan-Meier curves
km_bankruptcy <- survfit(Surv(tstop, bankruptcy) ~ 1, data = data_bankruptcy)
km_acquisition <- survfit(Surv(tstop, acquisition) ~ 1, data = data_acquisition)
# Plot the curves with emphasis on plateaus
par(mfrow = c(1, 2))
plot(km_bankruptcy, conf.int = TRUE, xlab = "Years", ylab = "Probability of No Bankruptcy",
main = "Bankruptcy-Free Survival with Potential Cure Fraction")
abline(h = tail(km_bankruptcy$surv, 1), col = "red", lty = 2)
text(max(km_bankruptcy$time) * 0.7, tail(km_bankruptcy$surv, 1) + 0.02,
paste0("Estimated cure fraction: ", round(tail(km_bankruptcy$surv, 1) * 100, 1), "%"),
col = "red")
plot(km_acquisition, conf.int = TRUE, xlab = "Years", ylab = "Probability of No Acquisition",
main = "Acquisition-Free Survival with Potential Cure Fraction")
abline(h = tail(km_acquisition$surv, 1), col = "blue", lty = 2)
text(max(km_acquisition$time) * 0.7, tail(km_acquisition$surv, 1) + 0.02,
paste0("Estimated cure fraction: ", round(tail(km_acquisition$surv, 1) * 100, 1), "%"),
col = "blue")
par(mfrow = c(1, 1))
# Quantify the plateau (estimated cure fraction)
bankruptcy_plateau <- tail(km_bankruptcy$surv, 1)
acquisition_plateau <- tail(km_acquisition$surv, 1)
cat("\nEstimated cure fractions from KM curves:\n")
Estimated cure fractions from KM curves:
cat("Bankruptcy: Approximately", round(bankruptcy_plateau * 100, 1), "% of companies may never go bankrupt\n")
Bankruptcy: Approximately 90.2 % of companies may never go bankrupt
cat("Acquisition: Approximately", round(acquisition_plateau * 100, 1), "% of companies may never be acquired\n")
Acquisition: Approximately 28.1 % of companies may never be acquired
# Stratified analysis by industry
km_bankruptcy_sector <- survfit(Surv(tstop, bankruptcy) ~ gsector, data = data_bankruptcy)
km_acquisition_sector <- survfit(Surv(tstop, acquisition) ~ gsector, data = data_acquisition)
# Function to safely extract the last survival probability for each stratum
extract_last_surv_prob <- function(km_fit) {
# Get summary
km_sum <- summary(km_fit)
# Extract strata information
strata_info <- km_sum$strata
if (is.null(strata_info)) return(tail(km_sum$surv, 1))
# Initialize result vector
plateau_values <- numeric(length(strata_info))
names(plateau_values) <- names(strata_info)
# Need to manually extract the last survival probability for each stratum
strata_names <- names(strata_info)
# Loop through each stratum
for (i in seq_along(strata_names)) {
# Get subset of data for this stratum
strata_indices <- which(km_sum$strata == strata_names[i])
# Extract last survival probability if available
if (length(strata_indices) > 0) {
plateau_values[i] <- km_sum$surv[max(strata_indices)]
} else {
plateau_values[i] <- NA
}
}
return(plateau_values)
}
# Get plateau estimates
bk_plateaus_by_sector <- extract_last_surv_prob(km_bankruptcy_sector)
acq_plateaus_by_sector <- extract_last_surv_prob(km_acquisition_sector)