Question

我有一个数据框df，其中包含有唯一身份证号码的个人接种疫苗日期的数据。如果一个人在两岁前接受了三次疫苗接种，就被视为接种疫苗。我的目的是计算完全接种疫苗的个体的累积总和，其最终目标是绘制完全接种疫苗和任何给定时间的3岁以下人群的比例x。在我看来，我已经提出了完美的代码，但我的直觉由于某种原因而失败，并且在时间段结束时我得到了一个奇怪的增长。见下文。

经过大量数据争论后，我们使用数据框df启动示例数据，其中每一行都是一个疫苗接种事件，一个列数据框date包含感兴趣的时间段中的每个日期。 / p>

glimpse(df)
Observations: 50,469
Variables: 6
$ id          <chr> "1000038", "1000038", "1000038", "1000128", "1000380",... 
$ n_max       <int> 3, 1, 1, 3, 3, 3, 3,...  ###total num times before 2 years old
$ age_y       <int> 0, 0, 0, 0, 1, 0, 0,... ###current age for this observation
$ age_m       <int> 3, 5, 11, 3, 4,... ###current age in months for this obs
$ date_vacc   <date> 2013-05-08, 2013-07-03, 2014-01-13,... ###current date obs
$ year        <dbl> 2013, 2013, 2014, 2013,... ###current year of obs

glimpse(date)
Observations: 4,017
Variables: 1
$ date_vacc <date> 2005-01-01, 2005-01-02, 2005-01-03, 2005-01-04, 2005-01-05, 2005-01-06, 2005-01-07, 2005-01-08, 2005-01-09, 20...

现在我利用df的结构来改变每行的含义＆＃39;。此时，每一行代表对单一疫苗事件的观察，以下代码，首先i)使每一行代表个体接受其最后一次疫苗剂量的日期，无论他是否收到1,2或3总共。然后ii)它会改变行的含义，以表示在给定日期接受最后一次剂量的个体数量。

df <-
    df[!duplicated(dfid, fromLast = TRUE),] %>% ###i)
    droplevels() %>%
    right_join(date) %>%
    group_by(date_vacc) %>%
    summarise(nsum = n_distinct(id, na.rm = TRUE)) ###ii)

df$nsum <-
    ifelse(is.na(df$nsum),
           0,
           df$nsum)

最后，此代码假设将过去两年内接受最终剂量的人数加在一起，并作为滚动总和，接近完全接种疫苗的两岁儿童的数量在任何给定日期的人口中x。因为它在固定的时间间隔内总和，所以我认为它应该进入一个稳定的状态，在那里人们会退出＆＃39;是

lag_vacc <- 2 * 365.25
df$lagsum <- rep(NA, nrow(df))

for (i in (dim(df)[1] - (dim(df)[1] - lag_vacc)):dim(df)[1]) {
    df$lagsum[i] <-
        sum(df$nsum[(i - lag_vacc):i])
}

然而，如果我然后绘制这个，我得到一个非常奇怪的结果，我不能解释或纠正我的生活。

ggplot(df,
   aes(x = date_vacc, y = lagsum)) +
geom_point()

正如预测的那样，它达到稳定状态。然后再次开始增加并最终成为人口的1.3，即接种疫苗的人数超过存在人数。这不再具有任何实际意义，甚至是表示这些数据的愚蠢方式。但我无法弄清楚我的推理不正确的地方。为什么这不起作用？有更好的方法吗？

编辑：经过几天的几个小时，我觉得我终于弄明白了。作为回顾，上述代码根据他们的“最后一天”的日期计算接种个体的滚动累积总和。三剂疫苗的剂量。总结最后一个＆＃39;剂量（代表第二或第三剂量取决于具体情况）是理想的，因为即使没有第三剂量和最后一剂量，两剂量也能在生命的前4-5年内提供良好的保护。因为在x轴（31-12-2015）的末端有一个截止点，否则将会收到他们的第三个和最后一个＆＃39;在该点之后的剂量，而是过早地输入累积总和，因为他们的第二剂被确定为他们的最后一次＆＃39;

