Crear un vector en R de conteos por la cantidad de veces que cada elemento aparece en otro vector

Question

Esto es difícil de explicar para mí, así que solo daré un ejemplo. Tengo dos vectores a continuación (a & b).

a <- c("cat","dog","banana","yogurt","dog")
b <- c("salamander","worm","dog","banana","cat","yellow","blue")

Lo que me gustaría son los siguientes resultados:

[1] 0 0 2 1 1 0 0 

donde cada elemento del resultado es el número de veces que cada elemento de b aparece en el vector a.

do.call("c",lapply(b,function(x){sum(x == a)}))

Esto me da lo que quiero, pero necesito una versión vectorizada / más rápida de esto porque estoy trabajando con más de 20,000 registros. Cualquier ayuda apreciada!

Answer 1

Actualmente tabulate(match(a,b), length(b)) o tabulate(fastmatch::fmatch(a,b), length(b)) son las más rápidas y tienen el menor uso de memoria.

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

Answer 2

No estoy seguro acerca de la velocidad pero puedo hacer:

purrr::map_dbl(b, ~sum(.x==a))
[1] 0 0 2 1 1 0 0

Una alternativa base / stringi podría ser más lenta:

 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 

Answer 3

Puede crear un vector de recuentos para la cantidad de veces que cada elemento aparece en otro vector usando el factor para unir ambos vectores y la table para contar suponiendo que b es único:

table(factor(a, levels=b))
#salamander worm dog banana cat yellow blue
# 0 0 2 1 1 0 0 

Para optimizar esto, la coincidencia se puede hacer por match y el recuento por tabulate :

tabulate(match(a,b), length(b))
#[1] 0 0 2 1 1 0 0

En caso de que b no sea único, puede usar:

Ub <- unique(b)
tabulate(match(a,Ub), length(Ub))[match(b,Ub)]
#[1] 0 0 2 1 1 0 0
rm(Ub)

Debería ser posible acelerarlo, al colocar los casos más frecuentes al comienzo de b . También cambiar el uso de tabulate(bin, nbins) a .Internal(tabulate(bin, nbins)) debería disminuir un poco el tiempo de cálculo.

En lugar de usar match , fastmatch::fmatch podría usarse, lo que puede disminuir el tiempo de cálculo:

library(fastmatch)
tabulate(fmatch(a,b), length(b))
#[1] 0 0 2 1 1 0 0

Answer 4

Puede usar outer con colSums :

colSums(outer(a, b, `==`))
[1] 0 0 2 1 1 0 0

Answer 5

Quizás esto sea un poco más rápido, pero no estoy seguro de si una mejora importante:

vapply(b, function(x) sum(x == a), FUN.VALUE = integer(1))

Salida:

salamander worm dog banana cat yellow blue
0 0 2 1 1 0 0 

Además, unlist con lapply puede ser una combinación ligeramente mejor en la familia de apply :

unlist(lapply(b, function(x) sum(x == a)))

Salida:

[1] 0 0 2 1 1 0 0

No tengo la oportunidad de comparar correctamente en este momento, sin embargo, creo que también el uso innecesario de llaves ( {} ) puede afectar negativamente el rendimiento.

Answer 6

Tu puedes hacer:

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 

Si desea un vector de vainilla, hay as.vector(res) .

Comentarios

• (Gracias a @HectorHaffenden) Este enfoque supone que todos los valores en b son distintos.
• Espero que esto sea más rápido que hacer comparaciones exhaustivas con == como en algunas otras respuestas. Los pasos son bastante similares a la combinación doble de @ GKi: encuentre dónde coinciden los vectores, luego vuelva a asignar a b.

Puntos de referencia

Paquetes requeridos: data.table, purrr, microbenchmark

Varias opciones

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]

Ejemplo de entrada y código de evaluación comparativa

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

Resultados

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

Si toma menos de un segundo, cabe en la memoria y se ejecuta una vez, elegir entre estas opciones probablemente no sea demasiado importante. La clasificación entre las opciones no lentas probablemente depende de los parámetros del problema real del OP (que nv, na, nb se puede ajustar para aproximarse aquí).

Siéntase libre de editar más opciones y volver a ejecutar, copiando sus resultados sobre los míos aquí. Por ejemplo, no pude lograr que el enfoque stringi de @ NelsonGon funcione con estos parámetros, pero tal vez alguien más tenga más paciencia o una computadora más poderosa. También me gustaría ver el uso de la memoria, pero aún no he aprendido los paquetes que permiten medirlo.

Si hay alguna configuración nv / na / nb donde una respuesta funciona particularmente bien, la edición de esa respuesta con un punto de referencia similar que resalta ese caso es una opción.

Solo para tu información:

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 ~