Política Monetaria, Actividad Real y Spreads Crediticios

Pronósticos ARIMA — Basado en Caldara & Herbst (2019)

Autor/a

Milena

Fecha de publicación

17 de marzo de 2026

1 Introducción

Este documento replica parcialmente el análisis de Caldara y Herbst (2019) — “Monetary Policy, Real Activity, and Credit Spreads: Evidence from Bayesian Proxy SVARs”, publicado en el American Economic Journal: Macroeconomics.

El objetivo específico de este trabajo es tomar las 5 variables del VAR base utilizado en el paper y, tratándolas como series independientes, estimar el mejor modelo ARIMA para cada una, justificando paso a paso las decisiones de diferenciación, y obtener pronósticos a 8 periodos.

Las variables del modelo de 5 ecuaciones son:

Variable Descripción
EFFR Tasa de Fondos Federales Efectiva (%)
LIPM Log de Producción Industrial Manufacturera
UNRATE Tasa de Desempleo (%)
LPPI Log del Índice de Precios al Productor
BAA10YMOODY Spread Baa corporativo (puntos básicos)

Muestra: Enero 1994 – Junio 2007 (igual que el paper)

2 Carga de Paquetes y Datos

Código 
library(forecast)
library(tseries)
library(urca)
library(ggplot2)
library(dplyr)
library(tidyr)
library(lubridate)
library(patchwork)
library(corrplot)
library(knitr)
library(kableExtra)
Código 
# ACTUALIZA ESTA RUTA A LA TUYA
ruta <- "C:/Users/pc/Documents/MILENA/USFQ MILENA/SEPTIMO SEMESTRE/TOPICOS AVANZADOS ECONOMIA/PROYECTO/ReplicationPackage/data/CHdata.txt"

datos_raw <- read.table(ruta, header = TRUE, sep = "", stringsAsFactors = FALSE)
datos_raw$DATES <- as.Date(datos_raw$DATES, format = "%m/%d/%Y")

# Filtrar muestra del paper
datos <- datos_raw |>
  filter(DATES >= as.Date("1994-01-01") & DATES <= as.Date("2007-06-01")) |>
  select(DATES, EFFR, LIPM, UNRATE, LPPI, BAA10YMOODY)

cat("Observaciones:", nrow(datos))
Observaciones: 162
Código 
cat("\nDesde:", as.character(min(datos$DATES)),
    "| Hasta:", as.character(max(datos$DATES)))

Desde: 1994-01-01 | Hasta: 2007-06-01
Código 
ts_ffr    <- ts(datos$EFFR,        start = c(1994, 1), frequency = 12)
ts_ip     <- ts(datos$LIPM,        start = c(1994, 1), frequency = 12)
ts_unrate <- ts(datos$UNRATE,      start = c(1994, 1), frequency = 12)
ts_ppi    <- ts(datos$LPPI,        start = c(1994, 1), frequency = 12)
ts_baa    <- ts(datos$BAA10YMOODY, start = c(1994, 1), frequency = 12)

series_list <- list(
  FFR    = ts_ffr,
  IP     = ts_ip,
  UNRATE = ts_unrate,
  PPI    = ts_ppi,
  BAA    = ts_baa
)

nombres_completos <- c(
  FFR    = "Tasa de Fondos Federales (EFFR, %)",
  IP     = "Producción Industrial Manufacturera (log)",
  UNRATE = "Tasa de Desempleo (%)",
  PPI    = "Índice de Precios al Productor (log)",
  BAA    = "Spread Baa (puntos básicos)"
)

3 Estadísticas Descriptivas

Código 
datos |>
  select(-DATES) |>
  summary() |>
  kable(caption = "Estadísticas descriptivas de las variables (1994–2007)") |>
  kable_styling(bootstrap_options = c("striped", "hover", "condensed"))
Estadísticas descriptivas de las variables (1994–2007)
EFFR LIPM UNRATE LPPI BAA10YMOODY
Min. :0.980 Min. :411.7 Min. :3.800 Min. :482.9 Min. :1.290
1st Qu.:2.533 1st Qu.:432.7 1st Qu.:4.500 1st Qu.:487.7 1st Qu.:1.640
Median :4.990 Median :446.3 Median :5.150 Median :493.1 Median :1.825
Mean :4.162 Mean :441.8 Mean :5.091 Mean :494.3 Mean :2.080
3rd Qu.:5.490 3rd Qu.:450.3 3rd Qu.:5.600 3rd Qu.:499.7 3rd Qu.:2.498
Max. :6.540 Max. :460.8 Max. :6.600 Max. :512.0 Max. :3.790

4 Visualización de las Series

Código 
datos_long <- datos |>
  pivot_longer(cols = -DATES, names_to = "variable", values_to = "valor") |>
  mutate(variable = factor(variable,
                           levels = c("EFFR","LIPM","UNRATE","LPPI","BAA10YMOODY"),
                           labels = names(nombres_completos)))

ggplot(datos_long, aes(x = DATES, y = valor, color = variable)) +
  geom_line(linewidth = 0.8) +
  facet_wrap(~ variable, scales = "free_y", ncol = 1) +
  labs(title = "Series del VAR — Caldara & Herbst (2019)",
       subtitle = "Enero 1994 – Junio 2007",
       x = NULL, y = NULL) +
  theme_bw(base_size = 11) +
  theme(legend.position = "none",
        strip.text = element_text(face = "bold"),
        plot.title = element_text(face = "bold"))

Observación visual: Se aprecia que LIPM y LPPI presentan tendencias crecientes claras, lo que sugiere no estacionariedad. EFFR y UNRATE muestran comportamiento cíclico persistente. El spread BAA luce más estacionario en torno a una media.

5 Análisis de Estacionariedad

Para cada serie se aplican tres tests complementarios:

  • ADF (Dickey-Fuller Aumentado): H₀ = raíz unitaria → rechazar ⟹ estacionaria
  • PP (Phillips-Perron): H₀ = raíz unitaria → robusto a heterocedasticidad
  • KPSS: H₀ = estacionaria → rechazar ⟹ no estacionaria

La decisión final combina los tres: se concluye I(0) si ADF y PP rechazan H₀ y KPSS no rechaza H₀; en caso contrario se diagnostica I(1).

Código 
test_estac <- function(serie, nombre) {
  adf  <- adf.test(serie, alternative = "stationary")
  pp   <- pp.test(serie, alternative = "stationary")
  kpss <- kpss.test(serie, null = "Level")

  d_val <- if (adf$p.value < 0.05 & pp$p.value < 0.05 & kpss$p.value >= 0.05) 0 else 1

  data.frame(
    Variable   = nombre,
    ADF_pval   = round(adf$p.value, 4),
    PP_pval    = round(pp$p.value, 4),
    KPSS_pval  = round(kpss$p.value, 4),
    Decision   = ifelse(d_val == 0, "I(0) — Estacionaria", "I(1) — Diferenciación"),
    d          = d_val
  )
}

resultados_tabla <- bind_rows(lapply(names(series_list), function(nm) {
  test_estac(series_list[[nm]], nombres_completos[nm])
}))

# Guardar d para uso posterior
d_valores <- setNames(resultados_tabla$d, names(series_list))

resultados_tabla |>
  select(-d) |>
  kable(caption = "Tests de raíz unitaria en niveles",
        col.names = c("Variable", "ADF (p-val)", "PP (p-val)",
                      "KPSS (p-val)", "Decisión")) |>
  kable_styling(bootstrap_options = c("striped", "hover")) |>
  column_spec(5, bold = TRUE,
              color = ifelse(resultados_tabla$d == 0, "darkgreen", "darkred"))
