Эффективно находите установленные различия и генерируйте случайную выборку

У меня есть очень большой набор данных с категориальными метками 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, к сожалению, медленнее, чем исходный цикл. Если у кого-то есть креативная идея с конкурентоспособным результатом, буду рад услышать!


r set sample set-difference
person Mr. Z    schedule 16.08.2019    source источник
comment
Готово, спасибо, что указали.   -  person Mr. Z    schedule 16.08.2019

Ответы (3)


arrow_upward
3
arrow_downward

Мы можем использовать 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
person akrun    schedule 16.08.2019
comment
Я просто пытался сравнить масштабируемость. Интересно, что следующий код приводит к ошибке (исходный пример работает нормально!). У вас есть идея, почему? a <- sample(c(1:4), 10000, replace=T) b <- c(1,2,3,4) vapply(a, function(x) sample(setdiff(b, a), 1), numeric(1)) Error in sample.int(length(x), size, replace, prob) : invalid first argument - person Mr. Z; 16.08.2019
comment
@Мистер Дзен. в setdiff у меня была опечатка, извините, это x - person akrun; 16.08.2019
comment
Спасибо за исправление! К сожалению, предлагаемый подход даже медленнее, чем исходный цикл (см. Верхнее редактирование сообщения). - person Mr. Z; 16.08.2019
comment
@Мистер Дзен. Я думал, вы хотите специально использовать функцию setdiff. - person akrun; 16.08.2019
comment
Извините за неясность! Использование setdiff было моей первой интуицией, в этом нет необходимости. - person Mr. Z; 16.08.2019

arrow_upward
3
arrow_downward

Оказывается, повторная выборка меток, которые равны меткам в данных, является еще более быстрым подходом, используя

 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
person Mr. Z    schedule 16.08.2019
comment
Это замечательно!. Почти оцифровано, так что его будет сложно превзойти. Единственная возможность для улучшения, по-видимому, заключается в том, что потенциально может потребоваться несколько while итераций для повторной выборки любого значения. Я пробовал некоторые идеи, чтобы преодолеть это, но не работал с точки зрения производительности. В любом случае, хорошее нестандартное мышление. +1 - person Shree; 16.08.2019

arrow_upward
1
arrow_downward

Обновление: вот быстрая версия с 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
person Shree    schedule 16.08.2019
comment
Я пробовал sample(b[-x], 1), но это только на 10% быстрее - person Ben Bolker; 16.08.2019
comment
@BenBolker, извините, я мог что-то упустить, но разве b[-x] не удаляет x-е значение, а не значение x? - person Shree; 16.08.2019