提取并计算行内的相邻数字对

Question

我希望提取“一对数字”，即同一行内相邻列中的数字。然后我想计算这些对以确定哪些是最频繁的。

例如，我创建了一个包含 5 列和 4 行的数据集：

var1 var2 var3 var4 var5
   1    2    3    0   11
   2    0    3    0    1
   3    0    3    1    2
   4    1    2    2   11

最频繁的连续数字对是：

1 -> 2：3 次（第 1 行，var1 -> var2；第 3 行，var4 -> var5；第 4 行，var2 -> var3）

3 -> 0：3 次（第 1 行，var3 -> var4；第 2 行，var3 -> var4；第 3 行，var1 -> var2）

0 -> 3：2次

我正在为识别最常见的“连续数字对”的代码而苦苦挣扎？

如何将已识别的连续数字对替换为 2 并将其他数字替换为 0？

Answer 1

library(zoo)
pairs <- sort(table(c(rollapply(t(DF), 2, toString))))

# all pairs with their frequency
pairs
##  0, 1 0, 11  2, 0 2, 11  2, 2  2, 3  3, 1  4, 1  0, 3  1, 2  3, 0 
##     1     1     1     1     1     1     1     1     2     3     3 

# same but as data.frame
data.frame(read.table(text = names(pairs), sep = ","), freq = c(pairs))
##       V1 V2 freq
## 0, 1   0  1    1
## 0, 11  0 11    1
## ...
## 0, 3   0  3    2
## 1, 2   1  2    3
## 3, 0   3  0    3

# pair with highest frequency - picks one if there are several
tail(pairs, 1)
## 3, 0 
##    3 

# all pairs with highest frequency
pairs[pairs == max(pairs)]
## 1, 2 3, 0 
##    3    3 

用 2 替换所有 3,0 对，用 0 替换所有其他：

top <- scan(text = names(tail(pairs, 1)), sep = ",", what = 0L, quiet = TRUE)
right <- rollapplyr(unname(t(DF)), 2, identical, top, fill = FALSE)
left <- rbind(right[-1, ], FALSE)
t(2 * (left | right))
##      [,1] [,2] [,3] [,4] [,5]
## [1,]    0    0    2    2    0
## [2,]    0    0    2    2    0
## [3,]    2    2    0    0    0
## [4,]    0    0    0    0    0

注意

可重现形式的输入DF 是：

Lines <- "1     2     3   0    11
2     0     3   0     1
3     0     3   1     2
4     1     2   2     11"
DF <- read.table(text = Lines)

Answer 2

base 替代方案。

1.查找和计数对

因为您只有数值，所以我们将数据强制转换为矩阵。这将使随后的计算大大加快。创建数据的滞后和领先版本（按列），即分别删除最后一列 (m[ , -ncol(m)]) 和第一列 (m[ , -ncol(m)])。

将滞后和超前数据强制转换为“从”和“到”向量，并对对进行计数 (table)。将表格转换为矩阵。选择具有最大频率的第一对。

m <- as.matrix(d)
tt <- table(from = as.vector(m[ , -ncol(m)]), to = as.vector(m[ , -1]))
m2 <- cbind(from = as.integer(dimnames(tt)[[1]]),
            to = rep(as.integer(dimnames(tt)[[2]]), each = dim(tt)[1]),
            freq = as.vector(tt))      
m3 <- m2[which.max(m2[ , "freq"]), ]
# from   to freq 
#    3    0    3

如果您希望 所有 对具有最大频率，请改用 m2[m2[ , "freq"] == max(m2[ , "freq"]), ]。

---

2。替换最频繁对的值并将剩余设置为零

制作原始数据的副本。用零填充它。获取“最大对”的“从”和“到”值。获取滞后和领先数据中匹配的索引，这些索引对应于“来自”列。 rbind 带有“到”列的索引。在索引处，将零替换为 2。

m_bin <- m
m_bin[] <- 0
ix <- which(m[ , -ncol(m)] == m3["from"] &
              m[ , -1] == m3["to"],
            arr.ind = TRUE)
m_bin[rbind(ix, cbind(ix[ , "row"], ix[ , "col"] + 1))] <- 2
m_bin
#      var1 var2 var3 var4 var5
# [1,]    0    0    2    2    0
# [2,]    0    0    2    2    0
# [3,]    2    2    0    0    0
# [4,]    0    0    0    0    0

---

3.基准测试

我使用的数据大小与 OP 在评论中提到的有些相似：一个具有 10000 行、100 列并从 100 个不同值中采样的数据框。

我将上面的代码 (f_m()) 与 zoo 的答案 (f_zoo(); 下面的函数) 进行比较。为了比较输出，我将dimnames 添加到zoo 结果中。

结果显示f_m 的速度要快得多。

set.seed(1)
nr <- 10000
nc <- 100
d <- as.data.frame(matrix(sample(1:100, nr * nc, replace = TRUE),
                          nrow = nr, ncol = nc))

res_f_m <- f_m(d)
res_f_zoo <- f_zoo(d)
dimnames(res_f_zoo) <- dimnames(res_f_m)

all.equal(res_f_m, res_f_zoo)
# [1] TRUE

system.time(f_m(d))
# user  system elapsed 
# 0.12    0.01    0.14 

system.time(f_zoo(d))
# user  system elapsed 
# 61.58   26.72   88.45

f_m <- function(d){
  m <- as.matrix(d)
  tt <- table(from = as.vector(m[ , -ncol(m)]),
              to = as.vector(m[ , -1]))
  m2 <- cbind(from = as.integer(dimnames(tt)[[1]]),
              to = rep(as.integer(dimnames(tt)[[2]]),
                       each = dim(tt)[1]),
              freq = as.vector(tt))

  m3 <- m2[which.max(m2[ , "freq"]), ]
  m_bin <- m
  m_bin[] <- 0
  ix <- which(m[ , -ncol(m)] == m3["from"] &
                m[ , -1] == m3["to"],
              arr.ind = TRUE)
  m_bin[rbind(ix, cbind(ix[ , "row"], ix[ , "col"] + 1))] <- 2
  return(m_bin)
}


f_zoo <- function(d){
  pairs <- sort(table(c(rollapply(t(d), 2, toString))))
  top <- scan(text = names(tail(pairs, 1)), sep = ",", what = 0L, quiet = TRUE)
  right <- rollapplyr(unname(t(d)), 2, identical, top, fill = FALSE)
  left <- rbind(right[-1, ], FALSE)
  t(2 * (left | right))
  }