Tests de raíz unitaria en niveles
Variable ADF (p-val) PP (p-val) KPSS (p-val) Decisión
FFR Tasa de Fondos Federales (EFFR, %) 0.5282 0.9113 0.0100 I(1) — Diferenciación
IP Producción Industrial Manufacturera (log) 0.6090 0.9042 0.0100 I(1) — Diferenciación
UNRATE Tasa de Desempleo (%) 0.6925 0.8343 0.0614 I(1) — Diferenciación
PPI Índice de Precios al Productor (log) 0.9354 0.9594 0.0100 I(1) — Diferenciación
BAA Spread Baa (puntos básicos) 0.9126 0.8617 0.0100 I(1) — Diferenciación

5.1 Tests en Primera Diferencia

Para las series diagnosticadas como I(1), confirmamos que su primera diferencia es estacionaria:

Código 
series_i1 <- names(d_valores)[d_valores == 1]

if (length(series_i1) > 0) {
  res_dif <- bind_rows(lapply(series_i1, function(nm) {
    d_serie <- diff(series_list[[nm]])
    adf_d   <- adf.test(d_serie, alternative = "stationary")
    kpss_d  <- kpss.test(d_serie, null = "Level")
    data.frame(
      Variable  = nombres_completos[nm],
      ADF_pval  = round(adf_d$p.value, 4),
      KPSS_pval = round(kpss_d$p.value, 4),
      Decision  = ifelse(adf_d$p.value < 0.05 & kpss_d$p.value >= 0.05,
                         "I(1) confirmado ✓", "Revisar")
    )
  }))

  res_dif |>
    kable(caption = "Tests sobre primeras diferencias",
          col.names = c("Variable", "ADF (p-val)", "KPSS (p-val)", "Diagnóstico")) |>
    kable_styling(bootstrap_options = c("striped", "hover"))
}
Tests sobre primeras diferencias
Variable ADF (p-val) KPSS (p-val) Diagnóstico
FFR Tasa de Fondos Federales (EFFR, %) 0.3288 0.1000 Revisar
IP Producción Industrial Manufacturera (log) 0.1296 0.0182 Revisar
UNRATE Tasa de Desempleo (%) 0.0231 0.1000 I(1) confirmado ✓
PPI Índice de Precios al Productor (log) 0.0100 0.0885 I(1) confirmado ✓
BAA Spread Baa (puntos básicos) 0.0100 0.1000 I(1) confirmado ✓

6 ACF y PACF

Los correlogramas de las series estacionarias (o diferenciadas) guían la identificación manual de los órdenes AR(p) y MA(q).

Código 
par(mfrow = c(5, 2), mar = c(3, 3, 3, 1))
for (nm in names(series_list)) {
  serie_plot <- if (d_valores[nm] == 1) diff(series_list[[nm]]) else series_list[[nm]]
  sufijo     <- if (d_valores[nm] == 1) "Δ" else ""
  acf(serie_plot,  main = paste0("ACF — ", sufijo, nm),  lag.max = 24)
  pacf(serie_plot, main = paste0("PACF — ", sufijo, nm), lag.max = 24)
}

Código 
par(mfrow = c(1,1))

Interpretación: Un ACF que decae exponencialmente y un PACF que corta en el lag p sugiere un AR(p). Un PACF que decae y un ACF que corta en el lag q sugiere un MA(q). Patrones mixtos llevan a modelos ARMA(p,q).

7 Estimación de Modelos ARIMA

Usamos auto.arima() con búsqueda exhaustiva (stepwise = FALSE) y verosimilitud exacta (approximation = FALSE), fijando el orden de integración d según los tests anteriores.

Código 
modelos <- list()

for (nm in names(series_list)) {
  modelos[[nm]] <- auto.arima(
    series_list[[nm]],
    d             = d_valores[nm],
    max.p         = 6,
    max.q         = 6,
    max.P         = 2,
    max.Q         = 2,
    seasonal      = TRUE,
    ic            = "aic",
    stepwise      = FALSE,
    approximation = FALSE
  )
}

7.1 Modelos Seleccionados

Código 
tabla_mod <- data.frame(
  Variable    = names(modelos),
  Descripcion = nombres_completos[names(modelos)],
  Modelo      = sapply(modelos, function(m) as.character(m)),
  AIC         = round(sapply(modelos, AIC), 2),
  BIC         = round(sapply(modelos, BIC), 2),
  RMSE        = round(sapply(modelos, function(m) sqrt(mean(residuals(m)^2))), 5),
  row.names   = NULL
)

