Algoritmos de Alisamiento Exponencial

Suavizado exponencial:

  • TĆ©cnica para suavizar datos de series de tiempo utilizando una función de ventana exponencial.

  • Difiere del promedio móvil simple, con el tiempo las funciones exponenciales asignan pesos exponencialmente decrecientes.

    • Los pesos mayores se asignan a los valores u observaciones recientes, mientras que los pesos menores se asignan a los valores u observaciones mĆ”s antiguos.
  • Entre muchas funciones de ventana, en el procesamiento de seƱales, la función de suavizado exponencial generalmente se aplica para suavizar datos donde actĆŗa como un filtro de paso bajo para eliminar el ruido de alta frecuencia.

Suaviamiento exponencial simple - SES (simple exponencial smoothing)

Este procedimiento es adecuado cuando los datos no tienen tendencia o patrón estacional. Los pesos de cada observación son determinados por un parÔmetro de suavizamiento \(\alpha\).

Para un conjunto de datos con \(T\) observaciones , calculamos el valor predicho \(\hat{y}_{t+1}\), el cual estarƔ basado en \(y_1\) a travƩs de \(y_t\) de la siguiente forma:

\[\hat{y}_{t+1}=\alpha y_t+\alpha(1-\alpha)y_{tāˆ’1}+...+\alpha(1āˆ’\alpha)^{tāˆ’1}y_1\]

Donde:

  • \(0< \alpha < 1\).

  • \(\alpha\) puede ser visto como una tasa de aprendizaje.

  • Valores cercanos a cero son considerados como aprendizaje lento ya que se da mĆ”s peso a información histórica

  • Valores cercanos a 1 son considerados como aprendizaje rĆ”pido porque el algoritmo da mĆ”s peso a las observaciones recientes.

library(tseries)
#library(FitAR)
library(urca)
library(highcharter)
library(readxl)
library(ggplot2)
library(TSstudio)
library(forecast)
library(car)
library(rio)
library(readxl)
IPC <- rio::import("https://github.com/Wilsonsr/Series-de-Tiempo/raw/main/bases/IPC%20(4).xlsx")

head(IPC)
##   Inflación mensual
## 1            0.0129
## 2            0.0230
## 3            0.0171
## 4            0.0100
## 5            0.0052
## 6           -0.0002
z2=ts(IPC, start = c(2000,1),frequency = 12)
z2
##          Jan     Feb     Mar     Apr     May     Jun     Jul     Aug     Sep
## 2000  0.0129  0.0230  0.0171  0.0100  0.0052 -0.0002 -0.0004  0.0032  0.0043
## 2001  0.0105  0.0189  0.0148  0.0115  0.0042  0.0004  0.0011  0.0026  0.0037
## 2002  0.0080  0.0126  0.0071  0.0092  0.0060  0.0043  0.0002  0.0009  0.0036
## 2003  0.0117  0.0111  0.0105  0.0115  0.0049 -0.0005 -0.0014  0.0031  0.0022
## 2004  0.0089  0.0120  0.0098  0.0046  0.0038  0.0060 -0.0003  0.0003  0.0030
## 2005  0.0082  0.0102  0.0077  0.0044  0.0041  0.0040  0.0005  0.0000  0.0043
## 2006  0.0054  0.0066  0.0070  0.0045  0.0033  0.0030  0.0041  0.0039  0.0029
## 2007  0.0077  0.0117  0.0121  0.0090  0.0030  0.0012  0.0017 -0.0013  0.0008
## 2008  0.0106  0.0151  0.0081  0.0071  0.0093  0.0086  0.0048  0.0019 -0.0019
## 2009  0.0059  0.0084  0.0050  0.0032  0.0001 -0.0006 -0.0004  0.0004 -0.0011
## 2010  0.0069  0.0083  0.0025  0.0046  0.0010  0.0011 -0.0004  0.0011 -0.0014
## 2011  0.0091  0.0060  0.0027  0.0012  0.0028  0.0032  0.0014 -0.0003  0.0031
## 2012  0.0073  0.0061  0.0012  0.0014  0.0030  0.0008 -0.0002  0.0004  0.0029
## 2013  0.0030  0.0044  0.0021  0.0025  0.0028  0.0023  0.0004  0.0008  0.0029
## 2014  0.0049  0.0063  0.0039  0.0046  0.0048  0.0009  0.0015  0.0020  0.0014
## 2015  0.0064  0.0115  0.0059  0.0054  0.0026  0.0010  0.0019  0.0048  0.0072
## 2016  0.0129  0.0128  0.0094  0.0050  0.0051  0.0048  0.0052 -0.0032 -0.0005
## 2017  0.0102  0.0101  0.0047  0.0047  0.0023  0.0011 -0.0005  0.0014  0.0004
## 2018  0.0063  0.0071  0.0024  0.0046  0.0025  0.0015 -0.0013  0.0012  0.0016
## 2019  0.0060  0.0057  0.0043  0.0050  0.0031  0.0027  0.0022  0.0009  0.0023
## 2020  0.0042  0.0067                                                        
##          Oct     Nov     Dec
## 2000  0.0015  0.0033  0.0046
## 2001  0.0019  0.0012  0.0034
## 2002  0.0056  0.0078  0.0027
## 2003  0.0006  0.0035  0.0061
## 2004 -0.0001  0.0028  0.0030
## 2005  0.0023  0.0011  0.0007
## 2006 -0.0014  0.0024  0.0023
## 2007  0.0001  0.0047  0.0049
## 2008  0.0035  0.0028  0.0044
## 2009 -0.0013 -0.0007  0.0008
## 2010 -0.0009  0.0019  0.0065
## 2011  0.0019  0.0014  0.0042
## 2012  0.0016 -0.0014  0.0009
## 2013 -0.0026 -0.0022  0.0026
## 2014  0.0016  0.0013  0.0027
## 2015  0.0068  0.0060  0.0062
## 2016 -0.0006  0.0011  0.0042
## 2017  0.0002  0.0018  0.0038
## 2018  0.0012  0.0012  0.0030
## 2019  0.0016  0.0010  0.0026
## 2020

