Commit ea0e2b60 by Dirk Eddelbuettel

### Import Upstream version 1.3-28

parent bb0260c9
 Package: mgcv Version: 1.3-27 Version: 1.3-28 Author: Simon Wood Maintainer: Simon Wood Title: GAMs with GCV smoothness estimation and GAMMs by REML/PQL Description: Routines for GAMs and other generalized ridge regression with multiple smoothing parameter selection by GCV or UBRE. Also GAMMs by REML or PQL. Includes a gam() function. with multiple smoothing parameter selection by GCV or UBRE/AIC. Also GAMMs by REML or PQL. Includes a gam() function. Priority: recommended Depends: R (>= 2.3.0) Imports: graphics, stats Suggests: nlme (>= 3.1-64), MASS (>= 7.2-2) LazyLoad: yes License: GPL version 2 or later Packaged: Wed Sep 26 22:48:19 2007; simon Packaged: Wed Oct 10 10:43:12 2007; simon
 ... ... @@ -848,14 +848,14 @@ extract.lme.cov<-function(b,data,start.level=1) formXtViX <- function(V,X) ## forms X'V^{-1}X as efficiently as possible given the structure of ## V (diagonal, block-diagonal, full) { X <- X[V$ind,] # have to re-order X according to V ordering { X <- X[V$ind,,drop=FALSE] # have to re-order X according to V ordering if (is.list(V$V)) { ### block diagonal case Z <- X j0<-1 for (i in 1:length(V$V)) { Cv <- chol(V$V[[i]]) j1 <- j0+nrow(V$V[[i]])-1 Z[j0:j1,]<-backsolve(Cv,as.matrix(X[j0:j1,]),transpose=TRUE) Z[j0:j1,]<-backsolve(Cv,X[j0:j1,,drop=FALSE],transpose=TRUE) j0 <- j1 + 1 } res <- t(Z)%*%Z ... ... @@ -883,6 +883,69 @@ new.name <- function(proposed,old.names) prop } gammPQL <- function (fixed, random, family, data, correlation, weights, control, niter = 30, verbose = TRUE, ...) ## service routine for gamm' to do PQL fitting. Based on glmmPQL ## from the MASS library (Venables & Ripley). In particular, for back ## compatibility the numerical results should be identical with gamm ## fits by glmmPQL calls. Because gamm' already does some of the ## preliminary stuff that glmmPQL does, gammPQL can be simpler. It also ## deals with the possibility of the original data frame containing ## variables called zz' wts' or invwt' { off <- model.offset(data) if (is.null(off)) off <- 0 wts <- weights if (is.null(wts)) wts <- rep(1, nrow(data)) wts.name <- new.name("wts",names(data)) ## avoid overwriting what's already in data' data[[wts.name]] <- wts fit0 <- NULL ## keep checking tools happy ## initial fit (might be better replaced with gam' call) eval(parse(text=paste("fit0 <- glm(formula = fixed, family = family, data = data,", "weights =",wts.name,",...)"))) w <- fit0$prior.weights eta <- fit0$linear.predictors zz <- eta + fit0$residuals - off wz <- fit0$weights fam <- family ## find non clashing name for pseudodata and insert in formula zz.name <- new.name("zz",names(data)) eval(parse(text=paste("fixed[[2]] <- quote(",zz.name,")"))) data[[zz.name]] <- zz ## pseudodata to data' ## find non-clashing name fro inverse weights, and make ## varFixed formula using it... invwt.name <- new.name("invwt",names(data)) data[[invwt.name]] <- 1/wz w.formula <- as.formula(paste("~",invwt.name,sep="")) for (i in 1:niter) { if (verbose) message("iteration ", i) fit<-lme(fixed=fixed,random=random,data=data,correlation=correlation, control=control,weights=varFixed(w.formula),method="ML",...) etaold <- eta eta <- fitted(fit) + off if (sum((eta - etaold)^2) < 1e-06 * sum(eta^2)) break mu <- fam$linkinv(eta) mu.eta.val <- fam$mu.eta(eta) ## get pseudodata and insert in data' data[[zz.name]] <- eta + (fit0$y - mu)/mu.eta.val - off wz <- w * mu.eta.val^2/fam$variance(mu) data[[invwt.name]] <- 1/wz } ## end i in 1:niter fit } gamm <- function(formula,random=NULL,correlation=NULL,family=gaussian(),data=list(),weights=NULL, subset=NULL,na.action,knots=NULL,control=nlme::lmeControl(niterEM=0,optimMethod="L-BFGS-B"), ... ... @@ -896,7 +959,7 @@ gamm <- function(formula,random=NULL,correlation=NULL,family=gaussian(),data=lis # NOTE: need to fill out the gam object properly { if (!require("nlme")) stop("gamm() requires package nlme to be installed") if (!require("MASS")) stop("gamm() requires package MASS to be installed") # if (!require("MASS")) stop("gamm() requires package MASS to be installed") # check that random is a named list if (!is.null(random)) { if (is.list(random)) ... ... @@ -1001,7 +1064,8 @@ gamm <- function(formula,random=NULL,correlation=NULL,family=gaussian(),data=lis if (lme.used) { ## following construction is a work-around for problem in nlme 3-1.52 eval(parse(text=paste("ret$lme<-lme(",deparse(fixed.formula), ",random=rand,data=strip.offset(mf),correlation=correlation,control=control,weights=weights,method=method)" ",random=rand,data=strip.offset(mf),correlation=correlation,", "control=control,weights=weights,method=method)" ,sep="" ))) ##ret$lme<-lme(fixed.formula,random=rand,data=mf,correlation=correlation,control=control) } else ... ... @@ -1009,8 +1073,9 @@ gamm <- function(formula,random=NULL,correlation=NULL,family=gaussian(),data=lis if (inherits(weights,"varFunc")) stop("weights must be like glm weights for generalized case") if (verbosePQL) cat("\n Maximum number of PQL iterations: ",niterPQL,"\n") eval(parse(text=paste("ret$lme<-glmmPQL(",deparse(fixed.formula), ",random=rand,data=strip.offset(mf),family=family,correlation=correlation,control=control,", eval(parse(text=paste("ret$lme<-gammPQL(",deparse(fixed.formula), ",random=rand,data=strip.offset(mf),family=family,", "correlation=correlation,control=control,", "weights=weights,niter=niterPQL,verbose=verbosePQL)",sep=""))) ##ret$lme<-glmmPQL(fixed.formula,random=rand,data=mf,family=family,correlation=correlation, ... ... @@ -1069,9 +1134,6 @@ gamm <- function(formula,random=NULL,correlation=NULL,family=gaussian(),data=lis V<-extract.lme.cov2(ret$lme,mf,n.sr+1) # the data covariance matrix, excluding smooths XVX <- formXtViX(V,G$Xf) # Cv<-chol(V) # X<-G$Xf # Z<-backsolve(Cv,X,transpose=TRUE) S<-matrix(0,ncol(G$Xf),ncol(G$Xf)) # penalty matrix first <- G$nsdf+1 k <- 1 ... ... @@ -1089,7 +1151,6 @@ gamm <- function(formula,random=NULL,correlation=NULL,family=gaussian(),data=lis first <- last + 1 } S<-S/ret$lme$sigma^2 # X'V^{-1}X divided by \sigma^2, so should S be # Z<-t(Z)%*%Z # X'V^{-1}X # this was XVX Vb <- chol2inv(chol(XVX+S)) # covariance matrix - in constraint space # need to project out of constraint space Vp <- matrix(Vb[1:G$nsdf,],G$nsdf,ncol(Vb)) ... ...  ... ... @@ -747,6 +747,7 @@ gam <- function(formula,family=gaussian(),data=list(),weights=NULL,subset=NULL,n } else ## do performance iteration.... object<-gam.fit(G,family=G$family,control=control,gamma=gamma,fixedSteps=fixedSteps,...) # fill returned s.p. array with estimated and supplied terms temp.sp<-object$sp object$sp<-G$all.sp ... ... @@ -772,6 +773,21 @@ gam <- function(formula,family=gaussian(),data=list(),weights=NULL,subset=NULL,n temp.sp <- G$all.sp temp.sp[G$all.sp<0] <- object$sp # copy estimated sp's into whole vector object$sp <- temp.sp # correct object sp vector } else { ## check for all fixed sp case ... if (!G$am && (method$gam=="perf.outer"||method$gam=="outer")) { ## need to fix up GCV/UBRE score if (G$sig2>0) {criterion <- "UBRE";scale <- G$sig2} else { criterion <- method$gcv;scale <- -1} if (criterion=="UBRE") object$gcv.ubre <- object$deviance/G$n - scale + 2 * gamma * scale* sum(object$edf)/G$n else if (criterion=="deviance") object$gcv.ubre <- G$n * object$deviance/(G$n-sum(object$edf))^2 else if (criterion=="GACV") { P <- sum(object$weights*object$residuals^2) tau <- sum(object$edf) object$gcv.ubre <- object$deviance/G$n + 2 * gamma*tau * P / (G$n*(G\$n-tau)) } } } ## correct null deviance if there's an offset .... ... ...
 1.3-28 * gamm' modified to call a routine gammPQL' in place of MASS::glmmPQL. This avoids some duplication, and facilitates maintainance. * Bug fix in formXtViX' where matrix dimensions got dropped when subsetting thereby messing up variance calculations for gamm fits in which some group sizes were 1. 1.3-27 * Fix of nasty bug in large dataset handling with "tp" basis. Subsampling code was re-seeding RNG instead of intended behaviour of saving RNG state and restoring it. Fixed and tested. * Fix of nasty bug in large dataset handling with "tp" basis (introduced in 1.3-26). Subsampling code was re-seeding RNG instead of intended behaviour of saving RNG state and restoring it. Fixed and tested. 1.3-26 * modification to gam' so that GCV/UBRE scores reported with all fixed smoothing parameters are consistent with equivalent under s.p. estimation. * gam.fit3 modified to test for convergence of coefficients as well as penalized deviance, otherwise in extreme cases the derivative iterations can diverge. ... ...
 ... ... @@ -47,7 +47,7 @@ one of the standard families. \seealso{ \code{\link{gam.fit3}}} } \keyword{models} \keyword{regression}%-- one or more .. ... ...
 ... ... @@ -199,9 +199,10 @@ Wang, Y. (1998) Mixed effects smoothing spline analysis of variance. J.R. Statis \section{WARNINGS }{ This version of \code{gamm} works best with \code{nlme} 3.1-62 and above and R 2.2.0 and above. This is because it is designed to work with the optimizers used from these versions onwards, rather than the earlier default optimizers. \code{gamm} assumes that you know what you are doing! For example, unlike \code{glmmPQL} from \code{MASS} it will return the complete \code{lme} object from the working model at convergence of the PQL iteration, including the log likelihood', even though this is not the likelihood of the fitted GAMM. The routine will be very slow and memory intensive if correlation structures are used for the very large groups of data. e.g. attempting to run the ... ...
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!