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 ~