Damos formato de serie de tiempo

z1=ts(IPC, start = c(2000,1), end=c(2018,12),frequency = 12)
length(z1)
## [1] 228
h1=auto.arima(z1)
hchart(forecast(h1,h=12))
v=as.vector(forecast(h1, h=12))
w=v$mean
#rmse(data_real, w)

Realizamos la grƔfica de los datos

ts_plot(z1, title = "IPC 2000-2018" , slider = T)
ts_decompose(z1)
ts_decompose(z1,type="multiplicative")
ts_seasonal(z1, type="all")
ts_heatmap(z1)
ts_surface(z1)

SES(Suavizado Exponencial Simple)

  • Datos que no tienen tendencia o patrón estacional.
library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## āœ” dplyr     1.1.2     āœ” readr     2.1.4
## āœ” forcats   1.0.0     āœ” stringr   1.5.0
## āœ” lubridate 1.9.2     āœ” tibble    3.2.1
## āœ” purrr     1.0.2     āœ” tidyr     1.3.0
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## āœ– dplyr::filter() masks stats::filter()
## āœ– dplyr::lag()    masks stats::lag()
## āœ– dplyr::recode() masks car::recode()
## āœ– purrr::some()   masks car::some()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
#library(fpp2)

El pronóstico del período \(t\) \((F_{t})\) serÔ igual al pronóstico del período anterior, es decir, del período \(t-1\) \((F_{t-1})\) mÔs alfa \((\alpha)\) por el error del período anterior \((A_{t-1}-F_{t-1})\)

ipc_ses <- ses(z1, alpha = .2,  h = 12)
autoplot(ipc_ses)

summary(ipc_ses)
## 
## Forecast method: Simple exponential smoothing
## 
## Model Information:
## Simple exponential smoothing 
## 
## Call:
##  ses(y = z1, h = 12, alpha = 0.2) 
## 
##   Smoothing parameters:
##     alpha = 0.2 
## 
##   Initial states:
##     l = 0.011 
## 
##   sigma:  0.0039
## 
##       AIC      AICc       BIC 
## -1291.502 -1291.448 -1284.643 
## 
## Error measures:
##                         ME        RMSE         MAE  MPE MAPE     MASE      ACF1
## Training set -0.0001984582 0.003865419 0.002975794 -Inf  Inf 1.237051 0.6173737
## 
## Forecasts:
##          Point Forecast        Lo 80       Hi 80        Lo 95       Hi 95
## Jan 2019    0.001937618 -0.003037987 0.006913222 -0.005671913 0.009547148
## Feb 2019    0.001937618 -0.003136523 0.007011759 -0.005822611 0.009697847
## Mar 2019    0.001937618 -0.003233182 0.007108418 -0.005970439 0.009845674
## Apr 2019    0.001937618 -0.003328067 0.007203303 -0.006115553 0.009990788
## May 2019    0.001937618 -0.003421273 0.007296508 -0.006258098 0.010133333
## Jun 2019    0.001937618 -0.003512884 0.007388119 -0.006398206 0.010273441
## Jul 2019    0.001937618 -0.003602981 0.007478216 -0.006535997 0.010411232
## Aug 2019    0.001937618 -0.003691636 0.007566872 -0.006671583 0.010546819
## Sep 2019    0.001937618 -0.003778917 0.007654152 -0.006805067 0.010680303
## Oct 2019    0.001937618 -0.003864885 0.007740120 -0.006936544 0.010811779
## Nov 2019    0.001937618 -0.003949597 0.007824832 -0.007066100 0.010941336
## Dec 2019    0.001937618 -0.004033108 0.007908343 -0.007193819 0.011069054
autoplot(ipc_ses) +
  autolayer(fitted(ipc_ses), series="Fitted") +
  xlab("Year")

