In nelson16silva/wavcoreinf: Estimation and Evaluation of Wavelet Core Inflation Measures

knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>"
)
getwd()

library(wavcoreinf)
library(dplyr)
library(tidyr)
library(ggplot2)
library(tibble)
library(purrr)
library(rlang)
library(lubridate)
library(forecast)
library(ellipsis)

The main goal of this vignette is to construct an example showing how a wavelet-based core inflation measure can be obtained from the wavcoreinf package. Then, this wavelet-based core inflation measure is compared with other tranditional measures. Data is the same as in the database coreinf_br. This database contains the headline inflation and core inflation measures of the Brazilian economy. The example is based on empirical Bayes thresholding on the levels of a wavelet transform method that is available in the R package EbayesThresh. Measures based on other methods can be constructed in the same way.

Data: Brazilian Headline Inflation and Core Inflation

Getting data

for (i in 1:200000) {
tryCatch(
  error = function(cnd) cnd,
  inf <- getsgs(x, n)
)
}
inf

n <- c(433, 11427, 16121, 27838, 27839, 11426, 4466, 16122)
x <- c("ipca", "ipcams", "ipcama", "ipcaex0", "ipcaex1", "ipcadp", "ipcaex2", "ipcaex3")
# inf <- getsgs(x, n)

Creating individual time series from 2006-07-01 to 2019-08-01

coreinf_br2 <- filter(coreinf_br, date >= "2006-07-01")
date <- coreinf_br2[["date"]]
ts_start <- c(year(date[1]), month(date[1]))
for(i in seq_along(x)) {
  assign(x[[i]], ts(coreinf_br2[[i + 1]], start = ts_start, freq = 12))
}

Wavelet Core Inflation

lags

pq <- lags(2, 1)

Setting wavelet parameters

ebthr_xform <- list(wt = c("dwt", "modwt"))

ebthr_wt <- list(
  wf = c("haar", "la8"),
  n.levels = 3:4
)

ebthr_ebwav <- list(
  vscale = c("level", "independet"),
  a = 3.83,
  prior = c("laplace", "cauchy")
)

ebthr_args <- wav_args_ebthr(ebthr_xform, ebthr_wt, ebthr_ebwav)

Determining prior "a" and mutating in ebthr_args$args_tbl

a <- ebthr_args$args_tbl %>%
  dplyr::select(-a) %>%
  purrr::pmap_dbl(~ purrr::possibly(prior_a, NULL)(
    x = ipca, h = 3, k = 15, lags = pq,
    interval = c(2, 4),
    tol = 0.4,
    wtfun = ..1,
    wtfunlist = list(..2, ..3),
    vscale = ..4, prior = ..5))

ebthr_args$args_tbl <- ebthr_args$args_tbl %>%
  mutate(a = .env$a)

Estimates wavelet core inflation and inserts a date column

ebthr_smooth <- wav_smooth(ipca, ebthr_args)

ebthr_table <- wcore_table(ebthr_smooth, ipca)

Statistics for Evaluation of the wavelet core inflation, h = 3 and k = 15 only for faster computation. More realistic h and k could be 12 and 24, respectively.

ebthr_error_mean <- error_wave_summary(3, x = ebthr_args, y = ipca, lags = pq, k = 15, RMSE = TRUE)

ebthr_summary <- wcore_summary_fcast(ipca, ebthr_table, ebthr_error_mean)

The best wavelet core inflation

ebthr_best <-  ebthr_summary %>% 
  wcore_summary_best(d = c(1, 1, 1, 1, 2))

A data frame with the best core inflation

ebthr_best_median <- wcore_best_median(ebthr_best)

Time series of the most appropriate wavelet core inflation

bayes2_ts <- ts(ebthr_best_median, start = ts_start, freq = 12)

Analysis

Tibble with headline inflation, traditional and wavelet core inflation

inf <- tibble(
  date = time(ipca), ipca,
  `IPCA-MS` = ipcams,
  `IPCA-EX0` = ipcaex0,
  `IPCA-EX1` = ipcaex1,
  `IPCA-DP` = ipcadp,
  `IPCA-EX2` = ipcaex2,
  `IPCA-EX3` = ipcaex3,
#  `IPCA-UNI` = uni_ts[, 2],
#  `IPCA-MIN` = min_ts[, 2],
#  `IPCA-SURE` = sure_ts[, 2],
#  `IPCA-CV` = cv_ts[, 2],
#  `IPCA-BAYES1` = bayes1_ts[, 2],
  `IPCA-BAYES2` = bayes2_ts[, 2]
)

inf %>%
  gather(-1:-2, key = "measure", value = "core") %>%
  ggplot(aes(x = date)) +
  geom_line(aes(y = core, linetype = "Core")) +
  facet_wrap(~measure, nrow = 4) +
  geom_line(aes(y = ipca, linetype = "Headline")) +
  labs(x = "", y = "%a.m", linetype = "") +
  theme(legend.position = c(.8, .1)) + # legend.position = "bottom") +
  scale_linetype_manual(values = c(Core = "solid", Headline = "dashed"))   

Descriptive statistics for core inflation measures

