Question

我有一段工作代码需要太多时间（几天？）来计算。我有一个1s和0s的稀疏矩阵，我需要以任何可能的组合从任何其他行中减去每一行，将结果向量乘以另一个向量，最后求平均值，以便得到我需要的单个标量插入矩阵。我所拥有的是：

m <- matrix( 
c(0, 1, 1, 0, 1, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0), nrow=4,ncol=4,
byrow = TRUE)   

b <- c(1,2,3,4)

for (j in 1:dim(m)[1]){
 for (i in 1:dim(m)[1]){
    a <- m[j,] - m[i,]
    a[i] <- 0L
    a[a < 0] <- 0L
    c <- a*b
    d[i,j] <- mean(c[c > 0])
 }
}

所需的输出是尺寸为m的相同矩阵，其中每个条目都是这些运算的结果。此循环有效，但是否有任何想法可提高效率？谢谢

Answer 1

我愚蠢的解决方案是使用apply或sapply函数，而不是for循环来进行迭代：

sapply(1:dim(m)[1], function(k) {z <- t(apply(m, 1, function(x) m[k,]-x)); diag(z) <- 0; z[z<0] <- 0; apply(t(apply(z, 1, function(x) x*b)),1,function(x) mean(x[x>0]))})

我试图比较您的解决方案，并以此来比较计算机的运行时间，您的解决方案需要

t1 <- Sys.time()
d1 <- m
for (j in 1:dim(m)[1]){
  for (i in 1:dim(m)[1]){
    a <- m[j,] - m[i,]
    a[i] <- 0L
    a[a < 0] <- 0L
    c <- a*b
    d1[i,j] <- mean(c[c > 0])
  }
}
Sys.time()-t1

您需要Time difference of 0.02799988 secs。对于我的而言，运行时它会减少一点，但不会减少太多，即Time difference of 0.01899815 secs

t2 <- Sys.time()
d2 <- sapply(1:dim(m)[1], function(k) {z <- t(apply(m, 1, function(x) m[k,]-x)); diag(z) <- 0; z[z<0] <- 0; apply(t(apply(z, 1, function(x) x*b)),1,function(x) mean(x[x>0]))})
Sys.time()-t2

您可以在自己的计算机上尝试使用更大的矩阵，祝您好运！

Answer 2

1）创建测试稀疏矩阵：

nc <- nr <- 100
p <- 0.001
require(Matrix)
M <- Matrix(0L, nr, nc, sparse = T) # 0 matrix
n1 <- ceiling(p * (prod(dim(M)))) # 1 count
M[1:n1] <- 1L # fill only first column, to approximate max non 0 row count
# (each row has at maximum 1 positive element)
sum(M)/(prod(dim(M)))

b <- 1:ncol(M)

sum(rowSums(M))

因此，如果给定的比例正确，那么我们最多有10行包含非0元素

基于此事实和您提供的计算结果：

# a <- m[j, ] - m[i, ]
# a[i] <- 0L
# a[a < 0] <- 0L
# c <- a*b
# mean(c[c > 0])

我们可以看到，结果仅对具有至少1个非0元素的m[, j]行有意义

==>我们可以跳过仅包含0的所有m[, j]的计算，因此：

minem <- function() { # write as function
  t1 <- proc.time() # timing
  require(data.table)
  i <- CJ(1:nr, 1:nr) # generate all combinations
  k <- rowSums(M) > 0L # get index where at least 1 element is greater that 0
  i <- i[data.table(V1 = 1:nr, k), on = 'V1'] # merge
  cat('at moust', i[, sum(k)/.N*100], '% of rows needs to be calculated \n')
  i[k == T, rowN := 1:.N] # add row nr for 0 subset
  i2 <- i[k == T] # subset only those indexes who need calculation
  a <- M[i2[[1]],] - M[i2[[2]],] # operate on all combinations at once
  a <- drop0(a) # clean up 0

  ids <- as.matrix(i2[, .(rowN, V2)]) # ids for 0 subset
  a[ids] <- 0L # your line: a[i] <- 0L
  a <- drop0(a) # clean up 0

  a[a < 0] <- 0L # the same as your line
  a <- drop0(a) # clean up 0

  c <- t(t(a)*b) # multiply each row with vector
  c <- drop0(c) # clean up 0

  c[c < 0L] <- 0L # for mean calculation
  c <- drop0(c) # clean up 0

  r <- rowSums(c)/rowSums(c > 0L) # row means
  i[k == T, result := r] # assign results to data.table
  i[is.na(result), result := NaN] # set rest to NaN
  d2 <- matrix(i$result, nr, nr, byrow = F) # create resulting matrix
  t2 <- proc.time() # timing
  cat(t2[3] - t1[3], 'sec \n')
  d2
}
d2 <- minem()
# at most 10 % of rows needs to be calculated 
# 0.05 sec

在较小的示例中测试结果是否匹配

d <- matrix(NA, nrow(M), ncol(M))
for (j in 1:dim(M)[1]) {
  for (i in 1:dim(M)[1]) {
    a <- M[j, ] - M[i, ]
    a[i] <- 0L
    a[a < 0] <- 0L
    c <- a*b
    d[i, j] <- mean(c[c > 0])
  }
}
all.equal(d, d2)

我们可以得到您的真实数据大小的结果吗？：

# generate data:
nc <- nr <- 6663L
b <- 1:nr
p <- 0.0001074096 # proportion of 1s
M <- Matrix(0L, nr, nc, sparse = T) # 0 matrix
n1 <- ceiling(p * (prod(dim(M)))) # 1 count
M[1:n1] <- 1L

object.size(as.matrix(M))/object.size(M)
# storing this data in usual matrix uses 4000+ times more memory

# calculation:
d2 <- minem()
# at most 71.57437 % of rows needs to be calculated 
# 28.33 sec

所以您需要将矩阵转换为稀疏矩阵

M <- Matrix(m, sparse = T)

double for循环的更快计算？

2 个答案: