Carga librerías

PUNTO 2

¿Por qué una transformación de Box-Cox no es útil para los datos cangas?

Realizamos los gráficos necesarios(autoplot, seasonplot) y su respectiva transformación y hacemos las observaciones respectivas

#lambda_cangas <- BoxCox.lambda(cangas)
#cangas1<- autoplot(cangas) 
#cangas2<- autoplot(BoxCox(cangas, lambda_cangas))
#grid.arrange( grobs = list(cangas1,cangas2))

xt=cangas;
 # Transformación logarítmica
log_xt <- log(cangas)

# Transformación raíz
#log_xt <- sqrt(xt)

# Box Cox Transformation
library(forecast)
lamb.x <- BoxCox.lambda(xt)
lamb.x

## [1] 0.5767759

##realiza la transformacion
tran_box <- function(xt,lambda){
  if (lamb.x == 0) {
    xt_box <- log(xt)
  } else {
    xt_box <- (xt^lamb.x - 1)/lamb.x
  }
}

xt_boxCox <- tran_box(xt, lamb.x)

data1 <- cbind(xt, log_xt, xt_boxCox)
#plot(data1, col = "steelblue", lwd = 2,     main=" ")# otra forma de graficar

autoplot(data1,facet=T) + xlab("Year") + ggtitle("myts")

##SEASONPLOT

s1 <- ggseasonplot(xt, year.labels=TRUE, year.labels.left=TRUE) +
  ylab("billion cubic metres") +
  ggtitle("Seasonal plot: cangas")
s2 <-ggseasonplot(xt_boxCox, year.labels=TRUE, year.labels.left=TRUE) +
  ylab("billion cubic metres") +
  ggtitle("Seasonal plot: cangas tranformed")
grid.arrange(s1,s2,ncol=2)

Después de elegir el mejor valor de lambda \(\lambda=0.577\) y aplicar box cox en los datos de la serie temporal, no pudimos estabilizar la varianza. Como podemos ver la comparación de ambos plots, la transformación box-cox está generando resultados similares al original, la transformación no proporciona estacionariedad a las series de tiempo.

El objetivo de la transformación es hacer que el tamaño de la variación estacional sea el mismo en toda la serie. Los datos sin procesar y el gráfico estacional muestran que la variación estacional está cambiando con el tiempo. Se observa que la variación estacional es relativamente baja de 1960 a 1970, pero luego el patrón comienza a cambiar.

Las caídas de enero a febrero, así como las subidas de febrero a marzo, por ejemplo, aumentan en amplitud con el tiempo a partir de 1973.

El propósito de la transformación es tratar de “suavizar” esta variación a lo largo del tiempo y hacerla igual en todo serie. Observando el season plot muestra que Box-Cox no da el resultado esperado

PUNTO 3

Para cada una de las siguientes series, haga un gráfico de los datos. Si la transformación parece apropiada, hágalo y describa el efecto: dole, usdeaths, bricksq

Se realiza transformacional box-cox y log para revisar gráficamente

p1_0 <- autoplot(dole) +
  ggtitle("Beneficios para desempleados en Australia") +
  xlab("Año") +
  ylab("# personas")

p2_0 <- autoplot(usdeaths)+
  ggtitle("Muertes en EU") +
  xlab("Año") +
  ylab("# accidentes")

p3_0 <-autoplot(bricksq)+
  ggtitle("Produccion de ladrillos") +
  xlab("Año") +
  ylab("Ladrillos") 

lambda_1 <- BoxCox.lambda(dole)
#lambda_dole
lambda_1

## [1] 0.3290922

p1 <- autoplot(BoxCox(dole,lambda_1)) +
  ggtitle("Tr.box Beneficios para desempleados en Australia") +
  xlab("Year") +
  ylab("Personas transf")

lambda_2 <- BoxCox.lambda(usdeaths)
#lambda_usdeaths
lambda_2