ipc_ses
##          Point Forecast        Lo 80       Hi 80        Lo 95       Hi 95
## Jan 2019    0.001937618 -0.003037987 0.006913222 -0.005671913 0.009547148
## Feb 2019    0.001937618 -0.003136523 0.007011759 -0.005822611 0.009697847
## Mar 2019    0.001937618 -0.003233182 0.007108418 -0.005970439 0.009845674
## Apr 2019    0.001937618 -0.003328067 0.007203303 -0.006115553 0.009990788
## May 2019    0.001937618 -0.003421273 0.007296508 -0.006258098 0.010133333
## Jun 2019    0.001937618 -0.003512884 0.007388119 -0.006398206 0.010273441
## Jul 2019    0.001937618 -0.003602981 0.007478216 -0.006535997 0.010411232
## Aug 2019    0.001937618 -0.003691636 0.007566872 -0.006671583 0.010546819
## Sep 2019    0.001937618 -0.003778917 0.007654152 -0.006805067 0.010680303
## Oct 2019    0.001937618 -0.003864885 0.007740120 -0.006936544 0.010811779
## Nov 2019    0.001937618 -0.003949597 0.007824832 -0.007066100 0.010941336
## Dec 2019    0.001937618 -0.004033108 0.007908343 -0.007193819 0.011069054
length(z2)
## [1] 242
length(z1)
## [1] 228
test=z2[229:240]

ETS (Error tenndencia y estacionalidad)

  • El algoritmo ETS es especialmente Ćŗtil para conjuntos de datos con estacionalidad y otras suposiciones previas sobre los datos.

  • ETS calcula un promedio ponderado sobre todas las observaciones en el conjunto de datos de las series temporales de entrada como su predicción.

  • Las ponderaciones disminuyen exponencialmente con el tiempo, en lugar de las ponderaciones constantes en los mĆ©todos de promedio móvil simple.

  • Las ponderaciones dependen de un parĆ”metro constante, conocido como parĆ”metro de suavizamiento.

fit_ets_default <- ets(z1)
checkresiduals(fit_ets_default)

## 
##  Ljung-Box test
## 
## data:  Residuals from ETS(A,Ad,A)
## Q* = 59.913, df = 24, p-value = 6.57e-05
## 
## Model df: 0.   Total lags used: 24
mod2 <- forecast(fit_ets_default, 12, level = 95)
plot(mod2)

  • Veamos el ajuste entre los datos de la serie y el pronóstico del modelo en la siguiente representación grĆ”fica, usando la función fitted() que obtiene un ajuste con la data historica.
autoplot(mod2)+
  autolayer(fitted(mod2), series="Ajuste")

print(summary(mod2))
## 
## Forecast method: ETS(A,Ad,A)
## 
## Model Information:
## ETS(A,Ad,A) 
## 
## Call:
##  ets(y = z1) 
## 
##   Smoothing parameters:
##     alpha = 0.4864 
##     beta  = 1e-04 
##     gamma = 2e-04 
##     phi   = 0.9771 
## 
##   Initial states:
##     l = 0.0113 
##     b = -3e-04 
##     s = 2e-04 -0.0014 -0.0023 -0.0017 -0.0031 -0.0036
##            -0.0021 -5e-04 0.0015 0.0028 0.0062 0.004
## 
##   sigma:  0.0024
## 
##       AIC      AICc       BIC 
## -1495.301 -1492.029 -1433.573 
## 
## Error measures:
##                        ME        RMSE         MAE  MPE MAPE      MASE      ACF1
## Training set 4.010303e-05 0.002304734 0.001780198 -Inf  Inf 0.7400362 0.2217259
## 
## Forecasts:
##          Point Forecast         Lo 95       Hi 95
## Jan 2019   0.0069225819  2.226938e-03 0.011618225
## Feb 2019   0.0091664671  3.944585e-03 0.014388349
## Mar 2019   0.0057379159  3.798047e-05 0.011437851
## Apr 2019   0.0044307943 -1.710268e-03 0.010571856
## May 2019   0.0024238671 -4.128853e-03 0.008976587
## Jun 2019   0.0008133985 -6.126753e-03 0.007753550
## Jul 2019  -0.0006307583 -7.937967e-03 0.006676450
## Aug 2019  -0.0001912126 -7.848031e-03 0.007465606
## Sep 2019   0.0012354958 -6.755773e-03 0.009226765
## Oct 2019   0.0006180184 -7.694368e-03 0.008930405
## Nov 2019   0.0015067935 -7.114866e-03 0.010128453
## Dec 2019   0.0030864219 -5.833896e-03 0.012006739

Y podemos representar solo los resultados a través de un dataframe, asignando la ejecución del mismo a la variable pronóstico.

