Функція передачі втручання ARIMA - як візуалізувати ефект

У мене є щомісячний часовий ряд з втручанням, і я хотів би кількісно оцінити вплив цього втручання на результат. Я усвідомлюю, що серія досить коротка, і ефект ще не завершений.

Дані

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")

Методика

1) За допомогою auto.arimaфункції використовується серія перед втручанням (до жовтня 2013 року) . Запропонована модель була ARIMA (1,0,0) з ненульовим середнім. Сюжет ACF виглядав добре.

pre <- window(cds, start=c(2012, 01), end=c(2013, 09))

mod.pre <- auto.arima(log(pre))

# Coefficients:
#          ar1  intercept
#       0.5821     7.9652
# s.e.  0.1763     0.0810
# 
# sigma^2 estimated as 0.02709:  log likelihood=7.89
# AIC=-9.77   AICc=-8.36   BIC=-6.64

2) Враховуючи графік повного ряду, імпульсна характеристика була обрана нижче, з T = жовтень 2013 р.

які відповідно до крикеру та чану можуть бути пристосовані таким чином до функції аримакс:

mod.arimax <- arimax(log(cds), order=c(1, 0, 0),
                     seasonal=list(order=c(0, 0, 0), frequency=12),
                     include.mean=TRUE,
                     xtransf=data.frame(Oct13=1 * (seq(cds) == 22)),
                     transfer=list(c(1, 1)))
mod.arimax

# Series: log(cds) 
# 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

Залишки від цього виявилися нормально:

Сюжет пристосованих та актуальних:

plot(fitted(mod.arimax), col="red", type="b")
lines(window(log(cds), start=c(2012, 02)), type="b")

Питання

1) Чи правильна ця методика для аналізу втручання?

2) Чи можна переглянути оцінку / SE для компонентів функції передачі і сказати, що ефект від втручання був значним?

3) Як можна візуалізувати ефект функції передачі (побудувати його?)

4) Чи є спосіб оцінити, наскільки втручання збільшило обсяг продукції через "х" місяців? Я думаю, що для цього (а може бути, і №3) я запитую, як працювати з рівнянням моделі - якби це була проста лінійна регресія з фіктивними змінними (наприклад), я б міг запускати сценарії з втручанням і без нього, і вимірювати вплив - але я просто не впевнений, як працювати з цією моделлю.

ДОДАТИ

На запит, ось залишки двох параметрів.

Спочатку від пристосування:

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)))

plot(resid(fit), type="b")

Тоді, від цього підходять

mod.arimax <- arimax(log(cds), order=c(1, 0, 0),
                     seasonal=list(order=c(0, 0, 0), frequency=12),
                     include.mean=TRUE,
                     xtransf=data.frame(Oct13=1 * (seq(cds) == 22)),
                     transfer=list(c(1, 1))) 

mod.arimax
plot(resid(mod.arimax), type="b")

Модель AR (1) з втручанням, визначеним у рівнянні, наведеному у питанні, може бути встановлена, як показано нижче. Зауважте, як визначено аргумент transfer; вам також потрібна одна змінна індикатора в xtransfдля кожного з втручань (зміни пульсу і минущі):

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

$\omega_0$$\omega_1$coeftest

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\%$

Ефект втручання можна кількісно оцінити наступним чином:

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)

Ви можете побудувати ефект від втручання наступним чином:

plot(100 * (intv.effect - 1), type = "h", main = "Total intervention effect")

$\omega_2$$1$$\omega_2$$1$

Чисельно, це приблизно оцінені збільшення у кожний момент часу, викликані втручанням у жовтні 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

$\omega_2$$0.9231$xreg$\omega_2$

Ці втручання еквівалентні адитивній грубій формі (AO) і перехідній зміні (TC), визначеній в упаковці tsoutliers. Цей пакет можна використовувати для виявлення цих ефектів, як показано у відповіді @forecaster, або для побудови регресорів, які використовувалися раніше. Наприклад, у цьому випадку:

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

Редагуйте 1

Я бачив, що рівняння, яке ви дали, можна переписати як:

і його можна вказати, як ви робили за допомогою transfer=list(c(1, 1)).

