Question

我有一个看似简单的问题，与之相比，我需要更快的R实现方式

在此示例中，我初始化了随机种子和尺寸：

set.seed(1)
d1<-400
d2<-20000
d3<-50

我有一个矩阵X，尺寸为 d1 x d2 ：

X<-as.data.frame(matrix(rnorm(d1*d2),nrow=d1,ncol=d2))
rownames(X)<-paste0("row",1:nrow(X))
colnames(X)<-paste0("col",1:ncol(X))

还有一个带有 d1 行索引的向量u：

u<-sample(rownames(X),nrow(X),replace=TRUE)

我也有一个矩阵C，矩阵C的行和维度为 d3 x d2 ：

C<-matrix(rnorm(d3*d2),nrow=d3,ncol=d2)
rownames(C)<-sample(rownames(X),nrow(C),replace=FALSE)

现在，通过以下非常慢循环，我用匹配的X行之和填充矩阵C：

system.time(
    for(i in 1:nrow(C)){
        indexes<-which(u==rownames(C)[i])
        C[i,] <- colSums(X[indexes,])
    }
)

此操作在我的PC上大约需要11.5秒，但是我确信可以通过避免for循环来加快操作速度。有任何想法吗？非常感谢！

Answer 1

您可以尝试使用sapply进行循环。

system.time(
  C2 <- `dimnames<-`(t(sapply(match(rownames(C), u), function(x) 
    colSums(X[x, ]))), list(rownames(C), NULL))
)
#  user  system elapsed 
# 20.06    0.03   20.14 

stopifnot(all.equal(C, C2))

与

相比

system.time(
  for(i in 1:nrow(C)){
    indexes <- which(u == rownames(C)[i])
    C[i, ] <- colSums(X[indexes, ])
  }
)
#  user  system elapsed 
# 20.76    0.69   28.30

但是，目前仅是一次测量。

更新

似乎运行稍快 ......

Unit: seconds
    expr      min       lq     mean   median       uq      max neval cld
 forloop 20.44852 20.57730 21.67771 20.74106 21.01723 29.63220    10   a
  sapply 19.86707 20.17126 21.34529 20.50283 20.81254 29.73764    10   a

更新2

但是您可以使用parallel::parSapply来做到这一点。

system.time({
  library(parallel)
  cl <- makeCluster(detectCores() - 1)
  clusterExport(cl, c("C", "u", "X"))
  C3 <- parSapply(cl, match(rownames(C), u), function(x) colSums(X[x, ]))
  stopCluster(cl)
  C3 <- `dimnames<-`(t(C3), list(rownames(C), NULL))
})
# user  system elapsed 
# 0.81    3.16    9.82

stopifnot(all.equal(C, C3))

现在，通过for循环，我的机器和您的机器一样快：）

Answer 2

只需将matrixStats::colSums2与传递行索引并将rownames()移到循环外的选项一起使用（X需要转换为矩阵）：

Xm <- as.matrix(X)
names_of_rows <- rownames(C)
system.time(for (i in 1:nrow(C)) {
  indexes <- which(u == names_of_rows[i])
  C[i, ] <-  matrixStats::colSums2(Xm, rows = indexes)
})
# 0.03 sek

Answer 3

在这里使用data.table解决方案。如果OP只需要基本的R解决方案，我将删除此帖子：

library(data.table)
mtd_dt <- function() {
    setDT(dtX)[, u := as.integer(gsub("row","",u))]
    mX <- melt(dtX, id.var="u", variable.name="col")
    C2 <- data.table(rn=seq_len(nrow(C)), u=as.integer(gsub("row","",rownames(C))))
    dcast(mX[C2, on=.(u)][, sum(value), by=.(rn, col)], rn ~ col, value.var="V1")[,
        "NA" := NULL][,
            lapply(.SD, function(x) replace(x, is.na(x), 0))]
}

时间：

# A tibble: 2 x 14
  expression      min     mean   median      max `itr/sec` mem_alloc  n_gc n_itr total_time result                    memory                time    gc             
  <chr>      <bch:tm> <bch:tm> <bch:tm> <bch:tm>     <dbl> <bch:byt> <dbl> <int>   <bch:tm> <list>                    <list>                <list>  <list>         
1 mtd0()        59.1s    59.1s    59.1s    59.1s    0.0169     447MB    24     1      59.1s <dbl [50 x 20,000]>       <Rprofmem [44,515 x ~ <bch:t~ <tibble [1 x 3~
2 mtd_dt()       2.7s     2.7s     2.7s     2.7s    0.370      309MB     4     1       2.7s <data.table [50 x 20,001~ <Rprofmem [88,029 x ~ <bch:t~ <tibble [1 x 3~

计时代码：

mtd0 <- function() {
    for (i in 1:nrow(C)) {
        indexes <- which(u==rownames(C)[i])
        C[i, ] <- colSums(X[indexes, ])
    }
    C
}

bench::mark(mtd0(), mtd_dt(), check=FALSE)

数据：

library(data.table)
set.seed(0)
#d1 <- 10
#d2 <- 10
#d3 <- 5
d1<-400
d2<-20000
d3<-50

X <- as.data.frame(matrix(rnorm(d1*d2),nrow=d1,ncol=d2))
rownames(X) <- paste0("row",1:nrow(X))
colnames(X) <- paste0("col",1:ncol(X))
dtX <- X

u <- sample(rownames(X),nrow(X),replace=TRUE)

C <- matrix(0,nrow=d3,ncol=d2)
rownames(C) <- sample(rownames(X),nrow(C),replace=FALSE)

如何为嵌套矩阵匹配和colSums加快R中的for循环

3 个答案:

更新

更新2