Geek Answers Handbook

Counting the number of ordered pairs in a matrix in R

The matrix is ​​specified mas follows (string permutations 1-5):

    # [,1] [,2] [,3] [,4] [,5]
 # [1,]    1    5    2    4    3
 # [2,]    2    1    4    3    5
 # [3,]    3    4    1    2    5
 # [4,]    4    1    3    2    5
 # [5,]    4    3    1    2    5
 # [6,]    1    4    2    3    5
 # [7,]    4    3    2    5    1
 # [8,]    4    1    3    5    2
 # [9,]    1    2    3    4    5
# [10,]    4    3    2    1    5

I would like to know how many times each element 1-5 is preceded by another element in the line (i.e. considering all possible pairs)

For example, for a pair (1, 5) it is 1preceded 5, 9 times among all lines. Another example, for a pair (3, 1), is 3preceded 1by 4 times among all rows. I would like to have the same results for all possible pairs among all rows. I.e

# (1, 2), (1, 3), (1, 4), (1, 5)
# (2, 1), (2, 3), (2, 4), (2, 5)
# (3, 1), (3, 2), (3, 4), (3, 5)
# (4, 1), (4, 2), (4, 3), (4, 5)
# (5, 1), (5, 2), (5, 3), (5, 4)

m <- structure(c(1L, 2L, 3L, 4L, 4L, 1L, 4L, 4L, 1L, 4L, 5L, 1L, 4L, 
1L, 3L, 4L, 3L, 1L, 2L, 3L, 2L, 4L, 1L, 3L, 1L, 2L, 2L, 3L, 3L, 
2L, 4L, 3L, 2L, 2L, 2L, 3L, 5L, 5L, 4L, 1L, 3L, 5L, 5L, 5L, 5L, 
5L, 1L, 2L, 5L, 5L), .Dim = c(10L, 5L))

How to do this efficiently in R?

EDIT

How would you do the same for this matrix?

      # [,1] [,2] [,3] [,4] [,5]
 # [1,]    3    4    1    5    0
 # [2,]    1    2    5    3    0
 # [3,]    3    5    0    0    0
 # [4,]    4    5    0    0    0
 # [5,]    3    4    1    5    2
 # [6,]    3    1    2    0    0
 # [7,]    4    1    5    2    0
 # [8,]    4    3    5    2    0
 # [9,]    5    2    0    0    0
# [10,]    5    4    2    0    0

m <- structure(c(3, 1, 3, 4, 3, 3, 4, 4, 5, 5, 4, 2, 5, 5, 4, 1, 1, 
3, 2, 4, 1, 5, 0, 0, 1, 2, 5, 5, 0, 2, 5, 3, 0, 0, 5, 0, 2, 2, 
0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0), .Dim = c(10L, 5L))
+4
source share
4 answers

, (1) , (2) 0 (3) nrow(m) 2-3 , ncol(m), , , 0:

ff = function(x, a, b)
{
    ia = rep_len(NA_integer_, nrow(x)) # positions of 'a' in each row
    ib = rep_len(NA_integer_, nrow(x)) # -//- of 'b'
    notfound0 = seq_len(nrow(x))  # rows that have not, yet, a 0
    for(j in seq_len(ncol(x))) {
        xj = x[notfound0, j]
        if(!length(xj)) break

        ia[notfound0[xj == a]] = j
        ib[notfound0[xj == b]] = j

        notfound0 = notfound0[xj != 0L]  # check if any more rows have 0 now on
    }

    i = ia < ib ## is 'a' before 'b'?

    ## return both a - b and b - a; no need to repeat computations
    data.frame(a = c(a, b), 
               b = c(b, a), 
               n = c(sum(i, na.rm = TRUE), sum(!i, na.rm = TRUE)))
}

m:

ff(m, 3, 2)
# a b n
#1 3 2 3
#2 2 3 1
ff(m, 5, 1)
#  a b n
#1 5 1 0
#2 1 5 4

:

xtabs(n ~ a + b, 
      do.call(rbind, 
              combn(5, 2, function(x) ff(m, x[1], x[2]), 
                    simplify = FALSE)))
