Discussions
The Bayesian Markov switching panel data model
I would like if this code is coherent and provide correct plots?
Load necessary libraries
library(MCMCpack)
library(MASS)
library(ggplot2)
library(dplyr)
library(tidyr)
library(imputeTS)
Load the user data
data <- read.csv("C:/Users/TBS/Documents/Data-Was.csv")
Define output directory
output_dir <- "C:/Users/TBS/Documents/Output/"
if (!dir.exists(output_dir)) {
dir.create(output_dir, recursive = TRUE)
}
Prepare country-specific data
countries <- unique(data$Country)
N <- length(countries) # Number of units (countries)
time_column <- "Date"
T <- length(unique(data[[time_column]])) # Number of time points
M <- 3 # Variables: TempAnom, CPI, GDP
K <- 2 # Two regimes
n_iter <- 5000 # Number of iterations for Gibbs sampler
burnin <- 1000 # Burn-in period for Gibbs sampling
Initialize matrices for TempAnom, CPI, and GDP
TempAnom <- matrix(NA, nrow = N, ncol = T)
CPI <- matrix(NA, nrow = N, ncol = T)
GDP <- matrix(NA, nrow = N, ncol = T)
Fill matrices with data for each country
for (i in 1:N) {
country_data <- data %>%
filter(Country == countries[i]) %>%
arrange(!!sym(time_column))
if (nrow(country_data) != T) {
stop(paste("Data for country", countries[i], "has inconsistent time periods."))
}
Replace non-positive values with a small positive value
country_data$TempAnom <- ifelse(country_data$TempAnom <= 0, 0.01, country_data$TempAnom)
country_data$CPI <- ifelse(country_data$CPI <= 0, 0.01, country_data$CPI)
country_data$GDP <- ifelse(country_data$GDP <= 0, 0.01, country_data$GDP)
Logarithmic transformation
TempAnom[i, ] <- log(na_interpolation(country_data$TempAnom))
CPI[i, ] <- log(na_interpolation(country_data$CPI))
GDP[i, ] <- log(na_interpolation(country_data$GDP))
}
Create a 3-dimensional array for data
Y <- array(NA, dim = c(N, T, M))
Y[, , 1] <- TempAnom
Y[, , 2] <- CPI
Y[, , 3] <- GDP
FFBS function
ffbs <- function(log_probs, P, T) {
K <- ncol(P)
S <- numeric(T)
alpha <- matrix(0, nrow = T, ncol = K)
alpha[1, ] <- log_probs[1, ] - log(sum(exp(log_probs[1, ])))
for (t in 2:T) {
for (k in 1:K) {
alpha[t, k] <- log_probs[t, k] + log(sum(exp(alpha[t-1, ] + log(P[, k]))))
}
}
S[T] <- sample(1:K, 1, prob = exp(alpha[T, ]))
for (t in (T-1):1) {
trans_probs <- exp(alpha[t, ] + log(P[, S[t+1]]))
S[t] <- sample(1:K, 1, prob = trans_probs / sum(trans_probs))
}
return(S)
}
Gibbs sampler function (updated with corrections)
gibbs_sampler_block <- function(Y, N, T, M, K, iterations, burnin) {
beta <- array(0, dim = c(iterations, N, K, M + 1)) # Include intercept term
Sigma <- array(0, dim = c(iterations, N, K, M + 1, M + 1)) # Covariance matrices
alpha <- array(0, dim = c(N, K, K, 2)) # Transition parameters
P <- array(0, dim = c(N, K, K)) # Transition probability matrix
for (iter in 2:iterations) {
for (i in 1:N) { # Loop over countries
country_data <- Y[i, , ]
for (k in 1:K) { # Loop over regimes
# Design matrix with intercept
X_ik <- cbind(1, country_data[, 1:M])
y_ik <- country_data[, k]
# Posterior for beta
XtX <- t(X_ik) %*% X_ik + diag(1e-3, M + 1) # Regularization
XtY <- t(X_ik) %*% y_ik
beta_mean <- solve(XtX) %*% XtY
beta_var <- solve(XtX)
beta[iter, i, k, ] <- mvrnorm(1, beta_mean, beta_var)
# Residuals as a matrix
residuals <- y_ik - X_ik %*% beta[iter, i, k, ]
residuals <- matrix(residuals, nrow = T, ncol = 1) # Ensure residuals are a T x 1 matrix
# Update covariance matrix (Sigma)
S <- (t(X_ik) %*% diag(residuals[, 1]^2) %*% X_ik) / T + diag(0.001, M + 1)
Sigma[iter, i, k, , ] <- riwish(T + M, S)
}
# Transition probabilities with centered parametrization
for (l in 1:K) { # Previous state
denom <- 0
for (k in 1:K) { # Current state
if (k != K) { # Reference state
Vt <- apply(country_data, 2, mean) # Average over time
ci <- mean(Vt) # Threshold parameter
log_prob <- sum((Vt - ci) * alpha[i, k, l, ])
P[i, k, l] <- exp(log_prob) # Numerator
denom <- denom + exp(log_prob)
} else {
P[i, k, l] <- 1 # Reference state
denom <- denom + 1
}
}
# Normalize probabilities
for (k in 1:K) {
P[i, k, l] <- P[i, k, l] / denom
}
}
}
}
return(list(beta = beta, Sigma = Sigma, P = P, alpha = alpha))
}
Run the Gibbs sampler
posterior_samples <- gibbs_sampler_block(Y, N, T, M, K, n_iter, burnin)
Extract posterior samples
beta_samples <- posterior_samples$beta
Sigma_samples <- posterior_samples$Sigma
P_samples <- posterior_samples$P
alpha_samples <- posterior_samples$alpha
Plotting the results
beta_df <- data.frame()
sigma_df <- data.frame()
for (i in 1:N) {
country_name <- countries[i]
for (k in 1:K) {
for (iter in (burnin + 1):n_iter) {
beta_df <- rbind(beta_df, data.frame(
country = country_name,
Regime = paste("Regime", k),
Variable = "TempAnom-CPI",
Intercept = beta_samples[iter, i, k, 2]
))
beta_df <- rbind(beta_df, data.frame(
country = country_name,
Regime = paste("Regime", k),
Variable = "TempAnom-GDP",
Intercept = beta_samples[iter, i, k, 3]
))
sigma_df <- rbind(sigma_df, data.frame(
country = country_name,
Regime = paste("Regime", k),
Variable = "TempAnom-CPI",
Volatility = sqrt(Sigma_samples[iter, i, k, 2, 2])
))
sigma_df <- rbind(sigma_df, data.frame(
country = country_name,
Regime = paste("Regime", k),
Variable = "TempAnom-GDP",
Volatility = sqrt(Sigma_samples[iter, i, k, 3, 3])
))
}
}
}
Save plots for each country
for (country in countries) {
beta_data <- beta_df %>% filter(country == country)
sigma_data <- sigma_df %>% filter(country == country)
interceptplot <- ggplot(beta_data, aes(x = Intercept, color = Regime)) +
geom_density(adjust = 1.5, alpha = 0.5) +
facet_wrap(~Variable, scales = "free") +
labs(title = paste("Intercepts for", country), x = "Intercept", y = "Density") +
theme_minimal()
ggsave(paste0(output_dir, "Intercepts", country, ".png"), intercept_plot, width = 10, height = 5)
volatilityplot <- ggplot(sigma_data, aes(x = Volatility, color = Regime)) +
geom_density(adjust = 1.5, alpha = 0.5) +
facet_wrap(~Variable, scales = "free") +
labs(title = paste("Volatilities for", country), x = "Volatility", y = "Density") +
theme_minimal()
ggsave(paste0(output_dir, "Volatilities", country, ".png"), volatility_plot, width = 10, height = 5)
}