mgcv/0000755000176200001440000000000013561447343011220 5ustar liggesusersmgcv/NAMESPACE0000755000176200001440000001575313545347056012457 0ustar liggesusersuseDynLib(mgcv, .registration = TRUE, .fixes = "C_") export("%.%",anova.gam, bam, bam.update,bandchol, betar, choldrop,cholup,cox.ph,concurvity, cSplineDes,dDeta, exclude.too.far,extract.lme.cov, extract.lme.cov2,FFdes, formXtViX, full.score, formula.gam,fixDependence,fix.family.link, fix.family.var, fix.family.ls, fix.family.qf,fix.family.rd, fs.test,fs.boundary,gam, gam2derivative, gam2objective, gamm, gam.check, gam.control,gam.fit3, gam.fit,gam.fit5.post.proc, gamlss.etamu,gamlss.gH,gammals, gam.outer,gam.reparam, gam.vcomp, gamSim , gaulss,gam.side,get.var,gevlss,ginla, influence.gam, in.out,inSide,interpret.gam,initial.sp, jagam,k.check,ldetS, ldTweedie, logLik.gam,ls.size, magic, magic.post.proc, model.matrix.gam,mini.roots, mono.con, mroot, multinom, mvn, nb, negbin, new.name, notExp,notExp2,notLog,notLog2,pcls,null.space.dimension, ocat, pen.edf,pdIdnot,pdTens, place.knots, plot.gam, polys.plot,print.anova.gam, print.gam,print.summary.gam,predict.gam,predict.bam, PredictMat,Predict.matrix,Predict.matrix2, Predict.matrix.Bspline.smooth, Predict.matrix.cr.smooth, Predict.matrix.duchon.spline, Predict.matrix.cs.smooth, Predict.matrix.cyclic.smooth, Predict.matrix.tensor.smooth, Predict.matrix.tprs.smooth, Predict.matrix.ts.smooth, Predict.matrix.sos.smooth, Predict.matrix.soap.film, Predict.matrix.sf, Predict.matrix.sw, Predict.matrix.mrf.smooth, Predict.matrix.pspline.smooth, Predict.matrix.random.effect, Predict.matrix.t2.smooth, Predict.matrix.gp.smooth, qq.gam, residuals.gam,rig,rTweedie,rmvn, Rrank,s,scat,sdiag,"sdiag<-", sim2jam,Sl.initial.repara,Sl.inirep,Sl.repara,Sl.setup, slanczos,smooth2random, smoothCon,smooth.construct,smooth.construct2, smooth.construct.bs.smooth.spec, smooth.construct.cc.smooth.spec, smooth.construct.cp.smooth.spec, smooth.construct.cr.smooth.spec, smooth.construct.cs.smooth.spec, smooth.construct.ds.smooth.spec, smooth.construct.tensor.smooth.spec, smooth.construct.tp.smooth.spec, smooth.construct.ts.smooth.spec, smooth.construct.ps.smooth.spec, smooth.construct.re.smooth.spec, smooth.construct.mrf.smooth.spec, smooth.construct.gp.smooth.spec, smooth.construct.sos.smooth.spec, smooth.construct.so.smooth.spec, smooth.construct.sf.smooth.spec, smooth.construct.sw.smooth.spec, smooth.construct.ad.smooth.spec, smooth.construct.t2.smooth.spec, summary.gam,sp.vcov, spasm.construct,spasm.sp,spasm.smooth, t2,te,ti,tensor.prod.model.matrix,tensor.prod.penalties, totalPenaltySpace,trichol,trind.generator, Tweedie,tw,twlss,uniquecombs, vcov.gam, vis.gam, XWXd,XWyd,Xbd,diagXVXd, ziP, ziplss) importFrom(grDevices,cm.colors,dev.interactive,devAskNewPage,gray,grey, heat.colors,terrain.colors,topo.colors,axisTicks) importFrom(graphics,abline,axis,axTicks,box,contour,hist,image,lines, mtext, par, persp,plot,points, polygon,rect,strheight,strwidth,text,title) importFrom(utils, setTxtProgressBar, txtProgressBar) importFrom(splines,interpSpline) importFrom(stats,.checkMFClasses,.getXlevels,anova,approx,as.formula, binomial,coef,contrasts,"contrasts<-",cooks.distance,cor,cov, delete.response,dbeta,dgamma,dnorm,dpois,fitted,formula,gaussian,glm, influence,logLik,lm,mad, make.link,median,model.frame,model.offset,model.matrix,model.response, na.action,nlm,na.pass,napredict,na.omit,naresid,optim,pchisq,pnorm,pt,pf, power,predict,printCoefmat,quantile, qbeta,qbinom,qcauchy,qchisq,qnbinom,qgamma,qnorm,qpois,qqline,qqnorm,qqplot, reformulate,residuals, rbeta,rbinom,rgamma,rnbinom,rnorm,rpois,runif,sd, termplot,terms.formula,terms,uniroot,var,vcov,weights) importFrom(utils,object.size) importFrom(nlme,Dim,corMatrix,logDet,pdConstruct,pdFactor,pdMatrix,getGroupsFormula,lme,varFixed,lmeControl) importMethodsFrom(Matrix,t,colMeans,colSums,chol,solve,lu,expand) importFrom(Matrix,Diagonal,sparseMatrix,Matrix) importFrom(methods,cbind2,as) importFrom(stats,weighted.mean) importFrom(stats,optimize) S3method(anova, gam) S3method(influence, gam) S3method(cooks.distance, gam) S3method(formula, gam) S3method(logLik, gam) S3method(model.matrix,gam) S3method(plot, gam) S3method(plot, jam) S3method(predict, gam) S3method(predict, bam) S3method(predict, jam) S3method(print, anova.gam) S3method(print, gam) S3method(print, jam) S3method(print, summary.gam) S3method(residuals, gam) S3method(summary, gam) S3method(vcov,gam) S3method(vcov,jam) S3method(coef,pdTens) S3method(pdConstruct,pdTens) S3method(pdFactor,pdTens) S3method(pdMatrix,pdTens) S3method(summary,pdTens) S3method(Dim,pdIdnot) S3method(coef,pdIdnot) S3method(corMatrix,pdIdnot) S3method(logDet,pdIdnot) S3method(pdConstruct,pdIdnot) S3method(pdFactor,pdIdnot) S3method(pdMatrix,pdIdnot) S3method(solve,pdIdnot) S3method(summary,pdIdnot) S3method(fix.family.link,family) S3method(fix.family.link,extended.family) S3method(fix.family.link,general.family) S3method(smooth.construct,ad.smooth.spec) S3method(smooth.construct,bs.smooth.spec) S3method(smooth.construct, cc.smooth.spec) S3method(smooth.construct,cp.smooth.spec) S3method(smooth.construct, cr.smooth.spec) S3method(smooth.construct, cs.smooth.spec) S3method(smooth.construct,ds.smooth.spec) S3method(smooth.construct, fs.smooth.spec) S3method(smooth.construct, mrf.smooth.spec) S3method(smooth.construct, gp.smooth.spec) S3method(smooth.construct,ps.smooth.spec) S3method(smooth.construct, re.smooth.spec) S3method(smooth.construct,so.smooth.spec) S3method(smooth.construct,sw.smooth.spec) S3method(smooth.construct,sf.smooth.spec) S3method(smooth.construct,sos.smooth.spec) S3method(smooth.construct, tp.smooth.spec) S3method(smooth.construct, tensor.smooth.spec) S3method(smooth.construct, t2.smooth.spec) S3method(smooth.construct, ts.smooth.spec) S3method(Predict.matrix,Bspline.smooth) S3method(Predict.matrix,cr.smooth) S3method(Predict.matrix,cs.smooth) S3method(Predict.matrix,cyclic.smooth) S3method(Predict.matrix,cpspline.smooth) S3method(Predict.matrix,duchon.spline) S3method(Predict.matrix,fs.interaction) S3method(Predict.matrix,mrf.smooth) S3method(Predict.matrix,pspline.smooth) S3method(Predict.matrix,random.effect) S3method(Predict.matrix,tprs.smooth) S3method(Predict.matrix,ts.smooth) S3method(Predict.matrix,tensor.smooth) S3method(Predict.matrix,t2.smooth) S3method(Predict.matrix,soap.film) S3method(Predict.matrix,sf) S3method(Predict.matrix,sw) S3method(Predict.matrix,sos.smooth) S3method(Predict.matrix,gp.smooth) S3method(spasm.construct,cus) S3method(spasm.sp,cus) S3method(spasm.smooth,cus) S3method(smooth2random,mgcv.smooth) S3method(smooth2random,fs.interaction) S3method(smooth2random,tensor.smooth) S3method(smooth2random,t2.smooth) mgcv/GPL-20000644000176200001440000004313313073161530011715 0ustar liggesusers GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. mgcv/ChangeLog0000755000176200001440000041624513561356102013001 0ustar liggesusers** denotes quite substantial/important changes *** denotes really big changes Liable to change in future release: - method="GCV.Cp" as default in gam. Default will change to "REML". (1.8-24, June 2018) Currently deprecated and liable to be removed: - gam performance iteration (1.8-19, Sept 2017) - argument 'pers' in plot.gam (1.8-23, Nov 2017) Issues: ** openblas 0.3.x x<7 is not thread safe if itself compiled for single thread use and then called from multiple threads (unlike the reference BLAS, say). 0.2.20 appears to be OK. For 0.3.x x>6 make USE_THREAD=0 USE_LOCKING=1 to make openblas ensures thread safety (currently unclear if USE_LOCKING will be default from 0.3.7). * t2 in bam(...,discrete=TRUE) - not treated as tensor products at present, and reparameterization needs checking (also for bam). * bam(...,discrete=TRUE) does not currently deal with the corner case in which no smoother is penalized. 1.8-31 * fix in initalization in gammPQL * fix of some C routines of type void in place of SEXP called by .Call. 1.8-30 * anova.gam now uses GLRT for multi-model comparisons in both extended and general family cases. * Fix to bug in bam(...,discrete=TRUE) offset handling introduced in 1.8-29, which corrupted offset (and generated numerous warnings). Also fixes a less obvious bug introduced at the same time in predict.gam which could get the offset wrong when prediciting with such models. Thanks to Brian Montgomery and Sean Wilson. * Fix to problem in pen.reg (used to initialize location scale models in particular), which could lead to initialization failure for lightly penalized models. Thanks Matteo Fasiolo. * Fix to predict.bamd handling of 'terms' and 'exclude' for models fit by bam(...,discrete=TRUE). * Work around in predict.gam for a spurious model.matrix warning when a contrasts.arg relates to a variable in data not required by object. * Fix to gammals family which had 'd2link' etc defined with argument 'eta' instead of the intended 'mu'. Thanks to Jim Stagge. * 'in.out' modified to allow boundaries specified exactly as for a soap film smoother. * soap film smoother constructor modified to check knots are within boundary on entry and drop those that are not, with a warning. Also halts if it detects that basis setup is catastrophically ill-conditioned. 1.8-29 * gammPQL modified to use standard GLM IRLS initilization (rather than glmmPQL method) to improve convergence of `gamm' fits. * bam(...,discrete=TRUE) now drops rownames from parametric model matrix components, to save substantial memory. * All BLAS/LAPACK calls from C now explicitly pass hidden string length arguments to avoid breakage by recent gfortran optimizations (stack corruption causing BLAS/LAPACK to return error code). * predict.gam bug fix - parameteric interaction terms could be dropped for type="terms" if there were no smooths. knock on was that they were also dropped for all bam(...,discrete=TRUE) fits. (Thanks Justin Davis.) * bam(...,discrete=TRUE) indexing bug in setup meant that models containing smooths with matrix arguments and other smooths with factor by variable would fail at the setup stage. * gam.fit4 initial divergence bug fix. * Gamma location-scale family 'gammals' added. See ?gammals. * row-wise Kronecker product operator %.% added for convenience. * changes to general families to allow return of first deriv of penalized Hessian component more easily. * ocat bug fix. Response scale prediction was wrong - it ignored the estimated thresholds. Thanks to Fabian Scheipl. * bam deviance could be wrongly returned, leading to 100% explained deviance. Fixed. 1.8-28 * fix of obscure sp naming bug. * changed some contour default colours from green to blue (they overlay heatmaps, so green was not clever). * Tweedie likelihood evaluation code made slightly more robust - for a model with machine zero scale parameter estimate it could segfault, as series maximum location could then overflow integer storage. Fixed + upper limit imposed on series length (warning if it's not enough). 1.8-27 ** Added routine 'ginla' for fully Bayesian inference based on an integrated nested Laplace approximation (INLA) approach. See ?ginla. * Tweedie location scale family added: 'twlss'. * gam.fit5 modified to distinguish more carefully between +ve semi definite and +ve definite. Previously could fail, claiming indefiniteness when it should not have. Affects general families. * bam was ignoring supplied scale parameter in extended family cases - fixed. * work around in list formula handling for reformulate sometimes setting response to a name in place of a call. * preinitialize in general families is now a function, not an expression. See cox.ph for an example. * added routine cholup for rank one modification of Cholesky factor. * two stage gam/bam fitting now allows 'sp' to be modified. * predict.gam could fail with type="response" for families requiring the response to be provided in this case (e.g. cox.ph). Fixed. * sp.vcov defaults to extracting edge corrected log sp cov matrix, if gam(...,gam.control(edge.control=TRUE)) used for fitting. * gam(...,gam.control(edge.correct=TRUE)) could go into infinite loop if sp was effectively zero. Corrected. 1.8-26 * LINPACK dependency removed. * Added service routine choldrop to down date a Cholesky factor on row/col deletion. * liu2 had a check messed up when vectorized. Fix to stop vector being checked for equality to zero. 1.8-25 ** bam(...,discrete=TRUE) methods improved. Cross products now usually faster (can be much faster) and code can now make better use of optimised BLAS. * fix to 'fs' smooth.construct method and smooth2random method, to allow constructor to be called without a "gamm" atribute set on the smooth spec but still get a sensible result from smooth2random (albeit never using sarse matrices). Useful for other packages using constructors and smooth2random, for 'fs' smooths. * The mrf smooth constructor contained an obsolete hack in which the term dimension was set to 2 to avoid plotting when used as a te marginal. This messed up side constraints for terms where a mrf smooth was a main effect and te marginal. Fixed. * extract.lme.cov/2 documentation modified to cover NA handling properly, and routines modified to not require data to be supplied. * fix of efsudr bug whereby extended families with no extra parameters to estimate could give incorrect results when using optimer="efs" in 'gam'. * negbin() corrected - it was declaring the log link to be canonical, leading to poor convergence and slight misfit. * predict.bam(...,discrete=TRUE) now handles na.action properly, rather than always dropping NAs. * Fix of very obscure bug in which very poor model of small dataset could end up with fewer `good' data than coefs, breaking an assumption of C code and segfaulting. * fix of null deviance computation bug introduced with extended families in bam - null deviance was wrong for non-default methods. * liu2 modified to deal with random effects estimated to be exactly 0, so that summary.gam does not fail in this case. 1.8-24 * Extended Fellner Schall optimizer now avaialable for all families with 'gam' using gam(...,optimizer="efs"). * Change to default behaviour of plot.gam when 'seWithMean=TRUE', and of predict.gam when 'type="iterms"'. The extra uncertainty added to CIs or standard errors now reflects the uncertainty in the mean in all other model terms, not just the uncertanity in the mean of the fixed effects as before. See ?plot.gam and ?predict.gam (including for how to get the old behaviour). * 're' smooths can now accept matrix arguments: see ?linear.functional.terms. * cox.ph now allows an offset to be provided. * Fix in smoothCon for bug in case in which only a single coefficient is involved in a sum-to-zero constraint. Could cause failure in e.g. t2 with cc marginal. * Model terms s, te etc are now always evaluated in mgcv workspace explicitly to avoid masking problems in obscure circumstances. * 'mrf' smooth documentation modified to make it clearer how to specify 'nb', and code modified so that it is now possible to specify the neighbour structure using names rather than indices. * 'bfgs' fix to handle extended families. * plot.gam modified to only prompt (via devAskNewPage) for a new page after the first page is used up. * export 'k.check'. * Fix to 'Rrank'. Previously a matrix R with more columns than rows could cause a segfault. * Fix to non-finite likelihood handling in gam.fit5. * Fix in bgam.fitd to step reduce under indefinite deviance and to ensure penalty evaluation is round off negative proof. * newton slighty modified to avoid (small) chance of all sp's being dropped for indef likelihood. 1.8-23 * default plot methods added for smooths of 3 and 4 variables. * The `gamma' control parameter for gam and bam can now be used with RE/ML smoothness selection, not just GCV/AIC. Essentially smoothing parameters are chosen as if the sample size was n/gamma instead of n. * The "bs" basis now allows multiple penalties of different orders on the same spline. e.g. s(x,bs="bs",m=c(3,2,0)). See ?b.spline. * bam(...,discrete=TRUE) can now use the smooth 'id' mechanism to link smoothing parameters, but note the method constraint that the linked bases are not forced to be identical in this case (unlike other fitting methods). * summary.gam now allows random effects tests to be skipped (in some large models the test is costly and uninteresting). * 'interpret.gam0' modified so that masked 's', 'te', etc from other packages does not cause failure. * coxph fix of prediction bug introduced with stratified model (thanks Giampiero Marra) * bam(...,discrete=TRUE) fix to handle nested matrix arguments to smooths. * bam(...,discrete=TRUE) fix to by variable handling with fs and re smooths which could fail during re-representation as tensor smooths (for discretization purposes). * bam extended family extension had introduced a bug in null deviance computation for Gaussian additive case when using methods other than fREML or GCV.Cp. Fixed. * bam(...,discrete=TRUE) now defaults to discrete=FALSE if there are no smooths, rather than failing. * bam was reporting wrong family under some smoothing parameter selection methods (not default). * null deviance computation improved for extended families. Previous version used an approximation valid for most families, and corrected the rest - now replaced with exact computations for all cases. * scat initialization tweaked to avoid -ve def problems at start. * paraPen handling in bam was broken - fixed. * slight adjustment to sp initialization for extended families - use observed information in weights if possible. 1.8-22 * Fix of bug whereby testing for OpenMP and nthreads>1 in bam, would fail if OpenMP was missing. 1.8-21 * When functions were added to families within mgcv some very large environments could end up attached to those functions, for no good reason. The problem originated from the dispatch of the generic 'fix.family.link' and then propagated via fix.family.var and fix.family.ls. This is now avoided, resulting in smaller gam objects on disk and lower R memory usage. Thanks to Niels Richard Hansen for uncovering this. * Another bug fix for prediction from discrete fit bam models with an offset, this time when there were more than 50000 data. Also fix to bam fitting when the number of data was an integer multiple of the chunk size + 1. * check.term was missing a 'stop' so that some unhandled nesting structures in bam(...,discrete=TRUE) failed with an unhelpful error, instead of a helpful one. Fixed. 1.8-20 * bam(,discrete=TRUE) could produce garbage with ti(x,z,k=c(6,5),mc=c(T,F)) because tensor re-ordering for efficiency failed to re-order mc (this is a *very* specialist bug!). Thanks to Fabian Scheipl. * plot(...,residuals=TRUE) weighted the working residuals by the sqrt working weights divided by the mean sqrt working weight. The standardization by the mean sqrt weight was non standard and has been removed. * Fix to bad bug in bam(...,discrete=TRUE) offset handling, and predict.bamd modified to avoid failure predicting with offset. Thanks to Paul Shearer. * fix of typo in bgam.fit, which caused failure of extended families when dataset larger than chunk size. Thanks Martijn Wieling. * bam(...,discrete=TRUE)/bgam.fitd modified to use fisher weights with extended families if rho!=0. 1.8-19 ** bam() now accepts extended families (i.e. nb, tw, ocat etc) * cox.ph now allows stratification (i.e. baseline hazard can differ between groups). * Example code for matched case control in ?cox.ph was just plain wrong. Now fixed. Thanks to Patrick Farrell. * bam(...,discrete=TRUE) tolerance for judging whether smoothing parameters are on boundary was far too low, so that sps could become so large that numerical instability set in. Fixed. Thanks to Paul Rosenfield. * p.type!=0 removed in summary.gam (previously deprecated) * single penalty tensor product smooths removed (previously deprecated). * gam(...,optimizer="perf") deprecated. * extra divergence check added to bam gam default gam fitting (similar to discrete method). * preinitialize and postproc components of extended families are now functions, not expressions. * coefficient divergence check was missing in bam(...,discrete=TRUE) release code - now fixed. * gaulss family link derivatives modified to avoid overflow. Thanks to Kristen Beck for reporting the problem. * redundant 'n' argument removed from extended family 'ls' functions. * Convergence checking can step fail earlier in fast.REML.fit. If trial step is no improvement and equal to previous best (to within a tolerance), then terminate with step failure after a few step halvings if situation persists. Thanks to Zheyuan Li for reporting problem. 1.8-18 * Tweak to 'newton' to further reduce chance of false convergence at indefinite point. * Fix to bam.update to deal with NAs in response. * 'scat' family now takes a 'min.df' argument which defaults to 3. Could otherwise occasionally have indefinite LAML problems as df headed towards 2. * Fix to `gam.fit4' where in rare circumstances the PIRLS iteration could finish at an indefinite point, spoiling implicit differentiation. * `gam.check' modified to fix a couple of issues with `gamm' fitted models, and to warn that interpretability is reduced for such models. * `qq.gam' default method slight modification to default generation of reference quantiles. In theory previous method could cause a problem if enough residuals were exactly equal. * Fix to `plot.mrf.smooth' to deal with models with by variables. * `plot.gam' fix to handling of plot limits when using 'trans' (from 1.8-16 'trans' could be applied twice). * `plot.gam' argument 'rug' now defaults to 'NULL' corresponding to 'rug=TRUE' if the number of data is <= 10000 and 'rug=FALSE' otherwise. * bam(...,discrete=TRUE) could fail if NAs in the smooth terms caused data rows to be dropped which led to parametric term factors having unused levels (which were then not being dropped). Fixed (in discrete.mf). * bam(...,discrete=TRUE,nthreads=n) now warns if n>1 and openMP is not available on the platform being used. * Sl.addS modified to use C code for some otherwise very slow matrix subset and addition ops which could become rate limiting for bam(...,discrete=TRUE). * Parallel solves in Sl.iftChol can speed up bam(...,discrete=TRUE) with large numbers of smoothing/variance parameters. * 'gamm' now warns if called with extended families. * disasterous 'te' in place of 'ti' typo in ?smooth.terms fixed thanks to John McKinlay. * Some `internal' functions exported to facilitate quantile gam methods in separate package. * Minor fix in gam.fit5 - 1 by 1 matrix coerced to scalar, to prevent failure in some circumstances. 1.8-17 * Export gamlss.etamu, gamlss.gH and trind.generator to facilitate user addition of new location-scale families. * Re-ordering of initialization in gam.fit4 to avoid possible failure of dev.resids call before initialization. * trap in fast.REML.fit for situation in which all smoothing parameters satisfy conditions for indefinite convergence on entry, with an immediate warning that this probably indicates iteration divergence (of bam). * "bs" basis modified to allow easier control of the interval over which the spline penalty applies which in turn allows more sensible control of extrapolation behaviour, when this is unavoidable. * Fix in uniquecombs - revised faster code (from 1.8-13) could occasionally generate false matches between different input combinations for integer variables or factors. Thanks to Rohan Sadler for reporting the issue that uncovered this. * A very bad initial model for uninformative data could lead to a negative fletcher estimate of the scale parameter and optimizer failure - fixed. * "fREML" allowed in sp.vcov so that it works with bam fitted models. * 2 occurances of 'return' replaced by (correct) return(). 1.8-16 * slightly improved intial value heuristics for overlapping penalties in general family case. * 'ocat' checks that response is numeric. * plot.gam(...,scale=-1) now changes scale according to 'trans' and 'shift'. * newton optimizer made slightly more cautious: contracts step if reduction in true objective too far different from reduction predicted by quadratic approximation underlying Newton step. Also leaves parameters unchanged in Newton step while their grad is less than 1% of max grad. * Fix to Fisher weight computation in gam.fit4. Previously a weight could (rarely) evaluate as negative machine prec instead of zero, get passed to gdi2 in C code, generate a NaN when square rooted, resulting in a NaN passed to the LAPACK dgeqp3 routine, which then hung in a non-interuptable way. * Fix of 'sp' argument handling with multiple formulae. Allocation to terms could be incorrect. * Option 'edge.correct' added to 'gam.control' to allow better correction of edge of smoothing parameter space effects with 'gam' when RE/ML used. * Fix to setting of penalty rank in smooth.construct.mrf.smooth.spec. Previously this was wrong, which could cause failure with gamm if the penalty was rank deficient. Thanks Paul Buerkner. * Fix to Vb.corr call from gam.fit3.post.proc to ensure that sp not dropped (wrongly treated as scale estimate) when P-REML or P-ML used. Could cause failure depending on BLAS. Thanks Matteo Fasiolo. * Fix in gam.outer that caused failure with "efs" optimizer and fixed sps. * Fix to `get.var' to drop matrix attributes of 1 column matrix variables. * Extra argument added to `uniquecombs' to allow result to have same row ordering regardless of input data ordering. Now used by smooth constructors that subsample unique covariate values during basis setup to ensure invariance to data re-ordering. * Correction of scaling error in spherical correlation structure GP smooth. * qf and rd functions for binomial family fixed for zero n case. 1.8-15 * Fix of survival function prediction in cox.ph family. Code used expression (8.8.5) in Klein and Moeschberger (2003), which is missing a term. Correct expression is, e.g., (10) from Andersen, Weis Bentzon and Klein (1996) Scandinavian Journal of Statistics. * Added help file 'cox.pht' for Cox PH regression with time dependent covariates. * fix of potential seg fault in gdi.c:get_bSb if single smooth model rank deficient (insufficient workspace allocated). * gam.fit5 modified to step half if trial penalized likelihood is infinite. * Fix so that bam works properly with drop.intercept=TRUE. 1.8-14 * bug fix to smoothCon that could generate NAs in model matrix when using bam with numeric by variables. The problem was introduced as part of the bam(...,discrete=TRUE) coding. 1.8-13 * Added help file ?one.se.rule on the `one standard error rule' for obtaining smoother models. * bam(...,discrete=TRUE) no longer complains about more coefficients than data. * 's', 'te', 'ti' and 't2' modified to allow user to specify that the smooth should pass through zero at a specified point. See ?identifiability. * anova.gam modified to use more appropriate reference degrees of freedom for multiple model call, where possible. Also fixed to allow multiple formulae models and to use -2*logLik in place of `deviance' for general.family models. * offsets allowed with multinomial, ziplss and gaulss families. * gevlss family implementing generalized extreme value location, scale and shape models. * Faster code used in 'uniquecombs'. Speeds up discretization step in 'bam(...,discrete=TRUE)'. Could still be improved for multi-column case. * modification to 'smoothCon' to allow resetting of smooth supplied constraints - enables fix of bug in bam handling of 't2' terms, where parameterization of penalty and model matrix did not previously match properly. * clarification of `exclude' argument to predict.gam in help files. * modification to 'plot.gam' etc, so that 'ylim' is no longer shifted by 'shift'. * ylim and ... handling improved for 'fs' plot method (thanks Dave Miller) * gam.check now recognises RStudio and plots appropriately. * bam(...,sparse=TRUE) removed - not efficient, because of unavoidability of dense off diagonal terms in X'X or equivalent. Deprecated since 1.8-5. * tweak to initial.sp/g to avoid infinite loop in s.p. initialization, in rather unusual circumstances. Thanks to Mark Bravington. * bam and gam have `drop.intercept' argument to force the parametric terms not to include a constant in their span, even when there are factor variables. * Fix in Vb.corr (2nd order edf correction) for fixed smoothing parameter case. * added 'all.vars1' to enable terms like s(x$y) in model formulae. * modification to gam.fit4 to ignore 'start' if it is immediately worse than 'null.coef'. * cSplineDes can now accept a 'derivs' argument. * added drop.intercept handling for multiple formulae (mod by Matteo Fasiolo). * 'gam.side' fix to avoid duplication of smooth model matrices to be tested against, when checking for numerical degeneracy. Problem could occasionally cause a failure (especially with bam), when the total matrix to be tested against ended upo with more columns than rows. * 4 occurances of as.name("model.frame") changed to quote(stats::model.frame) * fix in predict.bamd discrete prediction code to be a bit more relaxed about use of as.factor, etc in formulae. * fix in predict.gam handling of 'na.action' to avoid trying to get type of na.action from name of na.action function - this was fragile to nesting and could cause predict.bam to fail in the presence of NA's. * fix of gam.outer so that general families (e.g. cox.ph) can have all their smoothing parameters supplied without then ignoring the penalties! * fix in multiple formulae handling of fixed smoothing parameters. * Fix of bug in zlim handling in vis.gam perspective plot with standard errors. Thanks Petra Kuhnert. * probit link added to 'jagam' (suggested by Kenneth Knoblauch). * 'Sl.' routines revised to allow operation with non-linearly parameterized smoothers. * bug fix in Hessian computation in gam.fit5 - leading diagonal of Hessian of log|Hp| could be wrong where Hp is penalized Hessian. * better use of crossprod in gamlss.gH 1.8-12 ** "bs" B-spline smoothing basis. B-splines with derivative based penalties of various orders. * 'gamm' now uses a fixed scale parameter in PQL estimation for Poisson and binomial data via the `sigma' option in lmeControl. * bam null deviance computation was wrong with prior weights (including binomial other than binary case), and returned deviance was wrong for non-binary binomial. Fixed (did not affect estimation). * improvements to "bfgs" optimizer to better deal with `infinite' smoothing parameters. * changed scheme=3 in default 2-D plotting to grey scale version of scheme=2. * 'trichol' and 'bandchol' added for banded Cholesky decompositions, plus 'sdiag' functions added for extracting and setting matrix sub- and super- diagonals. * p-spline constructor and Predict.matrix.pspline.smooth now allow set up of SCOP-spline monotonic smoothers, and derivatives of smooths. Not used in modelling functions yet. * s(...,bs="re") now allows known precision matrix structures to be defined using the `xt' argument of 's' see ?smooth.construct.re.smooth.spec for details and example. * negbin() with a grid search for `theta' is no longer supported - use 'nb' instead. * bug fix to bam aic computation with AR rho correction. 1.8-11 * bam(...,discrete=TRUE) can now handle matrix arguments to smooths (and hence linear functional terms). * bam(...,discrete=TRUE) bug fix in fixed sp handling. * bam(...,discrete = TRUE) db.drho reparameterization fix, fixing nonsensical edf2. Also bam edf2 limited to maximum of edf1. * smoothCon rescaling of S changed to use efficient matrix norm in place of relatively slow computation involving model matrix crossproduct. * bam aic corrected for AR model if present. * Added select=TRUE argument to 'bam'. * Several discrete prediction fixes including improved thread safety. * bam/gam name gcv.ubre field by "method". * gam.side modified so that if a smooth has 'side.constrain==FALSE' it is neither constrained, nor used in the computation of constraints for other terms (the latter part being new). Very limited impact! * No longer checks if SUPPORT_OPENMP defined in Rconfig.h, but only if _OPENMP defined. No change in actual behaviour. 1.8-10 ** 'multinom' family implemented for multinomial logistic regression. * predict.bam now defaults to using efficient discrete prediction methods for models fit using discrete covariate methods (bam(...,discrete=TRUE)). * with bam(...,discrete=TRUE) terms like s(a,b,bs="re") had wrong p-value computation applied, as a result of being treated as tensor product terms. Fixed. * minor tweak to soap basis setup to avoid rounding error leading to 'approx' occasionally producing NA's with fixed boundaries. * misc.c:rwMatrix made thread safe (had been using R_chk_calloc, which isn't). * some upgrading for 64bit addressing. * uniquecombs now preserves contrasts on factors. * variable summary tweak so that 1 column matrices in parametric model are treated as regular numeric variables. 1.8-9 * C level fix in bam(...,discrete=TRUE) code. Some memory was mistakenly allocated via 'calloc' rather than 'R_chk_calloc', but was then freed via 'R_chk_free'. This could cause R to halt on some platforms. 1.8-8 ** New "gp" smooth class (see ?gp.smooth) implemeting the Matern covariance based Gaussian process model of Kamman and Wand (2003), and a variety of other simple GP smoothers. * some smooth plot methods now accept 'colors' and 'contour.col' argument to set color palette in image plots and contour line colors. * predict.gam and predict.bam now accept an 'exclude' argument allowing terms (e.g. random effects) to be zeroed for prediction. For efficiency, smooth terms not in 'terms' or in 'exclude' are no longer evaluated, and are instead set to zero or not returned. See ?predict.gam. * ocat saturated likelihood definition changed to zero, leading to better comprability of deviance between model fits (thanks to Herwig Friedl). * null.deviance calculation for extended families modified to make more sense when `mu' is the mean of a latent variable, rather than the response itself. * bam now returns standarized residuals 'std.rsd' if `rho!=0'. * bam(...,discrete=TRUE) can now handle 'fs' terms. * bam(...,discrete=TRUE) now accepts 'by' variables. Thanks to Zheyaun Li for debugging on this. * bam now works with drop.unused.levels == TRUE when random effects should have more levels than those that exist in data. (Thanks Alec Leh) * bam chunk.size logic error fix - error could be triggered if chunk.size reset automaticlly to be larger than data size. * uniqucombs can now accept a data frame with some or all factor columns, as well as purely numeric marices. * discrete.mf modified to avoid discretizing a covariate more than once, and to halt if a model requires the same covariate to be discretized two different ways (e.g. s(x) + s(x,z)). This affects only bam(...,discrete=TRUE). * Some changes to ziP and ziplss families to improve numerical robustness, and to ziP help file to suggest appropriate checking. Thanks to Keren Raiter, for reporting problems. * numerical robustness of extended gam methods (gam.fit4) improved for cases with many zero or near zero iterative weights. Handling of zero weights modified to avoid divide by (near) zero problems. Also tests for poor scaling of sqrt(abs(w))*z and substitutes computations based on w*z if detected. Also 'newton' routine now step halves if REML score not finite! * Sl.setup (used by bam) modification to allow more efficient handling of terms with multiple diagonal penalties with no non-zero elements in common, but possibly with non zero elements `interleaved' between penalties. 1.8-7 ** 'gam' default scale parameter changed to modified Pearson estimator developed by Fletcher 2012 Biometrika 99(1), 230-237. See ?gam.scale. ** 'bam' now has a 'discrete' argument to allow discretization of covariates for more efficient computation, with substantially more parallelization (via 'nthreads'). Still somewhat experimental. * Slightly more accurate smoothing parameter uncertainty correction. Changes edf2 used for AIC (under RE/ML), and hence may change AIC values. * jagam prior variance on fixed effects is now set with reference to data and model during initialization step. * bam could lose offset for small datasets in gaussian additive case. fixed. * gam.side now setup to include penalties in computations if fewer data than coefs (an exceedingly specialist topic). * p-value computation for smooth terms modified to avoid an ambiguity in the choice of test statistic that could lead to p-value changing somewhat between platforms. * gamm now warns if attempt is made to use extended family. * step fail logic improved for "fREML" optimization in 'bam'. * fix of openMP error in mgcv_pbsi, which could cause a problem in multi-threaded bam computation (failure to declare a variable as private). * Smoothing parameter uncertainty corrected AIC calculations had an indexing problem in Sl.postproc, which could result in failure of bam with linked smooths. * mroot patched for fact that chol(...,pivot=TRUE) does not operate as documented on rank deficient matrices: trailing block of triangular factor has to be zeroed for pivoted crossprod of factor to equal original matrix. * bam(...,sparse=TRUE) deprecated as no examples found where it is really worthwhile (but let me know if this is a problem). * marginal model matrices in tensor product smooths now stored in re-parameterized form, if re-parameterization happened (shouldn't change anything!). * initial.spg could fail if response vector had dim attributes and extended family used. fixed. 1.8-6 * Generalization of list formula handling to allow linear predictors to share terms. e.g. gam(list(y1~s(x),y2~s(z),1+2~s(v)+w-1),family=mvn(d=2)) * New German translation thanks to Detlef Steuer. * plot.gam now silently returns a list of plotting data, to help advanced users (Fabian Scheipl) to produce customized plot. * bam can now set up an object suitable for fitting, but not actually do the fit, following a suggestion by Fabian Scheipl. See arguments 'fit' and 'G'. 1.8-5 * Korean translation added thanks to Chel Hee Lee. * scale parameter handling in edf in logLik.gam made consistent with glm (affects AIC). * 'bam', 'gam' and 'gamm' modified to often produce smaller files when models saved (and never to produce absurdly large files). Achieved by setting environment of formula, terms etc to .GlobalEnv. Previously 'save' could save entire contents of environment of formula/terms with fitted model object. Note that change can cause failure in user written functions calling gam/bam and then 'predict' without supplying all prediction variables (fix obvious). * A help file 'single.index' supplied illustrating how single index models can be estimated in mgcv. * predict.gam now only creates a "constant" attribute if the model has one. * gam.fit4 convergence testing of coefs modified to more robust test of gradients of penalized dev w.r.t. params, rather than change in params, which can fail under rank deficiency. * mgcv_qrqy was not thread safe. Not noticeable on many platforms as all threads did exactly the same thing to the same matrix, but very noticeable on Windows. Thread safe mgcv_qrqy0 added and used in any parallel sections. * Allow openMP support if compiler supports it and provides pre-defined macro _OPENMP, even if SUPPORT_OPENMP undefined. (Allows multi-threading on Windows, for example.) * 'eps' is now an argument to 'betar' allowing some control on how to handle response values too close to 0 or 1. Help file expanded to emphasise the problems with using beta regression with 0s and 1s in the data. * fix of bug in multi-formula contrast handling, causing failure of prediction in some cases. * ziP and ziplss now check for non-integer (or binary) responses and produce an error message if these are found. Previously this was not trapped and could lead to a segfault. 1.8-4 ** JAGS/BUGS support added, enabling auto-generation of code and data required to used mgcv type GAMs with JAGS. Useful for complex random effects structures, for example. * smoothCon failed if selection penalties requested, but term was unpenalized. Now fixed (no selection penalties on unpenalized terms.) * gam.check would fail for tensor product smooths with by variables - fixed. * predict.gam would fail when predicting for more data than the blocksize but selecting only some terms. Fixed thanks to Scott Kostyshak. * smoothCon now has an argument `diagonal.penalty' allowing single penalty smooths to be re-parameterized in order to diagonalize the penalty matrix. PredictMat is modified to apply the same reparameterization, making it user transparent. Facilitates the setup of smooths for export to other packages. * predict.bam now exported in response to a request from another package maintainer. * 1.8 allows some prediction tasks for some families (e.g. cox.ph) to require response variables to be supplied. NAs in these then messed up prediction when they were not needed (e.g. if response variables with NAs were provided to predict.gam for a simple exponential family GAM). Response NAs now passed to the family specific prediction code, restoring the previous behaviour for most models. Thanks Casper Wilestofte Berg. * backend parallel QR code used by gam modified to use a pivoted block algorithm. * nthreads argument added to 'bam' to allow for parallel computation for computations in the main process (serial on any cluster nodes). e.g. QR based combination of results from cluster nodes is now parallel. * fREML computation now partly in parallel (controlled by 'nthreads' argument to 'bam') * slanczos now accepts an nt argument allowing parallel computation of main O(n^2) step. * fix to newton logic problem, which could cause an attempt to use 'score2' before definition. * fix to fREML code which could cause matrix square root to lose dimensions and cause an error. * initial.sp could perform very poorly for very low basis dimensions - could set initial sp to effective infinity. 1.8-3 * Fix of two illegal read/write bugs with extended family models with no smooths. (Thanks to Julian Faraway for reporting beta regr problem). * bam now checks that chunk.size > number of parameters and resets the chunk.size if not. * Examples of use of smoothCon and PredictMat for setting up bases for use outside mgcv (and then predicting) added to ?smoothCon. 1.8-2 * For exponential family gams, fitted by outer iteration, a warning is now generated if the Pearson scale parameter estimate is more than 4 times a robust estimate. This may indicate an unstable Pearson estimate. * 'gam.control' now has an option 'scale.est' to allow selection of the estimator to use for the scale parameter in exponential family GAMs. See ?gam.scale. Thanks to Trevor Davies for providing a clear unstable Pearson estimate example. * drop.unused.levels argument added to gam, bam and gamm to allow "mrf" (and "re") terms to have unobserved factor levels. * "mrf" constructor modified to deal properly with regions that contain no observations. * "fs" smooths are no longer eligible to have side conditions set, since they are fully penalized terms and hence always identifiable (in theory). * predict.bam was not declared as a method in NAMESPACE - fixed * predict.bam modified to strip down object to save memory (especially in parallel). * predict.gam now has block.size=NULL as default. This implies a block size of 1000 when newdata supplied, and use of a single block if no new data was supplied. * some messages were not printing correctly after a change in message handling to facilitate easier translation. Now fixed. 1.8-1 * bam modified so that choleski based fitting works properly with rank deficient model matrix (without regularization). * fix of 1.8-0 bug - gam prior weights mishandled in computation of cov matrix, resulting in incorrect variance estimates (even without prior weights specified). Thanks Fabian Scheipl. 1.8-0 *** Cox Proportional Hazard family 'cox.ph' added as example of general penalized likelihood families now useable with 'gam'. *** 'ocat', 'tw', 'nb', 'betar', 'ziP' and 'scat' families added for ordered categorical data, Tweedie with estimation of 'p', negative binomial with (fast) estimation of 'theta', beta regression for proportions, simple zero inflated Poisson regression and heavy tailed regression with scaled t distribution. These are all examples of 'extended families' now useable with 'gam'. *** 'gaulss' and 'ziplss' families, implementing models with multiple linear predictors. For gaulss there is a linear predictor for the Gaussian mean and another for the standard deviation. For ziplss there is a linear predictor controlling `presence' and another controlling the Poisson parameter, given presence. *** 'mvn' family for multivariate normal additive models. ** AIC computation changed for bam and gam models estimated by REML/ML to account for smoothing parameter uncertainty in degrees of freedom term. * With REML/ML smoothness selection in gam/bam an extra covariance matrix 'Vc' is now computed which allows for smoothing parameter uncertainty. See the 'unconditional' arguments to 'predict.gam' and 'plot.gam' to use this. * 'gam.vcomp' bug fix. Computed intervals for families with fixed scale parameter were too wide. * gam now defaults to the Pearson estimator of the scale parameter to avoid poor scale estimates in the quasipoisson case with low counts (and possibly elsewhere). Gaussian, Poisson and binomial inference invariant to change. Thanks to Greg Dropkin, for reporting the issue. * Polish translation added thanks to Lukasz Daniel. * gam.fit3 now forces eta and mu to be consistent with coef and valid on return (previously could happen that if step halving was used in final iteration then eta or mu could be invalid, e.g. when using identity link with non-negative data) * gam.fit3 now bases its convergence criteria on grad deviance w.r.t. model coefs, rather than changes in model coefs. This prevents problems when there is rank deficiency but different coefs get dropped at different iterations. Thanks to Kristynn Sullivan. * If mgcv is not on the search path then interpret.gam now tries to evaluate in namespace of mgcv with environment of formula as enclosing environment, if evaluation in the environment of the formula fails. * bug fix to sos plotting method so that it now works with 'by' variables. * 'plot.gam' now weights partial residuals by *normalized* square root iterative weights so that the average weight is 1 and the residuals should have constant variance if all is ok. * 'pcls' now reports if the initial point is not feasible. * 'print.gam' and 'summary.gam' now report the rank of the model if it is rank deficient. 'gam.check' reports the model rank whenever it is available. * fix of bug in 'k.check' called by 'gam.check' that gave an error for smooths with by variables. * predict.gam now checks that factors in newdata do not contain more levels than those used in fitting. * predict.gam could fail for type "terms" with no intercept - fixed. * 'bfgs' now uses a finite difference approximation for the initial inverse Hessian. 1.7-29 * Single character change to Makevars file so that openMP multi-threading actually works. 1.7-28 * exclude.too.far updated to use kd-tree instead of inefficient search for neighbours. This can make plot.gam *much* faster for large datasets. * Change in smoothCon, so that sweep and drop constraints (default for bam for efficiency reasons) are no longer allowed with by variables and matrix arguments (could lead to confusing results with factor by variables in bam). * 'ti' terms now allow control of which marginals to constrain, via 'mc'. Allows e.g. y ~ ti(x) + ti(x,z,mc=c(0,1)) - for experts only! * tensor.prod.model.matrix re-written to call C code. Around 5-10 times faster than old version for large data sets. * re-write of mini.mf function used by bam to generate a reduced size model frame for model setup. New version ensures that all factor levels are present in reduced frame, and avoids production of unrealistic combinations of variables in multi-dimensional smooths which could occur with old version. * bam models could fail if a penalty matrix was 1 by 1, or if multiple penalties on a smooth were in fact seperable into single penalties. Fixed. Thanks to Martijn weiling for reporting. * Constant in tps basis computation was different to published version for odd dimensions - makes no difference to fit, but annoying if you are trying to test a re-implementation. Thanks to Weijie Cai at SAS. * prediction for "cc" and "cp" classes is now cyclic - values outside the range of knots are wrapped back into the interval. * ldTweedie now returns derivatives w.r.t. a transform of p as well as w.r.t log of scale parameter phi. * gamm can now handle 'varComb' variance functions (thanks Sven Neulinger for reporting that it didn't). * fix of a bug which could cause bam to seg fault for a model with no smooths (insufficient storage allocated in C in this case). Thanks Martijn Weiling. 1.7-27 * Further multi-threading in gam fits - final two leading order matrix operations parallelized using openMP. * Export of smooth.construct.t2.smooth.spec and Predict.matrix.t2.smooth, and Rrank. * Fix of of missing [,,drop=FALSE] in predict.gam that could cause problems with single row prediction when 'terms' supplied (thanks Yang Yang). 1.7-26 * Namespace fixes. 1.7-25 * code added to allow openMP based multi-threading in gam fits (see ?gam.control and ?"mgcv-parallel"). * bam now allows AR1 error model to be split blockwise. See argument 'AR.start'. * magic.post.proc made more efficient (one of two O(np^2) steps removed). * var.summary now coerces character to factor. * bugs fixed whereby etastart etc were not passed to initial.spg and get.null.coefs. Thanks to Gavin Simpson. * reformulate removed from predict.gam to avoid (slow) repeated parser calls. * gaussian(link="log") initialization fixed so that negative data does not make it fail, via fix.family patching function. * bug fix in plot method for "fs" basis - ignored any side conditions. Thanks to Martijn Weiling and Jacolien van Rij. * gamm now checks whether smooths nested in factors have illegal side conditions, and halts if so (re-ordering formula can help). * anova.glmlist no longer called. * Compiled code now uses R_chck_calloc and R_chk_free for memory management to avoid the possibility of unfriendly exit on running out of memory. * fix in gam.side which would fail with unpenalized interactions in the presence of main effects. 1.7-24 * Examples pruned in negbin, smooth.construct.ad.smooth.spec and bam help files to reduce CRAN checking load. * gam.side now warns if only repeated 1-D smooths of the same variable are encountered, but does not halt. * Bug fix in C code for "cr" basis, that could cause a memory violation during prediction, when an extrapolation was immediately followed by a prediction that lay exactly on the upper boundary knot. Thanks to Keith Woolner for reporting this. * Fix for bug in fast REML code that could cause bam to fail with ti/te only models. Thanks to Martijn Wieling. * Fix of bug in extract.lme.cov2, which could cause gamm to fail when a correlation structure was nested inside a grouping factor finer than the finest random effect grouping factor. * Fix for an interesting feature of lme that getGroups applied to the corStruct that is part of the fitted lme object returns groups in sorted order, not data frame order, and without an index from one order to the other. (Oddly, the same corStruct Initialized outside lme has its groups in data frame order.) This feature could cause gamm to fail, complaining that the grouping factors for the correlation did not appear to be nested inside the grouping structure of the random effects. A bunch of ordering sensitivity tests have been added to the mgcv test suite. Thanks to Dave Miller for reporting the bug. 1.7-23 *** Fix of severe bug introduced with R 2.15.2 LAPACK change. The shipped version of dsyevr can fail to produce orthogonal eigenvectors when uplo='U' (upper triangle of symmetric matrix used), as opposed to 'L'. This led to a substantial number of gam smoothing parameter estimation convergence failures, as the key stabilizing re-parameterization was substantially degraded. The issue did not affect gaussian additive models with GCV model selection. Other models could fail to converge any further as soon as any smoothing parameter became `large', as happens when a smooth is estimated as a straight line. check.gam reported the lack of full convergence, but the issue could also generate complete fit failures. Picked up late as full test suite had only been run on R > 2.15.1 with an external LAPACK. ** 'ti' smooth specification introduced, which provides a much better (and very simple) way of allowing nested models based on 'te' type tensor product smooths. 'ti' terms are used to set up smooth interactions excluding main effects (so ti(x,z) is like x:z while te(x,z) is more like x*z, although the analogy is not exact). * summary.gam now uses a more efficient approach to p-value computation for smooths, using the factor R from the QR factorization of the weighted model matrix produced during fitting. This is a weighted version of the Wood (2013) statistic used previously - simulations in that paper essentially unchanged by the change. * summary.gam now deals gracefully with terms such as "fs" smooths estimated using gamm, for which p-values can not be computed. (thanks to Gavin Simpson). * gam.check/qq.gam now uses a normal QQ-plot when the model has been fitted using gamm or gamm4, since qq.gam cannot compute corrext quantiles in the presence of random effects in these cases. * gamm could fail with fixed smooths while assembling total penalty matrix, by attempting to access non-existent penalty matrix. (Thanks Ainars Aunins for reporting this.) * stripped rownames from model matrix, eta, linear predictor etc. Saves memory and time. * plot.soap.film could switch axis ranges. Fixed. * plot.mgcv.smooth now sets smooth plot range on basis of xlim and ylim if present. * formXtViX documentation fixed + return matrix labels. * fixDependence related negative index failures for completely confounded terms - now fixed. * sos smooth model matrix re-scaled for better conditioning. * sos plot method could produce NaNs by a rounding error in argument to acos - fixed. 1.7-22 * Predict.matrix.pspline.smooth now allows prediction outside range of knots, and uses linear extrapolation in this case. * missing drop=FALSE in reTest called by summary.gam caused 1-D random effect p-value computation to fail. Fixed (thanks Silje Skår). 1.7-21 ** soap film smoother class added. See ?soap * Polish translation added thanks to Lukasz Daniel. * mgcv/po/R-mgcv.pot up-dated. * plot methods for smooths modified slightly to allow methods to return plot data directly, without a prediction matrix. 1.7-20 * '...' now passed to termplot by plot.gam (thanks Andreas Eckner). * fix to null deviance computation for binomial when n>1, matrix response used and an offset is present. (Thanks to Tim Miller) * Some pruning of unused code from recov and reTest. * recov modified to stop it returning a numerically non-symmetric Ve, and causing occasional failures of summary.gam with "re" terms. * MRF smooth bug. Region ordering could become confused under some circumstances due to incorrect setting of factor levels. Corrected thanks to detailed bug report from Andreas Bender. * polys.plot colour/grey scale bug. Could ask for colour 0 from colour scheme, and therefore fail. Fixed. 1.7-19 ** summary.gam and anova.gam now use an improved p-value computation for smooth terms with a zero dimensional penalty null space (including random effects). The new scheme has been tested by full replication of the simulation study in Scheipl (2008,CSDA) to compare it to the best method therein. In these tests it is at least as powerful as the best method given there, and usually indistinguishable, but it gives slightly too low null p-values when smoothing parameters are very poorly identified. Note that the new p-values can not be computed from old fitted gam objects. Thanks to Martijn Wieling for pointing out how bad the p-values for regular smooths could be with random effects. * t2 terms now take an argument `ord' that allows orders of interaction to be selected. * "tp" smooths can now drop the null space from their construction via a vector m argument, to allow testing against polynomials in the null space. * Fix of vicious little bug in gamm tensor product handling that could have a te term pick up the wrong model matrix and fail. * bam now resets method="fREML" to "REML" if there are no free smoothing parameters, since there is no advantage to the "fREML" optimizer in this case, and it assumes there is at least one free smoothing parameter. * print.gam modified to print effective degrees of freedom more prettily, * testStat bug fix. qr was called with default arguments, which includes tol=1e-7... * bam now correctly returns fitting weights (rather than prior) in weights field. 1.7-18 * Embarrassingly, the adjusted r^2 computation in summary.gam was wrong for models with prior weights. Now fixed, thanks to Antony Unwin. * bam(...,method="fREML") could give incorrect edfs for "re" terms as a result of a matrix indexing error in Sl.initial.repara. Now fixed. Thanks to Martijn Wieling for reporting this. * summary.gam had freq=TRUE set as default in 1.7-17. This gave better p-values for paraPen terms, but spoiled p-values for fixed effects in the presence of "re" terms (a rather more common setup). Default now reset to freq=FALSE. * bam(...,method="fREML") made fully compatible with gam.vcomp. * bam and negbin examples speeded up * predict.gam could fail for models of the form y~1 when newdata are supplied. (Could make some model averaging methods fail). Fixed. * plot.gam had an overzealous check for availibility of variance estimates, which could make rank deficient models fail to plot CIs. fixed. 1.7-17 ** p-values for terms with no un-penalized components were poor. The theory on which the p-value computation for other terms is based shows why this is, and allows fixes to be made. These are now implemented. * summary p value bug fix --- smooths with no null space had a bug in lower tail of p-value computation, yielding far too low values. Fixed. * bam now outputs frequentist cov matrix Ve and alternative effective degrees of freedom edf1, in all cases. * smoothCon now adjusts null.space.dim on constraint absorption. * Prediction with matrix arguments (i.e. for models using summation convention) could be very memory hungry. This in turn meant that bam could run out of memory when fitting models with such terms. The problem was memory inefficient handling of duplicate evaluations. Now fixed by modification of PredictMat * bam could fail if the response vector was of class matrix. fixed. * reduced rank mrf smooths with supplied penalty could use the incorrect penalty rank when computing the reduced rank basis and fail. fixed thanks to Fabian Scheipl. * a cr basis efficiency change could lead to old fitted model objects causing segfaults when used with current mgcv version. This is now caught. 1.7-16 * There was an unitialized variable bug in the 1.7-14 re-written "cr" basis code for the case k=3. Fixed. * gam.check modified slightly so that k test only applied to smooths of numeric variables, not factors. 1.7-15 * Several packages had documentation linking to the 'mgcv' function help page (now removed), when a link to the package was meant. An alias has been added to mgcv-package.Rd to fix/correct these links. 1.7-14 ** predict.bam now added as a wrapper for predict.gam, allowing parallel computation ** bam now has method="fREML" option which uses faster REML optimizer: can make a big difference on parameter rich models. * bam can now use a cross product and Choleski based method to accumulate the required model matrix factorization. Faster, but less stable than the QR based default. * bam can now obtain starting values using a random sub sample of the data. Useful for seriously large datasets. * check of adequacy of basis dimensions added to gam.check * magic can now deal with model matrices with more columns than rows. * p-value reference distribution approximations improved. * bam returns objects of class "bam" inheriting from "gam" * bam now uses newdata.guaranteed=TRUE option when predicting as part of model matrix decomposition accumulation. Speeds things up. * More efficient `sweep and drop' centering constraints added as default for bam. Constaint null space unchanged, but computation is faster. * Underlying "cr" basis code re-written for greater efficiency. * routine mgcv removed, it now being many years since there has been any reason to use it. C source code heavily pruned as a result. * coefficient name generation moved from estimate.gam to gam.setup. * smooth2random.tensor.smooth had a bug that could produce a nonsensical penalty null space rank and an error, in some cases (e.g. "cc" basis) causing te terms to fail in gamm. Fixed. * minor change to te constructor. Any unpenalized margin now has corresponding penalty rank dropped along with penalty. * Code for handling sp's fixed at exactly zero was badly thought out, and could easily fail. fixed. * TPRS prediction code made more efficient, partly by use of BLAS. Large dataset setup also made more efficient using BLAS. * smooth.construct.tensor.smooth.spec now handles marginals with factor arguments properly (there was a knot generation bug in this case) * bam now uses LAPACK version of qr, for model matrix QR, since it's faster and uses BLAS. 1.7-13 ** The Lanczos routine in mat.c was using a stupidly inefficient check for convergence of the largest magnitude eigenvectors. This resulted in far too many Lanczos steps being used in setting up thin plate regression splines, and a noticeable speed penalty. This is now fixed, with many thanks David Shavlik for reporting the slow down. * Namespace modified to import from methods. Dependency on stats and graphics made explicit. * "re" smooths are no longer subject to side constraint under nesting (since this is almost always un-necessary and undesirable, and often unexpected). * side.con modified to allow smooths to be excluded and to allow side constraint computation to take account of penalties (unused at present). 1.7-12 * bam can now compute the leading order QR decomposition on a cluster set up using the parallel package. * Default k for "tp" and "ds" modified so that it doesn't exceed 100 + the null space dimension (to avoid complaints from users smoothing in quite alot of dimensions). Also default sub-sample size reduced to 2000. * Greater use of BLAS routines in the underlying method code. In particular all leading order operations count steps for gam fitting now use BLAS. You'll need R to be using a rather fancy BLAS to see much difference, however. * Amusingly, some highly tuned blas libraries can result in lapack not always giving identical eigenvalues when called twice with the same matrix. The `newton' optimizer had assumed this wouldn't happen: not any more. * Now byte compiled by default. Turn this off in DESCRIPTION if it interferes with debugging. * summary.gam p-value computation options modified (default remains the same). * summary.gam default p-value computation made more computationally efficient. * gamm and bam could fail under some options for specifying binomial models. Now fixed. 1.7-11 * smoothCon bug fix to avoid NA labels for matrix arguments when no by variable provided. * modification to p-value computation in summary.gam: `alpha' argument removed (was set to zero anyway); computation now deals with possibility of rank deficiency computing psuedo-inverse of cov matrix for statistic. Previously p-value computation could fail for random effect smooths with large datasets, when a random effect has many levels. Also for large data sets test statistic is now based on randomly sampling max(1000,np*2) model matrix rows, where np is number of model coefficients (random number generator state unchanged by this), previous sample size was 3000. * plot.mrf.smooth modified to allow passing '...' argument. * 'negbin' modified to avoid spurious warnings on initialization call. 1.7-10 * fix stupid bug in 1.7-9 that lost term labels in plot.gam. 1.7-9 * rather lovely plot method added for splines on the sphere. * plot.gam modified to allow 'scheme' to be specified for plots, to easily select different plot looks. * schemes added for default smooth plotting method, modified for mrfs and factor-smooth interactions. * mgcv function deprected, since magic and gam are much better (let me know if this is really a problem). 1.7-8 * gamm.setup fix. Bug introduced in 1.7-7 whereby gamm with no smooths would fail. * gamm gives returned object a class "gamm" 1.7-7 * "fs" smooth factor interaction class introduced, for smooth factor interactions where smoothing parameters are same at each factor level. Very efficient with gamm, so good for e.g. individual subject smooths. * qq.gam default method modified for increased power. * "re" terms now allowed as tensor product marginals. * log saturated likelihoods modified w.r.t. weight handling, so that weights are treated as modifying the scale parameter, when scale parameter is free. i.e. obs specific scale parameter is overall scale parameter divided by obs weight. This ensures that when the scale parameter is free, RE/ML based inference is invariant to multiplicative rescaling of weights. * te and t2 now accept lists for 'm'. This allows more flexibility with marginals that can have vector 'm' arguments (Duchon splines, P splines). * minor mroot fix/gam.reparam fix. Could declare symmetric matrix not symmetric and halt gam fit. * argument sparse added to bam to allow exploitation of sparsity in fitting, but results disappointing. * "mrf" now evaluates rank of penalty null space numerically (previously assumed it was always one, which it need not be with e.g. a supplied penalty). * gam.side now corrects the penalty rank in smooth objects that have been constrained, to account for the constraint. Avoids some nested model failures. * gamm and gamm.setup code restructured to allow smooths nested in factors and for cleaner object oriented converion of smooths to random effects. * gam.fit3 bug. Could fail on immediate divergence as null.eta was matrix. * slanczos bug fixes --- could segfault if k negative. Could also fail to return correct values when k small and kl < 0 (due to a convergence testing bug, now fixed) * gamm bug --- could fail if only smooth was a fixed one, by looking for non-existent sp vector. fixed. * 'cc' Predict.matrix bug fix - prediction failed for single points. * summary.gam failed for single coefficient random effects. fixed. * gam returns rV, where t(rV)%*%rV*scale is Bayesian cov matrix. 1.7-6 ** factor `by' variable handling extended: if a by variable is an ordered factor then the first level is treated as a reference level and smooths are only generated for the other levels. This is useful for avoiding identifiability issues in complex models with factor by variables. * bam bug fix. aic was reported incorrectly (too low). 1.7-5 * gam.fit3 modified to converge more reliably with links that don't guarantee feasible mu (e.g poisson(link="identity")). One vulnerability removed + a new approach taken, which restarts the iteration from null model coefficients if the original start values lead to an infinite deviance. * Duchon spline bug fix (could fail to create model matrix if number of data was one greater than number of unique data). * fix so that 'main' is not ignored by plot.gam (got broken in 1.7-0 object orientation of smooth plotting) * Duchon spline constructor now catches k > number of data errors. * fix of a gamm bug whereby a model with no smooths would fail after fitting because of a missing smoothing parameter vector. * fix to bug introduced to gam/bam in 1.7-3, whereby '...' were passed to gam.control, instead of passing on to fitting routines. * fix of some compiler warnings in matrix.c * fix to indexing bug in monotonic additive model example in ?pcls. 1.7-4 * Fix for single letter typo bug in C code called by slanczos, could actually segfault on matrices of less than 10 by 10. * matrix.c:Rlanczos memory error fix in convergence testing of -ve eigenvalues. * Catch for min.sp vector all zeroes, which could cause an ungraceful failure. 1.7-3 ** "ds" (Duchon splines) smooth class added. See ?Duchon.spline ** "sos" (spline on the sphere) smooth class added. See ?Spherical.Spline. * Extended quasi-likelihood used with RE/ML smoothness selection and quasi families. * random subsampling code in bam, sos and tp smooths modified a little, so that .Random.seed is set if it doesn't exist. * `control' argument changed for gam/bam/gamm to a simple list, which is then passed to gam.control (or lmeControl), to match `glm'. * Efficiency of Lanczos iteration code improved, by restructuring, and calling LAPACK for the eigen decompostion of the working tri-diagonal matrix. * Slight modification to `t2' marginal reparameterization, so that `main effects' can be extracted more easily, if required. 1.7-2 * `polys.plot' now exported, to facilitate plotting of results for models involving mrf terms. * bug fix in plot.gam --- too.far had stopped working in 1.7-0. 1.7-1 * post fitting constraint modification would fail if model matrix was rank deficient until penalized. This was an issue when mixing new t2 terms with "re" type random effects. Fixed. * plot.mrf.smooth bug fix. There was an implicit assumption that the `polys' list was ordered in the same way as the levels of the covariate of the smooth. fixed. * gam.side intercept detection could occasionally fail. Improved. * concurvity would fail if model matrix contained NA's. Fixed. 1.7-0 ** `t2' alternative tensor product smooths added. These can be used with gamm4. ** "mrf" smooth class added (at the suggestion of Thomas Kneib). Implements smoothing over discrete geographic districts using a Markov random field penalty. See ?mrf * qq.gam added to allow better checking of distribution of residuals. * gam.check modified to use qq.gam for QQ plots of deviance residuals. Also, it now works with gam(*, na.action = "na.replace") and NAs. * `concurvity' function added to provide simple concurvity measures. * plot.gam automatic layout modified to be a bit more sensible (i.e. to recognise that most screens are landscape, and that usually squarish plots are wanted). * Plot method added for mrf smooths. * in.out function added to test whether points are interior to a region defined by a set of polygons. Useful when working with MRFs. * `plot.gam' restructured so that smooths are plotted by smooth specific plot methods. * Plot method added for "random.effect" smooth class. * `pen.edf' function added to extract EDF associated with each penalty. Useful with t2 smooths. * Facilty provided to allow different identifiability constraints to be used for fitting and prediction. This allows t2 smooths to be fitted with a constraint that allows fitting by gamm4, but still perform inference with the componentwise optimal sum to zero constraints. * mgcv-FAQ.Rd added. * paraPen works properly with `gam.vcomp' and full.sp names returned correctly. * bam (and bam.update) can now employ an AR1 error model in the guassian-identity case. * bam.update modified for faster updates (initial scale parameter estimate now supplied in RE/ML case) * Absorption of identifiability constraints modified to allow constraints that only affect some parameters to leave rest of parameters completely unchanged. * rTweedie added for quick simulation of Tweedie random deviates when 1 pmin) * color example added to plot.gam.Rd * bug fix in `smooth.construct.tensor.smooth.spec' - class "cyclic.smooth" marginals no longer re-parameterized. * `te' documentation modified to mention that marginal reparameterization can destabilize tensor products. 1.3-17 * print.summary.gam prints estimated ranks more prettily (thanks Martin Maechler) ** `fix.family.link' can now handle the `cauchit' link, and also appends a third derivative of link function to the family (not yet used). * `fix.family.var' now adds a second derivative of the link function to the family (not yet used). ** `magic' modified to (i) accept an argument `rss.extra' which is added to the RSS(squared norm) term in the GCV/UBRE or scale calculation; (ii) accept argument `n.score' (defaults to number of data), the number to use in place of the number of data in the GCV/UBRE calculation. These are useful for dealing with very large data sets using pseudo-model approaches. * `trans' and `shift' arguments added to `plot.gam': allows, e.g. single smooth models to be easily plotted on uncentred response scale. * Some .Rd bug fixes. ** Addition of choose.k.Rd helpfile, including example code for diagnosing overly restrictive choice of smoothing basis dimension `k'. 1.3-16 * bug fix in predict.gam documentation + example of how to predict from a `gam' outside `R'. 1.3-15 * chol(A,pivot=TRUE) now (R 2.3.0) generates a warning if `A' is not +ve definite. `mroot' modified to supress this (since it only calls `chol(A,pivot=TRUE)' because `A' is usually +ve semi-definite). 1.3-14 * mat.c:mgcv_symeig modified to allow selection of the LAPACK routine actually used: dsyevd is the routine used previously, and seems very reliable. dsyevr is the faster, smaller more modern version, which it seems possible to break... rest of code still calls dsyevd. * Symbol registration added (thanks largely to Brian Ripley). Version depends on R >= 2.3.0 1.3-13 * some doc changes ** The p-values for smooth terms had too low power sometimes. Modified testing procedure so that testing rank is at most ceiling(2*edf.for.term). This gives quite close to uniform p-value distributions when the null is true, in simulations, without excessive inflation of the p-values, relative to parametetric equivalents when it is not. Still not really satisfactory. 1.3-12 * vis.gam could fail if the original model formula contained functions of covariates, since vis.gam calls predict.gam with a newdata argument based on the *model frame* of the model object. predict.gam now recognises that this has happened and doesn't fail if newdata is a model frame which contains, e.g. log(x) rather than x itself. offset handling simplified as a result. * prediction from te smooths could fail because of a bug in handling the list of re-parameterization matrices for 1-D terms in Predict.matrix.tensor.smooth. Fixed. (tensor product docs also updated) * gamm did not handle s(...,fx=TRUE) terms properly, due to several failures to count s(...,fx=FALSE) terms properly if there were fixed terms present. Now fixed. * In the gaussian additive mixed model case `gamm' now allows "ML" or "REML" to be selected (and is slightly more self consistent in handling the results of the two alternatives). 1.3-11 * added package doc file * added French error message support (thanks to Philippe Grosjean), and error message quotation characters (thanks to Brian Ripley.) 1.3-10 * a `constant' attribute has been added to the object returned by predict.gam(...,type="terms"), although what is returned is still not an exact match to what `predict.lm' would do. ** na.action handling made closer to glm/lm functions. In particular, default for predict.gam is now to pad predictions with NA's as opposed to dropping rows of newdata containing NA's. * interpret.gam had a bug caused by a glitch in the terms.object documentation (R <=2.2.0). Formulae such as y ~ a + b:a + s(x) could cause failure. This was because attr(tf,"specials") is documented as returning indices of specials in `terms'. It doesn't, it indexes specials in the variables dimension of the attr(tf,"factors") table: latter now used to translate. * `by' variable use could fail unreasonably if a `by' variable was not of mode `numeric': now coerced to numeric at appropriate times in smooth constructors. 1.3-9 * constants multiplying TPRS basis functions were `unconventional' for d odd in function eta() in tprs.c. The constants are immaterial if you are using gam, gamm etc, but matter if you are trying to get out the explicit representation of a TPRS term yourself (e.g. to differentiate a smooth exactly). 1.3-8 * get.var() now checks that result is numeric or factor (avoids occasional problems with variable names that are functions - e.g `t') * fix.family.var and fix.family.link now pass through unaltered any family already containing the extra derivative functions. Usually, to make a family work with gam.fit2 it is only necessary to add a dvar function. * defaults modified so that when using outer iteration, several performance iteration steps are now used for initialization of smoothing parameters etc. The number is controlled by gam.control(outerPIsteps). This tends to lead to better starting values, especially with binary data. gam, gam.fit and gam.control are modified. * initial.sp modified to allow a more expensive intialization method, but this is not currently used by gam. * minor documentation changes (e.g. removal of full stops from titles) 1.3-7 * change to `pcls' example to account for model matrix rescaling changing smoothing parameter sizes. * `gamm' `control' argument set to use "L-BFGS-B" method if `lme' is using `optim' (only does this if `nlminb' not present). Consequently `mgcv' now depends on nlme_3.1-64 or above. * improvement of the algorithm in `initial.sp'. Previously it was possible for very low rank smoothers (e.g. k=3) to cause the initialization to fail, because of poor handling of unpenalized parameters. 1.3-6 * pdIdnot class changed so that parameters are variances not standard deviations - this makes for greater consistency with pdTens class, and means that limits on notLog2 parameterization should mean the same thing for both classes. ** niterEM set to 0 in lme calls. This is because EM steps in lme are not set up to deal properly with user defined pdMat classes (latter confirmed by DB). 1.3-5 ** Improvements to anova and summary functions by Henric Nilsson incorporated. Functions are now closer to glm equivalents, and printing is more informative. See ?anova.gam and ?summary.gam. * nlme 3.1-62 changed the optimizer underlying lme, so that indefintie likelihoods cause problems. See ?logExp2 for the workaround. - niterEM now reset to 25, since parameterization prevents parameters wandering to +/- infinity (this is important as starting values for Newton steps are now more critical, since reparameterization introduces new local minima). ** smoothCon modified to rescale penalty coefficient matrices to have similar `size' to X'X for each term. This is to try and ensure that gamm is reasonably scale invariant in its behaviour, given the logExp2 re-parameterization. * magic dropped dimensions of an array inapproporiately - fixed. * gam now checks that model does not have more coefficients than data. 1.3-4 * inst/CITATION file added. Some .Rd fixes 30/6/2005 1.3-3 * te() smooths were not always estimated correctly by gamm(): invariance lost and different results to equivalent s() smooths. The problem seems to lie in a sensitivity of lme() estimation to the absolute size of the `S' attribute matrices of a pdTens class pdMat object: the problem did not occur at the last revision of the pdTens class, and there are no changes logged for nlme that could have caused it, so I guess it's down to a change in something that lme calls in the base distribution. To avoid the problem, smooth.construct.tensor.smooth.spec has been modified to scale all marginal penalty matrices so that they have largest singular value 1. * Changes to GLMs in R 2.1.1 mean that if the response is an array, gam could fail, due to failure of terms like w * X when w is and array rather than a vector. Code modified accordingly. * Outer iteration now suppresses some warnings, until the final fitted model is obtained, in order to avoid printing warnings that actually don't apply to the final fit. * Version number reporting made (hopefully) more robust. * pdconstruct.pdTens removed absolute lower limit on coef - replaced with relative lower limit. * moved tensor product constraint construction to BEFORE by variable stuff in smooth.construct.tensor.smooth.spec. 1.3-1 * vcov had been left out of namespace - fixed. * cr and cc smooths now trap the case in which the incorrect number of knots are supplied to them. * `s(.)' in a formula could cause a segfault, it get's trapped now, hopefully it will be handled nicely at some point in the future. Thanks Martin Maechler. * wrong n reported in summary.gam() in the generalized case - fixed. Thanks YK Chau. 1.3-0 *** The GCV/UBRE score used in the generalized case when fitting by outer iteration (the default) in version 1.2 was based on the Pearson statistic. It is prone to serious undersmoothing, particularly of binary data. The default is now to use a GCV/UBRE score based on the deviance: this performs much better, while still maintaining the enhanced numerical convergence performance of outer iteration. * The Pearson based scores are still available as an option (see ?gam.method) * For the known scale parameter case the default UBRE score is now just a linearly rescaled AIC criterion. 1.2-6 * Two bugs in smooth.sconstruct.tensor.smooth.spec: (i) incorrect testing of class of smooth before re-parameterizing, so that cr smooths were re-parameterized, when there is no need to; (ii) knots used in re-parameterization were based on quantiles of the relevant marginal covariate, which meant that repeated knots could be generated: now uses quantiles of unique covariate values. * Thanks to Henric Nilsson a bug in the documentation of magic.post.proc has been fixed. 1.2-5 ** Bug fix in gam.fit2: prior weights not subsetted for non-informative data in GCV/UBRE calculation. Also plot.gam modified to allow for consequent NA working residuals. Thanks to B. Stollenwerk for reporting this bug. ** vcov.gam written by Henric Nilsson included... see ?vcov.gam * Some minor documentation fixes. * Some tweaking of tolerances for outer iteration (was too lax). ** Modification of the way predict.gam picks up variables. (complication is that it should behave like other predict functions, but warn if an incomplete prediction data frame is supplied -since latter violates what white book says). 1.2-2 *** An alternative approach to GCV/UBRE optimization in the *generalized* additive model case has been implemented. It leads to more reliable convergence for models with concurvity problems, but is slower than the old default `performance iteration'. Basically the GAM IRLS process is iterated to convergence for each trial set of smoothing parameters, and the derivatives of the GCV/UBRE score w.r.t. smoothing parameters are calculated explicitly as part of the IRLS iteration. This means that the GCV/UBRE optimization is now `outer' to the IRLS iteration, rather than being performed on each working model of the IRLS iteration. The faster `performance iteration' is still available as an option. As a side effect, when using outer iteration, it is not possible to find smoothing parameters that marginally improve on the GCV/UBRE scores of the estimated ones by hand tuning: this improves the logical self consistency of using GCV/UBRE scores for model selection purposes. * To facilitate the expanded list of fitting methods, `gam' now has a `method' argument requiring a 3 item list, specifying which method to use for additive models, which for generalized additive models and if using outer iteration, which optimization routine to use. See ?gam.method for details. `gam.control' has also been modified accordingly. *** By default all smoothing bases are now automatically re-parameterized to absorb centering constraints on smooths into the basis. This makes everything more modular, and is usually user transparent. See ?gam.control to get the old behaviour. ** Tensor product smooths (te) now use a reparameterization of the marginal smoothing bases, which ensures that the penalties of a tensor product smooth retain the interpretation, in terms of function shape, of the marginal penalties from which they are induced. In practice this almost always improves MSE performance (at least for smooth underlying functions.) See ?te to turn this off. *** P-values reported by anova.gam and summary.gam are now based on strictly frequentist calculations. This means that they are much better justified theoretically, and are interpretable as ordinary frequentist p-values. They are still conditional on smoothing parameters, however, and are hence underestimates when smoothing parameters have been estimated. ** Identifiability side conditions modified to work with all smooths (including user defined). Now works by identifying possible dependencies symbolically, but dealing with the resulting degeneracies numerically. This allows full ANOVA decompositions of functions using tensor product smooths, for example. * summary.gam modified to deal with prior weights in adjusted r^2 calculation. ** `gam' object now contains `Ve' the frequentist covariance matrix of the paremeter estimators, which is useful for p-value calculation. see ?gamObject and ?magic.post.proc for details. * Now depends on R >=2.0.0 * Default residual plots modified in `gam.check' ** Added `cooks.distance.gam' function. * Bug whereby te smooths ignored `by' variables is now fixed. 1.1-6 * Smoothing parameter initialization method changed in magic, to allow better initialization of te() terms. This affects default gam fits. * gamm and extract.lme.cov2 modified to work correctly when the correlation structure applies to a finer grouping than the random effects. (Example of this added to gamm help file) * modifications of pdTens class. pdFactor.pdTens now returns a vector, not a matrix in accordance with documentation (in nlme 3.1-52). Factors are now always of form A=B'B (previously, could be A=BB') in accordance with documentation (nlme 3.1-52). pdConstruct.pdTens now tests whether initializing matrix is proportional to r.e. cov matrix or its inverse and initializes appropriately. gamm fitting with te() class tested extensively with modifications and nlme 3.1-52, and lme fits with pdTens class tested against equivalent fits made using re-parameterization and pdIdent class. In particular for gamm testing : model fits with single argument te() terms now match their equivalent models using s() terms; models fitted using gam() and gamm() match if gam() is called with the gamm() estimated smoothing parameters. * modifications of gamm() for compatibility with nlme 3.1-52: in particular a work around to allow everything to work correctly with a constructed formula object in lme call. * some modifications of plot.gam to allow greater control of appearance of plots of smooths of 2 variables. * added argument `offset' to gam for further compatibility with glm/lm. * change to safe prediction for parameteric terms had a bug in offset handling (offset not picked up if no newdata supplied, since model frame not created in this case). Fixed. (thanks to Jim Young for this) 1.1-5 * predict.gam had a further bug introduced with parametric safe prediction. Fixed by using a formula only containing the actual variable names when collecting data for prediction (i.e. no terms like `offset(x)') 1.1-5 * partial argument matching made col.shade be matched by col passed in ..in plot.gam, taking away user control of colors. 1.1-5 * 2d smooth plotting in plot.gam modified. * plot.gam could fail with residuals=TRUE due to incorrect counting in the code allowing use of termplot. plot.gam failed to prompt before a newpage if there was only one smooth. gam and gamm .Rd files updated slightly. 1.1-3 * extract.lme.cov2 could fail for random effect group sizes of 1 because submatrices with only a row or column lose their dimensions, and because single number calls to diag() result in an identity matrix. 1.1-2 * Some model formulae constructed in interpret.gam and used in facilitating safe prediction for parametric terms had the wrong environment - this could cause gam to fail to find data when e.g. lm, would find it. (thanks Thomas Maiwald) * Some items were missing from the NAMESPACE file. (thanks Kurt Hornik) * A very simple formula.gam function added, purely to facilitate better printing of anova method results under R 2.0.0. 1.1-1 * Due, no doubt, to gross moral turpitude on the part of the author, gamm() calculated the complete estimated covariance matrix of the response data explicitly, despite the fact that this matrix is usually rather sparse. For large datasets this could easily require more memory than was available, and huge computational expense to find the choleski decomposition of the matrix. This has now been rectified: when the covariance matrix has diagonal or block diagonal structure, then this is exploited. * Better examples have been added to gamm(). * Some documentation bugs were fixed. 1.1-0 Main changes are as follows. Note that `gam' object has been modified, so old objects will not always work with version 1.1 functions. ** Two new smooth classes "cs" and "ts": these are like "cr" and "tp" but can be penalized all the way down to zero degrees of freedom to allow fully automatic model selection (more self consistent than having a step.gam function). * The gam object expanded to allow inheritance from type lm and type glm, although QR related components of glm and lm are not available because of the difference in fitting method between glm/lm and gam. ** An anova method for gam objects has been added, for *approximate* hypothesis testing with GAMs. ** logLik.gam added (logLik.glm with df's fixed): enables AIC() to be used with gam objects. ** plot.gam modified to allow plotting of order 1 parametric terms via call to termplot. * Thanks to Henric Nilsson option `shade' added to plot.gam * predict.gam modified to allow safe prediction of parametric model components (such as poly() terms). * predict.gam type="terms" now works like predict.glm for parametric components. (also some enhancements to facilitate calling from termplot()) * Range of smoothing parameter estimation iteration methods expanded to help with non-convergent cases --- see ?gam.convergence * monotonic smoothing examples modified in light of above changes. * gamm modified to allow offset terms. * gamm bug fixed whereby terms in a model formula could get lost if there were too many of them. * gamm object modified in light of changes to gam object. 1.0-7 * Allows a model frame to be passed as `newdata' to predict.gam: it must contain all the terms in the gam objects model frame, `model'. * vis.gam() now passes a model frame to predict.gam and should be more robust as a result. `view' and `cond' must contain names from `names(x$model)' where x is the gam object. 1.0-6/5/4 * partial residuals modified to be IRLS residuals, weighted by IRLS weights. This is a much better reflecton of the influence of residuals than the raw IRLS residuals used before. * gamm summary sorted out by using NextMethod to get around fact that summary.pdMat can't be called directly (not in nlme namespace exports). * niterPQL and verbosePQL arguments added to gamm to allow more control of PQL iteration. * backquote=TRUE added when deparsing to allow non-standard names. (thanks: Brian Ripley) * bug in gam corrected: now gives correct null deviance when an offset is present. (thanks: Louise Burt) * bug in smooth.construct.tp.smooth.spec corrected: k=2 caused a segfault as the C code was reseting k to 3 (actually null space dimension +1), and not enough space was being allocated in R to handle the resultng returned objects. k reset in R code, with warning. (Thanks: Jari Oksanen) * predict.gam() now has "standard" data searching using a model frame based on a fake formula produced from full.formula in the fitted object. However it also warns if newdata is present but incomplete. This means that if newdata does not meet White book specifications, you get a warning, but the function behaves like predict.lm etc. predict.gam had been segfaulting if variables were missing from newdata (Thanks: Andy Liaw and BR) * contour option added to vis.gam * te smooths can be forced to use only a single penalty (theoretical interest only - not recommended for practical use) 1.0-3 * Fixes bugs in handling graphics parameters in plot.gam() * Adds option of partial residuals to plot.gam() 1.0-2/1 * Fixes a bug in evaluating variables of smooths, knots and by-variables. 1.0-0 *** Tensor product smooths - any bases available via s() terms in a gam formula can be used as the basis for tensor product smooths of multiple covariates. A separate wiggliness penalty and smoothing parameter is associated with each `marginal' basis. ** Cyclic smoothers: penalized cubic regression splines which have the same value and first two derivatives at their first and last knots. *** An object oriented approach to handling smooth terms which allows the user to add their own smooths. Smooth terms are constructed using smooth.construct method functions, while predictions from individual smooth terms are handled by predict.matrix method functions. ** p-splines implemented as the illustrative example for the above in the help files. *** A generalized additive mixed model function gamm() with estimation via lme() in the normal-identity case and glmmPQL() otherwise. The main aim of the function is to allow a defensible way of modelling correlated error structures while using a GAM. * The gam object itself has changed to facilitate the above. Most information pertaining to smooth terms is now stored in a list of smooth objects, whose classes depend on the bases used. The objects are not back compatible, and neither are the new method functions. This has been done in an attempt to minimize the scope for bugs, given the amount of time available for maintenance. ** s() no longer supports old stlye (version <0.6) specification of smooths (e.g. s(x,10|f)). This is in order to reduce the scope for problems with user defined smooth classes. * The mgcv() function now has an argument list more similar to magic(). * Function GAMsetup() has been removed. * I've made a general attempt to make the R code a bit less like a simultaneous translation from C. 0.9-5/4/3/2/1 * Mixtures of fixed degree of freedom and estimated degree of freedom smooths did not work correctly with the perf.iter=FALSE option. Fixed. * fx=TRUE not handled correctly by fit.method="magic": fixed. * some fixes to GAMsetup and gam documentation. * call re-instated to the fitted gam object to allow updating * -Wall and -pedantic removed from Makevars as they are gcc specific. * isolated call to Stop() replaced by call to stop()! 0.9-0 *** There is a new underlying smoothing parameter selection method, based on pivoted QR decomposition and SVD methods implemented in LAPACK. The method is more stable than the Wood (2000) method and allows the user to fix some smoothing parameters while estimating others, regularize the GAM fit in non-convergent cases and put lower bounds on smoothing parameters. The new method can deal with rank deficient problems, for example if there is a lack of identifiability between the parametric and smooth parts of the model. See ?magic for fuller details. The old method is still available, but gam() defaults to the new method. * Note that the new method calls LAPACK routines directly, which means that the package now depends on external linear algebra libraries, rather than relying entirely on my linear algebra routines. This is a good thing in terms of numerical robustness and speed, but does mean that to install the package from source you need a BLAS library installed and accesible to the linker. If you sucessfully installed R by building from source then you should have no problem: you have everything already installed, but occasionally users may have to install ATLAS in order to install from source. * Negative binomial GAMs now use the families supplied by the MASS library and employ a fast integrated GCV based method for estiamting the negative binomial parameter. See ?gam.neg.bin for details. The new method seems to converge slightly more often than the old method, and does so more quickly. * persp.gam() has been replaced by a new routine vis.gam() which is prettier, simpler and deals better with factor covariates and at all with `by' variables. * NA's can now be handled properly in a manner consistent with lm() and glm() [thanks to Brian Ripley for pointing me in the right direction here] and there is some internal tidying of GAM so that it's behavious is more similar to glm() and lm(). * Users can now choose to `polish' gam model fits by adding an nlm() based optimization after the usual Gu (2002) style `power iteration' to find smoothing parameters. This second stage will typically result in a slightly lower final GCV/UBRE score than the defualt method, but is much slower. See ?gam.control for more information. * The option to add a ridge penalty to the GAM fitting objective has been added to help deal with some convergence issues that occur when the linear predictor is essentially un-identifiable. see ?gam.control. 0.8-7 * There was a bug in the calculation of identifiability side conditions that could lead to over constraint of smooths using `by' variables in models with mixtures of smooths of different numbers of variables. This has been fixed. 0.8-6 * Fixes a bug which occured with user supplied smoothing parameters, in which the weight vector was omitted from part of the influence (hat) matrix calculation. This could result in non-sensical variance estimates. * Stronger consistency checks introduced on estimated degrees of freedom. 0.8-5 * mgcv was using Machine() which is deprecated from R 1.6.0, this version uses .Machine instead. 0.8-4 * There was a memory bug which could occur with the "cr" basis, in which un-allocated memory was written to in the tps_g() routine in the compiled C code - this occured when that routine was asked to clean up its memory, when there was nothing to clean up. Thanks to Luke Tierney for finding this problem and locating it to tps_g()! * A very minor memory leak which occured when knots are used to start a tps basis was fixed. 0.8-3 * Elements on leading diagonal of Hat/Influence matrix are now returned in gam object. * Over-zealous error trap introduced at 0.8-2, caused failure with smoothless models. 0.8-2 * User can now supply smoothing parameters for all smooth terms (can't have a mixture of supplied and estimated smoothing parameters). Feature is useful if e.g. GCV/UBRE fails to produce sensible estimates. * svd() replaced by La.svd() in summary.gam(). * a bug in the Lanczos iteration code meant that smooths behaved poorly if the smooth had exactly one less degree of freedom than the number of data (the wrong eigenvectors were retained in this case) - this was a rather rare bug in practice! * pcls() was not using sensible tolerances and svdroot() was using tolerances incorrectly, leading to problems with pcls(), now fixed. * prior weights were missing from the pearson residuals. * Faulty by variable documentation fixed (have lost name of person who let me know this, but thanks!) * Scale factor removed from Pearson residual calculation for consistancy with a higher proportion of authors. * The proportion deviance explained has been added to summary.gam() as a better measure than r-squared in most cases. * Routine SANtest() has been removed (obsolete). * A bug in the select option of plot.gam has been fixed. 0.8-1 * The GCV/UBRE score can develop phantom minima for some models: these are minima in the score for the IRLS problem which suggest large parameter changes, but which disappear if those large changes are actually made. This problem occurs in some logistic regression models. To aid convergence in such cases, gam.fit now switches to a cautious mgcv optimization method if convergence has not been obtained in a user defined number of iterations. The cautious mode selects the local minimum of the GCV/UBRE closest to the previous minimum if multiple minima are present. See gam.control for details about controlling iterations. * Option trace in gam.control now prints and plots more useful information for diagnosing convergence problems. * The one explicit formation of an inverse in the underlying multiple GCV optimization has been replaced with something more stable (and quicker). * A bug in the calculation of side conditions has been fixed - this caused a failure with models having parametric terms and terms like: s(x)+s(z)+s(z,x). * A bug whereby predict.gam simply failed to pick up offset terms has been fixed. * gam() now drops unused levels in factors. * A bug in the conversion of svd convergence criteria between version 0.7-2 and 0.8-0 has been fixed. * Memory leaks have been removed from the C code (thanks to the superb dmalloc library). * A bug that caused an undignified exit when 1-d smoothing with full splines in 0.8-0 has been fixed. 0.8-0 * There was a problem on some platforms resulting from the default compiler optimizations used by R. Specifically: floating point registers can be used to store local variables. If the register is larger than a double (as is the case for Intel 486 and up), this means that: double a,b; a=b; if (a==b) can evaluate as FALSE. The mgcv source code assumed that this could never happen (it wouldn't under strict ieee fp compliance, for example). As a result, for some models using the package compiled using some compiler versions, the one dimensional "overall" smoothing parameter search could fail, resulting in convergence failure, or undersmoothing. The Windows version from CRAN was OK, but versions installed under Linux could have problems. Version 0.8 does not make the problematic assumption. * The search for the optimal overall smoothing parameter has been improved, providing better protection against local minima in the GCV/UBRE score. * Extra GCV/UBRE diagnostics are provided, along with a function gam.check() for checking them. * It is now possible for the user to supply "knots" to be used when producing the t.p.r.s. basis, or for the cubic regression spline basis. This makes it feasible to work with very large datasets using the of the data. It also provides a mechanism for obtaining purely "knot based" thin plate regression splines. * A new mechanism is provided for allowing a smooth term to be multiplied by a covariate within the model. Such "by" variables allow smooths to be conditional on factors, for example. * Formulae such as y~s(x)+s(z)+s(x,z) can now be used. * The package now reports the UBRE score of a fitted model if UBRE was used for smoothing parameter selection, and the GCV score otherwise. * A new help page gam.models has been added. * A bug whereby offsets in model formulae only worked if they were at the end of the formulae has been fixed. * A bug whereby weights could not be supplied in the model data frame has been fixed. * gam.fit has been upgraded using the R 1.5.0 version of glm.fit * An error in the documentaion of xp in the gam object has been fixed, in addition to numerous other changes to the documentation. * The scoping rules employed by gam() have been brought into line with lm() and glm by searching for variables in the environment of the model formula rather than in the environment from which gam() was called - usually these are the same, but not always. * A bug in persp.gam() has been fixed, whereby slice information had to be supplied in a particular order. * All compiled code calls now specify package mgcv to avoid any possibility of calling the wrong function. * All examples now set the random number generator seed to facilitate cross platform comparisons. 0.7-2 * T and F changed to TRUE and FALSE in code and examples. * Minor predict.gam error fixed (didn't get correct fitted values if called without new data and model contained multi-dimensional smooths). 0.7-1 * There was a somewhat over-zealous warning message in the single smoothing parameter selection code - gave a warning everytime that GCV suggested a smoothing parameter at the boundary of the search interval - even if this GCV function was also flat. Fixed. * The search range for 1-d smoothing parameter selection was too wide - it was possible to give so little weight to the data that numerical problems caused all parameters to be estimates as zero (along with the edf for the term!). The range has been narrowed to something more sensible [above warning should still be triggered if it is ever too narrow - but this should not be possible]. * summary.gam() documentation extended a bit. p-values for smooths are slightly improved, and an example included that shows the user how to check them! 0.7-0 * The underlying multiple GCV/UBRE optimization method has been considereably strengthened, as follows: o First and second guess starting values for the relative smoothing parameters have been improved. o Steepest descent is used if either: i) the Hessian of the objective is not positive definite, or (ii) Steps in the Newton direction fails to improve the GCV/UBRE score after 4 step halvings (since in this case the quadratic model is clearly poor). o Newton steps are rescaled so that the largest step component (in log relative smoothing parameters) is of size 5 if any step components are >5. This avoids very large Newton steps that can occur in flat regions of the objective. o All steepest descent steps are initially scaled so that their longest component is 1, this avoids long steps into flat regions of the objective. o MGCV Convergence diagnostics are returned from routines mgcv and gam. o In gam.fit() smoothing parameters are re-auto-initialized during IRLS if they have become so far apart that some are likely to be in flat parts of the GCV/UBRE score. o A bug whereby poor second guesses at relative smoothing parameters could lead to acceptance of the first guess at these parameters has been removed. o The user is warned if the initial smoothing parameter guesses are not improved upon (can happen legitmately if all s.p.s should be very high or very low.) The end result of these changes is to make fits from gam much more reliable (particularly when using the tprs basis available from version 0.6). * A summary.gam and associated print function are provided. These provide approximate p-values for all model terms. * plot.gam now provides a mechanism for selecting single plots, and allows jittering of rug plots. * A bug that prevented models with no smooth terms from being fitted has been removed. * A scoping bug in gam.setup has been fixed. * A bug preventing certain mixtures of the bases to be used has been fixed. * The neg.bin family has been renamed neg.binom to avoid masking a function in the MASS library. 0.6-2 revisions from 0.6.1 * Relatively important fix in low level numerics. Under some circumstances the Lanczos routines used to find the thin plate regression spline basis could fail to converge or give wrong answers (many thanks to Charles Paxton for spotting this). The problem was with an insufficiently stable inverse iteration scheme used to find eigenvectors as part of the Lanczos scheme. The scheme had been used because it was very fast: unfortuantely stabilizing it is as computationally costly as simply accumulating eigen-vectors with the eigen-values - hence the latter has now been done. Some further examples also added. 0.6-1 * Junk files removed from src directory. * 3 C++ style comments removed from tprs.c. 0.6-0 * Multi-dimesional smoothing is now available, using "thin plate regression splines" (MS submitted). These are based on optimal approximations to the thin-plate splines. * gam formula syntax upgraded (see ?s ). Old syntax still works, with the exception that if no df specified then the tprs basis is always used by default. * plot.gam can now deal with two dimensional smooth terms as well as one dimensional smooths. * persp.gam added to allow user to visualize slices through a gam [Mike Lonergan] * negative binomial family added [Mike Lonergan] - not quite as robust as rest of families though [can have convergence problems]. * predict.gam now has an option to return the matrix mapping the parameters to the linear predictor at the supplied covariate values. * Variance calculation has been made more robust. * Routine pcls added, for penalized, linearly constrained optimization (e.g. monotonic splines). * Residual method provided (there was a bug in the default - Thanks Carmen Fernandez). * The cubic regression spline basis behaved wrongly when extrapolating [thanks Sharon Hedley]. This is now fixed. * Tests included to check that there are enough unique covariate combinations to support the users choise of smoothing basis dimension. * Internal storage improved so that large numbers of zeroes are no longer stored in arrays of matrices. * Some method argument lists brought into line with the R default versions. 0.5 * There was a bug in gam.fit(). The square roots of the correct iterative weights were being used in place of the weights: the bug was apparent because the sum of fitted values didn't always equal the sum of the response data when using the canonical link (which it should as a result of X'f=X'y when canonical link used and unpenalized). The bug has been corrected, and the correction tested. This problem did not affect (unweighted) additive models, only generalized additive models. * There was a bug that caused a crash in the compiled code when there were more than 8000 datapoints to fit. This has been fixed. * The package now reports its version number when loaded into R. * predict.gam() now returns predictions for the original covariate values (used to fit the model) when called without new data. * predict.gam() now allows type="response" as an argument - returning predictions on the scale of the response variable. * plot.gam() no-longer defaults to automatic page layout, use argument pages=1 to get the old default behaviour. * A bug that could cause a crash with the model formula y~s(x)-1 has been fixed. * Yet more sloppy practices are now allowed for naming variables in model formulae. e.g. d$y ~ s(d$x) now works, although its not recommended. * The GCV score is now reported by print.gam() (whether or not GCV was actually used - it isn't the default for Poisson or binomial). * plot.gam() modified to avoid prompting for input when not used interactively. 0.4 * Transformations allowed on lhs of gam formulae . * Argument order same as Splus gam. * Search for data now designed to be like lm() , so you can now be quite sloppy about where your data are. * The above mean that Venables and Ripley examples can be run without having to read the documentation for gam() so carefully! * A bug in the standard error calculations for parametric terms in predict.gam() is fixed. * A serious bug in the handling of factors was fixed - it was previously possible to obtain a rank deficient design matrix when using factors, despite having specified an identifiable model. * Some glitches when dealing with formulae containing offset() and/or I() have been fixed. * Fitting defaults can now be altered using gam.control when calling gam() 0.3-3 * Documentation updated, including removal of wrong information about constraints and mgcv . Also some readability changes in code and no smooths are now allowed. 0.3-2/1 * Allows all ways of specifying a family that glm() allows (previously family=poisson or family="poisson" would fail). Some more documentation fixes. * 0.2 lost the end of long formulae (because of a difference in the way that R and Splus deal with formulae). This is now fixed. * A minor error that meant that QT() failed under some versions of Windows is now fixed. * All package functions now have help(). Also the help files have been more carefully checked - version 0.2 actually contained no information on how to write a GAM formula as a result of a single missing '}' in the help file! 0.2 * Fixed d.f. regression splines allowed as part of gam() model specification. * Bug in knot placement algorithm fixed (caused crash with df close to number of data). * Replicate covariate values dealt with properly in gam()! * Data search method in gam() revised - now looks in frame from which gam() called. * plot.gam() can now deal with missing variance estimates gracefully. * Low (1,2) d.f. smooths dealt with gracefully by gam() - no longer cause freeze or crash. * Confidence intervals simulation tested for normal(identity), poisson(log), binomial(logit) and gamma(log) cases. Average coverage probabilities from 0.89 to 0.97 term by term, 0.93 to 0.96 "across the model", for nominal 0.95. * R documentation updated and tidied. mgcv/data/0000755000176200001440000000000013073161527012124 5ustar liggesusersmgcv/data/columb.polys.rda0000644000176200001440000002010613073161527015241 0ustar liggesusers\xUI$-3sM!PC.J {TPHQPiP)4{uR^龧v^LZmS]ax>/1?|9s~N* ߛs>?[@cF쫆N@ށ@x~EΒWawDnk(Or7d374~:ns娶_ ,*nL@?оko@AяkPIO>-ͧ2 un ;ƕ͠/ƞ(o%Q?+cFyg"~*Ս7|5X > ZJo{4~"UʏrJȯ{|V=]ЊW4 Z6Q9s%S>>9g5>Ftv^ s}J?sl" ? ǗVvu~CoGfg+ Cv_}@Km&7R #="րef zA'_b#NO)旲{ʋawuΔUDch1uǜ5&1. <PﴕqA}#?}O>"?oƸeg[s_TKm!0&TژC@hV?Km:,5^D{wىq)s3z tB1 y!k΀hgPƶq@3[*q _if,ԱSRRƜl9.) ]=!z~Zz/ 17xV _+:Ao-'>r.ߋ{7a"O.-z79Ñut͘ 1NguEwϊ?Eg>*:yqgϕ.rURhi7?x3۬>3b ('IF_ ?1SFf('AlkE{u牝fI+Q_S<-|KX~U1?O_o(G6eR^+)㽧_qSXϻ~ޝuu#J:?+IdLUks(:Zc/mp9Qg[ic!c#c冱ԯ@'wb\.Aׁ~1/XOcdD^ ɋgD9O{x?#}7~ B7rtc;?U@l܌x׻(迻?l\ 헁{,O$7>dZHt5h |Y;^Lg,|H۴p}Lꚅ~p/|:Rx9*-9l>ÉˉQ{{{Te;u^C{#4 FTOAHO˻^{: _~}1΁X⾵W|ވ}9 x>VjK<3{{Wem1~0Q8CQ>qgO?5cm-7J7=-~^?bU}0honę]aBo}ˏ+_/aM;׊ Gt3?+8ķFhݦ<sfxPNE,20#s0=LڝqBǥր^+gѦ_k˸gƵ{4r;@}ԏ4>/H9䆥BX3eo63o&.}hh*6ƚ 9S y=9s1ʩwo39Z\ʡq;ʋ'$f;ANV +}Q AOXmpSa5]3aNKٻn&kmЅww_(T>ޑoBbL m ꩽw¹57$|S}VRow4NN}kO {?!ʳ_[kˏ/-=7ǂ^d }Buyw1A+< V{31P_Főg/-+ ;ߌ>DΰuQ>mC;.Y6!1 bZ'9A-wwnTݕSu?A y׷>ٵ|X[Dƻ7H=J};IQΒw/<ywjSe!OPN/|w\N1J\[_HxWEh61_an5.5 6=~$[o-UxXKMܭq8b|04#3CScO_o+BFJNRVZ^bfjnrvz~b7~|û>/֭zxLȺw)7RH9XͿQ"]]uў0~zoppp/qo齦"rxJg"77 >T>|1hYkkkkkkkw=G闃ϟwdо3G>dfdde\eeܝPsy9q8J 㱊:^2~22ƽ5}s>¥*7չ]u.ܖ.s_ ̓` ׽(+K[0A+2wd.ܒ&sOMLD91:7`|K܅+ g2B۴]GO?W=.b]0\h/nB#קOv .r%{/U;p=yؓo)|3x5ǵb(-1^OJ K[w?I^s"ԯ@㜻AQuΪszs6FL(GgsER"[kPW%נּw콕Uyzެ|M6 }D}0=}J.b0x8x@x';< o+N;祽|"xse̥[3frq:W'9IlsR&\ѕ£><W 9YH |e#<ʸ_~Au5v?ʋ&}7gF=]3J:bsx<&i(b{nVŰd%N2WwbQ_as)93'7f#((rH,\=:Ss?Emy %A]]kqZ>{(({0f lo)=0aNeH]8yWy֋NCyUƻOmC_Qw/JM-u,eleUz8ϸp6y;pމQ1qI <:|#?)m| ~**=s2 FذEQ"#&g<ڂQOd` cJXA&CS_~ F\(w EŊ~!:>ss_NDy s>gxWXQ;Ka Duo}} -~y7[}[aGܱ;.]n ; s񾽥)׭^\\\jp}Y#7uUn\q?1&1GGOW_gow>Se ӱO+θ:亜j˅DoýF'8a ثcc#׉Z7\Ga(ߚ"x%B.)"XBc/❎ LF0)"\HFΟfJs f`'ck&6XV:NY?+2"l,a %mH8+Arxߔ6h0. :c]%el܂/!Am}yP?3n!-Cn_#/ x#vHCzж3CC|^(PбW!OcK/QYdWv>{Cpz=F:ZX5 X<BG{]|K`5%se|*俁jk6ʞ\`F} 5n$$$$$%.][t4 o7ne'EPXx-ڇc/]_?QH=qO9_=gsYo=3()O=*Eo%g?/(Iqi6Jq:OmEWAJVŢ$GXj<_A>=k+25Y1-kJo8}\d_=ş>!Sa͙kva.F:}t.$ZIȱj\Qw[5݋mP_߷7ߖv$b=o5J8LƙUIQYaiqy e^} 17bܩ"݇Яi΋ عqZR *<ߜZS5 [ν1mP?B9&皇9#q9= k5/Pg%?tt?zXڃa̟Y\"&*𝧫Kah'.S4!6QXz6tJ3kUp ubsE{z=n~q.o:,6*g1PN5,l_b5+ִ<7ed̾Ps6׸W <,A_ho\+(z^*ϊ.zPxܺD9qNsx9[?- gqݠB^4gO 8_~CuwPw[_HY @I/8K2?C\=9O[%Vx f=JxvT8rLeԏ zO]#:?a䰦܎k#u^Pu|?\KQUt wp7ׅ;Oc +0wPs k0`.܄Kc}_Z~&WXQ.Ή5R~ st7;\>ߓz^0'`9s 90'aœv0!A^"~~LѦ5[QqЎ mk|K)8 :{tϏjYj'3q_iŻf|m66*Ds468:<> 5N$n_&=;'j!g0(rg͟50߾1oG|竹,K*Ok{O0oTaNxxxxx~ŷV&`dq}9p8gCΩSlU591?߾Xg=sɹ\CE?̀nɯqe2O48JQ?GU#bUQѿb8+^Uֿ_ZFeh1ZFeh1ZFejZFejZFejZFeiqZFeiqZF\,?"KTmgcv/data/columb.rda0000644000176200001440000000551113073161527014077 0ustar liggesusers행?'d)DY#f 3ؗ&DnqCĸɾS$-lnd$kQ)H7nI3ys><9ys|3H$Ib&+K) gtHL䚨$&A}M'wSmŵ7Oɵy7QwRJ>fܧhH1SSQѷIwщŋ7F~\\0ѕ"srХ7 FoEos:~vCVOE<4d,]//{:u?֥A:ȬqE&,ݪЕu/>O>G-XyJ¡{c;$d7+nZU?_CU{ nEdmkԲ.vzjiPop?j|׺> XVDw VסY>6աwF3/:֨duzO&jxe 6*o89*{>pqN+\: {j0m .{G{[)=udx#a ۝I.|iHX_$jxmnaIaN}&#ⰗfwEf[%%:"?֢8DKh^M%s1,_{X=Y_)~d Hc%~{;:3z*P/'7-EZK 2:`xߔ  5`J?k`? t,|^c`P5t#Q:Q >y~ST@- |b<|`uaGJZ8@3~W G-w-4WoJ*,b{)*?5vL 0ﷹ퀍 E?&|؍R<D>X Kvkցyv-gpNaiLlkR/ݶ9z=I??<a`yټ5;#}ddLpu{k*#~x 1/;:k3V ] -> 8In}C[{H]Q xT/#\Pu$rʖ pi&xe< .L:T7p~x'ۢ3 ǚ'F B~ǃfq^miN<8[| )pOԍW4hm]sgs_;ylkU8gaC.(ʸ}QG`[*UKb6}E**WQ$! ;dVM$#ݵs_݄~|I]hA*$32*ϩarcoQQ}9Df~cy<ԲU4"K4pwX|KYڸkȲ<[Z'>S0qѹuW4[ٌMH "f]pk˫ѐۊ,D*[}w´R!╵ΚPrBZOTʂ9Wj#pfixv R鹟L0hb뜮j K-I  -ÿO.QtQ4X-Xpł'ba&ba!"!aC(P\BeJ(3BʂPFx`Fx`Fx`Fx`Fx`\ƒKxp .%<<ƒGx# ^v`ݏG. 5}h'yMK.RPAsߜ~N 3}w.O};a@w+tj%Zk{vS!/kR?*]@;l[ڃٯ/өX17^M2bde@WghZ ^Mh?~NQ|$ "=cULdmpc ۈ1>̈G$[dCCūzC$r1L;+7ҿ&aV}mgcv/man/0000755000176200001440000000000013555551146011773 5ustar liggesusersmgcv/man/pdTens.Rd0000755000176200001440000000625513073161527013525 0ustar liggesusers\name{pdTens} \alias{pdTens} \alias{pdConstruct.pdTens} \alias{pdFactor.pdTens} \alias{pdMatrix.pdTens} \alias{coef.pdTens} \alias{summary.pdTens} %- Also NEED an `\alias' for EACH other topic documented here. \title{Functions implementing a pdMat class for tensor product smooths} \description{This set of functions implements an \code{nlme} library \code{pdMat} class to allow tensor product smooths to be estimated by \code{lme} as called by \code{gamm}. Tensor product smooths have a penalty matrix made up of a weighted sum of penalty matrices, where the weights are the smoothing parameters. In the mixed model formulation the penalty matrix is the inverse of the covariance matrix for the random effects of a term, and the smoothing parameters (times a half) are variance parameters to be estimated. It's not possible to transform the problem to make the required random effects covariance matrix look like one of the standard \code{pdMat} classes: hence the need for the \code{pdTens} class. A \code{\link{notLog2}} parameterization ensures that the parameters are positive. These functions (\code{pdTens}, \code{pdConstruct.pdTens}, \code{pdFactor.pdTens}, \code{pdMatrix.pdTens}, \code{coef.pdTens} and \code{summary.pdTens}) would not normally be called directly. } \usage{ pdTens(value = numeric(0), form = NULL, nam = NULL, data = sys.frame(sys.parent())) } %- maybe also `usage' for other objects documented here. \arguments{ \item{value}{Initialization values for parameters. Not normally used.} \item{form}{A one sided formula specifying the random effects structure. The formula should have an attribute \code{S} which is a list of the penalty matrices the weighted sum of which gives the inverse of the covariance matrix for these random effects.} \item{nam}{a names argument, not normally used with this class.} \item{data}{data frame in which to evaluate formula.} } \details{ If using this class directly note that it is worthwhile scaling the \code{S} matrices to be of `moderate size', for example by dividing each matrix by its largest singular value: this avoids problems with \code{lme} defaults (\code{\link{smooth.construct.tensor.smooth.spec}} does this automatically). This appears to be the minimum set of functions required to implement a new \code{pdMat} class. Note that while the \code{pdFactor} and \code{pdMatrix} functions return the inverse of the scaled random effect covariance matrix or its factor, the \code{pdConstruct} function is sometimes initialised with estimates of the scaled covariance matrix, and sometimes intialized with its inverse. } \value{ A class \code{pdTens} object, or its coefficients or the matrix it represents or the factor of that matrix. \code{pdFactor} returns the factor as a vector (packed column-wise) (\code{pdMatrix} always returns a matrix). } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Pinheiro J.C. and Bates, D.M. (2000) Mixed effects Models in S and S-PLUS. Springer The \code{nlme} source code. \url{http://www.maths.bris.ac.uk/~sw15190/} } \seealso{ \code{\link{te}} \code{\link{gamm}}} \examples{ # see gamm } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/mono.con.Rd0000755000176200001440000000360213073161526014006 0ustar liggesusers\name{mono.con} \alias{mono.con} \title{Monotonicity constraints for a cubic regression spline} \description{ Finds linear constraints sufficient for monotonicity (and optionally upper and/or lower boundedness) of a cubic regression spline. The basis representation assumed is that given by the \code{gam}, \code{"cr"} basis: that is the spline has a set of knots, which have fixed x values, but the y values of which constitute the parameters of the spline. } \usage{ mono.con(x,up=TRUE,lower=NA,upper=NA) } \arguments{ \item{x}{The array of knot locations.} \item{up}{If \code{TRUE} then the constraints imply increase, if \code{FALSE} then decrease. } \item{lower}{This specifies the lower bound on the spline unless it is \code{NA} in which case no lower bound is imposed.} \item{upper}{This specifies the upper bound on the spline unless it is \code{NA} in which case no upper bound is imposed.} } \details{ Consider the natural cubic spline passing through the points \eqn{ \{x_i,p_i:i=1 \ldots n \} }{ (x_i,p_i), i=1..n}. Then it is possible to find a relatively small set of linear constraints on \eqn{\mathbf{p}}{p} sufficient to ensure monotonicity (and bounds if required): \eqn{\mathbf{Ap}\ge\mathbf{b}}{Ap >= b}. Details are given in Wood (1994). } \value{ a list containing constraint matrix \code{A} and constraint vector \code{b}. } \references{ Gill, P.E., Murray, W. and Wright, M.H. (1981) \emph{Practical Optimization}. Academic Press, London. Wood, S.N. (1994) Monotonic smoothing splines fitted by cross validation. \emph{SIAM Journal on Scientific Computing} \bold{15}(5), 1126--1133. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \seealso{ \code{\link{magic}}, \code{\link{pcls}} } \examples{ ## see ?pcls } \keyword{models} \keyword{smooth} \keyword{regression} %-- one or more .. mgcv/man/exclude.too.far.Rd0000755000176200001440000000426313073161526015264 0ustar liggesusers\name{exclude.too.far} \alias{exclude.too.far} %- Also NEED an `\alias' for EACH other topic documented here. \title{Exclude prediction grid points too far from data} \description{ Takes two arrays defining the nodes of a grid over a 2D covariate space and two arrays defining the location of data in that space, and returns a logical vector with elements \code{TRUE} if the corresponding node is too far from data and \code{FALSE} otherwise. Basically a service routine for \code{vis.gam} and \code{plot.gam}. } \usage{ exclude.too.far(g1,g2,d1,d2,dist) } %- maybe also `usage' for other objects documented here. \arguments{ \item{g1}{co-ordinates of grid relative to first axis.} \item{g2}{co-ordinates of grid relative to second axis.} \item{d1}{co-ordinates of data relative to first axis.} \item{d2}{co-ordinates of data relative to second axis.} \item{dist}{how far away counts as too far. Grid and data are first scaled so that the grid lies exactly in the unit square, and \code{dist} is a distance within this unit square.} } \details{ Linear scalings of the axes are first determined so that the grid defined by the nodes in \code{g1} and \code{g2} lies exactly in the unit square (i.e. on [0,1] by [0,1]). These scalings are applied to \code{g1}, \code{g2}, \code{d1} and \code{d2}. The minimum Euclidean distance from each node to a datum is then determined and if it is greater than \code{dist} the corresponding entry in the returned array is set to \code{TRUE} (otherwise to \code{FALSE}). The distance calculations are performed in compiled code for speed without storage overheads. } \value{A logical array with \code{TRUE} indicating a node in the grid defined by \code{g1}, \code{g2} that is `too far' from any datum. } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{vis.gam}} } \examples{ library(mgcv) x<-rnorm(100);y<-rnorm(100) # some "data" n<-40 # generate a grid.... mx<-seq(min(x),max(x),length=n) my<-seq(min(y),max(y),length=n) gx<-rep(mx,n);gy<-rep(my,rep(n,n)) tf<-exclude.too.far(gx,gy,x,y,0.1) plot(gx[!tf],gy[!tf],pch=".");points(x,y,col=2) } \keyword{hplot}%-- one or more ... mgcv/man/fixDependence.Rd0000755000176200001440000000402313303547337015023 0ustar liggesusers\name{fixDependence} \alias{fixDependence} %- Also NEED an `\alias' for EACH other topic documented here. \title{Detect linear dependencies of one matrix on another} \description{Identifies columns of a matrix \code{X2} which are linearly dependent on columns of a matrix \code{X1}. Primarily of use in setting up identifiability constraints for nested GAMs. } \usage{ fixDependence(X1,X2,tol=.Machine$double.eps^.5,rank.def=0,strict=FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{X1}{ A matrix.} \item{X2}{ A matrix, the columns of which may be partially linearly dependent on the columns of \code{X1}.} \item{tol}{The tolerance to use when assessing linear dependence.} \item{rank.def}{If the degree of rank deficiency in \code{X2}, given \code{X1}, is known, then it can be supplied here, and \code{tol} is then ignored. Unused unless positive and not greater than the number of columns in \code{X2}.} \item{strict}{if \code{TRUE} then only columns individually dependent on \code{X1} are detected, if \code{FALSE} then enough columns to make the reduced \code{X2} full rank and independent of \code{X1} are detected.} } \details{ The algorithm uses a simple approach based on QR decomposition: see Wood (2017, section 5.6.3) for details. } \value{ A vector of the columns of \code{X2} which are linearly dependent on columns of \code{X1} (or which need to be deleted to acheive independence and full rank if \code{strict==FALSE}). \code{NULL} if the two matrices are independent. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Wood S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC Press. } \examples{ library(mgcv) n<-20;c1<-4;c2<-7 X1<-matrix(runif(n*c1),n,c1) X2<-matrix(runif(n*c2),n,c2) X2[,3]<-X1[,2]+X2[,4]*.1 X2[,5]<-X1[,1]*.2+X1[,2]*.04 fixDependence(X1,X2) fixDependence(X1,X2,strict=TRUE) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.ad.smooth.spec.Rd0000755000176200001440000001260713304006776020447 0ustar liggesusers\name{smooth.construct.ad.smooth.spec} \alias{smooth.construct.ad.smooth.spec} \alias{adaptive.smooth} %- Also NEED an `\alias' for EACH other topic documented here. \title{Adaptive smooths in GAMs} \description{\code{\link{gam}} can use adaptive smooths of one or two variables, specified via terms like \code{s(...,bs="ad",...)}. (\code{\link{gamm}} can not use such terms --- check out package \code{AdaptFit} if this is a problem.) The basis for such a term is a (tensor product of) p-spline(s) or cubic regression spline(s). Discrete P-spline type penalties are applied directly to the coefficients of the basis, but the penalties themselves have a basis representation, allowing the strength of the penalty to vary with the covariates. The coefficients of the penalty basis are the smoothing parameters. When invoking an adaptive smoother the \code{k} argument specifies the dimension of the smoothing basis (default 40 in 1D, 15 in 2D), while the \code{m} argument specifies the dimension of the penalty basis (default 5 in 1D, 3 in 2D). For an adaptive smooth of two variables \code{k} is taken as the dimension of both marginal bases: different marginal basis dimensions can be specified by making \code{k} a two element vector. Similarly, in the two dimensional case \code{m} is the dimension of both marginal bases for the penalties, unless it is a two element vector, which specifies different basis dimensions for each marginal (If the penalty basis is based on a thin plate spline then \code{m} specifies its dimension directly). By default, P-splines are used for the smoothing and penalty bases, but this can be modified by supplying a list as argument \code{xt} with a character vector \code{xt$bs} specifying the smoothing basis type. Only \code{"ps"}, \code{"cp"}, \code{"cc"} and \code{"cr"} may be used for the smoothing basis. The penalty basis is always a B-spline, or a cyclic B-spline for cyclic bases. The total number of smoothing parameters to be estimated for the term will be the dimension of the penalty basis. Bear in mind that adaptive smoothing places quite severe demands on the data. For example, setting \code{m=10} for a univariate smooth of 200 data is rather like estimating 10 smoothing parameters, each from a data series of length 20. The problem is particularly serious for smooths of 2 variables, where the number of smoothing parameters required to get reasonable flexibility in the penalty can grow rather fast, but it often requires a very large smoothing basis dimension to make good use of this flexibility. In short, adaptive smooths should be used sparingly and with care. In practice it is often as effective to simply transform the smoothing covariate as it is to use an adaptive smooth. } \usage{ \method{smooth.construct}{ad.smooth.spec}(object, data, knots) } \arguments{ \item{object}{a smooth specification object, usually generated by a term \code{s(...,bs="ad",...)}} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}} } \value{ An object of class \code{"pspline.smooth"} in the 1D case or \code{"tensor.smooth"} in the 2D case. } \details{ The constructor is not normally called directly, but is rather used internally by \code{\link{gam}}. To use for basis setup it is recommended to use \code{\link{smooth.construct2}}. This class can not be used as a marginal basis in a tensor product smooth, nor by \code{gamm}. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ ## Comparison using an example taken from AdaptFit ## library(AdaptFit) require(mgcv) set.seed(0) x <- 1:1000/1000 mu <- exp(-400*(x-.6)^2)+5*exp(-500*(x-.75)^2)/3+2*exp(-500*(x-.9)^2) y <- mu+0.5*rnorm(1000) ##fit with default knots ## y.fit <- asp(y~f(x)) par(mfrow=c(2,2)) ## plot(y.fit,main=round(cor(fitted(y.fit),mu),digits=4)) ## lines(x,mu,col=2) b <- gam(y~s(x,bs="ad",k=40,m=5)) ## adaptive plot(b,shade=TRUE,main=round(cor(fitted(b),mu),digits=4)) lines(x,mu-mean(mu),col=2) b <- gam(y~s(x,k=40)) ## non-adaptive plot(b,shade=TRUE,main=round(cor(fitted(b),mu),digits=4)) lines(x,mu-mean(mu),col=2) b <- gam(y~s(x,bs="ad",k=40,m=5,xt=list(bs="cr"))) plot(b,shade=TRUE,main=round(cor(fitted(b),mu),digits=4)) lines(x,mu-mean(mu),col=2) ## A 2D example (marked, 'Not run' purely to reduce ## checking load on CRAN). \donttest{ par(mfrow=c(2,2),mar=c(1,1,1,1)) x <- seq(-.5, 1.5, length= 60) z <- x f3 <- function(x,z,k=15) { r<-sqrt(x^2+z^2);f<-exp(-r^2*k);f} f <- outer(x, z, f3) op <- par(bg = "white") ## Plot truth.... persp(x,z,f,theta=30,phi=30,col="lightblue",ticktype="detailed") n <- 2000 x <- runif(n)*2-.5 z <- runif(n)*2-.5 f <- f3(x,z) y <- f + rnorm(n)*.1 ## Try tprs for comparison... b0 <- gam(y~s(x,z,k=150)) vis.gam(b0,theta=30,phi=30,ticktype="detailed") ## Tensor product with non-adaptive version of adaptive penalty b1 <- gam(y~s(x,z,bs="ad",k=15,m=1),gamma=1.4) vis.gam(b1,theta=30,phi=30,ticktype="detailed") ## Now adaptive... b <- gam(y~s(x,z,bs="ad",k=15,m=3),gamma=1.4) vis.gam(b,theta=30,phi=30,ticktype="detailed") cor(fitted(b0),f);cor(fitted(b),f) } } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/Predict.matrix.soap.film.Rd0000755000176200001440000000716413073161526017053 0ustar liggesusers\name{Predict.matrix.soap.film} \alias{Predict.matrix.soap.film} \alias{Predict.matrix.sw} \alias{Predict.matrix.sf} %- Also NEED an `\alias' for EACH other topic documented here. \title{Prediction matrix for soap film smooth} \description{ Creates a prediction matrix for a soap film smooth object, mapping the coefficients of the smooth to the linear predictor component for the smooth. This is the \code{\link{Predict.matrix}} method function required by \code{\link{gam}}. } \usage{ \method{Predict.matrix}{soap.film}(object,data) \method{Predict.matrix}{sw}(object,data) \method{Predict.matrix}{sf}(object,data) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{A class \code{"soap.film"}, \code{"sf"} or \code{"sw"} object.} \item{data}{A list list or data frame containing the arguments of the smooth at which predictions are required.} } \details{ The smooth object will be largely what is returned from \code{\link{smooth.construct.so.smooth.spec}}, although elements \code{X} and \code{S} are not needed, and need not be present, of course. } \value{ A matrix. This may have an \code{"offset"} attribute corresponding to the contribution from any known boundary conditions on the smooth. } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{s.wood@bath.ac.uk}} \seealso{\code{\link{smooth.construct.so.smooth.spec}}} \examples{ ## This is a lower level example. The basis and ## penalties are obtained explicitly ## and `magic' is used as the fitting routine... require(mgcv) set.seed(66) ## create a boundary... fsb <- list(fs.boundary()) ## create some internal knots... knots <- data.frame(x=rep(seq(-.5,3,by=.5),4), y=rep(c(-.6,-.3,.3,.6),rep(8,4))) ## Simulate some fitting data, inside boundary... n<-1000 x <- runif(n)*5-1;y<-runif(n)*2-1 z <- fs.test(x,y,b=1) ind <- inSide(fsb,x,y) ## remove outsiders z <- z[ind];x <- x[ind]; y <- y[ind] n <- length(z) z <- z + rnorm(n)*.3 ## add noise ## plot boundary with knot and data locations plot(fsb[[1]]$x,fsb[[1]]$y,type="l");points(knots$x,knots$y,pch=20,col=2) points(x,y,pch=".",col=3); ## set up the basis and penalties... sob <- smooth.construct2(s(x,y,bs="so",k=40,xt=list(bnd=fsb,nmax=100)), data=data.frame(x=x,y=y),knots=knots) ## ... model matrix is element `X' of sob, penalties matrices ## are in list element `S'. ## fit using `magic' um <- magic(z,sob$X,sp=c(-1,-1),sob$S,off=c(1,1)) beta <- um$b ## produce plots... par(mfrow=c(2,2),mar=c(4,4,1,1)) m<-100;n<-50 xm <- seq(-1,3.5,length=m);yn<-seq(-1,1,length=n) xx <- rep(xm,n);yy<-rep(yn,rep(m,n)) ## plot truth... tru <- matrix(fs.test(xx,yy),m,n) ## truth image(xm,yn,tru,col=heat.colors(100),xlab="x",ylab="y") lines(fsb[[1]]$x,fsb[[1]]$y,lwd=3) contour(xm,yn,tru,levels=seq(-5,5,by=.25),add=TRUE) ## Plot soap, by first predicting on a fine grid... ## First get prediction matrix... X <- Predict.matrix2(sob,data=list(x=xx,y=yy)) ## Now the predictions... fv <- X\%*\%beta ## Plot the estimated function... image(xm,yn,matrix(fv,m,n),col=heat.colors(100),xlab="x",ylab="y") lines(fsb[[1]]$x,fsb[[1]]$y,lwd=3) points(x,y,pch=".") contour(xm,yn,matrix(fv,m,n),levels=seq(-5,5,by=.25),add=TRUE) ## Plot TPRS... b <- gam(z~s(x,y,k=100)) fv.gam <- predict(b,newdata=data.frame(x=xx,y=yy)) names(sob$sd$bnd[[1]]) <- c("xx","yy","d") ind <- inSide(sob$sd$bnd,xx,yy) fv.gam[!ind]<-NA image(xm,yn,matrix(fv.gam,m,n),col=heat.colors(100),xlab="x",ylab="y") lines(fsb[[1]]$x,fsb[[1]]$y,lwd=3) points(x,y,pch=".") contour(xm,yn,matrix(fv.gam,m,n),levels=seq(-5,5,by=.25),add=TRUE) } \keyword{models} \keyword{smooth} \keyword{regression}mgcv/man/mini.roots.Rd0000644000176200001440000000164013137076645014366 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mgcvExports.R \name{mini.roots} \alias{mini.roots} \title{Obtain square roots of penalty matrices} \usage{ mini.roots(S, off, np, rank = NULL) } \arguments{ \item{S}{a list of penalty matrices, in packed form.} \item{off}{a vector where the i-th element is the offset for the i-th matrix. The elements in columns \code{1:off[i]} of \code{B[[i]]} will be equal to zero.} \item{np}{total number of parameters.} \item{rank}{here \code{rank[i]} is optional supplied rank of \code{S[[i]]}. Set \code{rank[i] < 1}, or \code{rank=NULL} to estimate.} } \value{ A list of matrix square roots such that \code{S[[i]]=B[[i]]\%*\%t(B[[i]])}. } \description{ INTERNAL function to obtain square roots, \code{B[[i]]}, of the penalty matrices \code{S[[i]]}'s having as few columns as possible. } \author{ Simon N. Wood . } mgcv/man/pcls.Rd0000755000176200001440000001734013073161526013225 0ustar liggesusers\name{pcls} \alias{pcls} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Penalized Constrained Least Squares Fitting} \description{ Solves least squares problems with quadratic penalties subject to linear equality and inequality constraints using quadratic programming. } \usage{ pcls(M) } %- maybe also `usage' for other objects documented here. \arguments{ \item{M}{is the single list argument to \code{pcls}. It should have the following elements: \describe{ \item{y}{The response data vector.} \item{w}{A vector of weights for the data (often proportional to the reciprocal of the variance). } \item{X}{The design matrix for the problem, note that \code{ncol(M$X)} must give the number of model parameters, while \code{nrow(M$X)} should give the number of data.} \item{C}{Matrix containing any linear equality constraints on the problem (e.g. \eqn{ \bf C}{C} in \eqn{ {\bf Cp}={\bf c} }{Cp=c}). If you have no equality constraints initialize this to a zero by zero matrix. Note that there is no need to supply the vector \eqn{ \bf c}{c}, it is defined implicitly by the initial parameter estimates \eqn{ \bf p}{p}.} \item{S}{ A list of penalty matrices. \code{S[[i]]} is the smallest contiguous matrix including all the non-zero elements of the ith penalty matrix. The first parameter it penalizes is given by \code{off[i]+1} (starting counting at 1). } \item{off}{ Offset values locating the elements of \code{M$S} in the correct location within each penalty coefficient matrix. (Zero offset implies starting in first location)} \item{sp}{ An array of smoothing parameter estimates.} \item{p}{An array of feasible initial parameter estimates - these must satisfy the constraints, but should avoid satisfying the inequality constraints as equality constraints.} \item{Ain}{Matrix for the inequality constraints \eqn{ {\bf A}_{in} {\bf p} > {\bf b}_{in}}{A_in p > b}. } \item{bin}{vector in the inequality constraints. } } % end describe } % end M } \details{ This solves the problem: \deqn{ minimise~ \| { \bf W}^{1/2} ({ \bf Xp - y} ) \|^2 + \sum_{i=1}^m \lambda_i {\bf p^\prime S}_i{\bf p} }{ min || W^0.5 (Xp-y) ||^2 + lambda_1 p'S_1 p + lambda_1 p'S_2 p + . . .} subject to constraints \eqn{ {\bf Cp}={\bf c}}{Cp=c} and \eqn{ {\bf A}_{in}{\bf p}>{\bf b}_{in}}{A_in p > b_in}, w.r.t. \eqn{\bf p}{p} given the smoothing parameters \eqn{\lambda_i}{lambda_i}. \eqn{ {\bf X}}{X} is a design matrix, \eqn{\bf p}{p} a parameter vector, \eqn{\bf y}{y} a data vector, \eqn{\bf W}{W} a diagonal weight matrix, \eqn{ {\bf S}_i}{S_i} a positive semi-definite matrix of coefficients defining the ith penalty and \eqn{\bf C}{C} a matrix of coefficients defining the linear equality constraints on the problem. The smoothing parameters are the \eqn{\lambda_i}{lambda_i}. Note that \eqn{ {\bf X}}{X} must be of full column rank, at least when projected into the null space of any equality constraints. \eqn{ {\bf A}_{in}}{A_in} is a matrix of coefficients defining the inequality constraints, while \eqn{ {\bf b}_{in}}{b_in} is a vector involved in defining the inequality constraints. Quadratic programming is used to perform the solution. The method used is designed for maximum stability with least squares problems: i.e. \eqn{ {\bf X}^\prime {\bf X}}{X'X} is not formed explicitly. See Gill et al. 1981. } \value{ The function returns an array containing the estimated parameter vector. } \references{ Gill, P.E., Murray, W. and Wright, M.H. (1981) Practical Optimization. Academic Press, London. Wood, S.N. (1994) Monotonic smoothing splines fitted by cross validation SIAM Journal on Scientific Computing 15(5):1126-1133 \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{magic}}, \code{\link{mono.con}} } \examples{ require(mgcv) # first an un-penalized example - fit E(y)=a+bx subject to a>0 set.seed(0) n <- 100 x <- runif(n); y <- x - 0.2 + rnorm(n)*0.1 M <- list(X=matrix(0,n,2),p=c(0.1,0.5),off=array(0,0),S=list(), Ain=matrix(0,1,2),bin=0,C=matrix(0,0,0),sp=array(0,0),y=y,w=y*0+1) M$X[,1] <- 1; M$X[,2] <- x; M$Ain[1,] <- c(1,0) pcls(M) -> M$p plot(x,y); abline(M$p,col=2); abline(coef(lm(y~x)),col=3) # Penalized example: monotonic penalized regression spline ..... # Generate data from a monotonic truth. x <- runif(100)*4-1;x <- sort(x); f <- exp(4*x)/(1+exp(4*x)); y <- f+rnorm(100)*0.1; plot(x,y) dat <- data.frame(x=x,y=y) # Show regular spline fit (and save fitted object) f.ug <- gam(y~s(x,k=10,bs="cr")); lines(x,fitted(f.ug)) # Create Design matrix, constraints etc. for monotonic spline.... sm <- smoothCon(s(x,k=10,bs="cr"),dat,knots=NULL)[[1]] F <- mono.con(sm$xp); # get constraints G <- list(X=sm$X,C=matrix(0,0,0),sp=f.ug$sp,p=sm$xp,y=y,w=y*0+1) G$Ain <- F$A;G$bin <- F$b;G$S <- sm$S;G$off <- 0 p <- pcls(G); # fit spline (using s.p. from unconstrained fit) fv<-Predict.matrix(sm,data.frame(x=x))\%*\%p lines(x,fv,col=2) # now a tprs example of the same thing.... f.ug <- gam(y~s(x,k=10)); lines(x,fitted(f.ug)) # Create Design matrix, constriants etc. for monotonic spline.... sm <- smoothCon(s(x,k=10,bs="tp"),dat,knots=NULL)[[1]] xc <- 0:39/39 # points on [0,1] nc <- length(xc) # number of constraints xc <- xc*4-1 # points at which to impose constraints A0 <- Predict.matrix(sm,data.frame(x=xc)) # ... A0%*%p evaluates spline at xc points A1 <- Predict.matrix(sm,data.frame(x=xc+1e-6)) A <- (A1-A0)/1e-6 ## ... approx. constraint matrix (A\%*\%p is -ve ## spline gradient at points xc) G <- list(X=sm$X,C=matrix(0,0,0),sp=f.ug$sp,y=y,w=y*0+1,S=sm$S,off=0) G$Ain <- A; # constraint matrix G$bin <- rep(0,nc); # constraint vector G$p <- rep(0,10); G$p[10] <- 0.1 # ... monotonic start params, got by setting coefs of polynomial part p <- pcls(G); # fit spline (using s.p. from unconstrained fit) fv2 <- Predict.matrix(sm,data.frame(x=x))\%*\%p lines(x,fv2,col=3) ###################################### ## monotonic additive model example... ###################################### ## First simulate data... set.seed(10) f1 <- function(x) 5*exp(4*x)/(1+exp(4*x)); f2 <- function(x) { ind <- x > .5 f <- x*0 f[ind] <- (x[ind] - .5)^2*10 f } f3 <- function(x) 0.2 * x^11 * (10 * (1 - x))^6 + 10 * (10 * x)^3 * (1 - x)^10 n <- 200 x <- runif(n); z <- runif(n); v <- runif(n) mu <- f1(x) + f2(z) + f3(v) y <- mu + rnorm(n) ## Preliminary unconstrained gam fit... G <- gam(y~s(x)+s(z)+s(v,k=20),fit=FALSE) b <- gam(G=G) ## generate constraints, by finite differencing ## using predict.gam .... eps <- 1e-7 pd0 <- data.frame(x=seq(0,1,length=100),z=rep(.5,100), v=rep(.5,100)) pd1 <- data.frame(x=seq(0,1,length=100)+eps,z=rep(.5,100), v=rep(.5,100)) X0 <- predict(b,newdata=pd0,type="lpmatrix") X1 <- predict(b,newdata=pd1,type="lpmatrix") Xx <- (X1 - X0)/eps ## Xx \%*\% coef(b) must be positive pd0 <- data.frame(z=seq(0,1,length=100),x=rep(.5,100), v=rep(.5,100)) pd1 <- data.frame(z=seq(0,1,length=100)+eps,x=rep(.5,100), v=rep(.5,100)) X0 <- predict(b,newdata=pd0,type="lpmatrix") X1 <- predict(b,newdata=pd1,type="lpmatrix") Xz <- (X1-X0)/eps G$Ain <- rbind(Xx,Xz) ## inequality constraint matrix G$bin <- rep(0,nrow(G$Ain)) G$C = matrix(0,0,ncol(G$X)) G$sp <- b$sp G$p <- coef(b) G$off <- G$off-1 ## to match what pcls is expecting ## force inital parameters to meet constraint G$p[11:18] <- G$p[2:9]<- 0 p <- pcls(G) ## constrained fit par(mfrow=c(2,3)) plot(b) ## original fit b$coefficients <- p plot(b) ## constrained fit ## note that standard errors in preceding plot are obtained from ## unconstrained fit } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/magic.post.proc.Rd0000755000176200001440000000462013073161526015267 0ustar liggesusers\name{magic.post.proc} \alias{magic.post.proc} %- Also NEED an `\alias' for EACH other topic documented here. \title{Auxilliary information from magic fit} \description{Obtains Bayesian parameter covariance matrix, frequentist parameter estimator covariance matrix, estimated degrees of freedom for each parameter and leading diagonal of influence/hat matrix, for a penalized regression estimated by \code{magic}. } \usage{ magic.post.proc(X,object,w=NULL) } %- maybe also `usage' for other objects documented here. \arguments{ \item{X}{ is the model matrix.} \item{object}{is the list returned by \code{magic} after fitting the model with model matrix \code{X}.} \item{w}{is the weight vector used in fitting, or the weight matrix used in fitting (i.e. supplied to \code{magic}, if one was.). If \code{w} is a vector then its elements are typically proportional to reciprocal variances (but could even be negative). If \code{w} is a matrix then \code{t(w)\%*\%w} should typically give the inverse of the covariance matrix of the response data supplied to \code{magic}.} } \details{ \code{object} contains \code{rV} (\eqn{ {\bf V}}{V}, say), and \code{scale} (\eqn{ \phi}{s}, say) which can be used to obtain the require quantities as follows. The Bayesian covariance matrix of the parameters is \eqn{ {\bf VV}^\prime \phi}{VV's}. The vector of estimated degrees of freedom for each parameter is the leading diagonal of \eqn{ {\bf VV}^\prime {\bf X}^\prime {\bf W}^\prime {\bf W}{\bf X}}{ VV'X'W'WX} where \eqn{\bf{W}}{W} is either the weight matrix \code{w} or the matrix \code{diag(w)}. The hat/influence matrix is given by \eqn{ {\bf WX}{\bf VV}^\prime {\bf X}^\prime {\bf W}^\prime }{ WXVV'X'W'} . The frequentist parameter estimator covariance matrix is \eqn{ {\bf VV}^\prime {\bf X}^\prime {\bf W}^\prime {\bf WXVV}^\prime \phi}{ VV'X'W'WXVV's}: it is sometimes useful for testing terms for equality to zero. } \value{ A list with three items: \item{Vb}{the Bayesian covariance matrix of the model parameters.} \item{Ve}{the frequentist covariance matrix for the parameter estimators.} \item{hat}{the leading diagonal of the hat (influence) matrix.} \item{edf}{the array giving the estimated degrees of freedom associated with each parameter.} } \seealso{\code{\link{magic}}} \author{ Simon N. Wood \email{simon.wood@r-project.org}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/gam.fit3.Rd0000755000176200001440000001321013073161526013664 0ustar liggesusers\name{gam.fit3} \alias{gam.fit3} %- Also NEED an `\alias' for EACH other topic documented here. \title{P-IRLS GAM estimation with GCV \& UBRE/AIC or RE/ML derivative calculation} \description{Estimation of GAM smoothing parameters is most stable if optimization of the UBRE/AIC, GCV, GACV, REML or ML score is outer to the penalized iteratively re-weighted least squares scheme used to estimate the model given smoothing parameters. This routine estimates a GAM (any quadratically penalized GLM) given log smoothing paramaters, and evaluates derivatives of the smoothness selection scores of the model with respect to the log smoothing parameters. Calculation of exact derivatives is generally faster than approximating them by finite differencing, as well as generally improving the reliability of GCV/UBRE/AIC/REML score minimization. The approach is to run the P-IRLS to convergence, and only then to iterate for first and second derivatives. Not normally called directly, but rather service routines for \code{\link{gam}}. } \usage{ gam.fit3(x, y, sp, Eb ,UrS=list(), weights = rep(1, nobs), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, nobs), U1 = diag(ncol(x)), Mp = -1, family = gaussian(), control = gam.control(), intercept = TRUE,deriv=2,gamma=1,scale=1, printWarn=TRUE,scoreType="REML",null.coef=rep(0,ncol(x)), pearson.extra=0,dev.extra=0,n.true=-1,Sl=NULL,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{The model matrix for the GAM (or any penalized GLM).} \item{y}{The response variable.} \item{sp}{The log smoothing parameters.} \item{Eb}{A balanced version of the total penalty matrix: usd for numerical rank determination.} \item{UrS}{List of square root penalties premultiplied by transpose of orthogonal basis for the total penalty.} \item{weights}{prior weights for fitting.} \item{start}{optional starting parameter guesses.} \item{etastart}{optional starting values for the linear predictor.} \item{mustart}{optional starting values for the mean.} \item{offset}{the model offset} \item{U1}{An orthogonal basis for the range space of the penalty --- required for ML smoothness estimation only.} \item{Mp}{The dimension of the total penalty null space --- required for ML smoothness estimation only.} \item{family}{the family - actually this routine would never be called with \code{gaussian()}} \item{control}{control list as returned from \code{\link{glm.control}}} \item{intercept}{does the model have and intercept, \code{TRUE} or \code{FALSE}} \item{deriv}{ Should derivatives of the GCV and UBRE/AIC scores be calculated? 0, 1 or 2, indicating the maximum order of differentiation to apply.} \item{gamma}{The weight given to each degree of freedom in the GCV and UBRE scores can be varied (usually increased) using this parameter.} \item{scale}{The scale parameter - needed for the UBRE/AIC score.} \item{printWarn}{Set to \code{FALSE} to suppress some warnings. Useful in order to ensure that some warnings are only printed if they apply to the final fitted model, rather than an intermediate used in optimization.} \item{scoreType}{specifies smoothing parameter selection criterion to use.} \item{null.coef}{coefficients for a model which gives some sort of upper bound on deviance. This allows immediate divergence problems to be controlled.} \item{pearson.extra}{Extra component to add to numerator of pearson statistic in P-REML/P-ML smoothness selection criteria.} \item{dev.extra}{Extra component to add to deviance for REML/ML type smoothness selection criteria.} \item{n.true}{Number of data to assume in smoothness selection criteria. <=0 indicates that it should be the number of rows of \code{X}.} \item{Sl}{A smooth list suitable for passing to gam.fit5. } \item{...}{Other arguments: ignored.} } \details{ This routine is basically \code{\link{glm.fit}} with some modifications to allow (i) for quadratic penalties on the log likelihood; (ii) derivatives of the model coefficients with respect to log smoothing parameters to be obtained by use of the implicit function theorem and (iii) derivatives of the GAM GCV, UBRE/AIC, REML or ML scores to be evaluated at convergence. In addition the routines apply step halving to any step that increases the penalized deviance substantially. The most costly parts of the calculations are performed by calls to compiled C code (which in turn calls LAPACK routines) in place of the compiled code that would usually perform least squares estimation on the working model in the IRLS iteration. Estimation of smoothing parameters by optimizing GCV scores obtained at convergence of the P-IRLS iteration was proposed by O'Sullivan et al. (1986), and is here termed `outer' iteration. Note that use of non-standard families with this routine requires modification of the families as described in \code{\link{fix.family.link}}. } \references{ Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 O 'Sullivan, Yandall & Raynor (1986) Automatic smoothing of regression functions in generalized linear models. J. Amer. Statist. Assoc. 81:96-103. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} The routine has been modified from \code{glm.fit} in R 2.0.1, written by the R core (see \code{\link{glm.fit}} for further credits). } \seealso{\code{\link{gam.fit}}, \code{\link{gam}}, \code{\link{magic}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/smooth.construct.re.smooth.spec.Rd0000755000176200001440000001314213502400044020446 0ustar liggesusers\name{smooth.construct.re.smooth.spec} \alias{smooth.construct.re.smooth.spec} \alias{Predict.matrix.random.effect} %- Also NEED an `\alias' for EACH other topic documented here. \title{Simple random effects in GAMs} \description{\code{\link{gam}} can deal with simple independent random effects, by exploiting the link between smooths and random effects to treat random effects as smooths. \code{s(x,bs="re")} implements this. Such terms can can have any number of predictors, which can be any mixture of numeric or factor variables. The terms produce a parametric interaction of the predictors, and penalize the corresponding coefficients with a multiple of the identity matrix, corresponding to an assumption of i.i.d. normality. See details. } \usage{ \method{smooth.construct}{re.smooth.spec}(object, data, knots) \method{Predict.matrix}{random.effect}(object, data) } \arguments{ \item{object}{For the \code{smooth.construct} method a smooth specification object, usually generated by a term \code{s(x,...,bs="re",)}. For the \code{predict.Matrix} method an object of class \code{"random.effect"} produced by the \code{smooth.construct} method.} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{generically a list containing any knots supplied for basis setup --- unused at present.} } \value{ An object of class \code{"random.effect"} or a matrix mapping the coefficients of the random effect to the random effects themselves. } \details{Exactly how the random effects are implemented is best seen by example. Consider the model term \code{s(x,z,bs="re")}. This will result in the model matrix component corresponding to \code{~x:z-1} being added to the model matrix for the whole model. The coefficients associated with the model matrix component are assumed i.i.d. normal, with unknown variance (to be estimated). This assumption is equivalent to an identity penalty matrix (i.e. a ridge penalty) on the coefficients. Because such a penalty is full rank, random effects terms do not require centering constraints. If the nature of the random effect specification is not clear, consider a couple more examples: \code{s(x,bs="re")} results in \code{model.matrix(~x-1)} being appended to the overall model matrix, while \code{s(x,v,w,bs="re")} would result in \code{model.matrix(~x:v:w-1)} being appended to the model matrix. In both cases the corresponding model coefficients are assumed i.i.d. normal, and are hence subject to ridge penalties. If the random effect precision matrix is of the form \eqn{\sum_j \lambda_j S_j}{sum_j p_j S_j} for known matrices \eqn{S_j}{S_j} and unknown parameters \eqn{\lambda_j}{p_j}, then a list containing the \eqn{S_j}{S_j} can be supplied in the \code{xt} argument of \code{\link{s}}. In this case an array \code{rank} should also be supplied in \code{xt} giving the ranks of the \eqn{S_j}{S_j} matrices. See simple example below. Note that smooth \code{id}s are not supported for random effect terms. Unlike most smooth terms, side conditions are never applied to random effect terms in the event of nesting (since they are identifiable without side conditions). Random effects implemented in this way do not exploit the sparse structure of many random effects, and may therefore be relatively inefficient for models with large numbers of random effects, when \code{gamm4} or \code{\link{gamm}} may be better alternatives. Note also that \code{\link{gam}} will not support models with more coefficients than data. The situation in which factor variable random effects intentionally have unobserved levels requires special handling. You should set \code{drop.unused.levels=FALSE} in the model fitting function, \code{\link{gam}}, \code{\link{bam}} or \code{\link{gamm}}, having first ensured that any fixed effect factors do not contain unobserved levels. The implementation is designed so that supplying random effect factor levels to \code{\link{predict.gam}} that were not levels of the factor when fitting, will result in the corresponding random effect (or interactions involving it) being set to zero (with zero standard error) for prediction. See \code{\link{random.effects}} for an example. This is achieved by the \code{Predict.matrix} method zeroing any rows of the prediction matrix involving factors that are \code{NA}. \code{\link{predict.gam}} will set any factor observation to \code{NA} if it is a level not present in the fit data. } \references{ Wood, S.N. (2008) Fast stable direct fitting and smoothness selection for generalized additive models. Journal of the Royal Statistical Society (B) 70(3):495-518 } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{gam.vcomp}}, \code{\link{gamm}}} \examples{ ## see ?gam.vcomp require(mgcv) ## simulate simple random effect example set.seed(4) nb <- 50; n <- 400 b <- rnorm(nb)*2 ## random effect r <- sample(1:nb,n,replace=TRUE) ## r.e. levels y <- 2 + b[r] + rnorm(n) r <- factor(r) ## fit model.... b <- gam(y ~ s(r,bs="re"),method="REML") gam.vcomp(b) ## example with supplied precision matrices... b <- c(rnorm(nb/2)*2,rnorm(nb/2)*.5) ## random effect now with 2 variances r <- sample(1:nb,n,replace=TRUE) ## r.e. levels y <- 2 + b[r] + rnorm(n) r <- factor(r) ## known precision matrix components... S <- list(diag(rep(c(1,0),each=nb/2)),diag(rep(c(0,1),each=nb/2))) b <- gam(y ~ s(r,bs="re",xt=list(S=S,rank=c(nb/2,nb/2))),method="REML") gam.vcomp(b) summary(b) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/place.knots.Rd0000755000176200001440000000252513073161526014504 0ustar liggesusers\name{place.knots} \alias{place.knots} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Automatically place a set of knots evenly through covariate values} \description{ Given a univariate array of covariate values, places a set of knots for a regression spline evenly through the covariate values. } \usage{ place.knots(x,nk) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{array of covariate values (need not be sorted).} \item{nk}{integer indicating the required number of knots.} } \details{ Places knots evenly throughout a set of covariates. For example, if you had 11 covariate values and wanted 6 knots then a knot would be placed at the first (sorted) covariate value and every second (sorted) value thereafter. With less convenient numbers of data and knots the knots are placed within intervals between data in order to achieve even coverage, where even means having approximately the same number of data between each pair of knots.} \value{ An array of knot locations. } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{smooth.construct.cc.smooth.spec}} } \examples{ require(mgcv) x<-runif(30) place.knots(x,7) rm(x) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/choose.k.Rd0000755000176200001440000001533213303547337014000 0ustar liggesusers\name{choose.k} \alias{choose.k} %- Also NEED an `\alias' for EACH other topic documented here. \title{Basis dimension choice for smooths} \description{Choosing the basis dimension, and checking the choice, when using penalized regression smoothers. Penalized regression smoothers gain computational efficiency by virtue of being defined using a basis of relatively modest size, \code{k}. When setting up models in the \code{mgcv} package, using \code{\link{s}} or \code{\link{te}} terms in a model formula, \code{k} must be chosen: the defaults are essentially arbitrary. In practice \code{k-1} (or \code{k}) sets the upper limit on the degrees of freedom associated with an \code{\link{s}} smooth (1 degree of freedom is usually lost to the identifiability constraint on the smooth). For \code{\link{te}} smooths the upper limit of the degrees of freedom is given by the product of the \code{k} values provided for each marginal smooth less one, for the constraint. However the actual effective degrees of freedom are controlled by the degree of penalization selected during fitting, by GCV, AIC, REML or whatever is specified. The exception to this is if a smooth is specified using the \code{fx=TRUE} option, in which case it is unpenalized. So, exact choice of \code{k} is not generally critical: it should be chosen to be large enough that you are reasonably sure of having enough degrees of freedom to represent the underlying `truth' reasonably well, but small enough to maintain reasonable computational efficiency. Clearly `large' and `small' are dependent on the particular problem being addressed. As with all model assumptions, it is useful to be able to check the choice of \code{k} informally. If the effective degrees of freedom for a model term are estimated to be much less than \code{k-1} then this is unlikely to be very worthwhile, but as the EDF approach \code{k-1}, checking can be important. A useful general purpose approach goes as follows: (i) fit your model and extract the deviance residuals; (ii) for each smooth term in your model, fit an equivalent, single, smooth to the residuals, using a substantially increased \code{k} to see if there is pattern in the residuals that could potentially be explained by increasing \code{k}. Examples are provided below. The obvious, but more costly, alternative is simply to increase the suspect \code{k} and refit the original model. If there are no statistically important changes as a result of doing this, then \code{k} was large enough. (Change in the smoothness selection criterion, and/or the effective degrees of freedom, when \code{k} is increased, provide the obvious numerical measures for whether the fit has changed substantially.) \code{\link{gam.check}} runs a simple simulation based check on the basis dimensions, which can help to flag up terms for which \code{k} is too low. Grossly too small \code{k} will also be visible from partial residuals available with \code{\link{plot.gam}}. One scenario that can cause confusion is this: a model is fitted with \code{k=10} for a smooth term, and the EDF for the term is estimated as 7.6, some way below the maximum of 9. The model is then refitted with \code{k=20} and the EDF increases to 8.7 - what is happening - how come the EDF was not 8.7 the first time around? The explanation is that the function space with \code{k=20} contains a larger subspace of functions with EDF 8.7 than did the function space with \code{k=10}: one of the functions in this larger subspace fits the data a little better than did any function in the smaller subspace. These subtleties seldom have much impact on the statistical conclusions to be drawn from a model fit, however. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Wood, S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). CRC/Taylor & Francis. \url{http://www.maths.bris.ac.uk/~sw15190/} } \examples{ ## Simulate some data .... library(mgcv) set.seed(1) dat <- gamSim(1,n=400,scale=2) ## fit a GAM with quite low `k' b<-gam(y~s(x0,k=6)+s(x1,k=6)+s(x2,k=6)+s(x3,k=6),data=dat) plot(b,pages=1,residuals=TRUE) ## hint of a problem in s(x2) ## the following suggests a problem with s(x2) gam.check(b) ## Another approach (see below for more obvious method).... ## check for residual pattern, removeable by increasing `k' ## typically `k', below, chould be substantially larger than ## the original, `k' but certainly less than n/2. ## Note use of cheap "cs" shrinkage smoothers, and gamma=1.4 ## to reduce chance of overfitting... rsd <- residuals(b) gam(rsd~s(x0,k=40,bs="cs"),gamma=1.4,data=dat) ## fine gam(rsd~s(x1,k=40,bs="cs"),gamma=1.4,data=dat) ## fine gam(rsd~s(x2,k=40,bs="cs"),gamma=1.4,data=dat) ## `k' too low gam(rsd~s(x3,k=40,bs="cs"),gamma=1.4,data=dat) ## fine ## refit... b <- gam(y~s(x0,k=6)+s(x1,k=6)+s(x2,k=20)+s(x3,k=6),data=dat) gam.check(b) ## better ## similar example with multi-dimensional smooth b1 <- gam(y~s(x0)+s(x1,x2,k=15)+s(x3),data=dat) rsd <- residuals(b1) gam(rsd~s(x0,k=40,bs="cs"),gamma=1.4,data=dat) ## fine gam(rsd~s(x1,x2,k=100,bs="ts"),gamma=1.4,data=dat) ## `k' too low gam(rsd~s(x3,k=40,bs="cs"),gamma=1.4,data=dat) ## fine gam.check(b1) ## shows same problem ## and a `te' example b2 <- gam(y~s(x0)+te(x1,x2,k=4)+s(x3),data=dat) rsd <- residuals(b2) gam(rsd~s(x0,k=40,bs="cs"),gamma=1.4,data=dat) ## fine gam(rsd~te(x1,x2,k=10,bs="cs"),gamma=1.4,data=dat) ## `k' too low gam(rsd~s(x3,k=40,bs="cs"),gamma=1.4,data=dat) ## fine gam.check(b2) ## shows same problem ## same approach works with other families in the original model dat <- gamSim(1,n=400,scale=.25,dist="poisson") bp<-gam(y~s(x0,k=5)+s(x1,k=5)+s(x2,k=5)+s(x3,k=5), family=poisson,data=dat,method="ML") gam.check(bp) rsd <- residuals(bp) gam(rsd~s(x0,k=40,bs="cs"),gamma=1.4,data=dat) ## fine gam(rsd~s(x1,k=40,bs="cs"),gamma=1.4,data=dat) ## fine gam(rsd~s(x2,k=40,bs="cs"),gamma=1.4,data=dat) ## `k' too low gam(rsd~s(x3,k=40,bs="cs"),gamma=1.4,data=dat) ## fine rm(dat) ## More obvious, but more expensive tactic... Just increase ## suspicious k until fit is stable. set.seed(0) dat <- gamSim(1,n=400,scale=2) ## fit a GAM with quite low `k' b <- gam(y~s(x0,k=6)+s(x1,k=6)+s(x2,k=6)+s(x3,k=6), data=dat,method="REML") b ## edf for 3rd smooth is highest as proportion of k -- increase k b <- gam(y~s(x0,k=6)+s(x1,k=6)+s(x2,k=12)+s(x3,k=6), data=dat,method="REML") b ## edf substantially up, -ve REML substantially down b <- gam(y~s(x0,k=6)+s(x1,k=6)+s(x2,k=24)+s(x3,k=6), data=dat,method="REML") b ## slight edf increase and -ve REML change b <- gam(y~s(x0,k=6)+s(x1,k=6)+s(x2,k=40)+s(x3,k=6), data=dat,method="REML") b ## defintely stabilized (but really k around 20 would have been fine) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/extract.lme.cov.Rd0000755000176200001440000000730313346772024015302 0ustar liggesusers\name{extract.lme.cov} \alias{extract.lme.cov} \alias{extract.lme.cov2} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Extract the data covariance matrix from an lme object} \description{ This is a service routine for \code{\link{gamm}}. Extracts the estimated covariance matrix of the data from an \code{lme} object, allowing the user control about which levels of random effects to include in this calculation. \code{extract.lme.cov} forms the full matrix explicitly: \code{extract.lme.cov2} tries to be more economical than this. } \usage{ extract.lme.cov(b,data=NULL,start.level=1) extract.lme.cov2(b,data=NULL,start.level=1) } %- maybe also `usage' for other objects documented here. \arguments{ \item{b}{ A fitted model object returned by a call to \code{\link[nlme]{lme}}}. \item{data}{ The data frame/ model frame that was supplied to \code{\link[nlme]{lme}}, but with any rows removed by the na action dropped. Uses the data stored in the model object if not supplied.} \item{start.level}{The level of nesting at which to start including random effects in the calculation. This is used to allow smooth terms to be estimated as random effects, but treated like fixed effects for variance calculations.} } \details{ The random effects, correlation structure and variance structure used for a linear mixed model combine to imply a covariance matrix for the response data being modelled. These routines extracts that covariance matrix. The process is slightly complicated, because different components of the fitted model object are stored in different orders (see function code for details!). The \code{extract.lme.cov} calculation is not optimally efficient, since it forms the full matrix, which may in fact be sparse. \code{extract.lme.cov2} is more efficient. If the covariance matrix is diagonal, then only the leading diagonal is returned; if it can be written as a block diagonal matrix (under some permutation of the original data) then a list of matrices defining the non-zero blocks is returned along with an index indicating which row of the original data each row/column of the block diagonal matrix relates to. The block sizes are defined by the coarsest level of grouping in the random effect structure. \code{\link{gamm}} uses \code{extract.lme.cov2}. \code{extract.lme.cov} does not currently deal with the situation in which the grouping factors for a correlation structure are finer than those for the random effects. \code{extract.lme.cov2} does deal with this situation. } \value{ For \code{extract.lme.cov} an estimated covariance matrix. For \code{extract.lme.cov2} a list containing the estimated covariance matrix and an indexing array. The covariance matrix is stored as the elements on the leading diagonal, a list of the matrices defining a block diagonal matrix, or a full matrix if the previous two options are not possible. } \references{ For \code{lme} see: Pinheiro J.C. and Bates, D.M. (2000) Mixed effects Models in S and S-PLUS. Springer For details of how GAMMs are set up here for estimation using \code{lme} see: Wood, S.N. (2006) Low rank scale invariant tensor product smooths for Generalized Additive Mixed Models. Biometrics 62(4):1025-1036 or Wood S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC Press. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gamm}}, \code{\link{formXtViX}} } \examples{ ## see also ?formXtViX for use of extract.lme.cov2 require(mgcv) library(nlme) data(Rail) b <- lme(travel~1,Rail,~1|Rail) extract.lme.cov(b) extract.lme.cov2(b) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/s.Rd0000755000176200001440000001477613303547337012544 0ustar liggesusers\name{s} \alias{s} %- Also NEED an `\alias' for EACH other topic documented here. \title{Defining smooths in GAM formulae} \description{ Function used in definition of smooth terms within \code{gam} model formulae. The function does not evaluate a (spline) smooth - it exists purely to help set up a model using spline based smooths. } \usage{s(..., k=-1,fx=FALSE,bs="tp",m=NA,by=NA,xt=NULL,id=NULL,sp=NULL,pc=NULL)} %- maybe also `usage' for other objects documented here. \arguments{ \item{...}{ a list of variables that are the covariates that this smooth is a function of. Transformations whose form depends on the values of the data are best avoided here: e.g. \code{s(log(x))} is fine, but \code{s(I(x/sd(x)))} is not (see \code{\link{predict.gam}}).} \item{k}{ the dimension of the basis used to represent the smooth term. The default depends on the number of variables that the smooth is a function of. \code{k} should not be less than the dimension of the null space of the penalty for the term (see \code{\link{null.space.dimension}}), but will be reset if it is. See \code{\link{choose.k}} for further information.} \item{fx}{indicates whether the term is a fixed d.f. regression spline (\code{TRUE}) or a penalized regression spline (\code{FALSE}).} \item{bs}{a two letter character string indicating the (penalized) smoothing basis to use. (eg \code{"tp"} for thin plate regression spline, \code{"cr"} for cubic regression spline). see \code{\link{smooth.terms}} for an over view of what is available. } \item{m}{The order of the penalty for this term (e.g. 2 for normal cubic spline penalty with 2nd derivatives when using default t.p.r.s basis). \code{NA} signals autoinitialization. Only some smooth classes use this. The \code{"ps"} class can use a 2 item array giving the basis and penalty order separately.} \item{by}{a numeric or factor variable of the same dimension as each covariate. In the numeric vector case the elements multiply the smooth, evaluated at the corresponding covariate values (a `varying coefficient model' results). For the numeric \code{by} variable case the resulting smooth is not usually subject to a centering constraint (so the \code{by variable} should not be added as an additional main effect). In the factor \code{by} variable case a replicate of the smooth is produced for each factor level (these smooths will be centered, so the factor usually needs to be added as a main effect as well). See \code{\link{gam.models}} for further details. A \code{by} variable may also be a matrix if covariates are matrices: in this case implements linear functional of a smooth (see \code{\link{gam.models}} and \code{\link{linear.functional.terms}} for details). } \item{xt}{Any extra information required to set up a particular basis. Used e.g. to set large data set handling behaviour for \code{"tp"} basis.} \item{id}{A label or integer identifying this term in order to link its smoothing parameters to others of the same type. If two or more terms have the same \code{id} then they will have the same smoothing paramsters, and, by default, the same bases (first occurance defines basis type, but data from all terms used in basis construction). An \code{id} with a factor \code{by} variable causes the smooths at each factor level to have the same smoothing parameter.} \item{sp}{any supplied smoothing parameters for this term. Must be an array of the same length as the number of penalties for this smooth. Positive or zero elements are taken as fixed smoothing parameters. Negative elements signal auto-initialization. Over-rides values supplied in \code{sp} argument to \code{\link{gam}}. Ignored by \code{gamm}.} \item{pc}{If not \code{NULL}, signals a point constraint: the smooth should pass through zero at the point given here (as a vector or list with names corresponding to the smooth names). Never ignored if supplied. See \code{\link{identifiability}}. } } \details{The function does not evaluate the variable arguments. To use this function to specify use of your own smooths, note the relationships between the inputs and the output object and see the example in \code{\link{smooth.construct}}. } \value{ A class \code{xx.smooth.spec} object, where \code{xx} is a basis identifying code given by the \code{bs} argument of \code{s}. These \code{smooth.spec} objects define smooths and are turned into bases and penalties by \code{smooth.construct} method functions. The returned object contains the following items: \item{term}{An array of text strings giving the names of the covariates that the term is a function of.} \item{bs.dim}{The dimension of the basis used to represent the smooth.} \item{fixed}{TRUE if the term is to be treated as a pure regression spline (with fixed degrees of freedom); FALSE if it is to be treated as a penalized regression spline} \item{dim}{The dimension of the smoother - i.e. the number of covariates that it is a function of.} \item{p.order}{The order of the t.p.r.s. penalty, or 0 for auto-selection of the penalty order.} \item{by}{is the name of any \code{by} variable as text (\code{"NA"} for none).} \item{label}{A suitable text label for this smooth term.} \item{xt}{The object passed in as argument \code{xt}.} \item{id}{An identifying label or number for the smooth, linking it to other smooths. Defaults to \code{NULL} for no linkage. } \item{sp}{array of smoothing parameters for the term (negative for auto-estimation). Defaults to \code{NULL}.} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 Wood S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC Press. \url{http://www.maths.bris.ac.uk/~sw15190/} } \seealso{ \code{\link{te}}, \code{\link{gam}}, \code{\link{gamm}}} \examples{ # example utilising `by' variables library(mgcv) set.seed(0) n<-200;sig2<-4 x1 <- runif(n, 0, 1);x2 <- runif(n, 0, 1);x3 <- runif(n, 0, 1) fac<-c(rep(1,n/2),rep(2,n/2)) # create factor fac.1<-rep(0,n)+(fac==1);fac.2<-1-fac.1 # and dummy variables fac<-as.factor(fac) f1 <- exp(2 * x1) - 3.75887 f2 <- 0.2 * x1^11 * (10 * (1 - x1))^6 + 10 * (10 * x1)^3 * (1 - x1)^10 f<-f1*fac.1+f2*fac.2+x2 e <- rnorm(n, 0, sqrt(abs(sig2))) y <- f + e # NOTE: smooths will be centered, so need to include fac in model.... b<-gam(y~fac+s(x1,by=fac)+x2) plot(b,pages=1) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/gam.selection.Rd0000755000176200001440000002173613073161527015021 0ustar liggesusers\name{gam.selection} \alias{gam.selection} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generalized Additive Model Selection} \description{ This page is intended to provide some more information on how to select GAMs. In particular, it gives a brief overview of smoothness selection, and then discusses how this can be extended to select inclusion/exclusion of terms. Hypothesis testing approaches to the latter problem are also discussed. } \section{Smoothness selection criteria}{ Given a model structure specified by a gam model formula, \code{gam()} attempts to find the appropriate smoothness for each applicable model term using prediction error criteria or likelihood based methods. The prediction error criteria used are Generalized (Approximate) Cross Validation (GCV or GACV) when the scale parameter is unknown or an Un-Biased Risk Estimator (UBRE) when it is known. UBRE is essentially scaled AIC (Generalized case) or Mallows' Cp (additive model case). GCV and UBRE are covered in Craven and Wahba (1979) and Wahba (1990). Alternatively REML of maximum likelihood (ML) may be used for smoothness selection, by viewing the smooth components as random effects (in this case the variance component for each smooth random effect will be given by the scale parameter divided by the smoothing parameter --- for smooths with multiple penalties, there will be multiple variance components). The \code{method} argument to \code{\link{gam}} selects the smoothness selection criterion. Automatic smoothness selection is unlikely to be successful with few data, particularly with multiple terms to be selected. In addition GCV and UBRE/AIC score can occasionally display local minima that can trap the minimisation algorithms. GCV/UBRE/AIC scores become constant with changing smoothing parameters at very low or very high smoothing parameters, and on occasion these `flat' regions can be separated from regions of lower score by a small `lip'. This seems to be the most common form of local minimum, but is usually avoidable by avoiding extreme smoothing parameters as starting values in optimization, and by avoiding big jumps in smoothing parameters while optimizing. Never the less, if you are suspicious of smoothing parameter estimates, try changing fit method (see \code{\link{gam}} arguments \code{method} and \code{optimizer}) and see if the estimates change, or try changing some or all of the smoothing parameters `manually' (argument \code{sp} of \code{\link{gam}}, or \code{sp} arguments to \code{\link{s}} or \code{\link{te}}). REML and ML are less prone to local minima than the other criteria, and may therefore be preferable. } \section{Automatic term selection}{ Unmodified smoothness selection by GCV, AIC, REML etc. will not usually remove a smooth from a model. This is because most smoothing penalties view some space of (non-zero) functions as `completely smooth' and once a term is penalized heavily enough that it is in this space, further penalization does not change it. However it is straightforward to modify smooths so that under heavy penalization they are penalized to the zero function and thereby `selected out' of the model. There are two approaches. The first approach is to modify the smoothing penalty with an additional shrinkage term. Smooth classes\code{cs.smooth} and \code{tprs.smooth} (specified by \code{"cs"} and \code{"ts"} respectively) have smoothness penalties which include a small shrinkage component, so that for large enough smoothing parameters the smooth becomes identically zero. This allows automatic smoothing parameter selection methods to effectively remove the term from the model altogether. The shrinkage component of the penalty is set at a level that usually makes negligable contribution to the penalization of the model, only becoming effective when the term is effectively `completely smooth' according to the conventional penalty. The second approach leaves the original smoothing penalty unchanged, but constructs an additional penalty for each smooth, which penalizes only functions in the null space of the original penalty (the `completely smooth' functions). Hence, if all the smoothing parameters for a term tend to infinity, the term will be selected out of the model. This latter approach is more expensive computationally, but has the advantage that it can be applied automatically to any smooth term. The \code{select} argument to \code{\link{gam}} turns on this method. In fact, as implemented, both approaches operate by eigen-decomposiong the original penalty matrix. A new penalty is created on the null space: it is the matrix with the same eigenvectors as the original penalty, but with the originally postive egienvalues set to zero, and the originally zero eigenvalues set to something positive. The first approach just addes a multiple of this penalty to the original penalty, where the multiple is chosen so that the new penalty can not dominate the original. The second approach treats the new penalty as an extra penalty, with its own smoothing parameter. Of course, as with all model selection methods, some care must be take to ensure that the automatic selection is sensible, and a decision about the effective degrees of freedom at which to declare a term `negligible' has to be made. } \section{Interactive term selection}{ In general the most logically consistent method to use for deciding which terms to include in the model is to compare GCV/UBRE/ML scores for models with and without the term (REML scores should not be used to compare models with different fixed effects structures). When UBRE is the smoothness selection method this will give the same result as comparing by \code{\link{AIC}} (the AIC in this case uses the model EDF in place of the usual model DF). Similarly, comparison via GCV score and via AIC seldom yields different answers. Note that the negative binomial with estimated \code{theta} parameter is a special case: the GCV score is not informative, because of the \code{theta} estimation scheme used. More generally the score for the model with a smooth term can be compared to the score for the model with the smooth term replaced by appropriate parametric terms. Candidates for replacement by parametric terms are smooth terms with estimated degrees of freedom close to their minimum possible. Candidates for removal can also be identified by reference to the approximate p-values provided by \code{summary.gam}, and by looking at the extent to which the confidence band for an estimated term includes the zero function. It is perfectly possible to perform backwards selection using p-values in the usual way: that is by sequentially dropping the single term with the highest non-significant p-value from the model and re-fitting, until all terms are significant. This suffers from the same problems as stepwise procedures for any GLM/LM, with the additional caveat that the p-values are only approximate. If adopting this approach, it is probably best to use ML smoothness selection. Note that GCV and UBRE are not appropriate for comparing models using different families: in that case AIC should be used. } \section{Caveats/platitudes}{ Formal model selection methods are only appropriate for selecting between reasonable models. If formal model selection is attempted starting from a model that simply doesn't fit the data, then it is unlikely to provide meaningful results. The more thought is given to appropriate model structure up front, the more successful model selection is likely to be. Simply starting with a hugely flexible model with `everything in' and hoping that automatic selection will find the right structure is not often successful. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Marra, G. and S.N. Wood (2011) Practical variable selection for generalized additive models. Computational Statistics and Data Analysis 55,2372-2387. Craven and Wahba (1979) Smoothing Noisy Data with Spline Functions. Numer. Math. 31:377-403 Venables and Ripley (1999) Modern Applied Statistics with S-PLUS Wahba (1990) Spline Models of Observational Data. SIAM. Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 Wood, S.N. (2008) Fast stable direct fitting and smoothness selection for generalized additive models. J.R.Statist. Soc. B 70(3):495-518 Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 \url{http://www.maths.bris.ac.uk/~sw15190/} } \seealso{\code{\link{gam}}, \code{\link{step.gam}}} \examples{ ## an example of automatic model selection via null space penalization library(mgcv) set.seed(3);n<-200 dat <- gamSim(1,n=n,scale=.15,dist="poisson") ## simulate data dat$x4 <- runif(n, 0, 1);dat$x5 <- runif(n, 0, 1) ## spurious b<-gam(y~s(x0)+s(x1)+s(x2)+s(x3)+s(x4)+s(x5),data=dat, family=poisson,select=TRUE,method="REML") summary(b) plot(b,pages=1) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/one.se.rule.Rd0000755000176200001440000000533713073161526014424 0ustar liggesusers\name{one.se.rule} \alias{one.se.rule} %- Also NEED an `\alias' for EACH other topic documented here. \title{The one standard error rule for smoother models} \description{ The `one standard error rule' (see e.g. Hastie, Tibshirani and Friedman, 2009) is a way of producing smoother models than those directly estimated by automatic smoothing parameter selection methods. In the single smoothing parameter case, we select the largest smoothing parameter within one standard error of the optimum of the smoothing parameter selection criterion. This approach can be generalized to multiple smoothing parameters estimated by REML or ML.} \details{Under REML or ML smoothing parameter selection an asyptotic distributional approximation is available for the log smoothing parameters. Let \eqn{\rho}{r} denote the log smoothing parameters that we want to increase to obtain a smoother model. The large sample distribution of the estimator of \eqn{\rho}{r} is \eqn{N(\rho,V)}{N(r,V)} where \eqn{V}{V} is the matrix returned by \code{\link{sp.vcov}}. Drop any elements of \eqn{\rho}{r} that are already at `effective infinity', along with the corresponding rows and columns of \eqn{V}{V}. The standard errors of the log smoothing parameters can be obtained from the leading diagonal of \eqn{V}{V}. Let the vector of these be \eqn{d}{d}. Now suppose that we want to increase the estimated log smoothing parameters by an amount \eqn{\alpha d}{a*d}. We choose \eqn{\alpha}{a} so that \eqn{\alpha d^T V^{-1}d = \sqrt{2p}}{a d'V^{-1}d = (2p)^0.5}, where p is the dimension of d and 2p the variance of a chi-squared r.v. with p degrees of freedom. The idea is that we increase the log smoothing parameters in proportion to their standard deviation, until the RE/ML is increased by 1 standard deviation according to its asypmtotic distribution. } \author{Simon N. Wood \email{simon.wood@r-project.org} } \references{Hastie, T, R. Tibshirani and J. Friedman (2009) The Elements of Statistical Learning 2nd ed. Springer.} \seealso{ \code{\link{gam}}} \examples{ require(mgcv) set.seed(2) ## simulate some data... dat <- gamSim(1,n=400,dist="normal",scale=2) b <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat,method="REML") b ## only the first 3 smoothing parameters are candidates for ## increasing here... V <- sp.vcov(b)[1:3,1:3] ## the approx cov matrix of sps d <- diag(V)^.5 ## sp se. ## compute the log smoothing parameter step... d <- sqrt(2*length(d))/d%*%solve(V,d)*d sp <- b$sp ## extract original sp estimates sp[1:3] <- sp[1:3]*exp(d) ## apply the step ## refit with the increased smoothing parameters... b1 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat,method="REML",sp=sp) b;b1 ## compare fits } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/gamObject.Rd0000755000176200001440000002252013303547351014153 0ustar liggesusers\name{gamObject} \alias{gamObject} %- Also NEED an `\alias' for EACH other topic documented here. \title{Fitted gam object} \description{A fitted GAM object returned by function \code{gam} and of class \code{"gam"} inheriting from classes \code{"glm"} and \code{"lm"}. Method functions \code{anova}, \code{logLik}, \code{influence}, \code{plot}, \code{predict}, \code{print}, \code{residuals} and \code{summary} exist for this class. All compulsory elements of \code{"glm"} and \code{"lm"} objects are present, but the fitting method for a GAM is different to a linear model or GLM, so that the elements relating to the QR decomposition of the model matrix are absent. } \value{ A \code{gam} object has the following elements: \item{aic}{AIC of the fitted model: bear in mind that the degrees of freedom used to calculate this are the effective degrees of freedom of the model, and the likelihood is evaluated at the maximum of the penalized likelihood in most cases, not at the MLE.} \item{assign}{Array whose elements indicate which model term (listed in \code{pterms}) each parameter relates to: applies only to non-smooth terms.} \item{boundary}{did parameters end up at boundary of parameter space?} \item{call}{the matched call (allows \code{update} to be used with \code{gam} objects, for example). } \item{cmX}{column means of the model matrix (with elements corresponding to smooths set to zero ) --- useful for componentwise CI calculation.} \item{coefficients}{the coefficients of the fitted model. Parametric coefficients are first, followed by coefficients for each spline term in turn.} \item{control}{the \code{gam} control list used in the fit.} \item{converged}{indicates whether or not the iterative fitting method converged.} \item{data}{the original supplied data argument (for class \code{"glm"} compatibility). Only included if \code{\link{gam}} \code{control} argument element \code{keepData} is set to \code{TRUE} (default is \code{FALSE}).} \item{db.drho}{matrix of first derivatives of model coefficients w.r.t. log smoothing parameters.} \item{deviance}{model deviance (not penalized deviance).} \item{df.null}{null degrees of freedom.} \item{df.residual}{effective residual degrees of freedom of the model.} \item{edf}{estimated degrees of freedom for each model parameter. Penalization means that many of these are less than 1.} \item{edf1}{similar, but using alternative estimate of EDF. Useful for testing.} \item{edf2}{if estimation is by ML or REML then an edf that accounts for smoothing parameter uncertainty can be computed, this is it. \code{edf1} is a heuristic upper bound for \code{edf2}.} \item{family}{family object specifying distribution and link used.} \item{fitted.values}{fitted model predictions of expected value for each datum.} \item{formula}{the model formula.} \item{full.sp}{full array of smoothing parameters multiplying penalties (excluding any contribution from \code{min.sp} argument to \code{gam}). May be larger than \code{sp} if some terms share smoothing parameters, and/or some smoothing parameter values were supplied in the \code{sp} argument of \code{\link{gam}}.} \item{F}{Degrees of freedom matrix. This may be removed at some point, and should probably not be used.} \item{gcv.ubre}{The minimized smoothing parameter selection score: GCV, UBRE(AIC), GACV, negative log marginal likelihood or negative log restricted likelihood.} \item{hat}{array of elements from the leading diagonal of the `hat' (or `influence') matrix. Same length as response data vector.} \item{iter}{number of iterations of P-IRLS taken to get convergence.} \item{linear.predictors}{fitted model prediction of link function of expected value for each datum.} \item{method}{One of \code{"GCV"} or \code{"UBRE"}, \code{"REML"}, \code{"P-REML"}, \code{"ML"}, \code{"P-ML"}, \code{"PQL"}, \code{"lme.ML"} or \code{"lme.REML"}, depending on the fitting criterion used.} \item{mgcv.conv}{ A list of convergence diagnostics relating to the \code{"magic"} parts of smoothing parameter estimation - this will not be very meaningful for pure \code{"outer"} estimation of smoothing parameters. The items are: \code{full.rank}, The apparent rank of the problem given the model matrix and constraints; \code{rank}, The numerical rank of the problem; \code{fully.converged}, \code{TRUE} is multiple GCV/UBRE converged by meeting convergence criteria and \code{FALSE} if method stopped with a steepest descent step failure; \code{hess.pos.def}Was the hessian of the GCV/UBRE score positive definite at smoothing parameter estimation convergence?; \code{iter} How many iterations were required to find the smoothing parameters? \code{score.calls}, and how many times did the GCV/UBRE score have to be evaluated?; \code{rms.grad}, root mean square of the gradient of the GCV/UBRE score at convergence. } % end of mgcv.conv listing \item{min.edf}{Minimum possible degrees of freedom for whole model.} \item{model}{model frame containing all variables needed in original model fit.} \item{na.action}{The \code{\link{na.action}} used in fitting.} \item{nsdf}{number of parametric, non-smooth, model terms including the intercept.} \item{null.deviance}{deviance for single parameter model.} \item{offset}{model offset.} \item{optimizer}{\code{optimizer} argument to \code{\link{gam}}, or \code{"magic"} if it's a pure additive model.} \item{outer.info}{If `outer' iteration has been used to fit the model (see \code{\link{gam}} argument \code{optimizer}) then this is present and contains whatever was returned by the optimization routine used (currently \code{\link{nlm}} or \code{\link{optim}}). } \item{paraPen}{If the \code{paraPen} argument to \code{\link{gam}} was used then this provides information on the parametric penalties. \code{NULL} otherwise.} \item{pred.formula}{one sided formula containing variables needed for prediction, used by \code{predict.gam}} \item{prior.weights}{prior weights on observations.} \item{pterms}{\code{terms} object for strictly parametric part of model.} \item{R}{Factor R from QR decomposition of weighted model matrix, unpivoted to be in same column order as model matrix (so need not be upper triangular).} \item{rank}{apparent rank of fitted model.} \item{reml.scale}{The scale (RE)ML scale parameter estimate, if (P-)(RE)ML used for smoothness estimation. } \item{residuals}{the working residuals for the fitted model.} \item{rV}{If present, \code{rV\%*\%t(rV)*sig2} gives the estimated Bayesian covariance matrix.} \item{scale}{when present, the scale (as \code{sig2})} \item{scale.estimated}{ \code{TRUE} if the scale parameter was estimated, \code{FALSE} otherwise.} \item{sig2}{estimated or supplied variance/scale parameter.} \item{smooth}{list of smooth objects, containing the basis information for each term in the model formula in the order in which they appear. These smooth objects are what gets returned by the \code{\link{smooth.construct}} objects.} \item{sp}{estimated smoothing parameters for the model. These are the underlying smoothing parameters, subject to optimization. For the full set of smoothing parameters multiplying the penalties see \code{full.sp}. Divide the scale parameter by the smoothing parameters to get, variance components, but note that this is not valid for smooths that have used rescaling to improve conditioning.} \item{terms}{\code{terms} object of \code{model} model frame.} \item{var.summary}{A named list of summary information on the predictor variables. If a parametric variable is a matrix, then the summary is a one row matrix, containing the observed data value closest to the column median, for each matrix column. If the variable is a factor the then summary is the modal factor level, returned as a factor, with levels corresponding to those of the data. For numerics and matrix arguments of smooths, the summary is the mean, nearest observed value to median and maximum, as a numeric vector. Used by \code{\link{vis.gam}}, in particular. } \item{Ve}{frequentist estimated covariance matrix for the parameter estimators. Particularly useful for testing whether terms are zero. Not so useful for CI's as smooths are usually biased.} \item{Vp}{estimated covariance matrix for the parameters. This is a Bayesian posterior covariance matrix that results from adopting a particular Bayesian model of the smoothing process. Paricularly useful for creating credible/confidence intervals.} \item{Vc}{Under ML or REML smoothing parameter estimation it is possible to correct the covariance matrix \code{Vp} for smoothing parameter uncertainty. This is the corrected version. } \item{weights}{final weights used in IRLS iteration.} \item{y}{response data.} } \references{ A Key Reference on this implementation: Wood, S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman & Hall/ CRC, Boca Raton, Florida Key Reference on GAMs generally: Hastie (1993) in Chambers and Hastie (1993) Statistical Models in S. Chapman and Hall. Hastie and Tibshirani (1990) Generalized Additive Models. Chapman and Hall. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \section{WARNINGS }{ This model object is different to that described in Chambers and Hastie (1993) in order to allow smoothing parameter estimation etc. } \seealso{\code{\link{gam}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/gam.fit.Rd0000755000176200001440000000536413073161526013614 0ustar liggesusers\name{gam.fit} \alias{gam.fit} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM P-IRLS estimation with GCV/UBRE smoothness estimation} \description{ This is an internal function of package \code{mgcv}. It is a modification of the function \code{glm.fit}, designed to be called from \code{gam} when perfomance iteration is selected (not the default). The major modification is that rather than solving a weighted least squares problem at each IRLS step, a weighted, penalized least squares problem is solved at each IRLS step with smoothing parameters associated with each penalty chosen by GCV or UBRE, using routine \code{\link{magic}}. For further information on usage see code for \code{gam}. Some regularization of the IRLS weights is also permitted as a way of addressing identifiability related problems (see \code{\link{gam.control}}). Negative binomial parameter estimation is supported. The basic idea of estimating smoothing parameters at each step of the P-IRLS is due to Gu (1992), and is termed `performance iteration' or `performance oriented iteration'. } \usage{ gam.fit(G, start = NULL, etastart = NULL, mustart = NULL, family = gaussian(), control = gam.control(),gamma=1, fixedSteps=(control$maxit+1),...) } \arguments{ \item{G}{An object of the type returned by \code{\link{gam}} when \code{fit=FALSE}.} \item{start}{Initial values for the model coefficients.} \item{etastart}{Initial values for the linear predictor.} \item{mustart}{Initial values for the expected response.} \item{family}{The family object, specifying the distribution and link to use.} \item{control}{Control option list as returned by \code{\link{gam.control}}.} \item{gamma}{Parameter which can be increased to up the cost of each effective degree of freedom in the GCV or AIC/UBRE objective.} \item{fixedSteps}{How many steps to take: useful when only using this routine to get rough starting values for other methods.} \item{...}{Other arguments: ignored.} } \value{A list of fit information.} \references{ Gu (1992) Cross-validating non-Gaussian data. J. Comput. Graph. Statist. 1:169-179 Gu and Wahba (1991) Minimizing GCV/GML scores with multiple smoothing parameters via the Newton method. SIAM J. Sci. Statist. Comput. 12:383-398 Wood, S.N. (2000) Modelling and Smoothing Parameter Estimation with Multiple Quadratic Penalties. J.R.Statist.Soc.B 62(2):413-428 Wood, S.N. (2004) Stable and efficient multiple smoothing parameter estimation for generalized additive models. J. Amer. Statist. Ass. 99:637-686 } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gam.fit3}}, \code{\link{gam}}, \code{\link{magic}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/t2.Rd0000755000176200001440000002775613073161526012625 0ustar liggesusers\name{t2} \alias{t2} %- Also NEED an `\alias' for EACH other topic documented here. \title{Define alternative tensor product smooths in GAM formulae} \description{ Alternative to \code{\link{te}} for defining tensor product smooths in a \code{\link{gam}} formula. Results in a construction in which the penalties are non-overlapping multiples of identity matrices (with some rows and columns zeroed). The construction, which is due to Fabian Scheipl (\code{mgcv} implementation, 2010), is analogous to Smoothing Spline ANOVA (Gu, 2002), but using low rank penalized regression spline marginals. The main advantage of this construction is that it is useable with \code{gamm4} from package \code{gamm4}. } \usage{t2(..., k=NA,bs="cr",m=NA,d=NA,by=NA,xt=NULL, id=NULL,sp=NULL,full=FALSE,ord=NULL,pc=NULL) } %- maybe also `usage' for other objects documented here. \arguments{ \item{...}{ a list of variables that are the covariates that this smooth is a function of. Transformations whose form depends on the values of the data are best avoided here: e.g. \code{t2(log(x),z)} is fine, but \code{t2(I(x/sd(x)),z)} is not (see \code{\link{predict.gam}}).} \item{k}{ the dimension(s) of the bases used to represent the smooth term. If not supplied then set to \code{5^d}. If supplied as a single number then this basis dimension is used for each basis. If supplied as an array then the elements are the dimensions of the component (marginal) bases of the tensor product. See \code{\link{choose.k}} for further information.} \item{bs}{array (or single character string) specifying the type for each marginal basis. \code{"cr"} for cubic regression spline; \code{"cs"} for cubic regression spline with shrinkage; \code{"cc"} for periodic/cyclic cubic regression spline; \code{"tp"} for thin plate regression spline; \code{"ts"} for t.p.r.s. with extra shrinkage. See \code{\link{smooth.terms}} for details and full list. User defined bases can also be used here (see \code{\link{smooth.construct}} for an example). If only one basis code is given then this is used for all bases.} \item{m}{The order of the spline and its penalty (for smooth classes that use this) for each term. If a single number is given then it is used for all terms. A vector can be used to supply a different \code{m} for each margin. For marginals that take vector \code{m} (e.g. \code{\link{p.spline}} and \code{\link{Duchon.spline}}), then a list can be supplied, with a vector element for each margin. \code{NA} autoinitializes. \code{m} is ignored by some bases (e.g. \code{"cr"}).} \item{d}{array of marginal basis dimensions. For example if you want a smooth for 3 covariates made up of a tensor product of a 2 dimensional t.p.r.s. basis and a 1-dimensional basis, then set \code{d=c(2,1)}. Incompatibilities between built in basis types and dimension will be resolved by resetting the basis type.} \item{by}{a numeric or factor variable of the same dimension as each covariate. In the numeric vector case the elements multiply the smooth evaluated at the corresponding covariate values (a `varying coefficient model' results). In the factor case causes a replicate of the smooth to be produced for each factor level. See \code{\link{gam.models}} for further details. May also be a matrix if covariates are matrices: in this case implements linear functional of a smooth (see \code{\link{gam.models}} and \code{\link{linear.functional.terms}} for details).} \item{xt}{Either a single object, providing any extra information to be passed to each marginal basis constructor, or a list of such objects, one for each marginal basis. } \item{id}{A label or integer identifying this term in order to link its smoothing parameters to others of the same type. If two or more smooth terms have the same \code{id} then they will have the same smoothing paramsters, and, by default, the same bases (first occurance defines basis type, but data from all terms used in basis construction).} \item{sp}{any supplied smoothing parameters for this term. Must be an array of the same length as the number of penalties for this smooth. Positive or zero elements are taken as fixed smoothing parameters. Negative elements signal auto-initialization. Over-rides values supplied in \code{sp} argument to \code{\link{gam}}. Ignored by \code{gamm}.} \item{full}{If \code{TRUE} then there is a separate penalty for each combination of null space column and range space. This gives strict invariance. If \code{FALSE} each combination of null space and range space generates one penalty, but the coulmns of each null space basis are treated as one group. The latter is more parsimonious, but does mean that invariance is only achieved by an arbitrary rescaling of null space basis vectors.} \item{ord}{an array giving the orders of terms to retain. Here order means number of marginal range spaces used in the construction of the component. \code{NULL} to retain everything. } \item{pc}{If not \code{NULL}, signals a point constraint: the smooth should pass through zero at the point given here (as a vector or list with names corresponding to the smooth names). Never ignored if supplied. See \code{\link{identifiability}}. } } \details{ Smooths of several covariates can be constructed from tensor products of the bases used to represent smooths of one (or sometimes more) of the covariates. To do this `marginal' bases are produced with associated model matrices and penalty matrices. These are reparameterized so that the penalty is zero everywhere, except for some elements on the leading diagonal, which all have the same non-zero value. This reparameterization results in an unpenalized and a penalized subset of parameters, for each marginal basis (see e.g. appendix of Wood, 2004, for details). The re-parameterized marginal bases are then combined to produce a basis for a single function of all the covariates (dimension given by the product of the dimensions of the marginal bases). In this set up there are multiple penalty matrices --- all zero, but for a mixture of a constant and zeros on the leading diagonal. No two penalties have a non-zero entry in the same place. Essentially the basis for the tensor product can be thought of as being constructed from a set of products of the penalized (range) or unpenalized (null) space bases of the marginal smooths (see Gu, 2002, section 2.4). To construct one of the set, choose either the null space or the range space from each marginal, and from these bases construct a product basis. The result is subject to a ridge penalty (unless it happens to be a product entirely of marginal null spaces). The whole basis for the smooth is constructed from all the different product bases that can be constructed in this way. The separately penalized components of the smooth basis each have an interpretation in terms of the ANOVA - decomposition of the term. See \code{\link{pen.edf}} for some further information. Note that there are two ways to construct the product. When \code{full=FALSE} then the null space bases are treated as a whole in each product, but when \code{full=TRUE} each null space column is treated as a separate null space. The latter results in more penalties, but is the strict analog of the SS-ANOVA approach. Tensor product smooths are especially useful for representing functions of covariates measured in different units, although they are typically not quite as nicely behaved as t.p.r.s. smooths for well scaled covariates. Note also that GAMs constructed from lower rank tensor product smooths are nested within GAMs constructed from higher rank tensor product smooths if the same marginal bases are used in both cases (the marginal smooths themselves are just special cases of tensor product smooths.) Note that tensor product smooths should not be centred (have identifiability constraints imposed) if any marginals would not need centering. The constructor for tensor product smooths ensures that this happens. The function does not evaluate the variable arguments. } \value{ A class \code{t2.smooth.spec} object defining a tensor product smooth to be turned into a basis and penalties by the \code{smooth.construct.tensor.smooth.spec} function. The returned object contains the following items: \item{margin}{A list of \code{smooth.spec} objects of the type returned by \code{\link{s}}, defining the basis from which the tensor product smooth is constructed.} \item{term}{An array of text strings giving the names of the covariates that the term is a function of.} \item{by}{is the name of any \code{by} variable as text (\code{"NA"} for none).} \item{fx}{ logical array with element for each penalty of the term (tensor product smooths have multiple penalties). \code{TRUE} if the penalty is to be ignored, \code{FALSE}, otherwise. } \item{label}{A suitable text label for this smooth term.} \item{dim}{The dimension of the smoother - i.e. the number of covariates that it is a function of.} \item{mp}{\code{TRUE} is multiple penalties are to be used (default).} \item{np}{\code{TRUE} to re-parameterize 1-D marginal smooths in terms of function values (defualt).} \item{id}{the \code{id} argument supplied to \code{te}.} \item{sp}{the \code{sp} argument supplied to \code{te}.} } \author{ Simon N. Wood \email{simon.wood@r-project.org} and Fabian Scheipl} \references{ Wood S.N., F. Scheipl and J.J. Faraway (2013, online Feb 2012) Straightforward intermediate rank tensor product smoothing in mixed models. Statistical Computing. 23(3):341-360 Gu, C. (2002) Smoothing Spline ANOVA, Springer. Alternative approaches to functional ANOVA decompositions, *not* implemented by t2 terms, are discussed in: Belitz and Lang (2008) Simultaneous selection of variables and smoothing parameters in structured additive regression models. Computational Statistics & Data Analysis, 53(1):61-81 Lee, D-J and M. Durban (2011) P-spline ANOVA type interaction models for spatio-temporal smoothing. Statistical Modelling, 11:49-69 Wood, S.N. (2006) Low-Rank Scale-Invariant Tensor Product Smooths for Generalized Additive Mixed Models. Biometrics 62(4): 1025-1036. } \seealso{\code{\link{te}} \code{\link{s}},\code{\link{gam}},\code{\link{gamm}}, } \examples{ # following shows how tensor product deals nicely with # badly scaled covariates (range of x 5\% of range of z ) require(mgcv) test1<-function(x,z,sx=0.3,sz=0.4) { x<-x*20 (pi**sx*sz)*(1.2*exp(-(x-0.2)^2/sx^2-(z-0.3)^2/sz^2)+ 0.8*exp(-(x-0.7)^2/sx^2-(z-0.8)^2/sz^2)) } n<-500 old.par<-par(mfrow=c(2,2)) x<-runif(n)/20;z<-runif(n); xs<-seq(0,1,length=30)/20;zs<-seq(0,1,length=30) pr<-data.frame(x=rep(xs,30),z=rep(zs,rep(30,30))) truth<-matrix(test1(pr$x,pr$z),30,30) f <- test1(x,z) y <- f + rnorm(n)*0.2 b1<-gam(y~s(x,z)) persp(xs,zs,truth);title("truth") vis.gam(b1);title("t.p.r.s") b2<-gam(y~t2(x,z)) vis.gam(b2);title("tensor product") b3<-gam(y~t2(x,z,bs=c("tp","tp"))) vis.gam(b3);title("tensor product") par(old.par) test2<-function(u,v,w,sv=0.3,sw=0.4) { ((pi**sv*sw)*(1.2*exp(-(v-0.2)^2/sv^2-(w-0.3)^2/sw^2)+ 0.8*exp(-(v-0.7)^2/sv^2-(w-0.8)^2/sw^2)))*(u-0.5)^2*20 } n <- 500 v <- runif(n);w<-runif(n);u<-runif(n) f <- test2(u,v,w) y <- f + rnorm(n)*0.2 ## tensor product of 2D Duchon spline and 1D cr spline m <- list(c(1,.5),0) b <- gam(y~t2(v,w,u,k=c(30,5),d=c(2,1),bs=c("ds","cr"),m=m)) ## look at the edf per penalty. "rr" denotes interaction term ## (range space range space). "rn" is interaction of null space ## for u with range space for v,w... pen.edf(b) ## plot results... op <- par(mfrow=c(2,2)) vis.gam(b,cond=list(u=0),color="heat",zlim=c(-0.2,3.5)) vis.gam(b,cond=list(u=.33),color="heat",zlim=c(-0.2,3.5)) vis.gam(b,cond=list(u=.67),color="heat",zlim=c(-0.2,3.5)) vis.gam(b,cond=list(u=1),color="heat",zlim=c(-0.2,3.5)) par(op) b <- gam(y~t2(v,w,u,k=c(25,5),d=c(2,1),bs=c("tp","cr"),full=TRUE), method="ML") ## more penalties now. numbers in labels like "r1" indicate which ## basis function of a null space is involved in the term. pen.edf(b) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/fix.family.link.Rd0000755000176200001440000000717213137076654015300 0ustar liggesusers\name{fix.family.link} \alias{fix.family.link} \alias{fix.family.var} \alias{fix.family.ls} \alias{fix.family.qf} \alias{fix.family.rd} %- Also NEED an `\alias' for EACH other topic documented here. \title{Modify families for use in GAM fitting and checking} \description{ Generalized Additive Model fitting by `outer' iteration, requires extra derivatives of the variance and link functions to be added to family objects. The first 3 functions add what is needed. Model checking can be aided by adding quantile and random deviate generating functions to the family. The final two functions do this. } \usage{ fix.family.link(fam) fix.family.var(fam) fix.family.ls(fam) fix.family.qf(fam) fix.family.rd(fam) } %- maybe also `usage' for other objects documented here. \arguments{ \item{fam}{A \code{family}.} } \details{ Consider the first 3 function first. Outer iteration GAM estimation requires derivatives of the GCV, UBRE/gAIC, GACV, REML or ML score, which are obtained by finding the derivatives of the model coefficients w.r.t. the log smoothing parameters, using the implicit function theorem. The expressions for the derivatives require the second and third derivatives of the link w.r.t. the mean (and the 4th derivatives if Fisher scoring is not used). Also required are the first and second derivatives of the variance function w.r.t. the mean (plus the third derivative if Fisher scoring is not used). Finally REML or ML estimation of smoothing parameters requires the log saturated likelihood and its first two derivatives w.r.t. the scale parameter. These functions add functions evaluating these quantities to a family. If the family already has functions \code{dvar}, \code{d2var}, \code{d3var}, \code{d2link}, \code{d3link}, \code{d4link} and for RE/ML \code{ls}, then these functions simply return the family unmodified: this allows non-standard links to be used with \code{\link{gam}} when using outer iteration (performance iteration operates with unmodified families). Note that if you only need Fisher scoring then \code{d4link} and \code{d3var} can be dummy, as they are ignored. Similalry \code{ls} is only needed for RE/ML. The \code{dvar} function is a function of a mean vector, \code{mu}, and returns a vector of corresponding first derivatives of the family variance function. The \code{d2link} function is also a function of a vector of mean values, \code{mu}: it returns a vector of second derivatives of the link, evaluated at \code{mu}. Higher derivatives are defined similarly. If modifying your own family, note that you can often get away with supplying only a \code{dvar} and \code{d2var}, function if your family only requires links that occur in one of the standard families. The second two functions are useful for investigating the distribution of residuals and are used by \code{\link{qq.gam}}. If possible the functions add quantile (\code{qf}) or random deviate (\code{rd}) generating functions to the family. If a family already has \code{qf} or \code{rd} functions then it is left unmodified. \code{qf} functions are only available for some families, and for quasi families neither type of function is available. } \value{A family object with extra component functions \code{dvar}, \code{d2var}, \code{d2link}, \code{d3link}, \code{d4link}, \code{ls}, and possibly \code{qf} and \code{rd}, depending on which functions are called. \code{fix.family.var} also adds a variable \code{scale} set to negative to indicate that family has a free scale parameter. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gam.fit3}}, \code{\link{qq.gam}}} \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/qq.gam.Rd0000755000176200001440000001323713073161526013451 0ustar liggesusers\name{qq.gam} \alias{qq.gam} \title{QQ plots for gam model residuals} \description{ Takes a fitted \code{gam} object produced by \code{gam()} and produces QQ plots of its residuals (conditional on the fitted model coefficients and scale parameter). If the model distributional assumptions are met then usually these plots should be close to a straight line (although discrete data can yield marked random departures from this line). } \usage{ qq.gam(object, rep=0, level=.9,s.rep=10, type=c("deviance","pearson","response"), pch=".", rl.col=2, rep.col="gray80", \dots) } \arguments{ \item{object}{ a fitted \code{gam} object as produced by \code{gam()} (or a \code{glm} object).} \item{rep}{How many replicate datasets to generate to simulate quantiles of the residual distribution. \code{0} results in an efficient simulation free method for direct calculation, if this is possible for the object family.} \item{level}{If simulation is used for the quantiles, then reference intervals can be provided for the QQ-plot, this specifies the level. 0 or less for no intervals, 1 or more to simply plot the QQ plot for each replicate generated.} \item{s.rep}{how many times to randomize uniform quantiles to data under direct computation.} \item{type}{what sort of residuals should be plotted? See \code{\link{residuals.gam}}.} \item{pch}{plot character to use. 19 is good.} \item{rl.col}{color for the reference line on the plot.} \item{rep.col}{color for reference bands or replicate reference plots.} \item{...}{extra graphics parameters to pass to plotting functions.} } \details{QQ-plots of the the model residuals can be produced in one of two ways. The cheapest method generates reference quantiles by associating a quantile of the uniform distribution with each datum, and feeding these uniform quantiles into the quantile function associated with each datum. The resulting quantiles are then used in place of each datum to generate approximate quantiles of residuals. The residual quantiles are averaged over \code{s.rep} randomizations of the uniform quantiles to data. The second method is to use direct simulatation. For each replicate, data are simulated from the fitted model, and the corresponding residuals computed. This is repeated \code{rep} times. Quantiles are readily obtained from the empirical distribution of residuals so obtained. From this method reference bands are also computable. Even if \code{rep} is set to zero, the routine will attempt to simulate quantiles if no quantile function is available for the family. If no random deviate generating function family is available (e.g. for the quasi families), then a normal QQ-plot is produced. The routine conditions on the fitted model coefficents and the scale parameter estimate. The plots are very similar to those proposed in Ben and Yohai (2004), but are substantially cheaper to produce (the interpretation of residuals for binary data in Ben and Yohai is not recommended). Note that plots for raw residuals from fits to binary data contain almost no useful information about model fit. Whether the residual is negative or positive is decided by whether the response is zero or one. The magnitude of the residual, given its sign, is determined entirely by the fitted values. In consequence only the most gross violations of the model are detectable from QQ-plots of residuals for binary data. To really check distributional assumptions from residuals for binary data you have to be able to group the data somehow. Binomial models other than binary are ok. } \references{ N.H. Augustin, E-A Sauleaub, S.N. Wood (2012) On quantile quantile plots for generalized linear models Computational Statistics & Data Analysis. 56(8), 2404-2409. M.G. Ben and V.J. Yohai (2004) JCGS 13(1), 36-47. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{choose.k}}, \code{\link{gam}}} \examples{ library(mgcv) ## simulate binomial data... set.seed(0) n.samp <- 400 dat <- gamSim(1,n=n.samp,dist="binary",scale=.33) p <- binomial()$linkinv(dat$f) ## binomial p n <- sample(c(1,3),n.samp,replace=TRUE) ## binomial n dat$y <- rbinom(n,n,p) dat$n <- n lr.fit <- gam(y/n~s(x0)+s(x1)+s(x2)+s(x3) ,family=binomial,data=dat,weights=n,method="REML") par(mfrow=c(2,2)) ## normal QQ-plot of deviance residuals qqnorm(residuals(lr.fit),pch=19,cex=.3) ## Quick QQ-plot of deviance residuals qq.gam(lr.fit,pch=19,cex=.3) ## Simulation based QQ-plot with reference bands qq.gam(lr.fit,rep=100,level=.9) ## Simulation based QQ-plot, Pearson resids, all ## simulated reference plots shown... qq.gam(lr.fit,rep=100,level=1,type="pearson",pch=19,cex=.2) ## Now fit the wrong model and check.... pif <- gam(y~s(x0)+s(x1)+s(x2)+s(x3) ,family=poisson,data=dat,method="REML") par(mfrow=c(2,2)) qqnorm(residuals(pif),pch=19,cex=.3) qq.gam(pif,pch=19,cex=.3) qq.gam(pif,rep=100,level=.9) qq.gam(pif,rep=100,level=1,type="pearson",pch=19,cex=.2) ## Example of binary data model violation so gross that you see a problem ## on the QQ plot... y <- c(rep(1,10),rep(0,20),rep(1,40),rep(0,10),rep(1,40),rep(0,40)) x <- 1:160 b <- glm(y~x,family=binomial) par(mfrow=c(2,2)) ## Note that the next two are not necessarily similar under gross ## model violation... qq.gam(b) qq.gam(b,rep=50,level=1) ## and a much better plot for detecting the problem plot(x,residuals(b),pch=19,cex=.3) plot(x,y);lines(x,fitted(b)) ## alternative model b <- gam(y~s(x,k=5),family=binomial,method="ML") qq.gam(b) qq.gam(b,rep=50,level=1) plot(x,residuals(b),pch=19,cex=.3) plot(b,residuals=TRUE,pch=19,cex=.3) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/ziplss.Rd0000755000176200001440000000673513073161526013616 0ustar liggesusers\name{ziplss} \alias{ziplss} %- Also NEED an `\alias' for EACH other topic documented here. \title{Zero inflated Poisson location-scale model family} \description{The \code{ziplss} family implements a zero inflated Poisson model in which one linear predictor controls the probability of presence and the other controls the mean given presence. Useable only with \code{\link{gam}}, the linear predictors are specified via a list of formulae. Should be used with care: simply having a large number of zeroes is not an indication of zero inflation. Requires integer count data. } \usage{ ziplss(link=list("identity","identity")) } \arguments{ \item{link}{two item list specifying the link - currently only identity links are possible, as parameterization is directly in terms of log of Poisson response and logit of probability of presence.} } \value{ An object inheriting from class \code{general.family}. } \details{Used with \code{\link{gam}} to fit 2 stage zero inflated Poisson models. \code{gam} is called with a list containing 2 formulae, the first specifies the response on the left hand side and the structure of the linear predictor for the Poisson parameter on the right hand side. The second is one sided, specifying the linear predictor for the probability of presence on the right hand side. The fitted values for this family will be a two column matrix. The first column is the log of the Poisson parameter, and the second column is the complimentary log log of probability of presnece.. Predictions using \code{\link{predict.gam}} will also produce 2 column matrices for \code{type} \code{"link"} and \code{"response"}. The null deviance computed for this model assumes that a single probability of presence and a single Poisson parameter are estimated. For data with large areas of covariate space over which the response is zero it may be advisable to use low order penalties to avoid problems. For 1D smooths uses e.g. \code{s(x,m=1)} and for isotropic smooths use \code{\link{Duchon.spline}}s in place of thin plaste terms with order 1 penalties, e.g \code{s(x,z,m=c(1,.5))} --- such smooths penalize towards constants, thereby avoiding extreme estimates when the data are uninformative. } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \references{ Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association 111, 1548-1575 \url{http://dx.doi.org/10.1080/01621459.2016.1180986} } \section{WARNINGS }{ Zero inflated models are often over-used. Having lots of zeroes in the data does not in itself imply zero inflation. Having too many zeroes *given the model mean* may imply zero inflation. } \examples{ library(mgcv) ## simulate some data... f0 <- function(x) 2 * sin(pi * x); f1 <- function(x) exp(2 * x) f2 <- function(x) 0.2 * x^11 * (10 * (1 - x))^6 + 10 * (10 * x)^3 * (1 - x)^10 n <- 500;set.seed(5) x0 <- runif(n); x1 <- runif(n) x2 <- runif(n); x3 <- runif(n) ## Simulate probability of potential presence... eta1 <- f0(x0) + f1(x1) - 3 p <- binomial()$linkinv(eta1) y <- as.numeric(runif(n)0 eta2 <- f2(x2[ind])/3 y[ind] <- rpois(exp(eta2),exp(eta2)) ## Fit ZIP model... b <- gam(list(y~s(x2)+s(x3),~s(x0)+s(x1)),family=ziplss()) b$outer.info ## check convergence summary(b) plot(b,pages=1) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/family.mgcv.Rd0000755000176200001440000000711713147027512014477 0ustar liggesusers\name{family.mgcv} \alias{family.mgcv} %- Also NEED an `\alias' for EACH other topic documented here. \title{Distribution families in mgcv} \description{As well as the standard families documented in \code{\link{family}} (see also \code{\link{glm}}) which can be used with functions \code{\link{gam}}, \code{\link{bam}} and \code{\link{gamm}}, \code{mgcv} also supplies some extra families, most of which are currently only usable with \code{\link{gam}}, although some can also be used with \code{\link{bam}}. These are described here. } \details{ The following families are in the exponential family given the value of a single parameter. They are usable with all modelling functions. \itemize{ \item \code{\link{Tweedie}} An exponential family distribution for which the variance of the response is given by the mean response to the power \code{p}. \code{p} is in (1,2) and must be supplied. Alternatively, see \code{\link{tw}} to estimate \code{p} (\code{gam} only). \item \code{\link{negbin}} The negative binomial. Alternatively see \code{\link{nb}} to estimate the \code{theta} parameter of the negative binomial (\code{gam} only). } The following families are for regression type models dependent on a single linear predictor, and with a log likelihood which is a sum of independent terms, each coprresponding to a single response observation. Usable with \code{\link{gam}}, with smoothing parameter estimation by \code{"REML"} or \code{"ML"} (the latter does not integrate the unpenalized and parameteric effects out of the marginal likelihood optimized for the smoothing parameters). Also usable with \code{\link{bam}}. \itemize{ \item \code{\link{ocat}} for ordered categorical data. \item \code{\link{tw}} for Tweedie distributed data, when the power parameter relating the variance to the mean is to be estimated. \item \code{\link{nb}} for negative binomial data when the \code{theta} parameter is to be estimated. \item \code{\link{betar}} for proportions data on (0,1) when the binomial is not appropriate. \item \code{\link{scat}} scaled t for heavy tailed data that would otherwise be modelled as Gaussian. \item \code{\link{ziP}} for zero inflated Poisson data, when the zero inflation rate depends simply on the Poisson mean. } %% end itemize The following families implement more general model classes. Usable only with \code{\link{gam}} and only with REML smoothing parameter estimation. \itemize{ \item \code{\link{cox.ph}} the Cox Proportional Hazards model for survival data. \item \code{\link{gaulss}} a Gaussian location-scale model where the mean and the standard deviation are both modelled using smooth linear predictors. \item \code{\link{gevlss}} a generalized extreme value (GEV) model where the location, scale and shape parameters are each modelled using a linear predictor. \item \code{\link{ziplss}} a `two-stage' zero inflated Poisson model, in which 'potential-presence' is modelled with one linear predictor, and Poisson mean abundance given potential presence is modelled with a second linear predictor. \item \code{\link{mvn}}: multivariate normal additive models. \item \code{\link{multinom}}: multinomial logistic regression, for unordered categorical responses. } %% end itemize } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood (s.wood@r-project.org) & Natalya Pya } \references{Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association 111, 1548-1575 \url{http://dx.doi.org/10.1080/01621459.2016.1180986} } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/FFdes.Rd0000755000176200001440000000237613402770537013262 0ustar liggesusers\name{FFdes} \alias{FFdes} %- Also NEED an `\alias' for EACH other topic documented here. \title{Level 5 fractional factorial designs} \description{Computes level 5 fractional factorial designs for up to 120 factors using the agorithm of Sanchez and Sanchez (2005), and optionally central composite designs. } \usage{ FFdes(size=5,ccd=FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{size}{number of factors up to 120.} \item{ccd}{if \code{TRUE}, adds points along each axis at the same distance from the origin as the points in the fractional factorial design, to create the outer points of a central composite design. Add central points to complete.} } \details{Basically a translation of the code provided in the appendix of Sanchez and Sanchez (2005). } \references{ Sanchez, S. M. & Sanchez, P. J. (2005) Very large fractional factorial and central composite designs. ACM Transactions on Modeling and Computer Simulation. 15: 362-377 } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ require(mgcv) plot(rbind(0,FFdes(2,TRUE)),xlab="x",ylab="y", col=c(2,1,1,1,1,4,4,4,4),pch=19,main="CCD") FFdes(5) FFdes(5,TRUE) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/inSide.Rd0000755000176200001440000000472313073161526013500 0ustar liggesusers\name{inSide} \alias{inSide} %- Also NEED an `\alias' for EACH other topic documented here. \title{Are points inside boundary?} \description{ Assesses whether points are inside a boundary. The boundary must enclose the domain, but may include islands. } \usage{ inSide(bnd,x,y) } %- maybe also `usage' for other objects documented here. \arguments{ \item{bnd}{This should have two equal length columns with names matching whatever is supplied in \code{x} and \code{y}. This may contain several sections of boundary separated by \code{NA}. Alternatively \code{bnd} may be a list, each element of which contains 2 columns named as above. See below for details.} \item{x}{x co-ordinates of points to be tested.} \item{y}{y co-ordinates of points to be tested.} } \details{ Segments of boundary are separated by \code{NA}s, or are in separate list elements. The boundary co-ordinates are taken to define nodes which are joined by straight line segments in order to create the boundary. Each segment is assumed to define a closed loop, and the last point in a segment will be assumed to be joined to the first. Loops must not intersect (no test is made for this). The method used is to count how many times a line, in the y-direction from a point, crosses a boundary segment. An odd number of crossings defines an interior point. Hence in geographic applications it would be usual to have an outer boundary loop, possibly with some inner `islands' completely enclosed in the outer loop. The routine calls compiled C code and operates by an exhaustive search for each point in \code{x, y}. } \value{ The function returns a logical array of the same dimension as \code{x} and \code{y}. \code{TRUE} indicates that the corresponding \code{x, y} point lies inside the boundary. } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ require(mgcv) m <- 300;n <- 150 xm <- seq(-1,4,length=m);yn<-seq(-1,1,length=n) x <- rep(xm,n);y<-rep(yn,rep(m,n)) er <- matrix(fs.test(x,y),m,n) bnd <- fs.boundary() in.bnd <- inSide(bnd,x,y) plot(x,y,col=as.numeric(in.bnd)+1,pch=".") lines(bnd$x,bnd$y,col=3) points(x,y,col=as.numeric(in.bnd)+1,pch=".") ## check boundary details ... plot(x,y,col=as.numeric(in.bnd)+1,pch=".",ylim=c(-1,0),xlim=c(3,3.5)) lines(bnd$x,bnd$y,col=3) points(x,y,col=as.numeric(in.bnd)+1,pch=".") } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/vis.gam.Rd0000755000176200001440000001312513073161526013625 0ustar liggesusers\name{vis.gam} \alias{vis.gam} \alias{persp.gam} \title{Visualization of GAM objects} \usage{ vis.gam(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,...) } \arguments{ \item{x}{a \code{gam} object, produced by \code{gam()}} \item{view}{an array containing the names of the two main effect terms to be displayed on the x and y dimensions of the plot. If omitted the first two suitable terms will be used. Note that variables coerced to factors in the model formula won't work as view variables, and \code{vis.gam} can not detect that this has happened when setting defaults. } \item{cond}{a named list of the values to use for the other predictor terms (not in \code{view}). Variables omitted from this list will have the closest observed value to the median for continuous variables, or the most commonly occuring level for factors. Parametric matrix variables have all the entries in each column set to the observed column entry closest to the column median. } \item{n.grid}{The number of grid nodes in each direction used for calculating the plotted surface.} \item{too.far}{ plot grid nodes that are too far from the points defined by the variables given in \code{view} can be excluded from the plot. \code{too.far} determines what is too far. The grid is scaled into the unit square along with the \code{view} variables and then grid nodes more than \code{too.far} from the predictor variables are excluded.} \item{col}{The colours for the facets of the plot. If this is \code{NA} then if \code{se}>0 the facets are transparent, otherwise the colour scheme specified in \code{color} is used. If \code{col} is not \code{NA} then it is used as the facet colour.} \item{color}{ the colour scheme to use for plots when \code{se}<=0. One of \code{"topo"}, \code{"heat"}, \code{"cm"}, \code{"terrain"}, \code{"gray"} or \code{"bw"}. Schemes \code{"gray"} and \code{"bw"} also modify the colors used when \code{se}>0.} \item{contour.col}{sets the colour of contours when using \code{plot.type="contour"}. Default scheme used if \code{NULL}.} \item{se}{if less than or equal to zero then only the predicted surface is plotted, but if greater than zero, then 3 surfaces are plotted, one at the predicted values minus \code{se} standard errors, one at the predicted values and one at the predicted values plus \code{se} standard errors.} \item{type}{\code{"link"} to plot on linear predictor scale and \code{"response"} to plot on the response scale.} \item{plot.type}{one of \code{"contour"} or \code{"persp"}.} \item{zlim}{a two item array giving the lower and upper limits for the z-axis scale. \code{NULL} to choose automatically.} \item{nCol}{The number of colors to use in color schemes.} \item{...}{other options to pass on to \code{\link{persp}}, \code{\link{image}} or \code{\link{contour}}. In particular \code{ticktype="detailed"} will add proper axes labelling to the plots. } } \value{Simply produces a plot.} \description{ Produces perspective or contour plot views of \code{gam} model predictions, fixing all but the values in \code{view} to the values supplied in \code{cond}. } \details{ The x and y limits are determined by the ranges of the terms named in \code{view}. If \code{se}<=0 then a single (height colour coded, by default) surface is produced, otherwise three (by default see-through) meshes are produced at mean and +/- \code{se} standard errors. Parts of the x-y plane too far from data can be excluded by setting \code{too.far} All options to the underlying graphics functions can be reset by passing them as extra arguments \code{...}: such supplied values will always over-ride the default values used by \code{vis.gam}. } \author{Simon Wood \email{simon.wood@r-project.org} Based on an original idea and design by Mike Lonergan.} \section{WARNINGS}{ The routine can not detect that a variable has been coerced to factor within a model formula, and will therefore fail if such a variable is used as a \code{view} variable. When setting default \code{view} variables it can not detect this situation either, which can cause failures if the coerced variables are the first, otherwise suitable, variables encountered. } \seealso{ \code{\link{persp}} and \code{\link{gam}}. } \examples{ library(mgcv) set.seed(0) n<-200;sig2<-4 x0 <- runif(n, 0, 1);x1 <- runif(n, 0, 1) x2 <- runif(n, 0, 1) y<-x0^2+x1*x2 +runif(n,-0.3,0.3) g<-gam(y~s(x0,x1,x2)) old.par<-par(mfrow=c(2,2)) # display the prediction surface in x0, x1 .... vis.gam(g,ticktype="detailed",color="heat",theta=-35) vis.gam(g,se=2,theta=-35) # with twice standard error surfaces vis.gam(g, view=c("x1","x2"),cond=list(x0=0.75)) # different view vis.gam(g, view=c("x1","x2"),cond=list(x0=.75),theta=210,phi=40, too.far=.07) # ..... areas where there is no data are not plotted # contour examples.... vis.gam(g, view=c("x1","x2"),plot.type="contour",color="heat") vis.gam(g, view=c("x1","x2"),plot.type="contour",color="terrain") vis.gam(g, view=c("x1","x2"),plot.type="contour",color="topo") vis.gam(g, view=c("x1","x2"),plot.type="contour",color="cm") par(old.par) # Examples with factor and "by" variables fac<-rep(1:4,20) x<-runif(80) y<-fac+2*x^2+rnorm(80)*0.1 fac<-factor(fac) b<-gam(y~fac+s(x)) vis.gam(b,theta=-35,color="heat") # factor example z<-rnorm(80)*0.4 y<-as.numeric(fac)+3*x^2*z+rnorm(80)*0.1 b<-gam(y~fac+s(x,by=z)) vis.gam(b,theta=-35,color="heat",cond=list(z=1)) # by variable example vis.gam(b,view=c("z","x"),theta= -135) # plot against by variable } \keyword{hplot} \keyword{models} \keyword{smooth} \keyword{regression} mgcv/man/Sl.setup.Rd0000644000176200001440000000415413465314724014002 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mgcvExports.R \name{Sl.setup} \alias{Sl.setup} \title{Setting up a list representing a block diagonal penalty matrix} \usage{ Sl.setup(G,cholesky=FALSE) } \arguments{ \item{G}{the output of \code{gam.setup}.} \item{cholesky}{re-parameterize using Cholesky only.} } \value{ A list with an element for each block. For block, b, \code{Sl[[b]]} is a list with the following elements \itemize{ \item{\code{repara}: should re-parameterization be applied to model matrix, etc? Usually \code{FALSE} if non-linear in coefficients.} \item{\code{start, stop}: such that \code{start:stop} are the indexes of the parameters of this block.} \item{\code{S}: a list of penalty matrices for the block (\code{dim = stop-start+1}) If \code{length(S)==1} then this will be an identity penalty. Otherwise it is a multiple penalty, and an \code{rS} list of square root penalty matrices will be added. \code{S} (if \code{repara==TRUE}) and \code{rS} (always) will be projected into range space of total penalty matrix.} \item{\code{rS}: square root of penalty matrices if multiple penalties are used.} \item{\code{D}: a reparameterization matrix for the block. Applies to cols/params in \code{start:stop}. If numeric then \code{X[,start:stop]\%*\%diag(D)} is re-parametrization of \code{X[,start:stop]}, and \code{b.orig = D*b.repara} (where \code{b.orig} is the original parameter vector). If matrix then \code{X[,start:stop]\%*\%D} is re-parametrization of \code{X[,start:stop]}, and \code{b.orig = D\%*\%b.repara} (where \code{b.orig} is the original parameter vector).} } } \description{ INTERNAL function for setting up a list representing a block diagonal penalty matrix from the object produced by \code{gam.setup}. } \author{ Simon N. Wood . } mgcv/man/gam.reparam.Rd0000644000176200001440000000320013137076643014447 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mgcvExports.R \name{gam.reparam} \alias{gam.reparam} \title{Finding stable orthogonal re-parameterization of the square root penalty.} \usage{ gam.reparam(rS, lsp, deriv) } \arguments{ \item{rS}{list of the square root penalties: last entry is root of fixed penalty, if \code{fixed.penalty==TRUE} (i.e. \code{length(rS)>length(sp)}). The assumption here is that \code{rS[[i]]} are in a null space of total penalty already; see e.g. \code{totalPenaltySpace} and \code{mini.roots}.} \item{lsp}{vector of log smoothing parameters.} \item{deriv}{if \code{deriv==1} also the first derivative of the log-determinant of the penalty matrix is returned, if \code{deriv>1} also the second derivative is returned.} } \value{ A list containing \itemize{ \item{\code{S}: the total penalty matrix similarity transformed for stability.} \item{\code{rS}: the component square roots, transformed in the same way.} \item{\code{Qs}: the orthogonal transformation matrix \code{S = t(Qs)\%*\%S0\%*\%Qs}, where \code{S0} is the untransformed total penalty implied by \code{sp} and \code{rS} on input.} \item{\code{det}: log|S|.} \item{\code{det1}: dlog|S|/dlog(sp) if \code{deriv >0}.} \item{\code{det2}: hessian of log|S| wrt log(sp) if \code{deriv>1}.} } } \description{ INTERNAL function for finding an orthogonal re-parameterization which avoids "dominant machine zero leakage" between components of the square root penalty. } \author{ Simon N. Wood . } mgcv/man/smooth.construct.mrf.smooth.spec.Rd0000755000176200001440000001626413303547351020650 0ustar liggesusers\name{smooth.construct.mrf.smooth.spec} \alias{smooth.construct.mrf.smooth.spec} \alias{Predict.matrix.mrf.smooth} \alias{mrf} %- Also NEED an `\alias' for EACH other topic documented here. \title{Markov Random Field Smooths} \description{For data observed over discrete spatial units, a simple Markov random field smoother is sometimes appropriate. These functions provide such a smoother class for \code{mgcv}. See details for how to deal with regions with missing data. } \usage{ \method{smooth.construct}{mrf.smooth.spec}(object, data, knots) \method{Predict.matrix}{mrf.smooth}(object, data) } \arguments{ \item{object}{For the \code{smooth.construct} method a smooth specification object, usually generated by a term \code{s(x,...,bs="mrf",xt=list(polys=foo))}. \code{x} is a factor variable giving labels for geographic districts, and the \code{xt} argument is obligatory: see details. For the \code{Predict.Matrix} method an object of class \code{"mrf.smooth"} produced by the \code{smooth.construct} method.} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{If there are more geographic areas than data were observed for, then this argument is used to provide the labels for all the areas (observed and unobserved). } } \value{ An object of class \code{"mrf.smooth"} or a matrix mapping the coefficients of the MRF smooth to the predictions for the areas listed in \code{data}. } \details{A Markov random field smooth over a set of discrete areas is defined using a set of area labels, and a neighbourhood structure for the areas. The covariate of the smooth is the vector of area labels corresponding to each obervation. This covariate should be a factor, or capable of being coerced to a factor. The neighbourhood structure is supplied in the \code{xt} argument to \code{s}. This must contain at least one of the elements \code{polys}, \code{nb} or \code{penalty}. \describe{ \item{polys}{contains the polygons defining the geographic areas. It is a list with as many elements as there are geographic areas. \code{names(polys)} must correspond to the levels of the argument of the smooth, in any order (i.e. it gives the area labels). \code{polys[[i]]} is a 2 column matrix the rows of which specify the vertices of the polygon(s) defining the boundary of the ith area. A boundary may be made up of several closed loops: these must be separated by \code{NA} rows. A polygon within another is treated as a hole. The first polygon in any \code{polys[[i]]} should not be a hole. An example of the structure is provided by \code{\link{columb.polys}} (which contains an artificial hole in its second element, for illustration). Any list elements with duplicate names are combined into a single NA separated matrix. Plotting of the smooth is not possible without a \code{polys} object. If \code{polys} is the only element of \code{xt} provided, then the neighbourhood structure is computed from it automatically. To count as neigbours, polygons must exactly share one of more vertices. } \item{nb}{is a named list defining the neighbourhood structure. \code{names(nb)} must correspond to the levels of the covariate of the smooth (i.e. the area labels), but can be in any order. \code{nb[[i]]} is a numeric vector indexing the neighbours of the ith area. All indices are relative to \code{nb} itself, but can be translated using \code{names(nb)}. See example code. As an alternative each \code{nb[[i]]} can be an array of the names of the neighbours, but these will be converted to the arrays of numeric indices internally. If no \code{penalty} is provided then it is computed automatically from this list. The ith row of the penalty matrix will be zero everwhere, except in the ith column, which will contain the number of neighbours of the ith geographic area, and the columns corresponding to those geographic neighbours, which will each contain -1. } \item{penalty}{ if this is supplied, then it is used as the penalty matrix. It should be positive semi-definite. Its row and column names should correspond to the levels of the covariate.} } If no basis dimension is supplied then the constructor produces a full rank MRF, with a coefficient for each geographic area. Otherwise a low rank approximation is obtained based on truncation of the parameterization given in Wood (2017) Section 5.4.2. See Wood (2017, section 5.8.1). Note that smooths of this class have a built in plot method, and that the utility function \code{\link{in.out}} can be useful for working with discrete area data. The plot method has two schemes, \code{scheme==0} is colour, \code{scheme==1} is grey scale. The situation in which there are areas with no data requires special handling. You should set \code{drop.unused.levels=FALSE} in the model fitting function, \code{\link{gam}}, \code{\link{bam}} or \code{\link{gamm}}, having first ensured that any fixed effect factors do not contain unobserved levels. Also make sure that the basis dimension is set to ensure that the total number of coefficients is less than the number of observations. } \references{ Wood S.N. (2017) Generalized additive models: an introduction with R (2nd edition). CRC. } \author{ Simon N. Wood \email{simon.wood@r-project.org} and Thomas Kneib (Fabian Scheipl prototyped the low rank MRF idea) } \seealso{\code{\link{in.out}}, \code{\link{polys.plot}}} \examples{ library(mgcv) ## Load Columbus Ohio crime data (see ?columbus for details and credits) data(columb) ## data frame data(columb.polys) ## district shapes list xt <- list(polys=columb.polys) ## neighbourhood structure info for MRF par(mfrow=c(2,2)) ## First a full rank MRF... b <- gam(crime ~ s(district,bs="mrf",xt=xt),data=columb,method="REML") plot(b,scheme=1) ## Compare to reduced rank version... b <- gam(crime ~ s(district,bs="mrf",k=20,xt=xt),data=columb,method="REML") plot(b,scheme=1) ## An important covariate added... b <- gam(crime ~ s(district,bs="mrf",k=20,xt=xt)+s(income), data=columb,method="REML") plot(b,scheme=c(0,1)) ## plot fitted values by district par(mfrow=c(1,1)) fv <- fitted(b) names(fv) <- as.character(columb$district) polys.plot(columb.polys,fv) ## Examine an example neighbourhood list - this one auto-generated from ## 'polys' above. nb <- b$smooth[[1]]$xt$nb head(nb) names(nb) ## these have to match the factor levels of the smooth ## look at the indices of the neighbours of the first entry, ## named '0'... nb[['0']] ## by name nb[[1]] ## same by index ## ... and get the names of these neighbours from their indices... names(nb)[nb[['0']]] b1 <- gam(crime ~ s(district,bs="mrf",k=20,xt=list(nb=nb))+s(income), data=columb,method="REML") b1 ## fit unchanged plot(b1) ## but now there is no information with which to plot the mrf } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/random.effects.Rd0000755000176200001440000001233013502401740015144 0ustar liggesusers\name{random.effects} \alias{random.effects} \title{Random effects in GAMs} \description{ The smooth components of GAMs can be viewed as random effects for estimation purposes. This means that more conventional random effects terms can be incorporated into GAMs in two ways. The first method converts all the smooths into fixed and random components suitable for estimation by standard mixed modelling software. Once the GAM is in this form then conventional random effects are easily added, and the whole model is estimated as a general mixed model. \code{\link{gamm}} and \code{gamm4} from the \code{gamm4} package operate in this way. The second method represents the conventional random effects in a GAM in the same way that the smooths are represented --- as penalized regression terms. This method can be used with \code{\link{gam}} by making use of \code{s(...,bs="re")} terms in a model: see \code{\link{smooth.construct.re.smooth.spec}}, for full details. The basic idea is that, e.g., \code{s(x,z,g,bs="re")} generates an i.i.d. Gaussian random effect with model matrix given by \code{model.matrix(~x:z:g-1)} --- in principle such terms can take any number of arguments. This simple approach is sufficient for implementing a wide range of commonly used random effect structures. For example if \code{g} is a factor then \code{s(g,bs="re")} produces a random coefficient for each level of \code{g}, with the random coefficients all modelled as i.i.d. normal. If \code{g} is a factor and \code{x} is numeric, then \code{s(x,g,bs="re")} produces an i.i.d. normal random slope relating the response to \code{x} for each level of \code{g}. If \code{h} is another factor then \code{s(h,g,bs="re")} produces the usual i.i.d. normal \code{g} - \code{h} interaction. Note that a rather useful approximate test for zero random effect is also implemented for such terms based on Wood (2013). If the precision matrix is known to within a multiplicative constant, then this can be supplied via the \code{xt} argument of \code{s}. See \link{smooth.construct.re.smooth.spec} for details and example. Alternatively, but less straightforwardly, the \code{paraPen} argument to \code{\link{gam}} can be used: see \code{\link{gam.models}}. If smoothing parameter estimation is by ML or REML (e.g. \code{gam(...,method="REML")}) then this approach is a completely conventional likelihood based treatment of random effects. \code{gam} can be slow for fitting models with large numbers of random effects, because it does not exploit the sparsity that is often a feature of parametric random effects. It can not be used for models with more coefficients than data. However \code{gam} is often faster and more reliable than \code{gamm} or \code{gamm4}, when the number of random effects is modest. To facilitate the use of random effects with \code{gam}, \code{\link{gam.vcomp}} is a utility routine for converting smoothing parameters to variance components. It also provides confidence intervals, if smoothness estimation is by ML or REML. Note that treating random effects as smooths does not remove the usual problems associated with testing variance components for equality to zero: see \code{\link{summary.gam}} and \code{\link{anova.gam}}. } \seealso{\code{\link{gam.vcomp}}, \code{\link{gam.models}}, \code{\link{smooth.terms}}, \code{\link{smooth.construct.re.smooth.spec}}, \code{\link{gamm}}} \author{ Simon Wood } \references{ Wood, S.N. (2013) A simple test for random effects in regression models. Biometrika 100:1005-1010 Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 Wood, S.N. (2008) Fast stable direct fitting and smoothness selection for generalized additive models. Journal of the Royal Statistical Society (B) 70(3):495-518 Wood, S.N. (2006) Low rank scale invariant tensor product smooths for generalized additive mixed models. Biometrics 62(4):1025-1036 } \examples{ ## see also examples for gam.models, gam.vcomp, gamm ## and smooth.construct.re.smooth.spec ## simple comparison of lme and gam require(mgcv) require(nlme) b0 <- lme(travel~1,data=Rail,~1|Rail,method="REML") b <- gam(travel~s(Rail,bs="re"),data=Rail,method="REML") intervals(b0) gam.vcomp(b) anova(b) plot(b) ## simulate example... dat <- gamSim(1,n=400,scale=2) ## simulate 4 term additive truth fac <- sample(1:20,400,replace=TRUE) b <- rnorm(20)*.5 dat$y <- dat$y + b[fac] dat$fac <- as.factor(fac) rm1 <- gam(y ~ s(fac,bs="re")+s(x0)+s(x1)+s(x2)+s(x3),data=dat,method="ML") gam.vcomp(rm1) fv0 <- predict(rm1,exclude="s(fac)") ## predictions setting r.e. to 0 fv1 <- predict(rm1) ## predictions setting r.e. to predicted values ## prediction setting r.e. to 0 and not having to provide 'fac'... pd <- dat; pd$fac <- NULL fv0 <- predict(rm1,pd,exclude="s(fac)",newdata.guaranteed=TRUE) ## Prediction with levels of fac not in fit data. ## The effect of the new factor levels (or any interaction involving them) ## is set to zero. xx <- seq(0,1,length=10) pd <- data.frame(x0=xx,x1=xx,x2=xx,x3=xx,fac=c(1:10,21:30)) fv <- predict(rm1,pd) pd$fac <- NULL fv0 <- predict(rm1,pd,exclude="s(fac)",newdata.guaranteed=TRUE) } \keyword{regression}mgcv/man/Predict.matrix.cr.smooth.Rd0000755000176200001440000000423513303547337017077 0ustar liggesusers\name{Predict.matrix.cr.smooth} \alias{Predict.matrix.cr.smooth} \alias{Predict.matrix.cs.smooth} \alias{Predict.matrix.cyclic.smooth} \alias{Predict.matrix.pspline.smooth} \alias{Predict.matrix.tensor.smooth} \alias{Predict.matrix.tprs.smooth} \alias{Predict.matrix.ts.smooth} \alias{Predict.matrix.t2.smooth} %- Also NEED an `\alias' for EACH other topic documented here. \title{Predict matrix method functions} \description{The various built in smooth classes for use with \code{\link{gam}} have associate \code{\link{Predict.matrix}} method functions to enable prediction from the fitted model. } \usage{ \method{Predict.matrix}{cr.smooth}(object, data) \method{Predict.matrix}{cs.smooth}(object, data) \method{Predict.matrix}{cyclic.smooth}(object, data) \method{Predict.matrix}{pspline.smooth}(object, data) \method{Predict.matrix}{tensor.smooth}(object, data) \method{Predict.matrix}{tprs.smooth}(object, data) \method{Predict.matrix}{ts.smooth}(object, data) \method{Predict.matrix}{t2.smooth}(object, data) } \arguments{ \item{object}{a smooth object, usually generated by a \code{\link{smooth.construct}} method having processed a smooth specification object generated by an \code{\link{s}} or \code{\link{te}} term in a \code{\link{gam}} formula.} \item{data}{ A data frame containing the values of the (named) covariates at which the smooth term is to be evaluated. Exact requirements are as for \code{\link{smooth.construct}} and \code{smooth.construct2}}. } \value{ A matrix mapping the coeffients for the smooth term to its values at the supplied data values. } \details{ The Predict matrix function is not normally called directly, but is rather used internally by \code{\link{predict.gam}} etc. to predict from a fitted \code{\link{gam}} model. See \code{\link{Predict.matrix}} for more details, or the specific \code{smooth.construct} pages for details on a particular smooth class. } \references{ Wood S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ ## see smooth.construct } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.tensor.smooth.spec.Rd0000755000176200001440000000401613073161530021361 0ustar liggesusers\name{smooth.construct.tensor.smooth.spec} \alias{smooth.construct.tensor.smooth.spec} %- Also NEED an `\alias' for EACH other topic documented here. \title{Tensor product smoothing constructor} \description{A special \code{smooth.construct} method function for creating tensor product smooths from any combination of single penalty marginal smooths. } \usage{ \method{smooth.construct}{tensor.smooth.spec}(object, data, knots) } \arguments{ \item{object}{a smooth specification object of class \code{tensor.smooth.spec}, usually generated by a term like \code{te(x,z)} in a \code{\link{gam}} model formula} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}. See details for further information.} } \value{ An object of class \code{"tensor.smooth"}. See \code{\link{smooth.construct}}, for the elements that this object will contain. } \details{Tensor product smooths are smooths of several variables which allow the degree of smoothing to be different with respect to different variables. They are useful as smooth interaction terms, as they are invariant to linear rescaling of the covariates, which means, for example, that they are insensitive to the measurement units of the different covariates. They are also useful whenever isotropic smoothing is inappropriate. See \code{\link{te}}, \code{\link{smooth.construct}} and \code{\link{smooth.terms}}. } \references{ Wood, S.N. (2006) Low rank scale invariant tensor product smooths for generalized additive mixed models. Biometrics 62(4):1025-1036 } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{cSplineDes}}} \examples{ ## see ?gam } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/bam.Rd0000755000176200001440000005066113435736437013041 0ustar liggesusers\name{bam} \alias{bam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generalized additive models for very large datasets} \description{ Fits a generalized additive model (GAM) to a very large data set, the term `GAM' being taken to include any quadratically penalized GLM (the extended families listed in \code{\link{family.mgcv}} can also be used). The degree of smoothness of model terms is estimated as part of fitting. In use the function is much like \code{\link{gam}}, except that the numerical methods are designed for datasets containing upwards of several tens of thousands of data (see Wood, Goude and Shaw, 2015). The advantage of \code{bam} is much lower memory footprint than \code{\link{gam}}, but it can also be much faster, for large datasets. \code{bam} can also compute on a cluster set up by the \link[parallel]{parallel} package. An alternative fitting approach (Wood et al. 2017, Li and Wood, 2019) is provided by the \code{discrete==TRUE} method. In this case a method based on discretization of covariate values and C code level parallelization (controlled by the \code{nthreads} argument instead of the \code{cluster} argument) is used. This extends both the data set and model size that are practical. } \usage{ bam(formula,family=gaussian(),data=list(),weights=NULL,subset=NULL, na.action=na.omit, offset=NULL,method="fREML",control=list(), select=FALSE,scale=0,gamma=1,knots=NULL,sp=NULL,min.sp=NULL, paraPen=NULL,chunk.size=10000,rho=0,AR.start=NULL,discrete=FALSE, cluster=NULL,nthreads=1,gc.level=1,use.chol=FALSE,samfrac=1, coef=NULL,drop.unused.levels=TRUE,G=NULL,fit=TRUE,drop.intercept=NULL,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{formula}{ A GAM formula (see \code{\link{formula.gam}} and also \code{\link{gam.models}}). This is exactly like the formula for a GLM except that smooth terms, \code{s} and \code{te} can be added to the right hand side to specify that the linear predictor depends on smooth functions of predictors (or linear functionals of these). } \item{family}{ This is a family object specifying the distribution and link to use in fitting etc. See \code{\link{glm}} and \code{\link{family}} for more details. The extended families listed in \code{\link{family.mgcv}} can also be used. } \item{data}{ A data frame or list containing the model response variable and covariates required by the formula. By default the variables are taken from \code{environment(formula)}: typically the environment from which \code{gam} is called.} \item{weights}{ prior weights on the contribution of the data to the log likelihood. Note that a weight of 2, for example, is equivalent to having made exactly the same observation twice. If you want to reweight the contributions of each datum without changing the overall magnitude of the log likelihood, then you should normalize the weights (e.g. \code{weights <- weights/mean(weights)}).} \item{subset}{ an optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{ a function which indicates what should happen when the data contain `NA's. The default is set by the `na.action' setting of `options', and is `na.fail' if that is unset. The ``factory-fresh'' default is `na.omit'.} \item{offset}{Can be used to supply a model offset for use in fitting. Note that this offset will always be completely ignored when predicting, unlike an offset included in \code{formula} (this used to conform to the behaviour of \code{lm} and \code{glm}).} \item{method}{The smoothing parameter estimation method. \code{"GCV.Cp"} to use GCV for unknown scale parameter and Mallows' Cp/UBRE/AIC for known scale. \code{"GACV.Cp"} is equivalent, but using GACV in place of GCV. \code{"REML"} for REML estimation, including of unknown scale, \code{"P-REML"} for REML estimation, but using a Pearson estimate of the scale. \code{"ML"} and \code{"P-ML"} are similar, but using maximum likelihood in place of REML. Default \code{"fREML"} uses fast REML computation.} \item{control}{A list of fit control parameters to replace defaults returned by \code{\link{gam.control}}. Any control parameters not supplied stay at their default values.} \item{select}{Should selection penalties be added to the smooth effects, so that they can in principle be penalized out of the model? See \code{gamma} to increase penalization. Has the side effect that smooths no longer have a fixed effect component (improper prior from a Bayesian perspective) allowing REML comparison of models with the same fixed effect structure. } \item{scale}{ If this is positive then it is taken as the known scale parameter. Negative signals that the scale paraemter is unknown. 0 signals that the scale parameter is 1 for Poisson and binomial and unknown otherwise. Note that (RE)ML methods can only work with scale parameter 1 for the Poisson and binomial cases. } \item{gamma}{Increase above 1 to force smoother fits. \code{gamma} is used to multiply the effective degrees of freedom in the GCV/UBRE/AIC score (so \code{log(n)/2} is BIC like). \code{n/gamma} can be viewed as an effective sample size, which allows it to play a similar role for RE/ML smoothing parameter estimation.} \item{knots}{this is an optional list containing user specified knot values to be used for basis construction. For most bases the user simply supplies the knots to be used, which must match up with the \code{k} value supplied (note that the number of knots is not always just \code{k}). See \code{\link{tprs}} for what happens in the \code{"tp"/"ts"} case. Different terms can use different numbers of knots, unless they share a covariate. } \item{sp}{A vector of smoothing parameters can be provided here. Smoothing parameters must be supplied in the order that the smooth terms appear in the model formula. Negative elements indicate that the parameter should be estimated, and hence a mixture of fixed and estimated parameters is possible. If smooths share smoothing parameters then \code{length(sp)} must correspond to the number of underlying smoothing parameters.} \item{min.sp}{Lower bounds can be supplied for the smoothing parameters. Note that if this option is used then the smoothing parameters \code{full.sp}, in the returned object, will need to be added to what is supplied here to get the smoothing parameters actually multiplying the penalties. \code{length(min.sp)} should always be the same as the total number of penalties (so it may be longer than \code{sp}, if smooths share smoothing parameters).} \item{paraPen}{optional list specifying any penalties to be applied to parametric model terms. \code{\link{gam.models}} explains more.} \item{chunk.size}{The model matrix is created in chunks of this size, rather than ever being formed whole. Reset to \code{4*p} if \code{chunk.size < 4*p} where \code{p} is the number of coefficients.} \item{rho}{An AR1 error model can be used for the residuals (based on dataframe order), of Gaussian-identity link models. This is the AR1 correlation parameter. Standardized residuals (approximately uncorrelated under correct model) returned in \code{std.rsd} if non zero. Also usable with other models when \code{discrete=TRUE}, in which case the AR model is applied to the working residuals and corresponds to a GEE approximation.} \item{AR.start}{logical variable of same length as data, \code{TRUE} at first observation of an independent section of AR1 correlation. Very first observation in data frame does not need this. If \code{NULL} then there are no breaks in AR1 correlaion.} \item{discrete}{with \code{method="fREML"} it is possible to discretize covariates for storage and efficiency reasons. If \code{discrete} is \code{TRUE}, a number or a vector of numbers for each smoother term, then discretization happens. If numbers are supplied they give the number of discretization bins.} \item{cluster}{\code{bam} can compute the computationally dominant QR decomposition in parallel using \link[parallel]{parLapply} from the \code{parallel} package, if it is supplied with a cluster on which to do this (a cluster here can be some cores of a single machine). See details and example code. } \item{nthreads}{Number of threads to use for non-cluster computation (e.g. combining results from cluster nodes). If \code{NA} set to \code{max(1,length(cluster))}. See details.} \item{gc.level}{to keep the memory footprint down, it helps to call the garbage collector often, but this takes a substatial amount of time. Setting this to zero means that garbage collection only happens when R decides it should. Setting to 2 gives frequent garbage collection. 1 is in between.} \item{use.chol}{By default \code{bam} uses a very stable QR update approach to obtaining the QR decomposition of the model matrix. For well conditioned models an alternative accumulates the crossproduct of the model matrix and then finds its Choleski decomposition, at the end. This is somewhat more efficient, computationally.} \item{samfrac}{For very large sample size Generalized additive models the number of iterations needed for the model fit can be reduced by first fitting a model to a random sample of the data, and using the results to supply starting values. This initial fit is run with sloppy convergence tolerances, so is typically very low cost. \code{samfrac} is the sampling fraction to use. 0.1 is often reasonable. } \item{coef}{initial values for model coefficients} \item{drop.unused.levels}{by default unused levels are dropped from factors before fitting. For some smooths involving factor variables you might want to turn this off. Only do so if you know what you are doing.} \item{G}{if not \code{NULL} then this should be the object returned by a previous call to \code{bam} with \code{fit=FALSE}. Causes all other arguments to be ignored except \code{sp}, \code{chunk.size}, \code{gamma},\code{nthreads}, \code{cluster}, \code{rho}, \code{gc.level}, \code{samfrac}, \code{use.chol}, \code{method} and \code{scale} (if >0).} \item{fit}{if \code{FALSE} then the model is set up for fitting but not estimated, and an object is returned, suitable for passing as the \code{G} argument to \code{bam}.} \item{drop.intercept}{Set to \code{TRUE} to force the model to really not have the a constant in the parametric model part, even with factor variables present.} \item{...}{further arguments for passing on e.g. to \code{gam.fit} (such as \code{mustart}). } } \value{ An object of class \code{"gam"} as described in \code{\link{gamObject}}. } \details{ When \code{discrete=FALSE}, \code{bam} operates by first setting up the basis characteristics for the smooths, using a representative subsample of the data. Then the model matrix is constructed in blocks using \code{\link{predict.gam}}. For each block the factor R, from the QR decomposition of the whole model matrix is updated, along with Q'y. and the sum of squares of y. At the end of block processing, fitting takes place, without the need to ever form the whole model matrix. In the generalized case, the same trick is used with the weighted model matrix and weighted pseudodata, at each step of the PIRLS. Smoothness selection is performed on the working model at each stage (performance oriented iteration), to maintain the small memory footprint. This is trivial to justify in the case of GCV or Cp/UBRE/AIC based model selection, and for REML/ML is justified via the asymptotic multivariate normality of Q'z where z is the IRLS pseudodata. For full method details see Wood, Goude and Shaw (2015). Note that POI is not as stable as the default nested iteration used with \code{\link{gam}}, but that for very large, information rich, datasets, this is unlikely to matter much. Note also that it is possible to spend most of the computational time on basis evaluation, if an expensive basis is used. In practice this means that the default \code{"tp"} basis should be avoided: almost any other basis (e.g. \code{"cr"} or \code{"ps"}) can be used in the 1D case, and tensor product smooths (\code{te}) are typically much less costly in the multi-dimensional case. If \code{cluster} is provided as a cluster set up using \code{\link[parallel]{makeCluster}} (or \code{\link[parallel]{makeForkCluster}}) from the \code{parallel} package, then the rate limiting QR decomposition of the model matrix is performed in parallel using this cluster. Note that the speed ups are often not that great. On a multi-core machine it is usually best to set the cluster size to the number of physical cores, which is often less than what is reported by \code{\link[parallel]{detectCores}}. Using more than the number of physical cores can result in no speed up at all (or even a slow down). Note that a highly parallel BLAS may negate all advantage from using a cluster of cores. Computing in parallel of course requires more memory than computing in series. See examples. When \code{discrete=TRUE} the covariate data are first discretized. Discretization takes place on a smooth by smooth basis, or in the case of tensor product smooths (or any smooth that can be represented as such, such as random effects), separately for each marginal smooth. The required spline bases are then evaluated at the discrete values, and stored, along with index vectors indicating which original observation they relate to. Fitting is by a version of performance oriented iteration/PQL using REML smoothing parameter selection on each iterative working model (as for the default method). The iteration is based on the derivatives of the REML score, without computing the score itself, allowing the expensive computations to be reduced to one parallel block Cholesky decomposition per iteration (plus two basic operations of equal cost, but easily parallelized). Unlike standard POI/PQL, only one step of the smoothing parameter update for the working model is taken at each step (rather than iterating to the optimal set of smoothing parameters for each working model). At each step a weighted model matrix crossproduct of the model matrix is required - this is efficiently computed from the pre-computed basis functions evaluated at the discretized covariate values. Efficient computation with tensor product terms means that some terms within a tensor product may be re-ordered for maximum efficiency. See Wood et al (2017) and Li and Wood (2019) for full details. When \code{discrete=TRUE} parallel computation is controlled using the \code{nthreads} argument. For this method no cluster computation is used, and the \code{parallel} package is not required. Note that actual speed up from parallelization depends on the BLAS installed and your hardware. With the (R default) reference BLAS using several threads can make a substantial difference, but with a single threaded tuned BLAS, such as openblas, the effect is less marked (since cache use is typically optimized for one thread, and is then sub optimal for several). However the tuned BLAS is usually much faster than using the reference BLAS, however many threads you use. If you have a multi-threaded BLAS installed then you should leave \code{nthreads} at 1, since calling a multi-threaded BLAS from multiple threads usually slows things down: the only exception to this is that you might choose to form discrete matrix cross products (the main cost in the fitting routine) in a multi-threaded way, but use single threaded code for other computations: this can be achieved by e.g. \code{nthreads=c(2,1)}, which would use 2 threads for discrete inner products, and 1 for most code calling BLAS. Not that the basic reason that multi-threaded performance is often disappointing is that most computers are heavily memory bandwidth limited, not flop rate limited. It is hard to get data to one core fast enough, let alone trying to get data simultaneously to several cores. \code{discrete=TRUE} will often produce identical results to the methods without discretization, since covariates often only take a modest number of discrete values anyway, so no approximation at all is involved in the discretization process. Even when some approximation is involved, the differences are often very small as the algorithms discretize marginally whenever possible. For example each margin of a tensor product smooth is discretized separately, rather than discretizing onto a grid of covariate values (for an equivalent isotropic smooth we would have to discretize onto a grid). The marginal approach allows quite fine scale discretization and hence very low approximation error. Note that when using the smooth \code{id} mechanism to link smoothing parameters, the discrete method cannot force the linked bases to be identical, so some differences to the none discrete methods will be noticable. The extended families given in \code{\link{family.mgcv}} can also be used. The extra parameters of these are estimated by maximizing the penalized likelihood, rather than the restricted marginal likelihood as in \code{\link{gam}}. So estimates may differ slightly from those returned by \code{\link{gam}}. Estimation is accomplished by a Newton iteration to find the extra parameters (e.g. the theta parameter of the negative binomial or the degrees of freedom and scale of the scaled t) maximizing the log likelihood given the model coefficients at each iteration of the fitting procedure. } \references{ Wood, S.N., Goude, Y. & Shaw S. (2015) Generalized additive models for large datasets. Journal of the Royal Statistical Society, Series C 64(1): 139-155. \url{http://dx.doi.org/10.1111/rssc.12068} Wood, S.N., Li, Z., Shaddick, G. & Augustin N.H. (2017) Generalized additive models for gigadata: modelling the UK black smoke network daily data. Journal of the American Statistical Association. 112(519):1199-1210 \url{http://dx.doi.org/10.1080/01621459.2016.1195744} Li, Z & S.N. Wood (2019) Faster model matrix crossproducts for large generalized linear models with discretized covariates. Statistics and Computing. \url{https://doi.org/10.1007/s11222-019-09864-2} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \section{WARNINGS }{ The routine will be slow if the default \code{"tp"} basis is used. Unless discrete=TRUE, you must have more unique combinations of covariates than the model has total parameters. (Total parameters is sum of basis dimensions plus sum of non-spline terms less the number of spline terms). This routine is less stable than `gam' for the same dataset. With \code{discrete=TRUE}, \code{te} terms are efficiently computed, but \code{t2} are not. The negbin family is only supported for the *known theta* case. } \seealso{\code{\link{mgcv.parallel}}, \code{\link{mgcv-package}}, \code{\link{gamObject}}, \code{\link{gam.models}}, \code{\link{smooth.terms}}, \code{\link{linear.functional.terms}}, \code{\link{s}}, \code{\link{te}} \code{\link{predict.gam}}, \code{\link{plot.gam}}, \code{\link{summary.gam}}, \code{\link{gam.side}}, \code{\link{gam.selection}}, \code{\link{gam.control}} \code{\link{gam.check}}, \code{\link{linear.functional.terms}} \code{\link{negbin}}, \code{\link{magic}},\code{\link{vis.gam}} } \examples{ library(mgcv) ## See help("mgcv-parallel") for using bam in parallel ## Sample sizes are small for fast run times. set.seed(3) dat <- gamSim(1,n=25000,dist="normal",scale=20) bs <- "cr";k <- 12 b <- bam(y ~ s(x0,bs=bs)+s(x1,bs=bs)+s(x2,bs=bs,k=k)+ s(x3,bs=bs),data=dat) summary(b) plot(b,pages=1,rug=FALSE) ## plot smooths, but not rug plot(b,pages=1,rug=FALSE,seWithMean=TRUE) ## `with intercept' CIs \donttest{ ba <- bam(y ~ s(x0,bs=bs,k=k)+s(x1,bs=bs,k=k)+s(x2,bs=bs,k=k)+ s(x3,bs=bs,k=k),data=dat,method="GCV.Cp") ## use GCV summary(ba)} ## A Poisson example... k <- 15 dat <- gamSim(1,n=21000,dist="poisson",scale=.1) system.time(b1 <- bam(y ~ s(x0,bs=bs)+s(x1,bs=bs)+s(x2,bs=bs,k=k), data=dat,family=poisson())) b1 ## Similar using faster discrete method... \donttest{ system.time(b2 <- bam(y ~ s(x0,bs=bs,k=k)+s(x1,bs=bs,k=k)+s(x2,bs=bs,k=k)+ s(x3,bs=bs,k=k),data=dat,family=poisson(),discrete=TRUE)) b2 } } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. \concept{Varying coefficient model} \concept{Functional linear model} \concept{Penalized GLM} \concept{Generalized Additive Model} \concept{Penalized regression} \concept{Spline smoothing} \concept{Penalized regression spline} \concept{Generalized Cross Validation} \concept{Smoothing parameter selection} \concept{tensor product smoothing} \concept{thin plate spline} \concept{P-spline} \concept{Generalized ridge regression} mgcv/man/rmvn.Rd0000755000176200001440000000236613303547351013250 0ustar liggesusers\name{rmvn} \alias{rmvn} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generate multivariate normal deviates} \description{ Generates multivariate normal random deviates. } \usage{ rmvn(n,mu,V) } \arguments{ \item{n}{number of simulated vectors required.} \item{mu}{the mean of the vectors: either a single vector of length \code{p=ncol(V)} or an \code{n} by \code{p} matrix.} \item{V}{A positive semi definite covariance matrix.} } \value{ An \code{n} row matrix, with each row being a draw from a multivariate normal density with covariance matrix \code{V} and mean vector \code{mu}. Alternatively each row may have a different mean vector if \code{mu} is a vector. } \details{Uses a `square root' of \code{V} to transform standard normal deviates to multivariate normal with the correct covariance matrix. } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood \email{simon.wood@r-project.org} } \seealso{\code{\link{ldTweedie}}, \code{\link{Tweedie}}} \examples{ library(mgcv) V <- matrix(c(2,1,1,2),2,2) mu <- c(1,3) n <- 1000 z <- rmvn(n,mu,V) crossprod(sweep(z,2,colMeans(z)))/n ## observed covariance matrix colMeans(z) ## observed mu } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.Rd0000755000176200001440000003463313433456434015631 0ustar liggesusers \name{smooth.construct} \alias{smooth.construct} \alias{smooth.construct2} \alias{user.defined.smooth} %- Also NEED an `\alias' for EACH other topic documented here. \title{Constructor functions for smooth terms in a GAM} \description{Smooth terms in a GAM formula are turned into smooth specification objects of class \code{xx.smooth.spec} during processing of the formula. Each of these objects is converted to a smooth object using an appropriate \code{smooth.construct} function. New smooth classes can be added by writing a new \code{smooth.construct} method function and a corresponding \code{\link{Predict.matrix}} method function (see example code below). In practice, \code{smooth.construct} is usually called via \code{smooth.construct2} and the wrapper function \code{\link{smoothCon}}, in order to handle \code{by} variables and centering constraints (see the \code{\link{smoothCon}} documentation if you need to handle these things directly, for a user defined smooth class). } \usage{ smooth.construct(object,data,knots) smooth.construct2(object,data,knots) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ is a smooth specification object, generated by an \code{\link{s}} or \code{\link{te}} term in a GAM formula. Objects generated by \code{s} terms have class \code{xx.smooth.spec} where \code{xx} is given by the \code{bs} argument of \code{s} (this convention allows the user to add their own smoothers). If \code{object} is not class \code{tensor.smooth.spec} it will have the following elements: \describe{ \item{term}{The names of the covariates for this smooth, in an array.} \item{bs.dim}{ Argument \code{k} of the \code{s} term generating the object. This is the dimension of the basis used to represent the term (or, arguably, 1 greater than the basis dimension for \code{cc} terms). \code{bs.dim<0} indicates that the constructor should set this to the default value.} \item{fixed}{\code{TRUE} if the term is to be unpenalized, otherwise \code{FALSE}.} \item{dim}{the number covariates of which this smooth is a function.} \item{p.order}{the order of the smoothness penalty or \code{NA} for autoselection of this. This is argument \code{m} of the \code{s} term that generated \code{object}.} \item{by}{the name of any \code{by} variable to multiply this term as supplied as an argument to \code{s}. \code{"NA"} if there is no such term.} \item{label}{A suitable label for use with this term.} \item{xt}{An object containing information that may be needed for basis setup (used, e.g. by \code{"tp"} smooths to pass optional information on big dataset handling).} \item{id}{Any identity associated with this term --- used for linking bases and smoothing parameters. \code{NULL} by default, indicating no linkage.} \item{sp}{Smoothing parameters for the term. Any negative are estimated, otherwise they are fixed at the supplied value. Unless \code{NULL} (default), over-rides \code{sp} argument to \code{\link{gam}}.} } If \code{object} is of class \code{tensor.smooth.spec} then it was generated by a \code{te} term in the GAM formula, and specifies a smooth of several variables with a basis generated as a tensor product of lower dimensional bases. In this case the object will be different and will have the following elements: \describe{ \item{margin}{is a list of smooth specification objects of the type listed above, defining the bases which have their tensor product formed in order to construct this term.} \item{term}{is the array of names of the covariates that are arguments of the smooth.} \item{by}{is the name of any \code{by} variable, or \code{"NA"}.} \item{fx}{is an array, the elements of which indicate whether (\code{TRUE}) any of the margins in the tensor product should be unpenalized.} \item{label}{A suitable label for use with this term.} \item{dim}{is the number of covariates of which this smooth is a function.} \item{mp}{\code{TRUE} if multiple penalties are to be used.} \item{np}{\code{TRUE} if 1-D marginal smooths are to be re-parameterized in terms of function values.} \item{id}{Any identity associated with this term --- used for linking bases and smoothing parameters. \code{NULL} by default, indicating no linkage.} \item{sp}{Smoothing parameters for the term. Any negative are estimated, otherwise they are fixed at the supplied value. Unless \code{NULL} (default), over-rides \code{sp} argument to \code{\link{gam}}.} }} \item{data}{For \code{smooth.construct} a data frame or list containing the evaluation of the elements of \code{object$term}, with names given by \code{object$term}. The last entry will be the \code{by} variable, if \code{object$by} is not \code{"NA"}. For \code{smooth.construct2} \code{data} need only be an object within which \code{object$term} can be evaluated, the variables can be in any order, and there can be irrelevant variables present as well. } \item{knots}{an optional data frame or list containing the knots relating to \code{object$term}. If it is \code{NULL} then the knot locations are generated automatically. The structure of \code{knots} should be as for \code{data}, depending on whether \code{smooth.construct} or \code{smooth.construct2} is used.} } \value{ The input argument \code{object}, assigned a new class to indicate what type of smooth it is and with at least the following items added: \item{X}{The model matrix from this term. This may have an \code{"offset"} attribute: a vector of length \code{nrow(X)} containing any contribution of the smooth to the model offset term. \code{by} variables do not need to be dealt with here, but if they are then an item \code{by.done} must be added to the \code{object}.} \item{S}{A list of positive semi-definite penalty matrices that apply to this term. The list will be empty if the term is to be left un-penalized.} \item{rank}{An array giving the ranks of the penalties.} \item{null.space.dim}{The dimension of the penalty null space (before centering).} The following items may be added: \item{C}{The matrix defining any identifiability constraints on the term, for use when fitting. If this is \code{NULL} then \code{smoothCon} will add an identifiability constraint that each term should sum to zero over the covariate values. Set to a zero row matrix if no constraints are required. If a supplied \code{C} has an attribute \code{"always.apply"} then it is never ignored, even if any \code{by} variables of a smooth imply that no constraint is actually needed. Code for creating \code{C} should check whether the specification object already contains a zero row matrix, and leave this unchanged if it is (since this signifies no constraint should be produced). } \item{Cp}{An optional matrix supplying alternative identifiability constraints for use when predicting. By default the fitting constrants are used. This option is useful when some sort of simple sparse constraint is required for fitting, but the usual sum-to-zero constraint is required for prediction so that, e.g. the CIs for model components are as narrow as possible. } \item{no.rescale}{if this is non-NULL then the penalty coefficient matrix of the smooth will not be rescaled for enhaced numerical stability (rescaling is the default, because \code{\link{gamm}} requires it). Turning off rescaling is useful if the values of the smoothing parameters should be interpretable in a model, for example because they are inverse variance components. } \item{df}{the degrees of freedom associated with this term (when unpenalized and unconstrained). If this is null then \code{smoothCon} will set it to the basis dimension. \code{smoothCon} will reduce this by the number of constraints.} \item{te.ok}{\code{0} if this term should not be used as a tensor product marginal, \code{1} if it can be used and plotted, and \code{2} is it can be used but not plotted. Set to \code{1} if \code{NULL}.} \item{plot.me}{Set to \code{FALSE} if this smooth should not be plotted by \code{\link{plot.gam}}. Set to \code{TRUE} if \code{NULL}.} \item{side.constrain}{Set to \code{FALSE} to ensure that the smooth is never subject to side constraints as a result of nesting. } \item{L}{smooths may depend on fewer `underlying' smoothing parameters than there are elements of \code{S}. In this case \code{L} is the matrix mapping the vector of underlying log smoothing parameters to the vector of logs of the smoothing parameters actually multiplying the \code{S[[i]]}. \code{L=NULL} signifies that there is one smoothing parameter per \code{S[[i]]}. } Usually the returned object will also include extra information required to define the basis, and used by \code{\link{Predict.matrix}} methods to make predictions using the basis. See the \code{Details} section for links to the information included for the built in smooth classes. \code{tensor.smooth} returned objects will additionally have each element of the \code{margin} list updated in the same way. \code{tensor.smooths} also have a list, \code{XP}, containing re-parameterization matrices for any 1-D marginal terms re-parameterized in terms of function values. This list will have \code{NULL} entries for marginal smooths that are not re-parameterized, and is only long enough to reach the last re-parameterized marginal in the list. } \details{ There are built in methods for objects with the following classes: \code{tp.smooth.spec} (thin plate regression splines: see \code{\link{tprs}}); \code{ts.smooth.spec} (thin plate regression splines with shrinkage-to-zero); \code{cr.smooth.spec} (cubic regression splines: see \code{\link{cubic.regression.spline}}; \code{cs.smooth.spec} (cubic regression splines with shrinkage-to-zero); \code{cc.smooth.spec} (cyclic cubic regression splines); \code{ps.smooth.spec} (Eilers and Marx (1986) style P-splines: see \code{\link{p.spline}}); \code{cp.smooth.spec} (cyclic P-splines); \code{ad.smooth.spec} (adaptive smooths of 1 or 2 variables: see \code{\link{adaptive.smooth}}); \code{re.smooth.spec} (simple random effect terms); \code{mrf.smooth.spec} (Markov random field smoothers for smoothing over discrete districts); \code{tensor.smooth.spec} (tensor product smooths). There is an implicit assumption that the basis only depends on the knots and/or the set of unique covariate combinations; i.e. that the basis is the same whether generated from the full set of covariates, or just the unique combinations of covariates. Plotting of smooths is handled by plot methods for smooth objects. A default \code{mgcv.smooth} method is used if there is no more specific method available. Plot methods can be added for specific smooth classes, see source code for \code{mgcv:::plot.sos.smooth}, \code{mgcv:::plot.random.effect}, \code{mgcv:::plot.mgcv.smooth} for example code. } \references{ Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 Wood, S.N. (2006) Low rank scale invariant tensor product smooths for generalized additive mixed models. Biometrics 62(4):1025-1036 The code given in the example is based on the smooths advocated in: Ruppert, D., M.P. Wand and R.J. Carroll (2003) Semiparametric Regression. Cambridge University Press. However if you want p-splines, rather than splines with derivative based penalties, then the built in "ps" class is probably a marginally better bet. It's based on Eilers, P.H.C. and B.D. Marx (1996) Flexible Smoothing with B-splines and Penalties. Statistical Science, 11(2):89-121 \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{s}},\code{\link{get.var}}, \code{\link{gamm}}, \code{\link{gam}}, \code{\link{Predict.matrix}}, \code{\link{smoothCon}}, \code{\link{PredictMat}} } \section{WARNING}{User defined smooth objects should avoid having attributes names \code{"qrc"} or \code{"nCons"} as these are used internally to provide constraint free parameterizations.} \examples{ ## Adding a penalized truncated power basis class and methods ## as favoured by Ruppert, Wand and Carroll (2003) ## Semiparametric regression CUP. (No advantage to actually ## using this, since mgcv can happily handle non-identity ## penalties.) smooth.construct.tr.smooth.spec<-function(object,data,knots) { ## a truncated power spline constructor method function ## object$p.order = null space dimension m <- object$p.order[1] if (is.na(m)) m <- 2 ## default if (m<1) stop("silly m supplied") if (object$bs.dim<0) object$bs.dim <- 10 ## default nk<-object$bs.dim-m-1 ## number of knots if (nk<=0) stop("k too small for m") x <- data[[object$term]] ## the data x.shift <- mean(x) # shift used to enhance stability k <- knots[[object$term]] ## will be NULL if none supplied if (is.null(k)) # space knots through data { n<-length(x) k<-quantile(x[2:(n-1)],seq(0,1,length=nk+2))[2:(nk+1)] } if (length(k)!=nk) # right number of knots? stop(paste("there should be ",nk," supplied knots")) x <- x - x.shift # basis stabilizing shift k <- k - x.shift # knots treated the same! X<-matrix(0,length(x),object$bs.dim) for (i in 1:(m+1)) X[,i] <- x^(i-1) for (i in 1:nk) X[,i+m+1]<-(x-k[i])^m*as.numeric(x>k[i]) object$X<-X # the finished model matrix if (!object$fixed) # create the penalty matrix { object$S[[1]]<-diag(c(rep(0,m+1),rep(1,nk))) } object$rank<-nk # penalty rank object$null.space.dim <- m+1 # dim. of unpenalized space ## store "tr" specific stuff ... object$knots<-k;object$m<-m;object$x.shift <- x.shift object$df<-ncol(object$X) # maximum DoF (if unconstrained) class(object)<-"tr.smooth" # Give object a class object } Predict.matrix.tr.smooth<-function(object,data) { ## prediction method function for the `tr' smooth class x <- data[[object$term]] x <- x - object$x.shift # stabilizing shift m <- object$m; # spline order (3=cubic) k<-object$knots # knot locations nk<-length(k) # number of knots X<-matrix(0,length(x),object$bs.dim) for (i in 1:(m+1)) X[,i] <- x^(i-1) for (i in 1:nk) X[,i+m+1] <- (x-k[i])^m*as.numeric(x>k[i]) X # return the prediction matrix } # an example, using the new class.... require(mgcv) set.seed(100) dat <- gamSim(1,n=400,scale=2) b<-gam(y~s(x0,bs="tr",m=2)+s(x1,bs="ps",m=c(1,3))+ s(x2,bs="tr",m=3)+s(x3,bs="tr",m=2),data=dat) plot(b,pages=1) b<-gamm(y~s(x0,bs="tr",m=2)+s(x1,bs="ps",m=c(1,3))+ s(x2,bs="tr",m=3)+s(x3,bs="tr",m=2),data=dat) plot(b$gam,pages=1) # another example using tensor products of the new class dat <- gamSim(2,n=400,scale=.1)$data b <- gam(y~te(x,z,bs=c("tr","tr"),m=c(2,2)),data=dat) vis.gam(b) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/Predict.matrix.Rd0000755000176200001440000000515513303547337015166 0ustar liggesusers\name{Predict.matrix} \alias{Predict.matrix} \alias{Predict.matrix2} %- Also NEED an `\alias' for EACH other topic documented here. \title{Prediction methods for smooth terms in a GAM} \description{ Takes \code{smooth} objects produced by \code{smooth.construct} methods and obtains the matrix mapping the parameters associated with such a smooth to the predicted values of the smooth at a set of new covariate values. In practice this method is often called via the wrapper function \code{\link{PredictMat}}. } \usage{ Predict.matrix(object,data) Predict.matrix2(object,data) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ is a smooth object produced by a \code{smooth.construct} method function. The object contains all the information required to specify the basis for a term of its class, and this information is used by the appropriate \code{Predict.matrix} function to produce a prediction matrix for new covariate values. Further details are given in \code{\link{smooth.construct}}.} \item{data}{A data frame containing the values of the (named) covariates at which the smooth term is to be evaluated. Exact requirements are as for \code{\link{smooth.construct}} and \code{smooth.construct2}}. } \value{ A matrix which will map the parameters associated with the smooth to the vector of values of the smooth evaluated at the covariate values given in \code{object}. If the smooth class is one which generates offsets the corresponding offset is returned as attribute \code{"offset"} of the matrix.} \details{ Smooth terms in a GAM formula are turned into smooth specification objects of class \code{xx.smooth.spec} during processing of the formula. Each of these objects is converted to a smooth object using an appropriate \code{smooth.construct} function. The \code{Predict.matrix} functions are used to obtain the matrix that will map the parameters associated with a smooth term to the predicted values for the term at new covariate values. Note that new smooth classes can be added by writing a new \code{smooth.construct} method function and a corresponding \code{\link{Predict.matrix}} method function: see the example code provided for \code{\link{smooth.construct}} for details.} \references{ Wood S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC Press. } \author{Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gam}},\code{\link{gamm}}, \code{\link{smooth.construct}}, \code{\link{PredictMat}} } \examples{# See smooth.construct examples } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/step.gam.Rd0000755000176200001440000000642313073161526014002 0ustar liggesusers\name{step.gam} \alias{step.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Alternatives to step.gam} \description{ There is no \code{step.gam} in package \code{mgcv}. The \code{mgcv} default for model selection is to use either prediction error criteria such as GCV, GACV, Mallows' Cp/AIC/UBRE or the likelihood based methods of REML or ML. Since the smoothness estimation part of model selection is done in this way it is logically most consistent to perform the rest of model selection in the same way. i.e. to decide which terms to include or omit by looking at changes in GCV, AIC, REML etc. To facilitate fully automatic model selection the package implements two smooth modification techniques which can be used to allow smooths to be shrunk to zero as part of smoothness selection. \describe{ \item{Shrinkage smoothers}{are smoothers in which a small multiple of the identity matrix is added to the smoothing penalty, so that strong enough penalization will shrink all the coefficients of the smooth to zero. Such smoothers can effectively be penalized out of the model altogether, as part of smoothing parameter estimation. 2 classes of these shrinkage smoothers are implemented: \code{"cs"} and \code{"ts"}, based on cubic regression spline and thin plate regression spline smoothers (see \code{\link{s}}) } \item{Null space penalization}{An alternative is to construct an extra penalty for each smooth which penalizes the space of functions of zero wiggliness according to its existing penalties. If all the smoothing parameters for such a term tend to infinity then the term is penalized to zero, and is effectively dropped from the model. The advantage of this approach is that it can be implemented automatically for any smooth. The \code{select} argument to \code{\link{gam}} causes this latter approach to be used. Unpenalized terms (e.g. \code{s(x,fx=TRUE)}) remain unpenalized. } } REML and ML smoothness selection are equivalent under this approach, and simulation evidence suggests that they tend to perform a little better than prediction error criteria, for model selection. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Marra, G. and S.N. Wood (2011) Practical variable selection for generalized additive models Computational Statistics and Data Analysis 55,2372-2387 } \seealso{\code{\link{gam.selection}}} \examples{ ## an example of GCV based model selection as ## an alternative to stepwise selection, using ## shrinkage smoothers... library(mgcv) set.seed(0);n <- 400 dat <- gamSim(1,n=n,scale=2) dat$x4 <- runif(n, 0, 1) dat$x5 <- runif(n, 0, 1) attach(dat) ## Note the increased gamma parameter below to favour ## slightly smoother models... b<-gam(y~s(x0,bs="ts")+s(x1,bs="ts")+s(x2,bs="ts")+ s(x3,bs="ts")+s(x4,bs="ts")+s(x5,bs="ts"),gamma=1.4) summary(b) plot(b,pages=1) ## Same again using REML/ML b<-gam(y~s(x0,bs="ts")+s(x1,bs="ts")+s(x2,bs="ts")+ s(x3,bs="ts")+s(x4,bs="ts")+s(x5,bs="ts"),method="REML") summary(b) plot(b,pages=1) ## And once more, but using the null space penalization b<-gam(y~s(x0,bs="cr")+s(x1,bs="cr")+s(x2,bs="cr")+ s(x3,bs="cr")+s(x4,bs="cr")+s(x5,bs="cr"), method="REML",select=TRUE) summary(b) plot(b,pages=1) detach(dat);rm(dat) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/gam.models.Rd0000755000176200001440000004660513303547337014324 0ustar liggesusers\name{gam.models} \alias{gam.models} %- Also NEED an `\alias' for EACH other topic documented here. \title{Specifying generalized additive models} \description{ This page is intended to provide some more information on how to specify GAMs. A GAM is a GLM in which the linear predictor depends, in part, on a sum of smooth functions of predictors and (possibly) linear functionals of smooth functions of (possibly dummy) predictors. Specifically let \eqn{y_i}{y_i} denote an independent random variable with mean \eqn{\mu_i}{mu_i} and an exponential family distribution, or failing that a known mean variance relationship suitable for use of quasi-likelihood methods. Then the the linear predictor of a GAM has a structure something like \deqn{g(\mu_i) = {\bf X}_i{\beta} + f_1(x_{1i},x_{2i}) + f_2(x_{3i}) + L_i f_3(x_4) + \ldots}{g(mu_i)=X_i b + f_1(x_1i,x_2i) + f_2(x_3i) + L_i f_3(x_4) + ...} where \eqn{g}{g} is a known smooth monotonic `link' function, \eqn{{\bf X}_i\beta}{X_i b} is the parametric part of the linear predictor, the \eqn{x_j}{x_j} are predictor variables, the \eqn{f_j}{f_j} are smooth functions and \eqn{L_i}{L_i} is some linear functional of \eqn{f_3}{f_3}. There may of course be multiple linear functional terms, or none. The key idea here is that the dependence of the response on the predictors can be represented as a parametric sub-model plus the sum of some (functionals of) smooth functions of one or more of the predictor variables. Thus the model is quite flexible relative to strictly parametric linear or generalized linear models, but still has much more structure than the completely general model that says that the response is just some smooth function of all the covariates. Note one important point. In order for the model to be identifiable the smooth functions usually have to be constrained to have zero mean (usually taken over the set of covariate values). The constraint is needed if the term involving the smooth includes a constant function in its span. \code{gam} always applies such constraints unless there is a \code{by} variable present, in which case an assessment is made of whether the constraint is needed or not (see below). The following sections discuss specifying model structures for \code{gam}. Specification of the distribution and link function is done using the \code{\link{family}} argument to \code{\link{gam}} and works in the same way as for \code{\link{glm}}. This page therefore concentrates on the model formula for \code{gam}. } \section{Models with simple smooth terms}{ Consider the example model. \deqn{g(\mu_i) = \beta_0 + \beta_1 x_{1i} + \beta_2 x_{2i} + f_1(x_{3i}) + f_2(x_{4i},x_{5i})}{ g(mu_i) = b_0 + b_1 x_1i + b_2 x_2i + f1(x_3i) + f2(x_4i,x_5i)} where the response variables \eqn{y_i}{y_i} has expectation \eqn{\mu_i}{mu_i} and \eqn{g}{g} is a link function. The \code{gam} formula for this would be \cr \code{y ~ x1 + x2 + s(x3) + s(x4,x5)}. \cr This would use the default basis for the smooths (a thin plate regression spline basis for each), with automatic selection of the effective degrees of freedom for both smooths. The dimension of the smoothing basis is given a default value as well (the dimension of the basis sets an upper limit on the maximum possible degrees of freedom for the basis - the limit is typically one less than basis dimension). Full details of how to control smooths are given in \code{\link{s}} and \code{\link{te}}, and further discussion of basis dimension choice can be found in \code{\link{choose.k}}. For the moment suppose that we would like to change the basis of the first smooth to a cubic regression spline basis with a dimension of 20, while fixing the second term at 25 degrees of freedom. The appropriate formula would be:\cr \code{y ~ x1 + x2 + s(x3,bs="cr",k=20) + s(x4,x5,k=26,fx=TRUE)}. The above assumes that \eqn{x_{4}}{x_4} and \eqn{x_5}{x_5} are naturally on similar scales (e.g. they might be co-ordinates), so that isotropic smoothing is appropriate. If this assumption is false then tensor product smoothing might be better (see \code{\link{te}}). \cr \code{y ~ x1 + x2 + s(x3) + te(x4,x5)}\cr would generate a tensor product smooth of \eqn{x_{4}}{x_4} and \eqn{x_5}{x_5}. By default this smooth would have basis dimension 25 and use cubic regression spline marginals. Varying the defaults is easy. For example\cr \code{y ~ x1 + x2 + s(x3) + te(x4,x5,bs=c("cr","ps"),k=c(6,7))}\cr specifies that the tensor product should use a rank 6 cubic regression spline marginal and a rank 7 P-spline marginal to create a smooth with basis dimension 42. } \section{Nested terms/functional ANOVA}{ Sometimes it is interesting to specify smooth models with a main effects + interaction structure such as \deqn{E(y_i) = f_1(x_i) + f_2(z_i) + f_3(x_i,z_i)}{E(y) = f1 (x) + f2(z) + f3(x,z)} or \deqn{E(y_i)=f_1(x_i) + f_2(z_i) + f_3(v_i) + f_4(x_i,z_i) + f_5(z_i,v_i) + f_6(z_i,v_i) + f_7(x_i,z_i,v_i) }{ E(y) = f1(x) + f2(z) + f3(v) + f4(x,z) + f5(z,v) + f6(z,v) + f7(x,z,v)} for example. Such models should be set up using \code{\link{ti}} terms in the model formula. For example: \cr \code{y ~ ti(x) + ti(z) + ti(x,z)}, or\cr \code{y ~ ti(x) + ti(z) + ti(v) + ti(x,z) + ti(x,v) + ti(z,v)+ti(x,z,v)}. \cr The \code{ti} terms produce interactions with the component main effects excluded appropriately. (There is in fact no need to use \code{ti} terms for the main effects here, \code{s} terms could also be used.) \code{gam} allows nesting (or `overlap') of \code{te} and \code{s} smooths, and automatically generates side conditions to make such models identifiable, but the resulting models are much less stable and interpretable than those constructed using \code{ti} terms. } \section{`by' variables}{ \code{by} variables are the means for constructing `varying-coefficient models' (geographic regression models) and for letting smooths `interact' with factors or parametric terms. They are also the key to specifying general linear functionals of smooths. The \code{\link{s}} and \code{\link{te}} terms used to specify smooths accept an argument \code{by}, which is a numeric or factor variable of the same dimension as the covariates of the smooth. If a \code{by} variable is numeric, then its \eqn{i^{th}}{ith} element multiples the \eqn{i^{th}}{ith} row of the model matrix corresponding to the smooth term concerned. Factor smooth interactions (see also \code{\link{factor.smooth.interaction}}). If a \code{by} variable is a \code{\link{factor}} then it generates an indicator vector for each level of the factor, unless it is an \code{\link{ordered}} factor. In the non-ordered case, the model matrix for the smooth term is then replicated for each factor level, and each copy has its rows multiplied by the corresponding rows of its indicator variable. The smoothness penalties are also duplicated for each factor level. In short a different smooth is generated for each factor level (the \code{id} argument to \code{\link{s}} and \code{\link{te}} can be used to force all such smooths to have the same smoothing parameter). \code{\link{ordered}} \code{by} variables are handled in the same way, except that no smooth is generated for the first level of the ordered factor (see \code{b3} example below). This is useful for setting up identifiable models when the same smooth occurs more than once in a model, with different factor \code{by} variables. As an example, consider the model \deqn{E(y_i) = \beta_0+ f(x_i)z_i}{E(y_i) = b_0 + f(x_i)z_i} where \eqn{f}{f} is a smooth function, and \eqn{z_i}{z_i} is a numeric variable. The appropriate formula is:\cr \code{y ~ s(x,by=z)}\cr - the \code{by} argument ensures that the smooth function gets multiplied by covariate \code{z}. Note that when using factor by variables, centering constraints are applied to the smooths, which usually means that the by variable should be included as a parametric term, as well. The example code below also illustrates the use of factor \code{by} variables. \code{by} variables may be supplied as numeric matrices as part of specifying general linear functional terms. If a \code{by} variable is present and numeric (rather than a factor) then the corresponding smooth is only subjected to an identifiability constraint if (i) the \code{by} variable is a constant vector, or, (ii) for a matrix \code{by} variable, \code{L}, if \code{L\%*\%rep(1,ncol(L))} is constant or (iii) if a user defined smooth constructor supplies an identifiability constraint explicitly, and that constraint has an attibute \code{"always.apply"}. } \section{Linking smooths with `id'}{ It is sometimes desirable to insist that different smooth terms have the same degree of smoothness. This can be done by using the \code{id} argument to \code{\link{s}} or \code{\link{te}} terms. Smooths which share an \code{id} will have the same smoothing parameter. Really this only makes sense if the smooths use the same basis functions, and the default behaviour is to force this to happen: all smooths sharing an \code{id} have the same basis functions as the first smooth occurring with that \code{id}. Note that if you want exactly the same function for each smooth, then this is best achieved by making use of the summation convention covered under `linear functional terms'. As an example suppose that \eqn{E(y_i)\equiv\mu_i}{E(y_i)=mu_i} and \deqn{g(\mu_i) = f_1(x_{1i}) + f_2(x_{2i},x_{3i}) + f_3(x_{4i})}{g(mu_i) = f1(x_1i) + f2(x_2i,x_3i) + f3(x_4i)} but that \eqn{f_1}{f1} and \eqn{f_3}{f3} should have the same smoothing parameters (and \eqn{x_2}{x_2} and \eqn{x_3}{x_3} are on different scales). Then the \code{gam} formula\cr \code{y ~ s(x1,id=1) + te(x_2,x3) + s(x4,id=1)}\cr would achieve the desired result. \code{id} can be numbers or character strings. Giving an \code{id} to a term with a factor \code{by} variable causes the smooths at each level of the factor to have the same smoothing parameter. Smooth term \code{id}s are not supported by \code{gamm}. } \section{Linear functional terms}{ General linear functional terms have a long history in the spline literature including in the penalized GLM context (see e.g. Wahba 1990). Such terms encompass varying coefficient models/ geographic regression, functional GLMs (i.e. GLMs with functional predictors), GLASS models, etc, and allow smoothing with respect to aggregated covariate values, for example. Such terms are implemented in \code{mgcv} using a simple `summation convention' for smooth terms: If the covariates of a smooth are supplied as matrices, then summation of the evaluated smooth over the columns of the matrices is implied. Each covariate matrix and any \code{by} variable matrix must be of the same dimension. Consider, for example the term\cr \code{s(X,Z,by=L)}\cr where \code{X}, \code{Z} and \code{L} are \eqn{n \times p}{n by p} matrices. Let \eqn{f}{f} denote the thin plate regression spline specified. The resulting contibution to the \eqn{i^{\rm th}}{ith} element of the linear predictor is \deqn{\sum_{j=1}^p L_{ij}f(X_{ij},Z_{ij})}{sum_j^p L_ij f(X_ij,Z_ij)} If no \code{L} is supplied then all its elements are taken as 1. In R code terms, let \code{F} denote the \eqn{n \times p}{n by p} matrix obtained by evaluating the smooth at the values in \code{X} and \code{Z}. Then the contribution of the term to the linear predictor is \code{rowSums(L*F)} (note that it's element by element multiplication here!). The summation convention applies to \code{te} terms as well as \code{s} terms. More details and examples are provided in \code{\link{linear.functional.terms}}. } \section{Random effects}{ Random effects can be added to \code{gam} models using \code{s(...,bs="re")} terms (see \code{\link{smooth.construct.re.smooth.spec}}), or the \code{paraPen} argument to \code{\link{gam}} covered below. See \code{\link{gam.vcomp}}, \code{\link{random.effects}} and \code{\link{smooth.construct.re.smooth.spec}} for further details. An alternative is to use the approach of \code{\link{gamm}}. } \section{Penalizing the parametric terms}{ In case the ability to add smooth classes, smooth identities, \code{by} variables and the summation convention are still not sufficient to implement exactly the penalized GLM that you require, \code{\link{gam}} also allows you to penalize the parametric terms in the model formula. This is mostly useful in allowing one or more matrix terms to be included in the formula, along with a sequence of quadratic penalty matrices for each. Suppose that you have set up a model matrix \eqn{\bf X}{X}, and want to penalize the corresponding coefficients, \eqn{\beta}{b} with two penalties \eqn{\beta^T {\bf S}_1 \beta}{b'S1 b} and \eqn{\beta^T {\bf S}_2 \beta}{b'S2 b}. Then something like the following would be appropriate:\cr \code{gam(y ~ X - 1,paraPen=list(X=list(S1,S2)))}\cr The \code{paraPen} argument should be a list with elements having names corresponding to the terms being penalized. Each element of \code{paraPen} is itself a list, with optional elements \code{L}, \code{rank} and \code{sp}: all other elements must be penalty matrices. If present, \code{rank} is a vector giving the rank of each penalty matrix (if absent this is determined numerically). \code{L} is a matrix that maps underlying log smoothing parameters to the log smoothing parameters that actually multiply the individual quadratic penalties: taken as the identity if not supplied. \code{sp} is a vector of (underlying) smoothing parameter values: positive values are taken as fixed, negative to signal that the smoothing parameter should be estimated. Taken as all negative if not supplied. An obvious application of \code{paraPen} is to incorporate random effects, and an example of this is provided below. In this case the supplied penalty matrices will be (generalized) inverse covariance matrices for the random effects --- i.e. precision matrices. The final estimate of the covariance matrix corresponding to one of these penalties is given by the (generalized) inverse of the penalty matrix multiplied by the estimated scale parameter and divided by the estimated smoothing parameter for the penalty. For example, if you use an identity matrix to penalize some coefficients that are to be viewed as i.i.d. Gaussian random effects, then their estimated variance will be the estimated scale parameter divided by the estimate of the smoothing parameter, for this penalty. See the `rail' example below. P-values for penalized parametric terms should be treated with caution. If you must have them, then use the option \code{freq=TRUE} in \code{\link{anova.gam}} and \code{\link{summary.gam}}, which will tend to give reasonable results for random effects implemented this way, but not for terms with a rank defficient penalty (or penalties with a wide eigen-spectrum). } %- maybe also `usage' for other objects documented here. \references{ Wahba (1990) Spline Models of Observational Data SIAM. Wood S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ require(mgcv) set.seed(10) ## simulate date from y = f(x2)*x1 + error dat <- gamSim(3,n=400) b<-gam(y ~ s(x2,by=x1),data=dat) plot(b,pages=1) summary(b) ## Factor `by' variable example (with a spurious covariate x0) ## simulate data... dat <- gamSim(4) ## fit model... b <- gam(y ~ fac+s(x2,by=fac)+s(x0),data=dat) plot(b,pages=1) summary(b) ## note that the preceding fit is the same as.... b1<-gam(y ~ s(x2,by=as.numeric(fac==1))+s(x2,by=as.numeric(fac==2))+ s(x2,by=as.numeric(fac==3))+s(x0)-1,data=dat) ## ... the `-1' is because the intercept is confounded with the ## *uncentred* smooths here. plot(b1,pages=1) summary(b1) ## repeat forcing all s(x2) terms to have the same smoothing param ## (not a very good idea for these data!) b2 <- gam(y ~ fac+s(x2,by=fac,id=1)+s(x0),data=dat) plot(b2,pages=1) summary(b2) ## now repeat with a single reference level smooth, and ## two `difference' smooths... dat$fac <- ordered(dat$fac) b3 <- gam(y ~ fac+s(x2)+s(x2,by=fac)+s(x0),data=dat,method="REML") plot(b3,pages=1) summary(b3) rm(dat) ## An example of a simple random effects term implemented via ## penalization of the parametric part of the model... dat <- gamSim(1,n=400,scale=2) ## simulate 4 term additive truth ## Now add some random effects to the simulation. Response is ## grouped into one of 20 groups by `fac' and each groups has a ## random effect added.... fac <- as.factor(sample(1:20,400,replace=TRUE)) dat$X <- model.matrix(~fac-1) b <- rnorm(20)*.5 dat$y <- dat$y + dat$X\%*\%b ## now fit appropriate random effect model... PP <- list(X=list(rank=20,diag(20))) rm <- gam(y~ X+s(x0)+s(x1)+s(x2)+s(x3),data=dat,paraPen=PP) plot(rm,pages=1) ## Get estimated random effects standard deviation... sig.b <- sqrt(rm$sig2/rm$sp[1]);sig.b ## a much simpler approach uses "re" terms... rm1 <- gam(y ~ s(fac,bs="re")+s(x0)+s(x1)+s(x2)+s(x3),data=dat,method="ML") gam.vcomp(rm1) ## Simple comparison with lme, using Rail data. ## See ?random.effects for a simpler method require(nlme) b0 <- lme(travel~1,data=Rail,~1|Rail,method="ML") Z <- model.matrix(~Rail-1,data=Rail, contrasts.arg=list(Rail="contr.treatment")) b <- gam(travel~Z,data=Rail,paraPen=list(Z=list(diag(6))),method="ML") b0 (b$reml.scale/b$sp)^.5 ## `gam' ML estimate of Rail sd b$reml.scale^.5 ## `gam' ML estimate of residual sd b0 <- lme(travel~1,data=Rail,~1|Rail,method="REML") Z <- model.matrix(~Rail-1,data=Rail, contrasts.arg=list(Rail="contr.treatment")) b <- gam(travel~Z,data=Rail,paraPen=list(Z=list(diag(6))),method="REML") b0 (b$reml.scale/b$sp)^.5 ## `gam' REML estimate of Rail sd b$reml.scale^.5 ## `gam' REML estimate of residual sd ################################################################ ## Approximate large dataset logistic regression for rare events ## based on subsampling the zeroes, and adding an offset to ## approximately allow for this. ## Doing the same thing, but upweighting the sampled zeroes ## leads to problems with smoothness selection, and CIs. ################################################################ n <- 50000 ## simulate n data dat <- gamSim(1,n=n,dist="binary",scale=.33) p <- binomial()$linkinv(dat$f-6) ## make 1's rare dat$y <- rbinom(p,1,p) ## re-simulate rare response ## Now sample all the 1's but only proportion S of the 0's S <- 0.02 ## sampling fraction of zeroes dat <- dat[dat$y==1 | runif(n) < S,] ## sampling ## Create offset based on total sampling fraction dat$s <- rep(log(nrow(dat)/n),nrow(dat)) lr.fit <- gam(y~s(x0,bs="cr")+s(x1,bs="cr")+s(x2,bs="cr")+s(x3,bs="cr")+ offset(s),family=binomial,data=dat,method="REML") ## plot model components with truth overlaid in red op <- par(mfrow=c(2,2)) fn <- c("f0","f1","f2","f3");xn <- c("x0","x1","x2","x3") for (k in 1:4) { plot(lr.fit,select=k,scale=0) ff <- dat[[fn[k]]];xx <- dat[[xn[k]]] ind <- sort.int(xx,index.return=TRUE)$ix lines(xx[ind],(ff-mean(ff))[ind]*.33,col=2) } par(op) rm(dat) ## A Gamma example, by modify `gamSim' output... dat <- gamSim(1,n=400,dist="normal",scale=1) dat$f <- dat$f/4 ## true linear predictor Ey <- exp(dat$f);scale <- .5 ## mean and GLM scale parameter ## Note that `shape' and `scale' in `rgamma' are almost ## opposite terminology to that used with GLM/GAM... dat$y <- rgamma(Ey*0,shape=1/scale,scale=Ey*scale) bg <- gam(y~ s(x0)+ s(x1)+s(x2)+s(x3),family=Gamma(link=log), data=dat,method="REML") plot(bg,pages=1,scheme=1) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/gam.Rd0000755000176200001440000007013213527756257013045 0ustar liggesusers\name{gam} \alias{gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generalized additive models with integrated smoothness estimation} \description{ Fits a generalized additive model (GAM) to data, the term `GAM' being taken to include any quadratically penalized GLM and a variety of other models estimated by a quadratically penalised likelihood type approach (see \code{\link{family.mgcv}}). The degree of smoothness of model terms is estimated as part of fitting. \code{gam} can also fit any GLM subject to multiple quadratic penalties (including estimation of degree of penalization). Confidence/credible intervals are readily available for any quantity predicted using a fitted model. Smooth terms are represented using penalized regression splines (or similar smoothers) with smoothing parameters selected by GCV/UBRE/AIC/REML or by regression splines with fixed degrees of freedom (mixtures of the two are permitted). Multi-dimensional smooths are available using penalized thin plate regression splines (isotropic) or tensor product splines (when an isotropic smooth is inappropriate), and users can add smooths. Linear functionals of smooths can also be included in models. For an overview of the smooths available see \code{\link{smooth.terms}}. For more on specifying models see \code{\link{gam.models}}, \code{\link{random.effects}} and \code{\link{linear.functional.terms}}. For more on model selection see \code{\link{gam.selection}}. Do read \code{\link{gam.check}} and \code{\link{choose.k}}. See \link[gam]{gam} from package \code{gam}, for GAMs via the original Hastie and Tibshirani approach (see details for differences to this implementation). For very large datasets see \code{\link{bam}}, for mixed GAM see \code{\link{gamm}} and \code{\link{random.effects}}. } \usage{ gam(formula,family=gaussian(),data=list(),weights=NULL,subset=NULL, na.action,offset=NULL,method="GCV.Cp", optimizer=c("outer","newton"),control=list(),scale=0, select=FALSE,knots=NULL,sp=NULL,min.sp=NULL,H=NULL,gamma=1, fit=TRUE,paraPen=NULL,G=NULL,in.out,drop.unused.levels=TRUE, drop.intercept=NULL,discrete=FALSE,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{formula}{ A GAM formula, or a list of formulae (see \code{\link{formula.gam}} and also \code{\link{gam.models}}). These are exactly like the formula for a GLM except that smooth terms, \code{\link{s}}, \code{\link{te}}, \code{\link{ti}} and \code{\link{t2}}, can be added to the right hand side to specify that the linear predictor depends on smooth functions of predictors (or linear functionals of these). } \item{family}{ This is a family object specifying the distribution and link to use in fitting etc (see \code{\link{glm}} and \code{\link{family}}). See \code{\link{family.mgcv}} for a full list of what is available, which goes well beyond exponential family. Note that \code{quasi} families actually result in the use of extended quasi-likelihood if \code{method} is set to a RE/ML method (McCullagh and Nelder, 1989, 9.6). } \item{data}{ A data frame or list containing the model response variable and covariates required by the formula. By default the variables are taken from \code{environment(formula)}: typically the environment from which \code{gam} is called.} \item{weights}{ prior weights on the contribution of the data to the log likelihood. Note that a weight of 2, for example, is equivalent to having made exactly the same observation twice. If you want to re-weight the contributions of each datum without changing the overall magnitude of the log likelihood, then you should normalize the weights (e.g. \code{weights <- weights/mean(weights)}). } \item{subset}{ an optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{ a function which indicates what should happen when the data contain `NA's. The default is set by the `na.action' setting of `options', and is `na.fail' if that is unset. The ``factory-fresh'' default is `na.omit'.} \item{offset}{Can be used to supply a model offset for use in fitting. Note that this offset will always be completely ignored when predicting, unlike an offset included in \code{formula} (this used to conform to the behaviour of \code{lm} and \code{glm}).} \item{control}{A list of fit control parameters to replace defaults returned by \code{\link{gam.control}}. Values not set assume default values. } \item{method}{The smoothing parameter estimation method. \code{"GCV.Cp"} to use GCV for unknown scale parameter and Mallows' Cp/UBRE/AIC for known scale. \code{"GACV.Cp"} is equivalent, but using GACV in place of GCV. \code{"REML"} for REML estimation, including of unknown scale, \code{"P-REML"} for REML estimation, but using a Pearson estimate of the scale. \code{"ML"} and \code{"P-ML"} are similar, but using maximum likelihood in place of REML. Beyond the exponential family \code{"REML"} is the default, and the only other option is \code{"ML"}.} \item{optimizer}{An array specifying the numerical optimization method to use to optimize the smoothing parameter estimation criterion (given by \code{method}). \code{"perf"} (deprecated) for performance iteration. \code{"outer"} for the more stable direct approach. \code{"outer"} can use several alternative optimizers, specified in the second element of \code{optimizer}: \code{"newton"} (default), \code{"bfgs"}, \code{"optim"}, \code{"nlm"} and \code{"nlm.fd"} (the latter is based entirely on finite differenced derivatives and is very slow). \code{"efs"} for the extended Fellner Schall method of Wood and Fasiolo (2017).} \item{scale}{ If this is positive then it is taken as the known scale parameter. Negative signals that the scale parameter is unknown. 0 signals that the scale parameter is 1 for Poisson and binomial and unknown otherwise. Note that (RE)ML methods can only work with scale parameter 1 for the Poisson and binomial cases. } \item{select}{ If this is \code{TRUE} then \code{gam} can add an extra penalty to each term so that it can be penalized to zero. This means that the smoothing parameter estimation that is part of fitting can completely remove terms from the model. If the corresponding smoothing parameter is estimated as zero then the extra penalty has no effect. Use \code{gamma} to increase level of penalization. } \item{knots}{this is an optional list containing user specified knot values to be used for basis construction. For most bases the user simply supplies the knots to be used, which must match up with the \code{k} value supplied (note that the number of knots is not always just \code{k}). See \code{\link{tprs}} for what happens in the \code{"tp"/"ts"} case. Different terms can use different numbers of knots, unless they share a covariate. } \item{sp}{A vector of smoothing parameters can be provided here. Smoothing parameters must be supplied in the order that the smooth terms appear in the model formula. Negative elements indicate that the parameter should be estimated, and hence a mixture of fixed and estimated parameters is possible. If smooths share smoothing parameters then \code{length(sp)} must correspond to the number of underlying smoothing parameters.} \item{min.sp}{Lower bounds can be supplied for the smoothing parameters. Note that if this option is used then the smoothing parameters \code{full.sp}, in the returned object, will need to be added to what is supplied here to get the smoothing parameters actually multiplying the penalties. \code{length(min.sp)} should always be the same as the total number of penalties (so it may be longer than \code{sp}, if smooths share smoothing parameters).} \item{H}{A user supplied fixed quadratic penalty on the parameters of the GAM can be supplied, with this as its coefficient matrix. A common use of this term is to add a ridge penalty to the parameters of the GAM in circumstances in which the model is close to un-identifiable on the scale of the linear predictor, but perfectly well defined on the response scale.} \item{gamma}{Increase this beyond 1 to produce smoother models. \code{gamma} multiplies the effective degrees of freedom in the GCV or UBRE/AIC. code{n/gamma} can be viewed as an effective sample size in the GCV score, and this also enables it to be used with REML/ML. Ignored with P-RE/ML or the \code{efs} optimizer. } \item{fit}{If this argument is \code{TRUE} then \code{gam} sets up the model and fits it, but if it is \code{FALSE} then the model is set up and an object \code{G} containing what would be required to fit is returned is returned. See argument \code{G}.} \item{paraPen}{optional list specifying any penalties to be applied to parametric model terms. \code{\link{gam.models}} explains more.} \item{G}{Usually \code{NULL}, but may contain the object returned by a previous call to \code{gam} with \code{fit=FALSE}, in which case all other arguments are ignored except for \code{sp}, \code{gamma}, \code{in.out}, \code{scale}, \code{control}, \code{method} \code{optimizer} and \code{fit}.} \item{in.out}{optional list for initializing outer iteration. If supplied then this must contain two elements: \code{sp} should be an array of initialization values for all smoothing parameters (there must be a value for all smoothing parameters, whether fixed or to be estimated, but those for fixed s.p.s are not used); \code{scale} is the typical scale of the GCV/UBRE function, for passing to the outer optimizer, or the the initial value of the scale parameter, if this is to be estimated by RE/ML.} \item{drop.unused.levels}{by default unused levels are dropped from factors before fitting. For some smooths involving factor variables you might want to turn this off. Only do so if you know what you are doing.} \item{drop.intercept}{Set to \code{TRUE} to force the model to really not have the a constant in the parametric model part, even with factor variables present. Can be vector when \code{formula} is a list.} \item{discrete}{experimental option for setting up models for use with discrete methods employed in \code{\link{bam}}. Do not modify.} \item{...}{further arguments for passing on e.g. to \code{gam.fit} (such as \code{mustart}). } } \value{ If \code{fit=FALSE} the function returns a list \code{G} of items needed to fit a GAM, but doesn't actually fit it. Otherwise the function returns an object of class \code{"gam"} as described in \code{\link{gamObject}}. } \details{ A generalized additive model (GAM) is a generalized linear model (GLM) in which the linear predictor is given by a user specified sum of smooth functions of the covariates plus a conventional parametric component of the linear predictor. A simple example is: \deqn{\log(E(y_i)) = \alpha + f_1(x_{1i})+f_2(x_{2i})}{log(E(y_i))= a + f_1(x_1i)+f_2(x_2i)} where the (independent) response variables \eqn{y_i \sim {\rm Poi }}{y_i~Poi}, and \eqn{f_1}{f_1} and \eqn{f_2}{f_2} are smooth functions of covariates \eqn{x_1}{x_1} and \eqn{x_2}{x_2}. The log is an example of a link function. Note that to be identifiable the model requires constraints on the smooth functions. By default these are imposed automatically and require that the function sums to zero over the observed covariate values (the presence of a metric \code{by} variable is the only case which usually suppresses this). If absolutely any smooth functions were allowed in model fitting then maximum likelihood estimation of such models would invariably result in complex over-fitting estimates of \eqn{f_1}{f_1} and \eqn{f_2}{f_2}. For this reason the models are usually fit by penalized likelihood maximization, in which the model (negative log) likelihood is modified by the addition of a penalty for each smooth function, penalizing its `wiggliness'. To control the trade-off between penalizing wiggliness and penalizing badness of fit each penalty is multiplied by an associated smoothing parameter: how to estimate these parameters, and how to practically represent the smooth functions are the main statistical questions introduced by moving from GLMs to GAMs. The \code{mgcv} implementation of \code{gam} represents the smooth functions using penalized regression splines, and by default uses basis functions for these splines that are designed to be optimal, given the number basis functions used. The smooth terms can be functions of any number of covariates and the user has some control over how smoothness of the functions is measured. \code{gam} in \code{mgcv} solves the smoothing parameter estimation problem by using the Generalized Cross Validation (GCV) criterion \deqn{n D / (n - DoF)^2}{n D/(n - DoF)^2} or an Un-Biased Risk Estimator (UBRE )criterion \deqn{D/n + 2 s DoF / n - s }{D/n + 2 s DoF / n -s} where \eqn{D}{D} is the deviance, \eqn{n}{n} the number of data, \eqn{s}{s} the scale parameter and \eqn{DoF}{DoF} the effective degrees of freedom of the model. Notice that UBRE is effectively just AIC rescaled, but is only used when \eqn{s}{s} is known. Alternatives are GACV, or a Laplace approximation to REML. There is some evidence that the latter may actually be the most effective choice. The main computational challenge solved by the \code{mgcv} package is to optimize the smoothness selection criteria efficiently and reliably. Broadly \code{gam} works by first constructing basis functions and one or more quadratic penalty coefficient matrices for each smooth term in the model formula, obtaining a model matrix for the strictly parametric part of the model formula, and combining these to obtain a complete model matrix (/design matrix) and a set of penalty matrices for the smooth terms. The linear identifiability constraints are also obtained at this point. The model is fit using \code{\link{gam.fit}}, \code{\link{gam.fit3}} or variants, which are modifications of \code{\link{glm.fit}}. The GAM penalized likelihood maximization problem is solved by Penalized Iteratively Re-weighted Least Squares (P-IRLS) (see e.g. Wood 2000). Smoothing parameter selection is possible in one of two ways. (i) `Performance iteration' uses the fact that at each P-IRLS step a working penalized linear model is estimated, and the smoothing parameter estimation can be performed for each such working model. Eventually, in most cases, both model parameter estimates and smoothing parameter estimates converge. This option is available in \code{\link{bam}} and \code{\link{gamm}} but is deprecated for \code{gam} (ii) Alternatively the P-IRLS scheme is iterated to convergence for each trial set of smoothing parameters, and GCV, UBRE or REML scores are only evaluated on convergence - optimization is then `outer' to the P-IRLS loop: in this case the P-IRLS iteration has to be differentiated, to facilitate optimization, and \code{\link{gam.fit3}} or one of its variants is used in place of \code{gam.fit}. \code{gam} uses the second method, outer iteration. Several alternative basis-penalty types are built in for representing model smooths, but alternatives can easily be added (see \code{\link{smooth.terms}} for an overview and \code{\link{smooth.construct}} for how to add smooth classes). The choice of the basis dimension (\code{k} in the \code{s}, \code{te}, \code{ti} and \code{t2} terms) is something that should be considered carefully (the exact value is not critical, but it is important not to make it restrictively small, nor very large and computationally costly). The basis should be chosen to be larger than is believed to be necessary to approximate the smooth function concerned. The effective degrees of freedom for the smooth will then be controlled by the smoothing penalty on the term, and (usually) selected automatically (with an upper limit set by \code{k-1} or occasionally \code{k}). Of course the \code{k} should not be made too large, or computation will be slow (or in extreme cases there will be more coefficients to estimate than there are data). Note that \code{gam} assumes a very inclusive definition of what counts as a GAM: basically any penalized GLM can be used: to this end \code{gam} allows the non smooth model components to be penalized via argument \code{paraPen} and allows the linear predictor to depend on general linear functionals of smooths, via the summation convention mechanism described in \code{\link{linear.functional.terms}}. \code{link{family.mgcv}} details what is available beyond GLMs and the exponential family. Details of the default underlying fitting methods are given in Wood (2011 and 2004). Some alternative methods are discussed in Wood (2000 and 2006). \code{gam()} is not a clone of Trevor Hastie's original (as supplied in S-PLUS or package \link[gam]{gam}). The major differences are (i) that by default estimation of the degree of smoothness of model terms is part of model fitting, (ii) a Bayesian approach to variance estimation is employed that makes for easier confidence interval calculation (with good coverage probabilities), (iii) that the model can depend on any (bounded) linear functional of smooth terms, (iv) the parametric part of the model can be penalized, (v) simple random effects can be incorporated, and (vi) the facilities for incorporating smooths of more than one variable are different: specifically there are no \code{lo} smooths, but instead (a) \code{\link{s}} terms can have more than one argument, implying an isotropic smooth and (b) \code{\link{te}}, \code{\link{ti}} or \code{\link{t2}} smooths are provided as an effective means for modelling smooth interactions of any number of variables via scale invariant tensor product smooths. Splines on the sphere, Duchon splines and Gaussian Markov Random Fields are also available. (vii) Models beyond the exponential family are available. See \link[gam]{gam} from package \code{gam}, for GAMs via the original Hastie and Tibshirani approach. } \references{ Key References on this implementation: Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models (with discussion). Journal of the American Statistical Association 111, 1548-1575 \url{http://dx.doi.org/10.1080/01621459.2016.1180986} Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 Wood, S.N. (2004) Stable and efficient multiple smoothing parameter estimation for generalized additive models. J. Amer. Statist. Ass. 99:673-686. [Default method for additive case by GCV (but no longer for generalized)] Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 Wood, S.N. (2006a) Low rank scale invariant tensor product smooths for generalized additive mixed models. Biometrics 62(4):1025-1036 Wood S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC Press. Wood, S.N. and M. Fasiolo (2017) A generalized Fellner-Schall method for smoothing parameter optimization with application to Tweedie location, scale and shape models. Biometrics 73 (4), 1071-1081 Wood S.N., F. Scheipl and J.J. Faraway (2012) Straightforward intermediate rank tensor product smoothing in mixed models. Statistical Computing. Marra, G and S.N. Wood (2012) Coverage Properties of Confidence Intervals for Generalized Additive Model Components. Scandinavian Journal of Statistics, 39(1), 53-74. Key Reference on GAMs and related models: Hastie (1993) in Chambers and Hastie (1993) Statistical Models in S. Chapman and Hall. Hastie and Tibshirani (1990) Generalized Additive Models. Chapman and Hall. Wahba (1990) Spline Models of Observational Data. SIAM Wood, S.N. (2000) Modelling and Smoothing Parameter Estimation with Multiple Quadratic Penalties. J.R.Statist.Soc.B 62(2):413-428 [The original mgcv paper, but no longer the default methods.] Background References: Green and Silverman (1994) Nonparametric Regression and Generalized Linear Models. Chapman and Hall. Gu and Wahba (1991) Minimizing GCV/GML scores with multiple smoothing parameters via the Newton method. SIAM J. Sci. Statist. Comput. 12:383-398 Gu (2002) Smoothing Spline ANOVA Models, Springer. McCullagh and Nelder (1989) Generalized Linear Models 2nd ed. Chapman & Hall. O'Sullivan, Yandall and Raynor (1986) Automatic smoothing of regression functions in generalized linear models. J. Am. Statist.Ass. 81:96-103 Wood (2001) mgcv:GAMs and Generalized Ridge Regression for R. R News 1(2):20-25 Wood and Augustin (2002) GAMs with integrated model selection using penalized regression splines and applications to environmental modelling. Ecological Modelling 157:157-177 \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} Front end design inspired by the S function of the same name based on the work of Hastie and Tibshirani (1990). Underlying methods owe much to the work of Wahba (e.g. 1990) and Gu (e.g. 2002). } \section{WARNINGS }{ The default basis dimensions used for smooth terms are essentially arbitrary, and it should be checked that they are not too small. See \code{\link{choose.k}} and \code{\link{gam.check}}. You must have more unique combinations of covariates than the model has total parameters. (Total parameters is sum of basis dimensions plus sum of non-spline terms less the number of spline terms). Automatic smoothing parameter selection is not likely to work well when fitting models to very few response data. For data with many zeroes clustered together in the covariate space it is quite easy to set up GAMs which suffer from identifiability problems, particularly when using Poisson or binomial families. The problem is that with e.g. log or logit links, mean value zero corresponds to an infinite range on the linear predictor scale. } \seealso{\code{\link{mgcv-package}}, \code{\link{gamObject}}, \code{\link{gam.models}}, \code{\link{smooth.terms}}, \code{\link{linear.functional.terms}}, \code{\link{s}}, \code{\link{te}} \code{\link{predict.gam}}, \code{\link{plot.gam}}, \code{\link{summary.gam}}, \code{\link{gam.side}}, \code{\link{gam.selection}}, \code{\link{gam.control}} \code{\link{gam.check}}, \code{\link{linear.functional.terms}} \code{\link{negbin}}, \code{\link{magic}},\code{\link{vis.gam}} } \examples{ ## see also examples in ?gam.models (e.g. 'by' variables, ## random effects and tricks for large binary datasets) library(mgcv) set.seed(2) ## simulate some data... dat <- gamSim(1,n=400,dist="normal",scale=2) b <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat) summary(b) plot(b,pages=1,residuals=TRUE) ## show partial residuals plot(b,pages=1,seWithMean=TRUE) ## `with intercept' CIs ## run some basic model checks, including checking ## smoothing basis dimensions... gam.check(b) ## same fit in two parts ..... G <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),fit=FALSE,data=dat) b <- gam(G=G) print(b) ## 2 part fit enabling manipulation of smoothing parameters... G <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),fit=FALSE,data=dat,sp=b$sp) G$lsp0 <- log(b$sp*10) ## provide log of required sp vec gam(G=G) ## it's smoother ## change the smoothness selection method to REML b0 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat,method="REML") ## use alternative plotting scheme, and way intervals include ## smoothing parameter uncertainty... plot(b0,pages=1,scheme=1,unconditional=TRUE) ## Would a smooth interaction of x0 and x1 be better? ## Use tensor product smooth of x0 and x1, basis ## dimension 49 (see ?te for details, also ?t2). bt <- gam(y~te(x0,x1,k=7)+s(x2)+s(x3),data=dat, method="REML") plot(bt,pages=1) plot(bt,pages=1,scheme=2) ## alternative visualization AIC(b0,bt) ## interaction worse than additive ## Alternative: test for interaction with a smooth ANOVA ## decomposition (this time between x2 and x1) bt <- gam(y~s(x0)+s(x1)+s(x2)+s(x3)+ti(x1,x2,k=6), data=dat,method="REML") summary(bt) ## If it is believed that x0 and x1 are naturally on ## the same scale, and should be treated isotropically ## then could try... bs <- gam(y~s(x0,x1,k=40)+s(x2)+s(x3),data=dat, method="REML") plot(bs,pages=1) AIC(b0,bt,bs) ## additive still better. ## Now do automatic terms selection as well b1 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat, method="REML",select=TRUE) plot(b1,pages=1) ## set the smoothing parameter for the first term, estimate rest ... bp <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),sp=c(0.01,-1,-1,-1),data=dat) plot(bp,pages=1,scheme=1) ## alternatively... bp <- gam(y~s(x0,sp=.01)+s(x1)+s(x2)+s(x3),data=dat) # set lower bounds on smoothing parameters .... bp<-gam(y~s(x0)+s(x1)+s(x2)+s(x3), min.sp=c(0.001,0.01,0,10),data=dat) print(b);print(bp) # same with REML bp<-gam(y~s(x0)+s(x1)+s(x2)+s(x3), min.sp=c(0.1,0.1,0,10),data=dat,method="REML") print(b0);print(bp) ## now a GAM with 3df regression spline term & 2 penalized terms b0 <- gam(y~s(x0,k=4,fx=TRUE,bs="tp")+s(x1,k=12)+s(x2,k=15),data=dat) plot(b0,pages=1) \donttest{ ## now simulate poisson data... set.seed(6) dat <- gamSim(1,n=2000,dist="poisson",scale=.1) ## use "cr" basis to save time, with 2000 data... b2<-gam(y~s(x0,bs="cr")+s(x1,bs="cr")+s(x2,bs="cr")+ s(x3,bs="cr"),family=poisson,data=dat,method="REML") plot(b2,pages=1) ## drop x3, but initialize sp's from previous fit, to ## save more time... b2a<-gam(y~s(x0,bs="cr")+s(x1,bs="cr")+s(x2,bs="cr"), family=poisson,data=dat,method="REML", in.out=list(sp=b2$sp[1:3],scale=1)) par(mfrow=c(2,2)) plot(b2a) par(mfrow=c(1,1)) ## similar example using GACV... dat <- gamSim(1,n=400,dist="poisson",scale=.25) b4<-gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=poisson, data=dat,method="GACV.Cp",scale=-1) plot(b4,pages=1) ## repeat using REML as in Wood 2011... b5<-gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=poisson, data=dat,method="REML") plot(b5,pages=1) ## a binary example (see ?gam.models for large dataset version)... dat <- gamSim(1,n=400,dist="binary",scale=.33) lr.fit <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=binomial, data=dat,method="REML") ## plot model components with truth overlaid in red op <- par(mfrow=c(2,2)) fn <- c("f0","f1","f2","f3");xn <- c("x0","x1","x2","x3") for (k in 1:4) { plot(lr.fit,residuals=TRUE,select=k) ff <- dat[[fn[k]]];xx <- dat[[xn[k]]] ind <- sort.int(xx,index.return=TRUE)$ix lines(xx[ind],(ff-mean(ff))[ind]*.33,col=2) } par(op) anova(lr.fit) lr.fit1 <- gam(y~s(x0)+s(x1)+s(x2),family=binomial, data=dat,method="REML") lr.fit2 <- gam(y~s(x1)+s(x2),family=binomial, data=dat,method="REML") AIC(lr.fit,lr.fit1,lr.fit2) ## For a Gamma example, see ?summary.gam... ## For inverse Gaussian, see ?rig ## now 2D smoothing... eg <- gamSim(2,n=500,scale=.1) attach(eg) op <- par(mfrow=c(2,2),mar=c(4,4,1,1)) contour(truth$x,truth$z,truth$f) ## contour truth b4 <- gam(y~s(x,z),data=data) ## fit model fit1 <- matrix(predict.gam(b4,pr,se=FALSE),40,40) contour(truth$x,truth$z,fit1) ## contour fit persp(truth$x,truth$z,truth$f) ## persp truth vis.gam(b4) ## persp fit detach(eg) par(op) ################################################## ## largish dataset example with user defined knots ################################################## par(mfrow=c(2,2)) n <- 5000 eg <- gamSim(2,n=n,scale=.5) attach(eg) ind<-sample(1:n,200,replace=FALSE) b5<-gam(y~s(x,z,k=40),data=data, knots=list(x=data$x[ind],z=data$z[ind])) ## various visualizations vis.gam(b5,theta=30,phi=30) plot(b5) plot(b5,scheme=1,theta=50,phi=20) plot(b5,scheme=2) par(mfrow=c(1,1)) ## and a pure "knot based" spline of the same data b6<-gam(y~s(x,z,k=64),data=data,knots=list(x= rep((1:8-0.5)/8,8), z=rep((1:8-0.5)/8,rep(8,8)))) vis.gam(b6,color="heat",theta=30,phi=30) ## varying the default large dataset behaviour via `xt' b7 <- gam(y~s(x,z,k=40,xt=list(max.knots=500,seed=2)),data=data) vis.gam(b7,theta=30,phi=30) detach(eg) } } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. \concept{Varying coefficient model} \concept{Functional linear model} \concept{Penalized GLM} \concept{Generalized Additive Model} \concept{Penalized regression} \concept{Spline smoothing} \concept{Penalized regression spline} \concept{Generalized Cross Validation} \concept{Smoothing parameter selection} \concept{tensor product smoothing} \concept{thin plate spline} \concept{P-spline} \concept{Generalized ridge regression} mgcv/man/formula.gam.Rd0000755000176200001440000001533313445342665014504 0ustar liggesusers\name{formula.gam} \alias{formula.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM formula} \description{ Description of \code{\link{gam}} formula (see Details), and how to extract it from a fitted \code{gam} object. } \usage{ \method{formula}{gam}(x,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{ fitted model objects of class \code{gam} (see \code{\link{gamObject}}) as produced by \code{gam()}.} \item{...}{un-used in this case} } \value{ Returns the model formula, \code{x$formula}. Provided so that \code{anova} methods print an appropriate description of the model. } \details{ \code{\link{gam}} will accept a formula or, with some families, a list of formulae. Other \code{mgcv} modelling functions will not accept a list. The list form provides a mechanism for specifying several linear predictors, and allows these to share terms: see below. The formulae supplied to \code{\link{gam}} are exactly like those supplied to \code{\link{glm}} except that smooth terms, \code{\link{s}}, \code{\link{te}}, \code{\link{ti}} and \code{\link{t2}} can be added to the right hand side (and \code{.} is not supported in \code{gam} formulae). Smooth terms are specified by expressions of the form: \cr \code{s(x1,x2,...,k=12,fx=FALSE,bs="tp",by=z,id=1)}\cr where \code{x1}, \code{x2}, etc. are the covariates which the smooth is a function of, and \code{k} is the dimension of the basis used to represent the smooth term. If \code{k} is not specified then basis specific defaults are used. Note that these defaults are essentially arbitrary, and it is important to check that they are not so small that they cause oversmoothing (too large just slows down computation). Sometimes the modelling context suggests sensible values for \code{k}, but if not informal checking is easy: see \code{\link{choose.k}} and \code{\link{gam.check}}. \code{fx} is used to indicate whether or not this term should be unpenalized, and therefore have a fixed number of degrees of freedom set by \code{k} (almost always \code{k-1}). \code{bs} indicates the basis to use for the smooth: the built in options are described in \code{\link{smooth.terms}}, and user defined smooths can be added (see \code{\link{user.defined.smooth}}). If \code{bs} is not supplied then the default \code{"tp"} (\code{\link{tprs}}) basis is used. \code{by} can be used to specify a variable by which the smooth should be multiplied. For example \code{gam(y~s(x,by=z))} would specify a model \eqn{ E(y) = f(x)z}{E(y)=f(x)z} where \eqn{f(\cdot)}{f(.)} is a smooth function. The \code{by} option is particularly useful for models in which different functions of the same variable are required for each level of a factor and for `varying coefficient models': see \code{\link{gam.models}}. \code{id} is used to give smooths identities: smooths with the same identity have the same basis, penalty and smoothing parameter (but different coefficients, so they are different functions). An alternative for specifying smooths of more than one covariate is e.g.: \cr \code{te(x,z,bs=c("tp","tp"),m=c(2,3),k=c(5,10))}\cr which would specify a tensor product smooth of the two covariates \code{x} and \code{z} constructed from marginal t.p.r.s. bases of dimension 5 and 10 with marginal penalties of order 2 and 3. Any combination of basis types is possible, as is any number of covariates. \code{\link{te}} provides further information. \code{\link{ti}} terms are a variant designed to be used as interaction terms when the main effects (and any lower order interactions) are present. \code{\link{t2}} produces tensor product smooths that are the natural low rank analogue of smoothing spline anova models. \code{s}, \code{te}, \code{ti} and \code{t2} terms accept an \code{sp} argument of supplied smoothing parameters: positive values are taken as fixed values to be used, negative to indicate that the parameter should be estimated. If \code{sp} is supplied then it over-rides whatever is in the \code{sp} argument to \code{gam}, if it is not supplied then it defaults to all negative, but does not over-ride the \code{sp} argument to \code{gam}. Formulae can involve nested or ``overlapping'' terms such as \cr \code{y~s(x)+s(z)+s(x,z)} or \code{y~s(x,z)+s(z,v)}\cr but nested models should really be set up using \code{\link{ti}} terms: see \code{\link{gam.side}} for further details and examples. Smooth terms in a \code{gam} formula will accept matrix arguments as covariates (and corresponding \code{by} variable), in which case a `summation convention' is invoked. Consider the example of \code{s(X,Z,by=L)} where \code{X}, \code{Z} and \code{L} are n by m matrices. Let \code{F} be the n by m matrix that results from evaluating the smooth at the values in \code{X} and \code{Z}. Then the contribution to the linear predictor from the term will be \code{rowSums(F*L)} (note the element-wise multiplication). This convention allows the linear predictor of the GAM to depend on (a discrete approximation to) any linear functional of a smooth: see \code{\link{linear.functional.terms}} for more information and examples (including functional linear models/signal regression). Note that \code{gam} allows any term in the model formula to be penalized (possibly by multiple penalties), via the \code{paraPen} argument. See \code{\link{gam.models}} for details and example code. When several formulae are provided in a list, then they can be used to specify multiple linear predictors for families for which this makes sense (e.g. \code{\link{mvn}}). The first formula in the list must include a response variable, but later formulae need not (depending on the requirements of the family). Let the linear predictors be indexed, 1 to d where d is the number of linear predictors, and the indexing is in the order in which the formulae appear in the list. It is possible to supply extra formulae specifying that several linear predictors should share some terms. To do this a formula is supplied in which the response is replaced by numbers specifying the indices of the linear predictors which will shre the terms specified on the r.h.s. For example \code{1+3~s(x)+z-1} specifies that linear predictors 1 and 3 will share the terms \code{s(x)} and \code{z} (but we don't want an extra intercept, as this would usually be unidentifiable). Note that it is possible that a linear predictor only includes shared terms: it must still have its own formula, but the r.h.s. would simply be \code{-1} (e.g. \code{y ~ -1} or \code{~ -1}). } \section{WARNING}{ A \code{gam} formula should not refer to variables using e.g. \code{dat[["x"]]}. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gam}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/predict.gam.Rd0000755000176200001440000003321213551100050014437 0ustar liggesusers\name{predict.gam} \alias{predict.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Prediction from fitted GAM model} \description{ Takes a fitted \code{gam} object produced by \code{gam()} and produces predictions given a new set of values for the model covariates or the original values used for the model fit. Predictions can be accompanied by standard errors, based on the posterior distribution of the model coefficients. The routine can optionally return the matrix by which the model coefficients must be pre-multiplied in order to yield the values of the linear predictor at the supplied covariate values: this is useful for obtaining credible regions for quantities derived from the model (e.g. derivatives of smooths), and for lookup table prediction outside \code{R} (see example code below).} \usage{ \method{predict}{gam}(object,newdata,type="link",se.fit=FALSE,terms=NULL, exclude=NULL,block.size=NULL,newdata.guaranteed=FALSE, na.action=na.pass,unconditional=FALSE,iterms.type=NULL,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ a fitted \code{gam} object as produced by \code{gam()}. } \item{newdata}{ A data frame or list containing the values of the model covariates at which predictions are required. If this is not provided then predictions corresponding to the original data are returned. If \code{newdata} is provided then it should contain all the variables needed for prediction: a warning is generated if not. See details for use with \code{link{linear.functional.terms}}. } \item{type}{ When this has the value \code{"link"} (default) the linear predictor (possibly with associated standard errors) is returned. When \code{type="terms"} each component of the linear predictor is returned seperately (possibly with standard errors): this includes parametric model components, followed by each smooth component, but excludes any offset and any intercept. \code{type="iterms"} is the same, except that any standard errors returned for smooth components will include the uncertainty about the intercept/overall mean. When \code{type="response"} predictions on the scale of the response are returned (possibly with approximate standard errors). When \code{type="lpmatrix"} then a matrix is returned which yields the values of the linear predictor (minus any offset) when postmultiplied by the parameter vector (in this case \code{se.fit} is ignored). The latter option is most useful for getting variance estimates for quantities derived from the model: for example integrated quantities, or derivatives of smooths. A linear predictor matrix can also be used to implement approximate prediction outside \code{R} (see example code, below). } \item{se.fit}{ when this is TRUE (not default) standard error estimates are returned for each prediction.} \item{terms}{if \code{type=="terms"} or \code{type="iterms"} then only results for the terms (smooth or parametric) named in this array will be returned. Otherwise any smooth terms not named in this array will be set to zero. If \code{NULL} then all terms are included.} \item{exclude}{if \code{type=="terms"} or \code{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 \code{NULL} then no terms are excluded. Note that this is the term names as it appears in the model summary, see example. You can avoid providing the covariates for the excluded terms by setting \code{newdata.guaranteed=TRUE}, which will avoid all checks on \code{newdata}.} \item{block.size}{maximum number of predictions to process per call to underlying code: larger is quicker, but more memory intensive. Set to < 1 to use total number of predictions as this. If \code{NULL} then block size is 1000 if new data supplied, and the number of rows in the model frame otherwise. } \item{newdata.guaranteed}{Set to \code{TRUE} to turn off all checking of \code{newdata} except for sanity of factor levels: this can speed things up for large prediction tasks, but \code{newdata} must be complete, with no \code{NA} values for predictors required in the model. } \item{na.action}{what to do about \code{NA} values in \code{newdata}. With the default \code{na.pass}, any row of \code{newdata} containing \code{NA} values for required predictors, gives rise to \code{NA} predictions (even if the term concerned has no \code{NA} predictors). \code{na.exclude} or \code{na.omit} result in the dropping of \code{newdata} rows, if they contain any \code{NA} values for required predictors. If \code{newdata} is missing then \code{NA} handling is determined from \code{object$na.action}.} \item{unconditional}{if \code{TRUE} then the smoothing parameter uncertainty corrected covariance matrix is used, when available, otherwise the covariance matrix conditional on the estimated smoothing parameters is used. } \item{iterms.type}{if \code{type="iterms"} then standard errors can either include the uncertainty in the overall mean (default, withfixed and random effects included) or the uncertainty in the mean of the non-smooth fixed effects only (\code{iterms.type=2}).} \item{...}{ other arguments.} } \value{ If \code{type=="lpmatrix"} then a matrix is returned which will give a vector of linear predictor values (minus any offest) at the supplied covariate values, when applied to the model coefficient vector. Otherwise, if \code{se.fit} is \code{TRUE} then a 2 item list is returned with items (both arrays) \code{fit} and \code{se.fit} containing predictions and associated standard error estimates, otherwise an array of predictions is returned. The dimensions of the returned arrays depends on whether \code{type} is \code{"terms"} or not: if it is then the array is 2 dimensional with each term in the linear predictor separate, otherwise the array is 1 dimensional and contains the linear predictor/predicted values (or corresponding s.e.s). The linear predictor returned termwise will not include the offset or the intercept. \code{newdata} can be a data frame, list or model.frame: if it's a model frame then all variables must be supplied. } \details{The standard errors produced by \code{predict.gam} are based on the Bayesian posterior covariance matrix of the parameters \code{Vp} in the fitted gam object. When predicting from models with \code{\link{linear.functional.terms}} then there are two possibilities. If the summation convention is to be used in prediction, as it was in fitting, then \code{newdata} should be a list, with named matrix arguments corresponding to any variables that were matrices in fitting. Alternatively one might choose to simply evaluate the constitutent smooths at particular values in which case arguments that were matrices can be replaced by vectors (and \code{newdata} can be a dataframe). See \code{\link{linear.functional.terms}} for example code. To facilitate plotting with \code{\link{termplot}}, if \code{object} possesses an attribute \code{"para.only"} and \code{type=="terms"} then only parametric terms of order 1 are returned (i.e. those that \code{termplot} can handle). Note that, in common with other prediction functions, any offset supplied to \code{\link{gam}} as an argument is always ignored when predicting, unlike offsets specified in the gam model formula. See the examples for how to use the \code{lpmatrix} for obtaining credible regions for quantities derived from the model. } \references{ Chambers and Hastie (1993) Statistical Models in S. Chapman & Hall. Marra, G and S.N. Wood (2012) Coverage Properties of Confidence Intervals for Generalized Additive Model Components. Scandinavian Journal of Statistics, 39(1), 53-74. Wood S.N. (2006b) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org} The design is inspired by the S function of the same name described in Chambers and Hastie (1993) (but is not a clone). } \section{WARNING }{ Predictions are likely to be incorrect if data dependent transformations of the covariates are used within calls to smooths. See examples. Note that the behaviour of this function is not identical to \code{predict.gam()} in Splus. \code{type=="terms"} does not exactly match what \code{predict.lm} does for parametric model components. } \seealso{ \code{\link{gam}}, \code{\link{gamm}}, \code{\link{plot.gam}}} \examples{ library(mgcv) n<-200 sig <- 2 dat <- gamSim(1,n=n,scale=sig) b<-gam(y~s(x0)+s(I(x1^2))+s(x2)+offset(x3),data=dat) newd <- data.frame(x0=(0:30)/30,x1=(0:30)/30,x2=(0:30)/30,x3=(0:30)/30) pred <- predict.gam(b,newd) pred0 <- predict(b,newd,exclude="s(x0)") ## prediction excluding a term ## ...and the same, but without needing to provide x0 prediction data... newd1 <- newd;newd1$x0 <- NULL ## remove x0 from `newd1' pred1 <- predict(b,newd1,exclude="s(x0)",newdata.guaranteed=TRUE) ############################################# ## difference between "terms" and "iterms" ############################################# nd2 <- data.frame(x0=c(.25,.5),x1=c(.25,.5),x2=c(.25,.5),x3=c(.25,.5)) predict(b,nd2,type="terms",se=TRUE) predict(b,nd2,type="iterms",se=TRUE) ######################################################### ## now get variance of sum of predictions using lpmatrix ######################################################### Xp <- predict(b,newd,type="lpmatrix") ## Xp \%*\% coef(b) yields vector of predictions a <- rep(1,31) Xs <- t(a) \%*\% Xp ## Xs \%*\% coef(b) gives sum of predictions var.sum <- Xs \%*\% b$Vp \%*\% t(Xs) ############################################################# ## Now get the variance of non-linear function of predictions ## by simulation from posterior distribution of the params ############################################################# rmvn <- function(n,mu,sig) { ## MVN random deviates L <- mroot(sig);m <- ncol(L); t(mu + L\%*\%matrix(rnorm(m*n),m,n)) } br <- rmvn(1000,coef(b),b$Vp) ## 1000 replicate param. vectors res <- rep(0,1000) for (i in 1:1000) { pr <- Xp \%*\% br[i,] ## replicate predictions res[i] <- sum(log(abs(pr))) ## example non-linear function } mean(res);var(res) ## loop is replace-able by following .... res <- colSums(log(abs(Xp \%*\% t(br)))) ################################################################## ## The following shows how to use use an "lpmatrix" as a lookup ## table for approximate prediction. The idea is to create ## approximate prediction matrix rows by appropriate linear ## interpolation of an existing prediction matrix. The additivity ## of a GAM makes this possible. ## There is no reason to ever do this in R, but the following ## code provides a useful template for predicting from a fitted ## gam *outside* R: all that is needed is the coefficient vector ## and the prediction matrix. Use larger `Xp'/ smaller `dx' and/or ## higher order interpolation for higher accuracy. ################################################################### xn <- c(.341,.122,.476,.981) ## want prediction at these values x0 <- 1 ## intercept column dx <- 1/30 ## covariate spacing in `newd' for (j in 0:2) { ## loop through smooth terms cols <- 1+j*9 +1:9 ## relevant cols of Xp i <- floor(xn[j+1]*30) ## find relevant rows of Xp w1 <- (xn[j+1]-i*dx)/dx ## interpolation weights ## find approx. predict matrix row portion, by interpolation x0 <- c(x0,Xp[i+2,cols]*w1 + Xp[i+1,cols]*(1-w1)) } dim(x0)<-c(1,28) fv <- x0\%*\%coef(b) + xn[4];fv ## evaluate and add offset se <- sqrt(x0\%*\%b$Vp\%*\%t(x0));se ## get standard error ## compare to normal prediction predict(b,newdata=data.frame(x0=xn[1],x1=xn[2], x2=xn[3],x3=xn[4]),se=TRUE) ################################################################## # illustration of unsafe scale dependent transforms in smooths.... ################################################################## b0 <- gam(y~s(x0)+s(x1)+s(x2)+x3,data=dat) ## safe b1 <- gam(y~s(x0)+s(I(x1/2))+s(x2)+scale(x3),data=dat) ## safe b2 <- gam(y~s(x0)+s(scale(x1))+s(x2)+scale(x3),data=dat) ## unsafe pd <- dat; pd$x1 <- pd$x1/2; pd$x3 <- pd$x3/2 par(mfrow=c(1,2)) plot(predict(b0,pd),predict(b1,pd),main="b0 and b1 predictions match") abline(0,1,col=2) plot(predict(b0,pd),predict(b2,pd),main="b2 unsafe, doesn't match") abline(0,1,col=2) #################################################################### ## Differentiating the smooths in a model (with CIs for derivatives) #################################################################### ## simulate data and fit model... dat <- gamSim(1,n=300,scale=sig) b<-gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat) plot(b,pages=1) ## now evaluate derivatives of smooths with associated standard ## errors, by finite differencing... x.mesh <- seq(0,1,length=200) ## where to evaluate derivatives newd <- data.frame(x0 = x.mesh,x1 = x.mesh, x2=x.mesh,x3=x.mesh) X0 <- predict(b,newd,type="lpmatrix") eps <- 1e-7 ## finite difference interval x.mesh <- x.mesh + eps ## shift the evaluation mesh newd <- data.frame(x0 = x.mesh,x1 = x.mesh, x2=x.mesh,x3=x.mesh) X1 <- predict(b,newd,type="lpmatrix") Xp <- (X1-X0)/eps ## maps coefficients to (fd approx.) derivatives colnames(Xp) ## can check which cols relate to which smooth par(mfrow=c(2,2)) for (i in 1:4) { ## plot derivatives and corresponding CIs Xi <- Xp*0 Xi[,(i-1)*9+1:9+1] <- Xp[,(i-1)*9+1:9+1] ## Xi\%*\%coef(b) = smooth deriv i df <- Xi\%*\%coef(b) ## ith smooth derivative df.sd <- rowSums(Xi\%*\%b$Vp*Xi)^.5 ## cheap diag(Xi\%*\%b$Vp\%*\%t(Xi))^.5 plot(x.mesh,df,type="l",ylim=range(c(df+2*df.sd,df-2*df.sd))) lines(x.mesh,df+2*df.sd,lty=2);lines(x.mesh,df-2*df.sd,lty=2) } } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/jagam.Rd0000755000176200001440000003425313303547351013345 0ustar liggesusers\name{jagam} \alias{jagam} \alias{sim2jam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Just Another Gibbs Additive Modeller: JAGS support for mgcv.} \description{Facilities to auto-generate model specification code and associated data to simulate with GAMs in JAGS (or BUGS). This is useful for inference about models with complex random effects structure best coded in JAGS. It is a very innefficient approach to making inferences about standard GAMs. The idea is that \code{jagam} generates template JAGS code, and associated data, for the smooth part of the model. This template is then directly edited to include other stochastic components. After simulation with the resulting model, facilities are provided for plotting and prediction with the model smooth components. } \usage{ jagam(formula,family=gaussian,data=list(),file,weights=NULL,na.action, offset=NULL,knots=NULL,sp=NULL,drop.unused.levels=TRUE, control=gam.control(),centred=TRUE,sp.prior = "gamma",diagonalize=FALSE) sim2jam(sam,pregam,edf.type=2,burnin=0) } %- maybe also `usage' for other objects documented here. \arguments{ \item{formula}{ A GAM formula (see \code{\link{formula.gam}} and also \code{\link{gam.models}}). This is exactly like the formula for a GLM except that smooth terms, \code{\link{s}}, \code{\link{te}}, \code{\link{ti}} and \code{\link{t2}} can be added to the right hand side to specify that the linear predictor depends on smooth functions of predictors (or linear functionals of these). } \item{family}{ This is a family object specifying the distribution and link function to use. See \code{\link{glm}} and \code{\link{family}} for more details. Currently only gaussian, poisson, binomial and Gamma families are supported, but the user can easily modify the assumed distribution in the JAGS code. } \item{data}{ A data frame or list containing the model response variable and covariates required by the formula. By default the variables are taken from \code{environment(formula)}: typically the environment from which \code{jagam} is called.} \item{file}{Name of the file to which JAGS model specification code should be written. See \code{\link{setwd}} for setting and querying the current working directory.} \item{weights}{ prior weights on the data.} \item{na.action}{ a function which indicates what should happen when the data contain `NA's. The default is set by the `na.action' setting of `options', and is `na.fail' if that is unset. The ``factory-fresh'' default is `na.omit'.} \item{offset}{Can be used to supply a model offset for use in fitting. Note that this offset will always be completely ignored when predicting, unlike an offset included in \code{formula}: this conforms to the behaviour of \code{lm} and \code{glm}.} \item{control}{A list of fit control parameters to replace defaults returned by \code{\link{gam.control}}. Any control parameters not supplied stay at their default values. little effect on \code{jagam}.} \item{knots}{this is an optional list containing user specified knot values to be used for basis construction. For most bases the user simply supplies the knots to be used, which must match up with the \code{k} value supplied (note that the number of knots is not always just \code{k}). See \code{\link{tprs}} for what happens in the \code{"tp"/"ts"} case. Different terms can use different numbers of knots, unless they share a covariate. } \item{sp}{A vector of smoothing parameters can be provided here. Smoothing parameters must be supplied in the order that the smooth terms appear in the model formula (without forgetting null space penalties). Negative elements indicate that the parameter should be estimated, and hence a mixture of fixed and estimated parameters is possible. If smooths share smoothing parameters then \code{length(sp)} must correspond to the number of underlying smoothing parameters.} \item{drop.unused.levels}{by default unused levels are dropped from factors before fitting. For some smooths involving factor variables you might want to turn this off. Only do so if you know what you are doing.} \item{centred}{Should centring constraints be applied to the smooths, as is usual with GAMS? Only set this to \code{FALSE} if you know exactly what you are doing. If \code{FALSE} there is a (usually global) intercept for each smooth.} \item{sp.prior}{\code{"gamma"} or \code{"log.uniform"} prior for the smoothing parameters? Do check that the default parameters are appropriate for your model in the JAGS code.} \item{diagonalize}{Should smooths be re-parameterized to have i.i.d. Gaussian priors (where possible)? For Gaussian data this allows efficient conjugate samplers to be used, and it can also work well with GLMs if the JAGS \code{"glm"} module is loaded, but otherwise it is often better to update smoothers blockwise, and not do this.} \item{sam}{jags sample object, containing at least fields \code{b} (coefficients) and \code{rho} (log smoothing parameters). May also contain field \code{mu} containing monitored expected response.} \item{pregam}{standard \code{mgcv} GAM setup data, as returned in \code{jagam} return list.} \item{edf.type}{Since EDF is not uniquely defined and may be affected by the stochastic structure added to the JAGS model file, 3 options are offered. See details.} \item{burnin}{the amount of burn in to discard from the simulation chains. Limited to .9 of the chain length.} } \value{ For \code{jagam} a three item list containing \item{pregam}{standard \code{mgcv} GAM setup data.} \item{jags.data}{list of arguments to be supplied to JAGS containing information referenced in model specification.} \item{jags.ini}{initialization data for smooth coefficients and smoothing parameters.} For \code{sim2jam} an object of class \code{"jam"}: a partial version of an \code{mgcv} \code{\link{gamObject}}, suitable for plotting and predicting. } \details{Smooths are easily incorportated into JAGS models using multivariate normal priors on the smooth coefficients. The smoothing parameters and smoothing penalty matrices directly specifiy the prior multivariate normal precision matrix. Normally a smoothing penalty does not correspond to a full rank precision matrix, implying an improper prior inappropriate for Gibbs sampling. To rectify this problem the null space penalties suggested in Marra and Wood (2011) are added to the usual penalties. In an additive modelling context it is usual to centre the smooths, to avoid the identifiability issues associated with having an intercept for each smooth term (in addition to a global intercept). Under Gibbs sampling with JAGS it is technically possible to omit this centring, since we anyway force propriety on the priors, and this propiety implies formal model identifiability. However, in most situations this formal identifiability is rather artificial and does not imply statistically meaningfull identifiability. Rather it serves only to massively inflate confidence intervals, since the multiple intercept terms are not identifiable from the data, but only from the prior. By default then, \code{jagam} imposes standard GAM identifiability constraints on all smooths. The \code{centred} argument does allow you to turn this off, but it is not recommended. If you do set \code{centred=FALSE} then chain convergence and mixing checks should be particularly stringent. The final technical issue for model setup is the setting of initial conditions for the coefficients and smoothing parameters. The approach taken is to take the default initial smoothing parameter values used elsewhere by \code{mgcv}, and to take a single PIRLS fitting step with these smoothing parameters in order to obtain starting values for the smooth coefficients. In the setting of fully conjugate updating the initial values of the coefficients are not critical, and good results are obtained without supplying them. But in the usual setting in which slice sampling is required for at least some of the updates then very poor results can sometimes be obtained without initial values, as the sampler simply fails to find the region of the posterior mode. The \code{sim2jam} function takes the partial \code{gam} object (\code{pregam}) from \code{jagam} along with simulation output in standard \code{rjags} form and creates a reduced version of a \code{gam} object, suitable for plotting and prediction of the model's smooth components. \code{sim2gam} computes effective degrees of freedom for each smooth, but it should be noted that there are several possibilites for doing this in the context of a model with a complex random effects structure. The simplest approach (\code{edf.type=0}) is to compute the degrees of freedom that the smooth would have had if it had been part of an unweighted Gaussian additive model. One might choose to use this option if the model has been modified so that the response distribution and/or link are not those that were specified to \code{jagam}. The second option is (\code{edf.type=1}) uses the edf that would have been computed by \code{\link{gam}} had it produced these estimates - in the context in which the JAGS model modifications have all been about modifying the random effects structure, this is equivalent to simply setting all the random effects to zero for the effective degrees of freedom calculation. The default option (\code{edf.type=2}) is to base the EDF on the sample covariance matrix, \code{Vp}, of the model coefficients. If the simulation output (\code{sim}) includes a \code{mu} field, then this will be used to form the weight matrix \code{W} in \code{XWX = t(X)\%*\%W\%*\%X}, where the EDF is computed from \code{rowSums(Vp*XWX)*scale}. If \code{mu} is not supplied then it is estimated from the the model matrix \code{X} and the mean of the simulated coefficients, but the resulting \code{W} may not be strictly comaptible with the \code{Vp} matrix in this case. In the situation in which the fitted model is very different in structure from the regression model of the template produced by \code{jagam} then the default option may make no sense, and indeed it may be best to use option 0. } \references{ Wood, S.N. (2016) Just Another Gibbs Additive Modeller: Interfacing JAGS and mgcv. Journal of Statistical Software 75(7):1-15 doi:10.18637/jss.v075.i07) Marra, G. and S.N. Wood (2011) Practical variable selection for generalized additive models. Computational Statistics & Data Analysis 55(7): 2372-2387 Here is a key early reference to smoothing using BUGS (although the approach and smooths used are a bit different to jagam) Crainiceanu, C. M. D Ruppert, & M.P. Wand (2005) Bayesian Analysis for Penalized Spline Regression Using WinBUGS Journal of Statistical Software 14. } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \section{WARNINGS }{ Gibb's sampling is a very slow inferential method for standard GAMs. It is only likely to be worthwhile when complex random effects structures are required above what is possible with direct GAMM methods. Check that the parameters of the priors on the parameters are fit for your purpose. } \seealso{\code{\link{gam}}, \code{\link{gamm}}, \code{\link{bam}} } \examples{ ## the following illustrates a typical workflow. To run the ## 'Not run' code you need rjags (and JAGS) to be installed. require(mgcv) set.seed(2) ## simulate some data... n <- 400 dat <- gamSim(1,n=n,dist="normal",scale=2) ## regular gam fit for comparison... b0 <- gam(y~s(x0)+s(x1) + s(x2)+s(x3),data=dat,method="REML") ## Set directory and file name for file containing jags code. ## In real use you would *never* use tempdir() for this. It is ## only done here to keep CRAN happy, and avoid any chance of ## an accidental overwrite. Instead you would use ## setwd() to set an appropriate working directory in which ## to write the file, and just set the file name to what you ## want to call it (e.g. "test.jags" here). jags.file <- paste(tempdir(),"/test.jags",sep="") ## Set up JAGS code and data. In this one might want to diagonalize ## to use conjugate samplers. Usually call 'setwd' first, to set ## directory in which model file ("test.jags") will be written. jd <- jagam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat,file=jags.file, sp.prior="gamma",diagonalize=TRUE) ## In normal use the model in "test.jags" would now be edited to add ## the non-standard stochastic elements that require use of JAGS.... \dontrun{ require(rjags) load.module("glm") ## improved samplers for GLMs often worth loading jm <-jags.model(jags.file,data=jd$jags.data,inits=jd$jags.ini,n.chains=1) list.samplers(jm) sam <- jags.samples(jm,c("b","rho","scale"),n.iter=10000,thin=10) jam <- sim2jam(sam,jd$pregam) plot(jam,pages=1) jam pd <- data.frame(x0=c(.5,.6),x1=c(.4,.2),x2=c(.8,.4),x3=c(.1,.1)) fv <- predict(jam,newdata=pd) ## and some minimal checking... require(coda) effectiveSize(as.mcmc.list(sam$b)) } ## a gamma example... set.seed(1); n <- 400 dat <- gamSim(1,n=n,dist="normal",scale=2) scale <- .5; Ey <- exp(dat$f/2) dat$y <- rgamma(n,shape=1/scale,scale=Ey*scale) jd <- jagam(y~s(x0)+te(x1,x2)+s(x3),data=dat,family=Gamma(link=log), file=jags.file,sp.prior="log.uniform") ## In normal use the model in "test.jags" would now be edited to add ## the non-standard stochastic elements that require use of JAGS.... \dontrun{ require(rjags) ## following sets random seed, but note that under JAGS 3.4 many ## models are still not fully repeatable (JAGS 4 should fix this) jd$jags.ini$.RNG.name <- "base::Mersenne-Twister" ## setting RNG jd$jags.ini$.RNG.seed <- 6 ## how to set RNG seed jm <-jags.model(jags.file,data=jd$jags.data,inits=jd$jags.ini,n.chains=1) list.samplers(jm) sam <- jags.samples(jm,c("b","rho","scale","mu"),n.iter=10000,thin=10) jam <- sim2jam(sam,jd$pregam) plot(jam,pages=1) jam pd <- data.frame(x0=c(.5,.6),x1=c(.4,.2),x2=c(.8,.4),x3=c(.1,.1)) fv <- predict(jam,newdata=pd) } } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. \concept{Varying coefficient model} \concept{Functional linear model} \concept{Penalized GLM} \concept{Generalized Additive Model} \concept{Penalized regression} \concept{Spline smoothing} \concept{Penalized regression spline} \concept{Generalized Cross Validation} \concept{Smoothing parameter selection} \concept{tensor product smoothing} \concept{thin plate spline} \concept{P-spline} \concept{Generalized ridge regression} mgcv/man/notExp.Rd0000755000176200001440000000464113073161527013542 0ustar liggesusers\name{notExp} \alias{notExp} \alias{notLog} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Functions for better-than-log positive parameterization} \description{ It is common practice in statistical optimization to use log-parameterizations when a parameter ought to be positive. i.e. if an optimization parameter \code{a} should be non-negative then we use \code{a=exp(b)} and optimize with respect to the unconstrained parameter \code{b}. This often works well, but it does imply a rather limited working range for \code{b}: using 8 byte doubles, for example, if \code{b}'s magnitude gets much above 700 then \code{a} overflows or underflows. This can cause problems for numerical optimization methods. \code{notExp} is a monotonic function for mapping the real line into the positive real line with much less extreme underflow and overflow behaviour than \code{exp}. It is a piece-wise function, but is continuous to second derivative: see the source code for the exact definition, and the example below to see what it looks like. \code{notLog} is the inverse function of \code{notExp}. The major use of these functions was originally to provide more robust \code{pdMat} classes for \code{lme} for use by \code{\link{gamm}}. Currently the \code{\link{notExp2}} and \code{\link{notLog2}} functions are used in their place, as a result of changes to the nlme optimization routines. } \usage{ notExp(x) notLog(x) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{Argument array of real numbers (\code{notExp}) or positive real numbers (\code{notLog}).} } \value{ An array of function values evaluated at the supplied argument values.} \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \seealso{ \code{\link{pdTens}}, \code{\link{pdIdnot}}, \code{\link{gamm}}} \examples{ ## Illustrate the notExp function: ## less steep than exp, but still monotonic. require(mgcv) x <- -100:100/10 op <- par(mfrow=c(2,2)) plot(x,notExp(x),type="l") lines(x,exp(x),col=2) plot(x,log(notExp(x)),type="l") lines(x,log(exp(x)),col=2) # redundancy intended x <- x/4 plot(x,notExp(x),type="l") lines(x,exp(x),col=2) plot(x,log(notExp(x)),type="l") lines(x,log(exp(x)),col=2) # redundancy intended par(op) range(notLog(notExp(x))-x) # show that inverse works! } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/smoothCon.Rd0000755000176200001440000001656613073161526014246 0ustar liggesusers\name{smoothCon} \alias{smoothCon} \alias{PredictMat} %- Also NEED an `\alias' for EACH other topic documented here. \title{Prediction/Construction wrapper functions for GAM smooth terms} \description{ Wrapper functions for construction of and prediction from smooth terms in a GAM. The purpose of the wrappers is to allow user-transparant re-parameterization of smooth terms, in order to allow identifiability constraints to be absorbed into the parameterization of each term, if required. The routine also handles `by' variables and construction of identifiability constraints automatically, although this behaviour can be over-ridden. } \usage{ smoothCon(object,data,knots=NULL,absorb.cons=FALSE, scale.penalty=TRUE,n=nrow(data),dataX=NULL, null.space.penalty=FALSE,sparse.cons=0, diagonal.penalty=FALSE,apply.by=TRUE,modCon=0) PredictMat(object,data,n=nrow(data)) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ is a smooth specification object or a smooth object.} \item{data}{A data frame, model frame or list containing the values of the (named) covariates at which the smooth term is to be evaluated. If it's a list then \code{n} must be supplied.} \item{knots}{An optional data frame supplying any knot locations to be supplied for basis construction.} \item{absorb.cons}{Set to \code{TRUE} in order to have identifiability constraints absorbed into the basis.} \item{scale.penalty}{should the penalty coefficient matrix be scaled to have approximately the same `size' as the inner product of the terms model matrix with itself? This can improve the performance of \code{\link{gamm}} fitting.} \item{n}{number of values for each covariate, or if a covariate is a matrix, the number of rows in that matrix: must be supplied explicitly if \code{data} is a list. } \item{dataX}{Sometimes the basis should be set up using data in \code{data}, but the model matrix should be constructed with another set of data provided in \code{dataX} --- \code{n} is assumed to be the same for both. Facilitates smooth id's.} \item{null.space.penalty}{Should an extra penalty be added to the smooth which will penalize the components of the smooth in the penalty null space: provides a way of penalizing terms out of the model altogether.} \item{apply.by}{set to \code{FALSE} to have basis setup exactly as in default case, but to return add an additional matrix \code{X0} to the return object, containing the model matrix without the \code{by} variable, if a \code{by} variable is present. Useful for \code{bam} discrete method setup.} \item{sparse.cons}{If \code{0} then default sum to zero constraints are used. If \code{-1} then sweep and drop sum to zero constraints are used (default with \code{\link{bam}}). If \code{1} then one coefficient is set to zero as constraint for sparse smooths. If \code{2} then sparse coefficient sum to zero constraints are used for sparse smooths. None of these options has an effect if the smooth supplies its own constraint.} \item{diagonal.penalty}{ If \code{TRUE} then the smooth is reparameterized to turn the penalty into an identity matrix, with the final diagonal elements zeroed (corresponding to the penalty nullspace). May result in a matrix \code{diagRP} in the returned object for use by \code{PredictMat}.} \item{modCon}{force modification of any smooth supplied constraints. 0 - do nothing. 1 - delete supplied constraints, replacing with automatically generated ones. 2 - set fit and predict constraint to predict constraint. 3 - set fit and predict constraint to fit constraint.} } \value{ From \code{smoothCon} a list of \code{smooth} objects returned by the appropriate \code{\link{smooth.construct}} method function. If constraints are to be absorbed then the objects will have attributes \code{"qrc"} and \code{"nCons"}. \code{"nCons"} is the number of constraints. \code{"qrc"} is usually the qr decomposition of the constraint matrix (returned by \code{\link{qr}}), but if it is a single positive integer it is the index of the coefficient to set to zero, and if it is a negative number then this indicates that the parameters are to sum to zero. For \code{predictMat} a matrix which will map the parameters associated with the smooth to the vector of values of the smooth evaluated at the covariate values given in \code{object}. } \details{ These wrapper functions exist to allow smooths specified using \code{\link{smooth.construct}} and \code{\link{Predict.matrix}} method functions to be re-parameterized so that identifiability constraints are no longer required in fitting. This is done in a user transparent manner, but is typically of no importance in use of GAMs. The routine's also handle \code{by} variables and will create default identifiability constraints. If a user defined smooth constructor handles \code{by} variables itself, then its returned smooth object should contain an object \code{by.done}. If this does not exist then \code{smoothCon} will use the default code. Similarly if a user defined \code{Predict.matrix} method handles \code{by} variables internally then the returned matrix should have a \code{"by.done"} attribute. Default centering constraints, that terms should sum to zero over the covariates, are produced unless the smooth constructor includes a matrix \code{C} of constraints. To have no constraints (in which case you had better have a full rank penalty!) the matrix \code{C} should have no rows. There is an option to use centering constraint that generate no, or limited infil, if the smoother has a sparse model matrix. \code{smoothCon} returns a list of smooths because factor \code{by} variables result in multiple copies of a smooth, each multiplied by the dummy variable associated with one factor level. \code{smoothCon} modifies the smooth object labels in the presence of \code{by} variables, to ensure that they are unique, it also stores the level of a by variable factor associated with a smooth, for later use by \code{PredictMat}. The parameterization used by \code{\link{gam}} can be controlled via \code{\link{gam.control}}. } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gam.control}}, \code{\link{smooth.construct}}, \code{\link{Predict.matrix}} } \examples{ ## example of using smoothCon and PredictMat to set up a basis ## to use for regression and make predictions using the result library(MASS) ## load for mcycle data. ## set up a smoother... sm <- smoothCon(s(times,k=10),data=mcycle,knots=NULL)[[1]] ## use it to fit a regression spline model... beta <- coef(lm(mcycle$accel~sm$X-1)) with(mcycle,plot(times,accel)) ## plot data times <- seq(0,60,length=200) ## creat prediction times ## Get matrix mapping beta to spline prediction at 'times' Xp <- PredictMat(sm,data.frame(times=times)) lines(times,Xp\%*\%beta) ## add smooth to plot ## Same again but using a penalized regression spline of ## rank 30.... sm <- smoothCon(s(times,k=30),data=mcycle,knots=NULL)[[1]] E <- t(mroot(sm$S[[1]])) ## square root penalty X <- rbind(sm$X,0.1*E) ## augmented model matrix y <- c(mcycle$accel,rep(0,nrow(E))) ## augmented data beta <- coef(lm(y~X-1)) ## fit penalized regression spline Xp <- PredictMat(sm,data.frame(times=times)) ## prediction matrix with(mcycle,plot(times,accel)) ## plot data lines(times,Xp\%*\%beta) ## overlay smooth } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/sp.vcov.Rd0000644000176200001440000000435013375470714013663 0ustar liggesusers\name{sp.vcov} \alias{sp.vcov} %- Also NEED an `\alias' for EACH other topic documented here. \title{Extract smoothing parameter estimator covariance matrix from (RE)ML GAM fit} \description{ Extracts the estimated covariance matrix for the log smoothing parameter estimates from a (RE)ML estimated \code{gam} object, provided the fit was with a method that evaluated the required Hessian. } \usage{ sp.vcov(x,edge.correct=TRUE,reg=1e-3) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{ a fitted model object of class \code{gam} as produced by \code{gam()}.} \item{edge.correct}{ if the model was fitted with \code{edge.correct=TRUE} (see \code{\link{gam.control}}), then thereturned covariance matrix will be for the edge corrected log smoothing parameters.} \item{reg}{regularizer for Hessian - default is equivalent to prior variance of 1000 on log smoothing parameters.} } \details{ Just extracts the inverse of the hessian matrix of the negative (restricted) log likelihood w.r.t the log smoothing parameters, if this has been obtained as part of fitting. } \value{ A matrix corresponding to the estimated covariance matrix of the log smoothing parameter estimators, if this can be extracted, otherwise \code{NULL}. If the scale parameter has been (RE)ML estimated (i.e. if the method was \code{"ML"} or \code{"REML"} and the scale parameter was unknown) then the last row and column relate to the log scale parameter. If \code{edge.correct=TRUE} and this was used in fitting then the edge corrected smoothing parameters are in attribute \code{lsp} of the returned matrix. } \author{Simon N. Wood \email{simon.wood@r-project.org} } \references{Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models (with discussion). Journal of the American Statistical Association 111, 1548-1575 \url{http://dx.doi.org/10.1080/01621459.2016.1180986} } \seealso{ \code{\link{gam}}, \code{\link{gam.vcomp}}} \examples{ require(mgcv) n <- 100 x <- runif(n);z <- runif(n) y <- sin(x*2*pi) + rnorm(n)*.2 mod <- gam(y~s(x,bs="cc",k=10)+s(z),knots=list(x=seq(0,1,length=10)), method="REML") sp.vcov(mod) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/formXtViX.Rd0000755000176200001440000000350713073161526014172 0ustar liggesusers\name{formXtViX} \alias{formXtViX} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Form component of GAMM covariance matrix} \description{ This is a service routine for \code{\link{gamm}}. Given, \eqn{V}{V}, an estimated covariance matrix obtained using \code{\link{extract.lme.cov2}} this routine forms a matrix square root of \eqn{ X^TV^{-1}X}{X'inv(V)X} as efficiently as possible, given the structure of \eqn{V}{V} (usually sparse). } \usage{ formXtViX(V,X) } %- maybe also `usage' for other objects documented here. \arguments{ \item{V}{ A data covariance matrix list returned from \code{\link{extract.lme.cov2}}} \item{X}{ A model matrix.} } \details{ The covariance matrix returned by \code{\link{extract.lme.cov2}} may be in a packed and re-ordered format, since it is usually sparse. Hence a special service routine is required to form the required products involving this matrix. } \value{ A matrix, R such that \code{crossprod(R)} gives \eqn{ X^TV^{-1}X}{X'inv(V)X}. } \references{ For \code{lme} see: Pinheiro J.C. and Bates, D.M. (2000) Mixed effects Models in S and S-PLUS. Springer For details of how GAMMs are set up for estimation using \code{lme} see: Wood, S.N. (2006) Low rank scale invariant tensor product smooths for Generalized Additive Mixed Models. Biometrics 62(4):1025-1036 \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gamm}}, \code{\link{extract.lme.cov2}} } \examples{ require(mgcv) library(nlme) data(ergoStool) b <- lme(effort ~ Type, data=ergoStool, random=~1|Subject) V1 <- extract.lme.cov(b, ergoStool) V2 <- extract.lme.cov2(b, ergoStool) X <- model.matrix(b, data=ergoStool) crossprod(formXtViX(V2, X)) t(X)%*%solve(V1,X) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/get.var.Rd0000755000176200001440000000313513073161526013627 0ustar liggesusers\name{get.var} \alias{get.var} %- Also NEED an `\alias' for EACH other topic documented here. \title{Get named variable or evaluate expression from list or data.frame} \description{ This routine takes a text string and a data frame or list. It first sees if the string is the name of a variable in the data frame/ list. If it is then the value of this variable is returned. Otherwise the routine tries to evaluate the expression within the data.frame/list (but nowhere else) and if successful returns the result. If neither step works then \code{NULL} is returned. The routine is useful for processing gam formulae. If the variable is a matrix then it is coerced to a numeric vector, by default.} \usage{ get.var(txt,data,vecMat=TRUE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{txt}{a text string which is either the name of a variable in \code{data} or when parsed is an expression that can be evaluated in \code{data}. It can also be neither in which case the function returns \code{NULL}.} \item{data}{A data frame or list.} \item{vecMat}{Should matrices be coerced to numeric vectors?} } \value{The evaluated variable or \code{NULL}. May be coerced to a numeric vector if it's a matrix.} \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \seealso{ \code{\link{gam} } } \examples{ require(mgcv) y <- 1:4;dat<-data.frame(x=5:10) get.var("x",dat) get.var("y",dat) get.var("x==6",dat) dat <- list(X=matrix(1:6,3,2)) get.var("X",dat) } \keyword{models} \keyword{smooth} \keyword{regression} %-- one or more .. mgcv/man/smooth.construct.tp.smooth.spec.Rd0000755000176200001440000002033613303547337020506 0ustar liggesusers\name{smooth.construct.tp.smooth.spec} \alias{smooth.construct.tp.smooth.spec} \alias{smooth.construct.ts.smooth.spec} \alias{tprs} %- Also NEED an `\alias' for EACH other topic documented here. \title{Penalized thin plate regression splines in GAMs} \description{\code{\link{gam}} can use isotropic smooths of any number of variables, specified via terms like \code{s(x,z,bs="tp",m=3)} (or just \code{s(x,z)} as this is the default basis). These terms are based on thin plate regression splines. \code{m} specifies the order of the derivatives in the thin plate spline penalty. If \code{m} is a vector of length 2 and the second element is zero, then the penalty null space of the smooth is not included in the smooth: this is useful if you need to test whether a smooth could be replaced by a linear term, or construct models with odd nesting structures. Thin plate regression splines are constructed by starting with the basis and penalty for a full thin plate spline and then truncating this basis in an optimal manner, to obtain a low rank smoother. Details are given in Wood (2003). One key advantage of the approach is that it avoids the knot placement problems of conventional regression spline modelling, but it also has the advantage that smooths of lower rank are nested within smooths of higher rank, so that it is legitimate to use conventional hypothesis testing methods to compare models based on pure regression splines. Note that the basis truncation does not change the meaning of the thin plate spline penalty (it penalizes exactly what it would have penalized for a full thin plate spline). The t.p.r.s. basis and penalties can become expensive to calculate for large datasets. For this reason the default behaviour is to randomly subsample \code{max.knots} unique data locations if there are more than \code{max.knots} such, and to use the sub-sample for basis construction. The sampling is always done with the same random seed to ensure repeatability (does not reset R RNG). \code{max.knots} is 2000, by default. Both seed and \code{max.knots} can be modified using the \code{xt} argument to \code{s}. Alternatively the user can supply knots from which to construct a basis. The \code{"ts"} smooths are t.p.r.s. with the penalty modified so that the term is shrunk to zero for high enough smoothing parameter, rather than being shrunk towards a function in the penalty null space (see details). } \usage{ \method{smooth.construct}{tp.smooth.spec}(object, data, knots) \method{smooth.construct}{ts.smooth.spec}(object, data, knots) } \arguments{ \item{object}{a smooth specification object, usually generated by a term \code{s(...,bs="tp",...)} or \code{s(...,bs="ts",...)}} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}} } \value{ An object of class \code{"tprs.smooth"} or \code{"ts.smooth"}. In addition to the usual elements of a smooth class documented under \code{\link{smooth.construct}}, this object will contain: \item{shift}{A record of the shift applied to each covariate in order to center it around zero and avoid any co-linearity problems that might otehrwise occur in the penalty null space basis of the term. } \item{Xu}{A matrix of the unique covariate combinations for this smooth (the basis is constructed by first stripping out duplicate locations).} \item{UZ}{The matrix mapping the t.p.r.s. parameters back to the parameters of a full thin plate spline.} \item{null.space.dimension}{The dimension of the space of functions that have zero wiggliness according to the wiggliness penalty for this term.} } \details{ The default basis dimension for this class is \code{k=M+k.def} where \code{M} is the null space dimension (dimension of unpenalized function space) and \code{k.def} is 8 for dimension 1, 27 for dimension 2 and 100 for higher dimensions. This is essentially arbitrary, and should be checked, but as with all penalized regression smoothers, results are statistically insensitive to the exact choise, provided it is not so small that it forces oversmoothing (the smoother's degrees of freedom are controlled primarily by its smoothing parameter). The default is to set \code{m} (the order of derivative in the thin plate spline penalty) to the smallest value satisfying \code{2m > d+1} where \code{d} if the number of covariates of the term: this yields `visually smooth' functions. In any case \code{2m>d} must be satisfied. The constructor is not normally called directly, but is rather used internally by \code{\link{gam}}. To use for basis setup it is recommended to use \code{\link{smooth.construct2}}. For these classes the specification \code{object} will contain information on how to handle large datasets in their \code{xt} field. The default is to randomly subsample 2000 `knots' from which to produce a tprs basis, if the number of unique predictor variable combinations in excess of 2000. The default can be modified via the \code{xt} argument to \code{\link{s}}. This is supplied as a list with elements \code{max.knots} and \code{seed} containing a number to use in place of 2000, and the random number seed to use (either can be missing). For these bases \code{knots} has two uses. Firstly, as mentioned already, for large datasets the calculation of the \code{tp} basis can be time-consuming. The user can retain most of the advantages of the t.p.r.s. approach by supplying a reduced set of covariate values from which to obtain the basis - typically the number of covariate values used will be substantially smaller than the number of data, and substantially larger than the basis dimension, \code{k}. This approach is the one taken automatically if the number of unique covariate values (combinations) exceeds \code{max.knots}. The second possibility is to avoid the eigen-decomposition used to find the t.p.r.s. basis altogether and simply use the basis implied by the chosen knots: this will happen if the number of knots supplied matches the basis dimension, \code{k}. For a given basis dimension the second option is faster, but gives poorer results (and the user must be quite careful in choosing knot locations). The shrinkage version of the smooth, eigen-decomposes the wiggliness penalty matrix, and sets its zero eigenvalues to small multiples of the smallest strictly positive eigenvalue. The penalty is then set to the matrix with eigenvectors corresponding to those of the original penalty, but eigenvalues set to the peturbed versions. This penalty matrix has full rank and shrinks the curve to zero at high enough smoothing parameters. } \references{ Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ require(mgcv); n <- 100; set.seed(2) x <- runif(n); y <- x + x^2*.2 + rnorm(n) *.1 ## is smooth significantly different from straight line? summary(gam(y~s(x,m=c(2,0))+x,method="REML")) ## not quite ## is smooth significatly different from zero? summary(gam(y~s(x),method="REML")) ## yes! ## Fool bam(...,discrete=TRUE) into (strange) nested ## model fit... set.seed(2) ## simulate some data... dat <- gamSim(1,n=400,dist="normal",scale=2) dat$x1a <- dat$x1 ## copy x1 so bam allows 2 copies of x1 ## Following removes identifiability problem, by removing ## linear terms from second smooth, and then re-inserting ## the one that was not a duplicate (x2)... b <- bam(y~s(x0,x1)+s(x1a,x2,m=c(2,0))+x2,data=dat,discrete=TRUE) ## example of knot based tprs... k <- 10; m <- 2 y <- y[order(x)];x <- x[order(x)] b <- gam(y~s(x,k=k,m=m),method="REML", knots=list(x=seq(0,1,length=k))) X <- model.matrix(b) par(mfrow=c(1,2)) plot(x,X[,1],ylim=range(X),type="l") for (i in 2:ncol(X)) lines(x,X[,i],col=i) ## compare with eigen based (default) b1 <- gam(y~s(x,k=k,m=m),method="REML") X1 <- model.matrix(b1) plot(x,X1[,1],ylim=range(X1),type="l") for (i in 2:ncol(X1)) lines(x,X1[,i],col=i) ## see ?gam } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.bs.smooth.spec.Rd0000644000176200001440000002132713433041132020447 0ustar liggesusers\name{smooth.construct.bs.smooth.spec} \alias{smooth.construct.bs.smooth.spec} \alias{Predict.matrix.Bspline.smooth} \alias{b.spline} %- Also NEED an `\alias' for EACH other topic documented here. \title{Penalized B-splines in GAMs} \description{\code{\link{gam}} can use smoothing splines based on univariate B-spline bases with derivative based penalties, specified via terms like \code{s(x,bs="bs",m=c(3,2))}. \code{m[1]} controls the spline order, with \code{m[1]=3} being a cubic spline, \code{m[1]=2} being quadratic, and so on. The integrated square of the \code{m[2]}th derivative is used as the penalty. So \code{m=c(3,2)} is a conventional cubic spline. Any further elements of \code{m}, after the first 2, define the order of derivative in further penalties. If \code{m} is supplied as a single number, then it is taken to be \code{m[1]} and \code{m[2]=m[1]-1}, which is only a conventional smoothing spline in the \code{m=3}, cubic spline case. Notice that the definition of the spline order in terms of \code{m[1]} is intuitive, but differs to that used with the \code{\link{tprs}} and \code{\link{p.spline}} bases. See details for options for controlling the interval over which the penalty is evaluated (which can matter if it is necessary to extrapolate). } \usage{ \method{smooth.construct}{bs.smooth.spec}(object, data, knots) \method{Predict.matrix}{Bspline.smooth}(object, data) } \arguments{ \item{object}{a smooth specification object, usually generated by a term \code{s(x,bs="bs",...)}} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}. See details for further information.} } \value{ An object of class \code{"Bspline.smooth"}. See \code{\link{smooth.construct}}, for the elements that this object will contain. } \details{ The basis and penalty are sparse (although sparse matrices are not used to represent them). \code{m[2]>m[1]} will generate an error, since in that case the penalty would be based on an undefined derivative of the basis, which makes no sense. The terms can have multiple penalties of different orders, for example \code{s(x,bs="bs",m=c(3,2,1,0))} specifies a cubic basis with 3 penalties: a conventional cubic spline penalty, an integrated square of first derivative penalty, and an integrated square of function value penalty. The default basis dimension, \code{k}, is the larger of 10 and \code{m[1]}. \code{m[1]} is the lower limit on basis dimension. If knots are supplied, then the number of supplied knots should be \code{k + m[1] + 1}, and the range of the middle \code{k-m[1]+1} knots should include all the covariate values. Alternatively, 2 knots can be supplied, denoting the lower and upper limits between which the spline can be evaluated (making this range too wide mean that there is no information about some basis coefficients, because the corresponding basis functions have a span that includes no data). Unlike P-splines, splines with derivative based penalties can have uneven knot spacing, without a problem. Another option is to supply 4 knots. Then the outer 2 define the interval over which the penalty is to be evaluated, while the inner 2 define an interval within which all but the outermost 2 knots should lie. Normally the outer 2 knots would be the interval over which predictions might be required, while the inner 2 knots define the interval within which the data lie. This option allows the penalty to apply over a wider interval than the data, while still placing most of the basis functions where the data are. This is useful in situations in which it is necessary to extrapolate slightly with a smooth. Only applying the penalty over the interval containing the data amounts to a model in which the function could be less smooth outside the interval than within it, and leads to very wide extrapolation confidence intervals. However the alternative of evaluating the penalty over the whole real line amounts to asserting certainty that the function has some derivative zeroed away from the data, which is equally unreasonable. It is prefereable to build a model in which the same smoothness assumtions apply over both data and extrapolation intervals, but not over the whole real line. See example code for practical illustration. Linear extrapolation is used for prediction that requires extrapolation (i.e. prediction outside the range of the interior \code{k-m[1]+1} knots --- the interval over which the penalty is evaluated). Such extrapolation is not allowed in basis construction, but is when predicting. It is possible to set a \code{deriv} flag in a smooth specification or smooth object, so that a model or prediction matrix produces the requested derivative of the spline, rather than evaluating it. } \section{WARNING}{\code{m[1]} directly controls the spline order here, which is intuitively sensible, but different to other bases.} \author{ Simon N. Wood \email{simon.wood@r-project.org}. Extrapolation ideas joint with David Miller.} \seealso{\code{\link{p.spline}}} \references{ Wood, S.N. (2017) P-splines with derivative based penalties and tensor product smoothing of unevenly distributed data. Statistics and Computing. 27(4) 985-989 \url{http://arxiv.org/abs/1605.02446} } \examples{ require(mgcv) set.seed(5) dat <- gamSim(1,n=400,dist="normal",scale=2) bs <- "bs" ## note the double penalty on the s(x2) term... b <- gam(y~s(x0,bs=bs,m=c(4,2))+s(x1,bs=bs)+s(x2,k=15,bs=bs,m=c(4,3,0))+ s(x3,bs=bs,m=c(1,0)),data=dat,method="REML") plot(b,pages=1) ## Extrapolation example, illustrating the importance of considering ## the penalty carefully if extrapolating... f3 <- function(x) 0.2 * x^11 * (10 * (1 - x))^6 + 10 * (10 * x)^3 * (1 - x)^10 ## test function n <- 100;x <- runif(n) y <- f3(x) + rnorm(n)*2 ## first a model with first order penalty over whole real line (red) b0 <- gam(y~s(x,m=1,k=20),method="ML") ## now a model with first order penalty evaluated over (-.5,1.5) (black) op <- options(warn=-1) b <- gam(y~s(x,bs="bs",m=c(3,1),k=20),knots=list(x=c(-.5,0,1,1.5)), method="ML") options(op) ## and the equivalent with same penalty over data range only (blue) b1 <- gam(y~s(x,bs="bs",m=c(3,1),k=20),method="ML") pd <- data.frame(x=seq(-.7,1.7,length=200)) fv <- predict(b,pd,se=TRUE) ul <- fv$fit + fv$se.fit*2; ll <- fv$fit - fv$se.fit*2 plot(x,y,xlim=c(-.7,1.7),ylim=range(c(y,ll,ul)),main= "Order 1 penalties: red tps; blue bs on (0,1); black bs on (-.5,1.5)") ## penalty defined on (-.5,1.5) gives plausible predictions and intervals ## over this range... lines(pd$x,fv$fit);lines(pd$x,ul,lty=2);lines(pd$x,ll,lty=2) fv <- predict(b0,pd,se=TRUE) ul <- fv$fit + fv$se.fit*2; ll <- fv$fit - fv$se.fit*2 ## penalty defined on whole real line gives constant width intervals away ## from data, as slope there must be zero, to avoid infinite penalty: lines(pd$x,fv$fit,col=2) lines(pd$x,ul,lty=2,col=2);lines(pd$x,ll,lty=2,col=2) fv <- predict(b1,pd,se=TRUE) ul <- fv$fit + fv$se.fit*2; ll <- fv$fit - fv$se.fit*2 ## penalty defined only over the data interval (0,1) gives wild and wide ## extrapolation since penalty has been `turned off' outside data range: lines(pd$x,fv$fit,col=4) lines(pd$x,ul,lty=2,col=4);lines(pd$x,ll,lty=2,col=4) ## construct smooth of x. Model matrix sm$X and penalty ## matrix sm$S[[1]] will have many zero entries... x <- seq(0,1,length=100) sm <- smoothCon(s(x,bs="bs"),data.frame(x))[[1]] ## another example checking penalty numerically... m <- c(4,2); k <- 15; b <- runif(k) sm <- smoothCon(s(x,bs="bs",m=m,k=k),data.frame(x), scale.penalty=FALSE)[[1]] sm$deriv <- m[2] h0 <- 1e-3; xk <- sm$knots[(m[1]+1):(k+1)] Xp <- PredictMat(sm,data.frame(x=seq(xk[1]+h0/2,max(xk)-h0/2,h0))) sum((Xp\%*\%b)^2*h0) ## numerical approximation to penalty b\%*\%sm$S[[1]]\%*\%b ## `exact' version ## ...repeated with uneven knot spacing... m <- c(4,2); k <- 15; b <- runif(k) ## produce the required 20 unevenly spaced knots... knots <- data.frame(x=c(-.4,-.3,-.2,-.1,-.001,.05,.15, .21,.3,.32,.4,.6,.65,.75,.9,1.001,1.1,1.2,1.3,1.4)) sm <- smoothCon(s(x,bs="bs",m=m,k=k),data.frame(x), knots=knots,scale.penalty=FALSE)[[1]] sm$deriv <- m[2] h0 <- 1e-3; xk <- sm$knots[(m[1]+1):(k+1)] Xp <- PredictMat(sm,data.frame(x=seq(xk[1]+h0/2,max(xk)-h0/2,h0))) sum((Xp\%*\%b)^2*h0) ## numerical approximation to penalty b\%*\%sm$S[[1]]\%*\%b ## `exact' version } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/initial.sp.Rd0000755000176200001440000000413113073161526014330 0ustar liggesusers\name{initial.sp} \alias{initial.sp} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Starting values for multiple smoothing parameter estimation} \description{ Finds initial smoothing parameter guesses for multiple smoothing parameter estimation. The idea is to find values such that the estimated degrees of freedom per penalized parameter should be well away from 0 and 1 for each penalized parameter, thus ensuring that the values are in a region of parameter space where the smoothing parameter estimation criterion is varying substantially with smoothing parameter value. } %- end description \usage{ initial.sp(X,S,off,expensive=FALSE,XX=FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{X}{is the model matrix.} \item{S}{ is a list of of penalty matrices. \code{S[[i]]} is the ith penalty matrix, but note that it is not stored as a full matrix, but rather as the smallest square matrix including all the non-zero elements of the penalty matrix. Element 1,1 of \code{S[[i]]} occupies element \code{off[i]}, \code{off[i]} of the ith penalty matrix. Each \code{S[[i]]} must be positive semi-definite. } \item{off}{is an array indicating the first parameter in the parameter vector that is penalized by the penalty involving \code{S[[i]]}.} \item{expensive}{if \code{TRUE} then the overall amount of smoothing is adjusted so that the average degrees of freedom per penalized parameter is exactly 0.5: this is numerically costly. } \item{XX}{if \code{TRUE} then \code{X} contains \eqn{X^TX}{X'X}, rather than \eqn{X}{X}.} } \details{ Basically uses a crude approximation to the estimated degrees of freedom per model coefficient, to try and find smoothing parameters which bound these e.d.f.'s away from 0 and 1. Usually only called by \code{\link{magic}} and \code{\link{gam}}. } \value{ An array of initial smoothing parameter estimates. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{magic}}, \code{\link{gam.outer}}, \code{\link{gam}}, } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/coxpht.Rd0000755000176200001440000001224113426265156013572 0ustar liggesusers\name{cox.pht} \alias{cox.pht} %- Also NEED an `\alias' for EACH other topic documented here. \title{Additive Cox proportional hazard models with time varying covariates} \description{The \code{cox.ph} family only allows one set of covariate values per subject. If each subject has several time varying covariate measurements then it is still possible to fit a proportional hazards regression model, via an equivalent Poisson model. The recipe is provided by Whitehead (1980) and is equally valid in the smooth additive case. Its drawback is that the equivalent Poisson dataset can be quite large. The trick is to generate an artificial Poisson observation for each subject in the risk set at each non-censored event time. The corresponding covariate values for each subject are whatever they are at the event time, while the Poisson response is zero for all subjects except those experiencing the event at that time (this corresponds to Peto's correction for ties). The linear predictor for the model must include an intercept for each event time (the cumulative sum of the exponential of these is the Breslow estimate of the baseline hazard). Below is some example code employing this trick for the \code{\link[survival]{pbcseq}} data from the \code{survival} package. It uses \code{\link{bam}} for fitting with the \code{discrete=TRUE} option for efficiency: there is some approximation involved in doing this, and the exact equivalent to what is done in \code{\link{cox.ph}} is rather obtained by using \code{\link{gam}} with \code{method="REML"} (taking some 14 times the computational time for the example below). The function \code{tdpois} in the example code uses crude piecewise constant interpolation for the covariates, in which the covariate value at an event time is taken to be whatever it was the previous time that it was measured. Obviously more sophisticated interpolation schemes might be preferable. } \references{ Whitehead (1980) Fitting Cox's regression model to survival data using GLIM. Applied Statistics 29(3):268-275 } \examples{ require(mgcv);require(survival) ## First define functions for producing Poisson model data frame app <- function(x,t,to) { ## wrapper to approx for calling from apply... y <- if (sum(!is.na(x))<1) rep(NA,length(to)) else approx(t,x,to,method="constant",rule=2)$y if (is.factor(x)) factor(levels(x)[y],levels=levels(x)) else y } ## app tdpois <- function(dat,event="z",et="futime",t="day",status="status1", id="id") { ## dat is data frame. id is patient id; et is event time; t is ## observation time; status is 1 for death 0 otherwise; ## event is name for Poisson response. if (event \%in\% names(dat)) warning("event name in use") require(utils) ## for progress bar te <- sort(unique(dat[[et]][dat[[status]]==1])) ## event times sid <- unique(dat[[id]]) inter <- interactive() if (inter) prg <- txtProgressBar(min = 0, max = length(sid), initial = 0, char = "=",width = NA, title="Progress", style = 3) ## create dataframe for poisson model data dat[[event]] <- 0; start <- 1 dap <- dat[rep(1:length(sid),length(te)),] for (i in 1:length(sid)) { ## work through patients di <- dat[dat[[id]]==sid[i],] ## ith patient's data tr <- te[te <= di[[et]][1]] ## times required for this patient ## Now do the interpolation of covariates to event times... um <- data.frame(lapply(X=di,FUN=app,t=di[[t]],to=tr)) ## Mark the actual event... if (um[[et]][1]==max(tr)&&um[[status]][1]==1) um[[event]][nrow(um)] <- 1 um[[et]] <- tr ## reset time to relevant event times dap[start:(start-1+nrow(um)),] <- um ## copy to dap start <- start + nrow(um) if (inter) setTxtProgressBar(prg, i) } if (inter) close(prg) dap[1:(start-1),] } ## tdpois ## The following typically takes a minute or less... \donttest{ ## Convert pbcseq to equivalent Poisson form... pbcseq$status1 <- as.numeric(pbcseq$status==2) ## death indicator pb <- tdpois(pbcseq) ## conversion pb$tf <- factor(pb$futime) ## add factor for event time ## Fit Poisson model... b <- bam(z ~ tf - 1 + sex + trt + s(sqrt(protime)) + s(platelet)+ s(age)+ s(bili)+s(albumin), family=poisson,data=pb,discrete=TRUE,nthreads=2) par(mfrow=c(2,3)) plot(b,scale=0) ## compute residuals... chaz <- tapply(fitted(b),pb$id,sum) ## cum haz by subject d <- tapply(pb$z,pb$id,sum) ## censoring indicator mrsd <- d - chaz ## Martingale drsd <- sign(mrsd)*sqrt(-2*(mrsd + d*log(chaz))) ## deviance ## plot survivor function and s.e. band for subject 25 te <- sort(unique(pb$futime)) ## event times di <- pbcseq[pbcseq$id==25,] ## data for subject 25 pd <- data.frame(lapply(X=di,FUN=app,t=di$day,to=te)) ## interpolate to te pd$tf <- factor(te) X <- predict(b,newdata=pd,type="lpmatrix") eta <- drop(X\%*\%coef(b)); H <- cumsum(exp(eta)) J <- apply(exp(eta)*X,2,cumsum) se <- diag(J\%*\%vcov(b)\%*\%t(J))^.5 plot(stepfun(te,c(1,exp(-H))),do.points=FALSE,ylim=c(0.7,1), ylab="S(t)",xlab="t (days)",main="",lwd=2) lines(stepfun(te,c(1,exp(-H+se))),do.points=FALSE) lines(stepfun(te,c(1,exp(-H-se))),do.points=FALSE) rug(pbcseq$day[pbcseq$id==25]) ## measurement times } } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/trichol.Rd0000755000176200001440000000312413073161526013723 0ustar liggesusers\name{trichol} \alias{trichol} %- Also NEED an `\alias' for EACH other topic documented here. \title{Choleski decomposition of a tri-diagonal matrix} \description{ Computes Choleski decomposition of a (symmetric positive definite) tri-diagonal matrix stored as a leading diagonal and sub/super diagonal. } \usage{ trichol(ld,sd) } %- maybe also `usage' for other objects documented here. \arguments{ \item{ld}{leading diagonal of matrix} \item{sd}{sub-super diagonal of matrix} } \value{ A list with elements \code{ld} and \code{sd}. \code{ld} is the leading diagonal and \code{sd} is the super diagonal of bidiagonal matrix \eqn{\bf B}{B} where \eqn{{\bf B}^T{\bf B} = {\bf T}}{B'B=T} and \eqn{\bf T}{T} is the original tridiagonal matrix. } \details{Calls \code{dpttrf} from \code{LAPACK}. The point of this is that it has \eqn{O(n)}{O(n)} computational cost, rather than the \eqn{O(n^3)}{O(n^3)} required by dense matrix methods. } \seealso{\code{\link{bandchol}}} \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Anderson, E., Bai, Z., Bischof, C., Blackford, S., Dongarra, J., Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A. and Sorensen, D., 1999. LAPACK Users' guide (Vol. 9). Siam. } \examples{ require(mgcv) ## simulate some diagonals... set.seed(19); k <- 7 ld <- runif(k)+1 sd <- runif(k-1) -.5 ## get diagonals of chol factor... trichol(ld,sd) ## compare to dense matrix result... A <- diag(ld);for (i in 1:(k-1)) A[i,i+1] <- A[i+1,i] <- sd[i] R <- chol(A) diag(R);diag(R[,-1]) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/totalPenaltySpace.Rd0000644000176200001440000000165413137076643015724 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mgcvExports.R \name{totalPenaltySpace} \alias{totalPenaltySpace} \title{Obtaining (orthogonal) basis for null space and range of the penalty matrix} \usage{ totalPenaltySpace(S, H, off, p) } \arguments{ \item{S}{a list of penalty matrices, in packed form.} \item{H}{the coefficient matrix of an user supplied fixed quadratic penalty on the parameters of the GAM.} \item{off}{a vector where the i-th element is the offset for the i-th matrix.} \item{p}{total number of parameters.} } \value{ A list of matrix square roots such that \code{S[[i]]=B[[i]]\%*\%t(B[[i]])}. } \description{ INTERNAL function to obtain (orthogonal) basis for the null space and range space of the penalty, and obtain actual null space dimension components are roughly rescaled to avoid any dominating. } \author{ Simon N. Wood . } mgcv/man/ls.size.Rd0000644000176200001440000000156613073161526013653 0ustar liggesusers\name{ls.size} \alias{ls.size} %- Also NEED an `\alias' for EACH other topic documented here. \title{Size of list elements} \description{Produces a named array giving the size, in bytes, of the elements of a list. } \usage{ ls.size(x) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{ A list.} } \value{ A numeric vector giving the size in bytes of each element of the list \code{x}. The elements of the array have the same names as the elements of the list. If \code{x} is not a list then its size in bytes is returned, un-named. } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \examples{ library(mgcv) b <- list(M=matrix(runif(100),10,10),quote= "The world is ruled by idiots because only an idiot would want to rule the world.", fam=binomial()) ls.size(b) } mgcv/man/bam.update.Rd0000644000176200001440000000720613137076654014311 0ustar liggesusers\name{bam.update} \alias{bam.update} %- Also NEED an `\alias' for EACH other topic documented here. \title{Update a strictly additive bam model for new data.} \description{ Gaussian with identity link models fitted by \code{\link{bam}} can be efficiently updated as new data becomes available, by simply updating the QR decomposition on which estimation is based, and re-optimizing the smoothing parameters, starting from the previous estimates. This routine implements this. } \usage{ bam.update(b,data,chunk.size=10000) } %- maybe also `usage' for other objects documented here. \arguments{ \item{b}{ A \code{gam} object fitted by \code{\link{bam}} and representing a strictly additive model (i.e. \code{gaussian} errors, \code{identity} link).} \item{data}{Extra data to augment the original data used to obtain \code{b}. Must include a \code{weights} column if the original fit was weighted and a \code{AR.start} column if \code{AR.start} was non \code{NULL} in original fit.} \item{chunk.size}{size of subsets of data to process in one go when getting fitted values.} } \value{ An object of class \code{"gam"} as described in \code{\link{gamObject}}. } \details{ \code{bam.update} updates the QR decomposition of the (weighted) model matrix of the GAM represented by \code{b} to take account of the new data. The orthogonal factor multiplied by the response vector is also updated. Given these updates the model and smoothing parameters can be re-estimated, as if the whole dataset (original and the new data) had been fitted in one go. The function will use the same AR1 model for the residuals as that employed in the original model fit (see \code{rho} parameter of \code{\link{bam}}). Note that there may be small numerical differences in fit between fitting the data all at once, and fitting in stages by updating, if the smoothing bases used have any of their details set with reference to the data (e.g. default knot locations). } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \section{WARNINGS }{ AIC computation does not currently take account of AR model, if used. } \seealso{\code{\link{mgcv-package}}, \code{\link{bam}} } \examples{ library(mgcv) ## following is not *very* large, for obvious reasons... set.seed(8) n <- 5000 dat <- gamSim(1,n=n,dist="normal",scale=5) dat[c(50,13,3000,3005,3100),]<- NA dat1 <- dat[(n-999):n,] dat0 <- dat[1:(n-1000),] bs <- "ps";k <- 20 method <- "GCV.Cp" b <- bam(y ~ s(x0,bs=bs,k=k)+s(x1,bs=bs,k=k)+s(x2,bs=bs,k=k)+ s(x3,bs=bs,k=k),data=dat0,method=method) b1 <- bam.update(b,dat1) b2 <- bam.update(bam.update(b,dat1[1:500,]),dat1[501:1000,]) b3 <- bam(y ~ s(x0,bs=bs,k=k)+s(x1,bs=bs,k=k)+s(x2,bs=bs,k=k)+ s(x3,bs=bs,k=k),data=dat,method=method) b1;b2;b3 ## example with AR1 errors... e <- rnorm(n) for (i in 2:n) e[i] <- e[i-1]*.7 + e[i] dat$y <- dat$f + e*3 dat[c(50,13,3000,3005,3100),]<- NA dat1 <- dat[(n-999):n,] dat0 <- dat[1:(n-1000),] b <- bam(y ~ s(x0,bs=bs,k=k)+s(x1,bs=bs,k=k)+s(x2,bs=bs,k=k)+ s(x3,bs=bs,k=k),data=dat0,rho=0.7) b1 <- bam.update(b,dat1) summary(b1);summary(b2);summary(b3) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. \concept{Varying coefficient model} \concept{Functional linear model} \concept{Penalized GLM} \concept{Generalized Additive Model} \concept{Penalized regression} \concept{Spline smoothing} \concept{Penalized regression spline} \concept{Generalized Cross Validation} \concept{Smoothing parameter selection} \concept{tensor product smoothing} \concept{thin plate spline} \concept{P-spline} \concept{Generalized ridge regression} mgcv/man/smooth.construct.ps.smooth.spec.Rd0000755000176200001440000001520013073161526020473 0ustar liggesusers\name{smooth.construct.ps.smooth.spec} \alias{smooth.construct.ps.smooth.spec} \alias{smooth.construct.cp.smooth.spec} \alias{p.spline} \alias{cyclic.p.spline} %- Also NEED an `\alias' for EACH other topic documented here. \title{P-splines in GAMs} \description{\code{\link{gam}} can use univariate P-splines as proposed by Eilers and Marx (1996), specified via terms like \code{s(x,bs="ps")}. These terms use B-spline bases penalized by discrete penalties applied directly to the basis coefficients. Cyclic P-splines are specified by model terms like \code{s(x,bs="cp",...)}. These bases can be used in tensor product smooths (see \code{\link{te}}). The advantage of P-splines is the flexible way that penalty and basis order can be mixed. This often provides a useful way of `taming' an otherwise poorly behave smooth. However, in regular use, splines with derivative based penalties (e.g. \code{"tp"} or \code{"cr"} bases) tend to result in slightly better MSE performance, presumably because the good approximation theoretic properties of splines are rather closely connected to the use of derivative penalties. } \usage{ \method{smooth.construct}{ps.smooth.spec}(object, data, knots) \method{smooth.construct}{cp.smooth.spec}(object, data, knots) } \arguments{ \item{object}{a smooth specification object, usually generated by a term \code{s(x,bs="ps",...)} or \code{s(x,bs="cp",...)}} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}. See details for further information.} } \value{ An object of class \code{"pspline.smooth"} or \code{"cp.smooth"}. See \code{\link{smooth.construct}}, for the elements that this object will contain. } \details{A smooth term of the form \code{s(x,bs="ps",m=c(2,3))} specifies a 2nd order P-spline basis (cubic spline), with a third order difference penalty (0th order is a ridge penalty) on the coefficients. If \code{m} is a single number then it is taken as the basis order and penalty order. The default is the `cubic spline like' \code{m=c(2,2)}. The default basis dimension, \code{k}, is the larger of 10 and \code{m[1]+1} for a \code{"ps"} terms and the larger of 10 and \code{m[1]} for a \code{"cp"} term. \code{m[1]+1} and \code{m[1]} are the lower limits on basis dimension for the two types. If knots are supplied, then the number of knots should be one more than the basis dimension (i.e. \code{k+1}) for a \code{"cp"}smooth. For the \code{"ps"} basis the number of supplied knots should be \code{k + m[1] + 2}, and the range of the middle \code{k-m[1]} knots should include all the covariate values. See example. Alternatively, for both types of smooth, 2 knots can be supplied, denoting the lower and upper limits between which the spline can be evaluated (Don't make this range too wide, however, or you can end up with no information about some basis coefficients, because the corresponding basis functions have a span that includes no data!). Note that P-splines don't make much sense with uneven knot spacing. Linear extrapolation is used for prediction that requires extrapolation (i.e. prediction outside the range of the interior \code{k-m[1]} knots). Such extrapolation is not allowed in basis construction, but is when predicting. For the \code{"ps"} basis it is possible to set flags in the smooth specification object, requesting setup according to the SCOP-spline monotonic smoother construction of Pya and Wood (2015). As yet this is not supported by any modelling functions in \code{mgcv} (see package \code{scam}). Similarly it is possible to set a \code{deriv} flag in a smooth specification or smooth object, so that a model or prediction matrix produces the requested derivative of the spline, rather than evaluating it. See examples below. } \references{ Eilers, P.H.C. and B.D. Marx (1996) Flexible Smoothing with B-splines and Penalties. Statistical Science, 11(2):89-121 Pya, N., and Wood, S.N. (2015). Shape constrained additive models. Statistics and Computing, 25(3), 543-559. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{cSplineDes}}, \code{\link{adaptive.smooth}}} \examples{ ## see ?gam ## cyclic example ... require(mgcv) set.seed(6) x <- sort(runif(200)*10) z <- runif(200) f <- sin(x*2*pi/10)+.5 y <- rpois(exp(f),exp(f)) ## finished simulating data, now fit model... b <- gam(y ~ s(x,bs="cp") + s(z,bs="ps"),family=poisson) ## example with supplied knot ranges for x and z (can do just one) b <- gam(y ~ s(x,bs="cp") + s(z,bs="ps"),family=poisson, knots=list(x=c(0,10),z=c(0,1))) ## example with supplied knots... bk <- gam(y ~ s(x,bs="cp",k=12) + s(z,bs="ps",k=13),family=poisson, knots=list(x=seq(0,10,length=13),z=(-3):13/10)) ## plot results... par(mfrow=c(2,2)) plot(b,select=1,shade=TRUE);lines(x,f-mean(f),col=2) plot(b,select=2,shade=TRUE);lines(z,0*z,col=2) plot(bk,select=1,shade=TRUE);lines(x,f-mean(f),col=2) plot(bk,select=2,shade=TRUE);lines(z,0*z,col=2) ## Example using montonic constraints via the SCOP-spline ## construction, and of computng derivatives... x <- seq(0,1,length=100); dat <- data.frame(x) sspec <- s(x,bs="ps") sspec$mono <- 1 sm <- smoothCon(sspec,dat)[[1]] sm$deriv <- 1 Xd <- PredictMat(sm,dat) ## generate random coeffients in the unconstrainted ## parameterization... b <- runif(10)*3-2.5 ## exponentiate those parameters indicated by sm$g.index ## to obtain coefficients meeting the constraints... b[sm$g.index] <- exp(b[sm$g.index]) ## plot monotonic spline and its derivative par(mfrow=c(2,2)) plot(x,sm$X\%*\%b,type="l",ylab="f(x)") plot(x,Xd\%*\%b,type="l",ylab="f'(x)") ## repeat for decrease... sspec$mono <- -1 sm1 <- smoothCon(sspec,dat)[[1]] sm1$deriv <- 1 Xd1 <- PredictMat(sm1,dat) plot(x,sm1$X\%*\%b,type="l",ylab="f(x)") plot(x,Xd1\%*\%b,type="l",ylab="f'(x)") ## Now with sum to zero constraints as well... sspec$mono <- 1 sm <- smoothCon(sspec,dat,absorb.cons=TRUE)[[1]] sm$deriv <- 1 Xd <- PredictMat(sm,dat) b <- b[-1] ## dropping first param plot(x,sm$X\%*\%b,type="l",ylab="f(x)") plot(x,Xd\%*\%b,type="l",ylab="f'(x)") sspec$mono <- -1 sm1 <- smoothCon(sspec,dat,absorb.cons=TRUE)[[1]] sm1$deriv <- 1 Xd1 <- PredictMat(sm1,dat) plot(x,sm1$X\%*\%b,type="l",ylab="f(x)") plot(x,Xd1\%*\%b,type="l",ylab="f'(x)") } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/rTweedie.Rd0000755000176200001440000000370213073161526014031 0ustar liggesusers\name{rTweedie} \alias{rTweedie} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generate Tweedie random deviates} \description{ Generates Tweedie random deviates, for powers between 1 and 2. } \usage{ rTweedie(mu,p=1.5,phi=1) } \arguments{ \item{mu}{vector of expected values for the deviates to be generated. One deviate generated for each element of \code{mu}.} \item{p}{the variance of a deviate is proportional to its mean, \code{mu} to the power \code{p}. \code{p} must be between 1 and 2. 1 is Poisson like (exactly Poisson if \code{phi=1}), 2 is gamma. } \item{phi}{The scale parameter. Variance of the deviates is given by is \code{phi*mu^p}.} } \value{ A vector of random deviates from a Tweedie distribution, expected value vector \code{mu}, variance vector \code{phi*mu^p}. } \details{ A Tweedie random variable with 1. } mgcv/man/smooth.construct.cr.smooth.spec.Rd0000755000176200001440000001200213303547351020452 0ustar liggesusers\name{smooth.construct.cr.smooth.spec} \alias{smooth.construct.cr.smooth.spec} \alias{smooth.construct.cs.smooth.spec} \alias{smooth.construct.cc.smooth.spec} \alias{cubic.regression.spline} \alias{cyclic.cubic.spline} %- Also NEED an `\alias' for EACH other topic documented here. \title{Penalized Cubic regression splines in GAMs} \description{\code{\link{gam}} can use univariate penalized cubic regression spline smooths, specified via terms like \code{s(x,bs="cr")}. \code{s(x,bs="cs")} specifies a penalized cubic regression spline which has had its penalty modified to shrink towards zero at high enough smoothing parameters (as the smoothing parameter goes to infinity a normal cubic spline tends to a straight line.) \code{s(x,bs="cc")} specifies a cyclic penalized cubic regression spline smooth. `Cardinal' spline bases are used: Wood (2017) sections 5.3.1 and 5.3.2 gives full details. These bases have very low setup costs. For a given basis dimension, \code{k}, they typically perform a little less well then thin plate regression splines, but a little better than p-splines. See \code{\link{te}} to use these bases in tensor product smooths of several variables. Default \code{k} is 10. } \usage{ \method{smooth.construct}{cr.smooth.spec}(object, data, knots) \method{smooth.construct}{cs.smooth.spec}(object, data, knots) \method{smooth.construct}{cc.smooth.spec}(object, data, knots) } \arguments{ \item{object}{a smooth specification object, usually generated by a term \code{s(...,bs="cr",...)}, \code{s(...,bs="cs",...)} or \code{s(...,bs="cc",...)}} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}. See details.} } \value{ An object of class \code{"cr.smooth"} \code{"cs.smooth"} or \code{"cyclic.smooth"}. In addition to the usual elements of a smooth class documented under \code{\link{smooth.construct}}, this object will contain: \item{xp}{giving the knot locations used to generate the basis.} \item{BD}{class \code{"cyclic.smooth"} objects include matrix \code{BD} which transforms function values at the knots to second derivatives at the knots.} } \details{ The constructor is not normally called directly, but is rather used internally by \code{\link{gam}}. To use for basis setup it is recommended to use \code{\link{smooth.construct2}}. If they are not supplied then the knots of the spline are placed evenly throughout the covariate values to which the term refers: For example, if fitting 101 data with an 11 knot spline of \code{x} then there would be a knot at every 10th (ordered) \code{x} value. The parameterization used represents the spline in terms of its values at the knots. The values at neighbouring knots are connected by sections of cubic polynomial constrained to be continuous up to and including second derivative at the knots. The resulting curve is a natural cubic spline through the values at the knots (given two extra conditions specifying that the second derivative of the curve should be zero at the two end knots). The shrinkage version of the smooth, eigen-decomposes the wiggliness penalty matrix, and sets its 2 zero eigenvalues to small multiples of the smallest strictly positive eigenvalue. The penalty is then set to the matrix with eigenvectors corresponding to those of the original penalty, but eigenvalues set to the peturbed versions. This penalty matrix has full rank and shrinks the curve to zero at high enough smoothing parameters. Note that the cyclic smoother will wrap at the smallest and largest covariate values, unless knots are supplied. If only two knots are supplied then they are taken as the end points of the smoother (provided all the data lie between them), and the remaining knots are generated automatically. The cyclic smooth is not subject to the condition that second derivatives go to zero at the first and last knots. } \references{ Wood S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ ## cyclic spline example... require(mgcv) set.seed(6) x <- sort(runif(200)*10) z <- runif(200) f <- sin(x*2*pi/10)+.5 y <- rpois(exp(f),exp(f)) ## finished simulating data, now fit model... b <- gam(y ~ s(x,bs="cc",k=12) + s(z),family=poisson, knots=list(x=seq(0,10,length=12))) ## or more simply b <- gam(y ~ s(x,bs="cc",k=12) + s(z),family=poisson, knots=list(x=c(0,10))) ## plot results... par(mfrow=c(2,2)) plot(x,y);plot(b,select=1,shade=TRUE);lines(x,f-mean(f),col=2) plot(b,select=2,shade=TRUE);plot(fitted(b),residuals(b)) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/gaulss.Rd0000755000176200001440000000657613137076654013603 0ustar liggesusers\name{gaulss} \alias{gaulss} %- Also NEED an `\alias' for EACH other topic documented here. \title{Gaussian location-scale model family} \description{The \code{gaulss} family implements Gaussian location scale additive models in which the mean and the logb of the standard deviation (see details) can depend on additive smooth predictors. Useable only with \code{\link{gam}}, the linear predictors are specified via a list of formulae. } \usage{ gaulss(link=list("identity","logb"),b=0.01) } \arguments{ \item{link}{two item list specifying the link for the mean and the standard deviation. See details.} \item{b}{The minumum standard deviation, for the \code{"logb"} link.} } \value{ An object inheriting from class \code{general.family}. } \details{Used with \code{\link{gam}} to fit Gaussian location - scale models. \code{gam} is called with a list containing 2 formulae, the first specifies the response on the left hand side and the structure of the linear predictor for the mean on the right hand side. The second is one sided, specifying the linear predictor for the standard deviation on the right hand side. Link functions \code{"identity"}, \code{"inverse"}, \code{"log"} and \code{"sqrt"} are available for the mean. For the standard deviation only the \code{"logb"} link is implemented: \eqn{\eta = \log(\sigma - b)}{eta = log(sigma-b)} and \eqn{\sigma = b + \exp(\eta)}{sigma = b + exp(eta)}. This link is designed to avoid singularities in the likelihood caused by the standard deviation tending to zero. Note that internally the family is parameterized in terms of the \eqn{\tau=\sigma^{-1}}{tau=1/sigma}, i.e. the standard deviation of the precision, so the link and inverse link are coded to reflect this, however the reltaionships between the linear predictor and the standard deviation are as given above. The fitted values for this family will be a two column matrix. The first column is the mean, and the second column is the inverse of the standard deviation. Predictions using \code{\link{predict.gam}} will also produce 2 column matrices for \code{type} \code{"link"} and \code{"response"}. The second column when \code{type="response"} is again on the reciprocal standard deviation scale (i.e. the square root precision scale). The second column when \code{type="link"} is \eqn{\log(\sigma - b)}{log(sigma-b)}. Also \code{\link{plot.gam}} will plot smooths relating to \eqn{\sigma}{sigma} on the \eqn{\log(\sigma - b)}{log(sigma-b)} scale (so high values correspond to high standard deviation and low values to low standard deviation). Similarly the smoothing penalties are applied on the (log) standard deviation scale, not the log precision scale. The null deviance reported for this family is the sum of squares of the difference between the response and the mean response divided by the standard deviation of the response according to the model. The deviance is the sum of squares of residuals divided by model standard deviations. } \references{ Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association 111, 1548-1575 \url{http://dx.doi.org/10.1080/01621459.2016.1180986} } \examples{ library(mgcv);library(MASS) b <- gam(list(accel~s(times,k=20,bs="ad"),~s(times)), data=mcycle,family=gaulss()) summary(b) plot(b,pages=1,scale=0) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/gam.outer.Rd0000755000176200001440000000537413073161526014171 0ustar liggesusers\name{gam.outer} \alias{gam.outer} %- Also NEED an `\alias' for EACH other topic documented here. \title{Minimize GCV or UBRE score of a GAM using `outer' iteration} \description{Estimation of GAM smoothing parameters is most stable if optimization of the smoothness selection score (GCV, GACV, UBRE/AIC, REML, ML etc) is outer to the penalized iteratively re-weighted least squares scheme used to estimate the model given smoothing parameters. This routine optimizes a smoothness selection score in this way. Basically the score is evaluated for each trial set of smoothing parameters by estimating the GAM for those smoothing parameters. The score is minimized w.r.t. the parameters numerically, using \code{newton} (default), \code{bfgs}, \code{optim} or \code{nlm}. Exact (first and second) derivatives of the score can be used by fitting with \code{\link{gam.fit3}}. This improves efficiency and reliability relative to relying on finite difference derivatives. Not normally called directly, but rather a service routine for \code{\link{gam}}. } \usage{ gam.outer(lsp,fscale,family,control,method,optimizer, criterion,scale,gamma,G,start=NULL,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{lsp}{The log smoothing parameters.} \item{fscale}{Typical scale of the GCV or UBRE/AIC score.} \item{family}{the model family.} \item{control}{control argument to pass to \code{\link{gam.fit}} if pure finite differencing is being used.} \item{method}{method argument to \code{\link{gam}} defining the smoothness criterion to use (but depending on whether or not scale known).} \item{optimizer}{The argument to \code{\link{gam}} defining the numerical optimization method to use. } \item{criterion}{Which smoothness selction criterion to use. One of \code{"UBRE"}, \code{"GCV"}, \code{"GACV"}, \code{"REML"} or \code{"P-REML"}. } \item{scale}{Supplied scale parameter. Positive indicates known.} \item{gamma}{ The degree of freedom inflation factor for the GCV/UBRE/AIC score.} \item{G}{List produced by \code{mgcv:::gam.setup}, containing most of what's needed to actually fit a GAM.} \item{start}{starting parameter values.} \item{...}{other arguments, typically for passing on to \code{gam.fit3} (ultimately).} } \details{ See Wood (2008) for full details on `outer iteration'. } \references{ Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{gam.fit3}}, \code{\link{gam}}, \code{\link{magic}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/gamlss.etamu.Rd0000644000176200001440000000443513073161526014662 0ustar liggesusers\name{gamlss.etamu} \alias{gamlss.etamu} \title{Transform derivatives wrt mu to derivatives wrt linear predictor} \usage{ gamlss.etamu(l1, l2, l3 = NULL, l4 = NULL, ig1, g2, g3 = NULL, g4 = NULL, i2, i3 = NULL, i4 = NULL, deriv = 0) } \arguments{ \item{l1}{array of 1st order derivatives of log-likelihood wrt mu.} \item{l2}{array of 2nd order derivatives of log-likelihood wrt mu.} \item{l3}{array of 3rd order derivatives of log-likelihood wrt mu.} \item{l4}{array of 4th order derivatives of log-likelihood wrt mu.} \item{ig1}{reciprocal of the first derivative of the link function wrt the linear predictor.} \item{g2}{array containing the 2nd order derivative of the link function wrt the linear predictor.} \item{g3}{array containing the 3rd order derivative of the link function wrt the linear predictor.} \item{g4}{array containing the 4th order derivative of the link function wrt the linear predictor.} \item{i2}{two-dimensional index array, such that \code{l2[,i2[i,j]]} contains the partial w.r.t. params indexed by i,j with no restriction on the index values (except that they are in 1,...,ncol(l1)).} \item{i3}{third-dimensional index array, such that \code{l3[,i3[i,j,k]]} contains the partial w.r.t. params indexed by i,j,k.} \item{i4}{third-dimensional index array, such that \code{l4[,i4[i,j,k,l]]} contains the partial w.r.t. params indexed by i,j,k,l.} \item{deriv}{if \code{deriv==0} only first and second order derivatives will be calculated. If \code{deriv==1} the function goes up to 3rd order, and if \code{deriv==2} it provides also 4th order derivatives.} } \value{ A list where the arrays \code{l1}, \code{l2}, \code{l3}, \code{l4} contain the derivatives (up to order four) of the log-likelihood wrt the linear predictor. } \description{Mainly intended for internal use in specifying location scale models. Let \code{g(mu) = lp}, where \code{lp} is the linear predictor, and \code{g} is the link function. Assume that we have calculated the derivatives of the log-likelihood wrt \code{mu}. This function uses the chain rule to calculate the derivatives of the log-likelihood wrt \code{lp}. See \code{\link{trind.generator}} for array packing conventions. } \seealso{\code{\link{trind.generator}}} \author{ Simon N. Wood . } mgcv/man/pdIdnot.Rd0000755000176200001440000000530213073161526013660 0ustar liggesusers\name{pdIdnot} \alias{pdIdnot} \alias{pdConstruct.pdIdnot} \alias{pdFactor.pdIdnot} \alias{pdMatrix.pdIdnot} \alias{coef.pdIdnot} \alias{corMatrix.pdIdnot} \alias{Dim.pdIdnot} \alias{logDet.pdIdnot} \alias{solve.pdIdnot} \alias{summary.pdIdnot} %- Also NEED an `\alias' for EACH other topic documented here. \title{Overflow proof pdMat class for multiples of the identity matrix} \description{ This set of functions is a modification of the \code{pdMat} class \code{pdIdent} from library \code{nlme}. The modification is to replace the log parameterization used in \code{pdMat} with a \code{\link{notLog2}} parameterization, since the latter avoids indefiniteness in the likelihood and associated convergence problems: the parameters also relate to variances rather than standard deviations, for consistency with the \code{\link{pdTens}} class. The functions are particularly useful for working with Generalized Additive Mixed Models where variance parameters/smoothing parameters can be very large or very small, so that overflow or underflow can be a problem. These functions would not normally be called directly, although unlike the \code{\link{pdTens}} class it is easy to do so. } \usage{ pdIdnot(value = numeric(0), form = NULL, nam = NULL, data = sys.frame(sys.parent())) } %- maybe also `usage' for other objects documented here. \arguments{ \item{value}{Initialization values for parameters. Not normally used.} \item{form}{A one sided formula specifying the random effects structure. } \item{nam}{a names argument, not normally used with this class.} \item{data}{data frame in which to evaluate formula.} } \details{ The following functions are provided: \code{Dim.pdIndot}, \code{coef.pdIdnot}, \code{corMatrix.pdIdnot}, \code{logDet.pdIdnot}, \code{pdConstruct.pdIdnot}, \code{pdFactor.pdIdnot}, \code{pdMatrix.pdIdnot}, \code{solve.pdIdnot}, \code{summary.pdIdnot}. (e.g. \code{mgcv:::coef.pdIdnot} to access.) Note that while the \code{pdFactor} and \code{pdMatrix} functions return the inverse of the scaled random effect covariance matrix or its factor, the \code{pdConstruct} function is initialised with estimates of the scaled covariance matrix itself. } \value{ A class \code{pdIdnot} object, or related quantities. See the \code{nlme} documentation for further details.} \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Pinheiro J.C. and Bates, D.M. (2000) Mixed effects Models in S and S-PLUS. Springer The \code{nlme} source code. \url{http://www.maths.bris.ac.uk/~sw15190/} } \seealso{ \code{\link{te}}, \code{\link{pdTens}}, \code{\link{notLog2}}, \code{\link{gamm}}} \examples{ # see gamm } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/predict.bam.Rd0000755000176200001440000001747513502362276014467 0ustar liggesusers\name{predict.bam} \alias{predict.bam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Prediction from fitted Big Additive Model model} \description{ Essentially a wrapper for \code{\link{predict.gam}} for prediction from a model fitted by \code{\link{bam}}. Can compute on a parallel cluster. Takes a fitted \code{bam} object produced by \code{\link{bam}} and produces predictions given a new set of values for the model covariates or the original values used for the model fit. Predictions can be accompanied by standard errors, based on the posterior distribution of the model coefficients. The routine can optionally return the matrix by which the model coefficients must be pre-multiplied in order to yield the values of the linear predictor at the supplied covariate values: this is useful for obtaining credible regions for quantities derived from the model (e.g. derivatives of smooths), and for lookup table prediction outside \code{R} (see example code below).} \usage{ \method{predict}{bam}(object,newdata,type="link",se.fit=FALSE,terms=NULL, exclude=NULL,block.size=50000,newdata.guaranteed=FALSE, na.action=na.pass,cluster=NULL,discrete=TRUE,n.threads=1,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ a fitted \code{bam} object as produced by \code{\link{bam}}. } \item{newdata}{ A data frame or list containing the values of the model covariates at which predictions are required. If this is not provided then predictions corresponding to the original data are returned. If \code{newdata} is provided then it should contain all the variables needed for prediction: a warning is generated if not. } \item{type}{ When this has the value \code{"link"} (default) the linear predictor (possibly with associated standard errors) is returned. When \code{type="terms"} each component of the linear predictor is returned seperately (possibly with standard errors): this includes parametric model components, followed by each smooth component, but excludes any offset and any intercept. \code{type="iterms"} is the same, except that any standard errors returned for smooth components will include the uncertainty about the intercept/overall mean. When \code{type="response"} predictions on the scale of the response are returned (possibly with approximate standard errors). When \code{type="lpmatrix"} then a matrix is returned which yields the values of the linear predictor (minus any offset) when postmultiplied by the parameter vector (in this case \code{se.fit} is ignored). The latter option is most useful for getting variance estimates for quantities derived from the model: for example integrated quantities, or derivatives of smooths. A linear predictor matrix can also be used to implement approximate prediction outside \code{R} (see example code, below). } \item{se.fit}{ when this is TRUE (not default) standard error estimates are returned for each prediction.} \item{terms}{if \code{type=="terms"} or \code{type="iterms"} then only results for the terms (smooth or parametric) named in this array will be returned. Otherwise any smooth terms not named in this array will be set to zero. If \code{NULL} then all terms are included.} \item{exclude}{if \code{type=="terms"} or \code{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 \code{NULL} then no terms are excluded. To avoid supplying covariate values for excluded terms, set \code{newdata.guaranteed=TRUE}, but note that this skips all checks of \code{newdata}. } \item{block.size}{maximum number of predictions to process per call to underlying code: larger is quicker, but more memory intensive.} \item{newdata.guaranteed}{Set to \code{TRUE} to turn off all checking of \code{newdata} except for sanity of factor levels: this can speed things up for large prediction tasks, but \code{newdata} must be complete, with no \code{NA} values for predictors required in the model. } \item{na.action}{what to do about \code{NA} values in \code{newdata}. With the default \code{na.pass}, any row of \code{newdata} containing \code{NA} values for required predictors, gives rise to \code{NA} predictions (even if the term concerned has no \code{NA} predictors). \code{na.exclude} or \code{na.omit} result in the dropping of \code{newdata} rows, if they contain any \code{NA} values for required predictors. If \code{newdata} is missing then \code{NA} handling is determined from \code{object$na.action}.} \item{cluster}{\code{predict.bam} can compute in parallel using \link[parallel]{parLapply} from the \code{parallel} package, if it is supplied with a cluster on which to do this (a cluster here can be some cores of a single machine). See details and example code for \code{\link{bam}}. } \item{discrete}{if \code{TRUE} then discrete prediction methods used with model fitted by discrete methods. \code{FALSE} for regular prediction.} \item{n.threads}{if \code{se.fit=TRUE} and discrete prediction is used then parallel computation can be used to speed up se calcualtion. This specifies number of htreads to use.} \item{...}{ other arguments.} } \value{ If \code{type=="lpmatrix"} then a matrix is returned which will give a vector of linear predictor values (minus any offest) at the supplied covariate values, when applied to the model coefficient vector. Otherwise, if \code{se.fit} is \code{TRUE} then a 2 item list is returned with items (both arrays) \code{fit} and \code{se.fit} containing predictions and associated standard error estimates, otherwise an array of predictions is returned. The dimensions of the returned arrays depends on whether \code{type} is \code{"terms"} or not: if it is then the array is 2 dimensional with each term in the linear predictor separate, otherwise the array is 1 dimensional and contains the linear predictor/predicted values (or corresponding s.e.s). The linear predictor returned termwise will not include the offset or the intercept. \code{newdata} can be a data frame, list or model.frame: if it's a model frame then all variables must be supplied. } \details{The standard errors produced by \code{predict.gam} are based on the Bayesian posterior covariance matrix of the parameters \code{Vp} in the fitted bam object. To facilitate plotting with \code{\link{termplot}}, if \code{object} possesses an attribute \code{"para.only"} and \code{type=="terms"} then only parametric terms of order 1 are returned (i.e. those that \code{termplot} can handle). Note that, in common with other prediction functions, any offset supplied to \code{\link{gam}} as an argument is always ignored when predicting, unlike offsets specified in the gam model formula. See the examples in \code{\link{predict.gam}} for how to use the \code{lpmatrix} for obtaining credible regions for quantities derived from the model. } \references{ Chambers and Hastie (1993) Statistical Models in S. Chapman & Hall. Marra, G and S.N. Wood (2012) Coverage Properties of Confidence Intervals for Generalized Additive Model Components. Scandinavian Journal of Statistics. Wood S.N. (2006b) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org} The design is inspired by the S function of the same name described in Chambers and Hastie (1993) (but is not a clone). } \section{WARNING }{ Predictions are likely to be incorrect if data dependent transformations of the covariates are used within calls to smooths. See examples in \code{\link{predict.gam}}. } \seealso{ \code{\link{bam}}, \code{\link{predict.gam}}} \examples{ ## for parallel computing see examples for ?bam ## for general useage follow examples in ?predict.gam } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/tensor.prod.model.matrix.Rd0000755000176200001440000000510213465315074017140 0ustar liggesusers\name{tensor.prod.model.matrix} \alias{tensor.prod.model.matrix} \alias{tensor.prod.penalties} \alias{\%.\%} %- Also NEED an `\alias' for EACH other topic documented here. \title{Row Kronecker product/ tensor product smooth construction} \description{ Produce model matrices or penalty matrices for a tensor product smooth from the model matrices or penalty matrices for the marginal bases of the smooth. The model matrix construction uses row Kronecker products. } \usage{ tensor.prod.model.matrix(X) tensor.prod.penalties(S) a\%.\%b } %- maybe also `usage' for other objects documented here. \arguments{ \item{X}{a list of model matrices for the marginal bases of a smooth} \item{S}{a list of penalties for the marginal bases of a smooth.} \item{a}{a matrix with the same number of rows as \code{A}.} \item{b}{a matrix with the same number of rows as \code{B}.} } \details{ If \code{X[[1]]}, \code{X[[2]]} ... \code{X[[m]]} are the model matrices of the marginal bases of a tensor product smooth then the ith row of the model matrix for the whole tensor product smooth is given by \code{X[[1]][i,]\%x\%X[[2]][i,]\%x\% ... X[[m]][i,]}, where \code{\%x\%} is the Kronecker product. Of course the routine operates column-wise, not row-wise! \code{A\%.\%B} is the operator form of this `row Kronecker product'. If \code{S[[1]]}, \code{S[[2]]} ... \code{S[[m]]} are the penalty matrices for the marginal bases, and \code{I[[1]]}, \code{I[[2]]} ... \code{I[[m]]} are corresponding identity matrices, each of the same dimension as its corresponding penalty, then the tensor product smooth has m associate penalties of the form: \code{S[[1]]\%x\%I[[2]]\%x\% ... I[[m]]}, \code{I[[1]]\%x\%S[[2]]\%x\% ... I[[m]]} ... \code{I[[1]]\%x\%I[[2]]\%x\% ... S[[m]]}. Of course it's important that the model matrices and penalty matrices are presented in the same order when constructing tensor product smooths. } \value{ Either a single model matrix for a tensor product smooth, or a list of penalty terms for a tensor product smooth. } \references{ Wood, S.N. (2006) Low rank scale invariant tensor product smooths for Generalized Additive Mixed Models. Biometrics 62(4):1025-1036 } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{te}}, \code{\link{smooth.construct.tensor.smooth.spec}} } \examples{ require(mgcv) X <- list(matrix(1:4,2,2),matrix(5:10,2,3)) tensor.prod.model.matrix(X) X[[1]]\%.\%X[[2]] S<-list(matrix(c(2,1,1,2),2,2),matrix(c(2,1,0,1,2,1,0,1,2),3,3)) tensor.prod.penalties(S) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/interpret.gam.Rd0000755000176200001440000000334613137076654015054 0ustar liggesusers\name{interpret.gam} \alias{interpret.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Interpret a GAM formula} \description{ This is an internal function of package \code{mgcv}. It is a service routine for \code{gam} which splits off the strictly parametric part of the model formula, returning it as a formula, and interprets the smooth parts of the model formula. Not normally called directly. } \usage{interpret.gam(gf, extra.special = NULL)} \arguments{\item{gf}{A GAM formula as supplied to \code{\link{gam}} or \code{\link{gamm}}, or a list of such formulae, as supplied for some \code{\link{gam}} families.} \item{extra.special}{Name of any extra special in formula in addition to \code{s}, \code{te}, \code{ti} and \code{t2}.} } \value{An object of class \code{split.gam.formula} with the following items: \item{pf}{A model formula for the strictly parametric part of the model.} \item{pfok}{TRUE if there is a \code{pf} formula.} \item{smooth.spec}{A list of class \code{xx.smooth.spec} objects where \code{xx} depends on the basis specified for the term. (These can be passed to smooth constructor method functions to actually set up penalties and bases.)} \item{full.formula}{An expanded version of the model formula in which the options are fully expanded, and the options do not depend on variables which might not be available later.} \item{fake.formula}{A formula suitable for use in evaluating a model frame.} \item{response}{Name of the response variable.} } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gam}} \code{\link{gamm}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/gam.check.Rd0000755000176200001440000001444413303547351014106 0ustar liggesusers\name{gam.check} \alias{gam.check} \title{Some diagnostics for a fitted gam model} \description{ Takes a fitted \code{gam} object produced by \code{gam()} and produces some diagnostic information about the fitting procedure and results. The default is to produce 4 residual plots, some information about the convergence of the smoothness selection optimization, and to run diagnostic tests of whether the basis dimension choises are adequate. Care should be taken in interpreting the results when applied to \code{gam} objects returned by \code{\link{gamm}}. } \usage{ gam.check(b, old.style=FALSE, type=c("deviance","pearson","response"), k.sample=5000,k.rep=200, rep=0, level=.9, rl.col=2, rep.col="gray80", \dots) } \arguments{ \item{b}{a fitted \code{gam} object as produced by \code{\link{gam}()}.} \item{old.style}{If you want old fashioned plots, exactly as in Wood, 2006, set to \code{TRUE}.} \item{type}{type of residuals, see \code{\link{residuals.gam}}, used in all plots.} \item{k.sample}{Above this k testing uses a random sub-sample of data.} \item{k.rep}{how many re-shuffles to do to get p-value for k testing.} \item{rep, level, rl.col, rep.col}{ arguments passed to \code{\link{qq.gam}()} when \code{old.style} is false, see there.} \item{\dots}{extra graphics parameters to pass to plotting functions.} } \value{A vector of reference quantiles for the residual distribution, if these can be computed.} \details{ Checking a fitted \code{gam} is like checking a fitted \code{glm}, with two main differences. Firstly, the basis dimensions used for smooth terms need to be checked, to ensure that they are not so small that they force oversmoothing: the defaults are arbitrary. \code{\link{choose.k}} provides more detail, but the diagnostic tests described below and reported by this function may also help. Secondly, fitting may not always be as robust to violation of the distributional assumptions as would be the case for a regular GLM, so slightly more care may be needed here. In particular, the thoery of quasi-likelihood implies that if the mean variance relationship is OK for a GLM, then other departures from the assumed distribution are not problematic: GAMs can sometimes be more sensitive. For example, un-modelled overdispersion will typically lead to overfit, as the smoothness selection criterion tries to reduce the scale parameter to the one specified. Similarly, it is not clear how sensitive REML and ML smoothness selection will be to deviations from the assumed response dsistribution. For these reasons this routine uses an enhanced residual QQ plot. This function plots 4 standard diagnostic plots, some smoothing parameter estimation convergence information and the results of tests which may indicate if the smoothing basis dimension for a term is too low. Usually the 4 plots are various residual plots. For the default optimization methods the convergence information is summarized in a readable way, but for other optimization methods, whatever is returned by way of convergence diagnostics is simply printed. The test of whether the basis dimension for a smooth is adequate (Wood, 2017, section 5.9) is based on computing an estimate of the residual variance based on differencing residuals that are near neighbours according to the (numeric) covariates of the smooth. This estimate divided by the residual variance is the \code{k-index} reported. The further below 1 this is, the more likely it is that there is missed pattern left in the residuals. The \code{p-value} is computed by simulation: the residuals are randomly re-shuffled \code{k.rep} times to obtain the null distribution of the differencing variance estimator, if there is no pattern in the residuals. For models fitted to more than \code{k.sample} data, the tests are based of \code{k.sample} randomly sampled data. Low p-values may indicate that the basis dimension, \code{k}, has been set too low, especially if the reported \code{edf} is close to k', the maximum possible EDF for the term. Note the disconcerting fact that if the test statistic itself is based on random resampling and the null is true, then the associated p-values will of course vary widely from one replicate to the next. Currently smooths of factor variables are not supported and will give an \code{NA} p-value. Doubling a suspect \code{k} and re-fitting is sensible: if the reported \code{edf} increases substantially then you may have been missing something in the first fit. Of course p-values can be low for reasons other than a too low \code{k}. See \code{\link{choose.k}} for fuller discussion. The QQ plot produced is usually created by a call to \code{\link{qq.gam}}, and plots deviance residuals against approximate theoretical quantilies of the deviance residual distribution, according to the fitted model. If this looks odd then investigate further using \code{\link{qq.gam}}. Note that residuals for models fitted to binary data contain very little information useful for model checking (it is necessary to find some way of aggregating them first), so the QQ plot is unlikely to be useful in this case. Take care when interpreting results from applying this function to a model fitted using \code{\link{gamm}}. In this case the returned \code{gam} object is based on the working model used for estimation, and will treat all the random effects as part of the error. This means that the residuals extracted from the \code{gam} object are not standardized for the family used or for the random effects or correlation structure. Usually it is necessary to produce your own residual checks based on consideration of the model structure you have used. } \references{ N.H. Augustin, E-A Sauleaub, S.N. Wood (2012) On quantile quantile plots for generalized linear models. Computational Statistics & Data Analysis. 56(8), 2404-3409. Wood S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC Press. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{choose.k}}, \code{\link{gam}}, \code{\link{magic}}} \examples{ library(mgcv) set.seed(0) dat <- gamSim(1,n=200) b<-gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat) plot(b,pages=1) gam.check(b,pch=19,cex=.3) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/cSplineDes.Rd0000755000176200001440000000365413073161526014320 0ustar liggesusers\name{cSplineDes} \alias{cSplineDes} %- Also NEED an `\alias' for EACH other topic documented here. \title{Evaluate cyclic B spline basis} \description{ Uses \code{splineDesign} to set up the model matrix for a cyclic B-spline basis. } \usage{ cSplineDes(x, knots, ord = 4, derivs=0) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{ covariate values for smooth.} \item{knots}{The knot locations: the range of these must include all the data.} \item{ord}{ order of the basis. 4 is a cubic spline basis. Must be >1.} \item{derivs}{ order of derivative of the spline to evaluate, between 0 and \code{ord}-1. Recycled to length of \code{x}. } } \details{ The routine is a wrapper that sets up a B-spline basis, where the basis functions wrap at the first and last knot locations.} \value{ A matrix with \code{length(x)} rows and \code{length(knots)-1} columns. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{cyclic.p.spline}}} \examples{ require(mgcv) ## create some x's and knots... n <- 200 x <- 0:(n-1)/(n-1);k<- 0:5/5 X <- cSplineDes(x,k) ## cyclic spline design matrix ## plot evaluated basis functions... plot(x,X[,1],type="l"); for (i in 2:5) lines(x,X[,i],col=i) ## check that the ends match up.... ee <- X[1,]-X[n,];ee tol <- .Machine$double.eps^.75 if (all.equal(ee,ee*0,tolerance=tol)!=TRUE) stop("cyclic spline ends don't match!") ## similar with uneven data spacing... x <- sort(runif(n)) + 1 ## sorting just makes end checking easy k <- seq(min(x),max(x),length=8) ## create knots X <- cSplineDes(x,k) ## get cyclic spline model matrix plot(x,X[,1],type="l"); for (i in 2:ncol(X)) lines(x,X[,i],col=i) ee <- X[1,]-X[n,];ee ## do ends match?? tol <- .Machine$double.eps^.75 if (all.equal(ee,ee*0,tolerance=tol)!=TRUE) stop("cyclic spline ends don't match!") } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/ginla.Rd0000755000176200001440000002204413432570425013354 0ustar liggesusers\name{ginla} \alias{ginla} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM Integrated Nested Laplace Approximation Newton Enhanced} \description{Apply Integrated Nested Laplace Approximation (INLA, Rue et al. 2009) to models estimable by \code{\link{gam}} or \code{\link{bam}}, using the INLA variant described in Wood (2019). Produces marginal posterior densities for each coefficient, selected coefficients or linear transformations of the coefficient vector. } \usage{ ginla(G,A=NULL,nk=16,nb=100,J=1,interactive=FALSE,int=0,approx=0) } %- maybe also `usage' for other objects documented here. \arguments{ \item{G}{A pre-fit gam object, as produced by \code{gam(...,fit=FALSE)} or \code{bam(...,discrete=TRUE,fit=FALSE)}.} \item{A}{Either a matrix of transforms of the coefficients that are of interest, or an array of indices of the parameters of interest. If \code{NULL} then distributions are produced for all coefficients.} \item{nk}{Number of values of each coefficient at which to evaluate its log marginal posterior density. These points are then spline interpolated.} \item{nb}{Number of points at which to evaluate posterior density of coefficients for returning as a gridded function.} \item{J}{How many determinant updating steps to take in the log determinant approximation step. Not recommended to increase this. } \item{interactive}{If this is \code{>0} or \code{TRUE} then every approximate posterior is plotted in red, overlaid on the simple Gaussian approximate posterior. If \code{2} then waits for user to press return between each plot. Useful for judging whether anything is gained by using INLA approach. } \item{int}{0 to skip integration and just use the posterior modal smoothing parameter. >0 for integration using the CCD approach proposed in Rue et al. (2009).} \item{approx}{0 for full approximation; 1 to update Hessian, but use approximate modes; 2 as 1 and assume constant Hessian. See details.} } \value{ A list with elements \code{beta} and \code{density}, both of which are matrices. Each row relates to one coefficient (or linear coefficient combination) of interest. Both matrices have \code{nb} columns. If \code{int!=0} then a further element \code{reml} gives the integration weights used in the CCD integration, with the central point weight given first. } \details{Let \eqn{\beta}{b}, \eqn{\theta}{h} and \eqn{y}{y} denote the model coefficients, hyperparameters/smoothing parameters and response data, respectively. In principle, INLA employs Laplace approximations for \eqn{\pi(\beta_i|\theta,y)}{p(b_i|h,y)} and \eqn{\pi(\theta|y)}{p(h|y)} and then obtains the marginal posterior distribution \eqn{\pi(\beta_i|y)}{p(b_i|y)} by intergrating the approximations to \eqn{\pi(\beta_i|\theta,y)\pi(\theta|y)}{p(b_i|h,y)p(h|y)} w.r.t \eqn{\theta}{h} (marginals for the hyperparameters can also be produced). In practice the Laplace approximation for \eqn{\pi(\beta_i|\theta,y)}{p(b_i|h,y)} is too expensive to compute for each \eqn{\beta_i}{b_i} and must itself be approximated. To this end, there are two quantities that have to be computed: the posterior mode \eqn{\beta^*|\beta_i}{b*|b_i} and the determinant of the Hessian of the joint log density \eqn{\log \pi(\beta,\theta,y)}{log p(b,h,y)} w.r.t. \eqn{\beta}{b} at the mode. Rue et al. (2009) originally approximated the posterior conditional mode by the conditional mode implied by a simple Gaussian approximation to the posterior \eqn{\pi(\beta|y)}{p(b|y)}. They then approximated the log determinant of the Hessian as a function of \eqn{\beta_i}{b_i} using a first order Taylor expansion, which is cheap to compute for the sparse model representaiton that they use, but not when using the dense low rank basis expansions used by \code{\link{gam}}. They also offer a more expensive alternative approximation based on computing the log determiannt with respect only to those elements of \eqn{\beta}{b} with sufficiently high correlation with \eqn{\beta_i}{b_i} according to the simple Gaussian posterior approximation: efficiency again seems to rest on sparsity. Wood (2018) suggests computing the required posterior modes exactly, and basing the log determinant approximation on a BFGS update of the Hessian at the unconditional model. The latter is efficient with or without sparsity, whereas the former is a `for free' improvement. Both steps are efficient because it is cheap to obtain the Cholesky factor of \eqn{H[-i,-i]}{H[-i,-i]} from that of \eqn{H}{H} - see \code{\link{choldrop}}. This is the approach taken by this routine. The \code{approx} argument allows two further approximations to speed up computations. For \code{approx==1} the exact posterior conditional modes are not used, but instead the conditional modes implied by the simple Gaussian posterior approximation. For \code{approx==2} the same approximation is used for the modes and the Hessian is assumed constant. The latter is quite fast as no log joint density gradient evaluations are required. Note that for many models the INLA estimates are very close to the usual Gaussian approximation to the posterior, the \code{interactive} argument is useful for investigating this issue. \code{\link{bam}} models are only supported with the \code{disrete=TRUE} option. The \code{discrete=FALSE} approach would be too inefficient. AR1 models are not supported (related arguments are simply ignored). } \references{ Rue, H, Martino, S. & Chopin, N. (2009) Approximate Bayesian inference for latent Gaussian models by using integrated nested Laplace approximations (with discussion). Journal of the Royal Statistical Society, Series B. 71: 319-392. Wood (2019) Simplified Integrated Laplace Approximation. In press Biometrika. } \section{WARNINGS}{ This routine is still somewhat experimental, so details are liable to change. Also currently not all steps are optimally efficient. The routine is written for relatively expert users. \code{ginla} is not designed to deal with rank deficient models. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ require(mgcv); require(MASS) ## example using a scale location model for the motorcycle data. A simple plotting ## routine is produced first... plot.inla <- function(x,inla,k=1,levels=c(.025,.1,.5,.9,.975), lcol = c(2,4,4,4,2),lwd = c(1,1,2,1,1),lty=c(1,1,1,1,1), xlab="x",ylab="y",cex.lab=1.5) { ## a simple effect plotter, when distributions of function values of ## 1D smooths have been computed require(splines) p <- length(x) betaq <- matrix(0,length(levels),p) ## storage for beta quantiles for (i in 1:p) { ## work through x and betas j <- i + k - 1 p <- cumsum(inla$density[j,])*(inla$beta[j,2]-inla$beta[j,1]) ## getting quantiles of function values... betaq[,i] <- approx(p,y=inla$beta[j,],levels)$y } xg <- seq(min(x),max(x),length=200) ylim <- range(betaq) ylim <- 1.1*(ylim-mean(ylim))+mean(ylim) for (j in 1:length(levels)) { ## plot the quantiles din <- interpSpline(x,betaq[j,]) if (j==1) { plot(xg,predict(din,xg)$y,ylim=ylim,type="l",col=lcol[j], xlab=xlab,ylab=ylab,lwd=lwd[j],cex.lab=1.5,lty=lty[j]) } else lines(xg,predict(din,xg)$y,col=lcol[j],lwd=lwd[j],lty=lty[j]) } } ## plot.inla ## set up the model with a `gam' call... G <- gam(list(accel~s(times,k=20,bs="ad"),~s(times)), data=mcycle,family=gaulss(),fit=FALSE) b <- gam(G=G,method="REML") ## regular GAM fit for comparison ## Now use ginla to get posteriors of estimated effect values ## at evenly spaced times. Create A matrix for this... rat <- range(mcycle$times) pd0 <- data.frame(times=seq(rat[1],rat[2],length=20)) X0 <- predict(b,newdata=pd0,type="lpmatrix") X0[,21:30] <- 0 pd1 <- data.frame(times=seq(rat[1],rat[2],length=10)) X1 <- predict(b,newdata=pd1,type="lpmatrix") X1[,1:20] <- 0 A <- rbind(X0,X1) ## A maps coefs to required function values ## call ginla. Set int to 1 for integrated version. ## Set interactive = 1 or 2 to plot marginal posterior distributions ## (red) and simple Gaussian approximation (black). inla <- ginla(G,A,int=0) par(mfrow=c(1,2),mar=c(5,5,1,1)) fv <- predict(b,se=TRUE) ## usual Gaussian approximation, for comparison ## plot inla mean smooth effect... plot.inla(pd0$times,inla,k=1,xlab="time",ylab=expression(f[1](time))) ## overlay simple Gaussian equivalent (in grey) ... points(mcycle$times,mcycle$accel,col="grey") lines(mcycle$times,fv$fit[,1],col="grey",lwd=2) lines(mcycle$times,fv$fit[,1]+2*fv$se.fit[,1],lty=2,col="grey",lwd=2) lines(mcycle$times,fv$fit[,1]-2*fv$se.fit[,1],lty=2,col="grey",lwd=2) ## same for log sd smooth... plot.inla(pd1$times,inla,k=21,xlab="time",ylab=expression(f[2](time))) lines(mcycle$times,fv$fit[,2],col="grey",lwd=2) lines(mcycle$times,fv$fit[,2]+2*fv$se.fit[,2],col="grey",lty=2,lwd=2) lines(mcycle$times,fv$fit[,2]-2*fv$se.fit[,2],col="grey",lty=2,lwd=2) ## ... notice some real differences for the log sd smooth, especially ## at the lower and upper ends of the time interval. } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/gamlss.gH.Rd0000644000176200001440000000564113073161526014105 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gamlss.R \name{gamlss.gH} \alias{gamlss.gH} \title{Calculating derivatives of log-likelihood wrt regression coefficients} \usage{ gamlss.gH(X, jj, l1, l2, i2, l3 = 0, i3 = 0, l4 = 0, i4 = 0, d1b = 0, d2b = 0, deriv = 0, fh = NULL, D = NULL) } \arguments{ \item{X}{matrix containing the model matrices of all the linear predictors.} \item{jj}{list of index vectors such that \code{X[,jj[[i]]]} is the model matrix of the i-th linear predictor.} \item{l1}{array of 1st order derivatives of each element of the log-likelihood wrt each parameter.} \item{l2}{array of 2nd order derivatives of each element of the log-likelihood wrt each parameter.} \item{i2}{two-dimensional index array, such that \code{l2[,i2[i,j]]} contains the partial w.r.t. params indexed by i,j with no restriction on the index values (except that they are in 1,...,ncol(l1)).} \item{l3}{array of 3rd order derivatives of each element of the log-likelihood wrt each parameter.} \item{i3}{third-dimensional index array, such that \code{l3[,i3[i,j,k]]} contains the partial w.r.t. params indexed by i,j,k.} \item{l4}{array of 4th order derivatives of each element of the log-likelihood wrt each parameter.} \item{i4}{third-dimensional index array, such that \code{l4[,i4[i,j,k,l]]} contains the partial w.r.t. params indexed by i,j,k,l.} \item{d1b}{first derivatives of the regression coefficients wrt the smoothing parameters.} \item{d2b}{second derivatives of the regression coefficients wrt the smoothing parameters.} \item{deriv}{if \code{deriv==0} only first and second order derivatives will be calculated. If \code{deriv==1} the function return also the diagonal of the first derivative of the Hessian, if \code{deriv==2} it return the full 3rd order derivative and if \code{deriv==3} it provides also 4th order derivatives.} \item{fh}{eigen-decomposition or Cholesky factor of the penalized Hessian.} \item{D}{diagonal matrix, used to provide some scaling.} } \value{ A list containing \code{lb} - the grad vector w.r.t. coefs; \code{lbb} - the Hessian matrix w.r.t. coefs; \code{d1H} - either a list of the derivatives of the Hessian w.r.t. the smoothing parameters, or a single matrix whose columns are the leading diagonals of these dervative matrices; \code{trHid2H} - the trace of the inverse Hessian multiplied by the second derivative of the Hessian w.r.t. all combinations of smoothing parameters. } \description{ Mainly intended for internal use with location scale model families. Given the derivatives of the log-likelihood wrt the linear predictor, this function obtains the derivatives and Hessian wrt the regression coefficients and derivatives of the Hessian w.r.t. the smoothing parameters. For input derivative array packing conventions see \code{\link{trind.generator}}. } \seealso{ \code{\link{trind.generator}}} \author{ Simon N. Wood . } mgcv/man/smooth.construct.so.smooth.spec.Rd0000755000176200001440000003043613137076654020512 0ustar liggesusers\name{smooth.construct.so.smooth.spec} \alias{smooth.construct.so.smooth.spec} \alias{smooth.construct.sf.smooth.spec} \alias{smooth.construct.sw.smooth.spec} \alias{soap} %- Also NEED an `\alias' for EACH other topic documented here. \title{Soap film smoother constructer} \description{ Sets up basis functions and wiggliness penalties for soap film smoothers (Wood, Bravington and Hedley, 2008). Soap film smoothers are based on the idea of constructing a 2-D smooth as a film of soap connecting a smoothly varying closed boundary. Unless smoothing very heavily, the film is distorted towards the data. The smooths are designed not to smooth across boundary features (peninsulas, for example). The \code{so} version sets up the full smooth. The \code{sf} version sets up just the boundary interpolating soap film, while the \code{sw} version sets up the wiggly component of a soap film (zero on the boundary). The latter two are useful for forming tensor products with soap films, and can be used with \code{\link{gamm}} and \code{gamm4}. To use these to simply set up a basis, then call via the wrapper \code{\link{smooth.construct2}} or \code{\link{smoothCon}}. } \usage{ \method{smooth.construct}{so.smooth.spec}(object,data,knots) \method{smooth.construct}{sf.smooth.spec}(object,data,knots) \method{smooth.construct}{sw.smooth.spec}(object,data,knots) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{A smooth specification object as produced by a \code{s(...,bs="so",xt=list(bnd=bnd,...))} term in a \code{gam} formula. Note that the \code{xt} argument to \code{s} *must* be supplied, and should be a list, containing at least a boundary specification list (see details). \code{xt} may also contain various options controlling the boundary smooth (see details), and PDE solution grid. The dimension of the bases for boundary loops is specified via the \code{k} argument of \code{s}, either as a single number to be used for each boundary loop, or as a vector of different basis dimensions for the various boundary loops. } \item{data}{A list or data frame containing the arguments of the smooth.} \item{knots}{list or data frame with two named columns specifying the knot locations within the boundary. The column names should match the names of the arguments of the smooth. The number of knots defines the *interior* basis dimension (i.e. it is *not* supplied via argument \code{k} of \code{s}).} } \details{ For soap film smooths the following *must* be supplied: \itemize{ \item{k}{ the basis dimension for each boundary loop smooth.} \item{xt$bnd}{ the boundary specification for the smooth.} \item{knots}{ the locations of the interior knots for the smooth.} } When used in a GAM then \code{k} and \code{xt} are supplied via \code{s} while \code{knots} are supplied in the \code{knots} argument of \code{\link{gam}}. The \code{bnd} element of the \code{xt} list is a list of lists (or data frames), specifying the loops that define the boundary. Each boundary loop list must contain 2 columns giving the co-ordinates of points defining a boundary loop (when joined sequentially by line segments). Loops should not intersect (not checked). A point is deemed to be in the region of interest if it is interior to an odd number of boundary loops. Each boundary loop list may also contain a column \code{f} giving known boundary conditions on a loop. The \code{bndSpec} element of \code{xt}, if non-NULL, should contain \itemize{ \item{bs}{ the type of cyclic smoothing basis to use: one of \code{"cc"} and \code{"cp"}. If not \code{"cc"} then a cyclic p-spline is used, and argument \code{m} must be supplied.} \item{knot.space}{ set to "even" to get even knot spacing with the "cc" basis.} \item{m}{ 1 or 2 element array specifying order of "cp" basis and penalty.} } Currently the code will not deal with more than one level of nesting of loops, or with separate loops without an outer enclosing loop: if there are known boundary conditions (identifiability constraints get awkward). Note that the function \code{\link{locator}} provides a simple means for defining boundaries graphically, using something like \code{bnd <-as.data.frame(locator(type="l"))}, after producing a plot of the domain of interest (right click to stop). If the real boundary is very complicated, it is probably better to use a simpler smooth boundary enclosing the true boundary, which represents the major boundary features that you don't want to smooth across, but doesn't follow every tiny detail. Model set up, and prediction, involves evaluating basis functions which are defined as the solution to PDEs. The PDEs are solved numerically on a grid using sparse matrix methods, with bilinear interpolation used to obtain values at any location within the smoothing domain. The dimension of the PDE solution grid can be controlled via element \code{nmax} (default 200) of the list supplied as argument \code{xt} of \code{s} in a \code{gam} formula: it gives the number of cells to use on the longest grid side. A little theory: the soap film smooth \eqn{f(x,y)}{f(x,y)} is defined as the solution of \deqn{f_{xx} + f_{yy} = g}{f_xx+f_yy = g} subject to the condition that \eqn{f=s}{f=s}, on the boundary curve, where \eqn{s}{s} is a smooth function (usually a cyclic penalized regression spline). The function \eqn{g}{g} is defined as the solution of \deqn{g_{xx}+g_{yy}=0}{g_xx+g_yy=0} where \eqn{g=0}{g=0} on the boundary curve and \eqn{g(x_k,y_k)=c_k}{g(x_k,y_k)=c_k} at the `knots' of the surface; the \eqn{c_k}{c_k} are model coefficients. In the simplest case, estimation of the coefficients of \eqn{f}{f} (boundary coefficients plus \eqn{c_k}{c_k}'s) is by minimization of \deqn{\|z-f\|^2 + \lambda_s J_s(s) + \lambda_f J_f(f)}{||z-f||^2 + l_s J_s(s) + l_f J_f(f)} where \eqn{J_s}{J_s} is usually some cubic spline type wiggliness penalty on the boundary smooth and \eqn{J_f}{J_f} is the integral of \eqn{(f_xx+f_yy)^2}{(f_xx+f_yy)^2} over the interior of the boundary. Both penalties can be expressed as quadratic forms in the model coefficients. The \eqn{\lambda}{l}'s are smoothing parameters, selectable by GCV, REML, AIC, etc. \eqn{z}{z} represents noisy observations of \eqn{f}{f}. } \value{ A list with all the elements of \code{object} plus \item{sd}{ A list defining the PDE solution grid and domain boundary, and including the sparse LU factorization of the PDE coefficient matrix.} \item{X}{ The model matrix: this will have an \code{"offset"} attribute, if there are any known boundary conditions.} \item{S}{ List of smoothing penalty matrices (in smallest non-zero submatrix form).} \item{irng}{ A vector of scaling factors that have been applied to the model matrix, to ensure nice conditioning.} In addition there are all the elements usually added by \code{smooth.construct} methods. } \references{ Wood, S.N., M.V. Bravington and S.L. Hedley (2008) "Soap film smoothing", J.R.Statist.Soc.B 70(5), 931-955. \url{http://www.maths.bris.ac.uk/~sw15190/} } \section{WARNINGS }{ Soap film smooths are quite specialized, and require more setup than most smoothers (e.g. you have to supply the boundary and the interior knots, plus the boundary smooth basis dimension(s)). It is worth looking at the reference. } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \seealso{\code{\link{Predict.matrix.soap.film}}} \examples{ require(mgcv) ########################## ## simple test function... ########################## fsb <- list(fs.boundary()) nmax <- 100 ## create some internal knots... knots <- data.frame(v=rep(seq(-.5,3,by=.5),4), w=rep(c(-.6,-.3,.3,.6),rep(8,4))) ## Simulate some fitting data, inside boundary... set.seed(0) n<-600 v <- runif(n)*5-1;w<-runif(n)*2-1 y <- fs.test(v,w,b=1) names(fsb[[1]]) <- c("v","w") ind <- inSide(fsb,x=v,y=w) ## remove outsiders y <- y + rnorm(n)*.3 ## add noise y <- y[ind];v <- v[ind]; w <- w[ind] n <- length(y) par(mfrow=c(3,2)) ## plot boundary with knot and data locations plot(fsb[[1]]$v,fsb[[1]]$w,type="l");points(knots,pch=20,col=2) points(v,w,pch="."); ## Now fit the soap film smoother. 'k' is dimension of boundary smooth. ## boundary supplied in 'xt', and knots in 'knots'... nmax <- 100 ## reduced from default for speed. b <- gam(y~s(v,w,k=30,bs="so",xt=list(bnd=fsb,nmax=nmax)),knots=knots) plot(b) ## default plot plot(b,scheme=1) plot(b,scheme=2) plot(b,scheme=3) vis.gam(b,plot.type="contour") ################################ # Fit same model in two parts... ################################ par(mfrow=c(2,2)) vis.gam(b,plot.type="contour") b1 <- gam(y~s(v,w,k=30,bs="sf",xt=list(bnd=fsb,nmax=nmax))+ s(v,w,k=30,bs="sw",xt=list(bnd=fsb,nmax=nmax)) ,knots=knots) vis.gam(b,plot.type="contour") plot(b1) ################################################## ## Now an example with known boundary condition... ################################################## ## Evaluate known boundary condition at boundary nodes... fsb[[1]]$f <- fs.test(fsb[[1]]$v,fsb[[1]]$w,b=1,exclude=FALSE) ## Now fit the smooth... bk <- gam(y~s(v,w,bs="so",xt=list(bnd=fsb,nmax=nmax)),knots=knots) plot(bk) ## default plot ########################################## ## tensor product example... ########################################## \donttest{ set.seed(9) n <- 10000 v <- runif(n)*5-1;w<-runif(n)*2-1 t <- runif(n) y <- fs.test(v,w,b=1) y <- y + 4.2 y <- y^(.5+t) fsb <- list(fs.boundary()) names(fsb[[1]]) <- c("v","w") ind <- inSide(fsb,x=v,y=w) ## remove outsiders y <- y[ind];v <- v[ind]; w <- w[ind]; t <- t[ind] n <- length(y) y <- y + rnorm(n)*.05 ## add noise knots <- data.frame(v=rep(seq(-.5,3,by=.5),4), w=rep(c(-.6,-.3,.3,.6),rep(8,4))) ## notice NULL element in 'xt' list - to indicate no xt object for "cr" basis... bk <- gam(y~ te(v,w,t,bs=c("sf","cr"),k=c(25,4),d=c(2,1), xt=list(list(bnd=fsb,nmax=nmax),NULL))+ te(v,w,t,bs=c("sw","cr"),k=c(25,4),d=c(2,1), xt=list(list(bnd=fsb,nmax=nmax),NULL)),knots=knots) par(mfrow=c(3,2)) m<-100;n<-50 xm <- seq(-1,3.5,length=m);yn<-seq(-1,1,length=n) xx <- rep(xm,n);yy<-rep(yn,rep(m,n)) tru <- matrix(fs.test(xx,yy),m,n)+4.2 ## truth image(xm,yn,tru^.5,col=heat.colors(100),xlab="v",ylab="w", main="truth") lines(fsb[[1]]$v,fsb[[1]]$w,lwd=3) contour(xm,yn,tru^.5,add=TRUE) vis.gam(bk,view=c("v","w"),cond=list(t=0),plot.type="contour") image(xm,yn,tru,col=heat.colors(100),xlab="v",ylab="w", main="truth") lines(fsb[[1]]$v,fsb[[1]]$w,lwd=3) contour(xm,yn,tru,add=TRUE) vis.gam(bk,view=c("v","w"),cond=list(t=.5),plot.type="contour") image(xm,yn,tru^1.5,col=heat.colors(100),xlab="v",ylab="w", main="truth") lines(fsb[[1]]$v,fsb[[1]]$w,lwd=3) contour(xm,yn,tru^1.5,add=TRUE) vis.gam(bk,view=c("v","w"),cond=list(t=1),plot.type="contour") } ############################# # nested boundary example... ############################# bnd <- list(list(x=0,y=0),list(x=0,y=0)) seq(0,2*pi,length=100) -> theta bnd[[1]]$x <- sin(theta);bnd[[1]]$y <- cos(theta) bnd[[2]]$x <- .3 + .3*sin(theta); bnd[[2]]$y <- .3 + .3*cos(theta) plot(bnd[[1]]$x,bnd[[1]]$y,type="l") lines(bnd[[2]]$x,bnd[[2]]$y) ## setup knots k <- 8 xm <- seq(-1,1,length=k);ym <- seq(-1,1,length=k) x=rep(xm,k);y=rep(ym,rep(k,k)) ind <- inSide(bnd,x,y) knots <- data.frame(x=x[ind],y=y[ind]) points(knots$x,knots$y) ## a test function f1 <- function(x,y) { exp(-(x-.3)^2-(y-.3)^2) } ## plot the test function within the domain par(mfrow=c(2,3)) m<-100;n<-100 xm <- seq(-1,1,length=m);yn<-seq(-1,1,length=n) x <- rep(xm,n);y<-rep(yn,rep(m,n)) ff <- f1(x,y) ind <- inSide(bnd,x,y) ff[!ind] <- NA image(xm,yn,matrix(ff,m,n),xlab="x",ylab="y") contour(xm,yn,matrix(ff,m,n),add=TRUE) lines(bnd[[1]]$x,bnd[[1]]$y,lwd=2);lines(bnd[[2]]$x,bnd[[2]]$y,lwd=2) ## Simulate data by noisy sampling from test function... set.seed(1) x <- runif(300)*2-1;y <- runif(300)*2-1 ind <- inSide(bnd,x,y) x <- x[ind];y <- y[ind] n <- length(x) z <- f1(x,y) + rnorm(n)*.1 ## Fit a soap film smooth to the noisy data nmax <- 60 b <- gam(z~s(x,y,k=c(30,15),bs="so",xt=list(bnd=bnd,nmax=nmax)), knots=knots,method="REML") plot(b) ## default plot vis.gam(b,plot.type="contour") ## prettier version ## trying out separated fits.... ba <- gam(z~s(x,y,k=c(30,15),bs="sf",xt=list(bnd=bnd,nmax=nmax))+ s(x,y,k=c(30,15),bs="sw",xt=list(bnd=bnd,nmax=nmax)), knots=knots,method="REML") plot(ba) vis.gam(ba,plot.type="contour") } \keyword{models} \keyword{smooth} \keyword{regression}mgcv/man/full.score.Rd0000755000176200001440000000262113073161526014334 0ustar liggesusers\name{full.score} \alias{full.score} %- Also NEED an `\alias' for EACH other topic documented here. \title{GCV/UBRE score for use within nlm} \description{ Evaluates GCV/UBRE score for a GAM, given smoothing parameters. The routine calls \code{\link{gam.fit}} to fit the model, and is usually called by \code{\link{nlm}} to optimize the smoothing parameters. This is basically a service routine for \code{\link{gam}}, and is not usually called directly by users. It is only used in this context for GAMs fitted by outer iteration (see \code{\link{gam.outer}}) when the the outer method is \code{"nlm.fd"} (see \code{\link{gam}} argument \code{optimizer}). } \usage{ full.score(sp,G,family,control,gamma,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{sp}{The logs of the smoothing parameters} \item{G}{a list returned by \code{mgcv:::gam.setup}} \item{family}{The family object for the GAM.} \item{control}{a list returned be \code{\link{gam.control}}} \item{gamma}{the degrees of freedom inflation factor (usually 1).} \item{...}{other arguments, typically for passing on to \code{gam.fit}.} } \value{ The value of the GCV/UBRE score, with attribute \code{"full.gam.object"} which is the full object returned by \code{\link{gam.fit}}. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/gam2objective.Rd0000755000176200001440000000436713073161526015012 0ustar liggesusers\name{gam2objective} \alias{gam2objective} \alias{gam2derivative} %- Also NEED an `\alias' for EACH other topic documented here. \title{Objective functions for GAM smoothing parameter estimation} \description{Estimation of GAM smoothing parameters is most stable if optimization of the UBRE/AIC or GCV score is outer to the penalized iteratively re-weighted least squares scheme used to estimate the model given smoothing parameters. These functions evaluate the GCV/UBRE/AIC score of a GAM model, given smoothing parameters, in a manner suitable for use by \code{\link{optim}} or \code{\link{nlm}}. Not normally called directly, but rather service routines for \code{\link{gam.outer}}. } \usage{ gam2objective(lsp,args,...) gam2derivative(lsp,args,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{lsp}{The log smoothing parameters.} \item{args}{List of arguments required to call \code{\link{gam.fit3}}.} \item{...}{Other arguments for passing to \code{gam.fit3}.} } \details{ \code{gam2objective} and \code{gam2derivative} are functions suitable for calling by \code{\link{optim}}, to evaluate the GCV/UBRE/AIC score and its derivatives w.r.t. log smoothing parameters. \code{gam4objective} is an equivalent to \code{gam2objective}, suitable for optimization by \code{\link{nlm}} - derivatives of the GCV/UBRE/AIC function are calculated and returned as attributes. The basic idea of optimizing smoothing parameters `outer' to the P-IRLS loop was first proposed in O'Sullivan et al. (1986). } \references{ Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 O 'Sullivan, Yandall & Raynor (1986) Automatic smoothing of regression functions in generalized linear models. J. Amer. Statist. Assoc. 81:96-103. Wood, S.N. (2008) Fast stable direct fitting and smoothness selection for generalized additive models. J.R.Statist.Soc.B 70(3):495-518 \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{gam.fit3}}, \code{\link{gam}}, \code{\link{magic}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/logLik.gam.Rd0000755000176200001440000000632713303547351014253 0ustar liggesusers\name{logLik.gam} \alias{logLik.gam} \alias{AIC.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{AIC and Log likelihood for a fitted GAM} \description{ Function to extract the log-likelihood for a fitted \code{gam} model (note that the models are usually fitted by penalized likelihood maximization). Used by \code{\link{AIC}}. See details for more information on AIC computation. } \usage{ \method{logLik}{gam}(object,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ fitted model objects of class \code{gam} as produced by \code{gam()}.} \item{...}{un-used in this case} } \details{ Modification of \code{logLik.glm} which corrects the degrees of freedom for use with \code{gam} objects. The function is provided so that \code{\link{AIC}} functions correctly with \code{gam} objects, and uses the appropriate degrees of freedom (accounting for penalization). See e.g. Wood, Pya and Saefken (2016) for a derivation of an appropriate AIC. There are two possibile AIC's that might be considered for use with GAMs. Marginal AIC is based on the marginal likelihood of the GAM, that is the likelihood based on treating penalized (e.g. spline) coefficients as random and integrating them out. The degrees of freedom is then the number of smoothing/variance parameters + the number of fixed effects. The problem with Marginal AIC is that marginal likelihood underestimates variance components/oversmooths, so that the approach favours simpler models excessively (substituting REML does not work, because REML is not comparable between models with different unpenalized/fixed components). Conditional AIC uses the likelihood of all the model coefficients, evaluated at the penalized MLE. The degrees of freedom to use then is the effective degrees of freedom for the model. However, Greven and Kneib (2010) show that the neglect of smoothing parameter uncertainty can lead to this conditional AIC being excessively likely to select larger models. Wood, Pya and Saefken (2016) propose a simple correction to the effective degrees of freedom to fix this problem. \code{mgcv} applies this correction whenever possible: that is when using \code{ML} or \code{REML} smoothing parameter selection with \code{\link{gam}} or \code{\link{bam}}. The correction is not computable when using the Extended Fellner Schall or BFGS optimizer (since the correction requires an estimate of the covariance matrix of the log smoothing parameters). } \value{ Standard \code{logLik} object: see \code{\link{logLik}}. } \references{ Greven, S., and Kneib, T. (2010), On the Behaviour of Marginal and Conditional AIC in Linear Mixed Models, Biometrika, 97, 773-789. Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models (with discussion). Journal of the American Statistical Association 111, 1548-1575 \url{http://dx.doi.org/10.1080/01621459.2016.1180986} Wood S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org} based directly on \code{logLik.glm}} \seealso{ \code{\link{AIC}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/summary.gam.Rd0000755000176200001440000002554213303547337014533 0ustar liggesusers\name{summary.gam} \alias{summary.gam} \alias{print.summary.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Summary for a GAM fit} \description{ Takes a fitted \code{gam} object produced by \code{gam()} and produces various useful summaries from it. (See \code{\link{sink}} to divert output to a file.) } \usage{ \method{summary}{gam}(object, dispersion=NULL, freq=FALSE, re.test=TRUE, ...) \method{print}{summary.gam}(x,digits = max(3, getOption("digits") - 3), signif.stars = getOption("show.signif.stars"),...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ a fitted \code{gam} object as produced by \code{gam()}.} \item{x}{a \code{summary.gam} object produced by \code{summary.gam()}.} \item{dispersion}{A known dispersion parameter. \code{NULL} to use estimate or default (e.g. 1 for Poisson).} \item{freq}{By default p-values for parametric terms are calculated using the Bayesian estimated covariance matrix of the parameter estimators. If this is set to \code{TRUE} then the frequentist covariance matrix of the parameters is used instead. } \item{re.test}{Should tests be performed for random effect terms (including any term with a zero dimensional null space)? For large models these tests can be computationally expensive. } \item{digits}{controls number of digits printed in output.} \item{signif.stars}{Should significance stars be printed alongside output.} \item{...}{ other arguments.} } \details{ Model degrees of freedom are taken as the trace of the influence (or hat) matrix \eqn{ {\bf A}}{A} for the model fit. Residual degrees of freedom are taken as number of data minus model degrees of freedom. Let \eqn{ {\bf P}_i}{P_i} be the matrix giving the parameters of the ith smooth when applied to the data (or pseudodata in the generalized case) and let \eqn{ {\bf X}}{X} be the design matrix of the model. Then \eqn{ tr({\bf XP}_i )}{tr(XP_i)} is the edf for the ith term. Clearly this definition causes the edf's to add up properly! An alternative version of EDF is more appropriate for p-value computation, and is based on the trace of \eqn{ 2{\bf A} - {\bf AA}}{2A - AA}. \code{print.summary.gam} tries to print various bits of summary information useful for term selection in a pretty way. P-values for smooth terms are usually based on a test statistic motivated by an extension of Nychka's (1988) analysis of the frequentist properties of Bayesian confidence intervals for smooths (Marra and Wood, 2012). These have better frequentist performance (in terms of power and distribution under the null) than the alternative strictly frequentist approximation. When the Bayesian intervals have good across the function properties then the p-values have close to the correct null distribution and reasonable power (but there are no optimality results for the power). Full details are in Wood (2013b), although what is computed is actually a slight variant in which the components of the test statistic are weighted by the iterative fitting weights. Note that for terms with no unpenalized terms (such as Gaussian random effects) the Nychka (1988) requirement for smoothing bias to be substantially less than variance breaks down (see e.g. appendix of Marra and Wood, 2012), and this results in incorrect null distribution for p-values computed using the above approach. In this case it is necessary to use an alternative approach designed for random effects variance components, and this is done. See Wood (2013a) for details: the test is based on a likelihood ratio statistic (with the reference distribution appropriate for the null hypothesis on the boundary of the parameter space). All p-values are computed without considering uncertainty in the smoothing parameter estimates. In simulations the p-values have best behaviour under ML smoothness selection, with REML coming second. In general the p-values behave well, but neglecting smoothing parameter uncertainty means that they may be somewhat too low when smoothing parameters are highly uncertain. High uncertainty happens in particular when smoothing parameters are poorly identified, which can occur with nested smooths or highly correlated covariates (high concurvity). By default the p-values for parametric model terms are also based on Wald tests using the Bayesian covariance matrix for the coefficients. This is appropriate when there are "re" terms present, and is otherwise rather similar to the results using the frequentist covariance matrix (\code{freq=TRUE}), since the parametric terms themselves are usually unpenalized. Default P-values for parameteric terms that are penalized using the \code{paraPen} argument will not be good. However if such terms represent conventional random effects with full rank penalties, then setting \code{freq=TRUE} is appropriate. } \value{\code{summary.gam} produces a list of summary information for a fitted \code{gam} object. \item{p.coeff}{is an array of estimates of the strictly parametric model coefficients.} \item{p.t}{is an array of the \code{p.coeff}'s divided by their standard errors.} \item{p.pv}{is an array of p-values for the null hypothesis that the corresponding parameter is zero. Calculated with reference to the t distribution with the estimated residual degrees of freedom for the model fit if the dispersion parameter has been estimated, and the standard normal if not.} \item{m}{The number of smooth terms in the model.} \item{chi.sq}{An array of test statistics for assessing the significance of model smooth terms. See details.} \item{s.pv}{An array of approximate p-values for the null hypotheses that each smooth term is zero. Be warned, these are only approximate.} \item{se}{array of standard error estimates for all parameter estimates.} \item{r.sq}{The adjusted r-squared for the model. Defined as the proportion of variance explained, where original variance and residual variance are both estimated using unbiased estimators. This quantity can be negative if your model is worse than a one parameter constant model, and can be higher for the smaller of two nested models! The proportion null deviance explained is probably more appropriate for non-normal errors. Note that \code{r.sq} does not include any offset in the one parameter model.} \item{dev.expl}{The proportion of the null deviance explained by the model. The null deviance is computed taking account of any offset, so \code{dev.expl} can be substantially lower than \code{r.sq} when an offset is present.} \item{edf}{array of estimated degrees of freedom for the model terms.} \item{residual.df}{estimated residual degrees of freedom.} \item{n}{number of data.} \item{np}{number of model coefficients (regression coefficients, not smoothing parameters or other parameters of likelihood).} \item{rank}{apparent model rank.} \item{method}{The smoothing selection criterion used.} \item{sp.criterion}{The minimized value of the smoothness selection criterion. Note that for ML and REML methods, what is reported is the negative log marginal likelihood or negative log restricted likelihood. } \item{scale}{estimated (or given) scale parameter.} \item{family}{the family used.} \item{formula}{the original GAM formula.} \item{dispersion}{the scale parameter.} \item{pTerms.df}{the degrees of freedom associated with each parametric term (excluding the constant).} \item{pTerms.chi.sq}{a Wald statistic for testing the null hypothesis that the each parametric term is zero.} \item{pTerms.pv}{p-values associated with the tests that each term is zero. For penalized fits these are approximate. The reference distribution is an appropriate chi-squared when the scale parameter is known, and is based on an F when it is not.} \item{cov.unscaled}{The estimated covariance matrix of the parameters (or estimators if \code{freq=TRUE}), divided by scale parameter.} \item{cov.scaled}{The estimated covariance matrix of the parameters (estimators if \code{freq=TRUE}).} \item{p.table}{significance table for parameters} \item{s.table}{significance table for smooths} \item{p.Terms}{significance table for parametric model terms} } \references{ Marra, G and S.N. Wood (2012) Coverage Properties of Confidence Intervals for Generalized Additive Model Components. Scandinavian Journal of Statistics, 39(1), 53-74. Nychka (1988) Bayesian Confidence Intervals for Smoothing Splines. Journal of the American Statistical Association 83:1134-1143. Wood, S.N. (2013a) A simple test for random effects in regression models. Biometrika 100:1005-1010 Wood, S.N. (2013b) On p-values for smooth components of an extended generalized additive model. Biometrika 100:221-228 Wood S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org} with substantial improvements by Henric Nilsson.} \section{WARNING }{ The p-values are approximate and neglect smoothing parameter uncertainty. They are likely to be somewhat too low when smoothing parameter estimates are highly uncertain: do read the details section. If the exact values matter, read Wood (2013a or b). P-values for terms penalized via `paraPen' are unlikely to be correct. } \seealso{ \code{\link{gam}}, \code{\link{predict.gam}}, \code{\link{gam.check}}, \code{\link{anova.gam}}, \code{\link{gam.vcomp}}, \code{\link{sp.vcov}} } \examples{ library(mgcv) set.seed(0) dat <- gamSim(1,n=200,scale=2) ## simulate data b <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat) plot(b,pages=1) summary(b) ## now check the p-values by using a pure regression spline..... b.d <- round(summary(b)$edf)+1 ## get edf per smooth b.d <- pmax(b.d,3) # can't have basis dimension less than 3! bc<-gam(y~s(x0,k=b.d[1],fx=TRUE)+s(x1,k=b.d[2],fx=TRUE)+ s(x2,k=b.d[3],fx=TRUE)+s(x3,k=b.d[4],fx=TRUE),data=dat) plot(bc,pages=1) summary(bc) ## Example where some p-values are less reliable... dat <- gamSim(6,n=200,scale=2) b <- gam(y~s(x0,m=1)+s(x1)+s(x2)+s(x3)+s(fac,bs="re"),data=dat) ## Here s(x0,m=1) can be penalized to zero, so p-value approximation ## cruder than usual... summary(b) ## p-value check - increase k to make this useful! k<-20;n <- 200;p <- rep(NA,k) for (i in 1:k) { b<-gam(y~te(x,z),data=data.frame(y=rnorm(n),x=runif(n),z=runif(n)), method="ML") p[i]<-summary(b)$s.p[1] } plot(((1:k)-0.5)/k,sort(p)) abline(0,1,col=2) ks.test(p,"punif") ## how close to uniform are the p-values? ## A Gamma example, by modify `gamSim' output... dat <- gamSim(1,n=400,dist="normal",scale=1) dat$f <- dat$f/4 ## true linear predictor Ey <- exp(dat$f);scale <- .5 ## mean and GLM scale parameter ## Note that `shape' and `scale' in `rgamma' are almost ## opposite terminology to that used with GLM/GAM... dat$y <- rgamma(Ey*0,shape=1/scale,scale=Ey*scale) bg <- gam(y~ s(x0)+ s(x1)+s(x2)+s(x3),family=Gamma(link=log), data=dat,method="REML") summary(bg) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/rig.Rd0000644000176200001440000000345713073161526013046 0ustar liggesusers\name{rig} \alias{rig} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generate inverse Gaussian random deviates} \description{Generates inverse Gaussian random deviates. } \usage{ rig(n,mean,scale) } %- maybe also `usage' for other objects documented here. \arguments{ \item{n}{the number of deviates required. If this has length > 1 then the length is taken as the number of deviates required.} \item{mean}{vector of mean values.} \item{scale}{vector of scale parameter values (lambda, see below)} } \value{ A vector of inverse Gaussian random deviates. } \details{ If x if the returned vector, then E(x) = \code{mean} while var(x) = \code{scale*mean^3}. For density and distribution functions see the \code{statmod} package. The algorithm used is Algorithm 5.7 of Gentle (2003), based on Michael et al. (1976). Note that \code{scale} here is the scale parameter in the GLM sense, which is the reciprocal of the usual `lambda' parameter. } \references{ Gentle, J.E. (2003) Random Number Generation and Monte Carlo Methods (2nd ed.) Springer. Michael, J.R., W.R. Schucany & R.W. Hass (1976) Generating random variates using transformations with multiple roots. The American Statistician 30, 88-90. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \examples{ require(mgcv) set.seed(7) ## An inverse.gaussian GAM example, by modify `gamSim' output... dat <- gamSim(1,n=400,dist="normal",scale=1) dat$f <- dat$f/4 ## true linear predictor Ey <- exp(dat$f);scale <- .5 ## mean and GLM scale parameter ## simulate inverse Gaussian response... dat$y <- rig(Ey,mean=Ey,scale=.2) big <- gam(y~ s(x0)+ s(x1)+s(x2)+s(x3),family=inverse.gaussian(link=log), data=dat,method="REML") plot(big,pages=1) gam.check(big) summary(big) } mgcv/man/gam.control.Rd0000755000176200001440000001616313303547351014511 0ustar liggesusers\name{gam.control} \alias{gam.control} %- Also NEED an `\alias' for EACH other topic documented here. \title{Setting GAM fitting defaults} \description{ This is an internal function of package \code{mgcv} which allows control of the numerical options for fitting a GAM. Typically users will want to modify the defaults if model fitting fails to converge, or if the warnings are generated which suggest a loss of numerical stability during fitting. To change the default choise of fitting method, see \code{\link{gam}} arguments \code{method} and \code{optimizer}. } \usage{ gam.control(nthreads=1,irls.reg=0.0,epsilon = 1e-07, maxit = 200, mgcv.tol=1e-7,mgcv.half=15, trace = FALSE, rank.tol=.Machine$double.eps^0.5,nlm=list(), optim=list(),newton=list(),outerPIsteps=0, idLinksBases=TRUE,scalePenalty=TRUE,efs.lspmax=15, efs.tol=.1,keepData=FALSE,scale.est="fletcher", edge.correct=FALSE) } \arguments{ \item{nthreads}{Some parts of some smoothing parameter selection methods (e.g. REML) can use some parallelization in the C code if your R installation supports openMP, and \code{nthreads} is set to more than 1. Note that it is usually better to use the number of physical cores here, rather than the number of hyper-threading cores.} \item{irls.reg}{For most models this should be 0. The iteratively re-weighted least squares method by which GAMs are fitted can fail to converge in some circumstances. For example, data with many zeroes can cause problems in a model with a log link, because a mean of zero corresponds to an infinite range of linear predictor values. Such convergence problems are caused by a fundamental lack of identifiability, but do not show up as lack of identifiability in the penalized linear model problems that have to be solved at each stage of iteration. In such circumstances it is possible to apply a ridge regression penalty to the model to impose identifiability, and \code{irls.reg} is the size of the penalty. } \item{epsilon}{This is used for judging conversion of the GLM IRLS loop in \code{\link{gam.fit}} or \code{\link{gam.fit3}}.} \item{maxit}{Maximum number of IRLS iterations to perform.} \item{mgcv.tol}{The convergence tolerance parameter to use in GCV/UBRE optimization.} \item{mgcv.half}{If a step of the GCV/UBRE optimization method leads to a worse GCV/UBRE score, then the step length is halved. This is the number of halvings to try before giving up.} \item{trace}{Set this to \code{TRUE} to turn on diagnostic output.} \item{rank.tol}{The tolerance used to estimate the rank of the fitting problem.} \item{nlm}{list of control parameters to pass to \code{\link{nlm}} if this is used for outer estimation of smoothing parameters (not default). See details.} \item{optim}{list of control parameters to pass to \code{\link{optim}} if this is used for outer estimation of smoothing parameters (not default). See details.} \item{newton}{list of control parameters to pass to default Newton optimizer used for outer estimation of log smoothing parameters. See details.} \item{outerPIsteps}{The number of performance interation steps used to initialize outer iteration.} \item{idLinksBases}{If smooth terms have their smoothing parameters linked via the \code{id} mechanism (see \code{\link{s}}), should they also have the same bases. Set this to \code{FALSE} only if you are sure you know what you are doing (you should almost surely set \code{scalePenalty} to \code{FALSE} as well in this case).} \item{scalePenalty}{\code{\link{gamm}} is somewhat sensitive to the absolute scaling of the penalty matrices of a smooth relative to its model matrix. This option rescales the penalty matrices to accomodate this problem. Probably should be set to \code{FALSE} if you are linking smoothing parameters but have set \code{idLinkBases} to \code{FALSE}.} \item{efs.lspmax}{maximum log smoothing parameters to allow under extended Fellner Schall smoothing parameter optimization.} \item{efs.tol}{change in REML to count as negligible when testing for EFS convergence. If the step is small and the last 3 steps led to a REML change smaller than this, then stop.} \item{keepData}{Should a copy of the original \code{data} argument be kept in the \code{gam} object? Strict compatibility with class \code{glm} would keep it, but it wastes space to do so. } \item{scale.est}{How to estimate the scale parameter for exponential family models estimated by outer iteration. See \code{\link{gam.scale}}.} \item{edge.correct}{With RE/ML smoothing parameter selection in \code{gam} using the default Newton RE/ML optimizer, it is possible to improve inference at the `completely smooth' edge of the smoothing parameter space, by decreasing smoothing parameters until there is a small increase in the negative RE/ML (e.g. 0.02). Set to \code{TRUE} or to a number representing the target increase to use. Only changes the corrected smoothing parameter matrix, \code{Vc}.} } \details{ Outer iteration using \code{newton} is controlled by the list \code{newton} with the following elements: \code{conv.tol} (default 1e-6) is the relative convergence tolerance; \code{maxNstep} is the maximum length allowed for an element of the Newton search direction (default 5); \code{maxSstep} is the maximum length allowed for an element of the steepest descent direction (only used if Newton fails - default 2); \code{maxHalf} is the maximum number of step halvings to permit before giving up (default 30). If outer iteration using \code{\link{nlm}} is used for fitting, then the control list \code{nlm} stores control arguments for calls to routine \code{\link{nlm}}. The list has the following named elements: (i) \code{ndigit} is the number of significant digits in the GCV/UBRE score - by default this is worked out from \code{epsilon}; (ii) \code{gradtol} is the tolerance used to judge convergence of the gradient of the GCV/UBRE score to zero - by default set to \code{10*epsilon}; (iii) \code{stepmax} is the maximum allowable log smoothing parameter step - defaults to 2; (iv) \code{steptol} is the minimum allowable step length - defaults to 1e-4; (v) \code{iterlim} is the maximum number of optimization steps allowed - defaults to 200; (vi) \code{check.analyticals} indicates whether the built in exact derivative calculations should be checked numerically - defaults to \code{FALSE}. Any of these which are not supplied and named in the list are set to their default values. Outer iteration using \code{\link{optim}} is controlled using list \code{optim}, which currently has one element: \code{factr} which takes default value 1e7. } \references{ Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 Wood, S.N. (2004) Stable and efficient multiple smoothing parameter estimation for generalized additive models. J. Amer. Statist. Ass.99:673-686. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{gam}}, \code{\link{gam.fit}}, \code{\link{glm.control}} } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/coxph.Rd0000755000176200001440000001673213401423462013404 0ustar liggesusers\name{cox.ph} \alias{cox.ph} %- Also NEED an `\alias' for EACH other topic documented here. \title{Additive Cox Proportional Hazard Model} \description{The \code{cox.ph} family implements the Cox Proportional Hazards model with Peto's correction for ties, optional stratification, and estimation by penalized partial likelihood maximization, for use with \code{\link{gam}}. In the model formula, event time is the response. Under stratification the response has two columns: time and a numeric index for stratum. The \code{weights} vector provides the censoring information (0 for censoring, 1 for event). \code{cox.ph} deals with the case in which each subject has one event/censoring time and one row of covariate values. When each subject has several time dependent covariates see \code{\link{cox.pht}}. See example below for conditional logistic regression. } \usage{ cox.ph(link="identity") } \arguments{ \item{link}{currently (and possibly for ever) only \code{"identity"} supported.} } \value{ An object inheriting from class \code{general.family}. } \details{Used with \code{\link{gam}} to fit Cox Proportional Hazards models to survival data. The model formula will have event/censoring times on the left hand side and the linear predictor specification on the right hand side. Censoring information is provided by the \code{weights} argument to \code{gam}, with 1 indicating an event and 0 indicating censoring. Stratification is possible, allowing for different baseline hazards in different strata. In that case the response has two columns: the first is event/censoring time and the second is a numeric stratum index. See below for an example. Prediction from the fitted model object (using the \code{predict} method) with \code{type="response"} will predict on the survivor function scale. This requires evaluation times to be provided as well as covariates (see example). Also see example code below for extracting the cumulative baseline hazard/survival directly. Martingale or deviance residuals can be extracted. The \code{fitted.values} stored in the model object are survival function estimates for each subject at their event/censoring time. Estimation of model coefficients is by maximising the log-partial likelihood penalized by the smoothing penalties. See e.g. Hastie and Tibshirani, 1990, section 8.3. for the partial likelihood used (with Peto's approximation for ties), but note that optimization of the partial likelihood does not follow Hastie and Tibshirani. See Klein amd Moeschberger (2003) for estimation of residuals, the cumulative baseline hazard, survival function and associated standard errors (the survival standard error expression has a typo). The percentage deviance explained reported for Cox PH models is based on the sum of squares of the deviance residuals, as the model deviance, and the sum of squares of the deviance residuals when the covariate effects are set to zero, as the null deviance. The same baseline hazard estimate is used for both. This family deals efficiently with the case in which each subject has one event/censoring time and one row of covariate values. For studies in which there are multiple time varying covariate measures for each subject then the equivalent Poisson model should be fitted to suitable pseudodata using \code{bam(...,discrete=TRUE)}. See \code{\link{cox.pht}}. } \references{ Hastie and Tibshirani (1990) Generalized Additive Models, Chapman and Hall. Klein, J.P and Moeschberger, M.L. (2003) Survival Analysis: Techniques for Censored and Truncated Data (2nd ed.) Springer. Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association 111, 1548-1575 \url{http://dx.doi.org/10.1080/01621459.2016.1180986} } \seealso{\code{\link{cox.pht}}} \examples{ library(mgcv) library(survival) ## for data col1 <- colon[colon$etype==1,] ## concentrate on single event col1$differ <- as.factor(col1$differ) col1$sex <- as.factor(col1$sex) b <- gam(time~s(age,by=sex)+sex+s(nodes)+perfor+rx+obstruct+adhere, family=cox.ph(),data=col1,weights=status) summary(b) plot(b,pages=1,all.terms=TRUE) ## plot effects plot(b$linear.predictors,residuals(b)) ## plot survival function for patient j... np <- 300;j <- 6 newd <- data.frame(time=seq(0,3000,length=np)) dname <- names(col1) for (n in dname) newd[[n]] <- rep(col1[[n]][j],np) newd$time <- seq(0,3000,length=np) fv <- predict(b,newdata=newd,type="response",se=TRUE) plot(newd$time,fv$fit,type="l",ylim=c(0,1),xlab="time",ylab="survival") lines(newd$time,fv$fit+2*fv$se.fit,col=2) lines(newd$time,fv$fit-2*fv$se.fit,col=2) ## crude plot of baseline survival... plot(b$family$data$tr,exp(-b$family$data$h),type="l",ylim=c(0,1), xlab="time",ylab="survival") lines(b$family$data$tr,exp(-b$family$data$h + 2*b$family$data$q^.5),col=2) lines(b$family$data$tr,exp(-b$family$data$h - 2*b$family$data$q^.5),col=2) lines(b$family$data$tr,exp(-b$family$data$km),lty=2) ## Kaplan Meier ## stratification example, with 2 randomly allocated strata ## so that results should be similar to previous.... col1$strata <- sample(1:2,nrow(col1),replace=TRUE) bs <- gam(cbind(time,strata)~s(age,by=sex)+sex+s(nodes)+perfor+rx+obstruct+adhere, family=cox.ph(),data=col1,weights=status) plot(bs,pages=1,all.terms=TRUE) ## plot effects ## baseline survival plots by strata... for (i in 1:2) { ## loop over strata ## create index picking out elements of stored hazard info for this stratum... ind <- which(bs$family$data$tr.strat == i) if (i==1) plot(bs$family$data$tr[ind],exp(-bs$family$data$h[ind]),type="l",ylim=c(0,1), xlab="time",ylab="survival",lwd=2,col=i) else lines(bs$family$data$tr[ind],exp(-bs$family$data$h[ind]),lwd=2,col=i) lines(bs$family$data$tr[ind],exp(-bs$family$data$h[ind] + 2*bs$family$data$q[ind]^.5),lty=2,col=i) ## upper ci lines(bs$family$data$tr[ind],exp(-bs$family$data$h[ind] - 2*bs$family$data$q[ind]^.5),lty=2,col=i) ## lower ci lines(bs$family$data$tr[ind],exp(-bs$family$data$km[ind]),col=i) ## KM } ## Simple simulated known truth example... ph.weibull.sim <- function(eta,gamma=1,h0=.01,t1=100) { lambda <- h0*exp(eta) n <- length(eta) U <- runif(n) t <- (-log(U)/lambda)^(1/gamma) d <- as.numeric(t <= t1) t[!d] <- t1 list(t=t,d=d) } n <- 500;set.seed(2) x0 <- runif(n, 0, 1);x1 <- runif(n, 0, 1) x2 <- runif(n, 0, 1);x3 <- runif(n, 0, 1) f0 <- function(x) 2 * sin(pi * x) f1 <- function(x) exp(2 * x) f2 <- function(x) 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 f3 <- function(x) 0*x f <- f0(x0) + f1(x1) + f2(x2) g <- (f-mean(f))/5 surv <- ph.weibull.sim(g) surv$x0 <- x0;surv$x1 <- x1;surv$x2 <- x2;surv$x3 <- x3 b <- gam(t~s(x0)+s(x1)+s(x2,k=15)+s(x3),family=cox.ph,weights=d,data=surv) plot(b,pages=1) ## conditional logistic regression models are often estimated using the ## cox proportional hazards partial likelihood with a strata for each ## case-control group. A dummy vector of times is created (all equal). ## The following compares to 'clogit' for a simple case. Note that ## the gam log likelihood is not exact if there is more than one case ## per stratum, corresponding to clogit's approximate method. library(survival);library(mgcv) infert$dumt <- rep(1,nrow(infert)) mg <- gam(cbind(dumt,stratum) ~ spontaneous + induced, data=infert, family=cox.ph,weights=case) ms <- clogit(case ~ spontaneous + induced + strata(stratum), data=infert, method="approximate") summary(mg)$p.table[1:2,]; ms } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/magic.Rd0000755000176200001440000003130213073161526013336 0ustar liggesusers\name{magic} \alias{magic} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Stable Multiple Smoothing Parameter Estimation by GCV or UBRE} \description{ Function to efficiently estimate smoothing parameters in generalized ridge regression problems with multiple (quadratic) penalties, by GCV or UBRE. The function uses Newton's method in multi-dimensions, backed up by steepest descent to iteratively adjust the smoothing parameters for each penalty (one penalty may have a smoothing parameter fixed at 1). For maximal numerical stability the method is based on orthogonal decomposition methods, and attempts to deal with numerical rank deficiency gracefully using a truncated singular value decomposition approach. } %- end description \usage{ magic(y,X,sp,S,off,L=NULL,lsp0=NULL,rank=NULL,H=NULL,C=NULL, w=NULL,gamma=1,scale=1,gcv=TRUE,ridge.parameter=NULL, control=list(tol=1e-6,step.half=25,rank.tol= .Machine$double.eps^0.5),extra.rss=0,n.score=length(y),nthreads=1) } %- maybe also `usage' for other objects documented here. \arguments{ \item{y}{is the response data vector.} \item{X}{is the model matrix (more columns than rows are allowed).} \item{sp}{is the array of smoothing parameters. The vector \code{L\%*\%log(sp) + lsp0} contains the logs of the smoothing parameters that actually multiply the penalty matrices stored in \code{S} (\code{L} is taken as the identity if \code{NULL}). Any \code{sp} values that are negative are autoinitialized, otherwise they are taken as supplying starting values. A supplied starting value will be reset to a default starting value if the gradient of the GCV/UBRE score is too small at the supplied value. } \item{S}{ is a list of of penalty matrices. \code{S[[i]]} is the ith penalty matrix, but note that it is not stored as a full matrix, but rather as the smallest square matrix including all the non-zero elements of the penalty matrix. Element 1,1 of \code{S[[i]]} occupies element \code{off[i]}, \code{off[i]} of the ith penalty matrix. Each \code{S[[i]]} must be positive semi-definite. Set to \code{list()} if there are no smoothing parameters to be estimated. } \item{off}{is an array indicating the first parameter in the parameter vector that is penalized by the penalty involving \code{S[[i]]}.} \item{L}{is a matrix mapping \code{log(sp)} to the log smoothing parameters that actually multiply the penalties defined by the elemts of \code{S}. Taken as the identity, if \code{NULL}. See above under \code{sp}.} \item{lsp0}{If \code{L} is not \code{NULL} this is a vector of constants in the linear transformation from \code{log(sp)} to the actual log smoothing parameters. So the logs of the smoothing parameters multiplying the \code{S[[i]]} are given by \code{L\%*\%log(sp) + lsp0}. Taken as 0 if \code{NULL}.} \item{rank}{ is an array specifying the ranks of the penalties. This is useful, but not essential, for forming square roots of the penalty matrices.} \item{H}{ is the optional offset penalty - i.e. a penalty with a smoothing parameter fixed at 1. This is useful for allowing regularization of the estimation process, fixed smoothing penalties etc.} \item{C}{ is the optional matrix specifying any linear equality constraints on the fitting problem. If \eqn{\bf b}{b} is the parameter vector then the parameters are forced to satisfy \eqn{ {\bf Cb} = {\bf 0} }{Cb=0}. } \item{w}{ the regression weights. If this is a matrix then it is taken as being the square root of the inverse of the covariance matrix of \code{y}, specifically \eqn{ {\bf V}_y^{-1} = {\bf w}^\prime{\bf w}}{V_y^{-1}=w'w}. If \code{w} is an array then it is taken as the diagonal of this matrix, or simply the weight for each element of \code{y}. See below for an example using this.} \item{gamma}{is an inflation factor for the model degrees of freedom in the GCV or UBRE score.} \item{scale}{ is the scale parameter for use with UBRE.} \item{gcv}{ should be set to \code{TRUE} if GCV is to be used, \code{FALSE} for UBRE.} \item{ridge.parameter}{It is sometimes useful to apply a ridge penalty to the fitting problem, penalizing the parameters in the constrained space directly. Setting this parameter to a value greater than zero will cause such a penalty to be used, with the magnitude given by the parameter value.} \item{control}{ is a list of iteration control constants with the following elements: \describe{ \item{tol}{The tolerance to use in judging convergence.} \item{step.half}{If a trial step fails then the method tries halving it up to a maximum of \code{step.half} times.} \item{rank.tol}{is a constant used to test for numerical rank deficiency of the problem. Basically any singular value less than \code{rank_tol} multiplied by the largest singular value of the problem is set to zero.} } } %- end of control \item{extra.rss}{is a constant to be added to the residual sum of squares (squared norm) term in the calculation of the GCV, UBRE and scale parameter estimate. In conjuction with \code{n.score}, this is useful for certain methods for dealing with very large data sets.} \item{n.score}{number to use as the number of data in GCV/UBRE score calculation: usually the actual number of data, but there are methods for dealing with very large datasets that change this.} \item{nthreads}{\code{magic} can make use of multiple threads if this is set to >1.} } \details{ The method is a computationally efficient means of applying GCV or UBRE (often approximately AIC) to the problem of smoothing parameter selection in generalized ridge regression problems of the form: \deqn{ minimise~ \| { \bf W} ({ \bf Xb - y} ) \|^2 + {\bf b}^\prime {\bf Hb} + \sum_{i=1}^m \theta_i {\bf b^\prime S}_i{\bf b} }{ min ||W(Xb-y)||^2 + b'Hb + theta_1 b'S_1 b + theta_2 b'S_2 b + . . .} possibly subject to constraints \eqn{ {\bf Cb}={\bf 0}}{Cb=0}. \eqn{ {\bf X}}{X} is a design matrix, \eqn{\bf b}{b} a parameter vector, \eqn{\bf y}{y} a data vector, \eqn{\bf W}{W} a weight matrix, \eqn{ {\bf S}_i}{S_i} a positive semi-definite matrix of coefficients defining the ith penalty with associated smoothing parameter \eqn{\theta_i}{theta_i}, \eqn{\bf H}{H} is the positive semi-definite offset penalty matrix and \eqn{\bf C}{C} a matrix of coefficients defining any linear equality constraints on the problem. \eqn{ {\bf X}}{X} need not be of full column rank. The \eqn{\theta_i}{theta_i} are chosen to minimize either the GCV score: \deqn{V_g = \frac{n\|{\bf W}({\bf y} - {\bf Ay})\|^2}{[tr({\bf I} - \gamma {\bf A})]^2}}{V_g = n ||W(y-Ay)||^2/[tr(I - g A)]^2} or the UBRE score: \deqn{V_u=\|{\bf W}({\bf y}-{\bf Ay})\|^2/n-2 \phi tr({\bf I}-\gamma {\bf A})/n + \phi}{ V_u =||W(y-Ay||^2/n - 2 s tr(I - g A)/n + s } where \eqn{\gamma}{g} is \code{gamma} the inflation factor for degrees of freedom (usually set to 1) and \eqn{\phi}{s} is \code{scale}, the scale parameter. \eqn{\bf A}{A} is the hat matrix (influence matrix) for the fitting problem (i.e the matrix mapping data to fitted values). Dependence of the scores on the smoothing parameters is through \eqn{\bf A}{A}. The method operates by Newton or steepest descent updates of the logs of the \eqn{\theta_i}{theta_i}. A key aspect of the method is stable and economical calculation of the first and second derivatives of the scores w.r.t. the log smoothing parameters. Because the GCV/UBRE scores are flat w.r.t. very large or very small \eqn{\theta_i}{theta_i}, it's important to get good starting parameters, and to be careful not to step into a flat region of the smoothing parameter space. For this reason the algorithm rescales any Newton step that would result in a \eqn{log(\theta_i)}{log(theta_i)} change of more than 5. Newton steps are only used if the Hessian of the GCV/UBRE is postive definite, otherwise steepest descent is used. Similarly steepest descent is used if the Newton step has to be contracted too far (indicating that the quadratic model underlying Newton is poor). All initial steepest descent steps are scaled so that their largest component is 1. However a step is calculated, it is never expanded if it is successful (to avoid flat portions of the objective), but steps are successively halved if they do not decrease the GCV/UBRE score, until they do, or the direction is deemed to have failed. (Given the smoothing parameters the optimal \eqn{\bf b}{b} parameters are easily found.) The method is coded in \code{C} with matrix factorizations performed using LINPACK and LAPACK routines. } \value{The function returns a list with the following items: \item{b}{The best fit parameters given the estimated smoothing parameters.} \item{scale}{the estimated (GCV) or supplied (UBRE) scale parameter.} \item{score}{the minimized GCV or UBRE score.} \item{sp}{an array of the estimated smoothing parameters.} \item{sp.full}{an array of the smoothing parameters that actually multiply the elements of \code{S} (same as \code{sp} if \code{L} was \code{NULL}). This is \code{exp(L\%*\%log(sp))}.} \item{rV}{a factored form of the parameter covariance matrix. The (Bayesian) covariance matrix of the parametes \code{b} is given by \code{rV\%*\%t(rV)*scale}. } \item{gcv.info}{is a list of information about the performance of the method with the following elements: \describe{ \item{full.rank}{The apparent rank of the problem: number of parameters less number of equality constraints.} \item{rank}{The estimated actual rank of the problem (at the final iteration of the method).} \item{fully.converged}{is \code{TRUE} if the method converged by satisfying the convergence criteria, and \code{FALSE} if it coverged by failing to decrease the score along the search direction.} \item{hess.pos.def}{is \code{TRUE} if the hessian of the UBRE or GCV score was positive definite at convergence.} \item{iter}{is the number of Newton/Steepest descent iterations taken.} \item{score.calls}{is the number of times that the GCV/UBRE score had to be evaluated.} \item{rms.grad}{is the root mean square of the gradient of the UBRE/GCV score w.r.t. the smoothing parameters.} \item{R}{The factor R from the QR decomposition of the weighted model matrix. This is un-pivoted so that column order corresponds to \code{X}. So it may not be upper triangular.}} } Note that some further useful quantities can be obtained using \code{\link{magic.post.proc}}. } \references{ Wood, S.N. (2004) Stable and efficient multiple smoothing parameter estimation for generalized additive models. J. Amer. Statist. Ass. 99:673-686 \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{magic.post.proc}},\code{\link{gam}} } \examples{ ## Use `magic' for a standard additive model fit ... library(mgcv) set.seed(1);n <- 200;sig <- 1 dat <- gamSim(1,n=n,scale=sig) k <- 30 ## set up additive model G <- gam(y~s(x0,k=k)+s(x1,k=k)+s(x2,k=k)+s(x3,k=k),fit=FALSE,data=dat) ## fit using magic (and gam default tolerance) mgfit <- magic(G$y,G$X,G$sp,G$S,G$off,rank=G$rank, control=list(tol=1e-7,step.half=15)) ## and fit using gam as consistency check b <- gam(G=G) mgfit$sp;b$sp # compare smoothing parameter estimates edf <- magic.post.proc(G$X,mgfit,G$w)$edf # get e.d.f. per param range(edf-b$edf) # compare ## p>n example... fit model to first 100 data only, so more ## params than data... mgfit <- magic(G$y[1:100],G$X[1:100,],G$sp,G$S,G$off,rank=G$rank) edf <- magic.post.proc(G$X[1:100,],mgfit,G$w[1:100])$edf ## constrain first two smooths to have identical smoothing parameters L <- diag(3);L <- rbind(L[1,],L) mgfit <- magic(G$y,G$X,rep(-1,3),G$S,G$off,L=L,rank=G$rank,C=G$C) ## Now a correlated data example ... library(nlme) ## simulate truth set.seed(1);n<-400;sig<-2 x <- 0:(n-1)/(n-1) f <- 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 ## produce scaled covariance matrix for AR1 errors... V <- corMatrix(Initialize(corAR1(.6),data.frame(x=x))) Cv <- chol(V) # t(Cv)%*%Cv=V ## Simulate AR1 errors ... e <- t(Cv)\%*\%rnorm(n,0,sig) # so cov(e) = V * sig^2 ## Observe truth + AR1 errors y <- f + e ## GAM ignoring correlation par(mfrow=c(1,2)) b <- gam(y~s(x,k=20)) plot(b);lines(x,f-mean(f),col=2);title("Ignoring correlation") ## Fit smooth, taking account of *known* correlation... w <- solve(t(Cv)) # V^{-1} = w'w ## Use `gam' to set up model for fitting... G <- gam(y~s(x,k=20),fit=FALSE) ## fit using magic, with weight *matrix* mgfit <- magic(G$y,G$X,G$sp,G$S,G$off,rank=G$rank,C=G$C,w=w) ## Modify previous gam object using new fit, for plotting... mg.stuff <- magic.post.proc(G$X,mgfit,w) b$edf <- mg.stuff$edf;b$Vp <- mg.stuff$Vb b$coefficients <- mgfit$b plot(b);lines(x,f-mean(f),col=2);title("Known correlation") } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/mgcv-package.Rd0000755000176200001440000001603413425521543014610 0ustar liggesusers\name{mgcv.package} \alias{mgcv.package} \alias{mgcv-package} \alias{mgcv} \docType{package} \title{Mixed GAM Computation Vehicle with GCV/AIC/REML smoothness estimation and GAMMs by REML/PQL } \description{ \code{mgcv} provides functions for generalized additive modelling (\code{\link{gam}} and \code{\link{bam}}) and generalized additive mixed modelling (\code{\link{gamm}}, and \code{\link{random.effects}}). The term GAM is taken to include any model dependent on unknown smooth functions of predictors and estimated by quadratically penalized (possibly quasi-) likelihood maximization. Available distributions are covered in \code{\link{family.mgcv}} and available smooths in \code{\link{smooth.terms}}. Particular features of the package are facilities for automatic smoothness selection (Wood, 2004, 2011), and the provision of a variety of smooths of more than one variable. User defined smooths can be added. A Bayesian approach to confidence/credible interval calculation is provided. Linear functionals of smooths, penalization of parametric model terms and linkage of smoothing parameters are all supported. Lower level routines for generalized ridge regression and penalized linearly constrained least squares are also available. In addition to the main modelling functions, \code{\link{jagam}} provided facilities to ease the set up of models for use with JAGS, while \code{\link{ginla}} provides marginal inference via a version of Integrated Nested Laplace Approximation. } \details{ \code{mgcv} provides generalized additive modelling functions \code{\link{gam}}, \code{\link{predict.gam}} and \code{\link{plot.gam}}, which are very similar in use to the S functions of the same name designed by Trevor Hastie (with some extensions). However the underlying representation and estimation of the models is based on a penalized regression spline approach, with automatic smoothness selection. A number of other functions such as \code{\link{summary.gam}} and \code{\link{anova.gam}} are also provided, for extracting information from a fitted \code{\link{gamObject}}. Use of \code{\link{gam}} is much like use of \code{\link{glm}}, except that within a \code{gam} model formula, isotropic smooths of any number of predictors can be specified using \code{\link{s}} terms, while scale invariant smooths of any number of predictors can be specified using \code{\link{te}}, \code{\link{ti}} or \code{\link{t2}} terms. \code{\link{smooth.terms}} provides an overview of the built in smooth classes, and \code{\link{random.effects}} should be refered to for an overview of random effects terms (see also \code{\link{mrf}} for Markov random fields). Estimation is by penalized likelihood or quasi-likelihood maximization, with smoothness selection by GCV, GACV, gAIC/UBRE or (RE)ML. See \code{\link{gam}}, \code{\link{gam.models}}, \code{\link{linear.functional.terms}} and \code{\link{gam.selection}} for some discussion of model specification and selection. For detailed control of fitting see \code{\link{gam.convergence}}, \code{\link{gam}} arguments \code{method} and \code{optimizer} and \code{\link{gam.control}}. For checking and visualization see \code{\link{gam.check}}, \code{\link{choose.k}}, \code{\link{vis.gam}} and \code{\link{plot.gam}}. While a number of types of smoother are built into the package, it is also extendable with user defined smooths, see \code{\link{smooth.construct}}, for example. A Bayesian approach to smooth modelling is used to derive standard errors on predictions, and hence credible intervals (see Marra and Wood, 2012). The Bayesian covariance matrix for the model coefficients is returned in \code{Vp} of the \code{\link{gamObject}}. See \code{\link{predict.gam}} for examples of how this can be used to obtain credible regions for any quantity derived from the fitted model, either directly, or by direct simulation from the posterior distribution of the model coefficients. Approximate p-values can also be obtained for testing individual smooth terms for equality to the zero function, using similar ideas (see Wood, 2013a,b). Frequentist approximations can be used for hypothesis testing based model comparison. See \code{\link{anova.gam}} and \code{\link{summary.gam}} for more on hypothesis testing. For large datasets (that is large n) see \code{\link{bam}} which is a version of \code{\link{gam}} with a much reduced memory footprint. The package also provides a generalized additive mixed modelling function, \code{\link{gamm}}, based on a PQL approach and \code{lme} from the \code{nlme} library (for an \code{lme4} based version, see package \code{gamm4}). \code{gamm} is particularly useful for modelling correlated data (i.e. where a simple independence model for the residual variation is inappropriate). In addition, low level routine \code{\link{magic}} can fit models to data with a known correlation structure. Some underlying GAM fitting methods are available as low level fitting functions: see \code{\link{magic}}. But there is little functionality that can not be more conventiently accessed via \code{\link{gam}} . Penalized weighted least squares with linear equality and inequality constraints is provided by \code{\link{pcls}}. For a complete list of functions type \code{library(help=mgcv)}. See also \code{\link{mgcv.FAQ}}. } \author{ Simon Wood with contributions and/or help from Natalya Pya, Thomas Kneib, Kurt Hornik, Mike Lonergan, Henric Nilsson, Fabian Scheipl and Brian Ripley. Polish translation - Lukasz Daniel; German translation - Chris Leick, Detlef Steuer; French Translation - Philippe Grosjean Maintainer: Simon Wood Part funded by EPSRC: EP/K005251/1 } \references{ These provide details for the underlying mgcv methods, and fuller references to the large literature on which the methods are based. Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models (with discussion). Journal of the American Statistical Association 111, 1548-1575 \url{http://dx.doi.org/10.1080/01621459.2016.1180986} Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 Wood, S.N. (2004) Stable and efficient multiple smoothing parameter estimation for generalized additive models. J. Amer. Statist. Ass. 99:673-686. Marra, G and S.N. Wood (2012) Coverage Properties of Confidence Intervals for Generalized Additive Model Components. Scandinavian Journal of Statistics, 39(1), 53-74. Wood, S.N. (2013a) A simple test for random effects in regression models. Biometrika 100:1005-1010 Wood, S.N. (2013b) On p-values for smooth components of an extended generalized additive model. Biometrika 100:221-228 Wood, S.N. (2017) \emph{Generalized Additive Models: an introduction with R (2nd edition)}, CRC Development of mgcv version 1.8 was part funded by EPSRC grants EP/K005251/1 and EP/I000917/1. } \keyword{ package } \keyword{models} \keyword{smooth} \keyword{regression} \examples{ ## see examples for gam and gamm } mgcv/man/trind.generator.Rd0000644000176200001440000000262213073161526015363 0ustar liggesusers\name{trind.generator} \alias{trind.generator} \title{Generates index arrays for upper triangular storage} \usage{ trind.generator(K = 2) } \arguments{ \item{K}{positive integer determining the size of the array.} } \value{ A list where the entries \code{i1} to \code{i4} are arrays in up to four dimensions, containing K indexes along each dimension. } \description{ Generates index arrays for upper triangular storage up to order four. Useful when working with higher order derivatives, which generate symmetric arrays. Mainly intended for internal use. } \details{ Suppose that \code{m=1} and you fill an array using code like \code{for(i in 1:K) for(j in i:K) for(k in j:K) for(l in k:K) {a[,m] <- something; m <- m+1 }} and do this because actually the same "something" would be stored for any permutation of the indices i,j,k,l. Clearly in storage we have the restriction l>=k>=j>=i, but for access we want no restriction on the indices. \code{i4[i,j,k,l]} produces the appropriate \code{m} for unrestricted indices. \code{i3} and {i2} do the same for 3d and 2d arrays. } \examples{ library(mgcv) A <- trind.generator(3) # All permutations of c(1, 2, 3) point to the same index (5) A$i3[1, 2, 3] A$i3[2, 1, 3] A$i3[2, 3, 1] A$i3[3, 1, 2] A$i3[1, 3, 2] } \author{ Simon N. Wood . } mgcv/man/columb.Rd0000644000176200001440000000361013073161530013530 0ustar liggesusers\name{columb} \alias{columb} \alias{columb.polys} \docType{data} %- Also NEED an `\alias' for EACH other topic documented here. \title{Reduced version of Columbus OH crime data} \description{By district crime data from Columbus OH, together with polygons describing district shape. Useful for illustrating use of simple Markov Random Field smoothers. } \usage{ data(columb) data(columb.polys) } %- maybe also `usage' for other objects documented here. \format{ \code{columb} is a 49 row data frame with the following columns \describe{ \item{area}{land area of district} \item{home.value}{housing value in 1000USD.} \item{income}{household income in 1000USD.} \item{crime}{residential burglaries and auto thefts per 1000 households.} \item{open.space}{measure of open space in district.} \item{district}{code identifying district, and matching \code{names(columb.polys)}. } } \code{columb.polys} contains the polygons defining the areas in the format described below. } \details{The data frame \code{columb} relates to the districts whose boundaries are coded in \code{columb.polys}. \code{columb.polys[[i]]} is a 2 column matrix, containing the vertices of the polygons defining the boundary of the ith district. \code{columb.polys[[2]]} has an artificial hole inserted to illustrate how holes in districts can be spefified. Different polygons defining the boundary of a district are separated by NA rows in \code{columb.polys[[1]]}, and a polygon enclosed within another is treated as a hole in that region (a hole should never come first). \code{names(columb.polys)} matches \code{columb$district} (order unimportant). } \source{ The data are adapted from the \code{columbus} example in the \code{spdep} package, where the original source is given as: Anselin, Luc. 1988. Spatial econometrics: methods and models. Dordrecht: Kluwer Academic, Table 12.1 p. 189. } \examples{ ## see ?mrf help files } mgcv/man/print.gam.Rd0000755000176200001440000000325313303547337014165 0ustar liggesusers\name{print.gam} \alias{print.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Print a Generalized Additive Model object.} \description{ The default print method for a \code{gam} object. } \usage{ \method{print}{gam}(x, ...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x, ...}{ fitted model objects of class \code{gam} as produced by \code{gam()}.} } \details{ Prints out the family, model formula, effective degrees of freedom for each smooth term, and optimized value of the smoothness selection criterion used. See \code{\link{gamObject}} (or \code{names(x)}) for a listing of what the object contains. \code{\link{summary.gam}} provides more detail. Note that the optimized smoothing parameter selection criterion reported is one of GCV, UBRE(AIC), GACV, negative log marginal likelihood (ML), or negative log restricted likelihood (REML). If rank deficiency of the model was detected then the apparent rank is reported, along with the length of the cofficient vector (rank in absense of rank deficieny). Rank deficiency occurs when not all coefficients are identifiable given the data. Although the fitting routines (except \code{gamm}) deal gracefully with rank deficiency, interpretation of rank deficient models may be difficult. } \references{ Wood, S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). CRC/ Chapmand and Hall, Boca Raton, Florida. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \seealso{ \code{\link{gam}}, \code{\link{summary.gam}}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/anova.gam.Rd0000755000176200001440000001455613552062255014142 0ustar liggesusers\name{anova.gam} \alias{anova.gam} \alias{print.anova.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Approximate hypothesis tests related to GAM fits} \description{ Performs hypothesis tests relating to one or more fitted \code{gam} objects. For a single fitted \code{gam} object, Wald tests of the significance of each parametric and smooth term are performed, so interpretation is analogous to \code{\link{drop1}} rather than \code{anova.lm} (i.e. it's like type III ANOVA, rather than a sequential type I ANOVA). Otherwise the fitted models are compared using an analysis of deviance table or GLRT test: this latter approach should not be use to test the significance of terms which can be penalized to zero. Models to be compared should be fitted to the same data using the same smoothing parameter selection method. } \usage{ \method{anova}{gam}(object, ..., dispersion = NULL, test = NULL, freq = FALSE) \method{print}{anova.gam}(x, digits = max(3, getOption("digits") - 3),...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object,...}{ fitted model objects of class \code{gam} as produced by \code{gam()}.} \item{x}{an \code{anova.gam} object produced by a single model call to \code{anova.gam()}.} \item{dispersion}{ a value for the dispersion parameter: not normally used.} \item{test}{what sort of test to perform for a multi-model call. One of \code{"Chisq"}, \code{"F"} or \code{"Cp"}. Reset to \code{"Chisq"} for extended and general families unless \code{NULL}. } \item{freq}{whether to use frequentist or Bayesian approximations for parametric term p-values. See \code{\link{summary.gam}} for details.} \item{digits}{number of digits to use when printing output.} } \details{ If more than one fitted model is provided than \code{anova.glm} is used, with the difference in model degrees of freedom being taken as the difference in effective degress of freedom (when possible this is a smoothing parameter uncertainty corrected version). For extended and general families this is set so that a GLRT test is used. The p-values resulting from the multi-model case are only approximate, and must be used with care. The approximation is most accurate when the comparison relates to unpenalized terms, or smoothers with a null space of dimension greater than zero. (Basically we require that the difference terms could be well approximated by unpenalized terms with degrees of freedom approximately the effective degrees of freedom). In simulations the p-values are usually slightly too low. For terms with a zero-dimensional null space (i.e. those which can be penalized to zero) the approximation is often very poor, and significance can be greatly overstated: i.e. p-values are often substantially too low. This case applies to random effect terms. Note also that in the multi-model call to \code{anova.gam}, it is quite possible for a model with more terms to end up with lower effective degrees of freedom, but better fit, than the notionally null model with fewer terms. In such cases it is very rare that it makes sense to perform any sort of test, since there is then no basis on which to accept the notional null model. If only one model is provided then the significance of each model term is assessed using Wald like tests, conditional on the smoothing parameter estimates: see \code{\link{summary.gam}} and Wood (2013a,b) for details. The p-values provided here are better justified than in the multi model case, and have close to the correct distribution under the null, unless smoothing parameters are poorly identified. ML or REML smoothing parameter selection leads to the best results in simulations as they tend to avoid occasional severe undersmoothing. In replication of the full simulation study of Scheipl et al. (2008) the tests give almost indistinguishable power to the method recommended there, but slightly too low p-values under the null in their section 3.1.8 test for a smooth interaction (the Scheipl et al. recommendation is not used directly, because it only applies in the Gaussian case, and requires model refits, but it is available in package \code{RLRsim}). In the single model case \code{print.anova.gam} is used as the printing method. By default the p-values for parametric model terms are also based on Wald tests using the Bayesian covariance matrix for the coefficients. This is appropriate when there are "re" terms present, and is otherwise rather similar to the results using the frequentist covariance matrix (\code{freq=TRUE}), since the parametric terms themselves are usually unpenalized. Default P-values for parameteric terms that are penalized using the \code{paraPen} argument will not be good. } \value{In the multi-model case \code{anova.gam} produces output identical to \code{\link{anova.glm}}, which it in fact uses. In the single model case an object of class \code{anova.gam} is produced, which is in fact an object returned from \code{\link{summary.gam}}. \code{print.anova.gam} simply produces tabulated output. } \references{ Scheipl, F., Greven, S. and Kuchenhoff, H. (2008) Size and power of tests for a zero random effect variance or polynomial regression in additive and linear mixed models. Comp. Statist. Data Anal. 52, 3283-3299 Wood, S.N. (2013a) On p-values for smooth components of an extended generalized additive model. Biometrika 100:221-228 Wood, S.N. (2013b) A simple test for random effects in regression models. Biometrika 100:1005-1010 } \author{ Simon N. Wood \email{simon.wood@r-project.org} with substantial improvements by Henric Nilsson.} \section{WARNING}{ If models 'a' and 'b' differ only in terms with no un-penalized components (such as random effects) then p values from anova(a,b) are unreliable, and usually much too low. Default P-values will usually be wrong for parametric terms penalized using `paraPen': use freq=TRUE to obtain better p-values when the penalties are full rank and represent conventional random effects. For a single model, interpretation is similar to drop1, not anova.lm. } \seealso{ \code{\link{gam}}, \code{\link{predict.gam}}, \code{\link{gam.check}}, \code{\link{summary.gam}} } \examples{ library(mgcv) set.seed(0) dat <- gamSim(5,n=200,scale=2) b<-gam(y ~ x0 + s(x1) + s(x2) + s(x3),data=dat) anova(b) b1<-gam(y ~ x0 + s(x1) + s(x2),data=dat) anova(b,b1,test="F") } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/ldTweedie.Rd0000755000176200001440000001123013073161526014162 0ustar liggesusers\name{ldTweedie} \alias{ldTweedie} %- Also NEED an `\alias' for EACH other topic documented here. \title{Log Tweedie density evaluation} \description{A function to evaluate the log of the Tweedie density for variance powers between 1 and 2, inclusive. Also evaluates first and second derivatives of log density w.r.t. its scale parameter, \code{phi}, and \code{p}, or w.r.t. \code{rho=log(phi)} and \code{theta} where \code{p = (a+b*exp(theta))/(1+exp(theta))}. } \usage{ ldTweedie(y,mu=y,p=1.5,phi=1,rho=NA,theta=NA,a=1.001,b=1.999,all.derivs=FALSE) } \arguments{ \item{y}{values at which to evaluate density.} \item{mu}{corresponding means (either of same length as \code{y} or a single value).} \item{p}{the variance of \code{y} is proportional to its mean to the power \code{p}. \code{p} must be between 1 and 2. 1 is Poisson like (exactly Poisson if \code{phi=1}), 2 is gamma. } \item{phi}{The scale parameter. Variance of \code{y} is \code{phi*mu^p}.} \item{rho}{optional log scale parameter. Over-rides \code{phi} if \code{theta} also supplied.} \item{theta}{parameter such that \code{p = (a+b*exp(theta))/(1+exp(theta))}. Over-rides \code{p} if \code{rho} also supplied.} \item{a}{lower limit parameter (>1) used in definition of \code{p} from \code{theta}.} \item{b}{upper limit parameter (<2) used in definition of \code{p} from \code{theta}.} \item{all.derivs}{if \code{TRUE} then derivatives w.r.t. \code{mu} are also returned. Only available with \code{rho} and \code{phi} parameterization.} } \value{ A matrix with 6 columns, or 10 if \code{all.derivs=TRUE}. The first is the log density of \code{y} (log probability if \code{p=1}). The second and third are the first and second derivatives of the log density w.r.t. \code{phi}. 4th and 5th columns are first and second derivative w.r.t. \code{p}, final column is second derivative w.r.t. \code{phi} and \code{p}. If \code{rho} and \code{theta} were supplied then derivatives are w.r.t. these. In this case, and if \code{all.derivs=TRUE} then the 7th colmn is the derivative w.r.t. \code{mu}, the 8th is the 2nd derivative w.r.t. \code{mu}, the 9th is the mixed derivative w.r.t. \code{theta} and\code{mu} and the 10th is the mixed derivative w.r.t. \code{rho} and \code{mu}. } \details{ A Tweedie random variable with 11.1 is OK y <- seq(1e-10,10,length=1000) p <- c(1.0001,1.001,1.01,1.1,1.2,1.5,1.8,2) phi <- .5 fy <- exp(ldTweedie(y,mu=2,p=p[1],phi=phi)[,1]) plot(y,fy,type="l",ylim=c(0,3),main="Tweedie density as p changes") for (i in 2:length(p)) { fy <- exp(ldTweedie(y,mu=2,p=p[i],phi=phi)[,1]) lines(y,fy,col=i) } } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/negbin.Rd0000755000176200001440000001247013303547337013531 0ustar liggesusers\name{negbin} \alias{negbin} \alias{nb} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM negative binomial families} \description{The \code{gam} modelling function is designed to be able to use the \code{\link{negbin}} family (a modification of MASS library \code{negative.binomial} family by Venables and Ripley), or the \code{\link{nb}} function designed for integrated estimation of parameter \code{theta}. \eqn{\theta} is the parameter such that \eqn{var(y) = \mu + \mu^2/\theta}, where \eqn{\mu = E(y)}. Two approaches to estimating \code{theta} are available (with \code{\link{gam}} only): \itemize{ \item With \code{negbin} then if `performance iteration' is used for smoothing parameter estimation (see \code{\link{gam}}), then smoothing parameters are chosen by GCV and \code{theta} is chosen in order to ensure that the Pearson estimate of the scale parameter is as close as possible to 1, the value that the scale parameter should have. \item If `outer iteration' is used for smoothing parameter selection with the \code{nb} family then \code{theta} is estimated alongside the smoothing parameters by ML or REML. } To use the first option, set the \code{optimizer} argument of \code{\link{gam}} to \code{"perf"} (it can sometimes fail to converge). } \usage{ negbin(theta = stop("'theta' must be specified"), link = "log") nb(theta = NULL, link = "log") } \arguments{ \item{theta}{Either i) a single value known value of theta or ii) two values of theta specifying the endpoints of an interval over which to search for theta (this is an option only for \code{negbin}, and is deprecated). For \code{nb} then a positive supplied \code{theta} is treated as a fixed known parameter, otherwise it is estimated (the absolute value of a negative \code{theta} is taken as a starting value).} \item{link}{The link function: one of \code{"log"}, \code{"identity"} or \code{"sqrt"}} } \value{ For \code{negbin} an object inheriting from class \code{family}, with additional elements \item{dvar}{the function giving the first derivative of the variance function w.r.t. \code{mu}.} \item{d2var}{the function giving the second derivative of the variance function w.r.t. \code{mu}.} \item{getTheta}{A function for retrieving the value(s) of theta. This also useful for retriving the estimate of \code{theta} after fitting (see example).} For \code{nb} an object inheriting from class \code{extended.family}. } \details{\code{nb} allows estimation of the \code{theta} parameter alongside the model smoothing parameters, but is only usable with \code{\link{gam}} or \code{\link{bam}} (not \code{gamm}). For \code{negbin}, if a single value of \code{theta} is supplied then it is always taken as the known fixed value and this is useable with \code{\link{bam}} and \code{\link{gamm}}. If \code{theta} is two numbers (\code{theta[2]>theta[1]}) then they are taken as specifying the range of values over which to search for the optimal theta. This option is deprecated and should only be used with performance iteration estimation (see \code{\link{gam}} argument \code{optimizer}), in which case the method of estimation is to choose \eqn{\hat \theta}{theta} so that the GCV (Pearson) estimate of the scale parameter is one (since the scale parameter is one for the negative binomial). In this case \eqn{\theta}{theta} estimation is nested within the IRLS loop used for GAM fitting. After each call to fit an iteratively weighted additive model to the IRLS pseudodata, the \eqn{\theta}{theta} estimate is updated. This is done by conditioning on all components of the current GCV/Pearson estimator of the scale parameter except \eqn{\theta}{theta} and then searching for the \eqn{\hat \theta}{theta} which equates this conditional estimator to one. The search is a simple bisection search after an initial crude line search to bracket one. The search will terminate at the upper boundary of the search region is a Poisson fit would have yielded an estimated scale parameter <1. } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood \email{simon.wood@r-project.org} modified from Venables and Ripley's \code{negative.binomial} family. } \references{ Venables, B. and B.R. Ripley (2002) Modern Applied Statistics in S, Springer. Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association 111, 1548-1575 \url{http://dx.doi.org/10.1080/01621459.2016.1180986} } \section{WARNINGS}{ \code{\link{gamm}} does not support \code{theta} estimation The negative binomial functions from the MASS library are no longer supported. } \examples{ library(mgcv) set.seed(3) n<-400 dat <- gamSim(1,n=n) g <- exp(dat$f/5) ## negative binomial data... dat$y <- rnbinom(g,size=3,mu=g) ## known theta fit ... b0 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=negbin(3),data=dat) plot(b0,pages=1) print(b0) ## same with theta estimation... b <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=nb(),data=dat) plot(b,pages=1) print(b) b$family$getTheta(TRUE) ## extract final theta estimate ## another example... set.seed(1) f <- dat$f f <- f - min(f)+5;g <- f^2/10 dat$y <- rnbinom(g,size=3,mu=g) b2 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=nb(link="sqrt"), data=dat,method="REML") plot(b2,pages=1) print(b2) rm(dat) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/mroot.Rd0000755000176200001440000000341313073161530013413 0ustar liggesusers\name{mroot} \alias{mroot} %- Also NEED an `\alias' for EACH other topic documented here. \title{Smallest square root of matrix} \description{ Find a square root of a positive semi-definite matrix, having as few columns as possible. Uses either pivoted choleski decomposition or singular value decomposition to do this. } \usage{ mroot(A,rank=NULL,method="chol") } %- maybe also `usage' for other objects documented here. \arguments{ \item{A}{ The positive semi-definite matrix, a square root of which is to be found.} \item{rank}{if the rank of the matrix \code{A} is known then it should be supplied. \code{NULL} or <1 imply that it should be estimated.} \item{method}{ \code{"chol"} to use pivoted choloeski decompositon, which is fast but tends to over-estimate rank. \code{"svd"} to use singular value decomposition, which is slow, but is the most accurate way to estimate rank.} } \details{ The function uses SVD, or a pivoted Choleski routine. It is primarily of use for turning penalized regression problems into ordinary regression problems.} \value{ A matrix, \eqn{ {\bf B}}{B} with as many columns as the rank of \eqn{ {\bf A}}{A}, and such that \eqn{ {\bf A} = {\bf BB}^\prime}{A=BB'}.} \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ require(mgcv) set.seed(0) a <- matrix(runif(24),6,4) A <- a\%*\%t(a) ## A is +ve semi-definite, rank 4 B <- mroot(A) ## default pivoted choleski method tol <- 100*.Machine$double.eps chol.err <- max(abs(A-B\%*\%t(B)));chol.err if (chol.err>tol) warning("mroot (chol) suspect") B <- mroot(A,method="svd") ## svd method svd.err <- max(abs(A-B\%*\%t(B)));svd.err if (svd.err>tol) warning("mroot (svd) suspect") } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/blas.thread.test.Rd0000755000176200001440000000337213502243040015416 0ustar liggesusers\name{blas.thread.test} \alias{blas.thread.test} %- Also NEED an `\alias' for EACH other topic documented here. \title{BLAS thread safety} \description{Most BLAS implementations are thread safe, but some verions of OpenBLAS, for example are not. This routne is a diagnostic helper function, which you will never need if you don't set \code{nthreads>1}, and even then are unlikely to need. } \usage{ blas.thread.test(n=1000,nt=4) } %- maybe also `usage' for other objects documented here. \arguments{ \item{n}{Number of iterations to run of parallel BLAS calling code.} \item{nt}{Number of parallel threads to use} } \details{While single threaded OpenBLAS 0.2.20 was thread safe, versions 0.3.0-0.3.6 are not, and from version 0.3.7 thread safety of the single threaded OpenBLAS requires making it with the option \code{USE_LOCKING=1}. The reference BLAS is thread safe, as are MKL and ATLAS. This routine repeatedly calls the BLAS from multi-threaded code and is sufficient to detect the problem in single threaded OpenBLAS 0.3.x. A multi-threaded BLAS is often no faster than a single-threaded BLAS, while judicious use of threading in the code calling the BLAS can still deliver a modest speed improvement. For this reason it is often better to use a single threaded BLAS and the code{nthreads} options to \code{\link{bam}} or \code{\link{gam}}. For \code{bam(...,discrete=TRUE)} using several threads can be a substantial benefit, especially with the reference BLAS. The MKL BLAS is mutlithreaded by default. Under linux seting evironment variable \code{MKL_NUM_THREADS=1} before starting R gives single threaded operation. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/dDeta.Rd0000644000176200001440000000172013137076654013305 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mgcvExports.R \name{dDeta} \alias{dDeta} \title{Obtaining derivative w.r.t. linear predictor} \usage{ dDeta(y, mu, wt, theta, fam, deriv = 0) } \arguments{ \item{y}{vector of observations.} \item{mu}{if \code{eta} is the linear predictor, \code{mu = inv_link(eta)}. In a traditional GAM \code{mu=E(y)}.} \item{wt}{vector of weights.} \item{theta}{vector of family parameters that are not regression coefficients (e.g. scale parameters).} \item{fam}{the family object.} \item{deriv}{the order of derivative of the smoothing parameter score required.} } \value{ A list of derivatives. } \description{ INTERNAL function. Distribution families provide derivatives of the deviance and link w.r.t. \code{mu = inv_link(eta)}. This routine converts these to the required derivatives of the deviance w.r.t. eta, the linear predictor. } \author{ Simon N. Wood . } mgcv/man/Beta.Rd0000755000176200001440000000535313303547351013140 0ustar liggesusers\name{betar} \alias{betar} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM beta regression family} \description{Family for use with \code{\link{gam}} or \code{\link{bam}}, implementing regression for beta distributed data on (0,1). A linear predictor controls the mean, \eqn{\mu}{mu} of the beta distribution, while the variance is then \eqn{\mu(1-\mu)/(1+\phi)}{mu(1-mu)/(1+phi)}, with parameter \eqn{\phi}{phi} being estimated during fitting, alongside the smoothing parameters. } \usage{ betar(theta = NULL, link = "logit",eps=.Machine$double.eps*100) } \arguments{ \item{theta}{the extra parameter (\eqn{\phi}{phi} above). } \item{link}{The link function: one of \code{"logit"}, \code{"probit"}, \code{"cloglog"} and \code{"cauchit"}.} \item{eps}{the response variable will be truncated to the interval \code{[eps,1-eps]} if there are values outside this range. This truncation is not entirely benign, but too small a value of \code{eps} will cause stability problems if there are zeroes or ones in the response.} } \value{ An object of class \code{extended.family}. } \details{These models are useful for proportions data which can not be modelled as binomial. Note the assumption that data are in (0,1), despite the fact that for some parameter values 0 and 1 are perfectly legitimate observations. The restriction is needed to keep the log likelihood bounded for all parameter values. Any data exactly at 0 or 1 are reset to be just above 0 or just below 1 using the \code{eps} argument (in fact any observation \code{1-eps} is reset to \code{1-eps}). Note the effect of this resetting. If \eqn{\mu\phi>1}{mu*phi>1} then impossible 0s are replaced with highly improbable \code{eps} values. If the inequality is reversed then 0s with infinite probability density are replaced with \code{eps} values having high finite probability density. The equivalent condition for 1s is \eqn{(1-\mu)\phi>1}{(1-mu)*phi>1}. Clearly all types of resetting are somewhat unsatisfactory, and care is needed if data contain 0s or 1s (often it makes sense to manually reset the 0s and 1s in a manner that somehow reflects the sampling setup). } %- maybe also `usage' for other objects documented here. \author{ Natalya Pya (nat.pya@gmail.com) and Simon Wood (s.wood@r-project.org) } \section{WARNINGS}{ Do read the details section if your data contain 0s and or 1s. } \examples{ library(mgcv) ## Simulate some beta data... set.seed(3);n<-400 dat <- gamSim(1,n=n) mu <- binomial()$linkinv(dat$f/4-2) phi <- .5 a <- mu*phi;b <- phi - a; dat$y <- rbeta(n,a,b) bm <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=betar(link="logit"),data=dat) bm plot(bm,pages=1) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/Tweedie.Rd0000755000176200001440000001202313303547351013643 0ustar liggesusers\name{Tweedie} \alias{Tweedie} \alias{tw} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM Tweedie families} \description{Tweedie families, designed for use with \code{\link{gam}} from the \code{mgcv} library. Restricted to variance function powers between 1 and 2. A useful alternative to \code{\link{quasi}} when a full likelihood is desirable. \code{Tweedie} is for use with fixed \code{p}. \code{tw} is for use when \code{p} is to be estimated during fitting. For fixed \code{p} between 1 and 2 the Tweedie is an exponential family distribution with variance given by the mean to the power \code{p}. \code{tw} is only useable with \code{\link{gam}} and \code{\link{bam}} but not \code{gamm}. \code{Tweedie} works with all three. } \usage{ Tweedie(p=1, link = power(0)) tw(theta = NULL, link = "log",a=1.01,b=1.99) } \arguments{ \item{p}{the variance of an observation is proportional to its mean to the power \code{p}. \code{p} must be greater than 1 and less than or equal to 2. 1 would be Poisson, 2 is gamma. } \item{link}{The link function: one of \code{"log"}, \code{"identity"}, \code{"inverse"}, \code{"sqrt"}, or a \code{\link{power}} link (\code{Tweedie} only).} \item{theta}{Related to the Tweedie power parameter by \eqn{p=\exp(a+b \exp(\theta))/(1+\exp(\theta))}{p=exp(a+b*exp(theta))/(1+exp(theta))}. If this is supplied as a positive value then it is taken as the fixed value for \code{p}. If it is a negative values then its absolute value is taken as the initial value for \code{p}.} \item{a}{lower limit on \code{p} for optimization.} \item{b}{upper limit on \code{p} for optimization.} } \value{ For \code{Tweedie}, an object inheriting from class \code{family}, with additional elements \item{dvar}{the function giving the first derivative of the variance function w.r.t. \code{mu}.} \item{d2var}{the function giving the second derivative of the variance function w.r.t. \code{mu}.} \item{ls}{A function returning a 3 element array: the saturated log likelihood followed by its first 2 derivatives w.r.t. the scale parameter.} For \code{tw}, an object of class \code{extended.family}. } \details{ A Tweedie random variable with 1 } \references{ \url{https://computing.llnl.gov/tutorials/openMP/} } \keyword{ package } \keyword{models} \keyword{smooth} \keyword{regression} \examples{ ## illustration of multi-threading with gam... require(mgcv);set.seed(9) dat <- gamSim(1,n=2000,dist="poisson",scale=.1) k <- 12;bs <- "cr";ctrl <- list(nthreads=2) system.time(b1<-gam(y~s(x0,bs=bs)+s(x1,bs=bs)+s(x2,bs=bs,k=k) ,family=poisson,data=dat,method="REML"))[3] system.time(b2<-gam(y~s(x0,bs=bs)+s(x1,bs=bs)+s(x2,bs=bs,k=k), family=poisson,data=dat,method="REML",control=ctrl))[3] ## Poisson example on a cluster with 'bam'. ## Note that there is some overhead in initializing the ## computation on the cluster, associated with loading ## the Matrix package on each node. Sample sizes are low ## here to keep example quick -- for such a small model ## little or no advantage is likely to be seen. k <- 13;set.seed(9) dat <- gamSim(1,n=6000,dist="poisson",scale=.1) \donttest{ require(parallel) nc <- 2 ## cluster size, set for example portability if (detectCores()>1) { ## no point otherwise cl <- makeCluster(nc) ## could also use makeForkCluster, but read warnings first! } else cl <- NULL system.time(b3 <- bam(y ~ s(x0,bs=bs,k=7)+s(x1,bs=bs,k=7)+s(x2,bs=bs,k=k) ,data=dat,family=poisson(),chunk.size=5000,cluster=cl)) fv <- predict(b3,cluster=cl) ## parallel prediction if (!is.null(cl)) stopCluster(cl) b3 } ## Alternative, better scaling example, using the discrete option with bam... system.time(b4 <- bam(y ~ s(x0,bs=bs,k=7)+s(x1,bs=bs,k=7)+s(x2,bs=bs,k=k) ,data=dat,family=poisson(),discrete=TRUE,nthreads=2)) } mgcv/man/missing.data.Rd0000755000176200001440000000651613536132043014644 0ustar liggesusers\name{missing.data} \alias{missing.data} \title{Missing data in GAMs} \description{If there are missing values in the response or covariates of a GAM then the default is simply to use only the `complete cases'. If there are many missing covariates, this can get rather wasteful. One possibility is then to use imputation. Another is to substitute a simple random effects model in which the \code{by} variable mechanism is used to set \code{s(x)} to zero for any missing \code{x}, while a Gaussian random effect is then substituted for the `missing' s(x). See the example for details of how this works, and \code{\link{gam.models}} for the necessary background on \code{by} variables. } \seealso{\code{\link{gam.vcomp}}, \code{\link{gam.models}}, \code{\link{s}}, \code{\link{smooth.construct.re.smooth.spec}},\code{\link{gam}}} \author{ Simon Wood } \examples{ ## The example takes a couple of minutes to run... \donttest{ require(mgcv) par(mfrow=c(4,4),mar=c(4,4,1,1)) for (sim in c(1,7)) { ## cycle over uncorrelated and correlated covariates n <- 350;set.seed(2) ## simulate data but randomly drop 300 covariate measurements ## leaving only 50 complete cases... dat <- gamSim(sim,n=n,scale=3) ## 1 or 7 drop <- sample(1:n,300) ## to for (i in 2:5) dat[drop[1:75+(i-2)*75],i] <- NA ## process data.frame producing binary indicators of missingness, ## mx0, mx1 etc. For each missing value create a level of a factor ## idx0, idx1, etc. So idx0 has as many levels as x0 has missing ## values. Replace the NA's in each variable by the mean of the ## non missing for that variable... dname <- names(dat)[2:5] dat1 <- dat for (i in 1:4) { by.name <- paste("m",dname[i],sep="") dat1[[by.name]] <- is.na(dat1[[dname[i]]]) dat1[[dname[i]]][dat1[[by.name]]] <- mean(dat1[[dname[i]]],na.rm=TRUE) lev <- rep(1,n);lev[dat1[[by.name]]] <- 1:sum(dat1[[by.name]]) id.name <- paste("id",dname[i],sep="") dat1[[id.name]] <- factor(lev) dat1[[by.name]] <- as.numeric(dat1[[by.name]]) } ## Fit a gam, in which any missing value contributes zero ## to the linear predictor from its smooth, but each ## missing has its own random effect, with the random effect ## variances being specific to the variable. e.g. ## for s(x0,by=ordered(!mx0)), declaring the `by' as an ordered ## factor ensures that the smooth is centred, but multiplied ## by zero when mx0 is one (indicating a missing x0). This means ## that any value (within range) can be put in place of the ## NA for x0. s(idx0,bs="re",by=mx0) produces a separate Gaussian ## random effect for each missing value of x0 (in place of s(x0), ## effectively). The `by' variable simply sets the random effect to ## zero when x0 is non-missing, so that we can set idx0 to any ## existing level for these cases. b <- gam(y~s(x0,by=ordered(!mx0))+s(x1,by=ordered(!mx1))+ s(x2,by=ordered(!mx2))+s(x3,by=ordered(!mx3))+ s(idx0,bs="re",by=mx0)+s(idx1,bs="re",by=mx1)+ s(idx2,bs="re",by=mx2)+s(idx3,bs="re",by=mx3) ,data=dat1,method="REML") for (i in 1:4) plot(b,select=i) ## plot the smooth effects from b ## fit the model to the `complete case' data... b2 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat,method="REML") plot(b2) ## plot the complete case results } } } \keyword{regression}mgcv/man/mgcv-FAQ.Rd0000755000176200001440000001667013303547337013636 0ustar liggesusers\name{mgcv.FAQ} \alias{mgcv.FAQ} %- Also NEED an `\alias' for EACH other topic documented here. \title{Frequently Asked Questions for package mgcv} \description{ This page provides answers to some of the questions that get asked most often about mgcv} \section{FAQ list}{ \enumerate{ \item \bold{How can I compare gamm models?} In the identity link normal errors case, then AIC and hypotheis testing based methods are fine. Otherwise it is best to work out a strategy based on the \code{\link{summary.gam}} Alternatively, simple random effects can be fitted with \code{\link{gam}}, which makes comparison straightforward. Package \code{gamm4} is an alternative, which allows AIC type model selection for generalized models. \item \bold{How do I get the equation of an estimated smooth?} This slightly misses the point of semi-parametric modelling: the idea is that we estimate the form of the function from data without assuming that it has a particular simple functional form. Of course for practical computation the functions do have underlying mathematical representations, but they are not very helpful, when written down. If you do need the functional forms then see chapter 5 of Wood (2017). However for most purposes it is better to use \code{\link{predict.gam}} to evaluate the function for whatever argument values you need. If derivatives are required then the simplest approach is to use finite differencing (which also allows SEs etc to be calculated). \item \bold{Some of my smooths are estimated to be straight lines and their confidence intervals vanish at some point in the middle. What is wrong?} Nothing. Smooths are subject to sum-to-zero identifiability constraints. If a smooth is estimated to be a straight line then it consequently has one degree of freedom, and there is no choice about where it passes through zero --- so the CI must vanish at that point. \item \bold{How do I test whether a smooth is significantly different from a straight line}. See \code{\link{tprs}} and the example therein. \item \bold{An example from an mgcv helpfile gives an error - is this a bug?} It might be, but first please check that the version of mgcv you have loaded into R corresponds to the version from which the helpfile came. Many such problems are caused by trying to run code only supported in a later mgcv version in an earlier version. Another possibility is that you have an object loaded whose name clashes with an mgcv function (for example you are trying to use the mgcv \code{multinom} function, but have another object called \code{multinom} loaded.) \item \bold{Some code from Wood (2006) causes an error: why?} The book was written using mgcv version 1.3. To allow for REML estimation of smoothing parameters in versions 1.5, some changes had to be made to the syntax. In particular the function \code{gam.method} no longer exists. The smoothness selection method (GCV, REML etc) is now controlled by the \code{method} argument to \code{gam} while the optimizer is selected using the \code{optimizer} argument. See \code{\link{gam}} and \url{http://www.maths.bris.ac.uk/~sw15190/igam/index.html} for details. \item \bold{Why is a model object saved under a previous mgcv version not usable with the current mgcv version?} I'm sorry about this issue, I know it's really annoying. Here's my defence. Each mgcv version is run through an extensive test suite before release, to ensure that it gives the same results as before, unless there are good statistical reasons why not (e.g. improvements to p-value approximation, fixing of an error). However it is sometimes necessary to modify the internal structure of model objects in a way that makes an old style object unusable with a newer version. For example, bug fixes or new R features sometimes require changes in the way that things are computed which in turn require modification of the object structure. Similarly improvements, such as the ability to compute smoothing parameters by RE/ML require object level changes. The only fix to this problem is to access the old object using the original mgcv version (available on CRAN), or to recompute the fit using the current mgcv version. \item \bold{When using \code{gamm} or \code{gamm4}, the reported AIC is different for the \code{gam} object and the \code{lme} or \code{lmer} object. Why is this?} There are several reasons for this. The most important is that the models being used are actually different in the two representations. When treating the GAM as a mixed model, you are implicitly assuming that if you gathered a replicate dataset, the smooths in your model would look completely different to the smooths from the original model, except for having the same degree of smoothness. Technically you would expect the smooths to be drawn afresh from their distribution under the random effects model. When viewing the gam from the usual penalized regression perspective, you would expect smooths to look broadly similar under replication of the data. i.e. you are really using Bayesian model for the smooths, rather than a random effects model (it's just that the frequentist random effects and Bayesian computations happen to coincide for computing the estimates). As a result of the different assumptions about the data generating process, AIC model comparisons can give rather different answers depending on the model adopted. Which you use should depend on which model you really think is appropriate. In addition the computations of the AICs are different. The mixed model AIC uses the marginal liklihood and the corresponding number of model parameters. The gam model uses the penalized likelihood and the effective degrees of freedom. \item \bold{What does 'mgcv' stand for?} '\bold{M}ixed \bold{G}AM \bold{C}omputation \bold{V}ehicle', is my current best effort (let me know if you can do better). Originally it stood for `Multiple GCV', which has long since ceased to be usefully descriptive, (and I can't really change 'mgcv' now without causing disruption). On a bad inbox day '\bold{M}ad \bold{G}AM \bold{C}omputing \bold{V}ulture'. \item \bold{My new method is failing to beat mgcv, what can I do?} If speed is the problem, then make sure that you use the slowest basis possible (\code{"tp"}) with a large sample size, and experiment with different optimizers to find one that is slow for your problem. For prediction error/MSE, then leaving the smoothing basis dimensions at their arbitrary defaults, when these are inappropriate for the problem setting, is a good way of reducing performance. Similarly, using p-splines in place of derivative penalty based splines will often shave a little more from the performance here. Unlike REML/ML, prediction error based smoothness selection criteria such as Mallows Cp and GCV often produce a small proportion of severe overfits, so careful choise of smoothness selection method can help further. In particular GCV etc. usually result in worse confidence interval and p-value performance than ML or REML. If all this fails, try using a really odd simulation setup for which mgcv is clearly not suited: for example poor performance is almost guaranteed for small noisy datasets with large numbers of predictors. } } \references{ Wood S.N. (2006) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. Wood S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.t2.smooth.spec.Rd0000755000176200001440000000433213073161526020402 0ustar liggesusers\name{smooth.construct.t2.smooth.spec} \alias{smooth.construct.t2.smooth.spec} %- Also NEED an `\alias' for EACH other topic documented here. \title{Tensor product smoothing constructor} \description{A special \code{smooth.construct} method function for creating tensor product smooths from any combination of single penalty marginal smooths, using the construction of Wood, Scheipl and Faraway (2013). } \usage{ \method{smooth.construct}{t2.smooth.spec}(object, data, knots) } \arguments{ \item{object}{a smooth specification object of class \code{t2.smooth.spec}, usually generated by a term like \code{t2(x,z)} in a \code{\link{gam}} model formula} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}. See details for further information.} } \value{ An object of class \code{"t2.smooth"}. } \details{Tensor product smooths are smooths of several variables which allow the degree of smoothing to be different with respect to different variables. They are useful as smooth interaction terms, as they are invariant to linear rescaling of the covariates, which means, for example, that they are insensitive to the measurement units of the different covariates. They are also useful whenever isotropic smoothing is inappropriate. See \code{\link{t2}}, \code{\link{te}}, \code{\link{smooth.construct}} and \code{\link{smooth.terms}}. The construction employed here produces tensor smooths for which the smoothing penalties are non-overlapping portions of the identity matrix. This makes their estimation by mixed modelling software rather easy. } \references{ Wood, S.N., F. Scheipl and J.J. Faraway (2013) Straightforward intermediate rank tensor product smoothing in mixed models. Statistics and Computing 23: 341-360. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{t2}}} \examples{ ## see ?t2 } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/Sl.initial.repara.Rd0000644000176200001440000000260213445223717015537 0ustar liggesusers\name{Sl.inirep} \alias{Sl.inirep} \alias{Sl.initial.repara} \title{Re-parametrizing model matrix X} \usage{ Sl.inirep(Sl,X,l,r,nt=1) Sl.initial.repara(Sl, X, inverse = FALSE, both.sides = TRUE, cov = TRUE, nt = 1) } \arguments{ \item{Sl}{the output of \code{Sl.setup}.} \item{X}{the model matrix.} \item{l}{if non-zero apply transform (positive) or inverse transform from left. 1 or -1 of transform, 2 or -2 for transpose.} \item{r}{if non-zero apply transform (positive) or inverse transform from right. 1 or -1 of transform, 2 or -2 for transpose.} \item{inverse}{if \code{TRUE} an inverse re-parametrization is performed.} \item{both.sides}{if \code{inverse==TRUE} and \code{both.sides==FALSE} then the re-parametrization only applied to rhs, as appropriate for a choleski factor. If \code{both.sides==FALSE}, \code{X} is a vector and \code{inverse==FALSE} then \code{X} is taken as a coefficient vector (so re-parametrization is inverse of that for the model matrix).} \item{cov}{boolean indicating whether \code{X} is a covariance matrix.} \item{nt}{number of parallel threads to be used.} } \value{ A re-parametrized version of \code{X}. } \description{ INTERNAL routine to apply initial Sl re-parameterization to model matrix X, or, if \code{inverse==TRUE}, to apply inverse re-parametrization to parameter vector or covariance matrix. } \author{ Simon N. Wood . } mgcv/man/smooth.construct.fs.smooth.spec.Rd0000755000176200001440000001220013347173522020461 0ustar liggesusers\name{smooth.construct.fs.smooth.spec} \alias{smooth.construct.fs.smooth.spec} \alias{Predict.matrix.fs.interaction} \alias{factor.smooth.interaction} %- Also NEED an `\alias' for EACH other topic documented here. \title{Factor smooth interactions in GAMs} \description{Simple factor smooth interactions, which are efficient when used with \code{\link{gamm}}. This smooth class allows a separate smooth for each level of a factor, with the same smoothing parameter for all smooths. It is an alternative to using factor \code{by} variables. See the discussion of \code{by} variables in \code{\link{gam.models}} for more general alternatives for factor smooth interactions (including interactions of tensor product smooths with factors). } \usage{ \method{smooth.construct}{fs.smooth.spec}(object, data, knots) \method{Predict.matrix}{fs.interaction}(object, data) } \arguments{ \item{object}{For the \code{smooth.construct} method a smooth specification object, usually generated by a term \code{s(x,...,bs="fs",)}. May have a \code{gamm} attribute: see details. For the \code{predict.Matrix} method an object of class \code{"fs.interaction"} produced by the \code{smooth.construct} method.} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term}.} \item{knots}{ a list containing any knots supplied for smooth basis setup.} } \value{ An object of class \code{"fs.interaction"} or a matrix mapping the coefficients of the factor smooth interaction to the smooths themselves. The contents of an \code{"fs.interaction"} object will depend on whether or not \code{smooth.construct} was called with an object with attribute \code{gamm}: see below. } \details{This class produces a smooth for each level of a single factor variable. Within a \code{\link{gam}} formula this is done with something like \code{s(x,fac,bs="fs")}, which is almost equivalent to \code{s(x,by=fac,id=1)} (with the \code{gam} argument \code{select=TRUE}). The terms are fully penalized, with separate penalties on each null space component: for this reason they are not centred (no sum-to-zero constraint). The class is particularly useful for use with \code{\link{gamm}}, where estimation efficiently exploits the nesting of the smooth within the factor. Note however that: i) \code{gamm} only allows one conditioning factor for smooths, so \code{s(x)+s(z,fac,bs="fs")+s(v,fac,bs="fs")} is OK, but \code{s(x)+s(z,fac1,bs="fs")+s(v,fac2,bs="fs")} is not; ii) all aditional random effects and correlation structures will be treated as nested within the factor of the smooth factor interaction. To facilitate this the constructor is called from \code{\link{gamm}} with an attribute \code{"gamm"} attached to the smooth specification object. The result differs from that resulting from the case where this is not done. Note that \code{gamm4} from the {\code{gamm4}} package suffers from none of the restrictions that apply to \code{gamm}, and \code{"fs"} terms can be used without side-effects. Construcor is still called with a smooth specification object having a \code{"gamm"} attribute. Any singly penalized basis can be used to smooth at each factor level. The default is \code{"tp"}, but alternatives can be supplied in the \code{xt} argument of \code{s} (e.g. \code{s(x,fac,bs="fs",xt="cr")} or \code{s(x,fac,bs="fs",xt=list(bs="cr")}). The \code{k} argument to \code{s(...,bs="fs")} refers to the basis dimension to use for each level of the factor variable. Note one computational bottleneck: currently \code{\link{gamm}} (or \code{gamm4}) will produce the full posterior covariance matrix for the smooths, including the smooths at each level of the factor. This matrix can get large and computationally costly if there are more than a few hundred levels of the factor. Even at one or two hundred levels, care should be taken to keep down \code{k}. The plot method for this class has two schemes. \code{scheme==0} is in colour, while \code{scheme==1} is black and white. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{gam.models}}, \code{\link{gamm}}} \examples{ library(mgcv) set.seed(0) ## simulate data... f0 <- function(x) 2 * sin(pi * x) f1 <- function(x,a=2,b=-1) exp(a * x)+b f2 <- function(x) 0.2 * x^11 * (10 * (1 - x))^6 + 10 * (10 * x)^3 * (1 - x)^10 n <- 500;nf <- 25 fac <- sample(1:nf,n,replace=TRUE) x0 <- runif(n);x1 <- runif(n);x2 <- runif(n) a <- rnorm(nf)*.2 + 2;b <- rnorm(nf)*.5 f <- f0(x0) + f1(x1,a[fac],b[fac]) + f2(x2) fac <- factor(fac) y <- f + rnorm(n)*2 ## so response depends on global smooths of x0 and ## x2, and a smooth of x1 for each level of fac. ## fit model (note p-values not available when fit ## using gamm)... bm <- gamm(y~s(x0)+ s(x1,fac,bs="fs",k=5)+s(x2,k=20)) plot(bm$gam,pages=1) summary(bm$gam) ## Could also use... ## b <- gam(y~s(x0)+ s(x1,fac,bs="fs",k=5)+s(x2,k=20),method="ML") ## ... but its slower (increasingly so with increasing nf) ## b <- gam(y~s(x0)+ t2(x1,fac,bs=c("tp","re"),k=5,full=TRUE)+ ## s(x2,k=20),method="ML")) ## ... is exactly equivalent. } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/mvn.Rd0000755000176200001440000000452513073161526013065 0ustar liggesusers\name{mvn} \alias{mvn} %- Also NEED an `\alias' for EACH other topic documented here. \title{Multivariate normal additive models} \description{Family for use with \code{\link{gam}} implementing smooth multivariate Gaussian regression. The means for each dimension are given by a separate linear predictor, which may contain smooth components. Extra linear predictors may also be specified giving terms which are shared between components (see \code{\link{formula.gam}}). The Choleski factor of the response precision matrix is estimated as part of fitting. } \usage{ mvn(d=2) } \arguments{ \item{d}{The dimension of the response (>1).} } \value{ An object of class \code{general.family}. } \details{The response is \code{d} dimensional multivariate normal, where the covariance matrix is estimated, and the means for each dimension have sperate linear predictors. Model sepcification is via a list of gam like formulae - one for each dimension. See example. Currently the family ignores any prior weights, and is implemented using first derivative information sufficient for BFGS estimation of smoothing parameters. \code{"response"} residuals give raw residuals, while \code{"deviance"} residuals are standardized to be approximately independent standard normal if all is well. } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood \email{simon.wood@r-project.org} } \references{ Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association 111, 1548-1575 \url{http://dx.doi.org/10.1080/01621459.2016.1180986} } \seealso{\code{\link{gaussian}}} \examples{ library(mgcv) ## simulate some data... V <- matrix(c(2,1,1,2),2,2) f0 <- function(x) 2 * sin(pi * x) f1 <- function(x) exp(2 * x) f2 <- function(x) 0.2 * x^11 * (10 * (1 - x))^6 + 10 * (10 * x)^3 * (1 - x)^10 n <- 300 x0 <- runif(n);x1 <- runif(n); x2 <- runif(n);x3 <- runif(n) y <- matrix(0,n,2) for (i in 1:n) { mu <- c(f0(x0[i])+f1(x1[i]),f2(x2[i])) y[i,] <- rmvn(1,mu,V) } dat <- data.frame(y0=y[,1],y1=y[,2],x0=x0,x1=x1,x2=x2,x3=x3) ## fit model... b <- gam(list(y0~s(x0)+s(x1),y1~s(x2)+s(x3)),family=mvn(d=2),data=dat) b summary(b) plot(b,pages=1) solve(crossprod(b$family$data$R)) ## estimated cov matrix } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/notExp2.Rd0000755000176200001440000000633013073161527013621 0ustar liggesusers\name{notExp2} \alias{notExp2} \alias{notLog2} %- Also NEED an `\alias' for EACH other topic documented here. \title{ Alternative to log parameterization for variance components} \description{ \code{notLog2} and \code{notExp2} are alternatives to \code{log} and \code{exp} or \code{\link{notLog}} and \code{\link{notExp}} for re-parameterization of variance parameters. They are used by the \code{\link{pdTens}} and \code{\link{pdIdnot}} classes which in turn implement smooths for \code{\link{gamm}}. The functions are typically used to ensure that smoothing parameters are positive, but the \code{notExp2} is not monotonic: rather it cycles between `effective zero' and `effective infinity' as its argument changes. The \code{notLog2} is the inverse function of the \code{notExp2} only over an interval centered on zero. Parameterizations using these functions ensure that estimated smoothing parameters remain positive, but also help to ensure that the likelihood is never indefinite: once a working parameter pushes a smoothing parameter below `effetive zero' or above `effective infinity' the cyclic nature of the \code{notExp2} causes the likelihood to decrease, where otherwise it might simply have flattened. This parameterization is really just a numerical trick, in order to get \code{lme} to fit \code{gamm} models, without failing due to indefiniteness. Note in particular that asymptotic results on the likelihood/REML criterion are not invalidated by the trick, unless parameter estimates end up close to the effective zero or effective infinity: but if this is the case then the asymptotics would also have been invalid for a conventional monotonic parameterization. This reparameterization was made necessary by some modifications to the underlying optimization method in \code{lme} introduced in nlme 3.1-62. It is possible that future releases will return to the \code{\link{notExp}} parameterization. Note that you can reset `effective zero' and `effective infinity': see below. } \usage{ notExp2(x,d=.Options$mgcv.vc.logrange,b=1/d) notLog2(x,d=.Options$mgcv.vc.logrange,b=1/d) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{Argument array of real numbers (\code{notExp}) or positive real numbers (\code{notLog}).} \item{d}{the range of \code{notExp2} runs from \code{exp(-d)} to \code{exp(d)}. To change the range used by \code{gamm} reset \code{mgcv.vc.logrange} using \code{\link{options}}.} \item{b}{determines the period of the cycle of \code{notExp2}.} } \value{ An array of function values evaluated at the supplied argument values.} \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \seealso{ \code{\link{pdTens}}, \code{\link{pdIdnot}}, \code{\link{gamm}}} \examples{ ## Illustrate the notExp2 function: require(mgcv) x <- seq(-50,50,length=1000) op <- par(mfrow=c(2,2)) plot(x,notExp2(x),type="l") lines(x,exp(x),col=2) plot(x,log(notExp2(x)),type="l") lines(x,log(exp(x)),col=2) # redundancy intended x <- x/4 plot(x,notExp2(x),type="l") lines(x,exp(x),col=2) plot(x,log(notExp2(x)),type="l") lines(x,log(exp(x)),col=2) # redundancy intended par(op) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/linear.functional.terms.Rd0000755000176200001440000002106713303547351017031 0ustar liggesusers\name{linear.functional.terms} \alias{linear.functional.terms} \alias{function.predictors} \alias{signal.regression} %- Also NEED an `\alias' for EACH other topic documented here. \title{Linear functionals of a smooth in GAMs} \description{\code{\link{gam}} allows the response variable to depend on linear functionals of smooth terms. Specifically dependancies of the form \deqn{g(\mu_i) = \ldots + \sum_j L_{ij} f(x_{ij}) + \ldots }{g(mu_i) = ... + sum_j L_ij f(x_ij) +...} are allowed, where the \eqn{x_{ij}}{x_ij} are covariate values and the \eqn{L_{ij}}{L_ij} are fixed weights. i.e. the response can depend on the weighted sum of the same smooth evaluated at different covariate values. This allows, for example, for the response to depend on the derivatives or integrals of a smooth (approximated by finite differencing or quadrature, respectively). It also allows dependence on predictor functions (sometimes called `signal regression'). The mechanism by which this is achieved is to supply matrices of covariate values to the model smooth terms specified by \code{\link{s}} or \code{\link{te}} terms in the model formula. Each column of the covariate matrix gives rise to a corresponding column of predictions from the smooth. Let the resulting matrix of evaluated smooth values be F (F will have the same dimension as the covariate matrices). In the absense of a \code{by} variable then these columns are simply summed and added to the linear predictor. i.e. the contribution of the term to the linear predictor is \code{rowSums(F)}. If a \code{by} variable is present then it must be a matrix, L,say, of the same dimension as F (and the covariate matrices), and it contains the weights \eqn{L_{ij}}{L_ij} in the summation given above. So in this case the contribution to the linear predictor is \code{rowSums(L*F)}. Note that if a \eqn{{\bf L1}}{L1} (i.e. \code{rowSums(L)}) is a constant vector, or there is no \code{by} variable then the smooth will automatically be centred in order to ensure identifiability. Otherwise it will not be. Note also that for centred smooths it can be worth replacing the constant term in the model with \code{rowSums(L)} in order to ensure that predictions are automatically on the right scale. \code{\link{predict.gam}} can accept matrix predictors for prediction with such terms, in which case its \code{newdata} argument will need to be a list. However when predicting from the model it is not necessary to provide matrix covariate and \code{by} variable values. For example to simply examine the underlying smooth function one would use vectors of covariate values and vector \code{by} variables, with the \code{by} variable and equivalent of \code{L1}, above, set to vectors of ones. The mechanism is usable with random effect smooths which take factor arguments, by using a trick to create a 2D array of factors. Simply create a factor vector containing the columns of the factor matrix stacked end to end (column major order). Then reset the dimensions of this vector to create the appropriate 2D array: the first dimension should be the number of response data and the second the number of columns of the required factor matrix. You can not use \code{matrix} or \code{data.matrix} to set up the required matrix of factor levels. See example below. } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ ### matrix argument `linear operator' smoothing library(mgcv) set.seed(0) ############################### ## simple summation example...# ############################### n<-400 sig<-2 x <- runif(n, 0, .9) f2 <- function(x) 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 x1 <- x + .1 f <- f2(x) + f2(x1) ## response is sum of f at two adjacent x values y <- f + rnorm(n)*sig X <- matrix(c(x,x1),n,2) ## matrix covariate contains both x values b <- gam(y~s(X)) plot(b) ## reconstruction of f plot(f,fitted(b)) ## example of prediction with summation convention... predict(b,list(X=X[1:3,])) ## example of prediction that simply evaluates smooth (no summation)... predict(b,data.frame(X=c(.2,.3,.7))) ###################################################################### ## Simple random effect model example. ## model: y[i] = f(x[i]) + b[k[i]] - b[j[i]] + e[i] ## k[i] and j[i] index levels of i.i.d. random effects, b. ###################################################################### set.seed(7) n <- 200 x <- runif(n) ## a continuous covariate ## set up a `factor matrix'... fac <- factor(sample(letters,n*2,replace=TRUE)) dim(fac) <- c(n,2) ## simulate data from such a model... nb <- length(levels(fac)) b <- rnorm(nb) y <- 20*(x-.3)^4 + b[fac[,1]] - b[fac[,2]] + rnorm(n)*.5 L <- matrix(-1,n,2);L[,1] <- 1 ## the differencing 'by' variable mod <- gam(y ~ s(x) + s(fac,by=L,bs="re"),method="REML") gam.vcomp(mod) plot(mod,page=1) ## example of prediction using matrices... dat <- list(L=L[1:20,],fac=fac[1:20,],x=x[1:20],y=y[1:20]) predict(mod,newdata=dat) ###################################################################### ## multivariate integral example. Function `test1' will be integrated# ## (by midpoint quadrature) over 100 equal area sub-squares covering # ## the unit square. Noise is added to the resulting simulated data. # ## `test1' is estimated from the resulting data using two alternative# ## smooths. # ###################################################################### test1 <- function(x,z,sx=0.3,sz=0.4) { (pi**sx*sz)*(1.2*exp(-(x-0.2)^2/sx^2-(z-0.3)^2/sz^2)+ 0.8*exp(-(x-0.7)^2/sx^2-(z-0.8)^2/sz^2)) } ## create quadrature (integration) grid, in useful order ig <- 5 ## integration grid within square mx <- mz <- (1:ig-.5)/ig ix <- rep(mx,ig);iz <- rep(mz,rep(ig,ig)) og <- 10 ## observarion grid mx <- mz <- (1:og-1)/og ox <- rep(mx,og);ox <- rep(ox,rep(ig^2,og^2)) oz <- rep(mz,rep(og,og));oz <- rep(oz,rep(ig^2,og^2)) x <- ox + ix/og;z <- oz + iz/og ## full grid, subsquare by subsquare ## create matrix covariates... X <- matrix(x,og^2,ig^2,byrow=TRUE) Z <- matrix(z,og^2,ig^2,byrow=TRUE) ## create simulated test data... dA <- 1/(og*ig)^2 ## quadrature square area F <- test1(X,Z) ## evaluate on grid f <- rowSums(F)*dA ## integrate by midpoint quadrature y <- f + rnorm(og^2)*5e-4 ## add noise ## ... so each y is a noisy observation of the integral of `test1' ## over a 0.1 by 0.1 sub-square from the unit square ## Now fit model to simulated data... L <- X*0 + dA ## ... let F be the matrix of the smooth evaluated at the x,z values ## in matrices X and Z. rowSums(L*F) gives the model predicted ## integrals of `test1' corresponding to the observed `y' L1 <- rowSums(L) ## smooths are centred --- need to add in L%*%1 ## fit models to reconstruct `test1'.... b <- gam(y~s(X,Z,by=L)+L1-1) ## (L1 and const are confounded here) b1 <- gam(y~te(X,Z,by=L)+L1-1) ## tensor product alternative ## plot results... old.par<-par(mfrow=c(2,2)) x<-runif(n);z<-runif(n); xs<-seq(0,1,length=30);zs<-seq(0,1,length=30) pr<-data.frame(x=rep(xs,30),z=rep(zs,rep(30,30))) truth<-matrix(test1(pr$x,pr$z),30,30) contour(xs,zs,truth) plot(b) vis.gam(b,view=c("X","Z"),cond=list(L1=1,L=1),plot.type="contour") vis.gam(b1,view=c("X","Z"),cond=list(L1=1,L=1),plot.type="contour") #################################### ## A "signal" regression example...# #################################### rf <- function(x=seq(0,1,length=100)) { ## generates random functions... m <- ceiling(runif(1)*5) ## number of components f <- x*0; mu <- runif(m,min(x),max(x));sig <- (runif(m)+.5)*(max(x)-min(x))/10 for (i in 1:m) f <- f+ dnorm(x,mu[i],sig[i]) f } x <- seq(0,1,length=100) ## evaluation points ## example functional predictors... par(mfrow=c(3,3));for (i in 1:9) plot(x,rf(x),type="l",xlab="x") ## simulate 200 functions and store in rows of L... L <- matrix(NA,200,100) for (i in 1:200) L[i,] <- rf() ## simulate the functional predictors f2 <- function(x) { ## the coefficient function (0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10)/10 } f <- f2(x) ## the true coefficient function y <- L\%*\%f + rnorm(200)*20 ## simulated response data ## Now fit the model E(y) = L\%*\%f(x) where f is a smooth function. ## The summation convention is used to evaluate smooth at each value ## in matrix X to get matrix F, say. Then rowSum(L*F) gives E(y). ## create matrix of eval points for each function. Note that ## `smoothCon' is smart and will recognize the duplication... X <- matrix(x,200,100,byrow=TRUE) b <- gam(y~s(X,by=L,k=20)) par(mfrow=c(1,1)) plot(b,shade=TRUE);lines(x,f,col=2) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/gamm.Rd0000755000176200001440000004277013555551146013220 0ustar liggesusers\name{gamm} \alias{gamm} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generalized Additive Mixed Models} \description{ Fits the specified generalized additive mixed model (GAMM) to data, by a call to \code{lme} in the normal errors identity link case, or by a call to \code{gammPQL} (a modification of \code{glmmPQL} from the \code{MASS} library) otherwise. In the latter case estimates are only approximately MLEs. The routine is typically slower than \code{gam}, and not quite as numerically robust. To use \code{lme4} in place of \code{nlme} as the underlying fitting engine, see \code{gamm4} from package \code{gamm4}. Smooths are specified as in a call to \code{\link{gam}} as part of the fixed effects model formula, but the wiggly components of the smooth are treated as random effects. The random effects structures and correlation structures available for \code{lme} are used to specify other random effects and correlations. It is assumed that the random effects and correlation structures are employed primarily to model residual correlation in the data and that the prime interest is in inference about the terms in the fixed effects model formula including the smooths. For this reason the routine calculates a posterior covariance matrix for the coefficients of all the terms in the fixed effects formula, including the smooths. To use this function effectively it helps to be quite familiar with the use of \code{\link{gam}} and \code{\link[nlme]{lme}}. } \usage{ gamm(formula,random=NULL,correlation=NULL,family=gaussian(), data=list(),weights=NULL,subset=NULL,na.action,knots=NULL, control=list(niterEM=0,optimMethod="L-BFGS-B",returnObject=TRUE), niterPQL=20,verbosePQL=TRUE,method="ML",drop.unused.levels=TRUE, mustart=NULL, etastart=NULL,...) } \arguments{ \item{formula}{ A GAM formula (see also \code{\link{formula.gam}} and \code{\link{gam.models}}). This is like the formula for a \code{glm} except that smooth terms (\code{\link{s}} and \code{\link{te}}) can be added to the right hand side of the formula. Note that \code{id}s for smooths and fixed smoothing parameters are not supported.} \item{random}{The (optional) random effects structure as specified in a call to \code{\link[nlme]{lme}}: only the \code{list} form is allowed, to facilitate manipulation of the random effects structure within \code{gamm} in order to deal with smooth terms. See example below.} \item{correlation}{An optional \code{corStruct} object (see \code{\link[nlme]{corClasses}}) as used to define correlation structures in \code{\link[nlme]{lme}}. Any grouping factors in the formula for this object are assumed to be nested within any random effect grouping factors, without the need to make this explicit in the formula (this is slightly different to the behaviour of \code{lme}). This is a GEE approach to correlation in the generalized case. See examples below.} \item{family}{A \code{family} as used in a call to \code{\link{glm}} or \code{\link{gam}}. The default \code{gaussian} with identity link causes \code{gamm} to fit by a direct call to \code{\link[nlme]{lme}} provided there is no offset term, otherwise \code{gammPQL} is used.} \item{data}{ A data frame or list containing the model response variable and covariates required by the formula. By default the variables are taken from \code{environment(formula)}, typically the environment from which \code{gamm} is called.} \item{weights}{In the generalized case, weights with the same meaning as \code{\link{glm}} weights. An \code{lme} type weights argument may only be used in the identity link gaussian case, with no offset (see documentation for \code{lme} for details of how to use such an argument).} \item{subset}{ an optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{ a function which indicates what should happen when the data contain `NA's. The default is set by the `na.action' setting of `options', and is `na.fail' if that is unset. The ``factory-fresh'' default is `na.omit'.} \item{knots}{this is an optional list containing user specified knot values to be used for basis construction. Different terms can use different numbers of knots, unless they share a covariate. } \item{control}{A list of fit control parameters for \code{\link[nlme]{lme}} to replace the defaults returned by \code{\link[nlme]{lmeControl}}. Note the setting for the number of EM iterations used by \code{lme}: smooths are set up using custom \code{pdMat} classes, which are currently not supported by the EM iteration code. If you supply a list of control values, it is advisable to include \code{niterEM=0}, as well, and only increase from 0 if you want to perturb the starting values used in model fitting (usually to worse values!). The \code{optimMethod} option is only used if your version of R does not have the \code{nlminb} optimizer function.} \item{niterPQL}{Maximum number of PQL iterations (if any).} \item{verbosePQL}{Should PQL report its progress as it goes along?} \item{method}{Which of \code{"ML"} or \code{"REML"} to use in the Gaussian additive mixed model case when \code{lme} is called directly. Ignored in the generalized case (or if the model has an offset), in which case \code{gammPQL} is used.} \item{drop.unused.levels}{by default unused levels are dropped from factors before fitting. For some smooths involving factor variables you might want to turn this off. Only do so if you know what you are doing.} \item{mustart}{starting values for mean if PQL used.} \item{etastart}{starting values for linear predictor if PQL used (over-rides \code{mustart} if supplied).} \item{...}{further arguments for passing on e.g. to \code{lme}} } %- maybe also `usage' for other objects documented here. \details{ The Bayesian model of spline smoothing introduced by Wahba (1983) and Silverman (1985) opens up the possibility of estimating the degree of smoothness of terms in a generalized additive model as variances of the wiggly components of the smooth terms treated as random effects. Several authors have recognised this (see Wang 1998; Ruppert, Wand and Carroll, 2003) and in the normal errors, identity link case estimation can be performed using general linear mixed effects modelling software such as \code{lme}. In the generalized case only approximate inference is so far available, for example using the Penalized Quasi-Likelihood approach of Breslow and Clayton (1993) as implemented in \code{glmmPQL} by Venables and Ripley (2002). One advantage of this approach is that it allows correlated errors to be dealt with via random effects or the correlation structures available in the \code{nlme} library (using correlation structures beyond the strictly additive case amounts to using a GEE approach to fitting). Some details of how GAMs are represented as mixed models and estimated using \code{lme} or \code{gammPQL} in \code{gamm} can be found in Wood (2004 ,2006a,b). In addition \code{gamm} obtains a posterior covariance matrix for the parameters of all the fixed effects and the smooth terms. The approach is similar to that described in Lin & Zhang (1999) - the covariance matrix of the data (or pseudodata in the generalized case) implied by the weights, correlation and random effects structure is obtained, based on the estimates of the parameters of these terms and this is used to obtain the posterior covariance matrix of the fixed and smooth effects. The bases used to represent smooth terms are the same as those used in \code{\link{gam}}, although adaptive smoothing bases are not available. Prediction from the returned \code{gam} object is straightforward using \code{\link{predict.gam}}, but this will set the random effects to zero. If you want to predict with random effects set to their predicted values then you can adapt the prediction code given in the examples below. In the event of \code{lme} convergence failures, consider modifying \code{options(mgcv.vc.logrange)}: reducing it helps to remove indefiniteness in the likelihood, if that is the problem, but too large a reduction can force over or undersmoothing. See \code{\link{notExp2}} for more information on this option. Failing that, you can try increasing the \code{niterEM} option in \code{control}: this will perturb the starting values used in fitting, but usually to values with lower likelihood! Note that this version of \code{gamm} works best with R 2.2.0 or above and \code{nlme}, 3.1-62 and above, since these use an improved optimizer. } \value{ Returns a list with two items: \item{gam}{an object of class \code{gam}, less information relating to GCV/UBRE model selection. At present this contains enough information to use \code{predict}, \code{summary} and \code{print} methods and \code{vis.gam}, but not to use e.g. the \code{anova} method function to compare models. This is based on the working model when using \code{gammPQL}.} \item{lme}{the fitted model object returned by \code{lme} or \code{gammPQL}. Note that the model formulae and grouping structures may appear to be rather bizarre, because of the manner in which the GAMM is split up and the calls to \code{lme} and \code{gammPQL} are constructed.} } \references{ Breslow, N. E. and Clayton, D. G. (1993) Approximate inference in generalized linear mixed models. Journal of the American Statistical Association 88, 9-25. Lin, X and Zhang, D. (1999) Inference in generalized additive mixed models by using smoothing splines. JRSSB. 55(2):381-400 Pinheiro J.C. and Bates, D.M. (2000) Mixed effects Models in S and S-PLUS. Springer Ruppert, D., Wand, M.P. and Carroll, R.J. (2003) Semiparametric Regression. Cambridge Silverman, B.W. (1985) Some aspects of the spline smoothing approach to nonparametric regression. JRSSB 47:1-52 Venables, W. N. and Ripley, B. D. (2002) Modern Applied Statistics with S. Fourth edition. Springer. Wahba, G. (1983) Bayesian confidence intervals for the cross validated smoothing spline. JRSSB 45:133-150 Wood, S.N. (2004) Stable and efficient multiple smoothing parameter estimation for generalized additive models. Journal of the American Statistical Association. 99:673-686 Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 Wood, S.N. (2006a) Low rank scale invariant tensor product smooths for generalized additive mixed models. Biometrics 62(4):1025-1036 Wood S.N. (2006b) Generalized Additive Models: An Introduction with R. Chapman and Hall/CRC Press. Wang, Y. (1998) Mixed effects smoothing spline analysis of variance. J.R. Statist. Soc. B 60, 159-174 \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \section{WARNINGS }{ \code{gamm} has a somewhat different argument list to \code{\link{gam}}, \code{gam} arguments such as \code{gamma} supplied to \code{gamm} will just be ignored. \code{gamm} performs poorly with binary data, since it uses PQL. It is better to use \code{gam} with \code{s(...,bs="re")} terms, or \code{gamm4}. \code{gamm} assumes that you know what you are doing! For example, unlike \code{glmmPQL} from \code{MASS} it will return the complete \code{lme} object from the working model at convergence of the PQL iteration, including the `log likelihood', even though this is not the likelihood of the fitted GAMM. The routine will be very slow and memory intensive if correlation structures are used for the very large groups of data. e.g. attempting to run the spatial example in the examples section with many 1000's of data is definitely not recommended: often the correlations should only apply within clusters that can be defined by a grouping factor, and provided these clusters do not get too huge then fitting is usually possible. Models must contain at least one random effect: either a smooth with non-zero smoothing parameter, or a random effect specified in argument \code{random}. \code{gamm} is not as numerically stable as \code{gam}: an \code{lme} call will occasionally fail. See details section for suggestions, or try the `gamm4' package. \code{gamm} is usually much slower than \code{gam}, and on some platforms you may need to increase the memory available to R in order to use it with large data sets (see \code{\link{memory.limit}}). Note that the weights returned in the fitted GAM object are dummy, and not those used by the PQL iteration: this makes partial residual plots look odd. Note that the \code{gam} object part of the returned object is not complete in the sense of having all the elements defined in \code{\link{gamObject}} and does not inherit from \code{glm}: hence e.g. multi-model \code{anova} calls will not work. It is also based on the working model when PQL is used. The parameterization used for the smoothing parameters in \code{gamm}, bounds them above and below by an effective infinity and effective zero. See \code{\link{notExp2}} for details of how to change this. Linked smoothing parameters and adaptive smoothing are not supported. } \seealso{\code{\link{magic}} for an alternative for correlated data, \code{\link{te}}, \code{\link{s}}, \code{\link{predict.gam}}, \code{\link{plot.gam}}, \code{\link{summary.gam}}, \code{\link{negbin}}, \code{\link{vis.gam}},\code{\link{pdTens}}, \code{gamm4} ( \url{https://cran.r-project.org/package=gamm4}) } \examples{ library(mgcv) ## simple examples using gamm as alternative to gam set.seed(0) dat <- gamSim(1,n=200,scale=2) b <- gamm(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat) plot(b$gam,pages=1) summary(b$lme) # details of underlying lme fit summary(b$gam) # gam style summary of fitted model anova(b$gam) gam.check(b$gam) # simple checking plots b <- gamm(y~te(x0,x1)+s(x2)+s(x3),data=dat) op <- par(mfrow=c(2,2)) plot(b$gam) par(op) rm(dat) ## Add a factor to the linear predictor, to be modelled as random dat <- gamSim(6,n=200,scale=.2,dist="poisson") b2 <- gamm(y~s(x0)+s(x1)+s(x2),family=poisson, data=dat,random=list(fac=~1)) plot(b2$gam,pages=1) fac <- dat$fac rm(dat) vis.gam(b2$gam) ## In the generalized case the 'gam' object is based on the working ## model used in the PQL fitting. Residuals for this are not ## that useful on their own as the following illustrates... gam.check(b2$gam) ## But more useful residuals are easy to produce on a model ## by model basis. For example... fv <- exp(fitted(b2$lme)) ## predicted values (including re) rsd <- (b2$gam$y - fv)/sqrt(fv) ## Pearson residuals (Poisson case) op <- par(mfrow=c(1,2)) qqnorm(rsd);plot(fv^.5,rsd) par(op) ## now an example with autocorrelated errors.... n <- 200;sig <- 2 x <- 0:(n-1)/(n-1) f <- 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 e <- rnorm(n,0,sig) for (i in 2:n) e[i] <- 0.6*e[i-1] + e[i] y <- f + e op <- par(mfrow=c(2,2)) ## Fit model with AR1 residuals b <- gamm(y~s(x,k=20),correlation=corAR1()) plot(b$gam);lines(x,f-mean(f),col=2) ## Raw residuals still show correlation, of course... acf(residuals(b$gam),main="raw residual ACF") ## But standardized are now fine... acf(residuals(b$lme,type="normalized"),main="standardized residual ACF") ## compare with model without AR component... b <- gam(y~s(x,k=20)) plot(b);lines(x,f-mean(f),col=2) ## more complicated autocorrelation example - AR errors ## only within groups defined by `fac' e <- rnorm(n,0,sig) for (i in 2:n) e[i] <- 0.6*e[i-1]*(fac[i-1]==fac[i]) + e[i] y <- f + e b <- gamm(y~s(x,k=20),correlation=corAR1(form=~1|fac)) plot(b$gam);lines(x,f-mean(f),col=2) par(op) ## more complex situation with nested random effects and within ## group correlation set.seed(0) n.g <- 10 n<-n.g*10*4 ## simulate smooth part... dat <- gamSim(1,n=n,scale=2) f <- dat$f ## simulate nested random effects.... fa <- as.factor(rep(1:10,rep(4*n.g,10))) ra <- rep(rnorm(10),rep(4*n.g,10)) fb <- as.factor(rep(rep(1:4,rep(n.g,4)),10)) rb <- rep(rnorm(4),rep(n.g,4)) for (i in 1:9) rb <- c(rb,rep(rnorm(4),rep(n.g,4))) ## simulate auto-correlated errors within groups e<-array(0,0) for (i in 1:40) { eg <- rnorm(n.g, 0, sig) for (j in 2:n.g) eg[j] <- eg[j-1]*0.6+ eg[j] e<-c(e,eg) } dat$y <- f + ra + rb + e dat$fa <- fa;dat$fb <- fb ## fit model .... b <- gamm(y~s(x0,bs="cr")+s(x1,bs="cr")+s(x2,bs="cr")+ s(x3,bs="cr"),data=dat,random=list(fa=~1,fb=~1), correlation=corAR1()) plot(b$gam,pages=1) summary(b$gam) vis.gam(b$gam) ## Prediction from gam object, optionally adding ## in random effects. ## Extract random effects and make names more convenient... refa <- ranef(b$lme,level=5) rownames(refa) <- substr(rownames(refa),start=9,stop=20) refb <- ranef(b$lme,level=6) rownames(refb) <- substr(rownames(refb),start=9,stop=20) ## make a prediction, with random effects zero... p0 <- predict(b$gam,data.frame(x0=.3,x1=.6,x2=.98,x3=.77)) ## add in effect for fa = "2" and fb="2/4"... p <- p0 + refa["2",1] + refb["2/4",1] ## and a "spatial" example... library(nlme);set.seed(1);n <- 100 dat <- gamSim(2,n=n,scale=0) ## standard example attach(dat) old.par<-par(mfrow=c(2,2)) contour(truth$x,truth$z,truth$f) ## true function f <- data$f ## true expected response ## Now simulate correlated errors... cstr <- corGaus(.1,form = ~x+z) cstr <- Initialize(cstr,data.frame(x=data$x,z=data$z)) V <- corMatrix(cstr) ## correlation matrix for data Cv <- chol(V) e <- t(Cv) \%*\% rnorm(n)*0.05 # correlated errors ## next add correlated simulated errors to expected values data$y <- f + e ## ... to produce response b<- gamm(y~s(x,z,k=50),correlation=corGaus(.1,form=~x+z), data=data) plot(b$gam) # gamm fit accounting for correlation # overfits when correlation ignored..... b1 <- gamm(y~s(x,z,k=50),data=data);plot(b1$gam) b2 <- gam(y~s(x,z,k=50),data=data);plot(b2) par(old.par) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/Sl.repara.Rd0000644000176200001440000000217513137076654014120 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mgcvExports.R \name{Sl.repara} \alias{Sl.repara} \title{Applying re-parameterization from log-determinant of penalty matrix to model matrix.} \usage{ Sl.repara(rp, X, inverse = FALSE, both.sides = TRUE) } \arguments{ \item{rp}{reparametrization.} \item{X}{if \code{X} is a matrix it is assumed to be a model matrix whereas if \code{X} is a vector it is assumed to be a parameter vector.} \item{inverse}{if \code{TRUE} an inverse re-parametrization is performed.} \item{both.sides}{if \code{inverse==TRUE} and \code{both.sides==FALSE} then the re-parametrization only applied to rhs, as appropriate for a choleski factor. If \code{both.sides==FALSE}, \code{X} is a vector and \code{inverse==FALSE} then \code{X} is taken as a coefficient vector (so re-parametrization is inverse of that for the model matrix).} } \value{ A re-parametrized version of \code{X}. } \description{ INTERNAL routine to apply re-parameterization from log-determinant of penalty matrix, \code{ldetS} to model matrix, \code{X}, blockwise. } \author{ Simon N. Wood . } mgcv/man/gam.convergence.Rd0000755000176200001440000001361113303547351015322 0ustar liggesusers\name{gam.convergence} \alias{gam.convergence} \alias{gam.performance} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM convergence and performance issues} \description{ When fitting GAMs there is a tradeoff between speed of fitting and probability of fit convergence. The fitting methods used by \code{\link{gam}} opt for certainty of convergence over speed of fit. \code{\link{bam}} opts for speed. \code{\link{gam}} uses a nested iteration method (see \code{\link{gam.outer}}), in which each trial set of smoothing parameters proposed by an outer Newton algorithm require an inner Newton algorithm (penalized iteratively re-weighted least squares, PIRLS) to find the corresponding best fit model coefficients. Implicit differentiation is used to find the derivatives of the coefficients with respect to log smoothing parameters, so that the derivatives of the smoothness selection criterion can be obtained, as required by the outer iteration. This approach is less expensive than it at first appears, since excellent starting values for the inner iteration are available as soon as the smoothing parameters start to converge. See Wood (2011) and Wood, Pya and Saefken (2016). \code{\link{bam}} uses an alternative approach similar to `performance iteration' or `PQL'. A single PIRLS iteration is run to find the model coefficients. At each step this requires the estimation of a working penalized linear model. Smoothing parameter selection is applied directly to this working model at each step (as if it were a Gaussian additive model). This approach is more straightforward to code and in principle less costly than the nested approach. However it is not guaranteed to converge, since the smoothness selection criterion is changing at each iteration. It is sometimes possible for the algorithm to cycle around a small set of smoothing parameter, coefficient combinations without ever converging. \code{\link{bam}} includes some checks to limit this behaviour, and the further checks in the algorithm used by \code{bam(...,discrete=TRUE)} actually guarantee convergence in some cases, but in general guarantees are not possible. See Wood, Goude and Shaw (2015) and Wood et al. (2017). \code{\link{gam}} when used with `general' families (such as \code{\link{multinom}} or \code{cox.ph}) can also use a potentially faster scheme based on the extended Fellner-Schall method (Wood and Fasiolo, 2017). This also operates with a single iteration and is not guaranteed to converge, theoretically. There are three things that you can try to speed up GAM fitting. (i) if you have large numbers of smoothing parameters in the generalized case, then try the \code{"bfgs"} method option in \code{\link{gam}} argument \code{optimizer}: this can be faster than the default. (ii) Try using \code{\link{bam}} (iii) For large datasets it may be worth changing the smoothing basis to use \code{bs="cr"} (see \code{\link{s}} for details) for 1-d smooths, and to use \code{\link{te}} smooths in place of \code{\link{s}} smooths for smooths of more than one variable. This is because the default thin plate regression spline basis \code{"tp"} is costly to set up for large datasets. If you have convergence problems, it's worth noting that a GAM is just a (penalized) GLM and the IRLS scheme used to estimate GLMs is not guaranteed to converge. Hence non convergence of a GAM may relate to a lack of stability in the basic IRLS scheme. Therefore it is worth trying to establish whether the IRLS iterations are capable of converging. To do this fit the problematic GAM with all smooth terms specified with \code{fx=TRUE} so that the smoothing parameters are all fixed at zero. If this `largest' model can converge then, then the maintainer would quite like to know about your problem! If it doesn't converge, then its likely that your model is just too flexible for the IRLS process itself. Having tried increasing \code{maxit} in \code{gam.control}, there are several other possibilities for stabilizing the iteration. It is possible to try (i) setting lower bounds on the smoothing parameters using the \code{min.sp} argument of \code{gam}: this may or may not change the model being fitted; (ii) reducing the flexibility of the model by reducing the basis dimensions \code{k} in the specification of \code{s} and \code{te} model terms: this obviously changes the model being fitted somewhat. Usually, a major contributer to fitting difficulties is that the model is a very poor description of the data. Please report convergence problems, especially if you there is no obvious pathology in the data/model that suggests convergence should fail. } %- maybe also `usage' for other objects documented here. \references{ Key References on this implementation: Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models (with discussion). Journal of the American Statistical Association 111, 1548-1575 \url{http://dx.doi.org/10.1080/01621459.2016.1180986} Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36 Wood, S.N., Goude, Y. & Shaw S. (2015) Generalized additive models for large datasets. Journal of the Royal Statistical Society, Series C 64(1): 139-155. Wood, S.N., Li, Z., Shaddick, G. & Augustin N.H. (2017) Generalized additive models for gigadata: modelling the UK black smoke network daily data. Journal of the American Statistical Association. Wood, S.N. and M. Fasiolo (2017) A generalized Fellner-Schall method for smoothing parameter optimization with application to Tweedie location, scale and shape models, Biometrics. Wood S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/sdiag.Rd0000755000176200001440000000177013073161526013353 0ustar liggesusers\name{sdiag} \alias{sdiag} \alias{sdiag<-} %- Also NEED an `\alias' for EACH other topic documented here. \title{Extract or modify diagonals of a matrix} \description{ Extracts or modifies sub- or super- diagonals of a matrix. } \usage{ sdiag(A,k=0) sdiag(A,k=0) <- value } %- maybe also `usage' for other objects documented here. \arguments{ \item{A}{a matrix} \item{k}{sub- (negative) or super- (positive) diagonal of a matrix. 0 is the leading diagonal.} \item{value}{single value, or vector of the same length as the diagonal.} } \value{A vector containing the requested diagonal, or a matrix with the requested diagonal replaced by \code{value}. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ require(mgcv) A <- matrix(1:35,7,5) A sdiag(A,1) ## first super diagonal sdiag(A,-1) ## first sub diagonal sdiag(A) <- 1 ## leading diagonal set to 1 sdiag(A,3) <- c(-1,-2) ## set 3rd super diagonal } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/ldetS.Rd0000644000176200001440000000311513450317761013332 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mgcvExports.R \name{ldetS} \alias{ldetS} \title{Getting log generalized determinant of penalty matrices} \usage{ ldetS(Sl, rho, fixed, np, root = FALSE, repara = TRUE, nt = 1,deriv=2) } \arguments{ \item{Sl}{the output of \code{Sl.setup}.} \item{rho}{the log smoothing parameters.} \item{fixed}{an array indicating whether the smoothing parameters are fixed (or free).} \item{np}{number of coefficients.} \item{root}{indicates whether or not to return the matrix square root, E, of the total penalty S_tot.} \item{repara}{if TRUE multi-term blocks will be re-parameterized using \code{gam.reparam}, and a re-parameterization object supplied in the returned object.} \item{nt}{number of parallel threads to use.} \item{deriv}{order of derivative to use} } \value{ A list containing: \itemize{ \item{\code{ldetS}: the log-determinant of S. } \item{\code{ldetS1}: the gradient of the log-determinant of S. } \item{\code{ldetS2}: the Hessian of the log-determinant of S. } \item{\code{Sl}: with modified rS terms, if needed and rho added to each block } \item{\code{rp}: a re-parameterization list. } \item{\code{rp}: E a total penalty square root such that \code{t(E)\%*\%E = S_tot} (if \code{root==TRUE}). } } } \description{ INTERNAL function calculating the log generalized determinant of penalty matrix S stored blockwise in an Sl list (which is the output of \code{Sl.setup}). } \author{ Simon N. Wood . } mgcv/man/polys.plot.Rd0000755000176200001440000000352313073161530014400 0ustar liggesusers\name{polys.plot} \alias{polys.plot} \title{Plot geographic regions defined as polygons} \usage{ polys.plot(pc,z=NULL,scheme="heat",lab="",...) } \arguments{ \item{pc}{A named list of matrices. Each matrix has two columns. The matrix rows each define the vertex of a boundary polygon. If a boundary is defined by several polygons, then each of these must be separated by an \code{NA} row in the matrix. See \code{\link{mrf}} for an example.} \item{z}{A vector of values associated with each area (item) of \code{pc}. If the vector elements have names then these are used to match elements of \code{z} to areas defined in \code{pc}. Otherwise \code{pc} and \code{z} are assumed to be in the same order. If \code{z} is \code{NULL} then polygons are not filled. } \item{scheme}{One of \code{"heat"} or \code{"grey"}, indicating how to fill the polygons in accordance with the value of \code{z}.} \item{lab}{label for plot.} \item{...}{other arguments to pass to plot (currently only if \code{z} is \code{NULL}).} } \value{Simply produces a plot.} \description{ Produces plots of geographic regions defined by polygons, optionally filling the polygons with a color or grey shade dependent on a covariate. } \details{Any polygon within another polygon counts as a hole in the area. Further nesting is dealt with by treating any point that is interior to an odd number of polygons as being within the area, and all other points as being exterior. The routine is provided to facilitate plotting with models containing \code{\link{mrf}} smooths. } \author{Simon Wood \email{simon.wood@r-project.org} } \seealso{ \code{\link{mrf}} and \code{\link{columb.polys}}. } \examples{ ## see also ?mrf for use of z require(mgcv) data(columb.polys) polys.plot(columb.polys) } \keyword{hplot} \keyword{models} \keyword{smooth} \keyword{regression} mgcv/man/gam.scale.Rd0000755000176200001440000000363013073161526014113 0ustar liggesusers\name{gam.scale} \alias{gam.scale} %- Also NEED an `\alias' for EACH other topic documented here. \title{Scale parameter estimation in GAMs} \description{Scale parameter estimation in \code{\link{gam}} depends on the type of \code{family}. For extended families then the RE/ML estimate is used. For conventional exponential families, estimated by the default outer iteration, the scale estimator can be controlled using argument \code{scale.est} in \code{\link{gam.control}}. The options are \code{"fletcher"} (default), \code{"pearson"} or \code{"deviance"}. The Pearson estimator is the (weighted) sum of squares of the pearson residuals, divided by the effective residual degrees of freedom. The Fletcher (2012) estimator is an improved version of the Pearson estimator. The deviance estimator simply substitutes deviance residuals for Pearson residuals. Usually the Pearson estimator is recommended for GLMs, since it is asymptotically unbiased. However, it can also be unstable at finite sample sizes, if a few Pearson residuals are very large. For example, a very low Poisson mean with a non zero count can give a huge Pearson residual, even though the deviance residual is much more modest. The Fletcher (2012) estimator is designed to reduce these problems. For performance iteration the Pearson estimator is always used. \code{\link{gamm}} uses the estimate of the scale parameter from the underlying call to \code{lme}. \code{\link{bam}} uses the REML estimator if the method is \code{"fREML"}. Otherwise the estimator is a Pearson estimator. } \author{ Simon N. Wood \email{simon.wood@r-project.org} with help from Mark Bravington and David Peel} \references{ Fletcher, David J. (2012) Estimating overdispersion when fitting a generalized linear model to sparse data. Biometrika 99(1), 230-237. } \seealso{ \code{\link{gam.control} } } \keyword{models} \keyword{smooth} \keyword{regression} %-- one or more .. mgcv/man/k.check.Rd0000755000176200001440000000521113303547351013564 0ustar liggesusers\name{k.check} \alias{k.check} \title{Checking smooth basis dimension } \description{ Takes a fitted \code{gam} object produced by \code{gam()} and runs diagnostic tests of whether the basis dimension choises are adequate. } \usage{ k.check(b, subsample=5000, n.rep=400) } \arguments{ \item{b}{a fitted \code{gam} object as produced by \code{\link{gam}()}.} \item{subsample}{above this number of data, testing uses a random sub-sample of data of this size.} \item{n.rep}{how many re-shuffles to do to get p-value for k testing.} } \value{A matrix contaning the output of the tests described above.} \details{ The test of whether the basis dimension for a smooth is adequate (Wood, 2017, section 5.9) is based on computing an estimate of the residual variance based on differencing residuals that are near neighbours according to the (numeric) covariates of the smooth. This estimate divided by the residual variance is the \code{k-index} reported. The further below 1 this is, the more likely it is that there is missed pattern left in the residuals. The \code{p-value} is computed by simulation: the residuals are randomly re-shuffled \code{n.rep} times to obtain the null distribution of the differencing variance estimator, if there is no pattern in the residuals. For models fitted to more than \code{subsample} data, the tests are based of \code{subsample} randomly sampled data. Low p-values may indicate that the basis dimension, \code{k}, has been set too low, especially if the reported \code{edf} is close to \code{k\'}, the maximum possible EDF for the term. Note the disconcerting fact that if the test statistic itself is based on random resampling and the null is true, then the associated p-values will of course vary widely from one replicate to the next. Currently smooths of factor variables are not supported and will give an \code{NA} p-value. Doubling a suspect \code{k} and re-fitting is sensible: if the reported \code{edf} increases substantially then you may have been missing something in the first fit. Of course p-values can be low for reasons other than a too low \code{k}. See \code{\link{choose.k}} for fuller discussion. } \references{ Wood S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC Press. \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{choose.k}}, \code{\link{gam}}, \code{\link{gam.check}}} \examples{ library(mgcv) set.seed(0) dat <- gamSim(1,n=200) b<-gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat) plot(b,pages=1) k.check(b) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/bandchol.Rd0000755000176200001440000000372713073161526014042 0ustar liggesusers\name{bandchol} \alias{bandchol} %- Also NEED an `\alias' for EACH other topic documented here. \title{Choleski decomposition of a band diagonal matrix} \description{ Computes Choleski decomposition of a (symmetric positive definite) band-diagonal matrix, \code{A}. } \usage{ bandchol(B) } %- maybe also `usage' for other objects documented here. \arguments{ \item{B}{An n by k matrix containing the diagonals of the matrix \code{A} to be decomposed. First row is leading diagonal, next is first sub-diagonal, etc. sub-diagonals are zero padded at the end. Alternatively gives \code{A} directly, i.e. a square matrix with 2k-1 non zero diagonals (those from the lower triangle are not accessed).} } \value{Let \code{R} be the factor such that \code{t(R)\%*\%R = A}. \code{R} is upper triangular and if the rows of \code{B} contained the diagonals of \code{A} on entry, then what is returned is an n by k matrix containing the diagonals of \code{R}, packed as \code{B} was packed on entry. If \code{B} was square on entry, then \code{R} is returned directly. See examples. } \details{Calls \code{dpbtrf} from \code{LAPACK}. The point of this is that it has \eqn{O(k^2n)}{O(k^2n)} computational cost, rather than the \eqn{O(n^3)}{O(n^3)} required by dense matrix methods. } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Anderson, E., Bai, Z., Bischof, C., Blackford, S., Dongarra, J., Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A. and Sorensen, D., 1999. LAPACK Users' guide (Vol. 9). Siam. } \examples{ require(mgcv) ## simulate a banded diagonal matrix n <- 7;set.seed(8) A <- matrix(0,n,n) sdiag(A) <- runif(n);sdiag(A,1) <- runif(n-1) sdiag(A,2) <- runif(n-2) A <- crossprod(A) ## full matrix form... bandchol(A) chol(A) ## for comparison ## compact storage form... B <- matrix(0,3,n) B[1,] <- sdiag(A);B[2,1:(n-1)] <- sdiag(A,1) B[3,1:(n-2)] <- sdiag(A,2) bandchol(B) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/single.index.Rd0000755000176200001440000000627613137076654014671 0ustar liggesusers\name{single.index} \alias{single.index} %- Also NEED an `\alias' for EACH other topic documented here. \title{Single index models with mgcv} \description{ Single index models contain smooth terms with arguments that are linear combinations of other covariates. e.g. \eqn{s(X\alpha)}{s(Xa)} where \eqn{\alpha}{a} has to be estimated. For identifiability, assume \eqn{\|\alpha\|=1}{||a||=1} with positive first element. One simple way to fit such models is to use \code{\link{gam}} to profile out the smooth model coefficients and smoothing parameters, leaving only the \eqn{\alpha}{a} to be estimated by a general purpose optimizer. Example code is provided below, which can be easily adapted to include multiple single index terms, parametric terms and further smooths. Note the initialization strategy. First estimate \eqn{\alpha}{a} without penalization to get starting values and then do the full fit. Otherwise it is easy to get trapped in a local optimum in which the smooth is linear. An alternative is to initialize using fixed penalization (via the \code{sp} argument to \code{\link{gam}}). } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ require(mgcv) si <- function(theta,y,x,z,opt=TRUE,k=10,fx=FALSE) { ## Fit single index model using gam call, given theta (defines alpha). ## Return ML if opt==TRUE and fitted gam with theta added otherwise. ## Suitable for calling from 'optim' to find optimal theta/alpha. alpha <- c(1,theta) ## constrained alpha defined using free theta kk <- sqrt(sum(alpha^2)) alpha <- alpha/kk ## so now ||alpha||=1 a <- x\%*\%alpha ## argument of smooth b <- gam(y~s(a,fx=fx,k=k)+s(z),family=poisson,method="ML") ## fit model if (opt) return(b$gcv.ubre) else { b$alpha <- alpha ## add alpha J <- outer(alpha,-theta/kk^2) ## compute Jacobian for (j in 1:length(theta)) J[j+1,j] <- J[j+1,j] + 1/kk b$J <- J ## dalpha_i/dtheta_j return(b) } } ## si ## simulate some data from a single index model... set.seed(1) f2 <- function(x) 0.2 * x^11 * (10 * (1 - x))^6 + 10 * (10 * x)^3 * (1 - x)^10 n <- 200;m <- 3 x <- matrix(runif(n*m),n,m) ## the covariates for the single index part z <- runif(n) ## another covariate alpha <- c(1,-1,.5); alpha <- alpha/sqrt(sum(alpha^2)) eta <- as.numeric(f2((x\%*\%alpha+.41)/1.4)+1+z^2*2)/4 mu <- exp(eta) y <- rpois(n,mu) ## Poi response ## now fit to the simulated data... th0 <- c(-.8,.4) ## close to truth for speed ## get initial theta, using no penalization... f0 <- nlm(si,th0,y=y,x=x,z=z,fx=TRUE,k=5) ## now get theta/alpha with smoothing parameter selection... f1 <- nlm(si,f0$estimate,y=y,x=x,z=z,hessian=TRUE,k=10) theta.est <-f1$estimate ## Alternative using 'optim'... \donttest{ th0 <- rep(0,m-1) ## get initial theta, using no penalization... f0 <- optim(th0,si,y=y,x=x,z=z,fx=TRUE,k=5) ## now get theta/alpha with smoothing parameter selection... f1 <- optim(f0$par,si,y=y,x=x,z=z,hessian=TRUE,k=10) theta.est <-f1$par } ## extract and examine fitted model... b <- si(theta.est,y,x,z,opt=FALSE) ## extract best fit model plot(b,pages=1) b b$alpha ## get sd for alpha... Vt <- b$J\%*\%solve(f1$hessian,t(b$J)) diag(Vt)^.5 } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.gp.smooth.spec.Rd0000755000176200001440000001610113303547337020464 0ustar liggesusers\name{smooth.construct.gp.smooth.spec} \alias{smooth.construct.gp.smooth.spec} \alias{Predict.matrix.gp.smooth} \alias{gp.smooth} %- Also NEED an `\alias' for EACH other topic documented here. \title{Low rank Gaussian process smooths} \description{Gaussian process/kriging models based on simple covariance functions can be written in a very similar form to thin plate and Duchon spline models (e.g. Handcock, Meier, Nychka, 1994), and low rank versions produced by the eigen approximation method of Wood (2003). Kammann and Wand (2003) suggest a particularly simple form of the Matern covariance function with only a single smoothing parameter to estimate, and this class implements this and other similar models. Usually invoked by an \code{s(...,bs="gp")} term in a \code{gam} formula. Argument \code{m} selects the covariance function, sets the range parameter and any power parameter. If \code{m} is not supplied then it defaults to \code{NA} and the covariance function suggested by Kammann and Wand (2003) along with their suggested range parameter is used. Otherwise \code{m[1]} between 1 and 5 selects the correlation function from respectively, spherical, power exponential, and Matern with kappa = 1.5, 2.5 or 3.5. \code{m[2]} if present specifies the range parameter, with non-positive or absent indicating that the Kammann and Wand estimate should be used. \code{m[3]} can be used to specify the power for the power exponential which otherwise defaults to 1. } \usage{ \method{smooth.construct}{gp.smooth.spec}(object, data, knots) \method{Predict.matrix}{gp.smooth}(object, data) } \arguments{ \item{object}{a smooth specification object, usually generated by a term \code{s(...,bs="ms",...)}.} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}} } \value{ An object of class \code{"gp.smooth"}. In addition to the usual elements of a smooth class documented under \code{\link{smooth.construct}}, this object will contain: \item{shift}{A record of the shift applied to each covariate in order to center it around zero and avoid any co-linearity problems that might otherwise occur in the penalty null space basis of the term. } \item{Xu}{A matrix of the unique covariate combinations for this smooth (the basis is constructed by first stripping out duplicate locations).} \item{UZ}{The matrix mapping the smoother parameters back to the parameters of a full GP smooth.} \item{null.space.dimension}{The dimension of the space of functions that have zero wiggliness according to the wiggliness penalty for this term.} \item{gp.defn}{the type, range parameter and power parameter defining the correlation function. } } \details{ Let \eqn{\rho>0}{r>0} be the range parameter, \eqn{0 < \kappa\le 2 }{0 alpha[i]&u <= alpha[i+1]] <- i } dat$y <- y ## plot the data... par(mfrow=c(2,2)) with(dat,plot(x0,y));with(dat,plot(x1,y)) with(dat,plot(x2,y));with(dat,plot(x3,y)) ## fit ocat model to data... b <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=ocat(R=R),data=dat) b plot(b,pages=1) gam.check(b) summary(b) b$family$getTheta(TRUE) ## the estimated cut points ## predict probabilities of being in each category predict(b,dat[1:2,],type="response",se=TRUE) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/smooth.construct.sos.smooth.spec.Rd0000755000176200001440000001322113073161526020656 0ustar liggesusers\name{smooth.construct.sos.smooth.spec} \alias{smooth.construct.sos.smooth.spec} \alias{Predict.matrix.sos.smooth} \alias{Spherical.Spline} %- Also NEED an `\alias' for EACH other topic documented here. \title{Splines on the sphere} \description{\code{\link{gam}} can use isotropic smooths on the sphere, via terms like \code{s(la,lo,bs="sos",m=2,k=100)}. There must be exactly 2 arguments to such a smooth. The first is taken to be latitude (in degrees) and the second longitude (in degrees). \code{m} (default 0) is an integer in the range -1 to 4 determining the order of the penalty used. For \code{m>0}, \code{(m+2)/2} is the penalty order, with \code{m=2} equivalent to the usual second derivative penalty. \code{m=0} signals to use the 2nd order spline on the sphere, computed by Wendelberger's (1981) method. \code{m = -1} results in a \code{\link{Duchon.spline}} being used (with m=2 and s=1/2), following an unpublished suggestion of Jean Duchon. \code{k} (default 50) is the basis dimension. } \usage{ \method{smooth.construct}{sos.smooth.spec}(object, data, knots) \method{Predict.matrix}{sos.smooth}(object, data) } \arguments{ \item{object}{a smooth specification object, usually generated by a term \code{s(...,bs="sos",...)}.} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}} } \value{ An object of class \code{"sos.smooth"}. In addition to the usual elements of a smooth class documented under \code{\link{smooth.construct}}, this object will contain: \item{Xu}{A matrix of the unique covariate combinations for this smooth (the basis is constructed by first stripping out duplicate locations).} \item{UZ}{The matrix mapping the parameters of the reduced rank spline back to the parameters of a full spline.} } \details{ For \code{m>0}, the smooths implemented here are based on the pseudosplines on the sphere of Wahba (1981) (there is a correction of table 1 in 1982, but the correction has a misprint in the definition of A --- the A given in the 1981 paper is correct). For \code{m=0} (default) then a second order spline on the sphere is used which is the analogue of a second order thin plate spline in 2D: the computation is based on Chapter 4 of Wendelberger, 1981. Optimal low rank approximations are obtained using exactly the approach given in Wood (2003). For \code{m = -1} a smooth of the general type discussed in Duchon (1977) is used: the sphere is embedded in a 3D Euclidean space, but smoothing employs a penalty based on second derivatives (so that locally as the smoothing parameter tends to zero we recover a "normal" thin plate spline on the tangent space). This is an unpublished suggestion of Jean Duchon. Note that the null space of the penalty is always the space of constant functions on the sphere, whatever the order of penalty. This class has a plot method, with 3 schemes. \code{scheme==0} plots one hemisphere of the sphere, projected onto a circle. The plotting sphere has the north pole at the top, and the 0 meridian running down the middle of the plot, and towards the viewer. The smoothing sphere is rotated within the plotting sphere, by specifying the location of its pole in the co-ordinates of the viewing sphere. \code{theta}, \code{phi} give the longitude and latitude of the smoothing sphere pole within the plotting sphere (in plotting sphere co-ordinates). (You can visualize the smoothing sphere as a globe, free to rotate within the fixed transparent plotting sphere.) The value of the smooth is shown by a heat map overlaid with a contour plot. lat, lon gridlines are also plotted. \code{scheme==1} is as \code{scheme==0}, but in black and white, without the image plot. \code{scheme>1} calls the default plotting method with \code{scheme} decremented by 2. } \seealso{\code{\link{Duchon.spline}}} \references{ Wahba, G. (1981) Spline interpolation and smoothing on the sphere. SIAM J. Sci. Stat. Comput. 2(1):5-16 Wahba, G. (1982) Erratum. SIAM J. Sci. Stat. Comput. 3(3):385-386. Wendelberger, J. (1981) PhD Thesis, University of Winsconsin. Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 } \author{ Simon Wood \email{simon.wood@r-project.org}, with help from Grace Wahba (m=0 case) and Jean Duchon (m = -1 case).} \examples{ require(mgcv) set.seed(0) n <- 400 f <- function(la,lo) { ## a test function... sin(lo)*cos(la-.3) } ## generate with uniform density on sphere... lo <- runif(n)*2*pi-pi ## longitude la <- runif(3*n)*pi-pi/2 ind <- runif(3*n)<=cos(la) la <- la[ind]; la <- la[1:n] ff <- f(la,lo) y <- ff + rnorm(n)*.2 ## test data ## generate data for plotting truth... lam <- seq(-pi/2,pi/2,length=30) lom <- seq(-pi,pi,length=60) gr <- expand.grid(la=lam,lo=lom) fz <- f(gr$la,gr$lo) zm <- matrix(fz,30,60) require(mgcv) dat <- data.frame(la = la *180/pi,lo = lo *180/pi,y=y) ## fit spline on sphere model... bp <- gam(y~s(la,lo,bs="sos",k=60),data=dat) ## pure knot based alternative... ind <- sample(1:n,100) bk <- gam(y~s(la,lo,bs="sos",k=60), knots=list(la=dat$la[ind],lo=dat$lo[ind]),data=dat) b <- bp cor(fitted(b),ff) ## plot results and truth... pd <- data.frame(la=gr$la*180/pi,lo=gr$lo*180/pi) fv <- matrix(predict(b,pd),30,60) par(mfrow=c(2,2),mar=c(4,4,1,1)) contour(lom,lam,t(zm)) contour(lom,lam,t(fv)) plot(bp,rug=FALSE) plot(bp,scheme=1,theta=-30,phi=20,pch=19,cex=.5) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/fs.test.Rd0000755000176200001440000000401713073161526013647 0ustar liggesusers\name{fs.test} \alias{fs.test} \alias{fs.boundary} %- Also NEED an `\alias' for EACH other topic documented here. \title{FELSPLINE test function} \description{Implements a finite area test function based on one proposed by Tim Ramsay (2002). } \usage{ fs.test(x,y,r0=.1,r=.5,l=3,b=1,exclude=TRUE) fs.boundary(r0=.1,r=.5,l=3,n.theta=20) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x,y}{Points at which to evaluate the test function.} \item{r0}{The test domain is a sort of bent sausage. This is the radius of the inner bend} \item{r}{The radius of the curve at the centre of the sausage.} \item{l}{The length of an arm of the sausage.} \item{b}{The rate at which the function increases per unit increase in distance along the centre line of the sausage.} \item{exclude}{Should exterior points be set to \code{NA}?} \item{n.theta}{How many points to use in a piecewise linear representation of a quarter of a circle, when generating the boundary curve.} } \details{ The function details are not given in the source article: but this is pretty close. The function is modified from Ramsay (2002), in that it bulges, rather than being flat: this makes a better test of the smoother. } \value{ \code{fs.test} returns function evaluations, or \code{NA}s for points outside the boundary. \code{fs.boundary} returns a list of \code{x,y} points to be jointed up in order to define/draw the boundary. } \references{ Tim Ramsay (2002) "Spline smoothing over difficult regions" J.R.Statist. Soc. B 64(2):307-319 } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ require(mgcv) ## plot the function, and its boundary... fsb <- fs.boundary() m<-300;n<-150 xm <- seq(-1,4,length=m);yn<-seq(-1,1,length=n) xx <- rep(xm,n);yy<-rep(yn,rep(m,n)) tru <- matrix(fs.test(xx,yy),m,n) ## truth image(xm,yn,tru,col=heat.colors(100),xlab="x",ylab="y") lines(fsb$x,fsb$y,lwd=3) contour(xm,yn,tru,levels=seq(-5,5,by=.25),add=TRUE) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/new.name.Rd0000755000176200001440000000220513073161526013766 0ustar liggesusers\name{new.name} \alias{new.name} %- Also NEED an `\alias' for EACH other topic documented here. \title{Obtain a name for a new variable that is not already in use} \description{ \code{\link{gamm}} works by transforming a GAMM into something that can be estimated by \code{\link[nlme]{lme}}, but this involves creating new variables, the names of which should not clash with the names of other variables on which the model depends. This simple service routine checks a suggested name against a list of those in use, and if neccesary modifies it so that there is no clash.} \usage{ new.name(proposed,old.names) } %- maybe also `usage' for other objects documented here. \arguments{ \item{proposed}{a suggested name} \item{old.names}{ An array of names that must not be duplicated} } \value{A name that is not in \code{old.names}.} \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \seealso{ \code{\link{gamm} } } \examples{ require(mgcv) old <- c("a","tuba","is","tubby") new.name("tubby",old) } \keyword{models} \keyword{smooth} \keyword{regression} %-- one or more .. mgcv/man/smooth.construct.ds.smooth.spec.Rd0000755000176200001440000001516213073161526020466 0ustar liggesusers\name{smooth.construct.ds.smooth.spec} \alias{smooth.construct.ds.smooth.spec} \alias{Predict.matrix.duchon.spline} \alias{Duchon.spline} %- Also NEED an `\alias' for EACH other topic documented here. \title{Low rank Duchon 1977 splines} \description{Thin plate spline smoothers are a special case of the isotropic splines discussed in Duchon (1977). A subset of this more general class can be invoked by terms like \code{s(x,z,bs="ds",m=c(1,.5)} in a \code{\link{gam}} model formula. In the notation of Duchon (1977) m is given by \code{m[1]} (default value 2), while s is given by \code{m[2]} (default value 0). Duchon's (1977) construction generalizes the usual thin plate spline penalty as follows. The usual TPS penalty is given by the integral of the squared Euclidian norm of a vector of mixed partial mth order derivatives of the function w.r.t. its arguments. Duchon re-expresses this penalty in the Fourier domain, and then weights the squared norm in the integral by the Euclidean norm of the fourier frequencies, raised to the power 2s. s is a user selected constant taking integer values divided by 2. If d is the number of arguments of the smooth, then it is required that -d/2 < s < d/2. To obtain continuous functions we further require that m + s > d/2. If s=0 then the usual thin plate spline is recovered. The construction is amenable to exactly the low rank approximation method given in Wood (2003) to thin plate splines, with similar optimality properties, so this approach to low rank smoothing is used here. For large datasets the same subsampling approach as is used in the \code{\link{tprs}} case is employed here to reduce computational costs. These smoothers allow the use of lower orders of derivative in the penalty than conventional thin plate splines, while still yielding continuous functions. For example, we can set m = 1 and s = d/2 - .5 in order to use first derivative penalization for any d (which has the advantage that the dimension of the null space of unpenalized functions is only d+1). } \usage{ \method{smooth.construct}{ds.smooth.spec}(object, data, knots) \method{Predict.matrix}{duchon.spline}(object, data) } \arguments{ \item{object}{a smooth specification object, usually generated by a term \code{s(...,bs="ds",...)}.} \item{data}{a list containing just the data (including any \code{by} variable) required by this term, with names corresponding to \code{object$term} (and \code{object$by}). The \code{by} variable is the last element.} \item{knots}{a list containing any knots supplied for basis setup --- in same order and with same names as \code{data}. Can be \code{NULL}} } \value{ An object of class \code{"duchon.spline"}. In addition to the usual elements of a smooth class documented under \code{\link{smooth.construct}}, this object will contain: \item{shift}{A record of the shift applied to each covariate in order to center it around zero and avoid any co-linearity problems that might otehrwise occur in the penalty null space basis of the term. } \item{Xu}{A matrix of the unique covariate combinations for this smooth (the basis is constructed by first stripping out duplicate locations).} \item{UZ}{The matrix mapping the smoother parameters back to the parameters of a full Duchon spline.} \item{null.space.dimension}{The dimension of the space of functions that have zero wiggliness according to the wiggliness penalty for this term.} } \details{ The default basis dimension for this class is \code{k=M+k.def} where \code{M} is the null space dimension (dimension of unpenalized function space) and \code{k.def} is 10 for dimension 1, 30 for dimension 2 and 100 for higher dimensions. This is essentially arbitrary, and should be checked, but as with all penalized regression smoothers, results are statistically insensitive to the exact choise, provided it is not so small that it forces oversmoothing (the smoother's degrees of freedom are controlled primarily by its smoothing parameter). The constructor is not normally called directly, but is rather used internally by \code{\link{gam}}. To use for basis setup it is recommended to use \code{\link{smooth.construct2}}. For these classes the specification \code{object} will contain information on how to handle large datasets in their \code{xt} field. The default is to randomly subsample 2000 `knots' from which to produce a reduced rank eigen approximation to the full basis, if the number of unique predictor variable combinations in excess of 2000. The default can be modified via the \code{xt} argument to \code{\link{s}}. This is supplied as a list with elements \code{max.knots} and \code{seed} containing a number to use in place of 2000, and the random number seed to use (either can be missing). Note that the random sampling will not effect the state of R's RNG. For these bases \code{knots} has two uses. Firstly, as mentioned already, for large datasets the calculation of the \code{tp} basis can be time-consuming. The user can retain most of the advantages of the approach by supplying a reduced set of covariate values from which to obtain the basis - typically the number of covariate values used will be substantially smaller than the number of data, and substantially larger than the basis dimension, \code{k}. This approach is the one taken automatically if the number of unique covariate values (combinations) exceeds \code{max.knots}. The second possibility is to avoid the eigen-decomposition used to find the spline basis altogether and simply use the basis implied by the chosen knots: this will happen if the number of knots supplied matches the basis dimension, \code{k}. For a given basis dimension the second option is faster, but gives poorer results (and the user must be quite careful in choosing knot locations). } \seealso{\code{\link{Spherical.Spline}}} \references{ Duchon, J. (1977) Splines minimizing rotation-invariant semi-norms in Solobev spaces. in W. Shemp and K. Zeller (eds) Construction theory of functions of several variables, 85-100, Springer, Berlin. Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ require(mgcv) eg <- gamSim(2,n=200,scale=.05) attach(eg) op <- par(mfrow=c(2,2),mar=c(4,4,1,1)) b0 <- gam(y~s(x,z,bs="ds",m=c(2,0),k=50),data=data) ## tps b <- gam(y~s(x,z,bs="ds",m=c(1,.5),k=50),data=data) ## first deriv penalty b1 <- gam(y~s(x,z,bs="ds",m=c(2,.5),k=50),data=data) ## modified 2nd deriv persp(truth$x,truth$z,truth$f,theta=30) ## truth vis.gam(b0,theta=30) vis.gam(b,theta=30) vis.gam(b1,theta=30) detach(eg) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/uniquecombs.Rd0000755000176200001440000000665513431731552014625 0ustar liggesusers\name{uniquecombs} \alias{uniquecombs} %- Also NEED an `\alias' for EACH other topic documented here. \title{find the unique rows in a matrix } \description{ This routine returns a matrix or data frame containing all the unique rows of the matrix or data frame supplied as its argument. That is, all the duplicate rows are stripped out. Note that the ordering of the rows on exit need not be the same as on entry. It also returns an index attribute for relating the result back to the original matrix. } \usage{ uniquecombs(x,ordered=FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{ is an \R matrix (numeric), or data frame. } \item{ordered}{ set to \code{TRUE} to have the rows of the returned object in the same order regardless of input ordering.} } \details{ Models with more parameters than unique combinations of covariates are not identifiable. This routine provides a means of evaluating the number of unique combinations of covariates in a model. When \code{x} has only one column then the routine uses \code{\link{unique}} and \code{\link{match}} to get the index. When there are multiple columns then it uses \code{\link{paste0}} to produce labels for each row, which should be unique if the row is unique. Then \code{unique} and \code{match} can be used as in the single column case. Obviously the pasting is inefficient, but still quicker for large n than the C based code that used to be called by this routine, which had O(nlog(n)) cost. In principle a hash table based solution in C would be only O(n) and much quicker in the multicolumn case. \code{\link{unique}} and \code{\link{duplicated}}, can be used in place of this, if the full index is not needed. Relative performance is variable. If \code{x} is not a matrix or data frame on entry then an attempt is made to coerce it to a data frame. } \value{ A matrix or data frame consisting of the unique rows of \code{x} (in arbitrary order). The matrix or data frame has an \code{"index"} attribute. \code{index[i]} gives the row of the returned matrix that contains row i of the original matrix. } \seealso{\code{\link{unique}}, \code{\link{duplicated}}, \code{\link{match}}.} \author{ Simon N. Wood \email{simon.wood@r-project.org} with thanks to Jonathan Rougier} \section{WARNINGS }{ If a dataframe contains variables of a type other than numeric, logical, factor or character, which either have no \code{as.character} method, or whose \code{as.character} method is a many to one mapping, then the routine is likely to fail. If the character representation of a dataframe variable (other than of class factor of character) contains \code{*} then in principle the method could fail (but with a warning). } \examples{ require(mgcv) ## matrix example... X <- matrix(c(1,2,3,1,2,3,4,5,6,1,3,2,4,5,6,1,1,1),6,3,byrow=TRUE) print(X) Xu <- uniquecombs(X);Xu ind <- attr(Xu,"index") ## find the value for row 3 of the original from Xu Xu[ind[3],];X[3,] ## same with fixed output ordering Xu <- uniquecombs(X,TRUE);Xu ind <- attr(Xu,"index") ## find the value for row 3 of the original from Xu Xu[ind[3],];X[3,] ## data frame example... df <- data.frame(f=factor(c("er",3,"b","er",3,3,1,2,"b")), x=c(.5,1,1.4,.5,1,.6,4,3,1.7), bb = c(rep(TRUE,5),rep(FALSE,4)), fred = c("foo","a","b","foo","a","vf","er","r","g"), stringsAsFactors=FALSE) uniquecombs(df) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/in.out.Rd0000644000176200001440000000305213551272330013465 0ustar liggesusers\name{in.out} \alias{in.out} %- Also NEED an `\alias' for EACH other topic documented here. \title{Which of a set of points lie within a polygon defined region} \description{Tests whether each of a set of points lie within a region defined by one or more (possibly nested) polygons. Points count as `inside' if they are interior to an odd number of polygons. } \usage{ in.out(bnd,x) } %- maybe also `usage' for other objects documented here. \arguments{ \item{bnd}{A two column matrix, the rows of which define the vertices of polygons defining the boundary of a region. Different polygons should be separated by an \code{NA} row, and the polygons are assumed closed. Alternatively can be a lists where \code{bnd[[i]][[1]]}, \code{bnd[[i]][[2]]} defines the ith boundary loop.} \item{x}{A two column matrix. Each row is a point to test for inclusion in the region defined by \code{bnd}. Can also be a 2-vector, defining a single point.} } \value{A logical vector of length \code{nrow(x)}. \code{TRUE} if the corresponding row of \code{x} is inside the boundary and \code{FALSE} otherwise. } \details{ The algorithm works by counting boundary crossings (using compiled C code). } \references{ \url{http://www.maths.bris.ac.uk/~sw15190/} } \author{ Simon N. Wood \email{simon.wood@r-project.org} } \examples{ library(mgcv) data(columb.polys) bnd <- columb.polys[[2]] plot(bnd,type="n") polygon(bnd) x <- seq(7.9,8.7,length=20) y <- seq(13.7,14.3,length=20) gr <- as.matrix(expand.grid(x,y)) inside <- in.out(bnd,gr) points(gr,col=as.numeric(inside)+1) } mgcv/man/smooth2random.Rd0000755000176200001440000001126013351170664015055 0ustar liggesusers\name{smooth2random} \alias{smooth2random} %- Also NEED an `\alias' for EACH other topic documented here. \title{Convert a smooth to a form suitable for estimating as random effect} \description{A generic function for converting \code{mgcv} smooth objects to forms suitable for estimation as random effects by e.g. \code{lme}. Exported mostly for use by other package developers. } \usage{ smooth2random(object,vnames,type=1) %\method{summary}{gam}(object, dispersion=NULL, freq=FALSE, p.type = 0, ...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{an \code{mgcv} smooth object.} \item{vnames}{a vector of names to avoid as dummy variable names in the random effects form.} \item{type}{\code{1} for \code{lme}, otherwise \code{lmer}.} } \details{There is a duality between smooths and random effects which means that smooths can be estimated using mixed modelling software. This function converts standard \code{mgcv} smooth objects to forms suitable for estimation by \code{lme}, for example. A service routine for \code{\link{gamm}} exported for use by package developers. See examples for creating prediction matrices for new data, corresponding to the random and fixed effect matrices returned when \code{type=2}. } \value{A list. \item{rand}{ a list of random effects, including grouping factors, and a fixed effects matrix. Grouping factors, model matrix and model matrix name attached as attributes, to each element. Alternatively, for \code{type=2} a list of random effect model matrices, each corresponding to an i.i.d. Gaussian random effect with a single variance component.} \item{trans.D}{A vector, trans.D, that transforms coefs, in order [rand1, rand2,... fix] back to original parameterization. If null, then taken as vector of ones. \code{b.original = trans.U \%*\% (trans.D*b.fit)}.} \item{trans.U}{A matrix, trans.U, that transforms coefs, in order [rand1, rand2,... fix] back to original parameterization. If null, then not needed. If null then taken as identity.} \item{Xf}{A matrix for the fixed effects, if any.} \item{fixed}{\code{TRUE/FALSE}, indicating if term was unpenalized or not. If unpenalized then other stuff may not be returned (it's not a random effect).} \item{rind}{an index vector such that if br is the vector of random coefficients for the term, br[rind] is the coefs in order for this term. } \item{pen.ind}{index of which penalty penalizes each coefficient: 0 for unpenalized.} } \references{ Wood S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC Press. } \author{ Simon N. Wood \email{simon.wood@r-project.org}.} \seealso{ \code{\link{gamm}} } \examples{ ## Simple type 1 'lme' style... library(mgcv) x <- runif(30) sm <- smoothCon(s(x),data.frame(x=x))[[1]] smooth2random(sm,"") ## Now type 2 'lme4' style... z <- runif(30) dat <- data.frame(x=x,z=z) sm <- smoothCon(t2(x,z),dat)[[1]] re <- smooth2random(sm,"",2) str(re) ## For prediction after fitting we might transform parameters back to ## original parameterization using 'rind', 'trans.D' and 'trans.U', ## and call PredictMat(sm,newdata) to get the prediction matrix to ## multiply these transformed parameters by. ## Alternatively we could obtain fixed and random effect Prediction ## matrices corresponding to the results from smooth2random, which ## can be used with the fit parameters without transforming them. ## The following shows how... s2rPred <- function(sm,re,data) { ## Function to aid prediction from smooths represented as type==2 ## random effects. re must be the result of smooth2random(sm,...,type=2). X <- PredictMat(sm,data) ## get prediction matrix for new data ## transform to r.e. parameterization if (!is.null(re$trans.U)) X <- X\%*\%re$trans.U X <- t(t(X)*re$trans.D) ## re-order columns according to random effect re-ordering... X[,re$rind] <- X[,re$pen.ind!=0] ## re-order penalization index in same way pen.ind <- re$pen.ind; pen.ind[re$rind] <- pen.ind[pen.ind>0] ## start return object... r <- list(rand=list(),Xf=X[,which(re$pen.ind==0),drop=FALSE]) for (i in 1:length(re$rand)) { ## loop over random effect matrices r$rand[[i]] <- X[,which(pen.ind==i),drop=FALSE] attr(r$rand[[i]],"s.label") <- attr(re$rand[[i]],"s.label") } names(r$rand) <- names(re$rand) r } ## s2rPred ## use function to obtain prediction random and fixed effect matrices ## for first 10 elements of 'dat'. Then confirm that these match the ## first 10 rows of the original model matrices, as they should... r <- s2rPred(sm,re,dat[1:10,]) range(r$Xf-re$Xf[1:10,]) range(r$rand[[1]]-re$rand[[1]][1:10,]) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/slanczos.Rd0000755000176200001440000000624413073161530014114 0ustar liggesusers\name{slanczos} \alias{slanczos} %- Also NEED an `\alias' for EACH other topic documented here. \title{Compute truncated eigen decomposition of a symmetric matrix} \description{ Uses Lanczos iteration to find the truncated eigen-decomposition of a symmetric matrix. } \usage{ slanczos(A,k=10,kl=-1,tol=.Machine$double.eps^.5,nt=1) } %- maybe also `usage' for other objects documented here. \arguments{ \item{A}{A symmetric matrix.} \item{k}{Must be non-negative. If \code{kl} is negative, then the \code{k} largest magnitude eigenvalues are found, together with the corresponding eigenvectors. If \code{kl} is non-negative then the \code{k} highest eigenvalues are found together with their eigenvectors and the \code{kl} lowest eigenvalues with eigenvectors are also returned.} \item{kl}{If \code{kl} is non-negative then the \code{kl} lowest eigenvalues are returned together with their corresponding eigenvectors (in addition to the \code{k} highest eignevalues + vectors). negative \code{kl} signals that the \code{k} largest magnitude eigenvalues should be returned, with eigenvectors.} \item{tol}{tolerance to use for convergence testing of eigenvalues. Error in eigenvalues will be less than the magnitude of the dominant eigenvalue multiplied by \code{tol} (or the machine precision!).} \item{nt}{number of threads to use for leading order iterative multiplication of A by vector. May show no speed improvement on two processor machine.} } \details{ If \code{kl} is non-negative, returns the highest \code{k} and lowest \code{kl} eigenvalues, with their corresponding eigenvectors. If \code{kl} is negative, returns the largest magnitude \code{k} eigenvalues, with corresponding eigenvectors. The routine implements Lanczos iteration with full re-orthogonalization as described in Demmel (1997). Lanczos iteraction iteratively constructs a tridiagonal matrix, the eigenvalues of which converge to the eigenvalues of \code{A}, as the iteration proceeds (most extreme first). Eigenvectors can also be computed. For small \code{k} and \code{kl} the approach is faster than computing the full symmetric eigendecompostion. The tridiagonal eigenproblems are handled using LAPACK. The implementation is not optimal: in particular the inner triadiagonal problems could be handled more efficiently, and there would be some savings to be made by not always returning eigenvectors. } \value{ A list with elements \code{values} (array of eigenvalues); \code{vectors} (matrix with eigenvectors in its columns); \code{iter} (number of iterations required). } \references{ Demmel, J. (1997) Applied Numerical Linear Algebra. SIAM } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{\code{\link{cyclic.p.spline}}} \examples{ require(mgcv) ## create some x's and knots... set.seed(1); n <- 700;A <- matrix(runif(n*n),n,n);A <- A+t(A) ## compare timings of slanczos and eigen system.time(er <- slanczos(A,10)) system.time(um <- eigen(A,symmetric=TRUE)) ## confirm values are the same... ind <- c(1:6,(n-3):n) range(er$values-um$values[ind]);range(abs(er$vectors)-abs(um$vectors[,ind])) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/smooth.terms.Rd0000755000176200001440000002516313073161526014730 0ustar liggesusers\name{smooth.terms} \alias{smooth.terms} \title{Smooth terms in GAM} \description{ Smooth terms are specified in a \code{\link{gam}} formula using \code{\link{s}}, \code{\link{te}}, \code{\link{ti}} and \code{\link{t2}} terms. Various smooth classes are available, for different modelling tasks, and users can add smooth classes (see \code{\link{user.defined.smooth}}). What defines a smooth class is the basis used to represent the smooth function and quadratic penalty (or multiple penalties) used to penalize the basis coefficients in order to control the degree of smoothness. Smooth classes are invoked directly by \code{s} terms, or as building blocks for tensor product smoothing via \code{te}, \code{ti} or \code{t2} terms (only smooth classes with single penalties can be used in tensor products). The smooths built into the \code{mgcv} package are all based one way or another on low rank versions of splines. For the full rank versions see Wahba (1990). Note that smooths can be used rather flexibly in \code{gam} models. In particular the linear predictor of the GAM can depend on (a discrete approximation to) any linear functional of a smooth term, using \code{by} variables and the `summation convention' explained in \code{\link{linear.functional.terms}}. The single penalty built in smooth classes are summarized as follows \describe{ \item{Thin plate regression splines}{\code{bs="tp"}. These are low rank isotropic smoothers of any number of covariates. By isotropic is meant that rotation of the covariate co-ordinate system will not change the result of smoothing. By low rank is meant that they have far fewer coefficients than there are data to smooth. They are reduced rank versions of the thin plate splines and use the thin plate spline penalty. They are the default smooth for \code{s} terms because there is a defined sense in which they are the optimal smoother of any given basis dimension/rank (Wood, 2003). Thin plate regression splines do not have `knots' (at least not in any conventional sense): a truncated eigen-decomposition is used to achieve the rank reduction. See \code{\link{tprs}} for further details. \code{bs="ts"} is as \code{"tp"} but with a modification to the smoothing penalty, so that the null space is also penalized slightly and the whole term can therefore be shrunk to zero.} \item{Duchon splines}{\code{bs="ds"}. These generalize thin plate splines. In particular, for any given number of covariates they allow lower orders of derivative in the penalty than thin plate splines (and hence a smaller null space). See \code{\link{Duchon.spline}} for further details. } \item{Cubic regression splines}{\code{bs="cr"}. These have a cubic spline basis defined by a modest sized set of knots spread evenly through the covariate values. They are penalized by the conventional intergrated square second derivative cubic spline penalty. For details see \code{\link{cubic.regression.spline}} and e.g. Wood (2006a). \code{bs="cs"} specifies a shrinkage version of \code{"cr"}. \code{bs="cc"} specifies a cyclic cubic regression splines (see \link{cyclic.cubic.spline}). i.e. a penalized cubic regression splines whose ends match, up to second derivative.} \item{Splines on the sphere}{\code{bs="sos"}. These are two dimensional splines on a sphere. Arguments are latitude and longitude, and they are the analogue of thin plate splines for the sphere. Useful for data sampled over a large portion of the globe, when isotropy is appropriate. See \code{\link{Spherical.Spline}} for details.} \item{P-splines}{\code{bs="ps"}. These are P-splines as proposed by Eilers and Marx (1996). They combine a B-spline basis, with a discrete penalty on the basis coefficients, and any sane combination of penalty and basis order is allowed. Although this penalty has no exact interpretation in terms of function shape, in the way that the derivative penalties do, P-splines perform almost as well as conventional splines in many standard applications, and can perform better in particular cases where it is advantageous to mix different orders of basis and penalty. \code{bs="cp"} gives a cyclic version of a P-spline (see \link{cyclic.p.spline}). } \item{Random effects}{\code{bs="re"}. These are parametric terms penalized by a ridge penalty (i.e. the identity matrix). When such a smooth has multiple arguments then it represents the parametric interaction of these arguments, with the coefficients penalized by a ridge penalty. The ridge penalty is equivalent to an assumption that the coefficients are i.i.d. normal random effects. See \code{\link{smooth.construct.re.smooth.spec}}.} \item{Markov Random Fields}{\code{bs="mrf"}. These are popular when space is split up into discrete contiguous geographic units (districts of a town, for example). In this case a simple smoothing penalty is constructed based on the neighbourhood structure of the geographic units. See \code{\link{mrf}} for details and an example.} \item{Gaussian process smooths}{\code{bs="gp"}. Gaussian process models with a variety of simple correlation functions can be represented as smooths. See \code{\link{gp.smooth}} for details.} \item{Soap film smooths}{\code{bs="so"} (actually not single penaltied, but \code{bs="sw"} and \code{bs="sf"} allows splitting into single penalty components for use in tensor product smoothing). These are finite area smoothers designed to smooth within complicated geographical boundaries, where the boundary matters (e.g. you do not want to smooth across boundary features). See \code{\link{soap}} for details.} } Broadly speaking the default penalized thin plate regression splines tend to give the best MSE performance, but they are slower to set up than the other bases. The knot based penalized cubic regression splines (with derivative based penalties) usually come next in MSE performance, with the P-splines doing just a little worse. However the P-splines are useful in non-standard situations. All the preceding classes (and any user defined smooths with single penalties) may be used as marginal bases for tensor product smooths specified via \code{\link{te}}, \code{\link{ti}} or \code{\link{t2}} terms. Tensor product smooths are smooth functions of several variables where the basis is built up from tensor products of bases for smooths of fewer (usually one) variable(s) (marginal bases). The multiple penalties for these smooths are produced automatically from the penalties of the marginal smooths. Wood (2006b) and Wood, Scheipl and Faraway (2012), give the general recipe for these constructions. \describe{ \item{te}{\code{te} smooths have one penalty per marginal basis, each of which is interpretable in a similar way to the marginal penalty from which it is derived. See Wood (2006b).} \item{ti}{\code{ti} smooths exclude the basis functions associated with the `main effects' of the marginal smooths, plus interactions other than the highest order specified. These provide a stable an interpretable way of specifying models with main effects and interactions. For example if we are interested in linear predicto \eqn{f_1(x)+f_2(z)+f_3(x,z)}{f1(x) + f2(z) + f3(x,z)}, we might use model formula \code{y~s(x)+s(z)+ti(x,z)} or \code{y~ti(x)+ti(z)+ti(x,z)}. A similar construction involving \code{te} terms instead will be much less statsitically stable.} \item{t2}{\code{t2} uses an alternative tensor product construction that results in more penalties each having a simple non-overlapping structure allowing use with the \code{gamm4} package. It is a natural generalization of the SS-ANOVA construction, but the penalties are a little harder to interpret. See Wood, Scheipl and Faraway (2012/13). } } Tensor product smooths often perform better than isotropic smooths when the covariates of a smooth are not naturally on the same scale, so that their relative scaling is arbitrary. For example, if smoothing with repect to time and distance, an isotropic smoother will give very different results if the units are cm and minutes compared to if the units are metres and seconds: a tensor product smooth will give the same answer in both cases (see \code{\link{te}} for an example of this). Note that \code{te} terms are knot based, and the thin plate splines seem to offer no advantage over cubic or P-splines as marginal bases. Some further specialist smoothers that are not suitable for use in tensor products are also available. \describe{ \item{Adaptive smoothers}{\code{bs="ad"} Univariate and bivariate adaptive smooths are available (see \code{\link{adaptive.smooth}}). These are appropriate when the degree of smoothing should itself vary with the covariates to be smoothed, and the data contain sufficient information to be able to estimate the appropriate variation. Because this flexibility is achieved by splitting the penalty into several `basis penalties' these terms are not suitable as components of tensor product smooths, and are not supported by \code{gamm}.} \item{Factor smooth interactions}{\code{bs="fs"} Smooth factor interactions are often produced using \code{by} variables (see \code{\link{gam.models}}), but a special smoother class (see \code{\link{factor.smooth.interaction}}) is available for the case in which a smooth is required at each of a large number of factor levels (for example a smooth for each patient in a study), and each smooth should have the same smoothing parameter. The \code{"fs"} smoothers are set up to be efficient when used with \code{\link{gamm}}, and have penalties on each null sapce component (i.e. they are fully `random effects'). } } } \seealso{\code{\link{s}}, \code{\link{te}}, \code{\link{t2}} \code{\link{tprs}},\code{\link{Duchon.spline}}, \code{\link{cubic.regression.spline}},\code{\link{p.spline}}, \code{\link{mrf}}, \code{\link{soap}}, \code{\link{Spherical.Spline}}, \code{\link{adaptive.smooth}}, \code{\link{user.defined.smooth}}, \code{\link{smooth.construct.re.smooth.spec}}, \code{\link{smooth.construct.gp.smooth.spec}},\code{\link{factor.smooth.interaction}}} \author{ Simon Wood } \references{ Eilers, P.H.C. and B.D. Marx (1996) Flexible Smoothing with B-splines and Penalties. Statistical Science, 11(2):89-121 Wahba (1990) Spline Models of Observational Data. SIAM Wood, S.N. (2003) Thin plate regression splines. J.R.Statist.Soc.B 65(1):95-114 Wood, S.N. (2006a) \emph{Generalized Additive Models: an introduction with R}, CRC Wood, S.N. (2006b) Low rank scale invariant tensor product smooths for generalized additive mixed models. Biometrics 62(4):1025-1036 Wood S.N., F. Scheipl and J.J. Faraway (2013) Straightforward intermediate rank tensor product smoothing in mixed models. Statistical Computing. 23(3), 341-360. [online 2012] } \examples{ ## see examples for gam and gamm } \keyword{regression}mgcv/man/vcov.gam.Rd0000755000176200001440000000367013073161526014005 0ustar liggesusers\name{vcov.gam} \alias{vcov.gam} %- Also NEED an `\alias' for EACH other topic documented here. \title{Extract parameter (estimator) covariance matrix from GAM fit} \description{ Extracts the Bayesian posterior covariance matrix of the parameters or frequentist covariance matrix of the parameter estimators from a fitted \code{gam} object. } \usage{ \method{vcov}{gam}(object, freq = FALSE, dispersion = NULL,unconditional=FALSE, ...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{ fitted model object of class \code{gam} as produced by \code{gam()}.} \item{freq}{ \code{TRUE} to return the frequentist covariance matrix of the parameter estimators, \code{FALSE} to return the Bayesian posterior covariance matrix of the parameters.} \item{dispersion}{ a value for the dispersion parameter: not normally used.} \item{unconditional}{ if \code{TRUE} (and \code{freq==FALSE}) then the Bayesian smoothing parameter uncertainty corrected covariance matrix is returned, if available. } \item{...}{ other arguments, currently ignored.} } \details{ Basically, just extracts \code{object$Ve} or \code{object$Vp} from a \code{\link{gamObject}}. } \value{ A matrix corresponding to the estimated frequentist covariance matrix of the model parameter estimators/coefficients, or the estimated posterior covariance matrix of the parameters, depending on the argument \code{freq}. } \author{ Henric Nilsson. Maintained by Simon N. Wood \email{simon.wood@r-project.org} } \references{ Wood, S.N. (2006) On confidence intervals for generalized additive models based on penalized regression splines. Australian and New Zealand Journal of Statistics. 48(4): 445-464. } \seealso{ \code{\link{gam}}} \examples{ require(mgcv) n <- 100 x <- runif(n) y <- sin(x*2*pi) + rnorm(n)*.2 mod <- gam(y~s(x,bs="cc",k=10),knots=list(x=seq(0,1,length=10))) diag(vcov(mod)) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/chol.down.Rd0000755000176200001440000000644113401471433014153 0ustar liggesusers\name{choldrop} \alias{choldrop} \alias{cholup} %- Also NEED an `\alias' for EACH other topic documented here. \title{Deletion and rank one Cholesky factor update} \description{Given a Cholesky factor, \code{R}, of a matrix, \code{A}, \code{choldrop} finds the Cholesky factor of \code{A[-k,-k]}, where \code{k} is an integer. \code{cholup} finds the factor of \eqn{A + uu^T}{A+uu'} (update) or \eqn{A - uu^T}{A-uu'} (downdate). } \usage{ choldrop(R,k) cholup(R,u,up) } %- maybe also `usage' for other objects documented here. \arguments{ \item{R}{Cholesky factor of a matrix, \code{A}.} \item{k}{row and column of \code{A} to drop.} \item{u}{vector defining rank one update.} \item{up}{if \code{TRUE} compute update, otherwise downdate.} } \details{First consider \code{choldrop}. If \code{R} is upper triangular then \code{t(R[,-k])\%*\%R[,-k] == A[-k,-k]}, but \code{R[,-k]} has elements on the first sub-diagonal, from its kth column onwards. To get from this to a triangular Cholesky factor of \code{A[-k,-k]} we can apply a sequence of Givens rotations from the left to eliminate the sub-diagonal elements. The routine does this. If \code{R} is a lower triangular factor then Givens rotations from the right are needed to remove the extra elements. If \code{n} is the dimension of \code{R} then the update has \eqn{O(n^2)}{O(n^2)} computational cost. \code{cholup} (which assumes \code{R} is upper triangular) updates based on the observation that \eqn{ R^TR + uu^T = [u,R^T][u,R^T]^T = [u,R^T]Q^TQ[u,R^T]^T}{R'R + uu' = [u,R'][u,R']' = [u,R']Q'Q[u,R']'}, and therefore we can construct \eqn{Q}{Q} so that \eqn{Q[u,R^T]^T=[0,R_1^T]^T}{Q[u,R']'=[0,R1']'}, where \eqn{R_1}{R1} is the modified factor. \eqn{Q}{Q} is constructed from a sequence of Givens rotations in order to zero the elements of \eqn{u}{u}. Downdating is similar except that hyperbolic rotations have to be used in place of Givens rotations --- see Golub and van Loan (2013, section 6.5.4) for details. Downdating only works if \eqn{A - uu^T}{A-uu'} is positive definite. Again the computational cost is \eqn{O(n^2)}{O(n^2)}. Note that the updates are vector oriented, and are hence not susceptible to speed up by use of an optimized BLAS. The updates are set up to be relatively Cache friendly, in that in the upper triangular case successive Givens rotations are stored for sequential application column-wise, rather than being applied row-wise as soon as they are computed. Even so, the upper triangular update is slightly slower than the lower triangular update. } \references{ Golub GH and CF Van Loan (2013) Matrix Computations (4th edition) Johns Hopkins } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \examples{ require(mgcv) set.seed(0) n <- 6 A <- crossprod(matrix(runif(n*n),n,n)) R0 <- chol(A) k <- 3 Rd <- choldrop(R0,k) range(Rd-chol(A[-k,-k])) Rd;chol(A[-k,-k]) ## same but using lower triangular factor A = LL' L <- t(R0) Ld <- choldrop(L,k) range(Ld-t(chol(A[-k,-k]))) Ld;t(chol(A[-k,-k])) ## Rank one update example u <- runif(n) R <- cholup(R0,u,TRUE) Ru <- chol(A+u \%*\% t(u)) ## direct for comparison R;Ru range(R-Ru) ## Downdate - just going back from R to R0 Rd <- cholup(R,u,FALSE) R0;Rd range(R-Ru) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/XWXd.Rd0000755000176200001440000000660113527756010013116 0ustar liggesusers\name{XWXd} \alias{XWXd} \alias{XWyd} \alias{Xbd} \alias{diagXVXd} %- Also NEED an `\alias' for EACH other topic documented here. \title{Internal functions for discretized model matrix handling} \description{Routines for computing with discretized model matrices as described in Wood et al. (2017) and Li and Wood (2019). } \usage{ XWXd(X,w,k,ks,ts,dt,v,qc,nthreads=1,drop=NULL,ar.stop=-1,ar.row=-1,ar.w=-1, lt=NULL,rt=NULL) XWyd(X,w,y,k,ks,ts,dt,v,qc,drop=NULL,ar.stop=-1,ar.row=-1,ar.w=-1,lt=NULL) Xbd(X,beta,k,ks,ts,dt,v,qc,drop=NULL,lt=NULL) diagXVXd(X,V,k,ks,ts,dt,v,qc,drop=NULL,nthreads=1,lt=NULL,rt=NULL) } %- maybe also `usage' for other objects documented here. \arguments{ \item{X}{A list of the matrices containing the unique rows of model matrices for terms of a full model matrix, or the model matrices of the terms margins. if term subsetting arguments \code{lt} and \code{rt} are non-NULL then this requires an \code{"lpip"} attribute: see details.} \item{w}{An n-vector of weights} \item{y}{n-vector of data.} \item{beta}{coefficient vector.} \item{k}{A matrix whose columns are index n-vectors each selecting the rows of an X[[i]] required to create the full matrix.} \item{ks}{The ith term has index vectors \code{ks[i,1]:(ks[i,2]-1)}. The corresponing full model matrices are summed over.} \item{ts}{The element of \code{X} at which each model term starts.} \item{dt}{How many elements of \code{X} contribute to each term.} \item{v}{\code{v[[i]]} is Householder vector for ith term, if \code{qc[i]>0}.} \item{qc}{if \code{qc[i]>0} then term has a constraint.} \item{nthreads}{number of threads to use} \item{drop}{list of columns of model matrix/parameters to drop} \item{ar.stop}{Negative to ignore. Otherwise sum rows \code{(ar.stop[i-1]+1):ar.stop[i]} of the rows selected by \code{ar.row} and weighted by \code{ar.w} to get ith row of model matrix to use.} \item{ar.row}{extract these rows...} \item{ar.w}{weight by these weights, and sum up according to \code{ar.stop}. Used to implement AR models.} \item{lt}{use only columns of X corresponding to these model matrix terms (for left hand \code{X} in \code{XWXd}).} \item{rt}{as \code{lt} for right hand \code{X}.} \item{V}{Coefficient covariance matrix.} } \details{These functions are really intended to be internal, but are exported so that they can be used in the initialization code of families without problem. They are primarily used by \code{\link{bam}} to implement the methods given in the references. \code{XWXd} produces \eqn{X^TWX}{X'WX}, \code{XWy} produces \eqn{X^TWy}{X'Wy}, \code{Xbd} produces \eqn{X\beta}{Xb} and \eqn{diagXVXd} produces the diagonal of \eqn{XVX^T}{XVX'}. The \code{"lpip"} attribute of \code{X} is a list of the coefficient indices for each term. Required if subsetting via \code{lt} and \code{rt}. } \references{ Wood, S.N., Li, Z., Shaddick, G. & Augustin N.H. (2017) Generalized additive models for gigadata: modelling the UK black smoke network daily data. Journal of the American Statistical Association. 112(519):1199-1210 \url{http://dx.doi.org/10.1080/01621459.2016.1195744} Li, Z & S.N. Wood (2019) Faster model matrix crossproducts for large generalized linear models with discretized covariates. Statistics and Computing. \url{https://doi.org/10.1007/s11222-019-09864-2} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/Rrank.Rd0000755000176200001440000000243613073161526013341 0ustar liggesusers\name{Rrank} \alias{Rrank} %- Also NEED an `\alias' for EACH other topic documented here. \title{Find rank of upper triangular matrix} \description{ Finds rank of upper triangular matrix R, by estimating condition number of upper \code{rank} by \code{rank} block, and reducing \code{rank} until this is acceptably low. Assumes R has been computed by a method that uses pivoting, usually pivoted QR or Choleski. } \usage{ Rrank(R,tol=.Machine$double.eps^.9) } %- maybe also `usage' for other objects documented here. \arguments{ \item{R}{An upper triangular matrix, obtained by pivoted QR or pivoted Choleski.} \item{tol}{the tolerance to use for judging rank.} } \details{ The method is based on Cline et al. (1979) as described in Golub and van Loan (1996). } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Cline, A.K., C.B. Moler, G.W. Stewart and J.H. Wilkinson (1979) An estimate for the condition number of a matrix. SIAM J. Num. Anal. 16, 368-375 Golub, G.H, and C.F. van Loan (1996) Matrix Computations 3rd ed. Johns Hopkins University Press, Baltimore. } \examples{ set.seed(0) n <- 10;p <- 5 X <- matrix(runif(n*(p-1)),n,p) qrx <- qr(X,LAPACK=TRUE) Rrank(qr.R(qrx)) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/gammals.Rd0000755000176200001440000000633713460052514013705 0ustar liggesusers\name{gammals} \alias{gammals} %- Also NEED an `\alias' for EACH other topic documented here. \title{Gamma location-scale model family} \description{The \code{gammals} family implements gamma location scale additive models in which the log of the mean and the log of the scale parameter (see details) can depend on additive smooth predictors. Useable only with \code{\link{gam}}, the linear predictors are specified via a list of formulae. } \usage{ gammals(link=list("identity","log"),b=-7) } \arguments{ \item{link}{two item list specifying the link for the mean and the standard deviation. See details for meaning which may not be intuitive.} \item{b}{The minumum log scale parameter.} } \value{ An object inheriting from class \code{general.family}. } \details{Used with \code{\link{gam}} to fit gamma location - scale models parameterized in terms of the log mean and the log scale parameter (the response variance is the mean multiplied by the scale parameter). Note that \code{identity} links mean that the linear predictors give the log mean and scale directly. By default the \code{log} link for the scale parameter simply forces the log scale parameter to have a lower limit given by argument \code{b}: if \eqn{\eta}{l} is the linear predictor for the log scale parameter, \eqn{\phi}{s}, then \eqn{\log \phi = b + \log(1+e^\eta)}{log(s) = b + log(1+e^l)}. \code{gam} is called with a list containing 2 formulae, the first specifies the response on the left hand side and the structure of the linear predictor for the log mean on the right hand side. The second is one sided, specifying the linear predictor for the log sscale on the right hand side. The fitted values for this family will be a two column matrix. The first column is the mean (on origianl, not log, scale), and the second column is the log scale. Predictions using \code{\link{predict.gam}} will also produce 2 column matrices for \code{type} \code{"link"} and \code{"response"}. The first column is on the original data scale when \code{type="response"} and on the log mean scale of the linear predictor when \code{type="link"}. The second column when \code{type="response"} is again the log scale parameter, but is on the linear predictor when \code{type="link"}. The null deviance reported for this family computed by setting the fitted values to the mean response, but using the model estimated scale. } \references{ Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association 111, 1548-1575 \url{http://dx.doi.org/10.1080/01621459.2016.1180986} } \examples{ library(mgcv) ## simulate some data f0 <- function(x) 2 * sin(pi * x) f1 <- function(x) exp(2 * x) f2 <- function(x) 0.2 * x^11 * (10 * (1 - x))^6 + 10 * (10 * x)^3 * (1 - x)^10 f3 <- function(x) 0 * x n <- 400;set.seed(9) x0 <- runif(n);x1 <- runif(n); x2 <- runif(n);x3 <- runif(n); mu <- exp((f0(x0)+f2(x2))/5) th <- exp(f1(x1)/2-2) y <- rgamma(n,shape=1/th,scale=mu*th) b1 <- gam(list(y~s(x0)+s(x2),~s(x1)+s(x3)),family=gammals) plot(b1,pages=1) summary(b1) gam.check(b1) plot(mu,fitted(b1)[,1]);abline(0,1,col=2) plot(log(th),fitted(b1)[,2]);abline(0,1,col=2) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/te.Rd0000755000176200001440000003051313303547337012675 0ustar liggesusers\name{te} \alias{te}\alias{ti} %- Also NEED an `\alias' for EACH other topic documented here. \title{Define tensor product smooths or tensor product interactions in GAM formulae} \description{ Functions used for the definition of tensor product smooths and interactions within \code{gam} model formulae. \code{te} produces a full tensor product smooth, while \code{ti} produces a tensor product interaction, appropriate when the main effects (and any lower interactions) are also present. The functions do not evaluate the smooth - they exists purely to help set up a model using tensor product based smooths. Designed to construct tensor products from any marginal smooths with a basis-penalty representation (with the restriction that each marginal smooth must have only one penalty). } \usage{te(..., k=NA,bs="cr",m=NA,d=NA,by=NA,fx=FALSE, np=TRUE,xt=NULL,id=NULL,sp=NULL,pc=NULL) ti(..., k=NA,bs="cr",m=NA,d=NA,by=NA,fx=FALSE, np=TRUE,xt=NULL,id=NULL,sp=NULL,mc=NULL,pc=NULL) } %- maybe also `usage' for other objects documented here. \arguments{ \item{...}{ a list of variables that are the covariates that this smooth is a function of. Transformations whose form depends on the values of the data are best avoided here: e.g. \code{te(log(x),z)} is fine, but \code{te(I(x/sd(x)),z)} is not (see \code{\link{predict.gam}}). } \item{k}{ the dimension(s) of the bases used to represent the smooth term. If not supplied then set to \code{5^d}. If supplied as a single number then this basis dimension is used for each basis. If supplied as an array then the elements are the dimensions of the component (marginal) bases of the tensor product. See \code{\link{choose.k}} for further information.} \item{bs}{array (or single character string) specifying the type for each marginal basis. \code{"cr"} for cubic regression spline; \code{"cs"} for cubic regression spline with shrinkage; \code{"cc"} for periodic/cyclic cubic regression spline; \code{"tp"} for thin plate regression spline; \code{"ts"} for t.p.r.s. with extra shrinkage. See \code{\link{smooth.terms}} for details and full list. User defined bases can also be used here (see \code{\link{smooth.construct}} for an example). If only one basis code is given then this is used for all bases.} \item{m}{The order of the spline and its penalty (for smooth classes that use this) for each term. If a single number is given then it is used for all terms. A vector can be used to supply a different \code{m} for each margin. For marginals that take vector \code{m} (e.g. \code{\link{p.spline}} and \code{\link{Duchon.spline}}), then a list can be supplied, with a vector element for each margin. \code{NA} autoinitializes. \code{m} is ignored by some bases (e.g. \code{"cr"}).} \item{d}{array of marginal basis dimensions. For example if you want a smooth for 3 covariates made up of a tensor product of a 2 dimensional t.p.r.s. basis and a 1-dimensional basis, then set \code{d=c(2,1)}. Incompatibilities between built in basis types and dimension will be resolved by resetting the basis type.} \item{by}{a numeric or factor variable of the same dimension as each covariate. In the numeric vector case the elements multiply the smooth evaluated at the corresponding covariate values (a `varying coefficient model' results). In the factor case causes a replicate of the smooth to be produced for each factor level. See \code{\link{gam.models}} for further details. May also be a matrix if covariates are matrices: in this case implements linear functional of a smooth (see \code{\link{gam.models}} and \code{\link{linear.functional.terms}} for details).} \item{fx}{indicates whether the term is a fixed d.f. regression spline (\code{TRUE}) or a penalized regression spline (\code{FALSE}).} \item{np}{ \code{TRUE} to use the `normal parameterization' for a tensor product smooth. This represents any 1-d marginal smooths via parameters that are function values at `knots', spread evenly through the data. The parameterization makes the penalties easily interpretable, however it can reduce numerical stability in some cases.} \item{xt}{Either a single object, providing any extra information to be passed to each marginal basis constructor, or a list of such objects, one for each marginal basis. } \item{id}{A label or integer identifying this term in order to link its smoothing parameters to others of the same type. If two or more smooth terms have the same \code{id} then they will have the same smoothing paramsters, and, by default, the same bases (first occurance defines basis type, but data from all terms used in basis construction).} \item{sp}{any supplied smoothing parameters for this term. Must be an array of the same length as the number of penalties for this smooth. Positive or zero elements are taken as fixed smoothing parameters. Negative elements signal auto-initialization. Over-rides values supplied in \code{sp} argument to \code{\link{gam}}. Ignored by \code{gamm}.} \item{mc}{For \code{ti} smooths you can specify which marginals should have centering constraints applied, by supplying 0/1 or \code{FALSE}/\code{TRUE} values for each marginal in this vector. By default all marginals are constrained, which is what is appropriate for, e.g., functional ANOVA models. Note that \code{'ti'} only applies constraints to the marginals, so if you turn off all marginal constraints the term will have no identifiability constraints. Only use this if you really understand how marginal constraints work. } \item{pc}{If not \code{NULL}, signals a point constraint: the smooth should pass through zero at the point given here (as a vector or list with names corresponding to the smooth names). Never ignored if supplied. See \code{\link{identifiability}}. } } \details{ Smooths of several covariates can be constructed from tensor products of the bases used to represent smooths of one (or sometimes more) of the covariates. To do this `marginal' bases are produced with associated model matrices and penalty matrices, and these are then combined in the manner described in \code{\link{tensor.prod.model.matrix}} and \code{\link{tensor.prod.penalties}}, to produce a single model matrix for the smooth, but multiple penalties (one for each marginal basis). The basis dimension of the whole smooth is the product of the basis dimensions of the marginal smooths. An option for operating with a single penalty (The Kronecker product of the marginal penalties) is provided, but it is rarely of practical use, and is deprecated: the penalty is typically so rank deficient that even the smoothest resulting model will have rather high estimated degrees of freedom. Tensor product smooths are especially useful for representing functions of covariates measured in different units, although they are typically not quite as nicely behaved as t.p.r.s. smooths for well scaled covariates. It is sometimes useful to investigate smooth models with a main-effects + interactions structure, for example \deqn{f_1(x) + f_2(z) + f_3(x,z)}{f_1(x) + f_2(z) + f_3(x,z)} This functional ANOVA decomposition is supported by \code{ti} terms, which produce tensor product interactions from which the main effects have been excluded, under the assumption that they will be included separately. For example the \code{~ ti(x) + ti(z) + ti(x,z)} would produce the above main effects + interaction structure. This is much better than attempting the same thing with \code{s}or \code{te} terms representing the interactions (although mgcv does not forbid it). Technically \code{ti} terms are very simple: they simply construct tensor product bases from marginal smooths to which identifiability constraints (usually sum-to-zero) have already been applied: correct nesting is then automatic (as with all interactions in a GLM framework). See Wood (2017, section 5.6.3). The `normal parameterization' (\code{np=TRUE}) re-parameterizes the marginal smooths of a tensor product smooth so that the parameters are function values at a set of points spread evenly through the range of values of the covariate of the smooth. This means that the penalty of the tensor product associated with any particular covariate direction can be interpreted as the penalty of the appropriate marginal smooth applied in that direction and averaged over the smooth. Currently this is only done for marginals of a single variable. This parameterization can reduce numerical stability when used with marginal smooths other than \code{"cc"}, \code{"cr"} and \code{"cs"}: if this causes problems, set \code{np=FALSE}. Note that tensor product smooths should not be centred (have identifiability constraints imposed) if any marginals would not need centering. The constructor for tensor product smooths ensures that this happens. The function does not evaluate the variable arguments. } \value{ A class \code{tensor.smooth.spec} object defining a tensor product smooth to be turned into a basis and penalties by the \code{smooth.construct.tensor.smooth.spec} function. The returned object contains the following items: \item{margin}{A list of \code{smooth.spec} objects of the type returned by \code{\link{s}}, defining the basis from which the tensor product smooth is constructed.} \item{term}{An array of text strings giving the names of the covariates that the term is a function of.} \item{by}{is the name of any \code{by} variable as text (\code{"NA"} for none).} \item{fx}{ logical array with element for each penalty of the term (tensor product smooths have multiple penalties). \code{TRUE} if the penalty is to be ignored, \code{FALSE}, otherwise. } \item{label}{A suitable text label for this smooth term.} \item{dim}{The dimension of the smoother - i.e. the number of covariates that it is a function of.} \item{mp}{\code{TRUE} is multiple penalties are to be used (default).} \item{np}{\code{TRUE} to re-parameterize 1-D marginal smooths in terms of function values (defualt).} \item{id}{the \code{id} argument supplied to \code{te}.} \item{sp}{the \code{sp} argument supplied to \code{te}.} \item{inter}{\code{TRUE} if the term was generated by \code{ti}, \code{FALSE} otherwise.} \item{mc}{the argument \code{mc} supplied to \code{ti}.} } \author{ Simon N. Wood \email{simon.wood@r-project.org}} \references{ Wood, S.N. (2006) Low rank scale invariant tensor product smooths for generalized additive mixed models. Biometrics 62(4):1025-1036 Wood S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC Press. \url{http://www.maths.bris.ac.uk/~sw15190/} } \seealso{ \code{\link{s}},\code{\link{gam}},\code{\link{gamm}}, \code{\link{smooth.construct.tensor.smooth.spec}}} \examples{ # following shows how tensor pruduct deals nicely with # badly scaled covariates (range of x 5\% of range of z ) require(mgcv) test1 <- function(x,z,sx=0.3,sz=0.4) { x <- x*20 (pi**sx*sz)*(1.2*exp(-(x-0.2)^2/sx^2-(z-0.3)^2/sz^2)+ 0.8*exp(-(x-0.7)^2/sx^2-(z-0.8)^2/sz^2)) } n <- 500 old.par <- par(mfrow=c(2,2)) x <- runif(n)/20;z <- runif(n); xs <- seq(0,1,length=30)/20;zs <- seq(0,1,length=30) pr <- data.frame(x=rep(xs,30),z=rep(zs,rep(30,30))) truth <- matrix(test1(pr$x,pr$z),30,30) f <- test1(x,z) y <- f + rnorm(n)*0.2 b1 <- gam(y~s(x,z)) persp(xs,zs,truth);title("truth") vis.gam(b1);title("t.p.r.s") b2 <- gam(y~te(x,z)) vis.gam(b2);title("tensor product") b3 <- gam(y~ ti(x) + ti(z) + ti(x,z)) vis.gam(b3);title("tensor anova") ## now illustrate partial ANOVA decomp... vis.gam(b3);title("full anova") b4 <- gam(y~ ti(x) + ti(x,z,mc=c(0,1))) ## note z constrained! vis.gam(b4);title("partial anova") plot(b4) par(old.par) ## now with a multivariate marginal.... test2<-function(u,v,w,sv=0.3,sw=0.4) { ((pi**sv*sw)*(1.2*exp(-(v-0.2)^2/sv^2-(w-0.3)^2/sw^2)+ 0.8*exp(-(v-0.7)^2/sv^2-(w-0.8)^2/sw^2)))*(u-0.5)^2*20 } n <- 500 v <- runif(n);w<-runif(n);u<-runif(n) f <- test2(u,v,w) y <- f + rnorm(n)*0.2 # tensor product of 2D Duchon spline and 1D cr spline m <- list(c(1,.5),rep(0,0)) ## example of list form of m b <- gam(y~te(v,w,u,k=c(30,5),d=c(2,1),bs=c("ds","cr"),m=m)) op <- par(mfrow=c(2,2)) vis.gam(b,cond=list(u=0),color="heat",zlim=c(-0.2,3.5)) vis.gam(b,cond=list(u=.33),color="heat",zlim=c(-0.2,3.5)) vis.gam(b,cond=list(u=.67),color="heat",zlim=c(-0.2,3.5)) vis.gam(b,cond=list(u=1),color="heat",zlim=c(-0.2,3.5)) par(op) } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/identifiability.Rd0000755000176200001440000000444613073161526015440 0ustar liggesusers\name{identifiability} \alias{identifiability} %- Also NEED an `\alias' for EACH other topic documented here. \title{Identifiability constraints} \description{Smooth terms are generally only identifiable up to an additive constant. In consequence sum-to-zero identifiability constraints are imposed on most smooth terms. The exceptions are terms with \code{by} variables which cause the smooth to be identifiable without constraint (that doesn't include factor \code{by} variables), and random effect terms. Alternatively smooths can be set up to pass through zero at a user specified point. } \details{ By default each smooth term is subject to the sum-to-zero constraint \deqn{\sum_i f(x_i) = 0.}{sum_i f(x_i) = 0.} The constraint is imposed by reparameterization. The sum-to-zero constraint causes the term to be orthogonal to the intercept: alternative constraints lead to wider confidence bands for the constrained smooth terms. No constraint is used for random effect terms, since the penalty (random effect covariance matrix) anyway ensures identifiability in this case. Also if a \code{by} variable means that the smooth is anyway identifiable, then no extra constraint is imposed. Constraints are imposed for factor \code{by} variables, so that the main effect of the factor must usually be explicitly added to the model (the example below is an exception). Occasionally it is desirable to substitute the constraint that a particular smooth curve should pass through zero at a particular point: the \code{pc} argument to \code{\link{s}}, \code{\link{te}}, \code{\link{ti}} and \code{\link{t2}} allows this: if specified then such constraints are always applied. } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood (s.wood@r-project.org) } \examples{ ## Example of three groups, each with a different smooth dependence on x ## but each starting at the same value... require(mgcv) set.seed(53) n <- 100;x <- runif(3*n);z <- runif(3*n) fac <- factor(rep(c("a","b","c"),each=100)) y <- c(sin(x[1:100]*4),exp(3*x[101:200])/10-.1,exp(-10*(x[201:300]-.5))/ (1+exp(-10*(x[201:300]-.5)))-0.9933071) + z*(1-z)*5 + rnorm(100)*.4 ## 'pc' used to constrain smooths to 0 at x=0... b <- gam(y~s(x,by=fac,pc=0)+s(z)) plot(b,pages=1) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/scat.Rd0000755000176200001440000000420013303547337013211 0ustar liggesusers\name{scat} \alias{scat} \alias{t.scaled} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM scaled t family for heavy tailed data} \description{Family for use with \code{\link{gam}} or \code{\link{bam}}, implementing regression for the heavy tailed response variables, y, using a scaled t model. The idea is that \eqn{(y-\mu)/\sigma \sim t_\nu }{(y - mu)/sig ~ t_nu} where \eqn{mu}{mu} is determined by a linear predictor, while \eqn{\sigma}{sig} and \eqn{\nu}{nu} are parameters to be estimated alongside the smoothing parameters. } \usage{ scat(theta = NULL, link = "identity",min.df=3) } \arguments{ \item{theta}{the parameters to be estimated \eqn{\nu = b + \exp(\theta_1)}{nu = b + exp(theta_1) } (where `b' is \code{min.df}) and \eqn{\sigma = \exp(\theta_2)}{sig = exp(theta_2)}. If supplied and both positive, then taken to be fixed values of \eqn{\nu}{nu} and \eqn{\sigma}{sig}. If any negative, then absolute values taken as starting values. } \item{link}{The link function: one of \code{"identity"}, \code{"log"} or \code{"inverse"}.} \item{min.df}{minimum degrees of freedom. Should not be set to 2 or less as this implies infinite response variance.} } \value{ An object of class \code{extended.family}. } \details{Useful in place of Gaussian, when data are heavy tailed. \code{min.df} can be modified, but lower values can occasionally lead to convergence problems in smoothing parameter estimation. In any case \code{min.df} should be >2, since only then does a t random variable have finite variance. } %- maybe also `usage' for other objects documented here. \author{ Natalya Pya (nat.pya@gmail.com) } \references{ Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association 111, 1548-1575 \url{http://dx.doi.org/10.1080/01621459.2016.1180986} } \examples{ library(mgcv) ## Simulate some t data... set.seed(3);n<-400 dat <- gamSim(1,n=n) dat$y <- dat$f + rt(n,df=4)*2 b <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=scat(link="identity"),data=dat) b plot(b,pages=1) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/spasm.construct.Rd0000755000176200001440000000217313073161526015430 0ustar liggesusers \name{spasm.construct} \alias{spasm.construct} \alias{spasm.sp} \alias{spasm.smooth} %- Also NEED an `\alias' for EACH other topic documented here. \title{Experimental sparse smoothers} \description{These are experimental sparse smoothing functions, and should be left well alone! } \usage{ spasm.construct(object,data) spasm.sp(object,sp,w=rep(1,object$nobs),get.trH=TRUE,block=0,centre=FALSE) spasm.smooth(object,X,residual=FALSE,block=0) } %- maybe also `usage' for other objects documented here. \arguments{ \item{object}{sparse smooth object} \item{data}{data frame} \item{sp}{smoothing parameter value} \item{w}{optional weights} \item{get.trH}{Should (estimated) trace of sparse smoother matrix be returned} \item{block}{index of block, 0 for all blocks} \item{centre}{should sparse smooth be centred?} \item{X}{what to smooth} \item{residual}{apply residual operation?} } %\value{} %\details{} %\references{} \author{Simon N. Wood \email{simon.wood@r-project.org}} %\seealso{} \section{WARNING}{It is not recommended to use these yet} %\examples{} \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more ... mgcv/man/gamSim.Rd0000755000176200001440000000321113443120347013466 0ustar liggesusers\name{gamSim} \alias{gamSim} %- Also NEED an `\alias' for EACH other topic documented here. \title{Simulate example data for GAMs} \description{ Function used to simulate data sets to illustrate the use of \code{\link{gam}} and \code{\link{gamm}}. Mostly used in help files to keep down the length of the example code sections. } \usage{gamSim(eg=1,n=400,dist="normal",scale=2,verbose=TRUE)} %- maybe also `usage' for other objects documented here. \arguments{ \item{eg}{ numeric value specifying the example required.} \item{n}{ number of data to simulate.} \item{dist}{character string which may be used to specify the distribution of the response.} \item{scale}{Used to set noise level.} \item{verbose}{Should information about simulation type be printed?} } \details{See the source code for exactly what is simulated in each case. \enumerate{ \item{Gu and Wahba 4 univariate term example.} \item{A smooth function of 2 variables.} \item{Example with continuous by variable.} \item{Example with factor by variable.} \item{An additive example plus a factor variable.} \item{Additive + random effect.} \item{As 1 but with correlated covariates.} } } \value{ Depends on \code{eg}, but usually a dataframe, which may also contain some information on the underlying truth. Sometimes a list with more items, including a data frame for model fitting. See source code or helpfile examples where the function is used for further information.} \author{ Simon N. Wood \email{simon.wood@r-project.org}} \seealso{ \code{\link{gam}}, \code{\link{gamm}}} \examples{ ## see ?gam } \keyword{models} \keyword{smooth} \keyword{regression}%-- one or more .. mgcv/man/twlss.Rd0000755000176200001440000000707313425365105013442 0ustar liggesusers\name{twlss} \alias{twlss} %- Also NEED an `\alias' for EACH other topic documented here. \title{Tweedie location scale family} \description{Tweedie family in which the mean, power and scale parameters can all depend on smooth linear predictors. Restricted to estimation via the extended Fellner Schall method of Wood and Fasiolo (2017). Only usable with \code{\link{gam}}. Tweedie distributions are exponential family with variance given by \eqn{\phi \mu^p}{s*m^p} where \eqn{\phi}{s} is a scale parameter, \eqn{p}{p} a parameter (here between 1 and 2) and \eqn{\mu}{m} is the mean. } \usage{ twlss(link=list("log","identity","identity"),a=1.01,b=1.99) } \arguments{ \item{link}{The link function list: currently no choise.} \item{a}{lower limit on the power parameter relating variance to mean.} \item{b}{upper limit on power parameter.} } \value{ An object inheriting from class \code{general.family}. } \details{ A Tweedie random variable with 10}{y>0} is given by the truncated Poisson probability function \eqn{p\mu^y/((\exp(\mu)-1)y!)}{(pmu^y/((exp(mu)-1)y!)}. The linear predictor gives \eqn{\log \mu}{log(mu)}, while \eqn{\eta = \log(-\log(1-p)) }{eta=log(-log(1-p))} and \eqn{\eta = \theta_1 + \{b+\exp(\theta_2)\} \log \mu }{eta = theta_1 + (b+exp(theta_2)) log(mu)}. The \code{theta} parameters are estimated alongside the smoothing parameters. Increasing the \code{b} parameter from zero can greatly reduce identifiability problems, particularly when there are very few non-zero data. The fitted values for this model are the log of the Poisson parameter. Use the \code{predict} function with \code{type=="response"} to get the predicted expected response. Note that the theta parameters reported in model summaries are \eqn{\theta_1}{theta_1} and \eqn{b + \exp(\theta_2)}{b + exp(theta_2)}. These models should be subject to very careful checking, especially if fitting has not converged. It is quite easy to set up models with identifiability problems, particularly if the data are not really zero inflated, but simply have many zeroes because the mean is very low in some parts of the covariate space. See example for some obvious checks. Take convergence warnings seriously. } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood \email{simon.wood@r-project.org} } \section{WARNINGS }{ Zero inflated models are often over-used. Having lots of zeroes in the data does not in itself imply zero inflation. Having too many zeroes *given the model mean* may imply zero inflation. } \references{ Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association 111, 1548-1575 \url{http://dx.doi.org/10.1080/01621459.2016.1180986} } \seealso{\code{\link{ziplss}}} \examples{ rzip <- function(gamma,theta= c(-2,.3)) { ## generate zero inflated Poisson random variables, where ## lambda = exp(gamma), eta = theta[1] + exp(theta[2])*gamma ## and 1-p = exp(-exp(eta)). y <- gamma; n <- length(y) lambda <- exp(gamma) eta <- theta[1] + exp(theta[2])*gamma p <- 1- exp(-exp(eta)) ind <- p > runif(n) y[!ind] <- 0 np <- sum(ind) ## generate from zero truncated Poisson, given presence... y[ind] <- qpois(runif(np,dpois(0,lambda[ind]),1),lambda[ind]) y } library(mgcv) ## Simulate some ziP data... set.seed(1);n<-400 dat <- gamSim(1,n=n) dat$y <- rzip(dat$f/4-1) b <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=ziP(),data=dat) b$outer.info ## check convergence!! b plot(b,pages=1) plot(b,pages=1,unconditional=TRUE) ## add s.p. uncertainty gam.check(b) ## more checking... ## 1. If the zero inflation rate becomes decoupled from the linear predictor, ## it is possible for the linear predictor to be almost unbounded in regions ## containing many zeroes. So examine if the range of predicted values ## is sane for the zero cases? range(predict(b,type="response")[b$y==0]) ## 2. Further plots... par(mfrow=c(2,2)) plot(predict(b,type="response"),residuals(b)) plot(predict(b,type="response"),b$y);abline(0,1,col=2) plot(b$linear.predictors,b$y) qq.gam(b,rep=20,level=1) ## 3. Refit fixing the theta parameters at their estimated values, to check we ## get essentially the same fit... thb <- b$family$getTheta() b0 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=ziP(theta=thb),data=dat) b;b0 ## Example fit forcing minimum linkage of prob present and ## linear predictor. Can fix some identifiability problems. b2 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=ziP(b=.3),data=dat) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/bug.reports.mgcv.Rd0000755000176200001440000000255413073161526015472 0ustar liggesusers\name{bug.reports.mgcv} \alias{bug.reports.mgcv} %- Also NEED an `\alias' for EACH other topic documented here. \title{Reporting mgcv bugs.} \description{\code{mgcv} works largely because many people have reported bugs over the years. If you find something that looks like a bug, please report it, so that the package can be improved. \code{mgcv} does not have a large development budget, so it is a big help if bug reports follow the following guidelines. The ideal report consists of an email to \email{simon.wood@r-project.org} with a subject line including \code{mgcv} somewhere, containing \enumerate{ \item The results of running \code{\link{sessionInfo}} in the R session where the problem occurs. This provides platform details, R and package version numbers, etc. \item A brief description of the problem. \item Short cut and paste-able code that produces the problem, including the code for loading/generating the data (using standard R functions like \code{load}, \code{read.table} etc). \item Any required data files. If you send real data it will only be used for the purposes of de-bugging. } Of course if you have dug deeper and have an idea of what is causing the problem, that is also helpful to know, as is any suggested code fix. (Don't send a fixed package .tar.gz file, however - I can't use this). } \author{ Simon N. Wood \email{simon.wood@r-project.org}} mgcv/man/multinom.Rd0000755000176200001440000000631713073161526014132 0ustar liggesusers\name{multinom} \alias{multinom} %- Also NEED an `\alias' for EACH other topic documented here. \title{GAM multinomial logistic regression} \description{Family for use with \code{\link{gam}}, implementing regression for categorical response data. Categories must be coded 0 to K, where K is a positive integer. \code{\link{gam}} should be called with a list of K formulae, one for each category except category zero (extra formulae for shared terms may also be supplied: see \code{\link{formula.gam}}). The first formula also specifies the response variable. } \usage{ multinom(K=1) } \arguments{ \item{K}{There are K+1 categories and K linear predictors. } } \value{ An object of class \code{general.family}. } \details{ The model has K linear predictors, \eqn{\eta_j}{h_j}, each dependent on smooth functions of predictor variables, in the usual way. If response variable, y, contains the class labels 0,...,K then the likelihood for y>0 is \eqn{\exp(\eta_y)/\{1+\sum_j \exp(\eta_j) \}}{exp(h_y)/(1 + sum_j exp(h_j) )}. If y=0 the likelihood is \eqn{1/\{1+\sum_j \exp(\eta_j) \}}{1/(1 + sum_j exp(h_j) )}. In the two class case this is just a binary logistic regression model. The implementation uses the approach to GAMLSS models described in Wood, Pya and Saefken (2016). The residuals returned for this model are simply the square root of -2 times the deviance for each observation, with a positive sign if the observed y is the most probable class for this observation, and a negative sign otherwise. Use \code{predict} with \code{type="response"} to get the predicted probabilities in each category. Note that the model is not completely invariant to category relabelling, even if all linear predictors have the same form. Realistically this model is unlikely to be suitable for problems with large numbers of categories. Missing categories are not supported. } %- maybe also `usage' for other objects documented here. \author{ Simon N. Wood \email{simon.wood@r-project.org} } \references{ Wood, S.N., N. Pya and B. Saefken (2016), Smoothing parameter and model selection for general smooth models. Journal of the American Statistical Association 111, 1548-1575 \url{http://dx.doi.org/10.1080/01621459.2016.1180986} } \seealso{\code{\link{ocat}}} \examples{ library(mgcv) set.seed(6) ## simulate some data from a three class model n <- 1000 f1 <- function(x) sin(3*pi*x)*exp(-x) f2 <- function(x) x^3 f3 <- function(x) .5*exp(-x^2)-.2 f4 <- function(x) 1 x1 <- runif(n);x2 <- runif(n) eta1 <- 2*(f1(x1) + f2(x2))-.5 eta2 <- 2*(f3(x1) + f4(x2))-1 p <- exp(cbind(0,eta1,eta2)) p <- p/rowSums(p) ## prob. of each category cp <- t(apply(p,1,cumsum)) ## cumulative prob. ## simulate multinomial response with these probabilities ## see also ?rmultinom y <- apply(cp,1,function(x) min(which(x>runif(1))))-1 ## plot simulated data... plot(x1,x2,col=y+3) ## now fit the model... b <- gam(list(y~s(x1)+s(x2),~s(x1)+s(x2)),family=multinom(K=2)) plot(b,pages=1) gam.check(b) ## now a simple classification plot... expand.grid(x1=seq(0,1,length=40),x2=seq(0,1,length=40)) -> gr pp <- predict(b,newdata=gr,type="response") pc <- apply(pp,1,function(x) which(max(x)==x)[1])-1 plot(gr,col=pc+3,pch=19) } \keyword{models} \keyword{regression}%-- one or more .. mgcv/man/null.space.dimension.Rd0000755000176200001440000000364513073161526016317 0ustar liggesusers\name{null.space.dimension} \alias{null.space.dimension} %- Also NEED an `\alias' for EACH other topic documented here. \title{The basis of the space of un-penalized functions for a TPRS} \description{ The thin plate spline penalties give zero penalty to some functions. The space of these functions is spanned by a set of polynomial terms. \code{null.space.dimension} finds the dimension of this space, \eqn{M}{M}, given the number of covariates that the smoother is a function of, \eqn{d}{d}, and the order of the smoothing penalty, \eqn{m}{m}. If \eqn{m}{m} does not satisfy \eqn{2m>d}{2m>d} then the smallest possible dimension for the null space is found given \eqn{d}{d} and the requirement that the smooth should be visually smooth. } \usage{ null.space.dimension(d,m) } %- maybe also `usage' for other objects documented here. \arguments{ \item{d}{ is a positive integer - the number of variables of which the t.p.s. is a function. } \item{m}{ a non-negative integer giving the order of the penalty functional, or signalling that the default order should be used.} } \details{ Thin plate splines are only visually smooth if the order of the wiggliness penalty, \eqn{m}{m}, satisfies \eqn{2m > d+1}{2m > d+1}. If \eqn{2m Maintainer: Simon Wood Title: Mixed GAM Computation Vehicle with Automatic Smoothness Estimation Description: Generalized additive (mixed) models, some of their extensions and other generalized ridge regression with multiple smoothing parameter estimation by (Restricted) Marginal Likelihood, Generalized Cross Validation and similar, or using iterated nested Laplace approximation for fully Bayesian inference. See Wood (2017) for an overview. Includes a gam() function, a wide variety of smoothers, 'JAGS' support and distributions beyond the exponential family. Priority: recommended Depends: R (>= 2.14.0), nlme (>= 3.1-64) Imports: methods, stats, graphics, Matrix, splines, utils Suggests: parallel, survival, MASS LazyLoad: yes ByteCompile: yes License: GPL (>= 2) NeedsCompilation: yes Packaged: 2019-11-08 21:21:15 UTC; sw283 Repository: CRAN Date/Publication: 2019-11-09 05:30:11 UTC mgcv/tests/0000755000176200001440000000000013416106250012346 5ustar liggesusersmgcv/tests/coxpht.R0000644000176200001440000000576313416106250014011 0ustar liggesusers## coxpht donttest case require(mgcv);require(survival) ## First define functions for producing Poisson model data frame app <- function(x,t,to) { ## wrapper to approx for calling from apply... y <- if (sum(!is.na(x))<1) rep(NA,length(to)) else approx(t,x,to,method="constant",rule=2)$y if (is.factor(x)) factor(levels(x)[y],levels=levels(x)) else y } ## app tdpois <- function(dat,event="z",et="futime",t="day",status="status1", id="id") { ## dat is data frame. id is patient id; et is event time; t is ## observation time; status is 1 for death 0 otherwise; ## event is name for Poisson response. if (event %in% names(dat)) warning("event name in use") require(utils) ## for progress bar te <- sort(unique(dat[[et]][dat[[status]]==1])) ## event times sid <- unique(dat[[id]]) inter <- interactive() if (inter) prg <- txtProgressBar(min = 0, max = length(sid), initial = 0, char = "=",width = NA, title="Progress", style = 3) ## create dataframe for poisson model data dat[[event]] <- 0; start <- 1 dap <- dat[rep(1:length(sid),length(te)),] for (i in 1:length(sid)) { ## work through patients di <- dat[dat[[id]]==sid[i],] ## ith patient's data tr <- te[te <= di[[et]][1]] ## times required for this patient ## Now do the interpolation of covariates to event times... um <- data.frame(lapply(X=di,FUN=app,t=di[[t]],to=tr)) ## Mark the actual event... if (um[[et]][1]==max(tr)&&um[[status]][1]==1) um[[event]][nrow(um)] <- 1 um[[et]] <- tr ## reset time to relevant event times dap[start:(start-1+nrow(um)),] <- um ## copy to dap start <- start + nrow(um) if (inter) setTxtProgressBar(prg, i) } if (inter) close(prg) dap[1:(start-1),] } ## tdpois pbcseq$status1 <- as.numeric(pbcseq$status==2) ## death indicator pb <- tdpois(pbcseq) ## conversion pb$tf <- factor(pb$futime) ## add factor for event time ## Fit Poisson model... b <- bam(z ~ tf - 1 + sex + trt + s(sqrt(protime)) + s(platelet)+ s(age)+ s(bili)+s(albumin), family=poisson,data=pb,discrete=TRUE,nthreads=2) par(mfrow=c(2,3)) plot(b,scale=0) ## compute residuals... chaz <- tapply(fitted(b),pb$id,sum) ## cum haz by subject d <- tapply(pb$z,pb$id,sum) ## censoring indicator mrsd <- d - chaz ## Martingale drsd <- sign(mrsd)*sqrt(-2*(mrsd + d*log(chaz))) ## deviance ## plot survivor function and s.e. band for subject 25 te <- sort(unique(pb$futime)) ## event times di <- pbcseq[pbcseq$id==25,] ## data for subject 25 pd <- data.frame(lapply(X=di,FUN=app,t=di$day,to=te)) ## interpolate to te pd$tf <- factor(te) X <- predict(b,newdata=pd,type="lpmatrix") eta <- drop(X%*%coef(b)); H <- cumsum(exp(eta)) J <- apply(exp(eta)*X,2,cumsum) se <- diag(J%*%vcov(b)%*%t(J))^.5 plot(stepfun(te,c(1,exp(-H))),do.points=FALSE,ylim=c(0.7,1), ylab="S(t)",xlab="t (days)",main="",lwd=2) lines(stepfun(te,c(1,exp(-H+se))),do.points=FALSE) lines(stepfun(te,c(1,exp(-H-se))),do.points=FALSE) rug(pbcseq$day[pbcseq$id==25]) ## measurement times mgcv/tests/single.index.R0000644000176200001440000000377613137076645015113 0ustar liggesusers## donttest single.index.Rd examples require(mgcv) si <- function(theta,y,x,z,opt=TRUE,k=10,fx=FALSE) { ## Fit single index model using gam call, given theta (defines alpha). ## Return ML if opt==TRUE and fitted gam with theta added otherwise. ## Suitable for calling from 'optim' to find optimal theta/alpha. alpha <- c(1,theta) ## constrained alpha defined using free theta kk <- sqrt(sum(alpha^2)) alpha <- alpha/kk ## so now ||alpha||=1 a <- x%*%alpha ## argument of smooth b <- gam(y~s(a,fx=fx,k=k)+s(z),family=poisson,method="ML") ## fit model if (opt) return(b$gcv.ubre) else { b$alpha <- alpha ## add alpha J <- outer(alpha,-theta/kk^2) ## compute Jacobian for (j in 1:length(theta)) J[j+1,j] <- J[j+1,j] + 1/kk b$J <- J ## dalpha_i/dtheta_j return(b) } } ## si ## simulate some data from a single index model... set.seed(1) f2 <- function(x) 0.2 * x^11 * (10 * (1 - x))^6 + 10 * (10 * x)^3 * (1 - x)^10 n <- 200;m <- 3 x <- matrix(runif(n*m),n,m) ## the covariates for the single index part z <- runif(n) ## another covariate alpha <- c(1,-1,.5); alpha <- alpha/sqrt(sum(alpha^2)) eta <- as.numeric(f2((x%*%alpha+.41)/1.4)+1+z^2*2)/4 mu <- exp(eta) y <- rpois(n,mu) ## Poi response ## now fit to the simulated data... th0 <- c(-.8,.4) ## close to truth for speed ## get initial theta, using no penalization... f0 <- nlm(si,th0,y=y,x=x,z=z,fx=TRUE,k=5) ## now get theta/alpha with smoothing parameter selection... f1 <- nlm(si,f0$estimate,y=y,x=x,z=z,hessian=TRUE,k=10) theta.est <-f1$estimate ## Alternative using 'optim'... th0 <- rep(0,m-1) ## get initial theta, using no penalization... f0 <- optim(th0,si,y=y,x=x,z=z,fx=TRUE,k=5) ## now get theta/alpha with smoothing parameter selection... f1 <- optim(f0$par,si,y=y,x=x,z=z,hessian=TRUE,k=10) theta.est <-f1$par ## extract and examine fitted model... b <- si(theta.est,y,x,z,opt=FALSE) ## extract best fit model plot(b,pages=1) b b$alpha ## get sd for alpha... Vt <- b$J%*%solve(f1$hessian,t(b$J)) diag(Vt)^.5 mgcv/tests/bam.R0000644000176200001440000000040113137076643013237 0ustar liggesusers## bam donttest case library(mgcv) set.seed(3); k <- 12; bs <- "cr" dat <- gamSim(1,n=25000,dist="normal",scale=20) ba <- bam(y ~ s(x0,bs=bs,k=k)+s(x1,bs=bs,k=k)+s(x2,bs=bs,k=k)+ s(x3,bs=bs,k=k),data=dat,method="GCV.Cp") ## use GCV summary(ba) mgcv/tests/gam.R0000644000176200001440000000614113137076645013255 0ustar liggesusers## \donttest examples from gam require(mgcv) ## now simulate poisson data... set.seed(6) dat <- gamSim(1,n=2000,dist="poisson",scale=.1) ## use "cr" basis to save time, with 2000 data... b2<-gam(y~s(x0,bs="cr")+s(x1,bs="cr")+s(x2,bs="cr")+ s(x3,bs="cr"),family=poisson,data=dat,method="REML") plot(b2,pages=1) ## drop x3, but initialize sp's from previous fit, to ## save more time... b2a<-gam(y~s(x0,bs="cr")+s(x1,bs="cr")+s(x2,bs="cr"), family=poisson,data=dat,method="REML", in.out=list(sp=b2$sp[1:3],scale=1)) par(mfrow=c(2,2)) plot(b2a) par(mfrow=c(1,1)) ## similar example using performance iteration dat <- gamSim(1,n=400,dist="poisson",scale=.25) b3<-gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=poisson, data=dat,optimizer="perf") plot(b3,pages=1) ## repeat using GACV as in Wood 2008... b4<-gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=poisson, data=dat,method="GACV.Cp",scale=-1) plot(b4,pages=1) ## repeat using REML as in Wood 2011... b5<-gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=poisson, data=dat,method="REML") plot(b5,pages=1) ## a binary example (see ?gam.models for large dataset version)... dat <- gamSim(1,n=400,dist="binary",scale=.33) lr.fit <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),family=binomial, data=dat,method="REML") ## plot model components with truth overlaid in red op <- par(mfrow=c(2,2)) fn <- c("f0","f1","f2","f3");xn <- c("x0","x1","x2","x3") for (k in 1:4) { plot(lr.fit,residuals=TRUE,select=k) ff <- dat[[fn[k]]];xx <- dat[[xn[k]]] ind <- sort.int(xx,index.return=TRUE)$ix lines(xx[ind],(ff-mean(ff))[ind]*.33,col=2) } par(op) anova(lr.fit) lr.fit1 <- gam(y~s(x0)+s(x1)+s(x2),family=binomial, data=dat,method="REML") lr.fit2 <- gam(y~s(x1)+s(x2),family=binomial, data=dat,method="REML") AIC(lr.fit,lr.fit1,lr.fit2) ## For a Gamma example, see ?summary.gam... ## For inverse Gaussian, see ?rig ## now 2D smoothing... eg <- gamSim(2,n=500,scale=.1) attach(eg) op <- par(mfrow=c(2,2),mar=c(4,4,1,1)) contour(truth$x,truth$z,truth$f) ## contour truth b4 <- gam(y~s(x,z),data=data) ## fit model fit1 <- matrix(predict.gam(b4,pr,se=FALSE),40,40) contour(truth$x,truth$z,fit1) ## contour fit persp(truth$x,truth$z,truth$f) ## persp truth vis.gam(b4) ## persp fit detach(eg) par(op) ################################################## ## largish dataset example with user defined knots ################################################## par(mfrow=c(2,2)) n <- 5000 eg <- gamSim(2,n=n,scale=.5) attach(eg) ind<-sample(1:n,200,replace=FALSE) b5<-gam(y~s(x,z,k=40),data=data, knots=list(x=data$x[ind],z=data$z[ind])) ## various visualizations vis.gam(b5,theta=30,phi=30) plot(b5) plot(b5,scheme=1,theta=50,phi=20) plot(b5,scheme=2) par(mfrow=c(1,1)) ## and a pure "knot based" spline of the same data b6<-gam(y~s(x,z,k=64),data=data,knots=list(x= rep((1:8-0.5)/8,8), z=rep((1:8-0.5)/8,rep(8,8)))) vis.gam(b6,color="heat",theta=30,phi=30) ## varying the default large dataset behaviour via `xt' b7 <- gam(y~s(x,z,k=40,xt=list(max.knots=500,seed=2)),data=data) vis.gam(b7,theta=30,phi=30) detach(eg)mgcv/tests/mgcv-parallel.R0000644000176200001440000000302113137076643015227 0ustar liggesusers## examples that are claimed to be too long in help files ## illustration of multi-threading with gam... require(mgcv);set.seed(9) dat <- gamSim(1,n=2000,dist="poisson",scale=.1) k <- 12;bs <- "cr";ctrl <- list(nthreads=2) system.time(b1<-gam(y~s(x0,bs=bs)+s(x1,bs=bs)+s(x2,bs=bs,k=k) ,family=poisson,data=dat,method="REML"))[3] system.time(b2<-gam(y~s(x0,bs=bs)+s(x1,bs=bs)+s(x2,bs=bs,k=k), family=poisson,data=dat,method="REML",control=ctrl))[3] ## Poisson example on a cluster with 'bam'. ## Note that there is some overhead in initializing the ## computation on the cluster, associated with loading ## the Matrix package on each node. For this reason the ## sample sizes here are very small to keep CRAN happy, but at ## this low sample size you see little advantage of parallel computation. k <- 13;set.seed(9) dat <- gamSim(1,n=6000,dist="poisson",scale=.1) require(parallel) nc <- 2 ## cluster size, set for example portability if (detectCores()>1) { ## no point otherwise cl <- makeCluster(nc) ## could also use makeForkCluster, but read warnings first! } else cl <- NULL system.time(b3 <- bam(y ~ s(x0,bs=bs,k=7)+s(x1,bs=bs,k=7)+s(x2,bs=bs,k=k) ,data=dat,family=poisson(),chunk.size=5000,cluster=cl)) fv <- predict(b3,cluster=cl) ## parallel prediction if (!is.null(cl)) stopCluster(cl) b3 ## Alternative using the discrete option with bam... system.time(b4 <- bam(y ~ s(x0,bs=bs,k=7)+s(x1,bs=bs,k=7)+s(x2,bs=bs,k=k) ,data=dat,family=poisson(),discrete=TRUE,nthreads=2)) mgcv/tests/smooth.construct.so.smooth.spec.R0000644000176200001440000000310413137076645020722 0ustar liggesusers## donttest examples from smooth.construct.so.smooth.spec library(mgcv) set.seed(9) n <- 10000;nmax <- 100 v <- runif(n)*5-1;w<-runif(n)*2-1 t <- runif(n) y <- fs.test(v,w,b=1) y <- y + 4.2 y <- y^(.5+t) fsb <- list(fs.boundary()) names(fsb[[1]]) <- c("v","w") ind <- inSide(fsb,x=v,y=w) ## remove outsiders y <- y[ind];v <- v[ind]; w <- w[ind]; t <- t[ind] n <- length(y) y <- y + rnorm(n)*.05 ## add noise knots <- data.frame(v=rep(seq(-.5,3,by=.5),4), w=rep(c(-.6,-.3,.3,.6),rep(8,4))) ## notice NULL element in 'xt' list - to indicate no xt object for "cr" basis... bk <- gam(y~ te(v,w,t,bs=c("sf","cr"),k=c(25,4),d=c(2,1), xt=list(list(bnd=fsb,nmax=nmax),NULL))+ te(v,w,t,bs=c("sw","cr"),k=c(25,4),d=c(2,1), xt=list(list(bnd=fsb,nmax=nmax),NULL)),knots=knots) par(mfrow=c(3,2)) m<-100;n<-50 xm <- seq(-1,3.5,length=m);yn<-seq(-1,1,length=n) xx <- rep(xm,n);yy<-rep(yn,rep(m,n)) tru <- matrix(fs.test(xx,yy),m,n)+4.2 ## truth image(xm,yn,tru^.5,col=heat.colors(100),xlab="v",ylab="w", main="truth") lines(fsb[[1]]$v,fsb[[1]]$w,lwd=3) contour(xm,yn,tru^.5,add=TRUE) vis.gam(bk,view=c("v","w"),cond=list(t=0),plot.type="contour") image(xm,yn,tru,col=heat.colors(100),xlab="v",ylab="w", main="truth") lines(fsb[[1]]$v,fsb[[1]]$w,lwd=3) contour(xm,yn,tru,add=TRUE) vis.gam(bk,view=c("v","w"),cond=list(t=.5),plot.type="contour") image(xm,yn,tru^1.5,col=heat.colors(100),xlab="v",ylab="w", main="truth") lines(fsb[[1]]$v,fsb[[1]]$w,lwd=3) contour(xm,yn,tru^1.5,add=TRUE) vis.gam(bk,view=c("v","w"),cond=list(t=1),plot.type="contour") mgcv/tests/missing.data.R0000644000176200001440000000464413137076654015100 0ustar liggesusers## donttest examples from missing.data.Rd require(mgcv) par(mfrow=c(4,4),mar=c(4,4,1,1)) for (sim in c(1,7)) { ## cycle over uncorrelated and correlated covariates n <- 350;set.seed(2) ## simulate data but randomly drop 300 covariate measurements ## leaving only 50 complete cases... dat <- gamSim(sim,n=n,scale=3) ## 1 or 7 drop <- sample(1:n,300) ## to for (i in 2:5) dat[drop[1:75+(i-2)*75],i] <- NA ## process data.frame producing binary indicators of missingness, ## mx0, mx1 etc. For each missing value create a level of a factor ## idx0, idx1, etc. So idx0 has as many levels as x0 has missing ## values. Replace the NA's in each variable by the mean of the ## non missing for that variable... dname <- names(dat)[2:5] dat1 <- dat for (i in 1:4) { by.name <- paste("m",dname[i],sep="") dat1[[by.name]] <- is.na(dat1[[dname[i]]]) dat1[[dname[i]]][dat1[[by.name]]] <- mean(dat1[[dname[i]]],na.rm=TRUE) lev <- rep(1,n);lev[dat1[[by.name]]] <- 1:sum(dat1[[by.name]]) id.name <- paste("id",dname[i],sep="") dat1[[id.name]] <- factor(lev) dat1[[by.name]] <- as.numeric(dat1[[by.name]]) } ## Fit a gam, in which any missing value contributes zero ## to the linear predictor from its smooth, but each ## missing has its own random effect, with the random effect ## variances being specific to the variable. e.g. ## for s(x0,by=ordered(!mx0)), declaring the `by' as an ordered ## factor ensures that the smooth is centred, but multiplied ## by zero when mx0 is one (indicating a missing x0). This means ## that any value (within range) can be put in place of the ## NA for x0. s(idx0,bs="re",by=mx0) produces a separate Gaussian ## random effect for each missing value of x0 (in place of s(x0), ## effectively). The `by' variable simply sets the random effect to ## zero when x0 is non-missing, so that we can set idx0 to any ## existing level for these cases. b <- gam(y~s(x0,by=ordered(!mx0))+s(x1,by=ordered(!mx1))+ s(x2,by=ordered(!mx2))+s(x3,by=ordered(!mx3))+ s(idx0,bs="re",by=mx0)+s(idx1,bs="re",by=mx1)+ s(idx2,bs="re",by=mx2)+s(idx3,bs="re",by=mx3) ,data=dat1,method="REML") for (i in 1:4) plot(b,select=i) ## plot the smooth effects from b ## fit the model to the `complete case' data... b2 <- gam(y~s(x0)+s(x1)+s(x2)+s(x3),data=dat,method="REML") plot(b2) ## plot the complete case results }mgcv/src/0000755000176200001440000000000013560763157012012 5ustar liggesusersmgcv/src/tprs.h0000755000176200001440000000141513073161531013142 0ustar liggesusers/* tprs.h: thin plate regression splines*/ #ifndef MATRIX_HEADER_IN #include "matrix.h" #endif /*extern double eta(int m,int d,double r);*/ void tpsE(matrix *E,matrix *X,int m,int d); void tpsT(matrix *T,matrix *X,int m,int d); double tps_g(matrix *X,matrix *p,double *x,int d,int m,double *b,int constant); void tprs_setup(double **x,double **knt,int m,int d,int n,int k,int constant,matrix *X,matrix *S, matrix *UZ,matrix *Xu,int n_knots); int null_space_dimension(int d,int m); int *Xd_strip(matrix *Xd); double eta_const(int m,int d); int Xd_row_comp(double *a,double *b,int k); int *Xd_strip(matrix *Xd); void tprs_setup(double **x,double **knt,int m,int d,int n,int k,int constant,matrix *X,matrix *S, matrix *UZ,matrix *Xu,int n_knots); mgcv/src/mgcv.h0000755000176200001440000003525013560623737013126 0ustar liggesusers/* main method routines */ /* See http://developer.r-project.org/blosxom.cgi/R-devel/2019/08/29#n2019-08-29 for what USE_FC_LEN_T is doing and for why see https://developer.r-project.org/Blog/public/2019/05/15/gfortran-issues-with-lapack/index.html In a nutshell, the mechanism used to call BLAS/LAPACK from C (by everyone, not just R) is not technically supported by the Fortran standard. Fortran needs to know how long strings are (they are not null terminated) so the lengths are passed as hidden extra function arguments. BLAS/LAPACK only ever uses single character strings, so it never needs to access the string lengths and it is then no problem that they are missing (they are at the end of the call arguments), so they are simply not passed in the C call. This was no problme until Gfortran decided to optimize the process of calling a function with the same argument list as the calling function. Basically it passed the call stack of the calling function to the called function assuming that it contained the string lengths - as it didn't this caused stack corruption. The solution is to pass the unit string lengths explicitly using FCONE defined in Rconfig.h if USE_FC_LEN_T is defined. This mechanism is needed since it is compiler specific what type is used to pass the string lengths (what happens then if BLAS/LAPACK and R are compiled using different extra argument types is unclear to me, but no problems of this sort are currently known in any case to get an actual problem the LAPACK/BLAS compiler would have to be using a different number of bytes to the R compiler). In practice when calling BLAS/LAPACK macro FCONE has to be added to the end of the call as many times as there are character arguments to the call. mat.c has many examples. */ #define USE_FC_LEN_T #include #include #include #include /* If we are compiling with a version of R before FCONE and the explicit supplying of extra arguments was introduced, then FCONE has to be defined */ #ifndef FCONE #define FCONE #endif /* Most compilers with openMP support supply a pre-defined compiler macro _OPENMP. Following facilitates selective turning off (by testing value or defining multiple versions OPENMP_ON1, OPENMP_ON2...) */ #if defined _OPENMP #define OPENMP_ON 1 #endif /* ... note also that there is no actual *need* to protect #pragmas with #ifdef OPENMP_ON, since C ignores undefined pragmas, but failing to do so may produce alot of compilation warnings if openMP is not supported. In contrast functions from omp.h must be protected, and there is non-avoidable use of these in the mgcv code. */ //#define OMP_REPORT // define to have all routines using omp report on start and end. /* sed -i 's/old-text/new-text/g' *.c is quite useful!! */ /* For safe memory handling from R... */ #define CALLOC R_chk_calloc #define FREE R_chk_free /* BUT, this can mess up valgrinding for memory error checking - problems are sometimes missed because standard allocation is being circumvented. Then errors can corrupt R memory management without detection and trigger nothing until R messes up internally because of corruption, which then makes it look as if R is generating the problem. Hence better to reset for checking. Also sizing errors in .C often generate no obvious valgrind error.*/ //#define CALLOC calloc //#define FREE free void *R_chk_calloc1(size_t nmemb,size_t size); void magic(double *y,double *X,double *sp0,double *def_sp,double *S,double *H,double *L, double *lsp0,double *gamma,double *scale, int *control,int *cS,double *rank_tol, double *tol,double *b,double *rV,double *norm_const,int *n_score,int *nt); void gdi1(double *X,double *E,double *Es,double *rS,double *U1, double *sp,double *z,double *w,double *wf,double *alpha,double *mu,double *eta, double *y, double *p_weights,double *g1,double *g2,double *g3,double *g4,double *V0, double *V1,double *V2,double *V3,double *beta,double *b1,double *w1,double *D1,double *D2, double *P0, double *P1,double *P2,double *trA, double *trA1,double *trA2,double *rV,double *rank_tol,double *conv_tol, int *rank_est, int *n,int *q, int *M,int *Mp,int *Enrow,int *rSncol,int *deriv, int *REML,int *fisher,int *fixed_penalty,int *nthreads,double *dVkk); void gdi2(double *X,double *E,double *Es,double *rS,double *U1, double *sp,double *theta,double *z,double *w,double *wz,double *wf, double *Dth,double *Det,double *Det2,double *Dth2,double *Det_th, double *Det2_th,double *Det3,double *Det_th2, double *Det4, double *Det3_th, double *Det2_th2, double *beta,double *b1,double *w1,double *D1,double *D2,double *P,double *P1,double *P2, double *ldet, double *ldet1,double *ldet2,double *rV, double *rank_tol,int *rank_est, int *n,int *q, int *M,int *n_theta, int *Mp,int *Enrow,int *rSncol,int *deriv, int *fixed_penalty,int *nt,int *type,double *dVkk); void pls_fit1(double *y,double *X,double *w,double *wy,double *E,double *Es,int *n,int *q,int *rE,double *eta, double *penalty,double *rank_tol,int *nt,int *use_wy); void get_detS2(double *sp,double *sqrtS, int *rSncol, int *q,int *M, int * deriv, double *det, double *det1, double *det2, double *d_tol, double *r_tol,int *fixed_penalty); /* stable determinant of sum evaluation */ void get_stableS(double *S,double *Qf,double *sp,double *sqrtS, int *rSncol, int *q,int *M, int * deriv, double *det, double *det1, double *det2, double *d_tol, double *r_tol,int *fixed_penalty); /* cox model routines */ void coxpred(double *X,double *t,double *beta,double *off,double *Vb,double *a,double *h,double *q, double *tr,int *n,int *p, int *nt,double *s,double *se); void coxpp(double *eta,double *X,int *r, int *d,double *h,double *q,double *km, int *n,int *p, int *nt); void coxlpl(double *eta,double *X,int *r, int *d,double *tr, int *n,int *p, int *nt,double *lp,double *g,double *H, double *d1beta,double *d1H,double *d2beta, double *d2H,int *n_sp,int *deriv); /* MVN smooth additive */ void mvn_ll(double *y,double *X,double *XX,double *beta,int *n,int *lpi, int *m,double *ll,double *lb,double *lbb,double *dbeta, double *dH,int *deriv,int *nsp,int *nt); /* discretized covariate methods */ void XWXd(double *XWX,double *X,double *w,int *k,int *ks, int *m,int *p, int *n, int *nx, int *ts, int *dt, int *nt,double *v,int *qc,int *nthreads,int *ar_stop, int *ar_row,double *ar_weights); void XWXd0(double *XWX,double *X,double *w,int *k,int *ks, int *m,int *p, int *n, int *nx, int *ts, int *dt, int *nt,double *v,int *qc,int *nthreads,int *ar_stop, int *ar_row,double *ar_weights); void XWXd1(double *XWX,double *X,double *w,int *k,int *ks, int *m,int *p, int *n, int *nx, int *ts, int *dt, int *nt,double *v,int *qc,int *nthreads,int *ar_stop,int *ar_row,double *ar_weights, int *rs, int *cs, int *nrs, int *ncs); void XWyd(double *XWy,double *y,double *X,double *w,int *k, int *ks, int *m,int *p, int *n,int *cy, int *nx, int *ts, int *dt, int *nt,double *v,int *qc, int *ar_stop,int *ar_row,double *ar_weights,int *cs,int *ncs); void Xbd(double *f,double *beta,double *X,int *k, int *ks, int *m,int *p, int *n, int *nx, int *ts, int *dt, int *nt,double *v,int *qc,int *bc,int *cs,int *ncs); void diagXVXt(double *diag,double *V,double *X,int *k,int *ks,int *m,int *p, int *n, int *nx, int *ts, int *dt, int *nt,double *v,int *qc,int *pv,int *cv,int *nthreads,int *cs,int *ncs,int *rs,int *nrs); /* various service routines */ void tweedious(double *w,double *w1,double *w2, double *w1p,double *w2p,double *w2pp, double *y,double *eps,int *n, double *th,double *rho,double *a, double *b); void tweedious2(double *w,double *w1,double *w2, double *w1p,double *w2p,double *w2pp, double *y,double *eps,int *n, double *th,double *rho,double *a, double *b); void psum(double *y, double *x,int *index,int *n); void rwMatrix(int *stop,int *row,double *w,double *X,int *n,int *p,int *trans,double *work); void in_out(double *bx, double *by, double *break_code, double *x,double *y,int *in, int *nb, int *n); void Rlanczos(double *A,double *U,double *D,int *n, int *m, int *lm,double *tol,int *nt); void RuniqueCombs(double *X,int *ind,int *r, int *c); void RPCLS(double *Xd,double *pd,double *yd, double *wd,double *Aind,double *bd,double *Afd,double *Sd,int *off,int *dim,double *theta, int *m,int *nar); void RMonoCon(double *Ad,double *bd,double *xd,int *control,double *lower,double *upper,int *n); void MinimumSeparation(double *x,int *n, int *d,double *t,int *m,double *dist); void rksos(double *x,int *n,double *eps); void pivoter(double *x,int *r,int *c,int *pivot, int *col, int *reverse); /* Routines for linear algebra with direct access to linpack and lapack */ void row_squash(double *X,int rnew,int rold,int col); void up2lo(double * A, int n); void band_chol(double *B,int *n,int *k,int *info); void tri_chol(double *ld,double *sd,int *n,int *info); void mgcv_omp(int *a); void mgcv_chol(double *a,int *pivot,int *n,int *rank); void mgcv_svd(double *x,double *u, double *d,int *r,int *c); void mgcv_qrqy(double *b,double *a,double *tau,int *r,int *c,int *k,int *left,int *tp); void mgcv_qrqy0(double *b,double *a,double *tau,int *r,int *c,int *k,int *left,int *tp); void mgcv_backsolve(double *R,int *r,int *c,double *B,double *C, int *bc, int *right); void mgcv_forwardsolve(double *R,int *r,int *c,double *B,double *C, int *bc, int *right); void mgcv_qr(double *x, int *r, int *c,int *pivot,double *tau); void mgcv_qr2(double *x, int *r, int *c,int *pivot,double *tau); void update_qr(double *Q,double *R,int *n, int *q,double *lam, int *k); extern void mgcv_mmult(double *A,double *B,double *C,int *bt,int *ct,int *r,int *c,int *n); void mgcv_pmmult(double *A,double *B,double *C,int *bt,int *ct,int *r,int *c,int *n,int *nt); SEXP mgcv_pmmult2(SEXP b, SEXP c,SEXP bt,SEXP ct, SEXP nthreads); void mgcv_mmult0(double *A,double *B,double *C,int *bt,int *ct,int *r,int *c,int *n); void mgcv_svd_full(double *x,double *vt,double *d,int *r,int *c); void mgcv_symeig(double *A,double *ev,int *n,int *use_dsyevd, int *get_vectors,int *descending); void mroot(double *A,int *rank,int *n); void R_cond(double *R,int *r,int *c,double *work,double *Rcondition); void mgcv_td_qy(double *S,double *tau,int *m,int *n, double *B,int *left,int *transpose); void mgcv_tri_diag(double *S,int *n,double *tau); void mgcv_trisymeig(double *d,double *g,double *v,int *n,int getvec,int descending); void getXtWX(double *XtWX, double *X,double *w,int *r,int *c,double *work); void getXtX(double *XtX,double *X,int *r,int *c); void getXtMX(double *XtMX,double *X,double *M,int *r,int *c,double *work); void getXXt(double *XXt,double *X,int *r,int *c); void read_mat(double *M,int *r,int*c, char *path); void row_block_reorder(double *x,int *r,int *c,int *nb,int *reverse); void mgcv_pqr(double *x,int *r, int *c,int *pivot, double *tau, int *nt); void getRpqr(double *R,double *x,int *r, int *c,int *rr,int *nt); void mgcv_pqrqy(double *b,double *a,double *tau,int *r,int *c,int *cb,int *tp,int *nt); SEXP mgcv_Rpiqr(SEXP X, SEXP BETA,SEXP PIV,SEXP NT,SEXP NB); SEXP mgcv_tmm(SEXP x,SEXP t,SEXP D,SEXP M, SEXP N); SEXP mgcv_Rpbsi(SEXP A, SEXP NT); SEXP mgcv_RPPt(SEXP a,SEXP r, SEXP NT); SEXP mgcv_Rpchol(SEXP Amat,SEXP PIV,SEXP NT,SEXP NB); void dchol(double *dA, double *R, double *dR,int *p); void chol_down(double *R,double *Rup,int *n,int *k,int *ut); SEXP mgcv_chol_down(SEXP r,SEXP ru,SEXP N,SEXP K, SEXP UT); SEXP mgcv_chol_up(SEXP r,SEXP U,SEXP N,SEXP UP,SEXP EPS); void vcorr(double *dR,double *Vr,double *Vb,int *p,int *M); SEXP mgcv_Rpforwardsolve(SEXP R, SEXP B,SEXP NT); SEXP mgcv_Rpbacksolve(SEXP R, SEXP B,SEXP NT); SEXP mgcv_Rpcross(SEXP A, SEXP NT,SEXP NB); SEXP mgcv_madi(SEXP a, SEXP b,SEXP ind,SEXP diag); /* basis constructor/prediction routines*/ void crspl(double *x,int *n,double *xk, int *nk,double *X,double *S, double *F,int *Fsupplied); void predict_tprs(double *x, int *d,int *n,int *m,int *k,int *M,double *Xu,int *nXu, double *UZ,double *by,int *by_exists,double *X); void construct_tprs(double *x,int *d,int *n,double *knt,int *nk,int *m,int *k,double *X,double *S, double *UZ,double *Xu,int *nXu,double *C); void gen_tps_poly_powers(int *pi,int *M,int *m, int *d); void boundary(int *G, double *d, double *dto, double *x0, double *y0, double *dx, double *dy, int *nx, int *ny, double *x, double *y,double *break_code, int *n, int *nb); void gridder(double *z,double *x,double *y,int *n,double *g, int *G,int *nx, int *ny,double *x0, double *y0,double *dx,double *dy,double NA_code); void pde_coeffs(int *G,double *x,int *ii,int *jj,int *n,int *nx,int *ny,double *dx,double *dy); /* sparse smooth related routines */ typedef struct { /* defines structure for kd-tree box */ double *lo,*hi; /* box defining co-ordinates */ int parent,child1,child2, /* indices of parent and 2 offspring */ p0,p1; /* indices of first and last point in box */ } box_type; typedef struct { box_type *box; int *ind, /* index of points in coordinate matrix which tree relates to */ *rind, /* where is ith row of X in ind? */ n_box, /* number of boxes */ d, /* dimension */ n; /* number of points that tree relates to */ double huge; /* number indicating an open boundary */ } kdtree_type; void k_newn_work(double *Xm,kdtree_type kd,double *X,double *dist,int *ni,int*m,int *n,int *d,int *k); void k_nn(double *X,double *dist,double *a,int *ni,int *n,int *d,int *k,int *get_a); //void Rkdtree(double *X,int *n, int *d,int *idat,double *ddat); SEXP Rkdtree(SEXP x); //void Rkdnearest(double *X,int *idat,double *ddat,int *n,double *x, int *m, int *ni, double *dist,int *k); SEXP Rkdnearest(SEXP kdr,SEXP Xr, SEXP xr,SEXP k); //void Rkradius(double *r,int *idat,double *ddat,double *X,double *x,int *m,int *off,int *ni,int *op); SEXP Rkradius(SEXP kdr,SEXP Xr, SEXP xr,SEXP rr,SEXP offr); double xidist(double *x,double *X,int i,int d, int n); int closest(kdtree_type *kd, double *X,double *x,int n,int *ex,int nex); void kd_tree(double *X,int *n, int *d,kdtree_type *kd); void free_kdtree(kdtree_type kd); void tri2nei(int *t,int *nt,int *n,int *d,int *off); void nei_penalty(double *X,int *n,int *d,double *D,int *ni,int *ii,int *off, int *m,int *a_weight,double *kappa); void sspl_construct(double *lambda,double *x,double *w,double *U,double *V, double *diagA,double *lb,int *n,double *tol); void sspl_mapply(double *y,double *x,double *w,double *U,double *V,int *n,int *nf,double *tol,int *m); mgcv/src/matrix.h0000755000176200001440000000213413303547337013465 0ustar liggesusers/* matrix.h : header file for matrix routines.*/ #ifndef MATRIX_HEADER_IN #define MATRIX_HEADER_IN /* The basic matrix structure */ #define TOL 1e-10 #define VEC M[0] typedef struct { int vec, r,c,original_r,original_c;long mem;double **M,*V;} matrix; extern matrix null_mat; extern long matrallocd; /* The user routines */ void mcopy(matrix *A,matrix *B); matrix initmat(int rows,int cols); void freemat(matrix A); void vmult(matrix *A,matrix *b,matrix *c,int t); void matmult(matrix C,matrix A,matrix B,int tA,int tB); void invert(matrix *a); double dot(matrix a,matrix b); double enorm(matrix d); void householder(matrix *u,matrix a,matrix b,int t1); void Hmult(matrix C,matrix u); void HQmult(matrix C,matrix U,int p,int t); void QT(matrix Q,matrix A,int Qfull); void Rsolv(matrix *R,matrix *p,matrix *y, int transpose); int QR(matrix *Q,matrix *R); void OrthoMult(matrix *Q,matrix *A,int off,int rows,int t,int pre,int o_pre); void matrixintegritycheck(void); void msort(matrix a); void RArrayFromMatrix(double *a,int r,matrix *M); matrix Rmatrix(double *A,int r,int c); matrix initvec(int rows); #endif mgcv/src/magic.c0000755000176200001440000007605213073161526013242 0ustar liggesusers /* Copyright (C) 2003-2013 Simon N. Wood simon.wood@r-project.org This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. (www.gnu.org/copyleft/gpl.html) You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #include #include #include #include "general.h" #include "mgcv.h" #include "matrix.h" #ifdef OPENMP_ON #include #endif double ***array3d(int ni,int nj,int nk) /* allocate 3d array */ { double ***a,***p,**p1,*p2; int j; a=(double ***)CALLOC((size_t)(ni),sizeof(double **)); *a=(double **)CALLOC((size_t)(ni*nj),sizeof(double *)); **a=(double *)CALLOC((size_t)(ni*nj*nk),sizeof(double)); p2 = **a; p1= *a;p=a; for (p=a;p0||control[3]) mroot(St,&rank_S,&q); /* St replaced by its square root */ else rank_S=0; /* Now form the augmented R matrix [R',St']' */ r=rank_S+q; R=(double *)CALLOC((size_t)(r*q),sizeof(double)); getRpqr(R,X,&n,&q,&r,nt); /*for (j=0;j1 then X should have nt*q^2 extra (double) memory tagged on the end sp0 - an mp-array of (underlying) smoothing parameters (any -ve => autoinitialize) def_sp - an array of default values for sp0's (any -ve => set up internally) b - a q dimensional parameter vector S - an array of dimension q columns of square roots of the m S_i penalty matrices. There are cS[i] columns for the ith penalty, and they are packed starting from i=0. H - a q by q fixed penalty matrix L - m by mp matrix mapping log(sp0) to log coeffs multiplying S terms. ignored if control[6] is negative. lsp0 - constant vector in linear transformation of log(sp0). So sp = Llog(sp0)+lsp0 also ignored if control[6] is negative. gamma - a factor by which to inflate the model degrees of freedom in GCV/UBRE scores. norm_const - a constant to be added to the residual sum of squares (squared norm) term in the GCV/UBRE and scale estimation calculations. scale - the scale parameter (fixed for UBRE, will be estimated for GCV). Elements of control are as follows: control[0] - 1 for GCV 0 for UBRE control[1] - n, the number of data control[2] - q, the number of parameters control[3] - 1 if H is to be used, 0 to ignore it control[4] - m, the number of penalty matrices in S. control[5] - the maximum number of step halvings to try control[6] - mp, the number of actual smoothing parameters: -ve signals that it's m and L is to be taken as the identity, but ignored. cS[i] gives the number of columns of S relating to S_i (column 0 is the first column of S_0). rank_tol is the tolerance to use in rank determination square root of the machine precision is quite good. tol is the convergence tolerance for the iterative score optimisation. b is the q dimensional parameter vector. rV is a square root of the parameter covariance matrix (to within the scale factor) cov(b)=rV rV' scale nt is the number of threads to use for parts of the calculation if openMP is supported The m square roots of smoothing penalty matrices are packed one after another in S. Currently first guess smoothing parameters are 1/tr(S_i), and second guess are \sigma^2 rank(S_i) / b'S_ib The routine modifies the following arguments on exit: b contains parameter estimates sp contains the smoothing parameter estimates gamma contains the estimated GCV/UBRE score scale - the estimated scale parameter if GCV used tol - the root mean square gradient of the GCV/UBRE score at convergence rV - square root of the param. cov. matrix cov(b) = rV%*%rV'*scale, rV is q by rank. control[0] - the final rank estimate control[1] - 1 if converged, 0 if step failure without meeting convergence criteria control[2] - 1 if the final Hessian was +ve definite control[3] - the number of iterations used control[4] - the number of score function evaluations control[5] - maximum number of step halvings to try control[6] - The maximum number of iterations before giving up Note that the effective degrees of freedom for each parameter are given by the leading diagonal of cov(b)X'X/scale. Appropriate initialization of the smoothing parameters is important for this algorithm, particularly since there is no line search in this approach. Whether the initial estimates are auto-generated or supplied, it is important to start with values such that the partial derivatives of the score w.r.t. the smoothing parameters are all "large", meeaning well above the level judged to have converged. To this end initial values are all checked for derivative magnitude. Any parameters for which the derivative magnitude is too small are modified in an attempt to increase the derivative magnitude. */ { int *pi,*pivot,q,n,autoinit,ScS,m,mp,i,j,tp,k,use_sd=0,rank,converged,iter=0,ok,*cucS, gcv,try,fit_call=0,step_fail=0,max_half,*spok,def_supplied,use_dsyevd=1,L_exists,TRUE=1,FALSE=0; double *sp=NULL,*p,*p1,*p2,*tau,xx,*y1,*y0,yy,**Si=NULL,*work,score,*sd_step,*n_step,*U1,*V,*d,**M,**K, *VS,*U1U1,**My,**Ky,**yK,*dnorm,*ddelta,**d2norm,**d2delta,norm,delta,*grad,**hess,*nsp, min_score,*step,d_score=1e10,*ev=NULL,*u,msg=0.0,Xms,*rSms,*bag,*bsp,sign,*grad1,*u0,*R; #ifdef OPENMP_ON m = omp_get_num_procs(); /* detected number of processors */ if (*nt > m || *nt < 1) *nt = m; /* no point in more threads than m */ omp_set_num_threads(*nt); /* set number of threads to use */ #else *nt = 1; #endif gcv=control[0];q=control[2];n=control[1];m=control[4];max_half=control[5];mp=control[6]; /* first get the QR decomposition of X */ tau=(double *)CALLOC((size_t)q *(1 + *nt),sizeof(double)); /* part of reflector storage */ pivot=(int *)CALLOC((size_t)q,sizeof(int)); /* Accuracy can be improved by pivoting on some occasions even though it's not going to be `used' as such here - see Golub and Van Loan (1983) section 6.4. page 169 for reference. */ /* mgcv_qr(X,&n,&q,pivot,tau);*/ mgcv_pqr(X,&n,&q,pivot,tau,nt); /* Apply pivoting to the parameter space - this simply means reordering the rows of the S_i stored in S doing the same for H, and then unscrambling the parameter vector at the end (along with covariance matrix) pivot[i] gives the unpivoted position of the ith pivoted parameter. */ cucS = (int *)CALLOC((size_t)m,sizeof(int)); /* cumulative cols in S */ for (i=1;i0) { Si=array2d(m,q*q); i=0;j=1; for (p=S,k=0;k0) sp = (double *)CALLOC((size_t)m,sizeof(double)); /* to hold actual log(sp[i]) terms multiplying penalties */ autoinit=0;for (p=sp0;p0&&!def_supplied) /* generate default sp's (only possible if there is no L)*/ { rSms=(double *)CALLOC((size_t)m,sizeof(double)); /* first get some sort of norm for X */ Xms=0.0;for (j=0;j0) /* allocate derivative related storage */ { M=array2d(m,q*q);K=array2d(m,q*q); VS=(double *)CALLOC((size_t)(q * q * *nt),sizeof(double)); My=array2d(m,q);Ky=array2d(m,q);yK=array2d(m,q); hess=array2d(m,m); grad=(double *)CALLOC((size_t)mp,sizeof(double)); grad1=(double *)CALLOC((size_t)m,sizeof(double)); dnorm=(double *)CALLOC((size_t)m,sizeof(double)); ddelta=(double *)CALLOC((size_t)m,sizeof(double)); nsp=(double *)CALLOC((size_t)mp,sizeof(double)); d2norm=array2d(m,m);d2delta=array2d(m,m); ev=(double *)CALLOC((size_t)mp,sizeof(double)); u=(double *)CALLOC((size_t)(m*m),sizeof(double)); u0=(double *)CALLOC((size_t)(m*mp),sizeof(double)); U1U1=(double *)CALLOC((size_t)(q*q),sizeof(double)); spok=(int *)CALLOC((size_t)m,sizeof(int)); /*dir_sp=(int *)CALLOC((size_t)m,sizeof(int));*/ bsp=(double *)CALLOC((size_t)m,sizeof(double)); bag=(double *)CALLOC((size_t)m,sizeof(double)); } else { M=K=My=Ky=yK=hess=d2norm=d2delta=NULL; u0=VS=grad1=grad=dnorm=ddelta=nsp=ev=u=U1U1=bsp=bag=NULL; spok=NULL;/*dir_sp=NULL;*/ } fit_magic(X,sp,Si,H,gamma,scale,control,*rank_tol,yy,y0,y1,U1,V,d,b,&score,&norm,&delta,&rank,norm_const,n_score,nt); fit_call++; /* .... U1 and V are q by rank matrices, d is a dimension rank vector */ /* Now check that all derivatives are large enough that SD or Newton can be expected to work... */ if (mp>0&&!autoinit) { magic_gH(U1U1,M,K,VS,My,Ky,yK,hess,grad1,dnorm,ddelta,sp,d2norm,d2delta,S, U1,V,d,y1,rank,q,m,cS,cucS,gcv,gamma,scale,norm,delta,*n_score,norm_const); xx=1e-4*(1+fabs(score)); ok=1; /* reset to default any sp w.r.t. which score is flat */ if (L_exists) { /* transform to grad w.r.t. sp0 */ i=0;j=1;mgcv_mmult(grad,L,grad1,&j,&i,&mp,&j,&m); } else { p = grad;grad=grad1;grad1=p; } for (i=0;i0) { converged=0;iter=0; while (!converged) { iter++; if (iter>400) error(_("magic, the gcv/ubre optimizer, failed to converge after 400 iterations.")); if (iter>1||(autoinit&&!def_supplied)) ok=1; /* try out step */ else ok=0; /* no step to try yet */ try=0; if (use_sd) step=sd_step; else step=n_step; while (ok) /* try out step, shrinking it if need be */ { try++; if (try==4&&!use_sd) {use_sd=1;step=sd_step;} for (i=0;i3) /* test for convergence */ { converged=1; if (d_score> *tol*(1+min_score)) converged=0; for (xx=0.0,i=0;ipow(*tol,1/3.0)*(1+fabs(min_score))) converged=0; if (try==max_half) converged=1; /* can't improve score */ if (converged) { msg=sqrt(xx*xx/mp);if (try==max_half) step_fail=1;} } /* now get derivatives */ { if (L_exists) { i=0;j=1;mgcv_mmult(sp,L,sp0,&i,&i,&m,&j,&mp); /* form sp = L sp0 */ for (p=sp,p1=lsp0,p2=sp+m;pxx) xx=fabs(n_step[i]); if (xx>5.0) /* scale step to max component length 5 */ { xx=5.0/xx;for (i=0;i0) {... )*/ /* prepare ``outputs''... */ /* now get rV (in unpivoted space) */ for (p2=V,p1=d;p10) {FREE(sp);free2d(Si);} /* unpivot R from QR factor of X */ for (i=0;i #include #include #include #include "mgcv.h" void coxpred(double *X,double *t,double *beta,double *off,double *Vb,double *a,double *h,double *q, double *tr,int *n,int *p, int *nt,double *s,double *se) { /* Function to predict the survivor function for the new data in X (n by p), t, given fit results in a, h, q, Vb, and original event times tr (length nt). The new data are in descending time order on entry, as is tr. On exit n - vectors s and se contain the estimated survival function and its se. */ double eta,*p1,*p2,*p3,*v,*pv,*pa,x,vVv,hi,exp_eta; int ir=0,i=0; v = (double *)CALLOC((size_t)*p,sizeof(double)); for (i=0;i<*n;i++) { /* loop through new data */ while (ir < *nt && t[i]0) for (i=0;i<*n;i++) gamma[i] = exp(eta[i]); else for (p1=gamma,p2=p1 + *n;p10) { gamma_p[j] = gamma_p[j-1]; gamma_np[j] = gamma_np[j-1]; /* copy b^+_{j-1}, bj1, into b^+_j, bj */ for (p1=bj,p2=p1 + *p;p1=0;j--) { /* back recursion, forwards in time */ y = dc[j]; x = y/gamma_p[j]; y/=gamma_np[j]; h[j] = h[j+1] + x; km[j] = km[j+1] + y; /* kaplan meier hazard estimate */ x /= gamma_p[j]; q[j] = q[j+1] + x; /* now accumulate the a vectors into X for return */ i = j * *p; //for (aj=X+i,aj1=p1=aj+ *p,p2=b+i;aj=0) { b_p = (double *)CALLOC((size_t)*p,sizeof(double)); A_p = (double *)CALLOC((size_t)(*p * *p),sizeof(double)); } /* form exponential of l.p. */ for (i=0;i<*n;i++) gamma[i] = exp(eta[i]); if (*deriv>0) { /* prepare for first derivatives */ /* Get basic first derivatives given d1beta */ d1eta = (double *)CALLOC((size_t)(*n * *n_sp),sizeof(double)); mgcv_mmult(d1eta,X,d1beta,&tB,&tC,n,n_sp,p); p1=d1gamma = (double *)CALLOC((size_t)(*n * *n_sp),sizeof(double)); p2=d1eta; for (j=0;j<*n_sp;j++) for (i=0;i<*n;i++) { *p1 = *p2 * gamma[i]; p1++; p2++; } /* accumulation storage */ d1gamma_p = (double *)CALLOC((size_t)*n_sp,sizeof(double)); d1b_p = (double *)CALLOC((size_t)(*n_sp * *p),sizeof(double)); } if (*deriv>2) { /* prepare for second derivative calculations */ /* Basic second derivative derived from d2beta */ nhh = *n_sp * (*n_sp+1) / 2; /* elements in `half hessian' */ d2eta = (double *)CALLOC((size_t)(*n * nhh),sizeof(double)); mgcv_mmult(d2eta,X,d2beta,&tB,&tC,n,&nhh,p); p1=d2gamma = (double *)CALLOC((size_t)(*n * nhh),sizeof(double)); p2=d2eta; for (j=0;j<*n_sp;j++) { /* create d2gamma */ for (k=j;k<*n_sp;k++) { p3 = d1eta + j * *n; p4 = d1eta + k * *n; for (i=0;i<*n;i++) { *p1 = gamma[i] * (*p2 + *p3 * *p4); p1++;p2++;p3++;p4++; } } } /* end of d2gamma loop */ /* accumulation storage */ d2gamma_p = (double *)CALLOC((size_t) nhh,sizeof(double)); d2b_p = (double *)CALLOC((size_t)( nhh * *p),sizeof(double)); } if (*deriv>0) { /* Derivatives of H are required */ /* create storage for accumulating derivatives */ d1A_p = (double *)CALLOC((size_t)(*n_sp * *p * *p),sizeof(double)); /* clear incoming storage */ for (j = *n_sp * *p * *p,k=0;k2) { d2ldA_p = (double *)CALLOC((size_t)(nhh * *p),sizeof(double)); for (j = nhh * *p,k=0;k= 0) { for (k=0;k<*p;k++) b_p[k] += gamma[i]*X[i + *n * k]; if (d[i]==1) for (k=0;k<*p;k++) g[k] += X[i + *n * k]; /* and second derivatives */ for (k = 0;k < *p;k++) for (m = k;m < *p ;m++) A_p[k + *p *m] += gamma[i]*X[i + *n * k] * X[i + *n * m]; } /* derivatives w.r.t. smoothing parameters */ if (*deriv >0 ) { /* first derivative stuff only */ for (k=0;k<*n_sp;k++) d1gamma_p[k] += d1gamma[i + *n * k]; for (m=0;m<*n_sp;m++) { xx = d1gamma[i + *n * m]; for (k=0;k<*p;k++) d1b_p[k + *p * m] += xx * X[i + *n * k]; } } /* end of first derivative accumulation */ if (*deriv>2) { /* second derivative accumulation */ off = 0; for (m=0;m<*n_sp;m++) for (k=m;k<*n_sp;k++) { /* second derivates loop */ d2gamma_p[off] += d2gamma[i+ off * *n]; for (l=0;l<*p;l++) d2b_p[l + off * *p] += d2gamma[i+ off * *n] * X[i + *n * l]; off++; } /* end k-loop */ } if (*deriv>0) { /* H derivatives needed */ for (m=0;m<*n_sp;m++) { /* First derivatives of A_p */ xx = d1gamma[i + *n * m]; for (k = 0;k < *p;k++) for (l = k;l < *p ;l++) d1A_p[k + *p * l + m * *p * *p] += xx * X[i + *n * k] * X[i + *n * l]; } if (*deriv>2) { off = 0; for (m=0;m<*n_sp;m++) for (k=m;k<*n_sp;k++) { /* second derivates of leading diagonal of A_p loop */ for (l=0;l<*p;l++) d2ldA_p[l + off * *p] += d2gamma[i+ off * *n] * X[i + *n * l] * X[ i + *n *l]; off++; } /* end m/k -loop */ } } i++; } /* finished getting this event's information */ lpl += eta_sum - dr * log(gamma_p); if (*deriv>=0) { for (k=0;k<*p;k++) g[k] += - dr/gamma_p * b_p[k]; for (k = 0;k < *p;k++) for (m = k;m < *p ;m++) H[k + *p * m] += - dr * A_p[k + *p *m] /gamma_p + dr * b_p[k]*b_p[m]/(gamma_p*gamma_p); } if (*deriv>0) { /* need derivatives of H */ for (m=0;m<*n_sp;m++) { /* first derivatives of H */ xx0 =dr/gamma_p; xx = d1gamma_p[m]*xx0/gamma_p; xx1 = xx0/gamma_p; xx2 = xx1*2*d1gamma_p[m]/gamma_p; for (k = 0;k < *p;k++) for (l = k;l < *p ;l++) { off = k + *p * l + m * *p * *p; d1H[off] += xx1 * (d1b_p[k + *p *m] * b_p[l] + b_p[k] * d1b_p[l + *p *m]) - xx2 * b_p[k] * b_p[l] + xx * A_p[k + *p * l] - xx0 * d1A_p[off]; } } /* m-loop end */ if (*deriv>2) { xx = dr/gamma_p; xx0 = xx/gamma_p; /* dr/gamma_p^2 */ xx1 = xx0/gamma_p; /* dr/gamma_p^3 */ xx2 = xx1/gamma_p; off = 0; for (m=0;m<*n_sp;m++) { xx3 = -2*xx1*d1gamma_p[m]; for (k=m;k<*n_sp;k++) { /* second derivates of leading diagonal of H */ for (l=0;l<*p;l++) { d2H[l + off * *p] += xx3 * (A_p[l + *p *l] * d1gamma_p[k] + 2 * d1b_p[l + *p * k] * b_p[l]) + xx0 * (d1A_p[l + l * *p + m * *p * *p] * d1gamma_p[k] + A_p[l + *p * l] * d2gamma_p[off] + d2b_p[l + off * *p] * b_p[l] + 2 * d1b_p[l + *p * k] * d1b_p[ l + *p * m] + b_p[l] * d2b_p[l + off * *p]) + xx0 * d1gamma_p[m] * d1A_p[l + l * *p + k * *p * *p] - xx * d2ldA_p[l + off * *p] + 6 * xx2 * d1gamma_p[m] * b_p[l] * b_p[l] * d1gamma_p[k] - 2 * xx1 * (2*d1b_p[l + *p * m] * b_p[l] * d1gamma_p[k] + b_p[l]*b_p[l]*d2gamma_p[off]); } off++; } /* end k -loop */ } /* end m - loop */ } /* end if (*deriv>2) */ } /* end of H derivatives */ } /* end of j loop (work back in time) */ for (k=0;k<*p;k++) for (m=0;m1) for (m=0;m<*n_sp;m++) { off = *p * *p * m; for (k = 0;k < *p;k++) for (l = 0;l < k ;l++) d1H[k + *p * l + off] = d1H[l + *p * k + off]; } if (*deriv>=0) { FREE(A_p);FREE(b_p);} FREE(gamma); if (*deriv > 0) { /* clear up first derivative storage */ FREE(d1eta);FREE(d1gamma); FREE(d1gamma_p);FREE(d1b_p); FREE(d1A_p); } if (*deriv > 2) { /* clear up second derivative storage */ FREE(d2eta);FREE(d2gamma); FREE(d2gamma_p);FREE(d2b_p); FREE(d2ldA_p); } *lp = lpl; } /* end coxlpl */ mgcv/src/mgcv.c0000755000176200001440000004546413534130535013117 0ustar liggesusers/* Source code for mgcv.dll/.so multiple smoothing parameter estimation code, suitable for interfacing to R Copyright (C) 2000-2012 Simon N. Wood simon.wood@r-project.org This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. (www.gnu.org/copyleft/gpl.html) You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #include #include #include #include #include #include "tprs.h" #include "mgcv.h" #include "matrix.h" #include "qp.h" #include "general.h" #define round(a) ((a)-floor(a) <0.5 ? (int)floor(a):(int) floor(a)+1) /* The following are some rather ancient routines used to set up an example additive model using regression (cubic) splines, via RGAMsetup(). */ void RUnpackSarray(int m,matrix *S,double *RS) /* unpacks the R array RS into an array of matrices initialized to the correct dimensions let kk = sum_{i=0}^k S[i].r*S[i].c Then the kth matrix starts at element kk of RS and stops at element k(k+1) ... let this extracted array be M. S[k].M[i][j]=M[i+S[k].r*j] - in this way we ensure that M can be extracted straight to a matrix in R with A<-matrix(M,S[k].r,S[k].c) */ { int start,i,j,k; start=0; for (k=0;k=b ensuring monotonic change of the cubic spline interpolating (x_i,y_i) where h_i=x_{i+1}-x_i control indicates type of constraints: up=control/4 - 0 for decrease, 1 for increase lo=(control-up*4)/2 - 1 for lower bound, 0 no lower bound hi=(control-up*4-lo*2) - 1 for upper bound, 0 no upper bound control = 4*up+2*lo+hi */ { long i,j,n; int up,lo,hi; double m; matrix h,D; h=initmat(x->r-1,1L); n=h.r; for (i=0;iV[i+1]-x->V[i]; D=getD(h,0); up=control/4;control=control%4; lo=control/2;control=control%2; hi=control; if (up) m= -1.0; else m=1.0; (*A)=initmat(4*n+hi+lo,n+1); for (i=0;iM[i][j]=(D.M[i][j]+3.0/h.V[i])*m; /**not certain of d.M update**/ A->M[i+n][j]=(D.M[i+1][j]+3.0/h.V[i])*m; A->M[i+2*n][j]=m; A->M[i+3*n][j]= -D.M[i][j]*m; } else if (j==(i+1)) { A->M[i][j]=(D.M[i][j]-3.0/h.V[i])*m; A->M[i+n][j]=(D.M[i+1][j]-3.0/h.V[i])*m; A->M[i+2*n][j]= -m; A->M[i+3*n][j]= -D.M[i][j]*m; } else { A->M[i][j]=D.M[i][j]*m; A->M[i+n][j]=D.M[i+1][j]*m; A->M[i+2*n][j]=0.0; A->M[i+3*n][j]= -D.M[i][j]*m; } } } *b = initmat(A->r,1L); if (lo) { for (j=0;jM[4*n][j]=0.0; if (up) A->M[4*n][0]=1.0; else A->M[4*n][n]=1.0; b->V[4*n]=lower; } if (hi) { for (j=0;jM[4*n][j]=0.0; if (up) A->M[4*n+lo][n]=-1.0; else A->M[4*n+lo][0]=-1.0; b->V[4*n+lo]=upper; } freemat(D); freemat(h); } void getFS(double *x,int n,double *S,double *F) { /* x contains ascending knot sequence for a cubic regression spline Routine finds wigglness penalty S and F such that F' maps function values at knots to second derivatives. See Wood 2006 section 4.1.2. F and S are n by n. F is F' in 4.1.2 notation. */ double *D,*ldB,*sdB,*h,*Di,*Di1,*Di2,*Fp,*Sp,a,b,c; int i,j,n1,n2; /* create knot spacing vector h */ h = (double *)CALLOC((size_t)(n-1),sizeof(double)); for (i=1;i3) { a = -1/h[0] - 1/h[1];b = 1/h[1]; /* row 1 */ for (Sp=S+1,Di1=D+1,Di=D,i=0;ikmax) { extrapolate=1; } else if (i>0 && fabs(xlast-xi) < 2*h) { /* use simple direct search */ while (xi <= xk[j] && j > 0) j--; while (xi > xk[j+1] && j < *nk-2) j++; /* next line should not be needed, except under dodgy use of fpu registers during optimization... */ if (j<0) j=0; if (j > *nk-2) j = *nk - 2; /* now xk[j] <= x[i] <= xk[j+1] */ } else { /* bisection search required */ j=0;jup=*nk-1; while (jup-j>1) { jmid = (jup+j) >> 1; /* a midpoint */ if (xi > xk[jmid]) j = jmid; else jup = jmid; } /* now xk[j] <= x[i] <= xk[j+1] */ } /* end of bisection */ /* knot interval containing x[i] now known. Compute spline basis */ if (extrapolate) { /* x[i] is outside knot range */ if (xikmax */ j = *nk-1; h = kmax - xk[j-1]; xik = xi - kmax; cjm= xik*h/6; cjp = xik*h/3; Xp = X + i; /* ith row of X */ for (Fp1 = F+ j * *nk,Fp = Fp1 - *nk,k=0;k < *nk;k++,Xp += *n,Fp++) *Xp = cjm * *Fp + cjp * *Fp1 ; X[i + *n * (*nk-2)] += - xik/h; X[i + *n * (*nk-1)] += 1+ xik/h; } } else { /* routine evaluation */ xj = xk[j];xj1=xk[j+1]; h = xj1-xj; /* interval width */ ajm = (xj1 - xi);ajp = (xi-xj); cjm = (ajm*(ajm*ajm/h - h))/6; cjp = (ajp*(ajp*ajp/h - h))/6; ajm /= h;ajp /= h; Xp = X + i; /* ith row of X */ for (Fp = F+ j * *nk, Fp1 = F+(j+1)* *nk,k=0;k < *nk;k++,Xp += *n,Fp++,Fp1++) *Xp = cjm * *Fp + cjp * *Fp1; Xp = X + i + j * *n; *Xp += ajm; Xp += *n; *Xp += ajp; } /* basis computation complete */ xlast=xi; } } /* end crspl */ void MinimumSeparation(double *x,int *n, int *d,double *t,int *m,double *dist) { /* For each of n ppoints point x[i,] calculates the minimum Euclidian distance to a point in m by d matrix t. These distances are stored in dist. */ int one=1,*ni; kdtree_type kd; kd_tree(t,m,d,&kd); /* build kd tree for target points */ ni = (int *)CALLOC((size_t)*n,sizeof(int)); k_newn_work(x,kd,t,dist,ni,n,m,d,&one); // for (i=0;i<*n;i++) { // k = closest(&kd,t,x + i * *d,*m,&j,-1); /* index of nearest neighbour of x[i,] */ // dist[i] = xidist(x + i * *d,t,k,*d, *m); /* distance to this nearest neighbour */ //} FREE(ni); free_kdtree(kd); } void MinimumSeparation_old(double *gx,double *gy,int *gn,double *dx,double *dy, int *dn,double *dist) /* For each point gx[i],gy[i] calculates the minimum Euclidian distance to a point in dx[], dy[]. These distances are stored in dist. Aweful routine: O(gn * dn) cost!! */ { double sep,xx,yy,*dum,*xdum,*ydum; int n,m; n = *gn;m = *dn; for (dum=dist;dum < dist + n; dum++,gx++,gy++) { xx= *gx - *dx;yy = *gy - *dy;*dum = xx*xx + yy*yy; /* first separation */ for (xdum=dx+1,ydum=dy+1;xdum < dx + m;xdum++,ydum++) { xx= *gx - *xdum;yy = *gy - *ydum;sep = xx*xx + yy*yy; /* subsequent separations */ if (sep < *dum) *dum = sep; } *dum = sqrt(*dum); } } void RuniqueCombs(double *X,int *ind,int *r, int *c) /* X is a matrix. This routine finds its unique rows and strips out the duplicates. This is useful for finding out the number of unique covariate combinations present in a set of data. */ { matrix B,Xd; int i,*ind1; B=Rmatrix(X,(long)(*r),(long)(*c)); Xd=initmat(B.r,B.c+1); Xd.c--;mcopy(&B,&Xd);freemat(B);Xd.c++; for (i=0;i= b & Af p = "constant" where B = \sum_{i=1}^m \theta_i S_i and W=diag(w) - in fact S_i are not stored whole - rather the smallest non-zero sub-matrix of each S_i is stored in a densely packed form in S[]: see routines RpackSarray() and RUnpackSarray() for details of the sub-matrix packing. off[i],off[i] is the location within the full S_i to insert the sub-matrix actually stored which is of dimension dim[i] by dim[i]. W = diag(w) on exit p contains the best fit parameter vector. */ { matrix y,X,p,w,Ain,Af,b,*S; int n,np,i,*active; np=nar[1];n=nar[0]; /* unpack from R into matrices */ X=Rmatrix(Xd,(long)n,(long)np); p=Rmatrix(pd,(long)np,1L); y=Rmatrix(yd,(long)n,1L); w=Rmatrix(wd,(long)n,1L); if (nar[2]>0) Ain=Rmatrix(Aind,(long)nar[2],(long)np); else Ain.r=0L; if (nar[3]>0) Af=Rmatrix(Afd,(long)nar[3],(long)np); else Af.r=0L; if (nar[2]>0) b=Rmatrix(bd,(long)nar[2],1L);else b.r=0L; if (*m) S=(matrix *)CALLOC((size_t) *m,sizeof(matrix)); else S=NULL; /* avoid spurious compiler warning */ for (i=0;i< *m;i++) S[i]=initmat((long)dim[i],(long)dim[i]); RUnpackSarray(*m,S,Sd); //if (nar[4]) H=initmat(y.r,y.r); else H.r=H.c=0L; active=(int *)CALLOC((size_t)(p.r+1),sizeof(int)); /* array for active constraints at best fit active[0] will be number of them */ /* call routine that actually does the work */ PCLS(&X,&p,&y,&w,&Ain,&b,&Af,S,off,theta,*m,active); /* copy results back into R arrays */ for (i=0;i #include #include #include #include "matrix.h" #include "qp.h" #include "general.h" #include "mgcv.h" #define DELMAX 35 #define max(a,b) (((a) > (b)) ? (a) : (b)) #define min(a,b) (((a) < (b)) ? (a) : (b)) #define round(a) ((a)-floor(a) <0.5 ? (int)floor(a):(int) floor(a)+1) matrix addconQT(Q,T,a,u) matrix *Q,T,a,*u; /* A constraint, a (a row vector), is added to the QT factorization of the working set. T must have been initialised square, and then had T.r set to correct length. */ { int q,i,j; double la,ra=0.0,*cV,*bV,*T1V; matrix b,c; c=initmat(Q->r,1);b=initmat(Q->r,1);(*u)=initmat(Q->r,1); for (i=0;iM[j][i]; la=dot(c,c); cV=c.V;bV=b.V; q=T.c-T.r-1; if (q!=0) { for (i=q+1;i0.0) bV[q]= -bV[q]; householder(u,c,b,q); Hmult((*Q),(*u)); } else for (i=0;ic-T->r-1 rows to store the Givens rotations and must be initialized outside the routine. */ { int q,i,j; double Qi,r,cc,ss,*bV,*sV,*cV,**QM,*QV,bb,bb1; matrix b; b.V=T->M[T->r]; b.r=Q->r;b.c=1; for (i=0;ic;i++) b.V[i]=0.0; for (i=0;ir;j++) b.V[i]+=Q->M[j][i]*a->V[j]; /* now calculate a series of Givens rotations that will rotate the null basis so that it is orthogonal to new constraint a */ bV=b.V;cV=c->V;sV=s->V;QM=Q->M; q=T->c-T->r-1; /* number of Givens transformations needed */ for (i=0;ir;j++) { QV=QM[j]; Qi=QV[i]; QV[i]=cc*Qi + ss*QV[i+1]; QV[i+1]=ss*Qi - cc*QV[i+1]; } } T->r++; } void LSQPaddcon(matrix *Ain,matrix *Q,matrix *T,matrix *Rf,matrix *Py,matrix *PX, matrix *s,matrix *c,int sth) /* Adds the sth row of Ain to the avtive set, updates Q and T using a sequence of T->c-T->r-1 Givens rotations from the right, coefficients of which are stored in s and c. The ith rotation acts on elements (i,i+1) (i=0,1,...). Updates the upper triangular (lower left 0) matrix Rf = PXQ, by applying the above Givens rotations from the right (updating Q) which introduces elements on the sub diagonal of Rf; these subdiaogonal elements are then zeroed using Givens rotations from the left, by way of updating P. Hence Py and PX can be updated at the same time. */ { matrix a; double RfMji,*RfV,*RfV1,ss,cc,r,x1,x2; int i,j,k; a.V=Ain->M[sth];a.r=Ain->c;a.c=1; /* vector containing sth constraint */ s->r=T->c-T->r-1; /* number of Givens rotations about to be returned */ /* Update Q and T and return Givens rotations required to do so ....*/ GivensAddconQT(Q,T,&a,s,c); /* Now apply the rotations from the right to Rf....*/ for (i=0;ir;i++) { cc=c->V[i];ss=s->V[i]; k=i+2;if (k>Rf->r) k--; for (j=0;jM[j]; RfMji=RfV[i]; RfV[i]=cc*RfMji+ss*RfV[i+1]; RfV[i+1]=ss*RfMji - cc*RfV[i+1]; } } /* Now zero the subdiagonal elements that have just been introduced, and apply the Givens rotations from the left, used to do this, to Py and PX */ for (i=0;ir;i++) /* work through the extra subdiagonal elements */ { /* this will act on rows i and i+1, zeroing i+1,i - work out coefficients */ RfV=Rf->M[i];RfV1=Rf->M[i+1]; x1=RfV[i];x2=RfV1[i]; r=sqrt(x1*x1+x2*x2);ss=x2/r;cc=x1/r; Rf->M[i][i]=r;Rf->M[i+1][i]=0.0; for (j=i+1;jc;j++) /* apply rotation along the rows */ { x1=RfV[j];x2=RfV1[j]; RfV[j]=cc*x1+ss*x2; RfV1[j]=ss*x1-cc*x2; } /* Apply this rotation to Py */ x1=Py->V[i];x2=Py->V[i+1]; Py->V[i]=cc*x1+ss*x2; Py->V[i+1]=ss*x1-cc*x2; /* and apply the same rotation to PX */ for (j=0;jc;j++) /* work along the rows */ { x1=PX->M[i][j];x2=PX->M[i+1][j]; PX->M[i][j]=cc*x1+ss*x2; PX->M[i+1][j]=ss*x1-cc*x2; } } } int LSQPstep(int *ignore,matrix *Ain,matrix *b,matrix *p1,matrix *p,matrix *pk) /* This is the stepping routine for the constrained least squares fitting routine. It should be faster than step, but more or less does the same thing. The return value is -1 for a minimum, otherwise the row of Ain containing the constraint to add is returned. ignore[i] should be set to 1 to ignore row i of Ain, to 0 to include it. Starting from p a step is taken to p+pk, if this would violate any constraints in the working set, then a step is taken from p along pk, to the closest constraint. The constraints are Ain p >= b. On exit: p1 contains the new parameter vector; the return value is -1 for a minimum, otherwise the constraint that needs to be added (i.e. the row of Ain) */ { double Ap1,ap,apk,alpha,alphamin,*AV,*pV,*p1V,*pkV; int imin,i,j; alphamin=1.0;imin= -1; p1V=p1->V;pV=p->V;pkV=pk->V; for (i=0;ir;i++) p1V[i]=pV[i]+pkV[i]; /* step all the way to minimum */ for (i=0;ir;i++) /* work through the constraints */ { AV=Ain->M[i]; if (!ignore[i]) /* skip any already in working set */ { Ap1=0.0; for (j=0;jc;j++) Ap1+=AV[j]*p1V[j]; /* form A p1 = A(p+pk) */ if ((b->V[i]-Ap1)>0.0) /* does p+pk violate the ith constraint? */ { ap=0.0;apk=0.0; /* working out quantities needed to find distance to constraint from p */ for (j=0;jc;j++) { ap+=AV[j]*pV[j]; apk+=AV[j]*pkV[j]; } if (fabs(apk)>0.0) { alpha=(b->V[i]-ap)/apk; /* p + alpha*pk is on the ith constraint */ if (alphar;j++) p1V[j]=pV[j]+alphamin*pkV[j]; /* 2/2/97 - avoids distance calc for all that would violate full step */ } } } } } return(imin); } void LSQPdelcon(matrix *Q,matrix *T,matrix *Rf,matrix *Py,matrix *PX,int sth) /* This routine deletes row s from the active set matrix, A, say, where AQ=[0,T] and T is reverse lower triangular (upper left is zero). It updates Q and T using Givens rotations from the right. These rotations induce subdiagonal elements in Rf=PXQ from column Rf->c-T->r to column Rf->c-s+2, where T->r is the number of active constraints before deletion. Note however that the Givens rotations that update Q and T, have to be applied in an order that works back through the columns of Rf=PXQ - this has the potential to produce a triangular block of elements below the diagonal, if they are all applied before applying the update rotations for P. Hence the appropriate thing to do is to apply each rotation from the left to Rf, as it is obtained and then work out the Givens rotation from the left that will immediately zero the unwanted subdiagonal element - this being an update of P, which should immediately be applied to PX and Py. */ { int i,j,colj,coli,k,Tr,Tc,Qr,T1r,T1c; double r,s,c,xi,xj,**TM,**QM,*TV,*QV,*T1V,*RfV,*RfV1; Tr=T->r;TM=T->M;QM=Q->M;Tc=T->c;Qr=Q->r; for (i=sth+1;iM[j]; /* row to apply rotation to */ xi=RfV[coli]; RfV[coli]= -c*xi+s*RfV[colj]; RfV[colj]=s*xi+c*RfV[colj]; } /* There is now an unwanted element at row colj, column coli */ /* Calculate a rotation from the right that will zero the extra element */ xi=Rf->M[coli][coli];xj=Rf->M[colj][coli]; /* xj to be zeroed */ r=sqrt(xi*xi+xj*xj); s=xj/r;c=xi/r; /* Givens coefficients to zero xj into xi */ Rf->M[coli][coli]=r;Rf->M[colj][coli]=0.0; /* Now apply to rest of row from column colj (column coli already done) */ RfV=Rf->M[coli];RfV1=Rf->M[colj]; for (j=colj;jc;j++) { xi=RfV[j];xj=RfV1[j]; RfV[j]=c*xi+s*xj; RfV1[j]=s*xi-c*xj; } /* And apply this rotation from the right to Py and PX */ /* Apply this rotation to Py */ xi=Py->V[coli];xj=Py->V[colj]; Py->V[coli]=c*xi+s*xj; Py->V[colj]=s*xi-c*xj; /* and apply the same rotation to PX */ for (j=0;jc;j++) /* work along the rows */ { xi=PX->M[coli][j];xj=PX->M[colj][j]; PX->M[coli][j]=c*xi+s*xj; PX->M[colj][j]=s*xi-c*xj; } } /* Now actually remove the extra row from T - this could be done awefully efficiently */ /* by shuffling the pointers to rows, but it would probably end in tears, so I haven't */ T->r--;T1r=T->r;T1c=T->c; for (k=0;k l'[0,T]=g'Q, and to find l, solve l'T=x, where x is the last tk=T->r rows of g'Q - this also yields the minimum of ||A'l-g||, which is appropriate. Note that T passed to the routine actually contains [0,T] and the first fixed_cons rows of T relate to the fixed constraints (if any). p1 and y1 are workspace matrices of length p->r and X->r respectively The routine returns -1 if there are no -ve multiplier estimates, otherwise it returns the index of *Inequlity* constraint with the most negative one. fixed[i] is set to 1 if the corresponding inequlity constraint is to be left in the active set regardless of lagrange multiplier - this is part of a strategy to avoid repeatedly deleting constraints wrongly. */ { int i,j,tk; double x; tk=T->r; vmult(X,p,y1,0); /* form y1= Xp */ vmult(X,y1,p1,1); /* form p1 = X'Xp */ for (i=0;ir;i++) p1->V[i]+= -Xy->V[i]; /* form p1 = g = X'Xp - X'y */ /* now create the last tk=T->r elements of g'Q and store in y1 */ for (i=0;iV[i]=0.0; for (j=0;jr;j++) y1->V[i]+=p1->V[j]*Q->M[j][Q->c-tk+i]; } /* Now solve l'T=g'Q (where first tk rows of y1 contain g'Q).... */ for (i=tk-1;i>=fixed_cons;i--) /* work down through the the lagrange multipliers */ { x=0.0;for (j=i+1;jV[j]*T->M[j][T->c-i-1]; if (T->M[i][T->c-i-1]!=0.0) p1->V[i]=(y1->V[tk-i-1]-x)/T->M[i][T->c-i-1];else p1->V[i]=0.0; } /* Now look for the most negative multiplier for an inequlity constraint */ x=0.0;j=-1; for (i=fixed_cons;iV[i]V[i];} /* if (j==-1) if (p1->V[i]V[i];} */ /* only delete last constraint added if it has only -ve multiplier */ if (j!=-1) j -= fixed_cons; return(j); /* returns index of inequality constraint to delete */ } /***************************************************************************/ /* Main Public Routines. */ /***************************************************************************/ void QPCLS(matrix *Z,matrix *X, matrix *p, matrix *y,matrix *Ain,matrix *b,matrix *Af,int *active) /* This routine aims to fit linearly constrained least squares problems of the form: min ||Xp-y||^2 subject to Ain p>=b and Af p = constant *without* forming X'X directly. By suitable redefinition of X and y it's easy to perform weighted and/or penalized regressions using this routine...... The routine uses working matrices T, Q, Rf, PX and working vectors Py, Xy, pz, pk, Pd In addition the routine creates workspace for the various service routines called by it, in order to avoid excessive memory allocation and deallocation. The Algorithm is as follows... 1. Form the QT factorisation of Af: Af Q = [0,T] T reverse lower triangular (i.e top left 0). Q contains column bases for the null and range spaces of Af: Q=[Z,Y]. Apply Q to X to get XQ(=[XZ,XY]). Form Q explicitly to give ready access to the null space basis Z. 2. Perform QR decomposition: XQ = P'Rf where P is orthogonal and Rf is upper triangular (lower left 0). Hence Rf= PXQ=[PXZ,PXY], as required. Apply P to y to get Py. Apply P to X to get PX. 3. Form Pd = Py-PXp, and solve: minimise || R pz - Pd ||^2, where R is the first p->r-tk-Af->r rows and columns of Rf. Solution occurs when R pz=x and x is the first p->r - tk - Af->r rows of Pd. (Note that Gill et al. get the sign wrong for Pd.) 4. Evaluate pk=Z pz, and step along it to minimum (goto 6.) or constraint. 5. Add constraint to working set: update QT factorisation; update Rf; update Py and PX. Return to 3. 6. Evaluate Lagrange multipliers l where Ac'l=g and g=X'Xp-X'y - Ac is the active constraint matrix. Clearly g involves X'X, which is unfortunate, but I can't figure out a way around it - however, it is only the signs of l that matter, so hopefully this is not critical. If multipliers are all +ve goto 8. otherwise proceed.... 7. Delete the constraint with the most -ve multiplier, updating Q, T, Rf, Py and PX at the same time. Return to 3. 8. Convergence! A minimum has been achieved. Free the workspace matrices and vectors and the indexing arrays, obtain Z, and return. On exit active[] contains the number of active inequlity constraints in active[0], and the row number of these constraints in Ain in the remaining elements of active[], active must be initialized to length p.r+1 on entry. See documentation in service routines: LSQPlagrange(); LSQPaddcon(); LSQPdelcon(); (above) Rsolv() (in matrix.c) for further details on steps 6, 5, 7 and 3. The approach is taken from Gill, Murray and Wright (1981) Practical Optimization page 180-181 Section 5.3.3. (But note wrong signs on p181 first display equation and definition of d_k) Routine has been tested against less numerically stable alternative using QP(). 20/11/99 */ { matrix Q,T,Rf,PX,Py,a,P,p1,s,c,Xy,y1,u,Pd,pz,pk; int k,i,j,tk,*I,*ignore,iter=0,*fixed,*delog,maxdel=100; double x; I=(int *)CALLOC((size_t) p->r,sizeof(int)); /* I[i] is the row of Ain containing ith active constraint */ fixed=(int *)CALLOC((size_t) p->r,sizeof(int)); /* fixed[i] is set to 1 when the corresponding inequality constraint is to be left in regardless of l.m. estimate */ ignore=(int *)CALLOC((size_t) Ain->r,sizeof(int)); /* ignore[i] is 1 if ith row of Ain is in active set, 0 otherwise */ delog=(int *)CALLOC((size_t) Ain->r,sizeof(int)); /* counts up number of times a constraint is deleted */ p1=initmat(p->r,1); /* a working space vector for stepping & lagrange */ y1=initmat(y->r,1); /* a work space vector for lagrange */ s=initmat(p->r,1);c=initmat(p->r,1); /* working space vectors for Givens rotation */ Xy=initmat(p->r,1); /* vector storing X'y for use in lagrange multiplier calculation */ vmult(X,y,&Xy,1); /* form X'y */ Rf=initmat(X->r,X->c); /* Rf=PXQ, where P and Q are orthogonal */ mcopy(X,&Rf); /* initialize Rf while P and Q are identity matrices */ T=initmat(p->r,p->r); /* initialised to max possible size */ Q=initmat(p->r,p->r); /* required for access to Z for null space to full space transform */ /* initialize Q, T and Rf using fixed constraints (if any) .... */ for (i=0;ir;i++) for (j=0;jr;j++) Q.M[i][j]=0.0; for (i=0;ir;i++) Q.M[i][i]=1.0; T.r=0;a.r=1;a.c=Af->c; for (i=0;ir;i++) { a.V=Af->M[i]; T=addconQT(&Q,T,a,&u); /* adding constraint from Af to working set */ Hmult(Rf,u); /* updating Rf (=XQ, at present) */ freemat(u); /* freeing u created by addconQT() */ } /* Now Form Rf, proper. i.e. PXQ, using QR factorization */ P=initmat(Rf.c,Rf.r); QR(&P,&Rf); /* Rf now contains Rf=PXQ (on entry it contained XQ) */ Py=initmat(y->r,1);mcopy(y,&Py); OrthoMult(&P,&Py,0,(int)P.r,0,1,1); /* Form Py */ PX=initmat(X->r,X->c);mcopy(X,&PX); OrthoMult(&P,&PX,0,(int)P.r,0,1,1); /* Form PX */ freemat(P); /* no longer needed */ P=initmat(b->r,1); /* used solely for feasibility checking */ Pd=initmat(y->r,1);pz=initmat(p->r,1);pk=initmat(p->r,1); tk=0; /* The number of inequality constraints currently active */ /*printf("\nLSQ");*/ while(1) { iter++; /* Form Pd=Py-PXp and minimize ||R pz - Pd|| */ vmult(&PX,p,&Pd,0); /* Pd = PXp */ for (i=0;ir-tk-Af->r; /* Restrict attention to QR factor of PXZ */ for (i=0;ir;Rf.c=X->c; /* Restore Rf */ pz.r=p->r-tk-Af->r; /* Find pk = Z pz, the search direction */ for (i=0;i-1) /* add a constraint to the working set and update Rf, Py and PX */ { I[tk]=k;ignore[k]=1; /* keeping track of what's in working set */ LSQPaddcon(Ain,&Q,&T,&Rf,&Py,&PX,&s,&c,k);tk++; if (delog[k]>maxdel) fixed[tk-1]=1; /*Rprintf("+");*/ } else /* it's a minimum - check lagrange multipliers */ { k=LSQPlagrange(X,&Q,&T,p,&Xy,&p1,&y1,fixed,(int)Af->r); if (k>-1) /* then a constraint must be deleted */ { LSQPdelcon(&Q,&T,&Rf,&Py,&PX,k+(int)Af->r); /* the Af.r added to k ensures that correct row of T deleted */ /*Rprintf("-");*/ /* update the fixed constraint list */ { for (i=k;i-1) /* updating indexing arrays */ { ignore[I[k]]=0; delog[I[k]]++; for (i=k;iV[i]V[i]; /*printf("P\n Worst feasibility violation %g",x);*/ /* create Z - this version is a full null space matrix, rather than sequence of rotations */ *Z=Q; Z->c -= tk; /* copy active constraint information to active */ active[0]=tk; for (i=0;i=b & Af p = "a constant vector" ...where B is a sum of m S[i] matrices multiplied by smoothing parameters theta[i]. The S[i]'s may be smaller than B (p->r by p->r) so S[i] is added to B starting at row and column off[i]. B must be non-negative definite, which means that the S[k]'s must be. W is the diagnoal matrix having w on the leading diagonal. In many applications the ith element of w will be the reciprocal of the variance associated with the ith element of i. The routine uses the fact that the problem can be re-written as.... minimise || Fp - z ||^2 Subject to Ain p >= b Af p = constant ... where F = [ X'W^0.5, B^0.5']' and z = [y'W^0.5, 0]'. This rewrite is performed and then QPCLS is called to obtain the solution. On exit active[] contains a list of the active inequlity constraints in elements 1->active[0]. This array should be initialized to length p.r+1 on entry. 20/11/99 */ { int i,j,k,n; matrix z,F,W,Z,B; double x,xx,*p1,*C; /* form transformed data vector z */ if (m>0) z=initmat(y->r+p->r,1);else z=initmat(y->r,1); W=initmat(w->r,1); for (i=0;ir;i++) { W.V[i]=sqrt(w->V[i]);z.V[i]=W.V[i]*y->V[i];} /* form transformed design matrix X */ F=initmat(z.r,p->r); /* first put in W^0.5X */ for (i=0;ir;i++) for (j=0;jc;j++) F.M[i][j]=W.V[i]*X->M[i][j]; /* add up the Penalties */ if (m>0) { //B=initmat(p->r,p->r); n = p->r; C = (double *)CALLOC((size_t)(n*n),sizeof(double)); for (k=0;kr rows of F */ for (p1=C,i=0;ir][i] = *p1; /* copy C' into the last p->r rows of F */ //for (i=0;ir][i]=C.M[i][j]; FREE(C); //freemat(B);//freemat(C); } /* printf("\ncond(F)=%g",condition(F));*/ /* Which means that the problem is now in a form where QPCLS can solve it.... */ QPCLS(&Z,&F,p,&z,Ain,b,Af,active); /* note that at present Z is full not HH */ // if (H->r==y->r) /* then calculate the influence matrix XZ(Z'F'FZ)^{-1}Z'X'W */ //{ freemat(W);W=initmat(Z.c,Z.c); // multi(4,W,Z,F,F,Z,1,1,0,0);invert(&W); /* Wildly inefficient!! */ // multi(5,*H,*X,Z,W,Z,*X,0,0,0,1,1); /* ditto */ // for (i=0;ir;i++) for (j=0;jc;j++) H->M[i][j]*=w->V[j]; //} /* working out value of objective at minimum */ B=initmat(z.r,1);matmult(B,F,*p,0,0); xx=0.0;for (i=0;i #include #include #include #include "mgcv.h" #ifdef OPENMP_ON #include #endif #define ANSI /*#define DEBUG*/ double trBtAB(double *A,double *B,int *n,int*m) /* form tr(B'AB) where A is n by n and B is n by m, m < n, basic point is that this is sum_ijk A_ik B_ij B_kj */ { double tr=0.0,x,*p,*p1,*p2; int j,k; for (j=0;j<*m;j++) for (k=0;k<*n;k++) { p = A + *n * k;p2 = p + *n; p1 = B + *n * j; x = B[k + j * *n]; for (;p0) { for (pa=A,pb=B,p1=pa + *r,pd=d;paj) j = rSncol[i]; j += *M0; /* work space needed */ work = (double *)CALLOC((size_t)j,sizeof(double)); Sb = (double *)CALLOC((size_t)*q,sizeof(double)); bt=0;ct=0;mgcv_mmult(work,E,beta,&bt,&ct,Enrow,&one,q); bt=1;ct=0;mgcv_mmult(Sb,E,work,&bt,&ct,q,&one,Enrow); /* S \hat \beta */ for (*bSb=0.0,i=0;i<*q;i++) *bSb += beta[i] * Sb[i]; /* \hat \beta' S \hat \beta */ if (*deriv <=0) {FREE(work);FREE(Sb);return;} work1 = (double *)CALLOC((size_t)j,sizeof(double)); Skb = (double *)CALLOC((size_t)*M * *q,sizeof(double)); for (p1=Skb,rSoff=0,i=0;i<*M;i++) { /* first part of first derivatives */ /* form S_k \beta * sp[k]... */ bt=1;ct=0;mgcv_mmult(work,rS + rSoff ,beta,&bt,&ct,rSncol+i,&one,q); for (j=0;j1) for (m=0;m < Mtot;m++) { /* Hessian */ bt=0;ct=0;mgcv_mmult(work1,E,b1 + m * *q,&bt,&ct,Enrow,&one,q); bt=1;ct=0;mgcv_mmult(work,E,work1,&bt,&ct,q,&one,Enrow); /* S dbeta/drho_m */ for (k=m;k < Mtot;k++) { km= k * Mtot + m ; mk= m * Mtot + k ; /* second derivatives needed */ /* d2beta'/drho_k drho_m S beta */ for (xx=0.0,p0=Sb,p1=Sb + *q;p0= *M0) { for (xx=0.0,p0=Skb + (k- *M0) * *q,p1=p0 + *q,p2= b1+ m * *q;p0= *M0) { for (xx=0.0,p0=Skb + (m - *M0) * *q,p1=p0 + *q,p2= b1 + k * *q;p0 pivot[i] row of unpivoted */ for (pd=dum,pd1=dum+*r,p1=p;pd ith row of pivoted */ for (pd=dum,pd1=dum+*r,p1=p;pd pivot[i] row of unpivoted */ for (i=0;i<*r;i++) p[i] = tau[i]; /* store unpivoted column in Xi */ } FREE(Qt); } /* end if (*get_inv) */ FREE(pivot);FREE(tau); return(ldet); } /* end qr_ldet_inv */ void get_detS2(double *sp,double *sqrtS, int *rSncol, int *q,int *M, int * deriv, double *det, double *det1, double *det2, double *d_tol, double *r_tol,int *fixed_penalty) /* Routine to evaluate log|S| and its derivatives wrt log(sp), in a stable manner, using an orthogonal transformation strategy based on QR decomposition. Inputs are: `sp' the array of smoothing parameters. `sqrtS' the `M' square root penalty matrices. The ith is `q' by `rSncol[i]'. They are packed one after the other. `deriv' is the order of derivatives required. 0,1 or 2. `d_tol' is the tolerance to use for grouping dominant terms. `r_tol' (<< d_tol) is the tolerance used for rank determination. `fixed_penalty' non-zero indicates that there is a fixed component of total penalty matrix S, the square root of which is in the final q * rSncol[M+1] elements of sqrtS. Outputs are: `det' the log determinant. `det1' M-array of derivatives of log det wrt log sp. `det2' M by M Hessian of log det wrt log sp. */ { double *R,*work,*tau,*rS1,*rS2, *S,*Si,*Sb,*B,*Sg,*p,*p1,*p2,*p3,*p4,*frob,max_frob,x,*spf,Rcond; int *pivot,iter,i,j,k,bt,ct,rSoff,K,Q,Qr,*gamma,*gamma1,*alpha,r,max_col,Mf,tot_col=0,left,tp; if (*fixed_penalty) { Mf = *M + 1; /* total number of components, including fixed one */ spf = (double *)CALLOC((size_t)Mf,sizeof(double)); for (i=0;i<*M;i++) spf[i]=sp[i]; spf[*M]=1.0; /* includes sp for fixed term */ } else {spf=sp;Mf = *M;} /* total number of components, including fixed one */ /* Create working copies of sqrtS, which can be modified: rS1 is repeatedly orthogonally transformed, while rS2 is row pivoted. */ if (*deriv) { /* only need to modify if derivatives needed */ for (j=i=0;imax_col) max_col=rSncol[i]; p = Si = (double *)CALLOC((size_t)*q * max_col * Mf,sizeof(double)); for (rSoff=i=0;imax_frob) max_frob=frob[i] * spf[i]; } /* Find sets alpha and gamma' */ for (i=0;i max_frob * *d_tol) { alpha[i] = 1;gamma1[i] = 0; /* deal with it now */ } else { alpha[i] = 0;gamma1[i] = 1; /* put it off */ } } else { /* wasn't in gamma, so not in alpha or gamma1 */ alpha[i] = gamma1[i] = 0; } } /* Form the scaled sum of the Si in alpha and get its rank by pivoted QR and condition estimation... */ for (p=Sb,p1=p + *q * Q;p 1) { r--;R_cond(Sb,&Q,&r,work,&Rcond);} Qr = Q-r; /* ... r is the rank of Sb, or any other positively weighted sum over alpha */ /* printf("\n iter = %d, rank = %d, Q = %d",iter,r,Q); printf("\n gamma = ");for (i=0;imax_col) max_col=rSncol[i]; } /* Initialize the sub-dominant set gamma and the counters */ K = 0; /* counter for coefs already deal with */ Q = *q; /* How many coefs left to deal with */ frob = (double *)CALLOC((size_t)Mf,sizeof(double)); gamma = (int *)CALLOC((size_t)Mf,sizeof(int)); /* terms remaining to deal with */ gamma1 = (int *)CALLOC((size_t)Mf,sizeof(int)); /* new gamma */ alpha = (int *)CALLOC((size_t)Mf,sizeof(int)); /* dominant terms */ for (i=0;imax_frob) max_frob=frob[i] * spf[i]; } /* Find sets alpha and gamma' */ n_gamma1=0; for (i=0;i max_frob * *d_tol) { alpha[i] = 1;gamma1[i] = 0; /* deal with it now */ } else { alpha[i] = 0;gamma1[i] = 1; n_gamma1++; /* put it off */ } } else { /* wasn't in gamma, so not in alpha or gamma1 */ alpha[i] = gamma1[i] = 0; } } /* Form the scaled sum of the Si in alpha and eigen-decompose it to get its rank */ if (n_gamma1) { /* stuff left in gamma1, so have to work out rank of contents of alpha */ for (p=Sb,p1=p+Q*Q;pev[Q-1] * *r_tol)) r++; } else { /* nothing left in gamma1, so... */ r=Q; } /* ... r is the rank of Sb, or any other positively weighted sum over alpha */ /* If Q==r then terminate (form S first if it's the first iteration) */ if (Q==r) { if (iter==1 ) { /* form S and Qf*/ for (p=Si,i=0;i0) { /* deal with upper right component B */ /* first copy out K by Q matrix B */ for (j=0;j0) { rSoff[0] = 0;for (m=0;m < *M-1;m++) rSoff[m+1] = rSoff[m] + rSncol[m]; } tid = 0; #ifdef OPENMP_ON #pragma omp parallel private(m,bt,ct,tid) num_threads(nthreads) #endif { /* parallel section start */ #ifdef OPENMP_ON #pragma omp for #endif for (m=0;m < *M;m++) { /* loop through penalty matrices */ #ifdef OPENMP_ON tid = omp_get_thread_num(); /* thread running this bit */ #endif bt=1;ct=0;mgcv_mmult(PtrSm + tid * *r * max_col,P,rS+rSoff[m] * *q,&bt,&ct,r,rSncol+m,q); /*rSoff += rSncol[m];*/ trPtSP[m] = sp[m] * diagABt(work + *n * tid,PtrSm + tid * *r * max_col, PtrSm + tid * *r * max_col,r,rSncol+m); /* sp[m]*tr(P'S_mP) */ det1[m + *M0] += trPtSP[m]; /* completed first derivative */ if (deriv2) { /* get P'S_mP */ bt=0;ct=1;mgcv_mmult(PtSP+ m * *r * *r,PtrSm + tid * *r * max_col, PtrSm+ tid * *r * max_col ,&bt,&ct,r,r,rSncol+m); } } } /* end of parallel section */ FREE(rSoff); /* Now accumulate the second derivatives */ // #ifdef OPENMP_ON //#pragma omp parallel private(m,k,km,mk,xx,tid,pdKK,p1,pTkm) num_threads(nthreads) //#endif if (deriv2) { /* start of parallel section */ //if (deriv2) #ifdef OPENMP_ON #pragma omp parallel for private(m,k,km,mk,xx,tid,pdKK,p1,pTkm) num_threads(nthreads) #endif for (m=0;m < Mtot;m++) { #ifdef OPENMP_ON tid = omp_get_thread_num(); /* thread running this bit */ #endif if (m==0) pTkm = Tkm; else pTkm = Tkm + (m * Mtot - (m*(m-1))/2) * *n; for (k=m;k < Mtot;k++) { km=k * Mtot + m;mk=m * Mtot + k; /* tr(Tkm KK') */ /*for (xx=0.0,pdKK=diagKKt,p1=pdKK + *n;pdKK= *M0 && k==m) det2[km] += trPtSP[m - *M0]; /* -sp[m]*tr(K'T_kKP'S_mP) */ if (m >= *M0) det2[km] -= sp[m - *M0]*diagABt(work + *n * tid,KtTK + k * *r * *r,PtSP + (m - *M0) * *r * *r,r,r); /* -sp[k]*tr(K'T_mKP'S_kP) */ if (k >= *M0) det2[km] -= sp[k - *M0]*diagABt(work + *n * tid,KtTK + m * *r * *r,PtSP + (k - *M0) * *r * *r,r,r); /* -sp[m]*sp[k]*tr(P'S_kPP'S_mP) */ if (k >= *M0 && m >= *M0) det2[km] -= sp[m - *M0]*sp[k - *M0]* diagABt(work + *n * tid,PtSP + (k - *M0) * *r * *r,PtSP + (m - *M0) * *r * *r,r,r); det2[mk] = det2[km]; } } } /* end of parallel section */ /* free up some memory */ if (deriv2) {FREE(PtSP);FREE(KtTK);} FREE(diagKKt);FREE(work); FREE(PtrSm);FREE(trPtSP); } /* end get_ddetXWXpS */ void get_trA2(double *trA,double *trA1,double *trA2,double *P,double *K,double *sp, double *rS,int *rSncol,double *Tk,double *Tkm,double *w,int *n,int *q, int *r,int *M,int *deriv,int *nt) /* obtains trA and its first two derivatives wrt the log smoothing parameters * P is q by r * K is n by r * U1 is q by r * this routine assumes that sp contains smoothing parameters, rather than log smoothing parameters. * If deriv is 0 then only tr(A) is obtained here. * This version uses only K and P, and is for the case where expressions involve weights which are reciprocal variances, not the squares of weights which are reciprocal standard deviations. * Note that tr(A) = tr(KK') and it is tempting to view diag(K'K) as giving the edfs of the parameters, but this seems to be wrong. It gives the edfs for R \beta, where R is (pseudo) inverse of P. * uses nt threads via openMP. Assumes thread number already set on entry and nt already reset to 1 if no openMP support. */ { double *diagKKt,*diagKKtKKt,xx,*KtTK,*KtTKKtK,*KKtK,*KtK,*work,*pTk,*pTm,*pdKKt,*pdKKtKKt,*p0,*p1,*p2,*p3,*pd, *PtrSm,*PtSP,*KPtrSm,*diagKPtSPKt,*diagKPtSPKtKKt,*PtSPKtK, *KtKPtrSm, *KKtKPtrSm,*Ip,*IpK/*,lowK,hiK*/; int i,m,k,bt,ct,j,one=1,km,mk,*rSoff,deriv2,neg_w=0,tid=0; #ifdef OMP_REPORT Rprintf("get_trA2 (d=%d)...",*deriv); #endif if (*deriv==2) deriv2=1; else deriv2=0; /* Get the sign array for negative w_i */ Ip = (double *)CALLOC((size_t)*n,sizeof(double)); for (p0=w,p1=p0+ *n,p2=Ip;p0=0;k--) { for (xx=0.0,j=k+1;j <=i;j++) xx += R[k + j * *r] * rc[j]; rc[k]=(eye-xx)/R[k + k * *r]; eye=0; } for (k=i+1;k<*c;k++) rc[k]=0.0; rc += *ri; } } void pearson2(double *P, double *P1, double *P2, double *y,double *mu,double *V, double *V1,double *V2,double *g1,double *g2, double *p_weights,double *eta1, double *eta2,int n,int M,int deriv, int deriv2) /* Alternative calculation of the derivatives of the Pearson statistic, which avoids assuming that z and w are based on Fisher scoring */ { double resid,xx,*Pe1,*Pe2,*pp,*p1,*p0,*v2,*Pi1,*Pi2; int i,k,m,n_2dCols=0,one=1; if (deriv) { Pe1 = (double *)CALLOC((size_t)n,sizeof(double)); /* for dP/deta */ Pi1 = (double *)CALLOC((size_t) n * M,sizeof(double)); /* for dPi/drho */ if (deriv2) { n_2dCols = (M * (1 + M))/2; Pe2 = (double *)CALLOC((size_t)n,sizeof(double)); /* for d2P/deta2 */ v2 = (double *)CALLOC((size_t)n,sizeof(double)); Pi2 = (double *)CALLOC((size_t)n_2dCols*n,sizeof(double)); /* for d2P_i/drho */ } else {Pe2=v2=Pi2=NULL;} } else {Pi1 = Pe2 = v2 = Pe1 = Pi2 = NULL;} *P=0.0; for (i=0; i < n;i++) { resid = y[i]-mu[i]; xx = resid*p_weights[i]/V[i]; *P += xx*resid; if (deriv) { Pe1[i] = - xx* (2 + resid*V1[i])/g1[i]; if (deriv2) { Pe2[i] = - Pe1[i]*g2[i]/g1[i] + (2*p_weights[i]/V[i]+2*xx*V1[i] - Pe1[i]*V1[i]*g1[i] - xx*resid*(V2[i]-V1[i]*V1[i]))/(g1[i]*g1[i]); } } } /* derivs wrt eta completed */ if (deriv) { /* transform to derivs wrt rho */ rc_prod(Pi1,Pe1,eta1,&M,&n); /* Pi1 = dP_i/drho_k done */ if (deriv2) { rc_prod(Pi2,Pe1,eta2,&n_2dCols,&n); for (pp=Pi2,m=0;m < M;m++) for (k=m;k < M;k++) { rc_prod(Pe1,eta1 + n * m,eta1 + n * k,&one,&n); rc_prod(v2,Pe2,Pe1,&one,&n); p1=v2 + n; for (p0=v2;p0=0;j--) { /* back through columns */ for (i=r-1;i>drop[n_drop-1];i--,X--,Xs--) *X = *Xs; *X = 0.0;X--; for (k=n_drop-1;k>0;k--) { for (i=drop[k]-1;i>drop[k-1];i--,X--,Xs--) *X = *Xs; *X = 0.0;X--; } for (i=drop[0]-1;i>=0;i--,X--,Xs--) *X = *Xs; } } /* end undrop rows */ double MLpenalty1(double *det1,double *det2,double *Tk,double *Tkm,double *nulli, double *X, double *R,double *Q, int *nind,double *sp,double *rS,int *rSncol,int *q,int *n, int *Ms,int *M,int *M0,int *neg_w,double *rank_tol,int *deriv, int *nthreads,int *type) { /* Routine to obtain the version of log|X'WX+S| that applies to ML, rather than REML. This version assumes that we are working in an already truncated range-null separated space. * nulli is an array indicating whether a parameter (column) relates to the null space (+ve) or range space (-ve) of the total penalty matrix. Because of pivoting they can be in any order. * Q, R are the QR factors of diag(abs(W))X augmenented by the square root of S * nind is the array indexing the locations of the `neg_w' -ve elements of W. * q is the number of model coefficients * Ms is the penalty null space dimension. * M is number of smoothing parameters, and M0 the number of theta parameters. * n is the number of rows in Q. Basic task of the routine is to project Hessian of the penalized log likelihood into the range space of the penalty, in order to obtain the correction term that applies for ML. NOTE: rS is over-written by this. */ double *RU1,*tau,*work,*Ri,*Qb=NULL,*K,*P,*IQ,*IQQ,*Vt,*XU1=NULL, *d,*p0,*p1,*p2,*p3,ldetXWXS,ldetI2D=0.0; int ScS,bt,ct,qM,*pivot,i,j,k,left,tp,n_drop=0,*drop,FALSE=0; drop = (int *)CALLOC((size_t)*Ms,sizeof(int)); for (i=0;i < *q;i++) if (nulli[i]>0.0) { drop[n_drop] = i;n_drop++; } for (ScS=0.0,i=0;i<*M;i++) ScS += rSncol[i]; /* total columns of rS */ qM = *q - n_drop; RU1 = (double *)CALLOC((size_t) *q * *q ,sizeof(double)); for (p1=RU1,p2=R,p3=R+ *q * *q;p2 < p3;p1++,p2++) *p1 = *p2; drop_cols(RU1,*q,*q,drop,n_drop); /* drop the null space columns from R */ /* A pivoted QR decomposition of RU1 is needed next */ tau=(double *)CALLOC((size_t)qM,sizeof(double)); /* part of reflector storage */ pivot=(int *)CALLOC((size_t)qM,sizeof(int)); mgcv_qr(RU1,q,&qM,pivot,tau); /* RU1 and tau now contain the QR decomposition information */ /* pivot[i] gives the unpivoted position of the ith pivoted parameter.*/ /* Ri needed */ Ri = (double *)CALLOC((size_t) qM * qM,sizeof(double)); Rinv(Ri,RU1,&qM,q,&qM); /* getting R^{-1} */ if (*type==0||*neg_w) { /* new Q factor needed explicitly */ Qb = (double *)CALLOC((size_t) *q * qM,sizeof(double)); for (i=0;i< qM;i++) Qb[i * *q + i] = 1.0; left=1;tp=0;mgcv_qrqy(Qb,RU1,tau,q,&qM,&qM,&left,&tp); /* Q from the QR decomposition */ } else { /* need X with null space cols dropped */ XU1 = (double *)CALLOC((size_t) *n * *q,sizeof(double)); for (p1=XU1,p2=X,p3=X + *n * *q;p2 < p3;p1++,p2++) *p1 = *p2; drop_cols(XU1,*n,*q,drop,n_drop); /* drop the null space columns from X */ } FREE(tau); K = (double *)CALLOC((size_t) *n * qM,sizeof(double)); P = (double *)CALLOC((size_t) qM * qM,sizeof(double)); if (*neg_w) { /* need to deal with -ve weight correction */ if (*neg_w < *q+1) k = *q+1; else k = *neg_w; IQ = (double *)CALLOC((size_t) k * *q,sizeof(double)); for (i=0;i< *neg_w;i++) { /* Copy the rows of Q corresponding to -ve w_i into IQ */ p0 = IQ + i;p1 = Q + nind[i]; for (j=0;j<*q;j++,p0+=k,p1+= *n) *p0 = *p1; } /* Note that IQ may be zero padded, for convenience */ IQQ = (double *)CALLOC((size_t) k * qM,sizeof(double)); bt=0;ct=0;mgcv_mmult(IQQ,IQ,Qb,&bt,&ct,&k,&qM,q); /* I^-Q_1 \bar Q is k by rank */ FREE(IQ); /* Get the SVD of IQQ */ Vt = (double *)CALLOC((size_t) qM * qM,sizeof(double)); d = (double *)CALLOC((size_t) qM,sizeof(double)); mgcv_svd_full(IQQ,Vt,d,&k,&qM); /* SVD of IQ */ FREE(IQQ); for (i=0;i 1) { (*rank)--;R_cond(R,&nr,rank,work,&Rcond);} /* Now have to drop the unidentifiable columns from R1, E and the corresponding rows from rS The columns to drop are indexed by the elements of pivot1 from pivot1[rank] onwards. Before returning, zeros will need to be inserted in the parameter vector at these locations. */ for (i=0;i<*q - *Mp;i++) nulli[i] = -1.0; /* parameter in penalty range space */ for (i= *q - *Mp;i < *q;i++) nulli[i] = 1.0; /* parameter in penalty null space */ *n_drop = *q - *rank; if (*n_drop) { for (i=0;i < *n_drop;i++) drop[i] = pivot1[*rank+i]; qsort(drop,*n_drop,sizeof(int),icompare); /* key assumption of the drop/undrop routines is that `drop' is ascending */ /* drop columns indexed in `drop'... */ drop_cols(R1,rr,*q,drop,*n_drop); /* R1 now q by rank */ drop_cols(E,*Enrow,*q,drop,*n_drop); /* E now q by rank */ drop_cols(X,*n,*q,drop,*n_drop); /* X now n by rank */ drop_rows(rS,*q,ScS,drop,*n_drop); /* rS now rank by ScS */ drop_rows(nulli,*q,1,drop,*n_drop); /* keeps track of null space params */ } /* At this stage the parameter space has been purged of terms that are theoretically unidentifiable, given WX and the penalties */ /* Now augment R1 with the real square root penalty (not the nicely scaled version), result in R... */ for (j=0;j < *rank;j++) { for (i=0;i< rr;i++) R[i + nr * j] = R1[i + rr * j]; for (i=0;i< *Enrow;i++) R[i + rr + nr * j] = E[i + *Enrow * j]; } mgcv_qr(R,&nr,rank,pivot1,tau1); /* The final QR decomposition */ i=1;pivoter(nulli,rank,&i,pivot1,&FALSE,&FALSE); /* pivoting the rows of nulli */ if (deriv2) { /* get first bit of X'WX (hessian of the deviance)*/ pivoter(R1,&rr,rank,pivot1,&TRUE,&FALSE); /* pivot the columns of R1 */ getXtX(dev_hess,R1,&rr,rank); } /* Form Q1 = Qf Qs[1:q,] where Qf and Qs are orthogonal factors from first and final QR decomps respectively ... */ if (neg_w || *type==0) { /* Q1 needed if neg_w correction needed, and anyway for type==0 */ Q = (double *)CALLOC((size_t) nr * *rank,sizeof(double)); for (i=0;i < *rank;i++) Q[i * nr + i] = 1.0; left=1;tp=0;mgcv_qrqy(Q,R,tau1,&nr,rank,rank,&left,&tp); /* Q from the second QR decomposition */ /* Q1 = Qb Q[1:q,] where Qb from first QR decomposition... */ for (i=0;i0) { for (*ldetXWXS=0.0,i=0;i < *rank;i++) *ldetXWXS += log(fabs(R[i + i * nr])); *ldetXWXS *= 2; *ldetXWXS += ldetI2D; /* correction for negative weights */ } /* Apply pivoting to the parameter space - this simply means reordering the cols of E and X and the rows of the rS_i, and then unscrambling the parameter vector at the end (along with any covariance matrix) pivot1[i] gives the unpivoted position of the ith pivoted parameter. */ pivoter(rS,rank,&ScS,pivot1,&FALSE,&FALSE); /* row pivot of rS */ pivoter(E,Enrow,rank,pivot1,&TRUE,&FALSE); /* column pivot of E */ pivoter(X,n,rank,pivot1,&TRUE,&FALSE); /* column pivot of X */ if (*type==1) { /* create K = XP... */ applyP(K,X,R,Vt,neg_w,nr,*rank,*n,1); } else { /* start PK'z --- the pivoted coefficients...*/ bt=1;ct=0;mgcv_mmult(work,K,zz,&bt,&ct,rank,&one,n); /* K'z */ mgcv_mmult(work + *q *2,Q1,zz,&bt,&ct,rank,&one,n); /* Q1'z */ } if (*type==1) { bt=1;ct=0;mgcv_mmult(work,K,z,&bt,&ct,rank,&one,n); /* K'Wz */ applyP(PKtz,work,R,Vt,neg_w,nr,*rank,1,0); } else { /* Create Wz (not sqrt(|W|)z)... */ for (i=0;i<*n;i++) zz[i] = raw[i] * raw[i] * z[i]; for (i=0;i *rank_tol * norm2) { applyPt(zz,work + *q,R,Vt,neg_w,nr,*rank,1,0); /* P'X'Wz */ applyP(PKtz,zz,R,Vt,neg_w,nr,*rank,1,0); } else applyP(PKtz,work,R,Vt,neg_w,nr,*rank,1,0); } FREE(WX);FREE(tau);FREE(Ri);FREE(R1); FREE(tau1); if (neg_w || *type==0) FREE(Q); FREE(pivot); if (*type==0) FREE(zz); } /* gdiPK */ void gdi2(double *X,double *E,double *Es,double *rS,double *U1, double *sp,double *theta,double *z,double *w,double *wz,double *wf, double *Dth,double *Det,double *Det2,double *Dth2,double *Det_th, double *Det2_th,double *Det3,double *Det_th2, double *Det4, double *Det3_th, double *Det2_th2, double *beta,double *b1,double *w1, double *D1,double *D2,double *P0,double *P1,double *P2, double *ldet, double *ldet1,double *ldet2,double *rV, double *rank_tol,int *rank_est, int *n,int *q, int *M,int *n_theta, int *Mp,int *Enrow,int *rSncol,int *deriv, int *fixed_penalty,int *nt,int *type,double *dVkk) /* Extended GAM derivative function, for independent data beyond exponential family. On entry *ldet < 0 indicates that ML ingredients should be computed, else REML type == 0 is the original computation involving (|w|)^{-1}dw/drho whereas type == 1 avoids the (|w|)^{-1} to avoid problems with zero weights (and/or badly scaled sqrt(|w|)z). Identifiability truncation is based on the "well scaled" penalty square root, Es, and is assuming that a stability enhancing reparameterization and stable E are being employed. This version deals properly with negative weights, which can occur with Newton based PIRLS. In consequence w's in this routine are proportional to reciprocal variances, not reciprocal standard deviations. The function is to be called at convergence of a P-IRLS scheme, estimating model coefficients by P-IRLS. All names ending in 1,2 or 3 are derivatives of some sort, with the integer indicating the order of differentiation. The arguments of this function point to the following: *i X is and n by q model matrix. On output this will contain K. *i E is a q by Enrow square root of the total penalty matrix, so E'E=S *i Es is the square root of a "well scaled" version of the total penalty, suitable for numerical determination of the theoretical rank of the problem. *i rS is a list of square roots of individual penalty matrices, packed in one array. The ith such matrix rSi, say, has dimension q by rSncol[i] and the ith penalty is [rSi][rSi]'. *i U1 is an (orthogonal) basis for the penalty range space (q by (q-Mp), where Mp is the null space dimension). *i sp is an M array of smoothing parameters (NOT log smoothing parameters) *i theta is the n_theta vector of extra parameters of the likelihood. *i z and w are pseudodata and iterative newton weights. *i wf are Fisher weights *i Dth, Dth2, Det, Det2, Det_th, Det2_th, Det3, Det_th2, Det4, Det3_th, Det2_th2 give derivs of deviance wrt eta (linear predictor) and theta (extra params) in obvious notation, where e.g Detj_thk is derivative of deviance j times wrt eta and k times wrt theta. absence of a j or k implies they are 1. *o beta - coefficients. *o b1 - first deriv of coefs w.r.t. sps (incl. theta) *o w1 - first deriv of weights w.r.t. sps (incl. theta) *o D1, D2 - first and second deriv of deviance w.r.t. sps (incl. theta) *o P0, P1, P2 - penalty b'Sb and its first and second derivs wrt sps. (incl theta) *o ldet, ldet1, ldet2, log|X'WX + S| & derivs wrt sp (incl theta) *o rV sqrt covariance matrix of coefs. *i rank_tol tol to use for rank estimation *o rank_est estimated rank *i n , q, M, n_theta number of data, coefs, smoothing params and theta params. *i Mp penalty null space dimension *i Enrow rows of E. *i *rSncol array of number of cols in components of rS *i deriv order of deriv required (0, 1 or 2) *i fixed_penalty, non-zero indicates that S includes a fixed penalty component, the range space projected square root of which is in the final element of `UrS'. This information is used by get_detS2(). *i nt number of threads to use, if supported. *i type 0 for computation using |w|^{-1} scaling, 1 to avoif this. *o dVkk is M by M matrix containing curvature terms for objective w.r.t smoothing params (is zero when second deriv is zero, but otherwise is not second deriv). The method has 4 main parts: 1. The initial QR- decomposition and negative w correction SVD are performed, and various quantities which are independent of derivatives are created 2. IFT used to obtain derivatives of the coefficients wrt the log smoothing parameters. 3. Evaluation of the derivatives of the deviance wrt the log smoothing parameters (i.e. calculation of D1 and D2) The method involves first and second derivatives of a number of k-vectors wrt log smoothing parameters (\rho), where k is q or n. Consider such a vector, v. * v1 will contain dv/d\rho_0, dv/d\rho_1 etc. So, for example, dv_i/d\rho_j (indices starting at zero) is located in v1[q*j+i]. * v2 will contain d^2v/d\rho_0d\rho_0, d^2v/d\rho_1d\rho_0,... but rows will not be stored if they duplicate an existing row (e.g. d^2v/d\rho_0d\rho_1 would not be stored as it already exists and can be accessed by interchanging the sp indices). So to get d^2v_k/d\rho_id\rho_j: i) if i m || *nt < 1) *nt = m; /* no point in more threads than m */ omp_set_num_threads(*nt); /* set number of threads to use */ #else *nt = 1; #endif if (*ldet<0) ML=1; /* require ML not REML */ if (*deriv==2) deriv2=1; else deriv2=0; ScS=0;for (pi=rSncol;pi0) raw[i] = sqrt(w[i]); else { *type=1; } /* zero weights so we have to use type 1 method */ if (neg_w) { Vt = (double *)CALLOC((size_t) *q * *q,sizeof(double)); nind = (int *)CALLOC((size_t)neg_w,sizeof(int)); /* index the negative w_i */ k=0;for (i=0;i< *n;i++) if (w[i]<0) { nind[k]=i;k++;} } else { nind = (int *)NULL; Vt = (double *)NULL;} /* get R,nulli,dev_hess,P,K,Vt,PKtz (== beta),Q1, nind,pivot1,drop,rank,n_drop,ldetXWXS */ if (*type==1) z=wz; /* need to pass wz to gdiPK */ //j=1; // debug &j for nt gdiPK(work,X,E,Es,rS,U1,z,raw, R,Rh,nulli,dev_hess,P,K,Vt,PKtz,Q1, nind,pivot1,drop, n,q,Mp,neg_w,nt,Enrow, &rank,&n_drop, deriv2,ScS,&TRUE, rank_tol,ldet,type); FREE(raw); /* now call ift2 to get derivatives of coefs w.r.t. smoothing/theta parameters */ ntot = *M + *n_theta; n_2dCols = (ntot * (1 + ntot))/2; if (*deriv) { //b1 = (double *)CALLOC((size_t) rank * ntot,sizeof(double)); eta1 = (double *)CALLOC((size_t) *n * ntot,sizeof(double)); if (deriv2) { b2 = (double *)CALLOC((size_t) rank * n_2dCols,sizeof(double)); eta2 = (double *)CALLOC((size_t) *n * n_2dCols,sizeof(double)); } ift2(R,Vt,X,rS,PKtz,sp,theta, Det_th,Det2_th,Det3,Det_th2, b1,b2,eta1,eta2, n,&rank,M,n_theta,rSncol,&deriv2,&neg_w,&nr); if (*M>0) { i=0;mgcv_mmult(work,Rh,b1,&i,&i,&rank,M,&rank); /* Rh db/drho */ /* Now obtain dVkk = db'/drho Rh' Rh db/drho ... */ getXtX(dVkk,work,&rank,M); } /* compute the grad of the deviance... */ for (p4 = Dth,p0=D1,p1=eta1,i=0;i < *n_theta;i++,p0++) { for (*p0=0.0,p2 = Det,p3=Det + *n;p2=0;j--) { p0 = b1 + rank * j; /* start of source column */ for (i=0;i< rank;i++) beta[pivot1[i]] = p0[i]; undrop_rows(beta,*q,1,drop,n_drop); /* zero rows inserted */ p1 = b1 + *q * j; /* start of target column */ for (p0=beta,p2=p0 + *q;p0 m || *nt < 1) *nt = m; /* no point in more threads than m */ omp_set_num_threads(*nt); /* set number of threads to use */ #else *nt = 1; #endif nt1 = *nt; /* allows threading to be switched off for QR for debugging*/ if (*deriv==2) deriv2=1; else deriv2=0; ScS=0;for (pi=rSncol;pi leave readable!)*/ a1=(double *)CALLOC((size_t)*n,sizeof(double)); a2=(double *)CALLOC((size_t)*n,sizeof(double)); alpha1=alpha2 =(double *)NULL; if (*fisher) { /* Fisher scoring updates */ /* set up constants involved in w updates */ /* dw/deta = - w[i]*(V'/V+2g''/g')/g' */ for (i=0;i< *n;i++) a1[i] = - w[i] *(V1[i] + 2*g2[i])/g1[i]; /* d2w/deta2 .... */ for (i=0;i< *n;i++) a2[i] = a1[i]*(a1[i]/w[i]-g2[i]/g1[i]) - w[i]*(V2[i]-V1[i]*V1[i] + 2*g3[i]-2*g2[i]*g2[i])/(g1[i]*g1[i]) ; } else { /* full Newton updates */ alpha1 = (double *) CALLOC((size_t)*n,sizeof(double)); alpha2 = (double *) CALLOC((size_t)*n,sizeof(double)); for (i=0;i< *n;i++) { xx = V2[i]-V1[i]*V1[i]+g3[i]-g2[i]*g2[i]; /* temp. storage */ alpha1[i] = (-(V1[i]+g2[i]) + (y[i]-mu[i])*xx)/alpha[i]; alpha2[i] = (-2*xx + (y[i]-mu[i])*(V3[i]-3*V1[i]*V2[i]+2*V1[i]*V1[i]*V1[i]+g4[i]-3*g3[i]*g2[i]+2*g2[i]*g2[i]*g2[i]))/alpha[i]; } /* end of preliminaries, now setup the multipliers that go forward */ /* dw/deta ... */ for (i=0;i<*n;i++) a1[i] = w[i]*(alpha1[i]-V1[i]-2*g2[i])/g1[i]; /* d2w/deta2... */ for (i=0;i<*n;i++) a2[i] = a1[i]*(a1[i]/w[i]-g2[i]/g1[i]) - w[i]*(alpha1[i]*alpha1[i] - alpha2[i] + V2[i]-V1[i]*V1[i] + 2*g3[i]-2*g2[i]*g2[i])/(g1[i]*g1[i]) ; if (! *REML) { /* then Fisher versions of a1 and a2 also needed */ af1=(double *)CALLOC((size_t)*n,sizeof(double)); af2=(double *)CALLOC((size_t)*n,sizeof(double)); /* dwf/deta = - w[i]*(V'/V+2g''/g')/g' */ for (i=0;i< *n;i++) af1[i] = - wf[i] *(V1[i] + 2*g2[i])/g1[i]; /* d2wf/deta2 .... */ for (i=0;i< *n;i++) af2[i] = af1[i]*(af1[i]/wf[i]-g2[i]/g1[i]) - wf[i]*(V2[i]-V1[i]*V1[i] + 2*g3[i]-2*g2[i]*g2[i])/(g1[i]*g1[i]) ; } FREE(alpha1);FREE(alpha2); } /* end of full Newton setup */ /* get gradient vector and Hessian of deviance wrt coefficients */ for (i=0;i< *n ;i++) v1[i] = -2*p_weights[i]*(y[i]-mu[i])/(V0[i]*g1[i]); dev_grad=(double *)CALLOC((size_t) rank,sizeof(double)); bt=1;ct=0;mgcv_mmult(dev_grad,X,v1,&bt,&ct,&rank,&one,n); if (deriv2) { /* get hessian of deviance w.r.t. beta */ for (p0=dev_hess,p1=p0 + rank * rank;p00) { i=0;mgcv_mmult(work,Rh,b1,&i,&i,&rank,M,&rank); /* Rh db/drho */ /* Now obtain dVkk = diag(db'/drho Rh' Rh db/drho) ... */ getXtX(dVkk,work,&rank,M); } /* Now use IFT based derivatives to obtain derivatives of W and hence the T_* terms */ /* get derivatives of w */ rc_prod(w1,a1,eta1,M,n); /* w1 = dw/d\rho_k done */ if (deriv2) { rc_prod(w2,a1,eta2,&n_2dCols,n); for (pw2=w2,m=0;m < *M;m++) for (k=m;k < *M;k++) { rc_prod(v1,eta1 + *n * m,eta1 + *n * k,&one,n); rc_prod(v2,a2,v1,&one,n); p1=v2 + *n; for (p0=v2;p01) for (p0=trA2,p1 = P2,p2 = P2 + *M * *M;p11) for (p1 = P2,p2 = P2 + *M * *M;p1=0;j--) { p0 = b1 + rank * j; /* start of source column */ for (i=0;i< rank;i++) beta[pivot1[i]] = p0[i]; undrop_rows(beta,*q,1,drop,n_drop); /* zero rows inserted */ p1 = b1 + *q * j; /* start of target column */ for (p0=beta,p2=p0 + *q;p00) { /* It's REML */ /* Now deal with log|X'WX+S| */ reml_penalty = ldetXWXS; get_ddetXWXpS(trA1,trA2,P,K,sp,rS,rSncol,Tk,Tkm,n,&rank,&rank,M,&FALSE,deriv,*nt); /* trA1/2 really contain det derivs */ } /* So trA1 and trA2 actually contain the derivatives for reml_penalty */ if (*REML<0) { /* it's ML, and more complicated */ /* get derivs of ML log det in trA1 and trA2... */ reml_penalty = MLpenalty1(trA1,trA2,Tk,Tkm,nulli,X,R,Q1,nind,sp,rS,rSncol, &rank,n,Mp,M,&FALSE,&neg_w,rank_tol,deriv,nt,&FALSE); FREE(R);FREE(Q1);FREE(nind); } /* note that rS scrambled from here on... */ /* clean up memory, except what's needed to get tr(A) and derivatives */ if (neg_w) FREE(Vt); FREE(work);FREE(PKtz); if (*deriv) { //FREE(b1); FREE(eta1); FREE(eta2); FREE(a1);FREE(a2);FREE(wi);FREE(dev_grad); //FREE(w1); FREE(w2);FREE(b2); if (deriv2) { FREE(dev_hess);} } /* Note: the following gets only trA if REML is being used, so as not to overwrite the derivatives actually needed, which also means that it doesn't matter if MLpenalty has messed up rS */ if (*fisher) { /* then all quantites are the ones required for EDF calculations */ wf = w;Tfk=Tk;Tfkm=Tkm; } else { /* Need expected value versions of everything for EDF calculation */ /* form sqrt(wf)X augmented with E */ nr = *n + *Enrow; /* st WX = (double *)CALLOC((size_t)nr * rank,sizeof(double)); */ WX = (double *) CALLOC((size_t) ( (nr + *nt * rank) * rank),sizeof(double)); for (p0=w,p1=w + *n,p2=wf;p0=0;k--) { yp = (1-p[k])/R[k + *r *k]; ym = (-1-p[k])/R[k + *r *k]; for (pp_norm=0.0,i=0;i= fabs(ym)+pm_norm) { y[k]=yp; for (i=0;iy_inf) y_inf=kappa; } for (i=0;i<*c;i++) { for (kappa=0.0,j=i;j<*c;j++) kappa += fabs(R[i + *r * j]); if (kappa>R_inf) R_inf = kappa; } kappa=R_inf*y_inf; *Rcondition=kappa; } /* end R_cond */ void pls_fit1(double *y,double *X,double *w,double *wy,double *E,double *Es,int *n,int *q,int *rE,double *eta, double *penalty,double *rank_tol,int *nt,int *use_wy) /* Fast but stable PLS fitter. Obtains linear predictor, eta, of weighted penalized linear model, without evaluating the coefficients, but also returns coefficients in case they are needed. WARNING: Coefficients are returned in first *q elements of y - which means that if n < q, y had better be padded or you'll spend days searching for a segfault that valgrind doesn't find the culprit for. Uses QR approach, but tests that X'Wz = R'Q_1'sqrt(\bar w)\bar z (in Wood 2011 notation), to ensure that rhs is stable, and uses R^{-T}X'Wy in plce of Q_1'sqrt(\bar w)\bar z if not. The reason for this is that it is possible for sqrt(w)*z to be *very* badly scaled when w*z is well scaled.... Also has the option to not test, but simply use X'Wy directly, if *use_wy is non-zero. This is useful in situations in which y is pseudodata involving a reciprocal w and some w_i is zero. Note that here E'E = S, while Es'Es = `well scaled version of S' In this version the w_i are the w_i in \sum_i w_i (y_i - X_i \beta)^2 rather than being the square root of these. Some w_i may be negative (as may occur when using Newton, rather than Fisher updates on IRLS). Note that it is still assumed that any zero weighted data will have been dropped before the call. If nt>1 and openMP is available then routine computes with the optimal number of threads up to nt. On return: * if *n is -ve then X'WX+E'E was not +ve definite (which means that the routine should be called again with weights based on Fisher scoring). otherwise: * eta contains the linear predictor * penalty is the evaluated penalty * the first q elements of y are the coefficients. */ { int i,j,k,rank,one=1,*pivot,*pivot1,left,tp,neg_w=0,*nind,bt,ct,nr,rr,n_drop=0,*drop,TRUE=1,FALSE=0,nz; double *z,*WX,*tau,Rcond,xx,zz,zz1,*work,*Q,*Q1,*IQ,*raw,*d,*Vt,*p0,*p1, *R1,*tau1,Rnorm,Enorm,*R,*Xp; #ifdef OPENMP_ON int m; m = omp_get_num_procs(); /* detected number of processors */ if (*nt > m || *nt < 1) *nt = m; /* no point in more threads than m */ omp_set_num_threads(*nt); /* set number of threads to use */ #else *nt = 1; /* no openMP support - turn off threading */ #endif rr = *q;if (rr>*n) rr = *n; /* number of rows of QR factor R */ nr = rr + *rE; nz = *n; if (nz 1) { rank--;R_cond(R,&nr,&rank,work,&Rcond);} /* Now have to drop the unidentifiable columns from R1, E and the corresponding rows from rS The columns to drop are indexed by the elements of pivot1 from pivot1[rank] onwards. Before returning, zeros will need to be inserted in the parameter vector at these locations. */ n_drop = *q - rank; if (n_drop) { drop = (int *)CALLOC((size_t)n_drop,sizeof(int)); /* original locations of dropped parameters */ for (i=0;i rr) j = rr; /* number of rows in r factor */ for (i=j;i *rank_tol * zz) { *use_wy = 1; } } if (*use_wy) { /* then R'Q'wz unstable or this computation signalled on entry */ for (k=0;k=0;k--) { for (xx=0.0,j=k+1;j < rank;j++) xx += R[k + nr * j]*z[j]; z[k] = (y[k] - xx)/R[k + nr * k]; } /* unpivot result (in z) into y */ for (i=0;i< rank;i++) y[pivot1[i]] = z[i]; /* insert zeroes for unidentifiables */ undrop_rows(y,*q,1,drop,n_drop); if (*use_wy) { /* re-compute other results from beta, as originals appear unstable or this method requested */ bt=0;ct=0;mgcv_mmult(eta,X,y,&bt,&ct,n,&one,q); bt=0;ct=0;mgcv_mmult(work,E,y,&bt,&ct,rE,&one,q); for (*penalty=0.0,i=0;i < *rE;i++) *penalty += work[i]*work[i]; /* the penalty term */ } FREE(z); FREE(WX);FREE(tau);FREE(pivot);FREE(raw); FREE(R);FREE(pivot1);FREE(tau1); FREE(work); if (n_drop) FREE(drop); if (neg_w) { FREE(nind);FREE(d);FREE(Vt);} } /* end pls_fit1 */ mgcv/src/init.c0000644000176200001440000000734313471714505013122 0ustar liggesusers/* Symbol registration initialization: original provided by Brian Ripley. Anything called from R should be registered here (and declared in mgcv.h). (See also NAMESPACE:1) */ #include #include #include #include "mgcv.h" R_CallMethodDef CallMethods[] = { {"mgcv_pmmult2", (DL_FUNC) &mgcv_pmmult2,5}, {"mgcv_Rpiqr", (DL_FUNC) &mgcv_Rpiqr,5}, { "mgcv_tmm",(DL_FUNC)&mgcv_tmm,5}, { "mgcv_chol_down",(DL_FUNC)&mgcv_chol_down,5}, { "mgcv_chol_up",(DL_FUNC)&mgcv_chol_up,5}, { "mgcv_Rpbsi",(DL_FUNC)&mgcv_Rpbsi,2}, { "mgcv_RPPt",(DL_FUNC)&mgcv_RPPt,3}, { "mgcv_Rpchol",(DL_FUNC)&mgcv_Rpchol,4}, { "mgcv_Rpforwardsolve",(DL_FUNC)&mgcv_Rpforwardsolve,3}, { "mgcv_Rpbacksolve",(DL_FUNC)&mgcv_Rpbacksolve,3}, { "mgcv_Rpcross",(DL_FUNC)&mgcv_Rpcross,3}, { "mgcv_madi",(DL_FUNC)&mgcv_madi,4}, { "Rkdtree",(DL_FUNC)&Rkdtree,1}, {"Rkdnearest",(DL_FUNC)&Rkdnearest,4}, {"Rkradius",(DL_FUNC)&Rkradius,5}, {NULL, NULL, 0} }; R_CMethodDef CEntries[] = { {"band_chol",(DL_FUNC) band_chol,4}, {"tri_chol",(DL_FUNC) tri_chol,4}, {"diagXVXt", (DL_FUNC) &diagXVXt,21}, {"XWXd", (DL_FUNC) &XWXd,18}, {"XWXd0", (DL_FUNC) &XWXd0,18}, {"XWXd1", (DL_FUNC) &XWXd1,22}, {"XWyd", (DL_FUNC) &XWyd,21}, {"Xbd", (DL_FUNC) &Xbd,17}, {"vcorr", (DL_FUNC) &vcorr, 5}, {"dchol", (DL_FUNC) &dchol, 4}, {"chol_down", (DL_FUNC) &chol_down, 5}, {"mgcv_omp", (DL_FUNC) &mgcv_omp, 1}, {"coxpred", (DL_FUNC) &coxpred, 14}, {"coxpp", (DL_FUNC) &coxpp, 10}, {"coxlpl", (DL_FUNC) &coxlpl, 17}, {"mvn_ll", (DL_FUNC) &mvn_ll,15}, {"RMonoCon", (DL_FUNC) &RMonoCon, 7}, {"RuniqueCombs", (DL_FUNC) &RuniqueCombs, 4}, {"RPCLS", (DL_FUNC) &RPCLS, 13}, {"construct_tprs", (DL_FUNC) &construct_tprs, 13}, {"crspl", (DL_FUNC) &crspl,8}, {"predict_tprs", (DL_FUNC) &predict_tprs, 12}, {"MinimumSeparation", (DL_FUNC) &MinimumSeparation, 6}, {"magic", (DL_FUNC) &magic, 19}, {"mgcv_mmult", (DL_FUNC) &mgcv_mmult,8}, {"mgcv_pmmult", (DL_FUNC) &mgcv_pmmult,9}, {"gdi1",(DL_FUNC) &gdi1,49}, {"gdi2",(DL_FUNC) &gdi2,48}, {"R_cond",(DL_FUNC) &R_cond,5} , {"pls_fit1",(DL_FUNC)&pls_fit1,14}, {"tweedious",(DL_FUNC)&tweedious,13}, {"tweedious2",(DL_FUNC)&tweedious2,13}, {"psum",(DL_FUNC)&psum,4}, {"get_detS2",(DL_FUNC)&get_detS2,12}, {"get_stableS",(DL_FUNC)&get_stableS,14}, {"mgcv_tri_diag",(DL_FUNC)&mgcv_tri_diag,3}, {"mgcv_td_qy",(DL_FUNC)&mgcv_td_qy,7}, {"mgcv_symeig",(DL_FUNC)&mgcv_symeig,6}, {"read_mat",(DL_FUNC)&read_mat,4}, {"rwMatrix",(DL_FUNC)&rwMatrix,8}, {"in_out",(DL_FUNC)&in_out,8}, {"Rlanczos",(DL_FUNC)&Rlanczos,8}, {"rksos",(DL_FUNC)&rksos,3}, {"gen_tps_poly_powers",(DL_FUNC)&gen_tps_poly_powers,4}, {"k_nn",(DL_FUNC)&k_nn,8}, // {"Rkdtree",(DL_FUNC)&Rkdtree,5}, //{"Rkdnearest",(DL_FUNC)&Rkdnearest,9}, //{"Rkradius",(DL_FUNC)&Rkradius,9}, {"sspl_construct",(DL_FUNC)&sspl_construct,9}, {"sspl_mapply",(DL_FUNC)&sspl_mapply,9}, {"tri2nei",(DL_FUNC)&tri2nei,5}, {"nei_penalty",(DL_FUNC)&nei_penalty, 10}, {"boundary",(DL_FUNC)&boundary, 14}, {"pde_coeffs",(DL_FUNC)&pde_coeffs, 9}, {"gridder",(DL_FUNC)&gridder, 13}, {"row_block_reorder",(DL_FUNC)&row_block_reorder,5}, {"mgcv_pqr",(DL_FUNC)&mgcv_pqr,6}, {"getRpqr",(DL_FUNC)&getRpqr,6}, {"mgcv_pqrqy",(DL_FUNC)&mgcv_pqrqy,8}, {NULL, NULL, 0} }; void R_init_mgcv(DllInfo *dll) { R_registerRoutines(dll, CEntries, CallMethods, NULL, NULL); R_useDynamicSymbols(dll, FALSE); R_RegisterCCallable("mgcv","mgcv_pmmult2", (DL_FUNC) &mgcv_pmmult2); R_RegisterCCallable("mgcv","pls_fit1", (DL_FUNC) &pls_fit1); R_RegisterCCallable("mgcv","gdi2", (DL_FUNC) &gdi2); } mgcv/src/mat.c0000755000176200001440000041750313560624055012745 0ustar liggesusers/* Convenient C wrappers for calling LAPACK and LINPACK + other matrix routines using same packing format.... See R-x/include/R_ext/Lapack.h... parallel support (using openMP) offered by... * mgcv_pqr - parallel QR based on row blocking ok for few cores and n>>p but somewhat involved. Advantage is that just one thread used per core, so threading overhead minimal. Disadvantage is that an extra single thread QR is used to combine everything. * mgcv_piqr - pivoted QR that simply parallelizes the 'householder-to-unfinished-cols' step. Storage exactly as standard LAPACK pivoted QR. * mgcv_Rpiqr - wrapper for above for use via .call * mgcv_pmmult - parallel matrix multiplication. * mgcv_Rpbsi - parallel inversion of upper triangular matrix. * Rlanczos - parallel on leading order cost step (but note that standard BLAS seems to use Strassen for square matrices.) */ /* dgemm(char *transa,char *transb,int *m,int *n,int *k,double *alpha,double *A, int *lda, double *B, int *ldb, double *beta,double *C,int *ldc) transa/b = 'T' or 'N' for A/B transposed or not. C = alpha op(A) op(B) + beta C, where op() is transpose or not. C is m by n. k is cols of op(A). ldx is rows of X in calling routine (to allow use of sub-matrices) */ /* dsyrk(char *uplo, char *trans,int *n, int *k,double *a, double *A, int *lda, double *b, double *C,int *ldc) uplo = 'U' or 'L' for upper or lower tri of C used. trans = 'N' for C = aAA' + bC and A n by k, or 'T' for C = aA'A + bC and A k by n; C is n by n. lda and ldc are actual number of rows in A and C respectively (allows use on submatrices). */ /* dswap(int *n,double *x,int *dx,double *y,int *dy) Swaps n elements of vectors x and y. Spacing between elements is dx and dy. */ /* dgemv(char *trans,int *m, int *n,double a,double *A,int *lda,double *x,int *dx, double *b, double *y,int *dy) trans='T' to transpose A, 'N' not to. A is m by n. Forms y = a*A'x + b*y, or y = a*Ax + b*y. lda is number of actual rows in A (to allow for sub-matrices) dx and dy are increments of x and y indices. */ /* dtrmm(char *side,char *uplo,char *transa, char *diag,int *m, int *n, double *alpha, double *A,int *lda,double *B,int *ldb) B = alpha*op(A)*B or B = alpha*B*op(A) for side = 'L' or 'R'. op is identity of transpose depending on whether transa = 'N' or 'T'. B is m by n, upper/lower triangular if uplo = 'U' or 'L'. B is unit diagonal if diag = 'U' rather than 'N'. lda and ldb are physical rows of A and B. */ #include "mgcv.h" #include #include #include #include #ifdef OPENMP_ON #include #endif /*#include */ void mgcv_omp(int *a) { #ifdef OPENMP_ON *a=1; #else *a=0; #endif } void rpmat(double *A,int n) { int i,j; for (i=0;i1) { (*m)--;dn = n/(double) *m; } /* m is number of threads to use */ N = (*m * (*m + 1))/2; /* total number of blocks to process */ /* get K such that i,jth block has rows K[i] to K[i+1]-1 and cols K[j] to K[j+1]-1 */ K[0]=0; for (x=0.0,i=1;i < *m;i++) { x+=dn; K[i] = (int) floor(x);} K[*m] = n; if (*m % 2) { /* odd number of threads */ kk=l=nb=B[0]=C[0]=R[0]=0;i=1; for (r=0;r < *m;r++) for (c=r+1;c < *m;c++,i++) { if (kk==(*m - 1)/2) { /* each new block gets one leading diagonal block */ kk=0;l++; C[i]=R[i]=l; nb++;B[nb]=i;i++; } C[i] = c;R[i]=r;kk++; } } else { /* even number of threads */ nb=l=kk=B[0]=i=0; for (r=0;r < *m;r++) for (c=r+1;c < *m;c++) { if (kk == *m/2) {kk=0;nb++;B[nb]=i;} if (kk==0 && l < *m) { /* allocate 2 leading diagonal blocks */ R[i]=C[i]=l;l++;i++;R[i]=C[i]=l;l++;i++;kk++; if (kk == *m/2) { kk = 0;nb++;B[nb]=i;} } R[i]=r;C[i]=c;kk++;i++; } } B[*m] = N; } /* tile_ut */ /* dtrmm(char *side,char *uplo,char *transa, char *diag,int *m, int *n, double *alpha, double *A,int *lda,double *B,int *ldb) B = alpha*op(A)*B or B = alpha*B*op(A) for side = 'L' or 'R'. op is identity of transpose depending on whether transa = 'N' or 'T'. B is m by n, upper/lower triangular if uplo = 'U' or 'L'. B is unit diagonal if diag = 'U' rather than 'N'. lda and ldb are physical rows of A and B. */ /* dgemm(char *transa,char *transb,int *m,int *n,int *k,double *alpha,double *A, int *lda, double *B, int *ldb, double *beta,double *C,int *ldc) transa/b = 'T' or 'N' for A/B transposed or not. C = alpha op(A) op(B) + beta C, where op() is transpose or not. C is m by n. k is cols of op(A). ldx is rows of X in calling routine (to allow use of sub-matrices) */ void pdtrmm(int *n,int *q,double *alpha, double *A,int *lda,double *D,int *ldd,int *nt,int *iwork,double *work) { /* iwork is dim 3 *nt * (nt + 1)/2 + 2 * nt + 2. work is dim q*(n+nt)*(nt+1)/2. D is n by q. A is n by n upper triangular. D = alpha * A * D. */ int i,j,m,N,*K,*C,*R,*B,*off,r,c,nr,nc,ldt; double *p0,*p1,*p2,*p3,*p4,*p5,zero=0.0; char side ='L',nope='N',up='U'; m = *nt;N = (m * (m + 1))/2; /* total number of blocks to process (upper bound)*/ K = iwork;iwork += m+1;C = iwork;iwork += N; R = iwork; iwork += N;B = iwork;iwork += m+1;off = iwork; tile_ut(*n,&m,K,C,R,B); /* set up tiling and allocation of tiles to threads */ N = (m * (m + 1))/2; /* total number of blocks to process (actual) */ off[0] = 0; for (i=1;i=0;i--) { /* work down through matrices stored in X */ Xk -= *n * (ptrdiff_t) d[i]; /* start of ith X matrix */ Xj = Xk; start = tp - pd * d[i]; /* start column of target block in T */ p = T + start * *n; /* start location in T */ for (j=0;j 0) { /* B is a vector */ for (i=0;i m || nt < 1) nt = m; /* no point in more threads than m */ /*Rprintf("\n open mp %d cores, %d used\n",m,nt);*/ #else /*Rprintf("\n no openmp\n");*/ nt = 1; /* no openMP support - turn off threading */ #endif mgcv_pmmult(A,B,C,&Bt,&Ct,&r,&col,&n,&nt); UNPROTECT(1); return(a); } /* mgcv_pmmult2 */ int mgcv_bchol0(double *A,int *piv,int *n,int *nt,int *nb) { /* Lucas (2004) "LAPACK-Style Codes for Level 2 and 3 Pivoted Cholesky Factorizations" block pivoted Choleski algorithm 5.1. Note some misprints in paper, noted below. nb is block size, nt is number of threads, A is symmetric +ve semi definite matrix and piv is pivot sequence. This version is BLAS free. */ int i,j,k,l,q,r=-1,*pk,*pq,jb,n1,m,N,*a,b; double tol=0.0,*dots,*pd,*p1,*Aj,*Aq0,*Aj0,*Aj1,*Ajn,*Ail,xmax,x,*Aq,*Ajj,*Aend; dots = (double *)CALLOC((size_t) *n,sizeof(double)); for (pk = piv,i=0;i < *n;pk++,i++) *pk = i; /* initialize pivot record */ jb = *nb; /* block size, allowing final to be smaller */ n1 = *n + 1; Ajn = A; m = *nt;if (m<1) m=1;if (m>*n) m = *n; /* threads to use */ a = (int *)CALLOC((size_t) (*nt+1),sizeof(int)); /* thread block cut points */ a[m] = *n; for (k=0;k<*n;k+= *nb) { if (*n - k < jb) jb = *n - k ; /* end block */ for (pd = dots + k,p1 = dots + *n;pdk) for (;pdxmax) { xmax = x;q=l;} /* find the pivot */ } if (j==0) tol = *n * xmax * DOUBLE_EPS; Aq = A + *n * q + q; // Rprintf("\n n = %d k = %d j = %d q = %d, A[q,q] = %g ",*n,k,j,q,*Aq); if (*Aq - dots[q] k&&j < *n) { /* Lucas (2004) has '1' in place of 'k' */ Aj = Ajn + *n; Aq = Aj + k; /* Lucas (2004) has '1' in place of 'k' */ Aj += j; Aj1 = Ajn + k; /* Lucas (2004) has '1' in place of 'k' */ for (;Aj 0) break; /* now the main work - updating the trailing factor... */ if (k + jb < *n) { /* create the m work blocks for this... */ N = *n - j; /* block to be processed is N by N */ if (m > N) { m = N;a[m] = *n; } /* number of threads to use must be <= r */ *a = j; /* start of first block */ x = (double) N;x = x*x / m; /* compute approximate optimal split... */ for (i=1;i < m;i++) a[i] = round(N - sqrt(x*(m-i)))+j; for (i=1;i <= m;i++) { /* don't allow zero width blocks */ if (a[i]<=a[i-1]) a[i] = a[i-1]+1; } #ifdef OPENMP_ON #pragma omp parallel private(b,i,l,Aj,Aend,Aq,Aj1,Ail,Aj0,Aq0) num_threads(m) #endif { /* start parallel section */ #ifdef OPENMP_ON #pragma omp for #endif for (b=0;b*n) m = *n; /* threads to use */ a = (int *)CALLOC((size_t) (*nt+1),sizeof(int)); /* thread block cut points */ a[m] = *n; for (k=0;k<*n;k+= *nb) { if (*n - k < jb) jb = *n - k ; /* end block */ for (pd = dots + k,p1 = dots + *n;pdk) for (;pdxmax) { xmax = x;q=l;} /* find the pivot q >= j (leading diag only used)*/ } if (j==0) tol = *n * xmax * DOUBLE_EPS; Aq = A + *n * q + q; if (*Aq - dots[q] A[q,q] */ /* A[j,j+1:q-1] <-> A[j+1:q-1,q] */ N = q-j-1; if (N>0) { Aj += *n; /* A[j,j+1] */ Aq = A + q * *n + j + 1; /* A[j+1,q] */ F77_CALL(dswap)(&N,Aj,n,Aq,&one); } /* A[q,q+1:n-1] <-> A[j,q+1:n-1] */ N = *n-q-1; if (N>0) { Aq = A + (q+1) * *n + q; /* A[q,q+1] */ Aj = A + (q+1) * *n + j; /* A[j,q+1] */ F77_CALL(dswap)(&N,Aj,n,Aq,n); } /* A[0:(j-1),j] <-> A[0:(j-1),q] --- note we have to start at row 0 (not k) or already complete rows will not end up correctly pivoted */ N = j; if (N>0) { Aq = A + q * *n; Aj = Ajn; F77_CALL(dswap)(&N,Aj,&one,Aq,&one); } /* now update (only accesses upper triangle) */ /* dgemv(char *trans,int *m, int *n,double *a,double *A,int *lda,double *x,int *dx, double *b, double *y,int *dy) trans='T' to transpose A, 'N' not to. A is m by n. Forms y = a*A'x + b*y, or y = a*Ax + b*y. lda is number of actual rows in A (to allow for sub-matrices) dx and dy are increments of x and y indices. */ Ajj = Ajn + j; *Ajj = sqrt(*Ajj - *pd); /* sqrt(A[j,j]-dots[j]) */ Aend = A + *n * *n; if (j > k&&j < *n) { /* Lucas (2004) has '1' in place of 'k' */ /* A[j,j+1:n-1] += -A[k:j-1,j]*A[k:j-1,j+1:n-1] */ trans='T';N = *n - j - 1;i=j-k; F77_CALL(dgemv)(&trans,&i,&N,&alpha,A+(j+1) * *n + k,n,A + j * *n + k,&one,&beta,A + (j+1) * *n+j,n FCONE); } if (j < *n) { Aj = Ajj; x = *Aj;Aj += *n; for (;Aj 0) break; /* now the main work - updating the trailing factor... A[j:n-1,j:n-1] += - A[k:j-1,j:n-1]'A[k:j-1,j:n-1] */ /* dsyrk(char *uplo, char *trans,int *n, int *k,double *a, double *A, int *lda, double *b, double *C,int *ldc) uplo = 'U' or 'L' for upper or lower tri of C used. trans = 'N' for C = aAA' + bC and A n by k, or 'T' for C = aA'A + bC and A k by n; C is n by n. lda and ldc are actual number of rows in A and C respectively (allows use on submatrices). */ if (k + jb < *n) { N = *n - j ; /* block to be processed is N by N */ i = j - k; /* number of rows in */ trans = 'T';uplo='U';//alpha = -1.0;beta=1.0; if (0) F77_CALL(dsyrk)(&uplo,&trans,&N, &i, &alpha,A+j * *n + k,n,&beta,A + j * *n + j,n FCONE FCONE); else pdsyrk(&N,&i,&alpha,A+j * *n + k,n,&beta,A + j * *n + j,n,work,nt); //rpmat(A,*n); } } /* k loop */ if (r<0) r = *n; FREE(dots); for (Ajn=A,j=0;j<*n;j++,Ajn += *n) { Aj = Ajn;Aend = Aj + *n; if (j *n) *nt = *n; m = *nt; a = (int *)CALLOC((size_t) (*nt+1),sizeof(int)); a[0] = 0;a[m] = *n; /* ... initialize column block splitting array */ r = 0;n1 = *n + 1; for (pk = piv,i=0;i < *n;pk++,i++) *pk = i; /* initialize pivot record */ for (pk=piv,k=0;k< *n;k++,pk++) { kn = k * *n; /* find largest element of diag(A), from k onwards */ Ak = A + kn + k;x = *Ak;q=k;Ak+=n1; for (i=k+1;i < *n;i++,Ak+=n1) if (*Ak>x) {x = *Ak;q=i;} qn = q * *n; if (k==0) thresh = *n * x * DOUBLE_EPS; if (x>thresh) { /* A[q,q] =x > 0 */ r++; /* piv[k] <-> piv[q] */ pq = piv + q;i = *pq; *pq = *pk;*pk = i; /* A[k,k] <-> A[q,q] */ Ak = A + kn + k;Aq = A + qn + q; x = *Ak;*Ak = *Aq;*Aq = x; /* A[k+1:q-1,k] <-> A[q,k+1:q-1] */ Ak++; Aend = Aq; Aq = A + q + kn + *n; for (;Aq A[k,1:k-1] */ Ak = A + k;Aend=Ak + kn;Aq = A + q; for (;Ak < Aend;Ak += *n,Aq += *n) {x = *Aq;*Aq = *Ak;*Ak = x;} /* A[q+1:n,k] <-> A[q+1:n,q] */ Ak = A + kn; Aq = A + qn+q+1;Aend = Ak + *n;Ak+=q+1; for (;Ak N) { m = N;a[m] = *n; } /* number of threads to use must be <= r */ (*a)++; x = (double) N;x = x*x / m; /* compute approximate optimal split... */ for (i=1;i < m;i++) a[i] = round(N - sqrt(x*(m-i)))+k+1; for (i=1;i <= m;i++) { /* don't allow zero width blocks */ if (a[i]<=a[i-1]) a[i] = a[i-1]+1; } /* check load balance... */ // for (i=0;inb0) nb = nb0;/* attempted block size */ for (a0=F,a1=F+nb*pb;a0x) { x = *a0;q=i; } /* find pivot col q */ if (q!=k) { /* then pivot */ i = piv[q];piv[q]=piv[k];piv[k] = i; x = cn[q];cn[q]=cn[k];cn[k] = x; x = icn[q];icn[q]=icn[k];icn[k] = x; Aq = A + q * (ptrdiff_t) n;Ak = A + k * (ptrdiff_t) n;a1 = Aq + n; for (;Aq A[:,q] */ Aq = F + q - jb;Ak = F + j;a1 = F + nb * (ptrdiff_t) pb; for (;Aq F[j,:] */ } /* update the pivot column: A[k:n-1,k] -= A[k:n-1,jb:k-1]F[j,0:j-1]' using BLAS call to DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) y := alpha*A*x + beta*y (or A' if TRANS='T')*/ m = n-k;Ak = A + (ptrdiff_t)n * k + k; if (j) { q = m ; /* total number of rows to split between threads */ rt = q/nt;if (rt*nt < q) rt++; /* rows per thread */ nth = nt; while (nth>1&&(nth-1)*rt>q) nth--; /* reduce number of threads if some empty */ kb[0] = k; /* starting row */ for (i=0;i1&&(nth-1)*rt>q) nth--; /* reduce number of threads if some empty */ kb[0] = j+1; for (i=0;i0) { q = j ; /* total number of rows to split between threads */ rt = q/nt;if (rt*nt < q) rt++; /* rows per thread */ nth = nt; while (nth>1&&(nth-1)*rt>q) nth--; /* reduce number of threads if some empty */ kb[0] = jb; /* starting row */ for (i=0;i1&&(nth-1)*rt>q) nth--; /* reduce number of threads if some empty */ kb[0] = 0; /* starting row */ for (i=0;i1&&(nth-1)*rt>q) nth--; /* reduce number of threads if some empty */ kb[0] = j+1; /* starting col in F, and jb to this to get start in A */ for (i=0;i1&&(nth-1)*rt>m) nth--; /* reduce number of threads if some empty */ kb[0] = k+1; for (i=0;itau) {tau=xx;k=i;} } r = -1; nh = n; /* householder length */ while (tau > 0) { r++; i=piv[r]; piv[r] = piv[k];piv[k] = i; /* swap r with k O(n) */ xx = c[r];c[r] = c[k];c[k] = xx; for (p0 = x + n * r, p1 = x + (ptrdiff_t)n * k,p2 = p0 + n;p0tau) { tau = c[i]; k=i; } } if (r==n-1) tau = 0.0; } /* end while (tau > 0) */ FREE(c); FREE(work); #ifdef OMP_REPORT Rprintf("done\n"); #endif return(r+1); } /* mgcv_piqr */ SEXP mgcv_Rpiqr(SEXP X, SEXP BETA,SEXP PIV,SEXP NT, SEXP NB) { /* routine to QR decompose N by P matrix X with pivoting. Work is done by bpqr. Designed for use with .call rather than .C Return object is as 'qr' in R. */ int n,p,nt,*piv,r,*rrp,nb; double *x,*beta; SEXP rr; nt = asInteger(NT);nb = asInteger(NB); n = nrows(X); p = ncols(X); x = REAL(X);beta = REAL(BETA); piv = INTEGER(PIV); r = bpqr(x,n,p,beta,piv,nb,nt); /* block version */ /* should return rank (r+1) */ rr = PROTECT(allocVector(INTSXP, 1)); rrp = INTEGER(rr); *rrp = r; UNPROTECT(1); return(rr); } /* mgcv_piqr */ void mgcv_pmmult(double *A,double *B,double *C,int *bt,int *ct,int *r,int *c,int *n,int *nt) { /* Forms r by c product, A, of B and C, transposing each according to bt and ct. n is the common dimension of the two matrices, which are stored in R default column order form. This version uses openMP parallelization. nt is number of threads to use. The strategy is rather simple, and this routine is really only useful when B and C have numbers of rows and columns somewhat higher than the number of threads. Assumes number of threads already set on entry and nt reset to 1 if no openMP support. BLAS version A is c (result), B is a, C is b, bt is transa ct is transb r is m, c is n, n is k. Does nothing if r,c or n <= zero. */ char transa='N',transb='N'; int lda,ldb,ldc,cpt,cpf,c1,i,nth; double alpha=1.0,beta=0.0; if (*r<=0||*c<=0||*n<=0) return; #ifdef OMP_REPORT Rprintf("mgcv_pmmult..."); #endif if (B==C) { /* this is serial, unfortunately. note case must be caught as B can be re-ordered! */ if (*bt&&(!*ct)&&(*r==*c)) { getXtX(A,B,n,r);return;} else if (*ct&&(!*bt)&&(*r==*c)) { getXXt(A,B,c,n);return;} } #ifndef OPENMP_ON *nt = 1; #endif if (*nt == 1) { mgcv_mmult(A,B,C,bt,ct,r,c,n); /* use single thread version */ return; } if (*bt) { /* so B is n by r */ transa = 'T'; lda = *n; } else lda = *r; /* B is r by n */ if (*ct) { /* C is c by n */ transb = 'T'; ldb = *c; } else ldb = *n; /* C is n by c */ ldc = *r; if (*ct) { /* have to split on B, which involves re-ordering */ if (*bt) { /* B'C': can split on columns of n by r matrix B, but (r by c) A then needs re-ordering */ cpt = *r / *nt; /* cols per thread */ if (cpt * *nt < *r) cpt++; nth = *r/cpt; if (nth * cpt < *r) nth++; cpf = *r - cpt * (nth-1); /* columns on final block */ #ifdef OPENMP_ON #pragma omp parallel private(i,c1) num_threads(nth) #endif { /* open parallel section */ //c1 = cpt; #ifdef OPENMP_ON #pragma omp for #endif for (i=0;i0) F77_CALL(dgemm)(&transa,&transb,&c1,c,n, &alpha,B + i * (ptrdiff_t) cpt * *n, n , C, c,&beta, A + i * (ptrdiff_t) cpt * *c, &c1 FCONE FCONE); } } /* parallel section ends */ /* now re-order the r by c matrix A, which currently contains the sequential blocks corresponding to each cpt rows of A */ row_block_reorder(A,r,c,&cpt,bt); /* bt used here for 'reverse' as it contains a 1 */ } else { /* BC':worst case - have to re-order r by n mat B and then reverse re-ordering of B and A at end */ cpt = *r / *nt; /* cols per thread */ if (cpt * *nt < *r) cpt++; nth = *r/cpt; if (nth * cpt < *r) nth++; cpf = *r - cpt * (nth-1); /* columns on final block */ /* re-order cpt-row blocks of B into sequential cpt by n matrices (in B) */ row_block_reorder(B,r,n,&cpt,bt); /* bt contains a zero - forward mode here */ #ifdef OPENMP_ON #pragma omp parallel private(i,c1) num_threads(nth) #endif { /* open parallel section */ //c1 = cpt; #ifdef OPENMP_ON #pragma omp for #endif for (i=0;i0) F77_CALL(dgemm)(&transa,&transb,&c1,c,n, &alpha,B + i * (ptrdiff_t) cpt * *n, &c1,C,c,&beta, A + i * (ptrdiff_t) cpt * *c, &c1 FCONE FCONE); } } /* parallel ends */ /* now reverse the re-ordering */ row_block_reorder(B,r,n,&cpt,ct); row_block_reorder(A,r,c,&cpt,ct); } } else { /* can split on columns of n by c matrix C, which avoids re-ordering */ cpt = *c / *nt; /* cols per thread */ if (cpt * *nt < *c) cpt++; nth = *c/cpt; if (nth * cpt < *c) nth++; cpf = *c - cpt * (nth-1); /* columns on final block */ #ifdef OPENMP_ON #pragma omp parallel private(i,c1) num_threads(*nt) #endif { /* open parallel section */ //c1 = cpt; #ifdef OPENMP_ON #pragma omp for #endif for (i=0;i< nth;i++) { if (i == nth-1) c1 = cpf;else c1=cpt; /* how many columns in this block */ if (c1>0) F77_CALL(dgemm)(&transa,&transb,r,&c1,n, &alpha,B, &lda,C + i * (ptrdiff_t) *n * cpt, &ldb,&beta, A + i * (ptrdiff_t) *r * cpt, &ldc FCONE FCONE); } } /* end parallel */ } #ifdef OMP_REPORT Rprintf("done\n"); #endif } /* end mgcv_pmmult */ void pcrossprod(double *B, double *A,int *R, int *C,int *nt,int *nb) { /* B=A'A if t==0. A is R by C. nb^2 is the target number of elements in a block. nt is the number of threads to use. B is C by C. 30/4 memorial edition */ int M,N,nf,nrf,kmax,kk,i,r,c,k,bn,an,cn; ptrdiff_t as,bs,cs; char uplo = 'U',trans='T',ntrans='N'; double alpha=1.0,beta=1.0; M = ceil(((double) *C)/ *nb); N = ceil(((double) *R)/ *nb); if (M==1) { /* perform single threaded crossprod */ beta = 0.0; F77_CALL(dsyrk)(&uplo,&trans,C,R,&alpha,A,R,&beta,B,C FCONE FCONE); } else { nf = *C - (M-1) * *nb; /* cols in last col block of A */ nrf = *R - (N-1) * *nb; /* rows in last row block of A */ kmax = (M+1)*M/2; /* number of blocks in upper triangle */ #ifdef OPENMP_ON #pragma omp parallel for private(kk,i,r,c,bn,bs,k,as,an,beta,cs,cn) num_threads(*nt) #endif for (kk=0;kk= M-r) { i -= M - r; r++;}; c = r + i; /* convert kk to row/col */ if (r==M-1) bn = nf; else bn = *nb; /* (row) B block size */ bs = r * (ptrdiff_t) *nb; /* (row) B block start */ if (c==r) { /* diagonal block */ for (k=0;k 0) *XtWX = xx; for (i=0;i< *c;i++) for (j=0;j0) { /* R is transposed */ for (i=0;i<*p;i++) { for (p0=Vi,k=0;k<*M;k++) { /* Vi is i by M */ p1 = dR + k * *p * *p + i * *p; /* start of col i of kth dR */ p2 = p1 + i + 1; /* first zero in col i of kth dR */ for (;p1i) dR[k] = (dA[k] - x - R[k]*dR[i + i * *p])/R[i + i * *p]; else dR[k] = (dA[k] - x)*.5/R[i + i * *p]; } } /* dchol */ SEXP mgcv_chol_down(SEXP r,SEXP ru,SEXP N,SEXP K, SEXP UT) { /* wrapper for calling chol_down using .Call */ double *R,*Rup; int *n,*k,*ut; R = REAL(r);Rup=REAL(ru); n = INTEGER(N); k = INTEGER(K); ut = INTEGER(UT); chol_down(R,Rup,n,k,ut); return(R_NilValue); } inline double hypot(double x, double y) { /* stable computation of sqrt(x^2 + y^2) */ double t; x = fabs(x);y=fabs(y); if (y>x) { t = x;x = y; y = t;} if (x==0) return(y); else t = y/x; return(x*sqrt(1+t*t)); } /* hypot */ void chol_down(double *R,double *Rup, int *n,int *k,int *ut) { /* R is an n by n choleski factor of an n by n matrix A. We want the downdated factor for A[-k,-k] returned in n-1 by n-1 matrix Rup. If ut!=0 then R'R = A, with R and Rup upper triangular. Otherwise RR'=A, with R and Rup lower triangular. The latter update is more Cache friendly with less effort, since the update is then from the right and operates columnwise. However, code below is column oriented in both cases, storing the givens rotations as they are computed to facilitate column orientation when R is upper triangular. Calls from R should ideally be made from a wrapper called from .Call, since otherwise copying can be the dominant cost. */ int i,n1; double x,*Ri1,*Ri,*Rj,c,s,*Re,*ca,*sa,*sp,*cp; n1 = *n-1; if (*ut) { /* upper trianglar col oriented computation */ ca = R + 2;sa = ca + *n; /* Givens storage */ for (i=0;i= *k) { /* cols from beyond dropped col k need updating */ /* first the stored rotations */ Re = Rup + i * n1 + i; Ri1=Ri;Ri--; for (cp=ca,sp=sa;Ri R[j,j] */ z0 = hypot(z,*x); /* sqrt(z^2+R[j,j]^2) */ c0 = *x/z0; s0 = z/z0; /* need to zero z */ /* now apply this rotation and this column is finished (so no need to update z) */ *x = s0 * z + c0 * *x; } else for (j1=-1,j=0;j<*n;j++,u++,j1++) { /* loop over columns of R for down-dating */ z = *u; /* initial element of u */ x = R + *n * j; /* current column */ c = R + 2;s = R + *n + 2; /* Storage for first n-2 hyperbolic rotations */ for (c1=c+j1;c R[j,j] */ z0 = z / *x; /* sqrt(z^2+R[j,j]^2) */ if (fabs(z0)>=1) { /* downdate not +ve def */ //Rprintf("j = %d d = %g ",j,z0); if (*n>1) R[1] = -2.0;return; /* signals error */ } if (z0 > 1 - *eps) z0 = 1 - *eps; c0 = 1/sqrt(1-z0*z0);s0 = c0 * z0; /* now apply this rotation and this column is finished (so no need to update z) */ *x = -s0 * z + c0 * *x; } /* now zero c and s storage */ c = R + 2;s = R + *n + 2; for (x = c + *n - 2;c0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); /* actual call */ F77_CALL(dgesvd)(&jobu,&jobvt, r, c, x, &lda, d, u, &ldu, vt,&ldvt, work, &lwork, &info FCONE FCONE); FREE(work); } void mgcv_svd_full(double *x,double *vt,double *d,int *r,int *c) /* call LA_PACK svd routine to form x=UDV'. U returned in x. V' returned in vt. assumed r >= c. U is r by c. D is length c. V is c by c. # Here is R test code..... library(mgcv) n<-4;q<-3 X<-matrix(rnorm(n*q),n,q) um<-.C("mgcv_svd_full",as.double(X),double(q*q),double(q),as.integer(n),as.integer(q), PACKAGE="mgcv") er<-La.svd(X) matrix(um[[1]],n,q);er$u um[[3]];er$d matrix(um[[2]],q,q);er$v */ { const char jobu='O',jobvt='A'; int lda,ldu,ldvt,lwork; int info; double work1,*work,*u=NULL; ldu=lda= *r;ldvt = *c; lwork=-1; /* workspace query */ F77_CALL(dgesvd)(&jobu,&jobvt, r, c, x, &lda, d, u, &ldu, vt,&ldvt, &work1, &lwork, &info FCONE FCONE); lwork=(int)floor(work1); if (work1-lwork>0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); /* actual call */ F77_CALL(dgesvd)(&jobu,&jobvt, r, c, x, &lda, d, u, &ldu, vt,&ldvt, work, &lwork, &info FCONE FCONE); FREE(work); } void mgcv_td_qy(double *S,double *tau,int *m,int *n, double *B,int *left,int *transpose) /* Multiplies m by n matrix B by orthogonal matrix returned from mgcv_tri_diag and stored in S, tau. B is overwritten with result. Note that this is a bit inefficient if really only a few rotations matter! Calls LAPACK routine dormtr */ { char trans='N',side='R',uplo='U'; int nq,lwork=-1,info; double *work,work1; if (*left) { side = 'L';nq = *m;} else nq = *n; if (*transpose) trans = 'T'; /* workspace query ... */ F77_CALL(dormtr)(&side,&uplo,&trans,m,n,S,&nq,tau,B,m,&work1,&lwork,&info FCONE FCONE FCONE); lwork=(int)floor(work1);if (work1-lwork>0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); /* actual call ... */ F77_CALL(dormtr)(&side,&uplo,&trans,m,n,S,&nq,tau,B,m,work,&lwork,&info FCONE FCONE FCONE); FREE(work); } void tri_chol(double *ld,double *sd,int *n,int *info) { /* compute LDL' decomposition of n by n symm tridiagonal matrix with leading diagonal ld and sub/sup diagonals sd. Returns D in ld and sub-diagonal of L in sd (leading diagonal of L is all ones). info is 0 for success, -k if kth argument illegal and k0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); /* Actual call... */ F77_CALL(dsytrd)(&uplo,n,S,n,d,e,tau,work,&lwork,&info FCONE); FREE(work);FREE(d);FREE(e); } void mgcv_pbsi0(double *R, int *n,int *nt) { /* Form inverse of upper triangular R (n by n) in situ. Block oriented, using BLAS/LAPACK calls. */ int j,info,jb,nb=50; char left = 'L',right = 'R',up='U',ntrans='N',diag='N'; double d1 = 1.0,m1= -1.0; for (j=0;j< *n;j+=nb) { jb = *n - j; if (jb>nb) jb=nb; /* block size */ if (j) { /* A[0:j-1,j:j+jb-1] <- A[0:j-1,0:j-1] A[0:j-1,j:j+jb-1] O(j^2 jb)*/ F77_CALL(dtrmm)(&left,&up,&ntrans,&diag,&j,&jb,&d1,R,n,R + j * *n,n FCONE FCONE FCONE FCONE); /* A[0:j-1,j:j+jb-1] <- A[0:j-1,j:j+jb-1] A[j:j+jb-1,j:j+jb-1]^{-1} O(j jb^2) */ F77_CALL(dtrsm)(&right,&up,&ntrans,&diag,&j,&jb,&m1,R + *n * j + j,n,R + j * *n,n FCONE FCONE FCONE FCONE); } /* invert A[j:j+jb-1,j:j+jb-1] O(jb^3)*/ F77_CALL(dtrti2)(&up,&diag,&jb,R + *n * j + j,n,&info FCONE FCONE); } } /* mgcv_pbsi0 */ void mgcv_pbsi1(double *R, int *n,int *nt) { /* Form inverse of upper triangular R (n by n) in situ. Block oriented, using BLAS/LAPACK calls. */ int j,info,jb,nb=50,*iwork; char left = 'L',right = 'R',up='U',ntrans='N',diag='N'; double d1 = 1.0,m1= -1.0,*work; iwork = (int *)CALLOC((size_t)3 * (*nt *(*nt+1))/2 + 2 * *nt + 2,sizeof(int)); work = (double *)CALLOC((size_t) nb * ((ptrdiff_t) *n + *nt + 1) * (*nt + 1)/2,sizeof(double)); for (j=0;j< *n;j+=nb) { jb = *n - j; if (jb>nb) jb=nb; /* block size */ if (j) { /* A[0:j-1,j:j+jb-1] <- A[0:j-1,0:j-1] A[0:j-1,j:j+jb-1] O(j^2 jb)*/ if (0) F77_CALL(dtrmm)(&left,&up,&ntrans,&diag,&j,&jb,&d1,R,n,R + j * *n,n FCONE FCONE FCONE FCONE); else pdtrmm(&j,&jb,&d1,R,n,R + j * *n,n,nt,iwork,work); /* A[0:j-1,j:j+jb-1] <- A[0:j-1,j:j+jb-1] A[j:j+jb-1,j:j+jb-1]^{-1} O(j jb^2) */ F77_CALL(dtrsm)(&right,&up,&ntrans,&diag,&j,&jb,&m1,R + *n * j + j,n,R + j * *n,n FCONE FCONE FCONE FCONE); } /* invert A[j:j+jb-1,j:j+jb-1] O(jb^3)*/ F77_CALL(dtrti2)(&up,&diag,&jb,R + *n * j + j,n,&info FCONE FCONE); } FREE(work);FREE(iwork); } /* mgcv_pbsi1 */ void mgcv_pbsi(double *R,int *r,int *nt) { /* parallel back substitution inversion of upper triangular matrix using nt threads i.e. Solve of R Ri = I for Ri. Idea is to work through columns of I exploiting fact that full solve is never needed. Results are stored in lower triangle of R and an r-dimensional array, and copied into R before exit (working back trough columns over-writing columns of R as we go is not an option without waiting for threads to return in right order - which can lead to blocking by slowest). This version avoids BLAS calls which have function call overheads. In single thread mode it is 2-3 times faster than a BLAS call to dtrsm. It uses a load balancing approach, splitting columns up to threads in advance, so that thread initialisation overheads are minimised. This is important, e.g. the alternative of sending each column to a separate thread removes almost all advantage of parallel computing, because of the thread initiation overheads. Only disadvantage of this approach is that all cores are assumed equal. */ int i,j,k,r1,*a,b; double x,*d,*dk,*z,*zz,*z1,*rr,*Rjj,*r2; #ifdef OMP_REPORT Rprintf("mgcv_pbsi..."); #endif d = (double *)CALLOC((size_t) *r,sizeof(double)); if (*nt < 1) *nt = 1; if (*nt > *r) *nt = *r; /* no point having more threads than columns */ /* now obtain block start columns, a. a[i] is start column of block i. */ a = (int *)CALLOC((size_t) (*nt+1),sizeof(int)); a[0] = 0;a[*nt] = *r; x = (double) *r;x = x*x*x / *nt; /* compute approximate optimal split... */ for (i=1;i < *nt;i++) a[i] = round(pow(x*i,1/3.0)); for (i=*nt-1;i>0;i--) { /* don't allow zero width blocks */ if (a[i]>=a[i+1]) a[i] = a[i+1]-1; } r1 = *r + 1; #ifdef OPENMP_ON #pragma omp parallel private(b,i,j,k,zz,z,z1,rr,Rjj,dk) num_threads(*nt) #endif { /* open parallel section */ #ifdef OPENMP_ON #pragma omp for #endif for (b=0;b< *nt;b++) { /* b is thread/block index */ for (i=a[b];i=0;j--) { Rjj -= r1; dk = z + j; *dk /= - *Rjj; for (zz=z,z1=z+j,rr=Rjj-j;zz0;i--) { /* don't allow zero width blocks */ if (a[i]>=a[i+1]) a[i] = a[i+1]-1; } #ifdef OPENMP_ON #pragma omp parallel private(b,i,k,zz,rr,r2) num_threads(*nt) #endif { /* open parallel section */ #ifdef OPENMP_ON #pragma omp for #endif for (b=0;b<*nt;b++) { for (i=a[b];i ii;a[ii]+(b[ii]-1)*n->ii ## upper library(mgcv);R <- matrix(0,n,n);R[ii] <- runif(n*(n+1)/2) system.time(A <- mgcv:::pRRt(R,2)) system.time(A2 <- tcrossprod(R));range(A-A2);plot(A,A2,pch=".") */ int i,j,k,ik,nb=50,ib,m,*s; char right='R',up='U',trans='T',no='N'; double one=1.0,di,x; // first pointlessly copy R to A s = (int *)CALLOC((size_t) *nt + 1,sizeof(int)); for (i=0;i<*r;i++) for (j=i;j<*r;j++) A[i + j * *r] = R[i + j * *r]; for (i=0;i< *r;i+=nb) { ib= *r-i; if (ib>nb) ib = nb; /* A[0:i-1,i:i+ib-1] = A[0:i-1,i:i+ib-1]A'[i:i+ib-1,i:i+ib-1] O(ib^2 i) */ F77_CALL(dtrmm)(&right,&up,&trans,&no,&i,&ib,&one,A + *r * i + i,r,A + *r * i, r FCONE FCONE FCONE FCONE); /* A[i:i+ib-1,i:i+ib-1] A[i:i+ib-1,i:i+ib-1]' (self overwrite)*/ F77_CALL(dlauu2)(&up,&ib,A + *r * i + i,r,&j FCONE); if (i+ib < *r) { j = *r - i - ib; m = *nt;while (5*m>i && m>1) m--; /* don't use a pointless number of threads */ di = i / (double) m; /* rows per thread */ s[0]=0; for (x=0.0,k=1;k *r) *nt = *r; /* no point having more threads than columns */ a = (int *)CALLOC((size_t) (*nt+1),sizeof(int)); a[0] = 0;a[*nt] = *r; /* It is worth transposing R into lower triangle */ x = (double) *r;x = x*x / *nt; /* compute approximate optimal split... */ for (i=1;i < *nt;i++) a[i] = round(*r - sqrt(x*(*nt-i))); for (i=1;i <= *nt;i++) { /* don't allow zero width blocks */ if (a[i]<=a[i-1]) a[i] = a[i-1]+1; } #ifdef OPENMP_ON #pragma omp parallel private(b,i,ru,rl,r1) num_threads(*nt) #endif { /* open parallel section */ #ifdef OPENMP_ON #pragma omp for #endif for (b=0;b<*nt;b++) { for (i=a[b];i=0;i--) { /* work up each column of B & C */ x = 0.0; /* for (k=i+1;k<*c;k++) x += R[i + *r * k] * C[k + j * *c]; ...following replaces...*/ pR = R + i + (i+1) * (ptrdiff_t)*r;pC = C + j * (ptrdiff_t)*c + i + 1; for (k=i+1;k<*c;k++,pR+= *r,pC++) x += *pR * *pC; C[i + (ptrdiff_t)j * *c] = (B[i + (ptrdiff_t)j * *c] - x)/R[i + (ptrdiff_t)*r * i]; } } } void mgcv_forwardsolve0(double *R,int *r,int *c,double *B,double *C, int *bc) /* BLAS free version Finds C = R^{-T} B where R is the c by c matrix stored in the upper triangle of r by c argument R. B is c by bc. (Possibility of non square argument R facilitates use with output from mgcv_qr). This is just a standard forward substitution loop. */ { int i,j,k; double x; for (j=0;j<*bc;j++) { /* work across columns of B & C */ for (i = 0;i< *c;i++) { /* work down each column of B & C */ x=0.0; for (k=0;k *nb * k) { nbf = *r - *nb * k;k++; /* nbf number of rows in final block */ } /* first task is to pad the end block segments, so that all segments have equal length, otherwise efficient segment swapping is not possible. This requires spilling over into extra storage. */ ns = k * *c; /* total number of segments */ if (nbf) { /* only do this if final block shorter than rest */ ns_main = (*r * *c) / *nb; /* full segments fitting in x */ ns_extra = ns - ns_main; /* segments requiring extra storage */ extra = (double *) CALLOC((size_t) (*nb * ns_extra),sizeof(double)); x0 = extra + *nb * ns_extra - 1; /* end of extra */ x1 = x + *r * *c -1 ; /* end of x */ if (*reverse) { /* blocks back into single matrix */ /* expand end segments out into extra storge */ for (i=ns-1;i >= ns_main;i--) { x0 -= *nb - nbf; /* skip padding in target */ for (j=0;j= ns - *c;i--) { x0 -= *nb - nbf; /* skip padding in target */ for (j=0;j=ns_main;i--) { /* work down through segments */ if ((i+1)%k) { /* not a short segment */ for (j = 0;j < *nb;j++,x0--,x1--) *x0 = *x1; } else { x0 -= (*nb - nbf); /* skip padding in target */ for (j = 0;j < nbf;j++,x0--,x1--) *x0 = *x1; /* fill rest from source */ } } /* now copy segments into x with padding ... */ x0 = x + ns_main * *nb - 1; /* end of main block segment storage */ for (;i>=0;i--) { /* continue down through segments */ if ((i+1)%k) { /* not a short segment */ for (j = 0;j < *nb;j++,x0--,x1--) *x0 = *x1; } else { x0 -= (*nb - nbf); for (j = 0;j < nbf;j++,x0--,x1--) *x0 = *x1; } } } /* end of forward mode padding */ } else { /* segments already equal length */ ns_main = ns;ns_extra=0; /* all segments fit into x */ } /* now re-arrange row-block wise... */ /* a[i] is original segment now in segment i... */ a = (ptrdiff_t *) CALLOC((size_t) (k * *c),sizeof(ptrdiff_t)); /* s[i] is segment now containing original segment i */ s = (ptrdiff_t *) CALLOC((size_t) (k * *c),sizeof(ptrdiff_t)); for (i=0;i *nt) k = *nt; else { fkd = floor(kd);ckd = ceil(kd); if (fkd>1) x = *r / fkd + fkd * *c; else x = *r; if (*r / ckd + ckd * *c < x) k = (int)ckd; else k = (int)fkd; } return(k); #else return(1); /* can only use 1 thread if no openMP support */ #endif } void getRpqr(double *R,double *x,int *r, int *c,int *rr,int *nt) { /* x contains qr decomposition of r by c matrix as computed by mgcv_pqr This routine simply extracts the c by c R factor into R. R has rr rows, where rr == c if R is square. */ int i,j,n,rows; double *Rs; Rs = x;n = *r; rows = *c; if (rows > *rr) rows = *rr; for (i=0;ij) R[i + *rr * j] = 0; else R[i + *rr * j] = Rs[i + n * j]; } /* getRpqr */ void getRpqr0(double *R,double *x,int *r, int *c,int *rr,int *nt) { /* x contains qr decomposition of r by c matrix as computed by mgcv_pqr This routine simply extracts the c by c R factor into R. R has rr rows, where rr == c if R is square. This version matches mgcv_pqrqy0, which is inferior to current code. */ int i,j,k,n; double *Rs; k = get_qpr_k(r,c,nt); /* number of blocks used */ if (k==1) { /* actually just a regular serial QR */ Rs = x;n = *r; } else { n = k * *c; /* rows of R */ Rs = x + *r * *c; /* source R */ } for (i=0;i<*c;i++) for (j=0;j<*c;j++) if (i>j) R[i + *rr * j] = 0; else R[i + *rr * j] = Rs[i + n * j]; } /* getRpqr0 */ void mgcv_pqrqy0(double *b,double *a,double *tau,int *r,int *c,int *cb,int *tp,int *nt) { /* Applies factor Q of a QR factor computed in parallel to b. If b is physically r by cb, but if tp = 0 it contains a c by cb matrix on entry, while if tp=1 it contains a c by cb matrix on exit. Unused elments of b on entry assumed 0. a and tau are the result of mgcv_pqr This version matches mgcv_pqr0, which scales less well than current code. */ int i,j,k,l,left=1,n,nb,nbf,nq,TRUE=1,FALSE=0; double *x0,*x1,*Qb; #ifdef OMP_REPORT Rprintf("mgcv_pqrqy0..."); #endif k = get_qpr_k(r,c,nt); /* number of blocks in use */ if (k==1) { /* single block case */ if (*tp == 0 ) {/* re-arrange so b is a full matrix */ x0 = b + *r * *cb -1; /* end of full b (target) */ x1 = b + *c * *cb -1; /* end of used block (source) */ for (j= *cb;j>0;j--) { /* work down columns */ /*for (i = *r;i > *c;i--,x0--) *x0 = 0.0;*/ /* clear unused */ x0 -= *r - *c; /* skip unused */ for (i = *c;i>0;i--,x0--,x1--) { *x0 = *x1; /* copy */ if (x0!=x1) *x1 = 0.0; /* clear source */ } } } /* if (*tp) */ mgcv_qrqy(b,a,tau,r,cb,c,&left,tp); if (*tp) { /* need to strip out the extra rows */ x1 = x0 = b; for (i=0;i < *cb;i++,x1 += *r - *c) for (j=0;j < *c;j++,x0++,x1++) *x0 = *x1; } return; } /* multi-block case starts here */ nb = (int)ceil(*r/(double)k); /* block size - in rows */ nbf = *r - (k-1)*nb; /* end block size */ Qb = (double *)CALLOC((size_t) (k * *c * *cb),sizeof(double)); nq = *c * k; if (*tp) { /* Q'b */ /* first the component Q matrices are applied to the blocks of b */ if (*cb > 1) { /* matrix case - repacking needed */ row_block_reorder(b,r,cb,&nb,&FALSE); } #ifdef OPENMP_ON #pragma omp parallel private(i,j,l,n,x1) num_threads(k) #endif { /* open parallel section */ #ifdef OPENMP_ON #pragma omp for #endif for (i=0;i1) row_block_reorder(b,r,cb,&nb,&TRUE); } #ifdef OMP_REPORT Rprintf("done\n"); #endif FREE(Qb); } /* mgcv_pqrqy0 */ void mgcv_pqrqy(double *b,double *a,double *tau,int *r,int *c,int *cb,int *tp,int *nt) { /* Applies factor Q of a QR factor computed by mgcv_pqr to b. b is physically r by cb, but if tp = 0 it contains a c by cb matrix on entry, while if tp=1 it contains a c by cb matrix on exit. Unused elments of b on entry assumed 0. a and tau are the result of mgcv_pqr. Note that in multi-threaded mode this uses mgcv_pqr0, which is thread safe, but level 2. mgcv_pqr is level 3 but not thread safe. mgcv_pqrqy itself is not thread safe - i.e. this should not be called from a parallel section (which would be dumb anyway). */ int i,j,ki,k,left=1,nth; double *x0,*x1,*aii,*p0; #ifdef OMP_REPORT Rprintf("mgcv_pqrqy..."); #endif //Rprintf("pqrqy %d ",*nt); if (*tp == 0 ) {/* re-arrange so b is a full matrix */ x0 = b + *r * *cb -1; /* end of full b (target) */ x1 = b + *c * *cb -1; /* end of used block (source) */ for (j= *cb;j>0;j--) { /* work down columns */ /*for (i = *r;i > *c;i--,x0--) *x0 = 0.0;*/ /* clear unused */ x0 -= *r - *c; /* skip unused */ for (i = *c;i>0;i--,x0--,x1--) { *x0 = *x1; /* copy */ if (x0!=x1) *x1 = 0.0; /* clear source */ } } } /* if (*tp) */ if (*cb==1 || *nt==1) mgcv_qrqy(b,a,tau,r,cb,c,&left,tp); else { /* split operation by columns of b */ /* set leading diagonal elements of a to 1 and store them */ aii = (double *)CALLOC((size_t)*c,sizeof(double)); for (k=*r+1,x0=aii,x1=aii + *c,p0=a;x0 *cb) nth = *cb; k = *cb/nth; if (k*nth < *cb) k++; /* otherwise last thread is rate limiting */ if (k*(nth-1) >= *cb) nth--; /* otherwise last thread has no work */ #ifdef OPENMP_ON #pragma omp parallel private(i,j,ki) num_threads(nth) #endif { /* open parallel section */ #ifdef OPENMP_ON #pragma omp for #endif for (i=0;i>p, not so good otherwise. - this is old code, which is uniformly less efficient than replacement. */ int i,j,k,l,*piv,nb,nbf,n,TRUE=1,FALSE=0,nr; double *R,*R1,*xi; #ifdef OMP_REPORT Rprintf("mgcv_pqr0..."); #endif k = get_qpr_k(r,c,nt);/* number of threads to use */ if (k==1) mgcv_qr(x,r,c,pivot,tau); else { /* multi-threaded version */ nb = (int)ceil(*r/(double)k); /* block size */ nbf = *r - (k-1)*nb; /* end block size */ /* need to re-arrange row blocks so that they can be split between qr calls */ row_block_reorder(x,r,c,&nb,&FALSE); piv = (int *)CALLOC((size_t) (k * *c),sizeof(int)); R = x + *r * *c ; /* pointer to combined unpivoted R matrix */ nr = *c * k; /* number of rows in R */ #ifdef OPENMP_ON #pragma omp parallel private(i,j,l,n,xi,R1) num_threads(k) #endif { /* open parallel section */ #ifdef OPENMP_ON #pragma omp for #endif for (i=0;i0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); /* actual call */ F77_CALL(dgeqp3)(r,c,x,r,pivot,tau,work,&lwork,&info); FREE(work); /*if (*r<*c) lwork= *r; else lwork= *c;*/ for (ip=pivot;ip < pivot + *c;ip++) (*ip)--; /* ... for 'tis C in which we work and not the 'cursed Fortran... */ } /* end mgcv_qr */ void mgcv_qr2(double *x, int *r, int *c,int *pivot,double *tau) /* call LA_PACK to get QR decomposition of x tau is an array of length min(r,c) pivot is array of length c, zeroed on entry, pivoting order on return. On exit upper triangle of x is R. Below upper triangle plus tau represent reflectors making up Q. pivoting is not performed in this case, but the pivoting index is returned anyway. library(mgcv) r<-4;c<-3 X<-matrix(rnorm(r*c),r,c) pivot<-rep(1,c);tau<-rep(0,c) um<-.C("mgcv_qr",as.double(X),as.integer(r),as.integer(c),as.integer(pivot),as.double(tau)) qr.R(qr(X));matrix(um[[1]],r,c)[1:c,1:c] */ { int info,*ip,i; double *work; work=(double *)CALLOC((size_t)*r,sizeof(double)); /* actual call */ /* Args: M, N, A, LDA, TAU, WORK, INFO */ F77_CALL(dgeqr2)(r,c,x,r,tau,work,&info); FREE(work); /*if (*r<*c) lwork= *r; else lwork= *c;*/ for (i=0,ip=pivot;ip < pivot + *c;ip++,i++) *ip = i; /* ... pivot index equivalent to no pivoting */ } /* end mgcv_qr2 */ void mgcv_qrqy0(double *b,double *a,double *tau,int *r,int *c,int *k,int *left,int *tp) { /* mgcv_qrqy is not thread safe, because of the behaviour of dormqr (and similar functions). This version uses dlarf for a thread safe routine, but this is then level 2, *and requires modification of a before entry*. Applies k reflectors of Q of a QR decomposition to r by c matrix b. Apply Q from left if left!=0, right otherwise. Transpose Q only if tp!=0. Information about Q has been returned from mgcv_qr, and is stored in tau and *on and* below the leading diagonal of a. In fact the leading diagonal elements must be set to 1 before entry to this routine. SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) */ char side='L'; int lda,lwork=-1,incv=1,ri,i0,i1,ii,i; double *work,*v; if (! *left) { side='R';lda = *c;lwork = *r; } else { lda= *r;lwork = *c; } /* calloc is thread safe, CALLOC ambiguous */ work=(double *)calloc((size_t)lwork,sizeof(double)); if ((*left && ! *tp)||(! *left && *tp)) { /* kth H applied first */ i0 = *k - 1;i1=-1;ii=-1; } else { /* 1st H applied first */ i0 = 0;i1 = *k;ii=1; } for (i=i0;i!=i1;i+=ii) { v = a + lda * i + i; /* start of v */ ri = *r - i; /* number of rows in sub-block to which this applies */ F77_CALL(dlarf)(&side,&ri,c,v,&incv,tau+i,b+i,r,work FCONE); } free(work); } /* mgcv_qrqy0 */ void mgcv_qrqy(double *b,double *a,double *tau,int *r,int *c,int *k,int *left,int *tp) /* applies k reflectors of Q of a QR decomposition to r by c matrix b. Apply Q from left if left!=0, right otherwise. Transpose Q only if tp!=0. Information about Q has been returned from mgcv_qr, and is stored in tau and below the leading diagonal of a. library(mgcv) r<-4;c<-3 X<-matrix(rnorm(r*c),r,c) qrx<-qr(X) pivot<-rep(1,c);tau<-rep(0,c) um<-.C("mgcv_qr",a=as.double(X),as.integer(r),as.integer(c),as.integer(pivot),tau=as.double(tau)) y<-1:4;left<-1;tp<-0;cy<-1 er<-.C("mgcv_qrqy",as.double(y),as.double(um$a),as.double(um$tau),as.integer(r),as.integer(cy),as.integer(c), as.integer(left),as.integer(tp),PACKAGE="mgcv") er[[1]];qr.qy(qrx,y) dormqr is not thread safe (with feasible memory use, at least). A block threadsafe version could be built using dlarft, dlarfb. A level 2 thread safe version could be built using dlarf (as in dorm2r) */ { char side='L',trans='N'; int lda,lwork=-1,info; double *work,work1; if (! *left) { side='R';lda = *c;} else lda= *r; if ( *tp) trans='T'; /* workspace query */ F77_CALL(dormqr)(&side,&trans,r,c,k,a,&lda,tau,b,r,&work1,&lwork,&info FCONE FCONE); lwork=(int)floor(work1);if (work1-lwork>0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); /* actual call */ F77_CALL(dormqr)(&side,&trans,r,c,k,a,&lda,tau,b,r,work,&lwork,&info FCONE FCONE); FREE(work); } void update_qr(double *Q,double *R,int *n, int *q,double *lam, int *k) /* Let X=QR where X is n by q and R is q by q upper triangular and Q is n by q. A single element extra row, x, is to be appended to X and Q and R updated accordingly. x is zero except for kth element lam. Let Q* be the full orthogonal matrix of which Q is the upper left portion, then [X] = [Q* 0][R] [x] [0 1][0] [x] The rhs of the above can be bought into standard QR form by application of givens rotations from the left to the augmented R matrix and the corresponding inverse rotations from the right to the augmented Q* matrix. The rotations from the right applied to the augmented Q* have the effect of rotating columns of Q into the final column of the augmented matrix and vice-versa. Since the columns between Q and the final column are not involved, only Q and R need to be updated here, the rest of Q* being irrelevant. This routine does not augment the Q by an extra row, it is assumed that the calling function only requires the update of the input rows. All matrices are assumed to be packed in column order. Some very minor further optimizations could be added (e.g. using fact that working and most of x are zero at first iteration), but it's really unlikely to yield a worthwhile saving. Some R code for testing the routine: library(mgcv) n<-4;q<-3 X<-matrix(rnorm(n*q),n,q) #X[,q-1]<-X[,q] qrx<-qr(X,tol=0) Q<-qr.Q(qrx);R<-qr.R(qrx);lam<-1 um<-.C("update_qr",as.double(Q),as.double(R),as.integer(n),as.integer(q), as.double(lam),as.integer(q-1),PACKAGE="mgcv") R1<-matrix(um[[2]],q,q);Q1<-matrix(um[[1]],n,q) Xa<-matrix(0,n+1,q) Xa[1:n,]<-X;Xa[n+1,q]<-lam qr.R(qr(Xa,tol=0)) */ { double *x,*work,c,s,r,x0,x1,m,*xip,*xjp,*riip,*rijp,*Qp,*wp; x=(double *)CALLOC((size_t)*q,sizeof(double)); work=(double *)CALLOC((size_t)*n,sizeof(double)); /* working extra column of Q */ x[*k] = *lam; /* conceptually i runs from k to q in the following loop */ for (Qp=Q+ *k * *n,riip=R+ *k * *q + *k,xip=x+ *k ;xip< x+ *q;xip++,riip+= *q+1) { /* rotate x[i] into R[i,i], using over/underflow proof rotator */ x0= *xip; /* x[i] */ x1= *riip; /* R[1 * *q + i] */ m = fabs(x0);s=fabs(x1); if (s>m) m=s; x1/=m;x0/=m; r=sqrt(x0*x0+x1*x1); c=x1/r;s=x0/r; *riip=m*r;/* *xip=0.0; but never neaded*/ /* conceptually j runs from i+1 to q in the following loop */ for (rijp=riip + *q,xjp=xip+1;xjp0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); liwork = iwork1;iwork= (int *)CALLOC((size_t)liwork,sizeof(int)); F77_CALL(dsyevd)(&jobz,&uplo,n,A,n,ev,work,&lwork,iwork,&liwork,&info FCONE FCONE); FREE(work);FREE(iwork); if (*descending) for (i=0;i<*n/2;i++) { /* work in from left and right swapping cols */ p = A + i * *n; /* start of left col */ p1 = A + *n * (*n - 1 - i); /* start of right col */ for (p2 = p + *n;p0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); liwork = iwork1;iwork= (int *)CALLOC((size_t)liwork,sizeof(int)); F77_CALL(dsyevr)(&jobz,&range,&uplo, n,A,n,&dum1,&dum1,&dumi,&dumi, &abstol,&n_eval,ev, Z,n,isupZ, work,&lwork,iwork,&liwork,&info FCONE FCONE FCONE); FREE(work);FREE(iwork); /* if (*descending) for (i=0;i<*n/2;i++) { x = ev[i]; ev[i] = ev[*n-i-1];ev[*n-i-1] = x; } - now below*/ if (*get_vectors) { /* copy vectors back into A */ p1 = A; if (*descending) { /* need to reverse order */ dum2 = Z + *n * (*n-1); for (work=dum2;work>=Z;work -= *n) for (p=work;p1e-14) { x += fabs(p[i + *n * j]);k++; } Rprintf("**\n"); j=k; if (k) Rprintf("Non orthogonal eigenvectors %d %g\n",k,x/k); x=0.0;k=0; for (i=0;i<*n;i++) if (fabs(p[i + *n * i]-1)>1e-14) { x += fabs(p[i + *n * i]-1);k++; } if (k) Rprintf("Eigenvectors not normalized %d %g\n",k,x/k); if (k+j>0) dump_mat(Acopy,n,n,"/home/sw283/tmp/badmat.dat"); FREE(p);FREE(Acopy); } } /* mgcv_symeig */ void mgcv_trisymeig(double *d,double *g,double *v,int *n,int getvec,int descending) /* Find eigen-values and vectors of n by n symmetric tridiagonal matrix with leading diagonal d and sub/super diagonals g. eigenvalues returned in d, and eigenvectors in columns of v, if getvec!=0. If *descending!=0 then eigenvalues returned in descending order, otherwise ascending. eigen-vector order corresponds. Routine is divide and conquer followed by inverse iteration. dstevd could be used instead, with just a name change. dstevx may be faster, but needs argument changes. */ { char compz; double *work,work1,x,*dum1,*dum2; int ldz=0,info,lwork=-1,liwork=-1,*iwork,iwork1,i,j; if (getvec) { compz='I';ldz = *n;} else { compz='N';ldz=0;} /* workspace query first .... */ F77_CALL(dstedc)(&compz,n, d, g, /* lead and su-diag */ v, /* eigenvectors on exit */ &ldz, /* dimension of v */ &work1, &lwork, &iwork1, &liwork, &info FCONE); lwork=(int)floor(work1);if (work1-lwork>0.5) lwork++; work=(double *)CALLOC((size_t)lwork,sizeof(double)); liwork = iwork1; iwork= (int *)CALLOC((size_t)liwork,sizeof(int)); /* and the actual call... */ F77_CALL(dstedc)(&compz,n, d, g, /* lead and su-diag */ v, /* eigenvectors on exit */ &ldz, /* dimension of v */ work, &lwork, iwork, &liwork, &info FCONE); if (descending) { /* need to reverse eigenvalues/vectors */ for (i=0;i<*n/2;i++) { /* reverse the eigenvalues */ x = d[i]; d[i] = d[*n-i-1];d[*n-i-1] = x; dum1 = v + *n * i;dum2 = v + *n * (*n-i-1); /* pointers to heads of cols to exchange */ for (j=0;j<*n;j++,dum1++,dum2++) { /* work down columns */ x = *dum1;*dum1 = *dum2;*dum2 = x; } } } FREE(work);FREE(iwork); *n=info; /* zero is success */ } /* mgcv_trisymeig */ void Rlanczos(double *A,double *U,double *D,int *n, int *m, int *lm,double *tol,int *nt) { /* Faster version of lanczos_spd for calling from R. A is n by n symmetric matrix. Let k = m + max(0,lm). U is n by k and D is a k-vector. m is the number of upper eigenvalues required and lm the number of lower. If lm<0 then the m largest magnitude eigenvalues (and their eigenvectors) are returned Matrices are stored in R (and LAPACK) format (1 column after another). If nt>1 and there is openMP support then the routine computes the O(n^2) inner products in parallel. ISSUE: 1. Currently all eigenvectors of Tj are found, although only the next unconverged one is really needed. Might be better to be more selective using dstein from LAPACK. 2. Basing whole thing on dstevx might be faster 3. Is random start vector really best? Actually Demmel (1997) suggests using a random vector, to avoid any chance of orthogonality with an eigenvector! 4. Could use selective orthogonalization, but cost of full orth is only 2nj, while n^2 of method is unavoidable, so probably not worth it. */ int biggest=0,f_check,i,k,kk,ok,l,j,vlength=0,ni,pi,converged,incx=1,ri,ci=0,cir,one=1; double **q,*v=NULL,bt,xx,yy,*a,*b,*d,*g,*z,*err,*p0,*p1,*zp,*qp,normTj,eps_stop,max_err,alpha=1.0,beta=0.0; unsigned long jran=1,ia=106,ic=1283,im=6075; /* simple RNG constants */ const char uplo='U',trans='T'; #ifdef OMP_REPORT Rprintf("Rlanczos"); #endif #ifndef OPENMP_ON *nt = 1; /* reset number of threads to 1 if openMP not available */ #endif if (*nt > *n) *nt = *n; /* don't use more threads than columns! */ eps_stop = *tol; if (*lm<0) { biggest=1;*lm=0;} /* get m largest magnitude eigen-values */ f_check = (*m + *lm)/2; /* how often to get eigen_decomp */ if (f_check<10) f_check =10; kk = (int) floor(*n/10); if (kk<1) kk=1; if (kk1 */ if (*nt>1) { ci = *n / *nt; /* cols per thread */ cir = *n - ci * (*nt - 1); /* cols for final thread */ if (cir>ci) { /* final thread has more work than normal thread - redo */ ci++; /* up work per thread by one */ *nt = (int)ceil(*n/ci); /* drop number of threads */ cir = *n - ci * (*nt - 1); /* recompute cols for final thread */ } if (cir == 0) { (*nt)--;cir=ci; } /* no cols left for final thread so drop it */ } //Rprintf("nt = %d, ci = %d, cir = %d\n",*nt,ci,cir); /* The main loop. Will break out on convergence. */ for (j=0;j< *n;j++) { /* form z=Aq[j]=A'q[j], the O(n^2) step ... */ /*blas free version ... for (Ap=A,zp=z,p0=zp+*n;zp1) { /* use parallel computation for the z = A q[j] */ #ifdef OPENMP_ON #pragma omp parallel private(i,ri) num_threads(*nt) #endif { #ifdef OPENMP_ON #pragma omp for #endif for (i=0;i<*nt;i++) { if (i < *nt-1) ri = ci; else ri = cir; /* number of cols of A to process */ /* note that symmetry, A' == A, is exploited here, (rows a:b of A are same as cols a:b of A, but latter are easier to access as a block) */ F77_CALL(dgemv)(&trans,n,&ri,&alpha,A+i * ci * *n,n,q[j], &one,&beta,z+i*ci,&one FCONE); } } /* end parallel */ } else F77_CALL(dsymv)(&uplo,n,&alpha, A,n, q[j],&incx, &beta,z,&incx FCONE); /* Now form a[j] = q[j]'z.... */ for (xx=0.0,qp=q[j],p0=qp+*n,zp=z;qp= *m + *lm)&&(j%f_check==0))||(j == *n-1)) /* no point doing this too early or too often */ { for (i=0;inormTj) normTj=fabs(d[j]); for (k=0;k= *m + *lm) { max_err=normTj*eps_stop; if (biggest) { /* getting m largest magnitude eigen values */ /* only one convergence test is sane here: 1. Find the *m largest magnitude elements of d. (*lm is 0) 2. When all these have converged, we are done. */ pi=ni=0;converged=1; while (pi+ni < *m) if (fabs(d[pi])>= fabs(d[j-ni])) { /* include d[pi] in largest set */ if (err[pi]>max_err) {converged=0;break;} else pi++; } else { /* include d[j-ni] in largest set */ if (err[ni]>max_err) {converged=0;break;} else ni++; } if (converged) { *m = pi; *lm = ni; j++;break; } } else /* number of largest and smallest supplied */ { ok=1; for (i=0;i < *m;i++) if (err[i]>max_err) ok=0; for (i=j;i > j - *lm;i--) if (err[i]>max_err) ok=0; if (ok) { j++;break;} } } } } /* At this stage, complete construction of the eigen vectors etc. */ /* Do final polishing of Ritz vectors and load va and V..... */ /* for (k=0;k < *m;k++) // create any necessary new Ritz vectors { va->V[k]=d[k]; for (i=0;iM[i][k]=0.0; for (l=0;lM[i][k]+=q[l][i]*v[k][l];} }*/ /* assumption that U is zero on entry! */ for (k=0;k < *m;k++) /* create any necessary new Ritz vectors */ { D[k]=d[k]; for (l=0;l #include #include #include #include #include "mgcv.h" #include "general.h" /* kd-tree tasks: 1. Build and return kd tree. 2. Find nearest neighbour of points x in given kd tree. 3. Find k nearest neighbours of points x in given kd tree. 4. Build kd tree, compute k nearest neighbours for all nodes, return these, and optionally tree. 5. Find all points in given tree within r-ball of each point in x. key routines: * kd_tree and free_kdtree for creating and freeing kd trees. * closest - find closest point in kd tree to a new point x. * k_nn_work finds k nearest neighbours of each node in kd tree * k_nn forms kd tree and then obtains k nearest neighbours * kd_sizes, kd_dump, kd_read are concerned with encoding kd tree in form suitable for storage in R and reading from this format. needed: * k_closest - find k nearest neighbours in kd tree to points not in kd tree. * r_ball - find points in kd tree within r-balls around points not in kd tree. */ void kd_sizes(kdtree_type kd,int *ni,int *nd) { /* reports size of integer array and double array (ni and nd) required to hold full kd tree in packed storage for passing back to R */ *nd = 1 + kd.d * kd.n_box * 2; /* to hold huge, lo and hi data for boxes */ *ni = 3 + /* n_box d and n */ 2 * kd.n + /* ind, rind */ 5 * kd.n_box; /* parent,child1,child2,p0,p1*/ } void kd_dump(kdtree_type kd,int *idat,double *ddat) { /* writes a kdtree structure to arrays idat and ddat, initialized to the sizes determined by kd_sizes for kd. The point is that these are suitable for passing to R, say. */ int *p,*p0,*p1,i,nb,d,*pc1,*pc2,*pp,n; double *pd,*pd1; nb = idat[0] = kd.n_box; /* number of boxes */ d = idat[1] = kd.d; /* dimension of boxes/points */ n = idat[2] = kd.n; /* number of points tree relates to */ *ddat = kd.huge;ddat++; /* copy kd.ind... */ for (p=idat+3,p0=kd.ind,p1=p0+n;p0n_box = idat[0]; /* number of boxes */ d = kd->d = idat[1]; /* dimensions of boxes etc. */ n = kd->n = idat[2]; /* number of points tree relates to */ kd->huge = *ddat;ddat++; if (new_mem) { /* allocate new memory and copy in contents */ kd->ind = (int *)CALLOC((size_t)n,sizeof(int)); for (pp=kd->ind,p0=pp+n,p1=idat+3;pprind = (int *)CALLOC((size_t)n,sizeof(int)); for (pp=kd->rind,p0=pp+n;ppind = idat + 3; kd->rind = idat + 3 + n; } /* Now make an array of boxes (all cleared to zero)... */ kd->box = (box_type *)CALLOC((size_t)nb,sizeof(box_type)); /* now work through boxes loading contents */ pp = idat + 3 + 2*n; /* parents */ pc1 = pp + nb; /* child1 */ pc2 = pc1 + nb; /* child2 */ p0 = pc2 + nb; /* p0 */ p1 = p0 + nb; /* p1 */ box = kd->box; for (i=0;ilo = ddat;ddat += d; box->hi = ddat;ddat += d; box->parent = *pp;pp++; box->child1 = *pc1;pc1++; box->child2 = *pc2;pc2++; box->p0 = *p0;p0++; box->p1 = *p1;p1++; } } void kd_sanity(kdtree_type kd) { int ok=1,i,*count,n=0; for (i=0;in) n = kd.box[i].p1; count = (int *)CALLOC((size_t)n,sizeof(int)); for (i=0;i1) { Rprintf("More than 2 points in a box!!\n");ok=0;} count[kd.box[i].p0]++; if (kd.box[i].p1!=kd.box[i].p0) count[kd.box[i].p1]++; } for (i=0;i=x[ind[k]]))==0 */ int l,r,m,ip,ri,li,dum; double xp; l = 0; /* leftmost point of current partition */ r = *n-1; /* rightmost point of current partitions */ while (1) { if (r > l+1) { /* partition large enough to need work still */ m = (l+r) / 2; /* pick a point from partition midpoint (by location not value) (Press et al say to do this to avoid poor behaviour on already sorted x).*/ dum = ind[l+1];ind[l+1] = ind[m];ind[m] = dum; /* swap points m and l+1 */ /* now re-arrange so that x[ind[l]] < x[ind[l+1]] < x[ind[r]]... */ if (x[ind[l]] > x[ind[r]]) { /* swap r and l */ dum = ind[r];ind[r] = ind[l];ind[l] = dum; } if (x[ind[l]] > x[ind[l+1]]) { /* swap l and l+1 */ dum = ind[l];ind[l] = ind[l+1];ind[l+1] = dum; } else if (x[ind[l+1]] > x[ind[r]]) { /* swap l+1 and r */ dum = ind[l+1];ind[l+1] = ind[r];ind[r] = dum; } ip = ind[l+1]; /* index of pivot */ xp = x[ip]; /* pivot value */ /* so pivot is xp = x[ind[l+1]]. start proccess of shuffling array into two partitions containing all the values less than xp, and all those larger than xp... */ ri = r; /* start searching down partition from here for wrongly located values (pos r above pivot already) */ li = l+1; /* start searching up from here (pos l is already below pivot, l+1 is pivot)*/ while (1) { /* BUG: can get stuck in here, when there are tied values, so that li and ri stay unmodified, but ri > li... changing to <= >= allows ri and li to move out of [0,n], which causes segfault!*/ li++;ri--; /* always move by one, or you can get stuck */ while(x[ind[li]] < xp) li++; /* move up until value on wrong side (or equal) found */ while(x[ind[ri]] > xp) ri--; /* move down until value on wrong side (or equal) found */ if (ri < 0) Rprintf("ri<0!!\n"); if (li >= *n) Rprintf("li >= n!!\n"); if (ri= *k ) r = ri - 1; /*else l=li;*/ /* if (ri <= *k + 1) l = li;*/ /* had else l=li; here */ if (ri <= *k ) l = li; } else { /* the partition can only contain 1 or 2 points */ if (r == l+1 && x[ind[r]] < x[ind[l]]) { /* contains two points, but in wrong order */ dum = ind[r];ind[r] = ind[l];ind[l] = dum; /* so swap indices */ } return; /* x[ind[k]] is kth largest value in x */ } } /* end while(1) - main loop */ } void free_kdtree(kdtree_type kd) { /* free a kdtree. Only use for tree created entirely from compiled code, not one read from R. For R only versions FREE(kd.box) is all that is needed, as rest uses memory sent in from R.*/ FREE(kd.ind);FREE(kd.rind); FREE(kd.box[0].lo); /* storage for box coordinates */ FREE(kd.box); } void kd_tree(double *X,int *n, int *d,kdtree_type *kd) { /* Create a kd tree for the points in n by d matrix X. X is in column order. Each row is one point. At end of process... * box[i] contains points indexed by ind[box[i].p0..box[i].p1] * box[i] has one parent and 2 children, unless it contains only one or 2 points, in which case it has no children. */ int *ind,*rind,*p,i,m,todo[50],todo_d[50],item,bi,nb,np,k,dim,b,p0,p1; box_type *box; double huge=1e100,*pd,*x,*dum1,*dum2,*dum3; /* create index for points... */ ind = (int *)CALLOC((size_t) *n,sizeof(int)); for (i=0,p=ind;i < *n;i++,p++) *p = i; /* Find the number of boxes in the tree */ m=2;while (m < *n) m *= 2; nb = *n * 2 - m / 2 - 1; if (nb > m-1) nb = m - 1; /* Now make an array of boxes (all cleared to zero)... */ box = (box_type *)CALLOC((size_t)nb,sizeof(box_type)); /* allocate storage for box defining coordinates... */ pd = (double *)CALLOC((size_t)nb * (2 * *d),sizeof(double)); for (i=0;i= 0) { /* todo list still has items */ b = todo[item]; /* current box */ dim = todo_d[item]; /* dimension on which to split box */ p0 = box[b].p0;p1=box[b].p1; np = p1-p0+1; /* number of points in box k */ x = X + dim * *n; /* array of co-ordinates for current dimension to sort on */ k = (np-1)/2; /* split the box around kth value in box */ /* next line re-orders the point index for this box only. after reordering the index is split into two parts, indexing points below and above the kth largest value */ k_order(&k,ind+p0,x,&np); /*... so the box is now split at a plane/line through x[ind[p0+k-1]] */ item--; /* basically done that item */ /* create the offspring boxes... */ bi++; /* lower box first */ if (bi>nb-1) Rprintf("too many boxes!!"); box[b].child1=bi;/* record box relationships */ /* copy box coordinates... */ for (dum1=box[bi].lo,dum2=dum1 + *d,dum3=box[b].lo;dum11) { /* more than two points , so more work needed */ item++; todo[item] = bi; todo_d[item] = dim+1; if (todo_d[item] == *d) todo_d[item] = 0; } bi++; /* now the higher box */ if (bi>nb-1) Rprintf("too many boxes!!"); box[b].child2=bi;/* record box relationships */ /* copy box coordinates... */ for (dum1=box[bi].lo,dum2=dum1 + *d,dum3=box[b].lo;dum13) { /* more than two points , so more work needed */ item++; todo[item] = bi; todo_d[item] = dim+1; if (todo_d[item] == *d) todo_d[item] = 0; } } if (bi!=nb-1) Rprintf("bi not equal to nb-1 %d %d\n",bi,nb-1); rind = (int *)CALLOC((size_t) *n,sizeof(int)); /* now create index of where ith row of X is in ind */ for (i=0;i<*n;i++) rind[ind[i]]=i; /* now put tree into kd object */ kd->box = box;kd->ind = ind;kd->rind = rind;kd->n_box = nb;kd->huge = huge; kd->d = *d;kd->n = *n; } /* end of kd_tree */ void Rkdtree0(double *X,int *n, int *d,int *idat,double *ddat) { /* Routine to export kdtree data to R m <- 2; while (m h[2*i+1] and h[i] > h[2*i+2] (each applying whenever elements exist). The exception is that h[0], may not obey these conditions. This function re-arranges h so that it does. It also applies the same re-arrangement to ind. Figure 8.3.1 of Press et al (2007) shows what's going on. */ double h0; int i,i0,ind0; h0 = h[0]; /* h0 should be largest element, in properly ordered heap */ ind0 = ind[0]; /* index vector to re-shuffle exactly as h vector */ i0 = 0; /* current position of h0 */ i = 1; /* index for first child node of i0 */ while (i < n) { /* work through to end of heap */ if (i < n-1&&h[i] h[i]) break; /* h0 should be at h[i0] */ /* since h0 <= h[i], move h[i] 'up' heap into h[i0], and move i0, the nominal position for h0 'down' heap to i */ h[i0] = h[i]; ind[i0] = ind[i]; i0 = i; i = 2*i+1; /* now move on to first child of h[i]... */ } h[i0] = h0; /* put h0 into location it should occupy in heap */ ind[i0] = ind0; } double box_dist(box_type *box,double *x,int d) { /* find distance from d dimensional box to point x */ double d2 = 0.0,z,*bl,*bh,*xd; for (xd=x+d,bl=box->lo,bh=box->hi; x < xd;x++,bl++,bh++) { if (*x < *bl) { z = *x - *bl;d2 += z*z;} if (*x > *bh) { z = *x - *bh;d2 += z*z;} } return(sqrt(d2)); } int which_box(kdtree_type *kd,int j) { /* Finds smallest box in kd tree containing jth point from point set used to create tree */ int i,bi,b1; i = kd->rind[j]; /* where jth point is in kd->ind */ bi=0; while (kd->box[bi].child1) { /* still haven't reached smallest */ b1 = kd->box[bi].child1; /* index of first child */ if (kd->box[b1].p1>=i) bi = b1; /* point is in child1 */ else bi = kd->box[bi].child2; /* kd->box[bi].child1 must be in child2 */ } return(bi); /* index of smallest box containing jth point */ } int xbox(kdtree_type *kd,double *x) { /* which box of the kd tree is point x located in? For maximal efficiency use the fact that nested boxes are split along one dimension, and that the split dimensions are cycled through in the same order, while descending the tree. */ int bi,d,b1; box_type *box; bi=0; /* root of the tree - the big box */ box = kd->box; d=0; /* dimension for first split */ while (box[bi].child1) { /* still not reached the outermost twig - smallest box*/ b1 = box[bi].child1; if (box[b1].hi[d]!=box[box[bi].child2].lo[d]) Rprintf("child boundary problem\n"); /* note that points on boundary are in lower box (child1) */ if (x[d] <= box[b1].hi[d]) bi = b1; else bi = box[bi].child2; d++; if (d == kd->d) d=0; } return(bi); } double ijdist(int i, int j, double *X,int n,int d) { /* return Euclidian distance between ith and jth rows of n by d matrix X */ double *pi,*pj,*pil,dist=0.0,x; for (pi=X+i,pil=pi+n*d,pj=X+j;pid is dimension. n is number of rows in X. rows of X are points in tree. if nex>0 then ex is a list of points to exclude. NOTE: may be buggy... */ int bx,ni,i,j,k,d,todo[100],bi,*ind,item,ok=0; double nd,d1,dix; box_type *box; if (nex<0) nex=0; nd = kd->huge; bx = xbox(kd,x); /* box containing x */ /* get closest point within that box */ d = kd->d; box = kd->box; ind = kd->ind; ni = -1; while (ni<0) { /* open larger boxes until one contains a non-excluded neighbour */ for (j=box[bx].p0;j=0) { /* items on the todo list */ if (todo[item]==bx) { /* this is the initializing box - already dealt with */ item--; } else { bi = todo[item]; /* box to deal with now */ item--; if (box_dist(box+bi,x,d)1) { /* there is a second point to consider */ k = kd.ind[kd.box[bi].p1]; if (k==i) check=1; for (j=0;j1 && x1[j]1 && x1[j]>x) x = x1[j]; if (x > lo[j]) hi[j] = x; /* sorted! */ else ok=0; /* not sorted! */ } if (lo[j] != -kd.huge && hi[j] != kd.huge) { x = hi[j]-lo[j]; if (min_w < 0 || x < min_w) min_w = x; } } /* end of first pass through limits */ if (!ok) { /* then there are unfixed limits left to deal with */ for (j=0;j1 && x1[j]0) x -= min_w; else x -= wa[j]; lo[j] = x; /* sorted! */ } if (hi[j] == kd.huge) { /* attempt to shrink boundary to (highest) point */ x = x0[j]; if (np>1 && x1[j]>x) x = x1[j]; if (min_w>0) x += min_w; else x += wa[j]; hi[j] = x; /* sorted! */ } } } /* all limits now reset */ } /* box is now finite */ /* compute box volume */ for (x=1.0,j=0;j= box[c2].lo[dim]) bi = c2; /* r-ball completely in child 2 */ dim++; if (dim==d) dim = 0; if (bi==bi_old) break; /* neither child contained whole r-ball, so use box[bi] */ } /* box[bi] completely encloses the r-ball around x. Now check whether its points lie within r-ball around x... */ item=0; /* index of end of task list */ todo[0] = bi; /* initial task - box bi */ while (item>=0) { bi = todo[item];item--; if (box_dist(box+bi,x,d) < r) { /* box could contain a point in r-ball so check */ if (box[bi].child1) { /* box has children, so add them to todo list */ item++;todo[item] = box[bi].child1; item++;todo[item] = box[bi].child2; } else { /* reached small end of tree - check actual points */ for (i=box[bi].p0;i<=box[bi].p1;i++) { if (xidist(x,X,ind[i],d,n) < r) { list[*nlist] = ind[i]; (*nlist)++; } } } } } } /* k_radius */ SEXP Rkradius(SEXP kdr,SEXP Xr,SEXP xr,SEXP rr,SEXP offr) { /* Xr is matrix of points with attribute with associated kd tree kdr. kdr has and attribute "kd_ptr" which is a handle to a kd tree, or is NULL. If it is NULL then the kd tree structure is created from the stored form in kdr. xr is a matrix of m cols - each col a point. The routine finds all elements of Xr within r of each row of xr. off is an m+1 vector. Returns a vector ni such that ni[off[i]:(off[i+1]-1)] contains the indices (rows) in Xr of the neighbours of the ith row of xr. */ double *X,*x,*r,*xx,*ddat; kdtree_type *kd; int *dim,m,d,*off,*nei,*list,nn,i,j,n_buff=0,nlist,*ni,nprot=1,*idat; SEXP DIM,ptr,neir,IDAT; static SEXP kd_symb = NULL, dim_sym = NULL,kd_symbi=NULL; if (!dim_sym) dim_sym = install("dim"); if (!kd_symbi) kd_symbi = install("kd_ind"); if (!kd_symb) kd_symb = install("kd_ptr"); /* register symbol for attribute */ DIM = getAttrib(xr, dim_sym); dim = INTEGER(DIM); m = dim[1]; X = REAL(Xr);x = REAL(xr); r = REAL(rr); ptr = getAttrib(kdr, kd_symb); kd = (kdtree_type *) R_ExternalPtrAddr(ptr); if (!kd) { /* need to re-create kd tree from kdr */ //Rprintf("Re-installing kd tree. "); IDAT = getAttrib(kdr, kd_symbi); idat = INTEGER(IDAT); ddat = REAL(kdr); kd = (kdtree_type *) CALLOC((size_t)1,sizeof(kdtree_type)); kd_read(kd,idat,ddat,1); ptr = R_MakeExternalPtr(kd,R_NilValue, R_NilValue); PROTECT(ptr); /* Register the routine to call when R object to which ptr belongs is destroyed... */ R_RegisterCFinalizerEx(ptr, kdFinalizer, TRUE); /* attach ptr as attibute to 'kdr' ... */ setAttrib(kdr, kd_symb, ptr); nprot++; } d = kd->d; /* dimension */ off = INTEGER(offr); /* get the r-radius neighbour information... */ list = (int *)CALLOC((size_t)kd->n,sizeof(int)); /* list of neighbours of ith point */ n_buff = kd->n*10; nei = (int *)CALLOC((size_t)n_buff,sizeof(int)); /* global list of neighbours */ xx=x;nn=0;off[0]=0; for (i=0;in_buff) { /* expand nei */ n_buff *= 2; nei = (int *)R_chk_realloc(nei,(size_t)n_buff*sizeof(int)); } for (j=nn;jn_buff) { /* expand nei */ n_buff *= 2; nei = (int *)R_chk_realloc(nei,(size_t)n_buff*sizeof(int)); } for (j=nn;j> k .... */ /*bi = which_box(&kd,i);*/ /* bi is smallest box containing ith point */ bi = xbox(&kd,x); /* bi is smallest box containing ith point, x */ while (box[bi].p1-box[bi].p0 < *k) bi = box[bi].parent; /* note k does not include self */ /* Rprintf("Initial box %d contains %d need %d\n",bi,kd.box[bi].p1-kd.box[bi].p0+1,*k); */ /* now find k nearest points in the box and put in dk... */ for (j=box[bi].p0;j<=box[bi].p1;j++) { pcount++; /*dij = ijdist(i,ind[j],X,*n,*d);*/ /* distance between points i and j */ dij = xidist(x,X,ind[j],*d,*n); if (dij1) update_heap(dk,ik,*k); /* update heap so it still obeys heap ordering */ } } /* finished initialising heap (dk, ik) */ /* Now search the rest of the tree. Basic idea is that if a box is further from the ith point than dk[0] (the largest of the current neighbour distances), then we can ignore all the points it contains (and hence its descendents) */ todo[0] = 0; /* index of root box... first to check */ item=0; bii = bi; /* index of initializing box */ while (item>=0) { /* items on the todo list */ if (todo[item]==bii) { /* this is the initializing box - already dealt with */ item--; } else { bi = todo[item]; /* box to deal with now */ item--; if (box_dist(box+bi,x,*d)1) update_heap(dk,ik,*k); /* update heap so it still obeys heap ordering */ } /* end of point addition */ } /* done the one or two points in this box */ } /* finished with this small box */ } /* finished with possible candiate box */ } /* end of else branch */ } /* todo list end */ /* So now the dk, ik contain the distances and indices of the k nearest neighbours */ for (j=0;j<*k;j++) { /* copy to output matrices */ dist[i + j * *m] = dk[j]; ni[i + j * *m] = ik[j]; } } /* end of points loop (i) */ FREE(dk); FREE(ik); FREE(x); *n = pcount; } /* k_newn_work */ void Rkdnearest0(double *X,int *idat,double *ddat,int *n,double *x, int *m, int *ni, double *dist,int *k) { /* given points in n rows of X and a kd tree stored in idat, ddat in R, find the k neares neighbours to each row of x m by d matrix x. * outputs ni is m by k matrix of neighbour indices dist is m by k matrix of neighbour distances */ kdtree_type kd; int d; kd_read(&kd,idat,ddat,0); /* unpack kd tree */ d = kd.d; /* dimension */ /* get the nearest neighbour information... */ k_newn_work(x,kd,X,dist,ni,m,n,&d,k); FREE(kd.box); /* free storage created by kd_read */ } SEXP Rkdnearest(SEXP kdr,SEXP Xr,SEXP xr,SEXP kr) { /* Takes n by d point matrix Xr, with a corresponding kd tree. kdr has an attribute that points to the tree, or if this is null (e.g. when read from file), the data to re-create it. xr is an m by p point matrix. Finds the k nearest neighbours in Xr to each point in xr returning the matrix of nearest neighbours to each point, with the corresponding distances as an attribute */ double *X,*x,*dis,*ddat; kdtree_type *kd; int *dim,n,m,d,*k,*nei,*idat,nprot=2; SEXP DIM,ptr,neir,dir,IDAT; static SEXP kd_symb = NULL, dim_sym = NULL,dist_sym = NULL,kd_symbi=NULL; if (!dim_sym) dim_sym = install("dim");if (!dist_sym) dist_sym = install("dist"); if (!kd_symb) kd_symb = install("kd_ptr"); /* register symbol for attribute */ if (!kd_symbi) kd_symbi = install("kd_ind"); DIM = getAttrib(Xr, dim_sym); dim = INTEGER(DIM); n = dim[0]; DIM = getAttrib(xr, dim_sym); dim = INTEGER(DIM); m = dim[0]; X = REAL(Xr);x = REAL(xr); k = INTEGER(kr); ptr = getAttrib(kdr, kd_symb); kd = (kdtree_type *) R_ExternalPtrAddr(ptr); if (!kd) { /* need to re-create kd tree from kdr */ //Rprintf("Re-installing kd tree. "); IDAT = getAttrib(kdr, kd_symbi); idat = INTEGER(IDAT); ddat = REAL(kdr); kd = (kdtree_type *) CALLOC((size_t)1,sizeof(kdtree_type)); kd_read(kd,idat,ddat,1); ptr = R_MakeExternalPtr(kd,R_NilValue, R_NilValue); PROTECT(ptr); /* Register the routine to call when R object to which ptr belongs is destroyed... */ R_RegisterCFinalizerEx(ptr, kdFinalizer, TRUE); /* attach ptr as attibute to 'kdr' ... */ setAttrib(kdr, kd_symb, ptr); nprot++; } d = kd->d; /* dimension */ neir = PROTECT(allocMatrix(INTSXP,m,*k)); nei = INTEGER(neir); dir = PROTECT(allocMatrix(REALSXP,m,*k)); dis = REAL(dir); k_newn_work(x,*kd,X,dis,nei,&m,&n,&d,k); setAttrib(neir, dist_sym,dir); UNPROTECT(nprot); return neir; } void k_nn_work(kdtree_type kd,double *X,double *dist,int *ni,int *n,int *d,int *k) { /* Given a kd tree, this routine does the actual work of finding the nearest neighbours. */ int i,j,bi,*ik,bii,todo[100],item,pcount,*ind; box_type *box; double *dk,huge,*p,*p1,*p2,dij,*x; huge = kd.huge; ind = kd.ind; box = kd.box; dk = (double *)CALLOC((size_t)*k,sizeof(double)); /* distance k-array */ ik = (int *)CALLOC((size_t)*k,sizeof(int)); /* corresponding index array */ x = (double *)CALLOC((size_t)*d,sizeof(double)); /* array for current point */ pcount=0; for (i=0;i < *n;i++) { /* work through all the points in X */ for (p=X+i,p1=x,p2=p1 + *d;p1> k .... */ bi = which_box(&kd,i); /* bi is smallest box containing ith point */ /* for (j=0;j<*d;j++) if (x[j]kd.box[bi].hi[j]) { Rprintf("%d ",i); for (j=0;j<*d;j++) Rprintf("%g ",x[j]); for (j=0;j<*d;j++) Rprintf("%g ",kd.box[bi].lo[j]); for (j=0;j<*d;j++) Rprintf("%g ",kd.box[bi].hi[j]); Rprintf("\n"); } Rprintf("%d ",bi);*/ while (box[bi].p1-box[bi].p0 < *k) bi = box[bi].parent; /* note k does not include self */ /* Rprintf("Initial box %d contains %d need %d\n",bi,kd.box[bi].p1-kd.box[bi].p0+1,*k); */ /* now find k nearest points in the box and put in dk... */ for (j=box[bi].p0;j<=box[bi].p1;j++) if (ind[j]!=i) { /* avoid self! */ pcount++; dij = ijdist(i,ind[j],X,*n,*d); /* distance between points i and j */ if (dij1) update_heap(dk,ik,*k); /* update heap so it still obeys heap ordering */ } } /* finished initialising heap (dk, ik) */ /* Now search the rest of the tree. Basic idea is that if a box is further from the ith point than dk[0] (the largest of the current neighbour distances), then we can ignore all the points it contains (and hence its descendents) */ todo[0] = 0; /* index of root box... first to check */ item=0; bii = bi; /* index of initializing box */ while (item>=0) { /* items on the todo list */ if (todo[item]==bii) { /* this is the initializing box - already dealt with */ item--; } else { bi = todo[item]; /* box to deal with now */ item--; if (box_dist(box+bi,x,*d)1) update_heap(dk,ik,*k); /* update heap so it still obeys heap ordering */ } /* end of point addition */ } /* done the one or two points in this box */ } /* finished with this small box */ } /* finished with possible candiate box */ } /* end of else branch */ } /* todo list end */ /* So now the dk, ik contain the distances and indices of the k nearest neighbours */ for (j=0;j<*k;j++) { /* copy to output matrices */ dist[i + j * *n] = dk[j]; ni[i + j * *n] = ik[j]; } } /* end of points loop (i) */ FREE(dk); FREE(ik); FREE(x); *n = pcount; } /* k_nn_work */ void k_nn(double *X,double *dist,double *a,int *ni,int *n,int *d,int *k,int *get_a) { /* NOTE: n modified on exit!! no tie handling... impractical without! X is an n by d matrix. Each row is the location of a point in some Euclidean d-space. Find k nearest neighbours in X of all points in X. ni and dist are both n by k. each row of ni contains the neighbour list. Each row of dist is contains the corresponding distances. if get_a is non zero, then volumes of kd boxes are associated with each point and returned in a. Some R test code... cd ~simon/mgcv-related/sparse-smooth R CMD SHLIB kd-tree.c R dyn.load("kd-tree.so") set.seed(2) n <- 100;d <- 2;k <- 5 X <- matrix(runif(n*d),n,d) dist <- matrix(0,n,k) system.time(oo <- .C("k_nn",X=as.double(X),dist=as.double(dist),a=as.double(1:n),ni=as.integer(dist), n=as.integer(n),d=as.integer(d),k=as.integer(k),get.a=as.integer(1))) oo$n/n^2 ## efficiency dist1 <- dist <- matrix(oo$dist,n,k) ni1 <- ni <- matrix(oo$ni+1,n,k) ## checking code... for (i in 1:n) { Xi <- t(t(X)-X[i,]) di <- rowSums(Xi^2)^.5 oi <- order(di) ni1[i,] <- (1:n)[oi[2:(k+1)]] dist1[i,] <- di[ni1[i,]] oi <- order(dist[i,]) dist[i,] <- dist[i,oi] ni[i,] <- ni[i,oi] } range(ni-ni1) range(dist-dist1) */ kdtree_type kd; kd_tree(X,n,d,&kd); /* set up the tree */ if (*get_a) p_area(a,X,kd,*n,*d); k_nn_work(kd,X,dist,ni,n,d,k); free_kdtree(kd); } void tri2nei(int *t,int *nt,int *n,int *d,int *off) { /* Takes a triangulation of n points in d dimensions, and turns this into a neighbours list. t is nt by d+1 and contains the indices of triangle vertices in its rows, on entry. The indices must run from 0 to n-1. off is an n vector. On exit t[0..off[0]-1] contains the neighbours of point 0, and t[off[i-1] .. off[i]-1] contain the neigbours of point i if i>0. IMPORTANT: t should be initialised to double its actual size (triangulation packed first). */ int i,j,k,l,ii,jj,*p,*p1,*nn,k0,k1; /* count d times the number of triangles each point is part of... */ for (p=off,p1=off + *n;p1. on exit ii[off[i-1]:(off[i]-1)] == i X is n by d, and each row of X contains the location of a point. There are no repeat points in X. D contains the finite difference approximation coefficients. D[i] is the coeff in row ii[i], col ni[i] This routine uses least squares/min norm solutions if there are more/fewer points in neighbourhood than are required for FD approximation. Set up is general to allow for future extension of this routine, but currently only the d==2, m=3, k=6 TPS like case is dealt with here where d is dimension m is number of components in penalty and k is number of polynomial coefficients in polynomial from which derivatives are estimated. */ int i,j,k,true=1,kk,l,i0,i1,max_nn=0,jj,di,doff; double *M,*Mi,*Vt,*sv, /* matrix mapping derivatives to function values */ x,z; /* first strip out distant neighbours */ z = 10.0; ni_dist_filter(X,n,d,ni,off,&z); /* now find the maximum number of neighbours */ i0 = 0; for (j=0;j<*n;j++) { i1 = off[j]; if (i1-i0>max_nn) max_nn = i1-i0; /* maximum number of neighbours */ i0=i1; } max_nn++; /* self! */ if (max_nn<6) max_nn=6; M = (double *)CALLOC((size_t) 6 * max_nn,sizeof(double)); Mi = (double *)CALLOC((size_t) 6 * max_nn,sizeof(double)); Vt = (double *)CALLOC((size_t) 6 * 6,sizeof(double)); sv = (double *)CALLOC((size_t) 6,sizeof(double)); /* Rprintf("Starting main loop...\n");*/ di = i0 = 0; doff = off[*n-1] + *n; /* total number of neighbours + selves */ for (j=0;j<*n;j++) { /* work through all points */ i1 = off[j]; /* neighbours of i are i0..i1-1 */ k = kk = i1-i0 + 1; /* number of neighbours + self */ if (kk<6) { /* will need to pack M with zero rows */ kk=6; for (i=0;i<6*kk;i++) M[i]=0.0; } l=0; /* row index */ /* NOTE: d= 2 hard coded! */ M[0] = 1.0;for (i=1;i<6;i++) M[i*kk] = 0.0; /* self row */ for (i=i0;i Mg as neighbours approach point i. Now pseudo invert M, to estimate g using g = M^{-}f */ /* call mgcv_svd_full to pseudoinvert M */ i = 6; mgcv_svd_full(M,Vt,sv,&kk,&i); /* Rprintf("%d done svd...\n",i);*/ jj = k; if (jj>6) jj=6; kappa[i] = sv[0]/sv[jj-1]; /* condition number */ for (i=0;isv[0]*1e-10) sv[i] = 1/sv[i]; else sv[i]=0.0; /* if k < kk, need to remove trailing rows of M */ if (k=0;i--) { V0c--;V0s--;V1c--;V1s--;U0c--;U0s--;U1c--;U1s--; L13 = - *V1s;L11 = *V1c; L21 = L23 * *V1s;L23 *= *V1c; L31 = L33 * *V1s;L33 *= *V1c; givens(L11,L31,&c,&s);s = -s; /** Rotation to remove upper element BEFORE it propagates **/ L11 = L11*c - L31*s; L12 =- L11 * *V0s; L11 *= *V0c; Lt = L21 * *V0c + L22 * *V0s; L22 = L22 * *V0c - L21 * *V0s; L21=Lt; X1 = -L11 * *U0s; L11 *= *U0c; L12 = L12 * *U1c + X1 * *U1s; X2 = -L21 * *U0s; L21 *= *U0c; L22 = L22 * *U1c + X2 * *U1s; givens(L11,L21,&c,&s); /** Second rotation removing upper element **/ L11 = L11*c+L21*s; Lt = L12*c+L22*s; L22 = L22*c-L12*s;L12=Lt; diagA[i+2]=L33*L33+L23*L23+L13*L13; if (i!=0) { L33=L22;L23=L12;L22=L11; } } diagA[1]=L22*L22+L12*L12; diagA[0]=L11*L11; for (i=0;i<*n;i++) diagA[i] = 1.0 - diagA[i]; FREE(ub); } void sspl_apply(double *y,double *x,double *w,double *U,double *V,int *n,int *nf,double *tol) { /* Apply the smoothing spline stored in U and V to the data in y, with weights w. The smoothed values are returned in y. x and w are also modified here. nf is length of y and x. n is the number of unique x values. */ int i,k,ok; double *Wy,*U0s,*U0c,*U1s,*U1c, *V0s,*V0c,*V1s,*V1c,*p,*p1,*p2,w2,*xx; if (*nf > *n) { /* deal with duplicates */ xx = (double *)CALLOC((size_t)*nf,sizeof(double)); for (p=x,p1=x + *nf,p2=xx;p=0;i--) { QTz(i,i+2,V1c[i],V1s[i],Wy); QTz(i,i+1,V0c[i],V0s[i],Wy); QTz(i,*n+i,U0c[i],U0s[i],Wy); if (i != *n-3) QTz(i+1,*n+i,U1c[i],U1s[i],Wy); } /* get fitted values... */ for (i=0;i<*n;i++) Wy[i] = y[i] - Wy[i]*w[i]; if (*nf > *n) { /* deal with duplicates */ k=0;ok=1; y[0] = Wy[0]; for (i=1;i<*nf;i++) if (x[k] + *tol < x[i]) { /* distinct */ k++;x[k] = x[i]; y[i] = Wy[k]; } else { /* a duplicate */ y[i] = Wy[k]; } } else { for (i=0;i<*n;i++) y[i] = Wy[i]; } FREE(Wy); } void sspl_mapply(double *y,double *x,double *w,double *U,double *V,int *n,int *nf,double *tol,int *m) { /* apply smoothing spline to the m columns of y */ int i,xw_store=0; double *xx,*ww,*p,*p1,*p2; if (*m > 1 && *nf != *n) xw_store=1; if (xw_store) { /* must store original x and w */ xx = (double *)CALLOC((size_t)*nf,sizeof(double)); ww = (double *)CALLOC((size_t)*nf,sizeof(double)); for (p=xx,p1=xx + *nf,p2=x;p=0;i--) c[i+1]=(z[i]-lb1[i]*c[i+2])/lb[i]; b[*n-1]=d[*n-1]=0; for (i=0;i<*n-1;i++) { d[i]=(c[i+1]-c[i])/(3*h[i]); b[i]=(a[i+1]-a[i])/h[i]-c[i]*h[i]-d[i]*h[i]*h[i]; } FREE(GTA);FREE(z);FREE(h); } mgcv/src/soap.c0000755000176200001440000003252413073161526013120 0ustar liggesusers/* Code for soap film smoothing. Copyright Simon Wood 2006-2012. R CMD SHLIB soap.c creates appropriate soap.so from this, can then be loaded by dyn.load("soap.so") and called with .C() */ #include #include #include #include #include "mgcv.h" /****************************************************************************************************/ /* Boundary handling utilities from here on.... */ /****************************************************************************************************/ void boundary(int *G, double *d, double *dto, double *x0, double *y0, double *dx, double *dy, int *nx, int *ny, double *x, double *y,double *break_code, int *n, int *nb) /* Function to create solution grid definition matrix G (nx by ny). Lower left cell centre is at x0, y0. cells are dx by dy. On entry matrices d and dto are same dimension as G. The boundary is supplied in n-arrays, `x' and `y'. Sub loops are separated by elements <= break_code. nb must have dimension of number of loops. On exit: G[i,j] < - nx * ny is outside boundary, otherwise G[i,j] <= 0 is on boundary, and -G[i,j] indexes cell in d and g. G[i,j] > 0 indexes cell in g. On exit d contains the distances along the boundary, stored sequentially from element 0 (i.e. d is a 1D array). nb contains the length of each boundary loop in d (i.e. its cell count). 'g' refers to the solution grid itself, which will contain only interior and boundary points. The boundary in x,y must be *strictly* within the outer grid cells. `G' is stored column-wise (R default). `dto' is a working matrix containing distances from the boundary to the cell centre. This is needed for judging which of multiple boundary segments should supply the boundary value (the closest). The term `vertical' means parallel to y axis. The basic principle is that the boundaries between grid cells are given by a set of evenly spaced horizontal and vertical lines. It is easy to work out which lines are crossed by a boundary line segment, and where this crossing occurs. Cells whose cell boundaries are cut are treated as boundary cells. */ { int segi,j,j0,j1,k,kk,i,reversed,*inb,*ip,*ip1,*ip2,bnd_count,ii,out_lim; double x1,y1,x2,y2,xb0,yb0,xl,yl,xc,yc,dist,dist_to,grad=0.0,b,len2,*p1,*p2; /* first step is to mark outside points in grid */ p1 = d;p2 = dto; for (x1 = *x0,i=0;i<*nx;i++,x1 += *dx) { for (y1 = *y0,j=0;j<*ny;j++,y1 += *dy,p1++,p2++) { *p1 = x1;*p2 = y1; /* cell centres */ } } k = *nx * *ny; /* total size of G, d, dto */ out_lim = -k; inb = (int *)CALLOC((size_t)k,sizeof(int)); in_out(x,y,break_code,d,dto,inb,n,&k); /* test all cell centres for in/out */ j = -(k + 10); for (ip = inb,ip1 = G,p2 = dto,ip2=G+k;ip10) grad = (y2-y1)/(x2-x1); else j1=j0-1; for (j=j0;j<=j1;j++) { /* loop through intersected lines */ xl = xb0 + j * *dx; /* line location */ yl = y1 + (xl - x1)*grad; /* y intersection location */ k = (int) floor(( yl - yb0)/ *dy); /* so nodes j,k and (j-1),k are boundary nodes */ kk = (j-1) * *ny + k; if (G[kk]>0||G[kk]< out_lim) { /* otherwise already a boundary cell */ G[kk] = -ii; ii++; nb[bnd_count]++; } kk += *ny; /* j * *ny + k */ if (G[kk]>0||G[kk]< out_lim) { /* otherwise already a boundary cell */ G[kk] = -ii; ii++; nb[bnd_count]++; } /* Now get the distance along/to the boundary */ for (i=0;i<2;i++) { /* loop over the two cells concerned */ xl = x2-x1;yl=y2-y1; xc = (j-i) * *dx + *x0; yc = k * *dy + *y0; xc -= x1;yc -= y1; /* cell centre done */ len2 = yl*yl + xl*xl; b = (xc*xl + yc*yl)/len2; xl = xl*b+x1;yl = yl * b + y1; /* location of projection from node to line */ if (xl < x1) {xl = x1;yl = y1;} if (xl > x2) {xl = x2;yl = y2;} /* constrained to *within* segment */ dist_to = sqrt((xl-xc)*(xl-xc) + (yl-yc)*(yl-yc)); kk = (j-i) * *ny + k; if (dist_to < dto[kk] || dto[kk]<0) { dto[kk] = dist_to; xl -= x1; yl -= y1; if (reversed) d[-G[kk]] = dist + sqrt(len2) - sqrt(xl*xl + yl*yl); else d[-G[kk]] = dist + sqrt(xl*xl + yl*yl); /* distance along boundary */ } } } /* end of vertical line processing */ /* Now deal with horizontal lines */ if (y[segi-1]0) grad = (x2-x1)/(y2-y1); else j1=j0-1; for (j=j0;j<=j1;j++) { /* loop through intersected lines */ yl = yb0 + j * *dy; /* line location */ xl = x1 + (yl - y1)*grad; /* y intersection location */ k = (int) floor(( xl - xb0)/ *dx); /* so nodes k,j and k, (j-1) are boundary nodes */ kk = k * *ny + j - 1; if (G[kk]>0||G[kk]< out_lim) {G[kk] = -ii;ii++;nb[bnd_count]++;} /* otherwise already a boundary cell */ kk ++; /* k * *ny + j */ if (G[kk]>0||G[kk]< out_lim) {G[kk] = -ii;ii++;nb[bnd_count]++;} /* otherwise already a boundary cell */ /* Now get the distance along/to the boundary */ for (i=0;i<2;i++) { /* loop over the two cells concerned */ xl = x2-x1;yl=y2-y1; yc = (j-i) * *dy + *y0; xc = k * *dx + *x0; xc -= x1;yc -= y1; /* cell centre done */ len2 = yl*yl + xl*xl; b = (xc*xl + yc*yl)/len2; xl = xl*b+x1;yl = yl * b + y1; /* location of projection from node to line */ if (yl < y1) {xl = x1;yl = y1;} if (yl > y2) {xl = x2;yl = y2;} /* constrained to *within* segment */ dist_to = sqrt((xl-xc)*(xl-xc) + (yl-yc)*(yl-yc)); kk = k * *ny + j-i; if (dist_to < dto[kk] || dto[kk]<0) { dto[kk] = dist_to; xl -= x1; yl -= y1; if (reversed) d[-G[kk]] = dist + sqrt(len2) - sqrt(xl*xl + yl*yl); else d[-G[kk]] = dist + sqrt(xl*xl + yl*yl); /* distance along boundary */ } } } /* end of horizontal line processing */ /* update `dist' */ x2 = x2-x1;y2=y2-y1; dist += sqrt(x2*x2+y2*y2); /* now look ahead to see if we are at the end of a sub-loop */ if (segi < *n - 1 && x[segi+1] <= *break_code) { /* reached segment end */ dist = 0.0; /* reset for new loop */ segi++;segi++; /* move past the break */ bnd_count++; /* loop counter */ if (segi < *n) nb[bnd_count] = 0; /* set cell counter for this loop */ } } /* end of line segment loop */ /* Clear the remainder of d to -ve */ k = *nx * *ny;for (i=ii;i 0) {*ip1 = ii;ii++;} } /* end of boundary */ void pde_coeffs(int *G,double *x,int *ii,int *jj,int *n,int *nx,int *ny,double *dx,double *dy) { /* Takes nx by ny grid G produced by function boundary, and produces corresponding PDE coefficient matrix, for soap PDEs in sparse triplet form. On entry x, ii and jj should be of length 5 times the number of cells within the boundary. On exit n will contain their exact required length. */ int i,j,*ip,outside,Gk0,Gk1,k0,k1; double xc,dx2,dy2,thresh=0.0; thresh = dx2= 1.0/(*dx * *dx);dy2 = 1.0/(*dy * *dy); if (dy2 < thresh) thresh = dy2; thresh *= .5; outside = - *nx * *ny - 1; *n=0; for (ip=G,i=0;i<*nx;i++) for (j=0;j<*ny;j++,ip++) if (*ip > outside){ if (*ip <= 0) { /* boundary cell */ *x=1.0;*jj = *ii= - *ip; x++;ii++;jj++;*n += 1; } else { /* interior */ xc=0.0; /* diagonal coefficient */ if (i>0&&i< *nx-1) { /* FD w.r.t. x may be possible */ k0 = (i-1) * *ny + j; /* backwards diff */ k1 = k0 + 2 * *ny; /* forwards diff */ Gk0 = G[k0];Gk1 = G[k1]; if (Gk0 > outside && Gk1 > outside) { /* difference is possible */ xc += 2*dx2; if (Gk0<0) Gk0 = -Gk0; *x = -dx2;*ii = *ip;*jj = Gk0; x++;ii++;jj++;*n += 1; if (Gk1<0) Gk1 = -Gk1; *x = -dx2;*ii = *ip;*jj = Gk1; x++;ii++;jj++;*n += 1; } } /* FD in x direction finished */ if (j>0&&j< *ny-1) { /* FD w.r.t. x may be possible */ k0 = i * *ny + j - 1; /* backwards diff */ k1 = k0 + 2; /* forwards diff */ Gk0 = G[k0];Gk1 = G[k1]; if (Gk0 > outside && Gk1 > outside) { /* difference is possible */ xc += 2*dy2; if (Gk0<0) Gk0 = -Gk0; *x = -dy2;*ii = *ip;*jj = Gk0; x++;ii++;jj++;*n += 1; if (Gk1<0) Gk1 = -Gk1; *x = -dy2;*ii = *ip;*jj = Gk1; x++;ii++;jj++;*n += 1; } if (xc > thresh) { /* there is a difference for this cell */ *x = xc;*ii = *jj = *ip; x++;ii++;jj++;*n += 1; } } } /* interior branch end*/ } /* main loop end */ } /* end of pde_coeffs */ void gridder(double *z,double *x,double *y,int *n,double *g, int *G,int *nx, int *ny,double *x0, double *y0,double *dx,double *dy,double NA_code) { /* Takes solution g indexed by ny by nx matrix G. lower left cell of G is centred at x0, y0 and cell sizes are dx by dy. Interpolates solution to n locations in x, y, returning NA code for out of area. Does not do strict boundary testing here, since this routine is often called several times with same geometry. */ int i,ix,iy,ok,Gthresh,Gk,k,ok00,ok01,ok10,ok11; double xx,yy,xx0,yy0,dmax,xa,ya,g00=0.0,g01=0.0,g10=0.0,g11=0.0,b0,b1,b2,b3,dist,d1; dmax = (*dx * *dx + *dy * *dy)*2; xx0 = *x0;yy0 = *y0; Gthresh = - *nx * *ny; /* G below with implies out of area */ for (i=0;i < *n;i++) { /* loop through x,y locations */ xx = x[i];yy = y[i]; ix = (int) floor((xx - xx0) / *dx); iy = (int) floor((yy - yy0) / *dy); k = ix * *ny + iy; ok = 0; /* node 00... */ if (ix<0||ix>=*nx||iy<0||iy>=*ny) ok00 = 0; else { Gk=G[k]; if (Gk < Gthresh) ok00 = 0; else { ok00 = 1; ok++; if (Gk < 0) Gk = -Gk; g00 = g[Gk]; } } /* end of node 00 */ iy++;k++; /* node 01 */ if (ix<0||ix>=*nx||iy<0||iy>=*ny) ok01 = 0; else { Gk=G[k]; if (Gk < Gthresh) ok01 = 0; else { ok01 = 1; ok++; if (Gk < 0) Gk = -Gk; g01 = g[Gk]; } } /* end of node 01 */ ix++; k += *ny; /* node 11 */ if (ix<0||ix>=*nx||iy<0||iy>=*ny) ok11 = 0; else { Gk=G[k]; if (Gk < Gthresh) ok11 = 0; else { ok11 = 1; ok++; if (Gk < 0) Gk = -Gk; g11 = g[Gk]; } } /* end of node 11 */ iy--;k--; /* node 10 */ if (ix<0||ix>=*nx||iy<0||iy>=*ny) ok10 = 0; else { Gk=G[k]; if (Gk < Gthresh) ok10 = 0; else { ok10 = 1; ok++; if (Gk < 0) Gk = -Gk; g10 = g[Gk]; } } /* end of node 10 */ ix--; if (ok==4) { /* all nodes are ok, full bilinear */ b0 = g00; b1 = (g10-g00) / *dx; b2 = (g01-g00) / *dy; b3 = (g11-g10-g01+g00)/( *dx * *dy); xx = xx - xx0 - ix * *dx; yy = yy - yy0 - iy * *dy; /* evaluate interpolating polynomial */ z[i] = b0 + b1 * xx + b2 * yy + b3 * xx * yy; } else if (!ok) { /* no good neighbours - NA */ z[i] = NA_code; } else { /* resort to nearest neighbour */ xa = xx - xx0 - ix * *dx; ya = yy - yy0 - iy * *dy; dist = dmax; if (ok00) { dist = xa*xa + ya*ya; z[i] = g00; } if (ok01) { ya = *dy - ya; d1 = xa*xa + ya*ya; if (d1 < dist) { dist=d1; z[i] = g01; } } if (ok11) { xa = *dx - xa; d1 = xa*xa + ya*ya; if (d1 < dist) { dist=d1; z[i] = g11; } } if (ok10) { ya = *dy - ya; d1 = xa*xa + ya*ya; if (d1 < dist) { z[i] = g10; } } } /* end of nearest neighbour */ } } /* end of gridder */ mgcv/src/Makevars0000755000176200001440000000044313501256073013477 0ustar liggesusersPKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) $(SHLIB_OPENMP_CFLAGS) PKG_CFLAGS = $(SHLIB_OPENMP_CFLAGS) ## *Both* the above must be *uncommented* for release #PKG_CFLAGS = -Wall -pedantic $(SHLIB_OPENMP_CFLAGS) ## `#' out previous line for release (but not without uncommenting openMP) mgcv/src/tprs.c0000755000176200001440000006223413534130577013153 0ustar liggesusers/* Copyright (C) 2000-2012 Simon N. Wood simon.wood@r-project.org This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. (www.gnu.org/copyleft/gpl.html) You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.*/ #include #include #include #include "mgcv.h" #include "matrix.h" #include "general.h" #include "tprs.h" /* Code for thin plate regression splines */ #define ROUND(a) ((a)-(int)floor(a)>0.5) ? ((int)floor(a)+1):((int)floor(a)) double eta_const(int m,int d) { /* compute the irrelevant constant for TPS basis */ double pi=PI,Ghalf; double f; int i,k,d2,m2; Ghalf = sqrt(pi); /* Gamma function of 0.5 = sqrt(pi) */ d2 = d/2;m2 = 2*m; if (m2 <= d) error(_("You must have 2m>d for a thin plate spline.")); if (d%2==0) /* then d even */ { if ((m+1+d2)%2) f= -1.0; else f=1.0; /* finding (-1)^{m+1+d/2} */ for (i=0;ir,X->r); EM = E->M; eta0 = eta_const(m,d); XMi = X->M;Xr = X->r;Xc = X->c; for (i=0;iM,j=0;jM[i][k]-X->M[j][k];*/ x = *xi - *xj; r+=x*x; } /*r=sqrt(r);*/ /* r= ||x_j-x_i||^2 where x_k is kth location vector */ EM[i][j]=EM[j][i]=fast_eta(m,d,r,eta0); } } void gen_tps_poly_powers(int *pi /* **pi */,int *M,int *m, int *d) /* generates the sequence of powers required to specify the M polynomials spanning the null space of the penalty of a d-dimensional tps with wiggliness penalty order m So, if x_i are the co-ordinates the kth polynomial is x_1^pi[k][1]*x_2^pi[k][2] .... pi[k][j] actually stored as pi[k + M * j] */ { int *index,i,j,sum; index=(int *)CALLOC((size_t) *d,sizeof(int)); for (i=0;i < *M;i++) { /* copy index to pi */ /* for (j=0;jr,M); for (i=0;ir;i++) for (j=0;jM[i][k]; */ for (k=0;kM[i][k]; T->M[i][j]=x; } /*for (i=0;id+1 */ { int M,i; if (2*m<=d) {m=1;while (2*m0) { m=0;while (2*m0&&sm>0) { /*for (i=0;i0) /* get a new basis for the null space of the penalty */ { M=1; /* dimension of penalty null space */ for (i=0;iM;n = X->r; for (pb=b,i=0;ir) g += *pb *p->V[i]; } off=1-constant; for (i=off;iV[i+X->r-off]=r;*/ if (p->r) g+=p->V[i+n-off]*r; } return(g); } int Xd_row_comp(double *a,double *b,int k) /* service routine for Xd_strip(), compares k elements of two rows for equality */ { int i; for (i=0;ir-1. These are vital for constructing the index. On exit Xd->r will contain the number of unique covariate points. */ { int *yxindex,start,stop,ok,i; double xi,**dum; yxindex = (int *)CALLOC((size_t)Xd->r,sizeof(int)); dum = (double **)CALLOC((size_t)Xd->r,sizeof(double *)); msort(*Xd); start=stop=0;ok=1; while(ok) { /* look for start of run of equal rows ..... */ while(startr-1&&!Xd_row_comp(Xd->M[start],Xd->M[start+1],Xd->c-1)) { /* Xd->M[start] not tied with anything, nothing to erase.... */ xi=Xd->M[start][Xd->c-1]; yxindex[ROUND(xi)]=start; start++; } if (start==Xd->r-1) { ok=0; /* reached end with no more ties */ xi=Xd->M[start][Xd->c-1]; yxindex[ROUND(xi)]=start; /* final index entry needed */ } if (ok) /* search for end of run */ { stop=start+1; while(stopr-1&&Xd_row_comp(Xd->M[stop],Xd->M[stop+1],Xd->c-1)) stop++; for (i=start;i<=stop;i++) /* fill out the index array */ { xi=Xd->M[i][Xd->c-1]; yxindex[ROUND(xi)]=start; dum[i-start]=Xd->M[i]; /* Rows stored to copy back onto end, so matrix can be freed properly */ } for (i=stop+1;ir;i++) { Xd->M[i-stop+start]=Xd->M[i];} Xd->r -= stop-start; for (i=1;i<=stop-start;i++) { Xd->M[Xd->r-1+i]=dum[i];} } } FREE(dum); return(yxindex); } void tprs_setup(double **x,double **knt,int m,int d,int n,int k,int constant,matrix *X,matrix *S, matrix *UZ,matrix *Xu,int n_knots) /* Takes d covariates x_1,..,x_d and creates the truncated basis for an order m smoothing spline, returning the design matrix and wiggliness penalty matrix for this spline, along with the matrix transforming back to the regular basis. The dimension of the truncated basis must be greater than the dimension of the null space of the penalty. The inputs are: x[i] = array of n values for covariate i (i=0..d-1) m = the order of the penalty (order of derivatives in penalty) if 2m>d is not satisfied (e.g. if m==0) then m is set to smallest value such that 2m>d+1 (ensures visual smoothness) d = the dimension of the spline = number of covariates. n = number of data. k = dimension of truncated basis. This must be greater than the dimension of the null space of the penalty, which is M=(m+d-1)!/[d!(m-1)!] constant = 0 if there is to be no intercept term in the model, 1 otherwise knt[i] array of n_knot knot location values for covariate i n_knot number of knots supplied - 0 for none meaning that the values in x are the knots. n_knots XW UZ -> UZW S -> WSW Provided the user uses UZ to transform back to the t.p.s parameters the rescaling is transparent. */ { matrix X1,E,U,v,TU,T,Z,p; const char trans='T'; int l,i,j,M,*yxindex,pure_knot=0,nk,minus=-1,kk,one=1; double w,*xc,*XMi,*Ea,*Ua,tol=DOUBLE_EPS,*b,*a,*uz,alpha=1.0,beta=0.0,*p0,*p1; tol = pow(tol,.7); if (n_knotsM[i][j]=x[j][i];Xu->M[i][d]=(double)i;} } else /* knot locations supplied */ { *Xu=initmat(n_knots,d+1); for (i=0;iM[i][j]=knt[j][i];Xu->M[i][d]=(double)i;} } /* Now the number of unique covariate "points" must be obtained */ /* and these points stored in Xu, to avoid problems with E */ yxindex=Xd_strip(Xu); /*yxindex[i] is the row of Xu corresponding to y[i] */ Xu->c--; /* hide indexing column */ if (Xu->rrr==k) pure_knot=1; /* basis dimension is number of knots - don't need eigen step */ if (pure_knot) /* don't need the lanczos step, but need to "fake" various matrices to make up for it! */ { *UZ=initmat(T.r+M-1+constant,T.r); UZ->r=T.r; TU=initmat(T.c,T.r); for (i=0;ir=U.r; mcopy(&U,UZ); HQmult(*UZ,Z,0,0);UZ->c -= M; /* Now UZ multiplied by truncated delta gives full delta */ UZ->c += M-1+constant; /* adding cols for un-constrained terms to UZ */ } UZ->r +=M-1+constant; /* Now add the elements required to get UZ to map from whole real parameter vector to whole t.p.s. vector */ for (i=0;ic;j++) UZ->M[i][j]=0.0; for (i=0;iM[UZ->r-i-1][UZ->c-i-1]=1.0; /* Now construct the design matrix X = [Udiag(v)Z,T] .... */ if (n_knotsM[i][j]=X1.M[l][j]; } freemat(X1); } else /* the user supplied a set of knots to generate the original un-truncated basis */ { p.r=0; /* don't want a value from tps_g() */ xc=(double *)CALLOC((size_t)d,sizeof(double)); kk = (int) UZ->r; b=(double *)CALLOC((size_t)kk,sizeof(double)); /* initmat((long)UZ->r,1L);*/ *X=initmat(n,k); a = (double *)CALLOC((size_t)k,sizeof(double)); /* following loop can dominate computational cost, so it is worth using BLAS routines and paying some attention to efficiency */ uz = (double *) CALLOC((size_t)(kk*k),sizeof(double)); RArrayFromMatrix(uz,kk,UZ); for (i=0;iM[i]; for (p0=a,p1=a+k;p0M[i]; UZM=UZ->M; for (j=0;jM[i][i]=v.V[i]; HQmult(*S,Z,0,0);HQmult(*S,Z,1,1); for (i=0;ir;i++) for (j=S->r-M;jr;j++) S->M[i][j]=S->M[j][i]=0.0; if (!constant) {S->r--;S->c--;} /* Now linearly transform everything so that numerical properties of X are as nice as possible. Specifically, rescale each column of X so that it has rms value 1. X -> XW. This means that S -> WSW and UZ -> UZW. */ for (i=0;ic;i++) { w=0; for (j=0;jr;j++) w+=X->M[j][i]*X->M[j][i]; w=sqrt(w/X->r); for (j=0;jr;j++) X->M[j][i]/=w; for (j=0;jr;j++) UZ->M[j][i]/=w; for (j=0;jr;j++) S->M[i][j]/=w; for (j=0;jr;j++) S->M[j][i]/=w; } FREE(yxindex);freemat(Z);freemat(TU);freemat(E);freemat(T); if (!pure_knot) {freemat(U);freemat(v);} } void construct_tprs(double *x,int *d,int *n,double *knt,int *nk,int *m,int *k,double *X,double *S, double *UZ,double *Xu,int *nXu,double *C) /* inputs: x contains the n values of each of the d covariates, stored end to end knt contains the nk knot locations packed as x m is the order of the penalty k is the basis dimension max_knots is the maximum number of knots to allow in t.p.r.s. setup. outputs: X is the n by k model matrix S is the K by K penalty matrix UZ is the (nXu+M) by k matrix transforming from the truncated to full bases Xu is the nXu by d matrix of unique covariate combinations C is the 1 by k sum to zero constraint matrix */ { double **xx,**kk=NULL,*dum,**XM; matrix Xm,Sm,UZm,Xum; int i,j,Xr; xx=(double **)CALLOC((size_t)(*d),sizeof(double*)); for (i=0;i<*d;i++) xx[i]=x + i * *n; if (*nk) { kk=(double **)CALLOC((size_t)(*d),sizeof(double*)); for (i=0;i<*d;i++) kk[i]=knt + i * *nk; } tprs_setup(xx,kk,*m,*d,*n,*k,1,&Xm,&Sm,&UZm,&Xum,*nk); /* Do actual setup */ RArrayFromMatrix(X,Xm.r,&Xm); RArrayFromMatrix(S,Sm.r,&Sm); RArrayFromMatrix(UZ,UZm.r,&UZm); RArrayFromMatrix(Xu,Xum.r,&Xum); *nXu=Xum.r; /* construct the sum to zero constraint */ dum=C;XM=Xm.M;Xr=Xm.r; for (i=0;i< *k;i++) { *dum = 0.0; for (j=0;j 0) { *m = 0;while ( 2 * *m < *d+2) (*m)++;} /* get null space polynomial powers */ pin=(int *)CALLOC((size_t) (*M * *d),sizeof(int)); gen_tps_poly_powers(pin, M, m, d); eta0 = eta_const(*m,*d); /*Xum=Rmatrix(Xu,*nXu,*d);*/ nobsM = *nXu + *M; /* UZm=Rmatrix(UZ,nobsM,*k);*/ b=(double *)CALLOC((size_t)nobsM,sizeof(double)); /* initmat(UZm.r,1L);*/ a=(double *)CALLOC((size_t)*k,sizeof(double)); /* Xm=initmat((long)*n,(long)*k);*/ xx=(double*)CALLOC((size_t) *d,sizeof(double)); for (Xp=X,xp=x,i=0;i< *n;i++,xp++,Xp++) { if (*by_exists) by_mult=by[i]; else by_mult=1.0; if (by_mult==0.0) { /* then don't waste flops on calculating stuff that will only be zeroed */ /*for (j=0;j< *k ;j++) Xm.M[i][j]=0.0;*/ for (xxp=Xp,j=0;j < *k;j++,xxp+= *n) *xxp = 0.0; } else { /* proceed as normal */ for (xxp=xx,xxp1=xx + *d,xp1=xp;xxp < xxp1;xxp++,xp1 += *n) *xxp = *xp1; /*xx[j]=x[j * *n + i];*/ /* evaluate radial basis */ for (Xup=Xu,Xup1=Xu+*nXu,pb=b;Xupd not satisfied. 11/2/2002 - tprs_setup now retains the largest magnitude eigen-vectors irrespective of sign this was not correctly handled previously: -ve's were always kept, due to an error in the original tprs optimality derivation. 2-3/2002 - tprs_setup modified to allow knot based tprs bases - pure knot based or knot and then eigen are both allowed. 6/5/2002 - bug fix: full spline bases failed - part of tprs_setup treated them as knot based and part as eigen-based - resulted in seg fault. 3/10/2002 - tps_g() has a fix so that if told to clear up before having anything to clear up, it doesn't write all sorts of things to un-allocated memory. Many thanks to Luke Tierney for finding this. 3/10/2002 - tprs_setup now tells tps_g() to clear up before returning 1/11/2005 - eta() constants `wrong' for odd d: fixed. */ mgcv/src/matrix.c0000755000176200001440000005516713303547337013476 0ustar liggesusers/* Copyright (C) 1991-2005 Simon N. Wood simon.wood@r-project.org 14/9/17 --- cleaned out routines no longer needed This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. (www.gnu.org/copyleft/gpl.html) You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.*/ /* Routines for basic matrix manipulation creation, destruction and file i/o for matrices. See end of file for update log */ #include #include #include #include #include #include #include "mgcv.h" #include "matrix.h" #include "general.h" #define RANGECHECK #define PAD 1 #define ROUND(a) ((a)-(int)floor(a)>0.5) ? ((int)floor(a)+1):((int)floor(a)) matrix null_mat; /* matrix for passing when you don't actually need to */ #define PADCON (-1.234565433647588392902028934e270) /* counter for memory used */ long memused=0L,matrallocd=0L; /* the routines */ struct mrec { matrix mat; struct mrec *fp,*bp; }; typedef struct mrec MREC; matrix null_mat; MREC *top,*bottom; matrix initmat(int rows,int cols) /* Don't alter this without altering freemat() as well !! */ { matrix A;int i,j,pad; #ifdef RANGECHECK pad=PAD; #else pad=0; #endif A.vec=0; A.M=(double **)CALLOC((size_t)(rows+2*pad),sizeof(double *)); if ((cols==1)||(rows==1)) { if (A.M) A.M[0]=(double *)CALLOC((size_t)(cols*rows+2*pad),sizeof(double)); for (i=1;i0)) { error(_("Failed to initialize memory for matrix."));} if (pad) /* This lot is debugging code that checks out matrix errors on allocation and release */ { if (A.vec) { A.V=A.M[0];for (i=0;imat=top->mat=A;top->bp=bottom;bottom->fp=top; } else /* expanding the linked list by one */ { top->fp=(MREC *)CALLOC(1,sizeof(MREC)); top->fp->mat=A;top->fp->bp=top;top=top->fp; /* crystal clear, no? */ } } A.V=A.M[0];/* This allows vectors to be accessed using A.V[i] */ return(A); } /* initmat */ matrix initvec(int rows) { return(initmat(1,rows));} void freemat(matrix A) { int i,j,pad;int ok=1; MREC *delet; #ifdef RANGECHECK pad=PAD; #else pad=0; #endif /* if (A.original_r*A.original_c!=0L) */ { if (pad) { if (A.vec) { for (i=-pad;i<0;i++) if ((A.V[i]!=PADCON)||(A.V[i+A.original_r*A.original_c+pad]!=PADCON)) ok=0; } else { for (i=-pad;imat.M!=A.M)) { i++;delet=delet->fp;} if (i==matrallocd) { error(_("INTEGRITY PROBLEM in the extant matrix list.")); } else { if (i) delet->bp->fp=delet->fp; else bottom=delet->fp; if (i!=matrallocd-1) delet->fp->bp=delet->bp; else top=delet->bp; FREE(delet); } /* repositioning pointers so that what was allocated gets freed */ if (!A.vec) for (i=0;imat; if (A.vec) { for (i=-pad;i<0;i++) if ((A.V[i]!=PADCON)||(A.V[i+A.original_r*A.original_c+pad]!=PADCON)) ok=0; } else { for (i=-pad;ifp; } } /* matrixintegritycheck */ void vmult(matrix *A,matrix *b,matrix *c,int t) /* fast multiplication of vector by matrix c=Ab if t==0 c=A'b otherwise*/ { double **AM,*bV,*cV,*p; int i,j,cr,br; cr=c->r;br=b->r; AM=A->M;bV=b->V;cV=c->V; if (t) /* then A transposed */ for (i=0;ir>B->r||A->c>B->c) error(_("Target matrix too small in mcopy")); BM=B->M;Ac=A->c; for (AM=A->M;AMM+A->r;AM++) { pB= *BM; for (pA= *AM;pA< *AM+Ac; pA++) *(pB++) = *pA; BM++; } } /* mcopy */ void matmult(C,A,B,tA,tB) matrix C,A,B;int tA,tB; /* Puts A*B in C. A will be transposed in this calculation if tA is not zero. B will be transposed if tB is not zero */ { int i,j,k; double temp,*p,*p1,*p2,**CM,**AM,**BM; AM=A.M;BM=B.M;CM=C.M; /* Saves address calculation involved in C.M */ if (tA) { if (tB) { if ((A.r!=B.c)||(A.c!=C.r)||(B.r!=C.c)) { error(_("Incompatible matrices in matmult."));} for (i=0;ir!=A->c) error(_("Attempt to invert() non-square matrix")); c=(int *)CALLOC((size_t)A->c,sizeof(int)); /* index of columns, used for column pivoting */ d=(int *)CALLOC((size_t)A->c,sizeof(int)); rp=(int *)CALLOC((size_t)A->c,sizeof(int)); /* row changes */ cp=(int *)CALLOC((size_t)A->c,sizeof(int)); /* row changes */ for (i=0;ic;i++) { c[i]=i;d[i]=i;} AM=A->M; /* saving adress calculations*/ for (j=0;jc;j++) /* loop through columns to be reduced */ { max=0.0; for (i=j;ir;i++) /* loop through rows to search for pivot */ { p=AM[i]; for (k=j;kc;k++) /* loop through cols to search for pivot */ { x=p[c[k]];if (fabs(x)>max) { max=fabs(x);pr=i;pc=k;}} } /* now move pivot to element j,j */ p=AM[j];AM[j]=AM[pr];AM[pr]=p; /* rows exchanged */ k=c[j];c[j]=c[pc];c[pc]=k; /* columns exchanged */ rp[j]=pr; /* stores row pivoted with */ cp[j]=pc; /* stores column pivoted with */ cj=c[j]; /* save time */ /* Now reduce the column */ x=AM[j][cj]; if (x==0.0) error(_("Singular Matrix passed to invert()")); for (p=AM[j];pc;p++) *p/=x; /* divide row j by pivot element */ AM[j][cj]=1.0/x; for (i=0;ir;i++) /* work down rows eliminating column j */ { p=AM[i];p1=AM[j]; if (i!=j) { x = -p[cj]; /* multiplier for this row */ for (k=0;kc;k++) /* cols of A */ { ck=c[k];p[ck]+=x*p1[ck];} } } } for (i=A->r-1;i>=0;i--) /*work down through column re-ordering */ { if (cp[i]!=i) { p=AM[i];AM[i]=AM[cp[i]];AM[cp[i]]=p; /* row exchange */ } } for (j=0;jc-1;j++) /* implement column exchange */ if (c[j]!=j) { if (c[j]r;i++) { p=AM[i];x=p[j];p[j]=p[k];p[k]=x;} d[k]=d[j];d[j]=c[j]; c[d[k]]=k; } for (i=A->r-1;i>=0;i--) /* column exchange implied by row re-ordering */ if (rp[i]!=i) { for (k=0;kr;k++) { p=AM[k];x=p[i];p[i]=p[rp[i]];p[rp[i]]=x;} /* column exchange */ } FREE(c);FREE(rp);FREE(cp);FREE(d); } /* invert */ double dot(a,b) matrix a,b; { int i,k=0;double c=0.0,*p,*p1; if (a.vec) { p1=b.V;for (p=a.V;pm) m=y; } else for (i=0;im) m=y;}/* m=max(m,fabs(*p)); */ if (!m) return(0.0); if (d.vec) for (p=d.V;pV; u->r=t1+1; for (i=0;ir;i++) uV[i]=aV[i]-bV[i]; v=enorm((*u))/sqrt(2.0); for (i=0;ir;i++) uV[i]/=v; } /* householder */ void Hmult(C,u) matrix C,u; /* This routine is for post multiplication by Housholder matrices only */ { double temp,*p,*p1,*uV,**CuM,**CM; int i,j; matrix Cu; Cu=initmat(C.r,u.c); uV=u.V;CuM=Cu.M;CM=C.M; for (i=0;i CQ; p==0,t==1 => CQ'; p==1,t==0 => QC; p==1,t==1 => Q'C NOTE that the routine expects C to be compatible with the Hi's - if this routine is being used for projection in and out of Null spaces, then make sure that C is appropriately packed with zeroes. If appropriate zero packing conventions have been used then OrthMult() is more efficient.... */ { double *u,*CuV,**CM; matrix Cu; int i,j,k; if (p) Cu=initmat(C.c,1);else Cu=initmat(C.r,1); CuV=Cu.V;CM=C.M; if (p) { if (t) { for (k=0;k=0;k--) /* loop through the householder matrices */ { u=U.M[k]; for (i=0;i=0;k--) /* loop through the householder matrices */ { u=U.M[k]; for (i=0;i0) { for (i=0;im) m=x;} /* scale factor */ if (m) for (j=0;jc,A->r); AM=A->M;AtM=At.M; for (i=0;ir;i++) for (j=0;jc;j++) AtM[j][i]=AM[i][j]; t=1-t; } else At=*A; AM=At.M;QM=Q->M;Ar=At.r;Qc=Q->c; for (kk=0;kkM; for (i=0;iV;yV=y->V; if (y->r==1) /* then p and y are vectors */ { if (transpose) /* solve R'p=y for p */ { RM=R->M; for (i=0;ir;i++) { x=0.0;dum=pV;for (j=0;jr-1;i>=0;i--) { RMi=R->M[i]; x=0.0;for (j=i+1;jr;j++) x+=RMi[j]*pV[j]; pV[i]=(yV[i]-x)/RMi[i]; } } else /* p and y are matrices */ { pM=p->M;yM=y->M; if (transpose) /* solve R'p=y for p */ { RM=R->M; for (k=0;kc;k++) for (i=0;ir;i++) { x=0.0;for (j=0;jc;k++) for (i=R->r-1;i>=0;i--) { RMi=R->M[i]; x=0.0;for (j=i+1;jr;j++) x+=RMi[j]*pM[j][k]; pM[i][k]=(yM[i][k]-x)/RMi[i]; } } } /* Rsolv */ int QR(matrix *Q,matrix *R) /* Does a QR factorisation of the matrix supplied in R. In Q the householder vectors are supplied to perform the transformation QR(in) -> R(out) R(out) is upper triangular (elements are 0 below leading diagonal). If Q->r is none zero then the vectors u are stored in successive rows of Q. The u vectors make up Q as a series of (stable) householder transformations. (I-uu'). The transformations are to be applied from the left in row order. The first i elements of the ith u are zero (i starting at zero). If A is the matrix input in R then QA=R, so that A=Q'R. Q can be used with OrthoMult(). Under/overflow avoidance added 13/1/2000 along with more efficient calculation of length of u (modifications tested). */ { int i,j,k,n,Rr; double *u,t,z,**RM,*p,m; RM=R->M;Rr=R->r; if (Rrc) n=Rr; else n=R->c; u=(double *)CALLOC((size_t)Rr,sizeof(double)); for (k=0;km) m=z;} if (m) for (i=k;i0.0) t = -sqrt(t);else t= sqrt(t); /* value of new RM[k][k] (stable) */ for (i=k+1;ic;j++) { t=0.0;for (i=k;ir) /* store vectors u for making Q */ { p=Q->M[k]; for (i=k;i0) { k=el;return(0);} na=(*(double **)a);nb=(*(double **)b); nak = na + k; for (;na *nb) return(1); } return(0); } int melemcmp(const void *a,const void *b) { return(real_elemcmp(a,b,-1)); } void msort(matrix a) /* sorts a matrix, in situ, using standard routine qsort so that its first col is in ascending order, its second col is in ascending order for any ties in the first col, and so on..... */ { double z=0.0; real_elemcmp(&z,&z,a.c); qsort(a.M,(size_t)a.r,sizeof(a.M[0]),melemcmp); } void RArrayFromMatrix(double *a,int r,matrix *M) /* copies matrix *M into R array a where r is the number of rows of A treated as a matrix by R */ { int i,j; for (i=0;ir;i++) for (j=0;jc;j++) a[i+r*j]=M->M[i][j]; } matrix Rmatrix(double *A,int r,int c) /* produces a matrix from the array containing a (default) R matrix stored: A[0,0], A[1,0], A[2,0] .... etc */ { int i,j; matrix M; M=initmat(r,c); for (i=0;i #include #include #include "mgcv.h" #include void mvn_ll(double *y,double *X,double *XX,double *beta,int *n,int *lpi, /* note zero indexing */ int *m,double *ll,double *lb,double *lbb,double *dbeta, double *dH,int *deriv,int *nsp,int *nt) { /* inputs: * 'y' is an m by n matrix, each column of which is a m-dimensional observation of a multivariate normal r.v. * 'X' is a sequence of model matrices. The first (0th) model matrix runs from columns 0 to lpi[0]-1, the jth from cols lpi[j-1] to lpi[j]-1. lpi indexing starts from 0!! * XX is the pre-computed X'X matrix. * 'beta' is a parameter vector corresponding to X. The m*(m+1)/2 elements starting at lpi[m] are the parameters of the Choleki factor of the precision matrix. * nt is number of threads to use. outputs: * 'll' is the evaluated log likelihood. * 'lb' is the grad vector */ double *R,*theta,ldetR,*Xl,*bl,oned=1.0,zerod=0.0,*p,*p1,*p2,*p3,xx,zz,yy,*yty, *mu,*Rymu,rip,*dtheta,*db,*deriv_theta,*yX,*yRX; int i,j,k,l,pl,one=1,bt,ct,nb,*din,ntheta,ncoef,*rri,*rci,ri,rj,ril,rjl,rik,rjk,rij,rjj,q,r; const char not_trans='N'; ntheta = *m * (*m+1)/2;ncoef = lpi[*m-1]; nb = ncoef + ntheta; /* number of coefficients overall */ /* Create the Choleski factor of the precision matrix */ R = (double *)CALLOC((size_t)*m * *m,sizeof(double)); theta = beta + lpi[*m-1]; /* parameters of R */ ldetR = 0.0; /* log|R| */ rri = (int *)CALLOC((size_t)ntheta,sizeof(int)); /* theta to R row index */ rci = (int *)CALLOC((size_t)ntheta,sizeof(int)); /* theta to R col index */ deriv_theta = (double *)CALLOC((size_t)ntheta,sizeof(double)); /* exp(theta) or 1*/ for (k=0,i=0;i<*m;i++) { /* fill out R */ deriv_theta[k] = exp(theta[k]); R[i + *m * i] = deriv_theta[k];ldetR += theta[k]; rri[k]=rci[k]=i;k++; for (j=i+1;j<*m;j++) { R[i + *m * j] = theta[k]; deriv_theta[k] = 1.0; rri[k]=i;rci[k]=j;k++; } } /* obtain y - mu */ mu = (double *)CALLOC((size_t)*n,sizeof(double)); for (l=0;l<*m;l++) { /* loop through components */ if (l==0) { Xl = X;pl = lpi[0];bl=beta;} /* Xl is lth model matrix with pl columns, coef vec bl */ else { Xl = X + *n * lpi[l-1];pl = lpi[l]-lpi[l-1];bl = beta + lpi[l-1];} F77_CALL(dgemv)(¬_trans,n,&pl,&oned,Xl,n, bl, &one,&zerod, mu, &one FCONE); /* BLAS call for mu = Xl bl */ /* now subtract mu from relevant component of y */ for (p=mu,p1= mu + *n,p2=y+l;p=k */ /* inner product of col l and col k of R ... */ for (p=R+l * *m,p1=R+k * *m,rip=0.0,p2=p1+k;p1<=p2;p++,p1++) rip += *p * *p1; lbb[i + nb * j] = lbb[j + nb * i] = -XX[i + ncoef * j]*rip; /* -xx*rip; */ } /* now the mixed blocks */ for (i=0;i /* required for R specific stuff */ #ifdef ENABLE_NLS #include #define _(String) dgettext ("mgcv", String) #else #define _(String) (String) #endif mgcv/src/misc.c0000755000176200001440000006667613501254612013123 0ustar liggesusers/* Copyright (C) 2008-2014 Simon N. Wood simon.wood@r-project.org This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. (www.gnu.org/copyleft/gpl.html) You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #include #include #include #include #include #include #include #include "mgcv.h" void *R_chk_calloc1(size_t nmemb,size_t size) { /* checks for zero or negative memory allocation calls...*/ if (nmemb<=0) { Rprintf("adjusting %d memory allocation\n",nmemb); nmemb++; } return(R_chk_calloc(nmemb,size)); } /* Compute reproducing kernel for spline on the sphere */ void rksos(double *x,int *n,double *eps) { /* Function to compute reproducing kernel for spline on the sphere, based on Jim Wendelberger's (1981) thesis. Returns evaluated kernel rk(x) in n vector x. */ double dl1,xi,rk,xk,xx; int i,k; dl1 = acos(0)*2; dl1 = dl1*dl1/6; /* dilog(1) = pi^2/6, dilog(0)=0 */ for (i=0;i< *n;i++) { xi = x[i]; if (xi <= 0) { if (xi < -1) xi = -1; rk = 1.0 - dl1; xk = xi = xi/2 + 0.5; for (k=1;k<1000;k++) { xx = xk/(k*k); rk += xx; xk *= xi; if (xx < *eps) break; } } else { if (xi>1) xi=1; if (xi/2>=.5) rk=1.0; else rk = 1 - log(.5+xi/2)*log(.5-xi/2); xk = xi = .5 - xi/2; for (k=1;k<1000;k++) { xx = xk/(k*k); rk += -xx; xk *= xi; if (xk < *eps) break; } } x[i] = rk; } } /* inside polygon tester.... */ void in_out(double *bx, double *by, double *break_code, double *x,double *y,int *in, int *nb, int *n) /* finds out whether points in arrays x,y are inside boundary or outside, by counting boundary crossings. The boundaries nodes are defined by bx, by. bx[i] and by[i] less than or equal to break_code signals a break in the boundary (e.g. between island and external boundary.) Each section of boundary is assumed to be a closed loop. nb is dimenion of bx and by; n is dimension of x and y. `in' will contain a 1 for an interior point and a 0 otherwise, on exit. Both bx[i] and by[i] or neither must be less than the break_code. */ { double xx,yy,dum,x0,x1,y0,y1; int i,j,count,start,swap; for (i=0;i<*n;i++) { /* loop through all test points */ xx=x[i];yy=y[i]; /* the current test point */ start=0; /* start of current boundary section */ for (count=0,j=0;j<*nb;j++) { /* loop through entire boundary */ x0 = bx[j]; /* start node */ if (x0 <= *break_code) start=j+1; /* next segment start */ else { /* not a new section start */ if (j==*nb-1) x1=bx[start]; else x1 = bx[j+1]; /* end node */ if (x1 <= *break_code) x1 = bx[start]; /* must join up segment end */ if (x0!=x1) { /* x0==x1 => segment immaterial to decision */ if (x1=xx) { /* might have a crossing */ y0 = by[j]; /* start node y co-ord */ if (j==*nb-1) y1=by[start]; else y1 = by[j+1]; /* end node y co-ord */ if (y1 <= *break_code) y1=by[start]; /* must join up */ if (y0<=yy&&y1<=yy) count++; /* definite crossing */ else { /* more detail needed to determine crossing */ if (!(y0>yy&&y1>yy)) { /* could still be one */ if (swap) {dum=y0;y0=y1;y1=dum;} dum = (xx-x0)*(y1-y0)/(x1-x0)+y0; /* at what y does vertical cross segment */ if (yy>=dum) count++; /* it's a crossing */ } /* end - could still be one */ } /* end - more detail */ } /* end - might be a crossing */ } /* end - does seg matter */ } /* end - not skipped because break */ } /* end boundary loop */ if (count%2) in[i]=1;else in[i]=0; /* record result */ } /* end x,y test loop */ } /* end of in_out */ /******************************/ /* Tweedie distribution stuff */ /******************************/ void psum(double *y, double *x,int *index,int *n) { /* y is of length max(index). x and index are of the same length, n. This routine fills y[index[i]-1] so that it contains the sum of the x[i]'s sharing index[i]. It is assumed that y is cleared to zero on entry. */ int i; for (i=0;i< *n;i++) { y[index[i]-1] += x[i]; } } double *forward_buf(double *buf,int *jal,int update) /* extend buffer forward 1000 */ { double *buf2,*p,*p1,*p2; int n=1000; buf2 = (double *)CALLOC((size_t)(*jal+n),sizeof(double)); for (p=buf,p1=buf + *jal,p2=buf2;p *j0-1) n = *j0 - 1; /* only extend back to j=1 */ if (n==0) return(buf); buf2 = (double *)CALLOC((size_t)(*jal+n),sizeof(double)); for (p=buf,p1=buf + *jal,p2=buf2 + n;p0) { exp_th = exp(- *th); //drho_const = (1+exp_th)/(1 - *b + (1 - *a)*exp_th); x = 1 + exp_th;p = (*b + *a * exp_th)/x; x1 = x*x;dpth1 = exp_th*(*b - *a)/x1; dpth2 = ((*a - *b)*exp_th+(*b - *a)*exp_th*exp_th)/(x1*x); } else { exp_th = exp(*th); //drho_const = (1+exp_th)/((1 - *b)*exp_th + 1 - *a); x = exp_th+1;p = (*b * exp_th + *a)/x; x1 = x*x;dpth1 = exp_th*(*b - *a)/x1; dpth2 = ((*a - *b)*exp_th*exp_th+(*b - *a)*exp_th)/(x*x1); } log_eps = log(*eps); onep = 1 - p;onep2 = onep * onep; alpha = (2 - p)/onep; /* get terms that are repeated in logWj etc., but simply multiplied by j */ w_base = alpha * log(p-1) + *rho/onep - log(2 - p); wp_base = (log(-onep) + *rho)/onep2 - alpha/onep + 1/(2 - p); wp2_base= 2*(log(-onep) + *rho)/(onep2*onep) - (3*alpha-2)/(onep2) + 1/((2 - p)*(2 - p)); /* initially establish the min and max y values, and hence the initial buffer range, at the same time produce the alpha log(y) log(y)/(1-p)^2 and log(y)/(1-p)^3 vectors. */ alogy = (double *)CALLOC((size_t)*n,sizeof(double)); logy1p2 = (double *)CALLOC((size_t)*n,sizeof(double)); logy1p3 = (double *)CALLOC((size_t)*n,sizeof(double)); ymax = ymin = *y; *alogy = alpha * log(*y); *logy1p2 = log(*y)/(onep2); *logy1p3 = *logy1p2/onep; for (p1=y+1,p2=y+ *n,p3=alogy+1,p4=logy1p2+1,p5=logy1p3+1;p1 ymax) ymax = *p1; else if (*p1 < ymin) ymin = *p1; } x = pow(ymin,2 - p)/(phi * (2 - p)); j_lo = (int) floor(x);if (j_lo<1) j_lo = 1; x = pow(ymax,2 - p)/(phi * (2 - p)); j_hi = (int) ceil(x);if (j_hi .5||j_max<1) j_max++; if (fabs(j_max-x)>1) { /* index has integer overflowed */ failed = 1; break; } j_max -= j0; /* converted to buffer index */ j = j_max+j0; jalogy = j*alogy[i]; wdW2d2W= wdlogwdp=dWpp=0.0; wi=w1i=w2i=0.0; // 1.0; /* j_max could be > jal_1 the currently allocated, or outside [j_lo,j_hi] the currently initialized. In either case we need fill in all the buffer values from the initialized set to j_max, so we might as well reset j_max to the appropriate buffer edge. */ if (j_max>j_hi) j_max = j_hi; if (j_maxxmax) {xmax=x;wp1jmin=x * *eps;} //if (x1>x1max) {x1max=x1;wdW2min=x1 * *eps;} //if (x2>x2max) {x2max=x2;Wppmin=x2 * *eps;} if (wj < wmin) { ok=1;break;} //&&(w1j < w1min)&&(w2j < w2min)&& // (x < wp1jmin)&&(x1 < wdW2min)&&(x2 < Wppmin)) { ok=1;break;} /* converged on upsweep */ } /* end of upsweep to buffer end */ while (!ok) { /* while upsweep unconverged need to fill in more buffer */ for (;jb jal-1) j_hi = jal-1; /* set j_hi to last element filled */ if (!ok) { if (jal=j_lo;jb--,j--) { jalogy = j * alogy[i]; wj = wb[jb] - jalogy; w1j = wb1[jb]; wp1j = wp1[jb] - j * logy1p2[i]; /* d log W / dp */ wp2j = wp2[jb] - 2 * j * logy1p3[i]; /* d^2 log W/ dp^2 */ /* transform to working parameterization ... */ wp2j = wp1j * dpth2 + wp2j * dpth1 * dpth1; /* d^2 log W/ dth^2 */ wp1j *= dpth1; /* d log W / dth */ wppj = wpp[jb] * dpth1; wj_scaled = exp(wj-wmax); wi += wj_scaled; /* sum of the scaled W_j */ w1i += wj_scaled * w1j; /* sum W_j dlogW_j / d rho */ w2i += wj_scaled * w1j*w1j; /* sum W_j d^2logW_j / d rho^2 */ x = wj_scaled*wp1j; wdlogwdp += x; /* sum_j W_j dlogW_j/dp */ x1 = wj_scaled*(wp1j*wp1j + wp2j); wdW2d2W += x1; /* sum_j (dlog W_j/dp)^2 + W_j d^2logW_j/dp^2 */ x2 = wj_scaled*(wp1j*j/onep + wppj); dWpp += x2; if (wj < wmin) { ok=1;break;} /* converged on downsweep */ } /* end of downsweep to buffer end */ if (j<=1&&j_lo==0) ok=1; /* don't care about element size if reached base */ while (!ok) { /* while downsweep unconverged need to fill in more buffer */ for (jb=j_lo-1;jb>=0;jb--,j--) { /* fill buffers and calculate w terms */ wb[jb] = j * w_base - lgamma((double)j+1) - lgamma(-j * alpha); wb1[jb] = -j/onep; xx = j/onep2; x = xx*digamma(-j*alpha); wp1[jb] = j * wp_base + x; /* base for d logW_j/dp */ xx = trigamma(-j*alpha) * xx * xx; wp2[jb] = j * wp2_base + 2*x/onep - xx; wpp[jb] = j /onep2; jalogy = j * alogy[i]; wj = wb[jb] - jalogy; w1j = wb1[jb]; wp1j = wp1[jb] - j * logy1p2[i]; /* d log W / dp */ wp2j = wp2[jb] - 2 * j * logy1p3[i]; /* d^2 log W/ dp^2 */ /* transform to working parameterization ... */ wp2j = wp1j * dpth2 + wp2j * dpth1 * dpth1; /* d^2 log W/ dth^2 */ wp1j *= dpth1; /* d log W / dth */ wppj = wpp[jb] * dpth1; wj_scaled = exp(wj-wmax); wi += wj_scaled; /* sum of the scaled W_j */ w1i += wj_scaled * w1j; /* sum W_j dlogW_j / d rho */ w2i += wj_scaled * w1j*w1j; /* sum W_j d^2logW_j / d rho^2 */ x = wj_scaled*wp1j; wdlogwdp += x; /* sum_j W_j dlogW_j/dp */ x1 = wj_scaled*(wp1j*wp1j + wp2j); wdW2d2W += x1; /* sum_j (dlog W_j/dp)^2 + W_j d^2logW_j/dp^2 */ x2 = wj_scaled*(wp1j*j/onep + wppj); dWpp += x2; if (wj < wmin) { ok=1;break;} /* converged on upsweep */ } if (j<=1) ok=1; /* don't care about element size if reached base */ j_lo = jb; if (j_lo<0) j_lo=0; /* set j_lo to first element filled */ if (!ok) { if (jal0) { exp_th = exp(-th[i]); x = 1 + exp_th;p = (*b + *a * exp_th)/x; x1 = x*x;dpth1 = exp_th*(*b - *a)/x1; dpth2 = ((*a - *b)*exp_th+(*b - *a)*exp_th*exp_th)/(x1*x); } else { exp_th = exp(th[i]); x = exp_th+1;p = (*b * exp_th + *a)/x; x1 = x*x;dpth1 = exp_th*(*b - *a)/x1; dpth2 = ((*a - *b)*exp_th*exp_th+(*b - *a)*exp_th)/(x*x1); } /* first find the location of the series maximum... */ x = pow(y[i],2 - p)/(phi * (2 - p)); j_max = (int) floor(x); if (x - j_max > .5||j_max<1) j_max++; if (fabs(j_max-x)>1) { /* index has integer overflowed */ failed = 1; break; } j = j_max; onep = 1 - p;onep2 = onep * onep; twop = 2 - p; alpha = twop/onep; alogy = log(y[i]); logy1p2 = alogy/(onep2); logy1p3 = logy1p2/onep; alogy *= alpha; /* alpha * log(y[i]) */ wdW2d2W= wdlogwdp=dWpp=0.0; wi=w1i=w2i=0.0; /* get terms that are repeated in logWj etc., but simply multiplied by j */ w_base = alpha * log(-onep) + rho[i]/onep - log(twop); wp_base = (log(-onep) + rho[i])/onep2 - alpha/onep + 1/twop; wp2_base= 2*(log(-onep) + rho[i])/(onep2*onep) - (3*alpha-2)/(onep2) + 1/(twop*twop); wmax = j * w_base - lgamma((double)j+1) - lgamma(-j * alpha) - j*alogy; wmin = wmax + log_eps; /* start upsweep/downsweep to convergence */ ok = 0;//xmax=x1max=x2max=0.0; //for (j=j_max+j0,jb=j_max;jb<=j_hi;jb++,j++) { // note initially wi etc initialized to 1 and summation starts 1 later incr = 1; lgammaj1 = lgamma((double)j+1); // lgamma(j+1) to be computed by recursion k=0; while (!ok) { wbj = j * w_base - lgammaj1 - lgamma(-j * alpha); wb1j = -j/onep; xx = j/onep2; x = xx*digamma(-j*alpha); wp1jb = j * wp_base + x; /* base for d logW_j/dp */ xx = trigamma(-j*alpha) * xx * xx; wp2jb = j * wp2_base + 2*x/onep - xx; wppjb = j /onep2; jalogy = j * alogy; wj = wbj - jalogy; w1j = wb1j; wp1j = wp1jb - j * logy1p2; /* d log W / dp */ wp2j = wp2jb - 2 * j * logy1p3; /* d^2 log W/ dp^2 */ /* transform to working parameterization ... */ wp2j = wp1j * dpth2 + wp2j * dpth1 * dpth1; /* d^2 log W/ dth^2 */ wp1j *= dpth1; /* d log W / dth */ wppj = wppjb * dpth1; wj_scaled = exp(wj-wmax); wi += wj_scaled; /* sum of the scaled W_j */ w1i += wj_scaled * w1j; /* sum W_j dlogW_j / d rho */ w2i += wj_scaled * w1j*w1j; /* sum W_j d^2logW_j / d rho^2 */ x = wj_scaled*wp1j; wdlogwdp += x; /* sum_j W_j dlogW_j/dp */ //Rprintf("wdlogwdp=%g wj_scaled=%g wp1j=%g\n",wdlogwdp,wj_scaled,wp1j); x1 = wj_scaled*(wp1j*wp1j + wp2j); wdW2d2W += x1; /* sum_j (dlog W_j/dp)^2 + W_j d^2logW_j/dp^2 */ x2 = wj_scaled*(wp1j*j/onep + wppj); dWpp += x2; j += incr; if (incr>0) { // upsweep lgammaj1 += log(j); if (wj < wmin) { j = j_max - 1;incr = -1; if (j==0) ok=1; // finished lgammaj1 = lgamma((double)j+1); } // change to downsweep } else { lgammaj1 += -log(j+1); if (wj < wmin||j<1) ok=1; // finished } k++; if (k>=jal_lim) ok = series_too_long = 1; /* avoid going on for ever */ } /* end of upsweep/downsweep */ //Rprintf("wdlogwdp = %g\n",wdlogwdp); /* Summation now complete: need to do final transformations */ w[i] = wmax + log(wi); /* contains log W */ w2[i] = w2i/wi - (w1i/wi)*(w1i/wi); w2p[i] = wdW2d2W/wi - (wdlogwdp/wi)*(wdlogwdp/wi); w2pp[i] = (w1i/wi)*(wdlogwdp/wi) + dWpp/wi; w1[i] = -w1i/wi; w1p[i] = wdlogwdp/wi; } /* end of looping through y */ if (series_too_long) *eps = -1.0; if (failed) *eps = -2.0; } /* tweedious2 */ /* test code for tweedious... library(mgcv);library(tweedie) phi <- 2 p <- 1.1 mu <- .001 y <- c(1,1,2,1,3,0,0,30,67) eps <- 1e-6 l0 <- colSums(mgcv:::ldTweedie(y,mu=mu,p=p,phi=phi)) l1 <- colSums(mgcv:::ldTweedie(y,mu=mu,p=p,phi=phi+eps)) (l1-l0)/eps;l0 log(dtweedie(y,power=p,mu=mu,phi=phi)) j <- 1:100 alpha <- (2-p)/(1-p) w <- -j*alpha*log(y)+alpha*j*log(p-1)-j*(1-alpha)*log(phi)-j*log(2-p)-lgamma(j+1) - lgamma(-j*alpha) theta <- mu^(1-p) k.theta <- mu*theta/(2-p) theta <- theta/(1-p) (y*theta-k.theta)/phi - log(y) + log(sum(exp(w))) n <- 20 mu <- rep(1,n) ml <- mgcv:::ldTweedie(1:n,mu,p=1.5,phi=1);ml dl <- log(dtweedie.series(1:n,power=1.5,mu,phi=1));dl x <- seq(.05,100,by=.1) mu <- 1+x*0 sum(dtweedie(x,power=1.5,mu,phi=1))*.1 + dtweedie(0,power=1.5,1,phi=1) sum(exp(mgcv:::ldTweedie(x,mu,p=1.5,phi=1)))*.1 + exp(mgcv:::ldTweedie(0,1,p=1.5,phi=1)) x <- rtweedie(10000,power=1.5,mu=1,phi=1) system.time(d1 <- dtweedie(x,power=1.5,mu=1,phi=1)) system.time(d2 <- mgcv:::ldTweedie(x,mu=1,p=1.5,phi=1)) range(d2-log(d1)) */ /*******************************************************/ /** Fast re-weighting routines */ /*******************************************************/ void rwMatrix(int *stop,int *row,double *w,double *X,int *n,int *p,int *trans,double *work) { /* Function to recombine rows of n by p matrix X (column ordered). ith row of X' is made up of row[stop[i-1]+1...stop[i]], weighted by w[stop[i-1]+1...stop[i]]. stop[-1]=-1 by convention. stop is an n vector. If (trans==0) the operation on a column x is x'[i] += w[row[j]] * X[row[j]] over the j from stop[i-1]+1 to stop[i]. Otherwise the tranposed operation x'[row[j]] += w[row[j]] * x[i] is used with the same j range. x' zero at outset. work is same dimension as X See rwMatrix in bam.r for call from R. */ ptrdiff_t i,j,jump,start=0,end,off; double *X1p,*Xp,weight,*Xpe,*X1; /* create storage for output matrix, cleared to zero */ X1 = work; jump = *n; off = *n * (ptrdiff_t) *p; for (X1p=X1,Xpe=X1p+off;X1p= *nt-r) { i -= *nt - r; r++;} c = r + i; */ #include #include #include #include "mgcv.h" #include #ifdef OPENMP_ON #include #endif struct SM_el { /* stores element of sparse matrix */ int i,j; /* row and column */ double w; /* entry */ struct SM_el *next; /* pointer to next record */ }; typedef struct SM_el SM; void SMinihash(unsigned long long *ht) { /* initialize hash generator ht (length 256), used in converting matrix row column pairs to hash keys. */ unsigned long long h; int j,k; h = 0x987564BACF987454LL; for (j=0;j<256;j++) { for (k=0;k<31;k++) { h = (h>>7)^h; h = (h<<11)^h; h = (h>>10)^h; } ht[j] = h; } } /* SMinihash */ void indReduce(int *ka,int *kb,double *w,int tri,int *n, unsigned long long *ht,SM **sm,SM * SMstack,double *C,double *A, int rc,int cc,int ra,int trans,int *worki,int buffer) { /* on input ka, kb and w are n-vectors. Let W be a matrix initialized to zero. w[i] is to be added to element ka[i], kb[i] of W. If tri!=0 then ws[i] is added to element ka[i], kb[i+1] and wl[i] to ka[i+1], kb[i]. ws is stored at w + n and wl at ws + n; C is rc by cc and A is ra by cc. If trans!=0 then form C+=W'A otherwise C+=WA On entry SMstack should be an n-vector if tri==0 and a 3n-vector otherwise. sm is an n vector. This routine accumulates W in a sparse, i,j,w structure constructed using a hash table. After accumulation the hash table contains n_u <= n unique matrix entries, which can then be used directly to form the matrix product. Accumulation cost is O(n). Access cost is then O(n_u) while matrix product cost is O(n_u * cc). In comparison direct accumulation costs would be O(n*cc). If buffer!=0 then the routine will access worki (dimension 6 * n) and will modify w. It does this becuase it massively improves data locality and cache performance to read the sparse matrix out of the hash table structure into 3 arrays, before using it for multiplication. */ SM **sm1, **sm2,*smk; int bpp,nstack,nkey,ij[2],k,l,i,j,t,*kao,*kbo; char *key,*keyend; unsigned long long h; double Wij,*Cq,*Aq,*Cq1,*ws,*wl; if (tri) { ws = w + *n;wl = ws + *n;} else {ws=wl=w; /* avoid compiler warning */} bpp = sizeof(int)/sizeof(char); nkey = bpp * 2; /* length of key in char */ if (tri) nstack = 3 * *n-1; else nstack = *n-1; /* top of the SM element stack */ /* clear the hash table */ for (sm1=sm,sm2=sm + *n;sm1i == i && smk->j==j) { smk->w += Wij;break; } smk = smk->next; /* next element in list */ } if (!smk) { /* no match found - add to linked list */ smk = SMstack + nstack;nstack--; /* remove an entry from the stack */ smk->next = sm[k];sm[k]=smk;smk->i = i;smk->j = j;smk->w=Wij; } } else { /* slot was empty */ smk = sm[k] = SMstack + nstack;nstack--; /* remove an entry from the stack */ smk->i = i;smk->j = j;smk->w=Wij;smk->next = (SM *)NULL; } } /* t loop */ } /* l loop */ /* Now form C = \bar W A -- There is a problem here - the access to C and A are cache inefficient --- The only solutions to this are either to read out the elements of the linked list to temporary arrays, which allows working over cols to be outer to working though the list, or transposing C and A so that they are in row-major order. */ if (buffer) { /* read data structure out to arrays */ ka = kao = worki; kb = kbo= worki + 3 * *n;ws=w; for (k=0,sm1=sm,sm2=sm + *n;sm1i;kbo[k] = smk->j;w[k] = smk->w;k++;smk = smk->next; *ka = smk->i;*kb = smk->j;*ws = smk->w;k++;ka++;kb++;ws++;smk = smk->next; } } if (trans) for (Aq=A,Cq = C,Cq1=C+rc*cc;Cqi;i = smk->j;} else { i = smk->i;j = smk->j;} Wij = smk->w;smk = smk->next; for (Cq = C + i,Aq = A + j,Cq1 = C + rc*cc;Cq0 && j==dt[i]-1) { c1 = pt[i] * (ptrdiff_t) m[q]; if (c1>dC) dC = c1; /* dimension of working matrix C */ } if (j==0) pt[i] = p[q]; else pt[i] *= p[q]; /* term dimension */ } if (qc[i]>0) voff[i+1] = voff[i] + pt[i]; else voff[i+1] = voff[i]; /* start of ith v matrix */ if (maxp < pt[i]) maxp = pt[i]; if (qc[i]<=0) tps[i+1] = tps[i] + pt[i]; /* where ith terms starts in param vector */ else tps[i+1] = tps[i] + pt[i] - 1; /* there is a tensor constraint to apply - reducing param count*/ } /* now form the product term by term... */ i = *n; if (i0 && j==dt[i]-1) { c1 = pt[i] * (ptrdiff_t) m[q]; if (c1>dC) dC = c1; /* dimension of working matrix C */ } if (j==0) pt[i] = p[q]; else pt[i] *= p[q]; /* term dimension */ } if (qc[i]>0) voff[i+1] = voff[i] + pt[i]; else voff[i+1] = voff[i]; /* start of ith v matrix */ if (maxp < pt[i]) maxp = pt[i]; //if (qc[i]<=0) tps[i+1] = tps[i] + pt[i]; /* where ith terms starts in param vector */ //else tps[i+1] = tps[i] + pt[i] - 1; /* there is a tensor constraint to apply - reducing param count*/ } if (*ncs<=0) { /* return everything */ for (j=0;j<*nt;j++) cs[j] = j; *ncs = *nt; } for (kk=j=0;j<*ncs;j++) { /* get the offsets for the returned terms in the output */ i = cs[j];tps[i] = kk; if (qc[i]<=0) kk += pt[i]; /* where cth terms starts in param vector */ else kk += pt[i] - 1; /* there is a tensor constraint to apply - reducing param count*/ } tps[*nt] = kk; // Rprintf("\n pt:"); //for (i=0;i<*nt;i++) Rprintf(" %d",pt[i]); //Rprintf("\n nt = %d ncs = %d cs, tps[cs]:\n",*nt,*ncs); //for (i=0;i< *ncs;i++) Rprintf(" %d %d",cs[i],tps[cs[i]]); /* now form the product term by term... */ i = *n; if (i0) X1 <- cbind(X1,X[[i]][k[,i],]) XWX <- XWXd(X,w,k,ks,ts,dt,v=NULL,qc=rep(-1,3),lt=lt,rt=lt) XWXf <- t(X1)%*%(w*X1) range(XWXf-XWX) */ double *xv,*dc,*p0,*p1,*p2,*p3,*ei,*xi; ptrdiff_t bsj,bs,bsf,i,j,kk; int one=1; #ifndef OPENMP_ON *nthreads = 1; #endif if (*nthreads<1) *nthreads = 1; if (*nthreads > *cv) *nthreads = *cv; xv = (double *) CALLOC((size_t) *nthreads * *n,sizeof(double)); /* storage for cols of XV */ xi = (double *) CALLOC((size_t) *nthreads * *n,sizeof(double)); /* storage for cols of X */ ei = (double *) CALLOC((size_t) *nthreads * *cv,sizeof(double)); /* storage for identity matrix cols */ dc = (double *) CALLOC((size_t) *nthreads * *n,sizeof(double)); /* storage for components of diag */ if (*nthreads>1) { bs = *cv / *nthreads; while (bs * *nthreads < *cv) bs++; while (bs * *nthreads - bs >= *cv) (*nthreads)--; bsf = *cv - (bs * *nthreads - bs); } else { bsf = bs = *cv; } #ifdef OPENMP_ON #pragma omp parallel for private(j,bsj,i,kk,p0,p1,p2,p3) num_threads(*nthreads) #endif for (j=0;j < *nthreads;j++) { if (j == *nthreads - 1) bsj = bsf; else bsj = bs; for (i=0;i0) ei[j * *pv + kk - 1] = 0; /* Note thread safety of XBd means this must be only memory allocator in this section*/ Xbd(xv + j * *n,V + kk * *pv,X,k,ks,m,p,n,nx,ts,dt,nt,v,qc,&one,cs,ncs); /* XV[:,kk] */ Xbd(xi + j * *n,ei + j * *pv,X,k,ks,m,p,n,nx,ts,dt,nt,v,qc,&one,rs,nrs); /* X[:,kk] inefficient, but deals with constraint*/ /*Rprintf("\n kk = %d\n",kk); for (kk=0;kk<*n;kk++) Rprintf("%d %g %g\n",kk,xv[kk],xi[kk]); Rprintf("---------------\n");*/ p0 = xi + j * *n;p1=xv + j * *n;p2 = dc + j * *n;p3 = p2 + *n; for (;p2=0) { /* model has AR component, requiring sqrt(weights) */ for (p0 = w,p1 = w + *n;p00) voff[i+1] = voff[i] + pt[i]; else voff[i+1] = voff[i]; /* start of ith Q matrix */ if (maxp < pt[i]) maxp=pt[i]; if (qc[i]<=0) tps[i+1] = tps[i] + pt[i]; /* where ith terms starts in param vector */ else tps[i+1] = tps[i] + pt[i] - 1; /* there is a tensor constraint to apply - reducing param count*/ } Xy0 = (double *) CALLOC((size_t)maxp,sizeof(double)); work = (double *) CALLOC((size_t)*n,sizeof(double)); work1 = (double *) CALLOC((size_t)maxm,sizeof(double)); /* apply W to y */ Wy = (double *) CALLOC((size_t)*n,sizeof(double)); /* Wy */ for (p0=Wy,p1=Wy + *n,p2=w;p0=0) { /* AR components present (weights are sqrt, therefore) */ rwMatrix(ar_stop,ar_row,ar_weights,Wy,n,&one,&zero,work); rwMatrix(ar_stop,ar_row,ar_weights,Wy,n,&one,&one,work); /* transpose of transform applied */ for (p0=w,p1=w + *n,p2=Wy;p01) { /* it's a tensor */ //tensorXty(Xy0,work,work1,Wy,X+off[ts[i]],m+ts[i],p+ts[i],dt+i,k+ts[i] * (ptrdiff_t) *n,n); for (q=0;q0) { /* there is a constraint to apply Z'Xy0: form Q'Xy0 and discard first row... */ /* Q' = I - vv' */ for (x=0.0,p0=Xy0,p1=p0 + pt[i],p2=v+voff[i];p0 0 then cs contains the subset of terms (blocks of model matrix columns) to include. */ double *Wy,*p0,*p1,*p2,*p3,*Xy0,*work,*work1,x; ptrdiff_t i,j,*off,*voff; int *tps,maxm=0,maxp=0,one=1,zero=0,*pt,add,q,kk,n_XWy; if (*ar_stop>=0) { /* model has AR component, requiring sqrt(weights) */ for (p0 = w,p1 = w + *n;p00) voff[i+1] = voff[i] + pt[i]; else voff[i+1] = voff[i]; /* start of ith Q matrix */ if (maxp < pt[i]) maxp=pt[i]; //if (qc[i]<=0) tps[i+1] = tps[i] + pt[i]; /* where ith terms starts in param vector */ //else tps[i+1] = tps[i] + pt[i] - 1; /* there is a tensor constraint to apply - reducing param count*/ } if (*ncs<=0) { /* return everything */ for (j=0;j<*nt;j++) cs[j] = j; *ncs = *nt; } for (kk=j=0;j<*ncs;j++) { /* get the offsets for the returned terms in the output */ i = cs[j];tps[i] = kk; if (qc[i]<=0) kk += pt[i]; /* where cth terms starts in param vector */ else kk += pt[i] - 1; /* there is a tensor constraint to apply - reducing param count*/ } /* kk is number of rows of XWy, at this point */ n_XWy = kk; Xy0 = (double *) CALLOC((size_t)maxp,sizeof(double)); work = (double *) CALLOC((size_t)*n,sizeof(double)); work1 = (double *) CALLOC((size_t)maxm,sizeof(double)); Wy = (double *) CALLOC((size_t)*n,sizeof(double)); /* Wy */ for (j=0;j<*cy;j++) { /* loop over columns of y */ for (p0=Wy,p1=Wy + *n,p2=w;p0=0) { /* AR components present (weights are sqrt, therefore) */ rwMatrix(ar_stop,ar_row,ar_weights,Wy,n,&one,&zero,work); rwMatrix(ar_stop,ar_row,ar_weights,Wy,n,&one,&one,work); /* transpose of transform applied */ for (p0=w,p1=w + *n,p2=Wy;p01) { /* it's a tensor */ //tensorXty(Xy0,work,work1,Wy,X+off[ts[i]],m+ts[i],p+ts[i],dt+i,k+ts[i] * (ptrdiff_t) *n,n); for (q=0;q0) { /* there is a constraint to apply Z'Xy0: form Q'Xy0 and discard first row... */ /* Q' = I - vv' */ for (x=0.0,p0=Xy0,p1=p0 + pt[i],p2=v+voff[i];p0=0) { /* model has AR component, requiring sqrt(weights) */ for (p0 = w,p1 = w + *n;p00) voff[i+1] = voff[i] + pt[i]; else voff[i+1] = voff[i]; /* start of ith v vector */ if (maxppd[c]) { /* Form Xr'WXc */ a=r;b=c; } else { /* Form Xc'WXr */ a=c;b=r; } /* split cols between threads... */ dk = pt[b] / *nthreads; //rk = pt[b] % *nthreads; if (dk * *nthreads < pt[b]) dk++; start[0]=0; for (i=0;i<*nthreads;i++) { start[i+1] = start[i] + dk; if (start[i+1]>pt[b]) start[i+1]=pt[b]; } #ifdef OPENMP_ON #pragma omp parallel private(Xi,Xj,i,q,add,temp,tempn,p0,p1,p2) num_threads(*nthreads) #endif { /* begin parallel section */ #ifdef OPENMP_ON #pragma omp for #endif for (kk=0;kk<*nthreads;kk++) { /* allocate thread specific storage... */ temp = tempB + kk * (ptrdiff_t) maxm; Xi = XiB + kk * (ptrdiff_t) *n; Xj = XjB + kk * (ptrdiff_t) *n; tempn = tempnB + kk * (ptrdiff_t) *n; for (i=start[kk];i1) { /* tensor */ for (p0=Xi,p1=p0+*n;p01) { /* tensor */ for (p0=Xj,p1=p0+*n;p0=0) { /* AR components present (weights are sqrt, therefore) */ rwMatrix(ar_stop,ar_row,ar_weights,Xi,n,&one,&zero,tempn); rwMatrix(ar_stop,ar_row,ar_weights,Xi,n,&one,&one,tempn); /* transpose of transform applied */ for (p0=w,p1=w + *n,p2=Xi;p01) { /* tensor */ tensorXty(xwx + i * pt[a],tempn,temp,Xi,X+off[ts[a]],m+ts[a],p+ts[a], dt+a,k, n,&add,ks+ts[a],&q); } else { /* singleton */ singleXty(xwx + i * pt[a],temp,Xi,X+off[ts[a]],m+ts[a],p+ts[a],k + (ptrdiff_t)*n * (q + ks[ts[a]]),n,&add); } add = 1; /* for q>0 accumulate result */ } } /* loop over columns of Xb */ } /* so now xwx contains pt[a] by pt[b] matrix Xa'WXb */ } /* end parallel section */ /* if Xb is tensor, may need to apply constraint */ if (dt[a]>1&&qc[a]>0) { /* first term is a tensor with a constraint */ x0=x1=xwx; /* pointers to columns of xwx */ /* col by col form (I-vv')xwx, dropping first row... */ for (j=0;j1&&qc[b]>0) { /* second term is a tensor with a constraint */ /* copy xwx to xwx0 */ for (p0=xwx,p1=p0 + pt[b] * (ptrdiff_t) pa,p2=xwx0;p0pd[c]) { /* xwx = Xr'WXc */ for (i=0;imjm*mim) acc_w = 1; else acc_w = 0; /* accumulate \bar W or \bar W X_j / \bar W'X_i)? */ if (acc_w) { if (p[im]*mim*mjm + p[im]*p[jm]*mjm > mim*mjm*p[jm] + p[im]*p[jm]*mim) rfac=0; else rfac=1; /* Allocate storage for W (mim*mjm) */ nwork += mim*mjm; //W = work; work += mim*mjm; } else { /* now establish whether to form left product, D, or right product C */ if (tensi) ii = 2; else ii = 1;if (tensj) ii++; if (tri) alpha = ii*3 + 3; else alpha = ii + 1; /* ~ ops per iteration of accumulation loop */ if (alpha*si*sj*n*p[im]+mjm*p[im]*p[jm]15)||(!rfac && p[im]>15))) { if (tri) nwork += 3*n; else nwork += n; } } return(nwork); } /* XWXijspace */ ptrdiff_t XWXspace(int N,int *sb,int *b,int *B,int *R,int *C,int *k, int *ks, int *m, int *p,int *pt,int *pd,int nx,int n,int *ts, int *dt,int nt, int tri) { /* Tedious routine to evaluate workspace requirment of XWXijs. Basically does a dummy run through the blocks computing the memory requirement for each and recording the maximum used. Avoids over allocating. */ int j,kk,kb,i,rb,cb,rt,ct,r,c; ptrdiff_t nn,nmax=0; for (j=0;j=sb[kb+1]) kb++; /* kb is main block */ rb = R[kb];cb=C[kb]; /* set up allows blocks to be computed in any order by re-arranging B */ i = kk - sb[kb]; /* sub-block index */ rt = pt[rb]/pd[rb]; ct = pt[cb]/pd[cb]; /* total rows and cols of sub-blocks */ /* compute sub-row and column */ if (sb[kb+1]-sb[kb]= rt - r) { i -= rt - r;r++;} c = i + r; } else { r = i / ct; c = i % ct; } nn = XWXijspace(rb,cb,r,c,k,ks,m,p,nx,n,ts, dt,nt,tri); if (nmaxm[mi]*m[mj])*m[mi]*m[mj] + max(m[mi]*p[mj],m[mj]*p[mi]) + 3n SMstack should be an n-vectors if tri==0 and a 3n-vector otherwise. sm is an n vector. This version uses sparse accumulation if \bar W too large, based on calling indReduce. ht is a 256 vector initialized by SMinihash. sm is length n. SMstack is length n if tri==0, 3n otherwise. */ int si,sj,ri,rj,jm,im,kk,ddt,ddtj,koff,*K,*Ki,*Kj,pim,pjm, ii,jj,rfac,t,s,ddti,tensi,tensj,acc_w,alpha,*Kik,*Kjk,*Kik1,*Kjk1,*Kjl1,q; ptrdiff_t mim,mjm; /* avoid integer overflow in large pointer calculations */ double x,*wl,*dXi,*dXj,*pdXj,*Xt,*Xi,*Xj,done=1.0,dzero=0.0,*Cq,*Dq, *C=NULL,*D=NULL,*W=NULL,*wb,*p0,*p1,*p2,*p3,*pw,*pw1,*pl,*ps,*wi,*wsi,*wli,*wo,*psi,*pwi,*pli; char trans = 'T',ntrans = 'N'; si = ks[ts[i]+nx]-ks[ts[i]]; /* number of terms in summation convention for i */ if (tri) wl = ws + n - 1; else wl=ws; /* sub-diagonal else only to keep compiler happy */ /* compute number of columns in dXi/ number of rows of blocks in product */ for (ri=1,kk=ts[i];kk1) { /* tensor */ ddt = dt[i]-1; /* number of marginals, exluding final */ koff = 0; /* only one index vector per marginal, so no offset */ } if (dt[i]>1) { /* extract col r of dXi */ for (kk=0;kk1) { /* extract col c of dXi */ if (r!=c) { dXj=pdXj;for (kk=0;kk1) { for (kk=0;kkmjm*mim) acc_w = 1; else acc_w = 0; /* accumulate \bar W or \bar W X_j / \bar W'X_i)? */ if (acc_w) { if (p[im]*mim*mjm + p[im]*p[jm]*mjm > mim*mjm*p[jm] + p[im]*p[jm]*mim) rfac=0; else rfac=1; /* Allocate storage for W (mim*mjm) */ W = work; work += mim*mjm; } else { /* now establish whether to form left product, D, or right product C */ if (tensi) ii = 2; else ii = 1;if (tensj) ii++; if (tri) alpha = ii*3 + 3; else alpha = ii + 1; /* ~ ops per iteration of accumulation loop */ if (alpha*si*sj*n*p[im]+mjm*p[im]*p[jm]15)||(!rfac && p[im]>15)) { ii = n; /* will contain compressed index length after indReduce call */ if (tri) { wi = work;wsi = work+ii;wli = work+2*ii; /* do not increment work - inside s,t, loop!! */ if (tensi&&tensj) { ps=ws;pw=w;pl=wl;pwi = wi;psi=wsi;pli=wli;wo=w+ii-1; for (p0=dXi,p1=dXj,p2=dXi+1,p3=dXj+1;pw0) voff[i+1] = voff[i] + pt[i]; else voff[i+1] = voff[i]; /* start of ith v vector */ if (maxp=0) { /* model has AR component*/ for (p0 = w,p1 = w + *n;p0=sb[kb+1]) kb++; /* kb is main block */ rb = R[kb];cb=C[kb]; cost[i] = Cost[kb]; B[i] = kb; } revsort(cost,b,sb[N]); /* R reverse sort on cost, to re-order b - see R.h*/ q = XWXspace(N,sb,b,B,R,C,k,ks,m,p,pt,pd,*nx,*n,ts,dt,*nt,tri); /* compute the maximum workspace required per thread */ work = (double *)CALLOC((size_t)q * *nthreads,sizeof(double)); /* allocate it */ /* In what follows rb and cb are the whole term row column indices. r and c are the sub blocks within the cross-product between two terms. The sub blocks arise when we have tensor product terms. The cleaner design in which the sub-blocks are dealt with in XWXij does not load balance so well, hence this design.*/ kb=0; #ifdef OPENMP_ON #pragma omp parallel for private(j,kb,kk,r,c,rb,cb,rt,ct,tid,i) num_threads(*nthreads) schedule(dynamic) #endif for (j=0;j=sb[kb+1]) kb++; /* kb is main block */ rb = R[kb];cb=C[kb]; /* set up allows blocks to be computed in any order by re-arranging B */ i = kk - sb[kb]; /* sub-block index */ rt = pt[rb]/pd[rb]; ct = pt[cb]/pd[cb]; /* total rows and cols of sub-blocks */ /* compute sub-row and column */ if (sb[kb+1]-sb[kb]= rt - r) { i -= rt - r;r++;} c = i + r; } else { r = i / ct; c = i % ct; } #ifdef OPENMP_ON tid = omp_get_thread_num(); /* needed for providing thread specific work space to XWXij */ #endif XWXijs(XWX+tpsu[rb] + (ptrdiff_t) nxwx * tpsu[cb],rb,cb,r,c,X,k,ks,m,p,*nx,*n,ts, dt,*nt,w,ws, tri,off,work + tid * q,worki + tid * (ptrdiff_t) qi,nxwx,ht, sm + tid * (ptrdiff_t) *n,SMstack + 3 * tid * (ptrdiff_t) *n ); /* compute r,c block */ /* NOTE: above will write directly to oversized XWX, then have constraints applied post-hoc. */ } /* block loop */ /* now XWX contains the unconstrained X'WX, but the constraints have to be applied to blocks involving tensor products */ for (r=0;r < *nt;r++) for (c=r;c< *nt;c++) { /* if Xr is tensor, may need to apply constraint */ if (dt[r]>1&&qc[r]>0) { /* first term is a tensor with a constraint */ /* col by col form (I-vv')xwx, dropping first row... */ for (j=0;j1&&qc[c]>0) { /* Xc term is a tensor with a constraint */ /* row by row form xwx(I-vv') dropping first col... */ for (j=0;j zero, then its array denotes the rows and cols required. - the selected blocks are returned as a dense compact matrix (rather than being inserted into the full X'WX in the appropriate places, for example.) This version has the looping over sub-blocks, associated with tensor product terms, located in this routine to get better load balancing. Requires XWX to be over-sized on entry - namely n.params + n.terms by n.params + n.terms instead of n.params by n.params. Forms Xt'WXt when Xt is divided into blocks of columns, each stored in compact form using arguments X and k. * 'X' contains 'nx' blocks, the ith is an m[i] by p[i] matrix containing the unique rows of the ith marginal model matrix. * There are 'nt' model terms. Each term is made up of one or more maginal model matrices. * The jth term starts at block ts[j] of X, and has dt[j] marginal matrices. The terms model matrix is the row tensor product of its full (n row) marginals. * The index vectors converting the unique row matrices to full marginal matrices are in 'k', an n-row matrix of integers. Conceptually if Xj and kj represent the jth unique row matrix and index vector then the ith row of the corresponding full marginal matrix is Xj[kj[i],], but things are more complicated when each full term matrix is actually the sum of several matrices (summation convention). * To handle the summation convention, each marginal matrix can have several index vectors. 'ks' is an nx by 2 matrix giving the columns of k corresponding to the ith marginal model matrix. Specifically columns ks[i,1]:(ks[i,2]-1) of k are the index vectors for the ith marginal. All marginals corresponding to one term must have the same number of index columns. The full model matrix for the jth term is constucted by summing over q the full model matrices corresponding to the qth index vectors for each of its marginals. * For example the exression for the full model matrix of the jth term is... X^full_j = sum_q prod_i X_{ts[j]+i}[k[,ks[i]+q],] - q runs from 0 to ks[i,2] - ks[i,1] - 1; i runs from 0 to dt[j] - 1. Tensor product terms may have constraint matrices Z, which post multiply the tensor product (typically imposing approximate sum-to-zero constraints). Actually Z is Q with the first column dropped where Q = I - vv'. qc[i]==0 for singleton terms. */ int *pt, *pd,i,j,ri,ci,si,maxp=0,tri,r,c,rb,cb,rt,ct,pa,*tpsr,*tpsur,*tpsc,*tpsuc,ptot, *b,*B,*C,*R,*sb,N,kk,kb,tid=0,nxwx=0,qi=0,*worki,symmetric=1; ptrdiff_t *off,*voff,mmp,q; double *work,*ws,*Cost,*cost,*x0,*x1,*p0,*p1,*p2,x; unsigned long long ht[256]; SM **sm,*SMstack; #ifndef OPENMP_ON *nthreads = 1; #endif if (*nthreads<1) *nthreads = 1; SMinihash(ht); /* check row/col subset arrays... */ if (*nrs <= 0) { if (*ncs > 0) { *nrs = *ncs;rs=cs; } else { for (i=0;i<*nt;i++) rs[i] = cs[i] = i; } } else { if (*ncs>0) symmetric = 0; else { *ncs = *nrs; cs = rs; } } //Rprintf("nt = %d\n",*nt); pt = (int *) CALLOC((size_t)*nt,sizeof(int)); /* the term dimensions */ pd = (int *) CALLOC((size_t)*nt,sizeof(int)); /* storage for last marginal size */ off = (ptrdiff_t *) CALLOC((size_t)*nx+1,sizeof(ptrdiff_t)); /* offsets for X submatrix starts */ voff = (ptrdiff_t *) CALLOC((size_t)*nt+1,sizeof(ptrdiff_t)); /* offsets for v subvectors starts */ tpsr = (int *) CALLOC((size_t)*nt+1,sizeof(int)); /* the term starts, row set */ tpsur = (int *) CALLOC((size_t)*nt+1,sizeof(int)); /* the unconstrained term starts, row set */ tpsc = (int *) CALLOC((size_t)*nt+1,sizeof(int)); /* the term starts, col set */ tpsuc = (int *) CALLOC((size_t)*nt+1,sizeof(int)); /* the unconstrained term starts, col set */ for (q=i=0;i< *nt; i++) { /* work through the terms */ for (j=0;j0) voff[i+1] = voff[i] + pt[i]; else voff[i+1] = voff[i]; /* start of ith v vector */ if (maxp=0) { /* model has AR component*/ for (p0 = w,p1 = w + *n;p0=sb[kb+1]) kb++; /* kb is main block */ rb = R[kb];cb=C[kb]; /* which main block row and column are we at? */ cost[i] = Cost[kb]; B[i] = kb; /* record the main block we are in */ } revsort(cost,b,sb[N]); /* R reverse sort on cost, to re-order b - see R.h*/ q = XWXspace(N,sb,b,B,R,C,k,ks,m,p,pt,pd,*nx,*n,ts,dt,*nt,tri); /* compute the maximum workspace required per thread */ work = (double *)CALLOC((size_t)q * *nthreads,sizeof(double)); /* allocate it */ /* In what follows rb and cb are the whole term row column indices. r and c are the sub blocks within the cross-product between two terms. The sub blocks arise when we have tensor product terms. The cleaner design in which the sub-blocks are dealt with in XWXij does not load balance so well, hence this design.*/ kb=0; #ifdef OPENMP_ON #pragma omp parallel for private(j,kb,kk,r,c,rb,cb,rt,ct,tid,i) num_threads(*nthreads) schedule(dynamic) #endif for (j=0;j= rt - r) { i -= rt - r;r++;} c = i + r; } else { r = i / ct; c = i % ct; } #ifdef OPENMP_ON tid = omp_get_thread_num(); /* needed for providing thread specific work space to XWXij */ #endif XWXijs(XWX+tpsur[rb] + (ptrdiff_t) nxwx * tpsuc[cb],rb,cb,r,c,X,k,ks,m,p,*nx,*n,ts, dt,*nt,w,ws, tri,off,work + tid * q,worki + tid * (ptrdiff_t) qi,nxwx,ht, sm + tid * (ptrdiff_t) *n,SMstack + 3 * tid * (ptrdiff_t) *n ); /* compute r,c block */ /* NOTE: above will write directly to oversized XWX, then have constraints applied post-hoc. */ } /* block loop */ /* now XWX contains the unconstrained X'WX, but the constraints have to be applied to blocks involving tensor products */ for (ri=0;ri < *nrs;ri++) { if (symmetric) ci=ri; else ci = 0; for (;ci< *ncs;ci++) { /* if Xr is tensor, may need to apply constraint */ r = rs[ri];c = cs[ci]; if (dt[r]>1&&qc[r]>0) { /* first term is a tensor with a constraint */ /* col by col form (I-vv')xwx, dropping first row... */ for (j=0;j1&&qc[c]>0) { /* Xc term is a tensor with a constraint */ /* row by row form xwx(I-vv') dropping first col... */ for (j=0;j 1e-4) { break; } if (inter) setTxtProgressBar(prg, i) } if (inter) close(prg) if (rr[1] < -1e-4||rr[2] > 1e-4) { cat("BLAS thread safety problem at iteration",i,"\n") } else cat("No problem encountered in",i,"iterations\n") } ## blas.thread.test rmvn <- function(n,mu,V) { ## generate multivariate normal deviates. e.g. ## V <- matrix(c(2,1,1,2),2,2); mu <- c(1,1);n <- 1000;z <- rmvn(n,mu,V);crossprod(sweep(z,2,colMeans(z)))/n p <- ncol(V) R <- mroot(V,rank=ncol(V)) ## RR' = V if (is.matrix(mu)) { if (ncol(mu)!=p||nrow(mu)!=n) stop("mu dimensions wrong") z <- matrix(rnorm(p*n),n,p)%*%t(R) + mu } else { if (length(mu)!=p) stop("mu dimensions wrong") z <- t(R%*% matrix(rnorm(p*n),p,n) + mu) if (n==1) z <- as.numeric(z) } z } ## rmvn sdiag <- function(A,k=0) { ## extract sub or super diagonal of matrix (k=0 is leading) p <- ncol(A) n <- nrow(A) if (k>p-1||-k > n-1) return() if (k >= 0) { i <- 1:n j <- (k+1):p } else { i <- (-k+1):n j <- 1:p } if (length(i)>length(j)) i <- i[1:length(j)] else j <- j[1:length(i)] ii <- i + (j-1) * n A[ii] } ## sdiag "sdiag<-" <- function(A,k=0,value) { p <- ncol(A) n <- nrow(A) if (k>p-1||-k > n-1) return() if (k >= 0) { i <- 1:n j <- (k+1):p } else { i <- (-k+1):n j <- 1:p } if (length(i)>length(j)) i <- i[1:length(j)] else j <- j[1:length(i)] ii <- i + (j-1) * n A[ii] <- value A } ## "sdiag<-" bandchol <- function(B) { ## obtain R such that R'R = A. Where A is banded matrix contained in R. n <- ncol(B) k <- 0 if (n==nrow(B)) { ## square matrix. Extract the diagonals A <- B*0 for (i in 1:n) { b <- sdiag(B,i-1) if (sum(b!=0)!=0) { k <- i ## largest index of a non-zero band A[i,1:length(b)] <- b } } B <- A[1:k,] } oo <- .C(C_band_chol,B=as.double(B),n=as.integer(n),k=as.integer(nrow(B)),info=as.integer(0)) if (oo$info<0) stop("something wrong with inputs to LAPACK routine") if (oo$info>0) stop("not positive definite") B <- matrix(oo$B,nrow(B),n) if (k>0) { ## was square on entry, so also on exit... A <- A * 0 for (i in 1:k) sdiag(A,i-1) <- B[i,1:(n-i+1)] B <- A } B } ## bandchol trichol <- function(ld,sd) { ## obtain chol factor R of symm tridiag matrix, A, with leading diag ## ld and sub/super diags sd. R'R = A. On exit ld is diag of R and ## sd its super diagonal. n <- length(ld) if (n<2) stop("don't be silly") if (n!=length(sd)+1) stop("sd should have exactly one less entry than ld") oo <- .C(C_tri_chol,ld=as.double(ld),sd=as.double(sd),n=as.integer(n),info=as.integer(0)) if (oo$info<0) stop("something wrong with inputs to LAPACK routine") if (oo$info>0) stop("not positive definite") ld <- sqrt(oo$ld) sd <- oo$sd*ld[1:(n-1)] list(ld=ld,sd=sd) } mgcv.omp <- function() { ## does open MP appear to be available? oo <- .C(C_mgcv_omp,a=as.integer(-1)) if (oo$a==1) TRUE else FALSE } mvn.ll <- function(y,X,beta,dbeta=NULL) { ## to facilitate testing of MVN routine mvn_ll. ## X is a sequence of m model matrices bound columnwise, with m dim attribute lpi ## indicating where the next starts in all cases. ## beta is parameter vector - last m*(m+1)/2 elements are chol factor of precision params. ## y is m by n data matrix. lpi <- attr(X,"lpi")-1;m <- length(lpi) nb <- length(beta) if (is.null(dbeta)) { nsp = 0;dbeta <- dH <- 0 } else { nsp = ncol(dbeta) dH = rep(0,nsp*nb*nb) } oo <- .C(C_mvn_ll,y=as.double(y),X=as.double(X),XX=as.double(crossprod(X)),beta=as.double(beta),n=as.integer(nrow(X)), lpi=as.integer(lpi),m=as.integer(m),ll=as.double(0),lb=as.double(beta*0), lbb=as.double(rep(0,nb*nb)), dbeta = as.double(dbeta), dH = as.double(dH), deriv = as.integer(nsp>0),nsp = as.integer(nsp),nt=as.integer(1)) if (nsp==0) dH <- NULL else { dH <- list();ind <- 1:(nb*nb) for (i in 1:nsp) { dH[[i]] <- matrix(oo$dH[ind],nb,nb) ind <- ind + nb*nb } } list(l=oo$ll,lb=oo$lb,lbb=matrix(oo$lbb,nb,nb),dH=dH) } ## mvn.ll ## discretized covariate routines... XWXd <- function(X,w,k,ks,ts,dt,v,qc,nthreads=1,drop=NULL,ar.stop=-1,ar.row=-1,ar.w=-1,lt=NULL,rt=NULL) { ## Form X'WX given weights in w and X in compressed form in list X. ## each element of X is a (marginal) model submatrix. Full version ## is given by X[[i]][k[,i],] (see below for summation convention). ## list X relates to length(ts) separate ## terms. ith term starts at matrix ts[i] and has dt[i] marginal matrices. ## For summation convention, k[,ks[j,1]:ks[j,2]] gives index columns ## for matrix j, thereby allowing summation over matrix covariates.... ## i.e. for q in ks[j,1]:ks[j,2] sum up X[[j]][k[,q],] ## Terms with several marginals are tensor products and may have ## constraints (if qc[i]>1), stored as a householder vector in v[[i]]. ## check ts and k index start (assumed 1 here) ## if drop is non-NULL it contains index of rows/cols to drop from result ## * lt is array of terms to include in left matrix (assumed in ascending coef index order) ## * rt is array of terms to include in right matrix (assumed in ascending coef index order) ## * if both NULL all are terms are included, if only one is NULL then used for left and right. m <- unlist(lapply(X,nrow));p <- unlist(lapply(X,ncol)) nx <- length(X);nt <- length(ts) n <- length(w);pt <- 0; for (i in 1:nt) pt <- pt + prod(p[ts[i]:(ts[i]+dt[i]-1)]) - as.numeric(qc[i]>0) ## block oriented code... if (is.null(lt)&&is.null(lt)) { #t0 <- system.time( oo <- .C(C_XWXd0,XWX =as.double(rep(0,(pt+nt)^2)),X= as.double(unlist(X)),w=as.double(w), k=as.integer(k-1),ks=as.integer(ks-1),m=as.integer(m),p=as.integer(p), n=as.integer(n), ns=as.integer(nx), ts=as.integer(ts-1), as.integer(dt), nt=as.integer(nt), v = as.double(unlist(v)),qc=as.integer(qc),nthreads=as.integer(nthreads), ar.stop=as.integer(ar.stop-1),ar.row=as.integer(ar.row-1),ar.weights=as.double(ar.w))#) XWX <- if (is.null(drop)) matrix(oo$XWX[1:pt^2],pt,pt) else matrix(oo$XWX[1:pt^2],pt,pt)[-drop,-drop] } else { lpip <- attr(X,"lpip") ## list of coefs for each term rpi <- unlist(lpip[rt]) lpi <- unlist(lpip[lt]) if (is.null(lt)) { lpi <- rpi nrs <- lt <- 0 ncs <- length(rt) } else { nrs <- length(lt) if (is.null(rt)) { rt <- ncs <- 0 rpi <- lpi } else ncs <- length(rt) } #t0 <- system.time( oo <- .C(C_XWXd1,XWX =as.double(rep(0,(pt+nt)^2)),X= as.double(unlist(X)),w=as.double(w), k=as.integer(k-1),ks=as.integer(ks-1),m=as.integer(m),p=as.integer(p), n=as.integer(n), ns=as.integer(nx), ts=as.integer(ts-1), as.integer(dt), nt=as.integer(nt), v = as.double(unlist(v)),qc=as.integer(qc),nthreads=as.integer(nthreads), ar.stop=as.integer(ar.stop-1),ar.row=as.integer(ar.row-1),ar.weights=as.double(ar.w),rs=as.integer(lt-1), cs=as.integer(rt-1),nrs=as.integer(nrs),ncs=as.integer(ncs))#) XWX <- matrix(oo$XWX[1:(length(lpi)*length(rpi))],length(lpi),length(rpi)) if (!is.null(drop)) { ldrop <- which(lpi %in% drop) rdrop <- which(lpi %in% drop) if (length(ldrop)>0||length(rdrop)>0) XWX <- if (length(ldrop==0)) XWX[,-rdrop] else if (length(rdrop)==0) XWX[-ldrop,] else XWX[-ldrop,-rdrop] } } ## old strictly level 2 code for comparison... # t1 <- system.time(ooo <- .C(C_XWXd,XWX =as.double(rep(0,pt^2)),X= as.double(unlist(X)),w=as.double(w), # k=as.integer(k-1),ks=as.integer(ks-1),m=as.integer(m),p=as.integer(p), n=as.integer(n), # ns=as.integer(nx), ts=as.integer(ts-1), as.integer(dt), nt=as.integer(nt), # v = as.double(unlist(v)),qc=as.integer(qc),nthreads=as.integer(nthreads), # ar.stop=as.integer(ar.stop-1),ar.row=as.integer(ar.row-1),ar.weights=as.double(ar.w))) # XWX <- matrix(oo$XWX[1:pt^2],pt,pt) # XWX0 <- matrix(ooo$XWX[1:pt^2],pt,pt) # plot(XWX0,XWX,pch=".",main=range(XWX-XWX0));abline(0,1,col=2) #if (is.null(drop)) matrix(oo$XWX[1:pt^2],pt,pt) else matrix(oo$XWX[1:pt^2],pt,pt)[-drop,-drop] XWX } ## XWXd XWyd <- function(X,w,y,k,ks,ts,dt,v,qc,drop=NULL,ar.stop=-1,ar.row=-1,ar.w=-1,lt=NULL) { ## X'Wy... ## if lt if not NULL then it lists the discrete terms to include (from X) ## returned vector/matrix only includes rows for selected terms m <- unlist(lapply(X,nrow));p <- unlist(lapply(X,ncol)) nx <- length(X);nt <- length(ts) n <- length(w);##pt <- 0; ##for (i in 1:nt) pt <- pt + prod(p[ts[i]:(ts[i]+dt[i]-1)]) - as.numeric(qc[i]>0) if (is.null(lt)) { pt <- 0 for (i in 1:nt) pt <- pt + prod(p[ts[i]:(ts[i]+dt[i]-1)]) - as.numeric(qc[i]>0) lt <- 1:nt } else { lpip <- attr(X,"lpip") ## list of coefs for each term lpi <- unlist(lpip[lt]) ## coefs corresponding to terms selected by lt if (!is.null(drop)) drop <- which(lpi %in% drop) ## rebase drop pt <- length(lpi) } cy <- if (is.matrix(y)) ncol(y) else 1 oo <- .C(C_XWyd,XWy=rep(0,pt*cy),y=as.double(y),X=as.double(unlist(X)),w=as.double(w),k=as.integer(k-1), ks=as.integer(ks-1), m=as.integer(m),p=as.integer(p),n=as.integer(n),cy=as.integer(cy), nx=as.integer(nx), ts=as.integer(ts-1), dt=as.integer(dt),nt=as.integer(nt),v=as.double(unlist(v)),qc=as.integer(qc), ar.stop=as.integer(ar.stop-1),ar.row=as.integer(ar.row-1),ar.weights=as.double(ar.w), cs=as.integer(lt-1),ncs=as.integer(length(lt))) if (cy>1) XWy <- if (is.null(drop)) matrix(oo$XWy,pt,cy) else matrix(oo$XWy,pt,cy)[-drop,] else XWy <- if (is.null(drop)) oo$XWy else oo$XWy[-drop] XWy } ## XWyd Xbd <- function(X,beta,k,ks,ts,dt,v,qc,drop=NULL,lt=NULL) { ## note that drop may contain the index of columns of X to drop before multiplying by beta. ## equivalently we can insert zero elements into beta in the appropriate places. ## if lt if not NULL then it lists the discrete terms to include (from X) n <- if (is.matrix(k)) nrow(k) else length(k) ## number of data m <- unlist(lapply(X,nrow)) ## number of rows in each discrete model matrix p <- unlist(lapply(X,ncol)) ## number of cols in each discrete model matrix nx <- length(X) ## number of model matrices nt <- length(ts) ## number of terms if (!is.null(drop)) { b <- if (is.matrix(beta)) matrix(0,nrow(beta)+length(drop),ncol(beta)) else rep(0,length(beta)+length(drop)) if (is.matrix(beta)) b[-drop,] <- beta else b[-drop] <- beta beta <- b } if (is.null(lt)) { lt <- 1:nt } lpip <- attr(X,"lpip") if (!is.null(lpip)) { ## then X list may not be in coef order... lpip <- unlist(lpip[lt]) beta <- if (is.matrix(beta)) beta[lpip,] else beta[lpip] ## select params required in correct order } bc <- if (is.matrix(beta)) ncol(beta) else 1 ## number of columns in beta oo <- .C(C_Xbd,f=as.double(rep(0,n*bc)),beta=as.double(beta),X=as.double(unlist(X)),k=as.integer(k-1), ks = as.integer(ks-1), m=as.integer(m),p=as.integer(p), n=as.integer(n), nx=as.integer(nx), ts=as.integer(ts-1), as.integer(dt), as.integer(nt),as.double(unlist(v)),as.integer(qc),as.integer(bc),as.integer(lt-1),as.integer(length(lt))) if (is.matrix(beta)) matrix(oo$f,n,bc) else oo$f } ## Xbd diagXVXd <- function(X,V,k,ks,ts,dt,v,qc,drop=NULL,nthreads=1,lt=NULL,rt=NULL) { ## discrete computation of diag(XVX') ## BUGS: 1. X list may not be in coefficient order - in which case V has to be re-ordered according to lpip ## attribute of X (if non-null) ## 2. It doesn't seem to work if terms are dropped, not from end, although Xbd seems to work in these cases. n <- if (is.matrix(k)) nrow(k) else length(k) m <- unlist(lapply(X,nrow));p <- unlist(lapply(X,ncol)) nx <- length(X);nt <- length(ts) if (!is.null(drop)) { pv <- ncol(V)+length(drop) V0 <- matrix(0,pv,pv) V0[-drop,-drop] <- V V <- V0;rm(V0) } else pv <- ncol(V) if (is.null(lt)) lt <- 1:nt if (is.null(rt)) rt <- 1:nt lpip <- attr(X,"lpip") if (!is.null(lpip)) { ## then X list may not be in coef order... lpi <- unlist(lpip[lt]) rpi <- unlist(lpip[rt]) V <- V[lpi,rpi] ## select part of V required required in correct order } oo <- .C(C_diagXVXt,diag=as.double(rep(0,n)),V=as.double(V),X=as.double(unlist(X)),k=as.integer(k-1), ks=as.integer(ks-1),m=as.integer(m),p=as.integer(p), n=as.integer(n), nx=as.integer(nx), ts=as.integer(ts-1), as.integer(dt), as.integer(nt),as.double(unlist(v)),as.integer(qc),as.integer(nrow(V)),as.integer(ncol(V)), as.integer(nthreads),as.integer(lt-1),as.integer(length(lt)),as.integer(rt-1),as.integer(length(rt))) oo$diag } ## diagXVXd dchol <- function(dA,R) { ## if dA contains matrix dA/dx where R is chol factor s.t. R'R = A ## then this routine returns dR/dx... p <- ncol(R) oo <- .C(C_dchol,dA=as.double(dA),R=as.double(R),dR=as.double(R*0),p=as.integer(ncol(R))) return(matrix(oo$dR,p,p)) } ## dchol choldrop <- function(R,k) { ## routine to update Cholesky factor R of A on dropping row/col k of A. ## R can be upper triangular, in which case (R'R=A) or lower triangular in ## which case RR'=A... n <- as.integer(ncol(R)) k1 <- as.integer(k-1) ut <- as.integer(as.numeric(R[1,2]!=0)) if (k<1||k>n) return(R) Rup <- matrix(0,n-1,n-1) #oo <- .C(C_chol_down,R=as.double(R),Rup=as.double(Rup),n=as.integer(n),k=as.integer(k-1),ut=as.integer(ut)) .Call(C_mgcv_chol_down,R,Rup,n,k1,ut) #matrix(oo$Rup,n-1,n-1) Rup } ## choldrop cholup <- function(R,u,up=TRUE) { ## routine to update Cholesky factor R to the factor of R'R + uu' (up == TRUE) ## or R'R - uu' (up=FALSE). n <- as.integer(ncol(R)) up <- as.integer(up) eps <- as.double(.Machine$double.eps) R1 <- R * 1.0 .Call(C_mgcv_chol_up,R1,u,n,up,eps) if (up==0) if ((n>1 && R1[2,1] < -1)||(n==1&&u[1]>R[1])) stop("update not positive definite") R1 } ## cholup vcorr <- function(dR,Vr,trans=TRUE) { ## Suppose b = sum_k op(dR[[k]])%*%z*r_k, z ~ N(0,Ip), r ~ N(0,Vr). vcorr returns cov(b). ## dR is a list of p by p matrices. 'op' is 't' if trans=TRUE and I() otherwise. p <- ncol(dR[[1]]) M <- if (trans) ncol(Vr) else -ncol(Vr) ## sign signals transpose or not to C code if (abs(M)!=length(dR)) stop("internal error in vcorr, please report to simon.wood@r-project.org") oo <- .C(C_vcorr,dR=as.double(unlist(dR)),Vr=as.double(Vr),Vb=as.double(rep(0,p*p)), p=as.integer(p),M=as.integer(M)) return(matrix(oo$Vb,p,p)) } ## vcorr pinv <- function(X,svd=FALSE) { ## a pseudoinverse for n by p, n>p matrices qrx <- qr(X,tol=0,LAPACK=TRUE) R <- qr.R(qrx);Q <- qr.Q(qrx) rr <- Rrank(R) if (svd&&rr=b) -> ii;a[ii]+(b[ii]-1)*n->ii ## lower ## n <- 4000;a <- rep(1:n,n);b <- rep(1:n,each=n);which(a<=b) -> ii;a[ii]+(b[ii]-1)*n->ii ## upper ## library(mgcv);R <- matrix(0,n,n);R[ii] <- runif(n*(n+1)/2) ## Note: A[a-b<=0] <- 0 zeroes upper triangle ## system.time(A <- mgcv:::pRRt(R,2)) ## system.time(A2 <- tcrossprod(R));range(A-A2) n <- nrow(R) A <- matrix(0,n,n) .Call(C_mgcv_RPPt,A,R,nt) A } block.reorder <- function(x,n.blocks=1,reverse=FALSE) { ## takes a matrix x divides it into n.blocks row-wise blocks, and re-orders ## so that the blocks are stored one after the other. ## e.g. library(mgcv); x <- matrix(1:18,6,3);xb <- mgcv:::block.reorder(x,2) ## x;xb;mgcv:::block.reorder(xb,2,TRUE) r = nrow(x);cols = ncol(x); if (n.blocks <= 1) return(x); if (r%%n.blocks) { nb = ceiling(r/n.blocks) } else nb = r/n.blocks; oo <- .C(C_row_block_reorder,x=as.double(x),as.integer(r),as.integer(cols), as.integer(nb),as.integer(reverse)); matrix(oo$x,r,cols) } ## block.reorder pqr <- function(x,nt=1) { ## parallel QR decomposition, using openMP in C, and up to nt threads (only if worthwhile) ## library(mgcv);n <- 20;p<-4;X <- matrix(runif(n*p),n,p);er <- mgcv:::pqr(X,nt=2) ## range(mgcv:::pqr.qy(er,mgcv:::pqr.R(er))-X[,er$pivot]) x.c <- ncol(x);r <- nrow(x) oo <- .C(C_mgcv_pqr,x=as.double(c(x,rep(0,nt*x.c^2))),as.integer(r),as.integer(x.c), pivot=as.integer(rep(0,x.c)), tau=as.double(rep(0,(nt+1)*x.c)),as.integer(nt)) list(x=oo$x,r=r,c=x.c,tau=oo$tau,pivot=oo$pivot+1,nt=nt) } pqr.R <- function(x) { ## x is an object returned by pqr. This extracts the R factor... ## e.g. as pqr then... ## R <- mgcv:::pqr.R(er); R0 <- qr.R(qr(X,tol=0)) ## svd(R)$d;svd(R0)$d oo <- .C(C_getRpqr,R=as.double(rep(0,x$c^2)),as.double(x$x),as.integer(x$r),as.integer(x$c), as.integer(x$c),as.integer(x$nt)) matrix(oo$R,x$c,x$c) } pqr.qy <- function(x,a,tr=FALSE) { ## x contains a parallel QR decomp as computed by pqr. a is a matrix. computes ## Qa or Q'a depending on tr. ## e.g. as above, then... ## a <- diag(p);Q <- mgcv:::pqr.qy(er,a);crossprod(Q) ## X[,er$pivot+1];Q%*%R ## Qt <- mgcv:::pqr.qy(er,diag(n),TRUE);Qt%*%t(Qt);range(Q-t(Qt)) ## Q <- qr.Q(qr(X,tol=0));z <- runif(n);y0<-t(Q)%*%z ## mgcv:::pqr.qy(er,z,TRUE)->y ## z <- runif(p);y0<-Q%*%z;mgcv:::pqr.qy(er,z)->y if (is.matrix(a)) a.c <- ncol(a) else a.c <- 1 if (tr) { if (is.matrix(a)) { if (nrow(a) != x$r) stop("a has wrong number of rows") } else if (length(a) != x$r) stop("a has wrong number of rows") } else { if (is.matrix(a)) { if (nrow(a) != x$c) stop("a has wrong number of rows") } else if (length(a) != x$c) stop("a has wrong number of rows") a <- c(a,rep(0,a.c*(x$r-x$c))) } oo <- .C(C_mgcv_pqrqy,a=as.double(a),as.double(x$x),as.double(x$tau),as.integer(x$r), as.integer(x$c),as.integer(a.c),as.integer(tr),as.integer(x$nt)) if (tr) return(matrix(oo$a[1:(a.c*x$c)],x$c,a.c)) else return(matrix(oo$a,x$r,a.c)) } pmmult <- function(A,B,tA=FALSE,tB=FALSE,nt=1) { ## parallel matrix multiplication (not for use on vectors or thin matrices) ## library(mgcv);r <- 10;c <- 5;n <- 8 ## A <- matrix(runif(r*n),r,n);B <- matrix(runif(n*c),n,c);range(A%*%B-mgcv:::pmmult(A,B,nt=1)) ## A <- matrix(runif(r*n),n,r);B <- matrix(runif(n*c),n,c);range(t(A)%*%B-mgcv:::pmmult(A,B,TRUE,FALSE,nt=1)) ## A <- matrix(runif(r*n),n,r);B <- matrix(runif(n*c),c,n);range(t(A)%*%t(B)-mgcv:::pmmult(A,B,TRUE,TRUE,nt=1)) ## A <- matrix(runif(r*n),r,n);B <- matrix(runif(n*c),c,n);range(A%*%t(B)-mgcv:::pmmult(A,B,FALSE,TRUE,nt=1)) if (tA) { n = nrow(A);r = ncol(A)} else {n = ncol(A);r = nrow(A)} if (tB) { c = nrow(B)} else {c = ncol(B)} C <- rep(0,r * c) oo <- .C(C_mgcv_pmmult,C=as.double(C),as.double(A),as.double(B),as.integer(tA),as.integer(tB),as.integer(r), as.integer(c),as.integer(n),as.integer(nt)); matrix(oo$C,r,c) }mgcv/R/coxph.r0000644000176200001440000003156413445100536012725 0ustar liggesusers## (c) Simon N. Wood (2013, 2014) coxph model general family. ## Released under GPL2 ... cox.ph <- function (link = "identity") { ## Extended family object for Cox PH. linktemp <- substitute(link) if (!is.character(linktemp)) linktemp <- deparse(linktemp) if (linktemp %in% c("identity")) stats <- make.link(linktemp) else if (is.character(link)) { stats <- make.link(link) linktemp <- link } else { if (inherits(link, "link-glm")) { stats <- link if (!is.null(stats$name)) linktemp <- stats$name } else stop(linktemp, " link not available for coxph family; available link is \"identity\" ") } env <- new.env(parent = .GlobalEnv) validmu <- function(mu) all(is.finite(mu)) ## initialization is tough here... need data frame in reverse time order, ## and intercept removed from X... preinitialize <- function(G) { ## G is a gam pre-fit object. Pre-initialize can manipulate some of its ## elements, returning a named list of the modified ones. ## sort y (time) into decending order, and ## re-order weights and rows of X accordingly ## matrix y has strat as second column G$family$data <- list() y.order <- if (is.matrix(G$y)) order(G$y[,2],G$y[,1],decreasing=TRUE) else order(G$y,decreasing=TRUE) G$family$data$y.order <- y.order G$y <- if (is.matrix(G$y)) G$y[y.order,] else G$y[y.order] attrX <- attributes(G$X) G$X <- G$X[y.order,,drop=FALSE] attributes(G$X) <- attrX G$w <- G$w[y.order] G$offset <- G$offset[y.order] list(family=G$family,y=G$y,X=G$X,w=G$w,offset=G$offset) } ## preinitialize postproc <- expression({ ## code to evaluate in estimate.gam, to do with data ordering and ## baseline hazard estimation... ## first get the estimated hazard and prediction information... G$X <- Sl.initial.repara(G$Sl,G$X,inverse=TRUE,cov=FALSE,both.sides=FALSE) object$family$data <- G$family$hazard(G$y,G$X,object$coefficients,G$w,G$offset) rumblefish <- G$family$hazard(G$y,matrix(0,nrow(G$X),0),object$coefficients,G$w) s0.base <- exp(-rumblefish$h[rumblefish$r]) ## no model baseline survival s0.base[s0.base >= 1] <- 1 - 2*.Machine$double.eps ## avoid NA later ## now put the survivor function in object$fitted object$fitted.values <- exp(-object$family$data$h[object$family$data$r]*exp(object$linear.predictors)) ## compute the null deviance... s.base <- exp(-object$family$data$h[object$family$data$r]) ## baseline survival s.base[s.base >= 1] <- 1 - 2*.Machine$double.eps ## avoid NA later object$null.deviance <- ## sum of squares of null deviance residuals 2*sum(abs((object$prior.weights + log(s0.base) + object$prior.weights*(log(-log(s0.base)))))) ## and undo the re-ordering... y.order <- G$family$data$y.order object$linear.predictors[y.order] <- object$linear.predictors object$fitted.values[y.order] <- object$fitted.values if (is.matrix(object$y)) object$y[y.order,] <- object$y else object$y[y.order] <- object$y object$prior.weights[y.order] <- object$prior.weights }) initialize <- expression({ n <- rep(1, nobs) if (is.null(start)) start <- rep(0,ncol(x)) }) hazard <- function(y, X,beta,wt,offset=0) { ## get the baseline hazard function information, given times in descending order in y ## model matrix (same ordering) in X, coefs in beta and censoring in wt (1 = death, 0 ## = censoring) if (is.matrix(y)) { ## first column is time, second is *numeric* code indicating strata strat <- y[,2] ## stratification variable y <- y[,1] ## event times strat.lev <- unique(strat) ns <- length(strat.lev) ## number of strata nt <- 0;for (i in 1:ns) nt <- nt + length(unique(y[strat==strat.lev[i]])) tr.strat <- tr <- rep(0,nt) k <- 1 for (i in 1:ns) { tr0 <- unique(y[strat==strat.lev[i]]) ind <- k:(k+length(tr0)-1);k <- k + length(tr0) tr[ind] <- tr0 ## unique times at this stratification level tr.strat[ind] <- strat.lev[i] ## stratication index for tr,h,q,km and a } } else { ns <- 1 tr <- unique(y) nt <- length(tr) } p <- ncol(X) eta <- as.double(X%*%beta) + offset if (ns==1) { r <- match(y,tr) oo <- .C("coxpp",eta,A=as.double(X),as.integer(r),d=as.integer(wt), h=as.double(rep(0,nt)),q=as.double(rep(0,nt)),km=as.double(rep(0,nt)), n=as.integer(nrow(X)),p=as.integer(ncol(X)), nt=as.integer(nt),PACKAGE="mgcv") return(list(tr=tr,h=oo$h,q=oo$q,a=matrix(oo$A[1:(p*nt)],p,nt),nt=nt,r=r,km=oo$km)) } else { r <- y*0;a <- matrix(0,p,nt) h <- q <- km <- rep(0,nt) for (i in 1:ns) { ## loop over strata ind <- which(strat==strat.lev[i]) trind <- which(tr.strat==strat.lev[i]) r0 <- match(y[ind],tr[trind]) nti <- length(trind) etai <- if (p>0) eta[ind] else eta oo <- .C("coxpp",etai,A=as.double(X[ind,]),as.integer(r0),d=as.integer(wt[ind]), h=as.double(rep(0,nti)),q=as.double(rep(0,nti)),km=as.double(rep(0,nti)), n=as.integer(length(ind)),p=as.integer(p), nt=as.integer(nti),PACKAGE="mgcv") ## now paste all this into return fields h[trind] <- oo$h q[trind] <- oo$q km[trind] <- oo$km r[ind] <- r0 ## note that indexing is to subsetted tr a[,trind] <- matrix(oo$A[1:(p*nti)],p,nti) } return(list(tr=tr,h=h,q=q,a=a,nt=nt,r=r,km=km,strat=strat,tr.strat=tr.strat)) } } ## hazard residuals <- function(object,type=c("deviance","martingale")) { type <- match.arg(type) w <- object$prior.weights;log.s <- log(object$fitted.values) res <- w + log.s ## martingale residuals if (type=="deviance") { log.s[log.s>-1e-50] <- -1e-50 res <- sign(res)*sqrt(-2*(res + w * log(-log.s))) } res } ## residuals predict <- function(family,se=FALSE,eta=NULL,y=NULL, X=NULL,beta=NULL,off=NULL,Vb=NULL) { ## prediction function. if (is.matrix(y)) { strat <- y[,2];y <- y[,1] if (is.null(family$data$strat)) stop("something wrong with stratified prediction") ii <- order(strat,y,decreasing=TRUE) ## C code expects non-increasing strat <- strat[ii] } else { ii <- order(y,decreasing=TRUE) ## C code expects non-increasing strat <- NULL } if (sum(is.na(y))>0) stop("NA times supplied for cox.ph prediction") X <- X[ii,,drop=FALSE];y <- y[ii]; n <- nrow(X) if (is.null(off)) off <- rep(0,n) if (is.null(strat)) { oo <- .C("coxpred",as.double(X),t=as.double(y),as.double(beta),as.double(off),as.double(Vb), a=as.double(family$data$a),h=as.double(family$data$h),q=as.double(family$data$q), tr = as.double(family$data$tr), n=as.integer(n),p=as.integer(ncol(X)),nt = as.integer(family$data$nt), s=as.double(rep(0,n)),se=as.double(rep(0,n)),PACKAGE="mgcv") s <- sef <- oo$s s[ii] <- oo$s sef[ii] <- oo$se } else { ## stratified fit, need to unravel everything by strata pstrata <- unique(strat) ns <- length(pstrata) p <- ncol(X) s <- sef <- rep(0,length(y)) for (i in 1:ns) { ind <- which(strat==pstrata[i]) ## prediction data index trind <- which(family$data$tr.strat == pstrata[i]) n <- length(ind) oo <- .C("coxpred",as.double(X[ind,]),t=as.double(y[ind]),as.double(beta),as.double(off),as.double(Vb), a=as.double(family$data$a[,trind]),h=as.double(family$data$h[trind]),q=as.double(family$data$q[trind]), tr = as.double(family$data$tr[trind]), n=as.integer(n),p=as.integer(p),nt = as.integer(length(trind)), s=as.double(rep(0,n)),se=as.double(rep(0,n)),PACKAGE="mgcv") s[ind] <- oo$s sef[ind] <- oo$se } ## strata loop s[ii] <- s sef[ii] <- sef } if (se) return(list(fit=s,se.fit=sef)) else return(list(fit=s)) } ## predict rd <- qf <- NULL ## these functions currently undefined for Cox PH ll <- function(y,X,coef,wt,family,offset=NULL,deriv=0,d1b=0,d2b=0,Hp=NULL,rank=0,fh=NULL,D=NULL) { ## function defining the Cox model log lik. ## Calls C code "coxlpl" ## deriv codes: 0 - evaluate the log likelihood ## 1 - evaluate the grad and Hessian, H, of log lik w.r.t. coefs (beta) ## 2 - evaluate tr(Hp^{-1}dH/drho) - Hp^{-1} must be supplied in fh ## and db/drho in d1b. Not clear if a more efficient algorithm exists for this. ## 3 - evaluate d1H =dH/drho given db/drho in d1b ## (2 is for evaluation of diagonal only) ## 4 - given d1b and d2b evaluate trHid2H= tr(Hp^{-1}d2H/drhodrho') ## Hp is the preconditioned penalized Hessian of the log lik ## which is of rank 'rank'. ## fh is a factorization of Hp - either its eigen decomposition ## or its Choleski factor ## D is the diagonal pre-conditioning matrix used to obtain Hp ## if Hr is the raw Hp then Hp = D*t(D*Hr) if (is.matrix(y)) { ## first column is time, second is *numeric* code indicating strata strat <- y[,2] ## stratification variable y <- y[,1] ## event times strat.lev <- unique(strat) ns <- length(strat.lev) ## number of strata } else ns <- 1 p <- ncol(X) deriv <- deriv - 1 mu <- X%*%coef + offset g <- rep(0,p);H <- rep(0,p*p) if (deriv > 0) { M <- ncol(d1b) d1H <- if (deriv==1) rep(0,p*M) else rep(0,p*p*M) } else M <- d1Ho <- d1H <- 0 if (deriv > 2) { d2H <- rep(0,p*M*(M+1)/2) if (is.list(fh)) { ev <- fh } else { ## need to compute eigen here ev <- eigen(Hp,symmetric=TRUE) if (rank < p) ev$values[(rank+1):p] <- 0 } X <- X%*%(ev$vectors*D) d1b <- t(ev$vectors)%*%(d1b/D); d2b <- t(ev$vectors)%*%(d2b/D) } else d2Ho <- trHid2H <- d2H <- 0 for (j in 1:ns) { ## loop over strata ind <- if (ns==1) 1:length(y) else which(strat==strat.lev[j]) ## index for points in this strata tr <- unique(y[ind]) r <- match(y[ind],tr) ## note that the following call can not use .C(C_coxlpl,...) since the ll ## function is not in the mgcv namespace. cderiv <- if (deriv==1) 2 else deriv ## reset 1 to 2 to get whole d1H returned oo <- .C("coxlpl",as.double(mu[ind]),as.double(X[ind,]),as.integer(r),as.integer(wt[ind]), as.double(tr),n=as.integer(length(y[ind])),p=as.integer(p),nt=as.integer(length(tr)), lp=as.double(0),g=as.double(g),H=as.double(H), d1b=as.double(d1b),d1H=as.double(d1H),d2b=as.double(d2b),d2H=as.double(d2H), n.sp=as.integer(M),deriv=as.integer(cderiv),PACKAGE="mgcv"); if (j==1) { lp <- oo$lp lb <- oo$g lbb <- matrix(oo$H,p,p) } else { ## accumulating over strata lp <- oo$lp + lp lb <- oo$g + lb lbb <- matrix(oo$H,p,p) + lbb } if (deriv==1) { #d1Ho <- matrix(oo$d1H,p,M) + if (j==1) 0 else d1Ho ind <- 1:(p^2) if (j==1) d1Ho <- rep(0,M) for (i in 1:M) { d1Ho[i] <- d1Ho[i] + sum(fh*matrix(oo$d1H[ind],p,p)) ## tr(Hp^{-1}dH/drho_i) ind <- ind + p^2 } } else if (deriv>1) { ind <- 1:(p^2) if (j==1) d1Ho <- list() for (i in 1:M) { d1Ho[[i]] <- if (j==1) matrix(oo$d1H[ind],p,p) else matrix(oo$d1H[ind],p,p) + d1Ho[[i]] ind <- ind + p^2 } } if (deriv>2) { d2Ho <- if (j==1) matrix(oo$d2H,p,M*(M+1)/2) else d2Ho + matrix(oo$d2H,p,M*(M+1)/2) } } ## strata loop if (deriv>2) { d <- ev$values d[d>0] <- 1/d[d>0];d[d<=0] <- 0 trHid2H <- colSums(d2Ho*d) } assign(".log.partial.likelihood", oo$lp, envir=environment(sys.function())) list(l=lp,lb=lb,lbb=lbb,d1H=d1Ho,d2H=d2Ho,trHid2H=trHid2H) } ## ll # environment(dev.resids) <- environment(aic) <- environment(getTheta) <- # environment(rd)<- environment(qf)<- environment(variance) <- environment(putTheta) #environment(aic) <- environment(ll) <- env structure(list(family = "Cox PH", link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, ll=ll, ## aic = aic, mu.eta = stats$mu.eta, initialize = initialize,preinitialize=preinitialize,postproc=postproc, hazard=hazard,predict=predict,residuals=residuals, validmu = validmu, valideta = stats$valideta, rd=rd,qf=qf,drop.intercept = TRUE, ls=1, ## signal ls not needed available.derivs = 2 ## can use full Newton here ), class = c("general.family","extended.family","family")) } ## cox.ph mgcv/R/fast-REML.r0000644000176200001440000020312213477524343013300 0ustar liggesusers## code for fast REML computation. key feature is that first and ## second derivatives come at no increase in leading order ## computational cost, relative to evaluation! ## (c) Simon N. Wood, 2010-2019 singleStrans <- function(S,rank=NULL) { ## transform single penalty matrix to partial identity using Cholesky ## t(D)%*%S%*%D transforms to a partial identity (rank rank) Ri <- R <- suppressWarnings(chol(S,pivot=TRUE)) k <- ncol(S) if (is.null(rank)) { rank <- Rrank(R) normS <- norm(S) while (rank>1&&max(abs(crossprod(R[1:(rank-1),rank:k,drop=FALSE])-S[rank:k,rank:k,drop=FALSE])) <.Machine$double.eps^.75*normS) rank <- rank - 1 } piv <- attr(R,"pivot") if (rank1) for (i in 2:m) St <- St + S[[i]]/norm(S[[i]]) R <- suppressWarnings(chol(St,pivot=TRUE)) p <- nrow(St) if (is.null(rank)) { rank <- Rrank(R) normS <- norm(St) ## direct check that rank not over-estimated while (rank>1&&max(abs(crossprod(R[1:(rank-1),rank:p,drop=FALSE])-St[rank:p,rank:p,drop=FALSE])) <.Machine$double.eps^.75*normS) rank <- rank - 1 } piv <- attr(R,"pivot") ipiv <- piv; ipiv[piv] <- 1:p if (rank==p) { ## nothing to do return(list(S=S,T=diag(p),Ti=diag(p))) } ind <- (rank+1):p R[ind,ind] <- diag(length(ind)) # S1 <- S # save original for checking for (i in 1:m) { S[[i]] <- forwardsolve(t(R),t(forwardsolve(t(R),S[[i]][piv,piv])))[1:rank,1:rank] S[[i]] <- (S[[i]] + t(S[[i]]))*.5 } T <- backsolve(R,diag(p))[ipiv,] #range((t(T)%*%S1[[1]]%*%T)[1:rank,1:rank]-S[[1]]) #range(T%*%R[,ipiv]-diag(p)) ## So T will map original S to transformed S, and R[,ipiv] is inverse transform. list(S=S,T=T,Ti=R[,ipiv],rank=rank) } ## iniStrans Sl.setup <- function(G,cholesky=FALSE) { ## Sets up a list representing a block diagonal penalty matrix. ## from the object produced by `gam.setup'. ## Uses only pivoted Cholesky if cholesky==TRUE. ## Return object is a list, Sl, with an element for each block. ## For block, b, Sl[[b]] is a list with the following elements ## * repara - should re-parameterization be applied to model matrix etc ## usually false if non-linear in coefs ## * start, stop: start:stop indexes the parameters of this block ## * S a list of penalty matrices for the block (dim = stop-start+1) ## - If length(S)==1 then this will be an identity penalty. ## - Otherwise it is a multiple penalty, and an rS list of square ## root penalty matrices will be added. S (if repara) and rS (always) ## will be projected into range space of total penalty matrix. ## If cholesky==TRUE then rS contains the projected S if !repara and otherwise ## rS not returned (since S contains same thing). ## * rS sqrt penalty matrices if it's a multiple penalty and cholesky==FALSE. ## projected penalty if cholesky==TRUE and !repara. NULL otherwise. ## * D a reparameterization matrix for the block ## - Applies to cols/params from start:stop. ## - If numeric then X[,start:stop]%*%diag(D) is repara X[,start:stop], ## b.orig = D*b.repara ## - If matrix then X[,start:stop]%*%D is repara X[,start:stop], ## b.orig = D%*%b.repara ## * Di is inverse of D, but is only supplied if D is not orthogonal, or ## diagonal. ## The penalties in Sl are in the same order as those in G ## Also returns attribute "E" a square root of the well scaled total ## penalty, suitable for rank deficiency testing, and attribute "lambda" ## the corresponding smoothing parameters. ##if (!is.null(G$H)) stop("paraPen min sp not supported") Sl <- list() b <- 1 ## block counter if (G$n.paraPen) { ## Have to proccess paraPen stuff first off <- unique(G$off[1:G$n.paraPen]) ## unique offset lists relating to paraPen for (i in 1:length(off)) { ## loop over blocks ind <- (1:G$n.paraPen)[G$off[1:G$n.paraPen]%in%off[i]] ## terms in same block if (length(ind)>1) { ## additive block nr <- 0;for (k in 1:length(ind)) nr <- max(nr,nrow(G$S[[ind[k]]])) ## get block size ## now fill Sl[[b]]$S, padding out any penalties that are not "full size" Sl[[b]] <- list() Sl[[b]]$S <- list() St <- matrix(0,nr,nr) ## accumulate a total matrix for rank determination for (k in 1:length(ind)) { ## work through all penalties for this block nk <- nrow(G$S[[ind[k]]]) if (nr>nk) { ## have to pad out this one Sl[[b]]$S[[k]] <- matrix(0,nr,nr) Sl[[b]]$S[[k]][1:nk,1:nk] <- G$S[[ind[k]]] } else Sl[[b]]$S[[k]] <- G$S[[ind[[k]]]] St <- St + Sl[[b]]$S[[k]] } Sl[[b]]$start <- off[ind[1]] Sl[[b]]$stop <- Sl[[b]]$start + nr - 1 Sl[[b]]$lambda <- rep(1,length(ind)) ## dummy at this stage Sl[[b]]$repara <- FALSE } else { ## singleton Sl[[b]] <- list(start=off[ind], stop=off[ind]+nrow(G$S[[ind]])-1, rank=G$rank[ind],S=list(G$S[[ind]])) Sl[[b]]$S <- list(G$S[[ind]]) Sl[[b]]$lambda <- 1 ## dummy at this stage Sl[[b]]$repara <- TRUE } ## finished singleton b <- b + 1 } ## finished this block } ## finished paraPen ## now work through the smooths.... if (length(G$smooth)) for (i in 1:length(G$smooth)) { if (!is.null(G$smooth[[i]]$fixed)&&G$smooth[[i]]$fixed) m <- 0 else m <- length(G$smooth[[i]]$S) if (m>0) { Sl[[b]] <- list() Sl[[b]]$start <- G$smooth[[i]]$first.para Sl[[b]]$stop <- G$smooth[[i]]$last.para ## if the smooth has a g.index field it indicates non-linear params, ## in which case re-parameterization will usually break the model! Sl[[b]]$repara <- if (is.null(G$smooth[[i]]$g.index)) TRUE else FALSE } if (m==0) {} else ## fixed block if (m==1) { ## singleton Sl[[b]]$rank <- G$smooth[[i]]$rank Sl[[b]]$S <- G$smooth[[i]]$S Sl[[b]]$lambda <- 1 b <- b + 1 } else { ## additive block... ## first test whether block can *easily* be split up into singletons ## easily here means no overlap in penalties Sl[[b]]$S <- G$smooth[[i]]$S Sl[[b]]$lambda <- rep(1,m) nb <- nrow(Sl[[b]]$S[[1]]) sbdiag <- sbStart <- sbStop <- rep(NA,m) ut <- upper.tri(Sl[[b]]$S[[1]],diag=FALSE) ## overlap testing requires the block ranges for (j in 1:m) { ## get block range for each S[[j]] sbdiag[j] <- sum(abs(Sl[[b]]$S[[j]][ut]))==0 ## is penalty diagonal?? ir <- range((1:nb)[rowSums(abs(Sl[[b]]$S[[j]]))>0]) sbStart[j] <- ir[1];sbStop[j] <- ir[2] ## individual ranges } split.ok <- TRUE for (j in 1:m) { ## test for overlap itot <- rep(FALSE,nb) if (all(sbdiag)) { ## it's all diagonal - can allow interleaving for (k in 1:m) if (j!=k) itot[diag(Sl[[b]]$S[[k]])!=0] <- TRUE if (sum(itot[diag(Sl[[b]]$S[[j]])!=0])>0) { ## no good, some overlap detected split.ok <- FALSE; break } } else { ## not diagonal - really need on overlapping blocks for (k in 1:m) if (j!=k) itot[sbStart[k]:sbStop[k]] <- TRUE if (sum(itot[sbStart[j]:sbStop[j]])>0) { ## no good, some overlap detected split.ok <- FALSE; break } } } if (split.ok) { ## can split this block into m separate singleton blocks for (j in 1:m) { Sl[[b]] <- list() ind <- sbStart[j]:sbStop[j] Sl[[b]]$S <- list(G$smooth[[i]]$S[[j]][ind,ind,drop=FALSE]) Sl[[b]]$start <- G$smooth[[i]]$first.para + sbStart[j]-1 Sl[[b]]$stop <- G$smooth[[i]]$first.para + sbStop[j]-1 Sl[[b]]$rank <- G$smooth[[i]]$rank[j] Sl[[b]]$lambda <- 1 ## dummy here Sl[[b]]$repara <- TRUE ## signals ok to linearly reparameterize if (!is.null(G$smooth[[i]]$g.index)) { ## then some parameters are non-linear - can't re-param if (any(G$smooth[[i]]$g.index[ind])) Sl[[b]]$repara <- FALSE } b <- b + 1 } } else { ## not possible to split Sl[[b]]$S <- G$smooth[[i]]$S b <- b + 1 ## next block!! } ## additive block finished } ## additive block finished } ## At this stage Sl contains the penalties, identified as singletons or ## multiple S blocks. Now the blocks need re-parameterization applied. ## Singletons need to be transformed to identity penalties, while ## multiples need to be projected into total penalty range space. if (length(Sl)==0) return(Sl) ## nothing to do np <- ncol(G$X) E <- matrix(0,np,np) ## well scaled square root penalty lambda <- rep(0,0) for (b in 1:length(Sl)) { ## once more into the blocks, dear friends... if (length(Sl[[b]]$S)==1) { ## then we have a singleton if (sum(abs(Sl[[b]]$S[[1]][upper.tri(Sl[[b]]$S[[1]],diag=FALSE)]))==0) { ## S diagonal ## Reparameterize so that S has 1's or zero's on diagonal ## In new parameterization smooth specific model matrix is X%*%diag(D) ## ind indexes penalized parameters from this smooth's set. D <- diag(Sl[[b]]$S[[1]]) ind <- D > 0 ## index penalized elements D[ind] <- 1/sqrt(D[ind]);D[!ind] <- 1 ## X' = X%*%diag(D) Sl[[b]]$D <- D; Sl[[b]]$ind <- ind } else { ## S is not diagonal if (cholesky) { ## use Cholesky based reparameterization tr <- singleStrans(Sl[[b]]$S[[1]],Sl[[b]]$rank) ind <- rep(FALSE,ncol(tr$D)) ind[1:tr$rank] <- TRUE Sl[[b]]$D <- tr$D Sl[[b]]$Di <- tr$Di Sl[[b]]$rank <- tr$rank } else { ## use eigen based re-parameterization es <- eigen(Sl[[b]]$S[[1]],symmetric=TRUE) U <- es$vectors;D <- es$values if (is.null(Sl[[b]]$rank)) { ## need to estimate rank Sl[[b]]$rank <- sum(D>.Machine$double.eps^.8*max(D)) } ind <- rep(FALSE,length(D)) ind[1:Sl[[b]]$rank] <- TRUE ## index penalized elements D[ind] <- 1/sqrt(D[ind]);D[!ind] <- 1 Sl[[b]]$D <- t(D*t(U)) ## D <- U%*%diag(D) Sl[[b]]$Di <- t(U)/D } ## so if X is smooth model matrix X%*%D is re-parameterized form ## and t(D)%*%Sl[[b]]$S[[1]]%*%D is the reparameterized penalty ## -- a partial identity matrix. ## Di is the inverse of D and crossprod(Di[1:rank,]) is the original ## penalty matrix Sl[[b]]$ind <- ind } ## add penalty square root into E if (Sl[[b]]$repara) { ## then it is just the identity ind <- (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind] diag(E)[ind] <- 1 lambda <- c(lambda,1) ## record corresponding lambda } else { ## need scaled root penalty in *original* parameterization D <- Sl[[b]]$Di[1:Sl[[b]]$rank,] D.norm <- norm(D); D <- D/D.norm indc <- Sl[[b]]$start:(Sl[[b]]$start+ncol(D)-1) indr <- Sl[[b]]$start:(Sl[[b]]$start+nrow(D)-1) E[indr,indc] <- D lambda <- c(lambda,1/D.norm^2) } } else { ## multiple S block ## must be in range space of total penalty... Sl[[b]]$ind <- rep(FALSE,ncol(Sl[[b]]$S[[1]])) if (cholesky) { tr <- iniStrans(Sl[[b]]$S,Sl[[b]]$rank) if (Sl[[b]]$repara) Sl[[b]]$rS <- list() for (i in 1:length(tr$S)) { if (Sl[[b]]$repara) Sl[[b]]$S[[i]] <- tr$S[[i]] else Sl[[b]]$rS[[i]] <- tr$S[[i]] ## only need to store here if !repara } ind <- 1:tr$rank Sl[[b]]$rank <- tr$rank Sl[[b]]$D <- tr$T Sl[[b]]$Di <- tr$Ti } else { Sl[[b]]$rS <- list() ## needed for adaptive re-parameterization S <- Sl[[b]]$S[[1]] for (j in 2:length(Sl[[b]]$S)) S <- S + Sl[[b]]$S[[j]] ## scaled total penalty es <- eigen(S,symmetric=TRUE);U <- es$vectors; D <- es$values Sl[[b]]$D <- U if (is.null(Sl[[b]]$rank)) { ## need to estimate rank Sl[[b]]$rank <- sum(D>.Machine$double.eps^.8*max(D)) } ind <- 1:Sl[[b]]$rank for (j in 1:length(Sl[[b]]$S)) { ## project penalties into range space of total penalty bob <- t(U[,ind])%*%Sl[[b]]$S[[j]]%*%U[,ind] bob <- (t(bob) + bob)/2 ## avoid over-zealous chol sym check if (Sl[[b]]$repara) { ## otherwise want St and E in original parameterization Sl[[b]]$S[[j]] <- bob } Sl[[b]]$rS[[j]] <- mroot(bob,Sl[[b]]$rank) } } #Sl[[b]]$ind <- rep(FALSE,ncol(Sl[[b]]$S[[1]])) Sl[[b]]$ind[ind] <- TRUE ## index penalized within sub-range ## now compute well scaled sqrt S.norm <- norm(Sl[[b]]$S[[1]]) St <- Sl[[b]]$S[[1]]/S.norm lambda <- c(lambda,1/S.norm) for (j in 2:length(Sl[[b]]$S)) { S.norm <- norm(Sl[[b]]$S[[j]]) St <- St + Sl[[b]]$S[[j]]/S.norm lambda <- c(lambda,1/S.norm) } St <- (t(St) + St)/2 ## avoid over-zealous chol sym check St <- t(mroot(St,Sl[[b]]$rank)) indc <- Sl[[b]]$start:(Sl[[b]]$start+ncol(St)-1) indr <- Sl[[b]]$start:(Sl[[b]]$start+nrow(St)-1) E[indr,indc] <- St } } ## re-para finished attr(Sl,"E") <- E ## E'E = scaled total penalty attr(Sl,"lambda") <- lambda ## smoothing parameters corresponding to E attr(Sl,"cholesky") <- cholesky ## store whether this is Cholesky based or not Sl ## the penalty list } ## end of Sl.setup Sl.Sb <- function(Sl,rho,beta) { ## computes S %*% beta where S is total penalty matrix defined by Sl and rho, ## the log smoothing parameters. Assumes initial re-parameterization has taken ## place, so single penalties are multiples of identity and uses S for ## multi-S blocks. Logic is identical to Sl.addS. k <- 1 a <- beta * 0 if (length(Sl)>0) for (b in 1:length(Sl)) { ind <- (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind] if (length(Sl[[b]]$S)==1) { ## singleton - multiple of identity a[ind] <- a[ind] + beta[ind] * exp(rho[k]) k <- k + 1 } else { ## multi-S block for (j in 1:length(Sl[[b]]$S)) { a[ind] <- a[ind] + exp(rho[k]) * (Sl[[b]]$S[[j]] %*% beta[ind]) k <- k + 1 } } } a } ## Sl.Sb Sl.rSb <- function(Sl,rho,beta) { ## Computes vector 'a' containing all terms rS %*% beta stacked end to end. ## sum of squares of 'a' this is bSb, but 'a' is linear in beta ## Assumes initial re-parameterization has taken ## place, so single penalties are multiples of identity and uses S for ## multi-S blocks. Logic is identical to Sl.addS. k <- 1 ## sp counter kk <- 0 ## total length of returned vector if (length(Sl)>0) for (b in 1:length(Sl)) { ind <- (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind] kk <- kk + length(Sl[[b]]$S)*length(ind) } a <- rep(0,kk) kk <- 0 if (length(Sl)>0) for (b in 1:length(Sl)) { ind <- (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind] if (length(Sl[[b]]$S)==1) { ## singleton - multiple of identity a[kk + 1:length(ind)] <- beta[ind] * exp(rho[k]/2) k <- k + 1 kk <- kk + length(ind) } else { ## multi-S block for (j in 1:length(Sl[[b]]$S)) { a[kk + 1:length(ind)] <- exp(rho[k]/2) * (beta[ind] %*% Sl[[b]]$rS[[j]]) k <- k + 1 kk <- kk + length(ind) } } } a } ## Sl.rSb Sl.inirep <- function(Sl,X,l=0,r=0,nt=1) { ## Re-parameterize X using initial Sl reparameterization info. ## l,r = -2,-1,0,1,2. O is do not apply, negative to apply inverse transform Di, ## positive for transform D, 1 for transform, 2 for its transpose. ## Aim is for simpler and cleaner than if (length(Sl)==0 && !l && !r) return(X) ## nothing to do if (is.matrix(X)) { for (b in 1:length(Sl)) if (Sl[[b]]$repara) { ind <- Sl[[b]]$start:Sl[[b]]$stop if (l) X[ind,] <- if (l == 1) Sl[[b]]$D%*%X[ind,,drop=FALSE] else if (l == 2) t(Sl[[b]]$D)%*%X[ind,,drop=FALSE] else if (l == -1) Sl[[b]]$Di%*%X[ind,,drop=FALSE] else t(Sl[[b]]$Di)%*%X[ind,,drop=FALSE] if (r) X[,ind] <- if (l == 1) X[,ind,drop=FALSE]%*%Sl[[b]]$D else if (l == 2) X[,ind,drop=FALSE]%*%t(Sl[[b]]$D) else if (l == -1) X[,ind,drop=FALSE]%*%Sl[[b]]$Di else X[,ind,drop=FALSE]%*%t(Sl[[b]]$Di) } } else { ## it's a vector for (b in 1:length(Sl)) if (Sl[[b]]$repara) { ind <- Sl[[b]]$start:Sl[[b]]$stop if (l) X[ind] <- if (l == 1) Sl[[b]]$D%*%X[ind] else if (l == 2) t(Sl[[b]]$D)%*%X[ind] else if (l == -1) Sl[[b]]$Di%*%X[ind] else t(Sl[[b]]$Di)%*%X[ind] if (r) X[ind] <- if (l == 1) X[ind]%*%Sl[[b]]$D else if (l == 2) X[ind]%*%t(Sl[[b]]$D) else if (l == -1) X[ind]%*%Sl[[b]]$Di else X[ind]%*%t(Sl[[b]]$Di) } } X } ## Sl.inirep Sl.initial.repara <- function(Sl,X,inverse=FALSE,both.sides=TRUE,cov=TRUE,nt=1) { ## Routine to apply initial Sl re-parameterization to model matrix X, ## or, if inverse==TRUE, to apply inverse re-para to parameter vector ## or cov matrix. If inverse is TRUE and both.sides=FALSE then ## re-para only applied to rhs, as appropriate for a choleski factor. ## If both.sides==FALSE, X is a vector and inverse==FALSE then X is ## taken as a coefficient vector (so re-para is inverse of that for model ## matrix...) if (length(Sl)==0) return(X) ## nothing to do if (inverse) { ## apply inverse re-para if (is.matrix(X)) { if (cov) { ## then it's a covariance matrix for (b in 1:length(Sl)) if (Sl[[b]]$repara) { ind <- Sl[[b]]$start:Sl[[b]]$stop if (is.matrix(Sl[[b]]$D)) { if (both.sides) X[ind,] <- if (nt==1) Sl[[b]]$D%*%X[ind,,drop=FALSE] else pmmult(Sl[[b]]$D,X[ind,,drop=FALSE],FALSE,FALSE,nt=nt) X[,ind] <- if (nt==1) X[,ind,drop=FALSE]%*%t(Sl[[b]]$D) else pmmult(X[,ind,drop=FALSE],Sl[[b]]$D,FALSE,TRUE,nt=nt) } else { ## Diagonal D X[,ind] <- t(Sl[[b]]$D * t(X[,ind,drop=FALSE])) if (both.sides) X[ind,] <- Sl[[b]]$D * X[ind,,drop=FALSE] } } } else { ## regular matrix: need to use Di for (b in 1:length(Sl)) if (Sl[[b]]$repara) { ind <- Sl[[b]]$start:Sl[[b]]$stop if (is.matrix(Sl[[b]]$D)) { Di <- if(is.null(Sl[[b]]$Di)) t(Sl[[b]]$D) else Sl[[b]]$Di if (both.sides) X[ind,] <- if (nt==1) t(Di)%*%X[ind,,drop=FALSE] else pmmult(Di,X[ind,,drop=FALSE],TRUE,FALSE,nt=nt) X[,ind] <- if (nt==1) X[,ind,drop=FALSE]%*%Di else pmmult(X[,ind,drop=FALSE],Di,FALSE,FALSE,nt=nt) } else { ## Diagonal D Di <- 1/Sl[[b]]$D X[,ind] <- t(Di * t(X[,ind,drop=FALSE])) if (both.sides) X[ind,] <- Di * X[ind,,drop=FALSE] } } } } else { ## it's a parameter vector for (b in 1:length(Sl)) if (Sl[[b]]$repara) { ind <- Sl[[b]]$start:Sl[[b]]$stop if (is.matrix(Sl[[b]]$D)) X[ind] <- Sl[[b]]$D%*%X[ind] else X[ind] <- Sl[[b]]$D*X[ind] } } } else for (b in 1:length(Sl)) if (Sl[[b]]$repara) { ## model matrix re-para ind <- Sl[[b]]$start:Sl[[b]]$stop if (is.matrix(X)) { if (is.matrix(Sl[[b]]$D)) { if (both.sides) X[ind,] <- if (nt==1) t(Sl[[b]]$D)%*%X[ind,,drop=FALSE] else pmmult(Sl[[b]]$D,X[ind,,drop=FALSE],TRUE,FALSE,nt=nt) X[,ind] <- if (nt==1) X[,ind,drop=FALSE]%*%Sl[[b]]$D else pmmult(X[,ind,drop=FALSE],Sl[[b]]$D,FALSE,FALSE,nt=nt) } else { if (both.sides) X[ind,] <- Sl[[b]]$D * X[ind,,drop=FALSE] X[,ind] <- t(Sl[[b]]$D*t(X[,ind,drop=FALSE])) ## X[,ind]%*%diag(Sl[[b]]$D) } } else { if (both.sides) { ## signalling vector to be treated like model matrix X... if (is.matrix(Sl[[b]]$D)) X[ind] <- t(Sl[[b]]$D)%*%X[ind] else X[ind] <- Sl[[b]]$D*X[ind] } else { ## both.sides == FALSE is just a signal that X is a parameter vector if (is.matrix(Sl[[b]]$D)) X[ind] <- if (is.null(Sl[[b]]$Di)) t(Sl[[b]]$D)%*%X[ind] else Sl[[b]]$Di%*%X[ind] else X[ind] <- X[ind]/Sl[[b]]$D } } } X } ## end Sl.initial.repara ldetSblock <- function(rS,rho,deriv=2,root=FALSE,nt=1) { ## finds derivatives wrt rho of log|S| where ## S = sum_i tcrossprod(rS[[i]]*exp(rho[i])) ## when S is full rank +ve def and no ## reparameterization is required.... lam <- exp(rho) S <- pcrossprod(rS[[1]],trans=TRUE,nt=nt)*lam[1] ##tcrossprod(rS[[1]])*lam[1] ## parallel p <- ncol(S) m <- length(rS) if (m > 1) for (i in 2:m) S <- S + pcrossprod(rS[[i]],trans=TRUE,nt=nt)*lam[i] ## S <- S + tcrossprod(rS[[i]])*lam[i] ## parallel if (!root) E <- S d <- diag(S);d[d<=0] <- 1;d <- sqrt(d) S <- t(S/d)/d ## diagonally pre-condition R <- if (nt>1) pchol(S,nt) else suppressWarnings(chol(S,pivot=TRUE)) piv <- attr(R,"pivot") r <- attr(R,"rank") if (rmax(nos)*1e-5) D <- nD[j]; nD <- nD[-j] cat("Dset =",j,"\n") return(list(D=D,nD=nD)) } ## dominant.set Rldet <- 0 m <- length(S) nD <- 1:m ## index of terms not yet dealt with a <- 1 ## starting row/col p <- ncol(S[[1]]) ## dimension T <- Ti <- diag(p) while (repara&&length(nD)>1 && a <= p) { ## get indices of dominant terms and remainder nos <- rep(0,length(nD)) ## for dominance determining norms j <- 1 for (i in nD) { nos[j] <- norm(S[[i]][a:p,a:p,drop=FALSE])*lam[i]; j <- j + 1} ds <- dominant.set(nos,nD) nD <- ds$nD ## not dominant set D <- ds$D ## dominant set ## Form the dominant term and its pivoted Cholesky k <- p-a+1 ## current block dimension Sd <- matrix(0,k,k) for (i in D) Sd <- Sd + lam[i] * S[[i]][a:p,a:p,drop=FALSE] R <- suppressWarnings(chol(Sd,pivot=TRUE)) rank <- min(Rrank(R),attr(R,"rank")) piv <- attr(R,"pivot") ipiv <- piv; ipiv[piv] <- 1:k Sp <- Sd[piv,piv,drop=FALSE]; normS <- norm(Sp) ## more expensive refinement of rank... while (rank>1&&max(abs(crossprod(R[1:(rank-1),rank:k,drop=FALSE])-Sp[rank:k,rank:k,drop=FALSE]))<.Machine$double.eps^.75*normS) rank <- rank - 1 if (rank < k) { ind <- (rank+1):k R[ind,ind] <- diag(length(ind)) ## augment to full rank k } ## Apply transform to components of D, suppressing definite machine zeroes for (i in D) { S[[i]][,a:p] <- t(forwardsolve(t(R),t(S[[i]][,a:p,drop=FALSE][,piv,drop=FALSE]))) ## SRi S[[i]][a:p,] <- forwardsolve(t(R),S[[i]][a:p,,drop=FALSE][piv,,drop=FALSE]) ## Ri'S if (rank < k) S[[i]][a:p,a:p][ind,] <- S[[i]][a:p,a:p][,ind] <- 0 } ## Apply transform to components of nD for (i in nD) { S[[i]][,a:p] <- t(forwardsolve(t(R),t(S[[i]][,a:p,drop=FALSE][,piv,drop=FALSE]))) ## SRi S[[i]][a:p,] <- forwardsolve(t(R),S[[i]][a:p,,drop=FALSE][piv,,drop=FALSE]) ## Ri'S } ## Update the total transform matrix, its log determinant and inverse... Rldet <- Rldet + sum(log(diag(R))) ## Accumulate T such that |sum_i lam_i*S_i| = |T' sum_i lam_i * St_i T| ## St_i being transformed versions... Ti[,a:p] <- t(forwardsolve(t(R),t(Ti[,a:p,drop=FALSE][,piv,drop=FALSE]))) ## this is inverse T[a:p,] <- R %*% T[a:p,,drop=FALSE][piv,,drop=FALSE] a <- a + rank } ## finished transforming ## compute the log determinant St <- matrix(0,p,p) for (i in 1:m) St <- St + lam[i]*S[[i]] if (repara) { E <- R1 <- chol(St) Rldet <- sum(log(diag(R1))) # + Rldet ## note: no log|T| - cancels in REML } else { ## use stabilized generalized inverse gi <- ginv1(St) E <- gi$E Rldet <- gi$ldet #+ Rldet ## note: no log|T| - cancels in REML } det1 <- det2 <- NULL if (deriv>0) { R1 <- if (repara) chol2inv(R1) else gi$inv det1 <- lam*0 for (i in 1:m) det1[i] <- sum(R1*S[[i]]*lam[i]) } if (deriv>1) { SiS <- list() det2 <- matrix(0,m,m) for (i in 1:m) { SiS[[i]] <- R1 %*% S[[i]] for (j in 1:i) det2[i,j] <- det2[j,i] <- -sum(SiS[[i]]*t(SiS[[j]]))*lam[i]*lam[j] det2[i,i] <- det2[i,i] + det1[i] } } list(det=2*Rldet,T=T,S=S,Ti=Ti,det1=det1,det2 = det2,St=St,E=E,kappa=kappa(St)) } ## ldetSt ldetS <- function(Sl,rho,fixed,np,root=FALSE,repara=TRUE,nt=1,deriv=2) { ## Get log generalized determinant of S stored blockwise in an Sl list. ## If repara=TRUE multi-term blocks will be re-parameterized using gam.reparam, and ## a re-parameterization object supplied in the returned object. ## rho contains log smoothing parameters, fixed is an array indicating whether they ## are fixed (or free). np is the number of coefficients. root indicates ## whether or not to return E. ## Returns: Sl, with modified rS terms, if needed and rho added to each block ## rp, a re-parameterization list ## E a total penalty square root such that E'E = S_tot (if root==TRUE) ## ldetS,ldetS1,ldetS2 the value, grad vec and Hessian n.deriv <- sum(!fixed) k.deriv <- k.sp <- k.rp <- 1 ldS <- 0 d1.ldS <- rep(0,n.deriv) d2.ldS <- matrix(0,n.deriv,n.deriv) cholesky <- attr(Sl,"cholesky") rp <- list() ## reparameterization list if (root) E <- matrix(0,np,np) else E <- NULL if (length(Sl)>0) for (b in 1:length(Sl)) { ## work through blocks if (length(Sl[[b]]$S)==1) { ## singleton ldS <- ldS + rho[k.sp] * Sl[[b]]$rank if (!fixed[k.sp]) { d1.ldS[k.deriv] <- Sl[[b]]$rank k.deriv <- k.deriv + 1 } if (root) { ## insert diagonal from block start to end if (Sl[[b]]$repara) { ind <- (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind] diag(E)[ind] <- exp(rho[k.sp]*.5) ## sqrt smoothing param } else { ## root has to be in original parameterization... D <- Sl[[b]]$Di[1:Sl[[b]]$rank,] indc <- Sl[[b]]$start:(Sl[[b]]$start+ncol(D)-1) indr <- Sl[[b]]$start:(Sl[[b]]$start+nrow(D)-1) E[indr,indc] <- D * exp(rho[k.sp]*.5) } } Sl[[b]]$lambda <- exp(rho[k.sp]) k.sp <- k.sp + 1 } else { ## multi-S block m <- length(Sl[[b]]$S) ## number of components for this block ind <- k.sp:(k.sp+m-1) ## index for smoothing parameters ## call gam.reparam to deal with this block ## in a stable way... if (cholesky) { grp <- ldetSt(Sl[[b]]$S,lam=exp(rho[ind]),deriv=deriv,repara) } else grp <- if (repara) gam.reparam(Sl[[b]]$rS,lsp=rho[ind],deriv=deriv) else ldetSblock(Sl[[b]]$rS,rho[ind],deriv=deriv,root=root,nt=nt) Sl[[b]]$lambda <- exp(rho[ind]) ldS <- ldS + grp$det ## next deal with the derivatives... grp$det1 <- grp$det1[!fixed[ind]] ## discard derivatives for fixed components grp$det2 <- if (deriv>1) grp$det2[!fixed[ind],!fixed[ind]] else 0 ##NULL nd <- length(grp$det1) if (nd>0) { ## then not all sp's are fixed dind <- k.deriv:(k.deriv+nd-1) d1.ldS[dind] <- grp$det1 d2.ldS[dind,dind] <- grp$det2 k.deriv <- k.deriv + nd } ## now store the reparameterization information if (repara) { ## note that Ti is equivalent to Qs... rp[[k.rp]] <- if (cholesky) list(block =b,ind = (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind],T=grp$T, Ti=grp$Ti,repara=Sl[[b]]$repara) else list(block =b,ind = (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind], Qs = grp$Qs,repara=Sl[[b]]$repara) k.rp <- k.rp + 1 for (i in 1:m) { Sl[[b]]$Srp[[i]] <- if (cholesky) Sl[[b]]$lambda[i]*grp$S[[i]] else Sl[[b]]$lambda[i]*grp$rS[[i]]%*%t(grp$rS[[i]]) } } k.sp <- k.sp + m if (Sl[[b]]$repara) { if (root) { ## unpack the square root E'E ic <- Sl[[b]]$start:(Sl[[b]]$start+ncol(grp$E)-1) ir <- Sl[[b]]$start:(Sl[[b]]$start+nrow(grp$E)-1) E[ir,ic] <- grp$E Sl[[b]]$St <- crossprod(grp$E) } else { ## gam.reparam always returns root penalty in E, but ## ldetSblock returns penalty in E if root==FALSE if (cholesky) Sl[[b]]$St <- grp$St else Sl[[b]]$St <- if (repara) crossprod(grp$E) else grp$E } } else { ## square root block and St need to be in original parameterization... Sl[[b]]$St <- Sl[[b]]$lambda[1]*Sl[[b]]$S[[1]] for (i in 2:m) { Sl[[b]]$St <- Sl[[b]]$St + Sl[[b]]$lambda[i]*Sl[[b]]$S[[i]] } if (root) { Eb <- t(mroot(Sl[[b]]$St,Sl[[b]]$rank)) indc <- Sl[[b]]$start:(Sl[[b]]$start+ncol(Eb)-1) indr <- Sl[[b]]$start:(Sl[[b]]$start+nrow(Eb)-1) E[indr,indc] <- Eb } } } ## end of multi-S block branch } ## end of block loop if (root) E <- E[rowSums(abs(E))!=0,,drop=FALSE] ## drop zero rows. list(ldetS=ldS,ldet1=d1.ldS,ldet2=d2.ldS,Sl=Sl,rp=rp,E=E) } ## end ldetS Sl.addS <- function(Sl,A,rho) { ## Routine to add total penalty to matrix A. Sl is smooth penalty ## list from Sl.setup, so initial reparameterizations have taken place, ## and should have already been applied to A using Sl.initial.repara k <- 1 A <- A*1 ## force a copy to be made so that A not modified in calling env!! if (length(Sl)>0) for (b in 1:length(Sl)) { ind <- (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind] if (length(Sl[[b]]$S)==1) { ## singleton B <- exp(rho[k]);diag <- -1 dummy <- .Call(C_mgcv_madi,A,B,ind,diag) ## diag(A)[ind] <- diag(A)[ind] + exp(rho[k]) ## penalty is identity times sp k <- k + 1 } else { for (j in 1:length(Sl[[b]]$S)) { B <- exp(rho[k]) * Sl[[b]]$S[[j]]; diag <- 0 .Call(C_mgcv_madi,A,B,ind,diag) ## A[ind,ind] <- A[ind,ind] + exp(rho[k]) * Sl[[b]]$S[[j]] k <- k + 1 } } } A } ## Sl.addS Sl.addS0 <- function(Sl,A,rho) { ## Routine to add total penalty to matrix A. Sl is smooth penalty ## list from Sl.setup, so initial reparameterizations have taken place, ## and should have already been applied to A using Sl.initial.repara ## inefficient prototype of Sl.addS k <- 1 for (b in 1:length(Sl)) { ind <- (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind] if (length(Sl[[b]]$S)==1) { ## singleton diag(A)[ind] <- diag(A)[ind] + exp(rho[k]) ## penalty is identity times sp k <- k + 1 } else { for (j in 1:length(Sl[[b]]$S)) { A[ind,ind] <- A[ind,ind] + exp(rho[k]) * Sl[[b]]$S[[j]] k <- k + 1 } } } A } ## Sl.addS0 Sl.repa <- function(rp,X,l=0,r=0) { ## Re-parameterize X using rp reparameterization info. ## l,r = -2,-1,0,1,2. O is do not apply, negative to apply inverse transform Di, ## positive for transform D, 1 for transform, 2 for its transpose. ## If b' is transformed and b orginal. Di b' = b and b' = D b. ## If T present D=T and Di = Ti. Otherwise D = t(Qs) and Di = Qs. ## Aim is for simpler and cleaner than Sl.repara nr <- length(rp);if (nr==0) return(X) for (i in 1:nr) if (rp[[i]]$repara) { if (l) { T <- if (is.null(rp[[i]]$Qs)) { if (l<0) { if (l==-2) t(rp[[i]]$Ti) else rp[[i]]$Ti } else { if (l==2) t(rp[[i]]$T) else rp[[i]]$T }} else { if (l<0) { if (l==-2) t(rp[[i]]$Qs) else rp[[i]]$Qs } else { if (l==2) rp[[i]]$Qs else t(rp[[i]]$Qs) }} if (is.matrix(X)) X[rp[[i]]$ind,] <- T %*% X[rp[[i]]$ind,] else X[rp[[i]]$ind] <- T %*% X[rp[[i]]$ind] } if (r) { T <- if (is.null(rp[[i]]$Qs)) { if (r<0) { if (r==-2) t(rp[[i]]$Ti) else rp[[i]]$Ti } else { if (r==2) t(rp[[i]]$T) else rp[[i]]$T }} else {if (r<0) { if (r==-2) t(rp[[i]]$Qs) else rp[[i]]$Qs } else { if (r==2) rp[[i]]$Qs else t(rp[[i]]$Qs) }} if (is.matrix(X)) X[,rp[[i]]$ind] <- X[,rp[[i]]$ind]%*%T else X[rp[[i]]$ind] <- t(X[rp[[i]]$ind])%*%T } } X } ## Sl.repa Sl.repara <- function(rp,X,inverse=FALSE,both.sides=TRUE) { ## Apply re-parameterization from ldetS to X, blockwise. ## If X is a matrix it is assumed to be a model matrix ## whereas if X is a vector it is assumed to be a parameter vector. ## If inverse==TRUE applies the inverse of the re-para to ## parameter vector X or cov matrix X... ## beta_trans = Ti beta_original T is inverse Ti nr <- length(rp);if (nr==0) return(X) if (inverse) { if (is.matrix(X)) { ## X is a cov matrix for (i in 1:nr) if (rp[[i]]$repara) { if (both.sides) X[rp[[i]]$ind,] <- if (is.null(rp[[i]]$Qs)) rp[[i]]$Ti %*% X[rp[[i]]$ind,,drop=FALSE] else rp[[i]]$Qs %*% X[rp[[i]]$ind,,drop=FALSE] X[,rp[[i]]$ind] <- if (is.null(rp[[i]]$Qs)) X[,rp[[i]]$ind,drop=FALSE] %*% t(rp[[i]]$Ti) else X[,rp[[i]]$ind,drop=FALSE] %*% t(rp[[i]]$Qs) } } else { ## X is a vector for (i in 1:nr) if (rp[[i]]$repara) X[rp[[i]]$ind] <- if (is.null(rp[[i]]$Qs)) rp[[i]]$Ti %*% X[rp[[i]]$ind] else rp[[i]]$Qs %*% X[rp[[i]]$ind] } } else { ## apply re-para to X if (is.matrix(X)) { for (i in 1:nr) if (rp[[i]]$repara) X[,rp[[i]]$ind] <- if (is.null(rp[[i]]$Qs)) X[,rp[[i]]$ind]%*%rp[[i]]$Ti else X[,rp[[i]]$ind]%*%rp[[i]]$Qs } else { for (i in 1:nr) if (rp[[i]]$repara) X[rp[[i]]$ind] <- if (is.null(rp[[i]]$Qs)) rp[[i]]$T %*% X[rp[[i]]$ind] else t(rp[[i]]$Qs) %*% X[rp[[i]]$ind] } } X } ## end Sl.repara Sl.mult <- function(Sl,A,k = 0,full=TRUE) { ## Sl contains the blocks of block diagonal penalty S. ## If k<=0 this routine forms S%*%A. ## If k>0 then the routine forms S_k%*%A, zero padded ## if full==TRUE, but in smallest number of rows form otherwise. nb <- length(Sl) ## number of blocks if (nb==0) return(A*0) Amat <- is.matrix(A) if (k<=0) { ## apply whole penalty B <- A*0 for (b in 1:nb) { ## block loop if (length(Sl[[b]]$S)==1) { ## singleton ind <- Sl[[b]]$start:Sl[[b]]$stop if (Sl[[b]]$repara) { ind <- ind[Sl[[b]]$ind] if (Amat) B[ind,] <- Sl[[b]]$lambda*A[ind,] else B[ind] <- Sl[[b]]$lambda*A[ind] } else { ## original penalty has to be applied if (Amat) B[ind,] <- Sl[[b]]$lambda*Sl[[b]]$S[[1]] %*% A[ind,] else B[ind] <- Sl[[b]]$lambda*Sl[[b]]$S[[1]] %*% A[ind] } } else { ## multi-S block ind <- (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind] if (Amat) B[ind,] <- Sl[[b]]$St %*% A[ind,] else B[ind] <- Sl[[b]]$St %*% A[ind] } } ## end of block loop A <- B } else { ## single penalty matrix selected j <- 0 ## S counter for (b in 1:nb) { ## block loop for (i in 1:length(Sl[[b]]$S)) { ## S loop within blocks j <- j + 1 if (j==k) { ## found block if (length(Sl[[b]]$S)==1) { ## singleton ind <- Sl[[b]]$start:Sl[[b]]$stop if (Sl[[b]]$repara) { ind <- ind[Sl[[b]]$ind] if (full) { ## return zero answer with all zeroes in place B <- A*0 if (Amat) B[ind,] <- Sl[[b]]$lambda*A[ind,] else B[ind] <- Sl[[b]]$lambda*A[ind] A <- B } else { ## strip zero rows from answer if (Amat) A <- Sl[[b]]$lambda*A[ind,] else A <- as.numeric(Sl[[b]]$lambda*A[ind]) } } else { ## not reparameterized version if (full) { B <- A*0 if (Amat) B[ind,] <- Sl[[b]]$lambda*Sl[[b]]$S[[1]]%*%A[ind,] else B[ind] <- Sl[[b]]$lambda*Sl[[b]]$S[[1]]%*%A[ind] A <- B } else { if (Amat) A <- Sl[[b]]$lambda*Sl[[b]]$S[[1]]%*%A[ind,] else A <- as.numeric(Sl[[b]]$lambda*Sl[[b]]$S[[1]]%*%A[ind]) } } ## not repara } else { ## multi-S block ind <- if (Sl[[b]]$repara) (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind] else Sl[[b]]$start:Sl[[b]]$stop if (full) { ## return zero answer with all zeroes in place B <- A*0 if (Amat) { B[ind,] <- if (is.null(Sl[[b]]$Srp)||!Sl[[b]]$repara) Sl[[b]]$lambda[i]*(Sl[[b]]$S[[i]]%*%A[ind,]) else Sl[[b]]$Srp[[i]]%*%A[ind,] } else { B[ind] <- if (is.null(Sl[[b]]$Srp)||!Sl[[b]]$repara) Sl[[b]]$lambda[i]*(Sl[[b]]$S[[i]]%*%A[ind]) else Sl[[b]]$Srp[[i]]%*%A[ind] } A <- B } else { ## strip zero rows from answer if (is.null(Sl[[b]]$Srp)||!Sl[[b]]$repara) { A <- if (Amat) Sl[[b]]$lambda[i]*(Sl[[b]]$S[[i]]%*%A[ind,]) else Sl[[b]]$lambda[i]*as.numeric(Sl[[b]]$S[[i]]%*%A[ind]) } else { A <- if (Amat) Sl[[b]]$Srp[[i]]%*%A[ind,] else as.numeric(Sl[[b]]$Srp[[i]]%*%A[ind]) } } } break } } ## end of S loop if (j==k) break } ## end of block loop } A } ## end Sl.mult Sl.termMult <- function(Sl,A,full=FALSE,nt=1) { ## returns a list containing the product of each element S of Sl ## with A. If full==TRUE then the results include the zero rows ## otherwise these are stripped out, but in that case each element ## of the return object contains an "ind" attribute, indicating ## which rows of the full matrix it relates to. Amat <- is.matrix(A) SA <- list() k <- 0 ## component counter nb <- length(Sl) ## number of blocks if (nb>0) for (b in 1:nb) { ## block loop if (length(Sl[[b]]$S)==1) { ## singleton k <- k + 1 ind <- Sl[[b]]$start:Sl[[b]]$stop if (Sl[[b]]$repara) { ind <- ind[Sl[[b]]$ind] if (full) { ## return zero answer with all zeroes in place B <- A*0 if (Amat) B[ind,] <- Sl[[b]]$lambda*A[ind,,drop=FALSE] else B[ind] <- Sl[[b]]$lambda*A[ind] SA[[k]] <- B } else { ## strip zero rows from answer if (Amat) SA[[k]] <- Sl[[b]]$lambda*A[ind,,drop=FALSE] else SA[[k]] <- as.numeric(Sl[[b]]$lambda*A[ind]) attr(SA[[k]],"ind") <- ind } } else { if (full) { ## return zero answer with all zeroes in place B <- A*0 if (Amat) B[ind,] <- Sl[[b]]$lambda*Sl[[b]]$S[[1]]%*%A[ind,,drop=FALSE] else B[ind] <- Sl[[b]]$lambda*Sl[[b]]$S[[1]]%*%A[ind] SA[[k]] <- B } else { ## strip zero rows from answer if (Amat) SA[[k]] <- Sl[[b]]$lambda*Sl[[b]]$S[[1]]%*%A[ind,,drop=FALSE] else SA[[k]] <- as.numeric(Sl[[b]]$lambda*Sl[[b]]$S[[1]]%*%A[ind]) attr(SA[[k]],"ind") <- ind } } } else { ## multi-S block ind <- if (Sl[[b]]$repara) (Sl[[b]]$start:Sl[[b]]$stop)[Sl[[b]]$ind] else Sl[[b]]$start:Sl[[b]]$stop for (i in 1:length(Sl[[b]]$S)) { ## work through S terms k <- k + 1 if (full) { ## return answer with all zeroes in place B <- A*0 if (is.null(Sl[[b]]$Srp)||!Sl[[b]]$repara) { if (Amat) { B[ind,] <- if (nt==1) Sl[[b]]$lambda[i]*(Sl[[b]]$S[[i]]%*%A[ind,,drop=FALSE]) else Sl[[b]]$lambda[i]*pmmult(Sl[[b]]$S[[i]],A[ind,,drop=FALSE],nt=nt) } else B[ind] <- Sl[[b]]$lambda[i]*(Sl[[b]]$S[[i]]%*%A[ind]) } else { if (Amat) { B[ind,] <- if (nt==1) Sl[[b]]$Srp[[i]]%*%A[ind,,drop=FALSE] else pmmult(Sl[[b]]$Srp[[i]],A[ind,,drop=FALSE],nt=nt) } else B[ind] <- Sl[[b]]$Srp[[i]]%*%A[ind] } SA[[k]] <- B } else { ## strip zero rows from answer if (is.null(Sl[[b]]$Srp)||!Sl[[b]]$repara) { if (Amat) { SA[[k]] <- if (nt==1) Sl[[b]]$lambda[i]*(Sl[[b]]$S[[i]]%*%A[ind,,drop=FALSE]) else Sl[[b]]$lambda[i]*pmmult(Sl[[b]]$S[[i]],A[ind,,drop=FALSE],nt=nt) } else SA[[k]] <- Sl[[b]]$lambda[i]*as.numeric(Sl[[b]]$S[[i]]%*%A[ind]) } else { if (Amat) { SA[[k]] <- if (nt==1) Sl[[b]]$Srp[[i]]%*%A[ind,,drop=FALSE] else pmmult(Sl[[b]]$Srp[[i]],A[ind,,drop=FALSE],nt=nt) } else SA[[k]] <- as.numeric(Sl[[b]]$Srp[[i]]%*%A[ind]) } attr(SA[[k]],"ind") <- ind } } ## end of S loop for block b } } ## end block loop SA } ## end Sl.termMult d.detXXS <- function(Sl,PP,nt=1,deriv=2) { ## function to obtain derivatives of log |X'X+S| given unpivoted PP' where ## P is inverse of R from the QR of the augmented model matrix. SPP <- Sl.termMult(Sl,PP,full=FALSE,nt=nt) ## SPP[[k]] is S_k PP' nd <- length(SPP) d1 <- rep(0,nd);d2 <- matrix(0,nd,nd) for (i in 1:nd) { indi <- attr(SPP[[i]],"ind") d1[i] <- sum(diag(SPP[[i]][,indi,drop=FALSE])) if (deriv==2) { for (j in i:nd) { indj <- attr(SPP[[j]],"ind") d2[i,j] <- d2[j,i] <- -sum(t(SPP[[i]][,indj,drop=FALSE])*SPP[[j]][,indi,drop=FALSE]) } d2[i,i] <- d2[i,i] + d1[i] } } list(d1=d1,d2=d2) } ## end d.detXXS Sl.ift <- function(Sl,R,X,y,beta,piv,rp) { ## function to obtain derviatives of \hat \beta by implicit differentiation ## and to use these directly to evaluate derivs of b'Sb and the RSS. ## piv and rp are the pivots and inverse pivots from the qr that produced R. ## rssj and bSbj only contain the terms that will not cancel in rssj + bSbj beta <- beta[rp] ## unpivot Sb <- Sl.mult(Sl,beta,k = 0) ## unpivoted Skb <- Sl.termMult(Sl,beta,full=TRUE) ## unpivoted rsd <- (X%*%beta - y) #Xrsd <- t(X)%*%rsd ## X'Xbeta - X'y nd <- length(Skb) np <- length(beta) db <- matrix(0,np,nd) rss1 <- bSb1 <- rep(0,nd) for (i in 1:nd) { ## compute the first derivatives db[,i] <- -backsolve(R,forwardsolve(t(R),Skb[[i]][piv]))[rp] ## d beta/ d rho_i ## rss1[i] <- 0* 2 * sum(db[,i]*Xrsd) ## d rss / d rho_i bSb1[i] <- sum(beta*Skb[[i]]) ## + 2 * sum(db[,i]*Sb) ## d b'Sb / d_rho_i } XX.db <- t(X)%*%(X%*%db) S.db <- Sl.mult(Sl,db,k=0) rss2 <- bSb2 <- matrix(0,nd,nd) for (k in 1:nd) { ## second derivative loop for (j in k:nd) { ## d2b <- (k==j)*db[,k] - backsolve(R,forwardsolve(t(R),Sk.db[[j]][piv,k]+Sk.db[[k]][piv,j]))[rp] rss2[j,k] <- rss2[k,j] <- 2 * sum(db[,j]*XX.db[,k]) ## + 2 * sum(d2b*Xrsd) bSb2[j,k] <- bSb2[k,j] <- (k==j)*sum(beta*Skb[[k]]) + 2*(sum(db[,k]*(Skb[[j]]+S.db[,j])) + sum(db[,j]*Skb[[k]])) ## + 2 * (sum(d2b*Sb) } } list(bSb=sum(beta*Sb),bSb1=bSb1,bSb2=bSb2,d1b=db,rss =sum(rsd^2),rss1=rss1,rss2=rss2) } ## end Sl.ift Sl.iftChol <- function(Sl,XX,R,d,beta,piv,nt=1) { ## function to obtain derviatives of \hat \beta by implicit differentiation ## and to use these directly to evaluate derivs of b'Sb and the RSS. ## piv contains the pivots from the chol that produced R. ## rssj and bSbj only contain the terms that will not cancel in rssj + bSbj Sb <- Sl.mult(Sl,beta,k = 0) ## unpivoted Skb <- Sl.termMult(Sl,beta,full=TRUE) ## unpivoted nd <- length(Skb) np <- length(beta) db <- matrix(0,np,nd) rss1 <- bSb1 <- rep(0,nd) ## alternative all in one code - matches loop results, but ## timing close to identical - modified for parallel exec D <- matrix(unlist(Skb),length(beta),nd) bSb1 <- colSums(beta*D) D1 <- .Call(C_mgcv_Rpforwardsolve,R,D[piv,]/d[piv],nt) ## note R transposed internally unlike forwardsolve db[piv,] <- -.Call(C_mgcv_Rpbacksolve,R,D1,nt)/d[piv] if (is.null(XX)) return(list(bSb1=bSb1,db=db)) ## return early ## XX.db <- XX%*%db XX.db <- .Call(C_mgcv_pmmult2,XX,db,0,0,nt) S.db <- Sl.mult(Sl,db,k=0) rss2 <- 2 * .Call(C_mgcv_pmmult2,db,XX.db,1,0,nt) bSb2 <- diag(x=colSums(beta*D),nrow=nd) bSb2 <- bSb2 + 2 * (.Call(C_mgcv_pmmult2,db,D+S.db,1,0,nt) + .Call(C_mgcv_pmmult2,D,db,1,0,nt)) list(bSb=sum(beta*Sb),bSb1=bSb1,bSb2=bSb2, d1b=db ,rss1=rss1,rss2=rss2) } ## end Sl.iftChol Sl.fitChol <- function(Sl,XX,f,rho,yy=0,L=NULL,rho0=0,log.phi=0,phi.fixed=TRUE, nobs=0,Mp=0,nt=c(1,1),tol=0,gamma=1) { ## given X'WX in XX and f=X'Wy solves the penalized least squares problem ## with penalty defined by Sl and rho, and evaluates a REML Newton step, the REML ## gradient and the the estimated coefs bhat. If phi.fixed=FALSE then we need ## yy = y'Wy in order to get derivsatives w.r.t. phi. ## NOTE: with an optimized BLAS nt==1 is likely to be much faster than ## nt > 1 tol <- as.numeric(tol) rho <- if (is.null(L)) rho + rho0 else L%*%rho + rho0 if (length(rho)1) pchol(t(XXp/d)/d,nt[2]) else suppressWarnings(chol(t(XXp/d)/d,pivot=TRUE)) r <- min(attr(R,"rank"),Rrank(R)) p <- ncol(XXp) piv <- attr(R,"pivot") #;rp[rp] <- 1:p if (r1) { P <- pbsi(R,nt=nt[2],copy=TRUE) ## invert R PP[piv,piv] <- pRRt(P,nt[2]) ## PP' } else PP[piv,piv] <- chol2inv(R) PP <- t(PP/d)/d ldetXXS <- 2*sum(log(diag(R))+log(d[piv])) ## log|X'X+S| dXXS <- d.detXXS(ldS$Sl,PP,nt=nt[1]) ## derivs of log|X'X+S| phi <- exp(log.phi) reml1 <- (dXXS$d1[!fixed] - ldS$ldet1 + (dift$rss1[!fixed] + dift$bSb1[!fixed])/(phi*gamma))/2 reml2 <- (dXXS$d2[!fixed,!fixed] - ldS$ldet2 + (dift$rss2[!fixed,!fixed] + dift$bSb2[!fixed,!fixed])/(phi*gamma))/2 if (!phi.fixed) { n <- length(reml1) rss.bSb <- yy - sum(beta*f) ## use identity ||y-Xb|| + b'Sb = y'y - b'X'y (b is minimizer) reml1[n+1] <- (-rss.bSb/(phi*gamma) + nobs/gamma - Mp)/2 d <- c(-(dift$rss1[!fixed] + dift$bSb1[!fixed]),rss.bSb)/(2*phi*gamma) reml2 <- rbind(cbind(reml2,d[1:n]),d) if (!is.null(L)) L <- rbind(cbind(L,rep(0,nrow(L))),c(rep(0,ncol(L)),1)) } if (!is.null(L)) { reml1 <- t(L)%*%reml1 reml2 <- t(L)%*%reml2%*%L } uconv.ind <- (abs(reml1) > tol)|(abs(diag(reml2))>tol) hess <- reml2 grad <- reml1 if (length(grad)>0&&sum(uconv.ind)>0) { if (sum(uconv.ind)!=ncol(reml2)) { reml1 <- reml1[uconv.ind] reml2 <- reml2[uconv.ind,uconv.ind] } er <- eigen(reml2,symmetric=TRUE) er$values <- abs(er$values) me <- max(er$values)*.Machine$double.eps^.5 er$values[er$values4) step <- 4*step/ms } else step <- 0 ## return the coefficient estimate, the reml grad and the Newton step... list(beta=beta,grad=grad,step=step,db=dift$d1b,PP=PP,R=R,piv=piv,rank=r, hess=hess,ldetS=ldS$ldetS,ldetXXS=ldetXXS) } ## Sl.fitChol Sl.fit <- function(Sl,X,y,rho,fixed,log.phi=0,phi.fixed=TRUE,rss.extra=0,nobs=NULL,Mp=0,nt=1,gamma=1) { ## fits penalized regression model with model matrix X and ## initialised block diagonal penalty Sl to data in y, given ## log smoothing parameters rho. ## Returns coefs, reml score + grad and Hessian. np <- ncol(X) ## number of parameters n <- nrow(X) phi <- exp(log.phi) if (is.null(nobs)) nobs <- n ## get log|S|_+ stably... ldS <- ldetS(Sl,rho,fixed,np,root=TRUE,nt=nt) ## apply resulting stable re-parameterization to X... X <- Sl.repara(ldS$rp,X) ## get pivoted QR decomp of augmented model matrix (in parallel if nt>1) qrx <- if (nt>1) pqr2(rbind(X,ldS$E),nt=nt) else qr(rbind(X,ldS$E),LAPACK=TRUE) rp <- qrx$pivot;rp[rp] <- 1:np ## reverse pivot vector ## find pivoted \hat beta... R <- qr.R(qrx) Qty0 <- qr.qty(qrx,c(y,rep(0,nrow(ldS$E)))) beta <- backsolve(R,Qty0)[1:np] rss.bSb <- sum(Qty0[-(1:np)]^2) + rss.extra ## get component derivatives based on IFT... dift <- Sl.ift(ldS$Sl,R,X,y,beta,qrx$pivot,rp) ## and the derivatives of log|X'X+S|... P <- pbsi(R,nt=nt,copy=TRUE) ## invert R ## P <- backsolve(R,diag(np))[rp,] ## invert R and row unpivot ## crossprod and unpivot (don't unpivot if unpivoting P above) PP <- if (nt==1) tcrossprod(P)[rp,rp] else pRRt(P,nt)[rp,rp] ## PP' ldetXXS <- 2*sum(log(abs(diag(R)))) ## log|X'X+S| dXXS <- d.detXXS(ldS$Sl,PP,nt=nt) ## derivs of log|X'X+S| ## all ingredients are now in place to form REML score and ## its derivatives.... reml <- (rss.bSb/(phi*gamma) + (nobs/gamma-Mp)*log(2*pi*phi) + Mp*log(gamma) + ldetXXS - ldS$ldetS)/2 reml1 <- (dXXS$d1[!fixed] - ldS$ldet1 + # dift$bSb1[!fixed]/phi)/2 (dift$rss1[!fixed] + dift$bSb1[!fixed])/(phi*gamma))/2 reml2 <- (dXXS$d2[!fixed,!fixed] - ldS$ldet2 + #dift$bSb2[!fixed,!fixed]/phi)/2 (dift$rss2[!fixed,!fixed] + dift$bSb2[!fixed,!fixed])/(phi*gamma))/2 ## finally add in derivatives w.r.t. log.phi if (!phi.fixed) { n <- length(reml1) reml1[n+1] <- (-rss.bSb/(phi*gamma) + nobs/gamma - Mp)/2 #d <- c(-(dift$bSb1[!fixed]),rss.bSb)/(2*phi) d <- c(-(dift$rss1[!fixed] + dift$bSb1[!fixed]),rss.bSb)/(2*phi*gamma) reml2 <- rbind(cbind(reml2,d[1:n]),d) } ## following are de-bugging lines for testing derivatives of components... #list(reml=ldetXXS,reml1=dXXS$d1,reml2=dXXS$d2) #list(reml=ldS$ldetS,reml1=ldS$ldet1,reml2=ldS$ldet2) #list(reml=dift$rss,reml1=dift$rss1,reml2=dift$rss2) #list(reml=dift$bSb,reml1=dift$bSb1,reml2=dift$bSb2) list(reml=as.numeric(reml),reml1=reml1,reml2=reml2,beta=beta[rp],PP=PP, rp=ldS$rp,rss=dift$rss+rss.extra,nobs=nobs,d1b=dift$d1b) } ## Sl.fit fast.REML.fit <- function(Sl,X,y,rho,L=NULL,rho.0=NULL,log.phi=0,phi.fixed=TRUE, rss.extra=0,nobs=NULL,Mp=0,conv.tol=.Machine$double.eps^.5,nt=1,gamma=gamma) { ## estimates log smoothing parameters rho, by optimizing fast REML ## using Newton's method. On input Sl is a block diagonal penalty ## structure produced by Sl.setup, while X is a model matrix ## reparameterized to correspond to any re-parameterization ## used in Sl. Both will have had been modified to drop any ## structurally un-identifiable coefficients. ## Note that lower bounds on smoothing parameters are not handled. maxNstep <- 5 if (is.null(nobs)) nobs <- nrow(X) np <- ncol(X) if (nrow(X) > np) { ## might as well do an initial QR step qrx <- if (nt>1) pqr2(X,nt=nt) else qr(X,LAPACK=TRUE) rp <- qrx$pivot rp[rp] <- 1:np X <- qr.R(qrx)[,rp] y <- qr.qty(qrx,y) rss.extra <- rss.extra + sum(y[-(1:np)]^2) y <- y[1:np] } if (is.null(L)) { L <- diag(length(rho)) if (is.null(rho.0)) rho.0 <- rep(0,nrow(L)) } else { ## convert intial s.p.s to account for L if (is.null(rho.0)) rho.0 <- rep(0,nrow(L)) rho <- as.numeric(coef(lm(rho ~ L-1+offset(rho.0)))) } fixed <- rep(FALSE,nrow(L)) best <- Sl.fit(Sl,X,y,L%*%rho+rho.0,fixed,log.phi,phi.fixed,rss.extra,nobs,Mp,nt=nt,gamma=gamma) ## get a typical scale for the reml score... reml.scale <- abs(best$reml) + best$rss/best$nobs nr <- length(rho.0) if (!phi.fixed) { rho <- c(rho,log.phi) ## append log.phi for fitting rho.0 <- c(rho.0,0) L <- rbind(cbind(L,L[,1]*0),c(L[1,]*0,1)) } grad <- as.numeric(t(L)%*% best$reml1) hess <- t(L)%*% best$reml2%*%L grad2 <- diag(hess) ## create and index for the unconverged... ## idea in following is only to exclude terms with zero first and second derivative ## from optimization, as it is only these that slow things down if included... uconv.ind <- (abs(grad) > reml.scale*conv.tol*.1)|(abs(grad2)>reml.scale*conv.tol*.1) ## if all appear converged at this stage, then there is probably something wrong, ## but reset anyway to see if situation can be recovered. If we don't do this then ## need to abort immediately, otherwise fails trying to eigen a 0 by 0 matrix if (sum(uconv.ind)==0) { warning("Possible divergence detected in fast.REML.fit",call.=FALSE,immediate.=TRUE) uconv.ind <- rep(TRUE,length(grad)) } step.failed <- FALSE for (iter in 1:200) { ## the Newton loop ## Work only with unconverged (much quicker under indefiniteness) hess <- (t(L)%*% best$reml2%*%L)[uconv.ind,uconv.ind] grad <- as.numeric(t(L)%*%best$reml1)[uconv.ind] ## check that Hessian is +ve def. Fix if not. eh <- eigen(hess,symmetric=TRUE) ## flip negative eigenvalues to get +ve def... ind <- eh$values < 0 eh$values[ind] <- -eh$values[ind] ## avoid indefiniteness by further manipulation... thresh <- max(abs(eh$values))*.Machine$double.eps^.5 ind <- eh$values < thresh eh$values[ind] <- thresh ## get the Newton direction, -ve inverse hessian times gradient uc.step <- - eh$vectors%*%((t(eh$vectors)%*%grad)/eh$values) ## now make sure step is not too far... ms <- max(abs(uc.step)) if (ms>maxNstep) uc.step <- maxNstep * uc.step/ms step <- rep(0,length(uconv.ind)); ## full step (including converged) step[uconv.ind] <- uc.step ## step includes converged ## try out the step... rho1 <- L%*%(rho + step)+rho.0; if (!phi.fixed) log.phi <- rho1[nr+1] trial <- Sl.fit(Sl,X,y,rho1[1:nr],fixed,log.phi,phi.fixed,rss.extra,nobs,Mp,nt=nt,gamma=gamma) k <- 0 not.moved <- 0 ## count number of consecutive steps of essentially no change from best while (trial$reml>best$reml) { ## step half until improvement or failure ## idea with the following is to count the number of consecutive step halvings ## without a numerically significant change from best$reml, since ## this is an early indicator of step failure. if (trial$reml-best$reml < conv.tol*reml.scale) not.moved <- not.moved + 1 else not.moved <- 0 if (k==25||sum(rho != rho + step)==0||not.moved>3) { step.failed <- TRUE break } step <- step/2;k <- k + 1 rho1 <- L%*%(rho + step)+rho.0; if (!phi.fixed) log.phi <- rho1[nr+1] trial <- Sl.fit(Sl,X,y,rho1[1:nr],fixed,log.phi,phi.fixed,rss.extra,nobs,Mp,nt=nt,gamma=gamma) } if (step.failed) break ## can get no further #if ((k==35 && trial$reml>best$reml)||(sum(rho != rho + step)==0)) { ## step has failed # step.failed <- TRUE # break ## can get no further #} ## At this stage the step has been successful. ## Need to test for convergence... converged <- TRUE grad <- as.numeric(t(L)%*%trial$reml1) hess <- t(L)%*%trial$reml2%*%L;grad2 <- diag(hess) ## idea in following is only to exclude terms with zero first and second derivative ## from optimization, as it is only these that slow things down if included... uconv.ind <- (abs(grad) > reml.scale*conv.tol*.1)|(abs(grad2)>reml.scale*conv.tol*.1) ## now do the convergence testing... ## First check gradiants... if (sum(abs(grad)>reml.scale*conv.tol)) converged <- FALSE ## Now check change in REML values if (abs(best$reml-trial$reml)>reml.scale*conv.tol) { if (converged) uconv.ind <- uconv.ind | TRUE ## otherwise can't progress converged <- FALSE } best <- trial ## trial becomes current best. rho <- rho + step ## and new log sp accepted. if (converged) break ## ok done, leave loop reml.scale <- abs(best$reml) + best$rss/best$nobs ## update for next iterate } ## end of Newton loop if (iter==200) warning("fast REML optimizer reached iteration limit") if (step.failed) best$conv <- "step failed" else if (iter==200) best$conv <- "no convergence in 200 iterations" else best$conv <- "full convergence" best$iter <- iter best$outer.info <- list(conv = best$conv, iter = best$iter,grad = grad,hess = hess) best$rho <- rho best$rho.full <- as.numeric(L%*%rho+rho.0) best ## return the best fit (note that it will need post-processing to be useable) } ## end fast.REML.fit ident.test <- function(X,E,nt=1) { ## routine to identify structurally un-identifiable coefficients ## for model with model matrix X and scaled sqrt penalty matrix E ## lambda is smoothing parameter vector corresponding to E, ## and the routine also suggests starting values for lambda ## based on scaling of X and E. ## If length(drop)>0 then X[,-drop] is new model matrix ## if beta contains coefs with unidentified dropped, and ## if beta.full is a vector of zeroes for each original coef ## then beta.full[undrop] <- beta, is the full, zero padded ## coeff vector, with dropped coefs re-nstated as zeroes. Xnorm <- norm(X,type="F") qrx <- if (nt>1) pqr2(rbind(X/Xnorm,E),nt=nt) else qr(rbind(X/Xnorm,E),LAPACK=TRUE) ## pivoted QR rank <- Rrank(qr.R(qrx),tol=.Machine$double.eps^.75) drop <- qrx$pivot[-(1:rank)] ## index of un-identifiable coefs undrop <- 1:ncol(X) if (length(drop)>0) undrop <- undrop[-drop] list(drop=drop,undrop=undrop) } ## ident.test Sl.drop <- function(Sl,drop,np) { ## routine to drop coefs in drop, from block diagonal penalty ## stored in Sl. np is total number of coeffs if (length(drop)==0) return(Sl) keep <- rep(TRUE,np) keep[drop] <- FALSE ## logical indexing of retained coefs ## let b1 be coefs after dropping and b0 be full vector before. ## new.loc gives location in b1 of ith element in b0. If i is ## in drop then new.loc[i] is position of last b0[j] not dropped. ## i.e. for i not in drop, b0[i] = b1[new.loc[i]]. ## for i in drop, b1[new.loc[i]] = b0[j] where j is largest ## j < i s.t. j not in drop. ## These indices facilitate easy dropping from parts of blocks ## corresponding to coef indices in drop. cholesky <- attr(Sl,"cholesky") ## is setup all Cholesky based? new.loc <- cumsum(keep) dropped.blocks <- FALSE for (b in 1:length(Sl)) { ind <- (Sl[[b]]$start:Sl[[b]]$stop)##[Sl[[b]]$ind] if (length(Sl[[b]]$S)==1) { ## singleton ## need to count terms dropped from penalty, ## adjusting rank, ind, start and stop bdrop <- ind%in%drop ## which are dropped here? npd <- sum(bdrop[Sl[[b]]$ind]) ## number of penalized dropped Sl[[b]]$ind <- Sl[[b]]$ind[!bdrop] ## retain not dropped Sl[[b]]$rank <- Sl[[b]]$rank - npd ## reduce rank by penalized dropped if (Sl[[b]]$rank <=0) dropped.blocks <- TRUE Sl[[b]]$start <- new.loc[Sl[[b]]$start] Sl[[b]]$stop <- new.loc[Sl[[b]]$stop] } else { ## multi-S bdrop <- ind%in%drop ## which are dropped here? keep <- !bdrop[Sl[[b]]$ind] ## index of what to keep in the penalties npd <- sum(!keep) ## number of penalized dropped Sl[[b]]$ind <- Sl[[b]]$ind[!bdrop] ## retain not dropped Sl[[b]]$rank <- Sl[[b]]$rank - npd ## reduce rank by penalized dropped if (Sl[[b]]$rank <=0) dropped.blocks <- TRUE ## need to drop rows and cols from S and and rows from rS for (i in 1:length(Sl[[b]]$S)) { if (length(Sl[[b]]$rS)) Sl[[b]]$rS[[i]] <- if (cholesky) Sl[[b]]$rS[[i]][keep,keep] else Sl[[b]]$rS[[i]][keep,] Sl[[b]]$S[[i]] <- Sl[[b]]$S[[i]][keep,keep] } Sl[[b]]$start <- new.loc[Sl[[b]]$start] Sl[[b]]$stop <- new.loc[Sl[[b]]$stop] } } if (dropped.blocks) { new.b <- 1 for (i in 1:length(Sl)) { if (Sl[[b]]$rank>0) { Sl[[new.b]] <- Sl[[b]] new.b <- new.b + 1 } } } attr(Sl,"drop") <- drop Sl } ## Sl.drop Sl.Xprep <- function(Sl,X,nt=1) { ## Sl is block diag object from Sl.setup, X is a model matrix ## this routine applies preliminary Sl transformations to X ## tests for structural identifibility problems and drops ## un-identifiable parameters. X <- Sl.initial.repara(Sl,X,inverse=FALSE,both.sides=FALSE,cov=FALSE,nt=nt) ## apply re-para used in Sl to X id <- ident.test(X,attr(Sl,"E"),nt=nt) ## deal with structural identifiability ## id contains drop, undrop, lambda if (length(id$drop)>0) { ## then there is something to do here Sl <- Sl.drop(Sl,id$drop,ncol(X)) ## drop unidentifiable from Sl X <- X[,-id$drop] ## drop unidentifiable from X } rank <- 0 for (b in 1:length(Sl)) rank <- rank + Sl[[b]]$rank ## the total penalty rank ## Also add Mp, the total null space dimension to return list. list(X=X,Sl=Sl,undrop=id$undrop,rank=rank,Mp=ncol(X)-rank) } ## end Sl.Xprep Sl.postproc <- function(Sl,fit,undrop,X0,cov=FALSE,scale = -1,L,nt=1) { ## reverse the various fitting re-parameterizations. ## X0 is the orginal model matrix before any re-parameterization ## or parameter dropping. Sl is also the original *before parameter ## dropping* np <- ncol(X0) beta <- rep(0,np) beta[undrop] <- Sl.repara(fit$rp,fit$beta,inverse=TRUE) beta <- Sl.initial.repara(Sl,beta,inverse=TRUE,both.sides=TRUE,cov=TRUE,nt=nt) if (cov) { d1b <- matrix(0,np,ncol(fit$d1b)) ## following construction a bit ugly due to Sl.repara assumptions... d1b[undrop,] <- t(Sl.repara(fit$rp,t(fit$d1b),inverse=TRUE,both.sides=FALSE)) for (i in 1:ncol(d1b)) d1b[,i] <- Sl.initial.repara(Sl,as.numeric(d1b[,i]),inverse=TRUE,both.sides=TRUE,cov=TRUE,nt=nt) ## d beta / d rho matrix PP <- matrix(0,np,np) PP[undrop,undrop] <- Sl.repara(fit$rp,fit$PP,inverse=TRUE) PP <- Sl.initial.repara(Sl,PP,inverse=TRUE,both.sides=TRUE,cov=TRUE,nt=nt) #XPP <- crossprod(t(X0),PP)*X0 #hat <- rowSums(XPP);edf <- colSums(XPP) XPP <- crossprod(t(X0),PP) hat <- rowSums(XPP*X0) F <- crossprod(XPP,X0) edf <- diag(F) edf1 <- 2*edf - rowSums(t(F)*F) ## edf <- rowSums(PP*crossprod(X0)) ## diag(PP%*%(t(X0)%*%X0)) if (scale<=0) { scale <- fit$rss/(fit$nobs - sum(edf)) } Vp <- PP * scale ## cov matrix ## sp uncertainty correction... if (!is.null(L)) d1b <- d1b%*%L M <- ncol(d1b) ev <- eigen(fit$outer.info$hess,symmetric=TRUE) ind <- ev$values <= 0 ev$values[ind] <- 0;ev$values[!ind] <- 1/sqrt(ev$values[!ind]) rV <- (ev$values*t(ev$vectors))[,1:M] Vc <- crossprod(rV%*%t(d1b)) Vc <- Vp + Vc ## Bayesian cov matrix with sp uncertainty edf2 <- rowSums(Vc*crossprod(X0))/scale ##bias <- as.numeric(beta-F%*%beta) ## estimate of smoothing bias in beta return(list(beta=beta,Vp=Vp,Vc=Vc,Ve=F%*%Vp,edf=edf,edf1=edf1,edf2=edf2,hat=hat,F=F)) } else return(list(beta=beta)) } ## Sl.postproc ## USEAGE SEQUENCE: ## 1. Use gam.setup to setup gam object, G, say, as usual ## 2. Call Sl.setup which uses info in G$smooth and G$paraPen ## to set up a block diagonal penalty structure, Sl, say ## 3. At this stage reweight the model matrix in G if needed ## (e.g. in IRLS) to get X ## 4. um <- Sl.Xprep(Sl,X) to deal with identifiability and re-para. ## 5. initial smoothing parameters from initial.sp(X,G$S,G$off), ## initial phi from, say variance of y over 10?? ## 6. fit <- fast.REML.fit(um$Sl,um$X,G$y,rho,L=G$L,rho.0=G$lsp0, ## log.phi=log.phi,phi.fixed=FALSE/TRUE,Mp=um$Mp) ## 7. res <- Sl.postproc(Sl,fit,um$undrop,X,cov=TRUE), to get postproc ## stuff ## Notice: that only steps 3-7 are needed in an IRLS loop and cov=TRUE ## is only needed after convergence of such a loop. ## Warning: min.sp not handled by this approach. mgcv/R/efam.r0000644000176200001440000022315013507463007012512 0ustar liggesusers## (c) Simon N. Wood & Natalya Pya (scat, beta), ## 2013-2017. Released under GPL2. ## See gam.fit4.r for testing functions fmud.test and fetad.test. estimate.theta <- function(theta,family,y,mu,scale=1,wt=1,tol=1e-7,attachH=FALSE) { ## Simple Newton iteration to estimate theta for an extended family, ## given y and mu. To be iterated with estimation of mu given theta. ## If used within a PIRLS loop then divergence testing of coef update ## will have to re-compute pdev after theta update. ## Not clear best way to handle scale - could optimize here as well if (!inherits(family,"extended.family")) stop("not an extended family") nlogl <- function(theta,family,y,mu,scale=1,wt=1,deriv=2) { ## compute the negative log likelihood and grad + hess nth <- length(theta) - if (scale<0) 1 else 0 if (scale < 0) { scale <- exp(theta[nth+1]) theta <- theta[1:nth] get.scale <- TRUE } else get.scale <- FALSE dev <- sum(family$dev.resids(y, mu, wt,theta))/scale if (deriv>0) Dd <- family$Dd(y, mu, theta, wt=wt, level=deriv) ls <- family$ls(y,w=wt,theta=theta,scale=scale) nll <- dev/2 - ls$ls if (deriv>0) { g1 <- colSums(as.matrix(Dd$Dth))/(2*scale) g <- if (get.scale) c(g1,-dev/2) else g1 ind <- 1:length(g) g <- g - ls$lsth1[ind] ## g <- if (deriv>0) colSums(as.matrix(Dd$Dth))/(2*scale) - ls$lsth1[1:nth] else NULL } else g <- NULL if (deriv>1) { x <- colSums(as.matrix(Dd$Dth2))/(2*scale) Dth2 <- matrix(0,nth,nth) k <- 0 for (i in 1:nth) for (j in i:nth) { k <- k + 1 Dth2[i,j] <- Dth2[j,i] <- x[k] } if (get.scale) Dth2 <- rbind(cbind(Dth2,-g1),c(-g1,dev/2)) H <- Dth2 - as.matrix(ls$lsth2)[ind,ind] # H <- Dth2 - as.matrix(ls$lsth2)[1:nth,1:nth] } else H <- NULL list(nll=nll,g=g,H=H) } ## nlogl if (scale>=0&&family$n.theta==0) stop("erroneous call to estimate.theta - no free parameters") n.theta <- length(theta) ## dimension of theta vector (family$n.theta==0 => all fixed) del.ind <- 1:n.theta if (scale<0) theta <- c(theta,log(var(y)*.1)) nll <- nlogl(theta,family,y,mu,scale,wt,2) g <- if (family$n.theta==0) nll$g[-del.ind] else nll$g H <- if (family$n.theta==0) nll$H[-del.ind,-del.ind,drop=FALSE] else nll$H step.failed <- FALSE for (i in 1:100) { ## main Newton loop #H <- if (family$n.theta==0) nll$H[-del.ind,-del.ind,drop=FALSE] else nll$H #g <- if (family$n.theta==0) nll$g[-del.ind] else nll$g eh <- eigen(H,symmetric=TRUE) pdef <- sum(eh$values <= 0)==0 if (!pdef) { ## Make the Hessian pos def eh$values <- abs(eh$values) thresh <- max(eh$values) * 1e-7 eh$values[eh$values4) step <- step*4/ms nll1 <- nlogl(theta+step,family,y,mu,scale,wt,2) iter <- 0 while (nll1$nll > nll$nll) { ## step halving step <- step/2; iter <- iter + 1 if (sum(theta!=theta+step)==0||iter>25) { step.failed <- TRUE break } nll1 <- nlogl(theta+step,family,y,mu,scale,wt,0) } ## step halving if (step.failed) break theta <- theta + step ## accept updated theta ## accept log lik and derivs ... nll <- if (iter>0) nlogl(theta,family,y,mu,scale,wt,2) else nll1 g <- if (family$n.theta==0) nll$g[-del.ind] else nll$g H <- if (family$n.theta==0) nll$H[-del.ind,-del.ind,drop=FALSE] else nll$H ## convergence checking... if (sum(abs(g) > tol*abs(nll$nll))==0) break } ## main Newton loop if (step.failed) warning("step failure in theta estimation") if (attachH) attr(theta,"H") <- H#nll$H theta } ## estimate.theta find.null.dev <- function(family,y,eta,offset,weights) { ## obtain the null deviance given y, best fit mu and ## prior weights fnull <- function(gamma,family,y,wt,offset) { ## evaluate deviance for single parameter model mu <- family$linkinv(gamma+offset) sum(family$dev.resids(y,mu, wt)) } mu <- family$linkinv(eta-offset) mum <- mean(mu*weights)/mean(weights) ## initial value eta <- family$linkfun(mum) ## work on l.p. scale deta <- abs(eta)*.1 + 1 ## search interval half width ok <- FALSE while (!ok) { search.int <- c(eta-deta,eta+deta) op <- optimize(fnull,interval=search.int,family=family,y=y,wt = weights,offset=offset) if (op$minimum > search.int[1] && op$minimum < search.int[2]) ok <- TRUE else deta <- deta*2 } op$objective } ## find.null.dev ## extended families for mgcv, standard components. ## family - name of family character string ## link - name of link character string ## linkfun - the link function ## linkinv - the inverse link function ## mu.eta - d mu/d eta function (derivative of inverse link wrt eta) ## note: for standard links this information is supplemented using ## function fix.family.link.extended.family with functions ## gkg where k is 2,3 or 4 giving the kth derivative of the ## link over the first derivative of the link to the power k. ## for non standard links these functions must be supplied. ## dev.resids - function computing deviance residuals. ## Dd - function returning derivatives of deviance residuals w.r.t. mu and theta. ## aic - function computing twice -ve log likelihood for 2df to be added to. ## initialize - expression to be evaluated in gam.fit4 and initial.spg ## to initialize mu or eta. ## preinitialize - optional function of y and family, returning a list with optional elements ## Theta - intitial Theta and y - modified y for use in fitting (see e.g. ocat and betar) ## postproc - function with arguments family, y, prior.weights, fitted, linear.predictors, offset, intercept ## to call after fit to compute (optionally) the label for the family, deviance and null deviance. ## See ocat for simple example and betar or ziP for complicated. Called in estimate.gam. ## ls - function to evaluated log saturated likelihood and derivatives w.r.t. ## phi and theta for use in RE/ML optimization. If deviance used is just -2 log ## lik. can just return zeroes. ## validmu, valideta - functions used to test whether mu/eta are valid. ## n.theta - number of theta parameters. ## no.r.sq - optional TRUE/FALSE indicating whether r^2 can be computed for family ## ini.theta - function for initializing theta. ## putTheta, getTheta - functions for storing and retriving theta values in function ## environment. ## rd - optional function for simulating response data from fitted model. ## residuals - optional function for computing residuals. ## predict - optional function for predicting from model, called by predict.gam. ## family$data - optional list storing any family specific data for use, e.g. in predict ## function. - deprecated (commented out below - appears to be used nowhere) ## scale - < 0 to estimate. ignored if NULL ## extended family object for ordered categorical ocat <- function(theta=NULL,link="identity",R=NULL) { ## extended family object for ordered categorical model. ## one of theta and R must be supplied. length(theta) == R-2. ## weights are ignored. #! is stuff removed under re-definition of ls as 0 linktemp <- substitute(link) if (!is.character(linktemp)) linktemp <- deparse(linktemp) if (linktemp %in% c("identity")) stats <- make.link(linktemp) else if (is.character(link)) { stats <- make.link(link) linktemp <- link } else { if (inherits(link, "link-glm")) { stats <- link if (!is.null(stats$name)) linktemp <- stats$name } else stop(linktemp, " link not available for ordered categorical family; available links are \"identity\"") } if (is.null(theta)&&is.null(R)) stop("Must supply theta or R to ocat") if (!is.null(theta)) R <- length(theta) + 2 ## number of catergories ## Theta <- NULL; n.theta <- R-2 ## NOTE: data based initialization is in preinitialize... if (!is.null(theta)&&sum(theta==0)==0) { if (sum(theta<0)) iniTheta <- log(abs(theta)) ## initial theta supplied else { iniTheta <- log(theta) ## fixed theta supplied n.theta <- 0 } } else iniTheta <- rep(-1,length=R-2) ## inital log theta value env <- new.env(parent = .GlobalEnv) assign(".Theta", iniTheta, envir = env) putTheta <-function(theta) assign(".Theta", theta,envir=environment(sys.function())) getTheta <-function(trans=FALSE) { theta <- get(".Theta") if (trans) { ## transform to (finite) cut points... R = length(theta)+2 alpha <- rep(0,R-1) ## the thresholds alpha[1] <- -1 if (R > 2) { ind <- 2:(R-1) alpha[ind] <- alpha[1] + cumsum(exp(theta)) } theta <- alpha } theta } postproc <- function(family,y,prior.weights,fitted,linear.predictors,offset,intercept) { posr <- list() ## null.deviance needs to be corrected... posr$null.deviance <- find.null.dev(family,y,eta=linear.predictors,offset,prior.weights) posr$family <- paste("Ordered Categorical(",paste(round(family$getTheta(TRUE),2),collapse=","),")",sep="") posr } validmu <- function(mu) all(is.finite(mu)) dev.resids <- function(y, mu, wt,theta=NULL) { #F <- function(x) { # h <- ind <- x > 0; h[ind] <- 1/(exp(-x[ind]) + 1) # x <- exp(x[!ind]); h[!ind] <- (x/(1+x)) # h #} Fdiff <- function(a,b) { ## cancellation resistent F(b)-F(a), b>a h <- rep(1,length(b)); h[b>0] <- -1; eb <- exp(b*h) h <- h*0+1; h[a>0] <- -1; ea <- exp(a*h) ind <- b<0;bi <- eb[ind];ai <- ea[ind] h[ind] <- bi/(1+bi) - ai/(1+ai) ind1 <- a>0;bi <- eb[ind1];ai <- ea[ind1] h[ind1] <- (ai-bi)/((ai+1)*(bi+1)) ind <- !ind & !ind1;bi <- eb[ind];ai <- ea[ind] h[ind] <- (1-ai*bi)/((bi+1)*(ai+1)) h } if (is.null(theta)) theta <- get(".Theta") R = length(theta)+2 alpha <- rep(0,R+1) ## the thresholds alpha[1] <- -Inf;alpha[R+1] <- Inf alpha[2] <- -1 if (R > 2) { ind <- 3:R alpha[ind] <- alpha[2] + cumsum(exp(theta)) } al1 <- alpha[y+1];al0 = alpha[y] ## cut points above and below y ## Compute sign for deviance residuals, based on sign of interval ## midpoint for each datum minus the fitted value of the latent ## variable. This makes first and last categories like 0s and 1s in ## logistic regression.... s <- sign((al1 + al0)/2-mu) ## sign for deviance residuals al1mu <- al1-mu;al0mu <- al0-mu ## f1 <- F(al1mu);f0 <- F(al0mu); ##f <- pmax(f1 - f0,.Machine$double.eps) f <- Fdiff(al0mu,al1mu) ##a1 <- f1^2 - f1;a0 <- f0^2 - f0; a <- a1 -a0 #! al1al0 <- (al1-al0)/2;al0al1 <- (al0-al1)/2 ##g1 <- F(al1al0);g0 <- F(al0al1) ##A <- pmax(g1 - g0,.Machine$double.eps) #! A <- Fdiff(al0al1,al1al0) rsd <- -2*log(f) #! 2*(log(A)-log(f)) attr(rsd,"sign") <- s rsd } ## end of dev.resids Dd <- function(y, mu, theta, wt=NULL, level=0) { ## derivatives of the ocat deviance... # F <- function(x) { ## e^(x)/(1+e^x) without overflow # h <- ind <- x > 0; h[ind] <- 1/(exp(-x[ind]) + 1) # x <- exp(x[!ind]); h[!ind] <- (x/(1+x)) # h # } Fdiff <- function(a,b) { ## cancellation resistent F(b)-F(a), b>a h <- rep(1,length(b)); h[b>0] <- -1; eb <- exp(b*h) h <- h*0+1; h[a>0] <- -1; ea <- exp(a*h) ind <- b<0;bi <- eb[ind];ai <- ea[ind] h[ind] <- bi/(1+bi) - ai/(1+ai) ind1 <- a>0;bi <- eb[ind1];ai <- ea[ind1] h[ind1] <- (ai-bi)/((ai+1)*(bi+1)) ind <- !ind & !ind1;bi <- eb[ind];ai <- ea[ind] h[ind] <- (1-ai*bi)/((bi+1)*(ai+1)) h } abcd <- function(x,level=-1) { bj <- cj <- dj <- NULL ## compute f_j^2 - f_j without cancellation error ## x <- 10;F(x)^2-F(x);abcd(x)$aj h <- rep(1,length(x)); h[x>0] <- -1; ex <- exp(x*h) ex1 <- ex+1;ex1k <- ex1^2 aj <- -ex/ex1k if (level>=0) { ## compute f_j - 3 f_j^2 + 2f_j^3 without cancellation error ## x <- 10;F(x)-3*F(x)^2+2*F(x)^3;abcd(x,0)$bj ex1k <- ex1k*ex1;ex2 <- ex^2 bj <- h*(ex-ex^2)/ex1k if (level>0) { ## compute -f_j + 7 f_j^2 - 12 f_j^3 + 6 f_j^4 ## x <- 10;-F(x)+7*F(x)^2-12*F(x)^3+6*F(x)^4;abcd(x,1)$cj ex1k <- ex1k*ex1;ex3 <- ex2*ex cj <- (-ex3 + 4*ex2 - ex)/ex1k if (level>1) { ## compute d_j ## x <- 10;F(x)-15*F(x)^2+50*F(x)^3-60*F(x)^4+24*F(x)^5;abcd(x,2)$dj ex1k <- ex1k*ex1;ex4 <- ex3*ex dj <- h * (-ex4 + 11*ex3 - 11*ex2 + ex)/ex1k } } } list(aj=aj,bj=bj,cj=cj,dj=dj) } R = length(theta)+2 alpha <- rep(0,R+1) ## the thresholds alpha[1] <- -Inf;alpha[R+1] <- Inf alpha[2] <- -1 if (R > 2) { ind <- 3:R alpha[ind] <- alpha[2] + cumsum(exp(theta)) } al1 <- alpha[y+1];al0 = alpha[y] al1mu <- al1-mu;al0mu <- al0 - mu ##f1 <- F(al1mu);f0 <- F(al0mu); ##f <- pmax(f1 - f0,.Machine$double.eps) f <- pmax(Fdiff(al0mu,al1mu),.Machine$double.xmin) r1 <- abcd(al1mu,level); a1 <- r1$aj r0 <- abcd(al0mu,level); a0 <- r0$aj ## a1 <- f1^2 - f1;a0 <- f0^2 - f0; a <- a1 - a0 #!al1al0 <- (al1-al0)/2; #! al0al1 <- (al0-al1)/2 ##g1 <- F(al1al0);g0 <- F(al0al1) ##A <- pmax(g1 - g0,.Machine$double.eps) #! A <- Fdiff(al0al1,al1al0) if (level>=0) { ## b1 <- f1 - 3 * f1^2 + 2 * f1^3;b0 <- f0 - 3 * f0^2 + 2 * f0^3 b1 <- r1$bj;b0 <- r0$bj b <- b1 - b0 } if (level>0) { ##c1 <- -f1 + 7 * f1^2 - 12* f1^3 + 6 * f1^4 ##c0 <- -f0 + 7 * f0^2 - 12* f0^3 + 6 * f0^4 c1 <- r1$cj;c0 <- r0$cj c <- c1 - c0 #! R1 <- abcd(al1al0,level-2) #! R0 <- abcd(al0al1,level-2) ## B <- g1^2 - g1 + g0^2 - g0 #! B <- R1$aj + R0$aj } if (level>1) { ##d1 <- f1 - 15 * f1^2 + 50 * f1^3 - 60 * f1^4 + 24 * f1^5 ##d0 <- f0 - 15 * f0^2 + 50 * f0^3 - 60 * f0^4 + 24 * f0^5 d1 <- r1$dj;d0 <- r0$dj d <- d1 - d0 ##C <- 2 * g1^3 - 3 * g1^2 + g1 - 2 * g0^3 + 3 * g0^2 - g0 #! C <- R1$bj - R0$bj } oo <- list(D=NULL,Dmu=NULL,Dmu2=NULL,Dth=NULL,Dmuth=NULL, Dmu2th=NULL) n <- length(y) ## deviance... oo$D <- -2 * log(f) #! 2*(log(A)-log(f)) if (level >= 0) { ## get derivatives used in coefficient estimation oo$Dmu <- -2 * a / f a2 <- a^2 oo$EDmu2 <- oo$Dmu2 <- 2 * (a2/f - b)/f } if (R<3) level <- 0 ## no free parameters if (level > 0) { ## get first derivative related stuff f2 <- f^2;a3 <- a2*a oo$Dmu3 <- 2*(- c - 2 * a3/f2 + 3 * a * b/f)/f Dmua0 <- 2 * (a0 * a/f - b0)/f Dmua1 <- -2 * (a1 * a /f - b1)/f Dmu2a0 <- -2* (c0 + (a0*(2*a2/f - b)- 2*b0*a )/f)/f Dmu2a1 <- 2*(c1 + (2*(a1*a2/f - b1*a) - a1*b)/f)/f Da0 <- -2*a0/f #! + B/A; Da1 <- 2 * a1/f #! - B/A ## now transform to derivatives w.r.t. theta... oo$Dmu2th <- oo$Dmuth <- oo$Dth <- matrix(0,n,R-2) for (k in 1:(R-2)) { etk <- exp(theta[k]) ind <- y == k+1 oo$Dth[ind,k] <- Da1[ind]*etk oo$Dmuth[ind,k] <- Dmua1[ind]*etk oo$Dmu2th[ind,k] <- Dmu2a1[ind]*etk if (R>k+2) { ind <- y > k+1 & y < R oo$Dth[ind,k] <- (Da1[ind]+Da0[ind])*etk oo$Dmuth[ind,k] <- (Dmua1[ind]+Dmua0[ind])*etk oo$Dmu2th[ind,k] <- (Dmu2a1[ind]+Dmu2a0[ind])*etk } ind <- y == R oo$Dth[ind,k] <- Da0[ind]*etk oo$Dmuth[ind,k] <- Dmua0[ind]*etk oo$Dmu2th[ind,k] <- Dmu2a0[ind]*etk } oo$EDmu2th <- oo$Dmu2th } if (level >1) { ## and the second derivative components oo$Dmu4 <- 2*((3*b^2 + 4*a*c)/f + a2*(6*a2/f - 12*b)/f2 - d)/f Dmu3a0 <- 2 * ((a0*c + 3*c0*a + 3*b0*b)/f - d0 + 6*a*(a0*a2/f - b0*a - a0*b)/f2 )/f Dmu3a1 <- 2 * (d1 - (a1*c + 3*(c1*a + b1*b))/f + 6*a*(b1*a - a1*a2/f + a1*b)/f2)/f Dmua0a0 <- 2*(c0 + (2*a0*(b0 - a0*a/f) - b0*a)/f )/f Dmua1a1 <- 2*( (b1*a + 2*a1*(b1 - a1*a/f))/f - c1)/f Dmua0a1 <- 2*(a0*(2*a1*a/f - b1) - b0*a1)/f2 Dmu2a0a0 <- 2*(d0 + (b0*(2*b0 - b) + 2*c0*(a0 - a))/f + 2*(b0*a2 + a0*(3*a0*a2/f - 4*b0*a - a0*b))/f2)/f Dmu2a1a1 <- 2*( (2*c1*(a + a1) + b1*(2*b1 + b))/f + 2*(a1*(3*a1*a2/f - a1*b) - b1*a*(a + 4*a1))/f2 - d1)/f Dmu2a0a1 <- 0 ## (8*a0*b1*a/f^3 + 8*b0*a1*a/f^3 - 12*a0*a1*a/f^4 - 4*b0*b1/f^2 + ## 4*a0*a1*b/f^3 - 2*c0*a1/f^2 - 2*c1*a0/f^2) Da0a0 <- 2 * (b0 + a0^2/f)/f #! + .5 * (C - B^2/A)/A Da1a1 <- -2* (b1 - a1^2/f)/f #! + .5 * (C - B^2/A)/A Da0a1 <- -2*a0*a1/f2 #! - .5 * (C - B^2/A)/A ## now transform to derivatives w.r.t. theta... n2d <- (R-2)*(R-1)/2 oo$Dmu3th <- matrix(0,n,R-2) oo$Dmu2th2 <- oo$Dmuth2 <- oo$Dth2 <- matrix(0,n,n2d) i <- 0 for (j in 1:(R-2)) for (k in j:(R-2)) { i <- i + 1 ## the second deriv col ind <- y >= j ## rest are zero ar1.k <- ar.k <- rep(exp(theta[k]),n) ar.k[y==R | y <= k] <- 0; ar1.k[yk&yk+1] <- exp(theta[k]) oo$Dmu3th[ind,k] <- Dmu3a1[ind]*ar.k[ind] + Dmu3a0[ind]*ar1.k[ind] } oo$Dth2[,i] <- Da1a1*ar.k*ar.j + Da0a1*ar.k*ar1.j + Da1 * ar.kj + Da0a0*ar1.k*ar1.j + Da0a1*ar1.k*ar.j + Da0 * ar1.kj oo$Dmuth2[,i] <- Dmua1a1*ar.k*ar.j + Dmua0a1*ar.k*ar1.j + Dmua1 * ar.kj + Dmua0a0*ar1.k*ar1.j + Dmua0a1*ar1.k*ar.j + Dmua0 * ar1.kj oo$Dmu2th2[,i] <- Dmu2a1a1*ar.k*ar.j + Dmu2a0a1*ar.k*ar1.j + Dmu2a1 * ar.kj + Dmu2a0a0*ar1.k*ar1.j + Dmu2a0a1*ar1.k*ar.j + Dmu2a0 * ar1.kj } } oo } ## end of Dd (ocat) aic <- function(y, mu, theta=NULL, wt, dev) { Fdiff <- function(a,b) { ## cancellation resistent F(b)-F(a), b>a h <- rep(1,length(b)); h[b>0] <- -1; eb <- exp(b*h) h <- h*0+1; h[a>0] <- -1; ea <- exp(a*h) ind <- b<0;bi <- eb[ind];ai <- ea[ind] h[ind] <- bi/(1+bi) - ai/(1+ai) ind1 <- a>0;bi <- eb[ind1];ai <- ea[ind1] h[ind1] <- (ai-bi)/((ai+1)*(bi+1)) ind <- !ind & !ind1;bi <- eb[ind];ai <- ea[ind] h[ind] <- (1-ai*bi)/((bi+1)*(ai+1)) h } if (is.null(theta)) theta <- get(".Theta") R = length(theta)+2 alpha <- rep(0,R+1) ## the thresholds alpha[1] <- -Inf;alpha[R+1] <- Inf alpha[2] <- -1 if (R > 2) { ind <- 3:R alpha[ind] <- alpha[2] + cumsum(exp(theta)) } al1 <- alpha[y+1];al0 = alpha[y] ##f1 <- F(al1-mu);f0 <- F(al0-mu);f <- f1 - f0 f <- Fdiff(al0-mu,al1-mu) -2*sum(log(f)) } ## end aic ls <- function(y,w,theta,scale) { ## the log saturated likelihood function. return(list(ls=0,lsth1=rep(0,R-2),lsth2=matrix(0,R-2,R-2))) } ## end of ls ## initialization is interesting -- needs to be with reference to initial cut-points ## so that mu puts each obs in correct category initially... preinitialize <- function(y,family) { ocat.ini <- function(R,y) { ## initialize theta from raw counts in each category if (R<3) return() y <- c(1:R,y) ## make sure there is *something* in each class p <- cumsum(tabulate(y[is.finite(y)])/length(y[is.finite(y)])) eta <- if (p[1]==0) 5 else -1 - log(p[1]/(1-p[1])) ## mean of latent theta <- rep(-1,R-1) for (i in 2:(R-1)) theta[i] <- log(p[i]/(1-p[i])) + eta theta <- diff(theta) theta[theta <= 0.01] <- 0.01 theta <- log(theta) } R3 <- length(family$getTheta())+2 if (!is.numeric(y)) stop("Response should be integer class labels") if (R3>2&&family$n.theta>0) { Theta <- ocat.ini(R3,y) return(list(Theta=Theta)) } } initialize <- expression({ R <- length(family$getTheta())+2 ## don't use n.theta as it's used to signal fixed theta if (any(y < 1)||any(y>R)) stop("values out of range") ## n <- rep(1, nobs) ## get the cut points... alpha <- rep(0,R+1) ## the thresholds alpha[1] <- -2;alpha[2] <- -1 if (R > 2) { ind <- 3:R alpha[ind] <- alpha[2] + cumsum(exp(family$getTheta())) } alpha[R+1] <- alpha[R] + 1 mustart <- (alpha[y+1] + alpha[y])/2 }) residuals <- function(object,type=c("deviance","working","response")) { if (type == "working") { res <- object$residuals } else if (type == "response") { theta <- object$family$getTheta() mu <- object$linear.predictors R = length(theta)+2 alpha <- rep(0,R+1) ## the thresholds alpha[1] <- -Inf;alpha[R+1] <- Inf alpha[2] <- -1 if (R > 2) { ind <- 3:R alpha[ind] <- alpha[2] + cumsum(exp(theta)) } fv <- mu*NA for (i in 1:(R+1)) { ind <- mu>alpha[i] & mu<=alpha[i+1] fv[ind] <- i } res <- object$y - fv } else if (type == "deviance") { y <- object$y mu <- object$fitted.values wts <- object$prior.weights res <- object$family$dev.resids(y,mu,wts) s <- attr(res,"sign") if (is.null(s)) s <- sign(y-mu) res <- as.numeric(sqrt(pmax(res,0)) * s) } res } ## residuals predict <- function(family,se=FALSE,eta=NULL,y=NULL,X=NULL, beta=NULL,off=NULL,Vb=NULL) { ## optional function to give predicted values - idea is that ## predict.gam(...,type="response") will use this, and that ## either eta will be provided, or {X, beta, off, Vb}. family$data ## contains any family specific extra information. ocat.prob <- function(theta,lp,se=NULL) { ## compute probabilities for each class in ocat model ## theta is finite cut points, lp is linear predictor, se ## is standard error on lp... R <- length(theta) dp <- prob <- matrix(0,length(lp),R+2) prob[,R+2] <- 1 for (i in 1:R) { x <- theta[i] - lp ind <- x > 0 prob[ind,i+1] <- 1/(1+exp(-x[ind])) ex <- exp(x[!ind]) prob[!ind,i+1] <- ex/(1+ex) dp[,i+1] <- prob[,i+1]*(prob[,i+1]-1) } prob <- t(diff(t(prob))) dp <- t(diff(t(dp))) ## dprob/deta if (!is.null(se)) se <- as.numeric(se)*abs(dp) list(prob,se) } ## ocat.prob theta <- family$getTheta(TRUE) if (is.null(eta)) { ## return probabilities discrete <- is.list(X) mu <- off + if (discrete) Xbd(X$Xd,beta,k=X$kd,ks=X$ks,ts=X$ts,dt=X$dt,v=X$v,qc=X$qc,drop=X$drop) else drop(X%*%beta) if (se) { se <- if (discrete) sqrt(pmax(0,diagXVXd(X$Xd,Vb,k=X$kd,ks=X$ks,ts=X$ts,dt=X$dt,v=X$v,qc=X$qc,drop=X$drop,nthreads=1))) else sqrt(pmax(0,rowSums((X%*%Vb)*X))) } else se <- NULL ##theta <- cumsum(c(-1,exp(theta))) p <- ocat.prob(theta,mu,se) if (is.null(se)) return(p) else { ## approx se on prob also returned names(p) <- c("fit","se.fit") return(p) } } else { ## return category implied by eta (i.e mean of latent) R = length(theta)+2 #alpha <- rep(0,R) ## the thresholds #alpha[1] <- -Inf;alpha[R] <- Inf alpha <- c(-Inf, theta, Inf) fv <- eta*NA for (i in 1:(R+1)) { ind <- eta>alpha[i] & eta<=alpha[i+1] fv[ind] <- i } return(fv) } } ## predict rd <- function(mu,wt,scale) { ## simulate data given fitted latent variable in mu theta <- get(".Theta") R = length(theta)+2 alpha <- rep(0,R+1) ## the thresholds alpha[1] <- -Inf;alpha[R+1] <- Inf alpha[2] <- -1 if (R > 2) { ind <- 3:R alpha[ind] <- alpha[2] + cumsum(exp(theta)) } ## ... cut points computed, now simulate latent variable, u y <- u <- runif(length(mu)) u <- mu + log(u/(1-u)) ## and allocate categories according to u and cut points... for (i in 1:R) { y[u > alpha[i]&u <= alpha[i+1]] <- i } y } environment(dev.resids) <- environment(aic) <- environment(putTheta) <- environment(getTheta) <- environment(rd) <- environment(predict) <- env structure(list(family = "Ordered Categorical", link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, dev.resids = dev.resids,Dd=Dd, aic = aic, mu.eta = stats$mu.eta, initialize = initialize,postproc=postproc, preinitialize = preinitialize, ls=ls,rd=rd,residuals=residuals, validmu = validmu, valideta = stats$valideta,n.theta=n.theta, ini.theta = iniTheta,putTheta=putTheta,predict=predict,step = 1, getTheta=getTheta,no.r.sq=TRUE), class = c("extended.family","family")) } ## end of ocat ####################### ## negative binomial... ####################### nb <- function (theta = NULL, link = "log") { ## Extended family object for negative binomial, to allow direct estimation of theta ## as part of REML optimization. Currently the template for extended family objects. linktemp <- substitute(link) if (!is.character(linktemp)) linktemp <- deparse(linktemp) if (linktemp %in% c("log", "identity", "sqrt")) stats <- make.link(linktemp) else if (is.character(link)) { stats <- make.link(link) linktemp <- link } else { if (inherits(link, "link-glm")) { stats <- link if (!is.null(stats$name)) linktemp <- stats$name } else stop(linktemp, " link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"") } ## Theta <- NULL; n.theta <- 1 if (!is.null(theta)&&theta!=0) { if (theta>0) { iniTheta <- log(theta) ## fixed theta supplied n.theta <- 0 ## signal that there are no theta parameters to estimate } else iniTheta <- log(-theta) ## initial theta supplied } else iniTheta <- 0 ## inital log theta value env <- new.env(parent = .GlobalEnv) assign(".Theta", iniTheta, envir = env) getTheta <- function(trans=FALSE) if (trans) exp(get(".Theta")) else get(".Theta") # get(".Theta") putTheta <- function(theta) assign(".Theta", theta,envir=environment(sys.function())) variance <- function(mu) mu + mu^2/exp(get(".Theta")) validmu <- function(mu) all(mu > 0) dev.resids <- function(y, mu, wt,theta=NULL) { if (is.null(theta)) theta <- get(".Theta") theta <- exp(theta) ## note log theta supplied mu[mu<=0] <- NA 2 * wt * (y * log(pmax(1, y)/mu) - (y + theta) * log((y + theta)/(mu + theta))) } Dd <- function(y, mu, theta, wt, level=0) { ## derivatives of the nb deviance... ##ltheta <- theta theta <- exp(theta) yth <- y + theta muth <- mu + theta r <- list() ## get the quantities needed for IRLS. ## Dmu2eta2 is deriv of D w.r.t mu twice and eta twice, ## Dmu is deriv w.r.t. mu once, etc... r$Dmu <- 2 * wt * (yth/muth - y/mu) r$Dmu2 <- -2 * wt * (yth/muth^2 - y/mu^2) r$EDmu2 <- 2 * wt * (1/mu - 1/muth) ## exact (or estimated) expected weight if (level>0) { ## quantities needed for first derivatives r$Dth <- -2 * wt * theta * (log(yth/muth) + (1 - yth/muth) ) r$Dmuth <- 2 * wt * theta * (1 - yth/muth)/muth r$Dmu3 <- 4 * wt * (yth/muth^3 - y/mu^3) r$Dmu2th <- 2 * wt * theta * (2*yth/muth - 1)/muth^2 r$EDmu2th <- 2 * wt / muth^2 } if (level>1) { ## whole damn lot r$Dmu4 <- 2 * wt * (6*y/mu^4 - 6*yth/muth^4) r$Dth2 <- -2 * wt * theta * (log(yth/muth) + theta*yth/muth^2 - yth/muth - 2*theta/muth + 1 + theta /yth) r$Dmuth2 <- 2 * wt * theta * (2*theta*yth/muth^2 - yth/muth - 2*theta/muth + 1)/muth r$Dmu2th2 <- 2 * wt * theta * (- 6*yth*theta/muth^2 + 2*yth/muth + 4*theta/muth - 1) /muth^2 r$Dmu3th <- 4 * wt * theta * (1 - 3*yth/muth)/muth^3 } r } aic <- function(y, mu, theta=NULL, wt, dev) { if (is.null(theta)) theta <- get(".Theta") Theta <- exp(theta) term <- (y + Theta) * log(mu + Theta) - y * log(mu) + lgamma(y + 1) - Theta * log(Theta) + lgamma(Theta) - lgamma(Theta + y) 2 * sum(term * wt) } ls <- function(y,w,theta,scale) { ## the log saturated likelihood function. Theta <- exp(theta) #vec <- !is.null(attr(theta,"vec.grad")) ## lsth by component? ylogy <- y;ind <- y>0;ylogy[ind] <- y[ind]*log(y[ind]) term <- (y + Theta) * log(y + Theta) - ylogy + lgamma(y + 1) - Theta * log(Theta) + lgamma(Theta) - lgamma(Theta + y) ls <- -sum(term*w) ## first derivative wrt theta... yth <- y+Theta lyth <- log(yth) psi0.yth <- digamma(yth) psi0.th <- digamma(Theta) term <- Theta * (lyth - psi0.yth + psi0.th-theta) #lsth <- if (vec) -term*w else -sum(term*w) lsth <- -sum(term*w) ## second deriv wrt theta... psi1.yth <- trigamma(yth) psi1.th <- trigamma(Theta) term <- Theta * (lyth - Theta*psi1.yth - psi0.yth + Theta/yth + Theta * psi1.th + psi0.th - theta -1) lsth2 <- -sum(term*w) list(ls=ls, ## saturated log likelihood lsth1=lsth, ## first deriv vector w.r.t theta - last element relates to scale, if free lsth2=lsth2) ## Hessian w.r.t. theta, last row/col relates to scale, if free } initialize <- expression({ if (any(y < 0)) stop("negative values not allowed for the negative binomial family") ##n <- rep(1, nobs) mustart <- y + (y == 0)/6 }) postproc <- function(family,y,prior.weights,fitted,linear.predictors,offset,intercept){ posr <- list() posr$null.deviance <- find.null.dev(family,y,eta=linear.predictors,offset,prior.weights) posr$family <- paste("Negative Binomial(",round(family$getTheta(TRUE),3),")",sep="") posr } rd <- function(mu,wt,scale) { Theta <- exp(get(".Theta")) rnbinom(mu,size=Theta,mu=mu) } qf <- function(p,mu,wt,scale) { Theta <- exp(get(".Theta")) qnbinom(p,size=Theta,mu=mu) } environment(dev.resids) <- environment(aic) <- environment(getTheta) <- environment(rd)<- environment(qf)<- environment(variance) <- environment(putTheta) <- env structure(list(family = "negative binomial", link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, dev.resids = dev.resids,Dd=Dd,variance=variance, aic = aic, mu.eta = stats$mu.eta, initialize = initialize,postproc=postproc,ls=ls, validmu = validmu, valideta = stats$valideta,n.theta=n.theta, ini.theta = iniTheta,putTheta=putTheta,getTheta=getTheta,rd=rd,qf=qf), class = c("extended.family","family")) } ## nb ## Tweedie.... tw <- function (theta = NULL, link = "log",a=1.01,b=1.99) { ## Extended family object for Tweedie, to allow direct estimation of p ## as part of REML optimization. ## p = (a+b*exp(theta))/(1+exp(theta)), i.e. a < p < b ## NOTE: The Tweedie density computation at low phi, low p is susceptible ## to cancellation error, which seems unavoidable. Furthermore ## there are known problems with spurious maxima in the likelihood ## w.r.t. p when the data are rounded. linktemp <- substitute(link) if (!is.character(linktemp)) linktemp <- deparse(linktemp) if (linktemp %in% c("log", "identity", "sqrt","inverse")) stats <- make.link(linktemp) else if (is.character(link)) { stats <- make.link(link) linktemp <- link } else { if (inherits(link, "link-glm")) { stats <- link if (!is.null(stats$name)) linktemp <- stats$name } else stop(gettextf("link \"%s\" not available for Tweedie family.", linktemp, collapse = ""), domain = NA) } ## Theta <- NULL; n.theta <- 1 if (!is.null(theta)&&theta!=0) { if (abs(theta)<=a||abs(theta)>=b) stop("Tweedie p must be in interval (a,b)") if (theta>0) { ## fixed theta supplied iniTheta <- log((theta-a)/(b-theta)) n.theta <- 0 ## so no theta to estimate } else iniTheta <- log((-theta-a)/(b+theta)) ## initial theta supplied } else iniTheta <- 0 ## inital log theta value env <- new.env(parent = .GlobalEnv) assign(".Theta", iniTheta, envir = env) assign(".a",a, envir = env);assign(".b",b, envir = env) getTheta <- function(trans=FALSE) { ## trans transforms to the original scale... th <- get(".Theta") a <- get(".a");b <- get(".b") if (trans) th <- if (th>0) (b+a*exp(-th))/(1+exp(-th)) else (b*exp(th)+a)/(exp(th)+1) th } putTheta <- function(theta) assign(".Theta", theta,envir=environment(sys.function())) validmu <- function(mu) all(mu > 0) variance <- function(mu) { th <- get(".Theta");a <- get(".a");b <- get(".b") p <- if (th>0) (b+a*exp(-th))/(1+exp(-th)) else (b*exp(th)+a)/(exp(th)+1) mu^p } dev.resids <- function(y, mu, wt,theta=NULL) { if (is.null(theta)) theta <- get(".Theta") a <- get(".a");b <- get(".b") p <- if (theta>0) (b+a*exp(-theta))/(1+exp(-theta)) else (b*exp(theta)+a)/(exp(theta)+1) y1 <- y + (y == 0) theta <- if (p == 1) log(y1/mu) else (y1^(1 - p) - mu^(1 - p))/(1 - p) kappa <- if (p == 2) log(y1/mu) else (y^(2 - p) - mu^(2 - p))/(2 - p) pmax(2 * (y * theta - kappa) * wt,0) } Dd <- function(y, mu, theta, wt, level=0) { ## derivatives of the tw deviance... a <- get(".a");b <- get(".b") th <- theta p <- if (th>0) (b+a*exp(-th))/(1+exp(-th)) else (b*exp(th)+a)/(exp(th)+1) dpth1 <- if (th>0) exp(-th)*(b-a)/(1+exp(-th))^2 else exp(th)*(b-a)/(exp(th)+1)^2 dpth2 <- if (th>0) ((a-b)*exp(-th)+(b-a)*exp(-2*th))/(exp(-th)+1)^3 else ((a-b)*exp(2*th)+(b-a)*exp(th))/(exp(th)+1)^3 mu1p <- mu^(1-p) mup <- mu^p r <- list() ## get the quantities needed for IRLS. ## Dmu2eta2 is deriv of D w.r.t mu twice and eta twice, ## Dmu is deriv w.r.t. mu once, etc... ymupi <- y/mup r$Dmu <- 2*wt*(mu1p - ymupi) r$Dmu2 <- 2*wt*(mu^(-1-p)*p*y + (1-p)/mup) r$EDmu2 <- (2*wt)/mup ## expected Dmu2 (weight) if (level>0) { ## quantities needed for first derivatives i1p <- 1/(1-p) y1 <- y + (y==0) ##ylogy <- y*log(y1) logmu <- log(mu) mu2p <- mu * mu1p r$Dth <- 2 * wt * ( (y^(2-p)*log(y1) - mu2p*logmu)/(2-p) + (y*mu1p*logmu - y^(2-p)*log(y1))/(1-p) - (y^(2-p) - mu2p)/(2-p)^2 + (y^(2-p) - y*mu1p)*i1p^2) *dpth1 r$Dmuth <- 2 * wt * logmu * (ymupi - mu1p)*dpth1 mup1 <- mu^(-p-1) r$Dmu3 <- -2 * wt * mup1*p*(y/mu*(p+1) + 1-p) r$Dmu2th <- 2 * wt * (mup1*y*(1-p*logmu)-(logmu*(1-p)+1)/mup )*dpth1 r$EDmu3 <- -2*wt*p*mup1 r$EDmu2th <- -2*wt*logmu/mup*dpth1 } if (level>1) { ## whole damn lot mup2 <- mup1/mu r$Dmu4 <- 2 * wt * mup2*p*(p+1)*(y*(p+2)/mu + 1 - p) y2plogy <- y^(2-p)*log(y1);y2plog2y <- y2plogy*log(y1) r$Dth2 <- 2 * wt * (((mu2p*logmu^2-y2plog2y)/(2-p) + (y2plog2y - y*mu1p*logmu^2)/(1-p) + 2*(y2plogy-mu2p*logmu)/(2-p)^2 + 2*(y*mu1p*logmu-y2plogy)/(1-p)^2 + 2 * (mu2p - y^(2-p))/(2-p)^3+2*(y^(2-p)-y*mu^(1-p))/(1-p)^3)*dpth1^2) + r$Dth*dpth2/dpth1 r$Dmuth2 <- 2 * wt * ((mu1p * logmu^2 - logmu^2*ymupi)*dpth1^2) + r$Dmuth*dpth2/dpth1 r$Dmu2th2 <- 2 * wt * ( (mup1 * logmu*y*(logmu*p - 2) + logmu/mup*(logmu*(1-p) + 2))*dpth1^2) + r$Dmu2th * dpth2/dpth1 r$Dmu3th <- 2 * wt * mup1*(y/mu*(logmu*(1+p)*p-p -p-1) +logmu*(1-p)*p + p - 1 + p)*dpth1 } r } aic <- function(y, mu, theta=NULL, wt, dev) { if (is.null(theta)) theta <- get(".Theta") a <- get(".a");b <- get(".b") p <- if (theta>0) (b+a*exp(-theta))/(1+exp(-theta)) else (b*exp(theta)+a)/(exp(theta)+1) scale <- dev/sum(wt) -2 * sum(ldTweedie(y, mu, p = p, phi = scale)[, 1] * wt) + 2 } ls <- function(y, w, theta, scale) { ## evaluate saturated log likelihood + derivs w.r.t. working params and log(scale) a <- get(".a");b <- get(".b") #vec <- !is.null(attr(theta,"vec.grad")) LS <- w * ldTweedie(y, y, rho=log(scale), theta=theta,a=a,b=b) #if (vec) lsth1 <- LS[,c(4,2)] LS <- colSums(LS) #if (!vec) lsth1 <- c(LS[4],LS[2]) lsth1 <- c(LS[4],LS[2]) ## deriv w.r.t. p then log scale lsth2 <- matrix(c(LS[5],LS[6],LS[6],LS[3]),2,2) list(ls=LS[1],lsth1=lsth1,lsth2=lsth2) } initialize <- expression({ ##n <- rep(1, nobs) mustart <- y + (y == 0)*.1 }) postproc <- function(family,y,prior.weights,fitted,linear.predictors,offset,intercept) { posr <- list() posr$null.deviance <- find.null.dev(family,y,eta=linear.predictors,offset,prior.weights) posr$family <- paste("Tweedie(p=",round(family$getTheta(TRUE),3),")",sep="") posr } rd <- function(mu,wt,scale) { th <- get(".Theta") a <- get(".a");b <- get(".b") p <- if (th>0) (b+a*exp(-th))/(1+exp(-th)) else (b*exp(th)+a)/(exp(th)+1) if (p == 2) rgamma(mu, shape = 1/scale, scale = mu * scale) else rTweedie(mu, p = p, phi = scale) } environment(Dd) <- environment(ls) <- environment(dev.resids) <- environment(aic) <- environment(getTheta) <- environment(rd) <- environment(variance) <- environment(putTheta) <- env structure(list(family = "Tweedie", link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, dev.resids = dev.resids,Dd=Dd,variance=variance,rd=rd, aic = aic, mu.eta = stats$mu.eta, initialize = initialize,postproc=postproc,ls=ls, validmu = validmu, valideta = stats$valideta,canonical="none",n.theta=n.theta, ini.theta = iniTheta,putTheta=putTheta,getTheta=getTheta,scale = -1), class = c("extended.family","family")) } ## tw ## beta regression betar <- function (theta = NULL, link = "logit",eps=.Machine$double.eps*100) { ## Extended family object for beta regression ## length(theta)=1; log theta supplied ## This serves as a prototype for working with -2logLik ## as deviance, and only dealing with saturated likelihood ## at the end. ## Written by Natalya Pya. 'saturated.ll' by Simon Wood linktemp <- substitute(link) if (!is.character(linktemp)) linktemp <- deparse(linktemp) if (linktemp %in% c("logit", "probit", "cloglog", "cauchit")) stats <- make.link(linktemp) else if (is.character(link)) { stats <- make.link(link) linktemp <- link } else { if (inherits(link, "link-glm")) { stats <- link if (!is.null(stats$name)) linktemp <- stats$name } else stop(linktemp, " link not available for beta regression; available links are \"logit\", \"probit\", \"cloglog\" and \"cauchit\"") } n.theta <- 1 if (!is.null(theta)&&theta!=0) { if (theta>0) { iniTheta <- log(theta) ## fixed theta supplied n.theta <- 0 ## signal that there are no theta parameters to estimate } else iniTheta <- log(-theta) ## initial theta supplied } else iniTheta <- 0 ## inital log theta value env <- new.env(parent = .GlobalEnv) assign(".Theta", iniTheta, envir = env) assign(".betarEps",eps, envir = env) getTheta <- function(trans=FALSE) if (trans) exp(get(".Theta")) else get(".Theta") putTheta <- function(theta) assign(".Theta", theta,envir=environment(sys.function())) variance <- function(mu) { th <- get(".Theta") mu*(1 - mu)/(1+exp(th)) } validmu <- function(mu) all(mu > 0 & mu < 1) dev.resids <- function(y, mu, wt,theta=NULL) { ## '-2*loglik' instead of deviance in REML/ML expression if (is.null(theta)) theta <- get(".Theta") theta <- exp(theta) ## note log theta supplied muth <- mu*theta ## yth <- y*theta 2* wt * (-lgamma(theta) +lgamma(muth) + lgamma(theta - muth) - muth*(log(y)-log1p(-y)) - theta*log1p(-y) + log(y) + log1p(-y)) } Dd <- function(y, mu, theta, wt, level=0) { ## derivatives of the -2*loglik... ## ltheta <- theta theta <- exp(theta) onemu <- 1 - mu; ## oney <- 1 - y muth <- mu*theta; ## yth <- y*theta onemuth <- onemu*theta ## (1-mu)*theta psi0.th <- digamma(theta) psi1.th <- trigamma(theta) psi0.muth <- digamma(muth) psi0.onemuth <- digamma(onemuth) psi1.muth <- trigamma(muth) psi1.onemuth <- trigamma(onemuth) psi2.muth <- psigamma(muth,2) psi2.onemuth <- psigamma(onemuth,2) psi3.muth <- psigamma(muth,3) psi3.onemuth <- psigamma(onemuth,3) log.yoney <- log(y)-log1p(-y) r <- list() ## get the quantities needed for IRLS. ## Dmu2eta2 is deriv of D w.r.t mu twice and eta twice, ## Dmu is deriv w.r.t. mu once, etc... r$Dmu <- 2 * wt * theta* (psi0.muth - psi0.onemuth - log.yoney) r$Dmu2 <- 2 * wt * theta^2*(psi1.muth+psi1.onemuth) r$EDmu2 <- r$Dmu2 if (level>0) { ## quantities needed for first derivatives r$Dth <- 2 * wt *theta*(-mu*log.yoney - log1p(-y)+ mu*psi0.muth+onemu*psi0.onemuth -psi0.th) r$Dmuth <- r$Dmu + 2 * wt * theta^2*(mu*psi1.muth -onemu*psi1.onemuth) r$Dmu3 <- 2 * wt *theta^3 * (psi2.muth - psi2.onemuth) r$EDmu2th <- r$Dmu2th <- 2* r$Dmu2 + 2 * wt * theta^3* (mu*psi2.muth + onemu*psi2.onemuth) } if (level>1) { ## whole lot r$Dmu4 <- 2 * wt *theta^4 * (psi3.muth+psi3.onemuth) r$Dth2 <- r$Dth +2 * wt *theta^2* (mu^2*psi1.muth+ onemu^2*psi1.onemuth-psi1.th) r$Dmuth2 <- r$Dmuth + 2 * wt *theta^2* (mu^2*theta*psi2.muth+ 2*mu*psi1.muth - theta*onemu^2*psi2.onemuth - 2*onemu*psi1.onemuth) r$Dmu2th2 <- 2*r$Dmu2th + 2* wt * theta^3* (mu^2*theta*psi3.muth +3*mu*psi2.muth+ onemu^2*theta*psi3.onemuth + 3*onemu*psi2.onemuth ) r$Dmu3th <- 3*r$Dmu3 + 2 * wt *theta^4*(mu*psi3.muth-onemu*psi3.onemuth) } r } aic <- function(y, mu, theta=NULL, wt, dev) { if (is.null(theta)) theta <- get(".Theta") theta <- exp(theta) muth <- mu*theta term <- -lgamma(theta)+lgamma(muth)+lgamma(theta-muth)-(muth-1)*log(y)- (theta-muth-1)*log1p(-y) ## `-' log likelihood for each observation 2 * sum(term * wt) } ls <- function(y,w,theta,scale) { ## the log saturated likelihood function. ## ls is defined as zero for REML/ML expression as deviance is defined as -2*log.lik list(ls=0,## saturated log likelihood lsth1=0, ## first deriv vector w.r.t theta - last element relates to scale lsth2=0) ##Hessian w.r.t. theta } ## preinitialization to reset G$y values of <=0 and >=1... ## code to evaluate in estimate.gam... ## reset G$y values of <=0 and >= 1 to eps and 1-eps... #preinitialize <- NULL ## keep codetools happy #eval(parse(text=paste("preinitialize <- expression({\n eps <- ",eps, # "\n G$y[G$y >= 1-eps] <- 1 - eps\n G$y[G$y<= eps] <- eps })"))) preinitialize <- function(y,family) { eps <- get(".betarEps") y[y >= 1-eps] <- 1 - eps;y[y<= eps] <- eps return(list(y=y)) } # preinitialize <- expression({ # eps <- 1e-7 # G$y[G$y >= 1-eps] <- 1 - eps # G$y[G$y<= eps] <- eps # }) saturated.ll <- function(y,wt,theta=NULL){ ## function to find the saturated loglik by Newton method, ## searching for the mu (on logit scale) that max loglik given theta and data... gbh <- function(y,eta,phi,deriv=FALSE,a=1e-8,b=1-a) { ## local function evaluating log likelihood (l), gradient and second deriv ## vectors for beta... a and b are min and max mu values allowed. ## mu = (a + b*exp(eta))/(1+exp(eta)) ind <- eta>0 expeta <- mu <- eta; expeta[ind] <- exp(-eta[ind]);expeta[!ind] <- exp(eta[!ind]) mu[ind] <- (a*expeta[ind] + b)/(1+expeta[ind]) mu[!ind] <- (a + b*expeta[!ind])/(1+expeta[!ind]) l <- dbeta(y,phi*mu,phi*(1-mu),log=TRUE) if (deriv) { g <- phi * log(y) - phi * log1p(-y) - phi * digamma(mu*phi) + phi * digamma((1-mu)*phi) h <- -phi^2*(trigamma(mu*phi)+trigamma((1-mu)*phi)) dmueta2 <- dmueta1 <- eta dmueta1 <- expeta*(b-a)/(1+expeta)^2 dmueta2 <- sign(eta)* ((a-b)*expeta+(b-a)*expeta^2)/(expeta+1)^3 h <- h * dmueta1^2 + g * dmueta2 g <- g * dmueta1 } else g=h=NULL list(l=l,g=g,h=h,mu=mu) } ## gbh ## now Newton loop... eps <- get(".betarEps") eta <- y a <- eps;b <- 1 - eps y[y1-eps] <- 1-eps eta[y<=eps*1.2] <- eps *1.2 eta[y>=1-eps*1.2] <- 1-eps*1.2 eta <- log((eta-a)/(b-eta)) mu <- LS <- ii <- 1:length(y) for (i in 1:200) { ls <- gbh(y,eta,theta,TRUE,a=eps/10) conv <- abs(ls$g)0) { ## some convergences occured LS[ii[conv]] <- ls$l[conv] ## store converged mu[ii[conv]] <- ls$mu[conv] ## store mu at converged ii <- ii[!conv] ## drop indices if (length(ii)>0) { ## drop the converged y <- y[!conv];eta <- eta[!conv] ls$l <- ls$l[!conv];ls$g <- ls$g[!conv];ls$h <- ls$h[!conv] } else break ## nothing left to do } h <- -ls$h hmin <- max(h)*1e-4 h[h2 delta[ind] <- sign(delta[ind])*2 ## step length limit ls1 <- gbh(y,eta+delta,theta,FALSE,a=eps/10); ## did it work? ind <- ls1$l0&&k<20) { ## step halve only failed steps k <- k + 1 delta[ind] <- delta[ind]/2 ls1$l[ind] <- gbh(y[ind],eta[ind]+delta[ind],theta,FALSE,a=eps/10)$l ind <- ls1$l0) { LS[ii] <- ls$l warning("saturated likelihood may be inaccurate") } list(f=sum(wt*LS),term=LS,mu=mu) ## fields f (sat lik) and term (individual datum sat lik) expected } ## saturated.ll ## computes deviance, null deviance, family label ## requires prior weights, family, y, fitted values, offset, intercept indicator postproc <- function(family,y,prior.weights,fitted,linear.predictors,offset,intercept) { ## code to evaluate in estimate.gam, to find the saturated ## loglik by Newton method ## searching for the mu (on logit scale) that max loglik given theta... # wts <- object$prior.weights theta <- family$getTheta(trans=TRUE) ## exp theta lf <- family$saturated.ll(y, prior.weights,theta) ## storing the saturated loglik for each datum... ##object$family$data <- list(ls = lf$term,mu.ls = lf$mu) l2 <- family$dev.resids(y,fitted,prior.weights) posr <- list() posr$deviance <- 2*lf$f + sum(l2) wtdmu <- if (intercept) sum(prior.weights * y)/sum(prior.weights) else family$linkinv(offset) posr$null.deviance <- 2*lf$f + sum(family$dev.resids(y, wtdmu, prior.weights)) posr$family <- paste("Beta regression(",round(theta,3),")",sep="") posr } ## postproc initialize <- expression({ ##n <- rep(1, nobs) mustart <- y }) residuals <- function(object,type=c("deviance","working","response","pearson")) { if (type == "working") { res <- object$residuals } else if (type == "response") { res <- object$y - object$fitted.values } else if (type == "deviance") { y <- object$y mu <- object$fitted.values wts <- object$prior.weights lf <- object$family$saturated.ll(y, wts,object$family$getTheta(TRUE)) #object$family$data$ls <- lf$term res <- 2*lf$term + object$family$dev.resids(y,mu,wts) res[res<0] <- 0 s <- sign(y-mu) res <- sqrt(res) * s } else if (type == "pearson") { mu <- object$fitted.values res <- (object$y - mu)/object$family$variance(mu)^.5 } res } ## residuals rd <- function(mu,wt,scale) { ## simulate data given fitted latent variable in mu Theta <- exp(get(".Theta")) r <- rbeta(mu,shape1=Theta*mu,shape2=Theta*(1-mu)) eps <- get(".betarEps") r[r>=1-eps] <- 1 - eps r[r=1-eps] <- 1 - eps q[q0) { ## quantities needed for first derivatives nu1nusig2a <- nu1/nusig2a nu2nu <- nu2/nu fym <- f*ym; ff1 <- f*f1; f1ym <- f1*ym; fymf1 <- fym*f1 ymsig2a <- ym/sig2a oo$EDmu2th <- oo$Dmu2th <- oo$Dmuth <- oo$Dth <- matrix(0,n,2) oo$Dth[,1] <- 1 * wt * nu2 * (log(a) - fym/nu) oo$Dth[,2] <- -2 * wt * fym oo$Dmuth[,1] <- 2 * wt *(f - ymsig2a - fymf1)*nu2nu oo$Dmuth[,2] <- 4* wt* f* (1- f1ym) oo$Dmu3 <- 4 * wt * f * (3/nusig2a - 4*f1^2) oo$Dmu2th[,1] <- 2* wt * (-nu1nusig2a + 1/sig2a + 5*ff1- 2*f1ym/sig2a - 4*fymf1*f1)*nu2nu oo$Dmu2th[,2] <- 4*wt*(-nu1nusig2a + ff1*5 - 4*ff1*f1ym) oo$EDmu3 <- rep(0,n) oo$EDmu2th <- cbind(4/(sig^2*(nu+3)^2)*exp(theta[1]),-2*oo$EDmu2) } if (level>1) { ## whole lot ## nu1nu2 <- nu1*nu2; nu1nu <- nu1/nu fymf1ym <- fym*f1ym; f1ymf1 <- f1ym*f1 oo$Dmu4 <- 12 * wt * (-nu1nusig2a/nusig2a + 8*ff1/nusig2a - 8*ff1 *f1^2) n2d <- 3 # number of the 2nd order derivatives oo$Dmu3th <- matrix(0,n,2) oo$Dmu2th2 <- oo$Dmuth2 <- oo$Dth2 <- matrix(0,n,n2d) oo$Dmu3th[,1] <- 4*wt*(-6*f/nusig2a + 3*f1/sig2a + 18*ff1*f1 - 4*f1ymf1/sig2a - 12*nu1ym*f1^4)*nu2nu oo$Dmu3th[,2] <- 48*wt* f* (- 1/nusig2a + 3*f1^2 - 2*f1ymf1*f1) oo$Dth2[,1] <- 1*wt *(nu2*log(a) +nu2nu*ym^2*(-2*nu2-nu1+ 2*nu1*nu2nu - nu1*nu2nu*f1ym)/nusig2a) ## deriv of D w.r.t. theta1 theta1 oo$Dth2[,2] <- 2*wt*(fym - ym*ymsig2a - fymf1ym)*nu2nu ## deriv of D wrt theta1 theta2 oo$Dth2[,3] <- 4 * wt * fym *(1 - f1ym) ## deriv of D wrt theta2 theta2 term <- 2*nu2nu - 2*nu1nu*nu2nu -1 + nu1nu oo$Dmuth2[,1] <- 2*wt*f1*nu2*(term - 2*nu2nu*f1ym + 4*fym*nu2nu/nu - fym/nu - 2*fymf1ym*nu2nu/nu) oo$Dmuth2[,2] <- 4*wt* (-f + ymsig2a + 3*fymf1 - ymsig2a*f1ym - 2*fymf1*f1ym)*nu2nu oo$Dmuth2[,3] <- 8*wt* f * (-1 + 3*f1ym - 2*f1ym^2) oo$Dmu2th2[,1] <- 2*wt*nu2*(-term + 10*nu2nu*f1ym - 16*fym*nu2nu/nu - 2*f1ym + 5*nu1nu*f1ym - 8*nu2nu*f1ym^2 + 26*fymf1ym*nu2nu/nu - 4*nu1nu*f1ym^2 - 12*nu1nu*nu2nu*f1ym^3)/nusig2a oo$Dmu2th2[,2] <- 4*wt*(nu1nusig2a - 1/sig2a - 11*nu1*f1^2 + 5*f1ym/sig2a + 22*nu1*f1ymf1*f1 - 4*f1ym^2/sig2a - 12*nu1*f1ymf1^2)*nu2nu oo$Dmu2th2[,3] <- 8*wt * (nu1nusig2a - 11*nu1*f1^2 + 22*nu1*f1ymf1*f1 - 12*nu1*f1ymf1^2) } oo } ## end of Dd aic <- function(y, mu, theta=NULL, wt, dev) { min.df <- get(".min.df") if (is.null(theta)) theta <- get(".Theta") nu <- exp(theta[1])+min.df; sig <- exp(theta[2]) term <- -lgamma((nu+1)/2)+ lgamma(nu/2) + log(sig*(pi*nu)^.5) + (nu+1)*log1p(((y-mu)/sig)^2/nu)/2 ## `-'log likelihood for each observation 2 * sum(term * wt) } ls <- function(y,w,theta,scale) { ## the log saturated likelihood function. ## (Note these are correct but do not correspond to NP notes) if (length(w)==1) w <- rep(w,length(y)) #vec <- !is.null(attr(theta,"vec.grad")) min.df <- get(".min.df") nu <- exp(theta[1])+min.df; sig <- exp(theta[2]); nu2 <- nu-min.df; nu2nu <- nu2/nu; nu12 <- (nu+1)/2 term <- lgamma(nu12) - lgamma(nu/2) - log(sig*(pi*nu)^.5) ls <- sum(term*w) ## first derivative wrt theta... lsth2 <- matrix(0,2,2) ## rep(0, 3) term <- nu2 * digamma(nu12)/2- nu2 * digamma(nu/2)/2 - 0.5*nu2nu #lsth <- if (vec) cbind(w*term,-1*w) else c(sum(w*term),sum(-w)) lsth <- c(sum(w*term),sum(-w)) ## second deriv... term <- nu2^2 * trigamma(nu12)/4 + nu2 * digamma(nu12)/2 - nu2^2 * trigamma(nu/2)/4 - nu2 * digamma(nu/2)/2 + 0.5*(nu2nu)^2 - 0.5*nu2nu lsth2[1,1] <- sum(term*w) lsth2[1,2] <- lsth2[2,1] <- lsth2[2,2] <- 0 list(ls=ls,## saturated log likelihood lsth1=lsth, ## first derivative vector wrt theta lsth2=lsth2) ## Hessian wrt theta } preinitialize <- function(y,family) { ## initialize theta from raw observations.. if (family$n.theta>0) { ## low df and low variance promotes indefiniteness. ## Better to start with moderate df and fairly high ## variance... Theta <- c(1.5, log(0.8*sd(y))) return(list(Theta=Theta)) } ## otherwise fixed theta supplied } initialize <- expression({ if (any(is.na(y))) stop("NA values not allowed for the scaled t family") ##n <- rep(1, nobs) mustart <- y + (y == 0)*.1 }) postproc <- function(family,y,prior.weights,fitted,linear.predictors,offset,intercept) { posr <- list() posr$null.deviance <- find.null.dev(family,y,eta=linear.predictors,offset,prior.weights) th <- round(family$getTheta(TRUE),3) if (th[1]>999) th[1] <- Inf posr$family <- paste("Scaled t(",paste(th,collapse=","),")",sep="") posr } rd <- function(mu,wt,scale) { ## simulate data given fitted latent variable in mu theta <- get(".Theta");min.df <- get(".min.df") nu <- exp(theta[1])+min.df; sig <- exp(theta[2]) n <- length(mu) stats::rt(n=n,df=nu)*sig + mu } environment(dev.resids) <- environment(aic) <- environment(getTheta) <- environment(Dd) <- environment(ls) <- environment(rd)<- environment(variance) <- environment(putTheta) <- env structure(list(family = "scaled t", link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, dev.resids = dev.resids,Dd=Dd,variance=variance,postproc=postproc, aic = aic, mu.eta = stats$mu.eta, initialize = initialize,ls=ls, preinitialize=preinitialize, validmu = validmu, valideta = stats$valideta,n.theta=n.theta, ini.theta = iniTheta,putTheta=putTheta,getTheta=getTheta, rd=rd), class = c("extended.family","family")) } ## scat ## zero inflated Poisson (Simon Wood)... lind <- function(l,th,deriv=0,k=0) { ## evaluate th[1] + exp(th[2])*l and some derivs th[2] <- exp(th[2]) r <- list(p = th[1] + (k+th[2])*l) r$p.l <- k + th[2] ## p_l r$p.ll <- 0 ## p_ll if (deriv) { n <- length(l); r$p.lllth <- r$p.llth <- r$p.lth <- r$p.th <- matrix(0,n,2) r$p.th[,1] <- 1 ## dp/dth1 r$p.th[,2] <- th[2]*l ## dp/dth2 r$p.lth[,2] <- th[2] ## p_lth2 r$p.llll <- r$p.lll <- 0 ## p_lll,p_llll r$p.llth2 <- r$p.lth2 <- r$p.th2 <- matrix(0,n,3) ## ordered l_th1th1,l_th1th2,l_th2th2 r$p.th2[,3] <- l*th[2] ## p_th2th2 r$p.lth2[,3] <- th[2] ## p_lth2th2 } r } ## lind logid <- function(l,th,deriv=0,a=0,trans=TRUE) { ## evaluate exp(th[1]+th[2]*l)/(1+exp(th[1]+th[2]*l)) ## and some of its derivatives ## if trans==TRUE then it is assumed that the ## transformation th[2] = exp(th[2]) is applied on input b <- 1-2*a ## x is dth[2]/dth[2]' where th[2]' is input version, xx is second deriv over first if (trans) { xx <- 1; x <- th[2] <- exp(th[2])} else { x <- 1;xx <- 0} p <- f <- th[1] + th[2] * l ind <- f > 0; ef <- exp(f[!ind]) p[!ind] <- ef/(1+ef); p[ind] <- 1/(1+exp(-f[ind])) r <- list(p = a + b * p) a1 <- p*(1-p); a2 <- p*(p*(2*p-3)+1) r$p.l <- b * th[2]*a1; ## p_l r$p.ll <- b * th[2]^2*a2 ## p_ll if (deriv>0) { n <- length(l); r$p.lth <- r$p.th <- matrix(0,n,2) r$p.th[,1] <- b * a1 ## dp/dth1 r$p.th[,2] <- b * l*a1 * x ## dp/dth2 r$p.lth[,1] <- b * th[2]*a2 ## p_lth1 r$p.lth[,2] <- b * (l*th[2]*a2 + a1) * x ## p_lth2 a3 <- p*(p*(p*(-6*p + 12) -7)+1) r$p.lll <- b * th[2]^3*a3 ## p_lll r$p.llth <- matrix(0,n,2) r$p.llth[,1] <- b * th[2]^2 * a3 ## p_llth1 r$p.llth[,2] <- b * (l*th[2]^2*a3 + 2*th[2]*a2) * x ## p_ppth2 a4 <- p*(p*(p*(p*(p*24-60)+50)-15)+1) r$p.llll <- b * th[2]^4*a4 ## p_llll r$p.lllth <- matrix(0,n,2) r$p.lllth[,1] <- b * th[2]^3*a4 ## p_lllth1 r$p.lllth[,2] <- b * (th[2]^3*l*a4 + 3*th[2]^2*a3) * x ## p_lllth2 r$p.llth2 <- r$p.lth2 <- r$p.th2 <- matrix(0,n,3) ## ordered l_th1th1,l_th1th2,l_th2th2 r$p.th2[,1] <- b * a2 ## p_th1th1 r$p.th2[,2] <- b * l*a2 * x ## p_th1th2 r$p.th2[,3] <- b * l*l*a2 * x * x + xx* r$p.th[,2] ## p_th2th2 r$p.lth2[,1] <- b * th[2]*a3 ## p_lth1th1 r$p.lth2[,2] <- b * (th[2]*l*a3 + a2) * x ## p_lth1th2 r$p.lth2[,3] <- b * (l*l*a3*th[2] + 2*l*a2) *x * x + xx*r$p.lth[,2] ## p_lth2th2 r$p.llth2[,1] <- b * th[2]^2*a4 ## p_llth1th1 r$p.llth2[,2] <- b * (th[2]^2*l*a4 + 2*th[2]*a3) *x ## p_llth1th2 r$p.llth2[,3] <- b * (l*l*th[2]^2*a4 + 4*l*th[2]*a3 + 2*a2) *x*x + xx*r$p.llth[,2] ## p_llth2th2 } r } ## logid ziP <- function (theta = NULL, link = "identity",b=0) { ## zero inflated Poisson parameterized in terms of the log Poisson parameter, gamma. ## eta = theta[1] + exp(theta[2])*gamma), and 1-p = exp(-exp(eta)) where p is ## probability of presence. linktemp <- substitute(link) if (!is.character(linktemp)) linktemp <- deparse(linktemp) if (linktemp %in% c("identity")) { stats <- make.link(linktemp) } else stop(linktemp, " link not available for zero inflated; available link for `lambda' is only \"loga\"") ## Theta <- NULL; n.theta <- 2 if (!is.null(theta)) { ## fixed theta supplied iniTheta <- c(theta[1],theta[2]) n.theta <- 0 ## no thetas to estimate } else iniTheta <- c(0,0) ## inital theta value - start at Poisson env <- new.env(parent = environment(ziP))# new.env(parent = .GlobalEnv) if (b<0) b <- 0; assign(".b", b, envir = env) assign(".Theta", iniTheta, envir = env) getTheta <- function(trans=FALSE) { ## trans transforms to the original scale... th <- get(".Theta") if (trans) { th[2] <- get(".b") + exp(th[2]) } th } putTheta <- function(theta) assign(".Theta", theta,envir=environment(sys.function())) validmu <- function(mu) all(is.finite(mu)) dev.resids <- function(y, mu, wt,theta=NULL) { ## this version ignores saturated likelihood if (is.null(theta)) theta <- get(".Theta") b <- get(".b") p <- theta[1] + (b + exp(theta[2])) * mu ## l.p. for prob present -2*zipll(y,mu,p,deriv=0)$l } Dd <- function(y, mu, theta, wt=NULL, level=0) { ## here mu is lin pred for Poisson mean so E(y) = exp(mu) ## Deviance for log lik of zero inflated Poisson. ## code here is far more general than is needed - could deal ## with any 2 parameter mapping of lp of mean to lp of prob presence. if (is.null(theta)) theta <- get(".Theta") deriv <- 1; if (level==1) deriv <- 2 else if (level>1) deriv <- 4 b <- get(".b") g <- lind(mu,theta,level,b) ## the derviatives of the transform mapping mu to p z <- zipll(y,mu,g$p,deriv) oo <- list();n <- length(y) if (is.null(wt)) wt <- rep(1,n) oo$Dmu <- -2*wt*(z$l1[,1] + z$l1[,2]*g$p.l) oo$Dmu2 <- -2*wt*(z$l2[,1] + 2*z$l2[,2]*g$p.l + z$l2[,3]*g$p.l^2 + z$l1[,2]*g$p.ll) ## WARNING: following requires z$El1 term to be added if transform modified so ## that g$p.ll != 0.... oo$EDmu2 <- -2*wt*(z$El2[,1] + 2*z$El2[,2]*g$p.l + z$El2[,3]*g$p.l^2) if (level>0) { ## l,p - ll,lp,pp - lll,llp,lpp,ppp - llll,lllp,llpp,lppp,pppp oo$Dth <- -2*wt*z$l1[,2]*g$p.th ## l_p p_th oo$Dmuth <- -2*wt*(z$l2[,2]*g$p.th + z$l2[,3]*g$p.l*g$p.th + z$l1[,2]*g$p.lth) oo$Dmu2th <- -2*wt*(z$l3[,2]*g$p.th + 2*z$l3[,3]*g$p.l*g$p.th + 2* z$l2[,2]*g$p.lth + z$l3[,4]*g$p.l^2*g$p.th + z$l2[,3]*(2*g$p.l*g$p.lth + g$p.th*g$p.ll) + z$l1[,2]*g$p.llth) oo$Dmu3 <- -2*wt*(z$l3[,1] + 3*z$l3[,2]*g$p.l + 3*z$l3[,3]*g$p.l^2 + 3*z$l2[,2]*g$p.ll + z$l3[,4]*g$p.l^3 +3*z$l2[,3]*g$p.l*g$p.ll + z$l1[,2]*g$p.lll) } if (level>1) { p.thth <- matrix(0,n,3);p.thth[,1] <- g$p.th[,1]^2 p.thth[,2] <- g$p.th[,1]*g$p.th[,2];p.thth[,3] <- g$p.th[,2]^2 oo$Dth2 <- -2*wt*(z$l2[,3]*p.thth + z$l1[,2]*g$p.th2) p.lthth <- matrix(0,n,3);p.lthth[,1] <- g$p.th[,1]*g$p.lth[,1]*2 p.lthth[,2] <- g$p.th[,1]*g$p.lth[,2] + g$p.th[,2]*g$p.lth[,1]; p.lthth[,3] <- g$p.th[,2]*g$p.lth[,2]*2 oo$Dmuth2 <- -2*wt*( z$l3[,3]*p.thth + z$l2[,2]*g$p.th2 + z$l3[,4]*g$p.l*p.thth + z$l2[,3]*(g$p.th2*g$p.l + p.lthth) + z$l1[,2]*g$p.lth2) p.lthlth <- matrix(0,n,3);p.lthlth[,1] <- g$p.lth[,1]*g$p.lth[,1]*2 p.lthlth[,2] <- g$p.lth[,1]*g$p.lth[,2] + g$p.lth[,2]*g$p.lth[,1]; p.lthlth[,3] <- g$p.lth[,2]*g$p.lth[,2]*2 p.llthth <- matrix(0,n,3);p.llthth[,1] <- g$p.th[,1]*g$p.llth[,1]*2 p.llthth[,2] <- g$p.th[,1]*g$p.llth[,2] + g$p.th[,2]*g$p.llth[,1]; p.llthth[,3] <- g$p.th[,2]*g$p.llth[,2]*2 oo$Dmu2th2 <- -2*wt*(z$l4[,3]*p.thth + z$l3[,2]*g$p.th2 + 2*z$l4[,4] * p.thth *g$p.l + 2*z$l3[,3]*(g$p.th2*g$p.l + p.lthth) + 2*z$l2[,2]*g$p.lth2 + z$l4[,5]*p.thth*g$p.l^2 + z$l3[,4]*(g$p.th2*g$p.l^2 + 2*p.lthth*g$p.l + p.thth*g$p.ll) + z$l2[,3]*(p.lthlth + 2*g$p.l*g$p.lth2 + p.llthth + g$p.th2*g$p.ll) + z$l1[,2]*g$p.llth2) oo$Dmu3th <- -2*wt*(z$l4[,2]*g$p.th + 3*z$l4[,3]*g$p.th*g$p.l + 3*z$l3[,2]*g$p.lth + 2*z$l4[,4]*g$p.th*g$p.l^2 + z$l3[,3]*(6*g$p.lth*g$p.l + 3*g$p.th*g$p.ll) + 3*z$l2[,2]*g$p.llth + z$l4[,4]*g$p.th*g$p.l^2 + z$l4[,5]*g$p.th*g$p.l^3 + 3*z$l3[,4]*(g$p.l^2*g$p.lth + g$p.th*g$p.l*g$p.ll) + z$l2[,3]*(3*g$p.lth*g$p.ll + 3*g$p.l*g$p.llth + g$p.th*g$p.lll) + z$l1[,2]*g$p.lllth) oo$Dmu4 <- -2*wt*(z$l4[,1] + 4*z$l4[,2]*g$p.l + 6*z$l4[,3]*g$p.l^2 + 6*z$l3[,2]*g$p.ll + 4*z$l4[,4]*g$p.l^3 + 12*z$l3[,3]*g$p.l*g$p.ll + 4*z$l2[,2]*g$p.lll + z$l4[,5] * g$p.l^4 + 6*z$l3[,4]*g$p.l^2*g$p.ll + z$l2[,3] *(4*g$p.l*g$p.lll + 3*g$p.ll^2) + z$l1[,2]*g$p.llll) } oo } ## end Dd for ziP aic <- function(y, mu, theta=NULL, wt, dev) { if (is.null(theta)) theta <- get(".Theta") b <- get(".b") p <- theta[1] + (b+ exp(theta[2])) * mu ## l.p. for prob present sum(-2*wt*zipll(y,mu,p,0)$l) } ls <- function(y,w,theta,scale) { ## the log saturated likelihood function. ## ls is defined as zero for REML/ML expression as deviance is defined as -2*log.lik #vec <- !is.null(attr(theta,"vec.grad")) #lsth1 <- if (vec) matrix(0,length(y),2) else c(0,0) list(ls=0,## saturated log likelihood lsth1=c(0,0), ## first deriv vector w.r.t theta - last element relates to scale lsth2=matrix(0,2,2)) ##Hessian w.r.t. theta } initialize <- expression({ if (any(y < 0)) stop("negative values not allowed for the zero inflated Poisson family") if (all.equal(y,round(y))!=TRUE) { stop("Non-integer response variables are not allowed with ziP ") } if ((min(y)==0&&max(y)==1)) stop("Using ziP for binary data makes no sense") ##n <- rep(1, nobs) mustart <- log(y + (y==0)/5) }) ## compute family label, deviance, null.deviance... ## requires prior weights, y, family, linear predictors postproc <- function(family,y,prior.weights,fitted,linear.predictors,offset,intercept) { posr <- list() posr$family <- paste("Zero inflated Poisson(",paste(round(family$getTheta(TRUE),3),collapse=","),")",sep="") ## need to fix deviance here!! ## wts <- object$prior.weights lf <- family$saturated.ll(y,family,prior.weights) ## storing the saturated loglik for each datum... ##object$family$data <- list(ls = lf) l2 <- family$dev.resids(y,linear.predictors,prior.weights) posr$deviance <- sum(l2-lf) fnull <- function(gamma,family,y,wt) { ## evaluate deviance for single parameter model sum(family$dev.resids(y, rep(gamma,length(y)), wt)) } meany <- mean(y) posr$null.deviance <- optimize(fnull,interval=c(meany/5,meany*3),family=family,y=y,wt = prior.weights)$objective - sum(lf) ## object$weights <- pmax(0,object$working.weights) ## Fisher can be too extreme ## E(y) = p * E(y) - but really can't mess with fitted.values if e.g. rd is to work. posr } ## postproc rd <- function(mu,wt,scale) { ## simulate data given fitted latent variable in mu rzip <- function(gamma,theta) { ## generate ziP deviates according to model and lp gamma y <- gamma; n <- length(y) lambda <- exp(gamma) mlam <- max(c(lambda[is.finite(lambda)],.Machine$double.eps^.2)) lambda[!is.finite(lambda)] <- mlam b <- get(".b") eta <- theta[1] + (b+exp(theta[2]))*gamma p <- 1- exp(-exp(eta)) ind <- p > runif(n) y[!ind] <- 0 #np <- sum(ind) ## generate from zero truncated Poisson, given presence... lami <- lambda[ind] yi <- p0 <- dpois(0,lami) nearly1 <- 1 - .Machine$double.eps*10 ii <- p0 > nearly1 yi[ii] <- 1 ## lambda so low that almost certainly y=1 yi[!ii] <- qpois(runif(sum(!ii),p0[!ii],nearly1),lami[!ii]) y[ind] <- yi y } rzip(mu,get(".Theta")) } saturated.ll <- function(y,family,wt=rep(1,length(y))) { ## function to get saturated ll for ziP - ## actually computes -2 sat ll. pind <- y>0 ## only these are interesting wt <- wt[pind] y <- y[pind]; mu <- log(y) keep.on <- TRUE theta <- family$getTheta() r <- family$Dd(y,mu,theta,wt) l <- family$dev.resids(y,mu,wt,theta) lmax <- max(abs(l)) ucov <- abs(r$Dmu) > lmax*1e-7 k <- 0 while (keep.on) { step <- -r$Dmu/r$Dmu2 step[!ucov] <- 0 mu1 <- mu + step l1 <- family$dev.resids(y,mu1,wt,theta) ind <- l1>l & ucov kk <- 0 while (sum(ind)>0&&kk<50) { step[ind] <- step[ind]/2 mu1 <- mu + step l1 <- family$dev.resids(y,mu1,wt,theta) ind <- l1>l & ucov kk <- kk + 1 } mu <- mu1;l <- l1 r <- family$Dd(y,mu,theta,wt) ucov <- abs(r$Dmu) > lmax*1e-7 k <- k + 1 if (all(!ucov)||k==100) keep.on <- FALSE } l1 <- rep(0,length(pind));l1[pind] <- l l1 } ## saturated.ll residuals <- function(object,type=c("deviance","working","response")) { if (type == "working") { res <- object$residuals } else if (type == "response") { res <- object$y - predict.gam(object,type="response") } else if (type == "deviance") { y <- object$y mu <- object$linear.predictors wts <- object$prior.weights res <- object$family$dev.resids(y,mu,wts) ## next line is correct as function returns -2*saturated.log.lik res <- res - object$family$saturated.ll(y,object$family,wts) fv <- predict.gam(object,type="response") s <- attr(res,"sign") if (is.null(s)) s <- sign(y-fv) res <- as.numeric(sqrt(pmax(res,0)) * s) } res } ## residuals (ziP) predict <- function(family,se=FALSE,eta=NULL,y=NULL,X=NULL, beta=NULL,off=NULL,Vb=NULL) { ## optional function to give predicted values - idea is that ## predict.gam(...,type="response") will use this, and that ## either eta will be provided, or {X, beta, off, Vb}. family$data ## contains any family specific extra information. theta <- family$getTheta() if (is.null(eta)) { ## return probabilities discrete <- is.list(X) ## linear predictor for poisson parameter... gamma <- off + if (discrete) Xbd(X$Xd,beta,k=X$kd,ks=X$ks,ts=X$ts,dt=X$dt,v=X$v,qc=X$qc,drop=X$drop) else drop(X%*%beta) if (se) { se <- if (discrete) sqrt(pmax(0,diagXVXd(X$Xd,Vb,k=X$kd,ks=X$ks,ts=X$ts,dt=X$dt,v=X$v,qc=X$qc,drop=X$drop,nthreads=1))) else sqrt(pmax(0,rowSums((X%*%Vb)*X))) ## se of lin pred } else se <- NULL #gamma <- drop(X%*%beta + off) ## linear predictor for poisson parameter #se <- if (se) drop(sqrt(pmax(0,rowSums((X%*%Vb)*X)))) else NULL ## se of lin pred } else { se <- NULL; gamma <- eta} ## now compute linear predictor for probability of presence... b <- get(".b") eta <- theta[1] + (b+exp(theta[2]))*gamma et <- exp(eta) mu <- p <- 1 - exp(-et) fv <- lambda <- exp(gamma) ind <- gamma < log(.Machine$double.eps)/2 mu[!ind] <- lambda[!ind]/(1-exp(-lambda[!ind])) mu[ind] <- 1 fv <- list(p*mu) ## E(y) if (is.null(se)) return(fv) else { dp.dg <- p ind <- eta < log(.Machine$double.xmax)/2 dp.dg[!ind] <- 0 dp.dg <- exp(-et)*et*exp(theta[2]) dmu.dg <- (lambda + 1)*mu - mu^2 fv[[2]] <- abs(dp.dg*mu+dmu.dg*p)*se names(fv) <- c("fit","se.fit") return(fv) } } ## predict environment(saturated.ll) <- environment(dev.resids) <- environment(Dd) <- environment(aic) <- environment(getTheta) <- environment(rd) <- environment(predict) <- environment(putTheta) <- env structure(list(family = "zero inflated Poisson", link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, dev.resids = dev.resids,Dd=Dd, rd=rd,residuals=residuals, aic = aic, mu.eta = stats$mu.eta, g2g = stats$g2g,g3g=stats$g3g, g4g=stats$g4g, #preinitialize=preinitialize, initialize = initialize,postproc=postproc,ls=ls,no.r.sq=TRUE, validmu = validmu, valideta = stats$valideta,n.theta=n.theta,predict=predict, ini.theta = iniTheta,putTheta=putTheta,getTheta=getTheta,saturated.ll = saturated.ll), class = c("extended.family","family")) } ## ziP mgcv/R/soap.r0000755000176200001440000007510313551273573012560 0ustar liggesusers## code for soap film smoothing to deal with difficult boundary regions ## Copyright Simon Wood 2006-2012 unconstrain <- function(object,beta) { ## function to produce full version of constrained coefficients of ## smooth object. Returned vector may have an attribute "constant" ## to be subtraccted from results. ## NOTE: sum to zero on some parameters only branch is not fully ## tested (also unused at present)! del.index <- attr(object,"del.index") if (!is.null(del.index)) { beta.full <- rep(0,length(beta)+length(del.index)) k <- 1;j <- 1 for (i in 1:length(beta.full)) { if (j <= length(del.index) && i==del.index[j]) { beta.full[i] <- 0;j <- j + 1 } else { beta.full[i] <- beta[k];k <- k + 1 } } beta <- beta.full } ## end of del.index handling qrc <- attr(object,"qrc") if (!is.null(qrc)) { ## then smoothCon absorbed constraints j <- attr(object,"nCons") if (j>0) { ## there were constraints to absorb - need to untransform k <- length(beta) + j if (inherits(qrc,"qr")) { indi <- attr(object,"indi") ## index of constrained parameters if (is.null(indi)) { ## X <- t(qr.qty(qrc,t(X))[(j+1):k,,drop=FALSE]) ## XZ beta <- qr.qy(qrc,c(rep(0,j),beta)) } else { ## only some parameters are subject to constraint ## NOTE: this branch not fully tested ##nx <- length(indi) ##nc <- j;nz <- nx - nc Xbeta <- qr.qy(qrc,c(rep(0,j),beta[indi])) beta.full <- rep(0,length(beta)+j) ib <- 1;ii <- 1 for (i in 1:length(beta.full)) { if (i==indi[ii]) { beta.full[i] <- Xbeta[ii]; ii <- ii + 1 } else { beta.full[i] <- beta[ib]; ib <- ib + 1 } } ##X[,indi[1:nz]]<-t(qr.qty(qrc,t(X[,indi,drop=FALSE]))[(nc+1):nx,,drop=FALSE]) ## X <- X[,-indi[(nz+1):nx]] beta <- beta.full } } else if (inherits(qrc,"sweepDrop")) { ## Sweep and drop constraints. First element is index to drop. ## Remainder are constants to be swept out of remaining columns ## X <- sweep(X[,-qrc[1],drop=FALSE],2,qrc[-1]) #X <- X[,-qrc[1],drop=FALSE] - matrix(qrc[-1],nrow(X),ncol(X)-1,byrow=TRUE) cnst <- sum(beta*qrc[-1]) if (qrc[1]==1) beta <- c(0,beta) else if (qrc[1]==length(beta)+1) beta <- c(beta,0) else beta <- c(beta[1:(qrc[1]-1)],0,beta[qrc[1]:length(beta)]) attr(beta,"constant") <- cnst } else if (qrc>0) { ## simple set to zero constraint ##X <- X[,-qrc] if (qrc==1) beta <- c(0,beta) else if (qrc==length(beta)+1) beta <- c(beta,0) else beta <- c(beta[1:(qrc-1)],0,beta[qrc:length(beta)]) } else if (qrc<0) { ## params sum to zero # X <- t(diff(t(X))) beta <- t(diff(diag(length(beta)+1)))%*%beta } } ## end if (j>0) } ## end if qrc exists beta } ## end of unconstrain bnd2C <- function(bnd) { ## converts boundary loop list to form required in C code. n.loop <- 1 if (is.null(bnd$x)) { ## translate into form that C routine needs bn <- list(x=bnd[[1]]$x,y=bnd[[1]]$y) n.loop <- length(bnd) if (length(bnd)>1) for (i in 2:n.loop) { bn$x <- c(bn$x,NA,bnd[[i]]$x);bn$y <- c(bn$y,NA,bnd[[i]]$y) } bnd <- bn } ## replace NA segment separators with a numeric code lowLim <- min(c(bnd$x,bnd$y),na.rm=TRUE)-1 ind <- is.na(bnd$x)|is.na(bnd$y) bnd$x[ind] <- bnd$y[ind] <- lowLim - 1 bnd$n <- length(bnd$x) if (bnd$n != length(bnd$y)) stop("x and y must be same length") bnd$breakCode <-lowLim bnd$n.loop <- n.loop bnd } ## end bnd2C inSide <- function(bnd,x,y) ## tests whether each point x[i],y[i] is inside the boundary defined ## by bnd$x, bnd$y, or by multiple boundary loops in bnd[[1]]$x, ## bnd[[1]]$y, bnd[[2]]$x, ... etc. ## names in bnd must match those of x and y, but do not need to be "x" and "y" { ## match the names up first... xname <- deparse(substitute(x)) yname <- deparse(substitute(y)) bnd.name <- names(bnd) if (is.null(bnd.name)) for (i in 1:length(bnd)) { bnd.name <- names(bnd[[i]]) if (xname%in%bnd.name==FALSE||yname%in%bnd.name==FALSE) stop("variable names don't match boundary names") bnd.name[xname==bnd.name] <- "x" bnd.name[yname==bnd.name] <- "y" names(bnd[[i]]) <- bnd.name } else { if (xname%in%bnd.name==FALSE||yname%in%bnd.name==FALSE) stop("variable names don't match boundary names") bnd.name[xname==bnd.name] <- "x" bnd.name[yname==bnd.name] <- "y" names(bnd) <- bnd.name } ## now do the real stuff... bnd <- bnd2C(bnd) um <-.C(C_in_out,bx=as.double(bnd$x),by=as.double(bnd$y),break.code=as.double(bnd$breakCode), x=as.double(x),y=as.double(y),inside=as.integer(y*0),nb=as.integer(bnd$n), n=as.integer(length(x))) as.logical(um$inside) } ## end inSide process.boundary <- function(bnd) ## takes a list of boundary loops, makes sure that they join up ## and add a distance along loop array, d to each list element. { for (i in 1:length(bnd)) { x <- bnd[[i]]$x;y<-bnd[[i]]$y;n <- length(x) if (length(y)!=n) stop("x and y not same length") if (x[1]!=x[n]||y[1]!=y[n]) { ## then loop not closed, so close it n<-n+1;x[n] <- x[1];y[n] <- y[1] if (inherits(bnd[[i]],"data.frame")) bnd[[i]][n,] <-bnd[[i]][1,] else { ## hopefully a list! bnd[[i]]$x[n] <- x[1];bnd[[i]]$y[n] <- y[1] if (!is.null(bnd[[i]]$f)) bnd[[i]]$f[n] <- bnd[[i]]$f[1] } } len <- c(0,sqrt((x[1:(n-1)]-x[2:n])^2+(y[1:(n-1)]-y[2:n])^2)) ## seg lengths bnd[[i]]$d<-cumsum(len) ## distance along boundary } bnd } ## end process.boundary crunch.knots <- function(G,knots,x0,y0,dx,dy) ## finds indices of knot locations in solution grid ## the knot x,y locations are given in the `knots' argument. { nk <- length(knots$x) nx <- ncol(G);ny <- nrow(G) ki <- rep(0,nk) if (nk==0) return(ki) for (k in 1:nk) { i <- round((knots$x[k]-x0)/dx)+1 j <- round((knots$y[k]-y0)/dy)+1 if (i>1&&i<=nx&&j>1&&j<=ny) { ki[k] <- G[j,i] if (ki[k] <= 0) { str <- paste("knot",k,"is on or outside boundary") stop(str) } } } ## all knots done ki ## ki[k] indexes kth knot in solution grid } ## end crunch.knots setup.soap <- function(bnd,knots,nmax=100,k=10,bndSpec=NULL) { ## setup soap film smooth - nmax is number of grid cells for longest side ## it's important that grid cells are square! ## check boundary... if (!inherits(bnd,"list")) stop("bnd must be a list.") n.loops <- length(bnd) if (n.loops!=length(k)) { if (length(k)==1) k <- rep(k,n.loops) else stop("lengths of k and bnd are not compatible.") } bnd <- process.boundary(bnd) ## add distances and close any open loops ## create grid on which to solve Laplace equation ## Obtain grid limits from boundary 'bnd'.... x0 <- min(bnd[[1]]$x);x1 <- max(bnd[[1]]$x) y0 <- min(bnd[[1]]$y);y1 <- max(bnd[[1]]$y) if (length(bnd)>1) for (i in 2:length(bnd)) { x0 <- min(c(x0,bnd[[i]]$x)); x1 <- max(c(x1,bnd[[i]]$x)) y0 <- min(c(y0,bnd[[i]]$y)); y1 <- max(c(y1,bnd[[i]]$y)) } ## now got the grid limits, can set it up if (x1-x0>y1-y0) { ## x is longest side dy <- dx <- (x1-x0) /(nmax-1) nx <- nmax ny <- ceiling((y1-y0)/dy)+1 } else { ## y is longest side dy <- dx <- (y1-y0) /(nmax-1) ny <- nmax nx <- ceiling((x1-x0)/dy)+1 } ## so grid is now nx by ny, cell size is dx by dy (but dx=dy) ## x0, y0 is "lower left" cell centre ## Create grid index G bnc <- bnd2C(bnd) ## convert boundary to form required in C code G <- matrix(0,ny,nx) nb <- rep(0,bnc$n.loop) oo <- .C(C_boundary,G=as.integer(G), d=as.double(G), dto=as.double(G), x0=as.double(x0), y0 = as.double(y0), dx=as.double(dx), dy = as.double(dy), nx=as.integer(nx),as.integer(ny), x=as.double(bnc$x),y=as.double(bnc$y), breakCode=as.double(bnc$breakCode),n=as.integer(bnc$n),nb=as.integer(nb)) ret <- list(G=matrix(oo$G,ny,nx),nb=oo$nb,d=oo$d[oo$d >= 0],x0=x0,y0=y0,dx=dx,dy=dy,bnd=bnd) rm(oo) ## Now create the PDE coefficient matrix n.inside <- sum(ret$G > - nx*ny) xx <- rep(0,5*n.inside) o1 <- .C(C_pde_coeffs,as.integer(ret$G),xx=as.double(xx),ii=as.integer(xx),jj=as.integer(xx), n=as.integer(0),as.integer(nx),as.integer(ny),as.double(dx),as.double(dy)) ind <- 1:o1$n X <- sparseMatrix(i=o1$ii[ind]+1,j=o1$jj[ind]+1,x=o1$xx[ind]) er <- expand(lu(X)) ret$Q <- er$Q;ret$U <- er$U;ret$L <- er$L;ret$P <- er$P ret$ng <- n.inside ## the number of cells to solve for rm(er);rm(X) ## ... so the sparse LU decomposition of X can be used to solve PDE. ## X = PLUQ where P and Q are permuation matrices. ## now obtain location of knots in solution ... ret$ki <- crunch.knots(ret$G,knots,x0,y0,dx,dy) ## setup the boundary conditions/boundary splines bc <- list() ## to hold boundary conditions start <- 1 for (i in 1:length(bnd)) { stop <- start - 1 + ret$nb[i] ## ret$d[start:stop] = dist along boundary loop i if (is.null(bnd[[i]]$f)) { ## this boundary is free d <- c(ret$d[start:stop],0) # boundary gridpoint distances along smooth if (is.null(bndSpec)) { bsm <- smooth.construct(s(d,bs="cc",k=k[i]),data=data.frame(d=d),knots=NULL) } else if (bndSpec$bs=="cc"){ if (bndSpec$knot.space=="even") knots <- seq(min(d),max(d),length=k[i]) else knots <- quantile(unique(d),seq(0,1,length=k[i])) bsm <- smooth.construct(s(d,bs="cc",k=k[i]),data=data.frame(d=d),knots=NULL) } else { ## use "cp" P-spline bsm <- smooth.construct(s(d,bs="cp",k=k[i],m=bndSpec$m),data=data.frame(d=d),knots=NULL) } bc[[i]] <- list(bsm=bsm,X=bsm$X[1:ret$nb[i],],S=bsm$S[[1]],free.bound=TRUE) } else { ## boundary is fixed ## pmax/pmin needed to avoid rounding error induced NA's d <- pmax(pmin(ret$d[start:stop],max(bnd[[i]]$d)),min(bnd[[i]]$d)) ui <- !duplicated(bnd[[i]]$d) ff <- approx(bnd[[i]]$d[ui],bnd[[i]]$f[ui],d)$y ## fixed values for BC bc[[i]] <- list(f=ff,free.bound=FALSE) } start <- stop + 1 } ret$bc <- bc ret } ## end of setup.soap soap.basis <- function(sd,x=NA,y=NA,film=TRUE,wiggly=TRUE,penalty=TRUE,plot=FALSE,beta=1) { ## function to evaluate soap basis using soap definition object 'sd' ## returned by setup.soap. x and y are values at which to evaluate. ## If plot==TRUE then then data suitable for plotting are returned at the resolution ## of the solution grid. Then beta contains either the coefficients, or a single number ## representing the single basis function to return (0 for the offset). if (!plot) { indout <- inSide(sd$bnd,x,y); n <- length(x) } else { penalty <- FALSE ## Some constraints result in the need to add a constant ## to the field (e.g. sweep and drop) cnst <- attr(beta,"constant") if (is.null(cnst)) cnst <- 0 else cnst <- -cnst } offset.needed <- FALSE; nc <- length(sd$ki)*as.numeric(wiggly) ## number of interior knots nb <- 0 ## boundary basis dimension offset <- NULL if (film) { stop <- 0 for (i in 1:length(sd$bc)) { ## work through boundary loops start <- stop + 1;stop <- start - 1 + sd$nb[i] if (sd$bc[[i]]$free.bound) nb <- nb + ncol(sd$bc[[i]]$X) else { ## fixed boundary, so offset required if (!offset.needed) { bndOff <- rep(0,sd$ng) ## array for fixed boundary conditions offset.needed <- TRUE } bndOff[start:stop] <- sd$bc[[i]]$f } ## fixed boundary done } ## finished first pass through loops } ## finished first if film if (plot) { ## preliminaries for plotting info if (length(beta)==1) { ## just one basis function to be returned if (beta<0||beta>nc+nb||(beta==0&&!offset.needed)) stop("attempt to select non existent basis function") select.basis <- TRUE } else { ## whole smooth to be returned if (length(beta)!=nc+nb) stop("coefficient vector wrong length") select.basis <- FALSE } G <- sd$G ## solution grid G[G < - length(G)] <- NA ## exterior marked as NA ind <- !is.na(G) gind <- G[ind] <- abs(G[ind])+1 ## need to create the indices such that G[gind] <- g is correct... gind[G[ind]] <- (1:length(G))[ind] G[ind] <- cnst ## now clear interior of G } ## finished preliminary if (plot) if (film) { if (offset.needed) { ## solve for offset soap film bndOff <- solve(sd$Q,solve(sd$U,solve(sd$L,solve(t(sd$P),bndOff)))) if (plot) { ## grid is all that's needed if (select.basis&&beta==0||!select.basis) { G[gind] <- bndOff } } else { ## need full interpolation NAcode <- max(bndOff)*2 offset <- .C(C_gridder,z=as.double(x),as.double(x),as.double(y),as.integer(length(x)),as.double(bndOff), as.integer(sd$G),nx=as.integer(ncol(sd$G)),ny=as.integer(nrow(sd$G)),as.double(sd$x0), as.double(sd$y0),as.double(sd$dx),as.double(sd$dy),as.double(NAcode*2))$z offset[offset>NAcode] <- NA offset[!indout] <- NA } } } ## finished preliminary if (film) if (!plot) { X <- matrix(0,n,nb+nc) ## model matrix if (penalty) { S <- list();off <- 1;nS=0} else {off <- S <- NULL} } k <- 1 ## model matrix column if (film&&nb>0) { ## now work through boundary bases stop <- 0 for (i in 1:length(sd$bc)) { ## work through boundary loops start <- stop + 1;stop <- start - 1 + sd$nb[i] ind <- start:stop ## index of this loop in solution grid if (sd$bc[[i]]$free.bound) { if (penalty) { nS <- nS + 1 off[nS] <- k S[[nS]] <- sd$bc[[i]]$S } ## penalty done for (j in 1:ncol(sd$bc[[i]]$X)) { ## loop over loop basis cols z <- rep(0,sd$ng) z[ind] <- sd$bc[[i]]$X[,j] ## PDE rhs z <- solve(sd$Q,solve(sd$U,solve(sd$L,solve(t(sd$P),z)))) if (plot) { if (select.basis) { if (beta==k) G[gind] <- z } else G[gind] <- G[gind] + beta[k]*z } else { NAcode <- max(z)*2 Xj <- .C(C_gridder,z=as.double(x),as.double(x),as.double(y),as.integer(length(x)),as.double(z), as.integer(sd$G),nx=as.integer(ncol(sd$G)),ny=as.integer(nrow(sd$G)),as.double(sd$x0), as.double(sd$y0),as.double(sd$dx),as.double(sd$dy),as.double(NAcode*2))$z Xj[Xj>NAcode] <- NA;X[,k] <- Xj; } k <- k + 1 } ## basis done } ## end of free boundary } ## end of boundary loops } ## end of film processing if (wiggly) { ## interior basis functions required g <- matrix(0,sd$ng,nc) for (i in 1:nc) g[sd$ki[i],i] <- 1 g <- as(solve(sd$Q,solve(sd$U,solve(sd$L,solve(t(sd$P),g)))),"matrix") g <- sweep(g,2,apply(g,2,max),"/") ## normalize - not really needed if (penalty) { ## get soap penalty nS <- nS + 1;off[nS] <- k S[[nS]] <- crossprod(g) * sd$dx * sd$dy } g <- solve(sd$Q,solve(sd$U,solve(sd$L,solve(t(sd$P),g)))) NAcode <- max(g)*2 for (i in 1:nc) { if (plot) { if (select.basis) { if (k==beta) G[gind] <- g[,i] } else G[gind] <- G[gind] + beta[k]*g[,i] } else { Xj <- .C(C_gridder,z=as.double(x),as.double(x),as.double(y),as.integer(length(x)),as.double(g[,i]), as.integer(sd$G),nx=as.integer(ncol(sd$G)),ny=as.integer(nrow(sd$G)),as.double(sd$x0), as.double(sd$y0),as.double(sd$dx),as.double(sd$dy),as.double(NAcode*2))$z Xj[Xj>NAcode] <- NA;X[,k] <- Xj } k <- k + 1 } } if (plot) { return(t(G)) } else { X[!indout,] <- NA return(list(X=X,S=S,off=off,offset=offset)) } } ## end soap.basis smooth.construct.so.smooth.spec<-function(object,data,knots) ## a full soap film smooth constructor method function for ## integration with mgcv::gam { if (is.null(knots)) stop("knots must be specified for soap") if (object$dim!=2) stop("soap films are bivariate only") x <- data[[object$term[1]]] y <- data[[object$term[2]]] knt <- list(x=knots[[object$term[1]]],y=knots[[object$term[2]]]) if (length(knt$x)<1) stop("need at least one interior knot") bnd <- object$xt$bnd if (is.null(bnd)) stop("can't soap smooth without a boundary") if (!inherits(bnd,"list")) stop("bnd must be a list of boundary loops") ## check knots within boundary... kin <- in.out(bnd,cbind(knt[[1]],knt[[2]])) if (any(!kin)) warning("dropping soap knots not inside boundary - use 'in.out' to investigate.") knt[[1]] <- knt[[1]][kin];knt[[2]] <- knt[[2]][kin] for (i in 1:length(bnd)) { ## re-lable boundary nm <- names(bnd[[i]]) ind <- nm==object$term[1] if (sum(ind)!=1) stop("faulty bnd") names(bnd[[i]])[ind] <- "x" ind <- nm==object$term[2] if (sum(ind)!=1) stop("faulty bnd") names(bnd[[i]])[ind] <- "y" } if (length(object$bs.dim)==1) k <- rep(object$bs.dim,length(bnd)) else { if (length(object$bs.dim)==length(bnd)) k <- object$bs.dim else stop("k and bnd lengths are inconsistent") } if (is.null(object$xt$nmax)) nmax <- 200 else nmax <- object$xt$nmax ## setup the soap defining structures sd <- setup.soap(bnd,knots=knt,nmax=nmax,k=k,bndSpec=object$xt$bndSpec) b <- soap.basis(sd,x,y,film=TRUE,wiggly=TRUE,penalty=TRUE) if (sum(is.na(b$X))>0) stop("data outside soap boundary") # b <- soap.construct(x,y,bnd,knots=knt,k=k,n.grid=n.grid,basis.type=2, # depth=depth,rel.eps=rel.eps,abs.eps=abs.eps, # bndSpec=object$xt$bndSpec) ## get penalty null space for the term... ns.dim <- 0;n <- length(sd$bc) if (n>0) for (i in 1:n) if (sd$bc[[i]]$free.bound) ns.dim <- ns.dim + sd$bc[[i]]$bsm$null.space.dim object$null.space.dim <- ns.dim need.con <- TRUE for (i in 1:length(sd$bc)) if (!sd$bc[[i]]$free.bound) need.con <- FALSE ## rescale basis for nice conditioning.... irng <- 1/as.numeric(apply(b$X,2,max)-apply(b$X,2,min)) b$X <- t(t(b$X)*irng) ## now apply rescaling for (i in 1:length(b$S)) { a <- irng[b$off[i]:(b$off[i]+ncol(b$S[[i]])-1)] b$S[[i]] <- diag(a)%*%b$S[[i]]%*%diag(a) } object$irng <- irng ## the column scaling factor if (any(!is.finite(irng))) stop("soap basis ill-conditioned - changing 'xt$nmax' may help") object$X <- b$X ## model matrix attr(object$X,"offset") <- b$offset if (!object$fixed) { ## have to unpack a bit... S <- list();n <- ncol(object$X) for (i in 1:length(b$S)) { S[[i]] <- matrix(0,n,n) m <- ncol(b$S[[i]]) ind <- b$off[i]:(b$off[i]+m-1) S[[i]][ind,ind] <- b$S[[i]] } object$S <- S ## penalties } rr <- ncol(b$S[[1]])-1 if (length(b$S)>1) for (i in 2:length(b$S)) rr <- c(rr,ncol(b$S[[i]])-1) rr[length(rr)] <- rr[length(rr)]+1 object$rank <- rr # penalty ranks if (!need.con) object$C <- matrix(0,0,ncol(object$X)) ## no con object$df <- ncol(object$X) # -nrow(object$C) for (i in 1:length(sd$bc)) { sd$bc[[i]]$bsm <- sd$bc[[i]]$S <- NULL } object$sd <- sd class(object)<-"soap.film" # Give object a class object } ## end of full soap constructor smooth.construct.sf.smooth.spec<-function(object,data,knots) ## a soap film smooth boundary interpolating film only constructor ## method function for integration with mgcv::gam { if (is.null(knots)) stop("knots must be specified for soap") if (object$dim!=2) stop("soap films are bivariate only") x <- data[[object$term[1]]] y <- data[[object$term[2]]] knt <- list(x=knots[[object$term[1]]],y=knots[[object$term[2]]]) ## if (length(knt$x)<1) stop("need at least one interior knot") bnd <- object$xt$bnd if (is.null(bnd)) stop("can't soap smooth without a boundary") if (!inherits(bnd,"list")) stop("bnd must be a list of boundary loops") for (i in 1:length(bnd)) { ## re-lable boundary nm <- names(bnd[[i]]) ind <- nm==object$term[1] if (sum(ind)!=1) stop("faulty bnd") names(bnd[[i]])[ind] <- "x" ind <- nm==object$term[2] if (sum(ind)!=1) stop("faulty bnd") names(bnd[[i]])[ind] <- "y" } if (length(object$bs.dim)==1) k <- rep(object$bs.dim,length(bnd)) else { if (length(object$bs.dim)==length(bnd)) k <- object$bs.dim else stop("k and bnd lengths are inconsistent") } if (is.null(object$xt$nmax)) nmax <- 200 else nmax <- object$xt$nmax ## setup the soap defining structures sd <- setup.soap(bnd,knots=knt,nmax=nmax,k=k,bndSpec=object$xt$bndSpec) b <- soap.basis(sd,x,y,film=TRUE,wiggly=FALSE,penalty=TRUE) if (sum(is.na(b$X))>0) stop("data outside soap boundary") if (ncol(b$X)==0) stop("no free coefs in sf smooth") # b <- soap.construct(x,y,bnd,knots=knt,k=k,n.grid=n.grid,basis.type=2, # depth=depth,rel.eps=rel.eps,abs.eps=abs.eps,film=TRUE, # wiggly=FALSE,bndSpec=object$xt$bndSpec) ## get penalty null space for term ns.dim <- 0;n <- length(sd$bc) k <- 0 ## counter for b$S rr <- rep(0,length(b$S)) if (n>0) for (i in 1:n) if (sd$bc[[i]]$free.bound) { nsd <- sd$bc[[i]]$bsm$null.space.dim ns.dim <- ns.dim + nsd k <- k + 1 rr[k] <- ncol(b$S[[k]]) - nsd ## rank of b$S[[k]] } object$null.space.dim <- ns.dim object$rank <- rr # penalty ranks need.con <- TRUE for (i in 1:length(sd$bc)) if (!sd$bc[[i]]$free.bound) need.con <- FALSE ## rescale basis for nice conditioning.... irng <- 1/as.numeric(apply(b$X,2,max)-apply(b$X,2,min)) b$X <- t(t(b$X)*irng) ## now apply rescaling if (length(b$S)>0) for (i in 1:length(b$S)) { a <- irng[b$off[i]:(b$off[i]+ncol(b$S[[i]])-1)] b$S[[i]] <- diag(a)%*%b$S[[i]]%*%diag(a) } object$irng <- irng ## the column scaling factor object$X <- b$X ## model matrix attr(object$X,"offset") <- b$offset if (!object$fixed) { ## have to unpack a bit... S <- list();n <- ncol(object$X) if (length(b$S)>0) for (i in 1:length(b$S)) { S[[i]] <- matrix(0,n,n) m <- ncol(b$S[[i]]) ind <- b$off[i]:(b$off[i]+m-1) S[[i]][ind,ind] <- b$S[[i]] } object$S <- S ## penalties } if (!need.con) object$C <- matrix(0,0,ncol(object$X)) ## no con object$df <- ncol(object$X) # -nrow(object$C) for (i in 1:length(sd$bc)) { sd$bc[[i]]$bsm <- sd$bc[[i]]$S <- NULL } object$sd <- sd class(object)<-c("sf","soap.film") # Give object a class object } ## end of boundary film component soap constructor smooth.construct.sw.smooth.spec<-function(object,data,knots) ## a soap film smooth wiggly component only constructor method function for ## integration with mgcv::gam { if (is.null(knots)) stop("knots must be specified for soap") if (object$dim!=2) stop("soap films are bivariate only") x <- data[[object$term[1]]] y <- data[[object$term[2]]] knt <- list(x=knots[[object$term[1]]],y=knots[[object$term[2]]]) if (length(knt$x)<1) stop("need at least one interior knot") bnd <- object$xt$bnd if (is.null(bnd)) stop("can't soap smooth without a boundary") if (!inherits(bnd,"list")) stop("bnd must be a list of boundary loops") for (i in 1:length(bnd)) { ## re-lable boundary nm <- names(bnd[[i]]) ind <- nm==object$term[1] if (sum(ind)!=1) stop("faulty bnd") names(bnd[[i]])[ind] <- "x" ind <- nm==object$term[2] if (sum(ind)!=1) stop("faulty bnd") names(bnd[[i]])[ind] <- "y" } if (length(object$bs.dim)==1) k <- rep(object$bs.dim,length(bnd)) else { if (length(object$bs.dim)==length(bnd)) k <- object$bs.dim else stop("k and bnd lengths are inconsistent") } if (is.null(object$xt$nmax)) nmax <- 200 else nmax <- object$xt$nmax ## setup the soap defining structures sd <- setup.soap(bnd,knots=knt,nmax=nmax,k=k,bndSpec=object$xt$bndSpec) b <- soap.basis(sd,x,y,film=FALSE,wiggly=TRUE,penalty=TRUE) if (sum(is.na(b$X))>0) stop("data outside soap boundary") object$null.space.dim <- 0 ## penalty is full rank, for this case ## rescale basis for nice conditioning.... irng <- 1/as.numeric(apply(b$X,2,max)-apply(b$X,2,min)) b$X <- t(t(b$X)*irng) ## now apply rescaling for (i in 1:length(b$S)) { a <- irng[b$off[i]:(b$off[i]+ncol(b$S[[i]])-1)] b$S[[i]] <- diag(a)%*%b$S[[i]]%*%diag(a) } object$irng <- irng ## the column scaling factor object$X <- b$X ## model matrix if (!object$fixed) { ## have to unpack a bit... S <- list();n <- ncol(object$X) for (i in 1:length(b$S)) { S[[i]] <- matrix(0,n,n) m <- ncol(b$S[[i]]) ind <- b$off[i]:(b$off[i]+m-1) S[[i]][ind,ind] <- b$S[[i]] } object$S <- S ## penalties } rr <- ncol(b$S[[1]])-1 if (length(b$S)>1) for (i in 2:length(b$S)) rr <- c(rr,ncol(b$S[[i]])-1) rr[length(rr)] <- rr[length(rr)]+1 object$rank <- rr # penalty ranks object$df <- ncol(object$X) # -nrow(object$C) for (i in 1:length(sd$bc)) { sd$bc[[i]]$bsm <- sd$bc[[i]]$S <- NULL } object$sd <- sd object$C <- matrix(0,0,ncol(object$X)) ## this is tied to zero class(object)<-c("sw","soap.film") # Give object a class object } ## end of wiggly component of soap constructor Predict.matrix.soap.film<-function(object,data) # prediction method function for the soap.film smooth class { x <- get.var(object$term[1],data) y <- get.var(object$term[2],data) b <- soap.basis(object$sd,x,y,film=TRUE,wiggly=TRUE,penalty=FALSE) X <- t(object$irng*t(b$X)) attr(X,"offset") <- b$offset X } Predict.matrix.sf <- function(object,data) # prediction method function for the sf smooth class --- the boundary interpolating film # component of a soap film smooth { x <- get.var(object$term[1],data) y <- get.var(object$term[2],data) b <- soap.basis(object$sd,x,y,film=TRUE,wiggly=FALSE,penalty=FALSE) X <- t(object$irng*t(b$X)) attr(X,"offset") <- b$offset X } Predict.matrix.sw <- function(object,data) # prediction method function for the sw smooth class --- the wiggly # component of a soap film smooth { x <- get.var(object$term[1],data) y <- get.var(object$term[2],data) X <- soap.basis(object$sd,x,y,film=FALSE,wiggly=TRUE,penalty=FALSE)$X X <- t(object$irng*t(X)) X } plot.soap.film <- 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,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=1,...) { ## plot method function for soap.smooth terms if (scheme==3) { if (is.null(P)) outline <- FALSE else outline <- TRUE if (is.null(xlim)) xlim <- c(x$sd$x0,x$sd$x0+ncol(x$sd$G)*x$sd$dx) if (is.null(ylim)) ylim <- c(x$sd$y0,x$sd$y0+nrow(x$sd$G)*x$sd$dy) P0 <- plot.mgcv.smooth(x=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,hcolors=hcolors, ## don't pass scheme!! contour.col=contour.col,...) if (outline) { if (is.null(names(P$bnd))) { for (i in 1:length(P$bnd)) lines(P$bnd[[i]],lwd=2) } else lines(P$bnd,lwd=2) } else { P0$bnd <- x$sd$bnd} return(P0) } if (is.null(P)) { ## get plotting information... if (!x$plot.me) return(NULL) ## shouldn't or can't plot ## get basic plot data beta <- unconstrain(x,attr(x,"coefficients"))*x$irng ## coefs raw <- data[x$term] film <- wiggly <- TRUE if (inherits(x,"sw")) film <- FALSE else if (inherits(x,"sf")) wiggly <- FALSE soap.basis(x$sd,film=film,wiggly=wiggly,plot=TRUE,beta=beta) -> G if (is.null(xlab)) xlabel<- x$term[1] else xlabel <- xlab if (is.null(ylab)) ylabel <- x$term[2] else ylabel <- ylab xscale <- x$sd$x0 + 0:(nrow(G)-1) * x$sd$dx yscale <- x$sd$y0 + 0:(ncol(G)-1) * x$sd$dy main <- if (is.null(main)) label return(list(fit=G,scale=FALSE,se=FALSE,raw=raw,xlab=xlabel,ylab=ylabel, xscale=xscale,yscale=yscale,main=main,bnd=x$sd$bnd)) } else { ## do plot if (scheme==0) { xlim <- range(P$xscale);dx = xlim[2] - xlim[1] ylim <- range(P$yscale);dy = ylim[2] - ylim[1] plot(P$xscale[1],P$yscale[1],xlab=P$xlab,ylab=P$ylab,main=P$main,xlim=xlim,ylim=ylim,...) rect(xlim[1]-dx,ylim[1]-dy,xlim[2]+dx,ylim[2]+dy,col="lightgrey") image(P$xscale,P$yscale,P$fit,add=TRUE,col=hcolors,...) contour(P$xscale,P$yscale,P$fit,add=TRUE,col=contour.col,...) } else if (scheme==1) { image(P$xscale,P$yscale,P$fit,col=grey(0:50/50),xlab=P$xlab, ylab=P$ylab,main=P$main,...) contour(P$xscale,P$yscale,P$fit,add=TRUE,col=contour.col,...) } else if (scheme==2) { contour(P$xscale,P$yscale,P$fit,xlab=P$xlab, ylab=P$ylab,main=P$main,col=contour.col,...) if (is.null(names(P$bnd))) { for (i in 1:length(P$bnd)) lines(P$bnd[[i]],lwd=2) } else lines(P$bnd,lwd=2) } } } ## end plot.soap.smooth fs.test <- function(x,y,r0=.1,r=.5,l=3,b=1,exclude=TRUE) ## test function based on Tim Ramsay (2002) J.R.Statist. Soc. B ## 64(2):307-319 "Spline smoothing over difficult regions" { q <- pi*r/2 ## 1/2 length of semi-circle part of centre curve a <- d <- x*0 ## along and distance to arrays ## convert x,y to along curve and distance to curve (a,d) ## co-ordinates. 0 distance along is at (x=-r,y=0) ind <- x>=0 & y>0 a[ind] <- q + x[ind] d[ind] <- y[ind]-r ind <- x>=0 & y<=0 a[ind] <- -q - x[ind] d[ind] <- -r - y[ind] ind <- x < 0 a[ind] <- -atan(y[ind]/x[ind])*r d[ind] <- sqrt(x[ind]^2+y[ind]^2) - r ## create exclusion index ind <- abs(d)>r-r0 | (x>l & (x-l)^2+d^2 > (r-r0)^2) # f <- a*b # the original f <- a*b+d^2 if (exclude) f[ind] <- NA attr(f,"exclude") <- ind f } fs.boundary <- function(r0=.1,r=.5,l=3,n.theta=20) ## produce boundary file for fs.test { rr <- r+(r-r0) theta <- seq(pi,pi/2,length=n.theta) x <- rr*cos(theta); y <- rr*sin(theta) theta <- seq(pi/2,-pi/2,length=2*n.theta) x <- c(x,(r-r0)*cos(theta)+l); y <- c(y,(r-r0)*sin(theta)+r) theta <- seq(pi/2,pi,length=n.theta) x <- c(x,r0*cos(theta)); y <- c(y,r0*sin(theta)) n<-length(x) x <- c(x,x[n:1]);y <- c(y,-y[n:1]) return(list(x=x,y=y)) } mgcv/R/mgcv.r0000755000176200001440000056040413561304526012547 0ustar liggesusers## R routines for the package mgcv (c) Simon Wood 2000-2016 ## With contributions from Henric Nilsson Rrank <- function(R,tol=.Machine$double.eps^.9) { ## Finds rank of upper triangular matrix R, by estimating condition ## number of upper rank by rank block, and reducing rank until this is ## acceptably low... assumes R pivoted m <- nrow(R) rank <- min(m,ncol(R)) ok <- TRUE while (ok) { Rcond <- .C(C_R_cond,R=as.double(R),r=as.integer(m),c=as.integer(rank), work=as.double(rep(0,4*m)),Rcond=as.double(1))$Rcond if (Rcond*tol<1) ok <- FALSE else rank <- rank - 1 } rank } slanczos <- function(A,k=10,kl=-1,tol=.Machine$double.eps^.5,nt=1) { ## Computes truncated eigen decomposition of symmetric A by ## Lanczos iteration. If kl < 0 then k largest magnitude ## eigenvalues returned, otherwise k highest and kl lowest. ## Eigenvectors are always returned too. ## set.seed(1);n <- 1000;A <- matrix(runif(n*n),n,n);A <- A+t(A);er <- slanczos(A,10) ## um <- eigen(A,symmetric=TRUE);ind <- c(1:5,(n-5+1):n) ## range(er$values-um$values[ind]);range(abs(er$vectors)-abs(um$vectors[,ind])) ## It seems that when k (or k+kl) is beyond 10-15% of n ## then you might as well use eigen(A,symmetric=TRUE), but the ## extra cost is the expensive accumulation of eigenvectors. ## Should re-write whole thing using LAPACK routines for eigenvectors. if (tol<=0||tol>.01) stop("silly tolerance supplied") k <- round(k);kl <- round(kl) if (k<0) stop("argument k must be positive.") m <- k + max(0,kl) n <- nrow(A) if (m<1) return(list(values=rep(0,0),vectors=matrix(0,n,0),iter=0)) if (n != ncol(A)) stop("A not square") if (m>n) stop("Can not have more eigenvalues than nrow(A)") oo <- .C(C_Rlanczos,A=as.double(A),U=as.double(rep(0,n*m)),D=as.double(rep(0,m)), n=as.integer(n),m=as.integer(k),ml=as.integer(kl),tol=as.double(tol),nt=as.integer(nt)) list(values = oo$D,vectors = matrix(oo$U,n,m),iter=oo$n) } rig <- function(n,mean,scale) { ## inverse guassian deviates generated by algorithm 5.7 of ## Gentle, 2003. scale = 1/lambda. if (length(n)>1) n <- length(n) x <- y <- rnorm(n)^2 mys <- mean*scale*y mu <- 0*y + mean ## y is there to ensure mu is a vector mu2 <- mu^2; ind <- mys < .Machine$double.eps^-.5 ## cut off for tail computation x[ind] <- mu[ind]*(1 + 0.5*(mys[ind] - sqrt(mys[ind]*4+mys[ind]^2))) x[!ind] <- mu[!ind]/mys[!ind] ## tail term (derived from Taylor of sqrt(1+eps) etc) #my <- mean*y; sc <- 0*y + scale #ind <- my > 1 ## cancellation error can be severe, without splitting #x[!ind] <- mu[!ind]*(1 + 0.5*sc[!ind]*(my[!ind] - sqrt(4*my[!ind]/sc[!ind] + my[!ind]^2))) ## really the sqrt in the next term should be expanded beyond first order and then ## worked on - otherwise too many exact zeros? #x[ind] <- pmax(0,mu[ind]*(1+my[ind]*.5*sc[ind]*(1-sqrt(1+ 4/(sc[ind]*my[ind]))))) ind <- runif(n) > mean/(mean+x) x[ind] <- mu2[ind]/x[ind] x ## E(x) = mean; var(x) = scale*mean^3 } strip.offset <- function(x) # sole purpose is to take a model frame and rename any "offset(a.name)" # columns "a.name" { na <- names(x) for (i in 1:length(na)) { if (substr(na[i],1,7)=="offset(") na[i] <- substr(na[i],8,nchar(na[i])-1) } names(x) <- na x } pcls <- function(M) # Function to perform penalized constrained least squares. # Problem to be solved is: # # minimise ||W^0.5 (y - Xp)||^2 + p'Bp # subject to Ain p >= b & C p = "constant" # # where B = \sum_{i=1}^m \theta_i S_i and W=diag(w) # on entry this routine requires a list M, with the following elements: # M$X - the design matrix for this problem. # M$p - a feasible initial parameter vector - note that this should not be set up to # lie exactly on all the inequality constraints - which can easily happen if M$p=0! # M$y - response variable # M$w - weight vector: W= diag(M$w) # M$Ain - matrix of inequality constraints # M$bin - b above # M$C - fixed constraint matrix # M$S - List of (minimal) penalty matrices # M$off - used for unpacking M$S # M$sp - array of theta_i's # Ain, bin and p are not in the object needed to call mgcv.... # { nar<-c(length(M$y),length(M$p),dim(M$Ain)[1],dim(M$C)[1]) ## sanity checking ... if (nrow(M$X)!=nar[1]) stop("nrow(M$X) != length(M$y)") if (ncol(M$X)!=nar[2]) stop("ncol(M$X) != length(M$p)") if (length(M$w)!=nar[1]) stop("length(M$w) != length(M$y)") if (nar[3]!=length(M$bin)) stop("nrow(M$Ain) != length(M$bin)") if (nrow(M$Ain)>0) { if (ncol(M$Ain)!=nar[2]) stop("nrow(M$Ain) != length(M$p)") res <- as.numeric(M$Ain%*%M$p) - as.numeric(M$bin) if (sum(res<0)>0) stop("initial parameters not feasible") res <- abs(res) if (sum(res<.Machine$double.eps^.5)>0) warning("initial point very close to some inequality constraints") res <- mean(res) if (res<.Machine$double.eps^.5) warning("initial parameters very close to inequality constraints") } if (nrow(M$C)>0) if (ncol(M$C)!=nar[2]) stop("ncol(M$C) != length(M$p)") if (length(M$S)!=length(M$off)) stop("M$S and M$off have different lengths") if (length(M$S)!=length(M$sp)) stop("M$sp has different length to M$S and M$off") # pack the S array for mgcv call m<-length(M$S) Sa<-array(0,0);df<-0 if (m>0) for (i in 1:m) { Sa<-c(Sa,M$S[[i]]) df[i]<-nrow(M$S[[i]]) if (M$off[i]+df[i]-1>nar[2]) stop(gettextf("M$S[%d] is too large given M$off[%d]", i, i)) } qra.exist <- FALSE if (ncol(M$X)>nrow(M$X)) { if (m>0) stop("Penalized model matrix must have no more columns than rows") else { ## absorb M$C constraints qra <- qr(t(M$C)) j <- nrow(M$C);k <- ncol(M$X) M$X <- t(qr.qty(qra,t(M$X))[(j+1):k,]) M$Ain <- t(qr.qty(qra,t(M$Ain))[(j+1):k,]) M$C <- matrix(0,0,0) M$p <- rep(0,ncol(M$X)) nar[2] <- length(M$p) qra.exist <- TRUE if (ncol(M$X)>nrow(M$X)) stop("Model matrix not full column rank") } } o<-.C(C_RPCLS,as.double(M$X),as.double(M$p),as.double(M$y),as.double(M$w),as.double(M$Ain),as.double(M$bin) ,as.double(M$C),as.double(Sa),as.integer(M$off),as.integer(df),as.double(M$sp), as.integer(length(M$off)),as.integer(nar)) p <- array(o[[2]],length(M$p)) if (qra.exist) p <- qr.qy(qra,c(rep(0,j),p)) p } ## pcls all.vars1 <- 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 0) { # start the replacement formulae response <- as.character(attr(tf,"variables")[2]) } else { response <- NULL } sp <- attr(tf,"specials")$s # array of indices of smooth terms tp <- attr(tf,"specials")$te # indices of tensor product terms tip <- attr(tf,"specials")$ti # indices of tensor product pure interaction terms t2p <- attr(tf,"specials")$t2 # indices of type 2 tensor product terms zp <- if (is.null(extra.special)) NULL else attr(tf,"specials")[[extra.special]] off <- attr(tf,"offset") # location of offset in formula ## have to translate sp, tp, tip, t2p (zp) so that they relate to terms, ## rather than elements of the formula... vtab <- attr(tf,"factors") # cross tabulation of vars to terms if (length(sp)>0) for (i in 1:length(sp)) { ind <- (1:nt)[as.logical(vtab[sp[i],])] sp[i] <- ind # the term that smooth relates to } if (length(tp)>0) for (i in 1:length(tp)) { ind <- (1:nt)[as.logical(vtab[tp[i],])] tp[i] <- ind # the term that smooth relates to } if (length(tip)>0) for (i in 1:length(tip)) { ind <- (1:nt)[as.logical(vtab[tip[i],])] tip[i] <- ind # the term that smooth relates to } if (length(t2p)>0) for (i in 1:length(t2p)) { ind <- (1:nt)[as.logical(vtab[t2p[i],])] t2p[i] <- ind # the term that smooth relates to } if (length(zp)>0) for (i in 1:length(zp)) { ind <- (1:nt)[as.logical(vtab[zp[i],])] zp[i] <- ind # the term that smooth relates to } ## re-referencing is complete k <- kt <- kti <- kt2 <- ks <- kz <- kp <- 1 # counters for terms in the 2 formulae len.sp <- length(sp) len.tp <- length(tp) len.tip <- length(tip) len.t2p <- length(t2p) len.zp <- length(zp) ns <- len.sp + len.tp + len.tip + len.t2p + len.zp# number of smooths pav <- av <- rep("",0) smooth.spec <- list() #mgcvat <- "package:mgcv" %in% search() ## is mgcv in search path? mgcvns <- loadNamespace('mgcv') if (nt) for (i in 1:nt) { # work through all terms if (k <= ns&&((ks<=len.sp&&sp[ks]==i)||(kt<=len.tp&&tp[kt]==i)||(kz<=len.zp&&zp[kz]==i)|| (kti<=len.tip&&tip[kti]==i)||(kt2<=len.t2p&&t2p[kt2]==i))) { # it's a smooth ## have to evaluate in the environment of the formula or you can't find variables ## supplied as smooth arguments, e.g. k <- 5;gam(y~s(x,k=k)), fails, ## but if you don't specify namespace of mgcv then stuff like ## loadNamespace('mgcv'); k <- 10; mgcv::interpret.gam(y~s(x,k=k)) fails (can't find s) ## eval(parse(text=terms[i]),envir=p.env,enclos=loadNamespace('mgcv')) fails?? ## following may supply namespace of mgcv explicitly if not on search path... ## If 's' etc are masked then we can fail even if mgcv on search path, hence paste ## of explicit mgcv reference into first attempt... st <- try(eval(parse(text=paste("mgcv::",terms[i],sep="")),envir=p.env),silent=TRUE) if (inherits(st,"try-error")) st <- eval(parse(text=terms[i]),enclos=p.env,envir=mgcvns) if (!is.null(textra)) { ## modify the labels on smooths with textra pos <- regexpr("(",st$lab,fixed=TRUE)[1] st$label <- paste(substr(st$label,start=1,stop=pos-1),textra, substr(st$label,start=pos,stop=nchar(st$label)),sep="") } smooth.spec[[k]] <- st if (ks<=len.sp&&sp[ks]==i) ks <- ks + 1 else # counts s() terms if (kt<=len.tp&&tp[kt]==i) kt <- kt + 1 else # counts te() terms if (kti<=len.tip&&tip[kti]==i) kti <- kti + 1 else # counts ti() terms if (kt2<=len.t2p&&t2p[kt2]==i) kt2 <- kt2 + 1 # counts t2() terms else kz <- kz + 1 k <- k + 1 # counts smooth terms } else { # parametric av[kp] <- terms[i] ## element kp on rhs of parametric kp <- kp+1 # counts parametric terms } } if (!is.null(off)) { ## deal with offset av[kp] <- as.character(attr(tf,"variables")[1+off]) kp <- kp+1 } pf <- paste(response,"~",paste(av,collapse=" + ")) if (attr(tf,"intercept")==0) { pf <- paste(pf,"-1",sep="") if (kp>1) pfok <- 1 else pfok <- 0 } else { pfok <- 1;if (kp==1) { pf <- paste(pf,"1"); } } fake.formula <- pf if (length(smooth.spec)>0) for (i in 1:length(smooth.spec)) { nt <- length(smooth.spec[[i]]$term) ff1 <- paste(smooth.spec[[i]]$term[1:nt],collapse="+") fake.formula <- paste(fake.formula,"+",ff1) if (smooth.spec[[i]]$by!="NA") { fake.formula <- paste(fake.formula,"+",smooth.spec[[i]]$by) av <- c(av,smooth.spec[[i]]$term,smooth.spec[[i]]$by) } else av <- c(av,smooth.spec[[i]]$term) } fake.formula <- as.formula(fake.formula,p.env) if (length(av)) { pred.formula <- as.formula(paste("~",paste(av,collapse="+"))) pav <- all.vars(pred.formula) ## trick to strip out 'offset(x)' etc... pred.formula <- reformulate(pav) } else pred.formula <- ~1 ret <- list(pf=as.formula(pf,p.env),pfok=pfok,smooth.spec=smooth.spec, fake.formula=fake.formula,response=response,fake.names=av, pred.names=pav,pred.formula=pred.formula) class(ret) <- "split.gam.formula" ret } ## interpret.gam0 interpret.gam <- function(gf,extra.special=NULL) { ## wrapper to allow gf to be a list of formulae or ## a single formula. This facilitates general penalized ## likelihood models in which several linear predictors ## may be involved... ## ## The list syntax is as follows. The first formula must have a response on ## the lhs, rather than labels. For m linear predictors, there ## must be m 'base formulae' in linear predictor order. lhs labels will ## be ignored in a base formula. Empty base formulae have '-1' on rhs. ## Further formulae have labels up to m labels 1,...,m on the lhs, in a ## syntax like this: 3 + 5 ~ s(x), which indicates that the same s(x) ## should be added to both linear predictors 3 and 5. ## e.g. A bivariate normal model with common expected values might be ## list(y1~-1,y2~-1,1+2~s(x)), whereas if the second component was contaminated ## by something else we might have list(y1~-1,y2~s(v)-1,1+2~s(x)) ## ## For a list argument, this routine returns a list of split.formula objects ## with an extra field "lpi" indicating the linear predictors to which each ## contributes... if (is.list(gf)) { d <- length(gf) ## make sure all formulae have a response, to avoid ## problems with parametric sub formulae of the form ~1 #if (length(gf[[1]])<3) stop("first formula must specify a response") resp <- gf[[1]][2] ret <- list() pav <- av <- rep("",0) nlp <- 0 ## count number of linear predictors (may be different from number of formulae) for (i in 1:d) { textra <- if (i==1) NULL else paste(".",i-1,sep="") ## modify smooth labels to identify to predictor lpi <- getNumericResponse(gf[[i]]) ## get linear predictors to which this applies, if explicit if (length(lpi)==1) warning("single linear predictor indices are ignored") if (length(lpi)>0) gf[[i]][[2]] <- NULL else { ## delete l.p. labels from formula response nlp <- nlp + 1;lpi <- nlp ## this is base formula for l.p. number nlp } ret[[i]] <- interpret.gam0(gf[[i]],textra,extra.special=extra.special) ret[[i]]$lpi <- lpi ## record of the linear predictors to which this applies ## make sure all parametric formulae have a response, to avoid ## problems with parametric sub formulae of the form ~1 respi <- rep("",0) ## no extra response terms if (length(ret[[i]]$pf)==2) { ret[[i]]$pf[3] <- ret[[i]]$pf[2];ret[[i]]$pf[2] <- resp respi <- rep("",0) } else if (i>1) respi <- ret[[i]]$response ## extra response terms av <- c(av,ret[[i]]$fake.names,respi) ## accumulate all required variable names pav <- c(pav,ret[[i]]$pred.names) ## predictors only } av <- unique(av) ## strip out duplicate variable names pav <- unique(pav) if (length(av)>0) { ## work around - reformulate with response = "log(x)" will treat log(x) as a name, ## not the call it should be... fff <- formula(paste(ret[[1]]$response,"~ .")) ret$fake.formula <- reformulate(av,response=ret[[1]]$response) ret$fake.formula[[2]] <- fff[[2]] ## fix messed up response } else ret$fake.formula <- ret[[1]]$fake.formula ## create fake formula containing all variables ret$pred.formula <- if (length(pav)>0) reformulate(pav) else ~1 ## predictor only formula ret$response <- ret[[1]]$response ret$nlp <- nlp ## number of linear predictors for (i in 1:d) if (max(ret[[i]]$lpi)>nlp||min(ret[[i]]$lpi)<1) stop("linear predictor labels out of range") class(ret) <- "split.gam.formula" return(ret) } else interpret.gam0(gf,extra.special=extra.special) } ## interpret.gam fixDependence <- function(X1,X2,tol=.Machine$double.eps^.5,rank.def=0,strict=FALSE) # model matrix X2 may be linearly dependent on X1. This # routine finds which columns of X2 should be zeroed to # fix this. If rank.def>0 then it is taken as the known degree # of dependence of X2 on X1 and tol is ignored. { qr1 <- qr(X1,LAPACK=TRUE) R11 <- abs(qr.R(qr1)[1,1]) r<-ncol(X1);n<-nrow(X1) if (strict) { ## only delete columns of X2 individually dependent on X1 ## Project columns of X2 into space of X1 and look at difference ## to orignal X2 to check for deficiency... QtX2 <- qr.qty(qr1,X2) QtX2[-(1:r),] <- 0 mdiff <- colMeans(abs(X2 - qr.qy(qr1,QtX2))) if (rank.def>0) ind <- (1:ncol(X2))[rank(mdiff) <= rank.def] else ind <- (1:ncol(X2))[mdiff < R11*tol] if (length(ind)<1) ind <- NULL } else { ## make X2 full rank given X1 QtX2 <- qr.qty(qr1,X2)[(r+1):n,] # Q'X2 qr2 <- qr(QtX2,LAPACK=TRUE) R <- qr.R(qr2) # now final diagonal block of R may be zero, indicating rank # deficiency. r0 <- r <- nrow(R) if (rank.def > 0 && rank.def <= nrow(R)) r0 <- r - rank.def else ## degree of rank def known while (r0>0 && mean(abs(R[r0:r,r0:r]))< R11*tol) r0 <- r0 -1 ## compute rank def r0 <- r0 + 1 if (r0>r) return(NULL) else ind <- qr2$pivot[r0:r] # the columns of X2 to zero in order to get independence } ind } ## fixDependence augment.smX <- function(sm,nobs,np) { ## augments a smooth model matrix with a square root penalty matrix for ## identifiability constraint purposes. ns <- length(sm$S) ## number of penalty matrices if (ns==0) { ## nothing to do return(rbind(sm$X,matrix(0,np,ncol(sm$X)))) } ind <- colMeans(abs(sm$S[[1]]))!=0 sqrmaX <- mean(abs(sm$X[,ind]))^2 alpha <- sqrmaX/mean(abs(sm$S[[1]][ind,ind])) St <- sm$S[[1]]*alpha if (ns>1) for (i in 2:ns) { ind <- colMeans(abs(sm$S[[i]]))!=0 alpha <- sqrmaX/mean(abs(sm$S[[i]][ind,ind])) St <- St + sm$S[[i]]*alpha } rS <- mroot(St,rank=ncol(St)) ## get sqrt of penalty X <- rbind(sm$X,matrix(0,np,ncol(sm$X))) ## create augmented model matrix X[nobs+sm$p.ind,] <- t(rS) ## add in X ## scaled augmented model matrix } ## augment.smX gam.side <- function(sm,Xp,tol=.Machine$double.eps^.5,with.pen=FALSE) # works through a list of smooths, sm, aiming to identify nested or partially # nested terms, and impose identifiability constraints on them. # Xp is the parametric model matrix. It is needed in order to check whether # there is a constant (or equivalent) in the model. If there is, then this needs # to be included when working out side constraints, otherwise dependencies can be # missed. # Note that with.pen is quite extreme, since you then pretty much only pick # up dependencies in the null spaces { if (!with.pen) { ## check that's possible and reset if not! with.pen <- nrow(Xp) < ncol(Xp) + sum(unlist(lapply(sm,function(x) ncol(x$X)))) } m <- length(sm) if (m==0) return(sm) v.names<-array("",0);maxDim<-1 for (i in 1:m) { ## collect all term names and max smooth `dim' vn <- sm[[i]]$term ## need to include by variables in names if (sm[[i]]$by!="NA") vn <- paste(vn,sm[[i]]$by,sep="") ## need to distinguish levels of factor by variables... if (!is.null(sm[[i]]$by.level)) vn <- paste(vn,sm[[i]]$by.level,sep="") sm[[i]]$vn <- vn ## use this record to identify variables from now v.names <- c(v.names,vn) if (sm[[i]]$dim > maxDim) maxDim <- sm[[i]]$dim } lv <- length(v.names) v.names <- unique(v.names) if (lv == length(v.names)) return(sm) ## no repeats => no nesting ## Only get this far if there is nesting. ## Need to test for intercept or equivalent in Xp intercept <- FALSE if (ncol(Xp)) { ## first check columns directly... if (sum(apply(Xp,2,sd)<.Machine$double.eps^.75)>0) intercept <- TRUE else { ## no constant column, so need to check span of Xp... f <- rep(1,nrow(Xp)) ff <- qr.fitted(qr(Xp),f) if (max(abs(ff-f))<.Machine$double.eps^.75) intercept <- TRUE } } sm.id <- as.list(v.names) names(sm.id) <- v.names for (i in 1:length(sm.id)) sm.id[[i]]<-array(0,0) sm.dim <- sm.id for (d in 1:maxDim) { for (i in 1:m) { if (sm[[i]]$dim==d&&sm[[i]]$side.constrain) for (j in 1:d) { ## work through terms term<-sm[[i]]$vn[j] a <- sm.id[[term]] la <- length(a)+1 sm.id[[term]][la] <- i ## record smooth i.d. for this variable sm.dim[[term]][la] <- d ## ... and smooth dim. } } } ## so now each unique variable name has an associated array of ## the smooths of which it is an argument, arranged in ascending ## order of dimension. Smooths for which side.constrain==FALSE are excluded. if (maxDim==1) warning("model has repeated 1-d smooths of same variable.") ## Now set things up to enable term specific model matrices to be ## augmented with square root penalties, on the fly... if (with.pen) { k <- 1 for (i in 1:m) { ## create parameter indices for each term k1 <- k + ncol(sm[[i]]$X) - 1 sm[[i]]$p.ind <- k:k1 k <- k1 + 1 } np <- k-1 ## number of penalized parameters } nobs <- nrow(sm[[1]]$X) ## number of observations for (d in 1:maxDim) { ## work up through dimensions for (i in 1:m) { ## work through smooths if (sm[[i]]$dim == d&&sm[[i]]$side.constrain) { ## check for nesting if (with.pen) X1 <- matrix(c(rep(1,nobs),rep(0,np)),nobs+np,as.integer(intercept)) else X1 <- matrix(1,nobs,as.integer(intercept)) X1comp <- rep(0,0) ## list of components of X1 to avoid duplication for (j in 1:d) { ## work through variables b <- sm.id[[sm[[i]]$vn[j]]] # list of smooths dependent on this variable k <- (1:length(b))[b==i] ## locate current smooth in list if (k>1) for (l in 1:(k-1)) if (!b[l] %in% X1comp) { ## collect X columns X1comp <- c(X1comp,b[l]) ## keep track of components to avoid adding same one twice if (with.pen) { ## need to use augmented model matrix in testing if (is.null(sm[[b[l]]]$Xa)) sm[[b[l]]]$Xa <- augment.smX(sm[[b[l]]],nobs,np) X1 <- cbind(X1,sm[[b[l]]]$Xa) } else X1 <- cbind(X1,sm[[b[l]]]$X) ## penalties not considered } } ## Now X1 contains columns for all lower dimensional terms if (ncol(X1)==as.integer(intercept)) ind <- NULL else { if (with.pen) { if (is.null(sm[[i]]$Xa)) sm[[i]]$Xa <- augment.smX(sm[[i]],nobs,np) ind <- fixDependence(X1,sm[[i]]$Xa,tol=tol) } else ind <- fixDependence(X1,sm[[i]]$X,tol=tol) } ## ... the columns to zero to ensure independence if (!is.null(ind)) { sm[[i]]$X <- sm[[i]]$X[,-ind] ## work through list of penalty matrices, applying constraints... nsmS <- length(sm[[i]]$S) if (nsmS>0) for (j in nsmS:1) { ## working down so that dropping is painless sm[[i]]$S[[j]] <- sm[[i]]$S[[j]][-ind,-ind] if (sum(sm[[i]]$S[[j]]!=0)==0) rank <- 0 else rank <- qr(sm[[i]]$S[[j]],tol=tol,LAPACK=FALSE)$rank sm[[i]]$rank[j] <- rank ## replace previous rank with new rank if (rank == 0) { ## drop the penalty sm[[i]]$rank <- sm[[i]]$rank[-j] sm[[i]]$S[[j]] <- NULL sm[[i]]$S.scale <- sm[[i]]$S.scale[-j] if (!is.null(sm[[i]]$L)) sm[[i]]$L <- sm[[i]]$L[-j,,drop=FALSE] } } ## penalty matrices finished ## Now we need to establish null space rank for the term mi <- length(sm[[i]]$S) if (mi>0) { St <- sm[[i]]$S[[1]]/norm(sm[[i]]$S[[1]],type="F") if (mi>1) for (j in 1:mi) St <- St + sm[[i]]$S[[j]]/norm(sm[[i]]$S[[j]],type="F") es <- eigen(St,symmetric=TRUE,only.values=TRUE) sm[[i]]$null.space.dim <- sum(es$values don't clone } specb ## return clone } ## clone.smooth.spec 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)0) return(rep(0,0)) ## deparse turns lhs into a string; strsplit extracts the characters ## corresponding to numbers; unlist deals with the fact that deparse ## will split long lines resulting in multiple list items from ## strsplit; as.numeric converts the numbers; na.omit drops NAs ## resulting from "" elements; unique & round are obvious... round(unique(na.omit(as.numeric(unlist(strsplit(deparse(form[[2]]), "[^0-9]+")))))) } ## getNumericResponse olid <- function(X,nsdf,pstart,flpi,lpi) { ## X is a model matrix, made up of nf=length(nsdf) column blocks. ## The ith block starts at column pstart[i] and its first nsdf[i] ## columns are unpenalized. X is used to define nlp=length(lpi) ## linear predictors. lpi[[i]] gives the columns of X used in the ## ith linear predictor. flpi[j] gives the linear predictor(s) ## to which the jth block of X belongs. The problem is that the ## unpenalized blocks need not be identifiable when used in combination. ## This function returns a vector dind of columns of X to drop for ## identifiability, along with modified lpi, pstart and nsdf vectors. nlp <- length(lpi) ## number of linear predictors n <- nrow(X) nf <- length(nsdf) ## number of formulae blocks Xp <- matrix(0,n*nlp,sum(nsdf)) start <- 1 ii <- 1:n tind <- rep(0,0) ## complete index of all parametric columns in X ## create a block matrix, Xp, with the same identifiability properties as ## unpenalized part of model... for (i in 1:nf) { stop <- start - 1 + nsdf[i] if (stop>=start) { ind <- pstart[i] + 1:nsdf[i] - 1 for (k in flpi[[i]]) { Xp[ii+(k-1)*n,start:stop] <- X[,ind] } tind <- c(tind,ind) start <- start + nsdf[i] } } ## rank deficiency of Xp will reveal number of redundant parametric ## terms, and a pivoted QR will reveal which to drop to restore ## full rank... qrx <- qr(Xp,LAPACK=TRUE,tol=0.0) ## unidentifiable columns get pivoted to final cols r <- Rrank(qr.R(qrx)) ## get rank from R factor of pivoted QR if (r==ncol(Xp)) { ## full rank, all fine, drop nothing dind <- rep(0,0) } else { ## reduced rank, drop some columns dind <- tind[sort(qrx$pivot[(r+1):ncol(X)],decreasing=TRUE)] ## columns to drop ## now we need to adjust nsdf, pstart and lpi for (d in dind) { ## working down through drop indices ## following commented out code is useful should it ever prove necessary to ## adjust pstart and nsdf, but at present these are only used in prediction, ## and it is cleaner to leave them unchanged, and simply drop using dind during prediction. #k <- if (d>=pstart[nf]) nlp else which(d >= pstart[1:(nf-1)] & d < pstart[2:nf]) #nsdf[k] <- nsdf[k] - 1 ## one less unpenalized column in this block #if (k0) lpi[[i]] <- lpi[[i]][-k] ## drop row k <- which(lpi[[i]]>d) if (length(k)>0) lpi[[i]][k] <- lpi[[i]][k] - 1 ## close up } } ## end of drop index loop } list(dind=dind,lpi=lpi) ##,pstart=pstart,nsdf=nsdf) } ## olid gam.setup.list <- 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=NULL,apply.by=TRUE,modCon=0) { ## version of gam.setup for when gam is called with a list of formulae, ## specifying several linear predictors... ## key difference to gam.setup is an attribute to the model matrix, "lpi", which is a list ## of column indices for each linear predictor if (!is.null(paraPen)) stop("paraPen not supported for multi-formula models") if (!absorb.cons) stop("absorb.cons must be TRUE for multi-formula models") d <- length(pterms) ## number of formulae if (is.null(drop.intercept)) drop.intercept <- rep(FALSE, d) if (length(drop.intercept) != d) stop("length(drop.intercept) should be equal to number of model formulas") lp.overlap <- if (formula$nlp0) sp <- sp[-(1:used.sp)] ## need to strip off already used sp's if (!is.null(min.sp)&&nrow(G$L)>0) min.sp <- min.sp[-(1:nrow(G$L))] ## formula[[1]] always relates to the base formula of the first linear predictor... flpi <- lpi <- list() for (i in 1:formula$nlp) lpi[[i]] <- rep(0,0) lpi[[1]] <- 1:ncol(G$X) ## lpi[[j]] is index of cols for jth linear predictor flpi[[1]] <- formula[[1]]$lpi ## used in identifiability testing by olid, later pof <- ncol(G$X) ## counts the model matrix columns produced so far pstart <- rep(0,d) ## indexes where parameteric columns start in each formula block of X pstart[1] <- 1 if (d>1) for (i in 2:d) { if (is.null(formula[[i]]$response)) { ## keep gam.setup happy formula[[i]]$response <- formula$response mv.response <- FALSE } else mv.response <- TRUE #spind <- if (is.null(sp)) 1 else (length(G$S)+1):length(sp) formula[[i]]$pfok <- 1 ## empty formulae OK here! um <- gam.setup(formula[[i]],pterms[[i]], data,knots,sp,min.sp,#sp[spind],min.sp[spind], H,absorb.cons,sparse.cons,select, idLinksBases,scale.penalty,paraPen,gamm.call,drop.intercept[i],apply.by=apply.by,list.call=TRUE,modCon=modCon) used.sp <- length(um$lsp0) if (!is.null(sp)&&used.sp>0) sp <- sp[-(1:used.sp)] ## need to strip off already used sp's if (!is.null(min.sp)&&nrow(um$L)>0) min.sp <- min.sp[-(1:nrow(um$L))] flpi[[i]] <- formula[[i]]$lpi for (j in formula[[i]]$lpi) { ## loop through all l.p.s to which this term contributes lpi[[j]] <- c(lpi[[j]],pof + 1:ncol(um$X)) ## add these cols to lpi[[j]] ##lpi[[i]] <- pof + 1:ncol(um$X) ## old code } if (mv.response) G$y <- cbind(G$y,um$y) if (i>formula$nlp&&!is.null(um$offset)) { stop("shared offsets not allowed") } G$offset[[i]] <- um$offset #G$contrasts[[i]] <- um$contrasts if (!is.null(um$contrasts)) G$contrasts <- c(G$contrasts,um$contrasts) G$xlevels[[i]] <- um$xlevels G$assign[[i]] <- um$assign G$rank <- c(G$rank,um$rank) pstart[i] <- pof+1 G$X <- cbind(G$X,um$X) ## extend model matrix ## deal with the smooths... k <- G$m if (um$m) for (j in 1:um$m) { um$smooth[[j]]$first.para <- um$smooth[[j]]$first.para + pof um$smooth[[j]]$last.para <- um$smooth[[j]]$last.para + pof k <- k + 1 G$smooth[[k]] <- um$smooth[[j]] } ## L, S and off... ks <- length(G$S) M <- length(um$S) if (!is.null(um$L)||!is.null(G$L)) { if (is.null(G$L)) G$L <- diag(1,nrow=ks) if (is.null(um$L)) um$L <- diag(1,nrow=M) G$L <- rbind(cbind(G$L,matrix(0,nrow(G$L),ncol(um$L))),cbind(matrix(0,nrow(um$L),ncol(G$L)),um$L)) } G$off <- c(G$off,um$off+pof) if (M) for (j in 1:M) { ks <- ks + 1 G$S[[ks]] <- um$S[[j]] } G$m <- G$m + um$m ## number of smooths ##G$nsdf <- G$nsdf + um$nsdf ## or list?? G$nsdf[i] <- um$nsdf if (!is.null(um$P)||!is.null(G$P)) { if (is.null(G$P)) G$P <- diag(1,nrow=pof) k <- ncol(um$X) if (is.null(um$P)) um$P <- diag(1,nrow=k) G$P <- rbind(cbind(G$P,matrix(0,pof,k)),cbind(matrix(0,k,pof),um$P)) } G$cmX <- c(G$cmX,um$cmX) if (um$nsdf>0) um$term.names[1:um$nsdf] <- paste(um$term.names[1:um$nsdf],i-1,sep=".") G$term.names <- c(G$term.names,um$term.names) G$lsp0 <- c(G$lsp0,um$lsp0) G$sp <- c(G$sp,um$sp) pof <- ncol(G$X) } ## formula loop end ## If there is overlap then there is a danger of lack of identifiability of the ## parameteric terms, especially if there are factors present in shared components. ## The following code deals with this possibility... if (lp.overlap) { rt <- olid(G$X,G$nsdf,pstart,flpi,lpi) if (length(rt$dind)>0) { ## then columns have to be dropped warning("dropping unidentifiable parametric terms from model",call.=FALSE) G$X <- G$X[,-rt$dind] ## drop cols G$cmX <- G$cmX[-rt$dind] G$term.names <- G$term.names[-rt$dind] ## adjust indexing in smooth list, noting that coefs of smooths ## are never dropped by dind for (i in 1:length(G$smooth)) { k <- sum(rt$dind < G$smooth[[i]]$first.para) G$smooth[[i]]$first.para <- G$smooth[[i]]$first.para - k G$smooth[[i]]$last.para <- G$smooth[[i]]$last.para - k } for (i in 1:length(G$off)) G$off[i] <- G$off[i] - sum(rt$dind < G$off[i]) ## replace various indices with updated versions... # pstart <- rt$pstart; G$nsdf <- rt$nsdf ## these two only needed in predict.gam - cleaner to leave unchanged lpi <- rt$lpi attr(G$nsdf,"drop.ind") <- rt$dind ## store drop index } } attr(lpi,"overlap") <- lp.overlap attr(G$X,"lpi") <- lpi attr(G$nsdf,"pstart") <- pstart ##unlist(lapply(lpi,min)) ## assemble a global indicator array for non-linear parameters... G$g.index <- rep(FALSE,ncol(G$X)) if (length(G$smooth)) for (i in 1:length(G$smooth)) if (!is.null(G$smooth[[i]]$g.index)) G$g.index[G$smooth[[i]]$first.para:G$smooth[[i]]$last.para] <- G$smooth[[i]]$g.index if (!any(G$g.index)) G$g.index <- NULL G } ## gam.setup.list 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 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 formula.gam <- function(x, ...) # 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 } gam.outer <- function(lsp,fscale,family,control,method,optimizer,criterion,scale,gamma,G,start=NULL,...) # function for smoothing parameter estimation by outer optimization. i.e. # P-IRLS scheme iterated to convergence for each trial set of smoothing # parameters. # MAJOR STEPS: # 1. Call appropriate smoothing parameter optimizer, and extract fitted model # `object' # 2. Call `gam.fit3.post.proc' to get parameter covariance matrices, edf etc to # add to `object' { if (is.na(optimizer[2])) optimizer[2] <- "newton" if (!optimizer[2]%in%c("newton","bfgs","nlm","optim","nlm.fd")) stop("unknown outer optimization method.") if (optimizer[2]%in%c("nlm.fd")) .Deprecated(msg=paste("optimizer",optimizer[2],"is deprecated, please use newton or bfgs")) # if (optimizer[1]=="efs" && !inherits(family,"general.family")) { # warning("Extended Fellner Schall only implemented for general families") # optimizer <- c("outer","newton") # } if (length(lsp)==0) { ## no sp estimation to do -- run a fit instead optimizer[2] <- "no.sps" ## will cause gam2objective to be called, below } nbGetTheta <- substr(family$family[1],1,17)=="Negative Binomial" && length(family$getTheta())>1 if (nbGetTheta) stop("Please provide a single value for theta or use nb to estimate it") if (optimizer[2]=="nlm.fd") { #if (nbGetTheta) stop("nlm.fd not available with negative binomial Theta estimation") if (method%in%c("REML","ML","GACV.Cp","P-ML","P-REML")) stop("nlm.fd only available for GCV/UBRE") um<-nlm(full.score,lsp,typsize=lsp,fscale=fscale, stepmax = control$nlm$stepmax, ndigit = control$nlm$ndigit, gradtol = control$nlm$gradtol, steptol = control$nlm$steptol, iterlim = control$nlm$iterlim, G=G,family=family,control=control, gamma=gamma,start=start,...) lsp<-um$estimate object<-attr(full.score(lsp,G,family,control,gamma=gamma,...),"full.gam.object") object$gcv.ubre <- um$minimum object$outer.info <- um object$sp <- exp(lsp) return(object) } ## some preparations for the other methods, which all use gam.fit3... family <- fix.family.link(family) family <- fix.family.var(family) if (method%in%c("REML","ML","P-REML","P-ML")) family <- fix.family.ls(family) if (optimizer[1]=="efs"&& optimizer[2] != "no.sps" ) { ## experimental extended efs ##warning("efs is still experimental!") if (inherits(family,"general.family")) { object <- efsud(x=G$X,y=G$y,lsp=lsp,Sl=G$Sl,weights=G$w,offset=G$offxset,family=family, control=control,Mp=G$Mp,start=start) } else { family <- fix.family.ls(family) object <- efsudr(x=G$X,y=G$y,lsp=lsp,Eb=G$Eb,UrS=G$UrS,weights=G$w,family=family,offset=G$offset, start=start, U1=G$U1, intercept = TRUE,scale=scale,Mp=G$Mp,control=control,n.true=G$n.true,...) } object$gcv.ubre <- object$REML } else if (optimizer[2]=="newton"||optimizer[2]=="bfgs"){ ## the gam.fit3 method if (optimizer[2]=="bfgs") b <- bfgs(lsp=lsp,X=G$X,y=G$y,Eb=G$Eb,UrS=G$UrS,L=G$L,lsp0=G$lsp0,offset=G$offset,U1=G$U1,Mp = G$Mp, family=family,weights=G$w,control=control,gamma=gamma,scale=scale,conv.tol=control$newton$conv.tol, maxNstep= control$newton$maxNstep,maxSstep=control$newton$maxSstep,maxHalf=control$newton$maxHalf, printWarn=FALSE,scoreType=criterion,null.coef=G$null.coef,start=start, pearson.extra=G$pearson.extra,dev.extra=G$dev.extra,n.true=G$n.true,Sl=G$Sl,...) else b <- newton(lsp=lsp,X=G$X,y=G$y,Eb=G$Eb,UrS=G$UrS,L=G$L,lsp0=G$lsp0,offset=G$offset,U1=G$U1,Mp=G$Mp, family=family,weights=G$w,control=control,gamma=gamma,scale=scale,conv.tol=control$newton$conv.tol, maxNstep= control$newton$maxNstep,maxSstep=control$newton$maxSstep,maxHalf=control$newton$maxHalf, printWarn=FALSE,scoreType=criterion,null.coef=G$null.coef,start=start, pearson.extra=G$pearson.extra,dev.extra=G$dev.extra,n.true=G$n.true,Sl=G$Sl, edge.correct=control$edge.correct,...) object <- b$object object$REML <- object$REML1 <- object$REML2 <- object$GACV <- object$D2 <- object$P2 <- object$UBRE2 <- object$trA2 <- object$GACV1 <- object$GACV2 <- object$GCV2 <- object$D1 <- object$P1 <- NULL object$sp <- as.numeric(exp(b$lsp)) object$gcv.ubre <- b$score b <- list(conv=b$conv,iter=b$iter,grad=b$grad,hess=b$hess,score.hist=b$score.hist) ## return info object$outer.info <- b } else { ## methods calling gam.fit3 args <- list(X=G$X,y=G$y,Eb=G$Eb,UrS=G$UrS,offset=G$offset,U1=G$U1,Mp=G$Mp,family=family, weights=G$w,control=control,scoreType=criterion,gamma=gamma,scale=scale, L=G$L,lsp0=G$lsp0,null.coef=G$null.coef,n.true=G$n.true,Sl=G$Sl,start=start) if (optimizer[2]=="nlm") { b <- nlm(gam4objective, lsp, typsize = lsp, fscale = fscale, stepmax = control$nlm$stepmax, ndigit = control$nlm$ndigit, gradtol = control$nlm$gradtol, steptol = control$nlm$steptol, iterlim = control$nlm$iterlim, check.analyticals=control$nlm$check.analyticals, args=args,...) lsp <- b$estimate } else if (optimizer[2]=="optim") { b<-optim(par=lsp,fn=gam2objective,gr=gam2derivative,method="L-BFGS-B",control= list(fnscale=fscale,factr=control$optim$factr,lmm=min(5,length(lsp))),args=args,...) lsp <- b$par } else b <- NULL obj <- gam2objective(lsp,args,printWarn=TRUE,...) # final model fit, with warnings object <- attr(obj,"full.fit") object$gcv.ubre <- as.numeric(obj) object$outer.info <- b object$sp <- exp(lsp) } # end of methods calling gam.fit2 if (scale>0) { object$scale.estimated <- FALSE; object$scale <- scale} else { object$scale <- object$scale.est;object$scale.estimated <- TRUE } object$control <- control object$method <- method if (inherits(family,"general.family")) { mv <- gam.fit5.post.proc(object,G$Sl,G$L,G$lsp0,G$S,G$off) ## object$coefficients <- Sl.initial.repara(G$Sl,object$coefficients,inverse=TRUE) } else mv <- gam.fit3.post.proc(G$X,G$L,G$lsp0,G$S,G$off,object) ## note: use of the following in place of Vp appears to mess up p-values for smooths, ## but doesn't change r.e. p-values of course. if (!is.null(mv$Vc)) object$Vc <- mv$Vc if (!is.null(mv$edf2)) object$edf2 <- mv$edf2 object$Vp <- mv$Vb object$hat<-mv$hat object$Ve <- mv$Ve object$edf<-mv$edf object$edf1 <- mv$edf1 ##object$F <- mv$F ## DoF matrix --- probably not needed object$R <- mv$R ## qr.R(sqrt(W)X) object$aic <- object$aic + 2*sum(mv$edf) object$nsdf <- G$nsdf object$K <- object$D1 <- object$D2 <- object$P <- object$P1 <- object$P2 <- object$GACV <- object$GACV1 <- object$GACV2 <- object$REML <- object$REML1 <- object$REML2 <- object$GCV<-object$GCV1<- object$GCV2 <- object$UBRE <-object$UBRE1 <- object$UBRE2 <- object$trA <- object$trA1<- object$trA2 <- object$alpha <- object$alpha1 <- object$scale.est <- NULL object$sig2 <- object$scale object } ## gam.outer get.null.coef <- function(G,start=NULL,etastart=NULL,mustart=NULL,...) { ## Get an estimate of the coefs corresponding to maximum reasonable deviance... y <- G$y weights <- G$w nobs <- G$n ## ignore codetools warning!! ##start <- etastart <- mustart <- NULL family <- G$family eval(family$initialize) ## have to do this to ensure y numeric y <- as.numeric(y) mum <- mean(y)+0*y etam <- family$linkfun(mum) null.coef <- qr.coef(qr(G$X),etam) null.coef[is.na(null.coef)] <- 0; ## get a suitable function scale for optimization routines null.scale <- sum(family$dev.resids(y,mum,weights))/nrow(G$X) list(null.coef=null.coef,null.scale=null.scale) } estimate.gam <- function (G,method,optimizer,control,in.out,scale,gamma,start=NULL,...) { ## Do gam estimation and smoothness selection... if (inherits(G$family,"extended.family")) { ## then there are some restrictions... if (!(method%in%c("REML","ML"))) method <- "REML" if (optimizer[1]=="perf") optimizer <- c("outer","newton") if (inherits(G$family,"general.family")) { method <- "REML" ## any method you like as long as it's REML G$Sl <- Sl.setup(G) ## prepare penalty sequence G$X <- Sl.initial.repara(G$Sl,G$X,both.sides=FALSE) ## re-parameterize accordingly if (!is.null(start)) start <- Sl.initial.repara(G$Sl,start,inverse=FALSE,both.sides=FALSE) ## make sure optimizer appropriate for available derivatives if (!is.null(G$family$available.derivs)) { if (G$family$available.deriv==1 && optimizer[1]!="efs") optimizer <- c("outer","bfgs") if (G$family$available.derivs==0) optimizer <- "efs" } } } if (!optimizer[1]%in%c("perf","outer","efs")) stop("unknown optimizer") if (optimizer[1]=="efs") method <- "REML" if (!method%in%c("GCV.Cp","GACV.Cp","REML","P-REML","ML","P-ML")) stop("unknown smoothness selection criterion") G$family <- fix.family(G$family) G$rS <- mini.roots(G$S,G$off,ncol(G$X),G$rank) if (method%in%c("REML","P-REML","ML","P-ML")) { if (optimizer[1]=="perf") { warning("Reset optimizer to outer/newton") optimizer <- c("outer","newton") } reml <- TRUE } else reml <- FALSE ## experimental insert Ssp <- totalPenaltySpace(G$S,G$H,G$off,ncol(G$X)) G$Eb <- Ssp$E ## balanced penalty square root for rank determination purposes G$U1 <- cbind(Ssp$Y,Ssp$Z) ## eigen space basis G$Mp <- ncol(Ssp$Z) ## null space dimension G$UrS <- list() ## need penalty matrices in overall penalty range space... if (length(G$S)>0) for (i in 1:length(G$S)) G$UrS[[i]] <- t(Ssp$Y)%*%G$rS[[i]] else i <- 0 if (!is.null(G$H)) { ## then the sqrt fixed penalty matrix H is needed for (RE)ML G$UrS[[i+1]] <- t(Ssp$Y)%*%mroot(G$H) } # is outer looping needed ? outer.looping <- ((!G$am && (optimizer[1]!="perf"))||reml||method=="GACV.Cp") ## && length(G$S)>0 && sum(G$sp<0)!=0 ## sort out exact sp selection criterion to use fam.name <- G$family$family[1] if (scale==0) { ## choose criterion for performance iteration if (fam.name == "binomial"||fam.name == "poisson") G$sig2<-1 #ubre else G$sig2 <- -1 #gcv } else {G$sig2 <- scale} if (reml) { ## then RE(ML) selection, but which variant? criterion <- method if (fam.name == "binomial"||fam.name == "poisson") scale <- 1 if (inherits(G$family,"extended.family") && scale <=0) { scale <- if (is.null(G$family$scale)) 1 else G$family$scale } } else { if (scale==0) { if (fam.name=="binomial"||fam.name=="poisson") scale <- 1 #ubre else scale <- -1 #gcv } if (scale > 0) criterion <- "UBRE" else { if (method=="GCV.Cp") criterion <- "GCV" else criterion <- "GACV" } } if (substr(fam.name,1,17)=="Negative Binomial") { scale <- 1; ## no choice if (method%in%c("GCV.Cp","GACV.Cp")) criterion <- "UBRE" } ## Reset P-ML or P-REML in known scale parameter cases if (scale>0) { if (method=="P-ML") criterion <- method <- "ML" else if (method=="P-REML") criterion <- method <- "REML" } # take only a few IRLS steps to get scale estimates for "pure" outer # looping... family <- G$family; nb.fam.reset <- FALSE if (outer.looping) { ## how many performance iteration steps to use for initialization... fixedSteps <- if (inherits(G$family,"extended.family")) 0 else control$outerPIsteps if (substr(G$family$family[1],1,17)=="Negative Binomial") { ## initialize sensibly scale <- G$sig2 <- 1 G$family <- negbin(max(family$getTheta()),link=family$link) nb.fam.reset <- TRUE } } else fixedSteps <- control$maxit+2 ## extended family may need to manipulate G... if (!is.null(G$family$preinitialize)) { if (inherits(G$family,"general.family")) { Gmod <- G$family$preinitialize(G) ## modifies some elements of G for (gnam in names(Gmod)) G[[gnam]] <- Gmod[[gnam]] ## copy these into G } else { ## extended family - just initializes theta and possibly y pini <- G$family$preinitialize(G$y,G$family) if (!is.null(pini$Theta)) G$family$putTheta(pini$Theta) if (!is.null(pini$y)) G$y <- pini$y } } if (length(G$sp)>0) lsp2 <- log(initial.spg(G$X,G$y,G$w,G$family,G$S,G$rank,G$off, offset=G$offset,L=G$L,lsp0=G$lsp0,E=G$Eb,...)) else lsp2 <- rep(0,0) if (outer.looping && !is.null(in.out)) { # initial s.p.s and scale provided ok <- TRUE ## run a few basic checks if (is.null(in.out$sp)||is.null(in.out$scale)) ok <- FALSE if (length(in.out$sp)!=length(G$sp)) ok <- FALSE if (!ok) stop("in.out incorrect: see documentation") lsp <- log(in.out$sp) } else {## do performance iteration.... if (fixedSteps>0) { object <- gam.fit(G,family=G$family,control=control,gamma=gamma,fixedSteps=fixedSteps,...) lsp <- log(object$sp) } else { lsp <- lsp2 } } if (nb.fam.reset) G$family <- family ## restore, in case manipulated for negative binomial if (outer.looping) { # don't allow PI initial sp's too far from defaults, otherwise optimizers may # get stuck on flat portions of GCV/UBRE score.... if (is.null(in.out)&&length(lsp)>0) { ## note no checks if supplied ind <- lsp > lsp2+5;lsp[ind] <- lsp2[ind]+5 ind <- lsp < lsp2-5;lsp[ind] <- lsp2[ind]-5 } ## Get an estimate of the coefs corresponding to maximum reasonable deviance, ## and an estimate of the function scale, suitable for optimizers that need this. ## Doesn't make sense for general families that have to initialize coefs directly. ## null.stuff <- if(inherits(G$family,"general.family")) list() else get.null.coef(G,...) ## Matteo modification to facilitate qgam... null.stuff <- if (inherits(G$family,"general.family")) list() else { if (is.null(G$family$get.null.coef)) get.null.coef(G,...) else G$family$get.null.coef(G,...) } if (fixedSteps>0&&is.null(in.out)) mgcv.conv <- object$mgcv.conv else mgcv.conv <- NULL if (criterion%in%c("REML","ML")&&scale<=0) { ## log(scale) to be estimated as a smoothing parameter if (fixedSteps>0) { log.scale <- log(sum(object$weights*object$residuals^2)/(G$n-sum(object$edf))) } else { if (is.null(in.out)) { log.scale <- log(null.stuff$null.scale/10) } else { log.scale <- log(in.out$scale) } } lsp <- c(lsp,log.scale) ## append log initial scale estimate to lsp ## extend G$L, if present... if (!is.null(G$L)) { G$L <- cbind(rbind(G$L,rep(0,ncol(G$L))),c(rep(0,nrow(G$L)),1)) #attr(G$L,"scale") <- TRUE ## indicates scale estimated as sp } if (!is.null(G$lsp0)) G$lsp0 <- c(G$lsp0,0) } ## check if there are extra parameters to estimate if (inherits(G$family,"extended.family")&&!inherits(G$family,"general.family")&&G$family$n.theta>0) { th0 <- G$family$getTheta() ## additional (initial) parameters of likelihood nth <- length(th0) nlsp <- length(lsp) ind <- 1:nlsp + nth ## only used if nlsp>0 lsp <- c(th0,lsp) ## append to start of lsp ## extend G$L, G$lsp0 if present... if (!is.null(G$L)&&nth>0) { L <- rbind(cbind(diag(nth),matrix(0,nth,ncol(G$L))), cbind(matrix(0,nrow(G$L),nth),G$L)) #sat <- attr(G$L,"scale") G$L <- L #attr(G$L,"scale") <- sat #attr(G$L,"not.sp") <- nth ## first not.sp params are not smoothing params } if (!is.null(G$lsp0)) G$lsp0 <- c(th0*0,G$lsp0) } else nth <- 0 G$null.coef <- null.stuff$null.coef object <- gam.outer(lsp,fscale=null.stuff$null.scale, ##abs(object$gcv.ubre)+object$sig2/length(G$y), family=G$family,control=control,criterion=criterion,method=method, optimizer=optimizer,scale=scale,gamma=gamma,G=G,start=start,...) if (criterion%in%c("REML","ML")&&scale<=0) object$sp <- object$sp[-length(object$sp)] ## drop scale estimate from sp array if (inherits(G$family,"extended.family")&&nth>0) object$sp <- object$sp[-(1:nth)] ## drop theta params object$mgcv.conv <- mgcv.conv } ## finished outer looping ## correct null deviance if there's an offset [Why not correct calc in gam.fit/3???].... if (!inherits(G$family,"extended.family")&&G$intercept&&any(G$offset!=0)) object$null.deviance <- glm(object$y~offset(G$offset),family=object$family,weights=object$prior.weights)$deviance object$method <- criterion object$smooth<-G$smooth names(object$edf) <- G$term.names names(object$edf1) <- G$term.names if (inherits(family,"general.family")) { object$coefficients <- Sl.initial.repara(G$Sl,object$coefficients,inverse=TRUE) } ## extended family may need to manipulate fit object. Code ## will need to include the following line if G$X used... ## G$X <- Sl.initial.repara(G$Sl,G$X,inverse=TRUE,cov=FALSE,both.sides=FALSE) if (!is.null(G$family$postproc)) { if (inherits(G$family,"general.family")) eval(G$family$postproc) else { posr <- G$family$postproc(family=object$family,y=G$y,prior.weights=object$prior.weights, fitted=object$fitted.values,linear.predictors=object$linear.predictors,offset=G$offset, intercept=G$intercept) if (!is.null(posr$family)) object$family$family <- posr$family if (!is.null(posr$deviance)) object$deviance <- posr$deviance if (!is.null(posr$null.deviance)) object$null.deviance <- posr$null.deviance } } if (!is.null(G$P)) { ## matrix transforming from fit to prediction parameterization object$coefficients <- as.numeric(G$P %*% object$coefficients) object$Vp <- G$P %*% object$Vp %*% t(G$P) object$Ve <- G$P %*% object$Ve %*% t(G$P) rownames(object$Vp) <- colnames(object$Vp) <- G$term.names rownames(object$Ve) <- colnames(object$Ve) <- G$term.names } names(object$coefficients) <- G$term.names object } ## end estimate.gam variable.summary <- function(pf,dl,n) { ## routine to summarize all the variables in dl, which is a list ## containing raw input variables to a model (i.e. no functions applied) ## pf is a formula containing the strictly parametric part of the ## model for the variables in dl. A list is returned, with names given by ## the variables. For variables in the parametric part, then the list elements ## may be: ## * a 1 column matrix with elements set to the column medians, if variable ## is a matrix. ## * a 3 figure summary (min,median,max) for a numeric variable. ## * a factor variable, with the most commonly occuring factor (all levels) ## --- classes are as original data type, but anything not numeric, factor or matrix ## is coerced to numeric. ## For non-parametric variables, any matrices are coerced to numeric, otherwise as ## parametric. ## medians in the above are always observed values (to deal with variables coerced to ## factors in the model formulae in a nice way). ## variables with less than `n' entries are discarded v.n <- length(dl) ## if (v.n) for (i in 1:v.n) if (length(dl[[i]])=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 ## don't be tempted to change to control=list(...) --- messes up passing on other stuff via ... gam <- function(formula,family=gaussian(),data=list(),weights=NULL,subset=NULL,na.action,offset=NULL, method="GCV.Cp",optimizer=c("outer","newton"),control=list(),#gam.control(), scale=0,select=FALSE,knots=NULL,sp=NULL,min.sp=NULL,H=NULL,gamma=1,fit=TRUE, paraPen=NULL,G=NULL,in.out=NULL,drop.unused.levels=TRUE,drop.intercept=NULL,discrete=FALSE,...) { ## Routine to fit a GAM to some data. The model is stated in the formula, which is then ## interpreted to figure out which bits relate to smooth terms and which to parametric terms. ## Basic steps: ## 1. 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' called to do most of basis construction and other ## elements of model setup. ## 3. 'estimate.gam' is called to estimate the model. This performs further ## pre- and post- fitting steps and calls either 'gam.fit' (performance ## iteration) or 'gam.outer' (default method). 'gam.outer' calls the actual ## smoothing parameter optimizer ('newton' by default) and then any post ## processing. The optimizer calls 'gam.fit3/4/5' to estimate the model ## coefficients and obtain derivatives w.r.t. the smoothing parameters. ## 4. Finished 'gam' object assembled. control <- do.call("gam.control",control) if (is.null(G) && discrete) { ## get bam to do the setup cl <- match.call() ## NOTE: check all arguments more carefully cl[[1]] <- quote(bam) cl$fit = FALSE G <- eval(cl,parent.frame()) ## NOTE: cl probaby needs modifying in G to work properly (with fit=FALSE reset?? also below??) } if (is.null(G)) { ## 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$in.out <- mf$discrete <- 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 <- all.vars1(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 (!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$var.summary <- var.summary G$family <- family 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 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) } else { ## G not null if (!is.null(sp)&&any(sp>=0)) { ## request to modify smoothing parameters if (is.null(G$L)) G$L <- diag(length(G$sp)) if (length(sp)!=ncol(G$L)) stop('length of sp must be number of free smoothing parameters in original model') ind <- sp>=0 ## which smoothing parameters are now fixed spind <- log(sp[ind]); spind[!is.finite(spind)] <- -30 ## set any zero parameters to effective zero G$lsp0 <- G$lsp0 + drop(G$L[,ind,drop=FALSE] %*% spind) ## add fix to lsp0 G$L <- G$L[,!ind,drop=FALSE] ## drop the cols of G G$sp <- rep(-1,ncol(G$L)) } } if (!fit) { class(G) <- "gam.prefit" return(G) } if (ncol(G$X)>nrow(G$X)) stop("Model has more coefficients than data") G$conv.tol <- control$mgcv.tol # tolerence for mgcv G$max.half <- control$mgcv.half # max step halving in Newton update mgcv object <- estimate.gam(G,method,optimizer,control,in.out,scale,gamma,...) if (!is.null(G$L)) { object$full.sp <- as.numeric(exp(G$L%*%log(object$sp)+G$lsp0)) names(object$full.sp) <- names(G$lsp0) } names(object$sp) <- names(G$sp) object$paraPen <- G$pP object$formula <- G$formula ## store any lpi attribute of G$X for use in predict.gam... if (is.list(object$formula)) attr(object$formula,"lpi") <- attr(G$X,"lpi") 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$na.action <- attr(G$mf,"na.action") # how to deal with NA's object$control <- control object$terms <- G$terms object$pred.formula <- G$pred.formula attr(object$pred.formula,"full") <- reformulate(all.vars(object$terms)) object$pterms <- G$pterms object$assign <- G$assign # applies only to pterms object$contrasts <- G$contrasts object$xlevels <- G$xlevels object$offset <- G$offset if (!is.null(G$Xcentre)) object$Xcentre <- G$Xcentre if (control$keepData) object$data <- data object$df.residual <- nrow(G$X) - sum(object$edf) object$min.edf <- G$min.edf if (G$am&&!(method%in%c("REML","ML","P-ML","P-REML"))) object$optimizer <- "magic" else object$optimizer <- optimizer object$call <- G$cl # needed for update() to work class(object) <- c("gam","glm","lm") if (is.null(object$deviance)) object$deviance <- sum(residuals(object,"deviance")^2) names(object$gcv.ubre) <- method environment(object$formula) <- environment(object$pred.formula) <- environment(object$terms) <- environment(object$pterms) <- .GlobalEnv if (!is.null(object$model)) environment(attr(object$model,"terms")) <- .GlobalEnv if (!is.null(attr(object$pred.formula,"full"))) environment(attr(object$pred.formula,"full")) <- .GlobalEnv object } ## gam print.gam<-function (x,...) # default print function for gam objects { 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) n.smooth<-length(x$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") } if (!is.null(x$method)&&!(x$method%in%c("PQL","lme.ML","lme.REML"))) cat("\n",x$method," score: ",x$gcv.ubre," ",sep="") if (!is.null(x$rank) && x$rank< length(x$coefficients)) cat("rank: ",x$rank,"/",length(x$coefficients),sep="") cat("\n") invisible(x) } gam.control <- function (nthreads=1,irls.reg=0.0,epsilon = 1e-7, maxit = 200, mgcv.tol=1e-7,mgcv.half=15,trace =FALSE, rank.tol=.Machine$double.eps^0.5, nlm=list(),optim=list(),newton=list(),outerPIsteps=0, idLinksBases=TRUE,scalePenalty=TRUE,efs.lspmax=15,efs.tol=.1, keepData=FALSE,scale.est="fletcher",edge.correct=FALSE) # Control structure for a gam. # irls.reg is the regularization parameter to use in the GAM fitting IRLS loop. # epsilon is the tolerance to use in the IRLS MLE loop. maxit is the number # of IRLS iterations to use. mgcv.tol is the tolerance to use in the mgcv call within each IRLS. mgcv.half is the # number of step halvings to employ in the mgcv search for the optimal GCV score, before giving up # on a search direction. trace turns on or off some de-bugging information. # rank.tol is the tolerance to use for rank determination # outerPIsteps is the number of performance iteration steps used to intialize # outer iteration { scale.est <- match.arg(scale.est,c("fletcher","pearson","deviance")) if (!is.logical(edge.correct)&&(!is.numeric(edge.correct)||edge.correct<0)) stop( "edge.correct must be logical or a positive number") if (!is.numeric(nthreads) || nthreads <1) stop("nthreads must be a positive integer") if (!is.numeric(irls.reg) || irls.reg <0.0) stop("IRLS regularizing parameter must be a non-negative number.") if (!is.numeric(epsilon) || epsilon <= 0) stop("value of epsilon must be > 0") if (!is.numeric(maxit) || maxit <= 0) stop("maximum number of iterations must be > 0") if (rank.tol<0||rank.tol>1) { rank.tol=.Machine$double.eps^0.5 warning("silly value supplied for rank.tol: reset to square root of machine precision.") } # work through nlm defaults if (is.null(nlm$ndigit)||nlm$ndigit<2) nlm$ndigit <- max(2,ceiling(-log10(epsilon))) 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 <- epsilon*10 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 newton defaults if (is.null(newton$conv.tol)) newton$conv.tol <- 1e-6 if (is.null(newton$maxNstep)) newton$maxNstep <- 5 if (is.null(newton$maxSstep)) newton$maxSstep <- 2 if (is.null(newton$maxHalf)) newton$maxHalf <- 30 if (is.null(newton$use.svd)) newton$use.svd <- FALSE # and optim defaults if (is.null(optim$factr)) optim$factr <- 1e7 optim$factr <- abs(optim$factr) if (efs.tol<=0) efs.tol <- .1 list(nthreads=round(nthreads),irls.reg=irls.reg,epsilon = epsilon, maxit = maxit, trace = trace, mgcv.tol=mgcv.tol,mgcv.half=mgcv.half, rank.tol=rank.tol,nlm=nlm, optim=optim,newton=newton,outerPIsteps=outerPIsteps, idLinksBases=idLinksBases,scalePenalty=scalePenalty,efs.lspmax=efs.lspmax,efs.tol=efs.tol, keepData=as.logical(keepData[1]),scale.est=scale.est,edge.correct=edge.correct) } mgcv.get.scale<-function(Theta,weights,good,mu,mu.eta.val,G) # Get scale implied by current fit and trial -ve binom Theta, I've used # mu and mu.eta.val used in fit rather than implied by it.... { variance<- negbin(Theta)$variance w<-sqrt(weights[good]*mu.eta.val[good]^2/variance(mu)[good]) wres<-w*(G$y-G$X%*%G$p) sum(wres^2)/(G$n-sum(G$edf)) } mgcv.find.theta<-function(Theta,T.max,T.min,weights,good,mu,mu.eta.val,G,tol) # searches for -ve binomial theta between given limits to get scale=1 { scale<-mgcv.get.scale(Theta,weights,good,mu,mu.eta.val,G) T.hi<-T.low<-Theta while (scale<1&&T.hi=1&&T.low>T.min) { T.low<-T.low/2 T.low<-max(T.low,T.min) scale<-mgcv.get.scale(T.low,weights,good,mu,mu.eta.val,G) } if (all.equal(T.low,T.min)==TRUE && scale>1) return(T.low) # (T.low,T.hi) now brackets scale=1. while (abs(scale-1)>tol) { Theta<-(T.low+T.hi)/2 scale<-mgcv.get.scale(Theta,weights,good,mu,mu.eta.val,G) if (scale<1) T.low<-Theta else T.hi<-Theta } Theta } full.score <- function(sp,G,family,control,gamma,...) # function suitable for calling from nlm in order to polish gam fit # so that actual minimum of score is found in generalized cases { if (is.null(G$L)) { G$sp<-exp(sp); } else { G$sp <- as.numeric(exp(G$L%*%sp + G$lsp0)) } # set up single fixed penalty.... q<-NCOL(G$X) if (is.null(G$H)) G$H<-matrix(0,q,q) for (i in 1:length(G$S)) { j<-ncol(G$S[[i]]) off1<-G$off[i];off2<-off1+j-1 G$H[off1:off2,off1:off2]<-G$H[off1:off2,off1:off2]+G$sp[i]*G$S[[i]] } G$S<-list() # have to reset since length of this is used as number of penalties G$L <- NULL xx<-gam.fit(G,family=family,control=control,gamma=gamma,...) res <- xx$gcv.ubre.dev attr(res,"full.gam.object")<-xx res } gam.fit <- function (G, start = NULL, etastart = NULL, mustart = NULL, family = gaussian(), control = gam.control(),gamma=1, fixedSteps=(control$maxit+1),...) # fitting function for a gam, modified from glm.fit. # note that smoothing parameter estimates from one irls iterate are carried over to the next irls iterate # unless the range of s.p.s is large enough that numerical problems might be encountered (want to avoid # completely flat parts of gcv/ubre score). In the latter case autoinitialization is requested. # fixedSteps < its default causes at most fixedSteps iterations to be taken, # without warning if convergence has not been achieved. This is useful for # obtaining starting values for outer iteration. { intercept<-G$intercept conv <- FALSE n <- nobs <- NROW(G$y) ## n just there to keep codetools happy nvars <- NCOL(G$X) # check this needed y<-G$y # original data X<-G$X # original design matrix if (nvars == 0) stop("Model seems to contain no terms") olm <- G$am # only need 1 iteration as it's a pure additive model. if (!olm) .Deprecated(msg="performance iteration with gam is deprecated, use bam instead") find.theta<-FALSE # any supplied -ve binomial theta treated as known, G$sig2 is scale parameter if (substr(family$family[1],1,17)=="Negative Binomial") { Theta <- family$getTheta() if (length(Theta)==1) { ## Theta fixed find.theta <- FALSE G$sig2 <- 1 } else { if (length(Theta)>2) warning("Discrete Theta search not available with performance iteration") Theta <- range(Theta) T.max <- Theta[2] ## upper search limit T.min <- Theta[1] ## lower search limit Theta <- sqrt(T.max*T.min) ## initial value find.theta <- TRUE } nb.link<-family$link # negative.binomial family, there's a choise of links } # obtain average element sizes for the penalties n.S<-length(G$S) if (n.S>0) { S.size<-0 for (i in 1:n.S) S.size[i]<-mean(abs(G$S[[i]])) } weights<-G$w # original weights n.score <- sum(weights!=0) ## n to use in GCV score (i.e. don't count points with no influence) offset<-G$offset variance <- family$variance;dev.resids <- family$dev.resids aic <- family$aic linkinv <- family$linkinv;linkfun <- family$linkfun;mu.eta <- family$mu.eta 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)) # new from version 1.5.0 { eval(family$initialize)} else { mukeep <- mustart eval(family$initialize) mustart <- mukeep } if (NCOL(y) > 1) stop("y must be univariate unless binomial") coefold <- NULL # 1.5.0 eta <- if (!is.null(etastart)) # 1.5.0 etastart else if (!is.null(start)) if (length(start) != nvars) stop(gettextf("Length of start should equal %d and correspond to initial coefs.",nvars)) else { coefold<-start #1.5.0 offset+as.vector(if (NCOL(G$X) == 1) G$X * start else G$X %*% start) } else family$linkfun(mustart) mu <- linkinv(eta) if (!(validmu(mu) && valideta(eta))) stop("Can't find valid starting values: please specify some") devold <- sum(dev.resids(y, mu, weights)) boundary <- FALSE scale <- G$sig2 msp <- G$sp magic.control<-list(tol=G$conv.tol,step.half=G$max.half,#maxit=control$maxit+control$globit, rank.tol=control$rank.tol) for (iter in 1:(control$maxit)) { good <- weights > 0 varmu <- variance(mu)[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) # note good modified here => must re-calc each iter if (all(!good)) { conv <- FALSE warning(gettextf("No observations informative at iteration %d", iter)) break } mevg <- mu.eta.val[good];mug <- mu[good];yg <- y[good] weg <- weights[good];##etag <- eta[good] var.mug<-variance(mug) G$y <- z <- (eta - offset)[good] + (yg - mug)/mevg w <- sqrt((weg * mevg^2)/var.mug) G$w<-w G$X<-X[good,,drop=FALSE] # truncated design matrix # must set G$sig2 to scale parameter or -1 here.... G$sig2 <- scale if (sum(!is.finite(G$y))+sum(!is.finite(G$w))>0) stop("iterative weights or data non-finite in gam.fit - regularization may help. See ?gam.control.") ## solve the working weighted penalized LS problem ... mr <- magic(G$y,G$X,msp,G$S,G$off,L=G$L,lsp0=G$lsp0,G$rank,G$H,matrix(0,0,ncol(G$X)), #G$C, G$w,gamma=gamma,G$sig2,G$sig2<0, ridge.parameter=control$irls.reg,control=magic.control,n.score=n.score,nthreads=control$nthreads) G$p<-mr$b;msp<-mr$sp;G$sig2<-mr$scale;G$gcv.ubre<-mr$score; if (find.theta) {# then family is negative binomial with unknown theta - estimate it here from G$sig2 ## need to get edf array mv <- magic.post.proc(G$X,mr,w=G$w^2) G$edf <- mv$edf Theta<-mgcv.find.theta(Theta,T.max,T.min,weights,good,mu,mu.eta.val,G,.Machine$double.eps^0.5) family<-do.call("negbin",list(theta=Theta,link=nb.link)) variance <- family$variance;dev.resids <- family$dev.resids aic <- family$aic family$Theta <- Theta ## save Theta estimate in family } if (any(!is.finite(G$p))) { conv <- FALSE warning(gettextf("Non-finite coefficients at iteration %d",iter)) break } start <- G$p eta <- drop(X %*% start) # 1.5.0 mu <- linkinv(eta <- eta + offset) eta <- linkfun(mu) # force eta/mu consistency even if linkinv truncates dev <- sum(dev.resids(y, mu, weights)) if (control$trace) message(gettextf("Deviance = %s Iterations - %d", dev, iter, domain = "R-mgcv")) boundary <- FALSE if (!is.finite(dev)) { if (is.null(coefold)) stop("no valid set of coefficients has been found:please supply starting values", call. = FALSE) warning("Step size truncated due to divergence",call.=FALSE) ii <- 1 while (!is.finite(dev)) { if (ii > control$maxit) stop("inner loop 1; can't correct step size") ii <- ii + 1 start <- (start + coefold)/2 eta<-drop(X %*% start) mu <- linkinv(eta <- eta + offset) eta <- linkfun(mu) dev <- sum(dev.resids(y, mu, weights)) } boundary <- TRUE if (control$trace) cat("Step halved: new deviance =", dev, "\n") } if (!(valideta(eta) && validmu(mu))) { warning("Step size truncated: out of bounds.",call.=FALSE) ii <- 1 while (!(valideta(eta) && validmu(mu))) { if (ii > control$maxit) stop("inner loop 2; can't correct step size") ii <- ii + 1 start <- (start + coefold)/2 eta<-drop(X %*% start) mu <- linkinv(eta <- eta + offset) eta<-linkfun(mu) } boundary <- TRUE dev <- sum(dev.resids(y, mu, weights)) if (control$trace) cat("Step halved: new deviance =", dev, "\n") } ## Test for convergence here ... if (abs(dev - devold)/(0.1 + abs(dev)) < control$epsilon || olm || iter >= fixedSteps) { conv <- TRUE coef <- start #1.5.0 break } else { devold <- dev coefold <- coef<-start } } if (!conv) { warning("Algorithm did not converge") } if (boundary) warning("Algorithm stopped at boundary value") eps <- 10 * .Machine$double.eps if (family$family[1] == "binomial") { if (any(mu > 1 - eps) || any(mu < eps)) warning("fitted probabilities numerically 0 or 1 occurred") } if (family$family[1] == "poisson") { if (any(mu < eps)) warning("fitted rates numerically 0 occurred") } residuals <- rep(NA, nobs) residuals[good] <- z - (eta - offset)[good] wt <- rep(0, nobs) wt[good] <- w^2 wtdmu <- if (intercept) sum(weights * y)/sum(weights) else linkinv(offset) nulldev <- sum(dev.resids(y, wtdmu, weights)) n.ok <- nobs - sum(weights == 0) nulldf <- n.ok - as.integer(intercept) ## Extract a little more information from the fit.... mv <- magic.post.proc(G$X,mr,w=G$w^2) G$Vp<-mv$Vb;G$hat<-mv$hat; G$Ve <- mv$Ve # frequentist cov. matrix G$edf<-mv$edf G$conv<-mr$gcv.info G$sp<-msp rank<-G$conv$rank aic.model <- aic(y, n, mu, weights, dev) + 2 * sum(G$edf) if (scale < 0) { ## deviance based GCV gcv.ubre.dev <- n.score*dev/(n.score-gamma*sum(G$edf))^2 } else { # deviance based UBRE, which is just AIC gcv.ubre.dev <- dev/n.score + 2 * gamma * sum(G$edf)/n.score - G$sig2 } list(coefficients = as.vector(coef), residuals = residuals, fitted.values = mu, family = family,linear.predictors = eta, deviance = dev, null.deviance = nulldev, iter = iter, weights = wt, prior.weights = weights, df.null = nulldf, y = y, converged = conv,sig2=G$sig2,edf=G$edf,edf1=mv$edf1,hat=G$hat, ##F=mv$F, R=mr$R, boundary = boundary,sp = G$sp,nsdf=G$nsdf,Ve=G$Ve,Vp=G$Vp,rV=mr$rV,mgcv.conv=G$conv, gcv.ubre=G$gcv.ubre,aic=aic.model,rank=rank,gcv.ubre.dev=gcv.ubre.dev,scale.estimated = (scale < 0)) } ## gam.fit model.matrix.gam <- function(object,...) { if (!inherits(object,"gam")) stop("`object' is not of class \"gam\"") predict(object,type="lpmatrix",...) } 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 predict.gam <- function(object,newdata,type="link",se.fit=FALSE,terms=NULL,exclude=NULL, block.size=NULL,newdata.guaranteed=FALSE,na.action=na.pass, unconditional=FALSE,iterms.type=NULL,...) { # This function is used for predicting from a GAM. 'object' is a gam object, newdata a dataframe to # be used in prediction...... # # Type == "link" - for linear predictor (may be several for extended case) # == "response" - for fitted values: may be several if several linear predictors, # and may return something other than inverse link of l.p. for some families # == "terms" - for individual terms on scale of linear predictor # == "iterms" - exactly as "terms" except that se's include uncertainty about mean # == "lpmatrix" - for matrix mapping parameters to l.p. - has "lpi" attribute if multiple l.p.s # == "newdata" - returns newdata after pre-processing # 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" or "iterms". # if `object' has an attribute `para.only' then only parametric terms of order # 1 are returned for type=="terms"/"iterms" : 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 ## para acts by adding all smooths to the exclude list. ## it also causes any lp matrix to be smaller than it would otherwise have been. #if (para) exclude <- c(exclude,unlist(lapply(object$smooth,function(x) x$label))) if (unconditional) { if (is.null(object$Vc)) warning("Smoothness uncertainty corrected covariance not available") else object$Vp <- object$Vc } if (type!="link"&&type!="terms"&&type!="iterms"&&type!="response"&&type!="lpmatrix"&&type!="newdata") { warning("Unknown type, reset to terms.") type<-"terms" } if (!inherits(object,"gam")) stop("predict.gam can only be used to predict from gam objects") ## 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" #if (is.character(na.action)) #na.txt <- na.action else ## 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) 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 levm <- levels(object$model[,nn[i]]) ## original levels levn <- 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) } ## set prediction levels to fit levels... if (is.matrix(newdata[[i]])) { dum <- factor(newdata[[i]],levels=levm) dim(dum) <- dim(newdata[[i]]) newdata[[i]] <- dum } else newdata[[i]] <- factor(newdata[[i]],levels=levm) } 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... ## in multi-linear predictor models, lpi[[i]][j] is the column of model matrix contributing the jth col to lp i lpi <- if (is.list(object$formula)) attr(object$formula,"lpi") else NULL nlp <- if (is.null(lpi)) 1 else length(lpi) ## number of linear predictors 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" ## get number of linear predictors, in case it's more than 1... #if (is.list(object$formula)) { # nlp <- length(lpi) ## number of linear predictors #} else nlp <- 1 fit <- if (nlp>1) matrix(0,np,nlp) else array(0,np) if (se.fit) se <- fit fit1 <- NULL ## "response" returned by fam$fv can be non-vector } stop <- 0 if (is.list(object$pterms)) { ## multiple linear predictors if (type=="iterms") { warning("type iterms not available for multiple predictor cases") type <- "terms" } pstart <- attr(object$nsdf,"pstart") ## starts of parametric blocks in coef vector pind <- rep(0,0) ## index of parametric coefs Terms <- list();pterms <- object$pterms for (i in 1:length(object$nsdf)) { Terms[[i]] <- delete.response(object$pterms[[i]]) if (object$nsdf[i]>0) pind <- c(pind,pstart[i]-1+1:object$nsdf[i]) } } else { ## normal single predictor case Terms <- list(delete.response(object$pterms)) ## make into a list anyway pterms <- list(object$pterms) pstart <- 1 pind <- 1:object$nsdf ## index of parameteric coefficients } ## check if extended family required intercept to be dropped... #drop.intercept <- FALSE #if (!is.null(object$family$drop.intercept)&&object$family$drop.intercept) { # drop.intercept <- TRUE; # ## make sure intercept explicitly included, so it can be cleanly dropped... # for (i in 1:length(Terms)) attr(Terms[[i]],"intercept") <- 1 #} drop.intercept <- object$family$drop.intercept if (is.null(drop.intercept)) { drop.intercept <- rep(FALSE, length(Terms)) } else { ## make sure intercept explicitly included, so it can be cleanly dropped... for (i in 1:length(Terms)) { if (drop.intercept[i] == TRUE) attr(Terms[[i]],"intercept") <- 1 } } ## index of any parametric terms that have to be dropped ## this is used to help with identifiability in multi- ## formula models... drop.ind <- attr(object$nsdf,"drop.ind") #################################### ## 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+length(drop.ind)) Xoff <- matrix(0,b.size[b],n.smooth) ## term specific offsets offs <- list() for (i in 1:length(Terms)) { ## loop for parametric components (1 per lp) ## 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]] (mode.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 } 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 (drop.intercept[i]) { xat <- attributes(Xp);ind <- xat$assign>0 Xp <- Xp[,xat$assign>0,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(Xp) <- xat } if (object$nsdf[i]>0) X[,pstart[i]-1 + 1:object$nsdf[i]] <- Xp } ## end of parametric loop ## if (length(offs)==1) offs <- offs[[1]] ## messes up later handling if (!is.null(drop.ind)) X <- X[,-drop.ind] 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))) { Xfrag <- PredictMat(object$smooth[[k]],data) 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 } } if (type=="terms"||type=="iterms") ColNames[n.pterms+k] <- klab } ## smooths done if (!is.null(object$Xcentre)) { ## Apply any column centering X <- sweep(X,2,object$Xcentre) } # Now have prediction matrix, X, for this block, need to do something with it... if (type=="lpmatrix") { H[start:stop,] <- X if (any.soff) s.offset <- rbind(s.offset,Xoff) } else if (type=="terms"||type=="iterms") { ## split results into terms lass <- if (is.list(object$assign)) object$assign else list(object$assign) k <- 0 for (j in 1:length(lass)) if (length(lass[[j]])) { ## work through assign list ind <- 1:length(lass[[j]]) ## index vector for coefs involved nptj <- max(lass[[j]]) ## number of terms involved here if (nptj>0) for (i in 1:nptj) { ## work through parametric part k <- k + 1 ## counts total number of parametric terms ii <- ind[lass[[j]]==i] + pstart[j] - 1 fit[start:stop,k] <- X[,ii,drop=FALSE]%*%object$coefficients[ii] if (se.fit) se[start:stop,k] <- sqrt(pmax(0,rowSums((X[,ii,drop=FALSE]%*%object$Vp[ii,ii])*X[,ii,drop=FALSE]))) } } ## assign list done 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 fit[start:stop,n.pterms+k] <- X[,first:last,drop=FALSE] %*% object$coefficients[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 (type=="iterms"&& attr(object$smooth[[k]],"nCons")>0) { ## termwise se to "carry the intercept ## some general families, add parameters after cmX created, which are irrelevant to cmX... if (length(object$cmX) < ncol(X)) object$cmX <- c(object$cmX,rep(0,ncol(X)-length(object$cmX))) if (!is.null(iterms.type)&&iterms.type==2) object$cmX[-(1:object$nsdf)] <- 0 ## variability of fixed effects mean only 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] 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[first:last,first:last,drop=FALSE])*X[,first:last,drop=FALSE]))) } ## end if (se.fit) } colnames(fit) <- ColNames if (se.fit) colnames(se) <- ColNames } else { 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") 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 } } } } else { ## "link" or "response" case fam <- object$family k <- attr(attr(object$model,"terms"),"offset") if (nlp>1) { ## multiple linear predictor case if (is.null(fam$predict)||type=="link") { ##pstart <- c(pstart,ncol(X)+1) ## get index of smooths with an offset... off.ind <- (1:n.smooth)[as.logical(colSums(abs(Xoff)))] for (j in 1:nlp) { ## looping over the model formulae ind <- lpi[[j]] ##pstart[j]:(pstart[j+1]-1) fit[start:stop,j] <- X[,ind,drop=FALSE]%*%object$coefficients[ind] + offs[[j]] if (length(off.ind)) for (i in off.ind) { ## add any term specific offsets if (object$smooth[[i]]$first.para%in%ind) fit[start:stop,j] <- fit[start:stop,j] + Xoff[,i] } if (se.fit) se[start:stop,j] <- sqrt(pmax(0,rowSums((X[,ind,drop=FALSE]%*%object$Vp[ind,ind,drop=FALSE])*X[,ind,drop=FALSE]))) ## model offset only handled for first predictor... fixed ##if (j==1&&!is.null(k)) fit[start:stop,j] <- fit[start:stop,j] + model.offset(mf) if (type=="response") { ## need to transform lp to response scale linfo <- object$family$linfo[[j]] ## link information if (se.fit) se[start:stop,j] <- se[start:stop,j]*abs(linfo$mu.eta(fit[start:stop,j])) fit[start:stop,j] <- linfo$linkinv(fit[start:stop,j]) } } ## end of lp loop } else { ## response case with own predict code #lpi <- list();pst <- c(pstart,ncol(X)+1) #for (i in 1:(length(pst)-1)) lpi[[i]] <- pst[i]:(pst[i+1]-1) attr(X,"lpi") <- lpi ffv <- fam$predict(fam,se.fit,y=response[start:stop],X=X,beta=object$coefficients, off=offs,Vb=object$Vp) if (is.matrix(fit)&&!is.matrix(ffv[[1]])) { fit <- fit[,1]; if (se.fit) se <- se[,1] } if (is.matrix(ffv[[1]])&&(!is.matrix(fit)||ncol(ffv[[1]])!=ncol(fit))) { fit <- matrix(0,np,ncol(ffv[[1]])); if (se.fit) se <- fit } if (is.matrix(fit)) { fit[start:stop,] <- ffv[[1]] if (se.fit) se[start:stop,] <- ffv[[2]] } else { fit[start:stop] <- ffv[[1]] if (se.fit) se[start:stop] <- ffv[[2]] } } ## end of own response prediction code } else { ## single linear predictor offs <- if (is.null(k)) rowSums(Xoff) else rowSums(Xoff) + model.offset(mf) fit[start:stop] <- X%*%object$coefficients + offs if (se.fit) se[start:stop] <- sqrt(pmax(0,rowSums((X%*%object$Vp)*X))) if (type=="response") { # transform linkinv <- fam$linkinv if (is.null(fam$predict)) { 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]) } else { ## family has its own prediction code for response case ffv <- fam$predict(fam,se.fit,y=response[start:stop],X=X,beta=object$coefficients,off=offs,Vb=object$Vp) if (is.null(fit1)&&is.matrix(ffv[[1]])) { fit1 <- matrix(0,np,ncol(ffv[[1]])) if (se.fit) se1 <- fit1 } if (is.null(fit1)) { fit[start:stop] <- ffv[[1]] if (se.fit) se[start:stop] <- ffv[[2]] } else { fit1[start:stop,] <- ffv[[1]] if (se.fit) se1[start:stop,] <- ffv[[2]] } } } } ## single lp done } ## end of link or response case 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") { 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... } #if (!is.null(attr(attr(object$model,"terms"),"offset"))) { # attr(H,"model.offset") <- napredict(na.act,model.offset(mf)) #} if (!is.null(offs)) { offs <- offs[1:nlp] for (i in 1:nlp) offs[[i]] <- napredict(na.act,offs[[i]]) attr(H,"model.offset") <- if (nlp==1) offs[[1]] else offs } H <- napredict(na.act,H) if (length(object$nsdf)>1) { ## add "lpi" attribute if more than one l.p. #lpi <- list();pst <- c(pstart,ncol(H)+1) #for (i in 1:(length(pst)-1)) lpi[[i]] <- pst[i]:(pst[i+1]-1) attr(H,"lpi") <- lpi } } 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 of predict.gam concurvity <- function(b,full=TRUE) { ## b is a gam object ## full==TRUE means that dependence of each term on rest of model ## is considered. ## full==FALSE => pairwise comparison. if (!inherits(b,"gam")) stop("requires an object of class gam") m <- length(b$smooth) if (m<1) stop("nothing to do for this model") X <- model.matrix(b) X <- X[rowSums(is.na(X))==0,] ## this step speeds up remaining computation... X <- qr.R(qr(X,tol=0,LAPACK=FALSE)) stop <- start <- rep(1,m) lab <- rep("",m) for (i in 1:m) { ## loop through smooths start[i] <- b$smooth[[i]]$first.para stop[i] <- b$smooth[[i]]$last.para lab[i] <- b$smooth[[i]]$label } if (min(start)>1) { ## append parametric terms start <- c(1,start) stop <- c(min(start)-1,stop) lab <- c("para",lab) m <- m + 1 } n.measures <- 3 measure.names <- c("worst","observed","estimate") ##n <- nrow(X) if (full) { ## get dependence of each smooth on all the rest... conc <- matrix(0,n.measures,m) for (i in 1:m) { Xi <- X[,-(start[i]:stop[i]),drop=FALSE] Xj <- X[,start[i]:stop[i],drop=FALSE] r <- ncol(Xi) R <- qr.R(qr(cbind(Xi,Xj),LAPACK=FALSE,tol=0))[,-(1:r),drop=FALSE] ## No pivoting!! ##u worst case... Rt <- qr.R(qr(R)) conc[1,i] <- svd(forwardsolve(t(Rt),t(R[1:r,,drop=FALSE])))$d[1]^2 ## observed... beta <- b$coef[start[i]:stop[i]] conc[2,i] <- sum((R[1:r,,drop=FALSE]%*%beta)^2)/sum((Rt%*%beta)^2) ## less pessimistic... conc[3,i] <- sum(R[1:r,]^2)/sum(R^2) } colnames(conc) <- lab rownames(conc) <- measure.names } else { ## pairwise measures conc <- list() for (i in 1:n.measures) conc[[i]] <- matrix(1,m,m) ## concurvity matrix for (i in 1:m) { ## concurvity calculation loop Xi <- X[,start[i]:stop[i],drop=FALSE] r <- ncol(Xi) for (j in 1:m) if (i!=j) { Xj <- X[,start[j]:stop[j],drop=FALSE] R <- qr.R(qr(cbind(Xi,Xj),LAPACK=FALSE,tol=0))[,-(1:r),drop=FALSE] ## No pivoting!! ## worst case... Rt <- qr.R(qr(R)) conc[[1]][i,j] <- svd(forwardsolve(t(Rt),t(R[1:r,,drop=FALSE])))$d[1]^2 ## observed... beta <- b$coef[start[j]:stop[j]] conc[[2]][i,j] <- sum((R[1:r,,drop=FALSE]%*%beta)^2)/sum((Rt%*%beta)^2) ## less pessimistic... conc[[3]][i,j] <- sum(R[1:r,]^2)/sum(R^2) ## Alternative less pessimistic # log.det.R <- sum(log(abs(diag(R[(r+1):nrow(R),,drop=FALSE])))) # log.det.Rt <- sum(log(abs(diag(Rt)))) # conc[[4]][i,j] <- 1 - exp(log.det.R-log.det.Rt) rm(Xj,R,Rt) } } ## end of conc loop for (i in 1:n.measures) rownames(conc[[i]]) <- colnames(conc[[i]]) <- lab names(conc) <- measure.names } ## end of pairwise conc ## } ## end of concurvity residuals.gam <-function(object, type = "deviance",...) ## calculates residuals for gam object { ## if family has its own residual function, then use that... if (!is.null(object$family$residuals)) { res <- object$family$residuals(object,type,...) res <- naresid(object$na.action,res) return(res) } type <- match.arg(type,c("deviance", "pearson","scaled.pearson", "working", "response")) #if (sum(type %in% c("deviance", "pearson","scaled.pearson", "working", "response") )==0) # stop(paste(type," residuals not available")) ## default computations... y <- object$y mu <- object$fitted.values wts <- object$prior.weights if (type == "working") { res <- object$residuals } else if (type == "response") { res <- y - mu } else if (type == "deviance") { res <- object$family$dev.resids(y,mu,wts) s <- attr(res,"sign") if (is.null(s)) s <- sign(y-mu) res <- sqrt(pmax(res,0)) * s } else { ## some sort of Pearson var <- object$family$variance if (is.null(var)) { warning("Pearson residuals not available for this family - returning deviance residuals") return(residuals.gam(object)) } res <- (y-mu)*sqrt(wts)/sqrt(var(mu)) if (type == "scaled.pearson") res <- res/sqrt(object$sig2) } res <- naresid(object$na.action,res) res } ## Start of anova and summary (with contributions from Henric Nilsson) .... 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 (FALSE) { ## 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) xpos <- x > 0 res <- 1 + 0 * x if (sum(xpos)==0 || c2 <= 0) return(res) s1 <- c3/c2^1.5 s2 <- sum(lh*lambda)/c2^2 sigQ <- sqrt(2*c2) t <- (x[xpos]-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 if (c3==0) return(res) l <- c2^3/c3^2 } muX <- l+delta sigX <- sqrt(2)*a res[xpos] <- pchisq(t*sigX+muX,df=l,ncp=delta,lower.tail=lower.tail) res } ## liu2 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 } recov <- 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,"gam")) stop("recov works with fitted gam 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(b$Ve)+b$Ve)*.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= crossprod(L%*%b$R%*%b$Vp)/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 reTest <- function(b,m) { ## Test the mth smooth for equality to zero ## and accounting for all random effects in model ## check that smooth penalty matrices are full size. ## e.g. "fs" type smooths estimated by gamm do not ## have full sized S matrices, and we can't compute ## p=values here.... if (ncol(b$smooth[[m]]$S[[1]]) != b$smooth[[m]]$last.para-b$smooth[[m]]$first.para+1) { return(list(stat=NA,pval=NA,rank=NA)) } ## 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(b,rind,m) Ve <- rc$Ve ind <- b$smooth[[m]]$first.para:b$smooth[[m]]$last.para B <- mroot(Ve[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 testStat <- function(p,X,V,rank=NULL,type=0,res.df= -1) { ## Implements Wood (2013) Biometrika 100(1), 221-228 ## 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. ## 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) ## remove possible ambiguity from statistic... siv <- sign(ed$vectors[1,]);siv[siv==0] <- 1 ed$vectors <- sweep(ed$vectors,2,siv,"*") k <- max(0,floor(rank)) nu <- abs(rank - k) ## fractional part of supplied edf if (type==1) { ## round up is more than .05 above lower if (rank > k + .05||k==0) k <- k + 1 nu <- 0;rank <- k } 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) vec1 <- vec vec1[,k:k1] <- t(rB%*%diag(c(-1,1))%*%t(vec[,k:k1])) vec[,k:k1] <- t(rB%*%t(vec[,k:k1])) } else { vec1 <- vec <- if (k==0) t(t(vec)*sqrt(1/ed$val[1])) else t(t(vec)/sqrt(ed$val[1:k])) if (k==1) rank <- 1 } ## there is an ambiguity in the choise of test statistic, leading to slight ## differences in the p-value computation depending on which of 2 alternatives ## is arbitrarily selected. Following allows both to be computed and p-values ## averaged (can't average test stat as dist then unknown) d <- t(vec)%*%(R%*%p) d <- sum(d^2) d1 <- t(vec1)%*%(R%*%p) d1 <- sum(d1^2) ##d <- d1 ## uncomment to avoid averaging 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) + liu2(d1,val))/2 else ## pval <- davies(d,val)$Qq else pval <- (simf(d,val,res.df) + simf(d1,val,res.df))/2 } 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)+pchisq(d1,df=rank1,lower.tail=FALSE))/2 else pval <- (pf(d/rank1,rank1,res.df,lower.tail=FALSE)+pf(d1/rank1,rank1,res.df,lower.tail=FALSE))/2 } list(stat=d,pval=min(1,pval),rank=rank) } ## end of testStat summary.gam <- function (object, dispersion = NULL, freq = FALSE,re.test = TRUE, ...) { ## summary method for gam object - provides approximate p values ## for terms + other diagnostics ## Improved by Henric Nilsson ## * freq determines whether a frequentist or Bayesian cov matrix is ## used for parametric terms. Usually the default TRUE will result ## in reasonable results with paraPen. ## If a smooth has a field 'random' and it is set to TRUE then ## it is treated as a random effect for some p-value dist calcs pinv<-function(V,M,rank.tol=1e-6) { ## 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 if (is.null(object$R)) { ## Factor from QR decomp of sqrt(W)X warning("p-values for any terms that can be penalized to zero will be unreliable: refit model to fix this.") useR <- FALSE } else useR <- TRUE p.table <- pTerms.table <- s.table <- NULL if (freq) covmat <- object$Ve else covmat <- object$Vp 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 <- object$Ve*dispersion/object$sig2 ## freq object$Vp <- object$Vp*dispersion/object$sig2 ## Bayes est.disp <- FALSE } else dispersion <- object$sig2 ## Now the individual parameteric coefficient p-values... 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 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 ## Bayesian p-values required if (useR) X <- object$R else { 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 (m>0) ii <- 0 for (i in 1:m) { ## loop through smooths start <- object$smooth[[i]]$first.para;stop <- object$smooth[[i]]$last.para V <- object$Vp[start:stop,start:stop,drop=FALSE] ## Bayesian p <- object$coefficients[start:stop] # params for smooth edf1i <- edfi <- sum(object$edf[start:stop]) # edf for this smooth ## extract alternative edf estimate for this smooth, if possible... if (!is.null(object$edf1)) edf1i <- sum(object$edf1[start:stop]) Xt <- X[,start:stop,drop=FALSE] fx <- if (inherits(object$smooth[[i]],"tensor.smooth")&& !is.null(object$smooth[[i]]$fx)) all(object$smooth[[i]]$fx) else object$smooth[[i]]$fixed if (!fx&&object$smooth[[i]]$null.space.dim==0&&!is.null(object$R)) { ## random effect or fully penalized term res <- if (re.test) reTest(object,i) else NULL } else { ## Inverted Nychka interval statistics if (est.disp) rdf <- residual.df else rdf <- -1 res <- testStat(p,Xt,V,min(ncol(Xt),edf1i),type=0,res.df = rdf) } if (!is.null(res)) { ii <- ii + 1 df[ii] <- res$rank chi.sq[ii] <- res$stat s.pv[ii] <- res$pval edf1[ii] <- edf1i edf[ii] <- edfi names(chi.sq)[ii]<- object$smooth[[i]]$label } } if (ii==0) df <- edf1 <- edf <- s.pv <- chi.sq <- array(0, 0) else { df <- df[1:ii];chi.sq <- chi.sq[1:ii];edf1 <- edf1[1:ii] edf <- edf[1:ii];s.pv <- s.pv[1:ii] } if (!est.disp) { 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 { 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 <- if (inherits(object$family,"general.family")||!is.null(object$family$no.r.sq)) NULL else 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 if (object$method%in%c("REML","ML")) object$method <- paste("-",object$method,sep="") 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=r.sq,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, rank=object$rank,np=length(object$coefficients)) class(ret)<-"summary.gam" ret } ## end summary.gam print.summary.gam <- function(x, digits = max(3, getOption("digits") - 3), signif.stars = getOption("show.signif.stars"), ...) # print method for gam summary method. Improved by Henric Nilsson { 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$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="") if (!is.null(x$r.sq)) cat("R-sq.(adj) = ",formatC(x$r.sq,digits=3,width=5)," ") if (length(x$dev.expl)>0) cat("Deviance explained = ",formatC(x$dev.expl*100,digits=3,width=4),"%",sep="") cat("\n") if (!is.null(x$method)&&!(x$method%in%c("PQL","lme.ML","lme.REML"))) cat(x$method," = ",formatC(x$sp.criterion,digits=5),sep="") cat(" Scale est. = ",formatC(x$scale,digits=5,width=8,flag="-")," n = ",x$n,"\n",sep="") invisible(x) } ## print.summary.gam anova.gam <- function (object, ..., dispersion = NULL, test = NULL, freq=FALSE) # improved by Henric Nilsson { # 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) { if (!is.null(test)&&!test%in%c("Chisq","LRT","F")) stop("un-supported test") ## check for multiple formulae to avoid problems... if (is.list(object$formula)) object$formula <- object$formula[[1]] ## reset df.residual to value appropriate for GLRT... n <- if (is.matrix(object$y)) nrow(object$y) else length(object$y) dfc <- if (is.null(object$edf2)) 0 else sum(object$edf2) - sum(object$edf) object$df.residual <- n - sum(object$edf1) - dfc ## reset the deviance to -2*logLik for general families... if (inherits(object$family,"extended.family")) { object$deviance <- -2 * as.numeric(logLik(object)) if (!is.null(test)) test <- "Chisq" } ## repeat above 3 steps for each element of dotargs... for (i in 1:length(dotargs)) { if (is.list(dotargs[[i]]$formula)) dotargs[[i]]$formula <- dotargs[[i]]$formula[[1]] dfc <- if (is.null(dotargs[[i]]$edf2)) 0 else sum(dotargs[[i]]$edf2) - sum(dotargs[[i]]$edf) dotargs[[i]]$df.residual <- n - sum(dotargs[[i]]$edf1) - dfc if (inherits(dotargs[[i]]$family,"extended.family")) { dotargs[[i]]$deviance <- -2 * as.numeric(logLik(dotargs[[i]])) } } return(anova(structure(c(list(object), dotargs), class="glmlist"), dispersion = dispersion, test = test)) } if (!is.null(test)) warning("test argument ignored") if (!inherits(object,"gam")) stop("anova.gam called with non gam object") sg <- summary(object, dispersion = dispersion, freq = freq) class(sg) <- "anova.gam" sg } ## anova.gam print.anova.gam <- function(x, digits = max(3, getOption("digits") - 3), ...) { # print method for class anova.gam resulting from single # gam model calls to anova. Improved by Henric Nilsson. 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.gam ## End of improved anova and summary code. pen.edf <- function(x) { ## obtains the edf associated with each penalty. That is the edf ## of the group of coefficients penalized by each penalty. ## hard to interpret for overlapping penalties. brilliant for t2 ## smooths! if (!inherits(x,"gam")) stop("not a gam object") if (length(x$smooth)==0) return(NULL) k <- 0 ## penalty counter edf <- rep(0,0) edf.name <- rep("",0) for (i in 1:length(x$smooth)) { ## work through smooths if (length(x$smooth[[i]]$S)>0) { pind <- x$smooth[[i]]$first.para:x$smooth[[i]]$last.para ## range of coefs relating to this term Snames <- names(x$smooth[[i]]$S) if (is.null(Snames)) Snames <- as.character(1:length(x$smooth[[i]]$S)) if (length(Snames)==1) Snames <- "" for (j in 1:length(x$smooth[[i]]$S)) { ind <- rowSums(x$smooth[[i]]$S[[j]]!=0)!=0 ## index of penalized coefs (within pind) k <- k+1 edf[k] <- sum(x$edf[pind[ind]]) edf.name[k] <- paste(x$smooth[[i]]$label,Snames[j],sep="") } } } ## finished all penalties names(edf) <- edf.name if (k==0) return(NULL) edf } ## end of pen.edf cooks.distance.gam <- function(model,...) { res <- residuals(model,type="pearson") dispersion <- model$sig2 hat <- model$hat p <- sum(model$edf) (res/(1 - hat))^2 * hat/(dispersion * p) } sp.vcov <- function(x,edge.correct=TRUE,reg=1e-3) { ## get cov matrix of smoothing parameters, if available if (!inherits(x,"gam")) stop("argument is not a gam object") if (x$method%in%c("ML","P-ML","REML","P-REML","fREML")&&!is.null(x$outer.info$hess)) { hess <- x$outer.info$hess p <- ncol(hess) if (edge.correct&&!is.null(attr(hess,"hess1"))) { V <- solve(attr(hess,"hess1")+diag(p)*reg) attr(V,"lsp") <- attr(hess,"lsp1") return(V) } else return(solve(hess+reg)) } else return(NULL) } gam.vcomp <- function(x,rescale=TRUE,conf.lev=.95) { ## Routine to convert smoothing parameters to variance components ## in a fitted `gam' object. if (!inherits(x,"gam")) stop("requires an object of class gam") if (!is.null(x$reml.scale)&&is.finite(x$reml.scale)) scale <- x$reml.scale else scale <- x$sig2 if (length(x$sp)==0) return() if (rescale) { ## undo any rescaling of S[[i]] that may have been done m <- length(x$smooth) if (is.null(x$paraPen)) { k <- 1; if (is.null(x$full.sp)) kf <- -1 else kf <- 1 ## place holder in full sp vector } else { ## don't rescale paraPen related stuff k <- sum(x$paraPen$sp<0)+1 ## count free sp's for paraPen if (is.null(x$full.sp)) kf <- -1 else kf <- length(x$paraPen$full.sp.names)+1 } idx <- rep("",0) ## vector of ids used idxi <- rep(0,0) ## indexes ids in smooth list if (m>0) for (i in 1:m) { ## loop through all smooths if (!is.null(x$smooth[[i]]$id)) { ## smooth has an id if (x$smooth[[i]]$id%in%idx) { ok <- FALSE ## id already dealt with --- ignore smooth } else { idx <- c(idx,x$smooth[[i]]$id) ## add id to id list idxi <- c(idxi,i) ## so smooth[[idxi[k]]] is prototype for idx[k] ok <- TRUE } } else { ok <- TRUE} ## no id so proceed if (ok) { if (length(x$smooth[[i]]$S.scale)!=length(x$smooth[[i]]$S)) warning("S.scale vector doesn't match S list - please report to maintainer") for (j in 1:length(x$smooth[[i]]$S.scale)) { if (x$smooth[[i]]$sp[j]<0) { ## sp not supplied x$sp[k] <- x$sp[k] / x$smooth[[i]]$S.scale[j] k <- k + 1 if (kf>0) { x$full.sp[kf] <- x$full.sp[kf] / x$smooth[[i]]$S.scale[j] kf <- kf + 1 } } else { ## sp supplied x$full.sp[kf] <- x$full.sp[kf] / x$smooth[[i]]$S.scale[j] kf <- kf + 1 } } } else { ## this id already dealt with, but full.sp not scaled yet ii <- idxi[idx%in%x$smooth[[i]]$id] ## smooth prototype for (j in 1:length(x$smooth[[ii]]$S.scale)) { x$full.sp[kf] <- x$full.sp[kf] / x$smooth[[ii]]$S.scale[j] kf <- kf + 1 } } } ## finished rescaling } ## variance components (original scale) vc <- c(scale/x$sp) names(vc) <- names(x$sp) if (is.null(x$full.sp)) vc.full <- NULL else { vc.full <- c(scale/x$full.sp) names(vc.full) <- names(x$full.sp) } ## If a Hessian exists, get CI's for variance components... if (x$method%in%c("ML","P-ML","REML","P-REML","fREML")&&!is.null(x$outer.info$hess)) { if (is.null(x$family$n.theta)||x$family$n.theta<=0) H <- x$outer.info$hess ## the hessian w.r.t. log sps and log scale else { ind <- 1:x$family$n.theta H <- x$outer.info$hess[-ind,-ind,drop=FALSE] } if (ncol(H)>length(x$sp)) scale.est <- TRUE else scale.est <- FALSE ## get derivs of log sqrt var comps wrt log sp and log scale.... J <- matrix(0,nrow(H),ncol(H)) if (scale.est) { diag(J) <- -.5 # -2 J[,ncol(J)] <- .5 # 2 vc <- c(vc,scale);names(vc) <- c(names(x$sp),"scale") } else { diag(J) <- -0.5 #-2 } #H <- t(J)%*%H%*%J ## hessian of log sqrt variances eh <- eigen(H,symmetric=TRUE) ind <- eh$values>max(eh$values)*.Machine$double.eps^75 ## index of non zero eigenvalues rank <- sum(ind) ## rank of hessian iv <- eh$values*0;iv[ind] <- 1/eh$values[ind] V <- eh$vectors%*%(iv*t(eh$vectors)) ## cov matrix for sp's ## log sqrt variances V <- J%*%V%*%t(J) ## cov matrix for log sqrt variance lsd <- log(sqrt(vc)) ## log sqrt variances sd.lsd <- sqrt(diag(V)) if (conf.lev<=0||conf.lev>=1) conf.lev <- 0.95 crit <- qnorm(1-(1-conf.lev)/2) ll <- lsd - crit * sd.lsd ul <- lsd + crit * sd.lsd res <- cbind(exp(lsd),exp(ll),exp(ul)) rownames(res) <- names(vc) colnames(res) <- c("std.dev","lower","upper") cat("\n") cat(paste("Standard deviations and",conf.lev,"confidence intervals:\n\n")) print(res) cat("\nRank: ");cat(rank);cat("/");cat(ncol(H));cat("\n") if (!is.null(vc.full)) { cat("\nAll smooth components:\n") print(sqrt(vc.full)) res <- list(all=sqrt(vc.full),vc=res) } invisible(res) } else { if (is.null(vc.full)) return(sqrt(vc)) else return(list(vc=sqrt(vc),all=sqrt(vc.full))) } } ## end of gam.vcomp vcov.gam <- function(object, freq = FALSE, dispersion = NULL,unconditional=FALSE, ...) ## supplied by Henric Nilsson { if (freq) vc <- object$Ve else { vc <- if (unconditional&&!is.null(object$Vc)) object$Vc else object$Vp } if (!is.null(dispersion)) vc <- dispersion * vc / object$sig2 name <- names(object$edf) dimnames(vc) <- list(name, name) vc } influence.gam <- function(model,...) { model$hat } logLik.gam <- function (object,...) { # based on logLik.glm - is ordering of p correction right??? # if (length(list(...))) # warning("extra arguments discarded") ##fam <- family(object)$family sc.p <- as.numeric(object$scale.estimated) p <- sum(object$edf) + sc.p val <- p - object$aic/2 #if (fam %in% c("gaussian", "Gamma", "inverse.gaussian","Tweedie")) # p <- p + 1 if (!is.null(object$edf2)) p <- sum(object$edf2) + sc.p np <- length(object$coefficients) + sc.p if (p > np) p <- np if (inherits(object$family,"extended.family")&&!is.null(object$family$n.theta)) p <- p + object$family$n.theta attr(val, "df") <- p class(val) <- "logLik" val } ## logLik.gam # From here on is the code for magic..... mroot <- function(A,rank=NULL,method="chol") # finds the smallest square root of A, or the best approximate square root of # given rank. B is returned where BB'=A. A assumed non-negative definite. # Current methods "chol", "svd". "svd" is much slower, but much better at getting the # correct rank if it isn't known in advance. { if (is.null(rank)) rank <- 0 if (!isTRUE(all.equal(A,t(A)))) stop("Supplied matrix not symmetric") if (method=="svd") { um <- La.svd(A) if (sum(um$d!=sort(um$d,decreasing=TRUE))>0) stop("singular values not returned in order") if (rank < 1) # have to work out rank { rank <- dim(A)[1] if (um$d[1]<=0) rank <- 1 else while (rank>0&&(um$d[rank]/um$d[1]<.Machine$double.eps|| all.equal(um$u[,rank],um$vt[rank,])!=TRUE)) rank<-rank-1 if (rank==0) stop("Something wrong - matrix probably not +ve semi definite") } d<-um$d[1:rank]^0.5 return(t(t(um$u[,1:rank])*as.vector(d))) # note recycling rule used for efficiency } else if (method=="chol") { ## don't want to be warned it's not +ve def... L <- suppressWarnings(chol(A,pivot=TRUE,tol=0)) piv <- order(attr(L,"pivot")) ## chol does not work as documented (reported), have to explicitly zero ## the trailing block... r <- attr(L,"rank") p <- ncol(L) if (r < p) L[(r+1):p,(r+1):p] <- 0 if (rank < 1) rank <- r L <- L[,piv,drop=FALSE]; L <- t(L[1:rank,,drop=FALSE]) return(L) } else stop("method not recognised.") } ## mroot magic.post.proc <- function(X,object,w=NULL) # routine to take list returned by magic and extract: # Vb the estimated bayesian parameter covariance matrix. rV%*%t(rV)*scale # Ve the frequentist parameter estimator covariance matrix. # edf the array of estimated degrees of freedom per parameter Vb%*%t(X)%*%W%*%X /scale # hat the leading diagonal of the hat/influence matrix # NOTE: W=diag(w) if w non-matrix, otherwise w is a matrix square root. # flop count is O(nq^2) if X is n by q... this is why routine not part of magic { ## V<-object$rV%*%t(object$rV) V <- tcrossprod(object$rV) if (!is.null(w)) { if (is.matrix(w)) WX <- X <- w%*%X else WX <- as.vector(w)*X # use recycling rule to form diag(w)%*%X cheaply } else {WX <- X} ##if (nthreads <= 1) M <- WX%*%V else M <- pmmult(WX,V,tA=FALSE,tB=FALSE,nt=nthreads) M <- WX%*%V ## O(np^2) part ##Ve <- (V%*%t(X))%*%M*object$scale # frequentist cov. matrix XWX <- crossprod(object$R) #t(X)%*%WX F <- Ve <- V%*%XWX edf1 <- rowSums(t(Ve)*Ve) ## this is diag(FF), where F is edf matrix Ve <- Ve%*%V*object$scale ## frequentist cov matrix B <- X*M rm(M) hat <- rowSums(B) #apply(B,1,sum) # diag(X%*%V%*%t(WX)) edf <- colSums(B) #apply(B,2,sum) # diag(V%*%t(X)%*%WX) Vb <- V*object$scale;rm(V) list(Ve=Ve,Vb=Vb,hat=hat,edf=edf,edf1=2*edf-edf1,F=F) } ## magic.post.proc single.sp <- function(X,S,target=.5,tol=.Machine$double.eps*100) ## function to find smoothing parameter corresponding to particular ## target e.d.f. for a single smoothing parameter problem. ## X is model matrix; S is penalty matrix; target is target ## average e.d.f. per penalized term. { R <- qr.R(qr(X)) ### BUG? pivoting? te <- try(RS <- backsolve(R,S,transpose=TRUE),silent=TRUE) if (inherits(te,"try-error")) return(-1) te <- try(RSR <- backsolve(R,t(RS),transpose=TRUE),silent=TRUE) if (inherits(te,"try-error")) return(-1) RSR <- (RSR+t(RSR))/2 d <- eigen(RSR,symmetric=TRUE)$values d <- d[d>max(d)*tol] ff <- function(lambda,d,target) { mean(1/(1+exp(lambda)*d))-target } lower <- 0 while (ff(lower,d,target) <= 0) lower <- lower - 1 upper <- lower while (ff(upper,d,target) > 0) upper <- upper + 1 exp(uniroot(ff,c(lower,upper),d=d,target=target)$root) } initial.spg <- function(x,y,weights,family,S,rank,off,offset=NULL,L=NULL,lsp0=NULL,type=1, start=NULL,mustart=NULL,etastart=NULL,E=NULL,...) { ## initial smoothing parameter values based on approximate matching ## of Frob norm of XWX and S. If L is non null then it is assumed ## that the sps multiplying S elements are given by L%*%sp+lsp0 and ## an appropriate regression step is used to find `sp' itself. ## This routine evaluates initial guesses at W. ## Get the initial weights... if (length(S)==0) return(rep(0,0)) ## start <- etastart <- mustart <- NULL nobs <- nrow(x) ## ignore codetools warning - required for initialization if (is.null(mustart)) mukeep <- NULL else mukeep <- mustart eval(family$initialize) if (inherits(family,"general.family")) { ## Cox, gamlss etc... lbb <- family$ll(y,x,start,weights,family,offset=offset,deriv=1)$lbb ## initial Hessian ## initially work out the number of times that each coefficient is penalized pcount <- rep(0,ncol(lbb)) for (i in 1:length(S)) { ind <- off[i]:(off[i]+ncol(S[[i]])-1) dlb <- -diag(lbb[ind,ind,drop=FALSE]) indp <- rowSums(abs(S[[i]]))>max(S[[i]])*.Machine$double.eps^.75 & dlb!=0 ind <- ind[indp] ## drop indices of unpenalized pcount[ind] <- pcount[ind] + 1 ## add up times penalized } lambda <- rep(0,length(S)) ## choose lambda so that corresponding elements of lbb and S[[i]] ## are roughly in balance... for (i in 1:length(S)) { ind <- off[i]:(off[i]+ncol(S[[i]])-1) lami <- 1 #dlb <- -diag(lbb[ind,ind]) dlb <- abs(diag(lbb[ind,ind,drop=FALSE])) dS <- diag(S[[i]]) pc <- pcount[ind] ## get index of elements doing any actual penalization... ind <- rowSums(abs(S[[i]]))>max(S[[i]])*.Machine$double.eps^.75 & dlb!=0 ## dlb > 0 ## drop elements that are not penalizing dlb <- dlb[ind]/pc[ind] ## idea is to share out between penalties dS <- dS[ind] rm <- max(length(dS)/rank[i],1) ## rough correction for rank deficiency in penalty #while (mean(dlb/(dlb + lami * dS * rm)) > 0.4) lami <- lami*5 #while (mean(dlb/(dlb + lami * dS * rm )) < 0.4) lami <- lami/5 while (sqrt(mean(dlb/(dlb + lami * dS * rm))*mean(dlb)/mean(dlb+lami*dS*rm)) > 0.4) lami <- lami*5 while (sqrt(mean(dlb/(dlb + lami * dS * rm))*mean(dlb)/mean(dlb+lami*dS*rm)) < 0.4) lami <- lami/5 lambda[i] <- lami ## norm(lbb[ind,ind])/norm(S[[i]]) } } else { ## some sort of conventional regression if (is.null(mukeep)) { if (!is.null(start)) etastart <- drop(x%*%start) if (!is.null(etastart)) mustart <- family$linkinv(etastart) } else mustart <- mukeep if (inherits(family,"extended.family")) { theta <- family$getTheta() ## use 'as.numeric' - 'drop' can leave result as 1D array... Ddo <- family$Dd(y,mustart,theta,weights) mu.eta2 <-family$mu.eta(family$linkfun(mustart))^2 w <- .5 * as.numeric(Ddo$Dmu2 * mu.eta2) if (any(w<0)) w <- .5 * as.numeric(Ddo$EDmu2 * mu.eta2) #w <- .5 * as.numeric(family$Dd(y,mustart,theta,weights)$EDmu2*family$mu.eta(family$linkfun(mustart))^2) } else w <- as.numeric(weights*family$mu.eta(family$linkfun(mustart))^2/family$variance(mustart)) w <- sqrt(w) if (type==1) { ## what PI would have used lambda <- initial.sp(w*x,S,off) } else { ## balance frobenius norms csX <- colSums((w*x)^2) lambda <- rep(0,length(S)) for (i in 1:length(S)) { ind <- off[i]:(off[i]+ncol(S[[i]])-1) lambda[i] <- sum(csX[ind])/sqrt(sum(S[[i]]^2)) } } } if (!is.null(L)) { lsp <- log(lambda) if (is.null(lsp0)) lsp0 <- rep(0,nrow(L)) lsp <- as.numeric(coef(lm(lsp~L-1+offset(lsp0)))) lambda <- exp(lsp) } lambda ## initial values } initial.sp <- function(X,S,off,expensive=FALSE,XX=FALSE) # Find initial smoothing parameter guesstimates based on model matrix X # and penalty list S. off[i] is the index of the first parameter to # which S[[i]] applies, since S[[i]]'s only store non-zero submatrix of # penalty coefficient matrix. # if XX==TRUE then X contains X'X, not X! { n.p <- length(S) if (XX) expensive <- FALSE def.sp <- array(0,n.p) if (n.p) { ldxx <- if (XX) diag(X) else colSums(X*X) # yields diag(t(X)%*%X) ldss <- ldxx*0 # storage for combined penalty l.d. if (expensive) St <- matrix(0,ncol(X),ncol(X)) pen <- rep(FALSE,length(ldxx)) # index of what actually gets penalized for (i in 1:n.p) { # loop over penalties maS <- max(abs(S[[i]])) rsS <- rowMeans(abs(S[[i]])) csS <- colMeans(abs(S[[i]])) dS <- diag(abs(S[[i]])) ## new 1.8-4 thresh <- .Machine$double.eps^.8 * maS ## .Machine$double.eps*maS*10 ind <- rsS > thresh & csS > thresh & dS > thresh # only these columns really penalize ss <- diag(S[[i]])[ind] # non-zero elements of l.d. S[[i]] start <- off[i];finish <- start+ncol(S[[i]])-1 xx <- ldxx[start:finish] xx <- xx[ind] pen[start:finish] <- pen[start:finish]|ind sizeXX <- mean(xx) sizeS <- mean(ss) if (sizeS <= 0) stop(gettextf("S[[%d]] matrix is not +ve definite.", i)) def.sp[i] <- sizeXX/ sizeS # relative s.p. estimate ## accumulate leading diagonal of \sum sp[i]*S[[i]] ldss[start:finish] <- ldss[start:finish] + def.sp[i]*diag(S[[i]]) if (expensive) St[start:finish,start:finish] <- St[start:finish,start:finish] + def.sp[i]*S[[i]] } if (expensive) { ## does full search for overall s.p. msp <- single.sp(X,St) if (msp>0) def.sp <- def.sp*msp } else { ind <- ldss > 0 & pen & ldxx > 0 # base following only on penalized terms ldxx<-ldxx[ind];ldss<-ldss[ind] while (mean(ldxx/(ldxx+ldss))>.4) { def.sp <- def.sp*10;ldss <- ldss*10 } while (mean(ldxx/(ldxx+ldss))<.4) { def.sp <- def.sp/10;ldss <- ldss/10 } } } as.numeric(def.sp) } ## initial.sp magic <- function(y,X,sp,S,off,L=NULL,lsp0=NULL,rank=NULL,H=NULL,C=NULL,w=NULL,gamma=1,scale=1,gcv=TRUE, ridge.parameter=NULL,control=list(tol=1e-6,step.half=25, rank.tol=.Machine$double.eps^0.5),extra.rss=0,n.score=length(y),nthreads=1) # Wrapper for C routine magic. Deals with constraints weights and square roots of # penalties. # y is data vector, X is model matrix, sp is array of smoothing parameters, # S is list of penalty matrices stored as smallest square submatrix excluding no # non-zero entries, off[i] is the location on the leading diagonal of the # total penalty matrix of element (1,1) of S[[i]], rank is an array of penalty # ranks, L is a matrix mapping the log underlying smoothing parameters to the # smoothing parameters that actually multiply the penalties. i.e. the # log smoothing parameters are L%*%sp + lsp0 # H is any fixed penalty, C is a linear constraint matrix and w is the # weight vector. gamma is the dof inflation factor, scale is the scale parameter, only # used with UBRE, gcv TRUE means use GCV, if false, use UBRE. # Return list includes rV such that cov(b)=rV%*%t(rV)*scale and the leading diagonal # of rV%*%t(rV)%*%t(X)%*%X gives the edf for each parameter. # NOTE: W is assumed to be square root of inverse of covariance matrix. i.e. if # W=diag(w) RSS is ||W(y-Xb||^2 # If `ridge.parameter' is a positive number then then it is assumed to be the multiplier # for a ridge penalty to be applied during fitting. # `extra.rss' is an additive constant by which the RSS is modified in the # GCV/UBRE or scale calculations, n.score is the `n' to use in the GCV/UBRE # score calcualtions (Useful for dealing with huge datasets). { if (is.null(control)) control <- list() if (is.null(control$tol)) control$tol <- 1e-6 if (is.null(control$step.half)) control$step.half <- 25 if (is.null(control$rank.tol)) control$rank.tol <- .Machine$double.eps^0.5 n.p<-length(S) n.b<-dim(X)[2] # number of parameters # get initial estimates of smoothing parameters, using better method than is # built in to C code. This must be done before application of general # constraints. if (n.p) def.sp <- initial.sp(X,S,off) else def.sp <- sp if (!is.null(L)) { ## have to estimate appropriate starting coefs if (!inherits(L,"matrix")) stop("L must be a matrix.") if (nrow(L)0) { for (i in 1:n.p) { if (is.null(rank)) B <- mroot(S[[i]],method="svd") else B <- mroot(S[[i]],rank=rank[i],method="chol") m <- dim(B)[2] R<-matrix(0,n.b,m) R[off[i]:(off[i]+dim(B)[1]-1),]<-B S[[i]]<-R } rm(B);rm(R) } # if there are constraints then need to form null space of constraints Z # (from final columns of Q, from QR=C'). Then form XZ and Z'S_i^0.5 for all i # and Z'HZ. # On return from mgcv2 set parameters to Zb (apply Q to [0,b']'). ##Xo<-X if (!is.null(C)) # then impose constraints { n.con<-dim(C)[1] ns.qr<-qr(t(C)) # last n.b-n.con columns of Q are the null space of C X<-t(qr.qty(ns.qr,t(X)))[,(n.con+1):n.b,drop=FALSE] # last n.b-n.con cols of XQ (=(Q'X')') # need to work through penalties forming Z'S_i^0.5 's if (n.p>0) for (i in 1:n.p) { S[[i]]<-qr.qty(ns.qr,S[[i]])[(n.con+1):n.b,,drop=FALSE] ## following essential given assumptions of the C code... if (ncol(S[[i]])>nrow(S[[i]])) { ## no longer have a min col square root. S[[i]] <- t(qr.R(qr(t(S[[i]])))) ## better! } } # and Z'HZ too if (!is.null(H)) { H<-qr.qty(ns.qr,H)[(n.con+1):n.b,,drop=FALSE] # Z'H H<-t(qr.qty(ns.qr,t(H))[(n.con+1):n.b,,drop=FALSE]) # Z'HZ = (Z'[Z'H]')' } full.rank=n.b-n.con } else full.rank=n.b # now deal with weights.... if (!is.null(w)) { if (is.matrix(w)) { if (dim(w)[1]!=dim(w)[2]||dim(w)[2]!=dim(X)[1]) stop("dimensions of supplied w wrong.") y<-w%*%y X<-w%*%X } else { if (length(y)!=length(w)) stop("w different length from y!") y<-y*w X<-as.vector(w)*X # use recycling rule to form diag(w)%*%X cheaply } } if (is.null(dim(X))) { # lost dimensions as result of being single columned! n <- length(y) if (n!=length(X)) stop("X lost dimensions in magic!!") dim(X) <- c(n,1) } # call real mgcv engine... Si<-array(0,0);cS<-0 if (n.p>0) for (i in 1:n.p) { Si <- c(Si,S[[i]]); cS[i] <- dim(S[[i]])[2] } rdef <- ncol(X) - nrow(X) if (rdef>0) { ## need to zero pad model matrix n.score <- n.score ## force evaluation *before* y lengthened X <- rbind(X,matrix(0,rdef,ncol(X))) y <- c(y,rep(0,rdef)) } icontrol<-as.integer(gcv);icontrol[2]<-length(y);q<-icontrol[3]<-dim(X)[2]; if (!is.null(ridge.parameter)&&ridge.parameter>0) { if(is.null(H)) H<-diag(ridge.parameter,q) else H<-H+diag(ridge.parameter,q)} icontrol[4]<-as.integer(!is.null(H));icontrol[5]<- n.p;icontrol[6]<-control$step.half if (is.null(L)) { icontrol[7] <- -1;L <- diag(n.p) } else icontrol[7]<-ncol(L) if (is.null(lsp0)) lsp0 <- rep(0,nrow(L)) b<-array(0,icontrol[3]) # argument names in call refer to returned values. if (nthreads<1) nthreads <- 1 ## can't set up storage without knowing nthreads if (nthreads>1) extra.x <- q^2 * nthreads else extra.x <- 0 um<-.C(C_magic,as.double(y),X=as.double(c(X,rep(0,extra.x))),sp=as.double(sp),as.double(def.sp), as.double(Si),as.double(H),as.double(L), lsp0=as.double(lsp0),score=as.double(gamma),scale=as.double(scale),info=as.integer(icontrol),as.integer(cS), as.double(control$rank.tol),rms.grad=as.double(control$tol),b=as.double(b),rV=double(q*q), as.double(extra.rss),as.integer(n.score),as.integer(nthreads)) res<-list(b=um$b,scale=um$scale,score=um$score,sp=um$sp,sp.full=as.numeric(exp(L%*%log(um$sp)))) res$R <- matrix(um$X[1:q^2],q,q) res$rV<-matrix(um$rV[1:(um$info[1]*q)],q,um$info[1]) gcv.info<-list(full.rank=full.rank,rank=um$info[1],fully.converged=as.logical(um$info[2]), hess.pos.def=as.logical(um$info[3]),iter=um$info[4],score.calls=um$info[5],rms.grad=um$rms.grad) res$gcv.info<-gcv.info if (!is.null(C)) { # need image of constrained parameter vector in full space b <- c(rep(0,n.con),res$b) res$b <- qr.qy(ns.qr,b) # Zb b <- matrix(0,n.b,dim(res$rV)[2]) b[(n.con+1):n.b,] <- res$rV res$rV <- qr.qy(ns.qr,b)# ZrV } res } ## magic print.mgcv.version <- function() { library(help=mgcv)$info[[1]] -> version version <- version[pmatch("Version",version)] um <- strsplit(version," ")[[1]] version <- um[nchar(um)>0][2] hello <- paste("This is mgcv ",version,". For overview type 'help(\"mgcv-package\")'.",sep="") packageStartupMessage(hello) } set.mgcv.options <- function() ## function used to set optional value used in notLog ## and notExp... { ##runif(1) ## ensure there is a seed (can be removed by user!) options(mgcv.vc.logrange=25) } .onLoad <- function(...) { set.mgcv.options() } .onAttach <- function(...) { print.mgcv.version() set.mgcv.options() } .onUnload <- function(libpath) library.dynam.unload("mgcv", libpath) ############################################################################### ### ISSUES..... # #* Could use R_CheckUserInterrupt() to allow user interupt of # mgcv code. (6.12) But then what about memory?# # #* predict.gam and plot.gam "iterms" and `seWithMean' options # don't deal properly with case in which centering constraints # are not conventional sum to zero ones. # # * add randomized residuals (see Mark B email)? # # * sort out all the different scale parameters floating around, and explain the # sp variance link better. mgcv/R/mvam.r0000644000176200001440000002475013445102233012537 0ustar liggesusers## (c) Simon N. Wood (2013-2015) mvn model extended family. ## Released under GPL2 ... lpi.expand <- function(X,trailing=TRUE) { ## takes a model matrix X, with "lpi" attribute, and produces ## full redundant version in which each column block is the full ## model matrix for one linear predictor, which may involve ## repeating columns between blocks. ## See mvn family (ll) for prototypic application lpi <- attr(X,"lpi") if (!attr(lpi,"overlap")) return(X) ## nothing to do ip <- unlist(lpi) if (trailing&&max(ip)lip) nt <- nrow(x)-lip else if (ncol(x)>lip) nt <- ncol(x) - lip } else if (length(x)>lip) nt <- length(x) - lip if (nt>0) { ## there is a trailing block - index it in lpi lpi[[length(lpi)+1]] <- 1:nt + max(ip) ip <- unlist(lpi) } } p <- max(ip) ## dimension of result if (is.matrix(x)) { if (type=="c"||type=="rc") { ## column contraction k <- 0 z <- matrix(0,nrow(x),p) for (i in 1:length(lpi)) { ii <- 1:length(lpi[[i]]) + k k <- k + length(ii) z[,lpi[[i]]] <- z[,lpi[[i]]] + x[,ii] } if (type=="rc") x <- z } if (type=="r"||type=="rc") { ## row contraction z <- matrix(0,p,ncol(x)) k <- 0 for (i in 1:length(lpi)) { ii <- 1:length(lpi[[i]]) + k k <- k + length(ii) z[lpi[[i]],] <- z[lpi[[i]],] + x[ii,] } } } else { ## vector z <- rep(0,p);k <- 0 for (i in 1:length(lpi)) { ii <- 1:length(lpi[[i]]) + k k <- k + length(ii) z[lpi[[i]]] <- z[lpi[[i]]] + x[ii] } } z } ## lpi.contract mvn <- function(d=2) { ## Extended family object for multivariate normal additive model. if (d<2) stop("mvn requires 2 or more dimensional data") stats <- list() for (i in 1:d) { stats[[i]] <- make.link("identity") } ##env <- new.env(parent = .GlobalEnv) validmu <- function(mu) all(is.finite(mu)) ## initialization has to add in the extra parameters of ## the cov matrix... preinitialize <- function(G) { ## G is a gam pre-fit object. Pre-initialize can manipulate some of its ## elements, returning a named list of the modified ones. ## extends model matrix with dummy columns and ## finds initial coefficients ydim <- ncol(G$y) ## dimension of response nbeta <- ncol(G$X) ntheta <- ydim*(ydim+1)/2 ## number of cov matrix factor params lpi <- attr(G$X,"lpi") #offs <- attr(G$X,"offset") XX <- crossprod(G$X) G$X <- cbind(G$X,matrix(0,nrow(G$X),ntheta)) ## add dummy columns to G$X #G$cmX <- c(G$cmX,rep(0,ntheta)) ## and corresponding column means G$term.names <- c(G$term.names,paste("R",1:ntheta,sep=".")) attr(G$X,"lpi") <- lpi #offs -> attr(G$X,"offset") attr(G$X,"XX") <- XX ## pad out sqrt of balanced penalty matrix to account for extra params if (!is.null(G$Sl)) attr(G$Sl,"E") <- cbind(attr(G$Sl,"E"),matrix(0,nbeta,ntheta)) G$family$data <- list(ydim = ydim,nbeta=nbeta) G$family$ibeta = rep(0,ncol(G$X)) ## now get initial parameters and store in family... for (k in 1:ydim) { sin <- G$off %in% lpi[[k]] #Sk <- G$S[sin] um <- magic(G$y[,k],G$X[,lpi[[k]]],rep(-1,sum(sin)),G$S[sin], match(G$off[sin],lpi[[k]])) # , ## turn G$off global indices into indices for this predictor #nt=control$nthreads) G$family$ibeta[lpi[[k]]] <- um$b G$family$ibeta[nbeta+1] <- -.5*log(um$scale) ## initial log root precision nbeta <- nbeta + ydim - k + 1 } list(X=G$X,term.names=G$term.names,family=G$family) } ## preinitialize postproc <- expression({ ## code to evaluate in estimate.gam, to do with estimated factor of ## precision matrix, etc... ydim <- G$family$data$ydim R <- matrix(0,ydim,ydim) ind <- G$family$data$nbeta + 1:(ydim*(ydim+1)/2); theta <- object$coefficients[ind] k <- 1;for (i in 1:ydim) for (j in i:ydim) { if (i==j) R[i,j] <- exp(theta[k]) else R[i,j] <- theta[k] k <- k + 1 } object$family$data <- list(R=R) rsd <- R%*%t(object$y-object$fitted.values) object$deviance <- sum(rsd^2) rsd <- R%*%(t(object$y)-colMeans(object$y)) object$null.deviance <- sum(rsd^2) }) initialize <- expression({ ## called in gam.fit5 and initial.spg n <- rep(1, nobs) if (is.null(start)) start <- family$ibeta ## need to re-parameterize XX is non-standard if (exists("rp",inherits=FALSE)&&length(rp$rp)>0) attr(x,"XX") <- Sl.repara(rp$rp,t(Sl.repara(rp$rp,attr(x,"XX")))) }) residuals <- function(object,type=c("response","deviance")) { type <- match.arg(type) res <- object$y - object$fitted.values if (type=="deviance") res <- res%*%t(object$family$data$R) res } ## residuals ll <- function(y,X,coef,wt,family,offset=NULL,deriv=0,d1b=NULL,d2b=NULL,Hp=NULL,rank=0,fh=NULL,D=NULL) { ## function defining the Multivariate Normal model log lik. ## Calls C code "mvn_ll" ## deriv codes: 0 - evaluate the log likelihood ## 1 - evaluate the grad and Hessian, H, of log lik w.r.t. coefs (beta) ## 2 - evaluate tr(Hp^{-1}dH/drho), given Hp^{-1} in fh and db/drho in d1b. Could be made more efficient. ## 3 - evaluate d1H =dH/drho given db/drho in d1b ## 4 - given d1b and d2b evaluate trHid2H= tr(Hp^{-1}d2H/drhodrho') (not implemented) ## Hp is the preconditioned penalized hessian of the log lik ## which is of rank 'rank'. ## fh is a factorization of Hp - either its eigen decomposition ## or its Choleski factor ## D is the diagonal pre-conditioning matrix used to obtain Hp ## if Hr is the raw Hp then Hp = D*t(D*Hr) if (!is.null(offset)) { for (i in 1:length(offset)) if (sum(offset[[i]]!=0)) stop("mvn does not yet handle offsets") } lpi <- attr(X,"lpi") ## lpi[[k]] is index of model matrix columns for dim k overlap <- attr(lpi,"overlap") ## do dimensions share terms? drop <- attr(X,"drop") if (!is.null(drop)) { ## the optimizer has dropped some parameters ## it will have adjusted lpi automatically, but XX is mvn specific attr(X,"XX") <- attr(X,"XX")[-drop,-drop] } m <- length(lpi) ## number of dimensions of MVN if (overlap) { ## linear predictors share terms - expand to redundant representation ip <- unlist(lpi) XX <- attr(X,"XX")[ip,ip] X <- lpi.expand(X) attr(X,"XX") <- XX;rm(XX) lpi0 <- lpi ## need to save this for contraction of results lpi <- attr(X,"lpi") ## this indexes the cols of each l.p in the expanded X ## need to expand coef beta, leaving m*(m+1)/2 final coefs of R at end ind <- (max(ip)+1):length(coef) if (length(ind)!=m*(m+1)/2) stop("mvn dimension error") coef <- c(coef[ip],coef[ind]) ## do same for derivatives of coef wrt log smoothing params... if (!is.null(d1b)) d1b <- rbind(d1b[ip,],d1b[ind,]) } else ind <- NULL lpstart <- rep(0,m) for (i in 1:(m-1)) lpstart[i] <- lpi[[i+1]][1] lpstart[m] <- lpi[[m]][length(lpi[[m]])]+1 nb <- length(coef) ## total number of parameters if (deriv<2) { nsp = 0;d1b <- dH <- 0 } else { nsp = ncol(d1b) dH = rep(0,nsp*nb*nb) } #cat("\nderiv=",deriv," lpstart=",lpstart," dim(y) = ",dim(y), # "\ndim(XX)=",dim(attr(X,"XX"))," m=",m," nsp=",nsp,"\n") oo <- .C("mvn_ll",y=as.double(t(y)),X=as.double(X),XX=as.double(attr(X,"XX")), beta=as.double(coef),n=as.integer(nrow(X)), lpi=as.integer(lpstart-1),m=as.integer(m),ll=as.double(0),lb=as.double(coef*0), lbb=as.double(rep(0,nb*nb)), dbeta = as.double(d1b), dH = as.double(dH), deriv = as.integer(nsp>0),nsp = as.integer(nsp),nt=as.integer(1),PACKAGE="mgcv") lb <- oo$lb;lbb <- matrix(oo$lbb,nb,nb) if (overlap) { ## need to apply lpi contraction lb <- lpi.contract(lb,lpi0) ## lpi.contract will automatically carry across the R coef related stuff lbb <- lpi.contract(lbb,lpi0) } if (nsp==0) d1H <- NULL else if (deriv==2) { d1H <- rep(0,nsp) #matrix(0,nb,nsp) for (i in 1:nsp) { dH <- matrix(oo$dH[ind],nb,nb) if (overlap) dH <- lpi.contract(dH,lpi0) # d1H[,i] <- diag(dH) d1H[i] <- sum(fh*dH) ind <- ind + nb*nb } } else { ## deriv==3 d1H <- list();ind <- 1:(nb*nb) for (i in 1:nsp) { dH <- matrix(oo$dH[ind],nb,nb) if (overlap) dH <- lpi.contract(dH,lpi0) d1H[[i]] <- dH ind <- ind + nb*nb } } list(l=oo$ll,lb=lb,lbb=lbb,d1H=d1H) } ## ll # environment(dev.resids) <- environment(aic) <- environment(getTheta) <- # environment(rd)<- environment(qf)<- environment(variance) <- environment(putTheta) ##environment(aic) <- ##environment(ll) <- env structure(list(family = "Multivariate normal", ## link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, ll=ll,nlp=d, initialize = initialize,preinitialize=preinitialize,postproc=postproc, residuals=residuals, validmu = validmu, ## valideta = stats$valideta, ## rd=rd,qf=qf, linfo = stats, ## link information list d2link=1,d3link=1,d4link=1, ## signals to fix.family.link that all done ls=1, ## signal ls not needed available.derivs = 1 ## signal only first derivatives available... ), class = c("general.family","extended.family","family")) } ## mvn mgcv/R/gam.sim.r0000755000176200001440000000727613073161530013143 0ustar liggesusers ## Example simulated data for gam.models (c) Simon N. Wood 2008 gamSim <- function(eg=1,n=400,dist="normal",scale=2,verbose=TRUE) { if (eg==1||eg==7) { ## 4 term Gu and Wahba example if (eg==1) { if (verbose) cat("Gu & Wahba 4 term additive model\n") } else { if (verbose) cat("Gu & Wahba 4 term additive model, correlated predictors\n")} x0 <- runif(n, 0, 1) if (eg==7) x1 <- x0*.7 + runif(n, 0, .3) else x1 <- runif(n,0,1) x2 <- runif(n, 0, 1) if (eg==7) x3 <- x2*.9 + runif(n,0,.1) else x3 <- runif(n, 0, 1) f0 <- function(x) 2 * sin(pi * x) f1 <- function(x) exp(2 * x) f2 <- function(x) 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 f3 <- function(x) 0*x f <- f0(x0) + f1(x1) + f2(x2) if (dist=="normal") { e <- rnorm(n, 0, scale) y <- f + e } else if (dist=="poisson") { g<-exp(f*scale) f <- log(g) ## true linear predictor y<-rpois(rep(1,n),g) } else if (dist=="binary") { f <- (f-5)*scale g <- binomial()$linkinv(f) y <- rbinom(g,1,g) } else stop("dist not recognised") data <- data.frame(y=y,x0=x0,x1=x1,x2=x2,x3=x3,f=f,f0=f0(x0),f1=f1(x1),f2=f2(x2),f3=x3*0) return(data) } else if (eg==2) { ## Simple 2D smoothing example if (verbose) cat("Bivariate smoothing example\n") test1<-function(x,z,sx=0.3,sz=0.4) { (pi**sx*sz)*(1.2*exp(-(x-0.2)^2/sx^2-(z-0.3)^2/sz^2)+ 0.8*exp(-(x-0.7)^2/sx^2-(z-0.8)^2/sz^2)) } x <- runif(n);z <- runif(n); xs<-seq(0,1,length=40);zs<-seq(0,1,length=40) pr <- data.frame(x=rep(xs,40),z=rep(zs,rep(40,40))) truth <- matrix(test1(pr$x,pr$z),40,40) f <- test1(x,z) y <- f + rnorm(n)*scale data <- data.frame(y=y,x=x,z=z,f=f) truth <- list(x=xs,z=zs,f=truth) return(list(data=data,truth=truth,pr=pr)) } else if (eg==3) { ## continuous `by' variable if (verbose) cat("Continuous `by' variable example\n") x1 <- runif(n, 0, 1) x2 <- sort(runif(n, 0, 1)) f <- 0.2 * x2^11 * (10 * (1 - x2))^6 + 10 * (10 * x2)^3 * (1 - x2)^10 e <- rnorm(n, 0, scale) # A continuous `by' variable example.... y <- f*x1 + e return(data.frame(y=y,x1=x1,x2=x2,f=f)) } else if (eg==4) { ## factor `by' variable if (verbose) cat("Factor `by' variable example\n") x0 <- runif(n, 0, 1) x1 <- runif(n, 0, 1) x2 <- runif(n, 0, 1) f1 <- 2 * sin(pi * x2) f2 <- exp(2 * x2) - 3.75887 f3 <- 0.2 * x2^11 * (10 * (1 - x2))^6 + 10 * (10 * x2)^3 * (1 - x2)^10 e <- rnorm(n, 0, scale) fac<-as.factor(sample(1:3,n,replace=TRUE)) fac.1<-as.numeric(fac==1);fac.2<-as.numeric(fac==2); fac.3<-as.numeric(fac==3) y<-f1*fac.1+f2*fac.2+f3*fac.3+ e return(data.frame(y=y,x0=x0,x1=x1,x2=x2,fac=fac,f1=f1,f2=f2,f3=f3)) } else if (eg==5) { ## additive + factor if (verbose) cat("Additive model + factor\n") x0 <- rep(1:4,50) x1 <- runif(n, 0, 1) x2 <- runif(n, 0, 1) x3 <- runif(n, 0, 1) y <- 2 * x0 y <- y + exp(2 * x1) y <- y + 0.2 * x2^11 * (10 * (1 - x2))^6 + 10 * (10 * x2)^3 * (1 - x2)^10 e <- rnorm(n, 0, scale) y <- y + e x0<-as.factor(x0) return(data.frame(y=y,x0=x0,x1=x1,x2=x2,x3=x3)) } else if (eg==6) { ## Gu and Wahba + a random factor if (verbose) cat("4 term additive + random effect") dat <- gamSim(1,n=n,scale=0) fac <- rep(1:4,n/4) dat$f <- dat$f + fac*3 dat$fac<-as.factor(fac) if (dist=="normal") { dat$y <- dat$f + rnorm(n)*scale } else if (dist=="poisson") { g <- exp(dat$f*scale) dat$y <- rpois(rep(1,n),g) } else if (dist=="binary") { g <- (dat$f-5)*scale g <- binomial()$linkinv(g) dat$y <- rbinom(g,1,g) } return(dat) } } mgcv/R/inla.r0000644000176200001440000004132313422412762012523 0ustar liggesusers## (c) Simon Wood 2018. Released under GPL2. ## Implements the version of INLA (Rue et al. 2009, JRSSB) described in ## Wood "Simplified Integrated Nested Laplace Approximation" (submitted, 2018) FFdes <- function (size=5,ccd=FALSE) { ## creates level 5 fractional factorial designs, up to size=120 ## according to Sanchez and Sanchez (2005) ## ACM Transactions on Modeling and Computer Simulation 15(4), 362-377 ## If ccd==TRUE, appends this to make the outer points of a ## Central Composite design (origin is added for full design). fwt <- function(x) { ## fast Walsh transform lag <- 1 while (lag < length(x)) { offset <- lag * 2 ngroups <- length(x)/offset for (group in 0:(ngroups-1)) { ## vectorized j <- 1:lag + group*offset k <- j + lag xj <- x[j];xk <- x[k] x[j] <- xj + xk x[k] <- xj - xk } lag <- offset } ## while lag x } ## fwt index <- c(1, 2, 4, 8, 15, 16, 32, 51, 64, 85, 106, 128, 150, 171, 219, 237, 247, 256, 279, 297, 455, 512, 537, 557, 594, 643, 803, 863, 998, 1024, 1051, 1070, 1112, 1169, 1333, 1345, 1620, 1866, 2048, 2076, 2085, 2185, 2372, 2456, 2618, 2800, 2873, 3127, 3284, 3483, 3557, 3763, 4096, 4125, 4135, 4174, 4435, 4459, 4469, 4497, 4752, 5255, 5732, 5804, 5915, 6100, 6369, 6907, 7069, 8192, 8263, 8351, 8422, 8458, 8571, 8750, 8858, 9124, 9314, 9500, 10026, 10455, 10556, 11778, 11885, 11984, 13548, 14007, 14514, 14965, 15125, 15554, 16384, 16457, 16517, 16609, 16771, 16853, 17022, 17453, 17891, 18073, 18562, 18980, 19030, 19932, 20075, 20745, 21544, 22633, 23200, 24167, 25700, 26360, 26591, 26776, 28443, 28905, 29577, 32705) power <- index;p <- 1 for (i in 1:length(index)) { if (index[i]>=p) p <- p * 2 power[i] <- p } if (size > 120||size<1) stop("size must be in [1,120]") design <- matrix(0,power[size],size) for (i in 1:size) { design[index[i]+1,i] <- 1 design[,i] <- fwt(design[,i]) } if (ccd&&size>1) { design <- rbind(design,diag(size)*sqrt(size),-diag(size)*sqrt(size)) } design } ## FFdes logf <- function(beta,b,Bi=NULL,Xm=NULL,deriv=0) { ## get log joint density and first deriv w.r.t. coefs for a gam... ## Bi is a matrix mapping from interesting parameters to model parameters ## first deal with the log likelihood... if (is.null(Xm)) Xm <- if (is.null(b$X)) model.matrix(b) else b$X dd <- NULL if (!is.null(Bi)) beta <- drop(Bi %*% beta) if (inherits(b$family,"general.family")) { foo <- b$family$ll(b$y,Xm,beta,b$prior.weights,b$family,offset=b$offset,deriv=1) sll <- -2*foo$l dd <- -foo$lb } else if (inherits(b$family,"extended.family")) { theta <- b$family$getTheta() eta <- if (is.null(b$Xd)) as.numeric(Xm%*%beta + b$offset) else Xbd(b$Xd,beta,b$kd,b$ks,b$ts,b$dt,b$v,b$qc,b$drop) + b$offset mu <- b$family$linkinv(eta) sll <- sum(b$family$dev.resids(b$y,mu,b$prior.weights,theta)) ## deviance if (deriv) { #dd <- colSums((b$family$mu.eta(eta)*b$family$Dd(b$y,mu,theta,b$prior.weights)$Dmu)*Xm)/2 dd <- if (is.null(b$Xd)) drop((b$family$mu.eta(eta)*b$family$Dd(b$y,mu,theta,b$prior.weights)$Dmu) %*% Xm)/2 else XWyd(b$Xd,b$family$mu.eta(eta),b$family$Dd(b$y,mu,theta,b$prior.weights)$Dmu,b$kd,b$ks,b$ts,b$dt,b$v,b$qc,b$drop)/2 } } else { ## regular exponential family eta <- if (is.null(b$Xd)) as.numeric(Xm%*%beta + b$offset) else Xbd(b$Xd,beta,b$kd,b$ks,b$ts,b$dt,b$v,b$qc,b$drop) + b$offset mu <- b$family$linkinv(eta) sll <- sum(b$family$dev.resids(b$y,mu,b$prior.weights)) ## deviance if (deriv) { ##dd <- -colSums(b$prior.weights*(b$family$mu.eta(eta)*(b$y-mu)/b$family$variance(mu))*Xm) dd <- if (is.null(b$Xd)) -drop((b$prior.weights*(b$family$mu.eta(eta)*(b$y-mu)/b$family$variance(mu))) %*% Xm) else -XWyd(b$Xd,b$prior.weights,b$family$mu.eta(eta)*(b$y-mu)/b$family$variance(mu),b$kd,b$ks,b$ts,b$dt,b$v,b$qc,b$drop) } } ## deviance done ## now the smoothing prior/penalty ## NOTE: id's, fixed sp ??? if (length(b$smooth)) { k <- 1;pen <- 0 for (i in 1:length(b$smooth)) for (j in 1:length(b$smooth[[i]]$S)) { ind <- b$smooth[[i]]$first.para:b$smooth[[i]]$last.para b0 <- beta[ind] Sb <- b$smooth[[i]]$S[[j]] %*% b0 * b$sp[k] pen <- pen + sum(b0*Sb) if (deriv) dd[ind] <- dd[ind] + Sb k <- k + 1 } } if (!is.null(Bi)) dd <- drop(t(dd) %*% Bi) list(ll =(sll + pen)/(2*b$sig2),dd=dd) ## on neg log lik scale } ## logf glogf <- function(beta,b,Bi=NULL,Xm=NULL) { logf(beta,b,Bi=Bi,Xm=Xm,deriv=1)$dd } flogf <- function(beta,b,Bi=NULL,Xm=NULL) { logf(beta,b,Bi=Bi,Xm=Xm,deriv=0)$ll } Acomp <- function(A,ortho=TRUE) { ## simple matrix completion, if A is p by n, p <= n ## then returns full rank n by n matrix, B, whose last n-p ## rows are orthogonal to A, and its inverse Bi. p <- nrow(A);n<- ncol(A) if (ortho) { ## use orthogonal methods - very stable qra <- qr(t(A)) R <- qr.R(qra) if (Rrank(R) 0) lsp <- c(b$family$getTheta(),lsp) } else n.theta <- 0 ## check that family supports enough derivatives to allow integration step, ## otherwise just use empirical Bayes. if (!is.null(G$family$available.derivs)&&G$family$available.derivs==0&&int>0) { int <- 0 warning("integration not available with this family - insufficient derivatives") } ## Gaussian approximation is that log(sp) ~ N(lsp,V) if (int>0) { ## integration requested rV <- chol(V) ## Rv'z + lsp gives trial sp ip <- dg(ncol(rV)) ## integration points nip <- nrow(ip$D) } else nip <- 0 if (!is.null(G$family$preinitialize)) { if (inherits(G$family,"general.family")) { Gmod <- G$family$preinitialize(G) for (gnam in names(Gmod)) G[[gnam]] <- Gmod[[gnam]] ## copy these into G } else { ## extended family - just initializes theta and possibly y pini <- G$family$preinitialize(G$y,G$family) #if (!is.null(pini$Theta)) G$family$putTheta(pini$Theta) ## DON'T - will reset stored theta! if (!is.null(pini$y)) G$y <- pini$y } } X <- G$X G$prior.weights <- G$w G$sp <- b$sp reml <- rep(0,nip) dens <- list() ## list of lists of splines representing target density beta.lim <- matrix(0,ncol(X),2) ## evaluation limits for each A beta p <- ncol(b$Vp) if (!is.null(A)) { ## a transformation of original parameters is required if (is.matrix(A)||length(A)==p) { ## linear transforms needed B <- Acomp(A,is.null(G$Xd)) ## use orthogonal method only with gam fitting pa <- nrow(A) kind <- 1:pa } else { ## just a list of elements of beta A <- round(A) pa <- length(A) if (max(A)>p||min(A)<1||pa>p) stop("something wrong with A index vector") kind <- A B <- list() } } else { pa=p;kind <- 1:pa;B <- list()} iprog <- 0 if (prog) prg <- txtProgressBar(min = 0, max = (nip+1)*pa, initial = 0, char = "=",width = NA, title="Progress", style = 3) for (qq in 0:nip) { ## integration loop dens[[qq+1]] <- list() ## elements will be log densities for each target parameter if (qq>0) { ## then a new fit is needed sp <- drop(t(rV) %*% ip$D[qq,]) + lsp sp <- pmin(pmax(sp,lsp-10),lsp+10) ## avoid +/- inf wprior <- -sum((sp-lsp)^2/(200)) ## include the prior assumed in sp.vcov if (n.theta>0) { ## set family hyper-parameters ii <- 1:n.theta G$family$putTheta(sp[ii]) G$n.theta <- 0 ## fixed not estimated now. sp <- sp[-ii] } if (scale.estimated) { scale <- exp(sp[length(sp)]) sp <- sp[-length(sp)] } else scale <- 1 sp <- exp(sp) if (inherits(G,"gam.prefit")) b <- gam(G=G0,method="REML",sp=sp,scale=scale) else b <- bam(G=G0,sp=sp,scale=scale) G$sp <- sp reml[qq] <- -b$gcv.ubre + wprior } else max.reml <- -b$gcv.ubre ## maximum LAML G$family <- b$family G$sig2 <- b$sig2 beta <- coef(b) if (!is.null(B$B)) { ## a transformation of original parameters is required b$Vp <- B$B%*%b$Vp%*%t(B$B) beta <- drop(B$B%*%beta) } if (approx<2) { H <- cholinv(b$Vp) ## get Hessian - would be better returned directly by gam/bam dpc <- 1/sqrt(diag(H)) ## diagonal pre-conditioning R1 <- chol(dpc*t(H*dpc),pivot=TRUE) piv <- attr(R1,"pivot") } sd <- diag(b$Vp)^.5 ## standard dev of Gaussian approximation BM <- matrix(0,p,nk) ## storage for beta[k] conditional posterior modes inla <- list(density=matrix(0,pa,nb),beta=matrix(0,pa,nb)) ## storage for marginals ldet <- dens0 <- rep(0,nk) eps <- .0001 qn <- qnorm(seq(eps,1-eps,length=nk)) kk <- 0 for (k in kind) { kk <- kk + 1 ## counter for output arrays if (approx<2) { ## need R'R = H[-k,-k] (pivoted & pre-conditioned) kd <- which(piv==k) ## identify column of pivoted R1 corresponding to col k in H R <- choldrop(R1,kd) ## update R pivk <- piv[-kd]; pivk[pivk>k] <- pivk[pivk>k]-1 ## pivots updated attr(R,"pivot") <- pivk ## pivots of updated R attr(R,"dpc") <- dpc[-k] ## diagonal pre-conditioner ldetH <- 2*(sum(log(diag(R)))-sum(log(dpc[-k]))) ## log det of H[-k,-k] } bg <- qn*sd[k]+beta[k] BM[k,] <- bg BM[-k,] <- beta[-k] + b$Vp[-k,k]%*%((t(bg)-beta[k])/b$Vp[k,k]) ## Gaussian approx. if (approx==0) { ## get actual modes db <- db0 <- beta*0 for (i in c((nk/2):1,(nk/2):nk)) { beta0 <- BM[,i] + db0 nn <- logf(beta0,G,B$Bi,X,deriv=1) if (is.finite(nn$ll)) for (j in 1:20) { ## newton loop if (max(abs(nn$dd[-k]))<1e-4*abs(nn$ll)) break # db[-k] <- -backsolve(R,forwardsolve(Rt,nn$dd[-k])) db[-k] <- -Rsolve(R,nn$dd[-k]) beta1 <- beta0 + db nn1 <- logf(beta1,G,B$Bi,X,deriv=1) get.deriv <- FALSE hstep <- 0 while (!is.finite(nn1$ll) || nn1$ll>nn$ll) { db <- db/2; hstep <- hstep+1 beta1 <- beta0 + db nn1 <- logf(beta1,G,B$Bi,X,deriv=0) get.deriv <- TRUE } if (get.deriv) nn1 <- logf(beta1,G,B$Bi,X,deriv=1) nn <- nn1 beta0 <- beta1 } ## newton loop db0 <- if (i==1) 0 else beta0 - BM[,i] BM[,i] <- beta0 dens0[i] <- nn$ll } } else for (i in 1:nk) dens0[i] <- logf(BM[,i],G,B$Bi,X,deriv=0)$ll ## now get the log determinant correction... if (approx<2) { if (J>1) { vb <- apply(BM,1,var);vb[k] <- 0 j <- length(vb) del <- which(rank(vb)%in%(j:(j-J+2))) } step.length <- mean(colSums((BM - beta)^2)^.5)/20 D <- rep(c(-1,1),J) ## create matrix of steps and matrix of evaluated gradient at steps for (i in 1:nk) if (is.finite(dens0[i])) { bm <- BM[,i] db <- beta - bm;db[k] <- 0 db <- db/sqrt(sum(db^2))*step.length for (j in 1:J) { h = H[-k,-k] %*% db[-k] + if (j>1) u%*%(D[1:(2*(j-1))]*(t(u)%*%db[-k])) else 0 g1 <- glogf(bm+db/2,G,B$Bi,X) - glogf(bm-db/2,G,B$Bi,X) v <- cbind(h/sqrt(sum(db[-k]*h)),g1[-k]/sqrt(sum(db*g1))) u <- if (j>1) cbind(v,u) else v db <- -db; if (jmaxd*5e-3) { ok <- FALSE bg0 <- bg0 - sd[k] } if (inla$density[kk,nb]>maxd*5e-3) { ok <- FALSE bg1 <- bg1 + sd[k] } } ## normalizing interpolant as well... din$coefficients[,1] <- din$coefficients[,1] - log(n.const) dens[[qq+1]][[kk]] <- din if (qq==0||bg0beta.lim[k,2]) beta.lim[k,2] <- bg1 ## normalize iprog <- iprog + 1 if (prog) setTxtProgressBar(prg, iprog) if (interactive) { plot(inla$beta[kk,],inla$density[kk,],ylim=range(inla$density[kk,])*1.2,type="l",col=2, xlab=bquote(beta[.(k)]),ylab="density") lines(inla$beta[kk,],dnorm(inla$beta[kk,],mean=beta[k],sd=sd[k])) if (interactive==2) readline() } } ## beta loop } ## integration loop ## now the actual integration, if nip>0, otherwise we are done if (nip) { ## normalize the integration weights reml <- c(ip$k0,ip$k1*exp(reml-max.reml)) reml <- reml/sum(reml) for (k in 1:pa) { ## parameter loop inla$beta[k,] <- seq(beta.lim[k,1],beta.lim[k,2],length=nb) ## output beta sequence inla$density[k,] <- exp(predict(dens[[1]][[k]],inla$beta[k,])$y)*reml[1] ## normalized density } for (qq in 2:(nip+1)) { for (k in 1:pa) { ## parameter loop inla$density[k,] <- inla$density[k,] + exp(predict(dens[[qq]][[k]],inla$beta[k,])$y)*reml[qq] ## normalized density } } inla$reml <- reml } ## if nip if (prog) cat("\n") inla } ## ginla or gam inla newton enhanced (ginlane) mgcv/R/gamm.r0000755000176200001440000020422013555550567012536 0ustar liggesusers## R routines for mgcv::gamm (c) Simon Wood 2002-2019 ### the following two functions are for use in place of log and exp ### in positivity ensuring re-parameterization.... they have `better' ### over/underflow characteristics, but are still continuous to second ### derivative. notExp <- function(x) # overflow avoiding C2 function for ensuring positivity { 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) x[ind] <- -x[ind] ;f[ind] <- exp(1)*(x[ind]^2+1)/2; f[ind]<-1/f[ind] f } notLog <- function(x) # inverse function of notExp { f <- x ind <- x> exp(1) f[ind] <- sqrt(2*x[ind]/exp(1)-1) ind <- !ind & x > exp(-1) f[ind] <- log(x[ind]) ind <- x <= exp(-1) x[ind]<- 1/x[ind]; f[ind] <- sqrt(2*x[ind]/exp(1)-1);f[ind] <- -f[ind] f } ## notLog/notExp replacements. ## around 27/7/05 nlme was modified to use a new optimizer, which fails with ## indefinite Hessians. This is a problem if smoothing parameters are zero ## or infinite. The following attempts to make the notLog parameterization ## non-monotonic, to artificially reduce the likelihood at very large and very ## small parameter values. ## note gamm, pdTens, pdIdnot, notExp and notExp2 .Rd files all modified by ## this change. notExp2 <- function (x,d=.Options$mgcv.vc.logrange,b=1/d) ## to avoid needing to modify solve.pdIdnot, this transformation must ## maintain the property that 1/notExp2(x) = notExp2(-x) { exp(d*sin(x*b)) } notLog2 <- function(x,d=.Options$mgcv.vc.logrange,b=1/d) { x <- log(x)/d x <- pmin(1,x) x <- pmax(-1,x) asin(x)/b } #### pdMat class definitions, to enable tensor product smooths to be employed with gamm() #### Based on various Pinheiro and Bates pdMat classes. pdTens <- function(value = numeric(0), form = NULL, nam = NULL, data = sys.frame(sys.parent())) ## Constructor for the pdTens pdMat class: # the inverse of the scaled random effects covariance matrix for this class # is given by a weighted sum of the matrices in the list that is the "S" attribute of # a pdTens formula. The weights are the exponentials of the class parameters. # i.e. the inverse of the r.e. covariance matrix is # \sum_i \exp(\theta_i) S_i / \sigma^2 # The class name relates to the fact that these objects are used with tensor product smooths. { object <- numeric(0) class(object) <- c("pdTens", "pdMat") nlme::pdConstruct(object, value, form, nam, data) } ## Methods for local generics pdConstruct.pdTens <- function(object, value = numeric(0), form = formula(object), nam = nlme::Names(object), data = sys.frame(sys.parent()), ...) ## used to initialize pdTens objects. Note that the initialization matrices supplied ## are (factors of) trial random effects covariance matrices or their inverses. ## Which one is being passed seems to have to be derived from looking at its ## structure. ## Class tested rather thoroughly with nlme 3.1-52 on R 2.0.0 { val <- NextMethod() if (length(val) == 0) { # uninitiliazed object class(val) <- c("pdTens","pdMat") return(val) } if (is.matrix(val)) { # initialize from a positive definite S <- attr(form,"S") m <- length(S) ## codetools gets it wrong about `y' y <- as.numeric((crossprod(val))) # it's a factor that gets returned in val lform <- "y ~ as.numeric(S[[1]])" if (m>1) for (i in 2:m) lform <- paste(lform," + as.numeric(S[[",i,"]])",sep="") lform <- formula(paste(lform,"-1")) mod1 <- lm(lform) mod1.r2 <- 1-sum(residuals(mod1)^2)/sum((y-mean(y))^2) y <- as.numeric(solve(crossprod(val))) ## ignore codetools complaint about this mod2 <- lm(lform) mod2.r2 <- 1-sum(residuals(mod2)^2)/sum((y-mean(y))^2) ## `value' and `val' can relate to the cov matrix or its inverse: ## the following seems to be only way to tell which. #if (summary(mod2)$r.sq>summary(mod1)$r.sq) mod1<-mod2 if (mod2.r2 > mod1.r2) mod1 <- mod2 value <- coef(mod1) value[value <=0] <- .Machine$double.eps * mean(as.numeric(lapply(S,function(x) max(abs(x))))) value <- notLog2(value) attributes(value) <- attributes(val)[names(attributes(val)) != "dim"] class(value) <- c("pdTens", "pdMat") return(value) } m <- length(attr(form,"S")) if ((aux <- length(val)) > 0) { if (aux && (aux != m)) { stop(gettextf("An object of length %d does not match the required parameter size",aux)) } } class(val) <- c("pdTens","pdMat") val } pdFactor.pdTens <- function(object) ## The factor of the inverse of the scaled r.e. covariance matrix is returned here ## it should be returned as a vector. { sp <- as.vector(object) m <- length(sp) S <- attr(formula(object),"S") value <- S[[1]]*notExp2(sp[1]) if (m>1) for (i in 2:m) value <- value + notExp2(sp[i])*S[[i]] if (sum(is.na(value))>0) warning("NA's in pdTens factor") value <- (value+t(value))/2 c(t(mroot(value,rank=nrow(value)))) } pdMatrix.pdTens <- function(object, factor = FALSE) # the inverse of the scaled random effect covariance matrix is returned here, or # its factor if factor==TRUE. If A is the matrix being factored and B its # factor, it is required that A=B'B (not the mroot() default!) { if (!nlme::isInitialized(object)) { stop("Cannot extract the matrix from an uninitialized object") } sp <- as.vector(object) m <- length(sp) S <- attr(formula(object),"S") value <- S[[1]]*notExp2(sp[1]) if (m>1) for (i in 2:m) value <- value + notExp2(sp[i])*S[[i]] value <- (value + t(value))/2 # ensure symmetry if (sum(is.na(value))>0) warning("NA's in pdTens matrix") if (factor) { value <- t(mroot(value,rank=nrow(value))) } dimnames(value) <- attr(object, "Dimnames") value } #### Methods for standard generics coef.pdTens <- function(object, unconstrained = TRUE, ...) { if (unconstrained) NextMethod() else { val <- notExp2(as.vector(object)) names(val) <- paste("sp.",1:length(val), sep ="") val } } summary.pdTens <- function(object, structName = "Tensor product smooth term", ...) { NextMethod(object, structName, noCorrelation=TRUE) } # .... end of pdMat definitions for tensor product smooths ### pdIdnot: multiple of the identity matrix - the parameter is ### the notLog2 of the multiple. This is directly modified form ### Pinheiro and Bates pdIdent class. ####* Constructor pdIdnot <- ## Constructor for the pdIdnot class function(value = numeric(0), form = NULL, nam = NULL, data = sys.frame(sys.parent())) { #cat(" pdIdnot ") object <- numeric(0) class(object) <- c("pdIdnot", "pdMat") nlme::pdConstruct(object, value, form, nam, data) } ####* Methods for local generics corMatrix.pdIdnot <- function(object, ...) { if (!nlme::isInitialized(object)) { stop("Cannot extract the matrix from an uninitialized pdMat object") } if (is.null(Ncol <- attr(object, "ncol"))) { stop(paste("Cannot extract the matrix with uninitialized dimensions")) } val <- diag(Ncol) ## REMOVE sqrt() to revert ... attr(val, "stdDev") <- rep(sqrt(notExp2(as.vector(object))), Ncol) if (length(nm <- nlme::Names(object)) == 0) { len <- length(as.vector(object)) nm <- paste("V", 1:len, sep = "") dimnames(val) <- list(nm, nm) } names(attr(val, "stdDev")) <- nm val } pdConstruct.pdIdnot <- function(object, value = numeric(0), form = formula(object), nam = nlme::Names(object), data = sys.frame(sys.parent()), ...) { #cat(" pdConstruct.pdIdnot ") val <- NextMethod() if (length(val) == 0) { # uninitialized object if ((ncol <- length(nlme::Names(val))) > 0) { attr(val, "ncol") <- ncol } return(val) } if (is.matrix(val)) { # value <- notLog2(sqrt(mean(diag(crossprod(val))))) value <- notLog2(mean(diag(crossprod(val)))) ## REPLACE by above to revert attributes(value) <- attributes(val)[names(attributes(val)) != "dim"] attr(value, "ncol") <- dim(val)[2] class(value) <- c("pdIdnot", "pdMat") return(value) } if (length(val) > 1) { stop(paste("An object of length", length(val), "does not match the required parameter size")) } if (((aux <- length(nlme::Names(val))) == 0) && is.null(formula(val))) { stop(paste("Must give names when initializing pdIdnot from parameter.", "without a formula")) } else { attr(val, "ncol") <- aux } val } pdFactor.pdIdnot <- function(object) { ## UNCOMMENT first line, comment 2nd to revert # notExp2(as.vector(object)) * diag(attr(object, "ncol")) #cat(" pdFactor.pdIdnot ") sqrt(notExp2(as.vector(object))) * diag(attr(object, "ncol")) } pdMatrix.pdIdnot <- function(object, factor = FALSE) { #cat(" pdMatrix.pdIdnot ") if (!nlme::isInitialized(object)) { stop("Cannot extract the matrix from an uninitialized pdMat object") } if (is.null(Ncol <- attr(object, "ncol"))) { stop(paste("Cannot extract the matrix with uninitialized dimensions")) } value <- diag(Ncol) ## REPLACE by #1,#2,#3 to revert if (factor) { #1 value <- notExp2(as.vector(object)) * value #2 attr(value, "logDet") <- Ncol * log(notExp2(as.vector(object))) value <- sqrt(notExp2(as.vector(object))) * value attr(value, "logDet") <- Ncol * log(notExp2(as.vector(object)))/2 } else { #3 value <- notExp2(as.vector(object))^2 * value value <- notExp2(as.vector(object)) * value } dimnames(value) <- attr(object, "Dimnames") value } ####* Methods for standard generics coef.pdIdnot <- function(object, unconstrained = TRUE, ...) { #cat(" coef.pdIdnot ") if (unconstrained) NextMethod() else structure(notExp2(as.vector(object)), names = c(paste("sd(", deparse(formula(object)[[2]],backtick=TRUE),")",sep = ""))) } Dim.pdIdnot <- function(object, ...) { if (!is.null(val <- attr(object, "ncol"))) { c(val, val) } else { stop("Cannot extract the dimensions") } } logDet.pdIdnot <- function(object, ...) { ## REMOVE /2 to revert .... attr(object, "ncol") * log(notExp2(as.vector(object)))/2 } solve.pdIdnot <- function(a, b, ...) { if (!nlme::isInitialized(a)) { stop("Cannot extract the inverse from an uninitialized object") } atr <- attributes(a) a <- -coef(a, TRUE) attributes(a) <- atr a } summary.pdIdnot <- function(object, structName = "Multiple of an Identity", ...) { #cat(" summary.pdIdnot ") # summary.pdMat(object, structName, noCorrelation = TRUE) ## ... summary.pdMat is not exported in the nlme NAMESPACE file, so.... NextMethod(object, structName, noCorrelation=TRUE) } ### end of pdIdnot class smooth2random <- function(object,vnames,type=1) UseMethod("smooth2random") smooth2random.fs.interaction <- function(object,vnames,type=1) { ## conversion method for smooth-factor random interactions. ## For use with gamm4, this needs to generate a sparse version of ## each full model matrix, with smooth coefs re-ordered so that the ## penalties are not interwoven, but blocked (i.e. this ordering is ## as for gamm case). if (object$fixed) return(list(fixed=TRUE,Xf=object$X)) ## If smooth constructor was not called with "gamm" attribute set, ## then we need to reset model matrix to base model matrix. if (!is.null(object$Xb)) { object$X <- object$Xb object$S <- object$base$S if (!is.null(object$S.scale)&&length(object$S)>0) for (i in 1:length(object$S)) object$S[[i]] <- object$S[[i]]/object$S.scale[i] } colx <- ncol(object$X) diagU <- rep(1,colx) ind <- 1:colx ## flev <- levels(object$fac) n.lev <- length(object$flev) if (type==2) { ## index which params in fit parameterization are penalized by each penalty. ## e.g. pen.ind==1 is TRUE for each param penalized by first penalty and ## FALSE otherwise... pen.ind <- rep(ind*0,n.lev) } else pen.ind <- NULL random <- list() k <- 1 rinc <- rind <- rep(0,0) for (i in 1:length(object$S)) { ## work through penalties indi <- ind[diag(object$S[[i]])!=0] ## index of penalized cols X <- object$X[,indi,drop=FALSE] ## model matrix for this component D <- diag(object$S[[i]])[indi] diagU[indi] <- 1/sqrt(D) ## transform that reduces penalty to identity X <- X%*%diag(diagU[indi],ncol=length(indi)) term.name <- new.name("Xr",vnames) vnames <- c(vnames,term.name) rind <- c(rind,k:(k+ncol(X)-1)) rinc <- c(rinc,rep(ncol(X),ncol(X))) k <- k + n.lev * ncol(X) if (type==1) { ## gamm form for use with lme ## env set to avoid 'save' saving whole environment to file... form <- as.formula(paste("~",term.name,"-1",sep=""),env=.GlobalEnv) random[[i]] <- pdIdnot(form) names(random)[i] <- object$fterm ## supplied factor name attr(random[[i]],"group") <- object$fac ## factor supplied as part of term attr(random[[i]],"Xr.name") <- term.name attr(random[[i]],"Xr") <- X } else { ## gamm4 form --- whole sparse matrices Xr <- as(matrix(0,nrow(X),0),"dgCMatrix") ii <- 0 for (j in 1:n.lev) { ## assemble full sparse model matrix Xr <- cbind2(Xr,as(X*as.numeric(object$fac==object$flev[j]),"dgCMatrix")) pen.ind[indi+ii] <- i;ii <- ii + colx } random[[i]] <- if (is.null(object$Xb)) Xr else as(Xr,"matrix") names(random)[i] <- term.name attr(random[[i]],"s.label") <- object$label } } if (type==2) { ## expand the rind (rinc not needed) ind <- 1:length(rind) ni <- length(ind) rind <- rep(rind,n.lev) if (n.lev>1) for (k in 2:n.lev) { rind[ind+ni] <- rind[ind]+rinc ind <- ind + ni } D <- rep(diagU,n.lev) } else D <- diagU ## b_original = D*b_fit Xf <- matrix(0,nrow(object$X),0) list(rand=random,trans.D=D,Xf=Xf,fixed=FALSE,rind=rind,rinc=rinc, pen.ind=pen.ind) ## pen.ind==i is TRUE for coefs penalized by ith penalty } ## smooth2random.fs.interaction smooth2random.t2.smooth <- function(object,vnames,type=1) { ## takes a smooth object and turns it into a form suitable for estimation as a random effect ## vnames is a list of names to avoid when assigning variable names. ## type==1 indicates an lme random effect. ## Returns 1. a list of random effects, including grouping factors, and ## a fixed effects matrix. Grouping factors, model matrix and ## model matrix name attached as attributes, to each element. ## 2. rind: and index vector such that if br is the vector of ## random coefficients for the term, br[rind] is the coefs in ## order for this term. rinc - dummy here. ## 3. A matrix, trans.D, that transforms coefs, in order [rand1, rand2,... fix] ## back to original parameterization. If null, then not needed. ## 4. A matrix Xf for the fixed effects, if any. ## 5. fixed TRUE/FALSE if its fixed or not. If fixed the other stuff is ## not returned. ## This version deals only with t2 smooths conditioned on a whole ## dataset dummy factor. ## object must contain model matrix for smooth. if (object$fixed) return(list(fixed=TRUE,Xf=object$X)) fixed <- rep(TRUE,ncol(object$X)) random <- list() diagU <- rep(1,ncol(object$X)) ind <- 1:ncol(object$X) pen.ind <- ind*0 n.para <- 0 for (i in 1:length(object$S)) { ## work through penalties indi <- ind[diag(object$S[[i]])!=0] ## index of penalized cols pen.ind[indi] <- i X <- object$X[,indi,drop=FALSE] ## model matrix for this component D <- diag(object$S[[i]])[indi] diagU[indi] <- 1/sqrt(D) ## transform that reduces penalty to identity X <- X%*%diag(diagU[indi]) fixed[indi] <- FALSE term.name <- new.name("Xr",vnames) group.name <- new.name("g",vnames) vnames <- c(vnames,term.name,group.name) if (type==1) { ## gamm form for lme ## env set to avoid 'save' saving whole environment to file... form <- as.formula(paste("~",term.name,"-1",sep=""),env=.GlobalEnv) random[[i]] <- pdIdnot(form) names(random)[i] <- group.name attr(random[[i]],"group") <- factor(rep(1,nrow(X))) attr(random[[i]],"Xr.name") <- term.name attr(random[[i]],"Xr") <- X } else { ## lmer form as used by gamm4 random[[i]] <- X names(random)[i] <- term.name attr(random[[i]],"s.label") <- object$label } n.para <- n.para + ncol(X) } if (sum(fixed)) { ## then there are fixed effects! Xf <- object$X[,fixed,drop=FALSE] } else Xf <- matrix(0,nrow(object$X),0) list(rand=random,trans.D=diagU,Xf=Xf,fixed=FALSE, rind=1:n.para,rinc=rep(n.para,n.para),pen.ind=pen.ind) } ## smooth2random.t2.smooth smooth2random.mgcv.smooth <- function(object,vnames,type=1) { ## takes a smooth object and turns it into a form suitable for estimation as a random effect ## vnames is a list of names to avoid when assigning variable names. ## type==1 indicates an lme random effect. ## Returns 1. a list of random effects, including grouping factors, and ## a fixed effects matrix. Grouping factors, model matrix and ## model matrix name attached as attributes, to each element. ## 2. rind: an index vector such that if br is the vector of ## random coefficients for the term, br[rind] is the coefs in ## order for this term. rinc - dummy here. ## 3. A matrix, U, + vec D that transforms coefs, in order [rand1, rand2,... fix] ## back to original parameterization. b_origonal = U%*%(D*b_fit) ## 4. A matrix Xf for the fixed effects, if any. ## 5. fixed TRUE/FALSE if its fixed or not. If fixed the other stuff is ## not returned. ## This version deals only with single penalty smooths conditioned on a whole ## dataset dummy factor. ## object must contain model matrix for smooth. if (object$fixed) return(list(fixed=TRUE,Xf=object$X)) if (length(object$S)>1) stop("Can not convert this smooth class to a random effect") ## reparameterize so that unpenalized basis is separated out and at end... ev <- eigen(object$S[[1]],symmetric=TRUE) null.rank <- object$df - object$rank p.rank <- object$rank if (p.rank>ncol(object$X)) p.rank <- ncol(object$X) U <- ev$vectors D <- c(ev$values[1:p.rank],rep(1,null.rank)) D <- 1/sqrt(D) UD <- t(t(U)*D) ## U%*%[b,beta] returns coefs in original parameterization X <- object$X%*%UD if (p.rank1) for (l in 2:length(object$S)) { sum.S <- sum.S + object$S[[l]]/mean(abs(object$S[[l]])) #dfl <- ncol(object$margin[[l]]$X) ## actual df of term (`df' may not be set by constructor) #null.rank <- null.rank * (dfl-object$margin[[l]]$rank) #bs.dim <- bs.dim * dfl } null.rank <- object$null.space.dim #null.rank <- null.rank - bs.dim + object$df ##sum.S <- (sum.S+t(sum.S))/2 # ensure symmetry ev <- eigen(sum.S,symmetric=TRUE) p.rank <- ncol(object$X) - null.rank if (p.rank>ncol(object$X)) p.rank <- ncol(object$X) U <- ev$vectors D <- c(ev$values[1:p.rank],rep(1,null.rank)) if (sum(D<=0)) stop( "Tensor product penalty rank appears to be too low: please email Simon.Wood@R-project.org with details.") ## D <- 1/sqrt(D) U <- U ## maps coefs back to untransformed versions X <- object$X%*%U if (p.rank0) ind <- 1:G$nsdf else ind <- rep(0,0) X <- G$X[,ind,drop=FALSE] # accumulate fixed effects into here xlab <- rep("",0) ## first have to create a processing order, so that any smooths conditional on ## multi-level factors are processed last, and hence end up at the end of the ## random list (right is nested in left in this list!) if (G$m>0) { pord <- 1:G$m done <- rep(FALSE,length(pord)) k <- 0 f.name <- NULL for (i in 1:G$m) if (is.null(G$smooth[[i]]$fac)) { k <- k + 1 pord[k] <- i done[i] <- TRUE } else { if (is.null(f.name)) f.name <- G$smooth[[i]]$fterm else if (f.name!=G$smooth[[i]]$fterm) stop("only one level of smooth nesting is supported by gamm") if (!is.null(attr(G$smooth[[i]],"del.index"))) stop("side conditions not allowed for nested smooths") } if (k < G$m) pord[(k+1):G$m] <- (1:G$m)[!done] ## .... ordered so that nested smooths are last } if (G$m) for (i in 1:G$m) { ## work through the smooths sm <- G$smooth[[pord[i]]] sm$X <- G$X[,sm$first.para:sm$last.para,drop=FALSE] rasm <- smooth2random(sm,names(data)) ## convert smooth to random effect and fixed effects sm$fixed <- rasm$fixed if (!is.null(sm$fac)) { flev <- levels(sm$fac) ## grouping factor for smooth ##n.lev <- length(flev) } ##else n.lev <- 1 ## now append constructed variables to model frame and random effects to main list n.para <- 0 ## count random coefficients ## rinc <- rind <- rep(0,0) if (!sm$fixed) { # kk <- 1; for (k in 1:length(rasm$rand)) { group.name <- names(rasm$rand)[k] group <- attr(rasm$rand[[k]],"group") Xr.name <- attr(rasm$rand[[k]],"Xr.name") Xr <- attr(rasm$rand[[k]],"Xr") attr(rasm$rand[[k]],"group") <- attr(rasm$rand[[k]],"Xr") <- attr(rasm$rand[[k]],"Xr.name") <- NULL # rind <- c(rind,kk:(kk+ncol(Xr)-1)) # rinc <- c(rinc,rep(ncol(Xr),ncol(Xr))) ## increment for rind # kk <- kk + n.lev * ncol(Xr) n.para <- n.para + ncol(Xr) data[[group.name]] <- group data[[Xr.name]] <- Xr } random <- c(random,rasm$rand) sm$trans.U <- rasm$trans.U ## matrix mapping fit coefs back to original sm$trans.D <- rasm$trans.D ## so b_original = U%*%(D*b_fit) } if (ncol(rasm$Xf)) { ## lme requires names Xfnames <- rep("",ncol(rasm$Xf)) k <- length(xlab)+1 for (j in 1:ncol(rasm$Xf)) { xlab[k] <- Xfnames[j] <- new.name(paste(sm$label,"Fx",j,sep=""),xlab) k <- k + 1 } colnames(rasm$Xf) <- Xfnames } X <- cbind(X,rasm$Xf) # add fixed model matrix to overall fixed X ## update the counters indicating which elements of the whole model ## fixed and random coef vectors contain the coefs for this smooth. ## note convention that smooth coefs are [random, fixed] sm$first.f.para <- first.f.para first.f.para <- first.f.para + ncol(rasm$Xf) sm$last.f.para <- first.f.para - 1 ## note less than sm$first.f.para => no fixed sm$rind <- rasm$rind - 1 + first.r.para sm$rinc <- rasm$rinc # sm$first.r.para <- first.r.para first.r.para <- first.r.para+n.para # sm$last.r.para <- first.r.para-1 sm$n.para <- n.para ## convention is that random coefs for grouped smooths will be ## packed [coefs for level 1, coefs for level 2, ...] ## n.para is number of random paras at each level. ## so coefs for ith level will be indexed by ## rind + (i-1)*n.para ## first.r.para:last.r.para + (i-1)*n.para if (!is.null(sm$fac)) { ## there is a grouping factor for this smooth ## have to up this first.r.para to allow a copy of coefs for each level of fac... first.r.para <- first.r.para + n.para*(length(flev)-1) } sm$X <- NULL ## delete model matrix if (G$m>0) G$smooth[[pord[i]]] <- sm ## replace smooth object with extended version } G$random <- random G$X <- X ## fixed effects model matrix G$data <- data if (G$m>0) G$pord <- pord ## gamm needs to run through smooths in same order as here G } ## end of gamm.setup varWeights.dfo <- function(b,data) ## get reciprocal *standard deviations* implied by the estimated variance ## structure of an lme object, b, in *original data frame order*. { w <- nlme::varWeights(b$modelStruct$varStruct) # w is not in data.frame order - it's in inner grouping level order group.name <- names(b$groups) # b$groups[[i]] doesn't always retain factor ordering ind <- NULL order.txt <- paste("ind<-order(data[[\"",group.name[1],"\"]]",sep="") if (length(b$groups)>1) for (i in 2:length(b$groups)) order.txt <- paste(order.txt,",data[[\"",group.name[i],"\"]]",sep="") order.txt <- paste(order.txt,")") eval(parse(text=order.txt)) w[ind] <- w # into data frame order w } extract.lme.cov2<-function(b,data=NULL,start.level=1) # function to extract the response data covariance matrix from an lme fitted # model object b, fitted to the data in data. "inner" == "finest" grouping # start.level is the r.e. grouping level at which to start the construction, # levels outer to this will not be included in the calculation - this is useful # for gamm calculations # # This version aims to be efficient, by not forming the complete matrix if it # is diagonal or block diagonal. To this end the matrix is returned in a form # that relates to the data re-ordered according to the coarsest applicable # grouping factor. ind[i] gives the row in the original data frame # corresponding to the ith row/column of V. # V is either returned as an array, if it's diagonal, a matrix if it is # a full matrix or a list of matrices if it is block diagonal. { if (!inherits(b,"lme")) stop("object does not appear to be of class lme") if (is.null(data)) { na.act <- na.action(b) data <- if (is.null(na.act)) b$data else b$data[-na.act,] } grps <- nlme::getGroups(b) # labels of the innermost groupings - in data frame order n <- length(grps) # number of data n.levels <- length(b$groups) # number of levels of grouping (random effects only) # if (n.levels 0 iff it determines the coarsest grouping ## level if > start.level. if (n.levels1) for (i in 2:length(vnames)) { lab <- paste(lab,"/",eval(parse(text=vnames[i]),envir=b$data),sep="") } grps <- factor(lab) } if (n.levels >= start.level||n.corlevels >= start.level) { if (n.levels >= start.level) Cgrps <- nlme::getGroups(b,level=start.level) # outer grouping labels (dforder) else Cgrps <- grps #Cgrps <- nlme::getGroups(b$modelStruct$corStruct) # ditto Cind <- sort(as.numeric(Cgrps),index.return=TRUE)$ix # Cind[i] is where row i of sorted Cgrps is in original data frame order rCind <- 1:n; rCind[Cind] <- 1:n # rCind[i] is location of ith original datum in the coarse ordering ## CFgrps <- grps[Cind] # fine group levels in coarse group order (unused!!) Clevel <- levels(Cgrps) # levels of coarse grouping factor n.cg <- length(Clevel) # number of outer groups size.cg <- array(0,n.cg) for (i in 1:n.cg) size.cg[i] <- sum(Cgrps==Clevel[i]) # size of each coarse group ## Cgrps[Cind] is sorted by coarsest grouping factor level ## so e.g. y[Cind] would be data in c.g.f. order } else {n.cg <- 1;Cind<-1:n} if (is.null(b$modelStruct$varStruct)) w<-rep(b$sigma,n) ### else { w <- 1/nlme::varWeights(b$modelStruct$varStruct) # w is not in data.frame order - it's in inner grouping level order group.name<-names(b$groups) # b$groups[[i]] doesn't always retain factor ordering order.txt <- paste("ind<-order(data[[\"",group.name[1],"\"]]",sep="") if (length(b$groups)>1) for (i in 2:length(b$groups)) order.txt <- paste(order.txt,",data[[\"",group.name[i],"\"]]",sep="") order.txt <- paste(order.txt,")") eval(parse(text=order.txt)) w[ind] <- w # into data frame order w <- w*b$sigma } w <- w[Cind] # re-order in coarse group order if (is.null(b$modelStruct$corStruct)) V<-array(1,n) else { c.m<-nlme::corMatrix(b$modelStruct$corStruct) # correlation matrices for each innermost group if (!is.list(c.m)) { # copy and re-order into coarse group order V <- c.m;V[Cind,] -> V;V[,Cind] -> V } else { V<-list() # V[[i]] is cor matrix for ith coarse group ind <- list() # ind[[i]] is order index for V[[i]] for (i in 1:n.cg) { V[[i]] <- matrix(0,size.cg[i],size.cg[i]) ind[[i]] <- 1:size.cg[i] } # Voff[i] is where, in coarse order data, first element of V[[i]] # relates to ... Voff <- cumsum(c(1,size.cg)) gr.name <- names(c.m) # the names of the innermost groups n.g<-length(c.m) # number of innermost groups j0<-rep(1,n.cg) # place holders in V[[i]]'s ii <- 1:n for (i in 1:n.g) # work through innermost groups { # first identify coarse grouping Clev <- unique(Cgrps[grps==gr.name[i]]) # level for coarse grouping factor if (length(Clev)>1) stop("inner groupings not nested in outer!!") k <- (1:n.cg)[Clevel==Clev] # index of coarse group - i.e. update V[[k]] # now need to get c.m into right place within V[[k]] j1<-j0[k]+nrow(c.m[[i]])-1 V[[k]][j0[k]:j1,j0[k]:j1]<-c.m[[i]] ind1 <- ii[grps==gr.name[i]] # ind1 is the rows of original data.frame to which c.m[[i]] applies # assuming that data frame order is preserved at the inner grouping ind2 <- rCind[ind1] # ind2 contains the rows of the coarse ordering to which c.m[[i]] applies ind[[k]][j0[k]:j1] <- ind2 - Voff[k] + 1 # ind[k] accumulates rows within coarse group k to which V[[k]] applies j0[k]<-j1+1 } for (k in 1:n.cg) { # pasting correlations into right place in each matrix V[[k]][ind[[k]],]<-V[[k]];V[[k]][,ind[[k]]]<-V[[k]] } } } # now form diag(w)%*%V%*%diag(w), depending on class of V if (is.list(V)) # it's a block diagonal structure { for (i in 1:n.cg) { wi <- w[Voff[i]:(Voff[i]+size.cg[i]-1)] V[[i]] <- as.vector(wi)*t(as.vector(wi)*V[[i]]) } } else if (is.matrix(V)) { V <- as.vector(w)*t(as.vector(w)*V) } else # it's a diagonal matrix { V <- w^2*V } # ... covariance matrix according to fitted correlation structure in coarse # group order ## Now work on the random effects ..... X <- list() grp.dims <- b$dims$ncol # number of Zt columns for each grouping level (inner levels first) # inner levels are first in Zt Zt <- model.matrix(b$modelStruct$reStruct,data) # a sort of proto - Z matrix # b$groups and cov (defined below have the inner levels last) cov <- as.matrix(b$modelStruct$reStruct) # list of estimated covariance matrices (inner level last) i.col<-1 Z <- matrix(0,n,0) # Z matrix if (start.level<=n.levels) { for (i in 1:(n.levels-start.level+1)) # work through the r.e. groupings inner to outer { # get matrix with columns that are indicator variables for ith set of groups... # groups has outer levels first if(length(levels(b$groups[[n.levels-i+1]]))==1) { ## model.matrix needs >1 level X[[1]] <- matrix(rep(1,nrow(b$groups))) } else { clist <- list('b$groups[[n.levels - i + 1]]'=c("contr.treatment","contr.treatment")) X[[1]] <- model.matrix(~b$groups[[n.levels - i + 1]]-1, contrasts.arg=clist) } # Get `model matrix' columns relevant to current grouping level... X[[2]] <- Zt[,i.col:(i.col+grp.dims[i]-1),drop=FALSE] i.col <- i.col+grp.dims[i] # tensor product the X[[1]] and X[[2]] rows... Z <- cbind(Z,tensor.prod.model.matrix(X)) } # so Z assembled from inner to outer levels # Now construct overall ranef covariance matrix Vr <- matrix(0,ncol(Z),ncol(Z)) start <- 1 for (i in 1:(n.levels-start.level+1)) { k <- n.levels-i+1 for (j in 1:b$dims$ngrps[i]) { stop <- start+ncol(cov[[k]])-1 Vr[start:stop,start:stop]<-cov[[k]] start <- stop+1 } } Vr <- Vr*b$sigma^2 ## Now re-order Z into coarse group order Z <- Z[Cind,] ## Now Z %*% Vr %*% t(Z) is block diagonal: if Z' = [Z1':Z2':Z3': ... ] ## where Zi contains th rows of Z for the ith level of the coarsest ## grouping factor, then the ith block of (Z Vr Z') is (Zi Vr Zi') if (n.cg == 1) { if (is.matrix(V)) { V <- V+Z%*%Vr%*%t(Z) } else V <- diag(V) + Z%*%Vr%*%t(Z) } else { # V has a block - diagonal structure j0 <- 1 Vz <- list() for (i in 1:n.cg) { j1 <- size.cg[i] + j0 -1 Zi <- Z[j0:j1,,drop=FALSE] Vz[[i]] <- Zi %*% Vr %*% t(Zi) j0 <- j1+1 } if (is.list(V)) { for (i in 1:n.cg) V[[i]] <- V[[i]]+Vz[[i]] } else { j0 <-1 for (i in 1:n.cg) { kk <- size.cg[i] j1 <- kk + j0 -1 Vz[[i]] <- Vz[[i]] + diag(x=V[j0:j1],nrow=kk,ncol=kk) j0 <- j1+1 } V <- Vz } } } list(V=V,ind=Cind) } ## extract.lme.cov2 extract.lme.cov<-function(b,data=NULL,start.level=1) # function to extract the response data covariance matrix from an lme fitted # model object b, fitted to the data in data. "inner" == "finest" grouping # start.level is the r.e. grouping level at which to start the construction, # levels outer to this will not be included in the calculation - this is useful # for gamm calculations { if (!inherits(b,"lme")) stop("object does not appear to be of class lme") if (is.null(data)) { na.act <- na.action(b) data <- if (is.null(na.act)) b$data else b$data[-na.act,] } grps<-nlme::getGroups(b) # labels of the innermost groupings - in data frame order n<-length(grps) # number of data if (is.null(b$modelStruct$varStruct)) w<-rep(b$sigma,n) ### else { w<-1/nlme::varWeights(b$modelStruct$varStruct) # w is not in data.frame order - it's in inner grouping level order group.name<-names(b$groups) # b$groups[[i]] doesn't always retain factor ordering order.txt <- paste("ind<-order(data[[\"",group.name[1],"\"]]",sep="") if (length(b$groups)>1) for (i in 2:length(b$groups)) order.txt <- paste(order.txt,",data[[\"",group.name[i],"\"]]",sep="") order.txt <- paste(order.txt,")") eval(parse(text=order.txt)) w[ind] <- w # into data frame order w<-w*b$sigma } if (is.null(b$modelStruct$corStruct)) V<-diag(n) #*b$sigma^2 else { c.m<-nlme::corMatrix(b$modelStruct$corStruct) # correlation matrices for each group if (!is.list(c.m)) V<-c.m else { V<-matrix(0,n,n) # data cor matrix gr.name <- names(c.m) # the names of the groups n.g<-length(c.m) # number of innermost groups j0<-1 ind<-ii<-1:n for (i in 1:n.g) { j1<-j0+nrow(c.m[[i]])-1 V[j0:j1,j0:j1]<-c.m[[i]] ind[j0:j1]<-ii[grps==gr.name[i]] j0<-j1+1 } V[ind,]<-V;V[,ind]<-V # pasting correlations into right place in overall matrix # V<-V*b$sigma^2 } } V <- as.vector(w)*t(as.vector(w)*V) # diag(w)%*%V%*%diag(w) # ... covariance matrix according to fitted correlation structure X<-list() grp.dims<-b$dims$ncol # number of Zt columns for each grouping level (inner levels first) # inner levels are first in Zt Zt<-model.matrix(b$modelStruct$reStruct,data) # a sort of proto - Z matrix # b$groups and cov (defined below have the inner levels last) cov<-as.matrix(b$modelStruct$reStruct) # list of estimated covariance matrices (inner level last) i.col<-1 n.levels<-length(b$groups) Z<-matrix(0,n,0) # Z matrix if (start.level<=n.levels) { for (i in 1:(n.levels-start.level+1)) # work through the r.e. groupings inner to outer { # get matrix with columns that are indicator variables for ith set of groups... # groups has outer levels first if(length(levels(b$groups[[n.levels-i+1]]))==1) { ## model.matrix needs >1 level X[[1]] <- matrix(rep(1,nrow(b$groups))) } else { clist <- list('b$groups[[n.levels - i + 1]]'=c("contr.treatment","contr.treatment")) X[[1]] <- model.matrix(~b$groups[[n.levels - i + 1]]-1, contrasts.arg=clist) } # Get `model matrix' columns relevant to current grouping level... X[[2]] <- Zt[,i.col:(i.col+grp.dims[i]-1),drop=FALSE] i.col <- i.col+grp.dims[i] # tensor product the X[[1]] and X[[2]] rows... Z <- cbind(Z,tensor.prod.model.matrix(X)) } # so Z assembled from inner to outer levels # Now construct overall ranef covariance matrix Vr <- matrix(0,ncol(Z),ncol(Z)) start <- 1 for (i in 1:(n.levels-start.level+1)) { k <- n.levels-i+1 for (j in 1:b$dims$ngrps[i]) { stop <- start+ncol(cov[[k]])-1 Vr[start:stop,start:stop]<-cov[[k]] start <- stop+1 } } Vr <- Vr*b$sigma^2 V <- V+Z%*%Vr%*%t(Z) } V } ## extract.lme.cov formXtViX <- function(V,X) ## forms X'V^{-1}X as efficiently as possible given the structure of ## V (diagonal, block-diagonal, full) ## Actually returns R where R'R = X'V^{-1}X { X <- X[V$ind,,drop=FALSE] # have to re-order X according to V ordering if (is.list(V$V)) { ### block diagonal case Z <- X j0 <- 1 for (i in 1:length(V$V)) { Cv <- chol(V$V[[i]]) j1 <- j0+nrow(V$V[[i]])-1 Z[j0:j1,] <- backsolve(Cv,X[j0:j1,,drop=FALSE],transpose=TRUE) j0 <- j1 + 1 } #res <- t(Z)%*%Z } else if (is.matrix(V$V)) { ### full matrix case Cv <- chol(V$V) Z <- backsolve(Cv,X,transpose=TRUE) #res <- t(Z)%*%Z } else { ### diagonal matrix case Z <- X/sqrt(as.numeric(V$V)) #res <- t(X)%*%(X/as.numeric(V$V)) } qrz <- qr(Z,LAPACK=TRUE) R <- qr.R(qrz);R[,qrz$pivot] <- R colnames(R) <- colnames(X) #res <- crossprod(R) #res R } new.name <- function(proposed,old.names) # finds a name based on proposed, that is not in old.names # if the proposed name is in old.names then ".xx" is added to it # where xx is a number chosen to ensure the a unique name { prop <- proposed k <- 0 while (sum(old.names==prop)) { prop<-paste(proposed,".",k,sep="") k <- k + 1 } prop } gammPQL <- function (fixed, random, family, data, correlation, weights, control, niter = 30, verbose = TRUE, mustart=NULL, etastart=NULL, ...) { ## service routine for `gamm' to do PQL fitting. Based on glmmPQL ## from the MASS library (Venables & Ripley). Because `gamm' already ## does some of the preliminary stuff that glmmPQL does, gammPQL can ## be simpler. It also deals with the possibility of the original ## data frame containing variables called `zz' `wts' or `invwt'. ## Modified 2019 to use standard GLM initialization to imporove convergence. off <- model.offset(data) if (is.null(off)) off <- 0 y <- model.response(data) ## NEW nobs <- nrow(data) ## NEW if (is.null(weights)) weights <- rep(1, nrow(data)) start <- NULL ## never used if (is.null(mustart)) { eval(family$initialize) } else { mukeep <- mustart eval(family$initialize) mustart <- mukeep } #eval(family$initialize) ## NEW wts <- weights #if (is.null(wts)) wts <- rep(1, nrow(data)) wts.name <- new.name("wts",names(data)) ## avoid overwriting what's already in `data' data[[wts.name]] <- wts # fit0 <- NULL ## keep checking tools happy ## initial fit (might be better replaced with `gam' call) # eval(parse(text=paste("fit0 <- glm(formula = fixed, family = family, data = data,", # "weights =",wts.name,",...)"))) # w <- fit0$prior.weights # eta <- fit0$linear.predictors fam <- family eta <- if (!is.null(etastart)) etastart else fam$linkfun(mustart) mu <- fam$linkinv(eta) w <- wts; # zz <- eta + fit0$residuals - off mu.eta.val <- fam$mu.eta(eta) zz <- eta + (y - mu)/mu.eta.val - off # wz <- fit0$weights wz <- w * mu.eta.val^2/fam$variance(mustart) ## find non clashing name for pseudodata and insert in formula zz.name <- new.name("zz",names(data)) eval(parse(text=paste("fixed[[2]] <- quote(",zz.name,")"))) data[[zz.name]] <- zz ## pseudodata to `data' ## find non-clashing name for inverse weights, and make ## varFixed formula using it... invwt.name <- new.name("invwt",names(data)) data[[invwt.name]] <- 1/wz w.formula <- as.formula(paste("~",invwt.name,sep="")) converged <- FALSE if (family$family %in% c("poisson","binomial")) { control$sigma <- 1 ## set scale parameter to 1 control$apVar <- FALSE ## not available } for (i in 1:niter) { if (verbose) message(gettextf("iteration %d", i)) fit <- lme(fixed=fixed,random=random,data=data,correlation=correlation, control=control,weights=varFixed(w.formula),method="ML",...) etaold <- eta eta <- fitted(fit) + off if (sum((eta - etaold)^2) < 1e-06 * sum(eta^2)) { converged <- TRUE break } mu <- fam$linkinv(eta) mu.eta.val <- fam$mu.eta(eta) ## get pseudodata and insert in `data' # data[[zz.name]] <- eta + (fit0$y - mu)/mu.eta.val - off data[[zz.name]] <- eta + (y - mu)/mu.eta.val - off wz <- w * mu.eta.val^2/fam$variance(mu) data[[invwt.name]] <- 1/wz } ## end i in 1:niter if (!converged) warning("gamm not converged, try increasing niterPQL") # fit$y <- fit0$y fit$y <- y fit$w <- w ## prior weights fit } ## gammPQL gamm <- function(formula,random=NULL,correlation=NULL,family=gaussian(),data=list(),weights=NULL, subset=NULL,na.action,knots=NULL,control=list(niterEM=0,optimMethod="L-BFGS-B",returnObject=TRUE), niterPQL=20,verbosePQL=TRUE,method="ML",drop.unused.levels=TRUE,mustart=NULL, etastart=NULL,...) # Routine to fit a GAMM to some data. Fixed and smooth terms are defined in the formula, but the wiggly # parts of the smooth terms are treated as random effects. The onesided formula random defines additional # random terms. correlation describes the correlation structure. This routine is basically an interface # between the basis constructors provided in mgcv and the gammPQL routine used to estimate the model. { if (inherits(family,"extended.family")) warning("family are not designed for use with gamm!") ## lmeControl turns sigma=NULL into sigma=0, but if you supply sigma=0 rejects it, ## which will break the standard handling of the control list. Following line fixes. ## but actually Martin M has now fixed lmeControl... ##if (!is.null(control$sigma)&&control$sigma==0) control$sigma <- NULL if (inherits(family,"extended.family")) warning("gamm is not designed to use extended families") control <- do.call("lmeControl",control) # check that random is a named list if (!is.null(random)) { if (is.list(random)) { r.names<-names(random) if (is.null(r.names)) stop("random argument must be a *named* list.") else if (sum(r.names=="")) stop("all elements of random list must be named") } else stop("gamm() can only handle random effects defined as named lists") random.vars<-c(unlist(lapply(random, function(x) all.vars(formula(x)))),r.names) } else random.vars<-NULL if (!is.null(correlation)) { cor.for<-attr(correlation,"formula") if (!is.null(cor.for)) cor.vars<-all.vars(cor.for) } else cor.vars<-NULL ## now establish whether weights is varFunc or not... wisvf <- try(inherits(weights,"varFunc"),silent=TRUE) if (inherits(wisvf,"try-error")) wisvf <- FALSE if (wisvf) { ## collect its variables if (inherits(weights,"varComb")) { ## actually a list of varFuncs vf.vars <- rep("",0) for (i in 1:length(weights)) { vf.vars <- c(vf.vars,all.vars(attr(weights[[i]],"formula"))) } vf.vars <- unique(vf.vars) } else { ## single varFunc vf.for<-attr(weights,"formula") if (!is.null(vf.for)) vf.vars<-all.vars(vf.for) } } else vf.vars <- NULL # create model frame..... gp <- interpret.gam(formula) # interpret the formula ##cl<-match.call() # call needed in gamm object for update to work mf <- match.call(expand.dots=FALSE) mf$formula <- gp$fake.formula if (wisvf) { mf$correlation <- mf$random <- mf$family <- mf$control <- mf$scale <- mf$knots <- mf$sp <- mf$weights <- mf$min.sp <- mf$H <- mf$gamma <- mf$fit <- mf$niterPQL <- mf$verbosePQL <- mf$G <- mf$method <- mf$... <- NULL } else { mf$correlation <- mf$random <- mf$family <- mf$control <- mf$scale <- mf$knots <- mf$sp <- mf$min.sp <- mf$H <- mf$gamma <- mf$fit <- mf$niterPQL <- mf$verbosePQL <- mf$G <- mf$method <- mf$... <- NULL } mf$drop.unused.levels <- drop.unused.levels mf[[1]] <- quote(stats::model.frame) ## as.name("model.frame") pmf <- mf gmf <- eval(mf, parent.frame()) # the model frame now contains all the data, for the gam part only gam.terms <- attr(gmf,"terms") # terms object for `gam' part of fit -- need this for prediction to work properly if (!wisvf) weights <- gmf[["(weights)"]] allvars <- c(cor.vars,random.vars,vf.vars) if (length(allvars)) { mf$formula <- as.formula(paste(paste(deparse(gp$fake.formula,backtick=TRUE),collapse=""), "+",paste(allvars,collapse="+"))) mf <- eval(mf, parent.frame()) # the model frame now contains *all* the data } else mf <- gmf rm(gmf) 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 <- all.vars1(gp$fake.formula[-2]) ## drop response here inp <- parse(text = paste("list(", paste(vars, collapse = ","),")")) 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 pmf$formula <- gp$pf pmf <- eval(pmf, parent.frame()) # pmf contains all data for parametric part pTerms <- attr(pmf,"terms") if (is.character(family)) family<-eval(parse(text=family)) if (is.function(family)) family <- family() if (is.null(family$family)) stop("family not recognized") # now call gamm.setup G <- gamm.setup(gp,pterms=pTerms, data=mf,knots=knots,parametric.only=FALSE,absorb.cons=TRUE) #G$pterms <- pTerms G$var.summary <- var.summary mf <- G$data n.sr <- length(G$random) # number of random smooths (i.e. s(...,fx=FALSE,...) terms) if (is.null(random)&&n.sr==0) stop("gamm models must have at least 1 smooth with unknown smoothing parameter or at least one other random effect") offset.name <- attr(mf,"names")[attr(attr(mf,"terms"),"offset")] yname <- new.name("y",names(mf)) eval(parse(text=paste("mf$",yname,"<-G$y",sep=""))) Xname <- new.name("X",names(mf)) eval(parse(text=paste("mf$",Xname,"<-G$X",sep=""))) fixed.formula <- paste(yname,"~",Xname,"-1") if (length(offset.name)) { fixed.formula <- paste(fixed.formula,"+",offset.name) } fixed.formula <- as.formula(fixed.formula) ## Add any explicit random effects to the smooth induced r.e.s rand <- G$random if (!is.null(random)) { r.m <- length(random) r.names <- c(names(rand),names(random)) for (i in 1:r.m) rand[[n.sr+i]]<-random[[i]] names(rand) <- r.names } ## need to modify the correlation structure formula, in order that any ## grouping factors for correlation get nested within at least the ## constructed dummy grouping factors. if (length(formula(correlation))) # then modify the correlation formula { # first get the existing grouping structure .... corGroup <- paste(names(rand),collapse="/") groupForm<-nlme::getGroupsFormula(correlation) if (!is.null(groupForm)) { groupFormNames <- all.vars(groupForm) exind <- groupFormNames %in% names(rand) groupFormNames <- groupFormNames[!exind] ## dumping duplicates if (length(groupFormNames)) corGroup <- paste(corGroup,paste(groupFormNames,collapse="/"),sep="/") } # now make a new formula for the correlation structure including these groups corForm <- as.formula(paste(deparse(nlme::getCovariateFormula(correlation)),"|",corGroup)) attr(correlation,"formula") <- corForm } ### Actually do fitting .... ret <- list() if (family$family=="gaussian"&&family$link=="identity"&& length(offset.name)==0) lme.used <- TRUE else lme.used <- FALSE if (lme.used&&!is.null(weights)&&!wisvf) lme.used <- FALSE if (lme.used) { ## following construction is a work-around for problem in nlme 3-1.52 eval(parse(text=paste("ret$lme<-lme(",deparse(fixed.formula), ",random=rand,data=strip.offset(mf),correlation=correlation,", "control=control,weights=weights,method=method)" ,sep="" ))) ## need to be able to work out full edf for following to work... # if (is.null(correlation)) { ## compute conditional aic precursor # dev <- sum(family$dev.resids(G$y,fitted(ret$lme),weights)) # ret$lme$aic <- family$aic(G$y,1,fitted(ret$lme),weights,dev) # } ##ret$lme<-lme(fixed.formula,random=rand,data=mf,correlation=correlation,control=control) } else { ## Again, construction is a work around for nlme 3-1.52 if (wisvf) stop("weights must be like glm weights for generalized case") if (verbosePQL) cat("\n Maximum number of PQL iterations: ",niterPQL,"\n") eval(parse(text=paste("ret$lme<-gammPQL(",deparse(fixed.formula), ",random=rand,data=strip.offset(mf),family=family,", "correlation=correlation,control=control,", "weights=weights,niter=niterPQL,verbose=verbosePQL,mustart=mustart,etastart=etastart,...)",sep=""))) G$y <- ret$lme$y ## makes sure that binomial response is returned as a vector! } ### .... fitting finished # now fake a gam object object <- list(model=mf,formula=formula,smooth=G$smooth,nsdf=G$nsdf,family=family, df.null=nrow(G$X),y=G$y,terms=gam.terms,pterms=G$pterms,xlevels=G$xlevels, contrasts=G$contrasts,assign=G$assign,na.action=attr(mf,"na.action"), cmX=G$cmX,var.summary=G$var.summary,scale.estimated=TRUE) pvars <- all.vars(delete.response(object$terms)) object$pred.formula <- if (length(pvars)>0) reformulate(pvars) else NULL ####################################################### ## Transform parameters back to the original space.... ####################################################### bf <- as.numeric(ret$lme$coefficients$fixed) # br <- as.numeric(unlist(ret$lme$coefficients$random)) ## Grouped random coefs are returned in matrices. Each row relates to one ## level of the grouping factor. So to get coefs in order, with all coefs ## for each grouping factor level contiguous, requires the following... br <- as.numeric(unlist(lapply(ret$lme$coefficients$random,t))) fs.present <- FALSE if (G$nsdf) p <- bf[1:G$nsdf] else p <- array(0,0) if (G$m>0) for (i in 1:G$m) { fx <- G$smooth[[i]]$fixed first <- G$smooth[[i]]$first.f.para;last <- G$smooth[[i]]$last.f.para if (first <=last) beta <- bf[first:last] else beta <- array(0,0) ## fixed coefs if (fx) p <- c(p, beta) else { ## not fixed so need to undo transform of random effects etc. ind <- G$smooth[[i]]$rind ##G$smooth[[i]]$first.r.para:G$smooth[[i]]$last.r.para if (!is.null(G$smooth[[i]]$fac)) { ## nested term, need to unpack coefs at each level of fac fs.present <- TRUE if (first<=last) stop("Nested smooths must be fully random") flev <- levels(G$smooth[[i]]$fac) for (j in 1:length(flev)) { b <- br[ind] b <- G$smooth[[i]]$trans.D*b if (!is.null(G$smooth[[i]]$trans.U)) b <- G$smooth[[i]]$trans.U%*%b ind <- ind + G$smooth[[i]]$rinc p <- c(p,b) } } else { ## single level b <- c(br[ind],beta) b <- G$smooth[[i]]$trans.D*b if (!is.null(G$smooth[[i]]$trans.U)) b <- G$smooth[[i]]$trans.U%*%b p <- c(p,b) } } } var.param <- coef(ret$lme$modelStruct$reStruct) n.v <- length(var.param) # k <- 1 spl <- list() if (G$m>0) for (i in 1:G$m) # var.param in reverse term order, but forward order within terms!! { ii <- G$pord[i] n.sp <- length(object$smooth[[ii]]$S) # number of s.p.s for this term if (n.sp>0) { if (inherits(object$smooth[[ii]],"tensor.smooth")) ## ... really mean pdTens used here... ## object$sp[k:(k+n.sp-1)] spl[[ii]] <- notExp2(var.param[(n.v-n.sp+1):n.v]) else ## object$sp[k:(k+n.sp-1)] spl[[ii]] <- 1/notExp2(var.param[n.v:(n.v-n.sp+1)]) } # k <- k + n.sp n.v <- n.v - n.sp } object$sp <- rep(0,0) if (length(spl)) for (i in 1:length(spl)) if (!is.null(spl[[i]])) object$sp <- c(object$sp,spl[[i]]) if (length(object$sp)==0) object$sp <- NULL object$coefficients <- p V <- extract.lme.cov2(ret$lme,mf,n.sr+1) # the data covariance matrix, excluding smooths ## obtain XVX and S.... first.para <- last.para <- rep(0,G$m) ## collect first and last para info relevant to expanded Xf if (fs.present) { ## First create expanded Xf... Xf <- G$Xf[,1:G$nsdf,drop=FALSE] if (G$m>0) for (i in 1:G$m) {# Accumulate the total model matrix ind <- object$smooth[[i]]$first.para:object$smooth[[i]]$last.para if (is.null(object$smooth[[i]]$fac)) { ## normal smooth first.para[i] <- ncol(Xf)+1 Xf <- cbind(Xf,G$Xf[,ind]) last.para[i] <- ncol(Xf) } else { ## smooth conditioned on multilevel factor. Expand Xf flev <- levels(object$smooth[[i]]$fac) first.para[i] <- ncol(Xf)+1 for (k in 1:length(flev)) { Xf <- cbind(Xf,G$Xf[,ind]*as.numeric(object$smooth[[i]]$fac==flev[k])) } last.para[i] <- ncol(Xf) } } object$R <- formXtViX(V,Xf) ## inefficient, if there are smooths conditioned on factors XVX <- crossprod(object$R) nxf <- ncol(Xf) } else { if (G$m>0) for (i in 1:G$m) { first.para[i] <- object$smooth[[i]]$first.para last.para[i] <- object$smooth[[i]]$last.para } object$R <- formXtViX(V,G$Xf) XVX <- crossprod(object$R) nxf <- ncol(G$Xf) } object$R <- object$R*ret$lme$sigma ## correction to what is required by summary.gam ## Now S... S <- matrix(0,nxf,nxf) ## penalty matrix first <- G$nsdf+1 k <- 1 if (G$m>0) for (i in 1:G$m) {# Accumulate the total penalty matrix if (is.null(object$smooth[[i]]$fac)) { ## simple regular smooth... ind <- first.para[i]:last.para[i] ns <-length(object$smooth[[i]]$S) if (ns) for (l in 1:ns) { S[ind,ind] <- S[ind,ind] + object$smooth[[i]]$S[[l]]*object$sp[k] k <- k+1 } } else { ## smooth conditioned on factor flev <- levels(object$smooth[[i]]$fac) ind <- first.para[i]:(first.para[i]+object$smooth[[i]]$n.para-1) ns <- length(object$smooth[[i]]$S) for (j in 1:length(flev)) { if (ns) for (l in 1:ns) { S[ind,ind] <- S[ind,ind] + object$smooth[[i]]$S[[l]]*object$sp[k] k <- k+1 } k <- k - ns ## same smoothing parameters repeated for each factor level ind <- ind + object$smooth[[i]]$n.para } k <- k + ns } } S <- S/ret$lme$sigma^2 # X'V^{-1}X divided by \sigma^2, so should S be ## now replace original first.para and last.para with expanded versions... if (G$m) for (i in 1:G$m) { object$smooth[[i]]$first.para <- first.para[i] object$smooth[[i]]$last.para <- last.para[i] } ## stable computation of coefficient covariance matrix... ev <- eigen(XVX+S,symmetric=TRUE) ind <- ev$values != 0 iv <- ev$values;iv[ind] <- 1/ev$values[ind] Vb <- ev$vectors%*%(iv*t(ev$vectors)) object$edf<-rowSums(Vb*t(XVX)) object$df.residual <- length(object$y) - sum(object$edf) #if (!is.null(ret$lme$aic)) { ## finish the conditional AIC (only happens if no correlation) # object$aic <- ret$lme$aic + sum(object$edf) ## requires edf for r.e. as well! # ret$lme$aic<- NULL #} object$sig2 <- ret$lme$sigma^2 if (lme.used) { object$method <- paste("lme.",method,sep="")} else { object$method <- "PQL"} if (!lme.used||method=="ML") Vb <- Vb*length(G$y)/(length(G$y)-G$nsdf) object$Vp <- Vb object$Ve <- Vb%*%XVX%*%Vb object$prior.weights <- weights class(object) <- "gam" ## If prediction parameterization differs from fit parameterization, transform now... ## (important for t2 smooths, where fit constraint is not good for component wise ## prediction s.e.s) if (!is.null(G$P)) { object$coefficients <- G$P %*% object$coefficients object$Vp <- G$P %*% object$Vp %*% t(G$P) object$Ve <- G$P %*% object$Ve %*% t(G$P) } object$linear.predictors <- predict.gam(object,type="link") object$fitted.values <- object$family$linkinv(object$linear.predictors) object$residuals <- residuals(ret$lme) #as.numeric(G$y) - object$fitted.values 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) { for (i in 1:n.smooth) { k <- 1 for (j in object$smooth[[i]]$first.para:object$smooth[[i]]$last.para) { term.names[j] <- paste(object$smooth[[i]]$label,".",as.character(k),sep="") k <- k+1 } } if (!is.null(object$sp)) names(object$sp) <- names(G$sp) } names(object$coefficients) <- term.names # note - won't work on matrices!! names(object$edf) <- term.names if (is.null(weights)) object$prior.weights <- object$y*0+1 else if (wisvf) object$prior.weights <- varWeights.dfo(ret$lme,mf)^2 else object$prior.weights <- ret$lme$w object$weights <- object$prior.weights if (!is.null(G$Xcentre)) object$Xcentre <- G$Xcentre ## column centering values ## set environments to global to avoid enormous saved object files environment(attr(object$model,"terms")) <- environment(object$terms) <- environment(object$pterms) <- environment(object$formula) <- .GlobalEnv if (!is.null(object$pred.formula)) environment(object$pred.formula) <- .GlobalEnv ret$gam <- object environment(attr(ret$lme$data,"terms")) <- environment(ret$lme$terms) <- .GlobalEnv if (!is.null(ret$lme$modelStruct$varStruct)) { environment(attr(ret$lme$modelStruct$varStruct,"formula")) <- .GlobalEnv } if (!is.null(ret$lme$modelStruct$corStruct)) { environment(attr(ret$lme$modelStruct$corStruct,"formula")) <- .GlobalEnv } class(ret) <- c("gamm","list") ret } ## end gamm test.gamm <- function(control=nlme::lmeControl(niterEM=3,tolerance=1e-11,msTol=1e-11)) ## this function is a response to repeated problems with nlme/R updates breaking ## the pdTens class. It tests for obvious breakages! { test1<-function(x,z,sx=0.3,sz=0.4) { x<-x*20 (pi**sx*sz)*(1.2*exp(-(x-0.2)^2/sx^2-(z-0.3)^2/sz^2)+ 0.8*exp(-(x-0.7)^2/sx^2-(z-0.8)^2/sz^2)) } compare <- function(b,b1,edf.tol=.001) { edf.diff <- abs(sum(b$edf)-sum(b1$edf)) fit.cor <- cor(fitted(b),fitted(b1)) if (fit.cor<.999) { cat("FAILED: fit.cor = ",fit.cor,"\n");return()} if (edf.diff>edf.tol) { cat("FAILED: edf.diff = ",edf.diff,"\n");return()} cat("PASSED \n") } n<-500 x<-runif(n)/20;z<-runif(n); f <- test1(x,z) y <- f + rnorm(n)*0.2 control$sigma <- NULL ## avoid failure on silly test cat("testing covariate scale invariance ... ") b <- gamm(y~te(x,z), control=control ) x1 <- x*100 b1 <- gamm(y~te(x1,z),control=control) res <- compare(b$gam,b1$gam) cat("testing invariance w.r.t. response ... ") y1 <- y*100 b1 <- gamm(y1~te(x,z),control=control) res <- compare(b$gam,b1$gam) cat("testing equivalence of te(x) and s(x) ... ") b2 <- gamm(y~te(x,k=10,bs="cr"),control=control) b1 <- gamm(y~s(x,bs="cr",k=10),control=control) res <- compare(b2$gam,b1$gam,edf.tol=.1) cat("testing equivalence of gam and gamm with same sp ... ") b1 <- gam(y~te(x,z),sp=b$gam$sp) res <- compare(b$gam,b1) if (FALSE) cat(res,x1,y1) ## fool codetools } mgcv/R/smooth.r0000755000176200001440000047523713502402064013124 0ustar liggesusers## R routines for the package mgcv (c) Simon Wood 2000-2019 ## This file is primarily concerned with defining classes of smoother, ## via constructor methods and prediction matrix methods. There are ## also wrappers for the constructors to automate constraint absorption, ## `by' variable handling and the summation convention used for general ## linear functional terms. SmoothCon, PredictMat and the generics are ## at the end of the file. ############################## ## First some useful utilities ############################## nat.param <- function(X,S,rank=NULL,type=0,tol=.Machine$double.eps^.8,unit.fnorm=TRUE) { ## X is an n by p model matrix. ## S is a p by p +ve semi definite penalty matrix, with the ## given rank. ## * type 0 reparameterization leaves ## the penalty matrix as a diagonal, ## * type 1 reduces it to the identity. ## * type 2 is not really natural. It simply converts the ## penalty to rank deficient identity, with some attempt to ## control the condition number sensibly. ## * type 3 is type 2, but constructed to force a constant vector ## to be the final null space basis function, if possible. ## type 2 is most efficient, but has highest condition. ## unit.fnorm == TRUE implies that the model matrix should be ## rescaled so that its penalized and unpenalized model matrices ## both have unit Frobenious norm. ## For natural param as in the book, type=0 and unit.fnorm=FALSE. ## test code: ## x <- runif(100) ## sm <- smoothCon(s(x,bs="cr"),data=data.frame(x=x),knots=NULL,absorb.cons=FALSE)[[1]] ## np <- nat.param(sm$X,sm$S[[1]],type=3) ## range(np$X-sm$X%*%np$P) if (type==2||type==3) { ## no need for QR step er <- eigen(S,symmetric=TRUE) if (is.null(rank)||rank<1||rank>ncol(S)) { rank <- sum(er$value>max(er$value)*tol) } null.exists <- rank < ncol(X) ## is there a null space, or is smooth full rank E <- rep(1,ncol(X));E[1:rank] <- sqrt(er$value[1:rank]) X <- X%*%er$vectors col.norm <- colSums(X^2) col.norm <- col.norm/E^2 ## col.norm[i] is now what norm of ith col will be, unless E modified... av.norm <- mean(col.norm[1:rank]) if (null.exists) for (i in (rank+1):ncol(X)) { E[i] <- sqrt(col.norm[i]/av.norm) } P <- t(t(er$vectors)/E) X <- t(t(X)/E) ## if type==3 re-do null space so that a constant vector is the ## final element of the null space basis, if possible... if (null.exists && type==3 && rank < ncol(X)-1) { ind <- (rank+1):ncol(X) rind <- ncol(X):(rank+1) Xn <- X[,ind,drop=FALSE] ## null basis n <- nrow(Xn) one <- rep(1,n) Xn <- Xn - one%*%(t(one)%*%Xn)/n um <- eigen(t(Xn)%*%Xn,symmetric=TRUE) ## use ind in next 2 lines to have const column last, ## rind to have it first (among null space cols) X[,rind] <- X[,ind,drop=FALSE]%*%um$vectors P[,rind] <- P[,ind,drop=FALSE]%*%(um$vectors) } if (unit.fnorm) { ## rescale so ||X||_f = 1 ind <- 1:rank scale <- 1/sqrt(mean(X[,ind]^2)) X[,ind] <- X[,ind]*scale;P[ind,] <- P[ind,]*scale if (null.exists) { ind <- (rank+1):ncol(X) scalef <- 1/sqrt(mean(X[,ind]^2)) X[,ind] <- X[,ind]*scalef;P[ind,] <- P[ind,]*scalef } } else scale <- 1 ## see end for return list defs return(list(X=X,D=rep(scale^2,rank),P=P,rank=rank,type=type)) ## type of reparameterization } qrx <- qr(X,tol=.Machine$double.eps^.8) R <- qr.R(qrx) RSR <- forwardsolve(t(R),t(forwardsolve(t(R),t(S)))) er <- eigen(RSR,symmetric=TRUE) if (is.null(rank)||rank<1||rank>ncol(S)) { rank <- sum(er$value>max(er$value)*tol) } null.exists <- rank < ncol(X) ## is there a null space, or is smooth full rank ## D contains +ve elements of diagonal penalty ## (zeroes at the end)... D <- er$values[1:rank] ## X is the model matrix... X <- qr.Q(qrx,complete=FALSE)%*%er$vectors ## P transforms parameters in this parameterization back to ## original parameters... P <- backsolve(R,er$vectors) if (type==1) { ## penalty should be identity... E <- c(sqrt(D),rep(1,ncol(X)-length(D))) P <- t(t(P)/E) X <- t(t(X)/E) ## X%*%diag(1/E) D <- D*0+1 } if (unit.fnorm) { ## rescale so ||X||_f = 1 ind <- 1:rank scale <- 1/sqrt(mean(X[,ind]^2)) X[,ind] <- X[,ind]*scale;P[,ind] <- P[,ind]*scale D <- D * scale^2 if (null.exists) { ind <- (rank+1):ncol(X) scalef <- 1/sqrt(mean(X[,ind]^2)) X[,ind] <- X[,ind]*scalef;P[,ind] <- P[,ind]*scalef } } ## unpenalized always at the end... list(X=X, ## transformed model matrix D=D, ## +ve elements on leading diagonal of penalty P=P, ## transforms parameter estimates back to original parameterization ## postmultiplying original X by P gives reparam version rank=rank, ## penalty rank (number of penalized parameters) type=type) ## type of reparameterization } ## end nat.param mono.con<-function(x,up=TRUE,lower=NA,upper=NA) # Takes the knot sequence x for a cubic regression spline and returns a list with # 2 elements matrix A and array b, such that if p is the vector of coeffs of the # spline, then Ap>b ensures monotonicity of the spline. # up=TRUE gives monotonic increase, up=FALSE gives decrease. # lower and upper are the optional lower and upper bounds on the spline. { if (is.na(lower)) {lo<-0;lower<-0;} else lo<-1 if (is.na(upper)) {hi<-0;upper<-0;} else hi<-1 if (up) inc<-1 else inc<-0 control<-4*inc+2*lo+hi n<-length(x) if (n<4) stop("At least three knots required in call to mono.con.") A<-matrix(0,4*(n-1)+lo+hi,n) b<-array(0,4*(n-1)+lo+hi) if (lo*hi==1&&lower>=upper) stop("lower bound >= upper bound in call to mono.con()") oo<-.C(C_RMonoCon,as.double(A),as.double(b),as.double(x),as.integer(control),as.double(lower), as.double(upper),as.integer(n)) A<-matrix(oo[[1]],dim(A)[1],dim(A)[2]) b<-array(oo[[2]],dim(A)[1]) list(A=A,b=b) } ## end mono.con uniquecombs <- function(x,ordered=FALSE) { ## takes matrix x and counts up unique rows ## `unique' now does this in R if (is.null(x)) stop("x is null") if (is.null(nrow(x))||is.null(ncol(x))) x <- data.frame(x) recheck <- FALSE if (inherits(x,"data.frame")) { xoo <- xo <- x ## reset character, logical and factor to numeric, to guarantee that text versions of labels ## are unique iff rows are unique (otherwise labels containing "*" could in principle ## fool it). is.char <- rep(FALSE,length(x)) for (i in 1:length(x)) { if (is.character(xo[[i]])) { is.char[i] <- TRUE xo[[i]] <- as.factor(xo[[i]]) } if (is.factor(xo[[i]])||is.logical(xo[[i]])) x[[i]] <- as.numeric(xo[[i]]) if (!is.numeric(x[[i]])) recheck <- TRUE ## input contains unknown type cols } #x <- data.matrix(xo) ## ensure all data are numeric } else xo <- NULL if (ncol(x)==1) { ## faster to use R xu <- if (ordered) sort(unique(x[,1])) else unique(x[,1]) ind <- match(x[,1],xu) if (is.null(xo)) x <- matrix(xu,ncol=1,nrow=length(xu)) else { x <- data.frame(xu) names(x) <- names(xo) } } else { ## no R equivalent that directly yields indices if (ordered) { chloc <- Sys.getlocale("LC_CTYPE") Sys.setlocale("LC_CTYPE","C") } ## txt <- paste("paste0(",paste("x[,",1:ncol(x),"]",sep="",collapse=","),")",sep="") ## ... this can produce duplicate labels e.g. x[,1] = c(1,11), x[,2] = c(12,2)... ## solution is to insert separator not present in representation of a number (any ## factor codes are already converted to numeric by data.matrix call above.) txt <- paste("paste0(",paste("x[,",1:ncol(x),"]",sep="",collapse=",\"*\","),")",sep="") xt <- eval(parse(text=txt)) ## text representation of rows dup <- duplicated(xt) ## identify duplicates xtu <- xt[!dup] ## unique text rows x <- x[!dup,] ## unique rows in original format #ordered <- FALSE if (ordered) { ## return unique in same order regardless of entry order ## ordering of character based labels is locale dependent ## so that e.g. running the same code interactively and via ## R CMD check can give different answers. coloc <- Sys.getlocale("LC_COLLATE") Sys.setlocale("LC_COLLATE","C") ii <- order(xtu) Sys.setlocale("LC_COLLATE",coloc) Sys.setlocale("LC_CTYPE",chloc) xtu <- xtu[ii] x <- x[ii,] } ind <- match(xt,xtu) ## index each row to the unique duplicate deleted set } if (!is.null(xo)) { ## original was a data.frame x <- as.data.frame(x) names(x) <- names(xo) for (i in 1:ncol(xo)) { if (is.factor(xo[,i])) { ## may need to reset factors to factors xoi <- levels(xo[,i]) x[,i] <- if (is.ordered(xo[,i])) ordered(x[,i],levels=1:length(xoi),labels=xoi) else factor(x[,i],levels=1:length(xoi),labels=xoi) contrasts(x[,i]) <- contrasts(xo[,i]) } if (is.char[i]) x[,i] <- as.character(x[,i]) if (is.logical(xo[,i])) x[,i] <- as.logical(x[,i]) } } if (recheck) { if (all.equal(xoo,x[ind,],check.attributes=FALSE)!=TRUE) warning("uniquecombs has not worked properly") } attr(x,"index") <- ind x } ## uniquecombs uniquecombs0 <- function(x,ordered=FALSE) { ## takes matrix x and counts up unique rows ## `unique' now does this in R if (is.null(x)) stop("x is null") if (is.null(nrow(x))||is.null(ncol(x))) x <- data.frame(x) if (inherits(x,"data.frame")) { xo <- x x <- data.matrix(xo) ## ensure all data are numeric } else xo <- NULL if (ncol(x)==1) { ## faster to use R xu <- if (ordered) sort(unique(x)) else unique(x) ind <- match(as.numeric(x),xu) x <- matrix(xu,ncol=1,nrow=length(xu)) } else { ## no R equivalent that directly yields indices if (ordered) { chloc <- Sys.getlocale("LC_CTYPE") Sys.setlocale("LC_CTYPE","C") } ## txt <- paste("paste0(",paste("x[,",1:ncol(x),"]",sep="",collapse=","),")",sep="") ## ... this can produce duplicate labels e.g. x[,1] = c(1,11), x[,2] = c(12,2)... ## solution is to insert separator not present in representation of a number (any ## factor codes are already converted to numeric by data.matrix call above.) txt <- paste("paste0(",paste("x[,",1:ncol(x),"]",sep="",collapse=",\":\","),")",sep="") xt <- eval(parse(text=txt)) ## text representation of rows dup <- duplicated(xt) ## identify duplicates xtu <- xt[!dup] ## unique text rows x <- x[!dup,] ## unique rows in original format #ordered <- FALSE if (ordered) { ## return unique in same order regardless of entry order ## ordering of character based labels is locale dependent ## so that e.g. running the same code interactively and via ## R CMD check can give different answers. coloc <- Sys.getlocale("LC_COLLATE") Sys.setlocale("LC_COLLATE","C") ii <- order(xtu) Sys.setlocale("LC_COLLATE",coloc) Sys.setlocale("LC_CTYPE",chloc) xtu <- xtu[ii] x <- x[ii,] } ind <- match(xt,xtu) ## index each row to the unique duplicate deleted set } if (!is.null(xo)) { ## original was a data.frame x <- as.data.frame(x) names(x) <- names(xo) for (i in 1:ncol(xo)) if (is.factor(xo[,i])) { ## may need to reset factors to factors xoi <- levels(xo[,i]) x[,i] <- if (is.ordered(xo[,i])) ordered(x[,i],levels=1:length(xoi),labels=xoi) else factor(x[,i],levels=1:length(xoi),labels=xoi) contrasts(x[,i]) <- contrasts(xo[,i]) } } attr(x,"index") <- ind x } ## uniquecombs0 cSplineDes <- function (x, knots, ord = 4,derivs=0) { ## cyclic version of spline design... ##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 <- splines::splineDesign(knots,x,ord,outer.ok=TRUE,derivs=derivs) x[ind] <- x[ind] - max(knots) + k1 if (sum(ind)) { ## wrapping part... X2 <- splines::splineDesign(knots,x[ind],ord,outer.ok=TRUE,derivs=derivs) X1[ind,] <- X1[ind,] + X2 } X1 ## final model matrix } ## cSplineDes get.var <- function(txt,data,vecMat = TRUE) # txt contains text that may be a variable name and may be an expression # for creating a variable. get.var first tries data[[txt]] and if that # fails tries evaluating txt within data (only). Routine returns NULL # on failure, or if result is not numeric or a factor. # matrices are coerced to vectors, which facilitates matrix arguments # to smooths. { x <- data[[txt]] if (is.null(x)) { x <- try(eval(parse(text=txt),data,enclos=NULL),silent=TRUE) if (inherits(x,"try-error")) x <- NULL } if (!is.numeric(x)&&!is.factor(x)) x <- NULL if (is.matrix(x)) { if (ncol(x)==1) { x <- as.numeric(x) ismat <- FALSE } else ismat <- TRUE } else ismat <- FALSE if (vecMat&&is.matrix(x)) x <- x[1:prod(dim(x))] ## modified from x <- as.numeric(x) to allow factors if (ismat) attr(x,"matrix") <- TRUE x } ## get.var ################################################ ## functions for use in `gam(m)' formulae ...... ################################################ ti <- function(..., k=NA,bs="cr",m=NA,d=NA,by=NA,fx=FALSE,np=TRUE,xt=NULL,id=NULL,sp=NULL,mc=NULL,pc=NULL) { ## function to use in gam formula to specify a te type tensor product interaction term ## ti(x) + ti(y) + ti(x,y) is *much* preferable to te(x) + te(y) + te(x,y), as ti(x,y) ## automatically excludes ti(x) + ti(y). Uses general fact about interactions that ## if identifiability constraints are applied to main effects, then row tensor product ## of main effects gives identifiable interaction... ## mc allows selection of which marginals to apply constraints to. Default is all. by.var <- deparse(substitute(by),backtick=TRUE) #getting the name of the by variable object <- te(...,k=k,bs=bs,m=m,d=d,fx=fx,np=np,xt=xt,id=id,sp=sp,pc=pc) object$inter <- TRUE object$by <- by.var object$mc <- mc substr(object$label,2,2) <- "i" object } ## ti te <- function(..., k=NA,bs="cr",m=NA,d=NA,by=NA,fx=FALSE,np=TRUE,xt=NULL,id=NULL,sp=NULL,pc=NULL) # function for use in gam formulae to specify a tensor product smooth term. # e.g. te(x0,x1,x2,k=c(5,4,4),bs=c("tp","cr","cr"),m=c(1,1,2),by=x3) specifies a rank 80 tensor # product spline. The first basis is rank 5, t.p.r.s. basis penalty order 1, and the next 2 bases # are rank 4 cubic regression splines with m ignored. # k, bs,d and fx can be supplied as single numbers or arrays with an element for each basis. # m can be a single number, and array with one element for each basis, or a list, with an # array for each basis # Returns a list consisting of: # * margin - a list of smooth.spec objects specifying the marginal bases # * term - array of covariate names # * by - the by variable name # * fx - array indicating which margins should be treated as fixed (i.e unpenalized). # * label - label for this term { vars <- as.list(substitute(list(...)))[-1] # gets terms to be smoothed without evaluation dim <- length(vars) # dimension of smoother by.var <- deparse(substitute(by),backtick=TRUE) #getting the name of the by variable term <- deparse(vars[[1]],backtick=TRUE) # first covariate if (dim>1) # then deal with further covariates for (i in 2:dim) term[i]<-deparse(vars[[i]],backtick=TRUE) for (i in 1:dim) term[i] <- attr(terms(reformulate(term[i])),"term.labels") # term now contains the names of the covariates for this model term # check d - the number of covariates per basis if (sum(is.na(d))||is.null(d)) { n.bases<-dim;d<-rep(1,dim)} # one basis for each dimension else # array d supplied, the dimension of each term in the tensor product { d<-round(d) ok<-TRUE if (sum(d<=0)) ok<-FALSE if (sum(d)!=dim) ok<-FALSE if (ok) n.bases<-length(d) else { warning("something wrong with argument d.") n.bases<-dim;d<-rep(1,dim) } } # now evaluate k if (sum(is.na(k))||is.null(k)) k<-5^d else { k<-round(k);ok<-TRUE if (sum(k<3)) { ok<-FALSE;warning("one or more supplied k too small - reset to default")} if (length(k)==1&&ok) k<-rep(k,n.bases) else if (length(k)!=n.bases) ok<-FALSE if (!ok) k<-5^d } # evaluate fx if (sum(is.na(fx))||is.null(fx)) fx<-rep(FALSE,n.bases) else if (length(fx)==1) fx<-rep(fx,n.bases) else if (length(fx)!=n.bases) { warning("dimension of fx is wrong") fx<-rep(FALSE,n.bases) } # deal with `xt' extras list xtra <- list() if (is.null(xt)||length(xt)==1) for (i in 1:n.bases) xtra[[i]] <- xt else if (length(xt)==n.bases) xtra <- xt else stop("xt argument is faulty.") # now check the basis types if (length(bs)==1) bs<-rep(bs,n.bases) if (length(bs)!=n.bases) {warning("bs wrong length and ignored.");bs<-rep("cr",n.bases)} bs[d>1&(bs=="cr"|bs=="cs"|bs=="ps"|bs=="cp")]<-"tp" # finally the spline/penalty orders if (!is.list(m)&&length(m)==1) m <- rep(m,n.bases) if (length(m)!=n.bases) { warning("m wrong length and ignored."); m <- rep(0,n.bases) } if (!is.list(m)) m[m<0] <- 0 ## Duchon splines can have -ve elements in a vector m # check for repeated variables in function argument list if (length(unique(term))!=dim) stop("Repeated variables as arguments of a smooth are not permitted") # Now construct smooth.spec objects for the margins j <- 1 # counter for terms margin <- list() for (i in 1:n.bases) { j1<-j+d[i]-1 if (is.null(xt)) xt1 <- NULL else xt1 <- xtra[[i]] ## ignore codetools stxt<-"s(" for (l in j:j1) stxt<-paste(stxt,term[l],",",sep="") stxt<-paste(stxt,"k=",deparse(k[i],backtick=TRUE),",bs=",deparse(bs[i],backtick=TRUE), ",m=",deparse(m[[i]],backtick=TRUE),",xt=xt1", ")") margin[[i]]<- eval(parse(text=stxt)) # NOTE: fx and by not dealt with here! j<-j1+1 } # assemble term.label #if (mp) mp <- TRUE else mp <- FALSE if (np) np <- TRUE else np <- FALSE full.call<-paste("te(",term[1],sep="") if (dim>1) for (i in 2:dim) full.call<-paste(full.call,",",term[i],sep="") label<-paste(full.call,")",sep="") # label for parameters of this term if (!is.null(id)) { if (length(id)>1) { id <- id[1] warning("only first element of `id' used") } id <- as.character(id) } ret<-list(margin=margin,term=term,by=by.var,fx=fx,label=label,dim=dim,#mp=mp, np=np,id=id,sp=sp,inter=FALSE) if (!is.null(pc)) { if (length(pc)1) # then deal with further covariates for (i in 2:dim) { term[i]<-deparse(vars[[i]],backtick=TRUE) } for (i in 1:dim) term[i] <- attr(terms(reformulate(term[i])),"term.labels") # term now contains the names of the covariates for this model term # check d - the number of covariates per basis if (sum(is.na(d))||is.null(d)) { n.bases<-dim;d<-rep(1,dim)} # one basis for each dimension else # array d supplied, the dimension of each term in the tensor product { d<-round(d) ok<-TRUE if (sum(d<=0)) ok<-FALSE if (sum(d)!=dim) ok<-FALSE if (ok) n.bases<-length(d) else { warning("something wrong with argument d.") n.bases<-dim;d<-rep(1,dim) } } # now evaluate k if (sum(is.na(k))||is.null(k)) k<-5^d else { k<-round(k);ok<-TRUE if (sum(k<3)) { ok<-FALSE;warning("one or more supplied k too small - reset to default")} if (length(k)==1&&ok) k<-rep(k,n.bases) else if (length(k)!=n.bases) ok<-FALSE if (!ok) k<-5^d } fx <- FALSE # deal with `xt' extras list xtra <- list() if (is.null(xt)||length(xt)==1) for (i in 1:n.bases) xtra[[i]] <- xt else if (length(xt)==n.bases) xtra <- xt else stop("xt argument is faulty.") # now check the basis types if (length(bs)==1) bs<-rep(bs,n.bases) if (length(bs)!=n.bases) {warning("bs wrong length and ignored.");bs<-rep("cr",n.bases)} bs[d>1&(bs=="cr"|bs=="cs"|bs=="ps"|bs=="cp")]<-"tp" # finally the spline/penalty orders if (!is.list(m)&&length(m)==1) m <- rep(m,n.bases) if (length(m)!=n.bases) { warning("m wrong length and ignored."); m <- rep(0,n.bases) } if (!is.list(m)) m[m<0] <- 0 ## Duchon splines can have -ve elements in a vector m # check for repeated variables in function argument list if (length(unique(term))!=dim) stop("Repeated variables as arguments of a smooth are not permitted") # Now construct smooth.spec objects for the margins j<-1 # counter for terms margin<-list() for (i in 1:n.bases) { j1<-j+d[i]-1 if (is.null(xt)) xt1 <- NULL else xt1 <- xtra[[i]] ## ignore codetools stxt<-"s(" for (l in j:j1) stxt<-paste(stxt,term[l],",",sep="") stxt<-paste(stxt,"k=",deparse(k[i],backtick=TRUE),",bs=",deparse(bs[i],backtick=TRUE), ",m=",deparse(m[[i]],backtick=TRUE),",xt=xt1", ")") margin[[i]]<- eval(parse(text=stxt)) # NOTE: fx and by not dealt with here! j<-j1+1 } # check ord argument if (!is.null(ord)) { if (sum(ord%in%0:n.bases)==0) { ord <- NULL warning("ord is wrong. reset to NULL.") } if (sum(ord<0)>0||sum(ord>n.bases)>0) warning("ord contains out of range orders (which will be ignored)") } # assemble term.label full.call<-paste("t2(",term[1],sep="") if (dim>1) for (i in 2:dim) full.call<-paste(full.call,",",term[i],sep="") label<-paste(full.call,")",sep="") # label for parameters of this term if (!is.null(id)) { if (length(id)>1) { id <- id[1] warning("only first element of `id' used") } id <- as.character(id) } full <- as.logical(full) if (is.na(full)) full <- FALSE ret<-list(margin=margin,term=term,by=by.var,fx=fx,label=label,dim=dim, id=id,sp=sp,full=full,ord=ord) if (!is.null(pc)) { if (length(pc)1) # then deal with further covariates for (i in 2:d) { term[i]<-deparse(vars[[i]],backtick=TRUE,width.cutoff=500) if (term[i]==".") stop("s(.) not yet supported.") } for (i in 1:d) term[i] <- attr(terms(reformulate(term[i])),"term.labels") # term now contains the names of the covariates for this model term # now evaluate all the other k.new <- round(k) # in case user has supplied non-integer basis dimension if (all.equal(k.new,k)!=TRUE) {warning("argument k of s() should be integer and has been rounded")} k <- k.new # check for repeated variables in function argument list if (length(unique(term))!=d) stop("Repeated variables as arguments of a smooth are not permitted") # assemble label for term full.call<-paste("s(",term[1],sep="") if (d>1) for (i in 2:d) full.call<-paste(full.call,",",term[i],sep="") label<-paste(full.call,")",sep="") # used for labelling parameters if (!is.null(id)) { if (length(id)>1) { id <- id[1] warning("only first element of `id' used") } id <- as.character(id) } ret <- list(term=term,bs.dim=k,fixed=fx,dim=d,p.order=m,by=by.var,label=label,xt=xt, id=id,sp=sp) if (!is.null(pc)) { if (length(pc)1) for (i in (m-1):1) { X0 <- X1;X1 <- matrix(0,n,0) for (j in 1:ncol(X[[i]])) X1 <- cbind(X1,X[[i]][,j]*X0) } X1 } ## end tensor.prod.model.matrix1 tensor.prod.model.matrix <- function(X) { # X is a list of model matrices, from which a tensor product model matrix is to be produced. # e.g. ith row is basically X[[1]][i,]%x%X[[2]][i,]%x%X[[3]][i,], but this routine works # column-wise, for efficiency, and does work in compiled code. m <- length(X) ## number to row tensor product d <- unlist(lapply(X,ncol)) ## dimensions of each X n <- nrow(X[[1]]) ## columns in each X X <- as.numeric(unlist(X)) ## append X[[i]]s columnwise T <- numeric(n*prod(d)) ## storage for result .Call(C_mgcv_tmm,X,T,d,m,n) ## produce product ## Give T attributes of matrix. Note that initializing T as a matrix ## requires more time than forming the row tensor product itself (R 3.0.1) attr(T,"dim") <- c(n,prod(d)) class(T) <- "matrix" T } ## end tensor.prod.model.matrix tensor.prod.penalties <- function(S) # Given a list S of penalty matrices for the marginal bases of a tensor product smoother # this routine produces the resulting penalties for the tensor product basis. # e.g. if S_1, S_2 and S_3 are marginal penalties and I_1, I_2, I_3 are identity matrices # of the same dimensions then the tensor product penalties are: # S_1 %x% I_2 %x% I_3, I_1 %x% S_2 %x% I_3 and I_1 %*% I_2 %*% S_3 # Note that the penalty list must be in the same order as the model matrix list supplied # to tensor.prod.model() when using these together. { m <- length(S) I <- list(); for (i in 1:m) { n <- ncol(S[[i]]) I[[i]] <- diag(n) } TS <- list() if (m==1) TS[[1]] <- S[[1]] else for (i in 1:m) { if (i==1) M0 <- S[[1]] else M0 <- I[[1]] for (j in 2:m) { if (i==j) M1 <- S[[i]] else M1 <- I[[j]] M0<-M0 %x% M1 } TS[[i]] <- if (ncol(M0)==nrow(M0)) (M0+t(M0))/2 else M0 # ensure exactly symmetric } TS }## end tensor.prod.penalties smooth.construct.tensor.smooth.spec <- function(object,data,knots) { ## the constructor for a tensor product basis object inter <- object$inter ## signal generation of a pure interaction m <- length(object$margin) # number of marginal bases if (inter) { ## interaction term so at least some marginals subject to constraint object$mc <- if (is.null(object$mc)) rep(TRUE,m) else as.logical(object$mc) ## which marginals to constrain object$sparse.cons <- if (is.null(object$sparse.cons)) rep(0,m) else object$sparse.cons } else { object$mc <- rep(FALSE,m) ## all marginals unconstrained } Xm <- list();Sm<-list();nr<-r<-d<-array(0,m) C <- NULL object$plot.me <- TRUE mono <- rep(FALSE,m) ## indicator for monotonic parameteriztion margins for (i in 1:m) { if (!is.null(object$margin[[i]]$mono)&&object$margin[[i]]$mono!=0) mono[i] <- TRUE knt <- dat <- list() term <- object$margin[[i]]$term for (j in 1:length(term)) { dat[[term[j]]] <- data[[term[j]]] knt[[term[j]]] <- knots[[term[j]]] } object$margin[[i]] <- if (object$mc[i]) smoothCon(object$margin[[i]],dat,knt,absorb.cons=TRUE,n=length(dat[[1]]), sparse.cons=object$sparse.cons[i])[[1]] else smooth.construct(object$margin[[i]],dat,knt) Xm[[i]] <- object$margin[[i]]$X if (!is.null(object$margin[[i]]$te.ok)) { if (object$margin[[i]]$te.ok == 0) stop("attempt to use unsuitable marginal smooth class") if (object$margin[[i]]$te.ok == 2) object$plot.me <- FALSE ## margin has declared itself unplottable in a te term } if (length(object$margin[[i]]$S)>1) stop("Sorry, tensor products of smooths with multiple penalties are not supported.") Sm[[i]] <- object$margin[[i]]$S[[1]] d[i] <- nrow(Sm[[i]]) r[i] <- object$margin[[i]]$rank nr[i] <- object$margin[[i]]$null.space.dim if (!inter&&!is.null(object$margin[[i]]$C)&&nrow(object$margin[[i]]$C)==0) C <- matrix(0,0,0) ## no centering constraint needed } ## Re-parameterization currently breaks monotonicity constraints ## so turn it off. An alternative would be to shift the marginal ## basis functions to force non-negativity. if (sum(mono)) { object$np <- FALSE ## need the re-parameterization indicator for the whole term, ## by combination of those for single terms. km <- which(mono) g <- list(); for (i in 1:length(km)) g[[i]] <- object$margin[[km[i]]]$g.index for (i in 1:length(object$margin)) { dx <- ncol(object$margin[[i]]$X) for (j in length(km)) if (i!=km[j]) g[[j]] <- if (i > km[j]) rep(g[[j]],each=dx) else rep(g[[j]],dx) } object$g.index <- as.logical(rowSums(matrix(unlist(g),length(g[[1]]),length(g)))) } XP <- list() if (object$np) for (i in 1:m) { # reparameterize if (object$margin[[i]]$dim==1) { # only do classes not already optimal (or otherwise excluded) if (is.null(object$margin[[i]]$noterp)) { ## apply repara x <- get.var(object$margin[[i]]$term,data) np <- ncol(object$margin[[i]]$X) ## number of params ## note: to avoid extrapolating wiggliness measure ## must include extremes as eval points knt <- if(is.factor(x)) { unique(x) } else { seq(min(x), max(x), length=np) } pd <- data.frame(knt) names(pd) <- object$margin[[i]]$term sv <- if (object$mc[i]) svd(PredictMat(object$margin[[i]],pd)) else svd(Predict.matrix(object$margin[[i]],pd)) if (sv$d[np]/sv$d[1]<.Machine$double.eps^.66) { ## condition number rather high XP[[i]] <- NULL warning("reparameterization unstable for margin: not done") } else { XP[[i]] <- sv$v%*%(t(sv$u)/sv$d) object$margin[[i]]$X <- Xm[[i]] <- Xm[[i]]%*%XP[[i]] Sm[[i]] <- t(XP[[i]])%*%Sm[[i]]%*%XP[[i]] } } else XP[[i]] <- NULL } else XP[[i]] <- NULL } # scale `nicely' - mostly to avoid problems with lme ... for (i in 1:m) Sm[[i]] <- Sm[[i]]/eigen(Sm[[i]],symmetric=TRUE,only.values=TRUE)$values[1] max.rank <- prod(d) r <- max.rank*r/d # penalty ranks X <- tensor.prod.model.matrix(Xm) # if (object$mp) { # multiple penalties S <- tensor.prod.penalties(Sm) for (i in m:1) if (object$fx[i]) { S[[i]] <- NULL # remove penalties for un-penalized margins r <- r[-i] # remove corresponding rank from list } # } else { # single penalty # warning("single penalty tensor product smooths are deprecated and likely to be removed soon") # S <- Sm[[1]];r <- object$margin[[i]]$rank # if (m>1) for (i in 2:m) # { S <- S%x%Sm[[i]] # r <- r*object$margin[[i]]$rank # } # if (sum(object$fx)==m) # { S <- list();object$fixed=TRUE } else # { S <-list(S);object$fixed=FALSE } # nr <- max.rank-r # object$bs.dim <- max.rank # } if (!is.null(object$margin[[1]]$xt$dropu)&&object$margin[[1]]$xt$dropu) { ind <- which(colSums(abs(X))!=0) X <- X[,ind] if (!is.null(object$g.index)) object$g.index <- object$g.index[ind] #for (i in 1:length(S)) { ## next line is equivalent to setting coefs for deleted to zero! #S[[i]] <- S[[i]][ind,ind] #} ## Instead we need to drop the differences involving deleted coefs for (i in 1:m) { if (is.null(object$margin[[i]]$D)) stop("basis not usable with reduced te") Sm[[i]] <- object$margin[[i]]$D ## differences } S <- tensor.prod.penalties(Sm) ## tensor prod difference penalties ## drop rows corresponding to differences that involve a dropped ## basis function, and crossproduct... for (i in 1:m) { D <- S[[i]][rowSums(S[[i]][,-ind,drop=FALSE])==0,ind] r[i] <- nrow(D) ## penalty rank S[[i]] <- crossprod(D) } object$udrop <- ind ## rank r ?? } object$X <- X;object$S <- S; if (inter) object$C <- matrix(0,0,0) else object$C <- C ## really just in case a marginal has implied that no cons are needed object$df <- ncol(X) object$null.space.dim <- prod(nr) # penalty null space rank object$rank <- r object$XP <- XP class(object)<-"tensor.smooth" object } ## end smooth.construct.tensor.smooth.spec Predict.matrix.tensor.smooth <- function(object,data) ## the prediction method for a tensor product smooth { m <- length(object$margin) X <- list() for (i in 1:m) { term <- object$margin[[i]]$term dat <- list() for (j in 1:length(term)) dat[[term[j]]] <- data[[term[j]]] X[[i]] <- if (object$mc[i]) PredictMat(object$margin[[i]],dat,n=length(dat[[1]])) else Predict.matrix(object$margin[[i]],dat) } mxp <- length(object$XP) if (mxp>0) for (i in 1:mxp) if (!is.null(object$XP[[i]])) X[[i]] <- X[[i]]%*%object$XP[[i]] T <- tensor.prod.model.matrix(X) if (is.null(object$udrop)) T else T[,object$udrop] }## end Predict.matrix.tensor.smooth ######################################################################### ## Type 2 tensor product methods start here - separate identity penalties ######################################################################### t2.model.matrix <- function(Xm,rank,full=TRUE,ord=NULL) { ## Xm is a list of marginal model matrices. ## The first rank[i] columns of Xm[[i]] are penalized, ## by a ridge penalty, the remainder are unpenalized. ## this routine constructs a tensor product model matrix, ## subject to a sequence of non-overlapping ridge penalties. ## If full is TRUE then the result is completely invariant, ## as each column of each null space is treated separately in ## the construction. Otherwise there is an element of arbitrariness ## in the invariance, as it depends on scaling of the null space ## columns. ## ord is the list of term orders to include. NULL indicates all ## terms are to be retained. Zi <- Xm[[1]][,1:rank[1],drop=FALSE] ## range space basis for first margin X2 <- list(Zi) order <- 1 ## record order of component (number of range space components) lab2 <- "r" ## list of term labels "r" denotes range space null.exists <- rank[1] < ncol(Xm[[1]]) ## does null exist for margin 1 no.null <- FALSE if (full) pen2 <- TRUE if (null.exists) { Xi <- Xm[[1]][,(rank[1]+1):ncol(Xm[[1]]),drop=FALSE] ## null space basis margin 1 if (full) { pen2[2] <- FALSE colnames(Xi) <- as.character(1:ncol(Xi)) } X2[[2]] <- Xi ## working model matrix component list lab2[2]<- "n" ## "n" is null space order[2] <- 0 } else no.null <- TRUE ## tensor product will have *no* null space... n.m <- length(Xm) ## number of margins X1 <- list() n <- nrow(Zi) if (n.m>1) for (i in 2:n.m) { ## work through margins... Zi <- Xm[[i]][,1:rank[i],drop=FALSE] ## margin i range space null.exists <- rank[i] < ncol(Xm[[i]]) ## does null exist for margin i if (null.exists) { Xi <- Xm[[i]][,(rank[i]+1):ncol(Xm[[i]]),drop=FALSE] ## margin i null space if (full) colnames(Xi) <- as.character(1:ncol(Xi)) } else no.null <- TRUE ## tensor product will have *no* null space... X1 <- X2 if (full) pen1 <- pen2 lab1 <- lab2 ## labels order1 <- order k <- 1 for (ii in 1:length(X1)) { ## form products with Zi if (!full || pen1[ii]) { ## X1[[ii]] is penalized and treated as a whole A <- matrix(0,n,0) for (j in 1:ncol(X1[[ii]])) A <- cbind(A,X1[[ii]][,j]*Zi) X2[[k]] <- A if (full) pen2[k] <- TRUE lab2[k] <- paste(lab1[ii],"r",sep="") order[k] <- order1[ii] + 1 k <- k + 1 } else { ## X1[[ii]] is un-penalized, columns to be treated separately cnx1 <- colnames(X1[[ii]]) for (j in 1:ncol(X1[[ii]])) { X2[[k]] <- X1[[ii]][,j]*Zi lab2[k] <- paste(cnx1[j],"r",sep="") order[k] <- order1[ii] + 1 pen2[k] <- TRUE k <- k + 1 } } } ## finished dealing with range space for this margin if (null.exists) { for (ii in 1:length(X1)) { ## form products with Xi if (!full || !pen1[ii]) { ## treat product as whole if (full) { ## need column labels to make correct term labels cn <- colnames(X1[[ii]]);cnxi <- colnames(Xi) cnx2 <- rep("",0) } A <- matrix(0,n,0) for (j in 1:ncol(X1[[ii]])) { if (full) cnx2 <- c(cnx2,paste(cn[j],cnxi,sep="")) ## column labels A <- cbind(A,X1[[ii]][,j]*Xi) } if (full) colnames(A) <- cnx2 lab2[k] <- paste(lab1[ii],"n",sep="") order[k] <- order1[ii] X2[[k]] <- A; if (full) pen2[k] <- FALSE ## if full, you only get to here when pen1[i] FALSE k <- k + 1 } else { ## treat cols of Xi separately (full is TRUE) cnxi <- colnames(Xi) for (j in 1:ncol(Xi)) { X2[[k]] <- X1[[ii]]*Xi[,j] lab2[k] <- paste(lab1[ii],cnxi[j],sep="") ## null space labels => order unchanged order[k] <- order1[ii] pen2[k] <- TRUE k <- k + 1 } } } } ## finished dealing with null space for this margin } ## finished working through margins rm(X1) ## X2 now contains a sequence of model matrices, all but the last ## should have an associated ridge penalty. if (!is.null(ord)) { ## may need to drop some terms ii <- order %in% ord ## terms to retain X2 <- X2[ii] lab2 <- lab2[ii] if (sum(ord==0)==0) no.null <- TRUE ## null space dropped } xc <- unlist(lapply(X2,ncol)) ## number of columns of sub-matrix X <- matrix(unlist(X2),n,sum(xc)) if (!no.null) { xc <- xc[-length(xc)] ## last block unpenalized lab2 <- lab2[-length(lab2)] ## don't need label for unpenalized block } attr(X,"sub.cols") <- xc ## number of columns in each seperately penalized sub matrix attr(X,"p.lab") <- lab2 ## labels for each penalty, identifying how space is constructed ## note that sub.cols/xc only contains dimension of last block if it is penalized X } ## end t2.model.matrix smooth.construct.t2.smooth.spec <- function(object,data,knots) ## the constructor for an ss-anova style tensor product basis object. ## needs to check `by' variable, to see if a centering constraint ## is required. If it is, then it must be applied here. { m <- length(object$margin) # number of marginal bases Xm <- list();Sm <- list();nr <- r <- d <- array(0,m) Pm <- list() ## list for matrices by which to postmultiply raw model matris to get repara version C <- NULL ## potential constraint matrix object$plot.me <- TRUE for (i in 1:m) { ## create marginal model matrices and penalties... ## pick up the required variables.... knt <- dat <- list() term <- object$margin[[i]]$term for (j in 1:length(term)) { dat[[term[j]]] <- data[[term[j]]] knt[[term[j]]] <- knots[[term[j]]] } ## construct marginal smooth... object$margin[[i]]<-smooth.construct(object$margin[[i]],dat,knt) Xm[[i]]<-object$margin[[i]]$X if (!is.null(object$margin[[i]]$te.ok)) { if (object$margin[[i]]$te.ok==0) stop("attempt to use unsuitable marginal smooth class") if (object$margin[[i]]$te.ok==2) object$plot.me <- FALSE ## margin declared itself unplottable } if (length(object$margin[[i]]$S)>1) stop("Sorry, tensor products of smooths with multiple penalties are not supported.") Sm[[i]]<-object$margin[[i]]$S[[1]] d[i]<-nrow(Sm[[i]]) r[i]<-object$margin[[i]]$rank ## rank of penalty for this margin nr[i]<-object$margin[[i]]$null.space.dim ## reparameterize so that penalty is identity (and scaling is nice)... np <- nat.param(Xm[[i]],Sm[[i]],rank=r[i],type=3,unit.fnorm=TRUE) Xm[[i]] <- np$X; dS <- rep(0,ncol(Xm[[i]]));dS[1:r[i]] <- 1; Sm[[i]] <- diag(dS) ## penalty now diagonal Pm[[i]] <- np$P ## maps original model matrix to reparameterized if (!is.null(object$margin[[i]]$C)&& nrow(object$margin[[i]]$C)==0) C <- matrix(0,0,0) ## no centering constraint needed } ## margin creation finished ## Create the model matrix... X <- t2.model.matrix(Xm,r,full=object$full,ord=object$ord) sub.cols <- attr(X,"sub.cols") ## size (cols) of penalized sub blocks ## Create penalties, which are simple non-overlapping ## partial identity matrices... nsc <- length(sub.cols) ## number of penalized sub-blocks of X S <- list() cxn <- c(0,cumsum(sub.cols)) if (nsc>0) for (j in 1:nsc) { dd <- rep(0,ncol(X));dd[(cxn[j]+1):cxn[j+1]] <- 1 S[[j]] <- diag(dd) } names(S) <- attr(X,"p.lab") if (length(object$fx)==1) object$fx <- rep(object$fx,nsc) else if (length(object$fx)!=nsc) { warning("fx length wrong from t2 term: ignored") object$fx <- rep(FALSE,nsc) } if (!is.null(object$sp)&&length(object$sp)!=nsc) { object$sp <- NULL warning("length of sp incorrect in t2: ignored") } object$null.space.dim <- ncol(X) - sum(sub.cols) ## penalty null space rank ## Create identifiability constraint. Key feature is that it ## only affects the unpenalized parameters... nup <- sum(sub.cols[1:nsc]) ## range space rank ##X.shift <- NULL if (is.null(C)) { ## if not null then already determined that constraint not needed if (object$null.space.dim==0) { C <- matrix(0,0,0) } else { ## no null space => no constraint if (object$null.space.dim==1) C <- ncol(X) else ## might as well use set to zero C <- matrix(c(rep(0,nup),colSums(X[,(nup+1):ncol(X),drop=FALSE])),1,ncol(X)) ## constraint on null space ## X.shift <- colMeans(X[,1:nup]) ## X[,1:nup] <- sweep(X[,1:nup],2,X.shift) ## make penalized columns orthog to constant col. ## last is fine because it is equivalent to adding the mean of each col. times its parameter ## to intercept... only parameter modified is the intercept. ## .... amounted to shifting random efects to fixed effects -- not legitimate } } object$X <- X object$S <- S object$C <- C ##object$X.shift <- X.shift if (is.matrix(C)&&nrow(C)==0) object$Cp <- NULL else object$Cp <- matrix(colSums(X),1,ncol(X)) ## alternative constraint for prediction object$df <- ncol(X) object$rank <- sub.cols[1:nsc] ## ranks of individual penalties object$P <- Pm ## map original marginal model matrices to reparameterized versions object$fixed <- as.logical(sum(object$fx)) ## needed by gamm/4 class(object)<-"t2.smooth" object } ## end of smooth.construct.t2.smooth.spec Predict.matrix.t2.smooth <- function(object,data) ## the prediction method for a t2 tensor product smooth { m <- length(object$margin) X <- list() rank <- rep(0,m) for (i in 1:m) { term <- object$margin[[i]]$term dat <- list() for (j in 1:length(term)) dat[[term[j]]] <- data[[term[j]]] X[[i]]<-Predict.matrix(object$margin[[i]],dat)%*%object$P[[i]] rank[i] <- object$margin[[i]]$rank } T <- t2.model.matrix(X,rank,full=object$full,ord=object$ord) T } ## end of Predict.matrix.t2.smooth split.t2.smooth <- function(object) { ## function to split up a t2 smooth into a list of separate smooths if (!inherits(object,"t2.smooth")) return(object) ind <- 1:ncol(object$S[[1]]) ## index of penalty columns ind.para <- object$first.para:object$last.para ## index of coefficients sm <- list() ## list to receive split up smooths sm[[1]] <- object ## stores everything in original object St <- object$S[[1]]*0 for (i in 1:length(object$S)) { ## work through penalties indi <- ind[diag(object$S[[i]])!=0] ## index of penalized coefs. label <- paste(object$label,".frag",i,sep="") sm[[i]] <- list(S = list(object$S[[i]][indi,indi]), ## the penalty first.para = min(ind.para[indi]), last.para = max(ind.para[indi]), fx=object$fx[i],fixed=object$fx[i], sp=object$sp[i], null.space.dim=0, df = length(indi), rank=object$rank[i], label=label, S.scale=object$S.scale[i] ) class(sm[[i]]) <- "t2.frag" St <- St + object$S[[i]] } ## now deal with the null space (alternative would be to append this to one of penalized terms) i <- length(object$S) + 1 indi <- ind[diag(St)==0] ## index of unpenalized elements if (length(indi)) { ## then there are unplenalized elements label <- paste(object$label,".frag",i,sep="") sm[[i]] <- list(S = NULL, ## the penalty first.para = min(ind.para[indi]), last.para = max(ind.para[indi]), fx=TRUE,fixed=TRUE, null.space.dim=0, label = label, df = length(indi) ) class(sm[[i]]) <- "t2.frag" } sm } ## split.t2.smooth expand.t2.smooths <- function(sm) { ## takes a list that may contain `t2.smooth' objects, and expands it into ## a list of `smooths' with single penalties m <- length(sm) not.needed <- TRUE for (i in 1:m) if (inherits(sm[[i]],"t2.smooth")&&length(sm[[i]]$S)>1) { not.needed <- FALSE;break} if (not.needed) return(NULL) smr <- list() ## return list k <- 0 for (i in 1:m) { if (inherits(sm[[i]],"t2.smooth")) { smi <- split.t2.smooth(sm[[i]]) comp.ind <- (k+1):(k+length(smi)) ## index of all fragments making up complete smooth for (j in 1:length(smi)) { k <- k + 1 smr[[k]] <- smi[[j]] smr[[k]]$comp.ind <- comp.ind } } else { k <- k+1; smr[[k]] <- sm[[i]] } } smr ## return expanded list } ## expand.t2.smooths ########################################################## ## Thin plate regression splines (tprs) methods start here ########################################################## null.space.dimension <- function(d,m) # vectorized function for calculating null space dimension for tps penalties of order m # for dimension d data M=(m+d-1)!/(d!(m-1)!). Any m not satisfying 2m>d is reset so # that 2m>d+1 (assuring "visual" smoothness) { if (sum(d<0)) stop("d can not be negative in call to null.space.dimension().") ind <- 2*m < d+1 if (sum(ind)) # then default m required for some elements { m[ind] <- 1;ind <- 2*m < d+2 while (sum(ind)) { m[ind]<-m[ind]+1;ind <- 2*m < d+2;} } M <- m*0+1;ind <- M==1;i <- 0 while(sum(ind)) { M[ind] <- M[ind]*(d[ind]+m[ind]-1-i);i <- i+1;ind <- i1;i <- 2 while(sum(ind)) { M[ind] <- M[ind]/i;ind <- d>i;i <- i+1 } M } ## null.space.dimension smooth.construct.tp.smooth.spec <- function(object,data,knots) ## The constructor for a t.p.r.s. basis object. { shrink <- attr(object,"shrink") ## deal with possible extra arguments of "tp" type smooth xtra <- list() if (is.null(object$xt$max.knots)) xtra$max.knots <- 2000 else xtra$max.knots <- object$xt$max.knots if (is.null(object$xt$seed)) xtra$seed <- 1 else xtra$seed <- object$xt$seed ## now collect predictors x<-array(0,0) shift<-array(0,object$dim) for (i in 1:object$dim) { ## xx <- get.var(object$term[[i]],data) xx <- data[[object$term[i]]] shift[i]<-mean(xx) # centre covariates xx <- xx - shift[i] if (i==1) n <- length(xx) else if (n!=length(xx)) stop("arguments of smooth not same dimension") x<-c(x,xx) } if (is.null(knots)) {knt<-0;nk<-0} else { knt<-array(0,0) for (i in 1:object$dim) { dum <- knots[[object$term[i]]]-shift[i] if (is.null(dum)) {knt<-0;nk<-0;break} # no valid knots for this term knt <- c(knt,dum) nk0 <- length(dum) if (i > 1 && nk != nk0) stop("components of knots relating to a single smooth must be of same length") nk <- nk0 } } if (nk>n) { nk <- 0 warning("more knots than data in a tp term: knots ignored.")} ## deal with possibility of large data set if (nk==0 && n>xtra$max.knots) { ## then there *may* be too many data xu <- uniquecombs(matrix(x,n,object$dim),TRUE) ## find the unique `locations' nu <- nrow(xu) ## number of unique locations if (nu>xtra$max.knots) { ## then there is really a problem 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(xtra$seed) ## ensure repeatability nk <- xtra$max.knots ## going to create nk knots ind <- sample(1:nu,nk,replace=FALSE) ## by sampling these rows from xu knt <- as.numeric(xu[ind,]) ## ... like this RNGkind(kind[1],kind[2]) assign(".Random.seed",seed,envir=.GlobalEnv) ## RNG behaves as if it had not been used } } ## end of large data set handling ##if (object$bs.dim[1]<0) object$bs.dim <- 10*3^(object$dim-1) # auto-initialize basis dimension object$p.order[is.na(object$p.order)] <- 0 ## auto-initialize M <- null.space.dimension(object$dim,object$p.order[1]) if (length(object$p.order)>1&&object$p.order[2]==0) object$drop.null <- M else object$drop.null <- 0 def.k <- c(8,27,100) ## default penalty range space dimension for different dimensions dd <- min(object$dim,length(def.k)) if (object$bs.dim[1]<0) object$bs.dim <- M+def.k[dd] ##10*3^(object$dim-1) # auto-initialize basis dimension k<-object$bs.dim if (k0) { ind <- 1:(k-M) if (FALSE) { ## nat param version np <- nat.param(object$X,object$S[[1]],rank=k-M,type=0) object$P <- np$P object$S[[1]] <- diag(np$D) object$X <- np$X[,ind] } else { ## original param object$S[[1]] <- object$S[[1]][ind,ind] object$X <- object$X[,ind] object$cmX <- colMeans(object$X) object$X <- sweep(object$X,2,object$cmX) } object$null.space.dim <- 0 object$df <- object$df - M object$bs.dim <- object$bs.dim -M object$C <- matrix(0,0,ncol(object$X)) # null constraint matrix } class(object) <- "tprs.smooth" object } ## smooth.construct.tp.smooth.spec smooth.construct.ts.smooth.spec <- function(object,data,knots) # implements a class of tprs like smooths with an additional shrinkage # term in the penalty... this allows for fully integrated GCV model selection { attr(object,"shrink") <- 1e-1 object <- smooth.construct.tp.smooth.spec(object,data,knots) class(object) <- "ts.smooth" object } ## smooth.construct.ts.smooth.spec Predict.matrix.tprs.smooth <- function(object,data) # prediction matrix method for a t.p.r.s. term { x<-array(0,0) for (i in 1:object$dim) { xx <- data[[object$term[i]]] xx <- xx - object$shift[i] if (i==1) n <- length(xx) else if (length(xx)!=n) stop("arguments of smooth not same dimension") if (length(xx)<1) stop("no data to predict at") x<-c(x,xx) } by<-0;by.exists<-FALSE ## following used to be object$null.space.dim, but this is now *post constraint* M <- null.space.dimension(object$dim,object$p.order[1]) ind <- 1:object$bs.dim if (is.null(object$drop.null)) object$drop.null <- 0 ## pre 1.7_19 compatibility if (object$drop.null>0) object$bs.dim <- object$bs.dim + M X<-matrix(0,n,object$bs.dim) oo<-.C(C_predict_tprs,as.double(x),as.integer(object$dim),as.integer(n),as.integer(object$p.order[1]), as.integer(object$bs.dim),as.integer(M),as.double(object$Xu), as.integer(nrow(object$Xu)),as.double(object$UZ),as.double(by),as.integer(by.exists),X=as.double(X)) X<-matrix(oo$X,n,object$bs.dim) if (object$drop.null>0) { if (FALSE) { ## nat param X <- (X%*%object$P)[,ind] ## drop null space } else { ## original X <- X[,ind] X <- sweep(X,2,object$cmX) } } X } ## Predict.matrix.tprs.smooth Predict.matrix.ts.smooth <- function(object,data) # this is the prediction method for a t.p.r.s # with shrinkage { Predict.matrix.tprs.smooth(object,data) } ## Predict.matrix.ts.smooth ############################################# ## Cubic regression spline methods start here ############################################# smooth.construct.cr.smooth.spec <- function(object,data,knots) { # this routine is the constructor for cubic regression spline basis objects # It takes a cubic regression spline specification object and returns the # corresponding basis object. Efficient code. shrink <- attr(object,"shrink") if (length(object$term)!=1) stop("Basis only handles 1D smooths") x <- data[[object$term]] nx <- length(x) if (is.null(knots)) ok <- FALSE else { k <- knots[[object$term]] if (is.null(k)) ok <- FALSE else ok<-TRUE } if (object$bs.dim < 0) object$bs.dim <- 10 ## default if (object$bs.dim <3) { object$bs.dim <- 3 warning("basis dimension, k, increased to minimum possible\n") } xu <- unique(x) nk <- object$bs.dim if (length(xu)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 smooth.construct.cc.smooth.spec <- function(object,data,knots) # constructor function for cyclic cubic splines { getBD<-function(x) # matrices B and D in expression Bm=Dp where m are s"(x_i) and # p are s(x_i) and the x_i are knots of periodic spline s(x) # B and D slightly modified (for periodicity) from Lancaster # and Salkauskas (1986) Curve and Surface Fitting section 4.7. { n<-length(x) h<-x[2:n]-x[1:(n-1)] n<-n-1 D<-B<-matrix(0,n,n) B[1,1]<-(h[n]+h[1])/3;B[1,2]<-h[1]/6;B[1,n]<-h[n]/6 D[1,1]<- -(1/h[1]+1/h[n]);D[1,2]<-1/h[1];D[1,n]<-1/h[n] for (i in 2:(n-1)) { B[i,i-1]<-h[i-1]/6 B[i,i]<-(h[i-1]+h[i])/3 B[i,i+1]<-h[i]/6 D[i,i-1]<-1/h[i-1] D[i,i]<- -(1/h[i-1]+1/h[i]) D[i,i+1]<- 1/h[i] } B[n,n-1]<-h[n-1]/6;B[n,n]<-(h[n-1]+h[n])/3;B[n,1]<-h[n]/6 D[n,n-1]<-1/h[n-1];D[n,n]<- -(1/h[n-1]+1/h[n]);D[n,1]<-1/h[n] list(B=B,D=D) } # end of getBD local function # evaluate covariate, x, and knots, k. if (length(object$term)!=1) stop("Basis only handles 1D smooths") x <- data[[object$term]] if (object$bs.dim < 0 ) object$bs.dim <- 10 ## default if (object$bs.dim <4) { object$bs.dim <- 4 warning("basis dimension, k, increased to minimum possible\n") } nk <- object$bs.dim k <- knots[[object$term]] if (is.null(k)) k <- place.knots(x,nk) if (length(k)==2) { k <- place.knots(c(k,x),nk) } if (length(k)!=nk) stop("number of supplied knots != k for a cc smooth") um<-getBD(k) BD<-solve(um$B,um$D) # s"(k)=BD%*%s(k) where k are knots minus last knot if (!object$fixed) { object$S<-list(t(um$D)%*%BD) # the penalty object$S[[1]]<-(object$S[[1]]+t(object$S[[1]]))/2 # ensure exact symmetry } object$BD<-BD # needed for prediction object$xp<-k # needed for prediction X<-Predict.matrix.cyclic.smooth(object,data) object$X<-X object$rank<-ncol(X)-1 # rank of smoother matrix object$df<-object$bs.dim-1 # degrees of freedom, accounting for cycling object$null.space.dim <- 1 class(object)<-"cyclic.smooth" object$noterp <- TRUE # do not re-parameterize in te object } ## smooth.construct.cc.smooth.spec 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)min(x)||x10) warning("knot range is so wide that there is *no* information about some basis coefficients") } ## now construct penalty... p.ord <- m[2] np <- ncol(object$X) if (p.ord>np-1) stop("penalty order too high for basis dimension") 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 <- np-1 # penalty rank object$null.space.dim <- 1 # dimension of unpenalized space object$knots <- k; object$m <- m # store p-spline specific info. class(object)<-"cpspline.smooth" # Give object a class object } ## smooth.construct.cp.smooth.spec Predict.matrix.cpspline.smooth <- function(object,data) ## prediction method function for the cpspline 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 } ## Predict.matrix.cpspline.smooth ############################## ## P-spline methods start here ############################## smooth.construct.ps.smooth.spec <- function(object,data,knots) # a p-spline constructor method function { ##require(splines) 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]+1) ## default nk <- object$bs.dim - m[1] # number of interior knots if (nk<=0) 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)) { xl <- min(x);xu <- max(x) } else if (length(k)==2) { xl <- min(k);xu <- max(k); if (xl>min(x)||xu0) warning("there is *no* information about some basis coefficients") } if (length(unique(x)) < object$bs.dim) warning("basis dimension is larger than number of unique covariates") ## check and set montonic parameterization indicator: 1 increase, -1 decrease, 0 no constraint if (is.null(object$mono)) object$mono <- 0 if (object$mono!=0) { ## scop-spline requested p <- ncol(object$X) B <- matrix(as.numeric(rep(1:p,p)>=rep(1:p,each=p)),p,p) ## coef summation matrix if (object$mono < 0) B[,2:p] <- -B[,2:p] ## monotone decrease case object$D <- cbind(0,-diff(diag(p-1))) if (object$mono==2||object$mono==-2) { ## drop intercept term object$D <- object$D[,-1] B <- B[,-1] object$null.space.dim <- 1 object$g.index <- rep(TRUE,p-1) object$C <- matrix(0,0,ncol(object$X)) # null constraint matrix } else { object$g.index <- c(FALSE,rep(TRUE,p-1)) object$null.space.dim <- 2 } ## ... g.index is indicator of which coefficients must be positive (exponentiated) object$X <- object$X %*% B object$S <- list(crossprod(object$D)) ## penalty for a scop-spline object$B <- B object$rank <- p-2 } else { ## now construct conventional P-spline penalty object$D <- S <- if (m[2]>0) diff(diag(object$bs.dim),differences=m[2]) else diag(object$bs.dim); ## if (m[2]) for (i in 1:m[2]) S <- diff(S) ##object$S <- list(t(S)%*%S) # get penalty ##object$S[[1]] <- (object$S[[1]]+t(object$S[[1]]))/2 # exact symmetry object$S <- list(crossprod(S)) object$rank <- object$bs.dim-m[2] # penalty rank object$null.space.dim <- m[2] # dimension of unpenalized space } object$knots <- k; object$m <- m # store p-spline specific info. class(object)<-"pspline.smooth" # Give object a class object } ### end of p-spline constructor Predict.matrix.pspline.smooth <- function(object,data) # prediction method function for the p.spline smooth class { ##require(splines) m <- object$m[1]+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 (is.null(object$deriv)) object$deriv <- 0 if (sum(ind)==n) { ## all in range X <- splines::spline.des(object$knots,x,m,rep(object$deriv,n))$design } else { ## some extrapolation needed ## matrix mapping coefs to value and slope at end points... D <- splines::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 nin <- sum(ind) if (nin>0) X[ind,] <- splines::spline.des(object$knots,x[ind],m,rep(object$deriv,nin))$design ## interior rows ## Now add rows for linear extrapolation (of smooth itself)... if (object$deriv<2) { ## under linear extrapolation higher derivatives vanish. ind <- x < ll if (sum(ind)>0) X[ind,] <- if (object$deriv==0) cbind(1,x[ind]-ll)%*%D[1:2,] else matrix(D[2,],sum(ind),ncol(D),byrow=TRUE) ind <- x > ul if (sum(ind)>0) X[ind,] <- if (object$deriv==0) cbind(1,x[ind]-ul)%*%D[3:4,] else matrix(D[4,],sum(ind),ncol(D),byrow=TRUE) } } if (object$mono==0) X else X %*% object$B } ## Predict.matrix.pspline.smooth ############################## ## B-spline methods start here ############################## smooth.construct.bs.smooth.spec <- function(object,data,knots) { ## a B-spline constructor method function ## get orders: m[1] is spline order, 3 is cubic. m[2] is order of derivative in penalty. if (length(object$p.order)==1) m <- c(object$p.order,max(0,object$p.order-1)) else m <- object$p.order # m[1] - basis order, m[2] - penalty order if (is.na(m[1])) if (is.na(m[2])) m <- c(3,2) else m[1] <- m[2] + 1 if (is.na(m[2])) m[2] <- max(0,m[1]-1) object$m <- object$p.order <- m if (object$bs.dim<0) object$bs.dim <- max(10,m[1]) ## default nk <- object$bs.dim - m[1] + 1 # number of interior knots if (nk<=0) 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)) { xl <- min(x);xu <- max(x) } else if (length(k)==2) { xl <- min(k);xu <- max(k); if (xl>min(x)||xu0) warning("there is *no* information about some basis coefficients") } if (length(unique(x)) < object$bs.dim) warning("basis dimension is larger than number of unique covariates") ## now construct derivative based penalty. Order of derivate ## is equal to m, which is only a conventional spline in the ## cubic case... object$knots <- k; class(object) <- "Bspline.smooth" # Give object a class k0 <- k[m[1]+1:nk] ## the interior knots object$D <- object$S <- list() m2 <- m[2:length(m)] ## penalty orders if (length(unique(m2))1) stop("\"fs\" smooth cannot use a multiply penalized basis (wrong basis in xt)") ## save some base smooth information object$base <- list(bs=class(object),bs.dim=object$bs.dim, rank=object$rank,null.space.dim=object$null.space.dim, term=object$term) object$term <- oterm ## restore original term list ## Re-parameterize to separate out null space. rp <- nat.param(object$X,object$S[[1]],rank=object$rank,type=3) ## copy range penalty and create null space penalties... null.d <- ncol(object$X) - object$rank ## null space dim object$S[[1]] <- diag(c(rp$D,rep(0,null.d))) ## range space penalty for (i in 1:null.d) { ## create null space element penalties object$S[[i+1]] <- object$S[[1]]*0 object$S[[i+1]][object$rank+i,object$rank+i] <- 1 } object$P <- rp$P ## X' = X%*%P, where X is original version object$fterm <- fterm ## the factor name... if (!is.factor(fac)) warning("no factor supplied to fs smooth") object$flev <- levels(fac) object$fac <- fac ## gamm should use this for grouping ## Now the model matrix if (gamm) { ## no duplication, gamm will handle this by nesting if (object$fixed==TRUE) stop("\"fs\" terms can not be fixed here") object$X <- rp$X #object$fac <- fac ## gamm should use this for grouping object$te.ok <- 0 ## would break special handling ## rank?? } else { ## duplicate model matrix columns, and penalties... nf <- length(object$flev) ## Store the base model matrix/S in case user wants to convert to r.e. but ## has not created with a "gamm" attribute on object object$Xb <- rp$X object$base$S <- object$S ## creating the model matrix... object$X <- rp$X * as.numeric(fac==object$flev[1]) if (nf>1) for (i in 2:nf) { object$X <- cbind(object$X,rp$X * as.numeric(fac==object$flev[i])) } ## now penalties... #object$S <- fullS object$S[[1]] <- diag(rep(c(rp$D,rep(0,null.d)),nf)) ## range space penalties for (i in 1:null.d) { ## null space penalties um <- rep(0,ncol(rp$X));um[object$rank+i] <- 1 object$S[[i+1]] <- diag(rep(um,nf)) } object$bs.dim <- ncol(object$X) object$te.ok <- 0 object$rank <- c(object$rank*nf,rep(nf,null.d)) } object$side.constrain <- FALSE ## don't apply side constraints - these are really random effects object$null.space.dim <- 0 object$C <- matrix(0,0,ncol(object$X)) # null constraint matrix object$plot.me <- TRUE class(object) <- if ("tensor.smooth.spec"%in%spec.class) c("fs.interaction","tensor.smooth") else "fs.interaction" if ("tensor.smooth.spec"%in%spec.class) { ## give object margins like a tensor product smooth... ## need just enough for fitting and discrete prediction to work object$margin <- list() if (object$dim>1) stop("fs smooth not suitable for discretisation with more than one metric predictor") form1 <- as.formula(paste("~",object$fterm,"-1")) fac -> data[[fterm]] object$margin[[1]] <- list(X=model.matrix(form1,data),term=object$fterm,form=form1,by="NA") class(object$margin[[1]]) <- "random.effect" object$margin[[2]] <- object object$margin[[2]]$X <- rp$X object$margin[[2]]$margin.only <- TRUE ## list(X=rp$X,term=object$base$term,base=object$base,margin.only=TRUE,P=object$P,by="NA") ## class(object$margin[[2]]) <- "fs.interaction" ## note --- no re-ordering at present - inefficiecnt as factor should really ## be last, but that means complete re-working of penalty structure. } ## finished tensor like setup object } ## end of smooth.construct.fs.smooth.spec Predict.matrix.fs.interaction <- function(object,data) # prediction method function for the smooth-factor interaction class { ## first remove factor from the data... fac <- data[[object$fterm]] data[[object$fterm]] <- NULL ## now get base prediction matrix... class(object) <- object$base$bs object$rank <- object$base$rank object$null.space.dim <- object$base$null.space.dim object$bs.dim <- object$base$bs.dim object$term <- object$base$term Xb <- Predict.matrix(object,data)%*%object$P if (!is.null(object$margin.only)) return(Xb) X <- matrix(0,nrow(Xb),0) for (i in 1:length(object$flev)) { X <- cbind(X,Xb * as.numeric(fac==object$flev[i])) } X } ## Predict.matrix.fs.interaction ########################################## ## Adaptive smooth constructors start here ########################################## mfil <- function(M,i,j,m) { ## sets M[i[k],j[k]] <- m[k] for all k in 1:length(m) without ## looping.... nr <- nrow(M) a <- as.numeric(M) k <- (j-1)*nr+i a[k] <- m matrix(a,nrow(M),ncol(M)) } ## mfil D2 <- function(ni=5,nj=5) { ## Function to obtain second difference matrices for ## coefficients notionally on a regular ni by nj grid ## returns second order differences in each direction + ## mixed derivative, scaled so that ## t(Dcc)%*%Dcc + t(Dcr)%*%Dcr + t(Drr)%*%Drr ## is the discrete analogue of a thin plate spline penalty ## (the 2 on the mixed derivative has been absorbed) Ind <- matrix(1:(ni*nj),ni,nj) ## the indexing matrix rmt <- rep(1:ni,nj) ## the row index cmt <- rep(1:nj,rep(ni,nj)) ## the column index ci <- Ind[2:(ni-1),1:nj] ## column index n.ci <- length(ci) Drr <- matrix(0,n.ci,ni*nj) ## difference matrices rr.ri <- rmt[ci] ## index to coef array row rr.ci <- cmt[ci] ## index to coef array column Drr <- mfil(Drr,1:n.ci,ci,-2) ## central coefficient ci <- Ind[1:(ni-2),1:nj] Drr <- mfil(Drr,1:n.ci,ci,1) ## back coefficient ci <- Ind[3:ni,1:nj] Drr <- mfil(Drr,1:n.ci,ci,1) ## forward coefficient ci <- Ind[1:ni,2:(nj-1)] ## column index n.ci <- length(ci) Dcc <- matrix(0,n.ci,ni*nj) ## difference matrices cc.ri <- rmt[ci] ## index to coef array row cc.ci <- cmt[ci] ## index to coef array column Dcc <- mfil(Dcc,1:n.ci,ci,-2) ## central coefficient ci <- Ind[1:ni,1:(nj-2)] Dcc <- mfil(Dcc,1:n.ci,ci,1) ## back coefficient ci <- Ind[1:ni,3:nj] Dcc <- mfil(Dcc,1:n.ci,ci,1) ## forward coefficient ci <- Ind[2:(ni-1),2:(nj-1)] ## column index n.ci <- length(ci) Dcr <- matrix(0,n.ci,ni*nj) ## difference matrices cr.ri <- rmt[ci] ## index to coef array row cr.ci <- cmt[ci] ## index to coef array column ci <- Ind[1:(ni-2),1:(nj-2)] Dcr <- mfil(Dcr,1:n.ci,ci,sqrt(0.125)) ## -- coefficient ci <- Ind[3:ni,3:nj] Dcr <- mfil(Dcr,1:n.ci,ci,sqrt(0.125)) ## ++ coefficient ci <- Ind[1:(ni-2),3:nj] Dcr <- mfil(Dcr,1:n.ci,ci,-sqrt(0.125)) ## -+ coefficient ci <- Ind[3:ni,1:(nj-2)] Dcr <- mfil(Dcr,1:n.ci,ci,-sqrt(0.125)) ## +- coefficient list(Dcc=Dcc,Drr=Drr,Dcr=Dcr,rr.ri=rr.ri,rr.ci=rr.ci,cc.ri=cc.ri, cc.ci=cc.ci,cr.ri=cr.ri,cr.ci=cr.ci,rmt=rmt,cmt=cmt) } ## D2 smooth.construct.ad.smooth.spec <- function(object,data,knots) ## an adaptive p-spline constructor method function ## This is the simplifies and more efficient version... { bs <- object$xt$bs if (length(bs)>1) bs <- bs[1] if (is.null(bs)) { ## use default bases bs <- "ps" } else { # bases supplied, need to sanity check if (!bs%in%c("cc","cr","ps","cp")) bs[1] <- "ps" } if (bs == "cc"||bs=="cp") bsp <- "cp" else bsp <- "ps" ## if basis is cyclic, then so should penalty if (object$dim> 2 ) stop("the adaptive smooth class is limited to 1 or 2 covariates.") else if (object$dim==1) { ## following is 1D case... if (object$bs.dim < 0) object$bs.dim <- 40 ## default if (is.na(object$p.order[1])) object$p.order[1] <- 5 pobject <- object pobject$p.order <- c(2,2) class(pobject) <- paste(bs[1],".smooth.spec",sep="") ## get basic spline object... if (is.null(knots)&&bs[1]%in%c("cr","cc")) { ## must create knots x <- data[[object$term]] knots <- list(seq(min(x),max(x),length=object$bs.dim)) names(knots) <- object$term } ## end of knot creation pspl <- smooth.construct(pobject,data,knots) nk <- ncol(pspl$X) k <- object$p.order[1] ## penalty basis size if (k>=nk-2) stop("penalty basis too large for smoothing basis") if (k <= 0) { ## no penalty pspl$fixed <- TRUE pspl$S <- NULL } else if (k>=2) { ## penalty basis needed ... x <- 1:(nk-2)/nk;m=2 ## All elements of V must be >=0 for all S[[l]] to be +ve semi-definite if (k==2) V <- cbind(rep(1,nk-2),x) else if (k==3) { m <- 1 ps2 <- smooth.construct(s(x,k=k,bs=bsp,m=m,fx=TRUE),data=data.frame(x=x),knots=NULL) V <- ps2$X } else { ## general penalty basis construction... ps2 <- smooth.construct(s(x,k=k,bs=bsp,m=m,fx=TRUE),data=data.frame(x=x),knots=NULL) V <- ps2$X } Db<-diff(diff(diag(nk))) ## base difference matrix ##D <- list() # for (i in 1:k) D[[i]] <- as.numeric(V[,i])*Db # L <- matrix(0,k*(k+1)/2,k) S <- list() for (i in 1:k) { S[[i]] <- t(Db)%*%(as.numeric(V[,i])*Db) ind <- rowSums(abs(S[[i]]))>0 ev <- eigen(S[[i]][ind,ind],symmetric=TRUE,only.values=TRUE)$values pspl$rank[i] <- sum(ev>max(ev)*.Machine$double.eps^.9) } pspl$S <- S } } else if (object$dim==2){ ## 2D case ## first task is to obtain a tensor product basis object$bs.dim[object$bs.dim<0] <- 15 ## default k <- object$bs.dim;if (length(k)==1) k <- c(k[1],k[1]) tec <- paste("te(",object$term[1],",",object$term[2],",bs=bs,k=k,m=2)",sep="") pobject <- eval(parse(text=tec)) ## tensor smooth specification object pobject$np <- FALSE ## do not re-parameterize if (is.null(knots)&&bs[1]%in%c("cr","cc")) { ## create suitable knots for (i in 1:2) { x <- data[[object$term[i]]] knots <- list(seq(min(x),max(x),length=k[i])) names(knots)[i] <- object$term[i] } } ## finished knots pspl <- smooth.construct(pobject,data,knots) ## create basis ## now need to create the adaptive penalties... ## First the penalty basis... kp <- object$p.order if (length(kp)!=2) kp <- c(kp[1],kp[1]) kp[is.na(kp)] <- 3 ## default kp.tot <- prod(kp);k.tot <- (k[1]-2)*(k[2]-2) ## rows of Difference matrices if (kp.tot > k.tot) stop("penalty basis too large for smoothing basis") if (kp.tot <= 0) { ## no penalty pspl$fixed <- TRUE pspl$S <- NULL } else { ## penalized, but how? Db <- D2(ni=k[1],nj=k[2]) ## get the difference-on-grid matrices pspl$S <- list() ## delete original S list if (kp.tot==1) { ## return a single fixed penalty pspl$S[[1]] <- t(Db[[1]])%*%Db[[1]] + t(Db[[2]])%*%Db[[2]] + t(Db[[3]])%*%Db[[3]] pspl$rank <- ncol(pspl$S[[1]]) - 3 } else { ## adaptive if (kp.tot==3) { ## planar adaptiveness V <- cbind(rep(1,k.tot),Db[[4]],Db[[5]]) } else { ## spline adaptive penalty... ## first check sanity of basis dimension request ok <- TRUE if (sum(kp<2)) ok <- FALSE if (!ok) stop("penalty basis too small") m <- min(min(kp)-2,1); m<-c(m,m);j <- 1 ps2 <- smooth.construct(te(i,j,bs=bsp,k=kp,fx=TRUE,m=m,np=FALSE), data=data.frame(i=Db$rmt,j=Db$cmt),knots=NULL) Vrr <- Predict.matrix(ps2,data.frame(i=Db$rr.ri,j=Db$rr.ci)) Vcc <- Predict.matrix(ps2,data.frame(i=Db$cc.ri,j=Db$cc.ci)) Vcr <- Predict.matrix(ps2,data.frame(i=Db$cr.ri,j=Db$cr.ci)) } ## spline adaptive basis finished ## build penalty list S <- list() for (i in 1:kp.tot) { S[[i]] <- t(Db$Drr)%*%(as.numeric(Vrr[,i])*Db$Drr) + t(Db$Dcc)%*%(as.numeric(Vcc[,i])*Db$Dcc) + t(Db$Dcr)%*%(as.numeric(Vcr[,i])*Db$Dcr) ev <- eigen(S[[i]],symmetric=TRUE,only.values=TRUE)$values pspl$rank[i] <- sum(ev>max(ev)*.Machine$double.eps*10) } pspl$S <- S pspl$pen.smooth <- ps2 ## the penalty smooth object } ## adaptive penalty finished } ## penalized case finished } pspl$te.ok <- 0 ## not suitable as a tensor product marginal pspl } ## end of smooth.construct.ad.smooth.spec ######################################################## # Random effects terms start here. Plot method in plot.r ######################################################## smooth.construct.re.smooth.spec <- function(object,data,knots) ## a simple random effects constructor method function ## basic idea is that s(x,f,z,...,bs="re") generates model matrix ## corresponding to ~ x:f:z: ... - 1. Corresponding coefficients ## have an identity penalty. If object inherits from "tensor.smooth.spec" ## then terms depending on more than one variable are set up with a te ## smooth like structure (used e.g. in bam(...,discrete=TRUE)) { ## id's with factor variables are problematic - should terms have ## same levels, or just same number of levels, for example? ## => ruled out if (!is.null(object$id)) stop("random effects don't work with ids.") form <- as.formula(paste("~",paste(object$term,collapse=":"),"-1")) object$X <- model.matrix(form,data) object$bs.dim <- ncol(object$X) if (inherits(object,"tensor.smooth.spec")) { ## give object margins like a tensor product smooth... object$margin <- list() maxd <- maxi <- 0 for (i in 1:object$dim) { form1 <- as.formula(paste("~",object$term[i],"-1")) object$margin[[i]] <- list(X=model.matrix(form1,data),term=object$term[i],form=form1,by="NA") class(object$margin[[i]]) <- "random.effect" d <- ncol(object$margin[[i]]$X) if (d>maxd) {maxi <- i;maxd <- d} } ## now re-order so that largest margin is last... if (maxi= lo1)|(hi1[k] <= hi1 & hi1[k] >= lo1)| (lo1 <= hi1[k] & lo1 >= lo1[k])|(hi1 <= hi1[k] & hi1 >= lo1[k]) ol2 <- (lo2[k] <= hi2 & lo2[k] >= lo2)|(hi2[k] <= hi2 & hi2[k] >= lo2)| (lo2 <= hi2[k] & lo2 >= lo2[k])|(hi2 <= hi2[k] & hi2 >= lo2[k]) ol <- ol1&ol2;ol[k] <- FALSE ind <- (1:n.poly)[ol] ## index of potential neighbours of poly k ## co-ordinates of polygon k... cok <- pc[[k]] if (length(ind)>0) for (j in 1:length(ind)) { co <- rbind(pc[[ind[j]]],cok) cou <- uniquecombs(co) n.shared <- nrow(co) - nrow(cou) ## if there are common vertices add area from which j comes ## to vector of neighbour indices if (n.shared>0) nb[[k]] <- c(nb[[k]],ind[j]) } } for (i in 1:length(pc)) nb[[i]] <- unique(nb[[i]]) names(nb) <- names(pc) list(nb=nb,xlim=c(min(lo1),max(hi1)),ylim=c(min(lo2),max(hi2))) } ## end of pol2nb smooth.construct.mrf.smooth.spec <- function(object, data, knots) { ## Argument should be factor or it will be coerced to factor ## knots = vector of all regions (may include regions with no data) ## xt must contain at least one of ## * `penalty' - a penalty matrix, with row and column names corresponding to the ## levels of the covariate, or the knots. ## * `polys' - a list of lists of polygons, defining the areas, names(polys) must correspond ## to the levels of the covariate or the knots. polys[[i]] is ## a 2 column matrix defining the vertices of polygons defining area i's boundary. ## If there are several polygons they should be separated by an NA row. ## * `nb' - is a list defining the neighbourhood structure. names(nb) must correspond to ## the levels of the covariate or knots. nb[[i]][j] is the index of the jth neighbour ## of area i. i.e. the jth neighbour of area names(nb)[i] is area names(nb)[nb[[i]][j]]. ## Being a neighbour should be a symmetric state!! ## `polys' is only stored for subsequent plotting if `nb' or `penalty' are supplied. ## If `penalty' is supplied it is always used. ## If `penalty' is not supplied then it is computed from `nb', which is in turn computed ## from `polys' if `nb' is missing. ## Modified from code by Thomas Kneib. if (!is.factor(data[[object$term]])) warning("argument of mrf should be a factor variable") x <- as.factor(data[[object$term]]) k <- knots[[object$term]] if (is.null(k)) { k <- as.factor(levels(x)) # default knots = all regions in the data } else k <- as.factor(k) if (object$bs.dim<0) object$bs.dim <- length(levels(k)) if (object$bs.dim>length(levels(k))) stop("MRF basis dimension set too high") if (sum(!levels(x)%in%levels(k))) stop("data contain regions that are not contained in the knot specification") ##levels(x) <- levels(k) ## to allow for regions with no data x <- factor(x,levels=levels(k)) ## to allow for regions with no data object$X <- model.matrix(~x-1,data.frame(x=x)) ## model matrix ## now set up the penalty... if(is.null(object$xt)) stop("penalty matrix, boundary polygons and/or neighbours list must be supplied in xt") ## If polygons supplied as list with duplicated names, then re-format... if (!is.null(object$xt$polys)) { a.name <- names(object$xt$polys) d.name <- unique(a.name[duplicated(a.name)]) ## find duplicated names if (length(d.name)) { ## deal with duplicates for (i in 1:length(d.name)) { ind <- (1:length(a.name))[a.name==d.name[i]] ## index of duplicates for (j in 2:length(ind)) object$xt$polys[[ind[1]]] <- ## combine matrices for duplicate names rbind(object$xt$polys[[ind[1]]],c(NA,NA),object$xt$polys[[ind[j]]]) } ## now delete the un-wanted duplicates... ind <- (1:length(a.name))[duplicated(a.name)] if (length(ind)>0) for (i in length(ind):1) object$xt$polys[[ind[i]]] <- NULL } object$plot.me <- TRUE ## polygon list in correct format } else { object$plot.me <- FALSE ## can't plot without polygon information } ## actual penalty building... if (is.null(object$xt$penalty)) { ## must construct penalty if (is.null(object$xt$nb)) { ## no neighbour list... construct one if (is.null(object$xt$polys)) stop("no spatial information provided!") object$xt$nb <- pol2nb(object$xt$polys)$nb } else if (!is.numeric(object$xt$nb[[1]])) { ## user has (hopefully) supplied names not indices nb.names <- names(object$xt$nb) for (i in 1:length(nb.names)) { object$xt$nb[[i]] <- which(nb.names %in% object$xt$nb[[i]]) } } ## now have a neighbour list a.name <- names(object$xt$nb) if (all.equal(sort(a.name),sort(levels(k)))!=TRUE) stop("mismatch between nb/polys supplied area names and data area names") np <- ncol(object$X) S <- matrix(0,np,np) rownames(S) <- colnames(S) <- levels(k) for (i in 1:np) { ind <- object$xt$nb[[i]] lind <- length(ind) S[a.name[i],a.name[i]] <- lind if (lind>0) for (j in 1:lind) S[a.name[i],a.name[ind[j]]] <- -1 } if (sum(S!=t(S))>0) stop("Something wrong with auto- penalty construction") object$S[[1]] <- S } else { ## penalty given, just need to check it object$S[[1]] <- object$xt$penalty if (ncol(object$S[[1]])!=nrow(object$S[[1]])) stop("supplied penalty not square!") if (ncol(object$S[[1]])!=ncol(object$X)) stop("supplied penalty wrong dimension!") if (!is.null(colnames(object$S[[1]]))) { a.name <- colnames(object$S[[1]]) if (all.equal(levels(k),sort(a.name))!=TRUE) { stop("penalty column names don't match supplied area names!") } else { if (all.equal(sort(a.name),a.name)!=TRUE) { ## re-order penalty to match object$X object$S[[1]] <- object$S[[1]][levels(k),] object$S[[1]] <- object$S[[1]][,levels(k)] } } } } ## end of check -- penalty ok if we got this far ## Following (optionally) constructs a low rank approximation based on the ## natural parameterization given in Wood (2006) 4.1.14 if (object$bs.dim0) { ## create dummy obs for missing... object$X <- rbind(matrix(0,length(mi),np),object$X) for (i in 1:length(mi)) object$X[i,mi[i]] <- 1 } rp <- nat.param(object$X,object$S[[1]],type=0) ## now retain only bs.dim least penalized elements ## of basis, which are the final bs.dim cols of rp$X ind <- (np-object$bs.dim+1):np object$X <- if (length(mi)) rp$X[-(1:length(mi)),ind] else rp$X[,ind] ## model matrix object$P <- rp$P[,ind] ## re-para matrix ##ind <- ind[ind <= rp$rank] ## drop last element as zeros not returned in D object$S[[1]] <- diag(c(rp$D[ind[ind <= rp$rank]],rep(0,sum(ind>rp$rank)))) object$rank <- sum(ind <= rp$rank) ## rp$rank ## penalty rank } else { ## full rank basis, but need to ## numerically evaluate mrf penalty rank... ev <- eigen(object$S[[1]],symmetric=TRUE,only.values=TRUE)$values object$rank <- sum(ev >.Machine$double.eps^.8*max(ev)) ## ncol(object$X)-1 } object$null.space.dim <- ncol(object$X) - object$rank object$knots <- k object$df <- ncol(object$X) object$te.ok <- 2 ## OK in te but not to plot object$noterp <- TRUE ## do not re-para in te terms class(object)<-"mrf.smooth" object } ## smooth.construct.mrf.smooth.spec Predict.matrix.mrf.smooth <- function(object, data) { x <- factor(data[[object$term]],levels=levels(object$knots)) ##levels(x) <- levels(object$knots) X <- model.matrix(~x-1) if (!is.null(object$P)) X <- X%*%object$P X } ## Predict.matrix.mrf.smooth ############################# # Splines on the sphere.... ############################# makeR <- function(la,lo,lak,lok,m=2) { ## construct a matrix R the i,jth element of which is ## R(p[i],pk[j]) where p[i] is the point given by ## la[i], lo[i] and something similar holds for pk[j]. ## Wahba (1981) SIAM J Sci. Stat. Comput. 2(1):5-14 is the ## key reference, although some expressions are oddly unsimplified ## there. There's an errata in 3(3):385-386, but it doesn't ## change anything here (only higher order penalties) ## Return null space basis matrix T as attribute... pi180 <- pi/180 ## convert to radians la <- la * pi180;lo <- lo * pi180 lak <- lak * pi180;lok <- lok * pi180 og <- expand.grid(lo=lo,lok=lok) ag <- expand.grid(la=la,lak=lak) ## get array of angles between points (lo,la) and knots (lok,lak)... #v <- 1 - cos(ag$la)*cos(og$lo)*cos(ag$lak)*cos(og$lok) - # cos(ag$la)*sin(og$lo)*cos(ag$lak)*sin(og$lok)- # sin(ag$la)*sin(ag$lak) #v[v<0] <- 0 #gamma <- 2*asin(sqrt(v*0.5)) v <- sin(ag$la)*sin(ag$lak)+cos(ag$la)*cos(ag$lak)*cos(og$lo-og$lok) v[v > 1] <- 1;v[v < -1] <- -1 gamma <- acos(v) if (m == -1) { ## Jean Duchon's unpublished proposal... z <- 2*sin(gamma/2) ## Euclidean 3 - distance between points eps <- .Machine$double.xmin*10 z[z 0 is 1 W <- z/2;C <- sqrt(W) A <- log(1+1/C);C <- C*2 if (m==1) { ## order 3/2 penalty q1 <- 2*A*W - C + 1 R <- matrix((q1-1/2)/(2*pi),length(la),length(lak)) ## rk matrix attr(R,"T") <- matrix(1,nrow(R),1) attr(R,"Tc") <- matrix(1,ncol(R),1) ## constraint return(R) } W2 <- W*W if (m==2) { ## order 2 penalty q2 <- A*(6*W2-2*W)-3*C*W+3*W+1/2 ## This is Wahba's pseudospline r.k. alternative would be to ## sum series to get regular spline kernel, as in m=0 case above R <- matrix((q2/2-1/6)/(2*pi),length(la),length(lak)) ## rk matrix attr(R,"T") <- matrix(1,nrow(R),1) attr(R,"Tc") <- matrix(1,ncol(R),1) ## constraint return(R) } W3 <- W2*W if (m==3) { ## order 5/2 penalty q3 <- (A*(60*W3 - 36*W2) + 30*W2 + C*(8*W-30*W2) - 3*W + 1)/3 R <- matrix( (q3/6-1/24)/(2*pi),length(la),length(lak)) ## rk matrix attr(R,"T") <- matrix(1,nrow(R),1) attr(R,"Tc") <- matrix(1,ncol(R),1) ## constraint return(R) } W4 <- W3*W if (m==4) { ## order 3 penalty q4 <- A*(70*W4-60*W3 + 6*W2) +35*W3*(1-C) + C*55*W2/3 - 12.5*W2 - W/3 + 1/4 R <- matrix( (q4/24-1/120)/(2*pi),length(la),length(lak)) ## rk matrix attr(R,"T") <- matrix(1,nrow(R),1) attr(R,"Tc") <- matrix(1,ncol(R),1) ## constraint return(R) } } ## makeR smooth.construct.sos.smooth.spec<-function(object,data,knots) ## The constructor for a spline on the sphere basis object. ## Assumption: first variable is lat, second is lon!! { ## deal with possible extra arguments of "sos" type smooth xtra <- list() if (is.null(object$xt$max.knots)) xtra$max.knots <- 2000 else xtra$max.knots <- object$xt$max.knots if (is.null(object$xt$seed)) xtra$seed <- 1 else xtra$seed <- object$xt$seed if (object$dim!=2) stop("Can only deal with a sphere") ## now collect predictors x<-array(0,0) for (i in 1:2) { xx <- data[[object$term[i]]] if (i==1) n <- length(xx) else if (n!=length(xx)) stop("arguments of smooth not same dimension") x<-c(x,xx) } if (is.null(knots)) { knt<-0;nk<-0} else { knt<-array(0,0) for (i in 1:2) { dum <- knots[[object$term[i]]] if (is.null(dum)) {knt<-0;nk<-0;break} # no valid knots for this term knt <- c(knt,dum) nk0 <- length(dum) if (i > 1 && nk != nk0) stop("components of knots relating to a single smooth must be of same length") nk <- nk0 } } if (nk>n) { ## more knots than data - silly. nk <- 0 warning("more knots than data in an sos term: knots ignored.") } ## deal with possibility of large data set if (nk==0) { ## need to create knots xu <- uniquecombs(matrix(x,n,2),TRUE) ## find the unique `locations' nu <- nrow(xu) ## number of unique locations if (n > xtra$max.knots) { ## then there *may* be too many data if (nu>xtra$max.knots) { ## then there is really a problem 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(xtra$seed) ## ensure repeatability nk <- xtra$max.knots ## going to create nk knots ind <- sample(1:nu,nk,replace=FALSE) ## by sampling these rows from xu knt <- as.numeric(xu[ind,]) ## ... like this RNGkind(kind[1],kind[2]) assign(".Random.seed",seed,envir=.GlobalEnv) ## RNG behaves as if it had not been used } else { knt <- xu;nk <- nu } ## end of large data set handling } else { knt <- xu;nk <- nu } ## just set knots to data } if (object$bs.dim[1]<0) object$bs.dim <- 50 # auto-initialize basis dimension ## Now get the rk matrix... if (is.na(object$p.order)) object$p.order <- 0 object$p.order <- round(object$p.order) if (object$p.order< -1) object$p.order <- -1 if (object$p.order>4) object$p.order <- 4 R <- makeR(la=knt[1:nk],lo=knt[-(1:nk)],lak=knt[1:nk],lok=knt[-(1:nk)],m=object$p.order) T <- attr(R,"Tc") ## constraint matrix ind <- 1:ncol(T) k <- object$bs.dim if (k nk) { ## split into chunks to save memory n.chunk <- n %/% nk for (i in 1:n.chunk) { ## build predict matrix in chunks ind <- 1:nk + (i-1)*nk Xc <- makeR(la=la[ind],lo=lo[ind], lak=lak,lok=lok,m=object$p.order) Xc <- cbind(Xc%*%object$UZ,attr(Xc,"T")) if (i == 1) X <- Xc else { X <- rbind(X,Xc);rm(Xc)} } ## finished size nk chunks if (n > ind[nk]) { ## still some left over ind <- (ind[nk]+1):n ## last chunk Xc <- makeR(la=la[ind],lo=lo[ind], lak=lak,lok=lok,m=object$p.order) Xc <- cbind(Xc%*%object$UZ,attr(Xc,"T")) X <- rbind(X,Xc);rm(Xc) } } else { X <- makeR(la=la,lo=lo, lak=lak,lok=lok,m=object$p.order) X <- cbind(X%*%object$UZ,attr(X,"T")) } if (!is.null(object$xc.scale)) X <- t(t(X)*object$xc.scale) ## apply column scaling X } ## Predict.matrix.sos.smooth ########################### # Duchon 1977.... ########################### poly.pow <- function(m,d) { ## create matrix containing powers of (m-1)th order polynomials in d dimensions ## p[i,j] is power for x_j in ith basis component. p has d columns M <- choose(m+d-1,d) ## total basis size p <- matrix(0,M,d) oo <- .C(C_gen_tps_poly_powers,p=as.integer(p),M=as.integer(M),m=as.integer(m),d=as.integer(d)) matrix(oo$p,M,d) } ## poly.pow DuchonT <- function(x,m=2,n=1) { ## Get null space basis for Duchon '77 construction... ## n is dimension in Duchon's notation, so x is a matrix ## with n columns. m is penalty order. p <- poly.pow(m,n) M <- nrow(p) ## basis size if (!is.matrix(x)) x <- matrix(x,length(x),1) nx <- nrow(x) T <- matrix(0,nx,M) for (i in 1:M) { y <- rep(1,nx) for (j in 1:n) y <- y * x[,j]^p[i,j] T[,i] <- y } T } ## DuchonT DuchonE <- function(x,xk,m=2,s=0,n=1) { ## Get the r.k. matrix for a Duchon '77 construction... ind <- expand.grid(x=1:nrow(x),xk=1:nrow(xk)) ## get d[i,j] the Euclidian distance from x[i] to xk[j]... d <- matrix(sqrt(rowSums((x[ind$x,,drop=FALSE]-xk[ind$xk,,drop=FALSE])^2)),nrow(x),nrow(xk)) k <- 2*m + 2*s - n if (k%%2==0) { ## even ind <- d==0 E <- d E[!ind] <- d[!ind]^k * log(d[!ind]) } else { E <- d^k } ## k == 1 => -ve - then sign flips every second k value ## i.e. if floor(k/2+1) is odd then sign is -ve, otherwise +ve signE <- 1-2*((floor(k/2)+1)%%2) rm(d) E*signE } ## DuchonE smooth.construct.ds.smooth.spec <- function(object,data,knots) ## The constructor for a Duchon 1977 smoother { ## deal with possible extra arguments of "ds" type smooth xtra <- list() if (is.null(object$xt$max.knots)) xtra$max.knots <- 2000 else xtra$max.knots <- object$xt$max.knots if (is.null(object$xt$seed)) xtra$seed <- 1 else xtra$seed <- object$xt$seed ## now collect predictors x<-array(0,0) for (i in 1:object$dim) { xx <- data[[object$term[i]]] if (i==1) n <- length(xx) else if (n!=length(xx)) stop("arguments of smooth not same dimension") x<-c(x,xx) } if (is.null(knots)) { knt<-0;nk<-0} else { knt<-array(0,0) for (i in 1:object$dim) { dum <- knots[[object$term[i]]] if (is.null(dum)) {knt<-0;nk<-0;break} # no valid knots for this term knt <- c(knt,dum) nk0 <- length(dum) if (i > 1 && nk != nk0) stop("components of knots relating to a single smooth must be of same length") nk <- nk0 } } if (nk>n) { ## more knots than data - silly. nk <- 0 warning("more knots than data in a ds term: knots ignored.") } xu <- uniquecombs(matrix(x,n,object$dim),TRUE) ## find the unique `locations' if (nrow(xu) xtra$max.knots) { ## then there *may* be too many data if (nu>xtra$max.knots) { ## then there is really a problem 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(xtra$seed) ## ensure repeatability nk <- xtra$max.knots ## going to create nk knots ind <- sample(1:nu,nk,replace=FALSE) ## by sampling these rows from xu knt <- as.numeric(xu[ind,]) ## ... like this RNGkind(kind[1],kind[2]) assign(".Random.seed",seed,envir=.GlobalEnv) ## RNG behaves as if it had not been used } else { knt <- xu;nk <- nu } ## end of large data set handling } else { knt <- xu;nk <- nu } ## just set knots to data } ## if (object$bs.dim[1]<0) object$bs.dim <- 10*3^(object$dim[1]-1) # auto-initialize basis dimension ## Check the conditions on Duchon's m, s and n (p.order[1], p.order[2] and dim)... if (is.na(object$p.order[1])) object$p.order[1] <- 2 ## default penalty order 2 if (is.na(object$p.order[2])) object$p.order[2] <- 0 ## default s=0 (tps) object$p.order[1] <- round(object$p.order[1]) ## m is integer object$p.order[2] <- round(object$p.order[2]*2)/2 ## s is in halfs if (object$p.order[1]< 1) object$p.order[1] <- 1 ## m > 0 ## -n/2 < s < n/2... if (object$p.order[2] >= object$dim/2) { object$p.order[2] <- (object$dim-1)/2 warning("s value reduced") } if (object$p.order[2] <= -object$dim/2) { object$p.order[2] <- -(object$dim-1)/2 warning("s value increased") } ## m + s > n/2 for continuity... if (sum(object$p.order)<=object$dim/2) { object$p.order[2] <- 1/2 + object$dim/2 - object$p.order[1] if (object$p.order[2]>=object$dim/2) stop("No suitable s (i.e. m[2]) try increasing m[1]") warning("s value modified to give continuous function") } x <- matrix(x,n,object$dim) knt <- matrix(knt,nk,object$dim) ## centre the covariates... object$shift <- colMeans(x) x <- sweep(x,2,object$shift) knt <- sweep(knt,2,object$shift) ## Get the E matrix... E <- DuchonE(knt,knt,m=object$p.order[1],s=object$p.order[2],n=object$dim) T <- DuchonT(knt,m=object$p.order[1],n=object$dim) ## constraint matrix ind <- 1:ncol(T) def.k <- c(10,30,100) dd <- min(object$dim,length(def.k)) if (object$bs.dim[1]<0) object$bs.dim <- ncol(T) + def.k[dd] ## default basis dimension if (object$bs.dim < ncol(T)+1) { object$bs.dim <- ncol(T)+1 warning("basis dimension reset to minimum possible") } k <- object$bs.dim if (k nk) { ## split into chunks to save memory n.chunk <- n %/% nk for (i in 1:n.chunk) { ## build predict matrix in chunks ind <- 1:nk + (i-1)*nk Xc <- DuchonE(x=x[ind,,drop=FALSE],xk=object$knt,m=object$p.order[1],s=object$p.order[2],n=object$dim) Xc <- cbind(Xc%*%object$UZ,DuchonT(x=x[ind,,drop=FALSE],m=object$p.order[1],n=object$dim)) if (i == 1) X <- Xc else { X <- rbind(X,Xc);rm(Xc)} } ## finished size nk chunks if (n > ind[nk]) { ## still some left over ind <- (ind[nk]+1):n ## last chunk Xc <- DuchonE(x=x[ind,,drop=FALSE],xk=object$knt,m=object$p.order[1],s=object$p.order[2],n=object$dim) Xc <- cbind(Xc%*%object$UZ,DuchonT(x=x[ind,,drop=FALSE],m=object$p.order[1],n=object$dim)) X <- rbind(X,Xc);rm(Xc) } } else { X <- DuchonE(x=x,xk=object$knt,m=object$p.order[1],s=object$p.order[2],n=object$dim) X <- cbind(X%*%object$UZ,DuchonT(x=x,m=object$p.order[1],n=object$dim)) } X } ## end of Predict.matrix.duchon.spline ################################################## # Matern splines following Kammann and Wand (2003) ################################################## gpT <- function(x) { ## T matrix for Kamman and Wand Matern Spline... cbind(x[,1]*0+1,x) } ## gpT gpE <- function(x,xk,defn = NA) { ## Get the E matrix for a Kammann and Wand Matern spline. ## rho is the range parameter... set to K&W default if not supplied ind <- expand.grid(x=1:nrow(x),xk=1:nrow(xk)) ## get d[i,j] the Euclidian distance from x[i] to xk[j]... E <- matrix(sqrt(rowSums((x[ind$x,,drop=FALSE]-xk[ind$xk,,drop=FALSE])^2)),nrow(x),nrow(xk)) rho <- -1; k <- 1 if ((length(defn)==1&&is.na(defn))||length(defn)<1) { type <- 3 } else if (length(defn)>0) type <- round(defn[1]) if (length(defn)>1) rho <- defn[2] if (length(defn)>2) k <- defn[3] if (rho <= 0) rho <- max(E) ## approximately the K & W choise E <- E/rho if (!type%in%1:5||k>2||k<=0) stop("incorrect arguments to GP smoother") if (type>2) eE <- exp(-E) E <- switch(type, (1 - 1.5*E + 0.5 *E^3)*(E <= 1), ## 1 spherical exp(-E^k), ## 2 power exponential (1 + E) * eE, ## 3 Matern k = 1.5 eE + (E*eE)*(1+E/3), ## 4 Matern k = 2.5 eE + (E*eE)*(1+.4*E+E^2/15) ## 5 Matern k = 3.5 ) attr(E,"defn") <- c(type,rho,k) E } ## gpE smooth.construct.gp.smooth.spec <- function(object,data,knots) ## The constructor for a Kamman and Wand (2003) Matern Spline, and other GP smoothers. ## See also Handcock, Meier and Nychka (1994), and Handcock and Stein (1993). { ## deal with possible extra arguments of "gp" type smooth xtra <- list() if (is.null(object$xt$max.knots)) xtra$max.knots <- 2000 else xtra$max.knots <- object$xt$max.knots if (is.null(object$xt$seed)) xtra$seed <- 1 else xtra$seed <- object$xt$seed ## now collect predictors x <- array(0,0) for (i in 1:object$dim) { xx <- data[[object$term[i]]] if (i==1) n <- length(xx) else if (n!=length(xx)) stop("arguments of smooth not same dimension") x<-c(x,xx) } if (is.null(knots)) { knt <- 0; nk <- 0} else { knt <- array(0,0) for (i in 1:object$dim) { dum <- knots[[object$term[i]]] if (is.null(dum)) { knt <- 0; nk <- 0; break} # no valid knots for this term knt <- c(knt,dum) nk0 <- length(dum) if (i > 1 && nk != nk0) stop("components of knots relating to a single smooth must be of same length") nk <- nk0 } } if (nk>n) { ## more knots than data - silly. nk <- 0 warning("more knots than data in an ms term: knots ignored.") } xu <- uniquecombs(matrix(x,n,object$dim),TRUE) ## find the unique `locations' if (nrow(xu) < object$bs.dim) stop( "A term has fewer unique covariate combinations than specified maximum degrees of freedom") ## deal with possibility of large data set if (nk==0) { ## need to create knots nu <- nrow(xu) ## number of unique locations if (n > xtra$max.knots) { ## then there *may* be too many data if (nu > xtra$max.knots) { ## then there is really a problem 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(xtra$seed) ## ensure repeatability nk <- xtra$max.knots ## going to create nk knots ind <- sample(1:nu,nk,replace=FALSE) ## by sampling these rows from xu knt <- as.numeric(xu[ind,]) ## ... like this RNGkind(kind[1],kind[2]) assign(".Random.seed",seed,envir=.GlobalEnv) ## RNG behaves as if it had not been used } else { knt <- xu; nk <- nu } ## end of large data set handling } else { knt <- xu;nk <- nu } ## just set knots to data } x <- matrix(x,n,object$dim) knt <- matrix(knt,nk,object$dim) ## centre the covariates... object$shift <- colMeans(x) x <- sweep(x,2,object$shift) knt <- sweep(knt,2,object$shift) ## Get the E matrix... E <- gpE(knt,knt,object$p.order) object$gp.defn <- attr(E,"defn") def.k <- c(10,30,100) dd <- ncol(knt) if (object$bs.dim[1] < 0) object$bs.dim <- ncol(knt) + 1 + def.k[dd] ## default basis dimension if (object$bs.dim < ncol(knt)+2) { object$bs.dim <- ncol(knt)+2 warning("basis dimension reset to minimum possible") } object$null.space.dim <- ncol(knt) + 1 k <- object$bs.dim - object$null.space.dim if (k < nk) { er <- slanczos(E,k,-1) ## truncated eigen decomposition of E D <- diag(c(er$values,rep(0,object$null.space.dim))) ## penalty matrix } else { ## no point using eigen-decomp D <- matrix(0,object$bs.dim,object$bs.dim) D[1:k,1:k] <- E ## penalty er <- list(vectors=diag(k)) ## U is identity here } rm(E) object$S <- list(S=D) object$UZ <- er$vectors ## UZ - (original params) = UZ %*% (working params) object$knt = knt ## save the knots object$df <- object$bs.dim object$rank <- k class(object)<-"gp.smooth" object$X <- Predict.matrix.gp.smooth(object,data) object } ## end of smooth.construct.gp.smooth.spec Predict.matrix.gp.smooth <- function(object,data) # prediction method function for the gp (Matern) smooth class { nk <- nrow(object$knt) ## number of 'knots' ## get evaluation points.... for (i in 1:object$dim) { xx <- data[[object$term[i]]] if (i==1) { n <- length(xx) x <- matrix(xx,n,object$dim) } else { if (n!=length(xx)) stop("arguments of smooth not same dimension") x[,i] <- xx } } x <- sweep(x,2,object$shift) ## apply centering if (n > nk) { ## split into chunks to save memory n.chunk <- n %/% nk for (i in 1:n.chunk) { ## build predict matrix in chunks ind <- 1:nk + (i-1)*nk Xc <- gpE(x=x[ind,,drop=FALSE],xk=object$knt,object$gp.defn) Xc <- cbind(Xc%*%object$UZ,gpT(x=x[ind,,drop=FALSE])) if (i == 1) X <- Xc else { X <- rbind(X,Xc);rm(Xc)} } ## finished size nk chunks if (n > ind[nk]) { ## still some left over ind <- (ind[nk]+1):n ## last chunk Xc <- gpE(x=x[ind,,drop=FALSE],xk=object$knt,object$gp.defn) Xc <- cbind(Xc%*%object$UZ,gpT(x=x[ind,,drop=FALSE])) X <- rbind(X,Xc);rm(Xc) } } else { X <- gpE(x=x,xk=object$knt,object$gp.defn) X <- cbind(X%*%object$UZ,gpT(x=x)) } X } ## end of Predict.matrix.gp.smooth ################################### # Soap film smoothers are in soap.r ################################### ############################ ## The generics and wrappers ############################ smooth.construct <- function(object,data,knots) UseMethod("smooth.construct") smooth.construct2 <- function(object,data,knots) { ## This routine does not require that `data' contains only ## the evaluated `object$term's and the `by' variable... it ## obtains such a data object from `data' and also deals with ## multiple evaluations at the same covariate points efficiently dk <- ExtractData(object,data,knots) object <- smooth.construct(object,dk$data,dk$knots) ind <- attr(dk$data,"index") ## repeats index if (!is.null(ind)) { ## unpack the model matrix offs <- attr(object$X,"offset") object$X <- object$X[ind,] if (!is.null(offs)) attr(object$X,"offset") <- offs[ind] } class(object) <- c(class(object),"mgcv.smooth") object } ## smooth.construct2 smooth.construct3 <- function(object,data,knots) { ## This routine does not require that `data' contains only ## the evaluated `object$term's and the `by' variable... it ## obtains such a data object from `data' and also deals with ## multiple evaluations at the same covariate points efficiently ## In contrast to smooth.constuct2 it returns an object in which ## `X' contains the rows required to make the full model matrix, ## and ind[i] tells you which row of `X' is the ith row of the ## full model matrix. If `ind' is NULL then `X' is the full model matrix. dk <- ExtractData(object,data,knots) object <- smooth.construct(object,dk$data,dk$knots) ind <- attr(dk$data,"index") ## repeats index object$ind <- ind class(object) <- c(class(object),"mgcv.smooth") if (!is.null(object$point.con)) { ## 's' etc has requested a point constraint object$C <- Predict.matrix3(object,object$point.con)$X ## handled by 's' attr(object$C,"always.apply") <- TRUE ## if constraint requested then always apply it! } object } ## smooth.construct3 Predict.matrix <- function(object,data) UseMethod("Predict.matrix") Predict.matrix2 <- function(object,data) { dk <- ExtractData(object,data,NULL) X <- Predict.matrix(object,dk$data) ind <- attr(dk$data,"index") ## repeats index if (!is.null(ind)) { ## unpack the model matrix offs <- attr(X,"offset") X <- X[ind,] if (!is.null(offs)) attr(X,"offset") <- offs[ind] } X } ## Predict.matrix2 Predict.matrix3 <- function(object,data) { ## version of Predict.matrix matching smooth.construct3 dk <- ExtractData(object,data,NULL) X <- Predict.matrix(object,dk$data) ind <- attr(dk$data,"index") ## repeats index list(X=X,ind=ind) } ## Predict.matrix3 ExtractData <- function(object,data,knots) { ## `data' and `knots' contain the data needed to evaluate the `terms', `by' ## and `knots' elements of `object'. This routine does so, and returns ## a list with element `data' containing just the evaluated `terms', ## with the by variable as the last column. If the `terms' evaluate matrices, ## then a check is made of whether repeat evaluations are being made, ## and if so only the unique evaluation points are returned in data, along ## with the `index' attribute required to re-assemble the full dataset. knt <- dat <- list() for (i in 1:length(object$term)) { dat[[object$term[i]]] <- get.var(object$term[i],data) knt[[object$term[i]]] <- get.var(object$term[i],knots) } names(dat) <- object$term; m <- length(object$term) if (!is.null(attr(dat[[1]],"matrix"))) { ## strip down to unique covariate combinations n <- length(dat[[1]]) X <- matrix(unlist(dat),n,m) if (is.numeric(X)) { X <- uniquecombs(X) if (nrow(X)1) for (i in 2:length(sm$S)) upen <- upen & rowMeans(abs(sm$S[[i]]))==0 if (sum(upen)>0) drop <- min(which(upen)) else { drop <- min(which(!sm$g.index)) } } else drop <- 1 sm$g.index <- sm$g.index[-drop] } else drop <- -1 ## signals not to use sweep and drop (may be modified below) if (is.null(sm$C)) { if (sparse.cons<=0) { sm$C <- matrix(colMeans(sm$X),1,ncol(sm$X)) ## following 2 lines implement sweep and drop constraints, ## which are computationally faster than QR null space ## however note that these are not appropriate for ## models with by-variables requiring constraint! if (sparse.cons == -1) { vcol <- apply(sm$X,2,var) ## drop least variable column drop <- min((1:length(vcol))[vcol==min(vcol)]) } } else if (sparse.cons>0) { ## use sparse constraints for sparse terms if (sum(sm$X==0)>.1*sum(sm$X!=0)) { ## treat term as sparse if (sparse.cons==1) { xsd <- apply(sm$X,2,FUN=sd) if (sum(xsd==0)) ## are any columns constant? sm$C <- ((1:length(xsd))[xsd==0])[1] ## index of coef to set to zero else { ## xz <- colSums(sm$X==0) ## find number of zeroes per column (without big memory footprint)... xz <- apply(sm$X,2,FUN=function(x) {sum(x==0)}) sm$C <- ((1:length(xz))[xz==min(xz)])[1] ## index of coef to set to zero } } else if (sparse.cons==2) { sm$C = -1 ## params sum to zero } else { stop("unimplemented sparse constraint type requested") } } else { ## it's not sparse anyway sm$C <- matrix(colSums(sm$X),1,ncol(sm$X)) } } else { ## end of sparse constraint handling sm$C <- matrix(colSums(sm$X),1,ncol(sm$X)) ## default dense case } ## conSupplied <- FALSE alwaysCon <- FALSE } else { ## sm$C supplied if (modCon==2&&!is.null(sm$Cp)) sm$C <- sm$Cp ## reset fit con to predict if (modCon>=3) sm$Cp <- NULL ## get rid of separate predict con ## should supplied constraint be applied even if not needed? if (is.null(attr(sm$C,"always.apply"))) alwaysCon <- FALSE else alwaysCon <- TRUE } ## set df fields (pre-constraint)... if (is.null(sm$df)) sm$df <- sm$bs.dim ## automatically discard penalties for fixed terms... if (!is.null(object$fixed)&&object$fixed) { sm$S <- NULL } ## The following is intended to make scaling `nice' for better gamm performance. ## Note that this takes place before any resetting of the model matrix, and ## any `by' variable handling. From a `gamm' perspective this is not ideal, ## but to do otherwise would mess up the meaning of smoothing parameters ## sufficiently that linking terms via `id's would not work properly (they ## would have the same basis, but different penalties) sm$S.scale <- rep(1,length(sm$S)) if (scale.penalty && length(sm$S)>0 && is.null(sm$no.rescale)) # then the penalty coefficient matrix is rescaled { maXX <- norm(sm$X,type="I")^2 ##mean(abs(t(sm$X)%*%sm$X)) # `size' of X'X for (i in 1:length(sm$S)) { maS <- norm(sm$S[[i]])/maXX ## mean(abs(sm$S[[i]])) / maXX sm$S[[i]] <- sm$S[[i]] / maS sm$S.scale[i] <- maS ## multiply S[[i]] by this to get original S[[i]] } } ## check whether different data to be used for basis setup ## and model matrix... if (!is.null(dataX)) { er <- Predict.matrix3(sm,dataX) sm$X <- er$X sm$ind <- er$ind rm(er) } ## check whether smooth called with matrix argument if ((is.null(sm$ind)&&nrow(sm$X)!=n)||(!is.null(sm$ind)&&length(sm$ind)!=n)) { matrixArg <- TRUE ## now get the number of columns in the matrix argument... if (is.null(sm$ind)) q <- nrow(sm$X)/n else q <- length(sm$ind)/n if (!is.null(sm$by.done)) warning("handling `by' variables in smooth constructors may not work with the summation convention ") } else { matrixArg <- FALSE if (!is.null(sm$ind)) { ## unpack model matrix + any offset offs <- attr(sm$X,"offset") sm$X <- sm$X[sm$ind,,drop=FALSE] if (!is.null(offs)) attr(sm$X,"offset") <- offs[sm$ind] } } offs <- NULL ## pick up "by variables" now, and handle summation convention ... if (matrixArg||(object$by!="NA"&&is.null(sm$by.done))) { #drop <- -1 ## sweep and drop constraints inappropriate if (is.null(dataX)) by <- get.var(object$by,data) else by <- get.var(object$by,dataX) if (matrixArg&&is.null(by)) { ## then by to be taken as sequence of 1s if (is.null(sm$ind)) by <- rep(1,nrow(sm$X)) else by <- rep(1,length(sm$ind)) } if (is.null(by)) stop("Can't find by variable") offs <- attr(sm$X,"offset") if (!is.factor(by)) { ## test for cases where no centring constraint on the smooth is needed. if (!alwaysCon) { if (matrixArg) { L1 <- as.numeric(matrix(by,n,q)%*%rep(1,q)) if (sd(L1)>mean(L1)*.Machine$double.eps*1000) { ## sml[[1]]$C <- sm$C <- matrix(0,0,1) ## if (!is.null(sm$Cp)) sml[[1]]$Cp <- sm$Cp <- NULL if (!is.null(sm$Cp)) sm$Cp <- NULL } else sm$meanL1 <- mean(L1) ## else sml[[1]]$meanL1 <- mean(L1) ## store mean of L1 for use when adding intercept variability } else { ## numeric `by' -- constraint only needed if constant if (sd(by)>mean(by)*.Machine$double.eps*1000) { ## sml[[1]]$C <- sm$C <- matrix(0,0,1) ## if (!is.null(sm$Cp)) sml[[1]]$Cp <- sm$Cp <- NULL if (!is.null(sm$Cp)) sm$Cp <- NULL } } } ## end of constraint removal } } ## end of initial setup of by variables if (absorb.cons&&drop>0&&nrow(sm$C)>0) { ## sweep and drop constraints have to be applied before by variables if (!is.null(sm$by.done)) warning("sweep and drop constraints unlikely to work well with self handling of by vars") qrc <- c(drop,as.numeric(sm$C)[-drop]) class(qrc) <- "sweepDrop" sm$X <- sm$X[,-drop,drop=FALSE] - matrix(qrc[-1],nrow(sm$X),ncol(sm$X)-1,byrow=TRUE) if (length(sm$S)>0) for (l in 1:length(sm$S)) { # some smooths have > 1 penalty sm$S[[l]]<-sm$S[[l]][-drop,-drop] } attr(sm,"qrc") <- qrc attr(sm,"nCons") <- 1 sm$Cp <- sm$C <- 0 sm$rank <- pmin(sm$rank,ncol(sm$X)) sm$df <- sm$df - 1 sm$null.space.dim <- max(0,sm$null.space.dim-1) } if (matrixArg||(object$by!="NA"&&is.null(sm$by.done))) { ## apply by variables if (is.factor(by)) { ## generates smooth for each level of by if (matrixArg) stop("factor `by' variables can not be used with matrix arguments.") sml <- list() lev <- levels(by) ## if by variable is an ordered factor then first level is taken as a ## reference level, and smooths are only generated for the other levels ## this can help to ensure identifiability in complex models. if (is.ordered(by)&&length(lev)>1) lev <- lev[-1] for (j in 1:length(lev)) { sml[[j]] <- sm ## replicate smooth for each factor level by.dum <- as.numeric(lev[j]==by) sml[[j]]$X <- by.dum*sm$X ## multiply model matrix by dummy for level sml[[j]]$by.level <- lev[j] ## store level sml[[j]]$label <- paste(sm$label,":",object$by,lev[j],sep="") if (!is.null(offs)) { attr(sml[[j]]$X,"offset") <- offs*by.dum } } } else { ## not a factor by variable sml <- list(sm) if ((is.null(sm$ind)&&length(by)!=nrow(sm$X))|| (!is.null(sm$ind)&&length(by)!=length(sm$ind))) stop("`by' variable must be same dimension as smooth arguments") if (matrixArg) { ## arguments are matrices => summation convention used #if (!apply.by) warning("apply.by==FALSE unsupported in matrix case") if (is.null(sm$ind)) { ## then the sm$X is in unpacked form sml[[1]]$X <- as.numeric(by)*sm$X ## normal `by' handling ## Now do the summation stuff.... ind <- 1:n X <- sml[[1]]$X[ind,,drop=FALSE] for (i in 2:q) { ind <- ind + n X <- X + sml[[1]]$X[ind,,drop=FALSE] } sml[[1]]$X <- X if (!is.null(offs)) { ## deal with any term specific offset (i.e. sum it too) ## by variable multiplied version... offs <- attr(sm$X,"offset")*as.numeric(by) ind <- 1:n offX <- offs[ind,] for (i in 2:q) { ind <- ind + n offX <- offX + offs[ind,] } attr(sml[[1]]$X,"offset") <- offX } ## end of term specific offset handling } else { ## model sm$X is in packed form to save memory ind <- 0:(q-1)*n offs <- attr(sm$X,"offset") if (!is.null(offs)) offX <- rep(0,n) else offX <- NULL sml[[1]]$X <- matrix(0,n,ncol(sm$X)) for (i in 1:n) { ## in this case have to work down the rows ind <- ind + 1 sml[[1]]$X[i,] <- colSums(by[ind]*sm$X[sm$ind[ind],,drop=FALSE]) if (!is.null(offs)) { offX[i] <- sum(offs[sm$ind[ind]]*by[ind]) } } ## finished all rows attr(sml[[1]]$X,"offset") <- offX } } else { ## arguments not matrices => not in packed form + no summation needed sml[[1]]$X <- as.numeric(by)*sm$X if (!is.null(offs)) attr(sml[[1]]$X,"offset") <- if (apply.by) offs*as.numeric(by) else offs } if (object$by == "NA") sml[[1]]$label <- sm$label else sml[[1]]$label <- paste(sm$label,":",object$by,sep="") } ## end of not factor by branch } else { ## no by variables sml <- list(sm) } ########################### ## absorb constraints.....# ########################### if (absorb.cons) { k<-ncol(sm$X) ## If Cp is present it denotes a constraint to use in place of the fitting constraints ## when predicting. if (!is.null(sm$Cp)&&is.matrix(sm$Cp)) { ## identifiability cons different for prediction pj <- nrow(sm$Cp) qrcp <- qr(t(sm$Cp)) for (i in 1:length(sml)) { ## loop through smooth list sml[[i]]$Xp <- t(qr.qty(qrcp,t(sml[[i]]$X))[(pj+1):k,]) ## form XZ sml[[i]]$Cp <- NULL if (length(sml[[i]]$S)) { ## gam.side requires penalties in prediction para sml[[i]]$Sp <- sml[[i]]$S ## penalties in prediction parameterization for (l in 1:length(sml[[i]]$S)) { # some smooths have > 1 penalty ZSZ <- qr.qty(qrcp,sml[[i]]$S[[l]])[(pj+1):k,] sml[[i]]$Sp[[l]]<-t(qr.qty(qrcp,t(ZSZ))[(pj+1):k,]) ## Z'SZ } } } } else qrcp <- NULL ## rest of Cp processing is after C processing if (is.matrix(sm$C)) { ## the fit constraints j <- nrow(sm$C) if (j>0) { # there are constraints indi <- (1:ncol(sm$C))[colSums(sm$C)!=0] ## index of non-zero columns in C nx <- length(indi) if (nx < ncol(sm$C)&&drop<0) { ## then some parameters are completely constraint free nc <- j ## number of constraints nz <- nx-nc ## reduced null space dimension qrc <- qr(t(sm$C[,indi,drop=FALSE])) ## gives constraint null space for constrained only for (i in 1:length(sml)) { ## loop through smooth list if (length(sm$S)>0) for (l in 1:length(sm$S)) # some smooths have > 1 penalty { ZSZ <- sml[[i]]$S[[l]] if (nz>0) ZSZ[indi[1:nz],]<-qr.qty(qrc,sml[[i]]$S[[l]][indi,,drop=FALSE])[(nc+1):nx,] ZSZ <- ZSZ[-indi[(nz+1):nx],] if (nz>0) ZSZ[,indi[1:nz]]<-t(qr.qty(qrc,t(ZSZ[,indi,drop=FALSE]))[(nc+1):nx,]) sml[[i]]$S[[l]] <- ZSZ[,-indi[(nz+1):nx],drop=FALSE] ## Z'SZ ## ZSZ<-qr.qty(qrc,sm$S[[l]])[(j+1):k,] ## sml[[i]]$S[[l]]<-t(qr.qty(qrc,t(ZSZ))[(j+1):k,]) ## Z'SZ } if (nz>0) sml[[i]]$X[,indi[1:nz]]<-t(qr.qty(qrc,t(sml[[i]]$X[,indi,drop=FALSE]))[(nc+1):nx,]) sml[[i]]$X <- sml[[i]]$X[,-indi[(nz+1):nx]] ## sml[[i]]$X<-t(qr.qty(qrc,t(sml[[i]]$X))[(j+1):k,]) ## form XZ attr(sml[[i]],"qrc") <- qrc attr(sml[[i]],"nCons") <- j; attr(sml[[i]],"indi") <- indi ## index of constrained parameters sml[[i]]$C <- NULL sml[[i]]$rank <- pmin(sm$rank,k-j) sml[[i]]$df <- sml[[i]]$df - j sml[[i]]$null.space.dim <- max(0,sml[[i]]$null.space.dim - j) ## ... so qr.qy(attr(sm,"qrc"),c(rep(0,nrow(sm$C)),b)) gives original para.'s } ## end smooth list loop } else { ## full null space created # if (drop>0) { ## sweep and drop constraints # qrc <- c(drop,as.numeric(sm$C)[-drop]) # class(qrc) <- "sweepDrop" # for (i in 1:length(sml)) { ## loop through smooth list # ## sml[[i]]$X <- sweep(sml[[i]]$X[,-drop],2,qrc[-1]) # sml[[i]]$X <- sml[[i]]$X[,-drop] - # matrix(qrc[-1],nrow(sml[[i]]$X),ncol(sml[[i]]$X)-1,byrow=TRUE) # if (length(sm$S)>0) # for (l in 1:length(sm$S)) { # some smooths have > 1 penalty # sml[[i]]$S[[l]]<-sml[[i]]$S[[l]][-drop,-drop] # } # } # } else { ## full QR based approach qrc<-qr(t(sm$C)) for (i in 1:length(sml)) { ## loop through smooth list if (length(sm$S)>0) for (l in 1:length(sm$S)) { # some smooths have > 1 penalty ZSZ<-qr.qty(qrc,sm$S[[l]])[(j+1):k,] sml[[i]]$S[[l]]<-t(qr.qty(qrc,t(ZSZ))[(j+1):k,]) ## Z'SZ } sml[[i]]$X <- t(qr.qty(qrc,t(sml[[i]]$X))[(j+1):k,]) ## form XZ } ## ... so qr.qy(attr(sm,"qrc"),c(rep(0,nrow(sm$C)),b)) gives original para.'s ## and qr.qy(attr(sm,"qrc"),rbind(rep(0,length(b)),diag(length(b)))) gives ## null space basis Z, such that Zb are the original params, subject to con. } for (i in 1:length(sml)) { ## loop through smooth list attr(sml[[i]],"qrc") <- qrc attr(sml[[i]],"nCons") <- j; sml[[i]]$C <- NULL sml[[i]]$rank <- pmin(sm$rank,k-j) sml[[i]]$df <- sml[[i]]$df - j sml[[i]]$null.space.dim <- max(0,sml[[i]]$null.space.dim-j) } ## end smooth list loop } # end full null space version of constraint } else { ## no constraints for (i in 1:length(sml)) { attr(sml[[i]],"qrc") <- "no constraints" attr(sml[[i]],"nCons") <- 0; } } ## end else no constraints } else if (sm$C>0) { ## set to zero constraints for (i in 1:length(sml)) { ## loop through smooth list if (length(sm$S)>0) for (l in 1:length(sm$S)) { # some smooths have > 1 penalty sml[[i]]$S[[l]] <- sml[[i]]$S[[l]][-sm$C,-sm$C] } sml[[i]]$X <- sml[[i]]$X[,-sm$C] attr(sml[[i]],"qrc") <- sm$C attr(sml[[i]],"nCons") <- 1; sml[[i]]$C <- NULL sml[[i]]$rank <- pmin(sm$rank,k-1) sml[[i]]$df <- sml[[i]]$df - 1 sml[[i]]$null.space.dim <- max(sml[[i]]$null.space.dim-1,0) ## so insert an extra 0 at position sm$C in coef vector to get original } ## end smooth list loop } else if (sm$C <0) { ## params sum to zero for (i in 1:length(sml)) { ## loop through smooth list if (length(sm$S)>0) for (l in 1:length(sm$S)) { # some smooths have > 1 penalty sml[[i]]$S[[l]] <- diff(t(diff(sml[[i]]$S[[l]]))) } sml[[i]]$X <- t(diff(t(sml[[i]]$X))) attr(sml[[i]],"qrc") <- sm$C attr(sml[[i]],"nCons") <- 1; sml[[i]]$C <- NULL sml[[i]]$rank <- pmin(sm$rank,k-1) sml[[i]]$df <- sml[[i]]$df - 1 sml[[i]]$null.space.dim <- max(sml[[i]]$null.space.dim-1,0) ## so insert an extra 0 at position sm$C in coef vector to get original } ## end smooth list loop } ## finish off treatment of case where prediction constraints are different if (!is.null(qrcp)) { for (i in 1:length(sml)) { ## loop through smooth list attr(sml[[i]],"qrc") <- qrcp if (pj!=attr(sml[[i]],"nCons")) stop("Number of prediction and fit constraints must match") attr(sml[[i]],"indi") <- NULL ## no index of constrained parameters for Cp } } } else for (i in 1:length(sml)) attr(sml[[i]],"qrc") <-NULL ## no absorption ## now convert single penalties to identity matrices, if requested. ## This is relatively expensive, so is not routinely done. However ## for expensive inference methods, such as MCMC, it is often worthwhile ## as in speeds up sampling much more than it slows down setup if (diagonal.penalty && length(sml[[1]]$S)==1) { ## recall that sml is a list that may contain several 'cloned' smooths ## if there was a factor by variable. They have the same penalty matrices ## but different model matrices. So cheapest re-para is to use a version ## that does not depend on the model matrix (e.g. type=2) S11 <- sml[[1]]$S[[1]][1,1];rank <- sml[[1]]$rank; p <- ncol(sml[[1]]$X) if (is.null(rank) || max(abs(sml[[1]]$S[[1]] - diag(c(rep(S11,rank),rep(0,p-rank))))) > abs(S11)*.Machine$double.eps^.8 ) { np <- nat.param(sml[[1]]$X,sml[[1]]$S[[1]],rank=sml[[1]]$rank,type=2,unit.fnorm=FALSE) sml[[1]]$X <- np$X;sml[[1]]$S[[1]] <- diag(p) diag(sml[[1]]$S[[1]]) <- c(np$D,rep(0,p-np$rank)) sml[[1]]$diagRP <- np$P if (length(sml)>1) for (i in 2:length(sml)) { sml[[i]]$X <- sml[[i]]$X%*%np$P ## reparameterized model matrix sml[[i]]$S <- sml[[1]]$S ## diagonalized penalty (unpenalized last) sml[[i]]$diagRP <- np$P ## re-parameterization matrix for use in PredictMat } } ## end of if, otherwise was already diagonal, and there is nothing to do } ## The idea here is that term selection can be accomplished as part of fitting ## by applying penalties to the null space of the penalty... if (null.space.penalty) { ## then an extra penalty on the un-penalized space should be added ## first establish if there is a quick method for doing this nsm <- length(sml[[1]]$S) if (nsm==1) { ## only have quick method for single penalty S11 <- sml[[1]]$S[[1]][1,1] rank <- sml[[1]]$rank; p <- ncol(sml[[1]]$X) if (is.null(rank) || max(abs(sml[[1]]$S[[1]] - diag(c(rep(S11,rank),rep(0,p-rank))))) > abs(S11)*.Machine$double.eps^.8 ) need.full <- TRUE else { need.full <- FALSE ## matrix is already a suitable diagonal if (p>rank) for (i in 1:length(sml)) { sml[[i]]$S[[2]] <- diag(c(rep(0,rank),rep(1,p-rank))) sml[[i]]$rank[2] <- p-rank sml[[i]]$S.scale[2] <- 1 sml[[i]]$null.space.dim <- 0 } } } else need.full <- if (nsm > 0) TRUE else FALSE if (need.full) { St <- sml[[1]]$S[[1]] if (length(sml[[1]]$S)>1) for (i in 1:length(sml[[1]]$S)) St <- St + sml[[1]]$S[[i]] es <- eigen(St,symmetric=TRUE) ind <- es$values0) { ## there were constraints to absorb - need to untransform k<-ncol(X) if (inherits(qrc,"qr")) { indi <- attr(object,"indi") ## index of constrained parameters if (is.null(indi)) { if (sum(is.na(X))) { ind <- !is.na(rowSums(X)) X1 <- t(qr.qty(qrc,t(X[ind,,drop=FALSE]))[(j+1):k,,drop=FALSE]) ## XZ X <- matrix(NA,nrow(X),ncol(X1)) X[ind,] <- X1 } else { X <- t(qr.qty(qrc,t(X))[(j+1):k,,drop=FALSE]) } } else { ## only some parameters are subject to constraint nx <- length(indi) nc <- j;nz <- nx - nc if (sum(is.na(X))) { ind <- !is.na(rowSums(X)) if (nz>0) X[ind,indi[1:nz]]<-t(qr.qty(qrc,t(X[ind,indi,drop=FALSE]))[(nc+1):nx,]) X <- X[,-indi[(nz+1):nx]] X[!ind,] <- NA } else { if (nz>0) X[,indi[1:nz]]<-t(qr.qty(qrc,t(X[,indi,drop=FALSE]))[(nc+1):nx,,drop=FALSE]) X <- X[,-indi[(nz+1):nx]] } } } else if (inherits(qrc,"sweepDrop")) { ## Sweep and drop constraints. First element is index to drop. ## Remainder are constants to be swept out of remaining columns ## Actually better handled first (see above) #X <- X[,-qrc[1],drop=FALSE] - matrix(qrc[-1],nrow(X),ncol(X)-1,byrow=TRUE) } else if (qrc>0) { ## simple set to zero constraint X <- X[,-qrc] } else if (qrc<0) { ## params sum to zero X <- t(diff(t(X))) } } } ## apply any reparameterization that resulted from diagonalizing penalties ## in smoothCon ... if (!is.null(object$diagRP)) X <- X %*% object$diagRP ## drop columns eliminated by side-conditions... del.index <- attr(object,"del.index") if (!is.null(del.index)) X <- X[,-del.index,drop=FALSE] attr(X,"offset") <- offset X } ## end of PredictMat mgcv/R/gam.fit4.r0000644000176200001440000020105113561304416013205 0ustar liggesusers## (c) Simon N. Wood (2013-2015). Provided under GPL 2. ## Routines for gam estimation beyond exponential family. dDeta <- function(y,mu,wt,theta,fam,deriv=0) { ## What is available directly from the family are derivatives of the ## deviance and link w.r.t. mu. This routine converts these to the ## required derivatives of the deviance w.r.t. eta. ## deriv is the order of derivative of the smoothing parameter score ## required. ## This version is based on ratios of derivatives of links rather ## than raw derivatives of links. g2g = g''/g'^2, g3g = g'''/g'^3 etc r <- fam$Dd(y, mu, theta, wt, level=deriv) d <- list(Deta=0,Dth=0,Dth2=0,Deta2=0,EDeta2=0,Detath=0, Deta3=0,Deta2th=0,Detath2=0, Deta4=0,Deta3th=0,Deta2th2=0) if (fam$link=="identity") { ## don't waste time on transformation d$Deta <- r$Dmu;d$Deta2 <- r$Dmu2 d$EDeta2 <- r$EDmu2;d$Deta.Deta2 <- r$Dmu/r$Dmu2 d$Deta.EDeta2 <- r$Dmu/r$EDmu2 if (deriv>0) { d$Dth <- r$Dth; d$Detath <- r$Dmuth d$Deta3 <- r$Dmu3; d$Deta2th <- r$Dmu2th d$EDeta2th <- r$EDmu2th;d$EDeta3 <- r$EDmu3 } if (deriv>1) { d$Deta4 <- r$Dmu4; d$Dth2 <- r$Dth2; d$Detath2 <- r$Dmuth2 d$Deta2th2 <- r$Dmu2th2; d$Deta3th <- r$Dmu3th } } else { ig1 <- fam$mu.eta(fam$linkfun(mu)) ig12 <- ig1^2 g2g <- fam$g2g(mu) ## ig12 <- ig1^2;ig13 <- ig12 * ig1 d$Deta <- r$Dmu * ig1 d$Deta2 <- r$Dmu2*ig12 - r$Dmu*g2g*ig1 d$EDeta2 <- r$EDmu2*ig12 d$Deta.Deta2 <- r$Dmu/(r$Dmu2*ig1 - r$Dmu*g2g) d$Deta.EDeta2 <- r$Dmu/(r$EDmu2*ig1) if (deriv>0) { ig13 <- ig12 * ig1 d$Dth <- r$Dth d$Detath <- r$Dmuth * ig1 g3g <- fam$g3g(mu) d$Deta3 <- r$Dmu3*ig13 - 3*r$Dmu2 * g2g * ig12 + r$Dmu * (3*g2g^2 - g3g)*ig1 if (!is.null(r$EDmu3)) d$EDeta3 <- r$EDmu3*ig13 - 3*r$EDmu2 * g2g * ig12 ## EDmu=0 d$Deta2th <- r$Dmu2th*ig12 - r$Dmuth*g2g*ig1 if (!is.null(r$EDmu2th)) d$EDeta2th <- r$EDmu2th*ig12 ##- r$EDmuth*g2g*ig1 } if (deriv>1) { g4g <- fam$g4g(mu) d$Deta4 <- ig12^2*r$Dmu4 - 6*r$Dmu3*ig13*g2g + r$Dmu2*(15*g2g^2-4*g3g)*ig12 - r$Dmu*(15*g2g^3-10*g2g*g3g +g4g)*ig1 d$Dth2 <- r$Dth2 d$Detath2 <- r$Dmuth2 * ig1 d$Deta2th2 <- ig12*r$Dmu2th2 - r$Dmuth2*g2g*ig1 d$Deta3th <- ig13*r$Dmu3th - 3 *r$Dmu2th*g2g*ig12 + r$Dmuth*(3*g2g^2-g3g)*ig1 } } ## end of non identity good <- is.finite(d$Deta)&is.finite(d$Deta2) if (deriv>0) { if (length(theta)>1) good <- good&is.finite(rowSums(d$Dth))&is.finite(rowSums(d$Detath))& is.finite(rowSums(d$Deta2th))&is.finite(d$Deta3) else good <- good&is.finite(d$Dth)&is.finite(d$Detath)&is.finite(d$Deta2th)&is.finite(d$Deta3) if (deriv>1) { if (length(theta)==1) good <- good&is.finite(d$Dth2)&is.finite(d$Detath2)&is.finite(d$Deta2th2)& is.finite(d$Deta3th)&is.finite(d$Deta4) else good <- good&is.finite(rowSums(d$Dth2))&is.finite(rowSums(d$Detath2))&is.finite(rowSums(d$Deta2th2))& is.finite(rowSums(d$Deta3th))&is.finite(d$Deta4) } } d$good <- good d } ## dDeta fetad.test <- function(y,mu,wt,theta,fam,eps = 1e-7,plot=TRUE) { ## test family derivatives w.r.t. eta dd <- dDeta(y,mu,wt,theta,fam,deriv=2) dev <- fam$dev.resids(y, mu, wt,theta) mu1 <- fam$linkinv(fam$linkfun(mu)+eps) dev1 <- fam$dev.resids(y,mu1, wt,theta) Deta.fd <- (dev1-dev)/eps cat("Deta: rdiff = ",range(dd$Deta-Deta.fd)," cor = ",cor(dd$Deta,Deta.fd),"\n") plot(dd$Deta,Deta.fd);abline(0,1) nt <- length(theta) for (i in 1:nt) { th1 <- theta;th1[i] <- th1[i] + eps dev1 <- fam$dev.resids(y, mu, wt,th1) Dth.fd <- (dev1-dev)/eps um <- if (nt>1) dd$Dth[,i] else dd$Dth cat("Dth[",i,"]: rdiff = ",range(um-Dth.fd)," cor = ",cor(um,Dth.fd),"\n") plot(um,Dth.fd);abline(0,1) } ## second order up... dd1 <- dDeta(y,mu1,wt,theta,fam,deriv=2) Deta2.fd <- (dd1$Deta - dd$Deta)/eps cat("Deta2: rdiff = ",range(dd$Deta2-Deta2.fd)," cor = ",cor(dd$Deta2,Deta2.fd),"\n") plot(dd$Deta2,Deta2.fd);abline(0,1) Deta3.fd <- (dd1$Deta2 - dd$Deta2)/eps cat("Deta3: rdiff = ",range(dd$Deta3-Deta3.fd)," cor = ",cor(dd$Deta3,Deta3.fd),"\n") plot(dd$Deta3,Deta3.fd);abline(0,1) Deta4.fd <- (dd1$Deta3 - dd$Deta3)/eps cat("Deta4: rdiff = ",range(dd$Deta4-Deta4.fd)," cor = ",cor(dd$Deta4,Deta4.fd),"\n") plot(dd$Deta4,Deta4.fd);abline(0,1) ## and now the higher derivs wrt theta... ind <- 1:nt for (i in 1:nt) { th1 <- theta;th1[i] <- th1[i] + eps dd1 <- dDeta(y,mu,wt,th1,fam,deriv=2) Detath.fd <- (dd1$Deta - dd$Deta)/eps um <- if (nt>1) dd$Detath[,i] else dd$Detath cat("Detath[",i,"]: rdiff = ",range(um-Detath.fd)," cor = ",cor(um,Detath.fd),"\n") plot(um,Detath.fd);abline(0,1) Deta2th.fd <- (dd1$Deta2 - dd$Deta2)/eps um <- if (nt>1) dd$Deta2th[,i] else dd$Deta2th cat("Deta2th[",i,"]: rdiff = ",range(um-Deta2th.fd)," cor = ",cor(um,Deta2th.fd),"\n") plot(um,Deta2th.fd);abline(0,1) Deta3th.fd <- (dd1$Deta3 - dd$Deta3)/eps um <- if (nt>1) dd$Deta3th[,i] else dd$Deta3th cat("Deta3th[",i,"]: rdiff = ",range(um-Deta3th.fd)," cor = ",cor(um,Deta3th.fd),"\n") plot(um,Deta3th.fd);abline(0,1) ## now the 3 second derivative w.r.t. theta terms Dth2.fd <- (dd1$Dth - dd$Dth)/eps um <- if (nt>1) dd$Dth2[,ind] else dd$Dth2 er <- if (nt>1) Dth2.fd[,i:nt] else Dth2.fd cat("Dth2[",i,",]: rdiff = ",range(um-er)," cor = ",cor(as.numeric(um),as.numeric(er)),"\n") plot(um,er);abline(0,1) Detath2.fd <- (dd1$Detath - dd$Detath)/eps um <- if (nt>1) dd$Detath2[,ind] else dd$Detath2 er <- if (nt>1) Detath2.fd[,i:nt] else Detath2.fd cat("Detath2[",i,",]: rdiff = ",range(um-er)," cor = ",cor(as.numeric(um),as.numeric(er)),"\n") ## cat("Detath2[",i,",]: rdiff = ",range(dd$Detath2-Detath2.fd)," cor = ",cor(dd$Detath2,Detath2.fd),"\n") plot(um,er);abline(0,1) Deta2th2.fd <- (dd1$Deta2th - dd$Deta2th)/eps um <- if (nt>1) dd$Deta2th2[,ind] else dd$Deta2th2 er <- if (nt>1) Deta2th2.fd[,i:nt] else Deta2th2.fd cat("Deta2th2[",i,",]: rdiff = ",range(um-er)," cor = ",cor(as.numeric(um),as.numeric(er)),"\n") ## cat("Deta2th2[",i,",]: rdiff = ",range(dd$Deta2th2-Deta2th2.fd)," cor = ",cor(dd$Deta2th2,Deta2th2.fd),"\n") ind <- max(ind)+1:(nt-i) plot(um,er);abline(0,1) } } ## fetad.test corb <- function(x,z) { ## alternative to cor for measuring similarity of x and z, ## which is not scaling invariant. So 1 really means x and z ## are very close, not just linearly related. d <- x-z 1-mean(d^2)/(sd(x)*sd(z)) } fmud.test <- function(y,mu,wt,theta,fam,eps = 1e-7,plot=TRUE) { ## test family deviance derivatives w.r.t. mu ## copy to make debugging easier... Dd <- fam$Dd;dev.resids <- fam$dev.resids dd <- Dd(y, mu, theta, wt, level=2) dev <- dev.resids(y, mu, wt,theta) dev1 <- dev.resids(y, mu+eps, wt,theta) Dmu.fd <- (dev1-dev)/eps cat("Dmu: rdiff = ",range(dd$Dmu-Dmu.fd)," cor = ",corb(dd$Dmu,Dmu.fd),"\n") if (plot) { pch <- 19;cex <- .4 plot(dd$Dmu,Dmu.fd,pch=pch,cex=cex);abline(0,1,col=2) oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } nt <- length(theta) for (i in 1:nt) { th1 <- theta;th1[i] <- th1[i] + eps dev1 <- dev.resids(y, mu, wt,th1) Dth.fd <- (dev1-dev)/eps um <- if (nt>1) dd$Dth[,i] else dd$Dth cat("Dth[",i,"]: rdiff = ",range(um-Dth.fd)," cor = ",corb(um,Dth.fd),"\n") if (plot) { plot(um,Dth.fd,pch=pch,cex=cex);abline(0,1,col=2)} } ## second order up... dd1 <- Dd(y, mu+eps, theta, wt, level=2) Dmu2.fd <- (dd1$Dmu - dd$Dmu)/eps cat("Dmu2: rdiff = ",range(dd$Dmu2-Dmu2.fd)," cor = ",corb(dd$Dmu2,Dmu2.fd),"\n") if (plot) { plot(dd$Dmu2,Dmu2.fd,pch=pch,cex=cex);abline(0,1,col=2)} Dmu3.fd <- (dd1$Dmu2 - dd$Dmu2)/eps cat("Dmu3: rdiff = ",range(dd$Dmu3-Dmu3.fd)," cor = ",corb(dd$Dmu3,Dmu3.fd),"\n") if (plot) { plot(dd$Dmu3,Dmu3.fd,pch=pch,cex=cex);abline(0,1,col=2)} Dmu4.fd <- (dd1$Dmu3 - dd$Dmu3)/eps cat("Dmu4: rdiff = ",range(dd$Dmu4-Dmu4.fd)," cor = ",corb(dd$Dmu4,Dmu4.fd),"\n") if (plot) { plot(dd$Dmu4,Dmu4.fd,pch=pch,cex=cex);abline(0,1,col=2)} ## and now the higher derivs wrt theta ind <- 1:nt for (i in 1:nt) { th1 <- theta;th1[i] <- th1[i] + eps dd1 <- Dd(y, mu, th1, wt, level=2) Dmuth.fd <- (dd1$Dmu - dd$Dmu)/eps um <- if (nt>1) dd$Dmuth[,i] else dd$Dmuth cat("Dmuth[",i,"]: rdiff = ",range(um-Dmuth.fd)," cor = ",corb(um,Dmuth.fd),"\n") if (plot) { plot(um,Dmuth.fd,pch=pch,cex=cex);abline(0,1,col=2)} Dmu2th.fd <- (dd1$Dmu2 - dd$Dmu2)/eps um <- if (nt>1) dd$Dmu2th[,i] else dd$Dmu2th cat("Dmu2th[",i,"]: rdiff = ",range(um-Dmu2th.fd)," cor = ",corb(um,Dmu2th.fd),"\n") if (plot) { plot(um,Dmu2th.fd,pch=pch,cex=cex);abline(0,1,col=2)} if (!is.null(dd$EDmu2th)) { EDmu2th.fd <- (dd1$EDmu2 - dd$EDmu2)/eps um <- if (nt>1) dd$EDmu2th[,i] else dd$EDmu2th cat("EDmu2th[",i,"]: rdiff = ",range(um-EDmu2th.fd)," cor = ",corb(um,EDmu2th.fd),"\n") if (plot) { plot(um,EDmu2th.fd,pch=pch,cex=cex);abline(0,1,col=2)} } Dmu3th.fd <- (dd1$Dmu3 - dd$Dmu3)/eps um <- if (nt>1) dd$Dmu3th[,i] else dd$Dmu3th cat("Dmu3th[",i,"]: rdiff = ",range(um-Dmu3th.fd)," cor = ",corb(um,Dmu3th.fd),"\n") if (plot) { plot(um,Dmu3th.fd,pch=pch,cex=cex);abline(0,1,col=2)} ## now the 3 second derivative w.r.t. theta terms... Dth2.fd <- (dd1$Dth - dd$Dth)/eps um <- if (nt>1) dd$Dth2[,ind] else dd$Dth2 er <- if (nt>1) Dth2.fd[,i:nt] else Dth2.fd cat("Dth2[",i,",]: rdiff = ",range(um-er)," cor = ",corb(as.numeric(um),as.numeric(er)),"\n") if (plot) { plot(um,er,pch=pch,cex=cex);abline(0,1,col=2)} Dmuth2.fd <- (dd1$Dmuth - dd$Dmuth)/eps um <- if (nt>1) dd$Dmuth2[,ind] else dd$Dmuth2 er <- if (nt>1) Dmuth2.fd[,i:nt] else Dmuth2.fd cat("Dmuth2[",i,",]: rdiff = ",range(um-er)," cor = ",corb(as.numeric(um),as.numeric(er)),"\n") if (plot) { plot(um,er,pch=pch,cex=cex);abline(0,1,col=2)} Dmu2th2.fd <- (dd1$Dmu2th - dd$Dmu2th)/eps um <- if (nt>1) dd$Dmu2th2[,ind] else dd$Dmu2th2 er <- if (nt>1) Dmu2th2.fd[,i:nt] else Dmu2th2.fd cat("Dmu2th2[",i,",]: rdiff = ",range(um-er)," cor = ",corb(as.numeric(um),as.numeric(er)),"\n") if (plot) { plot(um,er,pch=pch,cex=cex);abline(0,1,col=2)} ind <- max(ind)+1:(nt-i) } } gam.fit4 <- function(x, y, sp, Eb,UrS=list(), weights = rep(1, nobs), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, nobs),U1=diag(ncol(x)), Mp=-1, family = gaussian(), control = gam.control(), deriv=2,gamma=1, scale=1,scoreType="REML",null.coef=rep(0,ncol(x)),...) { ## Routine for fitting GAMs beyond exponential family. ## Inputs as gam.fit3 except that family is of class "extended.family", while ## sp contains the vector of extended family parameters, followed by the log smoothing parameters, ## followed by the log scale parameter if scale < 0 ## some families have second derivative of deviance, and hence iterative weights ## very close to zero for some data. This can lead to poorly scaled sqrt(w)z ## and it is better to base everything on wz... if (is.null(family$use.wz)) family$use.wz <- FALSE if (family$n.theta>0) { ## there are extra parameters to estimate ind <- 1:family$n.theta theta <- sp[ind] ## parameters of the family family$putTheta(theta) sp <- sp[-ind] ## log smoothing parameters } else theta <- family$getTheta() ## fixed value ## penalized <- if (length(UrS)>0) TRUE else FALSE if (scale>0) scale.known <- TRUE else { ## unknown scale parameter, trial value supplied as ## final element of sp. scale.known <- FALSE nsp <- length(sp) scale <- exp(sp[nsp]) sp <- sp[-nsp] } x <- as.matrix(x) nSp <- length(sp) rank.tol <- .Machine$double.eps*100 ## tolerance to use for rank deficiency q <- ncol(x) n <- nobs <- nrow(x) xnames <- dimnames(x)[[2]] ynames <- if (is.matrix(y)) rownames(y) else names(y) ## Now a stable re-parameterization is needed.... if (length(UrS)) { grderiv <- if (scoreType=="EFS") 1 else deriv rp <- gam.reparam(UrS,sp,grderiv) T <- diag(q) T[1:ncol(rp$Qs),1:ncol(rp$Qs)] <- rp$Qs T <- U1%*%T ## new params b'=T'b old params null.coef <- t(T)%*%null.coef if (!is.null(start)) start <- t(T)%*%start ## form x%*%T in parallel x <- .Call(C_mgcv_pmmult2,x,T,0,0,control$nthreads) rS <- list() for (i in 1:length(UrS)) { rS[[i]] <- rbind(rp$rS[[i]],matrix(0,Mp,ncol(rp$rS[[i]]))) } ## square roots of penalty matrices in current parameterization Eb <- Eb%*%T ## balanced penalty matrix rows.E <- q-Mp Sr <- cbind(rp$E,matrix(0,nrow(rp$E),Mp)) St <- rbind(cbind(rp$S,matrix(0,nrow(rp$S),Mp)),matrix(0,Mp,q)) } else { grderiv <- 0 T <- diag(q); St <- matrix(0,q,q) rSncol <- rows.E <- Eb <- Sr <- 0 rS <- list(0) rp <- list(det=0,det1 = 0,det2 = 0,fixed.penalty=FALSE) } ## re-parameterization complete. Initialization.... nvars <- ncol(x) if (nvars==0) stop("emtpy models not available") if (is.null(weights)) weights <- rep.int(1, nobs) if (is.null(offset)) offset <- rep.int(0, nobs) linkinv <- family$linkinv valideta <- family$valideta validmu <- family$validmu dev.resids <- family$dev.resids ## need an initial `null deviance' to test for initial divergence... ## if (!is.null(start)) null.coef <- start - can be on edge of feasible - not good null.eta <- as.numeric(x%*%null.coef + as.numeric(offset)) ## call the families initialization code... if (is.null(mustart)) { eval(family$initialize) mukeep <- NULL } else { mukeep <- mustart eval(family$initialize) #mustart <- mukeep } old.pdev <- sum(dev.resids(y, linkinv(null.eta), weights,theta)) + t(null.coef)%*%St%*%null.coef if (!is.null(start)) { ## check it's at least better than null.coef pdev <- sum(dev.resids(y, linkinv(x%*%start+as.numeric(offset)), weights,theta)) + t(start)%*%St%*%start if (pdev>old.pdev) start <- mukeep <- etastart <- NULL } coefold <- null.coef ## set to default, may be replaced below etaold <- x %*% coefold + offset if (!is.null(mukeep)) mustart <- mukeep ## and now finalize initialization of mu and eta... eta <- if (!is.null(etastart)) etastart else if (!is.null(start)) if (length(start) != nvars) stop("Length of start should equal ", nvars, " and correspond to initial coefs for ", deparse(xnames)) else { coefold <- start etaold <- offset + as.vector(if (NCOL(x) == 1) x * start else x %*% start) } else family$linkfun(mustart) mu <- linkinv(eta) conv <- boundary <- FALSE dd <- dDeta(y,mu,weights,theta,family,0) ## derivatives of deviance w.r.t. eta w <- dd$Deta2 * .5 wz <- w*(eta-offset) - .5*dd$Deta z <- (eta-offset) - dd$Deta.Deta2 good <- is.finite(z)&is.finite(w) zg <- rep(0,max(dim(x))) for (iter in 1:control$maxit) { ## start of main fitting iteration if (control$trace) cat(iter," ") if (control$trace&sum(!good)>0) cat("\n",sum(!good)," not good\n") if (sum(!good)) { use.wy <- TRUE good <- is.finite(w)&is.finite(wz) z[!is.finite(z)] <- 0 ## avoid NaN in .C call - unused anyway } else use.wy <- family$use.wz if (sum(good)==0) stop("no good data in iteration") ng <- sum(good) zg[1:ng] <- z[good] ## ensure that y dimension large enough for coefs oo <- .C(C_pls_fit1, y=as.double(zg),X=as.double(x[good,]),w=as.double(w[good]),wy = as.double(wz[good]), E=as.double(Sr),Es=as.double(Eb),n=as.integer(ng), q=as.integer(ncol(x)),rE=as.integer(rows.E),eta=as.double(z), penalty=as.double(1),rank.tol=as.double(rank.tol), nt=as.integer(control$nthreads),use.wy=as.integer(use.wy)) posdef <- oo$n >= 0 if (!posdef) { ## then problem is indefinite - switch to +ve weights for this step if (control$trace) cat("**using positive weights\n") # problem is that Fisher can be very poor for zeroes ## index weights that are finite and positive good <- is.finite(dd$Deta2) good[good] <- dd$Deta2[good]>0 w[!good] <- 0 wz <- w*(eta-offset) - .5*dd$Deta z <- (eta-offset) - dd$Deta.Deta2 good <- is.finite(z)&is.finite(w) if (sum(!good)) { use.wy <- TRUE good <- is.finite(w)&is.finite(wz) z[!is.finite(z)] <- 0 ## avoid NaN in .C call - unused anyway } else use.wy <- family$use.wz ng <- sum(good) zg[1:ng] <- z[good] ## ensure that y dimension large enough for coefs oo <- .C(C_pls_fit1, ##C_pls_fit1, y=as.double(zg),X=as.double(x[good,]),w=as.double(w[good]),wy = as.double(wz[good]), E=as.double(Sr),Es=as.double(Eb),n=as.integer(ng), q=as.integer(ncol(x)),rE=as.integer(rows.E),eta=as.double(z), penalty=as.double(1),rank.tol=as.double(rank.tol), nt=as.integer(control$nthreads),use.wy=as.integer(use.wy)) } start <- oo$y[1:ncol(x)] ## current coefficient estimates penalty <- oo$penalty ## size of penalty eta <- drop(x%*%start) ## the linear predictor (less offset) if (any(!is.finite(start))) { ## test for breakdown conv <- FALSE warning("Non-finite coefficients at iteration ", iter) return(list(REML=NA)) ## return immediately signalling failure } mu <- linkinv(eta <- eta + offset) dev <- sum(dev.resids(y, mu, weights,theta)) ## now step halve under non-finite deviance... if (!is.finite(dev)) { if (is.null(coefold)) { 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 coefold <- null.coef etaold <- null.eta } ii <- 1 while (!is.finite(dev)) { if (ii > control$maxit) stop("inner loop 1; can't correct step size") ii <- ii + 1 start <- (start + coefold)/2 eta <- (eta + etaold)/2 mu <- linkinv(eta) dev <- sum(dev.resids(y, mu, weights,theta)) } boundary <- TRUE penalty <- t(start)%*%St%*%start ## 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))) { ii <- 1 while (!(valideta(eta) && validmu(mu))) { if (ii > control$maxit) stop("inner loop 2; can't correct step size") ii <- ii + 1 start <- (start + coefold)/2 eta <- (eta + etaold)/2 mu <- linkinv(eta) } boundary <- TRUE dev <- sum(dev.resids(y, mu, weights,theta)) penalty <- t(start)%*%St%*%start ## need to reset penalty too if (control$trace) cat("Step halved: new deviance =", dev, "\n") } ## end of invalid mu/eta handling ## now check for divergence of penalized deviance.... pdev <- dev + penalty ## the penalized deviance if (control$trace) cat("penalized deviance =", pdev, "\n") div.thresh <- 10*(.1+abs(old.pdev))*.Machine$double.eps^.5 if (pdev-old.pdev>div.thresh) { ## solution diverging ii <- 1 ## step halving counter if (iter==1) { ## immediate divergence, need to shrink towards zero etaold <- null.eta; coefold <- 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 start <- (start + coefold)/2 eta <- (eta + etaold)/2 mu <- linkinv(eta) dev <- sum(dev.resids(y, mu, weights,theta)) penalty <- t(start)%*%St%*%start pdev <- dev + penalty ## the penalized deviance if (control$trace) cat("Step halved: new penalized deviance =", pdev, "\n") } } ## end of pdev divergence if (scoreType=="EFS"&&family$n.theta>0) { ## there are theta parameters to estimate... scale1 <- if (!is.null(family$scale)) family$scale else scale if (family$n.theta>0||scale<0) theta <- estimate.theta(theta,family,y,mu,scale=scale1,wt=weights,tol=1e-7) if (!is.null(family$scale) && family$scale<0) { scale <- exp(theta[family$n.theta+1]) theta <- theta[1:family$n.theta] } family$putTheta(theta) } ## get new weights and pseudodata (needed now for grad testing)... dd <- dDeta(y,mu,weights,theta,family,0) ## derivatives of deviance w.r.t. eta w <- dd$Deta2 * .5; wz <- w*(eta-offset) - .5*dd$Deta z <- (eta-offset) - dd$Deta.Deta2 good <- is.finite(z)&is.finite(w) ## convergence testing... if (posdef && abs(pdev - old.pdev)/(0.1 + abs(pdev)) < control$epsilon) { ## Need to check coefs converged adequately, to ensure implicit differentiation ## ok. Testing coefs unchanged is problematic under rank deficiency (not guaranteed to ## drop same parameter every iteration!) grad <- 2 * t(x[good,,drop=FALSE])%*%((w[good]*(x%*%start)[good]-wz[good]))+ 2*St%*%start if (max(abs(grad)) > control$epsilon*max(abs(start+coefold))/2) { old.pdev <- pdev ## not converged quite enough coef <- coefold <- start etaold <- eta ##muold <- mu } else { ## converged conv <- TRUE coef <- start break } } else { ## not converged old.pdev <- pdev coef <- coefold <- start etaold <- eta } if (scoreType=="EFS"&&family$n.theta>0) { ## now recompute pdev with new theta, otherwise step control won't work at next iteration dev <- sum(dev.resids(y, mu, weights,theta)) old.pdev <- pdev <- dev + penalty } } ## end of main loop ## so at this stage the model has been fully estimated coef <- as.numeric(T %*% coef) ## now obtain derivatives, if these are needed... check.derivs <- FALSE while (check.derivs) { ## debugging code to check derivatives eps <- 1e-7 fmud.test(y,mu,weights,theta,family,eps = eps) fetad.test(y,mu,weights,theta,family,eps = eps) } dd <- dDeta(y,mu,weights,theta,family,deriv) w <- dd$Deta2 * .5 z <- (eta-offset) - dd$Deta.Deta2 ## - .5 * dd$Deta[good] / w wf <- pmax(0,dd$EDeta2 * .5) ## Fisher type weights wz <- w*(eta-offset) - 0.5*dd$Deta ## Wz finite when w==0 good <- is.finite(wz)&is.finite(w)&dd$good if (sum(good)==0) stop("not enough finite derivatives") residuals <- z - (eta - offset) residuals[!is.finite(residuals)] <- NA z[!is.finite(z)] <- 0 ## avoid passing NA etc to C code ntot <- length(theta) + length(sp) rSncol <- unlist(lapply(UrS,ncol)) ## Now drop any elements of dd that have been dropped in fitting... if (sum(!good)>0) { ## drop !good from fields of dd, weights and pseudodata z <- z[good]; w <- w[good]; wz <- wz[good]; wf <- wf[good] dd$Deta <- dd$Deta[good];dd$Deta2 <- dd$Deta2[good] dd$EDeta2 <- dd$EDeta2[good] if (deriv>0) dd$Deta3 <- dd$Deta3[good] if (deriv>1) dd$Deta4 <- dd$Deta4[good] if (length(theta)>1) { if (deriv>0) { dd$Dth <- dd$Dth[good,]; dd$Detath <- dd$Detath[good,]; dd$Deta2th <- dd$Deta2th[good,] if (deriv>1) { dd$Detath2 <- dd$Detath2[good,]; dd$Deta3th <- dd$Deta3th[good,] dd$Deta2th2 <- dd$Deta2th2[good,];dd$Dth2 <- dd$Dth2[good,] } } } else { if (deriv>0) { dd$Dth <- dd$Dth[good]; dd$Detath <- dd$Detath[good]; dd$Deta2th <- dd$Deta2th[good] if (deriv>1) { dd$Detath2 <- dd$Detath2[good]; dd$Deta3th <- dd$Deta3th[good] dd$Deta2th2 <- dd$Deta2th2[good]; dd$Dth2 <- dd$Dth2[good] } } } } ## gdi.type should probably be computed after dropping via good gdi.type <- if (any(abs(w)<.Machine$double.xmin*1e20)||any(!is.finite(z))) 1 else 0 if (scoreType=="EFS") scoreType <- "REML" oo <- .C(C_gdi2, X=as.double(x[good,]),E=as.double(Sr),Es=as.double(Eb),rS=as.double(unlist(rS)), U1 = as.double(U1),sp=as.double(exp(sp)),theta=as.double(theta), z=as.double(z),w=as.double(w),wz=as.double(wz),wf=as.double(wf),Dth=as.double(dd$Dth), Det=as.double(dd$Deta), Det2=as.double(dd$Deta2),Dth2=as.double(dd$Dth2),Det.th=as.double(dd$Detath), Det2.th=as.double(dd$Deta2th),Det3=as.double(dd$Deta3),Det.th2 = as.double(dd$Detath2), Det4 = as.double(dd$Deta4),Det3.th=as.double(dd$Deta3th), Deta2.th2=as.double(dd$Deta2th2), beta=as.double(coef),b1=as.double(rep(0,ntot*ncol(x))),w1=as.double(rep(0,ntot*length(z))), D1=as.double(rep(0,ntot)),D2=as.double(rep(0,ntot^2)), P=as.double(0),P1=as.double(rep(0,ntot)),P2 = as.double(rep(0,ntot^2)), ldet=as.double(1-2*(scoreType=="ML")),ldet1 = as.double(rep(0,ntot)), ldet2 = as.double(rep(0,ntot^2)), rV=as.double(rep(0,ncol(x)^2)), rank.tol=as.double(.Machine$double.eps^.75),rank.est=as.integer(0), n=as.integer(sum(good)),q=as.integer(ncol(x)),M=as.integer(nSp), n.theta=as.integer(length(theta)), Mp=as.integer(Mp),Enrow=as.integer(rows.E), rSncol=as.integer(rSncol),deriv=as.integer(deriv), fixed.penalty = as.integer(rp$fixed.penalty),nt=as.integer(control$nthreads), type=as.integer(gdi.type),dVkk=as.double(rep(0,nSp^2))) rV <- matrix(oo$rV,ncol(x),ncol(x)) ## rV%*%t(rV)*scale gives covariance matrix rV <- T %*% rV ## derivatives of coefs w.r.t. sps etc... db.drho <- if (deriv) T %*% matrix(oo$b1,ncol(x),ntot) else NULL dw.drho <- if (deriv) matrix(oo$w1,length(z),ntot) else NULL Kmat <- matrix(0,nrow(x),ncol(x)) Kmat[good,] <- oo$X ## rV%*%t(K)%*%(sqrt(wf)*X) = F; diag(F) is edf array D2 <- matrix(oo$D2,ntot,ntot); ldet2 <- matrix(oo$ldet2,ntot,ntot) bSb2 <- matrix(oo$P2,ntot,ntot) ## compute the REML score... ls <- family$ls(y,weights,theta,scale) nt <- length(theta) lsth1 <- ls$lsth1[1:nt]; lsth2 <- as.matrix(ls$lsth2)[1:nt,1:nt] ## exclude any derivs w.r.t log scale here REML <- ((dev+oo$P)/(2*scale) - ls$ls)/gamma + (oo$ldet - rp$det)/2 - as.numeric(scoreType=="REML") * Mp * (log(2*pi*scale)/2-log(gamma)/2) REML1 <- REML2 <- NULL if (deriv) { det1 <- oo$ldet1 if (nSp) { ind <- 1:nSp + length(theta) det1[ind] <- det1[ind] - rp$det1 } REML1 <- ((oo$D1+oo$P1)/(2*scale) - c(lsth1,rep(0,length(sp))))/gamma + (det1)/2 if (deriv>1) { ls2 <- D2*0;ls2[1:nt,1:nt] <- lsth2 if (nSp) ldet2[ind,ind] <- ldet2[ind,ind] - rp$det2 REML2 <- ((D2+bSb2)/(2*scale) - ls2)/gamma + ldet2/2 } } if (!scale.known&&deriv) { ## need derivatives wrt log scale, too Dp <- dev + oo$P dlr.dlphi <- (-Dp/(2 *scale) - ls$lsth1[nt+1])/gamma - Mp/2 d2lr.d2lphi <- (Dp/(2*scale) - ls$lsth2[nt+1,nt+1])/gamma d2lr.dspphi <- -(oo$D1+oo$P1)/(2*scale*gamma) d2lr.dspphi[1:nt] <- d2lr.dspphi[1:nt] - ls$lsth2[nt+1,1:nt]/gamma REML1 <- c(REML1,dlr.dlphi) if (deriv==2) { REML2 <- rbind(REML2,as.numeric(d2lr.dspphi)) REML2 <- cbind(REML2,c(as.numeric(d2lr.dspphi),d2lr.d2lphi)) } } nth <- length(theta) if (deriv>0&&family$n.theta==0&&nth>0) { ## need to drop derivs for fixed theta REML1 <- REML1[-(1:nth)] if (deriv>1) REML2 <- REML2[-(1:nth),-(1:nth)] db.drho <- db.drho[,-(1:nth),drop=FALSE] } names(coef) <- xnames names(residuals) <- ynames wtdmu <- sum(weights * y)/sum(weights) ## has to then be corrected when this is incorrect ## wtdmu <- sum(weights * mu)/sum(weights) ## changed from y nulldev <- sum(dev.resids(y, rep(wtdmu,length(y)), weights)) ## this will be corrected in family postproc n.ok <- nobs - sum(weights == 0) nulldf <- n.ok ww <- wt <- rep.int(0, nobs) wt[good] <- wf ww[good] <- w if (deriv && nrow(dw.drho)!=nrow(x)) { w1 <- dw.drho dw.drho <- matrix(0,nrow(x),ncol(w1)) dw.drho[good,] <- w1 } aic.model <- family$aic(y, mu, theta, weights, dev) # note: incomplete 2*edf needs to be added list(coefficients = coef,residuals=residuals,fitted.values = mu, family=family, linear.predictors = eta,deviance=dev, null.deviance=nulldev,iter=iter, weights=wt, ## note that these are Fisher type weights prior.weights=weights, working.weights = ww, ## working weights df.null = nulldf, y = y, converged = conv, boundary = boundary, REML=REML,REML1=REML1,REML2=REML2, rV=rV,db.drho=db.drho,dw.drho=dw.drho, scale.est=scale,reml.scale=scale, aic=aic.model, rank=oo$rank.est, K=Kmat,control=control, dVkk = matrix(oo$dVkk,nSp,nSp),ldetS1 = if (grderiv) rp$det1 else 0 #,D1=oo$D1,D2=D2, #ldet=oo$ldet,ldet1=oo$ldet1,ldet2=ldet2, #bSb=oo$P,bSb1=oo$P1,bSb2=bSb2, #ls=ls$ls,ls1=ls$lsth1,ls2=ls$lsth2 ) } ## gam.fit4 efsudr <- function(x,y,lsp,Eb,UrS,weights,family,offset=0,start=NULL,etastart=NULL,mustart=NULL, U1=diag(ncol(x)), intercept = TRUE,scale=1,Mp=-1,control=gam.control(),n.true=-1,...) { ## Extended Fellner-Schall method for regular and extended families, ## with PIRLS performed by gam.fit3/4. ## tr(S^-S_j) is returned by ldetS1, rV %*% t(rV)*scale is ## cov matrix. I think b'S_jb will need to be computed here. nsp <- length(UrS) if (inherits(family,"extended.family")) { spind <- family$n.theta + 1:nsp thind <- if (family$n.theta>0) 1:family$n.theta else rep(0,0) } else { thind <- rep(0,0) spind <- 1:nsp ## index of smoothing params in lsp } estimate.scale <- (length(lsp)>max(spind)) lsp[spind] <- lsp[spind] + 2.5 mult <- 1 fit <- gam.fit3(x=x, y=y, sp=lsp, Eb=Eb,UrS=UrS, weights = weights, start = start, offset = offset,U1=U1, Mp=Mp, family = family, control = control, intercept = intercept,deriv=0, gamma=1,scale=scale,scoreType="EFS", n.true=n.true,...) if (length(thind)>0) lsp[thind] <- family$getTheta() if (estimate.scale) lsp[length(lsp)] <- log(fit$scale) ## Also need scale estimate. OK from gam.fit3, but gam.fit4 version probably needs correcting ## for edf, as obtained via MLE. p <- ncol(x) n <- nrow(x) score.hist <- rep(0,200) bSb <- trVS <- rep(0,nsp) for (iter in 1:200) { start <- fit$coefficients Y <- U1[,1:(ncol(U1)-Mp)] ## penalty range space ## project coefs and rV to Y, since this is space of UrS[[i]] Yb <- drop(t(Y)%*%start) rV <- t(fit$rV) ## so t(rV)%*%rV*scale is cov matrix rVY <- rV %*% Y ## ith penalty is UrS[[i]]%*%t(UrS[[i]])... for (i in 1:length(UrS)) { xx <- Yb %*% UrS[[i]] bSb[i] <- sum(xx^2) xx <- rVY %*% UrS[[i]] trVS[i] <- sum(xx^2) } edf <- p - sum(trVS*exp(lsp[spind])) if (inherits(family,"extended.family")&&estimate.scale) { fit$scale <- fit$scale*n/(n-edf) ## correct for edf. } a <- pmax(0,fit$ldetS1*exp(-lsp[spind]) - trVS) ## NOTE: double check scaling here phi <- if (estimate.scale) fit$scale else scale r <- a/pmax(0,bSb)*phi r[a==0&bSb==0] <- 1 r[!is.finite(r)] <- 1e6 lsp1 <- lsp lsp1[spind] <- pmin(lsp[spind] + log(r)*mult,control$efs.lspmax) max.step <- max(abs(lsp1-lsp)) old.reml <- fit$REML fit <- gam.fit3(x=x, y=y, sp=lsp1, Eb=Eb,UrS=UrS, weights = weights, start = start, offset = offset,U1=U1, Mp=Mp, family = family, control = control, intercept = intercept,deriv=0,mustart=mustart, gamma=1,scale=scale,scoreType="EFS", n.true=n.true,...) if (length(thind)>0) lsp1[thind] <- family$getTheta() if (estimate.scale) lsp1[length(lsp)] <- log(fit$scale) ## some step length control... if (fit$REML<=old.reml) { ## improvement if (max.step<.05) { ## consider step extension (near optimum) lsp2 <- lsp lsp2[spind] <- pmin(lsp[spind] + log(r)*mult*2,control$efs.lspmax) ## try extending step... fit2 <- gam.fit3(x=x, y=y, sp=lsp2, Eb=Eb,UrS=UrS, weights = weights, start = start, offset = offset,U1=U1, Mp=Mp, family = family, control = control, intercept = intercept,deriv=0,mustart=mustart, gamma=1,scale=scale,scoreType="EFS", n.true=n.true,...) if (length(thind)>0) lsp2[thind] <- family$getTheta() if (estimate.scale) lsp2[length(lsp)] <- log(fit$scale) if (fit2$REML < fit$REML) { ## improvement - accept extension fit <- fit2;lsp <- lsp2 mult <- mult * 2 } else { ## accept old step lsp <- lsp1 } } else lsp <- lsp1 } else { ## no improvement while (fit$REML > old.reml&&mult>1) { ## don't contract below 1 as update doesn't have to improve REML mult <- mult/2 ## contract step lsp1 <- lsp lsp1[spind] <- pmin(lsp[spind] + log(r)*mult,control$efs.lspmax) fit <- gam.fit3(x=x, y=y, sp=lsp1, Eb=Eb,UrS=UrS, weights = weights, start = start, offset = offset,U1=U1, Mp=Mp, family = family, control = control, intercept = intercept,deriv=0,mustart=mustart, gamma=1,scale=scale,scoreType="EFS", n.true=n.true,...) if (length(thind)>0) lsp1[thind] <- family$getTheta() if (estimate.scale) lsp1[length(lsp)] <- log(fit$scale) } lsp <- lsp1 if (mult<1) mult <- 1 } score.hist[iter] <- fit$REML ## break if EFS step small and REML change negligible over last 3 steps. if (iter>3 && max.step<.05 && max(abs(diff(score.hist[(iter-3):iter])))0) TRUE else FALSE nSp <- length(lsp) q <- ncol(x) nobs <- length(y) if (penalized) { Eb <- attr(Sl,"E") ## balanced penalty sqrt ## the stability reparameterization + log|S|_+ and derivs... rp <- ldetS(Sl,rho=lsp,fixed=rep(FALSE,length(lsp)),np=q,root=TRUE) x <- Sl.repara(rp$rp,x) ## apply re-parameterization to x #x <- Sl.repa(rp$rp,x,r=-1) Eb <- Sl.repara(rp$rp,Eb) ## root balanced penalty #Eb <- Sl.repa(rp$rp,Eb,r=-1) St <- crossprod(rp$E) ## total penalty matrix E <- rp$E ## root total penalty attr(E,"use.unscaled") <- TRUE ## signal initialization code that E not to be further scaled if (!is.null(start)) start <- Sl.repara(rp$rp,start) ## re-para start #if (!is.null(start)) start <- Sl.repa(rp$rp,start,l=1) ## re-para start ## NOTE: it can be that other attributes need re-parameterization here ## this should be done in 'family$initialize' - see mvn for an example. } else { ## unpenalized so no derivatives required deriv <- 0 rp <- list(ldetS=0,rp=list()) St <- matrix(0,q,q) E <- matrix(0,0,q) ## can be needed by initialization code } ## now call initialization code, but make sure that any ## supplied 'start' vector is not overwritten... start0 <- start ## Assumption here is that the initialization code is fine with ## re-parameterized x... eval(family$initialize) if (!is.null(start0)) start <- start0 coef <- as.numeric(start) if (is.null(weights)) weights <- rep.int(1, nobs) if (is.null(offset)) offset <- rep.int(0, nobs) ## get log likelihood, grad and Hessian (w.r.t. coefs - not s.p.s) ... llf <- family$ll ll <- llf(y,x,coef,weights,family,offset=offset,deriv=1) ll0 <- ll$l - (t(coef)%*%St%*%coef)/2 rank.checked <- FALSE ## not yet checked the intrinsic rank of problem rank <- q;drop <- NULL eigen.fix <- FALSE converged <- FALSE check.deriv <- FALSE; eps <- 1e-5 drop <- NULL;bdrop <- rep(FALSE,q) ## by default nothing dropped perturbed <- 0 ## counter for number of times perturbation tried on possible saddle for (iter in 1:(2*control$maxit)) { ## main iteration ## get Newton step... if (check.deriv) { ## code for checking derivatives when debugging fdg <- ll$lb*0; fdh <- ll$lbb*0 for (k in 1:length(coef)) { coef1 <- coef;coef1[k] <- coef[k] + eps ll.fd <- llf(y,x,coef1,weights,family,offset=offset,deriv=1) fdg[k] <- (ll.fd$l-ll$l)/eps fdh[,k] <- (ll.fd$lb-ll$lb)/eps } } ## derivative checking end grad <- ll$lb - St%*%coef Hp <- -ll$lbb+St D <- diag(Hp) if (sum(!is.finite(D))>0) stop("non finite values in Hessian") if (min(D)<=0) { ## 2/2/19 replaces any D<0 indicating indef Dthresh <- max(D)*sqrt(.Machine$double.eps) if (-min(D) < Dthresh) { ## could be indef or +ve semi def indefinite <- FALSE D[D0]),max(ev)*1e-6)*mult mult <- mult*10 ev[ev0) { ## limit step length to .1 of coef length s.norm <- sqrt(sum(step^2)) c.norm <- sqrt(c.norm) if (s.norm > .1*c.norm) step <- step*0.1*c.norm/s.norm } ## try the Newton step... coef1 <- coef + step ll <- llf(y,x,coef1,weights,family,offset=offset,deriv=1) ll1 <- ll$l - (t(coef1)%*%St%*%coef1)/2 khalf <- 0;fac <- 2 while ((!is.finite(ll1)||ll1 < ll0) && khalf < 25) { ## step halve until it succeeds... step <- step/fac;coef1 <- coef + step ll <- llf(y,x,coef1,weights,family,offset=offset,deriv=0) ll1 <- ll$l - (t(coef1)%*%St%*%coef1)/2 if (is.finite(ll1)&&ll1>=ll0) { ll <- llf(y,x,coef1,weights,family,offset=offset,deriv=1) } else { ## abort if step has made no difference if (max(abs(coef1-coef))==0) khalf <- 100 } khalf <- khalf + 1 if (khalf>5) fac <- 5 } ## end step halve if (!is.finite(ll1) || ll1 < ll0) { ## switch to steepest descent... step <- -.5*drop(grad)*mean(abs(coef))/mean(abs(grad)) khalf <- 0 } while ((!is.finite(ll1)||ll1 < ll0) && khalf < 25) { ## step cut until it succeeds... step <- step/10;coef1 <- coef + step ll <- llf(y,x,coef1,weights,family,offset=offset,deriv=0) ll1 <- ll$l - (t(coef1)%*%St%*%coef1)/2 if (is.finite(ll1)&&ll1>=ll0) { ll <- llf(y,x,coef1,weights,family,offset=offset,deriv=1) } else { ## abort if step has made no difference if (max(abs(coef1-coef))==0) khalf <- 100 } khalf <- khalf + 1 } if ((is.finite(ll1)&&ll1 >= ll0)||iter==control$maxit) { ## step ok. Accept and test coef <- coef + step ## convergence test... ok <- (iter==control$maxit||(abs(ll1-ll0) < control$epsilon*abs(ll0) && max(abs(grad)) < .Machine$double.eps^.5*abs(ll0))) if (ok) { ## appears to have converged if (indefinite) { ## not a well defined maximum if (perturbed==5) stop("indefinite penalized likelihood in gam.fit5 ") if (iter<4||rank.checked) { perturbed <- perturbed + 1 coef <- coef*(1+(runif(length(coef))*.02-.01)*perturbed) + (runif(length(coef)) - 0.5 ) * mean(abs(coef))*1e-5*perturbed ll <- llf(y,x,coef,weights,family,offset=offset,deriv=1) ll0 <- ll$l - (t(coef)%*%St%*%coef)/2 } else { rank.checked <- TRUE if (penalized) { Sb <- crossprod(Eb) ## balanced penalty Hb <- -ll$lbb/norm(ll$lbb,"F")+Sb/norm(Sb,"F") ## balanced penalized hessian } else Hb <- -ll$lbb/norm(ll$lbb,"F") ## apply pre-conditioning, otherwise badly scaled problems can result in ## wrong coefs being dropped... D <- abs(diag(Hb)) D[D<1e-50] <- 1;D <- D^-.5 Hb <- t(D*Hb)*D qrh <- qr(Hb,LAPACK=TRUE) rank <- Rrank(qr.R(qrh)) if (rank < q) { ## rank deficient. need to drop and continue to adjust other params drop <- sort(qrh$pivot[(rank+1):q]) ## set these params to zero bdrop <- 1:q %in% drop ## TRUE FALSE version ## now drop the parameters and recompute ll0... lpi <- attr(x,"lpi") xat <- attributes(x) xat$dim <- xat$dimnames <- NULL coef <- coef[-drop] St <- St[-drop,-drop] x <- x[,-drop] ## dropping columns from model matrix if (!is.null(lpi)) { ## need to adjust column indexes as well ii <- (1:q)[!bdrop];ij <- rep(NA,q) ij[ii] <- 1:length(ii) ## col i of old model matrix is col ij[i] of new for (i in 1:length(lpi)) { lpi[[i]] <- ij[lpi[[i]][!(lpi[[i]]%in%drop)]] # drop and shuffle up } } ## lpi adjustment done if (length(xat)>0) for (i in 1:length(xat)) attr(x,names(xat)[i]) <- xat[[i]] attr(x,"lpi") <- lpi attr(x,"drop") <- drop ## useful if family has precomputed something from x ll <- llf(y,x,coef,weights,family,offset=offset,deriv=1) ll0 <- ll$l - (t(coef)%*%St%*%coef)/2 } } } else { ## not indefinite really converged converged <- TRUE break } } else ll0 <- ll1 ## step ok but not converged yet } else { ## step failed. converged <- FALSE if (is.null(drop)) bdrop <- rep(FALSE,q) warning(paste("step failed: max abs grad =",max(abs(grad)))) break } } ## end of main fitting iteration ## at this stage the Hessian (of pen lik. w.r.t. coefs) should be +ve semi definite, ## so that the pivoted Choleski factor should exist... if (iter == 2*control$maxit&&converged==FALSE) warning(gettextf("iteration limit reached: max abs grad = %g",max(abs(grad)))) ldetHp <- 2*sum(log(diag(L))) - 2 * sum(log(D)) ## log |Hp| if (!is.null(drop)) { ## create full version of coef with zeros for unidentifiable fcoef <- rep(0,length(bdrop));fcoef[!bdrop] <- coef } else fcoef <- coef dVkk <- d1l <- d2l <- d1bSb <- d2bSb <- d1b <- d2b <- d1ldetH <- d2ldetH <- d1b <- d2b <- NULL if (deriv>0) { ## Implicit differentiation for derivs... m <- nSp d1b <- matrix(0,rank,m) Sib <- Sl.termMult(rp$Sl,fcoef,full=TRUE) ## list of penalties times coefs if (nSp) for (i in 1:m) d1b[,i] <- -D*(backsolve(L,forwardsolve(t(L),(D*Sib[[i]][!bdrop])[piv]))[ipiv]) ## obtain the curvature check matrix... dVkk <- crossprod(L[,ipiv]%*%(d1b/D)) if (!is.null(drop)) { ## create full version of d1b with zeros for unidentifiable fd1b <- matrix(0,q,m) fd1b[!bdrop,] <- d1b } else fd1b <- d1b ## Now call the family again to get first derivative of Hessian w.r.t ## smoothing parameters, in list d1H... ll <- llf(y,x,coef,weights,family,offset=offset,deriv=3,d1b=d1b) # d1l <- colSums(ll$lb*d1b) # cancels if (deriv>1) { ## Implicit differentiation for the second derivatives is now possible... d2b <- matrix(0,rank,m*(m+1)/2) k <- 0 for (i in 1:m) for (j in i:m) { k <- k + 1 v <- -ll$d1H[[i]]%*%d1b[,j] + Sl.mult(rp$Sl,fd1b[,j],i)[!bdrop] + Sl.mult(rp$Sl,fd1b[,i],j)[!bdrop] d2b[,k] <- -D*(backsolve(L,forwardsolve(t(L),(D*v)[piv]))[ipiv]) if (i==j) d2b[,k] <- d2b[,k] + d1b[,i] } ## Now call family for last time to get trHid2H the tr(H^{-1} d^2 H / drho_i drho_j)... llr <- llf(y,x,coef,weights,family,offset=offset,deriv=4,d1b=d1b,d2b=d2b, Hp=Hp,rank=rank,fh = L,D=D) ## Now compute Hessian of log lik w.r.t. log sps using chain rule # d2la <- colSums(ll$lb*d2b) # cancels # k <- 0 d2l <- matrix(0,m,m) for (i in 1:m) for (j in i:m) { # k <- k + 1 d2l[j,i] <- d2l[i,j] <- # d2la[k] + # cancels t(d1b[,i])%*%ll$lbb%*%d1b[,j] } } ## if (deriv > 1) } ## if (deriv > 0) ## Compute the derivatives of log|H+S|... if (deriv > 0) { d1ldetH <- rep(0,m) d1Hp <- list() for (i in 1:m) { A <- -ll$d1H[[i]] + Sl.mult(rp$Sl,diag(q),i)[!bdrop,!bdrop] d1Hp[[i]] <- D*(backsolve(L,forwardsolve(t(L),(D*A)[piv,]))[ipiv,,drop=FALSE]) d1ldetH[i] <- sum(diag(d1Hp[[i]])) } } ## if (deriv > 0) if (deriv > 1) { d2ldetH <- matrix(0,m,m) k <- 0 for (i in 1:m) for (j in i:m) { k <- k + 1 d2ldetH[i,j] <- -sum(d1Hp[[i]]*t(d1Hp[[j]])) - llr$trHid2H[k] if (i==j) { ## need to add term relating to smoothing penalty A <- Sl.mult(rp$Sl,diag(q),i,full=TRUE)[!bdrop,!bdrop] bind <- rowSums(abs(A))!=0 ## row/cols of non-zero block A <- A[,bind,drop=FALSE] ## drop the zero columns A <- D*(backsolve(L,forwardsolve(t(L),(D*A)[piv,]))[ipiv,,drop=FALSE]) d2ldetH[i,j] <- d2ldetH[i,j] + sum(diag(A[bind,,drop=FALSE])) } else d2ldetH[j,i] <- d2ldetH[i,j] } } ## if (deriv > 1) ## Compute derivs of b'Sb... if (deriv>0) { Skb <- Sl.termMult(rp$Sl,fcoef,full=TRUE) d1bSb <- rep(0,m) for (i in 1:m) { Skb[[i]] <- Skb[[i]][!bdrop] d1bSb[i] <- sum(coef*Skb[[i]]) } } if (deriv>1) { d2bSb <- matrix(0,m,m) for (i in 1:m) { Sd1b <- St%*%d1b[,i] for (j in i:m) { d2bSb[j,i] <- d2bSb[i,j] <- 2*sum( d1b[,i]*Skb[[j]] + d1b[,j]*Skb[[i]] + d1b[,j]*Sd1b) } d2bSb[i,i] <- d2bSb[i,i] + sum(coef*Skb[[i]]) } } ## get grad and Hessian of REML score... REML <- -as.numeric((ll$l - drop(t(coef)%*%St%*%coef)/2)/gamma + rp$ldetS/2 - ldetHp/2 + Mp*(log(2*pi)/2)-log(gamma)/2) REML1 <- if (deriv<1) NULL else -as.numeric( # d1l # cancels - d1bSb/(2*gamma) + rp$ldet1/2 - d1ldetH/2 ) if (control$trace) { cat("\niter =",iter," ll =",ll$l," REML =",REML," bSb =",t(coef)%*%St%*%coef/2,"\n") cat("log|S| =",rp$ldetS," log|H+S| =",ldetHp," n.drop =",length(drop),"\n") if (!is.null(REML1)) cat("REML1 =",REML1,"\n") } REML2 <- if (deriv<2) NULL else -( (d2l - d2bSb/2)/gamma + rp$ldet2/2 - d2ldetH/2 ) ## Get possibly multiple linear predictors lpi <- attr(x,"lpi") if (is.null(lpi)) { ## only one... linear.predictors <- if (is.null(offset)) as.numeric(x%*%coef) else as.numeric(x%*%coef+offset) fitted.values <- family$linkinv(linear.predictors) } else { ## multiple... fitted.values <- linear.predictors <- matrix(0,nrow(x),length(lpi)) if (!is.null(offset)) offset[[length(lpi)+1]] <- 0 for (j in 1:length(lpi)) { linear.predictors[,j] <- as.numeric(x[,lpi[[j]],drop=FALSE] %*% coef[lpi[[j]]]) if (!is.null(offset[[j]])) linear.predictors[,j] <- linear.predictors[,j] + offset[[j]] fitted.values[,j] <- family$linfo[[j]]$linkinv( linear.predictors[,j]) } } coef <- Sl.repara(rp$rp,fcoef,inverse=TRUE) ## undo re-parameterization of coef #coef <- Sl.repa(rp$rp,fcoef,l=-1) if (!is.null(drop)&&!is.null(d1b)) { ## create full version of d1b with zeros for unidentifiable db.drho <- matrix(0,length(bdrop),ncol(d1b));db.drho[!bdrop,] <- d1b } else db.drho <- d1b ## and undo re-para... #if (!is.null(d1b)) db.drho <- t(Sl.repara(rp$rp,t(db.drho),inverse=TRUE,both.sides=FALSE)) ## wrong if (!is.null(d1b)) db.drho <- Sl.repa(rp$rp,db.drho,l=-1) #if (!is.null(d2b)) d2b <- Sl.repa(rp$rp,d2b,l=-1) ## NOTE: DEBUG only ## Following needed for debugging H derivatives if Cholesky stabilization used #if (!is.null(ll$d1H)) for (i in 1:length(ll$d1H)) ll$d1H[[i]] <- Sl.repa(rp$rp,ll$d1H[[i]],l=2,r=1) ## debug #ll$lbb <- Sl.repa(rp$rp,ll$lbb,l=2,r=1) ## debug ret <- list(coefficients=coef,family=family,y=y,prior.weights=weights, fitted.values=fitted.values, linear.predictors=linear.predictors, scale.est=1, ### NOTE: needed by newton, but what is sensible here? REML= REML,REML1= REML1,REML2=REML2, rank=rank,aic = -2*ll$l, ## 2*edf needs to be added ##deviance = -2*ll$l, l= ll$l,## l1 =d1l,l2 =d2l, lbb = ll$lbb, ## Hessian of log likelihood L=L, ## chol factor of pre-conditioned penalized hessian bdrop=bdrop, ## logical index of dropped parameters D=D, ## diagonal preconditioning matrix St=St, ## total penalty matrix rp = rp$rp, db.drho = db.drho, ## derivative of penalty coefs w.r.t. log sps. #bSb = bSb, bSb1 = d1bSb,bSb2 = d2bSb, S1=rp$ldet1, #S=rp$ldetS,S1=rp$ldet1,S2=rp$ldet2, #Hp=ldetHp,Hp1=d1ldetH,Hp2=d2ldetH, #b2 = d2b, niter=iter,H = ll$lbb,dH = ll$d1H,dVkk=dVkk)#,d2H=llr$d2H) ## debugging code to allow components of 2nd deriv of hessian w.r.t. sp.s ## to be passed to deriv.check.... #if (!is.null(ll$ghost1)&&!is.null(ll$ghost2)) { # ret$ghost1 <- ll$ghost1; ret$ghost2 <- ret$ghost2 #} ret } ## end of gam.fit5 efsud <- function(x,y,lsp,Sl,weights=NULL,offset=NULL,family, control=gam.control(),Mp=-1,start=NULL) { ## Extended Fellner-Schall method for general families ## tr(S^-S_j) is returned by ldetS as ldet1 - S1 from gam.fit5 ## b'S_jb is computed as d1bSb in gam.fit5 ## tr(V S_j) will need to be computed using Sl.termMult ## Sl returned by ldetS and Vb computed as in gam.fit5.postproc. tol <- 1e-6 lsp <- lsp + 2.5 mult <- 1 fit <- gam.fit5(x=x,y=y,lsp=lsp,Sl=Sl,weights=weights,offset=offset,deriv=0,family=family, control=control,Mp=Mp,start=start,gamma=1) score.hist <- rep(0,200) tiny <- .Machine$double.eps^.5 ## used to bound above zero for (iter in 1:200) { start <- fit$coefficients ## obtain Vb... ipiv <- piv <- attr(fit$L,"pivot") p <- length(piv) ipiv[piv] <- 1:p Vb <- crossprod(forwardsolve(t(fit$L),diag(fit$D,nrow=p)[piv,,drop=FALSE])[ipiv,,drop=FALSE]) if (sum(fit$bdrop)) { ## some coefficients were dropped... q <- length(fit$bdrop) ibd <- !fit$bdrop Vtemp <- Vb; Vb <- matrix(0,q,q) Vb[ibd,ibd] <- Vtemp } Vb <- Sl.repara(fit$rp,Vb,inverse=TRUE) SVb <- Sl.termMult(Sl,Vb) ## this could be made more efficient trVS <- rep(0,length(SVb)) for (i in 1:length(SVb)) { ind <- attr(SVb[[i]],"ind") trVS[i] <- sum(diag(SVb[[i]][,ind])) } Sb <- Sl.termMult(Sl,start,full=TRUE) bSb <- rep(0,length(Sb)) for (i in 1:length(Sb)) { bSb[i] <- sum(start*Sb[[i]]) } a <- pmax(tiny,fit$S1*exp(-lsp) - trVS) r <- a/pmax(tiny,bSb) r[a==0&bSb==0] <- 1 r[!is.finite(r)] <- 1e6 lsp1 <- pmin(lsp + log(r)*mult,control$efs.lspmax) max.step <- max(abs(lsp1-lsp)) old.reml <- fit$REML fit <- gam.fit5(x=x,y=y,lsp=lsp1,Sl=Sl,weights=weights,offset=offset,deriv=0, family=family,control=control,Mp=Mp,start=start,gamma=1) ## some step length control... if (fit$REML<=old.reml) { ## improvement if (max.step<.05) { ## consider step extension lsp2 <- pmin(lsp + log(r)*mult*2,12) ## try extending step... fit2 <- gam.fit5(x=x,y=y,lsp=lsp2,Sl=Sl,weights=weights,offset=offset,deriv=0,family=family, control=control,Mp=Mp,start=start,gamma=1) if (fit2$REML < fit$REML) { ## improvement - accept extension fit <- fit2;lsp <- lsp2 mult <- mult * 2 } else { ## accept old step lsp <- lsp1 } } else lsp <- lsp1 } else { ## no improvement while (fit$REML > old.reml&&mult>1) { ## don't contract below 1 as update doesn't have to improve REML mult <- mult/2 ## contract step lsp1 <- pmin(lsp + log(r)*mult,control$efs.lspmax) fit <- gam.fit5(x=x,y=y,lsp=lsp1,Sl=Sl,weights=weights,offset=offset,deriv=0,family=family, control=control,Mp=Mp,start=start,gamma=1) } lsp <- lsp1 if (mult<1) mult <- 1 } score.hist[iter] <- fit$REML ## break if EFS step small and REML change negligible over last 3 steps. if (iter>3 && max.step<.05 && max(abs(diff(score.hist[(iter-3):iter])))sum(edf1)) edf2 <- edf1 ## note hat not possible here... list(Vc=Vc,Vb=Vb,Ve=Ve,edf=edf,edf1=edf1,edf2=edf2,F=F,R=R) } ## gam.fit5.post.proc deriv.check5 <- function(x, y, sp, weights = rep(1, length(y)), start = NULL, offset = rep(0, length(y)),Mp,family = gaussian(), control = gam.control(),deriv=2,eps=1e-7,spe=1e-3, Sl,gamma=1,...) ## FD checking of derivatives for gam.fit5: a debugging routine { if (!deriv%in%c(1,2)) stop("deriv should be 1 or 2") if (control$epsilon>1e-9) control$epsilon <- 1e-9 ## first obtain the fit corresponding to sp... b <- gam.fit5(x=x,y=y,lsp=sp,Sl=Sl,weights=weights,offset=offset,deriv=deriv, family=family,control=control,Mp=Mp,start=start,gamma=gamma) ## now get the derivatives of the likelihood w.r.t. coefs... ll <- family$ll(y=y,X=x,coef=b$coefficients,wt=weights,family=family, deriv=1,d1b=0,d2b=0,Hp=NULL,rank=0,fh=NULL,D=NULL) ## and finite difference versions of these... p <- length(b$coefficients) fdg <- rep(0,p) fdh <- matrix(0,p,p) for (i in 1:p) { coef1 <- b$coefficients;coef1[i] <- coef1[i] + eps ll1 <- family$ll(y=y,X=x,coef=coef1,wt=weights,family=family, deriv=1,d1b=0,d2b=0,Hp=NULL,rank=0,fh=NULL,D=NULL) fdg[i] <- (ll1$l - ll$l)/eps fdh[,i] <- (ll1$lb - ll$lb)/eps } ## display them... oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) plot(ll$lb,fdg,xlab="computed",ylab="FD",main="grad of log lik");abline(0,1) cat("log lik grad cor. =",cor(ll$lb,fdg),"\n") plot(ll$lbb,fdh,xlab="computed",ylab="FD",main="hess of log lik");abline(0,1) cat("log lik hess cor. =",cor(as.numeric(ll$lbb),as.numeric(fdh)),"\n") ## now we need to investigate the derivatives w.r.t. the log smoothing parameters. M <- length(sp) ## number of smoothing parameters fd.br <- matrix(0,p,M) REML1 <- rep(0,M) fd.dH <- list() if (!is.null(b$b2)) fd.br2 <- b$b2*0 k <- 0 for (i in 1:M) { ## the smoothing parameter loop sp0 <- sp1 <- sp;sp1[i] <- sp[i] + spe/2;sp0[i] <- sp[i] - spe/2 b0 <- gam.fit5(x=x,y=y,lsp=sp0,Sl=Sl,weights=weights,offset=offset,deriv=1, family=family,control=control,Mp=Mp,start=start,gamma=gamma) b1 <- gam.fit5(x=x,y=y,lsp=sp1,Sl=Sl,weights=weights,offset=offset,deriv=1, family=family,control=control,Mp=Mp,start=start,gamma=gamma) fd.br[,i] <- (b1$coefficients - b0$coefficients)/spe if (!is.null(b$b2)) { for (j in i:M) { k <- k + 1 fd.br2[,k] <- (b1$db.drho[,j]-b0$db.drho[,j])/spe } } REML1[i] <- (b1$REML-b0$REML)/spe fd.dH[[i]] <- (b1$lbb - b0$lbb)/spe } ## plot db.drho against fd versions... for (i in 1:M) { plot(b$db.drho[,i],fd.br[,i],xlab="computed",ylab="FD",main="db/drho");abline(0,1) cat("cor db/drho[",i,"] = ",cor(b$db.drho[,i],fd.br[,i]),"\n") } ## second deriv of b if (!is.null(b$b2)) for (i in 1:ncol(b$b2)) { plot(b$b2[,i],fd.br2[,i],xlab="computed",ylab="FD",main="d2b/drhorho");abline(0,1) cat("cor d2b[",i,"] = ",cor(b$b2[,i],fd.br2[,i]),"\n") } ## plot first deriv Hessian against FD version for (i in 1:M) { plot(b$dH[[i]],fd.dH[[i]],xlab="computed",ylab="FD",main="dH/drho");abline(0,1) cat("cor dH/drho[",i,"] = ",cor(as.numeric(b$dH[[i]]),as.numeric(fd.dH[[i]])),"\n") } list(fd=list(lb=fdg,lbb=fdh,REML1=REML1,db.drho=fd.br,dH=fd.dH), lb=ll$lb,lbb=ll$lbb,REML1=b$REML1,db.drho=b$db.drho,dH=b$dH) } ## deriv.check5mgcv/R/gam.fit3.r0000755000176200001440000040132313501413525013207 0ustar liggesusers## R routines for gam fitting with calculation of derivatives w.r.t. sp.s ## (c) Simon Wood 2004-2013 ## These routines are for type 3 gam fitting. The basic idea is that a P-IRLS ## is run to convergence, and only then is a scheme for evaluating the ## derivatives via the implicit function theorem used. gam.reparam <- function(rS,lsp,deriv) ## Finds an orthogonal reparameterization which avoids `dominant machine zero leakage' between ## components of the square root penalty. ## rS is the list of the square root penalties: last entry is root of fixed. ## penalty, if fixed.penalty=TRUE (i.e. length(rS)>length(sp)) ## lsp is the vector of log smoothing parameters. ## *Assumption* here is that rS[[i]] are in a null space of total penalty already; ## see e.g. totalPenaltySpace & mini.roots ## Ouputs: ## S -- the total penalty matrix similarity transformed for stability ## rS -- the component square roots, transformed in the same way ## - tcrossprod(rS[[i]]) = rS[[i]] %*% t(rS[[i]]) gives the matrix penalty component. ## Qs -- the orthogonal transformation matrix S = t(Qs)%*%S0%*%Qs, where S0 is the ## untransformed total penalty implied by sp and rS on input ## E -- the square root of the transformed S (obtained in a stable way by pre-conditioning) ## det -- log |S| ## det1 -- dlog|S|/dlog(sp) if deriv >0 ## det2 -- hessian of log|S| wrt log(sp) if deriv>1 { q <- nrow(rS[[1]]) rSncol <- unlist(lapply(rS,ncol)) M <- length(lsp) if (length(rS)>M) fixed.penalty <- TRUE else fixed.penalty <- FALSE d.tol <- .Machine$double.eps^.3 ## group `similar sized' penalties, to save work r.tol <- .Machine$double.eps^.75 ## This is a bit delicate -- too large and penalty range space can be supressed. oo <- .C(C_get_stableS,S=as.double(matrix(0,q,q)),Qs=as.double(matrix(0,q,q)),sp=as.double(exp(lsp)), rS=as.double(unlist(rS)), rSncol = as.integer(rSncol), q = as.integer(q), M = as.integer(M), deriv=as.integer(deriv), det = as.double(0), det1 = as.double(rep(0,M)),det2 = as.double(matrix(0,M,M)), d.tol = as.double(d.tol), r.tol = as.double(r.tol), fixed_penalty = as.integer(fixed.penalty)) S <- matrix(oo$S,q,q) S <- (S+t(S))*.5 p <- abs(diag(S))^.5 ## by Choleski, p can not be zero if S +ve def p[p==0] <- 1 ## but it's possible to make a mistake!! ##E <- t(t(chol(t(t(S/p)/p)))*p) St <- t(t(S/p)/p) St <- (St + t(St))*.5 ## force exact symmetry -- avoids very rare mroot fails E <- t(mroot(St,rank=q)*p) ## the square root S, with column separation Qs <- matrix(oo$Qs,q,q) ## the reparameterization matrix t(Qs)%*%S%*%Qs -> S k0 <- 1 for (i in 1:length(rS)) { ## unpack the rS in the new space crs <- ncol(rS[[i]]); k1 <- k0 + crs * q - 1 rS[[i]] <- matrix(oo$rS[k0:k1],q,crs) k0 <- k1 + 1 } ## now get determinant + derivatives, if required... if (deriv > 0) det1 <- oo$det1 else det1 <- NULL if (deriv > 1) det2 <- matrix(oo$det2,M,M) else det2 <- NULL list(S=S,E=E,Qs=Qs,rS=rS,det=oo$det,det1=det1,det2=det2,fixed.penalty = fixed.penalty) } ## gam.reparam gam.fit3 <- function (x, y, sp, Eb,UrS=list(), weights = rep(1, nobs), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, nobs),U1=diag(ncol(x)), Mp=-1, family = gaussian(), control = gam.control(), intercept = TRUE,deriv=2, gamma=1,scale=1,printWarn=TRUE,scoreType="REML",null.coef=rep(0,ncol(x)), pearson.extra=0,dev.extra=0,n.true=-1,Sl=NULL,...) { ## Inputs: ## * x model matrix ## * y response ## * sp log smoothing parameters ## * Eb square root of nicely balanced total penalty matrix used for rank detection ## * UrS list of penalty square roots in range space of overall penalty. UrS[[i]]%*%t(UrS[[i]]) ## is penalty. See 'estimate.gam' for more. ## * weights prior weights (reciprocal variance scale) ## * start initial values for parameters. ignored if etastart or mustart present (although passed on). ## * etastart initial values for eta ## * mustart initial values for mu. discarded if etastart present. ## * control - control list. ## * intercept - indicates whether model has one. ## * deriv - order 0,1 or 2 derivatives are to be returned (lower is cheaper!) ## * gamma - multiplier for effective degrees of freedom in GCV/UBRE. ## * scale parameter. Negative signals to estimate. ## * printWarn print or supress? ## * scoreType - type of smoothness selection to use. ## * null.coef - coefficients for a null model, in order to be able to check for immediate ## divergence. ## * pearson.extra is an extra component to add to the pearson statistic in the P-REML/P-ML ## case, only. ## * dev.extra is an extra component to add to the deviance in the REML and ML cases only. ## * n.true is to be used in place of the length(y) in ML/REML calculations, ## and the scale.est only. ## ## Version with new reparameterization and truncation strategy. Allows iterative weights ## to be negative. Basically the workhorse routine for Wood (2011) JRSSB. ## A much modified version of glm.fit. Purpose is to estimate regression coefficients ## and compute a smoothness selection score along with its derivatives. ## if (control$trace) { t0 <- proc.time();tc <- 0} if (inherits(family,"extended.family")) { ## then actually gam.fit4/5 is needed if (inherits(family,"general.family")) { return(gam.fit5(x,y,sp,Sl=Sl,weights=weights,offset=offset,deriv=deriv, family=family,control=control,Mp=Mp,start=start,gamma=gamma)) } else return(gam.fit4(x, y, sp, Eb,UrS=UrS, weights = weights, start = start, etastart = etastart, mustart = mustart, offset = offset,U1=U1, Mp=Mp, family = family, control = control, deriv=deriv,gamma=gamma, scale=scale,scoreType=scoreType,null.coef=null.coef,...)) } if (family$link==family$canonical) fisher <- TRUE else fisher=FALSE ## ... if canonical Newton = Fisher, but Fisher cheaper! if (scale>0) scale.known <- TRUE else scale.known <- FALSE if (!scale.known&&scoreType%in%c("REML","ML","EFS")) { ## the final element of sp is actually log(scale) nsp <- length(sp) scale <- exp(sp[nsp]) sp <- sp[-nsp] } if (!deriv%in%c(0,1,2)) stop("unsupported order of differentiation requested of gam.fit3") x <- as.matrix(x) nSp <- length(sp) if (nSp==0) deriv.sp <- 0 else deriv.sp <- deriv rank.tol <- .Machine$double.eps*100 ## tolerance to use for rank deficiency xnames <- dimnames(x)[[2]] ynames <- if (is.matrix(y)) rownames(y) else names(y) q <- ncol(x) if (length(UrS)) { ## find a stable reparameterization... grderiv <- if (scoreType=="EFS") 1 else deriv*as.numeric(scoreType%in%c("REML","ML","P-REML","P-ML")) rp <- gam.reparam(UrS,sp,grderiv) ## note also detects fixed penalty if present ## Following is for debugging only... # deriv.check <- FALSE # if (deriv.check&&grderiv) { # eps <- 1e-4 # fd.grad <- rp$det1 # for (i in 1:length(sp)) { # spp <- sp; spp[i] <- spp[i] + eps/2 # rp1 <- gam.reparam(UrS,spp,grderiv) # spp[i] <- spp[i] - eps # rp0 <- gam.reparam(UrS,spp,grderiv) # fd.grad[i] <- (rp1$det-rp0$det)/eps # } # print(fd.grad) # print(rp$det1) # } T <- diag(q) T[1:ncol(rp$Qs),1:ncol(rp$Qs)] <- rp$Qs T <- U1%*%T ## new params b'=T'b old params null.coef <- t(T)%*%null.coef if (!is.null(start)) start <- t(T)%*%start ## form x%*%T in parallel x <- .Call(C_mgcv_pmmult2,x,T,0,0,control$nthreads) ## x <- x%*%T ## model matrix 0(nq^2) rS <- list() for (i in 1:length(UrS)) { rS[[i]] <- rbind(rp$rS[[i]],matrix(0,Mp,ncol(rp$rS[[i]]))) } ## square roots of penalty matrices in current parameterization Eb <- Eb%*%T ## balanced penalty matrix rows.E <- q-Mp Sr <- cbind(rp$E,matrix(0,nrow(rp$E),Mp)) St <- rbind(cbind(rp$S,matrix(0,nrow(rp$S),Mp)),matrix(0,Mp,q)) } else { grderiv <- 0 T <- diag(q); St <- matrix(0,q,q) rSncol <- sp <- rows.E <- Eb <- Sr <- 0 rS <- list(0) rp <- list(det=0,det1 = rep(0,0),det2 = rep(0,0),fixed.penalty=FALSE) } iter <- 0;coef <- rep(0,ncol(x)) if (scoreType=="EFS") { scoreType <- "REML" ## basically optimizing REML deriv <- 0 ## only derivatives of log|S|_+ required (see above) } conv <- FALSE n <- nobs <- NROW(y) ## n is just to keep codetools happy if (n.true <= 0) n.true <- nobs ## n.true is used in criteria in place of nobs nvars <- ncol(x) EMPTY <- nvars == 0 if (is.null(weights)) weights <- rep.int(1, nobs) if (is.null(offset)) offset <- rep.int(0, nobs) variance <- family$variance dev.resids <- family$dev.resids aic <- family$aic linkinv <- family$linkinv mu.eta <- family$mu.eta 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 D1 <- D2 <- P <- P1 <- P2 <- trA <- trA1 <- trA2 <- GCV<- GCV1<- GCV2<- GACV<- GACV1<- GACV2<- UBRE <- UBRE1<- UBRE2<- REML<- REML1<- REML2 <-NULL if (EMPTY) { eta <- rep.int(0, nobs) + offset if (!valideta(eta)) stop("Invalid linear predictor values in empty model") mu <- linkinv(eta) 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) ### BUG: 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 trA2 <- trA1 <- trA <- 0 if (deriv) GCV2 <- GCV1<- UBRE2 <- UBRE1<-trA1 <- rep(0,nSp) GCV <- nobs*alpha/(nobs-gamma*trA)^2 UBRE <- alpha/nobs - scale + 2*gamma/n*trA scale.est <- alpha / (nobs - trA) } ### end if (EMPTY) else { ##coefold <- NULL eta <- if (!is.null(etastart)) etastart else if (!is.null(start)) if (length(start) != nvars) stop(gettextf("Length of start should equal %d and correspond to initial coefs for %s", nvars, deparse(xnames))) else { coefold <- start offset + as.vector(if (NCOL(x) == 1) x * start else x %*% start) } else family$linkfun(mustart) #etaold <- eta ##muold <- mu <- linkinv(eta) #if (!(validmu(mu) && valideta(eta))) # stop("Can't find valid starting values: please specify some") boundary <- conv <- FALSE rV=matrix(0,ncol(x),ncol(x)) ## need an initial `null deviance' to test for initial divergence... ## Note: can be better not to shrink towards start on ## immediate failure, in case start is on edge of feasible space... ## if (!is.null(start)) null.coef <- start coefold <- null.coef etaold <- null.eta <- as.numeric(x%*%null.coef + as.numeric(offset)) old.pdev <- sum(dev.resids(y, linkinv(null.eta), weights)) + t(null.coef)%*%St%*%null.coef ## ... if the deviance exceeds this then there is an immediate problem 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") if (!is.null(start)) start <- start * .9 + coefold * .1 eta <- .9 * eta + .1 * etaold mu <- linkinv(eta) } zg <- rep(0,max(dim(x))) for (iter in 1:control$maxit) { ## start of main fitting iteration 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(gettextf("No observations informative at iteration %d", iter)) break } mevg<-mu.eta.val[good];mug<-mu[good];yg<-y[good] weg<-weights[good];var.mug<-var.val[good] if (fisher) { ## Conventional Fisher scoring z <- (eta - offset)[good] + (yg - mug)/mevg w <- (weg * mevg^2)/var.mug } else { ## full Newton c = yg - mug alpha <- 1 + c*(family$dvar(mug)/var.mug + family$d2link(mug)*mevg) alpha[alpha==0] <- .Machine$double.eps z <- (eta - offset)[good] + (yg-mug)/(mevg*alpha) ## ... offset subtracted as eta = X%*%beta + offset w <- weg*alpha*mevg^2/var.mug } ## Here a Fortran call has been replaced by pls_fit1 call if (sum(good) control$maxit) stop("inner loop 1; can't correct step size") ii <- ii + 1 start <- (start + coefold)/2 eta <- (eta + etaold)/2 mu <- linkinv(eta) dev <- sum(dev.resids(y, mu, weights)) } boundary <- TRUE penalty <- t(start)%*%St%*%start if (control$trace) cat("Step halved: new deviance =", dev, "\n") } if (!(valideta(eta) && validmu(mu))) { warning("Step size truncated: out of bounds", call. = FALSE) ii <- 1 while (!(valideta(eta) && validmu(mu))) { if (ii > control$maxit) stop("inner loop 2; can't correct step size") ii <- ii + 1 start <- (start + coefold)/2 eta <- (eta + etaold)/2 mu <- linkinv(eta) } boundary <- TRUE penalty <- t(start)%*%St%*%start dev <- sum(dev.resids(y, mu, weights)) if (control$trace) cat("Step halved: new deviance =", dev, "\n") } pdev <- dev + penalty ## the penalized deviance if (control$trace) message(gettextf("penalized deviance = %s", pdev, domain = "R-mgcv")) div.thresh <- 10*(.1+abs(old.pdev))*.Machine$double.eps^.5 ## ... threshold for judging divergence --- too tight and near ## perfect convergence can cause a failure here if (pdev-old.pdev>div.thresh) { ## solution diverging ii <- 1 ## step halving counter if (iter==1) { ## immediate divergence, need to shrink towards zero etaold <- null.eta; coefold <- 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 start <- (start + coefold)/2 eta <- (eta + etaold)/2 mu <- linkinv(eta) dev <- sum(dev.resids(y, mu, weights)) pdev <- dev + t(start)%*%St%*%start ## the penalized deviance if (control$trace) message(gettextf("Step halved: new penalized deviance = %g", pdev, "\n")) } } if (strictly.additive) { conv <- TRUE;coef <- start;break;} if (abs(pdev - old.pdev)/(0.1 + abs(pdev)) < control$epsilon) { ## Need to check coefs converged adequately, to ensure implicit differentiation ## ok. Testing coefs unchanged is problematic under rank deficiency (not guaranteed to ## drop same parameter every iteration!) grad <- 2 * t(x[good,])%*%(w*((x%*%start)[good]-z))+ 2*St%*%start if (max(abs(grad)) > control$epsilon*max(abs(start+coefold))/2) { ##if (max(abs(start-coefold))>control$epsilon*max(abs(start+coefold))/2) { ## if (max(abs(mu-muold))>control$epsilon*max(abs(mu+muold))/2) { old.pdev <- pdev coef <- coefold <- start etaold <- eta ##muold <- mu } else { conv <- TRUE coef <- start etaold <- eta break } } else { old.pdev <- pdev coef <- coefold <- start etaold <- eta } } ### end main loop wdr <- dev.resids(y, mu, weights) dev <- sum(wdr) wdr <- sign(y-mu)*sqrt(pmax(wdr,0)) ## used below in scale estimation ## Now call the derivative calculation scheme. This requires the ## following inputs: ## z and w - the pseudodata and weights ## X the model matrix and E where EE'=S ## rS the single penalty square roots ## sp the log smoothing parameters ## y and mu the data and model expected values ## g1,g2,g3 - the first 3 derivatives of g(mu) wrt mu ## V,V1,V2 - V(mu) and its first two derivatives wrt mu ## on output it returns the gradient and hessian for ## the deviance and trA 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) mevg <- mu.eta.val[good];mug <- mu[good];yg <- y[good] weg <- weights[good];etag <- eta[good] var.mug<-var.val[good] if (fisher) { ## Conventional Fisher scoring z <- (eta - offset)[good] + (yg - mug)/mevg w <- (weg * mevg^2)/var.mug alpha <- wf <- 0 ## Don't need Fisher weights separately } else { ## full Newton c <- yg - mug alpha <- 1 + c*(family$dvar(mug)/var.mug + family$d2link(mug)*mevg) ### can't just drop obs when alpha==0, as they are informative, but ### happily using an `effective zero' is stable here, and there is ### a natural effective zero, since E(alpha) = 1. alpha[alpha==0] <- .Machine$double.eps z <- (eta - offset)[good] + (yg-mug)/(mevg*alpha) ## ... offset subtracted as eta = X%*%beta + offset wf <- weg*mevg^2/var.mug ## Fisher weights for EDF calculation w <- wf * alpha ## Full Newton weights } g1 <- 1/mevg g2 <- family$d2link(mug) g3 <- family$d3link(mug) V <- family$variance(mug) V1 <- family$dvar(mug) V2 <- family$d2var(mug) if (fisher) { g4 <- V3 <- 0 } else { g4 <- family$d4link(mug) V3 <- family$d3var(mug) } if (TRUE) { ### TEST CODE for derivative ratio based versions of code... g2 <- g2/g1;g3 <- g3/g1;g4 <- g4/g1 V1 <- V1/V;V2 <- V2/V;V3 <- V3/V } P1 <- D1 <- array(0,nSp);P2 <- D2 <- matrix(0,nSp,nSp) # for derivs of deviance/ Pearson trA1 <- array(0,nSp);trA2 <- matrix(0,nSp,nSp) # for derivs of tr(A) rV=matrix(0,ncol(x),ncol(x)); dum <- 1 if (control$trace) cat("calling gdi...") REML <- 0 ## signals GCV/AIC used if (scoreType%in%c("REML","P-REML")) {REML <- 1;remlInd <- 1} else if (scoreType%in%c("ML","P-ML")) {REML <- -1;remlInd <- 0} if (REML==0) rSncol <- unlist(lapply(rS,ncol)) else rSncol <- unlist(lapply(UrS,ncol)) if (control$trace) t1 <- proc.time() oo <- .C(C_gdi1,X=as.double(x[good,]),E=as.double(Sr),Eb = as.double(Eb), rS = as.double(unlist(rS)),U1=as.double(U1),sp=as.double(exp(sp)), z=as.double(z),w=as.double(w),wf=as.double(wf),alpha=as.double(alpha), mu=as.double(mug),eta=as.double(etag),y=as.double(yg), p.weights=as.double(weg),g1=as.double(g1),g2=as.double(g2), g3=as.double(g3),g4=as.double(g4),V0=as.double(V),V1=as.double(V1), V2=as.double(V2),V3=as.double(V3),beta=as.double(coef),b1=as.double(rep(0,nSp*ncol(x))), w1=as.double(rep(0,nSp*length(z))), D1=as.double(D1),D2=as.double(D2),P=as.double(dum),P1=as.double(P1),P2=as.double(P2), trA=as.double(dum),trA1=as.double(trA1),trA2=as.double(trA2), rV=as.double(rV),rank.tol=as.double(rank.tol), conv.tol=as.double(control$epsilon),rank.est=as.integer(1),n=as.integer(length(z)), p=as.integer(ncol(x)),M=as.integer(nSp),Mp=as.integer(Mp),Enrow = as.integer(rows.E), rSncol=as.integer(rSncol),deriv=as.integer(deriv.sp), REML = as.integer(REML),fisher=as.integer(fisher), fixed.penalty = as.integer(rp$fixed.penalty),nthreads=as.integer(control$nthreads), dVkk=as.double(rep(0,nSp*nSp))) if (control$trace) { tg <- sum((proc.time()-t1)[c(1,4)]) cat("done!\n") } ## get dbeta/drho, directly in original parameterization db.drho <- if (deriv) T%*%matrix(oo$b1,ncol(x),nSp) else NULL dw.drho <- if (deriv) matrix(oo$w1,length(z),nSp) else NULL rV <- matrix(oo$rV,ncol(x),ncol(x)) ## rV%*%t(rV)*scale gives covariance matrix Kmat <- matrix(0,nrow(x),ncol(x)) Kmat[good,] <- oo$X ## rV%*%t(K)%*%(sqrt(wf)*X) = F; diag(F) is edf array coef <- oo$beta; eta <- drop(x%*%coef + offset) mu <- linkinv(eta) if (!(validmu(mu)&&valideta(eta))) { ## if iteration terminated with step halving then it can be that ## gdi1 returns an invalid coef, because likelihood is actually ## pushing coefs to invalid region. Probably not much hope in ## this case, but it is worth at least returning feasible values, ## even though this is not quite consistent with derivs. coef <- start eta <- etaold mu <- linkinv(eta) } trA <- oo$trA; if (control$scale.est%in%c("pearson","fletcher","Pearson","Fletcher")) { pearson <- sum(weights*(y-mu)^2/family$variance(mu)) scale.est <- (pearson+dev.extra)/(n.true-trA) if (control$scale.est%in%c("fletcher","Fletcher")) { ## Apply Fletcher (2012) correction ## note limited to 10 times Pearson... s.bar = max(-.9,mean(family$dvar(mu)*(y-mu)*sqrt(weights)/family$variance(mu))) if (is.finite(s.bar)) scale.est <- scale.est/(1+s.bar) } } else { ## use the deviance estimator scale.est <- (dev+dev.extra)/(n.true-trA) } reml.scale <- NA if (scoreType%in%c("REML","ML")) { ## use Laplace (RE)ML ls <- family$ls(y,weights,n,scale)*n.true/nobs ## saturated likelihood and derivatives Dp <- dev + oo$conv.tol + dev.extra REML <- (Dp/(2*scale) - ls[1])/gamma + oo$rank.tol/2 - rp$det/2 - remlInd*(Mp/2*(log(2*pi*scale)-log(gamma))) attr(REML,"Dp") <- Dp/(2*scale) if (deriv) { REML1 <- oo$D1/(2*scale*gamma) + oo$trA1/2 - rp$det1/2 if (deriv==2) REML2 <- (matrix(oo$D2,nSp,nSp)/(scale*gamma) + matrix(oo$trA2,nSp,nSp) - rp$det2)/2 if (sum(!is.finite(REML2))) { stop("Non finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam.contol'") } } if (!scale.known&&deriv) { ## need derivatives wrt log scale, too ##ls <- family$ls(y,weights,n,scale) ## saturated likelihood and derivatives dlr.dlphi <- (-Dp/(2 *scale) - ls[2]*scale)/gamma - Mp/2*remlInd d2lr.d2lphi <- (Dp/(2*scale) - ls[3]*scale^2 - ls[2]*scale)/gamma d2lr.dspphi <- -oo$D1/(2*scale*gamma) REML1 <- c(REML1,dlr.dlphi) if (deriv==2) { REML2 <- rbind(REML2,as.numeric(d2lr.dspphi)) REML2 <- cbind(REML2,c(as.numeric(d2lr.dspphi),d2lr.d2lphi)) } } reml.scale <- scale } else if (scoreType%in%c("P-REML","P-ML")) { ## scale unknown use Pearson-Laplace REML reml.scale <- phi <- (oo$P*(nobs-Mp)+pearson.extra)/(n.true-Mp) ## REMLish scale estimate ## correct derivatives, if needed... oo$P1 <- oo$P1*(nobs-Mp)/(n.true-Mp) oo$P2 <- oo$P2*(nobs-Mp)/(n.true-Mp) ls <- family$ls(y,weights,n,phi)*n.true/nobs ## saturated likelihood and derivatives Dp <- dev + oo$conv.tol + dev.extra K <- oo$rank.tol/2 - rp$det/2 REML <- (Dp/(2*phi) - ls[1]) + K - Mp/2*(log(2*pi*phi))*remlInd attr(REML,"Dp") <- Dp/(2*phi) if (deriv) { phi1 <- oo$P1; Dp1 <- oo$D1; K1 <- oo$trA1/2 - rp$det1/2; REML1 <- Dp1/(2*phi) - phi1*(Dp/(2*phi^2)+Mp/(2*phi)*remlInd + ls[2]) + K1 if (deriv==2) { phi2 <- matrix(oo$P2,nSp,nSp);Dp2 <- matrix(oo$D2,nSp,nSp) K2 <- matrix(oo$trA2,nSp,nSp)/2 - rp$det2/2 REML2 <- Dp2/(2*phi) - (outer(Dp1,phi1)+outer(phi1,Dp1))/(2*phi^2) + (Dp/phi^3 - ls[3] + Mp/(2*phi^2)*remlInd)*outer(phi1,phi1) - (Dp/(2*phi^2)+ls[2]+Mp/(2*phi)*remlInd)*phi2 + K2 } } } else { ## Not REML .... P <- oo$P delta <- nobs - gamma * trA delta.2 <- delta*delta GCV <- nobs*dev/delta.2 GACV <- dev/nobs + P * 2*gamma*trA/(delta * nobs) UBRE <- dev/nobs - 2*delta*scale/nobs + scale if (deriv) { trA1 <- oo$trA1 D1 <- oo$D1 P1 <- oo$P1 if (sum(!is.finite(D1))||sum(!is.finite(P1))||sum(!is.finite(trA1))) { stop( "Non-finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam.contol'") } delta.3 <- delta*delta.2 GCV1 <- nobs*D1/delta.2 + 2*nobs*dev*trA1*gamma/delta.3 GACV1 <- D1/nobs + 2*P/delta.2 * trA1 + 2*gamma*trA*P1/(delta*nobs) UBRE1 <- D1/nobs + gamma * trA1 *2*scale/nobs if (deriv==2) { trA2 <- matrix(oo$trA2,nSp,nSp) D2 <- matrix(oo$D2,nSp,nSp) P2 <- matrix(oo$P2,nSp,nSp) if (sum(!is.finite(D2))||sum(!is.finite(P2))||sum(!is.finite(trA2))) { stop( "Non-finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam.contol'") } GCV2 <- outer(trA1,D1) GCV2 <- (GCV2 + t(GCV2))*gamma*2*nobs/delta.3 + 6*nobs*dev*outer(trA1,trA1)*gamma*gamma/(delta.2*delta.2) + nobs*D2/delta.2 + 2*nobs*dev*gamma*trA2/delta.3 GACV2 <- D2/nobs + outer(trA1,trA1)*4*P/(delta.3) + 2 * P * trA2 / delta.2 + 2 * outer(trA1,P1)/delta.2 + 2 * outer(P1,trA1) *(1/(delta * nobs) + trA/(nobs*delta.2)) + 2 * trA * P2 /(delta * nobs) GACV2 <- (GACV2 + t(GACV2))*.5 UBRE2 <- D2/nobs +2*gamma * trA2 * scale / nobs } ## end if (deriv==2) } ## end if (deriv) } ## end !REML # end of inserted code if (!conv&&printWarn) warning("Algorithm did not converge") if (printWarn&&boundary) warning("Algorithm stopped at boundary value") eps <- 10 * .Machine$double.eps if (printWarn&&family$family[1] == "binomial") { if (any(mu > 1 - eps) || any(mu < eps)) warning("fitted probabilities numerically 0 or 1 occurred") } if (printWarn&&family$family[1] == "poisson") { if (any(mu < eps)) warning("fitted rates numerically 0 occurred") } residuals <- rep.int(NA, nobs) residuals[good] <- z - (eta - offset)[good] ## undo reparameterization.... coef <- as.numeric(T %*% coef) rV <- T %*% rV names(coef) <- xnames } ### end if (!EMPTY) names(residuals) <- ynames names(mu) <- ynames names(eta) <- ynames ww <- wt <- rep.int(0, nobs) if (fisher) { wt[good] <- w; ww <- wt} else { wt[good] <- wf ## note that Fisher weights are returned ww[good] <- w } names(wt) <- ynames names(weights) <- ynames names(y) <- ynames if (deriv && nrow(dw.drho)!=nrow(x)) { w1 <- dw.drho dw.drho <- matrix(0,nrow(x),ncol(w1)) dw.drho[good,] <- w1 } wtdmu <- if (intercept) sum(weights * y)/sum(weights) else linkinv(offset) nulldev <- sum(dev.resids(y, wtdmu, weights)) n.ok <- nobs - sum(weights == 0) nulldf <- n.ok - as.integer(intercept) aic.model <- aic(y, n, mu, weights, dev) # note: incomplete 2*edf needs to be added if (control$trace) { t1 <- proc.time() at <- sum((t1-t0)[c(1,4)]) cat("Proportion time in C: ",(tc+tg)/at," ls:",tc/at," gdi:",tg/at,"\n") } list(coefficients = coef, residuals = residuals, fitted.values = mu, family = family, linear.predictors = eta, deviance = dev, null.deviance = nulldev, iter = iter, weights = wt, working.weights=ww,prior.weights = weights, df.null = nulldf, y = y, converged = conv,##pearson.warning = pearson.warning, boundary = boundary,D1=D1,D2=D2,P=P,P1=P1,P2=P2,trA=trA,trA1=trA1,trA2=trA2, GCV=GCV,GCV1=GCV1,GCV2=GCV2,GACV=GACV,GACV1=GACV1,GACV2=GACV2,UBRE=UBRE, UBRE1=UBRE1,UBRE2=UBRE2,REML=REML,REML1=REML1,REML2=REML2,rV=rV,db.drho=db.drho, dw.drho=dw.drho,dVkk = matrix(oo$dVkk,nSp,nSp),ldetS1 = if (grderiv) rp$det1 else 0, scale.est=scale.est,reml.scale= reml.scale,aic=aic.model,rank=oo$rank.est,K=Kmat) } ## end gam.fit3 Vb.corr <- function(X,L,lsp0,S,off,dw,w,rho,Vr,nth=0,scale.est=FALSE) { ## compute higher order Vb correction... ## If w is NULL then X should be root Hessian, and ## dw is treated as if it was 0, otherwise X should be model ## matrix. ## dw is derivative w.r.t. all the smoothing parameters and family parameters as if these ## were not linked, but not the scale parameter, of course. Vr includes scale uncertainty, ## if scale estimated... ## nth is the number of initial elements of rho that are not smoothing ## parameters, scale.est is TRUE if scale estimated by REML and must be ## dropped from s.p.s M <- length(off) ## number of penalty terms if (scale.est) { ## drop scale param from L, rho and Vr... rho <- rho[-length(rho)] if (!is.null(L)) L <- L[-nrow(L),-ncol(L),drop=FALSE] Vr <- Vr[-nrow(Vr),-ncol(Vr),drop=FALSE] } if (is.null(lsp0)) lsp0 <- if (is.null(L)) rho*0 else rep(0,nrow(L)) ## note that last element of lsp0 can be a scale parameter... lambda <- if (is.null(L)) exp(rho+lsp0[1:length(rho)]) else exp(L%*%rho + lsp0[1:nrow(L)]) ## Re-create the Hessian, if is.null(w) then X assumed to be root ## unpenalized Hessian... H <- if (is.null(w)) crossprod(X) else H <- t(X)%*%(w*X) if (M>0) for (i in 1:M) { ind <- off[i] + 1:ncol(S[[i]]) - 1 H[ind,ind] <- H[ind,ind] + lambda[i+nth] * S[[i]] } R <- try(chol(H),silent=TRUE) ## get its Choleski factor. if (inherits(R,"try-error")) return(0) ## bail out as Hessian insufficiently well conditioned ## Create dH the derivatives of the hessian w.r.t. (all) the smoothing parameters... dH <- list() if (length(lambda)>0) for (i in 1:length(lambda)) { ## If w==NULL use constant H approx... dH[[i]] <- if (is.null(w)) H*0 else t(X)%*%(dw[,i]*X) if (i>nth) { ind <- off[i-nth] + 1:ncol(S[[i-nth]]) - 1 dH[[i]][ind,ind] <- dH[[i]][ind,ind] + lambda[i]*S[[i-nth]] } } ## If L supplied then dH has to be re-weighted to give ## derivatives w.r.t. optimization smoothing params. if (!is.null(L)) { dH1 <- dH;dH <- list() if (length(rho)>0) for (j in 1:length(rho)) { ok <- FALSE ## dH[[j]] not yet created if (nrow(L)>0) for (i in 1:nrow(L)) if (L[i,j]!=0.0) { dH[[j]] <- if (ok) dH[[j]] + dH1[[i]]*L[i,j] else dH1[[i]]*L[i,j] ok <- TRUE } } rm(dH1) } ## dH now w.r.t. optimization parameters if (length(dH)==0) return(0) ## nothing to correct ## Get derivatives of Choleski factor w.r.t. the smoothing parameters dR <- list() for (i in 1:length(dH)) dR[[i]] <- dchol(dH[[i]],R) rm(dH) ## need to transform all dR to dR^{-1} = -R^{-1} dR R^{-1}... for (i in 1:length(dR)) dR[[i]] <- -t(forwardsolve(t(R),t(backsolve(R,dR[[i]])))) ## BUT: dR, now upper triangular, and it relates to RR' = Vb not R'R = Vb ## in consequence of which Rz is the thing with the right distribution ## and not R'z... dbg <- FALSE if (dbg) { ## debugging code n.rep <- 10000;p <- ncol(R) r <- rmvn(n.rep,rep(0,M),Vr) b <- matrix(0,n.rep,p) for (i in 1:n.rep) { z <- rnorm(p) if (M>0) for (j in 1:M) b[i,] <- b[i,] + dR[[j]]%*%z*(r[i,j]) } Vfd <- crossprod(b)/n.rep } vcorr(dR,Vr,FALSE) ## NOTE: unscaled!! } ## Vb.corr gam.fit3.post.proc <- function(X,L,lsp0,S,off,object) { ## get edf array and covariance matrices after a gam fit. ## X is original model matrix, L the mapping from working to full sp scale <- if (object$scale.estimated) object$scale.est else object$scale Vb <- object$rV%*%t(object$rV)*scale ## Bayesian cov. # PKt <- object$rV%*%t(object$K) PKt <- .Call(C_mgcv_pmmult2,object$rV,object$K,0,1,object$control$nthreads) # F <- PKt%*%(sqrt(object$weights)*X) F <- .Call(C_mgcv_pmmult2,PKt,sqrt(object$weights)*X,0,0,object$control$nthreads) edf <- diag(F) ## effective degrees of freedom edf1 <- 2*edf - rowSums(t(F)*F) ## alternative ## edf <- rowSums(PKt*t(sqrt(object$weights)*X)) ## Ve <- PKt%*%t(PKt)*object$scale ## frequentist cov Ve <- F%*%Vb ## not quite as stable as above, but quicker hat <- rowSums(object$K*object$K) ## get QR factor R of WX - more efficient to do this ## in gdi_1 really, but that means making QR of augmented ## a two stage thing, so not clear cut... qrx <- pqr(sqrt(object$weights)*X,object$control$nthreads) R <- pqr.R(qrx);R[,qrx$pivot] <- R if (!is.na(object$reml.scale)&&!is.null(object$db.drho)) { ## compute sp uncertainty correction hess <- object$outer.info$hess edge.correct <- if (is.null(attr(hess,"edge.correct"))) FALSE else TRUE K <- if (edge.correct) 2 else 1 for (k in 1:K) { if (k==1) { ## fitted model computations db.drho <- object$db.drho dw.drho <- object$dw.drho lsp <- log(object$sp) } else { ## edge corrected model computations db.drho <- attr(hess,"db.drho1") dw.drho <- attr(hess,"dw.drho1") lsp <- attr(hess,"lsp1") hess <- attr(hess,"hess1") } M <- ncol(db.drho) ## transform to derivs w.r.t. working, noting that an extra final row of L ## may be present, relating to scale parameter (for which db.drho is 0 since it's a scale parameter) if (!is.null(L)) { db.drho <- db.drho%*%L[1:M,,drop=FALSE] M <- ncol(db.drho) } ## extract cov matrix for log smoothing parameters... ev <- eigen(hess,symmetric=TRUE) d <- ev$values;ind <- d <= 0 d[ind] <- 0;d[!ind] <- 1/sqrt(d[!ind]) rV <- (d*t(ev$vectors))[,1:M] ## root of cov matrix Vc <- crossprod(rV%*%t(db.drho)) ## set a prior precision on the smoothing parameters, but don't use it to ## fit, only to regularize Cov matrix. exp(4*var^.5) gives approx ## multiplicative range. e.g. var = 5.3 says parameter between .01 and 100 times ## estimate. Avoids nonsense at `infinite' smoothing parameters. d <- ev$values; d[ind] <- 0; d <- if (k==1) 1/sqrt(d+1/10) else 1/sqrt(d+1e-7) Vr <- crossprod(d*t(ev$vectors)) ## Note that db.drho and dw.drho are derivatives w.r.t. full set of smoothing ## parameters excluding any scale parameter, but Vr includes info for scale parameter ## if it has been estimated. nth <- if (is.null(object$family$n.theta)) 0 else object$family$n.theta ## any parameters of family itself drop.scale <- object$scale.estimated && !(object$method %in% c("P-REML","P-ML")) Vc2 <- scale*Vb.corr(R,L,lsp0,S,off,dw.drho,w=NULL,lsp,Vr,nth,drop.scale) Vc <- Vb + Vc + Vc2 ## Bayesian cov matrix with sp uncertainty ## finite sample size check on edf sanity... if (k==1) { ## compute edf2 only with fitted model, not edge corrected edf2 <- rowSums(Vc*crossprod(R))/scale if (sum(edf2)>sum(edf1)) { edf2 <- edf1 } } } ## k loop } else edf2 <- Vc <- NULL list(Vc=Vc,Vb=Vb,Ve=Ve,edf=edf,edf1=edf1,edf2=edf2,hat=hat,F=F,R=R) } ## gam.fit3.post.proc score.transect <- function(ii, x, y, sp, Eb,UrS=list(), weights = rep(1, length(y)), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, length(y)),U1,Mp,family = gaussian(), control = gam.control(), intercept = TRUE,deriv=2, gamma=1,scale=1,printWarn=TRUE,scoreType="REML",eps=1e-7,null.coef=rep(0,ncol(x)),...) { ## plot a transect through the score for sp[ii] np <- 200 if (scoreType%in%c("REML","P-REML","ML","P-ML")) reml <- TRUE else reml <- FALSE score <- spi <- seq(-30,30,length=np) for (i in 1:np) { sp[ii] <- spi[i] b<-gam.fit3(x=x, y=y, sp=sp,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=0, control=control,gamma=gamma,scale=scale, printWarn=FALSE,mustart=mustart,scoreType=scoreType,null.coef=null.coef,...) if (reml) { score[i] <- b$REML } else if (scoreType=="GACV") { score[i] <- b$GACV } else if (scoreType=="UBRE"){ score[i] <- b$UBRE } else { ## default to deviance based GCV score[i] <- b$GCV } } par(mfrow=c(2,2),mar=c(4,4,1,1)) plot(spi,score,xlab="log(sp)",ylab=scoreType,type="l") plot(spi[1:(np-1)],score[2:np]-score[1:(np-1)],type="l",ylab="differences") plot(spi,score,ylim=c(score[1]-.1,score[1]+.1),type="l") plot(spi,score,ylim=c(score[np]-.1,score[np]+.1),type="l") } ## score.transect deriv.check <- function(x, y, sp, Eb,UrS=list(), weights = rep(1, length(y)), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, length(y)),U1,Mp,family = gaussian(), control = gam.control(), intercept = TRUE,deriv=2, gamma=1,scale=1,printWarn=TRUE,scoreType="REML",eps=1e-7, null.coef=rep(0,ncol(x)),Sl=Sl,...) ## FD checking of derivatives: basically a debugging routine { if (!deriv%in%c(1,2)) stop("deriv should be 1 or 2") if (control$epsilon>1e-9) control$epsilon <- 1e-9 b<-gam.fit3(x=x, y=y, sp=sp,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=deriv, control=control,gamma=gamma,scale=scale,printWarn=FALSE, start=start,etastart=etastart,mustart=mustart,scoreType=scoreType, null.coef=null.coef,Sl=Sl,...) P0 <- b$P;fd.P1 <- P10 <- b$P1; if (deriv==2) fd.P2 <- P2 <- b$P2 trA0 <- b$trA;fd.gtrA <- gtrA0 <- b$trA1 ; if (deriv==2) fd.htrA <- htrA <- b$trA2 dev0 <- b$deviance;fd.D1 <- D10 <- b$D1 ; if (deriv==2) fd.D2 <- D2 <- b$D2 fd.db <- b$db.drho*0 if (scoreType%in%c("REML","P-REML","ML","P-ML")) reml <- TRUE else reml <- FALSE if (reml) { score0 <- b$REML;grad0 <- b$REML1; if (deriv==2) hess <- b$REML2 } else if (scoreType=="GACV") { score0 <- b$GACV;grad0 <- b$GACV1;if (deriv==2) hess <- b$GACV2 } else if (scoreType=="UBRE"){ score0 <- b$UBRE;grad0 <- b$UBRE1;if (deriv==2) hess <- b$UBRE2 } else { ## default to deviance based GCV score0 <- b$GCV;grad0 <- b$GCV1;if (deriv==2) hess <- b$GCV2 } fd.grad <- grad0*0 if (deriv==2) fd.hess <- hess diter <- rep(20,length(sp)) for (i in 1:length(sp)) { sp1 <- sp;sp1[i] <- sp[i]+eps/2 bf<-gam.fit3(x=x, y=y, sp=sp1,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=deriv, control=control,gamma=gamma,scale=scale,printWarn=FALSE, start=start,etastart=etastart,mustart=mustart,scoreType=scoreType, null.coef=null.coef,Sl=Sl,...) sp1 <- sp;sp1[i] <- sp[i]-eps/2 bb<-gam.fit3(x=x, y=y, sp=sp1, Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=deriv, control=control,gamma=gamma,scale=scale,printWarn=FALSE, start=start,etastart=etastart,mustart=mustart,scoreType=scoreType, null.coef=null.coef,Sl=Sl,...) diter[i] <- bf$iter - bb$iter ## check iteration count same fd.db[,i] <- (bf$coefficients - bb$coefficients)/eps if (!reml) { Pb <- bb$P;Pf <- bf$P P1b <- bb$P1;P1f <- bf$P1 trAb <- bb$trA;trAf <- bf$trA gtrAb <- bb$trA1;gtrAf <- bf$trA1 devb <- bb$deviance;devf <- bf$deviance D1b <- bb$D1;D1f <- bf$D1 } if (reml) { scoreb <- bb$REML;scoref <- bf$REML; if (deriv==2) { gradb <- bb$REML1;gradf <- bf$REML1} } else if (scoreType=="GACV") { scoreb <- bb$GACV;scoref <- bf$GACV; if (deriv==2) { gradb <- bb$GACV1;gradf <- bf$GACV1} } else if (scoreType=="UBRE"){ scoreb <- bb$UBRE; scoref <- bf$UBRE; if (deriv==2) { gradb <- bb$UBRE1;gradf <- bf$UBRE1} } else { ## default to deviance based GCV scoreb <- bb$GCV;scoref <- bf$GCV; if (deriv==2) { gradb <- bb$GCV1;gradf <- bf$GCV1} } if (!reml) { fd.P1[i] <- (Pf-Pb)/eps fd.gtrA[i] <- (trAf-trAb)/eps fd.D1[i] <- (devf - devb)/eps } fd.grad[i] <- (scoref-scoreb)/eps if (deriv==2) { fd.hess[,i] <- (gradf-gradb)/eps if (!reml) { fd.htrA[,i] <- (gtrAf-gtrAb)/eps fd.P2[,i] <- (P1f-P1b)/eps fd.D2[,i] <- (D1f-D1b)/eps } } } if (!reml) { cat("\n Pearson Statistic... \n") cat("grad ");print(P10) cat("fd.grad ");print(fd.P1) if (deriv==2) { fd.P2 <- .5*(fd.P2 + t(fd.P2)) cat("hess\n");print(P2) cat("fd.hess\n");print(fd.P2) } cat("\n\n tr(A)... \n") cat("grad ");print(gtrA0) cat("fd.grad ");print(fd.gtrA) if (deriv==2) { fd.htrA <- .5*(fd.htrA + t(fd.htrA)) cat("hess\n");print(htrA) cat("fd.hess\n");print(fd.htrA) } cat("\n Deviance... \n") cat("grad ");print(D10) cat("fd.grad ");print(fd.D1) if (deriv==2) { fd.D2 <- .5*(fd.D2 + t(fd.D2)) cat("hess\n");print(D2) cat("fd.hess\n");print(fd.D2) } } plot(b$db.drho,fd.db,pch=".") for (i in 1:ncol(fd.db)) points(b$db.drho[,i],fd.db[,i],pch=19,cex=.3,col=i) cat("\n\n The objective...\n") cat("diter ");print(diter) cat("grad ");print(grad0) cat("fd.grad ");print(fd.grad) if (deriv==2) { fd.hess <- .5*(fd.hess + t(fd.hess)) cat("hess\n");print(hess) cat("fd.hess\n");print(fd.hess) } NULL } ## deriv.check rt <- function(x,r1) { ## transform of x, asymptoting to values in r1 ## returns derivatives wrt to x as well as transform values ## r1[i] == NA for no transform x <- as.numeric(x) ind <- x>0 rho2 <- rho1 <- rho <- 0*x if (length(r1)==1) r1 <- x*0+r1 h <- exp(x[ind])/(1+exp(x[ind])) h1 <- h*(1-h);h2 <- h1*(1-2*h) rho[ind] <- r1[ind]*(h-0.5)*2 rho1[ind] <- r1[ind]*h1*2 rho2[ind] <- r1[ind]*h2*2 rho[!ind] <- r1[!ind]*x[!ind]/2 rho1[!ind] <- r1[!ind]/2 ind <- is.na(r1) rho[ind] <- x[ind] rho1[ind] <- 1 rho2[ind] <- 0 list(rho=rho,rho1=rho1,rho2=rho2) } ## rt rti <- function(r,r1) { ## inverse of rti. r <- as.numeric(r) ind <- r>0 x <- r if (length(r1)==1) r1 <- x*0+r1 r2 <- r[ind]*.5/r1[ind] + .5 x[ind] <- log(r2/(1-r2)) x[!ind] <- 2*r[!ind]/r1[!ind] ind <- is.na(r1) x[ind] <- r[ind] x } ## rti simplyFit <- function(lsp,X,y,Eb,UrS,L,lsp0,offset,U1,Mp,family,weights, control,gamma,scale,conv.tol=1e-6,maxNstep=5,maxSstep=2, maxHalf=30,printWarn=FALSE,scoreType="deviance", mustart = NULL,null.coef=rep(0,ncol(X)),Sl=Sl,...) ## function with same argument list as `newton' and `bfgs' which simply fits ## the model given the supplied smoothing parameters... { reml <- scoreType%in%c("REML","P-REML","ML","P-ML") ## REML/ML indicator ## sanity check L if (is.null(L)) L <- diag(length(lsp)) else { if (!inherits(L,"matrix")) stop("L must be a matrix.") if (nrow(L)lsp1.max lsp[ind] <- lsp1.max[ind]-1 ## reset lsp's already over limit delta <- rti(lsp,lsp1.max) ## initial optimization parameters } else { ## optimization parameters are just lsp delta <- lsp } ## code designed to be turned on during debugging... check.derivs <- FALSE;sp.trace <- FALSE if (check.derivs) { deriv <- 2 eps <- 1e-4 deriv.check(x=X, y=y, sp=L%*%lsp+lsp0, Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=deriv, control=control,gamma=gamma,scale=scale, printWarn=FALSE,start=start,mustart=mustart, scoreType=scoreType,eps=eps,null.coef=null.coef,Sl=Sl,...) } # ii <- 0 # if (ii>0) { # score.transect(ii,x=X, y=y, sp=L%*%lsp+lsp0, Eb=Eb,UrS=UrS, # offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=deriv, # control=control,gamma=gamma,scale=scale, # printWarn=FALSE,mustart=mustart, # scoreType=scoreType,eps=eps,null.coef=null.coef,...) # } ## ... end of debugging code ## initial fit initial.lsp <- lsp ## used if edge correcting to set direction of correction b<-gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=2, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=start, mustart=mustart,scoreType=scoreType,null.coef=null.coef,pearson.extra=pearson.extra, dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) mustart <- b$fitted.values etastart <- b$linear.predictors start <- b$coefficients if (reml) { old.score <- score <- b$REML;grad <- b$REML1;hess <- b$REML2 } else if (scoreType=="GACV") { old.score <- score <- b$GACV;grad <- b$GACV1;hess <- b$GACV2 } else if (scoreType=="UBRE"){ old.score <- score <- b$UBRE;grad <- b$UBRE1;hess <- b$UBRE2 } else { ## default to deviance based GCV old.score <- score <- b$GCV;grad <- b$GCV1;hess <- b$GCV2 } grad <- t(L)%*%grad hess <- t(L)%*%hess%*%L if (!is.null(lsp.max)) { ## need to transform to delta space rho <- rt(delta,lsp1.max) nr <- length(rho$rho1) hess <- diag(rho$rho1,nr,nr)%*%hess%*%diag(rho$rho1,nr,nr) + diag(rho$rho2*grad) grad <- rho$rho1*grad } if (reml) score.scale <- abs(log(b$scale.est)) + abs(score) else score.scale <- b$scale.est + abs(score) uconv.ind <- abs(grad) > score.scale*conv.tol ## check for all converged too soon, and undo ! if (!sum(uconv.ind)) uconv.ind <- uconv.ind | TRUE score.hist <- rep(NA,200) ################################ ## Start of Newton iteration.... ################################ qerror.thresh <- .8 ## quadratic approx error to tolerate in a step for (i in 1:200) { if (control$trace) { cat("\n",i,"newton max(|grad|) =",max(abs(grad)),"\n") } ## debugging code for checking derivatives .... okc <- check.derivs while (okc) { okc <- FALSE eps <- 1e-4 deriv <- 2 if (okc) { ## optional call to fitting to facilitate debugging trial.der <- 2 ## can reset if derivs not wanted b <- gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=trial.der, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=start, mustart=mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) } deriv.check(x=X, y=y, sp=L%*%lsp+lsp0, Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=deriv, control=control,gamma=gamma,scale=scale, printWarn=FALSE,etastart=etastart,start=start, scoreType=scoreType,eps=eps,null.coef=null.coef,Sl=Sl,...) if (inherits(family,"general.family")) { ## call gam.fit5 checking eps <- 1e-6 spe <- 1e-3 er <- deriv.check5(x=X, y=y, sp=L%*%lsp+lsp0, weights = weights, start = start, offset = offset,Mp=Mp,family = family, control = control,deriv=deriv,eps=eps,spe=spe, Sl=Sl,...) ## ignore codetools warning } } ## end of derivative checking # ii <- 0 # if (ii>0) { # score.transect(ii,x=X, y=y, sp=L%*%lsp+lsp0, Eb=Eb,UrS=UrS, # offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=deriv, # control=control,gamma=gamma,scale=scale, # printWarn=FALSE,mustart=mustart, # scoreType=scoreType,eps=eps,null.coef=null.coef,...) # } ## exclude dimensions from Newton step when the derviative is ## tiny relative to largest, as this space is likely to be poorly ## modelled on scale of Newton step... uconv.ind1 <- uconv.ind & abs(grad)>max(abs(grad))*.001 if (sum(uconv.ind1)==0) uconv.ind1 <- uconv.ind ## nothing left reset if (sum(uconv.ind)==0) uconv.ind[which(abs(grad)==max(abs(grad)))] <- TRUE ## need at least 1 to update ## exclude apparently converged gradients from computation hess1 <- hess[uconv.ind,uconv.ind] grad1 <- grad[uconv.ind] ## get the trial step ... eh <- eigen(hess1,symmetric=TRUE) d <- eh$values;U <- eh$vectors indef <- (sum(-d > abs(d[1])*.Machine$double.eps^.5)>0) ## indefinite problem ## need a different test if there is only one smoothing parameter, ## otherwise infinite sp can count as always indefinite... if (indef && length(d)==1) indef <- d < -score.scale * .Machine$double.eps^.5 ## set eigen-values to their absolute value - heuristically appealing ## as it avoids very long steps being proposed for indefinte components, ## unlike setting -ve e.v.s to very small +ve constant... ind <- d < 0 pdef <- if (sum(ind)>0) FALSE else TRUE ## is it positive definite? d[ind] <- -d[ind] ## see Gill Murray and Wright p107/8 low.d <- max(d)*.Machine$double.eps^.7 ind <- d < low.d if (sum(ind)>0) pdef <- FALSE ## not certain it is positive definite d[ind] <- low.d ind <- d != 0 d[ind] <- 1/d[ind] Nstep <- 0 * grad Nstep[uconv.ind] <- -drop(U%*%(d*(t(U)%*%grad1))) # (modified) Newton direction Sstep <- -grad/max(abs(grad)) # steepest descent direction ms <- max(abs(Nstep)) ## note smaller permitted step if !pdef mns <- maxNstep if (ms>maxNstep) Nstep <- mns * Nstep/ms sd.unused <- TRUE ## steepest descent direction not yet tried ## try the step ... if (sp.trace) cat(lsp,"\n") if (!is.null(lsp.max)) { ## need to take step in delta space delta1 <- delta + Nstep lsp1 <- rt(delta1,lsp1.max)$rho ## transform to log sp space while (max(abs(lsp1-lsp))>maxNstep) { ## make sure step is not too long Nstep <- Nstep / 2 delta1 <- delta + Nstep lsp1 <- rt(delta1,lsp1.max)$rho } } else lsp1 <- lsp + Nstep ## if pdef==TRUE then get grad and hess immediately, otherwise postpone as ## the steepest descent direction should be tried as well as Newton b <- gam.fit3(x=X, y=y, sp=L%*%lsp1+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=as.numeric(pdef)*2, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=start, mustart=mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) ## get the change predicted for this step according to the quadratic model pred.change <- sum(grad*Nstep) + 0.5*t(Nstep) %*% hess %*% Nstep if (reml) { score1 <- b$REML } else if (scoreType=="GACV") { score1 <- b$GACV } else if (scoreType=="UBRE") { score1 <- b$UBRE } else score1 <- b$GCV ## accept if improvement, else step halve ii <- 0 ## step halving counter score.change <- score1 - score qerror <- abs(pred.change-score.change)/(max(abs(pred.change),abs(score.change))+score.scale*conv.tol) ## quadratic approx error if (is.finite(score1) && score.change<0 && pdef && qerror < qerror.thresh) { ## immediately accept step if it worked and positive definite old.score <- score mustart <- b$fitted.values etastart <- b$linear.predictors start <- b$coefficients lsp <- lsp1 if (reml) { score <- b$REML;grad <- b$REML1;hess <- b$REML2 } else if (scoreType=="GACV") { score <- b$GACV;grad <- b$GACV1;hess <- b$GACV2 } else if (scoreType=="UBRE") { score <- b$UBRE;grad <- b$UBRE1;hess <- b$UBRE2 } else { score <- b$GCV;grad <- b$GCV1;hess <- b$GCV2} grad <- t(L)%*%grad hess <- t(L)%*%hess%*%L if (!is.null(lsp.max)) { ## need to transform to delta space delta <- delta1 rho <- rt(delta,lsp1.max) nr <- length(rho$rho1) hess <- diag(rho$rho1,nr,nr)%*%hess%*%diag(rho$rho1,nr,nr) + diag(rho$rho2*grad) grad <- rho$rho1*grad } } else if (!is.finite(score1) || score1>=score||qerror >= qerror.thresh) { ## initial step failed, try step halving ... step <- Nstep ## start with the (pseudo) Newton direction while ((!is.finite(score1) || score1>=score ||qerror >= qerror.thresh) && ii < maxHalf) { if (ii==3&&i<10) { ## Newton really not working - switch to SD, but keeping step length s.length <- min(sum(step^2)^.5,maxSstep) step <- Sstep*s.length/sum(Sstep^2)^.5 ## use steepest descent direction sd.unused <- FALSE ## signal that SD already tried } else step <- step/2 if (!is.null(lsp.max)) { ## need to take step in delta space delta1 <- delta + step lsp1 <- rt(delta1,lsp1.max)$rho ## transform to log sp space } else lsp1 <- lsp + step b1<-gam.fit3(x=X, y=y, sp=L%*%lsp1+lsp0,Eb=Eb,UrS=UrS,offset = offset,U1=U1,Mp=Mp, family = family,weights=weights,deriv=0,control=control,gamma=gamma, scale=scale,printWarn=FALSE,start=start,mustart=mustart,scoreType=scoreType, null.coef=null.coef,pearson.extra=pearson.extra,dev.extra=dev.extra, n.true=n.true,Sl=Sl,...) pred.change <- sum(grad*step) + 0.5*t(step) %*% hess %*% step ## Taylor prediction of change if (reml) { score1 <- b1$REML } else if (scoreType=="GACV") { score1 <- b1$GACV } else if (scoreType=="UBRE") { score1 <- b1$UBRE } else score1 <- b1$GCV score.change <- score1 - score ## don't allow step to fail altogether just because of qerror qerror <- if (ii>min(4,maxHalf/2)) qerror.thresh/2 else abs(pred.change-score.change)/(max(abs(pred.change),abs(score.change))+score.scale*conv.tol) ## quadratic approx error if (is.finite(score1) && score.change < 0 && qerror < qerror.thresh) { ## accept if (pdef||!sd.unused) { ## then accept and compute derivatives b <- gam.fit3(x=X, y=y, sp=L%*%lsp1+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=2, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=start, mustart=mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) mustart <- b$fitted.values etastart <- b$linear.predictors start <- b$coefficients old.score <- score;lsp <- lsp1 if (reml) { score <- b$REML;grad <- b$REML1;hess <- b$REML2 } else if (scoreType=="GACV") { score <- b$GACV;grad <- b$GACV1;hess <- b$GACV2 } else if (scoreType=="UBRE") { score <- b$UBRE;grad <- b$UBRE1;hess <- b$UBRE2 } else { score <- b$GCV;grad <- b$GCV1;hess <- b$GCV2} grad <- t(L)%*%grad hess <- t(L)%*%hess%*%L if (!is.null(lsp.max)) { ## need to transform to delta space delta <- delta1 rho <- rt(delta,lsp1.max) nr <- length(rho$rho1) hess <- diag(rho$rho1,nr,nr)%*%hess%*%diag(rho$rho1,nr,nr) + diag(rho$rho2*grad) grad <- rho$rho1*grad } } else { ## still need to try the steepest descent step to see if it does better b <- b1 score2 <- score1 ## store temporarily and restore below } score1 <- score - abs(score) - 1 ## make sure that score1 < score (restore once out of loop) } # end of if (score1<= score ) # accept if (!is.finite(score1) || score1>=score || qerror >= qerror.thresh) ii <- ii + 1 } ## end while (score1>score && ii < maxHalf) if (!pdef&&sd.unused&&iiscore2)||kk==40) ok <- FALSE } ## while (ok) ## step length control loop ## now pick the step that led to the biggest decrease if (is.finite(score2) && score2 score.scale*conv.tol*.1)|(abs(grad2)>score.scale*conv.tol*.1) if (sum(abs(grad)>score.scale*conv.tol*5)) converged <- FALSE if (abs(old.score-score)>score.scale*conv.tol) { if (converged) uconv.ind <- uconv.ind | TRUE ## otherwise can't progress converged <- FALSE } if (ii==maxHalf) converged <- TRUE ## step failure if (converged) break } ## end of iteration loop if (ii==maxHalf) { ct <- "step failed" warning("Fitting terminated with step failure - check results carefully") } else if (i==200) { ct <- "iteration limit reached" warning("Iteration limit reached without full convergence - check carefully") } else ct <- "full convergence" b$dVkk <- NULL if (as.logical(edge.correct)&&reml) { ## for those smoothing parameters that appear to be at working infinity ## reduce them until there is a detectable increase in RE/ML... flat <- which(abs(grad2) < abs(grad)*100) ## candidates for reduction REML <- b$REML alpha <- if (is.logical(edge.correct)) .02 else abs(edge.correct) ## target RE/ML change per sp b1 <- b; lsp1 <- lsp if (length(flat)) { step <- as.numeric(initial.lsp - lsp)*2-1 for (i in flat) { REML <- b1$REML + alpha while (b1$REML < REML) { lsp1[i] <- lsp1[i] + step[i] b1 <- gam.fit3(x=X, y=y, sp=L%*%lsp1+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=0, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=start, mustart=mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) } } } ## if length(flat) b1 <- gam.fit3(x=X, y=y, sp=L%*%lsp1+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=2, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=start, mustart=mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) score1 <- b1$REML;grad1 <- b1$REML1;hess1 <- b1$REML2 grad1 <- t(L)%*%grad1 hess1 <- t(L)%*%hess1%*%L if (!is.null(lsp.max)) { ## need to transform to delta space delta <- delta1 rho <- rt(delta,lsp1.max) nr <- length(rho$rho1) hess1 <- diag(rho$rho1,nr,nr)%*%hess1%*%diag(rho$rho1,nr,nr) + diag(rho$rho2*grad1) grad1 <- rho$rho1*grad1 } attr(hess,"edge.correct") <- TRUE attr(hess,"hess1") <- hess1 attr(hess,"db.drho1") <- b1$db.drho attr(hess,"dw.drho1") <- b1$dw.drho attr(hess,"lsp1") <- lsp1 attr(hess,"rp") <- b1$rp } ## if edge.correct list(score=score,lsp=lsp,lsp.full=L%*%lsp+lsp0,grad=grad,hess=hess,iter=i, conv =ct,score.hist = score.hist[!is.na(score.hist)],object=b) } ## newton bfgs <- function(lsp,X,y,Eb,UrS,L,lsp0,offset,U1,Mp,family,weights, control,gamma,scale,conv.tol=1e-6,maxNstep=3,maxSstep=2, maxHalf=30,printWarn=FALSE,scoreType="GCV",start=NULL, mustart = NULL,null.coef=rep(0,ncol(X)),pearson.extra=0, dev.extra=0,n.true=-1,Sl=NULL,...) ## BFGS optimizer to estimate smoothing parameters of models fitted by ## gam.fit3.... ## ## L is the matrix such that L%*%lsp + lsp0 gives the logs of the smoothing ## parameters actually multiplying the S[[i]]'s. sp's do not include the ## log scale parameter here. ## ## BFGS is based on Nocedal & Wright (2006) Numerical Optimization, Springer. ## 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. ## { zoom <- function(lo,hi) { ## 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) lsp <- ilsp + step * trial$alpha b <- gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=0, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=lo$start, mustart=lo$mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) trial$mustart <- fitted(b) trial$scale.est <- b$scale.est ## previously dev, but this differs from newton trial$start <- coef(b) if (reml) { trial$score <- b$REML; } else if (scoreType=="GACV") { trial$score <- b$GACV; } else if (scoreType=="UBRE"){ trial$score <- b$UBRE; } else { ## default to deviance based GCV trial$score <- b$GCV; } rm(b) if (trial$score>initial$score+trial$alpha*c1*initial$dscore||trial$score>=lo$score) { hi <- trial ## failed Wolfe 1 } else { ## met Wolfe 1 b <- gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=1, control=control,gamma=gamma,scale=scale,printWarn=FALSE, start=trial$start,mustart=trial$mustart, scoreType=scoreType,null.coef=null.coef,pearson.extra=pearson.extra, dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) if (reml) { trial$grad <- t(L)%*%b$REML1; } else if (scoreType=="GACV") { trial$grad <- t(L)%*%b$GACV1; } else if (scoreType=="UBRE"){ trial$grad <- t(L)%*%b$UBRE1 } else { ## default to deviance based GCV trial$grad <- t(L)%*%b$GCV1; } trial$dVkk <- diag(t(L0) %*% b$dVkk %*% L0) trial$scale.est <- b$scale.est;rm(b); trial$dscore <- sum(step*trial$grad) ## directional derivative if (abs(trial$dscore) <= -c2*initial$dscore) return(trial) ## met Wolfe 2 ## failed Wolfe 2 ... if (trial$dscore*(hi$alpha-lo$alpha)>=0) { hi <- lo } lo <- trial } } ## end while(TRUE) return(NULL) ## failed } ## end zoom reml <- scoreType%in%c("REML","P-REML","ML","P-ML") ## REML/ML indicator ## sanity check L if (is.null(L)) L <- diag(length(lsp)) else { if (!inherits(L,"matrix")) stop("L must be a matrix.") if (nrow(L)0) { ind <- 1:family$n.theta nind <- ncol(L) - family$n.theta - if (family$n.theta + nrow(b$dVkk)0) family$n.theta+1:nind else rep(0,0) rspind <- family$n.theta + 1:nrow(b$dVkk) } else { nind <- ncol(L) - if (nrow(b$dVkk)0) 1:nind else rep(0,0) ## index of smooth parameters rspind <- 1:nrow(b$dVkk) } L0 <- L[rspind,spind] ##if (nrow(L)!=nrow(b$dVkk)) L[spind,spind] else L initial$dVkk <- diag(t(L0) %*% b$dVkk %*% L0) initial$score <- score;initial$grad <- grad; initial$scale.est <- b$scale.est start0 <- coef(b) mustart0 <- fitted(b) rm(b) B <- diag(length(initial$grad)) ## initial Hessian feps <- 1e-4 for (i in 1:length(lsp)) { ## loop to FD for Hessian ilsp <- lsp;ilsp[i] <- ilsp[i] + feps b <- gam.fit3(x=X, y=y, sp=L%*%ilsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=1, control=control,gamma=gamma,scale=scale,printWarn=FALSE, start=start0,mustart=mustart0, scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) if (reml) { grad1 <- t(L)%*%b$REML1; } else if (scoreType=="GACV") { grad1 <- t(L)%*%b$GACV1; } else if (scoreType=="UBRE"){ grad1 <- t(L)%*%b$UBRE1 } else { ## default to deviance based GCV grad1 <- t(L)%*%b$GCV1; } 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) lsp <- ilsp + trial$alpha*step b <- gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=deriv, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=prev$start, mustart=prev$mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) ### Derivative testing code. Not usually called and not part of BFGS... ok <- check.derivs while (ok) { ## derivative testing #deriv <- 1 ok <- FALSE ## set to TRUE to re-run (e.g. with different eps) deriv.check(x=X, y=y, sp=L%*%lsp+lsp0, Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=1, control=control,gamma=gamma,scale=scale, printWarn=FALSE,mustart=mustart,start=start, scoreType=scoreType,eps=eps,null.coef=null.coef,Sl=Sl,...) ## deal with fact that deriv might be 0... bb <- if (deriv==1) b else gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=1, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=prev$start, mustart=prev$mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) fdH <- bb$dH fdb.dr <- bb$db.drho*0 for (j in 1:length(lsp)) { ## check dH and db.drho lsp1 <- lsp;lsp1[j] <- lsp[j] + eps ba <- gam.fit3(x=X, y=y, sp=L%*%lsp1+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=1, control=control,gamma=gamma,scale=scale,printWarn=FALSE,start=prev$start, mustart=prev$mustart,scoreType=scoreType,null.coef=null.coef, pearson.extra=pearson.extra,dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) fdH[[j]] <- (ba$H - bb$H)/eps fdb.dr[,j] <- (ba$coefficients - bb$coefficients)/eps } } ### end of derivative testing. BFGS code resumes... if (reml) { trial$score <- b$REML; } else if (scoreType=="GACV") { trial$score <- b$GACV; } else if (scoreType=="UBRE"){ trial$score <- b$UBRE; } else { ## default to deviance based GCV trial$score <- b$GCV; } if (deriv>0) { if (reml) { trial$grad <- t(L)%*%b$REML1; } else if (scoreType=="GACV") { trial$grad <- t(L)%*%b$GACV1; } else if (scoreType=="UBRE"){ trial$grad <- t(L)%*%b$UBRE1 } else { ## default to deviance based GCV trial$grad <- t(L)%*%b$GCV1; } trial$dVkk <- diag(t(L0) %*% b$dVkk %*% L0) ## curvature testing matrix trial$dscore <- sum(trial$grad*step) deriv <- 0 } else trial$grad <- trial$dscore <- NULL trial$mustart <- b$fitted.values trial$start <- b$coefficients trial$scale.est <- b$scale.est rm(b) Wolfe2 <- TRUE ## check the first Wolfe condition (sufficient decrease)... if (trial$score>initial$score+c1*trial$alpha*initial$dscore||(deriv==0&&trial$score>=prev$score)) { trial <- zoom(prev,trial) ## Wolfe 1 not met so backtracking break } if (is.null(trial$dscore)) { ## getting gradients b <- gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=1, control=control,gamma=gamma,scale=scale,printWarn=FALSE, start=trial$start,mustart=trial$mustart, scoreType=scoreType,null.coef=null.coef,pearson.extra=pearson.extra, dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) if (reml) { trial$grad <- t(L)%*%b$REML1; } else if (scoreType=="GACV") { trial$grad <- t(L)%*%b$GACV1; } else if (scoreType=="UBRE"){ trial$grad <- t(L)%*%b$UBRE1 } else { ## default to deviance based GCV trial$grad <- t(L)%*%b$GCV1; } trial$dscore <- sum(trial$grad*step) trial$scale.est <- b$scale.est trial$dVkk <- diag(t(L0) %*% b$dVkk %*% L0) ## curvature testing matrix rm(b) } ## 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 lsp <- ilsp break ## failed to move, so nothing more can be done. } 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 my 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 (left as an exercise for the reader)... B <- B - rho*(B%*%yg)%*%t(step) + rho*step%*%t(step) } score.hist[i+1] <- trial$score lsp <- ilsp <- ilsp + step ## test for convergence converged <- TRUE if (reml) score.scale <- 1 + abs(trial$score) ## abs(log(trial$dev/nrow(X))) + abs(trial$score) else score.scale <- abs(trial$scale.est) + abs(trial$score) ##trial$dev/nrow(X) + abs(trial$score) uconv.ind <- abs(trial$grad) > score.scale*conv.tol if (sum(uconv.ind)) converged <- FALSE #if (length(uconv.ind)>length(trial$dVkk)) trial$dVkk <- c(trial$dVkk,score.scale) ## following must be tighter than convergence... uconv.ind <- abs(trial$grad) > score.scale*conv.tol*.1 uconv.ind[spind] <- uconv.ind[spind] | abs(trial$dVkk) > score.scale * conv.tol*.1 if (abs(initial$score-trial$score) > score.scale*conv.tol) { if (!sum(uconv.ind)) uconv.ind <- uconv.ind | TRUE ## otherwise can't progress converged <- FALSE } ## roll back any `infinite' smoothing parameters to the point at ## which score carries some information about them and continue ## optimization. Guards against early long steps missing shallow minimum. if (converged) { ## try roll back for `working inf' sps... 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... lsp[!uconv.ind0] <- lsp[!uconv.ind0]*.8 + initial.lsp[!uconv.ind0]*.2 b <- gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=1, control=control,gamma=gamma,scale=scale,printWarn=FALSE, start=trial$start,mustart=trial$mustart, scoreType=scoreType,null.coef=null.coef,pearson.extra=pearson.extra, dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) if (reml) { trial$score <- b$REML trial$grad <- t(L)%*%b$REML1; } else if (scoreType=="GACV") { trial$score <- b$GACV trial$grad <- t(L)%*%b$GACV1; } else if (scoreType=="UBRE"){ trial$score <- b$UBRE trial$grad <- t(L)%*%b$UBRE1 } else { ## default to deviance based GCV trial$score <- b$GCV trial$grad <- t(L)%*%b$GCV1; } trial$dscore <- sum(trial$grad*step) trial$scale.est <- b$scale.est trial$dVkk <- diag(t(L0) %*% b$dVkk %*% L0) ## curvature testing matrix #if (length(uconv.ind)>length(trial$dVkk)) trial$dVkk <- c(trial$dVkk,score.scale) 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[spind] <- uconv.ind0[spind] | abs(trial$dVkk) > score.scale * conv.tol * 20 uconv.ind0 <- uconv.ind0 | uconv.ind ## make sure we don't start rolling back unproblematic sps } uconv.ind <- uconv.ind | TRUE ## following line is tempting, but will likely reduce usefullness of B as approximtion ## to inverse Hessian on return... ##B <- diag(diag(B),nrow=nrow(B)) ilsp <- lsp } initial <- trial initial$alpha <- 0 } } ## end of iteration loop if (is.null(trial)) { ct <- "step failed" lsp <- ilsp trial <- initial } else if (i==max.step) ct <- "iteration limit reached" else ct <- "full convergence" ## final fit b <- gam.fit3(x=X, y=y, sp=L%*%lsp+lsp0,Eb=Eb,UrS=UrS, offset = offset,U1=U1,Mp=Mp,family = family,weights=weights,deriv=1, control=control,gamma=gamma,scale=scale,printWarn=FALSE, start=trial$start,mustart=trial$mustart, scoreType=scoreType,null.coef=null.coef,pearson.extra=pearson.extra, dev.extra=dev.extra,n.true=n.true,Sl=Sl,...) if (reml) { score <- b$REML;grad <- t(L)%*%b$REML1; } else if (scoreType=="GACV") { score <- b$GACV;grad <- t(L)%*%b$GACV1; } else if (scoreType=="UBRE"){ score <- b$UBRE;grad <- t(L)%*%b$UBRE1 } else { ## default to deviance based GCV score <- b$GCV;grad <- t(L)%*%b$GCV1; } b$dVkk <- NULL ## get approximate Hessian... 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 B <- ev$vectors %*% (ev$values*t(ev$vectors)) list(score=score,lsp=lsp,lsp.full=L%*%lsp+lsp0,grad=grad,hess=B,iter=i,conv =ct, score.hist=score.hist[!is.na(score.hist)],object=b) } ## end of bfgs gam2derivative <- function(lsp,args,...) ## Performs IRLS GAM fitting for smoothing parameters given in lsp ## and returns the derivatives of the GCV or UBRE score w.r.t the ## smoothing parameters for the model. ## args is a list containing the arguments for gam.fit3 ## For use as optim() objective gradient { reml <- args$scoreType%in%c("REML","P-REML","ML","P-ML") ## REML/ML indicator if (!is.null(args$L)) { lsp <- args$L%*%lsp + args$lsp0 } b<-gam.fit3(x=args$X, y=args$y, sp=lsp,Eb=args$Eb,UrS=args$UrS, offset = args$offset,U1=args$U1,Mp=args$Mp,family = args$family,weights=args$w,deriv=1, control=args$control,gamma=args$gamma,scale=args$scale,scoreType=args$scoreType, null.coef=args$null.coef,n.true=args$n.true,Sl=args$Sl,...) if (reml) { ret <- b$REML1 } else if (args$scoreType=="GACV") { ret <- b$GACV1 } else if (args$scoreType=="UBRE") { ret <- b$UBRE1 } else { ret <- b$GCV1} if (!is.null(args$L)) ret <- t(args$L)%*%ret ret } ## gam2derivative gam2objective <- function(lsp,args,...) ## Performs IRLS GAM fitting for smoothing parameters given in lsp ## and returns the GCV or UBRE score for the model. ## args is a list containing the arguments for gam.fit3 ## For use as optim() objective { reml <- args$scoreType%in%c("REML","P-REML","ML","P-ML") ## REML/ML indicator if (!is.null(args$L)) { lsp <- args$L%*%lsp + args$lsp0 } b<-gam.fit3(x=args$X, y=args$y, sp=lsp,Eb=args$Eb,UrS=args$UrS, offset = args$offset,U1=args$U1,Mp=args$Mp,family = args$family,weights=args$w,deriv=0, control=args$control,gamma=args$gamma,scale=args$scale,scoreType=args$scoreType, null.coef=args$null.coef,n.true=args$n.true,Sl=args$Sl,start=args$start,...) if (reml) { ret <- b$REML } else if (args$scoreType=="GACV") { ret <- b$GACV } else if (args$scoreType=="UBRE") { ret <- b$UBRE } else { ret <- b$GCV} attr(ret,"full.fit") <- b ret } ## gam2objective gam4objective <- function(lsp,args,...) ## Performs IRLS GAM fitting for smoothing parameters given in lsp ## and returns the GCV or UBRE score for the model. ## args is a list containing the arguments for gam.fit3 ## For use as nlm() objective { reml <- args$scoreType%in%c("REML","P-REML","ML","P-ML") ## REML/ML indicator if (!is.null(args$L)) { lsp <- args$L%*%lsp + args$lsp0 } b<-gam.fit3(x=args$X, y=args$y, sp=lsp, Eb=args$Eb,UrS=args$UrS, offset = args$offset,U1=args$U1,Mp=args$Mp,family = args$family,weights=args$w,deriv=1, control=args$control,gamma=args$gamma,scale=args$scale,scoreType=args$scoreType, null.coef=args$null.coef,Sl=args$Sl,start=args$start,...) if (reml) { ret <- b$REML;at <- b$REML1 } else if (args$scoreType=="GACV") { ret <- b$GACV;at <- b$GACV1 } else if (args$scoreType=="UBRE") { ret <- b$UBRE;at <- b$UBRE1 } else { ret <- b$GCV;at <- b$GCV1} attr(ret,"full.fit") <- b if (!is.null(args$L)) at <- t(args$L)%*%at attr(ret,"gradient") <- at ret } ## gam4objective ## ## The following fix up family objects for use with gam.fit3 ## fix.family.link.general.family <- function(fam) fix.family.link.family(fam) fix.family.link.extended.family <- function(fam) { ## extended families require link derivatives in ratio form. ## g2g= g''/g'^2, g3g = g'''/g'^3, g4g = g''''/g'^4 - these quanitities are often ## less overflow prone than the raw derivatives if (!is.null(fam$g2g)&&!is.null(fam$g3g)&&!is.null(fam$g4g)) return(fam) link <- fam$link if (link=="identity") { fam$g2g <- fam$g3g <- fam$g4g <- function(mu) rep.int(0,length(mu)) } else if (link == "log") { fam$g2g <- function(mu) rep(-1,length(mu)) fam$g3g <- function(mu) rep(2,length(mu)) fam$g4g <- function(mu) rep(-6,length(mu)) } else if (link == "inverse") { ## g'(mu) = -1/mu^2 fam$g2g <- function(mu) 2*mu ## g'' = 2/mu^3 fam$g3g <- function(mu) 6*mu^2 ## g''' = -6/mu^4 fam$g4g <- function(mu) 24*mu^3 ## g'''' = 24/mu^5 } else if (link == "logit") { ## g = log(mu/(1-mu)) g' = 1/(1-mu) + 1/mu = 1/(mu*(1-mu)) fam$g2g <- function(mu) mu^2 - (1-mu)^2 ## g'' = 1/(1 - mu)^2 - 1/mu^2 fam$g3g <- function(mu) 2*mu^3 + 2*(1-mu)^3 ## g''' = 2/(1 - mu)^3 + 2/mu^3 fam$g4g <- function(mu) 6*mu^4 - 6*(1-mu)^4 ## g'''' = 6/(1-mu)^4 - 6/mu^4 } else if (link == "sqrt") { ## g = sqrt(mu); g' = .5*mu^-.5 fam$g2g <- function(mu) - mu^-.5 ## g'' = -.25 * mu^-1.5 fam$g3g <- function(mu) 3 * mu^-1 ## g''' = .375 * mu^-2.5 fam$g4g <- function(mu) -15 * mu^-1.5 ## -0.9375 * mu^-3.5 } else if (link == "probit") { ## g(mu) = qnorm(mu); 1/g' = dmu/deta = 1/dnorm(eta) fam$g2g <- function(mu) { #eta <- fam$linkfun(mu) eta <- qnorm(mu) ## g'' = eta/fam$mu.eta(eta)^2 eta } fam$g3g <- function(mu) { #eta <- fam$linkfun(mu) eta <- qnorm(mu) ## g''' = (1 + 2*eta^2)/fam$mu.eta(eta)^3 (1 + 2*eta^2) } fam$g4g <- function(mu) { #eta <- fam$linkfun(mu) eta <- qnorm(mu) ## g'''' = (7*eta + 6*eta^3)/fam$mu.eta(eta)^4 (7*eta + 6*eta^3) } } else if (link == "cauchit") { ## uses general result that if link is a quantile function then ## d mu / d eta = f(eta) where f is the density. Link derivative ## is one over this... repeated differentiation w.r.t. mu using chain ## rule gives results... fam$g2g <- function(mu) { #eta <- fam$linkfun(mu) eta <- qcauchy(mu) ## g'' = 2*pi*pi*eta*(1+eta*eta) eta/(1+eta*eta) } fam$g3g <- function(mu) { #eta <- fam$linkfun(mu) eta <- qcauchy(mu) eta2 <- eta*eta ## g''' = 2*pi*pi*pi*(1+3*eta2)*(1+eta2) (1+3*eta2)/(1+eta2)^2 } fam$g4g <- function(mu) { #eta <- fam$linkfun(mu) eta <- qcauchy(mu) eta2 <- eta*eta ## g'''' = 2*pi^4*(8*eta+12*eta2*eta)*(1+eta2) ((8+ 12*eta2)/(1+eta2)^2)*(eta/(1+eta2)) } } else if (link == "cloglog") { ## g = log(-log(1-mu)), g' = -1/(log(1-mu)*(1-mu)) fam$g2g <- function(mu) { l1m <- log1p(-mu) -l1m - 1 } fam$g3g <- function(mu) { l1m <- log1p(-mu) l1m*(2*l1m + 3) + 2 } fam$g4g <- function(mu){ l1m <- log1p(-mu) -l1m*(l1m*(6*l1m+11)+12)-6 } } else stop("link not implemented for extended families") ## avoid storing the calling environment of fix.family.link... environment(fam$g2g) <- environment(fam$g3g) <- environment(fam$g4g) <- environment(fam$linkfun) return(fam) } ## fix.family.link.extended.family fix.family.link.family <- function(fam) # adds d2link the second derivative of the link function w.r.t. mu # to the family supplied, as well as a 3rd derivative function # d3link... # All d2link and d3link functions have been checked numerically. { if (!inherits(fam,"family")) stop("fam not a family object") if (is.null(fam$canonical)) { ## note the canonical link - saves effort in full Newton if (fam$family=="gaussian") fam$canonical <- "identity" else if (fam$family=="poisson"||fam$family=="quasipoisson") fam$canonical <- "log" else if (fam$family=="binomial"||fam$family=="quasibinomial") fam$canonical <- "logit" else if (fam$family=="Gamma") fam$canonical <- "inverse" else if (fam$family=="inverse.gaussian") fam$canonical <- "1/mu^2" else fam$canonical <- "none" } if (!is.null(fam$d2link)&&!is.null(fam$d3link)&&!is.null(fam$d4link)) return(fam) link <- fam$link if (length(link)>1) { if (fam$family=="quasi") # then it's a power link { lambda <- log(fam$linkfun(exp(1))) ## the power, if > 0 if (lambda<=0) { fam$d2link <- function(mu) -1/mu^2 fam$d3link <- function(mu) 2/mu^3 fam$d4link <- function(mu) -6/mu^4 } else { fam$d2link <- function(mu) lambda*(lambda-1)*mu^(lambda-2) fam$d3link <- function(mu) (lambda-2)*(lambda-1)*lambda*mu^(lambda-3) fam$d4link <- function(mu) (lambda-3)*(lambda-2)*(lambda-1)*lambda*mu^(lambda-4) } } else stop("unrecognized (vector?) link") } else if (link=="identity") { fam$d4link <- fam$d3link <- fam$d2link <- function(mu) rep.int(0,length(mu)) } else if (link == "log") { fam$d2link <- function(mu) -1/mu^2 fam$d3link <- function(mu) 2/mu^3 fam$d4link <- function(mu) -6/mu^4 } else if (link == "inverse") { fam$d2link <- function(mu) 2/mu^3 fam$d3link <- function(mu) { mu <- mu*mu;-6/(mu*mu)} fam$d4link <- function(mu) { mu2 <- mu*mu;24/(mu2*mu2*mu)} } else if (link == "logit") { fam$d2link <- function(mu) 1/(1 - mu)^2 - 1/mu^2 fam$d3link <- function(mu) 2/(1 - mu)^3 + 2/mu^3 fam$d4link <- function(mu) 6/(1-mu)^4 - 6/mu^4 } else if (link == "probit") { fam$d2link <- function(mu) { #eta <- fam$linkfun(mu) eta <- qnorm(mu) #eta/fam$mu.eta(eta)^2 eta/pmax(dnorm(eta), .Machine$double.eps)^2 } fam$d3link <- function(mu) { #eta <- fam$linkfun(mu) eta <- qnorm(mu) #(1 + 2*eta^2)/fam$mu.eta(eta)^3 (1 + 2*eta^2)/pmax(dnorm(eta), .Machine$double.eps)^3 } fam$d4link <- function(mu) { #eta <- fam$linkfun(mu) eta <- qnorm(mu) #(7*eta + 6*eta^3)/fam$mu.eta(eta)^4 (7*eta + 6*eta^3)/pmax(dnorm(eta), .Machine$double.eps)^4 } } else if (link == "cloglog") { ## g = log(-log(1-mu)), g' = -1/(log(1-mu)*(1-mu)) fam$d2link <- function(mu) { l1m <- log1p(-mu) -1/((1 - mu)^2*l1m) *(1+ 1/l1m) } fam$d3link <- function(mu) { l1m <- log1p(-mu) mu3 <- (1-mu)^3 (-2 - 3*l1m - 2*l1m^2)/mu3/l1m^3 } fam$d4link <- function(mu){ l1m <- log1p(-mu) mu4 <- (1-mu)^4 ( - 12 - 11 * l1m - 6 * l1m^2 - 6/l1m )/mu4 /l1m^3 } } else if (link == "sqrt") { fam$d2link <- function(mu) -.25 * mu^-1.5 fam$d3link <- function(mu) .375 * mu^-2.5 fam$d4link <- function(mu) -0.9375 * mu^-3.5 } else if (link == "cauchit") { ## uses general result that if link is a quantile function then ## d mu / d eta = f(eta) where f is the density. Link derivative ## is one over this... repeated differentiation w.r.t. mu using chain ## rule gives results... fam$d2link <- function(mu) { #eta <- fam$linkfun(mu) eta <- qcauchy(mu) 2*pi*pi*eta*(1+eta*eta) } fam$d3link <- function(mu) { #eta <- fam$linkfun(mu) eta <- qcauchy(mu) eta2 <- eta*eta 2*pi*pi*pi*(1+3*eta2)*(1+eta2) } fam$d4link <- function(mu) { #eta <- fam$linkfun(mu) eta <- qcauchy(mu) eta2 <- eta*eta 2*pi^4*(8*eta+12*eta2*eta)*(1+eta2) } } else if (link == "1/mu^2") { fam$d2link <- function(mu) 6 * mu^-4 fam$d3link <- function(mu) -24 * mu^-5 fam$d4link <- function(mu) 120 * mu^-6 } else if (substr(link,1,3)=="mu^") { ## it's a power link ## note that lambda <=0 gives log link so don't end up here lambda <- get("lambda",environment(fam$linkfun)) fam$d2link <- function(mu) (lambda*(lambda-1)) * mu^{lambda-2} fam$d3link <- function(mu) (lambda*(lambda-1)*(lambda-2)) * mu^{lambda-3} fam$d4link <- function(mu) (lambda*(lambda-1)*(lambda-2)*(lambda-3)) * mu^{lambda-4} } else stop("link not recognised") ## avoid giant environments being stored.... environment(fam$d2link) <- environment(fam$d3link) <- environment(fam$d4link) <- environment(fam$linkfun) return(fam) } ## fix.family.link.family ## NOTE: something horrible can happen here. The way method dispatch works, the ## environment attached to functions created in fix.family.link is the environment ## from which fix.family.link was called - and this whole environment is stored ## with the created function - in the gam context that means the model matrix is ## stored invisibly away for no useful purpose at all. pryr:::object_size will ## show the true stored size of an object with hidden environments. But environments ## of functions created in method functions should be set explicitly to something ## harmless (see ?environment for some possibilities, empty is rarely a good idea) ## 9/2017 fix.family.link <- function(fam) UseMethod("fix.family.link") fix.family.var <- function(fam) # adds dvar the derivative of the variance function w.r.t. mu # to the family supplied, as well as d2var the 2nd derivative of # the variance function w.r.t. the mean. (All checked numerically). { if (inherits(fam,"extended.family")) return(fam) if (!inherits(fam,"family")) stop("fam not a family object") if (!is.null(fam$dvar)&&!is.null(fam$d2var)&&!is.null(fam$d3var)) return(fam) family <- fam$family fam$scale <- -1 if (family=="gaussian") { fam$d3var <- fam$d2var <- fam$dvar <- function(mu) rep.int(0,length(mu)) } else if (family=="poisson"||family=="quasipoisson") { fam$dvar <- function(mu) rep.int(1,length(mu)) fam$d3var <- fam$d2var <- function(mu) rep.int(0,length(mu)) if (family=="poisson") fam$scale <- 1 } else if (family=="binomial"||family=="quasibinomial") { fam$dvar <- function(mu) 1-2*mu fam$d2var <- function(mu) rep.int(-2,length(mu)) fam$d3var <- function(mu) rep.int(0,length(mu)) if (family=="binomial") fam$scale <- 1 } else if (family=="Gamma") { fam$dvar <- function(mu) 2*mu fam$d2var <- function(mu) rep.int(2,length(mu)) fam$d3var <- function(mu) rep.int(0,length(mu)) } else if (family=="quasi") { fam$dvar <- switch(fam$varfun, constant = function(mu) rep.int(0,length(mu)), "mu(1-mu)" = function(mu) 1-2*mu, mu = function(mu) rep.int(1,length(mu)), "mu^2" = function(mu) 2*mu, "mu^3" = function(mu) 3*mu^2 ) if (is.null(fam$dvar)) stop("variance function not recognized for quasi") fam$d2var <- switch(fam$varfun, constant = function(mu) rep.int(0,length(mu)), "mu(1-mu)" = function(mu) rep.int(-2,length(mu)), mu = function(mu) rep.int(0,length(mu)), "mu^2" = function(mu) rep.int(2,length(mu)), "mu^3" = function(mu) 6*mu ) fam$d3var <- switch(fam$varfun, constant = function(mu) rep.int(0,length(mu)), "mu(1-mu)" = function(mu) rep.int(0,length(mu)), mu = function(mu) rep.int(0,length(mu)), "mu^2" = function(mu) rep.int(0,length(mu)), "mu^3" = function(mu) rep.int(6,length(mu)) ) } else if (family=="inverse.gaussian") { fam$dvar <- function(mu) 3*mu^2 fam$d2var <- function(mu) 6*mu fam$d3var <- function(mu) rep.int(6,length(mu)) } else stop("family not recognised") environment(fam$dvar) <- environment(fam$d2var) <- environment(fam$d3var) <- environment(fam$linkfun) return(fam) } ## fix.family.var fix.family.ls <- function(fam) # adds ls the log saturated likelihood and its derivatives # w.r.t. the scale parameter to the family object. { if (!inherits(fam,"family")) stop("fam not a family object") if (!is.null(fam$ls)) return(fam) family <- fam$family if (family=="gaussian") { fam$ls <- function(y,w,n,scale) { nobs <- sum(w>0) c(-nobs*log(2*pi*scale)/2 + sum(log(w[w>0]))/2,-nobs/(2*scale),nobs/(2*scale*scale)) } } else if (family=="poisson") { fam$ls <- function(y,w,n,scale) { res <- rep(0,3) res[1] <- sum(dpois(y,y,log=TRUE)*w) res } } else if (family=="binomial") { fam$ls <- function(y,w,n,scale) { c(-binomial()$aic(y,n,y,w,0)/2,0,0) } } else if (family=="Gamma") { fam$ls <- function(y,w,n,scale) { res <- rep(0,3) y <- y[w>0];w <- w[w>0] scale <- scale/w k <- -lgamma(1/scale) - log(scale)/scale - 1/scale res[1] <- sum(k-log(y)) k <- (digamma(1/scale)+log(scale))/(scale*scale) res[2] <- sum(k/w) k <- (-trigamma(1/scale)/(scale) + (1-2*log(scale)-2*digamma(1/scale)))/(scale^3) res[3] <- sum(k/w^2) res } } else if (family=="quasi"||family=="quasipoisson"||family=="quasibinomial") { ## fam$ls <- function(y,w,n,scale) rep(0,3) ## Uses extended quasi-likelihood form... fam$ls <- function(y,w,n,scale) { nobs <- sum(w>0) c(-nobs*log(scale)/2 + sum(log(w[w>0]))/2,-nobs/(2*scale),nobs/(2*scale*scale)) } } else if (family=="inverse.gaussian") { fam$ls <- function(y,w,n,scale) { nobs <- sum(w>0) c(-sum(log(2*pi*scale*y^3))/2 + sum(log(w[w>0]))/2,-nobs/(2*scale),nobs/(2*scale*scale)) ## c(-sum(w*log(2*pi*scale*y^3))/2,-sum(w)/(2*scale),sum(w)/(2*scale*scale)) } } else stop("family not recognised") environment(fam$ls) <- environment(fam$linkfun) return(fam) } ## fix.family.ls 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 negbin <- function (theta = stop("'theta' must be specified"), link = "log") { ## modified from Venables and Ripley's MASS library to work with gam.fit3, ## and to allow a range of `theta' values to be specified ## single `theta' to specify fixed value; 2 theta values (first smaller than second) ## are limits within which to search for theta; otherwise supplied values make up ## search set. ## Note: to avoid warnings, get(".Theta")[1] is used below. Otherwise the initialization ## call to negbin can generate warnings since get(".Theta") returns a vector ## during initialization (only). linktemp <- substitute(link) if (!is.character(linktemp)) linktemp <- deparse(linktemp) if (linktemp %in% c("log", "identity", "sqrt")) stats <- make.link(linktemp) else if (is.character(link)) { stats <- make.link(link) linktemp <- link } else { if (inherits(link, "link-glm")) { stats <- link if (!is.null(stats$name)) linktemp <- stats$name } else stop(gettextf("%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"",linktemp)) } env <- new.env(parent = .GlobalEnv) assign(".Theta", theta, envir = env) variance <- function(mu) mu + mu^2/get(".Theta")[1] ## dvaraince/dmu needed as well dvar <- function(mu) 1 + 2*mu/get(".Theta")[1] ## d2variance/dmu... d2var <- function(mu) rep(2/get(".Theta")[1],length(mu)) d3var <- function(mu) rep(0,length(mu)) getTheta <- function() get(".Theta") validmu <- function(mu) all(mu > 0) dev.resids <- function(y, mu, wt) { Theta <- get(".Theta")[1] 2 * wt * (y * log(pmax(1, y)/mu) - (y + Theta) * log((y + Theta)/(mu + Theta))) } aic <- function(y, n, mu, wt, dev) { Theta <- get(".Theta")[1] term <- (y + Theta) * log(mu + Theta) - y * log(mu) + lgamma(y + 1) - Theta * log(Theta) + lgamma(Theta) - lgamma(Theta + y) 2 * sum(term * wt) } ls <- function(y,w,n,scale) { Theta <- get(".Theta")[1] ylogy <- y;ind <- y>0;ylogy[ind] <- y[ind]*log(y[ind]) term <- (y + Theta) * log(y + Theta) - ylogy + lgamma(y + 1) - Theta * log(Theta) + lgamma(Theta) - lgamma(Theta + y) c(-sum(term*w),0,0) } initialize <- expression({ if (any(y < 0)) stop("negative values not allowed for the negative binomial family") n <- rep(1, nobs) mustart <- y + (y == 0)/6 }) rd <- function(mu,wt,scale) { Theta <- get(".Theta")[1] rnbinom(mu,size=Theta,mu=mu) } qf <- function(p,mu,wt,scale) { Theta <- get(".Theta")[1] qnbinom(p,size=Theta,mu=mu) } environment(qf) <- environment(rd) <- environment(dvar) <- environment(d2var) <- environment(d3var) <-environment(variance) <- environment(validmu) <- environment(ls) <- environment(dev.resids) <- environment(aic) <- environment(getTheta) <- env famname <- paste("Negative Binomial(", format(round(theta,3)), ")", sep = "") structure(list(family = famname, link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, variance = variance,dvar=dvar,d2var=d2var,d3var=d3var, dev.resids = dev.resids, aic = aic, mu.eta = stats$mu.eta, initialize = initialize,ls=ls, validmu = validmu, valideta = stats$valideta,getTheta = getTheta,qf=qf,rd=rd,canonical=""), class = "family") } ## negbin totalPenalty <- function(S,H,off,theta,p) { if (is.null(H)) St <- matrix(0,p,p) else { St <- H; if (ncol(H)!=p||nrow(H)!=p) stop("H has wrong dimension") } theta <- exp(theta) m <- length(theta) if (m>0) for (i in 1:m) { k0 <- off[i] k1 <- k0 + nrow(S[[i]]) - 1 St[k0:k1,k0:k1] <- St[k0:k1,k0:k1] + S[[i]] * theta[i] } St } ## totalPenalty totalPenaltySpace <- function(S,H,off,p) { ## function to obtain (orthogonal) basis for the null space and ## range space of the penalty, and obtain actual null space dimension ## components are roughly rescaled to avoid any dominating Hscale <- sqrt(sum(H*H)); if (Hscale==0) H <- NULL ## H was all zeroes anyway! if (is.null(H)) St <- matrix(0,p,p) else { St <- H/sqrt(sum(H*H)); if (ncol(H)!=p||nrow(H)!=p) stop("H has wrong dimension") } m <- length(S) if (m>0) for (i in 1:m) { k0 <- off[i] k1 <- k0 + nrow(S[[i]]) - 1 St[k0:k1,k0:k1] <- St[k0:k1,k0:k1] + S[[i]]/sqrt(sum(S[[i]]*S[[i]])) } es <- eigen(St,symmetric=TRUE) ind <- es$values>max(es$values)*.Machine$double.eps^.66 Y <- es$vectors[,ind,drop=FALSE] ## range space Z <- es$vectors[,!ind,drop=FALSE] ## null space - ncol(Z) is null space dimension E <- sqrt(as.numeric(es$values[ind]))*t(Y) ## E'E = St list(Y=Y,Z=Z,E=E) } ## totalPenaltySpace mini.roots <- function(S,off,np,rank=NULL) # function to obtain square roots, B[[i]], of S[[i]]'s having as few # columns as possible. S[[i]]=B[[i]]%*%t(B[[i]]). np is the total number # of parameters. S is in packed form. rank[i] is optional supplied rank # of S[[i]], rank[i] < 1, or rank=NULL to estimate. { m<-length(S) if (m<=0) return(list()) B<-S if (is.null(rank)) rank <- rep(-1,m) for (i in 1:m) { b <- mroot(S[[i]],rank=rank[i]) B[[i]] <- matrix(0,np,ncol(b)) B[[i]][off[i]:(off[i]+nrow(b)-1),] <- b } B } ldTweedie0 <- function(y,mu=y,p=1.5,phi=1,rho=NA,theta=NA,a=1.001,b=1.999) { ## evaluates log Tweedie density for 1<=p<=2, using series summation of ## Dunn & Smyth (2005) Statistics and Computing 15:267-280. ## Original fixed p and phi version. if (!is.na(rho)&&!is.na(theta)) { ## use rho and theta and get derivs w.r.t. these if (length(rho)>1||length(theta)>1) stop("only scalar `rho' and `theta' allowed.") if (a>=b||a<=1||b>=2) stop("10) (b+a*exp(-th))/(1+exp(-th)) else (b*exp(th)+a)/(exp(th)+1) dpth1 <- if (th>0) exp(-th)*(b-a)/(1+exp(-th))^2 else exp(th)*(b-a)/(exp(th)+1)^2 dpth2 <- if (th>0) ((a-b)*exp(-th)+(b-a)*exp(-2*th))/(exp(-th)+1)^3 else ((a-b)*exp(2*th)+(b-a)*exp(th))/(exp(th)+1)^3 } else { ## still need working params for tweedious call... work.param <- FALSE if (length(p)>1||length(phi)>1) stop("only scalar `p' and `phi' allowed.") rho <- log(phi) if (p>1&&p<2) { if (p <= a) a <- (1+p)/2 if (p >= b) b <- (2+p)/2 pabp <- (p-a)/(b-p) theta <- log((p-a)/(b-p)) dthp1 <- (1+pabp)/(p-a) dthp2 <- (pabp+1)/((p-a)*(b-p)) -(pabp+1)/(p-a)^2 } } if (p<1||p>2) stop("p must be in [1,2]") ld <- cbind(y,y,y);ld <- cbind(ld,ld*NA) if (p == 2) { ## It's Gamma if (sum(y<=0)) stop("y must be strictly positive for a Gamma density") ld[,1] <- dgamma(y, shape = 1/phi,rate = 1/(phi * mu),log=TRUE) ld[,2] <- (digamma(1/phi) + log(phi) - 1 + y/mu - log(y/mu))/(phi*phi) ld[,3] <- -2*ld[,2]/phi + (1-trigamma(1/phi)/phi)/(phi^3) return(ld) } if (length(mu)==1) mu <- rep(mu,length(y)) if (p == 1) { ## It's Poisson like ## ld[,1] <- dpois(x = y/phi, lambda = mu/phi,log=TRUE) if (all.equal(y/phi,round(y/phi))!=TRUE) stop("y must be an integer multiple of phi for Tweedie(p=1)") ind <- (y!=0)|(mu!=0) ## take care to deal with y log(mu) when y=mu=0 bkt <- y*0 bkt[ind] <- (y[ind]*log(mu[ind]/phi) - mu[ind]) dig <- digamma(y/phi+1) trig <- trigamma(y/phi+1) ld[,1] <- bkt/phi - lgamma(y/phi+1) ld[,2] <- (-bkt - y + dig*y)/(phi*phi) ld[,3] <- (2*bkt + 3*y - 2*dig*y - trig *y*y/phi)/(phi^3) return(ld) } ## .. otherwise need the full series thing.... ## first deal with the zeros ind <- y==0;ld[ind,] <- 0 ind <- ind & mu>0 ## need mu condition otherwise may try to find log(0) ld[ind,1] <- -mu[ind]^(2-p)/(phi*(2-p)) ld[ind,2] <- -ld[ind,1]/phi ## dld/d phi ld[ind,3] <- -2*ld[ind,2]/phi ## d2ld/dphi2 ld[ind,4] <- -ld[ind,1] * (log(mu[ind]) - 1/(2-p)) ## dld/dp ld[ind,5] <- 2*ld[ind,4]/(2-p) + ld[ind,1]*log(mu[ind])^2 ## d2ld/dp2 ld[ind,6] <- -ld[ind,4]/phi ## d2ld/dphidp if (sum(!ind)==0) return(ld) ## now the non-zeros ind <- y==0 y <- y[!ind];mu <- mu[!ind] w <- w1 <- w2 <- y*0 oo <- .C(C_tweedious,w=as.double(w),w1=as.double(w1),w2=as.double(w2),w1p=as.double(y*0),w2p=as.double(y*0), w2pp=as.double(y*0),y=as.double(y),eps=as.double(.Machine$double.eps^2),n=as.integer(length(y)), th=as.double(theta),rho=as.double(rho),a=as.double(a),b=as.double(b)) if (!work.param) { ## transform working param derivatives to p/phi derivs... oo$w2 <- oo$w2/phi^2 - oo$w1/phi^2 oo$w1 <- oo$w1/phi oo$w2p <- oo$w2p*dthp1^2 + dthp2 * oo$w1p oo$w1p <- oo$w1p*dthp1 oo$w2pp <- oo$w2pp*dthp1/phi ## this appears to be wrong } log.mu <- log(mu) mu1p <- theta <- mu^(1-p) k.theta <- mu*theta/(2-p) ## mu^(2-p)/(2-p) theta <- theta/(1-p) ## mu^(1-p)/(1-p) l.base <- mu1p*(y/(1-p)-mu/(2-p))/phi ld[!ind,1] <- l.base - log(y) ## log density ld[!ind,2] <- -l.base/phi ## d log f / dphi ld[!ind,3] <- 2*l.base/(phi*phi) ## d2 logf / dphi2 x <- theta*y*(1/(1-p) - log.mu)/phi + k.theta*(log.mu-1/(2-p))/phi ld[!ind,4] <- x ld[!ind,5] <- theta * y * (log.mu^2 - 2*log.mu/(1-p) + 2/(1-p)^2)/phi - k.theta * (log.mu^2 - 2*log.mu/(2-p) + 2/(2-p)^2)/phi ## d2 logf / dp2 ld[!ind,6] <- - x/phi ## d2 logf / dphi dp if (work.param) { ## transform derivs to derivs wrt working ld[,3] <- ld[,3]*phi^2 + ld[,2]*phi ld[,2] <- ld[,2]*phi ld[,5] <- ld[,5]*dpth1^2 + ld[,4]*dpth2 ld[,4] <- ld[,4]*dpth1 ld[,6] <- ld[,6]*dpth1*phi } if (TRUE) { ## DEBUG disconnetion of a terms ld[!ind,1] <- ld[!ind,1] + oo$w ## log density ld[!ind,2] <- ld[!ind,2] + oo$w1 ## d log f / dphi ld[!ind,3] <- ld[!ind,3] + oo$w2 ## d2 logf / dphi2 ld[!ind,4] <- ld[!ind,4] + oo$w1p ld[!ind,5] <- ld[!ind,5] + oo$w2p ## d2 logf / dp2 ld[!ind,6] <- ld[!ind,6] + oo$w2pp ## d2 logf / dphi dp } if (FALSE) { ## DEBUG disconnetion of density terms ld[!ind,1] <- oo$w ## log density ld[!ind,2] <- oo$w1 ## d log f / dphi ld[!ind,3] <- oo$w2 ## d2 logf / dphi2 ld[!ind,4] <- oo$w1p ld[!ind,5] <- oo$w2p ## d2 logf / dp2 ld[!ind,6] <- oo$w2pp ## d2 logf / dphi dp } ld } ## ldTweedie0 ldTweedie <- function(y,mu=y,p=1.5,phi=1,rho=NA,theta=NA,a=1.001,b=1.999,all.derivs=FALSE) { ## evaluates log Tweedie density for 1<=p<=2, using series summation of ## Dunn & Smyth (2005) Statistics and Computing 15:267-280. n <- length(y) if (all(!is.na(rho))&&all(!is.na(theta))) { ## use rho and theta and get derivs w.r.t. these #if (length(rho)>1||length(theta)>1) stop("only scalar `rho' and `theta' allowed.") if (a>=b||a<=1||b>=2) stop("1 0;dpth1 <- dpth2 <-p <- rep(0,n) ethi <- exp(-th[ind]) ethni <- exp(th[!ind]) p[ind] <- (b+a*ethi)/(1+ethi) p[!ind] <- (b*ethni+a)/(ethni+1) dpth1[ind] <- ethi*(b-a)/(1+ethi)^2 dpth1[!ind] <- ethni*(b-a)/(ethni+1)^2 dpth2[ind] <-((a-b)*ethi+(b-a)*ethi^2)/(ethi+1)^3 dpth2[!ind] <- ((a-b)*ethni^2+(b-a)*ethni)/(ethni+1)^3 #p <- if (th>0) (b+a*exp(-th))/(1+exp(-th)) else (b*exp(th)+a)/(exp(th)+1) #dpth1 <- if (th>0) exp(-th)*(b-a)/(1+exp(-th))^2 else exp(th)*(b-a)/(exp(th)+1)^2 #dpth2 <- if (th>0) ((a-b)*exp(-th)+(b-a)*exp(-2*th))/(exp(-th)+1)^3 else # ((a-b)*exp(2*th)+(b-a)*exp(th))/(exp(th)+1)^3 } else { ## still need working params for tweedious call... work.param <- FALSE if (all.derivs) warning("all.derivs only available in rho, theta parameterization") #if (length(p)>1||length(phi)>1) stop("only scalar `p' and `phi' allowed.") buffer <- if (length(unique(p))==1&&length(unique(phi))==1) TRUE else FALSE rho <- log(phi) if (min(p)>=1&&max(p)<=2) { ind <- p>1&p<2 if (sum(ind)) { p.ind <- p[ind] if (min(p.ind) <= a) a <- (1+min(p.ind))/2 if (max(p.ind) >= b) b <- (2+max(p.ind))/2 pabp <- theta <- dthp1 <- dthp2 <- rep(0,n) pabp[ind] <- (p.ind-a)/(b-p.ind) theta[ind] <- log((p.ind-a)/(b-p.ind)) dthp1[ind] <- (1+pabp[ind])/(p.ind-a) dthp2[ind] <- (pabp[ind]+1)/((p.ind-a)*(b-p.ind)) -(pabp[ind]+1)/(p.ind-a)^2 } } } if (min(p)<1||max(p)>2) stop("p must be in [1,2]") ld <- cbind(y,y,y);ld <- cbind(ld,ld*NA) if (work.param&&all.derivs) ld <- cbind(ld,ld[,1:3]*0,y*0) if (length(p)!=n) p <- array(p,dim=n); if (length(phi)!=n) phi <- array(phi,dim=n) if (length(mu)!=n) mu <- array(mu,dim=n) ind <- p == 2 if (sum(ind)) { ## It's Gamma if (sum(y[ind]<=0)) stop("y must be strictly positive for a Gamma density") ld[ind,1] <- dgamma(y[ind], shape = 1/phi[ind],rate = 1/(phi[ind] * mu[ind]),log=TRUE) ld[ind,2] <- (digamma(1/phi[ind]) + log(phi[ind]) - 1 + y[ind]/mu[ind] - log(y[ind]/mu[ind]))/(phi[ind]*phi[ind]) ld[ind,3] <- -2*ld[ind,2]/phi[ind] + (1-trigamma(1/phi[ind])/phi[ind])/(phi[ind]^3) #return(ld) } ind <- p == 1 if (sum(ind)) { ## It's Poisson like ## ld[,1] <- dpois(x = y/phi, lambda = mu/phi,log=TRUE) if (all.equal(y[ind]/phi[ind],round(y[ind]/phi[ind]))!=TRUE) stop("y must be an integer multiple of phi for Tweedie(p=1)") indi <- (y[ind]!=0)|(mu[ind]!=0) ## take care to deal with y log(mu) when y=mu=0 bkt <- y[ind]*0 bkt[indi] <- ((y[ind])[indi]*log((mu[ind]/phi[ind])[indi]) - (mu[ind])[indi]) dig <- digamma(y[ind]/phi[ind]+1) trig <- trigamma(y[ind]/phi[ind]+1) ld[ind,1] <- bkt/phi[ind] - lgamma(y[ind]/phi[ind]+1) ld[ind,2] <- (-bkt - y[ind] + dig[ind]*y[ind])/(phi[ind]^2) ld[ind,3] <- (2*bkt + 3*y[ind] - 2*dig*y[ind] - trig * y[ind]^2/phi[ind])/(phi[ind]^3) #return(ld) } ## .. otherwise need the full series thing.... ## first deal with the zeros ind <- y==0&p>1&p<2;ld[ind,] <- 0 ind <- ind & mu>0 ## need mu condition otherwise may try to find log(0) if (sum(ind)) { mu.ind <- mu[ind];p.ind <- p[ind];phii <- phi[ind] ld[ind,1] <- -mu.ind^(2-p.ind)/(phii*(2-p.ind)) ld[ind,2] <- -ld[ind,1]/phii ## dld/d phi ld[ind,3] <- -2*ld[ind,2]/phii ## d2ld/dphi2 ld[ind,4] <- -ld[ind,1] * (log(mu.ind) - 1/(2-p.ind)) ## dld/dp ld[ind,5] <- 2*ld[ind,4]/(2-p.ind) + ld[ind,1]*log(mu.ind)^2 ## d2ld/dp2 ld[ind,6] <- -ld[ind,4]/phii ## d2ld/dphidp if (work.param&&all.derivs) { mup <- mu.ind^p.ind ld[ind,7] <- -mu.ind/(mup*phii) ld[ind,8] <- -(1-p.ind)/(mup*phii) ld[ind,9] <- log(mu.ind)*mu.ind/(mup*phii) ld[ind,10] <- -ld[ind,7]/phii } } if (sum(!ind)==0) return(ld) ## now the non-zeros ind <- which(y>0&p>1&p<2) y <- y[ind];mu <- mu[ind];p<- p[ind] w <- w1 <- w2 <- y*0 if (length(ind)>0) { if (buffer) { ## use code that can buffer expensive lgamma,digamma and trigamma evaluations... oo <- .C(C_tweedious,w=as.double(w),w1=as.double(w1),w2=as.double(w2),w1p=as.double(y*0),w2p=as.double(y*0), w2pp=as.double(y*0),y=as.double(y),eps=as.double(.Machine$double.eps^2),n=as.integer(length(y)), th=as.double(theta[1]),rho=as.double(rho[1]),a=as.double(a),b=as.double(b)) } else { ## use code that is not able to buffer as p and phi variable... if (length(theta)!=n) theta <- array(theta,dim=n) if (length(rho)!=n) rho <- array(rho,dim=n) oo <- .C(C_tweedious2,w=as.double(w),w1=as.double(w1),w2=as.double(w2),w1p=as.double(y*0),w2p=as.double(y*0), w2pp=as.double(y*0),y=as.double(y),eps=as.double(.Machine$double.eps^2),n=as.integer(length(y)), th=as.double(theta[ind]),rho=as.double(rho[ind]),a=as.double(a),b=as.double(b)) } if (oo$eps < -.5) { if (oo$eps < -1.5) { ## failure of series in C code oo$w2 <- oo$w1 <- oo$w2p <- oo$w1p <- oo$w2pp <- rep(NA,length(y)) } else warning("Tweedie density may be unreliable - series not fully converged") } phii <- phi[ind] if (!work.param) { ## transform working param derivatives to p/phi derivs... if (length(dthp1)!=n) dthp1 <- array(dthp1,dim=n) if (length(dthp2)!=n) dthp2 <- array(dthp2,dim=n) dthp1i <- dthp1[ind] oo$w2 <- oo$w2/phii^2 - oo$w1/phii^2 oo$w1 <- oo$w1/phii oo$w2p <- oo$w2p*dthp1i^2 + dthp2[ind] * oo$w1p oo$w1p <- oo$w1p*dthp1i oo$w2pp <- oo$w2pp*dthp1i/phii } log.mu <- log(mu) onep <- 1-p twop <- 2-p mu1p <- theta <- mu^onep k.theta <- mu*theta/twop ## mu^(2-p)/(2-p) theta <- theta/onep ## mu^(1-p)/(1-p) a1 <- (y/onep-mu/twop) l.base <- mu1p*a1/phii ld[ind,1] <- l.base - log(y) ## log density ld[ind,2] <- -l.base/phii ## d log f / dphi ld[ind,3] <- 2*l.base/(phii^2) ## d2 logf / dphi2 x <- theta*y*(1/onep - log.mu)/phii + k.theta*(log.mu-1/twop)/phii ld[ind,4] <- x ld[ind,5] <- theta * y * (log.mu^2 - 2*log.mu/onep + 2/onep^2)/phii - k.theta * (log.mu^2 - 2*log.mu/twop + 2/twop^2)/phii ## d2 logf / dp2 ld[ind,6] <- - x/phii ## d2 logf / dphi dp } ## length(ind)>0 if (work.param) { ## transform derivs to derivs wrt working ld[,3] <- ld[,3]*phi^2 + ld[,2]*phi ld[,2] <- ld[,2]*phi ld[,5] <- ld[,5]*dpth1^2 + ld[,4]*dpth2 ld[,4] <- ld[,4]*dpth1 ld[,6] <- ld[,6]*dpth1*phi colnames(ld)[1:6] <- c("l","rho","rho.2","th","th.2","th.rho") } if (work.param&&all.derivs&&length(ind)>0) { #ld <- cbind(ld,ld[,1:4]*0) a2 <- mu1p/(mu*phii) ## 1/(mu^p*phii) ld[ind,7] <- a2*(onep*a1-mu/twop) ## deriv w.r.t mu ld[ind,8] <- -a2*(onep*p*a1/mu+2*onep/twop) ## 2nd deriv w.r.t. mu ld[ind,9] <- a2*(-log.mu*onep*a1-a1 + onep*(y/onep^2-mu/twop^2)+mu*log.mu/twop-mu/twop^2) ## mu p ld[ind,10] <- a2*(mu/(phii*twop) - onep*a1/phii) ## mu phi ## transform to working... ld[,10] <- ld[,10]*phi ld[,9] <- ld[,9]*dpth1 colnames(ld) <- c("l","rho","rho.2","th","th.2","th.rho","mu","mu.2","mu.theta","mu.rho") } if (length(ind)>0) { ld[ind,1] <- ld[ind,1] + oo$w ## log density ld[ind,2] <- ld[ind,2] + oo$w1 ## d log f / dphi ld[ind,3] <- ld[ind,3] + oo$w2 ## d2 logf / dphi2 ld[ind,4] <- ld[ind,4] + oo$w1p ld[ind,5] <- ld[ind,5] + oo$w2p ## d2 logf / dp2 ld[ind,6] <- ld[ind,6] + oo$w2pp ## d2 logf / dphi dp } if (FALSE) { ## DEBUG disconnection of density terms ld[ind,1] <- oo$w ## log density ld[ind,2] <- oo$w1 ## d log f / dphi ld[ind,3] <- oo$w2 ## d2 logf / dphi2 ld[ind,4] <- oo$w1p ld[ind,5] <- oo$w2p ## d2 logf / dp2 ld[ind,6] <- oo$w2pp ## d2 logf / dphi dp } ld } ## ldTweedie Tweedie <- function(p=1,link=power(0)) { ## a restricted Tweedie family if (p<=1||p>2) stop("Only 1= 0) dev.resids <- function(y, mu, wt) { y1 <- y + (y == 0) if (p == 1) theta <- log(y1/mu) else theta <- (y1^(1 - p) - mu^(1 - p))/(1 - p) if (p == 2) kappa <- log(y1/mu) else kappa <- (y^(2 - p) - mu^(2 - p))/(2 - p) pmax(2 * wt * (y * theta - kappa),0) } initialize <- expression({ n <- rep(1, nobs) mustart <- y + 0.1 * (y == 0) }) ls <- function(y,w,n,scale) { power <- p colSums(w*ldTweedie(y,y,p=power,phi=scale)) } aic <- function(y, n, mu, wt, dev) { power <- p scale <- dev/sum(wt) -2*sum(ldTweedie(y,mu,p=power,phi=scale)[,1]*wt) + 2 } if (p==2) { rd <- function(mu,wt,scale) { rgamma(mu,shape=1/scale,scale=mu*scale) } } else { rd <- function(mu,wt,scale) { rTweedie(mu,p=p,phi=scale) } } structure(list(family = paste("Tweedie(",p,")",sep=""), variance = variance, dev.resids = dev.resids,aic = aic, link = linktemp, linkfun = stats$linkfun, linkinv = stats$linkinv, mu.eta = stats$mu.eta, initialize = initialize, validmu = validmu, valideta = stats$valideta,dvar=dvar,d2var=d2var,d3var=d3var,ls=ls,rd=rd,canonical="none"), class = "family") } ## Tweedie rTweedie <- function(mu,p=1.5,phi=1) { ## generate Tweedie random variables, with 1=2) stop("p must be in (1,2)") if (sum(mu<0)) stop("mean, mu, must be non negative") if (phi<=0) stop("scale parameter must be positive") lambda <- mu^(2-p)/((2-p)*phi) shape <- (2-p)/(p-1) scale <- phi*(p-1)*mu^(p-1) n.sim <- length(mu) ## how many Gamma r.v.s to sum up to get Tweedie ## 0 => none, and a zero value N <- rpois(length(lambda),lambda) ## following is a vector of N[i] copies of each gamma.scale[i] ## concatonated one after the other gs <- rep(scale,N) ## simulate gamma deviates to sum to get tweedie deviates y <- rgamma(gs*0+1,shape=shape,scale=gs) ## create summation index... lab <- rep(1:length(N),N) ## sum up each gamma sharing a label. 0 deviate if label does not occur o <- .C(C_psum,y=as.double(rep(0,n.sim)),as.double(y),as.integer(lab),as.integer(length(lab))) o$y } ## rTweedie mgcv/R/bam.r0000644000176200001440000034032413561302620012335 0ustar liggesusers## routines for very large dataset generalized additive modelling. ## (c) Simon N. Wood 2009-2019 ls.size <- function(x) { ## If `x' is a list, return the size of its elements, in bytes, in a named array ## otherwise return the size of the object if (is.list(x)==FALSE) return(object.size(x)) xn <- names(x) n <- length(x) sz <- rep(-1,n) for (i in 1:n) sz[i] <- object.size(x[[i]]) names(sz) <- xn sz } ## ls.size rwMatrix <- function(stop,row,weight,X,trans=FALSE) { ## Routine to recombine the rows of a matrix X according to info in ## stop, row and weight. Consider the ith row of the output matrix ## ind <- 1:stop[i] if i==1 and ind <- (stop[i-1]+1):stop[i] ## otherwise. The ith output row is then X[row[ind],]*weight[ind] if (is.matrix(X)) { n <- nrow(X);p<-ncol(X);ok <- TRUE} else { n<- length(X);p<-1;ok<-FALSE} stop <- stop - 1;row <- row - 1 ## R indices -> 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 chol2qr <- function(XX,Xy,nt=1) { ## takes X'X and X'y and returns R and f ## equivalent to qr update. op <- options(warn = -1) ## otherwise warns if +ve semidef R <- if (nt) pchol(XX,nt=nt) else chol(XX,pivot=TRUE) options(op) p <- length(Xy) ipiv <- piv <- attr(R,"pivot");ipiv[piv] <- 1:p rank <- attr(R,"rank");ind <- 1:rank if (rank1 and use.chol=FALSE then parallel QR is used { p <- ncol(Xn) y.norm2 <- y.norm2+sum(yn*yn) if (use.chol) { if (is.null(R)) { R <- crossprod(Xn) fn <- as.numeric(t(Xn)%*%yn) } else { R <- R + crossprod(Xn) fn <- f + as.numeric(t(Xn)%*%yn) } return(list(R=R,f=fn,y.norm2=y.norm2)) } else { ## QR update if (!is.null(R)) { Xn <- rbind(R,Xn) yn <- c(f,yn) } qrx <- if (nt==1) qr(Xn,tol=0,LAPACK=TRUE) else pqr2(Xn,nt) fn <- qr.qty(qrx,yn)[1:p] rp <- qrx$pivot;rp[rp] <- 1:p # reverse pivot return(list(R = qr.R(qrx)[,rp],f=fn,y.norm2=y.norm2)) } } ## qr.update qr.up <- function(arg) { ## routine for parallel computation of the QR factorization of ## a large gam model matrix, suitable for calling with parLapply. wt <- rep(0,0) dev <- 0 eta <- arg$eta efam <- !is.null(arg$family) ## extended family? for (b in 1:arg$n.block) { ind <- arg$start[b]:arg$stop[b] X <- predict(arg$G,newdata=arg$mf[ind,],type="lpmatrix",newdata.guaranteed=TRUE,block.size=length(ind)) rownames(X) <- NULL if (is.null(arg$coef)) eta1 <- arg$eta[ind] else eta[ind] <- eta1 <- drop(X%*%arg$coef) + arg$offset[ind] mu <- arg$linkinv(eta1) y <- arg$G$y[ind] ## arg$G$model[[arg$response]] weights <- arg$G$w[ind] if (efam) { ## extended family case dd <- dDeta(y,mu,weights,theta=arg$theta,arg$family,0) ## note: no handling of infinities and wz case yet w <- dd$EDeta2 * .5 #w <- w z <- (eta1-arg$offset[ind]) - dd$Deta.EDeta2 good <- is.finite(z)&is.finite(w) } else { ## regular exp fam case mu.eta.val <- arg$mu.eta(eta1) good <- (weights > 0) & (mu.eta.val != 0) z <- (eta1 - arg$offset[ind]) + (y - mu)/mu.eta.val w <- (weights * mu.eta.val^2)/arg$variance(mu) } w[!good] <- 0 ## drop if !good #z[!good] <- 0 ## irrelevant dev <- dev + if (efam) sum(arg$family$dev.resids(y,mu,weights,arg$theta)) else sum(arg$dev.resids(y,mu,weights)) wt <- c(wt,w) z <- z[good];w <- w[good] w <- sqrt(w) ## note assumption that nt=1 in following qr.update - i.e. each cluster node is strictly serial if (b == 1) qrx <- qr.update(w*X[good,,drop=FALSE],w*z,use.chol=arg$use.chol) else qrx <- qr.update(w*X[good,,drop=FALSE],w*z,qrx$R,qrx$f,qrx$y.norm2,use.chol=arg$use.chol) rm(X);if(arg$gc.level>1) gc() ## X can be large: remove and reclaim } qrx$dev <- dev;qrx$wt <- wt;qrx$eta <- eta if (arg$gc.level>1) { rm(arg,ind,mu,y,weights,mu.eta.val,good,z,w,wt,w);gc()} qrx } ## qr.up compress.df <- function(dat,m=NULL) { ## Takes dataframe in dat and compresses it by rounding and duplicate ## removal. For metric variables we first find the unique cases. ## If there are <= m of these then these are employed, otherwise ## rounding is used. Factors are always reduced to the number of ## levels present in the data. Idea is that this function is called ## with columns of dataframes corresponding to single smooths or marginals. ## Note that this uses random sampling, so random seed manipulation ## is typically used before calling to force exact repeatability. d <- ncol(dat) ## number of variables to deal with n <- nrow(dat) ## number of data/cases if (is.null(m)) m <- if (d==1) 1000 else if (d==2) 100 else 25 else if (d>1) m <- round(m^{1/d}) + 1 mf <- mm <- 1 ## total grid points for factor and metric for (i in 1:d) if (is.factor(dat[,i])) { mf <- mf * length(unique(as.vector(dat[,i]))) } else { mm <- mm * m } if (is.matrix(dat[[1]])) { ## must replace matrix terms with vec(dat[[i]]) dat0 <- data.frame(as.vector(dat[[1]])) if (d>1) for (i in 2:d) dat0[[i]] <- as.vector(dat[[i]]) names(dat0) <- names(dat) dat <- dat0;rm(dat0) } xu <- uniquecombs(dat,TRUE) if (nrow(xu)>mm*mf) { ## too many unique rows to use only unique for (i in 1:d) if (!is.factor(dat[,i])) { ## round the metric variables xl <- range(dat[,i]) xu <- seq(xl[1],xl[2],length=m) dx <- xu[2]-xu[1] kx <- round((dat[,i]-xl[1])/dx)+1 dat[,i] <- xu[kx] ## rounding the metric variables } xu <- uniquecombs(dat,TRUE) } k <- attr(xu,"index") ## shuffle rows in order to avoid induced dependencies between discretized ## covariates (which can mess up gam.side)... ## Any RNG setting should be done in routine calling this one!! ii <- sample(1:nrow(xu),nrow(xu),replace=FALSE) ## shuffling index xu[ii,] <- xu ## shuffle rows of xu k <- ii[k] ## correct k index accordingly ## ... finished shuffle ## if arguments were matrices, then return matrix index if (length(k)>n) k <- matrix(k,nrow=n) k -> attr(xu,"index") xu } ## compress.df check.term <- function(term,rec) { ## utility function for discrete.mf. Checks whether variables in "term" ## have already been discretized, and if so whether this discretization ## can be re-used for the current "term". Stops if term already discretized ## but we can't re-use discretization. Otherwise returns index of k index ## or 0 if the term is not in the existing list. ii <- which(rec$vnames%in%term) if (length(ii)) { ## at least one variable already discretized if (length(term)==rec$d[min(ii)]) { ## dimensions match previous discretization if (sum(!(term%in%rec$vnames[ii]))) stop("bam can not discretize with this nesting structure") else return(rec$ki[min(ii)]) ## all names match previous - return index of previous } else stop("bam can not discretize with this nesting structure") } else return(0) ## no match } ## check.term discrete.mf <- function(gp,mf,names.pmf,m=NULL,full=TRUE) { ## discretize the covariates for the terms specified in smooth.spec ## id not allowed. names.pmf gives the names of the parametric part ## of mf, and is used to create a model frame for just the ## parametric terms --- mini.mf is applied to this. ## if full is FALSE then parametric and response terms are ignored ## and what is returned is a list where columns can be of ## different lengths. ## On exit... ## * mf is a model frame containing the unique discretized covariate ## values, in randomized order, padded to all be same length ## * nr records the number of unique discretized covariate values ## i.e. the number of rows before the padding starts ## * k.start contains the starting column in index vector k, for ## each variable. The final element is the column beyond the last one. ## * k is the index matrix. The ith record of the 1st column of the ## jth variable is in row k[i,k.start[j]] of the corresponding ## column of mf. ## ... there is an element of nr and k.start for each variable of ## each smooth, but variables are only discretized and stored in mf ## once. If there are no matrix variables then k.start = 1:(ncol(k)+1) ## some sub sampling here... want to set and restore RNG state used for this ## to ensure strict repeatability. 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(8547) ## keep different to tps constructor! mf0 <- list() nk <- 0 ## count number of index vectors to avoid too much use of cbind nlp <- if (is.null(gp$nlp)) 1 else sum(unlist(lapply(gp,inherits,"split.gam.formula"))) for (lp in 1:nlp) { ## loop over linear predictors smooth.spec <- if (is.null(gp$nlp)) gp$smooth.spec else gp[[lp]]$smooth.spec if (length(smooth.spec)>0) for (i in 1:length(smooth.spec)) nk <- nk + as.numeric(smooth.spec[[i]]$by!="NA") + if (inherits(smooth.spec[[i]],"tensor.smooth.spec")) length(smooth.spec[[i]]$margin) else 1 } k <- matrix(0,nrow(mf),nk) ## each column is an index vector k.start <- 1:(nk+1) ## record last column for each term ik <- 0 ## index counter nr <- rep(0,nk) ## number of rows for term ## structure to record terms already processed... rec <- list(vnames = rep("",0), ## variable names ki = rep(0,0), ## index of original index vector var relates to d = rep(0,0)) ## dimension of terms involving this var ## loop through the terms discretizing the covariates... for (lp in 1:nlp) { ## loop over linear predictors smooth.spec <- if (is.null(gp$nlp)) gp$smooth.spec else gp[[lp]]$smooth.spec if (length(smooth.spec)>0) for (i in 1:length(smooth.spec)) { nmarg <- if (inherits(smooth.spec[[i]],"tensor.smooth.spec")) length(smooth.spec[[i]]$margin) else 1 maxj <- if (smooth.spec[[i]]$by=="NA") nmarg else nmarg + 1 mi <- if (is.null(m)||length(m)==1) m else m[i] j <- 0 for (jj in 1:maxj) { ## loop through marginals if (jj==1&&maxj!=nmarg) termi <- smooth.spec[[i]]$by else { j <- j + 1 termi <- if (inherits(smooth.spec[[i]],"tensor.smooth.spec")) smooth.spec[[i]]$margin[[j]]$term else smooth.spec[[i]]$term } ik.prev <- check.term(termi,rec) ## term already discretized? ik <- ik + 1 ## increment index counter if (ik.prev==0) { ## new discretization required mfd <- compress.df(mf[termi],m=mi) ki <- attr(mfd,"index") if (is.matrix(ki)) { ind <- (ik+1):length(k.start) k.start[ind] <- k.start[ind] + ncol(ki)-1 ## adjust start indices k <- cbind(k,matrix(0,nrow(k),ncol(ki)-1)) ## extend index matrix ind <- k.start[ik]:(k.start[ik+1]-1) k[,ind] <- ki } else { k[,k.start[ik]] <- ki } nr[ik] <- nrow(mfd) mf0 <- c(mf0,mfd) ## record variable discretization info... d <- length(termi) rec$vnames <- c(rec$vnames,termi) rec$ki <- c(rec$ki,rep(ik,d)) rec$d <- c(rec$d,rep(d,d)) } else { ## re-use an earlier discretization... ind.prev <- k.start[ik.prev]:(k.start[ik.prev+1]-1) ind <- (ik+1):length(k.start) k.start[ind] <- k.start[ind] + length(ind.prev)-1 if (length(ind.prev)>1) k <- cbind(k,matrix(0,nrow(k),length(ind.prev)-1)) ## extend index matrix ind <- k.start[ik]:(k.start[ik+1]-1) k[,ind] <- k[,ind.prev] nr[ik] <- nr[ik.prev] } } ## end marginal jj loop } ## term loop (i) } ## linear predictor, lp, loop ## obtain parametric terms and.. ## pad mf0 so that all rows are the same length ## padding is necessary if gam.setup is to be used for setup if (full) { maxr <- max(nr) ## If NA's caused rows to be dropped in mf, then they should ## also be dropped in pmf, otherwise we can end up with factors ## with more levels than unique observations, for example. ## The next couple of lines achieve this. ## find indices of terms in mf but not pmf... di <- sort(which(!names(mf) %in% names.pmf),decreasing=TRUE) ## create copy of mf with only pmf variables... mfp <- mf; for (i in di) mfp[[i]] <- NULL pmf0 <- mini.mf(mfp,maxr) ## deal with parametric components if (nrow(pmf0)>maxr) maxr <- nrow(pmf0) mf0 <- c(mf0,pmf0) ## add parametric terms to end of mf0 for (i in 1:length(mf0)) { me <- length(mf0[[i]]) if (me < maxr) mf0[[i]][(me+1):maxr] <- sample(mf0[[i]],maxr-me,replace=TRUE) } ## add response so that gam.setup can do its thing... mf0[[gp$response]] <- sample(mf[[gp$response]],maxr,replace=TRUE) ## mf0 is the discretized model frame (actually a list), padded to have equal length rows ## k is the index vector for each sub-matrix, only the first nr rows of which are ## to be retained... Use of check.names=FALSE ensures, e.g. 'offset(x)' not changed... ## now copy back into mf so terms unchanged mf <- mf[sample(1:nrow(mf),maxr,replace=TRUE),] for (na in names(mf0)) mf[[na]] <- mf0[[na]] } else mf <- mf0 ## reset RNG to old state... RNGkind(kind[1], kind[2]) assign(".Random.seed", seed, envir = .GlobalEnv) ## finally one more pass through, expanding k, k.start and nr to deal with replication that ## will occur with factor by variables... #ik <- ncol(k)+1 ## starting index col for this term in k.start - wrong with matrix predictors ik <- length(k.start) ## starting index col for this term in k.start for (lp in 1:nlp) { ## loop over linear predictors smooth.spec <- if (is.null(gp$nlp)) gp$smooth.spec else gp[[lp]]$smooth.spec if (length(smooth.spec)>0) for (i in length(smooth.spec):1) { ## work down through terms so insertion painless if (inherits(smooth.spec[[i]],"tensor.smooth.spec")) nd <- length(smooth.spec[[i]]$margin) else nd <- 1 ## number of indices ik <- ik - nd ## starting index if no by if (smooth.spec[[i]]$by!="NA") { ik <- ik - 1 ## first index nd <- nd + 1 ## number of indices byvar <- mf[[smooth.spec[[i]]$by]] if (is.factor(byvar)) { ## then need to expand nr and index matrix nex <- length(levels(byvar)) ## number of copies of term indices if (is.ordered(byvar)) nex <- nex - 1 ## first level dropped if (nex>0) { ## insert index copies ii0 <- if (ik>1) 1:(ik-1) else rep(0,0) ## earlier ii1 <- if (ik+nd-1 < length(nr)) (ik+nd):length(nr) else rep(0,0) ## later ii <- ik:(ik+nd-1) ## cols for this term ## indices for columns of k... kk0 <- if (ik>1) 1:(k.start[ik]-1) else rep(0,0) ## earlier kk1 <- if (ik+nd-1 < length(nr)) k.start[ik+nd]:ncol(k) else rep(0,0) ## later kk <- k.start[ik]:(k.start[ik+nd]-1) ## cols for this term k <- cbind(k[,kk0,drop=FALSE],k[,rep(kk,nex),drop=FALSE],k[,kk1,drop=FALSE]) nr <- c(nr[ii0],rep(nr[ii],nex),nr[ii1]) ## expand k.start... nkk <- length(kk) ## number of k columns in term to be repeated k.start <- c(k.start[ii0],rep(k.start[ii],nex)+rep(0:(nex-1),each=nkk)*nkk, (nex-1)*nkk+c(k.start[ii1],k.start[length(k.start)])) } } ## factor by } ## existing by } ## smooth.spec loop } ## lp loop list(mf=mf,k=k,nr=nr,k.start=k.start) } ## discrete.mf mini.mf <-function(mf,chunk.size) { ## takes a model frame and produces a representative subset of it, suitable for ## basis setup. ## first count the minimum number of rows required for representiveness mn <- 0 for (j in 1:length(mf)) mn <- mn + if (is.factor(mf[[j]])) length(levels(mf[[j]])) else 2 if (chunk.size < mn) chunk.size <- mn n <- nrow(mf) if (n <= chunk.size) return(mf) 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(66) ## randomly sample from original frame... ind <- sample(1:n,chunk.size) mf0 <- mf[ind,,drop=FALSE] ## ... now need to ensure certain sorts of representativeness ## work through elements collecting the rows containing ## max and min for each variable, and a random row for each ## factor level.... ind <- sample(1:n,n,replace=FALSE) ## randomized index for stratified sampling w.r.t. factor levels fun <- function(X,fac,ind) ind[fac[ind]==X][1] ## stratified sampler k <- 0 for (j in 1:length(mf)) if (is.numeric(mf0[[j]])) { if (is.matrix(mf0[[j]])) { ## find row containing minimum j.min <- min((1:n)[as.logical(rowSums(mf[[j]]==min(mf[[j]])))]) j.max <- min((1:n)[as.logical(rowSums(mf[[j]]==max(mf[[j]])))]) } else { ## vector j.min <- min(which(mf[[j]]==min(mf[[j]]))) j.max <- min(which(mf[[j]]==max(mf[[j]]))) } k <- k + 1; mf0[k,] <- mf[j.min,] k <- k + 1; mf0[k,] <- mf[j.max,] } else if (is.factor(mf[[j]])) { ## factor variable... ## randomly sample one row from each factor level... find <- apply(X=as.matrix(levels(mf[[j]])),MARGIN=1,FUN=fun,fac=mf[[j]],ind=ind) find <- find[is.finite(find)] ## in case drop.unused.levels==FALSE, so that there ar levels without rows nf <- length(find) mf0[(k+1):(k+nf),] <- mf[find,] k <- k + nf } RNGkind(kind[1], kind[2]) assign(".Random.seed", seed, envir = .GlobalEnv) mf0 } ## mini.mf bgam.fitd <- function (G, mf, gp ,scale , coef=NULL,etastart = NULL, mustart = NULL, offset = rep(0, nobs),rho=0, control = gam.control(), intercept = TRUE, gc.level=0,nobs.extra=0,npt=c(1,1),gamma=1) { ## This is a version of bgam.fit designed for use with discretized covariates. ## Difference to bgam.fit is that XWX, XWy and Xbeta are computed in C ## code using compressed versions of X. Parallelization of XWX formation ## is performed at the C level using openMP. ## Alternative fitting iteration using Cholesky only, including for REML. ## Basic idea is to take only one Newton step for parameters per iteration ## and to control the step length to ensure that at the end of the step we ## are not going uphill w.r.t. the REML criterion... #y <- mf[[gp$response]] y <- G$y weights <- G$w conv <- FALSE nobs <- nrow(mf) offset <- G$offset if (inherits(G$family,"extended.family")) { ## preinitialize extended family efam <- TRUE pini <- if (is.null(G$family$preinitialize)) NULL else G$family$preinitialize(y,G$family) if (!is.null(pini$Theta)) G$family$putTheta(pini$Theta) if (!is.null(pini$y)) y <- pini$y if (is.null(G$family$scale)) scale <- 1 else scale <- if (G$family$scale<0) scale else G$family$scale scale1 <- scale if (scale < 0) scale <- var(y) *.1 ## initial guess } else efam <- FALSE if (rho!=0) { ## AR1 error model ld <- 1/sqrt(1-rho^2) ## leading diagonal of root inverse correlation sd <- -rho*ld ## sub diagonal N <- nobs ## 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(mf$"(AR.start)")) { ## need to correct the start of new AR sections... ii <- which(mf$"(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 } } } else {## AR setup complete ar.row <- ar.weight <- ar.stop <- -1 ## signal no re-weighting } family <- G$family additive <- if (family$family=="gaussian"&&family$link=="identity") TRUE else FALSE linkinv <- family$linkinv;#dev.resids <- family$dev.resids if (!efam) { variance <- family$variance mu.eta <- family$mu.eta if (!is.function(variance) || !is.function(linkinv)) stop("'family' argument seems not to be a valid family object") } 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 } if (is.matrix(y)&&ncol(y)>1) stop("This family should not have a matrix response") eta <- if (!is.null(etastart)) etastart else family$linkfun(mustart) mu <- linkinv(eta) if (!(validmu(mu) && valideta(eta))) stop("cannot find valid starting values: please specify some") dev <- sum(family$dev.resids(y, mu, weights))*2 ## just to avoid converging at iter 1 conv <- FALSE G$coefficients <- rep(0,ncol(G$X)) class(G) <- "gam" ## need to reset response and weights to post initialization values ## in particular to deal with binomial properly... G$y <- y G$w <- weights Sl <- Sl.setup(G) ## setup block diagonal penalty object rank <- 0 if (length(Sl)>0) for (b in 1:length(Sl)) rank <- rank + Sl[[b]]$rank Mp <- ncol(G$X) - rank ## null space dimension Nstep <- 0 if (efam) theta <- family$getTheta() for (iter in 1L:control$maxit) { ## main fitting loop devold <- dev dev <- 0 if (iter==1||!additive) { qrx <- list() if (iter>1) { ## form eta = X%*%beta eta <- Xbd(G$Xd,coef,G$kd,G$ks,G$ts,G$dt,G$v,G$qc,G$drop) + offset lsp.full <- G$lsp0 if (n.sp>0) lsp.full <- lsp.full + if (is.null(G$L)) lsp[1:n.sp] else G$L %*% lsp[1:n.sp] #Sb <- Sl.Sb(Sl,lsp.full,prop$beta) ## store S beta to allow rapid step halving rSb <- Sl.rSb(Sl,lsp.full,prop$beta) ## store S beta to allow rapid step halving if (iter>2) { #Sb0 <- Sl.Sb(Sl,lsp.full,b0) #bSb0 <- sum(b0*Sb0) ## penalty at start of beta step rSb0 <- Sl.rSb(Sl,lsp.full,b0) bSb0 <- sum(rSb0^2) ## get deviance at step start, with current theta if efam dev0 <- if (efam) sum(family$dev.resids(G$y,mu0,G$w,theta)) else sum(family$dev.resids(G$y,mu0,G$w)) } } kk <- 1 repeat { mu <- linkinv(eta) dev <- if (efam) sum(family$dev.resids(G$y,mu,G$w,theta)) else sum(family$dev.resids(G$y,mu,G$w)) if (iter>2) { ## coef step length control #bSb <- sum(prop$beta*Sb) ## penalty at end of beta step bSb <- sum(rSb^2) ## penalty at end of beta step if ((!is.finite(dev) || dev0 + bSb0 < dev + bSb) && kk < 30) { ## beta step not improving current pen dev coef <- (coef0 + coef)/2 ## halve the step #Sb <- (Sb0 + Sb)/2 rSb <- (rSb0 + rSb)/2 eta <- (eta0 + eta)/2 prop$beta <- (b0 + prop$beta)/2 kk <- kk + 1 } else break } else break } if (iter>1) { ## save components of penalized deviance for step control coef0 <- coef ## original para eta0 <- eta mu0 <- mu b0 <- prop$beta ## beta repara #dev <- dev + sum(prop$beta*Sb) ## add penalty to deviance dev <- dev + sum(rSb^2) } else reml <- dev ## for convergence checking if (efam) { ## extended family if (iter>1) { ## estimate theta #scale1 <- if (!is.null(family$scale)) family$scale else scale if (family$n.theta>0||scale1<0) theta <- estimate.theta(theta,family,y,mu,scale=scale1,wt=G$w,tol=1e-7) if (!is.null(family$scale) && scale1<0) { scale <- exp(theta[family$n.theta+1]) theta <- theta[1:family$n.theta] } family$putTheta(theta) } dd <- dDeta(y,mu,G$w,theta=theta,family,0) ## note: no handling of infinities and wz case yet if (rho==0) { w <- dd$Deta2 * .5 z <- (eta-offset) - dd$Deta.Deta2 } else { ## use fisher weights w <- dd$EDeta2 * .5 z <- (eta-offset) - dd$Deta.EDeta2 } good <- is.finite(z)&is.finite(w) w[!good] <- 0 ## drop if !good z[!good] <- 0 ## irrelevant } else { ## exponential family mu.eta.val <- mu.eta(eta) good <- mu.eta.val != 0 mu.eta.val[!good] <- .1 ## irrelvant as weight is zero z <- (eta - offset) + (G$y - mu)/mu.eta.val w <- (G$w * mu.eta.val^2)/variance(mu) } qrx$y.norm2 <- if (rho==0) sum(w*z^2) else ## AR mod needed sum(rwMatrix(ar.stop,ar.row,ar.weight,sqrt(w)*z,trans=FALSE)^2) ## form X'WX efficiently... qrx$R <- XWXd(G$Xd,w,G$kd,G$ks,G$ts,G$dt,G$v,G$qc,npt[1],G$drop,ar.stop,ar.row,ar.weight) ##R0 <- XWXd(G$Xd,w,G$kd,G$ks,G$ts,G$dt,G$v,G$qc,1,G$drop,ar.stop,ar.row,ar.weight) ## DEBUG compare ## form X'Wz efficiently... qrx$f <- XWyd(G$Xd,w,z,G$kd,G$ks,G$ts,G$dt,G$v,G$qc,G$drop,ar.stop,ar.row,ar.weight) if(gc.level>1) gc() ## following reparameterizes X'X and f=X'y, according to initial reparameterizarion... qrx$XX <- Sl.initial.repara(Sl,qrx$R,inverse=FALSE,both.sides=TRUE,cov=FALSE,nt=npt[1]) qrx$Xy <- Sl.initial.repara(Sl,qrx$f,inverse=FALSE,both.sides=TRUE,cov=FALSE,nt=npt[1]) G$n <- nobs } else { ## end of if (iter==1||!additive) dev <- qrx$y.norm2 - sum(coef*qrx$f) ## actually penalized deviance } if (control$trace) message(gettextf("Deviance = %s Iterations - %d", dev, iter, domain = "R-mgcv")) if (!is.finite(dev)) stop("Non-finite deviance") ## preparation for working model fit is ready, but need to test for convergence first if (iter>2 && abs(dev - devold)/(0.1 + abs(dev)) < control$epsilon) { conv <- TRUE #coef <- start break } ## use fast REML code ## block diagonal penalty object, Sl, set up before loop if (iter==1) { ## need to get initial smoothing parameters lambda.0 <- initial.sp(qrx$R,G$S,G$off,XX=TRUE) ## note that this uses the untransformed X'X in qrx$R ## convert intial s.p.s to account for L lsp0 <- log(lambda.0) ## initial s.p. if (!is.null(G$L)) lsp0 <- if (ncol(G$L)>0) as.numeric(coef(lm(lsp0 ~ G$L-1+offset(G$lsp0)))) else rep(0,0) n.sp <- length(lsp0) } ## carry forward scale estimate if possible... if (scale>0) log.phi <- log(scale) else { if (iter==1) { if (is.null(coef)||qrx$y.norm2==0) lsp0[n.sp+1] <- log(var(as.numeric(G$y))*.05) else lsp0[n.sp+1] <- log(qrx$y.norm2/(nobs+nobs.extra)) } } ## get beta, grad and proposed Newton step... repeat { ## Take a Newton step to update log sp and phi lsp <- lsp0 + Nstep if (scale<=0) log.phi <- lsp[n.sp+1] prop <- Sl.fitChol(Sl,qrx$XX,qrx$Xy,rho=lsp[1:n.sp],yy=qrx$y.norm2,L=G$L,rho0=G$lsp0,log.phi=log.phi, phi.fixed=scale>0,nobs=nobs,Mp=Mp,nt=npt,tol=abs(reml)*.Machine$double.eps^.5,gamma=gamma) if (max(Nstep)==0) { Nstep <- prop$step;lsp0 <- lsp; break } else { ## step length control if (sum(prop$grad*Nstep)>dev*1e-7) Nstep <- Nstep/2 else { Nstep <- prop$step;lsp0 <- lsp;break; } } } ## end of sp update coef <- Sl.initial.repara(Sl,prop$beta,inverse=TRUE,both.sides=FALSE,cov=FALSE) if (any(!is.finite(coef))) { conv <- FALSE warning(gettextf("non-finite coefficients at iteration %d", iter)) break } reml <- (dev/(exp(log.phi)*gamma) - prop$ldetS + prop$ldetXXS)/2 } ## end fitting iteration if (!conv) warning("algorithm did not converge") eps <- 10 * .Machine$double.eps if (family$family == "binomial") { if (any(mu > 1 - eps) || any(mu < eps)) warning("fitted probabilities numerically 0 or 1 occurred") } if (family$family == "poisson") { if (any(mu < eps)) warning("fitted rates numerically 0 occurred") } Mp <- G$nsdf if (length(G$smooth)>1) for (i in 1:length(G$smooth)) Mp <- Mp + G$smooth[[i]]$null.space.dim scale <- exp(log.phi) reml <- (dev/(scale*gamma) - prop$ldetS + prop$ldetXXS + (length(y)/gamma-Mp)*log(2*pi*scale)+Mp*log(gamma))/2 if (rho!=0) { ## correct REML score for AR1 transform df <- if (is.null(mf$"(AR.start)")) 1 else sum(mf$"(AR.start)") reml <- reml - (nobs/gamma-df)*log(ld) } for (i in 1:ncol(prop$db)) prop$db[,i] <- ## d beta / d rho matrix Sl.initial.repara(Sl,as.numeric(prop$db[,i]),inverse=TRUE,both.sides=TRUE,cov=TRUE,nt=npt[1]) object <- list(db.drho=prop$db, gcv.ubre=reml,mgcv.conv=conv,rank=prop$r, scale.estimated = scale<=0,outer.info=NULL, optimizer=c("perf","chol")) object$coefficients <- coef object$family <- family ## form linear predictor efficiently... object$linear.predictors <- Xbd(G$Xd,coef,G$kd,G$ks,G$ts,G$dt,G$v,G$qc,G$drop) + G$offset object$fitted.values <- family$linkinv(object$linear.predictors) if (efam) { ## deal with any post processing if (!is.null(family$postproc)) { posr <- family$postproc(family=object$family,y=y,prior.weights=G$w, fitted=object$fitted.values,linear.predictors=object$linear.predictors,offset=G$offset, intercept=G$intercept) if (!is.null(posr$family)) object$family$family <- posr$family if (!is.null(posr$deviance)) object$deviance <- posr$deviance if (!is.null(posr$null.deviance)) object$null.deviance <- posr$null.deviance } if (is.null(object$null.deviance)) object$null.deviance <- sum(family$dev.resids(y,weighted.mean(y,G$w),G$w,theta)) } PP <- Sl.initial.repara(Sl,prop$PP,inverse=TRUE,both.sides=TRUE,cov=TRUE,nt=npt[1]) F <- pmmult(PP,qrx$R,FALSE,FALSE,nt=npt[1]) ##crossprod(PP,qrx$R) - qrx$R contains X'WX in this case object$edf <- diag(F) object$edf1 <- 2*object$edf - rowSums(t(F)*F) lsp <- if (n.sp>0) lsp[1:n.sp] else rep(0,0) object$sp <- exp(lsp) object$full.sp <- if (is.null(G$L)) object$sp else exp(drop(G$L%*%lsp + G$lsp0)) object$sig2 <- object$scale <- scale object$Vp <- PP * scale object$Ve <- pmmult(F,object$Vp,FALSE,FALSE,nt=npt[1]) ## F%*%object$Vp ## sp uncertainty correction... if (!is.null(G$L)) prop$db <- prop$db%*%G$L M <- ncol(prop$db) if (M>0) { ev <- eigen(prop$hess,symmetric=TRUE) ind <- ev$values <= 0 ev$values[ind] <- 0;ev$values[!ind] <- 1/sqrt(ev$values[!ind]) rV <- (ev$values*t(ev$vectors))[,1:M] Vc <- pcrossprod(rV%*%t(prop$db),nt=npt[1]) } else Vc <- 0 Vc <- object$Vp + Vc ## Bayesian cov matrix with sp uncertainty object$edf2 <- rowSums(Vc*qrx$R)/scale object$Vc <- Vc object$outer.info <- list(grad = prop$grad,hess=prop$hess) object$AR1.rho <- rho object$R <- if (npt[2]>1) pchol(qrx$R,npt) else suppressWarnings(chol(qrx$R,pivot=TRUE)) ## latter much faster under optimized BLAS piv <- attr(object$R,"pivot") object$R[,piv] <- object$R object$iter <- iter object$wt <- w object$y <- G$y object$prior.weights <- G$w rm(G);if (gc.level>0) gc() object } ## end bgam.fitd regular.Sb <- function(S,off,sp,beta) { ## form S %*% beta for a normal G list a <- beta*0 if (length(S)>0) for (i in 1:length(S)) { ind <- off[i] - 1 + 1:ncol(S[[i]]) a[ind] <- a[ind] + sp[i] * S[[i]] %*% beta[ind] } a } ## regular.Sb bgam.fit <- function (G, mf, chunk.size, gp ,scale ,gamma,method, coef=NULL,etastart = NULL, mustart = NULL, offset = rep(0, nobs), control = gam.control(), intercept = TRUE, cl = NULL,gc.level=0,use.chol=FALSE,nobs.extra=0,samfrac=1,npt=1) { #y <- mf[[gp$response]] y <- G$y weights <- G$w conv <- FALSE nobs <- nrow(mf) ##nvars <- ncol(G$X) offset <- G$offset family <- G$family if (inherits(G$family,"extended.family")) { ## preinitialize extended family efam <- TRUE pini <- if (is.null(G$family$preinitialize)) NULL else G$family$preinitialize(y,G$family) if (!is.null(pini$Theta)) G$family$putTheta(pini$Theta) if (!is.null(pini$y)) y <- pini$y if (is.null(G$family$scale)) scale <- 1 else scale <- if (G$family$scale<0) scale else G$family$scale scale1 <-scale if (scale < 0) scale <- var(y) *.1 ## initial guess } else efam <- FALSE G$family <- gaussian() ## needed if REML/ML used G$family$drop.intercept <- family$drop.intercept ## needed in predict.gam linkinv <- family$linkinv if (!efam) { variance <- family$variance mu.eta <- family$mu.eta 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 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 } if (is.matrix(y)&&ncol(y)>1) stop("This family should not have a matrix response") ##coefold <- NULL eta <- if (!is.null(etastart)) etastart else family$linkfun(mustart) mu <- linkinv(eta) if (!(validmu(mu) && valideta(eta))) stop("cannot find valid starting values: please specify some") dev <- sum(dev.resids(y, mu, weights))*2 ## just to avoid converging at iter 1 conv <- FALSE G$coefficients <- rep(0,ncol(G$X)) class(G) <- "gam" ## need to reset response and weights to post initialization values ## in particular to deal with binomial properly... G$y <- y G$w <- weights ## set up cluster for parallel computation... if (!is.null(cl)&&inherits(cl,"cluster")) { n.threads <- length(cl) while(nobs/n.threads < ncol(G$X)) n.threads <- n.threads - 1 if (n.threads < length(cl)) { warning("Too many cluster nodes to use all efficiently") } } else n.threads <- 1 if (n.threads>1) { ## set up thread argument lists ## number of obs per thread nt <- rep(ceiling(nobs/n.threads),n.threads) nt[n.threads] <- nobs - sum(nt[-n.threads]) arg <- list() n1 <- 0 for (i in 1:n.threads) { n0 <- n1+1;n1 <- n1+nt[i] ind <- n0:n1 ## this thread's data block from mf n.block <- nt[i]%/%chunk.size ## number of full sized blocks stub <- nt[i]%%chunk.size ## size of end block if (n.block>0) { start <- (0:(n.block-1))*chunk.size+1 stop <- (1:n.block)*chunk.size if (stub>0) { start[n.block+1] <- stop[n.block]+1 stop[n.block+1] <- nt[i] n.block <- n.block+1 } } else { n.block <- 1 start <- 1 stop <- nt[i] } arg[[i]] <- list(nobs= nt[i],start=start,stop=stop,n.block=n.block, linkinv=linkinv,dev.resids=dev.resids,gc.level=gc.level, mf = mf[ind,], eta = eta[ind],offset = offset[ind],G = G,use.chol=use.chol) if (efam) { arg[[i]]$family <- family } else { arg[[i]]$mu.eta <- mu.eta arg[[i]]$variance <- variance } arg[[i]]$G$w <- G$w[ind];arg[[i]]$G$model <- NULL arg[[i]]$G$y <- G$y[ind] } } else { ## single thread, requires single indices ## construct indices for splitting up model matrix construction... n.block <- nobs%/%chunk.size ## number of full sized blocks stub <- nobs%%chunk.size ## size of end block if (n.block>0) { start <- (0:(n.block-1))*chunk.size+1 stop <- (1:n.block)*chunk.size if (stub>0) { start[n.block+1] <- stop[n.block]+1 stop[n.block+1] <- nobs n.block <- n.block+1 } } else { n.block <- 1 start <- 1 stop <- nobs } } ## single thread indices complete conv <- FALSE if (method=="fREML") Sl <- Sl.setup(G) ## setup block diagonal penalty object if (efam) theta <- family$getTheta() for (iter in 1L:control$maxit) { ## main fitting loop ## accumulate the QR decomposition of the weighted model matrix devold <- dev kk <- 0 repeat { dev <- 0;wt <- rep(0,0) if (n.threads == 1) { ## use original serial update code wt <- G$y for (b in 1:n.block) { ind <- start[b]:stop[b] X <- predict(G,newdata=mf[ind,],type="lpmatrix",newdata.guaranteed=TRUE,block.size=length(ind)) rownames(X) <- NULL if (is.null(coef)) eta1 <- eta[ind] else eta[ind] <- eta1 <- drop(X%*%coef) + offset[ind] mu <- linkinv(eta1) y <- G$y[ind] ## G$model[[gp$response]] ## - G$offset[ind] weights <- G$w[ind] if (efam) { ## extended family case dd <- dDeta(y,mu,weights,theta=theta,family,0) ## note: no handling of infinities and wz case yet w <- dd$EDeta2 * .5 #w <- w z <- (eta1-offset[ind]) - dd$Deta.EDeta2 good <- is.finite(z)&is.finite(w) } else { ## regular exp fam case mu.eta.val <- mu.eta(eta1) good <- (weights > 0) & (mu.eta.val != 0) z <- (eta1 - offset[ind]) + (y - mu)/mu.eta.val w <- (weights * mu.eta.val^2)/variance(mu) } dev <- dev + if (efam) sum(dev.resids(y,mu,weights,theta)) else sum(dev.resids(y,mu,weights)) w[!good] <- 0 ## drop if !good #z[!good] <- 0 ## irrelevant wt[ind] <- w ## wt <- c(wt,w) w <- w[good];z <- z[good] w <- sqrt(w) ## note that QR may be parallel using npt>1, even under serial accumulation... if (b == 1) qrx <- qr.update(w*X[good,,drop=FALSE],w*z,use.chol=use.chol,nt=npt) else qrx <- qr.update(w*X[good,,drop=FALSE],w*z,qrx$R,qrx$f,qrx$y.norm2,use.chol=use.chol,nt=npt) rm(X);if(gc.level>1) gc() ## X can be large: remove and reclaim } if (use.chol) { ## post proc to get R and f... y.norm2 <- qrx$y.norm2 qrx <- chol2qr(qrx$R,qrx$f,nt=npt) qrx$y.norm2 <- y.norm2 } } else { ## use parallel accumulation for (i in 1:length(arg)) { arg[[i]]$coef <- coef if (efam) arg[[i]]$theta <- theta } res <- parallel::parLapply(cl,arg,qr.up) ## single thread debugging version #res <- list() #for (i in 1:length(arg)) { # res[[i]] <- qr.up(arg[[i]]) #} ## now consolidate the results from the parallel threads... if (use.chol) { R <- res[[1]]$R;f <- res[[1]]$f;dev <- res[[1]]$dev wt <- res[[1]]$wt;y.norm2 <- res[[1]]$y.norm2 eta <- res[[1]]$eta for (i in 2:n.threads) { R <- R + res[[i]]$R; f <- f + res[[i]]$f wt <- c(wt,res[[i]]$wt);eta <- c(eta,res[[i]]$eta); dev <- dev + res[[i]]$dev y.norm2 <- y.norm2 + res[[i]]$y.norm2 } qrx <- chol2qr(R,f,nt=npt) qrx$y.norm2 <- y.norm2 } else { ## proper QR R <- res[[1]]$R;f <- res[[1]]$f;dev <- res[[1]]$dev wt <- res[[1]]$wt;y.norm2 <- res[[1]]$y.norm2; eta <- res[[1]]$eta for (i in 2:n.threads) { R <- rbind(R,res[[i]]$R); f <- c(f,res[[i]]$f) wt <- c(wt,res[[i]]$wt);eta <- c(eta,res[[i]]$eta) dev <- dev + res[[i]]$dev y.norm2 <- y.norm2 + res[[i]]$y.norm2 } ## use parallel QR here if npt>1... qrx <- if (npt>1) pqr2(R,npt) else qr(R,tol=0,LAPACK=TRUE) f <- qr.qty(qrx,f)[1:ncol(R)] rp <- qrx$pivot;rp[rp] <- 1:ncol(R) # reverse pivot qrx <- list(R=qr.R(qrx)[,rp],f=f,y.norm2=y.norm2) } } ## if the routine has been called with only a random sample of the data, then ## R, f and ||y||^2 can be corrected to estimate the full versions... qrx$R <- qrx$R/sqrt(samfrac) qrx$f <- qrx$f/sqrt(samfrac) qrx$y.norm2 <- qrx$y.norm2/samfrac G$n <- nobs rss.extra <- qrx$y.norm2 - sum(qrx$f^2) if (control$trace) message(gettextf("Deviance = %s Iterations - %d", dev, iter, domain = "R-mgcv")) if (!is.finite(dev)) stop("Non-finite deviance") ## preparation for working model fit is ready, but need to test for convergence first if (iter>2 && abs(dev - devold)/(0.1 + abs(dev)) < control$epsilon) { conv <- TRUE coef <- start break } if (kk > 0) break ## already shrunk the step ## At this point it is worth checking that coef update actually improved the penalized ## deviance. If not try step halving, and redo the above once a suitable step has been ## found... if (iter>2) { ## can test divergence ## need to compute penalty at start and end of step if (efam) { dev0 <- sum(dev.resids(G$y,linkinv(eta0),G$w,theta0)) ## depends on theta, which will have changed dev1 <- sum(dev.resids(G$y,linkinv(eta),G$w,theta0)) ## depends on theta, which will have changed } else { dev1 <- dev } if (method=="fREML") { pcoef <- fit$beta Sb0 <- Sl.Sb(um$Sl,rho=log(object$full.sp),pcoef0) Sb <- Sl.Sb(um$Sl,rho=log(object$full.sp),pcoef) } else { pcoef <- coef full.sp <- if (is.null(object$full.sp)) object$sp else object$full.sp Sb0 <- regular.Sb(G$S,G$off,full.sp,pcoef0) Sb <- regular.Sb(G$S,G$off,full.sp,pcoef) } while (dev0 + sum(pcoef0*Sb0) < dev1 + sum(pcoef * Sb) && kk < 6) { ## shrink step ... coef <- (coef0 + coef)/2 pcoef <- (pcoef0 + pcoef)/2 eta <- (eta0 + eta)/2 Sb <- (Sb0 + Sb)/2 ## recompute deviance ... dev <- if (efam) sum(dev.resids(G$y,linkinv(eta),G$w,theta)) else sum(dev.resids(G$y,linkinv(eta),G$w)) dev1 <- if (efam) sum(dev.resids(G$y,linkinv(eta),G$w,theta0)) else dev kk <- kk + 1 } } if (kk == 0) break ## step was ok } ## repeat if (conv) break if (iter>1) { ## store coef and eta for divergence checking coef0 <- coef if (efam) theta0 <- theta ## theta used for determining step pcoef0 <- if (method=="fREML") fit$beta else coef eta0 <- eta dev0 <- dev } if (efam && iter>1) { ## estimate theta #scale1 <- if (!is.null(family$scale)) family$scale else scale if (family$n.theta>0||scale1<0) theta <- estimate.theta(theta,family,G$y,linkinv(eta),scale=scale1,wt=G$w,tol=1e-7) if (!is.null(family$scale) && scale1<0) { scale <- exp(theta[family$n.theta+1]) theta <- theta[1:family$n.theta] } family$putTheta(theta) } if (method=="GCV.Cp") { fit <- magic(qrx$f,qrx$R,G$sp,G$S,G$off,L=G$L,lsp0=G$lsp0,rank=G$rank, H=G$H,C=matrix(0,0,ncol(qrx$R)), ##C=G$C, gamma=gamma,scale=scale,gcv=(scale<=0), extra.rss=rss.extra,n.score=nobs+nobs.extra) post <- magic.post.proc(qrx$R,fit,qrx$f*0+1) } else if (method=="fREML") { ## use fast REML code ## block diagonal penalty object, Sl, set up before loop um <- Sl.Xprep(Sl,qrx$R,nt=npt) lambda.0 <- initial.sp(qrx$R,G$S,G$off) lsp0 <- log(lambda.0) ## initial s.p. ## carry forward scale estimate if possible... if (scale>0) log.phi <- log(scale) else { if (iter>1) log.phi <- log(object$scale) else { if (is.null(coef)||qrx$y.norm2==0) log.phi <- log(var(as.numeric(G$y))*.05) else log.phi <- log(qrx$y.norm2/(nobs+nobs.extra)) } } fit <- fast.REML.fit(um$Sl,um$X,qrx$f,rho=lsp0,L=G$L,rho.0=G$lsp0, log.phi=log.phi,phi.fixed=scale>0,rss.extra=rss.extra, nobs =nobs+nobs.extra,Mp=um$Mp,nt=npt,gamma=gamma) res <- Sl.postproc(Sl,fit,um$undrop,qrx$R,cov=FALSE,L=G$L,nt=npt) object <- list(coefficients=res$beta,db.drho=fit$d1b, gcv.ubre=fit$reml,mgcv.conv=list(iter=fit$iter, message=fit$conv),rank=ncol(um$X), Ve=NULL,scale.estimated = scale<=0,outer.info=fit$outer.info, optimizer=c("perf","newton")) if (scale<=0) { ## get sp's and scale estimate nsp <- length(fit$rho) object$sig2 <- object$scale <- exp(fit$rho[nsp]) object$sp <- exp(fit$rho[-nsp]) nsp <- length(fit$rho.full) object$full.sp <- exp(fit$rho.full[-nsp]) } else { ## get sp's object$sig2 <- object$scale <- scale object$sp <- exp(fit$rho) object$full.sp <- exp(fit$rho.full) } class(object)<-c("gam") } else { ## method is one of "ML", "P-REML" etc... y <- G$y; w <- G$w; n <- G$n;offset <- G$offset G$y <- qrx$f G$w <- G$y*0+1 G$X <- qrx$R G$n <- length(G$y) G$offset <- G$y*0 G$dev.extra <- rss.extra G$pearson.extra <- rss.extra G$n.true <- nobs+nobs.extra object <- gam(G=G,method=method,gamma=gamma,scale=scale,control=gam.control(nthreads=npt)) y -> G$y; w -> G$w; n -> G$n;offset -> G$offset object$deviance <- object$family <- object$null.deviance <- object$fitted.values <- NULL } if (method=="GCV.Cp") { object <- list() object$coefficients <- fit$b object$edf <- post$edf object$edf1 <- post$edf1 ##object$F <- post$F object$full.sp <- fit$sp.full object$gcv.ubre <- fit$score object$hat <- post$hat object$mgcv.conv <- fit$gcv.info object$optimizer="magic" object$rank <- fit$gcv.info$rank object$Ve <- post$Ve object$Vp <- post$Vb object$sig2 <- object$scale <- fit$scale object$sp <- fit$sp names(object$sp) <- names(G$sp) class(object)<-c("gam") } coef <- object$coefficients if (any(!is.finite(coef))) { conv <- FALSE warning(gettextf("non-finite coefficients at iteration %d", iter)) break } } ## end fitting iteration if (method=="fREML") { ## do expensive cov matrix cal only at end res <- Sl.postproc(Sl,fit,um$undrop,qrx$R,cov=TRUE,scale=scale,L=G$L,nt=npt) object$edf <- res$edf object$edf1 <- res$edf1 object$edf2 <- res$edf2 ##object$F <- res$F object$hat <- res$hat object$Vp <- res$Vp object$Ve <- res$Ve object$Vc <- res$Vc } if (efam) { ## deal with any post processing if (!is.null(family$postproc)) { object$family <- family posr <- family$postproc(family=family,y=y,prior.weights=G$w, fitted=linkinv(eta),linear.predictors=eta,offset=G$offset, intercept=G$intercept) if (!is.null(posr$family)) object$family$family <- posr$family if (!is.null(posr$deviance)) object$deviance <- posr$deviance if (!is.null(posr$null.deviance)) object$null.deviance <- posr$null.deviance } if (is.null(object$null.deviance)) object$null.deviance <- sum(family$dev.resids(G$y,weighted.mean(G$y,G$w),G$w,theta)) } if (!conv) warning("algorithm did not converge") eps <- 10 * .Machine$double.eps if (family$family == "binomial") { if (any(mu > 1 - eps) || any(mu < eps)) warning("fitted probabilities numerically 0 or 1 occurred") } if (family$family == "poisson") { if (any(mu < eps)) warning("fitted rates numerically 0 occurred") } object$R <- qrx$R object$iter <- iter object$wt <- wt object$y <- G$y object$prior.weights <- G$w rm(G);if (gc.level>0) gc() object } ## end bgam.fit ar.qr.up <- function(arg) { ## function to perform QR updating with AR residuals, on one execution thread if (arg$rho!=0) { ## AR1 error model ld <- 1/sqrt(1 - arg$rho^2) ## leading diagonal of root inverse correlation sd <- -arg$rho * ld ## sub diagonal } yX.last <- NULL qrx <- list(R=NULL,f=array(0,0),y.norm2=0) ## initial empty qr object for (i in 1:arg$n.block) { ind <- arg$start[i]:arg$end[i] if (arg$rho!=0) { ## have to find AR1 transform... N <- arg$end[i]-arg$start[i]+1 ## note first row implied by this transform ## is always dropped, unless really at beginning of data. row <- c(1,rep(1:N,rep(2,N))[-c(1,2*N)]) weight <- c(1,rep(c(sd,ld),N-1)) stop <- c(1,1:(N-1)*2+1) if (!is.null(arg$mf$"(AR.start)")) { ## need to correct the start of new AR sections... ii <- which(arg$mf$"(AR.start)"[ind]==TRUE) if (length(ii)>0) { if (ii[1]==1) ii <- ii[-1] ## first observation does not need any correction weight[ii*2-2] <- 0 ## zero sub diagonal weight[ii*2-1] <- 1 ## set leading diagonal to 1 } } } ## arg$G$model <- arg$mf[ind,] w <- sqrt(arg$G$w[ind]) X <- w*predict(arg$G,newdata=arg$mf[ind,],type="lpmatrix",newdata.guaranteed=TRUE,block.size=length(ind)) y <- w*(arg$mf[ind,arg$response] - arg$offset[ind]) ## w*(arg$G$model[[arg$response]] - arg$offset[ind]) if (arg$rho!=0) { ## Apply transform... if (arg$last&&arg$end[i]==arg$nobs) yX.last <- c(y[nrow(X)],X[nrow(X),]) ## store final row, in case of update if (arg$first&&i==1) { X <- rwMatrix(stop,row,weight,X) y <- rwMatrix(stop,row,weight,y) } else { X <- rwMatrix(stop,row,weight,X)[-1,] y <- rwMatrix(stop,row,weight,y)[-1] } } ## dealt with AR1 qrx <- qr.update(X,y,qrx$R,qrx$f,qrx$y.norm2,use.chol=arg$use.chol) rm(X);if (arg$gc.level>1) {gc()} ## X can be large: remove and reclaim } ## all blocks dealt with qrx$yX.last <- yX.last if (arg$gc.level>1) {rm(arg,w,y,ind);gc()} qrx } ## ar.qr.up pabapr <- function(arg) { ## function for parallel calling of predict.gam ## QUERY: ... handling? predict.gam(arg$object,newdata=arg$newdata,type=arg$type,se.fit=arg$se.fit,terms=arg$terms, block.size=arg$block.size,newdata.guaranteed=arg$newdata.guaranteed, na.action=arg$na.action) } predict.bam <- function(object,newdata,type="link",se.fit=FALSE,terms=NULL,exclude=NULL, block.size=50000,newdata.guaranteed=FALSE,na.action=na.pass, cluster=NULL,discrete=TRUE,n.threads=1,...) { ## function for prediction from a bam object, possibly in parallel #if (is.function(na.action)) na.action <- deparse(substitute(na.action)) ## otherwise predict.gam can't detect type if (discrete && !is.null(object$dinfo)) { return(predict.bamd(object,newdata,type,se.fit,terms,exclude, block.size,newdata.guaranteed,na.action,n.threads,...)) } ## remove some un-needed stuff from object object$Sl <- object$qrx <- object$R <- object$F <- object$Ve <- object$Vc <- object$G <- object$residuals <- object$fitted.values <- object$linear.predictors <- NULL gc() if (!is.null(cluster)&&inherits(cluster,"cluster")) { ## require(parallel) n.threads <- length(cluster) } else n.threads <- 1 if (missing(newdata)) n <- nrow(object$model) else { n <- if (is.matrix(newdata[[1]])) nrow(newdata[[1]]) else length(newdata[[1]]) } if (n < 100*n.threads) n.threads <- 1 ## not worth the overheads if (n.threads==1) { ## single threaded call if (missing(newdata)) return( predict.gam(object,newdata=object$model,type=type,se.fit=se.fit,terms=terms,exclude=exclude, block.size=block.size,newdata.guaranteed=newdata.guaranteed, na.action=na.action,...) ) else return( predict.gam(object,newdata=newdata,type=type,se.fit=se.fit,terms=terms,exclude=exclude, block.size=block.size,newdata.guaranteed=newdata.guaranteed, na.action=na.action,...)) } else { ## parallel call... nt <- rep(floor(n/n.threads),n.threads) nt[1] <- n - sum(nt[-1]) arg <- list() n1 <- 0 for (i in 1:n.threads) { n0 <- n1+1;n1 <- n1+nt[i] ind <- n0:n1 ## this thread's data block from mf arg[[i]] <- list(object=object,type=type,se.fit=se.fit,terms=terms,exclude=exclude, block.size=block.size,newdata.guaranteed=newdata.guaranteed, na.action=na.action) arg[[i]]$object$model <- object$model[1:2,] ## save space if (missing(newdata)) { arg[[i]]$newdata <- object$model[ind,] } else { arg[[i]]$newdata <- newdata[ind,] } } ## finished setting up arguments ## newdata and object no longer needed - all info in thread lists... if (!missing(newdata)) rm(newdata) rm(object) gc() res <- parallel::parLapply(cluster,arg,pabapr) ## perform parallel prediction gc() ## and splice results back together... if (type=="lpmatrix") { X <- res[[1]] for (i in 2:length(res)) X <- rbind(X,res[[i]]) return(X) } else if (se.fit==TRUE) { rt <- list(fit = res[[1]]$fit,se.fit = res[[1]]$se.fit) if (type=="terms") { for (i in 2:length(res)) { rt$fit <- rbind(rt$fit,res[[i]]$fit) rt$se.fit <- rbind(rt$se.fit,res[[i]]$se.fit) } } else { for (i in 2:length(res)) { rt$fit <- c(rt$fit,res[[i]]$fit) rt$se.fit <- c(rt$se.fit,res[[i]]$se.fit) } } return(rt) } else { ## no se's returned rt <- res[[1]] if (type=="terms") { for (i in 2:length(res)) rt <- rbind(rt,res[[i]]) } else { for (i in 2:length(res)) rt <- c(rt,res[[i]]) } return(rt) } } } ## end predict.bam bam.fit <- function(G,mf,chunk.size,gp,scale,gamma,method,rho=0, cl=NULL,gc.level=0,use.chol=FALSE,npt=1) { ## function that does big additive model fit in strictly additive case ## first perform the QR decomposition, blockwise.... n <- nrow(mf) if (rho!=0) { ## AR1 error model ld <- 1/sqrt(1-rho^2) ## leading diagonal of root inverse correlation sd <- -rho*ld ## sub diagonal } if (n>chunk.size) { ## then use QR accumulation approach if (!is.null(cl)&&inherits(cl,"cluster")) { n.threads <- length(cl) while(n/n.threads < ncol(G$X)) n.threads <- n.threads - 1 if (n.threads < length(cl)) { warning("Too many cluster nodes to use all efficiently") } } else n.threads <- 1 G$coefficients <- rep(0,ncol(G$X)) class(G) <- "gam" if (n.threads>1) { ## set up thread argument lists ## number of obs per thread nt <- rep(ceiling(n/n.threads),n.threads) nt[n.threads] <- n - sum(nt[-n.threads]) arg <- list() n1 <- 0 for (i in 1:n.threads) { n0 <- n1+1;n1 <- n1+nt[i] if (i>1&&rho!=0) { ## need to start from end of last block if rho!=0 n0 <- n0-1;nt[i] <- nt[i]+1 } ind <- n0:n1 ## this thread's data block from mf n.block <- nt[i]%/%chunk.size ## number of full sized blocks stub <- nt[i]%%chunk.size ## size of end block if (n.block>0) { ## each block is of size start <- (0:(n.block-1))*chunk.size+1 end <- start + chunk.size - 1 if (stub>0) { start[n.block+1] <- end[n.block]+1 end[n.block+1] <- nt[i] n.block <- n.block+1 } if (rho!=0) { ## then blocks must overlap ns <- length(start) if (ns>1) start[2:ns] <- start[2:ns]-1 } } else { n.block <- 1 start <- 1 end <- nt[i] } arg[[i]] <- list(nobs= nt[i],start=start,end=end,n.block=n.block, rho=rho,mf = mf[ind,],gc.level=gc.level, offset = G$offset[ind],G = G,response=gp$response, first=FALSE,last=FALSE,use.chol=use.chol) if (i==1) arg[[1]]$first <- TRUE if (i==n.threads) arg[[i]]$last <- TRUE arg[[i]]$G$w <- G$w[ind];arg[[i]]$G$model <- NULL } } else { ## single thread, requires single indices n.block <- n%/%chunk.size ## number of full sized blocks stub <- n%%chunk.size ## size of end block if (stub>0) n.block <- n.block + 1 start <- 0:(n.block-1)*chunk.size ## block starts end <- start + chunk.size; ## block ends end[n.block] <- n if (rho==0) start <- start + 1 ## otherwise most blocks go to 1 before block start start[1] <- 1 } if (n.threads==1) { ## use original single thread method... qrx <- list(R=NULL,f=array(0,0),y.norm2=0) ## initial empty qr object for (i in 1:n.block) { ind <- start[i]:end[i] if (rho!=0) { N <- end[i]-start[i]+1 row <- c(1,rep(1:N,rep(2,N))[-c(1,2*N)]) weight <- c(1,rep(c(sd,ld),N-1)) stop <- c(1,1:(N-1)*2+1) if (!is.null(mf$"(AR.start)")) { ## need to correct the start of new AR sections... ii <- which(mf$"(AR.start)"[ind]==TRUE) if (length(ii)>0) { if (ii[1]==1) ii <- ii[-1] ## first observation does not need any correction weight[ii*2-2] <- 0 ## zero sub diagonal weight[ii*2-1] <- 1 ## set leading diagonal to 1 } } } #G$model <- mf[ind,] w <- sqrt(G$w[ind]) X <- w*predict(G,newdata=mf[ind,],type="lpmatrix",newdata.guaranteed=TRUE,block.size=length(ind)) y <- w*(mf[ind,gp$response]-G$offset[ind]) ## w*(G$model[[gp$response]] - G$offset[ind]) if (rho!=0) { ## Apply transform... if (end[i]==n) yX.last <- c(y[nrow(X)],X[nrow(X),]) ## store final row, in case of update if (i==1) { X <- rwMatrix(stop,row,weight,X) y <- rwMatrix(stop,row,weight,y) } else { X <- rwMatrix(stop,row,weight,X)[-1,] y <- rwMatrix(stop,row,weight,y)[-1] } } qrx <- qr.update(X,y,qrx$R,qrx$f,qrx$y.norm2,use.chol=use.chol,nt=npt) rm(X) if (gc.level>1) {gc()} ## X can be large: remove and reclaim } ## end of single thread block loop if (use.chol) { ## post proc to get R and f... y.norm2 <- qrx$y.norm2 qrx <- chol2qr(qrx$R,qrx$f,nt=npt) qrx$y.norm2 <- y.norm2 } } else { ## use parallel accumulation res <- parallel::parLapply(cl,arg,ar.qr.up) ## Single thread de-bugging... # res <- list() # for (i in 1:length(arg)) { # res[[i]] <- ar.qr.up(arg[[i]]) # } ## now consolidate the results from the parallel threads... R <- res[[1]]$R;f <- res[[1]]$f; ## dev <- res[[1]]$dev y.norm2 <- res[[1]]$y.norm2 for (i in 2:n.threads) { if (use.chol) { R <- R + res[[i]]$R; f <- f + res[[i]]$f } else { R <- rbind(R,res[[i]]$R); f <- c(f,res[[i]]$f) } y.norm2 <- y.norm2 + res[[i]]$y.norm2 } if (use.chol) { qrx <- chol2qr(R,f,nt=npt) qrx$y.norm2 <- y.norm2 } else { ## proper QR ## use parallel QR if npt>1... qrx <- if (npt>1) pqr2(R,npt) else qr(R,tol=0,LAPACK=TRUE) f <- qr.qty(qrx,f)[1:ncol(R)] rp <- qrx$pivot;rp[rp] <- 1:ncol(R) # reverse pivot qrx <- list(R=qr.R(qrx)[,rp],f=f,y.norm2=y.norm2) } yX.last <- res[[n.threads]]$yX.last } G$n <- n #G$y <- mf[[gp$response]] } else { ## n <= chunk.size if (rho==0) qrx <- qr.update(sqrt(G$w)*G$X,sqrt(G$w)*(G$y-G$offset),use.chol=use.chol,nt=npt) else { row <- c(1,rep(1:n,rep(2,n))[-c(1,2*n)]) weight <- c(1,rep(c(sd,ld),n-1)) stop <- c(1,1:(n-1)*2+1) if (!is.null(mf$"(AR.start)")) { ## need to correct the start of new AR sections... ii <- which(mf$"(AR.start)"==TRUE) if (length(ii)>0) { if (ii[1]==1) ii <- ii[-1] ## first observation does not need any correction weight[ii*2-2] <- 0 ## zero sub diagonal weight[ii*2-1] <- 1 ## set leading diagonal to 1 } } yX.last <- c(G$y[n],G$X[n,]) ## store final row, in case of update X <- rwMatrix(stop,row,weight,sqrt(G$w)*G$X) y <- rwMatrix(stop,row,weight,sqrt(G$w)*G$y) qrx <- qr.update(X,y,use.chol=use.chol,nt=npt) rm(X); if (gc.level>1) gc() ## X can be large: remove and reclaim } if (use.chol) { ## post proc to get R and f... y.norm2 <- qrx$y.norm2 qrx <- chol2qr(qrx$R,qrx$f,nt=npt) qrx$y.norm2 <- y.norm2 } } rss.extra <- qrx$y.norm2 - sum(qrx$f^2) if (method=="GCV.Cp") { fit <- magic(qrx$f,qrx$R,G$sp,G$S,G$off,L=G$L,lsp0=G$lsp0,rank=G$rank, H=G$H,C=matrix(0,0,ncol(qrx$R)), ##C=G$C, gamma=gamma,scale=scale,gcv=(scale<=0), extra.rss=rss.extra,n.score=n) post <- magic.post.proc(qrx$R,fit,qrx$f*0+1) } else if (method=="fREML"){ ## use fast REML code Sl <- Sl.setup(G) ## setup block diagonal penalty object um <- Sl.Xprep(Sl,qrx$R,nt=npt) lambda.0 <- initial.sp(qrx$R,G$S,G$off) lsp0 <- log(lambda.0) ## initial s.p. if (scale<=0) log.phi <- log(var(as.numeric(G$y))*.05) else ## initial phi guess log.phi <- log(scale) fit <- fast.REML.fit(um$Sl,um$X,qrx$f,rho=lsp0,L=G$L,rho.0=G$lsp0, log.phi=log.phi,phi.fixed=scale>0,rss.extra=rss.extra, nobs =n,Mp=um$Mp,nt=npt,gamma=gamma) res <- Sl.postproc(Sl,fit,um$undrop,qrx$R,cov=TRUE,scale=scale,L=G$L,nt=npt) object <- list(coefficients=res$beta,edf=res$edf,edf1=res$edf1,edf2=res$edf2,##F=res$F, db.drho=fit$d1b, gcv.ubre=fit$reml,hat=res$hat,mgcv.conv=list(iter=fit$iter, message=fit$conv),rank=ncol(um$X), Ve=res$Ve,Vp=res$Vp,Vc=res$Vc, scale.estimated = scale<=0,outer.info=fit$outer.info, optimizer=c("perf","newton")) if (scale<=0) { ## get sp's and scale estimate nsp <- length(fit$rho) object$sig2 <- object$scale <- exp(fit$rho[nsp]) object$sp <- exp(fit$rho[-nsp]) nsp <- length(fit$rho.full) object$full.sp <- exp(fit$rho.full[-nsp]) } else { ## get sp's object$sig2 <- object$scale <- scale object$sp <- exp(fit$rho) object$full.sp <- exp(fit$rho.full) } if (rho!=0) { ## correct RE/ML score for AR1 transform df <- if (is.null(mf$"(AR.start)")) 1 else sum(mf$"(AR.start)") object$gcv.ubre <- object$gcv.ubre - (n-df)*log(ld) } G$X <- qrx$R;G$dev.extra <- rss.extra G$pearson.extra <- rss.extra;G$n.true <- n object$Sl <- Sl ## to allow for efficient update class(object)<-c("gam") } else { ## method is "ML", "P-REML" or similar y <- G$y; w <- G$w; n <- G$n;offset <- G$offset G$y <- qrx$f G$w <- G$y*0+1 G$X <- qrx$R G$n <- length(G$y) G$offset <- G$y*0 G$dev.extra <- rss.extra G$pearson.extra <- rss.extra G$n.true <- n object <- gam(G=G,method=method,gamma=gamma,scale=scale,control=gam.control(nthreads=npt)) object$null.deviance <- object$fitted.values <- NULL y -> G$y; w -> G$w; n -> G$n;offset -> G$offset if (rho!=0) { ## correct RE/ML score for AR1 transform df <- if (is.null(mf$"(AR.start)")) 1 else sum(mf$"(AR.start)") object$gcv.ubre <- object$gcv.ubre - (n-df)*log(ld) } } if (method=="GCV.Cp") { object <- list() object$coefficients <- fit$b object$edf <- post$edf object$edf1 <- post$edf1 ##object$F <- post$F object$full.sp <- fit$sp.full object$gcv.ubre <- fit$score object$hat <- post$hat object$mgcv.conv <- fit$gcv.info object$optimizer="magic" object$rank <- fit$gcv.info$rank object$Ve <- post$Ve object$Vp <- post$Vb object$sig2 <- object$scale <- fit$scale object$sp <- fit$sp class(object)<-c("gam") } else { } G$smooth <- G$X <- NULL object$prior.weights <- G$w object$AR1.rho <- rho if (rho!=0) { ## need to store last model matrix row, to allow update object$yX.last <- yX.last } object$R <- qrx$R object$gamma <- gamma;object$G <- G;object$qrx <- qrx ## to allow updating of the model object$y <- mf[[gp$response]] object$iter <- 1 object } # end of bam.fit predict.bamd <- function(object,newdata,type="link",se.fit=FALSE,terms=NULL,exclude=NULL, block.size=50000,newdata.guaranteed=FALSE,na.action=na.pass,n.threads=1,...) { ## function for prediction from a bam object, by discrete methods ## remove some un-needed stuff from object object$Sl <- object$qrx <- object$R <- object$F <- object$Ve <- object$Vc <- object$G <- object$residuals <- object$fitted.values <- object$linear.predictors <- NULL gc() if (missing(newdata)) newdata <- object$model convert2mf <- is.null(attr(newdata,"terms")) if (type=="iterms") { type <- "terms" warning("iterms reset to terms") } lpi <- attr(object$formula,"lpi") ## lpi[[i]] indexes coefs for ith linear predoctor nlp <- if (is.null(lpi)) 1 else length(lpi) ## number of linear predictors if (nlp>1) lpid <- object$dinfo$lpid ## index of discrete terms involved in each linear predictor # if (!is.null(exclude)) warning("exclude ignored by discrete prediction at present") ## newdata has to be processed first to avoid, e.g. dropping different subsets of data ## for parametric and smooth components.... newterms <- attr(newdata,"terms") ## non NULL for model frame newdata <- predict.gam(object,newdata=newdata,type="newdata",se.fit=se.fit,terms=terms,exclude=exclude, block.size=block.size,newdata.guaranteed=newdata.guaranteed, na.action=na.action,...) ## Next line needed to avoid treating newdata as a model frame if it was supplied not as a model frame. ## Otherwise names of e.g. offset are messed up (as they will also be if it was supplied as a model frame ## or was set to object$model and we set terms to NULL) if (is.null(newterms)) attr(newdata,"terms") <- NULL na.act <- attr(newdata,"na.action") ## save the NA action for later ## Parametric terms have to be dealt with safely, but without forming all terms ## or a full model matrix. Strategy here is to use predict.gam, having removed ## key smooth related components from model object, so that it appears to be ## a parametric model... offset <- 0 if (any(object$nsdf)||any(object$offset!=0)) { ## deal with parametric terms... ## save copies of smooth info... smooth <- object$smooth; coef <- object$coefficients; Vp <- object$Vp ## remove key smooth info from object ## first identify coefficients (indexed by ii) to retain, and modify pstart ## attribute so that it's pointing to retained coefficient array. if (length(object$nsdf)>1) { pstart <- attr(object$nsdf,"pstart") ps <- pstart * 0 ii <- rep(0,0); k <- 1 for (i in 1:length(object$nsdf)) if (object$nsdf[i]) { ps[i] <- k;k <- k + object$nsdf[i] ii <- c(ii,1:object$nsdf[i]+pstart[i]-1) } attr(object$nsdf,"pstart") <- ps ## make compatible with stripping out smooths } else { ii <- 1:object$nsdf; pstart <- 1; ps <- 1} object$coefficients <- object$coefficients[ii] object$Vp <- object$Vp[ii,ii] object$smooth <- NULL ## get prediction for parametric component. Always "lpmatrix", unless terms required. ptype <- if (type %in% c("terms","iterms")) type else "lpmatrix" pterms <- if (is.null(terms)) terms else terms[terms %in% row.names(attr(object$pterms,"factors"))] pexclude <- if (is.null(exclude)) exclude else exclude[exclude %in% row.names(attr(object$pterms,"factors"))] pp <- predict.gam(object,newdata=newdata,type=ptype,se.fit=se.fit,terms=pterms,exclude=pexclude, block.size=block.size,newdata.guaranteed=TRUE, na.action=na.action,...) ## restore smooths to 'object' object$coefficients <- coef object$Vp <- Vp object$smooth <- smooth if (length(object$nsdf)) pstart -> attr(object$nsdf,"pstart") ## restore pstart if (ptype=="lpmatrix") { offset <- attr(pp,"model.offset") if (is.null(offset)) offset <- if (nlp==1) 0 else as.list(rep(0,nlp)) } } else { pp <- if (se.fit) list(fit=rep(0,0),se.fit=rep(0,0)) else rep(0,0)} ## parametric component dealt with ## now discretize covariates... if (convert2mf) newdata <- model.frame(object$dinfo$gp$fake.formula[-2],newdata) dk <- discrete.mf(object$dinfo$gp,mf=newdata,names.pmf=NULL,full=FALSE) Xd <- list() ### list of discrete model matrices... k <- 1 kd <- dk$k if (any(object$nsdf>0)) for (i in 1:length(object$nsdf)) if (object$nsdf[i]>0) { Xd[[k]] <- if (type%in%c("terms","iterms")) matrix(0,0,0) else pp[,ps[k]+1:object$nsdf[k]-1,drop=FALSE] kd <- cbind(1:nrow(newdata),kd) ## add index for parametric part to index list k <- k + 1; dk$k.start <- c(1,dk$k.start+1) ## and adjust k.start accordingly dk$nr <- c(NA,dk$nr) ## need array index to match elements of Xd } else { #kb <- k <- 1; #kd <- dk$k } kb <- k ## k[,ks[j,1]:ks[j,2]] gives index columns for term j, thereby allowing ## summation over matrix covariates.... ks <- cbind(dk$k.start[-length(dk$k.start)],dk$k.start[-1]) ts <- object$dinfo$ts dt <- object$dinfo$dt for (i in 1:length(object$smooth)) { ## work through the smooth list ## first deal with any by variable (as first marginal of tensor)... if (object$smooth[[i]]$by!="NA") { by.var <- dk$mf[[object$smooth[[i]]$by]][1:dk$nr[k]] if (is.factor(by.var)) { ## create dummy by variable... by.var <- as.numeric(by.var==object$smooth[[i]]$by.level) } Xd[[k]] <- matrix(by.var,dk$nr[k],1) k <- k + 1 by.present <- 1 } else by.present <- 0 ## ... by done if (inherits(object$smooth[[i]],"tensor.smooth")) { nmar <- length(object$smooth[[i]]$margin) if (!is.null(object$smooth[[i]]$rind)) { ## terms re-ordered for efficiency, so the same has to be done on indices... rind <- k:(k+dt[kb]-1 - by.present) ## could use object$dinfo$dt[kb] dk$nr[rind] <- dk$nr[k+object$smooth[[i]]$rind-1] ks[rind,] <- ks[k+object$smooth[[i]]$rind-1,] # either this line or next not both ##kd[,rind] <- kd[,k+object$smooth[[i]]$rind-1] } XP <- object$smooth[[i]]$XP for (j in 1:nmar) { smooth[[i]]$margin[[j]]$by<- "NA" ## should be no by's here (any by dealt with above) Xd[[k]] <- PredictMat(smooth[[i]]$margin[[j]],dk$mf,n=dk$nr[k]) if (!is.null(XP)&&(j<=length(XP))&&!is.null(XP[[j]])) Xd[[k]] <- Xd[[k]]%*%XP[[j]] k <- k + 1 } } else { ## not a tensor smooth object$smooth[[i]]$by <- "NA" ## have to ensure by not applied here (it's dealt with as a tensor marginal)! Xd[[k]] <- PredictMat(object$smooth[[i]],dk$mf,n=dk$nr[k]) k <- k + 1 } kb <- kb + 1 } attr(Xd,"lpip") <- object$dinfo$lpip ## list of coef indices for each term ## end of discrete set up se <- se.fit if (type=="terms") { term.lab <- unlist(lapply(object$smooth,function(x) x$label)) termi <- rep(TRUE,length(object$smooth)) if (!is.null(terms)) termi <- termi & term.lab %in% terms if (!is.null(exclude)) termi <- termi & !(term.lab %in% exclude) if (any(object$nsdf>0)) { if (se) { fit <- cbind(pp$fit,matrix(0,nrow(kd),sum(termi))) se.fit <- cbind(pp$se.fit,matrix(0,nrow(kd),sum(termi))) } else fit <- cbind(pp,matrix(0,nrow(kd),sum(termi))) #k <- 2; ## starting Xd kk <- ncol(fit) - sum(termi) + 1 ## starting col of fit for smooth terms } else { if (se) { fit <- matrix(0,nrow(kd),sum(termi)) se.fit <- matrix(0,nrow(kd),sum(termi)) } else fit <- matrix(0,nrow(kd),sum(termi)) #k <- 1; ## starting Xd kk <- 1 ## starting col of fit for smooth terms } k <- min(which(!is.na(dk$nr))) ## starting Xd n.smooth <- length(object$smooth) if (n.smooth) for (i in 1:n.smooth) { ilab <- object$smooth[[i]]$label if (termi[i]) { ii <- ts[k]:(ts[k]+dt[k]-1) ## index components for this term ind <- object$smooth[[i]]$first.para:object$smooth[[i]]$last.para ## index coefs for this term if (!is.null(object$dinfo$drop)) { drop <- object$dinfo$drop-object$smooth[[i]]$first.para+1 drop <- drop[drop<=length(ii)] } else drop <- NULL fit[,kk] <- Xbd(Xd[ii],object$coefficients[ind],kd,ks[ii,], ##kd[,ii,drop=FALSE] 1,dt[k],object$dinfo$v[k],object$dinfo$qc[k],drop=drop) if (se) se.fit[,kk] <- diagXVXd(Xd[ii],object$Vp[ind,ind],kd,ks[ii,], #kd[,ii,drop=FALSE], 1,dt[k],object$dinfo$v[k],object$dinfo$qc[k],drop=drop,nthreads=n.threads)^.5 kk <- kk + 1 } k <- k + 1; } fit.names <- c(if (se) colnames(pp$fit) else colnames(pp), term.lab[termi]) colnames(fit) <- fit.names if (se) { colnames(se.fit) <- fit.names fit <- list(fit=fit,se.fit=se.fit) } } else if (type=="lpmatrix") { fit <- Xbd(Xd,diag(length(object$coefficients)),kd,ks,ts,dt,object$dinfo$v,object$dinfo$qc,drop=object$dinfo$drop) if (nlp>1) attr(fit,"lpi") <- lpi } else { ## link or response if (is.null(object$family$predict)||type=="link") { if (nlp>1) { fit <- matrix(0,nrow(kd),nlp) for (i in 1:nlp) fit[,i] <- Xbd(Xd,object$coefficients,kd,ks,ts,dt,object$dinfo$v,object$dinfo$qc,drop=object$dinfo$drop,lt=lpid[[i]]) + offset[[i]] } else fit <- Xbd(Xd,object$coefficients,kd,ks,ts,dt,object$dinfo$v,object$dinfo$qc,drop=object$dinfo$drop) + offset if (type=="response") { linkinv <- object$family$linkinv dmu.deta <- object$family$mu.eta } else linkinv <- dmu.deta <- NULL if (se==TRUE) { if (nlp>1) { se.fit <- matrix(0,nrow(kd),nlp) for (i in 1:nlp) se.fit[,i] <- diagXVXd(Xd,object$Vp,kd,ks,ts,dt,object$dinfo$v,object$dinfo$qc,drop=object$dinfo$drop, lt=lpid[[i]],rt=lpid[[i]],nthreads=n.threads)^.5 } else se.fit <- diagXVXd(Xd,object$Vp,kd,ks,ts,dt,object$dinfo$v,object$dinfo$qc,drop=object$dinfo$drop,nthreads=n.threads)^.5 if (type=="response") { if (nlp>1) for (i in 1:nlp) { se.fit[,i] <- se.fit[,i] * abs(object$family$linfo[[i]]$mu.eta[fit[,i]]) fit[,i] <- object$family$linfo[[i]]$linkinv[fit[,i]] } else { se.fit <- se.fit * abs(object$family$mu.eta(fit)) fit <- object$family$linkinv(fit) } } fit <- list(fit=fit,se.fit=se.fit) } else if (type=="response") fit <- object$family$linkinv(fit) } else { ## family has its own response fitting code X <- list(Xd=Xd,kd=kd,ks=ks,ts=ts,dt=dt,v=object$dinfo$v,qc=object$dinfo$qc,drop=object$dinfo$drop,lpid=lpid) if (nlp>1) attr(X,"lpi") <- lpi ## NOTE: not set up for families needing response for prediction (e.g. cox.ph) fampred <- object$family$predict ## just eases debugging ffv <- fampred(object$family,se=se,y=NULL,X=X,beta=object$coefficients, off=offset,Vb=object$Vp) ## NOTE: offsets not handled fit <- ffv[[1]] if (se) fit <- list(fit=fit,se.fit =ffv[[2]]) } } rn <- rownames(newdata) if (type=="lpmatrix") { colnames(fit) <- names(object$coefficients) rownames(fit) <- rn attr(fit,"model.offset") <- offset #if (!is.null(attr(attr(object$model,"terms"),"offset"))) { # attr(fit,"model.offset") <- napredict(na.act,offset) #} fit <- napredict(na.act,fit) } else { if (se) { if (is.null(nrow(fit$fit))) { names(fit$fit) <- rn names(fit$se.fit) <- rn fit$fit <- napredict(na.act,fit$fit) fit$se.fit <- napredict(na.act,fit$se.fit) } else { rownames(fit$fit) <- rn rownames(fit$se.fit) <- rn fit$fit <- napredict(na.act,fit$fit) fit$se.fit <- napredict(na.act,fit$se.fit) } } else { if (is.null(nrow(fit))) names(fit) <- rn else rownames(fit) <- rn fit <- napredict(na.act,fit) } } fit } ## end predict.bamd tero <- function(sm) { ## te smooth spec re-order so that largest marginal is last. maxd <- 0 ns <- length(sm$margin) for (i in 1:ns) if (sm$margin[[i]]$bs.dim>=maxd) { maxi <- i;maxd <- sm$margin[[i]]$bs.dim } if (maxi0) { 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 bam <- function(formula,family=gaussian(),data=list(),weights=NULL,subset=NULL,na.action=na.omit, offset=NULL,method="fREML",control=list(),select=FALSE,scale=0,gamma=1,knots=NULL,sp=NULL, min.sp=NULL,paraPen=NULL,chunk.size=10000,rho=0,AR.start=NULL,discrete=FALSE, cluster=NULL,nthreads=1,gc.level=1,use.chol=FALSE,samfrac=1,coef=NULL, drop.unused.levels=TRUE,G=NULL,fit=TRUE,drop.intercept=NULL,...) ## Routine to fit an additive model to a large dataset. The model is stated in the formula, ## which is then interpreted to figure out which bits relate to smooth terms and which to ## parametric terms. ## This is a modification of `gam' designed to build the QR decomposition of the model matrix ## up in chunks, to keep memory costs down. ## If cluster is a parallel package cluster uses parallel QR build on cluster. ## 'n.threads' is number of threads to use for non-cluster computation (e.g. combining ## results from cluster nodes). If 'NA' then is set to max(1,length(cluster)). { control <- do.call("gam.control",control) if (control$trace) t3 <- t2 <- t1 <- t0 <- proc.time() if (length(nthreads)==1) nthreads <- rep(nthreads,2) if (is.null(G)) { ## need to set up model! 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=="gaussian"&&family$link=="identity") am <- TRUE else am <- FALSE if (scale==0) { if (family$family%in%c("poisson","binomial")) scale <- 1 else scale <- -1} if (!method%in%c("fREML","GACV.Cp","GCV.Cp","REML", "ML","P-REML","P-ML")) stop("un-supported smoothness selection method") if (is.logical(discrete)) { discretize <- discrete discrete <- NULL ## use default discretization, if any } else { discretize <- if (is.numeric(discrete)) TRUE else FALSE } if (discretize) { if (method!="fREML") { discretize <- FALSE warning("discretization only available with fREML") } else { if (!is.null(cluster)) warning("discrete method does not use parallel cluster - use nthreads instead") if (all(is.finite(nthreads)) && any(nthreads>1) && !mgcv.omp()) warning("openMP not available: single threaded computation only") } } if (inherits(family,"extended.family")) { family <- fix.family.link(family); efam <- TRUE } else efam <- FALSE if (method%in%c("fREML")&&!is.null(min.sp)) { min.sp <- NULL warning("min.sp not supported with fast REML computation, and ignored.") } gp <- interpret.gam(formula) # interpret the formula if (discretize && length(gp$smooth.spec)==0) { ok <- TRUE ## check it's not a list formula if (!is.null(gp$nlp)) for (i in 1:gp$nlp) if (length(gp[[i]]$smooth.spec)>0) ok <- FALSE if (ok) { warning("no smooths, ignoring `discrete=TRUE'") discretize <- FALSE } } if (discretize) { ## re-order the tensor terms for maximum efficiency, and ## signal that "re"/"fs" terms should be constructed with marginals ## also for efficiency if (is.null(gp$nlp)) for (i in 1:length(gp$smooth.spec)) { if (inherits(gp$smooth.spec[[i]],"tensor.smooth.spec")) gp$smooth.spec[[i]] <- tero(gp$smooth.spec[[i]]) if (inherits(gp$smooth.spec[[i]],c("re.smooth.spec","fs.smooth.spec"))&&gp$smooth.spec[[i]]$dim>1) { class(gp$smooth.spec[[i]]) <- c(class(gp$smooth.spec[[i]]),"tensor.smooth.spec") gp$smooth.spec[[i]]$margin <- list() ## only ok for 'fs' with univariate metric variable (caught in 'fs' construcor)... for (j in 1:gp$smooth.spec[[i]]$dim) gp$smooth.spec[[i]]$margin[[j]] <- list(term=gp$smooth.spec[[i]]$term[j]) } } else for (j in 1:length(formula)) if (length(gp[[j]]$smooth.spec)>0) for (i in 1:length(gp[[j]]$smooth.spec)) { if (inherits(gp[[j]]$smooth.spec[[i]],"tensor.smooth.spec")) gp[[j]]$smooth.spec[[i]] <- tero(gp[[j]]$smooth.spec[[i]]) if (inherits(gp[[j]]$smooth.spec[[i]],c("re.smooth.spec","fs.smooth.spec"))&&gp[[j]]$smooth.spec[[i]]$dim>1) { class(gp[[j]]$smooth.spec[[i]]) <- c(class(gp[[j]]$smooth.spec[[i]]),"tensor.smooth.spec") gp[[j]]$smooth.spec[[i]]$margin <- list() ## only ok for 'fs' with univariate metric variable (caught in 'fs' construcor)... for (k in 1:gp[[j]]$smooth.spec[[i]]$dim) gp[[j]]$smooth.spec[[i]]$margin[[k]] <- list(term=gp[[j]]$smooth.spec[[i]]$term[k]) } } } ## if (discretize) cl <- match.call() # call needed in gam object for update to work mf <- match.call(expand.dots=FALSE) mf$formula <- gp$fake.formula mf$method <- mf$family<-mf$control<-mf$scale<-mf$knots<-mf$sp<-mf$min.sp <- mf$gc.level <- mf$gamma <- mf$paraPen<- mf$chunk.size <- mf$rho <- mf$cluster <- mf$discrete <- mf$use.chol <- mf$samfrac <- mf$nthreads <- mf$G <- mf$fit <- mf$select <- mf$drop.intercept <- mf$coef <- mf$...<-NULL mf$drop.unused.levels <- drop.unused.levels mf[[1]] <- quote(stats::model.frame) ## as.name("model.frame") 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) pmf.names <- rep("",0) for (i in 1:length(formula)) { pmf <- mf pmf$formula <- gp[[i]]$pf pmf <- eval(pmf, parent.frame()) pmf.names <- c(pmf.names,names(pmf)) pterms[[i]] <- attr(pmf,"terms") tlabi <- attr(pterms[[i]],"term.labels") if (i>1&&length(tlabi)>0) tlabi <- paste(tlabi,i-1,sep=".") tlab <- c(tlab,tlabi) } pmf.nmes <- unique(pmf.names) attr(pterms,"term.labels") <- tlab ## labels for all parametric terms, distinguished by predictor nlp <- gp$nlp lpid <- list() ## list of terms for each lp lpid[[nlp]] <- rep(0,0) } else { ## single linear predictor case nlp <- 1 pmf <- mf 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 and discretization, if selected. pmf.names <- names(pmf) } if (gc.level>0) gc() 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") if (gc.level>0) gc() if (rho!=0&&!is.null(mf$"(AR.start)")) if (!is.logical(mf$"(AR.start)")) stop("AR.start must be logical") ## summarize the *raw* input variables ## note can't use get_all_vars here -- buggy with matrices vars <- all.vars1(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()) if (!control$keepData) { rm(data);gc()} ## save space names(dl) <- vars ## list of all variables needed var.summary <- variable.summary(gp$pf,dl,nrow(mf)) ## summarize the input data rm(dl); if (gc.level>0) gc() ## save space ## should we force the intercept to be dropped, meaning that the constant is removed ## from the span of the parametric effects? 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 ## need mini.mf for basis setup, then accumulate full X, y, w and offset if (discretize) { ## discretize the data, creating list mf0 with discrete values ## and indices giving the discretized value for each element of model frame. ## 'discrete' can be null, or contain a discretization size, or ## a discretization size per smooth term. dk <- discrete.mf(gp,mf,pmf.names,m=discrete) mf0 <- dk$mf ## padded discretized model frame sparse.cons <- 0 ## default constraints required for tensor terms } else { mf0 <- mini.mf(mf,chunk.size) sparse.cons <- -1 } rm(pmf); ## no further use ## allow bam to set up general families, even if it can not (yet) process them... if (inherits(family,"general.family")&&!is.null(family$presetup)) eval(family$presetup) gsname <- if (is.list(formula)) "gam.setup.list" else "gam.setup" if (control$trace) t1 <- proc.time() reset <- TRUE while (reset) { # G <- gam.setup(gp,pterms=pterms, # data=mf0,knots=knots,sp=sp,min.sp=min.sp, # H=NULL,absorb.cons=TRUE,sparse.cons=sparse.cons,select=select, # idLinksBases=!discretize,scale.penalty=control$scalePenalty, # paraPen=paraPen,apply.by=!discretize,drop.intercept=drop.intercept,modCon=2) G <- do.call(gsname,list(formula=gp,pterms=pterms, data=mf0,knots=knots,sp=sp,min.sp=min.sp, H=NULL,absorb.cons=TRUE,sparse.cons=sparse.cons,select=select, idLinksBases=!discretize,scale.penalty=control$scalePenalty, paraPen=paraPen,apply.by=!discretize,drop.intercept=drop.intercept,modCon=2)) if (!discretize&&ncol(G$X)>=chunk.size) { ## no point having chunk.size < p chunk.size <- 4*ncol(G$X) warning(gettextf("chunk.size < number of coefficients. Reset to %d",chunk.size)) if (chunk.size>=nrow(mf)) { ## no sense splitting up computation mf0 <- mf ## just use full dataset } else reset <- FALSE } else reset <- FALSE } if (control$trace) t2 <- proc.time() if (discretize) { if (nlp>1) lpi <- attr(G$X,"lpi") v <- G$Xd <- list() kb <- k <- 1 G$kd <- dk$k qc <- dt <- ts <- rep(0,length(G$smooth)) ## have to extract full parametric model matrix from pterms and mf npt <- if (nlp==1) 1 else length(G$pterms) lpip <- list() ## record coef indices for each discretized term for (j in 1:npt) { ## loop over parametric terms in each formula G$Xd[[k]] <- if (nlp==1&&!is.list(G$pterms)) model.matrix(G$pterms,mf) else model.matrix(G$pterms[[j]],mf) attr(G$Xd[[k]],"dimnames") <- NULL ## unused and storage space otherwise huge if (drop.intercept[j]) { xat <- attributes(G$Xd[[1]]);ind <- xat$assign > 0 ## index of non intercept columns G$Xd[[k]] <- G$Xd[[k]][,ind,drop=FALSE] ## drop intercept xat$assign <- xat$assign[ind];xat$dimnames[[2]] <- xat$dimnames[[2]][ind]; xat$dim[2] <- xat$dim[2]-1;attributes(G$Xd[[k]]) <- xat } ## create data object suitable for discrete data methods, from marginal model ## matrices in G$smooth and G$X (stripping out padding, of course) if (ncol(G$Xd[[k]])) { G$kd <- cbind(1:nrow(mf),G$kd) ## add index for parametric part to index list dk$k.start <- c(1,dk$k.start+1) ## and adjust k.start accordingly #if (nlp>1) lpid[[j]] <- k lpip[[k]] <- if (nlp==1) 1:G$nsdf else attr(G$nsdf,"pstart")[j] - 1 + 1:G$nsdf[j] ## coefs for this term if (nlp>1) for (i in 1:length(lpi)) if (any(lpip[[k]]%in%lpi[[i]])) lpid[[i]] <- c(lpid[[i]],k) qc <- c(qc,0);dt <- c(dt,0); ts <- c(ts,0) dt[k] <- 1; ts[k] <- k; kb <- kb + 1;k <- k + 1; ## qc <- dt <- ts <- rep(0,length(G$smooth)+1) dk$nr <- c(NA,dk$nr) ## need array index to match elements of Xd } else { ## kb <- k <- 1; leave unchanged ## qc <- dt <- ts <- rep(0,length(G$smooth)) } } ## loop over parametric terms in each formula ## k is marginal counter, kb is block counter ## k[,ks[j,1]:ks[j,2]] gives index columns for term j, thereby allowing ## summation over matrix covariates.... G$ks <- cbind(dk$k.start[-length(dk$k.start)],dk$k.start[-1]) drop <- rep(0,0) ## index of te related columns to drop if (length(G$smooth)>0) for (i in 1:length(G$smooth)) { ## loop over smooths ts[kb] <- k ## first deal with any by variable (as first marginal of tensor)... if (G$smooth[[i]]$by!="NA") { dt[kb] <- 1 by.var <- dk$mf[[G$smooth[[i]]$by]][1:dk$nr[k]] if (is.factor(by.var)) { ## create dummy by variable... by.var <- as.numeric(by.var==G$smooth[[i]]$by.level) } G$Xd[[k]] <- matrix(by.var,dk$nr[k],1) k <- k + 1 by.present <- 1 } else by.present <- dt[kb] <- 0 ## ... by done if (inherits(G$smooth[[i]],"tensor.smooth")) { nmar <- length(G$smooth[[i]]$margin) dt[kb] <- dt[kb] + nmar if (inherits(G$smooth[[i]],"fs.interaction")&&which(G$smooth[[i]]$fterm==G$smooth[[i]]$term)!=1) { ## have to reverse the terms because tensor representation assumes factor is first rind <- 1:length(G$smooth[[i]]$term) k0 <- which(G$smooth[[i]]$fterm==G$smooth[[i]]$term) rind[1] <- k0;rind[k0] <- 1 G$smooth[[i]]$rind <- rind ## (k+1):k } if (!is.null(G$smooth[[i]]$rind)) { ## terms re-ordered for efficiency, so the same has to be done on indices... rind <- k:(k+dt[kb] - 1 - by.present) dk$nr[rind] <- dk$nr[k+G$smooth[[i]]$rind-1] G$ks[rind,] <- G$ks[k+G$smooth[[i]]$rind-1,] # either this line or next not both } for (j in 1:nmar) { G$Xd[[k]] <- G$smooth[[i]]$margin[[j]]$X[1:dk$nr[k],,drop=FALSE] k <- k + 1 } ## deal with any side constraints on tensor terms di <- attr(G$smooth[[i]],"del.index") if (!is.null(di)&&length(di>0)) { di <- di + G$smooth[[i]]$first.para + length(drop) - 1 drop <- c(drop,di) } ## deal with tensor smooth constraint qrc <- attr(G$smooth[[i]],"qrc") ## compute v such that Q = I-vv' and Q[,-1] is constraint null space basis if (inherits(qrc,"qr")) { v[[kb]] <- qrc$qr/sqrt(qrc$qraux);v[[kb]][1] <- sqrt(qrc$qraux) qc[kb] <- 1 ## indicate a constraint } else { v[[kb]] <- rep(0,0) ## if (!inherits(qrc,"character")||qrc!="no constraints") warning("unknown tensor constraint type") } } else { ## not a tensor smooth v[[kb]] <- rep(0,0) dt[kb] <- dt[kb] + 1 G$Xd[[k]] <- G$X[1:dk$nr[k],G$smooth[[i]]$first.para:G$smooth[[i]]$last.para,drop=FALSE] k <- k + 1 } jj <- G$smooth[[i]]$first.para:G$smooth[[i]]$last.para; lpip[[kb]] <- jj if (nlp>1) { ## record which lp each discrete term belongs to (can be more than one) for (j in 1:nlp) if (any(jj %in% lpi[[j]])) lpid[[j]] <- c(lpid[[j]],kb) } kb <- kb + 1 } ## looping over smooths ## put lpid indices into coefficient index order... if (nlp>1) { for (j in 1:nlp) lpid[[j]] <- lpid[[j]][order(unlist(lapply(lpip[lpid[[j]]],max)))] G$lpid <- lpid } if (length(drop>0)) G$drop <- drop ## index of terms to drop as a result of side cons on tensor terms attr(G$Xd,"lpip") <- lpip ## index of coefs by term ## ... Xd is the list of discretized model matrices, or marginal model matrices ## kd contains indexing vectors, so the ith model matrix or margin is Xd[[i]][kd[i,],] ## ts[i] is the starting matrix in Xd for the ith model matrix, while dt[i] is the number ## of elements of Xd that make it up (1 for a singleton, more for a tensor). ## v is list of Householder vectors encoding constraints and qc the constraint indicator. G$v <- v;G$ts <- ts;G$dt <- dt;G$qc <- qc } ## if (discretize) if (control$trace) t3 <- proc.time() ## no advantage to "fREML" with no free smooths... if (((!is.null(G$L)&&ncol(G$L) < 1)||(length(G$sp)==0))&&method=="fREML") method <- "REML" G$var.summary <- var.summary G$family <- family G$terms<-terms; G$pred.formula <- gp$pred.formula n <- nrow(mf) if (is.null(mf$"(weights)")) G$w<-rep(1,n) else G$w<-mf$"(weights)" G$y <- mf[[gp$response]] ## now get offset, dealing with possibility of multiple predictors (see gam.setup) ## the point is that G$offset relates to the compressed or discretized model frame, ## so we need to correct it to the full data version... if (discretize) { if (is.list(pterms)) { ## multiple predictors for (i in 1:length(pterms)) { offi <- attr(pterms[[i]],"offset") if (is.null(offi)) G$offset[[i]] <- rep(0,n) else { G$offset[[i]] <- mf[[names(attr(pterms[[i]],"dataClasses"))[offi]]] if (is.null(G$offset[[i]])) G$offset[[i]] <- rep(0,n) } } } else { ## single predictor, handle as non-discrete G$offset <- model.offset(mf) if (is.null(G$offset)) G$offset <- rep(0,n) } } else { ## non-discrete G$offset <- model.offset(mf) if (is.null(G$offset)) G$offset <- rep(0,n) } if (!discretize && ncol(G$X)>nrow(mf)) stop("Model has more coefficients than data") if (ncol(G$X) > chunk.size && !discretize) { ## no sense having chunk.size < p chunk.size <- 4*ncol(G$X) warning(gettextf("chunk.size < number of coefficients. Reset to %d",chunk.size)) } G$cl <- cl G$am <- am 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$discretize <- discretize G$formula<-formula ## environment(G$formula)<-environment(formula) environment(G$pterms) <- environment(G$terms) <- environment(G$pred.formula) <- environment(G$formula) <- .BaseNamespaceEnv } else { ## G supplied if (scale<=0) scale <- G$scale efam <- G$efam mf <- G$mf; G$mf <- NULL gp <- G$gp; G$gp <- NULL na.action <- G$na.action; G$na.action <- NULL if (!is.null(sp)&&any(sp>=0)) { ## request to modify smoothing parameters if (is.null(G$L)) G$L <- diag(length(G$sp)) if (length(sp)!=ncol(G$L)) stop('length of sp must be number of free smoothing parameters in original model') ind <- sp>=0 ## which smoothing parameters are now fixed spind <- log(sp[ind]); spind[!is.finite(spind)] <- -30 ## set any zero parameters to effective zero G$lsp0 <- G$lsp0 + drop(G$L[,ind,drop=FALSE] %*% spind) ## add fix to lsp0 G$L <- G$L[,!ind,drop=FALSE] ## drop the cols of G G$sp <- rep(-1,ncol(G$L)) } } ## end of G setup if (!fit) { G$efam <- efam G$scale <- scale G$mf <- mf;G$na.action <- na.action;G$gp <- gp class(G) <- "bam.prefit" return(G) } if (inherits(G$family,"general.family")) stop("general families not supported by bam") ## number of threads to use for non-cluster node computation if (!is.finite(nthreads[1])||nthreads[1]<1) nthreads[1] <- max(1,length(cluster)) G$conv.tol<-control$mgcv.tol # tolerence for mgcv G$max.half<-control$mgcv.half # max step halving in bfgs optimization ## now build up proper model matrix, and deal with y, w, and offset... if (control$trace) cat("Setup complete. Calling fit\n") colnamesX <- colnames(G$X) if (G$am&&!G$discretize) { if (nrow(mf)>chunk.size) G$X <- matrix(0,0,ncol(G$X)); if (gc.level>1) gc() object <- bam.fit(G,mf,chunk.size,gp,scale,gamma,method,rho=rho,cl=cluster, gc.level=gc.level,use.chol=use.chol,npt=nthreads[1]) } else if (G$discretize) { object <- bgam.fitd(G, mf, gp ,scale ,nobs.extra=0,rho=rho,coef=coef, control = control,npt=nthreads,gc.level=gc.level,gamma=gamma,...) } else { G$X <- matrix(0,0,ncol(G$X)); if (gc.level>1) gc() if (rho!=0) warning("AR1 parameter rho unused with generalized model") if (samfrac<1 && samfrac>0) { ## sub-sample first to get close to right answer... ind <- sample(1:nrow(mf),ceiling(nrow(mf)*samfrac)) if (length(ind)<2*ncol(G$X)) warning("samfrac too small - ignored") else { Gw <- G$w;Goffset <- G$offset G$w <- G$w[ind];G$offset <- G$offset[ind] control1 <- control control1$epsilon <- 1e-2 object <- bgam.fit(G, mf[ind,], chunk.size, gp ,scale ,gamma,method=method,nobs.extra=0, control = control1,cl=cluster,npt=nthreads[1],gc.level=gc.level,coef=coef, use.chol=use.chol,samfrac=1,...) G$w <- Gw;G$offset <- Goffset coef <- object$coefficients } } ## fit full dataset object <- bgam.fit(G, mf, chunk.size, gp ,scale ,gamma,method=method,coef=coef, control = control,cl=cluster,npt=nthreads[1],gc.level=gc.level, use.chol=use.chol,...) } if (gc.level>0) gc() if (control$trace) t4 <- proc.time() if (control$trace) cat("Fit complete. Finishing gam object.\n") if (scale < 0) { object$scale.estimated <- TRUE;object$scale <- object$scale.est} else { object$scale.estimated <- FALSE; object$scale <- scale } object$assign <- G$assign # applies only to pterms object$boundary <- FALSE # always FALSE for this case object$call<-G$cl # needed for update() to work object$cmX <- G$cmX ## column means of model matrix --- useful for CIs object$contrasts <- G$contrasts object$control <- control object$converged <- TRUE ## no iteration object$data <- NA ## not saving it in this case object$df.null <- nrow(mf) object$df.residual <- object$df.null - sum(object$edf) if (is.null(object$family)) object$family <- family object$formula <- G$formula if (method=="GCV.Cp") { if (scale<=0) object$method <- "GCV" else object$method <- "UBRE" } else { object$method <- method } object$min.edf<-G$min.edf object$model <- mf;rm(mf);if (gc.level>0) gc() object$na.action <- attr(object$model,"na.action") # how to deal with NA's object$nsdf <- G$nsdf if (G$nsdf>0) names(object$coefficients)[1:G$nsdf] <- colnamesX[1:G$nsdf] object$offset <- G$offset ##object$prior.weights <- G$w object$pterms <- G$pterms object$pred.formula <- G$pred.formula object$smooth <- G$smooth object$terms <- G$terms object$var.summary <- G$var.summary if (is.null(object$wt)) object$weights <- object$prior.weights else object$weights <- object$wt object$xlevels <- G$xlevels #object$y <- object$model[[gp$response]] object$NA.action <- na.action ## version to use in bam.update names(object$sp) <- names(G$sp) if (!is.null(object$full.sp)) names(object$full.sp) <- names(G$lsp0) names(object$coefficients) <- G$term.names names(object$edf) <- G$term.names ## note that predict.gam assumes that it must be ok not to split the ## model frame, if no new data supplied, so need to supply explicitly class(object) <- c("bam","gam","glm","lm") if (!G$discretize) { object$linear.predictors <- as.numeric(predict.bam(object,newdata=object$model,block.size=chunk.size,cluster=cluster)) } else { ## store discretization specific information to help with discrete prediction object$dinfo <- list(gp=gp, v = G$v, ts = G$ts, dt = G$dt, qc = G$qc, drop = G$drop) } rm(G);if (gc.level>0) gc() if (is.null(object$fitted.values)) object$fitted.values <- family$linkinv(object$linear.predictors) object$residuals <- if (is.null(family$residuals)) sqrt(family$dev.resids(object$y,object$fitted.values,object$prior.weights)) * sign(object$y-object$fitted.values) else residuals(object) if (rho!=0) object$std.rsd <- AR.resid(object$residuals,rho,object$model$"(AR.start)") if (!efam || is.null(object$deviance)) object$deviance <- sum(object$residuals^2) dev <- object$deviance if (rho!=0&&family$family=="gaussian") dev <- sum(object$std.rsd^2) object$aic <- if (efam) family$aic(object$y,object$fitted.values,family$getTheta(),object$prior.weights,dev) else family$aic(object$y,1,object$fitted.values,object$prior.weights,dev) object$aic <- object$aic - 2 * (length(object$y) - sum(sum(object$model[["(AR.start)"]])))*log(1/sqrt(1-rho^2)) + ## correction for AR 2*sum(object$edf) if (!is.null(object$edf2)&&sum(object$edf2)>sum(object$edf1)) object$edf2 <- object$edf1 if (is.null(object$null.deviance)) object$null.deviance <- sum(family$dev.resids(object$y,weighted.mean(object$y,object$prior.weights),object$prior.weights)) if (!is.null(object$full.sp)) { if (length(object$full.sp)==length(object$sp)&& all.equal(object$sp,object$full.sp)==TRUE) object$full.sp <- NULL } environment(object$formula) <- environment(object$pred.formula) <- environment(object$terms) <- environment(object$pterms) <- environment(attr(object$model,"terms")) <- .GlobalEnv if (control$trace) { t5 <- proc.time() t5 <- rbind(t1-t0,t2-t1,t3-t2,t4-t3,t5-t4)[,1:3] row.names(t5) <- c("initial","gam.setup","pre-fit","fit","finalise") print(t5) } names(object$gcv.ubre) <- method object } ## end of bam bam.update <- function(b,data,chunk.size=10000) { ## update the strictly additive model `b' in the light of new data in `data' ## Need to update modelframe (b$model) if (is.null(b$qrx)) { stop("Model can not be updated") } gp<-interpret.gam(b$formula) # interpret the formula ## next 2 lines problematic if there are missings in the response, so now constructed from mf below... ## X <- predict(b,newdata=data,type="lpmatrix",na.action=b$NA.action) ## extra part of model matrix ## rownames(X) <- NULL cnames <- names(b$coefficients) AR.start <- NULL ## keep R checks happy ## now get the new data in model frame form... getw <- "(weights)"%in%names(b$model) getARs <- "(AR.start)"%in%names(b$model) if (getw&&getARs) { mf <- model.frame(gp$fake.formula,data,weights=weights,AR.start=AR.start, xlev=b$xlev,na.action=b$NA.action) w <- mf[["(weights)"]] } else if (getw) { mf <- model.frame(gp$fake.formula,data,weights=weights,xlev=b$xlev,na.action=b$NA.action) w <- mf[["(weights)"]] } else if (getARs) { mf <- model.frame(gp$fake.formula,data,AR.start=AR.start,xlev=b$xlev,na.action=b$NA.action) w <- rep(1,nrow(mf)) } else { mf <- model.frame(gp$fake.formula,data,xlev=b$xlev,na.action=b$NA.action) w <- rep(1,nrow(mf)) } X <- predict(b,newdata=mf,type="lpmatrix",na.action=b$NA.action) ## extra part of model matrix rownames(X) <- NULL b$model <- rbind(b$model,mf) ## complete model frame --- old + new ## get response and offset... off.col <- attr(attr(b$model,"terms"),"offset") if (is.null(off.col)) offset <- rep(0,nrow(mf)) else offset <- mf[,off.col] y <- mf[,attr(attr(b$model,"terms"),"response")] - offset ## update G b$G$y <- c(b$G$y,y) b$G$offset <- c(b$G$offset,offset) b$G$w <- c(b$G$w,w) b$G$n <- nrow(b$model) n <- b$G$n; ## update the qr decomposition... w <- sqrt(w) if (b$AR1.rho!=0) { ## original model had AR1 error structure... rho <- b$AR1.rho ld <- 1/sqrt(1-rho^2) ## leading diagonal of root inverse correlation sd <- -rho*ld ## sub diagonal ## append the final row of weighted X and y from original fit, first wy <- c(b$yX.last[1],w*y) wX <- rbind(b$yX.last[-1],w*X) m <- nrow(wX) b$yX.last <- c(wy[m],wX[m,]) row <- c(1,rep(1:m,rep(2,m))[-c(1,2*m)]) weight <- c(1,rep(c(sd,ld),m-1)) stop <- c(1,1:(m-1)*2+1) if (!is.null(mf$"(AR.start)")) { ## need to correct the start of new AR sections... ii <- which(mf$"(AR.start)"==TRUE) if (length(ii)>0) { if (ii[1]==1) ii <- ii[-1] ## first observation does not need any correction weight[ii*2-2] <- 0 ## zero sub diagonal weight[ii*2-1] <- 1 ## set leading diagonal to 1 } } ## re-weight to independence.... wX <- rwMatrix(stop,row,weight,wX)[-1,] wy <- rwMatrix(stop,row,weight,wy)[-1] ## update b$qrx <- qr.update(wX,wy,b$qrx$R,b$qrx$f,b$qrx$y.norm2) } else { b$qrx <- qr.update(w*X,w*y,b$qrx$R,b$qrx$f,b$qrx$y.norm2) } ## now do the refit... rss.extra <- b$qrx$y.norm2 - sum(b$qrx$f^2) if (b$method=="GCV"||b$method=="UBRE") method <- "GCV.Cp" else method <- b$method if (method=="GCV.Cp") { if (b$method=="GCV") scale <- -1 else scale = b$sig2 fit <- magic(b$qrx$f,b$qrx$R,b$sp,b$G$S,b$G$off,L=b$G$L,lsp0=b$G$lsp0,rank=b$G$rank, H=b$G$H,C= matrix(0,0,ncol(b$qrx$R)),##C=b$G$C, gamma=b$gamma,scale=scale,gcv=(scale<=0), extra.rss=rss.extra,n.score=n) post <- magic.post.proc(b$qrx$R,fit,b$qrx$f*0+1) b$y <- b$G$y;b$offset <- b$G$offset; b$G$w -> b$weights -> b$prior.weights; } else if (method=="fREML") { ## fast REML um <- Sl.Xprep(b$Sl,b$qrx$R) lsp0 <- log(b$sp) ## initial s.p. log.phi <- log(b$sig2) ## initial or fixed scale fit <- fast.REML.fit(um$Sl,um$X,b$qrx$f,rho=lsp0,L=b$G$L,rho.0=b$G$lsp0, log.phi=log.phi,phi.fixed = !b$scale.estimated,rss.extra=rss.extra, nobs =n,Mp=um$Mp,nt=1,gamma=b$gamma) if (b$scale.estimated) scale <- -1 else scale=b$sig2 res <- Sl.postproc(b$Sl,fit,um$undrop,b$qrx$R,cov=TRUE,scale=scale,L=b$g$L) object <- list(coefficients=res$beta,edf=res$edf,edf1=res$edf1,edf2=res$edf2,##F=res$F, gcv.ubre=fit$reml,hat=res$hat,outer.info=list(iter=fit$iter, message=fit$conv),optimizer="fast-REML",rank=ncol(um$X), Ve=res$Ve,Vp=res$Vp,Vc=res$Vc,db.drho=fit$d1b,scale.estimated = scale<=0) if (scale<=0) { ## get sp's and scale estimate nsp <- length(fit$rho) object$sig2 <- object$scale <- exp(fit$rho[nsp]) object$sp <- exp(fit$rho[-nsp]) nsp <- length(fit$rho.full) object$full.sp <- exp(fit$rho.full[-nsp]) } else { ## get sp's object$sig2 <- object$scale <- scale object$sp <- exp(fit$rho) object$full.sp <- exp(fit$rho.full) } if (b$AR1.rho!=0) { ## correct RE/ML score for AR1 transform df <- if (getARs) sum(b$model$"(AR.start)") else 1 object$gcv.ubre <- object$gcv.ubre - (n-df)*log(ld) } b$G$X <- b$qrx$R;b$G$dev.extra <- rss.extra b$G$pearson.extra <- rss.extra;b$G$n.true <- n b$y <- b$G$y;b$offset <- b$G$offset; b$G$w -> b$weights -> b$prior.weights; } else { ## method is "REML" or "ML" y <- b$G$y; w <- b$G$w;offset <- b$G$offset b$G$y <- b$qrx$f b$G$w <- b$G$y*0+1 b$G$X <- b$qrx$R b$G$n <- length(b$G$y) b$G$offset <- b$G$y*0 b$G$dev.extra <- rss.extra b$G$pearson.extra <- rss.extra b$G$n.true <- n if (b$scale.estimated) scale <- -1 else scale = b$sig2 in.out <- list(sp=b$sp,scale=b$reml.scale) object <- gam(G=b$G,method=method,gamma=b$gamma,scale=scale,in.out=in.out) if (b$AR1.rho!=0) { ## correct RE/ML score for AR1 transform df <- if (getARs) sum(b$model$"(AR.start)") else 1 object$gcv.ubre <- object$gcv.ubre - (n-df)*log(ld) } offset -> b$G$offset -> b$offset w -> b$G$w -> b$weights -> b$prior.weights; n -> b$G$n y -> b$G$y -> b$y; } if (method=="GCV.Cp") { b$coefficients <- fit$b b$edf <- post$edf b$edf1 <- post$edf1 ##b$F <- post$F b$full.sp <- fit$sp.full b$gcv.ubre <- fit$score b$hat <- post$hat b$mgcv.conv <- fit$gcv.info b$optimizer="magic" b$rank <- fit$gcv.info$rank b$Ve <- post$Ve b$Vp <- post$Vb b$sig2 <- b$scale <- fit$scale b$sp <- fit$sp } else { ## REML or ML b$coefficients <- object$coefficients b$edf <- object$edf b$edf1 <- object$edf1 ##b$F <- object$F b$full.sp <- object$sp.full b$gcv.ubre <- object$gcv.ubre b$hat <- object$hat b$outer.info <- object$outer.info b$rank <- object$rank b$Ve <- object$Ve b$Vp <- object$Vp b$sig2 <- b$scale <- object$sig2 b$sp <- object$sp if (b$AR1.rho!=0) { ## correct RE/ML score for AR1 transform b$gcv.ubre <- b$gcv.ubre - (n-1)*log(ld) } } b$R <- b$qrx$R b$G$X <- NULL b$linear.predictors <- as.numeric(predict.gam(b,newdata=b$model,block.size=chunk.size)) b$fitted.values <- b$linear.predictor ## strictly additive only! b$residuals <- sqrt(b$family$dev.resids(b$y,b$fitted.values,b$prior.weights)) * sign(b$y-b$fitted.values) b$deviance <- sum(b$residuals^2) b$aic <- b$family$aic(b$y,1,b$fitted.values,b$prior.weights,b$deviance) + 2 * sum(b$edf) if (b$AR1.rho!=0) { ## correct aic for AR1 transform df <- if (getARs) sum(b$model$"(AR.start)") else 1 b$aic <- b$aic + 2*(n-df)*log(ld) } b$null.deviance <- sum(b$family$dev.resids(b$y,mean(b$y),b$prior.weights)) names(b$coefficients) <- names(b$edf) <- cnames b } ## end of bam.update #### ISSUES: ## ? negative binomial support --- docs say it's there... ## offset unused in bam/bgam.fit, also gp only needed for "response", ## so could efficiently be replaced mgcv/R/jagam.r0000644000176200001440000004322113073161527012660 0ustar liggesusers## (c) Simon Wood 2014. Released under GPL2. ## jagam code (Just Another Gibbs Additive Model) ## Code offering JAGS/BUGS support for mgcv. ## In particular autogenerates the code and data to fit an mgcv ## style GAM in JAGS, and re-packages the simulation output ## in a form suitable for plotting and prediction. ## Idea is that the code would be modified to add the sort ## of random effects structure most appropriately handled in JAGS. write.jagslp <- function(resp,family,file,use.weights,offset=FALSE) { ## write the JAGS code for the linear predictor ## and response distribution. iltab <- ## table of inverse link functions c("eta[i]","exp(eta[i])","ilogit(eta[i])","phi(eta[i])","1/eta[i]","eta[i]^2") names(iltab) <- c("identity","log","logit","probit","inverse","sqrt") if (!family$link%in%names(iltab)) stop("sorry link not yet handled") ## code linear predictor and expected response... if (family$link=="identity") { if (offset) cat(" mu <- X %*% b + offset ## expected response\n",file=file,append=TRUE) else cat(" mu <- X %*% b ## expected response\n",file=file,append=TRUE) } else { if (offset) cat(" eta <- X %*% b + offset ## linear predictor\n",file=file,append=TRUE) else cat(" eta <- X %*% b ## linear predictor\n",file=file,append=TRUE) cat(" for (i in 1:n) { mu[i] <- ",iltab[family$link],"} ## expected response\n",file=file,append=TRUE) } ## code the response given mu and any scale parameter prior... #scale <- TRUE ## is scale parameter free? cat(" for (i in 1:n) { ",file=file,append=TRUE) if (family$family=="gaussian") { if (use.weights) cat(resp,"[i] ~ dnorm(mu[i],tau*w[i]) } ## response \n",sep="",file=file,append=TRUE) else cat(resp,"[i] ~ dnorm(mu[i],tau) } ## response \n",sep="",file=file,append=TRUE) cat(" scale <- 1/tau ## convert tau to standard GLM scale\n",file=file,append=TRUE) cat(" tau ~ dgamma(.05,.005) ## precision parameter prior \n",file=file,append=TRUE) } else if (family$family=="poisson") { # scale <- FALSE cat(resp,"[i] ~ dpois(mu[i]) } ## response \n",sep="",file=file,append=TRUE) if (use.weights) warning("weights ignored") use.weights <- FALSE } else if (family$family=="binomial") { # scale <- FALSE cat(resp,"[i] ~ dbin(mu[i],w[i]) } ## response \n",sep="",file=file,append=TRUE) use.weights <- TRUE } else if (family$family=="Gamma") { if (use.weights) cat(resp,"[i] ~ dgamma(r*w[i],r*w[i]/mu[i]) } ## response \n",sep="",file=file,append=TRUE) else cat(resp,"[i] ~ dgamma(r,r/mu[i]) } ## response \n",sep="",file=file,append=TRUE) cat(" r ~ dgamma(.05,.005) ## scale parameter prior \n",file=file,append=TRUE) cat(" scale <- 1/r ## convert r to standard GLM scale\n",file=file,append=TRUE) } else stop("family not implemented yet") use.weights } ## write.jagslp jini <- function(G,lambda) { ## get initial coefficients to initialize JAGS, otherwise ## initialization is hit and miss. y <- G$y; nobs <- length(y); p <- ncol(G$X) family <- G$family weights <- G$w start <- mustart <- etastart <- NULL ## ignore codetools warning - needed for eval eval(G$family$initialize) w <- as.numeric(G$w * family$mu.eta(family$linkfun(mustart))^2/family$variance(mustart)) w <- sqrt(w) z <- c(w*family$linkfun(mustart),rep(0,p)) ## residual is zero, so eta is all there is! X <- rbind(w*G$X,matrix(0,p,p)) ## now append square roots of penalties uoff <- unique(G$off) for (i in 1:length(uoff)) { jj <- which(G$off%in%uoff[i]) S <- G$S[[jj[1]]]*lambda[[jj[1]]] m <- length(jj) if (m>1) for (j in jj) S <- S + G$S[[j]]*lambda[j] S <- t(mroot(S)) jj <- nrow(S) X[(nobs+1):(nobs+jj),uoff[i]:(uoff[i]+ncol(S)-1)] <- S nobs <- nobs + jj } ## we need some idea of initial coeffs and some idea of ## associated standard error... qrx <- qr(X,LAPACK=TRUE) rp <- qrx$pivot;rp[rp] <- 1:ncol(X) Ri <- backsolve(qr.R(qrx),diag(1,nrow=ncol(X)))[rp,] beta <- qr.coef(qrx,z) se <- sqrt(rowSums(Ri^2))*sqrt(sum((z-X%*%beta)^2)/nrow(X)) list(beta=beta,se=se) } ## jini jagam <- function(formula,family=gaussian,data=list(),file,weights=NULL,na.action, offset=NULL,knots=NULL,sp=NULL,drop.unused.levels=TRUE,control=gam.control(),centred=TRUE, sp.prior = "gamma",diagonalize=FALSE) { ## rho contains log smoothing params and b the model coefficients, in JAGS ## diagonalize==TRUE actually seems to be faster for high dimensional terms ## in the Gaussian setting (Conjugate updates better than MH), otherwise ## diagonalize==FALSE faster as block MH is highly advantageous ## WARNING: centred=FALSE is usually a very bad idea!! if (is.null(file)) stop("jagam requires a file for the JAGS model specification") cat("model {\n",file=file) ## start the model specification if (!(sp.prior %in% c("gamma","log.uniform"))) { warning("smoothing parameter prior choise not recognised, reset to gamma") } ## takes GAM formula and data and produces JAGS model and corresponding ## data list... if (is.character(family)) family <- eval(parse(text = family)) if (is.function(family)) family <- family() if (is.null(family$family)) stop("family not recognized") 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$knots <- mf$sp <- mf$file <- mf$control <- mf$centred <- mf$sp.prior <- mf$diagonalize <- NULL mf$drop.unused.levels <- drop.unused.levels mf[[1]] <- quote(stats::model.frame) ##as.name("model.frame") pmf <- mf 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 rm(pmf) 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 <- all.vars(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()) if (!control$keepData) { rm(data)} ## save space names(dl) <- vars ## list of all variables needed var.summary <- variable.summary(gp$pf,dl,nrow(mf)) ## summarize the input data rm(dl) G <- gam.setup(gp,pterms=pterms, data=mf,knots=knots,sp=sp, H=NULL,absorb.cons=centred,sparse.cons=FALSE,select=TRUE, idLinksBases=TRUE,scale.penalty=control$scalePenalty, diagonal.penalty=diagonalize) G$model <- mf;G$terms <- terms;G$family <- family;G$call <- cl G$var.summary <- var.summary ## write JAGS code producing linear predictor and linking linear predictor to ## response.... use.weights <- if (is.null(weights)) FALSE else TRUE use.weights <- write.jagslp("y",family,file,use.weights,!is.null(G$offset)) if (is.null(weights)&&use.weights) weights <- rep(1,nrow(G$X)) ## start the JAGS data list... jags.stuff <- list(y=G$y,n=length(G$y),X=G$X) if (!is.null(G$offset)) jags.stuff$offset <- G$offset if (use.weights) jags.stuff$w <- weights if (family$family == "binomial") jags.stuff$y <- G$y*weights ## JAGS not expecting observed prob!! ## get initial values, for use by JAGS, and to guess suitable values for ## uninformative priors... lambda <- initial.spg(G$X,G$y,G$w,family,G$S,G$rank,G$off,offset=G$offset,L=G$L) ## initial sp values jags.ini <- list() lam <- if (is.null(G$L)) lambda else G$L%*%lambda jin <- jini(G,lam) jags.ini$b <- jin$beta prior.tau <- signif(0.01/(abs(jin$beta) + jin$se)^2,2) ## set the fixed effect priors... if (G$nsdf>0) { ptau <- min(prior.tau[1:G$nsdf]) cat(" ## Parametric effect priors CHECK tau=1/",signif(1/sqrt(ptau),2),"^2 is appropriate!\n",file=file,append=TRUE,sep="") cat(" for (i in 1:",G$nsdf,") { b[i] ~ dnorm(0,",ptau,") }\n",file=file,append=TRUE,sep="") } ## Work through smooths. ## In JAGS terms the penalties should simply define priors. ## Any unpenalized term should be given a diffuse prior. ## For diagonalized terms these should be written directly into the code ## and there is nothing to pass to JAGS. ## For overlapping multi term penalties, a null space penalty needs to ## be added and the components of the penalty have to be passed into ## JAGS in the argument list: cbinding the components into one matrix seems sensible. ## Smoothing parameters should be in a single vector in the code indexed by ## number. n.sp <- 0 ## count the smoothing parameters.... for (i in 1:length(G$smooth)) { ## Are penalties seperable... seperable <- FALSE M <- length(G$smooth[[i]]$S) p <- G$smooth[[i]]$last.para - G$smooth[[i]]$first.para + 1 ## number of params if (M<=1) seperable <- TRUE else { overlap <- rowSums(G$smooth[[i]]$S[[1]]) for (j in 2:M) overlap <- overlap & rowSums(G$smooth[[i]]$S[[j]]) if (!sum(overlap)) seperable <- TRUE } if (seperable) { ## double check that they are diagonal if (M>0) for (j in 1:M) { if (max(abs(G$smooth[[i]]$S[[j]] - diag(diag(G$smooth[[i]]$S[[j]]),nrow=p)))>0) seperable <- FALSE } } cat(" ## prior for ",G$smooth[[i]]$label,"... \n",file=file,append=TRUE,sep="") if (seperable) { b0 <- G$smooth[[i]]$first.para if (M==0) { cat(" ## Note fixed vague prior, CHECK tau = 1/",signif(1/sqrt(ptau),2),"^2...\n",file=file,append=TRUE,sep="") b1 <- G$smooth[[i]]$last.para ptau <- min(prior.tau[b0:b1]) cat(" for (i in ",b0,":",b1,") { b[i] ~ dnorm(0,",ptau,") }\n",file=file,append=TRUE,sep="") } else for (j in 1:M) { D <- diag(G$smooth[[i]]$S[[j]]) > 0 b1 <- sum(as.numeric(D)) + b0 - 1 n.sp <- n.sp + 1 cat(" for (i in ",b0,":",b1,") { b[i] ~ dnorm(0, lambda[",n.sp,"]) }\n",file=file,append=TRUE,sep="") b0 <- b1 + 1 } } else { ## inseperable - requires the penalty matrices to be supplied to JAGS... b0 <- G$smooth[[i]]$first.para; b1 <- G$smooth[[i]]$last.para Kname <- paste("K",i,sep="") ## total penalty matrix in JAGS Sname <- paste("S",i,sep="") ## components of total penalty in R & JAGS cat(" ",Kname," <- ",Sname,"[1:",p,",1:",p,"] * lambda[",n.sp+1,"] ", file=file,append=TRUE,sep="") if (M>1) { ## code to form total precision matrix... for (j in 2:M) cat(" + ",Sname,"[1:",p,",",(j-1)*p+1,":",j*p,"] * lambda[",n.sp+j,"]", file=file,append=TRUE,sep="") } cat("\n b[",b0,":",b1,"] ~ dmnorm(zero[",b0,":",b1,"],",Kname,") \n" ,file=file,append=TRUE,sep="") n.sp <- n.sp + M Sc <- G$smooth[[i]]$S[[1]] if (M>1) for (j in 2:M) Sc <- cbind(Sc,G$smooth[[i]]$S[[j]]) jags.stuff[[Sname]] <- Sc jags.stuff$zero <- rep(0,ncol(G$X)) } } ## smoothing penalties finished ## Write the smoothing parameter prior code, using L if it exists. cat(" ## smoothing parameter priors CHECK...\n",file=file,append=TRUE,sep="") if (is.null(G$L)) { if (sp.prior=="log.uniform") { cat(" for (i in 1:",n.sp,") {\n",file=file,append=TRUE,sep="") cat(" rho[i] ~ dunif(-12,12)\n",file=file,append=TRUE,sep="") cat(" lambda[i] <- exp(rho[i])\n",file=file,append=TRUE,sep="") cat(" }\n",file=file,append=TRUE,sep="") jags.ini$rho <- log(lambda) } else { ## gamma priors cat(" for (i in 1:",n.sp,") {\n",file=file,append=TRUE,sep="") cat(" lambda[i] ~ dgamma(.05,.005)\n",file=file,append=TRUE,sep="") cat(" rho[i] <- log(lambda[i])\n",file=file,append=TRUE,sep="") cat(" }\n",file=file,append=TRUE,sep="") jags.ini$lambda <- lambda } } else { jags.stuff$L <- G$L rho.lo <- FALSE if (any(G$lsp0!=0)) { jags.stuff$rho.lo <- G$lsp0 rho.lo <- TRUE } nr <- ncol(G$L) if (sp.prior=="log.uniform") { cat(" for (i in 1:",nr,") { rho0[i] ~ dunif(-12,12) }\n",file=file,append=TRUE,sep="") if (rho.lo) cat(" rho <- rho.lo + L %*% rho0\n",file=file,append=TRUE,sep="") else cat(" rho <- L %*% rho0\n",file=file,append=TRUE,sep="") cat(" for (i in 1:",n.sp,") { lambda[i] <- exp(rho[i]) }\n",file=file,append=TRUE,sep="") jags.ini$rho0 <- log(lambda) } else { ## gamma prior cat(" for (i in 1:",nr,") {\n",file=file,append=TRUE,sep="") cat(" lambda0[i] ~ dgamma(.05,.005)\n",file=file,append=TRUE,sep="") cat(" rho0[i] <- log(lambda0[i])\n",file=file,append=TRUE,sep="") cat(" }\n",file=file,append=TRUE,sep="") if (rho.lo) cat(" rho <- rho.lo + L %*% rho0\n",file=file,append=TRUE,sep="") else cat(" rho <- L %*% rho0\n",file=file,append=TRUE,sep="") cat(" for (i in 1:",n.sp,") { lambda[i] <- exp(rho[i]) }\n",file=file,append=TRUE,sep="") jags.ini$lambda0 <- lambda } } cat("}",file=file,append=TRUE) G$formula=formula G$rank=ncol(G$X) ## to Gibbs sample we force full rank! list(pregam=G,jags.data=jags.stuff,jags.ini=jags.ini) } ## jagam sim2jam <- function(sam,pregam,edf.type=2,burnin=0) { ## takes jags simulation output with field, b, containing model coefficients ## and a pregam object from jagam, and attempts to create a fake gam object suitable ## for plotting. This is given a class "jam" since only a limited range of gam ## methods are appropriate for such models. Ideally... ## vcov, print, plot, predict, model.matrix, ... if (is.null(sam$b)) stop("coefficient simulation data is missing") if (burnin>0) { nc <- dim(sam$b)[2] ## chain length if (burnin >= nc*.9) { warning("burnin too large, reset") burnin <- min(nc-1,floor(nc * .9)) } ind <- (burnin+1):nc sam$b <- sam$b[,ind,] if (!is.null(sam$mu)) sam$mu <- sam$mu[,ind,] if (!is.null(sam$rho)) sam$rho <- sam$rho[,ind,] if (!is.null(sam$scale)) sam$scale <- sam$scale[,ind,] } pregam$Vp <- cov(t(sam$b[,,1])) pregam$coefficients <- rowMeans(sam$b[,,1]) pregam$sig2 <- if (is.null(sam$scale)) 1 else mean(sam$scale) n.chain <- dim(sam$b)[3] if (n.chain>1) { for (i in 2:n.chain) { pregam$Vp <- pregam$Vp + cov(t(sam$b[,,i])) pregam$coefficients <- pregam$coefficients + rowMeans(sam$b[,,i]) } pregam$Vp <- pregam$Vp/n.chain pregam$coefficients <- pregam$coefficients/n.chain } ## NOTE: 3 edf versions... ## 0. diag((X'X+S)^{-1}X'X) ## 1. diag((X'WX+S)^-1X'WX) ## 2. diag(VbX'WX)/scale Vb by simulation. mu used for W may also be by sim. if (edf.type<2&&is.null(sam$rho)) { edf.type <- 2 warning("rho missing from simulation data edf.type reset to 2") } if (edf.type > 0) { ## use X'WX not X'X if (is.null(sam$mu)) { eta <- pregam$X %*% pregam$coefficients mu <- pregam$family$linkinv(eta) } else { mu <- rowMeans(sam$mu) eta <- pregam$family$linkfun(mu) } w <- as.numeric(pregam$w * pregam$family$mu.eta(eta)^2/pregam$family$variance(mu)) XWX <- t(pregam$X) %*% (w*pregam$X) } else XWX <- t(pregam$X) %*% (pregam$X) if (edf.type < 2) { ## tr((X'WX + S)^{-1}X'WX rho <- rowMeans(sam$rho);lambda <- exp(rho) XWXS <- XWX for (i in 1:length(lambda)) { ind <- pregam$off[i]:(pregam$off[i]+ncol(pregam$S[[i]])-1) XWXS[ind,ind] <- XWXS[ind,ind] + pregam$S[[i]] * lambda[i] } pregam$edf <- diag(solve(XWXS,XWX)) } else pregam$edf <- rowSums(pregam$Vp*t(XWX))/pregam$sig2 ## tr(Vb%*%XWX)/scale class(pregam) <- "jam" pregam } ## sim2jam ## method functions. Simple wrappers for gam methods ## idea is to limit options to those generally computable... print.jam <- function(x,...) print.gam(x,...) vcov.jam <- function(object,...) vcov.gam(object,...) plot.jam <- function(x,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, shade=FALSE,shade.col="gray80", shift=0,trans=I,seWithMean=FALSE, scheme=0,...) { ## residuals, unconditional, by.resids and all.terms not supported... arg.names <- names(list(...)) if (length(arg.names)>0) { if ("residuals"%in% arg.names) stop("residuals argument not supported") if ("unconditional"%in% arg.names) stop("unconditional argument not meaningful here") if ("by.resids"%in% arg.names) stop("by.resids argument not supported") if ("all.terms"%in% arg.names) stop("all.terms argument not supported") } plot.gam(x,residuals=FALSE,rug=rug,se=se,pages=pages,select=select,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, all.terms=FALSE,shade=shade,shade.col=shade.col, shift=shift,trans=trans,seWithMean=seWithMean, unconditional=FALSE,by.resids=FALSE, scheme=scheme,...) } ## plot.jam predict.jam <- function(object,newdata,type="link",se.fit=FALSE,terms=NULL, block.size=NULL,newdata.guaranteed=FALSE,na.action=na.pass,...) { class(object) <- "gam" ## cheat! arg.names <- names(list(...)) if (length(arg.names)>0) { if ("unconditional"%in% arg.names) warning("unconditional argument not meaningful here") } predict.gam(object,newdata,type=type,se.fit=se.fit,terms=terms, block.size=block.size,newdata.guaranteed=newdata.guaranteed, na.action=na.action,unconditional=FALSE,...) } ## predict.jam mgcv/R/plots.r0000755000176200001440000020212113551271713012741 0ustar liggesusers# R plotting routines for the package mgcv (c) Simon Wood 2000-2017 ## With contributions from Henric Nilsson in.out <- function(bnd,x) { ## tests whether point defined by each row of x is inside ## or outside boundary defined by bnd. bnd my be made up of multiple ## nested loops. if (!is.matrix(x)) x <- matrix(x,1,2) if (is.list(bnd)) { ## convert list of lists to matrix form b1 <- bnd[[1]][[1]] b2 <- bnd[[1]][[2]] if (length(bnd)>1) for (i in 2:length(bnd)) { b1 <- c(b1,NA,bnd[[i]][[1]]) b2 <- c(b2,NA,bnd[[i]][[2]]) } bnd <- cbind(b1,b2) } ## replace NA segment separators with a numeric code lowLim <- min(bnd,na.rm=TRUE) - mean(abs(bnd),na.rm=TRUE) ind <- is.na(rowSums(bnd)) bnd[ind,] <- lowLim n <- nrow(bnd) um <-.C(C_in_out,bx=as.double(bnd[,1]),by=as.double(bnd[,2]),break.code=as.double(lowLim), x=as.double(x[,1]),y=as.double(x[,2]),inside=as.integer(x[,2]*0),nb=as.integer(n), n=as.integer(nrow(x))) as.logical(um$inside) } fix.family.qf <- function(fam) { ## add quantile function to family object if (!inherits(fam, "family")) stop("fam not a family object") if (!is.null(fam$qf)) return(fam) ## already exists family <- fam$family if (family=="poisson") { fam$qf <- function(p,mu,wt,scale) { qpois(p,mu) } } else if (family=="binomial") { fam$qf <- function(p,mu,wt,scale) { if (all.equal(wt,ceiling(wt))!=TRUE) { wt <- ceiling(wt) warning("non-integer binomial denominator: quantiles incorrect") } qbinom(p,wt,mu)/(wt + as.numeric(wt==0)) } } else if (family=="Gamma") { fam$qf <- function(p,mu,wt,scale) { qgamma(p,shape=1/scale,scale=mu*scale) } } else if (family=="gaussian") { fam$qf <- function(p,mu,wt,scale) { qnorm(p,mean=mu,sd=sqrt(scale/wt)) } } fam } fix.family.rd <- function(fam) { ## add random deviate function to family objet if (!inherits(fam, "family")) stop("fam not a family object") if (!is.null(fam$rd)) return(fam) ## already exists family <- fam$family if (family=="poisson") { fam$rd <- function(mu,wt,scale) { rpois(length(mu),mu) } } else if (family=="binomial") { fam$rd <- function(mu,wt,scale) { rbinom(mu,wt,mu)/(wt + as.numeric(wt==0)) } } else if (family=="Gamma") { fam$rd <- function(mu,wt,scale) { rgamma(mu,shape=1/scale,scale=mu*scale) } } else if (family=="gaussian") { fam$rd <- function(mu,wt,scale) { rnorm(mu,mean=mu,sd=sqrt(scale/wt)) } } else if (family=="inverse.gaussian") { fam$rd <- function(mu,wt,scale) { rig(mu,mu,scale) } } fam } qq.gam <- function(object, rep=0, level=.9,s.rep=10, type=c("deviance","pearson","response"), pch=".", rl.col=2, rep.col="gray80",...) { ## get deviance residual quantiles under good fit type <- match.arg(type) ylab <- paste(type,"residuals") if (inherits(object,c("glm","gam"))) { if (is.null(object$sig2)) object$sig2 <- summary(object)$dispersion } else stop("object is not a glm or gam") ## in case of NA & na.action="na.exclude", we need the "short" residuals: object$na.action <- NULL D <- residuals(object,type=type) if (object$method %in% c("PQL","lme.ML","lme.REML","lmer.REML","lmer.ML","glmer.ML")) { ## then it's come out of a gamm fitter and qq.gam can't see the random effects ## that would be necessary to get quantiles. Fall back to normal QQ plot. qqnorm(D,ylab=ylab,pch=pch,...) return() } 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 { ## ix <- sort.int(D,index.return=TRUE)$ix ## messes up under multiple ties! #ix <- rank(D) #U <- (ix-.5)/length(D) ## code used pre-randomization - not needed 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.gam k.check <- function(b,subsample=5000,n.rep=400) { ## function to check k in a gam fit... ## does a randomization test looking for evidence of residual ## pattern attributable to covariates of each smooth. m <- length(b$smooth) if (m==0) return(NULL) rsd <- residuals(b) ve <- rep(0,n.rep) p.val<-v.obs <- kc <- edf<- rep(0,m) snames <- rep("",m) n <- nrow(b$model) if (n>subsample) { ## subsample to avoid excessive cost ind <- sample(1:n,subsample) modf <- b$model[ind,] rsd <- rsd[ind] } else modf <- b$model nr <- length(rsd) for (k in 1:m) { ## work through smooths ok <- TRUE b$smooth[[k]]$by <- "NA" ## can't deal with by variables dat <- ExtractData(b$smooth[[k]],modf,NULL)$data if (!is.null(attr(dat,"index"))||!is.null(attr(dat[[1]],"matrix"))||is.matrix(dat[[1]])) ok <- FALSE if (ok) dat <- as.data.frame(dat) snames[k] <- b$smooth[[k]]$label ind <- b$smooth[[k]]$first.para:b$smooth[[k]]$last.para kc[k] <- length(ind) edf[k] <- sum(b$edf[ind]) nc <- b$smooth[[k]]$dim if (ok && ncol(dat)>nc) dat <- dat[,1:nc,drop=FALSE] ## drop any by variables for (j in 1:nc) if (is.factor(dat[[j]])) ok <- FALSE if (!ok) { p.val[k] <- v.obs[k] <- NA ## can't do this test with summation convention/factors } else { ## normal term if (nc==1) { ## 1-D term e <- diff(rsd[order(dat[,1])]) v.obs[k] <- mean(e^2)/2 for (i in 1:n.rep) { e <- diff(rsd[sample(1:nr,nr)]) ## shuffle ve[i] <- mean(e^2)/2 } p.val[k] <- mean(ve0) cat("\nHessian positive definite, ") else cat("\n") cat("eigenvalue range [",min(ev),",",max(ev),"].\n",sep="") } else { ## just default print of information .. cat("\n");print(b$outer.info) } } else { ## no sp, perf iter or AM case if (length(b$sp)==0) ## no sp's estimated cat("\nModel required no smoothing parameter selection") else { cat("\nSmoothing parameter selection converged after",b$mgcv.conv$iter,"iteration") if (b$mgcv.conv$iter>1) cat("s") if (!b$mgcv.conv$fully.converged) cat(" by steepest\ndescent step failure.\n") else cat(".\n") cat("The RMS",b$method,"score gradient at convergence was",b$mgcv.conv$rms.grad,".\n") if (b$mgcv.conv$hess.pos.def) cat("The Hessian was positive definite.\n") else cat("The Hessian was not positive definite.\n") #cat("The estimated model rank was ",b$mgcv.conv$rank, # " (maximum possible: ",b$mgcv.conv$full.rank,")\n",sep="") } } if (!is.null(b$rank)) { cat("Model rank = ",b$rank,"/",length(b$coefficients),"\n") } } ## if gamm cat("\n") ## now check k kchck <- k.check(b,subsample=k.sample,n.rep=k.rep) if (!is.null(kchck)) { cat("Basis dimension (k) checking results. Low p-value (k-index<1) may\n") cat("indicate that k is too low, especially if edf is close to k\'.\n\n") printCoefmat(kchck,digits=3); } if (is.null(.Platform$GUI) ||.Platform$GUI != "RStudio") par(old.par) ## } else plot(linpred,resid,xlab="linear predictor",ylab="residuals",...) } ## end of gam.check ############################################# ## Start of plot method functions for smooths ############################################# 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,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 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 b <- as.numeric(trans(P$fit+shift)) qqnorm(b,main=P$main,xlab=P$xlab,ylab=P$ylab,...) qqline(b) } ## end of plot production } ## end of plot.random.effect 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 plot.mgcv.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(50), contour.col=4,...) { ## 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' containing the coefs for the smooth, but usually these ## are not needed. ## Usually this function is called twice. First to set up P, then to compute the ## actual plot information including standard error bands, and then to actually ## plot... ## `P' is a list of plot data. ## If `P' is NULL (first call) 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. ## * se.mult - the multiplier of the standard error used to plot confidence bands ## * 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 (second call) it will contain the following... ## * fit - the values for plotting ## * se - standard errors of fit multiplied by se.mult ## * 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)'. ## Note that if ylim is supplied it should not be transformed using trans and shift. ############################# 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>4) 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 if (x$dim==2) { ## 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)) } else { ## basic plot data for 3 or 4 d terms vname <- x$term ## if the smooth has margins and one is 2D then set that as the ## term for 2D plotting, rather than conditioning.... if (!is.null(x$margin)) { for (i in 1:length(x$margin)) if (x$margin[[i]]$dim==2) { vname <- x$margin[[i]]$term ## these are the variables to 2d plot vname <- c(vname,x$term[!x$term%in%vname]) break; } } ## ... so first 2 terms in vname are the vars to plot in 2D. ## Now get the limits for plotting... nv <- length(vname) lo <- hi <- rep(0,nv) for (i in 1:length(vname)) { xx <- data[vname[i]][[1]] lo[i] <- min(xx);hi[i] <- max(xx) } nc <- nr <- n3 ## set number cols and rows of plot m <- n2 ## 2d plotting grid side x1 <- seq(lo[1],hi[1],length=m) x2 <- seq(lo[2],hi[2],length=m) if (nv==3) { x3 <- seq(lo[3],hi[3],length=nr*nc) dat <- cbind(rep(x1,m*nr*nc), rep(rep(x2,each=m*nr),nc), x3[rep(rep((1:nr-1)*nc,each=m),m*nc) + rep(1:nc,each=m*m*nr)]) } else { x3 <- seq(lo[3],hi[3],length=nr) x4 <- seq(lo[4],hi[4],length=nc) dat <- cbind(rep(x1,m*nr*nc), rep(rep(x2,each=m*nr),nc), rep(rep(x3,each=m),m*nc), rep(x4,each=m*m*nr)) } ## 4D term end if (x$by!="NA") { dat <- data.frame(cbind(dat,1)) names(dat) <- c(vname,x$by) } else { dat <- data.frame(dat) names(dat) <- vname } X <- PredictMat(x,dat) ## prediction matrix for this term exclude <- if (too.far<=0) rep(FALSE,nrow(X)) else exclude.too.far(dat[,1],dat[,2],data[vname[1]][[1]],data[vname[2]][[1]],dist=too.far) if (is.null(main)) { main <- label } return(list(X=X,scale=FALSE,se=FALSE,m=m,nc=nc,nr=nr,lo=lo,hi=hi,vname=vname, main=main,exclude=exclude)) } ## end of 3/4 D case } 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 } } ylimit <- if (is.null(ylim)) ylimit <- trans(ylimit + shift) else ylim ## plot the smooth... if (shade) { plot(P$x,trans(P$fit+shift),type="n",xlab=P$xlab,ylim=ylimit, 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=ylimit,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||scheme==3) { if (scheme==3) hcolors <- grey(0:50/50) 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=hcolors,...) contour(P$x,P$y,matrix(trans(P$fit+shift),n2,n2),add=TRUE,col=contour.col,...) 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,...) } } ## contour plot done } else if (x$dim<5) { if (scheme==1) hcolors <- grey(0:50/50) md.plot(P$fit,P$nr,P$nc,P$m,P$vname,P$lo,P$hi,hcolors=hcolors,scheme=scheme,P$main,...) } 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) } ylimit <- if (is.null(ylim)) ylimit <- trans(ylimit + shift) else ylim plot(P$x,trans(P$fit+shift),type="l",xlab=P$xlab, ylab=P$ylab,ylim=ylimit,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||scheme==3) { if (scheme==3) hcolors <- grey(0:50/50) 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=hcolors,...) contour(P$x,P$y,matrix(trans(P$fit+shift),n2,n2),add=TRUE,col=contour.col,...) 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 if (x$dim<5) { if (scheme==1) hcolors <- grey(0:50/50) md.plot(P$fit,P$nr,P$nc,P$m,P$vname,P$lo,P$hi,hcolors=hcolors,scheme=scheme,P$main,...) } else { warning("no automatic plotting for smooths of more than four variables") } } ## end of no CI code } ## end of plot production } ## plot.mgcv.smooth 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 plot.gam <- function(x,residuals=FALSE,rug=NULL,se=TRUE,pages=0,select=NULL,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,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 GAM..... # x is a gam 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 (pers) warning("argument pers is deprecated, please use scheme instead") if (is.null(rug)) rug <- if (nrow(x$model)>10000) FALSE else TRUE 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.gam 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) #P <- plot(x$smooth[[i]],P=NULL,data=x$model,n=n,n2=n2,xlab=xlab,ylab=ylab,too.far=too.far,label=term.lab, # se1.mult=se1.mult,se2.mult=se2.mult,xlim=xlim,ylim=ylim,main=main,scheme=scheme[i],...) 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,n3=n3, 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],...) 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 .... if (is.null(offset)) P$fit <- P$X%*%p else P$fit <- P$X%*%p + offset if (!is.null(P$exclude)) P$fit[P$exclude] <- NA if (se && P$se) { ## get standard errors for fit ## 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))) if (seWithMean==2) x$cmX[-(1:x$nsdf)] <- 0 ## variability of fixed effects mean only 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)) se.fit[P$exclude] <- NA } ## standard errors for fit completed if (partial.resids) { P$p.resid <- fv.terms[,length(order)+i] + w.resid } 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 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.gam() 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()} ##################################### ## 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 ylim <- trans(ylim+shift) } ## end of common scale computation ############################################################## ## now plot smooths, by calling plot methods with plot data... ############################################################## if ((pages==0&&prod(par("mfcol"))1&&dev.interactive()) ask <- TRUE else ask <- FALSE if (!is.null(select)) { ask <- FALSE } # if (ask) { ## asks before plotting # oask <- devAskNewPage(TRUE) # on.exit(devAskNewPage(oask)) # } 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,n3=n3, 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],...) if (ask) { ## this is within loop so we don't get asked before it's necessary oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) ask <- FALSE ## only need to do this once } } ## end of smooth plotting loop #################################################### ## Finally deal with any parametric term plotting... #################################################### if (n.para>0) # plot parameteric terms { class(x) <- c("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.gam exclude.too.far <- function(g1,g2,d1,d2,dist) # if g1 and g2 are the co-ordinates of grid modes and d1,d2 are co-ordinates of data # then this routine returns a vector with TRUE if the grid node is too far from # any data and FALSE otherwise. Too far is judged using dist: a positive number indicating # distance on the unit square into which the grid is scaled prior to calculation { mig<-min(g1) d1<-d1-mig;g1<-g1-mig mag<-max(g1) d1<-d1/mag;g1<-g1/mag mig<-min(g2) d2<-d2-mig;g2<-g2-mig mag<-max(g2) d2<-d2/mag;g2<-g2/mag # all now in unit square n<-length(g1) m<-length(d1) if (length(g2)!=n) stop("grid vectors are different lengths") if (m!=length(d2)) stop("data vectors are of different lengths") if (dist<0) stop("supplied dist negative") distance<-array(0,n) o<-.C(C_MinimumSeparation,x=as.double(cbind(g1,g2)),n=as.integer(n), d=as.integer(2), t=as.double(cbind(d1,d2)),m=as.integer(m),distance=as.double(distance)) res <- rep(FALSE,n) res[o$distance > dist] <-TRUE res } ## exclude.too.far vis.gam <- 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,...) # takes a gam object and plots 2D views of it, supply ticktype="detailed" to get proper axis anotation # (c) Simon N. Wood 23/2/03 { 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(gettextf("view variables must be one of %s", paste(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(gettextf("View variables must contain more than one value. view = c(%s,%s).", view[1], view[2])) # now get the values of the variables which are not the arguments of the plotted surface # 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 newd[[view[1]]]<-v1 newd[[view[2]]]<-v2 # call predict.gam to get predictions..... if (type=="link") zlab<-paste("linear predictor") ## ignore codetools else if (type=="response") zlab<-type else stop("type must be \"link\" or \"response\"") fv <- predict.gam(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<-4;} 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("zlab" %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.") ## ignore codetools 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 { max.z<-max(fv$fit+fv$se.fit*se,na.rm=TRUE) min.z<-min(fv$fit-fv$se.fit*se,na.rm=TRUE) zlim<-c(min.z,max.z) } 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.gam") 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)) } } ## vis.gam mgcv/R/gamlss.r0000644000176200001440000030261013553564750013077 0ustar liggesusers## (c) Simon N. Wood (2013-2019) distributed under GPL2 ## Code for the gamlss families. ## idea is that there are standard functions converting ## derivatives w.r.t. mu to derivatives w.r.t. eta, given ## given the links and derivatives. ## Then there are standard routines to take the family ## specific derivatives and the model matrices, and convert ## these to the required gradient, hessian, etc... ## Storage convections: ## 1. A single model matrix is stored, along with a single param vector. ## an index object associates columns with particular gamlss predictors. ## 2. Distribution specific derivatives are stored in d1l-d4l. ## Need to somehow record block starts... ## idea is that if n blocks are stored using loops with the ## given l >= k >= j >= i structure then the block for index ## i,j,k,l starts at i4[i,j,k,l]*n+1, given symmetry over the indices. trind.generator <- function(K=2) { ## Generates index arrays for 'upper triangular' storage up to order 4 ## Suppose you fill an array using code like... ## m = 1 ## for (i in 1:K) for (j in i:K) for (k in j:K) for (l in k:K) { ## a[,m] <- something; m <- m+1 } ## ... and do this because actually the same 'something' would ## be stored for any permutation of the indices i,j,k,l. ## Clearly in storage we have the restriction l>=k>=j>=i, ## but for access we want no restriction on the indices. ## i4[i,j,k,l] produces the appropriate m for unrestricted ## indices. i3 and i2 do the same for 3d and 2d arrays. ## ixr will extract the unique elements from an x dimensional ## upper triangular array in the correct order. i4 <- array(0,dim=c(K,K,K,K)) m.start <- 1 m <- m.start for (i in 1:K) for (j in i:K) for (k in j:K) for (l in k:K) { i4[i,j,k,l] <- i4[i,j,l,k] <- i4[i,k,l,j] <- i4[i,k,j,l] <- i4[i,l,j,k] <- i4[i,l,k,j] <- i4[j,i,k,l] <- i4[j,i,l,k] <- i4[j,k,l,i] <- i4[j,k,i,l] <- i4[j,l,i,k] <- i4[j,l,k,i] <- i4[k,j,i,l] <- i4[k,j,l,i] <- i4[k,i,l,j] <- i4[k,i,j,l] <- i4[k,l,j,i] <- i4[k,l,i,j] <- i4[l,j,k,i] <- i4[l,j,i,k] <- i4[l,k,i,j] <- i4[l,k,j,i] <- i4[l,i,j,k] <- i4[l,i,k,j] <- m m <- m + 1 } i3 <- array(0,dim=c(K,K,K)) m <- m.start for (j in 1:K) for (k in j:K) for (l in k:K) { i3[j,k,l] <- i3[j,l,k] <- i3[k,l,j] <- i3[k,j,l] <- i3[l,j,k] <- i3[l,k,j] <- m m <- m + 1 } i2 <- array(0,dim=c(K,K)) m <- m.start for (k in 1:K) for (l in k:K) { i2[k,l] <- i2[l,k] <- m m <- m + 1 } ## now create the reverse indices... m <- m.start i4r <- rep(0,max(i4)) ## extracts the unique elements from a symmetric array in packing order. for (i in 1:K) for (j in i:K) for (k in j:K) for (l in k:K) { i4r[m] <- l + (k-1)*K + (j-1)*K^2 + (i-1)*K^3 m <- m + 1 } m <- m.start i3r <- rep(0,max(i3)) ## extracts the unique elements from a symmetric array in packing order. for (j in 1:K) for (k in j:K) for (l in k:K) { i3r[m] <- l + (k-1)*K + (j-1)*K^2 m <- m + 1 } m <- m.start i2r <- rep(0,max(i2)) ## extracts the unique elements from a symmetric array in packing order. for (k in 1:K) for (l in k:K) { i2r[m] <- l + (k-1)*K m <- m + 1 } list(i2=i2,i3=i3,i4=i4,i2r=i2r,i3r=i3r,i4r=i4r) } ## trind.generator gamlss.etamu <- function(l1,l2,l3=NULL,l4=NULL,ig1,g2,g3=NULL,g4=NULL,i2,i3=NULL,i4=NULL,deriv=0) { ## lj is the array of jth order derivatives of l ## gj[,k] contains the jth derivatives for the link of the kth lp ## ig1 is one over first deriv of link ## kth parameter. This routine transforms derivatives ## w.r.t. the parameters (mu_1..mu_K) to derivatives ## w.r.t. the linear predictors (eta_1.. eta_K) ## i2, i3 and i4 are the upper triangular indexing arrays ## e.g. l4[,i4[i,j,l,m]] contains the partial w.r.t. ## params indexed by i,j,l,m with no restriction on ## the index values except that they are in 1..K K <- ncol(l1) ## number of parameters of distribution d1 <- l1 for (i in 1:K) { ## first derivative loop d1[,i] <- l1[,i]*ig1[,i] } ##n <- length(ig1[,1]) k <- 0 d2 <- l2 for (i in 1:K) for (j in i:K) { ## obtain the order of differentiation associated ## with the i,j derivatives... ord <- rep(1,2);k <- k+1 if (i==j) {ord[1] <- ord[1] + 1; ord[2] <- 0 } ## l2[,k] is derivative to transform mo <- max(ord) if (mo==2) { ## pure 2nd derivative transform d2[,k] <- (l2[,k] - l1[,i]*g2[,i]*ig1[,i])*ig1[,i]^2 } else { ## all first derivative d2[,k] <- l2[,k]*ig1[,i]*ig1[,j] } } ## 2nd order transform done k <- 0 d3 <- l3 if (deriv>0) for (i in 1:K) for (j in i:K) for (l in j:K) { ## obtain the order of differentiation associated ## with the i,j,l derivatives... ord <- rep(1,3);k <- k+1 if (i==j) {ord[1] <- ord[1] + 1; ord[2] <- 0 } if (i==l) {ord[1] <- ord[1] + 1; ord[3] <- 0 } if (ord[2]) { if (j==l) {ord[2] <- ord[2] + 1; ord[3] <- 0 } } ii <- c(i,j,l) ## l3[,k] is derivative to transform mo <- max(ord) if (mo==3) { ## pure 3rd derivative transform d3[,k] <- (l3[,k] - 3*l2[,i2[i,i]]*g2[,i]*ig1[,i] + l1[,i]*(3*g2[,i]^2*ig1[,i]^2 - g3[,i]*ig1[,i]))*ig1[,i]^3 } else if (mo==1) { ## all first derivative d3[,k] <- l3[,k]*ig1[,i]*ig1[,j]*ig1[,l] } else { ## 2,1 deriv k1 <- ii[ord==1] ## index of order 1 deriv k2 <- ii[ord==2] ## index of order 2 part d3[,k] <- (l3[,k] - l2[,i2[k2,k1]]*g2[,k2]*ig1[,k2])* ig1[,k1]*ig1[,k2]^2 } } ## 3rd order transform done k <- 0 d4 <- l4 if (deriv>2) for (i in 1:K) for (j in i:K) for (l in j:K) for (m in l:K) { ## obtain the order of differentiation associated ## with the i,j,l & m derivatives... ord <- rep(1,4);k <- k+1 if (i==j) {ord[1] <- ord[1] + 1; ord[2] <- 0 } if (i==l) {ord[1] <- ord[1] + 1; ord[3] <- 0 } if (i==m) {ord[1] <- ord[1] + 1; ord[4] <- 0 } if (ord[2]) { if (j==l) {ord[2] <- ord[2] + 1; ord[3] <- 0 } if (j==m) {ord[2] <- ord[2] + 1; ord[4] <- 0 } } if (ord[3]&&l==m) { ord[3] <- ord[3] + 1; ord[4] <- 0 } ii <- c(i,j,l,m) ## l4[,k] is derivative to transform mo <- max(ord) if (mo==4) { ## pure 4th derivative transform d4[,k] <- (l4[,k] - 6*l3[,i3[i,i,i]]*g2[,i]*ig1[,i] + l2[,i2[i,i]]*(15*g2[,i]^2*ig1[,i]^2 - 4*g3[,i]*ig1[,i]) - l1[,i]*(15*g2[,i]^3*ig1[,i]^3 - 10*g2[,i]*g3[,i]*ig1[,i]^2 + g4[,i]*ig1[,i]))*ig1[,i]^4 } else if (mo==1) { ## all first derivative d4[,k] <- l4[,k]*ig1[,i]*ig1[,j]*ig1[,l]*ig1[,m] } else if (mo==3) { ## 3,1 deriv k1 <- ii[ord==1] ## index of order 1 deriv k3 <- ii[ord==3] ## index of order 3 part d4[,k] <- (l4[,k] - 3*l3[,i3[k3,k3,k1]]*g2[,k3]*ig1[,k3] + l2[,i2[k3,k1]]*(3*g2[,k3]^2*ig1[,k3]^2 - g3[,k3]*ig1[,k3]) )*ig1[,k1]*ig1[,k3]^3 } else { if (sum(ord==2)==2) { ## 2,2 k2a <- (ii[ord==2])[1];k2b <- (ii[ord==2])[2] d4[,k] <- (l4[,k] - l3[,i3[k2a,k2b,k2b]]*g2[,k2a]*ig1[,k2a] -l3[,i3[k2a,k2a,k2b]]*g2[,k2b]*ig1[,k2b] + l2[,i2[k2a,k2b]]*g2[,k2a]*g2[,k2b]*ig1[,k2a]*ig1[,k2b] )*ig1[,k2a]^2*ig1[,k2b]^2 } else { ## 2,1,1 k2 <- ii[ord==2] ## index of order 2 derivative k1a <- (ii[ord==1])[1];k1b <- (ii[ord==1])[2] d4[,k] <- (l4[,k] - l3[,i3[k2,k1a,k1b]]*g2[,k2]*ig1[,k2] )*ig1[,k1a]*ig1[,k1b]*ig1[,k2]^2 } } } ## 4th order transform done list(l1=d1,l2=d2,l3=d3,l4=d4) } # gamlss.etamu gamlss.gH <- function(X,jj,l1,l2,i2,l3=0,i3=0,l4=0,i4=0,d1b=0,d2b=0,deriv=0,fh=NULL,D=NULL) { ## X[,jj[[i]]] is the ith model matrix. ## lj contains jth derivatives of the likelihood for each datum, ## columns are w.r.t. different combinations of parameters. ## ij is the symmetric array indexer for the jth order derivs... ## e.g. l4[,i4[i,j,l,m]] contains derivatives with ## respect to parameters indexed by i,j,l,m ## d1b and d2b are first and second derivatives of beta w.r.t. sps. ## fh is a factorization of the penalized hessian, while D contains the corresponding ## Diagonal pre-conditioning weights. ## deriv: 0 - just grad and Hess ## 1 - tr(Hp^{-1} dH/drho_j) vector (was diagonal of first deriv of Hess - unused) ## 2 - first deriv of Hess ## 3 - everything. K <- length(jj) if (is.list(X)) { discrete <- TRUE p <- X$p;n <- nrow(X$kd) } else { discrete <- FALSE p <- ncol(X);n <- nrow(X) } trHid2H <- d1H <- d2H <- NULL ## defaults ## the gradient... lb <- rep(0,p) for (i in 1:K) { ## first derivative loop lb[jj[[i]]] <- lb[jj[[i]]] + if (discrete) XWyd(X$Xd,rep(1,n),l1[,i],X$kd,X$ks,X$ts,X$dt,X$v,X$qc,X$drop,lt=X$lpid[[i]]) else colSums(l1[,i]*X[,jj[[i]],drop=FALSE]) ## ! } ## the Hessian... lbb <- matrix(0,p,p) for (i in 1:K) for (j in i:K) { ## A <- t(X[,jj[[i]],drop=FALSE])%*%(l2[,i2[i,j]]*X[,jj[[j]],drop=FALSE]) A <- if (discrete) XWXd(X$Xd,w=l2[,i2[i,j]],k=X$kd,ks=X$ks,ts=X$ts,dt=X$dt,v=X$v,qc=X$qc,nthreads=1,drop=X$drop,lt=X$lpid[[i]],rt=X$lpid[[j]]) else crossprod(X[,jj[[i]],drop=FALSE],l2[,i2[i,j]]*X[,jj[[j]],drop=FALSE]) lbb[jj[[i]],jj[[j]]] <- lbb[jj[[i]],jj[[j]]] + A if (j>i) lbb[jj[[j]],jj[[i]]] <- lbb[jj[[j]],jj[[i]]] + t(A) } if (deriv>0) { ## the first derivative of the Hessian, using d1b ## the first derivates of the coefficients wrt the sps m <- ncol(d1b) ## number of smoothing parameters ## stack the derivatives of the various linear predictors on top ## of each other... d1eta <- matrix(0,n*K,m) ind <- 1:n for (i in 1:K) { d1eta[ind,] <- if (discrete) Xbd(X$Xd,d1b,k=X$kd,ks=X$ks,ts=X$ts,dt=X$dt,v=X$v,qc=X$qc,drop=X$drop,lt=X$lpid[[i]]) else X[,jj[[i]],drop=FALSE]%*%d1b[jj[[i]],] ind <- ind + n } } if (deriv==1) { # d1H <- matrix(0,p,m) ## only store diagonals of d1H # for (l in 1:m) { # for (i in 1:K) { # v <- rep(0,n);ind <- 1:n # for (q in 1:K) { # v <- v + l3[,i3[i,i,q]] * d1eta[ind,l] # ind <- ind + n # } # d1H[jj[[i]],l] <- d1H[jj[[i]],l] + colSums(X[,jj[[i]],drop=FALSE]*(v*X[,jj[[i]],drop=FALSE])) # } # } ## assuming fh contains the inverse penalized Hessian, Hp, forms tr(Hp^{-1}dH/drho_j) for each j g.index <- attr(d1b,"g.index") ## possible index indicating log parameterization if (!is.null(g.index)) { ## then several transform related quantities are required beta <- attr(d1b,"beta") ## regression coefficients d1g <- d1b; d1g[g.index,] <- d1g[g.index,]/beta[g.index] ## derivartive w.r.t. working parameters } d1H <- rep(0,m) if (discrete) { ## lpi <- attr(X,"lpi") ## this line was in original code for this discrete section, and lpi replaced jj below - mistake, I think for (i in 1:K) for (j in i:K) { ## lp block loop for (l in 1:m) { ## sp loop v <- rep(0,n);ind <- 1:n for (q in 1:K) { ## diagonal accumulation loop v <- v + l3[,i3[i,j,q]] * d1eta[ind,l] ind <- ind + n } XVX <- XWXd(X$Xd,w=v,k=X$kd,ks=X$ks,ts=X$ts,dt=X$dt,v=X$v,qc=X$qc,nthreads=1,drop=X$drop,lt=X$lpid[[i]],rt=X$lpid[[j]]) if (!is.null(g.index)) { ## non-linear correction terms required gi <- g.index[jj[[i]]];gj <- g.index[jj[[j]]] if (any(gi)) XVX[gi,] <- beta[jj[[i]]][gi]*XVX[gi,] if (any(gj)) XVX[,gj] <- t(beta[jj[[j]]][gj]*t(XVX[,gj])) if (any(gi)) { XWX <- beta[jj[[i]]][gi]*d1g[jj[[i]],l][gi]*lbb[jj[[i]],jj[[j]]][gi,] if (any(gj)) XWX[,gj] <- t(beta[jj[[j]]][gj]*t(XWX[,gj])) XVX[gi,] <- XVX[gi,] + XWX } if (any(gj)) { XWX <- t(beta[jj[[j]]][gj]*d1g[jj[[j]],l][gj]*t(lbb[jj[[i]],jj[[j]]][,gj])) if (any(gi)) XWX[gi,] <- beta[jj[[i]]][gi]*XWX[gi,] XVX[,gj] <- XVX[,gj] + XWX if (i==j) { ## add diagonal corrections dd <- beta[jj[[i]]][gi]*(lbb[jj[[i]][gi],] %*% d1b[,l] + lb[jj[[i]]][gi]*d1g[jj[[i]],l][gi]) XVX[gi,gj] <- XVX[gi,gj] + diag(drop(dd),nrow=sum(gi)) } } } ## end of non-linear corrections mult <- if (i==j) 1 else 2 d1H[l] <- d1H[l] + mult * sum(XVX * fh[jj[[i]],jj[[j]]]) ## accumulate tr(Hp^{-1}dH/drho_l) } } } else for (i in 1:K) for (j in i:K) { ## lp block loop Hpi <- fh[jj[[i]],jj[[j]]] ## correct component of inverse Hessian d1hc <- rep(0,m) if (!is.null(g.index)) { ## correct for non-linearity gi <- g.index[jj[[i]]];gj <- g.index[jj[[j]]] for (l in 1:m) { ## s.p. loop dcor <- 0 if (any(gi)) { XWX <- beta[jj[[i]]][gi]*d1g[jj[[i]],l][gi]*lbb[jj[[i]],jj[[j]]][gi,] if (any(gj)) XWX[,gj] <- t(beta[jj[[j]]][gj]*t(XWX[,gj])) dcor <- dcor + sum(XWX * Hpi[gi,]) } if (any(gj)) { XWX <- t(beta[jj[[j]]][gj]*d1g[jj[[j]],l][gj]*t(lbb[jj[[i]],jj[[j]]][,gj])) if (any(gi)) XWX[gi,] <- beta[jj[[i]]][gi]*XWX[gi,] dcor <- dcor + sum(XWX * Hpi[,gj]) if (i==j) { ## diagonal correction dd <- beta[jj[[i]]][gi]*(lbb[jj[[i]][gi],] %*% d1b[,l] + lb[jj[[i]]][gi]*d1g[jj[[i]],l][gi]) dcor <- dcor + sum(dd*diag(Hpi)[gi]) } } d1hc[l] <- dcor } ## s.p. loop end if (any(gi)) Hpi[gi,] <- Hpi[gi,]*beta[jj[[i]]][gi] if (any(gj)) Hpi[,gj] <- t(t(Hpi[,gj])*beta[jj[[i]]][gi]) } ## end of non-linearity correction a <- rowSums((X[,jj[[i]]] %*% Hpi) * X[,jj[[j]]]) for (l in 1:m) { ## sp loop v <- rep(0,n);ind <- 1:n for (q in 1:K) { ## diagonal accumulation loop v <- v + l3[,i3[i,j,q]] * d1eta[ind,l] ind <- ind + n } mult <- if (i==j) 1 else 2 d1H[l] <- d1H[l] + mult * (sum(a*v) + d1hc[l]) ## accumulate tr(Hp^{-1}dH/drho_l) } } } ## if deriv==1 if (deriv>1) { if (discrete) stop("er... no discrete methods for higher derivatives") d1H <- list() for (l in 1:m) { d1H[[l]] <- matrix(0,p,p) for (i in 1:K) for (j in i:K) { v <- rep(0,n);ind <- 1:n for (q in 1:K) { v <- v + l3[,i3[i,j,q]] * d1eta[ind,l] ind <- ind + n } ## d1H[[l]][jj[[j]],jj[[i]]] <- ## A <- t(X[,jj[[i]],drop=FALSE])%*%(v*X[,jj[[j]],drop=FALSE]) A <- crossprod(X[,jj[[i]],drop=FALSE],v*X[,jj[[j]],drop=FALSE]) d1H[[l]][jj[[i]],jj[[j]]] <- d1H[[l]][jj[[i]],jj[[j]]] + A if (j>i) d1H[[l]][jj[[j]],jj[[i]]] <- d1H[[l]][jj[[j]],jj[[i]]] + t(A) } } } ## if deriv>1 if (deriv>2) { ## need tr(Hp^{-1} d^2H/drho_k drho_j) ## First form the expanded model matrix... VX <- Xe <- matrix(0,K*n,ncol(X)) ind <- 1:n for (i in 1:K) { Xe[ind,jj[[i]]] <- X[,jj[[i]]] ind <- ind + n } ## Now form Hp^{-1} Xe'... if (is.list(fh)) { ## then the supplied factor is an eigen-decomposition d <- fh$values;d[d>0] <- 1/d[d>0];d[d<=0] <- 0 Xe <- t(D*((fh$vectors%*%(d*t(fh$vectors)))%*%(D*t(Xe)))) } else { ## the supplied factor is a choleski factor ipiv <- piv <- attr(fh,"pivot");ipiv[piv] <- 1:p Xe <- t(D*(backsolve(fh,forwardsolve(t(fh),(D*t(Xe))[piv,]))[ipiv,])) } ## now compute the required trace terms d2eta <- matrix(0,n*K,ncol(d2b)) ind <- 1:n for (i in 1:K) { d2eta[ind,] <- X[,jj[[i]],drop=FALSE]%*%d2b[jj[[i]],] ind <- ind + n } trHid2H <- rep(0,ncol(d2b)) kk <- 0 ## counter for second derivatives for (k in 1:m) for (l in k:m) { ## looping over smoothing parameters... kk <- kk + 1 for (i in 1:K) for (j in 1:K) { v <- rep(0,n);ind <- 1:n for (q in 1:K) { ## accumulate the diagonal matrix for X_i'diag(v)X_j v <- v + d2eta[ind,kk]*l3[,i3[i,j,q]] ins <- 1:n for (s in 1:K) { v <- v + d1eta[ind,k]*d1eta[ins,l]*l4[,i4[i,j,q,s]] ins <- ins + n } ind <- ind + n } if (i==j) { rind <- 1:n + (i-1)*n VX[rind,jj[[i]]] <- v * X[,jj[[i]]] } else { rind1 <- 1:n + (i-1)*n rind2 <- 1:n + (j-1)*n VX[rind2,jj[[i]]] <- v * X[,jj[[i]]] VX[rind1,jj[[j]]] <- v * X[,jj[[j]]] } } trHid2H[kk] <- sum(Xe*VX) } } ## if deriv>2 list(lb=lb,lbb=lbb,d1H=d1H,d2H=d2H,trHid2H=trHid2H) } ## end of gamlss.gH gaulss <- function(link=list("identity","logb"),b=0.01) { ## Extended family for Gaussian location scale model... ## so mu is mu1 and tau=1/sig is mu2 ## tau = 1/(b + exp(eta)) eta = log(1/tau - b) ## 1. get derivatives wrt mu, tau ## 2. get required link derivatives and tri indices. ## 3. transform derivs to derivs wrt eta (gamlss.etamu). ## 4. get the grad and Hessian etc for the model ## via a call to gamlss.gH ## the first derivatives of the log likelihood w.r.t ## the first and second parameters... ## first deal with links and their derivatives... if (length(link)!=2) stop("gaulss requires 2 links specified as character strings") okLinks <- list(c("inverse", "log", "identity","sqrt"),"logb") stats <- list() if (link[[1]] %in% okLinks[[1]]) stats[[1]] <- make.link(link[[1]]) else stop(link[[1]]," link not available for mu parameter of gaulss") fam <- structure(list(link=link[[1]],canonical="none",linkfun=stats[[1]]$linkfun, mu.eta=stats[[1]]$mu.eta), class="family") fam <- fix.family.link(fam) stats[[1]]$d2link <- fam$d2link stats[[1]]$d3link <- fam$d3link stats[[1]]$d4link <- fam$d4link if (link[[2]] %in% okLinks[[2]]) { ## creating the logb link stats[[2]] <- list() stats[[2]]$valideta <- function(eta) TRUE stats[[2]]$link = link[[2]] stats[[2]]$linkfun <- eval(parse(text=paste("function(mu) log(1/mu -",b,")"))) stats[[2]]$linkinv <- eval(parse(text=paste("function(eta) 1/(exp(eta) +",b,")"))) stats[[2]]$mu.eta <- eval(parse(text= paste("function(eta) { ee <- exp(eta); -ee/(ee +",b,")^2 }"))) stats[[2]]$d2link <- eval(parse(text= paste("function(mu) { mub <- pmax(1 - mu *",b,",.Machine$double.eps);(2*mub-1)/(mub*mu)^2}" ))) stats[[2]]$d3link <- eval(parse(text= paste("function(mu) { mub <- pmax(1 - mu *",b,",.Machine$double.eps);((1-mub)*mub*6-2)/(mub*mu)^3}" ))) stats[[2]]$d4link <- eval(parse(text= paste("function(mu) { mub <- pmax(1 - mu *",b,",.Machine$double.eps);(((24*mub-36)*mub+24)*mub-6)/(mub*mu)^4}"))) } else stop(link[[2]]," link not available for precision parameter of gaulss") residuals <- function(object,type=c("deviance","pearson","response")) { type <- match.arg(type) rsd <- object$y-object$fitted[,1] if (type=="response") return(rsd) else return((rsd*object$fitted[,2])) ## (y-mu)/sigma } postproc <- expression({ ## code to evaluate in estimate.gam, to evaluate null deviance ## in principle the following seems reasonable, but because no ## price is paid for the high null variance, it leads to silly ## % deviance explained... #er <- fitNull(G$y,G$family,G$w,G$offset,nlp=length(attr(G$X,"lpi")),tol=1e-7) #object$null.deviance <- sum(((object$y-er$mu[,1])*er$mu[,2])^2*G$w) object$null.deviance <- sum(((object$y-mean(object$y))*object$fitted[,2])^2) }) ll <- function(y,X,coef,wt,family,offset=NULL,deriv=0,d1b=0,d2b=0,Hp=NULL,rank=0,fh=NULL,D=NULL) { ## function defining the gamlss Gaussian model log lik. ## N(mu,sigma^2) parameterized in terms of mu and log(sigma) ## deriv: 0 - eval ## 1 - grad and Hess ## 2 - diagonal of first deriv of Hess ## 3 - first deriv of Hess ## 4 - everything. if (!is.null(offset)) offset[[3]] <- 0 discrete <- is.list(X) jj <- attr(X,"lpi") ## extract linear predictor index eta <- if (discrete) Xbd(X$Xd,coef,k=X$kd,ks=X$ks,ts=X$ts,dt=X$dt,v=X$v,qc=X$qc,drop=X$drop,lt=X$lpid[[1]]) else X[,jj[[1]],drop=FALSE]%*%coef[jj[[1]]] if (!is.null(offset[[1]])) eta <- eta + offset[[1]] mu <- family$linfo[[1]]$linkinv(eta) eta1 <- if (discrete) Xbd(X$Xd,coef,k=X$kd,ks=X$ks,ts=X$ts,dt=X$dt,v=X$v,qc=X$qc,drop=X$drop,lt=X$lpid[[2]]) else X[,jj[[2]],drop=FALSE]%*%coef[jj[[2]]] if (!is.null(offset[[2]])) eta1 <- eta1 + offset[[2]] tau <- family$linfo[[2]]$linkinv(eta1) ## tau = 1/sig here n <- length(y) l1 <- matrix(0,n,2) ymu <- y-mu;ymu2 <- ymu^2;tau2 <- tau^2 l <- sum(-.5 * ymu2 * tau2 - .5 * log(2*pi) + log(tau)) if (deriv>0) { l1[,1] <- tau2*ymu l1[,2] <- 1/tau - tau*ymu2 ## the second derivatives l2 <- matrix(0,n,3) ## order mm,ms,ss l2[,1] <- -tau2 l2[,2] <- 2*l1[,1]/tau l2[,3] <- -ymu2 - 1/tau2 ## need some link derivatives for derivative transform ig1 <- cbind(family$linfo[[1]]$mu.eta(eta),family$linfo[[2]]$mu.eta(eta1)) g2 <- cbind(family$linfo[[1]]$d2link(mu),family$linfo[[2]]$d2link(tau)) } l3 <- l4 <- g3 <- g4 <- 0 ## defaults if (deriv>1) { ## the third derivatives ## order mmm,mms,mss,sss l3 <- matrix(0,n,4) ## l3[,1] <- 0 l3[,2] <- -2*tau l3[,3] <- 2*ymu l3[,4] <- 2/tau^3 g3 <- cbind(family$linfo[[1]]$d3link(mu),family$linfo[[2]]$d3link(tau)) } if (deriv>3) { ## the fourth derivatives ## order mmmm,mmms,mmss,msss,ssss l4 <- matrix(0,n,5) ## l4[,1] <- 0 ## l4[,2] <- 0 l4[,3] <- -2 #l4[,4] <- 0 l4[,5] <- -6/tau2^2 g4 <- cbind(family$linfo[[1]]$d4link(mu),family$linfo[[2]]$d4link(tau)) } if (deriv) { i2 <- family$tri$i2; i3 <- family$tri$i3 i4 <- family$tri$i4 ## transform derivates w.r.t. mu to derivatives w.r.t. eta... de <- gamlss.etamu(l1,l2,l3,l4,ig1,g2,g3,g4,i2,i3,i4,deriv-1) ## get the gradient and Hessian... ret <- gamlss.gH(X,jj,de$l1,de$l2,i2,l3=de$l3,i3=i3,l4=de$l4,i4=i4, d1b=d1b,d2b=d2b,deriv=deriv-1,fh=fh,D=D) } else ret <- list() ret$l <- l; ret } ## end ll gaulss initialize <- expression({ ## idea is to regress g(y) on model matrix for mean, and then ## to regress the corresponding log absolute residuals on ## the model matrix for log(sigma) - may be called in both ## gam.fit5 and initial.spg... note that appropriate E scaling ## for full calculation may be inappropriate for initialization ## which is basically penalizing something different here. ## best we can do here is to use E only as a regularizer. n <- rep(1, nobs) ## should E be used unscaled or not?.. use.unscaled <- if (!is.null(attr(E,"use.unscaled"))) TRUE else FALSE if (is.null(start)) { jj <- attr(x,"lpi") if (!is.null(offset)) offset[[3]] <- 0 yt1 <- if (family$link[[1]]=="identity") y else family$linfo[[1]]$linkfun(abs(y)+max(y)*1e-7) if (!is.null(offset[[1]])) yt1 <- yt1 - offset[[1]] if (is.list(x)) { ## discrete case start <- rep(0,max(unlist(jj))) R <- suppressWarnings(chol(XWXd(x$Xd,w=rep(1,length(y)),k=x$kd,ks=x$ks,ts=x$ts,dt=x$dt,v=x$v,qc=x$qc,nthreads=1,drop=x$drop,lt=x$lpid[[1]])+crossprod(E[,jj[[1]]]),pivot=TRUE)) Xty <- XWyd(x$Xd,rep(1,length(y)),yt1,x$kd,x$ks,x$ts,x$dt,x$v,x$qc,x$drop,lt=x$lpid[[1]]) piv <- attr(R,"pivot") rrank <- attr(R,"rank") startji <- rep(0,ncol(R)) if (rrankK) stop("response not in 0 to number of predictors + 1") ee <- exp(eta[,-1,drop=FALSE]) beta <- 1 + rowSums(ee); alpha <- log(beta) l0 <- eta[1:n+y*n] - alpha ## log likelihood l <- sum(l0) l1 <- matrix(0,n,K) ## first deriv matrix if (deriv>0) { for (i in 1:K) l1[,i] <- ee[,i]/beta ## alpha1 ## the second derivatives... l2 <- matrix(0,n,K*(K+1)/2) ii <- 0; b2 <- beta^2 for (i in 1:K) for (j in i:K) { ii <- ii + 1 ## column index l2[,ii] <- if (i==j) -l1[,i] + ee[,i]^2/b2 else (ee[,i]*ee[,j])/b2 } ## finish first derivatives... for (i in 1:K) l1[,i] <- as.numeric(y==i) - l1[,i] } ## if (deriv>0) l3 <- l4 <- 0 ## defaults tri <- family$tri ## indices to facilitate access to earlier results if (deriv>1) { ## the third derivatives... l3 <- matrix(0,n,(K*(K+3)+2)*K/6) ii <- 0; b3 <- b2 * beta for (i in 1:K) for (j in i:K) for (k in j:K) { ii <- ii + 1 ## column index if (i==j&&j==k) { ## all same l3[,ii] <- l2[,tri$i2[i,i]] + 2*ee[,i]^2/b2 - 2*ee[,i]^3/b3 } else if (i!=j&&j!=k&i!=k) { ## all different l3[,ii] <- -2*(ee[,i]*ee[,j]*ee[,k])/b3 } else { ## two same one different kk <- if (i==j) k else j ## get indices for differing pair l3[,ii] <- l2[,tri$i2[i,kk]] - 2*(ee[,i]*ee[,j]*ee[,k])/b3 } } } ## if (deriv>1) if (deriv>3) { ## the fourth derivatives... l4 <- matrix(0,n,(6+K*11+K^2*6+K^3)*K/24) ii <- 0; b4 <- b3 * beta for (i in 1:K) for (j in i:K) for (k in j:K) for (l in k:K) { ii <- ii + 1 ## column index uni <- unique(c(i,j,k,l)); nun <- length(uni) ## number of unique indices if (nun==1) { ## all equal l4[,ii] <- l3[,tri$i3[i,i,i]] + 4*ee[,i]^2/b2 - 10*ee[,i]^3/b3 + 6*ee[,i]^4/b4 } else if (nun==4) { ## all unequal l4[,ii] <- 6*ee[,i]*ee[,j]*ee[,k]*ee[,l]/b4 } else if (nun==3) { ## 2 same 2 different l4[,ii] <- l3[,tri$i3[uni[1],uni[2],uni[3]]] +6*ee[,i]*ee[,j]*ee[,k]*ee[,l]/b4 } else if (sum(uni[1]==c(i,j,k,l))==2) { ## 2 unique (2 of each) l4[,ii] <- l3[,tri$i3[uni[1],uni[2],uni[2]]] - 2 * ee[,uni[1]]^2*ee[,uni[2]]/b3 + 6*ee[,i]*ee[,j]*ee[,k]*ee[,l]/b4 } else { ## 3 of one 1 of the other if (sum(uni[1]==c(i,j,k,l))==1) uni <- uni[2:1] ## first index is triple repeat index l4[,ii] <- l3[,tri$i3[uni[1],uni[1],uni[2]]] - 4 * ee[,uni[1]]^2*ee[,uni[2]]/b3 + 6*ee[,i]*ee[,j]*ee[,k]*ee[,l]/b4 } } } ## if deriv>3 if (return.l) return(list(l=l0,l1=l1,l2=l2,l3=l3,l4=l4)) ## for testing... if (deriv) { ## get the gradient and Hessian... ret <- gamlss.gH(X,jj,l1,l2,tri$i2,l3=l3,i3=tri$i3,l4=l4,i4=tri$i4, d1b=d1b,d2b=d2b,deriv=deriv-1,fh=fh,D=D) } else ret <- list() ret$l <- l; ret } ## end ll multinom rd <- function(mu,wt,scale) { ## simulate data given fitted linear predictor matrix in mu p <- exp(cbind(0,mu)) p <- p/rowSums(p) cp <- t(apply(p,1,cumsum)) apply(cp,1,function(x) min(which(x>runif(1))))-1 } ## rd initialize <- expression({ ## Binarize each category and lm on 6*y-3 by category. n <- rep(1, nobs) ## should E be used unscaled or not?.. use.unscaled <- if (!is.null(attr(E,"use.unscaled"))) TRUE else FALSE if (is.null(start)) { jj <- attr(x,"lpi") if (is.list(x)) { ## discrete case start <- rep(0,max(unlist(jj))) for (k in 1:length(jj)) { ## loop over the linear predictors yt1 <- 6*as.numeric(y==k)-3 R <- suppressWarnings(chol(XWXd(x$Xd,w=rep(1,length(y)),k=x$kd,ks=x$ks,ts=x$ts,dt=x$dt, v=x$v,qc=x$qc,nthreads=1,drop=x$drop,lt=x$lpid[[k]])+crossprod(E[,jj[[k]]]),pivot=TRUE)) Xty <- XWyd(x$Xd,rep(1,length(y)),yt1,x$kd,x$ks,x$ts,x$dt,x$v,x$qc,x$drop,lt=x$lpid[[k]]) piv <- attr(R,"pivot") rrank <- attr(R,"rank") startji <- rep(0,ncol(R)) if (rrank rr-.1*re) { ## increase penalization k <- k*10 qrr <- qr(rbind(R,e*k)); edf <- sum(qr.Q(qrr)[1:r,]^2) } while (edf<.7*rr) { ## reduce penalization k <- k/20 qrr <- qr(rbind(R,e*k)); edf <- sum(qr.Q(qrr)[1:r,]^2) } b <- qr.coef(qrr,c(Qy,rep(0,nrow(e))));b[!is.finite(b)] <- 0 b } ## pen.reg ## code for zero inflated Poisson models #log1ex <- function(x) { ## evaluate log(1+exp(x)) accurately and avoiding overflow # y <- x # big <- -log(.Machine$double.eps)+5 ## exp(big) overwhelms 1 # ind <- x > big # y[ind] <- x[ind] ## log(1+exp(x)) = x to machine precision # ## compute number below which log(1+exp(x)) = exp(x) to # ## machine precision... # small <- log(sqrt(.Machine$double.eps)) # ind1 <- x < small # y[ind1] <- exp(x[ind1]) # ind <- !ind&!ind1 ## the moderate size elements # y[ind] <- log(1+exp(x[ind])) # y #} #logist <- function(x) { ## overflow proof logistic # ind <- x > 0; y <- x # y[ind] <- 1/(exp(-x[ind])+1) # ex <- exp(x[!ind]) # y[!ind] <- ex/(1+ex) # y #} l1ee <- function(x) { ## log(1-exp(-exp(x)))... ind <- x < log(.Machine$double.eps)/3 ex <- exp(x);exi <- ex[ind] l <- log(1-exp(-ex)) l[ind] <- log(exi-exi^2/2+exi^3/6) ind <- x < -log(.Machine$double.xmax) l[ind] <- x[ind] l } lee1 <- function(x) { ## log(exp(exp(x))-1)... ind <- x < log(.Machine$double.eps)/3 ex <- exp(x);exi <- ex[ind] l <- log(exp(ex)-1) l[ind] <- log(exi+exi^2/2+exi^3/6) ind <- x < -log(.Machine$double.xmax) l[ind] <- x[ind] ind <- x > log(log(.Machine$double.xmax)) l[ind] <- ex[ind] l } ldg <- function(g,deriv=4) { alpha <- function(g) { ind <- g > log(.Machine$double.eps)/3 eg <- exp(g) g[ind] <- eg[ind]/(1-exp(-eg[ind])) g[!ind] <- 1+eg[!ind]/2 + eg[!ind]^2/12 g } ind <- g < log(.Machine$double.eps)/3 ghi <- log(log(.Machine$double.xmax)) + 1 ## ... above ghi alpha(g) is simply exp(g) ii <- g>ghi a <- alpha(g) eg <- exp(g) l2 <- a*(a-eg-1) egi <- eg[ind] ## in the lower tail alpha = 1 + b, where b = eg/2 + eg^2/12 ## so l'' = alpha*(b-eg)... b <- egi*(1+egi/6)/2 l2[ind] <- a[ind]*(b-egi) l2[ii] <- -exp(g[ii]) l3 <- l4 <- NULL ## in a similar vein l3 can be robustified... if (deriv>1) { l3 <- a*(a*(-2*a + 3*(eg+1)) - 3*eg - eg^2 - 1) l3[ind] <- a[ind]*(-b-2*b^2+3*b*egi-egi^2) l3[ii] <- -exp(g[ii]) } ## finally l4, which requires a similar approach... if (deriv>2) { l4 <- a*(6*a^3 - 12*(eg+1)*a^2+4*eg*a+7*(eg+1)^2*a-(4+3*eg)*eg -(eg+1)^3) l4[ind] <- a[ind]*(6*b*(3+3*b+b^2) - 12*egi*(1+2*b+b^2) - 12*b*(2-b) + 4*egi*(1+b)+ 7*(egi^2+2*egi+b*egi^2+2*b*egi+b)-(4+3*egi)*egi-egi*(3+3*egi+egi^2)) l4[ii] <- -exp(g[ii]) } l1=-a ghi <- log(.Machine$double.xmax)/5 ii <- g > ghi if (sum(ii)) { l1[ii] <- l2[ii] <- l3[ii] <- l4[ii] <- -exp(ghi) } list(l1=l1,l2=l2,l3=l3,l4=l4) } ## ldg lde <- function(eta,deriv=4) { ## llog lik derivs w.r.t. eta ind <- eta < log(.Machine$double.eps)/3 ii <- eta > log(.Machine$double.xmax) l1 <- et <- exp(eta);eti <- et[ind] l1[!ind] <- et[!ind]/(exp(et[!ind])-1) b <- -eti*(1+eti/6)/2 l1[ind] <- 1+b l1[ii] <- 0 ## l2 ... l2 <- l1*((1-et)-l1) l2[ind] <- -b*(1+eti+b) - eti l2[ii] <- 0 l3 <- l4 <- NULL ## l3 ... if (deriv>1) { ii <- eta > log(.Machine$double.xmax)/2 l3 <- l1*((1-et)^2-et - 3*(1-et)*l1 + 2*l1^2) l3[ind] <- l1[ind]*(-3*eti+eti^2 -3*(-eti+b-eti*b) + 2*b*(2+b)) l3[ii] <- 0 } ## l4 ... if (deriv>2) { ii <- eta > log(.Machine$double.xmax)/3 l4 <- l1*((3*et-4)*et + 4*et*l1 + (1-et)^3 - 7*(1-et)^2*l1 + 12*(1-et)*l1^2 - 6*l1^3) l4[ii] <- 0 l4[ind] <- l1[ind]*(4*l1[ind]*eti - eti^3 - b -7*b*eti^2 - eti^2 - 5*eti - 10*b*eti - 12*eti*b^2 - 6*b^2 - 6*b^3) } list(l1=l1,l2=l2,l3=l3,l4=l4) } ## lde zipll <- function(y,g,eta,deriv=0) { ## function to evaluate zero inflated Poisson log likelihood ## and its derivatives w.r.t. g/gamma and eta where ## 1-p = exp(-exp(eta)) and lambda = exp(gamma), for each datum in vector y. ## p is probability of potential presence. lambda is Poisson mean ## given potential presence. ## deriv: 0 - eval ## 1 - grad (l,p) and Hess (ll,lp,pp) ## 2 - third derivs lll,llp,lpp,ppp ## 4 - 4th derivs. llll,lllp,llpp,lppp,pppp l1 <- El2 <- l2 <- l3 <- l4 <- NULL zind <- y == 0 ## the index of the zeroes ## yz <- y[zind]; yp <- y[!zind] l <- et <- exp(eta) l[zind] <- -et[zind] # -exp(eta[ind]) l[!zind] <- l1ee(eta[!zind]) + yp*g[!zind] - lee1(g[!zind]) - lgamma(yp+1) p <- 1-exp(-et) ## probablity of non-zero if (deriv>0) { ## get first and second derivs... n <- length(y) l1 <- matrix(0,n,2) le <- lde(eta,deriv) ## derivs of ll wrt eta lg <- ldg(g,deriv) ## derivs of ll wrt gamma l1[!zind,1] <- yp + lg$l1[!zind] ## l_gamma, y>0 l1[zind,2] <- l[zind] ## l_eta, y==0 l1[!zind,2] <- le$l1[!zind] ## l_eta, y>0 El2 <- l2 <- matrix(0,n,3) ## order gg, ge, ee... l2[!zind,1] <- lg$l2[!zind] ## l_gg, y>0 l2[!zind,3] <- le$l2[!zind] ## l_ee, y>0 l2[zind,3] <- l[zind] ## l_ee, y=0 El2[,1] <- p*lg$l2 ## E(l_gg) El2[,3] <- -(1-p)*et + p*le$l2 ## E(l_ee) } if (deriv>1) { ## the third derivatives ## order ggg,gge,gee,eee l3 <- matrix(0,n,4) l3[!zind,1] <- lg$l3[!zind] ## l_ggg, y>0 l3[!zind,4] <- le$l3[!zind] ## l_eee, y>0 l3[zind,4] <- l[zind] ## l_eee, y=0 } if (deriv>3) { ## the fourth derivatives ## order gggg,ggge,ggee,geee,eeee l4 <- matrix(0,n,5) l4[!zind,1] <- lg$l4[!zind] ## l_gggg, y>0 l4[!zind,5] <- le$l4[!zind] ## l_eeee, y>0 l4[zind,5] <- l[zind] ## l_eeee, y=0 } list(l=l,l1=l1,l2=l2,l3=l3,l4=l4,El2=El2) } ## zipll ziplss <- function(link=list("identity","identity")) { ## Extended family for Zero Inflated Poisson fitted as gamlss ## type model. ## mu1 is Poisson mean, while mu2 is zero inflation parameter. ## first deal with links and their derivatives... if (length(link)!=2) stop("ziplss requires 2 links specified as character strings") okLinks <- list(c("identity"),c("identity")) stats <- list() param.names <- c("Poisson mean","binary probability") for (i in 1:2) { if (link[[i]] %in% okLinks[[i]]) stats[[i]] <- make.link(link[[i]]) else stop(link[[i]]," link not available for ",param.names[i]," parameter of ziplss") fam <- structure(list(link=link[[i]],canonical="none",linkfun=stats[[i]]$linkfun, mu.eta=stats[[i]]$mu.eta), class="family") fam <- fix.family.link(fam) stats[[i]]$d2link <- fam$d2link stats[[i]]$d3link <- fam$d3link stats[[i]]$d4link <- fam$d4link } residuals <- function(object,type=c("deviance","response")) { ls <- function(y) { ## compute saturated likelihood for ziplss model l <- y;l[y<2] <- 0 ind <- y > 1 & y < 18 ## lambda maximizing likelihood for y = 2 to 17 glo <- c(1.593624,2.821439,3.920690,4.965114,5.984901,6.993576, 7.997309,8.998888,9.999546,10.999816,11.999926,12.999971, 13.999988,14.999995,15.999998,16.999999) g <- y ## maximizing lambda essentially y above this g[ind] <- glo[y[ind]-1] ind <- y > 1 l[ind] <- zipll(y[ind],log(g[ind]),g[ind]*0+1e10,deriv=0)$l l } ## ls type <- match.arg(type) p <- exp(-exp(object$fitted[,2])); lam <- exp(object$fitted[,1]) ind <- lam > .Machine$double.eps^.5 ## compute E(y) Ey <- p ## very small lambda causes conditional expectation to be 1 Ey[ind] <- p[ind]*lam[ind]/(1-exp(-lam[ind])) rsd <- object$y - Ey ## raw residuals if (type=="response") return(rsd) else { ## compute deviance residuals sgn <- sign(rsd) ind <- object$y == 0 rsd <- pmax(0,2*(ls(object$y) - zipll(object$y,object$fitted[,1],object$fitted[,2],deriv=0)$l)) rsd <- sqrt(rsd)*sgn } rsd } ## ziplss residuals predict <- function(family,se=FALSE,eta=NULL,y=NULL,X=NULL, beta=NULL,off=NULL,Vb=NULL) { ## optional function to give predicted values - idea is that ## predict.gam(...,type="response") will use this, and that ## either eta will be provided, or {X, beta, off, Vb}. family$data ## contains any family specific extra information. ## if se = FALSE returns one item list containing matrix otherwise ## list of two matrices "fit" and "se.fit"... if (is.null(eta)) { if (is.null(off)) off <- list(0,0) off[[3]] <- 0 for (i in 1:2) if (is.null(off[[i]])) off[[i]] <- 0 lpi <- attr(X,"lpi") X1 <- X[,lpi[[1]],drop=FALSE] X2 <- X[,lpi[[2]],drop=FALSE] gamma <- drop(X1%*%beta[lpi[[1]]] + off[[1]]) ## linear predictor for poisson parameter eta <- drop(X2%*%beta[lpi[[2]]] + off[[2]]) ## linear predictor for presence parameter if (se) { v.g <- drop(pmax(0,rowSums((X1%*%Vb[lpi[[1]],lpi[[1]]])*X1))) ## var of gamma v.e <- drop(pmax(0,rowSums((X1%*%Vb[lpi[[1]],lpi[[1]]])*X1))) ## var of eta v.eg <- drop(pmax(0,rowSums((X1%*%Vb[lpi[[1]],lpi[[2]]])*X2))) ## cov of eta, gamma } } else { se <- FALSE gamma <- eta[,1] eta <- eta[,2] } et <- exp(eta) mu <- p <- 1 - exp(-et) fv <- lambda <- exp(gamma) ind <- gamma < log(.Machine$double.eps)/2 mu[!ind] <- lambda[!ind]/(1-exp(-lambda[!ind])) mu[ind] <- 1 fv <- list(p*mu) ## E(y) if (!se) return(fv) else { df.de <- p ind <- eta < log(.Machine$double.xmax)/2 df.de[!ind] <- 0 df.de[ind] <- exp(-et[ind])*et[ind] df.de <- df.de * mu df.dg <- ((lambda + 1)*mu - mu^2)*p fv[[2]] <- sqrt(df.dg^2*v.g + df.de^2*v.e + 2 * df.de * df.dg * v.eg) names(fv) <- c("fit","se.fit") return(fv) } } ## ziplss predict rd <- function(mu,wt,scale) { ## simulate data given fitted latent variable in mu rzip <- function(gamma,eta) { ## generate ziP deviates according to model and lp gamma y <- gamma; n <- length(y) lambda <- exp(gamma) p <- 1- exp(-exp(eta)) ind <- p > runif(n) y[!ind] <- 0 np <- sum(ind) ## generate from zero truncated Poisson, given presence... y[ind] <- qpois(runif(np,dpois(0,lambda[ind]),1),lambda[ind]) y } rzip(mu[,1],mu[,2]) } ## rd postproc <- expression({ ## code to evaluate in estimate.gam, to evaluate null deviance ## null model really has two parameters... probably need to newton iterate ls <- function(y) { ## compute saturated likelihood for ziplss model l <- y;l[y<2] <- 0 ind <- y > 1 & y < 18 ## lambda maximizing likelihood for y = 2 to 17 glo <- c(1.593624,2.821439,3.920690,4.965114,5.984901,6.993576, 7.997309,8.998888,9.999546,10.999816,11.999926,12.999971, 13.999988,14.999995,15.999998,16.999999) g <- y ## maximizing lambda essentially y above this g[ind] <- glo[y[ind]-1] ind <- y > 1 l[ind] <- zipll(y[ind],log(g[ind]),g[ind]*0+1e10,deriv=0)$l l } ## ls fp <- function(p,y) { ## compute zero related part of log likelihood eps <- .Machine$double.eps^.5 l1p <- if (p>eps) log(1-p) else -p - p^2/2 l1p*sum(y==0) + log(p)*sum(y>0) } ## fp flam <- function(lam,y) { ## compute >0 part of log likelihood y <- y[y>0] sum(y*log(lam) - log(exp(lam)-1) - lgamma(y+1)) } ## flam ## optimize zero repated part of likelihood w.r.t. p... lnull <- optimize(fp,interval=c(1e-60,1-1e-10),y=object$y,maximum=TRUE)$objective ## optimize >0 part for lambda... my <- mean(object$y[object$y>0]) lnull <- lnull + optimize(flam,interval=c(my/2,my*2),y=object$y,maximum=TRUE)$objective object$null.deviance <- 2*(sum(ls(object$y)) - lnull) }) ## postproc ll <- function(y,X,coef,wt,family,offset=NULL,deriv=0,d1b=0,d2b=0,Hp=NULL,rank=0,fh=NULL,D=NULL) { ## function defining the gamlss ZIP model log lik. ## First l.p. defines Poisson mean, given presence (lambda) ## Second l.p. defines probability of presence (p) ## deriv: 0 - eval ## 1 - grad and Hess ## 2 - diagonal of first deriv of Hess ## 3 - first deriv of Hess ## 4 - everything. if (is.null(offset)) offset <- list(0,0) else offset[[3]] <- 0 for (i in 1:2) if (is.null(offset[[i]])) offset[[i]] <- 0 jj <- attr(X,"lpi") ## extract linear predictor index eta <- X[,jj[[1]],drop=FALSE]%*%coef[jj[[1]]] + offset[[1]] lambda <- family$linfo[[1]]$linkinv(eta) eta1 <- X[,jj[[2]],drop=FALSE]%*%coef[jj[[2]]] +offset[[2]] p <- family$linfo[[2]]$linkinv(eta1) ##n <- length(y) ## l1 <- matrix(0,n,2) zl <- zipll(y,lambda,p,deriv) if (deriv>0) { ## need some link derivatives for derivative transform ig1 <- cbind(family$linfo[[1]]$mu.eta(eta),family$linfo[[2]]$mu.eta(eta1)) g2 <- cbind(family$linfo[[1]]$d2link(lambda),family$linfo[[2]]$d2link(p)) } ## l3 <- l4 <- g3 <- g4 <- 0 ## defaults if (deriv>1) { ## the third derivatives ## order lll,llp,lpp,ppp g3 <- cbind(family$linfo[[1]]$d3link(lambda),family$linfo[[2]]$d3link(p)) } if (deriv>3) { ## the fourth derivatives ## order llll,lllp,llpp,lppp,pppp g4 <- cbind(family$linfo[[1]]$d4link(lambda),family$linfo[[2]]$d4link(p)) } if (deriv) { i2 <- family$tri$i2; i3 <- family$tri$i3 i4 <- family$tri$i4 ## transform derivates w.r.t. mu to derivatives w.r.t. eta... de <- gamlss.etamu(zl$l1,zl$l2,zl$l3,zl$l4,ig1,g2,g3,g4,i2,i3,i4,deriv-1) ## get the gradient and Hessian... ret <- gamlss.gH(X,jj,de$l1,de$l2,i2,l3=de$l3,i3=i3,l4=de$l4,i4=i4, d1b=d1b,d2b=d2b,deriv=deriv-1,fh=fh,D=D) } else ret <- list() ret$l <- sum(zl$l); ret } ## end ll for ZIP initialize <- expression({ ## for ZIP ## Idea is to regress binarized y on model matrix for p. ## Then downweight any y=0 with p<0.5 and regress g(y) on ## the model matrix for lambda - don't drop as this may ## induce rank deficiency in model matrix! ## May be called in both gam.fit5 and initial.spg... ## note that appropriate E scaling ## for full calculation may be inappropriate for initialization ## which is basically penalizing something different here. ## best we can do here is to use E only as a regularizer. n <- rep(1, nobs) if (all.equal(y,round(y))!=TRUE) { stop("Non-integer response variables are not allowed with ziplss ") } if ((min(y)==0&&max(y)==1)) stop("Using ziplss for binary data makes no sense") ## should E be used unscaled or not?.. use.unscaled <- if (!is.null(attr(E,"use.unscaled"))) TRUE else FALSE if (is.null(start)) { jj <- attr(x,"lpi") start <- rep(0,ncol(x)) x1 <- x[,jj[[2]],drop=FALSE] e1 <- E[,jj[[2]],drop=FALSE] ## square root of total penalty yt1 <- as.numeric(as.logical(y)) ## binarized response if (use.unscaled) { qrx <- qr(rbind(x1,e1)) x1 <- rbind(x1,e1) startji <- qr.coef(qr(x1),c(yt1,rep(0,nrow(E)))) startji[!is.finite(startji)] <- 0 } else startji <- pen.reg(x1,e1,yt1) start[jj[[2]]] <- startji p <- drop(x1[1:nobs,,drop=FALSE] %*% startji) ## probability of presence ind <- y==0 & p < 0.5 ## downweight these for estimating lambda w <- rep(1,nobs); w[ind] <- .1 ## note assumption that working scale is log... yt1 <- family$linfo[[1]]$linkfun(log(abs(y)+(y==0)*.2)) yt1 <- yt1*w x1 <- w*x[,jj[[1]],drop=FALSE];e1 <- E[,jj[[1]],drop=FALSE] if (use.unscaled) { x1 <- rbind(x1,e1) startji <- qr.coef(qr(x1),c(yt1,rep(0,nrow(E)))) startji[!is.finite(startji)] <- 0 } else startji <- pen.reg(x1,e1,yt1) start[jj[[1]]] <- startji } }) ## initialize ziplss structure(list(family="ziplss",ll=ll,link=paste(link),nlp=2, tri = trind.generator(2), ## symmetric indices for accessing derivative arrays initialize=initialize,postproc=postproc,residuals=residuals,rd=rd,predict=predict, linfo = stats, ## link information list d2link=1,d3link=1,d4link=1, ## signals to fix.family.link that all done ls=1, ## signals that ls not needed here available.derivs = 2 ## can use full Newton here ),class = c("general.family","extended.family","family")) } ## ziplss gevlss <- function(link=list("identity","identity","logit")) { ## General family for GEV location scale model... ## so mu is mu1, rho = log(sigma) is mu2 and xi is mu3 ## 1. get derivatives wrt mu, rho and xi. ## 2. get required link derivatives and tri indices. ## 3. transform derivs to derivs wrt eta (gamlss.etamu). ## 4. get the grad and Hessian etc for the model ## via a call to gamlss.gH ## first deal with links and their derivatives... if (length(link)!=3) stop("gevlss requires 3 links specified as character strings") okLinks <- list(c("log", "identity"),"identity",c("identity","logit")) stats <- list() for (i in 1:3) { if (link[[i]] %in% okLinks[[i]]) stats[[i]] <- make.link(link[[i]]) else stop(link[[i]]," link not available for mu parameter of gaulss") fam <- structure(list(link=link[[i]],canonical="none",linkfun=stats[[i]]$linkfun, mu.eta=stats[[i]]$mu.eta), class="family") fam <- fix.family.link(fam) stats[[i]]$d2link <- fam$d2link stats[[i]]$d3link <- fam$d3link stats[[i]]$d4link <- fam$d4link } if (link[[3]]=="logit") { ## shifted logit link to confine xi to (-1,.5) ## Smith '85 Biometrika shows that -1 limit needed for MLE consistency ## but would need -0.5 for normality... stats[[3]]$linkfun <- function(mu) binomial()$linkfun((mu + 1)/1.5) stats[[3]]$mu.eta <- function(eta) binomial()$mu.eta(eta)*1.5 stats[[3]]$linkinv <- function(eta) 1.5* binomial()$linkinv(eta) - 1 stats[[3]]$d2link <- function(mu) { mu <- (mu+ 1)/1.5; (1/(1 - mu)^2 - 1/mu^2)/1.5^2} stats[[3]]$d3link <- function(mu) { mu <- (mu+ 1)/1.5; (2/(1 - mu)^3 + 2/mu^3)/1.5^3} stats[[3]]$d4link <- function(mu) { mu <- (mu+ 1)/1.5; (6/(1-mu)^4 - 6/mu^4)/1.5^4} } residuals <- function(object,type=c("deviance","pearson","response")) { mu <- object$fitted[,1] rho <- object$fitted[,2] xi <- object$fitted[,3] y <- object$y fv <- mu + exp(rho)*(gamma(1-xi)-1)/xi eps <- 1e-7; xi[xi>=0&xi-eps] <- -eps type <- match.arg(type) if (type=="deviance") { rsd <- (xi+1)/xi * log(1+(y-mu)*exp(-rho)*xi) + (1+(y-mu)*exp(-rho)*xi)^(-1/xi) + (1+xi)*log(1+xi) - (1 + xi) ## saturated part rsd <- sqrt(pmax(0,rsd))*sign(y-fv) } else if (type=="pearson") { sd <- exp(rho)/xi*sqrt(pmax(0,gamma(1-2*xi)-gamma(1-xi)^2)) rsd <- (y-fv)/sd } else { rsd <- y-fv } rsd } postproc <- expression({ ## code to evaluate in estimate.gam, to evaluate null deviance ## It's difficult to define a sensible version of this that ensures ## that the data fall in the support of the null model, whilst being ## somehow equivalent to the full fit object$null.deviance <- NA }) ll <- function(y,X,coef,wt,family,offset=NULL,deriv=0,d1b=0,d2b=0,Hp=NULL,rank=0,fh=NULL,D=NULL) { ## function defining the gamlss GEV model log lik. ## deriv: 0 - eval ## 1 - grad and Hess ## 2 - diagonal of first deriv of Hess ## 3 - first deriv of Hess ## 4 - everything. if (!is.null(offset)) offset[[4]] <- 0 discrete <- is.list(X) jj <- attr(X,"lpi") ## extract linear predictor index eta <- if (discrete) Xbd(X$Xd,coef,k=X$kd,ks=X$ks,ts=X$ts,dt=X$dt,v=X$v,qc=X$qc,drop=X$drop,lt=X$lpid[[1]]) else X[,jj[[1]],drop=FALSE]%*%coef[jj[[1]]] if (!is.null(offset[[1]])) eta <- eta + offset[[1]] mu <- family$linfo[[1]]$linkinv(eta) ## mean etar <- if (discrete) Xbd(X$Xd,coef,k=X$kd,ks=X$ks,ts=X$ts,dt=X$dt,v=X$v,qc=X$qc,drop=X$drop,lt=X$lpid[[2]]) else X[,jj[[2]],drop=FALSE]%*%coef[jj[[2]]] ## log sigma if (!is.null(offset[[2]])) etar <- etar + offset[[2]] rho <- family$linfo[[2]]$linkinv(etar) ## log sigma etax <- if (discrete) Xbd(X$Xd,coef,k=X$kd,ks=X$ks,ts=X$ts,dt=X$dt,v=X$v,qc=X$qc,drop=X$drop,lt=X$lpid[[3]]) else X[,jj[[3]],drop=FALSE]%*%coef[jj[[3]]] ## shape parameter if (!is.null(offset[[3]])) etax <- etax + offset[[3]] xi <- family$linfo[[3]]$linkinv(etax) ## shape parameter ## Avoid xi == 0 - using a separate branch for xi==0 requires ## seperate treatment of derivative w.r.t. xi, and statistically ## brings us nothing. eps <- 1e-7 xi[xi>=0&xi-eps] <- -eps n <- length(y) l1 <- matrix(0,n,3) ## note that the derivative code is largely auto-generated, and ## auto-simplified. Optimized Maxima derivs exported as Maxima ## code, translated to R code in R, then processed in R to ## remove redundant auxiliary variables and their definitions. ## Modifications of auto code (but not the consequent substitutions) are ## flagged '## added'. Code post auto and non-auto modification has ## been tested against raw translated code. exp1 <- exp(1); ## facilitates lazy auto-translation ymu <- y - mu aa0 <- (xi*ymu)/exp1^rho # added ind <- which(aa0 <= -1) ## added if (FALSE&&length(ind)>0) { ## all added xii <- xi[ind] ## this idea is really not a good one - messes up derivatives when triggered erho <- exp1^rho[ind] eps1 <- 1-.Machine$double.eps^.25 ymu[ind] <- -erho/xii*eps1 aa0[ind] <- -eps1 } log.aa1 <- log1p(aa0) ## added aa1 <- aa0 + 1 # (xi*(y-mu))/exp1^rho+1; aa2 <- 1/xi; l <- sum((-aa2*(1+xi)*log.aa1)-1/aa1^aa2-rho); #if (length(ind)>0) cat(aa0[ind]," l = ",l,"\n") if (deriv>0) { ## first derivatives m, r, x... bb1 <- 1/exp1^rho; bb2 <- bb1*xi*ymu+1; l1[,1] <- (bb1*(xi+1))/bb2-bb1*bb2^((-1/xi)-1); cc2 <- ymu; cc0 <- bb1*xi*cc2 ## added log.cc3 <- log1p(cc0) ## added cc3 <- cc0 + 1 ##bb1*xi*cc2+1; l1[,2] <- (-bb1*cc2*cc3^((-1/xi)-1))+(bb1*(xi+1)*cc2)/cc3-1; dd3 <- xi+1; dd6 <- 1/cc3; dd7 <- log.cc3; dd8 <- 1/xi^2; l1[,3] <- (-(dd8*dd7-bb1*aa2*cc2*dd6)/cc3^aa2)+dd8*dd3*dd7- aa2*dd7-bb1*aa2*dd3*cc2*dd6; ## the second derivatives mm mr mx rr rx xx l2 <- matrix(0,n,6) ee1 <- 1/exp1^(2*rho); ee3 <- -1/xi; l2[,1] <- ee1*(ee3-1)*xi*aa1^(ee3-2)+(ee1*xi*(xi+1))/aa1^2; ff7 <- ee3-1; l2[,2] <- bb1*cc3^ff7+ee1*ff7*xi*cc2*cc3^(ee3-2)-(bb1*dd3)/cc3+ (ee1*xi*dd3*cc2)/cc3^2; gg7 <- -aa2; l2[,3] <- (-bb1*cc3^(gg7-1)*(log.cc3/xi^2-bb1*aa2*cc2*dd6))+ ee1*cc2*cc3^(gg7-2)+bb1*dd6-(ee1*(xi+1)*cc2)/cc3^2; hh4 <- cc2^2; l2[,4] <- bb1*cc2*cc3^ff7+ee1*ff7*xi*hh4*cc3^(ee3-2)- (bb1*dd3*cc2)/cc3+(ee1*xi*dd3*hh4)/cc3^2; l2[,5] <- (-bb1*cc2*cc3^(gg7-1)*(log.cc3/xi^2-bb1*aa2*cc2*dd6))+ ee1*hh4*cc3^(gg7-2)+bb1*cc2*dd6-(ee1*(xi+1)*hh4)/cc3^2; jj08 <- 1/cc3^2; jj12 <- 1/xi^3; jj13 <- 1/cc3^aa2; l2[,6] <- (-jj13*(dd8*dd7-bb1*aa2*cc2*dd6)^2)-jj13*(ee1*aa2*hh4*jj08+ 2*bb1*dd8*cc2*dd6-2*jj12*dd7)-2*jj12*dd3*dd7+2*dd8*dd7+ 2*bb1*dd8*dd3*cc2*dd6-2*bb1*aa2*cc2*dd6+ee1*aa2*dd3*hh4*jj08; ## need some link derivatives for derivative transform ig1 <- cbind(family$linfo[[1]]$mu.eta(eta),family$linfo[[2]]$mu.eta(etar), family$linfo[[3]]$mu.eta(etax)) g2 <- cbind(family$linfo[[1]]$d2link(mu),family$linfo[[2]]$d2link(rho), family$linfo[[3]]$d2link(xi)) } l3 <- l4 <- g3 <- g4 <- 0 ## defaults if (deriv>1) { ## the third derivatives ## order mmm mmr mmx mrr mrx mxx rrr rrx rxx xxx l3 <- matrix(0,n,10) kk1 <- 1/exp1^(3*rho); kk2 <- xi^2; l3[,1] <- (2*kk1*kk2*(xi+1))/aa1^3-kk1*(ee3-2)*(ee3-1)*kk2*aa1^(ee3-3); ll5 <- (xi*cc2)/exp1^rho+1; ll8 <- ee3-2; l3[,2] <- (-2*ee1*ff7*xi*ll5^ll8)-kk1*ll8*ff7*kk2*cc2*ll5^(ee3-3)- (2*ee1*xi*dd3)/ll5^2+(2*kk1*kk2*dd3*cc2)/ll5^3; mm10 <- cc3^(gg7-3); mm11 <- gg7-2; mm12 <- cc3^mm11; l3[,3] <- ee1*(gg7-1)*xi*mm12*(log.cc3/xi^2-(bb1*aa2*cc2)/cc3)-ee1*mm12- kk1*mm11*xi*cc2*mm10+kk1*cc2*mm10+ee1*dd3*jj08+ee1*xi*jj08- (2*kk1*xi*dd3*cc2)/cc3^3; l3[,4] <- (-bb1*cc3^ff7)-3*ee1*ff7*xi*cc2*cc3^ll8-kk1*ll8*ff7*kk2*hh4* cc3^(ee3-3)+(bb1*dd3)/cc3-(3*ee1*xi*dd3*cc2)/cc3^2+ (2*kk1*kk2*dd3*hh4)/cc3^3; oo10 <- gg7-1; oo13 <- log.cc3/xi^2; l3[,5] <- bb1*cc3^oo10*(bb1*oo10*cc2*dd6+oo13)+ee1*oo10*xi*cc2*mm12* (bb1*mm11*cc2*dd6+oo13)+ee1*aa2*cc2*mm12+ee1*oo10*cc2*mm12- bb1*dd6+2*ee1*dd3*cc2*jj08+ee1*xi*cc2*jj08- (2*xi*dd3*cc2^2)/(exp1^(3*rho)*cc3^3); pp07 <- (-1/xi)-1; pp08 <- cc3^pp07; l3[,6] <- (-bb1*pp08*(bb1*pp07*cc2*dd6+dd8*dd7)^2)-bb1*pp08* ((-ee1*pp07*hh4*jj08)+2*bb1*dd8*cc2*dd6-(2*dd7)/xi^3)- 2*ee1*cc2*jj08+(2*(xi+1)*hh4)/(exp1^(3*rho)*cc3^3); qq05 <- cc2^3; l3[,7] <- (-bb1*cc2*cc3^ff7)-3*ee1*ff7*xi*hh4*cc3^ll8- kk1*ll8*ff7*kk2*qq05*cc3^(ee3-3)+(bb1*dd3*cc2)/cc3- (3*ee1*xi*dd3*hh4)/cc3^2+(2*kk1*kk2*dd3*qq05)/cc3^3; rr17 <- log.cc3/xi^2-bb1*aa2*cc2*dd6; l3[,8] <- bb1*cc2*cc3^oo10*rr17+ee1*oo10*xi*hh4*mm12*rr17-2*ee1*hh4*mm12- kk1*mm11*xi*qq05*mm10+kk1*qq05*mm10-bb1*cc2*dd6+ 2*ee1*dd3*hh4*jj08+ee1*xi*hh4*jj08-(2*kk1*xi*dd3*qq05)/cc3^3; l3[,9] <- (-bb1*cc2*pp08*(bb1*pp07*cc2*dd6+dd8*dd7)^2)-bb1*cc2*pp08* ((-ee1*pp07*hh4*jj08)+2*bb1*dd8*cc2*dd6-(2*dd7)/xi^3)- 2*ee1*hh4*jj08+(2*(xi+1)*cc2^3)/(exp1^(3*rho)*cc3^3); tt08 <- 1/cc3^3; tt16 <- 1/xi^4; tt18 <- dd8*dd7-bb1*aa2*cc2*dd6; l3[,10] <- (-jj13*tt18^3)-3*jj13*(ee1*aa2*hh4*jj08+2*bb1*dd8*cc2*dd6-2*jj12*dd7)* tt18-jj13*((-2*kk1*aa2*qq05*tt08)-3*ee1*dd8*hh4*jj08-6*bb1*jj12*cc2*dd6+ 6*tt16*dd7)+6*tt16*dd3*dd7-6*jj12*dd7-6*bb1*jj12*dd3*cc2*dd6+ 6*bb1*dd8*cc2*dd6-3*ee1*dd8*dd3*hh4*jj08+3*ee1*aa2*hh4*jj08- 2*kk1*aa2*dd3*qq05*tt08; g3 <- cbind(family$linfo[[1]]$d3link(mu),family$linfo[[2]]$d3link(rho), family$linfo[[3]]$d3link(xi)) } if (deriv>3) { ## the fourth derivatives ## mmmm mmmr mmmx mmrr mmrx mmxx mrrr mrrx mrxx mxxx ## rrrr rrrx rrxx rxxx xxxx l4 <- matrix(0,n,15) uu1 <- 1/exp1^(4*rho); uu2 <- xi^3; l4[,1] <- uu1*(ee3-3)*(ee3-2)*(ee3-1)*uu2*aa1^(ee3-4)+(6*uu1*uu2*(xi+1))/aa1^4; vv09 <- ee3-3; l4[,2] <- 3*kk1*ll8*ff7*kk2*ll5^vv09+uu1*vv09*ll8*ff7*uu2*cc2*ll5^(ee3-4)- (6*kk1*kk2*dd3)/ll5^3+(6*uu1*uu2*dd3*cc2)/ll5^4; ww11 <- gg7-3; ww12 <- cc3^(gg7-4); ww15 <- cc3^ww11; l4[,3] <- (-kk1*mm11*oo10*kk2*ww15*(log.cc3/kk2-(bb1*aa2*cc2)/cc3))+ 2*kk1*mm11*xi*ww15-kk1*ww15+uu1*ww11*mm11*kk2*cc2*ww12- uu1*oo10*xi*cc2*ww12-uu1*ww11*xi*cc2*ww12+2*kk1*kk2*tt08+ 4*kk1*xi*dd3*tt08-(6*uu1*kk2*dd3*cc2)/cc3^4; l4[,4] <- 4*ee1*ff7*xi*ll5^ll8+5*kk1*ll8*ff7*kk2*cc2*ll5^vv09+ uu1*vv09*ll8*ff7*uu2*hh4*ll5^(ee3-4)+(4*ee1*xi*dd3)/ll5^2- (10*kk1*kk2*dd3*cc2)/ll5^3+(6*uu1*uu2*dd3*hh4)/ll5^4; yy18 <- log.cc3/kk2; l4[,5] <- (-2*ee1*oo10*xi*mm12*(bb1*mm11*cc2*dd6+yy18))- kk1*mm11*oo10*kk2*cc2*ww15*(bb1*ww11*cc2*dd6+yy18)- 2*ee1*aa2*mm12-2*ee1*oo10*mm12-2*kk1*mm11*oo10*xi*cc2*ww15- kk1*oo10*cc2*ww15-kk1*mm11*cc2*ww15-2*ee1*dd3*jj08- 2*ee1*xi*jj08+2*kk1*kk2*cc2*tt08+8*kk1*xi*dd3*cc2*tt08- (6*kk2*dd3*cc2^2)/(exp1^(4*rho)*cc3^4); l4[,6] <- ee1*oo10*xi*mm12*tt18^2-2*ee1*mm12*tt18-2*kk1*mm11*xi*cc2*ww15*tt18+ 2*kk1*cc2*ww15*tt18+ee1*oo10*xi*mm12*(ee1*aa2*hh4*jj08+2*bb1* dd8*cc2*dd6-(2*dd7)/xi^3)+4*kk1*cc2*ww15+2*uu1*ww11*xi*hh4*ww12- 4*uu1*hh4*ww12+2*ee1*jj08-4*kk1*dd3*cc2*tt08-4*kk1*xi*cc2*tt08+ (6*uu1*xi*dd3*hh4)/cc3^4; l4[,7] <- bb1*cc3^ff7+7*ee1*ff7*xi*cc2*cc3^ll8+6*kk1*ll8*ff7*kk2*hh4*cc3^vv09+ uu1*vv09*ll8*ff7*uu2*qq05*cc3^(ee3-4)-(bb1*dd3)/cc3+ (7*ee1*xi*dd3*cc2)/cc3^2-(12*kk1*kk2*dd3*hh4)/cc3^3+ (6*uu1*uu2*dd3*qq05)/cc3^4; l4[,8] <- (-bb1*cc3^oo10*(bb1*oo10*cc2*dd6+yy18))-3*ee1*oo10*xi*cc2*mm12* (bb1*mm11*cc2*dd6+yy18)-kk1*mm11*oo10*kk2*hh4*ww15* (bb1*ww11*cc2*dd6+yy18)-3*ee1*aa2*cc2*mm12-3*ee1*oo10*cc2*mm12- 2*kk1*mm11*oo10*xi*hh4*ww15-kk1*oo10*hh4*ww15-kk1*mm11*hh4*ww15+ bb1*dd6-4*ee1*dd3*cc2*jj08-3*ee1*xi*cc2*jj08+2*kk1*kk2*hh4*tt08+ 10*kk1*xi*dd3*hh4*tt08-(6*kk2*dd3*cc2^3)/(exp1^(4*rho)*cc3^4); ad17 <- 2*bb1*dd8*cc2*dd6; ad19 <- -(2*dd7)/xi^3; ad20 <- cc3^oo10; ad21 <- dd8*dd7; ad22 <- ad21+bb1*mm11*cc2*dd6; l4[,9] <- bb1*ad20*(bb1*oo10*cc2*dd6+ad21)^2+ee1*oo10*xi*cc2*mm12*ad22^2+ 2*ee1*aa2*cc2*mm12*ad22+2*ee1*oo10*cc2*mm12*ad22+ bb1*ad20*((-ee1*oo10*hh4*jj08)+ad17+ad19)+ee1*oo10*xi*cc2*mm12* ((-ee1*mm11*hh4*jj08)+ad17+ad19)+4*ee1*cc2*jj08-6*kk1*dd3*hh4*tt08- 4*kk1*xi*hh4*tt08+(6*xi*dd3*cc2^3)/(exp1^(4*rho)*cc3^4); ae16 <- dd8*dd7+bb1*pp07*cc2*dd6; l4[,10] <- (-bb1*pp08*ae16^3)-3*bb1*pp08*((-ee1*pp07*hh4*jj08)+ 2*bb1*dd8*cc2*dd6-2*jj12*dd7)*ae16-bb1*pp08*(2*kk1*pp07*qq05*tt08- 3*ee1*dd8*hh4*jj08-6*bb1*jj12*cc2*dd6+(6*dd7)/xi^4)+6*kk1*hh4*tt08- (6*(xi+1)*qq05)/(exp1^(4*rho)*cc3^4); af05 <- cc2^4; l4[,11] <- bb1*cc2*cc3^ff7+7*ee1*ff7*xi*hh4*cc3^ll8+6*kk1*ll8*ff7*kk2*qq05* cc3^vv09+uu1*vv09*ll8*ff7*uu2*af05*cc3^(ee3-4)-(bb1*dd3*cc2)/cc3+ (7*ee1*xi*dd3*hh4)/cc3^2-(12*kk1*kk2*dd3*qq05)/cc3^3+ (6*uu1*uu2*dd3*af05)/cc3^4; ag23 <- log.cc3/kk2-bb1*aa2*cc2*dd6; l4[,12] <- (-bb1*cc2*cc3^oo10*ag23)-3*ee1*oo10*xi*hh4*mm12*ag23- kk1*mm11*oo10*kk2*qq05*ww15*ag23+4*ee1*hh4*mm12+ 5*kk1*mm11*xi*qq05*ww15-4*kk1*qq05*ww15+uu1*ww11*mm11*kk2*af05*ww12- uu1*oo10*xi*af05*ww12-uu1*ww11*xi*af05*ww12+bb1*cc2*dd6- 4*ee1*dd3*hh4*jj08-3*ee1*xi*hh4*jj08+2*kk1*kk2*qq05*tt08+ 10*kk1*xi*dd3*qq05*tt08-(6*uu1*kk2*dd3*af05)/cc3^4; ah24 <- (-(2*dd7)/xi^3)+2*bb1*dd8*cc2*dd6+ee1*aa2*hh4*jj08; ah27 <- tt18^2; l4[,13] <- bb1*cc2*ad20*ah27+ee1*oo10*xi*hh4*mm12*ah27-4*ee1*hh4*mm12*tt18- 2*kk1*mm11*xi*qq05*ww15*tt18+2*kk1*qq05*ww15*tt18+bb1*cc2*ad20*ah24+ ee1*oo10*xi*hh4*mm12*ah24+6*kk1*qq05*ww15+2*uu1*ww11*xi*af05*ww12- 4*uu1*af05*ww12+4*ee1*hh4*jj08-6*kk1*dd3*qq05*tt08- 4*kk1*xi*qq05*tt08+(6*uu1*xi*dd3*af05)/cc3^4; l4[,14] <- (-bb1*cc2*pp08*ae16^3)-3*bb1*cc2*pp08*((-ee1*pp07*hh4*jj08)+ 2*bb1*dd8*cc2*dd6-2*jj12*dd7)*ae16-bb1*cc2*pp08*(2*kk1*pp07*qq05* tt08-3*ee1*dd8*hh4*jj08-6*bb1*jj12*cc2*dd6+(6*dd7)/xi^4)+ 6*kk1*qq05*tt08-(6*(xi+1)*cc2^4)/(exp1^(4*rho)*cc3^4); aj08 <- 1/cc3^4; aj20 <- 1/xi^5; aj23 <- (-2*jj12*dd7)+2*bb1*dd8*cc2*dd6+ee1*aa2*hh4*jj08; l4[,15] <- (-jj13*tt18^4)-6*jj13*aj23*tt18^2-3*jj13*aj23^2- 4*jj13*((-2*kk1*aa2*qq05*tt08)-3*ee1*dd8*hh4*jj08-6*bb1*jj12*cc2*dd6+ 6*tt16*dd7)*tt18-jj13*(6*uu1*aa2*af05*aj08+8*kk1*dd8*qq05*tt08+ 12*ee1*jj12*hh4*jj08+24*bb1*tt16*cc2*dd6-24*aj20*dd7)- 24*aj20*dd3*dd7+24*tt16*dd7+24*bb1*tt16*dd3*cc2*dd6- 24*bb1*jj12*cc2*dd6+12*ee1*jj12*dd3*hh4*jj08-12*ee1*dd8*hh4*jj08+ 8*kk1*dd8*dd3*qq05*tt08-8*kk1*aa2*qq05*tt08+6*uu1*aa2*dd3*af05*aj08; g4 <- cbind(family$linfo[[1]]$d4link(mu),family$linfo[[2]]$d4link(rho), family$linfo[[3]]$d4link(xi)) } if (deriv) { i2 <- family$tri$i2; i3 <- family$tri$i3 i4 <- family$tri$i4 ## transform derivates w.r.t. mu to derivatives w.r.t. eta... de <- gamlss.etamu(l1,l2,l3,l4,ig1,g2,g3,g4,i2,i3,i4,deriv-1) ## get the gradient and Hessian... ret <- gamlss.gH(X,jj,de$l1,de$l2,i2,l3=de$l3,i3=i3,l4=de$l4,i4=i4, d1b=d1b,d2b=d2b,deriv=deriv-1,fh=fh,D=D) } else ret <- list() ret$l <- l; ret } ## end ll gevlss initialize <- expression({ ## start out with xi close to zero. If xi==0 then ## mean is mu + sigma*gamma and var is sigma^2*pi^2/6 ## where sigma = exp(rho) and gamma is Euler's constant. ## idea is to regress g(y) on model matrix for mean, and then ## to regress the corresponding log absolute residuals on ## the model matrix for log(sigma) - may be called in both ## gam.fit5 and initial.spg... note that appropriate E scaling ## for full calculation may be inappropriate for initialization ## which is basically penalizing something different here. ## best we can do here is to use E only as a regularizer. .euler <- 0.5772156649015328606065121 ## Euler's constant n <- rep(1, nobs) ## should E be used unscaled or not?.. use.unscaled <- if (!is.null(attr(E,"use.unscaled"))) TRUE else FALSE if (is.null(start)) { jj <- attr(x,"lpi") if (is.list(x)) { ## discrete case ## LP 1... start <- rep(0,max(unlist(jj))) yt1 <- if (family$link[[1]]=="identity") y else family$linfo[[1]]$linkfun(abs(y)+max(y)*1e-7) R <- suppressWarnings(chol(XWXd(x$Xd,w=rep(1,length(y)),k=x$kd,ks=x$ks,ts=x$ts,dt=x$dt, v=x$v,qc=x$qc,nthreads=1,drop=x$drop,lt=x$lpid[[1]])+crossprod(E[,jj[[1]]]),pivot=TRUE)) Xty <- XWyd(x$Xd,rep(1,length(y)),yt1,x$kd,x$ks,x$ts,x$dt,x$v,x$qc,x$drop,lt=x$lpid[[1]]) piv <- attr(R,"pivot");rrank <- attr(R,"rank");startji <- rep(0,ncol(R)) if (rrank1e-9*abs(lds[1]))==0) break g[1] <- g[1] * exp(th[1]) ## work on log scale for mu H <- matrix(0,3,3) ## mu, th, rh diag(H) <- c(lds[8],lds[5],lds[3]) H[1,2] <- H[2,1] <- lds[9] H[1,3] <- H[3,1] <- lds[10] H[2,3] <- H[3,2] <- lds[6] H[,1] <- H[,1]*exp(th[1]) H[1,-1] <- H[1,-1] * exp(th[1]) eh <- eigen(H,symmetric=TRUE) tol <- max(abs(eh$values))*1e-7 eh$values[eh$values>-tol] <- -tol step <- as.numeric(eh$vectors%*%((t(eh$vectors)%*%g)/eh$values)) ms <- max(abs(step)) if (ms>3) step <- step*3/ms ok <- FALSE while (!ok) { th1 <- th - step ld1 <- ldTweedie(y,exp(th1[1]),rho=th1[3],theta=th1[2],a=a,b=b,all.derivs=TRUE) if (sum(ld1[,1])0) (b + a*exp(-th[2]))/(1+exp(-th[2])) else (b*exp(th[2])+a)/(exp(th[2])+1) c(exp(th[1]),p,exp(th[3])) # mu, p, sigma } ## tw.null.fit twlss <- function(link=list("log","identity","identity"),a=1.01,b=1.99) { ## General family for Tweedie location scale model... ## so mu is mu1, rho = log(sigma) is mu2 and transformed p is mu3 ## Need to redo ldTweedie to allow vector p and phi ## -- advantage is that there is no point buffering ## 1. get derivatives wrt mu, rho and p. ## 2. get required link derivatives and tri indices. ## 3. transform derivs to derivs wrt eta (gamlss.etamu). ## 4. get the grad and Hessian etc for the model ## via a call to gamlss.gH ## first deal with links and their derivatives... if (length(link)!=3) stop("gevlss requires 3 links specified as character strings") okLinks <- list(c("log", "identity", "sqrt"),"identity",c("identity")) stats <- list() for (i in 1:3) { if (link[[i]] %in% okLinks[[i]]) stats[[i]] <- make.link(link[[i]]) else stop(link[[i]]," link not available for mu parameter of twlss") fam <- structure(list(link=link[[i]],canonical="none",linkfun=stats[[i]]$linkfun, mu.eta=stats[[i]]$mu.eta), class="family") fam <- fix.family.link(fam) stats[[i]]$d2link <- fam$d2link stats[[i]]$d3link <- fam$d3link stats[[i]]$d4link <- fam$d4link } env <- new.env(parent = .GlobalEnv) assign(".a",a, envir = env);assign(".b",b, envir = env) residuals <- function(object,type=c("deviance","pearson","response")) { a <- get(".a");b <- get(".b") type <- match.arg(type) mu <- object$fitted.values[,1] p <- object$fitted.values[,2] ind <- p > 0; ethi <- exp(-p[ind]);ethni <- exp(p[!ind]) p[ind] <- (b+a*ethi)/(1+ethi) p[!ind] <- (b*ethni+a)/(ethni+1) phi <- exp(object$fitted.values[,3]) if (type=="pearson") { rsd <- (object$y-mu)/sqrt(phi*mu^p) ## Pearson } else if (type=="response") rsd <- object$y-mu else { y1 <- object$y + (object$y == 0) theta <- (y1^(1 - p) - mu^(1 - p))/(1 - p) kappa <- (object$y^(2 - p) - mu^(2 - p))/(2 - p) rsd <- sign(object$y-mu)*sqrt(pmax(2 * (object$y * theta - kappa) * object$prior.weights/phi,0)) } return(rsd) ## (y-mu)/sigma } postproc <- expression({ ## code to evaluate in estimate.gam, to evaluate null deviance ## used for dev explained - really a mean scale concept. ## makes no sense to use single scale param here... tw.para <- tw.null.fit(object$y) ## paramaters mu, p and phi tw.y1 <- object$y + (object$y == 0) tw.theta <- (tw.y1^(1 - tw.para[2]) - tw.para[1]^(1 - tw.para[2]))/(1 - tw.para[2]) tw.kappa <- (object$y^(2 - tw.para[2]) - tw.para[1]^(2 - tw.para[2]))/(2 - tw.para[2]) object$null.deviance <- sum(pmax(2 * (object$y * tw.theta - tw.kappa) * object$prior.weights/exp(object$fitted.values[,3]),0)) }) ll <- function(y,X,coef,wt,family,offset=NULL,deriv=0,d1b=0,d2b=0,Hp=NULL,rank=0,fh=NULL,D=NULL) { ## function defining the gamlss Tweedie model log lik. ## deriv: 0 - eval ## 1 - grad and Hess ## 2 - diagonal of first deriv of Hess ## 3 - first deriv of Hess ## 4 - everything. ## This family does not have code for 3 and 4 if (is.null(offset)) offset <- list(0,0,0) else offset[[4]] <- 0 for (i in 1:3) if (is.null(offset[[i]])) offset[[i]] <- 0 jj <- attr(X,"lpi") ## extract linear predictor index eta <- X[,jj[[1]],drop=FALSE]%*%coef[jj[[1]]] + offset[[1]] mu <- family$linfo[[1]]$linkinv(eta) ## mean theta <- X[,jj[[2]],drop=FALSE]%*%coef[jj[[2]]] +offset[[2]] ## transformed p rho <- X[,jj[[3]],drop=FALSE]%*%coef[jj[[3]]] +offset[[3]] ## log scale parameter a <- get(".a");b <- get(".b") ld <- ldTweedie(y,mu=mu,p=NA,phi=NA,rho=rho,theta=theta,a=a,b=b,all.derivs=TRUE) ## m, t, r ; mm, mt, mr, tt, tr, rr l <- sum(ld[,1]) l1 <- cbind(ld[,7],ld[,4],ld[,2]) l2 <- cbind(ld[,8],ld[,9],ld[,10],ld[,5],ld[,6],ld[,3]) ig1 <- cbind(family$linfo[[1]]$mu.eta(eta),family$linfo[[2]]$mu.eta(theta), family$linfo[[3]]$mu.eta(rho)) g2 <- cbind(family$linfo[[1]]$d2link(mu),family$linfo[[2]]$d2link(theta), family$linfo[[3]]$d2link(rho)) n <- length(y) l3 <- l4 <- g3 <- g4 <- 0 ## defaults if (deriv) { i2 <- family$tri$i2;#i3 <- i4 <- 0 i3 <- family$tri$i3;i4 <- family$tri$i4 ## transform derivates w.r.t. mu to derivatives w.r.t. eta... de <- gamlss.etamu(l1,l2,l3,l4,ig1,g2,g3,g4,i2,i3,i4,0) ## get the gradient and Hessian... ret <- gamlss.gH(X,jj,de$l1,de$l2,i2,l3=de$l3,i3=i3,l4=de$l4,i4=i4, d1b=d1b,d2b=d2b,deriv=0,fh=fh,D=D) } else ret <- list() ret$l <- l; ret } ## end ll twlss initialize <- expression({ ## idea is to regress g(y) on model matrix for mean, and then ## to regress the corresponding log absolute scaled residuals on ## the model matrix for log(sigma) - may be called in both ## gam.fit5 and initial.spg... note that appropriate E scaling ## for full calculation may be inappropriate for initialization ## which is basically penalizing something different here. ## best we can do here is to use E only as a regularizer. ## initial theta params are zero for p = 1.5 n <- rep(1, nobs) ## should E be used unscaled or not?.. use.unscaled <- if (!is.null(attr(E,"use.unscaled"))) TRUE else FALSE if (is.null(start)) { jj <- attr(x,"lpi") start <- rep(0,ncol(x)) yt1 <- if (family$link[[1]]=="identity") y else family$linfo[[1]]$linkfun(abs(y)+max(y)*1e-7) x1 <- x[,jj[[1]],drop=FALSE] e1 <- E[,jj[[1]],drop=FALSE] ## square root of total penalty #ne1 <- norm(e1); if (ne1==0) ne1 <- 1 if (use.unscaled) { qrx <- qr(rbind(x1,e1)) x1 <- rbind(x1,e1) startji <- qr.coef(qr(x1),c(yt1,rep(0,nrow(E)))) startji[!is.finite(startji)] <- 0 } else startji <- pen.reg(x1,e1,yt1) ## now the scale parameter start[jj[[1]]] <- startji mu1 <- family$linfo[[1]]$linkinv(x[,jj[[1]],drop=FALSE]%*%start[jj[[1]]]) lres1 <- log(abs((y-mu1)/mu1^1.5)) x1 <- x[,jj[[3]],drop=FALSE];e1 <- E[,jj[[3]],drop=FALSE] #ne1 <- norm(e1); if (ne1==0) ne1 <- 1 if (use.unscaled) { x1 <- rbind(x1,e1) startji <- qr.coef(qr(x1),c(lres1,rep(0,nrow(E)))) startji[!is.finite(startji)] <- 0 } else startji <- pen.reg(x1,e1,lres1) start[jj[[3]]] <- startji } ## is.null(start) }) ## initialize twlss environment(ll) <- environment(residuals) <- env structure(list(family="twlss",ll=ll,link=paste(link),nlp=3, tri = trind.generator(3), ## symmetric indices for accessing derivative arrays initialize=initialize,postproc=postproc,residuals=residuals, linfo = stats, ## link information list d2link=1,d3link=1,d4link=1, ## signals to fix.family.link that all done ls=1, ## signals that ls not needed here available.derivs = 0 ## no higher derivs ),class = c("general.family","extended.family","family")) } ## end twlss lb.linkfun <- function(mu,b=-7) { ## lower bound link function - see gammals for related routines. eta <- mub <- mu-b ii <- mub < .Machine$double.eps if (any(ii)) eta[ii] <- log(.Machine$double.eps) jj <- mub > -log(.Machine$double.eps) if (any(jj)) eta[jj] <- mub[jj] jj <- !jj & !ii if (any(jj)) eta[jj] <- log(exp(mub[jj])-1) eta } ## lb.linkfun gammals <- function(link=list("identity","log"),b=-7) { ## General family for gamma location scale model... ## parameterization is in terms of log mean and log scale. ## so log(mu) is mu1, scale = log(sigma) is mu2 ## 1. get derivatives wrt mu, rho and xi. ## 2. get required link derivatives and tri indices. ## 3. transform derivs to derivs wrt eta (gamlss.etamu). ## 4. get the grad and Hessian etc for the model ## via a call to gamlss.gH ## first deal with links and their derivatives... if (length(link)!=2) stop("gammals requires 2 links specified as character strings") okLinks <- list(c("identity"),c("identity","log")) stats <- list() for (i in 1:2) { if (link[[i]] %in% okLinks[[i]]) stats[[i]] <- make.link(link[[i]]) else stop(link[[i]]," link not available for mu parameter of gammals") fam <- structure(list(link=link[[i]],canonical="none",linkfun=stats[[i]]$linkfun, mu.eta=stats[[i]]$mu.eta), class="family") fam <- fix.family.link(fam) stats[[i]]$d2link <- fam$d2link stats[[i]]$d3link <- fam$d3link stats[[i]]$d4link <- fam$d4link } if (link[[2]]=="log") { ## g^{-1}(eta) = b + log(1+exp(eta)) link stats[[2]]$valideta <- function(eta) TRUE stats[[2]]$linkfun <- eval(parse(text=paste("function(mu,b=",b,") {\n eta <- mub <- mu-b;\n", "ii <- mub < .Machine$double.eps;\n if (any(ii)) eta[ii] <- log(.Machine$double.eps);\n", "jj <- mub > -log(.Machine$double.eps);if (any(jj)) eta[jj] <- mub[jj];\n", "jj <- !jj & !ii;if (any(jj)) eta[jj] <- log(exp(mub[jj])-1);eta }"))) stats[[2]]$mu.eta <- eval(parse(text=paste("function(eta,b=",b,") {\n", "ii <- eta < 0;eta <- exp(-eta*sign(eta))\n", "if (any(ii)) { ei <- eta[ii];eta[ii] <- ei/(1+ei)}\n", "ii <- !ii;if (any(ii)) eta[ii] <- 1/(1+eta[ii])\n", "eta }\n"))) stats[[2]]$linkinv <- eval(parse(text=paste("function(eta,b=",b,") {\n", "mu <- eta;ii <- eta > -log(.Machine$double.eps)\n", "if (any(ii)) mu[ii] <- b + eta[ii]\n", "ii <- !ii;if (any(ii)) mu[ii] <- b + log(1 + exp(eta[ii]))\n", "mu }\n"))) stats[[2]]$d2link <- eval(parse(text=paste("function(mu,b=",b,") {\n", "eta <- lb.linkfun(mu,b=b); ii <- eta > 0\n", "eta <- exp(-eta*sign(eta))\n", "if (any(ii)) { ei <- eta[ii];eta[ii] <- -(ei^2 + ei) }\n", "ii <- !ii;if (any(ii)) { ei <- eta[ii];eta[ii] <- -(1+ei)/ei^2 }\n", "eta }\n"))) stats[[2]]$d3link <- eval(parse(text=paste("function(mu,b=",b,") {\n", "eta <- lb.linkfun(mu,b=b);ii <- eta > 0\n", "eta <- exp(-eta*sign(eta))\n", "if (any(ii)) { ei <- eta[ii]; eta[ii] <- (2*ei^2+ei)*(ei+1) }\n", "ii <- !ii;if (any(ii)) { ei <- eta[ii]; eta[ii] <- (2+ei)*(1+ei)/ei^3 }\n", "eta }\n"))) stats[[2]]$d4link <- eval(parse(text=paste("function(mu,b=",b,") {\n", "eta <- lb.linkfun(mu,b=b);ii <- eta > 0\n", "eta <- exp(-eta*sign(eta))\n", "if (any(ii)) { ei <- eta[ii];eta[ii] <- -(6*ei^3+6*ei^2+ei)*(ei+1) }\n", "ii <- !ii;if (any(ii)) { ei <- eta[ii]; eta[ii] <- -(6+6*ei+ei^2)*(1+ei)/ei^4 }\n", "eta }\n"))) } residuals <- function(object,type=c("deviance","pearson","response")) { mu <- object$fitted.values[,1] rho <- object$fitted.values[,2] y <- object$y type <- match.arg(type) if (type=="deviance") { rsd <- 2*((y-mu)/mu-log(y/mu))*exp(-rho) rsd <- sqrt(pmax(0,rsd))*sign(y-mu) } else if (type=="pearson") { (y-mu)/(exp(rho)*mu) } else { rsd <- y-mu } rsd } postproc <- expression({ ## code to evaluate in estimate.gam, to evaluate null deviance ## It's difficult to define a sensible version of this that ensures ## that the data fall in the support of the null model, whilst being ## somehow equivalent to the full fit object$fitted.values[,1] <- exp(object$fitted.values[,1]) .my <- mean(object$y) object$null.deviance <- sum(((object$y-.my)/.my-log(object$y/.my))*exp(-object$fitted.values[,2]))*2 }) ll <- function(y,X,coef,wt,family,offset=NULL,deriv=0,d1b=0,d2b=0,Hp=NULL,rank=0,fh=NULL,D=NULL) { ## function defining the gamlss gamma model log lik. ## deriv: 0 - eval ## 1 - grad and Hess ## 2 - diagonal of first deriv of Hess ## 3 - first deriv of Hess ## 4 - everything. if (!is.null(offset)) offset[[3]] <- 0 discrete <- is.list(X) jj <- attr(X,"lpi") ## extract linear predictor index eta <- if (discrete) Xbd(X$Xd,coef,k=X$kd,ks=X$ks,ts=X$ts,dt=X$dt,v=X$v,qc=X$qc,drop=X$drop,lt=X$lpid[[1]]) else X[,jj[[1]],drop=FALSE]%*%coef[jj[[1]]] if (!is.null(offset[[1]])) eta <- eta + offset[[1]] ## log mu mu <- family$linfo[[1]]$linkinv(eta) ## mean etat <- if (discrete) Xbd(X$Xd,coef,k=X$kd,ks=X$ks,ts=X$ts,dt=X$dt,v=X$v,qc=X$qc,drop=X$drop,lt=X$lpid[[2]]) else X[,jj[[2]],drop=FALSE]%*%coef[jj[[2]]] if (!is.null(offset[[2]])) etat <- etat + offset[[2]] th <- family$linfo[[2]]$linkinv(etat) ## log sigma eth <- exp(-th) ## 1/exp1^th; logy <- log(y); ethmu <- exp(-th-mu) ethmuy <- ethmu*y etlymt <- eth*(logy-mu-th) n <- length(y) l <- sum(etlymt-logy-ethmuy-lgamma(eth)) ## l if (deriv>0) { l1 <- matrix(0,n,2) l1[,1] <- ethmuy-eth ## lm digeth <- digamma(eth) l1[,2] <- -etlymt+ethmuy+eth*digeth-eth; ## lt ## the second derivatives l2 <- matrix(0,n,3) ## order mm,mt,tt l2[,1] <- -ethmuy; ## lmm l2[,2] <- eth-ethmuy; ## lmt eth2 <- eth^2;treth <- trigamma(eth) l2[,3] <- etlymt-ethmuy-treth*eth2-eth*digeth+2*eth; #ltt ## need some link derivatives for derivative transform ig1 <- cbind(family$linfo[[1]]$mu.eta(eta),family$linfo[[2]]$mu.eta(etat)) g2 <- cbind(family$linfo[[1]]$d2link(mu),family$linfo[[2]]$d2link(th)) } l3 <- l4 <- g3 <- g4 <- 0 ## defaults if (deriv>1) { ## the third derivatives ## order mmm,mmt,mtt,ttt l3 <- matrix(0,n,4) l3[,1] <- ethmuy; ## lmmm l3[,2] <- ethmuy; ## lmmt l3[,3] <- ethmuy-eth; ## lmtt eth3 <- eth2*eth; g3eth <- psigamma(eth,deriv=2) l3[,4] <- -etlymt+ethmuy+g3eth*eth3+3*treth*eth2+eth*digeth-3*eth; ## lttt g3 <- cbind(family$linfo[[1]]$d3link(mu),family$linfo[[2]]$d3link(th)) } if (deriv>3) { ## the fourth derivatives ## order mmmm,mmmt,mmtt,mttt,tttt l4 <- matrix(0,n,5) l4[,1] <- -ethmuy; ## lmmmm l4[,2] <- -ethmuy; ## lmmmt l4[,3] <- -ethmuy; ## lmmtt l4[,4] <- eth-ethmuy; ## lmttt eth4 <- eth3*eth l4[,5] <- etlymt-ethmuy-psigamma(eth,deriv=3)*eth4-6*g3eth*eth3- 7*treth*eth2-eth*digeth+4*eth; ## ltttt g4 <- cbind(family$linfo[[1]]$d4link(mu),family$linfo[[2]]$d4link(th)) } if (deriv) { i2 <- family$tri$i2; i3 <- family$tri$i3 i4 <- family$tri$i4 ## transform derivates w.r.t. mu to derivatives w.r.t. eta... de <- gamlss.etamu(l1,l2,l3,l4,ig1,g2,g3,g4,i2,i3,i4,deriv-1) ## get the gradient and Hessian... ret <- gamlss.gH(X,jj,de$l1,de$l2,i2,l3=de$l3,i3=i3,l4=de$l4,i4=i4, d1b=d1b,d2b=d2b,deriv=deriv-1,fh=fh,D=D) } else ret <- list() ret$l <- l; ret } ## end ll gammals initialize <- expression({ ## regress X[,[jj[[1]]] on log(y) then X[,jj[[2]]] on log abs ## raw residuals. ## note that appropriate E scaling ## for full calculation may be inappropriate for initialization ## which is basically penalizing something different here. ## best we can do here is to use E only as a regularizer. n <- rep(1, nobs) ## should E be used unscaled or not?.. use.unscaled <- if (!is.null(attr(E,"use.unscaled"))) TRUE else FALSE if (is.null(start)) { jj <- attr(x,"lpi") if (!is.null(offset)) offset[[3]] <- 0 yt1 <- log(y+max(y)*.Machine$double.eps^.75) if (!is.null(offset[[1]])) yt1 <- yt1 - offset[[1]] if (is.list(x)) { ## discrete case start <- rep(0,max(unlist(jj))) R <- suppressWarnings(chol(XWXd(x$Xd,w=rep(1,length(y)),k=x$kd,ks=x$ks,ts=x$ts,dt=x$dt,v=x$v, qc=x$qc,nthreads=1,drop=x$drop,lt=x$lpid[[1]])+crossprod(E[,jj[[1]]]),pivot=TRUE)) Xty <- XWyd(x$Xd,rep(1,length(y)),yt1,x$kd,x$ks,x$ts,x$dt,x$v,x$qc,x$drop,lt=x$lpid[[1]]) piv <- attr(R,"pivot") rrank <- attr(R,"rank") startji <- rep(0,ncol(R)) if (rrank1 return(list(ni = oo$T[1:oo$off[n]]+1,off=oo$off)) } tri.pen <- function(X,T) { ## finds a sparse approximate TPS penalty, based on the points in X, ## with triangulation T. Rows of X are points. Rows of T index vertices ## of triangles in X. nn <- tri2nei(T) ## get neighbour list from T ## now obtain generalized FD penalty... n <- nrow(X);d <- ncol(X); D <- rep(0,3*(nn$off[n]+n)) ## storage for oo <- .C(C_nei_penalty,as.double(X),as.integer(n),as.integer(d),D=as.double(D), ni=as.integer(nn$ni-1),ii=as.integer(nn$ni*0),off=as.integer(nn$off), as.integer(2),as.integer(0),kappa=as.double(rep(0,n))); ## unpack into sparse matrices... ni <- oo$off[n] ii <- c(1:n,oo$ii[1:ni]+1) ## row index jj <- c(1:n,oo$ni[1:ni]+1) ## col index ni <- length(ii) Kx <- sparseMatrix(i=ii,j=jj,x=oo$D[1:ni],dims=c(n,n)) Kz <- sparseMatrix(i=ii,j=jj,x=oo$D[1:ni+ni],dims=c(n,n)) Kxz <- sparseMatrix(i=ii,j=jj,x=oo$D[1:ni+2*ni],dims=c(n,n)) list(Kx=Kx,Kz=Kz,Kxz=Kxz) } ## Efficient stable full rank cubic spline routines, based on ## deHoog and Hutchinson, 1987 and Hutchinson and deHoog, ## 1985.... setup.spline <- function(x,w=rep(1,length(x)),lambda=1,tol=1e-9) { ## setup a cubic smoothing spline given data locations in x. ## ties will be treated by removing duplicate x's, and averaging corresponding ## y's. Averaging is \sum_i y_i w_i^2 / \sum_i w_i^2, and the weight ## assigned to this average is then w_a^2 = \sum_i w_i^2... ## spline object has to record duplication information, as well as ## rotations defining spline. n <- length(x) ind <- order(x) x <- x[ind] ## sort x w <- w[ind] U <- V <- rep(0,4*n) diagA <- rep(0,n) lb <- rep(0,2*n) oo <- .C(C_sspl_construct,as.double(lambda),x=as.double(x),w=as.double(w),U=as.double(U),V=as.double(V), diagA=as.double(diagA),lb=as.double(lb),n=as.integer(n),tol=as.double(tol)) list(trA=sum(oo$diagA), ## trace of influence matrix U=oo$U,V=oo$V, ## spline defining Givens rotations lb=oo$lb, ## final lower band x=x, ## original x sequence, ordered ind=ind, ## x0 <- x; x0[ind] <- x, puts original ordering in x0 w=w, ## original weights ns=oo$n, ## number of unique x values (maximum spline rank) tol=tol) ## tolerance used to judge tied x values } apply.spline <- function(spl,y) { ## Use cubic spline object spl, from setup.spline, to smooth data in y. if (is.matrix(y)) { m <- ncol(y) y <- y[spl$ind,] ## order as x } else { m <- 1 y <- y[spl$ind] } n <- length(spl$x) oo <- .C(C_sspl_mapply,f = as.double(y),x=as.double(spl$x),as.double(spl$w), U=as.double(spl$U),as.double(spl$V),n=as.integer(spl$ns), nf=as.integer(n),tol=as.double(spl$tol),m=as.integer(m)) if (is.matrix(y)) { y <- matrix(oo$f,n,m) y[spl$ind,] <- y ## original order } else { y[spl$ind] <- oo$f } y } ## kd tree/k nearest neighbout related routines.... kd.vis <- function(kd,X,cex=.5) { ## code visualizes a kd tree for points in rows of X ## kd <- kd.tree(X) produces correct tree. ## this worked with the structures used when ## kd tree was written out to R vecotrs and the read ## back in. Does not work with revised approach (would ## need an explicit helper function to do the write out) if (ncol(X)!=2) stop("only deals with 2D case") ##n <- nrow(X) d <- ncol(X) nb <- kd$idat[1] dd <- matrix(kd$ddat[-1],nb,2*d,byrow=TRUE) lo <- dd[,1:d];hi <- dd[,1:d+d] rm(dd) ll <- min(X[,1]); ul<- max(X[,1]) w <- ul-ll ind <- lo[,1] < ll-w/10;lo[ind,1] <- ll-w/10 ind <- hi[,1] > ul+w/10;hi[ind,1] <- ul+w/10 ll <- min(X[,2]);ul <- max(X[,2]) w <- ul-ll ind <- lo[,2] < ll-w/10;lo[ind,2] <- ll-w/10 ind <- hi[,2] > ul+w/10;hi[ind,2] <- ul+w/10 plot(X[,1],X[,2],pch=19,cex=cex,col=2) for (i in 1:nb) { rect(lo[i,1],lo[i,2],hi[i,1],hi[i,2]) } #points(X[,1],X[,2],pch=19,cex=cex,col=2) } nearest <- function(k,X,gt.zero = FALSE,get.a=FALSE) { ## The rows of X contain coordinates of points. ## For each point, this routine finds its k nearest ## neighbours, returning a list of 2, n by k matrices: ## ni - ith row indexes the rows of X containing ## the k nearest neighbours of X[i,] ## dist - ith row is the distances to the k nearest ## neighbours. ## a - area associated with each point, if get.a is TRUE ## ties are broken arbitrarily. ## gt.zero indicates that neighbours must have distances greater ## than zero... if (gt.zero) { Xu <- uniquecombs(X);ind <- attr(Xu,"index") ## Xu[ind,] == X } else { Xu <- X; ind <- 1:nrow(X)} if (k>nrow(Xu)) stop("not enough unique values to find k nearest") nobs <- length(ind) n <- nrow(Xu) d <- ncol(Xu) dist <- matrix(0,n,k) if (get.a) a <- 1:n else a=1 oo <- .C(C_k_nn,Xu=as.double(Xu),dist=as.double(dist),a=as.double(a),ni=as.integer(dist), n=as.integer(n),d=as.integer(d),k=as.integer(k),get.a=as.integer(get.a)) dist <- matrix(oo$dist,n,k)[ind,] rind <- 1:nobs rind[ind] <- 1:nobs ni <- matrix(rind[oo$ni+1],n,k)[ind,] if (get.a) a=oo$a[ind] else a <- NULL list(ni=ni,dist=dist,a=a) } # nearest #kd.tree <- function(X) { ## function to obtain kd tree for points in rows of X ## old version based on writing out tree to R # n <- nrow(X) ## number of points # d <- ncol(X) ## dimension of points # ## compute the number of boxes in the kd tree, nb # m <- 2;while (m < n) m <- m* 2; # nb = n * 2 - m %/% 2 - 1; # if (nb > m-1) nb = m - 1; # ## compute the storage requirements for the tree # nd = 1 + d * nb * 2 ## number of doubles # ni = 3 + 5 * nb + 2*n ## number of integers # oo <- .C(C_Rkdtree,as.double(X),as.integer(n),as.integer(d),idat = as.integer(rep(0,ni)), # ddat = as.double(rep(0,nd))) # list(idat=oo$idat,ddat=oo$ddat) #} kd.tree <- function(X) { ## Function to obtain kd tree for points in rows of X. ## Contains tree dumped as a vector of doubles with an attribute that is a vector ## of integers. Another attribute is the internal pointer to the tree. ## Redundant structure allows tree to be saved to disk and re-loaded. Pointer is ## set to NULL by this, but can tree can then be restored by kd.nearest and kd.radius ## and pointer reset. This works because documented behaviour is never to copy ## such external pointers within R - they are effectively global - so resetting resets ## it for every copy of the tree. kd <- .Call(C_Rkdtree,X) kd } kd.nearest <- function(kd,X,x,k) { ## Finds k nearest neigbours of each row of x within X. X has ## corresponding kd tree kd, stored as an external pointer: ## attribute "kd_ptr" of kd. Returns array of indices to rows in ## X, along with corresponding distances. nei <- .Call(C_Rkdnearest,kd,X,x,as.integer(k)) + 1 ## C to R } kd.radius <- function(kd,X,x,r){ ## find all points in kd tree (kd,X) in radius r of points in x. ## kd should come from kd.tree(X). ## neighbours of x[i,] in X are the rows given by ni[off[i]:(off[i+1]-1)] # m <- nrow(x); # off <- rep(0,m+1) off <- rep(as.integer(0),nrow(x)+1) xt <- t(x) ## required transposed in Rkradius ni <- .Call(C_Rkradius,kd,X,xt,as.double(r),off) + 1 list(ni=ni,off=off+1) } #kd.nearest <- function(kd,X,x,k) { ## given a set of points in rows of X, and corresponding kd tree, kd ## (produced by a call to kd.tree(X)), then this routine finds the ## k nearest neighbours in X, to the points in the rows of x. ## outputs: ni[i,] lists k nearest neighbours of X[i,]. ## dost[i,] is distance to those neighbours. ## note R indexing of output # n <- nrow(X) # m <- nrow(x) # ni <- matrix(0,m,k) # oo <- .C(C_Rkdnearest,as.double(X),as.integer(kd$idat),as.double(kd$ddat),as.integer(n),as.double(x), # as.integer(m), ni=as.integer(ni), dist=as.double(ni),as.integer(k)) # list(ni=matrix(oo$ni+1,m,k),dist=matrix(oo$dist,m,k)) #} #kd.radius <- function(kd,X,x,r) { ## find all points in kd tree (kd,X) in radius r of points in x. ## kd should come from kd.tree(X). ## neighbours of x[i,] in X are the rows given by ni[off[i]:(off[i+1]-1)] # m <- nrow(x); # off <- rep(0,m+1) ## do the work... # oo <- .C(C_Rkradius,as.double(r),as.integer(kd$idat),as.double(kd$ddat),as.double(X),as.double(t(x)), # as.integer(m),off=as.integer(off),ni=as.integer(0),op=as.integer(0)) # off <- oo$off # ni <- rep(0,off[m+1]) ## extract to R and clean up... # oo <- .C(C_Rkradius,as.double(r),as.integer(kd$idat),as.double(kd$ddat),as.double(X),as.double(t(x)), # as.integer(m),off=as.integer(off),ni=as.integer(ni),op=as.integer(1)) # list(off=off+1,ni=oo$ni+1) ## note R indexing here. #} ## kd.radius tieMatrix <- function(x) { ## takes matrix x, and produces sparse matrix P that maps list of unique ## rows to full set. Matrix of unique rows is returned in xu. ## If a smoothing penalty matrix, S, is set up based on rows of xu, ## then P%*%solve(t(P)%*%P + S,t(P)) is hat matrix. x <- as.matrix(x) n <- nrow(x) xu <- uniquecombs(x) if (nrow(xu)==nrow(x)) return(NULL) ind <- attr(xu,"index") x <- as.matrix(x) n <- nrow(x) P <- sparseMatrix(i=1:n,j=ind,x=rep(1,n),dims=c(n,nrow(xu))) return(list(P=P,xu=xu)) } ## sparse smooths must be initialized with... ## 1. a set of variable names, a blocking factor and a type. ######################################################### # routines for full rank cubic spline smoothers, based on # deHoog and Hutchinson, 1987. ######################################################### spasm.construct.cus <- function(object,data) { ## entry object inherits from "cus" & contains: ## * terms, the name of the argument of the smooth ## * block, the name of a blocking factor. Can be NULL. ## return object also has... ## * nobs - number of observations in total ## * nblock - number of blocks. ## * ind, list where ind[[i]] gives rows to which block i applies. ## * spl, and empty list which will contain intialised cubic ## spline smoothers for each block, once a smoothing parameter ## has been supplied... ##dat <- list() d <- length(object$terms) if (d != 1) stop("cubic spline only deals with 1D data") object$x <- get.var(object$term[1],data) object$nobs <- length(object$x) ind <- list() n <- length(object$x) ## if there is a blocking factor then set up indexes ## indicating which data go with which block... if (!is.null(object$block)) { block <- as.factor(get.var(object$block,data)) nb <- length(levels(block)) edf1 <- 0 for (i in 1:nb) { ind[[i]] <- (1:n)[block==levels(block)[i]] edf1 <- edf1 + length(unique(object$x[ind[[i]]])) ## max edf for this block } } else { ## all one block nb <- 1 ind[[1]] <- 1:n edf1 <- length(unique(object$x)) } object$nblock <- nb object$ind <- ind ## so ind[[i]] indexes the elements operated on by the ith smoother. object$spl <- list() object$edf0 <- 2*nb;object$edf1 <- edf1 class(object) <- "cus" object } spasm.sp.cus <- function(object,sp,w=rep(1,object$nobs),get.trH=FALSE,block=0,centre=FALSE) { ## Set up full cubic spline smooth, given new smoothing parameter and weights. ## In particular, construct the Givens rotations defining the ## smooth and compute the trace of the influence matrix. ## If block is non-zero, then it specifies which block to set up, otherwise ## all are set up. In either case w is assumed to be for the whole smoother, ## although only the values for the specified block(s) are used. ## If centre == TRUE then the spline is set up for centred smoothing, i.e. ## the results sum to zero. ## Note: w propto 1/std.dev(response) if (is.null(object$spl)) stop("object not fully initialized") trH <- 0 if (block==0) block <- 1:object$nblock for (i in block) { ##n <- length(object$ind[[i]]) object$spl[[i]] <- setup.spline(object$x[object$ind[[i]]],w=w[object$ind[[i]]],lambda=sp) trH <- trH + object$spl[[i]]$trA } object$sp=sp if (get.trH) { if (centre) { ## require correction for DoF lost by centring... for (i in block) { one <- rep(1,length(object$ind[[i]])) object$centre <- FALSE trH <- trH - mean(spasm.smooth(object,one,block=i)) } } object$trH <- trH } object$centre <- centre object } spasm.smooth.cus <- function(object,X,residual=FALSE,block=0) { ## apply smooth, or its residual operation to X. ## if block == 0 then apply whole thing, otherwise X must have the correct ## number of rows for the smooth block. if (block>0) { ## n <- length(object$ind[[block]]) if (object$centre) { X0 <- apply.spline(object$spl[[block]],X) if (is.matrix(X0)) { x0 <- colMeans(X0) X0 <- sweep(X0,2,x0) } else X0 <- X0 - mean(X0) if (residual) X <- X - X0 else X <- X0 } else { if (residual) X <- X - apply.spline(object$spl[[block]],X) else X <- apply.spline(object$spl[[block]],X) } } else for (i in 1:object$nblock) { ## work through all blocks ind <- object$ind[[i]] if (is.matrix(X)) { X0 <- apply.spline(object$spl[[i]],X[ind,]) if (object$centre) X0 <- sweep(X0,2,colMeans(X0)) if (residual) X[ind,] <- X[ind,] - X0 else X[ind,] <- X0 } else { X0 <- apply.spline(object$spl[[i]],X[ind]) if (object$centre) X0 <- X0 - mean(X0) if (residual) X[ind] <- X[ind] - X0 else X[ind] <- X0 } } X } ######################################################### ## The default sparse smooth class, which does nothing... ######################################################### spasm.construct.default <- function(object,data) { ## This smooth simply returns 0, under all circumstances. ## object might contain.... ## * block, the name of a blocking factor. Can be NULL. ## return object also has... ## * nblock - number of blocks. ## * ind, list where ind[[i]] gives rows to which block i applies. n <- nrow(data) if (!is.null(object$block)) { block <- as.factor(get.var(object$block,data)) nb <- length(levels(block)) for (i in 1:nb) { ind[[i]] <- (1:n)[block==levels(block)[i]] } } else { ## all one block nb <- 1 ind[[1]] <- 1:n } object$nblock <- nb object$ind <- ind ## so ind[[i]] indexes the elements operated on by the ith smoother. class(object) <- "default" object } spasm.sp.default <- function(object,sp,get.trH=FALSE) { ## Set up default null smoother. i.e. set trH=0, trH <- 0 if (get.trH) object$trH <- trH object$ldetH <- NA object } spasm.smooth.default <- function(object,X,residual=FALSE,block=0) { ## apply smooth, or its residual operation to X. ## if block == 0 then apply whole thing, otherwise X must have the correct ## number of rows for the smooth block. if (residual) return(X) else return(X*0) X } ## generics for sparse smooth classes... spasm.construct <- function(object,data) UseMethod("spasm.construct") spasm.sp <- function(object,sp,w=rep(1,object$nobs),get.trH=TRUE,block=0,centre=FALSE) UseMethod("spasm.sp") ## Note that w is assumed proportional to 1/std.dev(response) spasm.smooth <- function(object,X,residual=FALSE,block=0) UseMethod("spasm.smooth") spasm.range <- function(object,upper.prop=.5,centre=TRUE) { ## get reasonable smoothing parameter range for sparse smooth in object sp <- 1 edf <- spasm.sp(object,sp,get.trH=TRUE,centre=centre)$trH while (edf < object$edf0*1.01+.5) { sp <- sp /100 edf <- spasm.sp(object,sp,get.trH=TRUE,centre=centre)$trH } sp1 <- sp ## store smallest known good while (edf > object$edf0*1.01+.5) { sp <- sp * 100 edf <- spasm.sp(object,sp,get.trH=TRUE,centre=centre)$trH } sp0 <- sp while (edf < object$edf1*upper.prop) { sp1 <- sp1 / 100 edf <- spasm.sp(object,sp1,get.trH=TRUE,centre=centre)$trH } while (edf > object$edf1*upper.prop) { sp1 <- sp1 * 4 edf <- spasm.sp(object,sp1,get.trH=TRUE,centre=centre)$trH } c(sp1,sp0) ## small, large } mgcv/MD50000644000176200001440000002627013561447343011537 0ustar liggesusers71a2e6a53bdd59bd13e203b328ccbdae *ChangeLog 235b694ab012561f4d51afb654d784b2 *DESCRIPTION eb723b61539feef013de476e68b5c50a *GPL-2 357d52b17834fa06624621c077ba5a63 *NAMESPACE 0f1a7391129458fead407b1a2dbd71ed *R/bam.r 328cc0f51ee9575cda667a83c991f70e *R/coxph.r 49219d0ba453a70b1a53558d0975b714 *R/efam.r bba7848354bbb28961cf517091650509 *R/fast-REML.r fb6361860cce69ba4d6158c4514b3d05 *R/gam.fit3.r 0a6881d258450b850f78b8355570bc84 *R/gam.fit4.r 1b620b840ca67c9759639bd6e53824e3 *R/gam.sim.r 21d348eacdd13d660d27bbb7e33aecc1 *R/gamlss.r a6c21705b355506bdca51a636786b083 *R/gamm.r f4c20e36b4f1d42c5bf902270ba3515a *R/inla.r 10facb791e4cfd123d183f05660119c6 *R/jagam.r 9ed4259dda6a3ec97cf3a69c067a180a *R/mgcv.r 7ab20919c303882bb1406f2ff2a32680 *R/misc.r 16affc004cd2b26024513647a50e01bd *R/mvam.r bbbf91ab8cf360447836ee0c1f554496 *R/plots.r 2713ec55a87d4a7fd31ed5a85ad7335e *R/smooth.r d869c9c2658860f7a23e4590100939b2 *R/soap.r bde1774ce7903cabc57b3196f8872ea8 *R/sparse.r e468195a83fab90da8e760c2c3884bd3 *data/columb.polys.rda 40874e3ced720a596750f499ded8a60a *data/columb.rda e70536903ca327ade1496529ab817b60 *inst/CITATION 7e25ffb0d484bab0c35fad512a7ab1c2 *inst/po/de/LC_MESSAGES/R-mgcv.mo ebac5438e1028d84d64b193319a9146e *inst/po/de/LC_MESSAGES/mgcv.mo e8d8a8f6f5a86e91fb49b6c4dc96675b *inst/po/en@quot/LC_MESSAGES/R-mgcv.mo 569f2d290a14011211be1b009fc72724 *inst/po/en@quot/LC_MESSAGES/mgcv.mo dae0834c8cc06c95471b135d99cda7b2 *inst/po/fr/LC_MESSAGES/R-mgcv.mo 888812228a64dcb20a3dc6f7a93080d3 *inst/po/fr/LC_MESSAGES/mgcv.mo 1780bf7443ae918b06b90d1f6b71feae *inst/po/ko/LC_MESSAGES/R-mgcv.mo 521ebcd9d70d2163f2e7e4ec67760869 *inst/po/ko/LC_MESSAGES/mgcv.mo 1754621f2cbc91714f6575f8914ec0da *inst/po/pl/LC_MESSAGES/R-mgcv.mo 0d63fc78e4fde2471dd75825793c1ac4 *inst/po/pl/LC_MESSAGES/mgcv.mo 1f716ff54bb49f75188f92b830b49428 *man/Beta.Rd e7c91ae36c5d1ec720d210fd23140991 *man/FFdes.Rd 9d12d96a7f2dfe7faa1c112bf6631a8e *man/Predict.matrix.Rd 9c2573f0134dc2cbac7e11998e220558 *man/Predict.matrix.cr.smooth.Rd d0fa291cbbcef359c61e426f6ba38fbb *man/Predict.matrix.soap.film.Rd f12468625253dd3603907de233762fd6 *man/Rrank.Rd 53375daee3860f968e6b28f51f5d39ae *man/Sl.initial.repara.Rd 991a7e08485cdc1f3ffee00439f7e907 *man/Sl.repara.Rd 03a42d661d3908bfdd06e8eb2ccde4d2 *man/Sl.setup.Rd 69ae63833438a3af2963e39482f1d72f *man/Tweedie.Rd 981b3aaac13270c0d0573266bc1dc9eb *man/XWXd.Rd 98577aa92d0a16473b29b7ef73f37d82 *man/anova.gam.Rd 9e06549c2c3ca2e4945dfb31693512a4 *man/bam.Rd ab5e37c3bf8803de63b63c3bdc5909cd *man/bam.update.Rd cf5f1ee0aab639c7c4b9b357434f15b2 *man/bandchol.Rd 1b83aaa3fbfefd1e6ee30ee76356e742 *man/blas.thread.test.Rd 745cbf31eb14fc1c5916fc634c74d998 *man/bug.reports.mgcv.Rd 530b8b4bacffa9353561f19ecfccfe19 *man/cSplineDes.Rd 8133260bd3c26231322cd7cfbfa3b421 *man/chol.down.Rd 1e4a88fca144eda0f985b362ff5b3972 *man/choose.k.Rd c03748964ef606621418e428ae49b103 *man/columb.Rd 9906a83ce29a3b17044bc2a3c9940cee *man/concurvity.Rd 13d652273fb27fa3ecb9bb704ec2da02 *man/coxph.Rd 239e4c9f917ff2d94d02972fa6c31e4d *man/coxpht.Rd b78faf4ab9477183e7a3fbbd8801afeb *man/dDeta.Rd 0a6d4b3858cbb69a5d375ecd09282256 *man/exclude.too.far.Rd 3add7e72948f304246a412b3a91b9fad *man/extract.lme.cov.Rd 6d377ab3f866a3ba15b63ba2a8ae47ff *man/family.mgcv.Rd 42534ae5dffc0a7f6806270c901cbdd4 *man/fix.family.link.Rd b7830b485a29b13b520fd184e6717b0d *man/fixDependence.Rd e75719779e18c723ee1fd17e44e7901b *man/formXtViX.Rd 64c307314aad3ac3c9392a2e6499e685 *man/formula.gam.Rd 4da4d585b329769eb44f0c7a6e7dd554 *man/fs.test.Rd 6f405acde2d7b6f464cf45f5395113ba *man/full.score.Rd 746c2462c241c52c7232f7d8b44cff5a *man/gam.Rd 42d669d0f18eba79234b2e849d724863 *man/gam.check.Rd 6d1a075aab054f1e14e6f0f1f432626a *man/gam.control.Rd afd2fdc49ac57b4b94ee233fa5da1d64 *man/gam.convergence.Rd 1cf5145859af2263f4e3459f40e1ab23 *man/gam.fit.Rd 4728be401da6eceb8b0c257377dc5d01 *man/gam.fit3.Rd ec46b6f8190bac4b2d9eaee991c3e0a3 *man/gam.fit5.post.proc.Rd b4bbc35c5ab48dbc71881564fd4d0391 *man/gam.models.Rd c15f647511f54d05d9fc21760cf61d91 *man/gam.outer.Rd f50059fd42d0da09271a5768811a0bc4 *man/gam.reparam.Rd c17814cea1b11e5ca374e72d6e1cbd98 *man/gam.scale.Rd d828d474a4b069f9b9e3ebe5f05b70ec *man/gam.selection.Rd 310397e938dae8c6b818d2093e4aa354 *man/gam.side.Rd b2ff252537dd2155524b774b2435e66e *man/gam.vcomp.Rd eb8648cc6b3c9374b899abd2f2b12f7b *man/gam2objective.Rd ed77ce6e1b941625485706d7e307b816 *man/gamObject.Rd 89148f2dc12caff5073ac70c8873b33f *man/gamSim.Rd e5d2541f32dab56972f58b0773eba50c *man/gamlss.etamu.Rd c7f140d128d1d1d76909499900faf49e *man/gamlss.gH.Rd ed8d769db623b98f4e54b8be1b673321 *man/gamm.Rd a9c6065ae414eddec3aa345161c37caa *man/gammals.Rd 222535dd19201cfd929efd3305b13f43 *man/gaulss.Rd 398a5c12285401c1d37a8edb58780bc3 *man/get.var.Rd a62dd487f34f476f7f830ed9d1bc58dc *man/gevlss.Rd 09dba82ee7459800056dbd0511788ebf *man/ginla.Rd 39b47f30a7ea45382d62ca1753d876a8 *man/identifiability.Rd 6eac99acf6c718dfccf80052c2393108 *man/in.out.Rd 6c33026ebb458483d34a04548c05d664 *man/inSide.Rd 2f222eeeb3d7bc42f93869bf8c2af58a *man/influence.gam.Rd 39b9de9dbac7d9dc5c849e1a37def675 *man/initial.sp.Rd 4e8db08a1b17e9cf5a0d05363eb0fc08 *man/interpret.gam.Rd 4bc4d96708fc6454ad81207299608d28 *man/jagam.Rd d37e837db3089e3c0eb105669c04f0c8 *man/k.check.Rd 87d942b17bee05bb662270b894b183e6 *man/ldTweedie.Rd 502d19a8ec5a3e82e749074a2864e715 *man/ldetS.Rd 1b314907562e9236747ec1e344ebe491 *man/linear.functional.terms.Rd ab35592c0a29d1574579811ea1c6ec39 *man/logLik.gam.Rd b1c95a20afd6eb0825c00b46b8c3cbfa *man/ls.size.Rd 9a2c8f14c7a56eca69f4a59bef27a9bf *man/magic.Rd 5169af4be5fccf9fa79b6de08e9ea035 *man/magic.post.proc.Rd 5c4061016779a1504b6721cdf5182074 *man/mgcv-FAQ.Rd 1efa4f05a9b01dce18e0f75bca778259 *man/mgcv-package.Rd e85bd20fe881288da19e187c4c5d7a16 *man/mgcv-parallel.Rd 1f085fc302c7c0b10a44d59c439c3ec5 *man/mini.roots.Rd 0d4b14fbd2417e42513a7552527211f0 *man/missing.data.Rd 00ccf213c31910cd14f1df65a300eb33 *man/model.matrix.gam.Rd 2f2fdc722c5e9e58664da9378451cd4a *man/mono.con.Rd d33914a328f645af13f5a42914ca0f35 *man/mroot.Rd 39b4a5ffe69ca648601d949a25ff2fd9 *man/multinom.Rd c473b80af466ebd19ef6ad6e253df573 *man/mvn.Rd d3d754ce9fb571a37fc53ca3c50ac0cb *man/negbin.Rd 8a6a1926188511235f1e7406120c791e *man/new.name.Rd 00e39f302ab5efbe3b14265fffc16c18 *man/notExp.Rd 7a3280b766cab8424a12d6a8b1d5748e *man/notExp2.Rd e8ecb5f0b5214ef0bae54a645a4d12d6 *man/null.space.dimension.Rd 4a94f9015333b621637b073cafcd02e0 *man/ocat.Rd 145a5adf3f90b6f2a9a109a97d9fd8fe *man/one.se.rule.Rd 9f49b00733e6117337f619cebfdfcf00 *man/pcls.Rd ee9352ba4c531a8def16deddcab9a9fd *man/pdIdnot.Rd 8bc429d92aa9f58c4c43f2852e1f8123 *man/pdTens.Rd 1721f1b266d9e14827e8226e2cb74a81 *man/pen.edf.Rd 931c3aefb8b5e42aa230cfedd281bed1 *man/place.knots.Rd 1724c9c2f4ded94d4b855d474673e72a *man/plot.gam.Rd c27a6b886929b1dc83bf4b90cae848f9 *man/polys.plot.Rd 391744ab635462feabc29c2e6a487520 *man/predict.bam.Rd d11a89b629f88f61c368319c11c6cae9 *man/predict.gam.Rd 41b1b0883f2419c8e2d2dd913fc7d677 *man/print.gam.Rd 6d0ce4e574fabceffdbedd46c91364cb *man/qq.gam.Rd 22b7dcbc8ff4096365fa98ce56b957c9 *man/rTweedie.Rd fa483bfadd374c32f624afe4d7a21082 *man/random.effects.Rd c523210ae95cb9aaa0aaa1c37da1a4c5 *man/residuals.gam.Rd 3c747a8066bcc28ae706ccf74f903d3e *man/rig.Rd 4faef2a628f3c2c43c8a88552ff5a7df *man/rmvn.Rd 1c0b5434ba69062941aa72b262d32ff7 *man/s.Rd c45d0a4edfa63ff362bd34195b3059ca *man/scat.Rd 898e7cc2def2ee234475e68d0b904b29 *man/sdiag.Rd d54f4042e212fca7704cf8428bdaea38 *man/single.index.Rd 6f03e337d54221bc167d531e25af1eea *man/slanczos.Rd 40a5e35173c808dde102e2bfc492ac9d *man/smooth.construct.Rd 3f3e0cd76b77e207ee5a6ff89e5f7a9f *man/smooth.construct.ad.smooth.spec.Rd d2f3fb49a85066ef08d395a244d08a4d *man/smooth.construct.bs.smooth.spec.Rd 2f0463d1aca0b8798da6e681bd4c6e54 *man/smooth.construct.cr.smooth.spec.Rd f5e6d0f5122f61c336827b3615482157 *man/smooth.construct.ds.smooth.spec.Rd bd58515156b5e07c006e69f29aa830d1 *man/smooth.construct.fs.smooth.spec.Rd 92591aadf25c362bed2b07da4adbd8be *man/smooth.construct.gp.smooth.spec.Rd a7a3cb2c62724e7fea5edc94027fc097 *man/smooth.construct.mrf.smooth.spec.Rd 2523b6cefa306210c00f3477853b7f07 *man/smooth.construct.ps.smooth.spec.Rd d8fb8b7ac102af3e0b3914fd9860522a *man/smooth.construct.re.smooth.spec.Rd 119a26b7bb6cacc177cfd1507377a818 *man/smooth.construct.so.smooth.spec.Rd 0bfe981f2c3e6ea5b8d5372076ccde53 *man/smooth.construct.sos.smooth.spec.Rd 3cb4e59f915c8d64b90754eaeeb5a86f *man/smooth.construct.t2.smooth.spec.Rd 8672633a1fad8df3cb1f53d7fa883620 *man/smooth.construct.tensor.smooth.spec.Rd c522c270c217e5b83cf8f3e95220a03f *man/smooth.construct.tp.smooth.spec.Rd ae5e27524e37d57505754639455f18a5 *man/smooth.terms.Rd f642b1caecf3d2bcdbbc0a884e1d3fa5 *man/smooth2random.Rd 844f9653d74441293d05a24dd3e2876a *man/smoothCon.Rd 08a186c579a81d75d9855e53743db03e *man/sp.vcov.Rd 83bd8e097711bf5bd0fff09822743d43 *man/spasm.construct.Rd b9394812e5398ec95787c65c1325a027 *man/step.gam.Rd 62a42d898c2f1ccd7a64aef33d07b3a1 *man/summary.gam.Rd a0b0988dba55cca5b4b970e035e3c749 *man/t2.Rd d1358e5c7f1f9d9a56072a77787803d2 *man/te.Rd 474e8260d5320506d5ed3d5c0a8b26f8 *man/tensor.prod.model.matrix.Rd a6feff25ec8241bf5afb3d9fe219d26d *man/totalPenaltySpace.Rd f22f1cee0ff2b70628846d1d0f8e9a66 *man/trichol.Rd 87e6b4437d00fab4fc814f4cefa3795c *man/trind.generator.Rd 6e975eef6b1214e0be93fc641f982f67 *man/twlss.Rd bc350bfd3f4f8316d3b29b247292a16d *man/uniquecombs.Rd a16b3a5a4d13c705dcab8d1cd1b3347e *man/vcov.gam.Rd 281e73658c726997196727a99a4a1f9e *man/vis.gam.Rd cbb69f16706da27b44fc62c92dcae161 *man/ziP.Rd 14d41deaaee802a9e0a4f58cc9cc862d *man/ziplss.Rd a2c9a9e6a029567a7bab16290137bddb *po/R-de.po 0bdfcf98961b0d52b60f806dc1dba77e *po/R-en@quot.po 13fa409ffcc84a86c6af01ff1530fbfa *po/R-fr.po 18140c14d344121e197559dee112248c *po/R-ko.po 7521dc5d263438ff81980fbe7bff1198 *po/R-mgcv.pot 927a17cb995492e076b4685445e5d4eb *po/R-pl.po 47befe8ada4d6224a96b61a6af061a56 *po/de.po 93f72334356fe6f05a64e567efd35c8e *po/en@quot.po 5e72ab423bad5807c810a2298d68706f *po/fr.po 7e9b729f88dc3c80055f6caeeb73d1cd *po/ko.po 67cde8d585ef68e937a409ba2bdd0091 *po/mgcv.pot f16003b80af3c786aff0a24cbe3018e7 *po/pl.po 03972284b3400cf82cacd5d2dc4b8cb3 *src/Makevars e16c691700bbb44215597c6b0c7e6d2e *src/coxph.c 24c9f7ad06bbe3a26f14dc7ab08f953b *src/discrete.c c390a215a6a4b29455abc9d86acec55c *src/gdi.c 2436f9b328e80370ce2203dbf1dd813c *src/general.h 616abf556352b9b0a5ca79ad3fedf6a5 *src/init.c a9151b5236852eef9e6947590bfcf88a *src/magic.c d8f3175897d590a9c796c017a56595be *src/mat.c e4cef7f1753153fbab242d1c4d4f7e7f *src/matrix.c de37b0972199b796654405efc007f25b *src/matrix.h 5dbce5b588a13a57c06fdece4c5bb76e *src/mgcv.c e738e5400d36edfe06b1956115ca90ef *src/mgcv.h 7d38258442888668f541dbd77590bc4a *src/misc.c 057e8332e5856342b61682c980654bbc *src/mvn.c 563938b7bb6504ab10df5376c4360220 *src/qp.c 073a4b5b0bc6e869c5b35478c47facf1 *src/qp.h d5673b88f6f3d85c62a1337f49abba24 *src/soap.c 44c7ac70ff41f615d449fafd3280819c *src/sparse-smooth.c 0453fd7fb62c7ea7329a419ae688c739 *src/tprs.c 5bd85bf0319a7b7c755cf49c91a7cd94 *src/tprs.h 38e593a85a6fd0bb4fbed836f3361406 *tests/bam.R 98029c1a07ed9b4b00be53cdd67d154a *tests/coxpht.R fefd6fe58a089c4692652bc5c0bcc65c *tests/gam.R fa2508c443bdc759a734df0d00ed735e *tests/mgcv-parallel.R 9c1a01e6ea9ce8855f5489bc67762ecb *tests/missing.data.R 501f5e62e0f51516b8cf61b6aff5901b *tests/single.index.R d43c0ae1f13fe0a691f8fec99c135337 *tests/smooth.construct.so.smooth.spec.R mgcv/inst/0000755000176200001440000000000013303547340012165 5ustar liggesusersmgcv/inst/CITATION0000755000176200001440000000446613303547340013337 0ustar liggesuserscitHeader("2011 for generalized additive model method; 2016 for beyond exponential family; 2004 for strictly additive GCV based model method and basics of gamm; 2017 for overview; 2003 for thin plate regression splines.") bibentry( bibtype="Article", title="Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models", journal="Journal of the Royal Statistical Society (B)", volume= "73", number="1", pages="3-36", year="2011", author="S. N. Wood", textVersion="Wood, S.N. (2011) Fast stable restricted maximum likelihood and marginal likelihood estimation of semiparametric generalized linear models. Journal of the Royal Statistical Society (B) 73(1):3-36" ) bibentry( bibtype="Article", title= "Smoothing parameter and model selection for general smooth models (with discussion)", author= "S.N. Wood and N. and Pya and B. S{\"a}fken", journal= "Journal of the American Statistical Association", year= "2016", pages= "1548-1575", volume= "111", textVersion="Wood S.N., N. Pya and B. Saefken (2016) Smoothing parameter and model selection for general smooth models (with discussion). Journal of the American Statistical Association 111:1548-1575." ) bibentry( bibtype="Article", title= "Stable and efficient multiple smoothing parameter estimation for generalized additive models", journal="Journal of the American Statistical Association", volume= "99", number="467", pages="673-686", year="2004", author="S. N. Wood", textVersion="Wood, S.N. (2004) Stable and efficient multiple smoothing parameter estimation for generalized additive models. Journal of the American Statistical Association. 99:673-686." ) bibentry( bibtype="Book", title="Generalized Additive Models: An Introduction with R", year="2017", author="S.N Wood", edition="2", publisher="Chapman and Hall/CRC", textVersion="Wood, S.N. (2017) Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC. " ) bibentry( bibtype="Article", title="Thin-plate regression splines", journal="Journal of the Royal Statistical Society (B)", volume= "65", number="1", pages="95-114", year="2003", author="S. N. Wood", textVersion="Wood, S.N. (2003) Thin-plate regression splines. Journal of the Royal Statistical Society (B) 65(1):95-114." ) mgcv/inst/po/0000755000176200001440000000000013073161526012605 5ustar liggesusersmgcv/inst/po/ko/0000755000176200001440000000000013073161526013216 5ustar liggesusersmgcv/inst/po/ko/LC_MESSAGES/0000755000176200001440000000000013326153317015003 5ustar liggesusersmgcv/inst/po/ko/LC_MESSAGES/R-mgcv.mo0000644000176200001440000005645513533720051016505 0ustar liggesusersL d 7n #@AT2*5 A6_<%"-P-dF$$*@k%-'=7S $ '.V2jN"<;ZA#$!@bq1)#'D8a6$/8T%*(Bk0#+<K6"# 7@7x *") 5P(k+gA?-aQ4ccQ*N y 0   ( !3!=J!'!!!!!<"@\"B"""'#+#:<#w######$$$<$"\$&$$$$.$%',%(T%}%7%%% &*&MC&& &!&(&"'&$'K'g''*' '''( 3(=(L(5c(/(6()*MK+3++'+:+<2,-o,C,,X,[K-_-/.[7.7.P.V/,s/t/10KG010Y01r31?1D1J+2+v2W2F27A3Uy3,3;3;84mt4(42 51>52p5D5h5VQ6D6i6=W77>8"^868l8]%9L9,9E9NC:&:7:x:*j;c;q;+k<:<P<4#=>X=#=_=0>]L>R>I>.G?5v???*?A@DY@K@?@6*A3aA<A6AL BVBTBIEC4CWCND\kDcD,EFFE7E8E.E?-FAmFWF GGGKPHHWIRIMJ KFK%KfL'L=LCL(,MUMZuMGMN=N=NKO`bOkO_/POPhP+HQGtQAQ?Q=>R7|R6R.R4S5OSNSRS3'T:[T9TpT1AUisUEU>#VbbV)VDVE4WLzWbW5*X@`X>XNX>/YOnY/Y6Y"%ZyHZAZ+[<0[2m[=['['\Y.\O\T\& yI} o"Vai.%9+64/nJ>mLvhF=7 `5[W$gHrjSMsq?z0,X'RG;*cdK@U 3(P w]QAu~8b)O<k-D1YpfCE_|\:B^t2T{x#e!ZNl %s link not available for negative binomial family; available links are "identity", "log" and "sqrt"'family' argument seems not to be a valid family object'theta' must be specified,0s in V(mu)1= upper bound in call to mono.con()m can't be in rem wrong length and ignored.maximum number of iterations must be > 0mean, mu, must be non negativemethod not recognised.min.sp not supported with fast REML computation, and ignored.mvn requires 2 or more dimensional datanames of z and pc must matchncol(M$C) != length(M$p)ncol(M$X) != length(M$p)need at least one interior knotnegative values not allowed for the negative binomial familynegative values not allowed for the zero inflated Poisson familynewdata is a model.frame: it should contain all required variablesnlm.fd only available for GCV/UBREnon-finite coefficients at iteration %dnot a gam objectnot all required variables have been supplied in newdata!nrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)nthreads must be a positive integerobject is not a glm or gamobject not fully initializedonly deals with 2D caseonly first element of `id' usedonly scalar `p' and `phi' allowed.only scalar `rho' and `theta' allowed.ord is wrong. reset to NULL.p must be in (1,2)p must be in [1,2]paraPen not supported for multi-formula modelsparameter of ziplssrandom argument must be a *named* list.recov works with fitted gam objects onlyrequires an object of class gamresiduals argument to plot.gam is wrong length: ignoreds(.) not yet supported.samfrac too small - ignoredscale parameter must be positivesilly tolerance suppliedsilly value supplied for rank.tol: reset to square root of machine precision.supplied dist negativetoo few knotstype must be "link" or "response"un-supported smoothness selection methodunknown outer optimization method.unknown smoothness selection criterionunrecognized (vector?) linkvalue of epsilon must be > 0values out of rangevariance function not recognized for quasiview variables must be one of %sw different length from y!x and y must be same lengthx and y not same lengthx is nullx out of rangext argument is faulty.y must be an integer multiple of phi for Tweedie(p=1)y must be strictly positive for a Gamma densityziplss requires 2 links specified as character stringsProject-Id-Version: R 3.1.3 Report-Msgid-Bugs-To: bugs.r-project.org POT-Creation-Date: 2019-04-29 12:44 PO-Revision-Date: 2015-02-21 16:01-0600 Last-Translator:Chel Hee Lee Language-Team: Chel Hee Lee Language: ko MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=1; plural=0; %s는 음이항분포 페밀리(negative binomial family)에 사용할 수 있는 링크(link)가 아닙니다. 사용가능한 링크들에는 "identity", "log" 그리고 "sqrt"가 있습니다.'family' 인자는 올바른 family 객체가 아닌 것 같이 보입니다.'theta'의 값은 반드시 주어져야 합니다.,V(mu)에서 0이 발견되었습니다.1 Language-Team: Chel Hee Lee Language: ko MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=1; plural=0; addconQT 에서 에러가 발생했습니다.행렬생성에 필요한 메모리 초기화에 실패했습니다.특이함수(singular matrix)가 invert()에 전달되었습니다.L에 주어진 값이 없다면 스무딩 파라미터(smoothing parameter)에 대한 초기값(starting values)가 필요합니다.mgcv/inst/po/fr/0000755000176200001440000000000013073161526013214 5ustar liggesusersmgcv/inst/po/fr/LC_MESSAGES/0000755000176200001440000000000013326153317015001 5ustar liggesusersmgcv/inst/po/fr/LC_MESSAGES/R-mgcv.mo0000644000176200001440000003354413533720051016475 0ustar liggesusers~    #  2 E 5\  7 6 < 7\ %  : # ./ ^ ${ * %  9K[q7 0/$O2t$=7 B%\"#;f#A)#I$m81+FG8%*&(Qz0#5lI<"70%h%%%\]x0(041e1B<>{I':>[v--)38I'7M%H/n 8 %!3Uq* $ ) + &C Ij $ = 9!?Q!E!*!";"/["/"#")"- #77#'o#P###- $.:$Mi$$$$D$-A%"o%@%&%E%Y@&/&4&%&&%'&L'Is''CB("(&((B('.).V)5)B)&)%*;*NY*9*3*!+*8++c+3++++6 ,*B,Hm,o,N&-3u--A-I .:S.:.:.k/!p///=/%/*"0M03b0G0B0!1:1NS1D1 1S2&\2@2222535K3*3M3N3-I4Iw44c48=59v515O526G6[6"n66!6,6!67 07(;7pGoMv%S7WfA^ +.?85d\6(Oxg,QJw E:#nCze h02c)Nt>l<T/_ZXY1V&Br}"[4q=F 9 $3{@mbH~a!yik*su'|jDK;L P-`U]RI,0s in V(mu)Algorithm did not convergeAlgorithm stopped at boundary valueAn object of lengthAt least three knots required in call to mono.con.Can't find by variableCan't find valid starting values: please specify someCannot extract the dimensionsCannot extract the inverse from an uninitialized objectCannot extract the matrix from an uninitialized objectCannot extract the matrix from an uninitialized pdMat objectCannot extract the matrix with uninitialized dimensionsFirst argument is no sort of formula!H has wrong dimensionIRLS regularizing parameter must be a non-negative number.Invalid fitted means in empty modelInvalid linear predictor values in empty modelLength of start should equalM$S and M$off have different lengthsM$sp has different length to M$S and M$offModel has more coefficients than dataModel seems to contain no termsMust give names when initializing pdIdnot from parameter.NA's in min.sp.NA's in pdTens factorNA's in pdTens matrixNA's in supplied smoothing parameter vector - ignoring.NAs in V(mu)NAs in d(mu)/d(eta)No data supplied to gam.setupNo terms to plot - nothing for plot.gam() to do.No variance estimates availableNon-finite coefficients at iterationNot enough (non-NA) data to do anything meaningfulNot enough informative observations.Repeated variables as arguments of a smooth are not permittedSomething wrong - matrix probably not +ve semi definiteSomething wrong with zlimStep size truncated due to divergenceStep size truncated: out of boundsStep size truncated: out of bounds.Supplied matrix not symmetricSupplied smoothing parameter vector is too short - ignored.Tensor product penalty rank appears to be too low: please email Simon.Wood@R-project.org with details.The following arguments to anova.glm(..) are invalid and dropped:Unknown type, reset to terms.X lost dimensions in magic!!You've got no model....all elements of random list must be namedand correspond to initial coefs foranova.gam called with non gam objectargument k of s() should be integer and has been roundedbasis dimension, k, increased to minimum possiblebs wrong length and ignored.by=. not allowedcolor scheme not recognisedcomponents of knots relating to a single smooth must be of same lengthd can not be negative in call to null.space.dimension().data vectors are of different lengthsdimension of fx is wrongdimensions of supplied w wrong.does not match the required parameter sizeelements of min.sp must be non negative.fam not a family objectfamily not recognisedfamily not recognizedfitted probabilities numerically 0 or 1 occurredfitted rates numerically 0 occurredgamm can not fix only some margins of tensor product.gamm models must have at least 1 smooth with unknown smoothing parameter or at least one other random effectgamm() can only handle random effects defined as named listsgrid vectors are different lengthsillegal `family' argumentinitial parameters very close to inequality constraintsinner groupings not nested in outer!!inner loop 1; can't correct step sizeinner loop 2; can't correct step sizeinner loop 3; can't correct step sizeiterative weights or data non-finite in gam.fit - regularization may help. See ?gam.control.length of min.sp is wrong.length(M$w) != length(M$y)link not recognisedlower bound >= upper bound in call to mono.con()m wrong length and ignored.maximum number of iterations must be > 0method not recognised.model has repeated 1-d smooths of same variable.more knots than data in a tp term: knots ignored.more knots than unique data values is not allowedncol(M$C) != length(M$p)ncol(M$X) != length(M$p)newdata is a model.frame: it should contain all required variablesno automatic plotting for smooths of more than two variablesno data to predict atno valid set of coefficients has been found:please supply starting valuesnon-existent terms requested - ignoringnot all required variables have been supplied in newdata!nrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)number of supplied knots != k for a cc smoothnumber of supplied knots != k for a cr smoothobject does not appear to be of class lmeone or more supplied k too small - reset to defaultpredict.gam can only be used to predict from gam objectsrandom argument must be a *named* list.residuals argument to plot.gam is wrong length: ignoreds(.) not yet supported.silly value supplied for rank.tol: reset to square root of machine precision.singular values not returned in ordersmooth objects should not have a qrc attribute.something wrong with argument d.sorry no option for contouring with errors: try plot.gamsupplied dist negativetest argument ignoredtoo few knotstype must be "link" or "response"unrecognized (vector?) linkvalue of epsilon must be > 0variance function not recognized for quasiw different length from y!without a formulax is nully must be univariate unless binomialProject-Id-Version: mgcv 1.3-10 Report-Msgid-Bugs-To: bugs@r-project.org POT-Creation-Date: 2019-04-29 12:44 PO-Revision-Date: 2005-12-09 09:13+0100 Last-Translator: Philippe Grosjean Language-Team: French Language: fr MIME-Version: 1.0 Content-Type: text/plain; charset=ISO-8859-1 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n > 1); ,0s dans V(mu)L'algorithme n'a pas convergL'algorithme est arrt aux valeurs limitesUn objet de longueurAu moins trois noeuds requis pour mono.con.Impossible de trouver la variable 'by'Impossible de trouver des valeurs de dpart valides : veuillez en spcifierImpossible d'extraire les dimensionsImpossible d'extraire l'inverse depuis un objet non initialisImpossible d'extraire la matrice d'un objet non initialisImpossible d'extraire la matrice d'un objet pdMat non initialisImpossible d'extraire la matrice ayant des dimensions non initialisesLe premier argument n'est pas une formule.H a des mauvaises dimensionsle paramtre de rgularisation IRLS doit tre positif ou null.Moyennes ajustes incorrectes dans un modle videValeurs de prdiction linaire dans un modle videLa longueur de start doit tre gale M$S et M$off ont des longueurs diffrentesM$sp a une longueur diffrente de M$S et M$offLe modle a plus de coefficients que le nombre de donnesLe modle semble ne contenir aucun termeIl faut fournir des noms lors de l'initialisation de pdIdnot depuis un paramtre.valeurs manquantes (NA) dans min.spvaleurs manquantes (NA) dans le fateur pdTensvaleurs manquantes (NA) dans la matrice pdTensValeurs manquantes (NA) dans le vecteur de paramtres de lissage fixe - ignor.NAs dans V(mu)NAs dans d(mu)/d(eta)Aucune donne fournie gam.setupAucun terme reprsenter graphiquement - rien faire pour plot.gam().Aucun estimateur de variance n'est disponibleCoefficients non finis l'itrationPas assez de donnes (non-NA) pour faire quoi que ce soit d'utilePas assez d'observations informatives.Les variables rptes comme arguments d'un lissage ne sont pas permisesQuelque chose d'anormal s'est produit - la matrice n'est probablement pas +ve semi dfinieQuelque chose d'anormal s'est produit avec zlimLa taille du pas est tronque cause d'une divergenceTaille du pas tronque: hors de plage.Taille du pas tronque : hors de plage.La matrice fournie n'est pas symtriqueLe vecteur des paramtres de lissage fourni est trop court - il est ignor.Le rang de la pnalit pour le produit tensoriel semble trop bas : veuillez envoyer un email Simon.Wood@R-project.org avec les dtailsLes arguments suivants de anova.glm(..) sont incorrects et ignors :Type inconnu, rinitialis `terms'.X a perdu ses dimensions dans magic !!Vous n'avez aucun modle...tous les lments d'une liste de nombres alatoires doivent tre nomms et correspond aux coefs initiaux pour anova.gam appel sur un objet qui n'est pas gaml'argument k de s() doit tre un entier et a t arrondila dimension de base, k, est augmente la valeur minimale possiblebs, de longueur incorrecte, est ignor.by=. n'est pas permisschma de couleurs non reconnules composants des noeuds relatifs un mme lissage doivent tre de mme longueurd ne peut tre ngatif dans l'appel null.space.dimension()les vecteurs de donnes ont des longueurs diffrentesla dimension de fx est incorrecteles dimensions du w fourni sont mauvaises.ne correspond pas au paramtre taille requisles lments de min.sp doivent tre positifs ou nulls.fam n'est pas un objet familyfamille non reconnuefamille non reconnueprobabilits d'ajustement numrique de 0 ou 1 rencontrestaux d'ajustement numriques de 0 rencontrsgamm ne peut arranger seulement quelques marges de produits de tenseurs.les modles gamm doivent avoir au moins 1 lissage avec des parmtres inconnus ou au moins un autre effet alatoiregamm() peut seulement utiliser des effets alatoires dfinis comme listes nommesles vecteurs de grille ont des longueurs diffrentesargument `family' non autorisles paramtres initiaux sont trs proches des contraintes d'ingalitle regroupement interne n'est pas imbriqu dans le regroupement externe !!boucle interne 1 ; Impossible de corriger la taille du pasboucle interne 2 ; Impossible de corriger la taille du pasboucle interne 3 ; Impossible de corriger la taille du paspondrations itratives ou donnes non finies dans gam.fit - une rgularisation peut aider. Voyez ?gam.control.la longueur de min.sp est fausse.length(M$w) != length(M$y)link non reconnulimite infrieure >= limite suprieure dans l'appel mono.con()m, de longueur incorrecte, est ignor.le nombre maximum d'itrations doit tre > 0mthode non reconnue.le modle a des lissages 1-d rpts des mmes variablesplus de noeuds que de donnes dans un terme tp : des noeuds sont ignors.il n'est pas autoris d'avoir plus de noeuds que de valeurs uniquesncol(M$C) != length(M$p)ncol(M$X) != length(M$p)newdata est un model.frame : il devrait contenir toutes les variables requisesaucun graphe automatique pour les lissages de plus de deux variablespas de donnes pour la prdiction pas d'ensemble de coefficients valide trouv : veuillez fournir les valeurs de dpartterme inexistant requis - il est ignorles variables requises n'ont pas toutes t fournies dans newdata!nrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)le nombre de noeuds fournis != k pour un lissage 'cc'le nombre de noeuds fournis != k pour un lissage 'cr'l'objet ne semble pas tre de la classe lmeun ou plusieurs k spcifis trop petits - rinitialisation aux valeurs par dfautpredict.gam peut seulement tre utilis pour des prdictions partir d'objets gaml'argument random doit tre une liste *nomme*.l'argument residuals plot.gam est de la mauvaise longueur : il est ignors(.) pas encore supportvaleur aberrante fournie pour rank.tol : rinitialise la racine carre de la prcision de la machine.les valeurs singulires ne sont pas renvoyes dans l'ordreles objets lissage ne devraient pas avoir d'attribut qrc.il y a quelque chose d'anormal avec l'argument d.dsol, aucune option pour effectuer les contours avec erreurs : essayez plot.gamdist fournie ngativeargument test ignortrop peu de noeudstype doit tre "link" ou "response"link non reconnu (vecteur ?)la valeur de epsilon doit tre > 0function de variance non reconnue pour quasiw n'a pas la mme longueur que y !sans une formulex est nully doit tre univari moins d'tre binomialmgcv/inst/po/fr/LC_MESSAGES/mgcv.mo0000644000176200001440000000374313533720775016311 0ustar liggesusersHXI-%' ,1!^ " E++GW`(:.9 9C$})$$P4gF    A term has fewer unique covariate combinations than specified maximum degrees of freedomAn out of bound write to matrix has occurred!Attempt to invert() non-square matrixERROR in addconQT.Failed to initialize memory for matrix.INTEGRITY PROBLEM in the extant matrix list.Incompatible matrices in matmult.QPCLS - Rank deficiency in modelSingular Matrix passed to invert()Target matrix too small in mcopyYou are trying to check matrix integrity without defining RANGECHECK.You must have 2m>d for a thin plate spline.magic, the gcv/ubre optimizer, failed to converge after 400 iterations.Project-Id-Version: mgcv 1.3-10 Report-Msgid-Bugs-To: POT-Creation-Date: 2019-09-04 12:37+0100 PO-Revision-Date: 2005-12-08 00:40+0100 Last-Translator: Philippe Grosjean Language-Team: French Language: fr MIME-Version: 1.0 Content-Type: text/plain; charset=ISO-8859-1 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n > 1); Un terme a moins de combinaisons de covariables uniques que le degr de libert maximum spcifiUne crite hors des limites de la matrice s'est produite !Tentative d'inversion d'une matrice non carreERREUR dans addconQT.L'initialisation de la mmoire pour une matrice a chou.PROBLEME D'INTEGRITE dans la liste de la matrice tendue.Matrices incompatibles dans matmult.QPCLS - Dficience de rang dans le modleMatrice singulire passe invert()Matrice cible trop petite dans mcopyVous essayez de vrifier l'intgrit de la matrice sans avoir dfini RANGECHECK.Vous devez avoir 2m > d pour une 'thin plate spline'magic, l'optimisateur gcv/ubre, n'a pas converg aprs 400 itrations.mgcv/inst/po/de/0000755000176200001440000000000013073161525013174 5ustar liggesusersmgcv/inst/po/de/LC_MESSAGES/0000755000176200001440000000000013326153316014761 5ustar liggesusersmgcv/inst/po/de/LC_MESSAGES/R-mgcv.mo0000644000176200001440000013370313533720051016454 0ustar liggesusers #"E" _"d"7"#7# 9#E# _#Xl##/#$#)$M$Aa$2$$4$*)%T%p%5%%7%6&<J&7&&>&[';x'%'>'(:/(#j(.(B()")B)-V)[))F)@D*$*$*** *+>4+%s+!++9+,'4,-\,,,,7, , -#-C-a-+---0- .S+.$.'.S. /74/:l/2/$/3/30SI0N0:0@'1Rh1-1=1'2'G2Ao2#29273/G3w3L3(3%4"-4#P4&t44;4f4A\5-5-5#56(<6+e6A666876A7x7$7!777(8118c8)~888 8#9$&9K9h989+969&!:-H:/v:2:::);,>;1k; ;$;;;< ,<M<^<$y<6<0<&=-=M=Fi=$=8=E>T>%o>>>>D>(*?S?*g??3?1?(@0@1K@<}@@*@@A.A+DA pA0{A#AMA,B%KB5qB_B-Cl5C+C<C6 D%BD6hD"DYDE#6E"ZE0}ECE+EF7>F7vF%F%F%F% GBFG G*G\GH64H"kH HRH I#I)2I\I%wIIBI(I$$J+IJuJgJAJ-6KadKQK4LcMLQL*M.M0BMsMM(MMM=MA=N0N1N1N2O3GO1{OO-OOP'#P#KPoPPPP<P@QB\Q"Q.Q=Q</RlRRR$R RISMS/jS'S'SS:S6T*MTxTTTTT#T' U)HU-rU-U)UUV30VdV|V5V"V&V6W8SWW WWWaW.?XnXX+XX5XOY*dY8Y'Y#Y(Z0=Z5nZZ Z7Z-[4K[[,[[[[[&\ >\-_\\.\\M\+>]%j]/]?]^ ^-?^*m^^8^^ _')_Q_h_w_!_7_N_1=`o`:`7`` a6a!Ma(oaa*a.a#b(b":b&]bbbb:bc.c)Bc*lc ccc5cd+dGd _didxd5d/d$d6eQeNf41gofg@gh5h 7hCh[hushh7in2{n:nFn 0o$Qovo4owo#{ |T%|5z|,|3|8}3J}#~}?}h}HK~0~4~,~/'UW9E-MJgD'*"J mz64΁!3%<Y*//!><[0;Ƀ66</s<I4*1_1&Å,)0 Z*{#݆A:<%w&ćf݇'D?lL ,Gb*~H(4.c=r</9<Hv6ڋ 2G7\XJUI0:ЍB yN:Ȏ9O4.G4v-uِO3m&7ȑJ.K#z=Aܒ6<U<<ϓB O.\m ;'V'~a,5,Fs,Eٖ+CK3×qޗLP6mԘ_B=m^N1ߚ6,(D-m'ÛKڛ6&9]99ќ9 :E:5ѝ'1D.v*О'@*KkI#,%KRK#'*6)a']'@95z-ޢ=,9E ӣ,,4(a99Ĥ/.MNm+֥G"J&m7I̦,CTj4=R4lAT1RP0թ)20>c?"*=0:n@71B"`'!Ȭ( ?4 tc7511g>#خ"51U$P&2$*W(,۰DeM<DDMD$.L0fA(ٳ'$A*fAŴ)&/P(1%۵BW h ҶA00,a4X1qw'9v2|| 5YB_krM=6j*/7 X&S&nN":s>QxOoGOT4p>V.R agDhzW~hv@#Z  cmFbib*{}'z%((%VDP;CcdJ;Ex  1pfQ]u#7Uyt<-AI,aL85 dWwoe3T_?yYrA^?KNH-G{s`lKZe,}FU</=~mtR9 .q\"i$MS\E+LB$38J ![CH)j]6f0) +[`@k0u^ 2P:n4Igl!"fs" smooth cannot use a multiply penalized basis (wrong basis in xt)"fs" terms can not be fixed here%s link not available for negative binomial family; available links are "identity", "log" and "sqrt"'family' argument seems not to be a valid family object'theta' must be specified,0s in V(mu)1= upper bound in call to mono.con()m can't be in rem wrong length and ignored.maximum number of iterations must be > 0mean, mu, must be non negativemethod not recognised.min.sp not supported with fast REML computation, and ignored.mismatch between nb/polys supplied area names and data area namesmodel has repeated 1-d smooths of same variable.more knots than data in a ds term: knots ignored.more knots than data in a tp term: knots ignored.more knots than data in an ms term: knots ignored.more knots than data in an sos term: knots ignored.more knots than unique data values is not allowedmu dimensions wrongmultiple penalties of the same order is sillymvn dimension errormvn does not yet handle offsetsmvn requires 2 or more dimensional datana.action not character or functionnames of z and pc must matchncol(M$C) != length(M$p)ncol(M$X) != length(M$p)need at least one interior knotnegative values not allowed for the negative binomial familynegative values not allowed for the zero inflated Poisson familynewdata is a model.frame: it should contain all required variablesnlm.fd only available for GCV/UBREno NAs allowed in response data for this modelno automatic plotting for smooths of more than four variablesno automatic plotting for smooths of more than two variablesno data to predict atno factor supplied to fs smoothno free coefs in sf smoothno smooths, ignoring `discrete=TRUE'no spatial information provided!no valid set of coefficients has been found:please supply starting valuesnon finite values in Hessiannon-existent exclude terms requested - ignoringnon-existent terms requested - ignoringnon-finite coefficients at iteration %dnot a gam objectnot all required variables have been supplied in newdata!not an extended familynot enough unique values to find k nearestnot positive definitenothing to do for this modelnrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)nthreads must be a positive integernumber of categories must be at least 2number of linear predictors doesn't matchnumber of supplied knots != k for a cc smoothnumber of supplied knots != k for a cr smoothobject does not appear to be of class lmeobject is not a glm or gamobject not fully initializedone or more supplied k too small - reset to defaultonly deals with 2D caseonly first element of `id' usedonly one level of smooth nesting is supported by gammonly scalar `p' and `phi' allowed.only scalar `rho' and `theta' allowed.openMP not available: single threaded computation onlyord contains out of range orders (which will be ignored)ord is wrong. reset to NULL.order too lowp must be in (1,2)p must be in [1,2]p-values for any terms that can be penalized to zero will be unreliable: refit model to fix this.paraPen not supported for multi-formula modelsparameter of ziplsspenalized deviance = %spenalty basis too large for smoothing basispenalty basis too smallpenalty column names don't match supplied area names!penalty matrix, boundary polygons and/or neighbours list must be supplied in xtpenalty order too high for basis dimensionpredict.gam can only be used to predict from gam objectsrandom argument must be a *named* list.random effects don't work with ids.recov works with fitted gam objects onlyreparameterization unstable for margin: not donerequested non-existent derivative in B-spline penaltyrequires an object of class gamresiduals argument not supportedresiduals argument to plot.gam is wrong length: ignoredresponse not in 0 to number of predictors + 1rho missing from simulation data edf.type reset to 2s value increaseds value modified to give continuous functions value reduceds(.) not supported.s(.) not yet supported.samfrac too small - ignoredsaturated likelihood may be inaccuratescale parameter must be positivesd should have exactly one less entry than ldshared offsets not allowedside conditions not allowed for nested smoothssilly tolerance suppliedsilly value supplied for rank.tol: reset to square root of machine precision.single linear predictor indices are ignoredsingular values not returned in ordersmooth objects should not have a qrc attribute.smoothing parameter prior choise not recognised, reset to gammasoap films are bivariate onlysomething wrong with argument d.something wrong with inputs to LAPACK routinesomething wrong with stratified predictionsorry link not yet handledsorry no option for contouring with errors: try plot.gamstep failed: max abs grad =step failure in theta estimationsupplied S matrices are wrong diminsionsupplied dist negativesupplied knotssupplied penalty not square!supplied penalty wrong dimension!supply a value for each variable for a point constraintsweep and drop constraints unlikely to work well with self handling of by varste smooths not useable with gamm4: use t2 insteadtest argument ignoredthe adaptive smooth class is limited to 1 or 2 covariates.there is *no* information about some basis coefficientsthere should betoo few knotstype iterms not available for multiple predictor casestype must be "link" or "response"un-supported smoothness selection methodun-supported testunconditional argument not meaningful hereunimplemented sparse constraint type requesteduniquecombs has not worked properlyunknown optimizerunknown outer optimization method.unknown smoothness selection criterionunknown tensor constraint typeunrecognised na.actionunrecognized (vector?) linkunsupported order of differentiation requested of gam.fit3value of epsilon must be > 0values out of rangevariable names don't match boundary namesvariance function not recognized for quasiview variables must be one of %sw different length from y!weights ignoredweights must be like glm weights for generalized casewithout a formulax and y must be same lengthx and y not same lengthx is nullx out of rangext argument is faulty.y must be an integer multiple of phi for Tweedie(p=1)y must be strictly positive for a Gamma densityy must be univariate unless binomialziplss requires 2 links specified as character stringsProject-Id-Version: R 3.6.0 / mgcv 1.8-28 Report-Msgid-Bugs-To: bugs@r-project.org POT-Creation-Date: 2019-04-29 12:44 PO-Revision-Date: 2019-04-02 13:37+0200 Last-Translator: Detlef Steuer Language-Team: R-Core Language: de MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n != 1); "fs" Glätter kann keine mehrfach bestrafte Basis nutzen (falsche Basis in xt)"fs" Ausdrücke können nicht hier festgelegt werden%s Link nicht verfügbar für die negativ-binomial-Familie; verfügare Links sind "identity", "log" und "sqrt"'family' Argument scheint kein zulässiges family Objekt zu sein'theta' muss angegeben werden,0s in V(mu)1= obere Grenze im Aufruf von mono.con()m kann nicht in re seinm hat falsche Länge und wird ignoriert.maximale Anzahl der Iterationen muss > 0 seinmean und mu müssen nicht-negativ sein.Methode nicht erkannt.min.sp wird bei schneller REML Berechnung nicht unterstützt und ignoriert.area names aus nb/poly und Daten passen nicht zusammenModell hat 1-d-Glättungen derselben Variable wiederholt.mehr Knoten als Daten in einem ds Term: Knoten ignoriert.mehr Knoten als Daten in einem tp-Term: Knoten ignoriert.mehr Knoten als Daten in einem ms Term: Knoten ignoriert.mehr Knoten als Daten in einem sos Term: Knoten ignoriert.mehr Knoten als einheitliche Datenwerte sind nicht erlaubtmu Dimensionen falschmehrere Strafterme derselben Ordnung ist nichtsnutzigmvn Dimensionsfehlermvn kann noch nicht mit Offsets umgehenmvn benötigt zwei- oder höherdimensionale Datenna.action ist weder Zeichenkette noch FunktionNamen von z und pc müssen übereinstimmenncol(M$C) != length(M$p)ncol(M$X) != length(M$p)mindestens ein Knoten im Inneren nötignegative Werte sind bei der negativ-binomial-Familie unzulässignegative Werte nicht zulässig für die null-inflationierte Poisson-Familienewdata ist ein model.frame: Es soll alle benötigten Variablen enthaltennlm.fd nur verfügbar für GCV/UBREkeine NAs als Daten in diesem Modell erlaubtkeine automatische Darstellung für Glättungen von mehr als vier Variablenkeine automatische Darstellung für Glättungen von mehr als zwei Variablenkeine Daten zum Vorausberechnen vonKein Faktor angegeben für fs Glättungkeine freien Koeffizienten in sf-Glättungkeine Glätten, ignoriere 'discrete=TRUE'keine räumliche Information angegeben!es wurde keine gültige Menge von Koeffizienten gefunden: Bitte stellen Sie Startwerte bereitnicht endliche Werte in der Hessematrixnicht existierende Ausschluss-Terme angefordert - wird ignoriertnicht existierende Terme angefordert - wird ignoriertnicht-endliche Koeffizienten bei Iteration %dkein gam Objektnicht alle benötigten Variablen wurden in newdata angegeben!keine erweiterte Familienicht genug eindeutige Werte um die k nächsten zu findennicht positiv definitnichts zu tun für dieses Modellnrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)nthreads muss eine positive, ganze Zahl seinAnzahl von Kategorien muss mindestens 2 seinAnzahl linearer Prädiktoren passt nichtAnzahl der angegebenen Knoten != k für eine cc-GlättungAnzahl der angegebenen Knoten != k für eine cr-GlättungObjekt scheint nicht von der Klasse lme zu seinObejekt ist weder glm noch gamObjekt nicht voll initialisiertein oder mehrere bereitgestellte k zu klein - wird auf Standard zurückgesetztbehandelt nur den 2D Fallnur das erste Element von 'id' wird genutztnur eine Stufe von Glättungsverschachtelung wird von gamm unterstütztNur skalare 'p' und 'phi' erlaubt.Nur skalare 'rho' und 'theta' erlaubt.openMP nicht verfügbar: nur single thread Berechnungenord enthält Ordungen außerhalb des Wertebereichs (die ignoriert werden)ord ist falsch, wird auf NULL zurückgesetztOrdnung zu kleinp muss aus (1,2) seinp muss aus [1,2] seinDie p-Werte für einen Term, der auf Null bestraft werden kann, sind unzuverlässig: Modell wird neu angepasst, um dies zu korrigieren.paraPen für multi-formel Modelle nicht unterstütztParameter von ziplsspenalisierte Devianz = %sStraftermbasis ist zu groß für die GlättungsbasisStraftermordnung zu kleinStraftermspaltennamen passen nicht zu den angegebenen area names!Straftermmatrix, Grenzpolygone und/oder die Nachbarliste muss in xt angegeben werdenStraftermordnung zu groß für die Basisdimensionpredict.gam kann nur benutzt werden, um auf Basis von gam-Objekten vorherzusagenrandom-Argument muss eine *benannte* Liste sein.zufällige Effekte arbeiten nicht mit idsrecov funktioniert nur bei gefitteten gam ObjektenReparametrisierung für den Rand instabil: nicht durchgeführtnicht exisitierened Ableitung im B-Spline Strafterm angefordertverlangt ein Objekt der Klasse gamArgument residuals wird nicht unterstütztResiduen-Argument für plot.gam hat falsche Länge: IgnoriertAntwort ist nicht zwischen 0 und Zahl der Prädiktoren + 1rho fehlt in den Simulationsdaten, edf.type auf 2 zurückgesetzts Wert erhöhtS Wert verändert, um eine stetige Funktion zu erhaltens Wert reduzierts(.) wird nicht unterstützt.s(.) wird noch nicht unterstützt.samfrac zu klein - ignoriertsaturierte Likelihood kann ungenau seinSkalenparameter muss positiv seinsd sollte genau eins kleiner sein als ldgemeinsame Offsets nicht erlaubtNebenbedingungnen nicht erlaubt für verschachtelte Glättungenunangemessene Toleranz angegebendummer Wert für rank.tol angegeben: Wird auf Quadratwurzel der Maschinenpräzision zurückgesetzt.einzelne Indizes linearer Prädiktoren werden ignoriertSingulärwerte wurden nicht sortiert zurückgeliefertGlättungsobjekte sollten kein qrc-Attribut habenGlättungsparameterwahl nicht erkannt, falle zurück auf gammasoap films nur für bivariaten Falletwas stimmt nicht mit Argument d.Etwas ist falsch mit den Eingaben für LAPACK routineetwas stimmt nicht mit stratifizierter VorhersageSorry, Link noch nicht implementiertEntschuldigung. Keine Option für Formgebung mit Fehlern: Versuchen Sie plot.gamSchritt fehlgeschlagen: max abs grad =Schritt Fehlgeschlagen in der Schätzung von thetaAngegebene S Matrix hat falsche Dimension!angegebene Entfernung negativangegebene Knotenangegebener Strafterm nicht quadratisch!Angegebener Strafterm hat falsche Dimension!bitte für jede Variable einen Wert angeben bei Punktbeschränkungen"sweep and drop" Randbedingungen arbeiten wahrscheinlich nicht gut mit dem "self handling" durch varste Glättungen nicht nutzbar bei gamm4: nutze stattdessen t2Argument test ignoriertDie adaptive Glätterklasse ist beschränkt auf 1 oder 2 Kovariaten.es gibt *keine* Information über einige Basiskoeffizienten enthältda sollten seinzu wenige KnotenTyp iterms ist für den Fall multipler Prädiktoren nicht verfügbarTyp muss 'link' oder 'response' seinnicht unterstützte Methode zur Glattheitswahlnicht unterstützter Testdas unbedingte Argument hat hier keine Bedeutungnicht implementierter dünn besetzter Nebenbedingungstyp verlangtuniquecombs hat nicht richtig gearbeitetunbekannter OptimiererUnbekannte äußere Optimierungsmethodeunbekanntes Glattheitswahl-Kriteriumunbekannte Typ von Tensor-Einschränkungenunerkannter ba.actionunerkannter (Vektor?) Verweisnicht unterstützte Ordnung der Ableitung für gam.fit3 gefordertWert von epsilon muss > 0 seinWerte außerhalb des zulässigen BereichsVariablennamen passen nicht zu BegrenzungsnamenVarianzfunktion für quasi nicht erkanntDie view Variablen müssen aus %s gewählt werdenw hat eine von y verschiedene Länge!Gewichte ignoriertGewichte müssen wie glm-Gewichte sein für verallgemeinerten Fallohne eine Formelx und y müssen gleich lang seinx und y sind nicht gleich langx ist Nullx außerhalb des Wertebereichsxt-Argument ist fehlerhaft.y muss für Tweedie(p=1) ein ganzzahliges Vielfaches von phi seiny muss für die Gamma-Dichte streng positiv seinY muss univariat sein, falls nicht binomischziplss verlangt 2 Links, angegeben als Zeichenkettenmgcv/inst/po/de/LC_MESSAGES/mgcv.mo0000644000176200001440000000422113533720775016262 0ustar liggesusers hXi-%'),Q!~ " E+K@wGd:?3s74!(5^R{3@MC    A term has fewer unique covariate combinations than specified maximum degrees of freedomAn out of bound write to matrix has occurred!Attempt to invert() non-square matrixERROR in addconQT.Failed to initialize memory for matrix.INTEGRITY PROBLEM in the extant matrix list.Incompatible matrices in matmult.QPCLS - Rank deficiency in modelSingular Matrix passed to invert()Target matrix too small in mcopyYou are trying to check matrix integrity without defining RANGECHECK.You must have 2m>d for a thin plate spline.magic requires smoothing parameter starting values if L suppliedmagic, the gcv/ubre optimizer, failed to converge after 400 iterations.Project-Id-Version: R 2.10.0 / mgcv 1.5-5 Report-Msgid-Bugs-To: POT-Creation-Date: 2019-09-04 12:37+0100 PO-Revision-Date: 2009-10-08 16:16+0200 Last-Translator: Chris Leick Language-Team: German Language: de MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n != 1); Ein Term hat weniger einzigartige Kombinationen von Kovariaten als maximal angegebene FreiheitsgradeEin Schreiben außerhalb der Matrixgrenze ist aufgetreten!Versuch des Aufrufs von invert() für nicht-quadratische MatrixFEHLER in addconQT.Initialisieren von Speicher für Matrix fehlgeschlagen.INTEGRITÄTSPROBLEM in der bestehenden Matrix-Liste.Inkompatible Matrizen in matmult.QPCLS - Rang-Defizit im ModellSinguläre Matrix an invert() übergebenZielmatrix zu klein in mcopySie versuchen die Integrität der Matrix zu prüfen ohne RANGECHECK zu definieren.Es muss 2m>d für einen dünnwandige Spline gelten.magic benötigt Glättungsparameter-Startwerte, wenn L angegebenmagic, der gcv/ubre-Optimierer, konvergierte nach 400 Iterationen noch nicht.mgcv/inst/po/pl/0000755000176200001440000000000013073161526013220 5ustar liggesusersmgcv/inst/po/pl/LC_MESSAGES/0000755000176200001440000000000013326153320014777 5ustar liggesusersmgcv/inst/po/pl/LC_MESSAGES/R-mgcv.mo0000644000176200001440000007671113533720051016504 0ustar liggesuserso,E /7P  X/0`#{24*9d576#<Z7>[,;%:#;._"-[n$* >%T!z972 jw#-0 K Sk $ S 8!2L!$!3!!S!:B"=}""7"/#C#L]#%#"###$;5$fq$A$%8%U%8m%6%%$%!!&C&(R&{&)&#&$& '&'8C'&|'-'/')(,+(1X($(((($(6)M)m)F)$)8)E.*t*%****+*+(D+<m++++++ ,0%,#V,,z,%,5,_-lc-+-<-"9.Y\..#.C.78/%p/%/%/%/\0"e0 0R0 01),1V1%q11(1a1=20Q222(222=3AL30313133#41W44444<4B55"x5<555 6I*6't66:6*6707M7h7-7-7)78"83?8s8858"8&98+9d9 999a9:+/:[:5s:O:*:8$;'];#;(;0;<7#<[<,m<<<< <<M=%f=/== =8=4>K>Z>!w>1>>:>? ,?!:?(\?.??"?&?@:,@g@)@*@@5@*APB~P&PeP(NQewQQNQ$ER@jRRdR?,SAlS1SBS.#TRTRhT2T(T(U(@UKiUUe9V$V#VV@WPAW/W2W(WX(6X_X5}X2X/X'Y>YW]Y4Y/Y7Z>RZ4Z>Z$[*[AA[[)[N[-\ D\de\@\X ]Fd]]&]!]^4,^a^/^'^H^/"_R_r_7__L_=&`=d`9`R`/aaP=bXb&bfcuc/cOc9dJMd9d9d9 efFe'e!ece)[ff?f$f4f!g(x,RwU' T"fs" smooth cannot use a multiply penalized basis (wrong basis in xt)"fs" terms can not be fixed here'family' argument seems not to be a valid family object'theta' must be specified,0s in V(mu)1= upper bound in call to mono.con()m can't be in rem wrong length and ignored.maximum number of iterations must be > 0mean, mu, must be non negativemethod not recognised.min.sp not supported with fast REML computation, and ignored.mismatch between nb/polys supplied area names and data area namesmodel has repeated 1-d smooths of same variable.more knots than data in a ds term: knots ignored.more knots than data in a tp term: knots ignored.more knots than data in an sos term: knots ignored.more knots than unique data values is not allowednames of z and pc must matchncol(M$C) != length(M$p)ncol(M$X) != length(M$p)need at least one interior knotnegative values not allowed for the negative binomial familynewdata is a model.frame: it should contain all required variablesnlm.fd only available for GCV/UBREno automatic plotting for smooths of more than two variablesno data to predict atno free coefs in sf smoothno spatial information provided!no valid set of coefficients has been found:please supply starting valuesnon-existent terms requested - ignoringnot a gam objectnot all required variables have been supplied in newdata!not enough unique values to find k nearestnothing to do for this modelnrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)number of supplied knots != k for a cc smoothnumber of supplied knots != k for a cr smoothobject does not appear to be of class lmeobject is not a glm or gamobject not fully initializedone or more supplied k too small - reset to defaultonly deals with 2D caseonly first element of `id' usedonly one level of smooth nesting is supported by gammonly scalar `p' and `phi' allowed.only scalar `rho' and `theta' allowed.ord contains out of range orders (which will be ignored)ord is wrong. reset to NULL.order too lowp must be in (1,2)p must be in [1,2]p-values for any terms that can be penalized to zero will be unreliable: refit model to fix this.penalized deviance = %spenalty basis too large for smoothing basispenalty basis too smallpenalty column names don't match supplied area names!penalty matrix, boundary polygons and/or neighbours list must be supplied in xtpenalty order too high for basis dimensionpredict.gam can only be used to predict from gam objectsrandom argument must be a *named* list.random effects don't work with ids.recov works with fitted gam objects onlyreparameterization unstable for margin: not donerequires an object of class gamresiduals argument to plot.gam is wrong length: ignoreds value increaseds value modified to give continuous functions value reduceds(.) not yet supported.samfrac too small - ignoredscale parameter must be positivesilly tolerance suppliedsilly value supplied for rank.tol: reset to square root of machine precision.singular values not returned in ordersmooth objects should not have a qrc attribute.soap films are bivariate onlysomething wrong with argument d.sorry no option for contouring with errors: try plot.gamsupplied dist negativesupplied knotssupplied penalty not square!supplied penalty wrong dimension!te smooths not useable with gamm4: use t2 insteadtest argument ignoredthe adaptive smooth class is limited to 1 or 2 covariates.there should betoo few knotstype must be "link" or "response"un-supported smoothness selection methodunimplemented sparse constraint type requestedunknown optimizerunknown outer optimization method.unknown smoothness selection criterionunrecognized (vector?) linkunsupported order of differentiation requested of gam.fit3value of epsilon must be > 0variable names don't match boundary namesvariance function not recognized for quasiw different length from y!weights must be like glm weights for generalized casewithout a formulax and y must be same lengthx and y not same lengthx is nullx out of rangext argument is faulty.y must be an integer multiple of phi for Tweedie(p=1)y must be strictly positive for a Gamma densityy must be univariate unless binomialProject-Id-Version: mgcv 1.7-28 Report-Msgid-Bugs-To: bugs@r-project.org POT-Creation-Date: 2019-04-29 12:44 PO-Revision-Date: 2014-03-25 17:39+0100 Last-Translator: Łukasz Daniel Language-Team: Łukasz Daniel Language: pl_PL MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=3; plural=(n==1 ? 0 : n%10>=2 && n%10<=4 && (n%100<10 || n%100>=20) ? 1 : 2); X-Poedit-SourceCharset: iso-8859-1 X-Generator: Poedit 1.5.4 wygładzanie "fs" nie może użyć wielokrotnie ukaranej bazy (błędna baza w xt)człony "fs" nie mogą być poprawione tutajargument 'family' wydaje się nie być poprawnym obiektem klasy "family"argument 'theta' musi być określony,zera w 'V(mu)'1= górny zakres w wywołaniu przekazywanym do funkcji 'mono.con()'argument 'm' nie może być w argumencie 're''m' posiada niepoprawną długość przez co został zignorowanymaksymalna liczba iteracji musi być > 0średnia wartość 'mu' musi być nieujemnametoda nie została rozpoznana'min.sp' nie jest wspierane dla szybkich obliczeń REML, parametr został zignorowany.niezgodność pomiędzy dostarczonymi nazwami obszarów nb/polys a nazwami obszarów danychmodel powtórzył jednowymiarowe wygładzania tej samiej zmiennejwięcej węzłów niż danych w członie 'ds': węzły zostały zignorowanewięcej węzłów niż danych w członie 'tp': węzły zostały zignorowanewięcej węzłów niż danych w członie 'sos': węzły zostały zignorowanewiększa liczba węzłów niż unikalnych wartości danych nie jest dozwolonanazwy 'z' oraz 'pc' muszą się zgadzaćncol(M$C) != length(M$p)ncol(M$X) != length(M$p)potrzeba przynajmniej jednego wewnętrznego węzłaujemne wartości nie są dozwolone dla rozkładu z rodziny Pascala"newdata" jest klasy "model.frame": powinien zawierać wszystkie wymagane zmienne'nlm.fd' jest dostępne jedynie dla GCV/UBREbrak automatycznego rysowania dla wygładzeń o więcej niż dwóch zmiennychbrak danych na których można oprzeć przewidywaniebrak wolnych współczynników w wygładzaniu sfnie dostarczono informacji przestrzennej!nie znaleziono poprawnego zestawu współczynników: proszę dostarczyć wartości startowezażądano nieistniejących członów - ignorowanieargument nie jest obiektem klasy "gam"nie wszystkie wymagane zmienne zostały dostarczone w "newdata"!zbyt mało unikalnych wartości aby znaleźć k najbliższychnic do zrobienia dla tego modelunrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)liczba dostarczonych węzłów != k dla wygładzania 'cc'liczba dostarczonych węzłów != k dla wygładzania 'cr'argument nie jest obiektem klasy "lme"argument 'object' nie jest obiektem klasy "glm" lub "gam"obiekt nie został w pełni zainicjalizowanyjeden lub więcej dostarczonych 'k' jest zbyt mały - przyjmowanie wartości domyślnejobsługiwanie jedynie dwuwymiarowych przypadkówzostał użyty jedynie pierwszy element 'id'tylko jeden poziom zagnieżdżania gładkości jest wspierane przez funkcję 'gamm()'tylko skalarne 'p' oraz 'phi' są dozwolonetylko skalarne 'p' oraz 'phi' są dozwolone'ord' zawiera porządki poza zakresem (zostaną one zignorowane)argument 'ord' jest błędny. Przywracanie wartości NULLzbyt mała wartość argumentu 'ord'argument 'p' musi być w przedziale (1,2)argument 'p' musi być w przedziale [1,2]p-wartości dla jakichkolwiek członów, które da się ukarać do zera, będą nierzetelne: ponownie dopasuj model aby to naprawićkarne odchylenie = %spodstawa kar jest zbyt duża dla podstawy wygładzaniapodstawa kar jest zbyt małanazwa kolumny kary nie zgadza się z dostarczonymi nazwami obszaru!macierz kary, wielokąty brzegowe oraz/lub lista sąsiadów muszą być dostarczone w xtrząd kar jest zbyt duży dla podstawy wymiarufunkcja 'predict.gam()' może być użyta jedynie do przewidywania z obiektów klasy "gam"argument 'random' musi być *nazwaną* listą.losowe efekty nie działają z 'ids'argument nie jest obiektem klasy "gam"ponowna parametryzacja nie jest stabilna dla marginesu: nie wykonanoargument nie jest obiektem klasy "gam"argument reszt przekazywany do 'plot.gam' ma niepoprawną długość: zignorowanowartość 's' została zwiększonawartość 's' została zmieniona aby dać ciągłą funkcjęwartość 's' została zmniejszonafunkcja 's(.)' nie jest jeszcze wspierana'samfrac' jest zbyt małe - zignorowanoparametr skali musi być dodatnidostarczono mało wiarygodną tolerancjęśmieszna wartość została dostarczona do 'rank.tol': ustawianie pierwiastka kwadratowego z precyzji maszynyosobliwe wartości nie zostały zwrócone w w sposób uporządkowanygładkie obiekty nie powinny mieć atrybutu 'qrc'filmy 'soap' są tylko dwuwymiarowecoś nie tak z argumentem 'd'przykro mi, brak opcji rysowania konturu z błędami: spróbuj 'plot.gam'dostarczona odległość jest ujemna dostarczona kara nie jest kwadratowa!dostarczona kara ma niepoprawny wymiar!wygładzania 'te' nie są stosowalne z 'gamm4': zamiast tego użyj t2argument 'test' został zignorowanyadaptacyjna klasa wygładzania jest ograniczona do 1 lub 2 zmiennychliczba dostarczonych węzłów powinna być równa:zbyt mało węzłów'type' musi mieć wartość "link" lub "response"niewspierana metoda wyboru wygładzaniazażądano niezaimplementowanego typu rzadkiego więzunieznany optymalizatornieznana zewnętrzna metoda optymalizacjinieznane kryterium wyboru wygładzanianierozpoznane (wektorowe?) połączenieniewspierany porządek różniczkowania zażądany od 'gam.fit3()'wartość 'epsilon' musi być > 0nazwy zmiennych nie zgadzają się z nazwami granicfunkcja wariancji nie została rozpoznana dla kwaziargument 'w' posiada długość inną niż argument 'y'!wagi muszą być jak wagi w 'glm' dla ogólnego przypadkubez formułyx oraz y muszą mieć tę samą długość'x' oraz 'y' nie mają tej samej długości'x' ma wartość NULLargument 'x' jest poza zakresemargument 'xt' jest błędnyargument 'y' musi być całkowitą wielokrotnością argumentu 'phi' dla 'Tweedie(p=1)'argument 'y' musi być ściśle dodatni dla gęstości Gamma'y' musi zawierać jedną zmienną jeśli nie zawiera dwóchmgcv/inst/po/pl/LC_MESSAGES/mgcv.mo0000644000176200001440000000446213533720775016314 0ustar liggesusers hXi-%'),Q!~ " E+K@wGs({=74- b*6J.P`Q    A term has fewer unique covariate combinations than specified maximum degrees of freedomAn out of bound write to matrix has occurred!Attempt to invert() non-square matrixERROR in addconQT.Failed to initialize memory for matrix.INTEGRITY PROBLEM in the extant matrix list.Incompatible matrices in matmult.QPCLS - Rank deficiency in modelSingular Matrix passed to invert()Target matrix too small in mcopyYou are trying to check matrix integrity without defining RANGECHECK.You must have 2m>d for a thin plate spline.magic requires smoothing parameter starting values if L suppliedmagic, the gcv/ubre optimizer, failed to converge after 400 iterations.Project-Id-Version: mgcv 1.7-28 Report-Msgid-Bugs-To: POT-Creation-Date: 2019-09-04 12:37+0100 PO-Revision-Date: 2014-03-24 17:59+0100 Last-Translator: Łukasz Daniel Language-Team: Łukasz Daniel Language: pl_PL MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=3; plural=(n==1 ? 0 : n%10>=2 && n%10<=4 && (n%100<10 || n%100>=20) ? 1 : 2); X-Poedit-SourceCharset: iso-8859-1 X-Generator: Poedit 1.5.4 Człon posiada mniej unikalnych kombinacji zmiennych niezależnych niż określona maksymalna liczba stopni swobodyNastąpił zapis poza zakresem macierzy!Próba odwrócenia metodą 'invert()' niekwadratowej macierzyBŁĄD w addconQT.Nie udało się zainicjalizować pamięci dla macierzy.PROBLEM SPÓJNOŚCI w istniejącej liście macierzy.Niespójne macierze w 'matmult'.QPCLS - Niedobór rang w modeluPrzekazano osobliwą macierz do 'invert()'Docelowa macierz jest zbyt mała, aby wykonać 'mcopy'Próbujesz sprawdzić integralność macierzy bez określania 'RANGECHECK'Musisz mieć 2m>d dla cienkiej płyty splajnu.'magic' wymaga wartości startowych dla parametru wygładzającego jeśli L zostało dostarczone'magic', omptymalizator gcv/ubre, nie zdodał uzbieżnić się po 400 iteracjach.mgcv/inst/po/en@quot/0000755000176200001440000000000013073161526014220 5ustar liggesusersmgcv/inst/po/en@quot/LC_MESSAGES/0000755000176200001440000000000013326153316016004 5ustar liggesusersmgcv/inst/po/en@quot/LC_MESSAGES/R-mgcv.mo0000644000176200001440000013063413533720775017514 0ustar liggesusersd 9#E# #d#7]$$$ $$ $X$=%/V%%#%%A%2&N&4l&*&&&5&5'7S'6'<'7'7(>U([(;(%,)>R)):)#).*B5*x*"**-*[*X+Fu+@+$+$",*G, r,,>,%,!-3-9S--'---..(.7>. v..#...+.-$/0R//S/$/'0SD0070:021$R13w11S1N2:d2@2R2-33=a3#33'3A 4#M49q474/45L-5(z5%5"5#5&676;U6f6A6-:7-h7>7#77(8+@8Al8888869S9$r9!999(91 :>:)Y:8: :#:$;&;C;8`;+;6;&;-#</Q<2<+<:<)=,E=1r= =$===> 3>T>e>$>6>0>& ?4?T?Fp?$?8?E@[@%v@@@@D@(1AZA*nAA3A1A(B7B0RB5B1B<B(C*@CkCCC+C C0C#DM>D,D%D5D_E-uElE+F<W'nW'W5WW:X@XWX*uXXXXX Y#$Y'HY)pY-Y-Y)Y Z;Z3XZZZ5Z"Z&[6D[8{[[ [[[a\.g\\\+\\5]O<]*]8]']#^"<^(_^0^5^^ _70_-h_4__,_ ``.`F`&b` `-``.`"aM;a+a%aa/a?#bcb#b b-b*bc8:csc c'cccc!d7=dNud1dd: e7Gee e6e!e(ef*1f.\f#ff"f&f g*gAg:]gggg)g*h ;h\hwh5hhhh i ii53i/ii$i6i6iE,k rkdk;k4lRl Tl`l zlXll/l)m#DmhmA|m2mm4n*Dnonn5nn7n6.o<eo7oo>o[7p;p%p>p4q:Jq#q.qBqr":r]r-qr[rrFs@_s$s$s*s t6t>Ot%t!tt9t0u'Ou-wuuuu7u v&v#:v^v|v+v-v0v&wSFw$w'wSw;x7Ox:x2x$x3yNySdyNy:z@BzVz-z={#F{j{'{A{#{9|7R|/||L|(!}%J}"p}#}&}};}f8~A~-~->=#|(+AUr86À$!>`o(1)8* c#$͂8+@6l&-ʃ/2(+[:)„,1 K$l… څ $'6L0&ۆF$^8E%CZsD(؈*@3O1(މ05*1`<ϊ*-C+Y 0#M,3%`5_-lJ+<7 6X%6"Yi#"0ʏC+?k77Ð%%!%G%mEBّ *)\T6ǒ" !RB )œ% J0{B(ٔ$+'SgjAҕ.-C,qaQ4RcQ*=h0|(ژ"=9Aw&011C2u31ܚ-"Pd'#Л<?@|B".#=R<͝$8 ]I~Ȟ/''=5e:*G]z#ˠ')-A-o)ǡ33K5k"&Ģ68"[ xa.=Q+i5O*38^'#"(0/5` 7צ-4=r,է& 0-Q.ɨM+0%\/?ʩ #( L-m*ƪ8 6'W!«7N1k:7& 66D!{(ƭ*ح.#2V"h&Ѯ:?\y)* 5.dv ð5ڰ/$@6e&m!_E B1[|+DtR5ac^WfN~rhJ@4 \{  bFPZ#Nl +?g`6WpBz]'O,~".;%-uH$}c_Q;E-^nR1$FjqQ>] dC6kuIS(q nYyTJojG4axX| 9DUkZ0Sp*2LV, O}`i'z@73e&2Ts7Y9!whC[y)d*v>m8t<iKP=)(:g"VHKU?X{s/8<ebAL.rA#3/5w%\MlM o0:=xIGv f"fs" smooth cannot use a multiply penalized basis (wrong basis in xt)"fs" terms can not be fixed here%s link not available for negative binomial family; available links are "identity", "log" and "sqrt"'family' argument seems not to be a valid family object'theta' must be specified,0s in V(mu)1= upper bound in call to mono.con()m can't be in rem wrong length and ignored.maximum number of iterations must be > 0mean, mu, must be non negativemethod not recognised.min.sp not supported with fast REML computation, and ignored.mismatch between nb/polys supplied area names and data area namesmodal weight <=0 in integration step!!model has repeated 1-d smooths of same variable.more knots than data in a ds term: knots ignored.more knots than data in a tp term: knots ignored.more knots than data in an ms term: knots ignored.more knots than data in an sos term: knots ignored.more knots than unique data values is not allowedmu dimensions wrongmultiple penalties of the same order is sillymvn dimension errormvn does not yet handle offsetsmvn requires 2 or more dimensional datana.action not character or functionnames of z and pc must matchncol(M$C) != length(M$p)ncol(M$X) != length(M$p)need at least one interior knotnegative values not allowed for the negative binomial familynegative values not allowed for the zero inflated Poisson familynewdata is a model.frame: it should contain all required variablesnlm.fd only available for GCV/UBREno NAs allowed in response data for this modelno automatic plotting for smooths of more than four variablesno automatic plotting for smooths of more than two variablesno data to predict atno factor supplied to fs smoothno free coefs in sf smoothno good data in iterationno smooths, ignoring `discrete=TRUE'no spatial information provided!no valid set of coefficients has been found:please supply starting valuesnon finite values in Hessiannon-existent exclude terms requested - ignoringnon-existent terms requested - ignoringnon-finite coefficients at iteration %dnon-integer binomial denominator: quantiles incorrectnot a gam objectnot all required variables have been supplied in newdata!not an extended familynot enough finite derivativesnot enough unique values to find k nearestnot positive definitenothing to do for this modelnrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)nthreads must be a positive integernumber of categories must be at least 2number of linear predictors doesn't matchnumber of supplied knots != k for a cc smoothnumber of supplied knots != k for a cr smoothobject does not appear to be of class lmeobject is not a glm or gamobject not fully initializedone or more supplied k too small - reset to defaultonly deals with 2D caseonly first element of `id' usedonly one level of smooth nesting is supported by gammonly scalar `p' and `phi' allowed.only scalar `rho' and `theta' allowed.openMP not available: single threaded computation onlyord contains out of range orders (which will be ignored)ord is wrong. reset to NULL.order too lowp must be in (1,2)p must be in [1,2]p-values for any terms that can be penalized to zero will be unreliable: refit model to fix this.paraPen not supported for multi-formula modelsparameter of ziplsspenalized deviance = %spenalty basis too large for smoothing basispenalty basis too smallpenalty column names don't match supplied area names!penalty matrix, boundary polygons and/or neighbours list must be supplied in xtpenalty order too high for basis dimensionpredict.gam can only be used to predict from gam objectsrandom argument must be a *named* list.random effects don't work with ids.rank deficient re-parameterizationrecov works with fitted gam objects onlyreparameterization unstable for margin: not donerequested non-existent derivative in B-spline penaltyrequires an object of class gamresiduals argument not supportedresiduals argument to plot.gam is wrong length: ignoredresponse not in 0 to number of predictors + 1rho missing from simulation data edf.type reset to 2s value increaseds value modified to give continuous functions value reduceds(.) not supported.s(.) not yet supported.samfrac too small - ignoredsaturated likelihood may be inaccuratescale parameter must be positivesd should have exactly one less entry than ldshared offsets not allowedside conditions not allowed for nested smoothssilly tolerance suppliedsilly value supplied for rank.tol: reset to square root of machine precision.single linear predictor indices are ignoredsingular values not returned in ordersize must be in [1,120]smooth objects should not have a qrc attribute.smoothing parameter prior choise not recognised, reset to gammasoap films are bivariate onlysomething wrong with A index vectorsomething wrong with argument d.something wrong with inputs to LAPACK routinesomething wrong with stratified predictionsorry link not yet handledsorry no option for contouring with errors: try plot.gamstep failed: max abs grad =step failure in theta estimationsupplied S matrices are wrong diminsionsupplied dist negativesupplied knotssupplied penalty not square!supplied penalty wrong dimension!supply a value for each variable for a point constraintsweep and drop constraints unlikely to work well with self handling of by varste smooths not useable with gamm4: use t2 insteadtest argument ignoredthe adaptive smooth class is limited to 1 or 2 covariates.there is *no* information about some basis coefficientsthere should betoo few knotstype iterms not available for multiple predictor casestype must be "link" or "response"un-supported smoothness selection methodun-supported testunconditional argument not meaningful hereunimplemented sparse constraint type requesteduniquecombs has not worked properlyunknown optimizerunknown outer optimization method.unknown smoothness selection criterionunknown tensor constraint typeunrecognised na.actionunrecognized (vector?) linkunsupported order of differentiation requested of gam.fit3update not positive definitevalue of epsilon must be > 0values out of rangevariable names don't match boundary namesvariance function not recognized for quasiview variables must be one of %sw different length from y!weights ignoredweights must be like glm weights for generalized casewithout a formulax and y must be same lengthx and y not same lengthx is nullx out of rangext argument is faulty.y must be an integer multiple of phi for Tweedie(p=1)y must be strictly positive for a Gamma densityy must be univariate unless binomialziplss requires 2 links specified as character stringsProject-Id-Version: mgcv 1.8-29 POT-Creation-Date: 2019-04-29 13:35 PO-Revision-Date: 2019-04-29 13:35 Last-Translator: Automatically generated Language-Team: none MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Language: en Plural-Forms: nplurals=2; plural=(n != 1); "fs" smooth cannot use a multiply penalized basis (wrong basis in xt)"fs" terms can not be fixed here%s link not available for negative binomial family; available links are "identity", "log" and "sqrt"‘family’ argument seems not to be a valid family object‘theta’ must be specified,0s in V(mu)1= upper bound in call to mono.con()m can't be in rem wrong length and ignored.maximum number of iterations must be > 0mean, mu, must be non negativemethod not recognised.min.sp not supported with fast REML computation, and ignored.mismatch between nb/polys supplied area names and data area namesmodal weight <=0 in integration step!!model has repeated 1-d smooths of same variable.more knots than data in a ds term: knots ignored.more knots than data in a tp term: knots ignored.more knots than data in an ms term: knots ignored.more knots than data in an sos term: knots ignored.more knots than unique data values is not allowedmu dimensions wrongmultiple penalties of the same order is sillymvn dimension errormvn does not yet handle offsetsmvn requires 2 or more dimensional datana.action not character or functionnames of z and pc must matchncol(M$C) != length(M$p)ncol(M$X) != length(M$p)need at least one interior knotnegative values not allowed for the negative binomial familynegative values not allowed for the zero inflated Poisson familynewdata is a model.frame: it should contain all required variablesnlm.fd only available for GCV/UBREno NAs allowed in response data for this modelno automatic plotting for smooths of more than four variablesno automatic plotting for smooths of more than two variablesno data to predict atno factor supplied to fs smoothno free coefs in sf smoothno good data in iterationno smooths, ignoring `discrete=TRUE'no spatial information provided!no valid set of coefficients has been found:please supply starting valuesnon finite values in Hessiannon-existent exclude terms requested - ignoringnon-existent terms requested - ignoringnon-finite coefficients at iteration %dnon-integer binomial denominator: quantiles incorrectnot a gam objectnot all required variables have been supplied in newdata!not an extended familynot enough finite derivativesnot enough unique values to find k nearestnot positive definitenothing to do for this modelnrow(M$Ain) != length(M$bin)nrow(M$Ain) != length(M$p)nrow(M$X) != length(M$y)nthreads must be a positive integernumber of categories must be at least 2number of linear predictors doesn't matchnumber of supplied knots != k for a cc smoothnumber of supplied knots != k for a cr smoothobject does not appear to be of class lmeobject is not a glm or gamobject not fully initializedone or more supplied k too small - reset to defaultonly deals with 2D caseonly first element of `id' usedonly one level of smooth nesting is supported by gammonly scalar `p' and `phi' allowed.only scalar `rho' and `theta' allowed.openMP not available: single threaded computation onlyord contains out of range orders (which will be ignored)ord is wrong. reset to NULL.order too lowp must be in (1,2)p must be in [1,2]p-values for any terms that can be penalized to zero will be unreliable: refit model to fix this.paraPen not supported for multi-formula modelsparameter of ziplsspenalized deviance = %spenalty basis too large for smoothing basispenalty basis too smallpenalty column names don't match supplied area names!penalty matrix, boundary polygons and/or neighbours list must be supplied in xtpenalty order too high for basis dimensionpredict.gam can only be used to predict from gam objectsrandom argument must be a *named* list.random effects don't work with ids.rank deficient re-parameterizationrecov works with fitted gam objects onlyreparameterization unstable for margin: not donerequested non-existent derivative in B-spline penaltyrequires an object of class gamresiduals argument not supportedresiduals argument to plot.gam is wrong length: ignoredresponse not in 0 to number of predictors + 1rho missing from simulation data edf.type reset to 2s value increaseds value modified to give continuous functions value reduceds(.) not supported.s(.) not yet supported.samfrac too small - ignoredsaturated likelihood may be inaccuratescale parameter must be positivesd should have exactly one less entry than ldshared offsets not allowedside conditions not allowed for nested smoothssilly tolerance suppliedsilly value supplied for rank.tol: reset to square root of machine precision.single linear predictor indices are ignoredsingular values not returned in ordersize must be in [1,120]smooth objects should not have a qrc attribute.smoothing parameter prior choise not recognised, reset to gammasoap films are bivariate onlysomething wrong with A index vectorsomething wrong with argument d.something wrong with inputs to LAPACK routinesomething wrong with stratified predictionsorry link not yet handledsorry no option for contouring with errors: try plot.gamstep failed: max abs grad =step failure in theta estimationsupplied S matrices are wrong diminsionsupplied dist negativesupplied knotssupplied penalty not square!supplied penalty wrong dimension!supply a value for each variable for a point constraintsweep and drop constraints unlikely to work well with self handling of by varste smooths not useable with gamm4: use t2 insteadtest argument ignoredthe adaptive smooth class is limited to 1 or 2 covariates.there is *no* information about some basis coefficientsthere should betoo few knotstype iterms not available for multiple predictor casestype must be "link" or "response"un-supported smoothness selection methodun-supported testunconditional argument not meaningful hereunimplemented sparse constraint type requesteduniquecombs has not worked properlyunknown optimizerunknown outer optimization method.unknown smoothness selection criterionunknown tensor constraint typeunrecognised na.actionunrecognized (vector?) linkunsupported order of differentiation requested of gam.fit3update not positive definitevalue of epsilon must be > 0values out of rangevariable names don't match boundary namesvariance function not recognized for quasiview variables must be one of %sw different length from y!weights ignoredweights must be like glm weights for generalized casewithout a formulax and y must be same lengthx and y not same lengthx is nullx out of rangext argument is faulty.y must be an integer multiple of phi for Tweedie(p=1)y must be strictly positive for a Gamma densityy must be univariate unless binomialziplss requires 2 links specified as character stringsmgcv/inst/po/en@quot/LC_MESSAGES/mgcv.mo0000644000176200001440000000375713533721060017306 0ustar liggesusers hXi-%'),Q!~ " E+K@wGWXX-%',@!m " E+:@fG    A term has fewer unique covariate combinations than specified maximum degrees of freedomAn out of bound write to matrix has occurred!Attempt to invert() non-square matrixERROR in addconQT.Failed to initialize memory for matrix.INTEGRITY PROBLEM in the extant matrix list.Incompatible matrices in matmult.QPCLS - Rank deficiency in modelSingular Matrix passed to invert()Target matrix too small in mcopyYou are trying to check matrix integrity without defining RANGECHECK.You must have 2m>d for a thin plate spline.magic requires smoothing parameter starting values if L suppliedmagic, the gcv/ubre optimizer, failed to converge after 400 iterations.Project-Id-Version: mgcv 1.8-29 Report-Msgid-Bugs-To: POT-Creation-Date: 2019-09-04 12:37+0100 PO-Revision-Date: 2019-09-04 12:37+0100 Last-Translator: Automatically generated Language-Team: none Language: en MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n != 1); A term has fewer unique covariate combinations than specified maximum degrees of freedomAn out of bound write to matrix has occurred!Attempt to invert() non-square matrixERROR in addconQT.Failed to initialize memory for matrix.INTEGRITY PROBLEM in the extant matrix list.Incompatible matrices in matmult.QPCLS - Rank deficiency in modelSingular Matrix passed to invert()Target matrix too small in mcopyYou are trying to check matrix integrity without defining RANGECHECK.You must have 2m>d for a thin plate spline.magic requires smoothing parameter starting values if L suppliedmagic, the gcv/ubre optimizer, failed to converge after 400 iterations.mgcv/po/0000755000176200001440000000000013561356113011630 5ustar liggesusersmgcv/po/en@quot.po0000755000176200001440000001417013073161527013612 0ustar liggesusers# English translations for R package. # Copyright (C) 2005 The R Foundation # This file is distributed under the same license as the R package. # Automatically generated, 2005. # # All this catalog "translates" are quotation characters. # The msgids must be ASCII and therefore cannot contain real quotation # characters, only substitutes like grave accent (0x60), apostrophe (0x27) # and double quote (0x22). These substitutes look strange; see # http://www.cl.cam.ac.uk/~mgk25/ucs/quotes.html # # This catalog translates grave accent (0x60) and apostrophe (0x27) to # left single quotation mark (U+2018) and right single quotation mark (U+2019). # It also translates pairs of apostrophe (0x27) to # left single quotation mark (U+2018) and right single quotation mark (U+2019) # and pairs of quotation mark (0x22) to # left double quotation mark (U+201C) and right double quotation mark (U+201D). # # When output to an UTF-8 terminal, the quotation characters appear perfectly. # When output to an ISO-8859-1 terminal, the single quotation marks are # transliterated to apostrophes (by iconv in glibc 2.2 or newer) or to # grave/acute accent (by libiconv), and the double quotation marks are # transliterated to 0x22. # When output to an ASCII terminal, the single quotation marks are # transliterated to apostrophes, and the double quotation marks are # transliterated to 0x22. # msgid "" msgstr "" "Project-Id-Version: R 2.3.0\n" "Report-Msgid-Bugs-To: bugs@R-project.org\n" "POT-Creation-Date: 2005-12-09 07:31+0000\n" "PO-Revision-Date: 2005-12-09 07:31+0000\n" "Last-Translator: Automatically generated\n" "Language-Team: none\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n != 1);\n" #: gcv.c:290 #, c-format msgid "" "Overall smoothing parameter estimate on upper boundary.\n" "Boundary GCV score change: %g. Largest change: %g" msgstr "" "Overall smoothing parameter estimate on upper boundary.\n" "Boundary GCV score change: %g. Largest change: %g" #: gcv.c:875 msgid "resetting -ve inf" msgstr "resetting -ve inf" #: gcv.c:877 msgid "resetting +ve inf" msgstr "resetting +ve inf" #: gcv.c:1014 msgid "" "Multiple GCV didn't improve autoinitialized relative smoothing parameters" msgstr "" "Multiple GCV didn't improve autoinitialized relative smoothing parameters" #: magic.c:809 msgid "magic, the gcv/ubre optimizer, failed to converge after 400 iterations." msgstr "" "magic, the gcv/ubre optimizer, failed to converge after 400 iterations." #: matrix.c:85 msgid "Failed to initialize memory for matrix." msgstr "Failed to initialize memory for matrix." #: matrix.c:147 matrix.c:210 msgid "An out of bound write to matrix has occurred!" msgstr "An out of bound write to matrix has occurred!" #: matrix.c:153 msgid "INTEGRITY PROBLEM in the extant matrix list." msgstr "INTEGRITY PROBLEM in the extant matrix list." #: matrix.c:186 msgid "You are trying to check matrix integrity without defining RANGECHECK." msgstr "You are trying to check matrix integrity without defining RANGECHECK." #: matrix.c:255 #, c-format msgid "" "\n" "%s not found, nothing read ! " msgstr "" "\n" "%s not found, nothing read ! " #: matrix.c:325 msgid "Target matrix too small in mcopy" msgstr "Target matrix too small in mcopy" #: matrix.c:345 matrix.c:353 matrix.c:366 matrix.c:374 msgid "Incompatible matrices in matmult." msgstr "Incompatible matrices in matmult." #: matrix.c:480 msgid "Attempt to invert() non-square matrix" msgstr "Attempt to invert() non-square matrix" #: matrix.c:502 msgid "Singular Matrix passed to invert()" msgstr "Singular Matrix passed to invert()" #: matrix.c:655 msgid "Not a +ve def. matrix in choleski()." msgstr "Not a +ve def. matrix in choleski()." #: matrix.c:873 msgid "Error in Covariance(a,b) - a,b not same length." msgstr "Error in Covariance(a,b) - a,b not same length." #: matrix.c:1812 msgid "svd() not converged" msgstr "svd() not converged" #: matrix.c:1968 #, c-format msgid "%s not found by routine gettextmatrix().\n" msgstr "%s not found by routine gettextmatrix().\n" #: matrix.c:2190 #, c-format msgid "svdroot matrix not +ve semi def. %g" msgstr "svdroot matrix not +ve semi def. %g" #: matrix.c:2414 msgid "Sort failed" msgstr "Sort failed" #: matrix.c:2542 msgid "eigen_tri() failed to converge" msgstr "eigen_tri() failed to converge" #: matrix.c:2698 #, c-format msgid "eigenvv_tri() Eigen vector %d of %d failure. Error = %g > %g" msgstr "eigenvv_tri() Eigen vector %d of %d failure. Error = %g > %g" #: matrix.c:2832 msgid "Lanczos failed" msgstr "Lanczos failed" #: mgcv.c:868 msgid "" "Numerical difficulties obtaining tr(A) - apparently resolved. Apply some " "caution to results." msgstr "" "Numerical difficulties obtaining tr(A) - apparently resolved. Apply some " "caution to results." #: mgcv.c:872 msgid "tr(A) utter garbage and situation un-resolvable." msgstr "tr(A) utter garbage and situation un-resolvable." #: mgcv.c:873 msgid "" "Numerical difficulties calculating tr(A). Not completely resolved. Use " "results with care!" msgstr "" "Numerical difficulties calculating tr(A). Not completely resolved. Use " "results with care!" #: mgcv.c:958 msgid "Termwise estimate degrees of freedom are unreliable" msgstr "Termwise estimate degrees of freedom are unreliable" #: qp.c:59 msgid "ERROR in addconQT." msgstr "ERROR in addconQT." #: qp.c:465 msgid "QPCLS - Rank deficiency in model" msgstr "QPCLS - Rank deficiency in model" #: tprs.c:45 msgid "You must have 2m>d for a thin plate spline." msgstr "You must have 2m>d for a thin plate spline." #: tprs.c:99 msgid "You must have 2m > d" msgstr "You must have 2m > d" #: tprs.c:357 tprs.c:367 msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" #: tprs.c:359 msgid "" "Too many knots for t.p.r.s term: see `gam.control' to increase limit, or use " "a different basis, or see large data set help for `gam'." msgstr "" "Too many knots for t.p.r.s term: see ‘gam.control’ to increase limit, or use " "a different basis, or see large data set help for ‘gam’." mgcv/po/mgcv.pot0000755000176200001440000000336413533720775013331 0ustar liggesusers# SOME DESCRIPTIVE TITLE. # Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER # This file is distributed under the same license as the mgcv package. # FIRST AUTHOR , YEAR. # #, fuzzy msgid "" msgstr "" "Project-Id-Version: mgcv 1.8-29\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2019-09-04 12:37+0100\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" "Language: \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=CHARSET\n" "Content-Transfer-Encoding: 8bit\n" #: magic.c:444 msgid "magic requires smoothing parameter starting values if L supplied" msgstr "" #: magic.c:562 msgid "magic, the gcv/ubre optimizer, failed to converge after 400 iterations." msgstr "" #: matrix.c:82 msgid "Failed to initialize memory for matrix." msgstr "" #: matrix.c:144 matrix.c:202 msgid "An out of bound write to matrix has occurred!" msgstr "" #: matrix.c:150 msgid "INTEGRITY PROBLEM in the extant matrix list." msgstr "" #: matrix.c:182 msgid "You are trying to check matrix integrity without defining RANGECHECK." msgstr "" #: matrix.c:240 msgid "Target matrix too small in mcopy" msgstr "" #: matrix.c:260 matrix.c:268 matrix.c:281 matrix.c:289 msgid "Incompatible matrices in matmult." msgstr "" #: matrix.c:313 msgid "Attempt to invert() non-square matrix" msgstr "" #: matrix.c:335 msgid "Singular Matrix passed to invert()" msgstr "" #: qp.c:59 msgid "ERROR in addconQT." msgstr "" #: qp.c:465 msgid "QPCLS - Rank deficiency in model" msgstr "" #: tprs.c:42 msgid "You must have 2m>d for a thin plate spline." msgstr "" #: tprs.c:377 tprs.c:385 msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" mgcv/po/R-en@quot.po0000755000176200001440000004304613073161532014011 0ustar liggesusers# All this catalog "translates" are quotation characters. # The msgids must be ASCII and therefore cannot contain real quotation # characters, only substitutes like grave accent (0x60), apostrophe (0x27) # and double quote (0x22). These substitutes look strange; see # http://www.cl.cam.ac.uk/~mgk25/ucs/quotes.html # # This catalog translates grave accent (0x60) and apostrophe (0x27) to # left single quotation mark (U+2018) and right single quotation mark (U+2019). # It also translates pairs of apostrophe (0x27) to # left single quotation mark (U+2018) and right single quotation mark (U+2019) # and pairs of quotation mark (0x22) to # left double quotation mark (U+201C) and right double quotation mark (U+201D). # # When output to an UTF-8 terminal, the quotation characters appear perfectly. # When output to an ISO-8859-1 terminal, the single quotation marks are # transliterated to apostrophes (by iconv in glibc 2.2 or newer) or to # grave/acute accent (by libiconv), and the double quotation marks are # transliterated to 0x22. # When output to an ASCII terminal, the single quotation marks are # transliterated to apostrophes, and the double quotation marks are # transliterated to 0x22. # msgid "" msgstr "" "Project-Id-Version: R 2.3.0\n" "Report-Msgid-Bugs-To: bugs@r-project.org\n" "POT-Creation-Date: 2005-12-09 07:31\n" "PO-Revision-Date: 2005-12-09 07:31\n" "Last-Translator: Automatically generated\n" "Language-Team: none\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n != 1);\n" msgid "illegal `family' argument" msgstr "illegal ‘family’ argument" msgid "Invalid linear predictor values in empty model" msgstr "Invalid linear predictor values in empty model" msgid "Invalid fitted means in empty model" msgstr "Invalid fitted means in empty model" msgid "Length of start should equal" msgstr "Length of start should equal" msgid "and correspond to initial coefs for" msgstr "and correspond to initial coefs for" msgid "Can't find valid starting values: please specify some" msgstr "Can't find valid starting values: please specify some" msgid "NAs in V(mu)" msgstr "NAs in V(mu)" msgid "0s in V(mu)" msgstr "0s in V(mu)" msgid "NAs in d(mu)/d(eta)" msgstr "NAs in d(mu)/d(eta)" msgid "No observations informative at iteration" msgstr "No observations informative at iteration" msgid "Not enough informative observations." msgstr "Not enough informative observations." msgid "Non-finite coefficients at iteration" msgstr "Non-finite coefficients at iteration" msgid "" "no valid set of coefficients has been found:please supply starting values" msgstr "" "no valid set of coefficients has been found:please supply starting values" msgid "Step size truncated due to divergence" msgstr "Step size truncated due to divergence" msgid "inner loop 1; can't correct step size" msgstr "inner loop 1; can't correct step size" msgid "Step size truncated: out of bounds" msgstr "Step size truncated: out of bounds" msgid "inner loop 2; can't correct step size" msgstr "inner loop 2; can't correct step size" msgid "inner loop 3; can't correct step size" msgstr "inner loop 3; can't correct step size" msgid "Algorithm did not converge" msgstr "Algorithm did not converge" msgid "Algorithm stopped at boundary value" msgstr "Algorithm stopped at boundary value" msgid "fitted probabilities numerically 0 or 1 occurred" msgstr "fitted probabilities numerically 0 or 1 occurred" msgid "fitted rates numerically 0 occurred" msgstr "fitted rates numerically 0 occurred" msgid "fam not a family object" msgstr "fam not a family object" msgid "unrecognized (vector?) link" msgstr "unrecognized (vector?) link" msgid "link not recognised" msgstr "link not recognised" msgid "variance function not recognized for quasi" msgstr "variance function not recognized for quasi" msgid "family not recognised" msgstr "family not recognised" msgid "H has wrong dimension" msgstr "H has wrong dimension" msgid "An object of length" msgstr "An object of length" msgid "does not match the required parameter size" msgstr "does not match the required parameter size" msgid "NA's in pdTens factor" msgstr "NA's in pdTens factor" msgid "Cannot extract the matrix from an uninitialized object" msgstr "Cannot extract the matrix from an uninitialized object" msgid "NA's in pdTens matrix" msgstr "NA's in pdTens matrix" msgid "Cannot extract the matrix from an uninitialized pdMat object" msgstr "Cannot extract the matrix from an uninitialized pdMat object" msgid "Cannot extract the matrix with uninitialized dimensions" msgstr "Cannot extract the matrix with uninitialized dimensions" msgid "Must give names when initializing pdIdnot from parameter." msgstr "Must give names when initializing pdIdnot from parameter." msgid "without a formula" msgstr "without a formula" msgid "Cannot extract the dimensions" msgstr "Cannot extract the dimensions" msgid "Cannot extract the inverse from an uninitialized object" msgstr "Cannot extract the inverse from an uninitialized object" msgid "No data supplied to gam.setup" msgstr "No data supplied to gam.setup" msgid "NA's passed to eig: please email Simon.Wood@R-project.org with details" msgstr "NA's passed to eig: please email Simon.Wood@R-project.org with details" msgid "" "NA eigenvalues returned by eigen: please email Simon.Wood@R-project.org with " "details" msgstr "" "NA eigenvalues returned by eigen: please email Simon.Wood@R-project.org with " "details" msgid "" "NA's in eigenvectors from eigen: please email Simon.Wood@R-project.org with " "details" msgstr "" "NA's in eigenvectors from eigen: please email Simon.Wood@R-project.org with " "details" msgid "" "NA singular values returned by svd: please email Simon.Wood@R-project.org " "with details" msgstr "" "NA singular values returned by svd: please email Simon.Wood@R-project.org " "with details" msgid "" "NA's in singular vectors from svd: please email Simon.Wood@R-project.org " "with details" msgstr "" "NA's in singular vectors from svd: please email Simon.Wood@R-project.org " "with details" msgid "" "NA problem resolved using svd, but please email Simon.Wood@R-project.org " "anyway" msgstr "" "NA problem resolved using svd, but please email Simon.Wood@R-project.org " "anyway" msgid "Problem with linear algebra routines." msgstr "Problem with linear algebra routines." msgid "First argument is no sort of formula!" msgstr "First argument is no sort of formula!" msgid "You've got no model...." msgstr "You've got no model...." msgid "gamm can not fix only some margins of tensor product." msgstr "gamm can not fix only some margins of tensor product." msgid "" "Tensor product penalty rank appears to be too low: please email Simon.Wood@R-" "project.org with details." msgstr "" "Tensor product penalty rank appears to be too low: please email Simon.Wood@R-" "project.org with details." msgid "object does not appear to be of class lme" msgstr "object does not appear to be of class lme" msgid "inner groupings not nested in outer!!" msgstr "inner groupings not nested in outer!!" msgid "gamm() requires package nlme to be installed" msgstr "gamm() requires package nlme to be installed" msgid "gamm() requires package MASS to be installed" msgstr "gamm() requires package MASS to be installed" msgid "random argument must be a *named* list." msgstr "random argument must be a *named* list." msgid "all elements of random list must be named" msgstr "all elements of random list must be named" msgid "gamm() can only handle random effects defined as named lists" msgstr "gamm() can only handle random effects defined as named lists" msgid "Not enough (non-NA) data to do anything meaningful" msgstr "Not enough (non-NA) data to do anything meaningful" msgid "family not recognized" msgstr "family not recognized" msgid "" "gamm models must have at least 1 smooth with unknown smoothing parameter or " "at least one other random effect" msgstr "" "gamm models must have at least 1 smooth with unknown smoothing parameter or " "at least one other random effect" msgid "At least three knots required in call to mono.con." msgstr "At least three knots required in call to mono.con." msgid "lower bound >= upper bound in call to mono.con()" msgstr "lower bound >= upper bound in call to mono.con()" msgid "x is null" msgstr "x is null" msgid "x has no row attribute" msgstr "x has no row attribute" msgid "x has no col attribute" msgstr "x has no col attribute" msgid "d can not be negative in call to null.space.dimension()." msgstr "d can not be negative in call to null.space.dimension()." msgid "nrow(M$X) != length(M$y)" msgstr "nrow(M$X) != length(M$y)" msgid "ncol(M$X) != length(M$p)" msgstr "ncol(M$X) != length(M$p)" msgid "length(M$w) != length(M$y)" msgstr "length(M$w) != length(M$y)" msgid "nrow(M$Ain) != length(M$bin)" msgstr "nrow(M$Ain) != length(M$bin)" msgid "nrow(M$Ain) != length(M$p)" msgstr "nrow(M$Ain) != length(M$p)" msgid "initial parameters very close to inequality constraints" msgstr "initial parameters very close to inequality constraints" msgid "ncol(M$C) != length(M$p)" msgstr "ncol(M$C) != length(M$p)" msgid "M$S and M$off have different lengths" msgstr "M$S and M$off have different lengths" msgid "M$sp has different length to M$S and M$off" msgstr "M$sp has different length to M$S and M$off" msgid "M$S[" msgstr "M$S[" msgid "] is too large given M$off[" msgstr "] is too large given M$off[" msgid "]" msgstr "]" msgid "Can't mix fixed and estimated penalties in mgcv() - use magic()" msgstr "Can't mix fixed and estimated penalties in mgcv() - use magic()" msgid "something wrong with argument d." msgstr "something wrong with argument d." msgid "one or more supplied k too small - reset to default" msgstr "one or more supplied k too small - reset to default" msgid "dimension of fx is wrong" msgstr "dimension of fx is wrong" msgid "bs wrong length and ignored." msgstr "bs wrong length and ignored." msgid "m wrong length and ignored." msgstr "m wrong length and ignored." msgid "Repeated variables as arguments of a smooth are not permitted" msgstr "Repeated variables as arguments of a smooth are not permitted" msgid "by=. not allowed" msgstr "by=. not allowed" msgid "s(.) not yet supported." msgstr "s(.) not yet supported." msgid "argument k of s() should be integer and has been rounded" msgstr "argument k of s() should be integer and has been rounded" msgid "meaninglessly low k; reset to 2" msgstr "meaninglessly low k; reset to 2" msgid "cr basis only works with 1-d smooths!" msgstr "cr basis only works with 1-d smooths!" msgid "Can't find by variable" msgstr "Can't find by variable" msgid "components of knots relating to a single smooth must be of same length" msgstr "components of knots relating to a single smooth must be of same length" msgid "more knots than data in a tp term: knots ignored." msgstr "more knots than data in a tp term: knots ignored." msgid "basis dimension, k, increased to minimum possible" msgstr "basis dimension, k, increased to minimum possible" msgid "number of supplied knots != k for a cr smooth" msgstr "number of supplied knots != k for a cr smooth" msgid "more knots than unique data values is not allowed" msgstr "more knots than unique data values is not allowed" msgid "too few knots" msgstr "too few knots" msgid "number of supplied knots != k for a cc smooth" msgstr "number of supplied knots != k for a cc smooth" msgid "can't predict outside range of knots with periodic smoother" msgstr "can't predict outside range of knots with periodic smoother" msgid "no data to predict at" msgstr "no data to predict at" msgid "smooth objects should not have a qrc attribute." msgstr "smooth objects should not have a qrc attribute." msgid "model has repeated 1-d smooths of same variable." msgstr "model has repeated 1-d smooths of same variable." msgid "supplied sp has wrong length" msgstr "supplied sp has wrong length" msgid "supplied min.sp has wrong length" msgstr "supplied min.sp has wrong length" msgid "Supplied smoothing parameter vector is too short - ignored." msgstr "Supplied smoothing parameter vector is too short - ignored." msgid "NA's in supplied smoothing parameter vector - ignoring." msgstr "NA's in supplied smoothing parameter vector - ignoring." msgid "length of min.sp is wrong." msgstr "length of min.sp is wrong." msgid "NA's in min.sp." msgstr "NA's in min.sp." msgid "elements of min.sp must be non negative." msgstr "elements of min.sp must be non negative." msgid "Unknown additive model fit method." msgstr "Unknown additive model fit method." msgid "Unknown *generalized* additive model fit method." msgstr "Unknown *generalized* additive model fit method." msgid "Unknown GAM outer optimizing method." msgstr "Unknown GAM outer optimizing method." msgid "pearson should be TRUE or FALSE - set to FALSE." msgstr "pearson should be TRUE or FALSE - set to FALSE." msgid "" "Negative binomial family not (yet) usable with type 2 iteration methods." msgstr "" "Negative binomial family not (yet) usable with type 2 iteration methods." msgid "" "Must use gam.control(absorb.cons=TRUE), for type 2 iteration\n" " methods." msgstr "" "Must use gam.control(absorb.cons=TRUE), for type 2 iteration\n" " methods." msgid "Model has more coefficients than data" msgstr "Model has more coefficients than data" msgid "IRLS regularizing parameter must be a non-negative number." msgstr "IRLS regularizing parameter must be a non-negative number." msgid "value of epsilon must be > 0" msgstr "value of epsilon must be > 0" msgid "maximum number of iterations must be > 0" msgstr "maximum number of iterations must be > 0" msgid "nb.theta.mult must be >= 2" msgstr "nb.theta.mult must be >= 2" msgid "" "silly value supplied for rank.tol: reset to square root of machine precision." msgstr "" "silly value supplied for rank.tol: reset to square root of machine precision." msgid "Model seems to contain no terms" msgstr "Model seems to contain no terms" msgid "y must be univariate unless binomial" msgstr "y must be univariate unless binomial" msgid "and correspond to initial coefs." msgstr "and correspond to initial coefs." msgid "" "iterative weights or data non-finite in gam.fit - regularization may help. " "See ?gam.control." msgstr "" "iterative weights or data non-finite in gam.fit - regularization may help. " "See ?gam.control." msgid "Step size truncated: out of bounds." msgstr "Step size truncated: out of bounds." msgid "Unknown type, reset to terms." msgstr "Unknown type, reset to terms." msgid "predict.gam can only be used to predict from gam objects" msgstr "predict.gam can only be used to predict from gam objects" msgid "newdata is a model.frame: it should contain all required variables" msgstr "newdata is a model.frame: it should contain all required variables" msgid "not all required variables have been supplied in newdata!" msgstr "not all required variables have been supplied in newdata!" msgid "non-existent terms requested - ignoring" msgstr "non-existent terms requested - ignoring" msgid "residuals argument to plot.gam is wrong length: ignored" msgstr "residuals argument to plot.gam is wrong length: ignored" msgid "No terms to plot - nothing for plot.gam() to do." msgstr "No terms to plot - nothing for plot.gam() to do." msgid "No variance estimates available" msgstr "No variance estimates available" msgid "no automatic plotting for smooths of more than two variables" msgstr "no automatic plotting for smooths of more than two variables" msgid "no automatic plotting for smooths of more than one variable" msgstr "no automatic plotting for smooths of more than one variable" msgid "The following arguments to anova.glm(..) are invalid and dropped:" msgstr "The following arguments to anova.glm(..) are invalid and dropped:" msgid "," msgstr "," msgid "dispersion argument ignored" msgstr "dispersion argument ignored" msgid "test argument ignored" msgstr "test argument ignored" msgid "anova.gam called with non gam object" msgstr "anova.gam called with non gam object" msgid "extra arguments discarded" msgstr "extra arguments discarded" msgid "grid vectors are different lengths" msgstr "grid vectors are different lengths" msgid "data vectors are of different lengths" msgstr "data vectors are of different lengths" msgid "supplied dist negative" msgstr "supplied dist negative" msgid "Model doesn't seem to have enough terms to do anything useful" msgstr "Model doesn't seem to have enough terms to do anything useful" msgid "view variables must be one of" msgstr "view variables must be one of" msgid "View variables must contain more than one value. view = c(" msgstr "View variables must contain more than one value. view = c(" msgid ")." msgstr ")." msgid "type must be \"link\" or \"response\"" msgstr "type must be “link” or “response”" msgid "Something wrong with zlim" msgstr "Something wrong with zlim" msgid "color scheme not recognised" msgstr "color scheme not recognised" msgid "sorry no option for contouring with errors: try plot.gam" msgstr "sorry no option for contouring with errors: try plot.gam" msgid "Supplied matrix not symmetric" msgstr "Supplied matrix not symmetric" msgid "singular values not returned in order" msgstr "singular values not returned in order" msgid "Something wrong - matrix probably not +ve semi definite" msgstr "Something wrong - matrix probably not +ve semi definite" msgid "method not recognised." msgstr "method not recognised." msgid "S[[" msgstr "S[[" msgid "]] matrix is not +ve definite." msgstr "]] matrix is not +ve definite." msgid "dimensions of supplied w wrong." msgstr "dimensions of supplied w wrong." msgid "w different length from y!" msgstr "w different length from y!" msgid "X lost dimensions in magic!!" msgstr "X lost dimensions in magic!!" mgcv/po/R-ko.po0000644000176200001440000012441313461561644013013 0ustar liggesusers# Korean translations for mgcv package. # Recommended/mgcv/po/R-ko.po # Maintainer: Simon Wood # # This file is distributed under the same license as the R mgcv package. # Chel Hee Lee , 2013-2015. # # Reviewing process is in progress (06-FEB-2015) # The original source code review is in progress (06-FEB-2015) # QC: PASS # Freezing on 06-FEB-2015 for R-3.1.3 # msgid "" msgstr "" "Project-Id-Version: R 3.1.3\n" "Report-Msgid-Bugs-To: bugs.r-project.org\n" "POT-Creation-Date: 2019-04-29 12:44\n" "PO-Revision-Date: 2015-02-21 16:01-0600\n" "Last-Translator:Chel Hee Lee \n" "Language-Team: Chel Hee Lee \n" "Language: ko\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=1; plural=0;\n" msgid "bam can not discretize with this nesting structure" msgstr "" msgid "'family' argument seems not to be a valid family object" msgstr "'family' 인자는 올바른 family 객체가 아닌 것 같이 보입니다." msgid "This family should not have a matrix response" msgstr "" msgid "cannot find valid starting values: please specify some" msgstr "사용가능한 초기값을 찾을 수 없습니다. 값을 지정해 주시길 바랍니다." msgid "Deviance = %s Iterations - %d" msgstr "편차(deviance)= %s 반복(iterations) - %d" msgid "Non-finite deviance" msgstr "편차(deviance)가 유한(finite)한 값을 가지지 않습니다." msgid "non-finite coefficients at iteration %d" msgstr "" "%d번째 반복에서 얻어진 계수(coefficients)가 유한(finite)한 값을 가지지 않습니" "다." msgid "algorithm did not converge" msgstr "알고리즘이 수렴하지 않습니다." msgid "fitted probabilities numerically 0 or 1 occurred" msgstr "적합된 확률값이 수치적으로 0 또는 1 입니다." msgid "fitted rates numerically 0 occurred" msgstr "적합된 비율(rates)가 수치적으로 0입니다." msgid "Too many cluster nodes to use all efficiently" msgstr "" msgid "iterms reset to terms" msgstr "" msgid "exclude ignored by discrete prediction at present" msgstr "" msgid "family not recognized" msgstr "family에 대한 정보를 찾을 수 없습니다." msgid "un-supported smoothness selection method" msgstr "지원되지 않는 평활화 선택법(smoothness selection method)입니다." msgid "discretization only available with fREML" msgstr "" msgid "discrete method does not use parallel cluster - use nthreads instead" msgstr "" msgid "openMP not available: single threaded computation only" msgstr "" msgid "min.sp not supported with fast REML computation, and ignored." msgstr "" "fREML(fast REML 연산)을 method로 선택한 경우 min.sp는 사용되지 않습니다." msgid "no smooths, ignoring `discrete=TRUE'" msgstr "" msgid "Not enough (non-NA) data to do anything meaningful" msgstr "" "어떤 의미있는 작업을 하기에는 NA가 아닌 데이터의 개수가 충분하지 않습니다." msgid "AR.start must be logical" msgstr "AR.start는 반드시 논리형(logical)이어야 합니다." msgid "chunk.size < number of coefficients. Reset to %d" msgstr "" msgid "unknown tensor constraint type" msgstr "" msgid "Model has more coefficients than data" msgstr "모형(model)이 가진 계수(coefficients)가 데이터의 개수보다 많습니다." msgid "" "length of sp must be number of free smoothing parameters in original model" msgstr "" #, fuzzy msgid "general families not supported by bam" msgstr "" "plot.gam에 전달되는 인자 residuals의 길이가 올바르지 않아 무시되었습니다. " msgid "AR1 parameter rho unused with generalized model" msgstr "" msgid "samfrac too small - ignored" msgstr "samfrac의 값이 너무 작기 때문에 이용되지 않습니다." msgid "Model can not be updated" msgstr "모델을 업데이트할 수 없습니다." msgid "link not available for coxph family; available link is \"identity\"" msgstr "" "coxph 페밀리(family)에 사용할 수 있는 링크(link)가 아닙니다. 사용가능한 링크" "(link)는 \"identity\"입니다." #, fuzzy msgid "something wrong with stratified prediction" msgstr "zlim이 올바르지 않습니다." msgid "NA times supplied for cox.ph prediction" msgstr "" #, fuzzy msgid "not an extended family" msgstr "본 페밀리(family)에 사용가능한 링크(link)가 없습니다." msgid "erroneous call to estimate.theta - no free parameters" msgstr "" msgid "step failure in theta estimation" msgstr "" msgid "" "link not available for ordered categorical family; available links are " "\"identity\"" msgstr "" "순서범주형 페밀리(ordered categorical family)에 사용할 수 있는 링크(link)가 " "아닙니다. 사용가능한 링크(link)는 \"identity\"입니다." msgid "Must supply theta or R to ocat" msgstr "theta 또는 R을 ocat에 제공해주어야 합니다." msgid "Response should be integer class labels" msgstr "" msgid "values out of range" msgstr "범위 외의 값을 가집니다." msgid "" "link not available for negative binomial family; available links are " "\"identity\", \"log\" and \"sqrt\"" msgstr "" "음이항분포 페밀리(negative binomial family)에 사용할 수 없는 링크(link)입니" "다. 사용가능한 링크(link)에는 \"identity\", \"log\" 그리고 \"sqrt\"가 있습니" "다." msgid "negative values not allowed for the negative binomial family" msgstr "" "음이항분포 페밀리(negative binomial family)에 음의 값은 사용할 수 없습니다." msgid "link \"%s\" not available for Tweedie family." msgstr "" "트위디 페밀리(tweedie family)에 링크(link) \"%s\"는 사용할 수 없습니다." msgid "Tweedie p must be in interval (a,b)" msgstr "트위디(tweedie) p는 반드시 구간 (a,b)내에 존재해야 합니다." msgid "" "link not available for beta regression; available links are \"logit\", " "\"probit\", \"cloglog\" and \"cauchit\"" msgstr "" "베타회귀(beta regression)에 사용할 수 있는 링크(link)가 아닙니다. 사용가능" "한 링크(link)에는 \"logit\", \"probit\", \"cloglog\" 그리고 \"cauchit\"가 있" "습니다. " msgid "saturated likelihood may be inaccurate" msgstr "" msgid "" "link not available for scaled t distribution; available links are \"identity" "\", \"log\", and \"inverse\"" msgstr "" "스케일드 t 분포(scaled t distribution)에 사용할 수 있는 링크(link)가 아닙니" "다. 사용가능한 링크(link)에는 \"identity\", \"log\", 그리고 \"inverse\"가 있" "습니다." msgid "Supplied df below min.df. min.df reset" msgstr "" msgid "NA values not allowed for the scaled t family" msgstr "스케일드 t 페밀리(scaled t family)에는 NA 값을 사용할 수 없습니다." msgid "" "link not available for zero inflated; available link for `lambda' is only " "\"loga\"" msgstr "" "영과잉(zero inflated)모형에 사용할 수 있는 링크(link)가 아닙니다. " "`lambda'에 사용할 수 있는 링크(link)는 오로지 \"loga\"입니다." msgid "negative values not allowed for the zero inflated Poisson family" msgstr "" "영과잉 포아송 페밀리(zero inflated Poisson family)에는 음의 값을 사용할 수 없" "습니다." msgid "Non-integer response variables are not allowed with ziP" msgstr "" msgid "Using ziP for binary data makes no sense" msgstr "" msgid "Possible divergence detected in fast.REML.fit" msgstr "" msgid "fast REML optimizer reached iteration limit" msgstr "" msgid "unsupported order of differentiation requested of gam.fit3" msgstr "" msgid "illegal `family' argument" msgstr "`family' 인자의 값이 올바르지 않습니다." msgid "Invalid linear predictor values in empty model" msgstr "" msgid "Invalid fitted means in empty model" msgstr "" msgid "Length of start should equal %d and correspond to initial coefs for %s" msgstr "" "start의 길이는 %d와 같아야 하며 %s에 대응하는 계수의 초기값을 가지고 있어야 " "합니다." msgid "Can't find valid starting values: please specify some" msgstr "사용가능한 초기값을 찾을 수 없습니다. 값을 정해주시길 바랍니다." msgid "NAs in V(mu)" msgstr "V(mu)에서 NA가 발견되었습니다." msgid "0s in V(mu)" msgstr "V(mu)에서 0이 발견되었습니다." msgid "NAs in d(mu)/d(eta)" msgstr "d(mu)/d(eta)로부터 NA가 발견되었습니다." msgid "No observations informative at iteration %d" msgstr "" msgid "Not enough informative observations." msgstr "" msgid "Non-finite coefficients at iteration %d" msgstr "%d번째 반복에서 얻은 계수의 추정치가 유한(finite)하지 않습니다." msgid "" "no valid set of coefficients has been found:please supply starting values" msgstr "" msgid "Step size truncated due to divergence" msgstr "" msgid "inner loop 1; can't correct step size" msgstr "" msgid "Step size truncated: out of bounds" msgstr "" msgid "inner loop 2; can't correct step size" msgstr "" msgid "penalized deviance = %s" msgstr "" msgid "inner loop 3; can't correct step size" msgstr "" msgid "Step halved: new penalized deviance = %g" msgstr "" msgid "" "Non finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam." "contol'" msgstr "" msgid "" "Non-finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam." "contol'" msgstr "" msgid "Algorithm did not converge" msgstr "알고리즘이 수렴하지 않았습니다." msgid "Algorithm stopped at boundary value" msgstr "알고리즘이 경계값(boundary value)에서 멈추었습니다." msgid "deriv should be 1 or 2" msgstr "deriv의 값은 1 또는 2이어야 합니다." msgid "L must be a matrix." msgstr "L은 반드시 행렬(matrix)이어야 합니다." msgid "L must have at least as many rows as columns." msgstr "L이 가지고 있는 행의 개수는 적어도 열의 개수만큼 있어야 합니다." msgid "L has inconsistent dimensions." msgstr "" msgid "Fitting terminated with step failure - check results carefully" msgstr "" msgid "Iteration limit reached without full convergence - check carefully" msgstr "" msgid "link not implemented for extended families" msgstr "본 페밀리(family)에 사용가능한 링크(link)가 없습니다." msgid "fam not a family object" msgstr "fam은 family라는 클래스를 가진 객체가 아닙니다." msgid "unrecognized (vector?) link" msgstr "알 수 없는 (벡터 또는) 링크입니다." msgid "link not recognised" msgstr "알 수 없는 링크(link)입니다." msgid "variance function not recognized for quasi" msgstr "" "family에 quasi가 주어진 경우에 사용되어야 하는 분산함수(variance function)을 " "찾을 수 없습니다." msgid "family not recognised" msgstr "family에 알 수 없는 값이 입력되었습니다." msgid "'theta' must be specified" msgstr "'theta'의 값은 반드시 주어져야 합니다." msgid "" "%s link not available for negative binomial family; available links are " "\"identity\", \"log\" and \"sqrt\"" msgstr "" "%s는 음이항분포 페밀리(negative binomial family)에 사용할 수 있는 링크(link)" "가 아닙니다. 사용가능한 링크들에는 \"identity\", \"log\" 그리고 \"sqrt\"가 " "있습니다." msgid "H has wrong dimension" msgstr "H의 열과 행의 길이가 같아야 합니다." msgid "only scalar `rho' and `theta' allowed." msgstr "`rho'와 `theta'는 오로지 스칼라(scalar) 값만을 가질 수 있습니다." msgid "1 0" msgstr "epsilon의 값은 반드시 0 보다 커야 합니다." msgid "maximum number of iterations must be > 0" msgstr "최대 반복수(iteration)는 반드시 0 보다 커야 합니다." msgid "" "silly value supplied for rank.tol: reset to square root of machine precision." msgstr "" "rank.tol에 주어진 값은 올바르지 않습니다: reset to square root of machine " "precision." msgid "Model seems to contain no terms" msgstr "모델이 아무런 항(term)도 포함하지 않는 것 같습니다." msgid "Discrete Theta search not available with performance iteration" msgstr "" msgid "y must be univariate unless binomial" msgstr "" msgid "Length of start should equal %d and correspond to initial coefs." msgstr "" msgid "" "iterative weights or data non-finite in gam.fit - regularization may help. " "See ?gam.control." msgstr "" msgid "Step size truncated: out of bounds." msgstr "" msgid "`object' is not of class \"gam\"" msgstr "`object'는 클래스 \"gam\"가 아닙니다." #, fuzzy msgid "unrecognised na.action" msgstr "알 수 없는 (벡터 또는) 링크입니다." msgid "na.action not character or function" msgstr "" msgid "Smoothness uncertainty corrected covariance not available" msgstr "" msgid "Unknown type, reset to terms." msgstr "" msgid "predict.gam can only be used to predict from gam objects" msgstr "" msgid "newdata is a model.frame: it should contain all required variables" msgstr "" "newdata는 model.frame이므로 필요한 모든 변수들을 포함하고 있어야 합니다." msgid "no NAs allowed in response data for this model" msgstr "" msgid "not all required variables have been supplied in newdata!" msgstr "필요한 모든 변수들을 newdata로부터 찾을 수 없습니다!" msgid "type iterms not available for multiple predictor cases" msgstr "" msgid "non-existent terms requested - ignoring" msgstr "" msgid "non-existent exclude terms requested - ignoring" msgstr "" msgid "requires an object of class gam" msgstr "클래스 gam으로부터 얻어진 객체가 필요합니다." msgid "nothing to do for this model" msgstr "" msgid "" "Pearson residuals not available for this family - returning deviance " "residuals" msgstr "" "이 페밀리(family)에서는 피어슨 잔차(Pearson residuals)를 얻을 수 없어 이탈잔" "차(deviance residuals)를 구합니다." msgid "lambda and h should have the same length!" msgstr "lambda와 h 모두 같은 길이를 가져야 합니다." msgid "recov works with fitted gam objects only" msgstr "recov 함수는 오로지 적합된 gam 객체만을 사용합니다." msgid "m can't be in re" msgstr "m은 re 내에 있을 수 없습니다." msgid "" "p-values for any terms that can be penalized to zero will be unreliable: " "refit model to fix this." msgstr "" msgid "The following arguments to anova.glm(..) are invalid and dropped:" msgstr "다음의 인자들은 anova.glm(..)에 유효하지 않으므로 사용되지 않습니다: " msgid "," msgstr "," msgid "un-supported test" msgstr "" msgid "test argument ignored" msgstr "" msgid "anova.gam called with non gam object" msgstr "" msgid "not a gam object" msgstr "객체의 클래스가 gam이 아닙니다." msgid "argument is not a gam object" msgstr "인자의 클래스가 gam이 아닙니다." msgid "S.scale vector doesn't match S list - please report to maintainer" msgstr "" msgid "Supplied matrix not symmetric" msgstr "입력된 행렬은 대칭(symmetric)이 아닙니다." msgid "singular values not returned in order" msgstr "" msgid "Something wrong - matrix probably not +ve semi definite" msgstr "" msgid "method not recognised." msgstr "알 수 없는 method입니다." msgid "S[[%d]] matrix is not +ve definite." msgstr "" msgid "dimensions of supplied w wrong." msgstr "입력된 w의 차원(dimensions)가 올바르지 않습니다." msgid "w different length from y!" msgstr "w의 길이가 y의 길이와 다릅니다!" msgid "X lost dimensions in magic!!" msgstr "" #, fuzzy msgid "mu dimensions wrong" msgstr "fx의 차원(dimension)이 올바르지 않습니다." #, fuzzy msgid "something wrong with inputs to LAPACK routine" msgstr "zlim이 올바르지 않습니다." msgid "not positive definite" msgstr "" msgid "don't be silly" msgstr "" msgid "sd should have exactly one less entry than ld" msgstr "" msgid "update not positive definite" msgstr "" msgid "internal error in vcorr, please report to simon.wood@r-project.org" msgstr "" msgid "a has wrong number of rows" msgstr "a가 가진 행의 개수가 올바르지 않습니다." msgid "mvn requires 2 or more dimensional data" msgstr "mvn은 둘 이상의 차원을 가진 데이터를 필요로 합니다." msgid "mvn does not yet handle offsets" msgstr "" msgid "mvn dimension error" msgstr "" msgid "non-integer binomial denominator: quantiles incorrect" msgstr "" msgid "object is not a glm or gam" msgstr "object의 클래스가 glm 또는 gam이 아닙니다." msgid "names of z and pc must match" msgstr "" "z의 구성요소에 주어진 이름들과 pc의 구성요소에 주어진 이름들은 반드시 서로 일" "치해야 합니다." msgid "" "Partial residuals do not have a natural x-axis location for linear " "functional terms" msgstr "" msgid "no automatic plotting for smooths of more than two variables" msgstr "" msgid "no automatic plotting for smooths of more than four variables" msgstr "" msgid "argument pers is deprecated, please use scheme instead" msgstr "" msgid "residuals argument to plot.gam is wrong length: ignored" msgstr "" "plot.gam에 전달되는 인자 residuals의 길이가 올바르지 않아 무시되었습니다. " msgid "No variance estimates available" msgstr "사용할 수 있는 분산의 추정치를 찾을 수 없습니다." msgid "No terms to plot - nothing for plot.gam() to do." msgstr "" msgid "grid vectors are different lengths" msgstr "그리드 벡터(grid vectors) g1과 g2의 길이가 서로 다릅니다." msgid "data vectors are of different lengths" msgstr "데이터 벡터(data vectors) d1과 d2의 길이가 서로 다릅니다." msgid "supplied dist negative" msgstr "입력된 dist에서 음수가 발견되었습니다." msgid "Model does not seem to have enough terms to do anything useful" msgstr "" msgid "view variables must be one of %s" msgstr "view 변수들은 반드시 %s 중에 하나 이어야 합니다." msgid "" "Don't know what to do with parametric terms that are not simple numeric or " "factor variables" msgstr "" msgid "View variables must contain more than one value. view = c(%s,%s)." msgstr "" msgid "type must be \"link\" or \"response\"" msgstr "type은 반드시 \"link\" 또는 \"response\"이어야 합니다." msgid "Something wrong with zlim" msgstr "zlim이 올바르지 않습니다." msgid "color scheme not recognised" msgstr "알 수 없는 색상표(color scheme)입니다." msgid "sorry no option for contouring with errors: try plot.gam" msgstr "" msgid "At least three knots required in call to mono.con." msgstr "mono.con을 호출하기 위해서는 최소한 세개의 노트(knots)가 필요합니다." msgid "lower bound >= upper bound in call to mono.con()" msgstr "" "mono.con()함수에 전달된 lower 인자의 값이 upper 인자의 값보다 크거나 같습니" "다." msgid "x is null" msgstr "x는 아무런 구성요소도 가지고 있지 않습니다." msgid "uniquecombs has not worked properly" msgstr "" msgid "order too low" msgstr "" msgid "too few knots" msgstr "노트(knots)의 개수 nk가 너무 작은 값을 가집니다." msgid "x out of range" msgstr "x가 범위 밖에 놓여 있습니다." msgid "something wrong with argument d." msgstr "" msgid "one or more supplied k too small - reset to default" msgstr "" msgid "dimension of fx is wrong" msgstr "fx의 차원(dimension)이 올바르지 않습니다." msgid "xt argument is faulty." msgstr "인자 xt가 올바르지 않습니다." msgid "bs wrong length and ignored." msgstr "bs의 길이가 올바르지 않아 사용되지 않습니다." msgid "m wrong length and ignored." msgstr "m의 길이가 올바르지 않아 사용되지 않습니다." msgid "Repeated variables as arguments of a smooth are not permitted" msgstr "" msgid "only first element of `id' used" msgstr "`id'의 첫번째 요소만이 사용되었습니다." msgid "supply a value for each variable for a point constraint" msgstr "" msgid "ord is wrong. reset to NULL." msgstr "ord가 올바르지 않아 NULL로 설정합니다." msgid "ord contains out of range orders (which will be ignored)" msgstr "" msgid "by=. not allowed" msgstr "by=.는 사용할 수 없습니다." #, fuzzy msgid "s(.) not supported." msgstr "s(.)는 아직 지원되지 않습니다." msgid "s(.) not yet supported." msgstr "s(.)는 아직 지원되지 않습니다." msgid "argument k of s() should be integer and has been rounded" msgstr "s()의 인자 k는 반드시 정수이어야 하므로 반올림되었습니다." msgid "attempt to use unsuitable marginal smooth class" msgstr "" msgid "" "Sorry, tensor products of smooths with multiple penalties are not supported." msgstr "" msgid "reparameterization unstable for margin: not done" msgstr "" msgid "basis not usable with reduced te" msgstr "" msgid "fx length wrong from t2 term: ignored" msgstr "" msgid "length of sp incorrect in t2: ignored" msgstr "" msgid "d can not be negative in call to null.space.dimension()." msgstr "null.space.dimension()에 지정된 인자 d는 음수를 가질 수 없습니다." msgid "arguments of smooth not same dimension" msgstr "" msgid "components of knots relating to a single smooth must be of same length" msgstr "" msgid "more knots than data in a tp term: knots ignored." msgstr "" msgid "basis dimension, k, increased to minimum possible" msgstr "" msgid "no data to predict at" msgstr "" msgid "Basis only handles 1D smooths" msgstr "" msgid "number of supplied knots != k for a cr smooth" msgstr "" msgid "F is missing from cr smooth - refit model with current mgcv" msgstr "" msgid "more knots than unique data values is not allowed" msgstr "" msgid "number of supplied knots != k for a cc smooth" msgstr "" msgid "basis dimension too small for b-spline order" msgstr "" msgid "knot range does not include data" msgstr "" msgid "there should be" msgstr "" msgid "supplied knots" msgstr "" msgid "knots supplied" msgstr "" msgid "" "knot range is so wide that there is *no* information about some basis " "coefficients" msgstr "" msgid "penalty order too high for basis dimension" msgstr "" msgid "there is *no* information about some basis coefficients" msgstr "" msgid "basis dimension is larger than number of unique covariates" msgstr "" msgid "multiple penalties of the same order is silly" msgstr "" msgid "requested non-existent derivative in B-spline penalty" msgstr "" msgid "fs smooths can only have one factor argument" msgstr "" msgid "\"fs\" smooth cannot use a multiply penalized basis (wrong basis in xt)" msgstr "" #, fuzzy msgid "no factor supplied to fs smooth" msgstr "gam.setup에 이용될 데이터가 없습니다." msgid "\"fs\" terms can not be fixed here" msgstr "" msgid "" "fs smooth not suitable for discretisation with more than one metric predictor" msgstr "" msgid "the adaptive smooth class is limited to 1 or 2 covariates." msgstr "" msgid "penalty basis too large for smoothing basis" msgstr "" msgid "penalty basis too small" msgstr "" msgid "random effects don't work with ids." msgstr "" msgid "" "Please put term with most levels last in 're' to avoid spoiling supplied " "penalties" msgstr "" #, fuzzy msgid "supplied S matrices are wrong diminsion" msgstr "H의 열과 행의 길이가 같아야 합니다." #, fuzzy msgid "argument of mrf should be a factor variable" msgstr "s()의 인자 k는 반드시 정수이어야 하므로 반올림되었습니다." msgid "MRF basis dimension set too high" msgstr "" msgid "data contain regions that are not contained in the knot specification" msgstr "" msgid "" "penalty matrix, boundary polygons and/or neighbours list must be supplied in " "xt" msgstr "" msgid "no spatial information provided!" msgstr "" msgid "mismatch between nb/polys supplied area names and data area names" msgstr "" msgid "Something wrong with auto- penalty construction" msgstr "" msgid "supplied penalty not square!" msgstr "" msgid "supplied penalty wrong dimension!" msgstr "" msgid "penalty column names don't match supplied area names!" msgstr "" msgid "Can only deal with a sphere" msgstr "" msgid "more knots than data in an sos term: knots ignored." msgstr "" msgid "more knots than data in a ds term: knots ignored." msgstr "" msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" msgid "s value reduced" msgstr "" msgid "s value increased" msgstr "" msgid "No suitable s (i.e. m[2]) try increasing m[1]" msgstr "" msgid "s value modified to give continuous function" msgstr "" msgid "basis dimension reset to minimum possible" msgstr "" msgid "incorrect arguments to GP smoother" msgstr "" msgid "more knots than data in an ms term: knots ignored." msgstr "" msgid "smooth objects should not have a qrc attribute." msgstr "" msgid "unimplemented sparse constraint type requested" msgstr "" msgid "" "handling `by' variables in smooth constructors may not work with the " "summation convention" msgstr "" msgid "Can't find by variable" msgstr "by 변수(variable)를 찾을 수 없습니다." msgid "" "sweep and drop constraints unlikely to work well with self handling of by " "vars" msgstr "" msgid "factor `by' variables can not be used with matrix arguments." msgstr "" msgid "`by' variable must be same dimension as smooth arguments" msgstr "" msgid "Number of prediction and fit constraints must match" msgstr "" msgid "x and y must be same length" msgstr "x의 길이와 y의 길이는 반드시 같아야 합니다." msgid "variable names don't match boundary names" msgstr "" msgid "x and y not same length" msgstr "x의 길이가 y의 길이와 같지 않습니다." msgid "bnd must be a list." msgstr "bnd는 반드시 리스트(list)이어야 합니다." msgid "lengths of k and bnd are not compatible." msgstr "k의 길이와 bnd의 길이가 서로 일치하지 않습니다." msgid "attempt to select non existent basis function" msgstr "" msgid "coefficient vector wrong length" msgstr "" msgid "knots must be specified for soap" msgstr "" msgid "soap films are bivariate only" msgstr "" msgid "need at least one interior knot" msgstr "최소한 하나 이상의 내부 노트(interior knot)가 필요합니다." msgid "can't soap smooth without a boundary" msgstr "" msgid "bnd must be a list of boundary loops" msgstr "" msgid "faulty bnd" msgstr "" msgid "k and bnd lengths are inconsistent" msgstr "k와 bnd의 길이가 서로 일치하지 않습니다." msgid "data outside soap boundary" msgstr "" msgid "no free coefs in sf smooth" msgstr "" msgid "only deals with 2D case" msgstr "2차원(2D)인 경우만을 다룰 수 있습니다." msgid "not enough unique values to find k nearest" msgstr "" msgid "cubic spline only deals with 1D data" msgstr "" "삼차 스플라인(cubic spline)은 오로지 1차원 데이터(1D data)만을 다룹니다." msgid "object not fully initialized" msgstr "완전히 초기화된 object가 아닙니다." #, fuzzy #~ msgid "scaled t df must be > min.df" #~ msgstr "스케일드 t 분포(scaled t)의 자유도(df)는 2보다 커야합니다." #, fuzzy #~ msgid "Extended Fellner Schall only implemented for general families" #~ msgstr "본 페밀리(family)에 사용가능한 링크(link)가 없습니다." #~ msgid "non-finite coefficients at iteration" #~ msgstr "" #~ "다음의 반복단계에서 얻어진 계수(coefficients)의 값이 유한(finite)하지 않습" #~ "니다." #~ msgid "sparse=TRUE not supported with fast REML, reset to REML." #~ msgstr "" #~ "sparse=TRUE인 경우 method는 fREML(fast REML)을 사용할 수 없으므로 REML을 " #~ "사용합니다." #~ msgid "Pearson scale estimate maybe unstable. See ?gam.scale." #~ msgstr "" #~ "피어슨 척도 (Pearson scale)에 대한 추정치가 안정적(stable)이지 않은 것 같" #~ "습니다. ?gam.scale을 확인해 보시길 바랍니다." #~ msgid "nlm.fd not available with negative binomial Theta estimation" #~ msgstr "nlm.fd 방법은 음이항분포의 Theta 추정에 사용할 수 없습니다." #~ msgid "" #~ "only outer methods `newton' & `bfgs' supports `negbin' family and theta " #~ "selection: reset" #~ msgstr "" #~ "오로지 `newton'와 `bfgs' 방법만이 `negbin' 페밀리와 theta 선택에 사용될 " #~ "수 있습니다: reset" #~ msgid "x has no row attribute" #~ msgstr "x는 행속성(row attribute)를 가지고 있지 않습니다." #~ msgid "x has no col attribute" #~ msgstr "x는 열속성(col attribute)를 가지고 있지 않습니다." mgcv/po/pl.po0000644000176200001440000001134313533720775012615 0ustar liggesusersmsgid "" msgstr "" "Project-Id-Version: mgcv 1.7-28\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2019-09-04 12:37+0100\n" "PO-Revision-Date: 2014-03-24 17:59+0100\n" "Last-Translator: Łukasz Daniel \n" "Language-Team: Łukasz Daniel \n" "Language: pl_PL\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=3; plural=(n==1 ? 0 : n%10>=2 && n%10<=4 && (n%100<10 " "|| n%100>=20) ? 1 : 2);\n" "X-Poedit-SourceCharset: iso-8859-1\n" "X-Generator: Poedit 1.5.4\n" # mgcv/src/magic.c: 440 # error(_("magic requires smoothing parameter starting values if L supplied")) #: magic.c:444 msgid "magic requires smoothing parameter starting values if L supplied" msgstr "" "'magic' wymaga wartości startowych dla parametru wygładzającego jeśli L " "zostało dostarczone" # mgcv/src/magic.c: 558 # error(_("magic, the gcv/ubre optimizer, failed to converge after 400 iterations.")) #: magic.c:562 msgid "magic, the gcv/ubre optimizer, failed to converge after 400 iterations." msgstr "" "'magic', omptymalizator gcv/ubre, nie zdodał uzbieżnić się po 400 iteracjach." # mgcv/src/matrix.c: 85 # (_("Failed to initialize memory for matrix."),1) #: matrix.c:82 msgid "Failed to initialize memory for matrix." msgstr "Nie udało się zainicjalizować pamięci dla macierzy." # mgcv/src/matrix.c: 147 # (_("An out of bound write to matrix has occurred!"),1) # mgcv/src/matrix.c: 210 # (_("An out of bound write to matrix has occurred!"),1) #: matrix.c:144 matrix.c:202 msgid "An out of bound write to matrix has occurred!" msgstr "Nastąpił zapis poza zakresem macierzy!" # mgcv/src/matrix.c: 153 # (_("INTEGRITY PROBLEM in the extant matrix list."),1) #: matrix.c:150 msgid "INTEGRITY PROBLEM in the extant matrix list." msgstr "PROBLEM SPÓJNOŚCI w istniejącej liście macierzy." # mgcv/src/matrix.c: 186 # (_("You are trying to check matrix integrity without defining RANGECHECK.")) #: matrix.c:182 msgid "You are trying to check matrix integrity without defining RANGECHECK." msgstr "Próbujesz sprawdzić integralność macierzy bez określania 'RANGECHECK'" # mgcv/src/matrix.c: 248 # (_("Target matrix too small in mcopy"),1) #: matrix.c:240 msgid "Target matrix too small in mcopy" msgstr "Docelowa macierz jest zbyt mała, aby wykonać 'mcopy'" # mgcv/src/matrix.c: 268 # (_("Incompatible matrices in matmult."),1) # mgcv/src/matrix.c: 276 # (_("Incompatible matrices in matmult."),1) # mgcv/src/matrix.c: 289 # (_("Incompatible matrices in matmult."),1) # mgcv/src/matrix.c: 297 # (_("Incompatible matrices in matmult."),1) #: matrix.c:260 matrix.c:268 matrix.c:281 matrix.c:289 msgid "Incompatible matrices in matmult." msgstr "Niespójne macierze w 'matmult'." # mgcv/src/matrix.c: 384 # (_("Attempt to invert() non-square matrix"),1) #: matrix.c:313 msgid "Attempt to invert() non-square matrix" msgstr "Próba odwrócenia metodą 'invert()' niekwadratowej macierzy" # mgcv/src/matrix.c: 406 # (_("Singular Matrix passed to invert()"),1) #: matrix.c:335 msgid "Singular Matrix passed to invert()" msgstr "Przekazano osobliwą macierz do 'invert()'" # mgcv/src/qp.c: 60 # (_("ERROR in addconQT."),1) #: qp.c:59 msgid "ERROR in addconQT." msgstr "BŁĄD w addconQT." # mgcv/src/qp.c: 466 # (_("QPCLS - Rank deficiency in model"),1) #: qp.c:465 msgid "QPCLS - Rank deficiency in model" msgstr "QPCLS - Niedobór rang w modelu" # mgcv/src/tprs.c: 46 # (_("You must have 2m>d for a thin plate spline."),1) # mgcv/src/tprs.c: 81 # (_("You must have 2m>d for a thin plate spline."),1) #: tprs.c:42 msgid "You must have 2m>d for a thin plate spline." msgstr "Musisz mieć 2m>d dla cienkiej płyty splajnu." # mgcv/src/tprs.c: 417 # (_("A term has fewer unique covariate combinations than specified maximum degrees of freedom"),1) # mgcv/src/tprs.c: 425 # (_("A term has fewer unique covariate combinations than specified maximum degrees of freedom"),1) # mgcv/R/smooth.r: 2518 # stop( # "A term has fewer unique covariate combinations than specified maximum degrees of freedom") #: tprs.c:377 tprs.c:385 msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" "Człon posiada mniej unikalnych kombinacji zmiennych niezależnych niż " "określona maksymalna liczba stopni swobody" # mgcv/src/matrix.c: 1327 # (_("svd() not converged"),1) #~ msgid "svd() not converged" #~ msgstr "'svd()' nie uzbieżnił się" # mgcv/src/matrix.c: 1403 # sprintf(err,_("svdroot matrix not +ve semi def. %g"),w.V[i]*w.V[i]) #~ msgid "svdroot matrix not +ve semi def. %g" #~ msgstr "macierz 'svdroot' nie jest dodatnio określona %g" # mgcv/src/matrix.c: 1431 # (_("Sort failed"),1) #~ msgid "Sort failed" #~ msgstr "Sortowanie nie powiodło się" mgcv/po/ko.po0000644000176200001440000000434613533720775012620 0ustar liggesusers# Korean translations for mgcv package. # Recommended/mgcv/po/ko.po # Maintainer: Simon Wood # # This file is distributed under the same license as the R mgcv package. # Chel Hee Lee , 2013-2015. # msgid "" msgstr "" "Project-Id-Version: mgcv 1.8-4\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2019-09-04 12:37+0100\n" "PO-Revision-Date: 2015-02-21 16:01-0600\n" "Last-Translator:Chel Hee Lee \n" "Language-Team: Chel Hee Lee \n" "Language: ko\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=1; plural=0;\n" #: magic.c:444 msgid "magic requires smoothing parameter starting values if L supplied" msgstr "" "L에 주어진 값이 없다면 스무딩 파라미터(smoothing parameter)에 대한 초기값" "(starting values)가 필요합니다." #: magic.c:562 msgid "magic, the gcv/ubre optimizer, failed to converge after 400 iterations." msgstr "" #: matrix.c:82 msgid "Failed to initialize memory for matrix." msgstr "행렬생성에 필요한 메모리 초기화에 실패했습니다." #: matrix.c:144 matrix.c:202 msgid "An out of bound write to matrix has occurred!" msgstr "" #: matrix.c:150 msgid "INTEGRITY PROBLEM in the extant matrix list." msgstr "" #: matrix.c:182 msgid "You are trying to check matrix integrity without defining RANGECHECK." msgstr "" #: matrix.c:240 msgid "Target matrix too small in mcopy" msgstr "" #: matrix.c:260 matrix.c:268 matrix.c:281 matrix.c:289 msgid "Incompatible matrices in matmult." msgstr "" #: matrix.c:313 msgid "Attempt to invert() non-square matrix" msgstr "" #: matrix.c:335 msgid "Singular Matrix passed to invert()" msgstr "특이함수(singular matrix)가 invert()에 전달되었습니다." #: qp.c:59 msgid "ERROR in addconQT." msgstr "addconQT 에서 에러가 발생했습니다." #: qp.c:465 msgid "QPCLS - Rank deficiency in model" msgstr "" #: tprs.c:42 msgid "You must have 2m>d for a thin plate spline." msgstr "" #: tprs.c:377 tprs.c:385 msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" #~ msgid "Sort failed" #~ msgstr "정렬에 실패했습니다." mgcv/po/R-pl.po0000644000176200001440000027152213461561644013021 0ustar liggesusersmsgid "" msgstr "" "Project-Id-Version: mgcv 1.7-28\n" "Report-Msgid-Bugs-To: bugs@r-project.org\n" "POT-Creation-Date: 2019-04-29 12:44\n" "PO-Revision-Date: 2014-03-25 17:39+0100\n" "Last-Translator: Łukasz Daniel \n" "Language-Team: Łukasz Daniel \n" "Language: pl_PL\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=3; plural=(n==1 ? 0 : n%10>=2 && n%10<=4 && (n%100<10 " "|| n%100>=20) ? 1 : 2);\n" "X-Poedit-SourceCharset: iso-8859-1\n" "X-Generator: Poedit 1.5.4\n" msgid "bam can not discretize with this nesting structure" msgstr "" # mgcv/R/bam.r: 161 # stop("'family' argument seems not to be a valid family object") # mgcv/R/bam.r: 480 # stop("'family' argument seems not to be a valid family object") msgid "'family' argument seems not to be a valid family object" msgstr "" "argument 'family' wydaje się nie być poprawnym obiektem klasy \"family\"" msgid "This family should not have a matrix response" msgstr "" # mgcv/R/bam.r: 184 # stop("cannot find valid starting values: please specify some") # mgcv/R/bam.r: 503 # stop("cannot find valid starting values: please specify some") msgid "cannot find valid starting values: please specify some" msgstr "" "Nie mnżna znaleźć poprawnych wartości startowych: proszę określić kilka" # mgcv/R/bam.r: 336 # gettextf("Deviance = %s Iterations - %d", dev, iter, domain = "R-mgcv") # mgcv/R/bam.r: 544 # gettextf("Deviance = %s Iterations - %d", dev, iter, domain = "R-mgcv") # mgcv/R/gam.fit3.r: 347 # gettextf("Deviance = %s Iterations - %d", dev, iter, domain = "R-mgcv") # mgcv/R/mgcv.r: 1951 # gettextf("Deviance = %s Iterations - %d", dev, iter, domain = "R-mgcv") msgid "Deviance = %s Iterations - %d" msgstr "Odchylenie = %s Iteracje - %d" # mgcv/R/bam.r: 338 # stop("Non-finite deviance") # mgcv/R/bam.r: 546 # stop("Non-finite deviance") msgid "Non-finite deviance" msgstr "Nieskończone odchylenie" # mgcv/R/bam.r: 425 # warning(gettextf("non-finite coefficients at iteration %d", iter)) # mgcv/R/bam.r: 600 # warning(gettextf("non-finite coefficients at iteration %d", iter)) #, fuzzy msgid "non-finite coefficients at iteration %d" msgstr "nieskończone współczynniki w iteracji" # mgcv/R/gam.fit3.r: 663 # warning("Algorithm did not converge") # mgcv/R/mgcv.r: 2004 # warning("Algorithm did not converge") msgid "algorithm did not converge" msgstr "Algorytm nie uzbieżnił się" # mgcv/R/bam.r: 446 # warning("fitted probabilities numerically 0 or 1 occurred") # mgcv/R/bam.r: 611 # warning("fitted probabilities numerically 0 or 1 occurred") # mgcv/R/gam.fit3.r: 669 # warning("fitted probabilities numerically 0 or 1 occurred") # mgcv/R/mgcv.r: 2011 # warning("fitted probabilities numerically 0 or 1 occurred") msgid "fitted probabilities numerically 0 or 1 occurred" msgstr "" "dopasowane prawdopodobieństwa okazały się być numerycznie równe 0 lub 1" # mgcv/R/bam.r: 450 # warning("fitted rates numerically 0 occurred") # mgcv/R/bam.r: 615 # warning("fitted rates numerically 0 occurred") # mgcv/R/gam.fit3.r: 673 # warning("fitted rates numerically 0 occurred") # mgcv/R/mgcv.r: 2015 # warning("fitted rates numerically 0 occurred") msgid "fitted rates numerically 0 occurred" msgstr "dopasowane wskaźniki numerycznie okazały się być równe 0" msgid "Too many cluster nodes to use all efficiently" msgstr "" # mgcv/R/mgcv.r: 2100 # warning("Unknown type, reset to terms.") #, fuzzy msgid "iterms reset to terms" msgstr "Nieznany typ, resetowanie do 'terms'" msgid "exclude ignored by discrete prediction at present" msgstr "" # mgcv/R/gamm.r: 1433 # stop("family not recognized") # mgcv/R/bam.r: 1075 # stop("family not recognized") # mgcv/R/mgcv.r: 1564 # stop("family not recognized") msgid "family not recognized" msgstr "'family' nie został rozpoznany" # mgcv/R/bam.r: 1079 # stop("unsupported smoothness selection method") msgid "un-supported smoothness selection method" msgstr "niewspierana metoda wyboru wygładzania" msgid "discretization only available with fREML" msgstr "" msgid "discrete method does not use parallel cluster - use nthreads instead" msgstr "" msgid "openMP not available: single threaded computation only" msgstr "" # mgcv/R/bam.r: 1082 # warning("min.sp not supported with fast REML computation, and ignored.") msgid "min.sp not supported with fast REML computation, and ignored." msgstr "" "'min.sp' nie jest wspierane dla szybkich obliczeń REML, parametr został " "zignorowany." msgid "no smooths, ignoring `discrete=TRUE'" msgstr "" # mgcv/R/gamm.r: 1414 # stop("Not enough (non-NA) data to do anything meaningful") # mgcv/R/bam.r: 1106 # stop("Not enough (non-NA) data to do anything meaningful") # mgcv/R/mgcv.r: 1540 # stop("Not enough (non-NA) data to do anything meaningful") msgid "Not enough (non-NA) data to do anything meaningful" msgstr "" "Brak wystarczającej (nie NA) liczby danych, aby wykonać cokolwiek sensownego" # mgcv/R/bam.r: 1109 # stop("'AR.start' argumentmust be logical") #, fuzzy msgid "AR.start must be logical" msgstr "argument 'AR.start' musi być wartością logiczną" msgid "chunk.size < number of coefficients. Reset to %d" msgstr "" # mgcv/R/smooth.r: 2842 # stop("unimplemented sparse constraint type requested") #, fuzzy msgid "unknown tensor constraint type" msgstr "zażądano niezaimplementowanego typu rzadkiego więzu" # mgcv/R/bam.r: 1153 # stop("Model has more coefficients than data") # mgcv/R/mgcv.r: 1579 # stop("Model has more coefficients than data") msgid "Model has more coefficients than data" msgstr "Model posiada więcej współczynników niż danych" # mgcv/R/mgcv.r: 822 # stop("incorrect number of smoothing parameters supplied for a smooth term") # mgcv/R/mgcv.r: 830 # stop("incorrect number of smoothing parameters supplied for a smooth term") #, fuzzy msgid "" "length of sp must be number of free smoothing parameters in original model" msgstr "" "niepoprawna liczba parametrów wygładzających dostarczona do członu 'smooth'" # mgcv/R/mgcv.r: 3063 # warning("'test' argument ignored") #, fuzzy msgid "general families not supported by bam" msgstr "argument 'test' został zignorowany" # mgcv/R/bam.r: 1187 # warning("AR1 parameter rho unused with generalized model") msgid "AR1 parameter rho unused with generalized model" msgstr "parametr rho AR1 jest nieużywany z uogólnionym modelem" # mgcv/R/bam.r: 1191 # warning("samfrac too small - ignored") msgid "samfrac too small - ignored" msgstr "'samfrac' jest zbyt małe - zignorowano" # mgcv/R/bam.r: 1286 # stop("Model can not be updated") msgid "Model can not be updated" msgstr "Model nie może zostać zaktualizowany" # mgcv/R/gam.fit3.r: 2093 # stop(gettextf("%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"", linktemp)) #, fuzzy msgid "link not available for coxph family; available link is \"identity\"" msgstr "" ": połączenie nie jest dostępne dla rodziny rozkładu Pascala; dostępne " "połączenia to \"identity\", \"log\" oraz \"sqrt\"" # mgcv/R/smooth.r: 265 # warning("something wrong with argument 'd'.") # mgcv/R/smooth.r: 373 # warning("something wrong with argument 'd'.") #, fuzzy msgid "something wrong with stratified prediction" msgstr "coś nie tak z argumentem 'd'" msgid "NA times supplied for cox.ph prediction" msgstr "" msgid "not an extended family" msgstr "" msgid "erroneous call to estimate.theta - no free parameters" msgstr "" msgid "step failure in theta estimation" msgstr "" # mgcv/R/gam.fit3.r: 2093 # stop(gettextf("%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"", linktemp)) #, fuzzy msgid "" "link not available for ordered categorical family; available links are " "\"identity\"" msgstr "" ": połączenie nie jest dostępne dla rodziny rozkładu Pascala; dostępne " "połączenia to \"identity\", \"log\" oraz \"sqrt\"" msgid "Must supply theta or R to ocat" msgstr "" msgid "Response should be integer class labels" msgstr "" # mgcv/R/smooth.r: 177 # stop("'x' out of range") #, fuzzy msgid "values out of range" msgstr "argument 'x' jest poza zakresem" # mgcv/R/gam.fit3.r: 2093 # stop(gettextf("%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"", linktemp)) msgid "" "link not available for negative binomial family; available links are " "\"identity\", \"log\" and \"sqrt\"" msgstr "" ": połączenie nie jest dostępne dla rodziny rozkładu Pascala; dostępne " "połączenia to \"identity\", \"log\" oraz \"sqrt\"" # mgcv/R/gam.fit3.r: 2126 # stop("negative values not allowed for the negative binomial family") msgid "negative values not allowed for the negative binomial family" msgstr "ujemne wartości nie są dozwolone dla rozkładu z rodziny Pascala" # mgcv/R/gam.fit3.r: 2300 # stop(gettextf("link \"%s\" is not available for Tweedie family.", linktemp), domain = "R-mgcv") #, fuzzy msgid "link \"%s\" not available for Tweedie family." msgstr "" "połączenie \"%s\" nie jest dostępne dla rozkładów z rodziny rozkładów " "poissona" # mgcv/R/gam.fit3.r: 2360 # stop("p must be in (1,2)") #, fuzzy msgid "Tweedie p must be in interval (a,b)" msgstr "argument 'p' musi być w przedziale (1,2)" # mgcv/R/gam.fit3.r: 2093 # stop(gettextf("%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"", linktemp)) #, fuzzy msgid "" "link not available for beta regression; available links are \"logit\", " "\"probit\", \"cloglog\" and \"cauchit\"" msgstr "" ": połączenie nie jest dostępne dla rodziny rozkładu Pascala; dostępne " "połączenia to \"identity\", \"log\" oraz \"sqrt\"" msgid "saturated likelihood may be inaccurate" msgstr "" # mgcv/R/gam.fit3.r: 2093 # stop(gettextf("%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"", linktemp)) #, fuzzy msgid "" "link not available for scaled t distribution; available links are \"identity" "\", \"log\", and \"inverse\"" msgstr "" ": połączenie nie jest dostępne dla rodziny rozkładu Pascala; dostępne " "połączenia to \"identity\", \"log\" oraz \"sqrt\"" msgid "Supplied df below min.df. min.df reset" msgstr "" # mgcv/R/gam.fit3.r: 2126 # stop("negative values not allowed for the negative binomial family") #, fuzzy msgid "NA values not allowed for the scaled t family" msgstr "ujemne wartości nie są dozwolone dla rozkładu z rodziny Pascala" # mgcv/R/gam.fit3.r: 2093 # stop(gettextf("%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"", linktemp)) #, fuzzy msgid "" "link not available for zero inflated; available link for `lambda' is only " "\"loga\"" msgstr "" ": połączenie nie jest dostępne dla rodziny rozkładu Pascala; dostępne " "połączenia to \"identity\", \"log\" oraz \"sqrt\"" # mgcv/R/gam.fit3.r: 2126 # stop("negative values not allowed for the negative binomial family") #, fuzzy msgid "negative values not allowed for the zero inflated Poisson family" msgstr "ujemne wartości nie są dozwolone dla rozkładu z rodziny Pascala" msgid "Non-integer response variables are not allowed with ziP" msgstr "" msgid "Using ziP for binary data makes no sense" msgstr "" msgid "Possible divergence detected in fast.REML.fit" msgstr "" # mgcv/R/fast-REML.r: 640 # warning("fast REML optimizer reached iteration limit") msgid "fast REML optimizer reached iteration limit" msgstr "szybki optymalizator REML osiągnął granicę iteracji" # mgcv/R/gam.fit3.r: 125 # stop("unsupported order of differentiation requested of 'gam.fit3()'") msgid "unsupported order of differentiation requested of gam.fit3" msgstr "niewspierany porządek różniczkowania zażądany od 'gam.fit3()'" # mgcv/R/gam.fit3.r: 202 # stop("invalid 'family' argument") msgid "illegal `family' argument" msgstr "niepoprawny argument 'family'" # mgcv/R/gam.fit3.r: 231 # stop("Invalid linear predictor values in empty model") msgid "Invalid linear predictor values in empty model" msgstr "Niepoprawne wartości liniowej zmiennej niezależnej w pustym modelu" # mgcv/R/gam.fit3.r: 234 # stop("Invalid fitted means in empty model") msgid "Invalid fitted means in empty model" msgstr "Niepoprawnie dopasowane średnie w pustym modelu" # mgcv/R/gam.fit3.r: 256 # stop(gettextf("Length of start should equal %d and correspond to initial coefs for %s", nvars, deparse(xnames))) #, fuzzy msgid "Length of start should equal %d and correspond to initial coefs for %s" msgstr "oraz odpowiadać początkowym współczynnikom dla" # mgcv/R/gam.fit3.r: 267 # stop("Can't find valid starting values: please specify some") # mgcv/R/mgcv.r: 1875 # stop("Can't find valid starting values: please specify some") msgid "Can't find valid starting values: please specify some" msgstr "" "Nie można znaleźć poprawnych wartości startowych: proszę określić kilka" # mgcv/R/gam.fit3.r: 286 # stop("0s in V(mu)") # mgcv/R/gam.fit3.r: 458 # stop("0s in V(mu)") # mgcv/R/mgcv.r: 1892 # stop("0s in V(mu)") msgid "NAs in V(mu)" msgstr "wartości NA w 'V(mu)'" # mgcv/R/gam.fit3.r: 286 # stop("0s in V(mu)") # mgcv/R/gam.fit3.r: 458 # stop("0s in V(mu)") # mgcv/R/mgcv.r: 1892 # stop("0s in V(mu)") msgid "0s in V(mu)" msgstr "zera w 'V(mu)'" # mgcv/R/gam.fit3.r: 289 # stop("NA values in d(mu)/d(eta)") # mgcv/R/gam.fit3.r: 461 # stop("NA values in d(mu)/d(eta)") # mgcv/R/mgcv.r: 1895 # stop("NA values in d(mu)/d(eta)") msgid "NAs in d(mu)/d(eta)" msgstr "wartości NA w 'd(mu)/d(eta)'" # mgcv/R/gam.fit3.r: 295 # warning(gettextf("No observations informative at iteration %d", iter)) # mgcv/R/mgcv.r: 1899 # warning(gettextf("No observations informative at iteration %d", iter)) #, fuzzy msgid "No observations informative at iteration %d" msgstr "Brak informacyjnych obserwacji w iteracji" # mgcv/R/gam.fit3.r: 314 # stop("Not enough informative observations.") msgid "Not enough informative observations." msgstr "Zbyt mało informacyjnych obserwacji" # mgcv/R/gam.fit3.r: 339 # warning(gettextf("Non-finite coefficients at iteration %d", iter)) # mgcv/R/mgcv.r: 1940 # warning(gettextf("Non-finite coefficients at iteration %d", iter)) #, fuzzy msgid "Non-finite coefficients at iteration %d" msgstr "Nieskończone współczynniki w iteracji" # mgcv/R/gam.fit3.r: 353 # stop("no valid set of coefficients has been found:please supply starting values", call. = FALSE) # mgcv/R/mgcv.r: 1955 # stop("no valid set of coefficients has been found:please supply starting values", call. = FALSE) msgid "" "no valid set of coefficients has been found:please supply starting values" msgstr "" "nie znaleziono poprawnego zestawu współczynników: proszę dostarczyć wartości " "startowe" # mgcv/R/gam.fit3.r: 358 # warning("Step size truncated due to divergence", call. = FALSE) # mgcv/R/mgcv.r: 1956 # warning("Step size truncated due to divergence", call. = FALSE) msgid "Step size truncated due to divergence" msgstr "Rozmiar kroku przycięty z uwagi na rozbieżność" # mgcv/R/gam.fit3.r: 362 # stop("inner loop 1; can't correct step size") # mgcv/R/mgcv.r: 1960 # stop("inner loop 1; can't correct step size") msgid "inner loop 1; can't correct step size" msgstr "wewnętrzna pętla 1; nie można poprawić rozmiaru kroku" # mgcv/R/gam.fit3.r: 374 # warning("Step size truncated: out of bounds", call. = FALSE) msgid "Step size truncated: out of bounds" msgstr "Rozmiar kroku przycięty: poza granicami" # mgcv/R/gam.fit3.r: 378 # stop("inner loop 2; can't correct step size") # mgcv/R/mgcv.r: 1977 # stop("inner loop 2; can't correct step size") msgid "inner loop 2; can't correct step size" msgstr "wewnętrzna pętla 2; nie można poprawić rozmiaru kroku" # mgcv/R/gam.fit3.r: 393 # gettextf("penalized deviance = %s", pdev, domain = "R-mgcv") msgid "penalized deviance = %s" msgstr "karne odchylenie = %s" # mgcv/R/gam.fit3.r: 362 # stop("inner loop 1; can't correct step size") # mgcv/R/mgcv.r: 1960 # stop("inner loop 1; can't correct step size") msgid "inner loop 3; can't correct step size" msgstr "wewnętrzna pętla 3; nie można poprawić rozmiaru kroku" # mgcv/R/gam.fit3.r: 415 # gettextf("Step halved: new penalized deviance = %s", pdev, domain = "R-mgcv") #, fuzzy msgid "Step halved: new penalized deviance = %g" msgstr "Krok został skrócony o połowę: nowe karne odchylenie = %s" # mgcv/R/gam.fit3.r: 569 # stop("Non-finite derivatives. Try decreasing fit tolerance! See 'epsilon' in 'gam.contol'") # mgcv/R/gam.fit3.r: 630 # stop("Non-finite derivatives. Try decreasing fit tolerance! See 'epsilon' in 'gam.contol'") # mgcv/R/gam.fit3.r: 645 # stop("Non-finite derivatives. Try decreasing fit tolerance! See 'epsilon' in 'gam.contol'") msgid "" "Non finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam." "contol'" msgstr "" "Nieskończone pochodne. Spróbuj zmniejszyć tolerancję dopasowania! Zobacz " "'epsilon' w 'gam.contol'" # mgcv/R/gam.fit3.r: 569 # stop("Non-finite derivatives. Try decreasing fit tolerance! See 'epsilon' in 'gam.contol'") # mgcv/R/gam.fit3.r: 630 # stop("Non-finite derivatives. Try decreasing fit tolerance! See 'epsilon' in 'gam.contol'") # mgcv/R/gam.fit3.r: 645 # stop("Non-finite derivatives. Try decreasing fit tolerance! See 'epsilon' in 'gam.contol'") msgid "" "Non-finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam." "contol'" msgstr "" "Nieskończone pochodne. Spróbuj zmniejszyć tolerancję dopasowania! Zobacz " "'epsilon' w 'gam.contol'" # mgcv/R/gam.fit3.r: 663 # warning("Algorithm did not converge") # mgcv/R/mgcv.r: 2004 # warning("Algorithm did not converge") msgid "Algorithm did not converge" msgstr "algorytm nie uzbieżnił się" # mgcv/R/gam.fit3.r: 665 # warning("Algorithm stopped at boundary value") # mgcv/R/mgcv.r: 2007 # warning("Algorithm stopped at boundary value") msgid "Algorithm stopped at boundary value" msgstr "Algorytm zatrzymał się na wartości granicznej" # mgcv/R/gam.fit3.r: 785 # stop("deriv should be 1 or 2") msgid "deriv should be 1 or 2" msgstr "'deriv' powinien wynosić 1 lub 2" # mgcv/R/gam.fit3.r: 956 # stop("'L' argument must be a matrix.") # mgcv/R/gam.fit3.r: 998 # stop("'L' argument must be a matrix.") # mgcv/R/gam.fit3.r: 1275 # stop("'L' argument must be a matrix.") # mgcv/R/gam.fit3.r: 1518 # stop("'L' argument must be a matrix.") # mgcv/R/mgcv.r: 3524 # stop("'L' argument must be a matrix.") msgid "L must be a matrix." msgstr "argument 'L' musi być macierzą" # mgcv/R/gam.fit3.r: 957 # stop("'L' argument must have at least as many rows as columns.") # mgcv/R/gam.fit3.r: 999 # stop("'L' argument must have at least as many rows as columns.") # mgcv/R/gam.fit3.r: 1276 # stop("'L' argument must have at least as many rows as columns.") # mgcv/R/gam.fit3.r: 1519 # stop("'L' argument must have at least as many rows as columns.") # mgcv/R/mgcv.r: 3525 # stop("'L' argument must have at least as many rows as columns.") msgid "L must have at least as many rows as columns." msgstr "argument 'L' musi mieć co najmniej tyle wierszy co kolumn" # mgcv/R/gam.fit3.r: 958 # stop("'L' argument has inconsistent dimensions.") # mgcv/R/gam.fit3.r: 1000 # stop("'L' argument has inconsistent dimensions.") # mgcv/R/gam.fit3.r: 1277 # stop("'L' argument has inconsistent dimensions.") # mgcv/R/gam.fit3.r: 1520 # stop("'L' argument has inconsistent dimensions.") # mgcv/R/mgcv.r: 3526 # stop("'L' argument has inconsistent dimensions.") msgid "L has inconsistent dimensions." msgstr "argument 'L' ma niespójne wymiary" msgid "Fitting terminated with step failure - check results carefully" msgstr "" msgid "Iteration limit reached without full convergence - check carefully" msgstr "" msgid "link not implemented for extended families" msgstr "" msgid "fam not a family object" msgstr "argument 'fam' nie jest obiektem klasy \"family\"" # mgcv/R/gam.fit3.r: 1831 # stop("unrecognized (vector?) link") msgid "unrecognized (vector?) link" msgstr "nierozpoznane (wektorowe?) połączenie" # mgcv/R/gam.fit3.r: 1923 # stop("link not recognised") msgid "link not recognised" msgstr "połączenie nie zostało rozpoznane" # mgcv/R/gam.fit3.r: 1963 # stop("variance function not recognized for quasi") msgid "variance function not recognized for quasi" msgstr "funkcja wariancji nie została rozpoznana dla kwazi" # mgcv/R/gam.fit3.r: 1986 # stop("family not recognised") # mgcv/R/gam.fit3.r: 2055 # stop("family not recognised") msgid "family not recognised" msgstr "rodzina nie została rozpoznana" # mgcv/man/negbin.Rd: 27 # stop("'theta' must be specified") # mgcv/R/gam.fit3.r: 2072 # stop("'theta' must be specified") msgid "'theta' must be specified" msgstr "argument 'theta' musi być określony" # mgcv/R/gam.fit3.r: 2093 # stop(gettextf("%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"", linktemp)) #, fuzzy msgid "" "%s link not available for negative binomial family; available links are " "\"identity\", \"log\" and \"sqrt\"" msgstr "" ": połączenie nie jest dostępne dla rodziny rozkładu Pascala; dostępne " "połączenia to \"identity\", \"log\" oraz \"sqrt\"" # mgcv/R/gam.fit3.r: 2156 # stop("'H' argument has wrong dimension") # mgcv/R/gam.fit3.r: 2178 # stop("'H' argument has wrong dimension") msgid "H has wrong dimension" msgstr "argument 'H' ma niepoprawny wymiar" # mgcv/R/gam.fit3.r: 2218 # stop("only scalar 'p' and 'phi' allowed.") msgid "only scalar `rho' and `theta' allowed." msgstr "tylko skalarne 'p' oraz 'phi' są dozwolone" msgid "1 0") #, fuzzy msgid "number of categories must be at least 2" msgstr "maksymalna liczba iteracji musi być > 0" # mgcv/R/mgcv.r: 822 # stop("incorrect number of smoothing parameters supplied for a smooth term") # mgcv/R/mgcv.r: 830 # stop("incorrect number of smoothing parameters supplied for a smooth term") #, fuzzy msgid "number of linear predictors doesn't match" msgstr "" "niepoprawna liczba parametrów wygładzających dostarczona do członu 'smooth'" msgid "response not in 0 to number of predictors + 1" msgstr "" msgid "ziplss requires 2 links specified as character strings" msgstr "" # mgcv/R/gam.fit3.r: 2300 # stop(gettextf("link \"%s\" is not available for Tweedie family.", linktemp), domain = "R-mgcv") #, fuzzy msgid "link not available for" msgstr "" "połączenie \"%s\" nie jest dostępne dla rozkładów z rodziny rozkładów " "poissona" msgid "parameter of ziplss" msgstr "" msgid "Non-integer response variables are not allowed with ziplss" msgstr "" msgid "Using ziplss for binary data makes no sense" msgstr "" msgid "gevlss requires 3 links specified as character strings" msgstr "" # mgcv/R/gam.fit3.r: 2300 # stop(gettextf("link \"%s\" is not available for Tweedie family.", linktemp), domain = "R-mgcv") #, fuzzy msgid "link not available for mu parameter of twlss" msgstr "" "połączenie \"%s\" nie jest dostępne dla rozkładów z rodziny rozkładów " "poissona" msgid "gammals requires 2 links specified as character strings" msgstr "" # mgcv/R/gam.fit3.r: 2300 # stop(gettextf("link \"%s\" is not available for Tweedie family.", linktemp), domain = "R-mgcv") #, fuzzy msgid "link not available for mu parameter of gammals" msgstr "" "połączenie \"%s\" nie jest dostępne dla rozkładów z rodziny rozkładów " "poissona" # mgcv/R/gamm.r: 115 # stop(gettextf("An object of length %d does not match the required parameter size", aux)) # mgcv/R/gamm.r: 243 # stop(gettextf("An object of length %d does not match the required parameter size", length(val))) #, fuzzy msgid "An object of length %d does not match the required parameter size" msgstr "nie zgadza się z wymaganym rozmiarem parametru" msgid "NA's in pdTens factor" msgstr "wartości NA w czynniku klasy \"pdTens\"" # mgcv/R/gamm.r: 145 # stop("Cannot extract the matrix from an uninitialized object") msgid "Cannot extract the matrix from an uninitialized object" msgstr "Nie można wyodrębnić macierzy z niezainicjalizowanego obiektu" msgid "NA's in pdTens matrix" msgstr "wartości NA w macierzy klasy \"pdTens\"" # mgcv/R/gamm.r: 206 # stop("Cannot extract the matrix from an uninitialized pdMat object") # mgcv/R/gamm.r: 265 # stop("Cannot extract the matrix from an uninitialized pdMat object") msgid "Cannot extract the matrix from an uninitialized pdMat object" msgstr "" "Nie można wyodrębnić macierzy z niezainicjalizowanego obiektu klasy \"pdMAt\"" # mgcv/R/gamm.r: 209 # stop(paste("Cannot extract the matrix with uninitialized dimensions")) # mgcv/R/gamm.r: 268 # stop("Cannot extract the matrix with uninitialized dimensions") msgid "Cannot extract the matrix with uninitialized dimensions" msgstr "Nie można wyodrębnić macierzy z niezainicjalizowanymi wymiarami" msgid "An object of length" msgstr "Obiekt o długości" # mgcv/R/gamm.r: 115 # stop(gettextf("An object of length %d does not match the required parameter size", aux)) # mgcv/R/gamm.r: 243 # stop(gettextf("An object of length %d does not match the required parameter size", length(val))) msgid "does not match the required parameter size" msgstr "nie zgadza się z wymaganym rozmiarem parametru" # mgcv/R/gamm.r: 246 # stop("Must give names when initializing pdIdnot from parameter without a formula") msgid "Must give names when initializing pdIdnot from parameter." msgstr "" "Nazwy są wymagane podczas inicjalizowania obiektu klasy \"pdIdnot\" z " "parametru" msgid "without a formula" msgstr "bez formuły" # mgcv/R/gamm.r: 302 # stop("Cannot extract the dimensions") msgid "Cannot extract the dimensions" msgstr "Nie można wyodrębnić wymiarów" # mgcv/R/gamm.r: 317 # stop("Cannot extract the inverse from an uninitialized object") msgid "Cannot extract the inverse from an uninitialized object" msgstr "Nie można wyodrębnić odwrotności z niezainicjalizowanego obiektu" # mgcv/R/gamm.r: 663 # stop("Can not convert this smooth class to a random effect") msgid "Can not convert this smooth class to a random effect" msgstr "Nie można przekonwertować tej gładkiej klasy na efekt losowy" # mgcv/R/gamm.r: 724 # stop("te smooths not useable with gamm4: use t2 instead") msgid "te smooths not useable with gamm4: use t2 instead" msgstr "wygładzania 'te' nie są stosowalne z 'gamm4': zamiast tego użyj t2" # mgcv/R/gamm.r: 397 # warning("gamm can not fix only some margins of tensor product.") # mgcv/R/gamm.r: 727 # warning("gamm can not fix only some margins of tensor product.") msgid "gamm can not fix only some margins of tensor product." msgstr "" "funkcja 'gamm()' nie może ustalić tylko niektórych granic produktu " "tensorowego." # mgcv/R/gamm.r: 437 # stop("Tensor product penalty rank appears to be too low: please email Simon.Wood@R-project.org with details.") # mgcv/R/gamm.r: 748 # stop("Tensor product penalty rank appears to be too low: please email Simon.Wood@R-project.org with details.") msgid "" "Tensor product penalty rank appears to be too low: please email Simon.Wood@R-" "project.org with details." msgstr "" "Produkt tensorowy rang kar wydaje się być zbyt niski: proszę przesłać email " "na adresSimon.Wood@R-project.org ze szczegółami." # mgcv/R/mgcv.r: 561 # stop("No data supplied to gam.setup") msgid "No data supplied to gamm.setup" msgstr "Nie dostarczono danych do funkcji 'gam.setup()'" # mgcv/R/gamm.r: 361 # stop("gamm can not handle linked smoothing parameters (probably from use of 'id' or adaptive smooths)") # mgcv/R/gamm.r: 804 # stop("gamm can not handle linked smoothing parameters (probably from use of 'id' or adaptive smooths)") msgid "" "gamm can not handle linked smoothing parameters (probably from use of `id' " "or adaptive smooths)" msgstr "" "funkcja 'gamm()' nie może obsłużyć dołączonych parametrów wygładzania " "(prawdopodobnie z użycia 'id' lub adaptacyjnych wygładzeń)" # mgcv/R/gamm.r: 832 # stop("only one level of smooth nesting is supported by gamm") msgid "only one level of smooth nesting is supported by gamm" msgstr "" "tylko jeden poziom zagnieżdżania gładkości jest wspierane przez funkcję " "'gamm()'" # mgcv/R/gamm.r: 833 # stop("side conditions are not allowed for nested smooths") #, fuzzy msgid "side conditions not allowed for nested smooths" msgstr "warunki boczne nie są dozwolone dla zagnieżdżonych wygładzeń" # mgcv/R/plots.r: 90 # stop("'object' argument is not an object of class \"glm\" or \"gam\"") msgid "object does not appear to be of class lme" msgstr "argument nie jest obiektem klasy \"lme\"" # mgcv/R/gamm.r: 1049 # stop("inner groupings not nested in outer!!") msgid "inner groupings not nested in outer!!" msgstr "wewnętrzne grupowanie nie jest zagnieżdżone w zewnętrznym grupowaniu!!" # mgcv/R/gamm.r: 1327 # message(gettextf("iteration %d", i)) #, fuzzy msgid "iteration %d" msgstr "iteracja" # mgcv/R/gamm.r: 1343 # warning("gamm not converged, try increasing niterPQL") msgid "gamm not converged, try increasing niterPQL" msgstr "" "funkcja 'gamm()' nie uzbieżniła się, spróbuj zwiększyć parametr 'niterPQL'" msgid "family are not designed for use with gamm!" msgstr "" msgid "gamm is not designed to use extended families" msgstr "" # mgcv/R/gamm.r: 1366 # stop("random argument must be a *named* list.") msgid "random argument must be a *named* list." msgstr "argument 'random' musi być *nazwaną* listą." # mgcv/R/gamm.r: 1367 # stop("all elements of random list must be named") msgid "all elements of random list must be named" msgstr "wszystkie elementy listy 'random' muszą być nazwane" # mgcv/R/gamm.r: 1369 # stop("'gamm()' can only handle random effects defined as named lists") msgid "gamm() can only handle random effects defined as named lists" msgstr "" "funkcja 'gamm()' może obsłużyć jedynie efekty losowe zdefiniowane jaki " "nazwane listy" # mgcv/R/gamm.r: 1444 # stop("gamm models must have at least 1 smooth with unknown smoothing parameter or at least one other random effect") msgid "" "gamm models must have at least 1 smooth with unknown smoothing parameter or " "at least one other random effect" msgstr "" "modele 'gamm' muszą mieć co najmniej 1 wygładzenie z nieznanym parametrem " "wygładzania lub co najmniej jeden inny efekt losowy" # mgcv/R/gamm.r: 1505 # stop("weights must be like glm weights for generalized case") msgid "weights must be like glm weights for generalized case" msgstr "wagi muszą być jak wagi w 'glm' dla ogólnego przypadku" # mgcv/R/gamm.r: 1553 # stop("Nested smooths must be fully random") msgid "Nested smooths must be fully random" msgstr "Zagnieżdżone wygładzania muszą być w pełni losowe" # mgcv/R/gam.fit3.r: 2219 # stop("p must be in [1,2]") #, fuzzy msgid "size must be in [1,120]" msgstr "argument 'p' musi być w przedziale [1,2]" msgid "rank deficient re-parameterization" msgstr "" msgid "modal weight <=0 in integration step!!" msgstr "" msgid "Requires a gam or bam prefit object" msgstr "" msgid "bam fits only supported with discrete==TRUE" msgstr "" msgid "integration not available with this family - insufficient derivatives" msgstr "" # mgcv/R/smooth.r: 265 # warning("something wrong with argument 'd'.") # mgcv/R/smooth.r: 373 # warning("something wrong with argument 'd'.") #, fuzzy msgid "something wrong with A index vector" msgstr "coś nie tak z argumentem 'd'" msgid "sorry link not yet handled" msgstr "" # mgcv/R/mgcv.r: 3063 # warning("'test' argument ignored") #, fuzzy msgid "weights ignored" msgstr "argument 'test' został zignorowany" # mgcv/R/gamm.r: 1433 # stop("family not recognized") # mgcv/R/bam.r: 1075 # stop("family not recognized") # mgcv/R/mgcv.r: 1564 # stop("family not recognized") #, fuzzy msgid "family not implemented yet" msgstr "'family' nie został rozpoznany" msgid "jagam requires a file for the JAGS model specification" msgstr "" msgid "smoothing parameter prior choise not recognised, reset to gamma" msgstr "" msgid "coefficient simulation data is missing" msgstr "" msgid "burnin too large, reset" msgstr "" msgid "rho missing from simulation data edf.type reset to 2" msgstr "" # mgcv/R/mgcv.r: 3063 # warning("'test' argument ignored") #, fuzzy msgid "residuals argument not supported" msgstr "argument 'test' został zignorowany" msgid "unconditional argument not meaningful here" msgstr "" # mgcv/R/mgcv.r: 3063 # warning("'test' argument ignored") #, fuzzy msgid "by.resids argument not supported" msgstr "argument 'test' został zignorowany" # mgcv/R/mgcv.r: 3063 # warning("'test' argument ignored") #, fuzzy msgid "all.terms argument not supported" msgstr "argument 'test' został zignorowany" # mgcv/R/mgcv.r: 30 # stop("silly tolerance supplied") msgid "silly tolerance supplied" msgstr "dostarczono mało wiarygodną tolerancję" # mgcv/R/mgcv.r: 32 # stop("argument 'k' must be positive.") msgid "argument k must be positive." msgstr "argument 'k' musi być dodatni" # mgcv/R/mgcv.r: 36 # stop("matrix 'A' is not square") msgid "A not square" msgstr "macierz 'A' nie jest kwadratowa" # mgcv/R/mgcv.r: 37 # stop("Can not have more eigenvalues than nrow(A)") msgid "Can not have more eigenvalues than nrow(A)" msgstr "Nie można mieć więcej wartości własnych niż 'nrow(A)'" msgid "nrow(M$X) != length(M$y)" msgstr "nrow(M$X) != length(M$y)" msgid "ncol(M$X) != length(M$p)" msgstr "ncol(M$X) != length(M$p)" msgid "length(M$w) != length(M$y)" msgstr "length(M$w) != length(M$y)" msgid "nrow(M$Ain) != length(M$bin)" msgstr "nrow(M$Ain) != length(M$bin)" msgid "nrow(M$Ain) != length(M$p)" msgstr "nrow(M$Ain) != length(M$p)" # mgcv/R/mgcv.r: 102 # warning("initial parameters very close to inequality constraints") #, fuzzy msgid "initial parameters not feasible" msgstr "początkowe parametry bardzo blisko więzów nierowności" # mgcv/R/mgcv.r: 102 # warning("initial parameters very close to inequality constraints") #, fuzzy msgid "initial point very close to some inequality constraints" msgstr "początkowe parametry bardzo blisko więzów nierowności" # mgcv/R/mgcv.r: 102 # warning("initial parameters very close to inequality constraints") msgid "initial parameters very close to inequality constraints" msgstr "początkowe parametry bardzo blisko więzów nierowności" msgid "ncol(M$C) != length(M$p)" msgstr "ncol(M$C) != length(M$p)" # mgcv/R/mgcv.r: 106 # stop("'M$S' and 'M$off' have different lengths") msgid "M$S and M$off have different lengths" msgstr "'M$S' oraz 'M$off' mają różne długości" # mgcv/R/mgcv.r: 107 # stop("'M$sp' has different length to 'M$S' and 'M$off'") msgid "M$sp has different length to M$S and M$off" msgstr "'M$sp' ma inną długość niż 'M$S' oraz 'M$off'" # mgcv/R/mgcv.r: 116 # stop(gettextf("M$S[%d] is too large given M$off[%d]", i, i)) #, fuzzy msgid "M$S[%d] is too large given M$off[%d]" msgstr "] jest zbyt duże dla podanego M$off[" # mgcv/R/mgcv.r: 120 # stop("Penalized model matrix must have no more columns than rows") msgid "Penalized model matrix must have no more columns than rows" msgstr "Macierz modelu kary nie może mieć więcej kolumn niż wierszy" # mgcv/R/mgcv.r: 131 # stop("Model matrix not full column rank") msgid "Model matrix not full column rank" msgstr "Macierz modelu nie ma pełnej rangi kolumny" msgid "can't handle [[ in formula" msgstr "" # mgcv/R/gam.fit3.r: 231 # stop("Invalid linear predictor values in empty model") #, fuzzy msgid "single linear predictor indices are ignored" msgstr "Niepoprawne wartości liniowej zmiennej niezależnej w pustym modelu" # mgcv/R/smooth.r: 177 # stop("'x' out of range") #, fuzzy msgid "linear predictor labels out of range" msgstr "argument 'x' jest poza zakresem" # mgcv/R/mgcv.r: 356 # warning("model has repeated 1-d smooths of same variable.") msgid "model has repeated 1-d smooths of same variable." msgstr "model powtórzył jednowymiarowe wygładzania tej samiej zmiennej" # mgcv/R/mgcv.r: 458 # stop("'id' linked smooths must have same number of arguments") msgid "`id' linked smooths must have same number of arguments" msgstr "" "wygładzania połączone poprzez 'id' muszą mieć tę samą liczbę argumentów" # mgcv/R/mgcv.r: 515 # stop("'rank' has wrong length in 'paraPen'") msgid "`rank' has wrong length in `paraPen'" msgstr "'rank' posiada niepoprawną długość w 'paraPen'" # mgcv/R/mgcv.r: 520 # stop("a parametric penalty has wrong dimension") msgid "a parametric penalty has wrong dimension" msgstr "parametryczna kara ma niepoprawny wymiar" # mgcv/R/mgcv.r: 529 # stop("'L' has wrong dimension in 'paraPen'") msgid "L has wrong dimension in `paraPen'" msgstr "'L' posiada niepoprawny wymiar w 'paraPen'" # mgcv/R/mgcv.r: 537 # stop("'sp' dimension wrong in 'paraPen'") msgid "`sp' dimension wrong in `paraPen'" msgstr "wymiar 'sp' jest niepoprawny w 'paraPen'" # mgcv/R/mgcv.r: 551 # stop("'sp' is too short") msgid "`sp' too short" msgstr "'sp' jest zbyt krótkie" # mgcv/R/mgcv.r: 561 # stop("No data supplied to gam.setup") msgid "No data supplied to gam.setup" msgstr "Nie dostarczono danych do gam.setup" # mgcv/R/mgcv.r: 570 # stop("First argument is no sort of formula!") #, fuzzy msgid "paraPen not supported for multi-formula models" msgstr "Pierwszy argument nie jest typu formuły!" # mgcv/R/mgcv.r: 570 # stop("First argument is no sort of formula!") #, fuzzy msgid "absorb.cons must be TRUE for multi-formula models" msgstr "Pierwszy argument nie jest typu formuły!" msgid "length(drop.intercept) should be equal to number of model formulas" msgstr "" msgid "shared offsets not allowed" msgstr "" msgid "dropping unidentifiable parametric terms from model" msgstr "" # mgcv/R/mgcv.r: 570 # stop("First argument is no sort of formula!") msgid "First argument is no sort of formula!" msgstr "Pierwszy argument nie jest typu formuły!" # mgcv/R/mgcv.r: 572 # stop("You've got no model....") msgid "You've got no model...." msgstr "Nie posiadasz modelu..." # mgcv/R/mgcv.r: 714 # stop("Later terms sharing an 'id' can not have more smoothing parameters than the first such term") msgid "" "Later terms sharing an `id' can not have more smoothing parameters than the " "first such term" msgstr "" "Dalsze człony współdzielące 'id' nie mogą mieć więcej parametrów " "wygładzających niż pierwszy taki człon" # mgcv/R/mgcv.r: 802 # warning("Supplied smoothing parameter vector is too short - ignored.") msgid "Supplied smoothing parameter vector is too short - ignored." msgstr "" "Dostarczony wektor parametrów wygładzania jest zbyt krótki - zignorowano" # mgcv/R/mgcv.r: 803 # warning("NA's in supplied smoothing parameter vector - ignoring.") msgid "NA's in supplied smoothing parameter vector - ignoring." msgstr "" "Dostarczono wartości NA w wektorze parametrów wygładzających - ignorowanie" # mgcv/R/mgcv.r: 822 # stop("incorrect number of smoothing parameters supplied for a smooth term") # mgcv/R/mgcv.r: 830 # stop("incorrect number of smoothing parameters supplied for a smooth term") msgid "incorrect number of smoothing parameters supplied for a smooth term" msgstr "" "niepoprawna liczba parametrów wygładzających dostarczona do członu 'smooth'" # mgcv/R/mgcv.r: 863 # stop("length of min.sp is wrong.") msgid "length of min.sp is wrong." msgstr "długość 'min.sp' jest niepoprawna" # mgcv/R/mgcv.r: 864 # stop("NA's in min.sp.") msgid "NA's in min.sp." msgstr "wartości NA w 'min.sp'" # mgcv/R/mgcv.r: 865 # stop("elements of min.sp must be non negative.") msgid "elements of min.sp must be non negative." msgstr "elementy 'min.sp' muszą być nieujemne" # mgcv/R/mgcv.r: 1143 # stop("unknown outer optimization method.") msgid "unknown outer optimization method." msgstr "nieznana zewnętrzna metoda optymalizacji" msgid "Please provide a single value for theta or use nb to estimate it" msgstr "" # mgcv/R/mgcv.r: 1153 # stop("nlm.fd only available for GCV/UBRE") msgid "nlm.fd only available for GCV/UBRE" msgstr "'nlm.fd' jest dostępne jedynie dla GCV/UBRE" # mgcv/R/mgcv.r: 1275 # stop("unknown optimizer") msgid "unknown optimizer" msgstr "nieznany optymalizator" # mgcv/R/mgcv.r: 1276 # stop("unknown smoothness selection criterion") msgid "unknown smoothness selection criterion" msgstr "nieznane kryterium wyboru wygładzania" # mgcv/R/mgcv.r: 1282 # warning("Reset optimizer to outer/newton") msgid "Reset optimizer to outer/newton" msgstr "Resetowanie optymalizatora na zewnętrzny/newtona" # mgcv/R/mgcv.r: 1355 # stop("in.out incorrect: see documentation") msgid "in.out incorrect: see documentation" msgstr "'in.out' jest niepoprawne: zobacz dokumentację" # mgcv/R/mgcv.r: 822 # stop("incorrect number of smoothing parameters supplied for a smooth term") # mgcv/R/mgcv.r: 830 # stop("incorrect number of smoothing parameters supplied for a smooth term") #, fuzzy msgid "incorrect number of linear predictors for family" msgstr "" "niepoprawna liczba parametrów wygładzających dostarczona do członu 'smooth'" msgid "edge.correct must be logical or a positive number" msgstr "" # mgcv/R/mgcv.r: 32 # stop("argument 'k' must be positive.") #, fuzzy msgid "nthreads must be a positive integer" msgstr "argument 'k' musi być dodatni" # mgcv/R/mgcv.r: 1676 # stop("IRLS regularizing parameter must be a non-negative number.") msgid "IRLS regularizing parameter must be a non-negative number." msgstr "parametr regularyzacyjny IRLS musi być nieujemną liczbą" # mgcv/R/mgcv.r: 1678 # stop("value of epsilon must be > 0") msgid "value of epsilon must be > 0" msgstr "wartość 'epsilon' musi być > 0" # mgcv/R/mgcv.r: 1680 # stop("maximum number of iterations must be > 0") msgid "maximum number of iterations must be > 0" msgstr "maksymalna liczba iteracji musi być > 0" # mgcv/R/mgcv.r: 1683 # warning("silly value supplied for rank.tol: reset to square root of machine precision.") msgid "" "silly value supplied for rank.tol: reset to square root of machine precision." msgstr "" "śmieszna wartość została dostarczona do 'rank.tol': ustawianie pierwiastka " "kwadratowego z precyzji maszyny" # mgcv/R/mgcv.r: 1805 # stop("Model seems to contain no terms") msgid "Model seems to contain no terms" msgstr "Model wydaje się nie zawierać żadnych członów" # mgcv/R/mgcv.r: 1815 # warning("Discrete Theta search not available with performance iteration") msgid "Discrete Theta search not available with performance iteration" msgstr "Poszukiwania dyskretnej thety nie są dostępne z wykonywaną iteracją" # mgcv/R/mgcv.r: 1857 # stop("'y' must be univariate unless binomial") msgid "y must be univariate unless binomial" msgstr "'y' musi zawierać jedną zmienną jeśli nie zawiera dwóch" # mgcv/R/mgcv.r: 1865 # stop(gettextf("Length of start should equal %d and correspond to initial coefs.", nvars)) #, fuzzy msgid "Length of start should equal %d and correspond to initial coefs." msgstr "oraz odpowiadać początkowym współczynnikom" # mgcv/R/mgcv.r: 1918 # stop("iterative weights or data non-finite in gam.fit - regularization may help. See ?gam.control.") msgid "" "iterative weights or data non-finite in gam.fit - regularization may help. " "See ?gam.control." msgstr "" "iteracyjne wagi lub nieskończone dane w 'gam.fit' - regularyzacja może " "pomóc. Zobacz '?gam.control'" # mgcv/R/gam.fit3.r: 374 # warning("Step size truncated: out of bounds", call. = FALSE) msgid "Step size truncated: out of bounds." msgstr "Rozmiar kroku przycięty: poza granicami" # mgcv/R/plots.r: 90 # stop("'object' argument is not an object of class \"glm\" or \"gam\"") msgid "`object' is not of class \"gam\"" msgstr "argument 'object' nie jest obiektem klasy \"gam\"" # mgcv/R/gam.fit3.r: 1831 # stop("unrecognized (vector?) link") #, fuzzy msgid "unrecognised na.action" msgstr "nierozpoznane (wektorowe?) połączenie" msgid "na.action not character or function" msgstr "" msgid "Smoothness uncertainty corrected covariance not available" msgstr "" # mgcv/R/mgcv.r: 2100 # warning("Unknown type, reset to terms.") msgid "Unknown type, reset to terms." msgstr "Nieznany typ, resetowanie do 'terms'" # mgcv/R/mgcv.r: 2103 # stop("predict.gam can only be used to predict from gam objects") msgid "predict.gam can only be used to predict from gam objects" msgstr "" "funkcja 'predict.gam()' może być użyta jedynie do przewidywania z obiektów " "klasy \"gam\"" # mgcv/R/mgcv.r: 2127 # stop("newdata is a model.frame: it should contain all required variables\n") msgid "newdata is a model.frame: it should contain all required variables" msgstr "" "\"newdata\" jest klasy \"model.frame\": powinien zawierać wszystkie wymagane " "zmienne" # mgcv/R/mgcv.r: 2352 # stop("nothing to do for this model") #, fuzzy msgid "no NAs allowed in response data for this model" msgstr "nic do zrobienia dla tego modelu" # mgcv/R/mgcv.r: 2139 # warning("not all required variables have been supplied in newdata!\n") msgid "not all required variables have been supplied in newdata!" msgstr "nie wszystkie wymagane zmienne zostały dostarczone w \"newdata\"!" msgid "type iterms not available for multiple predictor cases" msgstr "" # mgcv/R/mgcv.r: 2284 # warning("non-existent terms requested - ignoring") msgid "non-existent terms requested - ignoring" msgstr "zażądano nieistniejących członów - ignorowanie" # mgcv/R/mgcv.r: 2284 # warning("non-existent terms requested - ignoring") #, fuzzy msgid "non-existent exclude terms requested - ignoring" msgstr "zażądano nieistniejących członów - ignorowanie" # mgcv/R/mgcv.r: 2350 # stop("'b' argument is not an object of class \"gam\"") msgid "requires an object of class gam" msgstr "argument nie jest obiektem klasy \"gam\"" # mgcv/R/mgcv.r: 2352 # stop("nothing to do for this model") msgid "nothing to do for this model" msgstr "nic do zrobienia dla tego modelu" msgid "" "Pearson residuals not available for this family - returning deviance " "residuals" msgstr "" # mgcv/R/mgcv.r: 2494 # stop("'lambda' and 'h' arguments should have the same length!") msgid "lambda and h should have the same length!" msgstr "argumenty 'lambda' oraz 'h' powinny mieć tę samą długość!" msgid "recov works with fitted gam objects only" msgstr "argument nie jest obiektem klasy \"gam\"" msgid "m can't be in re" msgstr "argument 'm' nie może być w argumencie 're'" # mgcv/R/mgcv.r: 2822 # warning("p-values for any terms that can be penalized to zero will be unreliable: refit model to fix this.") msgid "" "p-values for any terms that can be penalized to zero will be unreliable: " "refit model to fix this." msgstr "" "p-wartości dla jakichkolwiek członów, które da się ukarać do zera, będą " "nierzetelne: ponownie dopasuj model aby to naprawić" # mgcv/R/mgcv.r: 3053 # warning(gettext("The following arguments to anova.glm(..) are invalid and dropped: ", domain = "R-mgcv"), paste(deparse(dotargs[named]), collapse = ", "), domain = NA) msgid "The following arguments to anova.glm(..) are invalid and dropped:" msgstr "" "Następujące argumenty przekazywane do funkcji 'anova.glm(..)' są niepoprawne " "i zostały odrzucone:" msgid "," msgstr "," msgid "un-supported test" msgstr "" # mgcv/R/mgcv.r: 3063 # warning("'test' argument ignored") msgid "test argument ignored" msgstr "argument 'test' został zignorowany" msgid "anova.gam called with non gam object" msgstr "argument 'object' nie jest obiektem klasy \"gam\"" msgid "not a gam object" msgstr "argument nie jest obiektem klasy \"gam\"" # mgcv/R/mgcv.r: 2350 # stop("'b' argument is not an object of class \"gam\"") msgid "argument is not a gam object" msgstr "argument nie jest obiektem klasy \"gam\"" msgid "S.scale vector doesn't match S list - please report to maintainer" msgstr "" # mgcv/R/mgcv.r: 3315 # stop("Supplied matrix not symmetric") msgid "Supplied matrix not symmetric" msgstr "Dostarczona macierz nie jest symetryczna" # mgcv/R/mgcv.r: 3319 # stop("singular values not returned in order") msgid "singular values not returned in order" msgstr "osobliwe wartości nie zostały zwrócone w w sposób uporządkowany" # mgcv/R/mgcv.r: 3325 # stop("Something wrong - matrix probably not +ve semi definite") msgid "Something wrong - matrix probably not +ve semi definite" msgstr "Coś nie tak - prawdopodobnie macierz nie jest dodatnio określona" # mgcv/R/mgcv.r: 3340 # stop("method not recognised") msgid "method not recognised." msgstr "metoda nie została rozpoznana" # mgcv/R/mgcv.r: 3463 # stop(gettextf("S[[%d]] matrix is not +ve definite.", i)) #, fuzzy msgid "S[[%d]] matrix is not +ve definite." msgstr "]] nie jest dodatnio określona" # mgcv/R/mgcv.r: 3570 # stop("dimensions of supplied 'w' argument is wrong") msgid "dimensions of supplied w wrong." msgstr "wymiary dostarczonego argumentu 'w' są niepoprawne." # mgcv/R/mgcv.r: 3574 # stop("'w' argument has different length from 'y' argument!") msgid "w different length from y!" msgstr "argument 'w' posiada długość inną niż argument 'y'!" # mgcv/R/mgcv.r: 3581 # stop("'X' lost dimensions in magic!!") msgid "X lost dimensions in magic!!" msgstr "'X' utraciło wymiary w 'magic()!'!" # mgcv/R/smooth.r: 284 # warning("dimension of 'fx' is wrong") #, fuzzy msgid "mu dimensions wrong" msgstr "wymiar 'fx' jest niepoprawny" # mgcv/R/smooth.r: 2112 # stop("Something wrong with auto- penalty construction") #, fuzzy msgid "something wrong with inputs to LAPACK routine" msgstr "Coś nie tak z konstrukcją automatycznej kary" msgid "not positive definite" msgstr "" msgid "don't be silly" msgstr "" msgid "sd should have exactly one less entry than ld" msgstr "" # mgcv/R/mgcv.r: 3463 # stop(gettextf("S[[%d]] matrix is not +ve definite.", i)) #, fuzzy msgid "update not positive definite" msgstr "]] nie jest dodatnio określona" msgid "internal error in vcorr, please report to simon.wood@r-project.org" msgstr "" msgid "a has wrong number of rows" msgstr "" msgid "mvn requires 2 or more dimensional data" msgstr "" msgid "mvn does not yet handle offsets" msgstr "" msgid "mvn dimension error" msgstr "" msgid "non-integer binomial denominator: quantiles incorrect" msgstr "" # mgcv/R/plots.r: 90 # stop("'object' argument is not an object of class \"glm\" or \"gam\"") msgid "object is not a glm or gam" msgstr "argument 'object' nie jest obiektem klasy \"glm\" lub \"gam\"" # mgcv/R/plots.r: 581 # stop("names of 'z' and 'pc' must match") msgid "names of z and pc must match" msgstr "nazwy 'z' oraz 'pc' muszą się zgadzać" # mgcv/R/plots.r: 882 # warning("Partial residuals do not have a natural x-axis location for linear functional terms") msgid "" "Partial residuals do not have a natural x-axis location for linear " "functional terms" msgstr "" "Częsciowe reszty nie posiadają naturalnego położenia osi 'x' dla liniowych " "członów funkcyjnych" # mgcv/R/plots.r: 916 # warning("no automatic plotting for smooths of more than two variables") msgid "no automatic plotting for smooths of more than two variables" msgstr "" "brak automatycznego rysowania dla wygładzeń o więcej niż dwóch zmiennych" # mgcv/R/plots.r: 916 # warning("no automatic plotting for smooths of more than two variables") #, fuzzy msgid "no automatic plotting for smooths of more than four variables" msgstr "" "brak automatycznego rysowania dla wygładzeń o więcej niż dwóch zmiennych" msgid "argument pers is deprecated, please use scheme instead" msgstr "" # mgcv/R/plots.r: 1012 # warning("residuals argument to plot.gam is wrong length: ignored") msgid "residuals argument to plot.gam is wrong length: ignored" msgstr "" "argument reszt przekazywany do 'plot.gam' ma niepoprawną długość: zignorowano" # mgcv/R/plots.r: 1038 # warning("No variance estimates available") msgid "No variance estimates available" msgstr "Brak dostępnego oszacowania wariancji" # mgcv/R/plots.r: 1105 # stop("No terms to plot - nothing for plot.gam() to do.") msgid "No terms to plot - nothing for plot.gam() to do." msgstr "Brak członów do rysowania - nic do wykonania przez 'plot.gam()'." # mgcv/R/mgcv.r: 3295 # stop("grid vectors are different lengths") # mgcv/R/plots.r: 1225 # stop("grid vectors are different lengths") msgid "grid vectors are different lengths" msgstr "wektory siatki są różnej długości" # mgcv/R/mgcv.r: 3296 # stop("data vectors are of different lengths") # mgcv/R/plots.r: 1226 # stop("data vectors are of different lengths") msgid "data vectors are of different lengths" msgstr "wektory danych są różnej długości" # mgcv/R/mgcv.r: 3297 # stop("supplied dist negative") # mgcv/R/plots.r: 1227 # stop("supplied dist negative") msgid "supplied dist negative" msgstr "dostarczona odległość jest ujemna" # mgcv/R/plots.r: 1283 # stop("Model does not seem to have enough terms to do anything useful") msgid "Model does not seem to have enough terms to do anything useful" msgstr "" "Model nie wydaje się mieć wystarczającej liczby członów aby zrobić coś " "użytecznego" # mgcv/R/plots.r: 1285 # stop(gettextf("view variables must be one of %s", paste(v.names, collapse = ", "))) #, fuzzy msgid "view variables must be one of %s" msgstr "zmienne podglądu muszą jednym z" # mgcv/R/plots.r: 1288 # stop("Don't know what to do with parametric terms that are not simple numeric or factor variables") msgid "" "Don't know what to do with parametric terms that are not simple numeric or " "factor variables" msgstr "" "Nie wiadomo co zrobić z członami parametrycznymi, które nie są zmiennymi o " "prostych liczbach lub czynnikami" # mgcv/R/plots.r: 1298 # stop(gettextf("View variables must contain more than one value. view = c(%s,%s).", view[1], view[2])) #, fuzzy msgid "View variables must contain more than one value. view = c(%s,%s)." msgstr "zmienne 'view' muszą zawierać więcej niż jedną wartość. view =c(" # mgcv/R/plots.r: 1346 # stop("type must be \"link\" or \"response\"") msgid "type must be \"link\" or \"response\"" msgstr "'type' musi mieć wartość \"link\" lub \"response\"" # mgcv/R/plots.r: 1373 # stop("Something wrong with zlim") # mgcv/R/plots.r: 1433 # stop("Something wrong with zlim") msgid "Something wrong with zlim" msgstr "Coś nie tak z 'zlim'" # mgcv/R/plots.r: 1389 # stop("color scheme not recognised") msgid "color scheme not recognised" msgstr "nie rozpoznano schematu kolorów" # mgcv/R/plots.r: 1442 # warning("sorry no option for contouring with errors: try plot.gam") msgid "sorry no option for contouring with errors: try plot.gam" msgstr "przykro mi, brak opcji rysowania konturu z błędami: spróbuj 'plot.gam'" # mgcv/R/smooth.r: 142 # stop("At least three knots required in call passed to 'mono.con()'.") msgid "At least three knots required in call to mono.con." msgstr "" "Co najmniej trzy węzły są wymagane w wywołaniu przekazywanym do funkcji " "'mono.con()'" # mgcv/R/smooth.r: 145 # stop("lower bound >= upper bound in call passed to 'mono.con()'") msgid "lower bound >= upper bound in call to mono.con()" msgstr "" "dolny zakres >= górny zakres w wywołaniu przekazywanym do funkcji 'mono." "con()'" # mgcv/R/smooth.r: 157 # stop("'x' is null") msgid "x is null" msgstr "'x' ma wartość NULL" msgid "uniquecombs has not worked properly" msgstr "" # mgcv/R/smooth.r: 173 # stop("order too low") msgid "order too low" msgstr "zbyt mała wartość argumentu 'ord'" # mgcv/R/smooth.r: 174 # stop("too few knots") # mgcv/R/smooth.r: 1323 # stop("too few knots") msgid "too few knots" msgstr "zbyt mało węzłów" # mgcv/R/smooth.r: 177 # stop("'x' out of range") msgid "x out of range" msgstr "argument 'x' jest poza zakresem" # mgcv/R/smooth.r: 265 # warning("something wrong with argument 'd'.") # mgcv/R/smooth.r: 373 # warning("something wrong with argument 'd'.") msgid "something wrong with argument d." msgstr "coś nie tak z argumentem 'd'" # mgcv/R/smooth.r: 274 # warning("one or more supplied k too small - reset to default") # mgcv/R/smooth.r: 382 # warning("one or more supplied k too small - reset to default") msgid "one or more supplied k too small - reset to default" msgstr "" "jeden lub więcej dostarczonych 'k' jest zbyt mały - przyjmowanie wartości " "domyślnej" # mgcv/R/smooth.r: 284 # warning("dimension of 'fx' is wrong") msgid "dimension of fx is wrong" msgstr "wymiar 'fx' jest niepoprawny" # mgcv/R/smooth.r: 394 # stop("xt argument is faulty.") msgid "xt argument is faulty." msgstr "argument 'xt' jest błędny" # mgcv/R/smooth.r: 296 # warning("bs wrong length and ignored.") # mgcv/R/smooth.r: 398 # warning("bs wrong length and ignored.") msgid "bs wrong length and ignored." msgstr "'bs' posiada niepoprawną długość przez co został zignorowany" # mgcv/R/smooth.r: 296 # warning("bs wrong length and ignored.") # mgcv/R/smooth.r: 398 # warning("bs wrong length and ignored.") msgid "m wrong length and ignored." msgstr "'m' posiada niepoprawną długość przez co został zignorowany" # mgcv/R/smooth.r: 308 # stop("Repeated variables as arguments of a smooth are not permitted") # mgcv/R/smooth.r: 410 # stop("Repeated variables as arguments of a smooth are not permitted") # mgcv/R/smooth.r: 483 # stop("Repeated variables as arguments of a smooth are not permitted") msgid "Repeated variables as arguments of a smooth are not permitted" msgstr "Powtórzone zmienne jako argumenty wygładzenia nie są dozwolone" # mgcv/R/smooth.r: 331 # warning("only first element of 'id' used") # mgcv/R/smooth.r: 441 # warning("only first element of 'id' used") # mgcv/R/smooth.r: 491 # warning("only first element of 'id' used") msgid "only first element of `id' used" msgstr "został użyty jedynie pierwszy element 'id'" msgid "supply a value for each variable for a point constraint" msgstr "" # mgcv/R/smooth.r: 428 # warning("ord is wrong. reset to NULL.") msgid "ord is wrong. reset to NULL." msgstr "argument 'ord' jest błędny. Przywracanie wartości NULL" # mgcv/R/smooth.r: 430 # warning("ord contains out of range orders (which will be ignored)") msgid "ord contains out of range orders (which will be ignored)" msgstr "'ord' zawiera porządki poza zakresem (zostaną one zignorowane)" # mgcv/R/smooth.r: 468 # stop("by=. not allowed") msgid "by=. not allowed" msgstr "'by=.' nie jest dozwolone" # mgcv/R/smooth.r: 470 # stop("s(.) not yet supported.") # mgcv/R/smooth.r: 474 # stop("s(.) not yet supported.") #, fuzzy msgid "s(.) not supported." msgstr "funkcja 's(.)' nie jest jeszcze wspierana" # mgcv/R/smooth.r: 470 # stop("s(.) not yet supported.") # mgcv/R/smooth.r: 474 # stop("s(.) not yet supported.") msgid "s(.) not yet supported." msgstr "funkcja 's(.)' nie jest jeszcze wspierana" # mgcv/R/smooth.r: 480 # warning("argument k of s() should be integer and has been rounded") msgid "argument k of s() should be integer and has been rounded" msgstr "" "argument 'k' w funkcji 's()' powinie być liczbą calkowitą więc został " "zaokrąglony" # mgcv/R/smooth.r: 568 # stop("attempt to use unsuitable marginal smooth class") # mgcv/R/smooth.r: 812 # stop("attempt to use unsuitable marginal smooth class") msgid "attempt to use unsuitable marginal smooth class" msgstr "próba użycia niepasującej granicznej gładkiej klasy" # mgcv/R/smooth.r: 572 # stop("Sorry, tensor products of smooths with multiple penalties are not supported.") # mgcv/R/smooth.r: 816 # stop("Sorry, tensor products of smooths with multiple penalties are not supported.") msgid "" "Sorry, tensor products of smooths with multiple penalties are not supported." msgstr "" "Przykro mi, produkty tensorowe wygładzeń z wielokrotnymi karami nie są " "wpierane" # mgcv/R/smooth.r: 600 # warning("reparameterization unstable for margin: not done") msgid "reparameterization unstable for margin: not done" msgstr "ponowna parametryzacja nie jest stabilna dla marginesu: nie wykonano" msgid "basis not usable with reduced te" msgstr "" # mgcv/R/smooth.r: 855 # warning("fx length wrong from t2 term: ignored") msgid "fx length wrong from t2 term: ignored" msgstr "długość 'fx' z członu 't2' jest błędna: zignorowano" # mgcv/R/smooth.r: 861 # warning("length of sp incorrect in t2: ignored") msgid "length of sp incorrect in t2: ignored" msgstr "długość 'sp' jest niepoprawna w 't2': zignorowano" # mgcv/R/smooth.r: 987 # stop("'d' can not be negative in call passed to 'null.space.dimension()'.") msgid "d can not be negative in call to null.space.dimension()." msgstr "" "'d' nie może być ujemne w wywołaniu przekazywanym do funkcji 'null.space." "dimension()'" # mgcv/R/smooth.r: 1025 # stop("arguments of smooth not same dimension") # mgcv/R/smooth.r: 1157 # stop("arguments of smooth not same dimension") # mgcv/R/smooth.r: 2288 # stop("arguments of smooth not same dimension") # mgcv/R/smooth.r: 2495 # stop("arguments of smooth not same dimension") # mgcv/R/smooth.r: 2648 # stop("arguments of smooth not same dimension") msgid "arguments of smooth not same dimension" msgstr "argumenty wygładzania nie mają tego samego wymiaru" # mgcv/R/smooth.r: 1037 # stop("components of knots relating to a single smooth must be of same length") # mgcv/R/smooth.r: 2301 # stop("components of knots relating to a single smooth must be of same length") # mgcv/R/smooth.r: 2508 # stop("components of knots relating to a single smooth must be of same length") msgid "components of knots relating to a single smooth must be of same length" msgstr "" "komponenty węzłów odwołujące się do pojedynczego wygładzenia muszą być tej " "samej długości" # mgcv/R/smooth.r: 1042 # warning("more knots than data in a tp term: knots ignored.") msgid "more knots than data in a tp term: knots ignored." msgstr "więcej węzłów niż danych w członie 'tp': węzły zostały zignorowane" # mgcv/R/smooth.r: 1079 # warning("basis dimension, k, increased to minimum possible\n") # mgcv/R/smooth.r: 1217 # warning("basis dimension, k, increased to minimum possible\n") # mgcv/R/smooth.r: 1365 # warning("basis dimension, k, increased to minimum possible\n") msgid "basis dimension, k, increased to minimum possible" msgstr "wymiar podstawy, k, zwiększył się do minimalnego możliwego" # mgcv/R/smooth.r: 1158 # stop("no data to predict at") # mgcv/R/smooth.r: 1287 # stop("no data to predict at") # mgcv/R/smooth.r: 1419 # stop("no data to predict at") msgid "no data to predict at" msgstr "brak danych na których można oprzeć przewidywanie" # mgcv/R/smooth.r: 1205 # stop("Basis only handles 1D smooths") # mgcv/R/smooth.r: 1361 # stop("Basis only handles 1D smooths") # mgcv/R/smooth.r: 1442 # stop("Basis only handles 1D smooths") # mgcv/R/smooth.r: 1507 # stop("Basis only handles 1D smooths") msgid "Basis only handles 1D smooths" msgstr "Podstawa obsługuje jedynie jednowymiarowe wygładzania" # mgcv/R/smooth.r: 1231 # stop("number of supplied knots != k for a cr smooth") msgid "number of supplied knots != k for a cr smooth" msgstr "liczba dostarczonych węzłów != k dla wygładzania 'cr'" # mgcv/R/smooth.r: 1294 # stop("F is missing from cr smooth - refit model with current mgcv") msgid "F is missing from cr smooth - refit model with current mgcv" msgstr "" "Brakuje 'F' w wygładzaniu 'cr' - ponownie dopasuj model z bieżącym mgcv" # mgcv/R/smooth.r: 1322 # stop("more knots than unique data values is not allowed") msgid "more knots than unique data values is not allowed" msgstr "" "większa liczba węzłów niż unikalnych wartości danych nie jest dozwolona" # mgcv/R/smooth.r: 1375 # stop("number of supplied knots != k for a cc smooth") msgid "number of supplied knots != k for a cc smooth" msgstr "liczba dostarczonych węzłów != k dla wygładzania 'cc'" # mgcv/R/smooth.r: 1441 # stop("basis dimension too small for b-spline order") # mgcv/R/smooth.r: 1506 # stop("basis dimension too small for b-spline order") msgid "basis dimension too small for b-spline order" msgstr "wymiar podstawy jest zbyt mały dla rzędu b-splajnu" # mgcv/R/smooth.r: 1449 # stop("knot range does not include data") # mgcv/R/smooth.r: 1513 # stop("knot range does not include data") msgid "knot range does not include data" msgstr "zakres węzła nie zawiera danych" # mgcv/R/gam.fit3.r: 785 # stop("deriv should be 1 or 2") msgid "there should be" msgstr "liczba dostarczonych węzłów powinna być równa:" # mgcv/R/smooth.r: 2116 # stop("supplied penalty not square!") msgid "supplied knots" msgstr " " msgid "knots supplied" msgstr " " # mgcv/R/smooth.r: 1463 # warning("knot range is so wide that there is *no* information about some basis coefficients") # mgcv/R/smooth.r: 1526 # warning("knot range is so wide that there is *no* information about some basis coefficients") msgid "" "knot range is so wide that there is *no* information about some basis " "coefficients" msgstr "" "zakres węzła jest tak szeroki, że *brak* informacji o niektórych " "podstawowych współczynnikach" # mgcv/R/smooth.r: 1470 # stop("penalty order too high for basis dimension") msgid "penalty order too high for basis dimension" msgstr "rząd kar jest zbyt duży dla podstawy wymiaru" # mgcv/R/smooth.r: 1463 # warning("knot range is so wide that there is *no* information about some basis coefficients") # mgcv/R/smooth.r: 1526 # warning("knot range is so wide that there is *no* information about some basis coefficients") #, fuzzy msgid "there is *no* information about some basis coefficients" msgstr "" "zakres węzła jest tak szeroki, że *brak* informacji o niektórych " "podstawowych współczynnikach" msgid "basis dimension is larger than number of unique covariates" msgstr "" msgid "multiple penalties of the same order is silly" msgstr "" msgid "requested non-existent derivative in B-spline penalty" msgstr "" # mgcv/R/smooth.r: 1600 # stop("fs smooths can only have one factor argument") msgid "fs smooths can only have one factor argument" msgstr "wygładzania 'fs' mogą mieć tylko jeden argument czynnikowy" # mgcv/R/smooth.r: 1632 # stop("\"fs\" smooth cannot use a multiply penalized basis (wrong basis in xt)") msgid "\"fs\" smooth cannot use a multiply penalized basis (wrong basis in xt)" msgstr "" "wygładzanie \"fs\" nie może użyć wielokrotnie ukaranej bazy (błędna baza w " "xt)" # mgcv/R/mgcv.r: 561 # stop("No data supplied to gam.setup") #, fuzzy msgid "no factor supplied to fs smooth" msgstr "Nie dostarczono danych do gam.setup" # mgcv/R/smooth.r: 1664 # stop("\"fs\" terms can not be fixed here") msgid "\"fs\" terms can not be fixed here" msgstr "człony \"fs\" nie mogą być poprawione tutaj" msgid "" "fs smooth not suitable for discretisation with more than one metric predictor" msgstr "" # mgcv/R/smooth.r: 1805 # stop("the adaptive smooth class is limited to 1 or 2 covariates.") msgid "the adaptive smooth class is limited to 1 or 2 covariates." msgstr "adaptacyjna klasa wygładzania jest ograniczona do 1 lub 2 zmiennych" # mgcv/R/smooth.r: 1821 # stop("penalty basis too large for smoothing basis") # mgcv/R/smooth.r: 1872 # stop("penalty basis too large for smoothing basis") msgid "penalty basis too large for smoothing basis" msgstr "podstawa kar jest zbyt duża dla podstawy wygładzania" # mgcv/R/smooth.r: 1892 # stop("penalty basis too small") msgid "penalty basis too small" msgstr "podstawa kar jest zbyt mała" # mgcv/R/smooth.r: 1934 # stop("random effects don't work with ids.") msgid "random effects don't work with ids." msgstr "losowe efekty nie działają z 'ids'" msgid "" "Please put term with most levels last in 're' to avoid spoiling supplied " "penalties" msgstr "" # mgcv/R/smooth.r: 2117 # stop("supplied penalty wrong dimension!") #, fuzzy msgid "supplied S matrices are wrong diminsion" msgstr "dostarczona kara ma niepoprawny wymiar!" # mgcv/R/smooth.r: 480 # warning("argument k of s() should be integer and has been rounded") #, fuzzy msgid "argument of mrf should be a factor variable" msgstr "" "argument 'k' w funkcji 's()' powinie być liczbą calkowitą więc został " "zaokrąglony" # mgcv/R/smooth.r: 2062 # stop("MRF basis dimension set too high") msgid "MRF basis dimension set too high" msgstr "ustawiony bazowy wymiar MRF jest zbyt wysoki" # mgcv/R/smooth.r: 2065 # stop("data contain regions that are not contained in the knot specification") msgid "data contain regions that are not contained in the knot specification" msgstr "dane zawierają regiony, które nie są zawarte w specyfikacji węzła" # mgcv/R/smooth.r: 2075 # stop("penalty matrix, boundary polygons and/or neighbours list must be supplied in xt") msgid "" "penalty matrix, boundary polygons and/or neighbours list must be supplied in " "xt" msgstr "" "macierz kary, wielokąty brzegowe oraz/lub lista sąsiadów muszą być " "dostarczone w xt" # mgcv/R/smooth.r: 2097 # stop("no spatial information provided!") msgid "no spatial information provided!" msgstr "nie dostarczono informacji przestrzennej!" # mgcv/R/smooth.r: 2102 # stop("mismatch between nb/polys supplied area names and data area names") msgid "mismatch between nb/polys supplied area names and data area names" msgstr "" "niezgodność pomiędzy dostarczonymi nazwami obszarów nb/polys a nazwami " "obszarów danych" # mgcv/R/smooth.r: 2112 # stop("Something wrong with auto- penalty construction") msgid "Something wrong with auto- penalty construction" msgstr "Coś nie tak z konstrukcją automatycznej kary" # mgcv/R/smooth.r: 2116 # stop("supplied penalty not square!") msgid "supplied penalty not square!" msgstr "dostarczona kara nie jest kwadratowa!" # mgcv/R/smooth.r: 2117 # stop("supplied penalty wrong dimension!") msgid "supplied penalty wrong dimension!" msgstr "dostarczona kara ma niepoprawny wymiar!" # mgcv/R/smooth.r: 2121 # stop("penalty column names don't match supplied area names!") msgid "penalty column names don't match supplied area names!" msgstr "nazwa kolumny kary nie zgadza się z dostarczonymi nazwami obszaru!" # mgcv/R/smooth.r: 2281 # stop("Can only deal with a sphere") msgid "Can only deal with a sphere" msgstr "można obsługiwać jedynie sferę" # mgcv/R/smooth.r: 2307 # warning("more knots than data in an sos term: knots ignored.") msgid "more knots than data in an sos term: knots ignored." msgstr "więcej węzłów niż danych w członie 'sos': węzły zostały zignorowane" # mgcv/R/smooth.r: 2514 # warning("more knots than data in a ds term: knots ignored.") msgid "more knots than data in a ds term: knots ignored." msgstr "więcej węzłów niż danych w członie 'ds': węzły zostały zignorowane" # mgcv/src/tprs.c: 417 # (_("A term has fewer unique covariate combinations than specified maximum degrees of freedom"),1) # mgcv/src/tprs.c: 425 # (_("A term has fewer unique covariate combinations than specified maximum degrees of freedom"),1) # mgcv/R/smooth.r: 2518 # stop( # "A term has fewer unique covariate combinations than specified maximum degrees of freedom") msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" "człon posiada mniej unikalnych kombinacji zmiennych niezależnych niż " "określona maksymalna liczba stopni swobody" # mgcv/R/smooth.r: 2559 # warning("s value reduced") msgid "s value reduced" msgstr "wartość 's' została zmniejszona" # mgcv/R/smooth.r: 2563 # warning("s value increased") msgid "s value increased" msgstr "wartość 's' została zwiększona" # mgcv/R/smooth.r: 2569 # stop("No suitable s (i.e. m[2]) try increasing m[1]") msgid "No suitable s (i.e. m[2]) try increasing m[1]" msgstr "Brak odpowiedniego 's' (tj.: m[2]), spróbuj zwiększyć 'm[1]'" # mgcv/R/smooth.r: 2570 # warning("s value modified to give continuous function") msgid "s value modified to give continuous function" msgstr "wartość 's' została zmieniona aby dać ciągłą funkcję" # mgcv/R/smooth.r: 2596 # warning("basis dimension reset to minimum possible") msgid "basis dimension reset to minimum possible" msgstr "wymiar podstawy został przywrócony do minimalnego możliwego" msgid "incorrect arguments to GP smoother" msgstr "" # mgcv/R/smooth.r: 2307 # warning("more knots than data in an sos term: knots ignored.") #, fuzzy msgid "more knots than data in an ms term: knots ignored." msgstr "więcej węzłów niż danych w członie 'sos': węzły zostały zignorowane" # mgcv/R/smooth.r: 2804 # warning("smooth objects should not have a qrc attribute.") msgid "smooth objects should not have a qrc attribute." msgstr "gładkie obiekty nie powinny mieć atrybutu 'qrc'" # mgcv/R/smooth.r: 2842 # stop("unimplemented sparse constraint type requested") msgid "unimplemented sparse constraint type requested" msgstr "zażądano niezaimplementowanego typu rzadkiego więzu" # mgcv/R/smooth.r: 2893 # warning("handling 'by' variables in smooth constructors may not work with the summation convention") msgid "" "handling `by' variables in smooth constructors may not work with the " "summation convention" msgstr "" "obsługiwanie zmiennych 'by' w konstruktorach wygładzenia może nie działać z " "konwencją sumacyjną" # mgcv/R/smooth.r: 2910 # stop("Can't find by variable") # mgcv/R/smooth.r: 3175 # stop("Can't find by variable") # mgcv/R/smooth.r: 3200 # stop("Can't find by variable") msgid "Can't find by variable" msgstr "Nie można znaleźć poprzez zmienną" msgid "" "sweep and drop constraints unlikely to work well with self handling of by " "vars" msgstr "" # mgcv/R/smooth.r: 2913 # stop("factor 'by' variables can not be used with matrix arguments.") msgid "factor `by' variables can not be used with matrix arguments." msgstr "faktoryzacja zmiennych 'by' nie może być użyta z argumentami macierzy" # mgcv/R/smooth.r: 2933 # stop("'by' variable must be same dimension as smooth arguments") # mgcv/R/smooth.r: 3206 # stop("'by' variable must be same dimension as smooth arguments") msgid "`by' variable must be same dimension as smooth arguments" msgstr "zmienna 'by' musi mieć ten sam wymiar co argumenty wygładzania" # mgcv/R/smooth.r: 3137 # stop("Number of prediction and fit constraints must match") msgid "Number of prediction and fit constraints must match" msgstr "Liczba przewidywań oraz więzów dopasowania musi się zgadzać" # mgcv/R/soap.r: 92 # stop("x and y must be same length") msgid "x and y must be same length" msgstr "x oraz y muszą mieć tę samą długość" # mgcv/R/soap.r: 109 # stop("variable names don't match boundary names") # mgcv/R/soap.r: 114 # stop("variable names don't match boundary names") msgid "variable names don't match boundary names" msgstr "nazwy zmiennych nie zgadzają się z nazwami granic" # mgcv/R/soap.r: 133 # stop("x and y not same length") msgid "x and y not same length" msgstr "'x' oraz 'y' nie mają tej samej długości" # mgcv/R/soap.r: 177 # stop("bnd must be a list.") msgid "bnd must be a list." msgstr "'bnd' musi być listą" # mgcv/R/soap.r: 181 # stop("lengths of k and bnd are not compatible.") msgid "lengths of k and bnd are not compatible." msgstr "długości 'k' oraz 'bnd' nie są zgodne" # mgcv/R/soap.r: 306 # stop("attempt to select non existent basis function") msgid "attempt to select non existent basis function" msgstr "próba wybrania nieistniejącej funkcji bazowej" # mgcv/R/soap.r: 309 # stop("coefficient vector wrong length") msgid "coefficient vector wrong length" msgstr "błędna długość wektora współczynników" # mgcv/R/soap.r: 418 # stop("knots must be specified for soap") # mgcv/R/soap.r: 522 # stop("knots must be specified for soap") # mgcv/R/soap.r: 627 # stop("knots must be specified for soap") msgid "knots must be specified for soap" msgstr "węzły muszą być określone dla 'soap'" # mgcv/R/soap.r: 419 # stop("soap films are bivariate only") # mgcv/R/soap.r: 523 # stop("soap films are bivariate only") # mgcv/R/soap.r: 628 # stop("soap films are bivariate only") msgid "soap films are bivariate only" msgstr "filmy 'soap' są tylko dwuwymiarowe" # mgcv/R/soap.r: 426 # stop("need at least one interior knot") # mgcv/R/soap.r: 530 # stop("need at least one interior knot") # mgcv/R/soap.r: 635 # stop("need at least one interior knot") msgid "need at least one interior knot" msgstr "potrzeba przynajmniej jednego wewnętrznego węzła" # mgcv/R/soap.r: 429 # stop("can't soap smooth without a boundary") # mgcv/R/soap.r: 533 # stop("can't soap smooth without a boundary") # mgcv/R/soap.r: 638 # stop("can't soap smooth without a boundary") msgid "can't soap smooth without a boundary" msgstr "nie można wygładzić 'soap' bez granicy" # mgcv/R/soap.r: 430 # stop("bnd must be a list of boundary loops") # mgcv/R/soap.r: 534 # stop("bnd must be a list of boundary loops") # mgcv/R/soap.r: 639 # stop("bnd must be a list of boundary loops") msgid "bnd must be a list of boundary loops" msgstr "'bnd' musi być listą pętel granic" # mgcv/R/soap.r: 435 # stop("faulty bnd") # mgcv/R/soap.r: 438 # stop("faulty bnd") # mgcv/R/soap.r: 539 # stop("faulty bnd") # mgcv/R/soap.r: 542 # stop("faulty bnd") # mgcv/R/soap.r: 644 # stop("faulty bnd") # mgcv/R/soap.r: 647 # stop("faulty bnd") msgid "faulty bnd" msgstr "błędne 'bnd'" # mgcv/R/soap.r: 445 # stop("k and bnd lengths are inconsistent") # mgcv/R/soap.r: 549 # stop("k and bnd lengths are inconsistent") # mgcv/R/soap.r: 654 # stop("k and bnd lengths are inconsistent") msgid "k and bnd lengths are inconsistent" msgstr "długości 'k' oraz 'bnd' są niezgodne" # mgcv/R/soap.r: 456 # stop("data outside soap boundary") # mgcv/R/soap.r: 559 # stop("data outside soap boundary") # mgcv/R/soap.r: 665 # stop("data outside soap boundary") msgid "data outside soap boundary" msgstr "dane poza granicami 'soap'" # mgcv/R/soap.r: 561 # stop("no free coefs in sf smooth") msgid "no free coefs in sf smooth" msgstr "brak wolnych współczynników w wygładzaniu sf" # mgcv/R/sparse.r: 103 # stop("only deals with 2D case") msgid "only deals with 2D case" msgstr "obsługiwanie jedynie dwuwymiarowych przypadków" # mgcv/R/sparse.r: 141 # stop("not enough unique values to find k nearest") msgid "not enough unique values to find k nearest" msgstr "zbyt mało unikalnych wartości aby znaleźć k najbliższych" # mgcv/R/sparse.r: 248 # stop("cubic spline only deals with 1D data") msgid "cubic spline only deals with 1D data" msgstr "sześcienny splajn radzi sobie jedynie z danymi jednowymiarowymi" # mgcv/R/sparse.r: 288 # stop("object not fully initialized") msgid "object not fully initialized" msgstr "obiekt nie został w pełni zainicjalizowany" # mgcv/R/mgcv.r: 1678 # stop("value of epsilon must be > 0") #, fuzzy #~ msgid "scaled t df must be > min.df" #~ msgstr "wartość 'epsilon' musi być > 0" # mgcv/R/mgcv.r: 2716 # warning("p-values may give low power in some circumstances") #~ msgid "p-values may give low power in some circumstances" #~ msgstr "p-wartość może dać niską moc w pewnych okolicznościach" # mgcv/R/mgcv.r: 2719 # warning("p-values un-reliable") #~ msgid "p-values un-reliable" #~ msgstr "p-wartość nie jest wiarygodna" # mgcv/R/mgcv.r: 2723 # warning("p-values may give very low power") #~ msgid "p-values may give very low power" #~ msgstr "p-wartości mogą dać bardzo niską moc" # mgcv/R/plots.r: 959 # warning("no automatic plotting for smooths of more than one variable") #~ msgid "no automatic plotting for smooths of more than one variable" #~ msgstr "" #~ "brak automatycznego rysowania dla wygładzeń o więcej niż jednej zmiennej" # mgcv/R/bam.r: 425 # warning(gettextf("non-finite coefficients at iteration %d", iter)) # mgcv/R/bam.r: 600 # warning(gettextf("non-finite coefficients at iteration %d", iter)) #~ msgid "non-finite coefficients at iteration" #~ msgstr "nieskończone współczynniki w iteracji" # mgcv/R/bam.r: 1086 # warning("sparse=TRUE not supported with fast REML, reset to REML.") #~ msgid "sparse=TRUE not supported with fast REML, reset to REML." #~ msgstr "" #~ "'sparse=TRUE' nie jest wspierane dla szybkiego REML, przywracanie REML." # mgcv/R/bam.r: 1175 # warning("model matrix too dense for any possible benefit from sparse") #~ msgid "model matrix too dense for any possible benefit from sparse" #~ msgstr "macierz modelu jest zbyt gęsta aby móc skorzystać z zalez 'sparse'" # mgcv/R/bam.r: 1178 # warning("AR1 parameter rho unused with sparse fitting") #~ msgid "AR1 parameter rho unused with sparse fitting" #~ msgstr "parametr rho AR1 jest nieużywany podczas dopasowania 'sparse'" # mgcv/R/mgcv.r: 1152 # stop("nlm.fd not available with negative binomial Theta estimation") #~ msgid "nlm.fd not available with negative binomial Theta estimation" #~ msgstr "" #~ "'nlm.fd' nie jest dostępne z ujemnym oszacowaniem Theta rozkładu Pascala" # mgcv/R/mgcv.r: 1175 # warning("only outer methods 'newton' & 'bfgs' supports 'negbin' family and theta selection: reset") #~ msgid "" #~ "only outer methods `newton' & `bfgs' supports `negbin' family and theta " #~ "selection: reset" #~ msgstr "" #~ "tylko zewnętrzne metody 'newton' oraz 'bfgs' wspierają rodzinę 'negbin' " #~ "oraz wybór theta: reset" # mgcv/R/smooth.r: 158 # stop("'x' has no row attribute") #~ msgid "x has no row attribute" #~ msgstr "'x' nie posiada atrybutu 'row'" # mgcv/R/smooth.r: 159 # stop("'x' has no col attribute") #~ msgid "x has no col attribute" #~ msgstr "'x' nie posiada atrybutu 'col'" # mgcv/R/bam.r: 45 # stop("Choleski based method failed, switch to QR") #~ msgid "Choleski based method failed, switch to QR" #~ msgstr "" #~ "metoda oparta na algorytmie Choleskiego nie powiodła się, przełączania na " #~ "algorytm QR" #~ msgid "gamm() requires package nlme to be installed" #~ msgstr "funkcja 'gamm()' wymaga aby pakiet 'nlme' był zainstalowany" #~ msgid "M$S[" #~ msgstr "M$S[" #~ msgid "]" #~ msgstr "]" # mgcv/R/mgcv.r: 3265 # warning("extra arguments were discarded") #~ msgid "extra arguments discarded" #~ msgstr "dodatkowe argumenty zostały odrzucone" #~ msgid "S[[" #~ msgstr "S[[" #~ msgid ")." #~ msgstr ")." #~ msgid "can't predict outside range of knots with periodic smoother" #~ msgstr "" #~ "nie można przewidywać poza zakresem węzłów z periodycznym wygładzaniem" #~ msgid "k too small for balanced neighbours" #~ msgstr "'k' jest zbyt małe dla zbalansowanych sąsiadów" #~ msgid "only 2D case available so far" #~ msgstr "na chwilę obecną tylko dwuwymiarowe przypadki są dostępne" # mgcv/R/bam.r: 1170 # gettext("Setup complete. Calling fit", domain = "R-mgcv") #~ msgid "Setup complete. Calling fit" #~ msgstr "Ustawienie jest kompletne. Wywoływanie dopasowania." # mgcv/R/bam.r: 1209 # gettext("Fit complete. Finishing gam object.", domain = "R-mgcv") #~ msgid "Fit complete. Finishing gam object." #~ msgstr "Dopasowanie jest kompletne. Kończenie obiektu klasy \"gam\"." # mgcv/R/fast-REML.r: 641 # gettext("step failed", domain = "R-mgcv") # mgcv/R/gam.fit3.r: 1247 # gettext("step failed", domain = "R-mgcv") # mgcv/R/gam.fit3.r: 1424 # gettext("step failed", domain = "R-mgcv") # mgcv/R/gam.fit3.r: 1684 # gettext("step failed", domain = "R-mgcv") #~ msgid "step failed" #~ msgstr "krok nie powiódł się" # mgcv/R/fast-REML.r: 642 # gettext("no convergence in 200 iterations", domain = "R-mgcv") #~ msgid "no convergence in 200 iterations" #~ msgstr "brak zbieżności w 200 iteracjach" # mgcv/R/fast-REML.r: 643 # gettext("full convergence", domain = "R-mgcv") # mgcv/R/gam.fit3.r: 1249 # gettext("full convergence", domain = "R-mgcv") # mgcv/R/gam.fit3.r: 1426 # gettext("full convergence", domain = "R-mgcv") # mgcv/R/gam.fit3.r: 1689 # gettext("full convergence", domain = "R-mgcv") #~ msgid "full convergence" #~ msgstr "pełna zbieżność" # mgcv/R/gam.fit3.r: 284 # stop("NA values in V(mu)") # mgcv/R/gam.fit3.r: 457 # stop("NA values in V(mu)") # mgcv/R/mgcv.r: 1890 # stop("NA values in V(mu)") #~ msgid "NA values in V(mu)" #~ msgstr "wartości NA w 'V(mu)'" # mgcv/R/gam.fit3.r: 362 # stop("inner loop 1; can't correct step size") # mgcv/R/mgcv.r: 1960 # stop("inner loop 1; can't correct step size") #~ msgid "inner loop %d; can't correct step size" #~ msgstr "wewnętrzna pętla %d; nie można poprawić rozmiaru kroku" # mgcv/R/gam.fit3.r: 371 # gettextf("Step halved: new deviance = %s", dev, domain = "R-mgcv") # mgcv/R/gam.fit3.r: 387 # gettextf("Step halved: new deviance = %s", dev, domain = "R-mgcv") # mgcv/R/mgcv.r: 1970 # gettextf("Step halved: new deviance = %s", dev, domain = "R-mgcv") # mgcv/R/mgcv.r: 1987 # gettextf("Step halved: new deviance = %s", dev, domain = "R-mgcv") #~ msgid "Step halved: new deviance = %s" #~ msgstr "Krok został skrócony o połowę: nowe odchylenie = %s" # mgcv/R/gam.fit3.r: 521 # gettext("calling gdi...", domain = "R-mgcv") #~ msgid "calling gdi..." #~ msgstr "wywoływanie gdi..." # mgcv/R/gam.fit3.r: 546 # gettext("done!", domain = "R-mgcv") #~ msgid "done!" #~ msgstr "wykonano!" # mgcv/R/gam.fit3.r: 705 # gettextf("Proportion time in C: %s ls: %s gdi: %s",(tc+tg)/at,tc/at,tg/at, domain = "R-mgcv") #~ msgid "Proportion time in C: %s ls: %s gdi: %s" #~ msgstr "Czas proporcji w C: %s ls: %s gdi: %s" # mgcv/R/gam.fit3.r: 774 # gettext("differences", domain = "R-mgcv") #~ msgid "differences" #~ msgstr "różnice" # mgcv/R/gam.fit3.r: 868 # gettext("Pearson Statistic...", domain = "R-mgcv") #~ msgid "Pearson Statistic..." #~ msgstr "Statystyka Pearson'a..." # mgcv/R/gam.fit3.r: 887 # gettext("Deviance...", domain = "R-mgcv") #~ msgid "Deviance..." #~ msgstr "Odchylenie..." # mgcv/R/gam.fit3.r: 897 # gettext("The objective...", domain = "R-mgcv") #~ msgid "The objective..." #~ msgstr "Cel..." # mgcv/R/gam.fit3.r: 1248 # gettext("iteration limit reached", domain = "R-mgcv") # mgcv/R/gam.fit3.r: 1425 # gettext("iteration limit reached", domain = "R-mgcv") # mgcv/R/gam.fit3.r: 1688 # gettext("iteration limit reached", domain = "R-mgcv") #~ msgid "iteration limit reached" #~ msgstr "osiągnięto limit iteracji" # mgcv/R/gam.fit3.r: 2361 # stop("'mu' argument must be non negative") #~ msgid "'mu' argument must be non negative" #~ msgstr "argument 'mu' musi być nieujemny" #~ msgid "Deta: rdiff = %s cor = %s" #~ msgstr "Deta: rdiff = %s korelacja = %s" #~ msgid "Dth[%d]: rdiff = %s cor = %s" #~ msgstr "Dth[%d]: rdiff = %s korelacja = %s" #~ msgid "Deta2: rdiff = %s cor = %s" #~ msgstr "Deta2: rdiff = %s korelacja = %s" #~ msgid "Deta3: rdiff = %s cor = %s" #~ msgstr "Deta3: rdiff = %s korelacja = %s" #~ msgid "Deta4: rdiff = %s cor = %s" #~ msgstr "Deta4: rdiff = %s korelacja = %s" #~ msgid "Detath[%d]: rdiff = %s cor = %s" #~ msgstr "Detath[%d]: rdiff = %s korelacja = %s" #~ msgid "Deta2th[%d]: rdiff = %s cor = %s" #~ msgstr "Deta2th[%d]: rdiff = %s korelacja = %s" #~ msgid "Deta3th[%d]: rdiff = %s cor = %s" #~ msgstr "Deta3th[%d]: rdiff = %s korelacja = %s" #~ msgid "Dth2[%d]: rdiff = %s cor = %s" #~ msgstr "Dth2[%d]: rdiff = %s korelacja = %s" #~ msgid "Deta2th2[%d]: rdiff = %s cor = %s" #~ msgstr "Deta2th2[%d]: rdiff = %s korelacja = %s" #~ msgid "Dmu: rdiff = %s cor = %s" #~ msgstr "Dmu: rdiff = %s korelacja = %s" #~ msgid "Dmu2: rdiff = %s cor = %s" #~ msgstr "Dmu2: rdiff = %s korelacja = %s" #~ msgid "Dmu3: rdiff = %s cor = %s" #~ msgstr "Dmu3: rdiff = %s korelacja = %s" #~ msgid "Dmu4: rdiff = %s cor = %s" #~ msgstr "Dmu4: rdiff = %s korelacja = %s" #~ msgid "Dmuth[%d]: rdiff = %s cor = %s" #~ msgstr "Dmuth[%d]: rdiff = %s korelacja = %s" #~ msgid "Dmu2th[%d]: rdiff = %s cor = %s" #~ msgstr "Dmu2th[%d]: rdiff = %s korelacja = %s" #~ msgid "Dmu3th[%d]: rdiff = %s cor = %s" #~ msgstr "Dmu3th[%d]: rdiff = %s korelacja = %s" #~ msgid "Dmu2th2[%d]: rdiff = %s cor = %s" #~ msgstr "Dmu2th2[%d]: rdiff = %s korelacja = %s" # mgcv/R/gam.sim.r: 31 # stop("distribution was not recognised") #~ msgid "distribution was not recognised" #~ msgstr "rozkład nie został rozpoznany" # mgcv/R/gam.sim.r: 35 # gettext("Bivariate smoothing example", domain = "R-mgcv") #~ msgid "Bivariate smoothing example" #~ msgstr "przykład dwuwymiarowego wygładzania" # mgcv/R/gam.sim.r: 50 # gettext("Continuous 'by' variable example", domain = "R-mgcv") #~ msgid "Continuous 'by' variable example" #~ msgstr "Przykład z ciągłą zmienną 'by'" # mgcv/R/gam.sim.r: 60 # gettext("Factor 'by' variable example", domain = "R-mgcv") #~ msgid "Factor 'by' variable example" #~ msgstr "Przykład ze zmienną czynnikową 'by'" # mgcv/R/gam.sim.r: 76 # gettext("Additive model + factor", domain = "R-mgcv") #~ msgid "Additive model + factor" #~ msgstr "Model addytywny + czynnik" # mgcv/R/gamm.r: 131 # warning("NA values in factor of class \"pdTens\"") #~ msgid "NA values in factor of class \"pdTens\"" #~ msgstr "wartości Na w czynniku klasy \"pdTens\"" # mgcv/R/gamm.r: 154 # warning("NA values in matrix of class \"pdTens\"") #~ msgid "NA values in matrix of class \"pdTens\"" #~ msgstr "wartości Na w macierzy klasy \"pdTens\"" # mgcv/R/gamm.r: 176 # gettext("Tensor product smooth term", domain = "R-mgcv") #~ msgid "Tensor product smooth term" #~ msgstr "człon wygładzania produktu tensorowego" # mgcv/R/gamm.r: 338 # stop("No data supplied to gamm.setup") # mgcv/R/gamm.r: 781 # stop("No data supplied to gamm.setup") #~ msgid "No data supplied to 'gamm.setup()'" #~ msgstr "Nie dostarczono danych do 'gamm.setup()'" # mgcv/R/gamm.r: 1506 # gettext("Maximum number of PQL iterations: ", domain = "R-mgcv") #~ msgid "Maximum number of PQL iterations:" #~ msgstr "Maksymalna liczba iteracji PQL:" # mgcv/R/gamm.r: 1746 # gettextf("TEST FAILED: fit.cor = %s",fit.cor, domain = "R-mgcv") #~ msgid "TEST FAILED: fit.cor = %s" #~ msgstr "TEST NIE POWIÓDŁ SIĘ: fit.cor = %s" # mgcv/R/gamm.r: 1747 # gettext("TEST FAILED: edf.diff = %s",edf.diff, domain = "R-mgcv") #~ msgid "TEST FAILED: edf.diff = %s" #~ msgstr "TEST NIE POWIÓDŁ SIĘ: edf.diff = %s" # mgcv/R/gamm.r: 1748 # gettext("TEST PASSED", domain = "R-mgcv") #~ msgid "TEST PASSED" #~ msgstr "TEST PRZESZEDŁ POMYŚLNIE" # mgcv/R/gamm.r: 1754 # gettext("testing covariate scale invariance ... ", domain = "R-mgcv") #~ msgid "testing covariate scale invariance ..." #~ msgstr "testowanie niezależności skali zmiennej objaśniającej ..." # mgcv/R/gamm.r: 1760 # gettext("testing invariance w.r.t. response ... ", domain = "R-mgcv") #~ msgid "testing invariance w.r.t. response ..." #~ msgstr "testowanie niezmienniczości ze względu na zmienną zależną ..." # mgcv/R/gamm.r: 1765 # gettext("testing equivalence of te(x) and s(x) ... ", domain = "R-mgcv") #~ msgid "testing equivalence of te(x) and s(x) ..." #~ msgstr "testowanie równoważności 'te(x)' oraz 's(x)' ..." # mgcv/R/gamm.r: 1770 # gettext("testing equivalence of gam and gamm with same sp ... ", domain = "R-mgcv") #~ msgid "testing equivalence of gam and gamm with same sp ..." #~ msgstr "testowanie równoważności 'gam' oraz 'gamm' z tym samym sp ..." # mgcv/R/mgcv.r: 561 # stop("No data supplied to gam.setup") #~ msgid "No data supplied to 'gam.setup()'" #~ msgstr "Nie dostarczono danych do 'gam.setup()'" mgcv/po/R-de.po0000644000176200001440000015277013461561644013001 0ustar liggesusers# Translation of R-mgcv.pot to German # Copyright (C) 2005-2019 The R Foundation # This file is distributed under the same license as the mgcv package. msgid "" msgstr "" "Project-Id-Version: R 3.6.0 / mgcv 1.8-28\n" "Report-Msgid-Bugs-To: bugs@r-project.org\n" "POT-Creation-Date: 2019-04-29 12:44\n" "PO-Revision-Date: 2019-04-02 13:37+0200\n" "Last-Translator: Detlef Steuer \n" "Language-Team: R-Core \n" "Language: de\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n != 1);\n" msgid "bam can not discretize with this nesting structure" msgstr "bam kann in dieser Schachtelungsstruktur nicht disketisieren" msgid "'family' argument seems not to be a valid family object" msgstr "'family' Argument scheint kein zulässiges family Objekt zu sein" msgid "This family should not have a matrix response" msgstr "Diese Familie sollte keine Matrix-Response haben" msgid "cannot find valid starting values: please specify some" msgstr "Kann keine gültigen Startwerte finden: Bitte geben Sie einige an" msgid "Deviance = %s Iterations - %d" msgstr "Devianz = %s Iterationen - %d" msgid "Non-finite deviance" msgstr "nicht-endliche Devianz" msgid "non-finite coefficients at iteration %d" msgstr "nicht-endliche Koeffizienten bei Iteration %d" msgid "algorithm did not converge" msgstr "Algorithmus hat nicht konvergiert" msgid "fitted probabilities numerically 0 or 1 occurred" msgstr "" "Es trat der Fall auf, dass die angepassten Wahrscheinlichkeiten numerisch 0 " "oder 1 waren" msgid "fitted rates numerically 0 occurred" msgstr "" "Es trat der Fall auf, dass die angepassten Quoten numerisch 0 oder 1 waren" msgid "Too many cluster nodes to use all efficiently" msgstr "Zu viele Cluster-Knoten, um alle effizient zu nutzen" msgid "iterms reset to terms" msgstr "iterms auf terms zurückgesetzt." msgid "exclude ignored by discrete prediction at present" msgstr "zur Zeit wird bei diskreter Prädiktion exclude ignoriert" msgid "family not recognized" msgstr "family nicht erkannt" msgid "un-supported smoothness selection method" msgstr "nicht unterstützte Methode zur Glattheitswahl" msgid "discretization only available with fREML" msgstr "Diskretisierung nur mit fREML verfügbar" msgid "discrete method does not use parallel cluster - use nthreads instead" msgstr "" "diskrete Methode nutzt keinen parallelen Cluster - nutze besser nthreads" msgid "openMP not available: single threaded computation only" msgstr "openMP nicht verfügbar: nur single thread Berechnungen" msgid "min.sp not supported with fast REML computation, and ignored." msgstr "" "min.sp wird bei schneller REML Berechnung nicht unterstützt und ignoriert." msgid "no smooths, ignoring `discrete=TRUE'" msgstr "keine Glätten, ignoriere 'discrete=TRUE'" msgid "Not enough (non-NA) data to do anything meaningful" msgstr "Nicht genug (nicht-NA-) Daten, um etwas Sinnvolles zu tun" msgid "AR.start must be logical" msgstr "AR.start muss logisch sein" msgid "chunk.size < number of coefficients. Reset to %d" msgstr "chunk.size < number of coefficients. Zurückgesetzt auf %d" msgid "unknown tensor constraint type" msgstr "unbekannte Typ von Tensor-Einschränkungen" msgid "Model has more coefficients than data" msgstr "Modell hat mehr Koeffizienten als Daten" #, fuzzy msgid "" "length of sp must be number of free smoothing parameters in original model" msgstr "" "falsche Anzahl von Glättungsparametern an einen Glättungsterm übergeben" msgid "general families not supported by bam" msgstr "allgemeine Familien nicht von bam unterstützt" msgid "AR1 parameter rho unused with generalized model" msgstr "AR1 Parameter rho unbenutzt im verallgemeinerten Modell" msgid "samfrac too small - ignored" msgstr "samfrac zu klein - ignoriert" msgid "Model can not be updated" msgstr "Modell kann nicht aktualisiert werden" msgid "link not available for coxph family; available link is \"identity\"" msgstr "" "Link nicht verfügbar für die coxph Familie; \"identity\" Link ist verfügbar" msgid "something wrong with stratified prediction" msgstr "etwas stimmt nicht mit stratifizierter Vorhersage" msgid "NA times supplied for cox.ph prediction" msgstr "NA Zeiten für die coxph Vorhersage angegeben" msgid "not an extended family" msgstr "keine erweiterte Familie" msgid "erroneous call to estimate.theta - no free parameters" msgstr "" msgid "step failure in theta estimation" msgstr "Schritt Fehlgeschlagen in der Schätzung von theta" msgid "" "link not available for ordered categorical family; available links are " "\"identity\"" msgstr "" "Link nicht verfügbar für die angeordnete kategorielle Familie; \"identity\" " "Link ist verfügbar" msgid "Must supply theta or R to ocat" msgstr "theta oder R müssen an ocat übergeben werden" msgid "Response should be integer class labels" msgstr "Antwort sollten ganzzahlige Klassenlabel sein" msgid "values out of range" msgstr "Werte außerhalb des zulässigen Bereichs" msgid "" "link not available for negative binomial family; available links are " "\"identity\", \"log\" and \"sqrt\"" msgstr "" "Link nicht verfügbar für die negativ-binomial-Familie; verfügbare\n" "Links sind \"identity\", \"log\", und \"sqrt\"" msgid "negative values not allowed for the negative binomial family" msgstr "negative Werte sind bei der negativ-binomial-Familie unzulässig" msgid "link \"%s\" not available for Tweedie family." msgstr "Link \"%s\" nicht verfügbar für die Tweedie-Familie" msgid "Tweedie p must be in interval (a,b)" msgstr "Tweedie p muss aus dem Intervall (a, b) sein" msgid "" "link not available for beta regression; available links are \"logit\", " "\"probit\", \"cloglog\" and \"cauchit\"" msgstr "" "Link nicht verfügbar für die beta Regression; verfügbare Links sind \"logit" "\", \"probit\", \"cloglog\" und \"cauchit\"" msgid "saturated likelihood may be inaccurate" msgstr "saturierte Likelihood kann ungenau sein" msgid "" "link not available for scaled t distribution; available links are \"identity" "\", \"log\", and \"inverse\"" msgstr "" "Link nicht verfügbar für die skalierte t-Verteilung; verfügbare Links sind " "\"identity\", \"log\" und \"inverse\"" msgid "Supplied df below min.df. min.df reset" msgstr "Angegebenens df unter min.df. min.df zurückgesetzt" msgid "NA values not allowed for the scaled t family" msgstr "NA Werte für die skalierte t-Verteilung nicht zulässig" msgid "" "link not available for zero inflated; available link for `lambda' is only " "\"loga\"" msgstr "" "Link nicht verfügbar für Null-Inflation; einziger verfügbarer Link für " "'lambda' ist \"loga\"" msgid "negative values not allowed for the zero inflated Poisson family" msgstr "" "negative Werte nicht zulässig für die null-inflationierte Poisson-Familie" msgid "Non-integer response variables are not allowed with ziP" msgstr "" "Nicht-ganzzahlige Antwortvariablen nicht zulässig bei null-inflationierter " "Poisson-Verteilung" msgid "Using ziP for binary data makes no sense" msgstr "" "Für binäre Daten macht Gebrauch null-inflationierter Poisson-Verteilung " "keinen Sinn" msgid "Possible divergence detected in fast.REML.fit" msgstr "Mögliche Divergenz entdeckt in fast.REML.fit" msgid "fast REML optimizer reached iteration limit" msgstr "schneller REML Optimierer erreichte max. Iterationszahl" msgid "unsupported order of differentiation requested of gam.fit3" msgstr "nicht unterstützte Ordnung der Ableitung für gam.fit3 gefordert" msgid "illegal `family' argument" msgstr "unerlaubtes 'family'-Argument" # http://de.wikipedia.org/wiki/Prädiktor msgid "Invalid linear predictor values in empty model" msgstr "Ungültige Werte des linearen Prädiktors in leerem Modell" msgid "Invalid fitted means in empty model" msgstr "Ungültige angepasste Mittelwerte in leerem Modell" msgid "Length of start should equal %d and correspond to initial coefs for %s" msgstr "" "Länge von start sollte gleich %d sein und mit den initialen Koeffizienten " "für %s korrespondieren" msgid "Can't find valid starting values: please specify some" msgstr "" "Es wurden keine gültigen Startwerte gefunden: Bitte geben Sie einige an" msgid "NAs in V(mu)" msgstr "NAs in V(mu)" msgid "0s in V(mu)" msgstr "0s in V(mu)" msgid "NAs in d(mu)/d(eta)" msgstr "NAs in d(mu)/d(eta)" msgid "No observations informative at iteration %d" msgstr "Keine informativen Beobachtungen bei Iteration %d" msgid "Not enough informative observations." msgstr "Nicht genug informative Beobachtungen." msgid "Non-finite coefficients at iteration %d" msgstr "Nicht-endliche Koeffizienten bei Iteration %d" msgid "" "no valid set of coefficients has been found:please supply starting values" msgstr "" "es wurde keine gültige Menge von Koeffizienten gefunden: Bitte stellen Sie " "Startwerte bereit" msgid "Step size truncated due to divergence" msgstr "Schrittweite wurde wegen Divergenz reduziert" msgid "inner loop 1; can't correct step size" msgstr "innere Schleife 1; Schrittweite kann nicht korrigiert werden" msgid "Step size truncated: out of bounds" msgstr "Schrittweite verkleinert: Außerhalb der Begrenzung" msgid "inner loop 2; can't correct step size" msgstr "innere Schleife 2; Schrittweite kann nicht korrigiert werden" msgid "penalized deviance = %s" msgstr "penalisierte Devianz = %s" msgid "inner loop 3; can't correct step size" msgstr "innere Schleife 3; Schrittweite kann nicht korrigiert werden" msgid "Step halved: new penalized deviance = %g" msgstr "Schrittweite halbiert: neue penalisierte Devianz = %g" msgid "" "Non finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam." "contol'" msgstr "" "Unendliche Ableitungen. Versuchen Sie die Anpassungstoleranz zu reduzieren! " "Siehe 'epsilon' in 'gam.control'" msgid "" "Non-finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam." "contol'" msgstr "" "Unendliche Ableitungen. Versuchen Sie die Anpassungstoleranz zu reduzieren! " "Siehe 'epsilon' in 'gam.control'" msgid "Algorithm did not converge" msgstr "Algorithmus konvergierte nicht" msgid "Algorithm stopped at boundary value" msgstr "Algorithmus stoppte beim Randwert" msgid "deriv should be 1 or 2" msgstr "deriv sollte 1 oder 2 sein" msgid "L must be a matrix." msgstr "L muss eine Matrix sein." msgid "L must have at least as many rows as columns." msgstr "L muss mindestens so viele Zeilen wie Spalten haben." msgid "L has inconsistent dimensions." msgstr "L hat inkonsistente Dimensionen." msgid "Fitting terminated with step failure - check results carefully" msgstr "" "Anpassung beendet mit Schrittweitenfehler - Ergebnisse sorgfältig prüfen" msgid "Iteration limit reached without full convergence - check carefully" msgstr "Iterationsgrenze erreicht ohne volle Konvergenz -- sorgfältig prüfen" msgid "link not implemented for extended families" msgstr "Link nicht implementiert für erweiterte Familien" msgid "fam not a family object" msgstr "fam ist kein family-Objekt" msgid "unrecognized (vector?) link" msgstr "unerkannter (Vektor?) Verweis" msgid "link not recognised" msgstr "Verweis nicht erkannt" msgid "variance function not recognized for quasi" msgstr "Varianzfunktion für quasi nicht erkannt" # R/gam.fit3.r msgid "family not recognised" msgstr "family nicht erkannt" msgid "'theta' must be specified" msgstr "'theta' muss angegeben werden" msgid "" "%s link not available for negative binomial family; available links are " "\"identity\", \"log\" and \"sqrt\"" msgstr "" "%s Link nicht verfügbar für die negativ-binomial-Familie; verfügare Links " "sind \"identity\", \"log\" und \"sqrt\"" msgid "H has wrong dimension" msgstr "H hat falsche Dimension" msgid "only scalar `rho' and `theta' allowed." msgstr "Nur skalare 'rho' und 'theta' erlaubt." msgid "1 0" msgstr "Wert von epsilon muss > 0 sein" msgid "maximum number of iterations must be > 0" msgstr "maximale Anzahl der Iterationen muss > 0 sein" msgid "" "silly value supplied for rank.tol: reset to square root of machine precision." msgstr "" "dummer Wert für rank.tol angegeben: Wird auf Quadratwurzel der " "Maschinenpräzision zurückgesetzt." msgid "Model seems to contain no terms" msgstr "Modell scheint keine Terme zu enthalten" msgid "Discrete Theta search not available with performance iteration" msgstr "Diskrete Theta-Suche nicht mit Leistungsiteration verfügbar" # http://de.wikipedia.org/wiki/Transferfunktionsmodell msgid "y must be univariate unless binomial" msgstr "Y muss univariat sein, falls nicht binomisch" msgid "Length of start should equal %d and correspond to initial coefs." msgstr "" "Länge von start sollte %d sein und mit den initialen Koeffizienten " "korrespondieren" msgid "" "iterative weights or data non-finite in gam.fit - regularization may help. " "See ?gam.control." msgstr "" "iterative Gewichte oder nicht-endliche Daten in gam.fit - Regularisierung " "könnte helfen. Siehe ?gam.control." msgid "Step size truncated: out of bounds." msgstr "Schrittgröße verkleinert: Außerhalb der Begrenzungen." msgid "`object' is not of class \"gam\"" msgstr "'object' ist nicht aus der Klasse \"gam\"" msgid "unrecognised na.action" msgstr "unerkannter ba.action" msgid "na.action not character or function" msgstr "na.action ist weder Zeichenkette noch Funktion" msgid "Smoothness uncertainty corrected covariance not available" msgstr "Glattheitsunsicherheits-korrigierte Kovarianz ist nicht verfügbar" msgid "Unknown type, reset to terms." msgstr "Unbekannter Typ, wird auf terms zurückgesetzt." msgid "predict.gam can only be used to predict from gam objects" msgstr "" "predict.gam kann nur benutzt werden, um auf Basis von gam-Objekten " "vorherzusagen" msgid "newdata is a model.frame: it should contain all required variables" msgstr "" "newdata ist ein model.frame: Es soll alle benötigten Variablen enthalten" msgid "no NAs allowed in response data for this model" msgstr "keine NAs als Daten in diesem Modell erlaubt" msgid "not all required variables have been supplied in newdata!" msgstr "nicht alle benötigten Variablen wurden in newdata angegeben!" msgid "type iterms not available for multiple predictor cases" msgstr "Typ iterms ist für den Fall multipler Prädiktoren nicht verfügbar" msgid "non-existent terms requested - ignoring" msgstr "nicht existierende Terme angefordert - wird ignoriert" msgid "non-existent exclude terms requested - ignoring" msgstr "nicht existierende Ausschluss-Terme angefordert - wird ignoriert" msgid "requires an object of class gam" msgstr "verlangt ein Objekt der Klasse gam" msgid "nothing to do for this model" msgstr "nichts zu tun für dieses Modell" msgid "" "Pearson residuals not available for this family - returning deviance " "residuals" msgstr "" "Pearson-Residuen für diese Familie nicht verfügbar - geben Devianz-Residuen " "zurück" msgid "lambda and h should have the same length!" msgstr "lambda und h sollten die selbe Länge haben!" msgid "recov works with fitted gam objects only" msgstr "recov funktioniert nur bei gefitteten gam Objekten" msgid "m can't be in re" msgstr "m kann nicht in re sein" msgid "" "p-values for any terms that can be penalized to zero will be unreliable: " "refit model to fix this." msgstr "" "Die p-Werte für einen Term, der auf Null bestraft werden kann, sind " "unzuverlässig: Modell wird neu angepasst, um dies zu korrigieren." msgid "The following arguments to anova.glm(..) are invalid and dropped:" msgstr "Die folgenden Argumente für anova.glm(..) sind ungültig und entfallen:" msgid "," msgstr "," msgid "un-supported test" msgstr "nicht unterstützter Test" msgid "test argument ignored" msgstr "Argument test ignoriert" msgid "anova.gam called with non gam object" msgstr "anova.gam mit einem nicht-gam-Objekt aufgerufen" msgid "not a gam object" msgstr "kein gam Objekt" msgid "argument is not a gam object" msgstr "Argument ist kein gam Objekt" msgid "S.scale vector doesn't match S list - please report to maintainer" msgstr "" "S.scale Vektor passt nicht zu S Liste - bitte den Maintainer informieren!" msgid "Supplied matrix not symmetric" msgstr "Angegebene Matrix nicht symmetrisch" msgid "singular values not returned in order" msgstr "Singulärwerte wurden nicht sortiert zurückgeliefert" msgid "Something wrong - matrix probably not +ve semi definite" msgstr "Etwas stimmt nicht - Matrix wahrscheinlich nicht +ve halb definit" msgid "method not recognised." msgstr "Methode nicht erkannt." msgid "S[[%d]] matrix is not +ve definite." msgstr "S[[%d]] Matrix ist nicht +ve definit." msgid "dimensions of supplied w wrong." msgstr "Dimensionen des angegebenen w sind falsch." msgid "w different length from y!" msgstr "w hat eine von y verschiedene Länge!" msgid "X lost dimensions in magic!!" msgstr "X verlor Dimensionen in magic!!" msgid "mu dimensions wrong" msgstr "mu Dimensionen falsch" msgid "something wrong with inputs to LAPACK routine" msgstr "Etwas ist falsch mit den Eingaben für LAPACK routine" msgid "not positive definite" msgstr "nicht positiv definit" msgid "don't be silly" msgstr "sei nicht dumm" msgid "sd should have exactly one less entry than ld" msgstr "sd sollte genau eins kleiner sein als ld" #, fuzzy msgid "update not positive definite" msgstr "nicht positiv definit" msgid "internal error in vcorr, please report to simon.wood@r-project.org" msgstr "interner Fehler in vcorr, bitte an simon.wood@r-project.org melden" msgid "a has wrong number of rows" msgstr "a hat die falsche Zeilenzahl" msgid "mvn requires 2 or more dimensional data" msgstr "mvn benötigt zwei- oder höherdimensionale Daten" msgid "mvn does not yet handle offsets" msgstr "mvn kann noch nicht mit Offsets umgehen" msgid "mvn dimension error" msgstr "mvn Dimensionsfehler" msgid "non-integer binomial denominator: quantiles incorrect" msgstr "" msgid "object is not a glm or gam" msgstr "Obejekt ist weder glm noch gam" msgid "names of z and pc must match" msgstr "Namen von z und pc müssen übereinstimmen" msgid "" "Partial residuals do not have a natural x-axis location for linear " "functional terms" msgstr "" "Partielle Residuen haben keine natürliche x-Achsen Lage für lineare " "funktionale Ausdrücke" msgid "no automatic plotting for smooths of more than two variables" msgstr "" "keine automatische Darstellung für Glättungen von mehr als zwei Variablen" msgid "no automatic plotting for smooths of more than four variables" msgstr "" "keine automatische Darstellung für Glättungen von mehr als vier Variablen" msgid "argument pers is deprecated, please use scheme instead" msgstr "Argument pers ist veraltet, bitte stattdessen scheme nutzen" msgid "residuals argument to plot.gam is wrong length: ignored" msgstr "Residuen-Argument für plot.gam hat falsche Länge: Ignoriert" msgid "No variance estimates available" msgstr "Keine Varianzschätzungen verfügbar" msgid "No terms to plot - nothing for plot.gam() to do." msgstr "Keine Terme zum Darstellen - nichts für plot.gam() zu tun." msgid "grid vectors are different lengths" msgstr "Gittervektoren haben unterschiedliche Längen" msgid "data vectors are of different lengths" msgstr "Datenvektoren haben unterschiedliche Längen" msgid "supplied dist negative" msgstr "angegebene Entfernung negativ" msgid "Model does not seem to have enough terms to do anything useful" msgstr "Modell scheint nicht genug Terme zu haben, um etwas Nützliches zu tun" msgid "view variables must be one of %s" msgstr "Die view Variablen müssen aus %s gewählt werden" msgid "" "Don't know what to do with parametric terms that are not simple numeric or " "factor variables" msgstr "" "Weiß nichts anzufangen mit parametrischen Ausdrücken, die weder einfach " "numerisch noch Faktorvariablen sind" msgid "View variables must contain more than one value. view = c(%s,%s)." msgstr "View-Variablen müssen mehr als einen Wert enthalten. view = c(%s,%s)" msgid "type must be \"link\" or \"response\"" msgstr "Typ muss 'link' oder 'response' sein" msgid "Something wrong with zlim" msgstr "Etwas stimmt nicht mit zlim" msgid "color scheme not recognised" msgstr "Farbschema nicht erkannt" msgid "sorry no option for contouring with errors: try plot.gam" msgstr "" "Entschuldigung. Keine Option für Formgebung mit Fehlern: Versuchen Sie plot." "gam" msgid "At least three knots required in call to mono.con." msgstr "Mindestens drei Knoten im Aufruf von mono.con benötigt." msgid "lower bound >= upper bound in call to mono.con()" msgstr "untere Grenze >= obere Grenze im Aufruf von mono.con()" msgid "x is null" msgstr "x ist Null" msgid "uniquecombs has not worked properly" msgstr "uniquecombs hat nicht richtig gearbeitet" msgid "order too low" msgstr "Ordnung zu klein" msgid "too few knots" msgstr "zu wenige Knoten" msgid "x out of range" msgstr "x außerhalb des Wertebereichs" msgid "something wrong with argument d." msgstr "etwas stimmt nicht mit Argument d." msgid "one or more supplied k too small - reset to default" msgstr "" "ein oder mehrere bereitgestellte k zu klein - wird auf Standard zurückgesetzt" msgid "dimension of fx is wrong" msgstr "Dimension von fx ist falsch" msgid "xt argument is faulty." msgstr "xt-Argument ist fehlerhaft." msgid "bs wrong length and ignored." msgstr "bs hat falsche Länge und wird ignoriert." msgid "m wrong length and ignored." msgstr "m hat falsche Länge und wird ignoriert." msgid "Repeated variables as arguments of a smooth are not permitted" msgstr "Wiederholte Variablen als Argumente einer Glättung sind nicht erlaubt" msgid "only first element of `id' used" msgstr "nur das erste Element von 'id' wird genutzt" msgid "supply a value for each variable for a point constraint" msgstr "bitte für jede Variable einen Wert angeben bei Punktbeschränkungen" msgid "ord is wrong. reset to NULL." msgstr "ord ist falsch, wird auf NULL zurückgesetzt" msgid "ord contains out of range orders (which will be ignored)" msgstr "" "ord enthält Ordungen außerhalb des Wertebereichs (die ignoriert werden)" msgid "by=. not allowed" msgstr "by=. nicht erlaubt" msgid "s(.) not supported." msgstr "s(.) wird nicht unterstützt." msgid "s(.) not yet supported." msgstr "s(.) wird noch nicht unterstützt." msgid "argument k of s() should be integer and has been rounded" msgstr "Argument k von s() sollte ganzzahlig sein und wurde gerundet" msgid "attempt to use unsuitable marginal smooth class" msgstr "Versuch unpassende Randglätterklasse zu nutzen" msgid "" "Sorry, tensor products of smooths with multiple penalties are not supported." msgstr "" "Sorry, Tensorprodukte von Glättern mit multiplen Strafen werden nicht " "unterstützt." msgid "reparameterization unstable for margin: not done" msgstr "Reparametrisierung für den Rand instabil: nicht durchgeführt" msgid "basis not usable with reduced te" msgstr "Basis nicht nutzbar mit reduziertem te" msgid "fx length wrong from t2 term: ignored" msgstr "falsche Länge für fx aus dem t2 Ausdruck: wird ignoriert" msgid "length of sp incorrect in t2: ignored" msgstr "falsche Länge für sp in t2: wird ignoriert" msgid "d can not be negative in call to null.space.dimension()." msgstr "d kann im Aufruf von null.space.dimension() nicht negativ sein." msgid "arguments of smooth not same dimension" msgstr "Argumente der Glättung haben nicht dieselbe Dimension" msgid "components of knots relating to a single smooth must be of same length" msgstr "" "Komponenten der Knoten, die sich auf eine einzige Glättung beziehen, müssen " "die gleiche Länge haben" msgid "more knots than data in a tp term: knots ignored." msgstr "mehr Knoten als Daten in einem tp-Term: Knoten ignoriert." msgid "basis dimension, k, increased to minimum possible" msgstr "Basisdimension, k, erhöht auf mögliches Minimum" msgid "no data to predict at" msgstr "keine Daten zum Vorausberechnen von" msgid "Basis only handles 1D smooths" msgstr "Basis arbeitet nur mit 1D-Glättungen" msgid "number of supplied knots != k for a cr smooth" msgstr "Anzahl der angegebenen Knoten != k für eine cr-Glättung" msgid "F is missing from cr smooth - refit model with current mgcv" msgstr "F fehlt im cr-Glätter - Modell wird mit aktuellem mgcv neu angepasst" msgid "more knots than unique data values is not allowed" msgstr "mehr Knoten als einheitliche Datenwerte sind nicht erlaubt" msgid "number of supplied knots != k for a cc smooth" msgstr "Anzahl der angegebenen Knoten != k für eine cc-Glättung" msgid "basis dimension too small for b-spline order" msgstr "Basisdimension zu klein für die b-Spline Ordnung" msgid "knot range does not include data" msgstr "Bereich der Knoten enthält keine Daten" msgid "there should be" msgstr "da sollten sein" msgid "supplied knots" msgstr "angegebene Knoten" msgid "knots supplied" msgstr "Knoten angegeben" msgid "" "knot range is so wide that there is *no* information about some basis " "coefficients" msgstr "" "Knotenbereich ist so weit, dass er *keine* Information über einige " "Basiskoeffizienten enthält. " msgid "penalty order too high for basis dimension" msgstr "Straftermordnung zu groß für die Basisdimension" msgid "there is *no* information about some basis coefficients" msgstr "es gibt *keine* Information über einige Basiskoeffizienten enthält" msgid "basis dimension is larger than number of unique covariates" msgstr "" "Basisdimension ist größer als die Zahl der unterschiedlichen Kovariaten" msgid "multiple penalties of the same order is silly" msgstr "mehrere Strafterme derselben Ordnung ist nichtsnutzig" msgid "requested non-existent derivative in B-spline penalty" msgstr "nicht exisitierened Ableitung im B-Spline Strafterm angefordert" msgid "fs smooths can only have one factor argument" msgstr "fs-Glätter können nur ein Faktorargument haben" msgid "\"fs\" smooth cannot use a multiply penalized basis (wrong basis in xt)" msgstr "" "\"fs\" Glätter kann keine mehrfach bestrafte Basis nutzen (falsche Basis\n" "in xt)" msgid "no factor supplied to fs smooth" msgstr "Kein Faktor angegeben für fs Glättung" msgid "\"fs\" terms can not be fixed here" msgstr "\"fs\" Ausdrücke können nicht hier festgelegt werden" msgid "" "fs smooth not suitable for discretisation with more than one metric predictor" msgstr "" "fs Glättung passt nicht bei Diskretisierung mit mehr als einem metrischen " "Prädiktor" msgid "the adaptive smooth class is limited to 1 or 2 covariates." msgstr "Die adaptive Glätterklasse ist beschränkt auf 1 oder 2 Kovariaten." msgid "penalty basis too large for smoothing basis" msgstr "Straftermbasis ist zu groß für die Glättungsbasis" msgid "penalty basis too small" msgstr "Straftermordnung zu klein" msgid "random effects don't work with ids." msgstr "zufällige Effekte arbeiten nicht mit ids" msgid "" "Please put term with most levels last in 're' to avoid spoiling supplied " "penalties" msgstr "" "Bitte den Term mit den meisten Stufen auf die letzte Stellung in 're' " "setzen, um die angegebenen Strafterme nicht zu beschädigen" msgid "supplied S matrices are wrong diminsion" msgstr "Angegebene S Matrix hat falsche Dimension!" msgid "argument of mrf should be a factor variable" msgstr "Argument von mrf sollte eine Faktorvariable sein" msgid "MRF basis dimension set too high" msgstr "MRF Basisdimension ist zu hoch gesetzt" msgid "data contain regions that are not contained in the knot specification" msgstr "" "Daten enthalten Gebiete, die nicht in der Knotenspezifikation enthalten sind" msgid "" "penalty matrix, boundary polygons and/or neighbours list must be supplied in " "xt" msgstr "" "Straftermmatrix, Grenzpolygone und/oder die Nachbarliste muss in xt " "angegeben werden" msgid "no spatial information provided!" msgstr "keine räumliche Information angegeben!" msgid "mismatch between nb/polys supplied area names and data area names" msgstr "area names aus nb/poly und Daten passen nicht zusammen" msgid "Something wrong with auto- penalty construction" msgstr "Etwas stimmt nicht mit der automatischen Straftermkonstruktion" msgid "supplied penalty not square!" msgstr "angegebener Strafterm nicht quadratisch!" msgid "supplied penalty wrong dimension!" msgstr "Angegebener Strafterm hat falsche Dimension!" msgid "penalty column names don't match supplied area names!" msgstr "Straftermspaltennamen passen nicht zu den angegebenen area names!" msgid "Can only deal with a sphere" msgstr "Kann nur mit einer Sphäre umgehen" msgid "more knots than data in an sos term: knots ignored." msgstr "mehr Knoten als Daten in einem sos Term: Knoten ignoriert." msgid "more knots than data in a ds term: knots ignored." msgstr "mehr Knoten als Daten in einem ds Term: Knoten ignoriert." msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" "Ein Ausdruck hat weniger eindeutige Kombinationen von Kovariaten als die " "angegebene maximale Zahl von Freiheitsgraden" msgid "s value reduced" msgstr "s Wert reduziert" msgid "s value increased" msgstr "s Wert erhöht" msgid "No suitable s (i.e. m[2]) try increasing m[1]" msgstr "Kein passendes s (z.B. m[2]), versuche m[1] zu erhöhen" msgid "s value modified to give continuous function" msgstr "S Wert verändert, um eine stetige Funktion zu erhalten" msgid "basis dimension reset to minimum possible" msgstr "Basisdimension auf mögliches Minimum zurückgesetzt" msgid "incorrect arguments to GP smoother" msgstr "Falsche Argumente für den GP Glätter" msgid "more knots than data in an ms term: knots ignored." msgstr "mehr Knoten als Daten in einem ms Term: Knoten ignoriert." msgid "smooth objects should not have a qrc attribute." msgstr "Glättungsobjekte sollten kein qrc-Attribut haben" msgid "unimplemented sparse constraint type requested" msgstr "nicht implementierter dünn besetzter Nebenbedingungstyp verlangt" msgid "" "handling `by' variables in smooth constructors may not work with the " "summation convention" msgstr "" "die Handhabung von 'by' Variablen in der Glättungskonstruktion funktioniert " "evtl. nicht mit der Summationskonvention" msgid "Can't find by variable" msgstr "Kann nicht über Variable gefunden werden" msgid "" "sweep and drop constraints unlikely to work well with self handling of by " "vars" msgstr "" "\"sweep and drop\" Randbedingungen arbeiten wahrscheinlich nicht gut mit dem " "\"self handling\" durch vars" msgid "factor `by' variables can not be used with matrix arguments." msgstr "" "Faktor-'by'-Variablen können nicht mit Matrixargumenten benutzt werden." msgid "`by' variable must be same dimension as smooth arguments" msgstr "" "'by'-Variable muss die gleiche Dimension wie die Glättungsargumente haben" msgid "Number of prediction and fit constraints must match" msgstr "" "Anzahl der Restriktionen für Vorhersage und Anpassung müssen übereinstimmen" msgid "x and y must be same length" msgstr "x und y müssen gleich lang sein" msgid "variable names don't match boundary names" msgstr "Variablennamen passen nicht zu Begrenzungsnamen" msgid "x and y not same length" msgstr "x und y sind nicht gleich lang" msgid "bnd must be a list." msgstr "bnd muss eine Liste sein" msgid "lengths of k and bnd are not compatible." msgstr "Längen von k und bnd sind nicht kompatibel" msgid "attempt to select non existent basis function" msgstr "Versuch nicht exisitierende Basisfunktionen zu wählen" msgid "coefficient vector wrong length" msgstr "Koeffizientenvektor hat falsche Länge" msgid "knots must be specified for soap" msgstr "Knoten müssen für soap spezifiziert werden" msgid "soap films are bivariate only" msgstr "soap films nur für bivariaten Fall" msgid "need at least one interior knot" msgstr "mindestens ein Knoten im Inneren nötig" msgid "can't soap smooth without a boundary" msgstr "soap Glätter braucht Grenze" msgid "bnd must be a list of boundary loops" msgstr "bnd muss eine Liste von Grenz-Schleifen sein" msgid "faulty bnd" msgstr "fehlerhaftes bnd" msgid "k and bnd lengths are inconsistent" msgstr "Längen von k und bnd sind inkonsistent" msgid "data outside soap boundary" msgstr "Daten außerhalb der soap Grenze" msgid "no free coefs in sf smooth" msgstr "keine freien Koeffizienten in sf-Glättung" msgid "only deals with 2D case" msgstr "behandelt nur den 2D Fall" msgid "not enough unique values to find k nearest" msgstr "nicht genug eindeutige Werte um die k nächsten zu finden" msgid "cubic spline only deals with 1D data" msgstr "kubische Splines behandeln nur 1D Daten" msgid "object not fully initialized" msgstr "Objekt nicht voll initialisiert" #~ msgid "discretization can not handle smooth ids" #~ msgstr "Diskretisierung kann glatte ids nicht behandeln" #~ msgid "cox.ph does not yet handle offsets" #~ msgstr "cox.ph kann mit offsets nicht umgehen" #~ msgid "scaled t df must be > min.df" #~ msgstr "skalierte t df müssen > min.df sein" #~ msgid "Extended Fellner Schall only implemented for general families" #~ msgstr "" #~ "Erweiterter Fellner Schall nur für allgemeine Familien implementiert" #~ msgid "p-values may give low power in some circumstances" #~ msgstr "p-Werte können unter Umständen geringere Power geben" #~ msgid "p-values un-reliable" #~ msgstr "p-Werte unzuverlässig" #~ msgid "p-values may give very low power" #~ msgstr "p-Werte geben evtl. sehr geringe Power" #~ msgid "p.type!=0 is deprecated, and liable to be removed in future" #~ msgstr "p.type!=0 ist veraltet und wird in der Zukunft entfernt" #~ msgid "no automatic plotting for smooths of more than one variable" #~ msgstr "" #~ "keine automatische Darstellung für Glättungen von mehr als einer Variable" #~ msgid "" #~ "single penalty tensor product smooths are deprecated and likely to be " #~ "removed soon" #~ msgstr "" #~ "Tensorprodukt-Glätter mit einfachem Strafterm sind veraltet und werden " #~ "wahrscheinlich bald entfernt" #~ msgid "non-finite coefficients at iteration" #~ msgstr "nicht-endliche Koeffizienten bei Iteration" #~ msgid "sparse=TRUE not supported with fast REML, reset to REML." #~ msgstr "" #~ "sparse=TRUE nicht unterstützt bei schneller REML, rückgesetzt auf REML" #~ msgid "model matrix too dense for any possible benefit from sparse" #~ msgstr "" #~ "Modellmatrix zu dicht besetzt um von Behandlung als dünn besetzt zu " #~ "profitieren" #~ msgid "AR1 parameter rho unused with sparse fitting" #~ msgstr "AR1 Parameter rho bei sparse fitting unbenutzt" #~ msgid "Pearson scale estimate maybe unstable. See ?gam.scale." #~ msgstr "Pearson Skalenschätzung evtl. instabil. Siehe ?gam.scale." #~ msgid "" #~ "`negbin' with unknown theta and outer iteration is deprecated - use `nb'." #~ msgstr "" #~ "'negbin' mit unbekanntem theta und äußeren Iterationen ist veraltet - " #~ "bitte 'nb' nutzen" #~ msgid "nlm.fd not available with negative binomial Theta estimation" #~ msgstr "nlm.fd nicht verfügbar bei der negativ-binomialen Theta-Schätzung" #~ msgid "" #~ "only outer methods `newton' & `bfgs' supports `negbin' family and theta " #~ "selection: reset" #~ msgstr "" #~ "nur die äußere Methoden 'newton' & 'bfgs' unterstützen 'negbin'-Familie " #~ "und theta-Auswahl: Wird zurückgesetzt" #~ msgid "sorry, general families currently ignore offsets" #~ msgstr "sorry, allgemeine Familien ignorieren momentan Offsets" # R/smooth.r #~ msgid "x has no row attribute" #~ msgstr "x hat kein Zeilenattribut" #~ msgid "x has no col attribute" #~ msgstr "x hat kein Spaltenattribut" #~ msgid "" #~ "NA's passed to eig: please email Simon.Wood@R-project.org with details" #~ msgstr "" #~ "NAs an eig übergeben: Bitte E-Mail mit Details an Simon.Wood@R-project." #~ "org senden." #~ msgid "" #~ "NA eigenvalues returned by eigen: please email Simon.Wood@R-project.org " #~ "with details" #~ msgstr "" #~ "NA-Eigenwerte von eigen zurückgegeben: Bitte E-Mail mit Details an Simon." #~ "Wood@R-project.org senden." #~ msgid "" #~ "NA's in eigenvectors from eigen: please email Simon.Wood@R-project.org " #~ "with details" #~ msgstr "" #~ "NAs in Eigenvektoren von eigen: Bitte E-Mail mit Details an Simon.Wood@R-" #~ "project.org senden." #~ msgid "" #~ "NA singular values returned by svd: please email Simon.Wood@R-project.org " #~ "with details" #~ msgstr "" #~ "NA-Singulärwerte von svd zurückgegeben: Bitte E-Mail mit Details an Simon." #~ "Wood@R-project.org senden." #~ msgid "" #~ "NA's in singular vectors from svd: please email Simon.Wood@R-project.org " #~ "with details" #~ msgstr "" #~ "NAs in Singulärvektoren von svd: Bitte E-Mail mit Details an Simon.Wood@R-" #~ "project.org senden." #~ msgid "" #~ "NA problem resolved using svd, but please email Simon.Wood@R-project.org " #~ "anyway" #~ msgstr "" #~ "NA-Problem durch Benutzen von svd gelöst, aber bitte trotzdem eine E-Mail " #~ "an Simon.Wood@R-project.org sendne." #~ msgid "Problem with linear algebra routines." #~ msgstr "Problem mit linearen Algebra-Routinen." #~ msgid "gamm() requires package nlme to be installed" #~ msgstr "gamm() benötigt nlme, um installiert zu werden" #~ msgid "gamm() requires package MASS to be installed" #~ msgstr "gamm() benötigt das Paket MASS, um installiert zu werden" #~ msgid "M$S[" #~ msgstr "M$S[" #~ msgid "]" #~ msgstr "]" #~ msgid "Can't mix fixed and estimated penalties in mgcv() - use magic()" #~ msgstr "" #~ "Feste und geschätzte Strafen in mgcv() können nicht gemischt werden - " #~ "benutzen Sie magic()" #~ msgid "meaninglessly low k; reset to 2" #~ msgstr "bedeutungslos niedriges k; wird auf 2 zurückgesetzt" #~ msgid "can't predict outside range of knots with periodic smoother" #~ msgstr "" #~ "es kann nicht außerhalb des Bereichs von Knoten mit periodischem Glätter " #~ "vorausberechnet werden" #~ msgid "supplied sp has wrong length" #~ msgstr "angegebener sp hat falsche Länge" #~ msgid "supplied min.sp has wrong length" #~ msgstr "angegebener min.sp hat falsche Länge" #~ msgid "Unknown additive model fit method." #~ msgstr "Unbekannte zusätzliche Modellanpassungsmethode." #~ msgid "Unknown *generalized* additive model fit method." #~ msgstr "Unbekannte *verallgemeinerte* zusätzliche Modellanpassungsmethode." #~ msgid "pearson should be TRUE or FALSE - set to FALSE." #~ msgstr "pearson sollte TRUE oder FALSE sein - auf FALSE gesetzt." #~ msgid "nb.theta.mult must be >= 2" #~ msgstr "nb.theta.mult muss >= 2 sein" #~ msgid "dispersion argument ignored" #~ msgstr "Argument dispersion ignoriert" #~ msgid "extra arguments discarded" #~ msgstr "zusätzliche Argumente verworfen" #~ msgid ")." #~ msgstr ")." #~ msgid "S[[" #~ msgstr "S[[" #~ msgid "Unkwown flavour of GCV" #~ msgstr "Unbekannte Art von GCV" #~ msgid "GACV only supported with newton optimization, GCV type reset" #~ msgstr "GACV nur mit newton-Optimierung unterstützt, GCV-Typ zurückgesetzt" #~ msgid "" #~ "Pearson based GCV is unsupported for newton or nlm outer methods, reset" #~ msgstr "" #~ "Pearson-basierte GCV ist nicht unterstützt für newton- oder äußere nlm-" #~ "Methoden. Wird zurückgesetzt." #~ msgid "\"perf.magic\" is deprecated: reset to \"perf\"" #~ msgstr "»perf.magic« ist missbilligt: wird auf »perf« zurückgesetzt" mgcv/po/R-mgcv.pot0000755000176200001440000006352313461567646013541 0ustar liggesusersmsgid "" msgstr "" "Project-Id-Version: mgcv 1.8-29\n" "POT-Creation-Date: 2019-04-29 13:35\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=CHARSET\n" "Content-Transfer-Encoding: 8bit\n" msgid "bam can not discretize with this nesting structure" msgstr "" msgid "'family' argument seems not to be a valid family object" msgstr "" msgid "This family should not have a matrix response" msgstr "" msgid "cannot find valid starting values: please specify some" msgstr "" msgid "Deviance = %s Iterations - %d" msgstr "" msgid "Non-finite deviance" msgstr "" msgid "non-finite coefficients at iteration %d" msgstr "" msgid "algorithm did not converge" msgstr "" msgid "fitted probabilities numerically 0 or 1 occurred" msgstr "" msgid "fitted rates numerically 0 occurred" msgstr "" msgid "Too many cluster nodes to use all efficiently" msgstr "" msgid "iterms reset to terms" msgstr "" msgid "exclude ignored by discrete prediction at present" msgstr "" msgid "family not recognized" msgstr "" msgid "un-supported smoothness selection method" msgstr "" msgid "discretization only available with fREML" msgstr "" msgid "discrete method does not use parallel cluster - use nthreads instead" msgstr "" msgid "openMP not available: single threaded computation only" msgstr "" msgid "min.sp not supported with fast REML computation, and ignored." msgstr "" msgid "no smooths, ignoring `discrete=TRUE'" msgstr "" msgid "Not enough (non-NA) data to do anything meaningful" msgstr "" msgid "AR.start must be logical" msgstr "" msgid "chunk.size < number of coefficients. Reset to %d" msgstr "" msgid "unknown tensor constraint type" msgstr "" msgid "Model has more coefficients than data" msgstr "" msgid "length of sp must be number of free smoothing parameters in original model" msgstr "" msgid "general families not supported by bam" msgstr "" msgid "AR1 parameter rho unused with generalized model" msgstr "" msgid "samfrac too small - ignored" msgstr "" msgid "Model can not be updated" msgstr "" msgid "link not available for coxph family; available link is \"identity\"" msgstr "" msgid "something wrong with stratified prediction" msgstr "" msgid "NA times supplied for cox.ph prediction" msgstr "" msgid "not an extended family" msgstr "" msgid "erroneous call to estimate.theta - no free parameters" msgstr "" msgid "step failure in theta estimation" msgstr "" msgid "link not available for ordered categorical family; available links are \"identity\"" msgstr "" msgid "Must supply theta or R to ocat" msgstr "" msgid "Response should be integer class labels" msgstr "" msgid "values out of range" msgstr "" msgid "link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"" msgstr "" msgid "negative values not allowed for the negative binomial family" msgstr "" msgid "link \"%s\" not available for Tweedie family." msgstr "" msgid "Tweedie p must be in interval (a,b)" msgstr "" msgid "link not available for beta regression; available links are \"logit\", \"probit\", \"cloglog\" and \"cauchit\"" msgstr "" msgid "saturated likelihood may be inaccurate" msgstr "" msgid "link not available for scaled t distribution; available links are \"identity\", \"log\", and \"inverse\"" msgstr "" msgid "Supplied df below min.df. min.df reset" msgstr "" msgid "NA values not allowed for the scaled t family" msgstr "" msgid "link not available for zero inflated; available link for `lambda' is only \"loga\"" msgstr "" msgid "negative values not allowed for the zero inflated Poisson family" msgstr "" msgid "Non-integer response variables are not allowed with ziP" msgstr "" msgid "Using ziP for binary data makes no sense" msgstr "" msgid "Possible divergence detected in fast.REML.fit" msgstr "" msgid "fast REML optimizer reached iteration limit" msgstr "" msgid "unsupported order of differentiation requested of gam.fit3" msgstr "" msgid "illegal `family' argument" msgstr "" msgid "Invalid linear predictor values in empty model" msgstr "" msgid "Invalid fitted means in empty model" msgstr "" msgid "Length of start should equal %d and correspond to initial coefs for %s" msgstr "" msgid "Can't find valid starting values: please specify some" msgstr "" msgid "NAs in V(mu)" msgstr "" msgid "0s in V(mu)" msgstr "" msgid "NAs in d(mu)/d(eta)" msgstr "" msgid "No observations informative at iteration %d" msgstr "" msgid "Not enough informative observations." msgstr "" msgid "Non-finite coefficients at iteration %d" msgstr "" msgid "no valid set of coefficients has been found:please supply starting values" msgstr "" msgid "Step size truncated due to divergence" msgstr "" msgid "inner loop 1; can't correct step size" msgstr "" msgid "Step size truncated: out of bounds" msgstr "" msgid "inner loop 2; can't correct step size" msgstr "" msgid "penalized deviance = %s" msgstr "" msgid "inner loop 3; can't correct step size" msgstr "" msgid "Step halved: new penalized deviance = %g" msgstr "" msgid "Non finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam.contol'" msgstr "" msgid "Non-finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam.contol'" msgstr "" msgid "Algorithm did not converge" msgstr "" msgid "Algorithm stopped at boundary value" msgstr "" msgid "deriv should be 1 or 2" msgstr "" msgid "L must be a matrix." msgstr "" msgid "L must have at least as many rows as columns." msgstr "" msgid "L has inconsistent dimensions." msgstr "" msgid "Fitting terminated with step failure - check results carefully" msgstr "" msgid "Iteration limit reached without full convergence - check carefully" msgstr "" msgid "link not implemented for extended families" msgstr "" msgid "fam not a family object" msgstr "" msgid "unrecognized (vector?) link" msgstr "" msgid "link not recognised" msgstr "" msgid "variance function not recognized for quasi" msgstr "" msgid "family not recognised" msgstr "" msgid "'theta' must be specified" msgstr "" msgid "%s link not available for negative binomial family; available links are \"identity\", \"log\" and \"sqrt\"" msgstr "" msgid "H has wrong dimension" msgstr "" msgid "only scalar `rho' and `theta' allowed." msgstr "" msgid "1 0" msgstr "" msgid "maximum number of iterations must be > 0" msgstr "" msgid "silly value supplied for rank.tol: reset to square root of machine precision." msgstr "" msgid "Model seems to contain no terms" msgstr "" msgid "Discrete Theta search not available with performance iteration" msgstr "" msgid "y must be univariate unless binomial" msgstr "" msgid "Length of start should equal %d and correspond to initial coefs." msgstr "" msgid "iterative weights or data non-finite in gam.fit - regularization may help. See ?gam.control." msgstr "" msgid "Step size truncated: out of bounds." msgstr "" msgid "`object' is not of class \"gam\"" msgstr "" msgid "unrecognised na.action" msgstr "" msgid "na.action not character or function" msgstr "" msgid "Smoothness uncertainty corrected covariance not available" msgstr "" msgid "Unknown type, reset to terms." msgstr "" msgid "predict.gam can only be used to predict from gam objects" msgstr "" msgid "newdata is a model.frame: it should contain all required variables" msgstr "" msgid "no NAs allowed in response data for this model" msgstr "" msgid "not all required variables have been supplied in newdata!" msgstr "" msgid "type iterms not available for multiple predictor cases" msgstr "" msgid "non-existent terms requested - ignoring" msgstr "" msgid "non-existent exclude terms requested - ignoring" msgstr "" msgid "requires an object of class gam" msgstr "" msgid "nothing to do for this model" msgstr "" msgid "Pearson residuals not available for this family - returning deviance residuals" msgstr "" msgid "lambda and h should have the same length!" msgstr "" msgid "recov works with fitted gam objects only" msgstr "" msgid "m can't be in re" msgstr "" msgid "p-values for any terms that can be penalized to zero will be unreliable: refit model to fix this." msgstr "" msgid "The following arguments to anova.glm(..) are invalid and dropped:" msgstr "" msgid "," msgstr "" msgid "un-supported test" msgstr "" msgid "test argument ignored" msgstr "" msgid "anova.gam called with non gam object" msgstr "" msgid "not a gam object" msgstr "" msgid "argument is not a gam object" msgstr "" msgid "S.scale vector doesn't match S list - please report to maintainer" msgstr "" msgid "Supplied matrix not symmetric" msgstr "" msgid "singular values not returned in order" msgstr "" msgid "Something wrong - matrix probably not +ve semi definite" msgstr "" msgid "method not recognised." msgstr "" msgid "S[[%d]] matrix is not +ve definite." msgstr "" msgid "dimensions of supplied w wrong." msgstr "" msgid "w different length from y!" msgstr "" msgid "X lost dimensions in magic!!" msgstr "" msgid "mu dimensions wrong" msgstr "" msgid "something wrong with inputs to LAPACK routine" msgstr "" msgid "not positive definite" msgstr "" msgid "don't be silly" msgstr "" msgid "sd should have exactly one less entry than ld" msgstr "" msgid "update not positive definite" msgstr "" msgid "internal error in vcorr, please report to simon.wood@r-project.org" msgstr "" msgid "a has wrong number of rows" msgstr "" msgid "mvn requires 2 or more dimensional data" msgstr "" msgid "mvn does not yet handle offsets" msgstr "" msgid "mvn dimension error" msgstr "" msgid "non-integer binomial denominator: quantiles incorrect" msgstr "" msgid "object is not a glm or gam" msgstr "" msgid "names of z and pc must match" msgstr "" msgid "Partial residuals do not have a natural x-axis location for linear functional terms" msgstr "" msgid "no automatic plotting for smooths of more than two variables" msgstr "" msgid "no automatic plotting for smooths of more than four variables" msgstr "" msgid "argument pers is deprecated, please use scheme instead" msgstr "" msgid "residuals argument to plot.gam is wrong length: ignored" msgstr "" msgid "No variance estimates available" msgstr "" msgid "No terms to plot - nothing for plot.gam() to do." msgstr "" msgid "grid vectors are different lengths" msgstr "" msgid "data vectors are of different lengths" msgstr "" msgid "supplied dist negative" msgstr "" msgid "Model does not seem to have enough terms to do anything useful" msgstr "" msgid "view variables must be one of %s" msgstr "" msgid "Don't know what to do with parametric terms that are not simple numeric or factor variables" msgstr "" msgid "View variables must contain more than one value. view = c(%s,%s)." msgstr "" msgid "type must be \"link\" or \"response\"" msgstr "" msgid "Something wrong with zlim" msgstr "" msgid "color scheme not recognised" msgstr "" msgid "sorry no option for contouring with errors: try plot.gam" msgstr "" msgid "At least three knots required in call to mono.con." msgstr "" msgid "lower bound >= upper bound in call to mono.con()" msgstr "" msgid "x is null" msgstr "" msgid "uniquecombs has not worked properly" msgstr "" msgid "order too low" msgstr "" msgid "too few knots" msgstr "" msgid "x out of range" msgstr "" msgid "something wrong with argument d." msgstr "" msgid "one or more supplied k too small - reset to default" msgstr "" msgid "dimension of fx is wrong" msgstr "" msgid "xt argument is faulty." msgstr "" msgid "bs wrong length and ignored." msgstr "" msgid "m wrong length and ignored." msgstr "" msgid "Repeated variables as arguments of a smooth are not permitted" msgstr "" msgid "only first element of `id' used" msgstr "" msgid "supply a value for each variable for a point constraint" msgstr "" msgid "ord is wrong. reset to NULL." msgstr "" msgid "ord contains out of range orders (which will be ignored)" msgstr "" msgid "by=. not allowed" msgstr "" msgid "s(.) not supported." msgstr "" msgid "s(.) not yet supported." msgstr "" msgid "argument k of s() should be integer and has been rounded" msgstr "" msgid "attempt to use unsuitable marginal smooth class" msgstr "" msgid "Sorry, tensor products of smooths with multiple penalties are not supported." msgstr "" msgid "reparameterization unstable for margin: not done" msgstr "" msgid "basis not usable with reduced te" msgstr "" msgid "fx length wrong from t2 term: ignored" msgstr "" msgid "length of sp incorrect in t2: ignored" msgstr "" msgid "d can not be negative in call to null.space.dimension()." msgstr "" msgid "arguments of smooth not same dimension" msgstr "" msgid "components of knots relating to a single smooth must be of same length" msgstr "" msgid "more knots than data in a tp term: knots ignored." msgstr "" msgid "basis dimension, k, increased to minimum possible" msgstr "" msgid "no data to predict at" msgstr "" msgid "Basis only handles 1D smooths" msgstr "" msgid "number of supplied knots != k for a cr smooth" msgstr "" msgid "F is missing from cr smooth - refit model with current mgcv" msgstr "" msgid "more knots than unique data values is not allowed" msgstr "" msgid "number of supplied knots != k for a cc smooth" msgstr "" msgid "basis dimension too small for b-spline order" msgstr "" msgid "knot range does not include data" msgstr "" msgid "there should be" msgstr "" msgid "supplied knots" msgstr "" msgid "knots supplied" msgstr "" msgid "knot range is so wide that there is *no* information about some basis coefficients" msgstr "" msgid "penalty order too high for basis dimension" msgstr "" msgid "there is *no* information about some basis coefficients" msgstr "" msgid "basis dimension is larger than number of unique covariates" msgstr "" msgid "multiple penalties of the same order is silly" msgstr "" msgid "requested non-existent derivative in B-spline penalty" msgstr "" msgid "fs smooths can only have one factor argument" msgstr "" msgid "\"fs\" smooth cannot use a multiply penalized basis (wrong basis in xt)" msgstr "" msgid "no factor supplied to fs smooth" msgstr "" msgid "\"fs\" terms can not be fixed here" msgstr "" msgid "fs smooth not suitable for discretisation with more than one metric predictor" msgstr "" msgid "the adaptive smooth class is limited to 1 or 2 covariates." msgstr "" msgid "penalty basis too large for smoothing basis" msgstr "" msgid "penalty basis too small" msgstr "" msgid "random effects don't work with ids." msgstr "" msgid "Please put term with most levels last in 're' to avoid spoiling supplied penalties" msgstr "" msgid "supplied S matrices are wrong diminsion" msgstr "" msgid "argument of mrf should be a factor variable" msgstr "" msgid "MRF basis dimension set too high" msgstr "" msgid "data contain regions that are not contained in the knot specification" msgstr "" msgid "penalty matrix, boundary polygons and/or neighbours list must be supplied in xt" msgstr "" msgid "no spatial information provided!" msgstr "" msgid "mismatch between nb/polys supplied area names and data area names" msgstr "" msgid "Something wrong with auto- penalty construction" msgstr "" msgid "supplied penalty not square!" msgstr "" msgid "supplied penalty wrong dimension!" msgstr "" msgid "penalty column names don't match supplied area names!" msgstr "" msgid "Can only deal with a sphere" msgstr "" msgid "more knots than data in an sos term: knots ignored." msgstr "" msgid "more knots than data in a ds term: knots ignored." msgstr "" msgid "A term has fewer unique covariate combinations than specified maximum degrees of freedom" msgstr "" msgid "s value reduced" msgstr "" msgid "s value increased" msgstr "" msgid "No suitable s (i.e. m[2]) try increasing m[1]" msgstr "" msgid "s value modified to give continuous function" msgstr "" msgid "basis dimension reset to minimum possible" msgstr "" msgid "incorrect arguments to GP smoother" msgstr "" msgid "more knots than data in an ms term: knots ignored." msgstr "" msgid "smooth objects should not have a qrc attribute." msgstr "" msgid "unimplemented sparse constraint type requested" msgstr "" msgid "handling `by' variables in smooth constructors may not work with the summation convention" msgstr "" msgid "Can't find by variable" msgstr "" msgid "sweep and drop constraints unlikely to work well with self handling of by vars" msgstr "" msgid "factor `by' variables can not be used with matrix arguments." msgstr "" msgid "`by' variable must be same dimension as smooth arguments" msgstr "" msgid "Number of prediction and fit constraints must match" msgstr "" msgid "x and y must be same length" msgstr "" msgid "variable names don't match boundary names" msgstr "" msgid "x and y not same length" msgstr "" msgid "bnd must be a list." msgstr "" msgid "lengths of k and bnd are not compatible." msgstr "" msgid "attempt to select non existent basis function" msgstr "" msgid "coefficient vector wrong length" msgstr "" msgid "knots must be specified for soap" msgstr "" msgid "soap films are bivariate only" msgstr "" msgid "need at least one interior knot" msgstr "" msgid "can't soap smooth without a boundary" msgstr "" msgid "bnd must be a list of boundary loops" msgstr "" msgid "faulty bnd" msgstr "" msgid "k and bnd lengths are inconsistent" msgstr "" msgid "data outside soap boundary" msgstr "" msgid "no free coefs in sf smooth" msgstr "" msgid "only deals with 2D case" msgstr "" msgid "not enough unique values to find k nearest" msgstr "" msgid "cubic spline only deals with 1D data" msgstr "" msgid "object not fully initialized" msgstr "" mgcv/po/R-fr.po0000755000176200001440000011571013461561644013014 0ustar liggesusers# Translation of R-mgcv.pot to French # Copyright (C) 2005 The R Foundation # This file is distributed under the same license as the mgcv R package. # Philippe Grosjean , 2005. # msgid "" msgstr "" "Project-Id-Version: mgcv 1.3-10\n" "Report-Msgid-Bugs-To: bugs@r-project.org\n" "POT-Creation-Date: 2019-04-29 12:44\n" "PO-Revision-Date: 2005-12-09 09:13+0100\n" "Last-Translator: Philippe Grosjean \n" "Language-Team: French \n" "Language: fr\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=ISO-8859-1\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n > 1);\n" msgid "bam can not discretize with this nesting structure" msgstr "" msgid "'family' argument seems not to be a valid family object" msgstr "" msgid "This family should not have a matrix response" msgstr "" #, fuzzy msgid "cannot find valid starting values: please specify some" msgstr "" "Impossible de trouver des valeurs de dpart valides : veuillez en spcifier" msgid "Deviance = %s Iterations - %d" msgstr "" msgid "Non-finite deviance" msgstr "" #, fuzzy msgid "non-finite coefficients at iteration %d" msgstr "Coefficients non finis l'itration" #, fuzzy msgid "algorithm did not converge" msgstr "L'algorithme n'a pas converg" msgid "fitted probabilities numerically 0 or 1 occurred" msgstr "probabilits d'ajustement numrique de 0 ou 1 rencontres" msgid "fitted rates numerically 0 occurred" msgstr "taux d'ajustement numriques de 0 rencontrs" msgid "Too many cluster nodes to use all efficiently" msgstr "" #, fuzzy msgid "iterms reset to terms" msgstr "Type inconnu, rinitialis `terms'." msgid "exclude ignored by discrete prediction at present" msgstr "" msgid "family not recognized" msgstr "famille non reconnue" msgid "un-supported smoothness selection method" msgstr "" msgid "discretization only available with fREML" msgstr "" msgid "discrete method does not use parallel cluster - use nthreads instead" msgstr "" msgid "openMP not available: single threaded computation only" msgstr "" msgid "min.sp not supported with fast REML computation, and ignored." msgstr "" msgid "no smooths, ignoring `discrete=TRUE'" msgstr "" msgid "Not enough (non-NA) data to do anything meaningful" msgstr "Pas assez de donnes (non-NA) pour faire quoi que ce soit d'utile" msgid "AR.start must be logical" msgstr "" msgid "chunk.size < number of coefficients. Reset to %d" msgstr "" msgid "unknown tensor constraint type" msgstr "" msgid "Model has more coefficients than data" msgstr "Le modle a plus de coefficients que le nombre de donnes" msgid "" "length of sp must be number of free smoothing parameters in original model" msgstr "" #, fuzzy msgid "general families not supported by bam" msgstr "argument test ignor" msgid "AR1 parameter rho unused with generalized model" msgstr "" msgid "samfrac too small - ignored" msgstr "" msgid "Model can not be updated" msgstr "" msgid "link not available for coxph family; available link is \"identity\"" msgstr "" #, fuzzy msgid "something wrong with stratified prediction" msgstr "il y a quelque chose d'anormal avec l'argument d." msgid "NA times supplied for cox.ph prediction" msgstr "" msgid "not an extended family" msgstr "" msgid "erroneous call to estimate.theta - no free parameters" msgstr "" msgid "step failure in theta estimation" msgstr "" msgid "" "link not available for ordered categorical family; available links are " "\"identity\"" msgstr "" msgid "Must supply theta or R to ocat" msgstr "" msgid "Response should be integer class labels" msgstr "" msgid "values out of range" msgstr "" msgid "" "link not available for negative binomial family; available links are " "\"identity\", \"log\" and \"sqrt\"" msgstr "" msgid "negative values not allowed for the negative binomial family" msgstr "" msgid "link \"%s\" not available for Tweedie family." msgstr "" msgid "Tweedie p must be in interval (a,b)" msgstr "" msgid "" "link not available for beta regression; available links are \"logit\", " "\"probit\", \"cloglog\" and \"cauchit\"" msgstr "" msgid "saturated likelihood may be inaccurate" msgstr "" msgid "" "link not available for scaled t distribution; available links are \"identity" "\", \"log\", and \"inverse\"" msgstr "" msgid "Supplied df below min.df. min.df reset" msgstr "" msgid "NA values not allowed for the scaled t family" msgstr "" msgid "" "link not available for zero inflated; available link for `lambda' is only " "\"loga\"" msgstr "" msgid "negative values not allowed for the zero inflated Poisson family" msgstr "" msgid "Non-integer response variables are not allowed with ziP" msgstr "" msgid "Using ziP for binary data makes no sense" msgstr "" msgid "Possible divergence detected in fast.REML.fit" msgstr "" msgid "fast REML optimizer reached iteration limit" msgstr "" msgid "unsupported order of differentiation requested of gam.fit3" msgstr "" msgid "illegal `family' argument" msgstr "argument `family' non autoris" msgid "Invalid linear predictor values in empty model" msgstr "Valeurs de prdiction linaire dans un modle vide" msgid "Invalid fitted means in empty model" msgstr "Moyennes ajustes incorrectes dans un modle vide" #, fuzzy msgid "Length of start should equal %d and correspond to initial coefs for %s" msgstr " et correspond aux coefs initiaux pour " msgid "Can't find valid starting values: please specify some" msgstr "" "Impossible de trouver des valeurs de dpart valides : veuillez en spcifier" msgid "NAs in V(mu)" msgstr "NAs dans V(mu)" msgid "0s in V(mu)" msgstr "0s dans V(mu)" msgid "NAs in d(mu)/d(eta)" msgstr "NAs dans d(mu)/d(eta)" #, fuzzy msgid "No observations informative at iteration %d" msgstr "Aucune observation informative l'itration" msgid "Not enough informative observations." msgstr "Pas assez d'observations informatives." #, fuzzy msgid "Non-finite coefficients at iteration %d" msgstr "Coefficients non finis l'itration" msgid "" "no valid set of coefficients has been found:please supply starting values" msgstr "" "pas d'ensemble de coefficients valide trouv : veuillez fournir les valeurs " "de dpart" msgid "Step size truncated due to divergence" msgstr "La taille du pas est tronque cause d'une divergence" msgid "inner loop 1; can't correct step size" msgstr "boucle interne 1 ; Impossible de corriger la taille du pas" msgid "Step size truncated: out of bounds" msgstr "Taille du pas tronque: hors de plage." msgid "inner loop 2; can't correct step size" msgstr "boucle interne 2 ; Impossible de corriger la taille du pas" msgid "penalized deviance = %s" msgstr "" msgid "inner loop 3; can't correct step size" msgstr "boucle interne 3 ; Impossible de corriger la taille du pas" msgid "Step halved: new penalized deviance = %g" msgstr "" msgid "" "Non finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam." "contol'" msgstr "" msgid "" "Non-finite derivatives. Try decreasing fit tolerance! See `epsilon' in `gam." "contol'" msgstr "" msgid "Algorithm did not converge" msgstr "L'algorithme n'a pas converg" msgid "Algorithm stopped at boundary value" msgstr "L'algorithme est arrt aux valeurs limites" msgid "deriv should be 1 or 2" msgstr "" msgid "L must be a matrix." msgstr "" msgid "L must have at least as many rows as columns." msgstr "" #, fuzzy msgid "L has inconsistent dimensions." msgstr "H a des mauvaises dimensions" msgid "Fitting terminated with step failure - check results carefully" msgstr "" msgid "Iteration limit reached without full convergence - check carefully" msgstr "" msgid "link not implemented for extended families" msgstr "" msgid "fam not a family object" msgstr "fam n'est pas un objet family" msgid "unrecognized (vector?) link" msgstr "link non reconnu (vecteur ?)" msgid "link not recognised" msgstr "link non reconnu" msgid "variance function not recognized for quasi" msgstr "function de variance non reconnue pour quasi" msgid "family not recognised" msgstr "famille non reconnue" msgid "'theta' must be specified" msgstr "" msgid "" "%s link not available for negative binomial family; available links are " "\"identity\", \"log\" and \"sqrt\"" msgstr "" msgid "H has wrong dimension" msgstr "H a des mauvaises dimensions" msgid "only scalar `rho' and `theta' allowed." msgstr "" msgid "1 0" msgid "number of linear predictors doesn't match" msgstr "" msgid "response not in 0 to number of predictors + 1" msgstr "" msgid "ziplss requires 2 links specified as character strings" msgstr "" msgid "link not available for" msgstr "" msgid "parameter of ziplss" msgstr "" msgid "Non-integer response variables are not allowed with ziplss" msgstr "" msgid "Using ziplss for binary data makes no sense" msgstr "" msgid "gevlss requires 3 links specified as character strings" msgstr "" msgid "link not available for mu parameter of twlss" msgstr "" msgid "gammals requires 2 links specified as character strings" msgstr "" msgid "link not available for mu parameter of gammals" msgstr "" #, fuzzy msgid "An object of length %d does not match the required parameter size" msgstr "ne correspond pas au paramtre taille requis" msgid "NA's in pdTens factor" msgstr "valeurs manquantes (NA) dans le fateur pdTens" msgid "Cannot extract the matrix from an uninitialized object" msgstr "Impossible d'extraire la matrice d'un objet non initialis" msgid "NA's in pdTens matrix" msgstr "valeurs manquantes (NA) dans la matrice pdTens" msgid "Cannot extract the matrix from an uninitialized pdMat object" msgstr "Impossible d'extraire la matrice d'un objet pdMat non initialis" msgid "Cannot extract the matrix with uninitialized dimensions" msgstr "Impossible d'extraire la matrice ayant des dimensions non initialises" msgid "An object of length" msgstr "Un objet de longueur" msgid "does not match the required parameter size" msgstr "ne correspond pas au paramtre taille requis" msgid "Must give names when initializing pdIdnot from parameter." msgstr "" "Il faut fournir des noms lors de l'initialisation de pdIdnot depuis un " "paramtre." msgid "without a formula" msgstr "sans une formule" msgid "Cannot extract the dimensions" msgstr "Impossible d'extraire les dimensions" msgid "Cannot extract the inverse from an uninitialized object" msgstr "Impossible d'extraire l'inverse depuis un objet non initialis" msgid "Can not convert this smooth class to a random effect" msgstr "" msgid "te smooths not useable with gamm4: use t2 instead" msgstr "" msgid "gamm can not fix only some margins of tensor product." msgstr "" "gamm ne peut arranger seulement quelques marges de produits de tenseurs." msgid "" "Tensor product penalty rank appears to be too low: please email Simon.Wood@R-" "project.org with details." msgstr "" "Le rang de la pnalit pour le produit tensoriel semble trop bas : veuillez " "envoyer un email Simon.Wood@R-project.org avec les dtails" #, fuzzy msgid "No data supplied to gamm.setup" msgstr "Aucune donne fournie gam.setup" msgid "" "gamm can not handle linked smoothing parameters (probably from use of `id' " "or adaptive smooths)" msgstr "" msgid "only one level of smooth nesting is supported by gamm" msgstr "" msgid "side conditions not allowed for nested smooths" msgstr "" msgid "object does not appear to be of class lme" msgstr "l'objet ne semble pas tre de la classe lme" msgid "inner groupings not nested in outer!!" msgstr "" "le regroupement interne n'est pas imbriqu dans le regroupement externe !!" msgid "iteration %d" msgstr "" msgid "gamm not converged, try increasing niterPQL" msgstr "" msgid "family are not designed for use with gamm!" msgstr "" msgid "gamm is not designed to use extended families" msgstr "" msgid "random argument must be a *named* list." msgstr "l'argument random doit tre une liste *nomme*." msgid "all elements of random list must be named" msgstr "tous les lments d'une liste de nombres alatoires doivent tre nomms" msgid "gamm() can only handle random effects defined as named lists" msgstr "" "gamm() peut seulement utiliser des effets alatoires dfinis comme listes " "nommes" msgid "" "gamm models must have at least 1 smooth with unknown smoothing parameter or " "at least one other random effect" msgstr "" "les modles gamm doivent avoir au moins 1 lissage avec des parmtres inconnus " "ou au moins un autre effet alatoire" msgid "weights must be like glm weights for generalized case" msgstr "" msgid "Nested smooths must be fully random" msgstr "" msgid "size must be in [1,120]" msgstr "" msgid "rank deficient re-parameterization" msgstr "" msgid "modal weight <=0 in integration step!!" msgstr "" msgid "Requires a gam or bam prefit object" msgstr "" msgid "bam fits only supported with discrete==TRUE" msgstr "" msgid "integration not available with this family - insufficient derivatives" msgstr "" #, fuzzy msgid "something wrong with A index vector" msgstr "il y a quelque chose d'anormal avec l'argument d." msgid "sorry link not yet handled" msgstr "" #, fuzzy msgid "weights ignored" msgstr "argument test ignor" #, fuzzy msgid "family not implemented yet" msgstr "famille non reconnue" msgid "jagam requires a file for the JAGS model specification" msgstr "" msgid "smoothing parameter prior choise not recognised, reset to gamma" msgstr "" msgid "coefficient simulation data is missing" msgstr "" msgid "burnin too large, reset" msgstr "" msgid "rho missing from simulation data edf.type reset to 2" msgstr "" #, fuzzy msgid "residuals argument not supported" msgstr "argument test ignor" msgid "unconditional argument not meaningful here" msgstr "" #, fuzzy msgid "by.resids argument not supported" msgstr "argument test ignor" #, fuzzy msgid "all.terms argument not supported" msgstr "argument test ignor" msgid "silly tolerance supplied" msgstr "" msgid "argument k must be positive." msgstr "" msgid "A not square" msgstr "" msgid "Can not have more eigenvalues than nrow(A)" msgstr "" msgid "nrow(M$X) != length(M$y)" msgstr "nrow(M$X) != length(M$y)" msgid "ncol(M$X) != length(M$p)" msgstr "ncol(M$X) != length(M$p)" msgid "length(M$w) != length(M$y)" msgstr "length(M$w) != length(M$y)" msgid "nrow(M$Ain) != length(M$bin)" msgstr "nrow(M$Ain) != length(M$bin)" msgid "nrow(M$Ain) != length(M$p)" msgstr "nrow(M$Ain) != length(M$p)" #, fuzzy msgid "initial parameters not feasible" msgstr "les paramtres initiaux sont trs proches des contraintes d'ingalit" #, fuzzy msgid "initial point very close to some inequality constraints" msgstr "les paramtres initiaux sont trs proches des contraintes d'ingalit" msgid "initial parameters very close to inequality constraints" msgstr "les paramtres initiaux sont trs proches des contraintes d'ingalit" msgid "ncol(M$C) != length(M$p)" msgstr "ncol(M$C) != length(M$p)" msgid "M$S and M$off have different lengths" msgstr "M$S et M$off ont des longueurs diffrentes" msgid "M$sp has different length to M$S and M$off" msgstr "M$sp a une longueur diffrente de M$S et M$off" #, fuzzy msgid "M$S[%d] is too large given M$off[%d]" msgstr "] est trop large, tant donn M$off[" msgid "Penalized model matrix must have no more columns than rows" msgstr "" msgid "Model matrix not full column rank" msgstr "" msgid "can't handle [[ in formula" msgstr "" #, fuzzy msgid "single linear predictor indices are ignored" msgstr "Valeurs de prdiction linaire dans un modle vide" #, fuzzy msgid "linear predictor labels out of range" msgstr "Valeurs de prdiction linaire dans un modle vide" msgid "model has repeated 1-d smooths of same variable." msgstr "le modle a des lissages 1-d rpts des mmes variables" msgid "`id' linked smooths must have same number of arguments" msgstr "" msgid "`rank' has wrong length in `paraPen'" msgstr "" #, fuzzy msgid "a parametric penalty has wrong dimension" msgstr "H a des mauvaises dimensions" #, fuzzy msgid "L has wrong dimension in `paraPen'" msgstr "H a des mauvaises dimensions" msgid "`sp' dimension wrong in `paraPen'" msgstr "" msgid "`sp' too short" msgstr "" msgid "No data supplied to gam.setup" msgstr "Aucune donne fournie gam.setup" msgid "paraPen not supported for multi-formula models" msgstr "" msgid "absorb.cons must be TRUE for multi-formula models" msgstr "" msgid "length(drop.intercept) should be equal to number of model formulas" msgstr "" msgid "shared offsets not allowed" msgstr "" msgid "dropping unidentifiable parametric terms from model" msgstr "" msgid "First argument is no sort of formula!" msgstr "Le premier argument n'est pas une formule." msgid "You've got no model...." msgstr "Vous n'avez aucun modle..." msgid "" "Later terms sharing an `id' can not have more smoothing parameters than the " "first such term" msgstr "" msgid "Supplied smoothing parameter vector is too short - ignored." msgstr "" "Le vecteur des paramtres de lissage fourni est trop court - il est ignor." msgid "NA's in supplied smoothing parameter vector - ignoring." msgstr "" "Valeurs manquantes (NA) dans le vecteur de paramtres de lissage fixe - ignor." msgid "incorrect number of smoothing parameters supplied for a smooth term" msgstr "" msgid "length of min.sp is wrong." msgstr "la longueur de min.sp est fausse." msgid "NA's in min.sp." msgstr "valeurs manquantes (NA) dans min.sp" msgid "elements of min.sp must be non negative." msgstr "les lments de min.sp doivent tre positifs ou nulls." #, fuzzy msgid "unknown outer optimization method." msgstr "Mthode d'optimisation externe GAM inconnue." msgid "Please provide a single value for theta or use nb to estimate it" msgstr "" msgid "nlm.fd only available for GCV/UBRE" msgstr "" msgid "unknown optimizer" msgstr "" msgid "unknown smoothness selection criterion" msgstr "" msgid "Reset optimizer to outer/newton" msgstr "" msgid "in.out incorrect: see documentation" msgstr "" msgid "incorrect number of linear predictors for family" msgstr "" msgid "edge.correct must be logical or a positive number" msgstr "" msgid "nthreads must be a positive integer" msgstr "" msgid "IRLS regularizing parameter must be a non-negative number." msgstr "le paramtre de rgularisation IRLS doit tre positif ou null." msgid "value of epsilon must be > 0" msgstr "la valeur de epsilon doit tre > 0" msgid "maximum number of iterations must be > 0" msgstr "le nombre maximum d'itrations doit tre > 0" msgid "" "silly value supplied for rank.tol: reset to square root of machine precision." msgstr "" "valeur aberrante fournie pour rank.tol : rinitialise la racine carre de la " "prcision de la machine." msgid "Model seems to contain no terms" msgstr "Le modle semble ne contenir aucun terme" msgid "Discrete Theta search not available with performance iteration" msgstr "" msgid "y must be univariate unless binomial" msgstr "y doit tre univari moins d'tre binomial" #, fuzzy msgid "Length of start should equal %d and correspond to initial coefs." msgstr "et correspondre aux coefficients initiaux." msgid "" "iterative weights or data non-finite in gam.fit - regularization may help. " "See ?gam.control." msgstr "" "pondrations itratives ou donnes non finies dans gam.fit - une rgularisation " "peut aider. Voyez ?gam.control." msgid "Step size truncated: out of bounds." msgstr "Taille du pas tronque : hors de plage." #, fuzzy msgid "`object' is not of class \"gam\"" msgstr "l'objet ne semble pas tre de la classe lme" #, fuzzy msgid "unrecognised na.action" msgstr "link non reconnu (vecteur ?)" msgid "na.action not character or function" msgstr "" msgid "Smoothness uncertainty corrected covariance not available" msgstr "" msgid "Unknown type, reset to terms." msgstr "Type inconnu, rinitialis `terms'." msgid "predict.gam can only be used to predict from gam objects" msgstr "" "predict.gam peut seulement tre utilis pour des prdictions partir d'objets " "gam" msgid "newdata is a model.frame: it should contain all required variables" msgstr "" "newdata est un model.frame : il devrait contenir toutes les variables " "requises" msgid "no NAs allowed in response data for this model" msgstr "" msgid "not all required variables have been supplied in newdata!" msgstr "les variables requises n'ont pas toutes t fournies dans newdata!" msgid "type iterms not available for multiple predictor cases" msgstr "" msgid "non-existent terms requested - ignoring" msgstr "terme inexistant requis - il est ignor" #, fuzzy msgid "non-existent exclude terms requested - ignoring" msgstr "terme inexistant requis - il est ignor" msgid "requires an object of class gam" msgstr "" msgid "nothing to do for this model" msgstr "" msgid "" "Pearson residuals not available for this family - returning deviance " "residuals" msgstr "" msgid "lambda and h should have the same length!" msgstr "" msgid "recov works with fitted gam objects only" msgstr "" msgid "m can't be in re" msgstr "" msgid "" "p-values for any terms that can be penalized to zero will be unreliable: " "refit model to fix this." msgstr "" msgid "The following arguments to anova.glm(..) are invalid and dropped:" msgstr "Les arguments suivants de anova.glm(..) sont incorrects et ignors :" msgid "," msgstr "," msgid "un-supported test" msgstr "" msgid "test argument ignored" msgstr "argument test ignor" msgid "anova.gam called with non gam object" msgstr "anova.gam appel sur un objet qui n'est pas gam" #, fuzzy msgid "not a gam object" msgstr "fam n'est pas un objet family" #, fuzzy msgid "argument is not a gam object" msgstr "fam n'est pas un objet family" msgid "S.scale vector doesn't match S list - please report to maintainer" msgstr "" msgid "Supplied matrix not symmetric" msgstr "La matrice fournie n'est pas symtrique" msgid "singular values not returned in order" msgstr "les valeurs singulires ne sont pas renvoyes dans l'ordre" msgid "Something wrong - matrix probably not +ve semi definite" msgstr "" "Quelque chose d'anormal s'est produit - la matrice n'est probablement pas " "+ve semi dfinie" msgid "method not recognised." msgstr "mthode non reconnue." #, fuzzy msgid "S[[%d]] matrix is not +ve definite." msgstr "]] n'est pas +ve dfinie." msgid "dimensions of supplied w wrong." msgstr "les dimensions du w fourni sont mauvaises." msgid "w different length from y!" msgstr "w n'a pas la mme longueur que y !" msgid "X lost dimensions in magic!!" msgstr "X a perdu ses dimensions dans magic !!" #, fuzzy msgid "mu dimensions wrong" msgstr "la dimension de fx est incorrecte" #, fuzzy msgid "something wrong with inputs to LAPACK routine" msgstr "il y a quelque chose d'anormal avec l'argument d." msgid "not positive definite" msgstr "" msgid "don't be silly" msgstr "" msgid "sd should have exactly one less entry than ld" msgstr "" #, fuzzy msgid "update not positive definite" msgstr "]] n'est pas +ve dfinie." msgid "internal error in vcorr, please report to simon.wood@r-project.org" msgstr "" msgid "a has wrong number of rows" msgstr "" msgid "mvn requires 2 or more dimensional data" msgstr "" msgid "mvn does not yet handle offsets" msgstr "" msgid "mvn dimension error" msgstr "" msgid "non-integer binomial denominator: quantiles incorrect" msgstr "" msgid "object is not a glm or gam" msgstr "" msgid "names of z and pc must match" msgstr "" msgid "" "Partial residuals do not have a natural x-axis location for linear " "functional terms" msgstr "" msgid "no automatic plotting for smooths of more than two variables" msgstr "aucun graphe automatique pour les lissages de plus de deux variables" #, fuzzy msgid "no automatic plotting for smooths of more than four variables" msgstr "aucun graphe automatique pour les lissages de plus de deux variables" msgid "argument pers is deprecated, please use scheme instead" msgstr "" msgid "residuals argument to plot.gam is wrong length: ignored" msgstr "" "l'argument residuals plot.gam est de la mauvaise longueur : il est ignor" msgid "No variance estimates available" msgstr "Aucun estimateur de variance n'est disponible" msgid "No terms to plot - nothing for plot.gam() to do." msgstr "Aucun terme reprsenter graphiquement - rien faire pour plot.gam()." msgid "grid vectors are different lengths" msgstr "les vecteurs de grille ont des longueurs diffrentes" msgid "data vectors are of different lengths" msgstr "les vecteurs de donnes ont des longueurs diffrentes" msgid "supplied dist negative" msgstr "dist fournie ngative" #, fuzzy msgid "Model does not seem to have enough terms to do anything useful" msgstr "" "Le modle ne semble pas avoir suffisamment de terme pour faire quoi que ce " "soit d'utile" #, fuzzy msgid "view variables must be one of %s" msgstr "les variables `view' doivent tre prises parmis" msgid "" "Don't know what to do with parametric terms that are not simple numeric or " "factor variables" msgstr "" #, fuzzy msgid "View variables must contain more than one value. view = c(%s,%s)." msgstr "Les variables `view' doivent contenir plus d'une valeur. view = c(" msgid "type must be \"link\" or \"response\"" msgstr "type doit tre \"link\" ou \"response\"" msgid "Something wrong with zlim" msgstr "Quelque chose d'anormal s'est produit avec zlim" msgid "color scheme not recognised" msgstr "schma de couleurs non reconnu" msgid "sorry no option for contouring with errors: try plot.gam" msgstr "" "dsol, aucune option pour effectuer les contours avec erreurs : essayez plot." "gam" msgid "At least three knots required in call to mono.con." msgstr "Au moins trois noeuds requis pour mono.con." msgid "lower bound >= upper bound in call to mono.con()" msgstr "limite infrieure >= limite suprieure dans l'appel mono.con()" msgid "x is null" msgstr "x est null" msgid "uniquecombs has not worked properly" msgstr "" msgid "order too low" msgstr "" msgid "too few knots" msgstr "trop peu de noeuds" msgid "x out of range" msgstr "" msgid "something wrong with argument d." msgstr "il y a quelque chose d'anormal avec l'argument d." msgid "one or more supplied k too small - reset to default" msgstr "" "un ou plusieurs k spcifis trop petits - rinitialisation aux valeurs par dfaut" msgid "dimension of fx is wrong" msgstr "la dimension de fx est incorrecte" #, fuzzy msgid "xt argument is faulty." msgstr "arguments supplmentaires limins" msgid "bs wrong length and ignored." msgstr "bs, de longueur incorrecte, est ignor." msgid "m wrong length and ignored." msgstr "m, de longueur incorrecte, est ignor." msgid "Repeated variables as arguments of a smooth are not permitted" msgstr "Les variables rptes comme arguments d'un lissage ne sont pas permises" msgid "only first element of `id' used" msgstr "" msgid "supply a value for each variable for a point constraint" msgstr "" msgid "ord is wrong. reset to NULL." msgstr "" msgid "ord contains out of range orders (which will be ignored)" msgstr "" msgid "by=. not allowed" msgstr "by=. n'est pas permis" #, fuzzy msgid "s(.) not supported." msgstr "s(.) pas encore support" msgid "s(.) not yet supported." msgstr "s(.) pas encore support" msgid "argument k of s() should be integer and has been rounded" msgstr "l'argument k de s() doit tre un entier et a t arrondi" msgid "attempt to use unsuitable marginal smooth class" msgstr "" msgid "" "Sorry, tensor products of smooths with multiple penalties are not supported." msgstr "" msgid "reparameterization unstable for margin: not done" msgstr "" msgid "basis not usable with reduced te" msgstr "" msgid "fx length wrong from t2 term: ignored" msgstr "" msgid "length of sp incorrect in t2: ignored" msgstr "" msgid "d can not be negative in call to null.space.dimension()." msgstr "d ne peut tre ngatif dans l'appel null.space.dimension()" msgid "arguments of smooth not same dimension" msgstr "" msgid "components of knots relating to a single smooth must be of same length" msgstr "" "les composants des noeuds relatifs un mme lissage doivent tre de mme " "longueur" msgid "more knots than data in a tp term: knots ignored." msgstr "" "plus de noeuds que de donnes dans un terme tp : des noeuds sont ignors." msgid "basis dimension, k, increased to minimum possible" msgstr "la dimension de base, k, est augmente la valeur minimale possible" msgid "no data to predict at" msgstr "pas de donnes pour la prdiction " #, fuzzy msgid "Basis only handles 1D smooths" msgstr "la base cr ne fonctionne que pour les lissages 1-d !" msgid "number of supplied knots != k for a cr smooth" msgstr "le nombre de noeuds fournis != k pour un lissage 'cr'" msgid "F is missing from cr smooth - refit model with current mgcv" msgstr "" msgid "more knots than unique data values is not allowed" msgstr "il n'est pas autoris d'avoir plus de noeuds que de valeurs uniques" msgid "number of supplied knots != k for a cc smooth" msgstr "le nombre de noeuds fournis != k pour un lissage 'cc'" msgid "basis dimension too small for b-spline order" msgstr "" msgid "knot range does not include data" msgstr "" msgid "there should be" msgstr "" #, fuzzy msgid "supplied knots" msgstr "dist fournie ngative" msgid "knots supplied" msgstr "" msgid "" "knot range is so wide that there is *no* information about some basis " "coefficients" msgstr "" msgid "penalty order too high for basis dimension" msgstr "" msgid "there is *no* information about some basis coefficients" msgstr "" msgid "basis dimension is larger than number of unique covariates" msgstr "" msgid "multiple penalties of the same order is silly" msgstr "" msgid "requested non-existent derivative in B-spline penalty" msgstr "" msgid "fs smooths can only have one factor argument" msgstr "" msgid "\"fs\" smooth cannot use a multiply penalized basis (wrong basis in xt)" msgstr "" #, fuzzy msgid "no factor supplied to fs smooth" msgstr "Aucune donne fournie gam.setup" msgid "\"fs\" terms can not be fixed here" msgstr "" msgid "" "fs smooth not suitable for discretisation with more than one metric predictor" msgstr "" msgid "the adaptive smooth class is limited to 1 or 2 covariates." msgstr "" msgid "penalty basis too large for smoothing basis" msgstr "" msgid "penalty basis too small" msgstr "" msgid "random effects don't work with ids." msgstr "" msgid "" "Please put term with most levels last in 're' to avoid spoiling supplied " "penalties" msgstr "" #, fuzzy msgid "supplied S matrices are wrong diminsion" msgstr "H a des mauvaises dimensions" #, fuzzy msgid "argument of mrf should be a factor variable" msgstr "l'argument k de s() doit tre un entier et a t arrondi" msgid "MRF basis dimension set too high" msgstr "" msgid "data contain regions that are not contained in the knot specification" msgstr "" msgid "" "penalty matrix, boundary polygons and/or neighbours list must be supplied in " "xt" msgstr "" msgid "no spatial information provided!" msgstr "" msgid "mismatch between nb/polys supplied area names and data area names" msgstr "" #, fuzzy msgid "Something wrong with auto- penalty construction" msgstr "il y a quelque chose d'anormal avec l'argument d." msgid "supplied penalty not square!" msgstr "" #, fuzzy msgid "supplied penalty wrong dimension!" msgstr "H a des mauvaises dimensions" msgid "penalty column names don't match supplied area names!" msgstr "" msgid "Can only deal with a sphere" msgstr "" #, fuzzy msgid "more knots than data in an sos term: knots ignored." msgstr "" "plus de noeuds que de donnes dans un terme tp : des noeuds sont ignors." #, fuzzy msgid "more knots than data in a ds term: knots ignored." msgstr "" "plus de noeuds que de donnes dans un terme tp : des noeuds sont ignors." msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" msgid "s value reduced" msgstr "" msgid "s value increased" msgstr "" msgid "No suitable s (i.e. m[2]) try increasing m[1]" msgstr "" msgid "s value modified to give continuous function" msgstr "" #, fuzzy msgid "basis dimension reset to minimum possible" msgstr "la dimension de base, k, est augmente la valeur minimale possible" msgid "incorrect arguments to GP smoother" msgstr "" #, fuzzy msgid "more knots than data in an ms term: knots ignored." msgstr "" "plus de noeuds que de donnes dans un terme tp : des noeuds sont ignors." msgid "smooth objects should not have a qrc attribute." msgstr "les objets lissage ne devraient pas avoir d'attribut qrc." msgid "unimplemented sparse constraint type requested" msgstr "" msgid "" "handling `by' variables in smooth constructors may not work with the " "summation convention" msgstr "" msgid "Can't find by variable" msgstr "Impossible de trouver la variable 'by'" msgid "" "sweep and drop constraints unlikely to work well with self handling of by " "vars" msgstr "" msgid "factor `by' variables can not be used with matrix arguments." msgstr "" msgid "`by' variable must be same dimension as smooth arguments" msgstr "" msgid "Number of prediction and fit constraints must match" msgstr "" msgid "x and y must be same length" msgstr "" msgid "variable names don't match boundary names" msgstr "" msgid "x and y not same length" msgstr "" #, fuzzy msgid "bnd must be a list." msgstr "l'argument random doit tre une liste *nomme*." msgid "lengths of k and bnd are not compatible." msgstr "" msgid "attempt to select non existent basis function" msgstr "" msgid "coefficient vector wrong length" msgstr "" msgid "knots must be specified for soap" msgstr "" msgid "soap films are bivariate only" msgstr "" msgid "need at least one interior knot" msgstr "" msgid "can't soap smooth without a boundary" msgstr "" msgid "bnd must be a list of boundary loops" msgstr "" msgid "faulty bnd" msgstr "" msgid "k and bnd lengths are inconsistent" msgstr "" msgid "data outside soap boundary" msgstr "" msgid "no free coefs in sf smooth" msgstr "" msgid "only deals with 2D case" msgstr "" msgid "not enough unique values to find k nearest" msgstr "" msgid "cubic spline only deals with 1D data" msgstr "" msgid "object not fully initialized" msgstr "" #, fuzzy #~ msgid "scaled t df must be > min.df" #~ msgstr "la valeur de epsilon doit tre > 0" #~ msgid "no automatic plotting for smooths of more than one variable" #~ msgstr "aucun graphe automatique pour les lissages de plus d'une variable" #, fuzzy #~ msgid "non-finite coefficients at iteration" #~ msgstr "Coefficients non finis l'itration" #~ msgid "x has no row attribute" #~ msgstr "x n'a pas d'attribut de lignes" #~ msgid "x has no col attribute" #~ msgstr "x n'a pas d'attribut de colonnes" #~ msgid "" #~ "NA's passed to eig: please email Simon.Wood@R-project.org with details" #~ msgstr "" #~ "NA pass eig : veuillez envoyer un email Simon.Wood@R-project.org avec " #~ "les dtails" #~ msgid "" #~ "NA eigenvalues returned by eigen: please email Simon.Wood@R-project.org " #~ "with details" #~ msgstr "" #~ "Valeurs propres NA renvoyes par eigen : veuillez envoyer un email Simon." #~ "Wood@R-project.org avec les dtails" #~ msgid "" #~ "NA's in eigenvectors from eigen: please email Simon.Wood@R-project.org " #~ "with details" #~ msgstr "" #~ "Valeurs manquantes (NA) dans les vecteurs propres pour eigen : veuillez " #~ "envoyer un email Simon.Wood@R-project.org" #~ msgid "" #~ "NA singular values returned by svd: please email Simon.Wood@R-project.org " #~ "with details" #~ msgstr "" #~ "Valeurs singulires NA renvoyes par svd : veuillez envoyer un email Simon." #~ "Wood@R-project.org" #~ msgid "" #~ "NA's in singular vectors from svd: please email Simon.Wood@R-project.org " #~ "with details" #~ msgstr "" #~ "Valeurs manqsuantes (NA) dans les vecteurs singuliers pour svd : veuillez " #~ "envoyer un email Simon.Wood@R-project.org" #~ msgid "" #~ "NA problem resolved using svd, but please email Simon.Wood@R-project.org " #~ "anyway" #~ msgstr "" #~ "Problme de valeurs manquantes (NA) rsolu en utilisant svd, veuillez " #~ "envoyer un email Simon.Wood@R-project.org" #~ msgid "Problem with linear algebra routines." #~ msgstr "Problme avec les routines d'algbre linaire." #~ msgid "gamm() requires package nlme to be installed" #~ msgstr "gamm() ncessite le package nlme pour tre install" #~ msgid "gamm() requires package MASS to be installed" #~ msgstr "gamm() ncessite le package MASS pour tre install" #~ msgid "M$S[" #~ msgstr "M$S[" #~ msgid "]" #~ msgstr "]" #~ msgid "Can't mix fixed and estimated penalties in mgcv() - use magic()" #~ msgstr "" #~ "Impossible de mixer des pnalits fixes et estimes dans mgcv() - utilisez " #~ "magic() plutt" #~ msgid "meaninglessly low k; reset to 2" #~ msgstr "k trop bas et insignifiant ; Rinitialis 2" #~ msgid "can't predict outside range of knots with periodic smoother" #~ msgstr "" #~ "impossible d'effectuer une prdiction en dehors de la plage des noeuds " #~ "avec un lissage priodique" #~ msgid "supplied sp has wrong length" #~ msgstr "le sp fourni n'a pas la bonne longueur" #~ msgid "supplied min.sp has wrong length" #~ msgstr "min.sp fourni n'a pas la bonne longueur" #~ msgid "Unknown additive model fit method." #~ msgstr "Mthode d'ajustement de modle additif inconnue." #~ msgid "Unknown *generalized* additive model fit method." #~ msgstr "Mthode d'ajustement de modle additif *gnralis* inconnue." #~ msgid "pearson should be TRUE or FALSE - set to FALSE." #~ msgstr "'pearson' doit tre 'TRUE' ou 'FALSE' - valeur 'FALSE' utilise ici" #~ msgid "" #~ "Negative binomial family not (yet) usable with type 2 iteration methods." #~ msgstr "" #~ "Famille binomiale ngative pas (encore) utilisable avec les mthodes " #~ "d'itration de type 2." #~ msgid "" #~ "Must use gam.control(absorb.cons=TRUE), for type 2 iteration\n" #~ " methods." #~ msgstr "" #~ "Il faut utiliser gam.control(absorb.cons = TRUE), pour des mthodes " #~ "d'itration de type 2." #~ msgid "nb.theta.mult must be >= 2" #~ msgstr "nb.theta.mult doit tre >= 2" #~ msgid "dispersion argument ignored" #~ msgstr "argument dispersion ignor" #~ msgid ")." #~ msgstr ")." #~ msgid "S[[" #~ msgstr "la matrice S[[" mgcv/po/de.po0000644000176200001440000000544513533720775012600 0ustar liggesusers# Translation of mgcv.pot to German # Copyright (C) 2005-2009 The R Foundation # This file is distributed under the same license as the mgcv package. # Chris Leick , 2009. # msgid "" msgstr "" "Project-Id-Version: R 2.10.0 / mgcv 1.5-5\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2019-09-04 12:37+0100\n" "PO-Revision-Date: 2009-10-08 16:16+0200\n" "Last-Translator: Chris Leick \n" "Language-Team: German \n" "Language: de\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n != 1);\n" #: magic.c:444 msgid "magic requires smoothing parameter starting values if L supplied" msgstr "magic benötigt Glättungsparameter-Startwerte, wenn L angegeben" #: magic.c:562 msgid "magic, the gcv/ubre optimizer, failed to converge after 400 iterations." msgstr "" "magic, der gcv/ubre-Optimierer, konvergierte nach 400 Iterationen noch nicht." #: matrix.c:82 msgid "Failed to initialize memory for matrix." msgstr "Initialisieren von Speicher für Matrix fehlgeschlagen." #: matrix.c:144 matrix.c:202 msgid "An out of bound write to matrix has occurred!" msgstr "Ein Schreiben außerhalb der Matrixgrenze ist aufgetreten!" #: matrix.c:150 msgid "INTEGRITY PROBLEM in the extant matrix list." msgstr "INTEGRITÄTSPROBLEM in der bestehenden Matrix-Liste." #: matrix.c:182 msgid "You are trying to check matrix integrity without defining RANGECHECK." msgstr "" "Sie versuchen die Integrität der Matrix zu prüfen ohne RANGECHECK zu " "definieren." #: matrix.c:240 msgid "Target matrix too small in mcopy" msgstr "Zielmatrix zu klein in mcopy" #: matrix.c:260 matrix.c:268 matrix.c:281 matrix.c:289 msgid "Incompatible matrices in matmult." msgstr "Inkompatible Matrizen in matmult." #: matrix.c:313 msgid "Attempt to invert() non-square matrix" msgstr "Versuch des Aufrufs von invert() für nicht-quadratische Matrix" #: matrix.c:335 msgid "Singular Matrix passed to invert()" msgstr "Singuläre Matrix an invert() übergeben" #: qp.c:59 msgid "ERROR in addconQT." msgstr "FEHLER in addconQT." #: qp.c:465 msgid "QPCLS - Rank deficiency in model" msgstr "QPCLS - Rang-Defizit im Modell" #: tprs.c:42 msgid "You must have 2m>d for a thin plate spline." msgstr "Es muss 2m>d für einen dünnwandige Spline gelten." #: tprs.c:377 tprs.c:385 msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" "Ein Term hat weniger einzigartige Kombinationen von Kovariaten als maximal " "angegebene Freiheitsgrade" #~ msgid "svd() not converged" #~ msgstr "svd() nicht konvergiert" #~ msgid "svdroot matrix not +ve semi def. %g" #~ msgstr "svdroot-Matrix nicht +ve def. %g" #~ msgid "Sort failed" #~ msgstr "Sortieren fehlgeschlagen" mgcv/po/fr.po0000755000176200001440000000534113533720775012615 0ustar liggesusers# Translation of mgcv.pot to French # Copyright (C) 2005 The R Foundation # This file is distributed under the same license as the mgcv R package. # Philippe Grosjean , 2005. # msgid "" msgstr "" "Project-Id-Version: mgcv 1.3-10\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2019-09-04 12:37+0100\n" "PO-Revision-Date: 2005-12-08 00:40+0100\n" "Last-Translator: Philippe Grosjean \n" "Language-Team: French \n" "Language: fr\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=ISO-8859-1\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n > 1);\n" #: magic.c:444 msgid "magic requires smoothing parameter starting values if L supplied" msgstr "" #: magic.c:562 msgid "magic, the gcv/ubre optimizer, failed to converge after 400 iterations." msgstr "magic, l'optimisateur gcv/ubre, n'a pas converg aprs 400 itrations." #: matrix.c:82 msgid "Failed to initialize memory for matrix." msgstr "L'initialisation de la mmoire pour une matrice a chou." #: matrix.c:144 matrix.c:202 msgid "An out of bound write to matrix has occurred!" msgstr "Une crite hors des limites de la matrice s'est produite !" #: matrix.c:150 msgid "INTEGRITY PROBLEM in the extant matrix list." msgstr "PROBLEME D'INTEGRITE dans la liste de la matrice tendue." #: matrix.c:182 msgid "You are trying to check matrix integrity without defining RANGECHECK." msgstr "" "Vous essayez de vrifier l'intgrit de la matrice sans avoir dfini " "RANGECHECK." #: matrix.c:240 msgid "Target matrix too small in mcopy" msgstr "Matrice cible trop petite dans mcopy" #: matrix.c:260 matrix.c:268 matrix.c:281 matrix.c:289 msgid "Incompatible matrices in matmult." msgstr "Matrices incompatibles dans matmult." #: matrix.c:313 msgid "Attempt to invert() non-square matrix" msgstr "Tentative d'inversion d'une matrice non carre" #: matrix.c:335 msgid "Singular Matrix passed to invert()" msgstr "Matrice singulire passe invert()" #: qp.c:59 msgid "ERROR in addconQT." msgstr "ERREUR dans addconQT." #: qp.c:465 msgid "QPCLS - Rank deficiency in model" msgstr "QPCLS - Dficience de rang dans le modle" #: tprs.c:42 msgid "You must have 2m>d for a thin plate spline." msgstr "Vous devez avoir 2m > d pour une 'thin plate spline'" #: tprs.c:377 tprs.c:385 msgid "" "A term has fewer unique covariate combinations than specified maximum " "degrees of freedom" msgstr "" "Un terme a moins de combinaisons de covariables uniques que le degr de " "libert maximum spcifi" #~ msgid "svd() not converged" #~ msgstr "svd() n'a pas converg" #~ msgid "svdroot matrix not +ve semi def. %g" #~ msgstr "la matrice svdroot n'est pas +ve semi def. %g" #~ msgid "Sort failed" #~ msgstr "Le tri a chou"