EDIT2：以下代码生成人口分母，以生成与上图非常相似的图像 - 但将y轴转换为比例而不是计数。

df_pop <-
pop %>%
mutate(year = as.integer(year)) %>%
filter(grepl("all", pop$gender), age_y >= 1, age_y <= 2, year >= 2005) %>%
select(age_y, year, at_risk) %>%
group_by(year) %>%
summarise(n_atrisk = sum(at_risk))

df <-
df %>%
mutate(year = year(date_vacc)) %>%
left_join(df_pop) %>%
mutate(prop = lagsum / n_atrisk)

ggplot(df,
   aes(x = date_vacc, y = prop)) +
geom_line() +
scale_x_date(date_breaks = "1 year", date_labels = "%Y") +
scale_y_continuous(breaks = pretty(df$prop, n = 10)) +
theme_bw()

dput(head(df, n = 20))
structure(list(date_vacc = structure(c(12784, 12785, 12786, 12787, 
12788, 12789, 12790, 12791, 12792, 12793, 12794, 12795, 12796, 
12797, 12798, 12799, 12800, 12801, 12802, 12803), class = "Date"), 
    nsum = c(0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 
    0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L), lagsum = c(NA_integer_, 
    NA_integer_, NA_integer_, NA_integer_, NA_integer_, NA_integer_, 
    NA_integer_, NA_integer_, NA_integer_, NA_integer_, NA_integer_, 
    NA_integer_, NA_integer_, NA_integer_, NA_integer_, NA_integer_, 
    NA_integer_, NA_integer_, NA_integer_, NA_integer_), year = c(2005, 
    2005, 2005, 2005, 2005, 2005, 2005, 2005, 2005, 2005, 2005, 
    2005, 2005, 2005, 2005, 2005, 2005, 2005, 2005, 2005), n_atrisk = c(8422L, 
    8422L, 8422L, 8422L, 8422L, 8422L, 8422L, 8422L, 8422L, 8422L, 
    8422L, 8422L, 8422L, 8422L, 8422L, 8422L, 8422L, 8422L, 8422L, 
    8422L), prop = c(NA_real_, NA_real_, NA_real_, NA_real_, 
    NA_real_, NA_real_, NA_real_, NA_real_, NA_real_, NA_real_, 
    NA_real_, NA_real_, NA_real_, NA_real_, NA_real_, NA_real_, 
    NA_real_, NA_real_, NA_real_, NA_real_)), .Names = c("date_vacc", 
"nsum", "lagsum", "year", "n_atrisk", "prop"), row.names = c(NA, 
-20L), class = c("tbl_df", "tbl", "data.frame"))

Answer 1

好的，所以你不要指望一个稳定的值，而是围绕一些渐近线的“振荡”，对吗？在你的代码中，有一件事对我来说似乎有些奇怪。这一行：

for (i in (dim(df)[1] - (dim(df)[1] - lag_vacc)):dim(df)[1])

，如果我们做数学删除括号似乎最终为：