inf %>%
  gather(ipca:`IPCA-BAYES2`, key = "inf_core", value = "value") %>%
  group_by(inf_core) %>%
  summarise(
    mean = mean(value, na.rm = TRUE),
    min = min(value),
    max = max(value),
    sd = sd(value),
    cv = sd / mean,
    tmean = t.test(value, ipca)$p.value
  ) 

n-period centered moving average

mavc_order <- c(13, 25, 37)
names(mavc_order) <- paste0("mavc", mavc_order)

df_mavc <- purrr::map_df(mavc_order, ~mavc(x = ipca, k = .))

df_inf_core <- inf %>%
  mutate(IPCA = ipca) %>%
  dplyr::select(-c(date, ipca))

rmse_mae_tbl <- rmse_mae(df_inf_core, df_mavc)

rmse_mae_tbl %>% 
  add_column(a = rownames(rmse_mae_tbl), .before = "rmse") %>%
  separate(a, into = c("core", "ma", "stat" ), sep = "_") %>% 
  dplyr::select(-stat) %>% 
  gather(rmse, mae, key = stat, value = value) %>% 
  ggplot(aes(x = ma, y = Reduce(c, value))) +
  geom_point(aes(color = stat)) +
  scale_x_discrete(labels = c(13, 25, 37)) + 
  scale_color_discrete(labels = c("MAD", "RMSE")) +
  facet_wrap(~core) + 
  labs(color = "Statistic",
       y = "RMSE, MAD",
       x = "Months used in n-period centered moving averag") +
  theme(legend.position = c(.85, .15))

No-bias

df_inf_core %>% 
  dplyr::select(-IPCA) %>% 
  map_df(~ no_bias(ipca, .)) %>% 
  add_column(core = names(df_inf_core)[-8]) %>% 
  gather(c("a", "b", `Teste-F`, "R2" ), key = "stats", value = "value") %>% 
  ggplot() + 
  geom_point(aes(x = core, y = value)) +
  facet_wrap(~ stats, scales = "free", nrow = 4)

Dynamic adjustment: headline inflation equation

df_inf_core %>% 
  dplyr::select(-IPCA) %>% 
  map_df(~ dyn_adj(., inf = ipca, H = 6, p = 3)) %>% 
  add_column(h = rep(1:6, times = 7), 
             var = rep(names(df_inf_core[-8]), each = 6)) %>% 
  gather(-h, - var, key = "stats", value = "value") %>%
  dplyr::filter(stats == "alpha") %>% 
  ggplot() + 
  geom_point(aes(x = h, y = value)) +
  facet_wrap(~var, nrow = 3) + 
  scale_x_continuous(breaks = seq(3, 24, by = 3)) + 
  labs(y = quote(lambda[h]))

Dynamic adjustment: core inflation equation

df_inf_core %>% 
  dplyr::select(-IPCA) %>% 
  map_df(~ dyn_adj(., core = ipca, H = 6, p = 3)) %>% 
  add_column(h = rep(1:6, times = 7),
             var = rep(names(df_inf_core[-8]), each = 6)) %>% 
  gather(-h, - var, key = "stats", value = "value") %>%
  dplyr::filter(stats == "val_p") %>% 
  ggplot() + 
  geom_point(aes(x = h, y = value)) +
  facet_wrap(~var, nrow = 3)+ 
  scale_x_continuous(breaks = seq(3, 24, by = 3)) + 
  labs(y = quote(paste("p_value (", lambda[h] ^ "*",")")))

Forecasting

pq <- lags(2, 2)

ipca_fcast <- map_dbl(1:6, ~ model_error_single(
  18, ipca, unique(pq[,1:2]), .x, RMSE = TRUE))

args_best <- as.list(ebthr_best[1,1:6])

args_smooth_wavelet <- list(
  thfun = "ebayesthresh.wavelet",
  wtfun = args_best[[1]],
  wtfunlist = args_best[2:3]
)

args_ebayesthresh <- args_best[4:6]

ipca_bayes2_fcast <- map_dbl(1:6, ~ rlang::exec(
  model_error_wave_single,
  k = 18, y = ipca, lags = pq, h = .x,
  RMSE = TRUE,
  !!!args_smooth_wavelet, !!!args_ebayesthresh
))

wave_core_fcast <- tibble(#ipca_uni_fcast,
                          #ipca_min_fcast,
                          #ipca_bayes1_fcast,
                          #ipca_sure_fcast,
                          #ipca_cv_fcast,
                          ipca_bayes2_fcast)

core_fcast <- inf %>% 
  dplyr::select(`IPCA-MS`, `IPCA-EX0`, `IPCA-EX1`, `IPCA-DP`, `IPCA-EX2`, `IPCA-EX3`) %>% 
  map_df(function(core) {
    map_dbl(1:6, ~ model_error(18, ipca, core, pq, .x, RMSE = TRUE))
  }
  )

core_fcast %>% 
  bind_cols(wave_core_fcast, ipca_fcast = ipca_fcast) %>% 
  mutate_all(funs(. / ipca_fcast)) 

nelson16silva/wavcoreinf documentation built on Feb. 17, 2025, 7:10 p.m.