Cómo indexar una secuencia vectorial dentro de una secuencia vectorial

performance

Question

Tengo una solución a un problema que implica bucle y funciona, pero siento que me falta algo que implique una implementación más eficiente. El problema: tengo una secuencia de vectores numéricos y quiero identificar las posiciones iniciales en otro vector del primer vector.

Funciona así:

# helper function for matchSequence
# wraps a vector by removing the first n elements and padding end with NAs
wrapVector <- function(x, n) {
    stopifnot(n <= length(x))
    if (n == length(x)) 
        return(rep(NA, n))
    else
        return(c(x[(n+1):length(x)], rep(NA, n)))
}

wrapVector(LETTERS[1:5], 1)
## [1] "B" "C" "D" "E" NA
wrapVector(LETTERS[1:5], 2)
## [1] "C" "D" "E" NA  NA

# returns the starting index positions of the sequence found in a vector
matchSequence <- function(seq, vec) {
    matches <- seq[1] == vec
    if (length(seq) == 1) return(which(matches))
    for (i in 2:length(seq)) {
        matches <- cbind(matches, seq[i] == wrapVector(vec, i - 1))
    }
    which(rowSums(matches) == i)
}

myVector <- c(3, NA, 1, 2, 4, 1, 1, 2)
matchSequence(1:2, myVector)
## [1] 3 7
matchSequence(c(4, 1, 1), myVector)
## [1] 5
matchSequence(1:3, myVector)
## integer(0)

¿Hay una mejor manera de implementar matchSequence() ?

Adicional

"Mejor" aquí puede significar usar métodos más elegantes en los que no pensé, pero aún mejor, significaría más rápido. Intente comparar soluciones para:

set.seed(100)
myVector2 <- sample(c(NA, 1:4), size = 1000, replace = TRUE)
matchSequence(c(4, 1, 1), myVector2)
## [1]  12  48  91 120 252 491 499 590 697 771 865

microbenchmark::microbenchmark(matchSequence(c(4, 1, 1), myVector2))
## Unit: microseconds
##                                 expr     min       lq     mean   median       uq     max naval
## matchSequence(c(4, 1, 1), myVector2) 154.346 160.7335 174.4533 166.2635 176.5845 300.453   100

Answer 1

Aquí hay otra forma:

myVector <- c(3, NA, 1, 2, 4, 1, 1, 2)
matchSequence <- function(seq,vec) {
  n.vec <- length(vec)
  n.seq <- length(seq)
  which(sapply(1:(n.vec-n.seq+1),function(i)all(head(vec[i:n.vec],n.seq)==seq)))
}
matchSequence(1:2,myVector)
# [1] 3 7
matchSequence(c(4,1,1),myVector)
# [1] 5
matchSequence(1:3,myVector)
# integer(0)

Answer 2

Aquí hay una idea algo diferente:

f <- function(seq, vec) {
    mm <- t(embed(vec, length(seq))) == rev(seq)  ## relies on recycling of seq
    which(apply(mm, 2, all))
}

myVector <- c(3, NA, 1, 2, 4, 1, 1, 2)

f(1:2, myVector)
# [1] 3 7
f(c(4,1,1), myVector)
# [1] 5
f(1:3, myVector)
# integer(0)

Answer 3

Otro intento que creo es más rápido nuevamente. Esto debe su velocidad a solo buscar coincidencias desde puntos en el vector que coinciden con el inicio de la secuencia buscada.

flm <- function(sq, vec) {
  hits <- which(sq[1]==vec)
  out <- hits[
    colSums(outer(0:(length(sq)-1), hits, function(x,y) vec[x+y]) == sq)==length(sq)
  ]
  out[!is.na(out)]
}

Resultados de referencia:

#Unit: relative
#  expr      min       lq     mean   median       uq     max neval
# josh2 2.469769 2.393794 2.181521 2.353438 2.345911 1.51641   100
#    lm 1.000000 1.000000 1.000000 1.000000 1.000000 1.00000   100

Answer 4

Y una idea recursiva (editar el 5 de febrero de 2016 para trabajar con NA en el patrón) :

find_pat = function(pat, x) 
{
    ff = function(.pat, .x, acc = if(length(.pat)) seq_along(.x) else integer(0L)) {
        if(!length(.pat)) return(acc)

        if(is.na(.pat[[1L]])) 
            Recall(.pat[-1L], .x, acc[which(is.na(.x[acc]))] + 1L)
        else 
            Recall(.pat[-1L], .x, acc[which(.pat[[1L]] == .x[acc])] + 1L)
    }

    return(ff(pat, x) - length(pat))
}  

find_pat(1:2, myVector)
#[1] 3 7
find_pat(c(4, 1, 1), myVector)
#[1] 5
find_pat(1:3, myVector)
#integer(0)
find_pat(c(NA, 1), myVector)
#[1] 2
find_pat(c(3, NA), myVector)
#[1] 1