pronostico <- as.data.frame(mod2)
pronostico
##          Point Forecast         Lo 95       Hi 95
## Jan 2019   0.0069225819  2.226938e-03 0.011618225
## Feb 2019   0.0091664671  3.944585e-03 0.014388349
## Mar 2019   0.0057379159  3.798047e-05 0.011437851
## Apr 2019   0.0044307943 -1.710268e-03 0.010571856
## May 2019   0.0024238671 -4.128853e-03 0.008976587
## Jun 2019   0.0008133985 -6.126753e-03 0.007753550
## Jul 2019  -0.0006307583 -7.937967e-03 0.006676450
## Aug 2019  -0.0001912126 -7.848031e-03 0.007465606
## Sep 2019   0.0012354958 -6.755773e-03 0.009226765
## Oct 2019   0.0006180184 -7.694368e-03 0.008930405
## Nov 2019   0.0015067935 -7.114866e-03 0.010128453
## Dec 2019   0.0030864219 -5.833896e-03 0.012006739

SUAVIZADO EXPONENCIAL(HOLT-WINTERS)

  • El mĆ©todo se basa en un algoritmo iterativo que a cada tiempo realiza un pronóstico sobre el comportamiento de la serie en base a promedios debidamente ponderados de los datos obtenidos anteriormente.

  • A este particular hay que reseƱar los 2 diferentes tipos de estacionalidad que se pueden dar en las grĆ”ficas, que son estacionalidad aditiva o estacionalidad multiplicativa.

  • El modelo multiplicativo se usa cuando la magnitud del patron estacional en los datos depende de la magnitud de los datos. En otras palabras, la magnitud del patron estacional aumenta a medida que los valores de los datos se incrementan y disminuye a medida que los valores de los datos decrecen.

  • El modelo aditivo se usa cuando la magnitud del patron estacional en los datos no dependa de la magnitud de los datos. En otras palabras, la magnitud del patron estacional no cambia cuando la serie sube o baja.

El método de Holt-Winters es una técnica de suavizado que utiliza un conjunto de estimaciones recursivas a partir de la serie histórica. Estas estimaciones utilizan

  • Una constante de nivel \(\alpha\)

  • Una constante de tendencia \(\beta\)

  • Una constante estacional multiplicativa \(\gamma\)

Las estimaciones recursivas se basan en las siguientes ecuaciones:

\[\hat Y_t=\alpha(\hat Y_{t-1}-T_{t-1})+(1-\alpha)\frac{Y_t}{F_{t-s}}\ \ \ 0< \alpha <1\]

\[T_t=\beta T_{t-1}+(1-\beta)(\hat Y_{t}-\hat Y_{t-1})\ \ \ 0< \beta <1\]

\[F_t=\gamma F_{t-s}+(1-\gamma)\frac{Y_t}{\hat Y_{t}}\ \ \ 0< \gamma <1\]

donde \(s=4\) en el caso de datos trimestrales y \(s=12\) en el caso de datos mensuales.

  • \(\hat{Y}_t\) serĆ­a el nivel suavizado de la serie,

  • \(T_t\) la tendencia suavizada de la serie y

  • \(F_t\) el ajuste estacional suavizado de la serie.

HoltWinters(x, alpha = NULL, beta = NULL, gamma = NULL, seasonal = c(ā€œadditiveā€,multiplicativeā€œ), start.periods = 2, l.start = NULL, b.start = NULL, s.start = NULL, optim.start = c(alpha = 0.3, beta = 0.1, gamma = 0.1), optim.control = list())

Graficando nuevamente nuestros datos

