R中大型稀疏矩阵完全两两观测值线性模型拟合的加速

我有一个数字data.frame df，有134946行x 1938列。 99.82%的数据为NA。 对于每一对不同的列P1和P2，我需要找到哪些行都具有非NA值，然后对这些行执行一些线性模型操作

我写了一个脚本来实现这一点，但它似乎相当缓慢

似乎讨论了一个相关的任务，但我不能立即看到它是否或如何适应我的情况

借用那篇文章的例子：

set.seed(54321)
nr = 1000;
nc = 900;
dat = matrix(runif(nr*nc), nrow=nr)
rownames(dat) = paste(1:nr)
colnames(dat) = paste("time", 1:nc)
dat[sample(nr*nc, nr*nc*0.9)] = NA

df <- as.data.frame(dat)
df_ps <- names(df)
N_ps <- length(df_ps)

例如，尝试使用nr=100000；nc=100

我可能应该提到，我曾尝试使用索引，即：

naIds <- lapply(df, function(x) which(!is.na(x)))

然而，这比上面的要慢。

最大的瓶颈是lm函数，因为有许多检查和附加计算，您不一定需要。所以我只提取了需要的部分。 我让它在+/-18秒内运行

set.seed(54321)
nr = 1000;
nc = 900;
dat = matrix(runif(nr*nc), nrow = nr)
rownames(dat) = paste(1:nr)
colnames(dat) = paste("time", 1:nc)
dat[sample(nr*nc, nr*nc*0.9)] = NA

df <- as.data.frame(dat)
df_ps <- names(df)
N_ps <- length(df_ps)


tic = proc.time()

naIds <- lapply(df, function(x) !is.na(x)) # outside loop
dl <- as.list(df) # sub-setting list elements is faster that columns

rl <- sapply(1:(N_ps - 1), function(i) {
  x <- dl[[i]]
  xna <- naIds[[i]] # relevant logical vector if not empty elements
  rl2 <- sapply((i + 1):N_ps, function(j) {
    y <- dl[[j]]
    yna <- naIds[[j]]
    w <- xna & yna
    N <- sum(w)
    if (N >= 5) {
      xw <- x[w]
      yw <- y[w]

      if ((min(xw) != max(xw)) && (min(xw) != max(xw))) { # faster

        # extracts from lm/lm.fit/summary.lm  functions
        X <- cbind(1L, xw)
        m <- .lm.fit(X, yw)

        # calculate adj.r.squared
        fitted <- yw - m$residuals
        rss <- sum(m$residuals^2)
        mss <- sum((fitted - mean(fitted))^2)
        n <- length(m$residuals)
        rdf <- n - m$rank
        # rdf <- df.residual
        r.squared <- mss/(mss + rss)
        adj.r.squared <- 1 - (1 - r.squared) * ((n - 1L)/rdf)

        # calculate se & pvals
        p1 <- 1L:m$rank
        Qr <- m$qr
        R <- chol2inv(Qr[p1, p1, drop = FALSE])
        resvar <- rss/rdf
        se <- sqrt(diag(R) * resvar)
        est <- m$coefficients[m$pivot[p1]]
        tval <- est/se
        pvals <- 2 * pt(abs(tval), rdf, lower.tail = FALSE)
        res <- c(m$coefficients[2], se[2], pvals[2],
                 m$coefficients[1], se[1], pvals[1])
        o <- c(i, j, N, adj.r.squared, res)
        } else {
          o <- c(i,j,N,rep(NA,6))
          }
    } else {o <- NULL}
    return(o)
  }, simplify = F)
  do.call(rbind, rl2)
}, simplify = F)
out2 <- do.call(rbind, rl)

toc = proc.time();
show(toc - tic);
#  user  system elapsed 
# 17.94    0.11   18.44

---

