r - 无替换条件抽样

Question

我正在尝试编写一个模拟，该模拟涉及将项目随机重新分配到具有一些限制的类别。

假设我有一组 1 到 N 的鹅卵石分布在桶 A 到 J 之间:

set.seed(100)
df1 <- data.frame(pebble = 1:100, 
                  bucket = sample(LETTERS[1:10], 100, T), 
                  stringsAsFactors = F)
head(df1)
#>   pebble bucket
#> 1      1      D
#> 2      2      C
#> 3      3      F
#> 4      4      A
#> 5      5      E
#> 6      6      E

我想将鹅卵石随机重新分配给桶。没有限制，我可以这样做:

random.permutation.df1 <- data.frame(pebble = df1$pebble, bucket = sample(df1$bucket))
colSums(table(random.permutation.df1))
#>  A  B  C  D  E  F  G  H  I  J 
#>  4  7 13 14 12 11 11 10  9  9
colSums(table(df1))
#>  A  B  C  D  E  F  G  H  I  J 
#>  4  7 13 14 12 11 11 10  9  9

重要的是，这会重新分配鹅卵石，同时确保每个桶保留相同的数量(因为我们是在没有替换的情况下进行采样)。

但是，我有一组限制，某些鹅卵石不能分配给某些桶。我在 df2 中对限制进行了编码:

df2 <- data.frame(pebble = sample(1:100, 10), 
                  bucket = sample(LETTERS[1:10], 10, T), 
                  stringsAsFactors = F)
df2
#>    pebble bucket
#> 1      33      I
#> 2      39      I
#> 3       5      A
#> 4      36      C
#> 5      55      J
#> 6      66      A
#> 7      92      J
#> 8      95      H
#> 9       2      C
#> 10     49      I

这里的逻辑是，不能将卵石 33 和 39 放在桶 I 中，或将卵石 5 放在桶 A 中，等等。我想根据这些限制排列哪些卵石在哪个桶中。

到目前为止，我已经考虑在如下循环中解决它，但这不会导致桶保留相同数量的鹅卵石:

perms <- character(0)
cnt <- 1
for (p in df1$pebble) {
  perms[cnt] <- sample(df1$bucket[!df1$bucket %in% df2$bucket[df2$pebble==p]], 1)
  cnt <- cnt + 1
}
table(perms)
#> perms
#>  A  B  C  D  E  F  G  H  I  J 
#>  6  7 12 22 15  1 14  7  7  9

然后我尝试采样位置，然后从可用桶和可用的剩余位置中删除该位置。这也不起作用，我怀疑这是因为我正在对不产生解决方案的树的分支进行采样。

set.seed(42)
perms <- character(0)
cnt <- 1
ids <- 1:nrow(df1)
bckts <- df1$bucket
for (p in df1$pebble) {
  id <- sample(ids[!bckts %in% df2$bucket[df2$pebble==p]], 1)
  perms[cnt] <- bckts[id]
  bckts <- bckts[-id]
  ids <- ids[ids!=id]
  cnt <- cnt + 1
}
table(perms)
#> perms
#> A B C D E F G J 
#> 1 1 4 1 2 1 2 2 

任何想法或建议都非常感谢(并为长度道歉)。

编辑:

我愚蠢地忘记澄清我之前只是通过重新采样来解决这个问题，直到我得到一个不违反 df2 中的任何条件的平局。 ，但我现在有很多条件，这会使我的代码运行时间过长。如果我能想出一种方法来更快地强制它，我仍然愿意尝试强制它。

Answer 1

我有一个解决方案(我设法用基础 R 编写它，但 data.table 解决方案更容易理解和编写:

random.permutation.df2 <- data.frame(pebble = df1$pebble, bucket = rep(NA,length(df1$pebble)))
for(bucket in unique(df1$bucket)){
  N <-  length( random.permutation.df2$bucket[is.na(random.permutation.df2$bucket) & 
                                         !random.permutation.df2$pebble %in% df2$pebble[df2$bucket == bucket] ] )
  random.permutation.df2$bucket[is.na(random.permutation.df2$bucket) & 
                                  !random.permutation.df2$pebble %in% df2$pebble[df2$bucket == bucket] ] <- 
    sample(c(rep(bucket,sum(df1$bucket == bucket)),rep(NA,N-sum(df1$bucket == bucket))))

}

这个想法是对每个桶的授权 peeble 进行采样:那些不在 df2 中的，以及那些尚未填充的。然后对一个长度合适的向量进行采样，在 NA(对于以下存储桶值)和循环中的值之间进行选择，然后瞧。

现在使用 data.table 更容易阅读

library(data.table)
random.permutation.df2 <- setDT(random.permutation.df2)
df2 <- setDT(df2)

for( bucketi in unique(df1$bucket)){
 random.permutation.df2[is.na(bucket) & !pebble %in% df2[bucket == bucketi, pebble], 
                        bucket := sample(c(rep(bucketi,sum(df1$bucket == bucket)),rep(NA,.N-sum(df1$bucket == bucket))))] 
}

它有两个条件

> colSums(table(df1))
 A  B  C  D  E  F  G  H  I  J 
 4  7 13 14 12 11 11 10  9  9 
> colSums(table(random.permutation.df2))
 A  B  C  D  E  F  G  H  I  J 
 4  7 13 14 12 11 11 10  9  9 

验证与 df2 没有任何矛盾

> df2
    pebble bucket
 1:     37      D
 2:     95      H
 3:     90      C
 4:     80      C
 5:     31      D
 6:     84      G
 7:     76      I
 8:     57      H
 9:      7      E
10:     39      A
> random.permutation.df2[pebble %in% df2$pebble,.(pebble,bucket)]
    pebble bucket
 1:      7      D
 2:     31      H
 3:     37      J
 4:     39      F
 5:     57      B
 6:     76      E
 7:     80      F
 8:     84      B
 9:     90      H
10:     95      D