From berwin@maths.uwa.edu.au  Mon Apr 12 04:51:06 2004
X-VM-v5-Data: ([nil nil nil nil nil nil nil nil nil]
	["18691" "Monday" "12" "April" "2004" "10:51:00" "+0800" "Berwin A Turlach" "berwin@maths.uwa.edu.au" "<16506.1044.155769.557937@bossiaea.maths.uwa.edu.au>" "490" "Re: [R] Intercept in lasso models" "^From:" nil nil "4" "2004041204:51:00" "[R] Intercept in lasso models" nil "<opr6a4omv5jigwsf@mail.ist.org>" ("<opr6a4omv5jigwsf@mail.ist.org>") nil nil nil nil]
	nil)
Return-Path: <berwin@maths.uwa.edu.au>
Received: from asclepius.uwa.edu.au (asclepius.uwa.edu.au [130.95.128.56])
	by hypatia.math.ethz.ch (8.12.11/8.12.11) with ESMTP id i3C2p3hm003865
	for <maechler@stat.math.ethz.ch>; Mon, 12 Apr 2004 04:51:04 +0200
Received: from 127.0.0.1 (localhost [127.0.0.1])
	by dummy.domain.name (Postfix) with SMTP id AAA7F367416
	for <maechler@stat.math.ethz.ch>; Mon, 12 Apr 2004 10:51:02 +0800 (WST)
Received: from madvax (madvax.maths.uwa.edu.au [130.95.16.119])
	by asclepius.uwa.edu.au (Postfix) with ESMTP id 933293673F1
	for <maechler@stat.math.ethz.ch>; Mon, 12 Apr 2004 10:51:02 +0800 (WST)
Received: from bossiaea.maths.uwa.edu.au ([130.95.16.156] ident=mail)
	by madvax with esmtp (Exim 4.30)
	id 1BCrXI-00061N-P3; Mon, 12 Apr 2004 10:51:00 +0800
Received: from berwin by bossiaea.maths.uwa.edu.au with local (Exim 3.36 #1 (Debian))
	id 1BCrXI-00084V-00; Mon, 12 Apr 2004 10:51:00 +0800
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="DlA4Bmox1U"
Content-Transfer-Encoding: 7bit
Message-ID: <16506.1044.155769.557937@bossiaea.maths.uwa.edu.au>
In-Reply-To: <opr6a4omv5jigwsf@mail.ist.org>
References: <opr6a4omv5jigwsf@mail.ist.org>
X-Mailer: VM 7.18 under Emacs 21.3.1
X-Virus-Scanned: by amavisd-new
X-Spam-Checker-Version: SpamAssassin 2.63 (2004-01-11) on hypatia.math.ethz.ch
X-Spam-Level: 
X-Spam-Status: No, hits=-0.9 required=5.0 tests=AWL autolearn=no version=2.63
From: Berwin A Turlach <berwin@maths.uwa.edu.au>
To: Martin Keller-Ressel <martin@ist.org>
Cc: Martin Maechler <maechler@stat.math.ethz.ch>
Subject: Re: [R] Intercept in lasso models
Date: Mon, 12 Apr 2004 10:51:00 +0800


--DlA4Bmox1U
Content-Type: text/plain; charset=us-ascii
Content-Description: message body text
Content-Transfer-Encoding: 7bit

>>>>> "MKR" == Martin Keller-Ressel <martin@ist.org> writes:

(Martin: This problem is easily fixed.  Below I attach a corrected
l1ce.q file.  I would appreciate it if you put it into lasso2 and
release a new version.  Thanks.)

    MKR> Im using the function l1ce (L1-constrained estimation) from
    MKR> the lasso2 package.  when I try the example from the help
    MKR> pages [...]
This looks somewhat familiar.  An early version of the S-Plus library
(never released) did something similar.  Essentially, if several
bounds were used, parameter estimates that were not restricted got too
often corrected.  But when that bug was fixed, a bug was introduced in
the part of the code that is run if a single bound is specified---and
S-Plus library was released with the bug in the single bound routine.

Seems as if during the port to R the latter bug was fixed on the cost
of introducing the original one again. :-)

Below I attach a patch that should fix the problem.  Unpack the
sources for the lasso2 package, apply the patch to l1ce.q (in
lasso2/R) and then install the package from source.  

If the above paragraph is "chinese" for you :), I also attach a
version of l1ce.q.  Just source it so that you have a local version of
l1ce.q in your workspace which will override the one in the package.

With this patched version, your example works for me:

> library(lasso2)
R Package to solve regression problems while imposing
	 an L1 constraint on the parameters. Based on S-plus Release 2.1
