Speed ups for rlasso and lambda calculation

NAMESPACE

@@ -84,6 +84,7 @@ export(rlassologitEffects)
 export(tsls)
 importFrom(Formula,model.part)
 importFrom(methods,is)
+importFrom(stats,.lm.fit)
 importFrom(stats,as.formula)
 importFrom(stats,binomial)
 importFrom(stats,coef)

R/pkg-package.R

@@ -33,6 +33,7 @@
 #' @importFrom stats cor
 #' @importFrom stats glm
 #' @importFrom stats lm
+#' @importFrom stats .lm.fit
 #' @importFrom stats model.frame
 #' @importFrom stats model.matrix
 #' @importFrom stats model.response

R/rlasso.R

@@ -221,7 +221,9 @@ rlasso.default <- function(x, y, post = TRUE, intercept = TRUE, model = TRUE,
   XX <- crossprod(x)
   Xy <- crossprod(x, y)
 
-  startingval <- init_values(x,y)$residuals
+  init_vals <- init_values(x,y) 
+
+  startingval <- init_vals$residuals
   pen <- lambdaCalculation(penalty = penalty, y = startingval, x = x)
   lambda <- pen$lambda
   Ups0 <- Ups1 <- pen$Ups0
@@ -235,13 +237,13 @@ rlasso.default <- function(x, y, post = TRUE, intercept = TRUE, model = TRUE,
     #coefTemp <- LassoShooting.fit(x, y, lambda, XX = XX, Xy = Xy)$coefficients
     #xn <- t(t(x)/as.vector(Ups1))
     if (mm==1 && post) {
-      coefTemp <- LassoShooting.fit(x, y, lambda/2, XX = XX, Xy = Xy)$coefficients
+      coefTemp <- LassoShooting.fit(x, y, lambda/2, XX = XX, Xy = Xy, beta.start = init_vals$coefficients)$coefficients
       #lasso.reg <- glmnet::glmnet(xn, y, family = c("gaussian"), alpha = 1,
       #                            lambda = lambda0/(2*n)/2, standardize = FALSE, intercept = FALSE)
       #lasso.reg <- glmnet::glmnet(x, y, family = c("gaussian"), alpha = 1,
       #                           lambda = lambda0/(2*n)/2, standardize = FALSE, intercept = FALSE,  penalty.factor = Ups1)
     } else {
-      coefTemp <- LassoShooting.fit(x, y, lambda, XX = XX, Xy = Xy)$coefficients
+      coefTemp <- LassoShooting.fit(x, y, lambda, XX = XX, Xy = Xy, beta.start = init_vals$coefficients)$coefficients
       #lasso.reg <- glmnet::glmnet(xn, y, family = c("gaussian"), alpha = 1,
       #                           lambda = lambda0/(2*n), standardize = FALSE, intercept = FALSE)
       #lasso.reg <- glmnet::glmnet(x, y, family = c("gaussian"), alpha = 1,
@@ -280,8 +282,10 @@ rlasso.default <- function(x, y, post = TRUE, intercept = TRUE, model = TRUE,
 
     # refinement variance estimation
     if (post) {
-      reg <- lm(y ~ -1 + x1)
-      coefT <- coef(reg)
+      #reg <- lm(y ~ -1 + x1)
+      #coefT <- coef(reg)
+      reg <- .lm.fit(x1, y)
+      coefT <- reg$coefficients
       coefT[is.na(coefT)] <- 0
       e1 <- y - x1 %*% coefT
       coefTemp[ind1] <- coefT
@@ -492,14 +496,22 @@ lambdaCalculation <- function(penalty = list(homoscedastic = FALSE, X.dependent.
     # }
     xehat <- x*ehat
     psi <- apply(xehat, 2, function(x) mean(x^2))
-    tXehattpsi <- t(t(xehat)/sqrt(psi))
+    #tXehattpsi <- t(t(xehat)/sqrt(psi))
+    #
+    #  for (l in 1:R) {
+    #    g <- matrix(rep(rnorm(n), each = p), ncol = p, byrow = TRUE)
+    #    #sim[l] <- n * max(2 * colMeans(x * ehat* g))
+    #    sim[l] <- n * max(2 * abs(colMeans(tXehattpsi * g)))
+    #  }
 
-      for (l in 1:R) {
-        g <- matrix(rep(rnorm(n), each = p), ncol = p, byrow = TRUE)
-        #sim[l] <- n * max(2 * colMeans(x * ehat* g))
-        sim[l] <- n * max(2 * abs(colMeans(tXehattpsi * g)))
-      }
+    Xehattpsi <- t(xehat)/sqrt(psi)
+    for (l in 1:R) {
+      g <- rnorm(n)
+      sim[l] <- max(2* abs(Xehattpsi %*% g))
+    }
 
+    #g <- matrix(rnorm(n*R), ncol = R, byrow=FALSE)
+    #sim <- apply(2 * abs(Xehattpsi %*% g), 2, max) 
 
     lambda0 <- penalty$c * quantile(sim, probs = 1 - penalty$gamma)
     Ups0 <- 1/sqrt(n) * sqrt(t(t(y^2) %*% (x^2)))