Создание вектора в R отсчетов для количества раз, когда каждый элемент появляется в другом векторе
Мне сложно это объяснить, поэтому я просто приведу пример. У меня есть два вектора ниже (a и b).
a <- c("cat","dog","banana","yogurt","dog")
b <- c("salamander","worm","dog","banana","cat","yellow","blue")
Я хотел бы получить следующие результаты:
[1] 0 0 2 1 1 0 0
где каждый элемент результата — это количество раз, когда каждый элемент b появляется в векторе a.
do.call("c",lapply(b,function(x){sum(x == a)}))
Это дает мне то, что я хочу, но мне нужна векторная/более быстрая версия этого, потому что я работаю с> 20 000 записей. Любая помощь приветствуется!
@ Эндрю а и б довольно маленькие. Размер b равен 15, а размер a зависит от данных, отфильтрованных по идентификатору. a может варьироваться от 0 до примерно 50. В большинстве случаев оно меньше, чем b.
Ответы 6
Возможно, это немного быстрее, но не уверен, что это серьезное улучшение:
vapply(b, function(x) sum(x == a), FUN.VALUE = integer(1))
Выход:
salamander worm dog banana cat yellow blue
0 0 2 1 1 0 0
Также unlist с lapply может быть более эффективной комбинацией в семействе apply:
unlist(lapply(b, function(x) sum(x == a)))
Выход:
[1] 0 0 2 1 1 0 0
У меня сейчас нет возможности провести сравнительный анализ, однако я также считаю, что ненужное использование фигурных скобок ({}) может негативно сказаться на производительности.
Вы можете использовать создать вектор счетчиков для количества раз, когда каждый элемент появляется в другом векторе, используя factor для сопоставления обоих векторов и table для подсчета, предполагая, что b уникально:
table(factor(a, levels=b))
#salamander worm dog banana cat yellow blue
# 0 0 2 1 1 0 0
Чтобы оптимизировать это, сопоставление может быть выполнено с помощью match, а подсчет с помощью tabulate:
tabulate(match(a,b), length(b))
#[1] 0 0 2 1 1 0 0
В случае, если b не уникален, вы можете использовать:
Ub <- unique(b)
tabulate(match(a,Ub), length(Ub))[match(b,Ub)]
#[1] 0 0 2 1 1 0 0
rm(Ub)
Должна быть возможность ускорить его, помещая наиболее частые случаи в начало b. Также изменение использования tabulate(bin, nbins) на .Internal(tabulate(bin, nbins)) должно немного уменьшить время вычислений.
Вместо использования match можно использовать fastmatch::fmatch, что может сократить время вычислений:
library(fastmatch)
tabulate(fmatch(a,b), length(b))
#[1] 0 0 2 1 1 0 0
Не уверен насчет скорости, но могу:
purrr::map_dbl(b, ~sum(.x==a))
[1] 0 0 2 1 1 0 0
Альтернатива base/ stringi может быть медленнее:
sapply(b,function(x) sum(stringi::stri_count(x,
regex=a)))
salamander worm dog banana cat yellow
0 0 2 1 1 0
blue
0
Вы можете использовать outer с colSums:
colSums(outer(a, b, `==`))
[1] 0 0 2 1 1 0 0
outer создаст матрицу a*b, которая в вашем случае будет 4e+08 (2e4*2e4), что может занять много памяти.
@GKi, абсолютно согласен. outer будет быстрым, если a или b относительно короткие, но увязнут по мере увеличения матрицы. Это определенно не самое быстрое решение, если матрица 2e4x2e4, но мне это неясно из вопроса.
Ты можешь сделать:
res <- table(factor(b, levels=b)[match(a, b, nomatch=0)])
salamander worm dog banana cat yellow blue
0 0 2 1 1 0 0
Если вам нужен ванильный вектор, есть as.vector(res).
Комментарии
- (Спасибо @HectorHaffenden) Этот подход предполагает, что все значения в b различны.
- Я ожидаю, что это будет быстрее, чем проводить исчерпывающие сравнения с
==, как в некоторых других ответах. Шаги очень похожи на двойное слияние @GKi: найти, где совпадают векторы, затем сопоставить обратно с b.
Ориентиры
Требуемые пакеты: data.table, purrr, microbenchmark
Различные варианты
library(data.table)
# NelsonGon's answer
purrem <- function() purrr::map_dbl(b, ~sum(.x==a))
# Andrew's answer
vappem <- function() vapply(b, function(x) sum(x == a), FUN.VALUE = integer(1))
# Andrew's answer
collem <- function() colSums(outer(a, b, `==`))
# arg0naut91's answer
lappem <- function() unlist(lapply(b, function(x) sum(x == a)))
# this answer
matchem <- function() table(factor(b, levels=b)[match(a, b, nomatch=0)])
# this answer + data.table
matchem2<- function()
setDT(list(b))[, n := 0L][setDT(list(a))[, .N, by=V1], on=.(V1), n := N]$n
# @GKi's answer
mergem <- function() merge(b, table(merge(a, b, by=1)), by=1, all.x=T)[,2]
Пример кода ввода и бенчмаркинга
nv = 1e4 # values that can appear in a
nb = 1e3 # values to look up, nb <= na
na = 1e5 # length of a
set.seed(1)
a <- sample(nv, na, replace=TRUE)
b <- seq_len(nb)
microbenchmark::microbenchmark(times = 10,
pur_res <- purrem(),
vap_res <- vappem(),
col_res <- collem(),
lap_res <- lappem(),
mat_res <- matchem(),
mat_res2<- matchem2(),
mer_res <- mergem()
)
# make sure results match
# left as an exercise for the cautious user
identical(as.vector(mat_res), lap_res) # ok
identical(as.integer(col_res), lap_res) # ok
# etc
Результаты
Unit: milliseconds
expr min lq mean median uq max neval
pur_res <- purrem() 373.488498 389.331825 479.039835 430.363183 500.948370 858.77997 10
vap_res <- vappem() 367.247322 397.516902 472.635368 505.782597 532.951841 570.68548 10
col_res <- collem() 1353.356494 1481.029982 1507.536324 1515.966781 1552.886597 1650.93967 10
lap_res <- lappem() 352.197701 394.562073 469.988534 507.935397 525.426475 559.56388 10
mat_res <- matchem() 3.032507 3.230309 5.101941 3.371101 3.874484 15.31595 10
mat_res2 <- matchem2() 7.591947 11.666453 12.809046 12.266796 13.676658 22.04095 10
mer_res <- mergem() 23.448314 23.712974 27.730525 24.547323 24.716967 46.92548 10
Если это занимает менее секунды, умещается в памяти и запускается один раз, выбор среди этих вариантов, вероятно, не слишком важен. Ранжирование среди немедленных вариантов, вероятно, зависит от параметров фактической проблемы OP (которые nv, na, nb, как мы надеемся, можно скорректировать для аппроксимации здесь).
Не стесняйтесь редактировать дополнительные параметры и запускать повторно, копируя свои результаты вместо моих здесь. Например, я не смог заставить подход @NelsonGon stringi работать с этими параметрами, но, возможно, у кого-то есть больше терпения или более мощный компьютер. Мне также было бы любопытно увидеть использование памяти, но я еще не изучил пакеты, которые поддерживают ее измерение.
Если есть какая-то конфигурация nv/na/nb, в которой один ответ работает особенно хорошо, можно отредактировать этот ответ с помощью аналогичного эталона, выделяющего этот случай.
Просто к вашему сведению:
bench::mark(
pur_res <- purrem(),
vap_res <- vappem(),
col_res <- collem(),
lap_res <- lappem(),
mat_res <- matchem(),
mat_res2<- matchem2(),
mer_res <- mergem(),
stringi <- sapply(b, function(x) sum(stringi::stri_count(x, regex=a))),
check=FALSE
)
# A tibble: 8 x 14
expression min mean median max `itr/sec` mem_alloc n_gc n_itr total_time result memory time gc
<chr> <bch:tm> <bch:tm> <bch:tm> <bch:tm> <dbl> <bch:byt> <dbl> <int> <bch:tm> <list> <list> <list> <list>
1 pur_res <- purrem() 421.14ms 424.65ms 424.65ms 428.15ms 2.35 382.21MB 0 2 849.29ms <dbl [1,0~ <Rprofmem [2,1~ <bch:~ <tibble [2 ~
2 vap_res <- vappem() 367.88ms 370.61ms 370.61ms 373.34ms 2.70 381.52MB 0 2 741.23ms <int [1,0~ <Rprofmem [1,0~ <bch:~ <tibble [2 ~
3 col_res <- collem() 1.64s 1.64s 1.64s 1.64s 0.608 1.12GB 2 1 1.64s <dbl [1,0~ <Rprofmem [32 ~ <bch:~ <tibble [1 ~
4 lap_res <- lappem() 411.25ms 506.67ms 506.67ms 602.1ms 1.97 381.53MB 3 2 1.01s <int [1,0~ <Rprofmem [1,0~ <bch:~ <tibble [2 ~
5 mat_res <- matchem() 3.11ms 3.48ms 3.44ms 5.79ms 287. 1.4MB 0 144 501.66ms <S3: tabl~ <Rprofmem [90 ~ <bch:~ <tibble [14~
6 mat_res2 <- matchem2() 5.22ms 6.26ms 5.96ms 27.7ms 160. 4.83MB 1 80 501.18ms <int [1,0~ <Rprofmem [435~ <bch:~ <tibble [80~
7 mer_res <- mergem() 19.88ms 22.75ms 22.02ms 33.6ms 44.0 6.59MB 1 23 523.3ms <int [1,0~ <Rprofmem [410~ <bch:~ <tibble [23~
8 stringi <- sapply(b, function(x) sum(string~ 6.57m 6.57m 6.57m 6.57m 0.00254 1.12GB 1 1 6.57m <int [1,0~ <Rprofmem [2,3~ <bch:~ <tibble [1 ~
@NelsonGon :) Справедливый вопрос. Я собирался добавить ваш stringi, а также проверить, сделал ли fixed= вместо regex= быстрее, но потерял терпение при попытке запустить его один раз. Попробуйте system.time(res <- sapply(b,function(x) sum(stringi::stri_count(x, regex=a)))) с примерами данных здесь. Я пропускал map_dbl, так как я думаю (?) Это то же самое, что и vapply... но теперь я также заметил, что остановился на vapply, упс... Сейчас попробую эти два
В настоящее время
tabulate(match(a,b), length(b)) или tabulate(fastmatch::fmatch(a,b), length(b))
являются самыми быстрыми и имеют наименьшее использование памяти.
library(data.table)
library(purrr)
library(fastmatch)
library(microbenchmark)
fun <- alist(ACE = do.call("c",lapply(b,function(x){sum(x == a)}))
, Andrew = colSums(outer(a, b, `==`))
, arg0naut911 = vapply(b, function(x) sum(x == a), FUN.VALUE = integer(1))
, arg0naut912 = unlist(lapply(b, function(x) sum(x == a)))
, NelsonGon1 = purrr::map_dbl(b, ~sum(.x==a))
# , NelsonGon2 = sapply(b,function(x) sum(stringi::stri_count(x, regex=a))) #This is somehow slow
, Frank1 = table(factor(b, levels=b)[match(a, b, nomatch=0)])
, Frank2 = setDT(list(b))[, n := 0L][setDT(list(a))[, .N, by=V1], on=.(V1), n := N]$n
, GKi1 = table(factor(a, levels=b))
, GKi2 = tabulate(match(a,b), length(b))
, GKi3 = {Ub <- unique(b); tabulate(match(a,Ub), length(Ub))[match(b,Ub)]; rm(Ub)}
, GKi4 = tabulate(fmatch(a,b), length(b))
)
memUse <- function(list, setup = "", gctort = FALSE) {
as.data.frame(lapply(list, function(z) {
eval(setup)
ttt <- sum(.Internal(gc(FALSE, TRUE, TRUE))[13:14])
gctorture(on = gctort)
eval(z)
gctorture(on = FALSE)
sum(.Internal(gc(FALSE, FALSE, TRUE))[13:14]) - ttt
}))
}
nv = 1e4 # values that can appear in a
nb = 1e3 # values to look up, nb <= na
na = 1e5 # length of a
set.seed(42)
a <- sample(nv, na, replace=TRUE)
b <- seq_len(nb)
microbenchmark(list = fun, times = 10)
#Unit: milliseconds
# expr min lq mean median uq max neval
# ACE 269.954636 331.972708 328.789761 344.776136 345.382701 354.785752 10
# Andrew 848.698037 863.489016 876.087567 871.606562 880.389684 925.432033 10
# arg0naut911 269.009657 311.542098 324.791662 338.709570 344.767421 355.313022 10
# arg0naut912 269.993883 323.843154 330.403232 337.707712 345.261788 377.198969 10
# NelsonGon1 271.066344 316.591125 334.548298 341.959808 350.633499 365.647488 10
# Frank1 2.845864 2.880154 3.003895 3.029094 3.085876 3.232025 10
# Frank2 3.928908 4.066095 5.148183 4.162109 4.452070 13.676931 10
# GKi1 31.971671 32.343447 32.626064 32.733487 32.832000 33.282033 10
# GKi2 1.779743 1.859890 1.948823 1.970881 2.018004 2.099922 10
# GKi3 1.882411 1.946231 2.059325 2.055469 2.188922 2.214205 10
# GKi4 1.103117 1.160845 1.243543 1.242525 1.260500 1.500836 10
memUse(list=fun, gctort = FALSE) #in Mb
# ACE Andrew arg0naut911 arg0naut912 NelsonGon1 Frank1 Frank2 GKi1 GKi2 GKi3 GKi4
#1 382.4 1144.4 382.3 382.3 360.2 1.3 3.2 4.6 0.8 0.8 0.4
memUse(list=fun, gctort = TRUE) #in Mb
# ACE Andrew arg0naut911 arg0naut912 NelsonGon1 Frank1 Frank2 GKi1 GKi2 GKi3 GKi4
#1 1.7 1144.5 1.6 1.6 1.2 0.9 2.2 2.9 0.8 0.8 0.4
### Variant B - Mimicking the case of ACE ###
set.seed(42)
nv <- 20
nb <- 15
na <- 50 #max
lengtha <- 20000
xv <- replicate(nv, paste0(sample(LETTERS, sample(3:15, 1), TRUE), collapse = ""))
b <- sample(xv, nb)
la <- replicate(lengtha, sample(xv, sample(0:na, 1), TRUE))
fun <- alist(ACE = lapply(la, function(a) {do.call("c",lapply(b,function(x){sum(x == a)}))})
, Andrew = lapply(la, function(a) {colSums(outer(a, b, `==`))})
, arg0naut911 = lapply(la, function(a) {vapply(b, function(x) sum(x == a), FUN.VALUE = integer(1))})
, arg0naut912 = lapply(la, function(a) {unlist(lapply(b, function(x) sum(x == a)))})
, NelsonGon1 = lapply(la, function(a) {purrr::map_dbl(b, ~sum(.x==a))})
# , NelsonGon2 = lapply(la, function(a) {sapply(b,function(x) sum(stringi::stri_count(x, regex=a)))}) #This is somehow slow
, Frank1 = lapply(la, function(a) {table(factor(b, levels=b)[match(a, b, nomatch=0)])})
, Frank2 = lapply(la, function(a) {setDT(list(b))[, n := 0L][setDT(list(a))[, .N, by=V1], on=.(V1), n := N]$n})
, GKi1 = lapply(la, function(a) {table(factor(a, levels=b))})
, GKi2 = lapply(la, function(a) {tabulate(match(a,b), length(b))})
, GKi3 = lapply(la, function(a) {Ub <- unique(b); tabulate(match(a,Ub), length(Ub))[match(b,Ub)]; rm(Ub)})
, GKi4 = lapply(la, function(a) {tabulate(fmatch(a,b), length(b))})
)
microbenchmark(list = fun, times = 10)
#Unit: milliseconds
# expr min lq mean median uq max neval
# ACE 465.81627 473.90476 497.44989 486.15057 530.19484 550.1138 10
# Andrew 434.23044 439.07163 467.63245 447.41847 486.72514 564.0105 10
# arg0naut911 434.10375 453.50480 506.61509 503.49702 547.05514 619.0931 10
# arg0naut912 423.36126 427.58611 472.05053 482.25018 499.00205 534.3943 10
# NelsonGon1 1471.78370 1550.21649 1581.23682 1574.90285 1606.96480 1695.4031 10
# Frank1 1283.42164 1316.24555 1353.04844 1356.99698 1382.43747 1419.8793 10
# Frank2 34208.83565 35393.61614 36239.77059 35568.44068 37873.94184 39361.0081 10
# GKi1 1101.14022 1153.13165 1192.08497 1184.66592 1221.57634 1321.6016 10
# GKi2 77.63488 79.44446 94.12155 82.22419 97.47998 138.5571 10
# GKi3 673.66302 708.49934 728.21153 729.96899 759.65502 773.2909 10
# GKi4 81.43012 83.92463 91.73833 86.39957 92.53420 137.13057 10
memUse(list=fun, gctort = FALSE) #in Mb
# ACE Andrew arg0naut911 arg0naut912 NelsonGon1 Frank1 Frank2 GKi1 GKi2 GKi3 Gki4
#1 28.9 48.6 28.9 29.1 28.5 30.6 41.3 28.9 29.4 25.3 25.4
Просто из любопытства, какова длина
aиbв ваших данных?