#   b
#a   1 2 3 4 5
#  1 0 4 1 0 4
#  2 0 0 1 0 1
#  3 3 3 0 2 4
#  4 3 4 1 0 5
#  5 0 5 1 1 0

, , :

set.seed(007)
MAT = do.call(rbind, combinat::permn(8))[sample(1e4), ]
MAT[sample(length(MAT), length(MAT)*0.4)] = 0L #40% 0s
MAT = t(apply(MAT, 1, function(x) c(x[x != 0L], rep_len(0L, sum(x == 0L)))))
dim(MAT)
#[1] 10000     8

## including colonel answer for a quick comparison
colonel = function(x, a, b)
{
    i = (which(!t(x - b)) - which(!t(x - a))) > 0L
    data.frame(a = c(a, b), b = c(b, a), n = c(sum(i), sum(!i)))
} 

microbenchmark::microbenchmark(ff(MAT, 7, 2), colonel(MAT, 7, 2))
#Unit: milliseconds
#               expr      min       lq     mean   median       uq       max neval cld
#      ff(MAT, 7, 2) 3.795003 3.908802 4.500453 3.972138 4.096377 45.926679   100   b
# colonel(MAT, 7, 2) 2.156941 2.231587 2.423053 2.295794 2.404894  3.775516   100  a 
#There were 50 or more warnings (use warnings() to see the first 50)

, . 0s .

+1

apply:

func <- function(a,b) sum((which(!t(m-b)) - which(!t(m-a)))>0)

#> func(1,5)
#[1] 9
#> func(5,1)
#[1] 1

:

N = combn(1:5, 2)
cbind(N, N[nrow(N):1,])

.

+6

-, :

apply(m, 1, function(r) { which(r == 1) < which(r == 5) })
#  [1]  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE FALSE  TRUE  TRUE  TRUE
sum(apply(m, 1, function(r) { which(r == 1) < which(r == 5) }))
# [1] 9

1:5 ( ), data.frame :

df <- expand.grid(a = 1:5, b = 1:5)
df <- df[ df$a != df$b, ]
head(df)
#   a b
# 2 2 1
# 3 3 1
# 4 4 1
# 5 5 1
# 6 1 2
# 8 3 2

(, apply):

df$seqs <- sapply(seq_len(nrow(df)), function(i) {
  sum(apply(m, 1, function(r) which(r == df$a[i]) < which(r == df$b[i])))
})
head(df)
#   a b seqs
# 2 2 1    3
# 3 3 1    4
# 4 4 1    6
# 5 5 1    1
# 6 1 2    7
# 8 3 2    6

, , mapply:

myfunc <- function(a, b, m) sum(apply(m, 1, function(r) which(r == a) < which(r == b)))
df$seqs <- mapply(myfunc, df$a, df$b, list(m))
head(df)
#   a b seqs
# 2 2 1    3
# 3 3 1    4
# 4 4 1    6
# 5 5 1    1
# 6 1 2    7
# 8 3 2    6

, , (, ), .

: , m . , which logical(0), , sapply . :

apply(m, 1, function(r) which(r == a) < which(r == b))
# [[1]]
# logical(0)
# [[2]]
# [1] FALSE
# ...

emptyF <- function(x) sapply(x, function(y) if (! length(y)) FALSE else y)
emptyF(apply(m, 1, function(r) which(r == a) < which(r == b)))
# [1] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE

myfunc :

myfunc <- function(a, b, m) sum(emptyF(apply(m, 1, function(r) which(r == a) < which(r == b))))

(Note: I prefer the answer “Colonel Bovel” in the sense that it is vectorized and therefore much faster. It will also benefit from this and similar tools for immediate matches.))

+3
source

try it

library(plyr)
combns <- expand.grid(unique(as.vector(m)),unique(as.vector(m)))
combns <- combns[combns$Var1!=combns$Var2,]
combns <- combns[with(combns,order(Var1)),]
combns$count <- sapply(1:nrow(combns),function(u) sum(unlist(apply(apply(m,1,function(t) match(t,combns[u,])),2,function(s) na.exclude(count(unlist(sapply(seq(length(s)),function(t) diff(s,lag=t))))$freq[count(unlist(sapply(seq(length(s)),function(t) diff(s,lag=t))))$x==1]))),na.rm = T))
+1
source

More articles:


All Articles