R/statslm.Fit.R

In arcolombo/junk: qusage: Quantitative Set Analysis for Gene Expression

statslm.Fit <- function (x, y, offset = NULL, method = "qr", tol = 1e-07,
                    singular.ok = TRUE, ...)
{
    if (is.null(n <- nrow(x))) stop("'x' must be a matrix")
    if(n == 0L) stop("0 (non-NA) cases")
    p <- ncol(x)
    if (p == 0L) {
        ## oops, null model
        return(list(coefficients = numeric(), residuals = y,
                    fitted.values = 0 * y, rank = 0,
                    df.residual = length(y)))
    }
    ny <- NCOL(y)
    ## treat one-col matrix as vector
    if(is.matrix(y) && ny == 1)
        y <- drop(y)
    if(!is.null(offset))
        y <- y - offset
    if (NROW(y) != n)
        stop("incompatible dimensions")
    if(method != "qr")
        warning(gettextf("method = '%s' is not supported. Using 'qr'", method),
                domain = NA)
    dots <- list(...)
    if(length(dots) > 1L)
        warning("extra arguments ", paste(sQuote(names(dots)), sep=", "),
                " are disregarded.", domain = NA)
    else if(length(dots) == 1L)
        warning("extra argument ", sQuote(names(dots)),
       " is disregarded.", domain = NA)
    z <- .Call(C_Cdqrls, x, y, tol, FALSE)
    if(!singular.ok && z$rank < p) stop("singular fit encountered")
    coef <- z$coefficients
    pivot <- z$pivot
    ## careful here: the rank might be 0
    r1 <- seq_len(z$rank)
    dn <- colnames(x); if(is.null(dn)) dn <- paste0("x", 1L:p)
    nmeffects <- c(dn[pivot[r1]], rep.int("", n - z$rank))
    r2 <- if(z$rank < p) (z$rank+1L):p else integer()
    if (is.matrix(y)) {
        coef[r2, ] <- NA
        if(z$pivoted) coef[pivot, ] <- coef
        dimnames(coef) <- list(dn, colnames(y))
        dimnames(z$effects) <- list(nmeffects, colnames(y))
    } else {
        coef[r2] <- NA
        ## avoid copy
        if(z$pivoted) coef[pivot] <- coef
        names(coef) <- dn
        names(z$effects) <- nmeffects
    }
    z$coefficients <- coef
    r1 <- y - z$residuals ; if(!is.null(offset)) r1 <- r1 + offset
    ## avoid unnecessary copy
    if(z$pivoted) colnames(z$qr) <- colnames(x)[z$pivot]
 qr <- z[c("qr", "qraux", "pivot", "tol", "rank")]
    c(z[c("coefficients", "residuals", "effects", "rank")],
      list(fitted.values = r1, assign = attr(x, "assign"),
           qr = structure(qr, class="qr"),
           df.residual = n - z$rank))
}

.lm.fit <- function(x, y, tol = 1e-07) .Call(C_Cdqrls, x, y, tol, check=TRUE)