Início / coding / Perguntas / 79045676
Accepted
mto_19
Asked: 2024-10-02 15:05:43 +0800 CST

Substring comum mais longa em pares rápidos desde o início

  • 772

Suponha que existam muitas cadeias binárias

x <- c("0100100010101010", "0100110010101010","0111001000","010111")

Estou procurando um método rápido em R para gerar uma matriz contendo a substring comum mais longa em pares (excluindo autocorrespondências) desde o início . Por exemplo, uma solução poderia ser assim

> mySolution(x)
    [,1]     [,2]      [,3]      [,4]
[1,] ""       "01001"   "01"     "010"
[2,] "01001"  ""        "01"     "010"
[3,] "01"     "01"      ""       "01"
[4,] "010"    "010"     "01"     ""

Por exemplo, a matriz na posição [1,2] é a maior substring comum do início de x[1]e x[2]. Note que a matriz resultante é simétrica. Então, precisamos calcular apenas metade dela.

Eu sei que isso poderia funcionar com funções como substr,sub,grepl, mas como tenho muitas strings, estou procurando uma solução muito eficiente que exija pouco tempo de computação. Talvez seja uma opção converter para números binários para melhorar o desempenho?

3 respostas

  1. Talvez não seja tão eficiente, mas deve funcionar como esperado se você tiver uma helperfunção para encontrar a maior substring comum desde o início

    helper <- function(a, b) {
    l <- min(nchar(a), nchar(b))
    aa <- substr(a, 1, l)
    bb <- substr(b, 1, l)
    vaa <- utf8ToInt(aa)
    vbb <- utf8ToInt(bb)
    if (aa == bb) {
        aa
    } else {
        k <- which.max(vaa != vbb) - 1
        ifelse(k > 0, intToUtf8(vaa[1:k]), "")
    }
}

    e além disso você pode definir funções personalizadas f1()ou f2(), por exemplo,

    f1 <- function(x) `diag<-`(outer(x, x, Vectorize(helper)), "")

    ou sua variante, mas um pouco mais rápida

    f2 <- function(x) {
    res <- matrix(rep("", length(x)^2), length(x))
    v <- combn(x, 2, \(p) helper(p[1], p[2]))
    res[lower.tri(res)] <- v
    res[upper.tri(res)] <- t(res)[upper.tri(res)]
    res
}

    tal que

    > f1(x)
     [,1]    [,2]    [,3] [,4]
[1,] ""      "01001" "01" "010"
[2,] "01001" ""      "01" "010"
[3,] "01"    "01"    ""   "01"
[4,] "010"   "010"   "01" ""

> f2(x)
     [,1]    [,2]    [,3] [,4]
[1,] ""      "01001" "01" "010"
[2,] "01001" ""      "01" "010"
[3,] "01"    "01"    ""   "01"
[4,] "010"   "010"   "01" ""

    Referência

    set.seed(0)
x <- replicate(1000, paste0(sample.int(2, sample(5, 1), TRUE) - 1, collapse = ""))
microbenchmark(
    f1(x),
    f2(x),
    unit = "relative",
    times = 10L,
    check = "equal"
)

    mostra

    Unit: relative
  expr      min       lq     mean   median       uq      max neval
 f1(x) 2.125062 2.010759 2.057626 1.951325 2.154321 2.099333    10
 f2(x) 1.000000 1.000000 1.000000 1.000000 1.000000 1.000000    10
    • 5

  2. Usar data.tablepara alguns passos custosos pode escalar por thread. Imprimindo apenas o triângulo superior.

    library(data.table) # rleid, tstrsplit

getPsub <- function(dat){

  len <- seq_along(dat)
  mlen <- max(len)

  mat <- matrix(NA, mlen, mlen)
  d <- do.call(rbind, tstrsplit(dat, ""))

  mat[lower.tri(mat)] <- apply(combn(len, 2), 2, \(x){
    res <- d[,x[1]] == d[,x[2]]
    paste(d[rleid(res) == 1 & res, x[1]], collapse="")})

  t(mat)
}

    saída

    getPsub(x)
     [,1] [,2]    [,3] [,4]
