R（和 dplyr？） - 按组从数据帧中采样，最大样本大小为 n

Posted 2023-03-12

【中文标题】R（和 dplyr？） - 按组从数据帧中采样，最大样本大小为 n

【英文标题】：R (and dplyr?) - Sampling from a dataframe by group, up to a maximum sample size of n

【发布时间】：2019-03-19 20:42:45

【问题描述】：

我有一个数据框，其中每组包含多个样本 (1-n)。我想在不替换的情况下对这个数据集进行采样，这样我每组最多有 5 个样本 (1-5)。

这个问题以前是described and answered here。在这个问题中@evolvedmicrobe 的回答对我来说是最满意的，并且过去一直有效。这似乎在过去一年左右打破了。

这是我想做的一个可行的例子：

在 mtcars 中，按“cyl”分组时有不同的行数。

table(mtcars$cyl)
 4  6  8 
11  7 14 

我想创建一个子样本，其中每组 cyl 的最大汽车数量为 10。结果的行数理论上看起来像：

table(subsample$cyl)
 4  6  8
10  7 10

我对此的幼稚尝试是：

library(dplyr)
subsample <- mtcars %>% group_by(cyl) %>% sample_n(10) %>% ungroup()

但是，因为一组少于 10 行：

错误：size 必须小于或等于 7（数据大小），设置 replace = TRUE 以使用带替换的采样

@evolvedmicrobe 对此的回答是创建自定义采样函数：

### Custom sampler function to sample min(data, sample) which can't be done with dplyr
 ### it's a modified copy of sample_n.grouped_df
 sample_vals <- function (tbl, size, replace = FALSE, weight = NULL, .env = parent.frame()) 
 
   #assert_that(is.numeric(size), length(size) == 1, size >= 0)
   weight <- substitute(weight)
   index <- attr(tbl, "indices")
   sizes = sapply(index, function(z) min(length(z), size)) # here's my contribution
   sampled <- lapply(1:length(index), function(i) dplyr:::sample_group(index[[i]],  frac = FALSE, tbl = tbl, 
                                       size = sizes[i], replace = replace, weight = weight, .env = .env))
   idx <- unlist(sampled) + 1
   grouped_df(tbl[idx, , drop = FALSE], vars = groups(tbl))
 

 samped_data = dataset %>% group_by(something) %>% sample_vals(size = 50000) %>% ungroup()

此函数过去曾有效，我刚刚尝试重新运行它，但它不再有效，相反，它会返回与当前 mtcars 示例相同的错误：

library(dplyr)
subsample <- mtcars %>% group_by(cyl) %>% sample_vals(10) %>% ungroup()

dplyr:::sample_group(index[[i]], frac = FALSE, tbl = tbl, size = sizes[i], 中的错误： 未使用的参数（tbl = tbl） 调用自：FUN(X[[i]], ...)

有没有人有更好的按组抽样的方法，无需替换，达到每组的最大尺寸？我通常不是 dplyr 的大用户，所以也欢迎来自 base R 或其他包的所有选项。

否则，有没有人知道为什么以前的解决方法停止工作？

感谢大家的时间。

【参考方案1】：

对于一个简单的功能，你可以使用这个变通方法，它首先用没有足够的样本炸毁组，然后在最后过滤掉它们：

library(dplyr)
library(tidyr)

size <- 10

subsample <- mtcars %>% 
  group_by(cyl) %>% 
  mutate(group_count = n(), 
         group_count_along = 1:n()) %>% 
  ungroup() %>% 
  complete(cyl, group_count_along) %>% 
  group_by(cyl) %>% 
  filter(group_count_along <= max(group_count, size, na.rm = T)) %>% 
  sample_n(size) %>% 
  ungroup() %>% 
  filter(group_count_along <= group_count)

table(subsample$cyl)
 4  6  8 
10  7 10 

【讨论】：

请注意：此解决方案有效，但还需要 tidyr 才能实现“完整”功能。一个很好的快速响应，kath，但我确实对添加和删除假数据行感到不安。从第一个 group_by 到最终过滤器还有很多事情要做。

【参考方案2】：

这是一个使用slice 的简单解决方案-

samples_per_group <- 10

subsample <- mtcars %>%
  group_by(cyl) %>%
  slice(sample(n(), min(samples_per_group, n()))) %>%
  ungroup()

table(subsample$cyl)

#  4  6  8 
# 10  7 10

【讨论】：

sample 的默认长度是完整的向量，所以你也可以只输入slice(sample(min(samples_per_group, n())))

sample.int 要求 n，指定可供选择的样本数。当指定 n = 10（作为 samples_per_group 和 n() 的最小值但真正的 n = n() 大于 10 时会发生什么？

@RyanD 谢谢...简化了解决方案。

@Aaarrrgh'sMyGame 我想我明白了你的问题，并对示例代码进行了更改。让我知道这是否适合您。

谢谢@Shree，我的问题非常复杂。是的，现在编辑更有意义了。

【参考方案3】：

函数sample_group 已更新，参数tbl 和.env 已删除。从 sample_vals 函数中删除这些参数并删除 +1 可以恢复函数的功能。

require(dplyr)

sample_vals <- function (tbl, size, replace = FALSE, weight = NULL)
    ## assert_that(is.numeric(size), length(size) == 1, size >= 0)
    weight <- substitute(weight)
    index <- attr(tbl, "indices")
    sizes <- sapply(index, function(z) min(length(z), size)) # here's my contribution
    sampled <- lapply(1:length(index),
                      function(i) dplyr:::sample_group(index[[i]],  frac = FALSE, 
                                                       size = sizes[i],
                                                       replace = replace,
                                                       weight = weight))
    idx <- unlist(sampled) ## + 1
    grouped_df(tbl[idx, , drop = FALSE], vars = groups(tbl))


samped_data <- mtcars %>% group_by(cyl) %>% sample_vals(size = 10) %>% ungroup()

table(samped_data$cyl)

【参考方案4】：

基数 R 也很简单，例如：

do.call(rbind, lapply(split(mtcars, mtcars$cyl), function(x) 
  n <- nrow(x)
  s <- min(n, 10)
  x[sample(seq_len(n), s),]
))

输出中的行将按cyl 排序——但行顺序可能并不重要。