tidyverse 函数到`mutate_sample`？

Question

我正在寻找随机样本的一列变异，例如mutate_sample 。 有谁知道这是否有 dplyr/其他 tidyverse 动词？ 下面是我正在寻找的行为的代表和功能化的尝试（它没有运行，因为我正在为 if_else 中的if_else苦苦挣扎）。

library(dplyr)
library(tibble)
library(rlang)

# Setup -------------------------------------------------------------------

group_size <- 10
group_n <- 1

my_cars <-
  mtcars %>% 
  rownames_to_column(var = "model") %>% 
  mutate(group = NA_real_, .after = model)


# Code to create mutated sample -------------------------------------------

group_sample <- 
  my_cars %>% 
  filter(is.na(group)) %>% 
  slice_sample(n = group_size) %>% 
  pull(model)

my_cars %>% 
  mutate(group =  if_else(model %in% group_sample, group_n, group)) %>% 
  head()
#>               model group  mpg cyl disp  hp drat    wt  qsec vs am gear carb
#> 1         Mazda RX4    NA 21.0   6  160 110 3.90 2.620 16.46  0  1    4    4
#> 2     Mazda RX4 Wag     1 21.0   6  160 110 3.90 2.875 17.02  0  1    4    4
#> 3        Datsun 710     1 22.8   4  108  93 3.85 2.320 18.61  1  1    4    1
#> 4    Hornet 4 Drive    NA 21.4   6  258 110 3.08 3.215 19.44  1  0    3    1
#> 5 Hornet Sportabout    NA 18.7   8  360 175 3.15 3.440 17.02  0  0    3    2
#> 6           Valiant    NA 18.1   6  225 105 2.76 3.460 20.22  1  0    3    1


# Function to create mutated sample ---------------------------------------
# 
# Note: doesn't run because of var in if_else
# mutate_sample <- function(data, var, id, n, value) {
#   # browser()
#   sample <-
#     data %>% 
#     filter(is.na({{var}})) %>% 
#     slice_sample(n = n) %>% 
#     pull({{id}})
#   
#   data %>%
#     mutate(var =  if_else({{id}} %in% sample, value, {{var}}))
# }
# 
# mutate_sample(my_cars, group, model, group_size, group_n)

^{由reprex 包(v0.3.0) 于 2020 年 10 月 21 日创建}

通过 SO，我发现了这篇相关的文章： Mutate column as input to sample

Answer 1

我认为您可以通过这两个选项实现您的目标。

使用 dplyr：

mtcars %>% mutate(group = sample(`length<-`(rep(group_n, group_size), n())))

或以 R 为基础：

mtcars[sample(nrow(mtcars), group_size), "group"] <- group_n

---

如果您需要一个外部函数来处理它，您可以使用：

mutate_sample <- function(.data, .var, .size, .value) {
  
 mutate(.data, {{.var}} := sample(`length<-`(rep(.value, .size), n())))
 
}

mtcars %>% mutate_sample(group, group_size, group_n)

或者

mutate_sample_rbase <- function(.data, .var, .size, .value) {
 
 .data[sample(nrow(.data), size = min(.size, nrow(.data))), 
       deparse(substitute(.var))] <- .value
 .data
 
}

mtcars %>% mutate_sample(group, group_size, group_n)

请注意，如果.size大于.data的行数，则.var将是一个等于.value的常量。

---

编辑

如果您有兴趣保留旧组，我建议您另一种处理问题的方法：

library(dplyr)

# to understand this check out ?sample
resample <- function(x, ...){
 
 x[sample.int(length(x), ...)]
 
}

# this is to avoid any error in case you choose a size bigger than the available rows to select in one group
resample_max <- function (x, size) {
 
 resample(x, size = min(size, length(x)))
 
}

mutate_sample <- function(.data, .var, .size, .value) {
 
 # creare column if it doesnt exist
 if(! deparse(substitute(.var)) %in% names(.data)) .data <- mutate(.data, {{.var}} := NA)

 # replace missing values randomly keeping existing non-missing values
 mutate(.data, {{.var}} := replace({{.var}}, resample_max(which(is.na({{.var}})), .size), .value))
 
}


