组合学:不重复元素的随机性，我是否试图做一些不可能的事情？

Question

对标题的措辞表示歉意，如果答案非常明显，则表示歉意。我的数量背景不强，我可能会问一个愚蠢的问题。

我有一套24个项目，我们可以想象为图片，和24个标签，为这些图片。这意味着我有552对可能的图片标签对。

我想收集每个图片标签对的10个评级，所以总共有5520个评级，我想从460个参与者收集它们，每个参与者提供12个评级。

当我试图不重复地生成输入文件(选择12个图片标签对)时，我的问题就出现了。我可以做到这一点，不重复成对，但我也不希望任何图片出现两次，也不希望任何标签出现两次，在任何参与者的输入。

我已经尝试这样做了，从一个包含所有图片标签对的5520行的dataframe开始，我想收集评级。然后，我从这个dataframe中取样12行，直到找到一个不包含任何重复的示例为止，从dataframe中删除这些行并继续。这会导致陷入无限时间循环，因为我到达一个点，不再可能不重复地从其余的行中采样df。

这是因为我的做法是错误的，还是我试图做一些不可能的事情？

pairs <- as.data.frame(permutations(n = 24, r = 2, v = seq(1:24), repeats.allowed=F))
nrow(pairs)

for (i in seq(1, to =552, by =12)) {

#get sample
s <- sample(nrow(shuffled_pairs),12)
d <- shuffled_pairs[s,]

#check for repetitions of either V1 (pic) or V2 (label)
while (length(unique(d$V1))<12 | length(unique(d$V1))<12) {
    s <- sample(nrow(shuffled_pairs),12)
    d <- shuffled_pairs[s,]    
}

shuffled_pairs <- shuffled_pairs[-s,]

}

Answer 1

答案是，这是不可能的，对46名评分者:你需要48名评分者进行12个评级，以涵盖10 * 24 * 24，或5760，你需要的样本。但是，有了这个警告，就有可能在所需的约束范围内获得您想要的所有示例。代码本身非常短：

mod24 <- function(x) (x + 0:11 - 1) %% 24 + 1

df <- data.frame(picture = rep(c(rep(1:12, 24), rep(13:24, 24)), 10),
                 label = rep(do.call("c", lapply(1:24, mod24)), 20),
                 rater   = rep(c(rep(1:48, each = 12)), 10) + rep(0:9 * 48, each = 576))

然而，这需要相当多的解释。

无论你做什么，你都可以简化你的问题，把你的480个人分成10组，每组48人，每组做同样的事情，也就是说，在他们之间对每个图片/标签组合进行一次精确的评分，每组使用精确的12个评分。因此，你可以专注于一组48人如何完成这项任务，以涵盖所有576种可能性，完全一次。

另一件要注意的是，既然每个人都要挑选12幅画，你可以进一步简化，将48人组分成两组，24人，分别得到前12幅或第2 12幅画。这样，你保证不会有任何重复的绘画每一个评分者。

现在你要做的就是确保每幅画都贴上每幅画一次的标签。你可以给第一位参与者的绘画标签1:12，然后第二位参与者的绘画标签2:13等等，直到13:24，之后标签变成c(14:24, 1)，然后是c(15:24, 1:2)等。这确保了在画1:12的小组中，每幅画只分配一次。现在，对13:24的绘画也是如此。您将有48人与12个评级，涵盖所有可能的组合一次。

对每组48人做同样的操作，你将得到每个独特的图片/标签对的10个评级，每个评价者将给予12个评级，没有一个评价者会对同一幅画或标签进行两次评级。

回到我们的代码，我们可以看到df包含5760个示例：

nrow(df)
#> [1] 5760

它有576个独特的图片和标签组合，每次重复10次：

table(df$picture, df$label)
#>     
#>       1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
#>   1  10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   2  10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   3  10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   4  10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   5  10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   6  10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   7  10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   8  10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   9  10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   12 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   13 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   14 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   15 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   16 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   17 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   18 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   19 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   20 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   21 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   22 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   23 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
#>   24 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10

480名评分员中的每一位都有12对评分

table(table(df$rater))

#>  12 
#> 480 

所有这些都是独一无二的：

table(sapply(split(df, df$rater), function(x) nrow(unique(x))))

#>  12 
#> 480

编辑

OP关注的是，图片群的不断共存可能会带来一种偏见。方法是将图1:12组中的第一个人和13:24组中的第一个人配对，允许他们随机交换他们的部分分配。它们的图片不能复制，因为它们的图片没有重叠，它们的标签不能复制，因为它们总是交换相同的标签：

swaps <- do.call(c, lapply(1:10, function(x) c(rbinom(24 * 12, 1, 0.5), rep(0, 24 * 12))))
swap_out <- df[swaps == 1, ]
df[swaps == 1, ] <- df[which(swaps == 1) + 24 * 12, ]
df[which(swaps == 1) + 24 * 12, ] <- swap_out

这个新的数据框架仍然符合所有的规范。