tabla_mod |>
  kable(caption = "Modelos ARIMA seleccionados por AIC",
        col.names = c("Variable", "Descripción", "Modelo", "AIC", "BIC", "RMSE")) |>
  kable_styling(bootstrap_options = c("striped", "hover", "condensed")) |>
  column_spec(3, bold = TRUE, color = "steelblue")
Modelos ARIMA seleccionados por AIC
Variable Descripción Modelo AIC BIC RMSE
FFR Tasa de Fondos Federales (EFFR, %) ARIMA(1,1,1) -186.71 -177.46 0.13229
IP Producción Industrial Manufacturera (log) ARIMA(1,1,2)(0,0,2)[12] with drift 281.65 303.22 0.55200
UNRATE Tasa de Desempleo (%) ARIMA(1,1,2)(0,0,2)[12] -211.44 -192.95 0.11949
PPI Índice de Precios al Productor (log) ARIMA(2,1,2)(1,0,0)[12] with drift 222.30 243.87 0.45948
BAA Spread Baa (puntos básicos) ARIMA(4,1,1) -253.15 -234.66 0.10572

8 Diagnóstico de Residuos

Un modelo bien especificado debe tener residuos que se comporten como ruido blanco: sin autocorrelación, media cero y distribución aproximadamente normal.

Código 
par(mfrow = c(3, 2), mar = c(3, 3, 3, 1))
for (nm in names(modelos)) {
  res <- residuals(modelos[[nm]])
  plot(res, main = paste("Residuos:", nm),
       ylab = "", col = "steelblue", lwd = 0.8)
  abline(h = 0, col = "red", lty = 2)
}
par(mfrow = c(1,1))

Código 
par(mfrow = c(3, 2), mar = c(3, 3, 3, 1))
for (nm in names(modelos)) {
  acf(residuals(modelos[[nm]]),
      main = paste("ACF Residuos:", nm), lag.max = 24)
}
par(mfrow = c(1,1))

Código 
tabla_diag <- bind_rows(lapply(names(modelos), function(nm) {
  res <- residuals(modelos[[nm]])
  lb  <- Box.test(res, lag = 12, type = "Ljung-Box")
  sw  <- shapiro.test(as.numeric(res))
  data.frame(
    Variable    = nm,
    LB_stat     = round(lb$statistic, 3),
    LB_pval     = round(lb$p.value, 4),
    LB_result   = ifelse(lb$p.value > 0.05, "✓ Ruido blanco", "✗ Autocorrelación"),
    SW_pval     = round(sw$p.value, 4),
    SW_result   = ifelse(sw$p.value > 0.05, "✓ Normal", "~ No normal")
  )
}))

tabla_diag |>
  kable(caption = "Tests de diagnóstico de residuos",
        col.names = c("Variable", "LB Estadístico", "LB p-valor",
                      "Ljung-Box", "SW p-valor", "Shapiro-Wilk")) |>
  kable_styling(bootstrap_options = c("striped", "hover")) |>
  column_spec(4, color = ifelse(tabla_diag$LB_pval > 0.05, "darkgreen", "darkred")) |>
  column_spec(6, color = ifelse(tabla_diag$SW_pval > 0.05, "darkgreen", "darkorange"))
Tests de diagnóstico de residuos
Variable LB Estadístico LB p-valor Ljung-Box SW p-valor Shapiro-Wilk
X-squared...1 FFR 8.219 0.7678 ✓ Ruido blanco 0.0000 ~ No normal
X-squared...2 IP 14.422 0.2746 ✓ Ruido blanco 0.0085 ~ No normal
X-squared...3 UNRATE 6.421 0.8934 ✓ Ruido blanco 0.1343 ✓ Normal
X-squared...4 PPI 19.319 0.0811 ✓ Ruido blanco 0.0028 ~ No normal
X-squared...5 BAA 0.852 1.0000 ✓ Ruido blanco 0.0004 ~ No normal