## [1] -0.03363775

p2 <- autoplot(BoxCox(usdeaths,lambda_2))+
  ggtitle("Tr.box Muertes en EU") +
  xlab("Year") +
  ylab("# muertes")

lambda_3 <- BoxCox.lambda(bricksq)
#lambda bricks
lambda_3

## [1] 0.2548929

p3 <-autoplot(BoxCox(bricksq,lambda_3))+
  ggtitle("Tr.box Producción de ladrillos") +
  xlab("Año") +
  ylab("# Ladrillos") 



p1l <- autoplot(log(dole)) +
  ggtitle("Tr.log Beneficios para desempleados en Australia") +
  xlab("Year") +
  ylab("Personas transf")

p2l <- autoplot(log(usdeaths))+
  ggtitle("Tr.log Muertes en EU") +
  xlab("Year") +
  ylab("Numero de muertes")

p3l <-autoplot(log(bricksq))+
  ggtitle("Tr.log Producción de ladrillos") +
  xlab("Año") +
  ylab("Ladrillos") 



grid.arrange(p1_0,p2_0,p3_0,p1,p2,p3,p1l,p2l,p3l,ncol=3)

s1 = ggseasonplot(dole, year.labels=TRUE, year.labels.left=TRUE)
s2 <-ggseasonplot(BoxCox(dole,lambda_1), year.labels=TRUE, year.labels.left=TRUE) +
  ylab("Beneficios") +
  ggtitle("Dole transformado box cox")
grid.arrange(s1,s2,ncol=2)

s1 = ggseasonplot(usdeaths, year.labels=TRUE, year.labels.left=TRUE)
s2 <-ggseasonplot(BoxCox(usdeaths,lambda_1), year.labels=TRUE, year.labels.left=TRUE) +
  ylab("Cantidad") +
  ggtitle("usdeaths transformado box cox")
grid.arrange(s1,s2,ncol=2)

s1 = ggseasonplot(bricksq, year.labels=TRUE, year.labels.left=TRUE)
s2 <-ggseasonplot(BoxCox(bricksq,lambda_1), year.labels=TRUE, year.labels.left=TRUE) +
  ylab("Cantidad") +
  ggtitle("bricksq transformado box cox")
grid.arrange(s1,s2,ncol=2)

Serie dole

se observan tres grandes saltos en 1975, 1982 y 1991.No se observa un patrón estacional o cíclico. el número de personas beneficiadas aumenta significativamente en 1975 y 1982. Mientras tanto, está claro que desde 1991, este número ha aumentado continuamente, especialmente en 1992.

En el caso de Dole, los datos fueron transformados usando box-cox con \(\lambda= 0.33\), la transformación estabiliza la varianza, en el seasonplot se observa que con la transformación se observan patrones mas definidos

Serie usdeaths

Se observan patrones similares durante cada año, en la mitad de cada año aumenta el numero de muertes por accidente, se observa estacionalidad en la serie, el número total de muertes accidentales alcanza UN máximo en julio y el mínimo en febrero.

En el caso de la serie usdeaths no hay necesidad de una transformación , como se observa la gráfica, sobre la serie ya es posible hacer pronósticos.

Serie bricks

En los gráficos anteriores, podemos identificar tendencias crecientes y decrecientes, también hay una estacionalidad presente y se puede ver ciclicidad ya que parece haber un ciclo de 4 a 5 años.

La serie bricks fue transformada con box-cox con \(\lambda= 0.25\) se observa que la transformación estabiliza la varianza, aunque no seria necesario transformarlos.

PUNTO 4

Calcule los residuos de un pronóstico ingenuo estacional aplicado a los datos trimestrales de producción de cerveza australiana de 1992. El siguiente código ayudará

beer <- window(ausbeer, start=1992)

fc <- snaive(beer, h=10) ?snaive autoplot(fc)

res <- residuals(fc)

autoplot(res)

