将数据框拆分为确认样本和探索样本答案

【问题标题】：Splitting Dataframe into Confirmatory and Exploratory Samples将数据框拆分为确认样本和探索样本
【发布时间】：2014-09-19 15:31:26
【问题描述】：

我有一个非常大的数据框 (N = 107,251)，我希望将其分成相对相等的两半 (~53,625)。但是，我希望进行拆分，以使三个变量在两组中保持相等的比例（与性别、6 个级别的年龄类别和 5 个级别的区域有关）。

我可以独立（例如，通过prop.table(xtabs(~dat$Gender))）或组合（例如，通过prop.table(xtabs(~dat$Gender + dat$Region + dat$Age)）生成变量的比例，但我不确定如何利用这些信息来实际进行抽样。

样本数据集：

set.seed(42)
Gender <- sample(c("M", "F"), 1000, replace = TRUE)
Region <- sample(c("1","2","3","4","5"), 1000, replace = TRUE)
Age <- sample(c("1","2","3","4","5","6"), 1000, replace = TRUE)
X1 <- rnorm(1000)
dat <- data.frame(Gender, Region, Age, X1)

概率：

round(prop.table(xtabs(~dat$Gender)), 3)  # 48.5% Female; 51.5% Male
round(prop.table(xtabs(~dat$Age)), 3)     # 16.8, 18.2, ..., 16.0%
round(prop.table(xtabs(~dat$Region)), 3)  # 21.5%, 17.7, ..., 21.9%
# Multidimensional probabilities:
round(prop.table(xtabs(~dat$Gender + dat$Age + dat$Region)), 3)

这个虚拟示例的最终目标是两个数据框，每个数据框大约有 500 个观察值（完全独立，没有参与者出现在两者中），并且在性别/地区/年龄划分方面大致相等。在实际分析中，年龄和区域权重之间存在更大的差异，因此进行单个随机拆分是不合适的。在现实世界的应用中，我不确定是否需要使用每个观察值，或者是否最好让分割更均匀。

我一直在阅读来自 package:sampling 的文档，但我不确定它是否完全符合我的要求。

【问题讨论】：

参见caret 包中的createDataPartition 以及this SO question。

标签： r sampling

【解决方案1】：

您可以查看my stratified function，您应该可以像这样使用它：

set.seed(1) ## just so you can reproduce this

## Take your first group
sample1 <- stratified(dat, c("Gender", "Region", "Age"), .5)

## Then select the remainder
sample2 <- dat[!rownames(dat) %in% rownames(sample1), ]

summary(sample1)
#  Gender  Region  Age          X1          
#  F:235   1:112   1:84   Min.   :-2.82847  
#  M:259   2: 90   2:78   1st Qu.:-0.69711  
#          3: 94   3:82   Median :-0.03200  
#          4: 97   4:80   Mean   :-0.01401  
#          5:101   5:90   3rd Qu.: 0.63844  
#                  6:80   Max.   : 2.90422
summary(sample2)
#  Gender  Region  Age          X1          
#  F:238   1:114   1:85   Min.   :-2.76808  
#  M:268   2: 92   2:81   1st Qu.:-0.55173  
#          3: 97   3:83   Median : 0.02559  
#          4: 99   4:83   Mean   : 0.05789  
#          5:104   5:91   3rd Qu.: 0.74102  
#                  6:83   Max.   : 3.58466

比较以下内容，看看它们是否符合您的预期。

x1 <- round(prop.table(
  xtabs(~dat$Gender + dat$Age + dat$Region)), 3)
x2 <- round(prop.table(
  xtabs(~sample1$Gender + sample1$Age + sample1$Region)), 3)
x3 <- round(prop.table(
  xtabs(~sample2$Gender + sample2$Age + sample2$Region)), 3)

它应该能够很好地处理您描述的大小的数据，但是“data.table”版本正在开发中，它有望提高效率。

更新：

stratified 现在有一个新的逻辑参数“bothSets”，可让您将两组样本保留为list。

set.seed(1)
Samples <- stratified(dat, c("Gender", "Region", "Age"), .5, bothSets = TRUE)
lapply(Samples, summary)
# $SET1
#  Gender  Region  Age          X1          
#  F:235   1:112   1:84   Min.   :-2.82847  
#  M:259   2: 90   2:78   1st Qu.:-0.69711  
#          3: 94   3:82   Median :-0.03200  
#          4: 97   4:80   Mean   :-0.01401  
#          5:101   5:90   3rd Qu.: 0.63844  
#                  6:80   Max.   : 2.90422  
#
# $SET2
#  Gender  Region  Age          X1          
#  F:238   1:114   1:85   Min.   :-2.76808  
#  M:268   2: 92   2:81   1st Qu.:-0.55173  
#          3: 97   3:83   Median : 0.02559  
#          4: 99   4:83   Mean   : 0.05789  
#          5:104   5:91   3rd Qu.: 0.74102  
#                  6:83   Max.   : 3.58466

【讨论】：

【解决方案2】：

以下代码基本上基于组成员身份创建一个密钥，然后循环遍历每个组，对一组采样一半，对另一组采样一半（大致）。如果您比较得到的概率，它们之间的误差在 0.001 以内。这样做的缺点是，由于如何处理奇数组成员编号的四舍五入，它倾向于为第二组创建更大的样本量。在这种情况下，第一个样本是 488 个观测值，第二个是 512 个观测值。您可能可以加入一些逻辑来解释这一点，甚至更好。

编辑：添加了该逻辑并将其平均拆分。

set.seed(42)
Gender <- sample(c("M", "F"), 1000, replace = TRUE)
Region <- sample(c("1","2","3","4","5"), 1000, replace = TRUE)
Age <- sample(c("1","2","3","4","5","6"), 1000, replace = TRUE)
X1 <- rnorm(1000)
dat <- data.frame(Gender, Region, Age, X1)

dat$group <- with(dat, paste(Gender, Region, Age))
groups <- unique(dat$group)
setA <- dat[NULL,]
setB <- dat[NULL,]
for (i in 1:length(groups)){
  temp <- dat[dat$group==groups[i],]
  if (nrow(setA) > nrow(setB)){
    tempA <- temp[1:floor(nrow(temp)/2),]
    tempB <- temp[(1+floor(nrow(temp)/2)):nrow(temp),]
  } else {
    tempA <- temp[1:ceiling(nrow(temp)/2),]
    tempB <- temp[(1+ceiling(nrow(temp)/2)):nrow(temp),] 
  }
  setA <- rbind(setA, tempA)
  setB <- rbind(setB, tempB)
}

【讨论】：