如何基于四个分层抽取符合指定样本量的分层随机样本？

你需要的是多维度边际配额抽样——要求样本同时满足四个独立维度的数量配额，而非单一分层或交叉分层的抽样。下面提供两种可靠的实现方法：

方法一：使用survey包快速实现 #

survey包的quota.sample()函数原生支持边际配额抽样，代码简洁高效：

步骤1：修正数据生成代码（原代码存在语法问题） #

set.seed(123) # 设置随机种子，保证结果可重复
df <- data.frame(
  index = 1:100,
  gender = sample(c("male", "female"), 100, replace = TRUE),
  age = sample(c("young", "middle-aged", "old"), 100, replace = TRUE),
  education = sample(c("low", "middle", "high"), 100, replace = TRUE),
  residence = sample(c("A", "B", "C", "D", "E"), 100, replace = TRUE)
)

步骤2：安装并加载survey包 #

install.packages("survey")
library(survey)

步骤3：定义各维度的配额 #

quota_list <- list(
  gender = c(female = 15, male = 15),
  age = c(young = 8, `middle-aged` = 10, old = 12),
  education = c(low = 11, middle = 8, high = 11),
  residence = c(A = 11, B = 9, C = 4, D = 4, E = 2)
)

步骤4：执行配额抽样 #

sample_df <- quota.sample(df, quotas = quota_list, size = 30)

步骤5：验证配额是否满足 #

# 检查性别配额
table(sample_df$gender)
# 检查年龄配额
table(sample_df$age)
# 检查教育程度配额
table(sample_df$education)
# 检查居住地配额
table(sample_df$residence)

方法二：使用sampling包的IPFP算法（更灵活处理冲突） #

如果需要更精细地控制抽样过程（比如处理配额冲突），可以用**迭代比例拟合（IPFP）**算法先计算交叉层的目标样本量，再进行分层抽样：

步骤1：安装并加载sampling包 #

install.packages("sampling")
library(sampling)

步骤2：定义边际配额并计算交叉层目标样本量 #

# 边际配额列表
margins <- list(
  margin1 = c(female = 15, male = 15),
  margin2 = c(young = 8, `middle-aged` = 10, old = 12),
  margin3 = c(low = 11, middle = 8, high = 11),
  margin4 = c(A = 11, B = 9, C = 4, D = 4, E = 2)
)

# 计算总体的交叉层频数
cross_table <- table(df$gender, df$age, df$education, df$residence)

# 用IPFP算法计算每个交叉层的目标样本量
target_sample <- ipfp(cross_table, margins, rep(30, length(margins)))

步骤3：基于交叉层目标量进行分层抽样 #

# 将交叉表转换为数据框，方便处理
cross_df <- as.data.frame(cross_table)
colnames(cross_df) <- c("gender", "age", "education", "residence", "pop_count")
cross_df$target <- as.vector(target_sample)

# 过滤掉不需要抽样的层（目标量为0）
cross_df <- cross_df[cross_df$target > 0, ]

# 逐层抽样并合并结果
sample_list <- lapply(1:nrow(cross_df), function(i) {
  # 筛选当前交叉层的样本
  subset <- df[
    df$gender == cross_df$gender[i] &
    df$age == cross_df$age[i] &
    df$education == cross_df$education[i] &
    df$residence == cross_df$residence[i],
  ]
  # 抽取目标数量，若总体不足则抽取全部并警告
  if (nrow(subset) >= cross_df$target[i]) {
    subset[sample(nrow(subset), cross_df$target[i]), ]
  } else {
    warning(sprintf("层 %s-%s-%s-%s 样本量不足，已抽取全部 %d 个样本",
                    cross_df$gender[i], cross_df$age[i],
                    cross_df$education[i], cross_df$residence[i],
                    nrow(subset)))
    subset
  }
})

# 合并所有层的样本
sample_df <- do.call(rbind, sample_list)

步骤4：验证配额 #

同样使用table()函数检查各维度的样本数量是否符合要求。

注意事项 #

• 确保总体中每个类别的数量不小于对应的配额，否则抽样会出现样本量不足的警告，最终样本总数可能小于30。
• 设置set.seed()可以保证抽样结果的可重复性。

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