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

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

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

 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

Answer 3

更新：这是带有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