for (i in (lag_vacc:dim(df)[1])

这对我来说似乎不正确。不应该简单地说：

for (i in ((dim(df)[1] - lag_vacc):dim(df)[1])

也许我错了，但那可能是罪魁祸首。

此外，您可以考虑使用rollapply代替移动窗口的累积总和。

Answer 2

确定。让我们再试一次。在评论讨论的基础上，我会试着找出答案。

据我所知，您的分析只需要：

包含特定人口的ID和出生日期的数据框
一个数据框，其中包含给定身份证接种疫苗的日期

由于您无法提供数据，我将创建合成数据：

  library(ggplot2)
  library(dplyr)
  library(data.table)
  # build regular date array
  date <- data_frame(date_vacc = as.Date(as.Date("2005-01-01"):as.Date("2015-12-31"),
                                         origin = as.Date("1970-01-01")))
  # build a fake population of 5000 people born between 2005 and 2015
  n_people = 5000
  birth_date <- sample(date$date_vacc, n_people, replace = TRUE, set.seed(1))
  ids = as.factor(as.character(1:n_people))
  mypop = data.table(id = ids, birth = birth_date, key = "id") %>%  arrange(birth)
  qplot(mypop$birth, binwidth = 60, geom = "bar" )+theme_bw()

因此，这满足了（合理）恒定出生率的假设

现在，让我们创建一些假的疫苗接种数据并将其与人口数据集连接起来。在这里，我任意假设孩子在3个月左右第一次射击，第二次在6个月左右，第三次在一年左右，随机分散一个月。

# build fake vaccinations dataset
listout = list()

for (p in seq(along = mypop$id)) {
    indiv = mypop[p,]  # take one subject
    vaccs = c(indiv$birth + sample(seq(90,120),1),  # first vaxx at 3 months
              indiv$birth + sample(seq(180,210),1), # secodn at 6 months
              indiv$birth + sample(seq(365,395),1)) # third at one year
    vaccs = vaccs[vaccs >= "2009-01-01"]   # assume first vaccinations started in 2009
    if (length(vaccs) > 0 ){
      data = data.frame(id = as.character(indiv$id), birth = indiv$birth, date_vacc = vaccs, 
                        n_vacc = 1:length(vaccs))
      listout[[p]] = data
    } 
  }

  df = rbindlist(listout)
  df$id = as.factor(df$id)
  # Here I randomly remove some vaccinations: assume that only 95% of childs are usually vaccinated !
  vacc = sample(mypop$id, 0.95*length(mypop$id))
  df = subset(df, id %in% vacc)

  # Join the "population" data frame with the "vaccinations" one
  dftot = full_join(mypop, df) %>% arrange(birth,date_vacc,id)
  summary(dftot)


  id                birth              date_vacc              n_vacc     
Length:11364       Min.   :2005-01-01   Min.   :2009-01-01   Min.   :1.000  
Class :character   1st Qu.:2009-06-01   1st Qu.:2010-10-22   1st Qu.:1.000  
 Mode  :character   Median :2011-07-31   Median :2012-11-06   Median :2.000  
                Mean   :2011-06-30   Mean   :2012-10-30   Mean   :1.969  
                3rd Qu.:2013-12-13   3rd Qu.:2014-10-30   3rd Qu.:3.000  
                Max.   :2015-12-31   Max.   :2017-01-27   Max.   :3.000  
                                     NA's   :1565         NA's   :1565

在这里，NA对应于从未接种过疫苗的人：在2009年之前出生，或因其他原因未接种疫苗。现在让我们试着回答你原来的问题：在任何一天，2岁以下的受试者中有多少人接受了最后一次（第3次）接种疫苗：

percs = list()
for (d in 1:length(date$date_vacc)){
  dd <- date$date_vacc[d]

  #Now  establish our population of interest: people below 2 years old at date dd
  pop_sub <- dftot %>% 
    filter(birth < dd) %>%              #Remove not yet born
    filter(birth > (dd - 365.25*2))  # Remove older than 2 years

  # number of subjects to consider
  n_sub = length(unique(pop_sub$id))

  # Now Find subsample with 3 shots 
  perc <- pop_sub %>% 
    filter(date_vacc <= dd |is.na(date_vacc))  %>%   # remove all vaccinations made after current date analyzed
    group_by(id)  %>% # gropu by id and find the last vaccination shot (1,2,3)
    summarise(lastvacc = max(n_vacc)) %>% 
    filter(lastvacc == 3) # Get only people with 3 shots

  # number of "fully vaccinated"
  n_vacc = length(perc$id)

  percs[[d]] = data.frame(date = dd, perc = n_vacc/n_sub)

}
percs_df = rbindlist(percs)
ggplot(percs_df, aes(x = date, y = perc)) + geom_line(aes(group = 1))+
  scale_x_date(date_breaks = "18 months") + theme_bw()

起初，我认为分析是错误的。然而，更好地思考它是显而易见的：因为我假设孩子在一岁左右得到第三次射击，看着两岁以下的人中有三次射击我不可避免地会看到大约50％的东西，因为有一半的孩子还没有一岁，因此没有获得第三次射击！

然而，根据您的评论，我认为您实际上有兴趣回答一个相当不同的问题，即：在任何日期，2岁以下的受试者中有多少百分比是没有风险？这似乎也更有趣＆＃34;题！

为了回答这个问题，我认为你需要做出一些假设。特别是要定义不同的拍摄时间和拍摄时间。提供免疫接种。在这里，我实际上是随机数字，但根据你的评论，我暗示第一次注射给予4个月免疫，第2次和第3次给予3年。（这样，如果一个孩子获得第二次射击，如果他没有获得第三次射击就不算数）。可能性是这样的：

percsimm = list() duration_1st <- 130 # first shot immunizes for 4 months duration_2nd <- 365.25*3 # second shot immunizes for 3 years duration_3rd <- 365.25*3 for (d in 1:length(date$date_vacc)){ dd <- date$date_vacc[d] # establish our population of interest: people below 2 years old at date dd pop_sub <- dftot %>% filter(birth < dd) %>% #Remove unborn kids filter(birth > (dd - 365.25*2)) # Remove kids older than 2 years n_sub = length(unique(pop_sub$id)) perc <- pop_sub %>% filter(date_vacc <= dd |is.na(date_vacc)) %>% # remove all vaccinations made after current date analyzed group_by(id) %>% mutate(lastvacc = last(n_vacc)) %>% # find the last vaccination for the subject filter(row_number() %in% c(n())) %>% # extract it from the df mutate(timetolast = as.numeric(dd - date_vacc)) %>% # how much time elapsed since last shot ? mutate(immune = ifelse((lastvacc == 1 & timetolast <= duration_1st) | # Is subject still immune ? (lastvacc == 2 & timetolast <= duration_2nd) | (lastvacc == 3 & timetolast <= duration_3rd), 1, 0)) %>% filter(immune == 1) # Get only people with 3 shots n_immune= length(perc$id) percsimm[[d]] = data.frame(date = dd, perc = n_immune/n_sub) } percsimm_df = rbindlist(percsimm) ggplot(percsimm_df, aes(x = date, y = perc)) + geom_line(aes(group = 1)) + scale_x_date(date_breaks = "18 months") + theme_bw()

绝对更好，（希望）你想要完成的事情。

我们获得了相当稳定的80％免疫率。这是有道理的，如果你认为1）我任意假设5％的人口从未接种疫苗，2）如果平均第一次射击是在3个月时给出，那么0-3个月的部分人口 - 对应大约12％ - 不能＆＃34;免疫＆＃34;

当然，对于真实数据，这将会改变：我用来定义镜头时间的间隔是＆＃34;随机＆＃34;，以及假定的免疫接种＆＃34;持续时间＆＃34; （这可能是由于2009年底的perc下降所显示的：第1次和第2次注射之间的空间太大以及短期免疫导致可能导致perc的短暂下降。如果我们是看一下perc振荡的频率，我们会看到一个类似于第一次注射免疫的长度的时期....）
PS：我希望我没有在这里犯下可怕的错误或假设 - 我在一个完全不同的研究领域工作。所以，如果上述任何内容都没有意义告诉我，我会删除它。然而，应用于这个问题很好，也因为我设法学习了新的＆＃34;笔记本电脑＆＃34; RStudio的功能...整洁!!!

计算事件累计总和

2 个答案: