无替换条件抽样

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

Answer 2

这是一种蛮力方法，只需尝试足够长的时间，直到找到有效的解决方案：

set.seed(123)
df1 <- data.frame(pebble = 1:100, 
                  bucket = sample(LETTERS[1:10], 100, T), 
                  stringsAsFactors = F)
df2 <- data.frame(pebble = sample(1:100, 10), 
                  bucket = sample(LETTERS[1:10], 10, T), 
                  stringsAsFactors = F)

random.permutation.df1 <- data.frame(pebble = df1$pebble, bucket = sample(df1$bucket))

随机排列不符合条件，所以尝试新的：

merge(random.permutation.df1, df2)
#>   pebble bucket
#> 1     60      J

while(TRUE) {
  random.permutation.df1 <- data.frame(pebble = df1$pebble, bucket = sample(df1$bucket))
  if(nrow(merge(random.permutation.df1, df2)) == 0)
    break;
}

新排列符合条件：

merge(random.permutation.df1, df2)
#> [1] pebble bucket
#> <0 Zeilen> (oder row.names mit Länge 0)
colSums(table(random.permutation.df1))
#>  A  B  C  D  E  F  G  H  I  J 
#>  7 12 11  9 14  7 11 11 11  7
colSums(table(df1))
#>  A  B  C  D  E  F  G  H  I  J 
#>  7 12 11  9 14  7 11 11 11  7