Оцінка точки розриву в розбитій палиці / кусково-лінійній моделі з випадковими ефектами в R [код і вихід включені]

Може хто-небудь скажіть, будь ласка, як R оцінити точку розриву в кусково-лінійній моделі (як фіксований або випадковий параметр), коли мені також потрібно оцінити інші випадкові ефекти?

Нижче я включив приклад іграшки, що відповідає регресії хокейної палиці / розбитої палиці зі випадковими відхиленнями нахилу та випадковою відхиленням y-перехоплення для точки перерви 4. Я хочу оцінити точку перерви, а не вказувати її. Це може бути випадковий ефект (бажано) або фіксований ефект.

library(lme4)
str(sleepstudy)

#Basis functions
bp = 4
b1 <- function(x, bp) ifelse(x < bp, bp - x, 0)
b2 <- function(x, bp) ifelse(x < bp, 0, x - bp)

#Mixed effects model with break point = 4
(mod <- lmer(Reaction ~ b1(Days, bp) + b2(Days, bp) + (b1(Days, bp) + b2(Days, bp) | Subject), data = sleepstudy))

#Plot with break point = 4
xyplot(
        Reaction ~ Days | Subject, sleepstudy, aspect = "xy",
        layout = c(6,3), type = c("g", "p", "r"),
        xlab = "Days of sleep deprivation",
        ylab = "Average reaction time (ms)",
        panel = function(x,y) {
        panel.points(x,y)
        panel.lmline(x,y)
        pred <- predict(lm(y ~ b1(x, bp) + b2(x, bp)), newdata = data.frame(x = 0:9))
            panel.lines(0:9, pred, lwd=1, lty=2, col="red")
        }
    )

Вихід:

Linear mixed model fit by REML 
Formula: Reaction ~ b1(Days, bp) + b2(Days, bp) + (b1(Days, bp) + b2(Days, bp) | Subject) 
   Data: sleepstudy 
  AIC  BIC logLik deviance REMLdev
 1751 1783 -865.6     1744    1731
Random effects:
 Groups   Name         Variance Std.Dev. Corr          
 Subject  (Intercept)  1709.489 41.3460                
          b1(Days, bp)   90.238  9.4994  -0.797        
          b2(Days, bp)   59.348  7.7038   0.118 -0.008 
 Residual               563.030 23.7283                
Number of obs: 180, groups: Subject, 18

Fixed effects:
             Estimate Std. Error t value
(Intercept)   289.725     10.350  27.994
b1(Days, bp)   -8.781      2.721  -3.227
b2(Days, bp)   11.710      2.184   5.362

Correlation of Fixed Effects:
            (Intr) b1(D,b
b1(Days,bp) -0.761       
b2(Days,bp) -0.054  0.181

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

library(lme4)
str(sleepstudy)

#Basis functions
bp = 4
b1 <- function(x, bp) ifelse(x < bp, bp - x, 0)
b2 <- function(x, bp) ifelse(x < bp, 0, x - bp)

#Wrapper for Mixed effects model with variable break point
foo <- function(bp)
{
  mod <- lmer(Reaction ~ b1(Days, bp) + b2(Days, bp) + (b1(Days, bp) + b2(Days, bp) | Subject), data = sleepstudy)
  deviance(mod)
}

search.range <- c(min(sleepstudy$Days)+0.5,max(sleepstudy$Days)-0.5)
foo.opt <- optimize(foo, interval = search.range)
bp <- foo.opt$minimum
bp
[1] 6.071932
mod <- lmer(Reaction ~ b1(Days, bp) + b2(Days, bp) + (b1(Days, bp) + b2(Days, bp) | Subject), data = sleepstudy)

Щоб отримати довірчий інтервал для точки перерви, ви можете використовувати ймовірність профілю . Додайте, наприклад, qchisq(0.95,1)мінімальне відхилення (для 95% довірчого інтервалу), тоді шукайте точки, де foo(x)дорівнює обчисленому значенню:

foo.root <- function(bp, tgt)
{
  foo(bp) - tgt
}
tgt <- foo.opt$objective + qchisq(0.95,1)
lb95 <- uniroot(foo.root, lower=search.range[1], upper=bp, tgt=tgt)
ub95 <- uniroot(foo.root, lower=bp, upper=search.range[2], tgt=tgt)
lb95$root
[1] 5.754051
ub95$root
[1] 6.923529

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

Рішення, запропоноване jbowman, дуже добре, лише додавши кілька теоретичних зауважень:

• Зважаючи на припинення використовуваної функції індикатора, імовірність профілю може бути сильно помилковою, з кількома локальними мінімумами, тому звичайні оптимізатори можуть не працювати. Звичайним рішенням для таких "порогових моделей" є використання замість більш громіздкого пошуку в сітці, оцінюючи відхилення в кожен можливий реалізований день перерви / поріг (а не за значеннями між ними, як це зроблено в коді). Дивіться код внизу.

• У цій нестандартній моделі, де оцінюється точка розриву, відхилення зазвичай не мають стандартного розподілу. Зазвичай використовують більш складні процедури. Дивіться посилання на Hansen (2000) нижче.

• Запуск завантажувального пристрою не завжди є послідовним у цьому плані, дивіться Ю (майбутнє) нижче.

• Нарешті, мені незрозуміло, чому ви перетворюєте дані, переорієнтувавшись навколо днів (тобто, bp - x замість просто x). Я бачу два питання:

  1. За допомогою цієї процедури ви створюєте штучні дні, такі як 6,1 днів, 4,1 тощо. Я не впевнений, як інтерпретувати результат 6.07, наприклад, оскільки ви спостерігали лише значення для 6 та 7 дня? (у стандартній моделі точки перерви будь-яке значення порогу між 6 і 7 повинно давати вам той самий коефіцієнт / відхилення)
  2. b1 і b2 мають протилежне значення, оскільки для b1 днів зменшуються, при цьому збільшуються для b2? Тож неформальний тест на відсутність точки розриву - b1! = - b2

Стандартні посилання на це:

• Стандартний OLS: Hansen (2000) Розщеплення зразків і оцінка порогу, Econometrica, Vol. 68, № 3. (травень 2000 р.), Стор 575–603.
• Більш екзотичні моделі: Lee, Seo, Shin (2011) Тестування порогових ефектів у регресійних моделях, Журнал Американської статистичної асоціації (теорія та методи) (2011), 106, 220-231
• Пінг Ю (в майбутньому) Завантажувальний ремінь у пороговому регресії ", Економетрична теорія.

Код:

# Using grid search over existing values:
search.grid <- sort(unique(subset(sleepstudy, Days > search.range[1] &
Days<search.range[2], "Days", drop=TRUE)))

res <- unlist(lapply(as.list(search.grid), foo))

plot(search.grid, res, type="l")
bp_grid <- search.grid[which.min(res)]

Ви можете спробувати модель MARS . Однак я не впевнений, як вказати випадкові ефекти. earth(Reaction~Days+Subject, sleepstudy)

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