r - 按月分组的年龄组

Question

我正在努力寻找以下问题的解决方案。我有一个带有 id's/ dob's 的 df和另一个monthbucket df如下

set.seed(33)

df <- data.frame(dob = sample(seq(as.Date('1940/01/01'), as.Date('2010/01/01'), by="day"), 10),
                 id = seq(1:10) )


monthbucket <- data.frame(month = format(seq(as.Date("2010-01-01"),as.Date("2011-01-01"),by="months"),'%Y-%m'),
                          startmonth = seq(as.Date("2010-01-01"),as.Date("2011-01-01"),by="months"),
                          endmonth = seq(as.Date("2010-02-01"),as.Date("2011-02-01"),by="months")-1)

我想得到一个输出，它给出了年龄组内的成员数(<19, 19-64, >64)对于我每个月的存储桶。当人们过生日时，计数显然会转换年份。

我得到了类似这样的年龄计算:

age.fct <- function(dob, bucketdate) {

  period <- as.period(interval(dob, bucketdate),unit = "year")
  period$year}

我想一般的方法是计算每个月桶的年龄，分配到 3 age groups 之一并按月计算。有什么建议吗？

编辑 1.

感谢所有不同的方法，我只是对解决方案进行了简短的基准测试，以确定接受哪个答案。不知何故，数据表解决方案不适用于我的测试数据集，但我会在接下来的几分钟内尽快检查。

set.seed(33)

df <- data.frame(dob = sample(seq(as.Date('1940/01/01'), as.Date('2010/01/01'), by="day"), 10000),
                 id = seq(1:10000) )


monthbucket <- data.frame(month = format(seq(as.Date("2010-01-01"),as.Date("2011-01-01"),by="months"),'%Y-%m'),
                          startmonth = seq(as.Date("2010-01-01"),as.Date("2011-01-01"),by="months"),
                          endmonth = seq(as.Date("2010-02-01"),as.Date("2011-02-01"),by="months")-1)


birth_days <- df$dob
month_bucket <- monthbucket$startmonth

和基准

microbenchmark::microbenchmark(
  MM=  monthbucket %>% group_by_all %>% expand(id=df$id) %>%  left_join(.,{df %>% mutate(birth_month =cut(dob, "month"))},by="id") %>%  mutate(age=time_length(difftime(startmonth, birth_month),"years")) %>% 
    mutate(age_cat=case_when(age<19 ~ "<19", age>64 ~ ">64",TRUE ~ "19-64")) %>%  group_by(month) %>% count(age_cat) %>%  gather(variable, count, n) %>%
    unite(variable, age_cat) %>% spread(variable, count)
  ,
  AkselA = {ages <- as.data.frame(t(unclass(outer(monthbucket$startmonth, df$dob, "-")/365.25)))
  ages <- do.call(data.frame, lapply(ages, cut, c(0, 19, 64, Inf), c("0-19", "19-64", "64+")))
  ages <- sapply(ages, table)
  colnames(ages) <- monthbucket$month
  },
  Cole1 ={t(table(apply(X = outer(month_bucket, birth_days, `-`) / 365.25, MARGIN = 2, FUN = cut, c(0,19,65, Inf)), rep(format(month_bucket,'%Y-%m'), length(birth_days))))
   },
  # cole2={ cast(CJ(month_bucket, birth_days)[, .N, by = .(month_bucket , cut(as.numeric(month_bucket - birth_days)/365.25, c(0,19,65,Inf)))], month_bucket ~ cut, value.var = 'N')
  # },
  # 
  Cole3={crossing(month_bucket, birth_days)%>%count(month_bucket, age_range = cut(as.numeric(month_bucket - birth_days) / 365.25, c(0,19,65,Inf)))%>%spread(age_range, n)
  },

  Cole4={all_combos <- expand.grid(month_bucket =  month_bucket, birth_days = birth_days) 
  all_combos$age <- as.numeric(all_combos$month_bucket - all_combos$birth_days) / 365.25
  all_combos$cut_r <- cut(all_combos$age, c(0,19,65,Inf))
  reshape(data = aggregate( all_combos$month_bucket, by = list(bucket = all_combos$month_bucket,age_group = all_combos$cut_r), FUN = length), timevar = 'age_group' , idvar = 'bucket', direction = 'wide'  )
},
times = 1L)

Unit: milliseconds
   expr        min         lq       mean     median         uq        max neval
     MM 4249.02810 4249.02810 4249.02810 4249.02810 4249.02810 4249.02810     1
 AkselA   17.12697   17.12697   17.12697   17.12697   17.12697   17.12697     1
  Cole1 3237.94534 3237.94534 3237.94534 3237.94534 3237.94534 3237.94534     1
  Cole3   23.63945   23.63945   23.63945   23.63945   23.63945   23.63945     1
  Cole4  877.92782  877.92782  877.92782  877.92782  877.92782  877.92782     1

基于速度，AkselA 的方法似乎是最快的，但与所有其他方法相比，M-M 的方法得到了不同的结果(一旦 AkselA 在剪切部分 cut, c(0, 19, 64, Inf).. 中更改为 65。我将接受基于速度的答案，但将研究结果的差异!

Answer 1

不是很复杂，但我加入了两个表(首先在 df$id 上扩展了 monthbucket)然后计算了年龄(因为你有整个月，我只是用出生月份的第一天和 startmonth 计算出 difftime)。然后，对于每个月(桶)，我计算了不同年龄段的数量，最后将长格式转换为宽格式以便更好地说明。

library(lubridate)
library(tidyverse)

monthbucket %>% 
  group_by_all %>% 
  expand(id=df$id) %>% 
  left_join(.,{df %>%
                mutate(birth_month =cut(dob, "month"))},
            by="id") %>% 
  mutate(age=time_length(difftime(startmonth, birth_month),"years")) %>% 
  mutate(age_cat=case_when(age<19 ~ "<19",
                           age>64 ~ ">64",
                           TRUE ~ "19-64")) %>% 
  group_by(month) %>% 
  count(age_cat) %>% 
  gather(variable, count, n) %>%
  unite(variable, age_cat) %>% 
  spread(variable, count)

#> # A tibble: 13 x 4
#> # Groups:   month [13]
#>    month   `<19` `>64` `19-64`
#>    <fct>   <int> <int>   <int>
#>  1 2010-01     3     2       5
#>  2 2010-02     3     2       5
#>  3 2010-03     3     2       5
#>  4 2010-04     3     2       5
#>  5 2010-05     3     2       5
#>  6 2010-06     3     2       5
#>  7 2010-07     3     2       5
#>  8 2010-08     3     2       5
#>  9 2010-09     3     2       5
#> 10 2010-10     3     2       5
#> 11 2010-11     3     2       5
#> 12 2010-12     3     2       5
#> 13 2011-01     3     2       5

^{由 reprex package 于 2019-07-03 创建(v0.3.0)}