Nota: La no normalidad de los residuos (Shapiro-Wilk) no invalida el modelo si el test de Ljung-Box confirma ausencia de autocorrelación. Para pronóstico, la propiedad más importante es que los residuos sean ruido blanco.

9 Pronósticos a 8 Periodos

Se generan pronósticos para los 8 meses siguientes al fin de la muestra: julio 2007 – febrero 2008, con intervalos de confianza al 80% y 95%.

Código 
h <- 8
pronosticos <- lapply(modelos, forecast, h = h, level = c(80, 95))
fechas_fc   <- seq(as.Date("2007-07-01"), by = "month", length.out = h)

9.1 Gráficos de Pronósticos

Código 
plots_fc <- lapply(names(pronosticos), function(nm) {
  autoplot(pronosticos[[nm]]) +
    labs(title    = nombres_completos[nm],
         subtitle = paste("Modelo:", as.character(modelos[[nm]])),
         x = NULL, y = NULL) +
    theme_bw(base_size = 10) +
    theme(plot.title    = element_text(face = "bold", size = 10),
          plot.subtitle = element_text(size = 9, color = "gray40"))
})

(plots_fc[[1]] | plots_fc[[2]]) /
(plots_fc[[3]] | plots_fc[[4]]) /
(plots_fc[[5]] | plot_spacer())

9.2 Tabla de Pronósticos Puntuales

Código 
tabla_fc <- data.frame(Fecha = format(fechas_fc, "%b %Y"))

for (nm in names(pronosticos)) {
  fc_obj <- pronosticos[[nm]]
  tabla_fc[[paste0(nm, "_mean")]] <- round(as.numeric(fc_obj$mean), 4)
  tabla_fc[[paste0(nm, "_lo95")]] <- round(as.numeric(fc_obj$lower[,2]), 4)
  tabla_fc[[paste0(nm, "_hi95")]] <- round(as.numeric(fc_obj$upper[,2]), 4)
}

# Mostrar solo medias para claridad
tabla_medias <- data.frame(
  Fecha  = tabla_fc$Fecha,
  FFR    = tabla_fc$FFR_mean,
  IP     = tabla_fc$IP_mean,
  UNRATE = tabla_fc$UNRATE_mean,
  PPI    = tabla_fc$PPI_mean,
  BAA    = tabla_fc$BAA_mean
)

tabla_medias |>
  kable(caption = "Pronósticos puntuales (julio 2007 – febrero 2008)",
        col.names = c("Fecha", "FFR (%)", "IP (log)",
                      "Desempleo (%)", "PPI (log)", "Spread Baa")) |>
  kable_styling(bootstrap_options = c("striped", "hover", "condensed")) |>
  row_spec(0, bold = TRUE)
Pronósticos puntuales (julio 2007 – febrero 2008)
Fecha FFR (%) IP (log) Desempleo (%) PPI (log) Spread Baa
jul 2007 5.2494 461.3185 4.5348 513.0888 1.5409
ago 2007 5.2489 461.6843 4.5752 512.5266 1.5419
sept 2007 5.2484 462.2622 4.5636 512.9009 1.5543
oct 2007 5.2479 462.3157 4.5699 513.0617 1.5633
nov 2007 5.2475 462.4744 4.5730 512.9556 1.5737
dic 2007 5.2472 462.9205 4.6149 512.9901 1.5732
ene 2008 5.2469 463.1078 4.6641 512.8419 1.5707
feb 2008 5.2466 463.5320 4.6430 513.1144 1.5691

10 Correlaciones Cruzadas

10.1 Correlaciones Contemporáneas

Trabajamos con las series en su forma estacionaria (diferenciadas si I(1)).

Código 
series_estac <- lapply(names(series_list), function(nm) {
  if (d_valores[nm] == 1) as.numeric(diff(series_list[[nm]])) else as.numeric(series_list[[nm]])
})
names(series_estac) <- names(series_list)