Pruebe si los residuos son ruido blanco y normalmente distribuidos.

checkresiduals(fc)

beer <- window(ausbeer, start=1992) 
fc <- snaive(beer) 
autoplot(fc)

res <- residuals(fc) 
autoplot(res)

checkresiduals(fc)

## 
##  Ljung-Box test
## 
## data:  Residuals from Seasonal naive method
## Q* = 32.269, df = 8, p-value = 8.336e-05
## 
## Model df: 0.   Total lags used: 8

Recordamos que las series que no presentan autocorrelacion son ruido blanco

Contraste de hipótesis:

H0 = Los datos se distribuyen de manera independiente (Es un Ruido Blanco.)

H1 = Los datos no se distribuyen de manera independiente, (NO es un Ruido Blanco).

En este caso, al obtener como p-valor \(8.3336e-0.5 < \alpha (0.05)\), rechazamos la Hipótesis Nula de independencia,por tanto los datos no se distribuyen de manera independiente, lo residuales están correlacionados, por lo que decimos que dicha variables no es un Ruido Blanco. los residuos están correlacionados, Cambien se observa que el lag 4 sobresale a las lineas de bandas de confianza, es un modelo estadísticamente significativo con residuos normalmente distribuidos.

Queda información considerable en los residuos que no son tomadas usando el método ingenuo.

PUNTO 6

¿Son las siguientes afirmaciones verdaderas o falsas?

Los buenos métodos de pronóstico deberían tener residuos distribuidos normalmente.

Falso, es bueno tener normalidad en residuos pero no es obligatorio, aunque haría que los cálculos de predicción de intervalos fueran mas sencillos

Un modelo con pequeños residuos dará buenos pronósticos.

Falso, un buen modelo de pronostico genera residuos, que no deben estar correlacionados, los residuos tienen media 0, los residuos tienen varianza constante, y se distribuyen normalmente

La mejor medida de precisión del pronóstico es MAPE.

FaLsO es utilizado, pero depende de los datos de la serie, por ejemplo el MAPE es sensible a valores nulos y 0s, el MAPE es útil para comparar pronósticos en diferentes escalas, su medida es porcentual.

Si su modelo no pronostica bien, debería hacerlo más complicado.

FALSO un método complicado no es sinónimo de un buen pronostico, puede ser que con métodos complicados se obtengan peores resultados

Elija siempre el modelo con la mejor precisión de pronóstico medida en el conjunto de prueba.

FALSO no necesariamente, si el set de prueba tiene pocos datos, no tendríamos los mejores resultados

PUNTO 7.

La Base2 contiene datos mensuales de ventas minoristas en varias categorías para diferentes estados australianos.

Lea los datos en R. Utilice esta función: retaildata <- readxl::read_excel(“Base2.xlsx”, skip=1)
Seleccione una de las series temporales de la siguiente manera (pero reemplace el nombre de la columna con su propia columna elegida):

myts <- ts(retaildata[,“A3349873A”], frequency=12, start=c(1982,4))

Divide los datos en dos partes

myts.train <- window(myts, end=c(2010,12)) myts.test <- window(myts, start=2011)

Verifique que sus datos se hayan dividido adecuadamente produciendo la siguiente gráfica.

autoplot(myts) + autolayer(myts.train, series=“Training”) + autolayer(myts.test, series=“Test”)

Calcule pronósticos utilizando snaive aplicado a myts.train.
Compare la precisión de sus pronósticos con los valores reales almacenados en myts.test accuracy(fc,myts.test)
Verificar los residuos. ¿Los residuos parecen no estar correlacionados y normalmente distribuidos?
¿Cuán sensibles son las medidas de precisión para la división de entrenamiento / prueba?

SOLUCION

Punto 7a

Se realiza la lectura de los datos de la base de datos base2.xlsx

library(fpp2)
retaildata<-readxl::read_excel("base2.xlsx",skip=1)
#retaildata

