Вот взлом, хотя поймите, что никогда не гарантируется, что он будет работать.
#' 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 для предотвращения бесконечного l oop. Вы можете отключить его (для гонок!) На свой страх и риск.
Это не дает никаких обещаний, что будет найдено возможное решение. Представьте, что все значения кратны 20, а желаемый диапазон составляет всего 10. Конечно, есть и другие условия, которые эвристически трудно «знать» с уверенностью, чтобы узнать, существует ли решение.