MatrixModels/0000755000176200001440000000000012566165651012677 5ustar liggesusersMatrixModels/tests/0000755000176200001440000000000012566156115014034 5ustar liggesusersMatrixModels/tests/MModels.R0000644000176200001440000000022411630245531015505 0ustar liggesusers### So I see things in old saved "R CMD check .." directories require("Matrix") require("MatrixModels") sessionInfo() packageDescription("Matrix") MatrixModels/NAMESPACE0000644000176200001440000000664012566155760014124 0ustar liggesusers##useDynLib(MatrixModels, .registration=TRUE) ## Import non-base functions we need explicitly, ## notably for which we define methods ## -- prefering importMethodsFrom(., ...) where applicable ## importFrom("graphics", image) ## importFrom("utils", head, tail) ## importFrom("stats" ## potentially all these (we import into 'lme4a'): # , anova , coef, coefficients # confint, cov2cor, deviance, , fitted, fitted.values , formula # predict, profile , model.extract, model.matrix, model.offset, model.response, model.weights , residuals, resid # 'resid' needed too, unfortunately.. # , simulate, terms , update ) ## according to codetoolsBioC :: writeNamespaceImports("MatrixModels"): importClassesFrom("methods", ANY, call, character, environment, envRefClass, integer, list, matrix, numeric, oldClass) importMethodsFrom("methods", show) importFrom("methods" , callGeneric, as, is, extends, new , getClass, getClassDef, validObject , setClass, setClassUnion, setOldClass, setRefClass , setGeneric, setMethod , setValidity, slot, "slot<-", slotNames , signature, representation, prototype) ## Those our methods and functions use: importMethodsFrom("Matrix", as.matrix, as.vector, coerce, ## Group Methods "Arith", "Compare", "Logic", "Math", "Math2", "Ops", "Summary", t, "%*%", crossprod, tcrossprod, Cholesky, chol, chol2inv, solve, summary, print, update # notably the "CHMfactor" one ) importClassesFrom("Matrix", CHMfactor, CHMsimpl, CHMsuper, dCHMsimpl, dCHMsuper, Cholesky, CholeskyFactorization, compMatrix, corMatrix, dgCMatrix, dgeMatrix, dMatrix, dsparseMatrix, sparseMatrix, CsparseMatrix, ddenseMatrix, denseMatrix, generalMatrix, Matrix) importFrom("Matrix", .solve.dgC.chol, .solve.dgC.qr, Diagonal, isLDL, sparse.model.matrix) ## Generics and functions defined in this package ------------------------- export( "glm4", #TODO "lm.fit.sparse",# <- "somewhat experimental" "mkRespMod", "model.Matrix" , "solveCoef" , "reweightPred" , "updateMu" , "updateWts" ) exportClasses( "modelMatrix", "sparseModelMatrix", "denseModelMatrix", "dsparseModelMatrix", "ddenseModelMatrix", ## --- linear predictor modules, containing a model matrix "predModule", "dPredModule",# dense & "sPredModule",# sparse (for now) ## --- response modules, containing a response vector, etc. "respModule", # base class and also linear model "glmRespMod", # generalized linear models "nlsRespMod", # nonlinear regression response "nglmRespMod", # generalized nonlinear "glpModel", "Model" ) exportMethods(## for both own and "other" generics: ## re-export S4 methods, for "stats"-S3-generics: "coef", "coefficients" ## , "cov2cor" ,"fitted", "fitted.values", "formula" ,"residuals", "resid" ,"print"# print(x, ...) when show(x) is not sufficient ,"show" ## not yet ,"summary" ) MatrixModels/R/0000755000176200001440000000000012566156115013073 5ustar liggesusersMatrixModels/R/AllClass.R0000644000176200001440000002077211474303447014723 0ustar liggesusers.onLoad <- function(lib, pkg) { if(is.null(getOption("max.print"))) options(max.print = 10000)#-> show() of large matrices } ## Model Matrix setClass("modelMatrix", representation(assign = "integer", contrasts = "list", "VIRTUAL"), contains = "Matrix", validity = function(object) { if(length(object@assign) != (p <- ncol(object))) return(gettextf("'%s' slot must be integer of length %d", "assign", p)) contr <- object@contrasts c.cl <- sapply(contr, class, USE.NAMES=FALSE) if(length(nc <- names(contr)) != length(c.cl) || !all(nchar(nc) > 0)) return(gettextf("'%s' slot must be a correctly named list")) ## TODO? length(contrasts) < maximal value in 'assign' <= p contrCls <- c("character", "function", "matrix", "Matrix") if(any(unlist(lapply(c.cl, function(cl) all(is.na(match(extends(cl), contrCls))))))) return(gettextf("'%s' slot must be named list of contrast functions or their names, or matrices", "contrasts")) TRUE }) setClass("sparseModelMatrix", representation("VIRTUAL"), contains = c("CsparseMatrix", "modelMatrix")) setClass("denseModelMatrix", representation("VIRTUAL"), contains = c("denseMatrix", "modelMatrix")) ## The currently only *actual* denseModelMatrix class: setClass( "ddenseModelMatrix", contains = c("dgeMatrix", "ddenseMatrix", "denseModelMatrix")) ## here, add "ddense*": does not influence slots, but yields consistent superclass ordering ## The currently only *actual* sparseModelMatrix class: setClass("dsparseModelMatrix", contains = c("dgCMatrix", "sparseModelMatrix")) ###------ Modules related to modelling --- basically in two parts -------------- ###------ 1) "prediction-Module" -- currently in a sparse and dense flavor ###------ 2) "response-Module" ## Linear predictor modules, which consist of the model matrix, the ## coefficient vector and a triangular factor of the weighted model matrix. ## the super class contains the slots already; setClass("predModule", representation(X = "modelMatrix", coef = "numeric", Vtr = "numeric", fac = "CholeskyFactorization", "VIRTUAL")) ## the sub classes specify more specific classes for the two non-trivial slots: setClass("dPredModule", contains = "predModule", representation(X = "ddenseModelMatrix", fac = "Cholesky")) setClass("sPredModule", contains = "predModule", representation(X = "dsparseModelMatrix", fac = "CHMfactor")) ## Response modules for models with a linear predictor, which can ## include linear models, generalized linear models, nonlinear models ## and generalized nonlinear models. ## y, offset and mu are as expected. Note that length(offset) can be a multiple of length(y) ## weights are the prior weights ## sqrtrwt and sqrtXwt are the square roots of residual and X weights setClass("respModule", representation(mu = "numeric", # of length n offset = "numeric", # of length n * s sqrtXwt = "matrix", # of dim(.) == (n, s) sqrtrwt = "numeric", # sqrt(residual weights) weights = "numeric", # prior weights wtres = "numeric", y = "numeric"), validity = function(object) { n <- length(object@y) if (any(n != sapply(lapply(c("weights","sqrtrwt","mu","wtres" ), slot, object = object), length))) return("lengths of weights, sqrtwt and mu must match length(y)") lo <- length(object@offset) if (!lo || lo %% n) return("length(offset) must be a positive multiple of length(y)") if (length(object@sqrtXwt) != lo) return("length(sqrtXwt) must equal length(offset)") if (nrow(object@sqrtXwt) != n) return("nrow(sqrtXwt) != length(y)") TRUE }) setOldClass("family") ##' glm response module setClass("glmRespMod", representation(family = "family", eta = "numeric", n = "numeric"), # for evaluation of the aic contains = "respModule", validity = function(object) { if (length(object@eta) != length(object@y)) return("lengths of eta and y must match") }) ##' nls response module setClass("nlsRespMod", representation(nlenv = "environment", nlmod = "call", pnames = "character"), contains = "respModule", validity = function(object) { n <- length(object@y) N <- length(object@offset) s <- N %/% n lpn <- length(object@pnames) if (lpn != s) return(sprintf("length(pnames) = %d != s = %d", lpn, s)) dd <- dim(object@sqrtXwt) if (!all(dd == c(n, s))) { return(sprintf("dim(gradient) = (%d, %d), n = %d, s = %d", dd[1], dd[2], n, s)) } TRUE }) ##' nglm response module setClass("nglmRespMod", contains = c("glmRespMod", "nlsRespMod")) ### FIXME: move this eventually to 'methods': ## ----- ##' The mother class of all (S4 based) (statistical / physical / ...) models in R: setClass("Model", representation(call = "call", fitProps = "list", "VIRTUAL")) ##' Statistical models based on linear predictors ##' "glpModel" := General Linear Prediction Models setClass("glpModel", representation(resp = "respModule", pred = "predModule"), contains = "Model") rMod <- setRefClass("RespModule", fields = list( mu = "numeric", # of length n n = "integer", # for evaluation of the aic offset = "numeric", # of length n * s sqrtXwt = "matrix", # of dim(.) == (n, s) sqrtrwt = "numeric", # sqrt(residual weights) weights = "numeric", # prior weights wtres = "numeric", y = "numeric"), methods = list( initialize = function(...) { initFields(...) if (length(n) == 0L) n <<- length(y) s <- 0L ##currently fails at pkg INSTALL time: stopifnot(n > 0L) if (length(weights) == 0L) weights <<- numeric(n) + 1 sqrtrwt <<- sqrt(weights) if (any((dd <- dim(sqrtXwt)) < 1L)) sqrtXwt <<- matrix(1, ncol = 1L, nrow = n) else { stopifnot(nrow(sqrtXwt) == n) s <- ncol(sqrtXwt) } swrk <- max(s, 1L) if (length(offset) == 0) offset <<- numeric(n * swrk) else { so <- length(offset) %/% n stopifnot(length(offset) %% n == 0, s == 0 || so == s) } wtres <<- mu <<- numeric(n) * NA_real_ .self }, updateMu = function(gamma) { gamma <- as.numeric(gamma) stopifnot(length(gamma) == length(offset)) mu <<- gamma + offset wtres <<- sqrtrwt * (y - mu) }, updateWts = function() {} )) rMod$lock("y","n","weights","offset") glrMod <- setRefClass("GLMrespMod", fields = list( family = "family", eta = "numeric"), contains = "RespModule", methods = list( initialize = function(...) { callSuper(...) args <- list(...) stopifnot("family" %in% names(args), is(args$family, "family")) family <<- args$family .self }, updateMu = function(gamma) { gamma <- as.numeric(gamma) stopifnot(length(gamma) == length(offset)) mu <<- family$linkinv(eta <<- offset + gamma) wtres <<- sqrtrwt * (y - mu) }, updateWts = function() { sqrtrwt <<- rtrwt <- sqrt(weights/family$variance(mu)) sqrtXwt[] <<- rtrwt * family$mu.eta(eta) wtres <<- rtrwt * (y - mu) } )) glrMod$lock("family") MatrixModels/R/modelMatrix.R0000644000176200001440000005073012566155760015515 0ustar liggesusers####---- This was part of ../../Matrix/R/spModels.R -- till 2010-07-25 model.Matrix <- function(object, data = environment(object), contrasts.arg = NULL, xlev = NULL, sparse = FALSE, drop.unused.levels = FALSE, ...) { if(sparse) { m <- sparse.model.matrix(object, data=data, contrasts.arg=contrasts.arg, drop.unused.levels=drop.unused.levels, xlev=xlev, ...) new("dsparseModelMatrix", m, ## dropping attributes ? assign = attr(m, "assign"), contrasts = if(is.null(ctr <- attr(m,"contrasts")))list() else ctr) } else { ## as standard model.matrix() but producing a "ddenseModelMatrix": m <- model.matrix(object, data=data, contrasts.arg=contrasts.arg, xlev=xlev, ...) new("ddenseModelMatrix", as(m, "dgeMatrix"), assign = attr(m, "assign"), contrasts = if(is.null(ctr <- attr(m,"contrasts")))list() else ctr) } } ### Keep this namespace-hidden: Would need to return a classed object ## FIXME: still test this function for both methods, since currently ## ----- both dgCMatrix_cholsol and dgCMatrix_qrsol are only called from here! lm.fit.sparse <- function(x, y, w = NULL, offset = NULL, method = c("qr", "cholesky"), tol = 1e-7, singular.ok = TRUE, order = NULL, transpose = FALSE) ### Fit a linear model, __ given __ a sparse model matrix 'x' ### using a sparse QR or a sparse Cholesky factorization { cld <- getClass(class(x)) stopifnot(extends(cld, "dsparseMatrix"), is.numeric(y)) ## or if(!is(x, "dsparseMatrix")) x <- as(x, "dsparseMatrix") if(transpose) { tx <- x ; x <- t(x) } n <- nrow(x) if(NROW(y) != n) stop("incompatible dimensions of (x,y)") ny <- NCOL(y) if (!is.null(offset)) { stopifnot(length(offset) == n) y <- y - as.numeric(offset) } if(ny != 1L) ## FIXME: should not be too much work! stop("multivariate, i.e., matrix 'y' is not yet implemented") if ((has.w <- !is.null(w))) { if(any(w < 0 | is.na(w))) stop("missing or negative weights not allowed") if(length(w) != n) stop("weights vector 'w' is of wrong length") zero.weights <- any(wis0 <- w == 0) if (zero.weights) { save.r <- y save.f <- y save.w <- w ok <- !wis0 # == w != 0 i0 <- which(wis0) ok <- which(ok) # (faster when indexing repeatedly) w <- w[ok] x0 <- x[i0, , drop = FALSE] x <- x[ok, , drop = FALSE] n <- nrow(x) y0 <- if (ny > 1L) y[i0, , drop = FALSE] else y[i0] y <- if (ny > 1L) y[ok, , drop = FALSE] else y[ok] } wts <- sqrt(w) ## keep the unweighted (x,y): y. <- y ## x. <- x x <- x * wts y <- y * wts } method <- match.arg(method) order <- { if(is.null(order)) ## recommended default depends on method : if(method == "qr") 3L else 1L else as.integer(order) } switch(method, "cholesky" = { r <- .solve.dgC.chol(as(if(transpose) tx else t(x), "CsparseMatrix"), y) coef <- r[["coef"]] }, "qr" = { coef <- .solve.dgC.qr(if(cld@className %in% c("dtCMatrix", "dgCMatrix")) x else as(x, "dgCMatrix"), y, order) ## for now -- FIXME -- return(coef) }, ## otherwise: stop("unknown method ", dQuote(method)) ) ## FIXME: add names to coef as in lm.wfit(), ## ~/R/D/r-devel/R/src/library/stats/R/lm.R resid <- if(has.w) r[["resid"]] / wts else r[["resid"]] z <- list(coef = coef, weights = w, residuals = resid, fitted.values = y - resid) if(has.w && zero.weights) { coef[is.na(coef)] <- 0 f0 <- x0 %*% coef if (ny > 1) { save.r[ok, ] <- resid save.r[i0, ] <- y0 - f0 save.f[ok, ] <- z$fitted.values save.f[i0, ] <- f0 } else { save.r[ok] <- resid save.r[i0] <- y0 - f0 save.f[ok] <- z$fitted.values save.f[i0] <- f0 } z$residuals <- save.r z$fitted.values <- save.f z$weights <- save.w } if(!is.null(offset)) z$fitted.values <- z$fitted.values + offset z } ## allow extra args to be passed to print, notably those ## to printSpMatrix() [ ../sparseMatrix.R ] : printModelMat <- function(x, ...) { ## workaround because callNextMethod() fails here: cat(sprintf("\"%s\": ", class(x)[1])) ## (an "intermediate" class) - why exactly? -- callNextMethod() print(as(x, "generalMatrix"), ...) ## end{workaround} p <- length(ass <- x@assign) c.ass <- encodeString(ass) if(sum(nchar(c.ass))+ p-1 < getOption("width") - 10) ## short enough cat("@ assign: ", c.ass,"\n") else { cat("@ assign:\n"); print(ass) } cat("@ contrasts:\n"); print(x@contrasts) invisible(x) } setMethod("print", "modelMatrix", printModelMat) setMethod("show", "modelMatrix", function(object) printModelMat(object)) setAs("ddenseModelMatrix", "predModule", function(from) { p <- ncol(from) new("dPredModule", coef = numeric(p), Vtr = numeric(p), X = from, fac = chol(crossprod(from))) }) setAs("dsparseModelMatrix", "predModule", function(from) { p <- ncol(from) new("sPredModule", coef = numeric(p), Vtr = numeric(p), X = from, fac = Cholesky(crossprod(from), LDL = FALSE)) }) ##' Create an respModule, which could be from a derived class such as ##' glmRespMod or nlsRespMod. ##' @title Create a respModule object ##' @param a model frame ##' @param family the optional glm family (glmRespMod only) ##' @param nlenv the nonlinear model evaluation environment (nlsRespMod only) ##' @param nlmod the nonlinear model function (nlsRespMod only) ##' @param pnames character vector of parameter names for the ##' nonlinear model ##' @return an respModule object mkRespMod <- function(fr, family = NULL, nlenv = NULL, nlmod = NULL) { N <- n <- nrow(fr) if (!is.null(nlmod)) { nleta <- eval(nlmod, nlenv) grad <- attr(nleta, "gradient") if (is.null(grad)) stop("At present a nonlinear model must return a gradient attribute") N <- n * ncol(grad) } # components of the model frame y <- model.response(fr) if(length(dim(y)) == 1) { # avoid problems with 1D arrays, but keep names nm <- rownames(y) dim(y) <- NULL if(!is.null(nm)) names(y) <- nm } weights <- model.weights(fr) if (is.null(weights)) weights <- rep.int(1, n) else if (any(weights < 0)) stop(gettext("negative weights not allowed", domain = "R-Matrix")) offset <- model.offset(fr) if (is.null(offset)) offset <- numeric(N) if (length(offset) == 1) offset <- rep.int(offset, N) else if (length(offset) != N) stop(gettextf("number of offsets (%d) should be %d (s * n)", length(offset), N), domain = "R-Matrix") ll <- list(weights = unname(weights), offset = unname(offset), wtres = numeric(n)) if (!is.null(family)) { ll$y <- y # may get overwritten later rho <- new.env() rho$etastart <- model.extract(fr, "etastart") rho$mustart <- model.extract(fr, "mustart") rho$nobs <- n if (is.character(family)) family <- get(family, mode = "function", envir = parent.frame(3)) if (is.function(family)) family <- family() eval(family$initialize, rho) family$initialize <- NULL # remove clutter from str output ll$mu <- unname(rho$mustart) lr <- as.list(rho) ll[names(lr)] <- lr # may overwrite y, weights, etc. ll$weights <- unname(ll$weights) ll$y <- unname(ll$y) ll$eta <- family$linkfun(ll$mu) ll$sqrtrwt <- sqrt(ll$weights/family$variance(ll$mu)) ll$sqrtXwt <- matrix(ll$sqrtrwt * family$mu.eta(ll$eta)) ll$family <- family ll <- ll[intersect(names(ll), slotNames("glmRespMod"))] ll$n <- unname(rho$n) # for the family$aic function ll$Class <- "glmRespMod" } else { ll$sqrtrwt <- sqrt(ll$weights) ll$y <- unname(as.numeric(y)) ll$mu <- numeric(n) if (is.null(nlenv)) { ll$Class <- "respModule" ll$sqrtXwt <- matrix(ll$sqrtrwt) } else { ll$Class <- "nlsRespMod" ll$nlenv <- nlenv ll$nlmod <- quote(nlmod) ll$sqrtXwt <- grad ll$pnames <- colnames(ll$sqrtXwt) } } do.call("new", ll) } glm4 <- function(formula, family, data, weights, subset, na.action, start = NULL, etastart, mustart, offset, sparse = FALSE, drop.unused.levels = FALSE, doFit = TRUE, control = list(...), ## all the following are currently ignored: model = TRUE, x = FALSE, y = TRUE, contrasts = NULL, ...) { call <- match.call() if (missing(family)) { family <- NULL } else { if(is.character(family)) family <- get(family, mode = "function", envir = parent.frame()) if(is.function(family)) family <- family() if(is.null(family$family)) { print(family) stop("'family' not recognized") } } ## extract x, y, etc from the model formula and frame if(missing(data)) data <- environment(formula) mf <- match.call(expand.dots = FALSE) m <- match(c("formula", "data", "subset", "weights", "na.action", "etastart", "mustart", "offset"), names(mf), 0L) mf <- mf[c(1L, m)] mf$drop.unused.levels <- TRUE mf[[1L]] <- as.name("model.frame") mf <- eval(mf, parent.frame()) ans <- new("glpModel", call = call, resp = mkRespMod(mf, family), pred = as(model.Matrix(formula, mf, sparse = sparse, drop.unused.levels=drop.unused.levels), "predModule")) if (doFit) ## TODO ? - make 'doFP' a function argument / control component: fitGlm4(ans, doFP = TRUE, control = control) else ans } fitGlm4 <- function(lp, doFP = TRUE, control = list()) { ### note that more than one iteration would need to update more than just 'coef' if(doFP && is(lp@resp, "glmRespMod")) lp@pred@coef <- glm.fp(lp) IRLS(lp, control) } ##' A single step in the fixed-point algorithm for GLMs. ##' ##' In general we use an algorithm similar to the Gauss-Newton ##' algorithm for nonlinear least squares (except, of course, that it ##' allows for reweighting). For some models, such as those using the ##' Gamma family with the inverse link the initial values of eta must ##' be non-zero. This function calculates a single iteration of the ##' fixed-point algorithm used in stats::glm.fit to obtain suitable ##' starting estimates for the parameters. ##' @title Fixed-point iteration for a GLM ##' @param lp a linear predictor model. The resp slot should inherit ##' from the glmRespMod class. ##' @return parameter vector glm.fp <- function(lp) { stopifnot(is(lp, "glpModel"), is(rM <- lp@resp, "glmRespMod")) ff <- rM@family mu <- rM@mu vv <- ff$variance(mu) eta <- rM@eta muEta <- ff$mu.eta(eta) wts <- rM@weights z <- (eta - rM@offset) + (rM@y - rM@mu)/muEta good <- is.finite(vv) & vv > 0 & is.finite(z) stopifnot(any(good)) w <- sqrt(wts * muEta * muEta /vv)[good] wM <- lp@pred@X[good,] * w as.vector(solve(crossprod(wM), crossprod(wM, z[good] * w))) } ##' ##' @title ##' @param control a (named) list {or vector; as.list(.) must work}. ##' @param defaults a (named) list {or vector; as.list(.) must work}. ##' @param rho typically an environment; in fact anything that "works" as third ##' argument in 'assign(nm, val, rho)'> ##' @param nomatch.action string specifying what should happen when control() ##' entries do not match any of the defaults. ##' @return none. Side effect: 'rho' will contain 'control' and 'defaults' entries. ##' @author Doug Bates (& Martin Maechler) do.defaults <- function(control, defaults, rho, ## by default stop() on mistyped control arguments: nomatch.action = c("stop", "warning", "none")) { nomatch.action <- match.arg(nomatch.action) # Install the default values dnms <- names(defaults <- as.list(defaults)) lapply(dnms, function(nm) assign(nm, defaults[[nm]], rho)) # Match names of control arguments to defaults matched <- !is.na(mm <- pmatch(names(control <- as.list(control)), dnms)) if(nomatch.action != "none" && any(!matched)) { msg <- paste("The following control arguments did not match any default's names:", paste(dQuote(names(control)[!matched]), collapse=", "), sep="\n ") switch(nomatch.action, "warning" = warning(msg, call.=FALSE, immediate.=TRUE), "stop" = stop(msg, call.=FALSE)) } if (any(matched)) { cc <- control[matched] names(cc) <- dnms[mm[matched]] lapply(names(cc), function(nm) assign(nm, as(cc[[nm]], class(defaults[[nm]])), rho)) } invisible() } IRLS <- function(mod, control) { stopifnot(is(mod, "glpModel")) respMod <- mod@resp predMod <- mod@pred ## localVariables("..."): MXITER <- warnOnly <- verbose <- quick <- TOL <- SMIN <- finalUpdate <- NULL do.defaults(control, list(MXITER = 200L, TOL = 0.0001, SMIN = 0.0001, verbose = 0L,# integer: for verboseness levels warnOnly = FALSE, quick = TRUE, finalUpdate = FALSE), environment()) cc <- predMod@coef respMod <- updateMu(respMod, as.vector(predMod@X %*% cc)) iter <- nHalvings <- 0 ; DONE <- FALSE repeat { if((iter <- iter + 1) > MXITER) { msg <- paste("Number of iterations exceeded maximum MXITER =", MXITER) if(!warnOnly) stop(msg) ## else : warning(msg) cc <- cbase DONE <- TRUE break } cbase <- cc respMod <- updateWts(respMod) wrss0 <- sum(respMod@wtres^2) predMod <- reweightPred(predMod, respMod@sqrtXwt, respMod@wtres) incr <- solveCoef(predMod) convcrit <- sqrt(attr(incr, "sqrLen")/wrss0) if(verbose) cat(sprintf("_%d_ convergence criterion: %5g\n", iter, convcrit)) if(quick)## faster, but "loses" precision by not doing the "free" update: if (convcrit < TOL) break step <- 1 repeat { cc <- as.vector(cbase + step * incr) respMod <- updateMu(respMod, as.vector(predMod@X %*% cc)) wrss1 <- sum(respMod@wtres^2) if (verbose) { cat(sprintf("step = %.5f, new wrss = %.8g, Delta(wrss)= %g, coef =\n", step, wrss1, wrss0 - wrss1)) print(cc) } if (wrss1 < wrss0) break ## else if ((step <- step/2) < SMIN) { msg <- "Minimum step factor 'SMIN' failed to reduce wrss" if(!warnOnly) stop(msg) ## else : warning(msg) cc <- cbase DONE <- TRUE break } ## no further step halving, if we are good enough anyway if (DONE <- convcrit < TOL) break nHalvings <- nHalvings + 1 } if(DONE || (!quick # check now && convcrit < TOL)) break } predMod@coef <- cc if(finalUpdate) { respMod <- updateWts(respMod) predMod <- reweightPred(predMod, respMod@sqrtXwt, respMod@wtres) } mod@ fitProps <- list(convcrit=convcrit, iter=iter, nHalvings=nHalvings) ## This is more portable than new("glpModel", ....) as soon as ## the class contains extra slots (such as 'call'): mod@ resp <- respMod mod@ pred <- predMod mod } setMethod("formula", "Model", function(x, ...) x@call$formula) setMethod("coef", "glpModel", function(object, ...) { prd <- object@pred structure(prd@coef, names = colnames(prd@X)) }) setMethod("fitted", "respModule", function(object, ...) object@mu) setMethod("fitted", "glpModel", function(object, ...) {object <- object@resp; callGeneric(...)}) setMethod("residuals", "respModule", function(object, type = c("deviance", "pearson", "working", "response", "partial"), ...) { type <- match.arg(type) if (type %in% c("pearson", "deviance")) return(object@wtres) if (type %in% c("working", "response")) return(object@y - object@mu) stop(paste("residuals of type", sQuote(type), "not yet available")) }) setMethod("residuals", "glmRespMod", function(object, type = c("deviance", "pearson", "working", "response", "partial"), ...) { type <- match.arg(type) if (type == "pearson") return(object@wtres) fam <- object@family mu <- object@mu y <- object@y wts <- object@weights residuals <- y - mu if (type == "response") return(residuals) if (type == "working") return(residuals/fam$mu.eta(object@eta)) if (type == "deviance") { d.res <- sqrt(pmax(fam$dev.resids(y, mu, wts), 0)) return(ifelse(y > mu, d.res, -d.res)) } stop(paste("residuals of type", sQuote(type), "not yet available")) }) setMethod("residuals", "glpModel", function(object, type = c("deviance", "pearson", "working", "response", "partial"), ...) { object <- object@resp callGeneric(...) }) setMethod("updateMu", signature(respM = "respModule", gamma = "numeric"), function(respM, gamma, ...) { respM@ wtres <- respM@sqrtrwt * (respM@y - (respM@ mu <- respM@offset + gamma)) respM }) setMethod("updateMu", signature(respM = "glmRespMod", gamma = "numeric"), function(respM, gamma, ...) { respM@ mu <- respM@family$linkinv(respM@ eta <- respM@offset + gamma) respM@ wtres <- respM@sqrtrwt * (respM@y - respM@mu) respM }) setMethod("updateMu", signature(respM = "nlsRespMod", gamma = "numeric"), function(respM, gamma, ...) { ll <- as.data.frame(matrix(respM@offset + gamma, nrow = length(respM@y), dimnames = list(NULL, respM@pnames))) lapply(names(ll), function(nm) assign(nm, ll[[nm]], envir = respM@nlenv)) mm <- eval(respM@nlmod, respM@nlenv) respM@ wtres <- respM@sqrtrwt * (respM@y - (respM@ mu <- as.vector(mm))) respM@ sqrtXwt <- respM@sqrtrwt * attr(mm, "grad") respM }) setMethod("updateMu", signature(respM = "nglmRespMod", gamma = "numeric"), function(respM, gamma, ...) { .NotYetImplemented() ## FIXME }) ## For models based on a Gaussian distribution (incl. "nlsRespMod") ## updateWts() has no effect: setMethod("updateWts", signature(respM = "respModule"), function(respM, ...) respM) setMethod("updateWts", signature(respM = "glmRespMod"), function(respM, ...) { respM@ sqrtrwt <- rtrwt <- sqrt(respM@weights/respM@family$variance(respM@mu)) respM@ sqrtXwt[] <- rtrwt * respM@family$mu.eta(respM@eta) respM@ wtres <- rtrwt * (respM@y - respM@mu) respM }) setMethod("reweightPred", signature(predM = "dPredModule", sqrtXwt = "matrix", wtres = "numeric"), function(predM, sqrtXwt, wtres, ...) { V <- as.vector(sqrtXwt) * predM@X s <- ncol(sqrtXwt) if (s > 1L) V <- Reduce("+", lapply(split(seq_len(nrow(V)), gl(s, nrow(sqrtXwt))), function(ind) V[ind,])) predM@Vtr <- as.vector(crossprod(V, wtres)) predM@fac <- chol(crossprod(V)) predM }) setMethod("reweightPred", signature(predM = "sPredModule", sqrtXwt = "matrix", wtres = "numeric"), function(predM, sqrtXwt, wtres, ...) { Vt <- crossprod(predM@X, Diagonal(x = as.vector(sqrtXwt))) s <- ncol(sqrtXwt) if (s > 1L) Vt <- Reduce("+", lapply(split(seq_len(ncol(Vt)), gl(s, nrow(sqrtXwt))), function(ind) Vt[, ind])) predM@Vtr <- as.vector(Vt %*% wtres) predM@fac <- update(predM@fac, Vt) predM }) setMethod("solveCoef", "dPredModule", function(predM, ...) { cc <- solve(t(predM@fac), predM@Vtr) structure(as.vector(solve(predM@fac, cc)), sqrLen = sum(as.vector(cc)^2)) }) setMethod("solveCoef", "sPredModule", function(predM, ...) { ff <- predM@fac if (isLDL(ff)) stop("sparse factor must be LL, not LDL") cc <- solve(ff, solve(ff, predM@Vtr, system = "P"), system = "L") structure(as.vector(solve(ff, solve(ff, cc, system = "Lt"), system = "Pt")), sqrLen = sum(as.vector(cc)^2)) }) MatrixModels/R/AllGeneric.R0000644000176200001440000000625711703574015015230 0ustar liggesusers##' Updates the mean vector mu given the linear predictor ##' gamma. Evaluate the residuals and the weighted sum of squared ##' residuals. ##' ##' Note that the offset is added to the linear predictor before ##' calculating mu. ##' The sqrtXwt matrix can be updated but the sqrtrwt should not be in ##' that the weighted sum of squared residuals should be calculated ##' relative to fixed weights. Reweighting is done in a separate call. ##' @title Update the fitted mean response ##' @param respM a response module ##' @param gamma the value of the linear predictor before adding the offset ##' @param ... ##' @return updated respM setGeneric("updateMu", function(respM, gamma, ...) standardGeneric("updateMu")) ##' Update the weights, sqrtrwt and sqrtXwt ##' @title Update the residual and X weights ##' @param respM a response module ##' @param ... ##' @return updated response module setGeneric("updateWts", function(respM, ...) standardGeneric("updateWts")) if (FALSE) { # don't need this generic in R ##' Set new values of the coefficients. Can be called with a single ##' vector argument and with a pair of vectors, representing a base and ##' an increment, plus a step factor. ##' @title set new values of the coefficients ##' @param predM a predictor module ##' @param base coefficient base value ##' @param incr increment ##' @param step step factor, defaults to 0 in which case incr is ignored ##' @param ... ##' @return predM setGeneric("setCoef", function(predM, base, incr, step = 0, ...) standardGeneric("setCoef")) } ##' Update any internal structures associated with sqrtXwt and the ##' weighted residuals. The "V" matrix is evaluated from X using the ##' sqrtXwt matrix and a Vtr vector is calculated. ##' @title Reweight Prediction Module Structure Internals ##' @param predM a predictor module ##' @param sqrtXwt the sqrtXwt matrix ##' @param wtres the vector of weighted residuals ##' @param ... ##' @return updated predM setGeneric("reweightPred", function(predM, sqrtXwt, wtres, ...) standardGeneric("reweightPred")) if (FALSE) { # don't need this generic in R ##' Return the gamma vector ##' @title ##' @param predM a predictor module ##' @param ... ##' @return X %*% coef setGeneric("gammaInc", function(predM, ...) standardGeneric("gammaInc")) } ##' Solve for the coefficients, usually in the form of ##' coef <- solve(predM@fac, predM@Vtr, system = "A") ##' The squared length of the intermediate solution is attached as an ##' attribute of the returned value. ##' @title solve for the coefficients or coefficient increment ##' @param predM ##' @param ... ##' @return coefficient vector or increment setGeneric("solveCoef", function(predM, ...) standardGeneric("solveCoef")) ##------------ all these should wander to stats4 eventually: ----------------- ## Make resid() into a reasonable S4 generic (still dispatching for S3): setMethod("resid", "ANY", function(object, ...) residuals(object, ...)) ## ditto for fitted.values() & coefficients(): setMethod("fitted.values", "ANY", function(object, ...) fitted(object, ...)) setMethod("coefficients", "ANY", function(object, ...) coef (object, ...)) MatrixModels/MD50000644000176200001440000000206712566165651013214 0ustar liggesusers4ec9cd332840cbabc09ba9c99fa80e3a *ChangeLog 582085c214b9916b2a4bc49bd024a326 *DESCRIPTION 5eb001d1b55812200f0f71fd404e562b *NAMESPACE 7a7f7791efa7046efabbb67ab6e212ae *R/AllClass.R 412fdc8380154f704350319d8d0e42b4 *R/AllGeneric.R 93c883c1a6958246f1ea1518c05e80c1 *R/modelMatrix.R 0d4a8c52756fab885df4ad945c144220 *man/Model-class.Rd bb36643f358dd859d4239f8a2d13c838 *man/glm4.Rd cb5bd701214e3700654c964b62fa70c2 *man/glpModel-class.Rd f532227fdb1bcbc968a82f48ef00b3d0 *man/lm.fit.sparse.Rd 1307c69cb686f9cf520baf1bea46ef60 *man/mkRespMod.Rd 346eee8ca51b20a83991469da5fe342a *man/model.Matrix.Rd a24dafdb447ad0dfd8fb9ab88130fe4e *man/modelMatrix-class.Rd a2d4fd05608ce09bcc24bf51f2e8aa0e *man/predModule-class.Rd 8949a8027658932d62b32c8b06c3a59f *man/resid-et-al.Rd 093c0a234847d812352d2e9768d18584 *man/respModule-class.Rd 4447a50545cdd04a3b61d824d9f499ef *man/reweightPred.Rd 7182cbd142e779b2992c67ee868aeb6b *man/solveCoef.Rd 8a94f53b5077878b35d87442c5267ed1 *man/updateMu.Rd f71ab1edc84da9a6d7521563e7d6b900 *man/updateWts.Rd 97b70463118d303a8fbcd8057f399b6e *tests/MModels.R MatrixModels/DESCRIPTION0000644000176200001440000000130112566165651014400 0ustar liggesusersPackage: MatrixModels Version: 0.4-1 Date: 2015-08-22 Title: Modelling with Sparse And Dense Matrices Author: Douglas Bates and Martin Maechler Maintainer: Martin Maechler Contact: Doug and Martin Description: Modelling with sparse and dense 'Matrix' matrices, using modular prediction and response module classes. Depends: R (>= 3.0.1) Imports: stats, methods, Matrix (>= 1.1-5) Encoding: UTF-8 LazyLoad: yes License: GPL (>= 2) URL: http://Matrix.R-forge.R-project.org/ NeedsCompilation: no Packaged: 2015-08-22 20:32:14 UTC; maechler Repository: CRAN Date/Publication: 2015-08-22 23:37:45 MatrixModels/ChangeLog0000644000176200001440000000330411703574015014437 0ustar liggesusers2012-01-12 Martin Maechler * DESCRIPTION (Version): 0.3-1 (Depends): R >= 2.14.0, so we can * man/getCall.Rd: remove entirely * R/modelMatrix.R: ditto: get rid of getCall (and all the new wrong R CMD check warnings). 2011-08-19 Martin Maechler * DESCRIPTION (Version): 0.3-0 * R/modelMatrix.R: * NAMESPACE: only define & export getCall() if R < 2.14 2011-02-17 Douglas Bates * DESCRIPTION: Remove Encoding: directive. 2011-01-17 Douglas Bates * R/modelMatrix.R: Spelling correction. 2010-11-27 Martin Maechler * R/AllClass.R: comment stopifnot() which prevents INSTALL 2010-11-01 Douglas Bates * R/AllClass.R (rMod,glrMod): Initial attempt at using reference classes for the response modules. Still some problems with the contains argument to setRefClass for GLMRespMod. 2010-08-23 Martin Maechler * R/modelMatrix.R (model.Matrix, glm4): use argument 'drop.unused.levels' (and depend on Matrix version *-44). 2010-08-10 Martin Maechler * NAMESPACE: * R/AllGeneric.R, man/resid-et-al.Rd: define "ANY"-method (and hence generic) for the three standard aliases resid(), fitted.values() and coefficients(), and * man/glm4.Rd: check some of these 2010-08-09 Douglas Bates * R/modelMatrix.R: added "fitted" and "residuals" methods for "respModule" classes. Modified corresponding methods for "glpModel" to chain to these. Modified the reweightPred methods to allow for ncol(sqrtXwt) > 1. * DESCRIPTION (Version): 0.2-0, CRAN-released: ... MatrixModels/man/0000755000176200001440000000000012566156116013446 5ustar liggesusersMatrixModels/man/glpModel-class.Rd0000644000176200001440000000375611425353520016605 0ustar liggesusers\name{glpModel-class} \title{Class "glpModel" of General Linear Prediction Models} \Rdversion{1.1} \docType{class} \alias{glpModel-class} \alias{coef,glpModel-method} \alias{fitted,glpModel-method} \alias{residuals,glpModel-method} \description{ The class \code{"glpModel"} conceptually contains a very large class of \emph{\dQuote{General Linear Prediction Models}}. Its \code{resp} slot (of class \code{"\linkS4class{respModule}"}) may model linear, non-linear, generalized linear and non-linear generalized response models. } \section{Objects from the Class}{ Objects can be created by calls of the form \code{new("glpModel", ...)}, but typically rather are returned by our modeling functions, e.g., the (experimental, hence currently hidden) \code{glm4()}. } \section{Slots}{ \describe{ \item{\code{resp}:}{a \code{"\linkS4class{respModule}"} object.} \item{\code{pred}:}{a \code{"\linkS4class{predModule}"} object.} } } \section{Extends}{ Class \code{"\linkS4class{Model}"}, directly.%%-- FIXME move that stats4 } \section{Methods}{ \describe{ \item{coef}{\code{signature(object = "glpModel")}: extract the coefficient vector \eqn{\beta} from the object.} \item{fitted}{\code{signature(object = "glpModel")}: fitted values; there may be several types, corresponding to the residuals, see there (below).} \item{residuals}{\code{signature(object = "glpModel")}: residuals, depending on the type of the model, there are several types of residuals and correspondingly residuals, see \code{\link[stats:glm.summaries]{residuals.glm}} from the \pkg{stats} package.} } } %\author{Douglas Bates} \seealso{ \code{\link{glm4}()} returns fitted \code{glpModel} objects. The constituents of this class are \code{\linkS4class{respModule}} and \code{\linkS4class{predModule}}, both of which have several sub classes. } \examples{ showClass("glpModel") ## Use example(glm4) or see help(glm4) for many more examples. } \keyword{classes} MatrixModels/man/respModule-class.Rd0000644000176200001440000000701111430053417017143 0ustar liggesusers\name{respModule-class} \Rdversion{1.1} \docType{class} \alias{respModule-class} \alias{glmRespMod-class} \alias{nlsRespMod-class} \alias{nglmRespMod-class} \alias{fitted,respModule-method} \alias{residuals,respModule-method} \alias{residuals,glmRespMod-method} \title{"respModule" and derived classes} \description{ The \code{"respModule"} class is the virtual base class of response modules for \code{\linkS4class{glpModel}} model objects. Classes that inherit from \code{"respModule"} include \code{\linkS4class{glmRespMod}}, for generalized linear models, \code{\linkS4class{nlsRespMod}}, for nonlinear models and \code{\linkS4class{nglmRespMod}} for generalized nonlinear models. } \section{Objects from the Class}{ Objects from these classes are usually created with \code{\link{mkRespMod}} as part of an \code{\linkS4class{glpModel}} object returned by model-fitting functions such as the hidden function \code{glm4}. } \section{Slots}{ \describe{ \item{\code{mu}:}{Fitted mean response.} \item{\code{offset}:}{offset in the linear predictor -- always present even if it is a vector of zeros. In an \code{\linkS4class{nlsRespMod}} object the length of the offset can be a multiple of the length of the response.} \item{\code{sqrtXwt}:}{the matrix of weights for the model matrices, derived from the \code{sqrtrwt} slot.} \item{\code{sqrtrwt}:}{Numeric vector of the square roots of the weights for the residuals. For \code{respModule} and \code{\linkS4class{nlsRespMod}} objects these are constant. For \code{\linkS4class{glmRespMod}} and \code{\linkS4class{nglmRespMod}} objects these are updated at each iteration of the iteratively reweighted least squares algorithm.} \item{\code{weights}:}{Prior weights -- always present even when it is a vector of ones.} \item{\code{y}:}{Numeric response vector.} \item{\code{family}:}{a glm family, see \code{\link{family}} for details - \code{glmRespMod} objects only.} \item{\code{eta}:}{numeric vector, the linear predictor that is transformed to the conditional mean via the link function - \code{glmRespMod} objects only.} \item{\code{n}:}{a numeric vector used for calculation of the aic family function (it is really only used with the binomial family but we need to include it everywhere) - \code{glmRespMod} objects only.} \item{\code{nlenv}:}{an environment in which to evaluate the nonlinear model function - \code{nlsRespMod} objects only.} \item{\code{nlmod}:}{an unevaluated call to the nonlinear model function - \code{nlsRespMod} objects only.} \item{\code{pnames}:}{a character vector of parameter names - \code{nlsRespMod} objects only.} } } \section{Methods}{ \describe{ \item{fitted}{\code{signature(object = "respModule")}: fitted values; there may be several types, corresponding to the residuals, see there (below).} \item{residuals}{\code{signature(object = "respModule")}: residuals, depending on the type of the model, there are several types of residuals and correspondingly residuals, see \code{\link[stats:glm.summaries]{residuals.glm}} from the \pkg{stats} package. Because many of these types of residuals are identical except for objects that inherit from "glmRespMod", a separate method is defined for this subclass.} } } \seealso{\code{\link{mkRespMod}}} \examples{ showClass("respModule") showClass("glmRespMod") showClass("nlsRespMod") } \keyword{classes} MatrixModels/man/modelMatrix-class.Rd0000644000176200001440000000577411423257032017330 0ustar liggesusers\name{modelMatrix-class} \Rdversion{1.1} \title{Class "modelMatrix" and SubClasses} \docType{class} \alias{modelMatrix-class} \alias{denseModelMatrix-class} \alias{ddenseModelMatrix-class} \alias{sparseModelMatrix-class} \alias{dsparseModelMatrix-class} % \alias{show,modelMatrix-method} \alias{print,modelMatrix-method} \description{ The class \code{"modelMatrix"} and notably its subclass \code{"dsparseModelMatrix"} are used to encode additional information, analogously to what the standard \R function \code{\link{model.matrix}()} returns. } \section{Objects from the Classes}{ Only \code{"dsparseModelMatrix"} and \code{"ddenseModelMatrix"} are \dQuote{actual} (aka non-virtual) classes. For these, objects can be created by calls of the form \code{new("dsparseModelMatrix", x, assign, contrast)}, where \code{x} is a \code{\linkS4class{dgCMatrix}} classed object. } \section{Slots}{ The \code{"modelMatrix"} mother class contains \code{\linkS4class{Matrix}} plus two extra slots, \describe{ \item{\code{assign}:}{\code{"integer"} vector of length \code{ncol(.)}, coding the variables which make up the matrix columns, see \code{\link{model.matrix}}.} \item{\code{contrasts}:}{a named \code{\link{list}} of \code{\link{contrasts}}, as in \code{\link{model.matrix}()}.} \item{\code{Dim}:}{integer vector of length two with the matrix dimensions.} \item{\code{Dimnames}:}{list of length two, the \code{\link{dimnames}(.)} of the matrix.} } whereas the (current only) actual classes \code{"d*ModelMatrix"}, have an at least an additional (\code{\link{numeric}} slot \code{"x"}. E.g., "dsparseModelMatrix" has the additional slots \describe{ \item{\code{i},\code{p}:}{row number and \dQuote{pointer} integer vectors, see class \code{"\linkS4class{dgCMatrix}"}.} \item{\code{x}:}{\code{"numeric"} vector of non-zero entries.} \item{\code{factors}:}{a (possibly empty) \code{\link{list}} of factorizations.} } } \section{Extends}{ \code{"dsparseModelMatrix"} extends class \code{"\linkS4class{dgCMatrix}"} directly,\cr \code{"ddenseModelMatrix"} extends class \code{"\linkS4class{dgeMatrix}"} directly. } \section{Methods}{ \describe{ \item{show}{\code{signature(object = "modelMatrix")}: \code{\link{show}(.)} the matrix, but also the \code{assign} and \code{contrasts} slots.} \item{print}{\code{signature(x = "modelMatrix")}: as \code{show()}, however (via \code{\dots}) allowing to pass further arguments for printing the matrix.% notably those of (currently hidden !!) % \code{\link{printSpMatrix}()}. } } } \author{Martin Maechler} \seealso{ \code{\link{sparse.model.matrix}} will return a \code{"dsparseModelMatrix"} object. \code{\link{model.Matrix}} which is a simple wrapper around the traditional \code{\link{model.matrix}} and returns a \code{"ddenseModelMatrix"} object. } \examples{ showClass("modelMatrix") showClass("dsparseModelMatrix") ## see example(model.Matrix) } \keyword{classes} MatrixModels/man/solveCoef.Rd0000644000176200001440000000153111430021131015633 0ustar liggesusers\name{solveCoef} \title{Solve for the Coefficients or Coefficient Increment} \alias{solveCoef} \alias{solveCoef-methods} \alias{solveCoef,dPredModule-method} \alias{solveCoef,sPredModule-method} \usage{ solveCoef(predM, \dots) } \arguments{ \item{predM}{prediction module, i.e. from class \code{\linkS4class{predModule}}.} \item{\dots}{potentially further arguments used in methods; not used currently.} } \description{ The squared length of the intermediate solution is attached as an attribute of the returned value. } \value{coefficient vector or increment of coef.~vector.} % \details{ % } % \references{ % } % \seealso{ % } \section{Methods}{ \describe{ \item{\code{signature(predM = "dPredModule")}}{ .. } \item{\code{signature(predM = "sPredModule")}}{ .. } } } \examples{ ## TODO } \keyword{regression} \keyword{methods} MatrixModels/man/updateWts.Rd0000644000176200001440000000145111430021131015667 0ustar liggesusers\name{updateWts} \title{Update the Residual and X Weights - Generic and Methods} \alias{updateWts} \alias{updateWts-methods} \alias{updateWts,glmRespMod-method} \alias{updateWts,respModule-method} \usage{ updateWts(respM, \dots) } \arguments{ \item{respM}{a response module, see the \code{\linkS4class{respModule}} class.} \item{\dots}{potentially further arguments used in methods; not used currently.} } \description{Update the residual weights \code{sqrtrwt} and \eqn{X} weights \code{sqrtXwt}. } \section{Methods}{ \describe{ \item{\code{signature(respM = "glmRespMod")}}{ .. } \item{\code{signature(respM = "respModule")}}{ .. } } } % \details{ % } \value{updated response module. } % \references{ % } % \seealso{ % } \examples{ ## TODO } \keyword{regression} \keyword{methods} MatrixModels/man/Model-class.Rd0000644000176200001440000000311011703574015016065 0ustar liggesusers%% "FIXME" --- move this to stats4 \name{Model-class} \title{Mother Class "Model" of all S4 Models} \docType{class} \alias{Model-class} \alias{formula,Model-method} \alias{update,Model-method} \description{ Class \code{"Model"} is meant to be the mother class of all (S4) model classes. As some useful methods are already defined for \code{"Model"} objects, derived classes inherit those \dQuote{for free}. } \section{Objects from the Class}{A virtual Class: No objects may be created from it.} \section{Slots}{ \describe{ \item{\code{call}:}{the \code{\link{call}} which generated the model.} \item{\code{fitProps}:}{a \code{\link{list}}; must be named, i.e., have unique \code{\link{names}}, but can be empty. When the main object is a \emph{fitted} model, the list will typically have components such as \code{iter} (non-negative integer) and \code{convergenece} (\code{\link{logical}} typically). } } } \section{Methods}{ \describe{ \item{formula}{\code{signature(x = "Model")}: extract the model formula - if there is one, or \code{\link{NULL}}.} \item{update}{\code{signature(object = "Model")}: Update the model with a new formula, new data, \dots\dots etc. This semantically equivalent (and as \R function almost identical) to the standard \code{\link[stats]{update}} (package \pkg{stats}).} } } \seealso{% as this will move to 'stats4': the \code{\link[MatrixModels:glpModel-class]{glpModel}} class in package \pkg{MatrixModels} which extends this class. } \examples{ showClass("Model") } \keyword{classes} MatrixModels/man/reweightPred.Rd0000644000176200001440000000205611430021131016342 0ustar liggesusers\name{reweightPred} \title{Reweight Prediction Module Structure Internals} \alias{reweightPred} \alias{reweightPred-methods} \alias{reweightPred,dPredModule,matrix,numeric-method} \alias{reweightPred,sPredModule,matrix,numeric-method} \usage{ reweightPred(predM, sqrtXwt, wtres, \dots) } \arguments{ \item{predM}{a predictor module} \item{sqrtXwt}{the sqrtXwt matrix} \item{wtres}{the vector of weighted residuals} \item{\dots}{potentially further arguments used in methods; not used currently.} } \description{Update any internal structures associated with sqrtXwt and the weighted residuals. The "V" matrix is evaluated from X using the sqrtXwt matrix and a Vtr vector is calculated. } \value{updated predM} % \details{ % } % \references{ % } % \seealso{ % } \section{Methods}{ \describe{ \item{\code{signature(predM = "dPredModule", sqrtXwt = "matrix", wtres = "numeric")}}{ .. } \item{\code{signature(predM = "sPredModule", sqrtXwt = "matrix", wtres = "numeric")}}{ .. } } } \examples{ ## TODO } \keyword{regression} \keyword{methods} MatrixModels/man/glm4.Rd0000644000176200001440000001521512311667457014607 0ustar liggesusers\name{glm4} \alias{glm4} \title{Fitting Generalized Linear Models (using S4)} \description{ \code{glm4}, very similarly as standard \R's \code{\link{glm}()} is used to fit generalized linear models, specified by giving a symbolic description of the linear predictor and a description of the error distribution. It is more general, as it fits linear, generalized linear, non-linear and generalized nonlinear models. } \usage{ glm4(formula, family, data, weights, subset, na.action, start = NULL, etastart, mustart, offset, sparse = FALSE, drop.unused.levels = FALSE, doFit = TRUE, control = list(\dots), model = TRUE, x = FALSE, y = TRUE, contrasts = NULL, \dots) } \arguments{%% much cut & pasted from glm.Rd : \item{formula}{an object of class \code{"\link{formula}"} (or one that can be coerced to that class): a symbolic description of the model to be fitted. The details of model specification are given under \sQuote{Details}.} \item{family}{a description of the error distribution and link function to be used in the model. This can be a character string naming a family function, a family function or the result of a call to a family function. (See \code{\link{family}} for details of family functions.)} \item{data}{an optional data frame, list or environment (or object coercible by \code{\link{as.data.frame}} to a data frame) containing the variables in the model. If not found in \code{data}, the variables are taken from \code{environment(formula)}, typically the environment from which \code{glm} is called.} \item{weights}{an optional vector of \sQuote{prior weights} to be used in the fitting process. Should be \code{NULL} or a numeric vector.} \item{subset}{an optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{a function which indicates what should happen when the data contain \code{NA}s. The default is set by the \code{na.action} setting of \code{\link{options}}, and is \code{\link{na.fail}} if that is unset. The \sQuote{factory-fresh} default is \code{\link{na.omit}}. Another possible value is \code{NULL}, no action. Value \code{\link{na.exclude}} can be useful.} \item{start, etastart, mustart}{ starting values for the parameters in the linear predictor, the predictor itself and for the vector of means.} \item{offset}{this can be used to specify an \emph{a priori} known component to be included in the linear predictor during fitting. This should be \code{NULL} or a numeric vector of length equal to the number of cases. One or more \code{\link{offset}} terms can be included in the formula instead or as well, and if more than one is specified their sum is used. See \code{\link{model.offset}}.} \item{sparse}{logical indicating if the model matrix should be sparse or not.} \item{drop.unused.levels}{used only when \code{sparse} is TRUE: Should factors have unused levels dropped? (This used to be true, \emph{implicitly} in the first versions up to July 2010; the default has been changed for compatibility with \R's standard (dense) \code{\link{model.matrix}()}. } \item{doFit}{logical indicating if the model should be fitted (or just returned unfitted).} \item{control}{ a list with options on fitting; currently passed unchanged to (hidden) function \code{IRLS()}.} \item{model, x, y}{currently ignored; here for back compatibility with \code{\link{glm}}.} \item{contrasts}{currently ignored}%--- FIXME \item{\dots}{potentially arguments passed on to fitter functions; not used currently.} } % \details{ % ............... % } \value{ an object of class \code{\linkS4class{glpModel}}. } % \references{ % } \seealso{ \code{\link{glm}()} the standard \R function;\cr \code{\link{lm.fit.sparse}()} a sparse least squares fitter. The resulting class \code{\linkS4class{glpModel}} documentation. } \examples{ ### All the following is very experimental -- and probably will change: ------- data(CO2, package="datasets") ## dense linear model str(glm4(uptake ~ 0 + Type*Treatment, data=CO2, doFit = FALSE), 4) ## sparse linear model str(glm4(uptake ~ 0 + Type*Treatment, data=CO2, doFit = FALSE, sparse = TRUE), 4) ## From example(glm): ----------------- ## Dobson (1990) Page 93: Randomized Controlled Trial : str(trial <- data.frame(counts=c(18,17,15,20,10,20,25,13,12), outcome=gl(3,1,9,labels=LETTERS[1:3]), treatment=gl(3,3,labels=letters[1:3]))) glm.D93 <- glm(counts ~ outcome + treatment, family=poisson, data=trial) summary(glm.D93) c.glm <- unname(coef(glm.D93)) glmM <- glm4(counts ~ outcome + treatment, family = poisson, data=trial) glmM2 <- update(glmM, quick = FALSE) # slightly more accurate glmM3 <- update(glmM, quick = FALSE, finalUpdate = TRUE) # finalUpdate has no effect on 'coef' stopifnot( identical(glmM2@pred@coef, glmM3@pred@coef), all.equal(glmM @pred@coef, c.glm, tolerance=1e-7), all.equal(glmM2@pred@coef, c.glm, tolerance=1e-12)) \dontshow{ All.eq <- function(x,y, ...) all.equal(x,y, tolerance= 1e-12, ...) stopifnot( ## ensure typos are *caught* : inherits(try(glm4(counts ~ outcome + treatment, family=poisson, data=trial, fooBar = FALSE)), "try-error"), ## check formula(.): {environments differ - FIXME?} formula(glmM) == formula(glm.D93), identical(coef(glmM2), coefficients(glmM3)), All.eq (coef(glmM2), coefficients(glm.D93)), identical(fitted.values(glmM2), fitted(glmM3)), All.eq (residuals(glmM2), resid(glm.D93), check.attributes=FALSE),# names()% FIXME ?? identical(residuals(glmM2), resid(glmM3)) ) } ## Watch the iterations --- and use no intercept --> more sparse X ## 1) dense generalized linear model glmM <- glm4(counts ~ 0+outcome + treatment, poisson, trial, verbose = TRUE) ## 2) sparse generalized linear model glmS <- glm4(counts ~ 0+outcome + treatment, poisson, trial, verbose = TRUE, sparse = TRUE) str(glmS, max.lev = 4) stopifnot( all.equal(glmM@pred@coef, glmS@pred@coef), all.equal(glmM@pred@Vtr, glmS@pred@Vtr) ) ## A Gamma example, from McCullagh & Nelder (1989, pp. 300-2) clotting <- data.frame(u = c(5,10,15,20,30,40,60,80,100), lot1 = c(118,58,42,35,27,25,21,19,18), lot2 = c(69,35,26,21,18,16,13,12,12)) str(gMN <- glm4(lot1 ~ log(u), data=clotting, family=Gamma, verbose=TRUE)) glm. <- glm(lot1 ~ log(u), data=clotting, family=Gamma) stopifnot( all.equal(gMN@pred@coef, unname(coef(glm.)), tolerance=1e-7) ) } \keyword{models} \keyword{regression} MatrixModels/man/mkRespMod.Rd0000644000176200001440000000325611423257032015632 0ustar liggesusers\name{mkRespMod} \alias{mkRespMod} \title{Create a respModule object} \description{ Create a \code{\linkS4class{respModule}} object, which could be from a derived class such as \code{\linkS4class{glmRespMod}} or \code{\linkS4class{nlsRespMod}}. } \usage{ mkRespMod(fr, family = NULL, nlenv = NULL, nlmod = NULL) } \arguments{ \item{fr}{ a model frame, usually created by a call to \code{\link{model.frame}}.} \item{family}{ an optional glm \code{\link{family}} object (\code{\linkS4class{glmRespMod}} objects only).} \item{nlenv}{ an environment for evaluation of the nonlinear model, \code{nlmod}. (\code{\linkS4class{nlsRespMod}} objects only).} \item{nlmod}{ the nonlinear model function, as a function call (\code{\linkS4class{nlsRespMod}} objects only).} } \details{ The internal representation of a statistical model based on a linear predictor expression is derived from a \code{\link{formula}} expression and a \code{data} argument, possibly supplemented with a \code{\link{family}} object and/or a nonlinear model expression. The steps to obtain this representation usually involve calls to \code{\link{model.frame}} and to \code{\link{model.matrix}} or \code{\link{model.Matrix}}, which encapsulate important parts of this process. This function encapsulates other operations related to weights and offsets and to the model family to create a \code{\linkS4class{respModule}} object. } \value{ an object of a class inheriting from \code{\linkS4class{respModule}}. } %\references{} %\author{Doug Bates} \seealso{ The \code{\linkS4class{respModule}} class description. } \examples{ ## see help("glpModel-class") } \keyword{models} MatrixModels/man/resid-et-al.Rd0000644000176200001440000000231511430210707016026 0ustar liggesusers%% FIXME: move to stats4 \name{resid-et-al} \title{Aliases for Model Extractors} \alias{resid,ANY-method} \alias{fitted.values,ANY-method} \alias{coefficients,ANY-method} \description{ Aliases for model extractors; it is an old S and \R tradition to have aliases for these three model extractor functions: \describe{ \item{\code{resid()}}{equivalent to \code{\link{residuals}()}.} \item{\code{fitted.values()}}{equivalent to \code{\link{fitted}()}.} \item{\code{coefficients()}}{equivalent to \code{\link{coef}()}.} } We provide S4 generics and methods for these. } \seealso{ \code{\link{residuals}}; \code{\link{Methods}} for general information about formal (S4) methods. } \section{Methods}{ \describe{ \item{resid}{\code{signature(object = "ANY")}: return the residuals; this is a rarely used \emph{alias} for \code{\link{residuals}()}.} \item{fitted.values}{\code{signature(object = "ANY")}: return the fitted values; this is a rarely used \emph{alias} for \code{\link{fitted}()}.} \item{coefficients}{\code{signature(object = "ANY")}: return the coefficients of a model; this is a rarely used \emph{alias} for \code{\link{coef}()}.} } } \keyword{models} MatrixModels/man/lm.fit.sparse.Rd0000644000176200001440000001021612455202672016416 0ustar liggesusers\name{lm.fit.sparse} \alias{lm.fit.sparse} \title{Fitter Function for Sparse Linear Models} \description{ A basic computing engine for sparse linear least squares regression. Note that the exact interface (arguments, return value) currently is \bold{experimental}, and is bound to change. Use at your own risk! } \usage{ lm.fit.sparse(x, y, w = NULL, offset = NULL, method = c("qr", "cholesky"), tol = 1e-7, singular.ok = TRUE, order = NULL, transpose = FALSE) } \arguments{ \item{x}{\emph{sparse} design matrix of dimension \code{n * p}, i.e., an \R object of a \code{\link{class}} extending \code{\linkS4class{dsparseMatrix}}; typically the result of \code{\link{sparse.model.matrix}}.} \item{y}{vector of observations of length \code{n}, or a matrix with \code{n} rows.} \item{w}{vector of weights (length \code{n}) to be used in the fitting process. Weighted least squares is used with weights \code{w}, i.e., \code{sum(w * e^2)} is minimized. \bold{Not yet implemented !} } \item{offset}{numeric of length \code{n}). This can be used to specify an \emph{a priori} known component to be included in the linear predictor during fitting.} \item{method}{a character string specifying the (factorization) method. Currently, \code{"qr"} or \code{"cholesky"}.} \item{tol}{[for back-compatibility only; unused:] tolerance for the \code{\link{qr}} decomposition. Default is 1e-7.} \item{singular.ok}{[for back-compatibility only; unused:] logical. If \code{FALSE}, a singular model is an error.} \item{order}{integer or \code{NULL}, for \code{method == "qr"}, will determine how the fill-reducing ordering (aka permutation) for the \dQuote{symbolic} part is determined (in \code{cs_amd()}), with the options {0: natural}, {1: Chol}, {2: LU}, and {3: QR}, where \code{3} is the default.} \item{transpose}{ logical; if true, use the transposed matrix \code{t(x)} instead of \code{x}. } } % \details{ % %% ~~ If necessary, more details than the description above ~~ % } \value{ Either a single numeric vector or a list of four numeric vectors. } \seealso{ \code{\link{glm4}} is an alternative (much) more general fitting function. \code{\link{sparse.model.matrix}} from the \pkg{Matrix} package; the non-sparse function in standard \R's package \pkg{stats}: \code{\link{lm.fit}()}. } \examples{ dd <- expand.grid(a = as.factor(1:3), b = as.factor(1:4), c = as.factor(1:2), d= as.factor(1:8)) n <- nrow(dd <- dd[rep(seq_len(nrow(dd)), each = 10), ]) set.seed(17) dM <- cbind(dd, x = round(rnorm(n), 1)) ## randomly drop some n <- nrow(dM <- dM[- sample(n, 50),]) dM <- within(dM, { A <- c(2,5,10)[a] B <- c(-10,-1, 3:4)[b] C <- c(-8,8)[c] D <- c(10*(-5:-2), 20*c(0, 3:5))[d] Y <- A + B + A*B + C + D + A*D + C*x + rnorm(n)/10 wts <- sample(1:10, n, replace=TRUE) rm(A,B,C,D) }) str(dM) # 1870 x 7 X <- Matrix::sparse.model.matrix( ~ (a+b+c+d)^2 + c*x, data = dM) dim(X) # 1870 x 69 X[1:10, 1:20] ## For now, use 'MatrixModels:::' --- TODO : export once interface is clear! Xd <- as(X,"matrix") system.time(fmDense <- lm.fit(Xd, y = dM[,"Y"])) system.time( r1 <- MatrixModels:::lm.fit.sparse(X, y = dM[,"Y"]) ) # *is* faster stopifnot(all.equal(r1, unname(fmDense$coeff), tolerance = 1e-12)) system.time( r2 <- MatrixModels:::lm.fit.sparse(X, y = dM[,"Y"], method = "chol") ) stopifnot(all.equal(r1, r2$coef, tolerance = 1e-12), all.equal(fmDense$residuals, r2$residuals, tolerance=1e-9) ) ## with weights: system.time(fmD.w <- with(dM, lm.wfit(Xd, Y, w = wts))) system.time(fm.w1 <- with(dM, MatrixModels:::lm.fit.sparse(X, Y, w = wts))) system.time(fm.w2 <- with(dM, MatrixModels:::lm.fit.sparse(X, Y, w = wts, method = "chol") )) stopifnot(all.equal(fm.w1, unname(fmD.w$coeff), tolerance = 1e-12), all.equal(fm.w2$coef, fm.w1, tolerance = 1e-12), all.equal(fmD.w$residuals, fm.w2$residuals, tolerance=1e-9) ) } \keyword{regression} \keyword{array} MatrixModels/man/updateMu.Rd0000644000176200001440000000307311430021131015475 0ustar liggesusers\name{updateMu} \title{Update 'mu', the Fitted Mean Response} \alias{updateMu} \alias{updateMu-methods} \alias{updateMu,glmRespMod,numeric-method} \alias{updateMu,nglmRespMod,numeric-method} \alias{updateMu,nlsRespMod,numeric-method} \alias{updateMu,respModule,numeric-method} \usage{ updateMu(respM, gamma, \dots) } \arguments{ \item{respM}{a response module, see the \code{\linkS4class{respModule}} class.} \item{gamma}{the value of the linear predictor before adding the offset} \item{\dots}{potentially further arguments used in methods; not used currently.} } \description{ Updates the mean vector \eqn{\mu} given the linear predictor \eqn{\gamma}. Evaluate the residuals and the weighted sum of squared residuals. } \details{ Note that the offset is added to the linear predictor before calculating mu. The sqrtXwt matrix can be updated but the sqrtrwt should not be in that the weighted sum of squared residuals should be calculated relative to fixed weights. Reweighting is done in a separate call. } \value{updated \code{respM}} \section{Methods}{ \describe{ \item{\code{signature(respM = "glmRespMod", gamma = "numeric")}}{ .. } \item{\code{signature(respM = "nglmRespMod", gamma = "numeric")}}{ .. } \item{\code{signature(respM = "nlsRespMod", gamma = "numeric")}}{ .. } \item{\code{signature(respM = "respModule", gamma = "numeric")}}{ .. } } } % \references{ % } \seealso{ The \code{\linkS4class{respModule}} class (and specific subclasses); \code{\link{glm4}}. } \examples{ ## TODO } \keyword{regression} \keyword{methods} MatrixModels/man/predModule-class.Rd0000644000176200001440000000535511423257032017136 0ustar liggesusers\name{predModule-class} \Rdversion{1.1} %%________ FIXME _______ rename class to "linPredModule" %%________ ===== _______ as they are about *linear* pred. really \title{Class "predModule" and SubClasses} \docType{class} \alias{predModule-class} \alias{dPredModule-class} \alias{sPredModule-class} % \alias{coerce,ddenseModelMatrix,predModule-method} \alias{coerce,dsparseModelMatrix,predModule-method} \description{ The class \code{"predModule"} and notably its subclasses \code{"dPredModule"} and \code{"sPredModule"} encapsulate information about linear predictors in statistical models. They incorporate a \code{\linkS4class{modelMatrix}}, the corresponding coefficients and a representation of a triangular factor from the, possibly weighted or otherwise modified, model matrix. } \section{Objects from the Classes}{ Objects are typically created by coercion from objects of class \code{\linkS4class{ddenseModelMatrix}} or \code{\linkS4class{dsparseModelMatrix}}. } \section{Slots}{ The virtual class \code{"predModule"} and its two subclasses all have slots \describe{ \item{\code{X}:}{a \code{\linkS4class{modelMatrix}}.} \item{\code{coef}:}{\code{"numeric"} coefficient vector of length \code{ncol(.)}\eqn{:= p}.} \item{\code{Vtr}:}{\code{"numeric"} vector of length \eqn{p}, to contain \eqn{V'r} (\dQuote{\bold{V} \bold{t}ransposed \bold{r}}).} \item{\code{fac}:}{a representation of a triangular factor, the Cholesky decomposition of \eqn{V'V}.}% << FIXME? (weights !) } The actual classes \code{"dPredModule"} and \code{"sPredModule"} specify specific (sub) classes for the two non-trivial slots, \describe{ \item{\code{X}:}{a \code{"\linkS4class{ddenseModelMatrix}"} or \code{"\linkS4class{dsparseModelMatrix}"}, respectively.} \item{\code{fac}:}{For the \code{"dpredModule"} class this factor is a \code{\linkS4class{Cholesky}} object. For the \code{"spredModule"} class it is of class \code{\linkS4class{CHMfactor}}.} } } \section{Methods}{ \describe{ \item{coerce}{\code{signature(from = "ddenseModelMatrix", to = "predModule")}: Creates a \code{"dPredModule"} object.} \item{coerce}{\code{signature(from = "dsparseModelMatrix", to = "predModule")}: Creates an \code{"sPredModule"} object.} } } \author{Douglas Bates} \seealso{ \code{\link{model.Matrix}()} which returns a \code{"\linkS4class{ddenseModelMatrix}"} or \code{"\linkS4class{dsparseModelMatrix}"} object, depending if its \code{sparse} argument is false or true. In both cases, the resulting \code{"modelMatrix"} can then be coerced to a sparse or dense \code{"predModule"}. } \examples{ showClass("dPredModule") showClass("sPredModule") ## see example(model.Matrix) } \keyword{classes} MatrixModels/man/model.Matrix.Rd0000644000176200001440000000605712455202672016304 0ustar liggesusers\name{model.Matrix} \alias{model.Matrix} %% Cut and paste a lot from the "standard" model.matrix() help page, %% <--> ~/R/D/r-devel/R/src/library/stats/man/model.matrix.Rd \title{Construct Possibly Sparse Design or Model Matrices} \description{ \code{model.Matrix} creates design matrix, very much like the standard \R function \code{\link{model.matrix}}, however returning a dense or sparse object of class \code{\linkS4class{modelMatrix}}. } \usage{ model.Matrix(object, data = environment(object), contrasts.arg = NULL, xlev = NULL, sparse = FALSE, drop.unused.levels = FALSE, \dots) } \arguments{ \item{object}{an object of an appropriate class. For the default method, a model \link{formula} or a \code{\link{terms}} object.} \item{data}{a data frame created with \code{\link{model.frame}}. If another sort of object, \code{model.frame} is called first.} \item{contrasts.arg}{A list, whose entries are values (numeric matrices or character strings naming functions) to be used as replacement values for the \code{\link{contrasts}} replacement function and whose names are the names of columns of \code{data} containing \code{\link{factor}}s.} \item{xlev}{to be used as argument of \code{\link{model.frame}} if \code{data} has no \code{"terms"} attribute.} \item{sparse}{logical indicating if the result should be sparse (of class \code{\linkS4class{sparseModelMatrix}}), using \code{\link{sparse.model.matrix}()} (package \pkg{Matrix}).} \item{drop.unused.levels}{used only when \code{sparse} is TRUE: Should factors have unused levels dropped? (This used to be true, \emph{implicitly} in the first versions up to July 2010; the default has been changed for compatibility with \R's standard (dense) \code{\link{model.matrix}()}. } \item{\dots}{further arguments passed to or from other methods.} } \details{ \code{model.Matrix()} is a simple wrapper either (\code{sparse = FALSE}) around the traditional \code{\link{model.matrix}()} returning a \code{"\linkS4class{ddenseModelMatrix}"}, or (\code{sparse = TRUE}) around \code{\link{sparse.model.matrix}()}, returning a \code{"\linkS4class{dsparseModelMatrix}"} object. \code{model.Matrix} creates a design matrix from the description given in \code{terms(object)}, using the data in \code{data} which must supply variables with the same names as would be created by a call to \code{model.frame(object)} or, more precisely, by evaluating \code{attr(terms(object), "variables")}. For more details, see \code{\link{model.matrix}}. } \value{ an object inheriting from class \code{\linkS4class{modelMatrix}}, by default, \code{\linkS4class{ddenseModelMatrix}}. } % \author{Martin Maechler} \seealso{ \code{\link[stats]{model.matrix}}, \code{\link{sparse.model.matrix}}. } \examples{ data(CO2, package="datasets") class(sm <- model.Matrix(~ 0+Type*Treatment, data=CO2, sparse=TRUE)) class(dm <- model.Matrix(~ 0+Type*Treatment, data=CO2, sparse=FALSE)) stopifnot(dim(sm) == c(84,4), dim(sm) == dim(dm), all(sm == dm)) } \keyword{models}