Y en un punto de referencia:

all.equal(matchSequence(s, my_vec2), find_pat(s, my_vec2))
#[1] TRUE
microbenchmark::microbenchmark(matchSequence(s, my_vec2), 
                               flm(s, my_vec2), 
                               find_pat(s, my_vec2), 
                               unit = "relative")
#Unit: relative
#                      expr      min       lq   median       uq      max neval
# matchSequence(s, my_vec2) 2.970888 3.096573 3.068802 3.023167 12.41387   100
#           flm(s, my_vec2) 1.140777 1.173043 1.258394 1.280753 12.79848   100
#      find_pat(s, my_vec2) 1.000000 1.000000 1.000000 1.000000  1.00000   100

Usando datos más grandes:

set.seed(911); VEC = sample(c(NA, 1:3), 1e6, TRUE); PAT = c(3, 2, 2, 1, 3, 2, 2, 1, 1, 3)
all.equal(matchSequence(PAT, VEC), find_pat(PAT, VEC))
#[1] TRUE
microbenchmark::microbenchmark(matchSequence(PAT, VEC), 
                               flm(PAT, VEC), 
                               find_pat(PAT, VEC), 
                               unit = "relative", times = 20)
#Unit: relative
#                    expr       min       lq    median        uq       max neval
# matchSequence(PAT, VEC) 23.106862 20.54601 19.831344 18.677528 12.563634    20
#           flm(PAT, VEC)  2.810611  2.51955  2.963352  2.877195  1.728512    20
#      find_pat(PAT, VEC)  1.000000  1.00000  1.000000  1.000000  1.000000    20

Answer 5

Otra idea:

match_seq2 <- function(s,v){
  n  = length(s)
  nc = length(v)-n+1
  which(
    n == rowsum(
      as.integer(v[ rep(0:(n-1), nc) + rep(1:nc, each=n) ] == s),
      rep(seq(nc),each=n)
    )
  )
}

Intenté una versión de tapply , pero fue ~ 4 veces más lenta.

Primera idea

match_seq <- function(s, v) Filter( 
  function(i) all.equal( s, v[i + seq_along(s) - 1] ), 
  which( v == s[1] )
) 

# examples:
my_vec <- c(3, NA, 1, 2, 4, 1, 1, 2)
match_seq(1:2, my_vec)      # 3 7
match_seq(c(4,1,1), my_vec) # 5
match_seq(1:3, my_vec)      # integer(0)

Estoy usando all.equal lugar de identical porque el OP quiere que el entero 1:2 coincida con el numérico c(1,2) . Este enfoque introduce un caso más al permitir la comparación con puntos más allá del final de my_vec (que son NA cuando están indexados):

match_seq(c(1,2,NA), my_vec) # 7

El punto de referencia del OP

# variant on Josh''s, suggested by OP:

f2 <- function(seq, vec) {
    mm <- t(embed(vec, length(seq))) == rev(seq)  ## relies on recycling of seq
    which(colSums(mm)==length(seq))
}

my_check <- function(values) {
  all(sapply(values[-1], function(x) identical(values[[1]], x)))
}

set.seed(100)
my_vec2 <- sample(c(NA, 1:4), size = 1000, replace = TRUE)
s       <- c(4,1,1)
microbenchmark(
    op = matchSequence(s, my_vec2), 
    josh = f(s, my_vec2), 
    josh2 = f2(s, my_vec2), 
    frank = match_seq(s, my_vec2), 
    frank2 = match_seq2(s, my_vec2), 
    jlh = matchSequence2(s, my_vec2),
    tlm = flm(s, my_vec2),
    alexis = find_pat(s, my_vec2),
    unit = "relative", check=my_check)

Resultados:

Unit: relative
   expr        min         lq       mean     median         uq        max neval
     op   3.693609   3.505168   3.222532   3.481452   3.433955  1.9204263   100
   josh  15.670380  14.756374  12.617934  14.612219  14.575440  3.1076794   100
  josh2   3.115586   2.937810   2.602087   2.903687   2.905654  1.1927951   100
  frank 171.824973 157.711299 129.820601 158.304789 155.009037 15.8087792   100
 frank2   9.352514   8.769373   7.364126   8.607341   8.415083  1.9386370   100
    jlh 215.304342 197.643641 166.450118 196.657527 200.126846 44.1745551   100
    tlm   1.277462   1.323832   1.125965   1.333331   1.379717  0.2375295   100
 alexis   1.000000   1.000000   1.000000   1.000000   1.000000  1.0000000   100

¡Entonces las victorias de alexis_laz!

(No dude en actualizar esto. Consulte la respuesta de alexis para obtener un punto de referencia adicional).