[1,] NA   "01001" "01" "010"
[2,] NA   NA      "01" "010"
[3,] NA   NA      NA   "01"
[4,] NA   NA      NA   NA
    • 3
  3. Best Answer

    Uma solução rápida para grandes vetores de strings binárias. A função flcsabaixo é capaz de executar a operação desejada em strings de caracteres binários de 10k em cerca de 13 segundos.

    A ideia é verificar sequencialmente o kcaractere th de cada string e colocar cada string em um 0bin ou um 1bin. A maior substring comum entre ie jtermina em ou antes kse ie jestiverem em bins diferentes.

    flcsretorna o ponto final da substring comum em pares, que pode ser usada para preencher o triângulo inferior da matriz desejada.

    library(data.table)

flcs <- function(x) {
  y <- lapply(x, \(x) utf8ToInt(x) == 49L)
  nx <- length(x)
  nx1 <- nx - 1L
  lens <- lengths(y)
  dt <- data.table(
    v = unlist(y),
    i = sequence(lens),
    j1 = rep.int(1:nx, lens)
  )[,j2 := (j1 - 1L)*nx]
  # `n` is a vector containing the earliest mismatch between pairs
  n <- pmin(lens[rep.int(1:nx1, nx1:1)], lens[sequence(nx1:1, 2:nx)])
  b <- logical(length(n))
  # create a vector `idx` to map to the indices of `n`
  idx <- integer(nx^2)
  idx[sequence(nx1:1, seq(2, nx^2, nx + 1))] <-
    idx[sequence(nx1:1, seq(nx + 1, nx^2, nx + 1), nx)] <- 1:length(n)
  
  for (k in 1:-sort.int(-lens, 2)[2]) {
    nstop <- idx[dt[i == k, outer(j2[v], j1[!v], "+")]]
    nstop <- nstop[!b[nstop]]
    b[nstop] <- TRUE
    n[nstop] <- k - 1L
    if (all(b)) break
  }
  
  n
}

    Demonstrando:

    x <- c("0100100010101010", "0100110010101010","0111001000","010111")
flcs(x)
#> [1] 5 2 3 2 3 2

    Uma função para construir a matriz final a partir da saída de flcs:

    buildmat <- function(x, n, symmetric = FALSE) {
  nx <- length(x)
  nx1 <- nx - 1L
  z <- matrix("", nx, nx)
  if (symmetric) {
    z[sequence(nx1:1, seq(2, nx^2, nx + 1))] <-
      z[sequence(nx1:1, seq(nx + 1, nx^2, nx + 1), nx)] <-
      substr(x[rep.int(1:nx1, nx1:1)], 1, n)
  } else {
    z[sequence(nx1:1, seq(2, nx^2, nx + 1))] <-
      substr(x[rep.int(1:nx1, nx1:1)], 1, n)
  }
  
  z
}

buildmat(x, flcs(x), TRUE)
#>      [,1]    [,2]    [,3] [,4] 
#> [1,] ""      "01001" "01" "010"
#> [2,] "01001" ""      "01" "010"
#> [3,] "01"    "01"    ""   "01" 
#> [4,] "010"   "010"   "01" ""

    Compare com uma solução que compara cada string com cada outra string em paralelo.

    library(parallel)

f <- function(x) {
  n <- min(length(x[[1]]), length(x[[2]]))
  out <- which.max(x[[1]][1:n] != x[[2]][1:n])
  if (out == 1L && x[[1]][1] == x[[2]][1]) n + 1L else out
}

cl <- makeCluster(detectCores() - 1) # 15 cores
clusterExport(cl, c("f"), environment(f))

flcsPar <- function(x) {
  unlist(parLapply(cl, combn(lapply(x, utf8ToInt), 2, NULL, FALSE), f)) - 1L
}

buildmat(x, flcsPar(x), TRUE)
#>      [,1]    [,2]    [,3] [,4] 
#> [1,] ""      "01001" "01" "010"
#> [2,] "01001" ""      "01" "010"
#> [3,] "01"    "01"    ""   "01" 
#> [4,] "010"   "010"   "01" ""

    Cronometre as duas funções em um vetor de 10k strings binárias.

    x <- vapply(1:1e4, \(.) intToUtf8(sample(48:49, sample(10:20, 1), 1)), "")
system.time(n1 <- flcs(x))
#>    user  system elapsed 
#>    9.84    3.41   13.26
system.time(n2 <- flcsPar(x))
#>    user  system elapsed 
#>   69.31   54.53  242.07
identical(n1, n2)
#> [1] TRUE

    flcsrealizou quase 50 milhões de comparações em cerca de 13 segundos.

    • 3

relate perguntas