ジェネリックオプティマイザーを使用したglmnet線形回帰の結果の複製

タイトルが示すように、ライブラリのLBFGSオプティマイザーを使用して、glmnet linearの結果を複製しようとしていますlbfgs。このオプティマイザーを使用すると、目的関数（L1レギュラライザー項なし）が凸型である限り、微分可能性について心配する必要なくL1レギュラライザー項を追加できます。

弾性正味線形回帰問題glmnet紙はによって与えられる ここで、X∈RN×pは計画行列であり、Y∈RのPは、観測値のベクトルであり、αは∈[0、1]弾性ネットパラメータであり、λ>0は正則化パラメーターです。オペレータ‖X‖pは、通常のLPノルムを表します。

$$\min_{\beta \in \mathbb{R}^p} \frac{1}{2n}\Vert \beta_0 + X\beta - y \Vert_2^2 + \alpha \lambda \Vert \beta\Vert_1 + \frac{1}{2}(1-\alpha)\lambda\Vert\beta\Vert^2_2$$ $X \in \mathbb{R}^{n \times p}$$y \in \mathbb{R}^p$$\alpha \in [0,1]$$\lambda > 0$$\Vert x \Vert_p$

以下のコードは関数を定義し、結果を比較するためのテストを含みます。ご覧のとおり、結果はで許容可能alpha = 1ですが、次のプロットが示すように、alpha < 1.からalpha = 1に行くにつれてエラーが悪化しalpha = 0ます（「比較メトリック」はglmnetのパラメーター推定値間の平均ユークリッド距離です）および特定の正則化パスのlbfgs）。

さて、これがコードです。可能な限りコメントを追加しました。私の質問は：なぜ私の結果はglmnetの値の結果と異なるのalpha < 1ですか？それは明らかにL2正則化用語と関係がありますが、私が知る限り、この用語を論文のとおり正確に実装しました。どんな助けでも大歓迎です！

library(lbfgs)
linreg_lbfgs <- function(X, y, alpha = 1, scale = TRUE, lambda) {
  p <- ncol(X) + 1; n <- nrow(X); nlambda <- length(lambda)

  # Scale design matrix
  if (scale) {
    means <- colMeans(X)
    sds <- apply(X, 2, sd)
    sX <- (X - tcrossprod(rep(1,n), means) ) / tcrossprod(rep(1,n), sds)
  } else {
    means <- rep(0,p-1)
    sds <- rep(1,p-1)
    sX <- X
  }
  X_ <- cbind(1, sX)

  # loss function for ridge regression (Sum of squared errors plus l2 penalty)
  SSE <- function(Beta, X, y, lambda0, alpha) {
    1/2 * (sum((X%*%Beta - y)^2) / length(y)) +
      1/2 * (1 - alpha) * lambda0 * sum(Beta[2:length(Beta)]^2) 
                    # l2 regularization (note intercept is excluded)
  }

  # loss function gradient
  SSE_gr <- function(Beta, X, y, lambda0, alpha) {
    colSums(tcrossprod(X%*%Beta - y, rep(1,ncol(X))) *X) / length(y) + # SSE grad
  (1-alpha) * lambda0 * c(0, Beta[2:length(Beta)]) # l2 reg grad
  }

  # matrix of parameters
  Betamat_scaled <- matrix(nrow=p, ncol = nlambda)

  # initial value for Beta
  Beta_init <- c(mean(y), rep(0,p-1)) 

  # parameter estimate for max lambda
  Betamat_scaled[,1] <- lbfgs(call_eval = SSE, call_grad = SSE_gr, vars = Beta_init, 
                              X = X_, y = y, lambda0 = lambda[2], alpha = alpha,
                              orthantwise_c = alpha*lambda[2], orthantwise_start = 1, 
                              invisible = TRUE)$par

  # parameter estimates for rest of lambdas (using warm starts)
  if (nlambda > 1) {
    for (j in 2:nlambda) {
      Betamat_scaled[,j] <- lbfgs(call_eval = SSE, call_grad = SSE_gr, vars = Betamat_scaled[,j-1], 
                                  X = X_, y = y, lambda0 = lambda[j], alpha = alpha,
                                  orthantwise_c = alpha*lambda[j], orthantwise_start = 1, 
                                  invisible = TRUE)$par
    }
  }

  # rescale Betas if required
  if (scale) {
    Betamat <- rbind(Betamat_scaled[1,] -
colSums(Betamat_scaled[-1,]*tcrossprod(means, rep(1,nlambda)) / tcrossprod(sds, rep(1,nlambda)) ), Betamat_scaled[-1,] / tcrossprod(sds, rep(1,nlambda)) )
  } else {
    Betamat <- Betamat_scaled
  }
  colnames(Betamat) <- lambda
  return (Betamat)
}