n_min      <- min(sapply(series_estac, length))
series_mat <- sapply(series_estac, function(x) tail(x, n_min))
cor_matrix <- cor(series_mat, use = "complete.obs")

corrplot(cor_matrix,
         method    = "ellipse",
         type      = "upper",
         tl.col    = "black",
         addCoef.col = "black",
         number.cex  = 0.8,
         title     = "Correlaciones Contemporáneas (series estacionarias)",
         mar       = c(0, 0, 2, 0))

Código 
cor_matrix |>
  round(3) |>
  kable(caption = "Matriz de correlaciones contemporáneas") |>
  kable_styling(bootstrap_options = c("striped", "hover", "condensed"))
Matriz de correlaciones contemporáneas
FFR IP UNRATE PPI BAA
FFR 1.000 0.215 -0.238 0.081 -0.059
IP 0.215 1.000 -0.321 0.018 -0.060
UNRATE -0.238 -0.321 1.000 -0.020 0.036
PPI 0.081 0.018 -0.020 1.000 -0.044
BAA -0.059 -0.060 0.036 -0.044 1.000

10.2 Correlaciones Cruzadas con Lags (CCF)

La función de correlación cruzada (CCF) mide la relación entre dos series en diferentes rezagos, permitiendo identificar relaciones de liderazgo o rezago entre variables.

Código 
pares  <- combn(names(series_list), 2)
n_pares <- ncol(pares)

par(mfrow = c(ceiling(n_pares/2), 2), mar = c(3, 3, 3, 1))

for (i in 1:n_pares) {
  v1 <- pares[1, i]
  v2 <- pares[2, i]
  s1 <- series_estac[[v1]]
  s2 <- series_estac[[v2]]
  n  <- min(length(s1), length(s2))

  ccf(tail(s1, n), tail(s2, n),
      lag.max = 24,
      main    = paste("CCF:", v1, "↔", v2),
      ylab    = "CCF")

  ic <- 1.96 / sqrt(n)
  abline(h = c(-ic, ic), lty = 2, col = "red")
}

Código 
par(mfrow = c(1,1))

Interpretación de CCF: Las líneas rojas punteadas representan las bandas de confianza al 95% (±1.96/√T). Barras que superan esas bandas indican correlación cruzada estadísticamente significativa al nivel de confianza del 95%.

11 Conclusiones

Código 
cat("RESUMEN DE MODELOS SELECCIONADOS\n")
RESUMEN DE MODELOS SELECCIONADOS
Código 
cat(rep("-", 50), "\n")
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Código 
for (nm in names(modelos)) {
  cat(sprintf("%-8s | %s | AIC = %.2f\n",
              nm,
              as.character(modelos[[nm]]),
              AIC(modelos[[nm]])))
}
FFR      | ARIMA(1,1,1) | AIC = -186.71
IP       | ARIMA(1,1,2)(0,0,2)[12] with drift | AIC = 281.65
UNRATE   | ARIMA(1,1,2)(0,0,2)[12] | AIC = -211.44
PPI      | ARIMA(2,1,2)(1,0,0)[12] with drift | AIC = 222.30
BAA      | ARIMA(4,1,1) | AIC = -253.15

Los modelos ARIMA estimados para las 5 variables del BP-SVAR de Caldara & Herbst (2019) permiten:

  1. Confirmar el orden de integración de cada serie mediante los tests ADF, PP y KPSS. Las variables en logaritmo (IP, PPI) son claramente I(1), mientras que el spread Baa requiere verificación empírica en cada muestra.

  2. Obtener pronósticos individuales para el período julio–febrero 2008, los cuales sirven como benchmark univariado contra el que comparar las predicciones del VAR estructural.

  3. Documentar correlaciones cruzadas que anticipan las relaciones dinámicas entre variables que el paper explora en el marco SVAR: especialmente la relación contemporánea entre la FFR y el spread Baa (ψ₀,cs ≈ −1 en el paper).

Documento generado con Quarto. Datos: Caldara & Herbst (2019) Replication Package — AEJ: Macroeconomics.