按固定总样本量分层抽样而非分层组量的实现难题

现有含54条观测的数据集，需按指定变量strat_group尽可能均匀下采样至总样本量25。由于部分分层组样本量过小（示例中one组仅2条，小于平均每组5条），直接使用dplyr::group_by()+dplyr::slice_sample()会触发抽样量超过组容量的错误，且不允许通过replace=TRUE重复观测。需求为：先选取样本量不足平均的小组全部样本，再从剩余样本量充足的组中补充样本，最终达到总样本量25，实现无重复的均匀分层下采样。

示例代码及报错 #

df <- data.frame(
  strat_group = c(rep("one", 2), rep("two", 10), rep("three", 5), rep("four", 25), rep("five", 12))
)

strat_group_size <- (25 / length(unique(df$strat_group)))

df |>
  dplyr::group_by(strat_group) |>
  dplyr::slice_sample(n = strat_group_size)

报错信息：

Error in `dplyr::slice_sample()`:
! Problem while computing indices.
ℹ The error occurred in group 3: strat_group = "one".
Caused by error in `sample.int()`:
! cannot take a sample larger than the population when 'replace = FALSE'

期望输出 #

（各组样本量尽可能均匀，小组成员全保留）

df <- data.frame(
  strat_group = c(rep("1", 2), rep("2", 6), rep("3", 5), rep("4", 6), rep("5", 6))
)

实现方案 #

思路 #

1. 统计每个分层组的现有样本量，样本量小于目标平均的组直接保留全部样本
2. 计算已保留的样本总数，得出还需抽取的剩余样本量
3. 将剩余样本量尽可能均匀分配给样本量充足的组，处理分配余数
4. 按计算好的每组抽样数量执行无重复抽样

代码实现 #

library(dplyr)

df <- data.frame(
  strat_group = c(rep("one", 2), rep("two", 10), rep("three", 5), rep("four", 25), rep("five", 12))
)

target_total <- 25
group_count <- length(unique(df$strat_group))
target_avg <- target_total / group_count

# 统计每组现有样本量，标记初始保留数量
group_sizes <- df |>
  count(strat_group, name = "current_size") |>
  mutate(initial_n = pmin(current_size, target_avg))

# 计算剩余需抽取的样本量
reserved_total <- sum(group_sizes$initial_n)
remaining_needed <- target_total - reserved_total

# 分配剩余样本量给有空间的组
available_groups <- group_sizes |> filter(current_size > initial_n)
if (remaining_needed > 0) {
  per_group_add <- floor(remaining_needed / nrow(available_groups))
  remainder <- remaining_needed %% nrow(available_groups)
  
  available_groups <- available_groups |>
    mutate(
      add_n = per_group_add + if_else(row_number() <= remainder, 1, 0),
      final_n = initial_n + add_n
    )
} else {
  available_groups <- available_groups |> mutate(final_n = initial_n)
}

# 合并所有组的最终抽样数量
final_sample_sizes <- group_sizes |>
  left_join(available_groups |> select(strat_group, final_n), by = "strat_group") |>
  mutate(final_n = if_else(is.na(final_n), initial_n, final_n))

# 执行抽样
sampled_df <- df |>
  group_by(strat_group) |>
  slice_sample(n = final_sample_sizes$final_n[match(cur_group()$strat_group, final_sample_sizes$strat_group)]) |>
  ungroup()

# 查看抽样结果分布
sampled_df |> count(strat_group)

结果说明 #

运行代码后，抽样结果与期望一致：one组保留全部2条，three组保留全部5条，其余三组各抽取6条，总样本量为2+6+5+6+6=25，完全满足均匀无重复的下采样需求。

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