# CODE FOR TESTING
# simulate some linear regression data
n <- 100
p <- 5
X <- matrix(rnorm(n*p),n,p)
true_Beta <- sample(seq(0,9),p+1,replace = TRUE)
y <- drop(cbind(1,X) %*% true_Beta)

library(glmnet)

# function to compare glmnet vs lbfgs for a given alpha
glmnet_compare <- function(X, y, alpha) {
  m_glmnet <- glmnet(X, y, nlambda = 5, lambda.min.ratio = 1e-4, alpha = alpha)
  Beta1 <- coef(m_glmnet)
  Beta2 <- linreg_lbfgs(X, y, alpha = alpha, scale = TRUE, lambda = m_glmnet$lambda)
  # mean Euclidean distance between glmnet and lbfgs results
  mean(apply (Beta1 - Beta2, 2, function(x) sqrt(sum(x^2))) ) 
}

# compare results
alpha_seq <- seq(0,1,0.2)
plot(alpha_seq, sapply(alpha_seq, function(alpha) glmnet_compare(X,y,alpha)), type = "l", ylab = "Comparison metric")

---

@ hxd1011私はあなたのコードを試しました、ここにいくつかのテストがあります（glmnetの構造と一致するようにいくつかの微調整を行いました-インターセプト項を正則化していないため、損失関数をスケーリングする必要があります）。これはのためのalpha = 0ものですが、何でも試すことができますalpha-結果が一致しません。

rm(list=ls())
set.seed(0)
# simulate some linear regression data
n <- 1e3
p <- 20
x <- matrix(rnorm(n*p),n,p)
true_Beta <- sample(seq(0,9),p+1,replace = TRUE)
y <- drop(cbind(1,x) %*% true_Beta)

library(glmnet)
alpha = 0

m_glmnet = glmnet(x, y, alpha = alpha, nlambda = 5)

# linear regression loss and gradient
lr_loss<-function(w,lambda1,lambda2){
  e=cbind(1,x) %*% w -y
  v= 1/(2*n) * (t(e) %*% e) + lambda1 * sum(abs(w[2:(p+1)])) + lambda2/2 * crossprod(w[2:(p+1)])
  return(as.numeric(v))
}

lr_loss_gr<-function(w,lambda1,lambda2){
  e=cbind(1,x) %*% w -y
  v= 1/n * (t(cbind(1,x)) %*% e) + c(0, lambda1*sign(w[2:(p+1)]) + lambda2*w[2:(p+1)])
  return(as.numeric(v))
}

outmat <- do.call(cbind, lapply(m_glmnet$lambda, function(lambda) 
  optim(rnorm(p+1),lr_loss,lr_loss_gr,lambda1=alpha*lambda,lambda2=(1-alpha)*lambda,method="L-BFGS")$par
))

glmnet_coef <- coef(m_glmnet)
apply(outmat - glmnet_coef, 2, function(x) sqrt(sum(x^2)))

tl; drバージョン：

$\hat{s} = sd(y)$$sd(y)$

長いバージョン

glmnetのドキュメントの細かい部分を読むと、次のことがわかります。

「 "ガウス"」の目的関数は

               1/2  RSS/nobs + lambda*penalty,                  

他のモデルでは

               -loglik/nobs + lambda*penalty.                   

また、「 "gaussian"」の場合、「glmnet」はラムダシーケンスを計算する前にyを標準化して単位分散を持たせます（次に、結果の係数を非標準化します）。結果を他のソフトウェアと再現/比較する場合は、標準化されたyを提供することをお勧めします。

これは、目的が実際にであることを意味します

$$\frac{1}{2n} \lVert y/\hat{s}-X\beta \rVert_2^2 + \lambda\alpha \lVert \beta \rVert_1 + \lambda(1-\alpha)\lVert \beta \rVert_2^2,$$ $\tilde{\beta} = \hat{s} \beta$

$\alpha=1$$\tilde{\beta}$$1/\hat{s}$glmnet$\hat{s}$$\ell_2$$\alpha$glmnets

$y$

これはまだ完全には一致しません。これは次の2つの原因が原因のようです：

1. ラムダシーケンスは、ウォームスタート循環座標降下アルゴリズムを完全に収束させるには短すぎる場合があります。
2. $R^2$
3. またlambda[2]、最初の適合に必要なコードにバグがあることに注意してくださいlambda[1]。

アイテム1〜3を修正すると、次の結果が得られます（ただし、YMMVはランダムシードによって異なります）。