`

ts_plot(z1, slider = T, title = "IPC 2000-2019")
  • Ahora realizaremos una grĆ”fica donde se vea la serie del modelo (linea negra) y el ajuste con la predicción(linea roja), asĆ­ mismo aparecerĆ” la descomposición de la grĆ”fica para evaluar los datos.
m1 = HoltWinters(z1, seasonal = "additive")
plot(m1)

hchart(forecast(m1,12))
m1
## Holt-Winters exponential smoothing with trend and additive seasonal component.
## 
## Call:
## HoltWinters(x = z1, seasonal = "additive")
## 
## Smoothing parameters:
##  alpha: 0.2553878
##  beta : 0
##  gamma: 0.4959211
## 
## Coefficients:
##              [,1]
## a    2.349466e-03
## b   -3.293998e-05
## s1   4.969355e-03
## s2   5.727923e-03
## s3   1.202672e-03
## s4   1.449009e-03
## s5  -2.826090e-04
## s6  -1.331098e-03
## s7  -2.638474e-03
## s8  -1.885080e-03
## s9  -1.275333e-03
## s10 -1.633277e-03
## s11 -1.117777e-03
## s12  8.382107e-04
checkresiduals(m1)

## 
##  Ljung-Box test
## 
## data:  Residuals from HoltWinters
## Q* = 44.307, df = 24, p-value = 0.007027
## 
## Model df: 0.   Total lags used: 24
  • A posterori realizaremos las predicciones a 12 meses vista y las graficaremos:
mod3=predict(m1, 12, prediction.interval = TRUE)
mod3
##                    fit         upr          lwr
## Jan 2019  0.0072858818 0.012048061  0.002523703
## Feb 2019  0.0080115091 0.012926537  0.003096481
## Mar 2019  0.0034533181 0.008516583 -0.001609946
## Apr 2019  0.0036667152 0.008873998 -0.001540568
## May 2019  0.0019021574 0.007249582 -0.003445267
## Jun 2019  0.0008207284 0.006304714 -0.004663257
## Jul 2019 -0.0005195878 0.005097640 -0.006136815
## Aug 2019  0.0002008662 0.005948248 -0.005546515
## Sep 2019  0.0007776736 0.006652326 -0.005096979
## Oct 2019  0.0003867899 0.006386014 -0.005612434
## Nov 2019  0.0008693493 0.006990610 -0.005251912
## Dec 2019  0.0027923973 0.009033310 -0.003448515
plot(m1, mod3)

REDES NEURONALES DE RETROALIMENTACION (nntear)

Son redes con una sola capa oculta y entradas retrasadas para pronosticar series de tiempo univariadas.

Vamos a elaborar entonces el modelo de red neuronal con nuestros datos:

set.seed(42)
neural_network <- nnetar(z1)
class(neural_network)
## [1] "nnetar"
  • Una vez hecho esto vamos a comprobar los residuos que presenta nuestro modelo.
checkresiduals(neural_network)

## 
##  Ljung-Box test
## 
## data:  Residuals from NNAR(4,1,3)[12]
## Q* = 23.644, df = 24, p-value = 0.4821
## 
## Model df: 0.   Total lags used: 24

Una vez hecho esto realizamos la predicción a 12 meses de los datos, con una significancia del 95% de los mismos.

mod4 <- forecast(neural_network, h=12, level = 95)
mod4
##              Jan         Feb         Mar         Apr         May         Jun
## 2019 0.001885194 0.004454989 0.003886486 0.003540136 0.002410782 0.001614345
##              Jul         Aug         Sep         Oct         Nov         Dec
## 2019 0.001094972 0.001680259 0.002113773 0.002082866 0.001714576 0.001891870
  • Luego realizamos un grĆ”fico de nuestro pronostico.
autoplot(mod4)

  • Ahora vamos a ver representado el ajuste entre lo datos de la serie y el pronóstico del modelo en la siguiente representación grĆ”fica, para ello utilizamos la función fitted() que obtiene un ajuste con la data histórica.
autoplot(mod4)+
  autolayer(fitted(mod4), series="Ajuste")
## Warning: Removed 12 rows containing missing values (`geom_line()`).

Ahora vamos a determinar los resultados de este modelo creando un dataframe

pronostico <- as.data.frame(mod4)
pronostico
##              Jan         Feb         Mar         Apr         May         Jun
## 2019 0.001885194 0.004454989 0.003886486 0.003540136 0.002410782 0.001614345
##              Jul         Aug         Sep         Oct         Nov         Dec
## 2019 0.001094972 0.001680259 0.002113773 0.002082866 0.001714576 0.001891870

REDES NEURONALES RECURRENTES (Modelos Elman y Jordan).

  • Una red neuronal recurrente no tiene una estructura de capas definida, sino que permiten conexiones arbitrarias entre las neuronas, incluso pudiendo crear ciclos, con esto se consigue crear la temporalidad, permitiendo que la red tenga memoria.

  • Los RNN se denominan recurrentes porque realizan la misma tarea para cada elemento de una secuencia, y la salida depende de los cĆ”lculos anteriores.

Modelo Elman.

  • En las redes de Elman, las entradas de estas neuronas, se toman desde las salidas de las neuronas de una de las capas ocultas, y sus salidas se conectan de nuevo en las entradas de esta misma capa, lo que proporciona una especie de memoria sobre el estado anterior de dicha capa.

  • Para desarrollar este modelo junto con el de Jordan, se cargan las librerĆ­as

#install.packages("RSNNS")
library(RSNNS)
library(quantmod)

Vamos pronosticar 12 meses de nuestros datos con esta red.

  • En primer lugar para actuar en dicho proceso con redes neuronales tenemos que normalizar nuestros datos para que tomen valores entre 0 y 1. Para ello hemos asociado a nuestro dataset de base una variable ā€œZā€ y a partir de esta hemos realizar la normalización a travĆ©s de la variable ā€œSā€.
Z <- as.ts(z1,F)
S <- (Z-min(Z))/(max(Z)-min(Z))  
plot(S)

A continuación comprobamos el numero de filas totales que contiene nuestro dataset y dividiremos los conjuntos de entrenamiento en un 75% y prueba en un 25% respectivamente.

tamano_total <- length(S)
tamano_total
## [1] 228
tamano_train <- round(tamano_total*0.75, digits = 0)
train <- 0:(tamano_train-1)
train
##   [1]   0   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15  16  17
##  [19]  18  19  20  21  22  23  24  25  26  27  28  29  30  31  32  33  34  35
##  [37]  36  37  38  39  40  41  42  43  44  45  46  47  48  49  50  51  52  53
##  [55]  54  55  56  57  58  59  60  61  62  63  64  65  66  67  68  69  70  71
##  [73]  72  73  74  75  76  77  78  79  80  81  82  83  84  85  86  87  88  89
##  [91]  90  91  92  93  94  95  96  97  98  99 100 101 102 103 104 105 106 107
## [109] 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125
## [127] 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
## [145] 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161
## [163] 162 163 164 165 166 167 168 169 170
test <- (tamano_train):tamano_total
test
##  [1] 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189
## [20] 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208
## [39] 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227
## [58] 228
  • Ahora crearemos un dataframe con \(n\) columnas, cada una de las cuales adelantara un valor de la serie en el futuro, a travĆ©s de una variable tipo zoo, equivalente al periodo de retardo de la serie.
y <- as.zoo(S)
x1 <- Lag(y, k = 1)
x2 <- Lag(y, k = 2)
x3 <- Lag(y, k = 3)
x4 <- Lag(y, k = 4)
x5 <- Lag(y, k = 5)
x6 <- Lag(y, k = 6)
x7 <- Lag(y, k = 7)
x8 <- Lag(y, k = 8)
x9 <- Lag(y, k = 9)
x10 <- Lag(y, k = 10)
x11 <- Lag(y, k = 11)
x12 <- Lag(y, k = 12)
slogN <- cbind(y,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12)
DT::datatable(slogN)
  • A continuacion eliminaremos los valores NA producidos al desplazar la serie:
slogN1 <- slogN[-(1:12),]
DT::datatable(slogN1)
  • Luego definimos los valores de entrada y salida de la red neuronal:
inputs <- slogN1[,2:13]
outputs <- slogN1[,1]
  • Ahora crearemos la red de Elman, probando diferentes tipos de combinaciones de neuronas en las capas ocultas e iteraciones mĆ”ximas, ademas del ritmo de aprendizaje aunque este Ćŗltimo apenas lo hemos tocado, para ajustar lo mejor posible la curva de predicción a la del modelo de la serie. De esta forma hemos llegado a estos valores a la hora de crear nuestra red. Asi mismo ponemos una semilla para que el resultado sea reproducible.
set.seed(42)
fit<-elman(inputs[train],outputs[train],size=c(10,3),learnFuncParams=c(0.1),
                  maxit=64000)
  • En la grĆ”fica siguiente vemos como evoluciona el error de la red con el numero de iteraciones para los parĆ”metros expuestos.
plotIterativeError(fit, main = "Iterative Error for 7,3 Neuron")

  • Observamos que el error converge a 0 muy rapidamente.

  • Ahora realizamos la predicción con el resto de los tĆ©rminos de la serie que son los datos seleccionados para test, pasamos pues una vez entrenada a probarla y a representarla graficamente para ver el ajuste del modelo.

y <- as.vector(outputs[-test])
plot(y,type="l")
pred <- predict(fit, inputs[-test])
lines(pred,col = "red")

  • El ajuste que predice bastante bien con los parametros elegidos, pues la curva del modelo de la serie y la de la prediccion parecen bastante ajustadas.

  • Esta representacion grafica se puede utilizar para ir ajustando la prediccion y el modelo a medida que vamos probando diferentes parametros de la red de Elman, de forma que la curva del modelo y de la prediccion queden lo mas ajustados posibles.

  • Ahora gracias al efecto memoria vamos a adelantarle a la serie al menos en un valor con una precision muy buena. Para ello volveremos a introducir los datos de entrenamiento.

predictions <- predict(fit,inputs[-train])
predictions
##                 [,1]
## Mar 2015  0.34287089
## Apr 2015  0.42560601
## May 2015  0.20535362
## Jun 2015  0.25980479
## Jul 2015  0.11165993
## Aug 2015  0.19485514
## Sep 2015  0.03163630
## Oct 2015  0.06255832
## Nov 2015  0.05122411
## Dec 2015  0.22957855
## Jan 2016  0.68483299
## Feb 2016  0.90195239
## Mar 2016  0.64090347
## Apr 2016  0.39495099
## May 2016  0.07180335
## Jun 2016  0.07419004
## Jul 2016  0.28000736
## Aug 2016  0.11032754
## Sep 2016 -0.24422857
## Oct 2016 -0.11019516
## Nov 2016  0.44549102
## Dec 2016  0.18790153
## Jan 2017  0.57058644
## Feb 2017  0.89353001
## Mar 2017  0.79368675
## Apr 2017  0.35494488
## May 2017  0.25065106
## Jun 2017  0.20474343
## Jul 2017  0.46699345
## Aug 2017 -0.03953356
## Sep 2017  0.04635978
## Oct 2017 -0.09643587
## Nov 2017 -0.06307691
## Dec 2017  0.35087645
## Jan 2018  0.45331717
## Feb 2018  0.28481832
## Mar 2018  0.07885304
## Apr 2018  0.19831201
## May 2018  0.23532809
## Jun 2018  0.24468547
## Jul 2018  0.13511980
## Aug 2018  0.11410458
## Sep 2018  0.29595640
## Oct 2018  0.23477662
## Nov 2018  0.17375576
## Dec 2018  0.39652300
  • posteriori desnormalizaremos los datos:
mod5 <- predictions*(max(Z)-min(Z))+min(Z)
mod5
##                   [,1]
## Mar 2015  0.0057832173
## Apr 2015  0.0079508775
## May 2015  0.0021802648
## Jun 2015  0.0036068854
## Jul 2015 -0.0002745099
## Aug 2015  0.0019052046
## Sep 2015 -0.0023711290
## Oct 2015 -0.0015609719
## Nov 2015 -0.0018579283
## Dec 2015  0.0028149581
## Jan 2016  0.0147426243
## Feb 2016  0.0204311525
## Mar 2016  0.0135916710
## Apr 2016  0.0071477158
## May 2016 -0.0013187523
## Jun 2016 -0.0012562211
## Jul 2016  0.0041361929
## Aug 2016 -0.0003094184
## Sep 2016 -0.0095987886
## Oct 2016 -0.0060871132
## Nov 2016  0.0084718646
## Dec 2016  0.0017230200
## Jan 2017  0.0117493648
## Feb 2017  0.0202104863
## Mar 2017  0.0175945928
## Apr 2017  0.0060995560
## May 2017  0.0033670578
## Jun 2017  0.0021642779
## Jul 2017  0.0090352284
## Aug 2017 -0.0042357792
## Sep 2017 -0.0019853738
## Oct 2017 -0.0057266199
## Nov 2017 -0.0048526151
## Dec 2017  0.0059929630
## Jan 2018  0.0086769097
## Feb 2018  0.0042622400
## Mar 2018 -0.0011340503
## Apr 2018  0.0019957748
## May 2018  0.0029655960
## Jun 2018  0.0032107593
## Jul 2018  0.0003401386
## Aug 2018 -0.0002104601
## Sep 2018  0.0045540578
## Oct 2018  0.0029511473
## Nov 2018  0.0013524010
## Dec 2018  0.0071889026
  • Ahora veamos la representación de los valores predecidos para el siguiente periodo.
x <- 1:(tamano_total+length(mod5))
y <- c(as.vector(Z),mod5)
plot(x[1:tamano_total], y[1:tamano_total],col = "blue", type="l")
lines( x[(tamano_total):length(x)], y[(tamano_total):length(x)], col="red")

length(y)
## [1] 274
  • AquĆ­ vemos la grĆ”fica con los valores predecidos con la linea roja.

-Los valores que adelantamos en el tiempo corresponden a mod5, de los cuales adelantaremos 12 meses a futuro para nuestro estudio.

Modelo Jordan

  • En las redes Jordan, la diferencia esta en que la entrada de las neuronas de la capa de contexto se toma desde la salida de la red.

  • Realizamos las mismas operaciones que con la red Elman, sustituyendo el modelo, obtenemos el resultado para la red Jordan.

set.seed(42)
fit <-jordan(inputs[train],outputs[train],size=6,learnFuncParams=c(0.3),
             maxit=78000)

plotIterativeError(fit, main = "Iterative Error for 6 Neuron")

y <- as.vector(outputs[-test])
plot(y,type="l")
pred <- predict(fit, inputs[-test])
lines(pred,col = "red")

predictions <- predict(fit,inputs[-train])
mod6 <- predictions*(max(Z)-min(Z))+min(Z)
mod6
##                   [,1]
## Mar 2015  8.356027e-03
## Apr 2015  9.040188e-03
## May 2015  6.627689e-03
## Jun 2015  2.397062e-03
## Jul 2015  1.219208e-03
## Aug 2015  6.075835e-03
## Sep 2015  5.101195e-03
## Oct 2015  9.087083e-03
## Nov 2015  3.202661e-03
## Dec 2015  1.665009e-03
## Jan 2016  3.267486e-03
## Feb 2016  8.347225e-03
## Mar 2016  3.011390e-03
## Apr 2016  9.088597e-04
## May 2016  4.415583e-04
## Jun 2016 -1.032922e-03
## Jul 2016 -6.350545e-04
## Aug 2016 -3.511731e-06
## Sep 2016  2.084550e-03
## Oct 2016 -7.010381e-04
## Nov 2016 -2.075223e-04
## Dec 2016  4.124171e-02
## Jan 2017  2.074871e-02
## Feb 2017  2.796732e-02
## Mar 2017  1.974752e-02
## Apr 2017  9.540181e-03
## May 2017  1.062435e-02
## Jun 2017  8.969732e-04
## Jul 2017  2.229772e-03
## Aug 2017  2.585686e-03
## Sep 2017  1.881212e-03
## Oct 2017  1.469792e-03
## Nov 2017  1.782364e-03
## Dec 2017  4.321295e-03
## Jan 2018  6.076782e-03
## Feb 2018  8.067465e-03
## Mar 2018  5.400921e-03
## Apr 2018  2.697154e-03
## May 2018  4.485050e-03
## Jun 2018  1.304361e-03
## Jul 2018  1.358508e-03
## Aug 2018  1.581382e-03
## Sep 2018  3.029937e-03
## Oct 2018  2.434016e-03
## Nov 2018  6.245761e-03
## Dec 2018  3.972846e-03
x <- 1:(tamano_total+length(mod6))
y <- c(as.vector(Z),mod6)
plot(x[1:tamano_total], y[1:tamano_total],col = "blue", type="l")
lines( x[(tamano_total):length(x)], y[(tamano_total):length(x)], col="red")

  • La anterior grafica con los valores predecidos con la linea roja.

  • Los valores que adelantamos en el tiempo corresponden a mod6, de los cuales adelantaremos 12 meses a futuro para nuestro estudio

Estimación del error Comparativo de los modelos con los valores actuales observados.

data=IPC[229:241,]
data_real <- ts(data, start = c(2019,1), end=c(2019,12), frequency = 12)

data_real
##         Jan    Feb    Mar    Apr    May    Jun    Jul    Aug    Sep    Oct
## 2019 0.0060 0.0057 0.0043 0.0050 0.0031 0.0027 0.0022 0.0009 0.0023 0.0016
##         Nov    Dec
## 2019 0.0010 0.0026

Ahora haremos la comparacion de nuestros modelos con la data_real(valor de test en RMSE).

  • ETS:
accuracy(mod2,data_real)
##                        ME        RMSE         MAE      MPE     MAPE      MASE
## Training set 4.010303e-05 0.002304734 0.001780198     -Inf      Inf 0.7400362
## Test set     1.900180e-04 0.001609099 0.001326715 23.46858 53.30514 0.5515211
##                   ACF1 Theil's U
## Training set 0.2217259        NA
## Test set     0.6094793  0.834022
  • HOLT-WINTERS:
accuracy(mod3,data_real)
##                    ME        RMSE         MAE      MPE     MAPE      ACF1
## Test set 0.0006460168 0.001477215 0.001277648 36.79939 48.36339 0.4565426
##          Theil's U
## Test set  0.923831
  • NNTEAR:
accuracy(mod4,data_real)
##                         ME        RMSE         MAE      MPE     MAPE      MASE
## Training set -2.326001e-06 0.001970607 0.001521731     -Inf      Inf 0.6325901
## Test set      7.524794e-04 0.001459091 0.001082096 7.408959 38.79766 0.4498322
##                   ACF1 Theil's U
## Training set 0.1286471        NA
## Test set     0.2242569 0.4869346
  • Para Elman y Jordan al no ser modelos con forecast, lo convertimos en series de tiempo para que lo acepte el comando accuracy.De tal forma que:
mod5[1:12]
##  [1]  0.0057832173  0.0079508775  0.0021802648  0.0036068854 -0.0002745099
##  [6]  0.0019052046 -0.0023711290 -0.0015609719 -0.0018579283  0.0028149581
## [11]  0.0147426243  0.0204311525
m5 <- mod5[1:12]
mod5c <- ts(m5, frequency=12,start=c(2019,1))
mod5c
##                Jan           Feb           Mar           Apr           May
## 2019  0.0057832173  0.0079508775  0.0021802648  0.0036068854 -0.0002745099
##                Jun           Jul           Aug           Sep           Oct
## 2019  0.0019052046 -0.0023711290 -0.0015609719 -0.0018579283  0.0028149581
##                Nov           Dec
## 2019  0.0147426243  0.0204311525
m6 <- mod6[1:12]
mod6c <- ts(m6, frequency=12,start=c(2019,1))
mod6c
##              Jan         Feb         Mar         Apr         May         Jun
## 2019 0.008356027 0.009040188 0.006627689 0.002397062 0.001219208 0.006075835
##              Jul         Aug         Sep         Oct         Nov         Dec
## 2019 0.005101195 0.009087083 0.003202661 0.001665009 0.003267486 0.008347225
  • ELMAN(RNN):
accuracy(mod5c,data_real)
##                   ME        RMSE         MAE       MPE     MAPE      ACF1
## Test set -0.00132922 0.006928758 0.004510715 -107.8698 254.7136 0.5178112
##          Theil's U
## Test set  8.458994
  • JORDAN(RNN):
accuracy(mod6c,data_real)
##                    ME        RMSE         MAE       MPE     MAPE     ACF1
## Test set -0.002248889 0.003631703 0.002996177 -141.4128 160.2011 0.151485
##          Theil's U
## Test set  3.016997
#accuracy(h1, data_real)