Come afferma il titolo, sto cercando di replicare i risultati di glmnet linear usando l'ottimizzatore LBFGS della libreria lbfgs. Questo ottimizzatore ci consente di aggiungere un termine regolarizzatore L1 senza doversi preoccupare della differenziabilità, purché la nostra funzione obiettivo (senza il termine regolarizzatore L1) sia convessa.
Il problema della regressione lineare netta elastica nel documento glmnet è dato da dove X \ in \ mathbb {R} ^ {n \ times p} è la matrice di progettazione, y \ in \ mathbb {R} ^ p è il vettore delle osservazioni, \ alpha \ in [0,1] è il parametro della rete elastica e \ lambda> 0 è il parametro di regolarizzazione. L'operatore \ Vert x \ Vert_p indica la solita norma Lp.
Il codice seguente definisce la funzione e quindi include un test per confrontare i risultati. Come si può vedere, i risultati sono accettabili quando alpha = 1, ma sono fuori strada per i valori di alpha < 1.L'errore peggiora come andiamo da alpha = 1a alpha = 0, come mostrato nella seguente trama (il "confronto metrica" è la distanza euclidea media tra le stime dei parametri di glmnet e lbfgs per un determinato percorso di regolarizzazione).
Ok, quindi ecco il codice. Ho aggiunto commenti ove possibile. La mia domanda è: perché i miei risultati sono diversi da quelli di glmnetfor value of alpha < 1? Ha chiaramente a che fare con il termine di regolarizzazione L2, ma per quanto ne so, ho implementato questo termine esattamente come nel documento. Qualsiasi aiuto sarebbe molto apprezzato!
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 Ho provato il tuo codice, ecco alcuni test (ho apportato alcune piccole modifiche per abbinare la struttura di glmnet - nota che non regolarizziamo il termine di intercettazione e le funzioni di perdita devono essere ridimensionate). Questo è per alpha = 0, ma puoi provare qualsiasi alpha- i risultati non corrispondono.
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)))
lbfgse orthantwise_c, come quando alpha = 1, la soluzione è quasi la stessa con glmnet. Ha a che fare con il lato della regolarizzazione L2 delle cose, cioè quando alpha < 1. Penso che apportare una sorta di modifica alla definizione di SSEe SSE_grdovrebbe risolverla, ma non sono sicuro di quale dovrebbe essere la modifica - per quanto ne so, quelle funzioni sono definite esattamente come descritto nella carta glmnet.
lbfgssolleva un puntoorthantwise_csull'argomento relativoglmnetall'equivalenza.