Commit 2b1bc647 authored by Dirk Eddelbuettel's avatar Dirk Eddelbuettel

Import Upstream version 1.8-16

parent b90a627e
......@@ -5,6 +5,53 @@ Currently deprecated and liable to be removed:
- single penalty tensor product smooths.
- p.type!=0 in summary.gam.
1.8-16
* slightly improved intial value heuristics for overlapping penalties in
general family case.
* 'ocat' checks that response is numeric.
* plot.gam(...,scale=-1) now changes scale according to 'trans' and 'shift'.
* newton optimizer made slightly more cautious: contracts step if reduction
in true objective too far different from reduction predicted by quadratic
approximation underlying Newton step. Also leaves parameters unchanged
in Newton step while their grad is less than 1% of max grad.
* Fix to Fisher weight computation in gam.fit4. Previously a weight could
(rarely) evaluate as negative machine prec instead of zero, get passed to
gdi2 in C code, generate a NaN when square rooted, resulting in a NaN passed
to the LAPACK dgeqp3 routine, which then hung in a non-interuptable way.
* Fix of 'sp' argument handling with multiple formulae. Allocation to terms
could be incorrect.
* Option 'edge.correct' added to 'gam.control' to allow better correction
of edge of smoothing parameter space effects with 'gam' when RE/ML used.
* Fix to setting of penalty rank in smooth.construct.mrf.smooth.spec.
Previously this was wrong, which could cause failure with gamm if the
penalty was rank deficient. Thanks Paul Buerkner.
* Fix to Vb.corr call from gam.fit3.post.proc to ensure that sp not
dropped (wrongly treated as scale estimate) when P-REML or P-ML used.
Could cause failure depending on BLAS. Thanks Matteo Fasiolo.
* Fix in gam.outer that caused failure with "efs" optimizer and fixed sps.
* Fix to `get.var' to drop matrix attributes of 1 column matrix variables.
* Extra argument added to `uniquecombs' to allow result to have same row
ordering regardless of input data ordering. Now used by smooth constructors
that subsample unique covariate values during basis setup to ensure
invariance to data re-ordering.
* Correction of scaling error in spherical correlation structure GP smooth.
* qf and rd functions for binomial family fixed for zero n case.
1.8-15
* Fix of survival function prediction in cox.ph family. Code used expression
......
Package: mgcv
Version: 1.8-15
Version: 1.8-16
Author: Simon Wood <simon.wood@r-project.org>
Maintainer: Simon Wood <simon.wood@r-project.org>
Title: Mixed GAM Computation Vehicle with GCV/AIC/REML Smoothness
......@@ -16,6 +16,6 @@ LazyLoad: yes
ByteCompile: yes
License: GPL (>= 2)
NeedsCompilation: yes
Packaged: 2016-09-13 10:00:39 UTC; sw283
Packaged: 2016-11-07 10:22:00 UTC; sw283
Repository: CRAN
Date/Publication: 2016-09-14 18:51:00
Date/Publication: 2016-11-07 19:28:16
0d9b05a5c3954f23ca64d831c45daf89 *ChangeLog
992b7d6af50703c1753fe3dd458a9df3 *DESCRIPTION
a38e3e6c9f0ae98bdcf3d14127347fde *ChangeLog
e051228d6327e0b3d640616d4fa510c3 *DESCRIPTION
eb723b61539feef013de476e68b5c50a *GPL-2
595f7fa74dd678ae4be1f6968e174555 *NAMESPACE
41b51c0155f4cb0b9d746d896108c160 *R/bam.r
1aee82e17a9feb6166dbe107659029c9 *R/bam.r
87933a9e2845f871334d96f537ee11e9 *R/coxph.r
fdb1dd621eb177107bbfb5f5c11777b2 *R/efam.r
a25f5a55d9d8b4ada56ac0df3ec99a18 *R/efam.r
4b370253beb1eda19d389132ade30212 *R/fast-REML.r
dea8bcbb4668ad0a6dfe3420bebebf48 *R/gam.fit3.r
6f57e0f2cb348d07754b0e41a374e76c *R/gam.fit4.r
cb165a0a11de9686910fb27b0d6450ec *R/gam.fit3.r
7734ba62022328a50b771e721df98a72 *R/gam.fit4.r
1b620b840ca67c9759639bd6e53824e3 *R/gam.sim.r
66257913c556f135657b7c12b6ed733d *R/gamlss.r
cceac26b3d01513f8f87eacae91ddae0 *R/gamm.r
4a0ce642d904d7f871b5b766c04a2af4 *R/jagam.r
71d23c1ee219ca4242d5f49ccd164970 *R/mgcv.r
10facb791e4cfd123d183f05660119c6 *R/jagam.r
8cebce4d68d4c45d661073756ca7b202 *R/mgcv.r
2feca0dc9d354de7bc707c67a5891364 *R/misc.r
03772998ab05887f2eeae10dd6efe983 *R/mvam.r
586b0b4447aeb73b28fac9bdfefd3e21 *R/plots.r
38a7e6b503af65a76ffe999ac66049bb *R/smooth.r
5d07d6e4f75a64b6d04cda9e23278d70 *R/plots.r
cf3543d1d4b7fe6fb8576f681b345722 *R/smooth.r
666d7fd36fda68b928993d5388b0d7fc *R/soap.r
76cc875719bf0ef9eab45ea5bfeccda6 *R/sparse.r
e468195a83fab90da8e760c2c3884bd3 *data/columb.polys.rda
......@@ -58,9 +58,9 @@ e75719779e18c723ee1fd17e44e7901b *man/formXtViX.Rd
88888e966394c9f9792d9537341d053c *man/formula.gam.Rd
4da4d585b329769eb44f0c7a6e7dd554 *man/fs.test.Rd
6f405acde2d7b6f464cf45f5395113ba *man/full.score.Rd
912f575e1a6a7c9b1b94b2130fdfb38b *man/gam.Rd
0c075e9e58df199d59e77d94b712fde6 *man/gam.Rd
adaf0bd8e82d9472823cf3f3fa05e111 *man/gam.check.Rd
49de68e2abeb557b994032e4d7b5407a *man/gam.control.Rd
8931cd75ddec14d91ec94dec6ba69362 *man/gam.control.Rd
44db24b66ce63bc16d2c8bc3f5b42ac5 *man/gam.convergence.Rd
1cf5145859af2263f4e3459f40e1ab23 *man/gam.fit.Rd
4728be401da6eceb8b0c257377dc5d01 *man/gam.fit3.Rd
......@@ -97,8 +97,8 @@ df702cea24d0f92044a973b66a57e21f *man/missing.data.Rd
00ccf213c31910cd14f1df65a300eb33 *man/model.matrix.gam.Rd
2f2fdc722c5e9e58664da9378451cd4a *man/mono.con.Rd
d33914a328f645af13f5a42914ca0f35 *man/mroot.Rd
0748a44497317a19857f81bd76d162db *man/multinom.Rd
d70954045abda626a357951da5e2cbca *man/mvn.Rd
f624f3afcf4e2192e8f724d45257d983 *man/multinom.Rd
8fa6cf27db7192bbad6a2d41d2780937 *man/mvn.Rd
1064099913e539a75bf763c764bc72a1 *man/negbin.Rd
8a6a1926188511235f1e7406120c791e *man/new.name.Rd
00e39f302ab5efbe3b14265fffc16c18 *man/notExp.Rd
......@@ -114,7 +114,7 @@ ee9352ba4c531a8def16deddcab9a9fd *man/pdIdnot.Rd
b903ebcf31703db156e033fdfa527d73 *man/plot.gam.Rd
c27a6b886929b1dc83bf4b90cae848f9 *man/polys.plot.Rd
1a9d83c9fc67e5f0fc85d66d3112f4ef *man/predict.bam.Rd
2892714c395537c0cca29914989b1d50 *man/predict.gam.Rd
93f41380f769dff6a21394d80508c565 *man/predict.gam.Rd
cf14ce6cf8e4147f0f5c6e5b93b2af73 *man/print.gam.Rd
6d0ce4e574fabceffdbedd46c91364cb *man/qq.gam.Rd
22b7dcbc8ff4096365fa98ce56b957c9 *man/rTweedie.Rd
......@@ -122,7 +122,7 @@ fc1985e7dd5222182c4a8a939963b965 *man/random.effects.Rd
c523210ae95cb9aaa0aaa1c37da1a4c5 *man/residuals.gam.Rd
3c747a8066bcc28ae706ccf74f903d3e *man/rig.Rd
9f6f46f5c5da080bc82f9aa4685d364a *man/rmvn.Rd
845ec29324583d18c8dc150625e153e3 *man/s.Rd
c4be33830dfeb9e0dc766f8e5498931d *man/s.Rd
d515e51ec98d73af6166f7b31aeaba9b *man/scat.Rd
898e7cc2def2ee234475e68d0b904b29 *man/sdiag.Rd
8e968226c2b65ee89c8de2fd9869b086 *man/single.index.Rd
......@@ -149,11 +149,11 @@ b55a396da77559dac553613146633f97 *man/sp.vcov.Rd
83bd8e097711bf5bd0fff09822743d43 *man/spasm.construct.Rd
b9394812e5398ec95787c65c1325a027 *man/step.gam.Rd
f0791d830687d6155efb8a73db787401 *man/summary.gam.Rd
9ee8b9bd71f1b777ceb638fa21143cb9 *man/t2.Rd
36db3873e3e810ab6ee481f177d2535c *man/te.Rd
a0b0988dba55cca5b4b970e035e3c749 *man/t2.Rd
a27690f33b9a7bd56d9c1779c64896cc *man/te.Rd
6eebb6ef90374ee09453d6da6449ed79 *man/tensor.prod.model.matrix.Rd
f22f1cee0ff2b70628846d1d0f8e9a66 *man/trichol.Rd
c6c5fe7f6bfe07b63080248020dab331 *man/uniquecombs.Rd
94154ff18af819a7bb83919ee10db0de *man/uniquecombs.Rd
a16b3a5a4d13c705dcab8d1cd1b3347e *man/vcov.gam.Rd
281e73658c726997196727a99a4a1f9e *man/vis.gam.Rd
07a73758156dfa580c6e92edd34b0654 *man/ziP.Rd
......
......@@ -129,7 +129,7 @@ compress.df <- function(dat,m=NULL) {
names(dat0) <- names(dat)
dat <- dat0;rm(dat0)
}
xu <- uniquecombs(dat)
xu <- uniquecombs(dat,TRUE)
if (nrow(xu)>mm*mf) { ## too many unique rows to use only unique
for (i in 1:d) if (!is.factor(dat[,i])) { ## round the metric variables
xl <- range(dat[,i])
......@@ -138,7 +138,7 @@ compress.df <- function(dat,m=NULL) {
kx <- round((dat[,i]-xl[1])/dx)+1
dat[,i] <- xu[kx] ## rounding the metric variables
}
xu <- uniquecombs(dat)
xu <- uniquecombs(dat,TRUE)
}
k <- attr(xu,"index")
## shuffle rows in order to avoid induced dependencies between discretized
......
......@@ -450,6 +450,7 @@ ocat <- function(theta=NULL,link="identity",R=NULL) {
theta <- log(theta)
}
R3 <- length(G$family$getTheta())+2
if (!is.numeric(G$y)) stop("Response should be integer class labels")
if (R3>2&&G$family$n.theta>0) {
Theta <- ocat.ini(R3,G$y)
G$family$putTheta(Theta)
......
This diff is collapsed.
......@@ -310,18 +310,8 @@ gam.fit4 <- function(x, y, sp, Eb,UrS=list(),
}
else family$linkfun(mustart)
##mu.eta <- family$mu.eta
##Dd <- family$Dd
mu <- linkinv(eta);etaold <- eta
## need an initial `null deviance' to test for initial divergence...
## if (!is.null(start)) null.coef <- start - can be on edge of feasible - not good
#null.eta <- as.numeric(x%*%null.coef + as.numeric(offset))
#old.pdev <- sum(dev.resids(y, linkinv(null.eta), weights,theta)) + t(null.coef)%*%St%*%null.coef
coefold <- null.coef
conv <- boundary <- FALSE
......@@ -342,15 +332,6 @@ gam.fit4 <- function(x, y, sp, Eb,UrS=list(),
z[!is.finite(z)] <- 0 ## avoid NaN in .C call - unused anyway
} else use.wy <- family$use.wz
#if (sum(!good)) {
# good1 <- is.finite(w)&good ## make sure w finite too
# w[!is.finite(w)] <- 0 ## clear infinite w
# w[!good1&w==0] <- max(w)*.Machine$double.eps^.5 ## reset zero value weights for problem elements
# dd$Deta.Deta2[!good] <- .5*dd$Deta[!good]/w[!good] ## reset problem elements to finite
# good <- is.finite(dd$Deta.Deta2) ## check in case Deta not finite, for example
#}
#z <- (eta-offset)[good] - dd$Deta.Deta2[good] ## - .5 * dd$Deta[good] / w
oo <- .C(C_pls_fit1,
y=as.double(z[good]),X=as.double(x[good,]),w=as.double(w[good]),wy = as.double(wz[good]),
E=as.double(Sr),Es=as.double(Eb),n=as.integer(sum(good)),
......@@ -364,7 +345,6 @@ gam.fit4 <- function(x, y, sp, Eb,UrS=list(),
## index weights that are finite and positive
good <- is.finite(dd$Deta2)
good[good] <- dd$Deta2[good]>0
#w <- dd$Deta2*.5;
w[!good] <- 0
wz <- w*(eta-offset) - .5*dd$Deta
z <- (eta-offset) - dd$Deta.Deta2
......@@ -374,10 +354,6 @@ gam.fit4 <- function(x, y, sp, Eb,UrS=list(),
good <- is.finite(w)&is.finite(wz)
z[!is.finite(z)] <- 0 ## avoid NaN in .C call - unused anyway
} else use.wy <- family$use.wz
#thresh <- max(w[good])*.Machine$double.eps^.5
#w[w < thresh] <- thresh
#good <- is.finite(dd$Deta)
#z <- (eta-offset)[good] - .5 * dd$Deta[good] / w[good]
oo <- .C(C_pls_fit1, ##C_pls_fit1,
y=as.double(z[good]),X=as.double(x[good,]),w=as.double(w[good]),wy = as.double(wz[good]),
......@@ -485,7 +461,6 @@ gam.fit4 <- function(x, y, sp, Eb,UrS=list(),
## drop same parameter every iteration!)
grad <- 2 * t(x[good,])%*%((w[good]*(x%*%start)[good]-wz[good]))+ 2*St%*%start
if (max(abs(grad)) > control$epsilon*max(abs(start+coefold))/2) {
## if (max(abs(start-coefold))>control$epsilon*max(abs(start+coefold))/2) {
old.pdev <- pdev ## not converged quite enough
coef <- coefold <- start
etaold <- eta
......@@ -516,32 +491,17 @@ gam.fit4 <- function(x, y, sp, Eb,UrS=list(),
dd <- dDeta(y,mu,weights,theta,family,deriv)
w <- dd$Deta2 * .5
z <- (eta-offset) - dd$Deta.Deta2 ## - .5 * dd$Deta[good] / w
wf <- dd$EDeta2 * .5 ## Fisher type weights
wf <- pmax(0,dd$EDeta2 * .5) ## Fisher type weights
wz <- w*(eta-offset) - 0.5*dd$Deta ## Wz finite when w==0
gdi.type <- if (any(abs(w)<.Machine$double.xmin*1e20)||any(!is.finite(z))) 1 else 0
good <- is.finite(wz)&is.finite(w)
## exclude points for which gradient and second deriv are effectively zero and
## points with non finite second deriv or deriv ratio...
#min.Deta <- mean(abs(dd$Deta[is.finite(dd$Deta)]))*.Machine$double.eps*.001
#min.Deta2 <- mean(abs(dd$Deta2[is.finite(dd$Deta2)]))*.Machine$double.eps*.001
#good <- is.finite(dd$Deta.Deta2)&is.finite(w)&!(abs(dd$Deta2) < min.Deta2 & abs(dd$Deta) < min.Deta)
#if (control$trace&sum(!good)>0) cat("\n",sum(!good)," not good\n")
#w <- w[good]
#z <- (eta-offset)[good] - dd$Deta.Deta2[good] ## - .5 * dd$Deta[good] / w
#wf <- dd$EDeta2[good] * .5 ## Fisher type weights
#wz <- w*(eta-offset)[good] - 0.5*dd$Deta[good]
#residuals <- rep.int(NA, nobs)
residuals <- z - (eta - offset)
residuals[!is.finite(residuals)] <- NA
z[!is.finite(z)] <- 0 ## avoid passing NA etc to C code
ntot <- length(theta) + length(sp)
## if (deriv>1) n2d <- ntot*(1+ntot)/2 else n2d <- 0
rSncol <- unlist(lapply(UrS,ncol))
## Now drop any elements of dd that have been dropped in fitting...
if (sum(!good)>0) { ## drop !good from fields of dd, weights and pseudodata
......@@ -570,10 +530,7 @@ gam.fit4 <- function(x, y, sp, Eb,UrS=list(),
}
}
}
## can't have zero weights in gdi2 call - superceded by type=1 handling of w==0
#mwb <- max(abs(w))*.Machine$double.eps
#mwa <- min(abs(w[w!=0]))*.0001; if (mwa==0) mwa <- mwb
#w[w==0] <- min(mwa,mwb);
oo <- .C(C_gdi2,
X=as.double(x[good,]),E=as.double(Sr),Es=as.double(Eb),rS=as.double(unlist(rS)),
U1 = as.double(U1),sp=as.double(exp(sp)),theta=as.double(theta),
......@@ -582,7 +539,7 @@ gam.fit4 <- function(x, y, sp, Eb,UrS=list(),
Det2=as.double(dd$Deta2),Dth2=as.double(dd$Dth2),Det.th=as.double(dd$Detath),
Det2.th=as.double(dd$Deta2th),Det3=as.double(dd$Deta3),Det.th2 = as.double(dd$Detath2),
Det4 = as.double(dd$Deta4),Det3.th=as.double(dd$Deta3th), Deta2.th2=as.double(dd$Deta2th2),
beta=as.double(coef),b1=as.double(rep(0,ntot*ncol(x))),w1=rep(0,ntot*length(z)),
beta=as.double(coef),b1=as.double(rep(0,ntot*ncol(x))),w1=as.double(rep(0,ntot*length(z))),
D1=as.double(rep(0,ntot)),D2=as.double(rep(0,ntot^2)),
P=as.double(0),P1=as.double(rep(0,ntot)),P2 = as.double(rep(0,ntot^2)),
ldet=as.double(1-2*(scoreType=="ML")),ldet1 = as.double(rep(0,ntot)),
......@@ -1282,34 +1239,51 @@ gam.fit5.post.proc <- function(object,Sl,L,lsp0,S,off) {
lbb[ibd,ibd] <- lbbt
}
edge.correct <- FALSE
## compute the smoothing parameter uncertainty correction...
if (!is.null(object$outer.info$hess)&&!is.null(object$db.drho)) {
if (!is.null(L)) object$db.drho <- object$db.drho%*%L ## transform to derivs w.r.t. working
ev <- eigen(object$outer.info$hess,symmetric=TRUE)
hess <- object$outer.info$hess
edge.correct <- if (is.null(attr(hess,"edge.correct"))) FALSE else TRUE
K <- if (edge.correct) 2 else 1
for (k in 1:K) {
if (k==1) { ## fitted model computations
db.drho <- object$db.drho
dw.drho <- object$dw.drho
lsp <- log(object$sp)
} else { ## edge corrected model computations
db.drho <- attr(hess,"db.drho1")
dw.drho <- attr(hess,"dw.drho1")
lsp <- attr(hess,"lsp1")
hess <- attr(hess,"hess1")
}
if (!is.null(L)) db.drho <- db.drho%*%L ## transform to derivs w.r.t. working
ev <- eigen(hess,symmetric=TRUE)
d <- ev$values;ind <- d <= 0
d[ind] <- 0;d[!ind] <- 1/sqrt(d[!ind])
Vc <- crossprod((d*t(ev$vectors))%*%t(object$db.drho))
#dpv <- rep(0,ncol(object$outer.info$hess));M <- length(off)
#dpv[1:M] <- 1/100 ## prior precision (1/var) on log smoothing parameters
#Vr <- chol2inv(chol(object$outer.info$hess + diag(dpv,ncol=length(dpv))))[1:M,1:M]
#Vc <- object$db.drho%*%Vr%*%t(object$db.drho)
#dpv[1:M] <- 1/10 ## prior precision (1/var) on log smoothing parameters
#Vr <- chol2inv(chol(object$outer.info$hess + diag(dpv,ncol=length(dpv))))[1:M,1:M]
#M <- length(off)
Vc <- crossprod((d*t(ev$vectors))%*%t(db.drho)) ## first correction
d <- ev$values; d[ind] <- 0;
d <- d + 1/50 #d[1:M] <- d[1:M] + 1/50
d <- 1/sqrt(d)
d <- if (k==1) 1/sqrt(d+1/50) else 1/sqrt(d+1e-7)
Vr <- crossprod(d*t(ev$vectors))
#Vc2 <- Vb.corr(R,L,S,off,dw=NULL,w=NULL,log(object$sp),Vr)
Vc <- Vb + Vc #+ Vc2 ## Bayesian cov matrix with sp uncertainty
if (k==1) {
Vc1 <- Vc; Vr1 <- Vr; lsp1 <- lsp ## un-shifted version to use for edf
}
## reverse the various re-parameterizations...
} else Vc <- Vb
Vc <- Sl.repara(object$rp,Vc,inverse=TRUE)
}
rp <- if (edge.correct) attr(object$outer.info$hess,"rp") else object$rp
Vc <- Sl.repara(rp,Vc,inverse=TRUE)
Vc <- Sl.initial.repara(Sl,Vc,inverse=TRUE)
} else Vc <- 0
Vb <- Sl.repara(object$rp,Vb,inverse=TRUE)
Vb <- Sl.initial.repara(Sl,Vb,inverse=TRUE)
Vc <- Vb + Vc
if (edge.correct) {
Vc1 <- Sl.repara(object$rp,Vc1,inverse=TRUE)
Vc1 <- Sl.initial.repara(Sl,Vc1,inverse=TRUE)
Vc1 <- Vb + Vc1
}
R <- Sl.repara(object$rp,R,inverse=TRUE,both.sides=FALSE)
R <- Sl.initial.repara(Sl,R,inverse=TRUE,both.sides=FALSE,cov=FALSE)
F <- Vb%*%crossprod(R)
......@@ -1322,12 +1296,12 @@ gam.fit5.post.proc <- function(object,Sl,L,lsp0,S,off) {
## justification only applies to sum(edf1/2) not elementwise
if (!is.null(object$outer.info$hess)&&!is.null(object$db.drho)) {
## second correction term is easier computed in original parameterization...
Vc2 <- Vb.corr(R,L,lsp0,S,off,dw=NULL,w=NULL,log(object$sp),Vr)
Vc <- Vc + Vc2
Vc <- Vc + Vb.corr(R,L,lsp0,S,off,dw=NULL,w=NULL,lsp,Vr)
if (edge.correct) Vc1 <- Vc1 +
Vb.corr(R,L,lsp0,S,off,dw=NULL,w=NULL,lsp1,Vr1) else Vc1 <- Vc
}
edf1 <- 2*edf - rowSums(t(F)*F)
#edf2 <- diag(Vc%*%crossprod(R))
edf2 <- rowSums(Vc*crossprod(R))
edf2 <- if (edge.correct) rowSums(Vc1*crossprod(R)) else rowSums(Vc*crossprod(R))
if (sum(edf2)>sum(edf1)) edf2 <- edf1
## note hat not possible here...
list(Vc=Vc,Vb=Vb,Ve=Ve,edf=edf,edf1=edf1,edf2=edf2,F=F,R=R)
......
......@@ -165,7 +165,7 @@ sp.prior = "gamma",diagonalize=FALSE) {
## get initial values, for use by JAGS, and to guess suitable values for
## uninformative priors...
lambda <- initial.spg(G$X,G$y,G$w,family,G$S,G$off,offset=G$offset,L=G$L) ## initial sp values
lambda <- initial.spg(G$X,G$y,G$w,family,G$S,G$rank,G$off,offset=G$offset,L=G$L) ## initial sp values
jags.ini <- list()
lam <- if (is.null(G$L)) lambda else G$L%*%lambda
jin <- jini(G,lam)
......
......@@ -792,7 +792,8 @@ gam.setup.list <- function(formula,pterms,
#G$contrasts <- list(G$contrasts)
G$xlevels <- list(G$xlevels)
G$assign <- list(G$assign)
if (!is.null(sp)&&length(G$sp)>0) sp <- sp[-(1:length(G$sp))] ## need to strip off already used sp's
used.sp <- length(G$lsp0)
if (!is.null(sp)&&used.sp>0) sp <- sp[-(1:used.sp)] ## need to strip off already used sp's
if (!is.null(min.sp)&&nrow(G$L)>0) min.sp <- min.sp[-(1:nrow(G$L))]
## formula[[1]] always relates to the base formula of the first linear predictor...
......@@ -810,12 +811,14 @@ gam.setup.list <- function(formula,pterms,
formula[[i]]$response <- formula$response
mv.response <- FALSE
} else mv.response <- TRUE
spind <- if (is.null(sp)) 1 else (length(G$S)+1):length(sp)
#spind <- if (is.null(sp)) 1 else (length(G$S)+1):length(sp)
formula[[i]]$pfok <- 1 ## empty formulae OK here!
um <- gam.setup(formula[[i]],pterms[[i]],
data,knots,sp[spind],min.sp[spind],H,absorb.cons,sparse.cons,select,
data,knots,sp,min.sp,#sp[spind],min.sp[spind],
H,absorb.cons,sparse.cons,select,
idLinksBases,scale.penalty,paraPen,gamm.call,drop.intercept[i],list.call=TRUE)
if (!is.null(sp)&&length(um$sp)>0) sp <- sp[-(1:length(um$sp))] ## need to strip off already used sp's
used.sp <- length(um$lsp0)
if (!is.null(sp)&&used.sp>0) sp <- sp[-(1:used.sp)] ## need to strip off already used sp's
if (!is.null(min.sp)&&nrow(um$L)>0) min.sp <- min.sp[-(1:nrow(um$L))]
flpi[[i]] <- formula[[i]]$lpi
......@@ -1445,7 +1448,7 @@ gam.outer <- function(lsp,fscale,family,control,method,optimizer,criterion,scale
family <- fix.family.var(family)
if (method%in%c("REML","ML","P-REML","P-ML")) family <- fix.family.ls(family)
if (optimizer[1]=="efs") { ## experimental extended efs
if (optimizer[1]=="efs"&& optimizer[2] != "no.sps" ) { ## experimental extended efs
##warning("efs is still experimental!")
object <- efsud(x=G$X,y=G$y,lsp=lsp,Sl=G$Sl,weights=G$w,offset=G$offxset,family=family,
control=control,Mp=G$Mp,start=start)
......@@ -1461,7 +1464,8 @@ gam.outer <- function(lsp,fscale,family,control,method,optimizer,criterion,scale
family=family,weights=G$w,control=control,gamma=gamma,scale=scale,conv.tol=control$newton$conv.tol,
maxNstep= control$newton$maxNstep,maxSstep=control$newton$maxSstep,maxHalf=control$newton$maxHalf,
printWarn=FALSE,scoreType=criterion,null.coef=G$null.coef,start=start,
pearson.extra=G$pearson.extra,dev.extra=G$dev.extra,n.true=G$n.true,Sl=G$Sl,...)
pearson.extra=G$pearson.extra,dev.extra=G$dev.extra,n.true=G$n.true,Sl=G$Sl,
edge.correct=control$edge.correct,...)
object <- b$object
object$REML <- object$REML1 <- object$REML2 <-
......@@ -1504,6 +1508,7 @@ gam.outer <- function(lsp,fscale,family,control,method,optimizer,criterion,scale
}
object$control <- control
object$method <- method
if (inherits(family,"general.family")) {
mv <- gam.fit5.post.proc(object,G$Sl,G$L,G$lsp0,G$S,G$off)
## object$coefficients <- Sl.initial.repara(G$Sl,object$coefficients,inverse=TRUE)
......@@ -1662,7 +1667,7 @@ estimate.gam <- function (G,method,optimizer,control,in.out,scale,gamma,start=NU
if (!is.null(G$family$preinitialize)) eval(G$family$preinitialize)
if (length(G$sp)>0) lsp2 <- log(initial.spg(G$X,G$y,G$w,G$family,G$S,G$off,
if (length(G$sp)>0) lsp2 <- log(initial.spg(G$X,G$y,G$w,G$family,G$S,G$rank,G$off,
offset=G$offset,L=G$L,lsp0=G$lsp0,E=G$Eb,...))
else lsp2 <- rep(0,0)
......@@ -2052,7 +2057,7 @@ gam.control <- function (nthreads=1,irls.reg=0.0,epsilon = 1e-7, maxit = 200,
rank.tol=.Machine$double.eps^0.5,
nlm=list(),optim=list(),newton=list(),outerPIsteps=0,
idLinksBases=TRUE,scalePenalty=TRUE,
keepData=FALSE,scale.est="fletcher")
keepData=FALSE,scale.est="fletcher",edge.correct=FALSE)
# Control structure for a gam.
# irls.reg is the regularization parameter to use in the GAM fitting IRLS loop.
# epsilon is the tolerance to use in the IRLS MLE loop. maxit is the number
......@@ -2063,6 +2068,8 @@ gam.control <- function (nthreads=1,irls.reg=0.0,epsilon = 1e-7, maxit = 200,
# outerPIsteps is the number of performance iteration steps used to intialize
# outer iteration
{ scale.est <- match.arg(scale.est,c("fletcher","pearson","deviance"))
if (!is.logical(edge.correct)&&(!is.numeric(edge.correct)||edge.correct<0)) stop(
"edge.correct must be logical or a positive number")
if (!is.numeric(nthreads) || nthreads <1) stop("nthreads must be a positive integer")
if (!is.numeric(irls.reg) || irls.reg <0.0) stop("IRLS regularizing parameter must be a non-negative number.")
if (!is.numeric(epsilon) || epsilon <= 0)
......@@ -2108,7 +2115,7 @@ gam.control <- function (nthreads=1,irls.reg=0.0,epsilon = 1e-7, maxit = 200,
rank.tol=rank.tol,nlm=nlm,
optim=optim,newton=newton,outerPIsteps=outerPIsteps,
idLinksBases=idLinksBases,scalePenalty=scalePenalty,
keepData=as.logical(keepData[1]),scale.est=scale.est)
keepData=as.logical(keepData[1]),scale.est=scale.est,edge.correct=edge.correct)
}
......@@ -4112,7 +4119,7 @@ single.sp <- function(X,S,target=.5,tol=.Machine$double.eps*100)
}
initial.spg <- function(x,y,weights,family,S,off,offset=NULL,L=NULL,lsp0=NULL,type=1,
initial.spg <- function(x,y,weights,family,S,rank,off,offset=NULL,L=NULL,lsp0=NULL,type=1,
start=NULL,mustart=NULL,etastart=NULL,E=NULL,...) {
## initial smoothing parameter values based on approximate matching
## of Frob norm of XWX and S. If L is non null then it is assumed
......@@ -4127,6 +4134,16 @@ initial.spg <- function(x,y,weights,family,S,off,offset=NULL,L=NULL,lsp0=NULL,ty
eval(family$initialize)
if (inherits(family,"general.family")) { ## Cox, gamlss etc...
lbb <- family$ll(y,x,start,weights,family,offset=offset,deriv=1)$lbb ## initial Hessian
## initially work out the number of times that each coefficient is penalized
pcount <- rep(0,ncol(lbb))
for (i in 1:length(S)) {
ind <- off[i]:(off[i]+ncol(S[[i]])-1)
dlb <- -diag(lbb[ind,ind])
indp <- rowSums(abs(S[[i]]))>max(S[[i]])*.Machine$double.eps^.75 & dlb!=0
ind <- ind[indp] ## drop indices of unpenalized
pcount[ind] <- pcount[ind] + 1 ## add up times penalized
}
lambda <- rep(0,length(S))
## choose lambda so that corresponding elements of lbb and S[[i]]
## are roughly in balance...
......@@ -4134,12 +4151,17 @@ initial.spg <- function(x,y,weights,family,S,off,offset=NULL,L=NULL,lsp0=NULL,ty
ind <- off[i]:(off[i]+ncol(S[[i]])-1)
lami <- 1
dlb <- -diag(lbb[ind,ind]);dS <- diag(S[[i]])
pc <- pcount[ind]
## get index of elements doing any actual penalization...
ind <- rowSums(abs(S[[i]]))>max(S[[i]])*.Machine$double.eps^.75 & dlb!=0 ## dlb > 0
## drop elements that are not penalizing
dlb <- dlb[ind];dS <- dS[ind]
while (mean(dlb/(dlb + lami * dS)) > 0.4) lami <- lami*5
while (mean(dlb/(dlb + lami * dS)) < 0.4) lami <- lami/5
dlb <- dlb[ind]/pc[ind] ## idea is to share out between penalties
dS <- dS[ind]
rm <- max(length(dS)/rank[i],1) ## rough correction for rank deficiency in penalty
#while (mean(dlb/(dlb + lami * dS * rm)) > 0.4) lami <- lami*5
#while (mean(dlb/(dlb + lami * dS * rm )) < 0.4) lami <- lami/5
while (sqrt(mean(dlb/(dlb + lami * dS * rm))*mean(dlb)/mean(dlb+lami*dS*rm)) > 0.4) lami <- lami*5
while (sqrt(mean(dlb/(dlb + lami * dS * rm))*mean(dlb)/mean(dlb+lami*dS*rm)) < 0.4) lami <- lami/5
lambda[i] <- lami
## norm(lbb[ind,ind])/norm(S[[i]])
}
......
......@@ -32,7 +32,7 @@ fix.family.qf <- function(fam) {
}
} else if (family=="binomial") {
fam$qf <- function(p,mu,wt,scale) {
qbinom(p,wt,mu)/wt
qbinom(p,wt,mu)/(wt + as.numeric(wt==0))
}
} else if (family=="Gamma") {
fam$qf <- function(p,mu,wt,scale) {
......@@ -59,7 +59,7 @@ fix.family.rd <- function(fam) {
}
} else if (family=="binomial") {
fam$rd <- function(mu,wt,scale) {
rbinom(mu,wt,mu)/wt
rbinom(mu,wt,mu)/(wt + as.numeric(wt==0))
}
} else if (family=="Gamma") {
fam$rd <- function(mu,wt,scale) {
......@@ -1196,6 +1196,7 @@ plot.gam <- function(x,residuals=FALSE,rug=TRUE,se=TRUE,pages=0,select=NULL,scal
if (ll < ylim[1]) ylim[1] <- ll
} ## partial resids done
} ## loop end
ylim <- trans(ylim+shift)
} ## end of common scale computation
##############################################################
......
This diff is collapsed.
......@@ -172,10 +172,11 @@ Otherwise the function returns an object of class \code{"gam"} as described in \
A generalized additive model (GAM) is a generalized linear model (GLM) in which the linear
predictor is given by a user specified sum of smooth functions of the covariates plus a
conventional parametric component of the linear predictor. A simple example is:
\deqn{\log(E(y_i)) = f_1(x_{1i})+f_2(x_{2i})}{log(E(y_i))=f_1(x_1i)+f_2(x_2i)}
\deqn{\log(E(y_i)) = \alpha + f_1(x_{1i})+f_2(x_{2i})}{log(E(y_i))= a + f_1(x_1i)+f_2(x_2i)}
where the (independent) response variables \eqn{y_i \sim {\rm Poi }}{y_i~Poi}, and
\eqn{f_1}{f_1} and \eqn{f_2}{f_2} are smooth functions of covariates \eqn{x_1}{x_1} and
\eqn{x_2}{x_2}. The log is an example of a link function.
\eqn{x_2}{x_2}. The log is an example of a link function. Note that to be identifiable the model
requires constraints on the smooth functions. By default these are imposed automatically and require that the function sums to zero over the observed covariate values (the presence of a metric \code{by} variable is the only case which usually suppresses this).
If absolutely any smooth functions were allowed in model fitting then maximum likelihood
estimation of such models would invariably result in complex overfitting estimates of
......@@ -215,7 +216,7 @@ Broadly \code{gam} works by first constructing basis functions and one or more q
coefficient matrices for each smooth term in the model formula, obtaining a model matrix for
the strictly parametric part of the model formula, and combining these to obtain a
complete model matrix (/design matrix) and a set of penalty matrices for the smooth terms.
Some linear identifiability constraints are also obtained at this point. The model is
The linear identifiability constraints are also obtained at this point. The model is
fit using \code{\link{gam.fit}}, \code{\link{gam.fit3}} or varaints, which are modifications
of \code{\link{glm.fit}}. The GAM
penalized likelihood maximization problem is solved by Penalized Iteratively
......
......@@ -15,7 +15,7 @@ gam.control(nthreads=1,irls.reg=0.0,epsilon = 1e-07, maxit = 200,
rank.tol=.Machine$double.eps^0.5,
nlm=list(),optim=list(),newton=list(),
outerPIsteps=0,idLinksBases=TRUE,scalePenalty=TRUE,
keepData=FALSE,scale.est="fletcher")
keepData=FALSE,scale.est="fletcher",edge.correct=FALSE)
}
\arguments{
\item{nthreads}{Some parts of some smoothing parameter selection methods (e.g. REML) can use some
......@@ -78,6 +78,10 @@ do so. }
\item{scale.est}{How to estimate the scale parameter for exponential family models estimated
by outer iteration. See \code{\link{gam.scale}}.}
\item{edge.correct}{With RE/ML smoothing parameter selection in \code{gam} using the default Newton RE/ML optimizer, it is possible to improve inference at the
`completely smooth' edge of the smoothing parameter space, by decreasing
smoothing parameters until there is a small increase in the negative RE/ML (e.g. 0.02). Set to \code{TRUE} or to a number representing the target increase to use. Only changes the corrected smoothing parameter matrix, \code{Vc}.}
}
\details{
......
......@@ -2,7 +2,7 @@
\alias{multinom}
%- Also NEED an `\alias' for EACH other topic documented here.
\title{GAM multinomial logistic regression}
\description{Family for use with \code{\link{gam}}, implementing regression for categorical response data. Categories must be coded 0 to K, where K is a positive integer. \code{\link{gam}} should be called with a list of K formulae, one for each category except category zero (extra formulae for shared terms may also be supplied). The first formula also specifies the response variable.
\description{Family for use with \code{\link{gam}}, implementing regression for categorical response data. Categories must be coded 0 to K, where K is a positive integer. \code{\link{gam}} should be called with a list of K formulae, one for each category except category zero (extra formulae for shared terms may also be supplied: see \code{\link{formula.gam}}). The first formula also specifies the response variable.
}
\usage{
......
......@@ -3,8 +3,7 @@
%- Also NEED an `\alias' for EACH other topic documented here.
\title{Multivariate normal additive models}
\description{Family for use with \code{\link{gam}} implementing smooth multivariate Gaussian regression.
The means for each dimension are given by a separate linear predictor, which may contain smooth components. The
Choleski factor of the response precision matrix is estimated as part of fitting.
The means for each dimension are given by a separate linear predictor, which may contain smooth components. Extra linear predictors may also be specified giving terms which are shared between components (see \code{\link{formula.gam}}). The Choleski factor of the response precision matrix is estimated as part of fitting.
}
\usage{
......
......@@ -200,13 +200,15 @@ res <- colSums(log(abs(Xp \%*\% t(br))))
# illustration of unsafe scale dependent transforms in smooths....
##################################################################
b0 <- gam(y~s(x0)+s(x1)+s(x2)+scale(x3),data=dat) ## safe
b0 <- gam(y~s(x0)+s(x1)+s(x2)+x3,data=dat) ## safe
b1 <- gam(y~s(x0)+s(I(x1/2))+s(x2)+scale(x3),data=dat) ## safe
b2 <- gam(y~s(x0)+s(scale(x1))+s(x2)+scale(x3),data=dat) ## unsafe
pd <- dat; pd$x1 <- pd$x1/2; pd$x3 <- pd$x3/2
par(mfrow=c(1,2))
plot(predict(b0,pd),predict(b1,pd),main="b0 and b1 predictions match");abline(0,1,col=2)
plot(predict(b0,pd),predict(b2,pd),main="b2 unsafe, doesn't match");abline(0,1,col=2)
plot(predict(b0,pd),predict(b1,pd),main="b0 and b1 predictions match")
abline(0,1,col=2)
plot(predict(b0,pd),predict(b2,pd),main="b2 unsafe, doesn't match")
abline(0,1,col=2)
##################################################################
......
......@@ -12,7 +12,9 @@
%- maybe also `usage' for other objects documented here.
\arguments{
\item{...}{ a list of variables that are the covariates that this
smooth is a function of.}
smooth is a function of. Transformations whose form depends on
the values of the data are best avoided here: e.g. \code{s(log(x))}
is fine, but \code{s(I(x/sd(x)))} is not (see \code{\link{predict.gam}}).}
\item{k}{ the dimension of the basis used to represent the smooth term.
The default depends on the number of variables that the smooth is a
......
......@@ -16,7 +16,9 @@ is that it is useable with \code{gamm4} from package \code{gamm4}.
%- maybe also `usage' for other objects documented here.
\arguments{
\item{...}{ a list of variables that are the covariates that this
smooth is a function of.}
smooth is a function of. Transformations whose form depends on
the values of the data are best avoided here: e.g. \code{t2(log(x),z)}
is fine, but \code{t2(I(x/sd(x)),z)} is not (see \code{\link{predict.gam}}).}
\item{k}{ the dimension(s) of the bases used to represent the smooth term.
If not supplied then set to \code{5^d}. If supplied as a single number then this
......
......@@ -22,7 +22,9 @@ ti(..., k=NA,bs="cr",m=NA,d=NA,by=NA,fx=FALSE,
%- maybe also `usage' for other objects documented here.
\arguments{
\item{...}{ a list of variables that are the covariates that this
smooth is a function of.}
smooth is a function of. Transformations whose form depends on
the values of the data are best avoided here: e.g. \code{te(log(x),z)}
is fine, but \code{te(I(x/sd(x)),z)} is not (see \code{\link{predict.gam}}). }
\item{k}{ the dimension(s) of the bases used to represent the smooth term.
If not supplied then set to \code{5^d}. If supplied as a single number then this
......
......@@ -10,11 +10,12 @@ as on entry. It also returns an index attribute for relating the result back
to the original matrix.
}
\usage{
uniquecombs(x)
uniquecombs(x,ordered=FALSE)
}
%- maybe also `usage' for other objects documented here.
\arguments{
\item{x}{ is an \R matrix (numeric), or data frame. }
\item{ordered}{ set to \code{TRUE} to have the rows of the returned object in the same order regardless of input ordering.}
}
\details{ Models with more parameters than unique combinations of
covariates are not identifiable. This routine provides a means of
......@@ -60,6 +61,13 @@ ind <- attr(Xu,"index")
## find the value for row 3 of the original from Xu
Xu[ind[3],];X[3,]
## same with fixed output ordering
Xu <- uniquecombs(X,TRUE);Xu
ind <- attr(Xu,"index")
## find the value for row 3 of the original from Xu
Xu[ind[3],];X[3,]
## data frame example...
df <- data.frame(f=factor(c("er",3,"b","er",3,3,1,2,"b")),
x=c(.5,1,1.4,.5,1,.6,4,3,1.7))
......
Markdown is supported
0% or
You are about to add