README.md

In santoscs/niemd: Nucleo da Inflacao com Decomposicao de Modo Empirico (EMD)

niemd

Núcelo da Inflação como Decomposição de Modo Empírico (EMD)

Tutorial para reproduzir os resultados do artigo "Núcleo da Inflação no Brasil: uma medida usando a decomposição empírica de modo"

Requisitos técnicos

Caso não tenha ainda instalado:

1. Instale o pacote devtools do CRAN com o seguinte comando install.packages("devtools").

2. Programas auxiliares:

3. Windows: instale Rtools

4. Mac: Instale Xcode no Mac App Store
5. Linux: Instale várias bibliotecas de desenvolvimento (detalhes variam entre as diferentes distribuições de Linux).

Reproduzindo os resultados

Figura 2 - IPCA com as IMFs e o resíduo obtidos com CEEMDAN - 1995.1 a 2016.10.

library(niemd)
ipca <- ipca95[,"ipca"]
demd <- Rlibeemd::ceemdan(ipca, noise_strength = 0.4)
x <- cbind(ipca, demd)
colnames(x) <- c("IPCA", colnames(demd))
tsplot(x)

Tabela 1 – Medidas descritivas das IMFs e do resíduo para o IPCA de 1995.1 a 2016.5

n <- length(demd[,1])
ntml <- apply(demd, 2, function(x) length(Rlibeemd::extrema(x)$maxima[,1]))
pm <- n/ntml
vari <- apply(demd, 2, var)
varip <- (vari/var(ipca))*100
# tabela com os resultados
tab <- n2tab(cbind(pm, vari, varip), 2)
tab <- rbind(obs=c(rep("",1), n2tab(var(ipca), 2), ""),
             tab,
             soma=c(rep("",2), n2tab(sum(varip), 2)))
colnames(tab) <- c("Período Médio (mês)",
                   "Variância",
                   "variância como % da variância observada")
knitr::kable(tab)

Período Médio (mês) Variância variância como % da variância observada obs 0,23 IMF 1 3,05 0,03 13,72 IMF 2 4,85 0,00 1,75 IMF 3 6,72 0,02 8,79 IMF 4 11,39 0,02 9,10 IMF 5 23,82 0,01 5,20 IMF 6 43,67 0,09 38,10 IMF 7 87,33 0,01 5,05 Residual 131,00 0,02 7,92 soma 89,64

Figura 3 - Escolha das IMFs fora da tendência: evolução da média de ut como uma função de d.

# media das reconstrucoes parciais 
fc <- vector()
rp <- demd
for(i in 1:(length(demd[1,])-1)){
  rp[,i]<- apply(as.matrix(demd[,1:i]), 1, sum)
  fc[i] <- mean(rp[,i])
}

# teste t
rpt <- apply(rp, 2, function(x) t.test(x)$p.value)

library(ggplot2)
n <- length(demd[1,])
df <- data.frame(media=fc, rpt=n2tab(rpt[-n]), d=1:(n-1))
g <- ggplot(df, aes(y = media, x = d)) +
  geom_line(linetype="dashed", alpha=.6) +
  geom_point() + 
  geom_hline(yintercept=0) +
  scale_x_continuous(breaks=1:max(df$d)) +
  geom_text(aes(y=media+.5*mean(media), label=rpt, vjust=0), size=4.5, family="Times", position = "dodge") +
  theme_bw(base_size = 14)
g

Figura 4 – Tendência e ciclo extraídos da série IPCA com CEEMDAN, 1995.1 a 2016.10

core <- apply(as.matrix(demd[,-(1:5)]), 1, sum)
attributes(core) <- attributes(ipca)
u <- ipca - core
x <- cbind(tendencia=core, ciclo=u)
y <- cbind(ipca, NA)
tsplot(x, y)

## Don't know how to automatically pick scale for object of type yearmon. Defaulting to continuous.

Figura 5 – IPCA e as medidas de núcleo da inflação (% em 12 meses)

library(grid)
library(gridExtra)
x <- cbind(core, ipca95[,-1])
colnames(x) <- c("CORE-EMD", "IPCA-MAS", "IPCA-MA", "IPCA-EX", "IPCA-EX2", "IPCA-DP")
y <- ipca
p1 <- tsplot(acum(x[,1:3]), acum(y))
p2 <- tsplot(acum(x[,4:6]), acum(y))
grid.arrange(p1, p2, ncol = 2)

## Don't know how to automatically pick scale for object of type yearmon. Defaulting to continuous.
## Don't know how to automatically pick scale for object of type yearmon. Defaulting to continuous.

Tabela 2 – Testes ADF e KPSS para o IPCA e os núcleos - 1995.1 a 2016.5

