0

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

### 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), size = 1000000, 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), size = 1000000, 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_IDs)，共同开始日期为 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 至少晚一天，无论如果 Outcome == 0 或 Outcome == 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 个匹配个体）。

知道如何执行此操作吗？

4

1 回答 1

1

这是使用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"), size = 1e6, replace = TRUE), Age = sample(c(1:100), size = 1e6, 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, out_vec, idx + size + 1L))
}

# order the dataset by Sex, Age, and Exposure_Date, and mark as sorted
setkey(dt, Sex, Age, 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, Exposure_Date, 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 个人，每个集中的第一个是暴露者。

于 2021-06-24T14:20:23.433 回答