Başlık belirtildiği gibi, ben kütüphaneden LBFGS optimizer kullanarak glmnet doğrusal sonuçları çoğaltmaya çalışıyorum lbfgs. Bu optimize edici, objektif fonksiyonumuz (L1 düzenleyici terimi olmadan) dışbükey olduğu sürece, farklılaşma konusunda endişelenmenize gerek kalmadan bir L1 düzenleyici terim eklememizi sağlar.
Esnek ağ doğrusal regresyon sorun glmnet kağıdı ile verilir burada X \ in \ mathbb {R} ^ {n \ times p} tasarım matrisidir, y \ in \ mathbb {R} ^ p gözlem vektörü, [0,1] 'deki \ alpha \ elastik net parametredir ve \ lambda> 0 normalleştirme parametresidir. \ Vert x \ Vert_p operatörü normal Lp normunu gösterir. X∈Rn×p
Aşağıdaki kod işlevi tanımlar ve ardından sonuçları karşılaştırmak için bir test içerir. Gördüğünüz gibi, sonuçlar ne zaman kabul edilebilir alpha = 1değerleri için kapalı, ama olduğumuz yol alpha < 1.biz gitmek gibi hata kötüleşir alpha = 1için alpha = 0aşağıdaki arsa gösterildiği gibi, ( "kıyaslama ölçüsü" glmnet parametre tahminleri arasındaki ortalama Öklid mesafedir ve belirli bir düzenleme yolu için lbfgs).
Tamam, işte kod. Mümkün olan her yerde yorum ekledim. Benim sorum: Sonuçlarımın glmnetdeğerleri için olanlardan neden farklı alpha < 1? Açıkça L2 normalleştirme terimi ile ilgili, ama anlayabildiğim kadarıyla, bu terimi tam olarak kağıda göre uyguladım. Herhangi bir yardım çok takdir edilecektir!
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 Kodunuzu denedim, işte bazı testler (glmnet'in yapısına uyacak bazı küçük değişiklikler yaptım - intercept terimini normalleştirmediğimizi ve kayıp fonksiyonlarının ölçeklendirilmesi gerektiğini unutmayın). Bu alpha = 0, ancak herhangi birini deneyebilirsiniz alpha- sonuçlar eşleşmiyor.
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)))lbfgsve orthantwise_cne zaman olduğu alpha = 1gibi, çözüm tam olarak aynıdır glmnet. Şeylerin ne zaman L2 düzenleyici tarafı ile ilgili alpha < 1. Ben tanımında bir tür değişiklik yapmayı düşünüyorum SSEve SSE_grdüzeltmek gerekir, ama modifikasyonun ne olması gerektiğinden emin değilim - bildiğim kadarıyla, bu işlevler tam olarak glmnet kağıdında açıklandığı gibi tanımlanır.
lbfgshakkında bir noktaya değiniyor.orthantwise_cglmnet