Copyright (C) 1998, 1999
Justin Lokhorst   <jlokhors@stats.adelaide.edu.au>
Berwin A. Turlach <bturlach@stats.adelaide.edu.au>
Bill Venables     <wvenable@stats.adelaide.edu.au>

Copyright (C) 2002
Martin Maechler <maechler@stat.math.ethz.ch>

> data(Prostate)
> l1c.P <- l1ce(lpsa ~ ., Prostate, bound=.5)
> coef(l1c.P)
 (Intercept)       lcavol      lweight          age         lbph          svi 
0.7284810757 0.4936540169 0.2681863403 0.0000000000 0.0092825881 0.4550584943 
         lcp      gleason        pgg45 
0.0000000000 0.0000000000 0.0001812107 
> l1c.P <- l1ce(lpsa ~ ., Prostate, bound=(1:20)/20)
> coef(l1c.P)[10,]
 (Intercept)       lcavol      lweight          age         lbph          svi 
0.7284810757 0.4936540169 0.2681863403 0.0000000000 0.0092825881 0.4550584943 
         lcp      gleason        pgg45 
0.0000000000 0.0000000000 0.0001812107 
> coef(l1c.P)[20,]
 (Intercept)       lcavol      lweight          age         lbph          svi 
 0.669399027  0.587022881  0.454460641 -0.019637208  0.107054351  0.766155885 
         lcp      gleason        pgg45 
-0.105473570  0.045135964  0.004525324 
> coef(lm(lpsa ~ ., data = Prostate))
 (Intercept)       lcavol      lweight          age         lbph          svi 
 0.669399027  0.587022881  0.454460641 -0.019637208  0.107054351  0.766155885 
         lcp      gleason        pgg45 
-0.105473570  0.045135964  0.004525324 

Hope this helps.  Thanks for pointing the problem out to us.

Best wishes,

     Berwin


--DlA4Bmox1U
Content-Type: text/plain
Content-Description: patch file
Content-Disposition: inline;
	filename="patch"
Content-Transfer-Encoding: 7bit

*** l1ce.q.01	Mon Apr  8 17:36:28 2002
--- l1ce.q	Mon Apr 12 10:30:33 2004
***************
*** 90,96 ****
          if( X.so.qr$rank != ncol(X.sweep.out) )
              warning("Matrix built from variables in `sweep.out' is rank deficient")
  
!         X.so.coef  <- qr.coef  (X.so.qr, Y.to.C)
          X.so.X     <- qr.coef  (X.so.qr, X.to.C)
          X.so.Y.fit <- qr.fitted(X.so.qr, Y.to.C)
          X.to.C     <- qr.resid (X.so.qr, X.to.C)
--- 90,96 ----
          if( X.so.qr$rank != ncol(X.sweep.out) )
              warning("Matrix built from variables in `sweep.out' is rank deficient")
  
!         X.so.coefficients  <- qr.coef  (X.so.qr, Y.to.C)
          X.so.X     <- qr.coef  (X.so.qr, X.to.C)
          X.so.Y.fit <- qr.fitted(X.so.qr, Y.to.C)
          X.to.C     <- qr.resid (X.so.qr, X.to.C)
