为长格式数据集补全缺失观测行：解决随机日期重复问题

需求说明 #

• 处理长格式数据集，每个研究对象（id）一周内观测1-3次，观测日期限定为周一至周五
• 若研究对象观测次数不足3次，需生成对应缺失观测的空行补全
• 特殊规则：若某研究对象仅在周一和周五被观测，第三次观测日期必须从周二、周三、周四中随机选择
• 核心约束：补全的日期不能与该研究对象已有的观测日期重复

现有代码及缺陷 #

现有代码能实现基本补全功能，但随机生成的日期可能与研究对象已有的观测日期重复，违反约束。以下是现有代码：

# 示例数据集
dataset_long <- data.frame(
  id = c(1, 1, 2, 2, 2, 3, 3, 4, 5, 5),
  observation = c(1, 2, 1, 2, 3, 1, 2, 1, 1, 2),
  day_name = c("Monday", "Tuesday", "Monday", "Wednesday", "Thursday", "Tuesday", "Thursday", "Wednesday", "Monday", "Friday"),
  scores = sample(20:60, 10)
)

# 识别观测次数少于3次的研究对象
cases_to_fill <- dataset_long %>%
  group_by(id) %>%  # 注：原代码中误用`case`，实际数据集列名为`id`，此处修正
  summarize(days_observed = n()) %>%
  filter(days_observed < 3) %>%
  ungroup()

# 创建包含所有日期的向量
all_days <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")

# 随机填充缺失的观测日期
cases_to_fill_long <- cases_to_fill %>%
  mutate(missing_day = map(days_observed, ~sample(all_days, 3 - .x))) %>%
  unnest(missing_day) %>%
  mutate(observation = 3)

# 将补全的行与原数据集合并
dataset_long_filled <- dataset_long %>%
  full_join(cases_to_fill_long, by = c("id", "observation")) %>%
  arrange(id, observation)

# 合并两个日期列
dataset_long_filled |> 
  mutate(day = coalesce(day_name, missing_day)) |> 
  select(-days_observed, -missing_day)

缺陷示例：部分补全的日期与已有日期重复（如id=3补全了Tuesday，和已有观测日期重复）

解决方案代码 #

以下是全新实现方案，严格避免日期重复，并满足特殊规则：

library(dplyr)
library(purrr)
library(tidyr)

# 示例数据集
set.seed(123)  # 设置随机种子保证结果可复现
dataset_long <- data.frame(
  id = c(1, 1, 2, 2, 2, 3, 3, 4, 5, 5),
  observation = c(1, 2, 1, 2, 3, 1, 2, 1, 1, 2),
  day_name = c("Monday", "Tuesday", "Monday", "Wednesday", "Thursday", "Tuesday", "Thursday", "Wednesday", "Monday", "Friday"),
  scores = sample(20:60, 10)
)

# 定义所有工作日向量
all_weekdays <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")

# 按id分组处理每个研究对象的补全逻辑
filled_dataset <- dataset_long %>%
  group_by(id) %>%
  nest() %>%
  mutate(
    # 提取已有日期和观测次数
    existing_days = map(data, ~.$day_name),
    obs_count = map_int(data, nrow),
    # 计算需要补全的观测次数
    need_fill = 3 - obs_count,
    # 生成符合规则的补全日期
    fill_days = pmap(list(existing_days, need_fill), function(days, n) {
      if (n == 0) {
        return(NULL)
      }
      # 筛选可用日期：排除已有日期
      available_days <- setdiff(all_weekdays, days)
      # 特殊规则：如果已有日期是周一+周五，强制从中间三天选
      if (identical(sort(days), c("Friday", "Monday"))) {
        available_days <- intersect(available_days, c("Tuesday", "Wednesday", "Thursday"))
      }
      # 随机抽取n个不重复的日期
      sample(available_days, n, replace = FALSE)
    }),
    # 生成补全的观测行
    fill_rows = pmap(list(id, fill_days, obs_count), function(subj_id, days, count) {
      if (is.null(days)) {
        return(NULL)
      }
      data.frame(
        id = subj_id,
        observation = (count + 1):3,
        day_name = days,
        scores = NA_integer_
      )
    })
  ) %>%
  # 合并原数据和补全行
  unnest(c(data, fill_rows)) %>%
  # 按id和观测次数排序
  arrange(id, observation) %>%
  ungroup()

# 查看结果
print(filled_dataset)

代码说明 #

• 按id分组处理每个研究对象，确保补全日期仅从该对象未观测过的日期中选择
• 加入特殊规则判断：当已有日期为周一和周五时，仅从周二、周三、周四中随机抽取补全日期
• 使用setdiff()排除已有日期，保证补全日期不重复
• 用nest()和unnest()处理分组数据，逻辑清晰易维护

内容的提问来源于stack exchange，提问作者Michael Matta