Un modelo AR (1) con la intervención definida en la ecuación dada en la pregunta puede ajustarse como se muestra a continuación. Observe cómo transfer
se define el argumento ; También necesita una variable indicadora xtransf
para cada una de las intervenciones (el pulso y el cambio transitorio):
require(TSA)
cds <- structure(c(2580L, 2263L, 3679L, 3461L, 3645L, 3716L, 3955L, 3362L,
2637L, 2524L, 2084L, 2031L, 2256L, 2401L, 3253L, 2881L,
2555L, 2585L, 3015L, 2608L, 3676L, 5763L, 4626L, 3848L,
4523L, 4186L, 4070L, 4000L, 3498L),
.Dim = c(29L, 1L),
.Dimnames = list(NULL, "CD"),
.Tsp = c(2012, 2014.33333333333, 12),
class = "ts")
fit <- arimax(log(cds), order = c(1, 0, 0),
xtransf = data.frame(Oct13a = 1 * (seq_along(cds) == 22),
Oct13b = 1 * (seq_along(cds) == 22)),
transfer = list(c(0, 0), c(1, 0)))
fit
# Coefficients:
# ar1 intercept Oct13a-MA0 Oct13b-AR1 Oct13b-MA0
# 0.5599 7.9643 0.1251 0.9231 0.4332
# s.e. 0.1563 0.0684 0.1911 0.1146 0.2168
# sigma^2 estimated as 0.02131: log likelihood = 14.47, aic = -18.94
ω0ω1coeftest
require(lmtest)
coeftest(fit)
# Estimate Std. Error z value Pr(>|z|)
# ar1 0.559855 0.156334 3.5811 0.0003421 ***
# intercept 7.964324 0.068369 116.4896 < 2.2e-16 ***
# Oct13a-MA0 0.125059 0.191067 0.6545 0.5127720
# Oct13b-AR1 0.923112 0.114581 8.0564 7.858e-16 ***
# Oct13b-MA0 0.433213 0.216835 1.9979 0.0457281 *
# ---
# Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
5%
El efecto de la intervención se puede cuantificar de la siguiente manera:
intv.effect <- 1 * (seq_along(cds) == 22)
intv.effect <- ts(
intv.effect * 0.1251 +
filter(intv.effect, filter = 0.9231, method = "rec", sides = 1) * 0.4332)
intv.effect <- exp(intv.effect)
tsp(intv.effect) <- tsp(cds)
Puede trazar el efecto de la intervención de la siguiente manera:
plot(100 * (intv.effect - 1), type = "h", main = "Total intervention effect")
ω21ω21
Numéricamente, estos son los aumentos estimados cuantificados en cada punto de tiempo causado por la intervención en octubre de 2013:
window(100 * (intv.effect - 1), start = c(2013, 10))
# Jan Feb Mar Apr May Jun Jul Aug Sep Oct
# 2013 74.76989
# 2014 40.60004 36.96366 33.69046 30.73844 28.07132
# Nov Dec
# 2013 49.16560 44.64838
75%
stats::arima
0.9231
xreg <- cbind(
I1 = 1 * (seq_along(cds) == 22),
I2 = filter(1 * (seq_along(cds) == 22), filter = 0.9231, method = "rec",
sides = 1))
arima(log(cds), order = c(1, 0, 0), xreg = xreg)
# Coefficients:
# ar1 intercept I1 I2
# 0.5598 7.9643 0.1251 0.4332
# s.e. 0.1562 0.0671 0.1563 0.1620
# sigma^2 estimated as 0.02131: log likelihood = 14.47, aic = -20.94
ω20.9231xreg
ω2
Estas intervenciones son equivalentes a un valor atípico aditivo (AO) y un cambio transitorio (TC) definido en el paquete tsoutliers
. Puede usar este paquete para detectar estos efectos como se muestra en la respuesta de @forecaster o para construir los regresores utilizados anteriormente. Por ejemplo, en este caso:
require(tsoutliers)
mo <- outliers(c("AO", "TC"), c(22, 22))
oe <- outliers.effects(mo, length(cds), delta = 0.9231)
arima(log(cds), order = c(1, 0, 0), xreg = oe)
# Coefficients:
# ar1 intercept AO22 TC22
# 0.5598 7.9643 0.1251 0.4332
# s.e. 0.1562 0.0671 0.1563 0.1620
# sigma^2 estimated as 0.02131: log likelihood=14.47
# AIC=-20.94 AICc=-18.33 BIC=-14.1
Editar 1
He visto que la ecuación que diste puede reescribirse como:
(ω0+ω1)−ω0ω2B1−ω2BPt
y se puede especificar como lo hizo usando transfer=list(c(1, 1))
.
Como se muestra a continuación, esta parametrización conduce, en este caso, a estimaciones de parámetros que implican un efecto diferente en comparación con la parametrización previa. Me recuerda el efecto de un valor atípico innovador en lugar de un pulso más un cambio transitorio.
fit2 <- arimax(log(cds), order=c(1, 0, 0), include.mean = TRUE,
xtransf=data.frame(Oct13 = 1 * (seq(cds) == 22)), transfer = list(c(1, 1)))
fit2
# ARIMA(1,0,0) with non-zero mean
# Coefficients:
# ar1 intercept Oct13-AR1 Oct13-MA0 Oct13-MA1
# 0.7619 8.0345 -0.4429 0.4261 0.3567
# s.e. 0.1206 0.1090 0.3993 0.1340 0.1557
# sigma^2 estimated as 0.02289: log likelihood=12.71
# AIC=-15.42 AICc=-11.61 BIC=-7.22
No estoy muy familiarizado con la notación de paquete, TSA
pero creo que el efecto de la intervención ahora se puede cuantificar de la siguiente manera:
intv.effect <- 1 * (seq_along(cds) == 22)
intv.effect <- ts(intv.effect * 0.4261 +
filter(intv.effect, filter = -0.4429, method = "rec", sides = 1) * 0.3567)
tsp(intv.effect) <- tsp(cds)
window(100 * (exp(intv.effect) - 1), start = c(2013, 10))
# Jan Feb Mar Apr May Jun Jul Aug
# 2014 -3.0514633 1.3820052 -0.6060551 0.2696013 -0.1191747
# Sep Oct Nov Dec
# 2013 118.7588947 -14.6135216 7.2476455
plot(100 * (exp(intv.effect) - 1), type = "h",
main = "Intervention effect (parameterization 2)")
El efecto se puede describir ahora como un fuerte aumento en octubre de 2013 seguido de una disminución en la dirección opuesta; entonces el efecto de la intervención se desvanece rápidamente alternando los efectos positivos y negativos del peso en descomposición.
Este efecto es algo peculiar, pero puede ser posible en datos reales. En este punto, miraría el contexto de sus datos y los eventos que pueden haber afectado los datos. Por ejemplo, ha habido un cambio de política, campaña de marketing, descubrimiento, ... que pueda explicar la intervención en octubre de 2013. Si es así, ¿es más sensato que este evento tenga un efecto en los datos como se describió anteriormente o como encontramos? con la parametrización inicial?
−18.94−15.42
0.9
Editar 2
ω2ω2
omegas <- seq(0.5, 1, by = 0.01)
aics <- rep(NA, length(omegas))
for (i in seq(along = omegas)) {
tc <- filter(1 * (seq_along(cds) == 22), filter = omegas[i], method = "rec",
sides = 1)
tc <- ts(tc, start = start(cds), frequency = frequency(cds))
fit <- arima(log(cds), order = c(1, 0, 0), xreg = tc)
aics[i] <- AIC(fit)
}
omegas[which.min(aics)]
# [1] 0.88
plot(omegas, aics, main = "AIC for different values of the TC parameter")
ω2=0.880.9ω2=1
ω2=0.9
ω2=0.9
tc <- filter(1 * (seq.int(length(cds) + 12) == 22), filter = 0.9, method = "rec",
sides = 1)
tc <- ts(tc, start = start(cds), frequency = frequency(cds))
fit <- arima(window(log(cds), end = c(2013, 10)), order = c(1, 0, 0),
xreg = window(tc, end = c(2013, 10)))
Los pronósticos se pueden obtener y mostrar de la siguiente manera:
p <- predict(fit, n.ahead = 19, newxreg = window(tc, start = c(2013, 11)))
plot(cbind(window(cds, end = c(2013, 10)), exp(p$pred)), plot.type = "single",
ylab = "", type = "n")
lines(window(cds, end = c(2013, 10)), type = "b")
lines(window(cds, start = c(2013, 10)), col = "gray", lty = 2, type = "b")
lines(exp(p$pred), type = "b", col = "blue")
legend("topleft",
legend = c("observed before the intervention",
"observed after the intervention", "forecasts"),
lty = rep(1, 3), col = c("black", "gray", "blue"), bty = "n")
Los primeros pronósticos coinciden relativamente bien con los valores observados (línea punteada gris). Los pronósticos restantes muestran cómo la serie continuará el camino hacia la media original. Sin embargo, los intervalos de confianza son grandes, lo que refleja la incertidumbre. Por lo tanto, debemos ser precavidos y revisar el modelo a medida que se graben nuevos datos.
95%
lines(exp(p$pred + 1.96 * p$se), lty = 2, col = "red")
lines(exp(p$pred - 1.96 * p$se), lty = 2, col = "red")