基于R中的严格范围绘制一个没有放回的随机样本

Question

我正在尝试从数据集中抽取不替换的随机行样本，这样样本中列的总和应该严格在一个范围内。对于示例数据集mtcars，随机样本应使mpg之和严格在90-100之间。

一个可重现的例子：

data("mtcars")

random_sample <- function(dataset){
  final_mpg = 0
  while (final_mpg < 100) {
    basic_dat <- dataset %>%
      sample_n(1) %>%
      ungroup()
    total_mpg <- basic_dat %>%
      summarise(mpg = sum(mpg)) %>%
      pull(mpg)
    final_mpg <- final_mpg + total_mpg
    if (final_mpg > 90 & final_mpg < 100){
      break()
    }
    final_dat <- rbind(get0("final_dat"), get0("basic_dat"))
  }
  return(final_dat)
}

chosen_sample <- random_sample(mtcars)

但此函数输出样本为sum(mpg) > 100。如何确保它生成的每个样本都严格在该范围内？非常感谢任何帮助。

Answer 1

这是一个 hack，但要意识到永远无法保证它会起作用。

#' Random sampling of data
#'
#' Return a sample of the dataset's rows where the sum of 'fld' values
#' is between the two numbers of 'sumbetween'.
#'
#' @param dat data.frame
#' @param fld character, the name of one of the fields in 'dat'
#' @param sumbetween numeric, length 2, the two ends of the range of
#'   desired sum
#' @param suggestn integer, a suggestion for 'n' around which sample
#'   sizes are based; the actual samples attempted will vary between
#'   0.5 and 1.5 times this value; if 'NA' (the default), then it
#'   defaults naively to 'mean(sumbetween) / median(dat[[fld]])'
#' @param iters integer, number of samples to attempt before
#'   "giving up" (otherwise this might run forever)
#' @return data.frame, a sample of the original dataset; regardless of
#'   success, two attributes are included, 'mu' and 'sigma',
#'   indicating the mean and standard deviation of the samples tested
random_sample <- function(dat, fld, sumbetween, suggestn = NA, iters = 100) {
  stopifnot(fld %in% names(dat), is.numeric(dat[[fld]]), is.numeric(sumbetween))

  if (is.na(suggestn)) {
    suggestn <- mean(sumbetween) / median(dat[[fld]])
  }
  suggestn <- min(suggestn, nrow(dat))

  mu <- NA
  Sn <- 0
  ind <- FALSE
  n <- 0L

  while ((is.na(iters) || n < iters) && !ind) {
    n <- n + 1L
    size <- min(nrow(dat), sample(seq(max(1, floor(suggestn/2)), ceiling(suggestn*1.5)), size = 1))
    rows <- sample(nrow(dat), size = size)
    s <- sum(dat[[fld]][rows])
    ind <- sumbetween[1] <= s & s <= sumbetween[2]
    # incremental mean and almost-variance of the samples
    # http://datagenetics.com/blog/november22017/index.html
    lastmu <- mu
    mu <- sum(s, (n-1)*mu, na.rm = TRUE)/n
    Sn <- Sn + sum(s, -lastmu, na.rm = TRUE)*sum(s, -mu, na.rm = TRUE)
  }

  out <- if (ind) dat[rows,] else NA
  if (!ind) warning("unable to find a successful sample after ", n, " iterations")
  # actual mean and variance of samples, successful or not
  attr(out, "mu") <- mu
  attr(out, "sigma") <- sqrt(Sn / n)
  return(out)
}

它的用途如下。我在这里使用str 来演示一个功能：将所有测试样本的均值和偏差添加为属性。如果成功，则不显示属性（print.data.frame 默认不显示任何属性），但如果失败则会给出警告，并返回 NA 并返回相同的属性。

set.seed(42)
str(random_sample(mtcars, "mpg", c(90,100), iters=20))
# Warning in random_sample(mtcars, "mpg", c(90, 100), iters = 20) :
#   unable to find a successful sample after 20 iterations
#  logi NA
#  - attr(*, "mu")= num 106
#  - attr(*, "sigma")= num 37.9
str(random_sample(mtcars, "mpg", c(90,100), iters=20))
# 'data.frame': 5 obs. of  12 variables:
#  $ mpg : num  33.9 14.3 14.7 18.1 17.3
#  $ cyl : num  4 8 8 6 8
#  $ disp: num  71.1 360 440 225 275.8
#  $ hp  : num  65 245 230 105 180
#  $ drat: num  4.22 3.21 3.23 2.76 3.07
#  $ wt  : num  1.83 3.57 5.34 3.46 3.73
#  $ qsec: num  19.9 15.8 17.4 20.2 17.6
#  $ vs  : num  1 0 0 1 0
#  $ am  : num  1 0 0 0 0
#  $ gear: num  4 3 3 3 3
#  $ carb: num  1 4 4 1 3
#  $ new1: num  75.1 368 448 231 283.8
#  - attr(*, "mu")= num 96.1
#  - attr(*, "sigma")= num 42.1

返回均值/偏差的目的是帮助用户确定suggestn（建议起始样本大小）是否放错了位置，或者iters 是否太小而我们退出太早（例如，当预期范围在mu +/- sigma 内时。

这使用iters 来防止无限循环。您可以禁用它（参加比赛！），后果自负。

这并不保证可以找到可行的解决方案。想象一下所有值都是 20 的倍数，而所需的范围只有 10 宽。当然还有其他条件很难通过启发式方法“知道”确定是否存在解决方案。

Answer 2

这是有效的。由于 mpg 的值，它不能超过 90。

ransmpl <- function(df) { 
  s1<- df[sample(rownames(df),1),] 
  s11 <- sum(s1$mpg) 
  while(s11<100){
    rn2<- rownames(df[!(rownames(df) %in% rownames(s1)),]) 
    nr<- df[sample(rn2,1),] 
    s11 <- sum(rbind(s1,nr)$mpg) 
    if(s11>100){ 
      break() 
    } 
    s1<-rbind(s1,nr) 
  } 
  return(s1) 
  }


chosen_sample <- ransmpl(mtcars)
chosen_sample

输出

> chosen_sample
                   mpg cyl  disp  hp drat    wt  qsec vs am gear carb
Merc 280C         17.8   6 167.6 123 3.92 3.440 18.90  1  0    4    4
Hornet Sportabout 18.7   8 360.0 175 3.15 3.440 17.02  0  0    3    2
Merc 230          22.8   4 140.8  95 3.92 3.150 22.90  1  0    4    2
Chrysler Imperial 14.7   8 440.0 230 3.23 5.345 17.42  0  0    3    4

> sum(chosen_sample$mpg)
[1] 95.1