3

R で解決しようとしている奇妙な問題があります
。x と y の 2 つのベクトルがあり、各ベクトル内のすべての要素が一意であり、ベクトルの長さが同じで、ベクトル 2 がベクトルの順列であるとします。 1:

x <- LETTERS[c(1,2,3,4,5,6,7,8,9,10)]
y <- LETTERS[c(5,8,7,9,6,10,1,3,2,4)]

最初と最後の要素が定義された特別なタイプの順列として「チェーン」を定義しましょう。
たとえば、mayt be の順列は、mayt "A" "B" "C" "D"be"C" "B" "D" "A"
の「チェーン」です。"A" "B" "C" "D""A" "C" "B" "D"

私の目標は、x と y に共通するすべての「チェーン」を特定することです。たとえば、x と y には共通の長さ 4 のチェーンがあります。

> x[1:4]
[1] "A" "B" "C" "D"
> y[7:10]
[1] "A" "C" "B" "D"

(チェーンは A、B、C、および D であり、A で始まり D で終わる任意の順序)

共通の長さ 6 のチェーン:

> x[5:10]
[1] "E" "F" "G" "H" "I" "J"
> y[1:6]
[1] "E" "H" "G" "I" "F" "J"

(チェーンは、E、F、G、H、I、および J であり、E で始まり J で終わります)

特定の長さのサブチェーンを識別するために、次の関数を作成しました。

subChains <- function(x, y, Len){
    start.x <- rep(NA, length(x))
    start.y <- rep(NA, length(y))
    for (i in 1:(length(x) - Len + 1)) {
        for (j in 1:(length(y) - Len + 1)) {
            canidate.x <- x[i:(i+Len-1)]
            canidate.y <- y[j:(j+Len-1)]
            if (
                    canidate.x[1]==canidate.y[1] & 
                    canidate.x[Len]==canidate.y[Len] &
                    all(canidate.x %in% canidate.y) & 
                    all(canidate.y %in% canidate.x)
                    ){
                start.x[i] <- i
                start.y[i] <- j
            }
        }
    }
    return(na.omit(data.frame(start.x, start.y, Len)))
}

次のように使用されます。

> subChains(x, y, 4)
  start.x start.y Len
1       1       7   4

また、次の関数を使用して、2 つのベクトルに共通するすべてのチェーンを見つけることができます。

allSubchains <- function(x, y, Lens){
    do.call(rbind, lapply(Lens, function(l) subChains(x, y, l)))
}

次のように使用されます。

allSubchains(x, y, Lens=1:10)
   start.x start.y Len
1        1       7   1
2        2       9   1
3        3       8   1
4        4      10   1
5        5       1   1
6        6       5   1
7        7       3   1
8        8       2   1
9        9       4   1
10      10       6   1
11       1       7   4
51       5       1   6

もちろん、どちらの関数も非常に遅いです。はるかに大きな問題で妥当な時間内に実行できるように、それらを改善できますか? 例えば

n <- 100000
a <- 1:n
b <- sample(a, n)
allSubchains(a, b, Lens=50:100)
4

1 に答える 1

4

100,000 件のケースで 1 秒未満で満足できますか? これを試して：

allSubChains <- function(x, y, Lens) {

   N <- length(x)
   x.starts <- 1:N
   y.starts <- match(x, y)   # <-- That's where the money is

   subChains <- function(Len) {
      x.ends <- x.starts + Len - 1L
      y.ends <- y.starts + Len - 1L
      keep   <- which(x.ends <= N & y.ends <= N)
      good   <- keep[x[x.ends[keep]] == y[y.ends[keep]]]
      is.perm <- function(i) all(x[x.starts[i]:x.ends[i]] %in%
                                 y[y.starts[i]:y.ends[i]])
      good    <- Filter(is.perm, good) 
      if (length(good) > 0) data.frame(x.starts[good], y.starts[good], Len)
      else NULL
   }

   do.call(rbind, lapply(Lens, subChains))
}

ここでテスト：

n <- 100000
a <- 1:n
b <- sample(a, n)
system.time(z <- allSubChains(a, b, Lens=50:100))
#   user  system elapsed 
#  0.800   0.053   0.848
于 2013-01-05T02:05:14.787 に答える