Se selecciona la columna A3349873A y se visualizan los graficos autoplot, ggseasonplot, gglaplot, ggacf

Punto 7b

myts <- ts(retaildata[,"A3349873A"], frequency=12, start=c(1982,4))
autoplot(myts)

ggseasonplot(myts)

gglagplot(myts, lags = 24)

ggAcf(myts)

Según los gráficos, se observa tendencia y estacionalidad en los datos de la serie A3349873A, según el gráfico gglagplot los lags 1, 12, 24 son los mas correlacionados y se confirman con el grafico ACF

Punto 7c

Se realiza la división en dos partes una primera parte de entrenamiento y otra de prueba de acuerdo a las indicaciones,

myts.train <- window(myts, end=c(2010,12))
myts.test <- window(myts, start=2011)

Punto 7d

#myts.train
#myts.test
autoplot(myts)+autolayer(myts.train,series="Training")+autolayer(myts.test,series="Test")

Se observa gráficamente con el autoplot las partes de entrenamiento y las parte test

Punto 7e

snaive_train <- snaive(myts.train, h = 24)
#snaive_train
autoplot(snaive_train)

Se observan los pronósticos usando método ingenuo obteniendo la gráfica anterior

Punto 7f

 accuracy(snaive_train, myts.test)

##                     ME     RMSE      MAE       MPE      MAPE     MASE      ACF1
## Training set  7.772973 20.24576 15.95676  4.702754  8.109777 1.000000 0.7385090
## Test set     55.300000 71.44309 55.78333 14.900996 15.082019 3.495907 0.5315239
##              Theil's U
## Training set        NA
## Test set      1.297866

El MAPE de serie entrenamiento es de un 8% MAPE implica tiene una precisión 92 %

El MAPE de serie de prueba es de 15% implica una presionen de 85%

El RMSE en el set de prueba es de 71.44 en comparación con el set de entrenamiento que es de 20.25

Punto 7g

 checkresiduals(snaive_train)

## 
##  Ljung-Box test
## 
## data:  Residuals from Seasonal naive method
## Q* = 624.45, df = 24, p-value < 2.2e-16
## 
## Model df: 0.   Total lags used: 24

p-value < 2.2e-16 implica que se rechaza la hipotesis nula, hay correlación en los residuos de la serie, los residuos no son ruido blanco, se observa que los residuos no están normalizados

Punto 7h

En este caso se propone definir sets de entrenamiento y prueba diferentes y tomar las medidas de RMSE, MAE, MPE, MASE, MAPE y ACF1, de acuerdo a los resultados obtenidos por accuracy, se nota cambios significativos en las mediciones, en este caso se debe pensar en otras mediciones ej. usando validación cruzada

##  desde 2005
myts.train1 <- window(myts, end=c(2005,12))
myts.test1 <- window(myts, start=2006)

##  desde 2009
myts.train2 <- window(myts, end=c(2009,12))
myts.test2 <- window(myts, start=2010)


s1 <- snaive(myts.train1)
s2 <- snaive(myts.train2)

accuracy(s1, myts.test1)

##                     ME     RMSE      MAE      MPE     MAPE      MASE      ACF1
## Training set  9.365568 20.04803 15.85714 5.745128 8.661106 1.0000000 0.7202258
## Test set     10.337500 19.09667 13.87083 3.151397 4.490635 0.8747372 0.4852215
##              Theil's U
## Training set        NA
## Test set      0.404645

accuracy(s2, myts.test2)

##                     ME     RMSE      MAE       MPE     MAPE     MASE      ACF1
## Training set  8.989097 19.91337 15.62773  5.225943 8.065561 1.000000 0.6955129
## Test set     -5.695833 34.32162 27.13750 -3.330530 8.948578 1.736497 0.6105826
##              Theil's U
## Training set        NA
## Test set     0.9200031

PUNTO 9

