如何在中斷的分段時間序列回歸中向ggplot添加線性段

Question

我已經安裝了一個中斷的時間序列回歸來計算數據，並希望顯示與此類似的結果

取自：Lindstrand A，Bennet R，Galanis I，et al。 引入肺炎球菌結合疫苗后鼻竇炎和肺炎住院治療。 兒科。 2014; 134（6）：e1528-36。 DOI：10.1542 / peds.2013-4177。

具體來說，我正在嘗試（和失敗）再現的是分別添加品紅色和青色趨勢線。 我一直試圖在ggplot中這樣做。 問題是我的模型適合作為glm(family = poisson)因此系數不在原始尺度上。 更復雜的是，我提供了風險總體作為偏移量，即glm(count ~ ., offset(log(at_risk)), family = poisson, data = df)但是想要將數據顯示為(count / at_risk)*1000 Y軸上的(count / at_risk)*1000 。

set.seed(42)
int = 85
df <- data.frame(
    count = as.integer(rpois(132, 9) + rnorm(132, 1, 1)),
    time = 1:132,
    at_risk = rep(
        c(4305, 4251, 4478, 4535, 4758, 4843, 4893, 4673, 4522, 4454, 4351),
        each  = 12
    )
)
df$month <- factor(month.name, levels = month.name)
df$intv <- ifelse(df$time >= int, 1, 0)
df$intv_trend <- c(rep(0, (int - 1)),
                   1:(length(unique(df$time)) - (int - 1)))
df <-
    df %>%
    mutate(lag_count = dplyr::lag(count))

fit <- glm(
    count ~ month + time + intv + intv_trend +
        log(lag_count) + offset(log(at_risk)),
    family = "poisson",
    data = df
)
df$fit <- exp(c(NA, predict(fit)))


ggplot(df, aes(x = time, y = (fit / at_risk) * 1000)) +
    geom_line()

（我已經繪制了我希望能夠創建到生成的ggplot行圖中的行）

有一個連續的長期趨勢time由偽方程count ~ intercept + B1 * time ，我想截斷它使得它在大約time = 72時停止。 這類似於上圖中的洋紅色線。 干預intv發生在time = 85 ，這導致水平intv變化和斜率intv_trend變化。 intv效果線相對於時間的偽代碼是count ~ intercept + intv + B1 * time + B2* intv_trend ，類似於上面的青色線。

我嘗試使用不同版本的exp(coef(fit)[1] ...等等exp(coef(fit)[1] ... geom_abline() ，但我無法在繪圖中顯示該行。

有什么想法嗎？

Answer 1

正如我在評論中所說，如果您有一種識別變化點的方法，您可以添加一個名為，例如， group和標記預測線Control的第一部分和第二個Intervention （或您喜歡的任何標簽）的列。 然后在你的情節中使用group作為顏色美學來獲得兩條不同的線條。 在下面的代碼中，我手動添加了分組變量。 要獲得有關數據規模的預測，請添加type="response"進行predict 。

首先，設置數據：

library(ggplot2)
library(dplyr)

int = 85
set.seed(42)
df <- data.frame(
  count = as.integer(rpois(132, 9) + rnorm(132, 1, 1)),
  time = 1:132,  
  at_risk = rep(
    c(4305, 4251, 4478, 4535, 4758, 4843, 4893, 4673, 4522, 4454, 4351),
    each  = 12
  )
)

df$month <- factor(month.name, levels = month.name)
df$intv <- ifelse(df$time >= int, 1, 0)
df$intv_trend <- c(rep(0, (int - 1)),
                   1:(length(unique(df$time)) - (int - 1)))
df <- df %>%
  mutate(lag_count = dplyr::lag(count))

創建模型並獲得預測：

fit <- glm(
  count ~ month + time + intv + intv_trend +
    log(lag_count) + offset(log(at_risk)),
  family = "poisson",
  data = df
)

df$fit <- exp(c(NA, predict(fit)))

# Get predictions on the same scale as the data
df$fit2 = c(NA, predict(fit, type="response"))

# Add a grouping variable manually
df$group = rep(c("Control","Intervention"), c(72, 132 - 72))

情節：

ggplot(df, aes(x = time, y = fit2)) +
  geom_line() +
  geom_smooth(method="lm", se=FALSE, aes(colour=group)) +
  theme_bw() +
  labs(colour="")