有效地找到集合差异并生成随机样本

Question

我有一个非常大的数据集，其中包含分类标签 a 和一个向量 b，其中包含数据集中所有可能的标签：

a <- c(1,1,3,2)   # artificial data
b <- c(1,2,3,4)   # fixed categories

现在我想为a 中的每个观察找到所有剩余类别的集合（即b 的元素，不包括a 中的给定观察）。从剩下的这些类别中，我想随机抽取一个。

我使用循环的方法是

goal <- numeric() # container for results

for(i in 1:4){

d       <- setdiff(b, a[i]) # find the categories except the one observed in the data
goal[i] <- sample(d,1)      # sample one of the remaining categories randomly

}

goal
[1] 4 4 1 1

但是，这必须多次执行并应用于非常大的数据集。有没有人有更高效的版本来达到预期的结果？

编辑：

不幸的是，akrun 的函数比原来的循环慢。如果有人提出具有竞争力的创意想法，我很高兴听到！

Answer 1

我们可以使用vapply

vapply(a,  function(x) sample(setdiff(b, x), 1), numeric(1))

---

set.seed(24)
a <- sample(c(1:4), 10000, replace=TRUE)
b <- 1:4
system.time(vapply(a,  function(x) sample(setdiff(b, x), 1), numeric(1)))
#   user  system elapsed 
#  0.208   0.007   0.215 

Answer 2

更新：这是带有mapply 的快速版本。此方法避免为每次迭代调用sample()，因此速度更快。 -

mapply(function(x, y) b[!b == x][y], a, sample(length(b) - 1, length(a), replace = T))

---

这是一个没有setdiff 的版本（setdiff 可能有点慢），尽管我认为可以进行更多优化。 -

vapply(a, function(x) sample(b[!b == x], 1), numeric(1))

---

基准 -

set.seed(24)
a <- sample(c(1:4), 1000, replace=TRUE)
b <- 1:4

microbenchmark::microbenchmark(
  akrun = vapply(a,  function(x) sample(setdiff(b, x), 1), numeric(1)),
  shree = vapply(a, function(x) sample(b[!b == x], 1), numeric(1)),
  shree_mapply = mapply(function(x, y) b[!b == x][y], a, sample(length(b) - 1, length(a), replace = T))
)


Unit: milliseconds
         expr     min       lq      mean   median       uq      max neval
        akrun 28.7347 30.66955 38.319655 32.57875 37.45455 237.1690   100
        shree  5.6271  6.05740  7.531964  6.47270  6.87375  45.9081   100
 shree_mapply  1.8286  2.01215  2.628989  2.14900  2.54525   7.7700   100

Answer 3

事实证明，重新采样与数据中的标签相同的标签是一种更快的方法，使用

 test = sample(b, length(a), replace=T)
  resample = (a == test)

  while(sum(resample>0)){

  test[resample] = sample(b, sum(resample), replace=T)
  resample = (a == test)
  }

更新了 N=10,000 的基准：

Unit: microseconds
                               expr       min        lq       mean    median         uq       max neval
                               loop 14337.492 14954.595 16172.2165 15227.010 15585.5960 24071.727   100
                              akrun 14899.000 15507.978 16271.2095 15736.985 16050.6690 24085.839   100
                           resample    87.242   102.423   113.4057   112.473   122.0955   174.056   100
        shree(data = a, labels = b)  5195.128  5369.610  5472.4480  5454.499  5574.0285  5796.836   100
 shree_mapply(data = a, labels = b)  1500.207  1622.516  1913.1614  1682.814  1754.0190 10449.271   100