Use el índice Dow Jones (conjunto de datos dowjones) para hacer lo siguiente: ¿Qué puedes decir sobre los patrones estacionales?

Producir una trama temporal de la serie.
Produzca pronósticos utilizando el método de deriva y grafíquelos.
Muestre que los pronósticos son idénticos a extender la línea trazada entre la primera y la última observación.
Intente usar algunas de las otras funciones de referencia para pronosticar el mismo conjunto de datos. ¿Cuál crees que es mejor? ¿Por qué?

Punto 9a

Se gráfica dow jones días vs valor en dolares, la seria indice dow jones consta de 78 datos diarios

#?dowjones
autoplot(dowjones) + 
  ggtitle({"Indice Dow-Jones"}) + 
  xlab("DIA") + 
  ylab("DoLARES")

Se observa tendencia pero no se observa estacionalidad

Punto 9b

utilizando el método de deriva usando función rwf con drift=TRUE y de acuerdo al problema pronosticamos los siguientes 10, 20 y 30 valores

pr1 <-rwf(dowjones, drift=TRUE, h=10)
pr2 <-rwf(dowjones, drift=TRUE, h=20)
pr3 <-rwf(dowjones, drift=TRUE, h=30)


autoplot(dowjones)+
    autolayer(pr1, PI=FALSE, series="Deriva 10 pred ")+
    autolayer(pr2, PI=FALSE, series="Deriva  20")+
    autolayer(pr3, PI=FALSE, series="Deriva 30")+
    xlab("Tiempo")+
    ylab("Precio (US$)")+
    ggtitle("Indice Dow Jones ")+
    guides(colour=guide_legend(title="Predicciones") )

Punto 9c

#plot(rwf(dowjones, drift = TRUE, h = 30), xlab = "Dias", ylab = "Valor indice dowjones", main = "")

#x=c(0,78)
#y=c(110.94,121.23)

#slope <- diff(y)/diff(x)
#intercept <- y[1]-slope*x[1]
#abline(intercept, slope,lty = 2, col="red")

dj_x <- c(1, 78)
dj_y <- c(dowjones[1], dowjones[78])
lm_dj <- lm(dj_y ~ dj_x)
autoplot(rwf(dowjones, drift = TRUE, h = 30)) +
  geom_abline(intercept = lm_dj$coefficients[1],
              slope = lm_dj$coefficients[2],
              colour = "red")

Se observa que las predicciones realizadas con método deriva son idénticas extendiendo una linea entre la primera y la ultima observación

Punto 9d

Escogemos mean, ingenuo, ingenuo estacional,deriva para realizar los pronósticos, de

m <-meanf(dowjones, h=20)
naive <-rwf(dowjones, h=20)
naive_seas <-snaive(dowjones, drift=TRUE, h=20)
deriva <-rwf(dowjones, drift=TRUE, h=20)
g <- guide_legend("Prediccion")
autoplot(dowjones)+
  autolayer(m, PI=FALSE, series="mean f")+
  autolayer(naive, PI=FALSE, series="ingenuo")+
  autolayer(naive_seas, PI=FALSE, series="Ingenuo estacional")+
  autolayer(deriva,  PI=FALSE, series="Metodo deriva")+
  xlab("Tiempo")+ ylab("Precio (US$)")+
  ggtitle("Dow Jones")+
  guides(colour=g)

Tres pronósticos , ingenuo, y deriva son muy parecidos.

Con el método de deriva se obtienen mejores resultados que mean e ingenuo en cuanto tiene mejores resultados en cuanto a las tendencias que ocurre a lo largo de la serie, pensamos que no se debe usar método ingenuo estacional puesto que la serie no es estacional.

meanf esta muy por debajo de la tendencia actual

Taller 2 - Series de tiempo

Hector Henry Jurado Soto cod 1905224

Carlos Arango Pastrana cod 1900053

https://rpubs.com/hejurado/623124

29/05/2020