首先，如果您只有数字数据，我建议您将其存储为矩阵，而不是数据帧。第二，如果数据非常稀疏，为什么不将其存储为稀疏矩阵？好的，这两种更改都是可能的。你认为这有助于加快进程吗？太好了，谢谢@minem！事实上，我后来意识到我的代码repNA中有一个错误，6应该是repNA，7。通过其他试验，我发现通过收集x数据的非NA记录的索引，并使用这些索引仅查看y数据的相关记录，可以获得另一个很大的性能改进。我稍后会发布一篇编辑文章。事实上，更正：按照我说的做只会改进我的大集合的计算，而不是这个例子。我想这是因为我的矩阵要稀疏得多。另一方面，你是绝对正确的，lm部分正是扼杀这一切的原因。作为一个测试，我试图在你的脚本中改变一些东西，我可以报告以下内容。原始=22秒。递归子集设置=22秒。两个嵌套的for循环，而不是sapply=20 s单独用于计算，但存储数据的速度要慢得多？？？=~10分钟。与最初一样长，但sapply=~10分钟。再次感谢您，这看起来很有用！我知道一个事实，如果我把每次迭代时生成的o值附加到一个外部的可值结果中，这会大大降低过程的速度。以这种方式收集数据而不是任由他人去做，这两者之间肯定有着本质的区别。callrbind，利用sapply的输出完成这项工作。我认为这可能值得单独发表一篇文章。

naIds <- lapply(df, function(x) which(!is.na(x)))

w <- intersect(xna,yna)
N <- length(w)

set.seed(54321)
nr = 1000;
nc = 900;
dat = matrix(runif(nr*nc), nrow = nr)
rownames(dat) = paste(1:nr)
colnames(dat) = paste("time", 1:nc)
dat[sample(nr*nc, nr*nc*0.9)] = NA

df <- as.data.frame(dat)
df_ps <- names(df)
N_ps <- length(df_ps)


tic = proc.time()

naIds <- lapply(df, function(x) !is.na(x)) # outside loop
dl <- as.list(df) # sub-setting list elements is faster that columns

rl <- sapply(1:(N_ps - 1), function(i) {
  x <- dl[[i]]
  xna <- naIds[[i]] # relevant logical vector if not empty elements
  rl2 <- sapply((i + 1):N_ps, function(j) {
    y <- dl[[j]]
    yna <- naIds[[j]]
    w <- xna & yna
    N <- sum(w)
    if (N >= 5) {
      xw <- x[w]
      yw <- y[w]

      if ((min(xw) != max(xw)) && (min(xw) != max(xw))) { # faster

        # extracts from lm/lm.fit/summary.lm  functions
        X <- cbind(1L, xw)
        m <- .lm.fit(X, yw)

        # calculate adj.r.squared
        fitted <- yw - m$residuals
        rss <- sum(m$residuals^2)
        mss <- sum((fitted - mean(fitted))^2)
        n <- length(m$residuals)
        rdf <- n - m$rank
        # rdf <- df.residual
        r.squared <- mss/(mss + rss)
        adj.r.squared <- 1 - (1 - r.squared) * ((n - 1L)/rdf)

        # calculate se & pvals
        p1 <- 1L:m$rank
        Qr <- m$qr
        R <- chol2inv(Qr[p1, p1, drop = FALSE])
        resvar <- rss/rdf
        se <- sqrt(diag(R) * resvar)
        est <- m$coefficients[m$pivot[p1]]
        tval <- est/se
        pvals <- 2 * pt(abs(tval), rdf, lower.tail = FALSE)
        res <- c(m$coefficients[2], se[2], pvals[2],
                 m$coefficients[1], se[1], pvals[1])
        o <- c(i, j, N, adj.r.squared, res)
        } else {
          o <- c(i,j,N,rep(NA,6))
          }
    } else {o <- NULL}
    return(o)
  }, simplify = F)
  do.call(rbind, rl2)
}, simplify = F)
out2 <- do.call(rbind, rl)

toc = proc.time();
show(toc - tic);
#  user  system elapsed 
# 17.94    0.11   18.44