x <- cbind(ipca, core, ipca95[,-1])
tab <- tab.stationary(acum(x))
knitr::kable(tab)

Variavel tendencia ADF.lag ADF KPSS ipca sim 14 -3,235* 0,194** core sim 8 -2,870 0,206** ipca95[, -1].ipca.mas sim 15 -3,001 0,271*** ipca95[, -1].ipca.ma sim 14 -2,474 0,538*** ipca95[, -1].ipca.ex sim 14 -2,933 0,199** ipca95[, -1].ipca.ex2 sim 14 -3,138* 0,195** ipca95[, -1].ipca.dp sim 14 -3,478** 0,157** diff.ipca nao 13 -4,448*** 0,314 diff.core nao 15 -2,886** 0,657** diff.ipca95[, -1].ipca.mas nao 13 -3,455** 0,326 diff.ipca95[, -1].ipca.ma nao 13 -4,309*** 0,066 diff.ipca95[, -1].ipca.ex nao 13 -3,986*** 0,161 diff.ipca95[, -1].ipca.ex2 nao 13 -4,231*** 0,592** diff.ipca95[, -1].ipca.dp nao 13 -4,040*** 0,441*

Tabela 3 – Critérios de avaliação dos núcleos da inflação

x <- cbind(core, ipca95[,-1])
tab <- tab.marques(y=acum(ipca), x=acum(x))
knitr::kable(tab)

nucleos ADF t.alpha t.gamma t.lambda F.thetas core -4,081*** 0,572 0,000 0,174 0,129 ipca95[, -1].ipca.mas -2,748* 0,226 0,096 0,397 0,000 ipca95[, -1].ipca.ma -4,031*** 0,006 0,001 0,039 0,044 ipca95[, -1].ipca.ex -1,688 0,306 0,346 0,249 0,001 ipca95[, -1].ipca.ex2 -3,185** 0,136 0,054 0,795 0,013 ipca95[, -1].ipca.dp -2,237 0,354 0,370 0,875 0,091

Figura 6 – IPCA e previsões fora da amostra usando as medidas de núcleo, 2012.11 a 2016.10.

# Previsao fora da amostra

cores <- x
cores <- acum(cores)
ipca12 <- acum(ipca)

library(zoo)

## 
## Attaching package: 'zoo'

## The following objects are masked from 'package:base':
## 
##     as.Date, as.Date.numeric

out12.mdd <- vector("list")
for(i in 1:ncol(cores)){
  out12.mdd[[i]] <- outsample.mdd(yh=ipca12, yt=ipca12, x=cores[ ,i], m=6, p=6, n=48, h=12)
}
out12.mdd[[i+1]] <- outsample.mdd(yh=ipca12, yt=ipca12, x=NULL, m=6, p=6, n=48, h=12)

# matriz de dados com as previsoes
x <-sapply(out12.mdd, function(x) x$fcast)
atr <- tsp(out12.mdd[[1]]$fcast)
x <- ts(x, start = atr[1], end = atr[2], frequency = atr[3])

# ipca em 12 meses no periodo fora da amostra
ipca12 <- window(acum(ipca), start=start(x), end=end(x))

colnames(x) <- c("core", colnames(ipca95[,-1]), "benchmark")
dados <- cbind(ipca12, x)

colnames(dados) <-c("IPCA", "CORE-EMD", "IPCA-MAS", "IPCA-MA", "IPCA-EX", "IPCA-EX2", "IPCA-DP", "IPCA-referencia")
tsplot(dados, facet = F)

## Don't know how to automatically pick scale for object of type yearmon. Defaulting to continuous.

Tabela 4 – Desempenho preditivo fora da amostra das medidas de núcleo para um horizonte de 12 meses à frente, 2012.11 a 2016.10.

dados <- cbind(ipca12, x)
tab1 <- tab.reqm(dados, obs = "ipca12", ref = "x.benchmark")
tab2 <- tab.enctest(dados, obs = "ipca12", ref = "x.benchmark")
tab <- cbind(tab1[,-3], c("",tab2[,3]))
knitr::kable(tab)

reqm eqmr x.benchmark 1,84 1,00 x.core 1,19 0,42 1,21 (0,00) x.ipca.mas 1,77 0,92 -0,92 (0,21) x.ipca.ma 2,85 2,38 0,42 (0,30) x.ipca.ex 2,98 2,62 -0,65 (0,06) x.ipca.ex2 1,63 0,78 1,01 (0,00) x.ipca.dp 1,87 1,02 -1,38 (0,19)

santoscs/niemd documentation built on May 29, 2019, 1:48 p.m.