Як показано нижче, ця параметризація приводить у цьому випадку до оцінок параметрів, які передбачають інший ефект порівняно з попередньою параметризацією. Це нагадує мені ефект інноваційного випередження, а не пульсу плюс минущої зміни.

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

Я не дуже знайомий з позначенням пакету, TSAале думаю, що ефект від втручання зараз можна кількісно оцінити так:

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)")

Ефект зараз можна описати як різке зростання у жовтні 2013 року з подальшим зменшенням у зворотному напрямку; тоді ефект від втручання зникає швидко чергуючи позитивні та негативні наслідки зменшення ваги.

Цей ефект є дещо своєрідним, але може бути можливим у реальних даних. На даний момент я хотів би розглянути контекст ваших даних та події, які можуть вплинути на ці дані. Наприклад, чи відбулася зміна політики, маркетингова кампанія, відкриття, ... що може пояснити втручання в жовтні 2013 року. Якщо так, то чи розумнішим є те, що ця подія впливає на дані, описані раніше або як ми з’ясували з початковою параметризацією?

$-18.94$$-15.42$

$0.9$

Редагувати 2

$\omega_2$$\omega_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")

$\omega_2 = 0.88$$0.9$$\omega_2=1$

$\omega_2=0.9$

$\omega_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)))

Прогнози можна отримати та відобразити так:

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")

Перші прогнози відносно добре відповідають спостережуваним значенням (сіра пунктирна лінія). Решта прогнозів показують, як серія продовжить шлях до початкової середньої. Інтервали довіри, тим не менш, великі, що відображає невизначеність. Тому слід бути обережними та переглянути модель, коли записуються нові дані.

$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")

Іноді менше - більше. Маючи 30 спостережень, я подав дані до AUTOBOX, програмного забезпечення, яке я допоміг розробити. Я подаю наступний аналіз у надії отримати нагороду +200 (просто жартую!). Я побудував фактичні та очищені цінності, які наочно підказують вплив "недавньої діяльності". . Тут показана модель, яка була автоматично розроблена. і тут . Тут представлені залишки цієї досить простої зсувної серії . Зразкова статистика тут . Підсумовуючи, були втручання, які можна було емпірично ідентифікувати за допомогою процесу ARIMA; два імпульси та зсув 1 рівня . Графік фактичного / відповідного та прогнозування надалі підкреслює аналіз.

Я, наприклад, хотів би побачити сюжет залишків із зазначених раніше і, на мою думку, потенційно занадто визначених моделей.

$R$

Нижче наведено код:

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")
arimatr <- tsoutliers::tso(cds,args.tsmethod=list(d=0,D=0))
plot(arimatr)
arimatr

Нижче наведено оцінку, у жовтні 2013 року спостерігалося збільшення на 2356,3 одиниці зі стандартною помилкою ~ 481,8 і надалі впливає на зменшення. Функція автоматично ідентифікувала AR (1). Мені довелося зробити пару ітерацій і зробити як сезонне, так і несезонне розмежування на 0, що відображається на args.tsmethod у функції tso.

Series: cds 
ARIMA(1,0,0) with non-zero mean 

Coefficients:
         ar1  intercept       TC22
      0.5969  3034.6560  2356.2914
s.e.  0.1495   206.5202   481.7981

sigma^2 estimated as 209494:  log likelihood=-219.03
AIC=446.06   AICc=447.73   BIC=451.53

Outliers:
  type ind    time coefhat tstat
1   TC  22 2013:10    2356 4.891

Нижче наведено сюжет, tsoutlier - це єдиний пакет, про який я знаю, який може надрукувати тимчасові зміни це добре у сюжеті.

Цей аналіз, сподіваємось, дав відповідь на ваші 2, 3 та 4 запитання, хоча і з використанням іншої методології. Особливо сюжет та коефіцієнти забезпечували ефект від цього втручання і що було б, якби у вас не було цього втручання.

Також сподіваюся, що хтось інший може повторити цей сюжет / аналіз, використовуючи моделювання функції передачі в Р. Я не впевнений, чи можна це зробити в R, можливо, хтось ще може нас перевірити на цьому.