Question

我有一个我希望适合数据的公式列表，而不是为了性能而运行一个我想立即执行此操作的循环。估计应该是分开的，我不是要估计SUR或任何东西。以下代码执行我想要的操作

x <- matrix(rnorm(300),ncol=3)
y <- x %*% c(1,2,3)+rnorm(100)
formulae <-list(y~x[,1],
                y~x[,2],
                y~x[,1] + x[,2])
lapply(formulae,lm)

不幸的是，随着formulae长度的增加，这有点慢，有没有办法真正地对其进行矢量化？

如果有任何帮助，我关心的lm的唯一结果是系数和一些标准错误。

Answer 1

这并不是一种简单的矢量化方法，但pdredge包中的MuMIn函数为您提供了一种非常简单的并行化方法（假设您有多个核心）您的计算机或您可以使用parallel包支持的方式之一设置本地群集...

library(parallel)
clust <- makeCluster(2,"PSOCK")
library(MuMIn)

构建数据：

set.seed(101)
x <- matrix(rnorm(300),ncol=3)
y <- x %*% c(1,2,3)+rnorm(100)

使用命名数据框而不是匿名矩阵来执行此操作会更容易：

df <- setNames(data.frame(y,x),c("y",paste0("x",1:3)))

群集节点都需要访问数据集：

clusterExport(clust,"df")

适合完整模型（您可以使用y~.来适应所有变量）

full <- lm(y~x1+x2,data=df,na.action=na.fail)

现在适合所有子模型（请参阅?MuMIn::dredge以获取更多选项以控制哪些子模型适合）

p <- pdredge(full,cluster=clust)
coef(p)
##    (Intercept)        x1       x2
## 3 -0.003805107 0.7488708 2.590204
## 2 -0.028502039        NA 2.665305
## 1 -0.101434662 1.0490816       NA
## 0 -0.140451160        NA       NA

Answer 2

正如我在评论中所说，除了lm()之外，你真正需要的是一种更有效但更稳定的拟合程序。在这里，我将为您提供一个经过良好测试的自己，名为lm.chol()。它需要formula和data，并返回：

系数汇总表，正如您在summary(lm(...))$coef;
Pearson对残差标准误差的估计，来自summary(lm(...))$sigma;
adjust-R.squared，来自summary(lm(...))$adj.r.squared。

## linear model estimation based on pivoted Cholesky factorization with Jacobi preconditioner
lm.chol <- function(formula, data) {
  ## stage0: get response vector and model matrix
  ## we did not follow the normal route: match.call, model.frame, model.response, model matrix, etc
  y <- data[[as.character(formula[[2]])]]
  X <- model.matrix(formula, data)
  n <- nrow(X); p <- ncol(X)
  ## stage 1: XtX and Jacobi diagonal preconditioner
  XtX <- crossprod(X)
  D <- 1 / sqrt(diag(XtX))
  ## stage 2: pivoted Cholesky factorization
  R <- suppressWarnings(chol(t(D * t(D * XtX)), pivot = TRUE))
  piv <- attr(R, "pivot")
  r <- attr(R, "rank")
  if (r < p) {
    warning("Model is rank-deficient!")
    piv <- piv[1:r]
    R <- R[1:r, 1:r]
    }
  ## stage 3: solve linear system for coefficients
  D <- D[piv]
  b <- D * crossprod(X, y)[piv]
  z <- forwardsolve(t(R), b)
  RSS <- sum(y * y) - sum(z * z)
  sigma <- sqrt(RSS / (n - r))
  para <- D * backsolve(R, z)
  beta.hat <- rep(NA, p)
  beta.hat[piv] <- para
  ## stage 4: get standard error
  Rinv <- backsolve(R, diag(r))
  se <- rep(NA, p)
  se[piv] <- D * sqrt(rowSums(Rinv * Rinv)) * sigma
  ## stage 5: t-statistic and p-value
  t.statistic <- beta.hat / se
  p.value <- 2 * pt(-abs(t.statistic), df = n - r)
  ## stage 6: construct coefficient summary matrix
  coefficients <- matrix(c(beta.hat, se, t.statistic, p.value), ncol = 4L)
  colnames(coefficients) <- c("Estimate", "Std. Error", "t value", "Pr(>|t|)")
  rownames(coefficients) <- colnames(X)
  ## stage 7: compute adjusted R.squared
  adj.R2 <- 1 - sigma * sigma / var(y)
  ## return model fitting results
  attr(coefficients, "sigma") <- sigma
  attr(coefficients, "adj.R2") <- adj.R2
  coefficients
  }