***************
*** 166,181 ****
  
          if(something.to.sweep.out) {
              fit$fitted.values <- fit$fitted.values + X.so.Y.fit
!             X.so.coef <- X.so.coef - X.so.X %*% fit$coefficients
  
              tmp <- fit$coefficients
              fit$coefficients <- rep(0,ncol(X))
              names(fit$coefficients) <- dimnames(X)[[2]]
              fit$coefficients[X.names] <- tmp
!             names(X.so.coef) <- X.sweep.out.names
              ind <- names(fit$coefficients[name.matches])
              ##orig 1999 code : fit$coefficients[name.matches] <- X.so.coeff[ind]
!             fit$coefficients[name.matches] <- X.so.coef[ind]
  
              fit$sweep.out <- list(sweep.out = sweep.out,
                                    X.sweep.out.names = X.sweep.out.names,
--- 166,181 ----
  
          if(something.to.sweep.out) {
              fit$fitted.values <- fit$fitted.values + X.so.Y.fit
!             X.so.coefficients <- X.so.coefficients - X.so.X %*% fit$coefficients
  
              tmp <- fit$coefficients
              fit$coefficients <- rep(0,ncol(X))
              names(fit$coefficients) <- dimnames(X)[[2]]
              fit$coefficients[X.names] <- tmp
!             names(X.so.coefficients) <- X.sweep.out.names
              ind <- names(fit$coefficients[name.matches])
              ##orig 1999 code : fit$coefficients[name.matches] <- X.so.coeff[ind]
!             fit$coefficients[name.matches] <- X.so.coefficients[ind]
  
              fit$sweep.out <- list(sweep.out = sweep.out,
                                    X.sweep.out.names = X.sweep.out.names,
***************
*** 255,261 ****
  
              if(something.to.sweep.out) {
                  fit$fitted.values <- fit$fitted.values + X.so.Y.fit
!                 X.so.coef <- X.so.coef - X.so.X %*% fit$coefficients
  
                  tmp <- fit$coefficients
                  fit$coefficients <- rep(0,ncol(X))
--- 255,261 ----
  
              if(something.to.sweep.out) {
                  fit$fitted.values <- fit$fitted.values + X.so.Y.fit
!                 X.so.coef <- X.so.coefficients - X.so.X %*% fit$coefficients
  
                  tmp <- fit$coefficients
                  fit$coefficients <- rep(0,ncol(X))

--DlA4Bmox1U
Content-Type: text/plain
Content-Description: patched l1ce.q 
Content-Disposition: inline;
	filename="l1ce.q"
Content-Transfer-Encoding: 7bit

###  Copyright (C) 1998
###  Berwin A. Turlach <bturlach@stats.adelaide.edu.au>
###  Bill Venables <wvenable@stats.adelaide.edu.au>
### --> ../COPYRIGHT for more details

if(is.R()) {
### -- this is also used in gl1ce() hence ``package global'' :

    ## Orig 2.1 version (for S+) calls  qr.rtr.inv(.) which is not in R;
    ## Is only used to return the (R'R)^{-1} where MM thinks should
    ## rather return the QR object (or just its  $qr and $rank) !!
    ## It's only summary() or vcov() which needs this, and
    ## they really can compute it *then* instead of *now*
    qr.rtr.inv <- function(qr)
    {
        if(is.null(R <- qr$qr))
            stop("argument is not a valid \"qr\" object")
        p <- qr$rank
        rinv <- backsolve(R[1:p, 1:p, drop = FALSE], diag(p))
        r <- rinv %*% t(rinv)
        nm <- (dimnames(R)[[2]])[1:p]
        dimnames(r) <- list(nm, nm)
        r
    }
}

l1ce <- function(formula, data = sys.parent(), weights, subset, na.action,
                 sweep.out = ~ 1,
		 x = FALSE, y = FALSE, contrasts = NULL, standardize = TRUE,
		 trace = FALSE,
                 guess.constrained.coefficients = double(p),
		 bound = 0.5, absolute.t = FALSE)
{
    call <- match.call()
    m <- match.call(expand = FALSE)
    m$sweep.out <- m$x <- m$y <- m$contrasts <-
        m$standardize <- m$guess.constrained.coefficients <- m$trace <-
            m$bound <- m$absolute.t <- NULL

    something.to.sweep.out <- !is.null(sweep.out)
    if(something.to.sweep.out)
        m$formula <- merge.formula(formula,sweep.out)

    m[[1]] <- as.name("model.frame")

    if(!missing(data) && !is.data.frame(data)) {
        m$data <- data <- as.data.frame(data)
        warning(paste(deparse(substitute(data)), "is not a dataframe"))
    }

    m <- eval(m, data)
    weights <- model.extract(m, weights)
    Y <- model.extract(m, response)
    Terms <- terms(formula, data = data)
    X <- model.matrix(Terms, m, contrasts)
    X.names <- dimnames(X)[[2]]

    trace <- as.logical(trace)
    X.to.C <- X
    Y.to.C <- Y

    if(weighted <- length(weights)) {
        Y.to.C <- Y.to.C * (w <- sqrt(weights))
        X.to.C <- X.to.C * w
    }

    if(something.to.sweep.out) {
        sweep.out[[3]] <- sweep.out[[2]]
        sweep.out[[2]] <- formula[[2]]
        X.sweep.out <- model.matrix(terms(sweep.out, data = data),
                                    m, contrasts)
        X.sweep.out.names <- dimnames(X.sweep.out)[[2]]
        if(weighted)
            X.sweep.out <- X.sweep.out * w

        name.matches <- match(X.sweep.out.names,X.names)
        all.matched <- !any(is.na(name.matches))
        if(!all.matched)
            warning("Variables in `sweep.out' are not a subset of variables in `formula'")

        name.matches <- name.matches[!is.na(name.matches)]
        if(some.matched <- length(name.matches)) {
            X.to.C <- X.to.C[,-name.matches,drop = FALSE]
            X.names <- X.names[-name.matches]
            if(!length(X.to.C))
                stop("you cannot sweep out all the variables")
        }

        X.so.qr <- qr(X.sweep.out)
        if( X.so.qr$rank != ncol(X.sweep.out) )
            warning("Matrix built from variables in `sweep.out' is rank deficient")

        X.so.coefficients  <- qr.coef  (X.so.qr, Y.to.C)
        X.so.X     <- qr.coef  (X.so.qr, X.to.C)
        X.so.Y.fit <- qr.fitted(X.so.qr, Y.to.C)
        X.to.C     <- qr.resid (X.so.qr, X.to.C)
        Y.to.C     <- qr.resid (X.so.qr, Y.to.C)
    }

    if(standardize) {
        X.to.C.stds <- sqrt(apply(X.to.C,2,var))
        if( any(X.to.C.stds < sqrt(.Machine$double.eps)) )
            stop("Matrix build from transformed variables has a constant column")
        X.to.C <- sweep(X.to.C, 2, X.to.C.stds, "/")
    }

    n <- nrow(X.to.C)
    p <- ncol(X.to.C)

    if(!absolute.t) {
        rnk <- (X.to.C.qr <- qr(X.to.C))$rank
        if(rnk != p) ## maybe:  && p < n
            warning("X Matrix (transformed variables) has rank ",rnk,
                    " < p = ",p,", i.e., is deficient")
        else if( rnk == 0 )
            stop("Matrix built from transformed variables is null matrix")
        t0 <- sum(abs(qr.coef(X.to.C.qr, Y.to.C))[1:rnk])
        if( any(bound > 1) )
            stop("`bound'(s) must be between 0 and 1 if  absolute.t is false")

        bound <- (relative.bound <- bound) * t0

    }
    if(any(bound < 0))
        stop("`bound'(s) must be non negative")

    if( length(guess.constrained.coefficients) != p )
        stop("invalid argument for `guess.constrained.coefficients'")

    keep <- c("coefficients", "fitted.values", "residuals", "success",
              "Lagrangian", "bound")

    if( 1 == (num.bound <- length(bound)) ) { ## 1 bound ----------------------

        fit <- .C("lasso",
                  X = as.double(X.to.C),
                  n = n, p = p,
                  bound = as.double(bound),
                  coefficients = as.double(guess.constrained.coefficients),
                  Y = as.double(Y.to.C),
                  fitted.values = double(n),
                  residuals     = double(n),
                  Lagrangian    = double(1),
                  success = integer(1),
                  trace   = trace,
                  assub   = FALSE,
                  PACKAGE = "lasso2")[keep]

        if( fit$success < 0 )
            stop(paste("Oops, something went wrong in .C(\"lasso\",..):",
                       fit$success))

        ## else
        fit$success <- NULL

        fit$xtx <- crossprod(X.to.C)
        fit$xtr <- crossprod(X.to.C,fit$residuals)
        fit$constrained.coefficients <- fit$coefficients
        names(fit$coefficients) <- names(fit$constrained.coefficients) <-
            dimnames(X.to.C)[[2]]

        if(standardize) {
            fit$X.stds <- X.to.C.stds
            fit$coefficients   <- fit$coefficients / X.to.C.stds
        }

        if(something.to.sweep.out) {
            fit$fitted.values <- fit$fitted.values + X.so.Y.fit
            X.so.coefficients <- X.so.coefficients - X.so.X %*% fit$coefficients

            tmp <- fit$coefficients
            fit$coefficients <- rep(0,ncol(X))
            names(fit$coefficients) <- dimnames(X)[[2]]
            fit$coefficients[X.names] <- tmp
            names(X.so.coefficients) <- X.sweep.out.names
            ind <- names(fit$coefficients[name.matches])
            ##orig 1999 code : fit$coefficients[name.matches] <- X.so.coeff[ind]
            fit$coefficients[name.matches] <- X.so.coefficients[ind]

            fit$sweep.out <- list(sweep.out = sweep.out,
                                  X.sweep.out.names = X.sweep.out.names,
                                  name.matches = name.matches,
                                  all.matched = all.matched,
                                  some.matched = some.matched,
                                  X.so.rtr.inv = qr.rtr.inv(X.so.qr),
                                  X.so.X = X.so.X)
        }

        if(weighted) {
            fit$weights <- weights
            if( any(weights == 0) ) {
                fit$fitted.values <- X %*% fit$coefficients
                fit$residuals <- Y - fit$fitted.values
            } else {
                fit$fitted.values <- fit$fitted.values / w
                fit$residuals <- fit$residuals / w
            }
        }

        fit$terms <- Terms
        fit$call <- call
        fit$contrasts <- attr(X, "contrasts")
        fit$assign <- attr(X, "assign")
        if(x) fit$x <- X
        if(y) fit$y <- Y
        if(!absolute.t)
            fit$relative.bound <- relative.bound
        structure(fit, class = "l1ce",
                  na.message = attr(m, "na.message"))

    }
    else { ##--------- more than 1 bound ---------------------------------

        ordered.bound <- order(bound)
        guess.constraint.coefficients <-
            rep(guess.constrained.coefficients,num.bound)

        res <- .C("mult_lasso",
                  X = as.double(X.to.C), n = n, p = p,
                  bound = as.double(bound[ordered.bound]),
                  l = num.bound,
                  coefficients = as.double(guess.constraint.coefficients),
                  Y = as.double(Y.to.C),
                  fitted.values = double(n*num.bound),
                  residuals     = double(n*num.bound),
                  Lagrangian    = double(num.bound),
                  success = integer(1),
                  trace   = trace,
                  PACKAGE = "lasso2")[keep]

        if( res$success < 0 )
            stop(paste("Oops, something went wrong in .C(\"mult_lasso\",..):",
                       res$success))

        ## else
        res$success <- NULL

        total.fit <- vector("list", num.bound)
        ind1 <- 1:n
        ind2 <- 1:p
        for(i in 1:num.bound) {

            resi <- res$residuals[ind1]
            fit <- list(coefficients  = res$coefficients[ind2],
                        fitted.values = res$fitted.values[ind1],
                        residuals     = resi,
                        bound         = res$bound[i],
                        Lagrangian    = res$Lagrangian[i],
                        xtr           = crossprod(X.to.C, resi))#FIXED!
            names(fit$coefficients) <- dimnames(X.to.C)[[2]]
            fit$constrained.coefficients <- fit$coefficients

            if(standardize)
                fit$coefficients   <- fit$coefficients / X.to.C.stds

            if(something.to.sweep.out) {
                fit$fitted.values <- fit$fitted.values + X.so.Y.fit
                X.so.coef <- X.so.coefficients - X.so.X %*% fit$coefficients

                tmp <- fit$coefficients
                fit$coefficients <- rep(0,ncol(X))
                names(fit$coefficients) <- dimnames(X)[[2]]
                fit$coefficients[X.names] <- tmp
                names(X.so.coef) <- X.sweep.out.names
                ind <- names(fit$coefficients[name.matches])
                fit$coefficients[name.matches] <- X.so.coef[ind]
            }

            if(weighted) {
                if( any(weights == 0) ) {
                    fit$fitted.values <- X %*% fit$coefficients
                    fit$residuals <- Y - fit$fitted.values
                } else {
                    fit$fitted.values <- fit$fitted.values / w
                    fit$residuals <- fit$residuals / w
                }
            }

            if(!absolute.t)
                fit$relative.bound <- relative.bound[ordered.bound[i]]

            total.fit[[ordered.bound[i]]] <- fit
            ind1 <- ind1 + n
            ind2 <- ind2 + p
        }

        if(standardize) attr(total.fit, "X.stds") <- X.to.C.stds

        if(something.to.sweep.out) {
            attr(total.fit, "sweep.out") <-
                list(sweep.out = sweep.out,
                     X.sweep.out.names = X.sweep.out.names,
                     name.matches = name.matches,
                     all.matched = all.matched,
                     some.matched = some.matched,
                     X.so.rtr.inv = qr.rtr.inv(X.so.qr),
                     X.so.X = X.so.X)
        }
        attr(total.fit, "xtx") <- crossprod(X.to.C)
        if(weighted) attr(total.fit, "weights") <- weights
        attr(total.fit, "terms") <- Terms
        attr(total.fit, "call") <- call
        attr(total.fit, "contrasts") <- attr(X, "contrasts")
        attr(total.fit, "assign") <- attr(X, "assign")
        if(x) attr(total.fit, "x") <- X
        if(y) attr(total.fit, "y") <- Y
        structure(total.fit, class = "l1celist",
                  na.message = attr(m, "na.message"))
    }## multi-bound case
}

--DlA4Bmox1U
Content-Type: text/plain; charset=us-ascii
Content-Description: message body text
Content-Transfer-Encoding: 7bit



========================== Full address ============================
Berwin A Turlach                      Tel.: +61 (8) 6488 3338 (secr)   
School of Mathematics and Statistics        +61 (8) 6488 3383 (self)      
The University of Western Australia   FAX : +61 (8) 6488 1028
35 Stirling Highway                   
Crawley WA 6009                e-mail: berwin@maths.uwa.edu.au
Australia                        http://www.maths.uwa.edu.au/~berwin

--DlA4Bmox1U--

