对两个变量执行匹配风险集抽样发生率密度抽样而不进行替换匹配

编程问答 2022-04-22

问题描述

我有一个如下例所示的数据框：

### Packages needed for reproducible example
library(lubridate)
library(dplyr)

### Create data frame:
Person_IDs <- seq(1,1000000,1)
Example_DF <- as.data.frame(Person_IDs)

### Sex and age for matching:
set.seed(2021)
Example_DF$Sex <- sample(c("Male","Female"),size = 1000000,replace = T)
set.seed(2021)
Example_DF$Age <- sample(c(1:100),replace = T)

### Study start and end date (just for clarity):
Example_DF$start_Date <- as.Date("2020-01-01")
Example_DF$End_Date <- as.Date("2021-05-01")

### Study outcome (85% not experiencing the outcome,15% experiencing the outcome):
set.seed(2021)
Example_DF$Outcome <- sample(c(0,1),replace = TRUE,prob = c(0.85,0.15))

### Timestamp for outcome (either as exposed (Outcome = 1) or censored (Outcome = 0):
Example_DF$Timestamp_Outcome <- as.Date("1900-01-01") 
set.seed(2021)
Example_DF$Timestamp_Outcome[Example_DF$Outcome == 1] <- Example_DF$start_Date[Example_DF$Outcome == 1] + days(sample (c(45:295),size=length(unique(Example_DF$Person_IDs[Example_DF$Outcome == 1])),replace =T)) 
set.seed(2021)
Example_DF$Timestamp_Outcome[Example_DF$Outcome == 0] <- Example_DF$start_Date[Example_DF$Outcome == 0] + days(sample (c(275:340),size=length(unique(Example_DF$Person_IDs[Example_DF$Outcome == 0])),replace =T)) 

### Arrange data by timestamp outcome:
Example_DF <- Example_DF %>% arrange(Timestamp_Outcome)

### Show first rows of data frame:
head(Example_DF)

如您所见，有：

  1. 1000000 个唯一个体 (Person_ID)，共同开始日期为 2020-01-01（即所有个体的 Start_Date 列设置为 2020-01-01”）和共同结束日期 (End_Date) 为“2021-05-01”。

  2. 提供了有关性别和年龄的信息，这些信息将用于将 Outcome == 1 的 ID 与控件“匹配”。

  3. 所有个人都有一个结果的日期（结果是结果 == 0 或结果 == 1）。

**我现在要执行的操作称为风险集抽样（或发生率密度抽样）。数据帧按结果时间戳排列，现在：

  1. 每次“算法”遇到 Outcome == 1 的行时，随机选择三 (3) 个具有相同性别、相同年龄和较晚时间戳的 Person_ID（即 Timestamp_Outcome 至少为一天后，无论结果 == 0 还是结果 == 1) 都应该执行。

  2. 这 4 个个体（1 个暴露的个体和 3 个未暴露的个体）然后应该从数据框中删除（即替换 = FALSE），因此不能再次选择（称为无替换采样）。* *

为了在需要时更清楚，请考虑以下示例：

head(Example_DF)

如您所见，Person_ID 1030、1269、3180、4245 等都在 2020-02-15 体验结果。以Person_ID 1030为例，这是一位86岁的女性。因此，她应该与三名在 2020 年 2 月 15 日未暴露的 86 岁女性相匹配（她们可能在 2020 年 2 月 16 日、2020 年 2 月 20 日或以后的任何时间暴露）。如果这不可能，则应选择尽可能多的匹配个体（从 0 到 3 个匹配个体）。

知道如何执行此操作吗？

解决方法

这是使用 data.table 和递归的潜在解决方案：

library(data.table)
library(lubridate)

set.seed(123)

dt <- data.table(Person_IDs = 1:1e6,Start_Date = as.Date("2020-01-01"),Exposure_Date = as.Date("2020-01-01") + days(sample(c(45:365),size = 1e6,replace = TRUE)),End_Date = as.Date("2021-05-01"),Sex = sample(c("Male","Female"),replace = TRUE),Age = sample(c(1:100),replace = TRUE))

matched_risk_sample_rec <- function(id,Exposure_Date,size = 5L,out_vec,idx = 1L) {
  # perform the matched risk sampling
  
  # get the index of the next unexposed person
  idxUnexposed <- sum(Exposure_Date == Exposure_Date[1]) + 1L
  
  if (length(id) - idxUnexposed + 1L < size) {
    # not enough for another sample set
    return(out_vec)
  }
  
  # get a sample set
  sample.id <- c(1L,sample(idxUnexposed:length(id),size = size,replace = FALSE))
  out_vec[idx:(idx + size)] <- id[sample.id]
  # remove the samples and recurse
  return(matched_risk_sample_rec(id[-sample.id],Exposure_Date[-sample.id],size,idx + size + 1L))
}

# order the dataset by Sex,Age,and Exposure_Date,and mark as sorted
setkey(dt,Sex,Exposure_Date)

# add a column for the sample set ordering
# every 6 values of "set_ids" is a sample set of IDs,with the first value being the exposed person id
dt[,set_ids := matched_risk_sample_rec(Person_IDs,5L,rep(NA,.N)),by = .(Sex,Age)]
# rearrange the data.table by the "set_ids" column
# override "set_ids" with a unique ID for each set
dtSamples <- dt[dt[!is.na(set_ids),"set_ids"],on = .(Person_IDs == set_ids)][,set_ids := rep(1:(.N/6L),each = 6L)]

dtSamples 现在有 166588 个样本集，每个样本集 6 人，每集的第一个是暴露的人。

exposurelubridaterrsamplesample