Wie der Titel schon sagt, versuche ich, die Ergebnisse von glmnet linear mit dem LBFGS-Optimierer aus der Bibliothek zu replizieren lbfgs. Mit diesem Optimierer können wir einen L1-Regularisierungsbegriff hinzufügen, ohne uns um die Differenzierbarkeit kümmern zu müssen, solange unsere Zielfunktion (ohne den L1-Regularisierungsbegriff) konvex ist.
Das Problem der linearen Regression des elastischen Netzes im glmnet-Papier ist gegeben durch wobei X \ in \ mathbb {R} ^ {n \ times p} ist die Entwurfsmatrix, y \ in \ mathbb {R} ^ p ist der Beobachtungsvektor, \ alpha \ in [0,1] ist der elastische Netzparameter und \ lambda> 0 ist der Regularisierungsparameter. Der Operator \ Vert x \ Vert_p bezeichnet die übliche Lp-Norm.
Der folgende Code definiert die Funktion und enthält dann einen Test zum Vergleichen der Ergebnisse. Wie Sie sehen können, sind die Ergebnisse akzeptabel, wenn alpha = 1, aber weit entfernt von den Werten von alpha < 1.Der Fehler wird schlimmer, wenn wir von alpha = 1bis gehen alpha = 0, wie das folgende Diagramm zeigt (die "Vergleichsmetrik" ist der mittlere euklidische Abstand zwischen den Parameterschätzungen von glmnet und lbfgs für einen gegebenen Regularisierungspfad).
Okay, hier ist der Code. Ich habe wo immer möglich Kommentare hinzugefügt. Meine Frage ist: Warum unterscheiden sich meine Ergebnisse von denen glmnetfür Werte von alpha < 1? Es hat eindeutig mit dem L2-Regularisierungsbegriff zu tun, aber soweit ich das beurteilen kann, habe ich diesen Begriff genau gemäß dem Papier implementiert. Jede Hilfe wäre sehr dankbar!
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 Ich habe Ihren Code ausprobiert. Hier sind einige Tests (ich habe einige kleinere Änderungen vorgenommen, um sie an die Struktur von glmnet anzupassen. Beachten Sie, dass wir den Intercept-Term nicht regulieren und die Verlustfunktionen skaliert werden müssen.) Dies ist für alpha = 0, aber Sie können jeden ausprobieren alpha- die Ergebnisse stimmen nicht überein.
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)))
lbfgsund orthantwise_cwie damals alpha = 1ist die Lösung fast genau die gleiche mit glmnet. Es hat mit der L2-Regularisierungsseite der Dinge zu tun, dh wann alpha < 1. Ich denke, eine Änderung an der Definition von vorzunehmen SSEund diese SSE_grzu beheben, aber ich bin mir nicht sicher, wie die Änderung aussehen soll - soweit ich weiß, sind diese Funktionen genau wie im glmnet-Dokument beschrieben definiert.
lbfgsmöchte einen Punkt zumorthantwise_cArgument derglmnetÄquivalenz ansprechen.