group_size <- 10

mtcars %>% 
 mutate_sample(group, group_size, 1) %>% 
 mutate_sample(group, group_size, 2)

#>     mpg cyl  disp  hp drat    wt  qsec vs am gear carb group
#> 1  21.0   6 160.0 110 3.90 2.620 16.46  0  1    4    4    NA
#> 2  21.0   6 160.0 110 3.90 2.875 17.02  0  1    4    4    NA
#> 3  22.8   4 108.0  93 3.85 2.320 18.61  1  1    4    1     2
#> 4  21.4   6 258.0 110 3.08 3.215 19.44  1  0    3    1     1
#> 5  18.7   8 360.0 175 3.15 3.440 17.02  0  0    3    2    NA
#> 6  18.1   6 225.0 105 2.76 3.460 20.22  1  0    3    1     1
#> 7  14.3   8 360.0 245 3.21 3.570 15.84  0  0    3    4    NA
#> 8  24.4   4 146.7  62 3.69 3.190 20.00  1  0    4    2     2
#> 9  22.8   4 140.8  95 3.92 3.150 22.90  1  0    4    2    NA
#> 10 19.2   6 167.6 123 3.92 3.440 18.30  1  0    4    4    NA
#> 11 17.8   6 167.6 123 3.92 3.440 18.90  1  0    4    4     1
#> 12 16.4   8 275.8 180 3.07 4.070 17.40  0  0    3    3     2
#> 13 17.3   8 275.8 180 3.07 3.730 17.60  0  0    3    3     1
#> 14 15.2   8 275.8 180 3.07 3.780 18.00  0  0    3    3    NA
#> 15 10.4   8 472.0 205 2.93 5.250 17.98  0  0    3    4     2
#> 16 10.4   8 460.0 215 3.00 5.424 17.82  0  0    3    4     1
#> 17 14.7   8 440.0 230 3.23 5.345 17.42  0  0    3    4     1
#> 18 32.4   4  78.7  66 4.08 2.200 19.47  1  1    4    1     2
#> 19 30.4   4  75.7  52 4.93 1.615 18.52  1  1    4    2    NA
#> 20 33.9   4  71.1  65 4.22 1.835 19.90  1  1    4    1    NA
#> 21 21.5   4 120.1  97 3.70 2.465 20.01  1  0    3    1     1
#> 22 15.5   8 318.0 150 2.76 3.520 16.87  0  0    3    2     1
#> 23 15.2   8 304.0 150 3.15 3.435 17.30  0  0    3    2     2
#> 24 13.3   8 350.0 245 3.73 3.840 15.41  0  0    3    4     1
#> 25 19.2   8 400.0 175 3.08 3.845 17.05  0  0    3    2     2
#> 26 27.3   4  79.0  66 4.08 1.935 18.90  1  1    4    1     2
#> 27 26.0   4 120.3  91 4.43 2.140 16.70  0  1    5    2    NA
#> 28 30.4   4  95.1 113 3.77 1.513 16.90  1  1    5    2     2
#> 29 15.8   8 351.0 264 4.22 3.170 14.50  0  1    5    4     1
#> 30 19.7   6 145.0 175 3.62 2.770 15.50  0  1    5    6    NA
#> 31 15.0   8 301.0 335 3.54 3.570 14.60  0  1    5    8     2
#> 32 21.4   4 121.0 109 4.11 2.780 18.60  1  1    4    2    NA

请注意，此解决方案有效，即使grouped_df类（A后，你会得到什么dplyr::group_by ）：各组[所作dplyr::group_by样本] .size单位将被选中。

mtcars %>% 
 group_by(am) %>% 
 mutate_sample(group, 10, 1) %>% 
 ungroup() %>% 
 count(group)
#> # A tibble: 2 x 2
#>   group     n
#>   <dbl> <int>
#> 1     1    20 # two groups, each with 10!
#> 2    NA    12