Question

I have an odd problem that I’m trying to solve in R:
Let’s say we have 2 vectors, x and y, where every element within each vector is unique, the vectors have the same length, and vector 2 is a permutation of vector 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)]

Lets define a “chain” as a special type of permutation, with a defined first and last element.
e.g. a permutation of "A" "B" "C" "D" might be "C" "B" "D" "A"
while a “chain” of "A" "B" "C" "D" might be "A" "C" "B" "D"

My goal is to identify all the “chains” x and y have in common. For example, x and y have a chain of length 4 in common:

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

(the chain is A, B, C, and D, in any order, starting with A and ending in D)

and a chain of length 6 in common:

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

(the chain is E, F, G, H, I, and J in any order, starting with E and ending in J)

I’ve written the following function to identify subchains of a specific length:

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)))
}

Which is used as follows:

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

And the following function can be used to find all chains the 2 vectors have in common:

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

Which is used as follows:

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

Of course, both functions are dreadfully slow. Have can I improve them, such that they’ll run in a reasonable time on much larger problems? e.g.

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

Answer 1

Would less than a second for your 100,000 case make you happy? Try this:

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))
}

---

Tested here:

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