scam/0000755000176200001440000000000015154510372011200 5ustar liggesusersscam/MD50000644000176200001440000001171315154510372011513 0ustar liggesusers9571391d81b4f6b721464d812a783e92 *ChangeLog 2e380dbecf2906b7a2fc200397d082d2 *DESCRIPTION 11a645ce006bb0e873e9b3010120cfe0 *NAMESPACE 66eac716dcaab1f5a44cb30cf3b6fa54 *R/bfgs.r ea1df0bb76f3531c0051ef5746f1658a *R/bivar.smooth.const-ti.R 57b19269b0e853409caf928e65d80749 *R/bivar.smooth.const.R e93b6eac46d891cc6cb7a4872742bdf2 *R/check.analytical.R 4f16777518bcd26d3027f4b6ad21e9e6 *R/derivative.scam.r 465e748476a3846b449fd3b3bb7847ba *R/emmeans-support.r 32ad365105088f2aa6dff903acc9e47b *R/estimate.scam.R 49a3324b184ff0d3cd78996cf86925fe *R/plot.r 262aad336d3b339679f90a134d5dc459 *R/predict.scam.R 0e570692be60d6cfa0cc75cd535fb614 *R/print.scam.R 540d55c1cbfae5a71fffbfc6d2b5d8ba *R/residuals.scam.R ae6a4738ad7a078ad681a0ab105bd8e5 *R/scam.check.R 2787ae50f707e54061f7016c35ff2d6a *R/scam.fit1.r 77bdc81787d433bbc47330d9d2468f42 *R/scam.r bfc1a2af10aec21fe27d191329001ec2 *R/summary.scam.R 319a395ebcad97840eb6863fb26fe30b *R/uni.smooth.const-lscop.r 2c2dc579813584e87ca05c6c6949495c *R/uni.smooth.const.r 9d09834f77481ae4978dba0b7ba99c65 *R/vis.scam.r 70d9de9825f977284433152069112dd1 *R/zzz.R 961f6bdd6b99b50211b8e5a28f93eaec *build/partial.rdb ec6601614e668b6e11672c211846050c *man/Predict.matrix.mpi.smooth.Rd f5a564611c56a8b273d291e5d6600286 *man/anova.scam.Rd 5125411662e47c8c998e7837ce7e1938 *man/bfgs_gcv.ubre.Rd 6a30099c74b7bbf4e65af9190235653f *man/check.analytical.Rd 33da82b5e7768ce7ae663ba98186b2b6 *man/derivative.scam.Rd aa1f049d5b63d7898dc0d7b713112644 *man/formula.scam.Rd f0696309109bd4a262497d3e11280a5c *man/gcv.ubre_grad.Rd 24442153d997608b9745be5db6b155cc *man/linear.functional.terms.Rd 8ca32ad9ebed8f291520dbb3752fab71 *man/logLik.scam.Rd 04661ce181963825f441aa294a1bf042 *man/marginal.matrices.tescv.ps.Rd 8b3b515a8d95e1977ad479f25aa62928 *man/marginal.matrices.tesmi1.ps.Rd f2356e3bdf51f33d7c62aafc2eb9ca15 *man/marginal.matrices.tesmi2.ps.Rd 66f8fbe7d0eea337c2aca234ed85a5cc *man/plot.scam.Rd b9fdc7be2380ffd4b833d79d3a1a251c *man/predict.scam.Rd 59696dbf6526f0f149000e454b4e0d2a *man/print.scam.Rd db53464a15a989778f806323561d0da4 *man/qq.scam.Rd 37f6785b3ce4cddb0365b09e8345e67a *man/residuals.scam.Rd 5c3b066f1cb351a2a2b4614a5351a65c *man/scam-package.Rd 437649dd887a3898340673c94c2eeb44 *man/scam.Rd 49a9b42a35a4cd6931a5eb5feda9babf *man/scam.check.Rd 179bb77b6f5d740f5483a915efd43071 *man/scam.control.Rd c27a0fbc88dfee1bec142680ad4d4cad *man/scam.emmeans.support.Rd dfa3597e19d042f13864fe411426422b *man/scam.fit.Rd 7d3f6d0494b9a698bf131f55135d1e58 *man/shape.constrained.smooth.terms.Rd 809afb31076b367cc1b112e0c53c1fa6 *man/smooth.construct.cv.smooth.spec.rd 16d2824ba78547c4dc6dad582f54c937 *man/smooth.construct.cx.smooth.spec.Rd 37fd6259336638ad015ac47057c8e919 *man/smooth.construct.lmpi.smooth.spec.Rd ce80600c5f5c810891d50b54cb98a074 *man/smooth.construct.mdcv.smooth.spec.Rd 4deca200f001e47ed7d0ed5169909f3f *man/smooth.construct.mdcx.smooth.spec.Rd 6079848ccfa9d86825780cb878117a75 *man/smooth.construct.micv.smooth.spec.Rd f4a24d445932973f026c0ef1aea257fd *man/smooth.construct.micx.smooth.spec.Rd e3d58c452a3132af2a825811b958e4bd *man/smooth.construct.mifo.smooth.spec.Rd 356fce8d43617bb52bb3b0be385ee938 *man/smooth.construct.miso.smooth.spec.Rd ac44d56db178cd40295178c974ff9b41 *man/smooth.construct.mpd.smooth.spec.Rd eb5d6f177341185685c7806a9c687b51 *man/smooth.construct.mpi.smooth.spec.Rd 7bb58820f892728bce7b6f9ea7becc9f *man/smooth.construct.po.smooth.spec.Rd 3c0f2c734c140a0d3138a4fe27fb37eb *man/smooth.construct.tecvcv.smooth.spec.Rd a735b96d39a7edb99ff4f9010f3a4d8a *man/smooth.construct.tecxcv.smooth.spec.Rd 9a2ce5f5cb88d62621f73cffd89d8451 *man/smooth.construct.tecxcx.smooth.spec.Rd 2c9f3fedc8983be5ffb565302c6fd7f5 *man/smooth.construct.tedecv.smooth.spec.Rd 2a0b27bfca21d33ea50bedf3beda5b3a *man/smooth.construct.tedecx.smooth.spec.Rd 3b49899de2382c99e9e41d15cd5aa866 *man/smooth.construct.tedmd.smooth.spec.Rd 32606d04150a673d8a75f11cea1599b4 *man/smooth.construct.tedmi.smooth.spec.Rd 19486496ae5add3e0f508e4bba8a40cb *man/smooth.construct.temicv.smooth.spec.Rd 799c08a1975304fcecc987f3c1ccb0e5 *man/smooth.construct.temicx.smooth.spec.Rd c22b619554d2346b00e5506751e31c87 *man/smooth.construct.tescv.smooth.spec.Rd 476f9aab262908303531e8a8f534e0f6 *man/smooth.construct.tescx.smooth.spec.Rd 019085c7cec0050ad3156dd149bbe060 *man/smooth.construct.tesmd1.smooth.spec.Rd f6d570550e1d4856928c52c03ce1a664 *man/smooth.construct.tesmd2.smooth.spec.Rd eebba7613c99e680c642ef0ec23a32a0 *man/smooth.construct.tesmi1.smooth.spec.Rd 209f5431f395fc387066503e84faaf83 *man/smooth.construct.tesmi2.smooth.spec.Rd 4c517f578571a46b165374de1e2d29fb *man/smooth.construct.tismd.smooth.spec.Rd 5cf9fe48690e11d696284adbca1bc5c3 *man/smooth.construct.tismi.smooth.spec.Rd c1daa64ed83920ae5a86a176410e42f8 *man/summary.scam.Rd 64da5ebb30a505e5e058fda74bb19538 *man/vcov.scam.Rd e85bffca19f7b8f0393bcc48433985a3 *man/vis.scam.Rd 03972284b3400cf82cacd5d2dc4b8cb3 *src/Makevars f9d471f1c6f4608c613b9a2d27a2158d *src/scam.h 15744677d50bc9be6df2c38c47f9bf3d *src/scam_init.c 84f1ac0f7476bdc1dfe37f33464e7345 *src/someone.c scam/R/0000755000176200001440000000000015153754544011413 5ustar liggesusersscam/R/print.scam.R0000644000176200001440000000230315026260052013573 0ustar liggesusers################################################################### ## printing the results of the scam (clone of print.gam())... ## ################################################################### print.scam <- function (x,...) { print(x$family) cat("Formula:\n") print(x$formula) n.smooth <- x$n.smooth if (n.smooth == 0) cat("Total model degrees of freedom", sum(x$edf), "\n") else { edf <- 0 cat("\nEstimated degrees of freedom:\n") for (i in 1:n.smooth) edf[i] <- sum(x$edf[x$smooth[[i]]$first.para:x$smooth[[i]]$last.para]) edf.str <- format(round(edf,digits=4),digits=3,scientific=FALSE) for (i in 1:n.smooth) { cat(edf.str[i], " ", sep = "") if (i%%7 == 0) cat("\n") } cat(" total =",round(sum(x$edf),digits=2),"\n") ## (" total =", x$trA, "\n") } if (!is.null(x$gcv.ubre)) cat("\n",x$method," score: ", formatC(x$gcv.ubre, digits = 5), "\n", sep = "") if (!is.null(x$rank) && x$rank< length(x$coefficients)) cat("rank: ",x$rank,"/",length(x$coefficients),sep="") cat("\n") invisible(x) } scam/R/plot.r0000644000176200001440000016006515133442007012546 0ustar liggesusers## (c) Natalya Pya (2012-2025). Provided under GPL 2. ## based on (c) Simon N Wood plot.gam(mgcv) ## routines to produce plots for each smooth term of scam.... plot.scam <- function(x,residuals=FALSE,rug=TRUE,se=TRUE,pages=0,select=NULL,scale=-1,n=100,n2=40, pers=FALSE,theta=30,phi=30,jit=FALSE,xlab=NULL,ylab=NULL,main=NULL, ylim=NULL,xlim=NULL,too.far=0.1,all.terms=FALSE,shade=FALSE,shade.col="gray80", shift=0,trans=I,seWithMean=FALSE,unconditional=FALSE,by.resids=FALSE,scheme=0,...) # Create an appropriate plot for each smooth term of a scam..... # x is a scam object # rug determines whether a rug plot should be added to each plot # se determines whether twice standard error bars are to be added # pages is the number of pages over which to split output - 0 implies that # graphic settings should not be changed for plotting # scale -1 for same y scale for each plot # 0 for different y scales for each plot # n - number of x axis points to use for plotting each term # n2 is the square root of the number of grid points to use for contouring # 2-d terms. { ###################################### ## Local function for producing labels ###################################### sub.edf <- function(lab,edf) { ## local function to substitute edf into brackets of label ## labels are e.g. smooth[[1]]$label pos <- regexpr(":",lab)[1] if (pos<0) { ## there is no by variable stuff pos <- nchar(lab) - 1 lab <- paste(substr(lab,start=1,stop=pos),",",round(edf,digits=2),")",sep="") } else { lab1 <- substr(lab,start=1,stop=pos-2) lab2 <- substr(lab,start=pos-1,stop=nchar(lab)) lab <- paste(lab1,",",round(edf,digits=2),lab2,sep="") } lab } ## end of sub.edf ######################### ## start of main function ######################### if (unconditional) { if (is.null(x$Vc)) warning("Smoothness uncertainty corrected covariance not available") else x$Vp <- x$Vc ## cov matrix reset to full Bayesian } w.resid<-NULL if (length(residuals)>1) # residuals supplied { if (length(residuals)==length(x$residuals)) w.resid <- residuals else warning("residuals argument to plot.scam is wrong length: ignored") partial.resids <- TRUE } else partial.resids <- residuals # use working residuals or none m <- length(x$smooth) ## number of smooth terms if (length(scheme)==1) scheme <- rep(scheme,m) if (length(scheme)!=m) { warn <- paste("scheme should be a single number, or a vector with",m,"elements") warning(warn) scheme <- rep(scheme[1],m) } ## array giving order of each parametric term... order <- if (is.list(x$pterms)) unlist(lapply(x$pterms,attr,"order")) else attr(x$pterms,"order") if (all.terms) # plot parametric terms as well n.para <- sum(order==1) # plotable parametric terms else n.para <- 0 if (se) ## sort out CI widths for 1 and 2D { if (is.numeric(se)) se2.mult <- se1.mult <- se else { se1.mult <- 2;se2.mult <- 1} if (se1.mult<0) se1.mult<-0;if (se2.mult < 0) se2.mult <- 0 } else se1.mult <- se2.mult <-1 if (se && x$Vp[1,1] < 0) ## check that variances are actually available { se <- FALSE warning("No variance estimates available") } if (partial.resids) { ## getting information needed for partial residuals... if (is.null(w.resid)) { ## produce working resids if info available if (is.null(x$residuals)||is.null(x$weights)) partial.resids <- FALSE else { wr <- sqrt(x$weights) w.resid <- x$residuals*wr/mean(wr) # weighted working residuals } } if (partial.resids) fv.terms <- predict(x,type="terms") ## get individual smooth effects } pd <- list(); ## plot data list i <- 1 # needs a value if no smooths, but parametric terms ... ################################################## ## First the loop to get the data for the plots... ################################################## if (m>0) for (i in 1:m) { ## work through smooth terms first <- x$smooth[[i]]$first.para last <- x$smooth[[i]]$last.para edf <- sum(x$edf[first:last]) ## Effective DoF for this term term.lab <- sub.edf(x$smooth[[i]]$label,edf) attr(x$smooth[[i]],"coefficients") <- x$coefficients[first:last] ## relevent coefficients P <- plot(x$smooth[[i]],P=NULL,data=x$model,partial.resids=partial.resids,rug=rug,se=se,scale=scale,n=n,n2=n2, pers=pers,theta=theta,phi=phi,jit=jit,xlab=xlab,ylab=ylab,main=main,label=term.lab, ylim=ylim,xlim=xlim,too.far=too.far,shade=shade,shade.col=shade.col, se1.mult=se1.mult,se2.mult=se2.mult,shift=shift,trans=trans, by.resids=by.resids,scheme=scheme[i],...) ## plot.mgcv.smooth() called here if (is.null(P)) pd[[i]] <- list(plot.me=FALSE) else if (is.null(P$fit)) { p <- x$coefficients[first:last] ## relevent coefficients offset <- attr(P$X,"offset") ## any term specific offset ## get fitted values .... ## dealing with univariate shape-constrained smooths ... const.dif <- 0 if (inherits(x$smooth[[i]], c("mpi.smooth","mpd.smooth", "cv.smooth", "cx.smooth", "mdcv.smooth", "mdcx.smooth","micv.smooth","micx.smooth", "po.smooth", "ipo.smooth","dpo.smooth","cpopspline.smooth", "mifo.smooth", "miso.smooth","mpdBy.smooth", "cxBy.smooth","mpiBy.smooth","cvBy.smooth","mdcxBy.smooth","mdcvBy.smooth","micxBy.smooth","micvBy.smooth", "lmpi.smooth", "lipl.smooth"))) { q <- ncol(P$X) ## length(p) ## beta.c <- if (!x$not.exp) c(0,exp(p)) else c(0,notExp(p)) p.ident <- x$p.ident[first:last] iv <- (1:length(p))[p.ident] # define an index vector for the coeff-s to be exponentiated p[iv] <- if (!x$not.exp) exp(p[iv]) else notExp(p[iv],x$control$b.notexp,x$control$threshold.notexp) if (inherits(x$smooth[[i]], c("miso.smooth","mifo.smooth"))) { # beta.c <- c(rep(0,length(x$smooth[[i]]$n.zero)),p) beta.c <- rep(0,length(p)+length(x$smooth[[i]]$n.zero)) beta.c[-x$smooth[[i]]$n.zero] <- p } else if (inherits(x$smooth[[i]], c("mpi.smooth", "mpd.smooth", "cv.smooth", "cx.smooth", "mdcv.smooth", "mdcx.smooth","micv.smooth","micx.smooth", "mpdBy.smooth","cxBy.smooth","mpiBy.smooth","cvBy.smooth", "mdcxBy.smooth","mdcvBy.smooth", "micxBy.smooth","micvBy.smooth", "lmpi.smooth"))) { beta.c <- p } else if (inherits(x$smooth[[i]], c("dpo.smooth"))) { beta.c <- c(p,0) } else if (inherits(x$smooth[[i]], c("lipl.smooth"))) { beta.c <- c(0,p,rep(0,x$smooth[[i]]$n.zero.col)) } else beta.c <- c(0,p) fit.c <- P$X%*%beta.c # fitted values for the SCOP-splines identifiability constraints if (!inherits(x$smooth[[i]], c("mpdBy.smooth", "cxBy.smooth", "mpiBy.smooth", "cvBy.smooth", "mdcxBy.smooth", "mdcvBy.smooth", "micxBy.smooth", "micvBy.smooth", "lmpi.smooth"))) p <- beta.c ## if NOT those marked ## p <- if (inherits(x$smooth[[i]], c("mpdBy.smooth", "cxBy.smooth", "mpiBy.smooth", "cvBy.smooth", "mdcxBy.smooth", "mdcvBy.smooth", "micxBy.smooth", "micvBy.smooth", "lmpi.smooth"))) ## no changes in p here ## p ## else ## for ("mpi.smooth","mpd.smooth", "cv.smooth", "cx.smooth", "mdcv.smooth", "mdcx.smooth","micv.smooth","micx.smooth",))) centering constraint applied within smooth construction, so no need for the code below to apply a vertical shift to achieve the centered smooth.. ## beta.c ## below is before version 1.2-17 ## else { ## get a constant, a difference between two fits obtained by using 'zeroed ## ## intercept' constraint of the SCOP-spline and the centering constraint; ## ## centered-fit= SCOP-fit + const... ## ## this vertical shift to be applied to achieve the centered smooth term) ## const.dif <- -sum(fit.c)/n ## onet <- matrix(rep(1,n),1,n) ## A <- onet%*%P$X ## qrX <- qr(P$X) ## R <- qr.R(qrX) ## qrA <- qr(t(A)) ## R <- R[-1,] ## RZa <- t(qr.qty(qrA,t(R)))[,2:q] ## RZa.inv <- solve(RZa) ## RZaR <- RZa.inv%*%R ## beta.a <- RZaR%*%beta.c ## re-parametrized coeffs to meet centering ## ## identif. constraint ## p <- c(0,beta.a) ## p <- qr.qy(qrA,p) ## } if (inherits(x$smooth[[i]], c("mpiBy.smooth","mpdBy.smooth","ipo.smooth", "dpo.smooth"))) { ## to avoid high correlation between beta and the intercept, impose centering constraint for scop-splines that do not include centering const within smooth constraction... const.dif <- -sum(fit.c)/n onet <- matrix(rep(1,n),1,n) A <- onet%*%P$X qrX <- qr(P$X) R <- qr.R(qrX) qrA <- qr(t(A)) if (inherits(x$smooth[[i]], c("dpo.smooth"))) { R <- R[-q,] RZa <- t(qr.qty(qrA,t(R)))[,1:(q-1)] } else { R <- R[-1,] RZa <- t(qr.qty(qrA,t(R)))[,2:q] } RZa.inv <- solve(RZa) RZaR <- RZa.inv%*%R } } ## dealing with bivariate shape-constrained smooths... if (inherits(x$smooth[[i]], c("tedmi.smooth","tedmd.smooth", "tesmi1.smooth", "tismi.smooth", "tismd.smooth", "tesmi2.smooth","tesmd1.smooth", "tesmd2.smooth","temicx.smooth", "temicv.smooth","tedecx.smooth","tedecv.smooth","tescx.smooth", "tescv.smooth","tecvcv.smooth","tecxcx.smooth","tecxcv.smooth"))) { p.ident <- x$p.ident[first:last] iv <- (1:length(p))[p.ident] # define an index vector for the coeff-s to be exponentiated p[iv] <- if (!x$not.exp) exp(p[iv]) else notExp(p[iv],x$control$b.notexp,x$control$threshold.notexp) beta <- x$smooth[[i]]$Zc%*%p ## if(!is.null(x$smooth[[i]]$Zc)) x$smooth[[i]]$Zc%*%p else p # beta <- if (inherits(x$smooth[[i]], c("tismi.smooth", "tismd.smooth"))) p else x$smooth[[i]]$Zc%*%p fit.c <- P$X%*%beta # fitted values for the SCOP-spline identifiability constraints ## get a constant, a difference between two fits obtained by using 'zeroed intercept' constraint ## of the SCOP-spline and the centering constraint; centered.fit= SCOP.fit + const... const.dif <- -sum(fit.c)/length(fit.c) onet <- matrix(rep(1,nrow(P$X)),1,nrow(P$X)) A <- onet%*%P$X qrX <- qr(P$X) R <- qr.R(qrX) qrA <- qr(t(A)) q <- ncol(P$X) ## if (inherits(x$smooth[[i]], c("tismi.smooth", "tismd.smooth"))) ## { ## no re-parametrization for beta coeffs for smooth interaction... ## beta.a <- beta ## } else if (inherits(x$smooth[[i]], c("tedmi.smooth","tedmd.smooth","tedmdc.smooth", "temicx.smooth", "temicv.smooth", "tedecx.smooth", "tedecv.smooth","tecvcv.smooth","tecxcx.smooth","tecxcv.smooth"))) { # get `beta.a' for bivariate smooths s.t. double monotonicity... R <- R[-1,] RZa <- t(qr.qty(qrA,t(R)))[,2:q] RZa.inv <- solve(RZa) RZaR <- RZa.inv%*%R beta.a <- RZaR%*%beta ## re-parametrized coeffs to meet centering identif. constraint } else # get `beta.a' for bivariate smooths s.t. single monotonicity... { RZa <- t(qr.qty(qrA,t(R)))[,2:q] RZatRZa.inv <- solve(t(RZa)%*%RZa) Q <- qr.Q(qrX) B1 <- RZatRZa.inv%*%t(RZa) RZaR <- B1%*%R beta.a <- RZaR%*%beta + B1%*%(const.dif*colSums(Q)) } ## p <- if (inherits(x$smooth[[i]], c("tismi.smooth", "tismd.smooth"))) beta.a ## else qr.qy(qrA,c(0,beta.a)) p <- c(0,beta.a) p <- qr.qy(qrA,p) } ## end shape-constrained supplement ft <- P$X%*%p if (is.null(offset)) P$fit <- ft else P$fit <- ft + offset ## if (x$smooth[[i]]$by=="NA"){ ## if (is.null(offset)) P$fit <- ft ## get the fit with the centering identifiability constraint ## else P$fit <- ft + offset ## } else{ if (is.null(offset)) P$fit <- ft-const.dif ## 'zeroed intercept' SCOP.fit ## else P$fit <- ft + offset - const.dif ## } ## 'minus'- const.dif is applied to get back to the scop fit with the original 'zeroed intercept'constraint: ## SCOP.fit = centered.fit/ft - const(const.dif) if (!is.null(P$exclude)) P$fit[P$exclude] <- NA if (se && P$se) { ## get standard errors for fit ... if (inherits(x$smooth[[i]], c("mpi.smooth","mpd.smooth", "cv.smooth", "cx.smooth", "mdcv.smooth", "mdcx.smooth", "micv.smooth", "micx.smooth","po.smooth", "ipo.smooth","dpo.smooth","cpopspline.smooth", "mifo.smooth","miso.smooth", "mpdBy.smooth", "cxBy.smooth", "mpiBy.smooth", "cvBy.smooth", "mdcxBy.smooth", "mdcvBy.smooth", "micxBy.smooth", "micvBy.smooth", "lmpi.smooth", "lipl.smooth"))) { ## univariate scop smooths... if (inherits(x$smooth[[i]], c("miso.smooth","mifo.smooth"))) { Vp <- x$Vp.t[first:last, first:last] ind <- x$smooth[[i]]$n.zero ## adding rows and columns of 0's... Vp.c <- matrix(0,nrow(Vp)+length(ind),ncol(Vp)+length(ind)) Vp.c[-ind,-ind] <- Vp } else if (inherits(x$smooth[[i]], c("lipl.smooth"))) { ## Vp <- x$Vp.t[first:last, first:last] Vp <- x$Vp.t[c(1,first:last),c(1,first:last)] ind <- c((ncol(Vp)+1):(ncol(Vp)+ x$smooth[[i]]$n.zero.col)) ## adding rows and columns of 0's... Vp.c <- matrix(0,nrow(Vp)+length(ind),ncol(Vp)+length(ind)) Vp.c[-ind,-ind] <- Vp Vp.c[,1] <- rep(0,nrow(Vp.c)) Vp.c[1,] <- rep(0,ncol(Vp.c)) } else if (inherits(x$smooth[[i]], c("mpi.smooth", "mpd.smooth", "cv.smooth", "cx.smooth", "mdcv.smooth", "mdcx.smooth", "micv.smooth", "micx.smooth", "mpdBy.smooth", "cxBy.smooth","mpiBy.smooth","cvBy.smooth", "mdcxBy.smooth", "mdcvBy.smooth", "micxBy.smooth", "micvBy.smooth", "lmpi.smooth"))) { Vp.c <- x$Vp.t[first:last, first:last] } else if (inherits(x$smooth[[i]], c("dpo.smooth"))) { Vp.c <- x$Vp.t[c(first:last,1),c(first:last,1)] Vp.c[,q] <- rep(0,nrow(Vp.c)) Vp.c[q,] <- rep(0,ncol(Vp.c)) } else { Vp.c <- x$Vp.t[c(1,first:last),c(1,first:last)] # Vp.c <- Vp Vp.c[,1] <- rep(0,nrow(Vp.c)) Vp.c[1,] <- rep(0,ncol(Vp.c)) } ## since for univariate dicreasing/increasing, convex/concave, mixed constraints, 'centering' contraint is now applied after imposing the scop constraints within each smooth constructor, there is no need for centering the smooth after the fit ## if (inherits(x$smooth[[i]], c("po.smooth","mifo.smooth","miso.smooth","mpdBy.smooth", "cxBy.smooth", "mpiBy.smooth", "cvBy.smooth", "mdcxBy.smooth","mdcvBy.smooth","micxBy.smooth","micvBy.smooth", "lmpi.smooth"))) { ## se.fit <- sqrt(rowSums((P$X%*%Vp.c)*P$X)) ## } else { ## XZa <- t(qr.qty(qrA,t(P$X)))[,2:q] ## Ga <- XZa%*%RZaR ## se.fit <- sqrt(rowSums((Ga%*%Vp.c)*Ga)) ## } if (inherits(x$smooth[[i]], c("mpiBy.smooth","mpdBy.smooth","ipo.smooth", "dpo.smooth"))) { ## , "cpopspline.smooth" XZa <- if (inherits(x$smooth[[i]], c("dpo.smooth"))) t(qr.qty(qrA,t(P$X)))[,1:(q-1)] ## else if (inherits(x$smooth[[i]], c("po.smooth"))) t(qr.qty(qrA,t(P$X))) else t(qr.qty(qrA,t(P$X)))[,2:q] Ga <- XZa%*%RZaR se.fit <- sqrt(pmax(0,rowSums((Ga%*%Vp.c)*Ga))) } else se.fit <- sqrt(rowSums((P$X%*%Vp.c)*P$X)) } else if (inherits(x$smooth[[i]], c("tedmi.smooth", "tedmd.smooth", "tesmi1.smooth","tesmi2.smooth", "tismi.smooth", "tismd.smooth", "tesmd1.smooth", "tesmd2.smooth","temicx.smooth", "temicv.smooth", "tedecx.smooth", "tedecv.smooth","tescx.smooth","tescv.smooth","tecvcv.smooth","tecxcx.smooth","tecxcv.smooth"))) { ## bivariate scop smooths... XZa <- t(qr.qty(qrA,t(P$X)))[,2:ncol(P$X)] Ga <- XZa%*%RZaR%*%x$smooth[[i]]$Zc ## if(!is.null(x$smooth[[i]]$Zc)) XZa%*%RZaR%*%x$smooth[[i]]$Zc else XZa%*%RZaR # Vp <- x$Vp.t[first:last,first:last] # se.fit <- rowSums((Ga%*%Vp)*Ga)^.5 se.fit <- sqrt(pmax(0,rowSums((Ga%*%x$Vp.t[first:last,first:last,drop=FALSE] )*Ga))) ## } else if (inherits(x$smooth[[i]], c("mipoc.smooth"))) { ## shape constrained with a point constraint... # se.fit <- sqrt(pmax(0,rowSums((P$X%*%x$Vp.t[first:last,first:last,drop=FALSE])*P$X))) } else { ## unconstrained smooths... ## test whether mean variability to be added to variability (only for centred terms) if (seWithMean && attr(x$smooth[[i]],"nCons")>0) { if (length(x$cmX) < ncol(x$Vp)) x$cmX <- c(x$cmX,rep(0,ncol(x$Vp)-length(x$cmX))) X1 <- matrix(x$cmX,nrow(P$X),ncol(x$Vp),byrow=TRUE) meanL1 <- x$smooth[[i]]$meanL1 if (!is.null(meanL1)) X1 <- X1 / meanL1 X1[,first:last] <- P$X se.fit <- sqrt(pmax(0,rowSums((X1%*%x$Vp)*X1))) } else se.fit <- ## se in centred (or anyway unconstained) space only sqrt(pmax(0,rowSums((P$X%*%x$Vp[first:last,first:last,drop=FALSE])*P$X))) if (!is.null(P$exclude)) P$se.fit[P$exclude] <- NA } } ## standard errors for fit completed if (partial.resids) { P$p.resid <- fv.terms[,length(order)+i] + w.resid ## if (inherits(x$smooth[[i]], c("mpd.smooth", "cv.smooth", "cx.smooth", "mdcv.smooth", ## "mdcx.smooth", "micv.smooth", "micx.smooth"))) ## "mpi.smooth", ## P$p.resid <- P$p.resid + const.dif ## to shift the resid/fitted smooth, to get a centering smooth, as ## ## centered.fit= SCOP.fit + const(const.dif) } if (se && P$se) P$se <- se.fit*P$se.mult # Note multiplier P$X <- NULL P$plot.me <- TRUE pd[[i]] <- P;rm(P) } else { ## P$fit created directly (from if (is.null(P$fit))) if (partial.resids) { P$p.resid <- fv.terms[,length(order)+i] + w.resid } P$plot.me <- TRUE pd[[i]] <- P;rm(P) } } ## end of data setup loop through smooths ############################################## ## sort out number of pages and plots per page ############################################## n.plots <- n.para if (m>0) for (i in 1:m) n.plots <- n.plots + as.numeric(pd[[i]]$plot.me) if (n.plots==0) stop("No terms to plot - nothing for plot.scam() to do.") if (pages>n.plots) pages<-n.plots if (pages<0) pages<-0 if (pages!=0) # figure out how to display things { ppp<-n.plots%/%pages if (n.plots%%pages!=0) { ppp<-ppp+1 while (ppp*(pages-1)>=n.plots) pages<-pages-1 } # now figure out number of rows and columns c <- r <- trunc(sqrt(ppp)) if (c<1) r <- c <- 1 if (c*r < ppp) c <- c + 1 if (c*r < ppp) r <- r + 1 oldpar<-par(mfrow=c(r,c)) } else { ppp<-1;oldpar<-par()} if ((pages==0&&prod(par("mfcol"))1&&dev.interactive()) ask <- TRUE else ask <- FALSE if (!is.null(select)) { ask <- FALSE } if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } ##################################### ## get a common scale, if required... ##################################### if (scale==-1&&is.null(ylim)) { k <- 0 if (m>0) for (i in 1:m) if (pd[[i]]$plot.me&&pd[[i]]$scale) { ## loop through plot data if (se&&length(pd[[i]]$se)>1) { ## require CIs on plots ul<-pd[[i]]$fit+pd[[i]]$se ll<-pd[[i]]$fit-pd[[i]]$se if (k==0) { ylim <- c(min(ll,na.rm=TRUE),max(ul,na.rm=TRUE));k <- 1 } else { if (min(ll,na.rm=TRUE)ylim[2]) ylim[2] <- max(ul,na.rm=TRUE) } } else { ## no standard errors if (k==0) { ylim <- range(pd[[i]]$fit,na.rm=TRUE);k <- 1 } else { if (min(pd[[i]]$fit,na.rm=TRUE)ylim[2]) ylim[2] <- max(pd[[i]]$fit,na.rm=TRUE) } } if (partial.resids) { ul <- max(pd[[i]]$p.resid,na.rm=TRUE) if (ul > ylim[2]) ylim[2] <- ul ll <- min(pd[[i]]$p.resid,na.rm=TRUE) if (ll < ylim[1]) ylim[1] <- ll } ## partial resids done } ## loop end } ## end of common scale computation ############################################################## ## now plot smooths, by calling plot methods with plot data... ############################################################## if (m>0) for (i in 1:m) if (pd[[i]]$plot.me&&(is.null(select)||i==select)) { plot(x$smooth[[i]],P=pd[[i]],partial.resids=partial.resids,rug=rug,se=se,scale=scale,n=n,n2=n2, pers=pers,theta=theta,phi=phi,jit=jit,xlab=xlab,ylab=ylab,main=main, ylim=ylim,xlim=xlim,too.far=too.far,shade=shade,shade.col=shade.col, shift=shift,trans=trans,by.resids=by.resids,scheme=scheme[i],...) } ## end of smooth plotting loop #################################################### ## Finally deal with any parametric term plotting... #################################################### if (n.para>0) # plot parameteric terms { class(x) <- c("scam", "gam","glm","lm") # needed to get termplot to call model.frame.glm if (is.null(select)) { attr(x,"para.only") <- TRUE termplot(x,se=se,rug=rug,col.se=1,col.term=1,main=attr(x$pterms,"term.labels"),...) } else { # figure out which plot is required if (select > m) { ## can't figure out how to get this to work with more than first linear predictor ## as termplots relies on matching terms to names in original data... select <- select - m # i.e. which parametric term term.labels <- attr(x$pterms,"term.labels") term.labels <- term.labels[order==1] if (select <= length(term.labels)) { # if (interactive() && m &&i%%ppp==0) termplot(x,terms=term.labels[select],se=se,rug=rug,col.se=1,col.term=1,...) } } } } if (pages>0) par(oldpar) invisible(pd) } ## end plot.scam ## NOTE: 'centering' constraints applied after the fit in plot.scam function to only "mpiBy.smooth","mpdBy.smooth","ipo.smooth", "dpo.smooth". maybe to apply it to other six 'by' scop-splines? although, short simulation study doesn't show issue with high correlation between the intercept and smooth coefficients... predict.scam() function includes coef. re-parametrization due to 'centering' constraint only for "ipo.smooth", "dpo.smooth". ####################################################################################### ## below is copied from plots.r of the package mgcv (c) Simon Wood 2000-2017... ## the routines are plot method functions for smooths of the mgcv, which are needed ## if the scam model includes those ... ####################################################################################### plot.random.effect <- function(x,P=NULL,data=NULL,label="",se1.mult=1,se2.mult=2, partial.resids=FALSE,rug=TRUE,se=TRUE,scale=-1,n=100,n2=40, pers=FALSE,theta=30,phi=30,jit=FALSE,xlab=NULL,ylab=NULL,main=NULL, ylim=NULL,xlim=NULL,too.far=0.1,shade=FALSE,shade.col="gray80", shift=0,trans=I,by.resids=FALSE,scheme=0,...) { ## plot method for a "random.effect" smooth class if (is.null(P)) { ## get plotting information... if (!x$plot.me) return(NULL) else { ## shouldn't or can't plot raw <- data[x$term][[1]] p <- x$last.para - x$first.para + 1 X <- diag(p) # prediction matrix for this term if (is.null(xlab)) xlabel<- "Gaussian quantiles" else xlabel <- xlab if (is.null(ylab)) ylabel <- "effects" else ylabel <- ylab if (!is.null(main)) label <- main return(list(X=X,scale=FALSE,se=FALSE,raw=raw,xlab=xlabel,ylab=ylabel, main=label)) } ## end of basic plot data production } else { ## produce plot qqnorm(P$fit,main=P$main,xlab=P$xlab,ylab=P$ylab,...) qqline(P$fit) } ## end of plot production } ## end of plot.random.effect plot.mgcv.smooth <- function(x,P=NULL,data=NULL,label="",se1.mult=1,se2.mult=2, partial.resids=FALSE,rug=TRUE,se=TRUE,scale=-1,n=100,n2=40, pers=FALSE,theta=30,phi=30,jit=FALSE,xlab=NULL,ylab=NULL,main=NULL, ylim=NULL,xlim=NULL,too.far=0.1,shade=FALSE,shade.col="gray80", shift=0,trans=I,by.resids=FALSE,scheme=0,...) { ## default plot method for smooth objects `x' inheriting from "mgcv.smooth" ## `x' is a smooth object, usually part of a `gam' fit. It has an attribute ## 'coefficients' containg the coefs for the smooth, but usually these ## are not needed. ## `P' is a list of plot data. ## If `P' is NULL then the routine should compute some of this plot data ## and return without plotting... ## * X the matrix mapping the smooth's coefficients to the values at ## which the smooth must be computed for plotting. ## * The values against which to plot. ## * `exclude' indicates rows of X%*%p to set to NA for plotting -- NULL for none. ## * se TRUE if plotting of the term can use standard error information. ## * scale TRUE if the term should be considered by plot.gam if a common ## y scale is required. ## * any raw data information. ## * axis labels and plot titles ## As an alternative, P may contain a 'fit' field directly, in which case the ## very little processing is done outside the routine, except for partial residual ## computations. ## Alternatively return P as NULL if x should not be plotted. ## If P is not NULL it will contain ## * fit - the values for plotting ## * se.fit - standard errors of fit (can be NULL) ## * the values against which to plot ## * any raw data information ## * any partial.residuals ## `data' is a data frame containing the raw data for the smooth, usually the ## model.frame of the fitted gam. Can be NULL if P is not NULL. ## `label' is the term label, usually something like e.g. `s(x,12.34)'. ############################# sp.contour <- function(x,y,z,zse,xlab="",ylab="",zlab="",titleOnly=FALSE, se.plot=TRUE,se.mult=1,trans=I,shift=0,...) ## function for contouring 2-d smooths with 1 s.e. limits { gap<-median(zse,na.rm=TRUE) zr<-max(trans(z+zse+shift),na.rm=TRUE)-min(trans(z-zse+shift),na.rm=TRUE) # plotting range n<-10 while (n>1 && zr/n<2.5*gap) n<-n-1 zrange<-c(min(trans(z-zse+shift),na.rm=TRUE),max(trans(z+zse+shift),na.rm=TRUE)) zlev<-pretty(zrange,n) ## ignore codetools on this one yrange<-range(y);yr<-yrange[2]-yrange[1] xrange<-range(x);xr<-xrange[2]-xrange[1] ypos<-yrange[2]+yr/10 args <- as.list(substitute(list(...)))[-1] args$x <- substitute(x);args$y <- substitute(y) args$type="n";args$xlab<-args$ylab<-"";args$axes<-FALSE do.call("plot",args) cs<-(yr/10)/strheight(zlab);if (cs>1) cs<-1 # text scaling based on height tl<-strwidth(zlab); if (tl*cs>3*xr/10) cs<-(3*xr/10)/tl args <- as.list(substitute(list(...)))[-1] n.args <- names(args) zz <- trans(z+shift) ## ignore codetools for this args$x<-substitute(x);args$y<-substitute(y);args$z<-substitute(zz) if (!"levels"%in%n.args) args$levels<-substitute(zlev) if (!"lwd"%in%n.args) args$lwd<-2 if (!"labcex"%in%n.args) args$labcex<-cs*.65 if (!"axes"%in%n.args) args$axes <- FALSE if (!"add"%in%n.args) args$add <- TRUE do.call("contour",args) if (is.null(args$cex.main)) cm <- 1 else cm <- args$cex.main if (titleOnly) title(zlab,cex.main=cm) else { xpos<-xrange[1]+3*xr/10 xl<-c(xpos,xpos+xr/10); yl<-c(ypos,ypos) lines(xl,yl,xpd=TRUE,lwd=args$lwd) text(xpos+xr/10,ypos,zlab,xpd=TRUE,pos=4,cex=cs*cm,off=0.5*cs*cm) } if (is.null(args$cex.axis)) cma <- 1 else cma <- args$cex.axis axis(1,cex.axis=cs*cma);axis(2,cex.axis=cs*cma);box(); if (is.null(args$cex.lab)) cma <- 1 else cma <- args$cex.lab mtext(xlab,1,2.5,cex=cs*cma);mtext(ylab,2,2.5,cex=cs*cma) if (!"lwd"%in%n.args) args$lwd<-1 if (!"lty"%in%n.args) args$lty<-2 if (!"col"%in%n.args) args$col<-2 if (!"labcex"%in%n.args) args$labcex<-cs*.5 zz <- trans(z+zse+shift) args$z<-substitute(zz) do.call("contour",args) if (!titleOnly) { xpos<-xrange[1] xl<-c(xpos,xpos+xr/10)#;yl<-c(ypos,ypos) lines(xl,yl,xpd=TRUE,lty=args$lty,col=args$col) text(xpos+xr/10,ypos,paste("-",round(se.mult),"se",sep=""),xpd=TRUE,pos=4,cex=cs*cm,off=0.5*cs*cm) } if (!"lty"%in%n.args) args$lty<-3 if (!"col"%in%n.args) args$col<-3 zz <- trans(z - zse+shift) args$z<-substitute(zz) do.call("contour",args) if (!titleOnly) { xpos<-xrange[2]-xr/5 xl<-c(xpos,xpos+xr/10); lines(xl,yl,xpd=TRUE,lty=args$lty,col=args$col) text(xpos+xr/10,ypos,paste("+",round(se.mult),"se",sep=""),xpd=TRUE,pos=4,cex=cs*cm,off=0.5*cs*cm) } } ## end of sp.contour if (is.null(P)) { ## get plotting information... if (!x$plot.me||x$dim>2) return(NULL) ## shouldn't or can't plot if (x$dim==1) { ## get basic plotting data for 1D terms raw <- data[x$term][[1]] if (is.null(xlim)) xx <- seq(min(raw),max(raw),length=n) else # generate x sequence for prediction xx <- seq(xlim[1],xlim[2],length=n) if (x$by!="NA") # deal with any by variables { by<-rep(1,n);dat<-data.frame(x=xx,by=by) names(dat)<-c(x$term,x$by) } else { dat<-data.frame(x=xx);names(dat) <- x$term } ## prediction data.frame finished X <- PredictMat(x,dat) # prediction matrix for this term if (is.null(xlab)) xlabel<- x$term else xlabel <- xlab if (is.null(ylab)) ylabel <- label else ylabel <- ylab if (is.null(xlim)) xlim <- range(xx) return(list(X=X,x=xx,scale=TRUE,se=TRUE,raw=raw,xlab=xlabel,ylab=ylabel, main=main,se.mult=se1.mult,xlim=xlim)) } else { ## basic plot data for 2D terms xterm <- x$term[1] if (is.null(xlab)) xlabel <- xterm else xlabel <- xlab yterm <- x$term[2] if (is.null(ylab)) ylabel <- yterm else ylabel <- ylab raw <- data.frame(x=as.numeric(data[xterm][[1]]), y=as.numeric(data[yterm][[1]])) n2 <- max(10,n2) if (is.null(xlim)) xm <- seq(min(raw$x),max(raw$x),length=n2) else xm <- seq(xlim[1],xlim[2],length=n2) if (is.null(ylim)) ym <- seq(min(raw$y),max(raw$y),length=n2) else ym <- seq(ylim[1],ylim[2],length=n2) xx <- rep(xm,n2) yy <- rep(ym,rep(n2,n2)) if (too.far>0) exclude <- exclude.too.far(xx,yy,raw$x,raw$y,dist=too.far) else exclude <- rep(FALSE,n2*n2) if (x$by!="NA") # deal with any by variables { by <- rep(1,n2^2);dat <- data.frame(x=xx,y=yy,by=by) names(dat) <- c(xterm,yterm,x$by) } else { dat<-data.frame(x=xx,y=yy);names(dat)<-c(xterm,yterm) } ## prediction data.frame complete X <- PredictMat(x,dat) ## prediction matrix for this term if (is.null(main)) { main <- label } if (is.null(ylim)) ylim <- range(ym) if (is.null(xlim)) xlim <- range(xm) return(list(X=X,x=xm,y=ym,scale=FALSE,se=TRUE,raw=raw,xlab=xlabel,ylab=ylabel, main=main,se.mult=se2.mult,ylim=ylim,xlim=xlim,exclude=exclude)) } ## end of 2D basic plot data production } else { ## produce plot if (se) { ## produce CI's if (x$dim==1) { if (scheme == 1) shade <- TRUE ul <- P$fit + P$se ## upper CL ll <- P$fit - P$se ## lower CL if (scale==0&&is.null(ylim)) { ## get scale ylimit<-c(min(ll),max(ul)) if (partial.resids) { max.r <- max(P$p.resid,na.rm=TRUE) if ( max.r> ylimit[2]) ylimit[2] <- max.r min.r <- min(P$p.resid,na.rm=TRUE) if (min.r < ylimit[1]) ylimit[1] <- min.r } } if (!is.null(ylim)) ylimit <- ylim ## plot the smooth... if (shade) { plot(P$x,trans(P$fit+shift),type="n",xlab=P$xlab,ylim=trans(ylimit+shift), xlim=P$xlim,ylab=P$ylab,main=P$main,...) polygon(c(P$x,P$x[n:1],P$x[1]), trans(c(ul,ll[n:1],ul[1])+shift),col = shade.col,border = NA) lines(P$x,trans(P$fit+shift),...) } else { ## ordinary plot plot(P$x,trans(P$fit+shift),type="l",xlab=P$xlab,ylim=trans(ylimit+shift),xlim=P$xlim, ylab=P$ylab,main=P$main,...) if (is.null(list(...)[["lty"]])) { lines(P$x,trans(ul+shift),lty=2,...) lines(P$x,trans(ll+shift),lty=2,...) } else { lines(P$x,trans(ul+shift),...) lines(P$x,trans(ll+shift),...) } } ## ... smooth plotted if (partial.resids&&(by.resids||x$by=="NA")) { ## add any partial residuals if (length(P$raw)==length(P$p.resid)) { if (is.null(list(...)[["pch"]])) points(P$raw,trans(P$p.resid+shift),pch=".",...) else points(P$raw,trans(P$p.resid+shift),...) } else { warning("Partial residuals do not have a natural x-axis location for linear functional terms") } } ## partial residuals finished if (rug) { if (jit) rug(jitter(as.numeric(P$raw)),...) else rug(as.numeric(P$raw),...) } ## rug plot done } else if (x$dim==2) { P$fit[P$exclude] <- NA if (pers) scheme <- 1 if (scheme == 1) { ## perspective plot persp(P$x,P$y,matrix(trans(P$fit+shift),n2,n2),xlab=P$xlab,ylab=P$ylab, zlab=P$main,ylim=P$ylim,xlim=P$xlim,theta=theta,phi=phi,...) } else if (scheme==2) { image(P$x,P$y,matrix(trans(P$fit+shift),n2,n2),xlab=P$xlab,ylab=P$ylab, main=P$main,xlim=P$xlim,ylim=P$ylim,col=heat.colors(50),...) contour(P$x,P$y,matrix(trans(P$fit+shift),n2,n2),add=TRUE,col=3,...) if (rug) { if (is.null(list(...)[["pch"]])) points(P$raw$x,P$raw$y,pch=".",...) else points(P$raw$x,P$raw$y,...) } } else { ## contour plot with error contours sp.contour(P$x,P$y,matrix(P$fit,n2,n2),matrix(P$se,n2,n2), xlab=P$xlab,ylab=P$ylab,zlab=P$main,titleOnly=!is.null(main), se.mult=1,trans=trans,shift=shift,...) if (rug) { if (is.null(list(...)[["pch"]])) points(P$raw$x,P$raw$y,pch=".",...) else points(P$raw$x,P$raw$y,...) } } ## counter plot done } else { warning("no automatic plotting for smooths of more than two variables") } } else { ## no CI's if (x$dim==1) { if (scale==0&&is.null(ylim)) { if (partial.resids) ylimit <- range(P$p.resid,na.rm=TRUE) else ylimit <-range(P$fit) } if (!is.null(ylim)) ylimit <- ylim plot(P$x,trans(P$fit+shift),type="l",xlab=P$xlab, ylab=P$ylab,ylim=trans(ylimit+shift),xlim=P$xlim,main=P$main,...) if (rug) { if (jit) rug(jitter(as.numeric(P$raw)),...) else rug(as.numeric(P$raw),...) } if (partial.resids&&(by.resids||x$by=="NA")) { if (is.null(list(...)[["pch"]])) points(P$raw,trans(P$p.resid+shift),pch=".",...) else points(P$raw,trans(P$p.resid+shift),...) } } else if (x$dim==2) { P$fit[P$exclude] <- NA if (!is.null(main)) P$title <- main if (pers) scheme <- 1 if (scheme==1) { persp(P$x,P$y,matrix(trans(P$fit+shift),n2,n2),xlab=P$xlab,ylab=P$ylab, zlab=P$main,theta=theta,phi=phi,xlim=P$xlim,ylim=P$ylim,...) } else if (scheme==2) { image(P$x,P$y,matrix(trans(P$fit+shift),n2,n2),xlab=P$xlab,ylab=P$ylab, main=P$main,xlim=P$xlim,ylim=P$ylim,col=heat.colors(50),...) contour(P$x,P$y,matrix(trans(P$fit+shift),n2,n2),add=TRUE,col=3,...) if (rug) { if (is.null(list(...)[["pch"]])) points(P$raw$x,P$raw$y,pch=".",...) else points(P$raw$x,P$raw$y,...) } } else { contour(P$x,P$y,matrix(trans(P$fit+shift),n2,n2),xlab=P$xlab,ylab=P$ylab, main=P$main,xlim=P$xlim,ylim=P$ylim,...) if (rug) { if (is.null(list(...)[["pch"]])) points(P$raw$x,P$raw$y,pch=".",...) else points(P$raw$x,P$raw$y,...) } } } else { warning("no automatic plotting for smooths of more than one variable") } } ## end of no CI code } ## end of plot production } repole <- function(lo,la,lop,lap) { ## painfully plodding function to get new lo, la relative to pole at ## lap,lop... ## x,y,z location of pole... yp <- sin(lap) xp <- cos(lap)*sin(lop) zp <- cos(lap)*cos(lop) ## x,y,z location of meridian point for pole - i.e. point lat pi/2 ## from pole on pole's lon. ym <- sin(lap-pi/2) xm <- cos(lap-pi/2)*sin(lop) zm <- cos(lap-pi/2)*cos(lop) ## x,y,z locations of points in la, lo y <- sin(la) x <- cos(la)*sin(lo) z <- cos(la)*cos(lo) ## get angle between points and new equatorial plane (i.e. plane orthogonal to pole) d <- sqrt((x-xp)^2+(y-yp)^2+(z-zp)^2) ## distance from points to to pole phi <- pi/2-2*asin(d/2) ## location of images of la,lo on (new) equatorial plane ## sin(phi) gives distance to plane, -(xp, yp, zp) is ## direction... x <- x - xp*sin(phi) y <- y - yp*sin(phi) z <- z - zp*sin(phi) ## get distances to meridian point d <- sqrt((x-xm)^2+(y-ym)^2+(z-zm)^2) ## angles to meridian plane (i.e. plane containing origin, meridian point and pole)... theta <- (1+cos(phi)^2-d^2)/(2*cos(phi)) theta[theta < -1] <- -1; theta[theta > 1] <- 1 theta <- acos(theta) ## now decide which side of meridian plane... ## get points at extremes of hemispheres on either side ## of meridian plane.... y1 <- 0 x1 <- sin(lop+pi/2) z1 <- cos(lop+pi/2) y0 <- 0 x0 <- sin(lop-pi/2) z0 <- cos(lop-pi/2) d1 <- sqrt((x-x1)^2+(y-y1)^2+(z-z1)^2) d0 <- sqrt((x-x0)^2+(y-y0)^2+(z-z0)^2) ii <- d0 < d1 ## index -ve lon hemisphere theta[ii] <- -theta[ii] list(lo=theta,la=phi) } ## end of repole lolaxy <- function(lo,la,theta,phi) { ## takes locations lo,la, relative to a pole at lo=theta, la=phi. ## theta, phi are expressed relative to plotting co-ordinate system ## with pole at top. Convert to x,y in plotting co-ordinates. ## all in radians! er <- repole(-lo,la,-pi,phi) er$lo <- er$lo - theta y <- sin(er$la) x <- cos(er$la)*sin(er$lo) z <- cos(er$la)*cos(er$lo) ind <- z<0 list(x=x[ind],y=y[ind]) } ## end of lolaxy plot.sos.smooth <- function(x,P=NULL,data=NULL,label="",se1.mult=2,se2.mult=1, partial.resids=FALSE,rug=TRUE,se=TRUE,scale=-1,n=100,n2=40,n3=3, pers=FALSE,theta=30,phi=30,jit=FALSE,xlab=NULL,ylab=NULL,main=NULL, ylim=NULL,xlim=NULL,too.far=0.1,shade=FALSE,shade.col="gray80", shift=0,trans=I,by.resids=FALSE,scheme=0,hcolors=heat.colors(100), contour.col=4,...) { ## plot method function for sos.smooth terms if (scheme>1) return(plot.mgcv.smooth(x,P=P,data=data,label=label,se1.mult=se1.mult,se2.mult=se2.mult, partial.resids=partial.resids,rug=rug,se=se,scale=scale,n=n,n2=n2, pers=pers,theta=theta,phi=phi,jit=jit,xlab=xlab,ylab=ylab,main=main, ylim=ylim,xlim=xlim,too.far=too.far,shade=shade,shade.col=shade.col, shift=shift,trans=trans,by.resids=by.resids,scheme=scheme-2, hcolors=hcolors,contour.col=contour.col,...)) ## convert location of pole in plotting grid to radians phi <- phi*pi/180 theta <- theta*pi/180 ## re-map to sensible values... theta <- theta%%(2*pi) if (theta>pi) theta <- theta - 2*pi phi <- phi%%(2*pi) if (phi > pi) phi <- phi - 2*pi if (phi > pi/2) phi <- pi - phi if (phi < -pi/2 ) phi <- -(phi+pi) if (is.null(P)) { ## get plotting information... if (!x$plot.me) return(NULL) ## shouldn't or can't plot ## get basic plot data raw <- data[x$term] if (rug) { ## need to project data onto plotting grid... raw <- lolaxy(lo=raw[[2]]*pi/180,la=raw[[1]]*pi/180,theta,phi) } m <- round(n2*1.5) ym <- xm <- seq(-1,1,length=m) gr <- expand.grid(x=xm,y=ym) r <- z <- gr$x^2+gr$y^2 z[z>1] <- NA z <- sqrt(1-z) ## generate la, lo in plotting grid co-ordinates... ind <- !is.na(z) r <- r[ind] la <- asin(gr$y[ind]) lo <- cos(la) lo <- asin(gr$x[ind]/lo) um <- repole(lo,la,theta,phi) dat <- data.frame(la=um$la*180/pi,lo=um$lo*180/pi) names(dat) <- x$term if (x$by!="NA") dat[[x$by]] <- la*0+1 X <- PredictMat(x,dat) # prediction matrix for this term ## fix lo for smooth contouring lo <- dat[[2]] ii <- lo <= -177 lo[ii] <- lo[ii] <- 360 + lo[ii] ii <- lo < -165 & lo > -177 ii <- ii | (abs(dat[[1]])>80) lo[ii] <- NA return(list(X=X,scale=FALSE,se=FALSE,raw=raw,xlab="",ylab="",main="", ind=ind,xm=xm,ym=ym,lo=lo,la=dat[[1]])) } else { ## do plot op <- par(pty="s",mar=c(0,0,0,0)) m <- length(P$xm); zz <- rep(NA,m*m) if (scheme == 0) { col <- 1# "lightgrey zz[P$ind] <- trans(P$fit+shift) image(P$xm,P$ym,matrix(zz,m,m),col=hcolors,axes=FALSE,xlab="",ylab="",...) if (rug) { if (is.null(list(...)[["pch"]])) points(P$raw$x,P$raw$y,pch=".",...) else points(P$raw$x,P$raw$y,...) } zz[P$ind] <- P$la contour(P$xm,P$ym,matrix(zz,m,m),add=TRUE,levels=c(-8:8*10),col=col,...) zz[P$ind] <- P$lo contour(P$xm,P$ym,matrix(zz,m,m),add=TRUE,levels=c(-8:9*20),col=col,...) zz[P$ind] <- P$fit contour(P$xm,P$ym,matrix(zz,m,m),add=TRUE,col=contour.col,...) } else if (scheme == 1) { col <- 1 zz[P$ind] <- trans(P$fit+shift) contour(P$xm,P$ym,matrix(zz,m,m),col=1,axes=FALSE,xlab="",ylab="",...) if (rug) { if (is.null(list(...)[["pch"]])) points(P$raw$x,P$raw$y,pch=".",...) else points(P$raw$x,P$raw$y,...) } zz[P$ind] <- P$la contour(P$xm,P$ym,matrix(zz,m,m),add=TRUE,levels=c(-8:8*10),col=col,lty=2,...) zz[P$ind] <- P$lo contour(P$xm,P$ym,matrix(zz,m,m),add=TRUE,levels=c(-8:9*20),col=col,lty=2,...) theta <- seq(-pi/2,pi/2,length=200) x <- sin(theta);y <- cos(theta) x <- c(x,x[200:1]);y <- c(y,-y[200:1]) lines(x,y) } par(op) } } ## end plot.sos.smooth poly2 <- function(x,col) { ## let x be a 2 col matrix defining some polygons. ## Different closed loop sections are separated by ## NA rows. This routine assumes that loops nested within ## other loops are holes (further nesting gives and island ## in hole, etc). Holes are left unfilled. ## The first polygon should not be a hole. ind <- (1:nrow(x))[is.na(rowSums(x))] ## where are the splits? if (length(ind)==0|| ind[1]==nrow(x)) polygon(x,col=col,border="black") else { base <- x[1,] xf <- x xf[ind,1] <- base[1] xf[ind,2] <- base[2] if (!is.na(col)) polygon(xf,col=col,border=NA,fillOddEven=TRUE) polygon(x,border="black") } } ## poly2 polys.plot <- function(pc,z=NULL,scheme="heat",lab="",...) { ## pc is a list of polygons defining area boundaries ## pc[[i]] is the 2 col matrix of vertex co-ords for polygons defining ## boundary of area i ## z gives the value associated with the area ## first find the axes ranges... for (i in 1:length(pc)) { yr <- range(pc[[i]][,2],na.rm=TRUE) xr <- range(pc[[i]][,1],na.rm=TRUE) if (i==1) { ylim <- yr xlim <- xr } else { if (yr[1]ylim[2]) ylim[2] <- yr[2] if (xr[1]xlim[2]) xlim[2] <- xr[2] } } ## end of axes range loop mar <- par("mar"); oldpar <- par(mar=c(2,mar[2],2,1)) if (is.null(z)) { ## no z value, no shading, no scale, just outlines... plot(0,0,ylim=ylim,xlim=xlim,xaxt="n",yaxt="n",type="n",bty="n",ylab=lab,xlab="",...) for (i in 1:length(pc)) { poly2(pc[[i]],col=NA) } } else { nz <- names(z) npc <- names(pc) if (!is.null(nz)&&!is.null(npc)) { ## may have to re-order z into pc order. if (all.equal(sort(nz),sort(npc))!=TRUE) stop("names of z and pc must match") z <- z[npc] } xmin <- xlim[1] xlim[1] <- xlim[1] - .1 * (xlim[2]-xlim[1]) ## allow space for scale n.col <- 100 if (scheme=="heat") scheme <- heat.colors(n.col+1) else scheme <- gray(0:n.col/n.col) zlim <- range(pretty(z)) ## Now want a grey or color scale up the lhs of plot ## first scale the y range into the z range for plotting for (i in 1:length(pc)) pc[[i]][,2] <- zlim[1] + (zlim[2]-zlim[1])*(pc[[i]][,2]-ylim[1])/(ylim[2]-ylim[1]) ylim <- zlim plot(0,0,ylim=ylim,xlim=xlim,type="n",xaxt="n",bty="n",xlab="",ylab=lab,...) for (i in 1:length(pc)) { coli <- round((z[i] - zlim[1])/(zlim[2]-zlim[1])*n.col)+1 poly2(pc[[i]],col=scheme[coli]) } ## now plot the scale bar... xmin <- min(c(axTicks(1),xlim[1])) dx <- (xlim[2]-xlim[1])*.05 x0 <- xmin-2*dx x1 <- xmin+dx dy <- (ylim[2]-ylim[1])/n.col poly <- matrix(c(x0,x0,x1,x1,ylim[1],ylim[1]+dy,ylim[1]+dy,ylim[1]),4,2) for (i in 1:n.col) { polygon(poly,col=scheme[i],border=NA) poly[,2] <- poly[,2] + dy } poly <- matrix(c(x0,x0,x1,x1,ylim[1],ylim[2],ylim[2],ylim[1]),4,2) polygon(poly,border="black") } par(oldpar) } ## polys.plot plot.mrf.smooth <- function(x,P=NULL,data=NULL,label="",se1.mult=2,se2.mult=1, partial.resids=FALSE,rug=TRUE,se=TRUE,scale=-1,n=100,n2=40,n3=3, pers=FALSE,theta=30,phi=30,jit=FALSE,xlab=NULL,ylab=NULL,main=NULL, ylim=NULL,xlim=NULL,too.far=0.1,shade=FALSE,shade.col="gray80", shift=0,trans=I,by.resids=FALSE,scheme=0,...) { ## plot method function for mrf.smooth terms, depends heavily on polys.plot, above if (is.null(P)) { ## get plotting information... if (!x$plot.me||is.null(x$xt$polys)) return(NULL) ## shouldn't or can't plot ## get basic plot data raw <- data[x$term][[1]] dat <- data.frame(x=factor(names(x$xt$polys),levels=levels(x$knots))) names(dat) <- x$term x$by <- "NA" X <- PredictMat(x,dat) # prediction matrix for this term if (is.null(xlab)) xlabel<- "" else xlabel <- xlab if (is.null(ylab)) ylabel <- "" else ylabel <- ylab return(list(X=X,scale=FALSE,se=FALSE,raw=raw,xlab=xlabel,ylab=ylabel, main=label)) } else { ## do plot if (scheme==0) scheme <- "heat" else scheme <- "grey" polys.plot(x$xt$polys,trans(P$fit+shift),scheme=scheme,lab=P$main,...) } } ## end plot.mrf.smooth plot.fs.interaction <- function(x,P=NULL,data=NULL,label="",se1.mult=2,se2.mult=1, partial.resids=FALSE,rug=TRUE,se=TRUE,scale=-1,n=100,n2=40,n3=3, pers=FALSE,theta=30,phi=30,jit=FALSE,xlab=NULL,ylab=NULL,main=NULL, ylim=NULL,xlim=NULL,too.far=0.1,shade=FALSE,shade.col="gray80", shift=0,trans=I,by.resids=FALSE,scheme=0,...) { ## plot method for simple smooth factor interactions... if (is.null(P)) { ## get plotting info if (x$dim!=1) return(NULL) ## no method for base smooth dim > 1 raw <- data[x$base$term][[1]] xx <- seq(min(raw),max(raw),length=n) # generate x sequence for prediction nf <- length(x$flev) fac <- rep(x$flev,rep(n,nf)) dat <- data.frame(fac,xx,stringsAsFactors=TRUE) names(dat) <- c(x$fterm,x$base$term) if (x$by!="NA") { # deal with any by variables dat[[x$by]] <- rep(1,n) } X <- PredictMat(x,dat) if (is.null(xlab)) xlabel <- x$base$term else xlabel <- xlab if (is.null(ylab)) ylabel <- label else ylabel <- ylab return(list(X=X,scale=TRUE,se=FALSE,raw=raw,xlab=xlabel,ylab=ylabel, main="",x=xx,n=n,nf=nf)) } else { ## produce the plot ind <- 1:P$n if(is.null(ylim)) ylim <- trans(range(P$fit)+shift) plot(P$x[ind],trans(P$fit[ind]+shift),ylim=ylim,xlab=P$xlab,ylab=P$ylab,type="l",...) if (P$nf>1) for (i in 2:P$nf) { ind <- ind + P$n if (scheme==0) lines(P$x,trans(P$fit[ind]+shift),lty=i,col=i) else lines(P$x,trans(P$fit[ind]+shift),lty=i) } } } ## end plot.fs.interaction md.plot <- function(f,nr,nc,m,vname,lo,hi,hcolors,scheme,main,...) { ## multi-dimensional term plotter, called from plot.mgcv.smooth for ## 3 and 4 dimensional terms. ## *f is the plot data. See `basic plot data for 3 or 4 d terms' ## in plot.mgcv.smooth for details of the packing conventions ## (f = X %*% coefs). ## *nr and nc the number of rows and columns of plot panels ## *m each panel is m by m ## *vname contains the variable names ## *lo and hi are the arrays of axis limits ## *hcolors is the color palette for the image plot. ## *scheme indicates b/w or color ## *main is a title. concol <- if (scheme==1) "white" else "black" nv <- length(vname) ## insert NA breaks to separate the panels within a plot... f1 <- matrix(NA,nr*m+nr-1,nc*m) ii <- rep(1:m,nr) + rep(0:(nr-1)*(m+1),each=m) f1[ii,] <- f f <- matrix(NA,nr*m+nr-1,nc*m+nc-1) ii <- rep(1:m,nc) + rep(0:(nc-1)*(m+1),each=m) f[,ii] <- f1 xx <- seq(0,1,length=ncol(f)) yy <- seq(0,1,length=nrow(f)) image(xx,yy,t(f),axes=FALSE,xlab="",ylab="",col=hcolors) contour(xx,yy,t(f),add=TRUE,col=concol) dl <- list(...) c1 <- if (is.null(dl[["cex"]])) 1 else dl[["cex"]] c2 <- if (is.null(dl[["cex.axis"]])) .6 else dl[["cex.axis"]] c3 <- if (is.null(dl[["cex.lab"]])) .9 else dl[["cex.lab"]] if (nv==4) { x3 <- seq(lo[3],hi[3],length=nr) x4 <- seq(lo[4],hi[4],length=nc) mtext(vname[4],1,1.7,cex=c1*c3) ## x label mtext(vname[3],2,1.7,cex=c1*c3) ## y label at=(1:nc-.5)/nc lab <- format(x4,digits=2) for (i in 1:nc) mtext(lab[i],1,at=at[i],line=.5,cex=c1*c3) at=(1:nr-.5)/nr lab <- format(x4,digits=2) for (i in 1:nr) mtext(lab[i],2,at=at[i],line=.5,cex=c1*c3) ## now the 2d panel axes... xr <- axisTicks(c(lo[2],hi[2]),log=FALSE,nint=4) x0 <- ((nc-1)*(m+1)+1)/(nc*m+nc-1) xt <- (xr-lo[2])/(hi[2]-lo[2])*(1-x0)+x0 axis(3,at=xt,labels=as.character(xr),cex.axis=c2,cex=c1) xr <- axisTicks(c(lo[1],hi[1]),log=FALSE,nint=4) x0 <- ((nr-1)*(m+1)+1)/(nr*m+nr-1) xt <- (xr-lo[1])/(hi[1]-lo[1])*(1-x0)+x0 axis(4,at=xt,labels=as.character(xr),cex.axis=c2,cex=c1) at <- (2*nc-3)/(2*nc) mtext(vname[2],3,at=at,line=.5,cex=c1*c2) at <- (2*nr-3)/(2*nr) mtext(vname[1],4,at=at,line=.5,cex=c1*c2) mtext(main,3,at=0,adj=0,line=1,cex=c1*c3) } else { x3 <- seq(lo[3],hi[3],length=nr*nc) ## get pretty ticks xr <- axisTicks(c(lo[2],hi[2]),log=FALSE,nint=4) x0 <- (m-1)/(nc*m+nc-1) xt <- (xr-lo[2])/(hi[2]-lo[2])*x0 axis(1,at=xt,labels=as.character(xr),cex.axis=c2,cex=c1) mtext(vname[2],1,at=x0/2,line=2,cex=c1*c2) xr <- axisTicks(c(lo[1],hi[1]),log=FALSE,nint=4) x0 <- (m-1)/(nr*m+nr-1) xt <- (xr-lo[1])/(hi[1]-lo[1])*x0 axis(2,at=xt,labels=as.character(xr),cex.axis=c2,cex=c1) mtext(vname[1],2,at=x0/2,line=2,cex=c1*c2) lab <- c("",format(x3[-1],digits=2)) at=(1:nc-.5)/nc for (i in 2:nc) mtext(lab[i],1,at=at[i],line=.5,cex=c1*c3) mtext(parse(text=paste(vname[3],"%->% \" \"")),1,at=mean(at[2:nc]),line=2,cex=c1*c3) ii <- ((nr-1)*nr+1):(nc*nr) for (i in 1:nc) mtext(lab[ii[i]],3,at=at[i],line=.5,cex=c1*c3) mtext(parse(text=paste(vname[3],"%->% \" \"")),3,at=mean(at),line=2,cex=c1*c3) mtext(main,2,at=1/nr+0.5*(nr-1)/nr,line=1,cex=c1*c3) } } ## md.plot scam/R/bivar.smooth.const.R0000644000176200001440000035467015026260052015276 0ustar liggesusers## (c) Natalya Pya (2012-2025). Provided under GPL 2. ## Shape constrained smooth construct for bivariate terms. ## (2023) with sum-to-zero contraint applied to the final tensor product model matrices, XSig, after scop constraints, for bivariate smooths with double monotonicity or concavity/convexity only.. ####################################################################################### ### Tensor product P-spline construction with double monotone decreasing constraint, ### with sum-to-zero contraint applied to the final tensor product model matrix XSig... ####################################################################################### smooth.construct.tedmd.smooth.spec<- function(object, data, knots) { ## construction of the double monotone decreasing smooth surface # require(splines) if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) if (object$bs.dim[1]==-1) # set the default values for q1 and q2 { q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth nk2 <- q2+m[2]+2 ## number of knots for the 2nd smooth if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied if (is.null(xk)) # space knots through the values of the 1st covariate { n<-length(x) xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} } if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)) # space knots through the values of the 2nd covariate { zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} } if (length(xk)!=nk1 || length(zk)!=nk2) # right number of knots? stop(paste("there should be ",nk1, " and ", nk2," supplied knots")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m[1]+2) X2 <- splineDesign(zk,z,ord=m[2]+2) X <- matrix(0,n,q1*q2) # model matrix for ( i in 1:n) { X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS <- matrix(-1,q2,q2) ## Define submatrix of Sigma IS[upper.tri(IS)] <- 0 IS1 <- matrix(1,q1,q1) ## Define submatrix of Sigma IS1[upper.tri(IS1)] <- 0 Sig <- IS1%x%IS # Knonecker product to get Sigma Sig[,1] <- rep(1,ncol(Sig)) # apply scop identifiability constraint and get model matrix X <- X[,2:ncol(X)]%*%Sig[2:ncol(Sig),2:ncol(Sig)] ## applying sum-to-zero (centering) constraint... cmx <- colMeans(X) X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix with identifiability constraint object$cmX <- cmx # create the penalty matrix S <- list() I2<- diag(q2) I1 <- diff(diag(q1-1),difference=1) Pm1 <- matrix(0,q1-1,q1) # marginal sqrt penalty Pm1[2:(q1-1),2:q1] <- I1 S[[1]]<- Pm1%x%I2 I2 <- diff(diag(q2-1),difference=1) Pm2 <- matrix(0,q2-1,q2) Pm2[2:(q2-1),2:q2] <- I2 # marginal sqrt penalty I1 <- diag(q1) S[[2]] <- I1%x%Pm2 object$P <- list() object$P[[1]] <- S[[1]][2:nrow(S[[1]]),2:ncol(S[[1]])] object$P[[2]] <- S[[2]][2:nrow(S[[2]]),2:ncol(S[[2]])] object$S <- list() object$S[[1]] <- crossprod(object$P[[1]]) ## t(object$P[[1]])%*%object$P[[1]] object$S[[2]] <- crossprod(object$P[[2]]) ## t(object$P[[2]])%*%object$P[[2]] object$p.ident <- rep(TRUE,q1*q2-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- diag(q1*q2-1) # identfiability constraint matrix object$Zc <- rbind(rep(0,ncol(object$Zc)),object$Zc) ## store "tedmd" list() object$knots[[1]] <- xk object$knots[[2]] <- zk object$m <- m object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"tedmd.smooth" # Give object a class object } ###################################################### Predict.matrix.tedmd.smooth <- function(object, data) { ## prediction method function for the `tedmd' smooth class if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} bm <- marginal.linear.extrapolation(object, data) n <- length(data[[object$term[1]]]) X <- matrix(0,n,q1*q2) # model matrix for ( i in 1:n) { X[i,] <- bm$X1[i,] %x% bm$X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- ## IS <- matrix(0,q2,q2) # Define submatrix of Sigma ## for (j in 1:q2) IS[j,1:j] <- -1 IS <- matrix(-1,q2,q2) ## Define submatrix of Sigma IS[upper.tri(IS)] <- 0 ## IS1 <- matrix(0,q1,q1) # Define submatrix of Sigma ## for (j in 1:q1) IS1[j,1:j] <- 1 IS1 <- matrix(1,q1,q1) ## Define submatrix of Sigma IS1[upper.tri(IS1)] <- 0 Sig <- IS1%x%IS # Knonecker product to get Sigma Sig[,1] <- rep(1,ncol(Sig)) X <- X%*%Sig X <- sweep(X,2,c(0,object$cmX)) X # return the prediction matrix } ######################################################################## ## function used for predict method to get marginal model submatrices ## ## with linear extrapolation if needed ## ######################################################################## marginal.linear.extrapolation <- function(object, data) { ## function to get marginal matrices used in predict method on bivariate SCOP-splines x <- data[[object$term[1]]] z <- data[[object$term[2]]] if (length(x) != length(z)) stop ("arguments of smooth are not of the same dimension") m <- object$m + 1 ## vector of two components ## find spline basis inner knot range for 1st covariate, x... ll <- object$knots[[1]][m[1]+1];ul <- object$knots[[1]][length(object$knots[[1]])-m[1]] m[1] <- m[1] + 1 n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X1 <- spline.des(object$knots[[1]],x,m[1])$design } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots[[1]],c(ll,ll,ul,ul),m[1],c(0,1,0,1))$design X1 <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X1[ind,] <- spline.des(object$knots[[1]],x[ind],m[1])$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X1[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X1[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] } ## the same for 2nd maginal matrix... ## find spline basis inner knot range for 2nd covariate, z... ll <- object$knots[[2]][m[2]+1];ul <- object$knots[[2]][length(object$knots[[2]])-m[2]] m[2] <- m[2] + 1 ind <- z<=ul & z>=ll ## data in range if (sum(ind)==n) { ## all in range X2 <- spline.des(object$knots[[2]],z,m[2])$design } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots[[2]],c(ll,ll,ul,ul),m[2],c(0,1,0,1))$design X2 <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X2[ind,] <- spline.des(object$knots[[2]],z[ind],m[2])$design ## interior rows ## Now add rows for linear extrapolation... ind <- z < ll if (sum(ind)>0) X2[ind,] <- cbind(1,z[ind]-ll)%*%D[1:2,] ind <- z > ul if (sum(ind)>0) X2[ind,] <- cbind(1,z[ind]-ul)%*%D[3:4,] } list(X1=X1, X2=X2) } ####################################################################################### ### Tensor product P-spline construction with double monotone increasing constraint ## ####################################################################################### smooth.construct.tedmi.smooth.spec <- function(object, data, knots) { ## construction of the double monotone increasing smooth surface # require(splines) if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) if (object$bs.dim[1]==-1) # set the default values fro q1 and q2 { q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth nk2 <- q2+m[2]+2 ## number of knots for the 2nd smooth if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied if (is.null(xk)) # space knots through the values of the 1st covariate { n<-length(x) xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} } if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)) # space knots through the values of the 2nd covariate { zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} } if (length(xk)!=nk1 || length(zk)!=nk2) # right number of knots? stop(paste("there should be ",nk1, " and ", nk2," supplied knots")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m[1]+2) X2 <- splineDesign(zk,z,ord=m[2]+2) X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) { X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- # IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma # IS2[1:q2,1] <- rep(1,q2) # for (j in 2:q2) IS2[j,2:j] <- 1 # IS1 <- matrix(0,q1,q1) # Define marginal matrix of Sigma # IS1[1:q1,1] <- rep(1,q1) # for (j in 2:q1) IS1[j,2:j] <- 1 IS1 <- matrix(1,q1,q1) ## Define marginal matrix of Sigma IS1[upper.tri(IS1)] <- 0 IS2 <- matrix(1,q2,q2) ## Define marginal matrix of Sigma IS2[upper.tri(IS2)] <- 0 Sig <- IS1 %x% IS2 # apply identifiability constraint and get model matrix X <- X[,2:ncol(X)]%*%Sig[2:ncol(Sig),2:ncol(Sig)] ## applying sum-to-zero (centering) constraint... cmx <- colMeans(X) X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix with identifiability constraint object$cmX <- cmx # create the penalty matrix S <- list() I2<- diag(q2) I1 <- diff(diag(q1-1),difference=1) Pm1 <- matrix(0,q1-1,q1) # marginal sqrt penalty Pm1[2:(q1-1),2:q1] <- I1 S[[1]]<- Pm1%x%I2 I2 <- diff(diag(q2-1),difference=1) Pm2 <- matrix(0,q2-1,q2) Pm2[2:(q2-1),2:q2] <- I2 # marginal sqrt penalty I1 <- diag(q1) S[[2]] <- I1%x%Pm2 object$P <- list() object$P[[1]] <- S[[1]][2:nrow(S[[1]]),2:ncol(S[[1]])] object$P[[2]] <- S[[2]][2:nrow(S[[2]]),2:ncol(S[[2]])] object$S <- list() object$S[[1]] <- crossprod(object$P[[1]]) ## t(object$P[[1]])%*%object$P[[1]] object$S[[2]] <- crossprod(object$P[[2]]) ## t(object$P[[2]])%*%object$P[[2]] object$p.ident <- rep(TRUE,q1*q2-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- diag(q1*q2-1) # identfiability constraint matrix object$Zc <- rbind(rep(0,ncol(object$Zc)),object$Zc) ## store "tedmi" specific stuff ... object$knots <- list() object$knots[[1]] <- xk object$knots[[2]] <- zk object$m <- m object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"tedmi.smooth" # Give object a class object } #################################################################### Predict.matrix.tedmi.smooth <- function(object, data) { ## prediction method function for the `tedmi' smooth class if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} bm <- marginal.linear.extrapolation(object, data) n <- length(data[[object$term[1]]]) X <- matrix(0,n,q1*q2) # model matrix for ( i in 1:n) { X[i,] <- bm$X1[i,] %x% bm$X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- # IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma # IS2[1:q2,1] <- rep(1,q2) # for (j in 2:q2) IS2[j,2:j] <- 1 # IS1 <- matrix(0,q1,q1) # Define marginal matrix of Sigma # IS1[1:q1,1] <- rep(1,q1) # for (j in 2:q1) IS1[j,2:j] <- 1 IS1 <- matrix(1,q1,q1) ## Define marginal matrix of Sigma IS1[upper.tri(IS1)] <- 0 IS2 <- matrix(1,q2,q2) ## Define marginal matrix of Sigma IS2[upper.tri(IS2)] <- 0 Sig <- IS1 %x% IS2 # get final model matrix X <- X %*%Sig X <- sweep(X,2,c(0,object$cmX)) X # return the prediction matrix } ############################################################################ ## Tensor product P-spline construction with single monotone decreasing ## ## constraint wrt the first covariate ## ############################################################################ smooth.construct.tesmd1.smooth.spec<- function(object, data, knots) { ## construction of the single monotone decreasing smooth surface, deacreasing wrt the first covariate # require(splines) if (!is.null(object$xt)){ if (!(object$xt %in% c("ps", "cc")) ) stop("only 'ps' and 'cc' marginal basis are supported") else bs2 <- object$xt ## basis for the marginal smooth along second direction } else bs2 <- "ps" ## (only "ps" and 'cc' available currently) if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) { m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths object$p.order <- m } else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) object$p.order[is.na(object$p.order)] <- 2 if (object$bs.dim[1]==-1) # set the default values fro q1 and q2 { q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1) { q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths object$bs.dim <- rep(object$bs.dim, 2) } else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth if (bs2=="cc") nk2 <- q2+1 else nk2 <- q2+m[2]+2 ## number of knots for the 2nd smooth in case of p-splines if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied if (is.null(xk)) # space knots through the values of the 1st covariate { xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} knots[[object$term[1]]] <- xk } n<-length(x) if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)){ # space knots through the values of the 2nd covariate if (bs2=="cc") { zk <- place.knots(z,nk2) if (length(zk)==2) { zk <- place.knots(c(zk,z),nk2) } } else{ zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} knots[[object$term[2]]] <- zk } } if (length(xk)!=nk1 ) # right number of knots? stop(paste("there should be ",nk1," supplied knotsfor the x")) if (length(zk)!=nk2) # right number of knots? stop(paste("there should be ",nk2," supplied knots for z")) # get model matrix------------- # get marginal model matrices and penalties... if (bs2=="cc") bm <- marginal.matrices.tesmi1.cc(x,z,xk,zk,m,q1,q2) else bm <- marginal.matrices.tesmi1.ps(x,z,xk,zk,m,q1,q2) X1 <- bm$X1 X2 <- bm$X2 S <- bm$S # get the overall model matrix... X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices # get a matrix Sigma ----------------------- # IS <- matrix(0,q1,q1) # Define marginal matrix of Sigma # IS[1:q1,1]<-1 # for (j in 2:q1) IS[j,2:j] <- -1 IS <- matrix(-1,q1,q1) ## coef summation matrix IS[upper.tri(IS)] <-0 IS[,1] <- -IS[,1] I <- diag(q2) Sig <- IS%x%I # get model matrix X <- X%*%Sig # apply identifiability constraint D <- diag(q1*q2) D <- D[,-q2] D1 <- t(diff(diag(q2))) D[1:q2,1:(q2-1)] <- D1 X <- X%*%D ## applying sum-to-zero (centering) constraint... ## cmx <- colMeans(X) ## X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix with identifiability constraint ## object$cmX <- cmx object$S <- list() object$S[[1]] <- crossprod(D,S[[1]])%*%D ## t(D)%*%S[[1]]%*%D object$S[[2]] <- crossprod(D,S[[2]])%*%D ## t(D)%*%S[[2]]%*%D object$p.ident <- rep(TRUE,q1*q2-1) object$p.ident[1:(q2-1)] <- rep(FALSE, q2-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- D # identifiability constraint matrix ## store "tesmd1" specific stuff ... object$knots <- list() object$knots[[1]] <- xk if (is.null(zk)) object$knots[[2]] <- rep(0,0,0) else object$knots[[2]] <- zk object$m <- m object$margin.bs <- bs2 object$df <- ncol(object$X) # maximum DoF (if unconstrained) class(object) <- "tesmd1.smooth" # Give object a class object } ########################################################################### ## Prediction matrix for the `tesmd1` smooth class ************************* Predict.matrix.tesmd1.smooth<-function(object,data) { ## prediction method function for the `tesmd1' smooth class if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (!is.null(object$xt)) bs2 <- object$xt ## basis for the marginal smooth along second direction else bs2 <- "ps" if (bs2=="cc") bm <- marginal.linear.extrapolation.tesmi1.cc(object, data) else bm <- marginal.linear.extrapolation(object, data) n <- length(data[[object$term[1]]]) X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) { X[i,] <- bm$X1[i,] %x% bm$X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- # IS <- matrix(0,q1,q1) # Define marginal matrix of Sigma # IS[1:q1,1]<-1 # for (j in 2:q1) IS[j,2:j] <- -1 IS <- matrix(-1,q1,q1) ## coef summation matrix IS[upper.tri(IS)] <-0 IS[,1] <- -IS[,1] I <- diag(q2) Sig <- IS%x%I # get final model matrix X <- X%*%Sig # X <- sweep(X,2,c(0,object$cmX)) X # return the prediction matrix } ############################################################################ ## Tensor product P-spline construction with single monotone decreasing ## ## constraint wrt the second covariate ## ############################################################################ smooth.construct.tesmd2.smooth.spec<- function(object, data, knots) ## construction of the single monotone decreasing surface, decreasing wrt the second covariate { ## require(splines) #if (!is.null(object$xt)) bs2 <- object$xt ## basis for the marginal smooth along 1st direction # else bs2 <- "ps" ## (only "ps" ia available currently) if (!is.null(object$xt)){ if (!(object$xt %in% c("ps", "cc")) ) stop("only 'ps' and 'cc' marginal basis are supported") else bs2 <- object$xt ## basis for the marginal smooth along 1st direction } else bs2 <- "ps" if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) { m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths object$p.order <- m } else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) object$p.order[is.na(object$p.order)] <- 2 if (object$bs.dim[1]==-1) { # set the default values fro q1 and q2 q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1){ q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths object$bs.dim <- rep(object$bs.dim, 2) } else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk2 <- q2+m[2]+2 ## number of knots for the 2nd smooth if (bs2=="cc") nk1 <- q1+1 else nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth in case of p-splines if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied if (is.null(xk)){ # space knots through the values of the 1st covariate if (bs2=="cc") { xk <- place.knots(x,nk1) if (length(xk)==2) { xk <- place.knots(c(xk,x),nk1) } } else{ xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} knots[[object$term[1]]] <- xk } } n<-length(x) if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)) # space knots through the values of the 2nd covariate { zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} knots[[object$term[2]]] <- zk } if (length(zk)!=nk2 ) # right number of knots? stop(paste("there should be ",nk2," supplied knots for z")) if (length(xk)!=nk1) # right number of knots? stop(paste("there should be ",nk1," supplied knots for x")) # get model matrix------------- # get marginal model matrices and penalties... if (bs2=="cc") bm <- marginal.matrices.tesmi2.cc(x,z,xk,zk,m,q1,q2) else bm <- marginal.matrices.tesmi2.ps(x,z,xk,zk,m,q1,q2) X1 <- bm$X1 X2 <- bm$X2 S <- bm$S # get the overall model matrix... X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) { X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- # IS <- matrix(0,q2,q2) # Define submatrix of Sigma # IS[1:q2,1]<-1 # for (j in 2:q2) IS[j,2:j] <- -1 IS <- matrix(-1,q2,q2) ## coef summation matrix IS[upper.tri(IS)] <-0 IS[,1] <- -IS[,1] I <- diag(q1) Sig <- I%x%IS # get model matrix X <- X%*%Sig # apply identifiability constraint D<- diag(q1*q2) D<-D[,-((q1-1)*q2+1)] ind <- rep(0,q1-1) # get index number for the cells to be changed to "-1" for (i in 1:(q1-1)){ ind[i] <- (i-1)*q2+1 D[ind[i],ind[i]] <- -1 } for (i in 2:(q1-1)) D[ind[i],ind[i]-q2] <- 1 D[((q1-1)*q2+1),((q1-1)*q2+1-q2)] <- 1 X <- X%*%D ## applying sum-to-zero (centering) constraint... ## cmx <- colMeans(X) ## X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix with identifiability constraint ## object$cmX <- cmx # create the penalty matrix object$S <- list() object$S[[1]] <- t(D)%*%S[[1]]%*%D object$S[[2]] <- t(D)%*%S[[2]]%*%D object$p.ident <- rep(TRUE,q1*q2-1) object$p.ident[ind] <- FALSE ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- D # identifiability constraint matrix ## store "tesmd2" specific stuff ... object$knots <- list() if (is.null(xk)) object$knots[[1]] <- rep(0,0,0) else object$knots[[1]] <- xk object$knots[[2]] <- zk object$m <- m object$margin.bs <- bs2 object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"tesmd2.smooth" # Give object a class object } #################################################################### marginal.matrices.tesmi2.ps <- function(x,z,xk,zk,m,q1,q2) ## function to get marginal model matrices and penalties in the overall ## model coefficients in case of P-splines basis for the 1st unconstrained smooth { # get marginal model matrix for the first unconstrained smooth... X1 <- splineDesign(xk,x,ord=m[1]+2) # get marginal model matrix for the second monotonic smooth... X2 <- splineDesign(zk,z,ord=m[2]+2) # create the penalty matrix... S <- list() # get penalty matrix for the first unconstrained smooth... I2 <- diag(q2) P <- diff(diag(q1),difference=1) S[[1]]<- P %x% I2 c1 <- c(1,-2,1) c2 <- c(1,rep(0,q2-1)) c <- c1 %x% c2 for (i in 1:(q1-2)){ S[[1]][q2*(i-1)+1,(q2*(i-1)+1):(q2*(i-1)+length(c))] <- c } i <- q1-1 S[[1]][q2*(i-1)+1,(q2*(i-1)+1):ncol(S[[1]])] <- rep(0,2*q2) S[[1]] <- crossprod(S[[1]]) ## t(S[[1]])%*%S[[1]] # get penalty for the 2nd monotonic smooth... I2 <- diff(diag(q2-1),difference=1) P <- matrix(0,q2-1,q2) P[2:(q2-1),2:q2] <- I2 # marginal sqrt penalty I1 <- diag(q1) S[[2]] <- I1%x%P S[[2]] <- crossprod(S[[2]]) ## t(S[[2]])%*%S[[2]] list(X1=X1, X2=X2, S=S) } ########################################################################### ## Prediction matrix for the `tesmd2` smooth class ************************* Predict.matrix.tesmd2.smooth<-function(object,data) ## prediction method function for the `tesmd2' smooth class { if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} # bm <- marginal.linear.extrapolation(object, data) if (!is.null(object$xt)) bs2 <- object$xt ## basis for the marginal smooth along second direction else bs2 <- "ps" if (bs2=="cc") bm <- marginal.linear.extrapolation.tesmi2.cc(object, data) else bm <- marginal.linear.extrapolation(object, data) n <- length(data[[object$term[1]]]) X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) { X[i,] <- bm$X1[i,] %x% bm$X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- # IS <- matrix(0,q2,q2) # Define submatrix of Sigma # IS[1:q2,1]<-1 # for (j in 2:q2) IS[j,2:j] <- -1 IS <- matrix(-1,q2,q2) ## coef summation matrix IS[upper.tri(IS)] <-0 IS[,1] <- -IS[,1] I <- diag(q1) Sig <- I%x%IS # get final model matrix X <- X%*%Sig X # return the prediction matrix } ############################################################################ ## Tensor product P-spline construction with single monotone increasing ## ## constraint wrt the first covariate; ## ## and with sum-to-zero constraint applied... ############################################################################ smooth.construct.tesmi1.smooth.spec<- function(object, data, knots) ## construction of the single monotone increasing surface, increasing wrt 1st covariate; ## with sum-to-zero (centering) constraint applied to the final tensor product model matrix XSig, after scop-constraints... { if (!is.null(object$xt)){ if (!(object$xt %in% c("ps", "cc")) ) stop("only 'ps' and 'cc' marginal basis are supported") else bs2 <- object$xt ## basis for the marginal smooth along second direction } else bs2 <- "ps" ## if (bs2=="cc") print("tada") else print("nope") if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) {m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths object$p.order <- m } else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) object$p.order[is.na(object$p.order)] <- 2 if (object$bs.dim[1]==-1) { # set the default values for q1 and q2 q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1){ q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths object$bs.dim <- rep(object$bs.dim, 2) } else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth if (bs2=="cc") nk2 <- q2+1 else nk2 <- q2+m[2]+2 ## number of knots for the 2nd smooth in case of p-splines if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied if (is.null(xk)) # space knots through the values of the 1st covariate { xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} knots[[object$term[1]]] <- xk } n<-length(x) if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)){ # space knots through the values of the 2nd covariate if (bs2=="cc") { zk <- place.knots(z,nk2) if (length(zk)==2) { zk <- place.knots(c(zk,z),nk2) } } else{ zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} knots[[object$term[2]]] <- zk } } if (length(xk)!=nk1 ) # right number of knots? stop(paste("there should be ",nk1," supplied knotsfor the x")) if (length(zk)!=nk2) # right number of knots? stop(paste("there should be ",nk2," supplied knots for z")) # get model matrix------------- # get marginal model matrices and penalties... if (bs2=="cc") bm <- marginal.matrices.tesmi1.cc(x,z,xk,zk,m,q1,q2) else bm <- marginal.matrices.tesmi1.ps(x,z,xk,zk,m,q1,q2) X1 <- bm$X1 X2 <- bm$X2 S <- bm$S # get a matrix Sigma ----------------------- IS <- matrix(1,q1,q1) ## coef summation matrix IS[upper.tri(IS)] <-0 I <- diag(q2) ## Sig <- IS%x%I X1 <- X1%*%IS # get the overall model matrix... X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices ## X <- X%*%Sig # apply identifiability constraint #(the sum of the first q2 non-exponentiated coefficients is set to be zero) D <- diag(q1*q2) D <- D[,-q2] D1 <- t(diff(diag(q2))) D[1:q2,1:(q2-1)] <- D1 X <- X%*%D ## applying sum-to-zero (centering) constraint... ## cmx <- colMeans(X) ## X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix with identifiability constraint ## object$cmX <- cmx object$S <- list() object$S[[1]] <- crossprod(D,S[[1]])%*%D ## t(D)%*%S[[1]]%*%D object$S[[2]] <- crossprod(D,S[[2]])%*%D ## t(D)%*%S[[2]]%*%D object$p.ident <- rep(TRUE,q1*q2-1) object$p.ident[1:(q2-1)] <- rep(FALSE, q2-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- D # identifiability constraint matrix ## store "tesmi1" specific stuff ... object$knots <- list() object$knots[[1]] <- xk if (is.null(zk)) object$knots[[2]] <- rep(0,0,0) else object$knots[[2]] <- zk object$m <- m object$margin.bs <- bs2 object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"tesmi1.smooth" # Give object a class object } marginal.matrices.tesmi1.ps <- function(x,z,xk,zk,m,q1,q2) ## function to get marginal model matrices and penalties in the overall ## model coefficients in case of P-splines basis for the 2nd unconstrained marginal smooth { # get marginal model matrix for the first monotonic smooth... X1 <- splineDesign(xk,x,ord=m[1]+2) # get marginal model matrix for the second unconstrained smooth... X2 <- splineDesign(zk,z,ord=m[2]+2) # create the penalty matrix... S <- list() # get the penalty matrix for the first monotone smooth... I2<- diag(q2) P <- diff(diag(q1-1),difference=1) Pm1 <- matrix(0,q1-1,q1) # marginal sqrt penalty Pm1[2:(q1-1),2:q1] <- P S[[1]]<- Pm1%x%I2 S[[1]] <- crossprod(S[[1]]) ## t(S[[1]])%*%S[[1]] # get penalty for the 2nd smooth I2 <- diff(diag(q2),difference=1) I21<- diff(diag(q2),difference=2) I1 <- diag(q1) S[[2]] <-matrix(0,q2-2+(q1-1)*(q2-1), q1*q2) S[[2]][1:(q2-2),] <- t(I1[1,])%x%I21 S[[2]][(q2-1):nrow(S[[2]]),] <- I1[2:q1,]%x%I2 S[[2]] <- crossprod(S[[2]]) ## t(S[[2]])%*%S[[2]] list(X1=X1, X2=X2, S=S) } ############################################################################################### ## Cyclic cubic regression spline methods copied from mgcv:: smooth.construct.cc.smooth.spec()) ################################################################################################ place.knots <- function(x,nk) # knot placement code. x is a covariate array, nk is the number of knots, # and this routine spaces nk knots evenly throughout the x values, with the # endpoints at the extremes of the data. { x<-sort(unique(x));n<-length(x) if (nk>n) stop("more knots than unique data values is not allowed") if (nk<2) stop("too few knots") if (nk==2) return(range(x)) delta<-(n-1)/(nk-1) # how many data steps per knot lbi<-floor(delta*1:(nk-2))+1 # lower interval bound index frac<-delta*1:(nk-2)+1-lbi # left over proportion of interval x.shift<-x[-1] knot<-array(0,nk) knot[nk]<-x[n];knot[1]<-x[1] knot[2:(nk-1)]<-x[lbi]*(1-frac)+x.shift[lbi]*frac knot } ## place.knots cwrap <- function(x0,x1,x) { ## map x onto [x0,x1] in manner suitable for cyclic smooth on ## [x0,x1]. h <- x1-x0 if (max(x)>x1) { ind <- x>x1 x[ind] <- x0 + (x[ind]-x1)%%h } if (min(x)max(knots)||min(x)=ll ## data in range if (sum(ind)==n) { ## all in range X1 <- spline.des(object$knots[[1]],x,m[1])$design } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots[[1]],c(ll,ll,ul,ul),m[1],c(0,1,0,1))$design X1 <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X1[ind,] <- spline.des(object$knots[[1]],x[ind],m[1])$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X1[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X1[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] } ## "cc" basis for the 2nd marginal matrix... um <- getBD(object$knots[[2]]) BD <- solve(um$B,um$D) # s"(k)=BD%*%s(k) where k are knots minus last knot X2 <- pred.mat(z,object$knots[[2]],BD) list(X1=X1, X2=X2) } ############################################################################ ## Tensor product P-spline construction with single monotone increasing ## ## constraint wrt the second covariate ## ############################################################################ smooth.construct.tesmi2.smooth.spec<- function(object, data, knots) ## construction of the single monotone increasing smooth surface, increasing wrt the second covariate { ## require(splines) # if (!is.null(object$xt)) bs2 <- object$xt ## basis for the marginal smooth along 1st direction # else bs2 <- "ps" ## (only "ps" is available currently) if (!is.null(object$xt)){ if (!(object$xt %in% c("ps", "cc")) ) stop("only 'ps' and 'cc' marginal basis are supported") else bs2 <- object$xt ## basis for the marginal smooth along 1st direction } else bs2 <- "ps" if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) { m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths object$p.order <- m } else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) object$p.order[is.na(object$p.order)] <- 2 if (object$bs.dim[1]==-1) { # set the default values for q1 and q2 q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1){ q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths object$bs.dim <- rep(object$bs.dim, 2) } else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk2 <- q2+m[2]+2 ## number of knots for the 2nd SCOP-smooth ## nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth if (bs2=="cc") nk1 <- q1+1 else nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth in case of p-splines if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied n<-length(x) if (is.null(xk)){ # space knots through the values of the 1st covariate if (bs2=="cc") { xk <- place.knots(x,nk1) if (length(xk)==2) { xk <- place.knots(c(xk,x),nk1) } } else{ xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} knots[[object$term[1]]] <- xk } } if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)) # space knots through the values of the 2nd covariate { zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} knots[[object$term[2]]] <- zk } if (length(zk)!=nk2 ) # right number of knots? stop(paste("there should be ",nk2," supplied knots for z")) if (length(xk)!=nk1) # right number of knots? stop(paste("there should be ",nk1," supplied knots for x")) # get model matrix------------- # get marginal model matrices and penalties... if (bs2=="cc") bm <- marginal.matrices.tesmi2.cc(x,z,xk,zk,m,q1,q2) else bm <- marginal.matrices.tesmi2.ps(x,z,xk,zk,m,q1,q2) X1 <- bm$X1 X2 <- bm$X2 S <- bm$S # get the overall model matrix... X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) { X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- # IS <- matrix(0,q2,q2) # Define submatrix of Sigma # IS[1:q2,1]<-1 # for (j in 2:q2) IS[j,2:j] <- 1 IS <- matrix(1,q2,q2) ## coef summation matrix IS[upper.tri(IS)] <-0 I <- diag(q1) Sig <- I%x%IS # get model matrix X <- X%*%Sig # apply identifiability constraint D<- diag(q1*q2) D<-D[,-((q1-1)*q2+1)] ind <- rep(0,q1-1) # get index number for the cells to be changed to "-1" for (i in 1:(q1-1)){ ind[i] <- (i-1)*q2+1 D[ind[i],ind[i]] <- -1 } for (i in 2:(q1-1)) D[ind[i],ind[i]-q2] <- 1 D[((q1-1)*q2+1),((q1-1)*q2+1-q2)] <- 1 X <- X%*%D ## applying sum-to-zero (centering) constraint... ## cmx <- colMeans(X) ## X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix with identifiability constraint ## object$cmX <- cmx # create the penalty matrix object$S <- list() object$S[[1]] <- t(D)%*%S[[1]]%*%D object$S[[2]] <- t(D)%*%S[[2]]%*%D object$p.ident <- rep(TRUE,q1*q2-1) object$p.ident[ind]<-FALSE ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- D # identifiability constraint matrix ## store "tesmi2" specific stuff ... object$knots <- list() if (is.null(xk)) object$knots[[1]] <- rep(0,0,0) else object$knots[[1]] <- xk object$knots[[2]] <- zk object$m <- m object$margin.bs <- bs2 object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"tesmi2.smooth" # Give object a class object } #################################################################### marginal.matrices.tesmi2.ps <- function(x,z,xk,zk,m,q1,q2) ## function to get marginal model matrices and penalties in the overall ## model coefficients in case of P-splines basis for the 1st unconstrained smooth { # get marginal model matrix for the first unconstrained smooth... X1 <- splineDesign(xk,x,ord=m[1]+2) # get marginal model matrix for the second monotonic smooth... X2 <- splineDesign(zk,z,ord=m[2]+2) # create the penalty matrix... S <- list() # get penalty matrix for the first unconstrained smooth... I2 <- diag(q2) P <- diff(diag(q1),difference=1) S[[1]]<- P %x% I2 c1 <- c(1,-2,1) c2 <- c(1,rep(0,q2-1)) c <- c1 %x% c2 for (i in 1:(q1-2)){ S[[1]][q2*(i-1)+1,(q2*(i-1)+1):(q2*(i-1)+length(c))] <- c } i <- q1-1 S[[1]][q2*(i-1)+1,(q2*(i-1)+1):ncol(S[[1]])] <- rep(0,2*q2) S[[1]] <- crossprod(S[[1]]) ## t(S[[1]])%*%S[[1]] # get penalty for the 2nd monotonic smooth... I2 <- diff(diag(q2-1),difference=1) P <- matrix(0,q2-1,q2) P[2:(q2-1),2:q2] <- I2 # marginal sqrt penalty I1 <- diag(q1) S[[2]] <- I1%x%P S[[2]] <- crossprod(S[[2]]) ## t(S[[2]])%*%S[[2]] list(X1=X1, X2=X2, S=S) } marginal.matrices.tesmi2.cc <- function(x,z,xk,zk,m,q1,q2) ## function to get marginal model matrices and penalties in the overall ## model coefficients in case of cyclic cubic splines for the 1st marginal smooth { # get marginal model matrix for the 2nd monotonic smooth... X2 <- splineDesign(zk,z,ord=m[2]+2) # get marginal model matrix for the 1st 'cc' smooth ## (copied from mgcv:: smooth.construct.cc.smooth.spec())... um <- getBD(xk) BD <- solve(um$B,um$D) # s"(k)=BD%*%s(k) where k are knots minus last knot X1 <- pred.mat(x,xk,BD) ## object$S<-list(t(um$D)%*%BD) # the penalty ## object$S[[1]]<-(object$S[[1]]+t(object$S[[1]]))/2 # ensure exact symmetry ##============================ # create the penalty matrices... S <- list() # get penalty matrix for the 1st 'cc' smooth... I2 <- diag(q2) P <- diff(diag(q1),difference=1) S[[1]]<- P %x% I2 c1 <- c(1,-2,1) c2 <- c(1,rep(0,q2-1)) c <- c1 %x% c2 for (i in 1:(q1-2)){ S[[1]][q2*(i-1)+1,(q2*(i-1)+1):(q2*(i-1)+length(c))] <- c } i <- q1-1 S[[1]][q2*(i-1)+1,(q2*(i-1)+1):ncol(S[[1]])] <- rep(0,2*q2) S[[1]] <- crossprod(S[[1]]) ## t(S[[1]])%*%S[[1]] S[[1]] <- (S[[1]]+t(S[[1]]))/2 # ensure exact symmetry # get penalty for the 2nd monotonic smooth... I2 <- diff(diag(q2-1),difference=1) P <- matrix(0,q2-1,q2) P[2:(q2-1),2:q2] <- I2 # marginal sqrt penalty I1 <- diag(q1) S[[2]] <- I1%x%P S[[2]] <- crossprod(S[[2]]) ## t(S[[2]])%*%S[[2]] list(X1=X1, X2=X2, S=S) } ############################################################ ## Prediction matrix for the `tesmi2` smooth class .... ## ############################################################ Predict.matrix.tesmi2.smooth<-function(object,data) ## prediction method function for the `tesmi2' smooth class { if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (!is.null(object$xt)) bs2 <- object$xt ## basis for the marginal smooth along second direction else bs2 <- "ps" if (bs2=="cc") bm <- marginal.linear.extrapolation.tesmi2.cc(object, data) else bm <- marginal.linear.extrapolation(object, data) n <- length(data[[object$term[1]]]) X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) { X[i,] <- bm$X1[i,] %x% bm$X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- # IS <- matrix(0,q2,q2) # Define submatrix of Sigma # IS[1:q2,1]<-1 # for (j in 2:q2) IS[j,2:j] <- 1 IS <- matrix(1,q2,q2) ## coef summation matrix IS[upper.tri(IS)] <-0 I <- diag(q1) Sig <- I%x%IS # get final model matrix X <- X%*%Sig X # return the prediction matrix } ## function used for predict method to get marginal model submatrices for tesmi2.cc and tesmd2.cc (along x1) ## with linear extrapolation along x2 (SCOP-spline marginal) if needed... marginal.linear.extrapolation.tesmi2.cc <- function(object, data) { ## function to get marginal matrices used in predict method on bivariate SCOP-splines x <- data[[object$term[1]]] z <- data[[object$term[2]]] if (length(x) != length(z)) stop ("arguments of smooth are not of the same dimension") m <- object$m + 1 ## vector of two components ## find spline basis inner knot range for 2nd covariate, z... ll <- object$knots[[2]][m[2]+1];ul <- object$knots[[2]][length(object$knots[[2]])-m[2]] m[2] <- m[2] + 1 n <- length(z) ind <- z<=ul & z>=ll ## data in range if (sum(ind)==n) { ## all in range X2 <- spline.des(object$knots[[2]],z,m[2])$design } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots[[2]],c(ll,ll,ul,ul),m[2],c(0,1,0,1))$design X2 <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X2[ind,] <- spline.des(object$knots[[2]],z[ind],m[2])$design ## interior rows ## Now add rows for linear extrapolation... ind <- z < ll if (sum(ind)>0) X2[ind,] <- cbind(1,z[ind]-ll)%*%D[1:2,] ind <- z > ul if (sum(ind)>0) X2[ind,] <- cbind(1,z[ind]-ul)%*%D[3:4,] } ## "cc" basis for the 1st marginal matrix... um <- getBD(object$knots[[1]]) BD <- solve(um$B,um$D) # s"(k)=BD%*%s(k) where k are knots minus last knot X1 <- pred.mat(x,object$knots[[1]],BD) list(X1=X1, X2=X2) } ############################################################### ## Tensor product P-spline construction with mixed constraints: ## increasing wrt the 1st covariate and convex wrt the 2nd covariate ... ################################### smooth.construct.temicx.smooth.spec<- function(object, data, knots) ## construction of the bivariate smooth surface with mixed constraints: increasing ## wrt the 1st covariate and convex wrt the 2nd one... { if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) {m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths object$p.order <- m } else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) object$p.order[is.na(object$p.order)] <- 2 if (object$bs.dim[1]==-1) { # set the default values for q1 and q2 q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1){ q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths object$bs.dim <- rep(object$bs.dim, 2) } else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth nk2 <- q2+m[2]+2 ## number of knots for the 2nd smooth if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied if (is.null(xk)) # space knots through the values of the 1st covariate { n<-length(x) xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} knots[[object$term[1]]] <- xk } if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)) # space knots through the values of the 2nd covariate { zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} knots[[object$term[2]]] <- zk } if (length(xk)!=nk1 ) # right number of knots? stop(paste("there should be ",nk1," supplied knotsfor the x")) if (length(zk)!=nk2) # right number of knots? stop(paste("there should be ",nk2," supplied knots for z")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m[1]+2) X2 <- splineDesign(zk,z,ord=m[2]+2) X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) { X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for convexity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- -c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- c(1:(q2-i+1)) # IS1 <- matrix(0,q1,q1) # Define marginal matrix of Sigma for increasing constraint # IS1[1:q1,1] <- rep(1,q1) # for (j in 2:q1) IS1[j,2:j] <- 1 IS1 <- matrix(1,q1,q1) ## Define marginal matrix of Sigma for increasing constraint IS1[upper.tri(IS1)] <-0 Sig <- IS1 %x% IS2 # apply identifiability constraint and get model matrix X <- X[,2:ncol(X)]%*%Sig[2:ncol(Sig),2:ncol(Sig)] ## applying sum-to-zero (centering) constraint... ## cmx <- colMeans(X) ## X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix with identifiability constraint ## object$cmX <- cmx # create the penalty matrix S <- list() I2<- diag(q2) I1 <- diff(diag(q1-1),difference=1) Pm1 <- matrix(0,q1-1,q1) # marginal sqrt penalty Pm1[2:(q1-1),2:q1] <- I1 S[[1]]<- Pm1%x%I2 I2 <- diff(diag(q2-2),difference=1) Pm2 <- matrix(0,q2-1,q2) Pm2[3:(q2-1),3:q2] <- I2 # marginal sqrt penalty I1 <- diag(q1) S[[2]] <- I1%x%Pm2 object$P <- list() object$P[[1]] <- S[[1]][2:nrow(S[[1]]),2:ncol(S[[1]])] object$P[[2]] <- S[[2]][2:nrow(S[[2]]),2:ncol(S[[2]])] object$S <- list() object$S[[1]] <- crossprod(object$P[[1]]) ## t(object$P[[1]])%*%object$P[[1]] object$S[[2]] <- crossprod(object$P[[2]]) ## t(object$P[[2]])%*%object$P[[2]] object$p.ident <- rep(TRUE,q1*q2-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- diag(q1*q2-1) # identfiability constraint matrix object$Zc <- rbind(rep(0,ncol(object$Zc)),object$Zc) ## store "temicx" specific stuff ... object$knots <- list() object$knots[[1]] <- xk object$knots[[2]] <- zk object$m <- m object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"temicx.smooth" # Give object a class object } #################################################################### Predict.matrix.temicx.smooth <- function(object, data) { ## prediction method function for the `temicx' smooth class if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} bm <- marginal.linear.extrapolation(object, data) n <- length(data[[object$term[1]]]) X <- matrix(0,n,q1*q2) # model matrix for ( i in 1:n) { X[i,] <- bm$X1[i,] %x% bm$X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for convexity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- -c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- c(1:(q2-i+1)) # IS1 <- matrix(0,q1,q1) # Define marginal matrix of Sigma for increasing constraint # IS1[1:q1,1] <- rep(1,q1) # for (j in 2:q1) IS1[j,2:j] <- 1 IS1 <- matrix(1,q1,q1) ## Define marginal matrix of Sigma for increasing constraint IS1[upper.tri(IS1)] <-0 Sig <- IS1 %x% IS2 # get final model matrix X <- X %*%Sig ## X <- sweep(X,2,c(0,object$cmX)) X # return the prediction matrix } ################################################################ ## Tensor product P-spline construction with mixed constraints: ## increasing wrt the 1st covariate and concave wrt the 2nd covariate ... ################################################################# smooth.construct.temicv.smooth.spec<- function(object, data, knots) ## construction of the bivariate smooth surface with mixed constraints: increasing ## wrt the 1st covariate and concave wrt the 2nd one... { if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) {m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths object$p.order <- m } else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) object$p.order[is.na(object$p.order)] <- 2 if (object$bs.dim[1]==-1) { # set the default values for q1 and q2 q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1){ q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths object$bs.dim <- rep(object$bs.dim, 2) } else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth nk2 <- q2+m[2]+2 ## number of knots for the 2nd smooth if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied if (is.null(xk)) # space knots through the values of the 1st covariate { n<-length(x) xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} knots[[object$term[1]]] <- xk } if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)) # space knots through the values of the 2nd covariate { zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} knots[[object$term[2]]] <- zk } if (length(xk)!=nk1 ) # right number of knots? stop(paste("there should be ",nk1," supplied knotsfor the x")) if (length(zk)!=nk2) # right number of knots? stop(paste("there should be ",nk2," supplied knots for z")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m[1]+2) X2 <- splineDesign(zk,z,ord=m[2]+2) X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) { X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for concavity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- -c(1:(q2-i+1)) # IS1 <- matrix(0,q1,q1) # Define marginal matrix of Sigma for increasing constraint # IS1[1:q1,1] <- rep(1,q1) # for (j in 2:q1) IS1[j,2:j] <- 1 IS1 <- matrix(1,q1,q1) ## Define marginal matrix of Sigma for increasing constraint IS1[upper.tri(IS1)] <-0 Sig <- IS1 %x% IS2 # apply identifiability constraint and get model matrix X <- X[,2:ncol(X)]%*%Sig[2:ncol(Sig),2:ncol(Sig)] ## applying sum-to-zero (centering) constraint... ## cmx <- colMeans(X) ## X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix with identifiability constraint ## object$cmX <- cmx # create the penalty matrix S <- list() I2<- diag(q2) I1 <- diff(diag(q1-1),difference=1) Pm1 <- matrix(0,q1-1,q1) # marginal sqrt penalty Pm1[2:(q1-1),2:q1] <- I1 S[[1]]<- Pm1%x%I2 I2 <- diff(diag(q2-2),difference=1) Pm2 <- matrix(0,q2-1,q2) Pm2[3:(q2-1),3:q2] <- I2 # marginal sqrt penalty I1 <- diag(q1) S[[2]] <- I1%x%Pm2 object$P <- list() object$P[[1]] <- S[[1]][2:nrow(S[[1]]),2:ncol(S[[1]])] object$P[[2]] <- S[[2]][2:nrow(S[[2]]),2:ncol(S[[2]])] object$S <- list() object$S[[1]] <- crossprod(object$P[[1]]) ## t(object$P[[1]])%*%object$P[[1]] object$S[[2]] <- crossprod(object$P[[2]]) ## t(object$P[[2]])%*%object$P[[2]] object$p.ident <- rep(TRUE,q1*q2-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- diag(q1*q2-1) # identfiability constraint matrix object$Zc <- rbind(rep(0,ncol(object$Zc)),object$Zc) ## store "temicv" specific stuff ... object$knots <- list() object$knots[[1]] <- xk object$knots[[2]] <- zk object$m <- m object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"temicv.smooth" # Give object a class object } #################################################################### Predict.matrix.temicv.smooth <- function(object, data) { ## prediction method function for the `temicx' smooth class if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} bm <- marginal.linear.extrapolation(object, data) n <- length(data[[object$term[1]]]) X <- matrix(0,n,q1*q2) # model matrix for ( i in 1:n) { X[i,] <- bm$X1[i,] %x% bm$X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for concavity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- -c(1:(q2-i+1)) # IS1 <- matrix(0,q1,q1) # Define marginal matrix of Sigma for increasing constraint # IS1[1:q1,1] <- rep(1,q1) # for (j in 2:q1) IS1[j,2:j] <- 1 IS1 <- matrix(1,q1,q1) ## Define marginal matrix of Sigma for increasing constraint IS1[upper.tri(IS1)] <-0 Sig <- IS1 %x% IS2 # get final model matrix X <- X %*%Sig ## X <- sweep(X,2,c(0,object$cmX)) X # return the prediction matrix } ################################################################# ## Tensor product P-spline construction with mixed constraints: ## decreasing wrt the 1st covariate and concave wrt the second covariate ... ############################################################## smooth.construct.tedecv.smooth.spec<- function(object, data, knots) ## construction of the bivariate smooth surface with mixed constraints: decreasing ## wrt the 1st covariate and convex wrt the 2nd one... { if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) {m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths object$p.order <- m } else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) object$p.order[is.na(object$p.order)] <- 2 if (object$bs.dim[1]==-1) { # set the default values for q1 and q2 q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1){ q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths object$bs.dim <- rep(object$bs.dim, 2) } else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth nk2 <- q2+m[2]+2 ## number of knots for the 2nd smooth if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied if (is.null(xk)) # space knots through the values of the 1st covariate { n<-length(x) xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} knots[[object$term[1]]] <- xk } if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)) # space knots through the values of the 2nd covariate { zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} knots[[object$term[2]]] <- zk } if (length(xk)!=nk1 ) # right number of knots? stop(paste("there should be ",nk1," supplied knotsfor the x")) if (length(zk)!=nk2) # right number of knots? stop(paste("there should be ",nk2," supplied knots for z")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m[1]+2) X2 <- splineDesign(zk,z,ord=m[2]+2) X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) { X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for convexity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- -c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- c(1:(q2-i+1)) IS1 <- matrix(0,q1,q1) # Define marginal matrix of Sigma for decreasing constraint IS1[1:q1,1] <- -rep(1,q1) for (j in 2:q1) IS1[j,2:j] <- -1 Sig <- IS1 %x% IS2 # apply identifiability constraint and get model matrix X <- X[,2:ncol(X)]%*%Sig[2:ncol(Sig),2:ncol(Sig)] ## applying sum-to-zero (centering) constraint... ## cmx <- colMeans(X) ## X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix with identifiability constraint ## object$cmX <- cmx # create the penalty matrix S <- list() I2<- diag(q2) I1 <- diff(diag(q1-1),difference=1) Pm1 <- matrix(0,q1-1,q1) # marginal sqrt penalty Pm1[2:(q1-1),2:q1] <- I1 S[[1]]<- Pm1%x%I2 I2 <- diff(diag(q2-2),difference=1) Pm2 <- matrix(0,q2-1,q2) Pm2[3:(q2-1),3:q2] <- I2 # marginal sqrt penalty I1 <- diag(q1) S[[2]] <- I1%x%Pm2 object$P <- list() object$P[[1]] <- S[[1]][2:nrow(S[[1]]),2:ncol(S[[1]])] object$P[[2]] <- S[[2]][2:nrow(S[[2]]),2:ncol(S[[2]])] object$S <- list() object$S[[1]] <- crossprod(object$P[[1]]) ## t(object$P[[1]])%*%object$P[[1]] object$S[[2]] <- crossprod(object$P[[2]]) ## t(object$P[[2]])%*%object$P[[2]] object$p.ident <- rep(TRUE,q1*q2-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- diag(q1*q2-1) # identfiability constraint matrix object$Zc <- rbind(rep(0,ncol(object$Zc)),object$Zc) ## store "tedecv" specific stuff ... object$knots <- list() object$knots[[1]] <- xk object$knots[[2]] <- zk object$m <- m object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"tedecv.smooth" # Give object a class object } #################################################################### Predict.matrix.tedecv.smooth <- function(object, data) { ## prediction method function for the `tedecv' smooth class if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} bm <- marginal.linear.extrapolation(object, data) n <- length(data[[object$term[1]]]) X <- matrix(0,n,q1*q2) # model matrix for ( i in 1:n) { X[i,] <- bm$X1[i,] %x% bm$X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for convexity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- -c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- c(1:(q2-i+1)) IS1 <- matrix(0,q1,q1) # Define marginal matrix of Sigma for decreasing constraint IS1[1:q1,1] <- -rep(1,q1) for (j in 2:q1) IS1[j,2:j] <- -1 Sig <- IS1 %x% IS2 # get final model matrix X <- X %*%Sig ## X <- sweep(X,2,c(0,object$cmX)) X # return the prediction matrix } ################################################################ ## Tensor product P-spline construction with mixed constraints: ## decreasing wrt the 1st covariate and convex wrt the 2nd covariate ... ################################################################# smooth.construct.tedecx.smooth.spec<- function(object, data, knots) ## construction of the bivariate smooth surface with mixed constraints: decreasing ## wrt the first covariate and concave wrt the 2nd one... { if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) {m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths object$p.order <- m } else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) object$p.order[is.na(object$p.order)] <- 2 if (object$bs.dim[1]==-1) { # set the default values for q1 and q2 q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1){ q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths object$bs.dim <- rep(object$bs.dim, 2) } else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth nk2 <- q2+m[2]+2 ## number of knots for the 2nd smooth if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied if (is.null(xk)) # space knots through the values of the 1st covariate { n<-length(x) xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} knots[[object$term[1]]] <- xk } if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)) # space knots through the values of the 2nd covariate { zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} knots[[object$term[2]]] <- zk } if (length(xk)!=nk1 ) # right number of knots? stop(paste("there should be ",nk1," supplied knotsfor the x")) if (length(zk)!=nk2) # right number of knots? stop(paste("there should be ",nk2," supplied knots for z")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m[1]+2) X2 <- splineDesign(zk,z,ord=m[2]+2) X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) { X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for concavity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- -c(1:(q2-i+1)) IS1 <- matrix(0,q1,q1) # Define marginal matrix of Sigma for decreasing constraint IS1[1:q1,1] <- -rep(1,q1) for (j in 2:q1) IS1[j,2:j] <- -1 Sig <- IS1 %x% IS2 # apply identifiability constraint and get model matrix X <- X[,2:ncol(X)]%*%Sig[2:ncol(Sig),2:ncol(Sig)] ## applying sum-to-zero (centering) constraint... ## cmx <- colMeans(X) ## X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix with identifiability constraint ## object$cmX <- cmx # create the penalty matrix S <- list() I2<- diag(q2) I1 <- diff(diag(q1-1),difference=1) Pm1 <- matrix(0,q1-1,q1) # marginal sqrt penalty Pm1[2:(q1-1),2:q1] <- I1 S[[1]]<- Pm1%x%I2 I2 <- diff(diag(q2-2),difference=1) Pm2 <- matrix(0,q2-1,q2) Pm2[3:(q2-1),3:q2] <- I2 # marginal sqrt penalty I1 <- diag(q1) S[[2]] <- I1%x%Pm2 object$P <- list() object$P[[1]] <- S[[1]][2:nrow(S[[1]]),2:ncol(S[[1]])] object$P[[2]] <- S[[2]][2:nrow(S[[2]]),2:ncol(S[[2]])] object$S <- list() object$S[[1]] <- crossprod(object$P[[1]]) ## t(object$P[[1]])%*%object$P[[1]] object$S[[2]] <- crossprod(object$P[[2]]) ## t(object$P[[2]])%*%object$P[[2]] object$p.ident <- rep(TRUE,q1*q2-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- diag(q1*q2-1) # identfiability constraint matrix object$Zc <- rbind(rep(0,ncol(object$Zc)),object$Zc) ## store "tedecx" specific stuff ... object$knots <- list() object$knots[[1]] <- xk object$knots[[2]] <- zk object$m <- m object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"tedecx.smooth" # Give object a class object } #################################################################### Predict.matrix.tedecx.smooth <- function(object, data) { ## prediction method function for the `tedecx' smooth class if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} bm <- marginal.linear.extrapolation(object, data) n <- length(data[[object$term[1]]]) X <- matrix(0,n,q1*q2) # model matrix for ( i in 1:n) { X[i,] <- bm$X1[i,] %x% bm$X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for concavity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- -c(1:(q2-i+1)) IS1 <- matrix(0,q1,q1) # Define marginal matrix of Sigma for decreasing constraint IS1[1:q1,1] <- -rep(1,q1) for (j in 2:q1) IS1[j,2:j] <- -1 Sig <- IS1 %x% IS2 # get final model matrix X <- X %*%Sig ## X <- sweep(X,2,c(0,object$cmX)) X # return the prediction matrix } ################################################################ ## Tensor product P-spline construction with single concavity constraint ## wrt the 2nd covariate ... ################################################################# #################################################################### marginal.matrices.tescv.ps <- function(x,z,xk,zk,m,q1,q2) ## function to get marginal model matrices and penalties in the overall ## model coefficients in case of P-splines basis for the 1st unconstrained smooth { # get marginal model matrix for the first unconstrained smooth... X1 <- splineDesign(xk,x,ord=m[1]+2) # get marginal model matrix for the second concave smooth... X2 <- splineDesign(zk,z,ord=m[2]+2) # create the penalty matrix... S <- list() # get penalty matrix for the first unconstrained smooth... I2 <- diag(q2) P <- diff(diag(q1),difference=1) S[[1]]<- P %x% I2 c1 <- c(1,-2,1) c2 <- c(1,rep(0,q2-1)) c <- c1 %x% c2 for (i in 1:(q1-2)){ S[[1]][q2*(i-1)+1,(q2*(i-1)+1):(q2*(i-1)+length(c))] <- c } i <- q1-1 S[[1]][q2*(i-1)+1,(q2*(i-1)+1):ncol(S[[1]])] <- rep(0,2*q2) S[[1]] <- crossprod(S[[1]]) ## t(S[[1]])%*%S[[1]] # get penalty for the 2nd concave smooth... I2 <- diff(diag(q2-2),difference=1) P <- matrix(0,q2-1,q2) P[3:(q2-1),3:q2] <- I2 # marginal sqrt penalty I1 <- diag(q1) S[[2]] <- I1%x%P S[[2]] <- crossprod(S[[2]]) ## t(S[[2]])%*%S[[2]] list(X1=X1, X2=X2, S=S) } smooth.construct.tescv.smooth.spec<- function(object, data, knots) ## construction of the bivariate smooth surface with single concavity constraint ## wrt the 2nd covariate ... { if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) {m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths object$p.order <- m } else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) object$p.order[is.na(object$p.order)] <- 2 if (object$bs.dim[1]==-1) { # set the default values for q1 and q2 q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1){ q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths object$bs.dim <- rep(object$bs.dim, 2) } else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth nk2 <- q2+m[2]+2 ## number of knots for the 2nd smooth if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied if (is.null(xk)) # space knots through the values of the 1st covariate { n<-length(x) xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} knots[[object$term[1]]] <- xk } if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)) # space knots through the values of the 2nd covariate { zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} knots[[object$term[2]]] <- zk } if (length(xk)!=nk1 ) # right number of knots? stop(paste("there should be ",nk1," supplied knotsfor the x")) if (length(zk)!=nk2) # right number of knots? stop(paste("there should be ",nk2," supplied knots for z")) # get model matrix------------- bm <- marginal.matrices.tescv.ps(x,z,xk,zk,m,q1,q2) X1 <- bm$X1 X2 <- bm$X2 S <- bm$S # get the overall model matrix... X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) { X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for concavity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- -c(1:(q2-i+1)) I <- diag(q1) ## identity matrix for the unconstrained marginal Sig <- I%x%IS2 # get model matrix X <- X%*%Sig # apply identifiability constraint and get model matrix D<- diag(q1*q2) D<- D[,-1] ## D[,-((q1-1)*q2+1)] ind <- rep(0,q1-1) # get index number for the cells to be changed to "-1" for (i in 1:(q1-1)){ ind[i] <- (i-1)*q2+1 D[ind[i],ind[i]] <- -1 } for (i in 2:(q1-1)) D[ind[i],ind[i]-q2] <- 1 D[((q1-1)*q2+1),((q1-1)*q2+1-q2)] <- 1 X <- X%*%D ## applying sum-to-zero (centering) constraint... ## cmx <- colMeans(X) ## X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix with identifiability constraint ## object$cmX <- cmx # create the penalty matrix object$S <- list() object$S[[1]] <- crossprod(D,S[[1]])%*%D ## t(D)%*%S[[1]]%*%D object$S[[2]] <- crossprod(D,S[[2]])%*%D ## t(D)%*%S[[2]]%*%D object$p.ident <- rep(TRUE,q1*q2-1) object$p.ident[ind] <- FALSE ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- D # identifiability constraint matrix ## store "tescv" specific stuff ... object$knots <- list() if (is.null(xk)) object$knots[[1]] <- rep(0,0,0) else object$knots[[1]] <- xk object$knots[[2]] <- zk object$m <- m object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"tescv.smooth" # Give object a class object } #################################################################### Predict.matrix.tescv.smooth <- function(object, data) { ## prediction method function for the `tescv' smooth class if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} bm <- marginal.linear.extrapolation(object, data) n <- length(data[[object$term[1]]]) X <- matrix(0,n,q1*q2) # model matrix for ( i in 1:n) { X[i,] <- bm$X1[i,] %x% bm$X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for concavity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- -c(1:(q2-i+1)) I <- diag(q1) ## identity matrix for the unconstrained marginal Sig <- I%x%IS2 # get final model matrix X <- X %*%Sig X # return the prediction matrix } ################################################################ ## Tensor product P-spline construction with single convexity ## constraint wrt the second covariate ... ################################################################ smooth.construct.tescx.smooth.spec<- function(object, data, knots) ## construction of the bivariate smooth surface with single convexity ## constraint wrt the second covariate ... { if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) {m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths object$p.order <- m } else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) object$p.order[is.na(object$p.order)] <- 2 if (object$bs.dim[1]==-1) { # set the default values for q1 and q2 q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1){ q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths object$bs.dim <- rep(object$bs.dim, 2) } else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth nk2 <- q2+m[2]+2 ## number of knots for the 2nd smooth if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied if (is.null(xk)) # space knots through the values of the 1st covariate { n<-length(x) xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} knots[[object$term[1]]] <- xk } if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)) # space knots through the values of the 2nd covariate { zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} knots[[object$term[2]]] <- zk } if (length(xk)!=nk1 ) # right number of knots? stop(paste("there should be ",nk1," supplied knotsfor the x")) if (length(zk)!=nk2) # right number of knots? stop(paste("there should be ",nk2," supplied knots for z")) # get model matrix------------- bm <- marginal.matrices.tescv.ps(x,z,xk,zk,m,q1,q2) X1 <- bm$X1 X2 <- bm$X2 S <- bm$S # get the overall model matrix... X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) { X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for convexity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- -c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- c(1:(q2-i+1)) I <- diag(q1) ## identity matrix for the unconstrained marginal Sig <- I%x%IS2 # get model matrix X <- X%*%Sig # apply identifiability constraint D<- diag(q1*q2) D<- D[,-1] ## D[,-((q1-1)*q2+1)] ind <- rep(0,q1-1) # get index number for the cells to be changed to "-1" for (i in 1:(q1-1)){ ind[i] <- (i-1)*q2+1 D[ind[i],ind[i]] <- -1 } for (i in 2:(q1-1)) D[ind[i],ind[i]-q2] <- 1 D[((q1-1)*q2+1),((q1-1)*q2+1-q2)] <- 1 X <- X%*%D ## applying sum-to-zero (centering) constraint... ## cmx <- colMeans(X) ## X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix with identifiability constraint ## object$cmX <- cmx # create the penalty matrix object$S <- list() object$S[[1]] <- crossprod(D,S[[1]])%*%D ## t(D)%*%S[[1]]%*%D object$S[[2]] <- crossprod(D,S[[2]])%*%D ## t(D)%*%S[[2]]%*%D object$p.ident <- rep(TRUE,q1*q2-1) object$p.ident[ind] <- FALSE ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- D # identifiability constraint matrix ## store "tescx" specific stuff ... object$knots <- list() if (is.null(xk)) object$knots[[1]] <- rep(0,0,0) else object$knots[[1]] <- xk object$knots[[2]] <- zk object$m <- m object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"tescx.smooth" # Give object a class object } #################################################################### Predict.matrix.tescx.smooth <- function(object, data) { ## prediction method function for the `tescx' smooth class if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} bm <- marginal.linear.extrapolation(object, data) n <- length(data[[object$term[1]]]) X <- matrix(0,n,q1*q2) # model matrix for ( i in 1:n) { X[i,] <- bm$X1[i,] %x% bm$X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for convexity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- -c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- c(1:(q2-i+1)) I <- diag(q1) ## identity matrix for the unconstrained marginal Sig <- I%x%IS2 # get final model matrix X <- X %*%Sig X # return the prediction matrix } ############################################################# ## Tensor product P-spline construction with double concavity ## constraint ... ############################################################## smooth.construct.tecvcv.smooth.spec<- function(object, data, knots) ## construction of the bivariate smooth surface with double concavity constraint... { if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) {m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths object$p.order <- m } else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) object$p.order[is.na(object$p.order)] <- 2 if (object$bs.dim[1]==-1) { # set the default values for q1 and q2 q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1){ q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths object$bs.dim <- rep(object$bs.dim, 2) } else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth nk2 <- q2+m[2]+2 ## number of knots for the 2nd smooth if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied if (is.null(xk)) # space knots through the values of the 1st covariate { n<-length(x) xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} knots[[object$term[1]]] <- xk } if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)) # space knots through the values of the 2nd covariate { zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} knots[[object$term[2]]] <- zk } if (length(xk)!=nk1 ) # right number of knots? stop(paste("there should be ",nk1," supplied knotsfor the x")) if (length(zk)!=nk2) # right number of knots? stop(paste("there should be ",nk2," supplied knots for z")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m[1]+2) X2 <- splineDesign(zk,z,ord=m[2]+2) X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) { X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for concavity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- -c(1:(q2-i+1)) IS1 <- matrix(0,q1,q1) # Define marginal matrix of Sigma for concavity constraint wrt the first covariate IS1[1:q1,1] <- rep(1,q1) IS1[2:q1,2]<- c(1:(q1-1)) for (i in 3:q1) IS1[i:q1,i] <- -c(1:(q1-i+1)) Sig <- IS1 %x% IS2 # apply identifiability constraint and get model matrix X <- X[,2:ncol(X)]%*%Sig[2:ncol(Sig),2:ncol(Sig)] ## applying sum-to-zero (centering) constraint... cmx <- colMeans(X) X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix with identifiability constraint object$cmX <- cmx # create the penalty matrix S <- list() I2<- diag(q2) I1 <- diff(diag(q1-1),difference=1) Pm1 <- matrix(0,q1-1,q1) # marginal sqrt penalty Pm1[2:(q1-1),2:q1] <- I1 S[[1]]<- Pm1%x%I2 I2 <- diff(diag(q2-2),difference=1) Pm2 <- matrix(0,q2-1,q2) Pm2[3:(q2-1),3:q2] <- I2 # marginal sqrt penalty I1 <- diag(q1) S[[2]] <- I1%x%Pm2 object$P <- list() object$P[[1]] <- S[[1]][2:nrow(S[[1]]),2:ncol(S[[1]])] object$P[[2]] <- S[[2]][2:nrow(S[[2]]),2:ncol(S[[2]])] object$S <- list() object$S[[1]] <- crossprod(object$P[[1]]) ## t(object$P[[1]])%*%object$P[[1]] object$S[[2]] <- crossprod(object$P[[2]]) ## t(object$P[[2]])%*%object$P[[2]] object$p.ident <- rep(TRUE,q1*q2-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- diag(q1*q2-1) # identfiability constraint matrix object$Zc <- rbind(rep(0,ncol(object$Zc)),object$Zc) ## store "tecvcv" specific stuff ... object$knots <- list() object$knots[[1]] <- xk object$knots[[2]] <- zk object$m <- m object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"tecvcv.smooth" # Give object a class object } #################################################################### Predict.matrix.tecvcv.smooth <- function(object, data) { ## prediction method function for the `tecvcv' smooth class if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} bm <- marginal.linear.extrapolation(object, data) n <- length(data[[object$term[1]]]) X <- matrix(0,n,q1*q2) # model matrix for ( i in 1:n) { X[i,] <- bm$X1[i,] %x% bm$X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for concavity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- -c(1:(q2-i+1)) IS1 <- matrix(0,q1,q1) # Define marginal matrix of Sigma for concavity constraint wrt the 1st covariate...... IS1[1:q1,1] <- rep(1,q1) IS1[2:q1,2]<- c(1:(q1-1)) for (i in 3:q1) IS1[i:q1,i] <- -c(1:(q1-i+1)) Sig <- IS1 %x% IS2 # get final model matrix X <- X %*%Sig X <- sweep(X,2,c(0,object$cmX)) X # return the prediction matrix } ################################################################ ## Tensor product P-spline construction with double convexity ## constraint... ################################################################ smooth.construct.tecxcx.smooth.spec<- function(object, data, knots) ## construction of the bivariate smooth surface with double ## convexity constraint... { if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) {m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths object$p.order <- m } else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) object$p.order[is.na(object$p.order)] <- 2 if (object$bs.dim[1]==-1) { # set the default values for q1 and q2 q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1){ q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths object$bs.dim <- rep(object$bs.dim, 2) } else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth nk2 <- q2+m[2]+2 ## number of knots for the 2nd smooth if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied if (is.null(xk)) # space knots through the values of the 1st covariate { n<-length(x) xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} knots[[object$term[1]]] <- xk } if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)) # space knots through the values of the 2nd covariate { zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} knots[[object$term[2]]] <- zk } if (length(xk)!=nk1 ) # right number of knots? stop(paste("there should be ",nk1," supplied knotsfor the x")) if (length(zk)!=nk2) # right number of knots? stop(paste("there should be ",nk2," supplied knots for z")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m[1]+2) X2 <- splineDesign(zk,z,ord=m[2]+2) X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) { X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for convexity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- -c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- c(1:(q2-i+1)) IS1 <- matrix(0,q1,q1) # Define marginal matrix of Sigma for convexity IS1[1:q1,1] <- rep(1,q1) IS1[2:q1,2]<- -c(1:(q1-1)) for (i in 3:q1) IS1[i:q1,i] <- c(1:(q1-i+1)) Sig <- IS1 %x% IS2 # apply identifiability constraint and get model matrix X <- X[,2:ncol(X)]%*%Sig[2:ncol(Sig),2:ncol(Sig)] ## applying sum-to-zero (centering) constraint... cmx <- colMeans(X) X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix with identifiability constraint object$cmX <- cmx # create the penalty matrix S <- list() I2<- diag(q2) I1 <- diff(diag(q1-1),difference=1) Pm1 <- matrix(0,q1-1,q1) # marginal sqrt penalty Pm1[2:(q1-1),2:q1] <- I1 S[[1]]<- Pm1%x%I2 I2 <- diff(diag(q2-2),difference=1) Pm2 <- matrix(0,q2-1,q2) Pm2[3:(q2-1),3:q2] <- I2 # marginal sqrt penalty I1 <- diag(q1) S[[2]] <- I1%x%Pm2 object$P <- list() object$P[[1]] <- S[[1]][2:nrow(S[[1]]),2:ncol(S[[1]])] object$P[[2]] <- S[[2]][2:nrow(S[[2]]),2:ncol(S[[2]])] object$S <- list() object$S[[1]] <- crossprod(object$P[[1]]) ## t(object$P[[1]])%*%object$P[[1]] object$S[[2]] <- crossprod(object$P[[2]]) ## t(object$P[[2]])%*%object$P[[2]] object$p.ident <- rep(TRUE,q1*q2-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- diag(q1*q2-1) # identfiability constraint matrix object$Zc <- rbind(rep(0,ncol(object$Zc)),object$Zc) ## store "tecxcx" specific stuff ... object$knots <- list() object$knots[[1]] <- xk object$knots[[2]] <- zk object$m <- m object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"tecxcx.smooth" # Give object a class object } #################################################################### Predict.matrix.tecxcx.smooth <- function(object, data) { ## prediction method function for the `tecxcx' smooth class if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} bm <- marginal.linear.extrapolation(object, data) n <- length(data[[object$term[1]]]) X <- matrix(0,n,q1*q2) # model matrix for ( i in 1:n) { X[i,] <- bm$X1[i,] %x% bm$X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for convexity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- -c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- c(1:(q2-i+1)) IS1 <- matrix(0,q1,q1) # Define marginal matrix of Sigma for convexity IS1[1:q1,1] <- rep(1,q1) IS1[2:q1,2]<- -c(1:(q1-1)) for (i in 3:q1) IS1[i:q1,i] <- c(1:(q1-i+1)) Sig <- IS1 %x% IS2 # get final model matrix X <- X %*%Sig X <- sweep(X,2,c(0,object$cmX)) X # return the prediction matrix } ################################################################ ## Tensor product P-spline construction with convexity ## constraint along the 1st covarite and concavity along the 2nd... ################################################################ smooth.construct.tecxcv.smooth.spec<- function(object, data, knots) ## construction of the bivariate smooth surface with convexity ## constraint along the 1st covarite and concavity along the 2nd... { if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) {m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths object$p.order <- m } else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) object$p.order[is.na(object$p.order)] <- 2 if (object$bs.dim[1]==-1) { # set the default values for q1 and q2 q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1){ q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths object$bs.dim <- rep(object$bs.dim, 2) } else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth nk2 <- q2+m[2]+2 ## number of knots for the 2nd smooth if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied if (is.null(xk)) # space knots through the values of the 1st covariate { n<-length(x) xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} knots[[object$term[1]]] <- xk } if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)) # space knots through the values of the 2nd covariate { zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} knots[[object$term[2]]] <- zk } if (length(xk)!=nk1 ) # right number of knots? stop(paste("there should be ",nk1," supplied knotsfor the x")) if (length(zk)!=nk2) # right number of knots? stop(paste("there should be ",nk2," supplied knots for z")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m[1]+2) X2 <- splineDesign(zk,z,ord=m[2]+2) X <- matrix(0,n,q1*q2) # model matrix for (i in 1:n) { X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS1 <- matrix(0,q1,q1) # Define marginal matrix of Sigma for convexity IS1[1:q1,1] <- rep(1,q1) IS1[2:q1,2]<- -c(1:(q1-1)) for (i in 3:q1) IS1[i:q1,i] <- c(1:(q1-i+1)) IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for concavity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- -c(1:(q2-i+1)) Sig <- IS1 %x% IS2 # apply identifiability constraint and get model matrix X <- X[,2:ncol(X)]%*%Sig[2:ncol(Sig),2:ncol(Sig)] ## applying sum-to-zero (centering) constraint... ## cmx <- colMeans(X) ## X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix with identifiability constraint ## object$cmX <- cmx # create the penalty matrix S <- list() I2<- diag(q2) I1 <- diff(diag(q1-1),difference=1) Pm1 <- matrix(0,q1-1,q1) # marginal sqrt penalty Pm1[2:(q1-1),2:q1] <- I1 S[[1]]<- Pm1%x%I2 I2 <- diff(diag(q2-2),difference=1) Pm2 <- matrix(0,q2-1,q2) Pm2[3:(q2-1),3:q2] <- I2 # marginal sqrt penalty I1 <- diag(q1) S[[2]] <- I1%x%Pm2 object$P <- list() object$P[[1]] <- S[[1]][2:nrow(S[[1]]),2:ncol(S[[1]])] object$P[[2]] <- S[[2]][2:nrow(S[[2]]),2:ncol(S[[2]])] object$S <- list() object$S[[1]] <- crossprod(object$P[[1]]) ## t(object$P[[1]])%*%object$P[[1]] object$S[[2]] <- crossprod(object$P[[2]]) ## t(object$P[[2]])%*%object$P[[2]] object$p.ident <- rep(TRUE,q1*q2-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- diag(q1*q2-1) # identfiability constraint matrix object$Zc <- rbind(rep(0,ncol(object$Zc)),object$Zc) ## store "tecxcv" specific stuff ... object$knots <- list() object$knots[[1]] <- xk object$knots[[2]] <- zk object$m <- m object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"tecxcv.smooth" # Give object a class object } ############################################# Predict.matrix.tecxcv.smooth <- function(object, data) { ## prediction method function for the `tecxcv' smooth class if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} bm <- marginal.linear.extrapolation(object, data) n <- length(data[[object$term[1]]]) X <- matrix(0,n,q1*q2) # model matrix for ( i in 1:n) { X[i,] <- bm$X1[i,] %x% bm$X2[i,] # Kronecker product of two rows of marginal model matrices } # get a matrix Sigma ----------------------- IS1 <- matrix(0,q1,q1) # Define marginal matrix of Sigma for convexity IS1[1:q1,1] <- rep(1,q1) IS1[2:q1,2]<- -c(1:(q1-1)) for (i in 3:q1) IS1[i:q1,i] <- c(1:(q1-i+1)) IS2 <- matrix(0,q2,q2) # Define marginal matrix of Sigma for concavity IS2[1:q2,1] <- rep(1,q2) IS2[2:q2,2]<- c(1:(q2-1)) for (i in 3:q2) IS2[i:q2,i] <- -c(1:(q2-i+1)) Sig <- IS1 %x% IS2 # get final model matrix X <- X %*%Sig ## X <- sweep(X,2,c(0,object$cmX)) X # return the prediction matrix } scam/R/bfgs.r0000644000176200001440000006277415153754544012537 0ustar liggesusers## (c) Natalya Pya (2012-2026). Provided under GPL 2. ## routines for smoothing parameter selection using BFGS for GCV/UBRE minimization ## with modifications on convergence control, scaling, etc... ############################################################## ## function to get the gcv/ubre value and their gradient ## ############################################################## gcv.ubre_grad <- function(rho, G, env, control) { ## G - object from scam setup via gam(..., fit=FALSE) ## rho - logarithm of the smoothing parameters ## gamma - an ad hoc parametrer of the GCV ## check.analytical - logical whether the analytical gradient of GCV/UBRE should be checked ## del - increment for finite differences when checking analytical gradients y <- drop(G$y); X <- G$X; gamma <- G$gamma S <- G$S; not.exp <- G$not.exp ## q0 <- G$q0; q.f <- G$q.f p.ident <- G$p.ident; n.terms <- G$n.terms family <- G$family; intercept <- G$intercept; offset <- G$offset; weights <- G$weights; scale.known <- G$scale.known; sig2 <- G$sig2 n.pen <- length(S) # number of penalties if (length(rho)!=n.pen) stop (paste("length of rho and # penalties has to be the same")) sp <- exp(rho) ## fit the model with the given values of the smoothing parameters... b <- scam.fit(G=G,sp=sp, env=env, control=control) n <- nobs <- nrow(G$X) q <- ncol(G$X) if (G$AR1.rho!=0) { ld <- 1/sqrt(1-G$AR1.rho^2) ## leading diagonal of root inverse correlation sd <- -G$AR1.rho*ld ## sub diagonal row <- c(1,rep(1:nobs,rep(2,nobs))[-c(1,2*nobs)]) weight.r <- c(1,rep(c(sd,ld),nobs-1)) end <- c(1,1:(nobs-1)*2+1) if (!is.null(G$AR.start)) { ## need to correct the start of new AR sections... ii <- which(G$AR.start==TRUE) if (length(ii)>0) { if (ii[1]==1) ii <- ii[-1] ## first observation does not need any correction weight.r[ii*2-2] <- 0 ## zero sub diagonal weight.r[ii*2-1] <- 1 ## set leading diagonal to 1 } } ## apply transform... X <- rwMatrix(end,row,weight.r,G$X) y <- rwMatrix(end,row,weight.r,G$y) } y.mu <- y - b$mu## b$y-b$mu c <- -2*y.mu/(b$Var*b$dlink.mu) ## diag.C <- rep(1,q) # diagonal elements of matrix C with estimates of beta at convergence ## diag.C[b$iv] <- b$beta.t[b$iv] ## diag.C <- b$Cdiag ## D.beta <- (diag.C*t(b$X))%*%c # derivative of the deviance w.r.t. beta D.beta <- t(b$X1)%*%c # derivative of the deviance w.r.t. beta ## ----------------------------------------------------------- ## calculation of the deviance derivative wrt rho D.rho <- rep(0,n.pen) # define derivative of the deviance wrt rho D.rho <- t(D.beta)%*%b$dbeta.rho ## ------------------------------------------------------------ ## calculating the derivative of tr(A) w.r.t. log(sp) d2link.dlink <- b$d2link.mu/b$dlink.mu a1 <- as.numeric(y.mu*d2link.dlink) # a constant for updating the derivative of z ## a2 <- as.numeric(b$w^2*(b$dvar.mu*b$dlink.mu+2*b$Var*b$d2link.mu)) # a constant for updating the derivative of w a2 <- as.numeric(b$w1^2*(b$dvar.mu*b$dlink.mu+2*b$Var*b$d2link.mu)) # a constant for updating the derivative of w (corrected in scam_1.2-22) eta.rho <- matrix(0,n,n.pen) # define derivatives of the linear predictor N_rho <- matrix(0,q,n.pen) # define diagonal elements of N_j w.rho <- matrix(0,n,n.pen) # define derivatives of the diagonal elements of W alpha.rho <- matrix(0,n,n.pen) # define derivatives of alpha T_rho <- matrix(0,n,n.pen) # define diagonal elements of T_j ## a constant for the derivative of the alpha dvar.var <- b$dvar.mu/b$Var alpha1 <- as.numeric(-(dvar.var+d2link.dlink)/b$dlink.mu - y.mu*(dvar.var^2 + d2link.dlink^2 - b$d2var.mu/b$Var - b$d3link.mu/b$dlink.mu)/b$dlink.mu) eta.rho <- b$X1%*%b$dbeta.rho N_rho[b$iv,] <- b$dbeta.rho[b$iv,] alpha.rho <- alpha1*eta.rho w.rho <- -a2*b$alpha*eta.rho + b$w1*alpha.rho T_rho <- w.rho /b$abs.w z2 <- b$dlink.mu*y.mu # term for the derivative of E w1.rho <- matrix(0,n,n.pen) # define derivatives of the diagonal elements of W1 T1_rho <- matrix(0,n,n.pen) # define diagonal elements of T1_j Q_rho <- matrix(0,q,n.pen) # derivative of E diagonal wrt log(sp[j]) w1.rho <- -a2*eta.rho T1_rho <- w1.rho/b$w1 term <- T1_rho*z2 + a1*eta.rho- eta.rho Q_rho <- N_rho*drop(b$C2diag*crossprod(X,b$w1*z2)) + b$C1diag*crossprod(X,b$w1*term) ## Q_rho <- N_rho*drop(b$C1diag*(t(b$X)%*%(b$w1*z2))) + ## b$C1diag*(t(b$X)%*%(b$w1*(T1_rho*z2 + a1*eta.rho- eta.rho))) ## efficient version of derivative of trA... KtIL <- t((b$L*b$I.plus)*b$K) KtILK <- KtIL%*%b$K KKtILK <- b$K%*%KtILK ## KtIQ1R <- if (!not.exp) crossprod(b$I.plus*b$K,b$wX1) else crossprod(b$I.plus*b$K,b$wXC1) ## KtILQ1R<-if (!not.exp) crossprod(b$L*b$I.plus*b$K,b$wX1) else crossprod(b$L*b$I.plus*b$K,b$wXC1) trA.rho<-rep(0,n.pen) #if (n.pen>0) for (j in 1:n.pen){ trA.rho[j] <- - 2*sum(KtILK*(b$KtIQ1R%*%(N_rho[,j]*b$P))) - sum((T_rho[,j]*KKtILK)*b$K) - sp[j]*sum((t(b$P)%*%b$S[[j]]%*%b$P)*t(KtILK) )+ sum( (t(b$P)%*%(c(Q_rho[,j])*b$P))*t(KtILK) ) + 2*sum( b$KtILQ1R*t(N_rho[,j]*b$P) ) + #2*sum(KtILQ1R*t(N_rho[,j]*b$P) ) + sum(KtIL*t(T1_rho[,j]*b$K)) } ## Calculating the derivatives of the trA is completed here ----- if (scale.known) ## derivative of Mallow's Cp/UBRE/AIC wrt log(sp) { ubre.rho <- rep(0,n.pen) #if (n.pen>0) for (j in 1:n.pen){ ubre.rho[j] <- D.rho[j]/n +2*gamma*trA.rho[j]*sig2/n } gcv.ubre.rho <- ubre.rho gcv.ubre <- b$dev/n - sig2 +2*gamma*b$trA*sig2/n } else { # derivative of GCV wrt log(sp) ... gcv.rho<-rep(0,n.pen) # define the derivatives of the gcv #if (n.pen>0) for (j in 1:n.pen){ gcv.rho[j]<-n*(D.rho[j]*(n-gamma*b$trA)+2*gamma*b$dev*trA.rho[j])/(n-gamma*b$trA)^3 } gcv.ubre <- b$gcv gcv.ubre.rho <- gcv.rho } ## checking the derivatives by finite differences----------- dgcv.ubre.check <- NULL if (control$bfgs$check.analytical){ ##del <- del #1e-4 sp1 <- rep(0,n.pen) dbeta.check <- matrix(0,q,n.pen) dtrA.check <- rep(0,n.pen) dgcv.ubre.check <- rep(0,n.pen) #if (n.pen>0) for (j in 1:n.pen){ sp1 <- sp; sp1[j] <- sp[j]*exp(control$bfgs$del) b1 <- scam.fit(G=G,sp=sp1, env=env,control=control) ## calculating the derivatives of beta estimates by finite differences... dbeta.check[,j] <- (b1$beta - b$beta)/control$bfgs$del ## calculating the derivatives of the trA by finite differences... dtrA.check[j] <- (b1$trA-b$trA)/control$bfgs$del ## calculating derivatives of GCV/UBRE by finite differences... if (scale.known) gcv.ubre1 <- b1$dev/n - sig2 + 2*gamma*b1$trA*sig2/n else gcv.ubre1 <- b1$gcv dgcv.ubre.check[j] <- (gcv.ubre1-gcv.ubre)/control$bfgs$del } } check.grad <- NULL if (control$bfgs$check.analytical) check.grad <- 100*(gcv.ubre.rho-dgcv.ubre.check)/dgcv.ubre.check ## end of checking the derivatives ---------------------------- list(dgcv.ubre=gcv.ubre.rho,gcv.ubre=gcv.ubre, scale.est=b$dev/(n-b$trA), check.grad=check.grad, dgcv.ubre.check=dgcv.ubre.check, object = b, trA.rho=trA.rho,D.rho=D.rho) } ## end of gcv.ubre_grad ##################################################### ## BFGS for gcv/ubre miminization.. ## ##################################################### bfgs_gcv.ubre <- function(fn=gcv.ubre_grad, rho, ini.fd=TRUE, G, env, n.pen=length(rho), typx=rep(1,n.pen), typf=1, control) ## steptol.bfgs= 1e-7, gradtol.bfgs = 1e-06, maxNstep = 5, maxHalf = 30, check.analytical, del, devtol.fit, steptol.fit) { ## fn - GCV/UBRE Function which returns the GCV/UBRE value and its derivative wrt log(sp) ## rho - log of the initial values of the smoothing parameters ## ini.fd - if TRUE, a finite difference to the Hessian is used to find the initial inverse Hessian ## typx - vector whose component is a positive scalar specifying the typical magnitude of sp ## typf - a positive scalar estimating the magnitude of the gcv near the minimum ## gradtol.bfgs - a scalar giving a tolerance at which the gradient is considered ## to be close enougth to 0 to terminate the BFGS algorithm ## steptol.bfgs - a positive scalar giving the tolerance at which the scaled distance between ## two successive iterates is considered close enough to zero to terminate the BFGS algorithm ## maxNstep - a positive scalar which gives the maximum allowable step length ## maxHalf - a positive scalar which gives the maximum number of step halving in "backtracking" ## check.analytical - logical whether the analytical gradient of GCV/UBRE should be checked ## del - increment for finite differences when checking analytical gradients ## devtol.fit, steptol.fit - scalars giving the tolerance for the full Newton methods to estimate model coefficients Sp <- 1/typx # diagonal of the scaling matrix maxNstep <- control$bfgs$maxNstep ## the maximum allowable step length ## storage for solution track rho1 <- rho old.rho <- rho not.exp <- G$not.exp b <- fn(rho,G, env, control=control) old.score <- score <- b$gcv.ubre max.step <- 200 score.hist <- rep(NA,max.step+1) ## storing scores for history, for plotting the gcv score.hist[1] <- score grad <- b$dgcv.ubre scale.est <- b$scale.est rm(b) ## The initial inverse Hessian ... if (ini.fd) { B <- matrix(0,n.pen,n.pen) feps <- 1e-4 #if (n.pen>0) for (j in 1:n.pen){ rho2 <- rho; rho2[j] <- rho[j] + feps b2 <- fn(rho2,G,env, control=control) B[,j] <- (b2$dgcv.ubre - grad)/feps rm(b2) } ## force initial Hessian to +ve def and invert... B <- (B+t(B))/2 ## B + t(B) eh <- eigen(B,symmetric=TRUE) eh$values <- abs(eh$values) ## eh$values[eh$values < 0] <- -eh$values[eh$values < 0] ##ind <- eh$values > max(eh$values)*.Machine$double.eps^75 ## index of non zero eigenvalues ##eh$values[ind] <- 1/eh$values[ind]; eh$values[!ind] <- 0 ##B <- eh$vectors%*%(eh$values*t(eh$vectors)) thresh <- max(eh$values) * 1e-4 eh$values[eh$values score.scale*control$bfgs$gradtol.bfgs # checking the gradient is within the tolerance if (!sum(unconv.ind)) ## if at least one is false unconv.ind <- unconv.ind | TRUE consecmax <- 0 ## Quasi-Newton algorithm to minimize GCV... for (i in 1:max.step) { ## compute a BFGS search direction ... Nstep <- 0*grad ## initialize the quasi-Newton step Nstep[unconv.ind] <- -drop(B[unconv.ind, unconv.ind]%*%grad[unconv.ind]) if (sum(Nstep*grad)>=0) { ## step not descending! ## Following would really be in the positive definite space... ##step[uconv.ind] <- -solve(chol2inv(chol(B))[uconv.ind,uconv.ind],initial$grad[uconv.ind]) Nstep <- -diag(B)*grad ## simple scaled steepest descent Nstep[!uconv.ind] <- 0 ## don't move if apparently converged } Dp <- Sp*Nstep Newtlen <- (sum(Dp^2))^.5 ## Euclidean norm to get the Newton step if (Newtlen > maxNstep) { ## reduce if max step is greater than the max allowable Nstep <- maxNstep*Nstep/Newtlen Newtlen <- maxNstep } maxtaken <- FALSE retcode <- 2 initslope <- sum(Nstep* grad) ## initial slope, directional derivative rellength <- max(abs(Nstep)/max(abs(rho),1/Sp)) ## relative length of rho for the stopping criteria alpha.min <- control$bfgs$steptol.bfgs/rellength alpha.max <- maxNstep/Newtlen ms <- max(abs(Nstep)) if (ms - maxNstep > .Machine$double.eps^.9) { ## if (ms > maxNstep), initialize step length, alpha alpha <- maxNstep/ms alpha.max <- alpha*1.05 } else { alpha <- 1 alpha.max <- min(2,maxNstep/ms) ## 1*maxNstep/ms } ##alpha <- 1 ## initialize step length ii <- 0 ## initialize the number of "step halving" step <- alpha*Nstep ## step length selection ... curv.condition <- TRUE repeat { rho1 <- rho + alpha*Nstep b <- fn(rho=rho1,G,env, control=control) score1 <- b$gcv.ubre if (score1 <= score+c1*alpha*initslope) {## check the first Wolfe condition (sufficient decrease)... grad1 <- b$dgcv.ubre ## Wolfe 1 met newslope <- sum(grad1 * Nstep) ## directional derivative curv.condition <- TRUE if (newslope < c2*initslope) {# the curvature condition (Wolfe 2) is not satisfied if (isTRUE(all.equal(alpha,1)) && Newtlen < maxNstep) ## if (alpha == 1 && Newtlen < maxNstep) { ## alpha.max <- maxNstep/Newtlen for (kk in 1:40) ## repeat { old.alpha <- alpha old.score1 <- score1 alpha <- min(2*alpha, alpha.max) rho1 <- rho + alpha*Nstep b <- fn(rho=rho1,G, env, control=control) score1 <- b$gcv.ubre if (score1 <= score+c1*alpha*initslope) { grad1 <- b$dgcv.ubre newslope <- sum(grad1*Nstep) } if (score1 > score+c1*alpha*initslope) break if (newslope >= c2*initslope) break if (alpha >= alpha.max) break } } if ((!isTRUE(all.equal(alpha,1)) && alpha < 1) || ((!isTRUE(all.equal(alpha,1)) && alpha>1) && (score1>score+c1*alpha*initslope))) ## if ((alpha < 1) || (alpha>1 && (score1>score+c1*alpha*initslope))) { alpha.lo <- min(alpha, old.alpha) alpha.diff <- abs(old.alpha - alpha) if (alpha < old.alpha) { sc.lo <- score1 sc.hi <- old.score1 } else { sc.lo <- old.score1 sc.hi <- score1 } for (kk in 1:40) ## repeat { alpha.incr <- -newslope*alpha.diff^2/(2*(sc.hi-(sc.lo+newslope*alpha.diff))) if (alpha.incr < .2*alpha.diff) alpha.incr <- .2*alpha.diff alpha <- alpha.lo+alpha.incr rho1 <- rho + alpha*Nstep b <- fn(rho=rho1,G, env, control=control) score1 <- b$gcv.ubre if (score1 > score+c1*alpha*initslope) { alpha.diff <- alpha.incr sc.hi <- score1 } else { grad1 <- b$dgcv.ubre newslope <- sum(grad1*Nstep) if (newslope < c2 *initslope) { alpha.lo <- alpha alpha.diff <- alpha.diff-alpha.incr sc.lo <- score1 } } if (abs(newslope) <= -c2*initslope) ## met Wolfe 2, curvature condition break if (alpha.diff < alpha.min) break } if (newslope < c2*initslope) ## couldn't satisfy curvature condition { curv.condition <- FALSE score1 <- sc.lo rho1 <- rho + alpha.lo*Nstep b <- fn(rho=rho1,G,env, control=control) } } ## end of "if ((alpha < 1) || (alpha>1 && ..." } ## end of "if (newslope < c2*initslope) ...", if Wolfe 2 not met retcode <- 0 if (newslope < c2*initslope) ## couldn't satisfy curvature condition, failed Wolfe 2 curv.condition <- FALSE if (alpha*Newtlen > .99*maxNstep) maxtaken <- TRUE } ## end of "if (score1 <= ...) ...", checking the first Wolfe condition (sufficient decrease) else if (alpha < alpha.min) {## no satisfactory rho+ can be found suff-ly distinct from previous rho retcode <- 1 rho1 <- rho b <- fn(rho=rho1,G,env, control=control) } else ## backtracking to satisfy the sufficient decrease condition... { ii <- ii+1 if (alpha == 1) {## first backtrack, quadratic fit alpha.temp <- -initslope/(score1-score-initslope)/2 } else { ## all subsequent backtracts, cubic fit A1 <- matrix(0,2,2) bb1 <-rep(0,2) ab <- rep(0,2) A1[1,1] <- 1/alpha^2 A1[1,2] <- -1/old.alpha^2 A1[2,1] <- -old.alpha/alpha^2 A1[2,2] <- alpha/old.alpha^2 bb1[1] <- score1-score-alpha*initslope bb1[2] <- old.score1 -score-old.alpha*initslope ab <- 1/(alpha-old.alpha)*A1%*%bb1 disc <- ab[2]^2-3*ab[1]*initslope if (ab[1] == 0) ## cubic is a quadratic alpha.temp <- -initslope/ab[2]/2 else ## legitimate cubic alpha.temp <- (-ab[2]+disc^.5)/(3*ab[1]) if (alpha.temp > .5*alpha) alpha.temp <- .5*alpha } old.alpha <- alpha old.score1 <- score1 if (alpha.temp <= .1*alpha) alpha <- .1*alpha else alpha <- alpha.temp } if (ii == control$bfgs$maxHalf) break if (retcode < 2) break } ## end of REPEAT for the step length selection ## rho1 is now new point. step <- alpha*Nstep old.score <-score old.rho <- rho rho <- rho1 old.grad <- grad score <- score1 grad <- b$dgcv.ubre score.hist[i+1] <- score ## update B... yg <- grad - old.grad skipupdate <- TRUE ## skip update if `step' is sufficiently close to B%*%yg ... #if (n.pen>0) for (j in 1:n.pen){ closeness <- step[j]-B[j,]%*%yg if (abs(closeness) >= control$bfgs$gradtol.bfgs*max(abs(grad[j]),abs(old.grad[j]))) skipupdate <- FALSE } ## skip update if curvature condition is not satisfied... if (!curv.condition) skipupdate <- TRUE if (!skipupdate) { if (i==1) { ## initial step --- adjust Hessian as p143 of N&W B <- B * alpha ## this is Simon's version ## B <- B * sum(yg*step)/sum(yg*yg) ## this is N&W } rr <- 1/sum(yg * step) B <- B - rr * step %*% crossprod(yg,B) # (t(yg)%*%B) B <- B - rr*tcrossprod((B %*% yg),step) + rr *tcrossprod(step) # B - rr*(B %*% yg) %*% t(step) + rr * step %*% t(step) } ## check the termination condition ... termcode <- 0 if (retcode ==1) { if (max(abs(grad)*max(abs(rho),1/Sp)/max(abs(score),typf))<= control$bfgs$gradtol.bfgs*6.0554) termcode <- 1 else termcode <- 3 } else if (max(abs(grad)*max(abs(rho),1/Sp)/max(abs(score),typf))<= control$bfgs$gradtol.bfgs*6.0554) termcode <- 1 else if (max(abs(rho-old.rho)/max(abs(rho),1/Sp))<= control$bfgs$steptol.bfgs) termcode <- 2 else if (i==max.step) termcode <- 4 else if (maxtaken) ## step of length maxNstep was taken { consecmax <- consecmax +1 if (consecmax ==5) termcode <- 5 # limit of 5 maxNsteps was reached } else consecmax <- 0 ##--------------------- if (termcode > 0) break else ## if not converged... { converged <- TRUE score.scale <- abs(b$scale.est) + abs(score) unconv.ind <- abs(grad) > score.scale * control$bfgs$gradtol.bfgs ##*.1 if (sum(unconv.ind)) converged <- FALSE if (abs(old.score - score) > score.scale*control$bfgs$gradtol.bfgs) { if (converged) unconv.ind <- unconv.ind | TRUE converged <- FALSE } } # end of ELSE } ## end of the Quasi-Newton algorithm ## final fit... ## b <- fn(rho=rho,G,gamma=gamma,env, control=control) ## printing why the algorithm terminated... if (termcode == 1) ct <- "Full convergence" else if (termcode == 2) ct <- "Successive iterates within tolerance, current iterate is probably solution" else if (termcode == 3) ct <- "Last step failed to locate a lower point than 'rho'" else if (termcode == 4) ct <- "Iteration limit reached" else if (termcode ==5) ct <- "Five consecutive steps of length maxNstep have been taken" ## else if (!curv.condition){ ## curvature condition not met; B can not be updated (can fail to be +ve def) ## termcode <- 6 ## ct <- "step failed" ## } list (gcv.ubre=score, rho=rho, dgcv.ubre=grad, iterations=i, B=B, conv.bfgs = ct, object=b$object, score.hist=score.hist[!is.na(score.hist)], termcode = termcode, check.grad= b$check.grad, dgcv.ubre.check = b$dgcv.ubre.check) } ## end bfgs_gcv.ubre ####### ## Note: bfgs needs checking for dealing with 'infinite' smoothing parameters (when converged)... scam/R/summary.scam.R0000644000176200001440000006775615133420123014157 0ustar liggesusers## (c) Natalya Pya (2012-2024). Provided under GPL 2. ## routines for getting summary information of the fitted scam... ## based on summary routines (c) Simon N Wood ############################################################ ## summary functions for scam() (clone of summary.gam())... ## of mgcv version 1.7-22, ## but without p.type=0,1,...,5 as summary input variable, ## only with freq=T/F.... ########################################################### ######################################################################## ##### function to get all the summary information of the fitted scam.... ######################################################################## model.matrix.scam <- function(object,...) { if (!inherits(object,"scam")) stop("`object' is not of class \"scam\"") predict(object,type="lpmatrix",...) } summary.scam <- function (object,dispersion = NULL,freq = FALSE,...) { pinv <- function(V, M, rank.tol = 1e-06) { ## a local pseudoinverse function D <- eigen(V,symmetric=TRUE) M1<-length(D$values[D$values>rank.tol*D$values[1]]) if (M>M1) M<-M1 # avoid problems with zero eigen-values if (M+1<=length(D$values)) D$values[(M+1):length(D$values)]<-1 D$values<- 1/D$values if (M+1<=length(D$values)) D$values[(M+1):length(D$values)]<-0 res <- D$vectors%*%(D$values*t(D$vectors)) ##D$u%*%diag(D$d)%*%D$v attr(res,"rank") <- M res } ## end of pinv p.table <- pTerms.table <- s.table <- NULL if (freq) covmat <- object$Ve.t else covmat <- object$Vp.t name <- names(object$coefficients.t) # name <- names(object$edf) dimnames(covmat) <- list(name, name) covmat.unscaled <- covmat/object$sig2 est.disp <- object$scale.estimated if (!is.null(dispersion)) { covmat <- dispersion * covmat.unscaled object$Ve.t <- object$Ve.t*dispersion/object$sig2 ## freq object$Vp.t <- object$Vp.t*dispersion/object$sig2 ## Bayes est.disp <- FALSE } else dispersion <- object$sig2 ## Now the individual parameteric coefficient p-values... ## (copied from mgcv-1.8-34 (c) Simon N Wood) ============ se <- diag(covmat)^0.5 residual.df<-length(object$y)-sum(object$edf) if (sum(object$nsdf) > 0) { # individual parameters if (length(object$nsdf)>1) { ## several linear predictors (not used in scam!) pstart <- attr(object$nsdf,"pstart") ind <- rep(0,0) for (i in 1:length(object$nsdf)) if (object$nsdf[i]>0) ind <- c(ind,pstart[i]:(pstart[i]+object$nsdf[i]-1)) } else { pstart <- 1;ind <- 1:object$nsdf} ## only one lp p.coeff <- object$coefficients[ind] p.se <- se[ind] p.t<-p.coeff/p.se if (!est.disp) { p.pv <- 2*pnorm(abs(p.t),lower.tail=FALSE) p.table <- cbind(p.coeff, p.se, p.t, p.pv) dimnames(p.table) <- list(names(p.coeff), c("Estimate", "Std. Error", "z value", "Pr(>|z|)")) } else { p.pv <- 2*pt(abs(p.t),df=residual.df,lower.tail=FALSE) p.table <- cbind(p.coeff, p.se, p.t, p.pv) dimnames(p.table) <- list(names(p.coeff), c("Estimate", "Std. Error", "t value", "Pr(>|t|)")) } } else {p.coeff <- p.t <- p.pv <- array(0,0)} ## Next the p-values for parametric terms, so that factors are treated whole... pterms <- if (is.list(object$pterms)) object$pterms else list(object$pterms) if (!is.list(object$assign)) object$assign <- list(object$assign) npt <- length(unlist(lapply(pterms,attr,"term.labels"))) if (npt>0) pTerms.df <- pTerms.chi.sq <- pTerms.pv <- array(0,npt) term.labels <- rep("",0) k <- 0 ## total term counter for (j in 1:length(pterms)) { tlj <- attr(pterms[[j]],"term.labels") nt <- length(tlj) if (j>1 && nt>0) tlj <- paste(tlj,j-1,sep=".") term.labels <- c(term.labels,tlj) if (nt>0) { # individual parametric terms np <- length(object$assign[[j]]) ind <- pstart[j] - 1 + 1:np Vb <- covmat[ind,ind,drop=FALSE] bp <- array(object$coefficients[ind],np) for (i in 1:nt) { k <- k + 1 ind <- object$assign[[j]]==i b <- bp[ind];V <- Vb[ind,ind] ## pseudo-inverse needed in case of truncation of parametric space if (length(b)==1) { V <- 1/V pTerms.df[k] <- nb <- 1 pTerms.chi.sq[k] <- V*b*b } else { V <- pinv(V,length(b),rank.tol=.Machine$double.eps^.5) pTerms.df[k] <- nb <- attr(V,"rank") pTerms.chi.sq[k] <- t(b)%*%V%*%b } if (!est.disp) pTerms.pv[k] <- pchisq(pTerms.chi.sq[k],df=nb,lower.tail=FALSE) else pTerms.pv[k] <- pf(pTerms.chi.sq[k]/nb,df1=nb,df2=residual.df,lower.tail=FALSE) } ## for (i in 1:nt) } ## if (nt>0) } if (npt) { attr(pTerms.pv,"names") <- term.labels if (!est.disp) { pTerms.table <- cbind(pTerms.df, pTerms.chi.sq, pTerms.pv) dimnames(pTerms.table) <- list(term.labels, c("df", "Chi.sq", "p-value")) } else { pTerms.table <- cbind(pTerms.df, pTerms.chi.sq/pTerms.df, pTerms.pv) dimnames(pTerms.table) <- list(term.labels, c("df", "F", "p-value")) } } else { pTerms.df<-pTerms.chi.sq<-pTerms.pv<-array(0,0)} ## ================================ ## Now deal with the smooth terms.... m <- length(object$smooth) # number of smooth terms df <- edf1 <-edf <- s.pv <- chi.sq <- array(0, m) if (m > 0) { # form test statistics for each smooth if (!freq) { ## Bayesian p-values required sub.samp <- max(1000,2*length(object$coefficients)) if (nrow(object$model)>sub.samp) { ## subsample to get X for p-values calc. seed <- try(get(".Random.seed",envir=.GlobalEnv),silent=TRUE) ## store RNG seed if (inherits(seed,"try-error")) { runif(1) seed <- get(".Random.seed",envir=.GlobalEnv) } kind <- RNGkind(NULL) RNGkind("default","default") set.seed(11) ## ensure repeatability ind <- sample(1:nrow(object$model),sub.samp,replace=FALSE) ## sample these rows from X X <- predict(object,object$model[ind,],type="lpmatrix") RNGkind(kind[1],kind[2]) assign(".Random.seed",seed,envir=.GlobalEnv) ## RNG behaves as if it had not been used } else { ## don't need to subsample X <- model.matrix(object) } X <- X[!is.na(rowSums(X)),] ## exclude NA's (possible under na.exclude) } ## end if (!freq) for (i in 1:m) { ## loop through smooths start <- object$smooth[[i]]$first.para stop <- object$smooth[[i]]$last.para if (freq) { ## use frequentist cov matrix V <- object$Ve.t[start:stop,start:stop,drop=FALSE] } else V <- object$Vp.t[start:stop,start:stop,drop=FALSE] ## Bayesian p <- object$coefficients.t[start:stop] # transposed parameters of a smooth edf1[i] <- edf[i] <- sum(object$edf[start:stop]) # edf for this smooth ## extract alternative edf estimate for this smooth, if possible... ## edf1 is not done for scam output value... if (!is.null(object$edf1)) edf1[i] <- sum(object$edf1[start:stop]) if (freq) { M1 <- object$smooth[[i]]$df M <- min(M1, ceiling(2 * sum(object$edf[start:stop]))) ## upper limit of 2*edf on rank V <- pinv(V, M) # get rank M pseudoinverse of V chi.sq[i] <- t(p) %*% V %*% p df[i] <- attr(V, "rank") } else { ## Better founded alternatives... Xt <- X[, start:stop,drop=FALSE] if (object$smooth[[i]]$null.space.dim==0&&!is.null(object$R)) { ## random effect or fully penalized term res <- reTest.scam(object,i) } else { ## Inverted Nychka interval statistics ## df[i] <- min(ncol(Xt),edf1[i]) if (est.disp) rdf <- residual.df else rdf <- -1 res <- testStat(p,Xt,V,min(ncol(Xt),edf1[i]),type=0,res.df = rdf) ## was type=p.type } df[i] <- res$rank chi.sq[i] <- res$stat s.pv[i] <- res$pval } names(chi.sq)[i]<- object$smooth[[i]]$label if (freq) { if (!est.disp) s.pv[i] <- pchisq(chi.sq[i], df = df[i], lower.tail = FALSE) else s.pv[i] <- pf(chi.sq[i]/df[i], df1 = df[i], df2 = residual.df, lower.tail = FALSE) # ## p-values are meaningless for very small edf. Need to set to NA # if (df[i] < 0.1) s.pv[i] <- NA } ## p-values are meaningless for very small edf. Need to set to NA if (df[i] < 0.1) { s.pv[i] <- NA chi.sq[i] <- NA } } ## rounding output values of edf, df and chi.sq... edf <- round(edf,digits=4) df <- round(df,digits=4) chi.sq <- round(chi.sq,digits=4) if (!est.disp) { if (freq) { s.table <- cbind(edf, df, chi.sq, s.pv) dimnames(s.table) <- list(names(chi.sq), c("edf", "Est.rank", "Chi.sq", "p-value")) } else { s.table <- cbind(edf, df, chi.sq, s.pv) dimnames(s.table) <- list(names(chi.sq), c("edf", "Ref.df", "Chi.sq", "p-value")) } } else { if (freq) { s.table <- cbind(edf, df, chi.sq/df, s.pv) dimnames(s.table) <- list(names(chi.sq), c("edf", "Est.rank", "F", "p-value")) } else { s.table <- cbind(edf, df, chi.sq/df, s.pv) dimnames(s.table) <- list(names(chi.sq), c("edf", "Ref.df", "F", "p-value")) } } } w <- as.numeric(object$prior.weights) mean.y <- sum(w*object$y)/sum(w) w <- sqrt(w) nobs <- nrow(object$model) r.sq<- 1 - var(w*(as.numeric(object$y)-object$fitted.values))*(nobs-1)/(var(w*(as.numeric(object$y)-mean.y))*residual.df) dev.expl<-(object$null.deviance-object$deviance)/object$null.deviance ret<-list(p.coeff=p.coeff,se=se,p.t=p.t,p.pv=p.pv,residual.df=residual.df,m=m,chi.sq=chi.sq, s.pv=s.pv,scale=dispersion,r.sq=round(r.sq,digits=4),family=object$family,formula=object$formula,n=nobs, dev.expl=dev.expl,edf=edf,dispersion=dispersion,pTerms.pv=pTerms.pv,pTerms.chi.sq=pTerms.chi.sq, pTerms.df = pTerms.df, cov.unscaled = covmat.unscaled, cov.scaled = covmat, p.table = p.table, pTerms.table = pTerms.table, s.table = s.table,method=object$method,sp.criterion=object$gcv.ubre, sp=object$sp,dgcv.ubre=object$dgcv.ubre,termcode=object$termcode, gcv.ubre=object$gcv.ubre,optimizer=object$optimizer,rank=object$rank,np=length(object$coefficients)) class(ret) <- "summary.scam" ret } ## end summary.scam ##### print.summary.scam ..... print.summary.scam <- function (x, digits = max(3, getOption("digits") - 3), signif.stars = getOption("show.signif.stars"),...) ## print method for scam, a clone of print.summary.gam of mgcv() { print(x$family) cat("Formula:\n") print(x$formula) if (length(x$p.coeff) > 0) { cat("\nParametric coefficients:\n") printCoefmat(x$p.table, digits = digits, signif.stars = signif.stars, na.print = "NA", ...) } cat("\n") if (x$m > 0) { cat("Approximate significance of smooth terms:\n") printCoefmat(x$s.table, digits = digits, signif.stars = signif.stars, has.Pvalue = TRUE, na.print = "NA", cs.ind = 1, ...) } # cat("\n") if (!is.null(x$rank) && x$rank< x$np) cat("Rank: ",x$rank,"/",x$np,"\n",sep="") cat("\nR-sq.(adj) = ", formatC(x$r.sq, digits = 4, width = 5)) if (length(x$dev.expl) > 0) cat(" Deviance explained = ", formatC(x$dev.expl * 100, digits = 3, width = 4), "%\n", sep = "") if (length(x$sp.criterion) > 0) cat( x$method," score = ", formatC(x$sp.criterion, digits = 5), sep = "") cat(" Scale est. = ", formatC(x$scale, digits = 5, width = 8, flag = "-"), " n = ", x$n, "\n", sep = "") if ((x$optimizer[1] == "bfgs") && x$m>0){ if (x$termcode!= 1) { dgcv.ubre <- max(abs(x$dgcv.ubre)*max(abs(log(x$sp)),1)/max(abs(x$gcv.ubre),1)) cat("\nBFGS termination condition:\n", dgcv.ubre,"\n",sep = "") } } cat("\n") invisible(x) } ##### mgcv::: smoothTest (c) Simon N. Wood smoothTest <- function(b,X,V,eps=.Machine$double.eps^.5) { ## Forms Cox, Koh, etc type test statistic, and ## obtains null distribution by simulation... ## if b are coefs f=Xb, cov(b) = V. z is a vector of ## i.i.d. N(0,1) deviates qrx <- qr(X) R <- qr.R(qrx) V <- R%*%V[qrx$pivot,qrx$pivot]%*%t(R) V <- (V + t(V))/2 ed <- eigen(V,symmetric=TRUE) k <- n <- length(ed$values) ## could truncate, but it doesn't improve power in correlated case! f <- t(ed$vectors[,1:k])%*%R%*%b t <- sum(f^2) k <- ncol(X) lambda <- as.numeric(ed$values[1:k]) pval <- liu2(t,lambda) ## should really use Davies list(stat=t,pval=pval) } ###### mgcv::: liu2 (c) Simon N. Wood liu2 <- function(x, lambda, h = rep(1,length(lambda)),lower.tail=FALSE) { # Evaluate Pr[sum_i \lambda_i \chi^2_h_i < x] approximately. # Code adapted from CompQuadForm package of Pierre Lafaye de Micheaux # and directly from.... # H. Liu, Y. Tang, H.H. Zhang, A new chi-square approximation to the # distribution of non-negative definite quadratic forms in non-central # normal variables, Computational Statistics and Data Analysis, Volume 53, # (2009), 853-856. Actually, this is just Pearson (1959) given that # the chi^2 variables are central. # Note that this can be rubbish in lower tail (e.g. lambda=c(1.2,.3), x = .15) # if (TRUE) { ## use Davies exact method in place of Liu et al/ Pearson approx. # require(CompQuadForm) # r <- x # for (i in 1:length(x)) r[i] <- davies(x[i],lambda,h)$Qq # return(pmin(r,1)) # } if (length(h) != length(lambda)) stop("lambda and h should have the same length!") lh <- lambda*h muQ <- sum(lh) lh <- lh*lambda c2 <- sum(lh) lh <- lh*lambda c3 <- sum(lh) s1 <- c3/c2^1.5 s2 <- sum(lh*lambda)/c2^2 sigQ <- sqrt(2*c2) t <- (x-muQ)/sigQ if (s1^2>s2) { a <- 1/(s1-sqrt(s1^2-s2)) delta <- s1*a^3-a^2 l <- a^2-2*delta } else { a <- 1/s1 delta <- 0 l <- c2^3/c3^2 } muX <- l+delta sigX <- sqrt(2)*a return(pchisq(t*sigX+muX,df=l,ncp=delta,lower.tail=lower.tail)) } #### mgcv::: simf (c) Simon N. Wood simf <- function(x,a,df,nq=50) { ## suppose T = sum(a_i \chi^2_1)/(chi^2_df/df). We need ## Pr[T>x] = Pr(sum(a_i \chi^2_1) > x *chi^2_df/df). Quadrature ## used here. So, e.g. ## 1-pf(4/3,3,40);simf(4,rep(1,3),40);1-pchisq(4,3) p <- (1:nq-.5)/nq q <- qchisq(p,df) x <- x*q/df pr <- sum(liu2(x,a)) ## Pearson/Liu approx to chi^2 mixture pr/nq } #### the same as mgcv::: recov.gam (c) Simon N. Wood recov.scam <- function(b,re=rep(0,0),m=0) { ## b is a fitted gam object. re is an array of indices of ## smooth terms to be treated as fully random.... ## Returns frequentist Cov matrix based on the given ## mapping from data to params, but with dist of data ## corresponding to that implied by treating terms indexed ## by re as random effects... (would be usual frequentist ## if nothing treated as random) ## if m>0, then this is indexes a term, not in re, whose ## unpenalized cov matrix is required, with the elements of re ## dropped. if (!inherits(b,"scam")) stop("recov works with fitted scam objects only") if (is.null(b$full.sp)) sp <- b$sp else sp <- b$full.sp if (length(re)<1) { if (m>0) { ## annoyingly, need total penalty np <- length(coef(b)) k <- 1;S1 <- matrix(0,np,np) for (i in 1:length(b$smooth)) { ns <- length(b$smooth[[i]]$S) ind <- b$smooth[[i]]$first.para:b$smooth[[i]]$last.para if (ns>0) for (j in 1:ns) { S1[ind,ind] <- S1[ind,ind] + sp[k]*b$smooth[[i]]$S[[j]] k <- k + 1 } } LRB <- rbind(b$R,t(mroot(S1))) ii <- b$smooth[[m]]$first.para:b$smooth[[m]]$last.para ## ii is cols of LRB related to smooth m, which need ## to be moved to the end... LRB <- cbind(LRB[,-ii],LRB[,ii]) ii <- (ncol(LRB)-length(ii)+1):ncol(LRB) Rm <- qr.R(qr(LRB,tol=0,LAPACK=FALSE))[ii,ii] ## unpivoted QR } else Rm <- NULL return(list(Ve.t=(t(b$Ve.t)+b$Ve.t)*.5,Rm=Rm)) } if (m%in%re) stop("m can't be in re") ## partition R into R1 ("fixed") and R2 ("random"), with S1 and S2 p <- length(b$coefficients) rind <- rep(FALSE,p) ## random coefficient index for (i in 1:length(re)) { rind[b$smooth[[re[i]]]$first.para:b$smooth[[re[i]]]$last.para] <- TRUE } p2 <- sum(rind) ## number random p1 <- p - p2 ## number fixed map <- rep(0,p) ## remaps param indices to indices in split version map[rind] <- 1:p2 ## random map[!rind] <- 1:p1 ## fixed ## split R... R1 <- b$R[,!rind] ## fixed effect columns R2 <- b$R[,rind] ## random effect columns ## seitdem ich dich kennen, hab ich ein probleme, ## assemble S1 and S2 S1 <- matrix(0,p1,p1);S2 <- matrix(0,p2,p2) k <- 1 for (i in 1:length(b$smooth)) { ns <- length(b$smooth[[i]]$S) ind <- map[b$smooth[[i]]$first.para:b$smooth[[i]]$last.para] is.random <- i%in%re if (ns>0) for (j in 1:ns) { if (is.random) S2[ind,ind] <- S2[ind,ind] + sp[k]*b$smooth[[i]]$S[[j]] else S1[ind,ind] <- S1[ind,ind] + sp[k]*b$smooth[[i]]$S[[j]] k <- k + 1 } } ## pseudoinvert S2 if (nrow(S2)==1) { S2[1,1] <- 1/sqrt(S2[1,1]) } else if (max(abs(diag(diag(S2))-S2))==0) { ds2 <- diag(S2) ind <- ds2 > max(ds2)*.Machine$double.eps^.8 ds2[ind] <- 1/ds2[ind];ds2[!ind] <- 0 diag(S2) <- sqrt(ds2) } else { ev <- eigen((S2+t(S2))/2,symmetric=TRUE) ind <- ev$values > max(ev$values)*.Machine$double.eps^.8 ev$values[ind] <- 1/ev$values[ind];ev$values[!ind] <- 0 ## S2 <- ev$vectors%*%(ev$values*t(ev$vectors)) S2 <- sqrt(ev$values)*t(ev$vectors) } ## choleski of cov matrix.... ## L <- chol(diag(p)+R2%*%S2%*%t(R2)) ## L'L = I + R2 S2^- R2' L <- chol(diag(p) + crossprod(S2%*%t(R2))) ## now we need the square root of the unpenalized ## cov matrix for m if (m>0) { ## llr version LRB <- rbind(L%*%R1,t(mroot(S1))) ii <- map[b$smooth[[m]]$first.para:b$smooth[[m]]$last.para] ## ii is cols of LRB related to smooth m, which need ## to be moved to the end... LRB <- cbind(LRB[,-ii],LRB[,ii]) ii <- (ncol(LRB)-length(ii)+1):ncol(LRB) ## need to pick up final block Rm <- qr.R(qr(LRB,tol=0,LAPACK=FALSE))[ii,ii,drop=FALSE] ## unpivoted QR } else Rm <- NULL list(Ve.t= crossprod(L%*%b$R%*%b$Vp.t)/b$sig2, ## Frequentist cov matrix Rm=Rm) # mapi <- (1:p)[!rind] ## indexes mapi[j] is index of total coef vector to which jth row/col of Vb/e relates } ## end of recov ### same as mgcv::: reTest.scam, (c) Simon N. Wood reTest.scam <- function(b,m) { ## Test the mth smooth for equality to zero ## and accounting for all random effects in model ## find indices of random effects other than m rind <- rep(0,0) for (i in 1:length(b$smooth)) if (!is.null(b$smooth[[i]]$random)&&b$smooth[[i]]$random&&i!=m) rind <- c(rind,i) ## get frequentist cov matrix of effects treating smooth terms in rind as random rc <- recov.scam(b,rind,m) Ve.t <- rc$Ve.t ind <- b$smooth[[m]]$first.para:b$smooth[[m]]$last.para B <- mroot(Ve.t[ind,ind,drop=FALSE]) ## BB'=Ve Rm <- rc$Rm b.hat <- coef(b)[ind] d <- Rm%*%b.hat stat <- sum(d^2)/b$sig2 ev <- eigen(crossprod(Rm%*%B)/b$sig2,symmetric=TRUE,only.values=TRUE)$values ev[ev<0] <- 0 rank <- sum(ev>max(ev)*.Machine$double.eps^.8) if (b$scale.estimated) { pval <- simf(stat,ev,b$df.residual) } else { pval <- liu2(stat,ev) } list(stat=stat,pval=pval,rank=rank) } ## end reTest ########## mgcv::: testStat ## (c) Simon N. Wood ## below is not the updated version of testStat(), not the one of the mgcv version 1.8-40 testStat <- function(p,X,V,rank=NULL,type=0,res.df= -1) { ## Routine for forming fractionally trunctated ## pseudoinverse of XVX'. And returning ## p'X'(XVX)^-Xp. ## Truncates to numerical rank, if this is ## less than supplied rank+1. ## The type argument specifies the type of truncation to use. ## on entry `rank' should be an edf estimate ## 0. Default using the fractionally truncated pinv. ## 1. Round down to k if k<= rank < k+0.05, otherwise up. ## 2. Naive rounding. ## 3. Round up. ## 4. Numerical rank estimation, tol=1e-3 ## res.df is residual dof used to estimate scale. <=0 implies ## fixed scale. qrx <- qr(X,tol=0) R <- qr.R(qrx) V <- R%*%V[qrx$pivot,qrx$pivot,drop=FALSE]%*%t(R) V <- (V + t(V))/2 ed <- eigen(V,symmetric=TRUE) k <- max(0,floor(rank)) nu <- abs(rank - k) ## fractional part of supplied edf if (type < -.5) { ## Crude modification of Cox and Koh res <- smoothTest(p,X,V) res$rank <- rank return(res) } else if (type==1) { ## round up is more than .05 above lower if (rank > k + .05||k==0) k <- k + 1 nu <- 0;rank <- k } else if (type==2) { ## naive round nu <- 0;rank <- k <- max(1,round(rank)) warning("p-values may give low power in some circumstances") } else if (type==3) { ## round up nu <- 0; rank <- k <- max(1,ceiling(rank)) warning("p-values un-reliable") } else if (type==4) { ## rank estimation rank <- k <- max(sum(ed$values>1e-3*max(ed$values)),1) nu <- 0 warning("p-values may give very low power") } if (nu>0) k1 <- k+1 else k1 <- k ## check that actual rank is not below supplied rank+1 r.est <- sum(ed$values > max(ed$values)*.Machine$double.eps^.9) if (r.est0&&k>0) { if (k>1) vec[,1:(k-1)] <- t(t(vec[,1:(k-1)])/sqrt(ed$val[1:(k-1)])) b12 <- .5*nu*(1-nu) if (b12<0) b12 <- 0 b12 <- sqrt(b12) B <- matrix(c(1,b12,b12,nu),2,2) ev <- diag(ed$values[k:k1]^-.5,nrow=k1-k+1) B <- ev%*%B%*%ev eb <- eigen(B,symmetric=TRUE) rB <- eb$vectors%*%diag(sqrt(eb$values))%*%t(eb$vectors) vec[,k:k1] <- t(rB%*%t(vec[,k:k1])) } else { if (k==0) vec <- t(t(vec)*sqrt(1/ed$val[1])) else vec <- t(t(vec)/sqrt(ed$val[1:k])) if (k==1) rank <- 1 } d <- t(vec)%*%(R%*%p) d <- sum(d^2) rank1 <- rank ## rank for lower tail pval computation below ## note that for <1 edf then d is not weighted by EDF, and instead is ## simply refered to a chi-squared 1 if (nu>0) { ## mixture of chi^2 ref dist if (k1==1) rank1 <- val <- 1 else { val <- rep(1,k1) ##ed$val[1:k1] rp <- nu+1 val[k] <- (rp + sqrt(rp*(2-rp)))/2 val[k1] <- (rp - val[k]) } if (res.df <= 0) pval <- liu2(d,val) else ## pval <- davies(d,val)$Qq else pval <- simf(d,val,res.df) } else { pval <- 2 } ## integer case still needs computing, also liu/pearson approx only good in ## upper tail. In lower tail, 2 moment approximation is better (Can check this ## by simply plotting the whole interesting range as a contour plot!) if (pval > .5) { if (res.df <= 0) pval <- pchisq(d,df=rank1,lower.tail=FALSE) else pval <- pf(d/rank1,rank1,res.df,lower.tail=FALSE) } list(stat=d,pval=min(1,pval),rank=rank) } ## end of testStat ################## mgcv::: pinvXVX ## (c) Simon N. Wood pinvXVX <- function (X, V, rank = NULL) { k <- floor(rank) nu <- rank - k if (nu > 0) k1 <- k + 1 else k1 <- k qrx <- qr(X) R <- qr.R(qrx) V <- R %*% V[qrx$pivot, qrx$pivot] %*% t(R) V <- (V + t(V))/2 ed <- eigen(V, symmetric = TRUE) vec <- qr.qy(qrx, rbind(ed$vectors, matrix(0, nrow(X) - ncol(X), ncol(X)))) if (k1 < ncol(vec)) vec <- vec[, 1:k1, drop = FALSE] if (k == 0) { vec <- t(t(vec) * sqrt(nu/ed$val[1])) return(vec) } if (nu > 0) { if (k > 1) vec[, 1:(k - 1)] <- t(t(vec[, 1:(k - 1)])/sqrt(ed$val[1:(k - 1)])) b12 <- 0.5 * nu * (1 - nu) if (b12 < 0) b12 <- 0 b12 <- sqrt(b12) B <- matrix(c(1, b12, b12, nu), 2, 2) ev <- diag(ed$values[k:k1]^-0.5) B <- ev %*% B %*% ev eb <- eigen(B, symmetric = TRUE) rB <- eb$vectors %*% diag(sqrt(eb$values)) %*% t(eb$vectors) vec[, k:k1] <- t(rB %*% t(vec[, k:k1])) } else { vec <- t(t(vec)/sqrt(ed$val[1:k])) } vec } ## mgcv::: eigXVX (c) Simon N. Wood eigXVX <- function (X, V, rank = NULL, tol = .Machine$double.eps^0.5) { qrx <- qr(X) R <- qr.R(qrx) V <- R %*% V[qrx$pivot, qrx$pivot] %*% t(R) V <- (V + t(V))/2 ed <- eigen(V, symmetric = TRUE) ind <- abs(ed$values) > max(abs(ed$values)) * tol erank <- sum(ind) if (is.null(rank)) { rank <- erank } else { if (rank < erank) ind <- 1:rank else rank <- erank } vec <- qr.qy(qrx, rbind(ed$vectors, matrix(0, nrow(X) - ncol(X), ncol(X)))) list(values = ed$values[ind], vectors = vec[, ind], rank = rank) } ############################################### ## anova for scam models (clone of summary.gam()) ## of mgcv versions up to 1.8-11 (c) Simon N. Wood ... ############################################### anova.scam <- function (object, ..., dispersion = NULL, test = NULL, freq=FALSE,p.type=0) # clone of summary.gam(): mgcv package { # adapted from anova.glm: R stats package dotargs <- list(...) named <- if (is.null(names(dotargs))) rep(FALSE, length(dotargs)) else (names(dotargs) != "") if (any(named)) warning("The following arguments to anova.glm(..) are invalid and dropped: ", paste(deparse(dotargs[named]), collapse = ", ")) dotargs <- dotargs[!named] is.glm <- unlist(lapply(dotargs, function(x) inherits(x, "glm"))) dotargs <- dotargs[is.glm] if (length(dotargs) > 0) return(anova(structure(c(list(object), dotargs), class="glmlist"), dispersion = dispersion, test = test)) # return(anova.glmlist(c(list(object), dotargs), dispersion = dispersion, # test = test)) ## modified at BDR's suggestion 19/08/13 if (!is.null(test)) warning("test argument ignored") if (!inherits(object,"scam")) stop("anova.scam called with non scam object") sg <- summary(object, dispersion = dispersion, freq = freq,p.type=p.type) class(sg) <- "anova.scam" sg } ## anova.scam print.anova.scam <- function(x, digits = max(3, getOption("digits") - 3), ...) { # print method for class anova.scam resulting from single # scam model calls to anova. Clone of print.anova.gam(): mgcv package print(x$family) cat("Formula:\n") if (is.list(x$formula)) for (i in 1:length(x$formula)) print(x$formula[[i]]) else print(x$formula) if (length(x$pTerms.pv)>0) { cat("\nParametric Terms:\n") printCoefmat(x$pTerms.table, digits = digits, signif.stars = FALSE, has.Pvalue = TRUE, na.print = "NA", ...) } cat("\n") if(x$m>0) { cat("Approximate significance of smooth terms:\n") printCoefmat(x$s.table, digits = digits, signif.stars = FALSE, has.Pvalue = TRUE, na.print = "NA", ...) } invisible(x) } ## print.anova.scam scam/R/emmeans-support.r0000644000176200001440000001315115132433122014715 0ustar liggesusers## incorporating the emmeans package (copyright (c) 2012-2025 Russell V. Lenth ) support in the scam from version 1.2-21 ## (c) Natalya Pya (2026). Provided under GPL 2 ################################################################################### ## from the 'Extending *emmeans* vignette... ## ## need to write two S3 methods, 'recover_data' and 'emm_basis', for the class ## ## of object that your model-fitting function returns. ## ## i) The recover_data method is needed to recreate the dataset so that ## ## the reference grid can be identified. ## ## ii) The emm_basis method then determines the linear functions needed ## ## to evaluate each point in the reference grid and to obtain associated ## ## information such as the variance-covariance matrix needed to do estimation ## ## and testing. ## ## iii) 'emm_basis'calls a utility function 'smooth.is.random- to sort out which ## ## smoothers are associated with random effects, needed because emmeans focuses ## ## on fixed effects ## ################################################################################### ### for scam::scam objects ### similar to recover_data gam... recover_data.scam = function(object, ...) ## recreates the dataset so that the reference grid can be identified. { if (length(object$smooth) > 0) { # get rid of random terms fixnm = unlist(lapply(object$smooth, function(s) { if(.smooth.is.random(s)) "" else c(s$term, s$by) })) fixnm = union(emmeans::.all.vars(delete.response(object$pterms)), fixnm) fixnm = setdiff(fixnm, c("1", "", "NA")) object$terms = terms(.reformulate(fixnm, env = environment(terms(object)))) } recover_data.lm(object, ...) } ### emm_basis method for scam::scam objects ### extra arg `freq` and `untransformed' as in `vcov.scam` emm_basis.scam = function(object, trms, xlev, grid, freq = FALSE, untransformed = FALSE, ...) ## Obtains six things and return them in a named list: ## 1) matrix 'X' of linear functions for each point in the reference grid, ## 2) regression coefficients 'bhat', ## 3) variance-covariance matrix 'V', ## 4) matrix 'nbasis' for non-estimable functions, ## 5) function 'dffun(k,dfargs)' for computing degrees of freedom for the linear function sum(k*bhat), ## 6) a list 'dfargs' of arguments to pass to 'dffun'. { if (length(object$smooth) > 0) { # get rid of random terms rand = sapply(object$smooth, function(s) {ifelse(.smooth.is.random(s), s$label, NA)}) rand = if (all(is.na(rand))) NULL else rand[!is.na(rand)] } else rand = NULL X = predict.scam(object, newdata = grid, type = "lpmatrix", exclude = rand, newdata.guaranteed = TRUE) keep = if (is.null(rand)) rep(TRUE, ncol(X)) else apply(X, 2, function(x) !all(x == 0)) X = X[, keep, drop = FALSE] bhat = as.numeric(object$coefficients.t[keep]) V = emmeans::.my.vcov(object, freq = freq, untransformed = untransformed, ...)[keep, keep] nbasis = estimability::all.estble dfargs = list(df = object$df.residual) dffun = function(k, dfargs) dfargs$df list(X=X, bhat=bhat, nbasis=nbasis, V=V, dffun=dffun, dfargs=dfargs) } # Local utility for identifying random smooths .smooth.is.random = function(s) { rcls = c("random.effect", "fs.interaction") ### what to look for cls = c(class(s), unname(unlist(lapply(s$margin, class)))) any(cls %in% rcls) } ############################################################################### # below are internal (unexported) functions of the emmeans package, needed # # for running recover_data.scam() # # Copyright (c) 2012-2019 Russell V. Lenth # ############################################################################### ### Contributed by Jonathon Love, https://github.com/jonathon-love ### ### and adapted by RVL to exclude terms like df$trt or df[["trt"]] ### ############################################################################### # reformulate internally in emmeans # same as stats::reformulate, except it surrounds term labels with backsticks .reformulate <- function (termlabels, response = NULL, intercept = TRUE, env = parent.frame()) { if (!is.character(termlabels) || !length(termlabels)) stop("'termlabels' must be a character vector of length at least one") has.resp = !is.null(response) termlabels = sapply(trimws(termlabels), function(x) if (length(grep("\\$|\\[\\[", x)) > 0) x else paste0("`", x, "`")) termtext = paste(if (has.resp) "response", "~", paste(termlabels, collapse = "+"), collapse = "") # prev version: paste0("`", trimws(termlabels), "`", collapse = "+"), collapse = "") if (!intercept) termtext = paste(termtext, "- 1") rval = eval(parse(text = termtext, keep.source = FALSE)[[1L]]) if (has.resp) rval[[2L]] = if (is.character(response)) as.symbol(response) else response environment(rval) = env rval } recover_data.lm = function(object, frame = object$model, ...) { fcall = object$call emmeans::recover_data(fcall, delete.response(terms(object)), object$na.action, frame = frame, pwts = weights(object), ...) } scam/R/derivative.scam.r0000644000176200001440000002133115026260052014643 0ustar liggesusers## (c) Natalya Pya (2012-2024). Provided under GPL 2 ################################################################# ## function to get derivatives of the smooth model terms .... ## ## (currently only univariate smooths) ## ## analytic derivatives for P-, SCOP-splines ## ## finite differencing using predict.gam() for others ## ################################################################# derivative.scam <- function(object, smooth.number=1,deriv=1){ ## object - fitted scam object ## smooth.number - number of the smooth model term which derivative is needed to be calculated ## deriv - either 1 if the 1st derivative is required, or 2 if the 2nd sn <- smooth.number if (length(object$smooth[[sn]]$term)!=1) stop("derivative.smooth() currently handles only 1D smooths") if (deriv!=1 & deriv!=2) stop(paste("deriv can be either 1 or 2")) n <- length(object$y) q <- object$smooth[[sn]]$bs.dim ## smooth basis dimension first <- object$smooth[[sn]]$first.para last <- object$smooth[[sn]]$last.para beta.t <- object$coefficients.t[first:last] Vp <- object$Vp.t[first:last,first:last] if (inherits(object$smooth[[sn]], c("mpi.smooth","mpd.smooth", "cv.smooth", "cx.smooth", "mdcv.smooth","mdcx.smooth","micv.smooth", "micx.smooth", "mpiBy.smooth", "mpdBy.smooth", "mdcvBy.smooth", "mdcxBy.smooth","micvBy.smooth", "micxBy.smooth","cvBy.smooth", "cxBy.smooth", "po.smooth"))) { Sig <- object$smooth[[sn]]$Sigma if (deriv==1){ ## 1st order derivatives P <- if (inherits(object$smooth[[sn]], c("miso.smooth", "mifo.smooth"))) diff(diag(q-3),difference=1) else diff(diag(q-1),difference=1) Xd <- object$smooth[[sn]]$Xdf1%*%P%*%Sig } else { ## 2nd order derivative P <- if (inherits(object$smooth[[sn]], c("miso.smooth", "mifo.smooth"))) diff(diag(q-3),difference=2) else diff(diag(q-1),difference=2) Xd <- object$smooth[[sn]]$Xdf2%*%P%*%Sig } # } else if (inherits(object$smooth[[sn]], "pspline.smooth")){ ## unconstrained P-splines # if (deriv==1) ## 1st order derivatives # Xd <- object$smooth[[sn]]$Xdf1%*%diff(diag(q-1),difference=1) # else ## 2nd order derivative # Xd <- object$smooth[[sn]]$Xdf2%*%diff(diag(q-1),difference=2) # } } else { ## for other unconstrained smooths via finite differencing using predict.gam() xx <- object$model[object$smooth[[sn]]$term] ## find the data if (object$smooth[[sn]]$by != "NA") { by <- rep(1, n) newd <- data.frame(x = xx, by = by) names(newd) <- c(object$smooth[[sn]]$term, object$smooth[[sn]]$by) } else { newd <- data.frame(x = xx) names(newd) <- object$smooth[[sn]]$term } X0 <- PredictMat(object$smooth[[sn]], newd) eps <- 1e-7 ## finite difference interval xx <- xx + eps if (object$smooth[[sn]]$by != "NA") { newd <- data.frame(x = xx, by = by) names(newd) <- c(object$smooth[[sn]]$term, object$smooth[[sn]]$by) } else { newd <- data.frame(x = xx) names(newd) <- object$smooth[[sn]]$term } X1 <- PredictMat(object$smooth[[sn]], newd) Xd <- (X1-X0)/eps ## maps coefficients to (fd approx.) derivatives if (deriv==2){ ## for 2nd oder derivative xx <- xx + eps if (object$smooth[[sn]]$by != "NA") { newd <- data.frame(x = xx, by = by) names(newd) <- c(object$smooth[[sn]]$term, object$smooth[[sn]]$by) } else { newd <- data.frame(x = xx) names(newd) <- object$smooth[[sn]]$term } X2 <- PredictMat(object$smooth[[sn]], newd) Xd <- (X2-2*X1+X0)/eps^2 } if (inherits(object$smooth[[sn]], c("miso.smooth", "mifo.smooth"))) { ind.con <- object$smooth[[sn]]$n.zero Xd <- Xd[,-ind.con] } } df <- Xd%*%beta.t ## values of the derivatives df.sd <- rowSums(Xd%*%Vp*Xd)^.5 ## standard errors of the derivative of smooth list(d=df,se.d=df.sd) } ## end of derivative.scam ################################ ## checking 'miso' and 'mpi' derivatives with finite differencing derivatives... derivative.scam.miso <- function(object, smooth.number=1,deriv=1){ ## object - fitted scam object ## smooth.number - number of the smooth model term which derivative is needed to be calculated ## deriv - either 1 if the 1st derivative is required, or 2 if the 2nd sn <- smooth.number if (length(object$smooth[[sn]]$term)!=1) stop("derivative.smooth() currently handles only 1D smooths") if (deriv!=1 & deriv!=2) stop(paste("deriv can be either 1 or 2")) n <- length(object$y) q <- object$smooth[[sn]]$bs.dim ## smooth basis dimension first <- object$smooth[[sn]]$first.para last <- object$smooth[[sn]]$last.para beta.t <- object$coefficients.t[first:last] Vp <- object$Vp.t[first:last,first:last] if (inherits(object$smooth[[sn]], c("mpd.smooth", "cv.smooth", "cx.smooth", "mdcv.smooth","mdcx.smooth","micv.smooth", "micx.smooth", "mpiBy.smooth", "mpdBy.smooth", "mdcvBy.smooth", "mdcxBy.smooth","micvBy.smooth", "micxBy.smooth","cvBy.smooth", "cxBy.smooth", "po.smooth"))) { Sig <- object$smooth[[sn]]$Sigma if (deriv==1){ ## 1st order derivatives P <- diff(diag(q-1),difference=1) Xd <- object$smooth[[sn]]$Xdf1%*%P%*%Sig } else { ## 2nd order derivative P <- diff(diag(q-1),difference=2) Xd <- object$smooth[[sn]]$Xdf2%*%P%*%Sig } # } else if (inherits(object$smooth[[sn]], "pspline.smooth")){ ## unconstrained P-splines # if (deriv==1) ## 1st order derivatives # Xd <- object$smooth[[sn]]$Xdf1%*%diff(diag(q-1),difference=1) # else ## 2nd order derivative # Xd <- object$smooth[[sn]]$Xdf2%*%diff(diag(q-1),difference=2) # } } else { ## for other unconstrained smooths via finite differencing using predict.gam() xx <- object$model[object$smooth[[sn]]$term] ## find the data if (object$smooth[[sn]]$by != "NA") { by <- rep(1, n) newd <- data.frame(x = xx, by = by) names(newd) <- c(object$smooth[[sn]]$term, object$smooth[[sn]]$by) } else { newd <- data.frame(x = xx) names(newd) <- object$smooth[[sn]]$term } X0 <- PredictMat(object$smooth[[sn]], newd) eps <- 1e-7 ## finite difference interval xx <- xx + eps if (object$smooth[[sn]]$by != "NA") { newd <- data.frame(x = xx, by = by) names(newd) <- c(object$smooth[[sn]]$term, object$smooth[[sn]]$by) } else { newd <- data.frame(x = xx) names(newd) <- object$smooth[[sn]]$term } X1 <- PredictMat(object$smooth[[sn]], newd) Xd <- (X1-X0)/eps ## maps coefficients to (fd approx.) derivatives if (deriv==2){ ## for 2nd oder derivative xx <- xx + eps if (object$smooth[[sn]]$by != "NA") { newd <- data.frame(x = xx, by = by) names(newd) <- c(object$smooth[[sn]]$term, object$smooth[[sn]]$by) } else { newd <- data.frame(x = xx) names(newd) <- object$smooth[[sn]]$term } X2 <- PredictMat(object$smooth[[sn]], newd) Xd <- (X2-2*X1+X0)/eps^2 } } if (inherits(object$smooth[[sn]], c("miso.smooth", "mifo.smooth"))) { ind.con <- object$smooth[[sn]]$n.zero Xd <- Xd[,-ind.con] } else if (inherits(object$smooth[[sn]], c("mpi.smooth"))) Xd <- Xd[,-1] df <- Xd%*%beta.t ## values of the derivatives df.sd <- rowSums(Xd%*%Vp*Xd)^.5 ## standard errors of the derivative of smooth list(d=df,se.d=df.sd) } ## end of derivative.scam.miso scam/R/uni.smooth.const.r0000644000176200001440000027513415140351623015025 0ustar liggesusers## (c) Natalya Pya (2012-2026). Provided under GPL 2. ## routines for univariate SCOP-spline construction ## with sum-to-zero identifiability constraints (2023) ##################################################### ### Adding Monotone increasing SCOP-spline construction ###################################################### smooth.construct.mpi.smooth.spec<- function(object, data, knots) ## construction of the monotone increasing smooth { #require(splines) m <- object$p.order[1] if (is.na(m)) m <- 2 ## default for cubic spline if (m < 0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ", nk," supplied knots")) if (!is.null(object$point.con[[1]])) ## a point constraint is supplied? stop(paste("'mpi' smooth does not work with a point constraint; use 'miso' for a start-at-zero constraint, or 'mifo' for a finish-at-zero constraint")) ####################################################################### ## indentifiability constraint by first dropping the first columns of XSigma (setting beta_1=0) ## and then applying sum-to-zero (centering) constraint... # get model matrix------------- X1 <- splineDesign(xk,x,ord=m+2) # get matrix Sigma and remove the first column for the model matrix XSig ## Sig <- matrix(as.numeric(rep(1:q,q)>=rep(1:q,each=q)),q,q) ## coef summation matrix Sig <- matrix(1,q,q) ## coef summation matrix Sig[upper.tri(Sig)] <-0 X <- X1%*%Sig X <- X[,-1] ## applying sum-to-zero (centering) constraint... cmx <- colMeans(X) X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix object$cmX <- cmx object$P <- list() object$S <- list() object$Sigma <- Sig[-1,-1] if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-1),difference=1) object$P[[1]] <- P object$S[[1]] <- crossprod(P) } object$p.ident <- rep(TRUE,q-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 2 ## ##m+1 # dim. of unpenalized space, 2 as the basis of a straight line is two-dimensional object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,2:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative class(object)<-"mpi.smooth" # Give object a class object } ## Prediction matrix for the `mpi` smooth class... Predict.matrix.mpi.smooth<-function(object,data) ## prediction method function for the `mpi' smooth class ## change in version 1.2-21: no need to add the first column of the matrix ## (dropped in the smooth construction) { m <- object$m # spline order, m+1=3 default for cubic spline q <- object$df +1 # Sig <- matrix(as.numeric(rep(1:q,q)>=rep(1:q,each=q)),q,q) ## coef summation matrix Sig <- matrix(1,q,q) ## coef summation matrix Sig[upper.tri(Sig)] <-0 ## find spline basis inner knot range... ll <- object$knots[m+2];ul <- object$knots[length(object$knots)-m-1] x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m+2)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m+2,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m+2)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig ## X <- sweep(X,2,c(0,object$cmX)) } ## X <- X[,-1] X <- as.matrix(X[,-1,drop=FALSE]) X <- sweep(X,2,object$cmX) X } Predict.matrix.mpi0.smooth<-function(object,data) ## prediction method function for the `mpi' smooth class { m <- object$m # spline order, m+1=3 default for cubic spline q <- object$df +1 # Sig <- matrix(as.numeric(rep(1:q,q)>=rep(1:q,each=q)),q,q) ## coef summation matrix Sig <- matrix(1,q,q) ## coef summation matrix Sig[upper.tri(Sig)] <-0 ## find spline basis inner knot range... ll <- object$knots[m+2];ul <- object$knots[length(object$knots)-m-1] x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m+2)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m+2,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m+2)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig ## X <- sweep(X,2,c(0,object$cmX)) } X <- sweep(X,2,c(0,object$cmX)) X } #################################################################################################### ### Adding monotone increasing SCOP-spline construction without applying identifiability constraints ### to be used with numeric 'by' variable... #################################################################################################### ## when 'by' variable takes more than one value, the smooth terms are identifiable without a ## 'zero intercept' constraint, so they are left unconstrained. smooth.construct.mpiBy.smooth.spec<- function(object, data, knots) ## construction of the monotone increasing smooth { m <- object$p.order[1] if (is.na(m)) m <- 2 ## default for cubic spline if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ", nk," supplied knots")) if (!is.null(object$point.con[[1]])) ## a point constraint is supplied? stop(paste("'mpi' smooth does not work with a point constraint; use 'miso' for a start-at-zero constraint, or 'mifo' for a finish-at-zero constraint")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m+2) # get matrix Sigma... Sig <- matrix(1,q,q) ## coef summation matrix Sig[upper.tri(Sig)] <-0 X <- X1%*%Sig object$X <- X # the final model matrix object$P <- list() object$S <- list() object$Sigma <- Sig if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-1),difference=1) P <- rbind(rep(0,q-1),P) ## adding 1st row of zeros P <- cbind(rep(0,q-1),P) ## adding first column of zeros object$P[[1]] <- P object$S[[1]] <- crossprod(P) } object$p.ident <- c(FALSE,rep(TRUE,q-1)) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X) # penalty rank object$null.space.dim <- 2 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,1:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative class(object)<-"mpiBy.smooth" # Give object a class object } ## Prediction matrix for the `mpiBy` smooth class... Predict.matrix.mpiBy.smooth<-function(object,data) ## prediction method function for the `mpiBy' smooth class { m <- object$m # spline order, m+1=3 default for cubic spline q <- object$df Sig <- matrix(1,q,q) ## coef summation matrix Sig[upper.tri(Sig)] <-0 ## find spline basis inner knot range... ll <- object$knots[m+2];ul <- object$knots[length(object$knots)-m-1] x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m+2)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m+2,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m+2)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig } X } ############################################################################################## ### Adding Monotone increasing SCOP-spline construction with a 'start at zero' constraint, ### a SCOP-spline additionally constrained to be zero at a start, at the left-end point of the covariate range... ############################################################################################# smooth.construct.miso.smooth.spec<- function(object, data, knots) ## construction of the monotone increasing smooth with a 'start-at-zero' constraint; ## achieved simply by setting the first (m+1) spline coefficients to zero... { m <- object$p.order[1] if (is.na(m)) m <- 2 ## default for cubic spline if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) { # space knots evenly through data n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } ## move m knots, xk[m+3],...,xk[m+3+m-1] (2nd,...,(m+1) inner knots), to the first inner knot xk[m+2], ## join these m knots with the constrained xk[m+2] knot to avoid a plateau start... xk[(m+3):(m+2+m)] <- xk[m+2] if (length(xk)!=nk) # right number of knots? stop(paste("there should be ", nk," supplied knots")) if (!is.null(object$point.con[[1]])) ## a point constraint is supplied? stop(paste("'miso' smooth works only with a 'start at zero' constraint; 'pc' argument does not work here")) ## get model matrix... X1 <- splineDesign(xk,x,ord=m+2) ## get unconstrained matrix Sigma and remove the first m+1 columns and rows... Sig <- matrix(1,q,q) ## coef summation matrix Sig[upper.tri(Sig)] <-0 ind <- 1:(m+1) ## 1:3 if m=2; ## Sig[,ind] <- 0; Sig[ind,] <- 0 Sig <- Sig[-ind,-ind] X <- X1[,-ind]%*%Sig # drop (m+1) start terms, model submatrix for the scop-term object$X <- X # the final model matrix object$P <- list() object$S <- list() object$Sigma <- Sig if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-length(ind)),difference=1) object$P[[1]] <- P object$S[[1]] <- crossprod(P) } object$p.ident <- rep(TRUE,q-length(ind)) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$n.zero <- ind object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 2 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF ## get model matrix for 1st and 2nd derivatives of the smooth... h <- xk[q]-xk[q-1] ##(max(x)-min(x))/(q-m-1) ## distance between two adjacent knots (both expressions give the same distance) ## Xdf1, Xdf2 need to be checked... object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,(m+2):(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative class(object)<-"miso.smooth" # Give object a class object } ## Prediction matrix for the `miso` smooth class... Predict.matrix.miso.smooth<-function(object,data) ## prediction method function for the `miso' smooth class { m <- object$m # spline order, m+1=3 default for cubic spline q <- object$bs.dim ## object$df +1 ## ????? # Sig <- matrix(as.numeric(rep(1:q,q)>=rep(1:q,each=q)),q,q) ## coef summation matrix Sig <- matrix(1,q,q) ## coef summation matrix Sig[upper.tri(Sig)] <-0 ind <- object$n.zero ## 1:(m+1) Sig[,ind] <- 0; Sig[ind,] <- 0 ## find spline basis inner knot range... ll <- object$knots[m+2];ul <- object$knots[length(object$knots)-m-1] x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m+2)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m+2,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m+2)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig } X } ############################################################################################## ### Adding Monotone increasing SCOP-spline construction with an 'finish at zero' constraint, ### a SCOP-spline additionally constrained to be zero at the end, at the right-end point of ### the covariate range... ############################################################################################# smooth.construct.mifo.smooth.spec<- function(object, data, knots) ## construction of the monotone increasing smooth with a 'finish-at-zero' constraint; ## achieved simply by setting the last (m+1) spline coefficients to zero... { if (!is.null(object$point.con[[1]])) ## a point constraint is supplied? stop(paste("'mifo' smooth works only with a 'finish at zero' constraint; 'pc' argument does not work here")) m <- object$p.order[1] if (is.na(m)) m <- 2 ## default for cubic spline if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) { # space knots evenly through data n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } ## move m knots, xk[q-m+1],...,xk[q] (the m pre-last inner knots), to the last inner knot xk[q+1], ## join these m knots with the constrained xk[q+1] knot to avoid a plateau end... xk[(q-m+1):q] <- xk[q+1] if (length(xk)!=nk) # right number of knots? stop(paste("there should be ", nk," supplied knots")) ## get model matrix... X1 <- splineDesign(xk,x,ord=m+2) ## get unconstrained matrix Sigma and remove the last m+1 columns and rows... Sig <- matrix(1,q,q) ## coef summation matrix Sig[upper.tri(Sig)] <-0 ind <- (q-m):q ## Sig[,ind] <- 0; Sig[ind,] <- 0 Sig <- Sig[-ind,-ind] X <- X1[,-ind]%*%Sig # drop (m+1) end terms, model submatrix for the scop-term object$X <- X # the final model matrix object$P <- list() object$S <- list() object$Sigma <- Sig if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-length(ind)),difference=1) object$P[[1]] <- P object$S[[1]] <- crossprod(P) } object$p.ident <- c(FALSE,rep(TRUE,q-length(ind)-1)) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$n.zero <- ind object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 2 ##m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots ## Xdf1, Xdf2 need to be checked... object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,1:(q-1-(m+1))]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative class(object)<-"mifo.smooth" # Give object a class object } ## Prediction matrix for the `mifo` smooth class... Predict.matrix.mifo.smooth<-function(object,data) ## prediction method function for the `mifo' smooth class { m <- object$m # spline order, m+1=3 default for cubic spline q <- object$bs.dim ## object$df +1 ## ????? Sig <- matrix(1,q,q) ## coef summation matrix Sig[upper.tri(Sig)] <-0 ind <- object$n.zero Sig[,ind] <- 0; Sig[ind,] <- 0 ## find spline basis inner knot range... ll <- object$knots[m+2];ul <- object$knots[length(object$knots)-m-1] x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m+2)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m+2,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m+2)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig } X } ######################################################## ### Adding Monotone decreasing SCOP-spline construction ######################################################## smooth.construct.mpd.smooth.spec<- function(object, data, knots) ## construction of the monotone decreasing smooth { # require(splines) m <- object$p.order[1] if (is.na(m)) m <- 2 ## default for cubic splines if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n <- length(x) xk <- rep(0,q+m+2) xk[(m+2):(q+1)] <- seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i] <- xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i] <- xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ",nk," supplied knots")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m+2) # get matrix Sigma and remove the first column for the monotone smooth (column and row for Sig) # Sig <- matrix(as.numeric(rep(1:q,q)>=rep(1:q,each=q)),q,q) ## coef summation matrix Sig <- matrix(-1,q,q) ## coef summation matrix Sig[upper.tri(Sig)] <-0 Sig[,1] <- -Sig[,1] ## monotone decreasing case X <- X1[,-1]%*%Sig[-1,-1] # drop intercept term ## applying sum-to-zero (centering) constraint... cmx <- colMeans(X) X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix object$cmX <- cmx object$Sigma <- Sig[-1,-1] object$P <- list() object$S <- list() if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-1),difference=1) object$P[[1]] <- P object$S[[1]] <- crossprod(P) } object$p.ident <- rep(TRUE,q-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <-2 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,2:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"mpd.smooth" # Give object a class object } ## Prediction matrix for the `mpd` smooth class... Predict.matrix.mpd.smooth<-function(object,data) ## prediction method function for the `mpd' smooth class ## change in version 1.2-21: dropping the first column of the matrix ## (no need to bring it back) { m <- object$m+1; # spline order, m+1=3 default for cubic spline q <- object$df +1 # elements of matrix Sigma for decreasing smooth... # Sig <- matrix(as.numeric(rep(1:q,q)>=rep(1:q,each=q)),q,q) ## coef summation matrix Sig <- matrix(-1,q,q) ## coef summation matrix Sig[upper.tri(Sig)] <-0 Sig[,1] <- -Sig[,1] ## monotone decreasing case ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig ## X <- sweep(X,2,c(0,object$cmX)) } ##X <- sweep(X,2,c(0,object$cmX)) X <- as.matrix(X[,-1,drop=FALSE]) X <- sweep(X,2,object$cmX) X } ####################################################### ### Adding Monotone decreasing SCOP-spline construction without applying identifiability constraints ### to be used with numeric 'by' variable... ######################################################## smooth.construct.mpdBy.smooth.spec<- function(object, data, knots) ## construction of the monotone decreasing smooth { # require(splines) m <- object$p.order[1] if (is.na(m)) m <- 2 ## default for cubic splines if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n <- length(x) xk <- rep(0,q+m+2) xk[(m+2):(q+1)] <- seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i] <- xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i] <- xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ",nk," supplied knots")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m+2) # get matrix Sigma and remove the first column for the monotone smooth (column and row for Sig) # Sig <- matrix(as.numeric(rep(1:q,q)>=rep(1:q,each=q)),q,q) ## coef summation matrix Sig <- matrix(-1,q,q) ## coef summation matrix Sig[upper.tri(Sig)] <-0 Sig[,1] <- -Sig[,1] ## monotone decrease case X <- X1%*%Sig # no drop intercept term object$X<-X # the final model matrix object$Sigma <- Sig object$P <- list() object$S <- list() if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-1),difference=1) P <- rbind(rep(0,q-1),P) ## adding 1st row of zeros P <- cbind(rep(0,q-1),P) ## adding first column of zeros object$P[[1]] <- P object$S[[1]] <- crossprod(P) } object$p.ident <- c(FALSE,rep(TRUE,q-1)) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X) # penalty rank object$null.space.dim <- 2 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,1:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"mpdBy.smooth" # Give object a class object } ## Prediction matrix for the `mpdBy` smooth class Predict.matrix.mpdBy.smooth<-function(object,data) ## prediction method function for the `mpdBy' smooth class { m <- object$m+1; # spline order, m+1=3 default for cubic spline q <- object$df # elements of matrix Sigma for decreasing smooth... # Sig <- matrix(as.numeric(rep(1:q,q)>=rep(1:q,each=q)),q,q) ## coef summation matrix Sig <- matrix(-1,q,q) ## coef summation matrix Sig[upper.tri(Sig)] <-0 Sig[,1] <- -Sig[,1] ## monotone decrease case ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig } X } ############################################################## ### Smooth constructor for the mixed constrainted smooths ...... ############################################################## ############################################################### ### Adding Monotone decreasing & concave P-spline construction ############################################################### smooth.construct.mdcv.smooth.spec<- function(object, data, knots) ## construction of the monotone decreasing and concave smooth { # require(splines) m <- object$p.order[1] if (is.na(m)) m <- 2 ## default for cubis spline if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ",nk," supplied knots")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m+2) # use matrix Sigma and remove the first column for the monotone smooth Sig <- matrix(0,(q-1),(q-1)) # Define Matrix Sigma # for monotone decreasing & concave smooth for (i in 1:(q-1)) Sig[i:(q-1),i]<--c(1:(q-i)) X <- X1[,2:q]%*%Sig # model submatrix for the constrained term ## applying sum-to-zero (centering) constraint... cmx <- colMeans(X) X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix object$cmX <- cmx object$Sigma <- Sig object$P <- list() object$S <- list() if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-2),difference=1) object$P[[1]] <- P S <- matrix(0,q-1,q-1) S[2:(q-1),2:(q-1)] <- crossprod(P) object$S[[1]] <- S } object$p.ident <- rep(TRUE,q-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 2 ##m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,2:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"mdcv.smooth" # Give object a class object } ## Prediction matrix for the `mdcv` smooth class.... Predict.matrix.mdcv.smooth<-function(object,data) ## prediction method function for the `mdcv' smooth class { m <- object$m+1; # spline order, m+1=3 default for cubic spline q <- object$df +1 Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) for (i in 2:q) Sig[i:q,i] <- -c(1:(q-i+1)) ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig ## X <- sweep(X,2,c(0,object$cmX)) } ## X <- sweep(X,2,c(0,object$cmX)) X <- as.matrix(X[,-1,drop=FALSE]) X <- sweep(X,2,object$cmX) X } ########################################################### ### Adding decreasing & concave SCOP-spline construction without identifiability constraints ### to be used with numeric 'by' variable and linear functional terms... ########################################################## smooth.construct.mdcvBy.smooth.spec<- function(object, data, knots) ## construction of the monotone decreasing and concave smooth { m <- object$p.order[1] if (is.na(m)) m <- 2 ## default for cubis spline if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ",nk," supplied knots")) # get model matrix------------- X <- splineDesign(xk,x,ord=m+2) # Define matrix Sigma for monotone decreasing & concave smooth Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) for (i in 2:q) Sig[i:q,i] <- -c(1:(q-i+1)) X <- X%*%Sig # model matrix for the constrained term object$X <- X object$Sigma <- Sig object$P <- list() object$S <- list() if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-2),difference=1) P <- rbind(matrix(0,2,q-2),P) ## adding first two rows of zeros P <- cbind(matrix(0,q-1,2),P) ## adding first two columns of zeros object$P[[1]] <- P object$S[[1]] <- crossprod(P) } object$p.ident <- c(FALSE,rep(TRUE,q-1)) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X) # penalty rank object$null.space.dim <- 2 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,1:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"mdcvBy.smooth" # Give object a class object } ## Prediction matrix for the `mdcvBy` smooth class.... Predict.matrix.mdcvBy.smooth<-function(object,data) ## prediction method function for the `mdcvBy' smooth class { m <- object$m+1; # spline order, m+1=3 default for cubic spline q <- object$df Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) for (i in 2:q) Sig[i:q,i] <- -c(1:(q-i+1)) ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig } X } ############################################################### ### Adding decreasing & convex SCOP-spline construction ################################################################ smooth.construct.mdcx.smooth.spec<- function(object, data, knots) ## the constructor for the monotone decreasing and convex smooth { #require(splines) m <- object$p.order[1] if (is.na(m)) m <- 2 ## default if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ",nk," supplied knots")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m+2) # use matrix Sigma and remove the first column for the monotone smooth Sig <- matrix(0,(q-1),(q-1)) # Define Matrix Sigma # for monotone decreasing & convex smooth Sig[1,] <- -rep(1,q-1) for (i in 2:(q-1)) { Sig[i,1:(q-i)] <- -i; Sig[i,(q-i+1):(q-1)] <- -c((i-1):1) } X <- X1[,2:q]%*%Sig # model submatrix for the constrained term ## applying sum-to-zero (centering) constraint... cmx <- colMeans(X) X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix object$cmX <- cmx object$Sigma <- Sig object$P <- list() object$S <- list() if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-2),difference=1) object$P[[1]] <- P S <- matrix(0,q-1,q-1) S[2:(q-1),2:(q-1)] <- crossprod(P) object$S[[1]] <- S } object$p.ident <- rep(TRUE,q-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 2 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,2:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"mdcx.smooth" # Give object a class object } ## Prediction matrix for the `mdcx` smooth class.... Predict.matrix.mdcx.smooth<-function(object,data) ## the prediction method for the `mdcx' smooth class { x <- data[[object$term]] m <- object$m+1; # spline order, m+1=3 default for cubic spline q <- object$df +1 Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) Sig1 <- matrix(0,(q-1),(q-1)) Sig1[1,] <- -rep(1,q-1) for (i in 2:(q-1)) { Sig1[i,1:(q-i)]<--i; Sig1[i,(q-i+1):(q-1)]<--c((i-1):1) } Sig [2:q,2:q] <- Sig1 ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig ## X <- sweep(X,2,c(0,object$cmX)) } ## X <- sweep(X,2,c(0,object$cmX)) X <- as.matrix(X[,-1,drop=FALSE]) X <- sweep(X,2,object$cmX) X } ########################################################### ### Adding decreasing & convex SCOP-spline construction without identifiability constraints ### to be used with numeric 'by' variable and linear functional terms... ########################################################## smooth.construct.mdcxBy.smooth.spec<- function(object, data, knots) ## the constructor for the monotone decreasing and convex smooth { m <- object$p.order[1] if (is.na(m)) m <- 2 ## default if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ",nk," supplied knots")) # get model matrix------------- X <- splineDesign(xk,x,ord=m+2) # define matrix Sigma for monotone decreasing & convex smooth Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) Sig1 <- matrix(0,(q-1),(q-1)) Sig1[1,] <- -rep(1,q-1) for (i in 2:(q-1)) { Sig1[i,1:(q-i)]<--i; Sig1[i,(q-i+1):(q-1)]<--c((i-1):1) } Sig [2:q,2:q] <- Sig1 X <- X%*%Sig # model matrix for the constrained term object$X<-X object$Sigma <- Sig object$P <- list() object$S <- list() if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-2),difference=1) P <- rbind(matrix(0,2,q-2),P) ## adding first two rows of zeros P <- cbind(matrix(0,q-1,2),P) ## adding first two columns of zeros object$P[[1]] <- P object$S[[1]] <- crossprod(P) } object$p.ident <- c(FALSE,rep(TRUE,q-1)) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X) # penalty rank object$null.space.dim <-2 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,1:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"mdcxBy.smooth" # Give object a class object } ## Prediction matrix for the `mdcxBy` smooth class.... Predict.matrix.mdcxBy.smooth<-function(object,data) ## the prediction method for the `mdcxBy' smooth class { x <- data[[object$term]] m <- object$m+1; # spline order, m+1=3 default for cubic spline q <- object$df Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) Sig1 <- matrix(0,(q-1),(q-1)) Sig1[1,] <- -rep(1,q-1) for (i in 2:(q-1)) { Sig1[i,1:(q-i)]<--i; Sig1[i,(q-i+1):(q-1)]<--c((i-1):1) } Sig [2:q,2:q] <- Sig1 ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig } X } ################################################################ ### Adding monotone increasing & concave SCOP-spline construction ################################################################ smooth.construct.micv.smooth.spec<- function(object, data, knots) ## construction of the monotone increasing and concave smooth { # require(splines) m <- object$p.order[1] if (is.na(m)) m <- 2 ## default if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ",nk," supplied knots")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m+2) # use matrix Sigma and remove the first column for the monotone smooth Sig <- matrix(0,(q-1),(q-1)) # Define Matrix Sigma # for monotone increasing & concave smooth Sig[1,]<-rep(1,q-1) for (i in 2:(q-1)) { Sig[i,1:(q-i)]<-i; Sig[i,(q-i+1):(q-1)]<-c((i-1):1) } X <- X1[,2:q]%*%Sig # model submatrix for the constrained term ## applying sum-to-zero (centering) constraint... cmx <- colMeans(X) X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix object$cmX <- cmx object$Sigma <- Sig object$P <- list() object$S <- list() if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-2),difference=1) object$P[[1]] <- P S <- matrix(0,q-1,q-1) S[2:(q-1),2:(q-1)] <- crossprod(P) object$S[[1]] <- S } object$p.ident <- rep(TRUE,q-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 2 ##m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,2:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"micv.smooth" # Give object a class object } ## Prediction matrix for the `micv` smooth class.... Predict.matrix.micv.smooth<-function(object,data) ## prediction method function for the `micv' smooth class { m <- object$m+1; # spline order, m+1=3 default for cubic spline q <- object$df +1 Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) Sig1 <- matrix(0,(q-1),(q-1)) Sig1[1,] <- rep(1,q-1) for (i in 2:(q-1)) { Sig1[i,1:(q-i)] <- i; Sig1[i,(q-i+1):(q-1)] <- c((i-1):1) } Sig [2:q,2:q] <- Sig1 ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig ## X <- sweep(X,2,c(0,object$cmX)) } ## X <- sweep(X,2,c(0,object$cmX)) X <- as.matrix(X[,-1,drop=FALSE]) X <- sweep(X,2,object$cmX) X } ########################################################### ### Adding increasing & concave SCOP-spline construction without identifiability constraints ### to be used with numeric 'by' variable and linear functional terms... ########################################################## smooth.construct.micvBy.smooth.spec<- function(object, data, knots) ## construction of the monotone increasing and concave smooth { m <- object$p.order[1] if (is.na(m)) m <- 2 ## default if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ",nk," supplied knots")) ## get model matrix------------- X <- splineDesign(xk,x,ord=m+2) ## define matrix Sigma for monotone increasing & concave smooth Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) Sig1 <- matrix(0,(q-1),(q-1)) Sig1[1,] <- rep(1,q-1) for (i in 2:(q-1)) { Sig1[i,1:(q-i)] <- i; Sig1[i,(q-i+1):(q-1)] <- c((i-1):1) } Sig [2:q,2:q] <- Sig1 X <- X%*%Sig ## model matrix for the constrained term object$X <- X object$Sigma <- Sig object$P <- list() object$S <- list() if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-2),difference=1) P <- rbind(matrix(0,2,q-2),P) ## adding first two rows of zeros P <- cbind(matrix(0,q-1,2),P) ## adding first two columns of zeros object$P[[1]] <- P object$S[[1]] <- crossprod(P) } object$p.ident <- c(FALSE,rep(TRUE,q-1)) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X) # penalty rank object$null.space.dim <- 2 ##m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,1:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"micvBy.smooth" # Give object a class object } ## Prediction matrix for the `micvBy` smooth class.... Predict.matrix.micvBy.smooth<-function(object,data) ## prediction method function for the `micvBy' smooth class { m <- object$m+1; # spline order, m+1=3 default for cubic spline q <- object$df Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) Sig1 <- matrix(0,(q-1),(q-1)) Sig1[1,] <- rep(1,q-1) for (i in 2:(q-1)) { Sig1[i,1:(q-i)] <- i; Sig1[i,(q-i+1):(q-1)] <- c((i-1):1) } Sig [2:q,2:q] <- Sig1 ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig } X } ############################################################### ### Adding monotone increasing & convex SCOP-spline construction ################################################################ smooth.construct.micx.smooth.spec<- function(object, data, knots) ## construction of the monotone increasing and convex smooth { # require(splines) m <- object$p.order[1] if (is.na(m)) m <- 2 ## default if (m < 0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ",nk," supplied knots")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m+2) # use matrix Sigma and remove the first column for the monotone smooth Sig <- matrix(0,(q-1),(q-1)) # Define Matrix Sigma # for monotone increasing & convex smooth for (i in 1:(q-1)) Sig[i:(q-1),i]<-c(1:(q-i)) X <- X1[,2:q]%*%Sig # model submatrix for the constrained term ## applying sum-to-zero (centering) constraint... cmx <- colMeans(X) X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix object$cmX <- cmx object$Sigma <- Sig object$P <- list() object$S <- list() if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-2),difference=1) object$P[[1]] <- P S <- matrix(0,q-1,q-1) S[2:(q-1),2:(q-1)] <- crossprod(P) object$S[[1]] <- S } object$p.ident <- rep(TRUE,q-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 2 ##m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,2:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"micx.smooth" # Give object a class object } ## Prediction matrix for the `micx` smooth class... Predict.matrix.micx.smooth<-function(object,data) ## prediction method function for the `micx` smooth class { m <- object$m+1; # spline order, m+1=3 default for cubic spline q <- object$df +1 Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) for (i in 2:q) Sig[i:q,i] <- c(1:(q-i+1)) ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig ## X <- sweep(X,2,c(0,object$cmX)) } ## X <- sweep(X,2,c(0,object$cmX)) X <- as.matrix(X[,-1,drop=FALSE]) X <- sweep(X,2,object$cmX) X } ########################################################### ### Adding increasing & convex SCOP-spline construction without identifiability constraints ### to be used with numeric 'by' variable and linear functional terms... ########################################################## smooth.construct.micxBy.smooth.spec<- function(object, data, knots) ## construction of the monotone increasing and convex smooth { m <- object$p.order[1] if (is.na(m)) m <- 2 ## default if (m < 0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ",nk," supplied knots")) ## get model matrix... X <- splineDesign(xk,x,ord=m+2) ## Define matrix Sigma for monotone increasing & convex smooth Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) for (i in 2:q) Sig[i:q,i] <- c(1:(q-i+1)) X <- X%*%Sig # model matrix for the constrained term object$X <- X object$Sigma <- Sig object$P <- list() object$S <- list() if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-2),difference=1) P <- rbind(matrix(0,2,q-2),P) ## adding first two rows of zeros P <- cbind(matrix(0,q-1,2),P) ## adding first two columns of zeros object$P[[1]] <- P object$S[[1]] <- crossprod(P) } object$p.ident <- c(FALSE,rep(TRUE,q-1)) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X) # penalty rank object$null.space.dim <-2 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,1:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<- "micxBy.smooth" # Give object a class object } ## Prediction matrix for the `micxBy` smooth class... Predict.matrix.micxBy.smooth<-function(object,data) ## prediction method function for the `micxBy` smooth class { m <- object$m+1; # spline order, m+1=3 default for cubic spline q <- object$df Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) for (i in 2:q) Sig[i:q,i] <- c(1:(q-i+1)) ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig } X } ############################################################ ### Smooth construct for the convex/concave smooths ...... ########################################################### ########################################################### ### Adding concave SCOP-spline construction ########################################################### smooth.construct.cv.smooth.spec<- function(object, data, knots) ## construction of the concave smooth { # require(splines) m <- object$p.order[1] if (is.na(m)) m <- 2 ## default if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ",nk," supplied knots")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m+2) # use matrix Sigma and remove the first column for the monotone smooth Sig <- matrix(0,(q-1),(q-1)) # Define Sigma for concave smooth Sig[1:(q-1),1]<- c(1:(q-1)) for (i in 2:(q-1)) Sig[i:(q-1),i]<--c(1:(q-i)) X <- X1[,2:q]%*%Sig # model submatrix for the constrained term ## applying sum-to-zero (centering) constraint... cmx <- colMeans(X) X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix object$cmX <- cmx object$Sigma <- Sig object$P <- list() object$S <- list() if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-2),difference=1) object$P[[1]] <- P S <- matrix(0,q-1,q-1) S[2:(q-1),2:(q-1)] <- crossprod(P) object$S[[1]] <- S } object$p.ident <- rep(TRUE,q-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 2 ##m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,2:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"cv.smooth" # Give object a class object } ## Prediction matrix for the `cv` smooth class... Predict.matrix.cv.smooth<-function(object,data) ## prediction method function for the `cv' smooth class { m <- object$m+1; # spline order, m+1=3 default for cubic spline q <- object$df +1 Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) Sig[2:q,2]<- c(1:(q-1)) for (i in 3:q) Sig[i:q,i] <- -c(1:(q-i+1)) ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig ## X <- sweep(X,2,c(0,object$cmX)) } ## X <- sweep(X,2,c(0,object$cmX)) X <- as.matrix(X[,-1,drop=FALSE]) X <- sweep(X,2,object$cmX) X } #################################################################################################### ### Adding concave SCOP-spline construction without applying identifiability constraints ### to be used with numeric 'by' variable... #################################################################################################### ## when 'by' variable takes more than one value, the smooth terms are identifiable without a ## 'zero intercept' constraint, so they are left unconstrained... smooth.construct.cvBy.smooth.spec<- function(object, data, knots) ## construction of the concave smooth { # require(splines) m <- object$p.order[1] if (is.na(m)) m <- 2 ## default if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ",nk," supplied knots")) # get model matrix------------- X <- splineDesign(xk,x,ord=m+2) # get matrix Sigma for concave smooth... Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) Sig[2:q,2]<- c(1:(q-1)) for (i in 3:q) Sig[i:q,i] <- -c(1:(q-i+1)) X <- X%*%Sig # model matrix for the constrained term object$X<-X object$Sigma <- Sig object$P <- list() object$S <- list() if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-2),difference=1) P <- rbind(matrix(0,2,q-2),P) ## adding first two rows of zeros P <- cbind(matrix(0,q-1,2),P) ## adding first two columns of zeros object$P[[1]] <- P object$S[[1]] <- crossprod(P) } object$p.ident <- c(FALSE,rep(TRUE,q-1)) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X) # penalty rank object$null.space.dim <- 2 ##m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,1:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"cvBy.smooth" # Give object a class object } ## Prediction matrix for the `cvBy` smooth class... Predict.matrix.cvBy.smooth<-function(object,data) ## prediction method function for the `cvBy' smooth class { m <- object$m+1; # spline order, m+1=3 default for cubic spline q <- object$df Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) Sig[2:q,2]<- c(1:(q-1)) for (i in 3:q) Sig[i:q,i] <- -c(1:(q-i+1)) ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig } X } ########################################################### ### Adding convex SCOP-spline construction ########################################################## smooth.construct.cx.smooth.spec<- function(object, data, knots) ## construction of the convex smooth { # require(splines) m <- object$p.order[1] if (is.na(m)) m <- 2 ## default if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ",nk," supplied knots")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m+2) # use matrix Sigma and remove the first column for the monotone smooth Sig <- matrix(0,(q-1),(q-1)) # Define Sigma for convex smooth Sig[1:(q-1),1]<- -c(1:(q-1)) for (i in 2:(q-1)) Sig[i:(q-1),i]<- c(1:(q-i)) X <- X1[,2:q]%*%Sig # model submatrix for the constrained term ## applying sum-to-zero (centering) constraint... cmx <- colMeans(X) X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix object$cmX <- cmx object$Sigma <- Sig object$P <- list() object$S <- list() if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-2),difference=1) object$P[[1]] <- P S <- matrix(0,q-1,q-1) S[2:(q-1),2:(q-1)] <- crossprod(P) object$S[[1]] <- S } object$p.ident <- rep(TRUE,q-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 2 ##m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,2:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"cx.smooth" # Give object a class object } ## Prediction matrix for the `cx` smooth class... Predict.matrix.cx.smooth<-function(object,data) ## prediction method function for the `cx' smooth class { m <- object$m+1; # spline order, m+1=3 default for cubic spline q <- object$df +1 Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) Sig[2:q,2]<- -c(1:(q-1)) for (i in 3:q) Sig[i:q,i] <- c(1:(q-i+1)) ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig ## X <- sweep(X,2,c(0,object$cmX)) } ## X <- sweep(X,2,c(0,object$cmX)) X <- as.matrix(X[,-1,drop=FALSE]) X <- sweep(X,2,object$cmX) X } ########################################################### ### Adding convex SCOP-spline construction without identifiability constraints ### to be used with numeric 'by' variable and linear functional terms... ########################################################## smooth.construct.cxBy.smooth.spec<- function(object, data, knots) ## construction of the convex smooth { m <- object$p.order[1] if (is.na(m)) m <- 2 ## default if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ",nk," supplied knots")) # get model matrix------------- X <- splineDesign(xk,x,ord=m+2) # get matrix Sigma for convex smooth... Sig <- matrix(0,q,q) Sig[,1] <- 1 Sig[2:q,2]<- -c(1:(q-1)) for (i in 3:q) Sig[i:q,i] <- c(1:(q-i+1)) X <- X%*%Sig # model submatrix for the constrained term object$X<-X # the final model matrix object$Sigma <- Sig object$P <- list() object$S <- list() if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-2),difference=1) P <- rbind(matrix(0,2,q-2),P) ## adding first two rows of zeros P <- cbind(matrix(0,q-1,2),P) ## adding first two columns of zeros object$P[[1]] <- P object$S[[1]] <- crossprod(P) } object$p.ident <- c(FALSE,rep(TRUE,q-1)) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X) # penalty rank object$null.space.dim <- 2 ##m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,1:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m==0) matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines else splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd derivative object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"cxBy.smooth" # Give object a class object } ## Prediction matrix for the `cxBy` smooth class... Predict.matrix.cxBy.smooth<-function(object,data) ## prediction method function for the `cxBy' smooth class { m <- object$m+1; # spline order, m+1=3 default for cubic spline q <- object$df Sig <- matrix(0,q,q) Sig[,1] <- rep(1,q) Sig[2:q,2]<- -c(1:(q-1)) for (i in 3:q) Sig[i:q,i] <- c(1:(q-i+1)) ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig } X } ##################################################### ### Adding positive SCOP-spline construction ###################################################### smooth.construct.po.smooth.spec<- function(object, data, knots) ## construction of the positively costrained smooth { m <- object$p.order[1] if (is.na(m)) m <- 2 ## default for cubic spline if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ", nk," supplied knots")) # get model matrix------------- X <- splineDesign(xk,x,ord=m+2) Sig <- diag(1,(q-1)) ## identity matrix ## Sig <- diag(1,q) ## identity matrix X <- X[,-1] ## X[,1:(q-1)] object$X <- X # the final model matrix object$P <- list() object$S <- list() object$Sigma <- Sig if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-1),difference=1) ## P <- diff(diag(q),difference=1) object$P[[1]] <- P object$S[[1]] <- crossprod(P) } object$p.ident <- rep(TRUE,q-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) ## object$p.ident <- rep(TRUE,q) object$rank <- ncol(object$X)-1 # penalty rank ## object$rank <- ncol(object$X) # penalty rank object$null.space.dim <-2 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,2:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m>0) splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd deriv else matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines class(object)<-"po.smooth" # Give object a class object } ## NOte: maybe no need to set the first coefficient to zero, as no intercept is required in the model with 'po' smooth ## Prediction matrix for the `po` smooth class... Predict.matrix.po.smooth<-function(object,data) ## prediction method function for the `po' smooth class { m <- object$m+1; # spline order, m+1=3 default for cubic spline ## q <- object$df +1 ## Sig <- diag(1,q) # Define Matrix Sigma ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] } X } ################################################################## ### Adding SCOP-spline with decreasing and positivity constraints ################################################################## smooth.construct.dpo.smooth.spec<- function(object, data, knots) ## construction of the positively costrained smooth { m <- object$p.order[1] if (is.na(m)) m <- 2 ## default for cubic spline if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ", nk," supplied knots")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m+2) # get matrix Sigma and remove the last column for the decreasing and positive smooth Sig <- matrix(1,q,q) ## coef summation matrix Sig[lower.tri(Sig)] <-0 X <- X1%*%Sig X <- X[,-q] object$X <- X # the final model matrix object$Sigma <- Sig[-q,-q] object$P <- list() object$S <- list() if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-1),difference=1) object$P[[1]] <- P object$S[[1]] <- crossprod(P) } object$p.ident <- rep(TRUE,q-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) ## object$p.ident <- rep(TRUE,q) object$rank <- ncol(object$X)-1 # penalty rank ## object$rank <- ncol(object$X) # penalty rank object$null.space.dim <-2 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,2:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m>0) splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd deriv else matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines class(object)<-"dpo.smooth" # Give object a class object } ## Prediction matrix for the `dpo` smooth class... Predict.matrix.dpo.smooth<-function(object,data) ## prediction method function for the `dpo' smooth class { m <- object$m+1; # spline order, m+1=3 default for cubic spline q <- object$df +1 # elements of matrix Sigma for decreasing smooth... # Sig <- matrix(as.numeric(rep(1:q,q)>=rep(1:q,each=q)),q,q) ## coef summation matrix Sig <- matrix(1,q,q) ## coef summation matrix Sig[lower.tri(Sig)] <-0 ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig } X } ################################################################## ### Adding SCOP-spline with inreasing and positivity constraints ################################################################## smooth.construct.ipo.smooth.spec<- function(object, data, knots) ## construction of the increasing and positively costrained smooth { m <- object$p.order[1] if (is.na(m)) m <- 2 ## default for cubic spline if (m<0) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim nk <- q+m+2 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data xk <- knots[[object$term]] ## will be NULL if none supplied if (is.null(xk)) # space knots through data { n<-length(x) xk<-rep(0,q+m+2) xk[(m+2):(q+1)]<-seq(min(x),max(x),length=q-m) for (i in 1:(m+1)) {xk[i]<-xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2])} for (i in (q+2):(q+m+2)) {xk[i]<-xk[q+1]+(i-q-1)*(xk[m+3]-xk[m+2])} } if (length(xk)!=nk) # right number of knots? stop(paste("there should be ", nk," supplied knots")) # get model matrix------------- X1 <- splineDesign(xk,x,ord=m+2) # get matrix Sigma and remove the first column for the increasing and positive smooth Sig <- matrix(1,q,q) ## coef summation matrix Sig[upper.tri(Sig)] <-0 X <- X1%*%Sig X <- X[,-1] object$X <- X # the final model matrix object$Sigma <- Sig[-1,-1] object$P <- list() object$S <- list() if (!object$fixed) # create the penalty matrix { P <- diff(diag(q-1),difference=1) object$P[[1]] <- P object$S[[1]] <- crossprod(P) } object$p.ident <- rep(TRUE,q-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) ## object$p.ident <- rep(TRUE,q) object$rank <- ncol(object$X)-1 # penalty rank ## object$rank <- ncol(object$X) # penalty rank object$null.space.dim <-2 ## m+1 # dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF (if unconstrained) ## get model matrix for 1st and 2nd derivatives of the smooth... h <- (max(x)-min(x))/(q-m-1) ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,2:(q-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- if (m>0) splineDesign(xk,x,ord=m)[,2:(q-2)]/h^2 ## ord is by two less for the 2nd deriv else matrix(0,nrow(X),ncol(object$Xdf1)-1) ## for piecewise linear splines class(object)<-"ipo.smooth" # Give object a class object } ## Prediction matrix for the `ipo` smooth class... Predict.matrix.ipo.smooth<-function(object,data) ## prediction method function for the `ipo' smooth class { m <- object$m+1; # spline order, m+1=3 default for cubic spline q <- object$df +1 # elements of matrix Sigma for increasing smooth... # Sig <- matrix(as.numeric(rep(1:q,q)>=rep(1:q,each=q)),q,q) ## coef summation matrix Sig <- matrix(1,q,q) ## coef summation matrix Sig[upper.tri(Sig)] <-0 ## find spline basis inner knot range... ll <- object$knots[m+1];ul <- object$knots[length(object$knots)-m] m <- m + 1 x <- data[[object$term]] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) { ## all in range X <- spline.des(object$knots,x,m)$design X <- X%*%Sig } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] X <- X%*%Sig } X } ################################################################## ### Adding cyclic P-spline with positivity constraint ## based on R routines for the package mgcv (c) Simon Wood 2000-2019 ################################################################## cSplineDes <- function (x, knots, ord = 4,derivs=0) { ## cyclic version of spline design... the package mgcv (c) Simon Wood 2000-2019 ##require(splines) nk <- length(knots) if (ord<2) stop("order too low") if (nkknots[nk]) stop("x out of range") xc <- knots[nk-ord+1] ## wrapping involved above this point ## copy end intervals to start, for wrapping purposes... knots <- c(k1-(knots[nk]-knots[(nk-ord+1):(nk-1)]),knots) ind <- x>xc ## index for x values where wrapping is needed X1 <- splineDesign(knots,x,ord,outer.ok=TRUE,derivs=derivs) x[ind] <- x[ind] - max(knots) + k1 if (sum(ind)) { ## wrapping part... X2 <- splineDesign(knots,x[ind],ord,outer.ok=TRUE,derivs=derivs) X1[ind,] <- X1[ind,] + X2 } X1 ## final model matrix } ## cSplineDes smooth.construct.cpop.smooth.spec<- function(object, data, knots) ## construction of the cyclic and positively costrained smooth ##`s(x,bs="cpop",m=c(2,1))' would be a cubic B-spline basis with a 1st order difference ## penalty with positivity constraint. m==c(0,0) would be linear splines with a ridge penalty). { if (length(object$p.order)==1) m <- rep(object$p.order,2) else m <- object$p.order ## m[1] - basis order, m[2] - penalty order m[is.na(m)] <- 2 ## default object$p.order <- m if (object$bs.dim<0) object$bs.dim <- max(10,m[1]) ## default nk <- object$bs.dim +1 ## number of interior knots if (nk<=m[1]) stop("basis dimension too small for b-spline order") if (length(object$term)!=1) stop("Basis only handles 1D smooths") x <- data[[object$term]] # find the data k <- knots[[object$term]] if (is.null(k)) { x0 <- min(x);x1 <- max(x) } else if (length(k)==2) { x0 <- min(k);x1 <- max(k); if (x0>min(x)||x10) warning("knot range is so wide that there is *no* information about some basis coefficients") } p.ord <- m[2] np <- ncol(X) if (p.ord>np-1) stop("penalty order too high for basis dimension") Sig <- diag(1,(np-1)) ## identity matrix object$X <- X[,-1] object$Sigma <- Sig object$p.ident <- rep(TRUE,np-1) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$C <- matrix(0, 0, ncol(object$X)) # to have no other constraints ## now construct penalty... np <- np-1 De <- diag(np + p.ord) if (p.ord>0) { for (i in 1:p.ord) De <- diff(De) D <- De[,-(1:p.ord)] D[,(np-p.ord+1):np] <- D[,(np-p.ord+1):np] + De[,1:p.ord] } else D <- De object$S <- list(t(D)%*%D) # get penalty ## other stuff... object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 1 # dimension of unpenalized space object$knots <- k; object$m <- m # store p-spline specific info. object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"cpopspline.smooth" # Give object a class object } Predict.matrix.cpopspline.smooth<-function(object,data) ## prediction method function for the cpopspline smooth class { x <- data[[object$term]] k0 <- min(object$knots);k1 <- max(object$knots) if (min(x)k1) x <- cwrap(k0,k1,x) X <- cSplineDes(x,object$knots,object$m[1]+2) X } scam/R/vis.scam.r0000644000176200001440000002222515133415355013314 0ustar liggesusers## (c) Simon N. Wood 23/2/03, vis.gam() of the mgcv package vis.scam <- function(x,view=NULL,cond=list(),n.grid=30,too.far=0,col=NA,color="heat", contour.col=NULL,se=-1,type="link",plot.type="persp",zlim=NULL,nCol=50,...) ## hacked version of vis.gam() from mgcv package, (c) Simon N. Wood 23/2/03 ## predict.gam is simply replaced by predict.scam # takes a scam object and plots 2D views of it, supply ticktype="detailed" to get proper axis anotation { fac.seq<-function(fac,n.grid) # generates a sequence of factor variables of length n.grid { fn<-length(levels(fac));gn<-n.grid; if (fn>gn) mf<-factor(levels(fac))[1:gn] else { ln<-floor(gn/fn) # length of runs mf<-rep(levels(fac)[fn],gn) mf[1:(ln*fn)]<-rep(levels(fac),rep(ln,fn)) mf<-factor(mf,levels=levels(fac)) } mf } # end of local functions dnm <- names(list(...)) ## basic issues in the following are that not all objects will have a useful `data' ## component, but they all have a `model' frame. Furthermore, `predict.gam' recognises ## when a model frame has been supplied v.names <- names(x$var.summary) ## names of all variables ## Note that in what follows matrices in the parametric part of the model ## require special handling. Matrices arguments to smooths are different ## as they follow the summation convention. if (is.null(view)) # get default view if none supplied { ## need to find first terms that can be plotted against k <- 0;view <- rep("",2) for (i in 1:length(v.names)) { ok <- TRUE if (is.matrix(x$var.summary[[i]])) ok <- FALSE else if (is.factor(x$var.summary[[i]])) { if (length(levels(x$var.summary[[i]]))<=1) ok <- FALSE } else { if (length(unique(x$var.summary[[i]]))==1) ok <- FALSE } if (ok) { k <- k + 1;view[k] <- v.names[i] } if (k==2) break; } if (k<2) stop("Model does not seem to have enough terms to do anything useful") } else { if (sum(view%in%v.names)!=2) stop( paste(c("view variables must be one of",v.names),collapse=", ")) for (i in 1:2) if (!inherits(x$var.summary[[view[i]]],c("numeric","factor"))) stop("Don't know what to do with parametric terms that are not simple numeric or factor variables") } ok <- TRUE for (i in 1:2) if (is.factor(x$var.summary[[view[i]]])) { if (length(levels(x$var.summary[[view[i]]]))<=1) ok <- FALSE } else { if (length(unique(x$var.summary[[view[i]]]))<=1) ok <- FALSE } if (!ok) stop(paste("View variables must contain more than one value. view = c(",view[1],",",view[2],").",sep="")) # Make dataframe.... if (is.factor(x$var.summary[[view[1]]])) m1<-fac.seq(x$var.summary[[view[1]]],n.grid) else { r1<-range(x$var.summary[[view[1]]]);m1<-seq(r1[1],r1[2],length=n.grid)} if (is.factor(x$var.summary[[view[2]]])) m2<-fac.seq(x$var.summary[[view[2]]],n.grid) else { r2<-range(x$var.summary[[view[2]]]);m2<-seq(r2[1],r2[2],length=n.grid)} v1<-rep(m1,n.grid);v2<-rep(m2,rep(n.grid,n.grid)) newd <- data.frame(matrix(0,n.grid*n.grid,0)) ## creating prediction data frame full of conditioning values for (i in 1:length(x$var.summary)) { ma <- cond[[v.names[i]]] if (is.null(ma)) { ma <- x$var.summary[[i]] if (is.numeric(ma)) ma <- ma[2] ## extract median } if (is.matrix(x$var.summary[[i]])) newd[[i]] <- matrix(ma,n.grid*n.grid,ncol(x$var.summary[[i]]),byrow=TRUE) else newd[[i]]<-rep(ma,n.grid*n.grid) } names(newd) <- v.names #row.names <- attr(newd,"row.names") #attributes(newd) <- attributes(x$model) # done so that handling of offsets etc. works #attr(newd,"row.names") <- row.names newd[[view[1]]]<-v1 newd[[view[2]]]<-v2 # call predict.scam to get predictions..... if (type=="link") zlab<-paste("linear predictor") else if (type=="response") zlab<-type else stop("type must be \"link\" or \"response\"") ## turn newd into a model frame, so that names and averages are valid #attributes(newd)<-attributes(x$model) #attr(newd,"row.names")<-as.character(1:(n.grid*n.grid)) fv <- predict.scam(x,newdata=newd,se.fit=TRUE,type=type) z <- fv$fit # store NA free copy now if (too.far>0) # exclude predictions too far from data { ex.tf <- exclude.too.far(v1,v2,x$model[,view[1]],x$model[,view[2]],dist=too.far) fv$se.fit[ex.tf] <- fv$fit[ex.tf]<-NA } # produce a continuous scale in place of any factors if (is.factor(m1)) { m1<-as.numeric(m1);m1<-seq(min(m1)-0.5,max(m1)+0.5,length=n.grid) } if (is.factor(m2)) { m2<-as.numeric(m2);m2<-seq(min(m1)-0.5,max(m2)+0.5,length=n.grid) } if (se<=0) { old.warn<-options(warn=-1) av<-matrix(c(0.5,0.5,rep(0,n.grid-1)),n.grid,n.grid-1) options(old.warn) # z is without any exclusion of gridpoints, so that averaging works nicely max.z <- max(z,na.rm=TRUE) z[is.na(z)] <- max.z*10000 # make sure NA's don't mess it up z<-matrix(z,n.grid,n.grid) # convert to matrix surf.col<-t(av)%*%z%*%av # average over tiles surf.col[surf.col>max.z*2] <- NA # restore NA's # use only non-NA data to set colour limits if (!is.null(zlim)) { if (length(zlim)!=2||zlim[1]>=zlim[2]) stop("Something wrong with zlim") min.z<-zlim[1] max.z<-zlim[2] } else { min.z<-min(fv$fit,na.rm=TRUE) max.z<-max(fv$fit,na.rm=TRUE) } surf.col<-surf.col-min.z surf.col<-surf.col/(max.z-min.z) surf.col<-round(surf.col*nCol) con.col <-1 if (color=="heat") { pal<-heat.colors(nCol);con.col<-3;} else if (color=="topo") { pal<-topo.colors(nCol);con.col<-2;} else if (color=="cm") { pal<-cm.colors(nCol);con.col<-1;} else if (color=="terrain") { pal<-terrain.colors(nCol);con.col<-2;} else if (color=="gray"||color=="bw") {pal <- gray(seq(0.1,0.9,length=nCol));con.col<-1} else stop("color scheme not recognised") if (is.null(contour.col)) contour.col<-con.col # default colour scheme surf.col[surf.col<1]<-1;surf.col[surf.col>nCol]<-nCol # otherwise NA tiles can get e.g. -ve index if (is.na(col)) col<-pal[as.array(surf.col)] z<-matrix(fv$fit,n.grid,n.grid) if (plot.type=="contour") { stub <- paste(ifelse("xlab" %in% dnm, "" , ",xlab=view[1]"), ifelse("ylab" %in% dnm, "" , ",ylab=view[2]"), ifelse("main" %in% dnm, "" , ",main=zlab"),",...)",sep="") if (color!="bw") { txt <- paste("image(m1,m2,z,col=pal,zlim=c(min.z,max.z)",stub,sep="") # assemble image() call eval(parse(text=txt)) txt <- paste("contour(m1,m2,z,col=contour.col,zlim=c(min.z,max.z)", ifelse("add" %in% dnm, "" , ",add=TRUE"),",...)" , sep="") # assemble contour() call eval(parse(text=txt)) } else { txt <- paste("contour(m1,m2,z,col=1,zlim=c(min.z,max.z)",stub,sep="") # assemble contour() call eval(parse(text=txt)) } } else { stub <- paste(ifelse("xlab" %in% dnm, "" , ",xlab=view[1]"), ifelse("ylab" %in% dnm, "" , ",ylab=view[2]"), ifelse("main" %in% dnm, "" , ",zlab=zlab"),",...)",sep="") if (color=="bw") { op <- par(bg="white") txt <- paste("persp(m1,m2,z,col=\"white\",zlim=c(min.z,max.z) ",stub,sep="") # assemble persp() call eval(parse(text=txt)) par(op) } else { txt <- paste("persp(m1,m2,z,col=col,zlim=c(min.z,max.z)",stub,sep="") # assemble persp() call eval(parse(text=txt)) } } } else # add standard error surfaces { if (color=="bw"||color=="gray") { subs <- paste("grey are +/-",se,"s.e.") lo.col <- "gray" ## ignore codetools claims about this hi.col <- "gray" ## ignore codetools } else { subs<-paste("red/green are +/-",se,"s.e.") lo.col <- "green" hi.col <- "red" } if (!is.null(zlim)) { if (length(zlim)!=2||zlim[1]>=zlim[2]) stop("Something wrong with zlim") min.z<-zlim[1] max.z<-zlim[2] } else { z.max<-max(fv$fit+fv$se.fit*se,na.rm=TRUE) z.min<-min(fv$fit-fv$se.fit*se,na.rm=TRUE) } zlim<-c(z.min,z.max) z<-fv$fit-fv$se.fit*se;z<-matrix(z,n.grid,n.grid) if (plot.type=="contour") warning("sorry no option for contouring with errors: try plot.scam") stub <- paste(ifelse("xlab" %in% dnm, "" , ",xlab=view[1]"), ifelse("ylab" %in% dnm, "" , ",ylab=view[2]"), ifelse("zlab" %in% dnm, "" , ",zlab=zlab"), ifelse("sub" %in% dnm, "" , ",sub=subs"), ",...)",sep="") txt <- paste("persp(m1,m2,z,col=col,zlim=zlim", ifelse("border" %in% dnm, "" ,",border=lo.col"), stub,sep="") # assemble persp() call eval(parse(text=txt)) par(new=TRUE) # don't clean device z<-fv$fit;z<-matrix(z,n.grid,n.grid) txt <- paste("persp(m1,m2,z,col=col,zlim=zlim", ifelse("border" %in% dnm, "" ,",border=\"black\""), stub,sep="") eval(parse(text=txt)) par(new=TRUE) # don't clean device z<-fv$fit+se*fv$se.fit;z<-matrix(z,n.grid,n.grid) txt <- paste("persp(m1,m2,z,col=col,zlim=zlim", ifelse("border" %in% dnm, "" ,",border=hi.col"), stub,sep="") eval(parse(text=txt)) } } scam/R/scam.r0000644000176200001440000032704415132161063012514 0ustar liggesusers## (c) Natalya Pya (2012-2026). Provided under GPL 2. ## routines for fitting scam()... ## based on setup routines (c) Simon N Wood ############################################################# ## the wrapper overall function to fit scam... ## ############################################################# scam <- function(formula, family=gaussian(), data=list(), gamma=1, sp=NULL, weights=NULL, offset=NULL, optimizer=c("bfgs","newton"), optim.method=c("Nelder-Mead","fd"), scale=0, knots=NULL, not.exp=FALSE, start=NULL, etastart=NULL, mustart=NULL, control=list(), AR1.rho=0, AR.start=NULL,drop.unused.levels=TRUE) ##,devtol.fit=1e-8, steptol.fit=1e-8, check.analytical=FALSE, del=1e-4) ## Function to fit a SCAM to some data, withe the model stated in the formula ## Basic steps: ## 1) using 'interpret.gam()' of mgcv, formula is split up into parametric and ## non-parametric parts, and a fake formula constructed to be used to pick up ## data for model frame. pterms "terms" object(s) created for parametric ## components, model frame created along with terms object. ## 2. 'gam.setup()' of mgcv called to do most of basis construction and other ## elements of model setup. ## 3. 'estimate.scam()' is called to estimate the model if smoothing parameter should be ## selected, otherwise 'scam.fit' is called. Numerical optimization method to use ## to optimize the smoothing parameter estimation criterion is specified in 'optimizer' ## input argument as one of "bfgs" (currenlt default), "optim", "nlm", "nlm.fd", "efs" ## 4. 'scam.fit.post()' does post-fitting steps: compute null deviance and covariance ## matrices after the scam fit. ## 5. Finished 'scam' object assembled. ## 'scale': scale parameter of the exponential distribution as in gam(mgcv) ## 'optimizer': An array specifying the numerical optimization methods ## to optimize the smoothing parameter estimation criterion (specified in the first ## element of 'optimizer') and to use to estimate the model coefficients ## (specified in the second element of 'optimizer'). ## For the model coeff estimation, there are two alternatives: ## 'newton' (default) and 'bfgs' methods. ## For the sp selection the available methods are "bfgs" (default), "optim", "nlm", ## "nlm.fd", "efs". Note that 'bfgs' method for the coefficient estimation works only with 'efs'. ## 'optim.method': if optimizer[1]=="optim", then the first argument of optim.method specifies ## the method, and the second can be either "fd" for finite-difference approximation ## of the gradient or "grad" - to use analytical gradient of gcv/ubre ## 'not.exp': if TRUE then notExp() function will be used in place of exp in positivity ## ensuring beta parameters re-parameterization { control <- do.call("scam.control",control) ## Setting from mgcv(gam)....... ## create model frame..... gp <- interpret.gam(formula) # interpret the formula cl <- match.call() # call needed in gam object for update to work mf <- match.call(expand.dots=FALSE) mf$formula <- gp$fake.formula mf$family <- mf$control<-mf$scale<-mf$knots<-mf$sp<-mf$min.sp<-mf$H<-mf$select <- mf$drop.intercept <- mf$gamma<-mf$method<-mf$fit<-mf$paraPen<-mf$G<-mf$optimizer <- mf$optim.method <- mf$not.exp <- mf$in.out <- mf$AR1.rho <- mf$AR.start <- mf$start <- mf$etastart <- mf$mustart <-mf$devtol.fit <- mf$steptol.fit <- mf$del <- mf$...<-NULL mf$drop.unused.levels <- drop.unused.levels mf[[1]] <- quote(stats::model.frame) ## as.name("model.frame") pmf <- mf mf <- eval(mf, parent.frame()) # the model frame now contains all the data if (nrow(mf)<2) stop("Not enough (non-NA) data to do anything meaningful") terms <- attr(mf,"terms") ## summarize the *raw* input variables ## note can't use get_all_vars here -- buggy with matrices vars <- allvars1(gp$fake.formula[-2]) ## drop response here inp <- parse(text = paste("list(", paste(vars, collapse = ","),")")) ## allow a bit of extra flexibility in what `data' is allowed to be (as model.frame actually does) if (!is.list(data)&&!is.data.frame(data)) data <- as.data.frame(data) dl <- eval(inp, data, parent.frame()) names(dl) <- vars ## list of all variables needed var.summary <- variable.summary(gp$pf,dl,nrow(mf)) ## summarize the input data rm(dl) ## save space ## pterms are terms objects for the parametric model components used in ## model setup - don't try obtaining by evaluating pf in mf - doesn't ## work in general (e.g. with offset)... if (is.list(formula)) { ## then there are several linear predictors environment(formula) <- environment(formula[[1]]) ## e.g. termplots needs this pterms <- list() tlab <- rep("",0) for (i in 1:length(formula)) { pmf$formula <- gp[[i]]$pf pterms[[i]] <- attr(eval(pmf, parent.frame()),"terms") tlabi <- attr(pterms[[i]],"term.labels") if (i>1&&length(tlabi)>0) tlabi <- paste(tlabi,i-1,sep=".") tlab <- c(tlab,tlabi) } attr(pterms,"term.labels") <- tlab ## labels for all parametric terms, distinguished by predictor } else { ## single linear predictor case pmf$formula <- gp$pf pmf <- eval(pmf, parent.frame()) # pmf contains all data for parametric part pterms <- attr(pmf,"terms") ## pmf only used for this } if (is.character(family)) family <- eval(parse(text=family)) if (is.function(family)) family <- family() if (is.null(family$family)) stop("family not recognized") if (family$family[1]=="gaussian" && family$link=="identity") am <- TRUE else am <- FALSE ## if (AR1.rho!=0&&!is.null(mf$"(AR.start)")) if (!is.logical(mf$"(AR.start)")) stop("AR.start must be logical") ## scam_1.2-15... if (AR1.rho!=0&&!is.null(AR.start)) if (!is.logical(AR.start)) stop("AR.start must be logical") if (AR1.rho!=0 && !am) stop("residual autocorrelation, AR1, is currently available only for the Gaussian identity link model.") if (!control$keepData) rm(data) ## save space ## check whether family requires intercept to be dropped... # drop.intercept <- if (is.null(family$drop.intercept) || !family$drop.intercept) FALSE else TRUE # drop.intercept <- as.logical(family$drop.intercept) ### if (is.null(family$drop.intercept)) { ## family does not provide information ### lengthf <- if (is.list(formula)) length(formula) else 1 ### if (is.null(drop.intercept)) drop.intercept <- rep(FALSE, lengthf) else { ### drop.intercept <- rep(drop.intercept,length=lengthf) ## force drop.intercept to correct length ### if (sum(drop.intercept)) family$drop.intercept <- drop.intercept ## ensure prediction works ### } ### } else drop.intercept <- as.logical(family$drop.intercept) ## family overrides argument ### if (inherits(family,"general.family")&&!is.null(family$presetup)) eval(family$presetup) ### gsname <- if (is.list(formula)) "gam.setup.list" else "gam.setup" ### G <- do.call(gsname,list(formula=gp,pterms=pterms, ### data=mf,knots=knots,sp=sp, min.sp=min.sp, ### H=H,absorb.cons=TRUE,sparse.cons=0,select=select, ### idLinksBases=control$idLinksBases,scale.penalty=control$scalePenalty, ### paraPen=paraPen,drop.intercept=drop.intercept)) G <- do.call("gam.setup",list(formula=gp,pterms=pterms, data=mf,knots=knots,sp=sp, absorb.cons=TRUE,sparse.cons=0)) G$var.summary <- var.summary G$family <- family G$family <- fix.family(G$family) ## added in 1.2-19 to fix gaussian(link="log") initialization so that negative data does not make it fail if ((is.list(formula)&&(is.null(family$nlp)||family$nlp!=gp$nlp))|| (!is.list(formula)&&!is.null(family$npl)&&(family$npl>1))) stop("incorrect number of linear predictors for family") G$terms<-terms; G$mf<-mf;G$cl<-cl; G$am <- am G$AR1.rho <- AR1.rho; G$AR.start <- AR.start if (is.null(G$offset)) G$offset<-rep(0,G$n) G$min.edf <- G$nsdf ## -dim(G$C)[1] if (G$m) for (i in 1:G$m) G$min.edf<-G$min.edf+G$smooth[[i]]$null.space.dim G$formula <- formula G$pred.formula <- gp$pred.formula environment(G$formula)<-environment(formula) if (ncol(G$X)>nrow(G$X)) stop("Model has more coefficients than data") ### G <- gam(formula, family,data=data, knots=knots,fit=FALSE) ### n.terms <- length(G$smooth) ## number of smooth terms in the model ### n <- nrow(G$X) ## intercept <- G$intercept ## TRUE or FALSE ## now need to set 'offset' as the above G wouldn't take in 'offset' that is outside of formula.. ### gp <- interpret.gam(formula) # interpret the formula ### cl <- match.call() # call needed in gam object for update to work ### mf <- match.call(expand.dots=FALSE) ### mf$formula <- gp$fake.formula ### mf$family <- mf$control<-mf$scale<-mf$knots<-mf$sp<-mf$min.sp<-mf$H<-mf$select <- ### mf$gamma<-mf$method<-mf$fit<-mf$paraPen<-mf$G<-mf$optimizer <- mf$optim.method <- mf$not.exp <- mf$in.out <- ### mf$devtol.fit <- mf$steptol.fit <- mf$del <- mf$...<-NULL ### mf[[1]] <- quote(stats::model.frame) ## as.name("model.frame") ### pmf <- mf ### mf <- eval(mf, parent.frame()) # the model frame now contains all the data ### if (nrow(mf)<2) stop("Not enough (non-NA) data to do anything meaningful") # terms <- attr(mf,"terms") n.terms <- length(G$smooth) ## number of smooth terms in the model n <- nrow(G$X) intercept <- G$intercept G$offset <- as.vector(model.offset(mf)) if (is.null(G$offset)) G$offset <- rep.int(0, n) ## done offset ### if (is.null(weights)) ### weights <- rep.int(1,n) weights <- G$w fam.name <- G$family[1] if (scale == 0) { if (fam.name == "binomial" || fam.name == "poisson") sig2 <- 1 else sig2 <- -1 } else { sig2 <- scale } if (sig2 > 0) scale.known <- TRUE else scale.known <- FALSE ## get penalty matrices and ## vector of identifications for exponentiated model coefficients... Q <- penalty_pident(G) ## checking sp... if (!is.null(sp)) { neg <- FALSE if (length(sp)!= length(G$off)) { warning("Supplied smoothing parameter vector is too short - ignored.") sp <- NULL } else if (sum(is.na(sp))) { warning("NA's in supplied smoothing parameter vector - ignoring.") sp <- NULL } else { good <- sp < 0 if (sum(good) > 0) { ## cheking negative values.. warning("Supplied smoothing parameter vector has negative values - ignored.") neg <- TRUE } } if (neg) sp <- NULL } ## Create new environments with `start' initially empty (if not supplied)... # ee <- new.env() ## parent = .GlobalEnv env <- new.env() ## assign("start",rep(0,0),envir=env) assign("dbeta.start",rep(0,0),envir=env) assign("sp.last",rep(0,0),envir=env) nvars <- NCOL(G$X) # number of model coefficients if (!is.null(start)) { ## scam_1.2-12 ... if (length(start) != nvars) stop(gettextf("Length of start should equal %d and correspond to initial coefs.",nvars)) else assign("start",start,envir=env) } else{ assign("start",rep(0,0),envir=env) } G$S <- Q$S ## q.f <- rep(0,n.terms) ## if (n.terms >0) for (i in 1:n.terms) ## q.f[i] <- ncol(G$smooth[[i]]$S[[1]]) + 1 ## G$q.f <- q.f ## G$q0 <- G$off[1]-1 ## number of the parameters of the strictly parametric model ## G$off - first coef penalized by each element of S ## Note, that as paraPen is not implemented in scam, G$off does not include user supplied penalties on the parametric part of the model as it does with mgcv, plus it doe not include unpenalized smooths G$q0 <- if (G$intercept) 1+ length(unlist(lapply(G$pterms,attr,"term.labels"))) else length(unlist(lapply(G$pterms,attr,"term.labels"))) ## number of the parameters of the strictly parametric model, excluding intercept G$p.ident <- Q$p.ident ## vector of 0's & 1's for the model parameters identification: G$n.terms <- n.terms ## number of the smooth terms in the SCAM # G$intercept <- intercept G$weights <- weights G$sig2 <- sig2 G$scale.known <- scale.known G$not.exp <- not.exp G$gamma <- gamma ### if (!control$keepData) rm(data) ## save space object <- list() # if (is.null(sp)) { # ## get initial estimates of the smoothing parameter... # ## start <- etastart <- mustart <- NULL # y <- G$y; family <- G$family # nobs <- NROW(y) # eval(family$initialize) # G$y <- y ## needed to set factor response values as numeric # def.sp <- initial.sp.scam(G,optimizer=optimizer, Q,q.f=q.f,n.terms=n.terms,family=family, # intercept=intercept,offset=G$offset, env=env, # weights=weights, control=control) # rho <- log(def.sp+1e-4) ## get initial log(sp) ... # if (!is.null(start)) # assign("start",start,envir=env) ## scam_1.2-12 # ## minimize GCV/UBRE by optimizer.... # ptm <- proc.time() # re <- estimate.scam(G=G,optimizer=optimizer,optim.method=optim.method, # rho=rho, env=env,control=control) # CPU.time <- proc.time()-ptm # best <- re # object$gcv.ubre <- re$gcv.ubre # object$dgcv.ubre <- re$dgcv.ubre # best$p.ident <- Q$p.ident # best$S <- Q$S # object$optimizer <- re$optimizer # object$edf1 <- re$edf1 # object$termcode <- re$termcode # if (optimizer[1] == "bfgs") # { object$check.grad <- re$check.grad # object$dgcv.ubre.check <- re$dgcv.ubre.check # } # } else { ## no GCV minimization if sp is given... # object$optimizer <- optimizer # if (is.na(optimizer[2])) # optimizer[2] <- object$optimizer[2] <- "newton" # best <- if (optimizer[2] == "newton") # scam.fit(G=G, sp=sp,env=env, control=control) ## gamma=gamma # else scam.fit1(G=G, sp=sp,env=env, control=control) ## BFGS optimization # # object$optimizer[1] <- "NA" # } if (is.null(sp)) { ## scam_1.2-14 ... ## get initial estimates of the smoothing parameter... ## start <- etastart <- mustart <- NULL y <- G$y; family <- G$family nobs <- NROW(y) eval(family$initialize) G$y <- y ## needed to set factor response values as numeric def.sp <- initial.sp.scam(G,optimizer=optimizer, Q, n.terms=n.terms,family=family, ## ,q.f=q.f intercept=intercept,offset=G$offset, env=env, weights=weights, control=control) rho <- log(def.sp+1e-4) ## get initial log(sp) ... if (!is.null(start)) assign("start",start,envir=env) ## scam_1.2-12 } else { ## no sp estimation to do rho <- rep(0,0) G$sp <- sp } ptm <- proc.time() re <- estimate.scam(G=G,optimizer=optimizer,optim.method=optim.method, rho=rho, env=env,control=control) CPU.time <- proc.time()-ptm best <- re object$gcv.ubre <- re$gcv.ubre object$dgcv.ubre <- re$dgcv.ubre best$p.ident <- Q$p.ident best$S <- Q$S object$optimizer <- re$optimizer object$edf1 <- re$edf1 object$termcode <- re$termcode if (optimizer[1] == "bfgs") { object$check.grad <- re$check.grad object$dgcv.ubre.check <- re$dgcv.ubre.check } ## post-fitting values... best$n.smooth <- object$n.smooth <- n.terms best$formula <- object$formula <- formula best$family <- object$family <- G$family best$smooth <- object$smooth <- G$smooth best$model <- object$model <- G$mf object$R <- best$R if (is.null(object$R)){ if (object$optimizer[2] == "newton"){ rr <- scam.fit(G=G, sp=best$sp, env=env, control=control) ## gamma=gamma object$R <- rr$R ## not sure if it's needed? } } object$sp <- best$sp names(object$sp) <- names(G$sp) if (sum(is.na(names(object$sp)))!=0){ ## create names for sp if NA's from G if (n.terms >0) for (i in 1:n.terms) names(object$sp)[i] <- object$smooth[[i]]$label } object$conv <- best$conv # whether or not the inner full Newton(or bfgs) method converged if (object$optimizer[2] == "newton") post <- scam.fit.post(G=G, object=best,control=control) else post <- scam.fit.post1(G=G, object=best) ## for inner bfgs method object$edf <- best$edf # post$edf object$edf1 <- post$edf1 object$trA <- best$trA # post$trA names(object$edf) <- G$term.names names(object$edf1) <- G$term.names object$aic <- post$aic # best$aic object$null.deviance <- post$null.dev object$deviance <- post$deviance object$residuals <- post$residuals object$df.residual <- nrow(G$X) - sum(post$edf) object$rank <- post$rank object$var.summary <- G$var.summary object$cmX <- G$cmX ## column means of model matrix --- useful for CIs object$model<-G$mf # store the model frame object$full.sp <- G$full.sp ## incorrect !!! if (!is.null(object$full.sp)) names(object$full.sp) <- names(G$full.sp) object$na.action <- attr(G$mf,"na.action") # how to deal with NA's object$df.null <- post$df.null object$Ve <- post$Ve object$Vp <- post$Vb object$Ve.t <- post$Ve.t object$Vp.t <- post$Vb.t object$sig2 <- post$sig2 object$coefficients <- best$beta object$coefficients.t <- best$beta.t object$beta <- best$beta object$beta.t <- best$beta.t object$pterms <- G$pterms object$terms <- G$terms object$assign <- G$assign object$contrasts <- G$contrasts object$xlevels <- G$xlevels object$nsdf <- G$nsdf object$y <- G$y # object$data <- G$mf if (control$keepData) object$data <- data object$control <- control object$offset <- G$offset object$not.exp <- G$not.exp # object$scale.known <- scale.known # to be passed in the summary function object$scale.estimated <- !scale.known # to be passed in the summary function object$prior.weights <-weights # prior weights on observations object$weights <- best$w # final weights used in full Newton iteration object$fitted.values <- post$mu #best$mu object$linear.predictors <- post$eta #best$eta # cl<-match.call() # call needed in gam object for update to work object$call <- cl object$p.ident <- Q$p.ident object$intercept <- G$intercept object$min.edf <- G$min.edf ## Minimum possible degrees of freedom for whole model object$gamma <- gamma object$iter <- best$iter # number of iterations of the Full Newton object$pdev.hist <- best$pdev.hist if (is.null(sp)) object$CPU.time <- CPU.time else object$CPU.time <- NULL object$AR1.rho <- AR1.rho ## scam_1.2-15... object$AR.start <- AR.start object$std.rsd <- post$std.rsd ## get the optimizer info (smoothing parameter selection)..... if (is.null(sp)) { if (optimizer[1] == "bfgs") { ## get the bfgs info in case of sp selection... object$bfgs.info <- list() object$bfgs.info$conv <- re$conv.bfgs object$bfgs.info$iter <- re$iterations object$bfgs.info$grad <- re$dgcv.ubre object$bfgs.info$score.hist <- re$score.hist } else if (optimizer[1] == "nlm.fd" || optimizer[1] == "nlm") { object$nlm.info <- list() object$nlm.info$conv <- re$outer.info$conv object$nlm.info$iter <- re$outer.info$iterations object$nlm.info$grad <- re$dgcv.ubre } else if (optimizer[1]=="optim") { object$optim.info <- list() object$optim.info$conv <- re$outer.info$conv object$optim.info$iter <- re$outer.info$iterations object$optim.method <- re$optim.method } else if (optimizer[1]=="efs") { object$efs.info <- list() object$efs.info$conv <- re$outer.info$conv object$efs.info$iter <- re$outer.info$iter object$efs.info$score.hist <- re$outer.info$score.hist ## convergence info of the bfgs for pen.deviance minimization wrt model coeff-s... if (is.null(object$conv)) object$conv <- re$inner.info$conv if (is.null(object$iter)) object$iter <- re$inner.info$iter if (is.null(object$pdev.hist)) object$pdev.hist <- re$inner.info$pdev.hist } } if (scale.known) object$method <- "UBRE" else object$method <- "GCV" if (G$nsdf > 0) term.names <- colnames(G$X)[1:G$nsdf] else term.names <- array("", 0) if (n.terms >0) for (i in 1:n.terms) { k <- 1 for (j in G$smooth[[i]]$first.para:G$smooth[[i]]$last.para) { term.names[j] <- paste(G$smooth[[i]]$label, ".", as.character(k), sep = "") k <- k + 1 } } names(object$coefficients) <- term.names names(object$coefficients.t) <- term.names ynames <- if (is.matrix(G$y)) rownames(G$y) else names(G$y) names(object$residuals) <- ynames class(object) <- c("scam","glm","lm") rm(G) object } ## end scam ############################################################## ## control function for scam (similar to gam.control(mgcv)) ## ############################################################## scam.control <- function (maxit = 200, maxHalf=30, devtol.fit=1e-7, steptol.fit=1e-7, keepData=FALSE,efs.lspmax=15,efs.tol=.1, nlm=list(),optim=list(),bfgs=list(), trace =FALSE, print.warn=FALSE, b.notexp=1, threshold.notexp=20) # Control structure for a scam. # devtol.fit is the tolerance to use in the scam.fit call within each IRLS. # check.analytical - logical whether the analytical gradient of GCV/UBRE should be checked for bfgs method # del - increment for finite differences when checking analytical gradients for bfgs method # maxHalf is the number of step halvings to employ in bfgs_gcv.ubre search, before giving up on a search direction. # trace turns on or off some de-bugging information. # print.warn =FALSE - when set to 'FALSE' turns off printing warning messages for step halving under non-finite exponentiated coefficients, non-finite deviance and/or if mu or eta are out of bounds. # b.notexp, threshold.notexp are parameters of notExp() softPlus function { if (!is.numeric(devtol.fit) || devtol.fit <= 0) stop("value of devtol.fit must be > 0") if (!is.numeric(steptol.fit) || devtol.fit <= 0) stop("value of steptol.fit must be > 0") if (!is.numeric(maxit) || maxit <= 0) stop("maximum number of iterations must be > 0") if (!is.numeric(maxHalf) || maxHalf <= 0) stop("maximum number of step halving must be > 0") if (!is.logical(trace)) stop("trace must be logical") if (!is.logical(print.warn)) stop("print.warn must be logical") # work through nlm defaults if (is.null(nlm$ndigit)||nlm$ndigit<2) nlm$ndigit <- max(2,ceiling(-log10(1e-7))) nlm$ndigit <- round(nlm$ndigit) ndigit <- floor(-log10(.Machine$double.eps)) if (nlm$ndigit>ndigit) nlm$ndigit <- ndigit if (is.null(nlm$gradtol)) nlm$gradtol <- 1e-6 nlm$gradtol <- abs(nlm$gradtol) ## note that nlm will stop after hitting stepmax 5 consecutive times ## hence should not be set too small ... if (is.null(nlm$stepmax)||nlm$stepmax==0) nlm$stepmax <- 2 nlm$stepmax <- abs(nlm$stepmax) if (is.null(nlm$steptol)) nlm$steptol <- 1e-4 nlm$steptol <- abs(nlm$steptol) if (is.null(nlm$iterlim)) nlm$iterlim <- 200 nlm$iterlim <- abs(nlm$iterlim) ## Should be reset for a while anytime derivative code altered... if (is.null(nlm$check.analyticals)) nlm$check.analyticals <- FALSE nlm$check.analyticals <- as.logical(nlm$check.analyticals) # and bfgs defaults if (is.null(bfgs$check.analytical)) bfgs$check.analytical <- FALSE if (is.null(bfgs$del)) bfgs$del <- 1e-4 if (is.null(bfgs$steptol.bfgs)) bfgs$steptol.bfgs <- 1e-7 if (is.null(bfgs$gradtol.bfgs)) bfgs$gradtol.bfgs <- 1e-06 if (is.null(bfgs$maxNstep)) bfgs$maxNstep <- 5 ## the maximum allowable step length if (is.null(bfgs$maxHalf)) bfgs$maxHalf <- maxHalf ## the maximum number of step halving in "backtracking" # and optim defaults if (is.null(optim$factr)) optim$factr <- 1e7 optim$factr <- abs(optim$factr) if (efs.tol<=0) efs.tol <- .1 # notExp (sofPlus) function defaults... if (!is.numeric(b.notexp) || b.notexp <= 0) stop("value of b.notexp must be > 0") if (!is.numeric(threshold.notexp) || threshold.notexp <= 0) stop("value of threshold.notexp must be > 0") list(maxit=maxit, devtol.fit=devtol.fit, steptol.fit=steptol.fit, keepData=as.logical(keepData[1]), nlm=nlm, optim=optim,bfgs=bfgs,efs.lspmax=efs.lspmax,efs.tol=efs.tol,trace = trace, print.warn=print.warn,b.notexp=b.notexp, threshold.notexp=threshold.notexp) } ## end scam.control ################################################################# ## function to get initial estimates of smoothing parameters...## ################################################################# initial.sp.scam <- function(G,optimizer,Q, n.terms,family,intercept,offset, env= env, ##,q.f=q.f weights, control=control) { ## function to get initial estimates of smoothing parameters control$devtol.fit <- 1e-4 control$steptol.fit <- 1e-4 ## set 'newton' method for coeff estimation if not specified ## (it can happen if 'optimizer' was supplied with one element, specifying ## the sp optimization method to use as, e.g., 'optimizer="efs") if (is.na(optimizer[2])) optimizer[2] <- "newton" ## step 1: set sp=rep(0.5,p) and estimate hessian... if (optimizer[2] == "bfgs") { b <- scam.fit1(G=G,sp=rep(0.05,length(G$off)), env=env, control=control) H <- crossprod(b$wX1) } else { b <- scam.fit(G=G,sp=rep(0.05,length(G$off)), env=env, control=control) H <- crossprod(b$wX1) - b$E } ## step 2:... n.p <- length(Q$S) ## number of penalty matrices def.sp <- array(0,n.p) ## initialize the initial sp values j <- 1 if (n.terms >0) for (i in 1:n.terms){ if (is.null(G$smooth[[i]]$fixed)) fixed <- FALSE ## check if the smooth should be unpenalized else if (G$smooth[[i]]$fixed) fixed <- TRUE else fixed <- FALSE if (!fixed){ ## if (!G$smooth[[i]]$fixed){ for (kk in 1:length(G$smooth[[i]]$S)){ start <- G$off[j] finish <- start + ncol(G$smooth[[i]]$S[[kk]])-1 # matrix norm of the Hessian elements penalized by S[[kk]]... Hi.norm <- sum(H[start:finish,start:finish]*H[start:finish,start:finish]) Si.norm <- sum(G$smooth[[i]]$S[[kk]]*G$smooth[[i]]$S[[kk]]) def.sp[j] <- (Hi.norm/Si.norm)^0.5 j <- j+1 } } } ## Create again new environments with `start' initially empty... env <- new.env() assign("start",rep(0,0),envir=env) assign("dbeta.start",rep(0,0),envir=env) assign("sp.last",rep(0,0),envir=env) def.sp } ######################################################### ## function to get list of penalty matrices and ## ## vector of parameter identifications ..... ## ######################################################### penalty_pident <- function(object) { ## function to get the list of penalties and vector of model parameters ## identifications from the gam() setting... n.terms <- length(object$smooth) # number of terms in the model q <- ncol(object$X) # total number of parameters cons.terms <- rep(0,n.terms) # define whether each term is constrained or not if (n.terms>0) for (i in 1:n.terms){ if (!is.null(object$smooth[[i]]$p.ident)) cons.terms[i] <- 1 } p.ident <- rep(FALSE,q) # initialize vector of parameter identifications # with `TRUE' - for a parameter to be exponentiated, `FALSE' - otherwise off.terms <- rep(0,n.terms) # starting points for each term if (n.terms>0) for (i in 1:n.terms) off.terms[i] <- object$smooth[[i]]$first.para ## below is not correct for getting off.terms when some smooths are unpenalized (having fx=TRUE) ## off <- object$off ## if (n.terms ==length(off)) ## off.terms <- off ## else ## { off.terms[1] <- off[1] ## k <- 1; l <- 1 ## while (l0) for (i in 1:n.terms){ if (cons.terms[i]==1){ # if (inherits(object$smooth[[i]], c("mipc.smooth"))) # p.ident[off.terms[i]:(off.terms[i]+ncol(object$smooth[[i]]$S[[1]])-1)] <- # object$smooth[[i]]$p.ident[2:length(object$smooth[[i]]$p.ident)] # else ind <- attr(object$smooth[[i]],"del.index") ## to remove unidentifiable model coefficients, scam_1.2-15 if (!is.null(ind)) object$smooth[[i]]$p.ident <- object$smooth[[i]]$p.ident[-ind] ## p.ident[off.terms[i]:(off.terms[i]+ncol(object$smooth[[i]]$S[[1]])-1)] <- object$smooth[[i]]$p.ident p.ident[off.terms[i]:object$smooth[[i]]$last.para] <- object$smooth[[i]]$p.ident } } ## getting the list of penalty matrices in terms of the full model vector of coefficients... S <- list(); j <- 1 if (n.terms>0) for(i in 1:n.terms){ if (is.null(object$smooth[[i]]$fixed)) fixed <- FALSE ## check if the smooth should be unpenalized else if (object$smooth[[i]]$fixed) fixed <- TRUE else fixed <- FALSE if (!fixed){ ## if (!object$smooth[[i]]$fixed){ for (kk in 1:length(object$smooth[[i]]$S)){ S[[j]] <- matrix(0,q,q) # initialize penalty matrix S[[j]][off.terms[i]:(off.terms[i]+ncol(object$smooth[[i]]$S[[kk]])-1), off.terms[i]:(off.terms[i]+ncol(object$smooth[[i]]$S[[kk]])-1)] <- object$smooth[[i]]$S[[kk]] j <- j+1 } } } object$S <- S object$p.ident <- p.ident object } ## end penalty_pident ############################################################# ## Function to fit SCAM based on Full Newton method ## ############################################################# scam.fit <- function(G,sp, etastart=NULL, mustart=NULL, env=env, null.coef=rep(0,ncol(G$X)), control=scam.control()) ## gamma=1 ## maxit=200, devtol.fit=1e-8, steptol.fit=1e-8, trace=FALSE, print.warn=FALSE ## G - list of items from gam(...,fit=FALSE) needed to fit a scam ## sp- vector of smoothing parameters ## not.exp - if TRUE then notExp() function will be used in place of exp in positivity ensuring beta parameters re-parameterization ## null.coef - coefficients for a null model, in order to be able to check for immediate divergence. null.coef give some sort of upper bound on deviance. This allows immediate divergence problems to be controlled (from mgcv). here some of coeff need to be exponentiated. ## control - control list; it includes: ##* maxit - a positive scalar which gives the maximum number of iterations for Newton's method ##* devtol.fit - a scalar giving the tolerance at which the relative penalized deviance is considered to be close enougth to 0 to terminate the algorithm ##* steptol.fit - a scalar giving the tolerance at which the scaled distance between two successive iterates is considered close enough to zero to terminate the algorithm ##* trace turns on or off some de-bugging information. ##* print.warn =FALSE - when set to 'FALSE' turns off printing warning messages for step halving under non-finite exponentiated coefficients, non-finite deviance and/or if mu or eta are out of bounds. { y <- G$y; X <- G$X; S <- G$S; not.exp <- G$not.exp; gamma <- G$gamma AR1.rho <- G$AR1.rho attr(X,"dimnames") <- NULL ## q0 <- G$q0; q.f <- G$q.f p.ident <- G$p.ident; n.terms <- G$n.terms family <- G$family; intercept <- G$intercept; offset <- G$offset; weights <- G$weights; n <- nobs <- NROW(y) q <- ncol(X) dg <- fix.family.link(family) dv <- fix.family.var(family) nvars <- NCOL(X) EMPTY <- nvars == 0 variance <- family$variance linkinv <- family$linkinv if (!is.function(variance) || !is.function(linkinv)) stop("'family' argument seems not to be a valid family object") dev.resids <- family$dev.resids aic <- family$aic mu.eta <- family$mu.eta mu.eta <- family$mu.eta if (not.exp){ b.notexp <- control$b.notexp th.notexp <- control$threshold.notexp } if (AR1.rho!=0) { ld <- 1/sqrt(1-AR1.rho^2) ## leading diagonal of root inverse correlation sd <- -AR1.rho*ld ## sub diagonal row <- c(1,rep(1:nobs,rep(2,nobs))[-c(1,2*nobs)]) weight.r <- c(1,rep(c(sd,ld),nobs-1)) end <- c(1,1:(nobs-1)*2+1) if (!is.null(G$AR.start)) { ## need to correct the start of new AR sections... ii <- which(G$AR.start ==TRUE) if (length(ii)>0) { if (ii[1]==1) ii <- ii[-1] ## first observation does not need any correction weight.r[ii*2-2] <- 0 ## zero sub diagonal weight.r[ii*2-1] <- 1 ## set leading diagonal to 1 } } ## apply transform... X <- rwMatrix(end,row,weight.r,X) y <- rwMatrix(end,row,weight.r,y) } if (!is.function(variance) || !is.function(linkinv)) stop("illegal `family' argument") valideta <- family$valideta if (is.null(valideta)) valideta <- function(eta) TRUE validmu <- family$validmu if (is.null(validmu)) validmu <- function(mu) TRUE if (is.null(mustart)) { eval(family$initialize) } else { mukeep <- mustart eval(family$initialize) mustart <- mukeep } ## Added code... if (family$family=="gaussian"&&family$link=="identity") strictly.additive <- TRUE else strictly.additive <- FALSE ## end of added code if (EMPTY) { eta <- rep.int(0, nobs) + offset if (!valideta(eta)) stop("Invalid linear predictor values in empty model") mu <- linkinv(eta) if (AR1.rho!=0) { mu <- rwMatrix(end,row,weight.r,mu) } if (!validmu(mu)) stop("Invalid fitted means in empty model") dev <- sum(dev.resids(y, mu, weights)) w <- (weights * mu.eta(eta)^2)/variance(mu) ## incorrect for Newton residuals <- (y - mu)/mu.eta(eta) good <- rep(TRUE, length(residuals)) boundary <- conv <- TRUE coef <- numeric(0) iter <- 0 V <- variance(mu) alpha <- dev trA <- 0 GCV <- nobs * alpha/(nobs - gamma * trA)^2 UBRE <- alpha/nobs + 2 * gamma* trA*scale/n - scale scale.est <- alpha/(nobs - trA) aic.model <- aic(y, n, mu, weights, dev) + 2 * trA } ### end if (EMPTY) else { eta <- if (!is.null(etastart)) etastart else family$linkfun(mustart) mu <- as.numeric(linkinv(eta)) # if (!(validmu(mu) && valideta(eta))) # stop("Can't find valid starting values: please specify some") S.t <- matrix(0,q,q) # define the total sum of the penalties times sp n.pen <- length(S) # number of penalties if (length(sp)!=n.pen) stop (paste("length of sp has to be equal to", n.pen)) if (n.pen>0) for (j in 1:n.pen) S.t <- S.t + sp[j]*S[[j]] # get sqrt of total penalty matrix... er <- eigen(S.t,symmetric=TRUE); er$values[er$values<0] <- 0 rS <- crossprod(sqrt(sqrt(er$values))*t(er$vectors)) # ii <- p.ident==1 ## set to TRUE/FALSE ## count <- sum(p.ident) ## iv <- array(0, dim=c(count,1)) # define an index vector for the coeff-s to be exponentiated iv <- (1:q)[p.ident] # define an index vector for the coeff-s to be exponentiated ############################################## ## Initialization of parameters start here... beta0 <- get("start",envir=env) dbeta0 <- get("dbeta.start",envir=env) sp.old <- get("sp.last",envir=env) if (length(beta0)==0) { # list argument to pcls for initializing model coefficients M <- list(X=X,p=rep(0.1,q),C=matrix(0,0,0),sp=sp,y=eta-offset,w=y*0+1) M$Ain <- matrix(0,q,q); diag(M$Ain) <- rep(1,q); M$bin <- rep(-1e+12,q); M$bin[iv] <- 1e-12 M$off <- rep(0,n.pen); M$S <- list() if (n.pen>0) for (j in 1:n.pen) {M$S[[j]] <- matrix(0,q,q); M$S[[j]] <- S[[j]]} beta.t <- pcls(M) # initialize model coefficients (re-parameterized beta) beta <- beta.t # initialize beta beta[iv] <- log(beta.t[iv]) # values of beta of the constrained terms } else { beta <- beta0 beta.t <- beta ## current beta tilde beta.t[iv] <- if (!not.exp) exp(beta[iv]) else notExp(beta[iv],b.notexp,th.notexp) # values of re-para beta of the constrained term } ## Initialization of parameters finishes here ################################################# eta <- as.numeric(X%*%beta.t + as.numeric(offset)) # define initial linear predictor mu <- linkinv(eta) # define initial fitted model ## dev <- sum(dev.resids(y,mu,weights)) # define initial norm/deviance ## pdev <- dev + sum((rS%*%beta)^2) # define initial penalized deviance ## old.pdev <- pdev # initialize convergence control for penalized deviance ################################################################## ## added code here made on May 6, 2020 for scam version 1-2-6, ## following gam.fit3(mgcv_1.8-31)).... ################################################################### ## shrink towards null.coef if immediately invalid ## betaold <- null.coef ## etaold <- null.eta <- as.numeric(X%*%null.coef + as.numeric(offset)) ## old.pdev <- sum(dev.resids(y, linkinv(null.eta), weights)) + sum((rS%*%null.coef)^2) ## null.eta <- as.numeric(X%*%null.coef + as.numeric(offset)) ii <- 0 while (!(validmu(mu) && valideta(eta))) { ## shrink towards null.coef if immediately invalid ii <- ii + 1 if (ii>20) stop("Can't find valid starting values: please specify some") beta <- beta * .9 + null.coef * .1 beta.t <- beta ## current beta tilde beta.t[iv] <- if (!not.exp) exp(beta[iv]) else notExp(beta[iv],b.notexp,th.notexp) eta <- as.numeric(X%*%beta.t + offset) mu <- linkinv(eta) } betaold <- null.coef <- beta betaold.t <- beta betaold.t[iv] <- if (!not.exp) exp(betaold[iv]) else notExp(betaold[iv],b.notexp,th.notexp) etaold <- as.numeric(X%*%betaold.t + offset) old.pdev <- sum(dev.resids(y,linkinv(etaold),weights)) + sum((rS%*%betaold)^2) ################################################################## pdev.plot <- 0 # define initial pen dev for plotting it E <- matrix(0,q,q) # define diagonal matrix E- second term of the Hessian Cdiag <- rep(1,q); C1diag <- rep(0,q) ## if (!not.exp) { ## Cdiag[iv] <- C1diag[iv] <- beta.t[iv] ## } else { ## Cdiag[iv] <- DnotExp(beta[iv]); C1diag[iv] <- D2notExp(beta[iv]) ## } ## tX1 <- Cdiag*t(X) ## g.deriv <- 1/mu.eta(eta) # diag(G) ## w1 <- weights/(variance(mu)*g.deriv^2) # diag(W1) ## Dp.g <- - drop(tX1%*%(w1*g.deriv*(y-mu))) + S.t%*%beta # the gradient vector of the penalized deviance ## Dp.gnorm <- max(abs(Dp.g)) # set convergence on the max value of the Dp.g ## betaold <- beta boundary <- conv <- FALSE old.warn <- getOption("warn") if (!control$print.warn) curr.warn <- -1 else curr.warn <- old.warn ################################################### ## MAIN ITERATIONS START HERE... #cat("\nscam.fit iter start") for (iter in 1:control$maxit) { #cat(".") good <- weights > 0 var.val <- variance(mu) varmu <- var.val[good] if (any(is.na(varmu))) stop("NAs in V(mu)") if (any(varmu == 0)) stop("0s in V(mu)") mu.eta.val <- mu.eta(eta) if (any(is.na(mu.eta.val[good]))) stop("NAs in d(mu)/d(eta)") good <- (weights > 0) & (mu.eta.val != 0) if (all(!good)) { conv <- FALSE warning("No observations informative at iteration ", iter) break } if (!not.exp) { Cdiag[iv] <- C1diag[iv] <- beta.t[iv] } else { Cdiag[iv] <- DnotExp(beta[iv],b.notexp,th.notexp); C1diag[iv] <- D2notExp(beta[iv],b.notexp,th.notexp) } tX1 <- Cdiag*t(X) g.deriv <- 1/mu.eta(eta) # diag(G) w1 <- weights/(variance(mu)*g.deriv^2) # diag(W1) - Fisher weights y.mu <- y - mu alpha <- 1+ y.mu*(dv$dvar(mu)/variance(mu)+dg$d2link(mu)/g.deriv) # alpha elements of W w <- w1*alpha # diag(W) - Newton weights diag(E) <- drop((C1diag*t(X))%*%(w1*g.deriv*y.mu)) abs.w <- abs(w) # absolute values of the diag(W) I.minus <- rep(0,nobs) # define diagonal elements of the matrix I^{-} z1 <- g.deriv*y.mu/alpha # the first term of the pseudodata iin <- w < 0; I.minus[iin] <- 1;z1[iin] <- -z1[iin] wX11 <- rbind(sqrt(abs.w)[1:nobs]*t(tX1),rS) illcond <- FALSE Q <- qr(wX11,LAPACK=TRUE) R <- qr.R(Q) rp <- 1:ncol(R) rp[Q$pivot] <- rp ## reverse pivot X=Q%*%R[,rp] if (Rrank(R)==ncol(R)) { ## no need to truncate, can just use QR R.inv <- backsolve(R,diag(ncol(R)))[rp,] ## inverse of unpivoted R tR.inv <- t(R.inv) } else { ## need SVD step R <- R[,rp] ## unpivoted R svd.r <- svd(R) d.inv <- rep(0,q) # initial vector of inverse singular values good1 <- svd.r$d >= max(svd.r$d)*.Machine$double.eps^.5 d.inv[good1] <- 1/svd.r$d[good1] if (sum(!good1)>0) illcond <- TRUE R <- svd.r$d*t(svd.r$v) Q <- qr.qy(Q,rbind(svd.r$u,matrix(0,nobs,q))) ## this is inefficient don't need to extract Q really tR.inv <- d.inv*t(svd.r$v) # inverse of transpose of R R.inv <- t(tR.inv) } QtQRER <- tR.inv%*%(diag(E)*R.inv) if (sum(I.minus)>0) { if (is.qr(Q)) { # QtQRER <- QtQRER + 2*tcrossprod(qr.qty(Q,diag(nrow(wX11))[,(1:nobs)[as.logical(I.minus)]])) QtQRER <- QtQRER + 2*crossprod(I.minus*qr.Q(Q)[1:nobs,]) } else { QtQRER <- QtQRER + 2*crossprod(I.minus*Q[1:nobs,]) } } ei <- eigen(QtQRER,symmetric=TRUE) # eigen-decomposition of QtQRER d <- ei$values # vector of eigenvalues ok1 <- sum(d>1) > 0 # checking positive semi-definiteness if (ok1 == TRUE) {# Fisher step in case of not +ve semi-definiteness of penalized loglikelihood # set alpha =1 eta.t <- drop(t(beta)%*%tX1) # eta tilde for pseudodata wX11 <- rbind(sqrt(w1)[1:nobs]*t(tX1),rS) z<-g.deriv*y.mu+eta.t # pseudodata wz<-w1^.5*z # weighted pseudodata wz.aug<-c(wz,rep(0,nrow(rS))) # augmented pseudodata Q <- qr(wX11,LAPACK=TRUE) R <- qr.R(Q) rp <- 1:ncol(R) rp[Q$pivot] <- rp ## reverse pivot X=Q%*%R[,rp] if (Rrank(R)==ncol(R)) { ## no need to truncate, can just use QR beta <- backsolve(R,qr.qty(Q,wz.aug)[1:q])[rp] } else { ## need SVD step R <- R[,rp] ## unpivoted R s1 <- svd(R) d.inv1 <- rep(0,q) good1 <- s1$d >= max(s1$d)*.Machine$double.eps^.5 d.inv1[good1] <- 1/s1$d[good1] beta <- s1$v%*%((d.inv1*t(s1$u))%*%qr.qty(Q,wz.aug)[1:q]) } } ### end of if (ok1) - Fisher step else { ## full Newton step Id.inv.r<-1/(1-d)^.5 # vector of inverse values of (1-sv)^.5 iin <- (1-d) < .Machine$double.eps Id.inv.r[iin] <- 0 eidrop <- t(Id.inv.r*t(ei$vectors)) wz1<-sqrt(abs.w)*z1 # the first term of the weighted pseudodata if (is.qr(Q)) { beta <- R.inv%*%(eidrop%*%(t(eidrop)%*%qr.qty(Q,c(wz1,rep(0,nrow(rS))))[1:nrow(eidrop)])) } else { beta <- R.inv%*%(eidrop%*%(t(eidrop)%*%(t(Q[1:nobs,])%*%wz1)[1:nrow(eidrop)])) } beta <- betaold + drop(beta - R.inv%*%(eidrop%*%(t(eidrop)%*%(tR.inv%*%(S.t%*%betaold))))) } ### end of if (!ok1) - Newton step ## delta <- beta-c(betaold) # trial step ## step <- 1 # initial trial step length ## beta <- c(betaold)+step*delta # current parameter estimates beta.t <- beta # current reparameterized beta beta.t[iv] <- if (!not.exp) exp(beta[iv]) else notExp(beta[iv],b.notexp,th.notexp) # values of re-para beta of the shape constrained term ## eta <- drop(as.numeric(X%*%beta.t + offset)) # linear predictor ## mu <- linkinv(eta) # fitted values ## dev <- sum(dev.resids(y,mu,weights)) # deviance of the working model ## pdev <- dev + sum((rS%*%beta)^2) # deviance + penalty of the working model ################################################################## ## added code here made on May 6, 2020 for scam version 1-2-6, ## following gam.fit3(mgcv_1.8-31)).... ################################################################### if (any(!is.finite(beta))) { conv <- FALSE warning(gettextf("Non-finite coefficients at iteration %d", iter)) break } options(warn = curr.warn) ## turn of/on printing warning messages under non-finite deviance resulted in non-finite exponentiated coefficients... if (any(!is.finite(beta.t))) { conv <- FALSE warning(gettextf("Non-finite exponentiated coefficients at iteration %d", iter)) # break ## takes out of the main iteration loop 'iter in 1:maxit' } eta <- drop(as.numeric(X%*%beta.t + offset)) # linear predictor mu <- linkinv(eta) # fitted values dev <- sum(dev.resids(y,mu,weights)) # deviance of the working model penalty <- sum((rS%*%beta)^2) if (control$trace) message(gettextf("Deviance = %s Iterations - %d", dev, iter, domain = "R-scam")) boundary <- FALSE ## step halve under non-finite deviance... if (!is.finite(dev)) { if (is.null(betaold)) { if (is.null(null.coef)) stop("no valid set of coefficients has been found:please supply starting values", call. = FALSE) ## Try to find feasible coefficients from the null.coef and null.eta betaold <- null.coef } warning("Step size truncated due to divergence", call. = FALSE) ii <- 0 ## step <- 1 while (!is.finite(dev)) { if (ii > control$maxit) stop("inner loop 1; can't correct step size") ii <- ii + 1 ## beta <- (beta + betaold)/2 ## eta <- (eta + etaold)/2 ## mu <- linkinv(eta) ## step <- step/2 ## decrease step length ## beta <- c(betaold)+step*delta ## update current parameter estimates beta <- (beta + c(betaold))/2 beta.t <- beta ## update current re-para beta beta.t[iv] <- if (!not.exp) exp(beta[iv]) else notExp(beta[iv],b.notexp,th.notexp) eta <- as.numeric(X%*%beta.t + offset) ## linear predictor mu <- linkinv(eta) ## fitted values dev <- sum(dev.resids(y, mu, weights)) } boundary <- TRUE penalty <- sum((rS%*%beta)^2) ## t(beta)%*%S.t%*%beta # reset penalty too if (control$trace) cat("Step halved: new deviance =", dev, "\n") } ## end of infinite deviance correction ## now step halve if mu or eta are out of bounds... if (!(valideta(eta) && validmu(mu))) { warning("Step size truncated: out of bounds", call. = FALSE) ii <- 0 ## step <- 1 while (!(valideta(eta) && validmu(mu))) { if (ii > control$maxit) stop("inner loop 2; can't correct step size") ii <- ii + 1 ## beta <- (beta + betaold)/2 ## eta <- (eta + etaold)/2 ## mu <- linkinv(eta) ## step <- step/2 ## decrease step length ## beta <- c(betaold)+step*delta ## update current parameter estimates beta <- (beta + c(betaold))/2 ## update current parameter estimates beta.t <- beta ## update current re-para beta beta.t[iv] <- if (!not.exp) exp(beta[iv]) else notExp(beta[iv],b.notexp,th.notexp) eta <- as.numeric(X%*%beta.t + offset) ## linear predictor mu <- linkinv(eta) ## fitted values } boundary <- TRUE penalty <- sum((rS%*%beta)^2) ## t(beta)%*%S.t%*%beta dev <- sum(dev.resids(y, mu, weights)) if (control$trace) cat("Step halved: new deviance =", dev, "\n") } ## end of invalid mu/eta handling options(warn = old.warn) ## return to the default option for printing warning messages (which is '0') ## now check for divergence of penalized deviance.... pdev <- dev + penalty ## the penalized deviance if (control$trace) message(gettextf("penalized deviance = %s", pdev, domain = "R-scam")) ###################################################### ## end of added coding ###################################################### div.thresh <- 10*(.1 +abs(old.pdev))*.Machine$double.eps^.5 ## `step reduction' approach starts here... ## ii <- 1 ## while ( (pdev-old.pdev) > div.thresh) { # 'step reduction' approach ## if (ii > maxHalf.fit) ## break ## stop ("step reduction failed") ## ii <- ii+1 ## step <- step/2 # decrease step length ## beta <- c(old.beta)+step*delta # update current parameter estimates ## beta.t <- beta # update current re-para beta ## beta.t[iv] <- if (!not.exp) exp(beta[iv]) else notExp(beta[iv]) ## eta <- as.numeric(X%*%beta.t + offset) # linear predictor ## mu <- linkinv(eta) # fitted values ## dev <- sum(dev.resids(y,mu,weights)) # update deviance of the working model ## pdev <- dev+sum((rS%*%beta)^2) # update pen deviance of the working model ## } ## `step reduction' finishes here ## ... threshold for judging divergence --- too tight and near ## perfect convergence can cause a failure here if (pdev-old.pdev>div.thresh) { ## solution diverging ii <- 0 ## step halving counter ## step <- 1 ## if (iter==1) { ## immediate divergence, need to shrink towards zero ## betaold <- null.coef ## } while (pdev -old.pdev > div.thresh){ ## step halve until pdev <= old.pdev if (ii > 100) stop("inner loop 3; can't correct step size") ii <- ii + 1 ## beta <- (beta + betaold)/2 ## eta <- (eta + etaold)/2 ## mu <- linkinv(eta) ## step <- step/2 ## decrease step length ## beta <- c(betaold)+step*delta ## update current parameter estimates beta <- (beta + c(betaold))/2 beta.t <- beta ## update current re-para beta beta.t[iv] <- if (!not.exp) exp(beta[iv]) else notExp(beta[iv],b.notexp,th.notexp) eta <- as.numeric(X%*%beta.t + offset) ## linear predictor mu <- linkinv(eta) ## fitted values dev <- sum(dev.resids(y, mu, weights)) ## update deviance of the working model pdev <- dev + sum((rS%*%beta)^2) ## update the penalized deviance if (control$trace) message(gettextf("Step halved: new penalized deviance = %g", pdev, "\n")) } } ## end of pdev divergence Dp.g <- -drop(tX1%*%(w1*g.deriv*(y-mu)))+S.t%*%beta # the gradient vector of the penalized deviance Dp.gnorm <- max(abs(Dp.g)) pdev.plot[iter] <- pdev # store penilized deviance of the working model for plotting ## if (strictly.additive) { conv <- TRUE; break;} ## checking convergence adequately... if (abs(pdev - old.pdev)/(.1 + abs(pdev)) < control$devtol.fit) { if (Dp.gnorm > control$devtol.fit*max(abs(beta+c(betaold)))/2) { ## if (max(abs(beta - c(betaold))) > control$steptol.fit*max(abs(beta + c(betaold)))/2) { old.pdev <- pdev ## not converged quite enough betaold <- beta } else { ## converged conv <- TRUE beta <- beta break } } else { ## not converged old.pdev <- pdev betaold <- beta } } ## main iteration procedure is completed here. ####################################################### ## at this stage the model has been fully estimated ## now define matrices at their converged values from the full Newton method... # beta.t <- beta ## estimates of re-para beta # beta.t[iv] <- if (!not.exp) exp(beta[iv]) else notExp(beta[iv]) # eta <- as.numeric(X%*%beta.t + offset) ## linear predictor # mu <- linkinv(eta) ## fitted values # dev <- sum(dev.resids(y,mu,weights)) if (!not.exp) { Cdiag[iv] <- C1diag[iv] <- beta.t[iv] } else { Cdiag[iv] <- DnotExp(beta[iv],b.notexp,th.notexp); C1diag[iv] <- D2notExp(beta[iv],b.notexp,th.notexp) } X1 <- t(Cdiag*t(X)) g.deriv <- 1/ mu.eta(eta) # diag(G) w1 <- weights/(variance(mu)*g.deriv^2) # diag(W1) alpha <- 1+(y-mu)*(dv$dvar(mu)/variance(mu)+dg$d2link(mu)/g.deriv) # alpha elements of W w <- w1*alpha # diag(W) diag(E) <- drop((C1diag*t(X))%*%(w1*g.deriv*(y-mu))) # diagonal elements of E abs.w <- abs(w) # absolute values of the diag(W) I.minus <- rep(0,nobs) # define diagonal elements of the matrix I^{-} I.minus[w<0] <- 1 wX1 <- sqrt(abs.w)[1:nobs]*X1 ## wX1 actually used later wX11 <- rbind(wX1,rS) # augmented model matrix ## Faster version only does SVD when needed (and then only on QR factor) illcond <- FALSE Q <- qr(wX11,LAPACK=TRUE) R <- qr.R(Q) rp <- 1:ncol(R) rp[Q$pivot] <- rp ## reverse pivot X=Q%*%R[,rp] R.out <- R[,rp] ## unpivoted R, needed for summary function rank <- Rrank(R) if (rank==ncol(R)) { ## no need to truncate, can just use QR R.inv <- backsolve(R,diag(ncol(R)))[rp,] ## inverse of unpivoted R tR.inv <- t(R.inv) } else { ## need SVD step R <- R[,rp] ## unpivoted R svd.r <- svd(R) d.inv <- rep(0,q) # initial vector of inverse singular values good1 <- svd.r$d >= max(svd.r$d)*.Machine$double.eps^.5 d.inv[good1] <- 1/svd.r$d[good1] if (sum(!good1)>0) illcond <- TRUE R <- svd.r$d*t(svd.r$v) Q <- qr.qy(Q,rbind(svd.r$u,matrix(0,nobs,q))) ## this is inefficient don't need to extract Q really tR.inv <- d.inv*t(svd.r$v) # inverse of transpose of R R.inv <- t(tR.inv) } QtQRER <- tR.inv%*%(diag(E)*R.inv) if (sum(I.minus)>0) { if (is.qr(Q)) { QtQRER <- QtQRER + 2*crossprod(I.minus*qr.Q(Q)[1:nobs,]) } else { QtQRER <- QtQRER + 2*crossprod(I.minus*Q[1:nobs,]) } } ei <- eigen(QtQRER,symmetric=TRUE) # eigen-decomposition of QtQRER d <- ei$values # vector of eigenvalues ok1 <- sum(d>1)>0 if (ok1) { ## Fisher step in case of not positive semi-definiteness of penalized loglikelihood ## set alpha =1 ... wX1<-sqrt(w1)[1:nobs]*X1 wX11<-rbind(wX1,rS) Q <- qr(wX11,LAPACK=TRUE) R <- qr.R(Q) rp <- 1:ncol(R) rp[Q$pivot] <- rp ## reverse pivot X=Q%*%R[,rp] R.out <- R[,rp] ## unpivoted R, needed for summary function rank <- Rrank(R) if (rank==ncol(R)) { ## no need to truncate, can just use QR P <- backsolve(R,diag(ncol(R)))[rp,] K <- qr.Q(Q)[1:nobs,] } else { ## need SVD step R <- R[,rp] ## unpivoted R s1 <- svd(R) d.inv1 <- rep(0,q) good1 <- s1$d >= max(s1$d)*.Machine$double.eps^.5 d.inv1[good1] <- 1/s1$d[good1] P <- t(d.inv1*t(s1$v)) K <- qr.qy(Q,rbind(s1$u,matrix(0,nobs,q)))[1:nobs,] } } ## end of if (ok1) else { ## full Newton step Id.inv.r<-1/(1-d)^.5 # vector of inverse values of (1-sv)^1/2 ii <- (1-d) < .Machine$double.eps Id.inv.r[ii] <- 0 eidrop <- t(Id.inv.r*t(ei$vectors)) P <- R.inv%*%eidrop ## ei$vectors%*%diag(Id.inv.r) # define matrix P if (is.qr(Q)) { K <- qr.qy(Q,rbind(eidrop,matrix(0,nobs,q)))[1:nobs,] } else { K <- Q[1:nobs,]%*%eidrop ## (ei$vectors%*%diag(Id.inv.r)) # define matrix K } } ## end of if (!ok1) # end of calculation of the matrices at their converged values... Dp.g <- -t(X1)%*%(w1*g.deriv*(y-mu))+S.t%*%beta # the gradient vector of the penalized deviance Dp.gnorm<-max(abs(Dp.g)) # calculating tr(A)... I.plus <- rep(1,nobs) # define diagonal elements of the matrix I^{+} I.plus[w<0] <- -1 L <- c(1/alpha) # define diagonal elements of L=diag(1/alpha) ## NOTE PKt is O(np^2) and not needed --- can compute trA as side effect of gradiant KtILQ1R <- crossprod(L*I.plus*K,wX1) ## t(L*I.plus*K)%*%wX1 edf <- rowSums(P*t(KtILQ1R)) trA <- sum(edf) ## below is needed for later calculations of derivative of trA wXC1 <- sqrt(abs.w)[1:nobs]*t(C1diag*t(X)) KtILQ1R <- if (!not.exp) KtILQ1R else crossprod(L*I.plus*K,wXC1) ##t(L*I.plus*K)%*%wXC1 KtIQ1R <- if (!not.exp) crossprod(I.plus*K,wX1) else crossprod(I.plus*K,wXC1) C2diag <- rep(0,q) C2diag[iv] <- if (!not.exp) C1diag[iv] else D3notExp(beta[iv],b.notexp,th.notexp) XC2 <- t(C2diag*t(X)) XC1 <- t(C1diag*t(X)) ############################ ## some return values.... dlink.mu <- 1/mu.eta(eta); Var<- variance(mu) link <- family$linkfun(mu); d2link.mu <- dg$d2link(mu) dvar.mu <- dv$dvar(mu); d2var.mu <- dv$d2var(mu) d3link.mu <- dg$d3link(mu) z <- g.deriv*(y-mu)+X1%*%beta ############################# ############################# scale.est <- dev/(nobs-trA) # scale estimate ## re-transforming 'mu' back on original scale and hence residuals, in case of correlated errors... residuals <- rep.int(NA, nobs) residuals <- (y-mu)*g.deriv # if (AR1.rho==0) residuals <- (y-mu)*g.deriv # else { # eta <- as.numeric(G$X%*%beta.t + offset) # linear predictor on original scale # mu <- linkinv(eta) # fitted values on original scale # g.deriv <- 1/ mu.eta(eta) # diag(G) # residuals <- (G$y-mu)*g.deriv # } ################################ ## calculation of the derivatives of beta by the Implicit Function Theorem starts here dbeta.rho <- matrix(0,q,n.pen) # define matrix of the parameters derivatives if (n.pen>0) for (j in 1:n.pen) { dbeta.rho[,j] <- - sp[j]*P%*%(t(P)%*%(S[[j]]%*%beta)) # derivative of beta wrt rho[j] } # end of calculating the parameters derivatives aic.model <- aic(y, n, mu, weights, dev) + 2 * sum(edf) ## scam_1.2-15... if (AR1.rho!=0) { ## correct aic for AR1 transform std.rsd <- AR.resid(residuals,AR1.rho,G$AR.start) ##standardised residuals for AR1 model (approximately uncorrelated under correct model) dev.st <- sum(std.rsd^2) df <- if (is.null(G$AR.start)) 1 else sum(G$AR.start) aic.model <- aic(y, n, mu, weights, dev.st) +2*sum(edf) -2*(n-df)*log(ld) } assign("start",beta,envir=env) assign("dbeta.start",dbeta.rho,envir=env) assign("sp.last",sp,envir=env) } ### end if (!EMPTY) list(L=L,C1diag=C1diag,E=E,iter=iter, old.beta=betaold, gcv=dev*nobs/(nobs-gamma *trA)^2, sp=sp, mu=mu,X=G$X,y=drop(G$y), X1=X1,beta=beta,beta.t=beta.t,iv=iv,S=S,S.t=S.t,rS=rS, P=P,K=K, C2diag=C2diag, KtILQ1R= KtILQ1R, KtIQ1R=KtIQ1R, ## XC1=XC1, XC2=XC2, dlink.mu=dlink.mu,Var=Var, abs.w=drop(abs.w), link=link,w=as.numeric(w),w1=drop(w1),d2link.mu=d2link.mu,wX1=wX1,I.plus=I.plus, dvar.mu=dvar.mu,d2var.mu=d2var.mu,deviance=dev,scale.est=scale.est, ok1=ok1,alpha=as.numeric(alpha),d3link.mu=d3link.mu,eta=eta,iter=iter, Dp.gnorm=Dp.gnorm, Dp.g=Dp.g,d=d, conv=conv, illcond=illcond,R=R.out, edf=edf,trA=trA, residuals=residuals,z=z,dbeta.rho=dbeta.rho, aic=aic.model,rank=rank,pdev.hist=pdev.plot) ##step=step, AR1.rho=AR1.rho,AR.start=G$AR.start) } ## end of scam.fit ####################################################################### ## function to get null deviance and covariance matrices after fit ## ####################################################################### scam.fit.post<- function(G, object,control) ##,sig2,offset,intercept, weights,scale.known, not.exp) { ## Function to compute null deviance and covariance matrices after a scam fit. ## covariance matrix should use expected Hessian, so re-computation of factors ## is required. ## object - object from estimate.scam() y <- G$y; X <- G$X; sig2 <- G$sig2; offset <- G$offset; intercept <- G$intercept; weights <- G$weights; scale.known <- G$scale.known; not.exp <- G$not.exp n <- nobs <- NROW(y) # number of observations q <- ncol(X) if (not.exp) { b.notexp <- control$b.notexp th.notexp <- control$threshold.notexp } linkinv <- object$family$linkinv dev.resids <- object$family$dev.resids dg <- fix.family.link(object$family) dv <- fix.family.var(object$family) ## scam_1.2-15 (removed AR1 transform for y and X as output must be on original untransformed scale)... eta <- as.numeric(X%*%object$beta.t + offset) # linear predictor mu <- linkinv(eta) # fitted values dev <- sum(dev.resids(y,mu,weights)) # deviance of the final model wtdmu <- if (intercept) sum(weights * y)/sum(weights) else linkinv(offset) null.dev <- sum(dev.resids(y, wtdmu, weights)) n.ok <- nobs - sum(weights == 0) nulldf <- n.ok - as.integer(intercept) ## define matrices at their converged values from the full Newton method... Cdiag <- rep(1,q); C1diag <- rep(0,q) iv <- object$iv if (!not.exp) { Cdiag[iv] <- C1diag[iv] <- object$beta.t[iv] } else { Cdiag[iv] <- DnotExp(object$beta[iv],b.notexp,th.notexp); C1diag[iv] <- D2notExp(object$beta[iv],b.notexp,th.notexp) } X1 <- t(Cdiag*t(X)) g.deriv <- 1/object$family$mu.eta(eta) # diag(G) w1 <- weights/(object$family$variance(mu)*g.deriv^2) # diag(W1) alpha <- 1+(y-mu)*(dv$dvar(mu)/object$family$variance(mu)+dg$d2link(mu)/g.deriv) # alpha elements of W w <- w1*alpha # diag(W) E <- matrix(0,q,q) diag(E) <- drop((C1diag*t(X))%*%(w1*g.deriv*(y-mu))) # diagonal elements of E abs.w <- abs(w) # absolute values of the diag(W) I.minus <- rep(0,nobs) # define diagonal elements of the matrix I^{-} I.minus[w<0] <- 1 wX1 <- sqrt(abs.w)[1:nobs]*X1 wX11 <- rbind(wX1,object$rS) # augmented model matrix ## Faster version only does SVD when needed (and then only on QR factor) illcond <- FALSE Q <- qr(wX11,LAPACK=TRUE) R <- qr.R(Q) rp <- 1:ncol(R) rp[Q$pivot] <- rp ## reverse pivot X=Q%*%R[,rp] R.out <- R[,rp] ## unpivoted R, needed for summary function rank <- Rrank(R) if (rank==ncol(R)) { ## no need to truncate, can just use QR R.inv <- backsolve(R,diag(ncol(R)))[rp,] ## inverse of unpivoted R tR.inv <- t(R.inv) } else { ## need SVD step R <- R[,rp] ## unpivoted R svd.r <- svd(R) d.inv <- rep(0,q) # initial vector of inverse singular values good <- svd.r$d >= max(svd.r$d)*.Machine$double.eps^.5 d.inv[good] <- 1/svd.r$d[good] if (sum(!good)>0) illcond <- TRUE R <- svd.r$d*t(svd.r$v) Q <- qr.qy(Q,rbind(svd.r$u,matrix(0,nobs,q))) ## this is inefficient don't need to extract Q really tR.inv <- d.inv*t(svd.r$v) # inverse of transpose of R R.inv <- t(tR.inv) } QtQRER <- tR.inv%*%(diag(E)*R.inv) if (sum(I.minus)>0) { if (is.qr(Q)) { QtQRER <- QtQRER + 2*crossprod(I.minus*qr.Q(Q)[1:nobs,]) } else { QtQRER <- QtQRER + 2*crossprod(I.minus*Q[1:nobs,]) } } ei <- eigen(QtQRER,symmetric=TRUE) # eigen-decomposition of QtQRER d <- ei$values # vector of eigenvalues ok1 <- sum(d>1)>0 if (ok1) { ## Fisher step in case of not positive semi-definiteness of penalized loglikelihood ## set alpha =1 ... wX1<-sqrt(w1)[1:nobs]*X1 wX11<-rbind(wX1,object$rS) Q <- qr(wX11,LAPACK=TRUE) R <- qr.R(Q) rp <- 1:ncol(R) rp[Q$pivot] <- rp ## reverse pivot X=Q%*%R[,rp] R.out <- R[,rp] ## unpivoted R, needed for summary function rank <- Rrank(R) if (rank==ncol(R)) { ## no need to truncate, can just use QR P <- backsolve(R,diag(ncol(R)))[rp,] K <- qr.Q(Q)[1:nobs,] } else { ## need SVD step R <- R[,rp] ## unpivoted R s1 <- svd(R) d.inv1 <- rep(0,q) good1 <- s1$d >= max(s1$d)*.Machine$double.eps^.5 d.inv1[good1] <- 1/s1$d[good1] P <- t(d.inv1*t(s1$v)) K <- qr.qy(Q,rbind(s1$u,matrix(0,nobs,q)))[1:nobs,] } } ## end of if (ok1) else { ## full Newton step Id.inv.r<-1/(1-d)^.5 # vector of inverse values of (1-sv)^1/2 ii <- (1-d) < .Machine$double.eps Id.inv.r[ii] <- 0 eidrop <- t(Id.inv.r*t(ei$vectors)) P <- R.inv%*%eidrop ## ei$vectors%*%diag(Id.inv.r) # define matrix P if (is.qr(Q)) { K <- qr.qy(Q,rbind(eidrop,matrix(0,nobs,q)))[1:nobs,] } else { K <- Q[1:nobs,]%*%eidrop ## (ei$vectors%*%diag(Id.inv.r)) # define matrix K } } ## end of if (!ok1) # end of calculation of the matrices at their converged values... ## calculating edf and trA... I.plus <- rep(1,nobs) # define diagonal elements of the matrix I^{+} I.plus[w<0] <- -1 L <- c(1/alpha) KtILQ1R <- crossprod(L*I.plus*K,wX1) ## t(object$L*object$I.plus*K)%*%object$wX1 F <- P%*%(KtILQ1R) edf <- diag(F) ## effective degrees of freedom edf1 <- 2*edf - rowSums(t(F)*F) ## alternative trA <- sum(edf) ## calculating the approximate covariance matrices ## (dealing with the expected Hessian of the log likelihood) ... ## get the inverse of the expected Hessian... if (!scale.known) sig2 <- dev/(nobs-trA) # scale estimate Vb <- tcrossprod(P) * sig2 ## P%*%t(P)*sig2 # Bayesian posterior covariance matrix for the parameters Ve <- crossprod(K%*%t(P)) *sig2 #PKt%*%t(PKt)*sig2 # covariance matrix of the parameter estimators ## Delta method to get covariance matrix for the reparametrized parameters... df.p <- rep(1,q) df.p[object$iv] <- object$beta.t[object$iv] Vb.t <- t(df.p*t(df.p*Vb)) Ve.t <- t(df.p*t(df.p*Ve)) ## eta <- as.numeric(G$X%*%object$beta.t + offset) ## mu <- linkinv(eta) # fitted values residuals <- rep.int(NA, nobs) g.deriv <- 1/object$family$mu.eta(eta) # diag(G) residuals <- (G$y-mu)*g.deriv # the working residuals for the fitted model aic.model <- object$family$aic(y, n, mu, weights, dev) + 2 * sum(edf) ## scam_1.2-15... std.rsd <- NULL if (G$AR1.rho!=0){ std.rsd <- AR.resid(residuals,G$AR1.rho,G$AR.start) ##standardised residuals for AR1 model (approximately uncorrelated under correct model) dev.st <- sum(std.rsd^2) ## dev <- sum(residuals^2) ## ss of the working residuals of the fitted model df <- if (is.null(G$AR.start)) 1 else sum(G$AR.start) aic.model <- object$family$aic(y, n, mu, weights, dev.st) + 2 * sum(edf) - 2*(n-df)*log(1/sqrt(1-G$AR1.rho^2)) } list (null.dev=null.dev, df.null=nulldf,Vb=Vb,Vb.t=Vb.t,Ve=Ve,Ve.t=Ve.t,rank=rank, sig2=sig2,edf=edf, edf1=edf1,trA=trA, deviance=dev,residuals=residuals, aic=aic.model, mu=mu, eta=eta, std.rsd=std.rsd) ## scam_1.2-15 } ## end of scam.fit.post ### the following three functions are for use in place of exp(beta) ### notExp(), from scam version 1.2-17, is a softplus function suggested by Jens Lichter, and as implemented in PyTorch, to ensure positivity when re-parameterizing scop-spline coefficients. ## 'for numerical stability the implementation reverts to the linear function when x*b > threshold ### DnotExp() calculates the first derivative ### D2notExp() gets the second derivative notExp <- function(x,b=1,threshold=20){ ## Softplus function, as implemented in PyTorch, ## https://pytorch.org/docs/stable/generated/torch.nn.Softplus.html ## 'for numerical stability the implementation reverts to the linear function when ## x*b > threshold f <- x ind <- x*b < threshold f[ind] <- 1/b*log(1+exp(b*x[ind])) f } DnotExp <- function(x,b=1,threshold=20) { ## first derivative of notExp()... f <- 1 ind <- x*b < threshold f[ind] <- exp(b*x[ind])/(1+exp(b*x[ind])) f } D2notExp <- function(x,b=1,threshold=20) { ## second derivative of notExp()... f <- 0 ind <- x*b < threshold f[ind] <- b*exp(b*x[ind])/(1+exp(b*x[ind]))^2 f } D3notExp <- function(x,b=1,threshold=20) { ## third derivative of notExp()... f <- 0 ind <- x*b < threshold f[ind] <- b^2*exp(b*x[ind])*(1-exp(2*b*x[ind]))/(1+exp(b*x[ind]))^4 f } ### the following three functions are for use in place of exp(beta) ### notExp0(), used up till scam version 1.2-16, is similar to that in R package mgcv() of Simon N Wood ### in positivity ensuring beta parameters re-parameterization.... they have `better' ### over/underflow characteristics, but is still continuous to second ### derivative. ### DnotExp0() calculates the first derivative ### D2notExp0() gets the second derivative notExp0 <- function(x){ f <- x ind <- x > 1 f[ind] <- exp(1)*(x[ind]^2+1)/2 ind <- (x <= 1)&(x > -1) f[ind] <- exp(x[ind]) ind <- (x <= -1) f[ind] <- exp(1)*(x[ind]^2+1)/2; f[ind]<-1/f[ind] f } DnotExp0 <- function(x) { ## first derivative of notExp()... f <- x ind <- x > 1 f[ind] <- exp(1)*x[ind] ind <- (x <= 1)&(x > -1) f[ind] <- exp(x[ind]) ind <- (x <= -1) f[ind] <- -4*x[ind]/exp(1)/(x[ind]^2+1)^2 f } D2notExp0 <- function(x) { ## second derivative of notExp()... f <- x ind <- x > 1 f[ind] <- exp(1) ind <- (x <= 1)&(x > -1) f[ind] <- exp(x[ind]) ind <- (x <= -1) f[ind] <- (12*x[ind]^2-4)/exp(1)/(x[ind]^2+1)^3 f } D3notExp0 <- function(x) { ## third derivative of notExp()... f <- x ind <- x > 1 f[ind] <- 0 ind <- (x <= 1)&(x > -1) f[ind] <- exp(x[ind]) ind <- (x <= -1) f[ind] <- 48*x[ind]*(1-x[ind]^2)/exp(1)/(x[ind]^2+1)^4 f } ## checking derivatives... #eps <- 1e-7 #x<-seq(-5,5,length.out=100) #d1 <- (notExp(x+eps)-notExp(x))/eps #range((DnotExp(x)-d1)/d1) #d2 <- (DnotExp(x+eps)-DnotExp(x))/eps #range((D2notExp(x)-d2)/d2) #d3 <- (D2notExp(x+eps)-D2notExp(x))/eps #range((D3notExp(x)-d3)/d3) logLik.scam <- function (object,...) { # based on logLik.gam and logLik.glm sc.p <- as.numeric(object$scale.estimated) ## 1 or 0 p <- sum(object$edf) + sc.p val <- p - object$aic/2 #if (fam %in% c("gaussian", "Gamma", "inverse.gaussian","Tweedie")) # p <- p + 1 np <- length(object$coefficients) + sc.p if (p > np) p <- np attr(val, "df") <- p class(val) <- "logLik" val } ## logLik.scam formula.scam <- function(x, ...) # clone of formula.gam... # formula.lm and formula.glm reconstruct the formula from x$terms, this is # problematic because of the way mgcv handles s() and te() terms { x$formula } vcov.scam <- function(object, freq = FALSE, untransformed=FALSE, ...) ## extracts the Bayesian posterior covariance matrix of the transformed ## (some exponentiated) parameters, object$Vp.t, or frequentist covariance matrix ## of the transformed parameter estimators, object$Ve.t, from a fitted scam object, or ## same for the un-transformed parameters, object$Ve, object$Vp { if (freq) vc <- if (untransformed) object$Ve else object$Ve.t else { vc <- if (untransformed) object$Vp else object$Vp.t } name <- names(object$edf) dimnames(vc) <- list(name, name) vc } ############################################################################################### ## below are functions from mgcv package, copied as they are not exported by 'namespace:mgcv' ## Copyright (c) Simon N. Wood 2008-2019 simon.wood@r-project.org ## gam.setup() has extra SCAM lines to update smooth$Zc matrix using 'del.index' to deal with ## identifiability: when two or more smooths have the same covariate... (c) natalya pya (2024) ## also SCAM stuff added on Zc, scam_1.2-15. ############################################################################################### gam.setup <- function(formula,pterms, data=stop("No data supplied to gam.setup"),knots=NULL,sp=NULL, min.sp=NULL,H=NULL,absorb.cons=TRUE,sparse.cons=0,select=FALSE,idLinksBases=TRUE, scale.penalty=TRUE,paraPen=NULL,gamm.call=FALSE,drop.intercept=FALSE, diagonal.penalty=FALSE,apply.by=TRUE,list.call=FALSE,modCon=0) ## set up the model matrix, penalty matrices and auxilliary information about the smoothing bases ## needed for a gam fit. ## elements of returned object: ## * m - number of smooths ## * min.sp - minimum smoothing parameters ## * H supplied H matrix ## * pearson.extra, dev.extra, n.true --- entries to hold these quantities ## * pterms - terms object for parametric terms ## * intercept TRUE if intercept present ## * offset - the model offset ## * nsdf - number of strictly parameteric coefs ## * contrasts ## * xlevels - records levels of factors ## * assign - indexes which parametric model matrix columns map to which term in pterms ## * smooth - list of smooths ## * S - penalties (non-zero block only) ## * off - first coef penalized by each element of S ## * cmX - col mean of X ## * P - maps parameters in fit constraint parameterization to those in prediction parameterization ## * X - model matrix ## * sp ## * rank ## * n.paraPen ## * L ## * lsp0 ## * y - response ## * C - constraint matrix - only if absorb.cons==FALSE ## * n - dim(y) ## * w - weights ## * term.names ## * nP { # split the formula if the object being passed is a formula, otherwise it's already split if (inherits(formula,"split.gam.formula")) split <- formula else if (inherits(formula,"formula")) split <- interpret.gam(formula) else stop("First argument is no sort of formula!") if (length(split$smooth.spec)==0) { if (split$pfok==0) stop("You've got no model....") m <- 0 } else m <- length(split$smooth.spec) # number of smooth terms G <- list(m=m,min.sp=min.sp,H=H,pearson.extra=0, dev.extra=0,n.true=-1,pterms=pterms) ## dev.extra gets added to deviance if REML/ML used in gam.fit3 if (is.null(attr(data,"terms"))) # then data is not a model frame mf <- model.frame(split$pf,data,drop.unused.levels=FALSE) # must be false or can end up with wrong prediction matrix! else mf <- data # data is already a model frame G$intercept <- attr(attr(mf,"terms"),"intercept")>0 ## get any model offset. Complicated by possibility of offsets in multiple formulae... if (list.call) { offi <- attr(pterms,"offset") if (!is.null(offi)) { G$offset <- mf[[names(attr(pterms,"dataClasses"))[offi]]] } } else G$offset <- model.offset(mf) # get any model offset including from offset argument if (!is.null(G$offset)) G$offset <- as.numeric(G$offset) # construct strictly parametric model matrix.... if (drop.intercept) attr(pterms,"intercept") <- 1 ## ensure there is an intercept to drop X <- model.matrix(pterms,mf) if (drop.intercept) { ## some extended families require intercept to be dropped xat <- attributes(X);ind <- xat$assign>0 ## index of non intercept columns X <- X[,ind,drop=FALSE] ## some extended families need to drop intercept xat$assign <- xat$assign[ind];xat$dimnames[[2]]<-xat$dimnames[[2]][ind]; xat$dim[2] <- xat$dim[2]-1;attributes(X) <- xat G$intercept <- FALSE } rownames(X) <- NULL ## save memory G$nsdf <- ncol(X) G$contrasts <- attr(X,"contrasts") G$xlevels <- .getXlevels(pterms,mf) G$assign <- attr(X,"assign") # used to tell which coeffs relate to which pterms ## now deal with any user supplied penalties on the parametric part of the model... PP <- parametricPenalty(pterms,G$assign,paraPen,sp) if (!is.null(PP)) { ## strip out supplied sps already used ind <- 1:length(PP$sp) if (!is.null(sp)) sp <- sp[-ind] if (!is.null(min.sp)) { PP$min.sp <- min.sp[ind] min.sp <- min.sp[-ind] } } # next work through smooth terms (if any) extending model matrix..... G$smooth <- list() G$S <- list() if (gamm.call) { ## flag that this is a call from gamm --- some smoothers need to know! if (m>0) for (i in 1:m) attr(split$smooth.spec[[i]],"gamm") <- TRUE } if (m>0 && idLinksBases) { ## search smooth.spec[[]] for terms linked by common id's id.list <- list() ## id information list for (i in 1:m) if (!is.null(split$smooth.spec[[i]]$id)) { id <- as.character(split$smooth.spec[[i]]$id) if (length(id.list)&&id%in%names(id.list)) { ## it's an existing id ni <- length(id.list[[id]]$sm.i) ## number of terms so far with this id id.list[[id]]$sm.i[ni+1] <- i ## adding smooth.spec index to this id's list ## clone smooth.spec from base smooth spec.... base.i <- id.list[[id]]$sm.i[1] split$smooth.spec[[i]] <- clone.smooth.spec(split$smooth.spec[[base.i]], split$smooth.spec[[i]]) ## add data for this term to the data list for basis setup... temp.term <- split$smooth.spec[[i]]$term ## note cbind deliberate in next line, as construction will handle matrix argument ## correctly... for (j in 1:length(temp.term)) id.list[[id]]$data[[j]] <- cbind(id.list[[id]]$data[[j]], get.var(temp.term[j],data,vecMat=FALSE)) } else { ## new id id.list[[id]] <- list(sm.i=i) ## start the array of indices of smooths with this id id.list[[id]]$data <- list() ## need to collect together all data for which this basis will be used, ## for basis setup... term <- split$smooth.spec[[i]]$term for (j in 1:length(term)) id.list[[id]]$data[[j]] <- get.var(term[j],data,vecMat=FALSE) } ## new id finished } } ## id.list complete G$off<-array(0,0) first.para<-G$nsdf+1 sm <- list() newm <- 0 if (m>0) for (i in 1:m) { # idea here is that terms are set up in accordance with information given in split$smooth.spec # appropriate basis constructor is called depending on the class of the smooth # constructor returns penalty matrices model matrix and basis specific information id <- split$smooth.spec[[i]]$id if (is.null(id)||!idLinksBases) { ## regular evaluation sml <- smoothCon(split$smooth.spec[[i]],data,knots,absorb.cons,scale.penalty=scale.penalty, null.space.penalty=select,sparse.cons=sparse.cons, diagonal.penalty=diagonal.penalty,apply.by=apply.by,modCon=modCon) } else { ## it's a smooth with an id, so basis setup data differs from model matrix data names(id.list[[id]]$data) <- split$smooth.spec[[i]]$term ## give basis data suitable names sml <- smoothCon(split$smooth.spec[[i]],id.list[[id]]$data,knots, absorb.cons,n=nrow(data),dataX=data,scale.penalty=scale.penalty, null.space.penalty=select,sparse.cons=sparse.cons, diagonal.penalty=diagonal.penalty,apply.by=apply.by,modCon=modCon) } for (j in 1:length(sml)) { newm <- newm + 1 sm[[newm]] <- sml[[j]] } } G$m <- m <- newm ## number of actual smooths ## at this stage, it is neccessary to impose any side conditions required ## for identifiability if (m>0) { sm <- gam.side(sm,X,tol=.Machine$double.eps^.5) if (!apply.by) for (i in 1:length(sm)) { ## restore any by-free model matrices if (!is.null(sm[[i]]$X0)) { ## there is a by-free matrix to restore ind <- attr(sm[[i]],"del.index") ## columns, if any to delete sm[[i]]$X <- if (is.null(ind)) sm[[i]]$X0 else sm[[i]]$X0[,-ind,drop=FALSE] } } } ## The matrix, L, mapping the underlying log smoothing parameters to the ## log of the smoothing parameter multiplying the S[[i]] must be ## worked out... idx <- list() ## idx[[id]]$c contains index of first col in L relating to id L <- matrix(0,0,0) lsp.names <- sp.names <- rep("",0) ## need a list of names to identify sps in global sp array if (m>0) for (i in 1:m) { id <- sm[[i]]$id ## get the L matrix for this smooth... length.S <- length(sm[[i]]$S) if (is.null(sm[[i]]$L)) Li <- diag(length.S) else Li <- sm[[i]]$L if (length.S > 0) { ## there are smoothing parameters to name if (length.S == 1) lspn <- sm[[i]]$label else { Sname <- names(sm[[i]]$S) lspn <- if (is.null(Sname)) paste(sm[[i]]$label,1:length.S,sep="") else paste(sm[[i]]$label,Sname,sep="") ## names for all sp's } spn <- lspn[1:ncol(Li)] ## names for actual working sps } ## extend the global L matrix... if (is.null(id)||is.null(idx[[id]])) { ## new `id' if (!is.null(id)) { ## create record in `idx' idx[[id]]$c <- ncol(L)+1 ## starting column in L for this `id' idx[[id]]$nc <- ncol(Li) ## number of columns relating to this `id' } L <- rbind(cbind(L,matrix(0,nrow(L),ncol(Li))), cbind(matrix(0,nrow(Li),ncol(L)),Li)) if (length.S > 0) { ## there are smoothing parameters to name sp.names <- c(sp.names,spn) ## extend the sp name vector lsp.names <- c(lsp.names,lspn) ## extend full.sp name vector } } else { ## it's a repeat id => shares existing sp's L0 <- matrix(0,nrow(Li),ncol(L)) if (ncol(Li)>idx[[id]]$nc) { stop("Later terms sharing an `id' can not have more smoothing parameters than the first such term") } L0[,idx[[id]]$c:(idx[[id]]$c+ncol(Li)-1)] <- Li L <- rbind(L,L0) if (length.S > 0) { ## there are smoothing parameters to name lsp.names <- c(lsp.names,lspn) ## extend full.sp name vector } } } ## create the model matrix... Xp <- NULL ## model matrix under prediction constraints, if given if (m>0) for (i in 1:m) { n.para<-ncol(sm[[i]]$X) # define which elements in the parameter vector this smooth relates to.... sm[[i]]$first.para<-first.para first.para<-first.para+n.para sm[[i]]$last.para<-first.para-1 ## termwise offset handling ... Xoff <- attr(sm[[i]]$X,"offset") if (!is.null(Xoff)) { if (is.null(G$offset)) G$offset <- Xoff else G$offset <- G$offset + Xoff } ## model matrix accumulation ... ## alternative version under alternative constraint first (prediction only) if (is.null(sm[[i]]$Xp)) { if (!is.null(Xp)) Xp <- cbind2(Xp,sm[[i]]$X) } else { if (is.null(Xp)) Xp <- X Xp <- cbind2(Xp,sm[[i]]$Xp);sm[[i]]$Xp <- NULL } ## now version to use for fitting ... X <- cbind2(X,sm[[i]]$X);sm[[i]]$X<-NULL G$smooth[[i]] <- sm[[i]] } if (is.null(Xp)) { G$cmX <- colMeans(X) ## useful for componentwise CI construction } else { G$cmX <- colMeans(Xp) ## transform from fit params to prediction params... ## G$P <- qr.coef(qr(Xp),X) ## old code assumes always full rank!! qrx <- qr(Xp,LAPACK=TRUE) R <- qr.R(qrx) p <- ncol(R) rank <- Rrank(R) ## rank of Xp/R QtX <- qr.qty(qrx,X)[1:rank,] if (rank0) G$cmX[-(1:G$nsdf)] <- 0 ## zero the smooth parts here #else G$cmX <- G$cmX * 0 G$X <- X;rm(X) n.p <- ncol(G$X) # deal with penalties ## min.sp must be length nrow(L) to make sense ## sp must be length ncol(L) --- need to partition ## L into columns relating to free log smoothing parameters, ## and columns, L0, corresponding to values supplied in sp. ## lsp0 = L0%*%log(sp[sp>=0]) [need to fudge sp==0 case by ## setting log(0) to log(effective zero) computed case-by-case] ## following deals with supplied and estimated smoothing parameters... ## first process the `sp' array supplied to `gam'... if (!is.null(sp)) { # then user has supplied fixed smoothing parameters ok <- TRUE if (length(sp) < ncol(L)) { warning("Supplied smoothing parameter vector is too short - ignored.") ok <- FALSE } if (sum(is.na(sp))) { warning("NA's in supplied smoothing parameter vector - ignoring.") ok <- FALSE } } else ok <- FALSE G$sp <- if (ok) sp[1:ncol(L)] else rep(-1,ncol(L)) names(G$sp) <- sp.names ## now work through the smooths searching for any `sp' elements ## supplied in `s' or `te' terms.... This relies on `idx' created ## above... k <- 1 ## current location in `sp' array if (m>0) for (i in 1:m) { id <- sm[[i]]$id if (is.null(sm[[i]]$L)) Li <- diag(length(sm[[i]]$S)) else Li <- sm[[i]]$L if (is.null(id)) { ## it's a smooth without an id spi <- sm[[i]]$sp if (!is.null(spi)) { ## sp supplied in `s' or `te' if (length(spi)!=ncol(Li)) stop("incorrect number of smoothing parameters supplied for a smooth term") G$sp[k:(k+ncol(Li)-1)] <- spi } k <- k + ncol(Li) } else { ## smooth has an id spi <- sm[[i]]$sp if (is.null(idx[[id]]$sp.done)) { ## not already dealt with these sp's if (!is.null(spi)) { ## sp supplied in `s' or `te' if (length(spi)!=ncol(Li)) stop("incorrect number of smoothing parameters supplied for a smooth term") G$sp[idx[[id]]$c:(idx[[id]]$c+idx[[id]]$nc-1)] <- spi } idx[[id]]$sp.done <- TRUE ## only makes sense to use supplied `sp' from defining term k <- k + idx[[id]]$nc } } } ## finished processing `sp' vectors supplied in `s' or `te' terms ## copy initial sp's back into smooth objects, so there is a record of ## fixed and free... k <- 1 if (length(idx)) for (i in 1:length(idx)) idx[[i]]$sp.done <- FALSE if (m>0) for (i in 1:m) { ## work through all smooths id <- sm[[i]]$id if (!is.null(id)) { ## smooth with id if (idx[[id]]$nc>0) { ## only copy if there are sp's G$smooth[[i]]$sp <- G$sp[idx[[id]]$c:(idx[[id]]$c+idx[[id]]$nc-1)] } if (!idx[[id]]$sp.done) { ## only update k on first encounter with this smooth idx[[id]]$sp.done <- TRUE k <- k + idx[[id]]$nc } } else { ## no id, just work through sp if (is.null(sm[[i]]$L)) nc <- length(sm[[i]]$S) else nc <- ncol(sm[[i]]$L) if (nc>0) G$smooth[[i]]$sp <- G$sp[k:(k+nc-1)] k <- k + nc } } ## now all elements of G$smooth have a record of initial sp. if (!is.null(min.sp)) { # then minimum s.p.'s supplied if (length(min.sp)0) for (i in 1:m) { sm<-G$smooth[[i]] if (length(sm$S)>0) for (j in 1:length(sm$S)) { # work through penalty matrices k.sp <- k.sp+1 G$off[k.sp] <- sm$first.para G$S[[k.sp]] <- sm$S[[j]] G$rank[k.sp]<-sm$rank[j] if (!is.null(min.sp)) { if (is.null(H)) H<-matrix(0,n.p,n.p) H[sm$first.para:sm$last.para,sm$first.para:sm$last.para] <- H[sm$first.para:sm$last.para,sm$first.para:sm$last.para]+min.sp[k.sp]*sm$S[[j]] } } } ## need to modify L, lsp.names, G$S, G$sp, G$rank and G$off to include any penalties ## on parametric stuff, at this point.... if (!is.null(PP)) { ## deal with penalties on parametric terms L <- rbind(cbind(L,matrix(0,nrow(L),ncol(PP$L))), cbind(matrix(0,nrow(PP$L),ncol(L)),PP$L)) G$off <- c(PP$off,G$off) G$S <- c(PP$S,G$S) G$rank <- c(PP$rank,G$rank) G$sp <- c(PP$sp,G$sp) lsp.names <- c(PP$full.sp.names,lsp.names) G$n.paraPen <- length(PP$off) if (!is.null(PP$min.sp)) { ## deal with minimum sps if (is.null(H)) H <- matrix(0,n.p,n.p) for (i in 1:length(PP$S)) { ind <- PP$off[i]:(PP$off[i]+ncol(PP$S[[i]])-1) H[ind,ind] <- H[ind,ind] + PP$min.sp[i] * PP$S[[i]] } } ## min.sp stuff finished } else G$n.paraPen <- 0 ## Now remove columns of L and rows of sp relating to fixed ## smoothing parameters, and use removed elements to create lsp0 fix.ind <- G$sp>=0 if (sum(fix.ind)) { lsp0 <- G$sp[fix.ind] ind <- lsp0==0 ## find the zero s.p.s ef0 <- indi <- (1:length(ind))[ind] if (length(indi)>0) for (i in 1:length(indi)) { ## find "effective zero" to replace each zero s.p. with ii <- G$off[i]:(G$off[i]+ncol(G$S[[i]])-1) ef0[i] <- norm(G$X[,ii],type="F")^2/norm(G$S[[i]],type="F")*.Machine$double.eps*.1 } lsp0[!ind] <- log(lsp0[!ind]) lsp0[ind] <- log(ef0) ##log(.Machine$double.xmin)*1000 ## zero fudge lsp0 <- as.numeric(L[,fix.ind,drop=FALSE]%*%lsp0) L <- L[,!fix.ind,drop=FALSE] G$sp <- G$sp[!fix.ind] } else {lsp0 <- rep(0,nrow(L))} G$H <- H if (ncol(L)==nrow(L)&&!sum(L!=diag(ncol(L)))) L <- NULL ## it's just the identity G$L <- L;G$lsp0 <- lsp0 names(G$lsp0) <- lsp.names ## names of all smoothing parameters (not just underlying) if (absorb.cons==FALSE) { ## need to accumulate constraints G$C <- matrix(0,0,n.p) if (m>0) { for (i in 1:m) { if (is.null(G$smooth[[i]]$C)) n.con<-0 else n.con<- nrow(G$smooth[[i]]$C) C <- matrix(0,n.con,n.p) C[,G$smooth[[i]]$first.para:G$smooth[[i]]$last.para]<-G$smooth[[i]]$C G$C <- rbind(G$C,C) G$smooth[[i]]$C <- NULL } rm(C) } } ## absorb.cons == FALSE ## SCAM stuff added here, scam_1.2-15... if (m>0) for (i in 1:m) { if (!is.null(G$smooth[[i]]$Zc)) { ind <- attr(G$smooth[[i]],"del.index") G$smooth[[i]]$Zc <- if (!is.null(ind)) G$smooth[[i]]$Zc[-ind,-ind,drop=FALSE] ##need to check if removing "del.index" rows is correct else G$smooth[[i]]$Zc } } ## end of scam stuff G$y <- data[[split$response]] ##data[[deparse(split$full.formula[[2]],backtick=TRUE)]] G$n <- nrow(data) if (is.null(data$"(weights)")) G$w <- rep(1,G$n) else G$w <- data$"(weights)" ## Create names for model coefficients... if (G$nsdf > 0) term.names <- colnames(G$X)[1:G$nsdf] else term.names<-array("",0) n.smooth <- length(G$smooth) if (n.smooth) ## create coef names, if smooth has any coefs, and create a global indicator of non-linear parameters ## g.index, if needed for (i in 1:n.smooth) { k <- 1 jj <- G$smooth[[i]]$first.para:G$smooth[[i]]$last.para if (G$smooth[[i]]$df > 0) for (j in jj) { term.names[j] <- paste(G$smooth[[i]]$label,".",as.character(k),sep="") k <- k+1 } if (!is.null(G$smooth[[i]]$g.index)) { if (is.null(G$g.index)) G$g.index <- rep(FALSE,n.p) G$g.index[jj] <- G$smooth[[i]]$g.index } } G$term.names <- term.names ## Deal with non-linear parameterizations... G$pP <- PP ## return paraPen object, if present G } ## gam.setup ## of (c) Simon N. Wood added in scam version 1.2-19 to fix gaussian(link="log") initialization so that negative data does not make it fail... fix.family <- function(fam) { ## allows families to be patched... if (fam$family[1]=="gaussian") { ## sensible starting values given link... fam$initialize <- expression({ n <- rep.int(1, nobs) if (family$link == "inverse") mustart <- y + (y==0)*sd(y)*.01 else if (family$link == "log") mustart <- pmax(y,.01*sd(y)) else mustart <- y }) } fam } ## fix.family clone.smooth.spec <- function(specb,spec) { ## produces a version of base smooth.spec, `specb', but with ## the variables relating to `spec'. Used by `gam.setup' in handling ## of linked smooths. ## check dimensions same... if (specb$dim!=spec$dim) stop("`id' linked smooths must have same number of arguments") ## Now start cloning... if (inherits(specb,c("tensor.smooth.spec","t2.smooth.spec"))) { ##`te' or `t2' generated base smooth.spec specb$term <- spec$term specb$label <- spec$label specb$by <- spec$by k <- 1 for (i in 1:length(specb$margin)) { if (is.null(spec$margin)) { ## sloppy user -- have to construct margin info... for (j in 1:length(specb$margin[[i]]$term)) { specb$margin[[i]]$term[j] <- spec$term[k] k <- k + 1 } specb$margin[[i]]$label <- "" } else { ## second term was at least `te'/`t2', so margin cloning is easy specb$margin[[i]]$term <- spec$margin[[i]]$term specb$margin[[i]]$label <- spec$margin[[i]]$label specb$margin[[i]]$xt <- spec$margin[[i]]$xt } } } else { ## `s' generated case specb$term <- spec$term specb$label <- spec$label specb$by <- spec$by specb$xt <- spec$xt ## don't generally know what's in here => don't clone } specb ## return clone } ## clone.smooth.spec allvars1 <- function(form) { ## version of all.vars that doesn't split up terms like x$y into x and y vars <- all.vars(form) vn <- all.names(form) vn <- vn[vn%in%c(vars,"$","[[")] ## actual variable related names if ("[["%in%vn) stop("can't handle [[ in formula") ii <- which(vn%in%"$") ## index of '$' if (length(ii)) { ## assemble variable names vn1 <- if (ii[1]>1) vn[1:(ii[1]-1)] go <- TRUE k <- 1 while (go) { n <- 2; while(k=n) { k <- k+1 v.name[k] <- v.name1[i] ## save names of variables of correct length } if (k>0) v.name <- v.name[1:k] else v.name <- rep("",k) } ## v.name <- names(dl) ## the variable names p.name <- all.vars(pf[-2]) ## variables in parametric part (not response) vs <- list() v.n <- length(v.name) if (v.n>0) for (i in 1:v.n) { if (v.name[i]%in%p.name) para <- TRUE else para <- FALSE ## is variable in the parametric part? if (para&&is.matrix(dl[[v.name[i]]])&&ncol(dl[[v.name[i]]])>1) { ## parametric matrix --- a special case x <- matrix(apply(dl[[v.name[i]]],2,quantile,probs=0.5,type=3,na.rm=TRUE),1,ncol(dl[[v.name[i]]])) ## nearest to median entries } else { ## anything else x <- dl[[v.name[i]]] if (is.character(x)) x <- as.factor(x) if (is.factor(x)) { x <- x[!is.na(x)] lx <- levels(x) freq <- tabulate(x) ii <- min((1:length(lx))[freq==max(freq)]) x <- factor(lx[ii],levels=lx) } else { x <- as.numeric(x) x <- c(min(x,na.rm=TRUE),as.numeric(quantile(x,probs=.5,type=3,na.rm=TRUE)) ,max(x,na.rm=TRUE)) ## 3 figure summary } } vs[[v.name[i]]] <- x } vs } ## end variable.summary parametricPenalty <- function(pterms,assign,paraPen,sp0) { ## routine to process any penalties on the parametric part of the model. ## paraPen is a list whose items have names corresponding to the ## term.labels in pterms. Each list item may have named elements ## L, rank and sp. All other elements should be penalty coefficient matrices. S <- list() ## penalty matrix list off <- rep(0,0) ## offset array rank <- rep(0,0) ## rank array sp <- rep(0,0) ## smoothing param array full.sp.names <- rep("",0) ## names for sp's multiplying penalties (not underlying) L <- matrix(0,0,0) k <- 0 tind <- unique(assign) ## unique term indices n.t <- length(tind) if (n.t>0) for (j in 1:n.t) if (tind[j]>0) { term.label <- attr(pterms[tind[j]],"term.label") P <- paraPen[[term.label]] ## get any penalty information for this term if (!is.null(P)) { ## then there is information ind <- (1:length(assign))[assign==tind[j]] ## index of coefs involved here Li <- P$L;P$L <- NULL spi <- P$sp;P$sp <- NULL ranki <- P$rank;P$rank <- NULL ## remaining terms should be penalty matrices... np <- length(P) if (!is.null(ranki)&&length(ranki)!=np) stop("`rank' has wrong length in `paraPen'") if (np) for (i in 1:np) { ## unpack penalty matrices, offsets and ranks k <- k + 1 S[[k]] <- P[[i]] off[k] <- min(ind) ## index of first coef penalized by this term if ( ncol(P[[i]])!=nrow(P[[i]])||nrow(P[[i]])!=length(ind)) stop(" a parametric penalty has wrong dimension") if (is.null(ranki)) { ev <- eigen(S[[k]],symmetric=TRUE,only.values=TRUE)$values rank[k] <- sum(ev>max(ev)*.Machine$double.eps*10) ## estimate rank } else rank[k] <- ranki[i] } ## now deal with L matrices if (np) { ## only do this stuff if there are any penalties! if (is.null(Li)) Li <- diag(np) if (nrow(Li)!=np) stop("L has wrong dimension in `paraPen'") L <- rbind(cbind(L,matrix(0,nrow(L),ncol(Li))), cbind(matrix(0,nrow(Li),ncol(L)),Li)) ind <- (length(sp)+1):(length(sp)+ncol(Li)) ind2 <- (length(sp)+1):(length(sp)+nrow(Li)) ## used to produce names for full sp array if (is.null(spi)) { sp[ind] <- -1 ## auto-initialize } else { if (length(spi)!=ncol(Li)) stop("`sp' dimension wrong in `paraPen'") sp[ind] <- spi } ## add smoothing parameter names.... if (length(ind)>1) names(sp)[ind] <- paste(term.label,ind-ind[1]+1,sep="") else names(sp)[ind] <- term.label if (length(ind2)>1) full.sp.names[ind2] <- paste(term.label,ind2-ind2[1]+1,sep="") else full.sp.names[ind2] <- term.label } } ## end !is.null(P) } ## looped through all terms if (k==0) return(NULL) if (!is.null(sp0)) { if (length(sp0) C indices oo <-.C(C_rwMatrix,as.integer(stop),as.integer(row),as.double(weight),X=as.double(X), as.integer(n),as.integer(p),trans=as.integer(trans),work=as.double(rep(0,n*p))) if (ok) return(matrix(oo$X,n,p)) else return(oo$X) } ## rwMatrix AR.resid <- function(rsd,rho=0,AR.start=NULL) { ## standardised residuals for AR1 model if (rho==0) return(rsd) ld <- 1/sqrt(1-rho^2) ## leading diagonal of root inverse correlation sd <- -rho*ld ## sub diagonal N <- length(rsd) ## see rwMatrix() for how following are used... ar.row <- c(1,rep(1:N,rep(2,N))[-c(1,2*N)]) ## index of rows to reweight ar.weight <- c(1,rep(c(sd,ld),N-1)) ## row weights ar.stop <- c(1,1:(N-1)*2+1) ## (stop[i-1]+1):stop[i] are the rows to reweight to get ith row if (!is.null(AR.start)) { ## need to correct the start of new AR sections... ii <- which(AR.start==TRUE) if (length(ii)>0) { if (ii[1]==1) ii <- ii[-1] ## first observation does not need any correction ar.weight[ii*2-2] <- 0 ## zero sub diagonal ar.weight[ii*2-1] <- 1 ## set leading diagonal to 1 } } rwMatrix(ar.stop,ar.row,ar.weight,rsd) } ## AR.resid scam/R/scam.check.R0000644000176200001440000001531015073147454013532 0ustar liggesusers## (c) Natalya Pya (2012-2025). Provided under GPL 2. ## routines for checking scam()... ## based on gam.check routines (c) Simon N Wood ## (2024) qq.scam() added as a short version of qq.gam (c) Simon N Wood ## (2025) randomized quantile residuals plots added scam.check <- function(b,type=c("deviance","rquantile","pearson","response"),old.style=FALSE, pch=".", setseed=NULL, ## setseed can be passed to get randomized quantile residuals ## arguments passed to qq.scam(): rep=0, level=.9, rl.col=3, rep.col="gray80", ...) ## takes a fitted scam object and produces some standard diagnostic plots { ## old.par<-par(mfrow=c(2,2)) if (is.null(.Platform$GUI) || .Platform$GUI != "RStudio") old.par <- par(mfrow=c(2,2)) sc.name<-b$method type <- match.arg(type) ylab <- paste(type,"residuals") resid <- residuals(b,type=type, setseed=setseed) if (type == "rquantile"){ ## normal QQ plot for quantile residuals... qqnorm(resid, main="Normal Q-Q plot", pch=pch, xlab = "theoretical quantiles", ylab = "sample quantiles", plot.it = TRUE, frame.plot = TRUE) qqline(resid,col=rl.col,...) } else { ## deviance residuals plots... if (old.style){ qqnorm(resid,pch=pch,ylab=ylab,...) qqline(resid,col=rl.col,...) } else qq.scam(b, rep=rep, level=level, type=type, rl.col=rl.col, rep.col=rep.col, ...) } plot(b$linear.predictors,resid,main="Resids vs. linear pred.", xlab="linear predictor",ylab=ylab,...) # ylab="residuals" hist(resid,xlab=ylab,ylab="frequency", main="Histogram of residuals",...) # xlab="residuals" plot(fitted(b),b$y,xlab="fitted values",ylab="response",main="Response vs. Fitted Values",...) ## now summarize convergence information cat("\nMethod:", b$method, " Optimizer:", b$optimizer) if (b$optimizer[1] == "optim"){ cat("\nOptim Method:", b$optim.method[1]) if (is.na(b$optim.method[2])) cat("\n Finite-difference approximation of the GCV/UBRE gradient was used.") } if (!is.null(b$bfgs.info)) { ## summarize BFGS convergence information boi <- b$bfgs.info cat("\nNumber of iterations of smoothing parameter selection performed was",boi$iter,".") cat("\n",boi$conv,".",sep="") cat("\nGradient range: [",min(boi$grad),",",max(boi$grad),"]",sep="") cat("\n(score ",formatC(b$gcv.ubre, digits = 5)," & scale ",formatC(b$sig2, digits = 5),")",sep="") } else if (!is.null(b$optim.info)) { ## summarize optim() convergence information boi <- b$optim.info cat("\nNumber of iterations of smoothing parameter selection performed was",boi$iter[1],".") cat("\n",boi$conv,".",sep="") cat("\n(score ",formatC(b$gcv.ubre, digits = 5)," & scale ",formatC(b$sig2, digits = 5),")",sep="") } else if (!is.null(b$nlm.info)) { ## summarize nlm() convergence information boi <- b$nlm.info cat("\nNumber of iterations of smoothing parameter selection performed was",boi$iter,".") cat("\n",boi$conv,".",sep="") cat("\nGradient range: [",min(boi$grad),",",max(boi$grad),"]",sep="") cat("\n(score ",formatC(b$gcv.ubre, digits = 5)," & scale ",formatC(b$sig2, digits = 5),")",sep="") } else if (!is.null(b$efs.info)) { ## summarize 'efs' convergence information boi <- b$efs.info cat("\nNumber of iterations of smoothing parameter selection performed was",boi$iter[1],".") cat("\n",boi$conv,".",sep="") cat("\n(score ",formatC(b$gcv.ubre, digits = 5)," & scale ",formatC(b$sig2, digits = 5),")",sep="") } else { if (length(b$sp)==0) ## no sp's estimated cat("\nModel required no smoothing parameter selection") } ## print the estimated smoothing parameters... if (length(b$sp)!=0) cat("\nThe optimal smoothing parameter(s):",round(b$sp,5),".") cat("\n") par(old.par) } qq.scam <- function(object, rep=0, level=.9,s.rep=10, type=c("deviance","pearson","response"), pch=".", rl.col=3, rep.col="gray80",...) { ## get deviance residual quantiles under good fit type <- match.arg(type) ylab <- paste(type,"residuals") if (inherits(object,c("glm","scam"))) { if (is.null(object$sig2)) object$sig2 <- summary(object)$dispersion } else stop("object is not a glm or scam") ## in case of NA & na.action="na.exclude", we need the "short" residuals: object$na.action <- NULL D <- residuals(object,type=type) lim <- Dq <- NULL if (rep==0) { fam <- fix.family.qf(object$family) if (is.null(fam$qf)) rep <- 50 ## try simulation if quantile function not available level <- 0 } n <- length(D) if (rep > 0) { ## simulate quantiles fam <- fix.family.rd(object$family) if (!is.null(fam$rd)) { ##d <- rep(0,0) ## simulate deviates... dm <- matrix(0,n,rep) for (i in 1:rep) { yr <- fam$rd(object$fitted.values, object$prior.weights, object$sig2) #di <- fam$dev.resids(yr,object$fitted.values,object$prior.weights)^.5* # sign(yr-object$fitted.values) object$y <- yr dm[,i] <- sort(residuals(object,type=type)) #d <- c(d,sort(di)) } # n <- length(D) Dq <- quantile(as.numeric(dm),(1:n - .5)/n) ## now get simulation limits on QQ plot #dm <- matrix(d,length(Dq),rep) alpha <- (1-level)/2 if (alpha>.5||alpha<0) alpha <- .05 if (level>0&&level<1) lim <- apply(dm,1,FUN=quantile,p=c(alpha,1-alpha)) else if (level >= 1) lim <- level } } else { U <- (1:n-.5)/n if (!is.null(fam$qf)) { dm <- matrix(0,n,s.rep) for (i in 1:s.rep) { U <- sample(U,n) ## randomize uniform quantiles w.r.t. obs q0 <- fam$qf(U,object$fitted.values,object$prior.weights,object$sig2) object$y <- q0 dm[,i] <- sort(residuals(object,type=type)) ## original proposal } Dq <- sort(rowMeans(dm)) } } if (!is.null(Dq)) { qqplot(Dq,D,ylab=ylab,xlab="theoretical quantiles",ylim=range(c(lim,D)), pch=pch,...) abline(0,1,col=rl.col) if (!is.null(lim)) { if (level>=1) for (i in 1:rep) lines(Dq,dm[,i],col=rep.col) else { n <- length(Dq) polygon(c(Dq,Dq[n:1],Dq[1]),c(lim[1,],lim[2,n:1],lim[1,1]),col=rep.col,border=NA) } abline(0,1,col=rl.col) } points(Dq,sort(D),pch=pch,...) return(invisible(Dq)) } else qqnorm(D,ylab=ylab,pch=pch,...) } ## qq.scam scam/R/residuals.scam.R0000644000176200001440000001322215073164570014446 0ustar liggesusers## (c) Natalya Pya (2012-2025). Provided under GPL 2. ## similar to residuals.gam() (c) Simon N Wood.... ## (2025) added quantile residuals in version 1.2-20... residuals.scam <-function(object, type = c("deviance", "pearson","scaled.pearson", "working", "response", "rquantile"),setseed=NULL, ...) # calculates residuals for scam object the same as residulas.gam(), but from version 1.2-20 includes (randomized) quantile residuals... { type <- match.arg(type) y <- object$y mu <- object$fitted.values y.mu <- y-mu ## family <- object$family wts <- object$prior.weights res<- switch(type, working = object$residuals, scaled.pearson = y.mu*wts^.5/sqrt(object$sig2*object$family$variance(mu)), pearson = y.mu*wts^.5/sqrt(object$family$variance(mu)), deviance = { d.res <- sqrt(pmax(object$family$dev.resids(y,mu,wts),0)) ifelse(y>mu , d.res, -d.res) }, response = y.mu, rquantile = rquantile.residuals(y=y,fv=mu, wt=wts, scale=object$sig2, family=object$family,setseed=setseed) ) res <- naresid(object$na.action,res) res } ## based on residuals routines (c) Gavin L. Simpson r package gratia and (c) Mikis Stasinopoulos et al r package gamlss... rquantile.residuals <- function(y, fv, wt, scale, family,setseed=NULL) ## calculates non-randomized quantile residuals for continuous distributions ## and randomized quantile residuals for discrete distributions (Dunn and Smyth, 1996; Feng et al. 2020)... ## y - observed response, fv - fitted values, wt - prior weights, scale - dispersion or scale ## setseed allows to set seeds { if (is.null(family$cdf)) { family <- add.family.cdf(family) } # if it's still NULL... if (is.null(family$cdf)) { stop("Quantile residuals are not available for this family.") } cdf <- family$cdf(q=y, mu=fv, wt=wt, scale=scale, log.p=FALSE) fam.name <- family[1] discrete <- FALSE if (fam.name == "binomial" || fam.name == "poisson") discrete <- TRUE if(!discrete) ## for continuous distributions get non-randomized quantile residuals rquantile <- qnorm(cdf) else { ## for discrete distributions -> randomized quantile residuals aval <- family$cdf(q = y - 1L, mu = fv, wt = wt, scale = scale, log.p = FALSE) # generate a random value between aval and cdf... if (!is.null(setseed)) set.seed(setseed) uval <- runif(n = length(y), aval, cdf) uval <- ifelse(uval>0.999999,uval-.1e-15,uval) uval <- ifelse(uval<0.000001,uval+ .1e-15,uval) rquantile <- qnorm(uval) } rquantile } ## adding cdf to the families, needed for calculating the residual quantiles... ## based on cdf routines (c) Gavin L. Simpson, r package gratia... add.family.cdf <- function(family) ## adding cdf to family { if (!is.null(family$cdf)) { return(family) } fam.name <- family[1]$family qfun <- switch(EXPR = fam.name, poisson = cdf.poisson, binomial = cdf.binom, gaussian = cdf.norm, Gamma = cdf.gamma, inverse.gaussian = cdf.invgaussian ) # add the CDF fun to the family family$cdf <- qfun family } cdf.poisson <- function(q, mu, wt, scale, log.p = FALSE) { ppois(q, lambda = mu, log.p = log.p) } cdf.norm <- function(q, mu, wt, scale, log.p = FALSE) { pnorm(q, mean = mu, sd = sqrt(scale / wt), log.p = log.p) } cdf.binom <- function(q, mu, wt, scale, log.p = FALSE) { pbinom(q * (wt + as.numeric(wt == 0)), size = wt, prob = mu, log.p = log.p) } cdf.gamma <- function(q, mu, wt, scale, log.p = FALSE) { pgamma(q, shape = 1 / scale, scale = mu * scale, log.p = log.p) } ## inverse gaussian taken from (c) Mikis Stasinopoulos r package gamlss.dist.... cdf.invgaussian <- function(q, mu = 1, wt, scale = 1, log.p = FALSE) ## lower.tail = TRUE, only for lower tail of CDF { sigma <- scale if (any(mu < 0)) stop(paste("mu must be positive", "\n", "")) if (any(sigma < 0)) stop(paste("sigma must be positive", "\n", "")) ## if (any(q < 0)) stop(paste("y must be positive", "\n", "")) lq <- length(q) sigma <- rep(sigma, length = lq) mu <- rep(mu, length = lq) cdf1 <- pnorm(((q/mu)-1)/(sigma*sqrt(q))) lcdf2 <- (2/(mu*sigma^2))+pnorm((-((q/mu)+1))/(sigma*sqrt(q)),log.p=TRUE) cdf <- cdf1+ exp(lcdf2) ## if(lower.tail==TRUE) cdf <- cdf else cdf <- 1-cdf if(log.p==FALSE) cdf <- cdf else cdf <- log(cdf) cdf <- ifelse(q <= 0, 0, cdf) cdf } ########################################################## ## residual.scam() function used before version 1.2-20 ... residuals.scam_19 <-function(object, type = c("deviance", "pearson","scaled.pearson", "working", "response"),...) # calculates residuals for scam object the same as residulas.gam()... { type <- match.arg(type) y <- object$y mu <- object$fitted.values y.mu <- y-mu ## family <- object$family wts <- object$prior.weights res<- switch(type,working = object$residuals, scaled.pearson = y.mu*wts^.5/sqrt(object$sig2*object$family$variance(mu)), pearson = y.mu*wts^.5/sqrt(object$family$variance(mu)), deviance = { d.res <- sqrt(pmax(object$family$dev.resids(y,mu,wts),0)) ifelse(y>mu , d.res, -d.res) }, response = y.mu) res <- naresid(object$na.action,res) res } scam/R/predict.scam.R0000644000176200001440000007747215133440120014107 0ustar liggesusers## (c) Natalya Pya (2012-2025). Provided under GPL 2. ## based on (c) Simon N Wood predict.gam(mgcv) ... predict.scam <- function(object,newdata,type="link",se.fit=FALSE,terms=NULL,exclude=NULL, block.size=NULL,newdata.guaranteed=FALSE,na.action=na.pass,...) { # This function is used for predicting from a SCAM. object is a scam object, newdata a dataframe to # be used in prediction...... # # Type == "link" - for linear predictor # == "response" - for fitted values # == "terms" - for individual terms on scale of linear predictor # == "iterms" - exactly as "terms" except that se's include uncertainty about mean for unconstrained smooths # == "lpmatrix" - for matrix mapping parameters to linear predictor # Steps are: # 1. Set newdata to object$model if no newdata supplied # 2. split up newdata into manageable blocks if too large # 3. Obtain parametric model matrix (safely) # 4. Work through smooths calling prediction.matrix constructors for each term # 5. Work out required quantities # # The splitting into blocks enables blocks of compiled code to be called efficiently # using smooth class specific prediction matrix constructors, without having to # build up potentially enormous prediction matrices. # if newdata.guaranteed == TRUE then the data.frame is assumed complete and # ready to go, so that only factor levels are checked for sanity. # # if `terms' is non null then it should be a list of terms to be returned # when type=="terms". # if `object' has an attribute `para.only' then only parametric terms of order # 1 are returned for type=="terms": i.e. only what termplot can handle. # # if no new data is supplied then na.action does nothing, otherwise # if na.action == "na.pass" then NA predictors result in NA predictions (as lm # or glm) # == "na.omit" or "na.exclude" then NA predictors result in # dropping # if GC is TRUE then gc() is called after each block is processed # exclude: if type=="terms" or type="iterms" then terms (smooth or parametric) named # in this array will not be returned. Otherwise any smooth terms named in this # array will be set to zero. If NULL then no terms are excluded. if (type!="link"&&type!="terms"&&type!="iterms"&&type!="response"&&type!="lpmatrix") { warning("Unknown type, reset to terms.") type<-"terms" } if (!inherits(object,"scam")) stop("predict.scam can only be used to predict from scam objects") # if (ncol(attr(object$terms,"factors")) == 1) # { if (max(newdata) > max(object$data[,attr(b$terms,"term.labels")])) # stop("predict.scam can only be used for data within #the range of observed values, please use extrapolate.scam #otherwise") } ## to mimic behaviour of predict.lm, some resetting is required ... if (missing(newdata)) na.act <- object$na.action else { if (is.null(na.action)) na.act <- NULL else { na.txt <- if (is.character(na.action)||is.function(na.action)) get.na.action(na.action) else "na.pass" #na.txt <- "na.pass" #if (is.character(na.action)) #na.txt <- substitute(na.action) else #if (is.function(na.action)) na.txt <- deparse(substitute(na.action)) if (na.txt=="na.pass") na.act <- "na.exclude" else if (na.txt=="na.exclude") na.act <- "na.omit" else na.act <- na.action } } ## ... done # get data from which to predict..... nd.is.mf <- FALSE # need to flag if supplied newdata is already a model frame ## get name of response... # yname <- all.vars(object$terms)[attr(object$terms,"response")] yname <- attr(attr(object$terms,"dataClasses"),"names")[attr(object$terms,"response")] if (newdata.guaranteed==FALSE) { if (missing(newdata)) { # then "fake" an object suitable for prediction newdata <- object$model new.data.ok <- FALSE nd.is.mf <- TRUE response <- newdata[[yname]] ## ok even with "cbind(foo,bar)" as yname } else { # do an R ``standard'' evaluation to pick up data new.data.ok <- TRUE if (is.data.frame(newdata)&&!is.null(attr(newdata,"terms"))) { # it's a model frame if (sum(!(names(object$model)%in%names(newdata)))) stop( "newdata is a model.frame: it should contain all required variables\n") nd.is.mf <- TRUE } else { ## Following is non-standard to allow convenient splitting into blocks ## below, and to allow checking that all variables are in newdata ... ## get names of required variables, less response, but including offset variable ## see ?terms.object and ?terms for more information on terms objects # yname <- all.vars(object$terms)[attr(object$terms,"response")] ## redundant resp <- get.var(yname,newdata,FALSE) naresp <- FALSE #if (!is.null(object$family$predict)&&!is.null(newdata[[yname]])) { if (!is.null(object$family$predict)&&!is.null(resp)) { ## response provided, and potentially needed for prediction (e.g. Cox PH family): not in scam yet if (!is.null(object$pred.formula)) object$pred.formula <- attr(object$pred.formula,"full") response <- TRUE Terms <- terms(object) #resp <- newdata[[yname]] if (is.matrix(resp)) { if (sum(is.na(rowSums(resp)))>0) stop("no NAs allowed in response data for this model") } else { ## vector response if (sum(is.na(resp))>0) { naresp <- TRUE ## there are NAs in supplied response ## replace them with a numeric code, so that rows are not dropped below rar <- range(resp,na.rm=TRUE) thresh <- rar[1]*1.01-rar[2]*.01 resp[is.na(resp)] <- thresh newdata[[yname]] <- thresh } } } else { ## response not provided response <- FALSE Terms <- delete.response(terms(object)) } allNames <- if (is.null(object$pred.formula)) all.vars(Terms) else all.vars(object$pred.formula) if (length(allNames) > 0) { ff <- if (is.null(object$pred.formula)) reformulate(allNames) else object$pred.formula if (sum(!(allNames%in%names(newdata)))) { warning("not all required variables have been supplied in newdata!\n") } ## note that `xlev' argument not used here, otherwise `as.factor' in ## formula can cause a problem ... levels reset later. newdata <- eval(model.frame(ff,data=newdata,na.action=na.act),parent.frame()) if (naresp) newdata[[yname]][newdata[[yname]]<=thresh] <- NA ## reinstate as NA } ## otherwise it's intercept only and newdata can be left alone na.act <- attr(newdata,"na.action") #response <- if (response) newdata[[yname]] else NULL response <- if (response) get.var(yname,newdata,FALSE) else NULL } } } else { ## newdata.guaranteed == TRUE na.act <- NULL new.data.ok=TRUE ## it's guaranteed! if (!is.null(attr(newdata,"terms"))) nd.is.mf <- TRUE #response <- newdata[[yname]] response <- get.var(yname,newdata,FALSE) } ## now check the factor levels and split into blocks... if (new.data.ok){ ## check factor levels are right ... names(newdata)->nn # new data names colnames(object$model)->mn # original names for (i in 1:length(newdata)) if (nn[i]%in%mn && is.factor(object$model[,nn[i]])){ # then so should newdata[[i]] be ## newdata[[i]]<-factor(newdata[[i]],levels=levels(object$model[,nn[i]])) # set prediction levels to fit levels levm <- levels(object$model[,nn[i]]) ## original levels ## need to avoid dropping NAs if they are a factor level in original model (from version 1.2-20) levn <- if (any(is.na(levm))) levels(factor(newdata[[i]],exclude=NULL)) else levels(factor(newdata[[i]])) ## new levels if (sum(!levn%in%levm)>0) { ## check not trying to sneak in new levels msg <- paste("factor levels",paste(levn[!levn%in%levm],collapse=", "),"not in original fit",collapse="") warning(msg) xlev <- !(newdata[[i]] %in% levm) & !is.na(newdata[[i]]) ## attribute marking extra (non-NA) levels in factor (from version 1.2-20) } else xlev <- NULL ## set prediction levels to fit levels... if (is.matrix(newdata[[i]])) { dum <- factor(newdata[[i]],levels=levm,exclude=NULL) dim(dum) <- dim(newdata[[i]]) newdata[[i]] <- dum if (!is.null(xlev)) { dim(xlev) <- dim(dum) attr(newdata[[i]],"xlev") <- xlev } } else { newdata[[i]] <- factor(newdata[[i]],levels=levm,exclude=NULL) if (!is.null(xlev)) attr(newdata[[i]],"xlev") <- xlev ## not used in this routine } } if (type=="newdata") return(newdata) # split prediction into blocks, to avoid running out of memory if (length(newdata)==1) newdata[[2]]<-newdata[[1]] # avoids data frame losing its labels and dimensions below! if (is.null(dim(newdata[[1]]))) np<-length(newdata[[1]]) else np <- dim(newdata[[1]])[1] nb <- length(object$coefficients) if (is.null(block.size)) block.size <- 1000 if (block.size < 1) block.size <- np } else { # no new data, just use object$model np <- nrow(object$model) nb <- length(object$coefficients) } if (type=="lpmatrix") block.size <- NULL ## nothing gained by blocking in this case - and offset handling easier this way ## split prediction into blocks, to avoid running out of memory if (is.null(block.size)) { ## use one block as predicting using model frame ## and no block size supplied... n.blocks <- 1 b.size <- array(np,1) } else { n.blocks <- np %/% block.size b.size <- rep(block.size,n.blocks) last.block <- np-sum(b.size) if (last.block>0) { n.blocks <- n.blocks+1 b.size[n.blocks] <- last.block } } # setup prediction arrays... n.smooth<-length(object$smooth) if (type=="lpmatrix"){ H<-matrix(0,np,nb) } else if (type=="terms"||type=="iterms"){ term.labels<-attr(object$pterms,"term.labels") para.only <- attr(object,"para.only") if (is.null(para.only)) para.only <- FALSE # if TRUE then only return information on parametric part n.pterms <- length(term.labels) fit<-array(0,c(np,n.pterms+as.numeric(para.only==0)*n.smooth)) if (se.fit) se<-fit ColNames <- term.labels } else { ## "response" or "link" fit <- array(0,np) if (se.fit) se <- fit } stop <- 0 # Terms <- delete.response(object$pterms) ## from version 1.2-20... Terms <- list(delete.response(object$pterms)) ## make into a list anyway, no need for making list for scam as only one linear predictor usedm but adding the line anyway to be consistenty with predict.gam pterms <- list(object$pterms) pstart <- 1 pind <- 1:object$nsdf ## index of parameteric coefficients #################################### ## Actual prediction starts here... #################################### s.offset <- NULL # to accumulate any smooth term specific offset any.soff <- FALSE # indicator of term specific offset existence if (n.blocks > 0) for (b in 1:n.blocks){ # work through prediction blocks start <- stop+1 stop <- start+b.size[b]-1 if (n.blocks==1) data <- newdata else data <- newdata[start:stop,] X <- matrix(0,b.size[b],nb) Xoff <- matrix(0,b.size[b],n.smooth) ## term specific offsets for (i in 1:length(Terms)) { ## (versioin 1.2-20) loop for parametric components (actually only a single loop and only 1 linear predictor ) ## implements safe prediction for parametric part as described in ## http://developer.r-project.org/model-fitting-functions.txt if (new.data.ok){ if (nd.is.mf) mf <- model.frame(data,xlev=object$xlevels) else { mf <- model.frame(Terms[[i]],data,xlev=object$xlevels) if (!is.null(cl <- attr(pterms[[i]],"dataClasses"))) .checkMFClasses(cl,mf) } ## next line is just a work around to prevent a spurious warning (e.g. R 3.6) from ## model.matrix if contrast relates to a term in mf which is not ## part of Terms[[i]] (model.matrix doc actually defines contrast w.r.t. mf, ## not Terms[[i]])... oc <- if (length(object$contrasts)==0) object$contrasts else object$contrasts[names(object$contrasts)%in%attr(Terms[[i]],"term.labels")] Xp <- model.matrix(Terms[[i]],mf,contrasts=oc) } else { Xp <- model.matrix(Terms[[i]],object$model) mf <- newdata # needed in case of offset, below } if (!is.null(terms)||!is.null(exclude)) { ## work out which parts of Xp to zero assign <- attr(Xp,"assign") ## assign[i] is the term to which Xp[,i] relates if (min(assign)==0&&("(Intercept)"%in%exclude||(!is.null(terms)&&!"(Intercept)"%in%terms))) Xp[,which(assign==0)] <- 0 tlab <- attr(Terms[[i]],"term.labels") ii <- which(assign%in%which(tlab%in%exclude)) if (length(ii)) Xp[,ii] <- 0 if (!is.null(terms)) { ii <- which(assign%in%which(!tlab%in%terms)) if (length(ii)) Xp[,ii] <- 0 } } ## offi <- attr(Terms[[i]],"offset") ## if (is.null(offi)) offs[[i]] <- 0 else { ## extract offset ## offs[[i]] <- mf[[names(attr(Terms[[i]],"dataClasses"))[offi+1]]] ## } if (object$nsdf) X[,1:object$nsdf]<-Xp } ## end of parametric loop if (n.smooth) for (k in 1:n.smooth) { ## loop through smooths klab <- object$smooth[[k]]$label if ((is.null(terms)||(klab%in%terms))&&(is.null(exclude)||!(klab%in%exclude))) { ## if is.null(terms) & is.null(exclude) Xfrag <- PredictMat(object$smooth[[k]],data) if (!is.matrix(Xfrag)) Xfrag <- matrix(Xfrag,nrow=nrow(data)) ## added code specific for scam.... if (inherits(object$smooth[[k]], c("mpic.smooth", ## "mpi.smooth", "mpd.smooth", "cv.smooth", "cx.smooth", "po.smooth", ## "mdcv.smooth","mdcx.smooth","micv.smooth","micx.smooth", "ipo.smooth","cpopspline.smooth", "tedmi.smooth","tedmd.smooth","temicx.smooth","temicv.smooth", "tedecx.smooth", "tedecv.smooth","tecvcv.smooth","tecxcx.smooth","tecxcv.smooth"))) X[,object$smooth[[k]]$first.para:object$smooth[[k]]$last.para] <- Xfrag[,2:ncol(Xfrag)] else if (inherits(object$smooth[[k]], c("dpo.smooth"))) X[,object$smooth[[k]]$first.para:object$smooth[[k]]$last.para] <- Xfrag[,1:(ncol(Xfrag)-1)] else if (inherits(object$smooth[[k]], c("miso.smooth","mifo.smooth"))) ## 'zero start' and 'zero end' increasing constraints X[,object$smooth[[k]]$first.para:object$smooth[[k]]$last.para] <- Xfrag[,-object$smooth[[k]]$n.zero] # else if (inherits(object$smooth[[k]], c("mipoc.smooth"))) ## 'pss zero ' increasing constraint ... # X[,object$smooth[[k]]$first.para:object$smooth[[k]]$last.para] <- Xfrag else if (inherits(object$smooth[[k]], c("tesmi1.smooth", "tesmi2.smooth", "tesmd1.smooth", "tesmd2.smooth","tescx.smooth","tescv.smooth"))) { ## for single monotonicity/ convexity X[,object$smooth[[k]]$first.para:object$smooth[[k]]$last.para] <- Xfrag%*%object$smooth[[k]]$Zc ## X[,object$smooth[[k]]$first.para:object$smooth[[k]]$last.para] <- sweep(X[,object$smooth[[k]]$first.para:object$smooth[[k]]$last.para],2,object$smooth[[k]]$cmX) } else if (inherits(object$smooth[[k]], c("tismi.smooth","tismd.smooth"))) {## for smooth interaction X[,object$smooth[[k]]$first.para:object$smooth[[k]]$last.para] <- Xfrag %*%object$smooth[[k]]$Zc } else if (inherits(object$smooth[[k]], c("lipl.smooth"))) {## local scop-spline increasing up to given point and a plateau from it n.extra.col <- object$smooth[[k]]$n.zero.col ## ncol(Xfrag) - (object$smooth[[k]]$last.para-object$smooth[[k]]$first.para+1) ind.extra <- c((object$smooth[[k]]$last.para+1):(object$smooth[[k]]$last.para+n.extra.col)) object$coefficients.t <- c(object$coefficients.t,rep(0,n.extra.col)) ## temporary solution, works only for a single smooth model X <- cbind(X,matrix(0,nrow(X), n.extra.col)) ## X[,object$smooth[[k]]$first.para:(object$smooth[[k]]$last.para)] <- cbind(X[,object$smooth[[k]]$first.para:object$smooth[[k]]$last.para],matrix(0,nrow(X), n.extra.col)) X[,object$smooth[[k]]$first.para:(object$smooth[[k]]$first.para+ncol(Xfrag)-2)] <- Xfrag[,2:ncol(Xfrag)] } else ## unconstrainded smooths, 'by' constrained, local scop smooths, increasing/decreasing, convex/concave, and mixed constr... X[,object$smooth[[k]]$first.para:object$smooth[[k]]$last.para] <- Xfrag Xfrag.off <- attr(Xfrag,"offset") ## any term specific offsets? if (!is.null(Xfrag.off)) { Xoff[,k] <- Xfrag.off; any.soff <- TRUE } } ## end if is.null(terms) & is.null(exclude) if (type=="terms"||type=="iterms") ColNames[n.pterms+k] <- klab } ## smooths done # Now have prediction matrix, X, for this block, need to do something with it... if (type=="lpmatrix") { if (n.smooth) for (k in 1:n.smooth) { if (inherits(object$smooth[[k]], c("lipl.smooth"))) H <- cbind(H,matrix(0,nrow(H), n.extra.col)) } H[start:stop,] <- X if (any.soff) s.offset <- rbind(s.offset,Xoff) } else if (type=="terms" ||type=="iterms") { ind <- 1:length(object$assign) if (n.pterms) # work through parametric part for (i in 1:n.pterms){ ii <- ind[object$assign==i] ## CORRECTIONS FOR SCAM.... fit[start:stop,i] <- as.matrix(X[,ii,drop=FALSE])%*%object$coefficients.t[ii] if (se.fit) se[start:stop,i] <- sqrt(pmax(0,rowSums((as.matrix(X[,ii,drop=FALSE])%*%object$Vp.t[ii,ii])*as.matrix(X[,ii,drop=FALSE])))) } if (n.smooth&&!para.only) { for (k in 1:n.smooth) # work through the smooth terms { first <- object$smooth[[k]]$first.para; last <- object$smooth[[k]]$last.para ## CORRECTED for SCAM ... fit[start:stop,n.pterms+k] <- X[,first:last,drop=FALSE] %*% object$coefficients.t[first:last] + Xoff[,k] if (se.fit) { # diag(Z%*%V%*%t(Z))^0.5; Z=X[,first:last]; V is sub-matrix of Vp if (inherits(object$smooth[[k]], c("po.smooth","cpopspline.smooth" ## "mpi.smooth","mpd.smooth","cv.smooth", "cx.smooth", ))){ ## "mdcv.smooth","mdcx.smooth","micv.smooth","micx.smooth" if (nrow(X)==1) # prediction vector if prediction is made for only one value of covariates X1 <- c(1,t(X[,first:last])) else X1 <- cbind(rep(1,nrow(X)),X[,first:last]) # prediction matrix Vp <- object$Vp.t[c(1,first:last),c(1,first:last)] Vp[,1] <- rep(0,nrow(Vp)) Vp[1,] <- rep(0,ncol(Vp)) se[start:stop,n.pterms+k] <- sqrt(pmax(0,rowSums((X1%*%Vp)*X1))) } else if (inherits(object$smooth[[k]], c("ipo.smooth","dpo.smooth"))){ if (nrow(X)==1) # prediction vector if prediction is made for only one value of covariates X1 <- if (inherits(object$smooth[[k]], c("dpo.smooth"))) c(t(X[,first:last]),1) else c(1,t(X[,first:last])) else X1 <- if (inherits(object$smooth[[k]], c("dpo.smooth"))) cbind(X[,first:last],rep(1,nrow(X))) else cbind(rep(1,nrow(X)),X[,first:last]) # prediction matrix # X0 - model matrix of the original data.... object.X <- model.matrix(object) X0 <- if (inherits(object$smooth[[k]], c("dpo.smooth"))) cbind(object.X[,first:last], rep(1,nrow(object.X))) else cbind(rep(1,nrow(object.X)),object.X[,first:last]) q <- ncol(X0) onet <- matrix(rep(1,nrow(X0)),1,nrow(X0)) A <- onet%*%X0 qrX <- qr(X0) R <- qr.R(qrX) qrA <- qr(t(A)) if (inherits(object$smooth[[k]], c("dpo.smooth"))) { R <- R[-q,] RZa <- t(qr.qty(qrA,t(R)))[,1:(q-1)] } else { R <- R[-1,] RZa <- t(qr.qty(qrA,t(R)))[,2:q] } RZa.inv <- solve(RZa) RZaR <- RZa.inv%*%R if (nrow(X)==1) XZa <- if (inherits(object$smooth[[k]], c("dpo.smooth"))) t(qr.qty(qrA,X1))[,1:(q-1)] else t(qr.qty(qrA,X1))[,2:q] else XZa <- if (inherits(object$smooth[[k]], c("dpo.smooth"))) t(qr.qty(qrA,t(X1)))[,1:(q-1)] else t(qr.qty(qrA,t(X1)))[,2:q] Ga <- XZa%*%RZaR if (inherits(object$smooth[[k]], c("dpo.smooth"))) { Vp <- object$Vp.t[c(first:last,1),c(first:last,1)] Vp[,q] <- rep(0,nrow(Vp)) Vp[q,] <- rep(0,ncol(Vp)) } else { Vp <- object$Vp.t[c(1,first:last),c(1,first:last)] Vp[,1] <- rep(0,nrow(Vp)) Vp[1,] <- rep(0,ncol(Vp)) } se[start:stop,n.pterms+k] <- sqrt(pmax(0,rowSums((Ga%*%Vp)*Ga))) } else if (inherits(object$smooth[[k]], c("tedmi.smooth","tedmd.smooth","tesmi1.smooth", "tismi.smooth","tismd.smooth","tesmi2.smooth", "tesmd1.smooth", "tesmd2.smooth","temicx.smooth", "temicv.smooth", "tedecx.smooth", "tedecv.smooth", "tescx.smooth", "tescv.smooth","tecvcv.smooth","tecxcx.smooth","tecxcv.smooth"))) { # X0 - model matrix of the original data.... object.X <- model.matrix(object) X0 <- cbind(rep(1,nrow(object.X)),object.X[,first:last]) onet <- matrix(rep(1,nrow(X0)),1,nrow(X0)) if (nrow(X)==1) # prediction vector if prediction is made for only one value of covariates X1 <- c(1,t(X[,first:last])) else X1 <- cbind(rep(1,nrow(X)),X[,first:last]) # prediction matrix A <- onet%*%X0 qrX <- qr(X0) R <- qr.R(qrX) qrA <- qr(t(A)) q <- ncol(X0) if (inherits(object$smooth[[k]], c("tedmi.smooth", "tedmd.smooth","tedmdc.smooth", "temicx.smooth", "temicv.smooth", "tedecx.smooth","tedecv.smooth", "tecvcv.smooth", "tecxcx.smooth","tecxcv.smooth"))) { # get RZaR for double monotonicity... R <- R[-1,] RZa <- t(qr.qty(qrA,t(R)))[,2:q] RZa.inv <- solve(RZa) RZaR <- RZa.inv%*%R } else { # get RZaR for single monotonicity... RZa <- t(qr.qty(qrA,t(R)))[,2:q] RZatRZa.inv <- solve(crossprod(RZa)) ## solve(t(RZa)%*%RZa) Q <- qr.Q(qrX) B1 <- tcrossprod(RZatRZa.inv,RZa) ## RZatRZa.inv%*%t(RZa) RZaR <- B1%*%R } if (nrow(X)==1) XZa <- t(qr.qty(qrA,X1))[,2:ncol(X1)] else XZa <- t(qr.qty(qrA,t(X1)))[,2:ncol(X1)] Ga <- XZa%*%RZaR%*%object$smooth[[k]]$Zc Vp <- object$Vp.t[first:last,first:last] se[start:stop,n.pterms+k] <- sqrt(pmax(0,rowSums((Ga%*%Vp)*Ga))) } else if (inherits(object$smooth[[k]], c("miso.smooth", "mifo.smooth"))) { ## 'zero start' and passing through zero increasing constraint ... se[start:stop,n.pterms+k] <- sqrt(pmax(0,rowSums((X[,first:last,drop=FALSE]%*%object$Vp.t[first:last,first:last])*X[,first:last,drop=FALSE]))) } else { ## for local scop smooth terms, scop with'by' and unconstrained smooth terms..... if (type=="iterms"&& attr(object$smooth[[k]],"nCons")>0) { ## termwise se to "carry the intercept X1 <- matrix(object$cmX,nrow(X),ncol(X),byrow=TRUE) meanL1 <- object$smooth[[k]]$meanL1 if (!is.null(meanL1)) X1 <- X1 / meanL1 X1[,first:last] <- X[,first:last,drop=FALSE] se[start:stop,n.pterms+k] <- sqrt(pmax(0,rowSums((X1%*%object$Vp)*X1))) } else se[start:stop,n.pterms+k] <- ## terms strictly centred sqrt(pmax(0,rowSums((X[,first:last,drop=FALSE]%*%object$Vp.t[first:last,first:last])*X[,first:last,drop=FALSE]))) } } ## end if (se.fit) } ## end # work through the smooth terms colnames(fit) <- ColNames if (se.fit) colnames(se) <- ColNames } else { # para.only if (para.only&&is.list(object$pterms)) { ## have to use term labels that match original data, or termplot fails ## to plot. This only applies for 'para.only==1' calls which are ## designed for use from termplot called from plot.gam term.labels <- unlist(lapply(object$pterms,attr,"term.labels")) } colnames(fit) <- term.labels if (se.fit) colnames(se) <- term.labels if (para.only) { # retain only terms of order 1 - this is to make termplot work order <- if (is.list(object$pterms)) unlist(lapply(object$pterms,attr,"order")) else attr(object$pterms,"order") #attr(object$pterms,"order") term.labels <- term.labels[order==1] ## fit <- as.matrix(as.matrix(fit)[,order==1]) fit <- fit[,order==1,drop=FALSE] colnames(fit) <- term.labels if (se.fit) { ## se <- as.matrix(as.matrix(se)[,order==1]) se <- se[,order==1,drop=FALSE] colnames(se) <- term.labels } } } ##if (!is.null(terms)) { # return only terms requested via `terms' ## if (sum(!(terms %in%colnames(fit)))) ## warning("non-existent terms requested - ignoring") ## else { names(term.labels) <- term.labels ## term.labels <- term.labels[terms] # names lost if only one col ## fit <- as.matrix(as.matrix(fit)[,terms]) ## colnames(fit) <- term.labels ## if (se.fit) {se <- as.matrix(as.matrix(se)[,terms]) ## colnames(se) <- term.labels} ## } ##} } else {# "link" or "response" k <- attr(attr(object$model,"terms"),"offset") offs <- if (is.null(k)) rowSums(Xoff) else rowSums(Xoff) + model.offset(mf) # (from version 1.2-20) ## CORRECTED for SCAM... fit[start:stop] <- X%*%object$coefficients.t + offs ## + rowSums(Xoff) ## if (!is.null(k)) fit[start:stop]<-fit[start:stop]+model.offset(mf) + rowSums(Xoff) if (se.fit) se[start:stop] <- sqrt(pmax(0,rowSums((X%*%object$Vp.t)*X))) if (type=="response") {# transform fam <- object$family linkinv <- fam$linkinv dmu.deta <- fam$mu.eta if (se.fit) se[start:stop] <- se[start:stop]*abs(dmu.deta(fit[start:stop])) fit[start:stop] <- linkinv(fit[start:stop]) } } rm(X) } ## end of prediction block loop if ((type=="terms"||type=="iterms")&&(!is.null(terms)||!is.null(exclude))) { # return only terms requested via `terms' cnames <- colnames(fit) if (!is.null(terms)) { if (sum(!(terms %in%cnames))) warning("non-existent terms requested - ignoring") else { fit <- fit[,terms,drop=FALSE] if (se.fit) { se <- se[,terms,drop=FALSE] } } } if (!is.null(exclude)) { if (sum(!(exclude %in%cnames))) warning("non-existent exclude terms requested - ignoring") else { exclude <- which(cnames%in%exclude) ## convert to numeric column index fit <- fit[,-exclude,drop=FALSE] if (se.fit) { se <- se[,-exclude,drop=FALSE] } } } } #if (type=="response"&&!is.null(fit1)) { # fit <- fit1 # if (se.fit) se <- se1 #} rn <- rownames(newdata) if (type=="lpmatrix") { lipl.yes <- FALSE if (n.smooth) for (k in 1:n.smooth) { if (inherits(object$smooth[[k]], c("lipl.smooth"))) { colnames(H[,-ind.extra]) <- names(object$coefficients) lipl.yes <- TRUE } } if (!lipl.yes) colnames(H) <- names(object$coefficients) rownames(H)<-rn if (!is.null(s.offset)) { s.offset <- napredict(na.act,s.offset) attr(H,"offset") <- s.offset ## term specific offsets... } H <- napredict(na.act,H) } else { if (se.fit) { if (is.null(nrow(fit))) { names(fit) <- rn names(se) <- rn fit <- napredict(na.act,fit) se <- napredict(na.act,se) } else { rownames(fit)<-rn rownames(se)<-rn fit <- napredict(na.act,fit) se <- napredict(na.act,se) } H <- list(fit=fit,se.fit=se) } else { H <- fit if (is.null(nrow(H))) names(H) <- rn else rownames(H) <- rn H <- napredict(na.act,H) } } if ((type=="terms"||type=="iterms")&&attr(object$terms,"intercept")==1) attr(H,"constant") <- object$coefficients[1] H # ... and return } ## end predict.scam ################################ ## below is from mgcv r ... get.na.action <- function(na.action) { ## get the name of the na.action whether function or text string. ## avoids deparse(substitute(na.action)) which is easily broken by ## nested calls. if (is.character(na.action)) { if (na.action%in%c("na.omit","na.exclude","na.pass","na.fail")) return(na.action) else stop("unrecognised na.action") } if (!is.function(na.action)) stop("na.action not character or function") a <- try(na.action(c(0,NA)),silent=TRUE) if (inherits(a,"try-error")) return("na.fail") if (inherits((attr(a,"na.action")),"omit")) return("na.omit") if (inherits((attr(a,"na.action")),"exclude")) return("na.exclude") return("na.pass") } ## get.na.action ############################################################################### ### ISSUES..... # #* predict.scam "terms" and "iterms" don't deal properly with # shape constrained smooths: se.fit retured are the same for both types scam/R/zzz.R0000644000176200001440000000105415132161074012356 0ustar liggesusers print.scam.version <- function() { library(help=scam)$info[[1]] -> version version <- version[pmatch("Version",version)] um <- strsplit(version," ")[[1]] version <- um[nchar(um)>0][2] hello <- paste("This is scam ",version,".",sep="") packageStartupMessage(hello) } .onAttach <- function(...) { print.scam.version() } .onLoad <- function(libname, pkgname) { if (requireNamespace("emmeans", quietly = TRUE)) emmeans::.emm_register(c("scam"), pkgname) } ##.onUnload <- function(libpath) library.dynam.unload("scam", libpath) scam/R/check.analytical.R0000644000176200001440000000337415026260053014724 0ustar liggesusers## function to check analytical gradient fo GCV/UBRE... check.analytical <- function(object,data, del=1e-6,control){ # require(mgcv) G<-gam(object$formula,object$family,data,fit=FALSE) n.terms <- length(G$smooth) # number of smooths in the model n <- nrow(G$X) intercept <- G$intercept ## TRUE or FALSE n.pen <- length(G$S) Q <- penalty_pident(G) q.f <- rep(0,n.terms) for (i in 1:n.terms) { q.f[i] <- ncol(G$smooth[[i]]$S[[1]]) +1 } G$S <- Q$S G$q.f <- q.f G$q0 <- G$off[1]-1 ## number of the parameters of the strictly parametric model G$p.ident <- Q$p.ident # vector of 0's & 1's for the model parameters identification: G$n.terms <- n.terms ## number of the smooth terms in the SCAM G$weights <- object$prior.weights G$sig2 <- object$sig2 G$scale.known <- object$scale.known ## Create new environments with `start' initially empty env <- new.env() assign("start",object$coefficients,envir=env) assign("dbeta.start",object$dbeta.rho,envir=env) assign("sp.last",object$sp,envir=env) sp1 <- rep(0,n.pen) sp <- object$sp dgcv.ubre.check <- rep(0,n.pen) for (j in 1:n.pen){ sp1<- sp; sp1[j]<-sp[j]*exp(del) m1 <- scam.fit(G=G, sp=sp1,env=env,control=control) if (object$scale.known) gcv.ubre1 <- m1$deviance/n - object$sig2 +2*object$gamma*m1$trA*object$sig2/n else gcv.ubre1 <- m1$gcv dgcv.ubre.check[j] <- (gcv.ubre1-object$gcv)/del # finite difference derivative } check.grad <- 100*(object$dgcv.ubre - dgcv.ubre.check)/dgcv.ubre.check list(dgcv.ubre.fd=dgcv.ubre.check,check.grad=check.grad) } scam/R/scam.fit1.r0000644000176200001440000007671215026260052013361 0ustar liggesusers## (c) Natalya Pya (2022-2023). Released under GPL2. ## based on (c) Simon N Wood (bfgs(mgcv)) ####################################################################### ## Function to fit SCAM using quasi-Newton method, the BFGS method ## ####################################################################### scam.fit1 <- function(G,sp, gamma=1, etastart=NULL, mustart=NULL, env=env, null.coef=rep(0,ncol(G$X)), control=scam.control(), ## next are additional input arguments for BFGS: conv.tol=1e-6,maxNstep=3,maxSstep=2,maxHalf=30,printWarn=FALSE ) ## Function to fit SCAM using a quasi-Newton method, the BFGS method (as an alternative to the Newton method) ## by minimizing penalized deviance wrt model coefficients ## BFGS is based on Nocedal & Wright (2006) Numerical Optimization, Springer, ## and as applied in bfgs() of Simon Wood mgcv for smoothing parameter estimation. ## Simon, mgcv: "In particular the step lengths are chosen to meet the Wolfe conditions ## using their algorithms 3.5 (p60) and 3.6 (p61). On p143 they recommend a post step ## adjustment to the initial Hessian. I can't understand why one would do anything ## other than adjust so that the initial Hessian would give the step taken, and ## indeed the latter adjustment seems to give faster convergence than their ## proposal, and is therefore implemented." ## MAIN STEPS: ## 1. Initialization of parameters as in scam.fit() ## 2. shrinking towards null.coef if immediately after initialization invalid, remains as in scam.fit() ## 3. main BFGS iterations ... ## 4. define matrices at their converged values from the BFGS method.. ## below is valid for scam.fit via Newton: ## maxit=200, devtol.fit=1e-8, steptol.fit=1e-8, trace=FALSE, print.warn=FALSE ## G - list of items from gam(...,fit=FALSE) needed to fit a scam ## sp- vector of smoothing parameters ## not.exp - if TRUE then notExp() function will be used in place of exp in positivity ensuring beta parameters re-parameterization ## null.coef - coefficients for a null model, in order to be able to check for immediate divergence. null.coef give some sort of upper bound on deviance. This allows immediate divergence problems to be controlled (from mgcv). here some of coeff need to be exponentiated. ## control - control list; it includes: ##* maxit - a positive scalar which gives the maximum number of iterations for Newton's method ##* devtol.fit - a scalar giving the tolerance at which the relative penalized deviance is considered to be close enougth to 0 to terminate the algorithm ##* steptol.fit - a scalar giving the tolerance at which the scaled distance between two successive iterates is considered close enough to zero to terminate the algorithm ##* trace turns on or off some de-bugging information. ##* print.warn =FALSE - when set to 'FALSE' turns off printing warning messages for step halving under non-finite exponentiated coefficients, non-finite deviance and/or if mu or eta are out of bounds. ## { score <- function(y,X,beta,offset,weights, rS,S.t, q,iv,linkinv, dev.resids,mu.eta,variance) { ## function to calculate penalized deviance and its gradient beta.t <- beta ## re-parameterized beta beta.t[iv] <- if (!not.exp) exp(beta[iv]) else notExp(beta[iv],b.notexp,th.notexp) ## values of re-para beta of the shape constrained terms eta <- as.numeric(X%*%beta.t + as.numeric(offset)) ## linear predictor mu <- linkinv(eta) ## fitted values dev <- sum(dev.resids(y,mu,weights)) ## deviance pdev <- dev + sum((rS%*%beta)^2) ## penalized deviance Cdiag <- rep(1,q) Cdiag[iv] <- if (!not.exp) beta.t[iv] else DnotExp(beta[iv]) tX1 <- Cdiag*t(X) g.deriv <- 1/mu.eta(eta) # diag(G) w1 <- weights/(variance(mu)*g.deriv^2) # diag(W1) grad <- -drop(tX1%*%(w1*g.deriv*(y-mu)))+S.t%*%beta # the gradient vector of the penalized deviance list(pdev=pdev, grad=grad) } ## end score() zoom <- function(lo,hi) { ## as in bfgs() of mgcv: ## local function implementing Algorithm 3.6 of Nocedal & Wright ## (2006, p61) Numerical Optimization. Relies on R scoping rules. ## alpha.lo and alpha.hi are the bracketing step lengths. ## This routine bisection searches for a step length that meets the ## Wolfe conditions. lo and hi are both objects containing fields ## `score', `alpha', `dscore', where `dscore' is the derivative of ## the score in the current step direction, `grad' and `mustart'. ## `dscore' will be NULL if the gradiant has yet to be evaluated. for (i in 1:40) { trial <- list(alpha = (lo$alpha+hi$alpha)/2) beta <- ibeta +step * trial$alpha b <- score(y=y,X=X,beta=beta,offset=offset,weights=weights,rS=rS,S.t=S.t,q=q,iv=iv, linkinv=linkinv,dev.resids=dev.resids,mu.eta=mu.eta,variance=variance) trial$pdev <- b$pdev if (trial$pdev >initial$pdev+trial$alpha*c1*initial$dscore||trial$pdev>=lo$pdev) { hi <- trial ## failed Wolfe 1 - insufficient decrease - step too long } else { ## met Wolfe 1 so check Wolve 2 - sufficiently positive second derivative? trial$grad <- b$grad trial$dscore <- sum(step*trial$grad) ## directional derivative if (abs(trial$dscore) <= -c2*initial$dscore) return(trial) ## met Wolfe 2 ## failed Wolfe 2 derivative not increased enough if (trial$dscore*(hi$alpha-lo$alpha)>=0) { hi <- lo } lo <- trial } } ## end while(TRUE) return(NULL) ## failed } ## end zoom y <- G$y; X <- G$X; S <- G$S; not.exp <- G$not.exp; AR1.rho <- G$AR1.rho attr(X,"dimnames") <- NULL q0 <- G$q0; q.f <- G$q.f p.ident <- G$p.ident; n.terms <- G$n.terms family <- G$family; intercept <- G$intercept; offset <- G$offset; weights <- G$weights; n <- nobs <- NROW(y) q <- ncol(X) dg <- fix.family.link(family) dv <- fix.family.var(family) nvars <- NCOL(X) EMPTY <- nvars == 0 variance <- family$variance linkinv <- family$linkinv if (!is.function(variance) || !is.function(linkinv)) stop("'family' argument seems not to be a valid family object") dev.resids <- family$dev.resids aic <- family$aic mu.eta <- family$mu.eta mu.eta <- family$mu.eta if (not.exp){ b.notexp <- control$b.notexp th.notexp <- control$threshold.notexp } if (AR1.rho!=0) { ld <- 1/sqrt(1-AR1.rho^2) ## leading diagonal of root inverse correlation sd <- -AR1.rho*ld ## sub diagonal row <- c(1,rep(1:nobs,rep(2,nobs))[-c(1,2*nobs)]) weight.r <- c(1,rep(c(sd,ld),nobs-1)) end <- c(1,1:(nobs-1)*2+1) if (!is.null(G$mf$"(AR.start)")) { ## need to correct the start of new AR sections... ii <- which(G$mf$"(AR.start)"==TRUE) if (length(ii)>0) { if (ii[1]==1) ii <- ii[-1] ## first observation does not need any correction weight.r[ii*2-2] <- 0 ## zero sub diagonal weight.r[ii*2-1] <- 1 ## set leading diagonal to 1 } } ## apply transform... X <- rwMatrix(end,row,weight.r,X) y <- rwMatrix(end,row,weight.r,y) } if (!is.function(variance) || !is.function(linkinv)) stop("illegal `family' argument") valideta <- family$valideta if (is.null(valideta)) valideta <- function(eta) TRUE validmu <- family$validmu if (is.null(validmu)) validmu <- function(mu) TRUE if (is.null(mustart)) { eval(family$initialize) } else { mukeep <- mustart eval(family$initialize) mustart <- mukeep } ## Added code... if (family$family=="gaussian"&&family$link=="identity") strictly.additive <- TRUE else strictly.additive <- FALSE ## end of added code if (EMPTY) { eta <- rep.int(0, nobs) + offset if (!valideta(eta)) stop("Invalid linear predictor values in empty model") mu <- linkinv(eta) if (AR1.rho!=0) { mu <- rwMatrix(end,row,weight.r,mu) } if (!validmu(mu)) stop("Invalid fitted means in empty model") dev <- sum(dev.resids(y, mu, weights)) w <- (weights * mu.eta(eta)^2)/variance(mu) ## incorrect for Newton residuals <- (y - mu)/mu.eta(eta) good <- rep(TRUE, length(residuals)) boundary <- conv <- TRUE coef <- numeric(0) iter <- 0 V <- variance(mu) alpha <- dev trA <- 0 ## GCV <- nobs * alpha/(nobs - gamma * trA)^2 ## UBRE <- alpha/nobs + 2 * gamma* trA*scale/n - scale scale.est <- alpha/(nobs - trA) aic.model <- aic(y, n, mu, weights, dev) + 2 * trA } ### end if (EMPTY) else { eta <- if (!is.null(etastart)) etastart else family$linkfun(mustart) mu <- as.numeric(linkinv(eta)) # if (!(validmu(mu) && valideta(eta))) # stop("Can't find valid starting values: please specify some") S.t <- matrix(0,q,q) # define the total sum of the penalties times sp n.pen <- length(S) # number of penalties if (length(sp)!=n.pen) stop (paste("length of sp has to be equal to", n.pen)) if (n.pen>0) for (j in 1:n.pen) S.t <- S.t + sp[j]*S[[j]] # get sqrt of total penalty matrix... er <- eigen(S.t,symmetric=TRUE); er$values[er$values<0] <- 0 rS <- crossprod(sqrt(sqrt(er$values))*t(er$vectors)) # ii <- p.ident==1 ## set to TRUE/FALSE ## count <- sum(p.ident) ## iv <- array(0, dim=c(count,1)) # define an index vector for the coeff-s to be exponentiated iv <- (1:q)[p.ident] # define an index vector for the coeff-s to be exponentiated ############################################## ## Initialization of parameters starts here... beta0 <- get("start",envir=env) dbeta0 <- get("dbeta.start",envir=env) sp.old <- get("sp.last",envir=env) if (length(beta0)==0) { # list argument to pcls for initializing model coefficients M <- list(X=X,p=rep(0.1,q),C=matrix(0,0,0),sp=sp,y=eta-offset,w=y*0+1) M$Ain <- matrix(0,q,q); diag(M$Ain) <- rep(1,q); M$bin <- rep(-1e+12,q); M$bin[iv] <- 1e-12 M$off <- rep(0,n.pen); M$S <- list() if (n.pen>0) for (j in 1:n.pen) {M$S[[j]] <- matrix(0,q,q); M$S[[j]] <- S[[j]]} beta.t <- pcls(M) # initialize model coefficients (re-parameterized beta) beta <- beta.t # initialize beta beta[iv] <- log(beta.t[iv]) # values of beta of the constrained terms } else { beta <- beta0 beta.t <- beta ## current beta tilde beta.t[iv] <- if (!not.exp) exp(beta[iv]) else notExp(beta[iv],b.notexp,th.notexp) # values of re-para beta of the constrained term } ## end of initialization of parameters ############################################## eta <- as.numeric(X%*%beta.t + as.numeric(offset)) # define initial linear predictor mu <- linkinv(eta) # define initial fitted model ## dev <- sum(dev.resids(y,mu,weights)) # define initial norm/deviance ## pdev <- dev + sum((rS%*%beta)^2) # define initial penalized deviance ## old.pdev <- pdev # initialize convergence control for penalized deviance b <- score(y=y,X=X,beta=beta,offset=offset,weights=weights,rS=rS,S.t=S.t,q=q,iv=iv, linkinv=linkinv,dev.resids=dev.resids,mu.eta=mu.eta,variance=variance) pdev <- b$pdev ## define initial penalized deviance old.pdev <- pdev ## initialize convergence control for penalized deviance grad <- b$grad ## initialize gradient of the penalized deviance score.scale <- 1+abs(b$pdev) ################################################################## ## added code here made on May 6, 2020 for scam version 1-2-6, ## following Simon N Wood gam.fit3(mgcv_1.8-31)).... ################################################################### ## shrink towards null.coef if immediately invalid ## betaold <- null.coef ## etaold <- null.eta <- as.numeric(X%*%null.coef + as.numeric(offset)) ## old.pdev <- sum(dev.resids(y, linkinv(null.eta), weights)) + sum((rS%*%null.coef)^2) ## null.eta <- as.numeric(X%*%null.coef + as.numeric(offset)) ii <- 0 while (!(validmu(mu) && valideta(eta))) { ## shrink towards null.coef if immediately invalid ii <- ii + 1 if (ii>20) stop("Can't find valid starting values: please specify some") beta <- beta * .9 + null.coef * .1 beta.t <- beta ## current beta tilde beta.t[iv] <- if (!not.exp) exp(beta[iv]) else notExp(beta[iv],b.notexp,th.notexp) eta <- as.numeric(X%*%beta.t + offset) mu <- linkinv(eta) } betaold <- null.coef <- beta betaold.t <- beta betaold.t[iv] <- if (!not.exp) exp(betaold[iv]) else notExp(betaold[iv],b.notexp,th.notexp) etaold <- as.numeric(X%*%betaold.t + offset) old.pdev <- sum(dev.resids(y,linkinv(etaold),weights)) + sum((rS%*%betaold)^2) ################################################################## ## E <- matrix(0,q,q) # define diagonal matrix E- second term of the Hessian, NO NEED ## CHECK if var-s below are needed!!! boundary <- conv <- FALSE old.warn <- getOption("warn") if (!control$print.warn) curr.warn <- -1 else curr.warn <- old.warn ############################################ ### BFGS ALGORITHM STARTS HERE... initial.beta <- ibeta <- beta initial <- list(alpha = 0,mustart=b$fitted.values,start=coef(b)) initial$pdev <- pdev; initial$grad <- grad B <- diag(length(initial$grad)) ## initial Hessian feps <- 1e-4 for (i in 1:length(beta)) { ## loop to FD for Hessian ibeta <- beta ibeta[i] <- ibeta[i] + feps b <- score(y=y,X=X,beta=ibeta,offset=offset,weights=weights,rS=rS,S.t=S.t,q=q,iv=iv, linkinv=linkinv,dev.resids=dev.resids,mu.eta=mu.eta,variance=variance) grad1 <- b$grad ## gradient of the penalized deviance B[i,] <- (grad1-grad)/feps rm(b) } ## end of FD Hessian loop ## force initial Hessian to +ve def and invert... B <- (B+t(B))/2 eb <- eigen(B,symmetric=TRUE) eb$values <- abs(eb$values) thresh <- max(eb$values) * 1e-4 eb$values[eb$values=0) { ## step not descending! ## Following would really be in the positive definite space... ##step[uconv.ind] <- -solve(chol2inv(chol(B))[uconv.ind,uconv.ind],initial$grad[uconv.ind]) step <- -diag(B)*initial$grad ## simple scaled steepest descent step[!uconv.ind] <- 0 ## don't move if apparently converged } ms <- max(abs(step)) trial <- list() if (ms>maxNstep) { trial$alpha <- maxNstep/ms alpha.max <- trial$alpha*1.05 ## step <- maxNstep * step/ms #alpha.max <- 1 ## was 50 in place of 1 here and below } else { trial$alpha <- 1 alpha.max <- min(2,maxNstep/ms) ## 1*maxNstep/ms } initial$dscore <- sum(step*initial$grad) prev <- initial deriv <- 1 ## only get derivatives immediately for initial step length while(TRUE) { ## step length control Alg 3.5 of N&W (2006, p60) beta <- as.numeric(ibeta) + trial$alpha*step b <- score(y=y,X=X,beta=beta,offset=offset,weights=weights,rS=rS,S.t=S.t,q=q,iv=iv, linkinv=linkinv,dev.resids=dev.resids,mu.eta=mu.eta,variance=variance) trial$pdev <- b$pdev if (deriv>0) { trial$grad <- b$grad trial$dscore <- sum(trial$grad*step) deriv <- 0 } else trial$grad <- trial$dscore <- NULL # rm(b) Wolfe2 <- TRUE ## check the first Wolfe condition (sufficient decrease)... if (trial$pdev > initial$pdev+c1*trial$alpha*initial$dscore||(deriv==0&&trial$pdev>=prev$pdev)) { trial <- zoom(prev,trial) ## Wolfe 1 not met so backtracking break } if (is.null(trial$dscore)) { ## getting gradients b <- score(y=y,X=X,beta=beta,offset=offset,weights=weights,rS=rS,S.t=S.t,q=q,iv=iv, linkinv=linkinv,dev.resids=dev.resids,mu.eta=mu.eta,variance=variance) trial$grad <- b$grad trial$dscore <- sum(trial$grad*step) } ## Note that written this way so that we can pass on to next test when appropriate... if (abs(trial$dscore) <= -c2*initial$dscore) break; ## `trial' is ok. (2nd Wolfe condition met). Wolfe2 <- FALSE if (trial$dscore>=0) { ## increase at end of trial step trial <- zoom(trial,prev) Wolfe2 <- if (is.null(trial)) FALSE else TRUE break } prev <- trial if (trial$alpha == alpha.max) break ## { trial <- NULL;break;} ## step failed trial <- list(alpha = min(prev$alpha*1.3, alpha.max)) ## increase trial step to try to meet Wolfe 2 } ## end of while(TRUE) ## Now `trial' contains a suitable step, or is NULL on complete failure to meet Wolfe, ## or contains a step that fails to meet Wolfe2, so that B can not be updated if (is.null(trial)) { ## step failed beta <- ibeta if (rolled.back) break ## failed to move, so nothing more can be done. ## check for working infinite beta params... uconv.ind <- abs(initial$grad) > score.scale*conv.tol*.1 if (sum(!uconv.ind)==0) break ## nothing to move back so nothing more can be done. trial <- initial ## reset to allow roll back converged <- TRUE ## only to signal that roll back should be tried } else { ## update the Hessian etc... yg <- trial$grad-initial$grad step <- step*trial$alpha rho <- sum(yg*step) if (rho>0) { #Wolfe2) { ## only update if Wolfe2 is met, otherwise B can fail to be +ve def. if (i==1) { ## initial step --- adjust Hessian as p143 of N&W B <- B * trial$alpha ## this is Simon's version ## B <- B * sum(yg*step)/sum(yg*yg) ## this is N&W } rho <- 1/rho # sum(yg*step) B <- B - rho*step%*%(t(yg)%*%B) ## Note that Wolfe 2 guarantees that rho>0 and updated B is ## +ve definite ... B <- B - rho*(B%*%yg)%*%t(step) + rho*step%*%t(step) } pdev.hist[i+1] <- trial$pdev beta <- ibeta <- ibeta + step ## test for convergence converged <- TRUE score.scale <- .1+abs(trial$pdev) ##abs(trial$scale.est) + abs(trial$score) uconv.ind <- abs(trial$grad) > score.scale*conv.tol if (sum(uconv.ind)) converged <- FALSE ## following must be tighter than convergence... uconv.ind <- abs(trial$grad) > score.scale*conv.tol*.1 if (abs(initial$pdev-trial$pdev) > score.scale*conv.tol) { if (!sum(uconv.ind)) uconv.ind <- uconv.ind | TRUE ## otherwise can't progress converged <- FALSE } } ## end of else { update the Hessian etc... ## roll back any `infinite' beta parameters to the point at ## which pen.deviance carries some information about them and continue ## optimization. Guards against early long steps missing shallow minimum. if (converged) { ## try roll back for `working inf' betas... if (sum(!uconv.ind)==0||rolled.back) break rolled.back <- TRUE counter <- 0 uconv.ind0 <- uconv.ind while (sum(!uconv.ind0)>0&&counter<5) { ## shrink towards initial values... beta[!uconv.ind0] <- beta[!uconv.ind0]*.8 + initial.beta[!uconv.ind0]*.2 b <- score(y=y,X=X,beta=beta,offset=offset,weights=weights,rS=rS,S.t=S.t,q=q,iv=iv, linkinv=linkinv,dev.resids=dev.resids,mu.eta=mu.eta,variance=variance) trial$pdev <- b$pdev trial$grad <- b$grad trial$dscore <- sum(trial$grad*step) rm(b);counter <- counter + 1 ## note that following rolls back until there is clear signal in derivs... uconv.ind0 <- abs(trial$grad) > score.scale*conv.tol*20 uconv.ind0 <- uconv.ind0 | uconv.ind ## make sure we don't start rolling back unproblematic betas } uconv.ind <- uconv.ind | TRUE ibeta <- as.numeric(beta) } initial <- trial initial$alpha <- 0 } ## end of iteration loop if (is.null(trial)) { ct <- "step failed" beta <- ibeta trial <- initial } else if (i==max.step) ct <- "iteration limit reached" else ct <- "full convergence" ## final pen. deviance calculation b <- score(y=y,X=X,beta=beta,offset=offset,weights=weights,rS=rS,S.t=S.t,q=q,iv=iv, linkinv=linkinv,dev.resids=dev.resids,mu.eta=mu.eta,variance=variance) pdev <- b$pdev; grad <- b$grad ## get approximate Hessian and its inverse... ev <- eigen(B,symmetric=TRUE) ind <- ev$values>max(ev$values)*.Machine$double.eps^.9 ev$values[ind] <- 1/ev$values[ind] ev$values[!ind] <- 0 inv.B <- ev$vectors %*% (ev$values*t(ev$vectors)) ## inverse of B ## now define things at their converged values from the quasi-Newton method... beta.t <- beta beta.t[iv] <- if (!not.exp) exp(beta[iv]) else notExp(beta[iv],b.notexp,th.notexp) ## values of re-para beta of the shape constrained terms eta <- as.numeric(X%*%beta.t + offset) mu <- linkinv(eta) dev <- sum(dev.resids(y,mu,weights)) Cdiag <- rep(1,q) Cdiag[iv] <- if (!not.exp) beta.t[iv] else DnotExp(beta[iv],b.notexp,th.notexp) X1 <- t(Cdiag*t(X)) g.deriv <- 1/mu.eta(eta) ## diag(G) w1 <- weights/(variance(mu)*g.deriv^2) ## diag(W1) alpha <- 1+(y-mu)*(dv$dvar(mu)/variance(mu)+dg$d2link(mu)/g.deriv) ## alpha elements of W w <- w1*alpha ## diag(W) abs.w <- abs(w) ## absolute values of the diag(W) (maybe no need to output?) normgrad.Dp <- max(abs(grad)) ## calculating edf and tr(A)... ## ISSUE: how to get approximate expected Hessian of unpenalized deviance ?????? ## calculation of the edf below is not correct ## B.unpen <- B-S.t ## approximate Hessian of unpenalized deviance ## ## force approx Hessian to be +ve def ... ## B.unpen <- (B.unpen+t(B.unpen))/2 ## ebu <- eigen(B.unpen,symmetric=TRUE) ## ebu2 <- ifelse(ebu$values < 0, 0, ebu$values) ## B.unpen <- ebu$vectors%*%(t(ebu$vectors)*ebu2) ## B.unpen <- B.unpen/sqrt(tcrossprod(diag(B.unpen))) ## edf <- rowSums(inv.B*t(B.unpen)) ## diagonal elements of inv.B%*%B.unpen ## trA <- sum(edf) ## calculating edf and tr(A) using analytical Hessian (taking 2nd order deriv of the log likelihood) ## as it is in scam.fit()... ## tr(A), dev, sig2 are needed for sp selection for efsudr.scam2()... I.plus <- rep(1,nobs) # define diagonal elements of the matrix I^{+} I.plus[w<0] <- -1 ## L <- c(1/alpha) # define diagonal elements of L=diag(1/alpha) ## question: should set alpha=1 so use expected Hessian? L <- 1 wX1<-sqrt(w1)[1:nobs]*X1 wX11<-rbind(wX1,rS) Q <- qr(wX11,LAPACK=TRUE) R <- qr.R(Q) rp <- 1:ncol(R) rp[Q$pivot] <- rp ## reverse pivot X=Q%*%R[,rp] R.out <- R[,rp] ## unpivoted R, needed for summary function rank <- Rrank(R) if (rank==ncol(R)) { ## no need to truncate, can just use QR P <- backsolve(R,diag(ncol(R)))[rp,] K <- qr.Q(Q)[1:nobs,] } else { ## need SVD step R <- R[,rp] ## unpivoted R s1 <- svd(R) d.inv1 <- rep(0,q) good1 <- s1$d >= max(s1$d)*.Machine$double.eps^.5 d.inv1[good1] <- 1/s1$d[good1] P <- t(d.inv1*t(s1$v)) K <- qr.qy(Q,rbind(s1$u,matrix(0,nobs,q)))[1:nobs,] } ## matrices wX1, P are needed for efsudr.scam2() for calculating derivatives ## of deviance and tr(A) w.r.t. log(sp) ... KtILQ1R <- crossprod(L*I.plus*K,wX1) ## t(L*I.plus*K)%*%wX1 edf <- rowSums(P*t(KtILQ1R)) trA <- sum(edf) scale.est <- dev/(nobs-trA) # scale estimate ## re-transforming 'mu' back on original scale and hence residuals, in case of correlated errors... residuals <- rep.int(NA, nobs) residuals <- (y-mu)*g.deriv ## some more of the return values.... dlink.mu <- 1/mu.eta(eta); Var<- variance(mu) # link <- family$linkfun(mu); d2link.mu <- dg$d2link(mu) # dvar.mu <- dv$dvar(mu); d2var.mu <- dv$d2var(mu) # d3link.mu <- dg$d3link(mu) # z <- g.deriv*(y-mu)+X1%*%beta ############################# ## derivatives of beta wrt rho[j] by the Implicit Function Theorem... dbeta.rho <- matrix(0,q,n.pen) # define matrix of the parameters derivatives if (n.pen>0) for (j in 1:n.pen) { dbeta.rho[,j] <- -sp[j]*inv.B%*%(S[[j]]%*%beta) } aic.model <- aic(y, n, mu, weights, dev) + 2*trA if (AR1.rho!=0) { ## correct aic for AR1 transform df <- 1 ## if (getARs) sum(b$model$"(AR.start)") else 1 aic.model <- aic.model - 2*(n-df)*log(ld) } assign("start",beta,envir=env) assign("dbeta.start",dbeta.rho,envir=env) assign("sp.last",sp,envir=env) } ### end if (!EMPTY) #list(L=L,C1diag=C1diag,E=E,iter=iter, # P=P,K=K, C2diag=C2diag, KtILQ1R= KtILQ1R, KtIQ1R=KtIQ1R, # dlink.mu=dlink.mu,Var=Var, abs.w=drop(abs.w), # link=link,w=as.numeric(w),w1=drop(w1),d2link.mu=d2link.mu,I.plus=I.plus, # dvar.mu=dvar.mu,d2var.mu=d2var.mu, # ok1=ok1,alpha=as.numeric(alpha),d3link.mu=d3link.mu,eta=eta,iter=iter, # Dp.gnorm=Dp.gnorm, Dp.g=Dp.g,d=d, conv=conv, illcond=illcond,R=R.out, edf=edf,trA=trA, # residuals=residuals,z=z,dbeta.rho=dbeta.rho, aic=aic.model,rank=rank) list(pdev=pdev,grad.Dp=grad,iter=i,conv =ct,old.beta=ibeta, ## B=B,inv.B=inv.B, gcv=dev*nobs/(nobs-gamma*trA)^2, sp=sp, Var=Var,dlink.mu=dlink.mu, mu=mu,X=G$X,y=drop(G$y), X1=X1,beta=beta,beta.t=beta.t,iv=iv,S=S,S.t=S.t,rS=rS, P=P,K=K,L=L,wX1=wX1, rank=rank, F=P%*%(KtILQ1R), w=as.numeric(w),w1=drop(w1), deviance=dev,scale.est=scale.est, normgrad.Dp=normgrad.Dp,edf=edf,trA=trA, residuals=residuals,dbeta.rho=dbeta.rho, aic=aic.model,pdev.hist=pdev.hist[!is.na(pdev.hist)] ) } ## end of scam.fit1 #################################################################################### ## function to get null deviance and covariance matrices after quasi-Newton fit ## #################################################################################### scam.fit.post1<- function(G, object) ##,sig2,offset,intercept, weights,scale.known, not.exp) { ## Function to compute null deviance and covariance matrices after a scam fit by scam.fit1(). ## object - object from estimate.scam() y <- G$y; X <- G$X; sig2 <- G$sig2; offset <- G$offset; intercept <- G$intercept; weights <- G$weights; scale.known <- G$scale.known nobs <- NROW(y) # number of observations q <- ncol(X) if (G$AR1.rho!=0) { ld <- 1/sqrt(1-G$AR1.rho^2) ## leading diagonal of root inverse correlation sd <- -G$AR1.rho*ld ## sub diagonal row <- c(1,rep(1:nobs,rep(2,nobs))[-c(1,2*nobs)]) weight.r <- c(1,rep(c(sd,ld),nobs-1)) end <- c(1,1:(nobs-1)*2+1) if (!is.null(G$AR.start)) { ## need to correct the start of new AR sections... ii <- which(G$AR.start==TRUE) if (length(ii)>0) { if (ii[1]==1) ii <- ii[-1] ## first observation does not need any correction weight.r[ii*2-2] <- 0 ## zero sub diagonal weight.r[ii*2-1] <- 1 ## set leading diagonal to 1 } } ## apply transform... X <- rwMatrix(end,row,weight.r,X) y <- rwMatrix(end,row,weight.r,y) } linkinv <- object$family$linkinv dev.resids <- object$family$dev.resids dg <- fix.family.link(object$family) dv <- fix.family.var(object$family) eta <- as.numeric(X%*%object$beta.t + offset) # linear predictor mu <- linkinv(eta) # fitted values dev <- sum(dev.resids(y,mu,weights)) # deviance of the final model wtdmu <- if (intercept) sum(weights * G$y)/sum(weights) else linkinv(offset) null.dev <- sum(dev.resids(G$y, wtdmu, weights)) n.ok <- nobs - sum(weights == 0) nulldf <- n.ok - as.integer(intercept) edf <- object$edf ## effective degrees of freedom trA <- sum(edf) edf1 <- 2*edf - rowSums(t(object$F)*object$F) ## alternative form (needed for reference degrees of freedom used in computing test statistic and the p-values, but since the null distributions are non-standard the reference df is not very interpretable????) ## calculating the approximate covariance matrices ## (dealing with the expected Hessian of the log likelihood) ... ## get the inverse of the expected Hessian... if (!scale.known) sig2 <- dev/(nobs-trA) # scale estimate Vb <- tcrossprod(object$P) * sig2 ## P%*%t(P)*sig2 # Bayesian posterior covariance matrix for the parameters Ve <- crossprod(object$K%*%t(object$P)) *sig2 #PKt%*%t(PKt)*sig2 # covariance matrix of the parameter estimators ## Delta method to get covariance matrix for the reparametrized parameters... df.p <- rep(1,q) df.p[object$iv] <- object$beta.t[object$iv] Vb.t <- t(df.p*t(df.p*Vb)) Ve.t <- t(df.p*t(df.p*Ve)) residuals <- rep.int(NA, nobs) g.deriv <- 1/object$family$mu.eta(eta) # diag(G) residuals <- (G$y-mu)*g.deriv # the working residuals for the fitted model aic.model <- object$family$aic(y, nobs, mu, weights, dev) + 2*trA if (G$AR1.rho!=0) { ## correct aic for AR1 transform df <- 1 ## if (getARs) sum(G$AR.start) else 1 aic.model <- aic.model - 2*(nobs-df)*log(1/sqrt(1-G$AR1.rho^2)) } list (null.dev=null.dev, df.null=nulldf,Vb=Vb,Vb.t=Vb.t,Ve=Ve,Ve.t=Ve.t,rank=object$rank, sig2=sig2,edf=edf,edf1=edf1, trA=trA, deviance=dev,residuals=residuals, aic=aic.model, mu=mu, eta=eta) } ## end of scam.fit.post1 scam/R/bivar.smooth.const-ti.R0000644000176200001440000003777615026260052015715 0ustar liggesusers## (c) Natalya Pya (2023). Provided under GPL 2. ## routines for bivariate tensor product smooth 'interactions' with ## shape constrains ####################################################################################### ## Tensor product 'interaction' P-spline construction with increasing constraint along the first ## covariate and unconstrained along the 2nd one... ####################################################################################### smooth.construct.tismi.smooth.spec<- function(object, data, knots) ## construction of the tensor product 'iteraction' bivariate smooth with ## single monotone increasing constraint wrt 1st covariate ... { if (!is.null(object$xt)){ if (!(object$xt %in% c("ps", "cc")) ) stop("only 'ps' and 'cc' marginal basis are supported") else bs2 <- object$xt ## basis for the marginal smooth along second direction } else bs2 <- "ps" if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) {m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths object$p.order <- m } else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) object$p.order[is.na(object$p.order)] <- 2 if (object$bs.dim[1]==-1) { # set the default values for q1 and q2 q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1){ q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths object$bs.dim <- rep(object$bs.dim, 2) } else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth if (bs2=="cc") nk2 <- q2+1 else nk2 <- q2+m[2]+2 ## number of knots for the 2nd smooth in case of p-splines if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied if (is.null(xk)) # space knots through the values of the 1st covariate { xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} knots[[object$term[1]]] <- xk } n<-length(x) if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)){ # space knots through the values of the 2nd covariate if (bs2=="cc") { zk <- place.knots(z,nk2) if (length(zk)==2) { zk <- place.knots(c(zk,z),nk2) } } else{ zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} knots[[object$term[2]]] <- zk } } if (length(xk)!=nk1 ) # right number of knots? stop(paste("there should be ",nk1," supplied knotsfor the x")) if (length(zk)!=nk2) # right number of knots? stop(paste("there should be ",nk2," supplied knots for z")) # get model matrix------------- # get marginal model matrices and penalties... if (bs2=="cc") bm <- marginal.matrices.tesmi1.cc(x,z,xk,zk,m,q1,q2) else bm <- marginal.matrices.tesmi1.ps(x,z,xk,zk,m,q1,q2) X1 <- bm$X1 X2 <- bm$X2 ## S <- bm$S # get a matrix Sigma ----------------------- IS <- matrix(1,q1,q1) ## coef summation matrix IS[upper.tri(IS)] <-0 X1 <- X1%*%IS X1 <- X1[,-1] ## apply scop indentifiability constraint on the marginal # cmx <- colMeans(X2) # X2 <- sweep(X2,2,cmx) ## apply centering constraint for the unconstrained marginal # object$cmX <- cmx X2 <- X2[,-1] X <- matrix(0,n,(q1-1)*(q2-1)) ## tensor product model matrix # X <- matrix(0,n,q1*(q2-1)) for (i in 1:n) X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices # IS <- matrix(1,q1,q1) ## coef summation matrix # IS[upper.tri(IS)] <-0 # I <- diag(q2) # Sig <- IS%x%I # X <- X%*%Sig ## RE-CONSIDERed D and Penalties, to have no extra constraints!! # apply scop identifiability constraint... # D <- diag(q1*q2) # D <- D[,-q2] # D1 <- t(diff(diag(q2))) # D[1:q2,1:(q2-1)] <- D1 # X <- X%*%D # define identifiability constraint matrix to be used when predicting: # D removes the first q2 columns of X and also columns with ind as set below... D <- diag(q1*q2) D <- D[,-c(1:q2)] ind <- rep(0,q1-1) # get index number for the columns of X to be removed for (i in 1:(q1-1)) ind[i] <- (i-1)*q2+1 D <- D[,-ind] object$X <- X # the final model matrix with identifiability constraint ## create the penalty matrix... NEED here rather than from marginal.matrices.tesmi1.ps() used for X and S ## since identifiability constraints were applied on the marginal smooths S <- list() # get the penalty matrix for the first monotone marginal... I2<- diag(q2-1) P <- diff(diag(q1-1),difference=1) Pm1 <- matrix(0,q1-2,q1-1) # marginal sqrt penalty Pm1[1:(q1-2),1:(q1-1)] <- P S[[1]]<- Pm1%x%I2 S[[1]] <- crossprod(S[[1]]) ## t(S[[1]])%*%S[[1]] # get penalty for the 2nd marginal... I2 <- diff(diag(q2-1),difference=1) I21<- diff(diag(q2-1),difference=2) I1 <- diag(q1-1) S[[2]] <-matrix(0,q2-3+(q1-2)*(q2-2), (q1-1)*(q2-1)) S[[2]][1:(q2-3),] <- t(I1[1,])%x%I21 S[[2]][(q2-2):nrow(S[[2]]),] <- I1[2:(q1-1),]%x%I2 S[[2]] <- crossprod(S[[2]]) ## t(S[[2]])%*%S[[2]] object$S <- list() # object$S[[1]] <- crossprod(D,S[[1]])%*%D ## t(D)%*%S[[1]]%*%D # object$S[[2]] <- crossprod(D,S[[2]])%*%D ## t(D)%*%S[[2]]%*%D object$S[[1]] <- S[[1]] object$S[[2]] <- S[[2]] object$p.ident <- rep(TRUE,(q1-1)*(q2-1)) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$p.ident[1:(q2-1)] <- rep(FALSE, q2-1) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- D # identifiability constraint matrix ## store "tismi" specific stuff ... object$knots <- list() object$knots[[1]] <- xk if (is.null(zk)) object$knots[[2]] <- rep(0,0,0) else object$knots[[2]] <- zk object$m <- m object$margin.bs <- bs2 object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"tismi.smooth" # Give object a class object } ## Prediction matrix for the `tismi` smooth class ************************* Predict.matrix.tismi.smooth<-function(object,data) ## prediction method function for the `tesmi1' smooth class { if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (!is.null(object$xt)) bs2 <- object$xt ## basis for the marginal smooth along second direction else bs2 <- "ps" if (bs2=="cc") bm <- marginal.linear.extrapolation.tesmi1.cc(object, data) else bm <- marginal.linear.extrapolation(object, data) n <- length(data[[object$term[1]]]) IS <- matrix(1,q1,q1) ## coef summation matrix IS[upper.tri(IS)] <-0 X1 <- bm$X1%*%IS X2 <- bm$X2 # X2 <- sweep(X2,2,object$cmX) ## apply centering constraint for the unconstrained marginal X <- matrix(0,n,q1*q2) ## tensor product model matrix for (i in 1:n) X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices X # return the prediction matrix } ####################################################################################### ## Tensor product 'interaction' P-spline construction with decreasing constraint along the first ## covariate and unconstrained along the 2nd one... ####################################################################################### smooth.construct.tismd.smooth.spec<- function(object, data, knots) ## construction of the tensor product 'iteraction' bivariate smooth with ## single monotone decreasing constraint wrt 1st covariate ... { if (!is.null(object$xt)){ if (!(object$xt %in% c("ps", "cc")) ) stop("only 'ps' and 'cc' marginal basis are supported") else bs2 <- object$xt ## basis for the marginal smooth along second direction } else bs2 <- "ps" ## (only "ps" and 'cc' available currently) if (object$dim !=2) stop("the number of covariates should be two") if (length(object$p.order)==1) { m <- rep(object$p.order, 2) # if a single number is supplied the same ## order of P-splines is provided for both marginal smooths object$p.order <- m } else m <- object$p.order m[is.na(m)] <- 2 # the default order is 2 (cubic P-spline) object$p.order[is.na(object$p.order)] <- 2 if (object$bs.dim[1]==-1) # set the default values fro q1 and q2 { q1 <- object$bs.dim[1] <- 7 q2 <- object$bs.dim[2] <- 7 } else if (length(object$bs.dim)==1) { q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths object$bs.dim <- rep(object$bs.dim, 2) } else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (is.na(q1)) q1 <- object$bs.dim[1] <- 7 # the default basis dimension is 7 if (is.na(q2)) q2 <- object$bs.dim[2] <- 7 nk1 <- q1+m[1]+2 ## number of knots for the 1st smooth if (bs2=="cc") nk2 <- q2+1 else nk2 <- q2+m[2]+2 ## number of knots for the 2nd smooth in case of p-splines if (nk1<=0 || nk2<=0) stop("either k[1] or k[2] too small for m") ## the values of the first covariate... x <- data[[object$term[1]]] xk <- knots[[object$term[1]]] ## will be NULL if none supplied z <- data[[object$term[2]]] ## the values of the second covariate zk <- knots[[object$term[2]]] ## will be NULL if none supplied if (is.null(xk)) # space knots through the values of the 1st covariate { xk<-rep(0,q1+m[1]+2) xk[(m[1]+2):(q1+1)]<-seq(min(x),max(x),length=q1-m[1]) for (i in 1:(m[1]+1)) {xk[i]<-xk[m[1]+2]-(m[1]+2-i)*(xk[m[1]+3]-xk[m[1]+2])} for (i in (q1+2):(q1+m[1]+2)) {xk[i]<-xk[q1+1]+(i-q1-1)*(xk[m[1]+3]-xk[m[1]+2])} knots[[object$term[1]]] <- xk } n<-length(x) if (n != length(z)) stop ("arguments of smooth not same dimension") if (is.null(zk)){ # space knots through the values of the 2nd covariate if (bs2=="cc") { zk <- place.knots(z,nk2) if (length(zk)==2) { zk <- place.knots(c(zk,z),nk2) } } else{ zk<-rep(0,q2+m[2]+2) zk[(m[2]+2):(q2+1)]<-seq(min(z),max(z),length=q2-m[2]) for (i in 1:(m[2]+1)) {zk[i]<-zk[m[2]+2]-(m[2]+2-i)*(zk[m[2]+3]-zk[m[2]+2])} for (i in (q2+2):(q2+m[2]+2)) {zk[i]<-zk[q2+1]+(i-q2-1)*(zk[m[2]+3]-zk[m[2]+2])} knots[[object$term[2]]] <- zk } } if (length(xk)!=nk1 ) # right number of knots? stop(paste("there should be ",nk1," supplied knotsfor the x")) if (length(zk)!=nk2) # right number of knots? stop(paste("there should be ",nk2," supplied knots for z")) # get model matrix------------- # get marginal model matrices and penalties... if (bs2=="cc") bm <- marginal.matrices.tesmi1.cc(x,z,xk,zk,m,q1,q2) else bm <- marginal.matrices.tesmi1.ps(x,z,xk,zk,m,q1,q2) X1 <- bm$X1 X2 <- bm$X2 # get a matrix Sigma ----------------------- IS <- matrix(-1,q1,q1) ## coef summation matrix IS[upper.tri(IS)] <-0 IS[,1] <- -IS[,1] X1 <- X1%*%IS ## apply scop indentifiability constraint on the marginal... X1 <- X1[,-1] # cmx <- colMeans(X2) # X2 <- sweep(X2,2,cmx) ## apply centering constraint for the unconstrained marginal # object$cmX <- cmx X2 <- X2[,-1] ## apply zero-intercept constraint X <- matrix(0,n,(q1-1)*(q2-1)) ## tensor product model matrix for (i in 1:n) X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices # define matrix of identifiability constraints, D, to be used when predicting... # D removes the first q2 columns of X and also columns with ind as set below... D <- diag(q1*q2) D <- D[,-c(1:q2)] ind <- rep(0,q1-1) # get index number for the columns of X to be removed for (i in 1:(q1-1)) ind[i] <- (i-1)*q2+1 D <- D[,-ind] object$X <- X # the final model matrix with identifiability constraint ## create the penalty matrix... NEED here rather than from marginal.matrices.tesmi1.ps() used for X and S ## since identifiability constraints were applied on the marginal smooths S <- list() # get the penalty matrix for the first monotone smooth... I2<- diag(q2-1) P <- diff(diag(q1-1),difference=1) Pm1 <- matrix(0,q1-2,q1-1) # marginal sqrt penalty Pm1[1:(q1-2),1:(q1-1)] <- P S[[1]]<- Pm1%x%I2 S[[1]] <- crossprod(S[[1]]) ## t(S[[1]])%*%S[[1]] ## get penalty for the 2nd marginal smooth... I2 <- diff(diag(q2-1),difference=1) I21<- diff(diag(q2-1),difference=2) I1 <- diag(q1-1) S[[2]] <-matrix(0,q2-3+(q1-2)*(q2-2), (q1-1)*(q2-1)) S[[2]][1:(q2-3),] <- t(I1[1,])%x%I21 S[[2]][(q2-2):nrow(S[[2]]),] <- I1[2:(q1-1),]%x%I2 S[[2]] <- crossprod(S[[2]]) ## t(S[[2]])%*%S[[2]] object$S <- list() object$S[[1]] <- S[[1]] object$S[[2]] <- S[[2]] object$p.ident <- rep(TRUE,(q1-1)*(q2-1)) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X)-1 # penalty rank object$null.space.dim <- 3 ## dim. of unpenalized space object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$Zc <- D # identifiability constraint matrix ## store "tismd" specific stuff ... object$knots <- list() object$knots[[1]] <- xk if (is.null(zk)) object$knots[[2]] <- rep(0,0,0) else object$knots[[2]] <- zk object$m <- m object$margin.bs <- bs2 object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object) <- "tismd.smooth" # Give object a class object } ########################################################################### ## Prediction matrix for the `tismd` smooth class ************************* Predict.matrix.tismd.smooth<-function(object,data) { ## prediction method function for the `tismd1' smooth class if (length(object$bs.dim)==1) q1 <- q2 <- object$bs.dim # if `k' is supplied as a single number, the same ## basis dimension is provided for both marginal smooths else {q1 <- object$bs.dim[1]; q2 <- object$bs.dim[2]} if (!is.null(object$xt)) bs2 <- object$xt ## basis for the marginal smooth along second direction else bs2 <- "ps" if (bs2=="cc") bm <- marginal.linear.extrapolation.tesmi1.cc(object, data) else bm <- marginal.linear.extrapolation(object, data) n <- length(data[[object$term[1]]]) # get a matrix Sigma ----------------------- IS <- matrix(-1,q1,q1) ## coef summation matrix IS[upper.tri(IS)] <-0 IS[,1] <- -IS[,1] X1 <- bm$X1%*%IS X2 <- bm$X2 # X2 <- sweep(X2,2,object$cmX) ## apply centering constraint for the unconstrained marginal X <- matrix(0,n,q1*q2) # tensor product model matrix for (i in 1:n) X[i,] <- X1[i,]%x%X2[i,] # Kronecker product of two rows of marginal model matrices X # return the prediction matrix } scam/R/uni.smooth.const-lscop.r0000644000176200001440000003151615067154432016144 0ustar liggesusers## (c) Natalya Pya (2025). Provided under GPL 2. ## routines for univariate local SCOP-spline construction, LSOP-spline, ## in collaboration with Jens Lichter and Thomas Kneib, University of Gottingen, for a spline construction that is monotone increasing up until the change point ##################################################### ### Local monotone increasing LSCOP-spline construction, increasing up until the change point, xc, ###################################################### ## building B-spline bases functions over the whole range of x ## and making m knots at xc change point ... smooth.construct.lmpi.smooth.spec<- function(object, data, knots) ## construction of the monotone increasing smooth ## xc specifies a change point ## scop-spline up until xc and unconstrained p-spline from xc, ## using ceiling(q/2) basis functions for both parts { m <- object$p.order[1] if (is.na(m)) m <- 2 ## default for cubic spline if (m<1) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim ## q1 <- q2 <- ceiling(q/2) ## basis dimension for each part xc <- object$xt$xc ## a change point x <- data[[object$term]] ## the data rg <- range(x) share <- (xc-rg[1])/(rg[2]-rg[1]) ## share of the x values up untill the change point q1 <- max(ceiling(q*share),5) ## basis dimension for the constrained part q2 <- max((q-q1),5) n <- length(x) nk <- q1+q2+1 ## number of knots if (nk<=0) stop("k too small for m") xk <- knots[[object$term]] ## will be NULL if none supplied if (!is.null(xk)) ## if not NULL stop(paste("'lmpi' smooth currenly does not work with user-supplied knots")) if (is.null(xc)) stop(paste("a change point 'xc' is not supplied")) ## getting equally spaced knots from both sides of the change point... xk <- rep(NA,q1+q2+1+1) xk[(m+2):(q1+1)] <- seq(rg[1],xc,length=q1-m) ## inner knots for the constrained part (to the left from the change point) xk[(q1+1):(q1+q2-m+1)] <- seq(xc,rg[2],length=q2-m+1) ## inner knots for the unconstrained part (to the right from the change point), add one knot more than for the constrained part, as otherwise there 5 basis functions for the constrained part and only 3 for the unconstrained for (i in 1:(m+1)) ## outer knots on the left-hand-side of the x range xk[i] <- xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2]) for (i in (q1+q2-m+2):(q1+q2+2)) ## outer knots on the right-hand-side of the x range xk[i] <- xk[q1+q2-m]+(i-q1-q2+m)*(xk[q1+2]-xk[q1+1]) xk <- c(xk[which(xk < xc)],rep(xc,m),xk[which(xk > xc)]) ## including xc change point m times if (!is.null(object$point.con[[1]])) ## a point constraint is supplied? stop(paste("'lmpi' smooth does not work with a point constraint; use 'miso' for a start-at-zero constraint, or 'mifo' for a finish-at-zero constraint")) ## get model matrix... X <- splineDesign(xk,x,ord=m+2) Sig1 <- matrix(1,q1,q1) ## coef summation matrix Sig1[upper.tri(Sig1)] <- 0 q.t <- ncol(X) ## number of coefficients of the final lscop-spline, which is (q-2) Sig <- matrix(0,q.t,q.t) Sig[1:q1,1:q1] <- Sig1 Sig[(q1+1):q.t,(q1+1):q.t] <- diag(1,q.t-q1) X <- X%*%Sig ## applying sum-to-zero (centering) constraint... cmx <- colMeans(X) X <- sweep(X,2,cmx) ## subtract cmx from columns object$X <- X # the final model matrix object$cmX <- cmx object$P <- list() object$S <- list() object$Sigma <- Sig if (!object$fixed) { # P <- diff(diag(q.t-1),difference=1) # P <- rbind(rep(0,q.t-1),P) ## adding 1st row of zeros # P <- cbind(rep(0,q.t-1),P) ## adding first column of zeros ## making 1st order difference penalty for the constrained part and 2nd order diff-s for the unconstrained P <- matrix(0,q.t-3,q.t) d1 <- diff(diag(q1),difference=1) P[2:(q1),2:(q1+1)] <- d1 d1 <- diff(diag(q.t-q1-1),difference=2) P[(q1+1):(q.t-3),(q1+2):q.t] <- d1 object$P[[1]] <- P object$S[[1]] <- crossprod(P) ## create a block diagonal penalty matrix, penalizing separately constrained and unconstrained parts ## block diagonal penalty showed slightly worse mse when compared on two simul. examples ... ## penalty for the constrained first part # P <- matrix(0,q.t-2,q.t) # matrix(0,q.t-1,q.t) # d1 <- diff(diag(q1-1),difference=1) # P[2:(q1-1),2:q1] <- d1 # # P[q1:(q.t-1),(q1+1):q.t] <-diag(1,(q.t-q1)) # P[q1:(q.t-2),(q1+1):(q.t-1)] <-diag(1,(q.t-q1-1)) # object$P[[1]] <- P # object$S[[1]] <- crossprod(P) # ## block for the unconstrained second part... # P <- matrix(0,q.t-2,q.t) # matrix(0,q.t-1,q.t) # d1 <- diff(diag(q.t-q1),difference=2) # P[(q1+1):(q.t-2),(q1+1):q.t] <- d1 # object$P[[2]] <- P # object$S[[2]] <- crossprod(P) } object$p.ident <- c(FALSE,rep(TRUE,q1-1),rep(FALSE,q.t-q1)) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$rank <- ncol(object$X) # penalty rank object$null.space.dim <- 2 ## ##m+1 # dim. of unpenalized space, 2 as the basis of a straight line is two-dimensional object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$knots <- xk; object$m <- m; object$df<-ncol(object$X) # maximum DoF object$q1 <- q1 ## get model matrix for 1st and 2nd derivatives of the smooth... h <- xk[m+3]-xk[m+2] ## distance between two adjacent knots object$Xdf1 <- splineDesign(xk,x,ord=m+1)[,1:(q.t-1)]/h ## ord is by one less for the 1st derivative object$Xdf2 <- splineDesign(xk,x,ord=m)[,1:(q.t-2)]/h^2 ## ord is by two less for the 2nd derivative class(object)<-"lmpi.smooth" # Give object a class object } ## Prediction matrix for the `lmpi` smooth class... Predict.matrix.lmpi.smooth<-function(object,data) ## prediction method function for the `mpi' smooth class { m <- object$m # spline order, m+1=3 default for cubic spline q <- object$df q1 <- object$q1 ## basis dimention for the constrained part x <- data[[object$term]] Sig1 <- matrix(1,q1,q1) ## coef summation matrix Sig1[upper.tri(Sig1)] <-0 Sig <- matrix(0,q,q) Sig[1:q1,1:q1] <- Sig1 Sig[(q1+1):q,(q1+1):q] <- diag(1,q-q1) ## find spline basis inner knot range... ll <- object$knots[m+2];ul <- object$knots[length(object$knots)-m-1] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) ## all in range X <- spline.des(object$knots,x,m+2)$design else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m+2,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m+2)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] } X <- X%*%Sig X <- sweep(X,2,object$cmX) X } ##################################################### ### Local monotone increasing LSCOP-spline construction: ### increasing up until the change point, xc, and reaching a plateau from xc ###################################################### smooth.construct.lipl.smooth.spec<- function(object, data, knots) ## construction of the monotone increasing smooth ## xc specifies a change point ## scop-spline up until xc and a plateau from xc, { m <- object$p.order[1] if (is.na(m)) m <- 2 ## default for cubic spline if (m<1) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default q <- object$bs.dim ## q1 <- q2 <- ceiling(q/2) ## basis dimention for each part xc <- object$xt$xc ## a change point x <- data[[object$term]] ## the data rg <- range(x) share <- (xc-rg[1])/(rg[2]-rg[1]) ## share of the x values up untill the change point q1 <- max(ceiling(q*share),5) ## basis dimention for the constrained part q2 <- max((q-q1),5) n <- length(x) nk <- q1+q2+1 ## number of knots if (nk<=0) stop("k too small for m") xk <- knots[[object$term]] ## will be NULL if none supplied if (!is.null(xk)) ## if not NULL stop(paste("'lipl' smooth currenly does not work with user-supplied knots")) if (is.null(xc)) stop(paste("a change point 'xc' is not supplied")) ## getting equally spaced knots from both sides of the change point... xk <- rep(NA,q1+q2+1+1) xk[(m+2):(q1+1)] <- seq(rg[1],xc,length=q1-m) ## inner knots for the constrained part (to the left from the change point) xk[(q1+1):(q1+q2-m+1)] <- seq(xc,rg[2],length=q2-m+1) ## inner knots for the unconstrained part (to the right from the change point), add one knot more than for the constrained part, as otherwise there more (min 5) basis functions for the constrained part and less (only 3) for the unconstrained for (i in 1:(m+1)) ## outer knots on the left-hand-side of the x range xk[i] <- xk[m+2]-(m+2-i)*(xk[m+3]-xk[m+2]) for (i in (q1+q2-m+2):(q1+q2+2)) ## outer knots on the right-hand-side of the x range xk[i] <- xk[q1+q2-m]+(i-q1-q2+m)*(xk[q1+2]-xk[q1+1]) xk <- c(xk[which(xk < xc)],rep(xc,m),xk[which(xk > xc)]) ## including xc change point m times if (!is.null(object$point.con[[1]])) ## a point constraint is supplied? stop(paste("'lipl' smooth does not work with a point constraint; use 'miso' for a start-at-zero constraint, or 'mifo' for a finish-at-zero constraint")) ## get model matrix... X <- splineDesign(xk,x,ord=m+2) q.t <- ncol(X) # number of coefficients of the final lscop-spline Sig <- matrix(1,q.t,q.t) Sig[upper.tri(Sig)] <-0 X <- X%*%Sig X <- X[,-c(1,q1:q.t)] # removing (zeroing the last (q.t-q1+1) spline coefficients) columns ## Sig1 <- matrix(1,q1,q1) # coef summation matrix ## Sig1[upper.tri(Sig1)] <- 0 ## Sig <- matrix(0,q.t,q.t) ## Sig[1:q1,1:q1] <- Sig1 ## X <- X%*%Sig ## X <- X[,-c((q1+1):q.t)] cmx <- colMeans(X) X <- sweep(X,2,cmx) # subtract cmx from columns q1 <- q1-1 # since the last coefficient of the constrained part is zeroed as well object$X <- X # the final model matrix ## object$cmX <- rep(0,q.t) object$cmX <- c(0,cmx, rep(0,q.t-q1)) object$P <- list() object$S <- list() object$Sigma <- Sig if (!object$fixed) { ## making 1st order difference penalty for the constrained part and... ## P <- matrix(0,q1-1,q1) ## d1 <- diff(diag(q1-1),difference=1) ## P[2:(q1-1),2:(q1)] <- d1 ## object$P[[1]] <- P ## object$S[[1]] <- crossprod(P) P <- diff(diag(q1-1),difference=1) object$P[[1]] <- P object$S[[1]] <- crossprod(P) } ## object$p.ident <- c(FALSE,rep(TRUE,q1-1)) ## c(FALSE,rep(TRUE,q1-1)) ## p.ident is an indicator of which coefficients must be positive (exponentiated) object$p.ident <- rep(TRUE,q1-1) object$n.zero.col <- q.t-q1 ## number of zeroed coeff/columns removed, needed to be added in predict and plot functions object$rank <- ncol(object$X) # penalty rank object$null.space.dim <- 2 ## ##m+1 # dim. of unpenalized space, 2 as the basis of a straight line is two-dimensional object$C <- matrix(0, 0, ncol(X)) # to have no other constraints object$knots <- xk; object$m <- m; object$df<- ncol(object$X) # maximum DoF object$q1 <- q1 class(object)<-"lipl.smooth" # Give object a class object } ## with "lipl", when outputting (model$coefficients) only the estimated smooth coefficients are printed, no 0's coefficients shown ## Prediction matrix for the `lipl` smooth class... Predict.matrix.lipl.smooth<-function(object,data) ## prediction method function for the `mpi' smooth class { m <- object$m # spline order, m+1=3 default for cubic spline q1 <- object$q1 ## basis dimention for the constrained part x <- data[[object$term]] ## find spline basis inner knot range... ll <- object$knots[m+2];ul <- object$knots[length(object$knots)-m-1] n <- length(x) ind <- x<=ul & x>=ll ## data in range if (sum(ind)==n) ## all in range X <- spline.des(object$knots,x,m+2)$design else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- spline.des(object$knots,c(ll,ll,ul,ul),m+2,c(0,1,0,1))$design X <- matrix(0,n,ncol(D)) ## full predict matrix if (sum(ind)> 0) X[ind,] <- spline.des(object$knots,x[ind],m+2)$design ## interior rows ## Now add rows for linear extrapolation... ind <- x < ll if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ll)%*%D[1:2,] ind <- x > ul if (sum(ind)>0) X[ind,] <- cbind(1,x[ind]-ul)%*%D[3:4,] } q.t <- ncol(X) ## number of coefficients of the final lscop-spline Sig <- matrix(1,q.t,q.t) Sig[upper.tri(Sig)] <-0 X <- X%*%Sig X <- sweep(X,2,object$cmX) X } scam/R/estimate.scam.R0000644000176200001440000007532415026260052014267 0ustar liggesusers## (c) Natalya Pya (2012-2023). Released under GPL2. ## efsudr.scam based on (c) Simon N Wood (efsudr(mgcv)) ######################################################### # Function to return gcv/ubre ... ## ######################################################### gcv.ubre <- function(rho,G,env,control) { ## function to get GCV.UBRE value for optim()... if (length(rho)!= length(G$off)) stop (paste("length of rho and n.terms has to be the same")) sp <- exp(rho) b <- scam.fit(G=G, sp=sp, env=env,control=scam.control()) if (G$scale.known) # value of Mallow's Cp/UBRE/AIC .... { n <- nrow(G$X) gcv.ubre <- b$dev/n - G$sig2 +2*G$gamma*b$trA*G$sig2/n } else # value of GCV ... gcv.ubre <- b$gcv return(gcv.ubre) } ######################################################### ## function to get the gradient of the gcv/ubre..... ## ######################################################### gcv.ubre.derivative <- function(rho,G, env, control) { ## function to return derivative of GCV or UBRE for optim... gcv.ubre_grad(rho, G, env, control=control)$gcv.ubre.rho } ############################################################################# ## for nlm() function to get the gcv/ubre and gradient of the gcv/ubre.....## ############################################################################# dgcv.ubre.nlm <- function(rho,G, env, control) { ## GCV UBRE objective function for nlm gg <- gcv.ubre_grad(rho, G, env, control=control) attr(gg$gcv.ubre,"gradient") <- gg$gcv.ubre.rho gg$gcv.ubre } ####################################################### #### estimate.scam().... ## ####################################################### estimate.scam <- function(G,optimizer,optim.method,rho, env, control) ## check.analytical, del, devtol.fit, steptol.fit) ## function to select smoothing parameter by minimizing GCV/UBRE criterion... { ## set 'newton' method for coeff estimation if not specified ## (it can happen if 'optimizer' was supplied with one element, specifying ## the sp optimization method to use as, e.g., 'optimizer="efs") if (is.na(optimizer[2])) optimizer[2] <- "newton" if (!(optimizer[2] %in% c("newton", "bfgs")) ) stop("unknown optimization method to use for the model coefficient estimation") if (optimizer[2]== "bfgs") if (optimizer[1] !="efs") { warning("`bfgs` method for the coefficient estimation works only together with `efs` method; `efs' was used") optimizer[1] <- "efs" } if (!(optimizer[1] %in% c("bfgs", "nlm", "optim","nlm.fd","efs")) ) stop("unknown optimization method to use to optimize the smoothing parameter estimation criterion") if (length(rho)==0) { ## no sp estimation to do -- run a fit instead optimizer[1] <- "no.sps" ## will cause scam.fit/scam.fit1 to be called, below } if (optimizer[1] == "bfgs") {## minimize GCV/UBRE by BFGS... b <- bfgs_gcv.ubre(gcv.ubre_grad,rho=rho, G=G,env=env, control=control) ## check.analytical=check.analytical, del=del,devtol.fit=devtol.fit, steptol.fit=steptol.fit) sp <- exp(b$rho) object <- b$object object$gcv.ubre <- b$gcv.ubre object$dgcv.ubre <- b$dgcv.ubre object$termcode <- b$termcode object$check.grad <- b$check.grad object$dgcv.ubre.check <- b$dgcv.ubre.check object$conv.bfgs <- b$conv.bfgs object$iterations <- b$iterations object$score.hist <- b$score.hist } else if (optimizer[1]=="optim"){ ## gr=gcv.ubre.derivative if (!(optim.method[1] %in% c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SANN"))) { warning("unknown optim() method, `L-BFGS-B' were used") optim.method[1] <- "L-BFGS-B" } if (is.na(optim.method[2])) { warning("the second parameter of optim.method argument is not supplied, finite-difference approximation of the gradient were used") grr <- NULL } else if (!(optim.method[2] %in% c("fd","grad"))) { warning("only `fd' and `grad' options are possible, finite-difference approximation of the gradient were used") grr <- NULL } else if (optim.method[2] == "grad") grr <- gcv.ubre.derivative else grr <- NULL b <- optim(par=rho,fn=gcv.ubre, gr=grr, method=optim.method[1],G=G, control= list(factr=control$optim$factr,lmm=min(5,length(rho))), env=env) sp <- exp(b$par) gcv.ubre <- b$value dgcv.ubre <- NULL iterations <- b$counts termcode <- b$convergence if (termcode == 0) conv <- "Successful completion" else if (termcode == 1) conv <- "The iteration limit `maxit' had been reached" else if (termcode == 10) conv <- "Degeneracy of the Nelder-Mead simplex" else if (termcode == 51) conv <- "A warning from the `L-BFGS-B' method; see help for `optim' for further details" else if (termcode == 52) conv <- "An error from the `L-BFGS-B' method; see help for `optim' for further details" } else if (optimizer[1]=="nlm.fd") {## nlm() with finite difference derivatives... b <- nlm(f=gcv.ubre, p=rho,typsize=rho, stepmax = control$nlm$stepmax, ndigit = control$nlm$ndigit, gradtol = control$nlm$gradtol, steptol = control$nlm$steptol, iterlim = control$nlm$iterlim, G=G, env=env, control=control) } else if (optimizer[1]=="nlm"){ ## nlm() with analytical derivatives... b <- nlm(f=dgcv.ubre.nlm, p=rho,typsize=rho, stepmax = control$nlm$stepmax, ndigit = control$nlm$ndigit, gradtol = control$nlm$gradtol, steptol = control$nlm$steptol, iterlim = control$nlm$iterlim, G=G,env=env, control=control) } else if (optimizer[1]=="efs"){ ## Extended Fellner-Schall method ## if bfgs method is used for model coeff. estimation, the inner fit function is scam.fit1(), ## if newton method then the fit function is scam.fit()... fit.fn <- if (optimizer[2]== "bfgs") scam.fit1 else scam.fit b <- efsudr.scam2(fit.fn=fit.fn,G=G,lsp=rho,env=env, control=control) sp <- b$sp object <- b object$gcv.ubre <- b$gcv.ubre object$outer.info <- b$outer.info object$inner.info <- b$inner.info ## if (optimizer[2]== "bfgs") { ## bfgs method for the model coeff. estimation ## b <- efsudr.scam2(G=G,lsp=rho,env=env, control=control) ## sp <- b$sp ## object <- b ## # object$iterations <- b$niter ## # object$conv <- b$outer.info$conv ## # object$score.hist <- b$outer.info$score.hist ## object$gcv.ubre <- b$gcv.ubre ## object$outer.info <- b$outer.info ## object$inner.info <- b$inner.info ## } else { ## newton method for the model coeff. estimation ## b <- efsudr.scam(G=G,lsp=rho,env=env, control=control) ## ## b <- efsudr.scam1(G=G,lsp=rho,env=env, control=control) ## sp <- b$sp ## object <- b ## object$gcv.ubre <- b$gcv.ubre ## object$outer.info <- b$outer.info ## object$inner.info <- b$inner.info ## } } ## get some convergence info from the optimization method used... if (optimizer[1]== "nlm.fd" || optimizer[1]== "nlm"){ sp <- exp(b$estimate) gcv.ubre <- b$minimum dgcv.ubre <- b$gradient iterations <- b$iterations termcode <- b$code if (termcode == 1) conv <- "Relative gradient is close to zero, current iterate is probably solution" else if (termcode == 2) conv <- "Successive iterates within tolerance, current iterate is probably solution" else if (termcode == 3) conv <- "Last global step failed to locate a point lower than `estimate'. Either `estimate' is an approximate local minimum of the function or `steptol' is too small" else if (termcode == 4) conv <- "Iteration limit exceeded" else if (termcode == 5) conv <- "Maximum step size `stepmax' exceeded five consecutive times. Either the function is unbounded below, becomes asymptotic to a finite value from above in some direction or stepmax is too small" } ## fit the model using the optimal sp from "optim" or "nlm"... if (optimizer[1]== "nlm.fd" || optimizer[1]== "nlm" || optimizer[1]== "optim"){ object <- scam.fit(G=G, sp=sp,env=env,control=control) object$conv <- object$conv object$gcv.ubre <- gcv.ubre object$dgcv.ubre <- dgcv.ubre object$outer.info <- list(termcode=termcode,conv=conv,iterations=iterations) } else if (optimizer[1]=="no.sps"){ # object <- scam.fit(G=G, sp=exp(rho),env=env,control=control) sp <- G$sp object <- if (optimizer[2] == "newton") scam.fit(G=G, sp=sp,env=env, control=control) else scam.fit1(G=G, sp=sp,env=env, control=control) ## BFGS optimization # object$optimizer[1] <- "NA" } if (optimizer[1]=="optim"){ object$optim.method <- rep(NA,2) object$optim.method[1] <- optim.method[1] if (!is.null(grr)) object$optim.method[2] <- "grad" } object$sp <- sp ## object$q.f <- G$q.f object$p.ident <- G$p.ident object$S <- G$S object$optimizer <- optimizer if (optimizer[1]=="no.sps") object$optimizer[1] <- "NA" object } ## estimate.scam efsudr.scam2 <- function(fit.fn,G,lsp,env, control) ## Extended Fellner-Schall method for regular families as in efsudr(mgcv), however, ## rather than minimizing REML (as in gam(mgcv)), the function minimizes GCV/UBRE criterion; ## also there is an alternative BFGS method in place of the full Newton. ## The dependence of H on lambda is neglected. ## 'fit.fn' - the routine to estimate the model coefficients: ## fit.fn = scam.fit1 if a quasi-Newton/BFGS method is used for the coefficient estimation, ## fit.fn = scam.fit in case of the full Newton (PIRLS). ## This function is the same as efsudr.scam1 with the only difference that scam.fit() is either ## scam.fit1() or scam.fit()... { ## deriv.dev.edf <- function(G,fit,sp){ ## the expected approx Hessian is not correct here, not +ve def!! ## ## function to calculate derivatives of deviance and tr(A) w.r.t. log(sp) ## ## Hessian is replaced by a BFGS approximation from the scam.fit1, ## ## the dependence of H on sp/lambda is neglected ## b <- fit ## nsp <- length(G$S) ## H <- b$hess ## expected approximate Hessian ## Vb <- b$inv.B ## inverse of the approximate Hessian ## trA.rho<- rep(0,nsp) ## beta.rho <- matrix(0,ncol(G$X),nsp) ## matrix of the parameters derivatives wrt log(sp) ## for (j in 1:nsp){ ## VbS <- Vb%*%b$S[[j]] ## trA.rho[j] <- -sp[j]*sum((VbS%*%Vb)*t(H)) ## -lambda*tr(Vb*Sj*Vb*H) ## beta.rho[,j] <- -sp[j]*(VbS%*%b$beta) ## } ## y.mu <- drop(b$y)-b$mu ## c <- -2*y.mu/(b$Var*b$dlink.mu) ## D.beta <- t(b$X1)%*%c ## derivative of the deviance w.r.t. beta ## D.rho <- t(D.beta)%*%beta.rho ## derivative of the deviance w.r.t. log(sp) ## list(trA.rho=trA.rho,D.rho=D.rho) ## } ## deriv.dev.edf() deriv.dev.edf <- function(G,fit,sp){ ## function to calculate derivatives of deviance and tr(A) w.r.t. log(sp), ## using expected Hessian and neglecting its dependence on sp b <- fit nsp <- length(G$S) H <- crossprod(b$wX1) ## expected Hessian = CtXtWXC Vb <- tcrossprod(b$P) ## P%*%t(P)*sig2 Bayesian posterior covariance matrix for the parameters ## but without ? scale parameter here (inverse of the Hessian) trA.rho<- rep(0,nsp) beta.rho <- matrix(0,ncol(G$X),nsp) ## matrix of the parameters derivatives wrt log(sp) ## VbS <- matrix(0,dim(Vb)[1],dim(Vb)[2]) for (j in 1:nsp){ VbS <- Vb%*%b$S[[j]] trA.rho[j] <- -sp[j]*sum((VbS%*%Vb)*t(H)) ## -lambda*tr(Vb*Sj*Vb*H) beta.rho[,j] <- -sp[j]*(VbS%*%b$beta) } y.mu <- drop(b$y)-b$mu c <- -2*y.mu/(b$Var*b$dlink.mu) D.beta <- t(b$X1)%*%c ## derivative of the deviance w.r.t. beta D.rho <- t(D.beta)%*%beta.rho ## derivative of the deviance w.r.t. log(sp) list(trA.rho=trA.rho,D.rho=D.rho) } ## deriv.dev.edf() crit.gcv <- function(fit,G,n){ ## function to get the GCV criterion value ## gcv=dev*nobs/(nobs-gamma*trA)^2 fit$gcv } crit.ubre <- function(fit,G,n){ ## function to get the UBRE criterion value ## ubre = dev/n - sig2 +2*gamma*trA*sig2/n ## cr <- fit$deviance +2*G$gamma*fit$trA*G$sig2 cr <- fit$deviance/n +2*G$gamma*fit$trA*G$sig2/n - G$sig2 cr } if (G$scale.known) ## use UBRE... crit <- crit.ubre else crit <- crit.gcv ## use GCV nsp <- length(G$S) # number of smoothing parameters spind <- 1:nsp ## index of smoothing params in lsp lsp[spind] <- lsp[spind] + 2.5 mult <- 1 fit <- fit.fn(G=G,sp=exp(lsp), env=env,control=control) q <- ncol(G$X) n <- nrow(G$X) score.hist <- rep(0,200) D.rho <- tau.rho <- rep(0,nsp) ## initialize derivatives of deviance and edf (tau/trA) wrt log(sp) for (iter in 1:200) { ## loop for GCV/UBRE minimization... ## calculation of the derivatives of deviance and edf wrt rho... der <- deriv.dev.edf(G=G, fit=fit,sp=exp(lsp)) D.rho <- der$D.rho tau.rho <- der$trA.rho if (G$scale.known) a <- pmax(0,-2*G$gamma*G$sig2*tau.rho) else a <- pmax(0,-2*G$gamma*fit$deviance*tau.rho/(n-fit$trA)) r <- a/pmax(0,D.rho) # r[a==0 & D.rho==0] <- 1 r[a==0 | D.rho==0] <- 1 r[!is.finite(r)] <- 1e6 lsp1 <- lsp lsp1 <- pmin(lsp + log(r)*mult,control$efs.lspmax) max.step <- max(abs(lsp1-lsp)) old.gcv <- crit(fit, G,n) ## fit$gcv fit <- fit.fn(G=G,sp=exp(lsp1), env=env,control=control) ## some step length control... fit.gcv <- crit(fit, G,n) ## undated gcv/ubre value if (fit.gcv<=old.gcv) { ## improvement if (max.step<.05) { ## consider step extension (near optimum) lsp2 <- lsp lsp2 <- pmin(lsp + log(r)*mult*2,control$efs.lspmax) ## try extending step... fit2 <- fit.fn(G=G,sp=exp(lsp2), env=env,control=control) fit2.gcv <- crit(fit2,G,n) if (fit2.gcv < fit.gcv) { ## improvement - accept extension fit <- fit2;lsp <- lsp2 fit.gcv <- fit2.gcv mult <- mult * 2 } else { ## accept old step lsp <- lsp1 } } else lsp <- lsp1 } else { ## no improvement # while (fit$gcv > old.gcv&&mult>1) { ## don't contract below 1 as update doesn't have to improve GCV # mult <- mult/2 ## contract step # lsp1 <- lsp # lsp1 <- pmin(lsp + log(r)*mult,control$efs.lspmax) # fit <- fit.fn(G=G,sp=exp(lsp1), gamma=gamma, env=env,control=control) # } gcv.thresh <- 10*(.1 +abs(old.gcv))*.Machine$double.eps^.5 ii <- 1 maxHalf.fit <- 15 while (is.na(fit.gcv) || (fit.gcv-old.gcv) > gcv.thresh) { # 'step reduction' approach if (ii > maxHalf.fit) break ## stop ("step reduction failed") ii <- ii+1 mult <- mult/2 ## contract step lsp1 <- lsp lsp1 <- pmin(lsp + log(r)*mult,control$efs.lspmax) fit <- fit.fn(G=G,sp=exp(lsp1), env=env,control=control) fit.gcv <- crit(fit,G,n) } lsp <- lsp1 if (mult<1) mult <- 1 } score.hist[iter] <- fit.gcv ## break if EFS step small and GCV change negligible over last 3 steps. if (iter>3 && max.step<.05 && max(abs(diff(score.hist[(iter-3):iter]))) old.gcv&&mult>1) { ## don't contract below 1 as update doesn't have to improve GCV # mult <- mult/2 ## contract step # lsp1 <- lsp # lsp1 <- pmin(lsp + log(r)*mult,control$efs.lspmax) # fit <- scam.fit(G=G,sp=exp(lsp1), gamma=gamma, env=env,control=control) # } gcv.thresh <- 10*(.1 +abs(old.gcv))*.Machine$double.eps^.5 ii <- 1 maxHalf.fit <- 15 while (is.na(fit.gcv) || (fit.gcv-old.gcv) > gcv.thresh) { # 'step reduction' approach if (ii > maxHalf.fit) break ## stop ("step reduction failed") ii <- ii+1 mult <- mult/2 ## contract step lsp1 <- lsp lsp1 <- pmin(lsp + log(r)*mult,control$efs.lspmax) fit <- scam.fit(G=G,sp=exp(lsp1), env=env,control=control) fit.gcv <- crit(fit,G,n) } lsp <- lsp1 if (mult<1) mult <- 1 } score.hist[iter] <- fit.gcv ## break if EFS step small and GCV change negligible over last 3 steps. if (iter>3 && max.step<.05 && max(abs(diff(score.hist[(iter-3):iter]))) old.gcv&&mult>1) { ## don't contract below 1 as update doesn't have to improve GCV # mult <- mult/2 ## contract step # lsp1 <- lsp # lsp1 <- pmin(lsp + log(r)*mult,control$efs.lspmax) # fit <- scam.fit(G=G,sp=exp(lsp1), gamma=gamma, env=env,control=control) # } gcv.thresh <- 10*(.1 +abs(old.gcv))*.Machine$double.eps^.5 ii <- 1 maxHalf.fit <- 15 while (is.na(fit.gcv) || (fit.gcv-old.gcv) > gcv.thresh) { # 'step reduction' approach if (ii > maxHalf.fit) break ## stop ("step reduction failed") ii <- ii+1 mult <- mult/2 ## contract step lsp1 <- lsp lsp1 <- pmin(lsp + log(r)*mult,control$efs.lspmax) fit <- scam.fit(G=G,sp=exp(lsp1), env=env,control=control) fit.gcv <- crit(fit,G,n) } lsp <- lsp1 if (mult<1) mult <- 1 } score.hist[iter] <- fit.gcv ## break if EFS step small and GCV change negligible over last 3 steps. if (iter>3 && max.step<.05 && max(abs(diff(score.hist[(iter-3):iter])))