这里我将提供三个例子。

示例1：满秩线性模型

我们以R的内置数据集trees为例。

# using `lm()`
summary(lm(Height ~ Girth + Volume, trees))
#Coefficients:
#            Estimate Std. Error t value Pr(>|t|)    
#(Intercept)  83.2958     9.0866   9.167 6.33e-10 ***
#Girth        -1.8615     1.1567  -1.609   0.1188    
#Volume        0.5756     0.2208   2.607   0.0145 *  
#---
#Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

#Residual standard error: 5.056 on 28 degrees of freedom
#Multiple R-squared:  0.4123,   Adjusted R-squared:  0.3703 
#F-statistic:  9.82 on 2 and 28 DF,  p-value: 0.0005868

## using `lm.chol()`
lm.chol(Height ~ Girth + Volume, trees)
#              Estimate Std. Error   t value     Pr(>|t|)
#(Intercept) 83.2957705  9.0865753  9.166905 6.333488e-10
#Girth       -1.8615109  1.1566879 -1.609346 1.187591e-01
#Volume       0.5755946  0.2208225  2.606594 1.449097e-02
#attr(,"sigma")
#[1] 5.056318
#attr(,"adj.R2")
#[1] 0.3702869

结果完全一样！

示例2：排名不足的线性模型

## toy data
set.seed(0)
dat <- data.frame(y = rnorm(100), x1 = runif(100), x2 = rbeta(100,3,5))
dat$x3 <- with(dat, (x1 + x2) / 2)

## using `lm()`
summary(lm(y ~ x1 + x2 + x3, dat))
#Coefficients: (1 not defined because of singularities)
#            Estimate Std. Error t value Pr(>|t|)
#(Intercept)   0.2164     0.2530   0.856    0.394
#x1           -0.1526     0.3252  -0.469    0.640
#x2           -0.3534     0.5707  -0.619    0.537
#x3                NA         NA      NA       NA

#Residual standard error: 0.8886 on 97 degrees of freedom
#Multiple R-squared:  0.0069,   Adjusted R-squared:  -0.01358 
#F-statistic: 0.337 on 2 and 97 DF,  p-value: 0.7147

## using `lm.chol()`
lm.chol(y ~ x1 + x2 + x3, dat)
#              Estimate Std. Error    t value  Pr(>|t|)
#(Intercept)  0.2164455  0.2529576  0.8556595 0.3942949
#x1                  NA         NA         NA        NA
#x2          -0.2007894  0.6866871 -0.2924030 0.7706030
#x3          -0.3051760  0.6504256 -0.4691944 0.6399836
#attr(,"sigma")
#[1] 0.8886214
#attr(,"adj.R2")
#[1] -0.01357594
#Warning message:
#In lm.chol(y ~ x1 + x2 + x3, dat) : Model is rank-deficient!

此处，基于具有完全旋转的Cholesky分解的lm.chol()和基于具有部分旋转的QR分解的lm()已将不同的系数缩小到NA。但是两个估计是等价的，具有相同的拟合值和残差。

示例3：大型线性模型的性能

n <- 10000; p <- 300
set.seed(0)
dat <- as.data.frame(setNames(replicate(p, rnorm(n), simplify = FALSE), paste0("x",1:p)))
dat$y <- rnorm(n)

## using `lm()`
system.time(lm(y ~ ., dat))
#   user  system elapsed 
#  3.212   0.096   3.315

## using `lm.chol()`
system.time(lm.chol(y ~ ., dat))
#   user  system elapsed 
#  1.024   0.028   1.056

lm.chol()比lm()快3~4倍。如果您想知道原因，请阅读my this answer。

<强>备注

我专注于提高计算内核的性能。通过使用Ben Bolker的并行性建议，您可以更进一步。如果我的方法提高了3倍，并行计算在4个内核上提供了3倍的提升，那么最终会提升9倍！

一次适应多个公式，比lapply更快的选择？

2 个答案: