gss/0000755000176200001440000000000014467046032011054 5ustar liggesusersgss/NAMESPACE0000644000176200001440000000404213663110072012264 0ustar liggesusersuseDynLib(gss) # export user functions importFrom(stats, as.formula, dnorm, fitted, model.frame, model.matrix, model.offset, model.response, model.weights, na.omit, nlm, pnorm, predict, plogis, qlogis, qnorm, quantile, residuals, terms, terms.formula, var, runif) export(cdsscden, cpsscden, cqsscden, cdssden, cpssden, cqssden, dsscden, dssden, gauss.quad, gssanova, gssanova0, gssanova1, hzdcurve.sshzd, hzdrate.sshzd, nlm0, para.arma, predict1, predict9, project, psscden, pssden, qsscden, qssden, smolyak.quad, smolyak.size, ssanova, ssanova0, ssanova9, sscden, sscden1, sscox, ssden, ssden1, sshzd, sshzd1, ssllrm, survexp.sshzd,sscomp,sscomp2) export(sscopu, sscopu2, dsscopu, cdsscopu, cpsscopu, cqsscopu, sshzd2d, sshzd2d1, hzdrate.sshzd2d, survexp.sshzd2d) # export internal functions used in examples export(mkterm, mkphi.cubic, mkphi.tp, mkran, mkran1, mkrk.cubic, mkrk.tp) export(ngreg.proj) # register S3 methods S3method(fitted, gssanova) S3method(fitted, ssanova) S3method(predict, ssanova) S3method(predict, ssanova0) S3method(predict, sscox) S3method(predict, ssllrm) S3method(predict1, ssanova) S3method(predict9, gssanova) S3method(print, gssanova) S3method(print, ssanova) S3method(print, ssanova0) S3method(print, sscden) S3method(print, sscox) S3method(print, ssden) S3method(print, sshzd) S3method(print, ssllrm) S3method(print, summary.gssanova) S3method(print, summary.gssanova0) S3method(print, summary.ssanova) S3method(project, gssanova) S3method(project, ssanova) S3method(project, ssanova9) S3method(project, sscden) S3method(project, sscden1) S3method(project, sscox) S3method(project, ssden) S3method(project, ssden1) S3method(project, sshzd) S3method(project, sshzd1) S3method(project, ssllrm) S3method(summary, gssanova) S3method(summary, gssanova0) S3method(summary, ssanova) S3method(summary, ssanova0) S3method(summary, ssanova9) S3method(residuals, gssanova) S3method(residuals, ssanova) S3method(print, sscopu) S3method(print, sshzd2d) S3method(summary, sscopu) gss/ChangeLog0000644000176200001440000004622414467016401012633 0ustar liggesusersTue 15 Aug 2023 08:44:33 PM EDT, Chong Gu * DESCRIPTION: Version 2.2-7. * R: Edited numerous functions to allow for non-integer counts for binned data. * src: Edited numerous routines to allow for non-integer counts for binned data. Mon 07 Aug 2023 01:42:21 PM EDT, Chong Gu * DESCRIPTION: Version 2.2-6. * man: Minor fix in mkterm.copu.Rd. * src: Numerous edits to comply with stricter compiler checks. Sun 18 Jun 2023 06:27:01 PM EDT, Chong Gu * DESCRIPTION: Version 2.2-5. * src: Replaced FORTRAN function dfloat by dble. Tue 14 Mar 2023 08:36:01 PM EDT, Chong Gu * DESCRIPTION: Version 2.2-4. * inst: Edited CITATION to conform with new standard. * R: Edited numerous functions to replace "class(obj)==string" by "inherits(obj,string)". * src: Edits in smolyak.c to fix init(void), coeff(void). Tue Aug 3 20:32:06 EDT 2021, Chong Gu * DESCRIPTION: Version 2.2-3. * R: Edited sscomp. * src: Edits in smolyak.c to comment out unused calccoeff2. Tue May 26 00:21:21 EDT 2020, Chong Gu * DESCRIPTION: Version 2.2-2. * R: Added sscomp and sscomp2. * man: Added documentation for sscomp and sscomp2. Sat May 16 15:49:33 EDT 2020, Chong Gu * DESCRIPTION: Version 2.2-1. * R: Bug fixes, code cleanings in numerous places. Sun May 3 14:34:28 EDT 2020, Chong Gu * DESCRIPTION: Version 2.2-0. * R: i) Reworked the gssanova, gssanova1, and gssanova0 suites, to add support for the "polr" family. ii) Added predict9.gssanova for response scale prediction. * data: Added wesdr1. * man: Updated to reflect changes in R and data. Sat Feb 29 10:50:40 EST 2020, Chong Gu * DESCRIPTION: Version 2.1-12 * src: Bug fix in copu2newton, thanks to Elliott Sales de Andrade. Fri Feb 28 19:40:49 EST 2020, Chong Gu * DESCRIPTION: Version 2.1-11. Edits in R/ and man/ to prepare for the coming default data.frame(...,stringsAsFactors=FALSE). Merged gsscopu package into this one, adding sscopu/sscopu2 suites for copula density estimation, and sshzd2d/sshzd2d1 suites for 2-D hazard estimation. Wed Jun 5 13:14:18 EDT 2019, Chong Gu * DESCRIPTION: Version 2.1-10. * R: i) Bug fixes in cdssden.R and dssden.R. ii) Minor edits in ssanova0.R and gssanova0.R concerning calls to FORTRAN routine dmudr0. * src: Minor edits in dsidr0, dmudr0, and init.c, and removal of dsidr and dmudr. Sun Apr 22 09:19:19 EDT 2018, Chong Gu * DESCRIPTION: Version 2.1-9. * R: Reworked ssllrm suite to add qd.wt. * man: Minor edit to reflect changes in R. * src: i) Changes and bug fixes in llrmnewton. ii) Minor edit in cdennewton. Wed Apr 18 11:46:02 EDT 2018, Chong Gu * DESCRIPTION: Version 2.1-8. * R: Edited ssllrm to allow for non-integer weights. Thu Feb 23 20:55:02 EST 2017, Chong Gu * DESCRIPTION: Version 2.1-7. * R: i) Added mkran1 and modified mkran to allow for multiple terms of random effects. ii) Added predict1.ssanova to allow for the evaluation of f(x1)-f(x2) along with standard errors. iii) Bug fixes in project.ssanova and summary.ssanova involving random effects. * man: Updated to reflect changes in R. Sun Aug 28 09:47:18 EDT 2016, Chong Gu * DESCRIPTION: Version 2.1-6. * src: Replaced obsolete declarations character*1 and real*8. Thu Jul 2 10:51:16 EDT 2015, Chong Gu * DESCRIPTION: Version 2.1-5. * NAMESPACE: Added 'importFrom(stats, ...)'. Sat Dec 6 10:36:46 EST 2014, Chong Gu * DESCRIPTION: Version 2.1-4. * R: Along with a bug fix, edited utility functions for the nbinomial family in the gssanova suite, eliminating unnecessary subtractions to preserve numerical precision. man Mon Jul 21 00:14:45 EDT 2014, Chong Gu * DESCRIPTION: Version 2.1-3. * R: Edited utility functions for the binomial family in the gssanova suite, eliminating unnecessary subtractions to preserve numerical precision. Tue Jun 10 18:52:28 EDT 2014, Chong Gu * DESCRIPTION: Version 2.1-2. * inst: created the directory and added CITATION. * man: Updated references. Wed May 28 11:25:14 EDT 2014, Chong Gu * DESCRIPTION: Version 2.1-1. * R: i) Tuned Newton iteration algorithms in ngreg and ngreg.proj. ii) Bug fixes in routines involving univariate minimization via nlm0. iii) Minor changes in makedata.x's. Tue Dec 3 01:02:41 EST 2013, Chong Gu * DESCRIPTION: Version 2.1-0. * R: i) Changed time domain specification in sshzd/sshzd1. ii) Removed from sshzd1 the option of external rho. * man: Minor edit in sshzd.Rd. Fri Nov 15 17:19:59 EST 2013, Chong Gu * DESCRIPTION: Version 2.0-16. * R: i) Bug fix in survexp.sshzd. ii) Modified default values of qdsz.depth in ssden. * man: i) Updated references. ii) Added note in ssden.Rd. Wed Oct 9 11:44:05 EDT 2013, Chong Gu * DESCRIPTION: Version 2.0-15. * R: Bug fixes in summary.gssanova, summary.ssanova, and summary.ssanova9. Tue May 14 14:51:58 EDT 2013, Chong Gu * DESCRIPTION: Version 2.0-14. * R: Bug fixes in ssden1, sscden, sscden1 suites. Fri Mar 8 16:04:21 EST 2013, Chong Gu * DESCRIPTION: Version 2.0-13. * R: Replaced direct calls to LINPACK dchdc by chol(), in ssanova, cv.poisson, project.ssden1, project.sscden1, and project.sshzd1. Tue Feb 26 14:42:15 EST 2013, Chong Gu * DESCRIPTION: Version 2.0-12. * R: i) Bug fixes in summary.gssanova and project.gssanova. ii) Changes in ssanova and ssanova9 to supply sufficient work array for altered reg.f. iii) Replaced 'attach/detach' by 'with' in mkran, sscox, sshzd, and sshzd1 following suggestion by Professor Brian Ripley. * src: Replaced EISPACK routine rs by LAPACK routine dsyev in reg.f, and added $(LAPACK_LIBS) to Makevars. Tue Aug 28 18:28:31 EDT 2012, Chong Gu * DESCRIPTION: Version 2.0-11. * R: Bug fixes in fitting functions to prevent overflow in oversmoothing cases. Sat May 12 19:52:54 EDT 2012, Chong Gu * DESCRIPTION: Version 2.0-10. * R: Bug fixes in project.x to allow projections into spaces with only unpenalized terms. Tue Jan 24 09:35:43 EST 2012, Chong Gu * DESCRIPTION: Version 2.0-9. * R: Removed the .First.lib function. * man: Edited documentation for Sachs. Fri Jan 6 12:39:56 EST 2012, Chong Gu * DESCRIPTION: Version 2.0-8. * NAMESPACE: Manually created the file. * data: Added Sachs. * man: Added documentation for Sachs. Mon Jan 2 18:39:24 EST 2012, Chong Gu * DESCRIPTION: Version 2.0-7. * R: i) Bug fixes in sscden. ii) Reworked survexp.sshzd. * man: Updated to reflect changes in R. Tue Dec 20 15:44:32 EST 2011, Chong Gu * DESCRIPTION: Version 2.0-6. * R: Reworked the sshzd1 suite. * man: Updated to reflect changes in R. Tue Nov 15 21:47:30 EST 2011, Chong Gu * DESCRIPTION: Version 2.0-5. * R: Reworked the ssden1 suite to improve memory management. * man: Updated to reflect changes in R. Mon Nov 14 00:35:22 EST 2011, Chong Gu * DESCRIPTION: Version 2.0-4. * R: Bug fixes in ssden and ssden1. * data: Added NO2. * man: Added documentation for NO2. Tue Nov 8 14:09:09 EST 2011, Chong Gu * DESCRIPTION: Version 2.0-3. * R: Added the ssden1 suite. * man: Updated to reflect changes in R. * src: Added dnewton10. Sun Sep 18 10:34:49 EDT 2011, Chong Gu * DESCRIPTION: Version 2.0-2. * R: Reworked the sscden1 suite. * man: Updated to reflect changes in R. Sun Jul 31 01:03:45 EDT 2011, Chong Gu * DESCRIPTION: Version 2.0-1. * R: Bug fix in gssanova1. * src: Bug fix in drkl. Sun Jul 24 12:26:15 EDT 2011, Chong Gu * DESCRIPTION: Version 2.0-0. * R: i) Added the ssanova9, gssanova1, sscox, sscden, and sscden1 suites. ii) Reworked part of the gssanova suite. iii) Reworked the ssden suite to allow sampling bias. iv) Changed the syntax concerning partial terms, and added partial in sshzd and sshzd1 suites. v) Minor changes in cpssden and cqssden. * data: i) Added ColoCan. ii) Reformatted clim, LakeAcidity, and penny. * man: Expanded and updated to reflect changes in R. * src: i) Added cdennewton, cdenrkl, cdennewton10. ii) Changes in dnewton and drkl. Wed Jan 12 11:58:55 EST 2011, Chong Gu * DESCRIPTION: Version 1.1-7. * R: Set alpha=1 as default in ssllrm. * data: Added eyetrack. * man: Added documentation for eyetrack. Wed Oct 13 18:00:47 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-6. * R: Bug fixes in sshzd and sshzd1 concerning subset in call. * src: Bug fix in llrmnewton. Mon Jul 5 15:28:48 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-5. * R: Reworked qssden and cqssden to eliminate calls to pssden and cpssden, and removed a now redundant operation in cpssden; qssden and cqssden now run much faster. * data: Added esc. * man: i) Added documentation for esc. ii) Removed the warning for the slowness of cpssden and cqssden, as the new versions are no longer slow. Wed Jun 23 10:59:50 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-4. * R: i) Bug fixes in project.ssanova, ssden, sshzd, and sshzd1, and minor tweaking in project.gssanova, mostly concerning weighted data. ii) Added support of random effects to the sshzd and sshzd1 suites for frailty models. * man: Updated to reflect changes in R. * src: Minor change in hzdnewton10. Sun Jun 13 17:28:13 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-3. * R: i) Fixed bugs and inefficient code in ssllrm. ii) Fixed a bug in project.ssllrm. iii) Minor changes in sshzd and sshzd1. * man: Updated to reflect changes in R. * src: Changes in llrmnewton triggered by ssllrm. Thu May 27 19:52:17 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-2. * R: Fixed bugs in the ssanova suite introduced in 1.1-0. * man: Updated to reflect changes in R. Wed May 19 22:38:22 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-1. * R: i) Added support of random effects to the ssllrm suite. ii) Fixed bugs in mspreg1 and mspngreg introduced in 1.1-0. * man: Updated to reflect changes in R. Mon Nov 23 12:52:38 EST 2009, Chong Gu * DESCRIPTION: Version 1.1-0. * INDEX: Edited to reflect changes in R. * R: i) Added sshzd1 and project.sshzd1. ii) Added ssllrm, predict.ssllrm, and project.ssllrm. iii) Removed the dimension limit in ssden and added user-control of quadrature size via qdsz.depth. iv) Added skip.iter to fitting functions, and rearranged computation to speed up theta iteration. This affect all but the legacy fitting functions ssanova0 and gssanova0. v) reworked quadrature in pssden and cpssden to guarantee monotonicity. * man: Updated to reflect changes in R. Mon Mar 9 15:53:42 EDT 2009, Chong Gu * DESCRIPTION: Version 1.0-5. * R: Fixed a bug in regaux. Wed Mar 4 16:42:23 EST 2009, Chong Gu * DESCRIPTION: Version 1.0-4. * INDEX: Edited to reflect changes in R. * R: Further tweaking of the calculations concerning standard errors in predict.ssanova; added internal function regaux. * man: Updated to reflect changes in R. Wed Mar 4 00:22:21 EST 2009, Chong Gu * DESCRIPTION: Version 1.0-3. * R: Redesigned the calculations concerning standard errors in predict.ssanova. Sun Sep 7 14:42:33 EDT 2008, Chong Gu * DESCRIPTION: Version 1.0-2. * R: Fixed a bug in predict.ssanova. Fri Jun 27 17:10:27 EDT 2008, Chong Gu * DESCRIPTION: Version 1.0-1. * R: Installed more stable calculations concerning standard errors in predict.ssanova. * man: Fixed format for documentation of methods. * src: Fixed a bug in reg (undeclared dasum), which was forgiven by g77 and also by gfortran on (some) 32-bit machines; revealed by gfortran on 64-bit. Mon Aug 6 21:21:47 EDT 2007, Chong Gu * DESCRIPTION: Version 1.0-0. * INDEX: Edited to reflect changes in R. * R: i) Added mkterm to replace multiple mkterm.x in earlier versions, and modified the fitting functions accordingly. ii) Renamed ssanova to ssanova0, ssanova1 to ssanova, gssanova to gssanova0, and gssanova1 to gssanova; renamed the respective methods accordingly. iii) Added support of factor variables in ssden. * man: Extensive editing was done to reflect changes in R, to update references, and to improve readability. * src: i) Fixed bugs in hzdnewton1 and dnewton1. ii) Pushed ratfor source code to a subdirectory ratfor. Thu Sep 23 16:27:00 EST 2004, Chong Gu * DESCRIPTION: Version 0.9-3. * man: Fixed formatting bugs in ssden.Rd and sshzd.Rd. Fri Mar 26 10:40:04 EST 2004, Chong Gu * DESCRIPTION: Version 0.9-2. * R: Added SE calculations to the sshzd suite. * man: Updated hzdrate.sshzd.Rd to reflect the added SE functionality. * src: Added support for the SE calculations in the sshzd suite. Sun Oct 19 23:16:01 EST 2003, Chong Gu * DESCRIPTION: Version 0.9-1. * INDEX: Added new utility functions for gssanova1 and project.gssanova1. * R: i) Added supports of nbinomial, weibull, lognorm, and loglogis families to gssanova1. ii) Restructured project.gssanova1 along with added family supports. * man: Added to family.Rd the new utility functions for gssanova1 and project.gssanova1. Sat Aug 16 01:31:27 EST 2003, Chong Gu * DESCRIPTION: Version 0.8-6. * R: i) Added mkran and released the mixed-effect model functionality in ssanova1 and gssanova1. ii) Fixed project.ssanova1 and project.gssanova1 to treat random effects (in mixed-effect models) as offset. * data: Added bacteriuria. * man: i) Added mkran.Rd. ii) Added mixed-effect example in gssanova1.Rd. iii) To avoid confusion with the random effects in mixed-effect models, changed "fixed effects" to "unpenalized terms" and "random effects" to "penalized terms" throughout. Mon Jul 14 13:59:43 EST 2003, Chong Gu * DESCRIPTION: Version 0.8-5. * R: i) Added stable GCV evaluation in rkpk1.R. ii) Improved the reliability of nlm calls in numerous functions. iii) Bug fix in sshzd. * man: Blocked out time-consuming examples from auto executions and added warnings. Thu Jun 26 16:39:30 EST 2003, Chong Gu * DESCRIPTION: Version 0.8-4. * R: Bug fix in project.sshzd. Thu Jun 26 11:31:14 EST 2003, Chong Gu * DESCRIPTION: Version 0.8-3. * R: i) Bug fixes in sshzd and project.sshzd. ii) Miner fixes in documentation. Sun Mar 2 10:43:35 EST 2003, Chong Gu * DESCRIPTION: Version 0.8-2. * INDEX: Added gssanova1, sshzd, project.x, and related functions. * R: i) Added the gssanova1 suite for scalable non Gaussian regression. ii) Added the sshzd suite for hazard estimation. iii) Added code for Kullback-Leibler projection model diagnostics. iv) Code modifications and bug fixes in ssanova1 and ssden suites; added nlm0 for univariate optimization. * data: Added gastric. * man: Added documentations for the new entries in R. * src: Added routines to support the gssanova1 suite, the sshzd suite, and the projection code. Tue Dec 31 10:16:37 EST 2002, Chong Gu * DESCRIPTION: Version 0.7-4. * INDEX: Added ssanova1 and related functions. * R: i) Added the ssanova1 suite for scalable Gaussian regression, with modifications in fitted.R to accommodate ssanova1. ii) Minor bug fixes in ssden suite. * man: Added documentations for the new entries in R. * src: Added routines to support the ssanova1 suite. Thu Jun 27 12:03:26 EST 2002, Chong Gu * DESCRIPTION: Version 0.7-3. * R: Minor changes in ssden and related functions. * man: Minor changes to reflect code change. * src: Removed dchdc.f and dtrsl.f. Added an include line in smolyak.c as suggested by Kurt Hornik. Mon Jun 24 16:44:38 EST 2002, Chong Gu * DESCRIPTION: Version 0.7-2. * INDEX: Added ssden and related functions. * R: Added the ssden suite for density estimation. * data: Added buffalo, aids. * man: Added documentations for the new entries in R and data. * src: Added routines to support the ssden suite. Tue May 14 06:35:45 EST 2002, Chong Gu * DESCRIPTION: Version 0.6-5. * src: Removed BLAS routines, as suggested by Brian Ripley. Thu Apr 25 23:41:09 EST 2002, Chong Gu * DESCRIPTION: Version 0.6-4. * R: Cosmetic changes to conform with the formats of generic methods. * man: Minor changes to reflect the code change and to meet R-1.5.0 CMD check standard. * src: Added the file Makevars, as suggested by Martin Maechler. Thu Jul 9 22:10:07 EST 2001, Chong Gu * DESCRIPTION: Version 0.6-3. * R: Minor changes to correctly reflect documentations. * man: Minor changes to meet R-1.3.0 CMD check standard. Thu Jul 5 16:05:21 EST 2001, Chong Gu * DESCRIPTION: Version 0.6-2. * INDEX: Added mkdata.x, dev.resid.x, and dev.null.x for weibull, lognorm, and loglogis. * R: Added support for accelerated life model families weibull, lognorm, and loglogis for censored data regression. * data: Added ozone, stan, wesdr. * man: Revised relevant files to reflect the added support for accelerated life model families. Mon May 14 13:18:12 EST 2001, Chong Gu * DESCRIPTION: Version 0.5-3. Added Maintainer field per the new format requirement by R-1.2.1. * man: Fixed keywords in a few files. Thu Dec 21 19:35:38 EST 2000, Chong Gu * DESCRIPTION: Version 0.5-2. Moved the Title in here according to the new format requirement by R-1.2.0. * INDEX: Added new functions mkrk.nominal and mkrk.ordinal. * R: i) Added support for factors; ii) corrected minor bugs; iii) grouped functions into smaller number of files. * data: Replaced lake.acid by LakeAcidity. Added Nox. * man: Expanded to cover all objects. Revised existing ones to reflect code expansion/revision. * src: Fixed an inconsequential bug in dmudr1.f. Wed Jun 23 20:22:12 EST 1999, Chong Gu * DESCRIPTION (Version): First Public Release is 0.4-1 * INDEX: Expanded and reorganized. * R: i) Added support for partial and offset terms; ii) added linear splines; iii) added the gssanova suite for non Gaussian regression. * man: Expanded/revised to reflect the code expansion/revision. Fri May 28 00:31:24 EST 1999, Chong Gu * DESCRIPTION (Version): First Release is 0.3-1 gss/data/0000755000176200001440000000000013653220336011762 5ustar liggesusersgss/data/datalist0000644000176200001440000000017213653220336013512 0ustar liggesusersColoCan DiaRet LakeAcidity NO2 Sachs aids bacteriuria buffalo clim esc eyetrack gastric nox ozone penny stan wesdr wesdr1 gss/data/Sachs.rda0000644000176200001440000056632613267106071013535 0ustar liggesusersgU{w$AT# ER@QT( fA% "* `"IAQzΞO{#gtTU5:M4-H$d2H$7hH"u_(+Hxfj礕Soi:{c(6{ԁ|sU)QpokR^_{\Fjۮ[8iEI8ۛ`\oK;{^:7PGzv=+YޡsjOԮɟ}An}%?l~ȚԞŏX}MԮc/Ԟw>YԁnJ}~LҶWRG36͇R{ZslJ흼 R{S<B笪SZjɏO(~q_ӴԾOMioQI 2`b-|j/?Ԯ|/J\^gVN}lުE#ҳS:,? -^:РsILDwkw9s{%,5~^WW{}:8*{ԛS򒅗NIrS~%}g#61%MeO\yĵ{?2%J^2OS5!IV+sY퍩%R+}j~|]R{l>3,&ǿZauj'ὬԾ~vVRg}y C}yL(T G_'uJǯSFߌ{En\ۿMzU5kLOyCӣa9;E/>ӾVڗ(n>NpV`oKNBx(qOU-,:Pm+>tO6#a.X3u4eLʤe٩}9]̳_{qj犯M{ JvC_ s͕ ǁ |}WG0vPY=b(qq˻@.ǻ2rزDm1bW>m0xбuR{93So继٫r^OS]YBs}m_(qvu6vP4xT:D{ZKqȧڽzk=4?p[ϰiUa>[_;~C3^xk;JkyG:|/S~򃊼ǟJ~O{,ӤMR۞З:G72.X_Rm??rKU:ؠ-e/ڶqT[:YwWecߝDlgI8J%^=VSGa.=i{CP@_v{؛q??۶/nُ}ʖԶm/)y>%>=KkN.?㏵C#.8bSj}aԉȗ;YVtX8Z;odTb>)GeUl9QfakcZjσm-Uh񟥧k_u=sJ'GN~;,;owk͎Ox/y=v9Gyusks|sgW+< e|*h8q%uhAw>}WgZ旿}b;^ڱyՂaws:]].)Sq[{xwý6x4~='_d9BߥQElѽ9]_\V iko{鹏oaGQSv/_S=w^-Nke1I_MzRgpm'yJ)Q{jkK)>oL/H.;?Ƹ|2NOq~[>}i[w;y^5ovǿqO>wTa?|0i8x)kM!oSgGВݵeۧ{>:q֢d m籜+ {GrW:pn\_[F!_zUۮl߿eЂӜg!qnč޺r;p(v\`?$_3wi-;KUc|GZC\oJ<<ܹsmEΛɋ [fmtaڨov{H2*;w|q>H[\Oq99Α 9/?vmy{sBo3\MxeX8 O]XϽ^fzISk@NjLwAs8YC9}ɇ%K;1P8skUΎ21~ ^wkMyMpsڮqc7z]"O?i\'T~|$Qօ[tརKk~\_;qi,vKr: ~} ވ2z7~ r+51+}p^^\$`?ÒNw<"?su#}>;7+Wsq`C۫2:r/ݲI#8*r[,Qbkw8Ozo>u?ZW :7]w ^ 󣙉ENyy˽g}&s wiQ9O|NQfGT^9e17trjɭgt߯ȃN+N%nC74S&'Z9ץxu!Ο<>~ݸSA/ɏ?L7s+~c5uɃ΁r%eIC؅2~%c|x_#P~ >yݯSd(oY~ƙ -y2=GhduQ-7ߏݸ7S;X廞Ƈ+]{Q<7.>.u}yOfkpOo} 9pww^;;j^3~n5!?b~Yv|NsQ?r<޸IQ<r%}Uuqx5so~8nԋJ~m(cbKڦbrOgQgQ&כ9)}OoOUPkpyz89I?s3q%gܷ0>_Az}VriK+C|evjcc9]:MNu&Ce?m+'s˄ϒ_DDcڏPsemt?/yp?,okVu6 rLqRg)5H\0>{OJy!0N|kzyb#TԎOUEp3|R;i=C*\Aɴn_7HK̛U oq qܯMz^f됿#佰z>8&%uXv]8R{:o%m?b'<Ȟ8o%9w}~"}Ȼx U~MB9o.+LWȳ!/K]ׄE|'|1k۱~-w g!;q98 R߫ ݓuo88᮸=~U?OɮG'H?%KWq[gV-c==Go[QDBv,zs}Lg$A yr)汅}nIg¹~ֿ:rS S-i"n  |Fo{g[oת꣭ćeg%O7v~2W\yԖt{Η]?\K\Bs|:`mYUxx|D٭ }$eF>mdgׁ8?w)<#j9WF6cn=<^E+ߝ#%|DӼZ^}(c׽{6SC?Pnryv yyy.Xet)X\ل˼'" a8'sF_7:%wTȭCru_9V4-wU_~02^]}q;u)xPoo'K.qON·G߆ysY :1Ȟ<7O?Iȡ?*)pr_g(>3^"x^ )nz+o|㭸N {Wmoxkg]}<xsV?"qGǛCk:t#No'oF?7%E 6qQx} 'qqxt>y>_џO1%s5C~s_S }SS7O:_Wހz{A:ᒭ؏}uF\pjjNjӥWrƵO\H:GD[qxϳq{ݟz^.q>OHu*䂺8v99uTKp?qꠉq+(yQ|9/-z~cލpx~^瓉#FDao:y_:>u~ E40;:<~;%S.ǯǹOPrE^>sYlUpO^byGF-)Nyky"%OI߱kW'4sܰ|~/k"o9{W9k6>e/31NI}MykM<_Vy>ϻn(<>n*g~ÔyO"-tŨ/8<"sp^xNK}xʧYs;e׊y̳R|=<y6/%_}ZuK[xMzUfKV"9ot^Y3p‚"vKy CxsyNjQޛ\~!o@zw s3`T=Gɏ9_:2Z.OWy=熉-?[y㚵}OH˹}5uPv>8kểc>%?[3·' 3ϕ~eE<Oq)Ȫ///OWR?%_pwƼd5\}U}Fw\e̻Mޜ>=-'dr= ܵn3O=n rx09 gmrѪ#'#de,'w2K:bT o6>bxڒW [>:í7FӓWϚD>-ڹtQv__\{oQq-6(y m.|hg|~yUKWRQ!6~) g>|}ƴ):n3`WggNZ4jᆃ1_F}9 M{gQθ._ݝ|ϋ?z̅WʗemlQ}=pΎ(m!gd>YH޳sp˕#c袚QJ[e/nN!Gk6f=GfͼQةy{ᗣ Sg>w 5k˳'S}c.깳o|eiْKNiX:.g(~.ɟDɆg)|GG߳Ol+׽xhYϋr[ :ܨk"ʩxo+̴ g׍NO\tmGWt=ymgל31?zn?[e6㾆}yN{`y?$O/a빉:!r}Qv3'1v+irѝl#y߭睢#Nw9~oWGM({W׍cմOYb@eM~xW7TqrsF9KzqRv[.iީCϙ#J^@svMistڒ÷X[jZ޷t`uS&ݿQyK8GuK?Ћ߽Q?mK)}~'巬׷q?O-ܗeiS`V]ܦʟ9)YyC6`_?ݾU7+O']SgofO8K~p rG!~Ov?ſ'Gm}'xMv-gF˞O9 \箎puκcf\P3꾯Ijn2~Hxk95*}mer}qK'F*-ɯhmGMg;~S@UC`ݥTl`>?u]|WMkMFɨ}r7K^U9wc wNKkjz~Yv0u/ݿc c>=OyY7zQ%>gpk㿶y]a:~q_qׁ񂛊9UY Qngq}w?XH.W칿G=s%#?r{fN2?߳Z,J׸%܉)Y߮*m]~+Ӿ57q7c_--tn\L\UxUxg6yi .%^!.w8M%ZSwԭm;ErksK ==Oװ]6ab(쑼7^42;ϓ72Ǎɛȯ9Δ&'+;qBҚSy5OGϬz~?TkYŃQ^gn[Vy #US#aGC^ywgvcϼ>roo|ܿg\~Socyk^C(ѹUze}'2[M~r'<\yHģ7~"x@oD<@.7 -{7lr&oWlG1pvy|Ǐy瘯 SG\sgׂӺ;uB|-;pL<{P:rUSuKs)!렮Ȝ@w8{ϭDkΫus>=?{C?yLPX_B<lkS_ yPԉdnAޗ:SP>!wQ5257}H##r{WTs_ïgS"W)ү*>Gy) :q?z|/ܗ.<7x<_^G?Y/x/+C1zςV⇺w!% sV=' CҼr|S؛OW^Au`wx|KV'9o?|@}/cubeqa *|R_y̥a=p#G_Չ㥿_ݳ ;{Gx?1D$]R 7B?O:ק!O_NoB_x9qߝc岏^~˸Q~JUY>pa2;?!j{D|Js!kqUa/ɜ #ٮ~Qs0|w=˾nm{s:{]n_d 箻1|zjNNg^wqcG{p!^kOW%#}s#U><2\dxg4_:rB#8+M"2/g0ߙ=x=k}T̥fRc#Ϝ'- {iF\x1+qtfߟyd{Nf 썖 +J!b{;G<>?"3xs]՟d9)shڵ[_׃7ȣ0W_wSoL ?qtn[;ݰa7K,zN?a?*KKsx?ő$<_-^sz<ɉc>RyTKSp)'=t"1r}3:8uaP†D'{8j3qgk#sw<ϻc!;|yw{l0s[uegwm@ʼ|iԹ[ %k$<<Ǎ91c~o\ —?;:_s3[><3<7>o?7W,2?xw-?x' }&ԛ͇=_뼸ݷ¼$I|s+#`>"D|!Q,> %Jp Z/X3|sr7_WZbڃ>j.yA=ޞeFݛ\V:qOG ?OOJ\;h~i|g v{N'OlǏ=R»_:=z#\Gҿn޵z<\`C}'Q~nޏ(kO{A.s̓}<bu:*V f￦Md#/İ7C~ ܸ|>O/,S\7K GooœxG٬_ckscx`z]_f4rG?Av3l|-"zO_[އO:y.#OGɁrQ' A<%a_x>hÏkXwz4_}Ixò"OljnsID(/9[{^?Uџa\M?Fo rx ·엂w5~H~eZnǎSgsܩ~as+v3#|'UߪMxn~sxM ~6<}G"ȟ/3hoj]-3Q" fǸM~%IvGO&k^/iqy[y_䖾O>y~?GN~t+y$/xQ<[Nz~@v=er97?&n^Gr1 >s~#x3~09/!G^Zpf=lDWWbb?q|bD_S|#c$fupjg<}W%/@Q_-㗳>ʣ ObKR{;y6#qȡѭG <<_v5L9xN~I;x{71޼+- W 5p4}=oͥop!Q]>D"iq9y}aޑCG s1yK}?Î?&C};NsObx>އ|I9-FM^XN=s OJO/|{J~mdO}/ύ ϶‘ 9r~yEIBz?r(<'yNM5q^ߨxcTR7V5G<sSO/^zN9_vf u8O]׷w;>WJ=9=[J?'}9?Gz"z}bْ];rm*b&yܱ=*yu̿cΠΉsˏs-<#}ݒ;~^C]΢? y}Q;q%ψ]{֚w"{c';\\`k}y/~s.c×z-| uz N\98V=xΑ )x?y+pϼ˟vPvoK1ѽ{NNrPv/ IrM^ o{8_q:G ㄯ筙+b rtȕg^nVL[8T89xā)5_2潙o~zMKQDރt}\RG$Nމ~q&xM׻!ߏ' yJ}wTw|\uI yvȓx݃~x9J}q/u_^~qQ"@Ϩ+s&qQ.ڟ+QC\ oJ;mڴ_hٯ`?{ѻUuq.y7ۯɮp/?r<=u>8~ސeNx˾Q]~x%sjoǟyo%Mc?~_68o#h"qA:`nQ e%/ H>owy~>?|\t1O?Qx.pIc5WVl~s{N>39uܩx8 Nv&^чOM\7f>((?>Ů Su'-/r\~4A->yu*tSGy(I?^@o=sܱa?]dB} `KuTxN>?GN#Xp~-q"\Ja_xO橋/{9_).SF%z7 n+|Y#F?2'~\%WاR§azy#L/v\=OPOwDz]_{:_װMHg30rmg=[z#>~h &/3ށl"e,'>`*.~xp>p+sd?Mt8LJc殐佰sYB4{BkVX]f5-o#hsˁߋG{_=RW>.nޑpq$<ˊCq;LA].Ų{YoѷJ>3?Ïrxm|+\:笠;7:4Q/`o|=Wqr.9+>[ǿ-K2G_CտF>.N^10ak{$WKoo=&:?J?'Nߺ G ѯm/yz{[wɛ?~mobA8Ml9wX_><.:!ү<1_ aLNq~xn͠1+oK./bnꕜ7uٽ70ݚZ:+j3ߛ<>sy ]y27Sg  ̷}wܮ+[A{ru7`Q.g<4QYb:lHKlsŞ._?9=׆3ƿ7}/P_=ɯo᧚I_ C޲#w3c ?qx~bu%4s_5Fgy' K8W?W.ອ~㼱p!8|;+#]NEC>yċ_?Fȿy" @ޅ|G&ɯPzn}sR>W-gBn<69q|iyv=JQw`o rE^pɯ섋C_\/?5׈{ۨNy>ƿYܣ PG +[?ӟ."(%?goƏ!_ϕ\]`N;y,̝S&x+d/VD^:ݣ@[RGmoϾݧWH<ʟq{ǘK)8s_{p=|Rh¸w(n y #/[Ropi@?㑇\.+eޏpy!sAxގvg9* p~OȻEC_z }E=)+y7y9|M>u* =/GȾ;6OT]^5z q.zJ}:Ժ:_=)eO/5`> /V !/Jϰēԯ*#G7gW<o^'ˡދ8)k}}ȷux+a#Lܓ}^89w]鼜<' _A>3p ߃N])}1R﷿W:Fz} ^ ,'*/./X8{y!ҹz4ǰ'L)?{D#ߛG_ 52Af4<2B<-퓱r\kɜ4!?OEs{`?${HzK^ϗG 8[c6^S~-uQ" Õ ?y3}w~Ss3'i972'pΕ>8ZuycU^<7_-15Wy's3OW?q|"Nc8v|Uk֫\9?7UqÅ")sdSaq̓'~4ޮap)~hp5wgQuTW8?"=r!˦B_g.+c~ .g'C -<@$僝gg#9~/dB_=PGG 戺_XrO}|}CZ<( =ΛB~~ϛN0C|83Qg"9B>|:S|2?G=B~3i9]CaPr: yd<79N7u)?3)Ks?"ߒ; ]ijU%/IByg ᶇzO8?WpNyz_`4p_!ρ= I3!?0x?<'~*>#Vy^A:?L~( 7үH~Fr0Asxy xxQ -g[Ϟ ~<9>]s{sQGxHߪxS?yz|Qn~5Pg.1q>y}p&*||yꏎoL_Cp>Ay̎ccxl0OGcm~>R:mч-^r~,w_΋)w&;|¦{4AϿWMż.|Z lkL39,'!E*9qbωPs]/JX ijcK g#skJ[dEb/y)}|hw/݋Lds#'ѼbU_1| c !'*o@$&Obw-y!;I? 8xewg1ns:wAs<Y~,o^ӱ+sK[AoCƾ14 ߹/\]cܪ͞8,?=#mFc 0K̉ o_y3zs_+'O<;#oA]Nyyjm?8}g5O~}'{/WlɹUy(P=?yp=~7]k^ o{B¹q+_9P%#}{KϵwD~BO$K+|ɗG~^ {s! T9o?M>K'{a1xA=e;(99S[Wӽx~UͯP v~WcSs){䱈1sB'4y"u-G&^_N9jϜ`}lq>PgQ>a / <7~"SMxϡ^(u~(Cb.3:Ïo q>CFUq t"seks3#dޟ0~_[=S扰WOσ'2OSuXq%ut~\+ԽyN)3sS̓yyɿ"~ Oy¡W˜ioH5, V=;|W{2< :nGSiv̵O1}'|< H] 8|̂}x؏J3<1:3:ϋy4_2wVėiqfͼ"]_{Kf%'}u^43?} &Ms &w̅v;}Y:w4%?&ϓorߝ 8Mk^o~:'G@䙏[x/< uO?s汐I1ߛnMڪUxwdg=^<7Ƀ5u)N}p}=tNijIͫNx>Eg1u!͓u?P/oiA< 7 rop歂/$.91SC^ wI#KrMs 7oH?v_Wvsd"ɡ×ӽA ^d' W\}q̫f>zV|sS~=ԣ$4N>P?q_~=pQW#/㹴qS9̇sx ?!?>L~JϿ7ɎO^r+s$o|2OOz #Y} N^7+>"ά.׷ʬ|.:Aҹs+9|Ƈc]O 6=kᗰ#B vs`_,~i܌5+OOBsw('N'_9I_i //kQ@>ݏL}G'} Lyn_ާx0Hj8})2Y/$>'NcS)sEϥ=rJH<<[2^]ϏO)"?1??K:Xx/K^Ű?q?GԨw,Yx΀>`/7w!{j>>.YxQ]<'ؿ|_H?\Ofȯ?oH07C1'C'3?T(A}h揇g>rN7˔tޟz꽉W@.oOo yuA.>pߚoڒPdp cGVrC\9I¿\RW..y~=,{|1/xΞ;[")>\ ,Zō1'?ps0 9w]:ٷÜٛ$ʚ\eDOVQΌ=s^uz3|~W~zJ~|ݝg>%0#`]9#٥~3~QnTUn+>+3h{lMzJX~QNf^<e6㾆ފ5^yOh3TGF=v9햎=F;rݮJ]3ږk/l-J.{$WvEye>佟WFY%ozf|DvZmr֯왍o^ZA=nӢdFS_(=.}MMaG~gr݋?e}C7Y[|?ܨ([z!qs׮X^TkkmD&>=s/ 3ϫkQ7H޽Bˣu/^q֣'yn1=l᩵ϏZf7'dʗayM>vbTD'Ǐ}99{ցEهji(F-^{ךcJVGKD}~T(gi5W>uO/u:.{eo8iZrεX3n-_cvt!UCD9#;uL_)Q~`bdQNOUo=(ՒfWsb̙9fwEɑ9y[eWc{Tq|^ow>wSfΎ?Ou9$٘G9e iq=׹bFWKOxc(9c54c,_+oZu碇3?!)|_yTqrs'Jp_ճ&پU~jLهo=7XǨX#Qwy(󴝭 Ney[OT?lAZ'7vL_3#km˪^2WxeҲ~I/S_69k{ւ;v]îNԿlt7pVJ=8:{OgN~zeκcf\PW0.g։f|q3g}^P_)ǢdWu=p^BHf[Nt|or;uGڱ/&kjt'/?j+{`['٩Q&e~j7dk=x>/Ԓ#h?hKU' i>۴U3'/AĜ7>༳^ѶkfD^vkW׍c43W\qd Nnt򧣬=nLݥTlM'9m#RG$/y%_;gz}Oߒ}U{0'oW=䶛~֪{szO~쿌_8G!Hz`rSeQ~>t51gsF^[p6j}doKz )]uJFwȷu/|xn^X/WEU=*+vE<~->z uYagss>?Ǐr?=m+3NÎsŖ|cij|^E's J޿xuGc [̅"K%(7Q['DQ~-6;{ތ9͌9pcȹ?et}7<ԡ+Zǀ_{\?zEi˃8v{1Xer|/8nX.N d_%8V n!Nxw㢣4?~;|eF< g'v/1~n6^7܎+s̷NC^_{ n$.WhoNoE5zrZOw췡ê);/`] 44CG+>?F.~r_9`ox.;\pŚs&x %&ox܇q .ybGuA>Avlm-iܫ;ߗ[3q^J䃐c Pe}3owt}}ByOLu=37N>B]Ds-b̑.kK~4O5'\׸g{>?~xuStpm11 e^Kuٸ]=˙CA/7+{ l}jnC_OZ{>ˢ>{zGϰP|xW_,G˄ЯKݏ]?{ lOB}' p[d_>H.!|>~ؿzS[b}syn}0阫>fqs5`sYeKt3_+xixe%WEo|3x̕R<)9q?~ s1 ~܏Kr~$5:=S>7>p*?K8~U9FW#-e0rEEqs27K}ڟ< ^B;F_#~PO![<{0|B%G|?:_ass9P9+nao؏ ?Y_5ew2U{ގ>ȟ`mo79JBR?0kįAyOEg0{? ioI}z_~^;ɉ se[_I,8sU+a>%8Pύ{ ya*sJW\ [Ϸk?vs8Gܟ{ ¼q1\IrsCA5>{ G=GN3aٟƹx/s4<\]G<ܟ^U>ryGo}w6rV̫_|sG[|1GqSbo`e? N*gWsge@ Çxq}~:J_k^ȇ70G7 2ov]zar17>%}E}p>0s:W8sFGs`f78h~xbQ>qZGw2'5/_΋m0%fTg>/zmrS< c+WsĀG]zP ~Ua0'ʸkߜU{{RWo>Wn{>2QFy￦Mj׋SWn +9n\Sy//.{shG|<;5gnyf=KS}Xs{8Tn~6[z >,DN<⓷sgz2v}}ۙq'+>g͟g0O=*>vWL>'汧l>\P_SxQCŏr ͯ0u5w֊r6hZ%>?ݖz {xO?xSi=21321}oDK+x˸PNp=?<7YzM'us7~{ZO1"#R尿]Wնq2~nm從wp|F# 0ϖ2-3 ?i\~__qNQkw_& b7-u9sߗoFq<_6'أ߽ӗqMZ>c|A.+_2ySFB3J o_]s΃:yJч䯌ð?v=g0W>uwFqd7$G;‹)2'\L Dk97##Ƀ/$>&_KUń/X[?{iqUq Ӽx>AڞA}kǔ/i9}$ғ-תmb;~Xqy(sE_{`r^A89^KB{-Q7[:oC%پ䷬׷箉;|u+vvZlvɋ(opC>kɭrdð?S>~_!; O#͚)~8HUK*y3ȣyZW>pmDŽG|TCW])IMC}ģ5Y+ jysKgOyo9ߢF9Na1$ȇ.̹pB[)q}Jz"^g{?Ex>N:N_d=38emXD|y/_"y&] yZ5s7SM'<>U1&}~? ;ԟsx*ޫrx*ޫrx*ޫrx*ޫrx*ޫrx*ޫrx*UGqʾEwk?N~|i⠰DO8Cz;5b <;. /o+[+7 W[ؾ /kQx<]=ygi+ٹ-o?xm+=aΙ2=m7%ymI3O }2Γ==Ÿw<P8d# ~yP>"uN|~́]ўxkwc}gK2 ;%{ r}vrǝB{{/u0K-v?z6\4ųMybst#?g2GA8`#a7~;:%O'%s|Y^I95KeuT/2|KA9pj*,X|lC]'Y-"L`Oy#\y4?d8OO^s6O*py)W𳰷AE?[ny,p݌8'|` OŸ9xϗyyumYUZ{MuuuS 2'N翰_l C~>G;9!C~r%r p ~UyMClx%'u]-k\WOɫcW۸7YeG=/H(C-~ K{޾d#yʓwEX_ݔ8fޫ>yo+m!O s檆so}oއshZ諾t |I^sd%/Ema&ZUo%v<.9b1lL|ڴ'm/svwSx?{ mGn>ZfeG*0˟ۜ'c,z c|Ocg=|0(u|8疡/ɧ#ص'={K{#oU۷C}R3~oI}?Nܸ{q>%_Yrf,\ow֜rJ}]Oߜz>]%+x?ʧ=s>hܫ>lcon"]=?_?/xE5<%߫~֤بN5[v-wny'K>pȟ?-ۈ?xη)f/~߱;mڴ-]b9ZwV"K?GN?/sh.oϻ<`Ot_Nqf>t{r9-"W .5WX>[<ɼyZ2m}ǹ^\"NJSZ2h1-K^~QS;.|}ԪޗVDjYonTjVo]jݲý8ȯ}~oMOsԪ!>mԷ>2i" ~tת\佗]&`7|_y2nӱgf>psoς}3J)[vc-?d?_9c_ ?fN~:/.#x_~3=7Ч'?fE aWaUl3}^+B7Osf_.{{;z<ׂrKk7j?rZr;u}XK+k9s/FE=>S?Mnt_po=a=˺/`Djnʧe7QN475}=.XvqUy9Q_D?_6xV>GmGm߶k=wozEpyW/@5*_azEwOa{<G$ftʧ:m~_=-^ɧ`3v;~οcxN#Arw^`K>OxD>Ȏ|BH-ƶ ƽZq:v@П gi=q&'ol2'>f#'+~%;?{y>>z6(kܥq'"\9A{CoSпs'qy0¿H˛>%Uo [$N~J.ŸPq 8ӻ|aEp(ÿw,gC?:?E1{ 8IvR"qWυ"aMo-[aɯ?m]R;v˃7ӒĉgO'V;Y`w9 `׭7M%yҟuV_yygP.$~JF/{+K}>"yQ^e>M:7JuaVÁ '>A8'z}+G~~?74} InSRפ~J} q5Y#i__>+~rxWPx>f]a`ߔ/<ϩ6q}}7Jn>iy?8s3ba<9:ҩ1ߋyI7~;^~'|\y$ubhOy~oG87 {ϾIɓ~Sy̷_K93U<2EQ'}:' `Ov_ O|8uvյc?fUm'79W{ƼDs=`΃w5x@)3CnA&O9藣b?{Ox~W6K) 9MϰV}L+8އyHWG?%?H~JUO?!?3գ<Av7>GC{?S6ރ<^8/=z_6_ Ůoh/U}ohq5k)|\r`4 ws%3WSSO#e}IJGAF|YL5/޲rw/0O-CϜP{1rp?<^g 3d$>{$?[C7y=WSo~9p;CO E<9xS|=p[q^sܿ%rKAl!=#5s-ȃ/2B~σdnگ+o< ]ctq)38.K9rc w&軁#e_q!Es`ޏ}}i|.S#WhoTf?O m<_Rs~[OEA a79oW;8]9T}}CI߇Uq_qK~lWoA|̜/p9r, A2WBy.ϭ5A=#sx_IگRߠ/E}cr< .<% !zO|> }OscM<9w'x>t@kR= ZV9&<O| =?>SEh9܃p#ʞ0ʸ_޺ < ~B@Μo;cNNpUy i}.sU3y>ױ'K?7Π{'s V<i;%VtX8Z΋yD(o a5Is똷yA+>yr#}.eu ̜} gc9cq_G0/yZMWIyt`m Gq #=|Ǎs瞯CS}Ȋ.w|̾$× +| NlfhK{~^/{y#̉?9<ӓbz29\v=@Nס<( ssO#C`. x%{8ȟa=@ȋ{/"sg';͛ ꃮw|7M8~9k\?oOUoX™wQ;2ZLsr>Yo}J8lAȳ{nCf>8q `>hŻދ?#Unbq>Q9Ob뜬+`_e 9wA= sc+=ȿX-O{1< /! 4"({~G1/|1yUcṉ| 曑_wBץ/ȋȽ37PvH~ypA愒Ϡ%ϼ 揙O*_QB<7_IQW< y>)yG8_`yI}/Ȼy~`za":swMzC}s+^`!q!qe^%y̞&xA7xh^ Z'D@'!cxGzOpRyp`X6U |(wɻ2}RoJ/oyoyM/{d Dz~.:xLp~3B>9-gQn5*zsc&sGr=<u[)W^;Kqq ozOΟ0oxe?կg uH.DOdaN1r\p*|_p9/M=}ߌwt_ i!#iF^y-rݰ/x Æ[>R!ȯ'ywS'",oHJޜOy#?cʞs_/=E{i~gxT-|URP^seWwg0֟?SE|?}̻Oo'iy0{(7s!: _\A\r}V~>&}>_o8租x{5+[jٌ/\FFdƟG[|'G9ƞ2%x=3Ë?b+{dg[;S}H1݅wL:6o͋`o`4~G C_W>0_y?M4)z\ '+y$~aO|#\\|7?Y# x={K4n|coO_<O>l_cg'OO'@ }>*c&{srT⦟ڎ'@yqy#.s9^ <x{~Oݖt?:J8OID_8{_rD}ys$z.[kyϚyZqv~ݯl1Kz. x=;ƣ:7Ws ط0uTsG`OE_y :8rhp3ǺD p婘;^aO"s1{se߈ 7r.>>컦ywK8Ocg y~dӜ_ޭ}|S'^%7ѯ^#?}Վ{#|!yO3Ǎy'0?}sUE>u^恇[ـ~{=a{&5W yp_/ _^!WV O$p~""_ܻLEwL88r+CЯ3[< g:t>M? s?J~<|{޳){h*p%O /~=۹/◱_8Λgb-}}.{`O=z_{Ω'ԉGǏj}[Wa^8a?] _9.=Ŝ>旚F=r:oy7#'#_}L7G\䥰]Cù߱#y}@71L9WC{GN^Z}Ţex:yAG*vw<+{ǟ3}+8}Afޔq̋oؿrWKyƼ/pɾ`G}A~{;l;2=>Osa'žAz䍸bn#爾>h/zϣ' x^p ݓQ?A> >Opo^iȹu%?.ԕ6?ß_v^Q_0/y,0Ϡw%?Qk9I1.QUDM9iQշ=9~([irm(+gǓI&e5ѴpRZr-7{8 AfEY%oz({hV %n6?^Т_(V ,.UwrFv9똾Qߚqzs%dWuQ6)(y˟o,Jm|͘3GY}lQ%,12soؗ^k~~"RS6DɻTh3ty,}ĨB(wX9egtwu8_M7I_QW(sE_#,5~^WG9g\5bl1ow'}enփv\5J4YOU2ʊQr+,l%7$ZuorY(7l{˞楥DY[4[|T(g}e/qcF>{GC#{IQ^u 7rYov݋^2x?W}kqÇϘԿ(ဋV}<~zD:OeG9xc_r\&}Fiݶe_wGY5IMF9_]PQ?y(;O2mոQUO]]=js-sno(Bu"\e=>n`ٓauጺ'˟9Y^eoKzD:DDrϟ8iEHaGJ.O.Jϭp Oi#_bQfl}M.sWG^oQMWk{6~)p|?~Ny34>m˂d]?ٴρd>YJÊ(;`7jv>y_d 'evN$%&_#;Eeʮ(ݟk=:&?ay2?Ӫ:â mȳYw̙ jb'蟎աfoe;9"|v }h۫E{E:zerXzŗ YUV lxJCuxۑӒ;9kM1u%mS ebtOkm˪Nd:{#x?gi5W>e<вuFoZ^7Mc޵}oۼj_&rkI'_MF;rڿ~ %2A9>WK {U.y=ʸ`Ŷ~ނGg'#^e*f'suyKOxcz5-B.8.oZ*u{}*_?/vt f8[r++y|(0Rl{%\ֽxYf7]03dFS_(=ʾ্o0n<'n% }g6㾆ފMF/|zx_~o(~þ_+ |ȹt| evl?ފ|-^>4GjZ޷'?޷ۮ20 /G:!2{[xjO2}ٱoC&}~_ug'_>x?3!QA'8wmc3ӗ=ݗ4ůNO^=kR[Gr}{+n@܍繑~ngii r}~5:Bە=3?v#wh_bz5%…/3+FCPM3Kϡ׿C~ SG\sgX3-3~%\c}?gvMy(㒊s[X$ b<9ߓO}8s'܂ӰsrU j`n,>ÿsVi}Op< qCC*6Yk#y$|+oy>ImW vڂq|hYAc=?Cn˶Dzw9Ѳ}γ^$?ä7ە+[X8oi^tc.Թÿo'o*u ꏪ{GקA]XuxetDK\ _QmJ"xWgsy\Pq09ժ۰ A]NľV{?_ x Pw <΅G~!o셥̫W.3޿NĽi\u]ׁ7Bϐ{8յc9K˳ܧ3}ol{ Ik#z"^}V##U#3zΌ!{Ω]t}dvfQ6/=\]k4U 9G[ged{6uZz0CӼqms׸O/"E綤i5m^uj[Ď^lW炷"÷ {s<'i;S9h/l'"(:ayopv{G73/D=%/rG?<7v =g[dW;xɯ͂>€˅9gI`?C)x  Cn$~>5u_ˀ>Tjȧa,q=|g /7_-6OGN+g{0[k_ >9^O`ose~}޹˟WfpE p4~ as)3߃=q;7`9_G8* b?#  s^3p _^w2[ xNa}Oz>}]c*qr{;>Co8Njk<򇽅/n_Ny7硽E{Ǧ?K$~%Q>}|?~>}K y|pEyxxq+Bݯ8=!x~4NHv=Op‘1pI}#3g"^OGnsHjpo1%.vAOr4w%q;qWW[$ Fx<7b# {Z=6p3aB=E>yOh/=ro,9z{k=wʏo^gn#q#v!cxꇮj{pTLRꒆWTd }VƽAu/-yX8;p^+rH x =Nq ~߿lc%U|vbwgO'%95?"cB-|sx?1퀟fA2\ϧfs})Ie!?8\\>}<ꯦϘx7׼Rr<.S]G=UUw=rϊ}۞yOW\^U92G6cL߲W?r1c$s+\=䅨3}$]<9?C+Ls5l簗y.*&|ͭ=Wyf.L8\v}59%?R?Mime{ٿs{m߅ϼRϏ|v$~ޘå|`o} [p ~ iϰ7e\bϗe?=Oq`nH8_{KNsk%/ޏ* NasR||M S _.̷`ܼɯWG< n$eG_d^g+̞Z  '+^Y?&1>'>6>qy x1U:W{e!_i&Kk/ Uz?Dod$$5=G3y>ޗA;nd@}ܯJ~yyK燎W.{An.vsqa-zy<=cU*CN>.|ok]gcw5-}{?O~y!3g7+yq}Fe/@q#螉[U?5Կ:4{*Kf_sWI Seοހ=|5< 2WeJ߰ ożbK+x8}̑ rb{%a^1){g}ԽIBO /ķo+?x/{Vy^"v[~Tߝz,u!q >)J| Dw~tOα}i߰ωy7+y`~E~q's뛛kx|pqRyG<_[G]8z6JG{x\>컐pJ]${r?y _O\srQ&yג?= ?"'|L=Hvsk(yCy]!kb=n/{χK}#AuNW3ݛ{ Cߍȉ6O}$[<(yγE/; /\?&#'v c<ģΒwsp>7yvwΐ'P|Yw"=J!oc/ =_~''-? wFnEWb<:m,o8,!ikOFh^|=}ʋd_ s @ ?O^Z'CN=<<_\p%`!^C?{q+U=|p]Gg PIߊ\`eg/} e_u?>Qй{֜~?$/m/#k=x(Oy|񭟏s|"yI{}k,$yRG8^ ep*y&9Ks`|ߡ75 s|<~-q9"ؓs<vK~O#!_V'܁S='ܜxJw5OIOsz_0;|: ˚d>5r]BOϼW{TC|0J_lM Oc^4a/+UIaɟ}Anq0.<=3"yB;9~p$=fN~Cȗ(}:%8N? <)Ez[FK~%cnJ쉗wMv<.A'![|']}|zΓ7'}g !/c܏*s^[{Os&΀L;]"~ElM_~c~e;$}%d>eߜ>KNᡄ{Xswa~~g D/Owg'{8'~"o3'x ~~C#.8b'~|6?X`𔣲*6oGs=OtBz2vռԁ|sO`u~zޏ9~kۻE/}G4?_ <t1ȇ?\ 5EM7!>=q7]y=ڛ`='J }`'f> RI 53n~xVo[:Mp'ϫ}[IScp^>'G]Rr/ywM{J2yrsy'+a~{9]rߋ>^:p︝=]^Ew!yc/&<@σ=C?T~%yCzpO6х}'?W/? ) <2y&DTN.#w^;ܻO*}Qbkw~]g^Ix_qzn>oʹW$\x"|S:η] ǹ>Ip8-C%hM>qtNsb?^uO}?\>?y`xVȩWuoiJNf8}^];32b}gω+N*"y甝0y"xڏ׍<sNEg/94^`u~ޫ ~=_/{m>y8$~x}k^v_u=sJ+=o{Cn!7!H{p1=#ohz5Qr~9ɹy%;uU9^{/kU>81?!8  ?A|]qFt|yKK~xnq{JC/S3z}9!(^]dޟzdDM9C׹| P\b>y ?~P8soQhAO~*xsbOJ/z'~Gv}oJs}7v>Zv38ur[y.Aos3T:w.7'o~SF\?\+ߎ~+učG{|l<9sQAv}N+c~>9q_ï{ggpMzK<3vԧ7/h^{F.wEI~ۼx9wEU݄q o Kҿ8z_Ct~oϑg/v>Oᜧcy? eg)ďqyAljI`},~1qvyvs$uȯ\nz>vu-E$'yo<?5z@|L>} %?@/~O-ޓ;ɽ[ƣ93dy1ϖ{uݛh{s|f[|x1>s=!.;@3-~e+6SxID)7=G/<)9)K<1<9w#]g_J[UWFN "p>:?3߻@QN<9g##|h𨊯u7ep+asPq DvF~]9wOqAq!|Ƀ1gˤߗ}>#y G| _30d\#@7!yռp(?sKUz@8g#9?_z ȗ>Kos^ӧsxyO &珃\%NR ;?y= Π%;/ܓyg;vTr v~Qiި1$ny2/S~<#ݗ#}O㷥r~Oa0O:~d.|=Mb"ùtTY$˼:Ʌ?l,93RN-홻>qA_x ]<սsȣ`§K뽍Ǚ,C7 ʞw㡺x ǑU;꼖3!8wS"os%WCIn<ǂ ̵ sA<sGoD=RD3c>HNi\`|zS:evjcWo/>Oaz|~(qݍz38.oZ*ups[8 eMl[e?}i_nOfBut"=l᩵/ROEǢD^T>%ի7[g|OJe#W=ngQFMxy`;Ѡ[+ C=1'>(&8PAvyq4(q{[(||g;s6ۖq{GoOz=CdmrѪbܞ(ٟ3r,1gv^| OZ.KQVmeb>1y]l?ē/asI]}Ns/$7]?]pZ0GggC[c>W_D|ݫXTG2LupEޢ-U->gy7mo(q'~t4J wk- @VP>#ʸkߜ .7@n2Ν/1z#eޓ7sɭ_s^,s_zsksrEGMT?orA@VznK`WbNэ{_./<#A }a ]/nD;jax>5<(k݋Wh-8??67"O{_<׶5)c4(mS^,?i_MC$Ϯ_z>Sl_= }KN?U99i ccHߗ~aڨo(L~ErOG>b_U|qopx Qڻ{?{ΣfWu#,ƒQq-6/9z:O EW;{hAw>|X 8}WC\se"ƁtؕQ%>gp<(]׊w췡Q6=wwDJ4:cu>*AIaYpU[sqqG**㖆.Z}({s)O4J6mo#C >Ϗ_?y?]x1oMQ]^7xUeli %璧(s#efϛ8YlM%egG^y-_2<;.w}(gZ7ϐ^zJڠQօ[t07[Wvd( ϓ?[ۺ?2[w͵oyGyj*#p} [vy-^[~9O%4ğK8GE>97.V4Iuef^~Setmt7 xeznx {▉;_PQu}J!x~IF+O%!.{b}ԅo]ᇨ% s57$ tQ'+o 3#q^;͚([J|d l&_#;{!k&މ8ij!_$jQq]R0]*)>M?}p.Y؉QsiA?ekՖO=a(>g\v Ac|uQTw3wQv̼_/%I< tUcj7>7J8~N(٘?YTq+o B 4o8y_l{NN2Hvs" ?#ȇEŹ摥u|p>ά7ENtx[M19ǻ^385QV'n`[ڞ(]9䉩Ë'<1xyH#:(y}/tv -2ُWi\l/l͸>|:3^.g6㾆2%E۰y/20D-e5ѴpRne&\@Bx6"BC3x45Rf[seqLG`w}+L:F9=~2?9VIpBYcfKޱq^S~\gEm{hu/qyVC9فrSu(~tb(k^Ι?f>k=u5U{ }>d/`'+O1G9Ċ Uqy&Rv?O~e-?xx OO9do{rH!봹Zg|a=>7<4%N7nH׃_]wJQk"~1oYYuKu̡\Gd7Wێ_3v~8<(8=g$/^rϛ%?8wsI~H>;Wk]s^Q?K/b?:ğ?'RS6~c>Ow+$NW~ {o+Y ]I0s_Sނ3C2}|>c{ygϸ8O(󴝭 N:Hv__\~Wx8+'yy}Dž8oy] )%Gm}sO?pVq/q>vOzB~e1Tg#n~kxAu(PRLne&p{BqD/z)sɟbgG8>2>s}O,43g>'ʜnm{ޣx>:i|ϙ`^Oyeߧ>'=gp9_%k $l^&k(㒊s[h>ٕԟo(e=XiUw;>..xH|HK'*/e~TSUƟ3H⠿!B=CϪ|q~[}{il[z\*:._;qϨ>aWH޽B}j<yx{oIQj}W;J]8r݋? zcYT8:ox'gxΓGA%owč?c>ZY]ݺ{{)xU?݇ߧ֧GNO8>"擪ng{^r,F?{ G4uA1qYK%ozx^ϑyhH(k>W7y]u׸^GUud^T Oe嚕%/ ~p׊H3O3+n~o$0H}Ӊ}豯n p8v 'χ)w^s|U̧O'rJ<yE]ٿzs$|W[:bS~kqumO<<{s"΃~pŅ{ys1Qq'wgp889qxZY\y9^py! N?mq?!GwaGvH]E|yf}/{.w)˚a?:s2//Ǜ&|&7Zcӱ\5G˒G7S{3THi?|WIoȷK$T2zO+= |!U#xE.3`Wg*^.Rp)8Hx ~NL_:~<o$gE2ƼSu;'"λ3$w|/x=wC 3R]Py8_p·z^s_R!9q(\b\xH[5 /E7sQ|N=/ yɷ7s3KJ<(V!y g|w>c܏G8O? _λ9Qh4ۍ=oJ^TruiO.K*}~n(Or*rUxe$weS)N!M>=ؚgωruq^_I}g8?W= yN|K*3zXx{44xPwp-qIzE9ǰ.t~!ʞNϖg ?Zoe? J s ꂺ&^)T21 V76ۣK?/z4LC9_yطs>gHM 5j@Th(vР6BFIP XcHȘm(~y9<}>:׹:{.p {L~*Itչ:ױ۵y|??:Ekj;&\ ޻x=\0}O?$W{%_|`/n?Ο­{ί{ީkP%nNgo^fC5ϣ^|PY7>7?&/୫~eo#;ϟ/m<|`ϋûxC椨˽K^uq'u^P5>}kEV!i%?շ{gy/{%3Y} ou5:S'}^ Oo~y[' ;TG>yhEK[~ G ]>_=7WY?M CLBn>4}SR/fݧyԡinqHoM:7#u%1x}׈Nj[w`q,{ڷx{:7uSM%{>q?>ӷz灍EA='>POݭٍvWϽh?a=$=絮&<:~iœ#>_UNf_7KR's'4^q2Gs`'kkϓwk_mS,.֟cp逤8qOՑM;c'xi7o;su 7Zs֫:׹X݁q#z yͷj>0};+_uM:Pϛu40yߥE. k[R;>,Z眹_K܏ǓHN3fÑƻ9ߛ｀?Ԟy=~<}3t:7/c_8ι||n?N?|J 낛m~pݖa%OUt_[4Foɒ[?ixY|V}|i{;5YϞ?>胏-E\W~"?n.z'+Yx_{e~9zH]s+]X1~}$ggڃKSa}U;u`=KN|ҽmd;V_mߩ= OG-]fz~mk,l}gTqn[e'ˮsR-{M\<>XagWX|Kot=n{%;~{#n-y̜g o=,_ώx>_;88P};ս]>8Oc j߮G/购?OÜ?;tcz雟]OWs UU}.s7wWsE_:?K|^]ZIi9v{۟m6zN؊qױ[έ(}Nqk|q||o&Mv@sW\wn=}H;m3"~{3W5I> gGo֯I=%?PV/?n7Zޟ)n:)znðιA{n9e_B8lϹb{?>Y7N,~^O#"8aWsƷ=Vykϧ?ީ׳~~|v',(nƋ7۽Zqkѣogc\{EAC↞8,d۬{'k|&m\y`g{ozΛ_|g)܏({4N~qukKNzux |Z}܋-űpc]zYW|o(GkNz: K p /r :m@";V_[o߿U+Kxu>H3x-d:Hg9~Gk>Gܓ65%ߺw-}w Z{jQ<^%~Fǒ~z7ޟg_گc<^܌oGqn?I߼M u'O xk}9?}/OZљ.}qȮ3kΫg9܇gh~yFgk =vy >™s6XOy2uܵsWG3[~U`-yt#^E_]_.s[w7>gf.wӷ5|⽿Ym xvWZ-G5',;wü;oڝ7ϜyO{}߼n׷lI\`Ooәex7>֙:g\'d/1]6`9x::K?J|xvW>pC>rW<:g_V2fؽ/%7^8ןp1/{Ov]{ݽ3:swþt`o}`Eͣ#Nw)y/s矹Ϝ9G'0s׮r?9esg[L!y3`:Λy#]n>V]c/O)΅?\gϱt`s?~yYv;Wx6lM׶=Q3g9i}̊O^5g.W}ۧ_qΡ-Os޳~ Nyd]]A?껟OQ3G,Xo?/kpgKow?ᔇq^7ۃ~~+_=h {v`~myv7=vXǾwwWo:sb9s?o.{^W'{'}>ϟ}k/WU;|gګ׿߻eK?k]ܻh?g:;5WN/?d m:c\f\|m/UtNX}?1k/ջmً>Ƕ+ ^?{E} g/l{?yoo~u}w{_;q35~uZ\';_~|g}˿|~u^9^8vCv|}ˮý3ԯ #~y4w7_/̥߳ϲ#Ͽ~7Z\ঋ6_>cVgW=ѽӇX;o?߳Α}u|MU߹n=nmowg/{k,fOXm>yIoH漰KC<ʷ޺aW?ߛά9ϝ ͗oo}˱=կꤎa})9/>{4 v<8s>Od|덿yo}6ċi1G} _G_qIkdwfL/m'~#ϱ'׬풣v);9ezϥ/߸ݾ?s{o^{xO76'=Ir6X Ŏp9;.xß+ps>=GyѳGՁg{>gƸbtsk|y˞_7bfݿŷ;s';.pXt7ݹ|/_q񁧭/q5c|_tʟ} _8xʜ3>+>L:c8G`Žχg=ħį:[%Nj|=uo+~9?9㇛l7qocp7ϽWzs9?|n7 ':-ÉFw9'q6CxX\{W?>qv<5/>1sܸWF|1%o>ρϏ'f53ǿ}=߲M3s6yɏsGo^yY1/O^kߏy==gG|̷zyϧUJֽ~alg/_~]J|Kw1{Gnֹx9;g9#ɇ`W񴟪ChX^y,Y.ltV.z+7^ y|/C賱ߘyMl9\ѱ4|V'sa\wNiޓNg_=?%=o+4nOUf.Eubo_u>ANdQ'~֟l4עLԍTG ULâk_30(鴘B'T<;Bם'|zuJ{}0Gr?޴~vJyy,unE?ļ/omdsTgt/K1tjtF;g-.nԿ^E9D空t3wOfw9q:~'NlXνt^ݻηf2W>sz}{t_ceLA38pC͚K bOP̑}=Zz#CG]ݰ]WD^V8ߝ sL"wT:A+O=*tY1ȇ3ɹ^YV.y+\7qͷn =~ٕHIWtCܻ_97'KCԧ< h{w~S"~ S gZ@GU>[WH|̟[/F2g8tī'U >®wttfM >7C{[̯ܛ6:W ;du Z9{$|йKCO?'M_Ity=3Q,\}qrS=asO8C>|d}qGDǿ94&~~CO|o֟kFy_>F,U;e7=E1i:g'|[ٱx(]]p=1ςd{?{/;7=:wO*>i<<~/Z3>οP qGMz杻O.sģ3E"OeO߸xo'/nyWA WTW/7{xydWtHٳ!tx/_xܺъ>huʓ](pMHxtv\ y'avŧKwxw*.j>^>{C5)}t gFͣ<?]޼-sќ]\F_ž%_3GQ:: >ڼ]$}CQ^9;CH7g^9`s[|}Y~.vQt=Ӫh]7_ޥs~㩢 ט/'18|M~_}!?I=?|uy5S 1d /oʧ$Ux Fg,yi,9T Ϫ"̀?/M>z;_?^su|֑~zaH zxu@"Q2cuóV9E]%_OۿuKivB] \5;x-s${u'4 ύ[K\ty+p;~y6qmy+y.rVFtnt<2/W~ssbu%_Kg;'_=|QLxJb,Os}9 )y/Jށ}mw#'Zz*!? G݃@du}~xNo]?kNꒂksSM O1ʼn?7sċa#T;$TgYs Xۦ|]5o~K>]N> n\)IŞɧ}Sk+x/*n39xP9'(c4?N/kAy9p"y8y'|3]3u巓7M]Ӡ+8nO#?>A㴎99uO Q\y}[Һ\?$ּ?MؐųW1}5}>j&8՗6OmBwBs=?>ϹOb O8 \|K֏ʫ4#~s?Ly38 wٟM|}LjK7wJ=>3 _O7[W=.A=ߪX翧,z}E.IOY^}k<;O oS\ǮX?V.ﳼ9y҇95MuE,ElTWsgN7=/'_nz5ߩFzAtM< 9_!uP">כ;J<]uou^[_Ի_gd\zv9΅>2:^\|>0.o+[>e#Txԫvx~k@Q3|/kn1[-;{GqWSwK[>N^(8ֻ5\9uhYun> O_{C1 ^j\;R\>/u{WwgQqSāca q/^:qM|윽rNճҭ .[L0_%7֏/I}笧^Agc[SW"|>'x~&kpbGh] 3oWoj>S|/[jݼy<8E>Wu#W'/˻kd. ֹ5˾ू3ʏ\MR`vx̾Tg&¿g\ثw'/gjR-3G/H?dUtKgY0tʫϺ_2YE-||8F?\Z>>A ԷfT⩞OB<|X><;e)x}k0{^9#sS '7_sn7*/kjmZw-Q~_Tz0}cWi,uzwk}/|i\|ݱ+|Nz%qO~M2:-n[~1]9bӖy d˿4H<"׺'P>!629C?E/ڿC"z.lWw^2xCE^ۍ/SS]7wo{~_hZ~أw'G?g?֧_lz. +ua{>e[K+X{ZO8~8yoze'۾9gW4q}qTp } >ϩw0%s[7%}1Ev_\o}gui6hô'aι<{,<1\N'ߙ|;ު}X f'jo風kuoj$+=>8?OG!: =O:qUcu07<: z CS7W]U)z2xA=aY}h n\x~Uo'j=>趩C+?L/{%|c1Ad~4{&:3hA6Nh7~C%:C]%KsbgP\TCs..} op^y}꘢}gߍo==N~}嗪|%qo<'I_Ty^7᭏:|ul*ɃUFI 1Lu1;9^bt䇚Ϧ[Wȯ4z9sEI ~(|!^f钰sz7?>"x?mu>jFTkep??ѵPOL;>gpv:9w:ñ[vbmq 9Ùk`M} _= \.DށNx@H<ӏo~Ayu}T%oAc{r%1]ͽoKG-񷾉a܇k{[x9ٻΙg׻Ek 7i2Q8חWg<3.t,_͟wz*tSw#_:^|WwΜ>CtD-^: :WEGI[W?]^|o8ޒ[}jvX9}pw|x7I>}ֳߊw߭oeX޾5<2#$s;?[wAO".ֹkWZP~ #{%A͑t>_1@˸nRc/:oZǭ^ٽy^$Q/3Ϟ^:Zܫb2f.IɜyMSbsl3\sMZ`._<֧~.^얹{AxRZ}mVG?Y6~_s}ǫwg$Kםϕ@'}sxNOU-?0ߍ~Gg7ݳ_n?|<}. ǫC˺z~js37+U9z,QjMxqWλjru͎ki=IΉ}h=T}%#YſG9gys$`@kuph.  >`?U":xDzKs>յ#oo>"vu9fsO^|[W_6vnOiTo6>Ι]禥o-yxݒqyk[롂G&~ɇOgWרWH|h;S߹oQ~q>sFfzw\>k ^n6q_ğzȿ2UG˼ gJkaE֍]/O{|'n%{,^?:XWqp'7Kk^w)Nԏ:Q=y*5tMJ#Gݾp5O{o_i}J''xK=\/˥TM'ϹxbvẉYmۺVg&t|0W{d=gtԥu {EAJD G?]7WCVu?iŏ‹={p7C 7[o ^?}k_|FoEK|oة`[:go/}QvIt_Ci-{ %~awgy wn뎺k<k xW'OI<_ZWjxqL :ɯUIZi=Ep'CBda'o3B΅sڟ9h_bgZhtKy?#=bK+xF<_CH~gsܟ䋏?;\E>u~8R~-/]/q.?twcq^n]u^]Z={k.c=B~9poFߛ3aV9^qGen9s_l7;;oڝ7Dg|w7aax47nùOph^Q:|O߻ 3g_0'Pxok¡p[~7{#{)B<99Ϟ_un!?w_vٽg7:(ynQ=Ļ~<`.Ksg[|ylq V8|?ux*Εu=~?]a՟{|m/UϳC93||nϝ_C|sCO$+LJ7?7 =TuR=>v6}ɠ~Ƨ𺵗]?tRQ7T# *x4B>UB|f.Lw|:[{ &yy^?s_ît/\5.y[~5?:g:o|߼"u]:=Gҹ4G•\!N([kzgs ߺwo2ez̡or^3{sfx{6?O j.s|Oq?=|fGzAO{}IeGϲ~}m8udt7κ;nsĖ^_G/墯.ۯ~bի'>' y8e/úν5C?A뷂'/A8WQσ2/.^OXp>|~_y*qB 7ڇ#KMOAuGZMoG8=/?N My^:>pElxmŁ&?= ^8~peN;97?$.8=}kTi`p{\̝]p04<%/|7q*v?+W%}/?{~Co~9/'?{ y?ϹW/3pcg/"<8Y~[tk?T9TgR||Qξ#m|̏\~5sD>x. p\~^T1gw}˿|~ `ݿŷ;s޻YLu:eI88@ .k'p}e֣f?~vC~'_>yLxGN]Lu* oYjzSf1^޾ӗEdN>~z~<\:K"='xLcs_HDߐn]"4@ܣyɏkZ'}!z{u.C3upĬvG}l.zʼίk9vOzyAЇOsy.{꿪y+kܼ܍i~5x% @$f~IV~ҡ:YGysn27OA;copt)g跇G1՛H`u#c7;W/ ]Nms^nuU\wk{Qo?S6]k~|QF?ݹ|KV^o]z}X(}.[sՙם~>V8_GG; pGvn>qG~gOWK8pS,/*~OygYԃg_QyDxQ_*>NyNOz,š VYc ~3xnWA^胯]\q‹[,Ry}i:/K\{Go=M*/Goӽt^G7t /_U4sc:B[&>OsOeĹSd냿)8gGk7zSsWgo]_W_{Kse3umI|kOl_:*+Z{,7g9ڸ~7뎟ogї}/Tϼ~G.G.x/vsK??ё__ ]kETy/wx=I\VU})ϟߜVXܙ? <ypQݨĕ?ƥp߇O{;t1y(sT_~6|z7?R\^g0C s.<޹ybshdܛ;=sG>SG~z5g!یG/38j^~"~;sN:AZO)Z1p!@П4Wi=?H+[^~ ={y]PG GUw.B쿸,'qOZ_ρCnǏhkO1" ;/iY~Ӻ>q/;\*Ǜ%.9\9ݸϼ}yWvk77p{u=|˟v?, tKݺљK+b]\c8~~8Y@#Ǝ[K:yԧ< =}KcrU'͟ ~x]]}Ssw~]IiNy_3?ln-uai;+Oǩ>[Gn3s6^#w-?DZgj}ԝ87ݾ9uyS8EB}@9GsuEpx=Սg;YyQ?З(:7Vo(uO z{=塵:փnsߤn/˖O^{뜝S.c73x ߥyu]s?^&}&un>VZ'u_Q:9g ζt[xO!cTg`;zSg-{5}~ԫO ]T?޴oF]P={>\ODsu-[y5aaWy'zQs:N9kW#-uTO50(n}Q [o΄Q ^WWGpy O~߾߾Y/uI랋S\ѭW vӯ_,OdO[3yT}E7o;'.Vי{}I=c_C~R|Bm~x麶9焿a7oM^\?[f=P3_{Wعv}7c3|5?_Ot>Woݥ>cya>y:qˆx]ϫg{N[wKM~1nnvocv[9=/s |N_t7WWmn})pU}uϩ.~>VY}v{uqxb'Oei1vűx>o7@[?g*;`ޚzϥğv> o_8TNA1߾;=sOv18cZ7x~r九?w;VNb'?;!f=g_v9?zӯ‹q~}ȹ7X7oGrV<Ê[W8}!կϯݙ])xno"j^$<~9R=x}>|`jQ y):{GJp5|9ě~nj\}y:Cx 8gyk2{_+Q{oثщ>xxǷv[#ڗ> kj/tx G;7xu⿋sz1gywL_|:H'oݶOtrKP&@_=7u\-uGJ?\H?߾f'mv::_U_?:K?G?#3珽A4o?kUx vYOOq'pBW{;|^,o̱Pp<~_ߏΐ\yΫsVXXG:ǬϮzq̯r>C?O޷pwgӊͼ_s!+9C_ԯu=~Z]^fj_YwN>ڷAWz.C#=|땾ϓ |%{:/dˏ-={9g|W)Yus.sZ_u i.[xn5W! 7t^hNS_1S;pj=؝iV=[ݶg=3Vo4uU}1WqwNͺ;}ɺcx{ g' :pp͛K=ĉUGه7؟؃g-cŷl|PX,sO#{Kg<{\ͬ~*}gp|g_W` Q<<wܣqyoOeε|k΁ Okqylt=cyw:Y5u4~NN?L'^:'f }2{OxW<'&ސco/ kCHqb';}n?؇گ{q}}˷FFֿs?hܓǧOz9|ug[ }G?9x9ı{]|$oйwǗz_ќa~kv><9-M7W#syjqs^ٹJ6'gI._qz?~tֻCq?i?p{u.k)eԯ%SxJ6q⧼_-ﵞ\T]?肅<_ۺ*yq{q>eHUؑ~8n ^yn!>sԏů׮o?9/o~FugZh^ߌ_߾oYA1Qx0X]289qN>^­I?7oV'Zԍi_HbUw̯VGu'my\] s9Vq,B쁺6NOwS>cx1ܙ:'o_iS {PQ_'~e_+ީ7?/.v^\].'Ω } kjgfl|N3Xp9WsE_:ywn]NHy9;|GxQD?n7Ieα{wn95{Q9m\9˳oWt8? uϽk8i_xsjg[3I [wu_S>+8|3!_nYlm޲y _  {͏M'6$pb?qΤڹG[ygUO(~3{U]N'5z:_ՓyvU_to^_>rQw>|y;ՙϽ~ 3 ՏQc/W>:t(c7%,t?bįtIΉSrIQ漍}ޯyWuk ZH'Lj?w49b+9_$?׺QN?sw N?59/C>6~5{cՁ=Ew=Gꈓj6+8P 9?o.4o5o5K3O?z򆛯\>E_|uRFuw%{w~O yӿ_ËAut顫L~?sʊYFgWUsEZoȽcjw]'<՗߱I@ydu!#=*ykSnȷoe'h(^8ؽh_wo {?ŝuϩ+zWT>ߖs?9Yզ~;Pg:~ _ ^9M7˳;n8C_8o+T__VmqQfO38ﰳΕ:cөOϟ/mԾxn3'Ѝ{+ǚUAr.OG}K#Z`cƾ9l_|WkygKV,Nv^xLHfΗ7(vWg:!ze$T\WUį÷N7_Çaw×>rAy2%APn}e=g;)nmsgMխU_n(8=Υx[GgN/qKQGKF71][W'Ҿiq8ߧ?S}7_;7>:l7]MGq#|\/>l8qS }|^DM=Wv?SP6:9/W>[_X:v:7nLVxԊsk&Ϫ[1k/ #wjTdyaux*/ .< 'Kcqjzx_w.Q3$I/ܹ翪s뼺D1ġ c^pz9X|u_*?|K7/R^0 +[V;yc׸2:åoQq\3N|/Xtya7etz>uf'5g#/9 [zv>G?:Se.c~ :?#pOtq+ӹ걃;d#_/Cx&طVO0_}4ϽqV'w>K|s?:?l?K%yyf<#4 G"+9 _>iqֹ֧ql+~I\ѹ`9d.An y_t&nNC QB'S> Ρ>W wg%;ބgvuFuN2_v“nϵ.x+Y?hC:~unՉ ?)?R<;^Ry{sup u:oXgP>7{;,?7e|΂noٟۙkSMW/V7b_'|Su+Cp/' tV_TG>YIQxׅ{etnEfs֜2Hq Q3Y+jZCYZ d=_&ܹ׹g.q'^Љ k񟭛w^~񷾼+~;RIE쇺~+.}ұp4@iB~u-oiGxο>:ѝW~0ǥ'ߝ6puM/ F ?|p^5蠨N] n1>s3\o=yS}iM܃o`[OxL׉_ˏ8~W/2n9#/?oW/<8f'p嚍W1W'޾To?hN]}_'G+MmD,sY%V];q˓~dûG//oo4qq^Oj8n_|s55; k:Wދ[5g:)}G~}?}w򄭟s?:Ay#NwA3~ڸ,vvSQC[y(j .xdW鹜W[^CuՇӪ4}o\Bw`A8>4uRc|OO_r9>O4j'd-VMi9ZO?Aϡ}ٯ3a~+7kPМ5(xq'Ϗ|6)*uw<^|߾?>:tYKvJ{_]7QC:_#}o+NΒ|/vZXˣO }k$?,X-7۸vs/O[Ox\5ߘ߷֩_QOkNXv{s}\<;W=ן]Ѽ8' רdW?;J9xΗL_ʊZO^Nj}TsoqםxC}Xg<}h{0dWKNGz<W1a/α_/|յ󈷒G;U؋S윶9ccV:s>{G;8Rw23^Fu~6v~ N?~zW֨`g;PwrEO:$?:Kz.R0+K;ߺ I?{ճo7rnۯǍ{W;Y̓h2^S!Ro.pU7Xn#"`/1+E,r?<>Y\O%8>\#To}O_3ر[O^~P?; Uc:{\>xutS3U.kMUum2-^IC4g?sOf7S[{2i{1iɜwxu=rJ򧓹+D',>qtCH!xzg+NFz)o/7?[K34?+ϋ'%P`Md޻\> sݐ>)0?~x;;ꠂɼ~xѣ܏ߪ/8dЋT? Be\9Y_=~w2K}.9/\VދnNzwo'F%y)Our=/|G<};7ps^\O?}£M~>(v3fŬˠ{;^U-|uqQ2zN'#~9~H|{<~T?vOz#Ńx\o뤜UT c}?Vg3~kwcG?<~ M\V?.j yϺ~aE_Xw#Γܱ32:":,. Nlݤ?s2wy |o_B{^ҾykWS};Kwb_2u/;q׮r?n]Qus^O:c-dw/xJ>un^QC_uS+_>_Vzxl_fy_JON7^x#ɹ?2r_|:皝G{Cf!Ńeت[o xߜ ~9!gG7'sjݗ_eyOݿ×3gkW&sK{п 3ٺL}yW^| oUe?޺=kōkrO.Yzq:TOywž"gyol5س)^ոoι?5yk|~Hݔ]|pO>}vnCFsț?3 ttZlF6v>dW2_}ɳg:70;qJoWv]h~č_s?dٯk1"RyyujKG1v_!y1wus) sM}x}};oS[u$ED/?gC4/*_esP{.9CwY=<ߨvSY7e䞰gH>ԕUOR(k8.o.4ߗsa?"n=/Et}G?Q>:Cܓ<<غSrGuAH[CU?/zgf{xC_}3 '[u鮛r盫s,"p}ov.Wu .|O8֑%w:?P>?7_y7H |Nwsr[= 7x Ϙ} G4F's/~u"./MSںگxX](>P<8x$Q,ޯNi+~)xut5݋ex7>U Gs\>T[U+kQ /Ӊ{8s}<ʿSܱpcGsU Fj0g{vn6x}sΪlSZ*_ϵ(0Zs~ߪ5Σxm{zS+~կGgISuk4?H3#Piٸ7EAVg9~r;6=(ku)>zfU}?hg;G tS:~sw?zhK?¯1-yWs{uIpG138\]~;7;p]zv4H]ޮ}pz$<Lp$Qs.q{_[CW-7;+ >yK77v:/ y?|2ӽdNMP{>qнTHG7>׬sa:L~pfa? ih,}WJ|zQ]sӿT}(n;srt>Gn'#;ggbw[F< ^lTsGsuN4>+۷6oXe{✟Mbm,>Q}#GG0ovPI~8C?:du?Îq;>wnP]-sǬ|\8&{6?8ywh]6~WHQwΙx]?:4/29׌.;$`3v0Ku)Ct?=zi3*q&^9Խ\<ܗ1 _8Gw7+! bٿo~<9m|ߝsvt1ᳫx|>CqIֻ<}dq{[qL~<S;xuyυ/G [yԡn?o-8_9W?jQpb珘S%OeFgϏ9hRHsЅk;8cl_[u2 4L\Cʽ\W~ܼ>`GPor!>\~}3+^x=чӉⷛ^E|ƾ%ΙyxMiOgusn;ZZ\)Wc}'A9_6?#'W<$,Ζo>| Y?8ɇꪪK?HT.W`[q#_Qj\>ECEyMdW7Ϻn!Aӹ𽝻}g7bԍƮQonQၷm_g 6J{σַ:w= z=̽|ˣcO1g_j/8%lCKZߖϋǂ+گR]|{Q=$81 o_eu<\ymk\{\Gz;~zY˰cwʿo||UN}D~_Ρ|Ǵ^1׹pQΡ9)k~$9=TocGghG͆h ,~㾶NC]Ls:w+P^"%o- wC3w?o{!dչ_ :Ã2*뛇2s}י{y'{O4WEZ9݀g|8ptopb#U*xݵm͏d]}^U6*v:tNt7>#x`OG[A/ѫ/%:r8'C3SOG\EO/ؿs]l{h2lA{WIpPu8~~|H\b}4vuy/+.iz;TEO}%4~{伖O}|ET@qs; oCr_X`7Tמ;|U~]}Zp`!sߝ1_~~lgiw:::gn*ްEL~OV]؉j}ZJMqZ|jyyKy|}dt>ڇ^tkT'qskY.ͿNyёyC}Mr/'uco5{NPH~kGOe >~KN^y]Ýws9?69. yW'GpۇL\ǃ7aV/f?upEA a񏝳,O޷:IvS]_ìSzzwI}iUg&75uczet݃ yt^'{ԯΕ;s/kܼn%?yٷQeG?Η?q81ZGq}JLupY_j5~_\8s;ωWp[軳^{W:YR_3]?O6'8 tR1o=y;_\~T+vrpyq3;WGܜ4ſ[on%r~73+yoݎ|3녷>Nx+W<߹WǛױ1巓osnW;O}(<,\ݼnF'97:\s #_ުvBյ .Ѕo9%}PZ{˯7gj=ij҉}mH++3@#Iduh8`x1-S %NN_:|uZ\y>|=}]?EDu&roz;;O޶>t2uIs+#x>:wnz~W:\xnd[xf4k[O4ꏩ{Uw7oߗ~L씸sq?Wh'y$ao(|E?~:T2<8 я;@_z1=|aLU\w6"<;{ U>VG[_kzv͜#~_iEEγ:uusyts$/挈gk`E߲gszޫjEM\?cu/syčKn}y>rz\;1c%7'yzi]Q]s9Κ_wow_G[?u -$u߷ݸϼ}79'i 䬾>v>7cXΏϊ%0NW~:[/ k?4>@qx;a{>}R;<Ծ_I籯GN^B]]:|dWݯN>"+u眯 3/}& |/>$ c7; xq8ofYIɯxF$~U9'싿? ꜚS[|EtOV Q&;R}{n|<)/Nu>s% ޠnޣy/:sg|AO8vU~ /ѸNU GSoO`麴?-.:OyǴ(}Oxu$6G)59u9|νW-'y eO%||v֟z[wݵq]M]SW8sbr.Soy2;^ NqԕGq=jA3Kļ4vߜîk/׺w3MqثO{^~SxG~ ;?ί8(yއf?3/>P}'b٧oMy~,`wsz;_uEtG}9_s張.}O;v_i=HoO&=ͷ}[O_ա~zԉLt_73C;U]}wglox1~v5 ?^]ǽ9wsWQ}} 8:-*,;3[kACJ{93ym8 ®nˏ{|Zg.zE'x݅I?V ީ_NpGsw4?ރ;Վŏ;Ωsoû:w>?|dj߿qnhߝqiP>u9i=yqL"/7Op?=a=yQc1~3_ğ9_z4+ՑKGu/\Ip|yZÿGñx{um޹$.;ԏ :3jGGO;闄t.ܫUs2k+ܷ线՗ӹ}#sӟxy 4]C7?}O}OoYd/ŇܟO+}8^WG o]?>KYz+VuPRE˃v\`:W3SVw y2{,80|MHϥ:3}.}΃D<{9[:)tzdŏ]bx/w;@ݑg[GS'ATl/ ufa܋nt5}Td?Ov9:eM/}p \\)^|دk}[pz#}[wunVNuV'LUcWԅjpZk+}%6>C7<ܫK͕ծ18џtK6oa-^-*.:[OR]䑭FT8ҍmh{:xy稧~牿bW;%m}GVW4/b7࡚gk`_stGؠs WZ>ysv~N L1t0+3 g><;%Ϲ|/愴ܩqlP˚k3+U׎[x ~ӭb/?'c/sz/<֡:atvv71ޣs*yv>j`Q>,|o>e|{l<>Nxz;韮ow`gNM  tg4/._>i ;ѥWx\_-}3?ou/3v6wK}:9'|\^Yz>=ܹۯ8»us~z98~|o׸<_[{'~͜־{f.V{ؽ/%7HZWwuge~lt[,X-7xf>谾ƻw>mg^mOg~nmޝwtss]x{N߫h?t}Ymϸk_Sg:usÜEgz+k'|_{g ዓ?zcG)xgr:_0.z~"Tyz wkoϷtS's {'|8yy:4||gyolsާg/nWueM>ğ΃g/=[ Y?][~sQc+[s'Gs' I߷w8߰%ްs6yɏge [񑧜;eo>uX<}}|75'wJk[ٗa_;WXsEopw׹1~=j838_~.=t7[oC>I>˞k{o?ѻoz=>d?cV_x>}ӶlCv}6gSf~|7qa&yYvy>KSY/+~u090süi}r/G~^5oJ^UYEp/h<y/ )=|xo2iĕkLxg;{yC </ef{WqyO>#\0ncI@+t/<o6k}/8󊇒o8/y=ܝ<*.N 78}U_=/qc=ߠNso|̑՞g9%r8ΪW ~>/^]˓$ɾKu>aLj2wx־:g (ww׿R<=<_e箻~}O8 'ˑ;z^#;#v@c;+R>8x/|-ml? |rЇysxӬmǧ8{Abܹc1a'7{e#Nw֡Ş qtos<{+_b̫o H,q\@ (?\1R\l^oק . / ?{qgayh8?OvI>?^Oe'_χLJSuKtl'ŷd'Y;yYoggX/eGoǾlUo?ݟܟ}oF{2N[C_duםמ8^>Ї tl̝]tRI]:)nxAqUh%yƞ-^;xg=sIxqS~_޽uΗ{OǢι,74C_txHnpϧNc oչIp _=WSD~.|CܨSx!uIvB ~ Z}tޒ9% |鼥+g:8ܛj蜾N\ЅgTw~?o焇o@~sUu ߚs*^NKtpKF:v_뇧o칭kw'uWu&'yΩιOO~~o[g>=7u/sb˫75}{24ݺvsiG35uYir~s8S9qؙ5x/crwem'<_:w~^< ;s>#U79v}SqsIZyU'8%o?P/zR^䗭}K[7ع9'CW:Gn6n<n>sN샿W_'#"*YWyvsϝ;6xAP-|=ay^2>g'xs |ounwtEs'/'_9&ǫ\nx{'Y 1Ss%u6xOЭ]=g+cVeǥO?v)CS%{q85GHnN҇ISտ6O~(N]%k=s;P}#'so>_dQxإN|55W?x S:j8ӸsW? _xLCy35?+O]ǫ|n8}/{o<לy|碛K|q;*ǖ#Πkww~V琽o;O2ߝ C48~:9J|b3Ϳn+^KZ?"?Kk/Z5O;r677 \nUNHχwT4O=VsD+GR v~i o'_ǎu'āc=^sb';2q;nyPhu=VۿKϙݗwW$*wV_}_حY?}ύ<\c5YO벏U_*З}86m_&>s.?xuc:cA'^=w~@D_KNqbΗd ͳudW8}̵p!c<޹˹C~sӗWWxܿT&;9PװnrLy0z}.x G^`~HtS }:'4x>|\0w%]عat΀O;߶wuXW4~_^[2$)_=Du'sRo>sb^D<.O!h/sOtsؽQϝ7gw13:0a N'1~B4U5;WFߵmߺ xpdf~s2s˟Y8r C/;O׫V^~Q^#z7Uz#%:ܹgpS=KvΡ9y]vsU6s'<՟ 7G;7)s>l׹asC[/ }63vB^sV\MdN{-Vw<<]dIrAm3y2#~e|x_#F'sQ@8}gv :7WէO[=$:׎}ڣ}$.Ƀ?;H?+}vw>Yx[8UW7rj;7сWֽsp*^H<V_9{NПC'e31d~yO0̍3")|:?OF‡g=8q3nU_?*<({ֵ=0&;3sn~1/FEG|ώ6_9ڱkuU7^|ï[ɹ釽ltuB>aW;/4|sWh8%]z} ry8ZfR\.SӼWWg)~<ǫ:L2|^ /w~<^_Ԝc/o.?N3mmnP-A__+NE=<y=߲|'>]sV#Fu.<ͱHg3>ǁ/W#?+{}zֹ)oԹ򭣔NJ}*:Ow<~O;;Q^[<.7K^ko2EsnX1=W~.3x7}U[@tWg[}*W$WP .;^t6{8zR!/g>SxE/O7x%aͩC- rR:Ľ]q|<9}ηB 5y@x<{!^Q־ćsװ;? Sxv]?~z~ O}쀛kֻfSs_7<3WE67|seq:<9ao9>xuup{&\9h||}~3y*xSX>" ^{X U8^4WpYyqc7ĩk]-yv'“d5 )Q~scy $qtFsvHs! N]XZ!ĺu::m]~M:O?kxΉ$‹,x˲5aU-ok:Q&75:'OmpkO??NO8F8G+ TrPu4_{v;4 ~0|lIb7/6|8:`3L\)O*gm3^JeC11اJ^)s|䜕sOnx%C^ܴ>W:>\G@]؜/;ųpol_dΧwϓo՛|,=h5kt CϳW?O] <+~$|{{~ sap.:7]{=)K-yH< .RإGm;>QtO]a؝oӛ^~sR7#~УYCޜ)Cɼ6ۯRhuYK'Yxkj?[~'k\jmƮ)8= }bؿƋ3LW=?=j{{ ⡬+O589=Wyxp}/;/z:}vuxxMuIc'b7T: 0sWVҁ/ءG&^k;}OqI{Hϧv,jlC] f>>x0u7g[>#q}-j!?#9qQz9~3~u>ާqa x#.<$.wr{FT}aY Q#vGՏu;\HE|vS)ݏ`Mvoyۯ|oXw_8|f-.W`cԍgZ_x/ c'>pfxm|C~#9јh~oX4q*~G 4L׋8%q{Dz֭swx)k>!v7d|d͕Ndž8:+;H_ޟ~w\g{}:H z<~zZü_^_zwW[_6C鯕'i޺3\\{*o;=7;g._wO~JmuC :w _oy׫lnY_WgqNm^ϲ[Yƫ&s7WS6No_{#6(b_}Go)8s֏=o?rwNn(oR羽ž$n(F(qE/h\G{ޭ~zߚy=ωuC|NM\@u~z=yù#xSΥ:b ^t~~(> ^SH~8!|)p~7~}%# 3?8Y<]=Qo}?9M4b竣t}yN\ v:ͫ9)ukϽ}%Wk ._)﫞,g;:E᜝7~3Vy8Gtqo=ɼ AeQXqW|nGL'c_e~@ܞus NW[ߚڸ~ps鹨Wlܭ*| ;z~1}#>/LԠÐo n}n>[=A~s_?eʳeXO|mxsj1yɼ]wbGӷl<].O7vDξ[w]`;''>{:w%~?>Qxo?8a_m/^雷1݃q=ʿ裊](Uz:Zſ>?};}ɯn}Y91U4q?s䛇均zruSV<&T_aᇱ['^ z#ICur:YzhWAsbeKT]E甈;ѳΫz΁Twr#¯_G9_;Ԟ%^*^KڣyHܫA\YM݅x^|Ug^>"vع,z|W2&8W{W~zeO寂>| vNKoz&zĩ/[s76zCľ~dy6zջ?;j 'sd+8OQ9eև_DYu.yƽ8n{se3v8KqpyST| :xB9klIy v^i=E./i.2]G<|=N!v ޶֭Gs ۦ6N=m>CHjěLӯ`=v|Y7 YFF<|9^y7'NTo5rO:+ܧOmΝ:Qz_JLC|7v9;&8uq{xy??/sӧ~rx(ve{z`o/\nԇTG];6O>K\njtqPz/h|zmI:Lqk݌z=oKg^>O2Eߦ|x#ܬwO ͝kstrru'D?sk4#+X&%ή}=lAy<u/-gÏ9ȹhAל[練y케 \)Y{Rn\y8uuOd?Xv9xyr͵яOh2uc/?Q>%yiVF=y=_ѸY7ZQc<CaxKQ8#3ϙsmvΓ.o)uX:e>}1'u0M]:w;m?'{IuNktfsj7bo{^qOsqW!O`˺W 9K~}Vm ?՞?8o_L>^dߘ^o!T/(_^@ ~<ľljw\{I=T0lFqp%by'rwPP>nNˬSsϧv~?jOҷsʎ׿;Zs3w*.qk[Rߥ?Zm }|]LzY( ~1gE$Uҿ/|*>ο47u}y+dIrϫC1S Voo7-Njwu Kҹ,t/=?y͹4oz眛XWC:؅ᇇl\!xU/:ӔfeVx̏n:d~=,},X|6#QS{1YNg;wehdy?z ~d=7up⫶' XggIs'Kgs}2Y0i/3ۥq|~w ?=+l4Yզ~;AtdO;w|cc_npm]{ί{]ɢt>s;^= :N7Yz'/~+|7g^>[f_E~Wu+dOК$ol/ɢlՏ O4Y>rOvēp,NU>vkVɢUV^v|;}2eV}d|椽nyZ|%_dޣo{ qw\]N{VwN޸18{souw&:s{6e5FӏZɒc^/~uxYm~q[m{L| oW-Y|*{i+dXyO[~Wy><߬L-?1yG_|' M&7ڭi=ͰNy^gVw?d/qܾgߪK' Yi훓k~k~Q%/oX/=q~.~%y> gsVeg=`//:ڧW[|Ȃ|ď&v_yϽE/OKd'>W]S:ڃŷZoh7IpnÿT}Z-찋v?}os>,{7na{c^/M촺 wǼwo}>tɒ'}n7TI:לּN˗ĭfR/X%})qY-or_?;?=HyqUaїsGΩ}a׋.6oncoy/:sg|ᨮoDja?ٙ)#j}:'GW?^UG:iMD\.Ykc/ Ǟuoa'Kυ[z_ᯩ?lTN'>,vυw:/ߡ?ūW_ /=vXkAG.Wg=+tc _-~wN8ߺ{! >Ay%ozmU޸v*h9v;n>NS}cx!wϝs~/tⲞwCl:>xk{KS%`tMbo<N~U\.ޅ#G٬y ;&'ׯpW=m,m{µĩ'g<苍GSlx83xv ?Z)|{ov) wSE7}W}i -<Yp7.'>GxѺϔg'jr'.ӟ8 _)vcKxV~\W_}pߗ^~dxiAyOQn!90ݶړE}cÈW޽eם%;~{;S|~K~I-|(ޝ[<#=|W_(0[V_Nu>WjrFxaV뼓oq5X؇P:`3}ӳYRw|zRy]c: 6oE-qyI0YyǩA1m| yFQ:F{iy]\uRХinM/~}0gT<^@.ğ9ۨ_q}Yx>שoDuSR>_ɗd[ϣ1!St[n$׈p&I}E_ڛVߚ~y~~ԩ^m[Ήq$:ՎW:/ח׽_>{ #>5sQC?TGzں^[WTǮ7ۨn^5]$uG+>#37=ozö^g:؏L=a FKިsTnCxGS/OlݪMPZs^~8n|v.F˲9 QZOԫW_H`+}OS>HNdK֭>9} OuoJJY@GuoβQU/&u_A%uՅP"zdIz u'űV֫8 ;gթOڿF?!z%{j@C[J'"v޼o nyES/^]h~ڠ 1q.un6}ssKgJ5cyy!H,x=?ztS'3?>{g4;0)QJG]g/Vh4:ScOѳ7GgyWmt4Um}G}_FWf^gps~N?ݮq`U;Kj^ cutyn,~7GHև_~ݲ/ ;K?P/}ΩοgWtu=?:U7X|֡7Ϧ>ѺOqgۗN'$cɹzAO{C\\uq{!|EGN_٬=uϬ?`R_:f8&۵w洊X_y{}";պᑝoGI DqyKd_ߪ.~X;C b:7^ }s̭ǔS;9K^ntzcZ~u.wij_{̚ڹKc% nߕ>YzGv͛N_X^~jRT7"3N'=-^G,^֯y<1r5'S<êE/T9}L ه؍S;/"8%}]o=Q?yq8lZ=O~?9?﹏}us7MRy/qu~=ONԡϫk?gA{sJsnix_/F/~v;W\c+;}yip=_\~:utpc{{QW=\f]C:דyczkt2[d\l}}:}zgʹzw+y"u/}}[w9_yeb|qa;l ^ ]sgo28K9SݘSW,Ժ>_Ɏb[<$_#:~~D3.=S^޽εg˯\`<7q/r\ r~?E*u_=?yݩWuv#g~9Kǽ |;,uZѡkr>_=x}9 ӖOWGzEqqoՉI<➴.!_;νd䕪_Dg ~6׵K!K֏ȇE7e2&?GNK}>O}Waq÷4{?q5nyEq@9fG«Y|>{稽e'LstQ="gV^|]WC?:rZrs/n^te>rK>CL@ZK:0y_}汆G?~8.ÃSu=Ô_|"}E8G/~C^_Fx-ʇZ>oa}R|9ќyqY%^2}Jswt8:RUq';A:YG~l. ~Y:OKx>t'R6'C<'ڭT=LqU+;VV?0R} 9wxx9'%sn=|ݺ:3G*<Ω ?:qD_϶gLO5ew?ުdO_ʯoyJGuIh2E|KY l6|gm]H>a>uum㺩w__lUT-6p`89BX^@8yWUX 'ivͿCHr_>ڹ41꧒KgMW\E!U0~uq97w)/8@=Wϭ{y4ԇ};Xs#/Q#>xwDߜLۜc`{~?J=}Wx6BAQ $?[_S̞EwŹŇ@ǎTG]Z|šm'!kNEAO1V"k?{~r!v.xoV;>kǫj.|7d'H8~7.n9>Í7]92LjA=:g\^> _mNR_l75)_8VO\>xĮxs ԅ(|:wtYm.K纵?sK\;>+x=v?Q<ďOueyGۘ'9c9x˱#;͟ =깦=49?O(8}uu lOI]Qu;sK~?/8#v͜rx~>*o?^H>? {]}h^XO}w;9|۞׼36HUs~Wosc[6ҽߥm]EY+O91~khlBY{9 / qZͳM|xn|^q~εss$>=;vYSy04>罪s.4vYw~W<x^w's]3~7Kܼ^}vz#U3O_y|9͎kikyl8Q]PE/AcSĉύlVo~|Gќ$=lluoh?Z伊kUl_(_>>-Wu|bKu<_q V6Ϳ';kTe3>Gc|<\eYe/\soc{GǼ\_^!玽v~Pyqcq=s /YUxG],9HΟ36]O0kq眗ΧgĮ>t4|Ot;>sRu(4U߻]՝=̾mV]oCqv:ϕ{zگΥ1_|Kgu{< U}_P\:[86Y'u豳ԝ> yk=cw(zgaUs{;9~~z4_u/'d~G/墯.oחsZxx)}{ezO7xBuF|\^,spss5a/yO; p9X p|,QQs:}W Y՛_\x{ۍ{>ǒs |]7ڸ0w\gwe{n۷L\=x~0|ġ{Adc?}oW zh_֙~v忯]0~s% g+%pFΙLjxNX}Y8>8}k0'5q9~_ܑ߇sZ^x#_]=gZ2OVkZ߿?s4*?s3]0vs月ym;+/~EJgJwrKpLJjGWtۧsoy'‰՗sN4}F'}^- _n:t_kܴ>u[oC6>uōCcuTg '?Rw[E_|sP~T*~P>uz9돹 S=H} ޱ߫nG'ɺShnG{'g=Gr5O=G_a;OhDߏ"OG5'/R'ZsT}|-".WR\~|O1}ޝ:E'iݿ{{,-k>P\~N޻x ~J^饗+;v|9۟g:/NSxxG= ^=͟8j8~vg*O2ƣN{Muo}G'odi;..;yOPo 7w7Sڇ>&u@aP&}?3{=_?<߻ԇyC:zzA/W=h~P WW?SpxrGuO=C1qMs.|Xy/ <(U/ɯ21 ^O`_C[·z{\o7_H3qe?kϻboni1e.۠SXu ݹͫAe{S]7FHt~y?TAvuN(z|- CI<߾ ;?|/4$}rO^p19hC-0?ko~+>sVs\{Su#p~w_c:. ?Ӿ3#Knj]WyOڿ/o#<F|mK8?zq}bj's9<??Wo+{^u?^/͏'o~d7u:vҟho. xI ?'>d/7{5/Gr[_7ҟf_zNw)NːunE>Uf/{V..Hw-I}PGζ>z [F,4;Jyp({X]vyԃ:[}S{0Ǹ$tƜ| uJƽԫϝo4 ]^4zB3e~P󪾁}nzy[!:GGuPy9/=G GC7V\8=<R>[:y. munh}@S< ~8c-wc|;P ~%uO %NxֱϭSaNUpE?umuhtT)K̻g?[GqyɨSy_i?z }ę?X|@cɫOi-}uN^{I{9jHDO(ec{T.}z_^0IoSuy?^.>_ǃnh5~\z>vӫLt}:/:y_e U'ò.=-v=7up<f]w+?xs9yuWs?Oܑc/ œyx'qTߏ6XG"K %k-߸ڥֻ/s kl ]Szxy{9#|@?cW{o[rqs\G?O<{4zpGu>>Xq@phzҭN=>cu3W|Y^>}7`e|ŹcK@G ߏnFǍmd|/{ݗ޻'^׳}w̟/Ou΅>؏k0;zGi?KoG^@s9͓-̓G /ğ'Gg:{?#=|W5qlK}`T9OxE|_s٣I^px/?&q>=/%~C/^7~Wϧ[?ݺʻ`Gl\׺Kdocٶk-k^ (CsIYRT45FPJҤBH Je,, >{;꾟~K|8aۧmwK~ Fz72 {Oi_<{+a>?܌5P|}]Ro|#Oq ﱖu_'1"3!o=}~7a~h;Z'_ #W_y\k>)A+“΋2'C>d"G<).c yS7e\cSy' ǎ8{Z)~ESs6^x]=3w=g.yvqYiL8ks~wQYcNCN_;Gg>ԸařS{y8sas*{3:Ȥ%[Ywxa_yсᅃ?sˎ/+ܹsf69k>vX8k댽/]53;zB\$IqFٕ=t~^ovoo~?J gUEE=}/\/̩}σ[6έ]Zo|gU=A.X9h gޫF=7Ϋ>zc p#rԜUnZ8'>Պgg~x7_W:kg?|zʒu1<%v.^an&sBq֮gsJ9;s䎇ܜe;2^+vkb,{l?1Nsks6Y%qӢ2))}$;3aEnd?]3>wBF/6ssK.jM'nqx;&^byD_%/VnWLf7iĿi>-/ϛU=|_8]/q_yO/鼙DWYam|zpWW}cߐ-/M_#7s!o?y^ܻv}iu-~Mzxכ+ʏ!]7&K;Gh{n(yWoN{(w5<3{x3z%{+oo+׹8xMx#yZջFw_G/$O9uN3͇5U==泑TpS/"/>`}qFŒ|9^_p$l9M_̮x{:OO?r|vqn}v|̻GM2D_'C='8KVԕ{yG}~\u}tܠE3Դ VA}r_9Jm^TZw{K5^ͺʷ.ǏzS}c;{){c~ njՌ"b&W/ . x/􌟧nc}}>KH^գʾq_p.~?W n%_}E'8 \7)\4W ܇Lz* Rs-W`7guS~-}g<| !^Re}8Vq`oݸq{Y{'b܇u޲9>>/龍/W9[Γ?O_ E/;poUpf ^Ľ"~~?-]wM[s=׈Cy]E8g.-8le8?;~< {K^n]b>r.nuտ(+c}#+RyĞ4y>gA~.<|~fӳϋKj?H";/>+ ~Tre_roy =iyj?k0naPs; 9?4ްO׊m׹o#9v<[~9;ȋhe $&d}]W;'o}Q&+ɟd0Y%Y#

v?<'k^m9B[esαd{Ok/y7>G}~$^PK|x72_R|7H+_}O }JxoC}o|c|Mp;ڛ<8*`B⥰{(/NǏ360zFꉯlD՟GAv/{}lWxGsV;׌䣩qK8r }C'.3?yJ]T>/ןOG5p)v{#n~-_a:g8k-msw%8 S7#.D3m W O"ydw#Q#~#7;w}\rȽbJɃbϱ%?Lj3b=܏²?潲|*|b޿6Ώ^4??y˿= \Wҽ׀<~gܵ\bqz}y+qaG?J\g$oD_8?/k9!s<ĥ+y;>7qaHԪ_k<7?M;uc˟>Ge;pW ~O_el/S/FwQn+Z >XoN=/>*1?$˖o^` j͚>ӛlo}?˶;KΟkkQ߇`͞!/e_Wp^ }~D|> 6ŖH]שɿHU'pK|ndrܓ΍#S_wN>'ﵟ5 ?vP;cWK&/|N]确"=/8yRc}yDtIGПIFSN .g'T|]2~B'<P4''F_r_q/zXOu8(Q pX9UoF~^aDŽg,r;}2Üw~C?9{~i0xys?s{)>O.}}>;{E&sCWP_uPt>y"u7dSSg(- ZWlܷҧI+8?ϿlY_M=ٸKuOG7~~byD-rAJ 8ỳpm#6Ca c'T%Q!W}a3S$I|/SI_ r[8$$E}|Wyq[ w/Op=ԩq~N~< }k\TWKNbRz `"2UdG?s :'GKv|S?=2 vpq ;!7O&]:ָxJ~޸8Pӷ'^1[ ٞr!C?v`KN5_$^,]jGeC%bר)_SrG(d;uN }ϟT}WYIOL<[cu*O$43e춾'-QWs#ԇנ~@<ܳλi7WUʿN'`/S kV}L<#< TP[Ztr>EaI~O} #HW d%}y>3>I>8~<9s_}2׀kw<y0uFfCsIßW^O?|sQGDZyGv(uTs7c#ptF?VwѢ^|>>J{я|{npxAWlɺ~:1p { sGc\>:u |Ou~~o}/Romw2*6O/dȞ<=.9pW9%cJ? !9 ňS3K`ש3ב/}!|y@G\#a|J% }l{xqnQzNkį済o氈[8zM9 _wyijnzz:G9%^<˛l)"8}ݼ%Thsrk>+{`_#a񫜻zGwFJC~˽cU/Νn}^Ѷu:m{0^b8(z~W+w1?DSρ7[ZM͏b)ytYOM}RpHtߑ?uLӷI_y"SxO.cMK}GS`n~}%@"~E?딿p-2Nx/o߼g^Ƒ`n*A y"G Iݓ&*dwھaa %o,E*{:xn5sovYs!sm;d_ȿ@Lvwc;sgy-dVK5):+#Cυ۶ o8_ĥiC˾;%<CˉOyi“χ}I~'Nt~sNpny>ҷB꿞=?m'&_"տ^b;RH?ԹUoDg {n]Hʃ-rf2N|bzNeYę+0W1)9%~{Nq }Ʋwv}6^/_Z?ė9yy {X}A]fNP殘`7#c`ds6}F7N0}gPO|Z~sSr;zp~L>g~ι1WK/2C'*9O?(0?y_-FCVܯZwE^>ۉ5PKqxOo>p/3u|'9;WiXȟE|$ym n_kҿC:Eos?{ogJ? O癨W׶'/<$\wW}|x^*+#(v&}o ?s.0~y+l"癃 xɒ?ѓ L`*>1ptܿXܧA?v>#E{m磏Ioԟm9gg^%IBp!v &g<Ut_'Y苣_9AyHc}FK?IqW>Y"7g(fBO* ~>,E3e~Ou|pu}}˻ے?0ï]:,q.yo 7o;nn_~$}cZ|Y_sk{;ힱMN~,ZU13f6:Nj=fy;1sXW-n>h'~~sen}T|ë}^a{hC*?ovVeo>MQ.un{|с+ed`g?'MTݔYƒ,^`7 z'D&#Fڳ '~\MsS _ 򥋊<Psefi7 p\:zo䲿Xnw__2'tkſ]6k zi}]}V/ V&Gw'z#=ϵiT `^e]O<&|qG\o x%s_4e)}Ӽ/Vz.Vaef}@?='+~r2r̃x~AdcO?ބlwu{??xvop5{1TQ-sc'>G~_u2}n]c]>dg9fTc:??!ǡ$7F?jh/6k`M~CΝ}77qɾK}hӤ#.|őmD~,So6tvێu'ߔW\vܸ}?z7شheݲe.z}9+Xsk;=Z2cF˪T9ۓ߃WCH ^k `[p37V > {ɞ{~26µGE/z|٣cGWN<-bkQ\m v.7|tӆ/mG=y_Nq;ag~[>?b$~R{a&uKw=Yno69Bϟÿ9ރ}~ <,}UKIwab凼~^wӷ}UnE|s~Iw[/O )kc?mk?ogU74=">_⒎y&-.o^˿Lu/{y?q|;Z#gv=.yc%qx?L=uoe|}Щ=SZs_\{2/N5}+8'~5ݴ5eo E\l閩-?/1r8ҕ-+,/|qܲ7:v'׶c?>08}_''9*_p>yv{}&,ysK=3[~(-v ƽf=ەֵ%}:'?t`gރUvGS|8B|} cWT> U9Zb ~8S0x?vnP.HeaWC ?s^GωCWv=\!9o.RƸ@v/_]%7owq1Yuw܋&[u?,ScP[y^zc|?F e>?:s Q累=9˭q_VyK}7/0y}ԙTFF<}4fH_E.O:Gc>Zx0߉Џszpk^.x;oz>*:\W̏_v9(_I߁>o*we3f玿n,oDj~"1ܡ!GD?{涅/m;2}4ÑDrfNDi?2vUvs(Ce}xXáJx.y|{4#sar0)|؛z&{ %t?}-O9,.rϳ "EKò 'ۖW] HcN>Y=?}M? Maf;zOx}p2AF,8=Ua>mxI4yT4|u bΐ~Ka1W?0{ŐK=r/=!W9;w.}̽ߑsGz y&Zroĉ~k_6IV84ex=&3zYxrܫEۼMs3ԅ g`OInC~I˽O4e_>X\%O~{ g·8LпwW ?|`Oy؛&c~8WAü^2o/̱ISK;̃?9e 1y9yU_ڼ[&K<7=*W3 Z3<[ph~)yUI,];~J?z qZeK_K>cϚSpq"z*ęT;i9xIe@½]xB!g>9<;37wg2|+>=$?yI~_zc>>!u?iUhJW*bǍUW]X>` )9::.\{G]<*:81W#{wuN#4آܥ CYKr/~}DS'|&Z;i;o#N;>~ ~*Mv<߶x 85OKF4Թ gikSC%W\q8|VKYy'֯@!ijy>GvP$ڷ9ka;_ ;^2'upm8/g;J=z^98]Kz(r<Ε6 # ْatCz+!ԉ7p;F#*dr<ؓ^ g2\ОoL?JEܩC<b=?"ڗ7'Ixy11NJ}'s)'xg*:~y_:Iu^;*3&U_[{\zR7NJ-|V*ɛ:'}%wC'vB5op哺~+ KEi/o}̜ծsϓ}? 'm>e-UЗ~k?]ڼ㡴^6/E+F)È']흴n&TM|/P|.`}?|cw7-f6[5Ih履e8/8Jcϲ佬)y6_߁B0σ߭q>߃og; _71mMUUOx1'87V(q/1ϙE'[q&9ZN{-{D響YI{#?Nzu:n%E9R~f?yD/%~P@zDx<7q-n})E_Rosh_hϠ;{y"L|iwRDRrdwSq9y 7+w_o63 7X>=7F&_]W#w%c-Ƀ?}+"7p`yWvaKVM>~ny?Jȣsca.$=pO*|~F9`7W&nKulޟq>)C jB>g7ߪawczWϞ9?Tm=cO[|.ےlWYu))G~4u#c]!%]IR'|c|#\R:YA?88yeW=-}Is{ȍH߅^J>US 9'=v~ɍ`'S ~>ʮՎ#U|_M yD\} [C.?~.G}WW^㖖;ݽg'u O?v9Ozoeίm)wYS͸V"ˏשs*_xϢ6;n Z0wnNxS璾"9q+}Js܅߀RWvҋ&DxҼco!cOokIx>S_܂̣K?T2GCJq]GOq _\x͟˜o3?_ >S_ч! wS|z; YoK}D;cI]y8=W8\<>U˲W>g_poQQO- ޫa䀿y^r缺–>>ee\K=T>>dQx/!!5uvUp? ؿ#o.ۯI¾>yc.e!o>; 3 +faL#cXo==Ʌ._-N>&ySyމ_471|!D}rrs?5q,\xw3d,싔1NJ%/~< ޠ.Ci{/> $ߠ\u ?\Ȝ2c/{'`~s{Ku~_M6NIxt:kѿ/;99~"&su.EQz-7#:w}Qp<'=>/{N+^^QDcQeo3#~8p2j\=*r/̙OWH^l7_ ~ s2gix<ϥ4a'J~6O>.䁺Bz~8&ϣqdzJysi-|s;AK`u@$GN3{ Ηz=yI$gdwCs{$%gpߞϧ~/=!t浒u}A{F~}ӷ _|yh*]j&{Tu^OO}T<2>@9ȧ޼'&9U-Wϳo]q:q~{;\ȏ[gD<*<$%>8Ez~I8uh3׺IAϓSq15,y}y19}a? |/ȁp#yȎ8nW{nA~9ȗsg]`>:>z>gkr|~PPBu<~uF)؀@z| ". Lr{<9/OZ3Fr7_qad9?q׽vq*p}m {_+٤ J?x/N~Olp9Qp_|W8;K+ҿ"tz+r _ N] J=$~y7WWUsuߍf0<ͧ?##T>25vIY)E76y yH|ٯH;7Iß{w*=,ll>S?Iz=¯g7jc~w 佰[}so |jJ<>=p_F]s~ ?C>y$+].~+x'H@x {yo~C؝AGU}$/G'0?nlרɾyz;8ԳL8UO(o c!~ '9'2>ΉVw[[xPG'>7>}ї7Aqp79zqyWofQŊcgac?kGu>a=獽"_D^C>,3\{!/@>[?rkc c J{Ns>b»)9E^:z:/ \7*yJt汢M}5'Nǯ}\n˾ "WIG=?<>x疞XE|=}׬Qan_96}z=b^T1y27ݧL gކ=2/~LͽSw l3;R+ #[GU]_GpN~υs~›y!ڮ3wB }<%ȁE? u/ۿ\`I 3~ya|Yy,qw<0s_^\fxiW ^pޟ:;o{ ;SgnK}1J\缸o۰96U%kի?¿sٯs?'9܇9c%|v\>/ñ@n ߝ}O'2iyT1xd7Xl=\ԧbs졟)g{ o;.> ?C:s/s~dG]CU73f;0π_^@.ȣ;w y$4>ΏPTag 4->߳A븛>h|~ȼ>q{|?s_R2A/7o'sS+챕_>z=gSBxZ;L|0%O"b2gI\@Rឈ«>>@g[y^Y}%s&轋/O("wߧn]R^|pxc~Oѯ =ɏ?IMr8}}~?;~A5q6/.98Ab~ }V*-ӣ=˛?/-*=_fFމVv^oKEf/3vG~|ik^Xo? 3x<}6qيhϿym|_%y5Y{GEnV4v~y(mc4NvlXKF[7.tNMѮj?Pw]i͙׎v.1Z|Se᫮,_31U3u[ 'Og9lW=M|\StUoYѶZ|hEmvI{ʉ7wI\v\Q/l}Fv9v'G*ޯK͊>ws?^qoca^9$D+_s?iq1K㛕Ek?`Ӣ}ⷍv>:w|;_ygDj7;a~ɅyֲZh翖7;*jޭO5gn{nJ,Zm^@ۛ500=)97nG|hO7вm|]D_bqV.K};bM}wLsϲoo`kіߜskqk_{r#mO^n1Ƨ߼ +Ǵ.NJuZsN3++FoEMmr[|7>޴w6Q?#ۚsKtfZU',)ڔv3O:s^4h{Nطme{;`O,ϿeO;tΫ1hί WTU);iG?7?-ZWCxwG˪T9ۿ9{p׿ʮ(ZWs#mM.t6-)s˽#:nntͶ{zEm^2{OfS>1I[/r1md󎟶ddm #y_~lG=rq7ُu]Ы|w8-oڣӣ{IC/ZîÍcڷN܊Ǣheݲe.zΚc\*}_=-Wk7-ڹsssnk+lyi/>y>wzGRw:^3zJ'u=:7zz[t/U;r,ymhSnX%uuQv4ZsN==юTpᶿ;'oyeyܔ߉\>b'Fs~IwG5[l_kewC[淙r͍vmְ\BnOV]9lWU}>=u~v핝o:qѹ,9og_{{T2i+>|٣lk%f൸FC{sros^'~/x-8ϻQ{bWb=!^̮;u8q~ NƟG?x+vWxz:jdm8pĖ9qz=8^Y޻vGbo}W6b?}3{on{uw(q Ys>5vٟsv.@u7?K;3Fnq-wd վhT봱#/\ƅě;v~c{691^}X2c:[Wܯj- xWwܩ9gϤՇ:iS4qɾ_/\|o,n4v`;Kqgn]c]sbq=yvz큋:dq+h"{bCa5OO7:rv1ѬNίyLϗ8 ; Wc/~gb^4ngߔ΀#[kԬaw˾pNol'|򭺟\Ԯ v;o[_X {Oi5?8#|cmF)p"xC>9Ww|ܝ%87})*aKv<'xnw</{c1OSC y$ y}$I<,vZ'G=}NmJ[/yܚ7;ϋ<"E0#]Kkr~olXYcۏsnvjTrMM?1Z[W{axo>rJ|]ƿ/  #Go罁OϐоL3yF>~.m7~ɧ7 qE뗟\«9Os;c' xku$n=|/.<Ɂ眗$?j’:yY|󔲧ȅpկ$$Ϻzxϔ>RC;t|kuo./:iO;{N|Be\'E#q{8?g#G+xJk8D>/ 9h_$ ?nTg2~=oHsF{#ljG^ȧ_$>9[:ޱzGs߱+6LGnMz.|>oUR]>)ߜ?vzw9'K ߎOm<GCg!1.]o8#'p.L!_>8iOuQ V=>齈m}Qc;yržʟ޾kYRG義!?x䜨;nW>7A?⸆1ߣ_%ƞ>3]!> .ŎPFo7PιK}[]>Vyyo)8 / c*|oya?<'K,f/^>^s >Y ?'}q'K9oރ5rLgu͏|zynwCO-zog>dO< WRBNcȭxNqN&q/!G5roGewrԉ=I}GX?Ǒg7};g_vﾱ:.Zo,:'s^'Rrqmȑ+C? ?⺠s~?y #]Jߓ#u P >7qN~yP}?u9}{ׁ˖]ŸK|Gx}c|bj=vs|8HsۥIsg9'霱/\wޏԻ.&?>OSOJFtl~Q"ȥSjЇ~6> }>=Zٲ¢o<+8O#M\S_:.߃}E7^{EO,z>H`\B\gC^Vy0_<`/W>%|.@7x{pH< yO{B8y[_ŧZ-w '>/~^vG?:.zaL7KVsw<ϸijhX:z@\^G`c6}/ cJD?]WAL}<7+aHd|0}H>:':&NCu冏n?}8 u({W{rÞpx}"Cgx>SO?ϥ#߀>YבPzs-|.q\p'~:NS^G\0'q_P_o#'=xA+ ,s+­'y#K/!W˖nCyOSsygףy]/a=~Cܫ($FwJzM`CO?aG~M郡ByP]?gLxSωq3SqHg=\}(ʛ~]fxd?g7 yH:G C߿ {B S>:+n}N|㰇 q&ukik4r|?Go:`ww"cOF#܋zOsيǐ7`bų{4폍[@||X%M؍_O:Cwܷd'*[ӡ><˹n"e"WFg u\sg'gESKTyHke&y >OQ yGțS_/ g.I.;hn{yKX3{>t}B|~԰+W OeR_Bü68.9{?kYx d/c_@+67<{>^y$>g>9'#zN ҏsFr矗a.s's@?sҞ!%rH<_ #?c~ɹ|粙bVߏw{o1pԳ9G=e Y_$?7*ıG/<a;iݰ?tg')O}e]BBy ϡ<`ͳw?\d; r';|(3y͋3wI4ӯݘkg7灿&7Q'"9<}"?ϙ Ay>}1 >Jdt'ɭ~ p[W><- 3C<}ssإ j/szJ+RO~sϣwފުTLSz\=e|<翂#?(gvRrb ɏ ?cuy=lIx<}Q~xs{GxNIB\C<&O{'_؍9z|GSz^W>=s7_5pK'ւ ߟѿ#{f<>s1)^9/Ǿy~YCK]sz^}:ܗ.qq|S<'=]3,\?x}JC=s\-{Bq~^ݶ] CܯK%.џ؃pN[to;u  8a9^dg9c?Snv4` z/bZO!%n=:0"~۝88풇>~׉sk쿍WRl_9?yV߃yO<; 7=x b^1䬷2g>n^n9:87\uim %V&}jį'_m3zlug!MxԛRqOާqnvYkx, ?/z⌬ӚfߔT<qxf[b;o<8]Sw_doItpɈF:F_zѣlO6Ė)?)oNgao|ޒwM78þ0+˟vaz7߹x1ڣǣ-7]otZk=~~h%O8CڿdҞg~Tq?zȏW}8ﭶ~~qɱ<;7w(_gKppG|#GU'W츱K/(]S`G77ck}ȥO}u9{Nok6t`w>oH6=O_G;\{O ެNzk̕Hu/5Nu^;NWyf =2Gsj}$< D~8N[wSy>`_/8|y_}\y~9Ag8o&\U+^A/Ym2:wu+U~ex^߁x {$b9?o~{[kG|r=-K~޸KRw80񂫯_{3jTT rnޮW V`>rͧOH?ϻO_.N?qO.+?Nkf͕<)^p343;cuJۻ_Zs'ږSPFq{#}7Ͼ__$ʟ۷i|aO[ssLyaI{߂/jN_bBq')SrKB_Q?rϼa.Z=ϝ}3XliwʵgTnHտmq{o\Kؓ#ca=N?/ k#/>>&7Koe8~scCao$#G|5{v5rl?[ O~7(/YK}g뾜Tܧ3]6rթi[|ʗگ 9;s䎇,/H_J9w9Nokc N|bg! ~k?]ڼ4v7N{}Om]x}do?|*[ ?{:s]~17dH%ġ?s>?k zJxW9A<>H}Q[k ;ya䗕_AOrFdtGɞ$P8F~ ^O)-\4ICOvO? wh߿gܮ{\H/=$ߓu}~Y'qFϧ,uyo.P ?h_a8}+%߃`i77y*ެ_ |//!/<{MmG$=ogCs'Zw%x:4އ_7no}T _ǥXea/O?Έ ~nLA'E\1%_z/%?]\W _w~;^(eO<=#_H<ԡU$LS}aUȈg@uu)+z< c3'J's&-N9Gp_{RuA'vuks羙eּB>U^wɳ3z]~F_ S.({Jޒ~c>^bs-vG8>2#{$'$|W{ֹⷹgϋ_ {E*ㅍvbK_ӘR{d, ~a{χ{o@yb g>~ ,x{899dW9  9p^^#gvng`y6F=;ÿpr'< /Pѿ>bg۞s0)>cs.QiN]UyUk"_NaOׂ>uIc%ބGo>Fv~n]սWL|DOP'Kɮp?$oxfU1Gs_ \!~-|,|do{/;}_Ѓ@?_O@~!NMz~4S'?=˞eW/sP1?r̹z^ OR>v,5 v9Hp<+- }ns)&j#x]W'O";LMAy|?9#v9>O߸,œLݓ{4]qy_ =n{oSᓕo_1v8NIz9_b}ij-_^w7r<=w-s#-pyH>'.8Y\}GD^=>ɥ_0y/>B Ow~kxxB'}k_xI;>ToAùCxn͝l$L|)Oy1@"x{Lkʸ'[extoȷK½Яxߣ9s?=֠|!oT5v;M67+#ynC^sH`Ƨ/_V!/;{AA^|q]{yO/"E~8B^v{Fq޾@ރ,sN+^C{=}Zpqqn__~{=5Oc~E]#>ǰgb,sǔOf i6Ҳ?=ރ\q̋)KXP_qY~9c4wwn{{s/t^c*Ǽ/OߺW'T~KpZ혬o;x{^ny?9vM<v!ƣׂ;ǰǁz^lsmԣ|swU]/2i}ÿ,pGW4O\Rɟ'®+SGsJ']qK{O' =_~v{-c3k}#ޣM =g=>gCG3#~esK}Y~_V/HWgO]ŞA7NSr(}$>y$z|G2|ޫ!=`G_c)<n/zϋE%NlnNC}>?\'sowR{pO39isW凒yb?=W_|_S ˮ&yTݲϯV 4Me?ݷgg_3w/o3?^:}a|JjОþnyAG&q&R<4qGړ].֟Bއ^釰'őwe9ˉ_K=qO/89?TcOB(7?ufup_ ʾNM]{wīsaDqM/E;Pb ;$~.{7X G˪G_euZA7MG\N? ;9_¹]_{F_nC4W3SCnM޳y|?_qaO?_N|ZvϣH>4漉K,hވz2Cif'CƖ I“1U_૤~Nߊ7\MkRq>VAGݔ~Jޛ4 `pz-6 p+{GCcU2բWF DK"#p>/@9?~m+͹wOEz|<ǜzoc1x{,=担^?x>IZ>/;ګOzu?3s<:$`>CEsNW]C^EWߠ?ԡoG}^u _mķz&e=S8.]vz~|c=a7W>_93$½5<\ <=!gG>_aNKG>1Co}?5'"?f!xd{#3u?ܼ =pK<<٥_WsO9޻|=eW ه(W[szp2|/]OL={/c~{t/7aExF|r >='qg?=jE{mp^s<Um9_sܧNOO><:AlG?]Wbyos">>Dbܸ=*:G!l7cΏ{]߰Rzʽ_*D{ỔO{:'Kg~/ן=w}P!+OK P?J>N>~m҇Qػ8} Co ܓ"/-Ӹ'W~br>vy]W11y?}koA9?,p.{{ݡײLscA}^^~+'.]_2'tcxLp/!uLp q|?Ϳ8ZP?`_*~D?71oC}Q9'{\{g6!+OҿC=yo0G)|o? o$|\f0v~$} 9!/7}0H3̱PC/C~yA忈<捈=y =Ãz?R~| |>Ӻ~ '$X­1eywA;D}D~Qyjރ~eDy0x O;<2ψGv9_>Px$q-~y1g{N84{ ?k\ub2>b28WП=:1GdC+̵~g.<4ԙߊ%JG~ydݫMgK-|Oȧ?[>^d q zE^uDkN,)'wzeߡo(˾q>_S@>l+!3}\늒C.~Q~O?u晒/Z;< 8 | =>G^@ߎR CW0x:KYv| ߇;y9ѷ}%(]l9r|uH wMy,0| 37Q ~pR'}?; Gto\4(z:ACJ~G [G,'z><7xq^q*˅[O橏|.=#MR/湱OK _ޣ9G~\ɾރiDaͷ|'楑k^p>'/ [~e|đkO/v@,?ԍ7z8G3!$}|-ȉ}y~Q?̫b3aWy/>osO^0~z?xx[9?&πsBn]/9x[-׳+a'>O!PwRK(ss?-r3k^{uSɳ}Q!Ǽ/IC őyۄiAz@ nG?GqcOy'?lo{yIz&9lu{wЧu Mߗ>xpi`W_ψs'>Qgm~#+q';MǩA=os}|}_-`2@O׹axNgեŽ~?[_Xv>>7Q³> e }|\;uo;.o>Nx%qW@Cy5ve5>rG(/1^Hy~G@P\txm_Cs3 !OSO9"po=y<o^}B{8*yQTu[B>7+H :G:$<7Ts9njș Ώ] Gyȟu~ Eb ` J׿r p O!{I _xTKA_IXᱥE{+}K+/߾o0+)z9S_}pߚC֓o^< #CP_ x;˽kw? f.6G;ߒͅ|)y\!{%"w~K|fRV~C Bbyb/^$yqia?9%ןs_^I8}?s6׋,QwT _:G-Â?Vsg?wౢcE xoJ";P.}9ө>_ȿ_B|o??UyC({?ʿ9X5x|_9]RSyCQ7/>ty; (.>7}?Sv#~Nz2 'SGB|˔&笽Ø7sCnI?>ySYsJ>jЯxޟo~]o8#>^3o/N>'I- OsKz:~_/DU}Ӈ~&<)ͤ_WieW=uaރ~p%278=d/=NW}5^B=u2uM)~e{X%⺗QyRgzHD| _$w>/՛;>s\3{v_&eFu80Q5vSOsXҏпh{jrw~O{V<{6_>̻Ğvy`Po8oWȞ;nE7~>u]꼚s.瀽h{OGRD{H_x/O&[Cg`'cɳY叱;ԕ5d>-_kQzG=``b?s;s_yU^9 K/M~PtKU<"KG=:7ߟs9 &|>araSx/=پN"҇+e/\`k}b>IYAnϱ܏e+So=(Z뽕9&?7w}9G!7o[Nt|vǮ<#[;aԡzN圸O ?I:0s'">θ^y2pJ?v= e~y:ݯ){G>9Me7# <; r+{Cy B_9zF.v7.7^m߳SĻe;{Uz>[eyORyy1{\?{2ؿW?潉ПGy1oHar5>!޳]3 rlWe;c%|`{ܱJ\?"CO8Jq|jo_gӳ^ *nr翻齂x4_qh1s Ec-sx_v{s`'9|p.3\~b=\m>.hP U<\v=w^0.0| }sz,}08O&/x.[K~cӌa$yϱ}=Co^?υ$~;r>]p/[ὕ}^:q 4 q'=?G3C~ }}3>Ȟig{ǷO;o,{+rk'KXv~=,_-]"s܎^2N qӎz|-C<-#K\n/q'7@7Gaa/d^cG7Wr=Z~y`k)A>?>\CO'yr~qS x]z}S~!o" }(cӉ^>o&'u>x$Oԣ'EqQc`߈~n^nKxK9r!7DE%w'Q睔/E|N0\wf`O8/qQ_ƟO9=\`y}x8 swi$ʇ:&.}zu`U/ǫks57C`y?{~ }k~u`/a+ҨϦSQ=zzL^܇I'q$L+'S߄?J<}/817)o[!繜 yɼg~jӔރw:Ho~:::JYz\i1N䡏u~)zOƅ'4HB9toNO<?&%,<\$<>uPV'.~v]}AWzG~_oHM-IA㼎΋|M aM"o+_g} >Nq=x-J}g2Ȳm!A.FJ68u\ʿY?`^A8y(7&oǜ ~Cxd{V,{np"}vt&X4r{9|j}Hڐy}ʹOKП0z><)Cp|( O=SsMw؍淜\(N;3ouדwOzoǟ!O\bS?WlW>_EO7݅OxM>kp?;}aW|2yCxTy ?>9%y~;ȓ4!Z|IHx[UWQ!GV~{q|,d(?!aL{ZRGS}÷^v yvpç}'9џWI\L~AIɧʯRv599 a#3O[꼪szNL;xzO)u.?|Ş8y?(y"o@=Zu},y'eϓ}3IsUq_Ls+\7; 'nӓS`Kpτ(OT~!'<:i#Xߜ_eNY>a*}p;}?z _UU's>s7} ;椂J梨}~6{Sc{(ON + r_r9<*8sDyV=:)vϥ<9 '}̽)F~]I^x|q{s*ȧ~ϟ|$uMmyCT%oC9x;e~qd+| _O4&0T97I<Ľ(3AwE=_|79}'>$E淐ޘI;ϩ{걞u_ 5Ox$=`~e\Þ C򿚓aigy ~`sr¡':ϥJ7%N\kI^R)Ȏn1|C!Q>s}ݫ@%wW4zn0Yu} ~}u,n?XH|>Oy#1"ms5>=\~+͋Ϧ~1ŗ+*D_۰O[ :t9qgeY*>UYcCݗ,;n;D\c_ /}/_|x~#k5x)kRE^4=&#x\ ¾1k^Oȷ: %IA_c_6y<Jދyg^Y_QnsǗ]}}"8yfL~&삕ĥ: ?8k&oKZl9qV;i4sH^8(Q3{8s_7"2O53+h:^+vgvߊsjǖKeg>\7R~ &q]{qnŇ1ٻ %*x˙q^n'[gqL:qa^soڲ3W}8{R&,؍_gn$װa_{=싣.g|f~qvgϬ4=MY|;~qa9ƙS{yƅ{mSy5[zO kv\72ή]?ˬܽÅm3Talk6XVcO6#yI~|̻GM *y}Pqse;V8k܇K.NzyC^oU=|_Y~OZ\9 ۤlwF;uq\?]\8avkbp[êM>>ƥrvUs8c@;oi)l6za_;R3wL5z/o3tQd8gR/r|vqV,;9qTf\^7f/7t[\oK6Yrkq+Y14ﱸ5 ?$e72qv7'=|2صmve꣧n>N|{.?:5-87e=.1䲫fMK>큃wK5)yK#qG&-ٲ<];ǹG9[*m?7S\0kU3zYxr{_̉ę5.9bBԉ򭧮vr̸Tv>8My .;\58oq%]6.y7=܏!Μu >Xo3NyWq-&dg_Fo8ŕZN^%&&'ř6q%T89.>ǭ?oޤcN{r/) z r[8` >@\ͻo,Vԕ.rswzԱ;*\۷Z7/G~<~Ҕ5{ͧ^Yǹ]637dDzn rMsi7WINfEqNrWt[vdY`ta}-/M_#gKX/7Ě8W=8?gVK,7+ﯹ8S"zw1G598ہ!5gZкb㾕>_'qg>_;N1=㬲=vpxSaZξ|{۽f -uƂ`wW͒?%%>8ճo|I"qNyksnvr]N<n#{ztU}om>w=87S_1,5ΚnQ3gn{VzE`hr="OkCOaF~+v{ggxٸDקngiN..1莛?l7<νkۗVKHJߓqcC߭3-Mo\Rq\{Uѭ'6C7{ըZ5w3834}ltZǸ3nZT;➌R}>w=gJU34Ė3 'rwR;ZnƸ%+͌K.Z4mo.~R9mgUEE$Lv"y˗֟+1m?/\d+8O5Q?񣭞9(f}q&t/< qqOާ]k?k8u;?{u\y<ظ2;r'si?_{_3.^%c8cK+;#3/5 jFW+qC\"qFÙ .xyc =7\"q/;f4Α;2w\WPx='%/ﾽ,8{I5ٵZ4~=ܣ7?^W;yƓQF~8;=6w|wَoY?oG;? Ϗ>S~ Ĺ]O۱{.HSpqkoY|.RrG&~nRq=g /i@v\{ҟob³qi\s˭ءVxq8 yWfW9SKn ?`W^}%W\q "GfrZۍ.m8Νw-,A'.9+9]SCgY='MkR,dycQtX='~O"~~Ϫ%s+7+&{rq-Jv9=q*8=aG/.^ug?|zʒmKn|} q-ɪ>kTWB8uV~8Wϟ^9øpq|ݝ85Xt_N&FRqޮ[;~9> wG{W>&W&]7WG3埳NvoZįw9+vVAG_c9 'ϟq^9c6};y; ;D󽑏}fMM?0I~Mc|)gV8.-Z| m*_yȸS3g=\W+o u/SEt%SgW$G^T]Jycn{ޏyVre~[է@}%sׁE}>?WTAް`:O]7U_Ϲ~X(̭QJꊞ x&3%ɼst~?_p>"}r<="#GSľ a/7ݐ佑s'<_~`M~bGv{3NPO&{ioU6޼}5?+t 1g dؗMпo/=\?g9n-sב3nO?L&K sraũ"oNzf b7-w>7Y4Ὄ_oi[:s`0I:~OϕuwӷN4SxH}xS}9ԯl~9 3^_acƼ!/ys?sҲp{Bw2~8=wz^>&|5X`?^1kpeKX=.9<ݿDo0#O˟yV<~#1!7:`7|·o`˞䙾h{XܿȮ'+ * Fg_sy04o;ۿ^'ssQ#= oL1Zٛˑ_ zܒ|DPLJw}g^ {$9'iUhJW,'OW^}fwӷȏy#q'μǽ/*3g/(;AF(EcZru?/k7-Hy^(`sו*鷥Ϙ8[-3<2of悘bsv?p{1:p5] :7󳳯H~|?k7=~#x_iO5c?h'~pN|Wi8'q>u]nL]^{0땼x9pI o&o{ҤA2%;g=!x٧Hs^ޓ>=W8_0 χ/y$;4A߿ϗ߃0V\ ^n`<')Xsk;=уԹܽ_)$ܘHO `/I ? s]i;Yy=B7'Yύ޸."{jyS7e~`nrFSJK7yd6W|?5䟱3OC~aS@xN>'o= "a;&=\y=ssx{ ypx ICx:hm?{[G[s{{dwx/ρKe yɋP=%_}W+q;o#ʼ<+ܧeoOqkzx=-à/ $Wk|IyLy;/d>j7 ʳ'n2$;=];ω4Ac}6;Cfqзa~_x}`l^ #˸N{  ~NzCNoP'3/I :!rFކ4 2y'%_w}lw)ȳΉxOp[1S| 8μ + $L!J?egߦ^'*91;܇kw כNGM?C'z:}졇O=wA+GG3?5{Z[ߐyb䄽X_ ?:GN'v~Ry5 wB>,uO':_DQ8|} mL ɯe̫ _ɩƒ{߱go ;#95W+yg x8|4{QO y[Wo=G^ˮ[S/W~%N|[矓+?p; /{η+^pyMb̳e^䩼QާAP_vvH#'GgNz}֪pήS< ﯡBi}$4yfą_7 (`O5u y8G)?ܒew<Ι"z=+G~6SƏ6%eʧBz?{1Ȼ(]_}#d/}LS7`ϣt__3 E1zycÌۉ x4=d lx]wwq}qѝחR'C\w yw]Cfȯ.z C̣5Ԝ~@χ^ya/}Q89}&o|})6yS7>|[/>Z5y(`<ʓ}&ùяƞ"k>'c?puwd.Tο ؞aNN~|ҏ7~F0=oyR`Я!|`K {gAxzgS⹘[{ŸnWF/0s\\yOWG8յpct</}W33_{0TyysY[#E{8q+G_IG\#gEaGn;n{vK{wrۉmuOG?z^{#KވGBDpe=,<Bfҟ#)>d|>~J@ErC^}my\i{(o2ļ⧉'|Җo|'8|([aW\sq^@==7 ]?  o~%ɯ\}*sG<#q|?'@e$r>T?|cIp!%pkd/X2c_:?>Tm` }߁ ~OXm|S8 ~e 5S/yqJX7*]k21 /WㅎɾVߩ?sC)ש+ /cPq>~xsOWr<|/Ҿ_a}.2o0 {Q_~]CE9?u;ޣ{>"O#Hǿ:Kceb[k~uO aϝ/${p#9=e IýϣEv'N8}*'VbE7d+~+C!?"/%yB^Vg$C|GCdMQo^ݹ*_Wޑyo[}JݯM8_%7q7.ױn+N>VSf5>8y"/,Ã6E'<0zAlώ%@_܇E߹flO9$XeN3++FoY~;Wsȓ.ì_x{GoXz;⌬ӚfĜCK8eEq.z_?N]?$ٟ|?3#>zAmcɞѹkg/m^b+gO _%'ry7/{ ώy{3,y x/[x*y!&3h#y773)yN&7IʎwЧ>P}8A:x|ދ<xRzjEg{?+o=/~̡o:xl2/!&/SK2'TG0`AI+?;~;FQzxsxK8z={^9#ޙW>ՙ[=wi?9`D#uBeS/v,|qOL&)#&acF^3 9yy=#xߋxoes}PϤU9 |Řחry_ý/Rr>nFO/[x ̷~{ԒWďQGvyS=:x׊[x{w{#%+?RܗL#vCO{~aN> AOWKx=+z0y!O1': i`~H҇7o)soIHFϹeN<'kÞwoOrt]<xϡ?G^^74_/FA4xU7v~xoj0]zl [/GSռM{yx9^;i,Rw/y}߮u>B'}3_!{D1a"Зά5E]A}Mχ{_!m1fN=:/P;xnN#le_ǁ(nC'P &ayP5ΑS<'A3><-c¼}/|<&;=擥R^ٿ3BTv rHr OKmyfN~qm^vAz5=/i/o}̜9·?%y ̛z'(>Mqc?9 D//}=+ށ.=maS;9xbq<}%S_e?<(;#ԗܧ=}C_ AtID8 m]ɏ387׺V}lG}p7<=X?O} {]@߃4N<|i#Y湓}{?D~."7dp ?߁=\\ ?q6dzqޥٻ@H^R>̝O`W~GRO:f >\NuRs+ t95p 9=sAoc#6nu^3¥czo;1/f΀>/ɉdG7ᵐ'#h4s뤟$ODSq#Ln)|2]2)z}C=3'G0*gF0F$UwG;|!q#)Jݧ+zItʎI_u|}%/3~u Op/,eq<z>To+ZkNz\鱕r oܜuSO9K$?or.^=o&}̈́]Y,9O;nKTo3^=3[Mp_-ڴ΋/i\c糏X}Wq|'ߑS~sQsu,FYiLhEohQ4OO7:|?cּ)wHwrrahT&{'z/\*.e?KG,/Y ;By>ˮbk,>󳋝ӊ"Mc/({vnP.ǼZ|})\~h;o7o}$&rS|o~9Σ*5S}[2|CߕI޺عG'}$Zyсᅃ'{1΅;_ع QP9i3_|}_odd߄B|8d&r̃x.Z`̂VĮ|ժY)-Y MRrF('@>sF/DS>CvNίyLt;u_佁sJjg~z?o׻wtßSχ'r_W$ R=zߣ}e?RzWyZVO.j5ZPwn'秺ϸijhX~A>ݷnLUC^lզA6P:O}c_ߒ8]:{͵+'vew- K 2zݾUģw- y}js=U7}Qf"]]FNczsh3c;}ڮ75k嶴C<1rS>N?y^[_f^vucOո;x[7/ ]>Oc5; r.oU -1䲫fMqi]mj=v{7z#ΉK577#mt?{yfceFfW/լ`D:m~Tj[{/wvxϜ_[?E~R7o&v^G41Y>(7-=5d:88X}}Ur]H䛸rn5TSLNM}w$>d.]olXYc8O?9WMXR璗7 Kۻ-*qF\W:kqCxH]^+/.+W nu>˵=m.3?Dr˷c#}-a]۾k+|tOyՓ_vB;޿+3ebR~9iǟh}j9i+@0yN}?G*kO54 /QGouz\ںϩvPzi}~W8;9By*ωWw\r ϳoyTPtG=w'g<))`+%G0_F/zǝO*N>C2Pj/EFٿI<1qgܴLڧgg\7uZn87dz\~X'wNkޱX}*MT$Ήx7$xy'wL yfu}tDχi \O~+9CK^u]/woURKT[SGg_}om?_зpOMi:Š%\Gqܰkȧ?;_=_9kszMU}n^9y up5fT˽{.`g{O9x#C~4î<;u8QV@/ʿVyySsE.~/ՍgE1}Q?o-O&Qu*=ѯy6T>?F}D xOx =sX3}j󩟁kͿ,}6S-ABsZpU[e~z2I ЯA^}sR=~s}Oʛ³@ uh':,oHs^ӧ~ 7"?C鋦u}_JWoz|8 čy D_~~V<ĉ-Qߪā[>:tYA>3ԥ/Hn;ch2:No /9x81̟s+~ꪎCԳ{1 |*x!/~Z!=FO.vṡ$˟/9?p Okx4ub>k^ƒxoc>N %>/qcO]>>-rd%o_I}}z{^Xf8d9w:B޼?[17Nsf9O~>-[e/o4P O־ݧ=v2?^ro%M2~})\sr|x>Eq6Pۅ?+ &v||O /$@݁yO"!CyOP|JnUx5=Eqqp<;[K(M |&rt.O.17O!'+8^Aƹ;>{U\ss t>V*unqZS9郿^Wབྷr>R {R>687.<4C6?pvbݟJi~87J>Ӓieܐo8H~{ a{E/W8?iKޟ<~|%̗J;JY:26lkg'_Vv5JP*~{uޫ/&?OϾ#$}cC2i> ՙ-gx`_ ?a-h ʱ+T6NȿOx>+i =p>8眤k.*VW2O5yވ[ V|H>9tvf-5NP| 25>+-i}žƱYawgv{n /~x?ً}8w?z_a/0y;W輸_7qƀ*wҢ<'W> SQ5w|I8R> Qan C ${J=C9ze_so޶Nzd /sJ *{{yEԏfGpŠS~q[9zG妻[~m}䃗n'mdey^>{kλ8YsbuODҜyX96pS|?8pғչY9V<$nSA9ҾA=X恼:'7#mx ǚw_Nj{6Zޚ7Yz؛cOۑ'o>ñ?V= ύEg0rO>*x"7ęջ>~HjO [\Q\VV;|֑xkAs|+ܥ-)7)|*_PU̵g[#GOÜ/~X/4\\k3&o?-7zfT\U|{wz<\߶i>ş7}6xN슛3i8_b/'"W7O<_?vA%%DO|8O1yɳd_v: >e?@nzkjsW̧}3{.|_EM̕߷;8FH+yrs54el?NwO6'Zs6m[|)zzFBu丼J!B@#P_9߆՛;Yޡs"兯^Ծ7cO$ ?D/'P=) ^[~W}IgU":kut%>)[>g_;y^;Jt=ㇿ:/3G5!GJ|G\QA_wA\#x@ϗ%Mֹӻo罏J#߼ʷy>>{xٓwc"}k^;7ߺơ+KK:ïo!϶_> z:.\u%P=Myo_u\ist>tƟGQOGų5'3"IWϡ>UzJuunpݩ&uKWZwց spjOSh]iCjO]W>0{RG Y=Tzq'яpƯS"WQt&#^'}.+}Ck܍ ߻!vù;C~%3EO//|n?^?sh,|7}G7{ |' }U_w%_wztNt~O<܀c7:CV{ו|:sO|ȧǗ{nS+ nL<@EytKG8Or0~AO4}j]}﵏_9ڸW!z:Y'{W=AZ|W/fгGq<ߊ|9}-j'm᲍׾cW?l+Έ=iws]>zկگ|Noiy^~r|uvG`_=h]վ9z s1;\ ]7zo?Frߓ}(ſOg {\Їs>}1_~4F+>_2qQO/eryk8 "oБz8v >cwz}9'Şs6>^v{ޯ285n(S nԺ%JNG;Þ_>.Gn}莾C~o_us^&G70~/{Gݾ?sWv+?AIQ;s/uʑ9ٗnpO#3<#5{؍㬓$WąG_9zh}ةtO8zs w^{t)nO gWw)?pESqv0e_: y6cxMT/8}xLUNp_ gKPv&@5ro}3=SvyHu^S~!^c/W:s+ѧE_yQxT?u.o#Ӱ/vY*_Xy~v0оoUܮuFIDKԏcϮ^tο5Ln'+?%ϯd]L웱R?Z2'6ZevܗMz-֟|1g|rѢ_:7| {d1sٻ{7 ܣn~hy?O=hfE_Q}n~A9O_|#LJ>ԧo_<$k_Nsy<Ϗo$\<^}e= pFKNCh_vh.9{?Jh+O:uot[_Zto^=,qbW2a4oSϿ}/(N64Oc_,:wyϞ0Zsvob3| y'a#-f{ˊ룎i+nw|skr}Hlgg??p7 7p']tnq-V;旭H 9sYE^N^i%lh?mzסJsz蜫o:}~~y=3k3<<ſ`wk|s4;z#O讞#>Y?>_z-#/KwwzڱsvyK%zޟMo<j#g>owh;}t3կE>bo9]\q=tj?]Y|dyW#v@96DEn3s]WpSjW>WFq)｣~9j\Ņ|ũ>Ez+u[>_gqwՎzsHI'X;ɁGmj3|?{ޏۯ0^|KV}e''+9tS{"!W{1>d.[ߗz:fN%~K~*ЗSzgw-y֎f>#g[?h3?e;suySr9B?dswzE.d%أ?yf^ /XgoR}=ObQ^z*.rta~h/i[^_zz]lW\W?8g/о?m_ƗLu+x3g/ە{ڇ?m'>Fk?ҞWk9=  9E5c/ھOwGzOmxߟ߽#qYY8#ѥ}ع^~~L튜nO>ܢy4;_+,?@w(~Aο"O;Ļ՟~OqWO:?/ޗй'Vwg_>g~5{n¤~JM{ y]8+@7.3xK0_Q ɯcs&R/NN87_ sຏN^+}C|7\wtN+|½K@`s~! `C?6[.V/E=u@g8uEo07ynY|:C@y+VX{z4fՑ-.|C>};?V}R眤Τ^Rw}֋5u/1ε8/Jꆊg\aoo͍7ۗn^TO.WqS7/#ow=vAk>a}z0]=:#ڿ5ۓyc>]׵zP/{$gϩ6߯GAxAP9yN|>9kS:=u?Ex:+?lNprC%ucq}6=E'-~G~%K~ G[j[4ct=|EW],Μu;ޏ}(>ΉW1Eo;D_583-}9qBMs?Ft oI<įu;rH|8w}?C$;x$=c~S?ZjG//tcCNS'z?ɼ$}wCp~ T.l)i a}a_|MOT|ƺ5ͫ~m;&\vk1O:;WqsOq vn-ݿhBz;y]}ø}lI:$P%rO+~0P/ /?S?k,{ڗ!\uA쇮/jSWO|SN\ۿ|>b'w]7?1W.7Z}vk^_}ϻt/#s^q_^o_"|#Gw0K3y5z ~7ozW98/?pD-M_MٽKcZ!}E~<|GyqP?Arf잜C_~sd^ajbĉYSFψۋ;<Łȭt:_Wo`?8}q|+5|fT74!c|[v:;OJ,/F`x3WvyDoEϲ=npWę3+>F{>?&n#|JuoЗv}-/osW}9ăa7u 78进'g+d| q_p;Np#9~;E[~)n/Scf]d{x#/]9?O(>oӓGn}8׹\~^<pգeg.=wr(tM.-H];.̩p0ľO/9u +'>6ɛ]rS/O'rw 3}ĞB/=fHR|_['|=pf͟wVT{-~!O[#/(o ٗy]5G 'p=c}zM6rs_r<[P}7i272gӾ|l|7v`0|_.|ܦ߯On!DNAw|8v簟ov7;Vȯ|ӃD[8|1 ◵?Zy> CO0]0wm(S)O@k[??/l}yt{uN3ы|vRڷ"?c|>|ܢkE社I=YCvVtxZ7Ǻ[g u.j=S5S/<8~27J:PqΑdk=:yBeuC歧}拺:yGq~y#(v/:S7s}ڝ N#y^}>r)[?ʮ%cU +ֹۗ||Wz9w3f>λ t^r~QzEsỈuΑ+䅸%sN_;\Rf]GK~fߩ j8tl]'m:4}a|?wuI~wD= Տ+K3S<w gC~s&G;5\ ԇ&>ܼ=JOw[ЉKWeۗI/߱y-.8C&ߒk?y0'=6>. ߞ/GzodWQ{E9=f=c ڰ> ǛJ>-z9p:&D^|M>U߄ ;DU{I?&e_{P.#ẓ<:8#]XzyC.kX+lSWG!%_%ǏOW|ԏ&=4?4rIP~T! sƗr]\gAڻ3u)ߋBgv7.c>?"g7-KPu@xy.IKr'w@w^LM/90:8vߏMG?>THN##Л}o%qX =kt+z2yK֛O߈XI>sG7@CG#°Gy {=wNsѫEW[nޡ~}%Gn:zO>>7{y3zι+w#9c"bOWUn~lbfZg]uZ_|7Vot.n;I7qWV_re'7W"v_>n֙'䳸WaW~q[$Ż ~i{x3WxėOD"C8fgxڕ ot2O?p6?6s%qGzZkA|ƿߤťĥU ^fx x}ӻ.^%^/~ ozIOX|qT_">3_sQՑ[ȣʃ>QVuOb;u$?-?ˏ+y,GYǯo;=:z,\!>Ё<=ן}>?gU߫]e|GwNuqCcg864-BoT&s1Ƹɍ(ο yVΧ8Rc>OVwC6&Fƾ+?n"I?f3[=H^ENoK$7N;Z|w!y[]gN^?_I}Ϗ<'U~ݻ?#cGӺ؁v8?SȯhpʑT%^^+GrCqT>|;y 3zk>zgGoi]*IZqxG>]]{5εOoG<s/ZqKO:v#$׺7}ڹ˩OEG|f/ωSEDMnwqƕ#w/>p=rTVqxVJv}]$ϋ<<)yAxWyG.y1.>}P'<EŮ*ݧN}j<{?ݫ_=Ɲ/r~}OFixqmbGr9I:4/ϝo~~ W\~nug7<Mzޣ'ߦczg숛z/~w\xЋ^W>ר?_=cOZ=._o^>7wpT_޵?7zC:razplO}ϙ-_{Pwqk.͟e< x8|a;r'=<_p˟ߏ|:+߾痞z⏶~)m|Cz۹ۧ:yPG:z8?'d/K?Geގ/j) ~^h#r{~ϻ\W87痝~W6cG7WC{uHnu_O]XWwO# ߶ɺgǜ&wDߗCyW+yGBWWpxEn/'9{L}n{S^cn^'|n>ΡN ?,m>ա_z_Ṝ3!}L/T]*􁞇t:yu|~>P! :ލ.:_A=VέSX݇EƹF~Dӗ}sB]GV_~Apы}G?3ugˍO7h/5W+ù^ϵ;s3tb_uO$rn"Ob>}$ss?0zR_F;Oz!O@9'lБ{K~_#_{V؇+>7P{v,`'N~p眢KWUKvh:'o;;Za_ǶAX=7X=yHs}|:q_߃ =9־w{WXzoos^':?7^DWNuG5i x|FV+vxǐNbi_KϧOFhs@<-P˺R3l녻-~ݟ=ɯ?} H&{snW?|ם}%ND~+>ǧvC~6z]ӺqG}:J({}E>'+΢+v_E{E u?F^M.+ءΏHYq"R+)W3[N5^kzM5o_^kzM5^kzO5^kzM5^kfzM5^kzMߺL5^kzM5g5^kzM5p-^kzM5^kzM_f^kzM5^kzMxzM5^kzMΙ wC{:~u3g]Y gChpou۽ܭka7=÷n{yqf=ݡm]]߰c=o X/{l{cm'}Cކww;`|>OU8w~7woɗl>m=<~EH} gss/data/penny.rda0000644000176200001440000000067213267106071013610 0ustar liggesusersuԯKa n O,v[1 69 `p"j1 ``0 `|_/>s\~6OHL,ۖ\ڱoDl֊jKĚ, ~ AAY&kd\#6An[6CyLg9yI^ yKޑ]|$g|%w$輻B9N&v{9^{' ۞ g:z9.kk>WJs`_sc\|蹲o}]硯q5ON"I{IB9փn ݌"&GٱOF"vjWݖ;~R[D"2ns\-_|,6M*yQϓ:Wk~8RjҺF[%zm~7;DkNj-"ON?)qs:/rrꍗ?zX'rk:Q{u}eƺYM]OV:z̋59j~ZV;}7 >dS9坾CwJw ;@-=/'ޕq1" yNjh-@ @@@+r4uDB{r?'vw( g\q\䈄ߜ7rq@(+K/%vm^ +I~9/3{q%[+㢯إyoXb}QYO%/nϜ̫rkH^G'N?L=n{2^¹\мʵWG~P|&ω}X>7U;qE=OthPW{o9'4΋9KF"ˣ'~7W#[z{U%>qK/C1ūMN]PgbH蜌ՌFYWsRuKoyܬI_YH}?euN_˸|Fgg.C T&geFkɷ<0CO˰C}X3[wyܠ!wl""^P9;lp788P}F>f˨3udz.\;ʠ?w nK"IKG_h~ؽ/)/m^N=BE~Qh%wDؕ~ 2_!l?t>F;1~쓸ޣn;)%b+@hgg<%rɼ2hMJQ_$~7LOW3NT[㸲^Kx(K>s'T?xأy|)K8(#:*87 r8]Wt$גg.}K37eY?H7IJte؅u /`%~-KK ,QUT3.kyy|.7Cy֕ezY>'J>jSV[9=H;SK)v/pq-|Kb>YovH\j}mbY%?)ǎ (=N;> //LG bnC}ٴcAeC Q^{$_}34ty{%tXudqzM;p}HXPǶ?#zهIξd_~/H_t?Y5..{o+z~az\Dqy%v eeiNϧݻ>Tzͧ=N_}\骯>}bHwIRry#.·K%WvH?Ѧ\b/ȼQz)}YO]7ڲ&j2{BH|;_ѧO~hI;\LNz ޜ|^=q}FA/?~GCzU5zv@^F;T9 B_|7Lpfߏ]_/Z/.Z_}Ȝ=}~(Zo}'~Ty{Suq:E֮|aD\p z>ywvF^^\8?^ߋ#Qms~ mm;X ćZGw]E_7#P_/a뢮k%ԧYϑ?[yF~{3`i]B}?^oT,~7uq>ז78WIp/^,ƹPsf1&{M(6?cc+8/c^/n} ;?PNq>EW' o]B'37ɹBc־}Ù#7uīe߷[pŲw{d]qKOv1] h<+2>']c쏩z Z~N5]E;WRy#|YP]d_p).ϋ2ڹEYHg-{>x%*x> Ai[=&Mas B8K`qq>x:D?c~Y}ˡr3tyo`G>;'G1؂;>]_+J@~Cw7/g<"]*7ywY;sP I_|}))s r>yL}P><2,}IAj}ߠA=g,YY9Q=)7a2OApvR:(NAn?vxR=՞SWR_Uqбq0HWB߆$ny5U.aQtT;WWuUpggWpekP^pPO{,G>KSz<]yoYg}Qzucu"O#CѣY_F^{eO䁮SدQȫ\}^tq*#tx(޺6IZ' U5H{ uJ垊1,41iəGCω@]t^s+Zfur^prާ[UP?ĭS xnFwx!8SU]/Xwr;~*is[Hrw>O@`"$'{=%}#\⬡݇?#xxldqd]as\%q=W?@b|"YЂY>vXMTy@p@pļř';d⍓'whlqI-9E>oSt~Ʒ++? Ngi;ysi;5fg3Ћy@/^agc,ς,q-YYYٻ*W U_*U ~ջh+ϩ_+nps:rlndz?vr$?=<zщ_zLuzyEoO~n -[*i ϛFfzQ/Wbhgss/data/buffalo.rda0000644000176200001440000000044313267106071014071 0ustar liggesusers r0b```b`faa`b2Y# 'fO*MKK2!~&rmi s:턊@Q z"·dЁ uw~1 D{$D_%\|ցSA5jNg}PF{B3?>2K&@#9CsGT] 419:?jO ԝPwGB ;41" 7Pqp PZ.gss/data/nox.rda0000644000176200001440000000212713267106071013260 0ustar liggesusersVLuA/G*fσpZ؍5fM9+45gY3s%k]s5JȥtuqyY>??wMl$[ؒRIb;lmɍVv/ٕ./(طc(Y\W~ꩺxe cuc~ \}ave/'+žLêݎ5K`gt&g9߀ʪ-3wĹgK<<#>UO^PYg+{B$ͬ>?!sux.? ?^ q0*LI4D,<-?E1QbR f@ ]H<@/Bm.oй)kq4(4W@7H#|;^!@"ɾ_ѵ 4=?}@XbCu ʫ~EtW=8)̺g=B}KPun!,y Z+(h1t* ā*~x6L G~ A&L6@L4OWI/#Tps~~sk_qmJ봰SŹuL粨H 61>iV}$Z*6眮wOG+pXO-["]|t;D.M/>o7lM{eſmސU6lo1  ]5xo_DJb& gss/data/clim.rda0000644000176200001440000001267513267106071013411 0ustar liggesusersuyYxm7NG|z7}w}ww/}{ۻ;T*)DQUԪD REB>jT (jRH6M}%?<<} w-ܕJv*vLם;nqGjgjOoR9Ծv?g3Vsv 7hvO+a/~jxiJΤzpo3t/Ǫ8l5ua'pȿZÞI)A8%np(?ۻ 7zK8ok28CE+a5r:>'zDwgBwW8} ~1T:C%T&*}>}/T,/BGۑ[]'wzÄ_Op>li&U$?}_e^]2f¯?_7vdnݗc|?.@ڝw;>|o%.x_@/5E1C?A׋knL?>w8o:ùp6Y?jy͡6p1~.w};8'+ߏ>]~a'WI{v=~-;qk"qK?mm@?b N5'ZuM>ae$f]~b=v%A8Xn_*֓+Eףބy翝Ձwۙo/7E/2(5?lOឰ WYKӳΏ'zgwI޲oo'˓ȯ=<üݏS.Y7e~=yI_g@+?zr -zv2q {AB}!iדq= !Kv mq< iȺC;Gye؁<_oq\~L(_ Kz.a?|'O"WF pL)٧'ENτӬį)^j?|k21,|V緿ОDp{ Yڑ{uY$t`5+v] ycەUb};Ր71_yU?O8߄*ʄ?W&·x# :"?3M;rQۆ!7Ojc~˞vɉY}:'B; /ȭ~9ȹ]wgٹ2]z_H/sН7 Cu'2No#Mq4x qj!v>(lq]. }򲨷P<ÞK<vx&~6WZݾ-C_!Y+F~Y-57O<v\bܫ/VNq>rnD+z}: yl'ﶃC~ =1/mʻ_Чçcԧ'#]u#]OX2~vy乪â}hFr,~&K8'?E>6og;D'5Yu(W=ꤟT~(Gb/Ow-5ßC{WpY6Q+|݊?mMZW/M*?hKniiVw6Ƈw:OrkQd~?P~\O~NҴ=~3Gw;'z fWoC}#1eC_cٕ__()DyF޴x.RF>Q=u"D>屲G-0P_pMw|Ku^zQ>|E§xu}'*?F;ϡʟ .a[D+4~0|}1 o5+c:&Ohz&Sq:X?'-4^c7&{b}K+o~==_j?3͓`~E$AW~K i?:߈sBt]yɳ}:O(W:Ӆc\DIʗUyߕo73s&̫g}=<gJh= 'H?v zkqT=X/'_< ZK?$j;%Go]:,Zٯq_butlus~s~0ߏ龔{k(*>˯>^jG򟒳䳷ԟ.ߖ]2}U/YGҹs^/|hlڋ__YWq/i~2_|9~-v淔s.i[O]:?ν0~3~DշU*^I7>3UT'v.QhY\[ȺeIvw 5sW齎߯w:?@~cDB_.-zqR oTEq/]~K7.ܞ{}#X#Z9'us"qwؗ 6qnlou'1OɺOly?e:^#E%~51.ȈO6{& @=VpyeSNpZw{2w[G ~Z>73[?}l90{WU,-{><^/k:"s>4Ι#nD6 9jTK/> :Zԗ^Ho~ i98߷-ԑ^Rn֑G{ւ|Q7G]!<C>:G󏃿z,};b~Y87^ i {G$`Nm'j<}{g񷻹W[~{d:S^8-T?6}){̏B즾Uχ泈=vj~#w0}cy&~|+zt0=o2 Uo7GU/_k}[㰧Y ZQ:P{V7!=jѹf/1ަֻw(OBp?|BL%5ڜYFKfoQ.{vy=S^{7ջWU+ߕ=>*(8ݯW^זowO z"~:WyUitKt}VaGX*pç7-_ɧ7?q:Of衮W]רnn۴V7-S"i{ir__N͔9$޲$Ez җdBLPŸo)˹״uM/Ffh8͇Osx̠׳5 /A_g,Aѫ ƕS.n3y}{ xV =Ygvq~j?fʮV|EWЃN{VMD^+qC{/Wз_5"|{z#y9L;xПGc=k+s-weù&?(z7ue _JyeoƼQyyOx{*q- mZ}q׺:_Εh;nS=q_5yG:G"R\KVz?Gyy-/6?xP#c>_1]]ۘu,;ר6||c{1nRbvcMT޲v6[?va3'OmO&aWF0΃ms<ܯ5/ҿeC<'K陧? =W;׀7ԢԳ++/?KY7߰Y꿫5g,P'/v|f\ 𝦽 cl|&ເ.#eKӢ831"rF{,1a9^._|_*>K_b>6Vt?ƒ>Iytx`ELHn+w*κ?' 7=:yA+3/8 ~K/SeM;>O|~sB￈3tOwKQuU݋u_G@t~cٽ~g*ϰq/xcۈvw(Il =Ll}]Jԧ.=ma[V _kj瓶Fla_q6?IK]Y yx 2yM55Sp<| V ר#֨TWPy~ɣoPWJ*:H/. *6A vPqX;4Û>?y^>ݲXꥭo/qR8aAgss/data/bacteriuria.rda0000644000176200001440000000170513267106071014747 0ustar liggesusers[S1mA((Xi6Orp)Uop}: Kҙ|%O6a87y71䝱0Y6kF80pw`X:0z1 OL$pCmLE6)Qn !p_`VG <&$%sxȼ.a!X$B%E^X& &JXކ/A@L`:%>%$ >%EJ)Ngd,vC8`q?8(Z-"*!bYo_Wz=>_{'sUC{^t1]mvusiz~08mr^GWS+mydS:ߴ?~%~Njl>v՞שއyFMSAWmw]iLRwSSVi_uߠ{UYCDuS~,[?R'Q]eǧzW-ܺ!Yy@vuRG5վrZ}vn2*nyAUW=gg_PWVjWo0(l4Eojs{jOv+Jqfk)ܿ"6>s O-Qgss/data/esc.rda0000644000176200001440000005462213267106071013235 0ustar liggesusers\s.B6%3+ eeWdٔYFg BZHڛtQ<9u뾮&xJ6D;-{њFcvu/vsX6:o~V\Z׭)yњuBa:+󰵟hea VF:[+cZ+8"VY/?_srkuAk1ц}-cSk-7۫mwD+e>FJoDe:5r=,*?(m[;[s 6}KGGdckkKs?h=i|.niqgé#cqv/Yf._ hZG[f Nլ-ⶵj翖bkD+S"ZmTy5nWs=֘mY 쭹wmQmغbʴEMi+U6L҄#06LqOP-Z7[NmۭF]٧Thg Zٖr/6@k?0ۈV9YJwD"̩"ikhkݢ-m{06٭]#mէ:ޭq2۠VaA?'8Znhۖa{t`ѶPt[B6[mу[+#V^ѫۺnJ&]Dÿ VZk'ҞH}-jk䶼-{JV~{}3myvg[F\ݟ*.oubkk[ly[m -%,yZ]-. {V[m*&>¶=m\_}-mWih_hڔgSmUaaM?m!}žjK̂hk2iqs)Be\޻mp"2v{7M{'`45d-UiU)74(Bˏ/s5V;!;Pgw|~O93[3$2w#{NH|}"|+9x|ŭ33Ց /Z?tO}ƴQ /t_Pa# ͪI+)y#n_{k'=G.]yE2hm]#; ߱^@tZ4;8[3l;ZT'+SʂhӶիC4i׼Dޫ*Z{ݡLCuيv&l p%ݑ%I>u͉O?QC5'타gҏY#qt<PoʧޓJwnyEhHBs{=`n;)"G"YG EVg,d/ܺ=1C{Mar6-G:3JMʹNEɢN7uCvGOGY}昕Y=@UX%T$pC\ϯV cV65l|uoIo>6 ,k<:nm ]t_K`=`F 칟UBcCtu0Fc"͎g)BzL"=Pa1,_-'^yG@ciAŊ 37ԇ"T^ݝ(() sF݃Z"uݲOhuWFr:;m"u쑯isuHS-{j?},𖖫JsBAݧG S/dSD ^\~Yl꧃ogq9={) Yni-K+ق )f^ɼqSa`j1 NȰx Uß G3U6+oSNRDjAܛ Eu>ۜ9Yr9RחyqܘHQ>"IҹuP4cO4kEߊwV ^vA7צFFߚCō}Dd _(B‰E ;.CM[F7d+>?s UC}#V"c ͙&֣J&[^f,S\t޲{y7'p =0y9SΦ)hN\H4hT]:gpF;/Lx<t e -]L-Ӫ062mO6 >"d8Z\qpD>_tJEzEz?Eh[##|{YJw|YRDBud M.y_sQfǔ(B~Yfꂮ7 !yCh+].^>ίY=Ӈo~} }d<>~-68F4 _/WUM޵d2bgӔ_&PJjf\e[靪e~4+{̂"&GǗ;t5cR7]Ϗʽzh3'ixƚrw~9)иLu CE-})ReΜrx,23&(6}Y=WNZH*_@f*\a!x)gȜwUCQ :Ln%+ #3 T߷|76_r/C}{@>sbHc(@+QVcra#ruu0!?JHr fa3=U6[~| C>[:@5)h5IlyK$MbH 7A2vetxj}Mf#xق9O= 5g\ߗ`]6oDbx/Z (v]6D)" ݦM;Ƭ_/yA*?=94 SV%DEPTS,PDlz̆S3[z(nzSu_/ 1Yej E@AH%JtȻَcAU*?.IJߚV,7>v]zEי%$*D/fu/g}zA̰&ɺ)ԇ3lU-P~%re'R"MȌA*Nqw9s(B}̸_3z@g:=s;,owEjvA)wʸDBLȮ?r*T[xMmzP?siZGAI #/+e[~ ^Q w>cj TF{5pN#[0 d,Sd>u=_f21Z=ZQT@)k )#jƛ(eֲP Y9SPy½M\;#hL4Į+?r4EdV)~>ߒ@ j_ {[ʤs~بIꌵ+l=f?M∂Ej!'T3)"YC:Ȟ|uo>ZJ"ٿ )[:IR9HEX3/}6pT0 k%kQD9F#Gp(}km Ed]Af#W {W޵h+M93T!Ӄ P3PeYEwNild|>scȋG"izYf//!O~b9z+2P-\uo=~\d]6NOj˻@k-uf{29 ޼ZE&k@HGrFImsBkmt&xP7 ޛ5\TX}ұo8m|)2;z.*lóoN,7 {ݜYiʏ)W{0. APkS߈WGݝVﴪIXtm&2ӕ}Iǡא?ν˱4:Q˓9-)V3P>Mcq'qU~DS`6K?EP qe,\G8:dPDf\ q̀y)B ~ ;}<ߦy=)> 'H?Q'܊_B'Ɏ4W}2:t_-xEZU ھMCiBmT~w oG >4^YW>c!@z0NZn. ѪܺՂ_ywf? 琻 EujGԝ(h9% ~v6$\3nhOݾm . ,s2MǻQ/!3?~4+-7#Ce/)BI_/~.#=QPXnv+NVES Дl@s{ᔟ[:uUTD-Σ htϙ &Xa?MYV_qc8LʓQg7_(BFխB9Bd#akugι*qA5s(UȄ#}G9gEDsLʌ{ܹyZT6} wA!Z)(Rt3@di%wC4TkGc3EE~Q -zkTn>|Pztu;ԹG^ r,3ö](B{Ҧ?GVje!KD6;n?!zI>nL*5zq=y_]+lqif8qWs6{eZ[ԜRwWm+;_πWfB5Fui3SR( ;5rud:b`arBu?B8W{='ֿ~K^,_\2tO3#|d0gb273rqᤣ `}'9MS{׭UoT߸,2ѹփhجT:[T?Me[-W] .euyˁloJ/DcdnwE A6\&= w7RMW $o:n+0 lu[X}:ޓ&H:4vh[|'nt t!]qoͪpHfmOaj(%P>47Qf}(Ra`j9=SzUaԾdHbC&gTe"qtD'DȲhdX3ʳ,̑-7 {_zxy\J>;zy'WMpʬI)4]u^!{ U=?GBɗ+1'v_8՜<9{~d(n})v 1TocI[݉i2L]:YIj.)޿XFb4ufqȪ8@hCZ:Nnb(ukUfT<@^,B)Bie[23v{۱t速W)(VjW5^E3ٽw|އ{&g퇟 n[20D+F2~6Q ӈzˢ_ w Q; e.OAShErd.DS%sEPz;$E(5*:3 /&ٜDgco/ʲ}'Ҕ9H]Te{iR*/~0aJ(r'~?_~>#ؼ0Q+O֨ v}2x*2\ҿ9bi(`EœmB^=K* P\>9~Yumźj]$ܥv:u(ߐXa4O%Z[j]}r#WG/r -KZ#S[lyX}Y?}IruU rk'P@FEF} S(K)"{)CɉMZP}WKrN%Gk-=JSB,CM;YCSpL8W g=86)/r{,(Quf<z:M`J [n⚨ 4Ւ%~GzRv<2`MYchY}y4'r/Y֜FRxt`bEu3֠99'T10c-(_@nKP7pYt*?ٿbfY[;&=! |_57\qY?vU Jy dH H-Hʹ |%xTxzȠkG7"QaSKF"u(˨\o N5(>rN[.ʬs(BzBO6*FUJμdrțg]qʡLWp{>|mǍvZm;z(nTwلn?{nX}d%'xzǠ^dzvn?2}/+΅iw/.2ɒ jNE~b%6F ;ɟfCyNPD: ܱQGGӣ)C>e玖Bb4jhEgEvN Ń'q"qѡnzU4IkI`".Џd?I M4JM~^ 9GoF[^_>R+:`\ j2l-o_PdܘktSu<ԯzf!Hs]X/6O!M.)UHUE_ǯsI |*9e'␐3bSr<=v}B r,Un{fbqWH4$<8>|**it{P7R9 UQcܐiys"SgnY8d19YKF(&3nj3etT~Y|OhA4aCዢt_s!qslO6q"kN۴ɿɿ{qg I_k$2Ɠf!jґu]vMٺBU=D-CF:]{ܜHdxhjtމL#=5F2v)E;ԘxẂ5lw6-dmv(V58ĝ@}WoL]~֜T~DC3~2 }6&. ^{Hθ4.-X(I@DžaDi/Nl޼BƓϯVt`ð+ׂHle@Fm7b@xquȘM>x%t| -C+%z||:K.vTI;2r3ϝ1^u)2=xKj1@˼yɌx`74OW"N{JIb.7% ;2uu 0us{oVz3uvf {4Dmg|."cǛ{6QVpz@slb+Ys]>ȍuo2>"%]a,Ey&r(‘?7aﬡU%ɀ?E|3 d(5# sf+y+Sn:]Wo5?ic{ +2 ei {~=nF# ?,Gi٣w?* cO^;՝xWvA"CAE(a-cF"w]SO[U2>S RURl5 ?s3PlmZR)Ryxzn^GTRg+w<R91` 2x}5|'" {.T<9șĚ|RݔL?JP}͙P\툜Rm5Y1g6Js! O5?vҢY,{hs~R/4ݵUUVUtmN[+([}kGb]"\p[,٥߈ȞGw)G-MhlzUUk9_([q[FW Σ̪r۲ C hJp#UnP{v> nB?6Z7oNdXby_K\}*(*9@:r*49inj+kָA%-7+Ը@ FE} 6Bz% -6 ;J3wrw>0ӽ棖:id&-~2̯S!^֫p-.^\k :%pr=l>;jv:Ȉ&Ft) ?B.#SȎPDyjt1d)0j~$߄SjLErܬt(@UB49CeoغhM15͉mεY9R\ PUN&Y"BSS(xp3Eb kנJD#{d { ;`n)L% ~`_9pf8t;nO~iUTlaC)ͽ' Yo3`׸)"pKrH!fY4eh"4pG[iV;x[灪_ڹCqIVm`2kx2lf3AV?8jE+`Ӊ܏6ؽx'>uUAbja=#apl,a9PxTo)9fnV,M (Bi-r"U=r: J_[GF[A*G #sʋ)B݇Ly[$z4fdC$ \CnCc!XbdS7Dꅚ%%c0ABpMΚ߉f#/tд9y4G_N-zBfY>{6'*(/PS!Bٜ6%P)s2NwuSbU 6yO׵}6A{uRd}ٹ(5 崒닎R9;͆17'ьVa*w+]WqG==n/FC6;4_E*+տ~6޴"jN PJd-U޿DC&Dp%z HȌ} ]ޙ} jukP Cgi$@la=Y7=DC2 n VRy?<C3;"(Nр솬T_5RiϽvp¡+="Oɛ)BuˮCda.4VuK2]䗟F}Nśk;&j!}Ɖ#ٖ"{t}EyUp]wgxbB^~Ih.E#U },dL}ŕ\ AA )"z(Rf(>fP# 6P#@I#z-YC\X8~72X2_\oԻBo0i(Eud7OQ,j*/NL2fۤYCgEC5zC$=ڄfc%һXDv%YZP2Pf@KQQM)Axtk,+zїȬ›YEb r~Esz.=(;S@j*XỌI&Ju.~l rI 70財G*9|$t{3Mc1(uk*܈5?Me ʴ~"Ϩ:x*dz԰(&߲hxAfcܞn=Af#4ٽeC~!u$IGN{)b{QF֮_v/3Pc̷ qNgaN"E?ܵO*H(|݅.FlR.ukLtʓ[BqoAvnva[5*lؾy2";ѕ"\fK9v0tzs@<}x{{sGe17q}DcDs߯kLB_7Z5ٜ"TIt>?*P^ɒt@ '֟CK>K)#K\a8Xews?, l\䉨4yZ ->1e^!}vY= ?uDeFE$Nx%;*"$.k=k^ճmPjTfZo] oH\@x` ܓ2.Ĉ-7l ~S=WB^ᗠ.n/?!a&o$Y=~H8w(J\q("/5[sɿ.1)S"VhE xÖI\Ab>h:i&HhIo%U1PYZ见,HERz!"9OL{X;CBWލ"=kO1ğ/ :"Q˞f.&ϦlN1 oS'^2%疞%8Y {{=TkZ_Ύp՛Ûy،aK|'_Bi4#ѱAː1= NĆk U_x_;w껝5<+:]6'TK&E{d2;0C<3"/ ER;A/7Σ?T]y+ Uw)"c- A!/̡,*$Қ<{QTlqBJC8^vzw$걮|yʫD{Ь:07.>Qm:r:r^"G-#}bsu|<jnXq 26L'P=`lIT~8MT_?g-ϔ0K=M)F"iIWEo|V74p߈cȎ?H"VPDK}g)_!EJ irm/I=>b(YO?aOn{@P;v]Ħk"QP@"xOs_,wGZ* ߏηY "_diʐHQO5Wu.QH4KpEUz t]ȞL殣ya-J9)b nns1&5nnW:yƓ͐p$tGx{>ZU䛨0sY (,CW [@Mm>jPc\pjW(a}਱8u{wtYӃ1-l[4ol9~;-A\O&_ȷ 6s 85du[k਴eOf1ٔBI|`Ezf=A"RDgڧIGސP?^&x̭)? ǂG-<ֿex3d/%--dȑaș*ɛ;e+p|sOjVC˔AVہh{.Cawɖ4‚bu>9MzQF ~%.#8 f  Bkcl kaf'F|3I%w`MUL̖Eתn.g~&K4ȌSe P'ٵC]vV_)=AS=gA+Y^zDBڗLbPD9AZ|#~*8gL e㭲ΠH5)M&ǰ5h6 dxnMO68i_ [@gf|O>M=,տ&Huc:oCqu )GEپr{ §vg~rju+.ܸptm~GAe;f*ﻧ얺JUxB,n֚a)PcǠ32/nGk'~8֨_x?8m#i"Շ)\d|6p˰9!c--gmnv' J44hvޡov#Hko (aI!ߥ9~PZZL&hw:u kQ}Gt]}SP W}:f["H}6^G,mA4&ށ4e)i~΀jʯ f_OD#N^1*rS${~@ 'Y5aC~#{Qg6_o?^oSLݻvNGF2YaEc:u'f|FUvHLԭvXEjěuz4|ȲT dd\<}uE#$9l/ʷ>m@bi|PD2ӻN ?_$E[m"OXvMG_I5n'RynSY"c1Go_œ(Eߐ*8Nԍȱ?6=ǝ"^BDWx as֒;k٣K3xhJa'cw; 'o+~ӾJ 5̾av&?\4i<_޿_a6G`v/`wqށ4:[q$$>OTt@i:E2WOf‘}7NpB9SŁm(ByOwnmW#5)Ru34y\:SǵTY3_,NnKY\7y w3N&AIw) GcBQ_{l3V% _J q;Љ2`p+{X'?"ݙlD]ْx }OЂ/4Ul~|]'訓R+Uy4X27]Λ%R'݀~:B /4 FA+(ad[u|W$nʓ*|i b2|Y-&Ӭ TI {QarȚ3^slܨ# dPz|YɎ#GI>hLhp&fBn5O.}\GNoy0%#n8+"$v_$Mv^d"HPb]78P5Ee$>gkl%d/Z4=煱BJGwQ''u4x\B22' W,/jv"|I?[Y{AY6Ҽ? 1(^<>r_hڼgDmr29慊n>ł+uPhWQ9&!0/*iț%?E1S/^n*cF tK )23f.=u 9>Mv@N]GK|8z" n$ R]fȅR?xH}O2<2}'E>۞T ug%E ~Bc>ōDYeߝhgT7qq+ 2]<ԿyPM AY2V,s YR;1wFP$V>/wg2 3 P)#uU~C&r 2\ߌ" Y9&]܄)BEgwDEP-1G u'fn:a՝p hrh]dT ]cQ!z*J;F-5T)}~},T-H'9l_ߺGߝd-uPnۏ%#~YA,š^|Y}tn RBu 9زwqYdz&?4;y{"D|{2_U"p54AK&km]W(De؟:@h>Gߒڏ/;Z{ \CߘA=#NJ5^w3^qk2&'?Ecn\Cirj$bLo,% ne,K8:R y 7/4CU$/\2uD sV3ޣC0+EbSq 2?:x'*/i@-D__w]{*1vM2htt}wo*oKA ~9_+/u.vFuc#EpӋz*#WL0d &HL_$FS$m`.vJP2 q6I,n.ثMy~Y+}q^KBх c M})2z%'l =oY?)!PmȽ9{߼ IK}#!"1mɱșdxIڞ#q 4$:]jLIɘ[ʸ/#V}h]ed:=$vxLudn>3H4K3 *4#k:ѿ7 n (BPikOI|姆RZOd 7x(BFO*W ~9diig]Bj?ظNDܘ2P1G $}3Azhfܒ@ 5#*>NɫC7̘ +^# '[A)9 HH9r/*8/h!:ퟡA‘qŻ-K5Mk|.O qf}9(_71W;=yG:seQKRW^m\q7su?(o9o>qG9.4Hz@J֓cZ-XqDG!dzL2z& tc}KdԹ4\ɾώ#;e\zwm9-371fqP1OQʖ~MdEZgNyzg5Ed%+iv~Dc~j$ f-}'>`N3_pak_1 2%lQR&vOlg 9ƾU<7clU'UY=O>ֿ7jIwPU}}4 SWYu #`LۡflɽA4"vRD 4 {%yɫv[S;4ݱe_6 ϓg <^w@n됨i1/bS~ι'M(?J"KĊ0(]U[؃,_]ԇ7[PQ"IdDwL_K ݕ2:6 a*GdE0{ F+d7PriE^͒sVwJ+C].a/{ݰq4oZ$i6 վnAjr H!تڝa5 Ο+\: :|TN;͂K3YzAQ.+x7Vm>2z1QA=lsGN$k,ׁ}Y+y-\E&z8Q}h6AMm`r"UZ|׉ӟnwa<ϯg. |jC )Ą2Dub)oDV>c92X}2tsF*U'$ƑC]:g(V\sٕ- m.oTTS >1~`q.MQP$9(1F-> m, $ ~T]f(Gv۬7KДy0[\8$iϡA9dg.*EUS)"Q"Qԡ줙hnv͟d#O'HpN> j$cKK<ӗ'@~b;ޭ|ya!4}({ā,c=d7*j3";/n/L}p G7#Phb͵T&'= !L,!WH!%2LnaGSEnȒMzC5#_:MWi f!d7\tK28#j^ȎӀ2{iGd{M}UoXZ }^z__j]ɯ+4ƭPz!O:o0iNxMFv6d>uք"\mt~B%2q~aуW#P˧wPU_Cl3oW_o<7"Ur`^tLwz}sųm-E~ݽ!2._ TᲰ(ס"G#QAФcsδ`ԯƼKy>]ewY?<6g? MAFc#ǾAP.{ ]͆:'-Jҝ"d m&kGYK)+z R+"?Ȓ_4E()$[K$I_l]<++2{ZOk|CM㧰I(Js2|nCWǡnAy]gH&}Dk,c(6.*c\7X]B;F\`bLwt`ZAY53 :2T=Itm<Q~=~YLKA_~F?KFP8ԩ(un_%4T49o'led,XtQ r>#;Iod؋]Wd^ "7\njPgj]%gMx9!|<?3]Gf}gmq=1&yK?q,ņ-}%=L_'9l.vM I ÝLUnv .y(C囟s6ps~!7 +QD{NDEI_sTpvU{;esdɭ3Mti}F#ɝ8ʌro| f7IQ?*=b9v/Yt-H 3o;@3`,WPk}17Á"ʒPDvgʶ}(B-نx n\i>4Mks>3)BLcZUɼX?jE|&=CZ<]bszJ:,vDJDb"o!dս24kB!}pMO +tVc#w љޔOvgK$3~1nR!pY~o \.4ys#NzF!P9ՇhyFNOI7'bSFJ_t~C#VfuT&_^&e @﵂ZSTr?~1DwKG>Pױ;%H ]Qyhѭ*%J=T0EGt]~C~ sL9n5Mv|orqȤX)k+p}1=Hor'F~ksiR}"O^y;@Ճg#m\ސ+!7a+. -;ȋtr={xNUW9`g߀Dg8i2?k.8֜ȓ:$9t2)ZYFA/Js^D }َOJY_Wf+CI{[Zaj,#!Vȭ R[+J9l=-{/OcoϞZYNq=n|lj m-~L4+Ig3ԃWW0]f y&H 'ͫ6Yno|9Ib6hd#kF5}P?`o߲z|6zzPȓ^OC/!cf5H!_gss/data/wesdr1.rda0000644000176200001440000004717213653215753013701 0ustar liggesusers\ywbA; % bPRht8lGLSRF)MiNES48iJuӔNJm)%Ӿ?ߛyR\f+~9|=Nw=/;phwv::u5[O[g^Ͽ 7wo}ߟ̭/O8;%;͏n}[?i{/q繭[O}qO}=j=e?f{);I|{l^:ˎ{iQ{ϻeetl?u3?i{~㞱WWns?fy?cu^?igp؟:mfz֯k&ʅ.y߾-Gy{8^}>i磼PN?9׳[gzO­uO(|o8+9y]rLc4<~ /&{kUyXl;ߌ]wz^7vE;ǂ]w@~.}l3Ƈ׹R/cW䄽R]=8^qz®Ou1y_7)O}m9ߟn)oSv>s'/ 띲?mz~9f1:?bק>=n?e>c[G=c%oGwGN޴ ޚ簽vu֎''=rhף}8i~A)v&v^-*Cyܠ*׵8~;jw=ד6^L>oQS8>wy^ϩOg)wM~.iώ>;(91!'<';|b\/.yhɫ]r'vK;OcϳyQ/O.{v>ڧGi\hE)޿ӿ]GU[s~^gڮKo/(.q7S1բK=OrrrFO^re3f#^S/z5=Cn>W{΋/]Ro|"3){3:eףpPIc{yV9)Wv53kG~NQ:My=o8񙭪]C?ʧ]Үwʞ44>cSUs/M^^!?ެMʷnVǗrxq"3\y6M?n9myRq}&ǎL^QSoqw>8|I~$9^~R 4w{^ƍGO{Z gP\mwQOzzўeqnw=Ng9o1_$uJ;AH^}/=mzYVP~/.Rէ_wWhzvᵪxG{¸q1F>s=?jIg{M_^z~,?M.1?gta1=xÎ?&zCCsƇbN"'ݪkګ/b^f59{<G{M=qIcO nTs_˼?GF5Ω?OЏTO?kyq:*q$sy<Ɲqy?qL?8wOJX>_ zcǞ~g\XQɣ3G~=+%?oVE@v?ۯT>ߨ]kg}~c睐8 } yi}w卜qў0/L}=ޒ8yG%DϼWZ?2nbr8Np\$Ϙ9_;|vmKjת6zԛC_?OK'`>qUEpNnU:uɫϦ};9W<W_Rvþ_uOWEG}9/ft:skfj\c=K9#W_2a׿By39b?^~FUl>8;\:k߻fxY^)ߗgLOZ0c~!U5W sժ|o|\B_9Y_JNŏe|pL{W(6R8·_ݱ㸑#{NvR9/ߪ}ccWrty3ت .ޠZP0}*yWɳ]9799oٱ;7ROC9r]Qowl\u+p\Ov+_pƉymwwLfzy.3_GK;L=jË6+ԓgm]3y\b'rJ5|9rdvuj3=czjЮ'u{#s6o?{|5{~ڡ&⿲{Yvvjfu69]1F7W9Vʿ뫜LUQ٦_ec~͵W |]?"qE{;vwT+|ӛ_*8yתvO?~%+8~}NɞrAJ޷_88<3.j\3͸~+*^hv=uu{v/?a\D{vF綠xZx2A{2~S~ZX_}1, 17qf{<]Gx5?R^=·q72o;/u#ԗSO%W>S7e^6Kv]sirɼ6FYcqO)ߦv\sp^Ƶg7^#O7tr)7A?3EaqIUڷz~:냪ҿeހue3A?<7y_3Vϋ7̏1?tV$B_q>R!/r~f37^}yRN9N9)w)ūU8OWy)e̷2_xoG⼙=2kcq82y:[E_ߥ/Kw8 kThGOD9>{}1v׏WtI|'Ŝg_JJ?O=dވm8ǥf5~q<_r8O%q;Ve}Q/mUk[Ի7x!k< ,;%=c׳_L?}&oi'lܯP_|xY[+'w{=Ko\2x-CUv4e^[Ư<ǟ^l_b\Y/g\<%6U/U !J}D{D}rjo3جƹ/I= `^Y^ǧ<d=&ee{~g7n39_<. /uQnP˗0ߗun2L}Hyz7o/}ݠ<+inT'gΣ9szqsbwiKrqUz<1(|k[Q? [~o )/.15?GQyD>y)U/{xq _xwV]jzs7/º2pF"<ڗΉvy?S\:'Q=xX䄼?%8ģe ~q<# GH+2jYKO߬is2Tf]sY;~X֑nRg.ui\suú*z+׍^vC{7muOI oRu~:Xu~9嗪una;:{;xg}~XgNu=7p)A{xu\켼n]?dS\Gީ+ץQn/ KS~s|^rĺYN~xL_짜֎c_V\+ oӨ78ԏe}쬌}/Bzy>e ／e_CRͺa֭R?Lq\7+urws=Fu\Ng91/5>:\gV8`磾~zyGD?&Y&9vDq Y'Jw^x߬_Qr)W%ӯ9$~U(fu=ǟu벎(nqܒuNzrb߿K>{>_>zڃ JC_8.\,L\my"Ҿ:y/SPg{~S^'zuFƁ미tC3/I!Ը&~~f^ֹu܉sGKH:4\;?!u#{~Zu?C|>NA?O֗2bB=? ko9Dn|:&څ㺯-Y~Ǔ'K(,+D=$}k7Ms3!zr|u6+#U3׹Ae q⬬ԗ}N/%/@vTy}br}-1~)/qμu٧r\1(rE2~y:C\:oc"̫L ?o:$v'ӿ~Jη"?-kAky#qKG9>G<*z댙*#|\g}#oͲ.oWee1%|SoNIvn#>szٞ(_~+KbyL_e}r"Y^69sԑ} 8%.Я1>|3_`<j/J{<}(iHXڽ%7t]x?+GIWOʸ=!NU(/_ת3;/q~9?~_H9>6 $ot?~>\$'jyjrS7|y<^)iBQS#_xh] |qm$ON֗e<Ǽ(獸`]xG*; / K!*<11yCp<?LCKl˽%{'Ar)/rT+9xP'ye~*!mAr>ժc^g?Sռb|3E<+P>fd\ Ǘ-<ě|Gy'O}rUGqY|F/-E:b7f;Qeހr˼:X;(ʢ؏KiG̏-ߗ//{侎_!ʌw/硞z#rOzXsC.~{ge{ƵI޹ԫK%ޝ<ˆQ+d9wp|Yo3|5C}iƠy⋒\<)N׫u 'S^%})/ߖGyd?|?K=RA碝/kDn켶mKKZ__1.`nS"~2idwP_,>-l^Ο_<|bhz2/󣢿yğb<̈́襣2xpKO~y5CCe\_y 2WCP+[bU/YMq 3Գ1zJ#18O{kϊ?A#S__Mɼ]Rp^,Uǫ;E=*q>?y:¾4UOR}wr`!~^+O4wO>CwnH{3%S?q5 g~nZL?7ܺO{Pr$1%3vD䏧Euynɫpow:d~QZK>e6[~]p~Z69<.R2$O=)y*#'~['bS 9$7׊Խ>q ݖGel|_^2~UV~qM^1qyͪIAe^@yaoSO]g\1./Z d_){oH}ɏR2}Pʺպ#kO$ן;HףcC\Kץު/Iƥ">tBhĿe H^|)a_:㢯˼v9"~/(9-fCYCucrmH}ސ$~'^y~%娬'nNKz]~dJk_!e]<OS%_~TꐢH&u7߻;$u{sˁ͂w䷥qI~dE'?:|ս{}{.Rp|fY[O(}~9#M'hZiQ~X~SIY/$)Y}OR2!xDiY}yq ?^oMցLJ/놗/d~tV)ҩOjC֭R/q[%5/hSwO|)$_|RO~:ռMl{f?>,_$yr?EY/(s| +_Uo&ΒEw wEO^}WD$A5'DZ~yQGp⇲??%/ٓ-d$,;YW*)уKRO*>%뢖$"'p3*K@Go[B}M(֭KyyisgU1xPO.O[uR͸tAuO]J|5_ċ}%g\YG:5Yg?3'"=Y Ћxz^fU~/oFۂqu<%Ny}YޜxmZ y^_3lARJ~U;ԗ׼cH]9߉/uJ+$ޜz%rGy%>Y}!9+2ﻬ%U?`&e<DzE#3R( ZW"@i=ɻJ@Eh_=y)A7z /FՎ/ŏueZ%Yؑ'S~Uf_.eGiU+}{}e⌬_uD-KJyY= y)æe_9KXM`QFU;e?$+qR(癪[|K=]a2bǴNkNEC][eR( ѳ}C֗͋_?/-ޘRy{7ye}UG5.Kd>sRʊ(mEyfB8,n%.],sE⧯I=؋2 ."E_zMy_yb???4+h&,_YS#&E~XuWR_YJbV@k 3'~h_q4V|%R*<*"?'z ~ G>gů/K^}^%r޾OP;/&R,7'yY0/y/Wj\/lA@93GO'EM߹"~U)%Ar$բ݋"SG8/@ӢddF zpMY?;qbOuo闁ؕu OŲm;We|,va߁̼Š͋b&$=-wQ%O~X*W{lAiO}uY䱌+^ ő$%/&Nϊ= x/ށ?r\4o9Zr>s-?vLm3­)obOjW\{]<ꉞS}&fd>!R@ՆyKf\INɓ"SHnV% KyYL}djV(_{;)>.H|}(Ē q@z6%/?)XSbVy/I{FkAƩ/,߬߇sIi -}.ʼgg%~ϊ~H` DwA9 ɻ t~AOKqR!?<-8I' dEYEyd_O3#rְ/;+5'%UKNuϘӗy&wzeA&;$jS:/ @d|ZO%٧y ش<,~웤r2/~RC}B2z]tR=ߚ8Ձ#,H~/yv^gISצuuY]*rXeWOHҴ5GhJ@I]T{RþA8L!euN:zR_yyS'E.BSfTDugB_u v'qF_)7GIfRivL9yט?x^CʺOM~U{AjOA׃%/g=3>]>$yi)W2_rC}3ŜHoU짮c8,wSDLuI}{_Yɸ++-I/sViקH9;?_S2#52ߥtRv^LC'uf|^ZI@7{'&$gD9o]Z<$h>KRǦy]-yϺ/$Г<}V֫E#G?c!=R:'ڙ+sΊHډ)Z'1H\qJü݄=2)Ͽ(0:?@O5d~aNהlЫZ՗)LI^tA.JaJپ̏jP~SHa?Z߾$=W~" 8ϩM~!\;vs 1~ߢ_Ⱦ=MzX =oʺ}1''d~EM)/~IԷxP'_EU$fľ<6%g͊9Y_UY7''N$/*Ѫ)m@⋞KOwL 7WTҗ}'%4>m_geBߤ}OIyZS2ouNx~8-X{>Ւ|ۢf:;~w湒|7wqCō~f׈-[oC)|Vwof܈=3xg>OlqprvB㣰cNGp#LE.gnӖmB ܾeu>(4aaz(܆;vg?|\1Owy3Fq7膽~Z'.q {x]C|vCgҸ2B${ck-Xl};kKKwm3ޡ1gN)I׸}[۵Md 6smYݐqsc+6]_eF68&޺Ftw,}[^+of]n}uc??9WxJox#/Gxݗ^'?2= n1ޕwۻ2n{~2fYͦQ}{ھvn1ƴ󷙹-+3Fê}QFƐQU~gl3S{#dMW7B8̎-eR5Q2[ʮo(kgeGn\{q9nk}6UJmdhncarovc66wc({Z6v[ǔ6zӏ eַЋmm ݎЕ~[ڣcٖkӍ1|6r19ݘqظco~ 6ћ~ ?ˏq6jZ6U2-}&2t-m]xÍᛴ] {>^ovd܏3ߎC:n%Gx#z-IvIr\ǚuGvK +\ufIV(1w;J3'/{hJ +Cc'#*qg {*{VM'K$kZ:y:J]7WR9&{5-eXW%TV٫k*Id 35ar/kXo]{iss~CV骡0ZTI5q== Yj]xѱAWNh>'Fl!tQyY5TeQTk\N{L +d)ȱ*MrjdEРG"ViNu}}u޺ワIr; Oj=Ct (^O >og_e r_^7k@ DǠ/bj*?M0Ɩݕ+qȊu. !7jwSo S\g+cj6IOlZ6KRU%bۮ&Nv;:K_vӽ [klY.VJiDvE%gߩ P3uYԴN-mycE|~f5ꇬg%ZD ]2s?b BgPmv@,u7]RɆ0P?ZZۺPPXR4ԴK\]a\NƱG5״R9JqWKOUaɋ9TKo:;}2jW0;jbyWU7D^C ]]Cn,ѳM 'q#r_&gna:Y/qBk6cy7:2v޺(i>bTi9qp΂fG)utM*ؠinR? )DKe- bMе7L~*D\5 [8$5NvӄNDxI%(R~ 01uxJM!AMߛ M*Yh*Dp .$}M ʳ4"M$͖1 bML &frOu QariM!¨BԢW3fkֺbTM^lHj^-_"$&G"~ E8m"tPRFMSj!2Q('vYktmR,k&SonHb)hS8|dJR BT3tuI7"Ě#lhT$OY'ADtjsRtٴ%6LNu#4uE!B16n!8?5kX!Bk14ʩ l;(D5ņd^a!5?Iٷ:9Q&(!ϩ@}Tg #pjdoKSC1H-D5$bu`TB/4ؒ3"4%MbQ~D^5L*! #&WM;q94.hElMrҪM2764ΰBDiP$Qf[4d̷(zN -'\aۉ :[aM÷(D8IBųSofyv4-VfiSfGl,K mv _cd634'n1H)4 - im~үm!}X7|Mejݦ ![Nh!E!';o-')cNom |Oa aqHnBQ?G﨟#3 KC G2${hcƖ. ).g1ɨA ,DU4?7' )~U8SlԴP46VP} }^Ϗ|S'o+_~{!Wo]Y-9Z{0{ދvǭ;wٝރv/}hGۏڃh=va hhSh=i>,<"2~4k0f `6q7f ~hnpmv `7{0p 0p 0p 0p 0p18`8`8`8M88888888888 0qnK!88r,r,r65x9X`9X`9X`9lk<s<s<s66`:`:xL0`k:`:`:`;`;`;`;`;`;`;::::5:x9X`988×-vOn#x5^#xFjFa_#84N#84F#3>#3.#n`0#`/"."`."-"X`-"`,"`,"+"+"*"*~n̎'wc|40TSLE0a##*"*"*"`*"`*"X`)"X`)"X`)"8,ERK,ERK,E"x("`("`("`("`("`("`("`("`(~"'~"&f"x%[L3Dn"DNO?DO-`("laG0~٦|` 3 d)`3p Le{Nf2p v,'8IN2ذ daX`2p &g rd3d?g A3~;d` @20A3~u< d?m lK v3`h A3 ?g A3~ d?g A3~ d?g)?g $- >g A3v 7f = d8- d8 g 2A~3o d7f An3m d6f 2Af3l_. d6f 2Af3 :?f :?f :? g 2A3p 7f A~3oe 2A3p d8 g 2A~]l@lB'p‡ 2 6!A~lBMHB<'؆ې [l'؅ v!.$؅yOd>6$}'}'}}HOOlEHE`3|`7FH`?|vI #~$pQ I`)XJ`)8J(8J(8J($`KJ`*xJ)o`4SO <%i L%0TO $J`*J`*J)xJ)I=I*J+ v%J+ v%J]I-$ؕ^]I+ 6%$ؔd L&0d L&ؖ.L2$f l&`_L`3ےg |&`[M`4$0h &0h v%$j &j &j &j &j &pi &pi &pi &pi &pi &ؚVXM_jVs5999mnsp69mnst9|Ws079o~s69xk^s`5G59xjVsض59xk/9lfs0`69lfsؿ69lfs0`59XjVs`5ar`5TXjVsp`59XjVs`59XjVs`59XjVs`59XjVs`59XjVsT^s5`69lfs0`69lfs039hFs0`49h;49hFs|39g>s|39f6s03l`39f6sl`39f6sl`39f6ܚ~۝+f6 Yl`,e.ݹK/m{%^9cgss/data/LakeAcidity.rda0000644000176200001440000000740413267106071014642 0ustar liggesusers]X -8-D 6TRZoMdzN"ҤMhfl;y}y>{v~RsPSSTRSP.y9%9UnTqFxzn S榔%C4"myɎbqPK oaMvC9XN""ṙEtk_Abןֶ9E$js\x"1|½,pB``c]},5"BD,E\dD1-a=dQDQ7H#OQ: !ú.%+3g nd ]\g z1^?mq@"!N| <:>P~-GC|!|.s  ?E||~G}"6F7zu1D܆o!PG!E}u7%?G5}`W>zZz}CC5؁8Pgy7> mF}u&|<q)>:W;WBu>T/xa]''{17~b_%o> @.Ty5 =:`6kO n_}E^ߍ;|0@#V^_ LDzwÐW }*{pb_up>O3 ЍʈS@_Cש!azUk /0j 5?-OLs SKB#_ZE#<+c^rΒٷ>&W;u^r:'~ }xyCD獄Wלpe*S%J^0Mq`5@lb5k?9lE ez9Y̗@OV6`[X sY@Ve˔S$e*e<2ט*,)\ٲse,}]2-cwLY˨U,]3e˼%Cÿ^>L_nJ&fKQlR+Qyu0(M!`<7r'ݪ/#1BU<+5';7X&Jv~L41&w D]ree-ƕ*]2EY-pƑezI^8eueр>Qg2m +vw*}rqJumf~_My7D{)BW_Qxяa^yxc<q <Kd"k+?X&ߎ8}2f DWNю`<'Dۑ]hz/ Q QY͉y|3H5-r1-Q&a9l'7J!*FG[hJEos*=G>ڣ2W/ObSؖJ[\%G(H}0et\[aUV ;@tE(Ȫ_u}ЭB[\v~ $m|Y.] }xG]~fHߋ]~O%r[N-[]nSBS~f2xV(g5ƫ3y iN+_ACmMwXOIt˅L'k@ .kˢ(QBu 3MՀT4EHݛBUg@ϖҁNqS cjw55XJrXruhM*;! ~φ(J\;E9)AcoXTjc׃֊-f5 ATςU1Hڴ u]]vY9 ZRoҞw+Dґ4C6Tm\ Yl]rf@\1*5@&ؿ^r. % G@di [l֍l tn|sg*JZZr4"ϭrW-z2\>vt5Yigg Z?Nެ4&1Н;c'1tPo’S)붔au}{ p 08낇ESy G닞xͦ)Q(%}r,Q %\CQ1U*ov(W]_z8VozLmװ*Sߣf&-WdR 4xƍnnv>#q,h/Sn҂=*Tt* accw/uY3 nܑ`Q#.MU?4ldAˏC˱# wDl3] 5ak_ya`7购-RÜ^P <wQi޲ )ݖiͭ\-bp8]׭ ueh Xg+Yk˪+C db<}뉦2uWIudW8: &9֧xÉBH>TRH8ϕEy|^(觛ˆ ۽m[ GSByȘ}Yr2*uΕƀx 3O*)N1$읫OHCeOvC&|BȾURF߉~c/$še3bTщJ7ˈ%;.}*uLmw^E@M1o!vQ M =z)]췉LY%TvF>tb\H\,.OzZ-7ryJc}`׊wO;ٯܟ!*\f7Zqk>F>Pje/g &h_4,*IT8{ ^[.}|6+6!g* Vgw?n 2_Ugss/data/eyetrack.rda0000644000176200001440000001323113267106071014261 0ustar liggesusersɓGk{X 0n6u$݊p3D a,[ ^X 0+#G8ȁG8r@ȴم=+3|sjI]]UޗY|Nz߭]MlMݬ;2?޲nzϛs/^3x'ǧ__Ow㽋߻㝋oUw?W}|]Cz<~wqɝE/}gDz{߻{{]wzw=Owۻ]y|zW^+ޕgʷwݻ]}~zW_gwݻzǏwzǯw{w{w]<.>z/y~q;9wtO{_y9{gqGWeq|ΕswGW.}q|ޕ+8}wt];rmxo8x\*Zͱ1S94._/ዂZia|Εw ۡ*- #߅;z*֥FL^&/o MeVR돔9pRC]wc _y OOk]Ãy0Oc1y.T?k_O%ߑw|olz~+ۘs9 |N!.4߱5m̧Ԓ?O'~6[߸Ua)|>'W)/cZsY"y^ExQ/Ba$]ż 7&n_y=r(KF(|> 죌<q)˥KTfgWѼ̯zG~?cs"ɦ׫{ |_@^IOh=Jy@%ߢvXm#JNWuO<+/[ƟO'PBܕwƛT9.u5/|8OVϺ|s~.wx^Ⱥnֻe~"?lh~7n؟_}L<Z"YJ^k* yf|K~#|!y F>41W~@~p|>)mZy _u[SRtzM\g[yT ]^pkTK?Ov0+wkBj\Ucw;:K~g\~tLeL'br\qڈg3LNƖwG+6yy?8gt+nmt:8oWZ_KAyI<oV};~DxiI:o#}6ϕ~_/ >P?)];Wxכ+ F>ß8UB|7ywc?ܴousKч އ^[]< :_mb!މQn.| 2j/uM7!^q8y<η7y=oo| _K*;xK5=R)g3Y1[|k]﫝/ tɝߐo7ԡ㶲0_nΥϹZ^HyhM~0Jywc^Ӵq/+67|.>78guYgp})\0sVz\dx ~FӬϻT'5xe ~}~Z*^[ʗ.'0/_whm_بOh^CKErĻ-uyծ=ѺVSmh5 Oٮ,+t -dZe|PzGAh)Z.;RGyV[|_OoOo]yz@yi [q ԣ5iB~sg@ɑȺ/uwOqv} mVJXjs~.FK_?!_MxWN?b=;D_y eF$ٱ}c[2p;-R{6:Ts~\cᩇA\[ɋ@>|儞խOѵ=)zY[qA.KȁF [mֹI^KGյأ|J2r'h|/ړfZڣ}WJNǟGIu@kZo=igJ?:ry㨔ko__NNҔ!1zȭuh&Z`  +{O (<~jRjk:_j)?R&|}0p>qK|n9V8XZ9]LX/Z j6$YλB|w%2sV36{ fߜuGǭK{]:tq|āo^ڹ#wv/_uӣ]}z0uHaX֍mce|mѤv}hZ /C[9uJ baKԥ=A[JX-hC-9[N*SZ{A4qRb b=Mƚ/h1 s: :l=3xll\qQ6Ux.xD4< az֢$cKRw; Je=&@>,íW cv84 kZR! bا rSg3EL[5ʸ|}9BZlІ#k_Ԑv;$$NF+:EcNXXۙh~ǴEWMh+ h}M(*/;Ƶjm{n4x@%@x=dƛ@P5>T 6q @&@5xd T'> `6nvcɉççSç3ç姓'3Ng<=|=9{j8pS3Ngwzg3 83{f8pܳ;;|7\ps3 g87q~3/Ϙ8~zQeoںӵ9vk-t$6|TCy18c@>4JO(SjaЪ6L B3)r} r.q)yOcxd-?cRت!9sY OcW(5-`滱'ԟlxo6#=av>egzQS^/} R}ӂg]q$ F#cCY3m:?hHśv_V<^'=ѺZLJmcϺQp êkV׎Q]bWW݋|>\Ĉ>?m%}Cc[lW̄CwMu/ng-/znƟjϿB{~ KG#/,O-%72 ǥbǧ/c 'CcCJiX1A$9+q.;@ʣ2Sפg-gQ+;o3#B4Aϩ<$}D_XTZbs\6޴\*-eiA{5%򽥵w$５'Ƭ0&vB }Ԙ^KRS^ԳL]τGd'j8]1|ڱ`qO>۝K!1J#T8^y=M]ʹe51cyjo$Xj"ܦJ5<j߰YD_YεS<7Iko"}v-c9wK̷Z:>cT#z;ֵt_o,{|c=HKj|U͹Oϧ}3t]ܞg2;>kMj]1k]叩4a:H!c%R}khu+JfWJ鳶إs&u.E,&)c1|\LT9Hi/FHcK-|,1.$/jq/`֓O݆H:=ͥWƼGH>SR?j%2 ՚mNmML㔦=J(rkK3Gpڥ//GO>Xǰ-md @Р2E`Q ]h5f JVWLu f5"ﾗ}]PJT gn۷={ B^(=Jige@zii5+)JI UVӸTG MI3PcTh(߉_ ou 6b,D֌|qֹFy {u"u*U4C}w9wݥwrDkJRG/;1\0e]o+0 yHA>%Fڙ2]#!JbJ+:E1uJpŨFױ q߬*|<hC;Dž׻u17n662::֡.t8l_q3~p}i<9 [fFqm-ΓqSzLyoqb"8➟9/HQW7C<k>wp_;ܺ^5p^w]ǫ9\4 ^ ̽ @C)tv&;j"sGĕ#큄WdU5T;ѯ&@q1ߝWaf9j"/51A5x]TD*9INә+fhKuD=8Oggx +[?b>1@9OLw udxct&$= ]J}3 >g2>Toj"Н1΃w2W1DjBgjZNA,&7<|Swb݈T+U}8.2vL] ہ9;=`>m`Rm܈ w,\bONrDlqN 5>V>ݷ߻^_6y\C7ȉeWJ4y݂)WluIG, x #n)䝂e/=@g/맫w13Ço}9X ϭYBZkt;Ɇ^Mc h݅5n_,+JnHgl$O.ޤk]+lf|lo ickyYk\5*MX$쫿?7q3u,w,ZwL ([ 3m38lحHlcU+07.A/F6kۤPwpvɥTcT A /]'ff_ ݉~Gedu/2lfAilcdڬE_ٌ[ rwڂbm~fD%B]<Us/ȧ5'S,3?- ?Po.9 wA9]g rsWWfG;xr%gƬ^c;3H M?oYApLҰ,:J>ȶ|C7OAPTt=`5LhiY|?6-L^v4\X Ҷ峚2@zIsH[Yvś*&s_8?4>nh 'to~ Fp},G[ih_Gt~=g|o)+TQ3euy/[uw2(g.b3=N`_8j!8>_~%#in38sfZy{L&К7=N4xkGzRG0W*J|D V,a :s;y8pCֻU~.-P? }oTjr&i=ݩ&r$M31ȋh5T˸Կ_~ gss/data/DiaRet.rda0000644000176200001440000001176213132155664013634 0ustar liggesusers \yfLDI!]j~L4]3XmEEZE,riEB^",99jmؔ^vg3u2 &CE1xb_hȰDC#J6G̐Ho qG2GH*فCc9ry4a#le@B|D AEIC H6ُ#k}1R3}&4G[`/f!2L@&!X7s:2~2"Wzd%*ry! G7l1ְBllFۡ1C! _c! z56!Q"SyۡQ`[4#oqn71`9#H2#q ZlAp|YX *C!7 Ǘck"X>D\.v2زuY;`c}gX`_88#qr0 2y˙LF X/'dqDn:Y ]wVh Bl+ 3A߭+zֻ̿qnM JۇhII\aPpsPӹc8?۸:w{sɼ!yO4}U ̳6BpN?nC-Y5o4>[>7B6[ot)5+)%p]7t.ے_Wk~4~' 80v?0^6HMv3_Ɖ㳠n僴3K6?8|hx\kR=ޘ:.~qNǙn>XfUo g݃>;&݃J?p. (?eYѺ,UY+ <9oAx>4Ntwr=׉>zh'x݈hfr[ˁu'~I- Gs[[I:8TAw z_>UW^嬤x\ݒ`~&<7=ȡbMm%_6oI ˧*yc"Aiݬi xwIJX.yӽ\a`Hή{Ճ݌2}ź_ẃLFN^ 0SNccE@vm[@ghhC(ONGE?WՀ,Cyދ pgB ΥAґ\VAi7>댵 2`>ZZmv]!ʹ =ֳO!lDZ7-Нt诜 =)dH/]ٕ`Q }.T@zʪ[:2)*Yf }ׄ<\#*B']`t~aUCZpll+%E{pTkt'g)#]O_BxU0pXz1$y/6${M!8&"]2u]˺c~VBi|8\d.7qLXo 5/mȞ1u_=d'1h pھu l/N;?5BjizaF > 2(,DIR 5ϱs E=yۊ[=./ ֆm}y54s[3mv#rb\Y\;}H7-owq\lqɜ} Ңi  <7oV-^M!݁|TWq4]ƛ4)nGed~ ]>wʫ^>\{p1)X8B\|VrxFUJۻ /f2> 07ț,'`Gr~S9҂dl:Y*DpMzୗifG=n]9yf*8s9+Vn1Wђ) WsO\v%r3v=߭ٚvxQ>(CCfehPg[/CK݃(J.l bTFNAҡRq>'۽Y/9]B~0u>6zZbǟ{ P»9QU D }Qx,V/;ߗVZ ۲gi`1fQI }7(K E {|_<jy+rހv_-I_qNݽnB XWbO)/9kI\fqlKxW3 |H;&W";o\{`Ġ|| /mW-ӆ=cL6;s0,|z 6Y{n B/M =lwz [T9|#) `߯~xfX&++JMUGr  NEf,ߏnJ|f{+P->)0WDYT0R4ʸ)k12TĎA\JEjĀ9_GW-xQ*ƽ@苪uV[ZyBgY3tP3()I}:73\-Ґ pTǤ|[)0IP֎TֶTrNUϴU6tcOQ57yFYtlc?툉@\eN ϳD&2>rlbT#bpu6`hsI96+97km`K:e(ؑv5i"n8YRo'ל@έ2:'uqHݑ^Xhg4Pk,ROrIuHI Idb-I==H|n|;&i.i'80I]3KmEf|+t f15#e6i!;8v银ɦq}lWRvs[݅,>Ƥ^ZO2,Co \r\6 H|:h1iї&W09tͿ?19濕Qf?_(̿le&Q4L*`r_/79̿ #3LoerW(3M+19r/79 _|2LN+`r>69rg+39M09r/39J̿&GMN_nrd柘_nrb[/Ϳ?19r2mEhrWfrT)+d5L1'bU2)SWS0Z+d}6L1bebU*)&7b3Ŕb2*SL#_L1ev+yWdUe2 b?gͿL1)+#_)&7*2_))hbmyL1e0L1bb2/#uؗ_)&7$SLnUd2$SLm$SLfb_1Sebu:fI]5֐av}k1ձtXg՝W'Ɣ-j1kꠛ@cUUt,9}HhU:cA7s\Vg\S-VF~%"3zvbwQN-OɉfBbdbRӗĩN-?_E5"'9%N,IO%Γ~;.21/7sN)kj"_؁[6gss/data/ColoCan.rda0000644000176200001440000001637713267106071014006 0ustar liggesusers[gT˶!#JP1 eF@Af` " "DAP G6 f9* # s]?Y֦jW_UOە9g? ä0iLJH LSDWy'`&JH 9d0b$zhD"D$L$*Hڥh}| $ZH"1Dm׶}?ZgBY!A2WK5ulڟ(MANNju85i? "ԫF@~:A41рyC͐\vGb(ԩwuڼ9v=HLՆpQm7^z[G_Y] l&b Gt~4ITtkd=t}\nq&Wic~ ц6 rZC&gI,l S_w{ey̓;+F݌ -zݰ/Qb̮}Z. 2Gʕ9=y1ZDWV{'Yv9ꮋ,ygX{2F%x>v1N]ד_BFSH(4GHٕ =kAtX0^vxY=|7`u2I}:4E;M~7E aOC-<29lJ{]//h ]s!k"f:+~YrI!쪐m$W=k6924{Kc KlkuF;6#2N'ȳ!t^1 =`Q8vD) Vi>`h,W!Oy;H J2ȯWDյ=lrXk튏J &6ɹ~"dL=B09QT7$ji?.^}"\("uz0JwEDvq9(UYoۉ*ZFaOmGq\r)EGLJ 6n?E-w@~6죈ͥ(с}rI6ExSh&B%d"R*gSr5ٲ_KffAXeСr">_Y8({3(tiR6 HzHY0E*?BRpŒԦj /Q+;pI|m=E$tU甌gGS]Q)繲py_n SPnA7OHWDxBăU(bgG|7/|Cqd~c4:aPn 2NRvVU?R]#[R9o5HXnНH6r2ZL3б6A8Dߞ%ӯM%k- u&L"ur͉YƇ!Up2b; ̮(4]HqUZN_*_ ԞύXz(K,u4L?ڣ˒ބX˒qgT|I4m6XNsYPi)CL]!] $[o ST 騎U%GKݴ.Lr}"9r[ȸWeit7ӄN]b)_yeD2 GM Fy2%r_9⶟NfOZ2X#"]mv-UóR'3 ,Oj<.O1@DXcP0w 2å~`e1ɡh~gOyUpi p+$SsX x{}iuwVbBLy jكCvg7d%d\w+HJ Up"q;\y3djS\r\/G`%*f' sB'`o2G5ϊET6lr6f@~(&:,rͬ?Lҧ =}L/CM "kOZ]5v{BnP^NV{pS` EHpk~̴OmZǀ)MQ-%٧@*}-k"A5XC|vtdꎒ#P't{(-^f ,P!2uX߁7gT߰ҥS\Sl|CcljT㌽|aҍƽɨ(Ӎ3A^[U<|?dy )=hӹ dy+xI'C:9wدƣnX&P|gut&sYѓ3|Y; iQ4g~K.i~vy@i2wΓ9aO%qi%;#Ky{tzEֲdmQd@Sy1;/oy |ܿgh{IQH"5-G~)de;Muo~[z\bfř%o~}Ba׶k߫F}v펞2v::_Ug7Hl7Ό!s<~R t],]_%Oט)R_՟~ڈk~Rk4.MKAӦktZt_o]]eDD2UCk{&5~LFbĬI]JֿY5a3XY l&FE"=tM[ot yH\YHܑx D]*I GVJ] 4x<n(ٰA -6eG mxl_2%AS8_ۊ?nTD@^7":NjF?v${|𧩟? JAgss/data/gastric.rda0000644000176200001440000000073413267106071014112 0ustar liggesusersՕ=OP/-~@!qqppp&ACԒH0DEV?ёm9oIJB{sxGb4zcn&f-?.fciIZ68eڬBk1"g'.t*8Q{v"1_BydhQΦA9;Y]~W%^Ux7|!H `ep\``&[oc|'8uglbA<qc{x;F~|8 t*ߍpx(Zn{״۰i~P} '{}# |䢜͞YW#^f:=ImؓxV%^1jx4XwE7ug,gǛOif YboxTHgss/data/wesdr.rda0000644000176200001440000000751713267106071013610 0ustar liggesusers͜nWǧI&mҤM\s>zyDm BjAJ*@<@x@pQ+gTvۇ{?O/ 3Μ=3Z\aן?ap/s7O~?->ytoڌ{Gw7[9<knw%}?h1o-?qc\7ޯN|cF[[1G;1Vf㘯ĸhvе.Dm!~OYv9עk1o+oz|+6sЉ|+ rj!oA_ OWt w]KZg%߄{GxKzVcnʅܾ'R1n 9.Gf|"h?{(8^{ +̷W9M&1~vTpwFuv[dľc=ZnXчp8>-FK/eoR<_^' ?Z|M8ݖ+џ3 (Ʊc8J(?~+G+ѿ7Ko )Z/ $. A]G? M h1q.Nw{E*_y$?~<<⇞O1oZn?1u7x:O"O/Tw^_Gx^A#ߏg*A+=nO/_ʘGMyA؍e|= tqaWo⸆^+v>vDqGH⯘ϜSgD5F>I*?_>MW?px.-I/@wAޟUq)G&9/w+tSXyÆZxdYtPP܁]~8a;#op<$u]i$WՄwk?gK\*>"ni_@_)n(?n(j<{M vT=oe[v^wLt'Me izO+Egڟoɟ uqyƲE⡦⓲Ϋ^j:-SEU]HmeQKEBMŇ\T\Pwko59o+~MQׅ/K_gvUq%?_v|?=wO췣7YEzw}-Jn8/#(5u[XS}{H%gEqY:KsKAK~)}Xs>=UWչmwoSzV~P^R^]UnoqcUuutI^ҫ%ASmOyjM[ut.y$;XS޻&JWTԔtofʻ*=U7+}w,.kUvUӑ;^c|Tj W}TT6N;9|z&jOr=Xwv@ws C~<71y7c-0?ux9bxNu't4ҏ𙼐X( f}s=|GN|rn} 8K*l|p^9|Dϡ1BO{ u?`4>U7dsd?<ȝu{ t2{zaCOwGͺq?v^Α&:>mu3g䳘Obu݃\,4ɞb F;i=?n7׀Ct<ņPBc>^X37>7$~Aw_Ƣc]zAw;W@?A.tW-B~K|nr?91rJO>*+Jb7Bo7a{N +͆yL^A/]Б)^"s3}@}7O2`_#=RB}m /{x>ݦN\tfbf1nq_q~ɮ;?u4XPqq|(O=z%o'zf?h$ʯ%y=m?~)~Za7vOy?߄C}̿v}n.!9nlw,*~/s~D*>ӏi @'.cůcmc8s~;4#ps]y F>kK|=QȟWG7s}.r:} u;vήp|w"?>R8V>_)ܒȏx)s Mp$?_?yXqm g{[O_S<9ȑ~;|L\Pq] ppM~ePv4/#};x7MwcHsL\MeO1_{}#'o+}IcG~o%(V ;BnQO~{@xE@p>?<; }^'ui?-_ߋz1>[GKO'};oϳ׬t̊Ǘi8yZ\՟_Wa^z?/yR<~͊SˎO_ճ{V9ͪ_Zf/eլ7v>k1U1#fũyϊ߬yzyǏˊ^~gχW?.?/~__χ.<&{3V{ZYW"//~v>}-6Y\Tgss/data/NO2.rda0000644000176200001440000002447513267106071013064 0ustar liggesusers\|d{yW{{D$bE]ޣvQ"V+\kS%jV{>Ӿs{缷 RJU%_KP٫\.4&#ǃ)unacM|Co8 ㇸ238MMlڞ?mz34j5uϼ쳯-4Z`1n|w"E{"hfD߱45 . 4%~7rpuʘe˶-p߄ǡZ ѠqQRAN3iqp.XR?]Y^֊C砤#d]@3qR :=?KK. O_/ g<J~GЕ^8ֱ P]nno>tQ7 }gwMg_(Ӯgp{eä_ˍY>UmD|ZuF.>-&=Xu6u}BO7?~=ݩP"p#y֢9C[M>S\/X ?Lmםw'x4/-GO QN'w; ..UڹIץ]5N VeH_sBA7mcwIP4a4rt4 A~U jS~u8j= f(p0Bm3XȪƥPq=wOzWcT^vU~ fʒu1Aƹq ,nэt Mw''^B߁sE}W`i Mw[p>v)c~ڳ\q8q?\ͣ &p٫>\/2-ͭ5?jg Fe&W¨SՠYx맅?*R̽"Fo`@&-U$/zrpP$Pt?xڿwn5~yneod͞^%zMи5/lϧl%֤W :ʏaRUWK㽶85S{Y&C%@3ZƐeha0py{/[Ӌ{8YqU݉=W9~ǝ[R=&^bǼ_H6w>#"xc׿ܿ_d'Qwh?;~߀ Y'3 925f|vl*|#־c/y1dZށlέ,=qee,7>uTO(\giNz[)GpX{+ij_w> mO7qC;cپŏ6te/炽צJcjvr[4@s ж47j ~?ht+=| \-R:tVҝA<j^&~a+&B7n5rX(c#\x֥/<,U=*8~P|'%w㎡g)g3Y XC15G^b-{^n2D[fz\~}=vK";c7A;TJKAEYA׺W v* }4ou]D9&iEv3K欛1}cOp}յS-u~#zMʼ{U5x _Qb =ph -m}u;SWzU9LK ~twM}#EMw^J_tƑG~.Ax4Q/!n2dz'7g:jq**4qu:XuϿyfgdzܒ\N/ k,8w#5PsW%yxxuHO[6o eܸn5װqkAa8.ӫ.?5>ͯ6 F5dzWvF8~̈́CVsxbv=̎qGߧ#zaYP)R`˪l&p?=1u~c@zRfO 7?V`=`V|ԯ1Wfj`#nIƪSlҤTЭؐk<Za?`^"lz,HQ5r4`YW}+Ӕ7v30n{i,04;,A ^rӺ*HYm$M)L\;|7ljR='uxy|n?Ӛu+NrK٧iwL?5K;d ]P hՎ[dĵ,X?]`^Ybo`qU`IL.gB^z L&x:&M.l&c8o72Ηπ6 >ꗺ+gS2ىeHߓu7/i!ZY~ S`Y?ON`8~UkϏ= s1\a"ixՋq9X/_w? F `  `Yjnu$ |LY> ưugRY45};i38)wΩ~m!̷QL~7w2/n ?~r`^,M9.+aa*g!u6_ -$a-RBVF%<#9o}@]bZJ`E>`8UJX`%uҋe߆zqoõu[Kf>z2sL+v};MƩ1ɜE2h m[>!5cxqRS]d~E~^Qк%3]ϥA,%䂹ݒOaeztQA`~"}-Rڞ PIͽ~-cEfD 8q*>w _b3u6}+J)?keM \eġBu,+Ӏ9򺜞3!pS5`u$|\ŦiS I^Z"E`xDGXޣ#Fto턏mx0lהN .KiхaUӺ{Qo)F0^ef؜~We,Vk-f}]lL*[tn I m']ˁ{TJ#`mHjོP}^)0Up5 ~90=vdi4XT,m>lY'KU #N!D_& u%we)arT@-˴qF?I8>m(_%`ϻZv`z'u.扟 l`'|Ks4r}b%]7iJU!?; h]K2%{yAM7~S(N^*y^.HeC]cCzʴKjV^ԍ3C gYPv"W.|\VLi&|@]Me'SGVzA{h4L|t̓臶` zKiƢgs]Aw,$sTPߟbb0-ULOOs.?1c|tiLW[)lu*1-K߽gLug)0&4g`ѳ0}> '-~vEn a|'C@9_+5<׫KS]෷Sŝc^0\%C7r?P9Tog5r)s,\S羿5h4̔ڗM4W֕zw;ʗ7Kjc멉MjBb޿%sG'e)}~d f6dz/r`V(o1P]| s o: 7y(jRq]a1ɡ  gH#eZ|>ާ=;Lun? FJ8o`<%6,a}- .!V70SѸ^-ϘoSɄ9}8g^ gDysK|^MGiϙf=[E;Y> xP>} /;%;9mpop^8x/pMxu߬;5 x*»EO>yuĵyM!~L/wyx뱕?{_ȟW/zy)׆J>}/|bSFy % ??h' TyNPUVĉ DQ^-Vs[A;+" ߄H(O|~y̳d?[Y<}i% ‰mz~įH >"Qʻ?p'C~1ɯ_ca/)-wҡje\otT?[k i?udnr"p|?})g[llq}5pJqAOYNiUX>qM Qڕ5PEy{M?Юs(^HoO_!l/! B}~N|YpD+Hx+u<iR'Qҳs ]'Dv_Ot/Gx'.<ROnz{̿\h:Dx}R^rU GH`7ssn?Q_>JmieGٕOeۅZi^$$/i]i^&8dO` ہЗI K'):~T#QCUߐݕuN9geu4_>{JADOϽ|k?k =x|Uԧ)zCE/]DtD|NQ"~Du2oӈQ-'ʺہu7>> u?e zB#>⍢b8x/~~ \oe>yCCk+x>Ӓ|/OxvSKסVOpשz;Ux^#9y"?9 T}|߄ҵF𣿰Ce>~U y]su;J]'#3tW_q-N?^?z('\< +yY^Op^rPP'ʿ?3.ٗM_⛏#Ͽv+f^Q? S ?5=_\G׿G1v~h?n/_8-Wqyy/|?bKs\Eʺs< &|'u_Gn |/v/&w›JǗ8_i|>)ϾR~y\{ #з ϫd/!{籯Wߋɓ|^^u;2/~yQ.#x_bme_+$}}e|ws'|\Kwe?+}RL|](_B:E~{6k>*U~>7NWbt?w_񺘏[tRC#^8qQ ?8V! CG(p8/^1+\>qVq_A.'p]x#wȫYc$>%p?qA^w7h;Ȣ[A~?I')hOx~X_'p\^E;].C{{ah?=o8OdyѩoM [׬a^*^qrp=h9+1Nj F<ˍ>HE 8Կqp= J?@;|E8oO>Bׇbv@F~pse|/CwQ8+SW-c=K_ӓ9qGNq|ߓq^Ϭ=C)cDwN+ϟ9ǣ8/wr G|~MuyܕnSi@2i]θsph%ҺW)v$8ϓwD'}p<鷾^z$[ZJ øk?PyQ {J(u|J`J;Sy/kF|%S&7\So1[}qY8>So?ԟYcpdّR8osp;ȓQ/S(gʸO}x65TJn!<Op y$ uHg3!Sk >?փ󤣝g0%}(/ WP/Nϩy5'4wċk31Q[:3{~r=O&¸8AσpIE(;?EO|I1xT_!?:Iǧzz}>C~=&>)q@ih : ݨ)2 chUI-~]\NRj@Z]t8(j}vQ՜^gss/data/aids.rda0000644000176200001440000000260613267106071013376 0ustar liggesuserskkG' PRJ1ȶ"Y֬$*~ݟ_P*nǻ̜ؐs9gs{k2;;fk{qgk3c^V6^ +s'qAt=̫9yONܟu1浜yGx/CYe1OK)}q(AK?>g_D_sWVx~7M;y(i}x!Ηmx:c[r?.9} s"ľ8O_F s'IχQ4+N k;9n#>o}W=yi_uSwy|#1<(cSy9zay x*x.1 `o"!:>^ǹ1!Hq.{pk\q~| ?devw88W'X1Uؿ 8O)@ <x)9}?ݬ[1@=¿ |`!p=CC>Z/w.#G}}u:C^`^|&ZxCԵ6D?>#CS-ԍȔg8x~~-`~D.Ϛw y*^O|dźGuѼ'?rY!uuy <度)A||׆]?@>x!օyC>M"4~M+ o;B;[R)!d|/CO͔)x^'3))wGEĨ),E gIGp}k=Ku,'8½W[qžjvE^nO ?G3U?$8j+TbS>b )'~ |uoaPϭԼ~1p#%n%ץ>U<ωw|{=/[y{-ֿ<{ME>Hw߯\|Y{?MPȏgss/man/0000755000176200001440000000000014464222045011624 5ustar liggesusersgss/man/ssden.Rd0000644000176200001440000002135513626334611013237 0ustar liggesusers\name{ssden} \alias{ssden} \alias{ssden1} \title{Estimating Probability Density Using Smoothing Splines} \description{ Estimate probability densities using smoothing spline ANOVA models. The symbolic model specification via \code{formula} follows the same rules as in \code{\link{lm}}, but with the response missing. } \usage{ ssden(formula, type=NULL, data=list(), alpha=1.4, weights=NULL, subset, na.action=na.omit, id.basis=NULL, nbasis=NULL, seed=NULL, domain=as.list(NULL), quad=NULL, qdsz.depth=NULL, bias=NULL, prec=1e-7, maxiter=30, skip.iter=FALSE) ssden1(formula, type=NULL, data=list(), alpha=1.4, weights=NULL, subset, na.action=na.omit, id.basis=NULL, nbasis=NULL, seed=NULL, domain=as.list(NULL), quad=NULL, prec=1e-7, maxiter=30) } \arguments{ \item{formula}{Symbolic description of the model to be fit.} \item{type}{List specifying the type of spline for each variable. See \code{\link{mkterm}} for details.} \item{data}{Optional data frame containing the variables in the model.} \item{alpha}{Parameter defining cross-validation score for smoothing parameter selection.} \item{weights}{Optional vector of bin-counts for histogram data.} \item{subset}{Optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{Function which indicates what should happen when the data contain NAs.} \item{id.basis}{Index of observations to be used as "knots."} \item{nbasis}{Number of "knots" to be used. Ignored when \code{id.basis} is specified.} \item{seed}{Seed to be used for the random generation of "knots." Ignored when \code{id.basis} is specified.} \item{domain}{Data frame specifying marginal support of density.} \item{quad}{Quadrature for calculating integral. Mandatory if variables other than factors or numerical vectors are involved.} \item{qdsz.depth}{Depth to be used in \code{\link{smolyak.quad}} for the generation of quadrature.} \item{bias}{Input for sampling bias.} \item{prec}{Precision requirement for internal iterations.} \item{maxiter}{Maximum number of iterations allowed for internal iterations.} \item{skip.iter}{Flag indicating whether to use initial values of theta and skip theta iteration. See \code{\link{ssanova}} for notes on skipping theta iteration.} } \details{ The model specification via \code{formula} is for the log density. For example, \code{~x1*x2} prescribes a model of the form \deqn{ log f(x1,x2) = g_{1}(x1) + g_{2}(x2) + g_{12}(x1,x2) + C } with the terms denoted by \code{"x1"}, \code{"x2"}, and \code{"x1:x2"}; the constant is determined by the fact that a density integrates to one. The selective term elimination may characterize (conditional) independence structures between variables. For example, \code{~x1*x2+x1*x3} yields the conditional independence of x2 and x3 given x1. Parallel to those in a \code{\link{ssanova}} object, the model terms are sums of unpenalized and penalized terms. Attached to every penalized term there is a smoothing parameter, and the model complexity is largely determined by the number of smoothing parameters. The selection of smoothing parameters is through a cross-validation mechanism described in the references, with a parameter \code{alpha}; \code{alpha=1} is "unbiased" for the minimization of Kullback-Leibler loss but may yield severe undersmoothing, whereas larger \code{alpha} yields smoother estimates. A subset of the observations are selected as "knots." Unless specified via \code{id.basis} or \code{nbasis}, the number of "knots" \eqn{q} is determined by \eqn{max(30,10n^{2/9})}, which is appropriate for the default cubic splines for numerical vectors. } \note{ In \code{ssden}, default quadrature will be constructed for numerical vectors on a hyper cube, then outer product with factor levels will be taken if factors are involved. The sides of the hyper cube are specified by \code{domain}; for \code{domain$x} missing, the default is \code{c(min(x),max(x))+c(-1,1)*(max(x)-mimn(x))*.05}. In 1-D, the quadrature is the 200-point Gauss-Legendre formula returned from \code{\link{gauss.quad}}. In multi-D, delayed Smolyak cubatures from \code{\link{smolyak.quad}} are used on cubes with the marginals properly transformed; see Gu and Wang (2003) for the marginal transformations. For reasonable execution time in higher dimensions, set \code{skip.iter=TRUE} in call to \code{ssden}. If you get an error message from \code{ssden} stating \code{"Newton iteration diverges"}, try to use a larger \code{qdsz.depth} which will execute slower, or switch to \code{ssden1}. The default values of \code{qdsz.depth} for dimensions 4, 5, 6+ are 12, 11, 10. \code{ssden1} does not involve multi-D quadrature but does not perform as well as \code{ssden}. It can be used in very high dimensions where \code{ssden} is infeasible. The results may vary from run to run. For consistency, specify \code{id.basis} or set \code{seed}. } \value{ \code{ssden} returns a list object of class \code{"ssden"}. \code{ssden1} returns a list object of class \code{c("ssden1","ssden")}. \code{\link{dssden}} and \code{\link{cdssden}} can be used to evaluate the estimated joint density and conditional density; \code{\link{pssden}}, \code{\link{qssden}}, \code{\link{cpssden}}, and \code{\link{cqssden}} can be used to evaluate (conditional) cdf and quantiles. The method \code{\link{project.ssden}} can be used to calculate the Kullback-Leibler projection of \code{"ssden"} objects for model selection; \code{\link{project.ssden1}} can be used to calculate the square error projection of \code{"ssden1"} objects. } \author{Chong Gu, \email{chong@stat.purdue.edu}} \references{ Gu, C. and Wang, J. (2003), Penalized likelihood density estimation: Direct cross-validation and scalable approximation. \emph{Statistica Sinica}, \bold{13}, 811--826. Gu, C., Jeon, Y., and Lin, Y. (2013), Nonparametric density estimation in high dimensions. \emph{Statistica Sinica}, \bold{23}, 1131--1153. Gu, C. (2013), \emph{Smoothing Spline ANOVA Models (2nd Ed)}. New York: Springer-Verlag. Gu, C. (2014), Smoothing Spline ANOVA Models: R Package gss. \emph{Journal of Statistical Software}, 58(5), 1-25. URL http://www.jstatsoft.org/v58/i05/. } \examples{ ## 1-D estimate: Buffalo snowfall data(buffalo) buff.fit <- ssden(~buffalo,domain=data.frame(buffalo=c(0,150))) plot(xx<-seq(0,150,len=101),dssden(buff.fit,xx),type="l") plot(xx,pssden(buff.fit,xx),type="l") plot(qq<-seq(0,1,len=51),qssden(buff.fit,qq),type="l") ## Clean up \dontrun{rm(buffalo,buff.fit,xx,qq) dev.off()} ## 2-D with triangular domain: AIDS incubation data(aids) ## rectangular quadrature quad.pt <- expand.grid(incu=((1:40)-.5)/40*100,infe=((1:40)-.5)/40*100) quad.pt <- quad.pt[quad.pt$incu<=quad.pt$infe,] quad.wt <- rep(1,nrow(quad.pt)) quad.wt[quad.pt$incu==quad.pt$infe] <- .5 quad.wt <- quad.wt/sum(quad.wt)*5e3 ## additive model (pre-truncation independence) aids.fit <- ssden(~incu+infe,data=aids,subset=age>=60, domain=data.frame(incu=c(0,100),infe=c(0,100)), quad=list(pt=quad.pt,wt=quad.wt)) ## conditional (marginal) density of infe jk <- cdssden(aids.fit,xx<-seq(0,100,len=51),data.frame(incu=50)) plot(xx,jk$pdf,type="l") ## conditional (marginal) quantiles of infe (TIME-CONSUMING) \dontrun{ cqssden(aids.fit,c(.05,.25,.5,.75,.95),data.frame(incu=50)) } ## Clean up \dontrun{rm(aids,quad.pt,quad.wt,aids.fit,jk,xx) dev.off()} ## One factor plus one vector data(gastric) gastric$trt fit <- ssden(~futime*trt,data=gastric) ## conditional density cdssden(fit,c("1","2"),cond=data.frame(futime=150)) ## conditional quantiles cqssden(fit,c(.05,.25,.5,.75,.95),data.frame(trt=as.factor("1"))) ## Clean up \dontrun{rm(gastric,fit)} ## Sampling bias ## (X,T) is truncated to Tt)&(x<1) while(m<-sum(!ok)) { t[!ok] <- runif(m) x[!ok] <- rnorm(m,.5,.15) ok <- (x>t)&(x<1) } cbind(x,t) } xt <- rbias(100) x <- xt[,1]; t <- xt[,2] ## length-biased bias1 <- list(t=1,wt=1,fun=function(t,x){x[,]}) fit1 <- ssden(~x,domain=list(x=c(0,1)),bias=bias1) plot(xx<-seq(0,1,len=101),dssden(fit1,xx),type="l") ## truncated bias2 <- list(t=t,wt=rep(1/100,100),fun=function(t,x){x[,]>t}) fit2 <- ssden(~x,domain=list(x=c(0,1)),bias=bias2) plot(xx,dssden(fit2,xx),type="l") ## Clean up \dontrun{rm(rbias,xt,x,t,bias1,fit1,bias2,fit2)} } \keyword{smooth} \keyword{models} \keyword{distribution} gss/man/predict9.gssanova.Rd0000644000176200001440000000423613653352576015477 0ustar liggesusers\name{predict9.gssanova} \alias{predict9.gssanova} \alias{predict9} \title{Predicting from Smoothing Spline ANOVA Fits with Non-Gaussian Responses} \description{ Evaluate smoothing spline ANOVA fits with non-Gaussian responses at arbitrary points, with results on the response scale. } \usage{ \method{predict9}{gssanova}(object, newdata, ci=FALSE, level=.95, nu=NULL, ...) } \arguments{ \item{object}{Object of class inheriting from \code{"gssanova"}.} \item{newdata}{Data frame or model frame in which to predict.} \item{ci}{Flag indicating if Bayesian confidence intervals are required. Ignored for \code{family="polr"}.} \item{level}{Confidence level. Ignored when \code{ci=FALSE}.} \item{nu}{Sizes for \code{"nbinomial"} fits with known sizes. Ignored otherwise.} \item{...}{Ignored.} } \value{ For \code{ci=FALSE}, \code{predict9.gssanova} returns a vector of the evaluated fit, For \code{ci=TRUE}, \code{predict9.gssanova} returns a list of three elements. \item{fit}{Vector of evaluated fit on response scale.} \item{lcl}{Vector of lower confidence limit on response scale.} \item{ucl}{Vector of upper confidence limit on response scale.} For \code{family="polr"}, \code{predict9.gssanova} returns a matrix of probabilities with each row adding up to 1. } \note{ For mixed-effect models through \code{\link{gssanova}} or \code{\link{gssanova1}}, the Z matrix is set to 0 if not supplied. To supply the Z matrix, add an element \code{random=I(...)} in \code{newdata}, where the as-is function \code{I(...)} preserves the integrity of the Z matrix in data frame. Unlike on the link scale, partial sums make no sense on the response scale, so all terms are forced in here. } \seealso{ Fitting functions \code{\link{gssanova}}, \code{\link{gssanova1}} and methods \code{\link{predict.ssanova}}, \code{\link{summary.gssanova}}, \code{\link{project.gssanova}}, \code{\link{fitted.gssanova}}. } \references{ Gu, C. (2013), \emph{Smoothing Spline ANOVA Models (2nd Ed)}. New York: Springer-Verlag. } \keyword{models} \keyword{regression} \keyword{smooth} gss/man/sscox.Rd0000644000176200001440000001233113512125075013250 0ustar liggesusers\name{sscox} \alias{sscox} \title{Estimating Relative Risk Using Smoothing Splines} \description{ Estimate relative risk using smoothing spline ANOVA models. The symbolic model specification via \code{formula} follows the same rules as in \code{\link{lm}}, but with the response of a special form. } \usage{ sscox(formula, type=NULL, data=list(), weights=NULL, subset, na.action=na.omit, partial=NULL, alpha=1.4, id.basis=NULL, nbasis=NULL, seed=NULL, random=NULL, prec=1e-7, maxiter=30, skip.iter=FALSE) } \arguments{ \item{formula}{Symbolic description of the model to be fit, where the response is of the form \code{Surv(futime,status,start=0)}.} \item{type}{List specifying the type of spline for each variable. See \code{\link{mkterm}} for details.} \item{data}{Optional data frame containing the variables in the model.} \item{weights}{Optional vector of counts for duplicated data.} \item{subset}{Optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{Function which indicates what should happen when the data contain NAs.} \item{partial}{Optional symbolic description of parametric terms in partial spline models.} \item{alpha}{Parameter defining cross-validation score for smoothing parameter selection.} \item{id.basis}{Index of observations to be used as "knots."} \item{nbasis}{Number of "knots" to be used. Ignored when \code{id.basis} is specified.} \item{seed}{Seed to be used for the random generation of "knots." Ignored when \code{id.basis} is specified.} \item{random}{Input for parametric random effects (frailty) in nonparametric mixed-effect models. See \code{\link{mkran}} for details.} \item{prec}{Precision requirement for internal iterations.} \item{maxiter}{Maximum number of iterations allowed for internal iterations.} \item{skip.iter}{Flag indicating whether to use initial values of theta and skip theta iteration. See \code{\link{ssanova}} for notes on skipping theta iteration.} } \details{ A proportional hazard model is assumed, and the relative risk is estimated via penalized partial likelihood. The model specification via \code{formula} is for the log relative risk. For example, \code{Suve(t,d)~u*v} prescribes a model of the form \deqn{ log f(u,v) = g_{u}(u) + g_{v}(v) + g_{u,v}(u,v) } with the terms denoted by \code{"u"}, \code{"v"}, and \code{"u:v"}; relative risk is defined only up to a multiplicative constant, so the constant term is not included in the model. \code{sscox} takes standard right-censored lifetime data, with possible left-truncation and covariates; in \code{Surv(futime,status,start=0)~...}, \code{futime} is the follow-up time, \code{status} is the censoring indicator, and \code{start} is the optional left-truncation time. Parallel to those in a \code{\link{ssanova}} object, the model terms are sums of unpenalized and penalized terms. Attached to every penalized term there is a smoothing parameter, and the model complexity is largely determined by the number of smoothing parameters. The selection of smoothing parameters is through a cross-validation mechanism designed for density estimation under biased sampling, with a fudge factor \code{alpha}; \code{alpha=1} is "unbiased" for the minimization of Kullback-Leibler loss but may yield severe undersmoothing, whereas larger \code{alpha} yields smoother estimates. A subset of the observations are selected as "knots." Unless specified via \code{id.basis} or \code{nbasis}, the number of "knots" \eqn{q} is determined by \eqn{max(30,10n^{2/9})}, which is appropriate for the default cubic splines for numerical vectors. } \note{ The function \code{Surv(futime,status,start=0)} is defined and parsed inside \code{sscox}, not quite the same as the one in the \code{survival} package. The estimation is invariant of monotone transformations of time. The results may vary from run to run. For consistency, specify \code{id.basis} or set \code{seed}. } \value{ \code{sscox} returns a list object of class \code{"sscox"}. The method \code{\link{predict.sscox}} can be used to evaluate the fits at arbitrary points along with standard errors. The method \code{\link{project.sscox}} can be used to calculate the Kullback-Leibler projection for model selection. } \references{ Gu, C. (2013), \emph{Smoothing Spline ANOVA Models (2nd Ed)}. New York: Springer-Verlag. Gu, C. (2014), Smoothing Spline ANOVA Models: R Package gss. \emph{Journal of Statistical Software}, 58(5), 1-25. URL http://www.jstatsoft.org/v58/i05/. } \examples{ ## Relative Risk data(stan) fit.rr <- sscox(Surv(futime,status)~age,data=stan) est.rr <- predict(fit.rr,data.frame(age=c(35,40)),se=TRUE) ## Base Hazard risk <- predict(fit.rr,stan) fit.bh <- sshzd(Surv(futime,status)~futime,data=stan,offset=log(risk)) tt <- seq(0,max(stan$futime),length=51) est.bh <- hzdcurve.sshzd(fit.bh,tt,se=TRUE) ## Clean up \dontrun{rm(stan,fit.rr,est.rr,risk,fit.bh,tt,est.bh)} } \keyword{smooth} \keyword{models} \keyword{survival} gss/man/LakeAcid.Rd0000644000176200001440000000326312355360640013555 0ustar liggesusers\name{LakeAcidity} \alias{LakeAcidity} \title{Water Acidity in Lakes} \description{ Data extracted from the Eastern Lake Survey of 1984 conducted by the United States Environmental Protection Agency, concerning 112 lakes in the Blue Ridge. } \usage{data(LakeAcidity)} \format{ A data frame containing 112 observations on the following variables. \tabular{ll}{ \code{ph} \tab Surface ph.\cr \code{cal} \tab Calcium concentration.\cr \code{lat} \tab Latitude.\cr \code{lon} \tab Longitude.\cr \code{geog} \tab Geographic location, derived from \code{lat} and \code{lon} } } \details{ \code{geog} was generated from \code{lat} and \code{lon} using the code given in the Example section. } \source{ Douglas, A. and Delampady, M. (1990), \emph{Eastern Lake Survey -- Phase I: Documentation for the Data Base and the Derived Data sets.} Tech Report 160 (SIMS), Dept. Statistics, University of British Columbia. } \references{ Gu, C. and Wahba, G. (1993), Semiparametric analysis of variance with tensor product thin plate splines. \emph{Journal of the Royal Statistical Society Ser. B}, \bold{55}, 353--368. } \examples{ ## Converting latitude and longitude to x-y coordinates \dontrun{ltln2xy <- function(latlon,latlon0) { lat <- latlon[,1]*pi/180; lon <- latlon[,2]*pi/180 lt0 <- latlon0[1]*pi/180; ln0 <- latlon0[2]*pi/180 x <- cos(lt0)*sin(lon-ln0); y <- sin(lat-lt0) cbind(x,y) } data(LakeAcidity) latlon <- as.matrix(LakeAcidity[,c("lat","lon")]) m.lat <- (min(latlon[,1])+max(latlon[,1]))/2 m.lon <- (min(latlon[,2])+max(latlon[,2]))/2 ltln2xy(latlon,c(m.lat,m.lon)) ## Clean up rm(ltln2xy,LakeAcidity,latlon,m.lat,m.lon)} } \keyword{datasets} gss/man/summary.ssanova.Rd0000644000176200001440000000421213653352132015260 0ustar liggesusers\name{summary.ssanova} \alias{summary.ssanova} \alias{summary.ssanova0} \alias{summary.ssanova9} \title{Assessing Smoothing Spline ANOVA Fits} \description{ Calculate various summaries of smoothing spline ANOVA fits. } \usage{ \method{summary}{ssanova}(object, diagnostics=FALSE, ...) \method{summary}{ssanova0}(object, diagnostics=FALSE, ...) \method{summary}{ssanova9}(object, diagnostics=FALSE, ...) } \arguments{ \item{object}{Object of class \code{"ssanova"}.} \item{diagnostics}{Flag indicating if diagnostics are required.} \item{...}{Ignored.} } \value{ \code{summary.ssanova} returns a list object of \code{\link{class}} \code{"summary.ssanova"} consisting of the following elements. The entries \code{pi}, \code{kappa}, \code{cosines}, and \code{roughness} are only calculated if \code{diagnostics=TRUE}; see the reference below for details concerning the diagnostics. \item{call}{Fitting call.} \item{method}{Method for smoothing parameter selection.} \item{fitted}{Fitted values.} \item{residuals}{Residuals.} \item{sigma}{Assumed or estimated error standard deviation.} \item{r.squared}{Fraction of "explained variance" by the fitted model.} \item{rss}{Residual sum of squares.} \item{penalty}{Roughness penalty associated with the fit.} \item{pi}{"Percentage decomposition" of "explained variance" into model terms.} \item{kappa}{Concurvity diagnostics for model terms. Virtually the square roots of variance inflation factors of a retrospective linear model.} \item{cosines}{Cosine diagnostics for practical significance of model terms.} \item{roughness}{Percentage decomposition of the roughness penalty \code{penalty} into model terms.} } \references{ Gu, C. (1992), Diagnostics for nonparametric regression models with additive terms. \emph{Journal of the American Statistical Association}, \bold{87}, 1051--1058. } \seealso{ Fitting functions \code{\link{ssanova}}, \code{\link{ssanova0}} and methods \code{\link{predict.ssanova}}, \code{\link{project.ssanova}}, \code{\link{fitted.ssanova}}. } \keyword{models} \keyword{regression} \keyword{smooth} gss/man/dsscopu.Rd0000644000176200001440000000111112355360634013571 0ustar liggesusers\name{dsscopu} \alias{dsscopu} \title{Evaluating Copula Density Estimates} \description{ Evaluate copula density estimates. } \usage{ dsscopu(object, x, copu=TRUE) } \arguments{ \item{object}{Object of class \code{"sscopu"}.} \item{x}{Vector or matrix of point(s) on which copula density is to be evaluated.} \item{copu}{Flag indicating whether to apply copularization.} } \value{ A vector of copula density values. } \seealso{ Fitting functions \code{\link{sscopu}} and \code{\link{sscopu2}}. } \keyword{models} \keyword{distribution} \keyword{smooth} gss/man/cdsscden.Rd0000644000176200001440000000362213653350322013703 0ustar liggesusers\name{cdsscden} \alias{cdsscden} \alias{cpsscden} \alias{cqsscden} \title{Evaluating Conditional PDF, CDF, and Quantiles of Smoothing Spline Conditional Density Estimates} \description{ Evaluate conditional pdf, cdf, and quantiles of f(y1|x,y2) for smoothing spline conditional density estimates f(y|x). } \usage{ cdsscden(object, y, x, cond, int=NULL) cpsscden(object, q, x, cond) cqsscden(object, p, x, cond) } \arguments{ \item{object}{Object of class \code{"sscden"} or \code{"sscden1"}.} \item{x}{Data frame of x values on which conditional density f(y1|x,y2) is to be evaluated.} \item{y}{Data frame or vector of y1 points on which conditional density f(y1|x,y2) is to be evaluated.} \item{cond}{One row data frame of conditioning variables y2.} \item{q}{Vector of points on which cdf is to be evaluated.} \item{p}{Vector of probabilities for which quantiles are to be calculated.} \item{int}{Vector of normalizing constants.} } \value{ \code{cdsscden} returns a list object with the following elements. \item{pdf}{Matrix or vector of conditional pdf f(y1|x,y2), with each column corresponding to a distinct x value.} \item{int}{Vector of normalizing constants.} \code{cpsscden} and \code{cqsscden} return a matrix or vector of conditional cdf or quantiles of f(y1|x,y2). } \details{ The arguments \code{x} and \code{y} are of the same form as the argument \code{newdata} in \code{\link{predict.lm}}, but \code{y} in \code{cdsscden} can take a vector for 1-D y1. \code{cpsscden} and \code{cqsscden} naturally only work for 1-D y1. } \note{ If variables other than factors or numerical vectors are involved in \code{y1}, the normalizing constants can not be computed. } \seealso{ Fitting function \code{\link{sscden}} and \code{\link{dsscden}}. } \keyword{models} \keyword{distribution} \keyword{smooth} gss/man/Sachs.Rd0000644000176200001440000000256312355360640013163 0ustar liggesusers\name{Sachs} \alias{Sachs} \title{Protein Expression in Human Immune System Cells} \description{ Data concerning protein expression levels in human immune system cells under stimulations. } \usage{data(Sachs)} \format{ A data frame containing 7466 cells, with flow cytometry measurements of 11 phosphorylated proteins and phospholipids, on the \code{log10} scale of the original. \tabular{ll}{ \code{praf} \tab Raf phosphorylated at S259.\cr \code{pmek} \tab Mek1/mek2 phosphorylated at S217/S221.\cr \code{plcg} \tab Phosphorylation of phospholipase \eqn{C-\gamma} on Y783.\cr \code{pip2} \tab Phophatidylinositol 4,5-biphosphate.\cr \code{pip3} \tab Phophatidylinositol 3,4,5-triphosphate.\cr \code{p44.42} \tab Erk1/erk2 phosphorylated at T202/Y204.\cr \code{pakts473} \tab AKT phosphorylated at S473.\cr \code{pka} \tab Phosphorylation of of protein kinase A substrates on 3 sites.\cr \code{pkc} \tab Phosphorylation of of protein kinase C substrates on S660.\cr \code{p38} \tab Erk1/erk2 phosphorylated at T180/Y182.\cr \code{pjnk} \tab Erk1/erk2 phosphorylated at T183/Y185.\cr } } \source{ Sachs, K., Perez, O., Pe'er, D., Lauffenburger, D. A., and Nolan, G. P. (2005), Causal protein-signaling networks derived from multiparameter single-cell data. \emph{Science}, \bold{308 (5732)}, 523--529. } \keyword{datasets} gss/man/drkpk.Rd0000644000176200001440000000731213266671123013235 0ustar liggesusers\name{drkpk} \alias{sspdsty} \alias{mspdsty} \alias{sspdsty1} \alias{mspdsty1} \alias{mspcdsty} \alias{mspcdsty1} \alias{msphzd} \alias{msphzd1} \alias{sspcox} \alias{mspcox} \alias{mspllrm} \title{Numerical Engine for ssden, sshzd, and sshzd1} \description{ Perform numerical calculations for the \code{\link{ssden}} and \code{\link{sshzd}} suites. } \usage{ sspdsty(s, r, q, cnt, qd.s, qd.r, qd.wt, prec, maxiter, alpha, bias) mspdsty(s, r, id.basis, cnt, qd.s, qd.r, qd.wt, prec, maxiter, alpha, bias, skip.iter) sspdsty1(s, r, q, cnt, int, prec, maxiter, alpha) mspdsty1(s, r, id.basis, cnt, int, prec, maxiter, alpha) mspcdsty(s, r, id.basis, cnt, qd.s, qd.r, xx.wt, qd.wt, prec, maxiter, alpha, skip.iter) mspcdsty1(s, r, id.basis, cnt, int.s, int.r, prec, maxiter, alpha, skip.iter) msphzd(s, r, id.wk, Nobs, cnt, qd.s, qd.r, qd.wt, random, prec, maxiter, alpha, skip.iter) msphzd1(s, r, id.wk, Nobs, cnt, int.s, int.r, rho, random, prec, maxiter, alpha, skip.iter) sspcox(s, r, q, cnt, qd.s, qd.r, qd.wt, prec, maxiter, alpha, random, bias) mspcox(s, r, id.basis, cnt, qd.s, qd.r, qd.wt, prec, maxiter, alpha, random, bias, skip.iter) mspllrm(s, r, id.basis, cnt, qd.s, qd.r, xx.wt, qd.wt, random, prec, maxiter, alpha, skip.iter) } \details{ \code{sspdsty} is used by \code{\link{ssden}} to compute cross-validated density estimate with a single smoothing parameter. \code{mspdsty} is used by \code{\link{ssden}} to compute cross-validated density estimate with multiple smoothing parameters. \code{msphzd} is used by \code{\link{sshzd}} to compute cross-validated hazard estimate with single or multiple smoothing parameters. } \arguments{ \item{s}{Unpenalized terms evaluated at data points.} \item{r}{Basis of penalized terms evaluated at data points.} \item{q}{Penalty matrix.} \item{id.basis}{Index of observations to be used as "knots."} \item{id.wk}{Index of observations to be used as "knots."} \item{Nobs}{Total number of lifetime observations.} \item{cnt}{Bin-counts for histogram data.} \item{qd.s}{Unpenalized terms evaluated at quadrature nodes.} \item{qd.r}{Basis of penalized terms evaluated at quadrature nodes.} \item{qd.wt}{Quadrature weights.} \item{prec}{Precision requirement for internal iterations.} \item{maxiter}{Maximum number of iterations allowed for internal iterations.} \item{alpha}{Parameter defining cross-validation score for smoothing parameter selection.} \item{bias}{List of arrays incorporating possible sampling bias.} \item{skip.iter}{Flag indicating whether to use initial values of theta and skip theta iteration.} \item{int}{Integrals of basis terms.} \item{int.s}{Integrals of unpenalized terms.} \item{int.r}{Integrals of basis of penalized terms.} \item{rho}{rho function value on failure times.} \item{xx.wt}{Weights at unique x.} \item{random}{Input for parametric random effects in nonparametric mixed-effect models.} } \references{ Du, P. and Gu, C. (2006), Penalized likelihood hazard estimation: efficient approximation and Bayesian confidence intervals. \emph{Statistics and Probability Letters}, \bold{76}, 244--254. Du, P. and Gu, C. (2009), Penalized Pseudo-Likelihood Hazard Estimation: A Fast Alternative to Penalized Likelihood. \emph{Journal of Statistical Planning and Inference}, \bold{139}, 891--899. Gu, C. (2013), \emph{Smoothing Spline ANOVA Models (2nd Ed)}. New York: Springer-Verlag. Gu, C. and Wang, J. (2003), Penalized likelihood density estimation: Direct cross-validation and scalable approximation. \emph{Statistica Sinica}, \bold{13}, 811--826. } \keyword{internal} gss/man/gastric.Rd0000644000176200001440000000126312355360640013552 0ustar liggesusers\name{gastric} \alias{gastric} \title{Gastric Cancer Data} \description{ Survival of gastric cancer patients under chemotherapy and chemotherapy-radiotherapy combination. } \usage{data(gastric)} \format{ A data frame containing 90 observations on the following variables. \tabular{ll}{ \code{futime} \tab Follow-up time, in days.\cr \code{status} \tab Censoring status.\cr \code{trt} \tab Factor indicating the treatments: 1 -- chemothrapy, 2 -- combination. } } \source{ Moreau, T., O'Quigley, J., and Mesbah, M. (1985), A global goodness-of-fit statistic for the proportional hazards model. \emph{Applied Statistics}, \bold{34}, 212-218. } \keyword{datasets} gss/man/rkpk0.Rd0000644000176200001440000000434412355360640013150 0ustar liggesusers\name{rkpk0} \alias{sspreg0} \alias{mspreg0} \alias{getcrdr} \alias{getsms} \alias{sspregpoi} \alias{mspregpoi} \title{Interface to RKPACK} \description{ Call RKPACK routines for numerical calculations concerning the \code{\link{ssanova0}} and \code{\link{gssanova0}} suites. } \usage{ sspreg0(s, q, y, method="v", varht=1) mspreg0(s, q, y, method="v", varht=1, prec=1e-7, maxiter=30) sspregpoi(family, s, q, y, wt, offset, method="u", varht=1, nu, prec=1e-7, maxiter=30) mspregpoi(family, s, q, y, wt, offset, method="u", varht=1, nu, prec=1e-7, maxiter=30) getcrdr(obj, r) getsms(obj) } \details{ \code{sspreg0} is used by \code{\link{ssanova0}} to fit Gaussian models with a single smoothing parameter. \code{mspreg0} is used to fit Gaussian models with multiple smoothing parameters. \code{sspregpoi} is used by \code{\link{gssanova0}} to fit non Gaussian models with a single smoothing parameter. \code{mspregpoi} is used to fit non Gaussian models with multiple smoothing parameters. \code{getcrdr} and \code{getsms} are used by \code{\link{predict.ssanova0}} to calculate standard errors of the fitted terms. } \arguments{ \item{s}{Design matrix of unpenalized terms.} \item{q}{Penalty matrices of penalized terms.} \item{y}{Model response.} \item{method}{Method for smoothing parameter selection.} \item{varht}{Assumed dispersion parameter, needed only for \code{method="u"}.} \item{prec}{Precision requirement for iterations.} \item{maxiter}{Maximum number of iterations allowed.} \item{family}{Error family.} \item{wt}{Model weights.} \item{offset}{Model offset.} \item{obj}{Object returned from a call to \code{sspreg}, \code{mspreg}, \code{sspregpoi}, or \code{mspregpoi}.} \item{nu}{Optional argument for nbinomial, weibull, lognorm, and loglogis families.} \item{r}{Inputs for standard error calculation.} } \references{ Gu, C. (1989), RKPACK and its applications: Fitting smoothing spline models. In \emph{ASA Proceedings of Statistical Computing Section}, pp. 42--51. Gu, C. (1992), Cross validating non Gaussian data. \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 169--179. } \keyword{internal} gss/man/sshzd2d.Rd0000644000176200001440000001233113626334067013503 0ustar liggesusers\name{sshzd2d} \alias{sshzd2d} \alias{sshzd2d1} \title{Estimating 2-D Hazard Function Using Smoothing Splines} \description{ Estimate 2-D hazard function using smoothing spline ANOVA models. } \usage{ sshzd2d(formula1, formula2, symmetry=FALSE, data, alpha=1.4, weights=NULL, subset=NULL, id.basis=NULL, nbasis=NULL, seed=NULL, prec=1e-7, maxiter=30, skip.iter=FALSE) sshzd2d1(formula1, formula2, symmetry=FALSE, data, alpha=1.4, weights=NULL, subset=NULL, rho="marginal", id.basis=NULL, nbasis=NULL, seed=NULL, prec=1e-7, maxiter=30, skip.iter=FALSE) } \arguments{ \item{formula1}{Description of the hazard model to be fit on the first axis.} \item{formula2}{Description of the hazard model to be fit on the second axis.} \item{symmetry}{Flag indicating whether to enforce symmetry of the two axes.} \item{data}{Data frame containing the variables in the model.} \item{alpha}{Parameter defining cross-validation scores for smoothing parameter selection.} \item{weights}{Optional vector of counts for duplicated data.} \item{subset}{Optional vector specifying a subset of observations to be used in the fitting process.} \item{id.basis}{Index of observations to be used as "knots."} \item{nbasis}{Number of "knots" to be used. Ignored when \code{id.basis} is specified.} \item{seed}{Seed to be used for the random generation of "knots." Ignored when \code{id.basis} is specified.} \item{prec}{Precision requirement for internal iterations.} \item{maxiter}{Maximum number of iterations allowed for internal iterations.} \item{skip.iter}{Flag indicating whether to use initial values of theta and skip theta iteration in marginal hazard estimation.} \item{rho}{Choice of rho function for sshzd2d1: \code{"marginal"} or \code{"weibull"}.} } \details{ The 2-D survival function is expressed as \eqn{S(t1,t2)=C(S1(t1),S2(t2))}, where \eqn{S1(t1)}, \eqn{S2(t2)} are marginal survival functions and \eqn{C(u1,u2)} is a 2-D copula. The marginal survival functions are estimated via the marginal hazards as in \code{\link{sshzd}}, and the copula is estimated nonparametrically by calling \code{\link{sscopu2}}. When \code{symmetry=TRUE}, a common marginal survial function S1(t)=S2(t) is estimated, and a symmetric copula is estimated such that \eqn{C(u1,u2)=C(u2,u1)}. Covariates can be incorporated in the marginal hazard models as in \code{\link{sshzd}}, including parametric terms via \code{partial} and frailty terms via \code{random}. Arguments \code{formula1} and \code{formula2} are typically model formulas of the same form as the argument \code{formula} in \code{\link{sshzd}}, but when \code{partial} or \code{random} are needed, \code{formula1} and \code{formula2} should be lists with model formulas as the first elements and \code{partial}/\code{random} as named elements; when necessary, variable configurations (that are done via argument \code{type} in \code{\link{sshzd}}) should also be entered as named elements of lists \code{formula1}/\code{formula2}. When \code{symmetry=TRUE}, parallel model formulas must be consistent of each other, such as \tabular{l}{ \code{formula1=list(Surv(t1,d1)~t1*u1,partial=~z1,random=~1|id1)}\cr \code{formula2=list(Surv(t2,d2)~t2*u2,partial=~z2,random=~1|id2)} } where pairs \code{t1}-\code{t2}, \code{d2}-\code{d2} respectively are different elements in \code{data}, pairs \code{u1}-\code{u2}, \code{z1}-\code{z2} respectively may or may not be different elements in \code{data}, and factors \code{id1} and \code{id2} are typically the same but at least should have the same levels. } \note{ \code{sshzd2d1} executes faster than \code{sshzd2d}, but often at the cost of performance degradation. The results may vary from run to run. For consistency, specify \code{id.basis} or set \code{seed}. } \value{ \code{sshzd2d} and \code{sshzd2d1} return a list object of class \code{"sshzd2d"}. \code{\link{hzdrate.sshzd2d}} can be used to evaluate the estimated 2-D hazard function. \code{\link{survexp.sshzd2d}} can be used to calculate estimated survival functions. } \author{Chong Gu, \email{chong@stat.purdue.edu}} \references{ Gu, C. (2015), Hazard estimation with bivariate survival data and copula density estimation. \emph{Journal of Computational and Graphical Statistics}, \bold{24}, 1053-1073. } \examples{ ## THE FOLLOWING EXAMPLE IS TIME-CONSUMING \dontrun{ data(DiaRet) ## Common proportional hazard model on the margins fit <- sshzd2d(Surv(time1,status1)~time1+trt1*type, Surv(time2,status2)~time2+trt2*type, data=DiaRet,symmetry=TRUE) ## Evaluate fitted survival and hazard functions time <- cbind(c(50,70),c(70,70)) cova <- data.frame(trt1=as.factor(c(1,1)),trt2=as.factor(c(1,0)), type=as.factor(c("juvenile","adult"))) survexp.sshzd2d(fit,time,cov=cova) hzdrate.sshzd2d(fit,time,cov=cova) ## Association between margins: Kendall's tau and Spearman's rho summary(fit$copu) ## Clean up rm(DiaRet,fit,time,cova) dev.off() } } \keyword{smooth} \keyword{models} \keyword{survival} gss/man/wesdr1.Rd0000644000176200001440000000125413653217527013332 0ustar liggesusers\name{wesdr1} \alias{wesdr1} \title{Stages of Diabetic Retinopathy} \description{ Data derived from the Wisconsin Epidemiological Study of Diabetic Retinopathy. } \usage{data(wesdr1)} \format{ A data frame containing 2049 observations on the following variables. \tabular{ll}{ \code{age} \tab Age of patient.\cr \code{dur} \tab Duration of diabetes, in years.\cr \code{gly} \tab Percent of glycosylated hemoglobin.\cr \code{upro} \tab Ordinal urine protein level.\cr \code{insl} \tab Binary indicator of insulin usage.\cr \code{ret1} \tab Ordinal retinopathy stage, right eye.\cr \code{ret2} \tab Ordinal retinopathy stage, left eye. } } \keyword{datasets} gss/man/DiaRet.Rd0000644000176200001440000000243312355360634013271 0ustar liggesusers\name{DiaRet} \alias{DiaRet} \title{Diabetic Retinopathy} \description{ Time to blindness of 197 diabetic retinopathy patients who received a laser treatment in one eye. } \usage{data(DiaRet)} \format{ A data frame containing 197 observations on the following variables. \tabular{ll}{ \code{id} \tab Patient ID.\cr \code{time1} \tab Follow-up time of left eye.\cr \code{time2} \tab Follow-up time of right eye.\cr \code{status1} \tab Censoring indicator of left eye.\cr \code{status2} \tab Censoring indicator of right eye.\cr \code{trt1} \tab Treatment indicator of left eye.\cr \code{trt2} \tab Treatment indicator of right eye.\cr \code{type} \tab Type of diabetes.\cr \code{age} \tab Age of patient at diagnosis.\cr \code{time.t} \tab Follow-up time of treated eye.\cr \code{time.u} \tab Follow-up time of untreated eye.\cr \code{status.t} \tab Censoring indicator of treated eye.\cr \code{status.u} \tab Censoring indicator of untreated eye. } } \source{ This is reformatted from the data frame \code{diabetes} in the R package \code{timereg} by Thomas H. Scheike. } \references{ Huster, W.J., Brookmeyer, R., and Self, S.G. (1989), Modelling paired survival data with covariates. \emph{Biometrics}, \bold{45}, 145--56. } \keyword{datasets} gss/man/mkcov.Rd0000644000176200001440000000251013653350250013227 0ustar liggesusers\name{mkcov} \alias{mkcov} \alias{mkcov.arma} \alias{mkcov.long} \alias{mkcov.known} \title{ Generating Covariance for Correlated Data } \description{ Generate entries of covariance functions for correlated data. } \usage{ mkcov.arma(p, q, n) mkcov.long(id) mkcov.known(w) } \arguments{ \item{p}{Order of AR terms.} \item{q}{Order of MA terms.} \item{n}{Dimension of covariance matrix.} \item{id}{Factor of subject ID.} \item{w}{Covariance matrix; only the upper triangular part is used.} } \details{ \code{mkcov.arma} generates covariance functions for ARMA(p,q) model. \code{mkcov.long} generates covariance functions for longitudinal data. \code{mkcov.known} allows one to use a known covariance matrix in \code{ssanova9}. } \value{ A list of three elements. \item{fun}{Covariance matrix to be evaluated through \code{fun(gamma,env)} or \code{fun(env)}.} \item{env}{Constants in covariance function.} \item{init}{Initial values for correlation parameters.} } \note{ One may pass \code{list(fun=...,env=...,init=...)} directly to the argument \code{cov} in calls to \code{\link{ssanova9}}, or make use of the \code{mkcov.x} functions through \code{cov=list("arma",c(p,q))}, \code{cov=list("long",id)}, or \code{cov=list("known",w)}. } \keyword{internal} gss/man/predict.ssanova.Rd0000644000176200001440000001002313653351512015213 0ustar liggesusers\name{predict.ssanova} \alias{predict.ssanova} \alias{predict.ssanova0} \alias{predict1} \alias{predict1.ssanova} \title{Predicting from Smoothing Spline ANOVA Fits} \description{ Evaluate terms in a smoothing spline ANOVA fit at arbitrary points. Standard errors of the terms can be requested for use in constructing Bayesian confidence intervals. } \usage{ \method{predict}{ssanova}(object, newdata, se.fit=FALSE, include=c(object$terms$labels,object$lab.p), ...) \method{predict}{ssanova0}(object, newdata, se.fit=FALSE, include=c(object$terms$labels,object$lab.p), ...) \method{predict1}{ssanova}(object, contr=c(1,-1), newdata, se.fit=TRUE, include=c(object$terms$labels,object$lab.p), ...) } \arguments{ \item{object}{Object of class inheriting from \code{"ssanova"}.} \item{newdata}{Data frame or model frame in which to predict.} \item{se.fit}{Flag indicating if standard errors are required.} \item{include}{List of model terms to be included in the prediction. The \code{offset} term, if present, is to be specified by \code{"offset"}.} \item{contr}{Contrast coefficients.} \item{...}{Ignored.} } \value{ For \code{se.fit=FALSE}, \code{predict.ssanova} returns a vector of the evaluated fit. For \code{se.fit=TRUE}, \code{predict.ssanova} returns a list consisting of the following elements. \item{fit}{Vector of evaluated fit.} \item{se.fit}{Vector of standard errors.} } \note{ For mixed-effect models through \code{\link{ssanova}} or \code{\link{gssanova}}, the Z matrix is set to 0 if not supplied. To supply the Z matrix, add an element \code{random=I(...)} in \code{newdata}, where the as-is function \code{I(...)} preserves the integrity of the Z matrix in data frame. \code{predict1.ssanova} takes a list of data frames in \code{newdata} representing x1, x2, etc. By default, it calculates f(x1)-f(x2) along with standard errors. While pairwise contrast is the targeted application, all linear combinations can be computed. For \code{"gssanova"} objects, the results are on the link scale. See also \code{\link{predict9.gssanova}}. } \seealso{ Fitting functions \code{\link{ssanova}}, \code{\link{ssanova0}}, \code{\link{gssanova}}, \code{\link{gssanova0}} and methods \code{\link{summary.ssanova}}, \code{\link{summary.gssanova}}, \code{\link{summary.gssanova0}}, \code{\link{project.ssanova}}, \code{\link{fitted.ssanova}}. } \references{ Gu, C. (1992), Penalized likelihood regression: a Bayesian analysis. \emph{Statistica Sinica}, \bold{2}, 255--264. Gu, C. and Wahba, G. (1993), Smoothing spline ANOVA with component-wise Bayesian "confidence intervals." \emph{Journal of Computational and Graphical Statistics}, \bold{2}, 97--117. Kim, Y.-J. and Gu, C. (2004), Smoothing spline Gaussian regression: more scalable computation via efficient approximation. \emph{Journal of the Royal Statistical Society, Ser. B}, \bold{66}, 337--356. } \examples{ ## THE FOLLOWING EXAMPLE IS TIME-CONSUMING \dontrun{ ## Fit a model with cubic and thin-plate marginals, where geog is 2-D data(LakeAcidity) fit <- ssanova(ph~log(cal)*geog,,LakeAcidity) ## Obtain estimates and standard errors on a grid new <- data.frame(cal=1,geog=I(matrix(0,1,2))) new <- model.frame(~log(cal)+geog,new) predict(fit,new,se=TRUE) ## Evaluate the geog main effect predict(fit,new,se=TRUE,inc="geog") ## Evaluate the sum of the geog main effect and the interaction predict(fit,new,se=TRUE,inc=c("geog","log(cal):geog")) ## Evaluate the geog main effect on a grid grid <- seq(-.04,.04,len=21) new <- model.frame(~geog,list(geog=cbind(rep(grid,21),rep(grid,rep(21,21))))) est <- predict(fit,new,se=TRUE,inc="geog") ## Plot the fit and standard error par(pty="s") contour(grid,grid,matrix(est$fit,21,21),col=1) contour(grid,grid,matrix(est$se,21,21),add=TRUE,col=2) ## Clean up rm(LakeAcidity,fit,new,grid,est) dev.off() } } \keyword{models} \keyword{regression} \keyword{smooth} gss/man/sshzd.Rd0000644000176200001440000001606413512125140013244 0ustar liggesusers\name{sshzd} \alias{sshzd} \alias{sshzd1} \title{Estimating Hazard Function Using Smoothing Splines} \description{ Estimate hazard function using smoothing spline ANOVA models. The symbolic model specification via \code{formula} follows the same rules as in \code{\link{lm}}, but with the response of a special form. } \usage{ sshzd(formula, type=NULL, data=list(), alpha=1.4, weights=NULL, subset, offset, na.action=na.omit, partial=NULL, id.basis=NULL, nbasis=NULL, seed=NULL, random=NULL, prec=1e-7, maxiter=30, skip.iter=FALSE) sshzd1(formula, type=NULL, data=list(), alpha=1.4, weights=NULL, subset, na.action=na.omit, rho="marginal", partial=NULL, id.basis=NULL, nbasis=NULL, seed=NULL, random=NULL, prec=1e-7, maxiter=30, skip.iter=FALSE) } \arguments{ \item{formula}{Symbolic description of the model to be fit, where the response is of the form \code{Surv(futime,status,start=0)}.} \item{type}{List specifying the type of spline for each variable. See \code{\link{mkterm}} for details.} \item{data}{Optional data frame containing the variables in the model.} \item{alpha}{Parameter defining cross-validation score for smoothing parameter selection.} \item{weights}{Optional vector of counts for duplicated data.} \item{subset}{Optional vector specifying a subset of observations to be used in the fitting process.} \item{offset}{Optional offset term with known parameter 1.} \item{na.action}{Function which indicates what should happen when the data contain NAs.} \item{partial}{Optional symbolic description of parametric terms in partial spline models.} \item{id.basis}{Index of observations to be used as "knots."} \item{nbasis}{Number of "knots" to be used. Ignored when \code{id.basis} is specified.} \item{seed}{Seed to be used for the random generation of "knots." Ignored when \code{id.basis} is specified.} \item{random}{Input for parametric random effects (frailty) in nonparametric mixed-effect models. See \code{\link{mkran}} for details.} \item{prec}{Precision requirement for internal iterations.} \item{maxiter}{Maximum number of iterations allowed for internal iterations.} \item{skip.iter}{Flag indicating whether to use initial values of theta and skip theta iteration. See \code{\link{ssanova}} for notes on skipping theta iteration.} \item{rho}{Choice of rho function for sshzd1: \code{"marginal"} or \code{"weibull"}.} } \details{ The model specification via \code{formula} is for the log hazard. For example, \code{Suve(t,d)~t*u} prescribes a model of the form \deqn{ log f(t,u) = C + g_{t}(t) + g_{u}(u) + g_{t,u}(t,u) } with the terms denoted by \code{"1"}, \code{"t"}, \code{"u"}, and \code{"t:u"}. Replacing \code{t*u} by \code{t+u} in the \code{formula}, one gets a proportional hazard model with \eqn{g_{t,u}=0}. \code{sshzd} takes standard right-censored lifetime data, with possible left-truncation and covariates; in \code{Surv(futime,status,start=0)~...}, \code{futime} is the follow-up time, \code{status} is the censoring indicator, and \code{start} is the optional left-truncation time. The main effect of \code{futime} must appear in the model terms specified via \code{...}. Parallel to those in a \code{\link{ssanova}} object, the model terms are sums of unpenalized and penalized terms. Attached to every penalized term there is a smoothing parameter, and the model complexity is largely determined by the number of smoothing parameters. The selection of smoothing parameters is through a cross-validation mechanism described in Gu (2002, Sec. 7.2), with a parameter \code{alpha}; \code{alpha=1} is "unbiased" for the minimization of Kullback-Leibler loss but may yield severe undersmoothing, whereas larger \code{alpha} yields smoother estimates. A subset of the observations are selected as "knots." Unless specified via \code{id.basis} or \code{nbasis}, the number of "knots" \eqn{q} is determined by \eqn{max(30,10n^{2/9})}, which is appropriate for the default cubic splines for numerical vectors. } \note{ The function \code{Surv(futime,status,start=0)} is defined and parsed inside \code{sshzd}, not quite the same as the one in the \code{survival} package. Integration on the time axis is done by the 200-point Gauss-Legendre formula on \code{c(min(start),max(futime))}, returned from \code{\link{gauss.quad}}. \code{sshzd1} can be up to 50 times faster than \code{sshzd}, at the cost of performance degradation. The results may vary from run to run. For consistency, specify \code{id.basis} or set \code{seed}. } \value{ \code{sshzd} returns a list object of class \code{"sshzd"}. \code{sshzd1} returns a list object of class \code{c("sshzd1","sshzd")}. \code{\link{hzdrate.sshzd}} can be used to evaluate the estimated hazard function. \code{\link{hzdcurve.sshzd}} can be used to evaluate hazard curves with fixed covariates. \code{\link{survexp.sshzd}} can be used to calculated estimated expected survival. The method \code{\link{project.sshzd}} can be used to calculate the Kullback-Leibler projection of \code{"sshzd"} objects for model selection; \code{\link{project.sshzd1}} can be used to calculate the square error projection of \code{"sshzd1"} objects. } \references{ Du, P. and Gu, C. (2006), Penalized likelihood hazard estimation: efficient approximation and Bayesian confidence intervals. \emph{Statistics and Probability Letters}, \bold{76}, 244--254. Du, P. and Gu, C. (2009), Penalized Pseudo-Likelihood Hazard Estimation: A Fast Alternative to Penalized Likelihood. \emph{Journal of Statistical Planning and Inference}, \bold{139}, 891--899. Du, P. and Ma, S. (2010), Frailty Model with Spline Estimated Nonparametric Hazard Function, \emph{Statistica Sinica}, \bold{20}, 561--580. Gu, C. (2013), \emph{Smoothing Spline ANOVA Models (2nd Ed)}. New York: Springer-Verlag. Gu, C. (2014), Smoothing Spline ANOVA Models: R Package gss. \emph{Journal of Statistical Software}, 58(5), 1-25. URL http://www.jstatsoft.org/v58/i05/. } \examples{ ## Model with interaction data(gastric) gastric.fit <- sshzd(Surv(futime,status)~futime*trt,data=gastric) ## exp(-Lambda(600)), exp(-(Lambda(1200)-Lambda(600))), and exp(-Lambda(1200)) survexp.sshzd(gastric.fit,c(600,1200,1200),data.frame(trt=as.factor(1)),c(0,600,0)) ## Clean up \dontrun{rm(gastric,gastric.fit) dev.off()} ## THE FOLLOWING EXAMPLE IS TIME-CONSUMING ## Proportional hazard model \dontrun{ data(stan) stan.fit <- sshzd(Surv(futime,status)~futime+age,data=stan) ## Evaluate fitted hazard hzdrate.sshzd(stan.fit,data.frame(futime=c(10,20),age=c(20,30))) ## Plot lambda(t,age=20) tt <- seq(0,60,leng=101) hh <- hzdcurve.sshzd(stan.fit,tt,data.frame(age=20)) plot(tt,hh,type="l") ## Clean up rm(stan,stan.fit,tt,hh) dev.off() } } \keyword{smooth} \keyword{models} \keyword{survival} gss/man/dssden.Rd0000644000176200001440000000215312355360640013375 0ustar liggesusers\name{dssden} \alias{dssden} \alias{pssden} \alias{qssden} \alias{d.ssden} \alias{d.ssden1} \title{Evaluating PDF, CDF, and Quantiles of Smoothing Spline Density Estimates} \description{ Evaluate pdf, cdf, and quantiles for smoothing spline density estimates. } \usage{ dssden(object, x) pssden(object, q) qssden(object, p) d.ssden(object, x) d.ssden1(object, x) } \arguments{ \item{object}{Object of class \code{"ssden"}.} \item{x}{Data frame or vector of points on which density is to be evaluated.} \item{q}{Vector of points on which cdf is to be evaluated.} \item{p}{Vector of probabilities for which quantiles are to be calculated.} } \value{ A vector of pdf, cdf, or quantiles. } \details{ The argument \code{x} in \code{dssden} is of the same form as the argument \code{newdata} in \code{\link{predict.lm}}, but can take a vector for 1-D densities. \code{pssden} and \code{qssden} naturally only work for 1-D densities. } \seealso{ Fitting function \code{\link{ssden}} and \code{\link{cdssden}}. } \keyword{models} \keyword{distribution} \keyword{smooth} gss/man/ssllrm.Rd0000644000176200001440000001234113512125161013422 0ustar liggesusers\name{ssllrm} \alias{ssllrm} \title{Fitting Smoothing Spline Log-Linear Regression Models} \description{ Fit smoothing spline log-linear regression models. The symbolic model specification via \code{formula} follows the same rules as in \code{\link{lm}}. } \usage{ ssllrm(formula, response, type=NULL, data=list(), weights, subset, na.action=na.omit, alpha=1, id.basis=NULL, nbasis=NULL, seed=NULL, random=NULL, prec=1e-7, maxiter=30, skip.iter=FALSE) } \arguments{ \item{formula}{Symbolic description of the model to be fit.} \item{response}{Formula listing response variables.} \item{type}{List specifying the type of spline for each variable. See \code{\link{mkterm}} for details.} \item{data}{Optional data frame containing the variables in the model.} \item{weights}{Optional vector of weights to be used in the fitting process.} \item{subset}{Optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{Function which indicates what should happen when the data contain NAs.} \item{alpha}{Parameter modifying GCV or Mallows' CL; larger absolute values yield smoother fits; negative value invokes a stable and more accurate GCV/CL evaluation algorithm but may take two to five times as long. Ignored when \code{method="m"} are specified.} \item{id.basis}{Index designating selected "knots".} \item{nbasis}{Number of "knots" to be selected. Ignored when \code{id.basis} is supplied.} \item{seed}{Seed to be used for the random generation of "knots". Ignored when \code{id.basis} is supplied.} \item{random}{Input for parametric random effects in nonparametric mixed-effect models. See \code{\link{mkran}} for details.} \item{prec}{Precision requirement for internal iterations.} \item{maxiter}{Maximum number of iterations allowed for internal iterations.} \item{skip.iter}{Flag indicating whether to use initial values of theta and skip theta iteration. See \code{\link{ssanova}} for notes on skipping theta iteration.} } \details{ The model is specified via \code{formula} and \code{response}, where \code{response} lists the response variables. For example, \code{ssllrm(~y1*y2*x,~y1+y2)} prescribe a model of the form \deqn{ log f(y1,y2|x) = g_{1}(y1) + g_{2}(y2) + g_{12}(y1,y2) + g_{x1}(x,y1) + g_{x2}(x,y2) + g_{x12}(x,y1,y2) + C(x) } with the terms denoted by \code{"y1"}, \code{"y2"}, \code{"y1:y2"}, \code{"y1:x"}, \code{"y2:x"}, and \code{"y1:y2:x"}; the term(s) not involving response(s) are removed and the constant \code{C(x)} is determined by the fact that a conditional density integrates (adds) to one on the \code{y} axis. The model terms are sums of unpenalized and penalized terms. Attached to every penalized term there is a smoothing parameter, and the model complexity is largely determined by the number of smoothing parameters. A subset of the observations are selected as "knots." Unless specified via \code{id.basis} or \code{nbasis}, the number of "knots" \eqn{q} is determined by \eqn{max(30,10n^{2/9})}, which is appropriate for the default cubic splines for numerical vectors. } \note{ The responses, or y-variables, must be factors, and there must be at least one numerical x's. For \code{response}, there is no difference between \code{~y1+y2} and \code{~y1*y2}. The results may vary from run to run. For consistency, specify \code{id.basis} or set \code{seed}. } \value{ \code{ssllrm} returns a list object of class \code{"ssllrm"}. The method \code{\link{predict.ssllrm}} can be used to evaluate \code{f(y|x)} at arbitrary x, or contrasts of \code{log{f(y|x)}} such as the odds ratio along with standard errors. The method \code{\link{project.ssllrm}} can be used to calculate the Kullback-Leibler projection for model selection. } \references{ Gu, C. and Ma, P. (2011), Nonparametric regression with cross-classified responses. \emph{The Canadian Journal of Statistics}, \bold{39}, 591--609. Gu, C. (2014), Smoothing Spline ANOVA Models: R Package gss. \emph{Journal of Statistical Software}, 58(5), 1-25. URL http://www.jstatsoft.org/v58/i05/. } \examples{ ## Simulate data test <- function(x) {.3*(1e6*(x^11*(1-x)^6)+1e4*(x^3*(1-x)^10))-2} x <- (0:100)/100 p <- 1-1/(1+exp(test(x))) y <- rbinom(x,3,p) y1 <- as.ordered(y) y2 <- as.factor(rbinom(x,1,p)) ## Fit model fit <- ssllrm(~y1*y2*x,~y1+y2) ## Evaluate f(y|x) est <- predict(fit,data.frame(x=x), data.frame(y1=as.factor(0:3),y2=as.factor(rep(0,4)))) ## f(y|x) at all y values (fit$qd.pt) est <- predict(fit,data.frame(x=x)) ## Evaluate contrast of log f(y|x) est <- predict(fit,data.frame(x=x),odds=c(-1,.5,.5,0), data.frame(y1=as.factor(0:3),y2=as.factor(rep(0,4))),se=TRUE) ## Odds ratio log{f(0,0|x)/f(3,0|x)} est <- predict(fit,data.frame(x=x),odds=c(1,-1), data.frame(y1=as.factor(c(0,3)),y2=as.factor(c(0,1))),se=TRUE) ## KL projection kl <- project(fit,include=c("y2:x","y1:y2","y1:x","y2:x")) ## Clean up \dontrun{rm(test,x,p,y,y1,y2,fit,est,kl) dev.off()} } \keyword{smooth} \keyword{models} \keyword{regression} gss/man/wesdr.Rd0000644000176200001440000000316112355360640013241 0ustar liggesusers\name{wesdr} \alias{wesdr} \title{Progression of Diabetic Retinopathy} \description{ Data derived from the Wisconsin Epidemiological Study of Diabetic Retinopathy. } \usage{data(wesdr)} \format{ A data frame containing 669 observations on the following variables. \tabular{ll}{ \code{dur} \tab Duration of diabetes at baseline, in years.\cr \code{gly} \tab Percent of glycosylated hemoglobin at baseline.\cr \code{bmi} \tab Body mass index at baseline.\cr \code{ret} \tab Binary indicator of retinopathy progression at first follow-up. } } \source{ Wang, Y. (1997), GRKPACK: Fitting smoothing spline ANOVA models for exponential families. \emph{Communications in Statistics -- Simulations and Computation}, \bold{26}, 765--782. } \references{ Klein, R., Klein, B. E. K., Moss, S. E., Davis, M. D., and DeMets, D. L. (1988), Glycosylated hemoglobin predicts the incidence and progression of diabetic retinopathy. \emph{Journal of the American Medical Association}, \bold{260}, 2864--2871. Klein, R., Klein, B. E. K., Moss, S. E., Davis, M. D., and DeMets, D. L. (1989), The Wisconsin Epidemiologic Study of Diabetic Retinopathy. X. Four incidence and progression of diabetic retinopathy when age at diagnosis is 30 or more years. \emph{Archive Ophthalmology}, \bold{107}, 244--249. Wahba, G., Wang, Y., Gu, C., Klein, R., and Klein, B. E. K. (1995), Smoothing spline ANOVA for exponential families, with application to the Wisconsin Epidemiological Study of Diabetic Retinopathy. \emph{The Annals of Statistics}, \bold{23}, 1865--1895. } \keyword{datasets} gss/man/mkfun.poly.Rd0000644000176200001440000000313213653350406014216 0ustar liggesusers\name{mkfun.poly} \alias{mkfun.poly} \alias{mkrk.cubic} \alias{mkphi.cubic} \alias{mkrk.cubic.per} \alias{mkrk.linear} \alias{mkrk.linear.per} \alias{mkrk.trig} \alias{mkphi.trig} \title{ Crafting Building Blocks for Polynomial Splines } \description{ Craft numerical functions to be used by \code{\link{mkterm}} to assemble model terms. } \usage{ mkrk.cubic(range) mkphi.cubic(range) mkrk.trig(range) mkphi.trig(range) mkrk.cubic.per(range) mkrk.linear(range) mkrk.linear.per(range) } \arguments{ \item{range}{Numerical vector whose minimum and maximum specify the range on which the function to be crafted is defined.} } \value{ A list of two elements. \item{fun}{Function definition.} \item{env}{Portable local constants derived from the argument.} } \note{ \code{mkrk.x} create a bivariate function \code{fun(x,y,env,outer=FALSE)}, where \code{x}, \code{y} are real arguments and local constants can be passed in through \code{env}. \code{mkphi.cubic} creates a univariate function \code{fun(x,nu,env)}. } \seealso{ \code{\link{mkterm}}, \code{\link{mkfun.tp}}, and \code{\link{mkrk.nominal}}. } \details{ \code{mkrk.cubic}, \code{mkphi.cubic}, and \code{mkrk.linear} implement the polynomial spline construction in Gu (2002, Sec. 2.3.3) for \eqn{m=2,1}. \code{mkrk.cubic.per} and \code{mkrk.linear.per} implement the periodic polynomial spline construction in Gu (2002, Sec. 4.2.1) for \eqn{m=2,1}. } \references{ Gu, C. (2013), \emph{Smoothing Spline ANOVA Models (2nd Ed)}. New York: Springer-Verlag. } \keyword{internal} gss/man/summary.gssanova.Rd0000644000176200001440000000470413653352053015437 0ustar liggesusers\name{summary.gssanova} \alias{summary.gssanova} \title{Assessing Smoothing Spline ANOVA Fits with Non-Gaussian Responses} \description{ Calculate various summaries of smoothing spline ANOVA fits with non-Gaussian responses. } \usage{ \method{summary}{gssanova}(object, diagnostics=FALSE, ...) } \arguments{ \item{object}{Object of class \code{"gssanova"}.} \item{diagnostics}{Flag indicating if diagnostics are required.} \item{...}{Ignored.} } \value{ \code{summary.gssanova} returns a list object of \code{\link{class}} \code{"summary.gssanova"} consisting of the following elements. The entries \code{pi}, \code{kappa}, \code{cosines}, and \code{roughness} are only calculated if \code{diagnostics=TRUE}. \item{call}{Fitting call.} \item{family}{Error distribution.} \item{alpha}{Parameter used to define cross-validation in model fitting.} \item{fitted}{Fitted values on the link scale.} \item{dispersion}{Assumed or estimated dispersion parameter.} \item{residuals}{Working residuals on the link scale.} \item{rss}{Residual sum of squares.} \item{dev.resid}{Deviance residuals.} \item{deviance}{Deviance of the fit.} \item{dev.null}{Deviance of the null model.} \item{penalty}{Roughness penalty associated with the fit.} \item{pi}{"Percentage decomposition" of "explained variance" into model terms.} \item{kappa}{Concurvity diagnostics for model terms. Virtually the square roots of variance inflation factors of a retrospective linear model.} \item{cosines}{Cosine diagnostics for practical significance of model terms.} \item{roughness}{Percentage decomposition of the roughness penalty \code{penalty} into model terms.} } \details{ Similar to the iterated weighted least squares fitting of \code{\link{glm}}, penalized likelihood regression fit can be calculated through iterated penalized weighted least squares. The diagnostics are based on the "pseudo" Gaussian response model behind the weighted least squares problem at convergence. } \references{ Gu, C. (1992), Diagnostics for nonparametric regression models with additive terms. \emph{Journal of the American Statistical Association}, \bold{87}, 1051--1058. } \seealso{ Fitting function \code{\link{gssanova}} and methods \code{\link{predict.ssanova}}, \code{\link{project.gssanova}}, \code{\link{fitted.gssanova}}. } \keyword{models} \keyword{regression} \keyword{smooth} gss/man/ssanova.Rd0000644000176200001440000001602313512125041013556 0ustar liggesusers\name{ssanova} \alias{ssanova} \title{Fitting Smoothing Spline ANOVA Models} \description{ Fit smoothing spline ANOVA models in Gaussian regression. The symbolic model specification via \code{formula} follows the same rules as in \code{\link{lm}}. } \usage{ ssanova(formula, type=NULL, data=list(), weights, subset, offset, na.action=na.omit, partial=NULL, method="v", alpha=1.4, varht=1, id.basis=NULL, nbasis=NULL, seed=NULL, random=NULL, skip.iter=FALSE) } \arguments{ \item{formula}{Symbolic description of the model to be fit.} \item{type}{List specifying the type of spline for each variable. See \code{\link{mkterm}} for details.} \item{data}{Optional data frame containing the variables in the model.} \item{weights}{Optional vector of weights to be used in the fitting process.} \item{subset}{Optional vector specifying a subset of observations to be used in the fitting process.} \item{offset}{Optional offset term with known parameter 1.} \item{na.action}{Function which indicates what should happen when the data contain NAs.} \item{partial}{Optional symbolic description of parametric terms in partial spline models.} \item{method}{Method for smoothing parameter selection. Supported are \code{method="v"} for GCV, \code{method="m"} for GML (REML), and \code{method="u"} for Mallows' CL.} \item{alpha}{Parameter modifying GCV or Mallows' CL; larger absolute values yield smoother fits; negative value invokes a stable and more accurate GCV/CL evaluation algorithm but may take two to five times as long. Ignored when \code{method="m"} are specified.} \item{varht}{External variance estimate needed for \code{method="u"}. Ignored when \code{method="v"} or \code{method="m"} are specified.} \item{id.basis}{Index designating selected "knots".} \item{nbasis}{Number of "knots" to be selected. Ignored when \code{id.basis} is supplied.} \item{seed}{Seed to be used for the random generation of "knots". Ignored when \code{id.basis} is supplied.} \item{random}{Input for parametric random effects in nonparametric mixed-effect models. See \code{\link{mkran}} for details.} \item{skip.iter}{Flag indicating whether to use initial values of theta and skip theta iteration. See notes on skipping theta iteration.} } \details{ The model specification via \code{formula} is intuitive. For example, \code{y~x1*x2} yields a model of the form \deqn{ y = C + f_{1}(x1) + f_{2}(x2) + f_{12}(x1,x2) + e } with the terms denoted by \code{"1"}, \code{"x1"}, \code{"x2"}, and \code{"x1:x2"}. The model terms are sums of unpenalized and penalized terms. Attached to every penalized term there is a smoothing parameter, and the model complexity is largely determined by the number of smoothing parameters. A subset of the observations are selected as "knots." Unless specified via \code{id.basis} or \code{nbasis}, the number of "knots" \eqn{q} is determined by \eqn{max(30,10n^{2/9})}, which is appropriate for the default cubic splines for numerical vectors. Using \eqn{q} "knots," \code{ssanova} calculates an approximate solution to the penalized least squares problem using algorithms of the order \eqn{O(nq^{2})}, which for \eqn{q<d}. \code{mkrk.tp.p} generates the pseudo kernel, and \code{mkphi.tp.p} generates the \eqn{(m+d-1)!/d!/(m-1)!} lower order polynomials with total order less than \eqn{m}. \code{mkphi.tp} generates normalized lower order polynomials orthonormal w.r.t. a norm specified by \code{mesh} and \code{weight}, and \code{mkrk.tp} conditions the pseudo kernel to generate the reproducing kernel orthogonal to the lower order polynomials w.r.t. the norm. \code{mkrk.sphere} implements the reproducing kernel construction of Wahba (1981) for \eqn{m=2,3,4}. } \value{ A list of two elements. \item{fun}{Function definition.} \item{env}{Portable local constants derived from the arguments.} } \note{ \code{mkrk.tp} and \code{mkrk.sphere} create a bivariate function \code{fun(x,y,env,outer=FALSE)}, where \code{x}, \code{y} are real arguments and local constants can be passed in through \code{env}. \code{mkphi.tp} creates a collection of univariate functions \code{fun(x,nu,env)}, where \code{x} is the argument and \code{nu} is the index. } \references{ Gu, C. (2013), \emph{Smoothing Spline ANOVA Models (2nd Ed)}. New York: Springer-Verlag. Wahba, G. (1981), Spline interpolation and smoothing on the sphere. \emph{SIAM Journal on Scientific and Statistical Computing}, \bold{2}, 5--16. } \seealso{ \code{\link{mkterm}}, \code{\link{mkfun.poly}}, and \code{\link{mkrk.nominal}}. } \keyword{internal} gss/man/clim.Rd0000644000176200001440000000117212355360640013041 0ustar liggesusers\name{clim} \alias{clim} \title{Average Temperatures During December 1980 Through February 1981} \description{ Average temperatures at 690 weather stations during December 1980 through February 1981. } \usage{data(clim)} \format{ A data frame containing 690 observations on the following variables. \tabular{ll}{ \code{temp} \tab Average temperature, in Celsius.\cr \code{geog} \tab Geographic location (latitude,longitude), in degrees, as a matrix. } } \source{ This is reformulated from the data frame \code{climate} in the R package \code{assist} by Yuedong Wang and Chunlei Ke. } \keyword{datasets} gss/man/ColoCan.Rd0000644000176200001440000000323312355360640013433 0ustar liggesusers\name{ColoCan} \alias{ColoCan} \title{Colorectal Cancer Mortality Rate in Indiana Counties} \description{ County-wise death counts of colorectal cancer patients in Indiana during years 2000 through 2004. } \usage{data(ColoCan)} \format{ A data frame containing 184 observations on the following variables. \tabular{ll}{ \code{event} \tab Death counts.\cr \code{pop} \tab Population from Census 2000.\cr \code{sex} \tab Gender of population.\cr \code{wrt} \tab Proportion of Whites.\cr \code{brt} \tab Proportion of Blacks.\cr \code{ort} \tab Proportion of other minorities.\cr \code{lat} \tab Latitude.\cr \code{lon} \tab Longitude.\cr \code{geog} \tab Geographic location, derived from \code{lat} and \code{lon}.\cr \code{scrn} \tab Colorectal cancer screening rate.\cr \code{name} \tab County name. } } \details{ \code{geog} was generated from \code{lat} and \code{lon} using the code given in the example section. } \source{ Dr. Tonglin Zhang. } \references{ Zhang, T. and Lin, G. (2009), Cluster detection based on spatial associations and iterated residuals in generalized linear mixed models. \emph{Biometrics}, \bold{65}, 353--360. } \examples{ ## Converting latitude and longitude to x-y coordinates ## The 49th county is Marion, where Indianapolis is located. \dontrun{ltln2xy <- function(latlon,latlon0) { lat <- latlon[,1]*pi/180; lon <- latlon[,2]*pi/180 lt0 <- latlon0[1]*pi/180; ln0 <- latlon0[2]*pi/180 x <- cos(lt0)*sin(lon-ln0); y <- sin(lat-lt0) cbind(x,y) } data(ColoCan) latlon <- as.matrix(ColoCan[,c("lat","lon")]) ltln2xy(latlon,latlon[49,]) ## Clean up rm(ltln2xy,ColoCan,latlon)} } \keyword{datasets} gss/man/cdssden.Rd0000644000176200001440000000320413653350176013543 0ustar liggesusers\name{cdssden} \alias{cdssden} \alias{cpssden} \alias{cqssden} \title{Evaluating Conditional PDF, CDF, and Quantiles of Smoothing Spline Density Estimates} \description{ Evaluate conditional pdf, cdf, and quantiles for smoothing spline density estimates. } \usage{ cdssden(object, x, cond, int=NULL) cpssden(object, q, cond) cqssden(object, p, cond) } \arguments{ \item{object}{Object of class \code{"ssden"}.} \item{x}{Data frame or vector of points on which conditional density is to be evaluated.} \item{cond}{One row data frame of conditioning variables.} \item{int}{Normalizing constant.} \item{q}{Vector of points on which conditional cdf is to be evaluated.} \item{p}{Vector of probabilities for which conditional quantiles are to be calculated.} } \value{ \code{cdssden} returns a list object with the following elements. \item{pdf}{Vector of conditional pdf.} \item{int}{Normalizing constant.} \code{cpssden} and \code{cqssden} return a vector of conditional cdf or quantiles. } \details{ The argument \code{x} in \code{cdssden} is of the same form as the argument \code{newdata} in \code{\link{predict.lm}}, but can take a vector for 1-D conditional densities. \code{cpssden} and \code{cqssden} naturally only work for 1-D conditional densities of a numerical variable. } \note{ If variables other than factors or numerical vectors are involved in \code{x}, the normalizing constant can not be computed. } \seealso{ Fitting function \code{\link{ssden}} and \code{\link{dssden}}. } \keyword{models} \keyword{distribution} \keyword{smooth} gss/man/sscopu.Rd0000644000176200001440000001116213653611051013426 0ustar liggesusers\name{sscopu} \alias{sscopu} \alias{sscopu2} \title{Estimating Copula Density Using Smoothing Splines} \description{ Estimate copula densities using tensor-product cubic splines. } \usage{ sscopu(x, symmetry=FALSE, alpha=1.4, order=NULL, exclude=NULL, weights=NULL, id.basis=NULL, nbasis=NULL, seed=NULL, qdsz.depth=NULL, prec=1e-7, maxiter=30, skip.iter=dim(x)[2]!=2) sscopu2(x, censoring=NULL, truncation=NULL, symmetry=FALSE, alpha=1.4, weights=NULL, id.basis=NULL, nbasis=NULL, seed=NULL, prec=1e-7, maxiter=30) } \arguments{ \item{x}{Matrix of observations on unit cubes.} \item{symmetry}{Flag indicating whether to enforce symmetry, or invariance under coordinate permutation.} \item{order}{Highest order of interaction terms in log density. When \code{NULL}, it is set to \code{dim(x)[2]} internally.} \item{exclude}{Pair(s) of marginals whose interactions to be excluded in log density.} \item{alpha}{Parameter defining cross-validation score for smoothing parameter selection.} \item{weights}{Optional vector of bin-counts for histogram data.} \item{id.basis}{Index of observations to be used as "knots."} \item{nbasis}{Number of "knots" to be used. Ignored when \code{id.basis} is specified.} \item{seed}{Seed to be used for the random generation of "knots." Ignored when \code{id.basis} is specified.} \item{qdsz.depth}{Depth to be used in \code{\link{smolyak.quad}} for the generation of quadrature.} \item{prec}{Precision requirement for internal iterations.} \item{maxiter}{Maximum number of iterations allowed for internal iterations.} \item{skip.iter}{Flag indicating whether to use initial values of theta and skip theta iteration. See \code{\link{ssanova}} for notes on skipping theta iteration.} \item{censoring}{Optional censoring indicator.} \item{truncation}{Optional truncation points.} } \details{ \code{sscopu} is essentially \code{\link{ssden}} applied to observations on unit cubes. Instead of variables in data frames, the data are entered as a numerical matrix, and model complexity is globally controlled by the highest order of interactions allowed in log density. \code{sscopu2} further restricts the domain to the unit square, but allows for possible censoring and truncation. With \code{censoring==0,1,2,3}, a data point \eqn{(x1,x2)} represents exact observation, \eqn{[0,x1]x{x2}}, \eqn{{x1}x[0,x2]}, or \eqn{[0,x1]x[0,x2]}. With \code{truncation} point \eqn{(t1,t2)}, the sample is taken from \eqn{[0,t1]x[0,t2]} instead of the unit square. With \code{symmetriy=TRUE}, one may enforce the interchangeability of coordinates so that \eqn{f(x1,x2)=f(x2,x1)}, say. When \code{(1,2)} is a row in \code{exclude}, interaction terms involving coordinates \code{1} and \code{2} are excluded. } \note{ For reasonable execution time in higher dimensions, set \code{skip.iter=TRUE} in calls to \code{sscopu}. When \code{"Newton iteration diverges"} in \code{sscopu}, try to use a larger \code{qdsz.depth}; the default values for dimensions 2, 3, 4, 5, 6+ are 24, 14, 12, 11, 10. To be sure a larger \code{qdsz.depth} indeed makes difference, verify the cubature size using \code{\link{smolyak.size}}. The results may vary from run to run. For consistency, specify \code{id.basis} or set \code{seed}. } \value{ \code{sscopu} and \code{sscopu2} return a list object of class \code{"sscopu"}. \code{\link{dsscopu}} can be used to evaluate the estimated copula density. A "copularization" process is applied to the estimated density by default so the resulting marginal densities are guaranteed to be uniform. \code{\link{cdsscopu}}, \code{\link{cpsscopu}}, and \code{\link{cqsscopu}} can be used to evaluate 1-D conditional pdf, cdf, and quantiles. } \author{Chong Gu, \email{chong@stat.purdue.edu}} \references{ Gu, C. (2013), \emph{Smoothing Spline ANOVA Models (2nd Ed)}. New York: Springer-Verlag. Gu, C. (2015), Hazard estimation with bivariate survival data and copula density estimation. \emph{Journal of Computational and Graphical Statistics}, \bold{24}, 1053-1073. } \examples{ ## simulate 2-D data x <- matrix(runif(200),100,2) ## fit copula density fit <- sscopu(x) ## "same fit" fit2 <- sscopu2(x,id=fit$id) ## symmetric fit fit.s <- sscopu(x,sym=TRUE,id=fit$id) \dontrun{ ## Kendall's tau and Spearman's rho summary(fit); summary(fit2); summary(fit.s) ## clean up rm(x,fit,fit2,fit.s) } } \keyword{smooth} \keyword{models} \keyword{distribution} gss/man/project.Rd0000644000176200001440000000660113653351721013567 0ustar liggesusers\name{project} \alias{project} \alias{project.ssanova} \alias{project.ssanova9} \alias{project.gssanova} \alias{project.ssden} \alias{project.ssden1} \alias{project.sscden} \alias{project.sscden1} \alias{project.sshzd} \alias{project.sscox} \alias{project.sshzd1} \alias{project.ssllrm} \title{Projecting Smoothing Spline ANOVA Fits for Model Diagnostics} \description{ Calculate Kullback-Leibler projection of smoothing spline ANOVA fits for model diagnostics. } \usage{ project(object, ...) \method{project}{ssanova}(object, include, ...) \method{project}{ssanova9}(object, include, ...) \method{project}{gssanova}(object, include, ...) \method{project}{ssden}(object, include, mesh=FALSE, ...) \method{project}{ssden1}(object, include, drop1=FALSE, ...) \method{project}{sscden}(object, include, ...) \method{project}{sscden1}(object, include, ...) \method{project}{sshzd}(object, include, mesh=FALSE, ...) \method{project}{sscox}(object, include, ...) \method{project}{sshzd1}(object, include, ...) \method{project}{ssllrm}(object, include, ...) } \arguments{ \item{object}{Object of class \code{"ssanova"}, \code{"gssanova"}, \code{"ssden"}, \code{"ssden1"}, \code{"sscden"}, \code{"sscden1"}, \code{"sshzd"}, \code{"sshzd1"}, or \code{"ssllrm"}.} \item{...}{Additional arguments. Ignored in \code{project.x}.} \item{include}{List of model terms to be included in the reduced model space. The \code{partial} and \code{offset} terms, if present, are to be specified by \code{"partial"} and \code{"offset"}, respectively.} \item{mesh}{Flag indicating whether to return evaluations of the projection.} \item{drop1}{If TRUE, calculate \code{p<-length(include)} projections with \code{include[-i]}, \code{i=1,...,p}.} } \value{ The functions return a list consisting of the following elements. \item{ratio}{KL(fit0,fit1)/KL(fit0,null); the smaller the value, the more feasible the reduced model is.} \item{kl}{KL(fit0,fit1).} For regression fits, the list also contains the following element. \item{check}{KL(fit0,fit1)/KL(fit0,null)+KL(fit1,null)/KL(fit0,null); a value closer to 1 is preferred.} For density and hazard fits, the list may contain the following optional element. \item{mesh}{The evaluations of the projection.} } \note{ \code{project.ssden1}, \code{project.sscden1}, and \code{project.sshzd1} calculates square error projections. } \details{ The entropy KL(fit0,null) can be decomposed as the sum of KL(fit0,fit1) and KL(fit1,null), where fit0 is the fit to be projected, fit1 is the projection in the reduced model space, and null is the constant fit. The ratio KL(fit0,fit1)/KL(fit0,null) serves as a diagnostic of the feasibility of the reduced model. For regression fits, smoothness safe-guard is used to prevent interpolation, and KL(fit0,fit1)+KL(fit1,null) may not match KL(fit0,null) perfectly. For mixed-effect models from \code{ssanova} and \code{gssanova}, the estimated random effects are treated as offset. } \references{ Gu, C. (2004), Model diagnostics for smoothing spline ANOVA models. \emph{The Canadian Journal of Statistics}, \bold{32}, 347--358. } \seealso{ Fitting functions \code{\link{ssanova}}, \code{\link{gssanova}}, \code{\link{ssden}}, \code{\link{sshzd}}, and \code{\link{sshzd1}}. } \keyword{models} \keyword{smooth} \keyword{htest} gss/man/mkterm.Rd0000644000176200001440000001310313653351400013405 0ustar liggesusers\name{mkterm} \alias{mkterm} \title{ Assembling Model Terms for Smoothing Spline ANOVA Models } \description{ Assemble numerical functions for calculating model terms in a smoothing spline ANOVA model. } \usage{ mkterm(mf, type) } \arguments{ \item{mf}{Model frame of the model formula.} \item{type}{List specifying the type of spline for each variable.} } \section{Background}{ Tensor-product splines are constructed based on the model formula and the marginal reproducing kernels, as described in Gu (2002, Sec. 2.4). The marginal variables can be factors, numerical vectors, and numerical matrices, as specified in the details section. One-way ANOVA decompositions are built in the supported marginal constructions, in which one has the constant, a "nonparametric contrast," and possibly also a "parametric contrast." To the "nonparametric contrast" there corresponds a reproducing kernal \code{rk}, and to a "parametric contrast" there corresponds a set of null space basis \code{phi}. The reproducing kernels and null space basis on the product domain can be constructed from the marginal \code{rk} and \code{phi} in a systematic manner. The marginal one-way ANOVA structures induce a multi-way ANOVA structure on the product domain, with model terms consisting of unpenalized "parametric contrasts" and/or penalized "nonparametric contrasts." One only needs to construct \code{rk}'s and \code{phi}'s associated with the model terms implied by the model formula. } \details{ For a \bold{factor} \code{x}, \code{type$x} is ignored; \code{\link{mkrk.ordinal}} is used if \code{is.ordered(x)==TRUE} and \code{\link{mkrk.nominal}} is used otherwise. Factors with 3 or more levels are penalized. For a \bold{numerical vector} \code{x}, \code{type$x} is of the form \code{type.x} for \code{type.x}=\code{"cubic"}, \code{"linear"}, or of the form \code{list(type.x, range)} for \code{type.x}=\code{"per"}, \code{"cubic.per"}, \code{"linear.per"}, \code{"cubic"}, \code{"linear"}; \code{"per"} is short for \code{"cubic.per"}. See \code{\link{mkfun.poly}} for the functions used. For \code{type.x} missing, the \bold{default} is \code{"cubic"}. For \code{range} missing with \code{type.x}=\code{"cubic"}, \code{"linear"}, the \bold{default} is \code{c(min(x),max(x))+c(-1,1)*(max(x)-mimn(x))*.05}. For a \bold{numerical matrix} \code{x}, \code{type$x} is of the form \code{type.x} or \code{list(type.x, order)} for \code{type.x}=\code{"tp"}, \code{"sphere"}, or of the form \code{list("tp",list(order=order,mesh=mesh,weight=weight))}. See \code{\link{mkfun.tp}} for the functions used. For \code{type.x} missing, the \bold{default} is \code{"tp"}. For \code{order} missing, the \bold{default} is \code{2}. For \code{mesh} and \code{weight} missing with \code{type.x}=\code{"tp"} and \code{order} given, the \bold{defaults} are \code{mesh}=\code{x} and \code{weight}=\code{1}. For a \bold{numerical vector} or \bold{numerical matrix} \code{x}, one may also use \code{type$x} of the form \code{list("custom",list(nphi=nphi,mkphi=mkphi,mkrk=mkrk,env=env))}; \code{nphi} is the null space dimension \emph{excluding the constant}, and \code{mkphi} is ignored if \code{nphi}=0. See examples below. This feature allows the use of other marginal constructions; one may modify \code{\link{mkphi.cubic}} or \code{\link{mkphi.tp.p}} for \code{mkphi} and modify \code{\link{mkrk.cubic}} or \code{\link{mkrk.sphere}} for \code{mkrk}. } \note{ For a \bold{numerical vector} \code{x} in \code{\link{ssden}}, the default \code{range} is \code{domain$x}. For a \bold{numerical matrix} \code{x} with \code{type.x}=\code{"sphere"}, it is assumed that \code{dim(x)[2]==2}, \code{x[,1]} between [-90,90] the latitude in degrees, and \code{x[,2]} between [-180,180] the longitude in degrees. For \bold{backward compatibility}, one may set \code{type="cubic"}, \code{"linear"}, or \code{"tp"}, but then the default parameters can not be overridden; the type is simply duplicated for each variable. } \value{ A list object with an element \code{labels} containing the labels of all model terms. For each of the model terms, there is an element holding the numerical functions for calculating the unpenalized and penalized parts within the term. } \references{ Gu, C. (2013), \emph{Smoothing Spline ANOVA Models (2nd Ed)}. New York: Springer-Verlag. } \examples{ ## cubic marginals x1 <- rnorm(100); x2 <- rnorm(100); y <- 3+5*sin(x1-2*x2)+rnorm(x1) fit <- ssanova0(y~x1*x2) ## the same fit fit1 <- ssanova0(y~x1*x2,type=list(x1="cubic")) ## the same fit one more time par <- list(nphi=1,mkphi=mkphi.cubic,mkrk=mkrk.cubic, env=c(min(x2),max(x2))+c(-1,1)*(max(x2)-min(x2))*.05) fit2 <- ssanova0(y~x1*x2,type=list(x2=list("custom",par))) ## Clean up \dontrun{rm(x1,x2,y,fit,fit1,par,fit2)} ## cubic and thin-plate marginals x1 <- rnorm(100); x2 <- matrix(rnorm(200),100,2) y <- 3+5*sin(x1-2*x2[,1]*x2[,2])+rnorm(x1) fit <- ssanova0(y~x1*x2) ## the same fit fit1 <- ssanova0(y~x1*x2,type=list(x2="tp")) ## the same fit one more time mkphi.tp1 <- function(x) mkphi.tp(x$dm,x$ord,x$mesh,x$wt) mkrk.tp1 <- function(x) mkrk.tp(x$dm,x$ord,x$mesh,x$wt) env <- list(dm=2,ord=2,mesh=x2,wt=1) par <- list(nphi=2,mkphi=mkphi.tp1,mkrk=mkrk.tp1,env=env) fit2 <- ssanova0(y~x1*x2,type=list(x2=list("custom",par))) ## Clean up \dontrun{rm(x1,x2,y,fit,fit1,mkphi.tp1,mkrk.tp1,env,par,fit2)} } \keyword{internal} gss/man/mkran.Rd0000644000176200001440000000662613653350553013242 0ustar liggesusers\name{mkran} \alias{mkran} \alias{mkran1} \title{ Generating Random Effects in Mixed-Effect Models } \description{ Generate entries representing random effects in mixed-effect models. } \usage{ mkran(formula, data) mkran1(ran1, ran2) } \arguments{ \item{formula}{Symbolic description of the random effects.} \item{data}{Data frame containing the variables in the model.} \item{ran1}{Random effects in the form of the value of \code{mkran}}. \item{ran2}{Random effects in the form of the value of \code{mkran}}. } \details{ \code{mkran} generates random effect terms from simple grouping variables, for use in nonparametric mixed-effect models as described in Gu and Ma (2005a, b). The syntax of the formula resembles that of similar utilities for linear and nonlinear mixed-effect models, as described in Pinheiro and Bates (2000). Currently, \code{mkran} takes only two kinds of basic formulas, \code{~1|grp2} or \code{~grp1|grp2}. Both \code{grp1} and \code{grp2} should be factors, and for the second formula, the levels of \code{grp2} should be nested under those of \code{grp1}. The Z matrix is determined by \code{grp2}. When observations are ordered according to the levels of \code{grp2}, the Z matrix is block diagonal of 1 vectors. The Sigma matrix is diagonal. For \code{~1|grp2}, it has one tuning parameter. For \code{~grp1|grp2}, the number of parameters equals the number of levels of \code{grp1}, with each parameter shared by the \code{grp2} levels nested under the same \code{grp1} level. \code{mkran1} adds together two independent random effects, and can be used recursively to add more than two terms. The arguments are of the form of the value of \code{mkran} or \code{mkran1}, which may or may not be created by \code{mkran} or \code{mkran1}. Multiple terms of random effects can also be specified via the likes of \code{mkran(~1|grp1+1|grp2,data)}, which is equivalent to \code{mkran1(mkran(~1|grp1,data),mkran(~1|grp2,data))}. } \value{ A list of three elements. \item{z}{Z matrix.} \item{sigma}{Sigma matrix to be evaluated through \code{sigma$fun(para,sigma$env)}.} \item{init}{Initial parameter values.} } \note{ One may pass a formula or a list to the argument \code{random} in calls to \code{\link{ssanova}} or\code{\link{gssanova}} to fit nonparametric mixed-effect models. A formula will be converted to a list using \code{mkran}. A list should be of the same form as the value of \code{mkran}. } \references{ Gu, C. and Ma, P. (2005), Optimal smoothing in nonparametric mixed-effect models. \emph{The Annals of Statistics}, \bold{33}, 1357--1379. Gu, C. and Ma, P. (2005), Generalized nonparametric mixed-effect models: computation and smoothing parameter selection. \emph{Journal of Computational and Graphical Statistics}, \bold{14}, 485--504. Pinheiro and Bates (2000), \emph{Mixed-Effects Models in S and S-PLUS}. New York: Springer-Verlag. } \examples{ ## Toy data test <- data.frame(grp=as.factor(rep(1:2,c(2,3)))) ## First formula ran.test <- mkran(~1|grp,test) ran.test$z ran.test$sigma$fun(2,ran.test$sigma$env) # diag(10^(-2),2) ## Second formula ran.test <- mkran(~grp|grp,test) ran.test$z ran.test$sigma$fun(c(1,2),ran.test$sigma$env) # diag(10^(-1),10^(-2)) ## Clean up \dontrun{rm(test,ran.test)} } \keyword{internal} gss/man/summary.sscopu.Rd0000644000176200001440000000110412355360634015123 0ustar liggesusers\name{summary.sscopu} \alias{summary.sscopu} \title{Calculating Kendall's Tau and Spearman's Rho for 2-D Copula Density Estimates} \description{ Calculate Kendall's tau and Spearman's rho for 2-D copula density estimates. } \usage{ \method{summary}{sscopu}(object, ...) } \arguments{ \item{object}{Object of class \code{"sscopu"}.} \item{...}{Ignored.} } \value{ A list containing Kendall's tau and Spearman's rho. } \seealso{ Fitting functions \code{\link{sscopu}} and \code{\link{sscopu2}}. } \keyword{models} \keyword{distribution} \keyword{smooth} gss/man/mkrk.nominal.Rd0000644000176200001440000000236613653350606014526 0ustar liggesusers\name{mkrk.nominal} \alias{mkrk.nominal} \alias{mkrk.ordinal} \title{ Crafting Building Blocks for Discrete Splines } \description{ Craft numerical functions to be used by \code{mkterm} to assemble model terms involving factors. } \usage{ mkrk.nominal(levels) mkrk.ordinal(levels) } \arguments{ \item{levels}{Levels of the factor.} } \details{ For a nominal factor with levels \eqn{1,2,\dots,k}, the level means \eqn{f(i)} will be shrunk towards each other through a penalty proportional to \deqn{(f(1)-f(.))^2+\dots+(f(k)-f(.))^2} where \eqn{f(.)=(f(1)+\dots+f(k))/k}. For a ordinal factor with levels \eqn{1<2<\dots Maintainer: Chong Gu Depends: R (>= 3.0.0), stats Description: A comprehensive package for structural multivariate function estimation using smoothing splines. License: GPL (>= 2) Packaged: 2023-08-16 00:49:46 UTC; chong NeedsCompilation: yes Repository: CRAN Date/Publication: 2023-08-16 04:10:02 UTC gss/src/0000755000176200001440000000000014467016452011646 5ustar liggesusersgss/src/dmcdc.f0000644000176200001440000000450114443702023013055 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dmcdc (a, lda, p, e, jpvt, info) integer lda, p, jpvt(*), info double precision a(lda,*), e(*) double precision beta, delta, theta, tmp, dasum, ddot integer i, j, jmax, jtmp, idamax info = 0 if( lda .lt. p .or. p .lt. 1 )then info = -1 return endif tmp = 1.d0 23002 if( 1.d0 + tmp .gt. 1.d0 )then tmp = tmp / 2.d0 goto 23002 endif 23003 continue jmax = idamax (p, a, lda+1) beta = dmax1 (2.d0 * tmp, dabs (a(jmax,jmax))) tmp = dsqrt (dble (p*p-1)) if( tmp .lt. 1.d0 )then tmp = 1.d0 endif j=2 23006 if(.not.(j.le.p))goto 23008 jmax = idamax (j-1, a(1,j), 1) beta = dmax1 (beta, dabs (a(jmax,j)) / tmp) 23007 j=j+1 goto 23006 23008 continue delta = dasum (p, a, lda+1) / dble (p) * 1.d-7 delta = dmax1 (delta, 1.d-10) j=1 23009 if(.not.(j.le.p))goto 23011 jpvt(j) = j 23010 j=j+1 goto 23009 23011 continue j=1 23012 if(.not.(j.le.p))goto 23014 jmax = idamax (p-j+1, a(j,j), lda+1) + j - 1 if( jmax .ne. j )then call dswap (j-1, a(1,j), 1, a(1,jmax), 1) call dswap (jmax-j-1, a(j,j+1), lda, a(j+1,jmax), 1) call dswap (p-jmax, a(j,jmax+1), lda, a(jmax,jmax+1), lda) tmp = a(j,j) a(j,j) = a(jmax,jmax) a(jmax,jmax) = tmp jtmp = jpvt(j) jpvt(j) = jpvt(jmax) jpvt(jmax) = jtmp endif i=1 23017 if(.not.(i.lt.j))goto 23019 a(i,j) = a(i,j) / a(i,i) 23018 i=i+1 goto 23017 23019 continue i=j+1 23020 if(.not.(i.le.p))goto 23022 a(j,i) = a(j,i) - ddot (j-1, a(1,j), 1, a(1,i), 1) 23021 i=i+1 goto 23020 23022 continue if( j .eq. p )then theta = 0.d0 else jmax = idamax (p-j, a(j,j+1), lda) + j theta = dabs (a(j,jmax)) endif tmp = dmax1 (delta, dabs (a(j,j)), theta ** 2 / beta) e(j) = tmp - a(j,j) a(j,j) = tmp i=j+1 23025 if(.not.(i.le.p))goto 23027 a(i,i) = a(i,i) - a(j,i) ** 2 / a(j,j) 23026 i=i+1 goto 23025 23027 continue 23013 j=j+1 goto 23012 23014 continue j=1 23028 if(.not.(j.le.p))goto 23030 a(j,j) = dsqrt (a(j,j)) call dscal (p-j, a(j,j), a(j,j+1), lda) 23029 j=j+1 goto 23028 23030 continue return end gss/src/dsms.f0000644000176200001440000000504214443702023012752 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dsms (s, lds, nobs, nnull, jpvt, q, ldq, nlaht, sms, ld *sms, wk, info) integer lds, nobs, nnull, jpvt(*), ldq, ldsms, info double precision s(lds,*), q(ldq,*), nlaht, sms(ldsms,*), wk(2,*) double precision dum, ddot integer i, j, n, n0 info = 0 if( nnull .lt. 1 .or. nnull .ge. nobs .or. nobs .gt. lds .or. nobs * .gt. ldq .or. ldsms .lt. nnull )then info = -1 return endif n0 = nnull n = nobs - nnull call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) j=1 23002 if(.not.(j.le.n0))goto 23004 call dcopy (n, q(n0+1,j), 1, q(j,n0+1), ldq) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, q(n0+2,j), dum, q(n0+ *2,j), dum, dum, dum, 01000, info) 23003 j=j+1 goto 23002 23004 continue call dset (n, 10.d0 ** nlaht, wk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, wk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, wk(1,2), 2) call dpbfa (wk, 2, n, 1, info) if( info .ne. 0 )then info = -2 return endif j=1 23007 if(.not.(j.le.n0))goto 23009 call dpbsl (wk, 2, n, 1, q(n0+1,j)) 23008 j=j+1 goto 23007 23009 continue call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) j=1 23010 if(.not.(j.le.n0))goto 23012 call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, q(n0+2,j), q(n0+2,j), * dum, dum, dum, dum, 10000, info) 23011 j=j+1 goto 23010 23012 continue i=1 23013 if(.not.(i.le.n0))goto 23015 j=1 23016 if(.not.(j.lt.i))goto 23018 sms(i,j) = sms(j,i) 23017 j=j+1 goto 23016 23018 continue j=i 23019 if(.not.(j.le.n0))goto 23021 sms(i,j) = q(j,i) - ddot (n, q(n0+1,j), 1, q(i,n0+1), ldq) 23020 j=j+1 goto 23019 23021 continue sms(i,i) = sms(i,i) + 10.d0**nlaht 23014 i=i+1 goto 23013 23015 continue j=1 23022 if(.not.(j.le.n0))goto 23024 call dtrsl (s, lds, n0, sms(1,j), 01, info) 23023 j=j+1 goto 23022 23024 continue i=1 23025 if(.not.(i.le.n0))goto 23027 call dcopy (n0, sms(i,1), ldsms, wk, 1) call dtrsl (s, lds, n0, wk, 01, info) call dprmut (wk, n0, jpvt, 1) call dcopy (n0, wk, 1, sms(i,1), ldsms) 23026 i=i+1 goto 23025 23027 continue j=1 23028 if(.not.(j.le.n0))goto 23030 call dprmut (sms(1,j), n0, jpvt, 1) 23029 j=j+1 goto 23028 23030 continue j=1 23031 if(.not.(j.le.n0))goto 23033 call dcopy (n, q(j,n0+1), ldq, q(n0+1,j), 1) 23032 j=j+1 goto 23031 23033 continue return end gss/src/dset.f0000644000176200001440000000176414443702023012752 0ustar liggesusers subroutine dset(n,da,dx,incx) integer n,incx double precision da,dx(*) c c Purpose : set vector dx to constant da. Unrolled loops are used for c increment equal to one. c c On Entry: c n length of dx c da any constant c incx increment for dx c c On Exit: c dx(n) vector with all n entries set to da c c $Header: dset.f,v 2.1 86/04/08 14:06:25 lindstrom Exp $ c integer i,m,mp1,nincx c if(n.le.0)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c nincx = n*incx do 10 i = 1,nincx,incx dx(i) = da 10 continue return c c code for increment equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m dx(i) = da 30 continue if( n .lt. 5 ) return 40 mp1 = m + 1 do 50 i = mp1,n,5 dx(i) = da dx(i + 1) = da dx(i + 2) = da dx(i + 3) = da dx(i + 4) = da 50 continue return end gss/src/dcore.f0000644000176200001440000000442214443702023013101 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dcore (vmu, q, ldq, nobs, nnull, tol, z, job, limnla, n *laht, score, varht, info, twk, work) character vmu integer ldq, nobs, nnull, job, info double precision q(ldq,*), tol, z(*), limnla(2), nlaht, score(*), *varht, twk(2,*), work(*) double precision dum, low, upp, dasum, mchpr integer n0, n, j info = 0 if( vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u' )then info = -3 return endif if( nnull .lt. 1 .or. nobs .le. nnull .or. nobs .gt. ldq )then info = -1 return endif n0 = nnull n = nobs - nnull call dsytr (q(n0+1,n0+1), ldq, n, tol, info, work) if( info .ne. 0 )then return endif call dcopy (n-2, q(n0+2,n0+1), ldq+1, work, 1) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, work, z(n0+2), dum, z(n0+ *2), dum, dum, dum, 01000, info) if( job .eq. 0 )then mchpr = 1.d0 23008 if( 1.d0 + mchpr .gt. 1.d0 )then mchpr = mchpr / 2.d0 goto 23008 endif 23009 continue mchpr = mchpr * 2.d0 limnla(2) = dmax1 (dasum (n, q(n0+1,n0+1), ldq+1) * 1.d2, mchpr) limnla(1) = limnla(2) * mchpr limnla(2) = dlog10 (limnla(2)) limnla(1) = dlog10 (limnla(1)) endif low = limnla(1) upp = limnla(2) if( job .le. 0 )then call dgold (vmu, q(n0+1,n0+1), ldq, n, z(n0+1), low, upp, nlaht, s *core(1), varht, info, twk, work) if( vmu .eq. 'v' )then score(1) = score(1) * dble (nobs) / dble (n) endif if( vmu .eq. 'm' )then score(1) = score(1) * dble (n) / dble (nobs) endif if( vmu .eq. 'u' )then score(1) = score(1) * dble (n) / dble (nobs) + 2.d0 * varht endif else call deval (vmu, q(n0+1,n0+1), ldq, n, z(n0+1), job, low, upp, nla *ht, score, varht, info, twk, work) dum = dble (nobs) / dble (n) j=1 23018 if(.not.(j.le.job+1))goto 23020 if( vmu .eq. 'v' )then score(j) = score(j) * dum endif if( vmu .eq. 'm' )then score(j) = score(j) / dum endif if( vmu .eq. 'u' )then score(j) = score(j) / dum + 2.d0 * varht endif 23019 j=j+1 goto 23018 23020 continue endif return end gss/src/cdennewton10.f0000644000176200001440000001577714466752201014341 0ustar liggesusersC Output from Public domain Ratfor, version 1.04 subroutine cdennewton10 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, *intrs, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), cntsum, cnt(*), intr *s(*), prec, mchpr, wk(*) integer iwt, imu, iv, icdnew, iwtnew, iwk iwt = 1 imu = iwt + nobs iv = imu + nxis icdnew = iv + nxis*nxis iwtnew = icdnew + nxis iwk = iwtnew + nobs call cdennewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, intrs *, prec, maxiter, mchpr, wk(iwt), wk(imu), wk(iv), jpvt, wk(icdnew) *, wk(iwtnew), wk(iwk), info) return end subroutine cdennewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, * intrs, prec, maxiter, mchpr, wt, mu, v, jpvt, cdnew, wtnew, wk, i *nfo) integer nxis, nxi, nobs, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), cntsum, cnt(*), intr *s(*), prec, mchpr, wt(*), mu(*), v(nxis,*), cdnew(*), wtnew(*), wk *(*) integer i, j, k, iter, flag, rkv, idamax, infowk double precision tmp, ddot, dasum, wtsum, lkhd, mumax, wtsumnew, l *khdnew, disc, disc0 info = 0 i=1 23000 if(.not.(i.le.nobs))goto 23002 tmp = ddot (nxis, rs(i,1), nobs, cd, 1) wt(i) = dexp (-tmp) if(cntsum.gt.0.d0)then wt(i) = wt(i) * cnt(i) endif 23001 i=i+1 goto 23000 23002 continue wtsum = dasum (nobs, wt, 1) lkhd = dlog (wtsum) + ddot (nxis, intrs, 1, cd, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = lkhd + ddot (nxi, cd, 1, wk, 1) / 2.d0 call dscal (nobs, 1.d0/wtsum, wt, 1) iter = 0 flag = 0 23005 continue iter = iter + 1 i=1 23008 if(.not.(i.le.nxis))goto 23010 mu(i) = ddot (nobs, wt, 1, rs(1,i), 1) 23009 i=i+1 goto 23008 23010 continue i=1 23011 if(.not.(i.le.nxis))goto 23013 j=i 23014 if(.not.(j.le.nxis))goto 23016 v(i,j) = 0.d0 k=1 23017 if(.not.(k.le.nobs))goto 23019 v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) 23018 k=k+1 goto 23017 23019 continue v(i,j) = v(i,j) - mu(i) * mu(j) if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23015 j=j+1 goto 23014 23016 continue 23012 i=i+1 goto 23011 23013 continue call daxpy (nxis, -1.d0, intrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23022 if(.not.(i.le.nxis))goto 23024 jpvt(i) = 0 23023 i=i+1 goto 23022 23024 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23025 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23025 endif 23026 continue i=rkv+1 23027 if(.not.(i.le.nxis))goto 23029 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23028 i=i+1 goto 23027 23029 continue 23030 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) i=1 23033 if(.not.(i.le.nobs))goto 23035 tmp = ddot (nxis, rs(i,1), nobs, cdnew, 1) if(-tmp.gt.3.d2)then flag = flag + 1 goto 23035 endif wtnew(i) = dexp (-tmp) if(cntsum.gt.0.d0)then wtnew(i) = wtnew(i) * cnt(i) endif 23034 i=i+1 goto 23033 23035 continue wtsumnew = dasum (nobs, wtnew, 1) lkhdnew = dlog (wtsumnew) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 call dscal (nobs, 1.d0/wtsumnew, wtnew, 1) if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) if(cntsum.gt.0.d0)then i=1 23044 if(.not.(i.le.nobs))goto 23046 wt(i) = cnt(i) 23045 i=i+1 goto 23044 23046 continue else call dset (nobs, 1.d0, wt, 1) endif wtsum = dasum (nobs, wt, 1) lkhd = dlog (wtsum) call dscal (nobs, 1.d0/wtsum, wt, 1) iter = 0 goto 23032 endif if(flag.eq.3)then goto 23032 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23032 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax)).lt.1.d1*mchpr)then goto 23032 endif 23031 goto 23030 23032 continue if(flag.eq.1)then flag = 2 goto 23006 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 i=1 23057 if(.not.(i.le.nobs))goto 23059 disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) 23058 i=i+1 goto 23057 23059 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1 *.d0+dabs(lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nobs, wtnew, 1, wt, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23007 endif if(disc.lt.prec)then goto 23007 endif if(iter.lt.maxiter)then goto 23006 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) if(cntsum.gt.0.d0)then i=1 23070 if(.not.(i.le.nobs))goto 23072 wt(i) = cnt(i) 23071 i=i+1 goto 23070 23072 continue else call dset (nobs, 1.d0, wt, 1) endif wtsum = dasum (nobs, wt, 1) lkhd = dlog (wtsum) call dscal (nobs, 1.d0/wtsum, wt, 1) iter = 0 flag = 2 else info = 2 goto 23007 endif 23006 goto 23005 23007 continue i=1 23073 if(.not.(i.le.nxis))goto 23075 j=i 23076 if(.not.(j.le.nxis))goto 23078 v(i,j) = 0.d0 k=1 23079 if(.not.(k.le.nobs))goto 23081 v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) 23080 k=k+1 goto 23079 23081 continue if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23077 j=j+1 goto 23076 23078 continue 23074 i=i+1 goto 23073 23075 continue i=1 23084 if(.not.(i.le.nxis))goto 23086 jpvt(i) = 0 23085 i=i+1 goto 23084 23086 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23087 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23087 endif 23088 continue i=rkv+1 23089 if(.not.(i.le.nxis))goto 23091 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23090 i=i+1 goto 23089 23091 continue i=1 23092 if(.not.(i.le.nobs))goto 23094 call dcopy (nxis, rs(i,1), nobs, wk, 1) call dprmut (wk, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, wk, 11, infowk) call dset (nxis-rkv, 0.d0, wk(rkv+1), 1) wtnew(i) = wt(i) * ddot (nxis, wk, 1, wk, 1) if(cntsum.gt.0.d0)then wtnew(i) = wtnew(i) / cnt(i) endif 23093 i=i+1 goto 23092 23094 continue call dcopy (nobs, wtnew, 1, wt, 1) return end gss/src/dcoef.f0000644000176200001440000000263114456760274013105 0ustar liggesusersC Output from Public domain Ratfor, version 1.04 subroutine dcoef (s, lds, nobs, nnull, qraux, jpvt, z, q, ldq, nla *ht, c, d, info, twk) integer lds, nobs, nnull, jpvt(*), ldq, info double precision s(lds,*), qraux(*), z(*), q(ldq,*), nlaht, c(*), *d(*), twk(2,*) double precision dum, ddot integer n, n0, j info = 0 if( nnull .lt. 1 .or. nnull .ge. nobs .or. nobs .gt. lds .or. nobs * .gt. ldq )then info = -1 return endif n0 = nnull n = nobs - nnull call dset (n, 10.d0 ** nlaht, twk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, twk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, twk(1,2), 2) call dpbfa (twk, 2, n, 1, info) if( info .ne. 0 )then info = -2 return endif call dpbsl (twk, 2, n, 1, z(n0+1)) call dcopy (n-2, q(n0+2,n0+1), ldq+1, twk, 1) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, twk, z(n0+2), z(n0+2), du *m, dum, dum, dum, 10000, info) call dset (n0, 0.d0, c, 1) call dcopy (n, z(n0+1), 1, c(n0+1), 1) call dqrsl (s, lds, nobs, nnull, qraux, c, c, dum, dum, dum, dum, *10000, info) j=1 23004 if(.not.(j.le.n0))goto 23006 d(j) = z(j) - ddot (n, z(n0+1), 1, q(n0+1,j), 1) 23005 j=j+1 goto 23004 23006 continue call dtrsl (s, lds, n0, d, 01, info) call dprmut (d, n0, jpvt, 1) return end gss/src/dgold.f0000644000176200001440000000522114443702023013074 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dgold (vmu, q, ldq, n, z, low, upp, nlaht, score, varht *, info, twk, work) character vmu integer ldq, n, info double precision q(ldq,*), z(*), low, upp, nlaht, score, varht, tw *k(2,*), work(*) double precision ratio, mlo, mup, tmpl, tmpu ratio = ( dsqrt (5.d0) - 1.d0 ) / 2.d0 info = 0 if( upp .lt. low )then mlo = low low = upp upp = mlo endif if( vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u' )then info = -3 return endif if( n .lt. 1 .or. n .gt. ldq )then info = -1 return endif mlo = upp - ratio * (upp - low) call dset (n, 10.d0 ** (mlo), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mlo call dtrev (vmu, twk, 2, n, z, tmpl, varht, info, work) if( info .ne. 0 )then info = -2 return endif mup = low + ratio * (upp - low) call dset (n, 10.d0 ** (mup), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mup call dtrev (vmu, twk, 2, n, z, tmpu, varht, info, work) if( info .ne. 0 )then info = -2 return endif 23010 continue if( mup - mlo .lt. 1.d-7 )then goto 23012 endif if( tmpl .lt. tmpu )then upp = mup mup = mlo tmpu = tmpl mlo = upp - ratio * (upp - low) call dset (n, 10.d0 ** (mlo), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mlo call dtrev (vmu, twk, 2, n, z, tmpl, varht, info, work) if( info .ne. 0 )then info = -2 return endif else low = mlo mlo = mup tmpl = tmpu mup = low + ratio * (upp - low) call dset (n, 10.d0 ** (mup), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mup call dtrev (vmu, twk, 2, n, z, tmpu, varht, info, work) if( info .ne. 0 )then info = -2 return endif endif 23011 goto 23010 23012 continue nlaht = ( mup + mlo ) / 2.d0 call dset (n, 10.d0 ** (nlaht), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**nlaht call dtrev (vmu, twk, 2, n, z, score, varht, info, work) if( info .ne. 0 )then info = -2 return endif return end gss/src/ratfor/0000755000176200001440000000000014467014013013132 5ustar liggesusersgss/src/ratfor/dqrslm.r0000644000176200001440000000544014443702062014624 0ustar liggesusers #:::::::::::: # dqrslm #:::::::::::: subroutine dqrslm (x, ldx, n, k, qraux, a, lda, job, info, work) # Acronym: `dqrsl' Matrix version # Purpose: This routine generates the matrix Q^{T}AQ or QAQ^{T}, where # Q is the products of Householder matrix stored in factored form in # the LOWER triangle of `x' and `qraux', and A is assumed to be # symmetric. This routine is designed to be compatible with LINPACK's # `dqrdc' subroutine. # References: 1. Dongarra et al. (1979) LINPACK Users' Guide. (chap. 9) # 2. Golud and Van Loan (1983) Matrix Computation. (pp.276-7) integer ldx, n, k, lda, job, info double precision x(ldx,*), qraux(*), a(lda,*), work(*) # On entry: # x output from `dqrdc', of size (ldx,k). # ldx leading dimension of x. # n size of matrix A and Q. # k number of factors in Q. # qraux output from `dqrdc'. # a matrix A (of size (lda,n)), only LOWER triangle refered. # lda leading dimension of a. # job 0: Q^{T} A Q. # 1: Q A Q^{T}. # On Exit: # a matrix Q^{T}AQ or QAQ^{T} in LOWER triangle. # info 0: normal termination. # 1: `job' is out of scope. # -1: dimension error. # others unchanged. # Work array: # work of size at least (n). # Routines called: # Blas -- ddot, daxpy # Blas2 -- dsymv, dsyr2 # Written: Chong Gu, Statistics, UW-Madison, latest version 8/29/88. double precision tmp, alph, ddot integer i, j, step info = 0 # check input if ( lda < n | n < k | k < 1 ) { info = -1 return } if ( job != 0 & job != 1 ) { info = 1 return } # set operation sequence if ( job == 0 ) { j = 1 step = 1 } else { j = k step = -1 } # main process while ( j >= 1 & j <= k ) { if ( qraux(j) == 0.0d0 ) { j = j + step next } tmp = x(j,j) x(j,j) = qraux(j) # update the columns 1 thru j-1 for (i=1;i0.d0)) { for (j=1;j<=nobs;j=j+1) mrs(i) = mrs(i) + rs(i,j) mrs(i) = mrs(i) / dble (nobs) } else { for (j=1;j<=nobs;j=j+1) mrs(i) = mrs(i) + rs(i,j) * cnt(j) mrs(i) = mrs(i) / cntsum } } if (!(cntsum>0.d0)) trc = 1.d0 / dble (nobs) else trc = 1.d0 / cntsum # Initialization norm = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { wtsum(kk) = 0.d0 for (i=1;i<=nqd;i=i+1) { wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) * qdwt(i) wtsum(kk) = wtsum(kk) + wt(i,kk) } norm = norm + xxwt(kk) * dlog (wtsum(kk)) } fitmean = 0.d0 for (i=1;i<=nobs;i=i+1) { tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if (cntsum>0.d0) tmp = tmp * cnt(i) fitmean = fitmean + tmp } call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean * trc + norm iter = 0 flag = 0 # Iteration repeat { iter = iter + 1 # Calculate hessian and gradient call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nxis;i=i+1) muwk(i) = - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) / wtsum(kk) for (i=1;i<=nxis;i=i+1) { for (j=i;j<=nxis;j=j+1) { vwk(i,j) = 0.d0 for (k=1;k<=nqd;k=k+1) vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) vwk(i,j) = vwk(i,j) / wtsum(kk) - muwk(i) * muwk(j) } } call daxpy (nxis, xxwt(kk), muwk, 1, mu, 1) call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) } for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) v(i,j) = v(i,j) + q(i,j) } call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) while (v(rkv,rkv)3.d2) { flag = flag + 1 break } fitnew(i) = dexp (tmp) if (cntsum>0.d0) tmp = tmp * cnt(i) fitmean = fitmean + tmp } call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean * trc + norm } # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) for (kk=1;kk<=nx;kk=kk+1) call dcopy (nqd, qdwt, 1, wt(1,kk), 1) tmp = 0.d0 for (i=1;i<=nqd;i=i+1) tmp = tmp + qdwt(i) call dset (nx, tmp, wtsum, 1) call dset (nobs, 1.d0, fit, 1) lkhd = 0.d0 iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk)))) } for (i=1;i<=nobs;i=i+1) disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nx, wtnewsum, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew # Check convergence if (disc00.d0) call dscal (nxis, dsqrt(cnt(i)), rs(1,i), 1) call dtrsl (v, nxis, nxis, rs(1,i), 11, infowk) } trc = ddot (nobs*nxis, rs, 1, rs, 1) if (!(cntsum>0.d0)) { trc = trc / dble(nobs) / (dble(nobs)-1.d0) lkhd = 0.d0 for (i=1;i<=nobs;i=i+1) lkhd = lkhd + dlog (fit(i)) lkhd = lkhd / dble (nobs) } else { trc = trc / cntsum / (cntsum-1.d0) lkhd = 0.d0 for (i=1;i<=nobs;i=i+1) lkhd = lkhd + cnt(i) * dlog (fit(i)) lkhd = lkhd / cntsum } for (kk=1;kk<=nx;kk=kk+1) lkhd = lkhd - xxwt(kk) * dlog (wtsum(kk)) wtsum(1) = lkhd wtsum(2) = trc return end #::::::::::::: # llrmaux #::::::::::::: subroutine llrmaux (cd, nxis, q, nxi, qdrs, nqd, nx, xxwt, qdwt, mchpr, wt, wtsum, mu, v, vwk, jpvt) integer nxis, nxi, nqd, nx, jpvt(*) double precision cd(*), q(nxi,*), qdrs(nqd,nxis,*), xxwt(*), qdwt(*), mchpr, wt(nqd,*), wtsum(*), mu(*), v(nxis,*), vwk(nxis,*) integer i, j, k, kk, rkv double precision ddot # Initialization for (kk=1;kk<=nx;kk=kk+1) { wtsum(kk) = 0.d0 for (i=1;i<=nqd;i=i+1) { wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) * qdwt(i) wtsum(kk) = wtsum(kk) + wt(i,kk) } } # H matrix call dset (nxis*nxis, 0.d0, v, 1) for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nxis;i=i+1) mu(i) = ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) / wtsum(kk) for (i=1;i<=nxis;i=i+1) { for (j=i;j<=nxis;j=j+1) { vwk(i,j) = 0.d0 for (k=1;k<=nqd;k=k+1) vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) vwk(i,j) = vwk(i,j) / wtsum(kk) - mu(i) * mu(j) } } call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) } for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) v(i,j) = v(i,j) + q(i,j) } # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, vwk, jpvt, 1, rkv) while (v(rkv,rkv)3.d2) { flag = flag + 1 break } for (m=1;m<=nt;m=m+1) { wtnew(m,i) = qdwt(m,i) * dexp (tmp) wtnewsum(m) = wtnewsum(m) + wtnew(m,i) } } rklnew = 0.d0 for (m=1;m<=nt;m=m+1) { tmp = 0.d0 for (i=1;i<=nqd;i=i+1) { disc = wt0(i) * qdwt(m,i) tmp = tmp + dlog (disc/wtnew(m,i)) * disc } rklnew = rklnew + bwt(m) * (tmp + dlog (wtnewsum(m))) } if (flag==1) { # Reset iteration with uniform starting value call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) call dset (nt, 0.d0, wtsum, 1) for (m=1;m<=nt;m=m+1) { for (i=1;i<=nqd;i=i+1) wtsum(m) = wtsum(m) + wt(m,i) } rkl = 0.d0 for (m=1;m<=nt;m=m+1) { tmp = 0.d0 for (i=1;i<=nqd;i=i+1) tmp = tmp + dlog (wt0(i)) * wt0(i) * qdwt(m,i) rkl = rkl + bwt(m) * (tmp + dlog (wtsum(m))) } iter = 0 break } if (rklnew-rkl<1.d1*(1.d0+dabs(rkl))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (i=1;i<=nqd;i=i+1){ for (m=1;m<=nt;m=m+1) disc = dmax1 (disc, dabs(wt(m,i)-wtnew(m,i))/(1.d0+dabs(wt(m,i)))) } disc = dmax1 (disc, (mumax/(1.d0+rkl))**2) disc = dmax1 (disc, dabs(rkl-rklnew)/(1.d0+dabs(rkl))) # Check convergence if (disc0.d0)) { for (j=1;j<=nobs;j=j+1) mrs(i) = mrs(i) + rs(i,j) mrs(i) = mrs(i) / dble (nobs) } else { for (j=1;j<=nobs;j=j+1) mrs(i) = mrs(i) + rs(i,j) * cnt(j) mrs(i) = mrs(i) / cntsum } } if (!(cntsum>0.d0)) trc = 1.d0 / dble (nobs) else trc = 1.d0 / cntsum # Initialization norm = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { wtsum(kk) = 0.d0 for (i=1;i<=nqd;i=i+1) { wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) * qdwt(i) wtsum(kk) = wtsum(kk) + wt(i,kk) } norm = norm + xxwt(kk) * dlog (wtsum(kk)) } fitmean = 0.d0 for (i=1;i<=nobs;i=i+1) { tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if (cntsum>0.d0) tmp = tmp * cnt(i) fitmean = fitmean + tmp } call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean * trc + norm iter = 0 flag = 0 # Iteration repeat { iter = iter + 1 # Calculate hessian and gradient call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nxis;i=i+1) muwk(i) = - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) / wtsum(kk) for (i=1;i<=nxis;i=i+1) { for (j=i;j<=nxis;j=j+1) { vwk(i,j) = 0.d0 for (k=1;k<=nqd;k=k+1) vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) vwk(i,j) = vwk(i,j) / wtsum(kk) - muwk(i) * muwk(j) } } call daxpy (nxis, xxwt(kk), muwk, 1, mu, 1) call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) } for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) v(i,j) = v(i,j) + q(i,j) } call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) while (v(rkv,rkv)3.d2) { flag = flag + 1 break } fitnew(i) = dexp (tmp) if (cntsum>0.d0) tmp = tmp * cnt(i) fitmean = fitmean + tmp } call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean * trc + norm } # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) for (kk=1;kk<=nx;kk=kk+1) call dcopy (nqd, qdwt, 1, wt(1,kk), 1) call dset (nx, 1.d0, wtsum, 1) call dset (nobs, 1.d0, fit, 1) lkhd = 0.d0 iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk)))) } for (i=1;i<=nobs;i=i+1) disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nx, wtnewsum, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew # Check convergence if (disc00.d0) call dscal (nxis, dsqrt(cnt(i)), rs(1,i), 1) call dtrsl (v, nxis, nxis, rs(1,i), 11, infowk) } trc = ddot (nobs*nxis, rs, 1, rs, 1) if (!(cntsum>0.d0)) { trc = trc / dble(nobs) / (dble(nobs)-1.d0) lkhd = 0.d0 for (i=1;i<=nobs;i=i+1) lkhd = lkhd + dlog (fit(i)) lkhd = lkhd / dble (nobs) } else { trc = trc / cntsum / (cntsum-1.d0) lkhd = 0.d0 for (i=1;i<=nobs;i=i+1) lkhd = lkhd + cnt(i) * dlog (fit(i)) lkhd = lkhd / cntsum } for (kk=1;kk<=nx;kk=kk+1) lkhd = lkhd - xxwt(kk) * dlog (wtsum(kk)) wtsum(1) = lkhd wtsum(2) = trc return end #:::::::::::: # cdenrkl #:::::::::::: subroutine cdenrkl (cd, nxis, qdrs, nqd, nx, xxwt, qdwt, wt0, mchpr, wt, wtnew, mu, muwk, v, vwk, jpvt, cdnew, prec, maxiter, info) integer nxis, nqd, nx, jpvt(*), maxiter, info double precision cd(*), qdrs(nqd,nxis,*), xxwt(*), qdwt(*), wt0(nqd,*), mchpr, wt(nqd,*), wtnew(nqd,*), mu(*), muwk(*), v(nxis,*), vwk(nxis,*), cdnew(*), prec integer i, j, k, kk, iter, flag, idamax, infowk double precision ddot, dasum, rkl, tmp, mumax, rklnew, disc, disc0 # Initialization for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) { wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) * qdwt(i) } call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) } rkl = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { tmp = 0.d0 for (i=1;i<=nqd;i=i+1) tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) rkl = rkl + xxwt(kk) * tmp } iter = 0 flag = 0 # Iteration repeat { iter = iter + 1 # Calculate hessian and gradient call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nxis;i=i+1) muwk(i) = ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) for (i=1;i<=nxis;i=i+1) { for (j=i;j<=nxis;j=j+1) { vwk(i,j) = 0.d0 for (k=1;k<=nqd;k=k+1) vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) vwk(i,j) = vwk(i,j) - muwk(i) * muwk(j) } muwk(i) = ddot (nqd, wt0(1,kk), 1, qdrs(1,i,kk), 1) - muwk(i) } call daxpy (nxis, xxwt(kk), muwk, 1, mu, 1) call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) } mumax = dabs(mu(idamax(nxis, mu, 1))) # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dmcdc (v, nxis, nxis, cdnew, jpvt, infowk) # Update coefficients repeat { call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) { wtnew(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1)) * qdwt(i) } call dscal (nqd, 1.d0/dasum(nqd,wtnew(1,kk),1), wtnew(1,kk), 1) } if ((flag==0)|(flag==2)) { rklnew = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { tmp = 0.d0 for (i=1;i<=nqd;i=i+1) tmp = tmp + dlog(wt0(i,kk)/wtnew(i,kk)) * wt0(i,kk) rklnew = rklnew + xxwt(kk) * tmp } } # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) for (kk=1;kk<=nx;kk=kk+1) { call dcopy (nqd, qdwt, 1, wt(1,kk), 1) call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) } rkl = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { tmp = 0.d0 for (i=1;i<=nqd;i=i+1) tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) rkl = rkl + xxwt(kk) * tmp } iter = 0 break } if (flag==3) break if (rklnew-rkl<1.d1*(1.d0+dabs(rkl))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk)))) } disc = dmax1 (disc, (mumax/(1.d0+dabs(rkl)))**2) disc0 = dmax1 ((mumax/(1.d0+rkl))**2, dabs(rkl-rklnew)/(1+dabs(rkl))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) rkl = rklnew # Check convergence if (disc00.d0) wt(i) = wt(i) * cnt(i) } wtsum = dasum (nobs, wt, 1) lkhd = dlog (wtsum) + ddot (nxis, intrs, 1, cd, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = lkhd + ddot (nxi, cd, 1, wk, 1) / 2.d0 call dscal (nobs, 1.d0/wtsum, wt, 1) iter = 0 flag = 0 # Iteration repeat { iter = iter + 1 # Calculate hessian and gradient for (i=1;i<=nxis;i=i+1) mu(i) = ddot (nobs, wt, 1, rs(1,i), 1) for (i=1;i<=nxis;i=i+1) { for (j=i;j<=nxis;j=j+1) { v(i,j) = 0.d0 for (k=1;k<=nobs;k=k+1) v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) v(i,j) = v(i,j) - mu(i) * mu(j) if (j<=nxi) v(i,j) = v(i,j) + q(i,j) } } call daxpy (nxis, -1.d0, intrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) while (v(rkv,rkv)3.d2) { flag = flag + 1 break } wtnew(i) = dexp (-tmp) if (cntsum>0.d0) wtnew(i) = wtnew(i) * cnt(i) } wtsumnew = dasum (nobs, wtnew, 1) lkhdnew = dlog (wtsumnew) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 call dscal (nobs, 1.d0/wtsumnew, wtnew, 1) # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) if (cntsum>0.d0) { for (i=1;i<=nobs;i=i+1) wt(i) = cnt(i) } else call dset (nobs, 1.d0, wt, 1) wtsum = dasum (nobs, wt, 1) lkhd = dlog (wtsum) call dscal (nobs, 1.d0/wtsum, wt, 1) iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax))<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (i=1;i<=nobs;i=i+1) disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1.d0+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nobs, wtnew, 1, wt, 1) lkhd = lkhdnew # Check convergence if (disc00.d0) { for (i=1;i<=nobs;i=i+1) wt(i) = cnt(i) } else call dset (nobs, 1.d0, wt, 1) wtsum = dasum (nobs, wt, 1) lkhd = dlog (wtsum) call dscal (nobs, 1.d0/wtsum, wt, 1) iter = 0 flag = 2 } else { info = 2 break } } # Calculate uncorrected v for (i=1;i<=nxis;i=i+1) { for (j=i;j<=nxis;j=j+1) { v(i,j) = 0.d0 for (k=1;k<=nobs;k=k+1) v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) if (j<=nxi) v(i,j) = v(i,j) + q(i,j) } } # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) while (v(rkv,rkv)0.d0) wtnew(i) = wtnew(i) / cnt(i) } call dcopy (nobs, wtnew, 1, wt, 1) return end gss/src/ratfor/hzdaux.r0000644000176200001440000001551214443702062014626 0ustar liggesusers #::::::::::::: # hzdaux1 #::::::::::::: subroutine hzdaux1 (cd, nxis, q, nxi, qdrs, nqd, qdwt, nx, mchpr, wt, v, vwk, jpvt) integer nxis, nxi, nqd, nx, jpvt(*) double precision cd(*), q(nxi,*), qdrs(nqd,nxis,*), qdwt(nqd,*), mchpr, wt(nqd,*), v(nxis,*), vwk(nxis,*) integer i, j, k, kk, rkv double precision ddot # Initialization for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) wt(i,kk) = qdwt(i,kk) * dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) } # H matrix call dset (nxis*nxis, 0.d0, v, 1) for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nxis;i=i+1) { for (j=i;j<=nxis;j=j+1) { vwk(i,j) = 0.d0 for (k=1;k<=nqd;k=k+1) vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) } } call daxpy (nxis*nxis, 1.d0, vwk, 1, v, 1) } for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) v(i,j) = v(i,j) + q(i,j) } # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, vwk, jpvt, 1, rkv) while (v(rkv,rkv)3.d2) { flag = flag + 1 break } wtnew(i,kk) = qdwt(i,kk) * dexp (tmp) rklnew = rklnew + (wtnew(i,kk) - wt0(i,kk)*tmp) } } if (flag==1) { # Reset iteration with uniform starting value call dset (nxis, 0.d0, cd, 1) rkl = dasum (nqd*nx, qdwt, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) iter = 0 break } if (rklnew-rkl<1.d1*(1.d0+dabs(rkl))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk)))) } disc = dmax1 (disc, (mumax/(1.d0+rkl))**2) disc0 = dmax1 ((mumax/(1.d0+rkl))**2, dabs(rkl-rklnew)/(1+dabs(rkl))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) rkl = rklnew # Check convergence if (disc0= nobs | nobs > lds | nobs > ldq ) { info = -1 return } # main process call dstup (s, lds, nobs, nnull, qraux, jpvt, y, q, ldq, nobs, 1, info,_ wk) if ( info != 0 ) return call dcore (vmu1, q, ldq, nobs, nnull, tol, y, job, limnla, nlaht, score,_ varht, info, wk, wk(2*nobs+1)) if ( info != 0 ) return call dcoef (s, lds, nobs, nnull, qraux, jpvt, y, q, ldq, nlaht, c, d,_ info, wk) return end gss/src/ratfor/dnewton10.r0000644000176200001440000001421214466747773015165 0ustar liggesusers #::::::::::::::: # dnewton10 #::::::::::::::: subroutine dnewton10 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, intrs, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), cntsum, cnt(*), intrs(*), prec, mchpr, wk(*) integer iwt, imu, iv, icdnew, iwtnew, iwk iwt = 1 imu = iwt + nobs iv = imu + nxis icdnew = iv + nxis*nxis iwtnew = icdnew + nxis iwk = iwtnew + nobs call dnewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, intrs, prec, maxiter, mchpr, wk(iwt), wk(imu), wk(iv), jpvt, wk(icdnew), wk(iwtnew), wk(iwk), info) return end #:::::::::::::::: # dnewton101 #:::::::::::::::: subroutine dnewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, intrs, prec, maxiter, mchpr, wt, mu, v, jpvt, cdnew, wtnew, wk, info) integer nxis, nxi, nobs, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), cntsum, cnt(*), intrs(*), prec, mchpr, wt(*), mu(*), v(nxis,*), cdnew(*), wtnew(*), wk(*) integer i, j, k, iter, flag, rkv, idamax, infowk double precision wtsum, tmp, ddot, lkhd, mumax, wtsumnew, lkhdnew, disc, disc0 # Initialization info = 0 wtsum = 0.d0 for (i=1;i<=nobs;i=i+1) { tmp = ddot (nxis, rs(i,1), nobs, cd, 1) wt(i) = dexp (-tmp) if (cntsum>0.d0) wt(i) = wt(i) * cnt(i) wtsum = wtsum + wt(i) } if (!(cntsum>0.d0)) lkhd = wtsum / dble (nobs) else lkhd = wtsum / cntsum lkhd = dlog (lkhd) + ddot (nxis, intrs, 1, cd, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = lkhd + ddot (nxi, cd, 1, wk, 1) / 2.d0 iter = 0 flag = 0 # Iteration repeat { iter = iter + 1 # Calculate hessian and gradient for (i=1;i<=nxis;i=i+1) mu(i) = ddot (nobs, wt, 1, rs(1,i), 1) / wtsum for (i=1;i<=nxis;i=i+1) { for (j=i;j<=nxis;j=j+1) { v(i,j) = 0.d0 for (k=1;k<=nobs;k=k+1) v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) v(i,j) = v(i,j) / wtsum - mu(i) * mu(j) if (j<=nxi) v(i,j) = v(i,j) + q(i,j) } } call daxpy (nxis, -1.d0, intrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) while (v(rkv,rkv)3.d2) { flag = flag + 1 break } wtnew(i) = dexp (-tmp) if (cntsum>0.d0) wtnew(i) = wtnew(i) * cnt(i) wtsumnew = wtsumnew + wtnew(i) } if (!(cntsum>0.d0)) lkhdnew = wtsumnew / dble (nobs) else lkhdnew = wtsumnew / cntsum lkhdnew = dlog (lkhdnew) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) wtsum = 0.d0 for (i=1;i<=nobs;i=i+1) { if (cntsum>0.d0) wt(i) = cnt(i) else wt(i) = 1.d0 wtsum = wtsum + wt(i) } lkhd = 0.d0 iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax))<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (i=1;i<=nobs;i=i+1) disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1.d0+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nobs, wtnew, 1, wt, 1) wtsum = wtsumnew lkhd = lkhdnew # Check convergence if (disc00.d0) wt(i) = cnt(i) else wt(i) = 1.d0 wtsum = wtsum + wt(i) } lkhd = 0.d0 iter = 0 flag = 2 } else { info = 2 break } } # Calculate uncorrected v call dscal (nobs, 1.d0/wtsum, wt, 1) for (i=1;i<=nxis;i=i+1) { for (j=i;j<=nxis;j=j+1) { v(i,j) = 0.d0 for (k=1;k<=nobs;k=k+1) v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) if (j<=nxi) v(i,j) = v(i,j) + q(i,j) } } # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) while (v(rkv,rkv)0.d0) wtnew(i) = wtnew(i) / cnt(i) } call dcopy (nobs, wtnew, 1, wt, 1) return end gss/src/ratfor/hzdnewton10.r0000644000176200001440000001512014467014013015475 0ustar liggesusers #::::::::::::::::: # hzdnewton10 #::::::::::::::::: subroutine hzdnewton10 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, intrs, rho, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nt, nobs, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nt,*), cntsum, cnt(*), intrs(*), rho(*), prec, mchpr, wk(*) integer iwt, imu, iv, icdnew, iwtnew, iwk iwt = 1 imu = iwt + nt iv = imu + nxis icdnew = iv + nxis*nxis iwtnew = icdnew + nxis iwk = iwtnew + nt call hzdnewton101 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, intrs, rho, prec, maxiter, mchpr, wk(iwt), wk(imu), wk(iv), jpvt, wk(icdnew), wk(iwtnew), wk(iwk), info) return end #:::::::::::::::::: # hzdnewton101 #:::::::::::::::::: subroutine hzdnewton101 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, intrs, rho, prec, maxiter, mchpr, wt, mu, v, jpvt, cdnew, wtnew, wk, info) integer nxis, nxi, nt, nobs, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nt,*), cntsum, cnt(*), intrs(*), rho(*), prec, mchpr, wt(*), mu(*), v(nxis,*), cdnew(*), wtnew(*), wk(*) integer i, j, k, iter, flag, rkv, idamax, infowk double precision tmp, ddot, dasum, lkhd, mumax, lkhdnew, disc, disc0 # Initialization info = 0 for (i=1;i<=nt;i=i+1) { tmp = ddot (nxis, rs(i,1), nt, cd, 1) wt(i) = dexp (-tmp) * rho(i) if (cntsum>0.d0) wt(i) = wt(i) * cnt(i) } call dscal (nt, 1/dble(nobs), wt, 1) lkhd = dasum(nt, wt, 1) + ddot (nxis, intrs, 1, cd, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = lkhd + ddot (nxi, cd, 1, wk, 1) / 2.d0 iter = 0 flag = 0 # Iteration repeat { iter = iter + 1 # Calculate hessian and gradient for (i=1;i<=nxis;i=i+1) { mu(i) = ddot (nt, wt, 1, rs(1,i), 1) for (j=i;j<=nxis;j=j+1) { v(i,j) = 0.d0 for (k=1;k<=nt;k=k+1) v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) if (j<=nxi) v(i,j) = v(i,j) + q(i,j) } } call daxpy (nxis, -1.d0, intrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) while (v(rkv,rkv)3.d2) { flag = flag + 1 break } wtnew(i) = dexp (-tmp) * rho(i) if (cntsum>0.d0) wtnew(i) = wtnew(i) * cnt(i) } call dscal (nt, 1/dble(nobs), wtnew, 1) lkhdnew = dasum(nt, wtnew, 1) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) for (i=1;i<=nt;i=i+1) { wt(i) = rho(i) if (cntsum>0.d0) wt(i) = wt(i) * cnt(i) } call dscal (nt, 1/dble(nobs), wt, 1) lkhd = dasum (nt, wt, 1) iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax))<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (i=1;i<=nt;i=i+1) disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1.d0+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nt, wtnew, 1, wt, 1) lkhd = lkhdnew # Check convergence if (disc00.d0) wt(i) = wt(i) * cnt(i) } call dscal (nt, 1/dble(nobs), wt, 1) lkhd = dasum (nt, wt, 1) iter = 0 flag = 2 } else { info = 2 break } } # Calculate proxy loss lkhd = dasum (nt, wt, 1) + ddot (nxis, intrs, 1, cd, 1) tmp = 0.d0 disc = 0.d0 for (i=1;i<=nt;i=i+1) { call dcopy (nxis, rs(i,1), nt, wk, 1) call dprmut (wk, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, wk, 11, infowk) call dset (nxis-rkv, 0.d0, wk(rkv+1), 1) wtnew(i) = wt(i) * ddot (nxis, wk, 1, wk, 1) if (cntsum>0.d0) wtnew(i) = wtnew(i) / cnt(i) tmp = tmp + wt(i) * (dexp (wtnew(i)/(1.d0-wtnew(i))) - 1.d0) # tmp = tmp + wt(i) * (1.d0/(1.d0-wtnew(i))**2-1.d0)/2.d0 if (cntsum>0.d0) disc = disc + cnt(i) * wtnew(i)/(1.d0-wtnew(i)) else disc = disc + wtnew(i)/(1.d0-wtnew(i)) } wt(1) = lkhd wt(2) = tmp wt(3) = disc/dble(nobs) return end #::::::::::::::: # hzdaux101 #::::::::::::::: subroutine hzdaux101 (cd, nxis, q, nxi, rs, nt, rho, mchpr, v, jpvt) integer nxis, nxi, nt, jpvt(*) double precision cd(*), q(nxi,*), rs(nt,*), rho(*), mchpr, v(nxis,*) integer i, j, k, rkv double precision tmp, ddot # Initialization for (i=1;i<=nt;i=i+1) { tmp = ddot (nxis, rs(i,1), nt, cd, 1) rho(i) = dexp (-tmp) * rho(i) } # H matrix for (i=1;i<=nxis;i=i+1) { for (j=i;j<=nxis;j=j+1) { v(i,j) = 0.d0 for (k=1;k<=nt;k=k+1) v(i,j) = v(i,j) + rho(k) * rs(k,i) * rs(k,j) if (j<=nxi) v(i,j) = v(i,j) + q(i,j) } } # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, cd, jpvt, 1, rkv) while (v(rkv,rkv)0.d0)) mrs(i) = mrs(i) + rs(i,j) else mrs(i) = mrs(i) + rs(i,j) * cnt(j) } mrs(i) = mrs(i) / dble (nobs) } # Initialization for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) wt(i,kk) = qdwt(i,kk) * dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) } fitmean = 0.d0 for (i=1;i<=nt;i=i+1) { tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if (cntsum>0.d0) tmp = tmp * cnt(i) fitmean = fitmean + tmp } fitmean = fitmean / dble (nobs) - dasum (nqd*nx, wt, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean iter = 0 flag = 0 # Iteration repeat { iter = iter + 1 # Calculate hessian and gradient call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nxis;i=i+1) { muwk(i) = - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) for (j=i;j<=nxis;j=j+1) { vwk(i,j) = 0.d0 for (k=1;k<=nqd;k=k+1) vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) } } call daxpy (nxis, 1.d0, muwk, 1, mu, 1) call daxpy (nxis*nxis, 1.d0, vwk, 1, v, 1) } for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) v(i,j) = v(i,j) + q(i,j) } call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) while (v(rkv,rkv)3.d2) { flag = flag + 1 break } wtnew(i,kk) = qdwt(i,kk) * dexp (tmp) } if ((flag==1)|(flag==3)) break } if ((flag==0)|(flag==2)) { fitmean = 0.d0 for (i=1;i<=nt;i=i+1) { tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if (tmp>3.d2) { flag = flag + 1 break } fitnew(i) = dexp (tmp) if (cntsum>0.d0) tmp = tmp * cnt(i) fitmean = fitmean + tmp } fitmean = fitmean / dble (nobs) - dasum (nqd*nx, wtnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean } # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) fitmean = - dasum (nqd*nx, wt, 1) lkhd = - fitmean iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk)))) } for (i=1;i<=nt;i=i+1) disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1.d0+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nt, fitnew, 1, fit, 1) lkhd = lkhdnew # Check convergence if (disc00.d0) call dscal (nxis, dsqrt(cnt(i)), rs(1,i), 1) call dtrsl (v, nxis, nxis, rs(1,i), 11, infowk) } call dprmut (mrs, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, mrs, 11, infowk) trc = ddot (nxis*nt, rs, 1, rs, 1) - dble (nobs) * ddot (nxis, mrs, 1, mrs, 1) trc = trc / dble(nobs) / (dble(nobs)-1.d0) mrs(1) = fitmean mrs(2) = trc for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) } return end gss/src/ratfor/deval.r0000644000176200001440000000524014443702062014413 0ustar liggesusers #::::::::::: # deval #::::::::::: subroutine deval (vmu, q, ldq, n, z, nint, low, upp, nlaht, score, varht,_ info, twk, work) # Purpose: To evaluate GCV/GML function based on tridiagonal form and to # search minimum on an interval by equally spaced (in log10 scale) grid # search. character*1 vmu integer ldq, n, nint, info double precision q(ldq,*), z(*), low, upp, nlaht, score(*), varht,_ twk(2,*), work(*) # On entry: # vmu 'v': GCV criterion. # 'm': GML criterion. # 'u': unbiased risk estimate. # q tidiagonal matrix in diagonal and super diagonal. # ldq leading dimension of Q. # n size of the matrix. # z U^{T} F_{2}^{T} y. # nint number of intervals (number of grids minus 1). # low lower limit of log10(n*lambda). # upp upper limit of log10(n*lambda). # varht known variance if vmu=='u'. # On exit: # nlaht the estimated log10(n*lambda). # score the GCV/GML/URE score vector on grid points. # varht the variance estimate at the estimated n*lambda. # info 0: normal termination. # -1: dimension error. # -2: tridiagonal form is not non-negative definite. # -3: vmu or nint is out of scope. # Work arrays: # twk array of length at least (2,n). # work array of length at least (n). # Routines called directly: # Fortran -- dble # Blas -- daxpy, dcopy # Rkpack -- dtrev # Other -- dset # Written: Chong Gu, Statistics, Purdue, 12/29/91 latest version. double precision tmp, minscr, mlo, varhtwk integer j info = 0 # interchange boundaries if necessary if ( upp < low ) { mlo = low low = upp upp = mlo } # check job requests if ( (vmu != 'v' & vmu != 'm' & vmu != 'u') | nint < 1 ) { info = -3 return } # check dimension if ( 1 > n | n > ldq ) { info = -1 return } # evaluation for (j=1;j<=nint+1;j=j+1) { tmp = low + dble (j-1) * ( upp - low ) / dble (nint) call dset (n, 10.d0 ** (tmp), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**tmp call dtrev (vmu, twk, 2, n, z, score(j), varht, info, work) if ( info != 0 ) { info = -2 return } if ( score(j) <= minscr | j == 1 ) { minscr = score(j) nlaht = tmp varhtwk = varht } } varht = varhtwk return end #............................................................................... gss/src/ratfor/dsytr.r0000644000176200001440000001012414443702062014462 0ustar liggesusers #::::::::::: # dsytr #::::::::::: subroutine dsytr (x, ldx, n, tol, info, work) # Acronym: Double-precision SYmmetric matrix TRidiagonalization. # Purpose: This routine performs the Householder tridiagonalization # algorithm on symmetric matrix `x', with truncation strategy as # described in Gu, Bates, Chen, and Wahba (1988). # References: 1. Golud and Van Loan (1983) Matrix Computation. (pp.276-7) # 2. Gu, Bates, Chen, and Wahba(1988), TR#823, Stat, UW-M. # 3. Dongarra et al.(1979) LINPACK User's Guide. (Chap. 9) # Relation with LINPACK: This routine computes the tridiagonalization # U^{T}XU=T, where X is symmetric, T is tridiagonal, and U is an # orthogonal matrix as the product of Housholder matrices. To compute # U^{T}y or Uy for vector y, we can use routine `dqrsl' of LINPACK. # The calling procedure is: # # 1. Create vector `qraux' by # call dcopy(n-2, x(2,1), ldx+1, qraux, 1) # 2. Call `dqrsl' as # call dqrsl (x(2,1), ldx, n-1, n-2, qraux, y(2), ... ) integer ldx, n, info double precision x(ldx,*), tol, work(*) # On entry: # x symmetric matrix, only LOWER triangle refered. # ldx leading dimension of x. # n size of matrix `x'. # tol truncation tolarence; if zero, set to square machine # precision. # On Exit: # x diagonal: diagonal elements of tridiag. transf. # upper triangle: off-diagonal of tridiag. transf. # lower triangle: overwritten by Householder factors. # info 0 : normal termination. # -1 : dimension error. # Work array: # work of size at least (n). # Routines called directly: # Fortran -- dble, dsqrt # Blas -- daxpy, ddot, dscal # Blas2 -- dsymv, dsyr2 # Written: Chong Gu, Statistics, UW-Madison, latest version 8/29/88. double precision nrmtot, nrmxj, alph, toltot, tolcum, toluni, dn, ddot integer j info = 0 # check dimension if ( ldx < n | n <= 2 ) { info = -1 return } # total Frobenius norm nrmtot = ddot (n, x, ldx+1, x, ldx+1) for ( j=1 ; j 1.d0 ) toltot = toltot / 2.d0 toltot = 4.d0 * toltot ** 2 # set truncation criterion if ( toltot < tol ) toltot = tol toltot = toltot * nrmtot dn = dble (n) toluni = toltot * 6.d0 / dn / ( dn - 1.d0 ) / ( 2.d0 * dn - 1.d0 ) # initialization tolcum = 0.d0 # main process for ( j=1 ; j0.d0)) { for (j=1;j<=nobs;j=j+1) mrs(i) = mrs(i) + rs(i,j) mrs(i) = mrs(i) / dble (nobs) } else { for (j=1;j<=nobs;j=j+1) mrs(i) = mrs(i) + rs(i,j) * cnt(j) mrs(i) = mrs(i) / cntsum } } # Initialization for (m=1;m<=nt;m=m+1) wtsum(m) = 0.d0 for (i=1;i<=nqd;i=i+1) { tmp = dexp (ddot (nxis, qdrs(i,1), nqd, cd, 1)) for (m=1;m<=nt;m=m+1) { wt(m,i) = qdwt(m,i) * tmp wtsum(m) = wtsum(m) + wt(m,i) } } norm = 0.d0 for (m=1;m<=nt;m=m+1) norm = norm + bwt(m) * dlog (wtsum(m)) fitmean = 0.d0 for (i=1;i<=nobs;i=i+1) { tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if (cntsum>0.d0) tmp = tmp * cnt(i) fitmean = fitmean + tmp } if (!(cntsum>0.d0)) fitmean = fitmean / dble (nobs) else fitmean = fitmean / cntsum call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean + norm iter = 0 flag = 0 # Iteration repeat { iter = iter + 1 # Calculate hessian and gradient call dset(nxis, 0.d0, mu, 1) call dset(nxis*nxis, 0.d0, v, 1) for (m=1;m<=nt;m=m+1) { for (i=1;i<=nxis;i=i+1) muwk(i) = - ddot (nqd, wt(m,1), nt, qdrs(1,i), 1) / wtsum(m) for (i=1;i<=nxis;i=i+1) { for (j=i;j<=nxis;j=j+1) { vwk(i,j) = 0.d0 for (k=1;k<=nqd;k=k+1) vwk(i,j) = vwk(i,j) + wt(m,k) * qdrs(k,i) * qdrs(k,j) vwk(i,j) = vwk(i,j) / wtsum(m) - muwk(i) * muwk(j) } } call daxpy (nxis, bwt(m), muwk, 1, mu, 1) call daxpy (nxis*nxis, bwt(m), vwk, 1, v, 1) } for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) v(i,j) = v(i,j) + q(i,j) } call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) while (v(rkv,rkv)3.d2) { flag = flag + 1 break } tmp = dexp (tmp) for (m=1;m<=nt;m=m+1) { wtnew(m,i) = qdwt(m,i) * tmp wtsumnew(m) = wtsumnew(m) + wtnew(m,i) } } norm = 0.d0 for (m=1;m<=nt;m=m+1) norm = norm + bwt(m) * dlog (wtsumnew(m)) if ((flag==0)|(flag==2)) { fitmean = 0.d0 for (i=1;i<=nobs;i=i+1) { tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if (tmp>3.d2) { flag = flag + 1 break } fitnew(i) = dexp (tmp) if (cntsum>0.d0) tmp = tmp * cnt(i) fitmean = fitmean + tmp } if (!(cntsum>0.d0)) fitmean = fitmean / dble (nobs) else fitmean = fitmean / cntsum call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean + norm } # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) lkhd = 0.d0 for (m=1;m<=nt;m=m+1) { wtsum(m) = 0.d0 for (i=1;i<=nqd;i=i+1) wtsum(m) = wtsum(m) + wt(m,i) lkhd = lkhd + bwt(m) * dlog (wtsum(m)) } call dset (nobs, 1.d0, fit, 1) iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (i=1;i<=nqd;i=i+1) { for (m=1;m<=nt;m=m+1) disc = dmax1 (disc, dabs(wt(m,i)-wtnew(m,i))/(1.d0+dabs(wt(m,i)))) } for (i=1;i<=nobs;i=i+1) disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1.d0+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nt, wtnew, 1, wt, 1) call dcopy (nt, wtsumnew, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew # Check convergence if (disc00.d0) call dscal (nxis, dsqrt(cnt(i)), rs(1,i), 1) call dtrsl (v, nxis, nxis, rs(1,i), 11, infowk) if (nxis-rkv>0) call dset (nxis-rkv, 0.d0, rs(rkv+1,i), 1) } trc = ddot (nobs*nxis, rs, 1, rs, 1) if (!(cntsum>0.d0)) { trc = trc / dble(nobs) / (dble(nobs)-1.d0) lkhd = 0.d0 for (i=1;i<=nobs;i=i+1) lkhd = lkhd + dlog (fit(i)) lkhd = lkhd / dble (nobs) } else { trc = trc / cntsum / (cntsum-1.d0) lkhd = 0.d0 for (i=1;i<=nobs;i=i+1) lkhd = lkhd + cnt(i) * dlog (fit(i)) lkhd = lkhd / cntsum } for (m=1;m<=nt;m=m+1) lkhd = lkhd - bwt(m) * dlog (wtsum(m)) mrs(1) = lkhd mrs(2) = trc return end gss/src/ratfor/dtrev.r0000644000176200001440000000604714443702062014452 0ustar liggesusers #::::::::::: # dtrev #::::::::::: subroutine dtrev (vmu, t, ldt, n, z, score, varht, info, work) # Acronym: Double-precision TRidiagonal EValuation. # Purpose: To compute the GCV/GML function and the related variance # estimate from the tridiagonal matrix `t' and data vector `z'. # References: 1. Gu, Bates, Chen, and Wahba(1988), TR#823, Stat, UW-M. # 2. Dongarra et al. (1979) LINPACK User's Guide. (Chap. 4) character*1 vmu integer n, info double precision t(ldt,*), z(*), score, varht, work(*) # On entry: # vmu 'v': GCV. # 'm': GML. # 'u': unbiased risk estimate. # t the positive definite tridiagonal matrix T, # stored in packed form: # t(1,2:n): off-diagonal # t(2,1:n): diagonal. # ldt leading dimension of t. # n the dimension of the matrix. # z the appropriately transformed data vector. # varht known variance if vmu=='u'. # On exit: # score the GCV/GML/URE score. # varht \hat\sigma^{2}. # info -3: vmu is none of 'v', 'm', or 'u'. # > -3: as from LINPACK's `dpbfa'. # Work array: # work of size at least (n). # Routines called directly: # Fortran -- dexp, dble, dlog # Blas -- dasum, dcopy, ddot, dscal # Linpack -- dpbfa, dpbsl # Written: Chong Gu, Statistics, UW-Madison, latest version 12/29/91. double precision nume, deno, tmp, alph, la, dasum, ddot integer j info = 0 # check vmu if ( vmu != 'v' & vmu != 'm' & vmu != 'u' ) { info = -3 return } la = t(1,1) # standardize the matrix for numerical stability alph = dble (n) / dasum (n, t(2,1), ldt) call dscal (n, alph, t(2,1), ldt) call dscal (n-1, alph, t(1,2), ldt) # decomposition call dpbfa (t, ldt, n, 1, info) if ( info != 0 ) return call dcopy (n, z, 1, work, 1) call dpbsl (t, ldt, n, 1, work) # GCV computation if ( vmu == 'v' ) { tmp = 1.d0 / t(2,n) / t(2,n) deno = tmp for (j=n-1;j>0;j=j-1) { tmp = ( 1.d0 + t(1,j+1) * t(1,j+1) * tmp ) / t(2,j) / t(2,j) deno = deno + tmp } nume = ddot (n, work, 1, work, 1) / dble (n) deno = deno / dble (n) varht = alph * la * nume / deno score = nume / deno / deno } # GML computation if ( vmu == 'm' ) { deno = dlog (t(2,n)) for (j=n-1;j>0;j=j-1) deno = deno + dlog (t(2,j)) nume = ddot (n, z, 1, work, 1) / dble (n) varht = alph * la * nume score = nume * dexp (2.d0 * deno / dble (n)) } # unbiased risk computation if ( vmu == 'u' ) { nume = ddot (n, work, 1, work, 1) / dble (n) tmp = 1.d0 / t(2,n) / t(2,n) deno = tmp for (j=n-1;j>0;j=j-1) { tmp = ( 1.d0 + t(1,j+1) * t(1,j+1) * tmp ) / t(2,j) / t(2,j) deno = deno + tmp } deno = deno / dble (n) score = alph * alph * la * la * nume - 2.d0 * varht * alph * la * deno } return end #............................................................................... gss/src/ratfor/dmudr1.r0000644000176200001440000002507214464250624014526 0ustar liggesusers#::::::::::: # dmudr1 #::::::::::: subroutine dmudr1 (vmu,_ s, lds, nobs, nnull, q, ldqr, ldqc, nq, y,_ # inputs tol, init, prec, maxite,_ # tune para theta, nlaht, score, varht, c, d,_ # outputs qraux, jpvt, twk, traux, qwk, ywk, thewk,_ # work arrays hes, gra, hwk1, hwk2, gwk1, gwk2, pvtwk,_ kwk, work1, work2,_ info) # Acronym: Double precision MUltiple smoothing parameter DRiver. # Purpose: This routine implements the iterative algorithm for minimizing # GCV/GML scores with multiple smoothing parameters described in # Gu and Wahba(1988, Minimizing GCV/GML scores with multiple smoothing # parameters via the Newton method). # WARNING: Please be sure that you understand what this routine does before # you call it. Pilot runs with small problems are recommended. This # routine performs VERY INTENSIVE numerical calculations for big nobs. integer lds, nobs, nnull, ldqr, ldqc, nq, init, maxite,_ jpvt(*), pvtwk(*), info double precision s(lds,*), q(ldqr,ldqc,*), y(*), tol, prec,_ theta(*), nlaht, score, varht, c(*), d(*),_ qraux(*), traux(*), twk(2,*), qwk(ldqr,*), ywk(*),_ thewk(*), hes(nq,*), gra(*), hwk1(nq,*), hwk2(nq,*),_ gwk1(*), gwk2(*), kwk(nobs-nnull,nobs-nnull,*),_ work1(*), work2(*) character vmu # On entry: # vmu 'v': GCV criterion. # 'm': GML criterion. # 'u': unbiased risk estimate. # s the matrix S, of size (lds,nnull). # nobs the number of observations. # nnull the dimension of the null space. # q the matrices Q_{i}'s, of dimension (ldqr,ldqc,nq). # nq the number of Q_{i}'s. # y the response vector of size (nobs) # tol the tolerance for truncation in the tridiagonalization. # init 0 : No initial values provided for the theta. # 1 : Initial values provided for the theta. # theta initial values of theta if init = 1. # prec precision requested for the minimum score value. # maxite maximum number of iterations allowed. # varht known variance if vmu=='u'. # On exit: # theta the vector of parameter log10(theta) used in the final model, # of dimension (nq). -25 indicates effective minus infinity. # nlaht the estimated log10(n*lambda)|theta in the final model. # score the minimum GCV/GML/URE score found at (theta, nlaht). # varht the variance estimate. # c,d the coefficients estimates. # info 0 : normal termination. # -1 : dimension error. # -2 : F_{2}^{T} Q_{*}^{theta} F_{2} !>= 0. # -3 : tuning parameters are out of scope. # -4 : fails to converge within maxite steps. # -5 : fails to find a reasonable descent direction. # >0 : the matrix S is rank deficient: rank(S)+1. # Work arrays: # qraux of size at least (nnull). # jpvt of size at least (nnull). # twk of size at least (2,nobs-nnull). # traux of size at least (nobs-nnull-2). # qwk of size at least (nobs,nobs). # ywk of size at least (nobs). # thewk of size at least (nq). # hes of size at least (nq,nq). # gra of size at least (nq). # hwk1-2 of sizes at least (nq,nq). # gwk1-2 of sizes at least (nq). # pvtwk of size at least (nq). # kwk of size at least (nobs-nnull,nobs-nnull,nq). # work1-2 of sizes at least (nobs). # Routines called directly: # Blas -- dasum, daxpy, dcopy, ddot, dscal, idamax # Blas2 -- dsymv # Fortran -- dble, dlog, dlog10 # Linpack -- dpofa, dposl, sqrsl # Rkpack -- dcoef, dcore, ddeev, dmcdc, dstup # Other -- dprmut, dset # Routines called indirectly: # Blas -- dasum, daxpy, dcopy, ddot, dnrm2, dscal, dswap, idamax # Blas2 -- dgemv, dsymv, dsyr2 # Fortran -- dabs, dexp, dble, dlog, dlog10, dsqrt # Linpack -- dpbfa, dpbsl, dqrdc, dqrsl, dtrsl # Rkpack -- deval, dgold, dqrslm, dsytr, dtrev # Other -- dprmut, dset # Written: Chong Gu, Statistics, Purdue, latest version 1/6/92. double precision alph, scrold, scrwk, nlawk, limnla(2),_ tmp, dasum, ddot integer n, n0, i, j, iwk, maxitwk, idamax, job info = 0 # set working parameters n0 = nnull n = nobs - nnull maxitwk = maxite # check tuning parameters if ( (vmu != 'v' & vmu != 'm' & vmu != 'u') | (init != 0 & init != 1) |_ (maxitwk <=0) | (prec <= 0.d0) ) { info = -3 return } # check dimension if ( lds < nobs | nobs <= n0 | n0 < 1 | ldqr < nobs | ldqc < nobs |_ nq <= 0 ) { info = -1 return } # initialize call dstup (s, lds, nobs, n0, qraux, jpvt, y, q, ldqr, ldqc, nq, info,_ work1) if ( info != 0 ) return if ( init == 1 ) call dcopy (nq, theta, 1, thewk, 1) else { # use the "plug-in" weights as the starting theta for (i=1;i<=nq;i=i+1) { thewk(i) = dasum (n, q(n0+1,n0+1,i), ldqr+1) if ( thewk(i) > 0.d0 ) thewk(i) = 1.d0 / thewk(i) } # fit an initial model for (j=1;j<=nobs;j=j+1) call dset (nobs-j+1, 0.d0, qwk(j,j), 1) for (i=1;i<=nq;i=i+1) { for (j=1;j<=nobs;j=j+1) call daxpy (nobs-j+1, thewk(i), q(j,j,i), 1, qwk(j,j), 1) } call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, 0, limnla, nlawk,_ scrwk, varht, info, twk, work1) if (info != 0 ) return call dcoef (s, lds, nobs, n0, qraux, jpvt, ywk, qwk, ldqr, nlawk,_ c, d, info, twk) # assign weights due to norm \theta^{2}c^{T}(Q_{i})c call dqrsl (s, lds, nobs, n0, qraux, c, tmp, c, tmp, tmp, tmp,_ 01000, info) for (i=1;i<=nq;i=i+1) { call dsymv('l', n, thewk(i), q(n0+1,n0+1,i), ldqr, c(n0+1), 1,_ 0.d0, work1, 1) thewk(i) = ddot (n, c(n0+1), 1, work1, 1) * thewk(i) if ( thewk(i) > 0.d0 ) thewk(i) = dlog10 (thewk(i)) else thewk(i) = -25.d0 } } scrold = 1.d10 # main process job = 0 repeat { # nq == 1 if ( nq == 1 ) { theta(1) = 0.d0 break } # form Qwk = \sum_{i=1}^{nq} \thewk_{i} Q_{i} for (j=1;j<=nobs;j=j+1) call dset (nobs-j+1, 0.d0, qwk(j,j), 1) for (i=1;i<=nq;i=i+1) { if ( thewk(i) <= -25.d0 ) next for (j=1;j<=nobs;j=j+1) call daxpy (nobs-j+1, 10.d0 ** thewk(i), q(j,j,i), 1,_ qwk(j,j), 1) } # main calculation call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, job, limnla, nlawk,_ scrwk, varht, info, twk, work1) if (info != 0 ) return # half the increment if no gain if ( scrold < scrwk ) { # algorithm halts tmp = dabs (gwk1(idamax (nq, gwk1, 1))) if ( alph * tmp > - prec ) { info = -5 return } alph = alph / 2.d0 for (i=1;i<=nq;i=i+1) thewk(i) = theta(i) + alph * gwk1(i) next } # count for one iteration maxitwk = maxitwk - 1 # compute the gradient and the Hessian call dcopy (n-2, qwk(n0+2,n0+1), ldqr+1, traux, 1) call dcopy (n, qwk(n0+1,n0+1), ldqr+1, twk(2,1), 2) call dcopy (n-1, qwk(n0+1,n0+2), ldqr+1, twk(1,2), 2) call ddeev (vmu, nobs,_ q(n0+1,n0+1,1), ldqr, ldqc, n, nq, qwk(n0+2,n0+1),_ ldqr, traux, twk, ywk(n0+1),_ thewk, nlawk, scrwk, varht,_ # inputs hes, nq, gra,_ # outputs hwk1, hwk2, gwk1, gwk2,_ kwk, n, work1, work2, c,_ info) # get the active subset iwk = 0 for (i=1;i<=nq;i=i+1) { if ( thewk(i) <= -25.d0 ) next iwk = iwk + 1 call dcopy (nq, hes(1,i), 1, hes(1,iwk), 1) } iwk = 0 for (i=1;i<=nq;i=i+1) { if ( thewk(i) <= -25.d0 ) next iwk = iwk + 1 call dcopy (nq, hes(i,1), nq, hes(iwk,1), nq) gwk1(iwk) = gra(i) work2(iwk) = gra(i) } # compute the Newton direction for (i=1;i=1;i=i-1) { if ( thewk(i) <= -25.0 ) gwk1(i) = 0.d0 else { gwk1(i) = gwk1(iwk) iwk = iwk - 1 } } call dscal (nq, 1.d0/dlog(1.d1), gwk1, 1) tmp = dabs (gwk1(idamax (nq, gwk1, 1))) if ( tmp > 1.d0 ) call dscal (nq, 1.d0/tmp, gwk1, 1) # set thewk such that nlawk = 0.d0 for (i=1;i<=nq;i=i+1) { if ( thewk(i) <= -25.d0 ) next thewk(i) = thewk(i) - nlawk } call dcopy (nq, thewk, 1, theta, 1) # check convergence tmp = gra(idamax (nq, gra, 1)) ** 2 if ( tmp < prec ** 2 # zero gradient | scrold - scrwk < prec * (scrwk + 1.d0) # small change & tmp < prec * (scrwk + 1.d0) ** 2 ) { # small gradient break } # fail to converge if ( maxitwk < 1 ) { info = -4 return } # update records scrold = scrwk # increment thewk for (i=1;i<=nq;i=i+1) thewk(i) = thewk(i) + alph * gwk1(i) job = -1 limnla(1) = -1.d0 limnla(2) = 1.d0 } # the end of the main loop # compute the model to be returned for (j=1;j<=nobs;j=j+1) call dset (nobs-j+1, 0.d0, qwk(j,j), 1) for (i=1;i<=nq;i=i+1) { if ( theta(i) <= -25.d0 ) next for (j=1;j<=nobs;j=j+1) call daxpy (nobs-j+1, 10.d0 ** theta(i), q(j,j,i), 1,_ qwk(j,j), 1) } call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, job, limnla, nlaht,_ score, varht, info, twk, work1) if (info != 0 ) return call dcoef (s, lds, nobs, n0, qraux, jpvt, ywk, qwk, ldqr, nlaht,_ c, d, info, twk) return end #.................................................................................... gss/src/ratfor/dcore.r0000644000176200001440000001047214443702062014417 0ustar liggesusers #::::::::::: # dcore #::::::::::: subroutine dcore (vmu, q, ldq, nobs, nnull, tol, z, job, limnla, nlaht,_ score, varht, info, twk, work) # Purpose: To evaluate the GCV/GML score function at various trial values # of n*lambda using the tridiagonalization GCV/GML algorithm. Perform # either golden section search or regular grid search for minimizing # n*lambda. character*1 vmu integer ldq, nobs, nnull, job, info double precision q(ldq,*), tol, z(*), limnla(2), nlaht, score(*), varht,_ twk(2,*), work(*) # On entry: # vmu 'v': GCV criterion. # 'm': GML criterion. # 'u': unbiased risk estimate. # q F^{T} Q F, only refer the LOWER triangle of the BOTTOM- # RIGHT corner, i.e., F_{2}^{T} Q F_{2}. # ldq leading dimension of Q. # nobs number of observations. # nnull dimension of null space. # tol tolerance of truncation. # z F^{T} y. # job 0: searching interval for nlaht chosen automatically. # -1: searching interval for nlaht provided by limnla. # >0: search regular grid points on [limnla(1),limnla(2)]: # #(grids) = job + 1. # limnla searching interval in log10 scale, see job. # varht known variance if vmu=='u'. # On exit: # q tridiagonal form in diagonal and superdiagonal of the # corner, Householder factors in strict lower triangle of # the corner. # z diag(I, U^{T}) F^{T} y. # limnla see limnla of entry. # nlaht the estimated log10(n*lambda). # score job <= 0 : the GCV/GML/URE score at nlaht. # job > 0 : the GCV/GML/URE score at the regular grid points. # varht variance estimate. # info 0 : normal termination. # -1 : dimension error. # -2 : F_{2}^{T}QF_{2} is not non-negative definite. # -3 : vmu is none of 'v', 'm', or 'u'. # Work arrays: # twk of size at least (2,nobs-nnull). # work of size at least (nobs-nnull). # Routines called directly: # Fortran -- dble, dlog10 # Blas -- dasum, dcopy # Linpack -- dqrsl # Rkpack -- deval, dgold, dsytr # Written: Chong Gu, Statistics, Purdue, latest version 3/24/92. double precision dum, low, upp, dasum, mchpr integer n0, n, j info = 0 # check vmu if ( vmu != 'v' & vmu != 'm' & vmu != 'u' ) { info = -3 return } # check dimension if ( nnull < 1 | nobs <= nnull | nobs > ldq ) { info = -1 return } # set working parameters n0 = nnull n = nobs - nnull # tridiagonalization U^{T} ( F_{2}^{T} Q F_{2} ) U = T call dsytr (q(n0+1,n0+1), ldq, n, tol, info, work) if ( info != 0 ) return # U^{T} z_{2} call dcopy (n-2, q(n0+2,n0+1), ldq+1, work, 1) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, work, z(n0+2), dum, z(n0+2),_ dum, dum, dum, 01000, info) # set searching range if ( job == 0 ) { mchpr = 1.d0 while ( 1.d0 + mchpr > 1.d0 ) mchpr = mchpr / 2.d0 mchpr = mchpr * 2.d0 limnla(2) = dmax1 (dasum (n, q(n0+1,n0+1), ldq+1) * 1.d2, mchpr) limnla(1) = limnla(2) * mchpr limnla(2) = dlog10 (limnla(2)) limnla(1) = dlog10 (limnla(1)) } low = limnla(1) upp = limnla(2) if ( job <= 0 ) { # compute score and estimate nlaht thru golden-section search call dgold (vmu, q(n0+1,n0+1), ldq, n, z(n0+1), low, upp, nlaht,_ score(1), varht, info, twk, work) if ( vmu == 'v' ) score(1) = score(1) * dble (nobs) / dble (n) if ( vmu == 'm' ) score(1) = score(1) * dble (n) / dble (nobs) if ( vmu == 'u' ) score(1) = score(1) * dble (n) / dble (nobs) + 2.d0 * varht } else { # regular grid evaluation call deval (vmu, q(n0+1,n0+1), ldq, n, z(n0+1), job, low, upp, nlaht,_ score, varht, info, twk, work) dum = dble (nobs) / dble (n) for (j=1;j<=job+1;j=j+1) { if ( vmu == 'v' ) score(j) = score(j) * dum if ( vmu == 'm' ) score(j) = score(j) / dum if ( vmu == 'u' ) score(j) = score(j) / dum + 2.d0 * varht } } return end #............................................................................... gss/src/ratfor/reg.r0000644000176200001440000001051014456764341014105 0ustar liggesusers #::::::::: # reg #::::::::: subroutine reg (sr, nobs, nnull, q, nxi, y, method, alpha, varht, score, dc, mchpr, v, mu, jpvt, wk, rkv, info) integer nobs, nnull, nxi, method, jpvt(*), rkv, info double precision sr(nobs,*), q(nxi,*), y(*), alpha, varht, score, dc(*), mchpr, v(nnull+nxi,*), mu(*), wk(*) double precision ddot, dasum, rss, trc, dum integer i, j, nn, idamax, infowk, idum info = 0 nn = nnull + nxi # form linear system for (i=1;i<=nn;i=i+1) { mu(i) = ddot (nobs, sr(1,i), 1, y, 1) for (j=i;j<=nn;j=j+1) { v(i,j) = ddot (nobs, sr(1,i), 1, sr(1,j), 1) if (i>nnull) v(i,j) = v(i,j) + q(i-nnull,j-nnull) } } # Cholesky decomposition infowk = 0 for (i=1;i<=nn;i=i+1) infowk = infowk + jpvt(i) call dchdc (v, nn, nn, wk, jpvt, 1, rkv) j = idamax (rkv-infowk, v(infowk+1,infowk+1), nn+1) while (v(rkv,rkv)0) { call dqrdc (sr, nobs, nobs, nnull, wk, idum, dum, 0) for (i=1;i<=nxi;i=i+1) { call dqrsl (sr, nobs, nobs, nnull, wk, sr(1,nnull+i), dum, sr(1,nnull+i), dum, dum, dum, 01000, infowk) } } call dcopy (nxi, q, nxi+1, wk, 1) for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) q(i,j) = q(i,j) + ddot (nobs-nnull, sr(nnull+1,nnull+i), 1, sr(nnull+1,nnull+j), 1) } for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) { sr(i,j) = q(i,j) sr(j,i) = q(i,j) q(i,j) = q(j,i) } } call dcopy (nxi, wk, 1, q, nxi+1) # call rs (nobs, nxi, sr, mu, 0, dum, wk, y, info) call dsyev ('n', 'u', nxi, sr, nobs, mu, wk, 3*nxi, info) trc = 0.d0 for (i=1;i<=rkv-nnull;i=i+1) trc = trc + dlog (mu(nxi-i+1)) # call rs (nxi, nxi, q, mu, 0, dum, wk, y, info) call dsyev ('n', 'u', nxi, q, nxi, mu, wk, 3*nxi, info) for (i=1;i<=rkv-nnull;i=i+1) trc = trc - dlog (mu(nxi-i+1)) # return values score = rss / dble (nobs) * dexp (trc/dble(nobs-nnull)) varht = rss / dble (nobs-nnull) } else { # GCV or Cp rss = ddot (nobs, wk, 1, wk, 1) / dble (nobs) # trace for (i=1;i<=nobs;i=i+1) { call dcopy (nn, sr(i,1), nobs, mu, 1) call dprmut (mu, nn, jpvt, 0) call dtrsl (v, nn, nn, mu, 11, infowk) wk(i) = ddot (nn, mu, 1, mu, 1) } trc = dasum (nobs, wk, 1) / dble (nobs) # return values if (method==2) { score = rss / (1.d0-alpha*trc)**2 varht = rss / (1.d0-trc) } else score = rss + 2.d0 * varht * alpha * trc } wk(1) = rss wk(2) = trc return end #:::::::::::: # regaux #:::::::::::: subroutine regaux (v, nn, jpvt, rkv, r, nr, sms, nnull, wk) integer nn, jpvt(*), rkv, nr, nnull double precision v(nn,*), r(nn,*), sms(nnull,*), wk(nn,*) double precision ddot integer i, j, infowk # drcr for (i=1;i<=nr;i=i+1) { call dprmut (r(1,i), nn, jpvt, 0) call dtrsl (v, nn, nn, r(1,i), 11, infowk) if (nn-rkv>0) call dset (nn-rkv, 0.d0, r(rkv+1,i), 1) call dtrsl (v, nn, nn, r(1,i), 01, infowk) call dprmut (r(1,i), nn, jpvt, 1) } # sms call dset (nn*nnull, 0.d0, wk, 1) call dset (nnull, 1.d0, wk, nn+1) for (i=1;i<=nnull;i=i+1) call dtrsl (v, nn, nn, wk(1,i), 11, infowk) for (i=1;i<=nnull;i=i+1) { for (j=i;j<=nnull;j=j+1) { sms(i,j) = ddot (nn, wk(1,i), 1, wk(1,j), 1) sms(j,i) = sms(i,j) } } return end gss/src/ratfor/dcrdr.r0000644000176200001440000000660414443702062014423 0ustar liggesusers #::::::::::: # dcrdr #::::::::::: subroutine dcrdr (s, lds, nobs, nnull, qraux, jpvt, q, ldq, nlaht,_ r, ldr, nr, cr, ldcr, dr, lddr, wk, info) # Purpose: To compute auxiliary quantities cr and dr for posterior covariance # Usage: Use s, qraux, jpvt, q, and nlaht returned by dsidr. integer lds, nobs, nnull, jpvt(*), ldq, ldr, nr, ldcr, lddr, info double precision s(lds,*), qraux(*), q(ldq,*), nlaht, r(ldr,*), cr(ldcr,*),_ dr(lddr,*), wk(2,*) # On entry: # s,qraux,jpvt # QR-decomposition of S = F R. # nobs number of observations. # nnull dimension of null space. # q U^{T} F_{2}^{T} Q F_{2} U in BOTTOM-RIGHT corner's # LOWER triangle and SUPER DIAGONAL; # F_{2}^{T} Q F_{1} in BOTTOM-LEFT corner; # ldq leading dimension of q. # nlaht estimated log10(n*lambda). # r R(t,s^{T}). # nr length of s. # On exit: # cr (M^{-1}-M^{-1}S(S^{T}M^{-1}S)^{-1}S^{T}M^{-1})R(t,s^{T}) # dr (S^{T}M^{-1}S)^{-1}S^{T}M^{-1}R(t,s^{T}) # info 0: normal termination. # >0: S is not of full rank: rank(S)+1 . # -1: dimension error. # -2: F_{2}^{T} Q F_{2} is not non-negative definite. # others intact. # Work array: # wk of size at least (2,nobs-nnull). # Routines called directly: # Blas -- daxpy, dcopy, ddot # Linpack -- dpbfa, dpbsl, dqrsl, dtrsl # Other -- dprmut, dset # Written: Chong Gu, Statistics, Purdue, 2/27/96 at Ann Arbor. double precision dum, ddot integer i, j, n, n0 info = 0 # check dimension if ( nnull < 1 | nnull >= nobs | nobs > lds | nobs > ldq | ldr < nobs |_ nr < 1 | ldcr < nobs | lddr < nnull ) { info = -1 return } # set working parameters n0 = nnull n = nobs - nnull # copy r to cr for (j=1;j<=nr;j=j+1) call dcopy (nobs, r(1,j), 1, cr(1,j), 1) # compute diag(I, U^{T}) F^{T} R(t,s^{T}) call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) for (j=1;j<=nr;j=j+1) { call dqrsl (s, lds, nobs, nnull, qraux, cr(1,j), dum, cr(1,j), dum,_ dum, dum, 01000, info) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, cr(n0+2,j), dum, cr(n0+2,j), dum, dum, dum, 01000, info) } # compute U ( T + n*lambdahat I )^{-1} diag(I, U^{T}) F^{T} R(t,s^{T}) call dset (n, 10.d0 ** nlaht, wk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, wk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, wk(1,2), 2) call dpbfa (wk, 2, n, 1, info) if ( info != 0 ) { info = -2 return } for (j=1;j<=nr;j=j+1) call dpbsl (wk, 2, n, 1, cr(n0+1,j)) call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) for (j=1;j<=nr;j=j+1) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, cr(n0+2,j), cr(n0+2,j),_ dum, dum, dum, dum, 10000, info) # compute dr for (j=1;j<=nr;j=j+1) { for (i=1;i<=n0;i=i+1) dr(i,j) = cr(i,j) - ddot (n, cr(n0+1,j), 1, q(n0+1,i), 1) call dtrsl (s, lds, n0, dr(1,j), 01, info) call dprmut (dr(1,j), n0, jpvt, 1) } # compute cr for (j=1;j<=nr;j=j+1) { call dset (n0, 0.d0, cr(1,j), 1) call dqrsl (s, lds, nobs, nnull, qraux, cr(1,j), cr(1,j),_ dum, dum, dum, dum, 10000, info) } return end #.............................................................................. gss/src/ratfor/dmcdc.r0000644000176200001440000000632314443702062014375 0ustar liggesusers #::::::::::: # dmcdc #::::::::::: subroutine dmcdc (a, lda, p, e, jpvt, info) # Acronym: Double precision Modified Cholesky DeComposition. # Purpose: This routine implements the modified Cholesky decomposition as # described by Gill, Murray, and Wright (p.111, Practical Optimization, # Academic Press, 1981). The parameter delta is set to the maximum of # 1.d-7 * (average diag) and 1.d-10. Pivoting is enforced. The result # is compatible with the Linpack routine `dposl'. integer lda, p, jpvt(*), info double precision a(lda,*), e(*) # On entry: # a a symmetric matrix in the UPPER triangle. # lda the leading dimension of a. # p the size of a. # On exit: # a the Cholesky factor R of P^{T}AP + E = R^{T} R, where P # is a permutation matrix. # e the amount of diagonal modification, of size (p). # jpvt the permutation P, jpvt(j) contains the index of diagonal # element moved to j-th position, of size (p). # info 0: normal termination. # -1: dimension error. # Routines called directly: # Blas -- dasum, ddot, dscal, dswap, idamax # Fortran -- dabs, dmax1, dble, dsqrt # Written: Chong Gu, Statistics, UW-Madison, latest version 9/16/88. double precision beta, delta, theta, tmp, dasum, ddot integer i, j, jmax, jtmp, idamax info = 0 # check dimension if ( lda < p | p < 1 ) { info = -1 return } # compute constants tmp = 1.d0 while ( 1.d0 + tmp > 1.d0 ) tmp = tmp / 2.d0 jmax = idamax (p, a, lda+1) beta = dmax1 (2.d0 * tmp, dabs (a(jmax,jmax))) tmp = dsqrt (dble (p*p-1)) if ( tmp < 1.d0 ) tmp = 1.d0 for (j=2;j<=p;j=j+1) { jmax = idamax (j-1, a(1,j), 1) beta = dmax1 (beta, dabs (a(jmax,j)) / tmp) } delta = dasum (p, a, lda+1) / dble (p) * 1.d-7 delta = dmax1 (delta, 1.d-10) for (j=1;j<=p;j=j+1) jpvt(j) = j # compute P^{T}AP + E = LDL^{T} for (j=1;j<=p;j=j+1) { # pivoting jmax = idamax (p-j+1, a(j,j), lda+1) + j - 1 if ( jmax != j ) { call dswap (j-1, a(1,j), 1, a(1,jmax), 1) call dswap (jmax-j-1, a(j,j+1), lda, a(j+1,jmax), 1) call dswap (p-jmax, a(j,jmax+1), lda, a(jmax,jmax+1), lda) tmp = a(j,j) a(j,j) = a(jmax,jmax) a(jmax,jmax) = tmp jtmp = jpvt(j) jpvt(j) = jpvt(jmax) jpvt(jmax) = jtmp } # compute j-th column of L^{T} for (i=1;i0: S is not of full rank: rank(S)+1 . # -1: dimension error. # -2: F_{2}^{T} Q F_{2} is not non-negative definite. # Work array: # twk of size at least (2,nobs-nnull). # Routines called directly: # Blas -- daxpy, dcopy, ddot # Linpack -- dpbfa, dpbsl, dqrsl, dtrsl # Other -- dprmut, dset # Written: Chong Gu, Statistics, UW-Madison, 5/4/88 at Yale. double precision dum, ddot integer n, n0, j info = 0 # check dimension if ( nnull < 1 | nnull >= nobs | nobs > lds | nobs > ldq ) { info = -1 return } # set working parameters n0 = nnull n = nobs - nnull # compute U ( T + n*lambdahat I )^{-1} z call dset (n, 10.d0 ** nlaht, twk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, twk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, twk(1,2), 2) call dpbfa (twk, 2, n, 1, info) if ( info != 0 ) { info = -2 return } call dpbsl (twk, 2, n, 1, z(n0+1)) call dcopy (n-2, q(n0+2,n0+1), ldq+1, twk, 1) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, twk, z(n0+2), z(n0+2), dum,_ dum, dum, dum, 10000, info) # compute c call dset (n0, 0.d0, c, 1) call dcopy (n, z(n0+1), 1, c(n0+1), 1) call dqrsl (s, lds, nobs, nnull, qraux, c, c, dum, dum, dum, dum, 10000,_ info) # compute d for (j=1;j<=n0;j=j+1) { d(j) = z(j) - ddot (n, z(n0+1), 1, q(n0+1,j), 1) } call dtrsl (s, lds, n0, d, 01, info) call dprmut (d, n0, jpvt, 1) return end #............................................................................... gss/src/ratfor/dmudr0.r0000644000176200001440000000326014443702062014513 0ustar liggesuserssubroutine dmudr0 (vmu,_ s, lds, nobs, nnull, q, ldqr, ldqc, nq, y,_ # inputs tol, init, prec, maxite,_ # tune para theta, nlaht, score, varht, c, d,_ # outputs iwk, wk, info) integer vmu integer lds, nobs, nnull, ldqr, ldqc, nq, init, maxite,_ info, iwk(*) double precision s(lds,*), q(ldqr,ldqc,*), y(*), tol, prec,_ theta(*), nlaht, score, varht, c(*), d(*),_ wk(*) character*1 vmu1 integer n, n0 integer iqraux, itraux, itwk, iqwk, iywk, ithewk, ihes, igra, ihwk1, ihwk2,_ igwk1, igwk2, ikwk, iwork1, iwork2, ijpvt, ipvtwk if ( vmu == 1 ) vmu1 = 'v' if ( vmu == 2 ) vmu1 = 'm' if ( vmu == 3 ) vmu1 = 'u' n = nobs n0 = nnull iqraux = 1 itraux = iqraux + n0 itwk = itraux + (n-n0-2) iqwk = itwk + 2 * (n-n0) iywk = iqwk + n * n ithewk = iywk + n ihes = ithewk + nq igra = ihes + nq * nq ihwk1 = igra + nq ihwk2 = ihwk1 + nq * nq igwk1 = ihwk2 + nq * nq igwk2 = igwk1 + nq ikwk = igwk2 + nq iwork1 = ikwk + (n-n0) * (n-n0) * nq iwork2 = iwork1 + n ijpvt = 1 ipvtwk = ijpvt + n0 call dmudr1 (vmu1,_ s, lds, nobs, nnull, q, ldqr, ldqc, nq, y,_ # inputs tol, init, prec, maxite,_ # tune para theta, nlaht, score, varht, c, d,_ # outputs wk(iqraux), iwk(ijpvt), wk(itwk), wk(itraux), wk(iqwk),_ wk(iywk), wk(ithewk), wk(ihes), wk(igra), wk(ihwk1),_ wk(ihwk2), wk(igwk1), wk(igwk2), iwk(ipvtwk), wk(ikwk),_ wk(iwork1), wk(iwork2),_ info) return end gss/src/ratfor/dstup.r0000644000176200001440000000400714443702062014457 0ustar liggesusers #::::::::::: # dstup #::::::::::: subroutine dstup (s, lds, nobs, nnull, qraux, jpvt, y, q, ldqr, ldqc, nq,_ info, work) # Purpose: To perform QR decomposition of S=FR and to form F^{T}y, F^{T}QF's. integer lds, nobs, nnull, jpvt(*), ldqr, ldqc, nq, info double precision s(lds,*), y(*), qraux(*), q(ldqr,ldqc,*), work(*) # On entry: # s the S matrix spanning null space, of size (lds,nnull). # lds leading dimension of s. # nobs number of observations. # nnull dimension of null space. # y observations, of size (nobs). # q the reproducing kernels, of size (ldqr,ldqc,nq). # ldqr leading dimension for rows of q. # ldqc leading dimension for columns of q. # nq number of Q's. # On exit: # s,qraux,jpvt # QR decomposition of S=FR. # y F^{T} y. # q F^{T}QF's. # info 0: normal termination. # -1: dimension error. # >0: rank(S)+1. # Work array: # work of size at least (nobs). # Routines called directly: # Linpack -- dqrdc, dqrsl # Rkpack -- dqrslm # Written: Chong Gu, Statistics, Purdue, latest version 3/7/91. double precision dum integer j info = 0 # check dimension if ( nobs < 1 | nobs > lds | nobs > ldqr | nobs > ldqc ) { info = -1 return } # QR decomposition of S=FR # The indented line below is added on Mar 7, 1991, # with credit to Dick Franke for (j=1;j<=nnull;j=j+1) jpvt(j) = 0 call dqrdc (s, lds, nobs, nnull, qraux, jpvt, work, 1) # F^{T} y; test rank of R call dqrsl (s, lds, nobs, nnull, qraux, y, dum, y, work, dum, dum, 01100,_ info) if ( info != 0 ) return # F^{T} Q_{*} F for (j=1;j<=nq;j=j+1) { call dqrslm (s, lds, nobs, nnull, qraux, q(1,1,j), ldqr, 0, info,_ work) } return end #............................................................................... gss/src/ratfor/dgold.r0000644000176200001440000000767714443702062014431 0ustar liggesusers #::::::::::: # dgold #::::::::::: subroutine dgold (vmu, q, ldq, n, z, low, upp, nlaht, score, varht,_ info, twk, work) # Purpose: To evaluate GCV/GML function based on tridiagonal form and to # search minimum on an interval by golden section search. character*1 vmu integer ldq, n, info double precision q(ldq,*), z(*), low, upp, nlaht, score, varht, twk(2,*),_ work(*) # On entry: # vmu 'v': GCV criterion. # 'm': GML criterion. # 'u': unbiased risk estimate. # q tidiagonal matrix in diagonal and super diagonal. # ldq leading dimension of Q. # n size of the matrix. # z U^{T} F_{2}^{T} y. # low lower limit of log10(n*lambda). # upp upper limit of log10(n*lambda). # varht known variance if vmu=='u'. # On exit: # nlaht the estimated log(n*lambda). # score the GCV/GML/URE score at the estimated lambda. # varht the variance estimate at the estimated lambda. # info 0: normal termination. # -1: dimension error. # -2: tridiagonal form is not non-negative definite. # -3: vmu is none of 'v', 'm', or 'u'. # Work arrays: # twk of size at least (2,n). # work of size at least (n). # Routines called directly: # Fortran -- dsqrt # Blas -- daxpy, dcopy # Rkpack -- dtrev # Other -- dset # Written: Chong Gu, Statistics, Purdue, latest version 12/29/91. double precision ratio, mlo, mup, tmpl, tmpu ratio = ( dsqrt (5.d0) - 1.d0 ) / 2.d0 info = 0 # interchange the boundaries if necessary if ( upp < low ) { mlo = low low = upp upp = mlo } # check vmu if ( vmu != 'v' & vmu != 'm' & vmu != 'u' ) { info = -3 return } # check dimension if ( n < 1 | n > ldq ) { info = -1 return } # initialize golden section search for scrht mlo = upp - ratio * (upp - low) call dset (n, 10.d0 ** (mlo), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mlo call dtrev (vmu, twk, 2, n, z, tmpl, varht, info, work) if ( info != 0 ) { info = -2 return } mup = low + ratio * (upp - low) call dset (n, 10.d0 ** (mup), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mup call dtrev (vmu, twk, 2, n, z, tmpu, varht, info, work) if ( info != 0 ) { info = -2 return } # golden section search for estimate of lambda repeat { if ( mup - mlo < 1.d-7 ) break if ( tmpl < tmpu ) { upp = mup mup = mlo tmpu = tmpl mlo = upp - ratio * (upp - low) call dset (n, 10.d0 ** (mlo), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mlo call dtrev (vmu, twk, 2, n, z, tmpl, varht, info, work) if ( info != 0 ) { info = -2 return } } else { low = mlo mlo = mup tmpl = tmpu mup = low + ratio * (upp - low) call dset (n, 10.d0 ** (mup), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mup call dtrev (vmu, twk, 2, n, z, tmpu, varht, info, work) if ( info != 0 ) { info = -2 return } } } # compute the return value nlaht = ( mup + mlo ) / 2.d0 call dset (n, 10.d0 ** (nlaht), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**nlaht call dtrev (vmu, twk, 2, n, z, score, varht, info, work) if ( info != 0 ) { info = -2 return } return end #............................................................................... gss/src/ratfor/copu2newton.r0000644000176200001440000004076714443702062015620 0ustar liggesusers #::::::::::::::::: # copu2newton #::::::::::::::::: subroutine copu2newton (cd, nxis, q, nxi, rs0, n0, cntsum0, cnt0, qdrs, nqd, qdrs1, wt1, n1, cntsum1, cnt1, qdrs2, wt2, n2, cntsum2, cnt2, wt3, n3, cntsum3, cnt3, nt, twt, qdwt, tind, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, n0, cntsum0, cnt0(*), nqd, n1, cntsum1, cnt1(*), n2, cntsum2, cnt2(*), n3, cntsum3, cnt3(*), nt, tind(*), maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs0(nxis,*), qdrs(nxis,*), qdrs1(nqd,nxis,*), wt1(nqd,*), qdrs2(nqd,nxis,*), wt2(nqd,*), wt3(nqd,2,*), twt(*), qdwt(nqd,2,*), prec, mchpr, wk(*) integer imrs, imrs2, ieta, ieta1, ieta2, imu, imuwk, iv, ivwk, icdnew, imut, iwk imrs = 1 imrs2 = imrs + nxis ieta = imrs2 + nxis ieta1 = ieta + nqd*nqd ieta2 = ieta1 + nqd*n1 imu = ieta2 + nqd*n2 imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis imut = icdnew + nxis iwk = imut + nxis*nt call copu2newton1 (cd, nxis, q, nxi, rs0, n0, cntsum0, cnt0, qdrs, nqd, qdrs1, wt1, n1, cntsum1, cnt1, qdrs2, wt2, n2, cntsum2, cnt2, wt3, n3, cntsum3, cnt3, nt, twt, qdwt, tind, prec, maxiter, mchpr, wk(imrs), wk(imrs2), wk(ieta), wk(ieta1), wk(ieta2), wk(imu), wk(imuwk), wk(iv), wk(ivwk), jpvt, wk(icdnew), wk(imut), wk(iwk), info) return end #:::::::::::::::::: # copu2newton1 #:::::::::::::::::: subroutine copu2newton1 (cd, nxis, q, nxi, rs0, n0, cntsum0, cnt0, qdrs, nqd, qdrs1, wt1, n1, cntsum1, cnt1, qdrs2, wt2, n2, cntsum2, cnt2, wt3, n3, cntsum3, cnt3, nt, twt, qdwt, tind, prec, maxiter, mchpr, mrs, mrs2, eta, eta1, eta2, mu, muwk, v, vwk, jpvt, cdnew, mut, wk, info) integer nxis, nxi, n0, cntsum0, cnt0(*), nqd, n1, cntsum1, cnt1(*), n2, cntsum2, cnt2(*), n3, cntsum3, cnt3(*), nt, tind(*), maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs0(nxis,*), qdrs(nxis,*), qdrs1(nqd,nxis,*), wt1(nqd,*), qdrs2(nqd,nxis,*), wt2(nqd,*), wt3(nqd,2,*), twt(*), qdwt(nqd,2,*), prec, mchpr, mrs(*), mrs2(*), eta(*), eta1(nqd,*), eta2(nqd,*), mu(*), muwk(*), v(nxis,*), vwk(nxis,*), cdnew(*), mut(nxis,*), wk(*) integer nobs, i, j, k, kk, iter, flag, rkv, idamax, infowk double precision tmp, ddot, dasum, lkhd, mumax, lkhdnew, disc, disc0, trc # Calculate constants info = 0 if (cntsum0==0) nobs = n0 else nobs = cntsum0 if (cntsum1==0) nobs = nobs + n1 else nobs = nobs + cntsum1 if (cntsum2==0) nobs = nobs + n2 else nobs = nobs + cntsum2 if (cntsum3==0) nobs = nobs + n3 else nobs = nobs + cntsum3 for (i=1;i<=nxis;i=i+1) { mrs(i) = 0.d0 for (j=1;j<=n0;j=j+1) { if (cntsum0==0) mrs(i) = mrs(i) + rs0(i,j) else mrs(i) = mrs(i) + rs0(i,j) * dble (cnt0(j)) } } # Initialization for (i=1;i<=nqd*nqd;i=i+1) eta(i) = dexp (ddot (nxis, qdrs(1,i), 1, cd, 1)) lkhd = 0.d0 for (i=1;i<=n0;i=i+1) { tmp = ddot (nxis, rs0(1,i), 1, cd, 1) if (cntsum0!=0) tmp = tmp * dble (cnt0(i)) lkhd = lkhd - tmp } for (i=1;i<=n1;i=i+1) { for (j=1;j<=nqd;j=j+1) { eta1(j,i) = dexp (ddot (nxis, qdrs1(j,1,i), nqd, cd, 1)) * wt1(j,i) } if (cntsum1==0) lkhd = lkhd - dlog (dasum (nqd, eta1(1,i), 1)) else lkhd = lkhd - dlog (dasum (nqd, eta1(1,i), 1)) * dble (cnt1(i)) } for (i=1;i<=n2;i=i+1) { for (j=1;j<=nqd;j=j+1) { eta2(j,i) = dexp (ddot (nxis, qdrs2(j,1,i), nqd, cd, 1)) * wt2(j,i) } if (cntsum2==0) lkhd = lkhd - dlog (dasum (nqd, eta2(1,i), 1)) else lkhd = lkhd - dlog (dasum (nqd, eta2(1,i), 1)) * dble (cnt2(i)) } for (i=1;i<=n3;i=i+1) { tmp = 0.d0 for (j=1;j<=nqd;j=j+1) { tmp = tmp + ddot (nqd, eta((j-1)*nqd+1), 1, wt3(1,1,i), 1) * wt3(j,2,i) } if (cntsum3==0) lkhd = lkhd - dlog (tmp) else lkhd = lkhd - dlog (tmp) * dble (cnt3(i)) } lkhd = lkhd / dble (nobs) for (i=1;i<=nt;i=i+1) { tmp = 0.d0 for (j=1;j<=nqd;j=j+1) { tmp = tmp + ddot (nqd, eta((j-1)*nqd+1), 1, qdwt(1,1,i), 1) * qdwt(j,2,i) } lkhd = lkhd + dlog (tmp) * twt(i) } call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, muwk, 1) lkhd = lkhd + ddot (nxi, cd, 1, muwk, 1) / 2.d0 iter = 0 flag = 0 # Iteration repeat { iter = iter + 1 # Calculate hessian and gradient call dcopy (nxis, mrs, 1, mu, 1) call dset(nxis*nxis, 0.d0, v, 1) for (i=1;i<=n1;i=i+1) { tmp = dasum (nqd, eta1(1,i), 1) for (j=1;j<=nxis;j=j+1) muwk(j) = ddot (nqd, eta1(1,i), 1, qdrs1(1,j,i), 1) / tmp for (j=1;j<=nxis;j=j+1) { for (k=j;k<=nxis;k=k+1) { vwk(j,k) = 0.d0 for (kk=1;kk<=nqd;kk=kk+1) vwk(j,k) = vwk(j,k) + eta1(kk,i)*qdrs1(kk,j,i)*qdrs1(kk,k,i) vwk(j,k) = vwk(j,k) / tmp - muwk(j) * muwk(k) } } if (cntsum1==0) { call daxpy (nxis, 1.d0, muwk, 1, mu, 1) call daxpy (nxis*nxis, -1.d0, vwk, 1, v, 1) } else { call daxpy (nxis, dble (cnt1(i)), muwk, 1, mu, 1) call daxpy (nxis*nxis, -dble (cnt1(i)), vwk, 1, v, 1) } } for (i=1;i<=n2;i=i+1) { tmp = dasum (nqd, eta2(1,i), 1) for (j=1;j<=nxis;j=j+1) muwk(j) = ddot (nqd, eta2(1,i), 1, qdrs2(1,j,i), 1) / tmp for (j=1;j<=nxis;j=j+1) { for (k=j;k<=nxis;k=k+1) { vwk(j,k) = 0.d0 for (kk=1;kk<=nqd;kk=kk+1) vwk(j,k) = vwk(j,k) + eta2(kk,i)*qdrs2(kk,j,i)*qdrs2(kk,k,i) vwk(j,k) = vwk(j,k) / tmp - muwk(j) * muwk(k) } } if (cntsum2==0) { call daxpy (nxis, 1.d0, muwk, 1, mu, 1) call daxpy (nxis*nxis, -1.d0, vwk, 1, v, 1) } else { call daxpy (nxis, dble (cnt2(i)), muwk, 1, mu, 1) call daxpy (nxis*nxis, -dble (cnt2(i)), vwk, 1, v, 1) } } for (i=1;i<=n3;i=i+1) { for (j=1;j<=nqd;j=j+1) { for (k=1;k<=nqd;k=k+1) wk((k-1)*nqd+j) = eta((k-1)*nqd+j) * wt3(j,1,i) * wt3(k,2,i) } tmp = dasum (nqd*nqd, wk, 1) for (j=1;j<=nxis;j=j+1) muwk(j) = ddot (nqd*nqd, wk, 1, qdrs(j,1), nxis) / tmp for (j=1;j<=nxis;j=j+1) { for (k=j;k<=nxis;k=k+1) { vwk(j,k) = 0.d0 for (kk=1;kk<=nqd*nqd;kk=kk+1) vwk(j,k) = vwk(j,k) + wk(kk)*qdrs(j,kk)*qdrs(k,kk) vwk(j,k) = vwk(j,k) / tmp - muwk(j) * muwk(k) } } if (cntsum3==0) { call daxpy (nxis, 1.d0, muwk, 1, mu, 1) call daxpy (nxis*nxis, -1.d0, vwk, 1, v, 1) } else { call daxpy (nxis, dble (cnt3(i)), muwk, 1, mu, 1) call daxpy (nxis*nxis, -dble (cnt3(i)), vwk, 1, v, 1) } } call dscal (nxis, 1.d0/dble(nobs), mu, 1) call dscal (nxis*nxis, 1.d0/dble(nobs), v, 1) for (i=1;i<=nt;i=i+1) { for (j=1;j<=nqd;j=j+1) { for (k=1;k<=nqd;k=k+1) wk((k-1)*nqd+j) = eta((k-1)*nqd+j) * qdwt(j,1,i) * qdwt(k,2,i) } tmp = dasum (nqd*nqd, wk, 1) for (j=1;j<=nxis;j=j+1) muwk(j) = ddot (nqd*nqd, wk, 1, qdrs(j,1), nxis) / tmp for (j=1;j<=nxis;j=j+1) { for (k=j;k<=nxis;k=k+1) { vwk(j,k) = 0.d0 for (kk=1;kk<=nqd*nqd;kk=kk+1) vwk(j,k) = vwk(j,k) + wk(kk)*qdrs(j,kk)*qdrs(k,kk) vwk(j,k) = vwk(j,k) / tmp - muwk(j) * muwk(k) } } call dcopy (nxis, muwk, 1, mut(1,i), 1) call daxpy (nxis, -twt(i), muwk, 1, mu, 1) call daxpy (nxis*nxis, twt(i), vwk, 1, v, 1) } call dcopy (nxis, mu, 1, mrs2, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) v(i,j) = v(i,j) + q(i,j) } mumax = dabs(mu(idamax(nxis, mu, 1))) # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 # call dmcdc (v, nxis, nxis, muwk, jpvt, infowk) call dchdc (v, nxis, nxis, muwk, jpvt, 1, rkv) while (v(rkv,rkv)3.d2) { flag = flag + 1 break } wk(i) = dexp (tmp) } lkhdnew = 0.d0 for (i=1;i<=n0;i=i+1) { tmp = ddot (nxis, rs0(1,i), 1, cdnew, 1) if (cntsum0!=0) tmp = tmp * dble (cnt0(i)) lkhdnew = lkhdnew - tmp } for (i=1;i<=n1;i=i+1) { for (j=1;j<=nqd;j=j+1) { eta1(j,i) = dexp (ddot (nxis, qdrs1(j,1,i), nqd, cdnew, 1)) * wt1(j,i) } if (cntsum1==0) lkhdnew = lkhdnew - dlog (dasum (nqd, eta1(1,i), 1)) else lkhdnew = lkhdnew - dlog (dasum (nqd, eta1(1,i), 1)) * dble (cnt1(i)) } for (i=1;i<=n2;i=i+1) { for (j=1;j<=nqd;j=j+1) { eta2(j,i) = dexp (ddot (nxis, qdrs2(j,1,i), nqd, cdnew, 1)) * wt2(j,i) } if (cntsum2==0) lkhdnew = lkhdnew - dlog (dasum (nqd, eta2(1,i), 1)) else lkhdnew = lkhdnew - dlog (dasum (nqd, eta2(1,i), 1)) * dble (cnt2(i)) } for (i=1;i<=n3;i=i+1) { tmp = 0.d0 for (j=1;j<=nqd;j=j+1) { tmp = tmp + ddot (nqd, wk((j-1)*nqd+1), 1, wt3(1,1,i), 1) * wt3(j,2,i) } if (cntsum3==0) lkhdnew = lkhdnew - dlog (tmp) else lkhdnew = lkhdnew - dlog (tmp) * dble (cnt3(i)) } lkhdnew = lkhdnew / dble (nobs) for (i=1;i<=nt;i=i+1) { tmp = 0.d0 for (j=1;j<=nqd;j=j+1) { tmp = tmp + ddot (nqd, wk((j-1)*nqd+1), 1, qdwt(1,1,i), 1) * qdwt(j,2,i) } lkhdnew = lkhdnew + dlog (tmp) * twt(i) } call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, muwk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, muwk, 1) / 2.d0 # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) call dset (nqd*nqd, 1.d0, eta, 1) call dcopy (nqd*n1, wt1, 1, eta1, 1) call dcopy (nqd*n2, wt2, 1, eta2, 1) lkhd = 0.d0 for (i=1;i<=n1;i=i+1) { if (cntsum1==0) lkhd = lkhd - dlog (dasum (nqd, eta1(1,i), 1)) else lkhd = lkhd - dlog (dasum (nqd, eta1(1,i), 1)) * dble (cnt1(i)) } for (i=1;i<=n2;i=i+1) { if (cntsum2==0) lkhd = lkhd - dlog (dasum (nqd, eta2(1,i), 1)) else lkhd = lkhd - dlog (dasum (nqd, eta2(1,i), 1)) * dble (cnt2(i)) } for (i=1;i<=n3;i=i+1) { tmp = dasum (nqd, wt3(1,1,i), 1) * dasum (nqd, wt3(1,2,i), 1) if (cntsum3==0) lkhdnew = lkhdnew - dlog (tmp) else lkhdnew = lkhdnew - dlog (tmp) * dble (cnt3(i)) } lkhd = lkhd / dble (nobs) for (i=1;i<=nt;i=i+1) { tmp = dasum (nqd, qdwt(1,1,i), 1) * dasum (nqd, qdwt(1,2,i), 1) lkhd = lkhd + dlog (tmp) * twt(i) } iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (i=1;i<=nqd*nqd;i=i+1) { disc = dmax1 (disc, dabs(eta(i)-wk(i))/(1.d0+dabs(eta(i)))) } disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1.d0+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nqd, wk, 1, eta, 1) lkhd = lkhdnew # Check convergence if (disc01) call daxpy (nxis, -1.d0, mut(1,tind(i)), 1, muwk, 1) else call daxpy (nxis, -1.d0, mut, 1, muwk, 1) call daxpy (nxis, -1.d0, mrs2, 1, muwk, 1) call dprmut (muwk, nxis, jpvt, 0) if (cntsum0!=0) call dscal (nxis, dsqrt(dble(cnt0(i))), muwk, 1) call dtrsl (v, nxis, nxis, muwk, 11, infowk) if (nxis-rkv>0) call dset (nxis-rkv, 0.d0, muwk(rkv+1), 1) trc = trc + ddot (nxis, muwk, 1, muwk, 1) } for (i=1;i<=n1;i=i+1) { tmp = dasum (nqd, eta1(1,i), 1) for (j=1;j<=nxis;j=j+1) muwk(j) = ddot (nqd, eta1(1,i), 1, qdrs1(1,j,i), 1) / tmp if (nt>1) call daxpy (nxis, -1.d0, mut(1,tind(n0+i)), 1, muwk, 1) else call daxpy (nxis, -1.d0, mut, 1, muwk, 1) call daxpy (nxis, -1.d0, mrs2, 1, muwk, 1) call dprmut (muwk, nxis, jpvt, 0) if (cntsum1!=0) call dscal (nxis, dsqrt(dble(cnt1(i))), muwk, 1) call dtrsl (v, nxis, nxis, muwk, 11, infowk) if (nxis-rkv>0) call dset (nxis-rkv, 0.d0, muwk(rkv+1), 1) trc = trc + ddot (nxis, muwk, 1, muwk, 1) } for (i=1;i<=n2;i=i+1) { tmp = dasum (nqd, eta2(1,i), 1) for (j=1;j<=nxis;j=j+1) muwk(j) = ddot (nqd, eta2(1,i), 1, qdrs2(1,j,i), 1) / tmp if (nt>1) call daxpy (nxis, -1.d0, mut(1,tind(n0+n1+i)), 1, muwk, 1) else call daxpy (nxis, -1.d0, mut, 1, muwk, 1) call daxpy (nxis, -1.d0, mrs2, 1, muwk, 1) call dprmut (muwk, nxis, jpvt, 0) if (cntsum2!=0) call dscal (nxis, dsqrt(dble(cnt2(i))), muwk, 1) call dtrsl (v, nxis, nxis, muwk, 11, infowk) if (nxis-rkv>0) call dset (nxis-rkv, 0.d0, muwk(rkv+1), 1) trc = trc + ddot (nxis, muwk, 1, muwk, 1) } for (i=1;i<=n3;i=i+1) { for (j=1;j<=nqd;j=j+1) { for (k=1;k<=nqd;k=k+1) wk((k-1)*nqd+j) = eta((k-1)*nqd+j) * wt3(j,1,i) * wt3(k,2,i) } tmp = dasum (nqd*nqd, wk, 1) for (j=1;j<=nxis;j=j+1) muwk(j) = ddot (nqd*nqd, wk, 1, qdrs(j,1), nxis) / tmp if (nt>1) call daxpy (nxis, -1.d0, mut(1,tind(n0+n1+n2+i)), 1, muwk, 1) else call daxpy (nxis, -1.d0, mut, 1, muwk, 1) call daxpy (nxis, -1.d0, mrs2, 1, muwk, 1) call dprmut (muwk, nxis, jpvt, 0) if (cntsum3!=0) call dscal (nxis, dsqrt(dble(cnt3(i))), muwk, 1) call dtrsl (v, nxis, nxis, muwk, 11, infowk) if (nxis-rkv>0) call dset (nxis-rkv, 0.d0, muwk(rkv+1), 1) trc = trc + ddot (nxis, muwk, 1, muwk, 1) } trc = trc / dble(nobs) / (dble(nobs)-1.d0) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, muwk, 1) lkhd = lkhd - ddot (nxi, cdnew, 1, muwk, 1) / 2.d0 mrs(1) = lkhd mrs(2) = trc return end gss/src/ratfor/ddeev.r0000644000176200001440000002343714443702062014417 0ustar liggesusers #::::::::::: # ddeev #::::::::::: subroutine ddeev (vmu, nobs,_ q, ldqr, ldqc, n, nq, u, ldu, uaux, t, x,_ # inputs theta, nlaht, score, varht,_ hes, ldh, gra,_ # outputs hwk1, hwk2, gwk1, gwk2,_ # work arrays kwk, ldk, work1, work2, work3,_ info) # Acronym: Double precision DErivative EValuation. # Purpose: This routine calculates the gradient and the Hessian of # V(theta|lambda) or M(theta|lambda). character*1 vmu integer nobs, ldqr, ldqc, n, nq, ldu, ldh, ldk, info double precision q(ldqr,ldqc,*), u(ldu,*), uaux(*), t(2,*), x(*),_ theta(*), nlaht, score, varht,_ hes(ldh,*), gra(*), hwk1(nq,*), hwk2(nq,*), gwk1(*), gwk2(*),_ kwk(ldk,ldk,*), work1(*), work2(*), work3(*) # On entry: # vmu 'v': GCV criterion. # 'm': GML criterion. # 'u': unbiased risk estimate. # nobs the number of observations. # q F_{2}^{T} Q_{i} F_{2}, of size (n,n,nq). # n the size of q. # nq the number of Q_{i}'s. # u,uaux Householder vectors of U, of size (n-1,n-2), # where U^{T}DU is tridiagonal. # t U^{T} (D-n\lambda I) U in packed form, of size (2,n). # x U^{T}z = U^{T}F_{2}^{T}y, of size (n). # theta the current log(theta) for the D matrix, of dimension (nq). # nlaht the estimated log10(n*lambda) in the current model. # score the minimum GCV/GML score found at (theta, nlaht). # varht the variance estimate at (theta, nlaht). # On exit: # hes Hessian at point (theta, nlaht), of size (nq,nq). # gra gradient at point (theta, nlaht), of size (nq). # info 0 : normal termination. # -1 : dimension error. # -2 : D !>= 0. # -3 : tuning parameters are out of scope. # Work arrays: # hwk1,2 of sizes at least (nq,nq). # gwk1,2 of sizes at least (nq). # kwk of size at least (n,n,nq). # work1-3 of sizes at least (n). # Routines called directly: # Fortran -- dble # Blas -- daxpy, dcopy, ddot, dscal # Blas2 -- dgemv # Linpack -- dpbfa, dpbsl, dqrsl # Rkpack -- dqrslm # Other -- dset # Written: Chong Gu, Statistics, Purdue, latest version 12/29/91. double precision trc, det, dum, ddot integer i, j, m info = 0 call dset (nq, 0.d0, gra, 1) call dset (nq*nq, 0.d0, hes, 1) # check tuning parameters if ( vmu != 'v' & vmu != 'm' & vmu != 'u' ) { info = -3 return } # check dimension if ( nobs < n | ldqr < n | ldqc < n | nq <= 0 | ldu < n-1 | ldh < nq | ldk < n ) { info = -1 return } # compute K_{i} = U^{T}(\theta_{i}Q_{i})U for (i=2;i<=nq;i=i+1) { # from i=2 to nq if ( theta(i) <= -25.d0 ) next for (j=1;j<=n;j=j+1) { call dcopy (n-j+1, q(j,j,i), 1, kwk(j,j,i), 1) call dscal (n-j+1, 10.d0 ** theta(i), kwk(j,j,i), 1) } call dqrslm (u, ldu, n-1, n-2, uaux, kwk(2,2,i), n, 0, info, work1) call dqrsl (u, ldu, n-1, n-2, uaux, kwk(2,1,i), dum, kwk(2,1,i),_ dum, dum, dum, 01000, info) } # compute K_{1} through the identity: U^{T}(\sum K_{i})U = T call dcopy (n, t(2,1), 2, kwk(1,1,1), n+1) call dcopy (n-1, t(1,2), 2, kwk(2,1,1), n+1) for (j=1;j0: S is not of full rank: rank(S)+1 . # -1: dimension error. # -2: F_{2}^{T} Q F_{2} is not non-negative definite. # inputs intact but UPPER-RIGHT corner of q was used as work array. # Work array: # wk of size at least (2,nobs-nnull). # Routines called directly: # Blas -- daxpy, dcopy, ddot # Linpack -- dpbfa, dpbsl, dqrsl, dtrsl # Other -- dprmut, dset # Written: Chong Gu, Statistics, Purdue, latest version 4/17/92. double precision dum, ddot integer i, j, n, n0 info = 0 # check dimension if ( nnull < 1 | nnull >= nobs | nobs > lds | nobs > ldq | ldsms < nnull ) { info = -1 return } # set working parameters n0 = nnull n = nobs - nnull # compute sms # U^{T} (F_{2}^{T} Q F_{1}) call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) for (j=1;j<=n0;j=j+1) { call dcopy (n, q(n0+1,j), 1, q(j,n0+1), ldq) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, q(n0+2,j), dum, q(n0+2,j), dum, dum, dum, 01000, info) } # U^{T} (F_{2}^{T}QF_{2} + n lambda I)^{-1} (F_{2}^{T}QF_{1}) call dset (n, 10.d0 ** nlaht, wk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, wk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, wk(1,2), 2) call dpbfa (wk, 2, n, 1, info) if ( info != 0 ) { info = -2 return } for (j=1;j<=n0;j=j+1) call dpbsl (wk, 2, n, 1, q(n0+1,j)) # (F_{2}^{T}QF_{2} + n lambda I)^{-1} (F_{2}^{T}QF_{1}) call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) for (j=1;j<=n0;j=j+1) { call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, q(n0+2,j), q(n0+2,j),_ dum, dum, dum, dum, 10000, info) } # (F_{1}^{T}QF_{1} + n lambda I) - # (F_{1}^{T}QF_{2}^{T}) (F_{2}^{T}QF_{2} + n lambda I)^{-1} (F_{2}^{T}QF_{1}) for (i=1;i<=n0;i=i+1) { for (j=1;j #include // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .C calls */ extern void quad_smolyak(void *, void *, void *, void *); extern void size_smolyak(void *, void *, void *); /* .Fortran calls */ extern void F77_NAME(cdennewton)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(cdennewton10)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(cdenrkl)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(copu2newton)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void*); extern void F77_NAME(coxaux)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(dcrdr)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(dmudr0)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(dnewton)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(dnewton10)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(drkl)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(dsidr0)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(dsms)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(gaussq)(void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(hrkl)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(hzdaux1)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(hzdaux101)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(hzdaux2)(void *, void *, void *, void *, void *, void *); extern void F77_NAME(hzdnewton)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(hzdnewton10)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(llrmaux)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(llrmnewton)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(llrmrkl)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(reg)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(regaux)(void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(dmcdc)(void *, void *, void *, void *, void *, void *); static const R_CMethodDef CEntries[] = { {"quad_smolyak", (DL_FUNC) &quad_smolyak, 4}, {"size_smolyak", (DL_FUNC) &size_smolyak, 3}, {NULL, NULL, 0} }; static const R_FortranMethodDef FortranEntries[] = { {"cdennewton", (DL_FUNC) &F77_NAME(cdennewton), 19}, {"cdennewton10", (DL_FUNC) &F77_NAME(cdennewton10), 15}, {"cdenrkl", (DL_FUNC) &F77_NAME(cdenrkl), 20}, {"copu2newton", (DL_FUNC) &F77_NAME(copu2newton), 34}, {"coxaux", (DL_FUNC) &F77_NAME(coxaux), 16}, {"dcrdr", (DL_FUNC) &F77_NAME(dcrdr), 18}, {"dmudr0", (DL_FUNC) &F77_NAME(dmudr0), 23}, {"dnewton", (DL_FUNC) &F77_NAME(dnewton), 19}, {"dnewton10", (DL_FUNC) &F77_NAME(dnewton10), 15}, {"drkl", (DL_FUNC) &F77_NAME(drkl), 14}, {"dsidr0", (DL_FUNC) &F77_NAME(dsidr0), 20}, {"dsms", (DL_FUNC) &F77_NAME(dsms), 12}, {"gaussq", (DL_FUNC) &F77_NAME(gaussq), 9}, {"hrkl", (DL_FUNC) &F77_NAME(hrkl), 19}, {"hzdaux1", (DL_FUNC) &F77_NAME(hzdaux1), 13}, {"hzdaux101", (DL_FUNC) &F77_NAME(hzdaux101), 10}, {"hzdaux2", (DL_FUNC) &F77_NAME(hzdaux2), 6}, {"hzdnewton", (DL_FUNC) &F77_NAME(hzdnewton), 19}, {"hzdnewton10", (DL_FUNC) &F77_NAME(hzdnewton10), 17}, {"llrmaux", (DL_FUNC) &F77_NAME(llrmaux), 16}, {"llrmnewton", (DL_FUNC) &F77_NAME(llrmnewton), 19}, {"llrmrkl", (DL_FUNC) &F77_NAME(llrmrkl), 21}, {"reg", (DL_FUNC) &F77_NAME(reg), 18}, {"regaux", (DL_FUNC) &F77_NAME(regaux), 9}, {"dmcdc", (DL_FUNC) &F77_NAME(dmcdc), 6}, {NULL, NULL, 0} }; void R_init_gss(DllInfo *dll) { R_registerRoutines(dll, CEntries, NULL, FortranEntries, NULL); R_useDynamicSymbols(dll, FALSE); } gss/src/hzdaux.f0000644000176200001440000002125614443702024013315 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine hzdaux1 (cd, nxis, q, nxi, qdrs, nqd, qdwt, nx, mchpr, *wt, v, vwk, jpvt) integer nxis, nxi, nqd, nx, jpvt(*) double precision cd(*), q(nxi,*), qdrs(nqd,nxis,*), qdwt(nqd,*), m *chpr, wt(nqd,*), v(nxis,*), vwk(nxis,*) integer i, j, k, kk, rkv double precision ddot kk=1 23000 if(.not.(kk.le.nx))goto 23002 i=1 23003 if(.not.(i.le.nqd))goto 23005 wt(i,kk) = qdwt(i,kk) * dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1 *)) 23004 i=i+1 goto 23003 23005 continue 23001 kk=kk+1 goto 23000 23002 continue call dset (nxis*nxis, 0.d0, v, 1) kk=1 23006 if(.not.(kk.le.nx))goto 23008 i=1 23009 if(.not.(i.le.nxis))goto 23011 j=i 23012 if(.not.(j.le.nxis))goto 23014 vwk(i,j) = 0.d0 k=1 23015 if(.not.(k.le.nqd))goto 23017 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23016 k=k+1 goto 23015 23017 continue 23013 j=j+1 goto 23012 23014 continue 23010 i=i+1 goto 23009 23011 continue call daxpy (nxis*nxis, 1.d0, vwk, 1, v, 1) 23007 kk=kk+1 goto 23006 23008 continue i=1 23018 if(.not.(i.le.nxi))goto 23020 j=i 23021 if(.not.(j.le.nxi))goto 23023 v(i,j) = v(i,j) + q(i,j) 23022 j=j+1 goto 23021 23023 continue 23019 i=i+1 goto 23018 23020 continue i=1 23024 if(.not.(i.le.nxis))goto 23026 jpvt(i) = 0 23025 i=i+1 goto 23024 23026 continue call dchdc (v, nxis, nxis, vwk, jpvt, 1, rkv) 23027 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23027 endif 23028 continue i=rkv+1 23029 if(.not.(i.le.nxis))goto 23031 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23030 i=i+1 goto 23029 23031 continue return end subroutine hzdaux2 (v, nxis, jpvt, r, nr, se) double precision v(nxis,*), r(nxis,*), se(*) integer nxis, jpvt(*), nr double precision ddot integer i, infowk i=1 23032 if(.not.(i.le.nr))goto 23034 call dprmut (r(1,i), nxis, jpvt, 0) call dtrsl (v, nxis, nxis, r(1,i), 11, infowk) se(i) = dsqrt (ddot (nxis, r(1,i), 1, r(1,i), 1)) 23033 i=i+1 goto 23032 23034 continue return end subroutine hrkl (cd, nxis, qdrs, nqd, nx, qdwt, wt0, mchpr, wt, mu *, mu0, v, jpvt, wk, cdnew, wtnew, prec, maxiter, info) integer nxis, nqd, nx, jpvt(*), maxiter, info double precision cd(*), qdrs(nqd,nxis,*), qdwt(nqd,*), wt0(nqd,*), * mchpr, wt(nqd,*), mu(*), mu0(*), v(nxis,*), wk(*), cdnew(*), wtne *w(nqd,*), prec integer i, j, k, kk, idamax, iter, flag, infowk double precision tmp, ddot, dasum, rkl, mumax, rklnew, disc, disc0 info = 0 call dset (nxis, 0.d0, mu0, 1) kk=1 23035 if(.not.(kk.le.nx))goto 23037 i=1 23038 if(.not.(i.le.nxis))goto 23040 mu0(i) = mu0(i) + ddot (nqd, wt0(1,kk), 1, qdrs(1,i,kk), 1) 23039 i=i+1 goto 23038 23040 continue 23036 kk=kk+1 goto 23035 23037 continue rkl = 0.d0 kk=1 23041 if(.not.(kk.le.nx))goto 23043 i=1 23044 if(.not.(i.le.nqd))goto 23046 tmp = ddot (nxis, qdrs(i,1,kk), nqd, cd, 1) wt(i,kk) = qdwt(i,kk) * dexp (tmp) rkl = rkl + (wt(i,kk) - wt0(i,kk)*tmp) 23045 i=i+1 goto 23044 23046 continue 23042 kk=kk+1 goto 23041 23043 continue iter = 0 flag = 0 23047 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23050 if(.not.(kk.le.nx))goto 23052 i=1 23053 if(.not.(i.le.nxis))goto 23055 mu(i) = mu(i) - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) j=i 23056 if(.not.(j.le.nxis))goto 23058 k=1 23059 if(.not.(k.le.nqd))goto 23061 v(i,j) = v(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23060 k=k+1 goto 23059 23061 continue 23057 j=j+1 goto 23056 23058 continue 23054 i=i+1 goto 23053 23055 continue 23051 kk=kk+1 goto 23050 23052 continue call daxpy (nxis, 1.d0, mu0, 1, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23062 if(.not.(i.le.nxis))goto 23064 jpvt(i) = 0 23063 i=i+1 goto 23062 23064 continue call dmcdc (v, nxis, nxis, wk, jpvt, infowk) 23065 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) rklnew = 0.d0 kk=1 23068 if(.not.(kk.le.nx))goto 23070 i=1 23071 if(.not.(i.le.nqd))goto 23073 tmp = ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23073 endif wtnew(i,kk) = qdwt(i,kk) * dexp (tmp) rklnew = rklnew + (wtnew(i,kk) - wt0(i,kk)*tmp) 23072 i=i+1 goto 23071 23073 continue 23069 kk=kk+1 goto 23068 23070 continue if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) rkl = dasum (nqd*nx, qdwt, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) iter = 0 goto 23067 endif if(rklnew-rkl.lt.1.d1*(1.d0+dabs(rkl))*mchpr)then goto 23067 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23067 endif 23066 goto 23065 23067 continue if(flag.eq.1)then flag = 2 goto 23048 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23086 if(.not.(kk.le.nx))goto 23088 i=1 23089 if(.not.(i.le.nqd))goto 23091 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23090 i=i+1 goto 23089 23091 continue 23087 kk=kk+1 goto 23086 23088 continue disc = dmax1 (disc, (mumax/(1.d0+rkl))**2) disc0 = dmax1 ((mumax/(1.d0+rkl))**2, dabs(rkl-rklnew)/(1+dabs(rkl *))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) rkl = rklnew if(disc0.lt.prec)then goto 23049 endif if(disc.lt.prec)then goto 23049 endif if(iter.lt.maxiter)then goto 23048 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) rkl = dasum (nqd*nx, qdwt, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) iter = 0 flag = 2 else info = 2 goto 23049 endif 23048 goto 23047 23049 continue kk=1 23100 if(.not.(kk.le.nx))goto 23102 i=1 23103 if(.not.(i.le.nqd))goto 23105 wt0(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) 23104 i=i+1 goto 23103 23105 continue 23101 kk=kk+1 goto 23100 23102 continue return end subroutine coxaux (cd, nn, q, nxiz, qdrs, nqd, nt, twt, mchpr, qdw *t, wt, wtsum, muwk, v, vwk, jpvt) integer nn, nxiz, nqd, nt, jpvt(*) double precision cd(*), q(nxiz,*), qdrs(nqd,*), twt(*), mchpr, qdw *t(nqd,*), wt(nqd,*), wtsum(*), muwk(*), v(nn,*), vwk(nn,*) integer i, j, k, m, rkv double precision ddot, tmp call dset(nt, 0.d0, wtsum, 1) i=1 23106 if(.not.(i.le.nqd))goto 23108 tmp = dexp (ddot (nn, qdrs(i,1), nqd, cd, 1)) m=1 23109 if(.not.(m.le.nt))goto 23111 wt(i,m) = qdwt(i,m) * tmp wtsum(m) = wtsum(m) + wt(i,m) 23110 m=m+1 goto 23109 23111 continue 23107 i=i+1 goto 23106 23108 continue call dset(nn*nn, 0.d0, v, 1) m=1 23112 if(.not.(m.le.nt))goto 23114 i=1 23115 if(.not.(i.le.nn))goto 23117 muwk(i) = ddot (nqd, wt(1,m), 1, qdrs(1,i), 1) / wtsum(m) 23116 i=i+1 goto 23115 23117 continue i=1 23118 if(.not.(i.le.nn))goto 23120 j=i 23121 if(.not.(j.le.nn))goto 23123 vwk(i,j) = 0.d0 k=1 23124 if(.not.(k.le.nqd))goto 23126 vwk(i,j) = vwk(i,j) + wt(k,m) * qdrs(k,i) * qdrs(k,j) 23125 k=k+1 goto 23124 23126 continue vwk(i,j) = vwk(i,j) / wtsum(m) - muwk(i) * muwk(j) 23122 j=j+1 goto 23121 23123 continue 23119 i=i+1 goto 23118 23120 continue call daxpy (nn*nn, twt(m), vwk, 1, v, 1) 23113 m=m+1 goto 23112 23114 continue i=1 23127 if(.not.(i.le.nxiz))goto 23129 j=i 23130 if(.not.(j.le.nxiz))goto 23132 v(i,j) = v(i,j) + q(i,j) 23131 j=j+1 goto 23130 23132 continue 23128 i=i+1 goto 23127 23129 continue i=1 23133 if(.not.(i.le.nn))goto 23135 jpvt(i) = 0 23134 i=i+1 goto 23133 23135 continue call dchdc (v, nn, nn, vwk, jpvt, 1, rkv) 23136 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23136 endif 23137 continue i=rkv+1 23138 if(.not.(i.le.nn))goto 23140 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23139 i=i+1 goto 23138 23140 continue return end gss/src/dmudr1.f0000644000176200001440000001613614464250716013220 0ustar liggesusersC Output from Public domain Ratfor, version 1.04 subroutine dmudr1 (vmu, s, lds, nobs, nnull, q, ldqr, ldqc, nq, y, * tol, init, prec, maxite, theta, nlaht, score, varht, c, d, qraux, * jpvt, twk, traux, qwk, ywk, thewk, hes, gra, hwk1, hwk2, gwk1, gw *k2, pvtwk, kwk, work1, work2, info) integer lds, nobs, nnull, ldqr, ldqc, nq, init, maxite, jpvt(*), p *vtwk(*), info double precision s(lds,*), q(ldqr,ldqc,*), y(*), tol, prec, theta( **), nlaht, score, varht, c(*), d(*), qraux(*), traux(*), twk(2,*), * qwk(ldqr,*), ywk(*), thewk(*), hes(nq,*), gra(*), hwk1(nq,*), hwk *2(nq,*), gwk1(*), gwk2(*), kwk(nobs-nnull,nobs-nnull,*), work1(*), * work2(*) character vmu double precision alph, scrold, scrwk, nlawk, limnla(2), tmp, dasum *, ddot integer n, n0, i, j, iwk, maxitwk, idamax, job info = 0 n0 = nnull n = nobs - nnull maxitwk = maxite if( (vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u') .or. (ini *t .ne. 0 .and. init .ne. 1) .or. (maxitwk .le.0) .or. (prec .le. 0 *.d0) )then info = -3 return endif if( lds .lt. nobs .or. nobs .le. n0 .or. n0 .lt. 1 .or. ldqr .lt. *nobs .or. ldqc .lt. nobs .or. nq .le. 0 )then info = -1 return endif call dstup (s, lds, nobs, n0, qraux, jpvt, y, q, ldqr, ldqc, nq, i *nfo, work1) if( info .ne. 0 )then return endif if( init .eq. 1 )then call dcopy (nq, theta, 1, thewk, 1) else i=1 23008 if(.not.(i.le.nq))goto 23010 thewk(i) = dasum (n, q(n0+1,n0+1,i), ldqr+1) if( thewk(i) .gt. 0.d0 )then thewk(i) = 1.d0 / thewk(i) endif 23009 i=i+1 goto 23008 23010 continue j=1 23013 if(.not.(j.le.nobs))goto 23015 call dset (nobs-j+1, 0.d0, qwk(j,j), 1) 23014 j=j+1 goto 23013 23015 continue i=1 23016 if(.not.(i.le.nq))goto 23018 j=1 23019 if(.not.(j.le.nobs))goto 23021 call daxpy (nobs-j+1, thewk(i), q(j,j,i), 1, qwk(j,j), 1) 23020 j=j+1 goto 23019 23021 continue 23017 i=i+1 goto 23016 23018 continue call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, 0, limnla, nlawk, *scrwk, varht, info, twk, work1) if(info .ne. 0 )then return endif call dcoef (s, lds, nobs, n0, qraux, jpvt, ywk, qwk, ldqr, nlawk, *c, d, info, twk) call dqrsl (s, lds, nobs, n0, qraux, c, tmp, c, tmp, tmp, tmp, 010 *00, info) i=1 23024 if(.not.(i.le.nq))goto 23026 call dsymv('l', n, thewk(i), q(n0+1,n0+1,i), ldqr, c(n0+1), 1, 0.d *0, work1, 1) thewk(i) = ddot (n, c(n0+1), 1, work1, 1) * thewk(i) if( thewk(i) .gt. 0.d0 )then thewk(i) = dlog10 (thewk(i)) else thewk(i) = -25.d0 endif 23025 i=i+1 goto 23024 23026 continue endif scrold = 1.d10 job = 0 23029 continue if( nq .eq. 1 )then theta(1) = 0.d0 goto 23031 endif j=1 23034 if(.not.(j.le.nobs))goto 23036 call dset (nobs-j+1, 0.d0, qwk(j,j), 1) 23035 j=j+1 goto 23034 23036 continue i=1 23037 if(.not.(i.le.nq))goto 23039 if( thewk(i) .le. -25.d0 )then goto 23038 endif j=1 23042 if(.not.(j.le.nobs))goto 23044 call daxpy (nobs-j+1, 10.d0 ** thewk(i), q(j,j,i), 1, qwk(j,j), 1) 23043 j=j+1 goto 23042 23044 continue 23038 i=i+1 goto 23037 23039 continue call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, job, limnla, nlawk *, scrwk, varht, info, twk, work1) if(info .ne. 0 )then return endif if( scrold .lt. scrwk )then tmp = dabs (gwk1(idamax (nq, gwk1, 1))) if( alph * tmp .gt. - prec )then info = -5 return endif alph = alph / 2.d0 i=1 23051 if(.not.(i.le.nq))goto 23053 thewk(i) = theta(i) + alph * gwk1(i) 23052 i=i+1 goto 23051 23053 continue goto 23030 endif maxitwk = maxitwk - 1 call dcopy (n-2, qwk(n0+2,n0+1), ldqr+1, traux, 1) call dcopy (n, qwk(n0+1,n0+1), ldqr+1, twk(2,1), 2) call dcopy (n-1, qwk(n0+1,n0+2), ldqr+1, twk(1,2), 2) call ddeev (vmu, nobs, q(n0+1,n0+1,1), ldqr, ldqc, n, nq, qwk(n0+2 *,n0+1), ldqr, traux, twk, ywk(n0+1), thewk, nlawk, scrwk, varht, h *es, nq, gra, hwk1, hwk2, gwk1, gwk2, kwk, n, work1, work2, c, info *) iwk = 0 i=1 23054 if(.not.(i.le.nq))goto 23056 if( thewk(i) .le. -25.d0 )then goto 23055 endif iwk = iwk + 1 call dcopy (nq, hes(1,i), 1, hes(1,iwk), 1) 23055 i=i+1 goto 23054 23056 continue iwk = 0 i=1 23059 if(.not.(i.le.nq))goto 23061 if( thewk(i) .le. -25.d0 )then goto 23060 endif iwk = iwk + 1 call dcopy (nq, hes(i,1), nq, hes(iwk,1), nq) gwk1(iwk) = gra(i) work2(iwk) = gra(i) 23060 i=i+1 goto 23059 23061 continue i=1 23064 if(.not.(i.lt.iwk))goto 23066 call dcopy (iwk-i, hes(i+1,i), 1, hes(i,i+1), nq) 23065 i=i+1 goto 23064 23066 continue call dmcdc (hes, nq, iwk, gwk2, pvtwk, info) call dprmut (gwk1, iwk, pvtwk, 0) call dposl (hes, nq, iwk, gwk1) call dprmut (gwk1, iwk, pvtwk, 1) alph = -1.d0 j = iwk i=nq 23067 if(.not.(i.ge.1))goto 23069 if( thewk(i) .le. -25.0 )then gwk1(i) = 0.d0 else gwk1(i) = gwk1(iwk) iwk = iwk - 1 endif 23068 i=i-1 goto 23067 23069 continue call dscal (nq, 1.d0/dlog(1.d1), gwk1, 1) tmp = dabs (gwk1(idamax (nq, gwk1, 1))) if( tmp .gt. 1.d0 )then call dscal (nq, 1.d0/tmp, gwk1, 1) endif i=1 23074 if(.not.(i.le.nq))goto 23076 if( thewk(i) .le. -25.d0 )then goto 23075 endif thewk(i) = thewk(i) - nlawk 23075 i=i+1 goto 23074 23076 continue call dcopy (nq, thewk, 1, theta, 1) tmp = gra(idamax (nq, gra, 1)) ** 2 if( tmp .lt. prec ** 2 .or. scrold - scrwk .lt. prec * (scrwk + 1. *d0) .and. tmp .lt. prec * (scrwk + 1.d0) ** 2 )then goto 23031 endif if( maxitwk .lt. 1 )then info = -4 return endif scrold = scrwk i=1 23083 if(.not.(i.le.nq))goto 23085 thewk(i) = thewk(i) + alph * gwk1(i) 23084 i=i+1 goto 23083 23085 continue job = -1 limnla(1) = -1.d0 limnla(2) = 1.d0 23030 goto 23029 23031 continue j=1 23086 if(.not.(j.le.nobs))goto 23088 call dset (nobs-j+1, 0.d0, qwk(j,j), 1) 23087 j=j+1 goto 23086 23088 continue i=1 23089 if(.not.(i.le.nq))goto 23091 if( theta(i) .le. -25.d0 )then goto 23090 endif j=1 23094 if(.not.(j.le.nobs))goto 23096 call daxpy (nobs-j+1, 10.d0 ** theta(i), q(j,j,i), 1, qwk(j,j), 1) 23095 j=j+1 goto 23094 23096 continue 23090 i=i+1 goto 23089 23091 continue call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, job, limnla, nlaht *, score, varht, info, twk, work1) if(info .ne. 0 )then return endif call dcoef (s, lds, nobs, n0, qraux, jpvt, ywk, qwk, ldqr, nlaht, *c, d, info, twk) return end gss/src/drkl.f0000644000176200001440000001646614443702023012754 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine drkl (cd, nxis, qdrs, nqd, nt, bwt, qdwt, wt0, mchpr, p *rec, maxiter, jpvt, wk, info) integer nxis, nqd, nt, maxiter, jpvt(*), info double precision cd(*), qdrs(nqd,*), bwt(*), qdwt(nt,*), wt0(*), m *chpr, prec, wk(*) integer imrs, iwt, iwtsum, imu, imuwk, iv, ivwk, icdnew, iwtnew, i *wtnewsum imrs = 1 iwt = imrs + nxis iwtsum = iwt + nt*nqd imu = iwtsum + nt imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis iwtnewsum = iwtnew + nt*nqd call drkl1 (cd, nxis, qdrs, nqd, nt, bwt, qdwt, wt0, mchpr, prec, *maxiter, wk(imrs), wk(iwt), wk(iwtsum), wk(imu), wk(imuwk), wk(iv) *, wk(ivwk), jpvt, wk(icdnew), wk(iwtnew), wk(iwtnewsum), info) return end subroutine drkl1 (cd, nxis, qdrs, nqd, nt, bwt, qdwt, wt0, mchpr, *prec, maxiter, mrs, wt, wtsum, mu, muwk, v, vwk, jpvt, cdnew, wtne *w, wtnewsum, info) integer nxis, nqd, nt, maxiter, jpvt(*), info double precision cd(*), qdrs(nqd,*), bwt(*), qdwt(nt,*), wt0(*), m *chpr, mrs(*), wt(nt,*), wtsum(*), mu(*), muwk(*), v(nxis,*), vwk(n *xis,*), cdnew(*), wtnew(nt,*), wtnewsum(*), prec integer i, j, k, m, iter, flag, idamax, infowk double precision tmp, ddot, rkl, rklnew, mumax, disc info = 0 call dset (nxis, 0.d0, mrs, 1) m=1 23000 if(.not.(m.le.nt))goto 23002 i=1 23003 if(.not.(i.le.nqd))goto 23005 wt(m,i) = qdwt(m,i) * wt0(i) 23004 i=i+1 goto 23003 23005 continue i=1 23006 if(.not.(i.le.nxis))goto 23008 muwk(i) = ddot (nqd, qdrs(1,i), 1, wt(m,1), nt) 23007 i=i+1 goto 23006 23008 continue call daxpy (nxis, bwt(m), muwk, 1, mrs, 1) wtsum(m) = 0.d0 23001 m=m+1 goto 23000 23002 continue i=1 23009 if(.not.(i.le.nqd))goto 23011 tmp = dexp (ddot (nxis, qdrs(i,1), nqd, cd, 1)) m=1 23012 if(.not.(m.le.nt))goto 23014 wt(m,i) = qdwt(m,i) * tmp wtsum(m) = wtsum(m) + wt(m,i) 23013 m=m+1 goto 23012 23014 continue 23010 i=i+1 goto 23009 23011 continue rkl = 0.d0 m=1 23015 if(.not.(m.le.nt))goto 23017 tmp = 0.d0 i=1 23018 if(.not.(i.le.nqd))goto 23020 disc = wt0(i) * qdwt(m,i) tmp = tmp + dlog (disc/wt(m,i)) * disc 23019 i=i+1 goto 23018 23020 continue rkl = rkl + bwt(m) * (tmp + dlog (wtsum(m))) 23016 m=m+1 goto 23015 23017 continue iter = 0 flag = 0 23021 continue iter = iter + 1 call dset(nxis, 0.d0, mu, 1) call dset(nxis*nxis, 0.d0, v, 1) m=1 23024 if(.not.(m.le.nt))goto 23026 i=1 23027 if(.not.(i.le.nxis))goto 23029 muwk(i) = - ddot (nqd, wt(m,1), nt, qdrs(1,i), 1) / wtsum(m) 23028 i=i+1 goto 23027 23029 continue i=1 23030 if(.not.(i.le.nxis))goto 23032 j=i 23033 if(.not.(j.le.nxis))goto 23035 vwk(i,j) = 0.d0 k=1 23036 if(.not.(k.le.nqd))goto 23038 vwk(i,j) = vwk(i,j) + wt(m,k) * qdrs(k,i) * qdrs(k,j) 23037 k=k+1 goto 23036 23038 continue vwk(i,j) = vwk(i,j) / wtsum(m) - muwk(i) * muwk(j) 23034 j=j+1 goto 23033 23035 continue 23031 i=i+1 goto 23030 23032 continue call daxpy (nxis, bwt(m), muwk, 1, mu, 1) call daxpy (nxis*nxis, bwt(m), vwk, 1, v, 1) 23025 m=m+1 goto 23024 23026 continue call daxpy (nxis, 1.d0, mrs, 1, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23039 if(.not.(i.le.nxis))goto 23041 jpvt(i) = 0 23040 i=i+1 goto 23039 23041 continue call dmcdc (v, nxis, nxis, muwk, jpvt, infowk) 23042 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) call dset (nt, 0.d0, wtnewsum, 1) i=1 23045 if(.not.(i.le.nqd))goto 23047 tmp = ddot (nxis, qdrs(i,1), nqd, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23047 endif m=1 23050 if(.not.(m.le.nt))goto 23052 wtnew(m,i) = qdwt(m,i) * dexp (tmp) wtnewsum(m) = wtnewsum(m) + wtnew(m,i) 23051 m=m+1 goto 23050 23052 continue 23046 i=i+1 goto 23045 23047 continue rklnew = 0.d0 m=1 23053 if(.not.(m.le.nt))goto 23055 tmp = 0.d0 i=1 23056 if(.not.(i.le.nqd))goto 23058 disc = wt0(i) * qdwt(m,i) tmp = tmp + dlog (disc/wtnew(m,i)) * disc 23057 i=i+1 goto 23056 23058 continue rklnew = rklnew + bwt(m) * (tmp + dlog (wtnewsum(m))) 23054 m=m+1 goto 23053 23055 continue if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) call dset (nt, 0.d0, wtsum, 1) m=1 23061 if(.not.(m.le.nt))goto 23063 i=1 23064 if(.not.(i.le.nqd))goto 23066 wtsum(m) = wtsum(m) + wt(m,i) 23065 i=i+1 goto 23064 23066 continue 23062 m=m+1 goto 23061 23063 continue rkl = 0.d0 m=1 23067 if(.not.(m.le.nt))goto 23069 tmp = 0.d0 i=1 23070 if(.not.(i.le.nqd))goto 23072 tmp = tmp + dlog (wt0(i)) * wt0(i) * qdwt(m,i) 23071 i=i+1 goto 23070 23072 continue rkl = rkl + bwt(m) * (tmp + dlog (wtsum(m))) 23068 m=m+1 goto 23067 23069 continue iter = 0 goto 23044 endif if(rklnew-rkl.lt.1.d1*(1.d0+dabs(rkl))*mchpr)then goto 23044 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23044 endif 23043 goto 23042 23044 continue if(flag.eq.1)then flag = 2 goto 23022 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 i=1 23081 if(.not.(i.le.nqd))goto 23083 m=1 23084 if(.not.(m.le.nt))goto 23086 disc = dmax1 (disc, dabs(wt(m,i)-wtnew(m,i))/(1.d0+dabs(wt(m,i)))) 23085 m=m+1 goto 23084 23086 continue 23082 i=i+1 goto 23081 23083 continue disc = dmax1 (disc, (mumax/(1.d0+rkl))**2) disc = dmax1 (disc, dabs(rkl-rklnew)/(1.d0+dabs(rkl))) if(disc.lt.prec)then goto 23023 endif call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nt*nqd, wtnew, 1, wt, 1) call dcopy (nt, wtnewsum, 1, wtsum, 1) rkl = rklnew if(iter.lt.maxiter)then goto 23022 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) call dset (nt, 0.d0, wtsum, 1) m=1 23093 if(.not.(m.le.nt))goto 23095 i=1 23096 if(.not.(i.le.nqd))goto 23098 wtsum(m) = wtsum(m) + wt(m,i) 23097 i=i+1 goto 23096 23098 continue 23094 m=m+1 goto 23093 23095 continue rkl = 0.d0 m=1 23099 if(.not.(m.le.nt))goto 23101 tmp = 0.d0 i=1 23102 if(.not.(i.le.nqd))goto 23104 tmp = tmp + dlog (wt0(i)) * wt0(i) * qdwt(m,i) 23103 i=i+1 goto 23102 23104 continue rkl = rkl + bwt(m) * (tmp + dlog (wtsum(m))) 23100 m=m+1 goto 23099 23101 continue iter = 0 flag = 2 else info = 2 goto 23023 endif 23022 goto 23021 23023 continue i=1 23105 if(.not.(i.le.nqd))goto 23107 wt0(i) = dexp (ddot (nxis, qdrs(i,1), nqd, cd, 1)) 23106 i=i+1 goto 23105 23107 continue return end gss/src/dchdc0.f0000644000176200001440000001705014456764643013157 0ustar liggesusers subroutine dchdc0(a,lda,p,work,jpvt,job,info) integer lda,p,jpvt(1),job,info double precision a(lda,1),work(1) c c dchdc computes the cholesky decomposition of a positive definite c matrix. a pivoting option allows the user to estimate the c condition of a positive definite matrix or determine the rank c of a positive semidefinite matrix. c c on entry c c a double precision(lda,p). c a contains the matrix whose decomposition is to c be computed. onlt the upper half of a need be stored. c the lower part of the array a is not referenced. c c lda integer. c lda is the leading dimension of the array a. c c p integer. c p is the order of the matrix. c c work double precision. c work is a work array. c c jpvt integer(p). c jpvt contains integers that control the selection c of the pivot elements, if pivoting has been requested. c each diagonal element a(k,k) c is placed in one of three classes according to the c value of jpvt(k). c c if jpvt(k) .gt. 0, then x(k) is an initial c element. c c if jpvt(k) .eq. 0, then x(k) is a free element. c c if jpvt(k) .lt. 0, then x(k) is a final element. c c before the decomposition is computed, initial elements c are moved by symmetric row and column interchanges to c the beginning of the array a and final c elements to the end. both initial and final elements c are frozen in place during the computation and only c free elements are moved. at the k-th stage of the c reduction, if a(k,k) is occupied by a free element c it is interchanged with the largest free element c a(l,l) with l .ge. k. jpvt is not referenced if c job .eq. 0. c c job integer. c job is an integer that initiates column pivoting. c if job .eq. 0, no pivoting is done. c if job .ne. 0, pivoting is done. c c on return c c a a contains in its upper half the cholesky factor c of the matrix a as it has been permuted by pivoting. c c jpvt jpvt(j) contains the index of the diagonal element c of a that was moved into the j-th position, c provided pivoting was requested. c c info contains the index of the last positive diagonal c element of the cholesky factor. c c for positive definite matrices info = p is the normal return. c for pivoting with positive semidefinite matrices info will c in general be less than p. however, info may be greater than c the rank of a, since rounding error can cause an otherwise zero c element to be positive. indefinite systems will always cause c info to be less than p. c c linpack. this version dated 08/14/78 . c j.j. dongarra and g.w. stewart, argonne national laboratory and c university of maryland. c c c blas daxpy,dswap c fortran dsqrt c c internal variables c integer pu,pl,plp1,j,jp,jt,k,kb,km1,kp1,l,maxl double precision temp double precision maxdia logical swapk,negk c pl = 1 pu = 0 info = p if (job .eq. 0) go to 160 c c pivoting has been requested. rearrange the c the elements according to jpvt. c do 70 k = 1, p swapk = jpvt(k) .gt. 0 negk = jpvt(k) .lt. 0 jpvt(k) = k if (negk) jpvt(k) = -jpvt(k) if (.not.swapk) go to 60 if (k .eq. pl) go to 50 call dswap(pl-1,a(1,k),1,a(1,pl),1) temp = a(k,k) a(k,k) = a(pl,pl) a(pl,pl) = temp plp1 = pl + 1 if (p .lt. plp1) go to 40 do 30 j = plp1, p if (j .ge. k) go to 10 temp = a(pl,j) a(pl,j) = a(j,k) a(j,k) = temp go to 20 10 continue if (j .eq. k) go to 20 temp = a(k,j) a(k,j) = a(pl,j) a(pl,j) = temp 20 continue 30 continue 40 continue jpvt(k) = jpvt(pl) jpvt(pl) = k 50 continue pl = pl + 1 60 continue 70 continue pu = p if (p .lt. pl) go to 150 do 140 kb = pl, p k = p - kb + pl if (jpvt(k) .ge. 0) go to 130 jpvt(k) = -jpvt(k) if (pu .eq. k) go to 120 call dswap(k-1,a(1,k),1,a(1,pu),1) temp = a(k,k) a(k,k) = a(pu,pu) a(pu,pu) = temp kp1 = k + 1 if (p .lt. kp1) go to 110 do 100 j = kp1, p if (j .ge. pu) go to 80 temp = a(k,j) a(k,j) = a(j,pu) a(j,pu) = temp go to 90 80 continue if (j .eq. pu) go to 90 temp = a(k,j) a(k,j) = a(pu,j) a(pu,j) = temp 90 continue 100 continue 110 continue jt = jpvt(k) jpvt(k) = jpvt(pu) jpvt(pu) = jt 120 continue pu = pu - 1 130 continue 140 continue 150 continue 160 continue do 270 k = 1, p c c reduction loop. c maxdia = a(k,k) kp1 = k + 1 maxl = k c c determine the pivot element. c if (k .lt. pl .or. k .ge. pu) go to 190 do 180 l = kp1, pu if (a(l,l) .le. maxdia) go to 170 maxdia = a(l,l) maxl = l 170 continue 180 continue 190 continue c c quit if the pivot element is not positive. c if (maxdia .gt. 0.0d0) go to 200 info = k - 1 c ......exit go to 280 200 continue if (k .eq. maxl) go to 210 c c start the pivoting and update jpvt. c km1 = k - 1 call dswap(km1,a(1,k),1,a(1,maxl),1) a(maxl,maxl) = a(k,k) a(k,k) = maxdia jp = jpvt(maxl) jpvt(maxl) = jpvt(k) jpvt(k) = jp 210 continue c c reduction step. pivoting is contained across the rows. c work(k) = dsqrt(a(k,k)) a(k,k) = work(k) if (p .lt. kp1) go to 260 do 250 j = kp1, p if (k .eq. maxl) go to 240 if (j .ge. maxl) go to 220 temp = a(k,j) a(k,j) = a(j,maxl) a(j,maxl) = temp go to 230 220 continue if (j .eq. maxl) go to 230 temp = a(k,j) a(k,j) = a(maxl,j) a(maxl,j) = temp 230 continue 240 continue a(k,j) = a(k,j)/work(k) work(j) = a(k,j) temp = -a(k,j) call daxpy(j-k,temp,work(kp1),1,a(kp1,j),1) 250 continue 260 continue 270 continue 280 continue return end gss/src/dnewton.f0000644000176200001440000002425614466740735013513 0ustar liggesusersC Output from Public domain Ratfor, version 1.04 subroutine dnewton (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qdrs, * nqd, nt, bwt, qdwt, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, nqd, nt, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nxis,*), cntsum, cnt(*), qdrs *(nqd,*), bwt(*), qdwt(nt,*), prec, mchpr, wk(*) integer imrs, iwt, iwtsum, ifit, imu, imuwk, iv, ivwk, icdnew, iwt *new, iwtsumnew, ifitnew, iwk imrs = 1 iwt = imrs + max0 (nxis, 3) iwtsum = iwt + nqd*nt ifit = iwtsum + nt imu = ifit + nobs imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis iwtsumnew = iwtnew + nqd*nt ifitnew = iwtsumnew + nt iwk = ifitnew + nobs call dnewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qdrs, nqd, * nt, bwt, qdwt, prec, maxiter, mchpr, wk(imrs), wk(iwt), wk(iwtsum *), wk(ifit), wk(imu), wk(imuwk), wk(iv), wk(ivwk), jpvt, wk(icdnew *), wk(iwtnew), wk(iwtsumnew), wk(ifitnew), wk(iwk), info) return end subroutine dnewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qdrs *, nqd, nt, bwt, qdwt, prec, maxiter, mchpr, mrs, wt, wtsum, fit, m *u, muwk, v, vwk, jpvt, cdnew, wtnew, wtsumnew, fitnew, wk, info) integer nxis, nxi, nobs, nqd, nt, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nxis,*), cntsum, cnt(*), qdrs *(nqd,*), bwt(*), qdwt(nt,*), prec, mchpr, mrs(*), wt(nt,*), wtsum( **), fit(*), mu(*), muwk(*), v(nxis,*), vwk(nxis,*), cdnew(*), wtne *w(nt,*), wtsumnew(*), fitnew(*), wk(*) integer i, j, k, m, iter, flag, rkv, idamax, infowk double precision norm, tmp, ddot, fitmean, lkhd, mumax, lkhdnew, d *isc, disc0, trc info = 0 i=1 23000 if(.not.(i.le.nxis))goto 23002 mrs(i) = 0.d0 if(.not.(cntsum.gt.0.d0))then j=1 23005 if(.not.(j.le.nobs))goto 23007 mrs(i) = mrs(i) + rs(i,j) 23006 j=j+1 goto 23005 23007 continue mrs(i) = mrs(i) / dble (nobs) else j=1 23008 if(.not.(j.le.nobs))goto 23010 mrs(i) = mrs(i) + rs(i,j) * cnt(j) 23009 j=j+1 goto 23008 23010 continue mrs(i) = mrs(i) / cntsum endif 23001 i=i+1 goto 23000 23002 continue m=1 23011 if(.not.(m.le.nt))goto 23013 wtsum(m) = 0.d0 23012 m=m+1 goto 23011 23013 continue i=1 23014 if(.not.(i.le.nqd))goto 23016 tmp = dexp (ddot (nxis, qdrs(i,1), nqd, cd, 1)) m=1 23017 if(.not.(m.le.nt))goto 23019 wt(m,i) = qdwt(m,i) * tmp wtsum(m) = wtsum(m) + wt(m,i) 23018 m=m+1 goto 23017 23019 continue 23015 i=i+1 goto 23014 23016 continue norm = 0.d0 m=1 23020 if(.not.(m.le.nt))goto 23022 norm = norm + bwt(m) * dlog (wtsum(m)) 23021 m=m+1 goto 23020 23022 continue fitmean = 0.d0 i=1 23023 if(.not.(i.le.nobs))goto 23025 tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if(cntsum.gt.0.d0)then tmp = tmp * cnt(i) endif fitmean = fitmean + tmp 23024 i=i+1 goto 23023 23025 continue if(.not.(cntsum.gt.0.d0))then fitmean = fitmean / dble (nobs) else fitmean = fitmean / cntsum endif call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean + norm iter = 0 flag = 0 23030 continue iter = iter + 1 call dset(nxis, 0.d0, mu, 1) call dset(nxis*nxis, 0.d0, v, 1) m=1 23033 if(.not.(m.le.nt))goto 23035 i=1 23036 if(.not.(i.le.nxis))goto 23038 muwk(i) = - ddot (nqd, wt(m,1), nt, qdrs(1,i), 1) / wtsum(m) 23037 i=i+1 goto 23036 23038 continue i=1 23039 if(.not.(i.le.nxis))goto 23041 j=i 23042 if(.not.(j.le.nxis))goto 23044 vwk(i,j) = 0.d0 k=1 23045 if(.not.(k.le.nqd))goto 23047 vwk(i,j) = vwk(i,j) + wt(m,k) * qdrs(k,i) * qdrs(k,j) 23046 k=k+1 goto 23045 23047 continue vwk(i,j) = vwk(i,j) / wtsum(m) - muwk(i) * muwk(j) 23043 j=j+1 goto 23042 23044 continue 23040 i=i+1 goto 23039 23041 continue call daxpy (nxis, bwt(m), muwk, 1, mu, 1) call daxpy (nxis*nxis, bwt(m), vwk, 1, v, 1) 23034 m=m+1 goto 23033 23035 continue i=1 23048 if(.not.(i.le.nxi))goto 23050 j=i 23051 if(.not.(j.le.nxi))goto 23053 v(i,j) = v(i,j) + q(i,j) 23052 j=j+1 goto 23051 23053 continue 23049 i=i+1 goto 23048 23050 continue call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23054 if(.not.(i.le.nxis))goto 23056 jpvt(i) = 0 23055 i=i+1 goto 23054 23056 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23057 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23057 endif 23058 continue i=rkv+1 23059 if(.not.(i.le.nxis))goto 23061 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23060 i=i+1 goto 23059 23061 continue 23062 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) m=1 23065 if(.not.(m.le.nt))goto 23067 wtsumnew(m) = 0.d0 23066 m=m+1 goto 23065 23067 continue i=1 23068 if(.not.(i.le.nqd))goto 23070 tmp = ddot (nxis, qdrs(i,1), nqd, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23070 endif tmp = dexp (tmp) m=1 23073 if(.not.(m.le.nt))goto 23075 wtnew(m,i) = qdwt(m,i) * tmp wtsumnew(m) = wtsumnew(m) + wtnew(m,i) 23074 m=m+1 goto 23073 23075 continue 23069 i=i+1 goto 23068 23070 continue norm = 0.d0 m=1 23076 if(.not.(m.le.nt))goto 23078 norm = norm + bwt(m) * dlog (wtsumnew(m)) 23077 m=m+1 goto 23076 23078 continue if((flag.eq.0).or.(flag.eq.2))then fitmean = 0.d0 i=1 23081 if(.not.(i.le.nobs))goto 23083 tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23083 endif fitnew(i) = dexp (tmp) if(cntsum.gt.0.d0)then tmp = tmp * cnt(i) endif fitmean = fitmean + tmp 23082 i=i+1 goto 23081 23083 continue if(.not.(cntsum.gt.0.d0))then fitmean = fitmean / dble (nobs) else fitmean = fitmean / cntsum endif call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean + norm endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) lkhd = 0.d0 m=1 23092 if(.not.(m.le.nt))goto 23094 wtsum(m) = 0.d0 i=1 23095 if(.not.(i.le.nqd))goto 23097 wtsum(m) = wtsum(m) + wt(m,i) 23096 i=i+1 goto 23095 23097 continue lkhd = lkhd + bwt(m) * dlog (wtsum(m)) 23093 m=m+1 goto 23092 23094 continue call dset (nobs, 1.d0, fit, 1) iter = 0 goto 23064 endif if(flag.eq.3)then goto 23064 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23064 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23064 endif 23063 goto 23062 23064 continue if(flag.eq.1)then flag = 2 goto 23031 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 i=1 23108 if(.not.(i.le.nqd))goto 23110 m=1 23111 if(.not.(m.le.nt))goto 23113 disc = dmax1 (disc, dabs(wt(m,i)-wtnew(m,i))/(1.d0+dabs(wt(m,i)))) 23112 m=m+1 goto 23111 23113 continue 23109 i=i+1 goto 23108 23110 continue i=1 23114 if(.not.(i.le.nobs))goto 23116 disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) 23115 i=i+1 goto 23114 23116 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1.d0+da *bs(lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nt, wtnew, 1, wt, 1) call dcopy (nt, wtsumnew, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23032 endif if(disc.lt.prec)then goto 23032 endif if(iter.lt.maxiter)then goto 23031 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) lkhd = 0.d0 m=1 23125 if(.not.(m.le.nt))goto 23127 wtsum(m) = 0.d0 i=1 23128 if(.not.(i.le.nqd))goto 23130 wtsum(m) = wtsum(m) + wt(m,i) 23129 i=i+1 goto 23128 23130 continue lkhd = lkhd + bwt(m) * dlog (wtsum(m)) 23126 m=m+1 goto 23125 23127 continue call dset (nobs, 1.d0, fit, 1) iter = 0 flag = 2 else info = 2 goto 23032 endif 23031 goto 23030 23032 continue i=1 23131 if(.not.(i.le.nobs))goto 23133 call daxpy (nxis, -1.d0, mrs, 1, rs(1,i), 1) call dprmut (rs(1,i), nxis, jpvt, 0) if(cntsum.gt.0.d0)then call dscal (nxis, dsqrt(cnt(i)), rs(1,i), 1) endif call dtrsl (v, nxis, nxis, rs(1,i), 11, infowk) if(nxis-rkv.gt.0)then call dset (nxis-rkv, 0.d0, rs(rkv+1,i), 1) endif 23132 i=i+1 goto 23131 23133 continue trc = ddot (nobs*nxis, rs, 1, rs, 1) if(.not.(cntsum.gt.0.d0))then trc = trc / dble(nobs) / (dble(nobs)-1.d0) lkhd = 0.d0 i=1 23140 if(.not.(i.le.nobs))goto 23142 lkhd = lkhd + dlog (fit(i)) 23141 i=i+1 goto 23140 23142 continue lkhd = lkhd / dble (nobs) else trc = trc / cntsum / (cntsum-1.d0) lkhd = 0.d0 i=1 23143 if(.not.(i.le.nobs))goto 23145 lkhd = lkhd + cnt(i) * dlog (fit(i)) 23144 i=i+1 goto 23143 23145 continue lkhd = lkhd / cntsum endif m=1 23146 if(.not.(m.le.nt))goto 23148 lkhd = lkhd - bwt(m) * dlog (wtsum(m)) 23147 m=m+1 goto 23146 23148 continue mrs(1) = lkhd mrs(2) = trc return end gss/src/copu2newton.f0000644000176200001440000005004714443702023014274 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine copu2newton (cd, nxis, q, nxi, rs0, n0, cntsum0, cnt0, *qdrs, nqd, qdrs1, wt1, n1, cntsum1, cnt1, qdrs2, wt2, n2, cntsum2, * cnt2, wt3, n3, cntsum3, cnt3, nt, twt, qdwt, tind, prec, maxiter, * mchpr, jpvt, wk, info) integer nxis, nxi, n0, cntsum0, cnt0(*), nqd, n1, cntsum1, cnt1(*) *, n2, cntsum2, cnt2(*), n3, cntsum3, cnt3(*), nt, tind(*), maxiter *, jpvt(*), info double precision cd(*), q(nxi,*), rs0(nxis,*), qdrs(nxis,*), qdrs1 *(nqd,nxis,*), wt1(nqd,*), qdrs2(nqd,nxis,*), wt2(nqd,*), wt3(nqd,2 *,*), twt(*), qdwt(nqd,2,*), prec, mchpr, wk(*) integer imrs, imrs2, ieta, ieta1, ieta2, imu, imuwk, iv, ivwk, icd *new, imut, iwk imrs = 1 imrs2 = imrs + nxis ieta = imrs2 + nxis ieta1 = ieta + nqd*nqd ieta2 = ieta1 + nqd*n1 imu = ieta2 + nqd*n2 imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis imut = icdnew + nxis iwk = imut + nxis*nt call copu2newton1 (cd, nxis, q, nxi, rs0, n0, cntsum0, cnt0, qdrs, * nqd, qdrs1, wt1, n1, cntsum1, cnt1, qdrs2, wt2, n2, cntsum2, cnt2 *, wt3, n3, cntsum3, cnt3, nt, twt, qdwt, tind, prec, maxiter, mchp *r, wk(imrs), wk(imrs2), wk(ieta), wk(ieta1), wk(ieta2), wk(imu), w *k(imuwk), wk(iv), wk(ivwk), jpvt, wk(icdnew), wk(imut), wk(iwk), i *nfo) return end subroutine copu2newton1 (cd, nxis, q, nxi, rs0, n0, cntsum0, cnt0, * qdrs, nqd, qdrs1, wt1, n1, cntsum1, cnt1, qdrs2, wt2, n2, cntsum2 *, cnt2, wt3, n3, cntsum3, cnt3, nt, twt, qdwt, tind, prec, maxiter *, mchpr, mrs, mrs2, eta, eta1, eta2, mu, muwk, v, vwk, jpvt, cdnew *, mut, wk, info) integer nxis, nxi, n0, cntsum0, cnt0(*), nqd, n1, cntsum1, cnt1(*) *, n2, cntsum2, cnt2(*), n3, cntsum3, cnt3(*), nt, tind(*), maxiter *, jpvt(*), info double precision cd(*), q(nxi,*), rs0(nxis,*), qdrs(nxis,*), qdrs1 *(nqd,nxis,*), wt1(nqd,*), qdrs2(nqd,nxis,*), wt2(nqd,*), wt3(nqd,2 *,*), twt(*), qdwt(nqd,2,*), prec, mchpr, mrs(*), mrs2(*), eta(*), *eta1(nqd,*), eta2(nqd,*), mu(*), muwk(*), v(nxis,*), vwk(nxis,*), *cdnew(*), mut(nxis,*), wk(*) integer nobs, i, j, k, kk, iter, flag, rkv, idamax, infowk double precision tmp, ddot, dasum, lkhd, mumax, lkhdnew, disc, dis *c0, trc info = 0 if(cntsum0.eq.0)then nobs = n0 else nobs = cntsum0 endif if(cntsum1.eq.0)then nobs = nobs + n1 else nobs = nobs + cntsum1 endif if(cntsum2.eq.0)then nobs = nobs + n2 else nobs = nobs + cntsum2 endif if(cntsum3.eq.0)then nobs = nobs + n3 else nobs = nobs + cntsum3 endif i=1 23008 if(.not.(i.le.nxis))goto 23010 mrs(i) = 0.d0 j=1 23011 if(.not.(j.le.n0))goto 23013 if(cntsum0.eq.0)then mrs(i) = mrs(i) + rs0(i,j) else mrs(i) = mrs(i) + rs0(i,j) * dble (cnt0(j)) endif 23012 j=j+1 goto 23011 23013 continue 23009 i=i+1 goto 23008 23010 continue i=1 23016 if(.not.(i.le.nqd*nqd))goto 23018 eta(i) = dexp (ddot (nxis, qdrs(1,i), 1, cd, 1)) 23017 i=i+1 goto 23016 23018 continue lkhd = 0.d0 i=1 23019 if(.not.(i.le.n0))goto 23021 tmp = ddot (nxis, rs0(1,i), 1, cd, 1) if(cntsum0.ne.0)then tmp = tmp * dble (cnt0(i)) endif lkhd = lkhd - tmp 23020 i=i+1 goto 23019 23021 continue i=1 23024 if(.not.(i.le.n1))goto 23026 j=1 23027 if(.not.(j.le.nqd))goto 23029 eta1(j,i) = dexp (ddot (nxis, qdrs1(j,1,i), nqd, cd, 1)) * wt1(j,i *) 23028 j=j+1 goto 23027 23029 continue if(cntsum1.eq.0)then lkhd = lkhd - dlog (dasum (nqd, eta1(1,i), 1)) else lkhd = lkhd - dlog (dasum (nqd, eta1(1,i), 1)) * dble (cnt1(i)) endif 23025 i=i+1 goto 23024 23026 continue i=1 23032 if(.not.(i.le.n2))goto 23034 j=1 23035 if(.not.(j.le.nqd))goto 23037 eta2(j,i) = dexp (ddot (nxis, qdrs2(j,1,i), nqd, cd, 1)) * wt2(j,i *) 23036 j=j+1 goto 23035 23037 continue if(cntsum2.eq.0)then lkhd = lkhd - dlog (dasum (nqd, eta2(1,i), 1)) else lkhd = lkhd - dlog (dasum (nqd, eta2(1,i), 1)) * dble (cnt2(i)) endif 23033 i=i+1 goto 23032 23034 continue i=1 23040 if(.not.(i.le.n3))goto 23042 tmp = 0.d0 j=1 23043 if(.not.(j.le.nqd))goto 23045 tmp = tmp + ddot (nqd, eta((j-1)*nqd+1), 1, wt3(1,1,i), 1) * wt3(j *,2,i) 23044 j=j+1 goto 23043 23045 continue if(cntsum3.eq.0)then lkhd = lkhd - dlog (tmp) else lkhd = lkhd - dlog (tmp) * dble (cnt3(i)) endif 23041 i=i+1 goto 23040 23042 continue lkhd = lkhd / dble (nobs) i=1 23048 if(.not.(i.le.nt))goto 23050 tmp = 0.d0 j=1 23051 if(.not.(j.le.nqd))goto 23053 tmp = tmp + ddot (nqd, eta((j-1)*nqd+1), 1, qdwt(1,1,i), 1) * qdwt *(j,2,i) 23052 j=j+1 goto 23051 23053 continue lkhd = lkhd + dlog (tmp) * twt(i) 23049 i=i+1 goto 23048 23050 continue call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, muwk, 1) lkhd = lkhd + ddot (nxi, cd, 1, muwk, 1) / 2.d0 iter = 0 flag = 0 23054 continue iter = iter + 1 call dcopy (nxis, mrs, 1, mu, 1) call dset(nxis*nxis, 0.d0, v, 1) i=1 23057 if(.not.(i.le.n1))goto 23059 tmp = dasum (nqd, eta1(1,i), 1) j=1 23060 if(.not.(j.le.nxis))goto 23062 muwk(j) = ddot (nqd, eta1(1,i), 1, qdrs1(1,j,i), 1) / tmp 23061 j=j+1 goto 23060 23062 continue j=1 23063 if(.not.(j.le.nxis))goto 23065 k=j 23066 if(.not.(k.le.nxis))goto 23068 vwk(j,k) = 0.d0 kk=1 23069 if(.not.(kk.le.nqd))goto 23071 vwk(j,k) = vwk(j,k) + eta1(kk,i)*qdrs1(kk,j,i)*qdrs1(kk,k,i) 23070 kk=kk+1 goto 23069 23071 continue vwk(j,k) = vwk(j,k) / tmp - muwk(j) * muwk(k) 23067 k=k+1 goto 23066 23068 continue 23064 j=j+1 goto 23063 23065 continue if(cntsum1.eq.0)then call daxpy (nxis, 1.d0, muwk, 1, mu, 1) call daxpy (nxis*nxis, -1.d0, vwk, 1, v, 1) else call daxpy (nxis, dble (cnt1(i)), muwk, 1, mu, 1) call daxpy (nxis*nxis, -dble (cnt1(i)), vwk, 1, v, 1) endif 23058 i=i+1 goto 23057 23059 continue i=1 23074 if(.not.(i.le.n2))goto 23076 tmp = dasum (nqd, eta2(1,i), 1) j=1 23077 if(.not.(j.le.nxis))goto 23079 muwk(j) = ddot (nqd, eta2(1,i), 1, qdrs2(1,j,i), 1) / tmp 23078 j=j+1 goto 23077 23079 continue j=1 23080 if(.not.(j.le.nxis))goto 23082 k=j 23083 if(.not.(k.le.nxis))goto 23085 vwk(j,k) = 0.d0 kk=1 23086 if(.not.(kk.le.nqd))goto 23088 vwk(j,k) = vwk(j,k) + eta2(kk,i)*qdrs2(kk,j,i)*qdrs2(kk,k,i) 23087 kk=kk+1 goto 23086 23088 continue vwk(j,k) = vwk(j,k) / tmp - muwk(j) * muwk(k) 23084 k=k+1 goto 23083 23085 continue 23081 j=j+1 goto 23080 23082 continue if(cntsum2.eq.0)then call daxpy (nxis, 1.d0, muwk, 1, mu, 1) call daxpy (nxis*nxis, -1.d0, vwk, 1, v, 1) else call daxpy (nxis, dble (cnt2(i)), muwk, 1, mu, 1) call daxpy (nxis*nxis, -dble (cnt2(i)), vwk, 1, v, 1) endif 23075 i=i+1 goto 23074 23076 continue i=1 23091 if(.not.(i.le.n3))goto 23093 j=1 23094 if(.not.(j.le.nqd))goto 23096 k=1 23097 if(.not.(k.le.nqd))goto 23099 wk((k-1)*nqd+j) = eta((k-1)*nqd+j) * wt3(j,1,i) * wt3(k,2,i) 23098 k=k+1 goto 23097 23099 continue 23095 j=j+1 goto 23094 23096 continue tmp = dasum (nqd*nqd, wk, 1) j=1 23100 if(.not.(j.le.nxis))goto 23102 muwk(j) = ddot (nqd*nqd, wk, 1, qdrs(j,1), nxis) / tmp 23101 j=j+1 goto 23100 23102 continue j=1 23103 if(.not.(j.le.nxis))goto 23105 k=j 23106 if(.not.(k.le.nxis))goto 23108 vwk(j,k) = 0.d0 kk=1 23109 if(.not.(kk.le.nqd*nqd))goto 23111 vwk(j,k) = vwk(j,k) + wk(kk)*qdrs(j,kk)*qdrs(k,kk) 23110 kk=kk+1 goto 23109 23111 continue vwk(j,k) = vwk(j,k) / tmp - muwk(j) * muwk(k) 23107 k=k+1 goto 23106 23108 continue 23104 j=j+1 goto 23103 23105 continue if(cntsum3.eq.0)then call daxpy (nxis, 1.d0, muwk, 1, mu, 1) call daxpy (nxis*nxis, -1.d0, vwk, 1, v, 1) else call daxpy (nxis, dble (cnt3(i)), muwk, 1, mu, 1) call daxpy (nxis*nxis, -dble (cnt3(i)), vwk, 1, v, 1) endif 23092 i=i+1 goto 23091 23093 continue call dscal (nxis, 1.d0/dble(nobs), mu, 1) call dscal (nxis*nxis, 1.d0/dble(nobs), v, 1) i=1 23114 if(.not.(i.le.nt))goto 23116 j=1 23117 if(.not.(j.le.nqd))goto 23119 k=1 23120 if(.not.(k.le.nqd))goto 23122 wk((k-1)*nqd+j) = eta((k-1)*nqd+j) * qdwt(j,1,i) * qdwt(k,2,i) 23121 k=k+1 goto 23120 23122 continue 23118 j=j+1 goto 23117 23119 continue tmp = dasum (nqd*nqd, wk, 1) j=1 23123 if(.not.(j.le.nxis))goto 23125 muwk(j) = ddot (nqd*nqd, wk, 1, qdrs(j,1), nxis) / tmp 23124 j=j+1 goto 23123 23125 continue j=1 23126 if(.not.(j.le.nxis))goto 23128 k=j 23129 if(.not.(k.le.nxis))goto 23131 vwk(j,k) = 0.d0 kk=1 23132 if(.not.(kk.le.nqd*nqd))goto 23134 vwk(j,k) = vwk(j,k) + wk(kk)*qdrs(j,kk)*qdrs(k,kk) 23133 kk=kk+1 goto 23132 23134 continue vwk(j,k) = vwk(j,k) / tmp - muwk(j) * muwk(k) 23130 k=k+1 goto 23129 23131 continue 23127 j=j+1 goto 23126 23128 continue call dcopy (nxis, muwk, 1, mut(1,i), 1) call daxpy (nxis, -twt(i), muwk, 1, mu, 1) call daxpy (nxis*nxis, twt(i), vwk, 1, v, 1) 23115 i=i+1 goto 23114 23116 continue call dcopy (nxis, mu, 1, mrs2, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) i=1 23135 if(.not.(i.le.nxi))goto 23137 j=i 23138 if(.not.(j.le.nxi))goto 23140 v(i,j) = v(i,j) + q(i,j) 23139 j=j+1 goto 23138 23140 continue 23136 i=i+1 goto 23135 23137 continue mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23141 if(.not.(i.le.nxis))goto 23143 jpvt(i) = 0 23142 i=i+1 goto 23141 23143 continue call dchdc (v, nxis, nxis, muwk, jpvt, 1, rkv) 23144 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23144 endif 23145 continue i=rkv+1 23146 if(.not.(i.le.nxis))goto 23148 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23147 i=i+1 goto 23146 23148 continue 23149 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) i=1 23152 if(.not.(i.le.nqd*nqd))goto 23154 tmp = ddot (nxis, qdrs(1,i), 1, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23154 endif wk(i) = dexp (tmp) 23153 i=i+1 goto 23152 23154 continue lkhdnew = 0.d0 i=1 23157 if(.not.(i.le.n0))goto 23159 tmp = ddot (nxis, rs0(1,i), 1, cdnew, 1) if(cntsum0.ne.0)then tmp = tmp * dble (cnt0(i)) endif lkhdnew = lkhdnew - tmp 23158 i=i+1 goto 23157 23159 continue i=1 23162 if(.not.(i.le.n1))goto 23164 j=1 23165 if(.not.(j.le.nqd))goto 23167 eta1(j,i) = dexp (ddot (nxis, qdrs1(j,1,i), nqd, cdnew, 1)) * wt1( *j,i) 23166 j=j+1 goto 23165 23167 continue if(cntsum1.eq.0)then lkhdnew = lkhdnew - dlog (dasum (nqd, eta1(1,i), 1)) else lkhdnew = lkhdnew - dlog (dasum (nqd, eta1(1,i), 1)) * dble (cnt *1(i)) endif 23163 i=i+1 goto 23162 23164 continue i=1 23170 if(.not.(i.le.n2))goto 23172 j=1 23173 if(.not.(j.le.nqd))goto 23175 eta2(j,i) = dexp (ddot (nxis, qdrs2(j,1,i), nqd, cdnew, 1)) * wt2( *j,i) 23174 j=j+1 goto 23173 23175 continue if(cntsum2.eq.0)then lkhdnew = lkhdnew - dlog (dasum (nqd, eta2(1,i), 1)) else lkhdnew = lkhdnew - dlog (dasum (nqd, eta2(1,i), 1)) * dble (cnt *2(i)) endif 23171 i=i+1 goto 23170 23172 continue i=1 23178 if(.not.(i.le.n3))goto 23180 tmp = 0.d0 j=1 23181 if(.not.(j.le.nqd))goto 23183 tmp = tmp + ddot (nqd, wk((j-1)*nqd+1), 1, wt3(1,1,i), 1) * wt3(j, *2,i) 23182 j=j+1 goto 23181 23183 continue if(cntsum3.eq.0)then lkhdnew = lkhdnew - dlog (tmp) else lkhdnew = lkhdnew - dlog (tmp) * dble (cnt3(i)) endif 23179 i=i+1 goto 23178 23180 continue lkhdnew = lkhdnew / dble (nobs) i=1 23186 if(.not.(i.le.nt))goto 23188 tmp = 0.d0 j=1 23189 if(.not.(j.le.nqd))goto 23191 tmp = tmp + ddot (nqd, wk((j-1)*nqd+1), 1, qdwt(1,1,i), 1) * qdwt( *j,2,i) 23190 j=j+1 goto 23189 23191 continue lkhdnew = lkhdnew + dlog (tmp) * twt(i) 23187 i=i+1 goto 23186 23188 continue call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, muwk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, muwk, 1) / 2.d0 if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) call dset (nqd*nqd, 1.d0, eta, 1) call dcopy (nqd*n1, wt1, 1, eta1, 1) call dcopy (nqd*n2, wt2, 1, eta2, 1) lkhd = 0.d0 i=1 23194 if(.not.(i.le.n1))goto 23196 if(cntsum1.eq.0)then lkhd = lkhd - dlog (dasum (nqd, eta1(1,i), 1)) else lkhd = lkhd - dlog (dasum (nqd, eta1(1,i), 1)) * dble (cnt1(i)) endif 23195 i=i+1 goto 23194 23196 continue i=1 23199 if(.not.(i.le.n2))goto 23201 if(cntsum2.eq.0)then lkhd = lkhd - dlog (dasum (nqd, eta2(1,i), 1)) else lkhd = lkhd - dlog (dasum (nqd, eta2(1,i), 1)) * dble (cnt2(i)) endif 23200 i=i+1 goto 23199 23201 continue i=1 23204 if(.not.(i.le.n3))goto 23206 tmp = dasum (nqd, wt3(1,1,i), 1) * dasum (nqd, wt3(1,2,i), 1) if(cntsum3.eq.0)then lkhdnew = lkhdnew - dlog (tmp) else lkhdnew = lkhdnew - dlog (tmp) * dble (cnt3(i)) endif 23205 i=i+1 goto 23204 23206 continue lkhd = lkhd / dble (nobs) i=1 23209 if(.not.(i.le.nt))goto 23211 tmp = dasum (nqd, qdwt(1,1,i), 1) * dasum (nqd, qdwt(1,2,i), 1) lkhd = lkhd + dlog (tmp) * twt(i) 23210 i=i+1 goto 23209 23211 continue iter = 0 goto 23151 endif if(flag.eq.3)then goto 23151 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23151 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23151 endif 23150 goto 23149 23151 continue if(flag.eq.1)then flag = 2 goto 23055 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 i=1 23222 if(.not.(i.le.nqd*nqd))goto 23224 disc = dmax1 (disc, dabs(eta(i)-wk(i))/(1.d0+dabs(eta(i)))) 23223 i=i+1 goto 23222 23224 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1.d0+da *bs(lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nqd, wk, 1, eta, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23056 endif if(disc.lt.prec)then goto 23056 endif if(iter.lt.maxiter)then goto 23055 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) call dset (nqd*nqd, 1.d0, eta, 1) call dcopy (nqd*n1, wt1, 1, eta1, 1) call dcopy (nqd*n2, wt2, 1, eta2, 1) lkhd = 0.d0 i=1 23233 if(.not.(i.le.n1))goto 23235 if(cntsum1.eq.0)then lkhd = lkhd - dlog (dasum (nqd, eta1(1,i), 1)) else lkhd = lkhd - dlog (dasum (nqd, eta1(1,i), 1)) * dble (cnt1(i)) endif 23234 i=i+1 goto 23233 23235 continue i=1 23238 if(.not.(i.le.n2))goto 23240 if(cntsum2.eq.0)then lkhd = lkhd - dlog (dasum (nqd, eta2(1,i), 1)) else lkhd = lkhd - dlog (dasum (nqd, eta2(1,i), 1)) * dble (cnt2(i)) endif 23239 i=i+1 goto 23238 23240 continue i=1 23243 if(.not.(i.le.n3))goto 23245 tmp = dasum (nqd, wt3(1,1,i), 1) * dasum (nqd, wt3(1,2,i), 1) if(cntsum3.eq.0)then lkhdnew = lkhdnew - dlog (tmp) else lkhdnew = lkhdnew - dlog (tmp) * dble (cnt3(i)) endif 23244 i=i+1 goto 23243 23245 continue lkhd = lkhd / dble (nobs) i=1 23248 if(.not.(i.le.nt))goto 23250 tmp = dasum (nqd, qdwt(1,1,i), 1) * dasum (nqd, qdwt(1,2,i), 1) lkhd = lkhd + dlog (tmp) * twt(i) 23249 i=i+1 goto 23248 23250 continue iter = 0 flag = 2 else info = 2 goto 23056 endif 23055 goto 23054 23056 continue trc = 0.d0 i=1 23251 if(.not.(i.le.n0))goto 23253 call dcopy (nxis, rs0(1,i), 1, muwk, 1) if(nt.gt.1)then call daxpy (nxis, -1.d0, mut(1,tind(i)), 1, muwk, 1) else call daxpy (nxis, -1.d0, mut, 1, muwk, 1) endif call daxpy (nxis, -1.d0, mrs2, 1, muwk, 1) call dprmut (muwk, nxis, jpvt, 0) if(cntsum0.ne.0)then call dscal (nxis, dsqrt(dble(cnt0(i))), muwk, 1) endif call dtrsl (v, nxis, nxis, muwk, 11, infowk) if(nxis-rkv.gt.0)then call dset (nxis-rkv, 0.d0, muwk(rkv+1), 1) endif trc = trc + ddot (nxis, muwk, 1, muwk, 1) 23252 i=i+1 goto 23251 23253 continue i=1 23260 if(.not.(i.le.n1))goto 23262 tmp = dasum (nqd, eta1(1,i), 1) j=1 23263 if(.not.(j.le.nxis))goto 23265 muwk(j) = ddot (nqd, eta1(1,i), 1, qdrs1(1,j,i), 1) / tmp 23264 j=j+1 goto 23263 23265 continue if(nt.gt.1)then call daxpy (nxis, -1.d0, mut(1,tind(n0+i)), 1, muwk, 1) else call daxpy (nxis, -1.d0, mut, 1, muwk, 1) endif call daxpy (nxis, -1.d0, mrs2, 1, muwk, 1) call dprmut (muwk, nxis, jpvt, 0) if(cntsum1.ne.0)then call dscal (nxis, dsqrt(dble(cnt1(i))), muwk, 1) endif call dtrsl (v, nxis, nxis, muwk, 11, infowk) if(nxis-rkv.gt.0)then call dset (nxis-rkv, 0.d0, muwk(rkv+1), 1) endif trc = trc + ddot (nxis, muwk, 1, muwk, 1) 23261 i=i+1 goto 23260 23262 continue i=1 23272 if(.not.(i.le.n2))goto 23274 tmp = dasum (nqd, eta2(1,i), 1) j=1 23275 if(.not.(j.le.nxis))goto 23277 muwk(j) = ddot (nqd, eta2(1,i), 1, qdrs2(1,j,i), 1) / tmp 23276 j=j+1 goto 23275 23277 continue if(nt.gt.1)then call daxpy (nxis, -1.d0, mut(1,tind(n0+n1+i)), 1, muwk, 1) else call daxpy (nxis, -1.d0, mut, 1, muwk, 1) endif call daxpy (nxis, -1.d0, mrs2, 1, muwk, 1) call dprmut (muwk, nxis, jpvt, 0) if(cntsum2.ne.0)then call dscal (nxis, dsqrt(dble(cnt2(i))), muwk, 1) endif call dtrsl (v, nxis, nxis, muwk, 11, infowk) if(nxis-rkv.gt.0)then call dset (nxis-rkv, 0.d0, muwk(rkv+1), 1) endif trc = trc + ddot (nxis, muwk, 1, muwk, 1) 23273 i=i+1 goto 23272 23274 continue i=1 23284 if(.not.(i.le.n3))goto 23286 j=1 23287 if(.not.(j.le.nqd))goto 23289 k=1 23290 if(.not.(k.le.nqd))goto 23292 wk((k-1)*nqd+j) = eta((k-1)*nqd+j) * wt3(j,1,i) * wt3(k,2,i) 23291 k=k+1 goto 23290 23292 continue 23288 j=j+1 goto 23287 23289 continue tmp = dasum (nqd*nqd, wk, 1) j=1 23293 if(.not.(j.le.nxis))goto 23295 muwk(j) = ddot (nqd*nqd, wk, 1, qdrs(j,1), nxis) / tmp 23294 j=j+1 goto 23293 23295 continue if(nt.gt.1)then call daxpy (nxis, -1.d0, mut(1,tind(n0+n1+n2+i)), 1, muwk, 1) else call daxpy (nxis, -1.d0, mut, 1, muwk, 1) endif call daxpy (nxis, -1.d0, mrs2, 1, muwk, 1) call dprmut (muwk, nxis, jpvt, 0) if(cntsum3.ne.0)then call dscal (nxis, dsqrt(dble(cnt3(i))), muwk, 1) endif call dtrsl (v, nxis, nxis, muwk, 11, infowk) if(nxis-rkv.gt.0)then call dset (nxis-rkv, 0.d0, muwk(rkv+1), 1) endif trc = trc + ddot (nxis, muwk, 1, muwk, 1) 23285 i=i+1 goto 23284 23286 continue trc = trc / dble(nobs) / (dble(nobs)-1.d0) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, muwk, 1) lkhd = lkhd - ddot (nxi, cdnew, 1, muwk, 1) / 2.d0 mrs(1) = lkhd mrs(2) = trc return end gss/src/smolyak.c0000644000176200001440000016516414464254130013500 0ustar liggesusers/* This is Knut Petras' smolyak.c from SMOLPACK, * modified by Chong Gu to steal the nodes and * weights of the cubature for use in the * R package gss. * * The program implements the delayed Smolyak cubature * as discussed in the references by Knut Petras: * * [1] Asymptotically minimal Smolyak cubature, 2000 * [2] Fast Calculation of Coefficients in the Smolyak Algorithm * * Chong Gu, January 27, 2002, at Purdue. */ # include # include # include /* replace # include "smolyak.h" by one line -- C. Gu */ # define maxdim 40 /* replace # include "smolyak.h" by one line -- C. Gu */ #define uniw 256 /* total # of nodes of quadrature formulae */ #define fn 9 /* # of different basic formula */ #define gesfn 50 /* # of basic formulae (incl. multiplicities) */ static double quafo; /* cubature result */ static double x[maxdim]; /* function argument */ static double xnu[fn][uniw],dnu[fn][uniw]; /* Delta-parameter */ static double fsumme, summe; /* working var's */ /* static double fsumme, wsum, wprod, summe; working var's */ static int d, q; /* cubature formula parameter */ static int n[fn], ninv[fn], sw[gesfn]; /* working var's */ int count, wcount; /* counter of f-calls and coefficient calls */ static int indeces[maxdim], argind[maxdim]; /* formula and nodal indeces */ static int indsum[maxdim][maxdim]; /* parameter for 'divide et conquer' */ static int anzw[uniw], lookind[fn][uniw], invlook[fn][uniw], maxind; /* tree parameter */ /* static int wind[maxdim]; Parameter for slow coefficient calculation */ static double (*f)(int, double x[]); /* integrand (global) */ static void formula(int,int); /* sub-formula "between two dimensions" */ static double eval(int); /* sub-formula calculator */ static double fsum(int); /* sum(f(+-x_nu)) (use of symmetry) */ /* get pt and wt from formula1, eval1, fsum1 -- C. Gu */ static double wtt; static void formula1(int, int, double *pt, double *wt); static void eval1(int, double *pt, double *wt); static void fsum1(int, double *pt, double *wt); /* get pt and wt from formula1, eval1, fsum1 -- C. Gu */ static void init(void); /* initialization */ static double calccoeff(int); /* coefficient calculator */ /* static double calccoeff2(int,int); */ /* coefficient calculator (slow) */ static double wl(int, int, int); /* 'divide */ static double we(int, int, int); /* and */ static void sumind(int, int); /* conquer' */ /*************** tree definitions: *************************/ struct tnode { int empty; double *coeff; int *belegt; struct tnode *left; struct tnode *right; }; static struct tnode *root; static double coeff(void); /* tree manager */ static struct tnode *talloc(void); /* node generator */ static void frei(struct tnode *p); /* tree eraser */ /* Start of R interface -- C. Gu */ double f_dummy(int dd, double x[]) { count++; return 1; } void size_smolyak(int *dd, int *qq, int *size) /********************** get size ***************************/ { d=*dd; q=*qq; f=f_dummy; init(); formula(1,q-d); frei(root); *size = count; } void quad_smolyak(int *dd, int *qq, double *pt, double *wt) /********************** get pt and wt ***************************/ { d=*dd; q=*qq; f=f_dummy; init(); formula1(1,q-d,pt,wt); frei(root); } /* End of R interface -- C. Gu */ double int_smolyak(int dd, int qq, double(*ff)(int,double xx[]), int size) /********************** main program ***************************/ /*** for formula parameter dd<40, qq-dd<48 ******/ { /* make parameter global: */ d=dd; q=qq; f=ff; /* Initialisation */ init(); /* call of Smolyak algorithm */ formula(1,q-d); /* free space */ frei(root); /* statistics ( if desired ) */ /* if (size) { printf("%i function calls and ", count); printf("%i coefficient calculations \n", wcount);}*/ return quafo; } void formula(int k,int l) /* If k==d: evaluation. */ /* Else: */ /* determine the required formula */ /* l is the index sum that may be distributed */ /* to the remaining dimensions */ { int i; if (k==d+1) { quafo = quafo + eval(0); } else for (i=0; (i<=l) ; i++) /* Use only non-dummy-formulae */ if (sw[i]=1; j--){ /* anzw[j] to the L E F T */ if (p->left==NULL){ /* if node not existing, node generation : */ p->left = (struct tnode *) calloc(maxdim, sizeof(struct tnode)); pt=(p->left+anzw[j]); pt->left=pt->right=NULL; pt->empty = 1; p=pt;} else p=(p->left+anzw[j]); /* one to the R I G H T */ if (p->right==NULL){ /* if node not existing: */ pt=talloc(); /* node generation */ pt->empty=1; pt->left=pt->right=NULL; if (j==1){ /* leaf with coefficient */ pt->coeff=(double *) calloc(maxdim, sizeof(double)); pt->belegt=(int *) calloc(maxdim, sizeof(int)); pt->empty=0; }; p->right=pt; }; p=p->right; } if (!*(p->belegt+anzw[0])){ /* evtl. coeff.-calc. necessary */ wcount++; *(p->coeff +anzw[0]) = calccoeff(q-d); *(p->belegt+anzw[0]) =1; }; return *(p->coeff +anzw[0]); } void frei(struct tnode *p) /* tree eraser */ { if (!(p->empty)) { free (p->coeff); free (p->belegt);}; if (!(p->left ==NULL)) frei(p->left); if (!(p->right ==NULL)) frei(p->right); free(p); } struct tnode *talloc(void) /* Space for new tree-node */ { return (struct tnode *) malloc (sizeof(struct tnode)); } /******** tree-functions finished ******/ void sumind(int r, int s) /* Calculation of sums of formula indices at division of dimension r...s */ { int q; if (s==r) indsum[r][s] = ninv[indeces[r]]; else { q=(r+s)/2; sumind(r,q); sumind(q+1,s); indsum[r][s] = indsum[r][q] + indsum[q+1][s]; }; } double calccoeff (int l) { sumind(1,d); /* calculation of parameters of subdivision */ return wl(1,d,l); /* start of 'divide and conquer' */ } double wl(int r,int s, int l) /* sums in dimension s...r with sum of formula numbers <=l */ { double sum=0; int i,q, p; if (r==s) /* one-dimensional */ { p=lookind[indeces[r]][argind[r]]; for (i=ninv[indeces[r]]; i<=l; i++) { if (sw[i]=ninv[maxform+1]) maxform=maxform+1; /* total number of used 1-dim nodes */ maxind = (nj[maxform]+1)/2; /* table of 1-dim nodal numbers 0..maxind-1 corresponding to a combination formula number/nodal number and inverse formula */ lookind[0][0] = 0; for (i=1; i<=maxform; i++) { formfakt=pow(2, maxform-i); for (j=0; j<(nj[i]+1)/4; j++) lookind[i][j] = formfakt*(2*j+1); /* in a linear ordering of all used nodes, the (2j+1)-th node of the i-th basic formula is lookind[i][j]-th node */ for (j=0; j<(nj[i]+1)/2; j++) invlook[i][formfakt*j] = j; /* the lookind[i][2^(maxform-i)]-th node in a linear ordering of all used nodes is the j-th node of the i-th basic formula. Note that maxrorm is the number of used different basic formulae */ }; /* root of the coefficient TREE */ root=talloc(); root->empty=1; root->left=root->right=NULL; /* one dimensional formulae (Deltas) */ xnu[0][0] = 0.5; dnu[0][0] = 1.0; xnu[1][0] = 5.000000000000000E-001; xnu[1][1] = 8.8729833462074168851793E-001; dnu[1][0] = -5.5555555555555555555556E-001; dnu[1][1] = 2.7777777777777777777778E-001; xnu[2][0] = 5.0000000000000000000000E-001; xnu[2][1] = 7.1712187467340127900104E-001; xnu[2][2] = 8.8729833462074168851793E-001; xnu[2][3] = 9.8024563435401014171175E-001; dnu[2][0] = -2.1898617511520737327189E-001; dnu[2][1] = 2.0069870738798111145253E-001; dnu[2][2] = -1.4353373284361105741349E-001; dnu[2][3] = 5.2328113013233632596912E-002; xnu[3][0] = 5.0000000000000000000000E-001; xnu[3][1] = 6.1169334321448344081410E-001; xnu[3][2] = 7.1712187467340127900104E-001; xnu[3][3] = 8.1055147336861320147034E-001; xnu[3][4] = 8.8729833462074168851793E-001; xnu[3][5] = 9.4422961643612849944521E-001; xnu[3][6] = 9.8024563435401014171175E-001; xnu[3][7] = 9.9691598160637751110426E-001; dnu[3][0] = -1.1270301943013372747934E-001; dnu[3][1] = 1.0957842920079374820185E-001; dnu[3][2] = -1.0038444269948660093556E-001; dnu[3][3] = 8.5755954568195690393677E-002; dnu[3][4] = -6.7036417312274610184300E-002; dnu[3][5] = 4.6463597657562268842947E-002; dnu[3][6] = -2.6526471514693762748452E-002; dnu[3][7] = 8.5008598149701301695137E-003; xnu[4][0] = 5.0000000000000000000000E-001; xnu[4][1] = 5.5624447156659331287292E-001; xnu[4][2] = 6.1169334321448344081410E-001; xnu[4][3] = 6.6556769662898841654632E-001; xnu[4][4] = 7.1712187467340127900104E-001; xnu[4][5] = 7.6565987182218781198605E-001; xnu[4][6] = 8.1055147336861320147034E-001; xnu[4][7] = 8.5124810324576353930490E-001; xnu[4][8] = 8.8729833462074168851793E-001; xnu[4][9] = 9.1836296908443436775138E-001; xnu[4][10] = 9.4422961643612849944521E-001; xnu[4][11] = 9.6482742871487002833506E-001; xnu[4][12] = 9.8024563435401014171175E-001; xnu[4][13] = 9.9076557477687005343368E-001; xnu[4][14] = 9.9691598160637751110426E-001; xnu[4][15] = 9.9954906248383379883111E-001; dnu[4][0] = -5.6377621538718997889636E-002; dnu[4][1] = 5.5978436510476728440072E-002; dnu[4][2] = -5.4789218672831429083502E-002; dnu[4][3] = 5.2834946790117404871908E-002; dnu[4][4] = -5.0157125382596721131319E-002; dnu[4][5] = 4.6813554990632236808329E-002; dnu[4][6] = -4.2877994543200514816583E-002; dnu[4][7] = 3.8439810249501765521353E-002; dnu[4][8] = -3.3603750473896758409784E-002; dnu[4][9] = 2.8489754747061678706099E-002; dnu[4][10] = -2.3232151026683275572245E-002; dnu[4][11] = 1.7978551653564661048389E-002; dnu[4][12] = -1.2897842450451543066137E-002; dnu[4][13] = 8.2230249271939054668942E-003; dnu[4][14] = -4.2835769453095770463562E-003; dnu[4][15] = 1.2723903957809372077014E-003; xnu[5][0] = 5.0000000000000000000000E-001; xnu[5][1] = 5.2817215652329639498598E-001; xnu[5][2] = 5.5624447156659331287292E-001; xnu[5][3] = 5.8411762577610373249116E-001; xnu[5][4] = 6.1169334321448344081410E-001; xnu[5][5] = 6.3887491101091215753268E-001; xnu[5][6] = 6.6556769662898841654632E-001; xnu[5][7] = 6.9167966209936517345824E-001; xnu[5][8] = 7.1712187467340127900104E-001; xnu[5][9] = 7.4180901347292051378108E-001; xnu[5][10] = 7.6565987182218781198605E-001; xnu[5][11] = 7.8859785502602290742185E-001; xnu[5][12] = 8.1055147336861320147034E-001; xnu[5][13] = 8.3145483001239029773051E-001; xnu[5][14] = 8.5124810324576353930490E-001; xnu[5][15] = 8.6987802217634737933861E-001; xnu[5][16] = 8.8729833462074168851793E-001; xnu[5][17] = 9.0347026597510880592815E-001; xnu[5][18] = 9.1836296908443436775138E-001; xnu[5][19] = 9.3195396909684523857321E-001; xnu[5][20] = 9.4422961643612849944521E-001; xnu[5][21] = 9.5518557847850214624890E-001; xnu[5][22] = 9.6482742871487002833506E-001; xnu[5][23] = 9.7317142918670145257425E-001; xnu[5][24] = 9.8024563435401014171175E-001; xnu[5][25] = 9.8609143737429089828903E-001; xnu[5][26] = 9.9076557477687005343368E-001; xnu[5][27] = 9.9434237877371473996926E-001; xnu[5][28] = 9.9691598160637751110426E-001; xnu[5][29] = 9.9860312968611097953823E-001; xnu[5][30] = 9.9954906248383379883111E-001; xnu[5][31] = 9.9993644406017880596898E-001; dnu[5][0] = -2.8188814180191987109744E-002; dnu[5][1] = 2.8138849915627150636298E-002; dnu[5][2] = -2.7989218255238568736295E-002; dnu[5][3] = 2.7740702178279681993919E-002; dnu[5][4] = -2.7394605263980886602235E-002; dnu[5][5] = 2.6952749667633031963438E-002; dnu[5][6] = -2.6417473395059144940870E-002; dnu[5][7] = 2.5791626976024229388405E-002; dnu[5][8] = -2.5078569652948020678807E-002; dnu[5][9] = 2.4282165203336599357974E-002; dnu[5][10] = -2.3406777495318230607005E-002; dnu[5][11] = 2.2457265826816098707127E-002; dnu[5][12] = -2.1438980012491308330637E-002; dnu[5][13] = 2.0357755058472159466947E-002; dnu[5][14] = -1.9219905124773999502032E-002; dnu[5][15] = 1.8032216390391286320054E-002; dnu[5][16] = -1.6801938573891486499334E-002; dnu[5][17] = 1.5536775555843982439942E-002; dnu[5][18] = -1.4244877374144904399846E-002; dnu[5][19] = 1.2934839663607373455379E-002; dnu[5][20] = -1.1615723310923858549074E-002; dnu[5][21] = 1.0297116957956355574594E-002; dnu[5][22] = -8.9892758695005258819409E-003; dnu[5][23] = 7.7033752332797489010654E-003; dnu[5][24] = -6.4518989979126939693347E-003; dnu[5][25] = 5.2491234548106609491364E-003; dnu[5][26] = -4.1115209485759406322653E-003; dnu[5][27] = 3.0577534110586231698391E-003; dnu[5][28] = -2.1084676488811257036154E-003; dnu[5][29] = 1.2895248973428441362139E-003; dnu[5][30] = -6.3981211766590320201509E-004; dnu[5][31] = 1.8161074092276532984679E-004; xnu[6][0] = 5.0000000000000000000000E-001; xnu[6][1] = 5.1409232447487284716970E-001; xnu[6][2] = 5.2817215652329639498598E-001; xnu[6][3] = 5.4222702004185544185509E-001; xnu[6][4] = 5.5624447156659331287292E-001; xnu[6][5] = 5.7021211657628008729691E-001; xnu[6][6] = 5.8411762577610373249116E-001; xnu[6][7] = 5.9794875135555007695773E-001; xnu[6][8] = 6.1169334321448344081410E-001; xnu[6][9] = 6.2533936515174158830648E-001; xnu[6][10] = 6.3887491101091215753268E-001; xnu[6][11] = 6.5228822077835702166766E-001; xnu[6][12] = 6.6556769662898841654632E-001; xnu[6][13] = 6.7870191891576607618811E-001; xnu[6][14] = 6.9167966209936517345824E-001; xnu[6][15] = 7.0448991061494433620452E-001; xnu[6][16] = 7.1712187467340127900104E-001; xnu[6][17] = 7.2956500599491616643675E-001; xnu[6][18] = 7.4180901347292051378108E-001; xnu[6][19] = 7.5384387876685830107739E-001; xnu[6][20] = 7.6565987182218781198605E-001; xnu[6][21] = 7.7724756631596627443319E-001; xnu[6][22] = 7.8859785502602290742185E-001; xnu[6][23] = 7.9970196512112144648713E-001; xnu[6][24] = 8.1055147336861320147034E-001; xnu[6][25] = 8.2113832125487975688706E-001; xnu[6][26] = 8.3145483001239029773051E-001; xnu[6][27] = 8.4149371554553961404354E-001; xnu[6][28] = 8.5124810324576353930490E-001; xnu[6][29] = 8.6071154268504945774249E-001; xnu[6][30] = 8.6987802217634737933861E-001; xnu[6][31] = 8.7874198319025681896313E-001; xnu[6][32] = 8.8729833462074168851793E-001; xnu[6][33] = 8.9554246689992418071732E-001; xnu[6][34] = 9.0347026597510880592815E-001; xnu[6][35] = 9.1107812718249020368626E-001; xnu[6][36] = 9.1836296908443436775138E-001; xnu[6][37] = 9.2532224738417513987891E-001; xnu[6][38] = 9.3195396909684523857321E-001; xnu[6][39] = 9.3825670724235263487081E-001; xnu[6][40] = 9.4422961643612849944521E-001; xnu[6][41] = 9.4987244988847001831932E-001; xnu[6][42] = 9.5518557847850214624890E-001; xnu[6][43] = 9.6017001273500621036491E-001; xnu[6][44] = 9.6482742871487002833506E-001; xnu[6][45] = 9.6916019888979644182741E-001; xnu[6][46] = 9.7317142918670145257425E-001; xnu[6][47] = 9.7686500321288056820737E-001; xnu[6][48] = 9.8024563435401014171175E-001; xnu[6][49] = 9.8331892577920828354614E-001; xnu[6][50] = 9.8609143737429089828903E-001; xnu[6][51] = 9.8857075731985285707820E-001; xnu[6][52] = 9.9076557477687005343368E-001; xnu[6][53] = 9.9268574979926018555688E-001; xnu[6][54] = 9.9434237877371473996926E-001; xnu[6][55] = 9.9574786058905306619925E-001; xnu[6][56] = 9.9691598160637751110426E-001; xnu[6][57] = 9.9786205234920359425472E-001; xnu[6][58] = 9.9860312968611097953823E-001; xnu[6][59] = 9.9915831765920369626532E-001; xnu[6][60] = 9.9954906248383379883111E-001; xnu[6][61] = 9.9979939983595534162598E-001; xnu[6][62] = 9.9993644406017880596898E-001; xnu[6][63] = 9.9999121517744579929001E-001; dnu[6][0] = -1.4094407090096179346916E-002; dnu[6][1] = 1.4088159516508301065327E-002; dnu[6][2] = -1.4069424957813575318149E-002; dnu[6][3] = 1.4038227896908623303424E-002; dnu[6][4] = -1.3994609127619079851888E-002; dnu[6][5] = 1.3938625738306850804262E-002; dnu[6][6] = -1.3870351089139840996960E-002; dnu[6][7] = 1.3789874783240936517434E-002; dnu[6][8] = -1.3697302631990716258054E-002; dnu[6][9] = 1.3592756614812395909604E-002; dnu[6][10] = -1.3476374833816515981719E-002; dnu[6][11] = 1.3348311463725179953077E-002; dnu[6][12] = -1.3208736697529129965519E-002; dnu[6][13] = 1.3057836688353048840249E-002; dnu[6][14] = -1.2895813488012114694202E-002; dnu[6][15] = 1.2722884982732382906287E-002; dnu[6][16] = -1.2539284826474884353420E-002; dnu[6][17] = 1.2345262372243838454530E-002; dnu[6][18] = -1.2141082601668299678987E-002; dnu[6][19] = 1.1927026053019270040223E-002; dnu[6][20] = -1.1703388747657003100662E-002; dnu[6][21] = 1.1470482114693874380400E-002; dnu[6][22] = -1.1228632913408049353564E-002; dnu[6][23] = 1.0978183152658912469630E-002; dnu[6][24] = -1.0719490006251933623228E-002; dnu[6][25] = 1.0452925722906011926111E-002; dnu[6][26] = -1.0178877529236079733474E-002; dnu[6][27] = 9.8977475240487497440139E-003; dnu[6][28] = -9.6099525623638830096600E-003; dnu[6][29] = 9.3159241280693950931570E-003; dnu[6][30] = -9.0161081951956431600270E-003; dnu[6][31] = 8.7109650797320868735761E-003; dnu[6][32] = -8.4009692870519326354323E-003; dnu[6][33] = 8.0866093647888599709740E-003; dnu[6][34] = -7.7683877779219912199780E-003; dnu[6][35] = 7.4468208324075910174052E-003; dnu[6][36] = -7.1224386864583871530823E-003; dnu[6][37] = 6.7957855048827733947865E-003; dnu[6][38] = -6.4674198318036867280122E-003; dnu[6][39] = 6.1379152800413850434832E-003; dnu[6][40] = -5.8078616599775673581358E-003; dnu[6][41] = 5.4778666939189508240164E-003; dnu[6][42] = -5.1485584789781778127510E-003; dnu[6][43] = 4.8205888648512683476492E-003; dnu[6][44] = -4.4946378920320673048077E-003; dnu[6][45] = 4.1714193769840788527921E-003; dnu[6][46] = -3.8516876166398779769824E-003; dnu[6][47] = 3.5362449977167777340232E-003; dnu[6][48] = -3.2259500250877643515858E-003; dnu[6][49] = 2.9217249379178197537798E-003; dnu[6][50] = -2.6245617274062313865695E-003; dnu[6][51] = 2.3355251860571608737027E-003; dnu[6][52] = -2.0557519892906183110438E-003; dnu[6][53] = 1.7864463917586498246922E-003; dnu[6][54] = -1.5288767059708576017734E-003; dnu[6][55] = 1.2843824718970101865639E-003; dnu[6][56] = -1.0544075979161109798758E-003; dnu[6][57] = 8.4057143271073495315687E-004; dnu[6][58] = -6.4476285603763544016464E-004; dnu[6][59] = 4.6918492427119075039702E-004; dnu[6][60] = -3.1627461843371723357680E-004; dnu[6][61] = 1.8887332316349233013718E-004; dnu[6][62] = -9.1240958700071150936623E-005; dnu[6][63] = 2.5268047603931258812333E-005; xnu[7][0] = 5.0000000000000000000000E-001; xnu[7][1] = 5.0704694320539123130709E-001; xnu[7][2] = 5.1409232447487284716970E-001; xnu[7][3] = 5.2113458238268180160620E-001; xnu[7][4] = 5.2817215652329639498598E-001; xnu[7][5] = 5.3520348802142758953165E-001; xnu[7][6] = 5.4222702004185544185509E-001; xnu[7][7] = 5.4924119829905960104514E-001; xnu[7][8] = 5.5624447156659331287292E-001; xnu[7][9] = 5.6323529218615098342533E-001; xnu[7][10] = 5.7021211657628008729691E-001; xnu[7][11] = 5.7717340574068905434622E-001; xnu[7][12] = 5.8411762577610373249116E-001; xnu[7][13] = 5.9104324837962609912320E-001; xnu[7][14] = 5.9794875135555007695773E-001; xnu[7][15] = 6.0483261912159059738317E-001; xnu[7][16] = 6.1169334321448344081410E-001; xnu[7][17] = 6.1852942279491486360633E-001; xnu[7][18] = 6.2533936515174158830648E-001; xnu[7][19] = 6.3212168620546338097247E-001; xnu[7][20] = 6.3887491101091215753268E-001; xnu[7][21] = 6.4559757425912334098185E-001; xnu[7][22] = 6.5228822077835702166766E-001; xnu[7][23] = 6.5894540603423834159087E-001; xnu[7][24] = 6.6556769662898841654632E-001; xnu[7][25] = 6.7215367079971901138831E-001; xnu[7][26] = 6.7870191891576607618811E-001; xnu[7][27] = 6.8521104397503911506877E-001; xnu[7][28] = 6.9167966209936517345824E-001; xnu[7][29] = 6.9810640302880796959126E-001; xnu[7][30] = 7.0448991061494433620452E-001; xnu[7][31] = 7.1082884331308165002815E-001; xnu[7][32] = 7.1712187467340127900104E-001; xnu[7][33] = 7.2336769383101423687111E-001; xnu[7][34] = 7.2956500599491616643675E-001; xnu[7][35] = 7.3571253293582943846704E-001; xnu[7][36] = 7.4180901347292051378108E-001; xnu[7][37] = 7.4785320395938073008506E-001; xnu[7][38] = 7.5384387876685830107739E-001; xnu[7][39] = 7.5977983076872851099646E-001; xnu[7][40] = 7.6565987182218781198605E-001; xnu[7][41] = 7.7148283324915574524615E-001; xnu[7][42] = 7.7724756631596627443319E-001; xnu[7][43] = 7.8295294271182721131149E-001; xnu[7][44] = 7.8859785502602290742185E-001; xnu[7][45] = 7.9418121722383127071718E-001; xnu[7][46] = 7.9970196512112144648713E-001; xnu[7][47] = 8.0515905685759320007779E-001; xnu[7][48] = 8.1055147336861320147034E-001; xnu[7][49] = 8.1587821885559711520679E-001; xnu[7][50] = 8.2113832125487975688706E-001; xnu[7][51] = 8.2633083270500874805039E-001; xnu[7][52] = 8.3145483001239029773051E-001; xnu[7][53] = 8.3650941511520923959944E-001; xnu[7][54] = 8.4149371554553961404354E-001; xnu[7][55] = 8.4640688488955735144733E-001; xnu[7][56] = 8.5124810324576353930490E-001; xnu[7][57] = 8.5601657768112601729334E-001; xnu[7][58] = 8.6071154268504945774249E-001; xnu[7][59] = 8.6533226062109063066465E-001; xnu[7][60] = 8.6987802217634737933861E-001; xnu[7][61] = 8.7434814680846830141141E-001; xnu[7][62] = 8.7874198319025681896313E-001; xnu[7][63] = 8.8305890965188004535834E-001; xnu[7][64] = 8.8729833462074168851793E-001; xnu[7][65] = 8.9145969705914150819259E-001; xnu[7][66] = 8.9554246689992418071732E-001; xnu[7][67] = 8.9954614548042070089990E-001; xnu[7][68] = 9.0347026597510880592815E-001; xnu[7][69] = 9.0731439382756870671791E-001; xnu[7][70] = 9.1107812718249020368626E-001; xnu[7][71] = 9.1476109731870070008905E-001; xnu[7][72] = 9.1836296908443436775138E-001; xnu[7][73] = 9.2188344133635430051916E-001; xnu[7][74] = 9.2532224738417513987891E-001; xnu[7][75] = 9.2867915544311607826256E-001; xnu[7][76] = 9.3195396909684523857321E-001; xnu[7][77] = 9.3514652777405695292558E-001; xnu[7][78] = 9.3825670724235263487081E-001; xnu[7][79] = 9.4128442012367095342085E-001; xnu[7][80] = 9.4422961643612849944521E-001; xnu[7][81] = 9.4709228416777951142968E-001; xnu[7][82] = 9.4987244988847001831932E-001; xnu[7][83] = 9.5257017940663079759465E-001; xnu[7][84] = 9.5518557847850214624890E-001; xnu[7][85] = 9.5771879357788252032198E-001; xnu[7][86] = 9.6017001273500621036491E-001; xnu[7][87] = 9.6253946645353782618207E-001; xnu[7][88] = 9.6482742871487002833506E-001; xnu[7][89] = 9.6703421807886289399974E-001; xnu[7][90] = 9.6916019888979644182741E-001; xnu[7][91] = 9.7120578259554152990628E-001; xnu[7][92] = 9.7317142918670145257425E-001; xnu[7][93] = 9.7505764876064743827892E-001; xnu[7][94] = 9.7686500321288056820737E-001; xnu[7][95] = 9.7859410805493048136810E-001; xnu[7][96] = 9.8024563435401014171175E-001; xnu[7][97] = 9.8182031078490606626049E-001; xnu[7][98] = 9.8331892577920828354614E-001; xnu[7][99] = 9.8474232975122961588545E-001; xnu[7][100] = 9.8609143737429089828903E-001; xnu[7][101] = 9.8736722987620133388036E-001; xnu[7][102] = 9.8857075731985285707820E-001; xnu[7][103] = 9.8970314083543134190307E-001; xnu[7][104] = 9.9076557477687005343368E-001; xnu[7][105] = 9.9175932878931636438083E-001; xnu[7][106] = 9.9268574979926018555688E-001; xnu[7][107] = 9.9354626397701703359495E-001; xnu[7][108] = 9.9434237877371473996926E-001; xnu[7][109] = 9.9507568520038507959027E-001; xnu[7][110] = 9.9574786058905306619925E-001; xnu[7][111] = 9.9636067214139430766410E-001; xnu[7][112] = 9.9691598160637751110426E-001; xnu[7][113] = 9.9741575140031050025957E-001; xnu[7][114] = 9.9786205234920359425472E-001; xnu[7][115] = 9.9825707295744513692434E-001; xnu[7][116] = 9.9860312968611097953823E-001; xnu[7][117] = 9.9890267724797863728092E-001; xnu[7][118] = 9.9915831765920369626532E-001; xnu[7][119] = 9.9937280723404755735176E-001; xnu[7][120] = 9.9954906248383379883111E-001; xnu[7][121] = 9.9969016901251179096404E-001; xnu[7][122] = 9.9979939983595534162598E-001; xnu[7][123] = 9.9988024546221602366522E-001; xnu[7][124] = 9.9993644406017880596898E-001; xnu[7][125] = 9.9997199810352718788193E-001; xnu[7][126] = 9.9999121517744579929001E-001; xnu[7][127] = 9.9999879818987423231012E-001; dnu[7][0] = -7.0472035450480896734578E-003; dnu[7][1] = 7.0464225345802041774796E-003; dnu[7][2] = -7.0440797582541505326634E-003; dnu[7][3] = 7.0401759812768306624229E-003; dnu[7][4] = -7.0347124789067876590744E-003; dnu[7][5] = 7.0276910363249821385840E-003; dnu[7][6] = -7.0191139484543116517120E-003; dnu[7][7] = 7.0089840197283044049361E-003; dnu[7][8] = -6.9973045638095399259442E-003; dnu[7][9] = 6.9840794032584692578639E-003; dnu[7][10] = -6.9693128691534254021309E-003; dnu[7][11] = 6.9530098006627306317656E-003; dnu[7][12] = -6.9351755445699204984798E-003; dnu[7][13] = 6.9158159547532143382480E-003; dnu[7][14] = -6.8949373916204682587172E-003; dnu[7][15] = 6.8725467215009483161260E-003; dnu[7][16] = -6.8486513159953581290272E-003; dnu[7][17] = 6.8232590512856457141999E-003; dnu[7][18] = -6.7963783074061979548022E-003; dnu[7][19] = 6.7680179674781068068327E-003; dnu[7][20] = -6.7381874169082579908596E-003; dnu[7][21] = 6.7068965425550492564832E-003; dnu[7][22] = -6.6741557318625899765387E-003; dnu[7][23] = 6.6399758719652653251888E-003; dnu[7][24] = -6.6043683487645649827596E-003; dnu[7][25] = 6.5673450459800764181907E-003; dnu[7][26] = -6.5289183441765244201247E-003; dnu[7][27] = 6.4891011197686996429211E-003; dnu[7][28] = -6.4479067440060573471011E-003; dnu[7][29] = 6.4053490819386809834209E-003; dnu[7][30] = -6.3614424913661914531436E-003; dnu[7][31] = 6.3162018217710393822703E-003; dnu[7][32] = -6.2696424132374421767099E-003; dnu[7][33] = 6.2217800953570176315748E-003; dnu[7][34] = -6.1726311861219192272652E-003; dnu[7][35] = 6.1222124908059929493146E-003; dnu[7][36] = -6.0705413008341498394934E-003; dnu[7][37] = 6.0176353926397813152249E-003; dnu[7][38] = -5.9635130265096350201115E-003; dnu[7][39] = 5.9081929454151178816124E-003; dnu[7][40] = -5.8516943738285015503310E-003; dnu[7][41] = 5.7940370165219762842120E-003; dnu[7][42] = -5.7352410573469371902001E-003; dnu[7][43] = 5.6753271579902983008672E-003; dnu[7][44] = -5.6143164567040246767818E-003; dnu[7][45] = 5.5522305670034632684997E-003; dnu[7][46] = -5.4890915763294562348151E-003; dnu[7][47] = 5.4249220446686570495123E-003; dnu[7][48] = -5.3597450031259668116140E-003; dnu[7][49] = 5.2935839524425989654714E-003; dnu[7][50] = -5.2264628614530059630555E-003; dnu[7][51] = 5.1584061654738108409604E-003; dnu[7][52] = -5.0894387646180398667368E-003; dnu[7][53] = 5.0195860220284203990905E-003; dnu[7][54] = -4.9488737620243748720069E-003; dnu[7][55] = 4.8773282681587057305415E-003; dnu[7][56] = -4.8049762811819415048301E-003; dnu[7][57] = 4.7318449969150326471362E-003; dnu[7][58] = -4.6579620640346975465785E-003; dnu[7][59] = 4.5833555817803942033526E-003; dnu[7][60] = -4.5080540975978215800133E-003; dnu[7][61] = 4.4320866047412471320571E-003; dnu[7][62] = -4.3554825398660434367881E-003; dnu[7][63] = 4.2782717806538448095865E-003; dnu[7][64] = -4.2004846435259663177174E-003; dnu[7][65] = 4.1221518815164340152753E-003; dnu[7][66] = -4.0433046823944299854870E-003; dnu[7][67] = 3.9639746671474245551263E-003; dnu[7][68] = -3.8841938889609956099821E-003; dnu[7][69] = 3.8039948328595282916087E-003; dnu[7][70] = -3.7234104162037955087026E-003; dnu[7][71] = 3.6424739902769035319399E-003; dnu[7][72] = -3.5612193432291935765854E-003; dnu[7][73] = 3.4796807046952114697225E-003; dnu[7][74] = -3.3978927524413866973932E-003; dnu[7][75] = 3.3158906214509439470610E-003; dnu[7][76] = -3.2337099159018433636835E-003; dnu[7][77] = 3.1513867245428793585820E-003; dnu[7][78] = -3.0689576400206925217416E-003; dnu[7][79] = 2.9864597827540829024736E-003; dnu[7][80] = -2.9039308299887836817462E-003; dnu[7][81] = 2.8214090506922220792273E-003; dnu[7][82] = -2.7389333469594754120082E-003; dnu[7][83] = 2.6565433025935282831440E-003; dnu[7][84] = -2.5742792394890888809216E-003; dnu[7][85] = 2.4921822823827693006000E-003; dnu[7][86] = -2.4102944324256341738246E-003; dnu[7][87] = 2.3286586498784273886390E-003; dnu[7][88] = -2.2473189460160339308202E-003; dnu[7][89] = 2.1663204840464914272688E-003; dnu[7][90] = -2.0857096884920394263960E-003; dnu[7][91] = 2.0055343620375116994450E-003; dnu[7][92] = -1.9258438083199354620415E-003; dnu[7][93] = 1.8466889585128254091286E-003; dnu[7][94] = -1.7681224988583888670116E-003; dnu[7][95] = 1.6901989955434601911750E-003; dnu[7][96] = -1.6129750125439342307013E-003; dnu[7][97] = 1.5365092173512891617039E-003; dnu[7][98] = -1.4608624689589098768899E-003; dnu[7][99] = 1.3860978822967254969976E-003; dnu[7][100] = -1.3122808637022147812835E-003; dnu[7][101] = 1.2394791133287839653391E-003; dnu[7][102] = -1.1677625930285804368514E-003; dnu[7][103] = 1.0972034626819194194015E-003; dnu[7][104] = -1.0278759946636732617923E-003; dnu[7][105] = 9.5985648550693620626136E-004; dnu[7][106] = -8.9322319587932491235173E-004; dnu[7][107] = 8.2805636407722630260841E-004; dnu[7][108] = -7.6443835254388278387516E-004; dnu[7][109] = 7.0245399782757232135761E-004; dnu[7][110] = -6.4219123594850509816130E-004; dnu[7][111] = 5.8374205871497970384667E-004; dnu[7][112] = -5.2720381143165805354149E-004; dnu[7][113] = 4.7268075842926269123151E-004; dnu[7][114] = -4.2028571635537372133344E-004; dnu[7][115] = 3.7014140212225166523158E-004; dnu[7][116] = -3.2238102065234630638566E-004; dnu[7][117] = 2.7714765746518735745887E-004; dnu[7][118] = -2.3459246214726554551974E-004; dnu[7][119] = 1.9487264223664114660778E-004; dnu[7][120] = -1.5815182927018453366651E-004; dnu[7][121] = 1.2460620024149864701227E-004; dnu[7][122] = -9.4436690910239873306717E-005; dnu[7][123] = 6.7877455474614359864921E-005; dnu[7][124] = -4.5183414893318604279565E-005; dnu[7][125] = 2.6637646834890306562676E-005; dnu[7][126] = -1.2689112411790928068031E-005; dnu[7][127] = 3.4689682162054133584769E-006; xnu[8][0] = 5.0000000000000000000000E-001; xnu[8][1] = 5.0352356922966837324257E-001; xnu[8][2] = 5.0704694320539123130709E-001; xnu[8][3] = 5.1056992668916554416748E-001; xnu[8][4] = 5.1409232447487284716970E-001; xnu[8][5] = 5.1761394140422051163016E-001; xnu[8][6] = 5.2113458238268180160620E-001; xnu[8][7] = 5.2465405239543431335782E-001; xnu[8][8] = 5.2817215652329639498598E-001; xnu[8][9] = 5.3168869995866114493983E-001; xnu[8][10] = 5.3520348802142758953165E-001; xnu[8][11] = 5.3871632617492864128376E-001; xnu[8][12] = 5.4222702004185544185509E-001; xnu[8][13] = 5.4573537542017769545473E-001; xnu[8][14] = 5.4924119829905960104514E-001; xnu[8][15] = 5.5274429487477099426633E-001; xnu[8][16] = 5.5624447156659331287292E-001; xnu[8][17] = 5.5974153503272000256669E-001; xnu[8][18] = 5.6323529218615098342533E-001; xnu[8][19] = 5.6672555021058080067206E-001; xnu[8][20] = 5.7021211657628008729691E-001; xnu[8][21] = 5.7369479905596997002704E-001; xnu[8][22] = 5.7717340574068905434622E-001; xnu[8][23] = 5.8064774505565262868030E-001; xnu[8][24] = 5.8411762577610373249116E-001; xnu[8][25] = 5.8758285704315573785372E-001; xnu[8][26] = 5.9104324837962609912320E-001; xnu[8][27] = 5.9449860970586093052960E-001; xnu[8][28] = 5.9794875135555007695773E-001; xnu[8][29] = 6.0139348409153234877826E-001; xnu[8][30] = 6.0483261912159059738317E-001; xnu[8][31] = 6.0826596811423631404069E-001; xnu[8][32] = 6.1169334321448344081410E-001; xnu[8][33] = 6.1511455705961108857785E-001; xnu[8][34] = 6.1852942279491486360633E-001; xnu[8][35] = 6.2193775408944651079646E-001; xnu[8][36] = 6.2533936515174158830648E-001; xnu[8][37] = 6.2873407074553489524063E-001; xnu[8][38] = 6.3212168620546338097247E-001; xnu[8][39] = 6.3550202745275627176810E-001; xnu[8][40] = 6.3887491101091215753268E-001; xnu[8][41] = 6.4224015402136278874800E-001; xnu[8][42] = 6.4559757425912334098185E-001; xnu[8][43] = 6.4894699014842891171828E-001; xnu[8][44] = 6.5228822077835702166766E-001; xnu[8][45] = 6.5562108591843590015010E-001; xnu[8][46] = 6.5894540603423834159087E-001; xnu[8][47] = 6.6226100230296092760332E-001; xnu[8][48] = 6.6556769662898841654632E-001; xnu[8][49] = 6.6886531165944310981029E-001; xnu[8][50] = 6.7215367079971901138831E-001; xnu[8][51] = 6.7543259822900060450540E-001; xnu[8][52] = 6.7870191891576607618811E-001; xnu[8][53] = 6.8196145863327482763471E-001; xnu[8][54] = 6.8521104397503911506877E-001; xnu[8][55] = 6.8845050237027967240092E-001; xnu[8][56] = 6.9167966209936517345824E-001; xnu[8][57] = 6.9489835230923539773967E-001; xnu[8][58] = 6.9810640302880796959126E-001; xnu[8][59] = 7.0130364518436854633556E-001; xnu[8][60] = 7.0448991061494433620452E-001; xnu[8][61] = 7.0766503208766083188217E-001; xnu[8][62] = 7.1082884331308165002815E-001; xnu[8][63] = 7.1398117896053137129164E-001; xnu[8][64] = 7.1712187467340127900104E-001; xnu[8][65] = 7.2025076708443789789144E-001; xnu[8][66] = 7.2336769383101423687111E-001; xnu[8][67] = 7.2647249357038364189194E-001; xnu[8][68] = 7.2956500599491616643675E-001; xnu[8][69] = 7.3264507184731736792908E-001; xnu[8][70] = 7.3571253293582943846704E-001; xnu[8][71] = 7.3876723214941457764179E-001; xnu[8][72] = 7.4180901347292051378108E-001; xnu[8][73] = 7.4483772200222807771818E-001; xnu[8][74] = 7.4785320395938073008506E-001; xnu[8][75] = 7.5085530670769593912527E-001; xnu[8][76] = 7.5384387876685830107739E-001; xnu[8][77] = 7.5681876982799428925371E-001; xnu[8][78] = 7.5977983076872851099646E-001; xnu[8][79] = 7.6272691366822134369754E-001; xnu[8][80] = 7.6565987182218781198605E-001; xnu[8][81] = 7.6857855975789755799089E-001; xnu[8][82] = 7.7148283324915574524615E-001; xnu[8][83] = 7.7437254933126472430380E-001; xnu[8][84] = 7.7724756631596627443319E-001; xnu[8][85] = 7.8010774380636422090881E-001; xnu[8][86] = 7.8295294271182721131149E-001; xnu[8][87] = 7.8578302526287141699609E-001; xnu[8][88] = 7.8859785502602290742185E-001; xnu[8][89] = 7.9139729691865942541974E-001; xnu[8][90] = 7.9418121722383127071718E-001; xnu[8][91] = 7.9694948360506097719637E-001; xnu[8][92] = 7.9970196512112144648713E-001; xnu[8][93] = 8.0243853224079217665963E-001; xnu[8][94] = 8.0515905685759320007779E-001; xnu[8][95] = 8.0786341230449631900687E-001; xnu[8][96] = 8.1055147336861320147034E-001; xnu[8][97] = 8.1322311630585987327081E-001; xnu[8][98] = 8.1587821885559711520679E-001; xnu[8][99] = 8.1851666025524624753565E-001; xnu[8][100] = 8.2113832125487975688706E-001; xnu[8][101] = 8.2374308413178619439088E-001; xnu[8][102] = 8.2633083270500874805039E-001; xnu[8][103] = 8.2890145234985686771097E-001; xnu[8][104] = 8.3145483001239029773051E-001; xnu[8][105] = 8.3399085422387485108267E-001; xnu[8][106] = 8.3650941511520923959944E-001; xnu[8][107] = 8.3901040443132225891910E-001; xnu[8][108] = 8.4149371554553961404354E-001; xnu[8][109] = 8.4395924347391966287784E-001; xnu[8][110] = 8.4640688488955735144733E-001; xnu[8][111] = 8.4883653813685561645313E-001; xnu[8][112] = 8.5124810324576353930490E-001; xnu[8][113] = 8.5364148194598055170579E-001; xnu[8][114] = 8.5601657768112601729334E-001; xnu[8][115] = 8.5837329562287354788348E-001; xnu[8][116] = 8.6071154268504945774249E-001; xnu[8][117] = 8.6303122753769481634259E-001; xnu[8][118] = 8.6533226062109063066465E-001; xnu[8][119] = 8.6761455415974577383172E-001; xnu[8][120] = 8.6987802217634737933861E-001; xnu[8][121] = 8.7212258050567354115472E-001; xnu[8][122] = 8.7434814680846830141141E-001; xnu[8][123] = 8.7655464058527907126126E-001; xnu[8][124] = 8.7874198319025681896313E-001; xnu[8][125] = 8.8091009784491957458672E-001; xnu[8][126] = 8.8305890965188004535834E-001; xnu[8][127] = 8.8518834560853841213875E-001; xnu[8][128] = 8.8729833462074168851793E-001; xnu[8][129] = 8.8938880751641137235105E-001; xnu[8][130] = 8.9145969705914150819259E-001; xnu[8][131] = 8.9351093796176971108496E-001; xnu[8][132] = 8.9554246689992418071732E-001; xnu[8][133] = 8.9755422252555026338988E-001; xnu[8][134] = 8.9954614548042070089990E-001; xnu[8][135] = 9.0151817840963434389085E-001; xnu[8][136] = 9.0347026597510880592815E-001; xnu[8][137] = 9.0540235486907329718058E-001; xnu[8][138] = 9.0731439382756870671791E-001; xnu[8][139] = 9.0920633364396290369770E-001; xnu[8][140] = 9.1107812718249020368626E-001; xnu[8][141] = 9.1292972939182500054383E-001; xnu[8][142] = 9.1476109731870070008905E-001; xnu[8][143] = 9.1657219012158631236397E-001; xnu[8][144] = 9.1836296908443436775138E-001; xnu[8][145] = 9.2013339763051522117512E-001; xnu[8][146] = 9.2188344133635430051916E-001; xnu[8][147] = 9.2361306794579044219027E-001; xnu[8][148] = 9.2532224738417513987891E-001; xnu[8][149] = 9.2701095177273431290670E-001; xnu[8][150] = 9.2867915544311607826256E-001; xnu[8][151] = 9.3032683495214998490117E-001; xnu[8][152] = 9.3195396909684523857321E-001; xnu[8][153] = 9.3356053892965760780721E-001; xnu[8][154] = 9.3514652777405695292558E-001; xnu[8][155] = 9.3671192124042965509622E-001; xnu[8][156] = 9.3825670724235263487081E-001; xnu[8][157] = 9.3978087601327813128378E-001; xnu[8][158] = 9.4128442012367095342085E-001; xnu[8][159] = 9.4276733449864250446303E-001; xnu[8][160] = 9.4422961643612849944521E-001; xnu[8][161] = 9.4567126562565993583304E-001; xnu[8][162] = 9.4709228416777951142968E-001; xnu[8][163] = 9.4849267659415829518778E-001; xnu[8][164] = 9.4987244988847001831932E-001; xnu[8][165] = 9.5123161350808283752414E-001; xnu[8][166] = 9.5257017940663079759465E-001; xnu[8][167] = 9.5388816205752945181220E-001; xnu[8][168] = 9.5518557847850214624890E-001; xnu[8][169] = 9.5646244825718529503981E-001; xnu[8][170] = 9.5771879357788252032198E-001; xnu[8][171] = 9.5895463924953875081824E-001; xnu[8][172] = 9.6017001273500621036491E-001; xnu[8][173] = 9.6136494418167462076137E-001; xnu[8][174] = 9.6253946645353782618207E-001; xnu[8][175] = 9.6369361516476834842161E-001; xnu[8][176] = 9.6482742871487002833506E-001; xnu[8][177] = 9.6594094832547681967268E-001; xnu[8][178] = 9.6703421807886289399974E-001; xnu[8][179] = 9.6810728495822540331247E-001; xnu[8][180] = 9.6916019888979644182741E-001; xnu[8][181] = 9.7019301278683486068516E-001; xnu[8][182] = 9.7120578259554152990628E-001; xnu[8][183] = 9.7219856734293332429533E-001; xnu[8][184] = 9.7317142918670145257425E-001; xnu[8][185] = 9.7412443346706867853133E-001; xnu[8][186] = 9.7505764876064743827892E-001; xnu[8][187] = 9.7597114693628679474913E-001; xnu[8][188] = 9.7686500321288056820737E-001; xnu[8][189] = 9.7773929621909184878677E-001; xnu[8][190] = 9.7859410805493048136810E-001; xnu[8][191] = 9.7942952435510011067792E-001; xnu[8][192] = 9.8024563435401014171175E-001; xnu[8][193] = 9.8104253095232573787034E-001; xnu[8][194] = 9.8182031078490606626049E-001; xnu[8][195] = 9.8257907428995783298937E-001; xnu[8][196] = 9.8331892577920828354614E-001; xnu[8][197] = 9.8403997350887997398176E-001; xnu[8][198] = 9.8474232975122961588545E-001; xnu[8][199] = 9.8542611086639622162798E-001; xnu[8][200] = 9.8609143737429089828903E-001; xnu[8][201] = 9.8673843402625346338665E-001; xnu[8][202] = 9.8736722987620133388036E-001; xnu[8][203] = 9.8797795835100587656440E-001; xnu[8][204] = 9.8857075731985285707820E-001; xnu[8][205] = 9.8914576916237926976304E-001; xnu[8][206] = 9.8970314083543134190307E-001; xnu[8][207] = 9.9024302393836066970799E-001; xnu[8][208] = 9.9076557477687005343368E-001; xnu[8][209] = 9.9127095442554030212529E-001; xnu[8][210] = 9.9175932878931636438083E-001; xnu[8][211] = 9.9223086866440726729820E-001; xnu[8][212] = 9.9268574979926018555688E-001; xnu[8][213] = 9.9312415295650377634075E-001; xnu[8][214] = 9.9354626397701703359495E-001; xnu[8][215] = 9.9395227384756214023332E-001; xnu[8][216] = 9.9434237877371473996926E-001; xnu[8][217] = 9.9471678026012041935822E-001; xnu[8][218] = 9.9507568520038507959027E-001; xnu[8][219] = 9.9541930597914712183853E-001; xnu[8][220] = 9.9574786058905306619925E-001; xnu[8][221] = 9.9606157276543155884129E-001; xnu[8][222] = 9.9636067214139430766410E-001; xnu[8][223] = 9.9664539442584248310532E-001; xnu[8][224] = 9.9691598160637751110426E-001; xnu[8][225] = 9.9717268217836170296553E-001; xnu[8][226] = 9.9741575140031050025957E-001; xnu[8][227] = 9.9764545157440515113072E-001; xnu[8][228] = 9.9786205234920359425472E-001; xnu[8][229] = 9.9806583103965751889305E-001; xnu[8][230] = 9.9825707295744513692434E-001; xnu[8][231] = 9.9843607174263008064974E-001; xnu[8][232] = 9.9860312968611097953823E-001; xnu[8][233] = 9.9875855803173619998262E-001; xnu[8][234] = 9.9890267724797863728092E-001; xnu[8][235] = 9.9903581726246516165093E-001; xnu[8][236] = 9.9915831765920369626532E-001; xnu[8][237] = 9.9927052784858395301327E-001; xnu[8][238] = 9.9937280723404755735176E-001; xnu[8][239] = 9.9946552541540528111790E-001; xnu[8][240] = 9.9954906248383379883111E-001; xnu[8][241] = 9.9962380947167123679948E-001; xnu[8][242] = 9.9969016901251179096404E-001; xnu[8][243] = 9.9974855623359359526763E-001; xnu[8][244] = 9.9979939983595534162598E-001; xnu[8][245] = 9.9984314322415886588808E-001; xnu[8][246] = 9.9988024546221602366522E-001; xnu[8][247] = 9.9991118183989386959794E-001; xnu[8][248] = 9.9993644406017880596898E-001; xnu[8][249] = 9.9995654057233914140003E-001; xnu[8][250] = 9.9997199810352718788193E-001; xnu[8][251] = 9.9998336504924313844142E-001; xnu[8][252] = 9.9999121517744579929001E-001; xnu[8][253] = 9.9999614906812879401388E-001; xnu[8][254] = 9.9999879818987423231012E-001; xnu[8][255] = 9.9999983647836719219063E-001; dnu[8][0] = -3.5236017725240448367289E-003; dnu[8][1] = 3.5235041442227400686498E-003; dnu[8][2] = -3.5232112672901020887398E-003; dnu[8][3] = 3.5227231656397573838983E-003; dnu[8][4] = -3.5220398791270752663317E-003; dnu[8][5] = 3.5211614635481560479832E-003; dnu[8][6] = -3.5200879906384153312115E-003; dnu[8][7] = 3.5188195480707652615937E-003; dnu[8][8] = -3.5173562394533938295372E-003; dnu[8][9] = 3.5156981843271435475412E-003; dnu[8][10] = -3.5138455181624910692920E-003; dnu[8][11] = 3.5117983923561295551537E-003; dnu[8][12] = -3.5095569742271558258560E-003; dnu[8][13] = 3.5071214470128645821259E-003; dnu[8][14] = -3.5044920098641522024681E-003; dnu[8][15] = 3.5016688778405328640984E-003; dnu[8][16] = -3.4986522819047699629721E-003; dnu[8][17] = 3.4954424689171260377234E-003; dnu[8][18] = -3.4920397016292346289319E-003; dnu[8][19] = 3.4884442586775977292236E-003; dnu[8][20] = -3.4846564345767127010655E-003; dnu[8][21] = 3.4806765397118327574657E-003; dnu[8][22] = -3.4765049003313653158828E-003; dnu[8][23] = 3.4721418585389127471901E-003; dnu[8][24] = -3.4675877722849602492399E-003; dnu[8][25] = 3.4628430153582157781065E-003; dnu[8][26] = -3.4579079773766071691240E-003; dnu[8][27] = 3.4527830637779417740149E-003; dnu[8][28] = -3.4474686958102341293586E-003; dnu[8][29] = 3.4419653105217073549737E-003; dnu[8][30] = -3.4362733607504741580630E-003; dnu[8][31] = 3.4303933151139034897570E-003; dnu[8][32] = -3.4243256579976790645136E-003; dnu[8][33] = 3.4180708895445561092032E-003; dnu[8][34] = -3.4116295256428228571000E-003; dnu[8][35] = 3.4050020979144734418687E-003; dnu[8][36] = -3.3981891537030989774011E-003; dnu[8][37] = 3.3911912560615037304123E-003; dnu[8][38] = -3.3840089837390534034163E-003; dnu[8][39] = 3.3766429311687626453919E-003; dnu[8][40] = -3.3690937084541289954298E-003; dnu[8][41] = 3.3613619413557205401809E-003; dnu[8][42] = -3.3534482712775246282416E-003; dnu[8][43] = 3.3453533552530650329179E-003; dnu[8][44] = -3.3370778659312949882693E-003; dnu[8][45] = 3.3286224915622735410861E-003; dnu[8][46] = -3.3199879359826326625944E-003; dnu[8][47] = 3.3111749186008425472876E-003; dnu[8][48] = -3.3021841743822824913798E-003; dnu[8][49] = 3.2930164538341246889724E-003; dnu[8][50] = -3.2836725229900382090953E-003; dnu[8][51] = 3.2741531633947203202702E-003; dnu[8][52] = -3.2644591720882622100624E-003; dnu[8][53] = 3.2545913615903560041347E-003; dnu[8][54] = -3.2445505598843498214605E-003; dnu[8][55] = 3.2343376104011574084413E-003; dnu[8][56] = -3.2239533720030286735506E-003; dnu[8][57] = 3.2133987189671871946092E-003; dnu[8][58] = -3.2026745409693404917104E-003; dnu[8][59] = 3.1917817430670685489766E-003; dnu[8][60] = -3.1807212456830957265718E-003; dnu[8][61] = 3.1694939845884508295582E-003; dnu[8][62] = -3.1581009108855196911351E-003; dnu[8][63] = 3.1465429909909941834386E-003; dnu[8][64] = -3.1348212066187210883550E-003; dnu[8][65] = 3.1229365547624537427064E-003; dnu[8][66] = -3.1108900476785088157874E-003; dnu[8][67] = 3.0986827128683299817099E-003; dnu[8][68] = -3.0863155930609596136326E-003; dnu[8][69] = 3.0737897461954189510710E-003; dnu[8][70] = -3.0611062454029964746573E-003; dnu[8][71] = 3.0482661789894434646161E-003; dnu[8][72] = -3.0352706504170749197467E-003; dnu[8][73] = 3.0221207782867731729442E-003; dnu[8][74] = -3.0088176963198906576125E-003; dnu[8][75] = 2.9953625533400473573579E-003; dnu[8][76] = -2.9817565132548175100558E-003; dnu[8][77] = 2.9680007550372991380706E-003; dnu[8][78] = -2.9540964727075589408062E-003; dnu[8][79] = 2.9400448753139440160228E-003; dnu[8][80] = -2.9258471869142507751655E-003; dnu[8][81] = 2.9115046465567402885106E-003; dnu[8][82] = -2.8970185082609881421060E-003; dnu[8][83] = 2.8823900409985557147716E-003; dnu[8][84] = -2.8676205286734685951001E-003; dnu[8][85] = 2.8527112701024866615598E-003; dnu[8][86] = -2.8376635789951491504336E-003; dnu[8][87] = 2.8224787839335768444255E-003; dnu[8][88] = -2.8071582283520123383909E-003; dnu[8][89] = 2.7917032705160781880498E-003; dnu[8][90] = -2.7761152835017316342499E-003; dnu[8][91] = 2.7603956551738935322869E-003; dnu[8][92] = -2.7445457881647281174076E-003; dnu[8][93] = 2.7285670998515493199771E-003; dnu[8][94] = -2.7124610223343285247561E-003; dnu[8][95] = 2.6962290024127779680319E-003; dnu[8][96] = -2.6798725015629834058070E-003; dnu[8][97] = 2.6633929959135592898706E-003; dnu[8][98] = -2.6467919762212994827357E-003; dnu[8][99] = 2.6300709478462965560248E-003; dnu[8][100] = -2.6132314307265029815277E-003; dnu[8][101] = 2.5962749593517080743133E-003; dnu[8][102] = -2.5792030827369054204802E-003; dnu[8][103] = 2.5620173643950267591546E-003; dnu[8][104] = -2.5447193823090199333684E-003; dnu[8][105] = 2.5273107289032506252914E-003; dnu[8][106] = -2.5097930110142101995453E-003; dnu[8][107] = 2.4921678498605151495699E-003; dnu[8][108] = -2.4744368810121874360035E-003; dnu[8][109] = 2.4566017543592094868339E-003; dnu[8][110] = -2.4386641340793528652707E-003; dnu[8][111] = 2.4206256986052856760690E-003; dnu[8][112] = -2.4024881405909707524150E-003; dnu[8][113] = 2.3842531668773746263160E-003; dnu[8][114] = -2.3659224984575163235681E-003; dnu[8][115] = 2.3474978704408952326600E-003; dnu[8][116] = -2.3289810320173487732893E-003; dnu[8][117] = 2.3103737464204034374082E-003; dnu[8][118] = -2.2916777908901971016763E-003; dnu[8][119] = 2.2728949566360664274378E-003; dnu[8][120] = -2.2540270487989107900066E-003; dnu[8][121] = 2.2350758864134636345022E-003; dnu[8][122] = -2.2160433023706235660286E-003; dnu[8][123] = 2.1969311433800209763024E-003; dnu[8][124] = -2.1777412699330217183940E-003; dnu[8][125] = 2.1584755562663973996390E-003; dnu[8][126] = -2.1391358903269224047932E-003; dnu[8][127] = 2.1197241737371909221716E-003; dnu[8][128] = -2.1002423217629831588587E-003; dnu[8][129] = 2.0806922632825487288194E-003; dnu[8][130] = -2.0610759407582170076376E-003; dnu[8][131] = 2.0413953102107891917508E-003; dnu[8][132] = -2.0216523411972149927435E-003; dnu[8][133] = 2.0018490167921084428078E-003; dnu[8][134] = -1.9819873335737122775631E-003; dnu[8][135] = 1.9620693016149788733009E-003; dnu[8][136] = -1.9420969444804978049911E-003; dnu[8][137] = 1.9220722992300657945837E-003; dnu[8][138] = -1.9019974164297641458043E-003; dnu[8][139] = 1.8818743601714816912025E-003; dnu[8][140] = -1.8617052081018977543513E-003; dnu[8][141] = 1.8414920514620195598335E-003; dnu[8][142] = -1.8212369951384517659700E-003; dnu[8][143] = 1.8009421577276621593433E-003; dnu[8][144] = -1.7806096716145967882927E-003; dnu[8][145] = 1.7602416830670896134102E-003; dnu[8][146] = -1.7398403523476057348613E-003; dnu[8][147] = 1.7194078538439529593811E-003; dnu[8][148] = -1.6989463762206933486966E-003; dnu[8][149] = 1.6784581225930838067080E-003; dnu[8][150] = -1.6579453107254719735305E-003; dnu[8][151] = 1.6374101732561698478224E-003; dnu[8][152] = -1.6168549579509216818417E-003; dnu[8][153] = 1.5962819279871736839512E-003; dnu[8][154] = -1.5756933622714396792910E-003; dnu[8][155] = 1.5550915557921377307891E-003; dnu[8][156] = -1.5344788200103462608708E-003; dnu[8][157] = 1.5138574832909927223987E-003; dnu[8][158] = -1.4932298913770414512368E-003; dnu[8][159] = 1.4725984079092879114196E-003; dnu[8][160] = -1.4519654149943918408731E-003; dnu[8][161] = 1.4313333138237893412643E-003; dnu[8][162] = -1.4107045253461110396137E-003; dnu[8][163] = 1.3900814909956971752233E-003; dnu[8][164] = -1.3694666734797377060041E-003; dnu[8][165] = 1.3488625576264729333326E-003; dnu[8][166] = -1.3282716512967641415720E-003; dnu[8][167] = 1.3076964863611805461264E-003; dnu[8][168] = -1.2871396197445444404608E-003; dnu[8][169] = 1.2666036345396266287484E-003; dnu[8][170] = -1.2460911411913846503000E-003; dnu[8][171] = 1.2256047787527824196154E-003; dnu[8][172] = -1.2051472162128170869123E-003; dnu[8][173] = 1.1847211538969024757289E-003; dnu[8][174] = -1.1643293249392136943195E-003; dnu[8][175] = 1.1439744968259798618913E-003; dnu[8][176] = -1.1236594730080169654101E-003; dnu[8][177] = 1.1033870945800166459678E-003; dnu[8][178] = -1.0831602420232457136344E-003; dnu[8][179] = 1.0629818370073626652228E-003; dnu[8][180] = -1.0428548442460197131980E-003; dnu[8][181] = 1.0227822733997914672317E-003; dnu[8][182] = -1.0027671810187558497225E-003; dnu[8][183] = 9.8281267251575273865993E-004; dnu[8][184] = -9.6292190415996773102075E-004; dnu[8][185] = 9.4309808507904237696790E-004; dnu[8][186] = -9.2334447925641270456432E-004; dnu[8][187] = 9.0366440750904465039505E-004; dnu[8][188] = -8.8406124942919443350579E-004; dnu[8][189] = 8.6453844527230803583806E-004; dnu[8][190] = -8.4509949777173009558748E-004; dnu[8][191] = 8.2574797385957285327574E-004; dnu[8][192] = -8.0648750627196711535064E-004; dnu[8][193] = 7.8732179501606083094277E-004; dnu[8][194] = -7.6825460867564458085196E-004; dnu[8][195] = 7.4928978553228318107157E-004; dnu[8][196] = -7.3043123447945493844494E-004; dnu[8][197] = 7.1168293570860259950151E-004; dnu[8][198] = -6.9304894114836274849880E-004; dnu[8][199] = 6.7453337464176556563600E-004; dnu[8][200] = -6.5614043185110739064173E-004; dnu[8][201] = 6.3787437988673473672259E-004; dnu[8][202] = -6.1973955666439198266955E-004; dnu[8][203] = 6.0174037000632982440356E-004; dnu[8][204] = -5.8388129651429021842567E-004; dnu[8][205] = 5.6616688025798832458331E-004; dnu[8][206] = -5.4860173134095970970073E-004; dnu[8][207] = 5.3119052442670035687534E-004; dnu[8][208] = -5.1393799733183663089639E-004; dnu[8][209] = 4.9684894981938042897235E-004; dnu[8][210] = -4.7992824275346810313068E-004; dnu[8][211] = 4.6318079780655564168411E-004; dnu[8][212] = -4.4661159793966245617026E-004; dnu[8][213] = 4.3022568890426392406400E-004; dnu[8][214] = -4.1402818203861315130421E-004; dnu[8][215] = 3.9802425864877543575304E-004; dnu[8][216] = -3.8221917627194139209526E-004; dnu[8][217] = 3.6661827711238395602767E-004; dnu[8][218] = -3.5122699891378616067880E-004; dnu[8][219] = 3.3605088848005409732297E-004; dnu[8][220] = -3.2109561797425254420128E-004; dnu[8][221] = 3.0636700400611260464706E-004; dnu[8][222] = -2.9187102935748985192333E-004; dnu[8][223] = 2.7761386698865378985736E-004; dnu[8][224] = -2.6360190571582919306239E-004; dnu[8][225] = 2.4984177665640024225928E-004; dnu[8][226] = -2.3634037921463134561575E-004; dnu[8][227] = 2.2310490505070162374404E-004; dnu[8][228] = -2.1014285817768061591171E-004; dnu[8][229] = 1.9746206912343685221695E-004; dnu[8][230] = -1.8507070106112583261579E-004; dnu[8][231] = 1.7297724606495193567507E-004; dnu[8][232] = -1.6119051032643119483180E-004; dnu[8][233] = 1.4971958842545586543710E-004; dnu[8][234] = -1.3857382873259367872945E-004; dnu[8][235] = 1.2776279479761843100676E-004; dnu[8][236] = -1.1729623106196260243797E-004; dnu[8][237] = 1.0718404501710846857448E-004; dnu[8][238] = -9.7436321118320573341744E-005; dnu[8][239] = 8.8063382772541597737195E-005; dnu[8][240] = -7.9075915205566116981157E-005; dnu[8][241] = 7.0485151102052395706581E-005; dnu[8][242] = -6.2303100120749462771247E-005; dnu[8][243] = 5.4542772822870761025480E-005; dnu[8][244] = -4.7218316126617180477170E-005; dnu[8][245] = 4.0344961400701764692553E-005; dnu[8][246] = -3.3938727737915739053586E-005; dnu[8][247] = 2.8015975392808212607024E-005; dnu[8][248] = -2.2593183623060767475330E-005; dnu[8][249] = 1.7687568602759479431384E-005; dnu[8][250] = -1.3318826217940261494781E-005; dnu[8][251] = 9.5106840952937908339661E-006; dnu[8][252] = -6.2892960976606935680311E-006; dnu[8][253] = 3.6831203455116083442839E-006; dnu[8][254] = -1.7416856803596676839876E-006; dnu[8][255] = 4.7285796697500352441360E-007; } gss/src/dqrslm.f0000644000176200001440000000252214443702023013306 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dqrslm (x, ldx, n, k, qraux, a, lda, job, info, work) integer ldx, n, k, lda, job, info double precision x(ldx,*), qraux(*), a(lda,*), work(*) double precision tmp, alph, ddot integer i, j, step info = 0 if( lda .lt. n .or. n .lt. k .or. k .lt. 1 )then info = -1 return endif if( job .ne. 0 .and. job .ne. 1 )then info = 1 return endif if( job .eq. 0 )then j = 1 step = 1 else j = k step = -1 endif 23006 if( j .ge. 1 .and. j .le. k )then if( qraux(j) .eq. 0.0d0 )then j = j + step goto 23006 endif tmp = x(j,j) x(j,j) = qraux(j) i=1 23010 if(.not.(i.lt.j))goto 23012 alph = - ddot (n-j+1, x(j,j), 1, a(j,i), 1) / x(j,j) call daxpy (n-j+1, alph, x(j,j), 1, a(j,i), 1) 23011 i=i+1 goto 23010 23012 continue alph = 1.d0 / x(j,j) call dsymv ('l', n-j+1, alph, a(j,j), lda, x(j,j), 1, 0.d0, work(j *), 1) alph = - ddot (n-j+1, work(j), 1, x(j,j), 1) / 2.d0 / x(j,j) call daxpy (n-j+1, alph, x(j,j), 1, work(j), 1) call dsyr2 ('l', n-j+1, -1.d0, x(j,j), 1, work(j), 1, a(j,j), lda) x(j,j) = tmp j = j + step goto 23006 endif 23007 continue return end gss/src/hzdnewton.f0000644000176200001440000002027014467013476014041 0ustar liggesusersC Output from Public domain Ratfor, version 1.04 subroutine hzdnewton (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, * qdrs, nqd, qdwt, nx, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nt, nobs, nqd, nx, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nxis,*), cntsum, cnt(*), qdrs *(nqd,nxis,*), qdwt(nqd,*), prec, mchpr, wk(*) integer imrs, iwt, ifit, imu, imuwk, iv, ivwk, icdnew, iwtnew, ifi *tnew, iwk imrs = 1 iwt = imrs + max0 (nxis, 2) ifit = iwt + nqd*nx imu = ifit + nt imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis ifitnew = iwtnew + nqd*nx iwk = ifitnew + nt call hzdnewton1 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, qdrs *, nqd, qdwt, nx, prec, maxiter, mchpr, wk(imrs), wk(iwt), wk(ifit) *, wk(imu), wk(imuwk), wk(iv), wk(ivwk), jpvt, wk(icdnew), wk(iwtne *w), wk(ifitnew), wk(iwk), info) return end subroutine hzdnewton1 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt *, qdrs, nqd, qdwt, nx, prec, maxiter, mchpr, mrs, wt, fit, mu, muw *k, v, vwk, jpvt, cdnew, wtnew, fitnew, wk, info) integer nxis, nxi, nt, nobs, nqd, nx, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nxis,*), cntsum, cnt(*), qdrs *(nqd,nxis,*), qdwt(nqd,*), prec, mchpr, mrs(*), wt(nqd,*), fit(*), * mu(*), muwk(*), v(nxis,*), vwk(nxis,*), cdnew(*), wtnew(nqd,*), f *itnew(*), wk(*) integer i, j, k, kk, iter, flag, rkv, idamax, infowk double precision tmp, ddot, fitmean, dasum, lkhd, mumax, lkhdnew, *disc, disc0, trc info = 0 i=1 23000 if(.not.(i.le.nxis))goto 23002 mrs(i) = 0.d0 j=1 23003 if(.not.(j.le.nt))goto 23005 if(.not.(cntsum.gt.0.d0))then mrs(i) = mrs(i) + rs(i,j) else mrs(i) = mrs(i) + rs(i,j) * cnt(j) endif 23004 j=j+1 goto 23003 23005 continue mrs(i) = mrs(i) / dble (nobs) 23001 i=i+1 goto 23000 23002 continue kk=1 23008 if(.not.(kk.le.nx))goto 23010 i=1 23011 if(.not.(i.le.nqd))goto 23013 wt(i,kk) = qdwt(i,kk) * dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1 *)) 23012 i=i+1 goto 23011 23013 continue 23009 kk=kk+1 goto 23008 23010 continue fitmean = 0.d0 i=1 23014 if(.not.(i.le.nt))goto 23016 tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if(cntsum.gt.0.d0)then tmp = tmp * cnt(i) endif fitmean = fitmean + tmp 23015 i=i+1 goto 23014 23016 continue fitmean = fitmean / dble (nobs) - dasum (nqd*nx, wt, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean iter = 0 flag = 0 23019 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23022 if(.not.(kk.le.nx))goto 23024 i=1 23025 if(.not.(i.le.nxis))goto 23027 muwk(i) = - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) j=i 23028 if(.not.(j.le.nxis))goto 23030 vwk(i,j) = 0.d0 k=1 23031 if(.not.(k.le.nqd))goto 23033 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23032 k=k+1 goto 23031 23033 continue 23029 j=j+1 goto 23028 23030 continue 23026 i=i+1 goto 23025 23027 continue call daxpy (nxis, 1.d0, muwk, 1, mu, 1) call daxpy (nxis*nxis, 1.d0, vwk, 1, v, 1) 23023 kk=kk+1 goto 23022 23024 continue i=1 23034 if(.not.(i.le.nxi))goto 23036 j=i 23037 if(.not.(j.le.nxi))goto 23039 v(i,j) = v(i,j) + q(i,j) 23038 j=j+1 goto 23037 23039 continue 23035 i=i+1 goto 23034 23036 continue call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23040 if(.not.(i.le.nxis))goto 23042 jpvt(i) = 0 23041 i=i+1 goto 23040 23042 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23043 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23043 endif 23044 continue i=rkv+1 23045 if(.not.(i.le.nxis))goto 23047 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23046 i=i+1 goto 23045 23047 continue 23048 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) kk=1 23051 if(.not.(kk.le.nx))goto 23053 i=1 23054 if(.not.(i.le.nqd))goto 23056 tmp = ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23056 endif wtnew(i,kk) = qdwt(i,kk) * dexp (tmp) 23055 i=i+1 goto 23054 23056 continue if((flag.eq.1).or.(flag.eq.3))then goto 23053 endif 23052 kk=kk+1 goto 23051 23053 continue if((flag.eq.0).or.(flag.eq.2))then fitmean = 0.d0 i=1 23063 if(.not.(i.le.nt))goto 23065 tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23065 endif fitnew(i) = dexp (tmp) if(cntsum.gt.0.d0)then tmp = tmp * cnt(i) endif fitmean = fitmean + tmp 23064 i=i+1 goto 23063 23065 continue fitmean = fitmean / dble (nobs) - dasum (nqd*nx, wtnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) fitmean = - dasum (nqd*nx, wt, 1) lkhd = - fitmean iter = 0 goto 23050 endif if(flag.eq.3)then goto 23050 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23050 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23050 endif 23049 goto 23048 23050 continue if(flag.eq.1)then flag = 2 goto 23020 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23082 if(.not.(kk.le.nx))goto 23084 i=1 23085 if(.not.(i.le.nqd))goto 23087 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23086 i=i+1 goto 23085 23087 continue 23083 kk=kk+1 goto 23082 23084 continue i=1 23088 if(.not.(i.le.nt))goto 23090 disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) 23089 i=i+1 goto 23088 23090 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1.d0+da *bs(lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nt, fitnew, 1, fit, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23021 endif if(disc.lt.prec)then goto 23021 endif if(iter.lt.maxiter)then goto 23020 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) fitmean = - dasum (nqd*nx, wt, 1) lkhd = - fitmean iter = 0 flag = 2 else info = 2 goto 23021 endif 23020 goto 23019 23021 continue i=1 23099 if(.not.(i.le.nt))goto 23101 call dprmut (rs(1,i), nxis, jpvt, 0) if(cntsum.gt.0.d0)then call dscal (nxis, dsqrt(cnt(i)), rs(1,i), 1) endif call dtrsl (v, nxis, nxis, rs(1,i), 11, infowk) 23100 i=i+1 goto 23099 23101 continue call dprmut (mrs, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, mrs, 11, infowk) trc = ddot (nxis*nt, rs, 1, rs, 1) - dble (nobs) * ddot (nxis, mrs *, 1, mrs, 1) trc = trc / dble(nobs) / (dble(nobs)-1.d0) mrs(1) = fitmean mrs(2) = trc kk=1 23104 if(.not.(kk.le.nx))goto 23106 i=1 23107 if(.not.(i.le.nqd))goto 23109 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) 23108 i=i+1 goto 23107 23109 continue 23105 kk=kk+1 goto 23104 23106 continue return end gss/src/dtrev.f0000644000176200001440000000362514443702023013135 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dtrev (vmu, t, ldt, n, z, score, varht, info, work) character vmu integer n, info double precision t(ldt,*), z(*), score, varht, work(*) double precision nume, deno, tmp, alph, la, dasum, ddot integer j info = 0 if( vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u' )then info = -3 return endif la = t(1,1) alph = dble (n) / dasum (n, t(2,1), ldt) call dscal (n, alph, t(2,1), ldt) call dscal (n-1, alph, t(1,2), ldt) call dpbfa (t, ldt, n, 1, info) if( info .ne. 0 )then return endif call dcopy (n, z, 1, work, 1) call dpbsl (t, ldt, n, 1, work) if( vmu .eq. 'v' )then tmp = 1.d0 / t(2,n) / t(2,n) deno = tmp j=n-1 23006 if(.not.(j.gt.0))goto 23008 tmp = ( 1.d0 + t(1,j+1) * t(1,j+1) * tmp ) / t(2,j) / t(2,j) deno = deno + tmp 23007 j=j-1 goto 23006 23008 continue nume = ddot (n, work, 1, work, 1) / dble (n) deno = deno / dble (n) varht = alph * la * nume / deno score = nume / deno / deno endif if( vmu .eq. 'm' )then deno = dlog (t(2,n)) j=n-1 23011 if(.not.(j.gt.0))goto 23013 deno = deno + dlog (t(2,j)) 23012 j=j-1 goto 23011 23013 continue nume = ddot (n, z, 1, work, 1) / dble (n) varht = alph * la * nume score = nume * dexp (2.d0 * deno / dble (n)) endif if( vmu .eq. 'u' )then nume = ddot (n, work, 1, work, 1) / dble (n) tmp = 1.d0 / t(2,n) / t(2,n) deno = tmp j=n-1 23016 if(.not.(j.gt.0))goto 23018 tmp = ( 1.d0 + t(1,j+1) * t(1,j+1) * tmp ) / t(2,j) / t(2,j) deno = deno + tmp 23017 j=j-1 goto 23016 23018 continue deno = deno / dble (n) score = alph * alph * la * la * nume - 2.d0 * varht * alph * la * *deno endif return end gss/src/dmudr0.f0000644000176200001440000000314614443702023013202 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine dmudr0 (vmu, s, lds, nobs, nnull, q, ldqr, ldqc, nq, y, * tol, init, prec, maxite, theta, nlaht, score, varht, c, d, iwk, w *k, info) integer vmu integer lds, nobs, nnull, ldqr, ldqc, nq, init, maxite, info, iwk( **) double precision s(lds,*), q(ldqr,ldqc,*), y(*), tol, prec, theta( **), nlaht, score, varht, c(*), d(*), wk(*) character vmu1 integer n, n0 integer iqraux, itraux, itwk, iqwk, iywk, ithewk, ihes, igra, ihwk *1, ihwk2, igwk1, igwk2, ikwk, iwork1, iwork2, ijpvt, ipvtwk if( vmu .eq. 1 )then vmu1 = 'v' endif if( vmu .eq. 2 )then vmu1 = 'm' endif if( vmu .eq. 3 )then vmu1 = 'u' endif n = nobs n0 = nnull iqraux = 1 itraux = iqraux + n0 itwk = itraux + (n-n0-2) iqwk = itwk + 2 * (n-n0) iywk = iqwk + n * n ithewk = iywk + n ihes = ithewk + nq igra = ihes + nq * nq ihwk1 = igra + nq ihwk2 = ihwk1 + nq * nq igwk1 = ihwk2 + nq * nq igwk2 = igwk1 + nq ikwk = igwk2 + nq iwork1 = ikwk + (n-n0) * (n-n0) * nq iwork2 = iwork1 + n ijpvt = 1 ipvtwk = ijpvt + n0 call dmudr1 (vmu1, s, lds, nobs, nnull, q, ldqr, ldqc, nq, y, tol, * init, prec, maxite, theta, nlaht, score, varht, c, d, wk(iqraux), * iwk(ijpvt), wk(itwk), wk(itraux), wk(iqwk), wk(iywk), wk(ithewk), * wk(ihes), wk(igra), wk(ihwk1), wk(ihwk2), wk(igwk1), wk(igwk2), i *wk(ipvtwk), wk(ikwk), wk(iwork1), wk(iwork2), info) return end gss/src/Makevars0000644000176200001440000000005613267111001013322 0ustar liggesusersPKG_LIBS=$(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) gss/src/hzdnewton10.f0000644000176200001440000001700514467014077014202 0ustar liggesusersC Output from Public domain Ratfor, version 1.04 subroutine hzdnewton10 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cn *t, intrs, rho, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nt, nobs, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nt,*), cntsum, cnt(*), intrs( **), rho(*), prec, mchpr, wk(*) integer iwt, imu, iv, icdnew, iwtnew, iwk iwt = 1 imu = iwt + nt iv = imu + nxis icdnew = iv + nxis*nxis iwtnew = icdnew + nxis iwk = iwtnew + nt call hzdnewton101 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, in *trs, rho, prec, maxiter, mchpr, wk(iwt), wk(imu), wk(iv), jpvt, wk *(icdnew), wk(iwtnew), wk(iwk), info) return end subroutine hzdnewton101 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, c *nt, intrs, rho, prec, maxiter, mchpr, wt, mu, v, jpvt, cdnew, wtne *w, wk, info) integer nxis, nxi, nt, nobs, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nt,*), cntsum, cnt(*), intrs( **), rho(*), prec, mchpr, wt(*), mu(*), v(nxis,*), cdnew(*), wtnew( **), wk(*) integer i, j, k, iter, flag, rkv, idamax, infowk double precision tmp, ddot, dasum, lkhd, mumax, lkhdnew, disc, dis *c0 info = 0 i=1 23000 if(.not.(i.le.nt))goto 23002 tmp = ddot (nxis, rs(i,1), nt, cd, 1) wt(i) = dexp (-tmp) * rho(i) if(cntsum.gt.0.d0)then wt(i) = wt(i) * cnt(i) endif 23001 i=i+1 goto 23000 23002 continue call dscal (nt, 1/dble(nobs), wt, 1) lkhd = dasum(nt, wt, 1) + ddot (nxis, intrs, 1, cd, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = lkhd + ddot (nxi, cd, 1, wk, 1) / 2.d0 iter = 0 flag = 0 23005 continue iter = iter + 1 i=1 23008 if(.not.(i.le.nxis))goto 23010 mu(i) = ddot (nt, wt, 1, rs(1,i), 1) j=i 23011 if(.not.(j.le.nxis))goto 23013 v(i,j) = 0.d0 k=1 23014 if(.not.(k.le.nt))goto 23016 v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) 23015 k=k+1 goto 23014 23016 continue if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23012 j=j+1 goto 23011 23013 continue 23009 i=i+1 goto 23008 23010 continue call daxpy (nxis, -1.d0, intrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23019 if(.not.(i.le.nxis))goto 23021 jpvt(i) = 0 23020 i=i+1 goto 23019 23021 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23022 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23022 endif 23023 continue i=rkv+1 23024 if(.not.(i.le.nxis))goto 23026 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23025 i=i+1 goto 23024 23026 continue 23027 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) i=1 23030 if(.not.(i.le.nt))goto 23032 tmp = ddot (nxis, rs(i,1), nt, cdnew, 1) if(-tmp.gt.3.d2)then flag = flag + 1 goto 23032 endif wtnew(i) = dexp (-tmp) * rho(i) if(cntsum.gt.0.d0)then wtnew(i) = wtnew(i) * cnt(i) endif 23031 i=i+1 goto 23030 23032 continue call dscal (nt, 1/dble(nobs), wtnew, 1) lkhdnew = dasum(nt, wtnew, 1) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) i=1 23039 if(.not.(i.le.nt))goto 23041 wt(i) = rho(i) if(cntsum.gt.0.d0)then wt(i) = wt(i) * cnt(i) endif 23040 i=i+1 goto 23039 23041 continue call dscal (nt, 1/dble(nobs), wt, 1) lkhd = dasum (nt, wt, 1) iter = 0 goto 23029 endif if(flag.eq.3)then goto 23029 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23029 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax)).lt.1.d1*mchpr)then goto 23029 endif 23028 goto 23027 23029 continue if(flag.eq.1)then flag = 2 goto 23006 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 i=1 23054 if(.not.(i.le.nt))goto 23056 disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) 23055 i=i+1 goto 23054 23056 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1 *.d0+dabs(lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nt, wtnew, 1, wt, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23007 endif if(disc.lt.prec)then goto 23007 endif if(iter.lt.maxiter)then goto 23006 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) i=1 23065 if(.not.(i.le.nt))goto 23067 wt(i) = rho(i) if(cntsum.gt.0.d0)then wt(i) = wt(i) * cnt(i) endif 23066 i=i+1 goto 23065 23067 continue call dscal (nt, 1/dble(nobs), wt, 1) lkhd = dasum (nt, wt, 1) iter = 0 flag = 2 else info = 2 goto 23007 endif 23006 goto 23005 23007 continue lkhd = dasum (nt, wt, 1) + ddot (nxis, intrs, 1, cd, 1) tmp = 0.d0 disc = 0.d0 i=1 23070 if(.not.(i.le.nt))goto 23072 call dcopy (nxis, rs(i,1), nt, wk, 1) call dprmut (wk, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, wk, 11, infowk) call dset (nxis-rkv, 0.d0, wk(rkv+1), 1) wtnew(i) = wt(i) * ddot (nxis, wk, 1, wk, 1) if(cntsum.gt.0.d0)then wtnew(i) = wtnew(i) / cnt(i) endif tmp = tmp + wt(i) * (dexp (wtnew(i)/(1.d0-wtnew(i))) - 1.d0) if(cntsum.gt.0.d0)then disc = disc + cnt(i) * wtnew(i)/(1.d0-wtnew(i)) else disc = disc + wtnew(i)/(1.d0-wtnew(i)) endif 23071 i=i+1 goto 23070 23072 continue wt(1) = lkhd wt(2) = tmp wt(3) = disc/dble(nobs) return end subroutine hzdaux101 (cd, nxis, q, nxi, rs, nt, rho, mchpr, v, jpv *t) integer nxis, nxi, nt, jpvt(*) double precision cd(*), q(nxi,*), rs(nt,*), rho(*), mchpr, v(nxis, **) integer i, j, k, rkv double precision tmp, ddot i=1 23077 if(.not.(i.le.nt))goto 23079 tmp = ddot (nxis, rs(i,1), nt, cd, 1) rho(i) = dexp (-tmp) * rho(i) 23078 i=i+1 goto 23077 23079 continue i=1 23080 if(.not.(i.le.nxis))goto 23082 j=i 23083 if(.not.(j.le.nxis))goto 23085 v(i,j) = 0.d0 k=1 23086 if(.not.(k.le.nt))goto 23088 v(i,j) = v(i,j) + rho(k) * rs(k,i) * rs(k,j) 23087 k=k+1 goto 23086 23088 continue if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23084 j=j+1 goto 23083 23085 continue 23081 i=i+1 goto 23080 23082 continue i=1 23091 if(.not.(i.le.nxis))goto 23093 jpvt(i) = 0 23092 i=i+1 goto 23091 23093 continue call dchdc (v, nxis, nxis, cd, jpvt, 1, rkv) 23094 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23094 endif 23095 continue i=rkv+1 23096 if(.not.(i.le.nxis))goto 23098 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23097 i=i+1 goto 23096 23098 continue return end gss/src/llrmnewton.f0000644000176200001440000004342714466753327014240 0ustar liggesusersC Output from Public domain Ratfor, version 1.04 subroutine llrmnewton (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qd *rs, nqd, nx, xxwt, qdwt, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, nqd, nx, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nxis,*), cntsum, cnt(*), qdrs *(nqd,nxis,*), xxwt(*), qdwt(*), prec, mchpr, wk(*) integer iwt, iwtsum, imrs, ifit, imu, imuwk, iv, ivwk, icdnew, iwt *new, iwtnewsum, ifitnew, iwk iwt = 1 iwtsum = iwt + nqd*nx imrs = iwtsum + nx ifit = imrs + nxis imu = ifit + nobs imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis iwtnewsum = iwtnew + nqd*nx ifitnew = iwtnewsum + nx iwk = ifitnew + nobs call llrmnewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qdrs, n *qd, nx, xxwt, qdwt, prec, maxiter, mchpr, wk(iwt), wk(iwtsum), wk( *imrs), wk(ifit), wk(imu), wk(imuwk), wk(iv), wk(ivwk), jpvt, wk(ic *dnew), wk(iwtnew), wk(iwtnewsum), wk(ifitnew), wk(iwk), info) return end subroutine llrmnewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, q *drs, nqd, nx, xxwt, qdwt, prec, maxiter, mchpr, wt, wtsum, mrs, fi *t, mu, muwk, v, vwk, jpvt, cdnew, wtnew, wtnewsum, fitnew, wk, inf *o) integer nxis, nxi, nobs, nqd, nx, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nxis,*), cntsum, cnt(*), qdrs *(nqd,nxis,*), xxwt(*), qdwt(*), prec, mchpr, wt(nqd,*), wtsum(*), *mrs(*), fit(*), mu(*), muwk(*), v(nxis,*), vwk(nxis,*), cdnew(*), *wtnew(nqd,*), wtnewsum(*), fitnew(*), wk(*) integer i, j, k, kk, iter, flag, rkv, idamax, infowk double precision norm, tmp, ddot, fitmean, lkhd, mumax, lkhdnew, d *isc, disc0, trc info = 0 i=1 23000 if(.not.(i.le.nxis))goto 23002 mrs(i) = 0.d0 if(.not.(cntsum.gt.0.d0))then j=1 23005 if(.not.(j.le.nobs))goto 23007 mrs(i) = mrs(i) + rs(i,j) 23006 j=j+1 goto 23005 23007 continue mrs(i) = mrs(i) / dble (nobs) else j=1 23008 if(.not.(j.le.nobs))goto 23010 mrs(i) = mrs(i) + rs(i,j) * cnt(j) 23009 j=j+1 goto 23008 23010 continue mrs(i) = mrs(i) / cntsum endif 23001 i=i+1 goto 23000 23002 continue if(.not.(cntsum.gt.0.d0))then trc = 1.d0 / dble (nobs) else trc = 1.d0 / cntsum endif norm = 0.d0 kk=1 23013 if(.not.(kk.le.nx))goto 23015 wtsum(kk) = 0.d0 i=1 23016 if(.not.(i.le.nqd))goto 23018 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) * qdwt(i) wtsum(kk) = wtsum(kk) + wt(i,kk) 23017 i=i+1 goto 23016 23018 continue norm = norm + xxwt(kk) * dlog (wtsum(kk)) 23014 kk=kk+1 goto 23013 23015 continue fitmean = 0.d0 i=1 23019 if(.not.(i.le.nobs))goto 23021 tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if(cntsum.gt.0.d0)then tmp = tmp * cnt(i) endif fitmean = fitmean + tmp 23020 i=i+1 goto 23019 23021 continue call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean * trc + norm iter = 0 flag = 0 23024 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23027 if(.not.(kk.le.nx))goto 23029 i=1 23030 if(.not.(i.le.nxis))goto 23032 muwk(i) = - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) / wtsum(kk) 23031 i=i+1 goto 23030 23032 continue i=1 23033 if(.not.(i.le.nxis))goto 23035 j=i 23036 if(.not.(j.le.nxis))goto 23038 vwk(i,j) = 0.d0 k=1 23039 if(.not.(k.le.nqd))goto 23041 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23040 k=k+1 goto 23039 23041 continue vwk(i,j) = vwk(i,j) / wtsum(kk) - muwk(i) * muwk(j) 23037 j=j+1 goto 23036 23038 continue 23034 i=i+1 goto 23033 23035 continue call daxpy (nxis, xxwt(kk), muwk, 1, mu, 1) call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) 23028 kk=kk+1 goto 23027 23029 continue i=1 23042 if(.not.(i.le.nxi))goto 23044 j=i 23045 if(.not.(j.le.nxi))goto 23047 v(i,j) = v(i,j) + q(i,j) 23046 j=j+1 goto 23045 23047 continue 23043 i=i+1 goto 23042 23044 continue call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23048 if(.not.(i.le.nxis))goto 23050 jpvt(i) = 0 23049 i=i+1 goto 23048 23050 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23051 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23051 endif 23052 continue i=rkv+1 23053 if(.not.(i.le.nxis))goto 23055 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23054 i=i+1 goto 23053 23055 continue 23056 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) norm = 0.d0 kk=1 23059 if(.not.(kk.le.nx))goto 23061 wtnewsum(kk) = 0.d0 i=1 23062 if(.not.(i.le.nqd))goto 23064 wtnew(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1)) * qd *wt(i) wtnewsum(kk) = wtnewsum(kk) + wtnew(i,kk) 23063 i=i+1 goto 23062 23064 continue norm = norm + xxwt(kk) * dlog (wtnewsum(kk)) 23060 kk=kk+1 goto 23059 23061 continue if((flag.eq.0).or.(flag.eq.2))then fitmean = 0.d0 i=1 23067 if(.not.(i.le.nobs))goto 23069 tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23069 endif fitnew(i) = dexp (tmp) if(cntsum.gt.0.d0)then tmp = tmp * cnt(i) endif fitmean = fitmean + tmp 23068 i=i+1 goto 23067 23069 continue call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean * trc + nor *m endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) kk=1 23076 if(.not.(kk.le.nx))goto 23078 call dcopy (nqd, qdwt, 1, wt(1,kk), 1) 23077 kk=kk+1 goto 23076 23078 continue tmp = 0.d0 i=1 23079 if(.not.(i.le.nqd))goto 23081 tmp = tmp + qdwt(i) 23080 i=i+1 goto 23079 23081 continue call dset (nx, tmp, wtsum, 1) call dset (nobs, 1.d0, fit, 1) lkhd = 0.d0 iter = 0 goto 23058 endif if(flag.eq.3)then goto 23058 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23058 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23058 endif 23057 goto 23056 23058 continue if(flag.eq.1)then flag = 2 goto 23025 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23092 if(.not.(kk.le.nx))goto 23094 i=1 23095 if(.not.(i.le.nqd))goto 23097 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23096 i=i+1 goto 23095 23097 continue 23093 kk=kk+1 goto 23092 23094 continue i=1 23098 if(.not.(i.le.nobs))goto 23100 disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) 23099 i=i+1 goto 23098 23100 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1+dabs( *lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nx, wtnewsum, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23026 endif if(disc.lt.prec)then goto 23026 endif if(iter.lt.maxiter)then goto 23025 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) kk=1 23109 if(.not.(kk.le.nx))goto 23111 call dcopy (nqd, qdwt, 1, wt(1,kk), 1) 23110 kk=kk+1 goto 23109 23111 continue tmp = 0.d0 i=1 23112 if(.not.(i.le.nqd))goto 23114 tmp = tmp + qdwt(i) 23113 i=i+1 goto 23112 23114 continue call dset (nx, tmp, wtsum, 1) call dset (nobs, 1.d0, fit, 1) lkhd = 0.d0 iter = 0 flag = 2 else info = 2 goto 23026 endif 23025 goto 23024 23026 continue i=1 23115 if(.not.(i.le.nobs))goto 23117 call daxpy (nxis, -1.d0, mrs, 1, rs(1,i), 1) call dprmut (rs(1,i), nxis, jpvt, 0) if(cntsum.gt.0.d0)then call dscal (nxis, dsqrt(cnt(i)), rs(1,i), 1) endif call dtrsl (v, nxis, nxis, rs(1,i), 11, infowk) 23116 i=i+1 goto 23115 23117 continue trc = ddot (nobs*nxis, rs, 1, rs, 1) if(.not.(cntsum.gt.0.d0))then trc = trc / dble(nobs) / (dble(nobs)-1.d0) lkhd = 0.d0 i=1 23122 if(.not.(i.le.nobs))goto 23124 lkhd = lkhd + dlog (fit(i)) 23123 i=i+1 goto 23122 23124 continue lkhd = lkhd / dble (nobs) else trc = trc / cntsum / (cntsum-1.d0) lkhd = 0.d0 i=1 23125 if(.not.(i.le.nobs))goto 23127 lkhd = lkhd + cnt(i) * dlog (fit(i)) 23126 i=i+1 goto 23125 23127 continue lkhd = lkhd / cntsum endif kk=1 23128 if(.not.(kk.le.nx))goto 23130 lkhd = lkhd - xxwt(kk) * dlog (wtsum(kk)) 23129 kk=kk+1 goto 23128 23130 continue wtsum(1) = lkhd wtsum(2) = trc return end subroutine llrmaux (cd, nxis, q, nxi, qdrs, nqd, nx, xxwt, qdwt, m *chpr, wt, wtsum, mu, v, vwk, jpvt) integer nxis, nxi, nqd, nx, jpvt(*) double precision cd(*), q(nxi,*), qdrs(nqd,nxis,*), xxwt(*), qdwt( **), mchpr, wt(nqd,*), wtsum(*), mu(*), v(nxis,*), vwk(nxis,*) integer i, j, k, kk, rkv double precision ddot kk=1 23131 if(.not.(kk.le.nx))goto 23133 wtsum(kk) = 0.d0 i=1 23134 if(.not.(i.le.nqd))goto 23136 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) * qdwt(i) wtsum(kk) = wtsum(kk) + wt(i,kk) 23135 i=i+1 goto 23134 23136 continue 23132 kk=kk+1 goto 23131 23133 continue call dset (nxis*nxis, 0.d0, v, 1) kk=1 23137 if(.not.(kk.le.nx))goto 23139 i=1 23140 if(.not.(i.le.nxis))goto 23142 mu(i) = ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) / wtsum(kk) 23141 i=i+1 goto 23140 23142 continue i=1 23143 if(.not.(i.le.nxis))goto 23145 j=i 23146 if(.not.(j.le.nxis))goto 23148 vwk(i,j) = 0.d0 k=1 23149 if(.not.(k.le.nqd))goto 23151 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23150 k=k+1 goto 23149 23151 continue vwk(i,j) = vwk(i,j) / wtsum(kk) - mu(i) * mu(j) 23147 j=j+1 goto 23146 23148 continue 23144 i=i+1 goto 23143 23145 continue call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) 23138 kk=kk+1 goto 23137 23139 continue i=1 23152 if(.not.(i.le.nxi))goto 23154 j=i 23155 if(.not.(j.le.nxi))goto 23157 v(i,j) = v(i,j) + q(i,j) 23156 j=j+1 goto 23155 23157 continue 23153 i=i+1 goto 23152 23154 continue i=1 23158 if(.not.(i.le.nxis))goto 23160 jpvt(i) = 0 23159 i=i+1 goto 23158 23160 continue call dchdc (v, nxis, nxis, vwk, jpvt, 1, rkv) 23161 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23161 endif 23162 continue i=rkv+1 23163 if(.not.(i.le.nxis))goto 23165 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23164 i=i+1 goto 23163 23165 continue return end subroutine llrmrkl (cd, nxis, qdrs, nqd, nx, xxwt, qdwt, wt0, offs *et, mchpr, wt, wtnew, mu, muwk, v, vwk, jpvt, cdnew, prec, maxiter *, info) integer nxis, nqd, nx, jpvt(*), maxiter, info double precision cd(*), qdrs(nqd,nxis,*), xxwt(*), qdwt(*), wt0(nq *d,*), offset(nqd,*), mchpr, wt(nqd,*), wtnew(nqd,*), mu(*), muwk(* *), v(nxis,*), vwk(nxis,*), cdnew(*), prec integer i, j, k, kk, iter, flag, idamax, infowk double precision ddot, dasum, rkl, tmp, mumax, rklnew, disc, disc0 kk=1 23166 if(.not.(kk.le.nx))goto 23168 i=1 23169 if(.not.(i.le.nqd))goto 23171 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1) + offset(i, *kk)) * qdwt(i) 23170 i=i+1 goto 23169 23171 continue call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) 23167 kk=kk+1 goto 23166 23168 continue rkl = 0.d0 kk=1 23172 if(.not.(kk.le.nx))goto 23174 tmp = 0.d0 i=1 23175 if(.not.(i.le.nqd))goto 23177 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23176 i=i+1 goto 23175 23177 continue rkl = rkl + xxwt(kk) * tmp 23173 kk=kk+1 goto 23172 23174 continue iter = 0 flag = 0 23178 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23181 if(.not.(kk.le.nx))goto 23183 i=1 23184 if(.not.(i.le.nxis))goto 23186 muwk(i) = ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) 23185 i=i+1 goto 23184 23186 continue i=1 23187 if(.not.(i.le.nxis))goto 23189 j=i 23190 if(.not.(j.le.nxis))goto 23192 vwk(i,j) = 0.d0 k=1 23193 if(.not.(k.le.nqd))goto 23195 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23194 k=k+1 goto 23193 23195 continue vwk(i,j) = vwk(i,j) - muwk(i) * muwk(j) 23191 j=j+1 goto 23190 23192 continue muwk(i) = ddot (nqd, wt0(1,kk), 1, qdrs(1,i,kk), 1) - muwk(i) 23188 i=i+1 goto 23187 23189 continue call daxpy (nxis, xxwt(kk), muwk, 1, mu, 1) call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) 23182 kk=kk+1 goto 23181 23183 continue mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23196 if(.not.(i.le.nxis))goto 23198 jpvt(i) = 0 23197 i=i+1 goto 23196 23198 continue call dmcdc (v, nxis, nxis, cdnew, jpvt, infowk) 23199 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) kk=1 23202 if(.not.(kk.le.nx))goto 23204 i=1 23205 if(.not.(i.le.nqd))goto 23207 wtnew(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1) + off *set(i,kk)) * qdwt(i) 23206 i=i+1 goto 23205 23207 continue call dscal (nqd, 1.d0/dasum(nqd,wtnew(1,kk),1), wtnew(1,kk), 1) 23203 kk=kk+1 goto 23202 23204 continue if((flag.eq.0).or.(flag.eq.2))then rklnew = 0.d0 kk=1 23210 if(.not.(kk.le.nx))goto 23212 tmp = 0.d0 i=1 23213 if(.not.(i.le.nqd))goto 23215 tmp = tmp + dlog(wt0(i,kk)/wtnew(i,kk)) * wt0(i,kk) 23214 i=i+1 goto 23213 23215 continue rklnew = rklnew + xxwt(kk) * tmp 23211 kk=kk+1 goto 23210 23212 continue endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) kk=1 23218 if(.not.(kk.le.nx))goto 23220 i=1 23221 if(.not.(i.le.nqd))goto 23223 wt(i,kk) = dexp (offset(i,kk)) * qdwt(i) 23222 i=i+1 goto 23221 23223 continue call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) 23219 kk=kk+1 goto 23218 23220 continue rkl = 0.d0 kk=1 23224 if(.not.(kk.le.nx))goto 23226 tmp = 0.d0 i=1 23227 if(.not.(i.le.nqd))goto 23229 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23228 i=i+1 goto 23227 23229 continue rkl = rkl + xxwt(kk) * tmp 23225 kk=kk+1 goto 23224 23226 continue iter = 0 goto 23201 endif if(flag.eq.3)then goto 23201 endif if(rklnew-rkl.lt.1.d1*(1.d0+dabs(rkl))*mchpr)then goto 23201 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23201 endif 23200 goto 23199 23201 continue if(flag.eq.1)then flag = 2 goto 23179 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23240 if(.not.(kk.le.nx))goto 23242 i=1 23243 if(.not.(i.le.nqd))goto 23245 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23244 i=i+1 goto 23243 23245 continue 23241 kk=kk+1 goto 23240 23242 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(rkl)))**2) disc0 = dmax1 ((mumax/(1.d0+rkl))**2, dabs(rkl-rklnew)/(1+dabs(rkl *))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) rkl = rklnew if(disc0.lt.prec)then goto 23180 endif if(disc.lt.prec)then goto 23180 endif if(iter.lt.maxiter)then goto 23179 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) kk=1 23254 if(.not.(kk.le.nx))goto 23256 i=1 23257 if(.not.(i.le.nqd))goto 23259 wt(i,kk) = dexp (offset(i,kk)) * qdwt(i) 23258 i=i+1 goto 23257 23259 continue call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) 23255 kk=kk+1 goto 23254 23256 continue rkl = 0.d0 kk=1 23260 if(.not.(kk.le.nx))goto 23262 tmp = 0.d0 i=1 23263 if(.not.(i.le.nqd))goto 23265 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23264 i=i+1 goto 23263 23265 continue rkl = rkl + xxwt(kk) * tmp 23261 kk=kk+1 goto 23260 23262 continue iter = 0 flag = 2 else info = 2 goto 23180 endif 23179 goto 23178 23180 continue rkl = 0.d0 kk=1 23266 if(.not.(kk.le.nx))goto 23268 tmp = 0.d0 i=1 23269 if(.not.(i.le.nqd))goto 23271 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23270 i=i+1 goto 23269 23271 continue rkl = rkl + xxwt(kk) * tmp 23267 kk=kk+1 goto 23266 23268 continue wt(1,1) = rkl return end gss/src/dnewton10.f0000644000176200001440000001622114466750071013637 0ustar liggesusersC Output from Public domain Ratfor, version 1.04 subroutine dnewton10 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, int *rs, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), cntsum, cnt(*), intr *s(*), prec, mchpr, wk(*) integer iwt, imu, iv, icdnew, iwtnew, iwk iwt = 1 imu = iwt + nobs iv = imu + nxis icdnew = iv + nxis*nxis iwtnew = icdnew + nxis iwk = iwtnew + nobs call dnewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, intrs, p *rec, maxiter, mchpr, wk(iwt), wk(imu), wk(iv), jpvt, wk(icdnew), w *k(iwtnew), wk(iwk), info) return end subroutine dnewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, in *trs, prec, maxiter, mchpr, wt, mu, v, jpvt, cdnew, wtnew, wk, info *) integer nxis, nxi, nobs, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), cntsum, cnt(*), intr *s(*), prec, mchpr, wt(*), mu(*), v(nxis,*), cdnew(*), wtnew(*), wk *(*) integer i, j, k, iter, flag, rkv, idamax, infowk double precision wtsum, tmp, ddot, lkhd, mumax, wtsumnew, lkhdnew, * disc, disc0 info = 0 wtsum = 0.d0 i=1 23000 if(.not.(i.le.nobs))goto 23002 tmp = ddot (nxis, rs(i,1), nobs, cd, 1) wt(i) = dexp (-tmp) if(cntsum.gt.0.d0)then wt(i) = wt(i) * cnt(i) endif wtsum = wtsum + wt(i) 23001 i=i+1 goto 23000 23002 continue if(.not.(cntsum.gt.0.d0))then lkhd = wtsum / dble (nobs) else lkhd = wtsum / cntsum endif lkhd = dlog (lkhd) + ddot (nxis, intrs, 1, cd, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = lkhd + ddot (nxi, cd, 1, wk, 1) / 2.d0 iter = 0 flag = 0 23007 continue iter = iter + 1 i=1 23010 if(.not.(i.le.nxis))goto 23012 mu(i) = ddot (nobs, wt, 1, rs(1,i), 1) / wtsum 23011 i=i+1 goto 23010 23012 continue i=1 23013 if(.not.(i.le.nxis))goto 23015 j=i 23016 if(.not.(j.le.nxis))goto 23018 v(i,j) = 0.d0 k=1 23019 if(.not.(k.le.nobs))goto 23021 v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) 23020 k=k+1 goto 23019 23021 continue v(i,j) = v(i,j) / wtsum - mu(i) * mu(j) if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23017 j=j+1 goto 23016 23018 continue 23014 i=i+1 goto 23013 23015 continue call daxpy (nxis, -1.d0, intrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23024 if(.not.(i.le.nxis))goto 23026 jpvt(i) = 0 23025 i=i+1 goto 23024 23026 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23027 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23027 endif 23028 continue i=rkv+1 23029 if(.not.(i.le.nxis))goto 23031 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23030 i=i+1 goto 23029 23031 continue 23032 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) wtsumnew = 0.d0 i=1 23035 if(.not.(i.le.nobs))goto 23037 tmp = ddot (nxis, rs(i,1), nobs, cdnew, 1) if(-tmp.gt.3.d2)then flag = flag + 1 goto 23037 endif wtnew(i) = dexp (-tmp) if(cntsum.gt.0.d0)then wtnew(i) = wtnew(i) * cnt(i) endif wtsumnew = wtsumnew + wtnew(i) 23036 i=i+1 goto 23035 23037 continue if(.not.(cntsum.gt.0.d0))then lkhdnew = wtsumnew / dble (nobs) else lkhdnew = wtsumnew / cntsum endif lkhdnew = dlog (lkhdnew) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) wtsum = 0.d0 i=1 23046 if(.not.(i.le.nobs))goto 23048 if(cntsum.gt.0.d0)then wt(i) = cnt(i) else wt(i) = 1.d0 endif wtsum = wtsum + wt(i) 23047 i=i+1 goto 23046 23048 continue lkhd = 0.d0 iter = 0 goto 23034 endif if(flag.eq.3)then goto 23034 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23034 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax)).lt.1.d1*mchpr)then goto 23034 endif 23033 goto 23032 23034 continue if(flag.eq.1)then flag = 2 goto 23008 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 i=1 23061 if(.not.(i.le.nobs))goto 23063 disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) 23062 i=i+1 goto 23061 23063 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1 *.d0+dabs(lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nobs, wtnew, 1, wt, 1) wtsum = wtsumnew lkhd = lkhdnew if(disc0.lt.prec)then goto 23009 endif if(disc.lt.prec)then goto 23009 endif if(iter.lt.maxiter)then goto 23008 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) wtsum = 0.d0 i=1 23072 if(.not.(i.le.nobs))goto 23074 if(cntsum.gt.0.d0)then wt(i) = cnt(i) else wt(i) = 1.d0 endif wtsum = wtsum + wt(i) 23073 i=i+1 goto 23072 23074 continue lkhd = 0.d0 iter = 0 flag = 2 else info = 2 goto 23009 endif 23008 goto 23007 23009 continue call dscal (nobs, 1.d0/wtsum, wt, 1) i=1 23077 if(.not.(i.le.nxis))goto 23079 j=i 23080 if(.not.(j.le.nxis))goto 23082 v(i,j) = 0.d0 k=1 23083 if(.not.(k.le.nobs))goto 23085 v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) 23084 k=k+1 goto 23083 23085 continue if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23081 j=j+1 goto 23080 23082 continue 23078 i=i+1 goto 23077 23079 continue i=1 23088 if(.not.(i.le.nxis))goto 23090 jpvt(i) = 0 23089 i=i+1 goto 23088 23090 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23091 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23091 endif 23092 continue i=rkv+1 23093 if(.not.(i.le.nxis))goto 23095 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23094 i=i+1 goto 23093 23095 continue i=1 23096 if(.not.(i.le.nobs))goto 23098 call dcopy (nxis, rs(i,1), nobs, wk, 1) call dprmut (wk, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, wk, 11, infowk) call dset (nxis-rkv, 0.d0, wk(rkv+1), 1) wtnew(i) = wt(i) * ddot (nxis, wk, 1, wk, 1) if(cntsum.gt.0.d0)then wtnew(i) = wtnew(i) / cnt(i) endif 23097 i=i+1 goto 23096 23098 continue call dcopy (nobs, wtnew, 1, wt, 1) return end gss/src/ddeev.f0000644000176200001440000002255414466726223013117 0ustar liggesusersC Output from Public domain Ratfor, version 1.04 subroutine ddeev (vmu, nobs, q, ldqr, ldqc, n, nq, u, ldu, uaux, t *, x, theta, nlaht, score, varht, hes, ldh, gra, hwk1, hwk2, gwk1, *gwk2, kwk, ldk, work1, work2, work3, info) character*1 vmu integer nobs, ldqr, ldqc, n, nq, ldu, ldh, ldk, info double precision q(ldqr,ldqc,*), u(ldu,*), uaux(*), t(2,*), x(*), *theta(*), nlaht, score, varht, hes(ldh,*), gra(*), hwk1(nq,*), hwk *2(nq,*), gwk1(*), gwk2(*), kwk(ldk,ldk,*), work1(*), work2(*), wor *k3(*) double precision trc, det, dum, ddot integer i, j, m info = 0 call dset (nq, 0.d0, gra, 1) call dset (nq*nq, 0.d0, hes, 1) if( vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u' )then info = -3 return endif if( nobs .lt. n .or. ldqr .lt. n .or. ldqc .lt. n .or. nq .le. 0 . *or. ldu .lt. n-1 .or. ldh .lt. nq .or. ldk .lt. n )then info = -1 return endif i=2 23004 if(.not.(i.le.nq))goto 23006 if( theta(i) .le. -25.d0 )then goto 23005 endif j=1 23009 if(.not.(j.le.n))goto 23011 call dcopy (n-j+1, q(j,j,i), 1, kwk(j,j,i), 1) call dscal (n-j+1, 10.d0 ** theta(i), kwk(j,j,i), 1) 23010 j=j+1 goto 23009 23011 continue call dqrslm (u, ldu, n-1, n-2, uaux, kwk(2,2,i), n, 0, info, work1 *) call dqrsl (u, ldu, n-1, n-2, uaux, kwk(2,1,i), dum, kwk(2,1,i), d *um, dum, dum, 01000, info) 23005 i=i+1 goto 23004 23006 continue call dcopy (n, t(2,1), 2, kwk(1,1,1), n+1) call dcopy (n-1, t(1,2), 2, kwk(2,1,1), n+1) j=1 23012 if(.not.(j.lt.n-1))goto 23014 call dset (n-j-1, 0.d0, kwk(j+2,j,1), 1) 23013 j=j+1 goto 23012 23014 continue i=2 23015 if(.not.(i.le.nq))goto 23017 if( theta(i) .le. -25.d0 )then goto 23016 endif j=1 23020 if(.not.(j.le.n))goto 23022 call daxpy (n-j+1, -1.d0, kwk(j,j,i), 1, kwk(j,j,1), 1) 23021 j=j+1 goto 23020 23022 continue 23016 i=i+1 goto 23015 23017 continue i=1 23023 if(.not.(i.le.nq))goto 23025 if( theta(i) .le. -25.d0 )then goto 23024 endif j=1 23028 if(.not.(j.lt.n))goto 23030 call dcopy (n-j, kwk(j+1,j,i), 1, kwk(j,j+1,i), n) 23029 j=j+1 goto 23028 23030 continue 23024 i=i+1 goto 23023 23025 continue call dset (n, 10.d0 ** nlaht, work1, 1) call daxpy (n, 1.d0, work1, 1, t(2,1), 2) call dpbfa (t, 2, n, 1, info) if( info .ne. 0 )then info = -2 return endif i=1 23033 if(.not.(i.le.nq))goto 23035 if( theta(i) .le. -25.d0 )then goto 23034 endif j=1 23038 if(.not.(j.le.n))goto 23040 call dpbsl (t, 2, n, 1, kwk(1,j,i)) 23039 j=j+1 goto 23038 23040 continue 23034 i=i+1 goto 23033 23035 continue call dcopy (n, x, 1, work1, 1) call dpbsl (t, 2, n, 1, work1) if( vmu .ne. 'm' )then call dcopy (n, work1, 1, work2, 1) call dscal (n, 2.d0, work2, 1) else call dcopy (n, x, 1, work2, 1) endif i=1 23043 if(.not.(i.le.nq))goto 23045 if( theta(i) .le. -25.d0 )then goto 23044 endif call dgemv ('t', n, n, 1.d0, kwk(1,1,i), n, work2, 1, 0.d0, work3, * 1) gwk1(i) = - ddot (n, work1, 1, work3, 1) 23044 i=i+1 goto 23043 23045 continue i=1 23048 if(.not.(i.le.nq))goto 23050 gwk2(i) = 0.d0 if( theta(i) .le. -25.d0 )then goto 23049 endif j=1 23053 if(.not.(j.le.n))goto 23055 if( vmu .ne. 'm' )then call dcopy (n, kwk(1,j,i), 1, work1, 1) call dpbsl (t, 2, n, 1, work1) gwk2(i) = gwk2(i) - work1(j) else gwk2(i) = gwk2(i) - kwk(j,j,i) endif 23054 j=j+1 goto 23053 23055 continue 23049 i=i+1 goto 23048 23050 continue if( vmu .ne. 'm' )then call dcopy (n, x, 1, work1, 1) call dpbsl (t, 2, n, 1, work1) i=1 23060 if(.not.(i.le.nq))goto 23062 if( theta(i) .le. -25.d0 )then goto 23061 endif call dgemv ('n', n, n, 1.d0, kwk(1,1,i), n, work1, 1, 0.d0, work2, * 1) j=1 23065 if(.not.(j.le.i))goto 23067 if( theta(j) .le. -25.d0 )then goto 23066 endif call dgemv ('n', n, n, 1.d0, kwk(1,1,j), n, work1, 1, 0.d0, work3, * 1) hwk1(i,j) = 2.d0 * ddot (n, work2, 1, work3, 1) call dgemv ('t', n, n, 1.d0, kwk(1,1,j), n, work1, 1, 0.d0, work3, * 1) hwk1(i,j) = hwk1(i,j) + 2.d0 * ddot (n, work2, 1, work3, 1) 23066 j=j+1 goto 23065 23067 continue call dgemv ('t', n, n, 1.d0, kwk(1,1,i), n, work1, 1, 0.d0, work2, * 1) j=1 23070 if(.not.(j.le.i))goto 23072 if( theta(j) .le. -25.d0 )then goto 23071 endif call dgemv ('n', n, n, 1.d0, kwk(1,1,j), n, work1, 1, 0.d0, work3, * 1) hwk1(i,j) = hwk1(i,j) + 2.d0 * ddot (n, work2, 1, work3, 1) 23071 j=j+1 goto 23070 23072 continue 23061 i=i+1 goto 23060 23062 continue else call dcopy (n, x, 1, work1, 1) call dpbsl (t, 2, n, 1, work1) i=1 23075 if(.not.(i.le.nq))goto 23077 if( theta(i) .le. -25.d0 )then goto 23076 endif call dgemv ('n', n, n, 1.d0, kwk(1,1,i), n, work1, 1, 0.d0, work2, * 1) j=1 23080 if(.not.(j.le.i))goto 23082 if( theta(j) .le. -25.d0 )then goto 23081 endif call dgemv ('t', n, n, 1.d0, kwk(1,1,j), n, x, 1, 0.d0, work3, 1) hwk1(i,j) = 2.d0 * ddot (n, work2, 1, work3, 1) 23081 j=j+1 goto 23080 23082 continue 23076 i=i+1 goto 23075 23077 continue endif i=1 23085 if(.not.(i.le.nq))goto 23087 if( theta(i) .le. -25.d0 )then goto 23086 endif hwk1(i,i) = hwk1(i,i) + gwk1(i) 23086 i=i+1 goto 23085 23087 continue i=1 23090 if(.not.(i.le.nq))goto 23092 if( theta(i) .le. -25.d0 )then goto 23091 endif m=1 23095 if(.not.(m.le.i))goto 23097 hwk2(i,m) = 0.d0 if( theta(m) .le. -25.d0 )then goto 23096 endif j=1 23100 if(.not.(j.le.n))goto 23102 if( vmu .ne. 'm' )then call dcopy (n, kwk(1,j,m), 1, work1, 1) call dpbsl (t, 2, n, 1, work1) hwk2(i,m) = hwk2(i,m) + 2.d0 * ddot (n, kwk(j,1,i), n, work1, 1) else hwk2(i,m) = hwk2(i,m) + ddot (n, kwk(j,1,i), n, kwk(1,j,m), 1) endif 23101 j=j+1 goto 23100 23102 continue 23096 m=m+1 goto 23095 23097 continue 23091 i=i+1 goto 23090 23092 continue i=1 23105 if(.not.(i.le.nq))goto 23107 if( theta(i) .le. -25.d0 )then goto 23106 endif hwk2(i,i) = hwk2(i,i) + gwk2(i) 23106 i=i+1 goto 23105 23107 continue if( vmu .eq. 'v' )then trc = dble (nobs) * 10.d0 ** (-nlaht) * varht / score i=1 23112 if(.not.(i.le.nq))goto 23114 if( theta(i) .le. -25.d0 )then goto 23113 endif gra(i) = gwk1(i) / trc / trc - 2.d0 * score * gwk2(i) / trc / dble *(nobs) 23113 i=i+1 goto 23112 23114 continue call dscal (nq, dble (nobs), gra, 1) endif if( vmu .eq. 'u' )then dum = 10.d0 ** nlaht i=1 23119 if(.not.(i.le.nq))goto 23121 if( theta(i) .le. -25.d0 )then goto 23120 endif gra(i) = dum * dum * gwk1(i) - 2.d0 * varht * dum * gwk2(i) 23120 i=i+1 goto 23119 23121 continue call dscal (nq, 1.d0/dble (n), gra, 1) endif if( vmu .eq. 'm' )then det = 10.d0 ** (-nlaht) * varht / score i=1 23126 if(.not.(i.le.nq))goto 23128 if( theta(i) .le. -25.d0 )then goto 23127 endif gra(i) = gwk1(i) / det - dble (nobs) / dble (n) * score * gwk2(i) 23127 i=i+1 goto 23126 23128 continue call dscal (nq, 1.d0 / dble (nobs), gra, 1) endif if( vmu .eq. 'v' )then i=1 23133 if(.not.(i.le.nq))goto 23135 if( theta(i) .le. -25.d0 )then goto 23134 endif j=1 23138 if(.not.(j.le.i))goto 23140 if( theta(j) .le. -25.d0 )then goto 23139 endif hes(i,j) = hwk1(i,j) / trc / trc - 2.d0 * gwk1(i) * gwk2(j) / trc *** 3 - 2.d0 * gwk1(j) * gwk2(i) / trc ** 3 - 2.d0 * score * hwk2(i *,j) / trc / dble (nobs) + 6.d0 * score * gwk2(i) * gwk2(j) / trc / * trc / dble (nobs) 23139 j=j+1 goto 23138 23140 continue call dscal (i, dble (nobs), hes(i,1), ldh) 23134 i=i+1 goto 23133 23135 continue endif if( vmu .eq. 'u' )then i=1 23145 if(.not.(i.le.nq))goto 23147 if( theta(i) .le. -25.d0 )then goto 23146 endif j=1 23150 if(.not.(j.le.i))goto 23152 if( theta(j) .le. -25.d0 )then goto 23151 endif hes(i,j) = dum * dum * hwk1(i,j) - 2.d0 * varht * dum * hwk2(i,j) 23151 j=j+1 goto 23150 23152 continue call dscal (i, 1.d0/dble (n), hes(i,1), ldh) 23146 i=i+1 goto 23145 23147 continue endif if( vmu .eq. 'm' )then i=1 23157 if(.not.(i.le.nq))goto 23159 if( theta(i) .le. -25.d0 )then goto 23158 endif j=1 23162 if(.not.(j.le.i))goto 23164 if( theta(j) .le. -25.d0 )then goto 23163 endif hes(i,j) = hwk1(i,j) / det - gwk1(i) * gwk2(j) / det / dble (n) - *gwk1(j) * gwk2(i) / det / dble (n) - dble (nobs) / dble (n) * scor *e * hwk2(i,j) + dble (nobs) / dble (n) ** 2 * score * gwk2(i) * gw *k2(j) 23163 j=j+1 goto 23162 23164 continue call dscal (i, 1.d0 / dble (nobs), hes(i,1), ldh) 23158 i=i+1 goto 23157 23159 continue endif return end gss/src/dprmut.f0000644000176200001440000000361214443702023013320 0ustar liggesusers subroutine dprmut (x,npar,jpvt,job) integer npar,jpvt(npar),job double precision x(npar) c c Purpose: permute the elements of the array x according to the index c vector jpvt (either forward or backward permutation). c c On Entry: c x(npar) array to be permuted c npar size of x (and jpvt) c jpvt indices of the permutation c job indicator of forward or backward permutation c if job = 0 forward permutation c x(jpvt(i)) moved to x(i) c if job is nonzero backward permutation c x(i) moved to x(jpvt(i)) c On Exit: c x(npar) array with permuted entries c c Written: Yin Ling U. of Maryland, August,1978 c c $Header: dprmut.f,v 2.1 86/04/08 14:05:53 lindstrom Exp $ c integer i,j,k double precision t c if (npar .le. 1) then return endif do 10 j = 1,npar jpvt(j) = -jpvt(j) 10 continue if (job .eq. 0) then c forward permutation do 30 i = 1,npar if (jpvt(i) .gt. 0) then goto 30 endif j = i jpvt(j) = -jpvt(j) k = jpvt(j) c while 20 if (jpvt(k) .lt. 0) then t = x(j) x(j) = x(k) x(k) = t jpvt(k) = -jpvt(k) j = k k = jpvt(k) goto 20 c endwhile endif 30 continue endif if (job .ne. 0 ) then c backward permutation do 50 i = 1,npar if (jpvt(i) .gt. 0) then goto 50 endif jpvt(i) = -jpvt(i) j = jpvt(i) c while 40 if (j .ne. i) then t = x(i) x(i) = x(j) x(j) = t jpvt(j) = -jpvt(j) j = jpvt(j) goto 40 c endwhile endif 50 continue endif return end gss/src/gaussq.f0000644000176200001440000003217714464240717013332 0ustar liggesusersc To get dgamma, "send dgamma from fnlib". c To get d1mach, mail netlib c send d1mach from core c subroutine gaussq(kind, n, alpha, beta, kpts, endpts, b, t, w) c c this set of routines computes the nodes t(j) and weights c w(j) for gaussian-type quadrature rules with pre-assigned c nodes. these are used when one wishes to approximate c c integral (from a to b) f(x) w(x) dx c c n c by sum w f(t ) c j=1 j j c c (note w(x) and w(j) have no connection with each other.) c here w(x) is one of six possible non-negative weight c functions (listed below), and f(x) is the c function to be integrated. gaussian quadrature is particularly c useful on infinite intervals (with appropriate weight c functions), since then other techniques often fail. c c associated with each weight function w(x) is a set of c orthogonal polynomials. the nodes t(j) are just the zeroes c of the proper n-th degree polynomial. c c input parameters (all real numbers are in double precision) c c kind an integer between 1 and 6 giving the type of c quadrature rule: c c kind = 1: legendre quadrature, w(x) = 1 on (-1, 1) c kind = 2: chebyshev quadrature of the first kind c w(x) = 1/sqrt(1 - x*x) on (-1, +1) c kind = 3: chebyshev quadrature of the second kind c w(x) = sqrt(1 - x*x) on (-1, 1) c kind = 4: hermite quadrature, w(x) = exp(-x*x) on c (-infinity, +infinity) c kind = 5: jacobi quadrature, w(x) = (1-x)**alpha * (1+x)** c beta on (-1, 1), alpha, beta .gt. -1. c note: kind=2 and 3 are a special case of this. c kind = 6: generalized laguerre quadrature, w(x) = exp(-x)* c x**alpha on (0, +infinity), alpha .gt. -1 c c n the number of points used for the quadrature rule c alpha real parameter used only for gauss-jacobi and gauss- c laguerre quadrature (otherwise use 0.d0). c beta real parameter used only for gauss-jacobi quadrature-- c (otherwise use 0.d0) c kpts (integer) normally 0, unless the left or right end- c point (or both) of the interval is required to be a c node (this is called gauss-radau or gauss-lobatto c quadrature). then kpts is the number of fixed c endpoints (1 or 2). c endpts real array of length 2. contains the values of c any fixed endpoints, if kpts = 1 or 2. c b real scratch array of length n c c output parameters (both double precision arrays of length n) c c t will contain the desired nodes. c w will contain the desired weights w(j). c c underflow may sometimes occur, but is harmless. c c references c 1. golub, g. h., and welsch, j. h., "calculation of gaussian c quadrature rules," mathematics of computation 23 (april, c 1969), pp. 221-230. c 2. golub, g. h., "some modified matrix eigenvalue problems," c siam review 15 (april, 1973), pp. 318-334 (section 7). c 3. stroud and secrest, gaussian quadrature formulas, prentice- c hall, englewood cliffs, n.j., 1966. c c original version 20 jan 1975 from stanford c modified 21 dec 1983 by eric grosse c imtql2 => gausq2 c hex constant => d1mach (from core library) c compute pi using datan c removed accuracy claims, description of method c added single precision version c integer n, kind, kpts, i, ierr double precision b(n), t(n), w(n), endpts(2), muzero, t1, x gam, solve, dsqrt, alpha, beta c call class (kind, n, alpha, beta, b, t, muzero) c c the matrix of coefficients is assumed to be symmetric. c the array t contains the diagonal elements, the array c b the off-diagonal elements. c make appropriate changes in the lower right 2 by 2 c submatrix. c if (kpts.eq.0) go to 100 if (kpts.eq.2) go to 50 c c if kpts=1, only t(n) must be changed c t(n) = solve(endpts(1), n, t, b)*b(n-1)**2 + endpts(1) go to 100 c c if kpts=2, t(n) and b(n-1) must be recomputed c 50 gam = solve(endpts(1), n, t, b) t1 = ((endpts(1) - endpts(2))/(solve(endpts(2), n, t, b) - gam)) b(n-1) = dsqrt(t1) t(n) = endpts(1) + gam*t1 c c note that the indices of the elements of b run from 1 to n-1 c and thus the value of b(n) is arbitrary. c now compute the eigenvalues of the symmetric tridiagonal c matrix, which has been modified as necessary. c the method used is a ql-type method with origin shifting c 100 w(1) = 1.0d0 do i = 2, n w(i) = 0.0d0 end do c call gausq2 (n, t, b, w, ierr) do i = 1, n w(i) = muzero * w(i) * w(i) end do c return end c c c double precision function solve(shift, n, a, b) c c this procedure performs elimination to solve for the c n-th component of the solution delta to the equation c c (jn - shift*identity) * delta = en, c c where en is the vector of all zeroes except for 1 in c the n-th position. c c the matrix jn is symmetric tridiagonal, with diagonal c elements a(i), off-diagonal elements b(i). this equation c must be solved to obtain the appropriate changes in the lower c 2 by 2 submatrix of coefficients for orthogonal polynomials. c c integer n, nm1, i double precision shift, a(n), b(n), alpha c alpha = a(1) - shift nm1 = n - 1 do i = 2, nm1 alpha = a(i) - shift - b(i-1)**2/alpha end do solve = 1.0d0/alpha return end c c c subroutine class(kind, n, alpha, beta, b, a, muzero) c c this procedure supplies the coefficients a(j), b(j) of the c recurrence relation c c b p (x) = (x - a ) p (x) - b p (x) c j j j j-1 j-1 j-2 c c for the various classical (normalized) orthogonal polynomials, c and the zero-th moment c c muzero = integral w(x) dx c c of the given polynomial's weight function w(x). since the c polynomials are orthonormalized, the tridiagonal matrix is c guaranteed to be symmetric. c c the input parameter alpha is used only for laguerre and c jacobi polynomials, and the parameter beta is used only for c jacobi polynomials. the laguerre and jacobi polynomials c require the gamma function. c integer n, nm1, kind, i double precision a(n), b(n), muzero, alpha, beta double precision abi, a2b2, dgamma, pi, dsqrt, ab c pi = 4.0d0 * datan(1.0d0) nm1 = n - 1 go to (10, 20, 30, 40, 50, 60), kind c c kind = 1: legendre polynomials p(x) c on (-1, +1), w(x) = 1. c 10 muzero = 2.0d0 do i = 1, nm1 a(i) = 0.0d0 abi = i b(i) = abi/dsqrt(4*abi*abi - 1.0d0) end do a(n) = 0.0d0 return c c kind = 2: chebyshev polynomials of the first kind t(x) c on (-1, +1), w(x) = 1 / sqrt(1 - x*x) c 20 muzero = pi do i = 1, nm1 a(i) = 0.0d0 b(i) = 0.5d0 end do b(1) = dsqrt(0.5d0) a(n) = 0.0d0 return c c kind = 3: chebyshev polynomials of the second kind u(x) c on (-1, +1), w(x) = sqrt(1 - x*x) c 30 muzero = pi/2.0d0 do i = 1, nm1 a(i) = 0.0d0 b(i) = 0.5d0 end do a(n) = 0.0d0 return c c kind = 4: hermite polynomials h(x) on (-infinity, c +infinity), w(x) = exp(-x**2) c 40 muzero = dsqrt(pi) do i = 1, nm1 a(i) = 0.0d0 b(i) = dsqrt(i/2.0d0) end do a(n) = 0.0d0 return c c kind = 5: jacobi polynomials p(alpha, beta)(x) on c (-1, +1), w(x) = (1-x)**alpha + (1+x)**beta, alpha and c beta greater than -1 c 50 ab = alpha + beta abi = 2.0d0 + ab muzero = 2.0d0 ** (ab + 1.0d0) * dgamma(alpha + 1.0d0) * dgamma( x beta + 1.0d0) / dgamma(abi) a(1) = (beta - alpha)/abi b(1) = dsqrt(4.0d0*(1.0d0 + alpha)*(1.0d0 + beta)/((abi + 1.0d0)* 1 abi*abi)) a2b2 = beta*beta - alpha*alpha do i = 2, nm1 abi = 2.0d0*i + ab a(i) = a2b2/((abi - 2.0d0)*abi) b(i) = dsqrt (4.0d0*i*(i + alpha)*(i + beta)*(i + ab)/ 1 ((abi*abi - 1)*abi*abi)) end do abi = 2.0d0*n + ab a(n) = a2b2/((abi - 2.0d0)*abi) return c c kind = 6: laguerre polynomials l(alpha)(x) on c (0, +infinity), w(x) = exp(-x) * x**alpha, alpha greater c than -1. c 60 muzero = dgamma(alpha + 1.0d0) do i = 1, nm1 a(i) = 2.0d0*i - 1.0d0 + alpha b(i) = dsqrt(i*(i + alpha)) end do a(n) = 2.0d0*n - 1 + alpha return end c c subroutine gausq2(n, d, e, z, ierr) c c this subroutine is a translation of an algol procedure, c num. math. 12, 377-383(1968) by martin and wilkinson, c as modified in num. math. 15, 450(1970) by dubrulle. c handbook for auto. comp., vol.ii-linear algebra, 241-248(1971). c this is a modified version of the 'eispack' routine imtql2. c c this subroutine finds the eigenvalues and first components of the c eigenvectors of a symmetric tridiagonal matrix by the implicit ql c method. c c on input: c c n is the order of the matrix; c c d contains the diagonal elements of the input matrix; c c e contains the subdiagonal elements of the input matrix c in its first n-1 positions. e(n) is arbitrary; c c z contains the first row of the identity matrix. c c on output: c c d contains the eigenvalues in ascending order. if an c error exit is made, the eigenvalues are correct but c unordered for indices 1, 2, ..., ierr-1; c c e has been destroyed; c c z contains the first components of the orthonormal eigenvectors c of the symmetric tridiagonal matrix. if an error exit is c made, z contains the eigenvectors associated with the stored c eigenvalues; c c ierr is set to c zero for normal return, c j if the j-th eigenvalue has not been c determined after 30 iterations. c c ------------------------------------------------------------------ c integer i, j, k, l, m, n, ii, mml, ierr double precision d(n), e(n), z(n), b, c, f, g, p, r, s, machep double precision dsqrt, dabs, dsign, d1mach c machep=d1mach(4) c ierr = 0 if (n .eq. 1) go to 1001 c e(n) = 0.0d0 do 240 l = 1, n j = 0 c :::::::::: look for small sub-diagonal element :::::::::: 105 do 110 m = l, n if (m .eq. n) go to 120 if (dabs(e(m)) .le. machep * (dabs(d(m)) + dabs(d(m+1)))) x go to 120 110 continue c 120 p = d(l) if (m .eq. l) go to 240 if (j .eq. 30) go to 1000 j = j + 1 c :::::::::: form shift :::::::::: g = (d(l+1) - p) / (2.0d0 * e(l)) r = dsqrt(g*g+1.0d0) g = d(m) - p + e(l) / (g + dsign(r, g)) s = 1.0d0 c = 1.0d0 p = 0.0d0 mml = m - l c c :::::::::: for i=m-1 step -1 until l do -- :::::::::: do 200 ii = 1, mml i = m - ii f = s * e(i) b = c * e(i) if (dabs(f) .lt. dabs(g)) go to 150 c = g / f r = dsqrt(c*c+1.0d0) e(i+1) = f * r s = 1.0d0 / r c = c * s go to 160 150 s = f / g r = dsqrt(s*s+1.0d0) e(i+1) = g * r c = 1.0d0 / r s = s * c 160 g = d(i+1) - p r = (d(i) - g) * s + 2.0d0 * c * b p = s * r d(i+1) = g + p g = c * r - b c :::::::::: form first component of vector :::::::::: f = z(i+1) z(i+1) = s * z(i) + c * f z(i) = c * z(i) - s * f 200 continue c d(l) = d(l) - p e(l) = g e(m) = 0.0d0 go to 105 240 continue c c :::::::::: order eigenvalues and eigenvectors :::::::::: do 300 ii = 2, n i = ii - 1 k = i p = d(i) c do 260 j = ii, n if (d(j) .ge. p) go to 260 k = j p = d(j) 260 continue c if (k .eq. i) go to 300 d(k) = d(i) d(i) = p p = z(i) z(i) = z(k) z(k) = p 300 continue c go to 1001 c :::::::::: set error -- no convergence to an c eigenvalue after 30 iterations :::::::::: 1000 ierr = l 1001 return c :::::::::: last card of gausq2 :::::::::: end c c c double precision function dgamma(x) double precision x dgamma = 1.0d0 return end gss/src/dsidr0.f0000644000176200001440000000220114443702023013163 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine dsidr0 (vmu, s, lds, nobs, nnull, y, q, ldq, tol, job, *limnla, nlaht, score, varht, c, d, qraux, jpvt, wk, info) integer vmu integer lds, nobs, nnull, ldq, job, jpvt(*), info double precision s(lds,*), y(*), q(ldq,*), tol, limnla(2), nlaht, *score(*), varht, c(*), d(*), qraux(*), wk(*) character vmu1 if( vmu .eq. 1 )then vmu1 = 'v' endif if( vmu .eq. 2 )then vmu1 = 'm' endif if( vmu .eq. 3 )then vmu1 = 'u' endif info = 0 if( nnull .lt. 1 .or. nnull .ge. nobs .or. nobs .gt. lds .or. nobs * .gt. ldq )then info = -1 return endif call dstup (s, lds, nobs, nnull, qraux, jpvt, y, q, ldq, nobs, 1, *info, wk) if( info .ne. 0 )then return endif call dcore (vmu1, q, ldq, nobs, nnull, tol, y, job, limnla, nlaht, * score, varht, info, wk, wk(2*nobs+1)) if( info .ne. 0 )then return endif call dcoef (s, lds, nobs, nnull, qraux, jpvt, y, q, ldq, nlaht, c, * d, info, wk) return end gss/src/dcrdr.f0000644000176200001440000000456614443702023013114 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dcrdr (s, lds, nobs, nnull, qraux, jpvt, q, ldq, nlaht, * r, ldr, nr, cr, ldcr, dr, lddr, wk, info) integer lds, nobs, nnull, jpvt(*), ldq, ldr, nr, ldcr, lddr, info double precision s(lds,*), qraux(*), q(ldq,*), nlaht, r(ldr,*), cr *(ldcr,*), dr(lddr,*), wk(2,*) double precision dum, ddot integer i, j, n, n0 info = 0 if( nnull .lt. 1 .or. nnull .ge. nobs .or. nobs .gt. lds .or. nobs * .gt. ldq .or. ldr .lt. nobs .or. nr .lt. 1 .or. ldcr .lt. nobs .o *r. lddr .lt. nnull )then info = -1 return endif n0 = nnull n = nobs - nnull j=1 23002 if(.not.(j.le.nr))goto 23004 call dcopy (nobs, r(1,j), 1, cr(1,j), 1) 23003 j=j+1 goto 23002 23004 continue call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) j=1 23005 if(.not.(j.le.nr))goto 23007 call dqrsl (s, lds, nobs, nnull, qraux, cr(1,j), dum, cr(1,j), dum *, dum, dum, 01000, info) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, cr(n0+2,j), dum, cr(n *0+2,j), dum, dum, dum, 01000, info) 23006 j=j+1 goto 23005 23007 continue call dset (n, 10.d0 ** nlaht, wk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, wk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, wk(1,2), 2) call dpbfa (wk, 2, n, 1, info) if( info .ne. 0 )then info = -2 return endif j=1 23010 if(.not.(j.le.nr))goto 23012 call dpbsl (wk, 2, n, 1, cr(n0+1,j)) 23011 j=j+1 goto 23010 23012 continue call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) j=1 23013 if(.not.(j.le.nr))goto 23015 call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, cr(n0+2,j), cr(n0+2,j *), dum, dum, dum, dum, 10000, info) 23014 j=j+1 goto 23013 23015 continue j=1 23016 if(.not.(j.le.nr))goto 23018 i=1 23019 if(.not.(i.le.n0))goto 23021 dr(i,j) = cr(i,j) - ddot (n, cr(n0+1,j), 1, q(n0+1,i), 1) 23020 i=i+1 goto 23019 23021 continue call dtrsl (s, lds, n0, dr(1,j), 01, info) call dprmut (dr(1,j), n0, jpvt, 1) 23017 j=j+1 goto 23016 23018 continue j=1 23022 if(.not.(j.le.nr))goto 23024 call dset (n0, 0.d0, cr(1,j), 1) call dqrsl (s, lds, nobs, nnull, qraux, cr(1,j), cr(1,j), dum, dum *, dum, dum, 10000, info) 23023 j=j+1 goto 23022 23024 continue return end gss/src/deval.f0000644000176200001440000000246214443702023013102 0ustar liggesusers C Output from Public domain Ratfor, version 1.0 subroutine deval (vmu, q, ldq, n, z, nint, low, upp, nlaht, score, * varht, info, twk, work) character vmu integer ldq, n, nint, info double precision q(ldq,*), z(*), low, upp, nlaht, score(*), varht, * twk(2,*), work(*) double precision tmp, minscr, mlo, varhtwk integer j info = 0 if( upp .lt. low )then mlo = low low = upp upp = mlo endif if( (vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u') .or. nint * .lt. 1 )then info = -3 return endif if( 1 .gt. n .or. n .gt. ldq )then info = -1 return endif j=1 23006 if(.not.(j.le.nint+1))goto 23008 tmp = low + dble (j-1) * ( upp - low ) / dble (nint) call dset (n, 10.d0 ** (tmp), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**tmp call dtrev (vmu, twk, 2, n, z, score(j), varht, info, work) if( info .ne. 0 )then info = -2 return endif if( score(j) .le. minscr .or. j .eq. 1 )then minscr = score(j) nlaht = tmp varhtwk = varht endif 23007 j=j+1 goto 23006 23008 continue varht = varhtwk return end gss/src/reg.f0000644000176200001440000001233314456764370012603 0ustar liggesusersC Output from Public domain Ratfor, version 1.04 subroutine reg (sr, nobs, nnull, q, nxi, y, method, alpha, varht, *score, dc, mchpr, v, mu, jpvt, wk, rkv, info) integer nobs, nnull, nxi, method, jpvt(*), rkv, info double precision sr(nobs,*), q(nxi,*), y(*), alpha, varht, score, *dc(*), mchpr, v(nnull+nxi,*), mu(*), wk(*) double precision ddot, dasum, rss, trc, dum integer i, j, nn, idamax, infowk, idum info = 0 nn = nnull + nxi i=1 23000 if(.not.(i.le.nn))goto 23002 mu(i) = ddot (nobs, sr(1,i), 1, y, 1) j=i 23003 if(.not.(j.le.nn))goto 23005 v(i,j) = ddot (nobs, sr(1,i), 1, sr(1,j), 1) if(i.gt.nnull)then v(i,j) = v(i,j) + q(i-nnull,j-nnull) endif 23004 j=j+1 goto 23003 23005 continue 23001 i=i+1 goto 23000 23002 continue infowk = 0 i=1 23008 if(.not.(i.le.nn))goto 23010 infowk = infowk + jpvt(i) 23009 i=i+1 goto 23008 23010 continue call dchdc (v, nn, nn, wk, jpvt, 1, rkv) j = idamax (rkv-infowk, v(infowk+1,infowk+1), nn+1) 23011 if(v(rkv,rkv).lt.v(infowk+j,infowk+j)*dsqrt(mchpr))then rkv = rkv - 1 goto 23011 endif 23012 continue i=rkv+1 23013 if(.not.(i.le.nn))goto 23015 v(i,i) = v(j,j) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23014 i=i+1 goto 23013 23015 continue call dcopy (nn, mu, 1, dc, 1) call dprmut (dc, nn, jpvt, 0) call dtrsl (v, nn, nn, dc, 11, infowk) call dset (nn-rkv, 0.d0, dc(rkv+1), 1) call dtrsl (v, nn, nn, dc, 01, infowk) call dprmut (dc, nn, jpvt, 1) if(method.eq.4)then return endif i=1 23018 if(.not.(i.le.nobs))goto 23020 wk(i) = y(i) - ddot (nn, sr(i,1), nobs, dc, 1) 23019 i=i+1 goto 23018 23020 continue if(method.eq.5)then wk(nobs+1) = ddot (nobs, wk, 1, wk, 1) / dble (nobs) i=1 23023 if(.not.(i.le.nobs))goto 23025 call dcopy (nn, sr(i,1), nobs, mu, 1) call dprmut (mu, nn, jpvt, 0) call dtrsl (v, nn, nn, mu, 11, infowk) wk(i) = ddot (nn, mu, 1, mu, 1) 23024 i=i+1 goto 23023 23025 continue return endif if(method.eq.3)then rss = ddot (nobs, y, 1, wk, 1) if(nnull.gt.0)then call dqrdc (sr, nobs, nobs, nnull, wk, idum, dum, 0) i=1 23030 if(.not.(i.le.nxi))goto 23032 call dqrsl (sr, nobs, nobs, nnull, wk, sr(1,nnull+i), dum, sr(1,nn *ull+i), dum, dum, dum, 01000, infowk) 23031 i=i+1 goto 23030 23032 continue endif call dcopy (nxi, q, nxi+1, wk, 1) i=1 23033 if(.not.(i.le.nxi))goto 23035 j=i 23036 if(.not.(j.le.nxi))goto 23038 q(i,j) = q(i,j) + ddot (nobs-nnull, sr(nnull+1,nnull+i), 1, sr(nnu *ll+1,nnull+j), 1) 23037 j=j+1 goto 23036 23038 continue 23034 i=i+1 goto 23033 23035 continue i=1 23039 if(.not.(i.le.nxi))goto 23041 j=i 23042 if(.not.(j.le.nxi))goto 23044 sr(i,j) = q(i,j) sr(j,i) = q(i,j) q(i,j) = q(j,i) 23043 j=j+1 goto 23042 23044 continue 23040 i=i+1 goto 23039 23041 continue call dcopy (nxi, wk, 1, q, nxi+1) call dsyev ('n', 'u', nxi, sr, nobs, mu, wk, 3*nxi, info) trc = 0.d0 i=1 23045 if(.not.(i.le.rkv-nnull))goto 23047 trc = trc + dlog (mu(nxi-i+1)) 23046 i=i+1 goto 23045 23047 continue call dsyev ('n', 'u', nxi, q, nxi, mu, wk, 3*nxi, info) i=1 23048 if(.not.(i.le.rkv-nnull))goto 23050 trc = trc - dlog (mu(nxi-i+1)) 23049 i=i+1 goto 23048 23050 continue score = rss / dble (nobs) * dexp (trc/dble(nobs-nnull)) varht = rss / dble (nobs-nnull) else rss = ddot (nobs, wk, 1, wk, 1) / dble (nobs) i=1 23051 if(.not.(i.le.nobs))goto 23053 call dcopy (nn, sr(i,1), nobs, mu, 1) call dprmut (mu, nn, jpvt, 0) call dtrsl (v, nn, nn, mu, 11, infowk) wk(i) = ddot (nn, mu, 1, mu, 1) 23052 i=i+1 goto 23051 23053 continue trc = dasum (nobs, wk, 1) / dble (nobs) if(method.eq.2)then score = rss / (1.d0-alpha*trc)**2 varht = rss / (1.d0-trc) else score = rss + 2.d0 * varht * alpha * trc endif endif wk(1) = rss wk(2) = trc return end subroutine regaux (v, nn, jpvt, rkv, r, nr, sms, nnull, wk) integer nn, jpvt(*), rkv, nr, nnull double precision v(nn,*), r(nn,*), sms(nnull,*), wk(nn,*) double precision ddot integer i, j, infowk i=1 23056 if(.not.(i.le.nr))goto 23058 call dprmut (r(1,i), nn, jpvt, 0) call dtrsl (v, nn, nn, r(1,i), 11, infowk) if(nn-rkv.gt.0)then call dset (nn-rkv, 0.d0, r(rkv+1,i), 1) endif call dtrsl (v, nn, nn, r(1,i), 01, infowk) call dprmut (r(1,i), nn, jpvt, 1) 23057 i=i+1 goto 23056 23058 continue call dset (nn*nnull, 0.d0, wk, 1) call dset (nnull, 1.d0, wk, nn+1) i=1 23061 if(.not.(i.le.nnull))goto 23063 call dtrsl (v, nn, nn, wk(1,i), 11, infowk) 23062 i=i+1 goto 23061 23063 continue i=1 23064 if(.not.(i.le.nnull))goto 23066 j=i 23067 if(.not.(j.le.nnull))goto 23069 sms(i,j) = ddot (nn, wk(1,i), 1, wk(1,j), 1) sms(j,i) = sms(i,j) 23068 j=j+1 goto 23067 23069 continue 23065 i=i+1 goto 23064 23066 continue return end gss/src/cdennewton.f0000644000176200001440000003633514466751631014177 0ustar liggesusersC Output from Public domain Ratfor, version 1.04 subroutine cdennewton (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qd *rs, nqd, nx, xxwt, qdwt, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, nqd, nx, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nxis,*), cntsum, cnt(*), qdrs *(nqd,nxis,*), xxwt(*), qdwt(*), prec, mchpr, wk(*) integer iwt, iwtsum, imrs, ifit, imu, imuwk, iv, ivwk, icdnew, iwt *new, iwtnewsum, ifitnew, iwk iwt = 1 iwtsum = iwt + nqd*nx imrs = iwtsum + nx ifit = imrs + nxis imu = ifit + nobs imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis iwtnewsum = iwtnew + nqd*nx ifitnew = iwtnewsum + nx iwk = ifitnew + nobs call cdennewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qdrs, n *qd, nx, xxwt, qdwt, prec, maxiter, mchpr, wk(iwt), wk(iwtsum), wk( *imrs), wk(ifit), wk(imu), wk(imuwk), wk(iv), wk(ivwk), jpvt, wk(ic *dnew), wk(iwtnew), wk(iwtnewsum), wk(ifitnew), wk(iwk), info) return end subroutine cdennewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, q *drs, nqd, nx, xxwt, qdwt, prec, maxiter, mchpr, wt, wtsum, mrs, fi *t, mu, muwk, v, vwk, jpvt, cdnew, wtnew, wtnewsum, fitnew, wk, inf *o) integer nxis, nxi, nobs, nqd, nx, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nxis,*), cntsum, cnt(*), qdrs *(nqd,nxis,*), xxwt(*), qdwt(*), prec, mchpr, wt(nqd,*), wtsum(*), *mrs(*), fit(*), mu(*), muwk(*), v(nxis,*), vwk(nxis,*), cdnew(*), *wtnew(nqd,*), wtnewsum(*), fitnew(*), wk(*) integer i, j, k, kk, iter, flag, rkv, idamax, infowk double precision norm, tmp, ddot, fitmean, lkhd, mumax, lkhdnew, d *isc, disc0, trc info = 0 i=1 23000 if(.not.(i.le.nxis))goto 23002 mrs(i) = 0.d0 if(.not.(cntsum.gt.0.d0))then j=1 23005 if(.not.(j.le.nobs))goto 23007 mrs(i) = mrs(i) + rs(i,j) 23006 j=j+1 goto 23005 23007 continue mrs(i) = mrs(i) / dble (nobs) else j=1 23008 if(.not.(j.le.nobs))goto 23010 mrs(i) = mrs(i) + rs(i,j) * cnt(j) 23009 j=j+1 goto 23008 23010 continue mrs(i) = mrs(i) / cntsum endif 23001 i=i+1 goto 23000 23002 continue if(.not.(cntsum.gt.0.d0))then trc = 1.d0 / dble (nobs) else trc = 1.d0 / cntsum endif norm = 0.d0 kk=1 23013 if(.not.(kk.le.nx))goto 23015 wtsum(kk) = 0.d0 i=1 23016 if(.not.(i.le.nqd))goto 23018 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) * qdwt(i) wtsum(kk) = wtsum(kk) + wt(i,kk) 23017 i=i+1 goto 23016 23018 continue norm = norm + xxwt(kk) * dlog (wtsum(kk)) 23014 kk=kk+1 goto 23013 23015 continue fitmean = 0.d0 i=1 23019 if(.not.(i.le.nobs))goto 23021 tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if(cntsum.gt.0.d0)then tmp = tmp * cnt(i) endif fitmean = fitmean + tmp 23020 i=i+1 goto 23019 23021 continue call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean * trc + norm iter = 0 flag = 0 23024 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23027 if(.not.(kk.le.nx))goto 23029 i=1 23030 if(.not.(i.le.nxis))goto 23032 muwk(i) = - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) / wtsum(kk) 23031 i=i+1 goto 23030 23032 continue i=1 23033 if(.not.(i.le.nxis))goto 23035 j=i 23036 if(.not.(j.le.nxis))goto 23038 vwk(i,j) = 0.d0 k=1 23039 if(.not.(k.le.nqd))goto 23041 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23040 k=k+1 goto 23039 23041 continue vwk(i,j) = vwk(i,j) / wtsum(kk) - muwk(i) * muwk(j) 23037 j=j+1 goto 23036 23038 continue 23034 i=i+1 goto 23033 23035 continue call daxpy (nxis, xxwt(kk), muwk, 1, mu, 1) call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) 23028 kk=kk+1 goto 23027 23029 continue i=1 23042 if(.not.(i.le.nxi))goto 23044 j=i 23045 if(.not.(j.le.nxi))goto 23047 v(i,j) = v(i,j) + q(i,j) 23046 j=j+1 goto 23045 23047 continue 23043 i=i+1 goto 23042 23044 continue call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23048 if(.not.(i.le.nxis))goto 23050 jpvt(i) = 0 23049 i=i+1 goto 23048 23050 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23051 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23051 endif 23052 continue i=rkv+1 23053 if(.not.(i.le.nxis))goto 23055 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23054 i=i+1 goto 23053 23055 continue 23056 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) norm = 0.d0 kk=1 23059 if(.not.(kk.le.nx))goto 23061 wtnewsum(kk) = 0.d0 i=1 23062 if(.not.(i.le.nqd))goto 23064 wtnew(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1)) * qd *wt(i) wtnewsum(kk) = wtnewsum(kk) + wtnew(i,kk) 23063 i=i+1 goto 23062 23064 continue norm = norm + xxwt(kk) * dlog (wtnewsum(kk)) 23060 kk=kk+1 goto 23059 23061 continue if((flag.eq.0).or.(flag.eq.2))then fitmean = 0.d0 i=1 23067 if(.not.(i.le.nobs))goto 23069 tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23069 endif fitnew(i) = dexp (tmp) if(cntsum.gt.0.d0)then tmp = tmp * cnt(i) endif fitmean = fitmean + tmp 23068 i=i+1 goto 23067 23069 continue call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean * trc + nor *m endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) kk=1 23076 if(.not.(kk.le.nx))goto 23078 call dcopy (nqd, qdwt, 1, wt(1,kk), 1) 23077 kk=kk+1 goto 23076 23078 continue call dset (nx, 1.d0, wtsum, 1) call dset (nobs, 1.d0, fit, 1) lkhd = 0.d0 iter = 0 goto 23058 endif if(flag.eq.3)then goto 23058 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23058 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23058 endif 23057 goto 23056 23058 continue if(flag.eq.1)then flag = 2 goto 23025 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23089 if(.not.(kk.le.nx))goto 23091 i=1 23092 if(.not.(i.le.nqd))goto 23094 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23093 i=i+1 goto 23092 23094 continue 23090 kk=kk+1 goto 23089 23091 continue i=1 23095 if(.not.(i.le.nobs))goto 23097 disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) 23096 i=i+1 goto 23095 23097 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1+dabs( *lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nx, wtnewsum, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23026 endif if(disc.lt.prec)then goto 23026 endif if(iter.lt.maxiter)then goto 23025 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) kk=1 23106 if(.not.(kk.le.nx))goto 23108 call dcopy (nqd, qdwt, 1, wt(1,kk), 1) 23107 kk=kk+1 goto 23106 23108 continue call dset (nx, 1.d0, wtsum, 1) call dset (nobs, 1.d0, fit, 1) lkhd = 0.d0 iter = 0 flag = 2 else info = 2 goto 23026 endif 23025 goto 23024 23026 continue i=1 23109 if(.not.(i.le.nobs))goto 23111 call daxpy (nxis, -1.d0, mrs, 1, rs(1,i), 1) call dprmut (rs(1,i), nxis, jpvt, 0) if(cntsum.gt.0.d0)then call dscal (nxis, dsqrt(cnt(i)), rs(1,i), 1) endif call dtrsl (v, nxis, nxis, rs(1,i), 11, infowk) 23110 i=i+1 goto 23109 23111 continue trc = ddot (nobs*nxis, rs, 1, rs, 1) if(.not.(cntsum.gt.0.d0))then trc = trc / dble(nobs) / (dble(nobs)-1.d0) lkhd = 0.d0 i=1 23116 if(.not.(i.le.nobs))goto 23118 lkhd = lkhd + dlog (fit(i)) 23117 i=i+1 goto 23116 23118 continue lkhd = lkhd / dble (nobs) else trc = trc / cntsum / (cntsum-1.d0) lkhd = 0.d0 i=1 23119 if(.not.(i.le.nobs))goto 23121 lkhd = lkhd + cnt(i) * dlog (fit(i)) 23120 i=i+1 goto 23119 23121 continue lkhd = lkhd / cntsum endif kk=1 23122 if(.not.(kk.le.nx))goto 23124 lkhd = lkhd - xxwt(kk) * dlog (wtsum(kk)) 23123 kk=kk+1 goto 23122 23124 continue wtsum(1) = lkhd wtsum(2) = trc return end subroutine cdenrkl (cd, nxis, qdrs, nqd, nx, xxwt, qdwt, wt0, mchp *r, wt, wtnew, mu, muwk, v, vwk, jpvt, cdnew, prec, maxiter, info) integer nxis, nqd, nx, jpvt(*), maxiter, info double precision cd(*), qdrs(nqd,nxis,*), xxwt(*), qdwt(*), wt0(nq *d,*), mchpr, wt(nqd,*), wtnew(nqd,*), mu(*), muwk(*), v(nxis,*), v *wk(nxis,*), cdnew(*), prec integer i, j, k, kk, iter, flag, idamax, infowk double precision ddot, dasum, rkl, tmp, mumax, rklnew, disc, disc0 kk=1 23125 if(.not.(kk.le.nx))goto 23127 i=1 23128 if(.not.(i.le.nqd))goto 23130 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) * qdwt(i) 23129 i=i+1 goto 23128 23130 continue call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) 23126 kk=kk+1 goto 23125 23127 continue rkl = 0.d0 kk=1 23131 if(.not.(kk.le.nx))goto 23133 tmp = 0.d0 i=1 23134 if(.not.(i.le.nqd))goto 23136 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23135 i=i+1 goto 23134 23136 continue rkl = rkl + xxwt(kk) * tmp 23132 kk=kk+1 goto 23131 23133 continue iter = 0 flag = 0 23137 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23140 if(.not.(kk.le.nx))goto 23142 i=1 23143 if(.not.(i.le.nxis))goto 23145 muwk(i) = ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) 23144 i=i+1 goto 23143 23145 continue i=1 23146 if(.not.(i.le.nxis))goto 23148 j=i 23149 if(.not.(j.le.nxis))goto 23151 vwk(i,j) = 0.d0 k=1 23152 if(.not.(k.le.nqd))goto 23154 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23153 k=k+1 goto 23152 23154 continue vwk(i,j) = vwk(i,j) - muwk(i) * muwk(j) 23150 j=j+1 goto 23149 23151 continue muwk(i) = ddot (nqd, wt0(1,kk), 1, qdrs(1,i,kk), 1) - muwk(i) 23147 i=i+1 goto 23146 23148 continue call daxpy (nxis, xxwt(kk), muwk, 1, mu, 1) call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) 23141 kk=kk+1 goto 23140 23142 continue mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23155 if(.not.(i.le.nxis))goto 23157 jpvt(i) = 0 23156 i=i+1 goto 23155 23157 continue call dmcdc (v, nxis, nxis, cdnew, jpvt, infowk) 23158 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) kk=1 23161 if(.not.(kk.le.nx))goto 23163 i=1 23164 if(.not.(i.le.nqd))goto 23166 wtnew(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1)) * qd *wt(i) 23165 i=i+1 goto 23164 23166 continue call dscal (nqd, 1.d0/dasum(nqd,wtnew(1,kk),1), wtnew(1,kk), 1) 23162 kk=kk+1 goto 23161 23163 continue if((flag.eq.0).or.(flag.eq.2))then rklnew = 0.d0 kk=1 23169 if(.not.(kk.le.nx))goto 23171 tmp = 0.d0 i=1 23172 if(.not.(i.le.nqd))goto 23174 tmp = tmp + dlog(wt0(i,kk)/wtnew(i,kk)) * wt0(i,kk) 23173 i=i+1 goto 23172 23174 continue rklnew = rklnew + xxwt(kk) * tmp 23170 kk=kk+1 goto 23169 23171 continue endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) kk=1 23177 if(.not.(kk.le.nx))goto 23179 call dcopy (nqd, qdwt, 1, wt(1,kk), 1) call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) 23178 kk=kk+1 goto 23177 23179 continue rkl = 0.d0 kk=1 23180 if(.not.(kk.le.nx))goto 23182 tmp = 0.d0 i=1 23183 if(.not.(i.le.nqd))goto 23185 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23184 i=i+1 goto 23183 23185 continue rkl = rkl + xxwt(kk) * tmp 23181 kk=kk+1 goto 23180 23182 continue iter = 0 goto 23160 endif if(flag.eq.3)then goto 23160 endif if(rklnew-rkl.lt.1.d1*(1.d0+dabs(rkl))*mchpr)then goto 23160 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23160 endif 23159 goto 23158 23160 continue if(flag.eq.1)then flag = 2 goto 23138 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23196 if(.not.(kk.le.nx))goto 23198 i=1 23199 if(.not.(i.le.nqd))goto 23201 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23200 i=i+1 goto 23199 23201 continue 23197 kk=kk+1 goto 23196 23198 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(rkl)))**2) disc0 = dmax1 ((mumax/(1.d0+rkl))**2, dabs(rkl-rklnew)/(1+dabs(rkl *))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) rkl = rklnew if(disc0.lt.prec)then goto 23139 endif if(disc.lt.prec)then goto 23139 endif if(iter.lt.maxiter)then goto 23138 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) kk=1 23210 if(.not.(kk.le.nx))goto 23212 call dcopy (nqd, qdwt, 1, wt(1,kk), 1) call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) 23211 kk=kk+1 goto 23210 23212 continue rkl = 0.d0 kk=1 23213 if(.not.(kk.le.nx))goto 23215 tmp = 0.d0 i=1 23216 if(.not.(i.le.nqd))goto 23218 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23217 i=i+1 goto 23216 23218 continue rkl = rkl + xxwt(kk) * tmp 23214 kk=kk+1 goto 23213 23215 continue iter = 0 flag = 2 else info = 2 goto 23139 endif 23138 goto 23137 23139 continue rkl = 0.d0 kk=1 23219 if(.not.(kk.le.nx))goto 23221 tmp = 0.d0 i=1 23222 if(.not.(i.le.nqd))goto 23224 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23223 i=i+1 goto 23222 23224 continue rkl = rkl + xxwt(kk) * tmp 23220 kk=kk+1 goto 23219 23221 continue wt(1,1) = rkl return end gss/src/dstup.f0000644000176200001440000000173514443702023013150 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dstup (s, lds, nobs, nnull, qraux, jpvt, y, q, ldqr, ld *qc, nq, info, work) integer lds, nobs, nnull, jpvt(*), ldqr, ldqc, nq, info double precision s(lds,*), y(*), qraux(*), q(ldqr,ldqc,*), work(*) double precision dum integer j info = 0 if( nobs .lt. 1 .or. nobs .gt. lds .or. nobs .gt. ldqr .or. nobs . *gt. ldqc )then info = -1 return endif j=1 23002 if(.not.(j.le.nnull))goto 23004 jpvt(j) = 0 23003 j=j+1 goto 23002 23004 continue call dqrdc (s, lds, nobs, nnull, qraux, jpvt, work, 1) call dqrsl (s, lds, nobs, nnull, qraux, y, dum, y, work, dum, dum, * 01100, info) if( info .ne. 0 )then return endif j=1 23007 if(.not.(j.le.nq))goto 23009 call dqrslm (s, lds, nobs, nnull, qraux, q(1,1,j), ldqr, 0, info, *work) 23008 j=j+1 goto 23007 23009 continue return end gss/src/dsytr.f0000644000176200001440000000375414443702023013161 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dsytr (x, ldx, n, tol, info, work) integer ldx, n, info double precision x(ldx,*), tol, work(*) double precision nrmtot, nrmxj, alph, toltot, tolcum, toluni, dn, *ddot integer j info = 0 if( ldx .lt. n .or. n .le. 2 )then info = -1 return endif nrmtot = ddot (n, x, ldx+1, x, ldx+1) j=1 23002 if(.not.(j.lt.n ))goto 23004 nrmtot = nrmtot + 2.d0 * ddot (n-j, x(j+1,j), 1, x(j+1,j), 1) 23003 j=j+1 goto 23002 23004 continue toltot = 1.d0 23005 if( 1.d0 + toltot .gt. 1.d0 )then toltot = toltot / 2.d0 goto 23005 endif 23006 continue toltot = 4.d0 * toltot ** 2 if( toltot .lt. tol )then toltot = tol endif toltot = toltot * nrmtot dn = dble (n) toluni = toltot * 6.d0 / dn / ( dn - 1.d0 ) / ( 2.d0 * dn - 1.d0 ) tolcum = 0.d0 j=1 23009 if(.not.(j.lt.n-1 ))goto 23011 nrmtot = nrmtot - x(j,j) * x(j,j) nrmxj = ddot (n-j, x(j+1,j), 1, x(j+1,j), 1) dn = dble (n-j) tolcum = tolcum + toluni * dn * dn if( 2.d0 * nrmxj .le. tolcum )then x(j,j+1) = 0.d0 call dscal (n-j, 0.d0, x(j+1,j), 1) tolcum = tolcum - 2.d0 * nrmxj toltot = toltot - 2.d0 * nrmxj goto 23010 endif if( x(j+1,j) .lt. 0.d0 )then x(j,j+1) = dsqrt (nrmxj) else x(j,j+1) = - dsqrt (nrmxj) endif nrmtot = nrmtot - 2.d0 * nrmxj call dscal (n-j, -1.d0/x(j,j+1), x(j+1,j), 1) x(j+1,j) = 1.d0 + x(j+1,j) alph = 1.d0 / x(j+1,j) call dsymv ('l', n-j, alph, x(j+1,j+1), ldx, x(j+1,j), 1, 0.d0, wo *rk(j+1), 1) alph = - ddot (n-j, work(j+1), 1, x(j+1,j), 1) / 2.d0 / x(j+1,j) call daxpy (n-j, alph, x(j+1,j), 1, work(j+1), 1) call dsyr2 ('l', n-j, -1.d0, x(j+1,j), 1, work(j+1), 1, x(j+1,j+1) *, ldx) 23010 j=j+1 goto 23009 23011 continue x(n-1,n) = x(n,n-1) return end gss/R/0000755000176200001440000000000014467014320011250 5ustar liggesusersgss/R/sscopu.R0000644000176200001440000001240412355360634012716 0ustar liggesusers## Fit copula density model sscopu <- function(x,symmetry=FALSE,alpha=1.4,order=NULL,exclude=NULL, weights=NULL,id.basis=NULL,nbasis=NULL,seed=NULL, qdsz.depth=NULL,prec=1e-7,maxiter=30,skip.iter=dim(x)[2]!=2) { ## Check inputs if ((max(x)>1)|(min(x)<0)) stop("gss error in sscopu: data out of range") if (!(is.matrix(x)&dim(x)[2]>=2)) stop("gss error in sscopu: data must be a matrix of 2 or more columns") ## Generate sub-basis nobs <- dim(x)[1] dm <- dim(x)[2] if (is.null(order)) order <- dm if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=weights) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in sscopu: id.basis out of range") nbasis <- length(id.basis) } ## exclude if (dm==2) exclude <- NULL if (!is.null(exclude)) { symmetry <- FALSE if (is.vector(exclude)) exclude <- matrix(exclude,nrow=1) if (dim(exclude)[2]!=2) stop("gss error in sscopu: exclude must be a matrix of 2 columns") for (i in 1:dim(exclude)[1]) exclude[i,] <- sort(exclude[i,]) exclude <- unique(exclude) if (dim(exclude)[1]==choose(dm,2)) stop("gss error in sscopu: can not exclude all interactions") if (any(exclude[,1]==exclude[,2])) stop("gss error in sscopu: only interactions can be excluded") if (any(exclude>dm)) stop("gss error in sscopu: exclude out of range") } ## Generate numerical quadrature if (is.null(qdsz.depth)) qdsz.depth <- switch(min(dm,6)-1,24,14,12,11,10) quad <- smolyak.quad(dm,qdsz.depth) ## Generate terms order <- min(dm,max(order,2)) term <- mkterm.copu(dm,order,symmetry,exclude) ## Generate s and r s <- qd.s <- r <- qd.r <- NULL nq <- 0 nmesh <- length(quad$wt) for (nu in 1:term$nphi) { s <- cbind(s,term$phi(x,nu,term$env)) qd.s <- cbind(qd.s,term$phi(quad$pt,nu,term$env)) } for (nu in 1:term$nrk) { nq <- nq+1 r <- array(c(r,term$rk(x[id.basis,],x,nu,term$env,out=TRUE)),c(nbasis,nobs,nq)) qd.r <- array(c(qd.r,term$rk(x[id.basis,],quad$pt,nu,term$env,out=TRUE)), c(nbasis,nmesh,nq)) } nnull <- dim(s)[2] ## Check s rank if (qr(s)$rank1) { wt <- wt * (y[,1]+y[,2]) y <- y[,1]/(y[,1]+y[,2]) } p <- sum(wt*y)/sum(wt) if (is.null(offset)) eta <- rep(qlogis(p),length(y)) else { eta <- qlogis(p)-mean(offset) repeat { odds <- exp(eta+offset) p <- odds/(1+odds) u <- p - y w <- p/(1+odds) eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } eta <- eta + offset } eta } ##%%%%%%%%%% Poisson Family %%%%%%%%%% y0.poisson <- function(eta0) { lambda <- exp(eta0) list(lambda=lambda,eta=eta0) } proj0.poisson <- function(y0,eta,wt,offset) { if (is.null(offset)) offset <- rep(0,length(eta)) lambda <- exp(eta) u <- lambda - y0$lambda w <- lambda ywk <- eta-u/w-offset kl <- sum(wt*(y0$lambda*(y0$eta-eta)-y0$lambda+lambda))/sum(wt) wt <- w*wt list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.poisson <- function(eta0,eta1,wt) { lambda0 <- exp(eta0) lambda1 <- exp(eta1) sum(wt*(lambda0*(eta0-eta1)-lambda0+lambda1))/sum(wt) } cfit.poisson <- function(y,wt,offset) { lambda <- sum(wt*y)/sum(wt) if (is.null(offset)) eta <- rep(log(lambda),length(y)) else { eta0 <- log(sum(wt*y)/sum(wt*exp(offset))) eta <- eta0 + offset } eta } ##%%%%%%%%%% Gamma Family %%%%%%%%%% y0.Gamma <- function(eta0) { mu <- exp(eta0) list(mu=mu) } proj0.Gamma <- function(y0,eta,wt,offset) { if (is.null(offset)) offset <- rep(0,length(eta)) mu <- exp(eta) u <- 1-y0$mu/mu ywk <- eta-u-offset kl <- sum(wt*(y0$mu*(-1/y0$mu+1/mu)+log(mu/y0$mu)))/sum(wt) list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.Gamma <- function(eta0,eta1,wt) { mu0 <- exp(eta0) mu1 <- exp(eta1) sum(wt*(mu0*(-1/mu0+1/mu1)+log(mu1/mu0)))/sum(wt) } cfit.Gamma <- function(y,wt,offset) { mu <- sum(wt*y)/sum(wt) if (is.null(offset)) eta <- rep(log(mu),length(y)) else { eta0 <- log(sum(wt*y*exp(-offset))/sum(wt)) eta <- eta0 + offset } eta } ##%%%%%%%%%% Inverse Gaussian Family %%%%%%%%%% y0.inverse.gaussian <- function(eta0) { mu <- exp(eta0) list(mu=mu) } proj0.inverse.gaussian <- function(y0,eta,wt,offset) { if (is.null(offset)) offset <- rep(0,length(eta)) mu <- exp(eta) u <- (1-y0$mu/mu)/mu w <- 1/mu ywk <- eta-u/w-offset kl <- sum(wt*y0$mu/2*(1/mu-1/y0$mu)^2)/sum(wt) wt <- w*wt list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.inverse.gaussian <- function(eta0,eta1,wt) { mu0 <- exp(eta0) mu1 <- exp(eta1) sum(wt*mu0/2*(-1/mu0+1/mu1)^2)/sum(wt) } cfit.inverse.gaussian <- function(y,wt,offset) { mu <- sum(wt*y)/sum(wt) if (is.null(offset)) eta <- rep(log(mu),length(y)) else { eta0 <- log(sum(wt*y*exp(-2*offset))/sum(wt*exp(-offset))) eta <- eta0 + offset } eta } ##%%%%%%%%%% Negative Binomial Family %%%%%%%%%% y0.nbinomial <- function(y,eta0,nu) { if (!is.vector(y)) { nu <- y[,2] y <- y[,1] } mu <- nu*exp(-eta0) list(y=y,nu=nu,mu=mu,eta=eta0) } proj0.nbinomial <- function(y0,eta,wt,offset) { if (is.null(offset)) offset <- rep(0,length(eta)) odds <- exp(eta) p <- odds/(1+odds) q <- 1/(1+odds) u <- y0$mu*p-y0$nu*q w <- (y0$mu+y0$nu)*p*q ywk <- eta-u/w-offset kl <- sum(wt*((y0$nu+y0$mu)*log((1+exp(eta))/(1+exp(y0$eta))) +y0$nu*(y0$eta-eta)))/sum(wt) wt <- w*wt list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.nbinomial <- function(eta0,eta1,wt,nu) { mu0 <- nu*exp(-eta0) sum(wt*((nu+mu0)*log((1+exp(eta1))/(1+exp(eta0)))+nu*(eta0-eta1)))/sum(wt) } cfit.nbinomial <- function(y,wt,offset,nu) { if (!is.vector(y)) { nu <- y[,2] y <- y[,1] } p <- sum(wt*nu)/sum(wt*(y+nu)) if (is.null(offset)) eta <- rep(qlogis(p),length(y)) else { eta <- qlogis(p)-mean(offset) repeat { odds <- exp(eta+offset) p <- odds/(1+odds) q <- 1/(1+odds) u <- y*p-nu*q w <- (y+nu)*p*q eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } eta <- eta + offset } eta } ##%%%%%%%%%% PO Logistic Regression Family %%%%%%%%%% y0.polr <- function(eta0) { G <- c(0,cumsum(eta0$nu)) plogis(outer(eta0$eta,G,"+")) } proj0.polr <- function(y0,eta,wt,offset,nu) { if (is.null(offset)) offset <- rep(0,length(eta)) nnu <- length(nu) y <- y0[,1] for (i in 2:(nnu+1)) y <- cbind(y,y0[,i]-y0[,i-1]) y <- cbind(y,1-y0[,nnu+1]) lkhd <- function(log.nu) { nu <- exp(log.nu) G <- c(0,cumsum(nu)) P <- exp(outer(eta,G,"+")) lkhd <- 0 for (i in 1:(nnu+1)) lkhd <- lkhd+sum(wt*(y[,i]+y[,i+1])*log(1+P[,i]))/sum(wt) for (i in 1:nnu) lkhd <- lkhd-sum(wt*y[,i+1])/sum(wt)*log(exp(nu[i])-1) if (nnu>1) { for (i in 1:(nnu-1)) { tmp <- 0 for (j in (i+1):nnu) tmp <- tmp+sum(wt*y[,j+1])/sum(wt) lkhd <- lkhd-tmp*nu[i] } } lkhd } nu <- exp(nlm(lkhd,log(nu),stepmax=.5)$est) G <- c(0,cumsum(nu)) P <- exp(outer(eta,G,"+")) u <- -1+y[,nnu+2] for (i in 1:(nnu+1)) u <- u+(y[,i]+y[,i+1])*P[,i]/(1+P[,i]) w <- P[,2]/(1+P[,2])*P[,1]/(1+P[,1])^2 w <- w+1/(1+P[,nnu])*P[,nnu+1]/(1+P[,nnu+1])^2 if (nnu>1) { for (i in 2:nnu) w <- w+(P[,i+1]-P[,i-1])/(1+P[,i+1])/(1+P[,i-1])*P[,i]/(1+P[,i])^2 } ywk <- eta-u/w-offset kl <- 0 P <- P/(1+P) for (i in 1:length(eta)) { tmp <- diff(c(0,P[i,],1)) if (min(tmp)<=0) kl <- Inf else kl <- kl+wt[i]*sum(y[i,]*log(y[i,]/tmp)) } kl <- kl/sum(wt) wt <- w*wt list(ywk=ywk,wt=wt,kl=kl,nu=nu,u=wt*u) } kl.polr <- function(eta0,eta1,wt) { P0 <- plogis(outer(eta0$eta,c(0,cumsum(eta0$nu)),"+")) P1 <- plogis(outer(eta1$eta,c(0,cumsum(eta1$nu)),"+")) kl <- 0 for (i in 1:length(eta0$eta)) { tmp0 <- diff(c(0,P0[i,],1)) tmp1 <- diff(c(0,P1[i,],1)) kl <- kl+wt[i]*sum(tmp0*log(tmp0/tmp1)) } kl/sum(wt) } cfit.polr <- function(y,wt,offset) { nobs <- dim(y)[1] P <- apply(y*wt,2,sum) J <- length(P) P <- P/sum(P) P <- qlogis(cumsum(P[-J])) if (!is.null(offset)) { eta0 <- P-mean(offset) eta0[-1] <- log(diff(P)) lkhd <- function(eta) { eta[-1] <- cumsum(c(eta[1],exp(eta[-1]))) tmp <- 0 for (i in 1:nobs) { idx <- (1:J)[y[i,]] if (idx==1) wk <- wk-wt[i]*log(plogis(eta[1]+offset[i])) if (idx==J) wk <- wk-wt[i]*log(1-plogis(eta[J-1]+offset[i])) if ((idx>1)&(idx=3) zz <- y[,3] else zz <- rep(0,length(xx)) lam <- exp(-nu*eta0) list(lam=lam,eta=eta0,int=(xx^nu-zz^nu)) } proj0.weibull <- function(y0,eta,wt,offset,nu) { if (is.null(offset)) offset <- rep(0,length(eta)) u <- nu*(y0$lam-exp(-nu*eta)) w <- nu*nu*exp(-nu*eta) ywk <- eta-u/w-offset kl <- sum(wt*y0$int*(y0$lam*nu*(eta-y0$eta)+exp(-nu*eta)-y0$lam))/sum(wt) u <- y0$int*u w <- y0$int*w wt <- w*wt list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.weibull <- function(eta0,eta1,wt,nu,int) { lam0 <- exp(-nu*eta0) lam1 <- exp(-nu*eta1) sum(wt*int*(lam0*nu*(eta1-eta0)+lam1-lam0))/sum(wt) } cfit.weibull <- function(y,wt,offset,nu) { xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (is.null(offset)) offset <- rep(0,length(xx)) eta <- log(sum(wt*(xx^nu-zz^nu)*exp(-nu*offset))/sum(wt*delta))/nu eta + offset } ##%%%%%%%%%% Lognorm Family %%%%%%%%%% y0.lognorm <- function(y,eta0,nu) { xx <- y[,1] if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) quad <- gauss.quad(50,c(0,1)) list(eta=eta0,xx=xx,zz=zz,q.pt=quad$pt,q.wt=quad$wt) } proj0.lognorm <- function(y0,eta,wt,offset,nu) { if (is.null(offset)) offset <- rep(0,length(eta)) u <- NULL kl <- 0 for (i in 1:length(eta)) { q.pt <- y0$q.pt*(y0$xx[i]-y0$zz[i])+y0$zz[i] q.wt <- y0$q.wt*(y0$xx[i]-y0$zz[i]) z0 <- nu*(log(q.pt)-y0$eta[i]) z1 <- nu*(log(q.pt)-eta[i]) lam0 <- ifelse(z0<7,dnorm(z0)/(1-pnorm(z0)),z0+1/z0) lam1 <- ifelse(z1<7,dnorm(z1)/(1-pnorm(z1)),z1+1/z1) u <- c(u,nu*nu*sum(q.wt*(lam0-lam1)*(lam1-z1)/q.pt)) kl <- kl + nu*sum(q.wt*(lam0*log(lam0/lam1)+lam1-lam0)/q.pt) } xx <- nu*(log(y0$xx)-eta) zz <- nu*(log(y0$zz)-eta) s.xx <- ifelse(xx<7,dnorm(xx)/(1-pnorm(xx)),xx+1/xx) s.zz <- ifelse(zz<7,dnorm(zz)/(1-pnorm(zz)),zz+1/zz) s.xx <- pmax(s.xx,s.zz) w <- (s.xx^2/2-xx*s.xx+xx^2/2+log(s.xx)+log(2*pi)/2) w <- nu^2*(w-ifelse(s.zz==0,0,(s.zz^2/2-zz*s.zz+zz^2/2+log(s.zz)+log(2*pi)/2))) w <- pmax(w,1e-6) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,kl=kl/length(eta),u=wt*u) } kl.lognorm <- function(eta0,eta1,wt,nu,y0) { kl <- 0 for (i in 1:length(eta0)) { q.pt <- y0$q.pt*(y0$xx[i]-y0$zz[i])+y0$zz[i] q.wt <- y0$q.wt*(y0$xx[i]-y0$zz[i]) z0 <- nu*(log(q.pt)-eta0[i]) z1 <- nu*(log(q.pt)-eta1[i]) lam0 <- ifelse(z0<7,dnorm(z0)/(1-pnorm(z0)),z0+1/z0) lam1 <- ifelse(z1<7,dnorm(z1)/(1-pnorm(z1)),z1+1/z1) kl <- kl + nu*sum(q.wt*(lam0*log(lam0/lam1)+lam1-lam0)/q.pt) } kl/length(eta0) } cfit.lognorm <- function(y,wt,offset,nu) { xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (is.null(offset)) offset <- rep(0,length(xx)) lkhd <- function(eta) { eta <- eta + offset xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(-xx.wk^2/2-log(1-pnorm(xx.wk))) +log((1-pnorm(xx.wk))/(1-pnorm(zz.wk))))) } nlm(lkhd,mean(log(xx)-offset),stepmax=1)$est + offset } ##%%%%%%%%%% Loglogis Family %%%%%%%%%% y0.loglogis <- function(y,eta0,nu) { xx <- y[,1] if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) quad <- gauss.quad(50,c(0,1)) list(eta=eta0,xx=xx,zz=zz,q.pt=quad$pt,q.wt=quad$wt) } proj0.loglogis <- function(y0,eta,wt,offset,nu) { if (is.null(offset)) offset <- rep(0,length(eta)) e0 <- exp(-nu*y0$eta) e1 <- exp(-nu*eta) kl <- sum(log((1+y0$xx^nu*e1)*(1+y0$zz^nu*e0)/(1+y0$zz^nu*e1)/(1+y0$xx^nu*e0)) +nu*(eta-y0$eta)*log((1+y0$xx^nu*e0)/(1+y0$zz^nu*e0))) xx <- 1/(1+y0$xx^nu*e1) zz <- 1/(1+y0$zz^nu*e1) u <- -nu*(zz-xx) w <- nu^2/2*(zz^2-xx^2) for (i in 1:length(eta)) { q.pt <- y0$q.pt*(y0$xx[i]-y0$zz[i])+y0$zz[i] q.wt <- y0$q.wt*(y0$xx[i]-y0$zz[i]) u[i] <- u[i]+nu^2*sum(q.wt*q.pt^(nu-1)*e0[i] /(1+q.pt^nu*e0[i])/(1+q.pt^nu*e1[i])) kl <- kl + nu*sum(q.wt*q.pt^(nu-1)*e0[i]/(1+q.pt^nu*e0[i]) *log((1+q.pt^nu*e1[i])/(1+q.pt^nu*e0[i]))) } w <- pmax(w,1e-6) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,kl=kl/length(eta),u=wt*u) } kl.loglogis <- function(eta0,eta1,wt,nu,y0) { e0 <- exp(-nu*eta0) e1 <- exp(-nu*eta1) kl <- sum(log((1+y0$xx^nu*e1)*(1+y0$zz^nu*e0)/(1+y0$zz^nu*e1)/(1+y0$xx^nu*e0)) +nu*(eta1-eta0)*log((1+y0$xx^nu*e0)/(1+y0$zz^nu*e0))) for (i in 1:length(eta0)) { q.pt <- y0$q.pt*(y0$xx[i]-y0$zz[i])+y0$zz[i] q.wt <- y0$q.wt*(y0$xx[i]-y0$zz[i]) kl <- kl + nu*sum(q.wt*q.pt^(nu-1)*e0[i]/(1+q.pt^nu*e0[i]) *log((1+q.pt^nu*e1[i])/(1+q.pt^nu*e0[i]))) } kl/length(eta0) } cfit.loglogis <- function(y,wt,offset,nu) { xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (is.null(offset)) offset <- rep(0,length(xx)) lkhd <- function(eta) { eta <- eta + offset xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(xx.wk-log(1+exp(xx.wk))) -log((1+exp(xx.wk))/(1+exp(zz.wk))))) } nlm(lkhd,mean(log(xx)-offset),stepmax=1)$est + offset } gss/R/ssllrm.R0000644000176200001440000006200614466753374012735 0ustar liggesusers## Fit log-linear regression model ssllrm <- function(formula,response,type=NULL,data=list(),weights, subset,na.action=na.omit,alpha=1, id.basis=NULL,nbasis=NULL,seed=NULL,random=NULL, prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Obtain model frame and model terms mf <- match.call() mf$response <- mf$type <- mf$alpha <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- mf$random <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ynames <- as.character(attr(terms(response),"variables"))[-1] mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) cnt <- model.weights(mf) mf$"(weights)" <- NULL ## Generate sub-basis nobs <- nrow(mf) if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in ssllrm: id.basis out of range") nbasis <- length(id.basis) } ## Check inputs mt <- attr(mf,"terms") vars <- as.character(attr(mt,"variables"))[-1] if(!all(ynames%in%vars)) stop("gss error in ssllrm: response missing in model") for (ylab in ynames) { if (!is.factor(mf[,ylab])) stop("gss error in ssllrm: response not a factor") } xnames <- vars[!(vars%in%ynames)] if (is.null(xnames)) stop("gss error in ssllrm: missing covariate") ## Generate terms term <- mkterm(mf,type) term.labels <- labels(mt) facs <- attr(mt,"factors") ind.wk <- NULL for (lab in term.labels) ind.wk <- c(ind.wk,any(facs[ynames,lab])) term$labels <- term.labels[ind.wk] ## Generate quadrature qd.pt <- data.frame(levels(mf[,ynames[1]]),stringsAsFactors=TRUE) if (is.null(cnt)) wt.wk <- table(mf[,ynames[1]]) else { wt.wk <- NULL for (lvl in levels(mf[,ynames[1]])) wt.wk <- c(wt.wk,sum(cnt[mf[,ynames[1]]==lvl])) } qd.wt <- wt.wk/sum(wt.wk) if (length(ynames)>1) { for (ylab in ynames[-1]) { wk <- expand.grid(levels(mf[,ylab]),1:dim(qd.pt)[1]) qd.pt <- data.frame(qd.pt[wk[,2],],wk[,1],stringsAsFactors=TRUE) if (is.null(cnt)) wt.wk <- table(mf[,ylab]) else { wt.wk <- NULL for (lvl in levels(mf[,ylab])) wt.wk <- c(wt.wk,sum(cnt[mf[,ylab]==lvl])) } qd.wt <- as.vector(outer(wt.wk/sum(wt.wk),qd.wt)) } } colnames(qd.pt) <- ynames nmesh <- dim(qd.pt)[1] x <- mf[,xnames,drop=FALSE] ## obtain unique covariate observations xx <- mf[,xnames,drop=FALSE] if (!is.null(random)) { if (inherits(random,"formula")) random <- mkran(random,data) xx <- cbind(xx,random$z) } xx <- apply(xx,1,function(x)paste(x,collapse="\r")) x.dup.ind <- duplicated(xx) if (!is.null(cnt)) { xx.wt <- NULL for (x.wk in unique(xx)) xx.wt <- c(xx.wt,sum(cnt[xx==x.wk])) } else xx.wt <- as.vector(table(xx)[unique(xx)]) xx.wt <- xx.wt/sum(xx.wt) nx <- length(xx.wt) ## Generate Random if (!is.null(random)) { ## z and qd.z z <- qd.z <- nlvl <- NULL for (ylab in ynames) { y.wk <- mf[,ylab] pt.wk <- qd.pt[,ylab] lvl.wk <- levels(y.wk) nlvl.wk <- length(lvl.wk) nlvl <- c(nlvl,nlvl.wk) z.aux <- diag(1,nlvl.wk-1) z.aux <- rbind(z.aux,rep(-1,nlvl.wk-1)) rownames(z.aux) <- lvl.wk for (i in 1:(nlvl.wk-1)) { z <- cbind(z,z.aux[y.wk,i]*random$z) for (j in 1:nmesh) { qd.z <- cbind(qd.z,z.aux[pt.wk[j],i]*random$z[!x.dup.ind,]) } } } nz <- dim(random$z)[2] nZ <- sum(nlvl-1)*nz qd.z <- aperm(array(qd.z,c(nx,nz,nmesh,nZ/nz)),c(3,1,2,4)) qd.z <- array(qd.z,c(nmesh,nx,nZ)) ## Sigma env <- list(sigma=random$sigma,nzeta=length(random$init),nz=nz,nlvl=nlvl) fun <- function(zeta,env) { ny <- length(env$nlvl) nze <- env$nzeta sigma <- env$sigma dm <- cumsum(env$nlvl-1)*env$nz zz <- matrix(0,dm[ny],dm[ny]) dm <- c(0,dm) for (i in 1:ny) { nlvl.wk <- nlvl[i] wk <- kronecker(diag(1,nlvl.wk-1)+1, sigma$fun(zeta[nze*(i-1)+(1:nze)],sigma$env)) zz[(dm[i]+1):dm[i+1],(dm[i]+1):dm[i+1]] <- wk } zz } Sigma <- list(fun=fun,env=env) ## init init <- rep(random$init,length(nlvl)) ## assemble Random <- list(z=z,qd.z=qd.z,sigma=Sigma,init=init) } else Random <- NULL ## Generate s, r, qd.s, and qd.r s <- r <- qd.s <- NULL qd.r <- as.list(NULL) nu <- nq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] y.list <- ynames[ynames%in%vlist] xy <- mf[,vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- qd.pt[,y.list] if (length(x.list)) xx <- x[!x.dup.ind,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { nu <- nu+1 s.wk <- phi$fun(xy,nu=i,env=phi$env) s <- cbind(s,s.wk) if (is.null(xx)) { qd.s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) qd.wk <- matrix(qd.s.wk,nmesh,nx) } else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- cbind(qd.wk,phi$fun(qd.xy,i,phi$env)) } } qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r.wk <- rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE) r <- array(c(r,r.wk),c(nobs,nbasis,nq)) if (is.null(xx)) { qd.r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,out=TRUE) qd.r[[nq]] <- qd.r.wk } else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- array(c(qd.wk,rk$fun(qd.xy,xy.basis,i,rk$env,TRUE)), c(nmesh,nbasis,j)) } qd.r[[nq]] <- qd.wk } } } } ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rankalpha,(alpha.wk-alpha)*fit$wk[nqd*nx+2],0) cv+adj } cv.s.wk <- function(lambda) cv.scale*cv.s(lambda)+cv.shift cv.m <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 qd.r.wk0 <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + 10^theta[i]*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(10^theta[i]*qd.r[[i]]) } assign("r.wk",r.wk0+0,inherits=TRUE) assign("qd.r.wk",qd.r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk qd.r.wk0 <- qd.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + theta.wk*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(theta.wk*qd.r[[i]]) } } q.wk <- r.wk0[id.basis,] if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { r.wk0 <- cbind(r.wk0,10^ran.scal*random$z) q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(theta[-(1:nq)],random$sigma$env) } qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) if (!is.null(random)) { qd.r.wk0 <- array(c(qd.r.wk0,10^ran.scal*random$qd.z),c(nqd,nx,nxiz)) } qd.r.wk0 <- array(c(qd.r.wk0,qd.s),c(nqd,nx,nn)) qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) fit <- .Fortran("llrmnewton", cd=as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(t(cbind(r.wk0,s))), as.integer(nobs), as.double(cntsum), as.double(cnt), as.double(qd.r.wk0), as.integer(nqd), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*(nqd+1)*nx+2*nobs+nn*(2*nn+5)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in ssllrm: Newton iteration diverges") if (fit$info==2) warning("gss warning in ssllrm: Newton iteration fails to converge") assign("eta",fit$wk[1:(nqd*nx)],inherits=TRUE) assign("cd",fit$cd,inherits=TRUE) cv <- alpha*fit$wk[nqd*nx+2]-fit$wk[nqd*nx+1] alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[nqd*nx+2],0) cv+adj } cv.m.wk <- function(theta) cv.scale*cv.m(theta)+cv.shift ## Initialization theta <- -log10(apply(r[id.basis,,,drop=FALSE],3,function(x)sum(diag(x)))) nq <- length(theta) qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (!nnull) { vv.r <- 0 for (i in 1:nx) { mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- 0 } else { vv.s <- vv.r <- 0 for (i in 1:nx) { mu.s <- apply(qd.s[,i,,drop=FALSE],2,sum)/nqd v.s <- apply(qd.s[,i,,drop=FALSE]^2,2,sum)/nqd v.s <- v.s - mu.s^2 mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.s <- vv.s + xx.wt[i]*v.s vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- log10(sum(vv.s)/nnull/sum(vv.r)*nxi) / 2 } if (!is.null(random)) { vv.z <- 0 for (i in 1:nx) { mu.z <- apply(random$qd.z[,i,,drop=FALSE],2,sum)/nqd v.z <- apply(random$qd.z[,i,,drop=FALSE]^2,2,sum)/nqd v.z <- v.z - mu.z^2 vv.z <- vv.z + xx.wt[i]*v.z } ran.scal <- theta.wk - log10(sum(vv.z)/nz/sum(vv.r)*nxi) / 2 } else ran.scal <- NULL theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,10^ran.scal*random$qd.z),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.basis,] if (!is.null(random)) r.wk <- cbind(r.wk,10^ran.scal*random$z) log.la0 <- log10(sum(vv.r)/sum(diag(q.wk))) + 2*theta.wk ## fixed theta iteration eta <- NULL cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssllrm: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (nq==1) { if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("llrmaux", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(.Machine$double.eps), double(nqd*nx), double(nx), double(nn), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,fit=t(eta),se.aux=se.aux)) } ## theta adjustment qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(cd[1:nxi])%*%r[id.basis,,i]%*%cd[1:nxi]) if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (!nnull) { vv.r <- 0 for (i in 1:nx) { mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- 0 } else { vv.s <- vv.r <- 0 for (i in 1:nx) { mu.s <- apply(qd.s[,i,,drop=FALSE],2,sum)/nqd v.s <- apply(qd.s[,i,,drop=FALSE]^2,2,sum)/nqd v.s <- v.s - mu.s^2 mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.s <- vv.s + xx.wt[i]*v.s vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- log10(sum(vv.s)/nnull/sum(vv.r)*nxi) / 2 } if (!is.null(random)) { vv.z <- 0 for (i in 1:nx) { mu.z <- apply(random$qd.z[,i,,drop=FALSE],2,sum)/nqd v.z <- apply(random$qd.z[,i,,drop=FALSE]^2,2,sum)/nqd v.z <- v.z - mu.z^2 vv.z <- vv.z + xx.wt[i]*v.z } ran.scal <- theta.wk - log10(sum(vv.z)/nz/sum(vv.r)*nxi) / 2 } theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,10^ran.scal*random$qd.z),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.basis,] if (!is.null(random)) r.wk <- cbind(r.wk,10^ran.scal*random$z) log.la0 <- log10(sum(vv.r)/sum(diag(q.wk))) + 2*theta.wk log.th0 <- theta-log.la0 ## fixed theta iteration cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssllrm: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } ## early return if (skip.iter) { if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("llrmaux", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(.Machine$double.eps), double(nqd*nx), double(nx), double(nn), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,fit=t(eta),se.aux=se.aux)) } ## theta search counter <- 0 r.wk <- 0 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } theta.old <- theta if (!is.null(random)) theta <- c(theta,zeta) tmp <- abs(cv.m(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.m.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssllrm: CV iteration fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale if (is.null(random)) { theta <- zz$est zeta <- NULL } else { theta <- zz$est[1:nq] zeta <- zz$est[-(1:nq)] } ## return q.wk <- 0 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { q.wk <- q.wk + 10^theta[i]*r[id.basis,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,10^ran.scal*random$qd.z),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) se.aux <- .Fortran("llrmaux", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(.Machine$double.eps), double(nqd*nx), double(nx), double(nn), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,fit=t(eta),se.aux=se.aux)) } gss/R/print.R0000644000176200001440000002062013626327052012534 0ustar liggesusers## Print function for ssanova objects print.ssanova <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(c(x$terms$labels,x$lab.p)) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") if (x$method=="v") Method <- "GCV " if (x$method=="m") Method <- "GML.\n" if (x$method=="u") Method <- "Mallows CL " if (x$method=="m") cat("Smoothing parameters are selected by",Method) else cat("Smoothing parameters are selected by ",Method,"with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for ssanova0 objects print.ssanova0 <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(c(x$terms$labels,x$lab.p)) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") if (x$method=="v") Method <- "GCV.\n" if (x$method=="m") Method <- "GML.\n" if (x$method=="u") Method <- "Mallows CL.\n" cat("Smoothing parameters are selected by",Method) cat("\n") ## the rest are suppressed invisible() } ## Print function for gssanova objects print.gssanova <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(c(x$terms$labels,x$lab.p)) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for ssden objects print.ssden <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(x$terms$labels) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for sscden objects print.sscden <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(x$terms$labels) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for sshzd objects print.sshzd <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(c(x$terms$labels,x$lab.p)) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for sshzd objects print.sscox <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(c(x$terms$labels,x$lab.p)) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for ssllrm objects print.ssllrm <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(x$terms$labels) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for summary.ssanova objects print.summary.ssanova <- function (x,digits=6,...) { ## call cat("\nCall:\n",deparse(x$call),"\n",sep="") cat("\nEstimate of error standard deviation:",x$sigma,"\n") ## residuals res <- x$res cat("\nResiduals:\n") nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- structure(quantile(res), names = nam) print(rq,digits=digits) cat("Residual sum of squares:",x$rss) cat("\nR square:",x$r.squared) ## selected summaries cat("\n\nPenalty associated with the fit:",x$pen) cat("\n\n") invisible() } ## Print function for summary.gssanova objects print.summary.gssanova <- function (x,digits=6,...) { ## call cat("\nCall:\n",deparse(x$call),"\n",sep="") if (x$family%in%c("Gamma","inverse.gaussian")) { cat("\n(Dispersion parameter for ",x$family, " family estimated to be ",format(x$dispersion),")\n\n",sep="") } else { cat("\n(Dispersion parameter for ",x$family, " family taken to be ",format(x$dispersion),")\n\n",sep="") } ## residuals res <- x$res cat("Working residuals (weighted):\n") nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- structure(quantile(res), names = nam) print(rq,digits=digits) cat("Residual sum of squares:",x$rss,"\n") ## deviance residuals res <- x$dev.res cat("\nDeviance residuals:\n") nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- structure(quantile(res), names = nam) print(rq,digits=digits) cat("Deviance:",x$deviance) cat("\nNull deviance:",x$dev.null) ## selected summaries cat("\n\nPenalty associated with the fit:",x$pen) cat("\n\n") invisible() } ## Print function for summary.gssanova objects print.summary.gssanova0 <- function (x,digits=6,...) { ## call cat("\nCall:\n",deparse(x$call),"\n",sep="") if (x$method=="u") cat("\n(Dispersion parameter for ",x$family, " family taken to be ",format(x$dispersion),")\n\n",sep="") if (x$method=="v") cat("\n(Dispersion parameter for ",x$family, " family estimated to be ",format(x$dispersion),")\n\n",sep="") ## residuals res <- x$res cat("Working residuals (weighted):\n") nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- structure(quantile(res), names = nam) print(rq,digits=digits) cat("Residual sum of squares:",x$rss,"\n") ## deviance residuals res <- x$dev.res cat("\nDeviance residuals:\n") nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- structure(quantile(res), names = nam) print(rq,digits=digits) cat("Deviance:",x$deviance) cat("\nNull deviance:",x$dev.null) ## selected summaries cat("\n\nPenalty associated with the fit:",x$pen) cat("\n\nNumber of performance-oriented iterations:",x$iter) cat("\n\n") invisible() } ## Print function for sscopu objects print.sscopu <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## dimension cat("Dimemsion: ",dim(x$basis)[2],".",sep="") cat("\n\n") order <- x$order if (is.null(order)) order <- 2 cat("Maximum order of interaction: ",order,".",sep="") cat("\n\n") if (x$symmetry) { cat("The fit is symmetric, invariant to variable permutation.") cat("\n\n") } cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for sshzd2d objects print.sshzd2d <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") if (x$symmetry) { cat("The fit is symmetric, with a common marginal hazard and a symmetric copula.") cat("\n\n") } ## terms cat("Terms in hzd1:\n") print.default(c(x$hzd1$terms$labels,x$hzd1$lab.p)) ## terms overview cat("Number of unpenalized and penalized terms:\n") print.default(x$hzd1$desc) cat("\n") cat("Terms in hzd2:\n") print.default(c(x$hzd2$terms$labels,x$hzd2$lab.p)) ## terms overview cat("Number of unpenalized and penalized terms:\n") print.default(x$hzd2$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } gss/R/family.surv.R0000644000176200001440000002161513652457051013666 0ustar liggesusers##%%%%%%%%%% Weibull Family %%%%%%%%%% ## Make pseudo data for Weibull regression mkdata.weibull <- function(y,eta,wt,offset,nu) { if (is.vector(y)) stop("gss error: missing censoring indicator") if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") if (nu[[2]]) { lkhd <- function(log.nu) { nu <- exp(log.nu) -sum(wt*(delta*(nu*(log(xx)-eta)+log.nu) -(xx^nu-zz^nu)*exp(-nu*eta))) } if (is.null(nu[[1]])) nu[[1]] <- 1 nu[[1]] <- exp(nlm(lkhd,log(nu[[1]]),stepmax=.5)$est) } u <- nu[[1]]*(delta-(xx^nu[[1]]-zz^nu[[1]])*exp(-nu[[1]]*eta)) w <- nu[[1]]^2*(xx^nu[[1]]-zz^nu[[1]])*exp(-nu[[1]]*eta) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,nu=nu,u=u*wt) } ## Calculate deviance residuals for Weibull regression dev.resid.weibull <- function(y,eta,wt,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) z <- -delta*nu*(log(xx)-eta)+(xx^nu-zz^nu)*exp(-nu*eta) as.numeric(2*wt*(z+delta*(log(xx^nu)-log(xx^nu-zz^nu)-1))) } ## Calculate null deviance for Weibull regression dev.null.weibull <- function(y,wt,offset,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (is.null(offset)) offset <- rep(0,length(xx)) eta <- log(sum(wt*(xx^nu-zz^nu)*exp(-nu*offset))/sum(wt*delta))/nu eta <- eta + offset z <- -delta*nu*(log(xx)-eta)+(xx^nu-zz^nu)*exp(-nu*eta) sum(2*wt*(z+delta*(log(xx^nu)-log(xx^nu-zz^nu)-1))) } ##%%%%%%%%%% Log Normal Family %%%%%%%%%% ## Make pseudo data for log normal regression mkdata.lognorm <- function(y,eta,wt,offset,nu) { if (is.vector(y)) stop("gss error: missing censoring indicator") if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") if (nu[[2]]) { lkhd <- function(log.nu) { nu <- exp(log.nu) xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(-xx.wk^2/2-log(1-pnorm(xx.wk))+log.nu) +log((1-pnorm(xx.wk))/(1-pnorm(zz.wk))))) } if (is.null(nu[[1]])) nu[[1]] <- 1 nu[[1]] <- exp(nlm(lkhd,log(nu[[1]]),stepmax=.5)$est) } xx <- nu[[1]]*(log(xx)-eta) zz <- nu[[1]]*(log(zz)-eta) s.xx <- ifelse(xx<7,dnorm(xx)/(1-pnorm(xx)),xx+1/xx) s.zz <- ifelse(zz<7,dnorm(zz)/(1-pnorm(zz)),zz+1/zz) s.xx <- pmax(s.xx,s.zz) u <- nu[[1]]*(delta*(s.xx-xx)-(s.xx-s.zz)) w <- (s.xx^2/2-xx*s.xx+xx^2/2+log(s.xx)+log(2*pi)/2) w <- nu[[1]]^2*(w-ifelse(s.zz==0,0,(s.zz^2/2-zz*s.zz+zz^2/2+log(s.zz)+log(2*pi)/2))) w <- ifelse(w<1e-6,1e-6,w) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,nu=nu,u=u*wt) } ## Calculate deviance residuals for log normal regression dev.resid.lognorm <- function(y,eta,wt,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) dev0 <- NULL for (i in 1:length(xx)) { if (!delta[i]|!zz[i]) dev0 <- c(dev0,0) else { fun.wk <- function(eta) { (nu*(log(xx[i])-eta))^2/2+log(1-pnorm(nu*(log(zz[i])-eta))) } dev0 <- c(dev0,nlm(fun.wk,log(xx[i]),stepmax=1)$min) } } xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) s.xx <- log(1-pnorm(xx)) s.zz <- log(1-pnorm(zz)) z <- -delta*(-xx^2/2-s.xx)-s.xx+s.zz as.numeric(2*wt*(z-dev0)) } dev0.resid.lognorm <- function(y,eta,wt,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) s.xx <- ifelse(xx<7,log(1-pnorm(xx)),-xx^2/2-log(xx+.15)-log(2*pi)/2) s.zz <- ifelse(zz<7,log(1-pnorm(zz)),-zz^2/2-log(zz+.15)-log(2*pi)/2) s.xx <- pmin(s.xx,s.zz) z <- -delta*(-xx^2/2-s.xx)-s.xx+s.zz as.numeric(2*wt*z) } ## Calculate null deviance for log normal regression dev.null.lognorm <- function(y,wt,offset,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) dev0 <- NULL for (i in 1:length(xx)) { if (!delta[i]|!zz[i]) dev0 <- c(dev0,0) else { fun.wk <- function(eta) { (nu*(log(xx[i])-eta))^2/2+log(1-pnorm(nu*(log(zz[i])-eta))) } dev0 <- c(dev0,nlm(fun.wk,log(xx[i]),stepmax=1)$min) } } if (is.null(offset)) offset <- rep(0,length(xx)) lkhd <- function(eta) { eta <- eta + offset xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(-xx.wk^2/2-log(1-pnorm(xx.wk))) +log((1-pnorm(xx.wk))/(1-pnorm(zz.wk))))) } eta <- nlm(lkhd,mean(log(xx)-offset),stepmax=1)$est + offset xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) z <- -delta*(-xx^2/2-log(1-pnorm(xx)))-log((1-pnorm(xx))/(1-pnorm(zz))) sum(2*wt*(z-dev0)) } ##%%%%%%%%%% Log Logistic Family %%%%%%%%%% ## Make pseudo data for log logistic regression mkdata.loglogis <- function(y,eta,wt,offset,nu) { if (is.vector(y)) stop("gss error: missing censoring indicator") if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") if (nu[[2]]) { lkhd <- function(log.nu) { nu <- exp(log.nu) xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(xx.wk-log(1+exp(xx.wk))+log.nu) -log((1+exp(xx.wk))/(1+exp(zz.wk))))) } if (is.null(nu[[1]])) nu[[1]] <- 1 nu[[1]] <- exp(nlm(lkhd,log(nu[[1]]),stepmax=.5)$est) } xx <- 1/(1+exp(nu[[1]]*(log(xx)-eta))) zz <- 1/(1+exp(nu[[1]]*(log(zz)-eta))) u <- nu[[1]]*(delta*xx-(zz-xx)) w <- nu[[1]]^2/2*(zz^2-xx^2) w <- pmax(w,1e-6) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,nu=nu,u=u*wt) } ## Calculate deviance residuals for log logistic regression dev.resid.loglogis <- function(y,eta,wt,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) dev0 <- NULL for (i in 1:length(xx)) { if (!delta[i]) dev0 <- c(dev0,0) else { if (!zz[i]) dev0 <- c(dev0,2*log(2)) else { if ((xx[i]/zz[i])^nu<=2) dev0 <- c(dev0,nu*log(xx[i]/zz[i])) else dev0 <- c(dev0,2*log(2)-log(xx[i]^nu/(xx[i]^nu-zz[i]^nu))) } } } xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) z <- -delta*(xx-log(1+exp(xx)))+log((1+exp(xx))/(1+exp(zz))) as.numeric(2*wt*(z-dev0)) } dev0.resid.loglogis <- function(y,eta,wt,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) z <- -delta*(xx-log(1+exp(xx)))+log((1+exp(xx))/(1+exp(zz))) as.numeric(2*wt*z) } ## Calculate null deviance for log logistic regression dev.null.loglogis <- function(y,wt,offset,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) dev0 <- NULL for (i in 1:length(xx)) { if (!delta[i]) dev0 <- c(dev0,0) else { if (!zz[i]) dev0 <- c(dev0,2*log(2)) else { if ((xx[i]/zz[i])^nu<=2) dev0 <- c(dev0,nu*log(xx[i]/zz[i])) else dev0 <- c(dev0,2*log(2)-log(xx[i]^nu/(xx[i]^nu-zz[i]^nu))) } } } if (is.null(offset)) offset <- rep(0,length(xx)) lkhd <- function(eta) { eta <- eta + offset xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(xx.wk-log(1+exp(xx.wk))) -log((1+exp(xx.wk))/(1+exp(zz.wk))))) } eta <- nlm(lkhd,mean(log(xx)-offset))$est + offset xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) z <- -delta*(xx-log(1+exp(xx)))+log((1+exp(xx))/(1+exp(zz))) sum(2*wt*(z-dev0)) } gss/R/sscden.R0000644000176200001440000003734514466751565012710 0ustar liggesusers## Fit log-linear regression model sscden <- function(formula,response,type=NULL,data=list(),weights, subset,na.action=na.omit,alpha=1.4, id.basis=NULL,nbasis=NULL,seed=NULL, ydomain=as.list(NULL),yquad=NULL, prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Obtain model frame and model terms mf <- match.call() mf$response <- mf$type <- mf$alpha <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$ydomain <- mf$yquad <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ynames <- as.character(attr(terms(response),"variables"))[-1] mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) nobs <- nrow(mf) cnt <- model.weights(mf) if (is.null(cnt)) data$cnt <- rep(1,nobs) else { data$cnt <- cnt mf$"(weights)" <- NULL } ## Generate sub-basis nobs <- nrow(mf) if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in sscden: id.basis out of range") nbasis <- length(id.basis) } ## Check inputs mt <- attr(mf,"terms") vars <- as.character(attr(mt,"variables"))[-1] if(!all(ynames%in%vars)) stop("gss error in sscden: response missing in model") xnames <- vars[!(vars%in%ynames)] if (is.null(xnames)) stop("gss error in sscden: missing covariate") ## Set ydomain and type mtrx.y <- FALSE for (ylab in ynames) { y <- mf[[ylab]] if (!is.factor(y)) { if (is.vector(y)) { if (is.null(ydomain[[ylab]])) { mn <- min(y) mx <- max(y) ydomain[[ylab]] <- c(mn,mx)+c(-1,1)*(mx-mn)*.05 } else ydomain[[ylab]] <- c(min(ydomain[[ylab]]),max(ydomain[[ylab]])) if (is.null(type[[ylab]])) type[[ylab]] <- list("cubic",ydomain[[ylab]]) else { if (length(type[[ylab]])==1) type[[ylab]] <- list(type[[ylab]][[1]],ydomain[[ylab]]) } } else mtrx.y <- TRUE } } ydomain <- data.frame(ydomain) ## Generate terms term <- mkterm(mf,type) term.labels <- labels(mt) facs <- attr(mt,"factors") ind.wk <- NULL for (lab in term.labels) ind.wk <- c(ind.wk,any(facs[ynames,lab])) term$labels <- term.labels[ind.wk] ## Generate quadrature if (is.null(yquad)) { if (mtrx.y) stop("gss error in sscden: no default quadrature") yquad <- ssden(response,id.basis=id.basis,data=data,weights=cnt, alpha=2,domain=ydomain)$quad } qd.pt <- yquad$pt qd.wt <- yquad$wt nmesh <- length(qd.wt) ## obtain unique covariate observations x <- xx <- mf[,xnames,drop=FALSE] xx <- apply(xx,1,function(x)paste(x,collapse="\r")) x.dup.ind <- duplicated(xx) if (!is.null(cnt)) xx <- rep(xx,cnt) xx.wt <- as.vector(table(xx)[unique(xx)]) xx.wt <- xx.wt/sum(xx.wt) nx <- length(xx.wt) ## Generate s, r, qd.s, and qd.r s <- r <- qd.s <- NULL qd.r <- as.list(NULL) nu <- nq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] y.list <- ynames[ynames%in%vlist] xy <- mf[,vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- qd.pt[,y.list] if (length(x.list)) xx <- x[!x.dup.ind,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { nu <- nu+1 s.wk <- phi$fun(xy,nu=i,env=phi$env) s <- cbind(s,s.wk) if (is.null(xx)) { qd.s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) qd.wk <- matrix(qd.s.wk,nmesh,nx) } else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- cbind(qd.wk,phi$fun(qd.xy,i,phi$env)) } } qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r.wk <- rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE) r <- array(c(r,r.wk),c(nobs,nbasis,nq)) if (is.null(xx)) { qd.r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,out=TRUE) qd.r[[nq]] <- qd.r.wk } else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- array(c(qd.wk,rk$fun(qd.xy,xy.basis,i,rk$env,TRUE)), c(nmesh,nbasis,j)) } qd.r[[nq]] <- qd.wk } } } } ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rankalpha,(alpha.wk-alpha)*fit$wk[nqd*nx+2],0) cv+adj } cv.m <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 qd.r.wk0 <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + 10^theta[i]*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(10^theta[i]*qd.r[[i]]) } assign("r.wk",r.wk0+0,inherits=TRUE) assign("qd.r.wk",qd.r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk qd.r.wk0 <- qd.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + theta.wk*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(theta.wk*qd.r[[i]]) } } q.wk <- 10^(lambda)*r.wk0[id.basis,] qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) qd.r.wk0 <- array(c(qd.r.wk0,qd.s),c(nqd,nx,nn)) qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) fit <- .Fortran("cdennewton", cd=as.double(cd), as.integer(nn), as.double(q.wk), as.integer(nxi), as.double(t(cbind(r.wk0,s))), as.integer(nobs), as.double(sum(cnt)), as.double(cnt), as.double(qd.r.wk0), as.integer(nqd), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*(nqd+1)*nx+2*nobs+nn*(2*nn+5)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in sscden: Newton iteration diverges") if (fit$info==2) warning("gss warning in sscden: Newton iteration fails to converge") assign("eta",fit$wk[1:(nqd*nx)],inherits=TRUE) assign("cd",fit$cd,inherits=TRUE) cv <- alpha*fit$wk[nqd*nx+2]-fit$wk[nqd*nx+1] alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[nqd*nx+2],0) cv+adj } cv.m.wk <- function(theta) cv.scale*cv.m(theta)+cv.shift ## Initialization theta <- -log10(apply(r[id.basis,,,drop=FALSE],3,function(x)sum(diag(x)))) nq <- length(theta) qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (!nnull) { vv.r <- 0 for (i in 1:nx) { mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- 0 } else { vv.s <- vv.r <- 0 for (i in 1:nx) { mu.s <- apply(qd.s[,i,,drop=FALSE],2,sum)/nqd v.s <- apply(qd.s[,i,,drop=FALSE]^2,2,sum)/nqd v.s <- v.s - mu.s^2 mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.s <- vv.s + xx.wt[i]*v.s vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- log10(sum(vv.s)/nnull/sum(vv.r)*nxi) / 2 } theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.basis,] log.la0 <- log10(sum(vv.r)/sum(diag(q.wk))) + 2*theta.wk ## fixed theta iteration eta <- NULL cd <- rep(0,nn) la <- log.la0 mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } if (nq==1) { jk1 <- cv.s(zz$est) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=zz$est,theta=theta,c=c,d=d,cv=jk1,fit=t(eta))) } ## theta adjustment qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(cd[1:nxi])%*%r[id.basis,,i]%*%cd[1:nxi]) if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (!nnull) { vv.r <- 0 for (i in 1:nx) { mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- 0 } else { vv.s <- vv.r <- 0 for (i in 1:nx) { mu.s <- apply(qd.s[,i,,drop=FALSE],2,sum)/nqd v.s <- apply(qd.s[,i,,drop=FALSE]^2,2,sum)/nqd v.s <- v.s - mu.s^2 mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.s <- vv.s + xx.wt[i]*v.s vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- log10(sum(vv.s)/nnull/sum(vv.r)*nxi) / 2 } theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.basis,] log.la0 <- log10(sum(vv.r)/sum(diag(q.wk))) + 2*theta.wk log.th0 <- theta-log.la0 ## fixed theta iteration cd <- rep(0,nn) la <- log.la0 mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } lambda <- zz$est ## early return if (skip.iter) { jk1 <- cv.s(zz$est) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=zz$est,theta=theta,c=c,d=d,cv=jk1,fit=t(eta))) } ## theta search counter <- 0 r.wk <- 0 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } theta.old <- theta tmp <- abs(cv.m(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.m.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sscden: CV iteration fails to converge") break } } ## return jk1 <- cv.m(zz$est) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=lambda,theta=zz$est,c=c,d=d,cv=jk1,fit=t(eta))) } gss/R/project.ssllrm.R0000644000176200001440000002367213266770211014372 0ustar liggesusers## Calculate Kullback-Leibler projection from ssllrm objects project.ssllrm <- function(object,include,...) { mf <- object$mf term <- object$term id.basis <- object$id.basis qd.pt <- object$qd.pt xx.wt <- object$xx.wt qd.wt <- object$qd.wt ## evaluate full model x <- object$mf[!object$x.dup.ind,object$xnames,drop=FALSE] fit0 <- object$fit ## extract terms in subspace include <- union(object$ynames,include) nmesh <- dim(qd.pt)[1] nbasis <- length(id.basis) nx <- length(xx.wt) qd.s <- NULL qd.r <- as.list(NULL) theta <- d <- q <- NULL nu.wk <- nu <- nq.wk <- nq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- object$xnames[object$xnames%in%vlist] y.list <- object$ynames[object$ynames%in%vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- qd.pt[,y.list] if (length(x.list)) xx <- x[,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { nu.wk <- nu.wk+1 if (is.null(xx)) { if (!any(label==include)) next nu <- nu+1 d <- c(d,object$d[nu.wk]) s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) wk <- matrix(s.wk,nmesh,nx) qd.s <- array(c(qd.s,wk),c(nmesh,nx,nu)) } else { if (!any(label==include)) next nu <- nu+1 d <- c(d,object$d[nu.wk]) wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] wk <- cbind(wk,phi$fun(qd.xy,i,phi$env)) } qd.s <- array(c(qd.s,wk),c(nmesh,nx,nu)) } } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq.wk <- nq.wk+1 if (is.null(xx)) { if (!any(label==include)) next nq <- nq+1 theta <- c(theta,object$theta[nq.wk]) qd.r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,out=TRUE) qd.r[[nq]] <- qd.r.wk q <- cbind(q,rk$fun(xy.basis,xy.basis,i,rk$env,out=FALSE)) } else { if (!any(label==include)) next nq <- nq+1 theta <- c(theta,object$theta[nq.wk]) qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- array(c(qd.wk,rk$fun(qd.xy,xy.basis,i,rk$env,TRUE)), c(nmesh,nbasis,j)) } qd.r[[nq]] <- qd.wk q <- cbind(q,rk$fun(xy.basis,xy.basis,i,rk$env,out=FALSE)) } } } } nnull <- length(d) nxis <- nbasis+nnull ## random effect offset if (!is.null(object$b)) { offset <- apply(object$Random$qd.z,c(1,2),function(x,y)sum(x*y),object$b) } else offset <- matrix(0,nmesh,nx) ## calculate projection rkl <- function(theta1=NULL) { theta.wk <- 1:nq theta.wk[fix] <- theta[fix] if (nq-1) theta.wk[-fix] <- theta1 qd.rs <- array(0,c(nmesh,nbasis,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.rs <- qd.rs + 10^theta[i]*qd.r[[i]] else qd.rs <- qd.rs + as.vector(10^theta[i]*qd.r[[i]]) } qd.rs <- aperm(qd.rs,c(1,3,2)) qd.rs <- array(c(qd.rs,qd.s),c(nmesh,nx,nxis)) qd.rs <- aperm(qd.rs,c(1,3,2)) z <- .Fortran("llrmrkl", cd=as.double(cd), as.integer(nxis), as.double(qd.rs), as.integer(nmesh), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(t(fit0)), as.double(offset), as.double(.Machine$double.eps), wt=double(nmesh*nx), double(nmesh*nx), double(nxis), double(nxis), double(nxis*nxis), double(nxis*nxis), integer(nxis), double(nxis), as.double(1e-6), as.integer(30), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.ssllrm: Newton iteration diverges") if (z$info==2) warning("gss warning in project.ssllrm: Newton iteration fails to converge") assign("cd",z$cd,inherits=TRUE) z$wt[1] } cv.wk <- function(theta) cv.scale*rkl(theta)+cv.shift if (nq) { ## initialization if (!nnull) theta.wk <- 0 else { qd.r.wk <- array(0,c(nmesh,nbasis,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } v.s <- v.r <- 0 for (i in 1:nx) { mu.s <- apply(fit0[i,]*qd.s[,i,,drop=FALSE],2,sum) v.s.wk <- apply(fit0[i,]*qd.s[,i,,drop=FALSE]^2,2,sum)-mu.s^2 mu.r <- apply(fit0[i,]*qd.r.wk[,,i,drop=FALSE],2,sum) v.r.wk <- apply(fit0[i,]*qd.r.wk[,,i,drop=FALSE]^2,2,sum)-mu.r^2 v.s <- v.s + xx.wt[i]*v.s.wk v.r <- v.r + xx.wt[i]*v.r.wk } theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nbasis) / 2 } theta <- theta + theta.wk tmp <- NULL for (i in 1:nq) tmp <- c(tmp,10^theta[i]*sum(q[,i])) fix <- rev(order(tmp))[1] ## projection cd <- c(10^(-theta.wk)*object$c,d) mesh1 <- NULL if (nq-1) { if (object$skip.iter) kl <- rkl(theta[-fix]) else { if (nq-2) { ## scale and shift cv tmp <- abs(rkl(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } kl <- rkl(zz$est) } } else kl <- rkl() } else { z <- .Fortran("llrmrkl", cd=as.double(d), as.integer(nnull), as.double(aperm(qd.s,c(1,3,2))), as.integer(nmesh), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(t(fit0)), as.double(offset), as.double(.Machine$double.eps), wt=double(nmesh*nx), double(nmesh*nx), double(nnull), double(nnull), double(nnull*nnull), double(nnull*nnull), integer(nnull), double(nnull), as.double(1e-6), as.integer(30), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.ssllrm: Newton iteration diverges") if (z$info==2) warning("gss warning in project.ssllrm: Newton iteration fails to converge") kl <- z$wt[1] } ## cfit cfit <- matrix(1,nx,nmesh) if (!is.null(object$b)) { qd.z <- object$Random$qd.z nz <- object$Random$sigma$env$nz id.wk <- 0 } for (ylab in object$ynames) { lvl <- levels(object$mf[,ylab]) if (is.null(object$cnt)) wk <- table(object$mf[,ylab]) else wk <- table(rep(object$mf[,ylab],object$cnt)) if (is.null(object$cnt)) wk <- table(object$mf[,ylab]) else { wk <- NULL for (lvl in levels(object$mf[,ylab])) wk <- c(wk,sum(object$cnt[object$mf[,ylab]==lvl])) } wk <- wk/sum(wk) nlvl <- length(wk) if (is.null(object$b)) { for (j in 1:nlvl) { id <- (1:nmesh)[qd.pt[,ylab]==lvl[j]] cfit[,id] <- cfit[,id]*wk[j] } } else { id <- NULL for (j in 1:nlvl) { id <- c(id,(1:nmesh)[qd.pt[,ylab]==lvl[j]][1]) } offset <- apply(qd.z[id,,id.wk+(1:nz*(nlvl-1)),drop=FALSE],c(1,2), function(x,y)sum(x*y),object$b[id.wk+(1:nz*(nlvl-1))]) id.wk <- id.wk + nz*(nlvl-1) eta <- log(wk[-nlvl]/wk[nlvl]) repeat { p <- exp(c(eta,0)+offset) p <- t(p)/apply(p,2,sum) u <- (apply(p*xx.wt,2,sum)-wk)[-nlvl] w <- 0 for (i in 1:nx) { w <- w + xx.wt[i]*(diag(p[i,])-outer(p[i,],p[i,]))[-nlvl,-nlvl] } eta.new <- eta-solve(w,u) if (max(abs(eta-eta.new)/(1+abs(eta)))<1e-7) break eta <- eta.new } p <- exp(c(eta,0)+offset) p <- t(p)/apply(p,2,sum) for (j in 1:nlvl) { id <- (1:nmesh)[qd.pt[,ylab]==lvl[j]] cfit[,id] <- cfit[,id]*p[,j] } } } ## return kl0 <- 0 for (i in 1:nx) { wk <- sum(log(fit0[i,]/cfit[i,])*fit0[i,]) kl0 <- kl0 + xx.wt[i]*wk } list(ratio=kl/kl0,kl=kl) } gss/R/gssanova.R0000644000176200001440000005602414404122357013224 0ustar liggesusers## Fit gssanova model gssanova <- function(formula,family,type=NULL,data=list(),weights, subset,offset,na.action=na.omit,partial=NULL, alpha=NULL,nu=NULL, id.basis=NULL,nbasis=NULL,seed=NULL,random=NULL, skip.iter=FALSE) { if (!(family%in%c("binomial","poisson","Gamma","inverse.gaussian","nbinomial", "polr","weibull","lognorm","loglogis"))) stop("gss error in gssanova: family not implemented") if (is.null(alpha)) { alpha <- 1.4 if (family%in%c("binomial","nbinomial","inverse.gaussian")) alpha <- 1 } ## Obtain model frame and model terms mf <- match.call() mf$family <- mf$type <- mf$partial <- NULL mf$method <- mf$varht <- mf$nu <- NULL mf$alpha <- mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$random <- mf$skip.iter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) wt <- model.weights(mf) ## Generate sub-basis nobs <- dim(mf)[1] if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=wt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in gssanova: id.basis out of range") nbasis <- length(id.basis) } ## Generate terms term <- mkterm(mf,type) ## Generate random if (!is.null(random)) { if (inherits(random,"formula")) random <- mkran(random,data) } ## Generate s, r, and y s <- r <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nobs)) next } x <- mf[,term[[label]]$vlist] x.basis <- mf[id.basis,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(x,x.basis,nu=i,env=rk$env,out=TRUE)),c(nobs,nbasis,nq)) } } } if (is.null(r)) stop("gss error in gssanova: use glm for models with only unpenalized terms") ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in ssanova: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL if (qr(s)$rank10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssanova: iteration for model selection fails to converge") break } } } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } } ## return jk <- cv(zz$est) if (nu[[2]]) { nu.wk <- exp(zz$est[2]) zz$est <- zz$est[-2] } else nu.wk <- nu[[1]] if (is.null(random)) q.wk <- 10^theta*q else { q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- 10^theta*q q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal-zz$est[1])*random$sigma$fun(zz$est[-1],random$sigma$env) } se.aux <- regaux(sqrt(fit$w)*s,10^theta*sqrt(fit$w)*r,q.wk,zz$est[1],fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL if (nz) b <- 10^(ran.scal)*fit$dc[nnull+nxi+(1:nz)] else b <- NULL c(list(theta=theta,ran.scal=ran.scal,c=c,d=d,b=b,nlambda=zz$est[1], zeta=zz$est[-1],nu=nu.wk),fit[-1],list(se.aux=se.aux)) } ## Fit Multiple Smoothing Parameter Non-Gaussian REGression mspngreg <- function(family,s,r,id.basis,y,wt,offset,alpha,nu,random,skip.iter) { nobs <- nrow(r) nxi <- ncol(r) if (!is.null(s)) { if (is.vector(s)) nnull <- 1 else nnull <- ncol(s) } else nnull <- 0 if (!is.null(random)) nz <-ncol(as.matrix(random$z)) else nz <- 0 nxiz <- nxi + nz nn <- nxiz + nnull nq <- dim(r)[3] ## cv function cv <- function(theta) { if (nu[[2]]) { the.wk <- theta[-(nq+1)] nu.wk <- list(exp(theta[nq+1]),FALSE) } else { the.wk <- theta nu.wk <- nu } ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] } } qq.wk <- r.wk0[id.basis,] if (is.null(random)) q.wk <- 10^nlambda*qq.wk else { r.wk0 <- cbind(r.wk0,10^(ran.scal)*random$z) q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- 10^nlambda*qq.wk q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(the.wk[-(1:nq)],random$sigma$env) } alpha.wk <- max(0,the.wk[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) z <- ngreg(dc,family,cbind(s,r.wk0),q.wk,y,wt,offset,nu.wk,alpha.wk) assign("dc",z$dc,inherits=TRUE) assign("fit",z[c(1:3,5:10)],inherits=TRUE) if (family=="polr") assign("nu",z$nu,inherits=TRUE) z$score } cv.wk <- function(theta) cv.scale*cv(theta)+cv.shift ## initialization theta <- -log10(apply(r[id.basis,,],3,function(x)sum(diag(x)))) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } ## theta adjustment z <- sspngreg(family,s,r.wk,r.wk[id.basis,],y,wt,offset,alpha,nu,random) if (nu[[2]]|(family=="polr")) nu[[1]] <- z$nu theta <- theta + z$theta r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(z$c)%*%r[id.basis,,i]%*%z$c) r.wk <- r.wk + 10^theta[i]*r[,,i] } log.la0 <- log10(sum(r.wk^2)/sum(diag(r.wk[id.basis,]))) log.th0 <- theta-log.la0 ## lambda search z <- sspngreg(family,s,r.wk,r.wk[id.basis,],y,wt,offset,alpha,nu,random) if (nu[[2]]|(family=="polr")) nu[[1]] <- z$nu nlambda <- z$nlambda log.th0 <- log.th0 + z$lambda theta <- theta + z$theta if (!is.null(random)) ran.scal <- z$ran.scal ## early return if (skip.iter) { z$theta <- theta return(z) } ## theta search dc <- rep(0,nn) fit <- NULL theta.old <- theta if (family=="polr") { if (is.null(wt)) P <- apply(y,2,sum) else P <- apply(y*wt,2,sum) P <- P/sum(P) P <- cumsum(P) nnu <- length(P)-2 dc[1] <- qlogis(P[1]) nu[[1]] <- diff(qlogis(P[-(nnu+2)])) } if (nu[[2]]) theta <- c(theta, log(nu[[1]])) if (!is.null(random)) theta <- c(theta,z$zeta) counter <- 0 r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } tmp <- abs(cv(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in gssanova: iteration for model selection fails to converge") break } } ## return jk <- cv(zz$est) if (nu[[2]]) { nu.wk <- exp(zz$est[nq+1]) zz$est <- zz$est[-(nq+1)] } else nu.wk <- nu[[1]] r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^zz$est[i]*r[,,i] } qq.wk <- r.wk[id.basis,] if (is.null(random)) q.wk <- qq.wk else { r.wk <- cbind(r.wk,10^(ran.scal)*random$z) q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- qq.wk q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal-nlambda)*random$sigma$fun(zz$est[-(1:nq)],random$sigma$env) } se.aux <- regaux(sqrt(fit$w)*s,sqrt(fit$w)*r.wk,q.wk,nlambda,fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL if (nz) b <- 10^(ran.scal)*fit$dc[nnull+nxi+(1:nz)] else b <- NULL c(list(theta=zz$est[1:nq],c=c,d=d,b=b,nlambda=nlambda,zeta=zz$est[-(1:nq)],nu=nu.wk), fit[-1],list(se.aux=se.aux)) } ## Non-Gaussian regression with fixed smoothing parameters ngreg <- function(dc,family,sr,q,y,wt,offset,nu,alpha) { nobs <- nrow(sr) nn <- ncol(sr) nxi <- nrow(q) nnull <- nn - nxi ## initialization cc <- dc[nnull+(1:nxi)] eta <- as.vector(sr%*%dc) if (!is.null(offset)) eta <- eta + offset if ((family=="nbinomial")&is.vector(y)) y <- cbind(y,nu[[1]]) dev <- switch(family, binomial=dev.resid.binomial(y,eta,wt), polr=dev.resid.polr(y,eta,wt,nu[[1]]), nbinomial=dev.resid.nbinomial(y,eta,wt), poisson=dev.resid.poisson(y,eta,wt), Gamma=dev.resid.Gamma(y,eta,wt), inverse.gaussian=dev.resid.inverse.gaussian(y,eta,wt), weibull=dev.resid.weibull(y,eta,wt,nu[[1]]), lognorm=dev0.resid.lognorm(y,eta,wt,nu[[1]]), loglogis=dev0.resid.loglogis(y,eta,wt,nu[[1]])) dev <- sum(dev) + t(cc)%*%q%*%cc ## Newton iteration dc.new <- eta.new <- NULL dev.line <- function(x) { assign("dc.new",dc+c(x)*dc.diff,inherits=TRUE) cc <- dc.new[nnull+(1:nxi)] eta.wk <- as.vector(sr%*%dc.new) if (!is.null(offset)) eta.wk <- eta.wk + offset assign("eta.new",eta.wk,inherits=TRUE) dev.wk <- switch(family, binomial=dev.resid.binomial(y,eta.new,wt), nbinomial=dev.resid.nbinomial(y,eta.new,wt), polr=dev.resid.polr(y,eta.new,wt,nu[[1]]), poisson=dev.resid.poisson(y,eta.new,wt), Gamma=dev.resid.Gamma(y,eta.new,wt), inverse.gaussian=dev.resid.inverse.gaussian(y,eta.new,wt), weibull=dev.resid.weibull(y,eta.new,wt,nu[[1]]), lognorm=dev0.resid.lognorm(y,eta.new,wt,nu[[1]]), loglogis=dev0.resid.loglogis(y,eta.new,wt,nu[[1]])) sum(dev.wk) + t(cc)%*%q%*%cc } iter <- 0 flag <- 0 flag2 <- 0 repeat { iter <- iter+1 dat <- switch(family, binomial=mkdata.binomial(y,eta,wt,offset), nbinomial=mkdata.nbinomial(y,eta,wt,offset,nu), polr=mkdata.polr(y,eta,wt,offset,nu[[1]]), poisson=mkdata.poisson(y,eta,wt,offset), Gamma=mkdata.Gamma(y,eta,wt,offset), inverse.gaussian=mkdata.inverse.gaussian(y,eta,wt,offset), weibull=mkdata.weibull(y,eta,wt,offset,nu), lognorm=mkdata.lognorm(y,eta,wt,offset,nu), loglogis=mkdata.loglogis(y,eta,wt,offset,nu)) if (family=="polr") nu[[1]] <- dat$nu ## weighted least squares fit mumax <- 2*max(abs(t(sr)%*%dat$u+c(rep(0,nnull),q%*%dc[nnull+(1:nxi)]))) w <- as.vector(sqrt(dat$wt)) ywk <- w*dat$ywk srwk <- w*sr if (!is.finite(sum(w,ywk,srwk))) { if (flag) stop("gss error in gssanova: Newton iteration diverges") dc <- rep(0,nn) eta <- rep(0,nobs) if (family=="polr") { if (is.null(wt)) P <- apply(y,2,sum) else P <- apply(y*wt,2,sum) P <- P/sum(P) P <- cumsum(P) nnu <- length(P)-2 dc[1] <- qlogis(P[1]) nu[[1]] <- diff(qlogis(P[-(nnu+2)])) eta <- as.vector(sr%*%dc) } if (!is.null(offset)) eta <- eta + offset dev <- switch(family, binomial=dev.resid.binomial(y,eta,wt), nbinomial=dev.resid.nbinomial(y,eta,wt), polr=dev.resid.polr(y,eta,wt,nu[[1]]), poisson=dev.resid.poisson(y,eta,wt), Gamma=dev.resid.Gamma(y,eta,wt), inverse.gaussian=dev.resid.inverse.gaussian(y,eta,wt), weibull=dev.resid.weibull(y,eta,wt,nu[[1]]), lognorm=dev0.resid.lognorm(y,eta,wt,nu[[1]]), loglogis=dev0.resid.loglogis(y,eta,wt,nu[[1]])) dev <- sum(dev) iter <- 0 flag <- 1 next } z <- .Fortran("reg", as.double(srwk), as.integer(nobs), as.integer(nnull), as.double(q), as.integer(nxi), as.double(ywk), as.integer(4), double(1), double(1), double(1), dc=double(nn), as.double(.Machine$double.eps), double(nn*nn), double(nn), as.integer(c(rep(1,nnull),rep(0,nxi))), double(max(nobs,nn)), integer(1), integer(1), PACKAGE="gss")["dc"] dc.diff <- z$dc-dc repeat { dev.new <- dev.line(1) if (!is.finite(dev.new)) { dc.diff <- dc.diff/2 next } if (!flag2) { if (dev.new-dev<1e-7*(1+abs(dev))) break } zz <- nlm0(dev.line,c(0,1),1e-3) dev.new <- dev.line(zz$est) break } disc0 <- max((mumax/(1+eta))^2,abs(eta.new-eta)/(1+eta)) disc <- sum(dat$wt*((eta-eta.new)/(1+abs(eta)))^2)/sum(dat$wt) if (!is.finite(disc)) { if (flag) stop("gss error in gssanova: Newton iteration diverges") dc <- rep(0,nn) eta <- rep(0,nobs) if (family=="polr") { if (is.null(wt)) P <- apply(y,2,sum) else P <- apply(y*wt,2,sum) P <- P/sum(P) P <- cumsum(P) nnu <- length(P)-2 dc[1] <- qlogis(P[1]) nu[[1]] <- diff(qlogis(P[-(nnu+2)])) eta <- as.vector(sr%*%dc) } if (!is.null(offset)) eta <- eta + offset dev <- switch(family, binomial=dev.resid.binomial(y,eta,wt), nbinomial=dev.resid.nbinomial(y,eta,wt), polr=dev.resid.polr(y,eta,wt,nu[[1]]), poisson=dev.resid.poisson(y,eta,wt), Gamma=dev.resid.Gamma(y,eta,wt), inverse.gaussian=dev.resid.inverse.gaussian(y,eta,wt), weibull=dev.resid.weibull(y,eta,wt,nu[[1]]), lognorm=dev0.resid.lognorm(y,eta,wt,nu[[1]]), loglogis=dev0.resid.loglogis(y,eta,wt,nu[[1]])) dev <- sum(dev) iter <- 0 flag <- 1 next } dc <- dc.new eta <- eta.new dev <- dev.new if (min(disc0,disc)<1e-7) break if (iter<=30) next if (!flag2) { flag2 <- 1 iter <- 0 next } warning("gss warning in gssanova: Newton iteration fails to converge") break } ## calculate cv dat <- switch(family, binomial=mkdata.binomial(y,eta,wt,offset), nbinomial=mkdata.nbinomial(y,eta,wt,offset,nu), polr=mkdata.polr(y,eta,wt,offset,nu[[1]]), poisson=mkdata.poisson(y,eta,wt,offset), Gamma=mkdata.Gamma(y,eta,wt,offset), inverse.gaussian=mkdata.inverse.gaussian(y,eta,wt,offset), weibull=mkdata.weibull(y,eta,wt,offset,nu), lognorm=mkdata.lognorm(y,eta,wt,offset,nu), loglogis=mkdata.loglogis(y,eta,wt,offset,nu)) if (family=="polr") nu[[1]] <- dat$nu ## weighted least squares fit w <- as.vector(sqrt(dat$wt)) ywk <- w*dat$ywk srwk <- w*sr z <- .Fortran("reg", as.double(srwk), as.integer(nobs), as.integer(nnull), as.double(q), as.integer(nxi), as.double(ywk), as.integer(5), double(1), double(1), double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxi))), hat=double(max(nobs+1,nn)), rkv=integer(1), integer(1), PACKAGE="gss")[c("dc","chol","jpvt","hat","rkv")] cv <- switch(family, binomial=cv.binomial(y,eta,wt,z$hat[1:nobs],alpha), poisson=cv.poisson(y,eta,wt,z$hat[1:nobs],alpha,sr,q), Gamma=cv.Gamma(y,eta,wt,z$hat[1:nobs],z$hat[nobs+1],alpha), inverse.gaussian=cv.inverse.gaussian(y,eta,wt,z$hat[1:nobs],z$hat[nobs+1],alpha), nbinomial=cv.nbinomial(y,eta,wt,z$hat[1:nobs],alpha), polr=cv.polr(y,eta,wt,z$hat[1:nobs],nu[[1]],alpha), weibull=cv.weibull(y,eta,wt,z$hat[1:nobs],nu[[1]],alpha), lognorm=cv.lognorm(y,eta,wt,z$hat[1:nobs],nu[[1]],alpha), loglogis=cv.loglogis(y,eta,wt,z$hat[1:nobs],nu[[1]],alpha)) c(z,cv,list(eta=eta,nu=nu)) } gss/R/summary.gssanova.R0000644000176200001440000001100513510150055014677 0ustar liggesusers## Summarize gssanova objects summary.gssanova <- function(object,diagnostics=FALSE,...) { if (object$family=="polr") { y <- model.response(object$mf) if (!is.factor(y)) stop("gss error in gssanova1: need factor response for polr family") lvls <- levels(y) if (nlvl <- length(lvls)<3) stop("gss error in gssanova1: need at least 3 levels to fit polr family") y <- outer(y,lvls,"==") } else y <- model.response(object$mf,"numeric") wt <- model.weights(object$mf) offset <- model.offset(object$mf) if ((object$family=="nbinomial")&(!is.null(object$nu))) y <- cbind(y,object$nu) dev.null <- switch(object$family, binomial=dev.null.binomial(y,wt,offset), nbinomial=dev.null.nbinomial(y,wt,offset), polr=dev.null.polr(y,wt,offset), poisson=dev.null.poisson(y,wt,offset), Gamma=dev.null.Gamma(y,wt,offset), weibull=dev.null.weibull(y,wt,offset,object$nu), lognorm=dev.null.lognorm(y,wt,offset,object$nu), loglogis=dev.null.loglogis(y,wt,offset,object$nu)) w <- object$w if (is.null(offset)) offset <- rep(0,length(object$eta)) ## Residuals res <- residuals(object)*sqrt(w) dev.resid <- residuals(object,"deviance") ## Fitted values fitted <- fitted(object) ## dispersion sigma2 <- object$varht ## RSS, deviance rss <- sum(res^2) dev <- sum(dev.resid^2) ## Penalty associated with the fit obj.wk <- object obj.wk$d[] <- 0 if (!is.null(model.offset(obj.wk$mf))) obj.wk$mf[,"(offset)"] <- 0 penalty <- sum(obj.wk$c*predict(obj.wk,obj.wk$mf[object$id.basis,])) penalty <- as.vector(10^object$nlambda*penalty) if (!is.null(object$random)) { p.ran <- t(object$b)%*%object$random$sigma$fun(object$zeta,object$random$sigma$env)%*%object$b penalty <- penalty + p.ran } ## Calculate the diagnostics if (diagnostics) { ## Obtain retrospective linear model comp <- NULL p.dec <- NULL for (label in object$terms$labels) { if (label=="1") next if (label=="offset") next comp <- cbind(comp,predict(object,object$mf,inc=label)) jk <- sum(obj.wk$c*predict(obj.wk,obj.wk$mf[object$id.basis,],inc=label)) p.dec <- c(p.dec,10^object$nlambda*jk) } term.label <- object$terms$labels[object$terms$labels!="1"] term.label <- term.label[term.label!="offset"] if (!is.null(object$random)) { mf <- object$mf mf$random <- object$random$z comp <- cbind(comp,predict(object,mf,inc=NULL)) p.dec <- c(p.dec,p.ran) term.label <- c(term.label,"random") } fitted.off <- fitted-offset comp <- cbind(comp,yhat=fitted.off,y=fitted.off+res/sqrt(w),e=res/sqrt(w)) if (any(outer(term.label,c("yhat","y","e"),"=="))) warning("gss warning in summary.gssanova: avoid using yhat, y, or e as variable names") colnames(comp) <- c(term.label,"yhat","y","e") ## Sweep out constant comp <- sqrt(w)*comp - outer(sqrt(w),apply(w*comp,2,sum))/sum(w) ## Obtain pi comp1 <- comp[,c(term.label,"yhat")] decom <- t(comp1) %*% comp1[,"yhat"] names(decom) <- c(term.label,"yhat") decom <- decom[term.label]/decom["yhat"] ## Obtain kappa, norm, and cosines corr <- t(comp)%*%comp corr <- t(corr/sqrt(diag(corr)))/sqrt(diag(corr)) norm <- apply(comp,2,function(x){sqrt(sum(x^2))}) cosines <- rbind(corr[c("y","e"),],norm) rownames(cosines) <- c("cos.y","cos.e","norm") corr <- corr[term.label,term.label,drop=FALSE] if (qr(corr)$rank1)|(min(x)<0)) stop("gss error in sscopu2: data out of range") if (!(is.matrix(x)&(dim(x)[2]==2))) stop("gss error in sscopu2: data must be a matrix of two columns") nobs <- dim(x)[1] if (!is.null(truncation)) { if (!(is.matrix(x)&all(dim(x)==dim(truncation)))) stop("gss error in sscopu2: truncation and data must match in size") if (!all(x=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=weights) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in sscopu2: id.basis out of range") nbasis <- length(id.basis) } ## Generate numerical quadrature hsz <- 20 qdsz <- 2*hsz qd <- gauss.quad(qdsz,c(0,1)) gap <- diff(qd$pt) g.wk <- gap[hsz]/2 for (i in 1:(hsz-2)) g.wk <- c(g.wk,gap[hsz+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,1/2-sum(g.wk)) gap[hsz:1] <- gap[hsz+(1:hsz)] <- g.wk brk <- cumsum(c(0,gap)) qd.pt <- cbind(rep(qd$pt,qdsz),rep(qd$pt,rep(qdsz,qdsz))) nmesh <- qdsz*qdsz ## Generate terms term <- mkterm.copu(2,2,symmetry,exclude=NULL) ## Generate s, r, and q idx0 <- (1:length(cens))[cens==0] n0 <- length(idx0) s0 <- qd.s <- r0 <- q <- qd.r <- NULL for (nu in 1:term$nphi) { s0 <- cbind(s0,term$phi(x[idx0,],nu,term$env)) qd.s <- cbind(qd.s,term$phi(qd.pt,nu,term$env)) } nq <- 0 for (nu in 1:term$nrk) { nq <- nq+1 r0 <- array(c(r0,term$rk(x[id.basis,],x[idx0,],nu,term$env,out=TRUE)),c(nbasis,n0,nq)) q <- array(c(q,term$rk(x[id.basis,],x[id.basis,],nu,term$env,out=TRUE)),c(nbasis,nbasis,nq)) qd.r <- array(c(qd.r,term$rk(x[id.basis,],qd.pt,nu,term$env,out=TRUE)),c(nbasis,nmesh,nq)) } idx1 <- (1:length(cens))[cens==1] n1 <- length(idx1) qd.s1 <- qd.r1 <- wt1 <- NULL for (i in idx1) { x.wk <- cbind(qd$pt,x[i,2]) for (nu in 1:term$nphi) qd.s1 <- cbind(qd.s1,term$phi(x.wk,nu,term$env)) for (nu in 1:term$nrk) qd.r1 <- c(qd.r1,term$rk(x.wk,x[id.basis,],nu,term$env,out=TRUE)) wt.wk <- qd$wt mx <- sum(brkalpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv <- function(theta) { ind.wk <- theta!=theta.old if (sum(ind.wk)==nq) { q.wk0 <- r.wk0 <- qd.r.wk0 <- 0 if (n1) qd.r1.wk0 <- 0 if (n2) qd.r2.wk0 <- 0 for (i in 1:nq) { q.wk0 <- q.wk0 + 10^theta[i]*q[,,i] r.wk0 <- r.wk0 + 10^theta[i]*r0[,,i] qd.r.wk0 <- qd.r.wk0 + 10^theta[i]*qd.r[,,i] if (n1) qd.r1.wk0 <- qd.r1.wk0 + 10^theta[i]*qd.r1[,,i,] if (n2) qd.r2.wk0 <- qd.r2.wk0 + 10^theta[i]*qd.r2[,,i,] } assign("q.wk",q.wk0+0,inherits=TRUE) assign("r.wk",r.wk0+0,inherits=TRUE) assign("qd.r.wk",qd.r.wk0+0,inherits=TRUE) assign("theta.old",theta+0,inherits=TRUE) if (n1) assign("qd.r1.wk",qd.r1.wk0+0,inherits=TRUE) if (n2) assign("qd.r2.wk",qd.r2.wk0+0,inherits=TRUE) } else { q.wk0 <- q.wk r.wk0 <- r.wk qd.r.wk0 <- qd.r.wk if (n1) qd.r1.wk0 <- qd.r1.wk if (n2) qd.r2.wk0 <- qd.r2.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] q.wk0 <- q.wk0 + theta.wk*q[,,i] r.wk0 <- r.wk0 + theta.wk*r0[,,i] qd.r.wk0 <- qd.r.wk0 + theta.wk*qd.r[,,i] if (n1) qd.r1.wk0 <- qd.r1.wk0 + theta.wk*qd.r1[,,i,] if (n2) qd.r2.wk0 <- qd.r2.wk0 + theta.wk*qd.r2[,,i,] } } if (n1) qd.rs1 <- aperm(array(c(aperm(qd.r1.wk0,c(1,3,2)), aperm(qd.s1,c(1,3,2))), c(nqd,n1,nxis)),c(1,3,2)) if (n2) qd.rs2 <- aperm(array(c(aperm(qd.r2.wk0,c(1,3,2)), aperm(qd.s2,c(1,3,2))), c(nqd,n2,nxis)),c(1,3,2)) fit <- .Fortran("copu2newton", cd=as.double(cd), as.integer(nxis), as.double(10^lambda*q.wk0), as.integer(nxi), as.double(rbind(r.wk0,s0)), as.integer(n0), as.integer(sum(cnt0)), as.integer(cnt0), as.double(rbind(qd.r.wk0,qd.s)), as.integer(nqd), as.double(qd.rs1), as.double(wt1), as.integer(n1), as.integer(sum(cnt1)), as.integer(cnt1), as.double(qd.rs2), as.double(wt2), as.integer(n2), as.integer(sum(cnt2)), as.integer(cnt2), as.double(wt3), as.integer(n3), as.integer(sum(cnt3)), as.integer(cnt3), as.integer(trun$nt), as.double(trun$t.wt), as.double(trun$qd.wt), as.integer(trun$t.ind), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nxis), wk=double(nqd*(2*nqd+n1+n2)+nxis*(2*nxis+trun$nt+5)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in sscopu2: Newton iteration diverges") if (fit$info==2) warning("gss warning in sscopu2: Newton iteration fails to converge") assign("cd",fit$cd,inherits=TRUE) cv <- alpha*fit$wk[2]+fit$wk[1] alpha.wk <- max(0,theta-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.wk <- function(theta) cv.scale*cv(theta)+cv.shift ## initialization theta <- -log10(apply(q,3,function(x)sum(diag(x)))) q.wk <- r.wk <- qd.r.wk <- 0 if (n1) qd.r1.wk <- 0 if (n2) qd.r2.wk <- 0 for (i in 1:nq) { q.wk <- q.wk + 10^theta[i]*q[,,i] r.wk <- r.wk + 10^theta[i]*r0[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] if (n1) qd.r1.wk <- qd.r1.wk + 10^theta[i]*qd.r1[,,i,] if (n2) qd.r2.wk <- qd.r2.wk + 10^theta[i]*qd.r2[,,i,] } v.r <- v.s <- 0 for (i in 1:trun$nt) { wt.wk <- as.vector(outer(trun$qd.wt[,1,i],trun$qd.wt[,2,i])) mu.wk <- apply(t(qd.r.wk)*wt.wk,2,sum)/sum(wt.wk) v.r.wk <- apply(t(qd.r.wk^2)*wt.wk,2,sum)/sum(wt.wk)-mu.wk^2 v.r <- v.r + trun$t.wt[i]*v.r.wk mu.wk <- apply(t(qd.s)*wt.wk,2,sum)/sum(wt.wk) v.s.wk <- apply(t(qd.s^2)*wt.wk,2,sum)/sum(wt.wk)-mu.wk^2 v.s <- v.s + trun$t.wt[i]*v.s.wk } log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) ## initial lambda search theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 q.wk <- 10^theta.wk*q.wk r.wk <- 10^theta.wk*r.wk qd.r.wk <- 10^theta.wk*qd.r.wk if (n1) qd.r1.wk <- 10^theta.wk*qd.r1.wk if (n2) qd.r2.wk <- 10^theta.wk*qd.r2.wk theta <- theta + theta.wk log.la0 <- log.la0 + theta.wk if (n1) qd.rs1 <- aperm(array(c(aperm(qd.r1.wk,c(1,3,2)),aperm(qd.s1,c(1,3,2))), c(nqd,n1,nxis)),c(1,3,2)) if (n2) qd.rs2 <- aperm(array(c(aperm(qd.r2.wk,c(1,3,2)),aperm(qd.s2,c(1,3,2))), c(nqd,n2,nxis)),c(1,3,2)) cd <- rep(0,nxi+nnull) la <- log.la0 repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv.s,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else la <- zz$est } ## theta adjustment q.wk <- r.wk <- qd.r.wk <- 0 if (n1) qd.r1.wk <- 0 if (n2) qd.r2.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(cd[1:nxi])%*%q[,,i]%*%cd[1:nxi]) q.wk <- q.wk + 10^theta[i]*q[,,i] r.wk <- r.wk + 10^theta[i]*r0[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] if (n1) qd.r1.wk <- qd.r1.wk + 10^theta[i]*qd.r1[,,i,] if (n2) qd.r2.wk <- qd.r2.wk + 10^theta[i]*qd.r2[,,i,] } v.r <- v.s <- 0 for (i in 1:trun$nt) { wt.wk <- as.vector(outer(trun$qd.wt[,1,i],trun$qd.wt[,2,i])) if (sum(wt.wk)==0) next mu.wk <- apply(t(qd.r.wk)*wt.wk,2,sum)/sum(wt.wk) v.r.wk <- apply(t(qd.r.wk^2)*wt.wk,2,sum)/sum(wt.wk)-mu.wk^2 v.r <- v.r + trun$t.wt[i]*v.r.wk mu.wk <- apply(t(qd.s)*wt.wk,2,sum)/sum(wt.wk) v.s.wk <- apply(t(qd.s^2)*wt.wk,2,sum)/sum(wt.wk)-mu.wk^2 v.s <- v.s + trun$t.wt[i]*v.s.wk } log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) ## lambda search theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 q.wk <- 10^theta.wk*q.wk r.wk <- 10^theta.wk*r.wk qd.r.wk <- 10^theta.wk*qd.r.wk if (n1) qd.r1.wk <- 10^theta.wk*qd.r1.wk if (n2) qd.r2.wk <- 10^theta.wk*qd.r2.wk theta <- theta + theta.wk log.la0 <- log.la0 + theta.wk if (n1) qd.rs1 <- aperm(array(c(aperm(qd.r1.wk,c(1,3,2)),aperm(qd.s1,c(1,3,2))), c(nqd,n1,nxis)),c(1,3,2)) if (n2) qd.rs2 <- aperm(array(c(aperm(qd.r2.wk,c(1,3,2)),aperm(qd.s2,c(1,3,2))), c(nqd,n2,nxis)),c(1,3,2)) cd <- rep(0,nxi+nnull) la <- log.la0 repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv.s,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else la <- zz$est } log.th0 <- theta-log.la0 lambda <- zz$est log.th0 <- log.th0 + lambda ## theta search counter <- 0 q.wk <- r.wk <- qd.r.wk <- 0 if (n1) qd.r1.wk <- 0 if (n2) qd.r2.wk <- 0 for (i in 1:nq) { q.wk <- q.wk + 10^theta[i]*q[,,i] r.wk <- r.wk + 10^theta[i]*r0[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] if (n1) qd.r1.wk <- qd.r1.wk + 10^theta[i]*qd.r1[,,i,] if (n2) qd.r2.wk <- qd.r2.wk + 10^theta[i]*qd.r2[,,i,] } theta.old <- theta ## scale and shift cv tmp <- abs(cv(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=.5,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssden: CV iteration fails to converge") break } } ## return jk1 <- cv(zz$est) c <- cd[1:nxi] d <- cd[nxi+(1:nnull)] list(lambda=lambda,theta=zz$est,c=c,d=d,cv=jk1) } gss/R/hzdrate.sshzd.R0000644000176200001440000002254013626325002014167 0ustar liggesusershzdrate.sshzd <- ## Evaluate hazard estimate function (object,x,se=FALSE,include=c(object$terms$labels,object$lab.p)) { if (!any(class(object)=="sshzd")) stop("gss error in hzdrate.sshzd: not a sshzd object") if (dim(object$mf)[2]==1&is.vector(x)) { x <- data.frame(x,stringsAsFactors=TRUE) colnames(x) <- colnames(object$mf) } if (!is.null(object$d)) s <- matrix(0,dim(x)[1],length(object$d)) r <- matrix(0,dim(x)[1],length(object$id.basis)) for (label in include) { if (label=="1") { iphi <- object$terms[[label]]$iphi s[,iphi] <- rep(1,dim(x)[1]) next } if (label%in%object$lab.p) next xx <- object$mf[object$id.basis,object$terms[[label]]$vlist] x.new <- x[,object$terms[[label]]$vlist] nphi <- object$terms[[label]]$nphi nrk <- object$terms[[label]]$nrk if (nphi) { iphi <- object$terms[[label]]$iphi phi <- object$terms[[label]]$phi for (i in 1:nphi) { s[,iphi+(i-1)] <- phi$fun(x.new,nu=i,env=phi$env) } } if (nrk) { irk <- object$terms[[label]]$irk rk <- object$terms[[label]]$rk for (i in 1:nrk) { r <- r + 10^object$theta[irk+(i-1)]* rk$fun(x.new,xx,nu=i,env=rk$env,out=TRUE) } } } if (!is.null(object$partial)) { vars.p <- as.character(attr(object$partial$mt,"variables"))[-1] facs.p <- attr(object$partial$mt,"factors") vlist <- vars.p[as.logical(apply(facs.p,1,sum))] for (lab in object$lab.p) { if (lab%in%include) { vlist.wk <- vars.p[as.logical(facs.p[,lab])] vlist <- vlist[!(vlist%in%vlist.wk)] } } if (length(vlist)) { for (lab in vlist) x[[lab]] <- 0 } matx.p <- model.matrix(object$partial$mt,x)[,-1,drop=FALSE] matx.p <- sweep(matx.p,2,object$partial$center) matx.p <- sweep(matx.p,2,object$partial$scale,"/") nu <- length(object$d)-dim(matx.p)[2] for (label in object$lab.p) { nu <- nu+1 if (label%in%include) s[,nu] <- matx.p[,label] } } if (is.null(object$random)) rs <- cbind(r,s) else { nz <- length(object$b) rs <- cbind(r,matrix(0,dim(x)[1],nz),s) } if (!se) as.vector(exp(rs%*%c(object$c,object$b,object$d))) else { fit <- as.vector(exp(rs%*%c(object$c,object$b,object$d))) se.fit <- .Fortran("hzdaux2", as.double(object$se.aux$v), as.integer(dim(rs)[2]), as.integer(object$se.aux$jpvt), as.double(t(rs)), as.integer(dim(rs)[1]), se=double(dim(rs)[1]), PACKAGE="gss")[["se"]] list(fit=fit,se.fit=se.fit) } } hzdcurve.sshzd <- ## Evaluate hazard curve for plotting function (object,time,covariates=NULL,se=FALSE) { tname <- object$tname xnames <- object$xnames if (!any(class(object)=="sshzd")) stop("gss error in hzdcurve.sshzd: not a sshzd object") if (length(xnames)&&(!all(xnames%in%names(covariates)))) stop("gss error in hzdcurve.sshzd: missing covariates") mn <- min(object$tdomain) mx <- max(object$tdomain) if ((min(time)mx)) stop("gss error in hzdcurve.sshzd: time range beyond the domain") if (length(xnames)) { xx <- covariates[,xnames,drop=FALSE] xy <- data.frame(matrix(0,length(time),length(xnames)+1)) names(xy) <- c(tname,xnames) xy[,tname] <- time } else xx <- NULL if (!se) { if (is.null(xx)) zz <- hzdrate.sshzd(object,time) else { zz <- NULL for (i in 1:dim(xx)[1]) { xy[,xnames] <- xx[rep(i,length(time)),] zz <- cbind(zz,hzdrate.sshzd(object,xy)) } zz <- zz[,,drop=TRUE] } zz } else { if (is.null(xx)) zz <- hzdrate.sshzd(object,time,TRUE) else { fit <- se.fit <- NULL for (i in 1:dim(xx)[1]) { xy[,xnames] <- xx[rep(i,length(time)),] wk <- hzdrate.sshzd(object,xy,TRUE) fit <- cbind(fit,wk$fit) se.fit <- cbind(se.fit,wk$se.fit) } zz <- list(fit=fit[,,drop=TRUE],se.fit=se.fit[,,drop=TRUE]) } zz } } survexp.sshzd <- ## Compute expected survival function(object,time,covariates=NULL,start=0) { tname <- object$tname xnames <- object$xnames ## Check inputs if (!any(class(object)=="sshzd")) stop("gss error in survexp.sshzd: not a sshzd object") if (length(xnames)&&(!all(xnames%in%names(covariates)))) stop("gss error in survexp.sshzd: missing covariates") lmt <- cbind(start,time) if (any(lmt[,1]>lmt[,2])) stop("gss error in survexp.sshzd: start after follow-up time") nt <- dim(lmt)[1] if (is.null(covariates)) ncov <- 1 else ncov <- dim(covariates)[1] mn <- min(object$tdomain) mx <- max(object$tdomain) if ((min(start)mx)) stop("gss error in survexp.sshzd: time range beyond the domain") ## Calculate qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) if (is.null(covariates)) { zz <- NULL d.qd <- hzdcurve.sshzd(object,qd$pt) for (i in 1:nt) { ind <- (1:(2*qd.hize))[(qd$ptlmt[i,1])] if (length(ind)) { wk <- sum(d.qd[ind]*qd$wt[ind]) id.mx <- max(ind) if (lmt[i,2]=qd$pt[2*qd.hize]) wk <- d.qd[2*qd.hize]*qd$wt[2*qd.hize]*(lmt[i,2]-lmt[i,1])/gap[2*qd.hize] if ((lmt[i,1]>qd$pt[1])&(lmt[i,1]lmt[i,1]]) if (brk[i.wk]<=lmt[i,1]) wk <- d.qd[i.wk]*qd$wt[i.wk]*(lmt[i,2]-lmt[i,1])/gap[i.wk] if (brk[i.wk]>=lmt[i,2]) wk <- d.qd[i.wk-1]*qd$wt[i.wk-1]*(lmt[i,2]-lmt[i,1])/gap[i.wk-1] if ((brk[i.wk]lmt[i,1])) wk <- d.qd[i.wk]*qd$wt[i.wk]*(lmt[i,2]-brk[i.wk])/gap[i.wk]+ d.qd[i.wk-1]*qd$wt[i.wk-1]*(brk[i.wk]-lmt[i,1])/gap[i.wk-1] } } zz <- c(zz,wk) } } else { zz <- NULL for (j in 1:ncov) { zz.wk <- NULL d.qd <- hzdcurve.sshzd(object,qd$pt,covariates[j,,drop=FALSE]) for (i in 1:nt) { ind <- (1:(2*qd.hize))[(qd$ptlmt[i,1])] if (length(ind)) { wk <- sum(d.qd[ind]*qd$wt[ind]) id.mx <- max(ind) if (lmt[i,2]<=brk[id.mx+1]) wk <- wk-d.qd[id.mx]*qd$wt[id.mx]*(brk[id.mx+1]-lmt[i,2])/gap[id.mx] else wk <- wk+d.qd[id.mx+1]*qd$wt[id.mx+1]*(lmt[i,2]-brk[id.mx+1])/gap[id.mx+1] id.mn <- min(ind) if (lmt[i,1]=qd$pt[2*qd.hize]) wk <- d.qd[2*qd.hize]*qd$wt[2*qd.hize]*(lmt[i,2]-lmt[i,1])/gap[2*qd.hize] if ((lmt[i,1]>qd$pt[1])&(lmt[i,1]lmt[i,1]]) if (brk[i.wk]<=lmt[i,1]) wk <- d.qd[i.wk]*qd$wt[i.wk]*(lmt[i,2]-lmt[i,1])/gap[i.wk] if (brk[i.wk]>=lmt[i,2]) wk <- d.qd[i.wk-1]*qd$wt[i.wk-1]*(lmt[i,2]-lmt[i,1])/gap[i.wk-1] if ((brk[i.wk]lmt[i,1])) wk <- d.qd[i.wk]*qd$wt[i.wk]*(lmt[i,2]-brk[i.wk])/gap[i.wk]+ d.qd[i.wk-1]*qd$wt[i.wk-1]*(brk[i.wk]-lmt[i,1])/gap[i.wk-1] } } zz.wk <- c(zz.wk,wk) } zz <- cbind(zz,as.vector(zz.wk)) } if (ncov==1) zz <- as.vector(zz) } exp(-zz) } gss/R/cdssden.R0000644000176200001440000001437313626324555013040 0ustar liggesuserscdssden <- ## Evaluate conditional density function (object,x,cond,int=NULL) { if (!("ssden"%in%class(object))) stop("gss error in cdssden: not a ssden object") if (nrow(cond)!=1) stop("gss error in cdssden: condition has to be a single point") xnames <- NULL for (i in colnames(object$mf)) if (all(i!=colnames(cond))) xnames <- c(xnames,i) if (any(length(xnames)==c(0,ncol(object$mf)))) stop("gss error in cdssden: not a conditional density") if (length(xnames)==1&is.vector(x)) { x <- data.frame(x,stringsAsFactors=TRUE) colnames(x) <- xnames } if (!all(sort(xnames)==sort(colnames(x)))) stop("gss error in cdssden: mismatched variable names") ## Calculate normalizing constant while (is.null(int)) { fac.list <- NULL num.list <- NULL for (xlab in xnames) { if (is.factor(x.wk <- x[[xlab]])) fac.list <- c(fac.list,xlab) else { if (!is.vector(x.wk)|is.null(object$domain[[xlab]])) { warning("gss warning in cdssden: int set to 1") int <- 1 next } else num.list <- c(num.list,xlab) } } ## Generate quadrature for numerical variables if (!is.null(num.list)) { if (length(num.list)==1) { ## Gauss-Legendre quadrature mn <- min(object$domain[,num.list]) mx <- max(object$domain[,num.list]) quad <- gauss.quad(200,c(mn,mx)) quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- num.list } else { ## Smolyak cubature domain.wk <- object$domain[,num.list] code <- c(15,14,13) quad <- smolyak.quad(ncol(domain.wk),code[ncol(domain.wk)-1]) for (i in 1:ncol(domain.wk)) { xlab <- colnames(domain.wk)[i] form <- as.formula(paste("~",xlab)) jk <- ssden(form,data=object$mf,domain=domain.wk[i],alpha=2, id.basis=object$id.basis) quad$pt[,i] <- qssden(jk,quad$pt[,i]) quad$wt <- quad$wt/dssden(jk,quad$pt[,i]) } jk <- NULL quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- colnames(domain.wk) } } else quad <- list(pt=data.frame(dum=1),wt=1) ## Incorporate factors in quadrature if (!is.null(fac.list)) { for (i in 1:length(fac.list)) { wk <- expand.grid(levels(object$mf[[fac.list[i]]]),1:length(quad$wt)) quad$wt <- quad$wt[wk[,2]] col.names <- c(fac.list[i],colnames(quad$pt)) quad$pt <- data.frame(wk[,1],quad$pt[wk[,2],],stringsAsFactors=TRUE) colnames(quad$pt) <- col.names } } xmesh <- quad$pt[,xnames,drop=FALSE] xx <- cond[rep(1,nrow(xmesh)),,drop=FALSE] int <- sum(dssden(object,cbind(xmesh,xx))*quad$wt) } ## Return value xx <- cond[rep(1,nrow(x)),,drop=FALSE] list(pdf=dssden(object,cbind(x,xx))/int,int=int) } cpssden <- ## Compute cdf for univariate conditional density function(object,q,cond) { if (!("ssden"%in%class(object))) stop("gss error in cpssden: not a ssden object") xnames <- NULL for (i in colnames(object$mf)) if (all(i!=colnames(cond))) xnames <- c(xnames,i) if ((length(xnames)!=1)|!is.vector(object$mf[,xnames])) stop("gss error in cpssden: not a 1-D conditional density") mn <- min(object$domain[,xnames]) mx <- max(object$domain[,xnames]) order.q <- rank(q) p <- q <- sort(q) q.dup <- duplicated(q) p[q<=mn] <- 0 p[q>=mx] <- 1 qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) d.qd <- cdssden(object,qd$pt,cond)$pdf d.qd <- d.qd/sum(d.qd*qd$wt) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(q))[q>mn&q=1] <- mx qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) d.qd <- cdssden(object,qd$pt,cond)$pdf d.qd <- d.qd/sum(d.qd*qd$wt) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) p.wk <- cumsum(d.qd*qd$wt) kk <- (1:length(p))[p>0&p<1] for (i in kk) { if (p.dup[i]) { q[i] <- q.dup next } ind <- (1:(2*qd.hize))[p.wk=mx] <- 1 qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) d.qd <- dssden(object,qd$pt) d.qd <- d.qd/sum(d.qd*qd$wt) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(q))[q>mn&q=1] <- mx qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) d.qd <- dssden(object,qd$pt) d.qd <- d.qd/sum(d.qd*qd$wt) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) p.wk <- cumsum(d.qd*qd$wt) kk <- (1:length(p))[p>0&p<1] for (i in kk) { if (p.dup[i]) { q[i] <- q.dup next } ind <- (1:(2*qd.hize))[p.wktime)) stop("gss error in sshzd2d: start after follow-up time") if (min(start)<0) stop("gss error in sshzd2d: start before time 0") time <- cbind(start,time) list(tname=tname,start=time[,1],end=time[,2],status=as.logical(status)) } ## Obtain model terms for (i in 1:2) { ## Formula form.wk <- switch(i,form1,form2) term.wk <- terms.formula(form.wk) resp <- attr(term.wk,"variable")[[2]] ind.wk <- length(strsplit(deparse(resp),'')[[1]]) if ((substr(deparse(resp),1,5)!='Surv(') |(substr(deparse(resp),ind.wk,ind.wk)!=')')) stop("gss error in sshzd2d: response should be Surv(...)") yy <- with(data,eval(resp)) tname <- yy$tname term.labels <- attr(term.wk,"term.labels") if (!(tname%in%term.labels)) stop("gss error in sshzd2d: time main effect missing in model") form.wk <- eval(parse(text=paste("~",paste(term.labels,collapse="+")))) mf.wk <- model.frame(form.wk,data) ## Partial part.wk <- switch(i,part1,part2) if (!is.null(part.wk)) { mf.p.wk <- model.frame(part.wk,data) mt.p.wk <- attr(mf.p.wk,"terms") matx.p.wk <- model.matrix(mt.p.wk,data)[,-1,drop=FALSE] if (dim(matx.p.wk)[1]!=dim(mf.wk)[1]) stop("gss error in sshzd2d: partial data are of wrong size") } else mf.p.wk <- mt.p.wk <- matx.p.wk <- NULL ## Random random.wk <- switch(i,random1,random2) if (!is.null(random.wk)) { if (inherits(random.wk,"formula")) random.wk <- mkran(random.wk,data) } else random.wk <- NULL ## Set domain and type for time type.wk <- switch(i,type1,type2) mn <- min(yy$start) mx <- max(yy$end) tdomain <- c(max(mn-.05*(mx-mn),0),mx) tname <- yy$tname if (is.null(type.wk[[tname]])) type.wk[[tname]] <- list("cubic",tdomain) if (length(type.wk[[tname]])==1) type.wk[[tname]] <- c(type.wk[[tname]],tdomain) if (!(type.wk[[tname]][[1]]%in%c("cubic","linear"))) stop("gss error in sshzd2d: wrong type") if ((min(type.wk[[tname]][[2]])>min(tdomain))| (max(type.wk[[tname]][[2]])=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in sshzd2d: id.basis out of range") nbasis <- length(id.basis) } ## Generate terms if (symmetry) { nhzd <- 1 if (dim(mf2)[2]!=dim(mf1)[2]) stop("gss error in sshzd2d: variables in parallel formulas must match") mf1.wk <- mf1 mf2.wk <- mf2 names(mf1.wk) <- names(mf2) names(mf2.wk) <- names(mf1) tdomain1 <- c(min(tdomain1,tdomain2),max(tdomain1,tdomain2)) type1[[yy1$tname]][[2]] <- tdomain1 type2[[yy2$tname]][[2]] <- tdomain1 term1 <- mkterm(rbind(mf1,mf2.wk),type1) term2 <- mkterm(rbind(mf2,mf1.wk),type2) mf1 <- rbind(mf1,mf2.wk) yy1.sv <- yy1 yy1$start <- c(yy1$start,yy2$start) yy1$end <- c(yy1$end,yy2$end) yy1$status <- c(yy1$status,yy2$status) id.basis.wk <- c(id.basis,id.basis+nobs) if (!is.null(mf.p1)) { if (is.null(mf.p2)||(dim(mf.p2)[2]!=dim(mf.p1)[2])) stop("gss error in sshzd2d: variables in parallel formulas must match") matx.p1 <- rbind(matx.p1,matx.p2) } if (!is.null(random1)) { if (is.null(random2)||(dim(random2$z)[2]!=dim(random1$z)[2])) stop("gss error in sshzd2d: variables in parallel formulas must match") random1$z <- rbind(random1$z,random2$z) } if (!is.null(cnt)) cnt.wk <- c(cnt,cnt) else cnt.wk <- NULL } else { nhzd <- 2 term1 <- mkterm(mf1,type1) term2 <- mkterm(mf2,type2) id.basis.wk <- id.basis cnt.wk <- cnt } ## Fit marginal hazard models for (ii in 1:nhzd) { ## Extract model components mf <- switch(ii,mf1,mf2) yy <- switch(ii,yy1,yy2) term <- switch(ii,term1,term2) mf.p <- switch(ii,mf.p1,mf.p2) mt.p <- switch(ii,mt.p1,mt.p2) matx.p <- switch(ii,matx.p1,matx.p2) random <- switch(ii,random1,random2) tdomain <- switch(ii,tdomain1,tdomain2) ## Finalize id.basis nobs <- length(yy$status) id.basis.wk <- id.basis.wk[yy$status[id.basis.wk]] nbasis <- length(id.basis.wk) id.wk <- NULL nT <- sum(yy$status) for (i in 1:nbasis) { id.wk <- c(id.wk,(1:nT)[(1:nobs)[yy$status]%in%id.basis.wk[i]]) } ## Generate Gauss-Legendre quadrature nmesh <- 200 quad <- gauss.quad(nmesh,tdomain) ## set up partial terms if (!is.null(mf.p)) { for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] lab.p <- labels(mt.p) matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL ## Obtain unique covariate observations tname <- yy$tname xnames <- names(mf) xnames <- xnames[!xnames%in%tname] if (length(xnames)||!is.null(random)) { xx <- mf[,xnames,drop=FALSE] if (!is.null(part)) xx <- cbind(xx,matx.p) if (!is.null(random)) xx <- cbind(xx,random$z) xx <- apply(xx,1,function(x)paste(x,collapse="\r")) ux <- unique(xx) nx <- length(ux) x.dup.ind <- duplicated(xx) x.dup <- as.vector(xx[x.dup.ind]) x.pt <- mf[!x.dup.ind,xnames,drop=FALSE] ## xx[i,]==x.pt[x.ind[i],] x.ind <- 1:nobs x.ind[!x.dup.ind] <- 1:nx if (nobs-nx) { x.ind.wk <- range <- 1:(nobs-nx) for (i in 1:nx) { range.wk <- NULL for (j in range) { if (identical(ux[i],x.dup[j])) { x.ind.wk[j] <- i range.wk <- c(range.wk,j) } } if (!is.null(range.wk)) range <- range[!(range%in%range.wk)] } x.ind[x.dup.ind] <- x.ind.wk } if (!is.null(random)) { random$qd.z <- random$z[!x.dup.ind,] random$z <- random$z[yy$status,] } } else { nx <- 1 x.ind <- rep(1,nobs) x.pt <- NULL } ## Integration weights at x.pt[i,] qd.wt <- matrix(0,nmesh,nx) for (i in 1:nobs) { wk <- (quad$pt<=yy$end[i])&(quad$pt>yy$start[i]) if (is.null(cnt.wk)) qd.wt[,x.ind[i]] <- qd.wt[,x.ind[i]]+wk else qd.wt[,x.ind[i]] <- qd.wt[,x.ind[i]]+cnt.wk[i]*wk } if (is.null(cnt.wk)) qd.wt <- quad$wt*qd.wt/nobs else qd.wt <- quad$wt*qd.wt/sum(cnt.wk) ## Generate s and r s <- r <- qd.s <- NULL qd.r <- as.list(NULL) nq <- nu <- 0 for (label in term$labels) { if (label=="1") { nu <- nu+1 s <- cbind(s,rep(1,len=nT)) qd.wk <- matrix(1,nmesh,nx) qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) next } vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] xy <- mf[yy$status,vlist] xy.basis <- mf[id.basis.wk,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist if (tname%in%vlist) qd.xy[,tname] <- quad$pt if (length(x.list)) xx <- x.pt[,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { nu <- nu+1 s <- cbind(s,phi$fun(xy,nu=i,env=phi$env)) if (is.null(xx)) qd.wk <- matrix(phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env),nmesh,nx) else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- cbind(qd.wk,phi$fun(qd.xy[,,drop=TRUE],i,phi$env)) } } qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE)),c(nT,nbasis,nq)) if (is.null(xx)) qd.r[[nq]] <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,out=TRUE) else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- array(c(qd.wk,rk$fun(qd.xy[,,drop=TRUE],xy.basis,i, rk$env,TRUE)),c(nmesh,nbasis,j)) } qd.r[[nq]] <- qd.wk } } } } ## Add the partial term if (!is.null(part)) { s <- cbind(s,matx.p[yy$status,]) nu.p <- dim(matx.p)[2] qd.wk <- aperm(array(matx.p[!x.dup.ind,],c(nx,nu.p,nmesh)),c(3,1,2)) nu <- nu + nu.p qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) } ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rank=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in ssanova9: id.basis out of range") nbasis <- length(id.basis) } ## Generate terms term <- mkterm(mf,type) ## Generate cov if (is.null(cov$fun)) { type <- cov[[1]] if (type=="arma") { pq <- cov[[2]] cov <- mkcov.arma(pq[1],pq[2],nobs) } if (type=="long") { if (nobsalpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*z$wk[2] if (method=="v") score <- score + (alpha.wk-alpha)*2*z$wk[2]/(1-z$wk[2]) } z$score <- score assign("fit",z[c(1:5,7)],inherits=TRUE) score } cv.wk <- function(lambda) cv.scale*cv(lambda)+cv.shift ## initialization tmp <- sum(r^2) if (is.null(s)) theta <- 0 else theta <- log10(sum(s^2)/nnull/tmp*nxi) / 2 log.la0 <- log10(tmp/sum(diag(q))) + theta ## lambda search fit <- NULL la <- c(log.la0,cov$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssanova9: iteration for model selection fails to converge") break } } } else { ww <- cov$fun(cov$env) ww <- chol(ww) y.wk <- forwardsolve(t(ww),y) s.wk <- forwardsolve(t(ww),s) r.wk <- forwardsolve(t(ww),r) mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } } ## return lambda <- zz$est jk1 <- cv(lambda) q.wk <- 10^(theta)*q if (length(lambda)-1) ww <- cov$fun(lambda[-1],cov$env) else ww <- cov$fun(cov$env) ww <- chol(ww) s.wk <- forwardsolve(t(ww),s) r.wk <- forwardsolve(t(ww),r) se.aux <- regaux(s.wk,10^theta*r.wk,q.wk,lambda[1],fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL c(list(method=method,theta=theta,c=c,d=d,nlambda=lambda[1],zeta=lambda[-1]), fit[-3],list(se.aux=se.aux)) } ## Fit Multiple Smoothing Parameter (Gaussian) REGression mspreg91 <- function(s,r,id.basis,y,cov,method,alpha,varht,skip.iter) { ## get dimensions nobs <- nrow(r) nxi <- ncol(r) if (!is.null(s)) { if (is.vector(s)) nnull <- 1 else nnull <- ncol(s) } else nnull <- 0 nn <- nxi + nnull nq <- dim(r)[3] ## cv function cv <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] } } q.wk <- 10^nlambda*r.wk0[id.basis,] if (length(theta)-nq) { ww <- cov$fun(theta[-(1:nq)],cov$env) ww <- chol(ww) y.wk <- forwardsolve(t(ww),y) s.wk <- forwardsolve(t(ww),s) } r.wk0 <- forwardsolve(t(ww),r.wk0) z <- .Fortran("reg", as.double(cbind(s.wk,r.wk0)), as.integer(nobs), as.integer(nnull), as.double(q.wk), as.integer(nxi), as.double(y.wk), as.integer(switch(method,"u"=1,"v"=2,"m"=3)), as.double(alpha), varht=as.double(varht), score=double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxi))), wk=double(3*nobs+nnull), rkv=integer(1), info=integer(1), PACKAGE="gss")[c("score","varht","dc","chol","jpvt","wk","rkv","info")] if (z$info) stop("gss error in ssanova9: evaluation of GML score fails") if (!nnull|method%in%c("u","v")) detw <- 2*sum(log(diag(ww))) else { wk <- qr.qty(qr(s),t(ww))[-(1:nnull),] detw <- sum(log(eigen(wk%*%t(wk))$value)) } if (method=="m") score <- z$score*exp(detw/(nobs-nnull)) if (method=="u") score <- z$wk[1]/varht+detw/nobs+2*alpha*z$wk[2] if (method=="v") score <- log(z$wk[1])+detw/nobs+2*alpha*z$wk[2]/(1-z$wk[2]) alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) if (alpha.wk>alpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*z$wk[2] if (method=="v") score <- score + (alpha.wk-alpha)*2*z$wk[2]/(1-z$wk[2]) } z$score <- score assign("fit",z[c(1:5,7)],inherits=TRUE) score } cv.wk <- function(theta) cv.scale*cv(theta)+cv.shift ## initialization theta <- -log10(apply(r[id.basis,,],3,function(x)sum(diag(x)))) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } ## theta adjustment z <- sspreg91(s,r.wk,r.wk[id.basis,],y,cov,method,alpha,varht) theta <- theta + z$theta r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(z$c)%*%r[id.basis,,i]%*%z$c) r.wk <- r.wk + 10^theta[i]*r[,,i] } log.la0 <- log10(sum(r.wk^2)/sum(diag(r.wk[id.basis,]))) log.th0 <- theta-log.la0 ## lambda search z <- sspreg91(s,r.wk,r.wk[id.basis,],y,cov,method,alpha,varht) nlambda <- z$nlambda log.th0 <- log.th0 + z$nlambda theta <- theta + z$theta ## early return if (skip.iter) { z$theta <- theta return(z) } ## theta search fit <- NULL counter <- 0 r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } theta.old <- theta theta <- c(theta,z$zeta) ## scale and shift cv if (length(theta)==nq) { ww <- cov$fun(cov$env) ww <- chol(ww) y.wk <- forwardsolve(t(ww),y) s.wk <- forwardsolve(t(ww),s) } tmp <- abs(cv(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssanova9: iteration for model selection fails to converge") break } } ## return theta <- zz$est jk1 <- cv(theta) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.basis,] if (length(theta)-nq) ww <- cov$fun(theta[-(1:nq)],cov$env) else ww <- cov$fun(cov$env) ww <- chol(ww) s.wk <- forwardsolve(t(ww),s) r.wk <- forwardsolve(t(ww),r.wk) se.aux <- regaux(s.wk,r.wk,q.wk,nlambda,fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL c(list(method=method,theta=theta[1:nq],c=c,d=d,nlambda=nlambda, zeta=theta[-(1:nq)]),fit[-3],list(se.aux=se.aux)) } mkcov.arma <- function(p,q,n) { ## check inputs if ((p<0)|(q<0)) stop("gss error in mkcov.arma: ARMA orders must be non-negative") if (p+q==0) stop("gss error in mkcov.arma: use ssanova for independent data") if (n<(p+1)) stop("gss error in mkcov.arma: AR order too high") env <- list(p=p,q=q,n=n) init <- rep(0,p+q) fun <- function(x,env) { p <- env$p q <- env$q n <- env$n ## arma coefficients if (p) { a <- (1-exp(-x[1:p]))/(1+exp(-x[1:p])) if (p-1) { for (j in 2:p) a[1:(j-1)] <- a[1:(j-1)]-a[j]*a[(j-1):1] } } else a <- NULL if (q) { b <- (1-exp(-x[p+(1:q)]))/(1+exp(-x[p+(1:q)])) if (q-1) { for (j in 2:q) b[1:(j-1)] <- b[1:(j-1)]-b[j]*b[(j-1):1] } } else b <- NULL ## psi psi <- 1 if (qq <- max(p-1,q)) { for(i in 1:qq) { wk <- ifelse(i<=q,-b[i],0) if(p) { for(j in 1:min(i,p)) wk <- wk + a[j]*psi[i-j+1] } psi<-c(psi,wk) } } ## autocovariance aa <- bb <- 1 if (p) aa <- c(aa,-a) if (q) bb <- c(bb,-b) if (length(bb)0] nmesh <- length(ind) if (!nmesh) next qd.wt.wk <- qd.wt[ind,k] qd.s <- NULL qd.r <- as.list(NULL) iq <- 0 for (label in term$labels) { if (label=="1") { qd.wk <- rep(1,nmesh) qd.s <- cbind(qd.s,qd.wk) next } vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist if (tname%in%vlist) qd.xy[,tname] <- quad$pt[ind] if (length(x.list)) qd.xy[,x.list] <- x.pt[rep(k,nmesh),x.list,drop=FALSE] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { qd.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) qd.s <- cbind(qd.s,qd.wk) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { iq <- iq+1 qd.r[[iq]] <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,out=TRUE) } } } if (!is.null(object$partial)) { wk <- object$partial$pt[k,] qd.s <- cbind(qd.s,t(matrix(wk,length(wk),nmesh))) } ss <- ss + t(qd.wt.wk*qd.s)%*%qd.s for (i in 1:nq) { sr[,,i] <- sr[,,i] + t(qd.wt.wk*qd.s)%*%qd.r[[i]] for (j in 1:i) { rr.wk <- t(qd.wt.wk*qd.r[[i]])%*%qd.r[[j]] rr[,,i,j] <- rr[,,i,j] + rr.wk if (i-j) rr[,,j,i] <- rr[,,j,i] + t(rr.wk) } } } ## evaluate full model cfit <- log(object$cfit) d <- object$d c <- object$c theta <- object$theta s.eta <- ss%*%d r.eta <- tmp <- NULL r.wk <- sr.wk <- rr.wk <- 0 for (i in 1:nq) { tmp <- c(tmp,10^(2*theta[i])*sum(diag(rr[,,i,i]))) s.eta <- s.eta + 10^theta[i]*sr[,,i]%*%c if (length(d)==1) r.eta.wk <- sr[,,i]*d else r.eta.wk <- t(sr[,,i])%*%d r.wk <- r.wk + 10^theta[i]*r[,i] sr.wk <- sr.wk + 10^theta[i]*sr[,,i] for (j in 1:nq) { r.eta.wk <- r.eta.wk + 10^theta[j]*rr[,,i,j]%*%c rr.wk <- rr.wk + 10^(theta[i]+theta[j])*rr[,,i,j] } r.eta <- cbind(r.eta,r.eta.wk) } eta2 <- sum(c*(rr.wk%*%c)) + sum(d*(ss%*%d)) + 2*sum(d*(sr.wk%*%c)) mse <- eta2 - 2*sum(c(d,c)*c(s,r.wk))*cfit + cfit^2*sum(qd.wt) ## extract terms in subspace id.s <- id.q <- NULL for (label in term$labels) { if (label=="1") { id.s <- c(id.s,1) next } if (!any(label==include)) next term.wk <- term[[label]] if (term.wk$nphi>0) id.s <- c(id.s,term.wk$iphi+(1:term.wk$nphi)-1) if (term.wk$nrk>0) id.q <- c(id.q,term.wk$irk+(1:term.wk$nrk)-1) } if (!is.null(object$partial)) { nu <- length(object$d)-length(object$lab.p) for (label in object$lab.p) { nu <- nu+1 if (!any(label==include)) next id.s <- c(id.s,nu) } } ## calculate projection rkl <- function(theta1=NULL) { theta.wk <- 1:nq theta.wk[fix] <- theta[fix] if (nq0-1) theta.wk[id.q0] <- theta1 ## ss.wk <- ss[id.s,id.s] r.eta.wk <- sr.wk <- rr.wk <- 0 for (i in id.q) { r.eta.wk <- r.eta.wk + 10^theta.wk[i]*r.eta[,i] sr.wk <- sr.wk + 10^theta.wk[i]*sr[id.s,,i] for (j in id.q) { rr.wk <- rr.wk + 10^(theta.wk[i]+theta.wk[j])*rr[,,i,j] } } v <- cbind(rbind(ss.wk,t(sr.wk)),rbind(sr.wk,rr.wk)) mu <- c(s.eta[id.s],r.eta.wk) nn <- length(mu) suppressWarnings(z <- chol(v,pivot=TRUE)) v <- z rkv <- attr(z,"rank") m.eps <- .Machine$double.eps while (v[rkv,rkv]<2*sqrt(m.eps)*v[1,1]) rkv <- rkv - 1 if (rkvrkv,(1:nn)>rkv] <- diag(v[1,1],nn-rkv) mu <- backsolve(v,mu[attr(z,"pivot")],transpose=TRUE) eta2 - sum(mu[1:rkv]^2) } cv.wk <- function(theta) cv.scale*rkl(theta)+cv.shift ## initialization nq0 <- length(id.q) tmp[-id.q] <- 0 fix <- rev(order(tmp))[1] ## projection if (nq0-1) { id.q0 <- id.q[id.q!=fix] if (object$skip.iter) se <- rkl(theta[id.q0]) else { if (nq0-2) { ## scale and shift cv tmp <- abs(rkl(theta[id.q0])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[id.q0],stepmax=.5,ndigit=7) } else { the.wk <- theta[id.q0] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } se <- rkl(zz$est) } } else se <- rkl() list(ratio=se/mse,se=se) } gss/R/cdsscden.R0000644000176200001440000001724013626324472013175 0ustar liggesuserscdsscden <- ## Evaluate conditional density estimate function (object,y,x,cond,int=NULL) { ## check inputs if (!("sscden"%in%class(object))) stop("gss error in cdsscden: not a sscden object") if (!all(sort(object$xnames)==sort(colnames(x)))) stop("gss error in cdsscden: mismatched x variable names") if (nrow(cond)!=1) stop("gss error in cdsscden: condition has to be a single point") ynames <- NULL for (i in object$ynames) if (all(i!=colnames(cond))) ynames <- c(ynames,i) if (any(length(ynames)==c(0,length(object$ynames)))) stop("gss error in cdsscden: not a conditional density") if (length(ynames)==1&is.vector(y)) { y <- data.frame(y,stringsAsFactors=TRUE) colnames(y) <- ynames } if (!all(sort(ynames)==sort(colnames(y)))) stop("gss error in cdsscden: mismatched y variable names") ## Calculate normalizing constant if ("sscden1"%in%class(object)) ydomain <- object$rho$env$ydomain else ydomain <- object$ydomain while (is.null(int)) { fac.list <- NULL num.list <- NULL for (ylab in ynames) { if (is.factor(y.wk <- y[[ylab]])) fac.list <- c(fac.list,ylab) else { if (!is.vector(y.wk)|is.null(ydomain[[ylab]])) { warning("gss warning in cdsscden: int set to 1") int <- 1 next } else num.list <- c(num.list,ylab) } } ## Generate quadrature for numerical variables if (!is.null(num.list)) { if (length(num.list)==1) { ## Gauss-Legendre quadrature mn <- min(ydomain[,num.list]) mx <- max(ydomain[,num.list]) quad <- gauss.quad(200,c(mn,mx)) quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- num.list } else { ## Smolyak cubature domain.wk <- ydomain[,num.list] code <- c(15,14,13) quad <- smolyak.quad(ncol(domain.wk),code[ncol(domain.wk)-1]) for (i in 1:ncol(domain.wk)) { ylab <- colnames(domain.wk)[i] wk <- object$mf[[ylab]] jk <- ssden(~wk,domain=data.frame(wk=domain.wk[,i]),alpha=2, id.basis=object$id.basis) quad$pt[,i] <- qssden(jk,quad$pt[,i]) quad$wt <- quad$wt/dssden(jk,quad$pt[,i]) } jk <- wk <- NULL quad$pt <- data.frame(quad$pt) colnames(quad.pt) <- colnames(domain.wk) } } else quad <- list(pt=data.frame(dum=1),wt=1) ## Incorporate factors in quadrature if (!is.null(fac.list)) { for (i in 1:length(fac.list)) { wk <- expand.grid(levels(object$mf[[fac.list[i]]]),1:length(quad$wt)) quad$wt <- quad$wt[wk[,2]] col.names <- c(fac.list[i],colnames(quad$pt)) quad$pt <- data.frame(wk[,1],quad$pt[wk[,2],],stringsAsFactors=TRUE) colnames(quad$pt) <- col.names } } ymesh <- quad$pt[,ynames,drop=FALSE] yy <- cond[rep(1,nrow(ymesh)),,drop=FALSE] int <- apply(dsscden(object,cbind(ymesh,yy),x)*quad$wt,2,sum) } ## Return value yy <- cond[rep(1,nrow(y)),,drop=FALSE] list(pdf=t(t(dsscden(object,cbind(y,yy),x))/int),int=int) } cpsscden <- ## Compute cdf for univariate conditional density function(object,q,x,cond) { ## check inputs if (!("sscden"%in%class(object))) stop("gss error in cpsscden: not a sscden object") if (!all(sort(object$xnames)==sort(colnames(x)))) stop("gss error in cpsscden: mismatched x variable names") if (nrow(cond)!=1) stop("gss error in cpsscden: condition has to be a single point") ynames <- NULL for (i in object$ynames) if (all(i!=colnames(cond))) ynames <- c(ynames,i) if (length(ynames)!=1) stop("gss error in cpsscden: y is not 1-D") if (is.factor(object$mf[,ynames])) stop("gss error in cpsscden: y is not continuous") if ("sscden1"%in%class(object)) ydomain <- object$rho$env$ydomain else ydomain <- object$ydomain mn <- min(ydomain[[ynames]]) mx <- max(ydomain[[ynames]]) order.q <- rank(q) p <- q <- sort(q) q.dup <- duplicated(q) p[q<=mn] <- 0 p[q>=mx] <- 1 qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) y.wk <- data.frame(qd$pt) colnames(y.wk) <- ynames y.wk <- cbind(y.wk,cond) d.qd <- dsscden(object,y.wk,x) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(q))[q>mn&q=1] <- mx qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) y.wk <- data.frame(qd$pt) colnames(y.wk) <- ynames y.wk <- cbind(y.wk,cond) d.qd <- dsscden(object,y.wk,x) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(p))[p>0&p<1] z <- NULL for (k in 1:dim(x)[1]) { d.qd.wk <- d.qd[,k]/sum(d.qd[,k]*qd$wt) p.wk <- cumsum(d.qd.wk*qd$wt) for (i in kk) { if (p.dup[i]) { q[i] <- q.dup next } ind <- (1:(2*qd.hize))[p.wkdm)&(dm>=1))) { stop("gss error: thin-plate spline undefined for the parameters") } if (xor(is.vector(mesh),dm==1) |xor(is.matrix(mesh),dm>=2)) { stop("gss error in mkrk.tp: mismatched inputs") } if ((min(weight)<0)|(max(weight)<=0)) { stop("gss error in mkrk.tp: negative weights") } ## Set weights if (is.vector(mesh)) N <- length(mesh) else N <- dim(mesh)[1] weight <- rep(weight,len=N) weight <- sqrt(weight/sum(weight)) ## Obtain orthonormal basis phi.p <- mkphi.tp.p(dm,order) nnull <- choose(dm+order-1,dm) s <- NULL for (nu in 1:nnull) s <- cbind(s,phi.p$fun(mesh,nu,phi.p$env)) s <- qr(weight*s) if (s$rankdm)&(dm>=1))) { stop("gss error: thin-plate spline undefined for the parameters") } if (xor(is.vector(mesh),dm==1) |xor(is.matrix(mesh),dm>=2)) { stop("gss error in mkphi.tp: mismatched inputs") } if ((min(weight)<0)|(max(weight)<=0)) { stop("gss error in mkphi.tp: negative weights") } ## Set weights if (is.vector(mesh)) N <- length(mesh) else N <- dim(mesh)[1] weight <- rep(weight,len=N) weight <- sqrt(weight/sum(weight)) ## Create the environment phi.p <- mkphi.tp.p(dm,order) nnull <- choose(dm+order-1,dm) s <- NULL for (nu in 1:nnull) s <- cbind(s,phi.p$fun(mesh,nu,phi.p$env)) s <- qr(weight*s) if (s$rankdm)&(dm>=1))) { stop("gss error: thin-plate spline undefined for the parameters") } ## Create the environment if (dm%%2) { theta <- gamma(dm/2-order)/2^(2*order)/pi^(dm/2)/gamma(order) } else { theta <- (-1)^(dm/2+order+1)/2^(2*order-1)/pi^(dm/2)/ gamma(order)/gamma(order-dm/2+1) } env <- list(dim=dm,order=order,theta=theta) ## Create the rk.p function fun <- function(x,y,env,outer.prod=FALSE) { ## Check inputs if (env$dim==1) { if (!(is.vector(x)&is.vector(y))) { stop("gss error in rk: inputs are of wrong types") } } else { if (is.vector(x)) x <- t(as.matrix(x)) if (env$dim!=dim(x)[2]) { stop("gss error in rk: inputs are of wrong dimensions") } if (is.vector(y)) y <- t(as.matrix(y)) if (env$dim!=dim(y)[2]) { stop("gss error in rk: inputs are of wrong dimensions") } } ## Return the results if (outer.prod) { if (env$dim==1) { fn1 <- function(x,y) abs(x-y) d <- outer(x,y,fn1) } else { fn2 <- function(x,y) sqrt(sum((x-y)^2)) d <- NULL for (i in 1:dim(y)[1]) d <- cbind(d,apply(x,1,fn2,y[i,])) } } else { if (env$dim==1) d <- abs(x-y) else { N <- max(dim(x)[1],dim(y)[1]) x <- t(matrix(t(x),env$dim,N)) y <- t(matrix(t(y),env$dim,N)) fn <- function(x) sqrt(sum(x^2)) d <- apply(x-y,1,fn) } } power <- 2*env$order-env$dim switch(1+env$dim%%2, env$theta*d^power*log(ifelse(d>0,d,1)), env$theta*d^power) } ## Return the function and the environment list(fun=fun,env=env) } ## Make pseudo phi function for thin-plate splines mkphi.tp.p <- function(dm,order) { ## Check inputs if (!((2*order>dm)&(dm>=1))) { stop("gss error: thin-plate spline undefined for the parameters") } ## Create the environment pol.code <- NULL for (i in 0:(order^dm-1)) { ind <- i; code <- NULL for (j in 1:dm) { code <- c(code,ind%%order) ind <- ind%/%order } if (sum(code)90)|(max(abs(x[,2]),abs(y[,2]))>180)) { stop("gss error in rk: inputs are out of range") } ##% Convert to radian lat.x <- x[,1]/180*pi; lon.x <- x[,2]/180*pi lat.y <- y[,1]/180*pi; lon.y <- y[,2]/180*pi ##% Return the result rk <- function(lat.x,lon.x,lat.y,lon.y,order) { z <- cos(lat.x)*cos(lat.y)*cos(lon.x-lon.y)+sin(lat.x)*sin(lat.y) W <- ifelse(z<1-10^(-10),(1-z)/2,0) A <- ifelse(W>0,log(1+1/sqrt(W)),0) C <- ifelse(W>0,2*sqrt(W),0) switch(order-1, (A*4*W*(3*W-1)+6*W*(1-C)+1)/2, (W*W*(A*((840*W-720)*W+72)+420*W*(1-C)+220*C-150)-4*W+3)/12, (W*W*W*(A*(((27720*W-37800)*W+12600)*W-600)+ (13860*(1-C)*W+14280*C-11970)*W-2772*C+1470)+ 15*W*W-3*W+5)/30) - 1/(2*order-1) } if (outer.prod) { zz <- NULL for (i in 1:length(lat.y)) zz <- cbind(zz,rk(lat.x,lon.x,lat.y[i],lon.y[i],env$order)) } else zz <- rk(lat.x,lon.x,lat.y,lon.y,env$order) zz } ## Return the function and the environment list(fun=fun,env=env) } gss/R/sshzd.R0000644000176200001440000006174114467014220012536 0ustar liggesusers## Fit hazard model sshzd <- function(formula,type=NULL,data=list(),alpha=1.4, weights=NULL,subset,offset,na.action=na.omit, partial=NULL,id.basis=NULL,nbasis=NULL,seed=NULL, random=NULL,prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Local functions handling formula Surv <- function(time,status,start=0) { tname <- as.character(as.list(match.call())$time) if (!is.numeric(time)|!is.vector(time)) stop("gss error in sshzd: time should be a numerical vector") if ((nobs <- length(time))-length(status)) stop("gss error in sshzd: time and status mismatch in size") if ((length(start)-nobs)&(length(start)-1)) stop("gss error in sshzd: time and start mismatch in size") if (any(start>time)) stop("gss error in sshzd: start after follow-up time") if (min(start)<0) stop("gss error in sshzd: start before time 0") time <- cbind(start,time) list(tname=tname,start=time[,1],end=time[,2],status=as.logical(status)) } ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$alpha <- mf$random <- mf$partial <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ## response resp <- attr(term.wk,"variable")[[2]] ind.wk <- length(strsplit(deparse(resp),'')[[1]]) if ((substr(deparse(resp),1,5)!='Surv(') |(substr(deparse(resp),ind.wk,ind.wk)!=')')) stop("gss error in sshzd: response should be Surv(...)") yy <- with(data,eval(resp)) tname <- yy$tname ## model frame term.labels <- attr(term.wk,"term.labels") if (!(tname%in%term.labels)) stop("gss error in sshzd: time main effect missing in model") mf[[1]] <- as.name("model.frame") mf[[2]] <- eval(parse(text=paste("~",paste(term.labels,collapse="+")))) mf <- eval(mf,parent.frame()) offset <- model.offset(mf) mf$"(offset)" <- NULL ## trim yy if subset is used nobs <- nrow(mf) if (nobssum(yy$status)) nbasis <- sum(yy$status) if (!is.null(seed)) set.seed(seed) id.basis <- sample((1:nobs)[yy$status],nbasis,prob=cnt[yy$status]) } else { if (!all(id.basis%in%(1:nobs)[yy$status])) stop("gss error in sshzd: id.basis not all at failure cases") nbasis <- length(id.basis) } id.wk <- NULL nT <- sum(yy$status) for (i in 1:nbasis) { id.wk <- c(id.wk,(1:nT)[(1:nobs)[yy$status]%in%id.basis[i]]) } ## set domain and type for time mn <- min(yy$start) mx <- max(yy$end) tdomain <- c(max(mn-.05*(mx-mn),0),mx) if (is.null(type[[tname]])) type[[tname]] <- list("cubic",tdomain) if (length(type[[tname]])==1) type[[tname]] <- c(type[[tname]],tdomain) if (!(type[[tname]][[1]]%in%c("cubic","linear"))) stop("gss error in sshzd: wrong type") if ((min(type[[tname]][[2]])>min(tdomain))| (max(type[[tname]][[2]])yy$start[i]) if (!is.null(offset)) wk <- wk*exp(offset[i]) if (is.null(cnt)) qd.wt[,x.ind[i]] <- qd.wt[,x.ind[i]]+wk else qd.wt[,x.ind[i]] <- qd.wt[,x.ind[i]]+cnt[i]*wk } if (is.null(cnt)) qd.wt <- quad$wt*qd.wt/nobs else qd.wt <- quad$wt*qd.wt/sum(cnt) ## Generate s and r s <- r <- qd.s <- NULL qd.r <- as.list(NULL) nq <- nu <- 0 for (label in term$labels) { if (label=="1") { nu <- nu+1 s <- cbind(s,rep(1,len=nT)) qd.wk <- matrix(1,nmesh,nx) qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) next } vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] xy <- mf[yy$status,vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist if (tname%in%vlist) qd.xy[,tname] <- quad$pt if (length(x.list)) xx <- x.pt[,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { nu <- nu+1 s <- cbind(s,phi$fun(xy,nu=i,env=phi$env)) if (is.null(xx)) qd.wk <- matrix(phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env),nmesh,nx) else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- cbind(qd.wk,phi$fun(qd.xy[,,drop=TRUE],i,phi$env)) } } qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE)),c(nT,nbasis,nq)) if (is.null(xx)) qd.r[[nq]] <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,out=TRUE) else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- array(c(qd.wk,rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,TRUE)), c(nmesh,nbasis,j)) } qd.r[[nq]] <- qd.wk } } } } ## Add the partial term if (!is.null(partial)) { s <- cbind(s,matx.p[yy$status,]) nu.p <- dim(matx.p)[2] qd.wk <- aperm(array(matx.p[!x.dup.ind,],c(nx,nu.p,nmesh)),c(3,1,2)) nu <- nu + nu.p qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) part$pt <- matx.p[!x.dup.ind,,drop=FALSE] } ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rankalpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.s.wk <- function(lambda) cv.scale*cv.s(lambda)+cv.shift cv.m <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 qd.r.wk0 <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + 10^theta[i]*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(10^theta[i]*qd.r[[i]]) } assign("r.wk",r.wk0+0,inherits=TRUE) assign("qd.r.wk",qd.r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk qd.r.wk0 <- qd.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + theta.wk*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(theta.wk*qd.r[[i]]) } } q.wk <- r.wk0[id.wk,] if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { r.wk0 <- cbind(r.wk0,10^ran.scal*random$z) q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(theta[-(1:nq)],random$sigma$env) } qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) if (!is.null(random)) { qd.r.wk0 <- array(c(qd.r.wk0,qd.z.wk),c(nqd,nx,nxiz)) } qd.r.wk0 <- array(c(qd.r.wk0,qd.s),c(nqd,nx,nn)) qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) fit <- .Fortran("hzdnewton", cd=as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(t(cbind(r.wk0,s))), as.integer(nT), as.integer(Nobs), as.double(sum(cnt)), as.double(cnt), as.double(qd.r.wk0), as.integer(nqd), as.double(qd.wt), as.integer(nx), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*(nqd*nx+nT)+nn*(2*nn+4)+max(nn,2)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in sshzd: Newton iteration diverges") if (fit$info==2) warning("gss warning in sshzd: Newton iteration fails to converge") assign("cd",fit$cd,inherits=TRUE) assign("mesh0",matrix(fit$wk[max(nn,2)+(1:(nqd*nx))],nqd,nx),inherits=TRUE) cv <- alpha*fit$wk[2]-fit$wk[1] alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.m.wk <- function(theta) cv.scale*cv.m(theta)+cv.shift ## Initialization theta <- -log10(apply(r[id.wk,,,drop=FALSE],3,function(x)sum(diag(x)))) nq <- length(theta) qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } v.s <- v.r <- 0 for (i in 1:nx) { if (nnull) v.s <- v.s + apply(qd.wt[,i]*qd.s[,i,,drop=FALSE]^2,2,sum) v.r <- v.r + apply(qd.wt[,i]*qd.r.wk[,,i,drop=FALSE]^2,2,sum) } if (nnull) theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 else theta.wk <- 0 if (!is.null(random)) { v.z <- apply(apply(qd.wt,2,sum)*random$qd.z^2,2,sum) ran.scal <- theta.wk - log10(sum(v.z)/nz/sum(v.r)*nxi) / 2 qd.z.wk <- aperm(array(10^ran.scal*random$qd.z,c(nx,nz,nqd)),c(3,1,2)) } else ran.scal <- NULL theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,qd.z.wk),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.wk,] if (!is.null(random)) r.wk <- cbind(r.wk,10^ran.scal*random$z) log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk ## fixed theta iteration mesh0 <- NULL cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (nq==1) { if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("hzdaux1", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.double(qd.wt), as.integer(nx), as.double(.Machine$double.eps), double(nqd*nx), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,mesh0=mesh0,se.aux=se.aux)) } ## theta adjustment qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(cd[1:nxi])%*%r[id.wk,,i]%*%cd[1:nxi]) if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } v.s <- v.r <- 0 for (i in 1:nx) { if (nnull) v.s <- v.s + apply(qd.wt[,i]*qd.s[,i,,drop=FALSE]^2,2,sum) v.r <- v.r + apply(qd.wt[,i]*qd.r.wk[,,i,drop=FALSE]^2,2,sum) } if (nnull) theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 else theta.wk <- 0 if (!is.null(random)) { v.z <- apply(apply(qd.wt,2,sum)*random$qd.z^2,2,sum) ran.scal <- theta.wk - log10(sum(v.z)/nz/sum(v.r)*nxi) / 2 qd.z.wk <- aperm(array(10^ran.scal*random$qd.z,c(nx,nz,nqd)),c(3,1,2)) } else ran.scal <- NULL theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,qd.z.wk),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.wk,] if (!is.null(random)) r.wk <- cbind(r.wk,10^ran.scal*random$z) log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk log.th0 <- theta-log.la0 ## fixed theta iteration cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } ## early return if (skip.iter) { if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("hzdaux1", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.double(qd.wt), as.integer(nx), as.double(.Machine$double.eps), double(nqd*nx), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,mesh0=mesh0,se.aux=se.aux)) } ## theta search counter <- 0 r.wk <- 0 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } theta.old <- theta if (!is.null(random)) theta <- c(theta,zeta) tmp <- abs(cv.m(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.m.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd: CV iteration fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale if (is.null(random)) { theta <- zz$est zeta <- NULL } else { theta <- zz$est[1:nq] zeta <- zz$est[-(1:nq)] } ## return q.wk <- 0 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { q.wk <- q.wk + 10^theta[i]*r[id.wk,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,qd.z.wk),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) se.aux <- .Fortran("hzdaux1", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.double(qd.wt), as.integer(nx), as.double(.Machine$double.eps), double(nqd*nx), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,mesh0=mesh0,se.aux=se.aux)) } gss/R/summary.gssanova0.R0000644000176200001440000001065713511661117015002 0ustar liggesusers## Summarize gssanova objects summary.gssanova0 <- function(object,diagnostics=FALSE,...) { if (object$family=="polr") { y <- model.response(object$mf) if (!is.factor(y)) stop("gss error in gssanova1: need factor response for polr family") lvls <- levels(y) if (nlvl <- length(lvls)<3) stop("gss error in gssanova1: need at least 3 levels to fit polr family") y <- outer(y,lvls,"==") } else y <- model.response(object$mf,"numeric") wt <- model.weights(object$mf) offset <- model.offset(object$mf) if ((object$family=="nbinomial")&(!is.null(object$nu))) y <- cbind(y,object$nu) dev.resid <- switch(object$family, binomial=dev.resid.binomial(y,object$eta,wt), nbinomial=dev.resid.nbinomial(y,object$eta,wt), polr=dev.resid.polr(y,object$eta,wt,object$nu), poisson=dev.resid.poisson(y,object$eta,wt), inverse.gaussian=dev.resid.inverse.gaussian(y,object$eta,wt), Gamma=dev.resid.Gamma(y,object$eta,wt), weibull=dev.resid.weibull(y,object$eta,wt,object$nu), lognorm=dev.resid.lognorm(y,object$eta,wt,object$nu), loglogis=dev.resid.loglogis(y,object$eta,wt,object$nu)) dev.null <- switch(object$family, binomial=dev.null.binomial(y,wt,offset), nbinomial=dev.null.nbinomial(y,wt,offset), polr=dev.null.polr(y,wt,offset), poisson=dev.null.poisson(y,wt,offset), inverse.gaussian=dev.null.inverse.gaussian(y,wt,offset), Gamma=dev.null.Gamma(y,wt,offset), weibull=dev.null.weibull(y,wt,offset,object$nu), lognorm=dev.null.lognorm(y,wt,offset,object$nu), loglogis=dev.null.loglogis(y,wt,offset,object$nu)) w <- object$w if (is.null(offset)) offset <- rep(0,length(object$eta)) ## Residuals res <- 10^object$nlambda*object$c ## Fitted values fitted <- object$eta fitted.off <- fitted-offset ## dispersion sigma2 <- object$varht ## RSS, deviance rss <- sum(res^2) dev <- sum(dev.resid) ## Penalty associated with the fit penalty <- sum(object$c*fitted.off*sqrt(w)) penalty <- as.vector(10^object$nlambda*penalty) ## Calculate the diagnostics if (diagnostics) { ## Obtain retrospective linear model comp <- NULL for (label in object$terms$labels) { if (label=="1") next if (label=="offset") next comp <- cbind(comp,predict(object,object$mf,inc=label)) } comp <- cbind(comp,yhat=fitted.off,y=fitted.off+res/sqrt(w),e=res/sqrt(w)) term.label <- object$terms$labels[object$terms$labels!="1"] term.label <- term.label[term.label!="offset"] colnames(comp) <- c(term.label,"yhat","y","e") ## Sweep out constant comp <- sqrt(w)*comp - outer(sqrt(w),apply(w*comp,2,sum))/sum(w) ## Obtain pi comp1 <- comp[,c(term.label,"yhat")] decom <- t(comp1) %*% comp1[,"yhat"] names(decom) <- c(term.label,"yhat") decom <- decom[term.label]/decom["yhat"] ## Obtain kappa, norm, and cosines corr <- t(comp)%*%comp corr <- t(corr/sqrt(diag(corr)))/sqrt(diag(corr)) norm <- apply(comp,2,function(x){sqrt(sum(x^2))}) cosines <- rbind(corr[c("y","e"),],norm) rownames(cosines) <- c("cos.y","cos.e","norm") corr <- corr[term.label,term.label,drop=FALSE] if (qr(corr)$rank=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=wt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in ssanova: id.basis out of range") nbasis <- length(id.basis) } ## Generate terms term <- mkterm(mf,type) ## Generate random if (!is.null(random)) { if (inherits(random,"formula")) random <- mkran(random,data) } ## Generate s, r, and y s <- r <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nobs)) next } x <- mf[,term[[label]]$vlist] x.basis <- mf[id.basis,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(x,x.basis,nu=i,env=rk$env,out=TRUE)),c(nobs,nbasis,nq)) } } } if (is.null(r)) stop("gss error in ssanova: use lm for models with only unpenalized terms") ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in ssanova: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL if (qr(s)$rankalpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*varht*trc if (method=="v") score <- rss/(1-alpha.wk*trc)^2 } if (return.fit) { z <- .Fortran("reg", as.double(cbind(s,10^theta*r)), as.integer(nobs), as.integer(nnull), as.double(q.wk), as.integer(nxiz), as.double(y), as.integer(switch(method,"u"=1,"v"=2,"m"=3)), as.double(alpha), varht=as.double(varht), score=double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxiz))), wk=double(3*nobs+nnull+nz), rkv=integer(1), info=integer(1), PACKAGE="gss")[c("score","varht","dc","chol","jpvt","wk","rkv","info")] z$score <- score assign("fit",z[c(1:5,7)],inherits=TRUE) } } else { z <- .Fortran("reg", as.double(cbind(s,10^theta*r)), as.integer(nobs), as.integer(nnull), as.double(q.wk), as.integer(nxiz), as.double(y), as.integer(switch(method,"u"=1,"v"=2,"m"=3)), as.double(alpha), varht=as.double(varht), score=double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxiz))), wk=double(3*nobs+nnull+nz), rkv=integer(1), info=integer(1), PACKAGE="gss")[c("score","varht","dc","chol","jpvt","wk","rkv","info")] if (z$info) stop("gss error in ssanova: evaluation of GML score fails") assign("fit",z[c(1:5,7)],inherits=TRUE) score <- z$score alpha.wk <- max(0,log.la0-lambda[1]-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) if (alpha.wk>alpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*varht*z$wk[2] if (method=="v") score <- z$wk[1]/(1-alpha.wk*z$wk[2])^2 } } score } cv.wk <- function(lambda) cv.scale*cv(lambda)+cv.shift ## initialization tmp <- sum(r^2) if (is.null(s)) theta <- 0 else theta <- log10(sum(s^2)/nnull/tmp*nxi) / 2 log.la0 <- log10(tmp/sum(diag(q))) + theta if (!is.null(random)) { ran.scal <- theta - log10(sum(random$z^2)/nz/tmp*nxi) / 2 r <- cbind(r,10^(ran.scal-theta)*random$z) } else ran.scal <- NULL ## lambda search return.fit <- FALSE fit <- NULL if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssanova: iteration for model selection fails to converge") break } } } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } } ## return return.fit <- TRUE jk1 <- cv(zz$est) if (is.null(random)) q.wk <- 10^theta*q else { q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- 10^theta*q q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal-zz$est[1])*random$sigma$fun(zz$est[-1],random$sigma$env) } se.aux <- regaux(s,10^theta*r,q.wk,zz$est[1],fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL if (nz) b <- 10^(ran.scal)*fit$dc[nnull+nxi+(1:nz)] else b <- NULL c(list(method=method,theta=theta,ran.scal=ran.scal,c=c,d=d,b=b, nlambda=zz$est[1],zeta=zz$est[-1]),fit[-3],list(se.aux=se.aux)) } ## Fit Multiple Smoothing Parameter (Gaussian) REGression mspreg1 <- function(s,r,id.basis,y,wt,method,alpha,varht,random,skip.iter) { qr.trace <- FALSE if ((alpha<0)&(method%in%c("u","v"))) qr.trace <- TRUE alpha <- abs(alpha) ## get dimensions nobs <- nrow(r) nxi <- ncol(r) if (!is.null(s)) { if (is.vector(s)) nnull <- 1 else nnull <- ncol(s) } else nnull <- 0 if (!is.null(random)) nz <-ncol(as.matrix(random$z)) else nz <- 0 nxiz <- nxi + nz nn <- nxiz + nnull nq <- dim(r)[3] ## cv function cv <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] } } qq.wk <- r.wk0[id.basis,] if (is.null(random)) q.wk <- 10^nlambda*qq.wk else { r.wk0 <- cbind(r.wk0,10^(ran.scal)*random$z) q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- 10^nlambda*qq.wk q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(theta[-(1:nq)],random$sigma$env) } if (!is.null(wt)) { y.wk <- wt*y s.wk <- wt*s r.wk0 <- wt*r.wk0 } if (qr.trace) { suppressWarnings(qq.wk <- chol(q.wk,pivot=TRUE)) sr <- cbind(s.wk,r.wk0[,attr(qq.wk,"pivot")]) sr <- rbind(sr,cbind(matrix(0,nxiz,nnull),qq.wk)) sr <- qr(sr,tol=0) rss <- mean(qr.resid(sr,c(y.wk,rep(0,nxiz)))[1:nobs]^2) trc <- sum(qr.Q(sr)[1:nobs,]^2)/nobs if (method=="u") score <- rss + alpha*2*varht*trc if (method=="v") score <- rss/(1-alpha*trc)^2 alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) if (alpha.wk>alpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*varht*trc if (method=="v") score <- rss/(1-alpha.wk*trc)^2 } if (return.fit) { z <- .Fortran("reg", as.double(cbind(s.wk,r.wk0)), as.integer(nobs), as.integer(nnull), as.double(q.wk), as.integer(nxiz), as.double(y.wk), as.integer(switch(method,"u"=1,"v"=2,"m"=3)), as.double(alpha), varht=as.double(varht), score=double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxiz))), wk=double(3*nobs+nnull+nz), rkv=integer(1), info=integer(1), PACKAGE="gss")[c("score","varht","dc","chol","jpvt","wk","rkv","info")] z$score <- score assign("fit",z[c(1:5,7)],inherits=TRUE) } } else { z <- .Fortran("reg", as.double(cbind(s.wk,r.wk0)), as.integer(nobs), as.integer(nnull), as.double(q.wk), as.integer(nxiz), as.double(y.wk), as.integer(switch(method,"u"=1,"v"=2,"m"=3)), as.double(alpha), varht=as.double(varht), score=double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxiz))), wk=double(3*nobs+nnull+nz), rkv=integer(1), info=integer(1), PACKAGE="gss")[c("score","varht","dc","chol","jpvt","wk","rkv","info")] if (z$info) stop("gss error in ssanova: evaluation of GML score fails") assign("fit",z[c(1:5,7)],inherits=TRUE) score <- z$score alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) if (alpha.wk>alpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*varht*z$wk[2] if (method=="v") score <- z$wk[1]/(1-alpha.wk*z$wk[2])^2 } } score } cv.wk <- function(theta) cv.scale*cv(theta)+cv.shift ## initialization theta <- -log10(apply(r[id.basis,,],3,function(x)sum(diag(x)))) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } ## theta adjustment return.fit <- FALSE z <- sspreg1(s,r.wk,r.wk[id.basis,],y,wt,method,alpha,varht,random) theta <- theta + z$theta r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(z$c)%*%r[id.basis,,i]%*%z$c) r.wk <- r.wk + 10^theta[i]*r[,,i] } if (!is.null(wt)) q.wk <- wt*r.wk else q.wk <- r.wk log.la0 <- log10(sum(q.wk^2)/sum(diag(r.wk[id.basis,]))) log.th0 <- theta-log.la0 ## lambda search z <- sspreg1(s,r.wk,r.wk[id.basis,],y,wt,method,alpha,varht,random) nlambda <- z$nlambda log.th0 <- log.th0 + z$nlambda theta <- theta + z$theta if (!is.null(random)) ran.scal <- z$ran.scal ## early return if (skip.iter) { z$theta <- theta return(z) } ## theta search fit <- NULL counter <- 0 y.wk <- y s.wk <- s r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } theta.old <- theta if (!is.null(random)) theta <- c(theta,z$zeta) ## scale and shift cv tmp <- abs(cv(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssanova: iteration for model selection fails to converge") break } } ## return return.fit <- TRUE jk1 <- cv(zz$est) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^zz$est[i]*r[,,i] } qq.wk <- r.wk[id.basis,] if (is.null(random)) q.wk <- qq.wk else { r.wk <- cbind(r.wk,10^(ran.scal)*random$z) q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- qq.wk q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal-nlambda)*random$sigma$fun(zz$est[-(1:nq)],random$sigma$env) } if (!is.null(wt)) { s <- wt*s r.wk <- wt*r.wk } se.aux <- regaux(s,r.wk,q.wk,nlambda,fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL if (nz) b <- 10^(ran.scal)*fit$dc[nnull+nxi+(1:nz)] else b <- NULL c(list(method=method,theta=zz$est[1:nq],c=c,d=d,b=b,nlambda=nlambda, zeta=zz$est[-(1:nq)]),fit[-3],list(se.aux=se.aux)) } ## Auxiliary Quantities for Standard Error Calculation regaux <- function(s,r,q,nlambda,fit) { nnull <- dim(s)[2] nn <- nnull + dim(q)[1] zzz <- eigen(q,symmetric=TRUE) rkq <- min(fit$rkv-nnull,sum(zzz$val/zzz$val[1]>sqrt(.Machine$double.eps))) val <- zzz$val[1:rkq] vec <- zzz$vec[,1:rkq,drop=FALSE] if (nnull) { wk1 <- qr(s) wk1 <- (qr.qty(wk1,r%*%vec))[-(1:nnull),] } else wk1 <- r%*%vec wk2 <- t(t(wk1)/sqrt(val)) wk2 <- t(wk2)%*%wk2 wk2 <- solve(wk2+diag(10^nlambda,dim(wk2)[1]),wk2) wk2 <- (wk2+t(wk2))/2 wk2 <- t(wk2/sqrt(val))/sqrt(val) wk2 <- diag(1/val,dim(wk2)[1])-wk2 z <- .Fortran("regaux", as.double(fit$chol), as.integer(nn), as.integer(fit$jpvt), as.integer(fit$rkv), drcr=as.double(t(cbind(s,r))%*%r%*%vec), as.integer(rkq), sms=double(nnull^2), as.integer(nnull), double(nn*nnull), PACKAGE="gss")[c("drcr","sms")] drcr <- matrix(z$drcr,nn,rkq) dr <- drcr[1:nnull,,drop=FALSE] sms <- 10^nlambda*matrix(z$sms,nnull,nnull) wk1 <- matrix(0,nnull+rkq,nnull+rkq) wk1[1:nnull,1:nnull] <- sms wk1[1:nnull,nnull+(1:rkq)] <- -t(t(dr)/val) wk1[nnull+(1:rkq),nnull+(1:rkq)] <- wk2 suppressWarnings(z <- chol(wk1,pivot=TRUE)) wk1 <- z rkw <- attr(z,"rank") while (wk1[rkw,rkw]col(wk1)] <- 0 if (rkw=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in sscden1: id.basis out of range") nbasis <- length(id.basis) } ## Check inputs mt <- attr(mf,"terms") vars <- as.character(attr(mt,"variables"))[-1] if(!all(ynames%in%vars)) stop("gss error in sscden1: response missing in model") xnames <- vars[!(vars%in%ynames)] if (is.null(xnames)) stop("gss error in sscden1: missing covariate") ## Set type for given ydomain fac.list <- NULL for (ylab in ynames) { y <- mf[[ylab]] if (is.factor(y)) { fac.list <- c(fac.list,ylab) ydomain[[ylab]] <- NULL } else { if (!is.vector(y)&is.null(yquad)) stop("gss error in sscden1: no default quadrature") if (is.vector(y)) { if (is.null(ydomain[[ylab]])) { mn <- min(y) mx <- max(y) ydomain[[ylab]] <- c(mn,mx)+c(-1,1)*(mx-mn)*.05 } else ydomain[[ylab]] <- c(min(ydomain[[ylab]]),max(ydomain[[ylab]])) if (is.null(type[[ylab]])) type[[ylab]] <- list("cubic",ydomain[[ylab]]) else { if (length(type[[ylab]])==1) type[[ylab]] <- list(type[[ylab]][[1]],ydomain[[ylab]]) } } } } ## Generate terms term <- mkterm(mf,type) term$labels <- term$labels[term$labels!="1"] ## obtain unique covariate observations x <- xx <- mf[,xnames,drop=FALSE] xx <- apply(xx,1,function(x)paste(x,collapse="\r")) x.dup.ind <- duplicated(xx) if (!is.null(cnt)) xx <- rep(xx,cnt) xx.wt <- as.vector(table(xx)[unique(xx)]) xx.wt <- xx.wt/sum(xx.wt) nx <- length(xx.wt) ## calculate rho if (is.null(rho$fun)) { type <- rho[[1]] if (type=="y") { yfac <- TRUE for (ylab in ynames) yfac <- yfac&is.factor(mf[,ylab]) if (!yfac) { if (is.null(cnt)) cntt <- rep(1,dim(mf)[1]) rho <- ssden(response,data=data,weights=cnt,id.basis=id.basis, alpha=2,domain=ydomain,quad=yquad) qd.pt <- rho$quad$pt qd.wt <- rho$quad$wt env <- list(ydomain=ydomain,qd.pt=qd.pt,qd.wt=qd.wt,rho=rho) fun <- function(x,y,env,outer.prod=FALSE) { if (!outer.prod) dssden(env$rho,y) else t(matrix(dssden(env$rho,y),dim(y)[1],dim(x)[1])) } } else { qd.pt <- data.frame(levels(mf[,ynames[1]]),stringsAsFactors=TRUE) if (length(ynames)>1) { for (ylab in ynames[-1]) { wk <- expand.grid(levels(mf[,ylab]),1:dim(qd.pt)[1]) qd.pt <- data.frame(qd.pt[wk[,2],],wk[,1],stringsAsFactors=TRUE) } } colnames(qd.pt) <- ynames qd.wt <- as.vector(table(mf[,rev(ynames)])) qd.wt <- qd.wt/sum(qd.wt) env <- list(qd.pt=qd.pt,qd.wt=qd.wt) fun <- function(x,y,env,outer.prod=FALSE) { if (!outer.prod) rep(1,dim(x)[1]) else matrix(1,dim(x)[1],dim(y)[1]) } } rho <- list(fun=fun,env=env) } if (type=="xy") { ydomain <- data.frame(ydomain) mn <- ydomain[1,] mx <- ydomain[2,] dm <- ncol(ydomain) if (dm==1) { ## Gauss-Legendre quadrature quad <- gauss.quad(200,c(mn,mx)) quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- colnames(ydomain) } else { ## Smolyak cubature qdsz.depth <- switch(min(dm,6)-1,18,14,10,9,7) quad <- smolyak.quad(dm,qdsz.depth) for (i in 1:ncol(ydomain)) { ylab <- colnames(ydomain)[i] wk <- mf[[ylab]] jk <- ssden(~wk,domain=data.frame(wk=ydomain[,i]),alpha=2, id.basis=id.basis,weights=cnt) quad$pt[,i] <- qssden(jk,quad$pt[,i]) quad$wt <- quad$wt/dssden(jk,quad$pt[,i]) } jk <- wk <- NULL quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- colnames(ydomain) } ## Incorporate factors in quadrature if (!is.null(fac.list)) { for (i in 1:length(fac.list)) { wk <- expand.grid(levels(mf[[fac.list[i]]]),1:length(quad$wt)) quad$wt <- quad$wt[wk[,2]] col.names <- c(fac.list[i],colnames(quad$pt)) quad$pt <- data.frame(wk[,1],quad$pt[wk[,2],],stringsAsFactors=TRUE) colnames(quad$pt) <- col.names } } rho <- list(NULL) for (ylab in ynames) { if (is.numeric(mf[[ylab]])) { form <- as.formula(paste(ylab,"~",paste(xnames,collapse="+"))) rho[[ylab]] <- ssanova(form,data=mf,id.basis=id.basis) } if (is.factor(mf[[ylab]])) { form <- as.formula(paste("~(",paste(xnames,collapse="+"),")*",ylab)) resp <- as.formula(paste("~",ylab)) rho[[ylab]] <- ssllrm(form,resp,data=mf,id.basis=id.basis) } } env <- list(ynames=ynames,ydomain=ydomain,qd.pt=quad$pt,qd.wt=quad$wt,rho=rho) fun <- function(x,y,env,outer.prod=FALSE) { z <- 1 for (ylab in env$ynames) { yy <- y[[ylab]] if (is.numeric(yy)) { mu <- predict(env$rho[[ylab]],x) sigma <- sqrt(env$rho[[ylab]]$varht) ymn <- env$ydomain[1,ylab] ymx <- env$ydomain[2,ylab] if (!outer.prod) { wk <- dnorm((yy-mu)/sigma)/ (pnorm((ymx-mu)/sigma)-pnorm((ymn-mu)/sigma)) z <- z*wk } else { wk <- t(outer(yy,mu,dnorm,sigma))/ (pnorm((ymx-mu)/sigma)-pnorm((ymn-mu)/sigma)) z <- z*wk } } if (is.factor(yy)) { wk <- predict(env$rho[[ylab]],x) if (!outer.prod) { wk1 <- NULL for (i in 1:length(yy)) wk1 <- c(wk1,wk[i,yy[i]==env$rho[[ylab]]$qd.pt]) z <- z*wk1 } else { wk1 <- NULL for (i in 1:length(yy)) wk1 <- cbind(wk1,wk[,yy[i]==env$rho[[ylab]]$qd.pt]) z <- z*wk1 } } } z } rho <- list(fun=fun,env=env) } } ## Generate s, r, int.s, and int.r rho.wk <- rho$fun(x[!x.dup.ind,,drop=FALSE],rho$env$qd.pt,rho$env,outer=TRUE) rho.wk <- t(t(rho.wk)*rho$env$qd.wt) rho.wk1 <- apply(rho.wk*xx.wt,2,sum) nmesh <- length(rho$env$qd.wt) s <- r <- int.s <- int.r <- NULL id.s <- id.r <- NULL id.s.list <- id.r.list <- list(NULL) nu <- nq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] y.list <- ynames[ynames%in%vlist] xy <- mf[,vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- rho$env$qd.pt[,y.list] if (length(x.list)) xx <- x[!x.dup.ind,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi id.s.list[[label]] <- NULL for (i in 1:nphi) { nu <- nu+1 s.wk <- phi$fun(xy,nu=i,env=phi$env) s <- cbind(s,s.wk) if (is.null(xx)) { id.s <- c(id.s,nu) id.s.list[[label]] <- c(id.s.list[[label]],nu) qd.s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) int.s <- c(int.s,sum(qd.s.wk*rho.wk1)) } else { if (length(y.list)==0) { names(xx) <- x.list int.s <- c(int.s,sum(phi$fun(xx[,,drop=TRUE],i,phi$env)*xx.wt)) } else { id.s <- c(id.s,nu) id.s.list[[label]] <- c(id.s.list[[label]],nu) int.s.wk <- 0 for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.s.wk <- phi$fun(qd.xy,i,phi$env) int.s.wk <- int.s.wk + sum(qd.s.wk*rho.wk[j,])*xx.wt[j] } int.s <- c(int.s,int.s.wk) } } } } if (nrk) { rk <- term[[label]]$rk id.r.list[[label]] <- NULL for (i in 1:nrk) { nq <- nq+1 r.wk <- rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE) r <- array(c(r,r.wk),c(nobs,nbasis,nq)) if (is.null(xx)) { id.r <- c(id.r,nq) id.r.list[[label]] <- c(id.r.list[[label]],nq) qd.r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,out=TRUE) int.r <- cbind(int.r,apply(rho.wk1*qd.r.wk,2,sum)) } else { if (length(y.list)==0) { names(xx) <- x.list qd.r.wk <- rk$fun(xx[,,drop=TRUE],xy.basis,i,rk$env,TRUE) int.r <- cbind(int.r,apply(xx.wt*qd.r.wk,2,sum)) } else { id.r <- c(id.r,nq) id.r.list[[label]] <- c(id.r.list[[label]],nq) int.r.wk <- 0 for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.r.wk <- rk$fun(qd.xy,xy.basis,i,rk$env,TRUE) int.r.wk <- int.r.wk + apply(rho.wk[j,]*qd.r.wk,2,sum)*xx.wt[j] } int.r <- cbind(int.r,int.r.wk) } } } } } ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rankalpha,(alpha.wk-alpha)*trc,0) cv+adj } cv.m <- function(theta) { ind.wk <- theta!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- int.r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] int.r.wk0 <- int.r.wk0 + 10^theta[i]*int.r[,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("int.r.wk",int.r.wk0+0,inherits=TRUE) assign("theta.old",theta+0,inherits=TRUE) } else { r.wk0 <- r.wk int.r.wk0 <- int.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] int.r.wk0 <- int.r.wk0 + theta.wk*int.r[,i] } } q.wk <- r.wk0[id.basis,] fit <- .Fortran("cdennewton10", cd=as.double(cd), as.integer(nxis), as.double(10^lambda*q.wk), as.integer(nxi), as.double(cbind(r.wk0,s)), as.integer(nobs), as.double(sum(cnt)), as.double(cnt), as.double(c(int.r.wk0,int.s)), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nxis), wk=double(2*nobs+nxis*(nxis+3)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in sscden1: Newton iteration diverges") if (fit$info==2) warning("gss warning in sscden1: Newton iteration fails to converge") aa <- fit$wk[1:nobs] assign("cd",fit$cd,inherits=TRUE) eta0 <- cbind(r.wk,s)%*%cd wwt <- wt*exp(-eta0) wwt <- wwt/sum(wwt) assign("scal",sum(wt*exp(-eta0)),inherits=TRUE) trc <- sum(wwt*exp(aa/(1-aa)))-1 cv <- sum(c(int.r.wk0,int.s)*cd) + log(scal) + alpha*trc alpha.wk <- max(0,theta-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*trc,0) cv+adj } cv.wk <- function(theta) cv.scale*cv.m(theta)+cv.shift ## Initialization theta <- -log10(apply(r[id.basis,,,drop=FALSE],3,function(x)sum(diag(x)))) nq <- length(theta) r.wk <- int.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } if (!nnull) { mu.r <- apply(wt*r.wk,2,sum) v.r <- apply(wt*r.wk^2,2,sum) v.r <- v.r - mu.r^2 theta.wk <- 0 } else { mu.r <- apply(wt*r.wk,2,sum) v.r <- apply(wt*r.wk^2,2,sum) v.r <- v.r - mu.r^2 mu.s <- apply(wt*s,2,sum) v.s <- apply(wt*s^2,2,sum) v.s <- v.s - mu.s^2 theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 } theta <- theta + theta.wk r.wk <- 10^theta.wk*r.wk int.r.wk <- 10^theta.wk*int.r.wk q.wk <- r.wk[id.basis,] log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk ## fixed theta iteration cd <- rep(0,nxi+nnull) scal <- NULL la <- log.la0 mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } if (nq==1) { lambda <- zz$est c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL return(list(lambda=lambda,theta=theta,c=c,d=d,cv=zz$min,scal=scal)) } ## theta adjustment r.wk <- int.r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(cd[1:nxi])%*%r[id.basis,,i]%*%cd[1:nxi]) r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } if (!nnull) { mu.r <- apply(wt*r.wk,2,sum) v.r <- apply(wt*r.wk^2,2,sum) v.r <- v.r - mu.r^2 theta.wk <- 0 } else { mu.r <- apply(wt*r.wk,2,sum) v.r <- apply(wt*r.wk^2,2,sum) v.r <- v.r - mu.r^2 mu.s <- apply(wt*s,2,sum) v.s <- apply(wt*s^2,2,sum) v.s <- v.s - mu.s^2 theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 } theta <- theta + theta.wk r.wk <- 10^theta.wk*r.wk int.r.wk <- 10^theta.wk*int.r.wk q.wk <- r.wk[id.basis,] log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk log.th0 <- theta-log.la0 ## fixed theta iteration cd <- rep(0,nxi+nnull) la <- log.la0 mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } lambda <- zz$est ## early return if (skip.iter) { c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL return(list(lambda=lambda,theta=theta,c=c,d=d,cv=zz$min,scal=scal)) } ## theta search counter <- 0 r.wk <- int.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } theta.old <- theta tmp <- abs(cv.m(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sscden1: CV iteration fails to converge") break } } ## return c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL cv <- (zz$min-cv.shift)/cv.scale list(lambda=lambda,theta=zz$est,c=c,d=d,cv=cv,scal=scal) } gss/R/dsscden.R0000644000176200001440000001775613626324656013052 0ustar liggesusersdsscden <- ## Evaluate conditional density estimate function (object,y,x) { ## check input if (!("sscden"%in%class(object))) stop("gss error in dsscden: not a sscden object") if (!all(sort(object$xnames)==sort(colnames(x)))) stop("gss error in dsscden: mismatched x variable names") if (length(object$ynames)==1&is.vector(y)) { y <- data.frame(y,stringsAsFactors=TRUE) colnames(y) <- object$ynames } if (!all(sort(object$ynames)==sort(colnames(y)))) stop("gss error in dsscden: mismatched y variable names") if ("sscden1"%in%class(object)) { qd.pt <- object$rho$env$qd.pt qd.wt <- object$rho$env$qd.wt d.qd <- d.sscden1(object,x,qd.pt,scale=FALSE) int <- apply(d.qd*qd.wt,2,sum) return(t(t(d.sscden1(object,x,y,scale=FALSE))/int)) } else { qd.pt <- object$yquad$pt qd.wt <- object$yquad$wt d.qd <- d.sscden(object,x,qd.pt) int <- apply(d.qd*qd.wt,2,sum) return(t(t(d.sscden(object,x,y))/int)) } } psscden <- ## Compute cdf for univariate density estimate function(object,q,x) { if (!("sscden"%in%class(object))) stop("gss error in psscden: not a sscden object") if (length(object$ynames)!=1) stop("gss error in psscden: y is not 1-D") if (("sscden1"%in%class(object))&!is.numeric(object$mf[,object$ynames])) stop("gss error in qssden: y is not continuous") if ("sscden1"%in%class(object)) ydomain <- object$rho$env$ydomain else ydomain <- object$ydomain mn <- min(ydomain[[object$ynames]]) mx <- max(ydomain[[object$ynames]]) order.q <- rank(q) p <- q <- sort(q) q.dup <- duplicated(q) p[q<=mn] <- 0 p[q>=mx] <- 1 qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) y.wk <- data.frame(qd$pt) colnames(y.wk) <- object$ynames d.qd <- dsscden(object,y.wk,x) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(q))[q>mn&q=1] <- mx qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) y.wk <- data.frame(qd$pt) colnames(y.wk) <- object$ynames d.qd <- dsscden(object,y.wk,x) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(p))[p>0&p<1] z <- NULL for (k in 1:dim(x)[1]) { d.qd.wk <- d.qd[,k]/sum(d.qd[,k]*qd$wt) p.wk <- cumsum(d.qd.wk*qd$wt) for (i in kk) { if (p.dup[i]) { q[i] <- q.dup next } ind <- (1:(2*qd.hize))[p.wk=nnull)&(nnull>0))) { stop("gss error in sspreg: inputs have wrong dimensions") } ## Set method for smoothing parameter selection code <- (1:3)[c("v","m","u")==method] if (!length(code)) { stop("gss error: unsupported method for smoothing parameter selection") } ## Call RKPACK driver DSIDR z <- .Fortran("dsidr0", as.integer(code), swk=as.double(s), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(y), qwk=as.double(q), as.integer(nobs), as.double(0), as.integer(0), double(2), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), qraux=double(nnull), jpvt=integer(nnull), double(3*nobs), info=integer(1),PACKAGE="gss") ## Check info for error if (info<-z$info) { if (info>0) stop("gss error in sspreg: matrix s is rank deficient") if (info==-2) stop("gss error in sspreg: matrix q is indefinite") if (info==-1) stop("gss error in sspreg: input data have wrong dimensions") if (info==-3) stop("gss error in sspreg: unknown method for smoothing parameter selection.") } ## Return the fit c(list(method=method,theta=0), z[c("c","d","nlambda","score","varht","swk","qraux","jpvt","qwk")]) } ## Fit Multiple Smoothing Parameter REGression mspreg0 <- function(s,q,y,method="v",varht=1,prec=1e-7,maxiter=30) { ## Check inputs if (is.vector(s)) s <- as.matrix(s) if (!(is.matrix(s)&is.array(q)&(length(dim(q))==3) &is.vector(y)&is.character(method))) { stop("gss error in mspreg: inputs are of wrong types") } nobs <- length(y) nnull <- dim(s)[2] nq <- dim(q)[3] if (!((dim(s)[1]==nobs)&(dim(q)[1]==nobs)&(dim(q)[2]==nobs) &(nobs>=nnull)&(nnull>0)&(nq>1))) { stop("gss error in mspreg: inputs have wrong dimensions") } ## Set method for smoothing parameter selection code <- (1:3)[c("v","m","u")==method] if (!length(code)) { stop("gss error: unsupported method for smoothing parameter selection") } ## Call RKPACK driver DMUDR z <- .Fortran("dmudr0", as.integer(code), as.double(s), # s as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(q), # q as.integer(nobs), as.integer(nobs), as.integer(nq), as.double(y), # y as.double(0), as.integer(0), as.double(prec), as.integer(maxiter), theta=double(nq), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), integer(nnull+nq), double(nobs*nobs*(nq+2)), info=integer(1),PACKAGE="gss")[c("theta","info")] ## Check info for error if (info<-z$info) { if (info>0) stop("gss error in mspreg: matrix s is rank deficient") if (info==-2) stop("gss error in mspreg: matrix q is indefinite") if (info==-1) stop("gss error in mspreg: input data have wrong dimensions") if (info==-3) stop("gss error in mspreg: unknown method for smoothing parameter selection.") if (info==-4) stop("gss error in mspreg: iteration fails to converge, try to increase maxiter") if (info==-5) stop("gss error in mspreg: iteration fails to find a reasonable descent direction") } qwk <- 10^z$theta[1]*q[,,1] for (i in 2:nq) qwk <- qwk + 10^z$theta[i]*q[,,i] ## Call RKPACK driver DSIDR zz <- .Fortran("dsidr0", as.integer(code), swk=as.double(s), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(y), qwk=as.double(qwk), as.integer(nobs), as.double(0), as.integer(0), double(2), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), qraux=double(nnull), jpvt=integer(nnull), double(3*nobs), info=integer(1),PACKAGE="gss") ## Return the fit c(list(method=method,theta=z$theta), zz[c("c","d","nlambda","score","varht","swk","qraux","jpvt","qwk")]) } ## Obtain c & d for new y's getcrdr <- function(obj,r) { ## Check inputs if (is.vector(r)) r <- as.matrix(r) if (!(any(class(obj)=="ssanova0")&is.matrix(r))) { stop("gss error in getcrdr: inputs are of wrong types") } nobs <- length(obj$c) nnull <- length(obj$d) nr <- dim(r)[2] if (!((dim(r)[1]==nobs)&(nr>0))) { stop("gss error in getcrdr: inputs have wrong dimensions") } ## Call RKPACK ulitity DCRDR z <- .Fortran("dcrdr", as.double(obj$swk), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(obj$qraux), as.integer(obj$jpvt), as.double(obj$qwk), as.integer(nobs), as.double(obj$nlambda), as.double(r), as.integer(nobs), as.integer(nr), cr=double(nobs*nr), as.integer(nobs), dr=double(nnull*nr), as.integer(nnull), double(2*nobs), integer(1),PACKAGE="gss")[c("cr","dr")] ## Return cr and dr z$cr <- matrix(z$cr,nobs,nr) z$dr <- matrix(z$dr,nnull,nr) z } ## Obtain var-cov matrix for unpenalized terms getsms <- function(obj) { ## Check input if (!any(class(obj)=="ssanova0")) { stop("gss error in getsms: inputs are of wrong types") } nobs <- length(obj$c) nnull <- length(obj$d) ## Call RKPACK ulitity DSMS z <- .Fortran("dsms", as.double(obj$swk), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.integer(obj$jpvt), as.double(obj$qwk), as.integer(nobs), as.double(obj$nlambda), sms=double(nnull*nnull), as.integer(nnull), double(2*nobs), integer(1),PACKAGE="gss")["sms"] ## Return the nnull-by-nnull matrix matrix(z$sms,nnull,nnull) } gss/R/project.gssanova.R0000644000176200001440000003325613653610272014676 0ustar liggesusers## Calculate Kullback-Leibler projection from gssanova objects project.gssanova <- function(object,include,...) { if (class(object)[1]=="gssanova0") stop("gss error: Kullback-Leibler projection is not implemented for gssanova0") nobs <- nrow(object$mf) nxi <- length(object$id.basis) labels.p <- object$lab.p ## evaluate full model family <- object$family eta <- object$eta if (object$family=="polr") { y <- model.response(object$mf) if (!is.factor(y)) stop("gss error in gssanova1: need factor response for polr family") lvls <- levels(y) if (nlvl <- length(lvls)<3) stop("gss error in gssanova1: need at least 3 levels to fit polr family") y <- outer(y,lvls,"==") } else y <- model.response(object$mf,"numeric") wt <- model.weights(object$mf) if(is.null(wt)) wt <- rep(1,nobs) offset <- model.offset(object$mf) if (!is.null(object$random)) { if (is.null(offset)) offset <- 0 offset <- offset + object$random$z%*%object$b } nu <- object$nu y0 <- switch(family, binomial=y0.binomial(y,eta,wt), poisson=y0.poisson(eta), Gamma=y0.Gamma(eta), inverse.gaussian=y0.inverse.gaussian(eta), nbinomial=y0.nbinomial(y,eta,nu), polr=y0.polr(list(eta=eta,nu=nu)), weibull=y0.weibull(y,eta,nu), lognorm=y0.lognorm(y,eta,nu), loglogis=y0.loglogis(y,eta,nu)) # calculate constant fit cfit <- switch(family, binomial=cfit.binomial(y,wt,offset), poisson=cfit.poisson(y,wt,offset), Gamma=cfit.Gamma(y,wt,offset), inverse.gaussian=cfit.inverse.gaussian(y,wt,offset), nbinomial=cfit.nbinomial(y,wt,offset,nu), polr=cfit.polr(y,wt,offset), weibull=cfit.weibull(y,wt,offset,nu), lognorm=cfit.lognorm(y,wt,offset,nu), loglogis=cfit.loglogis(y,wt,offset,nu)) # calculate total entropy kl0 <- switch(family, binomial=kl.binomial(eta,cfit,y0$wt), poisson=kl.poisson(eta,cfit,wt), Gamma=kl.Gamma(eta,cfit,wt), inverse.gaussian=kl.inverse.gaussian(eta,cfit,wt), nbinomial=kl.nbinomial(eta,cfit,wt,y0$nu), polr=kl.polr(list(eta=eta,nu=nu),cfit,wt), weibull=kl.weibull(eta,cfit,wt,nu,y0$int), lognorm=kl.lognorm(eta,cfit,wt,nu,y0), loglogis=kl.loglogis(eta,cfit,wt,nu,y0)) ## extract terms in subspace s <- matrix(1,nobs,1) philist <- object$term[["1"]]$iphi r <- NULL theta <- NULL nq.wk <- nq <- 0 for (label in object$terms$labels) { if (label=="1") next if (label%in%labels.p) next x <- object$mf[,object$term[[label]]$vlist] x.basis <- object$mf[object$id.basis,object$term[[label]]$vlist] nphi <- object$term[[label]]$nphi nrk <- object$term[[label]]$nrk if (nphi) { phi <- object$term[[label]]$phi for (i in 1:nphi) { if (!any(label==include)) next philist <- c(philist,object$term[[label]]$iphi+(i-1)) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } } if (nrk) { rk <- object$term[[label]]$rk for (i in 1:nrk) { nq.wk <- nq.wk + 1 if (!any(label==include)) next nq <- nq + 1 theta <- c(theta,object$theta[nq.wk]) r <- array(c(r,rk$fun(x,x.basis,nu=i,env=rk$env,out=TRUE)), c(nobs,nxi,nq)) } } } if (!is.null(object$partial)) { nu <- length(object$d)-length(object$lab.p) matx.p <- model.matrix(object$partial$mt,object$mf)[,-1,drop=FALSE] matx.p <- scale(matx.p) for (label in labels.p) { nu <- nu+1 if (!any(label==include)) next philist <- c(philist,nu) s <- cbind(s,matx.p[,label]) } } ## calculate projection my.wls <- function(theta1=NULL) { if (!nq) { q <- matrix(0) sr <- cbind(s,0) z <- ngreg.proj(dc,family,sr,q,y0,wt,offset,nu) } else { theta.wk <- 1:nq theta.wk[fix] <- theta[fix] if (nq-1) theta.wk[-fix] <- theta1 sr <- 0 for (i in 1:nq) sr <- sr + 10^theta.wk[i]*r[,,i] q <- sr[object$id.basis,] sr <- cbind(s,sr) z <- ngreg.proj(dc,family,sr,q,y0,wt,offset,nu) } assign("dc",z$dc,inherits=TRUE) assign("eta1",z$eta,inherits=TRUE) if (family=="polr") assign("nu",z$nu,inherits=TRUE) z$kl } cv.wk <- function(theta) cv.scale*my.wls(theta)+cv.shift ## initialization if (nq) { r.wk <- 0 for (i in 1:nq) r.wk <- r.wk + 10^theta[i]*r[,,i] if (is.null(s)) theta.wk <- 0 else theta.wk <- log10(sum(wt*s^2)/ncol(s)/sum(wt*r.wk^2)*nxi) / 2 theta <- theta + theta.wk tmp <- NULL for (i in 1:nq) tmp <- c(tmp,10^theta[i]*sum(r[cbind(object$id.basis,1:nxi,i)])) fix <- rev(order(tmp))[1] } ## projection if (nq) dc <- c(object$d[philist],10^(-theta.wk)*object$c) else dc <- c(object$d[philist],0) eta1 <- NULL if (nq>1) { if (object$skip.iter) kl <- my.wls(theta[-fix]) else { ## scale and shift cv tmp <- abs(my.wls(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=1,ndigit=7) kl <- my.wls(zz$est) } } else kl <- my.wls() ## check kl1 <- switch(family, binomial=kl.binomial(eta1,cfit,y0$wt), poisson=kl.poisson(eta1,cfit,wt), Gamma=kl.Gamma(eta1,cfit,wt), inverse.gaussian=kl.inverse.gaussian(eta1,cfit,wt), nbinomial=kl.nbinomial(eta1,cfit,wt,y0$nu), polr=kl.polr(list(eta=eta1,nu=nu),cfit,wt), weibull=kl.weibull(eta1,cfit,wt,nu,y0$int), lognorm=kl.lognorm(eta1,cfit,wt,nu,y0), loglogis=kl.loglogis(eta1,cfit,wt,nu,y0)) list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) } ## KL projection with Non-Gaussian regression ngreg.proj <- function(dc,family,sr,q,y0,wt,offset,nu) { ## initialization q <- 10^(-5)*q eta <- as.vector(sr%*%dc) nobs <- length(eta) nn <- ncol(as.matrix(sr)) nxi <- ncol(q) nnull <- nn-nxi if (!is.null(offset)) eta <- eta + offset fit1 <- switch(family, binomial=proj0.binomial(y0,eta,offset), poisson=proj0.poisson(y0,eta,wt,offset), Gamma=proj0.Gamma(y0,eta,wt,offset), inverse.gaussian=proj0.inverse.gaussian(y0,eta,wt,offset), nbinomial=proj0.nbinomial(y0,eta,wt,offset), polr=proj0.polr(y0,eta,wt,offset,nu), weibull=proj0.weibull(y0,eta,wt,offset,nu), lognorm=proj0.lognorm(y0,eta,wt,offset,nu), loglogis=proj0.loglogis(y0,eta,wt,offset,nu)) if (family=="polr") nu <- fit1$nu kl <- fit1$kl ## Newton iteration dc.new <- eta.new <- NULL kl.line <- function(x) { assign("dc.new",dc+c(x)*dc.diff,inherits=TRUE) eta.wk <- as.vector(sr%*%dc.new) if (!is.null(offset)) eta.wk <- eta.wk + offset assign("eta.new",eta.wk,inherits=TRUE) fit.wk <- switch(family, binomial=proj0.binomial(y0,eta.new,offset), poisson=proj0.poisson(y0,eta.new,wt,offset), Gamma=proj0.Gamma(y0,eta.new,wt,offset), inverse.gaussian=proj0.inverse.gaussian(y0,eta.new,wt,offset), nbinomial=proj0.nbinomial(y0,eta.new,wt,offset), polr=proj0.polr(y0,eta.new,wt,offset,nu), weibull=proj0.weibull(y0,eta.new,wt,offset,nu), lognorm=proj0.lognorm(y0,eta.new,wt,offset,nu), loglogis=proj0.loglogis(y0,eta.new,wt,offset,nu)) assign("fit1",fit.wk,inherits=TRUE) if (family=="polr") nu <- fit1$nu fit1$kl } iter <- 0 flag <- 0 flag2 <- 0 repeat { iter <- iter+1 ## weighted least squares fit if (!is.finite(sum(fit1$wt,fit1$ywk))) { if (flag) stop("gss error in project.gssanova: Newton iteration diverges") dc <- rep(0,nn) eta <- rep(0,nobs) if (family=="polr") { if (is.null(wt)) P <- apply(y0,2,sum) else P <- apply(y0*wt,2,sum) P <- P/sum(P) P <- cumsum(P) nnu <- length(P)-2 dc[1] <- qlogis(P[1]) nu[[1]] <- diff(qlogis(P[-(nnu+2)])) eta <- as.vector(sr%*%dc) } if (!is.null(offset)) eta <- eta + offset fit1 <- switch(family, binomial=proj0.binomial(y0,eta,offset), poisson=proj0.poisson(y0,eta,wt,offset), Gamma=proj0.Gamma(y0,eta,wt,offset), inverse.gaussian=proj0.inverse.gaussian(y0,eta,wt,offset), nbinomial=proj0.nbinomial(y0,eta,wt,offset), polr=proj0.polr(y0,eta,wt,offset,nu), weibull=proj0.weibull(y0,eta,wt,offset,nu), lognorm=proj0.lognorm(y0,eta,wt,offset,nu), loglogis=proj0.loglogis(y0,eta,wt,offset,nu)) if (family=="polr") nu <- fit1$nu kl <- fit1$kl iter <- 0 flag <- 1 next } mumax <- max(abs(t(sr)%*%fit1$u)) w <- sqrt(as.vector(fit1$wt)) z <- .Fortran("reg", as.double(w*sr), as.integer(nobs), as.integer(nnull), as.double(q), as.integer(nxi), as.double(w*fit1$ywk), as.integer(4), double(1), double(1), double(1), dc=double(nn), as.double(.Machine$double.eps), double(nn*nn), double(nn), as.integer(rep(0,nn)), double(max(nobs,nn)), integer(1), integer(1), PACKAGE="gss")["dc"] dc.diff <- z$dc-dc repeat { kl.new <- kl.line(1) if (!is.finite(kl.new)) { dc.diff <- dc.diff/2 next } if (!flag2) { if (kl.new-kl<1e-7*(1+abs(kl))) break } zz <- nlm0(kl.line,c(0,1),1e-3) kl.new <- kl.line(zz$est) break } disc0 <- max((mumax/(1+kl))^2,abs(kl.new-kl)/(1+kl)) disc <- sum(fit1$wt*((eta-eta.new)/(1+abs(eta)))^2)/sum(fit1$wt) if (is.nan(disc)) { if (flag) stop("gss error in project.gssanova: Newton iteration diverges") dc <- rep(0,nn) eta <- rep(0,nobs) if (family=="polr") { if (is.null(wt)) P <- apply(y0,2,sum) else P <- apply(y0*wt,2,sum) P <- P/sum(P) P <- cumsum(P) nnu <- length(P)-2 dc[1] <- qlogis(P[1]) nu[[1]] <- diff(qlogis(P[-(nnu+2)])) eta <- as.vector(sr%*%dc) } if (!is.null(offset)) eta <- eta + offset fit1 <- switch(family, binomial=proj0.binomial(y0,eta,offset), poisson=proj0.poisson(y0,eta,wt,offset), Gamma=proj0.Gamma(y0,eta,wt,offset), inverse.gaussian=proj0.inverse.gaussian(y0,eta,wt,offset), nbinomial=proj0.nbinomial(y0,eta,wt,offset), polr=proj0.polr(y0,eta,wt,offset,nu), polr=proj0.polr(y0,eta,wt,offset), weibull=proj0.weibull(y0,eta,wt,offset,nu), lognorm=proj0.lognorm(y0,eta,wt,offset,nu), loglogis=proj0.loglogis(y0,eta,wt,offset,nu)) if (family=="polr") nu <- fit1$nu kl <- fit1$kl iter <- 0 flag <- 1 next } dc <- dc.new eta <- eta.new kl <- kl.new if (min(disc0,disc)<1e-5) break if (iter<=30) next if (!flag2) { flag2 <- 1 iter <- 0 next } warning("gss warning in gssanova: Newton iteration fails to converge") break } fit1 <- switch(family, binomial=proj0.binomial(y0,eta,offset), poisson=proj0.poisson(y0,eta,wt,offset), Gamma=proj0.Gamma(y0,eta,wt,offset), inverse.gaussian=proj0.inverse.gaussian(y0,eta,wt,offset), nbinomial=proj0.nbinomial(y0,eta,wt,offset), polr=proj0.polr(y0,eta,wt,offset,nu), weibull=proj0.weibull(y0,eta,wt,offset,nu), lognorm=proj0.lognorm(y0,eta,wt,offset,nu), loglogis=proj0.loglogis(y0,eta,wt,offset,nu)) if (family=="polr") nu <- fit1$nu kl <- fit1$kl list(dc=dc,eta=eta,kl=kl,nu=nu) } gss/R/family.R0000644000176200001440000003250013660040621012651 0ustar liggesusers##%%%%%%%%%% Binomial Family %%%%%%%%%% ## Make pseudo data for logistic regression mkdata.binomial <- function(y,eta,wt,offset) { if (is.vector(y)) y <- as.matrix(y) if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) if (dim(y)[2]==1) { if ((max(y)>1)|(min(y)<0)) stop("gss error: binomial responses should be between 0 and 1") } else { if (min(y)<0) stop("gss error: paired binomial response should be nonnegative") wt <- wt * (y[,1]+y[,2]) y <- y[,1]/(y[,1]+y[,2]) } odds <- exp(eta) p <- odds/(1+odds) u <- p - y w <- p/(1+odds) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,u=u*wt) } ## Calculate deviance residuals for logistic regression dev.resid.binomial <- function(y,eta,wt) { if (is.vector(y)) y <- as.matrix(y) if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (dim(y)[2]>1) { wt <- wt * (y[,1]+y[,2]) y <- y[,1]/(y[,1]+y[,2]) } odds <- exp(eta) as.vector(2*wt*(y*log(ifelse(y==0,1,y*(1+odds)/odds)) +(1-y)*log(ifelse(y==1,1,(1-y)*(1+odds))))) } ## Calculate null deviance for logistic regression dev.null.binomial <- function(y,wt,offset) { if (is.vector(y)) y <- as.matrix(y) if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (dim(y)[2]>1) { wt <- wt * (y[,1]+y[,2]) y <- y[,1]/(y[,1]+y[,2]) } p <- sum(wt*y)/sum(wt) odds <- p/(1-p) if (!is.null(offset)) { eta <- log(odds) - mean(offset) repeat { odds <- exp(eta+offset) p <- odds/(1+odds) u <- p - y w <- p/(1+odds) eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } } sum(2*wt*(y*log(ifelse(y==0,1,y*(1+odds)/odds)) +(1-y)*log(ifelse(y==1,1,(1-y)*(1+odds))))) } ##%%%%%%%%%% Poisson Family %%%%%%%%%% ## Make pseudo data for Poisson regression mkdata.poisson <- function(y,eta,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) if (is.null(offset)) offset <- rep(0,length(y)) if (min(y)<0) stop("gss error: Poisson response should be nonnegative") lambda <- exp(eta) u <- lambda - y w <- lambda ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,u=u*wt) } ## Calculate deviance residuals for Poisson regression dev.resid.poisson <- function(y,eta,wt) { if (is.null(wt)) wt <- rep(1,length(y)) lambda <- exp(eta) as.vector(2*wt*(y*log(ifelse(y==0,1,y/lambda))-(y-lambda))) } ## Calculate null deviance for Poisson regression dev.null.poisson <- function(y,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) lambda <- sum(wt*y)/sum(wt) if (!is.null(offset)) { eta <- log(lambda) - mean(offset) repeat { lambda <- exp(eta+offset) u <- lambda - y w <- lambda eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } } sum(2*wt*(y*log(ifelse(y==0,1,y/lambda))-(y-lambda))) } ##%%%%%%%%%% Gamma Family %%%%%%%%%% ## Make pseudo data for Gamma regression mkdata.Gamma <- function(y,eta,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) if (is.null(offset)) offset <- rep(0,length(y)) if (min(y)<=0) stop("gss error: gamma responses should be positive") mu <- exp(eta) u <- 1-y/mu ywk <- eta-u-offset list(ywk=ywk,wt=wt,u=u*wt) } ## Calculate deviance residuals for Gamma regression dev.resid.Gamma <- function(y,eta,wt) { if (is.null(wt)) wt <- rep(1,length(y)) mu <- exp(eta) as.vector(2*wt*(-log(y/mu)+(y-mu)/mu)) } ## Calculate null deviance for Gamma regression dev.null.Gamma <- function(y,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) mu <- sum(wt*y)/sum(wt) if (!is.null(offset)) { eta <- log(mu)-mean(offset) repeat { mu <- exp(eta+offset) u <- 1-y/mu eta.new <- eta-sum(wt*u)/sum(wt) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } } sum(2*wt*(-log(y/mu)+(y-mu)/mu)) } ##%%%%%%%%%% Inverse Gaussian Family %%%%%%%%%% ## Make pseudo data for IG regression mkdata.inverse.gaussian <- function(y,eta,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) if (is.null(offset)) offset <- rep(0,length(y)) if (min(y)<=0) stop("gss error: inverse gaussian responses should be positive") mu <- exp(eta) u <- (1-y/mu)/mu w <- 1/mu ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,u=u*wt) } ## Calculate deviance residuals for IG regression dev.resid.inverse.gaussian <- function(y,eta,wt) { if (is.null(wt)) wt <- rep(1,length(y)) mu <- exp(eta) as.vector(wt*((y-mu)^2/(y*mu^2))) } ## Calculate null deviance for IG regression dev.null.inverse.gaussian <- function(y,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) mu <- sum(wt*y)/sum(wt) if (!is.null(offset)) { eta <- log(mu)-mean(offset) repeat { mu <- exp(eta+offset) u <- (1-y/mu)/mu w <- 1/mu eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } } sum(wt*((y-mu)^2/(y*mu^2))) } ##%%%%%%%%%% Negative Binomial Family %%%%%%%%%% ## Make pseudo data for NB regression mkdata.nbinomial <- function(y,eta,wt,offset,nu) { if (is.vector(y)) y <- as.matrix(y) if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) if (dim(y)[2]==2) { if (min(y[,1])<0) stop("gss error: negative binomial response should be nonnegative") if (min(y[,2])<=0) stop("gss error: negative binomial size should be positive") odds <- exp(eta) p <- odds/(1+odds) q <- 1/(1+odds) u <- y[,1]*p-y[,2]*q w <- y[,2]*q ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,nu=1,u=u*wt) } else { if (min(y)<0) stop("gss error: negative binomial response should be nonnegative") odds <- exp(eta) p <- odds/(1+odds) q <- 1/(1+odds) if (is.null(nu)) log.nu <- log(mean(y*odds)) else log.nu <- log(nu) lkhd <- function(log.nu) { nu <- exp(log.nu) lgamma(nu)-sum(wt*lgamma(nu+y))/sum(wt)-nu*sum(wt*log(p))/sum(wt) } nu <- exp(nlm(lkhd,log.nu,stepmax=.5)$est) u <- y*p-nu*q w <- nu*q ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,nu=nu,u=u*wt) } } ## Calculate deviance residuals for NB regression dev.resid.nbinomial <- function(y,eta,wt) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) odds <- exp(eta) p <- odds/(1+odds) q <- 1/(1+odds) as.vector(2*wt*(y[,1]*log(ifelse(y[,1]==0,1,y[,1]/(y[,1]+y[,2])/q)) +y[,2]*log(y[,2]/(y[,1]+y[,2])/p))) } ## Calculate null deviance for NB regression dev.null.nbinomial <- function(y,wt,offset) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) p <- sum(wt*y[,2])/sum(wt*y) if (!is.null(offset)) { eta <- log(p/(1-p)) - mean(offset) repeat { odds <- exp(eta+offset) p <- odds/(1+odds) q <- 1/(1+odds) u <- y[,1]*p-y[,2]*q w <- y[,2]*q eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } } sum(2*wt*(y[,1]*log(ifelse(y[,1]==0,1,y[,1]/(y[,1]+y[,2])/q)) +y[,2]*log(y[,2]/(y[,1]+y[,2])/p))) } ##%%%%%%%%%% Proportional Odds Logistic Regression %%%%%%%%%% ## Make pseudo data for PO logistic regression mkdata.polr <- function(y,eta,wt,offset,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) nnu <- length(nu) hess <- matrix(0,nnu,nnu) G <- c(0,cumsum(nu)) P <- exp(outer(eta,G,"+")) lkhd <- 0 for (i in 1:(nnu+1)) lkhd <- lkhd+sum(wt*(y[,i]+y[,i+1])*log(1+P[,i]))/sum(wt) for (i in 1:nnu) lkhd <- lkhd-sum(wt*y[,i+1])/sum(wt)*log(exp(nu[i])-1) if (nnu>1) { for (i in 1:(nnu-1)) { tmp <- 0 for (j in (i+1):nnu) tmp <- tmp+sum(wt*y[,j+1])/sum(wt) lkhd <- lkhd-tmp*nu[i] } } dd <- log(nu) repeat { ## gradient and hessian nu <- exp(dd) G <- c(0,cumsum(nu)) P <- exp(outer(eta,G,"+")) grad <- hess.wk <- NULL for (i in 1:nnu) { g.wk <- h.wk <- 0 for (j in (i+1):(nnu+1)) { g.wk <- g.wk+sum(wt*(y[,j]+y[,j+1])*P[,j]/(1+P[,j]))/sum(wt) if (j<=nnu) g.wk <- g.wk-sum(wt*y[,j+1])/sum(wt) h.wk <- h.wk+sum(wt*(y[,j]+y[,j+1])*P[,j]/(1+P[,j])^2)/sum(wt) } g.wk <- g.wk-exp(nu[i])/(exp(nu[i])-1)*sum(wt*y[,i+1])/sum(wt) grad <- c(grad,g.wk) hess.wk <- c(hess.wk,h.wk) } for (i in 1:nnu) { hess[1:i,i] <- hess.wk[i] hess[i,i] <- hess[i,i]+exp(nu[i])/(exp(nu[i])-1)^2*sum(wt*y[,i+1])/sum(wt) } grad <- grad*nu hess <- hess*outer(nu,nu) diag(hess) <- diag(hess)+grad ## modify hessian if necessary if (nnu>1) { z <- .Fortran("dmcdc", as.double(hess), as.integer(nnu), as.integer(nnu), ee=double(nnu), pivot=integer(nnu), integer(1), PACKAGE="gss") if (max(z$ee)) { z$ee[z$pivot] <- z$ee hess <- hess+diag(z$ee) } } else hess <- abs(hess) ## update nu mumax <- max(abs(grad)) dd.diff <- solve(hess,grad) repeat { lkhd.line <- function(x) { ddnew <- dd-c(x)*dd.diff nu <- exp(ddnew) G <- c(0,cumsum(nu)) P <- exp(outer(eta,G,"+")) lkhd <- 0 for (i in 1:(nnu+1)) lkhd <- lkhd+sum(wt*(y[,i]+y[,i+1])*log(1+P[,i]))/sum(wt) for (i in 1:nnu) lkhd <- lkhd-sum(wt*y[,i+1])/sum(wt)*log(exp(nu[i])-1) if (nnu>1) { for (i in 1:(nnu-1)) { tmp <- 0 for (j in (i+1):nnu) tmp <- tmp+sum(wt*y[,j+1])/sum(wt) lkhd <- lkhd-tmp*nu[i] } } lkhd } if (!is.finite(lkhdnew <- lkhd.line(1))) { dd.diff <- dd.diff/2 next } ddnew <- dd-dd.diff if (lkhdnew-lkhd<(1+abs(lkhd))*10*.Machine$double.eps) break z <- nlm0(lkhd.line,c(0,1)) ddnew <- dd-z$est*dd.diff lkhdnew <- z$min break } disc <- abs(lkhdnew-lkhd)/(1+abs(lkhd)) disc <- max(disc,max(abs(dd-ddnew)/(1+abs(dd)))) disc0 <- (mumax/(1+abs(lkhd)))^2 dd <- ddnew lkhd <- lkhdnew if (min(disc,disc0)<1e-7) break } u <- -1+y[,nnu+2] for (i in 1:(nnu+1)) u <- u+(y[,i]+y[,i+1])*P[,i]/(1+P[,i]) w <- P[,2]/(1+P[,2])*P[,1]/(1+P[,1])^2 w <- w+1/(1+P[,nnu])*P[,nnu+1]/(1+P[,nnu+1])^2 if (nnu>1) { for (i in 2:nnu) w <- w+(P[,i+1]-P[,i-1])/(1+P[,i+1])/(1+P[,i-1])*P[,i]/(1+P[,i])^2 } ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,nu=nu,u=u*wt) } ## Calculate deviance residuals for PO logistic regression dev.resid.polr <- function(y,eta,wt,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) nnu <- length(nu) G <- c(0,cumsum(nu)) P <- plogis(outer(eta,G,"+")) wk <- NULL for (i in 1:length(wt)) { idx <- (1:(nnu+2))[y[i,]] if (idx==1) wk <- c(wk,P[i,1]) if (idx==nnu+2) wk <- c(wk,1-P[i,nnu+1]) if ((idx>1)&(idx1)&(idx1)&(idx1)|(min(x)<0)) stop("gss error in dsscopu: points out of range") if (is.vector(x)) x <- matrix(x,1,dim(object$basis)[2]) ## obtain quantiles of marginal distribution if (copu) { md <- object$mdsty qd <- gauss.quad(200,c(0,1)) gap <- diff(qd$pt) g.wk <- gap[100]/2 for (i in 1:98) g.wk <- c(g.wk,gap[100+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,1/2-sum(g.wk)) gap[100:1] <- gap[100+(1:100)] <- g.wk brk <- cumsum(c(0,gap)) qq <- NULL for (j in 1:dim(md)[2]) { p <- x[,j] order.p <- rank(p) q <- p <- sort(p) p.dup <- duplicated(p) p.wk <- cumsum(md[,j]*qd$wt) kk <- (1:length(p))[p>0&p<1] for (i in kk) { if (p.dup[i]) { q[i] <- q.dup next } ind <- (1:200)[p.wk1)) stop("gss error in cdsscopu: points out of range") if ((pos<1)|(pos>dm)) stop("gss error in cdsscopu: position out of range") if (is.null(int)) { quad <- gauss.quad(200,c(0,1)) xx <- matrix(0,200,dm) xx[,-pos] <- t(matrix(cond,dm-1,200)) xx[,pos] <- quad$pt int <- sum(dsscopu(object,xx)*quad$wt) } ## Return value xx <- matrix(0,length(x),dm) xx[,-pos] <- t(matrix(cond,dm-1,length(x))) xx[,pos] <- x list(pdf=dsscopu(object,xx)/int,int=int) } cpsscopu <- ## Compute cdf for 1-D conditional density function(object,q,cond,pos=1) { if (!inherits(object,"sscopu")) stop("gss error in cpsscopu: not a sscopu object") dm <- dim(object$basis)[2] if (length(cond)!=dm-1) stop("gss error in cpsscopu: condition is of wrong dimension") if ((min(q,cond)<0)|(max(q,cond)>1)) stop("gss error in cpsscopu: points out of range") if ((pos<1)|(pos>dm)) stop("gss error in cpsscopu: position out of range") order.q <- rank(q) p <- q <- sort(q) q.dup <- duplicated(q) p[q<=0] <- 0 p[q>=1] <- 1 qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(0,1)) d.qd <- cdsscopu(object,qd$pt,cond,pos)$pdf gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,1/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(0,gap)) kk <- (1:length(q))[q>0&q<1] for (i in kk) { if (q.dup[i]) { p[i] <- p.dup next } ind <- (1:(2*qd.hize))[qd$pt1)) stop("gss error in cqsscopu: points out of range") if ((pos<1)|(pos>dm)) stop("gss error in cqsscopu: position out of range") order.p <- rank(p) q <- p <- sort(p) p.dup <- duplicated(p) q[p<=0] <- 0 q[p>=1] <- 1 qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(0,1)) d.qd <- cdsscopu(object,qd$pt,cond,pos)$pdf gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,1/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(0,gap)) p.wk <- cumsum(d.qd*qd$wt) kk <- (1:length(p))[p>0&p<1] for (i in kk) { if (p.dup[i]) { q[i] <- q.dup next } ind <- (1:(2*qd.hize))[p.wk10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } kl <- rkl(zz$est) } } else kl <- rkl() } else { nn <- nrow(qd.s) z <- .Fortran("drkl", cd=as.double(d), as.integer(nn), as.double(qd.s), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(t(qd.wt)), mesh=as.double(mesh0), as.double(.Machine$double.eps), as.double(1e-6), as.integer(30), double(nn), double(2*bias$nt*(nqd+1)+nn*(2*nn+4)), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.sscox: Newton iteration diverges") if (z$info==2) warning("gss warning in project.sscox: Newton iteration fails to converge") mesh1 <- z$mesh kl <- sum(bias$wt*(apply(qd.wt*log(mesh0/mesh1)*mesh0,2,sum)+ log(apply(qd.wt*mesh1,2,sum)))) } kl0 <- sum(bias$wt*(apply(qd.wt*log(mesh0)*mesh0,2,sum)+ log(apply(qd.wt,2,sum)))) wt.wk <- t(t(qd.wt)/apply(qd.wt*mesh1,2,sum)) kl1 <- sum(bias$wt*(apply(wt.wk*log(mesh1)*mesh1,2,sum)+ log(apply(wt.wk,2,sum)))) obj <- list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) obj } gss/R/mkfun.poly.R0000644000176200001440000001345612355360640013511 0ustar liggesusers## Make RK for cubic splines mkrk.cubic <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the rk function fun <- function(x,y,env,outer.prod=FALSE) { ##% Check the inputs if (!(is.vector(x)&is.vector(y))) { stop("gss error in rk: inputs are of wrong types") } if ((min(x,y)env$max)) { stop("gss error in rk: inputs are out of range") } ##% Scale the inputs x <- (x-env$min)/(env$max-env$min) y <- (y-env$min)/(env$max-env$min) ##% Return the result rk <- function(x,y) { k2 <- function(x) ((x-.5)^2-1/12)/2 k4 <- function(x) ((x-.5)^4-(x-.5)^2/2+7/240)/24 k2(x)*k2(y)-k4(abs(x-y)) } if (outer.prod) outer(x,y,rk) else rk(x,y) } ## Return the function and the environment list(fun=fun,env=env) } ## Make phi function for cubic splines mkphi.cubic <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the phi function fun <- function(x,nu,env) { ##% Check the input if (!is.vector(x)) { stop("gss error in phi: inputs are of wrong types") } if ((min(x)env$max)) { stop("gss error in phi: inputs are out of range") } ##% Return the result (x-env$min)/(env$max-env$min)-.5 } ## Return the function and the environment list(fun=fun,env=env) } ## Make RK for periodic cubic splines mkrk.cubic.per <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the rk function fun <- function(x,y,env,outer.prod=FALSE) { ##% Check the inputs if (!(is.vector(x)&is.vector(y))) { stop("gss error in rk: inputs are of wrong types") } if ((min(x,y)env$max)) { stop("gss error in rk: inputs are out of range") } ##% Scale the inputs x <- (x-env$min)/(env$max-env$min) y <- (y-env$min)/(env$max-env$min) ##% Return the result rk <- function(x,y) { k4 <- function(x) ((x-.5)^4-(x-.5)^2/2+7/240)/24 -k4(abs(x-y)) } if (outer.prod) outer(x,y,rk) else rk(x,y) } ## Return the function and the environment list(fun=fun,env=env) } ## Make RK for trigonometric splines mkrk.trig <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the rk function fun <- function(x,y,env,outer.prod=FALSE) { ##% Check the inputs if (!(is.vector(x)&is.vector(y))) { stop("gss error in rk: inputs are of wrong types") } if ((min(x,y)env$max)) { stop("gss error in rk: inputs are out of range") } ##% Scale the inputs x <- (x-env$min)/(env$max-env$min) y <- (y-env$min)/(env$max-env$min) ##% Return the result rk <- function(x,y) { k4 <- function(x) ((x-.5)^4-(x-.5)^2/2+7/240)/24 -k4(abs(x-y))-2*cos(2*pi*(x-y))/(2*pi)^4 } if (outer.prod) outer(x,y,rk) else rk(x,y) } ## Return the function and the environment list(fun=fun,env=env) } ## Make phi function for trigonometric splines mkphi.trig <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the phi function fun <- function(x,nu,env) { ##% Check the input if (!is.vector(x)) { stop("gss error in phi: inputs are of wrong types") } if ((min(x)env$max)) { stop("gss error in phi: inputs are out of range") } ##% Return the result xx <- (x-env$min)/(env$max-env$min) switch(nu,cos(2*pi*xx),sin(2*pi*xx)) } ## Return the function and the environment list(fun=fun,env=env) } ## Make RK for linear splines mkrk.linear <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the rk function fun <- function(x,y,env,outer.prod=FALSE) { ##% Check the inputs if (!(is.vector(x)&is.vector(y))) { stop("gss error in rk: inputs are of wrong types") } if ((min(x,y)env$max)) { stop("gss error in rk: inputs are out of range") } ##% Scale the inputs x <- (x-env$min)/(env$max-env$min) y <- (y-env$min)/(env$max-env$min) ##% Return the result rk <- function(x,y) { k1 <- function(x) (x-.5) k2 <- function(x) ((x-.5)^2-1/12)/2 k1(x)*k1(y)+k2(abs(x-y)) } if (outer.prod) outer(x,y,rk) else rk(x,y) } ## Return the function and the environment list(fun=fun,env=env) } ## Make RK for periodic linear splines mkrk.linear.per <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the rk function fun <- function(x,y,env,outer.prod=FALSE) { ##% Check the inputs if (!(is.vector(x)&is.vector(y))) { stop("gss error in rk: inputs are of wrong types") } if ((min(x,y)env$max)) { stop("gss error in rk: inputs are out of range") } ##% Scale the inputs x <- (x-env$min)/(env$max-env$min) y <- (y-env$min)/(env$max-env$min) ##% Return the result rk <- function(x,y) { k2 <- function(x) ((x-.5)^2-1/12)/2 k2(abs(x-y)) } if (outer.prod) outer(x,y,rk) else rk(x,y) } ## Return the function and the environment list(fun=fun,env=env) } gss/R/family.cv.R0000644000176200001440000001733013657765613013311 0ustar liggesusers##%%%%%%%%%% Binomial Family %%%%%%%%%% ## Calculate CV score for binomial regression cv.binomial <- function(y,eta,wt,hat,alpha) { if (is.vector(y)) y <- as.matrix(y) if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (dim(y)[2]==1) { if ((max(y)>1)|(min(y)<0)) stop("gss error: binomial responses should be between 0 and 1") m <- rep(1,dim(y)[1]) } else { if (min(y)<0) stop("gss error: paired binomial response should be nonnegative") m <- y[,1]+y[,2] y <- y[,1]/m } wtt <- wt * m odds <- exp(eta) p <- odds/(1+odds) w <- p/(1+odds) lkhd <- -sum(wtt*(y*eta-log(1+odds)))/sum(wtt) aux1 <- sum(hat/w)/(sum(wtt)-sum(hat)) aux2 <- sum(wtt*y/(1+odds))/sum(wtt) list(score=lkhd+abs(alpha)*aux1*aux2,varht=1,w=as.vector(wtt*w)) } ##%%%%%%%%%% Poisson Family %%%%%%%%%% ## Calculate CV score for Poisson regression cv.poisson <- function(y,eta,wt,hat,alpha,sr,q) { if (is.null(wt)) wt <- rep(1,length(y)) if (min(y)<0) stop("gss error: Poisson response should be nonnegative") nxi <- ncol(q) nn <- ncol(sr) nnull <- nn-nxi lambda <- exp(eta) w <- as.vector(lambda) lkhd <- -sum(wt*(y*eta-lambda))/sum(wt*y) ## matrix H mu <- apply(wt*w*sr,2,sum)/sum(wt*w) v <- t(sr)%*%(wt*w*sr)/sum(wt*w)-outer(mu,mu) v[(nnull+1):nn,(nnull+1):nn] <- v[(nnull+1):nn,(nnull+1):nn]+q/sum(wt*y) ## Cholesky decomposition of H suppressWarnings(z <- chol(v,pivot=TRUE)) v <- z rkv <- attr(z,"rank") while (v[rkv,rkv]1) { for (i in 1:(nnu-1)) { tmp <- 0 for (j in (i+1):nnu) tmp <- tmp+sum(wt*y[,j+1])/sum(wt) lkhd <- lkhd-tmp*nu[i] } } lkhd <- lkhd-sum(wt*eta*(1-y[,nnu+2]))/sum(wt) u <- -1+y[,nnu+2] for (i in 1:(nnu+1)) u <- u+(y[,i]+y[,i+1])*P[,i]/(1+P[,i]) w <- P[,2]/(1+P[,2])*P[,1]/(1+P[,1])^2 w <- w+1/(1+P[,nnu])*P[,nnu+1]/(1+P[,nnu+1])^2 if (nnu>1) { for (i in 2:nnu) w <- w+(P[,i+1]-P[,i-1])/(1+P[,i+1])/(1+P[,i-1])*P[,i]/(1+P[,i])^2 } aux1 <- sum(hat/w)/(sum(wt)-sum(hat)) aux2 <- sum(wt*u^2)/sum(wt) list(score=lkhd+alpha*aux1*aux2,varht=1,w=as.vector(wt*w)) } ##%%%%%%%%%% Weibull Family %%%%%%%%%% ## Calculate CV score for Weibull regression cv.weibull <- function(y,eta,wt,hat,nu,alpha) { if (is.vector(y)) stop("gss error: missing censoring indicator") if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") u <- nu*(delta-(xx^nu-zz^nu)*exp(-nu*eta)) w <- nu^2*(xx^nu-zz^nu)*exp(-nu*eta) lkhd <- sum(wt*((xx^nu-zz^nu)*exp(-nu*eta)-delta*(nu*(log(xx)-eta)+log(nu))))/sum(wt) aux1 <- sum(hat/w)/(sum(wt)-sum(hat)) aux2 <- sum(wt*nu*delta*abs(u))/sum(wt) list(score=lkhd+alpha*aux1*aux2,varht=1,w=as.vector(wt*w)) } ##%%%%%%%%%% Log Normal Family %%%%%%%%%% ## Calculate CV score for log normal regression cv.lognorm <- function(y,eta,wt,hat,nu,alpha) { if (is.vector(y)) stop("gss error: missing censoring indicator") if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) s.xx <- ifelse(xx<7,dnorm(xx)/(1-pnorm(xx)),xx+1/xx) s.zz <- ifelse(zz<7,dnorm(zz)/(1-pnorm(zz)),zz+1/zz) s.xx <- pmax(s.xx,s.zz) u <- nu*(delta*(s.xx-xx)-(s.xx-s.zz)) w <- (s.xx^2/2-xx*s.xx+xx^2/2+log(s.xx)+log(2*pi)/2) w <- nu^2*(w-ifelse(s.zz==0,0,(s.zz^2/2-zz*s.zz+zz^2/2+log(s.zz)+log(2*pi)/2))) w <- ifelse(w<1e-6,1e-6,w) aux1 <- sum(hat/w)/(sum(wt)-sum(hat)) aux2 <- sum(wt*nu*delta*abs((s.xx-xx)*u))/sum(wt) s.xx <- ifelse(xx<7,log(1-pnorm(xx)),-xx^2/2-log(xx+1/xx)-log(2*pi)/2) s.zz <- ifelse(zz<7,log(1-pnorm(zz)),-zz^2/2-log(zz+1/zz)-log(2*pi)/2) s.xx <- pmin(s.xx,s.zz) lkhd <- sum(wt*(delta*(xx^2/2+s.xx-log(nu))+s.zz-s.xx))/sum(wt) list(score=lkhd+alpha*aux1*aux2,varht=1,w=as.vector(wt*w)) } ##%%%%%%%%%% Log Logistic Family %%%%%%%%%% ## Calculate CV score for log logistic regression cv.loglogis <- function(y,eta,wt,hat,nu,alpha) { if (is.vector(y)) stop("gss error: missing censoring indicator") if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") xx <- 1/(1+exp(nu*(log(xx)-eta))) zz <- 1/(1+exp(nu*(log(zz)-eta))) u <- nu*(delta*xx-(zz-xx)) w <- nu^2/2*(zz^2-xx^2) lkhd <- sum(wt*(delta*(-log(1-xx)-log(nu))+log(zz)-log(xx)))/sum(wt) aux1 <- sum(hat/w)/(sum(wt)-sum(hat)) aux2 <- sum(wt*nu*delta*xx*abs(u))/sum(wt) list(score=lkhd+alpha*aux1*aux2,varht=1,w=as.vector(wt*w)) } gss/R/summary.sscopu.R0000644000176200001440000000230414404124146014401 0ustar liggesusers## Calculate Kendall's tau and Spearman's rho for 2-D copula density estimate summary.sscopu <- function(object,...) { ## Check input if (!inherits(object,"sscopu")) stop("gss error in summary.sscopu: not a sscopu object") if (dim(object$mdsty)[2]!=2) stop("gss error in summary.sscopu: not a 2-D copula") ## Set up quadrature hsz <- 40 qdsz <- 2*hsz qd <- gauss.quad(qdsz,c(0,1)) gap <- diff(qd$pt) g.wk <- gap[hsz]/2 for (i in 1:(hsz-2)) g.wk <- c(g.wk,gap[hsz+i]-g.wk[i]) g.wk <- 2*g.wk pp <- qd$pt[1]/(1/2-sum(g.wk)) adj <- c(pp,rep(.5,qdsz-2),1-pp) qd.pt <- cbind(rep(qd$pt,qdsz),rep(qd$pt,rep(qdsz,qdsz))) ## Calculate cdf d.qd <- dsscopu(object,qd.pt) d.qd.wk <- matrix(d.qd,qdsz,qdsz) f.qd <- NULL for (i in 1:qdsz) { for (j in 1:qdsz) { wt1 <- qd$wt[1:i] wt1[i] <- wt1[i]*adj[i] wt2 <- qd$wt[1:j] wt2[j] <- wt2[j]*adj[j] f.qd <- c(f.qd,sum(d.qd.wk[1:i,1:j]*outer(wt1,wt2))) } } ## Calculate tau and rho tau <- 4*sum(f.qd*d.qd*outer(qd$wt,qd$wt))-1 rho <- 12*sum(d.qd*outer(qd$pt*qd$wt,qd$pt*qd$wt))-3 ## return list(tau=tau,rho=rho) } gss/R/hzdrate.sshzd2d.R0000644000176200001440000001107212355360634014423 0ustar liggesusershzdrate.sshzd2d <- ## Compute hazard rate function(object,time,covariates=NULL) { if (is.vector(time)) time <- rbind(NULL,time) s1 <- survexp.sshzd2d(object,time[,1],covariates,1) s2 <- survexp.sshzd2d(object,time[,2],covariates,2) s12 <- survexp.sshzd2d(object,time,covariates) wk <- data.frame(time[,1],time[,2]) names(wk) <- c(object$hzd1$tname,object$hzd2$tname) wk <- cbind(wk,covariates) h1 <- hzdrate.sshzd(object$hzd1,wk) h2 <- hzdrate.sshzd(object$hzd2,wk) as.vector(s1*h1*s2*h2*dsscopu(object$copu,cbind(s1,s2))/s12) } survexp.sshzd2d <- ## Compute survival function function(object,time,covariates=NULL,job=3) { if (!(job%in%1:3)) stop("gss error in survexp.sshzd2d: job must be 1, 2, or 3") if (is.vector(time)&(job==3)) time <- rbind(NULL,time) if (job!=3) { if (!is.null(covariates)) { nt <- dim(covariates)[1] if (nt==1) z <- switch(job,survexp.sshzd(object$hzd1,time,covariates), survexp.sshzd(object$hzd2,time,covariates)) else { if (nt!=length(time)) stop("gss error in survexp.sshzd2d: time and covariates must match in size") z <- NULL for (i in 1:nt) z <- c(z,switch(job, survexp.sshzd(object$hzd1,time[i], covariates[i,,drop=FALSE]), survexp.sshzd(object$hzd2,time[i], covariates[i,,drop=FALSE]))) } } else z <- switch(job,survexp.sshzd(object$hzd1,time), survexp.sshzd(object$hzd2,time)) } else { ## Set up quadrature hsz <- 40 qdsz <- 2*hsz qd <- gauss.quad(qdsz,c(0,1)) gap <- diff(qd$pt) g.wk <- gap[hsz]/2 for (i in 1:(hsz-2)) g.wk <- c(g.wk,gap[hsz+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,1/2-sum(g.wk)) gap[hsz:1] <- gap[hsz+(1:hsz)] <- g.wk brk <- cumsum(c(0,gap))[-(qdsz+1)] qd.pt <- cbind(rep(qd$pt,qdsz),rep(qd$pt,rep(qdsz,qdsz))) d.qd <- matrix(dsscopu(object$copu,qd.pt),qdsz,qdsz) if (!is.null(covariates)) { nt <- dim(covariates)[1] if (nt==1) { s1 <- survexp.sshzd(object$hzd1,time[,1],covariates) s2 <- survexp.sshzd(object$hzd2,time[,2],covariates) z <- NULL for (i in 1:dim(time)[1]) { ind1 <- (1:qdsz)[brk10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } kl <- rkl(zz$est) } } else kl <- rkl() } else { z <- .Fortran("cdenrkl", cd=as.double(d), as.integer(nnull), as.double(aperm(qd.s,c(1,3,2))), as.integer(nmesh), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(t(fit0)), as.double(.Machine$double.eps), wt=double(nmesh*nx), double(nmesh*nx), double(nnull), double(nnull), double(nnull*nnull), double(nnull*nnull), integer(nnull), double(nnull), as.double(1e-6), as.integer(30), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.sscden: Newton iteration diverges") if (z$info==2) warning("gss warning in project.sscden: Newton iteration fails to converge") kl <- z$wt[1] } ## cfit cfit <- matrix(1,nmesh,nx) for (ylab in object$ynames) { y <- object$mf[[ylab]] if (is.factor(y)) { lvl <- levels(y) if (is.null(object$cnt)) wk <- table(y) else wk <- table(rep(y,object$cnt)) wk <- wk/sum(wk) nlvl <- length(wk) for (j in 1:nlvl) { id <- (1:nmesh)[qd.pt[,ylab]==lvl[j]] cfit[id,] <- cfit[id,]*wk[j] } } else { if (!is.vector(y)) qd.wk <- object$yquad else qd.wk <- NULL qd.wk <- object$yquad form <- as.formula(paste("~",ylab)) wk <- ssden(form,data=object$mf,quad=qd.wk, domain=object$ydomain,alpha=object$alpha, id.basis=object$id.basis) cfit <- cfit*dssden(wk,qd.pt[ylab]) } } cfit <- t(cfit*qd.wt) ## return kl0 <- 0 for (i in 1:nx) { wk <- sum(log(fit0[i,]/cfit[i,])*fit0[i,]) kl0 <- kl0 + xx.wt[i]*wk } list(ratio=kl/kl0,kl=kl) } gss/R/mkran.R0000644000176200001440000000554713053636442012523 0ustar liggesusers## Make random effects for mixed-effect models mkran <- function(formula,data) { ## decipher formula form.wk <- terms.formula(formula)[[2]] terms <- strsplit(deparse(form.wk),' \\+ ')[[1]] if (length(terms)>1) { form <- as.formula(paste("~",terms[1])) zzz <- mkran(form,data) for (i in 2:length(terms)) { form <- as.formula(paste("~",terms[i])) zzz <- mkran1(zzz,mkran(form,data)) } return(zzz) } if (!("|"%in%strsplit(deparse(form.wk),'')[[1]])) stop("gss error in mkran: missing | in grouping formula") term.wk <- strsplit(deparse(form.wk),' \\| ')[[1]] with(data,{ ## make matrix Z z2.wk <- eval(parse(text=term.wk[2])) if (!is.factor(z2.wk)) stop(paste("gss error in mkran: ", term.wk[2], " should be a factor")) z <- NULL lvl.z2 <- levels(z2.wk) for (i in lvl.z2) z <- cbind(z,as.numeric(z2.wk==i)) ## make sigma function if (term.wk[1]=="1") { init <- 0 env <- length(levels(z2.wk)) fun <- function(zeta,env) diag(10^(-zeta),env) sigma <- list(fun=fun,env=env) } else { z1.wk <- eval(parse(text=term.wk[1])) if (!is.factor(z1.wk)) stop(paste("gss error in mkran: ", term.wk[1], " should be a factor")) ind <- lvl.wk <- NULL nz <- length(lvl.z2) nsig <- length(levels(z1.wk)) for (i in levels(z1.wk)) { zz.wk <- z2.wk[z1.wk==i,drop=TRUE] ind <- c(ind,list((1:nz)[lvl.z2%in%levels(zz.wk)])) lvl.wk <- c(lvl.wk,levels(zz.wk)) } if (max(table(lvl.wk)>1)) stop("gss error in mkran: ", term.wk[2], " should be nested under ", term.wk[1]) init <- rep(0, length(levels(z1.wk))) env <- list(size=nz,nsig=nsig,ind=ind) fun <- function(zeta,env) { wk <- rep(0,env$size) for (i in 1:env$nsig) wk[env$ind[[i]]] <- 10^(-zeta[i]) diag(wk) } sigma <- list(fun=fun,env=env) } list(z=z,sigma=sigma,init=init) }) } ## Combine random effects for mixed-effect models mkran1 <- function(ran1,ran2) { z <- cbind(ran1$z,ran2$z) env <- list(sz1=dim(ran1$z)[2],sig1=ran1$sigma,nz1=length(ran1$init), sz2=dim(ran2$z)[2],sig2=ran2$sigma,nz2=length(ran2$init)) fun <- function(zeta,env) { idx1 <- 1:env$sz1 idx2 <- env$sz1+(1:env$sz2) sig <- matrix(0,env$sz1+env$sz2,env$sz1+env$sz2) sig[idx1,idx1] <- env$sig1$fun(zeta[1:env$nz1],env$sig1$env) sig[idx2,idx2] <- env$sig2$fun(zeta[env$nz1+(1:env$nz2)],env$sig2$env) sig } sigma <- list(fun=fun,env=env) list(z=z,sigma=sigma,init=c(ran1$init,ran2$init)) } gss/R/predict.sscox.R0000644000176200001440000000553114404122612014162 0ustar liggesusers## Evaluate hazard estimate predict.sscox <- function (object,newdata,se.fit=FALSE, include=c(object$terms$labels,object$lab.p),...) { if (!inherits(object,"sscox")) stop("gss error in predict.sscox: not a sscox object") nnew <- nrow(newdata) nbasis <- length(object$id.basis) nnull <- length(object$d) nz <- length(object$b) nn <- nbasis + nnull + nz labels.p <- object$lab.p ## Extract included terms if (!is.null(object$d)) s <- matrix(0,nnew,nnull) r <- matrix(0,nnew,nbasis) for (label in include) { if (label%in%labels.p) next xx <- object$mf[object$id.basis,object$terms[[label]]$vlist] xnew <- newdata[,object$terms[[label]]$vlist] nphi <- object$terms[[label]]$nphi nrk <- object$terms[[label]]$nrk if (nphi) { iphi <- object$terms[[label]]$iphi phi <- object$terms[[label]]$phi for (i in 1:nphi) { s[,iphi+(i-1)] <- phi$fun(xnew,nu=i,env=phi$env) } } if (nrk) { irk <- object$terms[[label]]$irk rk <- object$terms[[label]]$rk for (i in 1:nrk) { r <- r + 10^object$theta[irk+(i-1)]* rk$fun(xnew,xx,nu=i,env=rk$env,out=TRUE) } } } if (!is.null(object$partial)) { vars.p <- as.character(attr(object$partial$mt,"variables"))[-1] facs.p <- attr(object$partial$mt,"factors") vlist <- vars.p[as.logical(apply(facs.p,1,sum))] for (lab in labels.p) { if (lab%in%include) { vlist.wk <- vars.p[as.logical(facs.p[,lab])] vlist <- vlist[!(vlist%in%vlist.wk)] } } if (length(vlist)) { for (lab in vlist) newdata[[lab]] <- 0 } matx.p <- model.matrix(object$partial$mt,newdata)[,-1,drop=FALSE] matx.p <- sweep(matx.p,2,object$partial$center) matx.p <- sweep(matx.p,2,object$partial$scale,"/") nu <- nnull-dim(matx.p)[2] for (label in labels.p) { nu <- nu+1 if (label%in%include) s[,nu] <- matx.p[,label] } } ## random effects if (nz) { if (is.null(newdata$random)) z.wk <- matrix(0,nnew,nz) else z.wk <- newdata$random rs <- cbind(r,z.wk,s) } else rs <- cbind(r,s) if (!se.fit) as.vector(exp(rs%*%c(object$c,object$b,object$d))) else { fit <- as.vector(exp(rs%*%c(object$c,object$b,object$d))) se.fit <- .Fortran("hzdaux2", as.double(object$se.aux$v), as.integer(dim(rs)[2]), as.integer(object$se.aux$jpvt), as.double(t(rs)), as.integer(dim(rs)[1]), se=double(dim(rs)[1]), PACKAGE="gss")[["se"]] list(fit=fit,se.fit=se.fit) } } gss/R/project.ssden.R0000644000176200001440000001463012355360640014163 0ustar liggesusers## Calculate Kullback-Leibler projection from ssden objects project.ssden <- function(object,include,mesh=FALSE,...) { qd.pt <- object$quad$pt qd.wt <- object$quad$wt bias <- object$bias ## evaluate full model mesh0 <- dssden(object,qd.pt) qd.wt <- qd.wt*bias$qd.wt qd.wt <- t(t(qd.wt)/apply(qd.wt*mesh0,2,sum)) ## extract terms in subspace nqd <- dim(qd.wt)[1] nxi <- length(object$id.basis) qd.s <- qd.r <- q <- NULL theta <- d <- NULL n0.wk <- nq.wk <- nq <- 0 for (label in object$terms$labels) { x.basis <- object$mf[object$id.basis,object$term[[label]]$vlist] qd.x <- qd.pt[,object$term[[label]]$vlist] nphi <- object$term[[label]]$nphi nrk <- object$term[[label]]$nrk if (nphi) { phi <- object$term[[label]]$phi for (i in 1:nphi) { n0.wk <- n0.wk + 1 if (!any(label==include)) next d <- c(d,object$d[n0.wk]) qd.s <- cbind(qd.s,phi$fun(qd.x,nu=i,env=phi$env)) } } if (nrk) { rk <- object$term[[label]]$rk for (i in 1:nrk) { nq.wk <- nq.wk + 1 if (!any(label==include)) next nq <- nq + 1 theta <- c(theta,object$theta[nq.wk]) qd.r <- array(c(qd.r,rk$fun(x.basis,qd.x,nu=i,env=rk$env,out=TRUE)), c(nxi,nqd,nq)) q <- cbind(q,rk$fun(x.basis,x.basis,nu=i,env=rk$env,out=FALSE)) } } } if (is.null(qd.s)&is.null(qd.r)) stop("gss error in project.ssden: include some terms") if (!is.null(qd.s)) { nn <- nxi + ncol(qd.s) qd.s <- t(qd.s) } else nn <- nxi ## calculate projection rkl <- function(theta1=NULL) { theta.wk <- 1:nq theta.wk[fix] <- theta[fix] if (nq-1) theta.wk[-fix] <- theta1 qd.rs <- 0 for (i in 1:nq) qd.rs <- qd.rs + 10^theta.wk[i]*qd.r[,,i] qd.rs <- rbind(qd.rs,qd.s) z <- .Fortran("drkl", cd=as.double(cd), as.integer(nn), as.double(t(qd.rs)), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(t(qd.wt)), mesh=as.double(mesh0), as.double(.Machine$double.eps), as.double(1e-6), as.integer(30), integer(nn), double(2*bias$nt*(nqd+1)+nn*(2*nn+4)), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.ssden: Newton iteration diverges") if (z$info==2) warning("gss warning in project.ssden: Newton iteration fails to converge") assign("cd",z$cd,inherits=TRUE) assign("mesh1",z$mesh,inherits=TRUE) sum(bias$wt*(apply(qd.wt*log(mesh0/mesh1)*mesh0,2,sum)+ log(apply(qd.wt*mesh1,2,sum)))) } cv.wk <- function(theta) cv.scale*rkl(theta)+cv.shift if (nq) { ## initialization if (is.null(qd.s)) theta.wk <- 0 else { qd.r.wk <- 0 for (i in 1:nq) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] vv.s <- vv.r <- 0 for (i in 1:bias$nt) { mu.s <- apply(qd.wt[,i]*qd.s,2,sum)/sum(qd.wt[,i]) v.s <- apply(qd.wt[,i]*qd.s^2,2,sum)/sum(qd.wt[,i]) v.s <- v.s - mu.s^2 mu.r <- apply(qd.wt[,i]*qd.r.wk,2,sum)/sum(qd.wt[,i]) v.r <- apply(qd.wt[,i]*qd.r.wk^2,2,sum)/sum(qd.wt[,i]) v.r <- v.r - mu.r^2 vv.s <- vv.s + bias$wt[i]*v.s vv.r <- vv.r + bias$wt[i]*v.r } theta.wk <- log10(sum(vv.s)/(nn-nxi)/sum(vv.r)*nxi) / 2 } theta <- theta + theta.wk tmp <- NULL for (i in 1:nq) tmp <- c(tmp,10^theta[i]*sum(q[,i])) fix <- rev(order(tmp))[1] ## projection cd <- c(10^(-theta.wk)*object$c,d) mesh1 <- NULL if (nq-1) { if (object$skip.iter) kl <- rkl(theta[-fix]) else { if (nq-2) { ## scale and shift cv tmp <- abs(rkl(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } kl <- rkl(zz$est) } } else kl <- rkl() } else { nn <- nrow(qd.s) z <- .Fortran("drkl", cd=as.double(d), as.integer(nn), as.double(qd.s), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(t(qd.wt)), mesh=as.double(mesh0), as.double(.Machine$double.eps), as.double(1e-6), as.integer(30), integer(nn), double(2*bias$nt*(nqd+1)+nn*(2*nn+4)), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.ssden: Newton iteration diverges") if (z$info==2) warning("gss warning in project.ssden: Newton iteration fails to converge") mesh1 <- z$mesh kl <- sum(bias$wt*(apply(qd.wt*log(mesh0/mesh1)*mesh0,2,sum)+ log(apply(qd.wt*mesh1,2,sum)))) } kl0 <- sum(bias$wt*(apply(qd.wt*log(mesh0)*mesh0,2,sum)+ log(apply(qd.wt,2,sum)))) kl <- sum(bias$wt*(apply(qd.wt*log(mesh0/mesh1)*mesh0,2,sum)+ log(apply(qd.wt*mesh1,2,sum)))) wt.wk <- t(t(qd.wt)/apply(qd.wt*mesh1,2,sum)) kl1 <- sum(bias$wt*(apply(wt.wk*log(mesh1)*mesh1,2,sum)+ log(apply(wt.wk,2,sum)))) obj <- list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) if (mesh) obj$mesh <- mesh1 obj } gss/R/project.ssanova.R0000644000176200001440000001151413053657574014532 0ustar liggesusers## S3 method project <- function (object,...) UseMethod("project") ## Calculate Kullback-Leibler projection from ssanova objects project.ssanova <- function(object,include,...) { if (class(object)[1]=="ssanova0") stop("gss error: square error projection is not implemented for ssanova0") nobs <- nrow(object$mf) nxi <- length(object$id.basis) labels.p <- object$lab.p ## evaluate full model mf <- object$mf yy <- fitted(object) wt <- model.weights(object$mf) if (!is.null(wt)) wt.wk <- sqrt(wt) offset <- model.offset(object$mf) if (!is.null(object$random)) { if (is.null(offset)) offset <- 0 offset <- offset + object$random$z%*%object$b } if (!is.null(offset)) yy <- yy - offset ## extract terms in subspace s <- matrix(1,nobs,1) r <- NULL theta <- NULL nq.wk <- nq <- 0 for (label in object$terms$labels) { if (label=="1") next if (label%in%labels.p) next x <- object$mf[,object$term[[label]]$vlist] x.basis <- object$mf[object$id.basis,object$term[[label]]$vlist] nphi <- object$term[[label]]$nphi nrk <- object$term[[label]]$nrk if (nphi) { phi <- object$term[[label]]$phi for (i in 1:nphi) { if (!any(label==include)) next s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } } if (nrk) { rk <- object$term[[label]]$rk for (i in 1:nrk) { nq.wk <- nq.wk + 1 if (!any(label==include)) next nq <- nq + 1 theta <- c(theta,object$theta[nq.wk]) r <- array(c(r,rk$fun(x,x.basis,nu=i,env=rk$env,out=TRUE)), c(nobs,nxi,nq)) } } } if (!is.null(object$partial)) { matx.p <- model.matrix(object$partial$mt,mf)[,-1,drop=FALSE] matx.p <- scale(matx.p) for (label in labels.p) { if (label%in%include) s <- cbind(s,matx.p[,label]) } } ## calculate projection my.ls <- function(theta1=NULL) { if (!nq) { q <- matrix(0) sr <- cbind(s,0) } else { theta.wk <- 1:nq theta.wk[fix] <- theta[fix] if (nq-1) theta.wk[-fix] <- theta1 sr <- 0 for (i in 1:nq) sr <- sr + 10^theta.wk[i]*r[,,i] q <- 10^(-5)*sr[object$id.basis,] sr <- cbind(s,sr) } nn <- ncol(as.matrix(sr)) nnull <- nn-nxi if (!is.null(wt)) { sr <- wt.wk*sr yy.wk <- wt.wk*yy } else yy.wk <- yy z <- .Fortran("reg", as.double(sr), as.integer(nobs), as.integer(nnull), as.double(q), as.integer(nxi), as.double(yy.wk), as.integer(4), double(1), double(1), double(1), dc=double(nn), as.double(.Machine$double.eps), double(nn*nn), double(nn), as.integer(rep(0,nn)), double(max(nobs,nn)), integer(1), integer(1), PACKAGE="gss")["dc"] assign("yhat",sr%*%z$dc,inherits=TRUE) if (!is.null(wt)) sum(wt*(yy-yhat/wt.wk)^2)/sum(wt) else mean((yy-yhat)^2) } cv.wk <- function(theta) cv.scale*my.ls(theta)+cv.shift ## initialization if (nq) { r.wk <- 0 for (i in 1:nq) r.wk <- r.wk + 10^theta[i]*r[,,i] if (is.null(s)) theta.wk <- 0 else theta.wk <- log10(sum(s^2)/ncol(s)/sum(r.wk^2)*nxi) / 2 theta <- theta + theta.wk tmp <- NULL for (i in 1:nq) tmp <- c(tmp,10^theta[i]*sum(r[cbind(object$id.basis,1:nxi,i)])) fix <- rev(order(tmp))[1] } ## projection yhat <- NULL if (nq>1) { if (object$skip.iter) kl <- my.ls(theta[-fix]) else { ## scale and shift cv tmp <- abs(my.ls(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) if (zz$code>3) warning("gss warning in project.ssanova: theta iteration fails to converge") kl <- my.ls(zz$est) } } else kl <- my.ls() if (!is.null(wt)) { yhat <- yhat/wt.wk ymean <- sum(wt*yy)/sum(wt) kl0 <- sum(wt*(yy-ymean)^2)/sum(wt) kl <- sum(wt*(yy-yhat)^2)/sum(wt) kl1 <- sum(wt*(ymean-yhat)^2)/sum(wt) } else { kl0 <- mean((yy-mean(yy))^2) kl <- mean((yy-yhat)^2) kl1 <- mean((mean(yy)-yhat)^2) } list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) } gss/R/predict9.gssanova.R0000644000176200001440000000462313653355303014750 0ustar liggesusers## S3 method predict9 <- function (object,...) UseMethod("predict9") ## Calculate prediction and Bayesian SE from ssanova objects predict9.gssanova <- function(object,newdata,ci=FALSE,level=.95,nu=NULL,...) { est <- predict(object,newdata,se.fit=ci) if (object$family=="binomial") { if (!ci) return(plogis(est)) else { z <- est$fit+outer(est$se.fit*qnorm(1-(1-level)/2),c(0,-1,1)) z <- plogis(z) return(list(fit=z[,1],lcl=z[,2],ucl=z[,3])) } } if (object$family%in%c("poisson","Gamma","inverse.gaussian")) { if (!ci) return(exp(est)) else { z <- est$fit+outer(est$se.fit*qnorm(1-(1-level)/2),c(0,-1,1)) z <- exp(z) return(list(fit=z[,1],lcl=z[,2],ucl=z[,3])) } } if (object$family=="nbinomial") { if (!is.vector(model.response(object$mf))) { if (is.null(nu)) stop("gss error: nu is missing for nbinomial family with 2 column response" ) } else nu <- object$nu if (!ci) return(nu/exp(est)) else { z <- est$fit+outer(est$se.fit*qnorm(1-(1-level)/2),c(0,1,-1)) z <- nu/exp(z) return(list(fit=z[,1],lcl=z[,2],ucl=z[,3])) } } if (object$family=="weibull") { gg <- gamma(1+1/object$nu) if (!ci) return(gg*exp(est)) else { z <- est$fit+outer(est$se.fit*qnorm(1-(1-level)/2),c(0,-1,1)) z <- gg*exp(z) return(list(fit=z[,1],lcl=z[,2],ucl=z[,3])) } } if (object$family=="lognorm") { gg <- exp(1/2/object$nu^2) if (!ci) return(gg*exp(est)) else { z <- est$fit+outer(est$se.fit*qnorm(1-(1-level)/2),c(0,-1,1)) z <- gg*exp(z) return(list(fit=z[,1],lcl=z[,2],ucl=z[,3])) } } if (object$family=="loglogis") { gg <- pi/object$nu/sin(pi/object$nu) if (!ci) return(gg*exp(est)) else { z <- est$fit+outer(est$se.fit*qnorm(1-(1-level)/2),c(0,-1,1)) z <- gg*exp(z) return(list(fit=z[,1],lcl=z[,2],ucl=z[,3])) } } if (object$family=="polr") { P <- plogis(outer(est,c(0,cumsum(object$nu)),"+")) z <- P[,1] J <- dim(P)[2] for (i in 2:J) z <- cbind(z,P[,i]-P[,i-1]) z <- cbind(z,1-P[,J]) colnames(z) <- NULL return(z) } } gss/R/sshzd1.R0000644000176200001440000005743014467014320012620 0ustar liggesusers## Fit hazard model sshzd1 <- function(formula,type=NULL,data=list(),alpha=1.4, weights=NULL,subset,na.action=na.omit,rho="marginal", partial=NULL,id.basis=NULL,nbasis=NULL,seed=NULL, random=NULL,prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Local functions handling formula Surv <- function(time,status,start=0) { tname <- as.character(as.list(match.call())$time) if (!is.numeric(time)|!is.vector(time)) stop("gss error in sshzd1: time should be a numerical vector") if ((nobs <- length(time))-length(status)) stop("gss error in sshzd1: time and status mismatch in size") if ((length(start)-nobs)&(length(start)-1)) stop("gss error in sshzd1: time and start mismatch in size") if (any(start>time)) stop("gss error in sshzd1: start after follow-up time") if (min(start)<0) stop("gss error in sshzd1: start before time 0") time <- cbind(start,time) list(tname=tname,start=time[,1],end=time[,2],status=as.logical(status)) } ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$alpha <- mf$random <- mf$partial <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- mf$rho <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ## response resp <- attr(term.wk,"variable")[[2]] ind.wk <- length(strsplit(deparse(resp),'')[[1]]) if ((substr(deparse(resp),1,5)!='Surv(') |(substr(deparse(resp),ind.wk,ind.wk)!=')')) stop("gss error in sshzd1: response should be Surv(...)") yy <- with(data,eval(resp)) tname <- yy$tname ## model frame term.labels <- attr(term.wk,"term.labels") if (!(tname%in%term.labels)) stop("gss error in sshzd1: time main effect missing in model") mf[[1]] <- as.name("model.frame") mf[[2]] <- eval(parse(text=paste("~",paste(term.labels,collapse="+")))) mf <- eval(mf,parent.frame()) ## Use sshzd in lack of covariate if (all(tname==names(mf))) stop("use sshzd when covariate is absent") ## trim yy if subset is used nobs <- nrow(mf) if (nobssum(yy$status)) nbasis <- sum(yy$status) if (!is.null(seed)) set.seed(seed) id.basis <- sample((1:nobs)[yy$status],nbasis,prob=cnt[yy$status]) } else { if (!all(id.basis%in%(1:nobs)[yy$status])) stop("gss error in sshzd1: id.basis not all at failure cases") nbasis <- length(id.basis) } id.wk <- NULL nT <- sum(yy$status) for (i in 1:nbasis) { id.wk <- c(id.wk,(1:nT)[(1:nobs)[yy$status]%in%id.basis[i]]) } ## set domain and type for time mn <- min(yy$start) mx <- max(yy$end) tdomain <- c(max(mn-.05*(mx-mn),0),mx) if (is.null(type[[tname]])) type[[tname]] <- list("cubic",tdomain) if (length(type[[tname]])==1) type[[tname]] <- c(type[[tname]],tdomain) if (!(type[[tname]][[1]]%in%c("cubic","linear"))) stop("gss error in sshzd1: wrong type") if ((min(type[[tname]][[2]])>min(tdomain))| (max(type[[tname]][[2]])yy$start[i]) if (is.vector(rho.qd)) wk <- wk*rho.qd else wk <- wk*rho.qd[,x.ind[i]] if (is.null(cnt)) qd.wt[,x.ind[i]] <- qd.wt[,x.ind[i]]+wk else qd.wt[,x.ind[i]] <- qd.wt[,x.ind[i]]+cnt[i]*wk } if (is.null(cnt)) qd.wt <- quad$wt*qd.wt/nobs else qd.wt <- quad$wt*qd.wt/sum(cnt) ## Generate s, r, int.s, and int.r s <- r <- int.s <- int.r <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nT)) int.s <- c(int.s,sum(qd.wt)) next } vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] xy <- mf[yy$status,vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist if (tname%in%vlist) qd.xy[,tname] <- quad$pt if (length(x.list)) xx <- x.pt[,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { s <- cbind(s,phi$fun(xy,nu=i,env=phi$env)) if (is.null(xx)) { qd.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) int.s <- c(int.s,sum(qd.wk*apply(qd.wt,1,sum))) } else { int.s.wk <- 0 for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- phi$fun(qd.xy[,,drop=TRUE],i,phi$env) int.s.wk <- int.s.wk + sum(qd.wk*qd.wt[,j]) } int.s <- c(int.s,int.s.wk) } } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE)),c(nT,nbasis,nq)) if (is.null(xx)) { qd.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,out=TRUE) int.r <- cbind(int.r,apply(apply(qd.wt,1,sum)*qd.wk,2,sum)) } else { int.r.wk <- 0 for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,TRUE) int.r.wk <- int.r.wk + apply(qd.wt[,j]*qd.wk,2,sum) } int.r <- cbind(int.r,int.r.wk) } } } } ## Add the partial term if (!is.null(partial)) { s <- cbind(s,matx.p[yy$status,]) int.s <- c(int.s,t(matx.p[!x.dup.ind,])%*%apply(qd.wt,2,sum)) part$pt <- matx.p[!x.dup.ind,,drop=FALSE] } ## generate int.z if (!is.null(random)) random$int.z <- t(qd.z)%*%apply(qd.wt,2,sum) ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rankalpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.s.wk <- function(lambda) cv.scale*cv.s(lambda)+cv.shift cv.m <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- int.r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] int.r.wk0 <- int.r.wk0 + 10^theta[i]*int.r[,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("int.r.wk",int.r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk int.r.wk0 <- int.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] int.r.wk0 <- int.r.wk0 + theta.wk*int.r[,i] } } q.wk <- r.wk0[id.wk,] if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { r.wk0 <- cbind(r.wk0,10^ran.scal*random$z) int.r.wk0 <- c(int.r.wk0,10^ran.scal*random$int.z) q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(theta[-(1:nq)],random$sigma$env) } fit <- .Fortran("hzdnewton10", cd=as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(r.wk0,s)), as.integer(nT), as.integer(Nobs), as.double(sum(cnt)), as.double(cnt), as.double(c(int.r.wk0,int.s)), as.double(rho), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*nT+nn*(nn+3)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in sshzd: Newton iteration diverges") if (fit$info==2) warning("gss warning in sshzd: Newton iteration fails to converge") assign("cd",fit$cd,inherits=TRUE) cv <- fit$wk[1]+alpha*fit$wk[2] alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.m.wk <- function(theta) cv.scale*cv.m(theta)+cv.shift ## Initialization theta <- -log10(apply(r[id.wk,,,drop=FALSE],3,function(x)sum(diag(x)))) nq <- length(theta) r.wk <- int.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } v.r <- sum(rho*r.wk^2) if (nnull) { v.s <- sum(rho*s^2) theta.wk <- log10(v.s/nnull/v.r*nxi) / 2 } else theta.wk <- 0 if (!is.null(random)) { v.z <- sum(rho*random$z^2) ran.scal <- theta.wk - log10(v.z/nz/v.r*nxi) / 2 } else ran.scal <- NULL theta <- theta + theta.wk r.wk <- 10^theta.wk*r.wk int.r.wk <- 10^theta.wk*int.r.wk q.wk <- r.wk[id.wk,] if (!is.null(random)) { r.wk <- cbind(r.wk,10^ran.scal*random$z) int.r.wk <- c(int.r.wk,10^ran.scal*random$int.z) } log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk ## fixed theta iteration cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (nq==1) { if (!is.null(cnt)) rho <- rho*cnt if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("hzdaux101", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(r.wk,s)), as.integer(nT), as.double(rho/Nobs), as.double(.Machine$double.eps), v=double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,se.aux=se.aux)) } ## theta adjustment for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(cd[1:nxi])%*%r[id.wk,,i]%*%cd[1:nxi]) } r.wk <- int.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } v.r <- sum(rho*r.wk^2) if (nnull) { v.s <- sum(rho*s^2) theta.wk <- log10(v.s/nnull/v.r*nxi) / 2 } else theta.wk <- 0 if (!is.null(random)) { v.z <- sum(rho*random$z^2) ran.scal <- theta.wk - log10(v.z/nz/v.r*nxi) / 2 } else ran.scal <- NULL theta <- theta + theta.wk r.wk <- 10^theta.wk*r.wk int.r.wk <- 10^theta.wk*int.r.wk q.wk <- r.wk[id.wk,] if (!is.null(random)) { r.wk <- cbind(r.wk,10^ran.scal*random$z) int.r.wk <- c(int.r.wk,10^ran.scal*random$int.z) } log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk log.th0 <- theta-log.la0 ## fixed theta iteration cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } ## early return if (skip.iter) { if (!is.null(cnt)) rho <- rho*cnt if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("hzdaux101", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(r.wk,s)), as.integer(nT), as.double(rho/Nobs), as.double(.Machine$double.eps), v=double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,se.aux=se.aux)) } ## theta search counter <- 0 r.wk <- int.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } theta.old <- theta if (!is.null(random)) theta <- c(theta,zeta) tmp <- abs(cv.m(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.m.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd1: CV iteration fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale if (is.null(random)) { theta <- zz$est zeta <- NULL } else { theta <- zz$est[1:nq] zeta <- zz$est[-(1:nq)] } ## return if (!is.null(cnt)) rho <- rho*cnt r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.wk,] if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { r.wk <- cbind(r.wk,10^ran.scal*random$z) q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("hzdaux101", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(r.wk,s)), as.integer(nT), as.double(rho/Nobs), as.double(.Machine$double.eps), v=double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,se.aux=se.aux) } gss/R/nlm0.R0000644000176200001440000000506213504067712012250 0ustar liggesusers## minimization of univariate function on finite intervals ## using 3-point quadratic fit with golden-section safe-guard nlm0 <- function(fun,range,prec=1e-7) { ratio <- 2/(sqrt(5)+1) ll.x <- min(range) uu.x <- max(range) if (uu.x-ll.xuu.x)|(deltarange.l) nn.x <- uu.x - ratio*range.u else nn.x <- ll.x + ratio*range.l } ## Update middle points nn.fit <- fun(nn.x) neval <- neval + 1 if (nn.x1) { if (object$skip.iter) kl <- my.ls(theta[-fix]) else { ## scale and shift cv tmp <- abs(my.ls(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) if (zz$code>3) warning("gss warning in project.ssanova: theta iteration fails to converge") kl <- my.ls(zz$est) } } else kl <- my.ls() yhat.wk <- forwardsolve(t(ww),yhat) one.wk <- forwardsolve(t(ww),rep(1,nobs)) ymean <- sum(one.wk*yy.wk)/sum(one.wk^2) kl0 <- sum((yy.wk-ymean*one.wk)^2)/sum(one.wk^2) kl <- sum((yy.wk-yhat.wk)^2)/sum(one.wk^2) kl1 <- sum((yhat.wk-ymean*one.wk)^2)/sum(one.wk^2) list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) } gss/R/ssden.R0000644000176200001440000003502614466741225012527 0ustar liggesusers## Fit density model ssden <- function(formula,type=NULL,data=list(),alpha=1.4, weights=NULL,subset,na.action=na.omit, id.basis=NULL,nbasis=NULL,seed=NULL, domain=as.list(NULL),quad=NULL, qdsz.depth=NULL,bias=NULL, prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$alpha <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$domain <- mf$quad <- mf$qdsz.depth <- mf$bias <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) cnt <- model.weights(mf) mf$"(weights)" <- NULL ## Generate sub-basis nobs <- dim(mf)[1] if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in ssden: id.basis out of range") nbasis <- length(id.basis) } ## Set domain and/or generate quadrature if (is.null(quad)) { ## Set domain and type fac.list <- NULL for (xlab in names(mf)) { x <- mf[[xlab]] if (is.factor(x)) { fac.list <- c(fac.list,xlab) domain[[xlab]] <- NULL } else { if (!is.vector(x)) stop("gss error in ssden: no default quadrature") if (is.null(domain[[xlab]])) { mn <- min(x) mx <- max(x) domain[[xlab]] <- c(mn,mx)+c(-1,1)*(mx-mn)*.05 } else domain[[xlab]] <- c(min(domain[[xlab]]),max(domain[[xlab]])) if (is.null(type[[xlab]])) type[[xlab]] <- list("cubic",domain[[xlab]]) else { if (length(type[[xlab]])==1) type[[xlab]] <- list(type[[xlab]][[1]],domain[[xlab]]) } } } ## Generate numerical quadrature domain <- data.frame(domain) mn <- domain[1,] mx <- domain[2,] dm <- ncol(domain) if (dm==1) { ## Gauss-Legendre or uniform quadrature xlab <- names(domain) if (type[[xlab]][[1]]%in%c("per","cubic.per","linear.per")) { quad <- list(pt=mn+(1:200)/200*(mx-mn), wt=rep((mx-mn)/200,200)) } else quad <- gauss.quad(200,c(mn,mx)) quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- colnames(domain) } else { ## Smolyak cubature if (is.null(qdsz.depth)) qdsz.depth <- switch(min(dm,6)-1,18,14,12,11,10) quad <- smolyak.quad(dm,qdsz.depth) for (i in 1:ncol(domain)) { xlab <- colnames(domain)[i] form <- as.formula(paste("~",xlab)) jk <- ssden(form,data=mf,domain=domain[i],alpha=2, id.basis=id.basis,weights=cnt) quad$pt[,i] <- qssden(jk,quad$pt[,i]) quad$wt <- quad$wt/dssden(jk,quad$pt[,i]) } jk <- NULL quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- colnames(domain) } ## Incorporate factors in quadrature if (!is.null(fac.list)) { for (i in 1:length(fac.list)) { wk <- expand.grid(levels(mf[[fac.list[i]]]),1:length(quad$wt)) quad$wt <- quad$wt[wk[,2]] col.names <- c(fac.list[i],colnames(quad$pt)) quad$pt <- data.frame(wk[,1],quad$pt[wk[,2],],stringsAsFactors=TRUE) colnames(quad$pt) <- col.names } } quad <- list(pt=quad$pt,wt=quad$wt) } else { for (xlab in names(mf)) { x <- mf[[xlab]] if (is.vector(x)&!is.factor(x)) { if (is.null(range <- domain[[xlab]])) { mn <- min(x) mx <- max(x) range <- c(mn,mx)+c(-1,1)*(mx-mn)*.05 range[1] <- min(c(range[1],quad$pt[[xlab]])) range[2] <- max(c(range[2],quad$pt[[xlab]])) } if (is.null(type[[xlab]])) type[[xlab]] <- list("cubic",range) else { if (length(type[[xlab]])==1) type[[xlab]] <- list(type[[xlab]][[1]],range) else { mn0 <- min(type[[xlab]][[2]]) mx0 <- max(type[[xlab]][[2]]) if ((mn0>mn)|(mx0alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } ## initialization mu.r <- apply(qd.wt*t(qd.r),2,sum)/sum(qd.wt) v.r <- apply(qd.wt*t(qd.r^2),2,sum)/sum(qd.wt) if (nnull) { mu.s <- apply(qd.wt*t(qd.s),2,sum)/sum(qd.wt) v.s <- apply(qd.wt*t(qd.s^2),2,sum)/sum(qd.wt) } if (is.null(s)) theta <- 0 else theta <- log10(sum(v.s-mu.s^2)/nnull/sum(v.r-mu.r^2)*nxi) / 2 log.la0 <- log10(sum(v.r-mu.r^2)/sum(diag(q))) + theta ## lambda search cd <- rep(0,nxi+nnull) la <- log.la0 mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } ## return jk1 <- cv(zz$est) int <- sum(qd.wt*exp(t(rbind(10^theta*qd.r,qd.s))%*%cd)) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL list(lambda=zz$est,theta=theta,c=c,d=d,int=int,cv=jk1) } ## Fit multiple smoothing parameter density mspdsty <- function(s,r,id.basis,cnt,qd.s,qd.r,qd.wt,prec,maxiter,alpha,bias,skip.iter) { nxi <- dim(r)[1] nobs <- dim(r)[2] nqd <- length(qd.wt) nq <- dim(r)[3] if (!is.null(s)) nnull <- dim(s)[1] else nnull <- 0 nxis <- nxi+nnull if (is.null(cnt)) cnt <- 0 ## cv function cv <- function(theta) { ind.wk <- theta!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- qd.r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] qd.r.wk0 <- qd.r.wk0 + 10^theta[i]*qd.r[,,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("qd.r.wk",qd.r.wk0+0,inherits=TRUE) assign("theta.old",theta+0,inherits=TRUE) } else { r.wk0 <- r.wk qd.r.wk0 <- qd.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] qd.r.wk0 <- qd.r.wk0 + theta.wk*qd.r[,,i] } } q.wk <- r.wk0[,id.basis] fit <- .Fortran("dnewton", cd=as.double(cd), as.integer(nxis), as.double(10^lambda*q.wk), as.integer(nxi), as.double(rbind(r.wk0,s)), as.integer(nobs), as.double(sum(cnt)), as.double(cnt), as.double(t(rbind(qd.r.wk0,qd.s))), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(t(qd.wt*bias$qd.wt)), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nxis), wk=double(2*((nqd+1)*bias$nt+nobs)+nxis*(2*nxis+4)+max(nxis,3)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in ssden: Newton iteration diverges") if (fit$info==2) warning("gss warning in ssden: Newton iteration fails to converge") assign("cd",fit$cd,inherits=TRUE) cv <- alpha*fit$wk[2]-fit$wk[1] alpha.wk <- max(0,theta-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.wk <- function(theta) cv.scale*cv(theta)+cv.shift ## initialization theta <- -log10(apply(r[,id.basis,],3,function(x)sum(diag(x)))) r.wk <- qd.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } ## theta adjustment z <- sspdsty(s,r.wk,r.wk[,id.basis],cnt,qd.s,qd.r.wk,qd.wt,prec,maxiter,alpha,bias) theta <- theta + z$theta r.wk <- qd.r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(z$c)%*%r[,id.basis,i]%*%z$c) r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } mu <- apply(qd.wt*t(qd.r.wk),2,sum)/sum(qd.wt) v <- apply(qd.wt*t(qd.r.wk^2),2,sum)/sum(qd.wt) log.la0 <- log10(sum(v-mu^2)/sum(diag(r.wk[,id.basis]))) log.th0 <- theta-log.la0 ## lambda search z <- sspdsty(s,r.wk,r.wk[,id.basis],cnt,qd.s,qd.r.wk,qd.wt,prec,maxiter,alpha,bias) lambda <- z$lambda log.th0 <- log.th0 + z$lambda theta <- theta + z$theta cd <- c(z$c,z$d) int <- z$int ## early return if (skip.iter) { z$theta <- theta return(z) } ## theta search counter <- 0 r.wk <- qd.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } theta.old <- theta ## scale and shift cv tmp <- abs(cv(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssden: CV iteration fails to converge") break } } ## return jk1 <- cv(zz$est) qd.r.wk <- 0 for (i in 1:nq) qd.r.wk <- qd.r.wk + 10^zz$est[i]*qd.r[,,i] int <- sum(qd.wt*exp(t(rbind(qd.r.wk,qd.s))%*%cd)) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL list(lambda=lambda,theta=zz$est,c=c,d=d,int=int,cv=jk1) } gss/R/predict.ssllrm.R0000644000176200001440000001344114404122651014341 0ustar liggesusers## Calculate prediction and Bayesian SE from ssllrm objects predict.ssllrm <- function (object,x,y=object$qd.pt,odds=NULL,se.odds=FALSE,...) { if (!inherits(object,"ssllrm")) stop("gss error in predict.ssllrm: not a ssllrm object") if ("random"%in%colnames(x)) { zz <- x$random x$random <- NULL } else zz <- NULL if (!all(sort(object$xnames)==sort(colnames(x)))) stop("gss error in predict.ssllrm: mismatched x variable names") if (!all(sort(object$ynames)==sort(colnames(y)))) stop("gss error in predict.ssllrm: mismatched y variable names") mf <- object$mf term <- object$term qd.pt <- object$qd.pt qd.wt <- object$qd.wt nmesh <- dim(qd.pt)[1] y.id <- NULL for (i in 1:dim(y)[1]) { if (!sum(duplicated(rbind(qd.pt,y[i,object$ynames,drop=FALSE])))) stop("gss error in predict.ssllrm: y value is out of range") wk <- FALSE for (j in 1:nmesh) { if (sum(duplicated(rbind(qd.pt[j,],y[i,object$ynames])))) y.id <- c(y.id,j) } } if (!is.null(odds)) { if (length(y.id)-length(odds)) stop("gss error in predict.ssllrm: odds is of wrong length") if (!max(odds)|sum(odds)) stop("gss error in predict.ssllrm: odds is not a contrast") if (sum(duplicated(y.id))) stop("gss error in predict.ssllrm: duplicated y in contrast") qd.pt <- qd.pt[y.id,,drop=FALSE] } ## Generate s, and r nobs <- dim(x)[1] nmesh <- dim(qd.pt)[1] nbasis <- length(object$id.basis) nnull <- length(object$d) nZ <- length(object$b) s <- NULL r <- array(0,c(nmesh,nbasis,nobs)) nu <- nq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- object$xnames[object$xnames%in%vlist] y.list <- object$ynames[object$ynames%in%vlist] xy.basis <- mf[object$id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- qd.pt[,y.list] if (length(x.list)) xx <- x[,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { nu <- nu+1 if (is.null(xx)) { s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) wk <- matrix(s.wk,nmesh,nobs) } else { wk <- NULL for (j in 1:nobs) { qd.xy[,x.list] <- xx[rep(j,nmesh),] wk <- cbind(wk,phi$fun(qd.xy,i,phi$env)) } } s <- array(c(s,wk),c(nmesh,nobs,nu)) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 if (is.null(xx)) { r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,out=TRUE) r <- r + as.vector(10^object$theta[nq]*r.wk) } else { wk <- NULL for (j in 1:nobs) { qd.xy[,x.list] <- xx[rep(j,nmesh),] wk <- array(c(wk,rk$fun(qd.xy,xy.basis,i,rk$env,TRUE)), c(nmesh,nbasis,j)) } r <- r + 10^object$theta[nq]*wk } } } } ## random effects if (nZ) { nz <- object$Random$sigma$env$nz if (is.null(zz)) z.wk <- matrix(0,nobs,nz) else z.wk <- as.matrix(zz) if (dim(z.wk)[2]!=nz) stop("gss error in predict.ssllrm: x$random is of wrong dimension") z <- nlvl <- NULL for (ylab in object$ynames) { y.wk <- mf[,ylab] lvl.wk <- levels(y.wk) nlvl.wk <- length(lvl.wk) nlvl <- c(nlvl,nlvl.wk) z.aux <- diag(1,nlvl.wk-1) z.aux <- rbind(z.aux,rep(-1,nlvl.wk-1)) rownames(z.aux) <- lvl.wk pt.wk <- qd.pt[,ylab] for (i in 1:(nlvl.wk-1)) { for (j in 1:nmesh) { z <- cbind(z,z.aux[pt.wk[j],i]*z.wk) } } } z <- aperm(array(z,c(nobs,nz,nmesh,nZ/nz)),c(3,2,4,1)) z <- array(z,c(nmesh,nZ,nobs)) } ## return if (is.null(odds)) { pdf <- NULL for (j in 1:nobs) { wk <- matrix(r[,,j],nmesh,nbasis)%*%object$c if (nnull) wk <- wk + matrix(s[,j,],nmesh,nnull)%*%object$d if (nZ) wk <- wk + matrix(z[,,j],nmesh,nZ)%*%object$b wk <- exp(wk)*qd.wt pdf <- cbind(pdf,wk/sum(wk)) } return(t(pdf[y.id,])) } else { s.wk <- r.wk <- z.wk <- w.wk <- 0 for (i in 1:length(odds)) { r.wk <- r.wk + odds[i]*r[i,,] if (nnull) s.wk <- s.wk + odds[i]*s[i,,] if (nZ) z.wk <- z.wk + odds[i]*z[i,,] w.wk <- w.wk + odds[i]*log(qd.wt[y.id[i]]) } s.wk <- matrix(s.wk,nobs,nnull) r.wk <- t(matrix(r.wk,nbasis,nobs)) z.wk <- t(matrix(z.wk,nZ,nobs)) rs <- cbind(r.wk,z.wk,s.wk) if (!se.odds) as.vector(rs%*%c(object$c,object$b,object$d)) else { fit <- as.vector(rs%*%c(object$c,object$b,object$d)) + w.wk se.fit <- .Fortran("hzdaux2", as.double(object$se.aux$v), as.integer(dim(rs)[2]), as.integer(object$se.aux$jpvt), as.double(t(rs)), as.integer(dim(rs)[1]), se=double(dim(rs)[1]), PACKAGE="gss")[["se"]] return(list(fit=fit,se.fit=se.fit)) } } } gss/R/summary.ssanova0.R0000644000176200001440000000630512355360640014630 0ustar liggesusers## Summarize ssanova0 objects summary.ssanova0 <- function(object,diagnostics=FALSE,...) { y <- model.response(object$mf,"numeric") w <- model.weights(object$mf) offset <- model.offset(object$mf) if (is.null(offset)) offset <- rep(0,length(object$c)) ## Residuals res <- 10^object$nlambda*object$c if (!is.null(w)) res <- res/sqrt(w) ## Fitted values fitted <- as.numeric(y-res) fitted.off <- fitted-offset ## (estimated) sigma sigma <- sqrt(object$varht) ## R^2 if (!is.null(w)) { r.squared <- sum(w*(fitted-sum(w*fitted)/sum(w))^2) r.squared <- r.squared/sum(w*(y-sum(w*y)/sum(w))^2) } else r.squared <- var(fitted)/var(y) ## Residual sum of squares if (is.null(w)) rss <- sum(res^2) else rss <- sum(w*res^2) ## Penalty associated with the fit if (is.null(w)) penalty <- sum(object$c*fitted.off) else penalty <- sum(object$c*fitted.off*sqrt(w)) penalty <- as.vector(10^object$nlambda*penalty) ## Calculate the diagnostics mf <- object$mf mf.part <- object$mf.part if (diagnostics) { ## Obtain retrospective linear model comp <- NULL for (label in c(object$terms$labels,object$lab.p)) { if (label=="1") next if (label=="offset") next comp <- cbind(comp,predict(object,mf,inc=label)) } comp <- cbind(comp,yhat=fitted.off,y=fitted.off+res,e=res) term.label <- object$terms$labels[object$terms$labels!="1"] term.label <- term.label[term.label!="offset"] term.label <- c(term.label,object$lab.p) if (any(outer(term.label,c("yhat","y","e"),"=="))) warning("gss warning in summary.ssanova0: avoid using yhat, y, or e as variable names") colnames(comp) <- c(term.label,"yhat","y","e") ## Sweep out constant if (!is.null(w)) comp <- sqrt(w)*comp - outer(sqrt(w),apply(w*comp,2,sum))/sum(w) else comp <- sweep(comp,2,apply(comp,2,mean)) ## Obtain pi comp1 <- comp[,c(term.label,"yhat")] decom <- t(comp1) %*% comp1[,"yhat"] names(decom) <- c(term.label,"yhat") decom <- decom[term.label]/decom["yhat"] ## Obtain kappa, norm, and cosines corr <- t(comp)%*%comp corr <- t(corr/sqrt(diag(corr)))/sqrt(diag(corr)) norm <- apply(comp,2,function(x){sqrt(sum(x^2))}) cosines <- rbind(corr[c("y","e"),],norm) rownames(cosines) <- c("cos.y","cos.e","norm") corr <- corr[term.label,term.label,drop=FALSE] if (qr(corr)$rank0) { qd.xy[,x.list] <- xx qd.s <- cbind(qd.s,phi$fun(qd.xy,i,phi$env)) } } } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { if (is.null(xx)) { qd.r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,TRUE) iq <- iq+1 qd.r[[iq]] <- qd.r.wk } else { if (length(y.list)>0) { qd.xy[,x.list] <- xx iq <- iq+1 qd.r[[iq]] <- rk$fun(qd.xy,xy.basis,i,rk$env,TRUE) } } } } } if (ns) { qd.s <- sweep(qd.s,2,apply(qd.s*rho.wt[,k],2,sum)) s.rho <- s.rho + xx.wt[k]*apply(qd.s*rho.d[,k]*rho.wt[,k],2,sum) ss <- ss + xx.wt[k]*t(rho.wt[,k]*qd.s)%*%qd.s } for (i in 1:iq) { qd.r[[i]] <- sweep(qd.r[[i]],2,apply(qd.r[[i]]*rho.wt[,k],2,sum)) r.rho[,i] <- r.rho[,i] + xx.wt[k]*apply(qd.r[[i]]*rho.d[,k]*rho.wt[,k],2,sum) if (ns) sr[,,i] <- sr[,,i] + xx.wt[k]*t(rho.wt[,k]*qd.s)%*%qd.r[[i]] for (j in 1:i) { rr.wk <- xx.wt[k]*t(rho.wt[,k]*qd.r[[i]])%*%qd.r[[j]] rr[,,i,j] <- rr[,,i,j] + rr.wk if (i-j) rr[,,j,i] <- rr[,,j,i] + t(rr.wk) } } } ## evaluate full model if (ns) d <- object$d[object$id.s] c <- object$c theta <- object$theta[object$id.r] nq <- length(theta) if (ns) s.eta <- ss%*%d r.eta <- tmp <- NULL r.rho.wk <- sr.wk <- rr.wk <- 0 for (i in 1:nq) { tmp <- c(tmp,10^(2*theta[i])*sum(diag(rr[,,i,i]))) if (ns) { s.eta <- s.eta + 10^theta[i]*sr[,,i]%*%c if (length(d)==1) r.eta.wk <- sr[,,i]*d else r.eta.wk <- t(sr[,,i])%*%d sr.wk <- sr.wk + 10^theta[i]*sr[,,i] } else r.eta.wk <- 0 r.rho.wk <- r.rho.wk + 10^theta[i]*r.rho[,i] for (j in 1:nq) { r.eta.wk <- r.eta.wk + 10^theta[j]*rr[,,i,j]%*%c rr.wk <- rr.wk + 10^(theta[i]+theta[j])*rr[,,i,j] } r.eta <- cbind(r.eta,r.eta.wk) } rho.eta <- sum(r.rho.wk*c) if (ns) rho.eta <- rho.eta + sum(r.rho.wk*c) eta2 <- sum(c*(rr.wk%*%c)) if (ns) eta2 <- eta2 + sum(d*(ss%*%d)) + 2*sum(d*(sr.wk%*%c)) mse <- eta2 + rho2 + 2*rho.eta ## extract terms in subspace id.s <- id.r <- NULL for (label in include) { id.s <- c(id.s,object$id.s.list[[label]]) id.r <- c(id.r,object$id.r.list[[label]]) } if (is.null(id.s)&is.null(id.r)) stop("gss error in project.sscden1: include some terms") if (!all(id.s%in%object$id.s)|!all(id.r%in%object$id.r)) stop("gss error in project.sscden1: included terms are not in the model") ## calculate projection rkl <- function(theta1=NULL) { theta.wk <- 1:nq0 theta.wk[fix] <- theta[fix] if (nq0-1) theta.wk[-fix] <- theta1 ## id.s0 <- (1:length(object$id.s))[object$id.s%in%id.s] id.r0 <- (1:length(object$id.r))[object$id.r%in%id.r] if (length(id.s0)) ss.wk <- ss[id.s0,id.s0,drop=FALSE] if (length(id.r0)) { r.eta.wk <- rr.wk <- 0 sr.wk <- matrix(0,length(id.s),nbasis) for (i in 1:length(id.r0)) { r.eta.wk <- r.eta.wk + 10^theta.wk[i]*r.eta[,id.r0[i]] if (length(id.s0)) sr.wk <- sr.wk + 10^theta.wk[i]*sr[id.s0,,id.r0[i]] for (j in 1:length(id.r0)) { rr.wk <- rr.wk + 10^(theta.wk[i]+theta.wk[j])*rr[,,id.r0[i],id.r0[j]] } } if (length(id.s0)) { v <- cbind(rbind(ss.wk,t(sr.wk)),rbind(sr.wk,rr.wk)) mu <- c(s.eta[id.s0],r.eta.wk) } else { v <- rbind(sr.wk,rr.wk) mu <- r.eta.wk } } else { v <- ss.wk mu <- s.eta[id.s0] } nn <- length(mu) suppressWarnings(z <- chol(v,pivot=TRUE)) v <- z rkv <- attr(z,"rank") m.eps <- .Machine$double.eps while (v[rkv,rkv]<2*sqrt(m.eps)*v[1,1]) rkv <- rkv - 1 if (rkvrkv,(1:nn)>rkv] <- diag(v[1,1],nn-rkv) mu <- backsolve(v,mu[attr(z,"pivot")],transpose=TRUE) eta2 - sum(mu[1:rkv]^2) } cv.wk <- function(theta) cv.scale*rkl(theta)+cv.shift ## initialization fix <- rev(order(tmp[id.r]))[1] theta <- object$theta[id.r] ## projection nq0 <- length(id.r) if (nq0>1) { if (object$skip.iter) se <- rkl(theta[-fix]) else { if (nq0-2) { ## scale and shift cv tmp <- abs(rkl(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } se <- rkl(zz$est) } } else se <- rkl() list(ratio=se/mse,se=se) } gss/R/summary.ssanova.R0000644000176200001440000000754413053702214014547 0ustar liggesusers## Summarize ssanova objects summary.ssanova <- function(object,diagnostics=FALSE,...) { y <- model.response(object$mf,"numeric") w <- model.weights(object$mf) offset <- model.offset(object$mf) if (is.null(offset)) offset <- rep(0,length(y)) ## Residuals mf <- object$mf if (!is.null(object$random)) mf$random <- object$random$z res <- y - predict(object,mf) ## Fitted values fitted <- as.numeric(y-res) ## (estimated) sigma sigma <- sqrt(object$varht) ## R^2 if (!is.null(w)) { r.squared <- sum(w*(fitted-sum(w*fitted)/sum(w))^2) r.squared <- r.squared/sum(w*(y-sum(w*y)/sum(w))^2) } else r.squared <- var(fitted)/var(y) ## Residual sum of squares if (is.null(w)) rss <- sum(res^2) else rss <- sum(w*res^2) ## Penalty associated with the fit obj.wk <- object obj.wk$d[] <- 0 if (!is.null(model.offset(obj.wk$mf))) obj.wk$mf[,"(offset)"] <- 0 penalty <- sum(obj.wk$c*predict(obj.wk,obj.wk$mf[object$id.basis,])) penalty <- as.vector(10^object$nlambda*penalty) if (!is.null(object$random)) { p.ran <- t(object$b)%*%object$random$sigma$fun(object$zeta, object$random$sigma$env)%*%object$b penalty <- penalty + p.ran } ## Calculate the diagnostics if (is.null(object$partial)) labels.p <- NULL else labels.p <- labels(object$partial$mt) if (diagnostics) { ## Obtain retrospective linear model comp <- NULL p.dec <- NULL for (label in c(object$terms$labels,labels.p)) { if (label=="1") next if (label=="offset") next comp <- cbind(comp,predict(object,object$mf,inc=label)) jk <- sum(obj.wk$c*predict(obj.wk,obj.wk$mf[object$id.basis,],inc=label)) p.dec <- c(p.dec,10^object$nlambda*jk) } term.label <- object$terms$labels[object$terms$labels!="1"] term.label <- term.label[term.label!="offset"] term.label <- c(term.label,labels.p) if (!is.null(object$random)) { comp <- cbind(comp,predict(object,mf,inc=NULL)) p.dec <- c(p.dec,p.ran) term.label <- c(term.label,"random") } fitted.off <- fitted-offset comp <- cbind(comp,yhat=fitted.off,y=fitted.off+res,e=res) if (any(outer(term.label,c("yhat","y","e"),"=="))) warning("gss warning in summary.ssanova: avoid using yhat, y, or e as variable names") colnames(comp) <- c(term.label,"yhat","y","e") ## Sweep out constant if (!is.null(w)) comp <- sqrt(w)*comp - outer(sqrt(w),apply(w*comp,2,sum))/sum(w) else comp <- sweep(comp,2,apply(comp,2,mean)) ## Obtain pi comp1 <- comp[,c(term.label,"yhat")] decom <- t(comp1) %*% comp1[,"yhat"] names(decom) <- c(term.label,"yhat") decom <- decom[term.label]/decom["yhat"] ## Obtain kappa, norm, and cosines corr <- t(comp)%*%comp corr <- t(corr/sqrt(diag(corr)))/sqrt(diag(corr)) norm <- apply(comp,2,function(x){sqrt(sum(x^2))}) cosines <- rbind(corr[c("y","e"),],norm) rownames(cosines) <- c("cos.y","cos.e","norm") corr <- corr[term.label,term.label,drop=FALSE] if (qr(corr)$rank0) id.s <- c(id.s,term$iphi+(1:term$nphi)-2) if (term$nrk>0) id.q <- c(id.q,term$irk+(1:term$nrk)-1) } ss.wk <- ss[id.s,id.s] r.eta.wk <- r.wk <- sr.wk <- rr.wk <- 0 for (i in id.q) { r.eta.wk <- r.eta.wk + 10^theta[i]*r.eta[,i] r.wk <- r.wk + 10^theta[i]*r[,i] sr.wk <- sr.wk + 10^theta[i]*sr[id.s,,i] for (j in id.q) { rr.wk <- rr.wk + 10^(theta[i]+theta[j])*rr[,,i,j] } } sr.wk <- sr.wk - outer(s[id.s],r.wk,"*") rr.wk <- rr.wk - outer(r.wk,r.wk,"*") v <- cbind(rbind(ss.wk,t(sr.wk)),rbind(sr.wk,rr.wk)) mu <- c(s.eta[id.s],r.eta.wk) nn <- length(mu) suppressWarnings(z <- chol(v,pivot=TRUE)) v <- z rkv <- attr(z,"rank") m.eps <- .Machine$double.eps while (v[rkv,rkv]<2*sqrt(m.eps)*v[1,1]) rkv <- rkv - 1 if (rkvrkv,(1:nn)>rkv] <- diag(v[1,1],nn-rkv) mu <- backsolve(v,mu[attr(z,"pivot")],transpose=TRUE) eta2 - sum(mu[1:rkv]^2) } ## projection if (drop1) { se <- NULL for (i in 1:length(include)) se <- c(se,rkl(include[-i])) ratio <- se/mse names(se) <- names(ratio) <- include } else se <- rkl(include) ratio <- se/mse list(ratio=ratio,se=se) } ## Calculate integrals of phi and rk for ssden1 mkint2 <- function(mf,type,id.basis,quad,term) { ## Obtain model terms mt <- attr(mf,"terms") xvars <- as.character(attr(mt,"variables"))[-1] xfacs <- attr(mt,"factors") term.labels <- labels(mt) vlist <- xvars[as.logical(apply(xfacs,1,sum))] ## Create phi and rk nbasis <- length(id.basis) phi.term <- rk.term <- list(NULL) nvar <- length(names(mf)) ns <- nq <- 0 for (label in term.labels) { ns <- ns+term[[label]]$nphi nq <- nq+term[[label]]$nrk phi.term[[label]] <- rk.term[[label]] <- list(NULL) vlist <- xvars[as.logical(xfacs[,label])] x <- mf[,vlist] dm <- length(vlist) phi <- rk <- NULL if (dm==1) { type.wk <- type[[vlist]][[1]] xx <- mf[id.basis,vlist] xmesh <- quad[[vlist]]$pt if (type.wk%in%c("nominal","ordinal")) { ## factor variable if (type.wk=="nominal") fun <- mkrk.nominal(levels(x)) else fun <- mkrk.ordinal(levels(x)) if (nlevels(x)>2) { ## rk rk <- fun$fun(xmesh,xx,fun$env,TRUE) } else { ## phi wk <- as.factor(names(fun$env$code)[1]) phi <- fun$fun(xmesh,wk,fun$env) } } if (type.wk=="cubic") { ## cubic splines range <- type[[vlist]][[2]] ## phi phi.fun <- mkphi.cubic(range) phi <- phi.fun$fun(xmesh,1,phi.fun$env) ## rk rk.fun <- mkrk.cubic(range) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, and linear periodic splines range <- type[[vlist]][[2]] ## rk if (type.wk=="cubic.per") rk.fun <- mkrk.cubic.per(range) if (type.wk=="linear") rk.fun <- mkrk.linear(range) if (type.wk=="linear.per") rk.fun <- mkrk.linear.per(range) if (type.wk=="sphere") rk.fun <- mkrk.sphere(range) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk=="tp") { ## thin-plate splines par <- type[[vlist]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x)) xdim <- 1 else xdim <- dim(x)[2] ## phi phi.fun <- mkphi.tp(xdim,order,mesh,weight) nphi <- choose(xdim+order-1,xdim)-1 if (nphi>0) { for (nu in 1:nphi) { phi <- cbind(phi,phi.fun$fun(xmesh,nu,phi.fun$env)) } } ## rk rk.fun <- mkrk.tp(xdim,order,mesh,weight) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk=="custom") { ## user-defined par <- type[[vlist]][[2]] nphi <- par$nphi if (nphi>0) { phi.fun <- par$mkphi(par$env) for (nu in 1:nphi) { phi <- cbind(phi,phi.fun$fun(xmesh,nu,phi.fun$env)) } } rk.fun <- par$mkrk(par$env) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } phi.term[[label]][[vlist]] <- phi if (is.null(rk)) rk.term[[label]][[vlist]] <- rk else { nmesh <- length(quad[[vlist]]$wt) rk.term[[label]][[vlist]] <- array(rk,c(nmesh,nbasis,1)) } } else { bin.fac <- n.phi <- phi.list <- rk.list <- NULL for (i in 1:dm) { type.wk <- type[[vlist[i]]][[1]] if (type.wk%in%c("nominal","ordinal")) { ## factor variable if (type.wk=="nominal") rk.wk <- mkrk.nominal(levels(x[[i]])) else rk.wk <- mkrk.ordinal(levels(x[[i]])) phi.wk <- rk.wk n.phi <- c(n.phi,0) bin.fac <- c(bin.fac,!(nlevels(x[[i]])>2)) } if (type.wk=="cubic") { ## cubic or linear splines range <- type[[vlist[i]]][[2]] ## phi phi.wk <- mkphi.cubic(range) n.phi <- c(n.phi,1) ## rk rk.wk <- mkrk.cubic(range) bin.fac <- c(bin.fac,0) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, or linear periodic splines range <- type[[vlist[i]]][[2]] n.phi <- c(n.phi,0) phi.wk <- NULL if (type.wk=="cubic.per") rk.wk <- mkrk.cubic.per(range) if (type.wk=="linear") rk.wk <- mkrk.linear(range) if (type.wk=="linear.per") rk.wk <- mkrk.linear.per(range) if (type.wk=="sphere") rk.wk <- mkrk.sphere(range) bin.fac <- c(bin.fac,0) } if (type.wk=="tp") { ## thin-plate splines par <- type[[vlist[i]]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x[[i]])) xdim <- 1 else xdim <- dim(x[[i]])[2] phi.wk <- mkphi.tp(xdim,order,mesh,weight) n.phi <- c(n.phi,choose(xdim+order-1,xdim)-1) rk.wk <- mkrk.tp(xdim,order,mesh,weight) bin.fac <- c(bin.fac,0) } if (type.wk=="custom") { ## user-defined par <- type[[vlist[i]]][[2]] n.phi <- c(n.phi,par$nphi) if (par$nphi>0) phi.wk <- par$mkphi(par$env) else phi.wk <- NULL rk.wk <- par$mkrk(par$env) bin.fac <- c(bin.fac,0) } phi.list <- c(phi.list,list(phi.wk)) rk.list <- c(rk.list,list(rk.wk)) } ## phi id0 <- names(mf)%in%vlist nphi <- term[[label]]$nphi iphi <- term[[label]]$iphi if (nphi>0) { for (nu in 1:nphi) { ind <- nu - 1 for (i in 1:dm) { phi.wk <- phi.list[[i]] xmesh <- quad[[vlist[i]]]$pt if (bin.fac[i]) { wk <- as.factor(names(phi.wk$env$code)[1]) phi <- phi.wk$fun(xmesh,wk,phi.wk$env) } else { code <- ind%%n.phi[i] + 1 ind <- ind%/%n.phi[i] phi <- phi.wk$fun(xmesh,code,phi.wk$env) } phi.term[[label]][[vlist[i]]] <- cbind(phi.term[[label]][[vlist[i]]],phi) } } } ## rk n.rk <- ifelse(n.phi,2,1) nrk <- prod(n.rk) - as.logical(nphi) if (nrk>0) { for (nu in 1:nrk) { ind <- nu - !nphi for (i in 1:dm) { code <- ind%%n.rk[i] + 1 ind <- ind%/%n.rk[i] xx <- mf[id.basis,vlist[[i]]] xmesh <- quad[[vlist[i]]]$pt if (code==n.rk[i]) { rk.wk <- rk.list[[i]] rk <- rk.wk$fun(xmesh,xx,rk.wk$env,TRUE) } else { rk <- 0 phi.wk <- phi.list[[i]] for (j in 1:n.phi[i]) { phix <- phi.wk$fun(xmesh,j,phi.wk$env) phiy <- phi.wk$fun(xx,j,phi.wk$env) rk <- rk + outer(phix,phiy) } } nmesh <- length(quad[[vlist[i]]]$wt) rk.term[[label]][[vlist[i]]] <- array(c(rk.term[[label]][[vlist[i]]],rk), c(nmesh,nbasis,nu)) } } } } } ## create arrays ss <- matrix(1,ns,ns) sr <- array(1,c(ns,nbasis,nq)) rr <- array(1,c(nbasis,nbasis,nq,nq)) for (label1 in term.labels) { if (!term[[label1]]$nphi) id.s1 <- NULL else id.s1 <- term[[label1]]$iphi+(1:term[[label1]]$nphi)-2 if (!term[[label1]]$nrk) id.r1 <- NULL else id.r1 <- term[[label1]]$irk+(1:term[[label1]]$nrk)-1 irk1 <- term[[label1]]$irk for (label2 in term.labels) { if (!term[[label2]]$nphi) id.s2 <- NULL else id.s2 <- term[[label2]]$iphi+(1:term[[label2]]$nphi)-2 if (!term[[label2]]$nrk) id.r2 <- NULL else id.r2 <- term[[label2]]$irk+(1:term[[label2]]$nrk)-1 irk2 <- term[[label2]]$irk for (xlab in names(mf)) { wmesh <- quad[[xlab]]$wt phi1 <- phi.term[[label1]][[xlab]] phi2 <- phi.term[[label2]][[xlab]] rk1 <- rk.term[[label1]][[xlab]] rk2 <- rk.term[[label2]][[xlab]] ## ss if (!is.null(id.s1)&!is.null(id.s2)) { if ((!is.null(phi1))&(!is.null(phi2))) { ss[id.s1,id.s2] <- ss[id.s1,id.s2]*(t(wmesh*phi1)%*%phi2) } else { if (!is.null(phi1)) { ss[id.s1,id.s2] <- ss[id.s1,id.s2]*apply(wmesh*matrix(phi1),2,sum) } else { if (!is.null(phi2)) { ss[id.s1,id.s2] <- t(t(ss[id.s1,id.s2])* apply(wmesh*matrix(phi2),2,sum)) } } } } ## sr if (!is.null(id.s1)&!is.null(id.r2)) { if ((!is.null(phi1))&(!is.null(rk2))) { for (i in id.r2) { sr[id.s1,,i] <- sr[id.s1,,i]*(t(wmesh*phi1)%*%rk2[,,i-irk2+1]) } } else { if (!is.null(phi1)) { sr[id.s1,,id.r2] <- sr[id.s1,,id.r2]*apply(wmesh*matrix(phi1),2,sum) } else { if (!is.null(rk2)) { for (i in id.r2) { sr[id.s1,,i] <- t(t(sr[id.s1,,i])* apply(wmesh*rk2[,,i-irk2+1],2,sum)) } } } } } ## rr if (!is.null(id.r1)&!is.null(id.r2)) { if ((!is.null(rk1))&(!is.null(rk2))) { for (i in id.r1) { for (j in id.r2) { rr[,,i,j] <- rr[,,i,j]*(t(wmesh*rk1[,,i-irk1+1])%*%rk2[,,j-irk2+1]) } } } else { if (!is.null(rk1)) { for (i in id.r1) { rr[,,i,id.r2] <- rr[,,i,id.r2]*apply(wmesh*rk1[,,i-irk1+1],2,sum) } } else { if (!is.null(rk2)) { for (j in id.r2) { rr[,,id.r1,j] <- aperm(aperm(rr[,,id.r1,j,drop=FALSE],c(2,1,3,4))* apply(wmesh*rk2[,,j-irk2+1],2,sum),c(2,1,3,4)) } } } } } } } } list(ss=ss,sr=sr,rr=rr) } gss/R/summary.ssanova9.R0000644000176200001440000000710412355360640014637 0ustar liggesusers## Summarize ssanova objects summary.ssanova9 <- function(object,diagnostics=FALSE,...) { y <- model.response(object$mf,"numeric") nobs <- length(y) cov <- object$cov if (length(object$zeta)) ww <- cov$fun(object$zeta,cov$env) else ww <- cov$fun(cov$env) ww <- chol(ww) offset <- model.offset(object$mf) if (is.null(offset)) offset <- rep(0,length(y)) ## Residuals mf <- object$mf res <- y - predict(object,mf) ## Fitted values fitted <- as.numeric(y-res) ## (estimated) sigma sigma <- sqrt(object$varht) ## R^2 y.wk <- forwardsolve(t(ww),y) fitted.wk <- forwardsolve(t(ww),fitted) one.wk <- forwardsolve(t(ww),rep(1,nobs)) mn.y <- sum(y.wk*one.wk)/sum(one.wk^2) mn.fitted <- sum(fitted.wk*one.wk)/sum(one.wk^2) r.squared <- sum((fitted.wk-mn.fitted*one.wk)^2) r.squared <- r.squared/sum((y.wk-mn.y*one.wk)^2) ## Residual sum of squares res.wk <- forwardsolve(t(ww),res) rss <- sum(res.wk^2) ## Penalty associated with the fit obj.wk <- object obj.wk$d[] <- 0 if (!is.null(model.offset(obj.wk$mf))) obj.wk$mf[,"(offset)"] <- 0 penalty <- sum(obj.wk$c*predict(obj.wk,obj.wk$mf[object$id.basis,])) penalty <- as.vector(10^object$nlambda*penalty) ## Calculate the diagnostics if (is.null(object$partial)) labels.p <- NULL else labels.p <- labels(object$partial$mt) if (diagnostics) { ## Obtain retrospective linear model comp <- NULL p.dec <- NULL for (label in c(object$terms$labels,labels.p)) { if (label=="1") next if (label=="offset") next comp <- cbind(comp,predict(object,mf,inc=label)) jk <- sum(obj.wk$c*predict(obj.wk,mf[object$id.basis,],inc=label)) p.dec <- c(p.dec,10^object$nlambda*jk) } term.label <- object$terms$labels[object$terms$labels!="1"] term.label <- term.label[term.label!="offset"] term.label <- c(term.label,labels.p) fitted.off <- fitted-offset comp <- cbind(comp,yhat=fitted.off,y=fitted.off+res,e=res) comp <- forwardsolve(t(ww),comp) if (any(outer(term.label,c("yhat","y","e"),"=="))) warning("gss warning in summary.ssanova: avoid using yhat, y, or e as variable names") colnames(comp) <- c(term.label,"yhat","y","e") ## Sweep out constant comp <- comp - outer(one.wk,apply(t(comp)%*%one.wk,1,sum))/sum(one.wk^2) ## Obtain pi comp1 <- comp[,c(term.label,"yhat")] decom <- t(comp1) %*% comp1[,"yhat"] names(decom) <- c(term.label,"yhat") decom <- decom[term.label]/decom["yhat"] ## Obtain kappa, norm, and cosines corr <- t(comp)%*%comp corr <- t(corr/sqrt(diag(corr)))/sqrt(diag(corr)) norm <- apply(comp,2,function(x){sqrt(sum(x^2))}) cosines <- rbind(corr[c("y","e"),],norm) rownames(cosines) <- c("cos.y","cos.e","norm") corr <- corr[term.label,term.label,drop=FALSE] if (qr(corr)$ranktime)) stop("gss error in sscox: start after follow-up time") if (min(start)<0) warning("gss warning in sscox: start before time 0") time <- cbind(start,time) list(start=time[,1],end=time[,2],status=as.logical(status)) } ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$alpha <- mf$random <- mf$partial <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ## response resp <- attr(term.wk,"variable")[[2]] ind.wk <- length(strsplit(deparse(resp),'')[[1]]) if ((substr(deparse(resp),1,5)!='Surv(') |(substr(deparse(resp),ind.wk,ind.wk)!=')')) stop("gss error in sscox: response should be Surv(...)") yy <- with(data,eval(resp)) ## model frame term.labels <- attr(term.wk,"term.labels") mf[[1]] <- as.name("model.frame") mf[[2]] <- eval(parse(text=paste("~",paste(term.labels,collapse="+"),"-1"))) mf <- eval(mf,parent.frame()) ## trim yy if subset is used nobs <- nrow(mf) if (nobssum(yy$status)) nbasis <- sum(yy$status) if (!is.null(seed)) set.seed(seed) id.basis <- sample((1:nobs)[yy$status],nbasis,prob=cnt[yy$status]) } else { if (!all(id.basis%in%(1:nobs)[yy$status])) stop("gss error in sscox: id.basis not all at failure cases") nbasis <- length(id.basis) } id.wk <- NULL nT <- sum(yy$status) for (i in 1:nbasis) { id.wk <- c(id.wk,(1:nT)[(1:nobs)[yy$status]%in%id.basis[i]]) } ## Generate terms term <- mkterm(mf,type) term$labels <- term$labels[term$labels!="1"] ## Generate random if (!is.null(random)) { if (inherits(random,"formula")) random <- mkran(random,data) random$qd.z <- random$z random$z <- random$z[yy$status,] } ## Generate s and r s <- qd.s <- r <- qd.r <- NULL nq <- 0 for (label in term$labels) { x.basis <- mf[id.basis,term[[label]]$vlist] qd.x <- mf[,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { s.wk <- phi$fun(qd.x,nu=i,env=phi$env) s <- cbind(s,s.wk[yy$status]) qd.s <- cbind(qd.s,s.wk) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r.wk <- rk$fun(qd.x,x.basis,nu=i,env=rk$env,out=TRUE) r <- array(c(r,r.wk[yy$status,]),c(nT,nbasis,nq)) qd.r <- array(c(qd.r,r.wk),c(nobs,nbasis,nq)) } } } ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in sscox: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p[yy$status,]) qd.s <- cbind(qd.s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rank=")&outer(yy$start,tt,"<="))/1 bias0 <- list(nt=nT,wt=b.wt,qd.wt=t.wt) ## Fit the model if (nq==1) { r <- r[,,1] qd.r <- qd.r[,,1] z <- sspcox(s,r,r[id.wk,],cntt,qd.s,qd.r,qd.wt,prec,maxiter,alpha,random,bias0) } else z <- mspcox(s,r,id.wk,cntt,qd.s,qd.r,qd.wt,prec,maxiter,alpha,random,bias0,skip.iter) ## Brief description of model terms desc <- NULL for (label in term$labels) desc <- rbind(desc,as.numeric(c(term[[label]][c("nphi","nrk")]))) if (!is.null(partial)) { desc <- rbind(desc,matrix(c(1,0),length(lab.p),2,byrow=TRUE)) } desc <- rbind(desc,apply(desc,2,sum)) if (is.null(partial)) rownames(desc) <- c(term$labels,"total") else rownames(desc) <- c(term$labels,lab.p,"total") colnames(desc) <- c("Unpenalized","Penalized") ## Return the results obj <- c(list(call=match.call(),mf=mf,cnt=cnt,terms=term,desc=desc, alpha=alpha,id.basis=id.basis,partial=part,lab.p=lab.p, random=random,bias=bias0,skip.iter=skip.iter),z) Nobs <- ifelse(is.null(cnt),nT,sum(cntt)) obj$se.aux$v <- sqrt(Nobs)*obj$se.aux$v class(obj) <- c("sscox") obj } ## Fit single smoothing parameter density sspcox <- function(s,r,q,cnt,qd.s,qd.r,qd.wt,prec,maxiter,alpha,random,bias) { nobs <- dim(r)[1] nxi <- dim(r)[2] nqd <- length(qd.wt) if (!is.null(s)) nnull <- dim(s)[2] else nnull <- 0 if (!is.null(random)) nz <- ncol(as.matrix(random$z)) else nz <- 0 nxiz <- nxi + nz nn <- nxiz + nnull if (is.null(cnt)) cnt <- 0 ## cv function cv <- function(lambda) { if (is.null(random)) q.wk0 <- 10^(lambda+theta)*q else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda[1]+theta)*q q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(lambda[-1],random$sigma$env) } fit <- .Fortran("dnewton", cd=as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(t(cbind(r.wk,s))), as.integer(nobs), as.double(sum(cnt)), as.double(cnt), as.double(cbind(qd.r.wk,qd.s)), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(t(qd.wt*bias$qd.wt)), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*((nqd+1)*bias$nt+nobs)+nn*(2*nn+4)+max(nn,3)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in sscox: Newton iteration diverges") if (fit$info==2) warning("gss warning in sscox: Newton iteration fails to converge") assign("cd",fit$cd,inherits=TRUE) cv <- alpha*fit$wk[2]-fit$wk[1] alpha.wk <- max(0,log.la0-lambda-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.wk <- function(lambda) cv.scale*cv(lambda)+cv.shift ## initialization if (!nnull) { vv.r <- 0 for (i in 1:bias$nt) { wt.wk <- qd.wt*bias$qd.wt[,i] mu.r <- apply(wt.wk*qd.r,2,sum)/sum(wt.wk) v.r <- apply(wt.wk*qd.r^2,2,sum)/sum(wt.wk) v.r <- v.r - mu.r^2 vv.r <- vv.r + bias$wt[i]*v.r } theta <- 0 } else { vv.s <- vv.r <- 0 for (i in 1:bias$nt) { wt.wk <- qd.wt*bias$qd.wt[,i] mu.s <- apply(wt.wk*qd.s,2,sum)/sum(wt.wk) v.s <- apply(wt.wk*qd.s^2,2,sum)/sum(wt.wk) v.s <- v.s - mu.s^2 mu.r <- apply(wt.wk*qd.r,2,sum)/sum(wt.wk) v.r <- apply(wt.wk*qd.r^2,2,sum)/sum(wt.wk) v.r <- v.r - mu.r^2 vv.s <- vv.s + bias$wt[i]*v.s vv.r <- vv.r + bias$wt[i]*v.r } theta <- log10(sum(vv.s)/nnull/sum(vv.r)*nxi) / 2 } log.la0 <- log10(sum(vv.r)/sum(diag(q))) + theta if (!is.null(random)) { mu.z <- apply(qd.wt*random$qd.z,2,sum) v.z <- apply(qd.wt*random$qd.z^2,2,sum) ran.scal <- theta - log10(sum(v.z-mu.z^2)/nz/sum(v.r-mu.r^2)*nxi) / 2 r.wk <- cbind(10^theta*r,10^ran.scal*random$z) qd.r.wk <- cbind(10^theta*qd.r,10^ran.scal*random$qd.z) } else { ran.scal <- NULL r.wk <- 10^theta*r qd.r.wk <- 10^theta*qd.r } ## lambda search cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sscox: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } ## return if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } if (is.null(random)) { q.wk0 <- 10^(lambda+theta)*q qd.r.wk <- 10^theta*qd.r } else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda+theta)*q q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) qd.r.wk <- cbind(10^theta*qd.r,10^ran.scal*random$qd.z) } se.aux <- .Fortran("coxaux", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(qd.r.wk,qd.s)), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(.Machine$double.eps), as.double(qd.wt*bias$qd.wt), double(nqd*bias$nt), double(bias$nt), double(nn), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,se.aux=se.aux)) } ## Fit multiple smoothing parameter density mspcox <- function(s,r,id.basis,cnt,qd.s,qd.r,qd.wt,prec,maxiter,alpha,random,bias,skip.iter) { nobs <- dim(r)[1] nxi <- dim(r)[2] nq <- dim(r)[3] nqd <- length(qd.wt) if (!is.null(s)) nnull <- dim(s)[2] else nnull <- 0 if (!is.null(random)) nz <- ncol(as.matrix(random$z)) else nz <- 0 nxiz <- nxi + nz nn <- nxiz + nnull if (is.null(cnt)) cnt <- 0 ## cv function cv <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- qd.r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] qd.r.wk0 <- qd.r.wk0 + 10^theta[i]*qd.r[,,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("qd.r.wk",qd.r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk qd.r.wk0 <- qd.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] qd.r.wk0 <- qd.r.wk0 + theta.wk*qd.r[,,i] } } q.wk <- r.wk0[id.basis,] if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { r.wk0 <- cbind(r.wk0,10^ran.scal*random$z) qd.r.wk0 <- cbind(qd.r.wk0,10^ran.scal*random$qd.z) q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(theta[-(1:nq)],random$sigma$env) } fit <- .Fortran("dnewton", cd=as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(t(cbind(r.wk0,s))), as.integer(nobs), as.double(sum(cnt)), as.double(cnt), as.double(cbind(qd.r.wk0,qd.s)), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(t(qd.wt*bias$qd.wt)), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*((nqd+1)*bias$nt+nobs)+nn*(2*nn+4)+max(nn,3)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in ssden: Newton iteration diverges") if (fit$info==2) warning("gss warning in ssden: Newton iteration fails to converge") assign("cd",fit$cd,inherits=TRUE) cv <- alpha*fit$wk[2]-fit$wk[1] alpha.wk <- max(0,theta-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.wk <- function(theta) cv.scale*cv(theta)+cv.shift ## initialization theta <- -log10(apply(r[id.basis,,],3,function(x)sum(diag(x)))) r.wk <- qd.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } ## theta adjustment z <- sspcox(s,r.wk,r.wk[id.basis,],cnt,qd.s,qd.r.wk,qd.wt,prec,maxiter,alpha,random,bias) theta <- theta + z$theta r.wk <- qd.r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(z$c)%*%r[id.basis,,i]%*%z$c) r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } mu <- apply(qd.wt*qd.r.wk,2,sum)/sum(qd.wt) v <- apply(qd.wt*qd.r.wk^2,2,sum)/sum(qd.wt) log.la0 <- log10(sum(v-mu^2)/sum(diag(r.wk[id.basis,]))) log.th0 <- theta-log.la0 ## lambda search z <- sspcox(s,r.wk,r.wk[id.basis,],cnt,qd.s,qd.r.wk,qd.wt,prec,maxiter,alpha,random,bias) ## early return if (skip.iter) { z$theta <- theta return(z) } ## theta search lambda <- z$lambda log.th0 <- log.th0 + z$lambda theta <- theta + z$theta ran.scal <- z$ran.scal cd <- c(z$c,z$b,z$d) counter <- 0 r.wk <- qd.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } theta.old <- theta if (!is.null(random)) theta <- c(theta,zeta) ## scale and shift cv tmp <- abs(cv(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sscox: CV iteration fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale if (is.null(random)) { theta <- zz$est zeta <- NULL } else { theta <- zz$est[1:nq] zeta <- zz$est[-(1:nq)] } ## return q.wk <- qd.r.wk <- 0 for (i in 1:nq) { q.wk <- q.wk + 10^theta[i]*r[id.basis,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) qd.r.wk <- cbind(qd.r.wk,10^ran.scal*random$qd.z) } se.aux <- .Fortran("coxaux", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(qd.r.wk,qd.s)), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(.Machine$double.eps), as.double(qd.wt*bias$qd.wt), double(nqd*bias$nt), double(bias$nt), double(nn), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,se.aux=se.aux)) } gss/R/mkterm.R0000644000176200001440000003636312355360640012710 0ustar liggesusers## Make phi and rk for model terms mkterm <- function(mf,type) { ## Obtain model terms mt <- attr(mf,"terms") xvars <- as.character(attr(mt,"variables"))[-1] xfacs <- attr(mt,"factors") term.labels <- labels(mt) if (attr(attr(mf,"terms"),"intercept")) term.labels <- c("1",term.labels) ## Backward compatibility vlist <- xvars[as.logical(apply(xfacs,1,sum))] if (!is.null(type)&&!is.list(type)&&(type%in%c("cubic","linear","tp"))) { type.wk <- type type <- NULL for (xlab in vlist) type[[xlab]] <- type.wk } ## Set types for marginals var.type <- NULL for (xlab in vlist) { x <- mf[,xlab] if (!is.null(type[[xlab]])) { ## Check consistency and set default parameters type.wk <- type[[xlab]][[1]] if (!(type.wk%in%c("ordinal","nominal","cubic","linear","per","trig", "cubic.per","linear.per","tp","sphere","custom"))) stop("gss error in mkterm: unknown type") if (type.wk%in%c("ordinal","nominal")) { par.wk <- NULL if (!is.factor(x)) stop("gss error in mkterm: wrong type") } if (type.wk%in%c("cubic","linear")) { if (length(type[[xlab]])==1) { mn <- min(x) mx <- max(x) par.wk <- c(mn,mx)+c(-1,1)*.05*(mx-mn) } else par.wk <- type[[xlab]][[2]] if (is.factor(x)|!is.vector(x)) stop("gss error in mkterm: wrong type") } if (type.wk%in%c("per","cubic.per","linear.per","trig")) { if (type.wk=="per") type.wk <- "cubic.per" if (length(type[[xlab]])==1) stop("gss error in mkterm: missing domain of periodicity") else par.wk <- type[[xlab]][[2]] if (is.factor(x)|!is.vector(x)) stop("gss error in mkterm: wrong type") } if (type.wk=="tp") { if (length(type[[xlab]])==1) par.wk <- list(order=2,mesh=x,weight=1) else { par.wk <- par.wk1 <- type[[xlab]][[2]] if (length(par.wk1)==1) par.wk <- list(order=par.wk1,mesh=x,weight=1) if (is.null(par.wk$mesh)) par.wk$mesh <- x if (is.null(par.wk$weight)) par.wk$weight <- 1 } if (dim(as.matrix(x))[2]!=dim(as.matrix(par.wk$mesh))[2]) stop("gss error in mkterm: wrong dimension in normalizing mesh") } if (type.wk=="sphere") { if (length(type[[xlab]])==1) par.wk <- 2 else par.wk <- type[[xlab]][[2]] if (!(par.wk%in%(2:4))) stop("gss error in mkterm: spherical order not implemented") } if (type.wk=="custom") par.wk <- type[[xlab]][[2]] } else { ## Set default types if (is.factor(x)) { ## categorical variable if (is.ordered(x)) type.wk <- "ordinal" else type.wk <- "nominal" par.wk <- NULL } else { ## numerical variable if (is.vector(x)) { type.wk <- "cubic" mn <- min(x) mx <- max(x) par.wk <- c(mn,mx)+c(-1,1)*.05*(mx-mn) } else { type.wk <- "tp" par.wk <- list(order=2,mesh=x,weight=1) } } } var.type[[xlab]] <- list(type.wk,par.wk) } ## Create the phi and rk functions term <- list(labels=term.labels) iphi.wk <- 1 irk.wk <- 1 for (label in term.labels) { iphi <- irk <- phi <- rk <- NULL if (label=="1") { ## the constant term iphi <- iphi.wk iphi.wk <- iphi.wk + 1 term[[label]] <- list(iphi=iphi,nphi=1,nrk=0) next } vlist <- xvars[as.logical(xfacs[,label])] x <- mf[,vlist] dm <- length(vlist) if (dm==1) { type.wk <- var.type[[vlist]][[1]] if (type.wk%in%c("nominal","ordinal")) { ## factor variable if (type.wk=="nominal") fun.env <- mkrk.nominal(levels(x)) else fun.env <- mkrk.ordinal(levels(x)) if (nlevels(x)>2) { ## phi nphi <- 0 ## rk rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=fun.env) } else { ## phi phi.fun <- function(x,nu=1,env) { wk <- as.factor(names(env$env$code)[1]) env$fun(x,wk,env$env) } nphi <- 1 iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=fun.env) ## rk nrk <- 0 } } if (type.wk=="cubic") { ## cubic splines range <- var.type[[vlist]][[2]] ## phi phi.env <- mkphi.cubic(range) phi.fun <- function(x,nu=1,env) env$fun(x,nu,env$env) nphi <- 1 iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=phi.env) ## rk rk.env <- mkrk.cubic(range) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, and linear periodic splines range <- var.type[[vlist]][[2]] ## phi nphi <- 0 ## rk if (type.wk=="cubic.per") rk.env <- mkrk.cubic.per(range) if (type.wk=="linear") rk.env <- mkrk.linear(range) if (type.wk=="linear.per") rk.env <- mkrk.linear.per(range) if (type.wk=="sphere") rk.env <- mkrk.sphere(range) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } if (type.wk=="trig") { ## trigonometric splines range <- var.type[[vlist]][[2]] ## phi phi.env <- mkphi.trig(range) phi.fun <- function(x,nu=1,env) env$fun(x,nu,env$env) nphi <- 2 iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=phi.env) ## rk rk.env <- mkrk.trig(range) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } if (type.wk=="tp") { ## thin-plate splines par <- var.type[[vlist]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x)) xdim <- 1 else xdim <- dim(x)[2] ## phi phi.env <- mkphi.tp(xdim,order,mesh,weight) phi.fun <- function(x,nu=1,env) { env$fun(x,nu,env$env) } nphi <- choose(xdim+order-1,xdim)-1 iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=phi.env) ## rk rk.env <- mkrk.tp(xdim,order,mesh,weight) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } if (type.wk=="custom") { ## user-defined par <- var.type[[vlist]][[2]] nphi <- par$nphi if (nphi>0) { phi.env <- par$mkphi(par$env) phi.fun <- function(x,nu=1,env) { env$fun(x,nu,env$env) } iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=phi.env) } rk.env <- par$mkrk(par$env) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } } else { bin.fac <- n.phi <- phi.list <- rk.list <- NULL for (i in 1:dm) { type.wk <- var.type[[vlist[i]]][[1]] if (type.wk%in%c("nominal","ordinal")) { ## factor variable if (type.wk=="nominal") rk.wk <- mkrk.nominal(levels(x[[i]])) else rk.wk <- mkrk.ordinal(levels(x[[i]])) phi.wk <- rk.wk n.phi <- c(n.phi,0) bin.fac <- c(bin.fac,!(nlevels(x[[i]])>2)) } if (type.wk=="cubic") { ## cubic splines range <- var.type[[vlist[i]]][[2]] ## phi phi.wk <- mkphi.cubic(range) n.phi <- c(n.phi,1) ## rk rk.wk <- mkrk.cubic(range) bin.fac <- c(bin.fac,0) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, or linear periodic splines range <- var.type[[vlist[i]]][[2]] n.phi <- c(n.phi,0) phi.wk <- NULL if (type.wk=="cubic.per") rk.wk <- mkrk.cubic.per(range) if (type.wk=="linear") rk.wk <- mkrk.linear(range) if (type.wk=="linear.per") rk.wk <- mkrk.linear.per(range) if (type.wk=="sphere") rk.wk <- mkrk.sphere(range) bin.fac <- c(bin.fac,0) } if (type.wk=="trig") { ## trigonometric splines range <- var.type[[vlist[i]]][[2]] ## phi phi.wk <- mkphi.trig(range) n.phi <- c(n.phi,2) ## rk rk.wk <- mkrk.trig(range) bin.fac <- c(bin.fac,0) } if (type.wk=="tp") { ## thin-plate splines par <- var.type[[vlist[i]]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x[[i]])) xdim <- 1 else xdim <- dim(x[[i]])[2] phi.wk <- mkphi.tp(xdim,order,mesh,weight) n.phi <- c(n.phi,choose(xdim+order-1,xdim)-1) rk.wk <- mkrk.tp(xdim,order,mesh,weight) bin.fac <- c(bin.fac,0) } if (type.wk=="custom") { ## user-defined par <- var.type[[vlist[i]]][[2]] n.phi <- c(n.phi,par$nphi) if (par$nphi>0) phi.wk <- par$mkphi(par$env) else phi.wk <- NULL rk.wk <- par$mkrk(par$env) bin.fac <- c(bin.fac,0) } phi.list <- c(phi.list,list(phi.wk)) rk.list <- c(rk.list,list(rk.wk)) } ## phi if (!all(as.logical(n.phi+bin.fac))) nphi <- 0 else { phi.env <- list(dim=dm,phi=phi.list,n.phi=n.phi,bin.fac=bin.fac) phi.fun <- function(x,nu=1,env) { ind <- nu - 1 z <- 1 for (i in 1:env$dim) { if (env$bin.fac[i]) { wk <- as.factor(names(env$phi[[i]]$env$code)[1]) z <- z * env$phi[[i]]$fun(x[[i]],wk,env$phi[[i]]$env) } else { code <- ind%%env$n.phi[i] + 1 ind <- ind%/%env$n.phi[i] z <- z * env$phi[[i]]$fun(x[[i]],code,env$phi[[i]]$env) } } z } nphi <- prod(n.phi+bin.fac) iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=phi.env) } ## rk rk.env <- list(dim=dm,n.phi=n.phi,nphi=nphi, phi=phi.list,rk=rk.list) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { n.rk <- ifelse(env$n.phi,2,1) ind <- nu - !env$nphi z <- 1 for (i in 1:env$dim) { code <- ind%%n.rk[i] + 1 ind <- ind%/%n.rk[i] if (code==n.rk[i]) { z <- z * env$rk[[i]]$fun(x[[i]],y[[i]], env$rk[[i]]$env,outer.prod) } else { z.wk <- 0 for (j in 1:env$n.phi[i]) { phix <- env$phi[[i]]$fun(x[[i]],j,env$phi[[i]]$env) phiy <- env$phi[[i]]$fun(y[[i]],j,env$phi[[i]]$env) if (outer.prod) z.wk <- z.wk + outer(phix,phiy) else z.wk <- z.wk + phix * phiy } z <- z * z.wk } } z } n.rk <- ifelse(n.phi,2,1) nrk <- prod(n.rk) - as.logical(nphi) irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } term[[label]] <- list(vlist=vlist, iphi=iphi,nphi=nphi,phi=phi, irk=irk,nrk=nrk,rk=rk) } term } gss/R/project.sshzd.R0000644000176200001440000001640012355360640014177 0ustar liggesusers## Calculate Kullback-Leibler projection from sshzd objects project.sshzd <- function(object,include,mesh=FALSE,...) { if (!(object$tname%in%include)) stop("gss error in project.sshzd: time main effect missing in included terms") quad.pt <- object$quad$pt qd.wt <- object$qd.wt nx <- dim(object$qd.wt)[2] nbasis <- length(object$id.basis) mesh0 <- object$mesh0 ## extract terms in subspace nqd <- length(quad.pt) nxi <- length(object$id.basis) d <- qd.s <- q <- theta <- NULL qd.r <- as.list(NULL) n0.wk <- nu <- nq.wk <- nq <- 0 for (label in object$terms$labels) { vlist <- object$terms[[label]]$vlist x.list <- object$xnames[object$xnames%in%vlist] xy.basis <- object$mf[object$id.basis,vlist] qd.xy <- data.frame(matrix(0,nqd,length(vlist))) names(qd.xy) <- vlist if (object$tname%in%vlist) qd.xy[,object$tname] <- quad.pt if (length(x.list)) xx <- object$x.pt[,x.list,drop=FALSE] else xx <- NULL nphi <- object$terms[[label]]$nphi nrk <- object$terms[[label]]$nrk if (nphi) { phi <- object$terms[[label]]$phi for (i in 1:nphi) { n0.wk <- n0.wk + 1 if (label=="1") { d <- object$d[n0.wk] nu <- nu + 1 qd.wk <- matrix(1,nqd,nx) qd.s <- array(c(qd.s,qd.wk),c(nqd,nx,nu)) next } if (!any(label==include)) next d <- c(d,object$d[n0.wk]) nu <- nu + 1 if (is.null(xx)) qd.wk <- matrix(phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env),nqd,nx) else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nqd),] for (k in x.list) if (is.factor(xx[,k])) qd.xy[,k] <- as.factor(qd.xy[,k]) qd.wk <- cbind(qd.wk,phi$fun(qd.xy[,,drop=TRUE],i,phi$env)) } } qd.s <- array(c(qd.s,qd.wk),c(nqd,nx,nu)) } } if (nrk) { rk <- object$terms[[label]]$rk for (i in 1:nrk) { nq.wk <- nq.wk + 1 if (!any(label==include)) next nq <- nq + 1 theta <- c(theta,object$theta[nq.wk]) q <- cbind(q,rk$fun(xy.basis,xy.basis,i,rk$env,out=FALSE)) if (is.null(xx)) qd.r[[nq]] <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,out=TRUE) else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nqd),] for (k in x.list) if (is.factor(xx[,k])) qd.xy[,k] <- as.factor(qd.xy[,k]) qd.wk <- array(c(qd.wk,rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,TRUE)), c(nqd,nbasis,j)) } qd.r[[nq]] <- qd.wk } } } } if (!is.null(object$partial)) { for (label in object$lab.p) { n0.wk <- n0.wk + 1 if (!any(label==include)) next d <- c(d,object$d[n0.wk]) qd.wk <- t(matrix(object$partial$pt[,label],nx,nqd)) qd.s <- array(c(qd.s,qd.wk),c(nqd,nx,n0.wk)) } } if (!is.null(qd.s)) nnull <- dim(qd.s)[3] else nnull <- 0 nn <- nxi + nnull ## random effect offset if (!is.null(object$b)) offset <- as.vector(object$random$qd.z%*%object$b) else offset <- rep(0,nx) ## calculate projection rkl <- function(theta1=NULL) { theta.wk <- 1:nq theta.wk[fix] <- theta[fix] if (nq-1) theta.wk[-fix] <- theta1 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta.wk[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta.wk[i]*qd.r[[i]]) } qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) z <- .Fortran("hrkl", cd=as.double(cd), as.integer(nn), as.double(qd.r.wk), as.integer(nqd), as.integer(nx), as.double(t(t(qd.wt)*exp(offset))), mesh=as.double(qd.wt*mesh0), as.double(.Machine$double.eps), double(nqd*nx), double(nn), double(nn), double(nn*nn), integer(nn), double(nn), double(nn), double(nqd*nx), as.double(1e-6), as.integer(30), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.sshzd: Newton iteration diverges") if (z$info==2) warning("gss warning in project.sshzd: Newton iteration fails to converge") assign("cd",z$cd,inherits=TRUE) assign("mesh1",t(t(matrix(z$mesh,nqd,nx))*exp(offset)),inherits=TRUE) sum(qd.wt*(log(mesh0/mesh1)*mesh0-mesh0+mesh1)) } cv.wk <- function(theta) cv.scale*rkl(theta)+cv.shift ## initialization if (nnull) { qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } v.s <- v.r <- 0 for (i in 1:nx) { v.s <- v.s + apply(qd.wt[,i]*qd.s[,i,,drop=FALSE]^2,2,sum) v.r <- v.r + apply(qd.wt[,i]*qd.r.wk[,,i,drop=FALSE]^2,2,sum) } theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 } else theta.wk <- 0 theta <- theta + theta.wk tmp <- NULL for (i in 1:nq) tmp <- c(tmp,10^theta[i]*sum(q[,i])) fix <- rev(order(tmp))[1] ## projection cd <- c(10^(-theta.wk)*object$c,d) mesh1 <- NULL if (nq-1) { if (object$skip.iter) kl <- rkl(theta[-fix]) else { if (nq-2) { ## scale and shift cv tmp <- abs(rkl(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } kl <- rkl(zz$est) } } else kl <- rkl() ## cfit cfit <- t(matrix(object$dbar/sum(t(qd.wt)*exp(offset))*exp(offset),nx,nqd)) ## return kl0 <- sum(object$qd.wt*(log(mesh0/cfit)*mesh0-mesh0+cfit)) kl1 <- sum(object$qd.wt*(log(mesh1/cfit)*mesh1-mesh1+cfit)) obj <- list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) if (mesh) obj$mesh <- mesh1 obj } gss/R/gssanova1.R0000644000176200001440000002035614404122451013277 0ustar liggesusers## Fit gssanova model gssanova1 <- function(formula,family,type=NULL,data=list(),weights, subset,offset,na.action=na.omit,partial=NULL, method=NULL,varht=1,alpha=1.4,nu=NULL, id.basis=NULL,nbasis=NULL,seed=NULL,random=NULL, skip.iter=FALSE) { if (!(family%in%c("binomial","poisson","Gamma","nbinomial","inverse.gaussian", "polr","weibull","lognorm","loglogis"))) stop("gss error in gssanova1: family not implemented") ## Obtain model frame and model terms mf <- match.call() mf$family <- mf$type <- mf$partial <- NULL mf$method <- mf$varht <- mf$nu <- NULL mf$alpha <- mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$random <- mf$skip.iter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) wt <- model.weights(mf) ## Generate sub-basis nobs <- dim(mf)[1] if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=wt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in gssanova: id.basis out of range") nbasis <- length(id.basis) } ## Generate terms term <- mkterm(mf,type) ## Generate random if (!is.null(random)) { if (inherits(random,"formula")) random <- mkran(random,data) } ## Specify default method if (is.null(method)) { method <- switch(family, binomial="u", nbinomial="u", poisson="u", inverse.gaussian="v", Gamma="v", polr="u", weibull="u", lognorm="u", loglogis="u") } ## Generate s, r, and y s <- r <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nobs)) next } x <- mf[,term[[label]]$vlist] x.basis <- mf[id.basis,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(x,x.basis,nu=i,env=rk$env,out=TRUE)),c(nobs,nbasis,nq)) } } } if (is.null(r)) stop("gss error in gssanova1: use glm for models with only unpenalized terms") ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in ssanova: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL if (qr(s)$rank=30) { warning("gss warning in gssanova1: performance-oriented iteration fails to converge") break } } ## Return the fit if (is.list(nu)) nu <- nu[[1]] c(z,list(nu=nu,eta=eta,w=dat$wt)) } gss/R/gauss.quad.R0000644000176200001440000000117712355360640013457 0ustar liggesusersgauss.quad <- ## Generate Gauss-Legendre quadrature function(size,interval) { if (interval[1]>=interval[2]) warning("gss warning in gauss.quad: interval limits swapped") z <- .Fortran("gaussq", as.integer(1), as.integer(size), as.double(0), as.double(0), as.integer(0), as.double(c(-1,1)), double(size), t=double(size), w=double(size), PACKAGE="gss") mn <- min(interval[1:2]) range <- abs(interval[1]-interval[2]) pt <- mn+range*(z$t+1)/2 wt <- range*z$w/2 list(pt=pt,wt=wt) } gss/R/sscomp.R0000644000176200001440000000322714046273144012707 0ustar liggesusers## Composition estimation with one sample sscomp <- function(x,wt=rep(1,length(x)),alpha=1.4) { ## Check inputs if ((nlvl <- length(x))<3) stop("gss error in sscomp: length of x should be 3 or more") if (length(x)!=length(wt)) stop("gss error in sscomp: x and wt mismatch in lengths") ## Generate terms cnt <- x x <- as.factor(1:nlvl) mf <- model.frame(~x) term <- mkterm(mf,NULL) rk <- term$x$rk ## get basis functions id.basis <- 1:nlvl if (max(abs(wt-mean(wt)))/mean(wt)<.Machine$double.eps) id.basis <- id.basis[cnt>0] if (length(id.basis)==nlvl) id.basis <- id.basis[-nlvl] ## generate matrices r <- rk$fun(x[id.basis],x,nu=1,env=rk$env,out=TRUE) q <- r[,id.basis] qd.wt <- as.vector(wt) ## Fit the model nt <- b.wt <- 1 t.wt <- matrix(1,nlvl,1) bias0 <- list(nt=nt,wt=b.wt,qd.wt=t.wt) z <- sspdsty(NULL,r,q,cnt,NULL,r,qd.wt,1e-7,30,alpha,bias0) ## return fitted probabilities fit <- exp(t(r)%*%z$c)*qd.wt rownames(fit) <- rownames(x) fit/sum(fit) } ## Composition estimation with a matrix input sscomp2 <- function(x,alpha=1.4) { if (!is.matrix(x)) stop("gss error in sscomp2: x should be a matrix") if (min(x)<0) stop("gss error in sscomp2: x should have non-negative entries") if (any(apply(x,2,sum)==0)) stop("gss error in sscomp2: column totals of x must be positive") nlvl <- dim(x)[1] yy <- apply(x,1,sum) p0 <- sscomp(yy) fit <- NULL for (i in 1:dim(x)[2]) { fit <- cbind(fit,sscomp(x[,i],p0,alpha)) } rownames(fit) <- rownames(x) colnames(fit) <- colnames(x) fit } gss/R/mkterm.copu.R0000644000176200001440000001315212355360634013647 0ustar liggesusers## Make term for sscopu mkterm.copu <- function(dm,order,symmetry,exclude) { phi0 <- function(x) x-.5 rk0 <- function(x,y) { k2 <- function(x) ((x-.5)^2-1/12)/2 k4 <- function(x) ((x-.5)^4-(x-.5)^2/2+7/240)/24 k2(x)*k2(y)-k4(abs(x-y)) } combo <- function(x,order) { d <- length(x) if (d==order) return(matrix(x,nrow=1)) if (order==1) z <- matrix(x,ncol=1) else { wk <- NULL for (i in 2:(d-order+2)) wk <- rbind(wk,combo(x[i:d],order-1)) z <- cbind(rep(x[1:(d-order+1)],choose((d-1):(order-1),order-1)),wk) } z } if (symmetry) { permut <- function(x) { d <- length(x) if (d==1) return(x) z <- NULL for (i in 1:d) z <- rbind(z,cbind(x[i],permut(x[-i]))) z } nphi <- order phi <- function(x,nu,env) { wk <- env$combo(1:dim(x)[2],nu) z <- 0 for (i in 1:dim(wk)[1]) { z.wk <- 1 for (j in 1:nu) z.wk <- z.wk*env$phi0(x[,wk[i,j]]) z <- z + z.wk } z } perm <- permut(1:dm) idx.rk <- cumsum(1:order) nrk <- sum(1:order) rk <- function(x,y,nu,env,out=TRUE) { order <- min((1:length(env$idx.rk))[nu<=env$idx.rk]) if (order==1) { z <- 0 for (i in 1:dim(env$perm)[1]) { y.wk <- y[,perm[i,]] for (j in 1:dim(x)[2]) { if (out) z <- z + outer(x[,j],y.wk[,j],env$rk0) else z <- z + env$rk0(x[,j],y.wk[,j]) } } return(z) } wk <- env$combo(1:dim(x)[2],order) nu.wk <- nu - env$idx.rk[order-1] z <- 0 for (i in 1:dim(env$perm)[1]) { y.wk <- y[,perm[i,]] for (j in 1:dim(wk)[1]) { idx.wk <- wk[j,] wk1 <- env$combo(idx.wk,nu.wk) for (k in 1:dim(wk1)[1]) { z.wk <- 1 for (ind in idx.wk) { if (ind%in%wk1[k,]) { if (out) z.wk <- z.wk*outer(x[,ind],y.wk[,ind],env$rk0) else z.wk <- z.wk*env$rk0(x[,ind],y.wk[,ind]) } else { if (out) z.wk <- z.wk*outer(env$phi0(x[,ind]), env$phi0(y.wk[,ind])) else z.wk <- z.wk*env$phi0(x[,ind])*env$phi0(y.wk[,ind]) } } z <- z + z.wk } } } z } env <- list(phi0=phi0,rk0=rk0,combo=combo,perm=perm,idx.rk=idx.rk) } else { idx.phi <- NULL nphi <- 0 for (i in 1:order) { wk <- combo(1:dm,i) if (!is.null(exclude)) { exc.ind <- NULL for (j in 1:choose(dm,i)) { exc.wk <- FALSE for (k in 1:dim(exclude)[1]) exc.wk <- any(exc.wk,all(exclude[k,]%in%wk[j,])) exc.ind <- c(exc.ind,exc.wk) } wk <- wk[!exc.ind,,drop=FALSE] } if (!dim(wk)[1]) next for (j in 1:dim(wk)[1]) idx.phi <- rbind(idx.phi,(1:dm)%in%wk[j,]) nphi <- nphi + dim(wk)[1] } phi <- function(x,nu,env) { z <- 1 for (i in 1:dm) if (env$idx.phi[nu,i]) z <- z*env$phi0(x[,i]) z } idx.rk <- NULL nrk <- 0 for (i in 1:order) { wk <- combo(1:dm,i) if (!is.null(exclude)) { exc.ind <- NULL for (j in 1:choose(dm,i)) { exc.wk <- FALSE for (k in 1:dim(exclude)[1]) exc.wk <- any(exc.wk,all(exclude[k,]%in%wk[j,])) exc.ind <- c(exc.ind,exc.wk) } wk <- wk[!exc.ind,,drop=FALSE] } if (!dim(wk)[1]) next for (j in 1:dim(wk)[1]) { idx.wk <- (1:dm)%in%wk[j,] for (k in 1:(2^i-1)) { ind <- k tmp <- NULL for (kk in 1:i) { tmp <- c(tmp,ind%%2) ind <- ind%/%2 } wwk <- rep(0,dm) wwk[idx.wk] <- tmp+1 idx.rk <- rbind(idx.rk,wwk) } } nrk <- nrk + dim(wk)[1]*(2^i-1) } rk <- function(x,y,nu,env,out=TRUE) { z <- 1 if (out) { for (i in 1:dm) { if (env$idx.rk[nu,i]==1) z <- z*outer(env$phi0(x[,i]),env$phi0(y[,i])) if (env$idx.rk[nu,i]==2) z <- z*outer(x[,i],y[,i],env$rk0) } } else { for (i in 1:dm) { if (env$idx.rk[nu,i]==1) z <- z*env$phi0(x[,i])*env$phi0(y[,i]) if (env$idx.rk[nu,i]==2) z <- z*env$rk0(x[,i],y[,i]) } } z } env <- list(phi0=phi0,rk0=rk0,idx.phi=idx.phi,idx.rk=idx.rk) } list(nphi=nphi,phi=phi,nrk=nrk,rk=rk,env=env) } gss/R/fitted.R0000644000176200001440000000534113510147655012663 0ustar liggesusers## Obtain fitted values from ssanova objects fitted.ssanova <- function(object,...) { mf <- object$mf if (!is.null(object$random)) mf$random <- I(object$random$z) predict(object,mf) } ## Obtain residuals from ssanova objects residuals.ssanova <- function(object,...) { y <- model.response(object$mf,"numeric") as.numeric(y-fitted.ssanova(object)) } ## Obtain fitted values in working scale from gssanova objects fitted.gssanova <- function(object,...) { as.numeric(object$eta) } ## Obtain residuals from gssanova objects residuals.gssanova <- function(object,type="working",...) { if (object$family=="polr") { y <- model.response(object$mf) if (!is.factor(y)) stop("gss error in gssanova1: need factor response for polr family") lvls <- levels(y) if (nlvl <- length(lvls)<3) stop("gss error in gssanova1: need at least 3 levels to fit polr family") y <- outer(y,lvls,"==") } else y <- model.response(object$mf,"numeric") wt <- model.weights(object$mf) offset <- NULL if ((object$family=="nbinomial")&(!is.null(object$nu))) y <- cbind(y,object$nu) dat <- switch(object$family, binomial=mkdata.binomial(y,object$eta,wt,offset), nbinomial=mkdata.nbinomial(y,object$eta,wt,offset,object$nu), polr=mkdata.polr(y,object$eta,wt,offset,object$nu), poisson=mkdata.poisson(y,object$eta,wt,offset), inverse.gaussian=mkdata.inverse.gaussian(y,object$eta,wt,offset), Gamma=mkdata.Gamma(y,object$eta,wt,offset), weibull=mkdata.weibull(y,object$eta,wt,offset,list(object$nu,FALSE)), lognorm=mkdata.lognorm(y,object$eta,wt,offset,list(object$nu,FALSE)), loglogis=mkdata.loglogis(y,object$eta,wt,offset,list(object$nu,FALSE))) res <- as.numeric(dat$ywk - object$eta) if (!is.na(charmatch(type,"deviance"))) { dev.resid <- switch(object$family, binomial=dev.resid.binomial(y,object$eta,wt), nbinomial=dev.resid.nbinomial(y,object$eta,wt), polr=dev.resid.polr(y,object$eta,wt,object$nu), poisson=dev.resid.poisson(y,object$eta,wt), inverse.gaussian=dev.resid.inverse.gaussian(y,object$eta,wt), Gamma=dev.resid.Gamma(y,object$eta,wt), weibull=dev.resid.weibull(y,object$eta,wt,object$nu), lognorm=dev.resid.lognorm(y,object$eta,wt,object$nu), loglogis=dev.resid.loglogis(y,object$eta,wt,object$nu)) res <- sqrt(dev.resid)*sign(res) } res } gss/R/smolyak.R0000644000176200001440000000121412355360640013053 0ustar liggesuserssmolyak.quad <- ## Generate delayed Smolyak cubature function(d, k) { size <- .C("size_smolyak", as.integer(d), as.integer(d+k), size=integer(1), PACKAGE="gss")$size z <- .C("quad_smolyak", as.integer(d), as.integer(d+k), pt=double(d*size), wt=as.double(1:size), PACKAGE="gss") list(pt=t(matrix(z$pt,d,size)),wt=z$wt) } smolyak.size <- ## Get the size of delayed Smolyak cubature function(d, k) { .C("size_smolyak", as.integer(d), as.integer(d+k), size=integer(1), PACKAGE="gss")$size } gss/R/sshzd2d1.R0000644000176200001440000004234314404124011013031 0ustar liggesusers## Fit hazard model sshzd2d1 <- function(formula1,formula2,symmetry=FALSE,data,alpha=1.4,weights=NULL, subset=NULL,rho="marginal",id.basis=NULL,nbasis=NULL, seed=NULL,prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Prepare data if (!is.null(subset)) { data <- data[subset,] if (!is.null(weights)) { id.wk <- apply(!is.na(data),1,all) cnt <- weights[id.wk] } else cnt <- NULL data <- na.omit(data[subset,]) } else { if (!is.null(weights)) { id.wk <- apply(!is.na(data),1,all) cnt <- weights[id.wk] } else cnt <- NULL data <- na.omit(data) } ## Extract formulas if (inherits(formula1,"formula")) { form1 <- formula1 part1 <- random1 <- type1 <- NULL } else { if (!inherits(formula1,"list")) stop("gss error in sshzd2d1: models must be specified via formulas or lists") form1 <- formula1[[1]] part1 <- formula1$partial random1 <- formula1$random type1 <- formula1$type } if (inherits(formula2,"formula")) { form2 <- formula2 part2 <- random2 <- type2 <- NULL } else { if (!inherits(formula2,"list")) stop("gss error in sshzd2d1: models must be specified via formulas or lists") form2 <- formula2[[1]] part2 <- formula2$partial random2 <- formula2$random type2 <- formula2$type } ## Local function handling formula Surv <- function(time,status,start=0) { tname <- as.character(as.list(match.call())$time) if (!is.numeric(time)|!is.vector(time)) stop("gss error in sshzd2d1: time should be a numerical vector") if ((nobs <- length(time))-length(status)) stop("gss error in sshzd2d1: time and status mismatch in size") if ((length(start)-nobs)&(length(start)-1)) stop("gss error in sshzd2d1: time and start mismatch in size") if (any(start>time)) stop("gss error in sshzd2d1: start after follow-up time") if (min(start)<0) stop("gss error in sshzd2d1: start before time 0") time <- cbind(start,time) list(tname=tname,start=time[,1],end=time[,2],status=as.logical(status)) } ## Obtain model terms for (i in 1:2) { ## Formula form.wk <- switch(i,form1,form2) term.wk <- terms.formula(form.wk) resp <- attr(term.wk,"variable")[[2]] ind.wk <- length(strsplit(deparse(resp),'')[[1]]) if ((substr(deparse(resp),1,5)!='Surv(') |(substr(deparse(resp),ind.wk,ind.wk)!=')')) stop("gss error in sshzd2d1: response should be Surv(...)") yy <- with(data,eval(resp)) tname <- yy$tname term.labels <- attr(term.wk,"term.labels") if (!(tname%in%term.labels)) stop("gss error in sshzd2d1: time main effect missing in model") form.wk <- eval(parse(text=paste("~",paste(term.labels,collapse="+")))) mf.wk <- model.frame(form.wk,data) ## Partial part.wk <- switch(i,part1,part2) if (!is.null(part.wk)) { mf.p.wk <- model.frame(part.wk,data) mt.p.wk <- attr(mf.p.wk,"terms") matx.p.wk <- model.matrix(mt.p.wk,data)[,-1,drop=FALSE] if (dim(matx.p.wk)[1]!=dim(mf.wk)[1]) stop("gss error in sshzd2d1: partial data are of wrong size") } else mf.p.wk <- mt.p.wk <- matx.p.wk <- NULL ## Random random.wk <- switch(i,random1,random2) if (!is.null(random.wk)) { if (inherits(random.wk,"formula")) random.wk <- mkran(random.wk,data) } else random.wk <- NULL ## Set domain and type for time type.wk <- switch(i,type1,type2) mn <- min(yy$start) mx <- max(yy$end) tdomain <- c(max(mn-.05*(mx-mn),0),mx) tname <- yy$tname if (is.null(type.wk[[tname]])) type.wk[[tname]] <- list("cubic",tdomain) if (length(type.wk[[tname]])==1) type.wk[[tname]] <- c(type.wk[[tname]],tdomain) if (!(type.wk[[tname]][[1]]%in%c("cubic","linear"))) stop("gss error in sshzd2d1: wrong type") if ((min(type.wk[[tname]][[2]])>min(tdomain))| (max(type.wk[[tname]][[2]])=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in sshzd2d1: id.basis out of range") nbasis <- length(id.basis) } ## Generate terms if (symmetry) { nhzd <- 1 if (dim(mf2)[2]!=dim(mf1)[2]) stop("gss error in sshzd2d1: variables in parallel formulas must match") mf1.wk <- mf1 mf2.wk <- mf2 names(mf1.wk) <- names(mf2) names(mf2.wk) <- names(mf1) tdomain1 <- c(min(tdomain1,tdomain2),max(tdomain1,tdomain2)) type1[[yy1$tname]][[2]] <- tdomain1 type2[[yy2$tname]][[2]] <- tdomain1 term1 <- mkterm(rbind(mf1,mf2.wk),type1) term2 <- mkterm(rbind(mf2,mf1.wk),type2) mf1 <- rbind(mf1,mf2.wk) yy1.sv <- yy1 yy1$start <- c(yy1$start,yy2$start) yy1$end <- c(yy1$end,yy2$end) yy1$status <- c(yy1$status,yy2$status) id.basis.wk <- c(id.basis,id.basis+nobs) if (!is.null(mf.p1)) { if (is.null(mf.p2)||(dim(mf.p2)[2]!=dim(mf.p1)[2])) stop("gss error in sshzd2d1: variables in parallel formulas must match") matx.p1 <- rbind(matx.p1,matx.p2) } if (!is.null(random1)) { if (is.null(random2)||(dim(random2$z)[2]!=dim(random1$z)[2])) stop("gss error in sshzd2d1: variables in parallel formulas must match") random1$z <- rbind(random1$z,random2$z) } if (!is.null(cnt)) cnt.wk <- c(cnt,cnt) else cnt.wk <- NULL } else { nhzd <- 2 term1 <- mkterm(mf1,type1) term2 <- mkterm(mf2,type2) id.basis.wk <- id.basis cnt.wk <- cnt } ## Fit marginal hazard models for (ii in 1:nhzd) { ## Extract model components mf <- switch(ii,mf1,mf2) yy <- switch(ii,yy1,yy2) term <- switch(ii,term1,term2) mf.p <- switch(ii,mf.p1,mf.p2) mt.p <- switch(ii,mt.p1,mt.p2) matx.p <- switch(ii,matx.p1,matx.p2) random <- switch(ii,random1,random2) tdomain <- switch(ii,tdomain1,tdomain2) if (rho=="weibull") partt <- switch(ii,part1,part2) ## Finalize id.basis nobs <- length(yy$status) id.basis.wk <- id.basis.wk[yy$status[id.basis.wk]] nbasis <- length(id.basis.wk) id.wk <- NULL nT <- sum(yy$status) for (i in 1:nbasis) { id.wk <- c(id.wk,(1:nT)[(1:nobs)[yy$status]%in%id.basis.wk[i]]) } ## Generate Gauss-Legendre quadrature nmesh <- 200 quad <- gauss.quad(nmesh,tdomain) ## set up partial terms if (!is.null(mf.p)) { for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] lab.p <- labels(mt.p) matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL ## Obtain unique covariate observations tname <- yy$tname xnames <- names(mf) xnames <- xnames[!xnames%in%tname] if (length(xnames)) { xx <- mf[,xnames,drop=FALSE] if (!is.null(part)) xx <- cbind(xx,matx.p) if (!is.null(random)) xx <- cbind(xx,random$z) xx <- apply(xx,1,function(x)paste(x,collapse="\r")) ux <- unique(xx) nx <- length(ux) x.dup.ind <- duplicated(xx) x.dup <- as.vector(xx[x.dup.ind]) x.pt <- mf[!x.dup.ind,xnames,drop=FALSE] ## xx[i,]==x.pt[x.ind[i],] x.ind <- 1:nobs x.ind[!x.dup.ind] <- 1:nx if (nobs-nx) { x.ind.wk <- range <- 1:(nobs-nx) for (i in 1:nx) { range.wk <- NULL for (j in range) { if (identical(ux[i],x.dup[j])) { x.ind.wk[j] <- i range.wk <- c(range.wk,j) } } if (!is.null(range.wk)) range <- range[!(range%in%range.wk)] } x.ind[x.dup.ind] <- x.ind.wk } if (!is.null(random)) { qd.z <- random$z[!x.dup.ind,] random$z <- random$z[yy$status,] } } else stop("gss error in sshzd2d1: missing covariate") ## calculate rho if (is.null(cnt.wk)) yy$cnt <- rep(1,nobs) else yy$cnt <- cnt.wk if (rho=="marginal") { rho.wk <- sshzd(Surv(end,status,start)~end,data=yy, id.basis=id.basis.wk,weights=cnt,alpha=2) rho.qd <- hzdcurve.sshzd(rho.wk,quad$pt) rhowk <- hzdcurve.sshzd(rho.wk,yy$end[yy$status]) } if (rho=="weibull") { y.wk <- cbind(yy$end,yy$status,yy$start) form <- as.formula(paste("y.wk~",paste(xnames,collapse="+"))) rho.wk <- gssanova(form,family="weibull",partial=partt,data=mf, id.basis=id.basis.wk,weights=cnt,alpha=2) yhat <- predict(rho.wk,rho.wk$mf) rho.qd <- exp(rho.wk$nu*outer(log(quad$pt),yhat[!x.dup.ind],"-"))/quad$pt rhowk <- (exp(rho.wk$nu*(log(yy$end)-yhat))/yy$end)[yy$status] } ## integration weights at x.pt[i,] qd.wt <- matrix(0,nmesh,nx) for (i in 1:nobs) { wk <- (quad$pt<=yy$end[i])&(quad$pt>yy$start[i]) if (is.vector(rho.qd)) wk <- wk*rho.qd else wk <- wk*rho.qd[,x.ind[i]] if (is.null(cnt.wk)) qd.wt[,x.ind[i]] <- qd.wt[,x.ind[i]]+wk else qd.wt[,x.ind[i]] <- qd.wt[,x.ind[i]]+cnt.wk[i]*wk } if (is.null(cnt.wk)) qd.wt <- quad$wt*qd.wt/nobs else qd.wt <- quad$wt*qd.wt/sum(cnt.wk) ## Generate s, r, int.s, and int.r s <- r <- int.s <- int.r <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nT)) int.s <- c(int.s,sum(qd.wt)) next } vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] xy <- mf[yy$status,vlist] xy.basis <- mf[id.basis.wk,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist if (tname%in%vlist) qd.xy[,tname] <- quad$pt if (length(x.list)) xx <- x.pt[,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { s <- cbind(s,phi$fun(xy,nu=i,env=phi$env)) if (is.null(xx)) { qd.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) int.s <- c(int.s,sum(qd.wk*apply(qd.wt,1,sum))) } else { int.s.wk <- 0 for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- phi$fun(qd.xy[,,drop=TRUE],i,phi$env) int.s.wk <- int.s.wk + sum(qd.wk*qd.wt[,j]) } int.s <- c(int.s,int.s.wk) } } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE)),c(nT,nbasis,nq)) if (is.null(xx)) { qd.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,out=TRUE) int.r <- cbind(int.r,apply(apply(qd.wt,1,sum)*qd.wk,2,sum)) } else { int.r.wk <- 0 for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,TRUE) int.r.wk <- int.r.wk + apply(qd.wt[,j]*qd.wk,2,sum) } int.r <- cbind(int.r,int.r.wk) } } } } ## Add the partial term if (!is.null(part)) { s <- cbind(s,matx.p[yy$status,]) int.s <- c(int.s,t(matx.p[!x.dup.ind,])%*%apply(qd.wt,2,sum)) } ## generate int.z if (!is.null(random)) random$int.z <- t(qd.z)%*%apply(qd.wt,2,sum) ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rank=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in ssden1: id.basis out of range") nbasis <- length(id.basis) } ## Set domain and type, generate rho and quadrature if (is.null(quad)) quad <- as.list(NULL) rho <- rho.log <- as.list(NULL) rho.int <- rho.int2 <- NULL for (xlab in names(mf)) { x <- mf[[xlab]] if (is.factor(x)) { ## factor variable domain[[xlab]] <- NULL wt <- as.numeric(table(x)) rho[[xlab]] <- wt/sum(wt) quad[[xlab]] <- list(pt=unique(x),wt=rho[[xlab]]) rho.log[[xlab]] <- log(rho[[xlab]]) rho.int <- c(rho.int,sum(rho[[xlab]]*log(rho[[xlab]]))) rho.int2 <- c(rho.int2,sum(rho[[xlab]]*(log(rho[[xlab]]))^2)) } if (is.vector(x)&!is.factor(x)) { ## numerical vector if (is.null(domain[[xlab]])) { mn <- min(x) mx <- max(x) domain[[xlab]] <- c(mn,mx)+c(-1,1)*(mx-mn)*.05 } else domain[[xlab]] <- c(min(domain[[xlab]]),max(domain[[xlab]])) if (is.null(type[[xlab]])) type[[xlab]] <- list("cubic",domain[[xlab]]) else { if (length(type[[xlab]])==1) type[[xlab]] <- list(type[[xlab]][[1]],domain[[xlab]]) } form <- as.formula(paste("~",xlab)) rho[[xlab]] <- ssden(form,data=mf,type=type[xlab], domain=data.frame(domain[xlab]), alpha=2,id.basis=id.basis) qd.wk <- rho[[xlab]]$quad rho.wk <- dssden(rho[[xlab]],qd.wk$pt) qd.wk$pt <- qd.wk$pt[[1]] qd.wk$wt <- rho.wk*qd.wk$wt quad[[xlab]] <- qd.wk rho.log[[xlab]] <- log(rho.wk) rho.int <- c(rho.int,sum(log(rho.wk)*qd.wk$wt)) rho.int2 <- c(rho.int2,sum((log(rho.wk))^2*qd.wk$wt)) } if (is.matrix(x)) { ## numerical matrix if (is.null(quad[[xlab]])|is.null(quad)) stop("gss error in ssden1: no default quadrature") else { qd.wk <- quad[[xlab]] qd.wk$pt <- data.frame(I(qd.wk$pt)) colnames(qd.wk$pt) <- xlab form <- as.formula(paste("~",xlab)) rho[[xlab]] <- ssden(form,data=mf,type=type[xlab],quad=qd.wk, alpha=2,id.basis=id.basis) rho.wk <- dssden(rho[[xlab]],qd.wk$pt) quad[[xlab]]$wt <- rho.wk*quad[[xlab]]$wt rho.log[[xlab]] <- log(rho.wk) rho.int <- c(rho.int,sum(log(rho.wk)*quad[[xlab]]$wt)) rho.int2 <- c(rho.int2,sum((log(rho.wk))^2*quad[[xlab]]$wt)) } } } ## Generate terms term <- mkterm(mf,type) term$labels <- term$labels[term$labels!="1"] int <- mkint(mf,type,id.basis,quad,term,rho.log,rho.int) ## Generate s, r, and q s <- r <- NULL nq <- 0 for (label in term$labels) { x <- mf[,term[[label]]$vlist] x.basis <- mf[id.basis,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(x,x.basis,nu=i,env=rk$env,out=TRUE)),c(nobs,nbasis,nq)) } } } if (!is.null(s)) { nnull <- dim(s)[2] ## Check s rank if (qr(s)$rankalpha,(alpha.wk-alpha)*trc,0) cv+adj } ## initialization mu.r <- apply(wt*r,2,sum) v.r <- apply(wt*r^2,2,sum) mu.s <- apply(wt*s,2,sum) v.s <- apply(wt*s^2,2,sum) if (is.null(s)) theta <- 0 else theta <- log10(sum(v.s-mu.s^2)/nnull/sum(v.r-mu.r^2)*nxi) / 2 log.la0 <- log10(sum(v.r-mu.r^2)/sum(diag(q))) + theta ## lambda search cd <- rep(0,nxi+nnull) la <- log.la0 tol <- 0 scal <- NULL mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } ## return jk1 <- cv(zz$est) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL list(lambda=zz$est,theta=theta,c=c,d=d,scal=scal,cv=zz$min) } ## Calculate integrals of phi and rk for ssden1 mkint <- function(mf,type,id.basis,quad,term,rho,rho.int) { ## Obtain model terms mt <- attr(mf,"terms") xvars <- as.character(attr(mt,"variables"))[-1] xfacs <- attr(mt,"factors") term.labels <- labels(mt) vlist <- xvars[as.logical(apply(xfacs,1,sum))] ## Set types for marginals var.type <- NULL for (xlab in vlist) { x <- mf[,xlab] if (!is.null(type[[xlab]])) { ## Check consistency and set default parameters type.wk <- type[[xlab]][[1]] if (!(type.wk%in%c("ordinal","nominal","cubic","linear","per", "cubic.per","linear.per","tp","sphere","custom"))) stop("gss error in mkint: unknown type") if (type.wk%in%c("ordinal","nominal")) { par.wk <- NULL if (!is.factor(x)) stop("gss error in mkint: wrong type") } if (type.wk%in%c("cubic","linear")) { if (length(type[[xlab]])==1) { mn <- min(x) mx <- max(x) par.wk <- c(mn,mx)+c(-1,1)*.05*(mx-mn) } else par.wk <- type[[xlab]][[2]] if (is.factor(x)|!is.vector(x)) stop("gss error in mkint: wrong type") } if (type.wk%in%c("per","cubic.per","linear.per")) { if (type.wk=="per") type.wk <- "cubic.per" if (length(type[[xlab]])==1) stop("gss error in mkint: missing domain of periodicity") else par.wk <- type[[xlab]][[2]] if (is.factor(x)|!is.vector(x)) stop("gss error in mkint: wrong type") } if (type.wk=="tp") { if (length(type[[xlab]])==1) par.wk <- list(order=2,mesh=x,weight=1) else { par.wk <- par.wk1 <- type[[xlab]][[2]] if (length(par.wk1)==1) par.wk <- list(order=par.wk1,mesh=x,weight=1) if (is.null(par.wk$mesh)) par.wk$mesh <- x if (is.null(par.wk$weight)) par.wk$weight <- 1 } if (dim(as.matrix(x))[2]!=dim(as.matrix(par.wk$mesh))[2]) stop("gss error in mkint: wrong dimension in normalizing mesh") } if (type.wk=="sphere") { if (length(type[[xlab]])==1) par.wk <- 2 else par.wk <- type[[xlab]][[2]] if (!(par.wk%in%(2:4))) stop("gss error in mkint: spherical order not implemented") } if (type.wk=="custom") par.wk <- type[[xlab]][[2]] } else { ## Set default types if (is.factor(x)) { ## categorical variable if (is.ordered(x)) type.wk <- "ordinal" else type.wk <- "nominal" par.wk <- NULL } else { ## numerical variable if (is.vector(x)) { type.wk <- "cubic" mn <- min(x) mx <- max(x) par.wk <- c(mn,mx)+c(-1,1)*.05*(mx-mn) } else { type.wk <- "tp" par.wk <- list(order=2,mesh=x,weight=1) } } } var.type[[xlab]] <- list(type.wk,par.wk) } ## Create phi and rk nbasis <- length(id.basis) nvar <- length(names(mf)) s <- r <- s.rho <- r.rho <- NULL ns <- nq <- 0 for (label in term.labels) { ns <- ns+term[[label]]$nphi nq <- nq+term[[label]]$nrk vlist <- xvars[as.logical(xfacs[,label])] x <- mf[,vlist] dm <- length(vlist) phi <- rk <- NULL if (dm==1) { type.wk <- var.type[[vlist]][[1]] xx <- mf[id.basis,vlist] xmesh <- quad[[vlist]]$pt if (type.wk%in%c("nominal","ordinal")) { ## factor variable if (type.wk=="nominal") fun <- mkrk.nominal(levels(x)) else fun <- mkrk.ordinal(levels(x)) if (nlevels(x)>2) { ## rk rk <- fun$fun(xmesh,xx,fun$env,TRUE) } else { ## phi wk <- as.factor(names(fun$env$code)[1]) phi <- fun$fun(xmesh,wk,fun$env) } } if (type.wk=="cubic") { ## cubic splines range <- var.type[[vlist]][[2]] ## phi phi.fun <- mkphi.cubic(range) phi <- phi.fun$fun(xmesh,1,phi.fun$env) ## rk rk.fun <- mkrk.cubic(range) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, and linear periodic splines range <- var.type[[vlist]][[2]] ## rk if (type.wk=="cubic.per") rk.fun <- mkrk.cubic.per(range) if (type.wk=="linear") rk.fun <- mkrk.linear(range) if (type.wk=="linear.per") rk.fun <- mkrk.linear.per(range) if (type.wk=="sphere") rk.fun <- mkrk.sphere(range) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk=="tp") { ## thin-plate splines par <- var.type[[vlist]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x)) xdim <- 1 else xdim <- dim(x)[2] ## phi phi.fun <- mkphi.tp(xdim,order,mesh,weight) nphi <- choose(xdim+order-1,xdim)-1 if (nphi>0) { for (nu in 1:nphi) { phi <- cbind(phi,phi.fun$fun(xmesh,nu,phi.fun$env)) } } ## rk rk.fun <- mkrk.tp(xdim,order,mesh,weight) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk=="custom") { ## user-defined par <- var.type[[vlist]][[2]] nphi <- par$nphi if (nphi>0) { phi.fun <- par$mkphi(par$env) for (nu in 1:nphi) { phi <- cbind(phi,phi.fun$fun(xmesh,nu,phi.fun$env)) } } rk.fun <- par$mkrk(par$env) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } wmesh <- quad[[vlist]]$wt if (!is.null(phi)) { s.rho.wk <- rho.int*sum(wmesh*phi) s.rho.wk[names(mf)==vlist] <- sum(wmesh*rho[[vlist]]*phi) s <- c(s,sum(wmesh*phi)) s.rho <- c(s.rho,sum(s.rho.wk)) } if (!is.null(rk)) { r.rho.wk <- outer(apply(wmesh*rk,2,sum),rho.int) r.rho.wk[,names(mf)==vlist] <- apply(wmesh*rho[[vlist]]*rk,2,sum) r <- cbind(r,apply(wmesh*rk,2,sum)) r.rho <- cbind(r.rho,apply(r.rho.wk,1,sum)) } } else { bin.fac <- n.phi <- phi.list <- rk.list <- NULL for (i in 1:dm) { type.wk <- var.type[[vlist[i]]][[1]] if (type.wk%in%c("nominal","ordinal")) { ## factor variable if (type.wk=="nominal") rk.wk <- mkrk.nominal(levels(x[[i]])) else rk.wk <- mkrk.ordinal(levels(x[[i]])) phi.wk <- rk.wk n.phi <- c(n.phi,0) bin.fac <- c(bin.fac,!(nlevels(x[[i]])>2)) } if (type.wk=="cubic") { ## cubic or linear splines range <- var.type[[vlist[i]]][[2]] ## phi phi.wk <- mkphi.cubic(range) n.phi <- c(n.phi,1) ## rk rk.wk <- mkrk.cubic(range) bin.fac <- c(bin.fac,0) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, or linear periodic splines range <- var.type[[vlist[i]]][[2]] n.phi <- c(n.phi,0) phi.wk <- NULL if (type.wk=="cubic.per") rk.wk <- mkrk.cubic.per(range) if (type.wk=="linear") rk.wk <- mkrk.linear(range) if (type.wk=="linear.per") rk.wk <- mkrk.linear.per(range) if (type.wk=="sphere") rk.wk <- mkrk.sphere(range) bin.fac <- c(bin.fac,0) } if (type.wk=="tp") { ## thin-plate splines par <- var.type[[vlist[i]]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x[[i]])) xdim <- 1 else xdim <- dim(x[[i]])[2] phi.wk <- mkphi.tp(xdim,order,mesh,weight) n.phi <- c(n.phi,choose(xdim+order-1,xdim)-1) rk.wk <- mkrk.tp(xdim,order,mesh,weight) bin.fac <- c(bin.fac,0) } if (type.wk=="custom") { ## user-defined par <- var.type[[vlist[i]]][[2]] n.phi <- c(n.phi,par$nphi) if (par$nphi>0) phi.wk <- par$mkphi(par$env) else phi.wk <- NULL rk.wk <- par$mkrk(par$env) bin.fac <- c(bin.fac,0) } phi.list <- c(phi.list,list(phi.wk)) rk.list <- c(rk.list,list(rk.wk)) } ## phi id0 <- names(mf)%in%vlist nphi <- term[[label]]$nphi iphi <- term[[label]]$iphi if (nphi>0) { for (nu in 1:nphi) { ind <- nu - 1 s.wk <- 1 s.rho.wk <- rho.int s.rho.wk[id0] <- 1 for (i in 1:dm) { phi.wk <- phi.list[[i]] xmesh <- quad[[vlist[i]]]$pt if (bin.fac[i]) { wk <- as.factor(names(phi.wk$env$code)[1]) phi <- phi.wk$fun(xmesh,wk,phi.wk$env) } else { code <- ind%%n.phi[i] + 1 ind <- ind%/%n.phi[i] phi <- phi.wk$fun(xmesh,code,phi.wk$env) } wmesh <- quad[[vlist[i]]]$wt s.wk <- s.wk*sum(wmesh*phi) id1 <- names(mf)==vlist[i] s.rho.wk[id1] <- s.rho.wk[id1]*sum(wmesh*rho[[vlist[i]]]*phi) s.rho.wk[!id1] <- s.rho.wk[!id1]*sum(wmesh*phi) } s <- c(s,s.wk) s.rho <- c(s.rho,sum(s.rho.wk)) } } ## rk n.rk <- ifelse(n.phi,2,1) nrk <- prod(n.rk) - as.logical(nphi) if (nrk>0) { for (nu in 1:nrk) { ind <- nu - !nphi r.wk <- 1 r.rho.wk <- outer(rep(1,nbasis),rho.int) r.rho.wk[,id0] <- 1 for (i in 1:dm) { code <- ind%%n.rk[i] + 1 ind <- ind%/%n.rk[i] xx <- mf[id.basis,vlist[[i]]] xmesh <- quad[[vlist[i]]]$pt if (code==n.rk[i]) { rk.wk <- rk.list[[i]] rk <- rk.wk$fun(xmesh,xx,rk.wk$env,TRUE) } else { rk <- 0 phi.wk <- phi.list[[i]] for (j in 1:n.phi[i]) { phix <- phi.wk$fun(xmesh,j,phi.wk$env) phiy <- phi.wk$fun(xx,j,phi.wk$env) rk <- rk + outer(phix,phiy) } } wmesh <- quad[[vlist[i]]]$wt r.wk <- r.wk*apply(wmesh*rk,2,sum) id1 <- names(mf)==vlist[i] r.rho.wk[,id1] <- r.rho.wk[,id1]*apply(wmesh*rho[[vlist[i]]]*rk,2,sum) r.rho.wk[,!id1] <- r.rho.wk[,!id1]*apply(wmesh*rk,2,sum) } r <- cbind(r,r.wk) r.rho <- cbind(r.rho,apply(r.rho.wk,1,sum)) } } } } list(s=s,r=r,s.rho=s.rho,r.rho=r.rho,var.type=var.type) } gss/R/gssanova0.R0000644000176200001440000003724313504451112013300 0ustar liggesusers## Fit gssanova0 model gssanova0 <- function(formula,family,type=NULL,data=list(),weights, subset,offset,na.action=na.omit,partial=NULL, method=NULL,varht=1,nu=NULL,prec=1e-7,maxiter=30) { if (!(family%in%c("binomial","poisson","Gamma","nbinomial","inverse.gaussian", "polr","weibull","lognorm","loglogis"))) stop("gss error in gssanova0: family not implemented") ## Obtain model frame and model terms mf <- match.call() mf$family <- mf$type <- mf$partial <- NULL mf$method <- mf$varht <- mf$nu <- NULL mf$prec <- mf$maxiter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) ## Generate terms term <- mkterm(mf,type) ## Specify default method if (is.null(method)) { method <- switch(family, binomial="u", nbinomial="u", poisson="u", inverse.gaussian="v", Gamma="v", polr="u", weibull="u", lognorm="u", loglogis="u") } ## Generate s, q, and y nobs <- dim(mf)[1] s <- q <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nobs)) next } x <- mf[,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 q <- array(c(q,rk$fun(x,x,nu=i,env=rk$env,out=TRUE)),c(nobs,nobs,nq)) } } } ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in ssanova: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL if (qr(s)$rank=nnull)&(nnull>0))) { stop("gss error in sspregpoi: inputs have wrong dimensions") } ## Set method for smoothing parameter selection code <- (1:3)[c("v","m","u")==method] if (!length(code)) { stop("gss error: unsupported method for smoothing parameter selection") } eta <- rep(0,nobs) nla0 <- log10(mean(abs(diag(q)))) limnla <- nla0+c(-.5,.5) if (family%in%c("Gamma","inverse.gaussian")) { ywk <- log(y) if (!is.null(offset)) ywk <- ywk-offset swk <- s qwk <- q if (!is.null(wt)) { w <- sqrt(wt) ywk <- w*ywk swk <- w*swk qwk <- w*t(w*qwk) } else w <- 1 z <- .Fortran("dsidr0", as.integer(code), swk=as.double(swk), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(ywk), qwk=as.double(qwk), as.integer(nobs), as.double(0), as.integer(-1), as.double(limnla), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), qraux=double(nnull), jpvt=integer(nnull), double(3*nobs), info=integer(1),PACKAGE="gss") eta <- (ywk-10^z$nlambda*z$c)/w } if (family=="nbinomial") nu <- NULL else nu <- list(nu,is.null(nu)) if (family=="polr") { if (is.null(wt)) P <- apply(y,2,sum) else P <- apply(y*wt,2,sum) P <- P/sum(P) P <- cumsum(P) nnu <- length(P)-2 eta <- rep(qlogis(P[1]),nobs) nu <- diff(qlogis(P[-(nnu+2)])) } iter <- 0 repeat { iter <- iter+1 dat <- switch(family, binomial=mkdata.binomial(y,eta,wt,offset), nbinomial=mkdata.nbinomial(y,eta,wt,offset,nu), polr=mkdata.polr(y,eta,wt,offset,nu), poisson=mkdata.poisson(y,eta,wt,offset), inverse.gaussian=mkdata.inverse.gaussian(y,eta,wt,offset), Gamma=mkdata.Gamma(y,eta,wt,offset), weibull=mkdata.weibull(y,eta,wt,offset,nu), lognorm=mkdata.lognorm(y,eta,wt,offset,nu), loglogis=mkdata.loglogis(y,eta,wt,offset,nu)) nu <- dat$nu w <- as.vector(sqrt(dat$wt)) ywk <- w*dat$ywk swk <- w*s qwk <- w*t(w*q) ## Call RKPACK driver DSIDR z <- .Fortran("dsidr0", as.integer(code), swk=as.double(swk), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(ywk), qwk=as.double(qwk), as.integer(nobs), as.double(0), as.integer(-1), as.double(limnla), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), qraux=double(nnull), jpvt=integer(nnull), double(3*nobs), info=integer(1),PACKAGE="gss") ## Check info for error if (info<-z$info) { if (info>0) stop("gss error in sspregpoi: matrix s is rank deficient") if (info==-2) stop("gss error in sspregpoi: matrix q is indefinite") if (info==-1) stop("gss error in sspregpoi: input data have wrong dimensions") if (info==-3) stop("gss error in sspregpoi: unknown method for smoothing parameter selection.") } eta.new <- (ywk-10^z$nlambda*z$c)/w if (!is.null(offset)) eta.new <- eta.new + offset disc <- sum(dat$wt*((eta-eta.new)/(1+abs(eta)))^2)/sum(dat$wt) limnla <- pmax(z$nlambda+c(-.5,.5),nla0-5) if (disc=maxiter) { warning("gss warning in gssanova0: performance-oriented iteration fails to converge") break } eta <- eta.new } ## Return the fit if (is.list(nu)) nu <- nu[[1]] c(list(method=method,theta=0,w=as.vector(dat$wt), eta=as.vector(eta),iter=iter,nu=nu), z[c("c","d","nlambda","score","varht","swk","qraux","jpvt","qwk")]) } ## Fit Multiple Smoothing Parameter REGression by Performance-Oriented Iteration mspregpoi <- function(family,s,q,y,wt,offset,method="u", varht=1,nu,prec=1e-7,maxiter=30) { ## Check inputs if (is.vector(s)) s <- as.matrix(s) if (!(is.matrix(s)&is.array(q)&(length(dim(q))==3) &is.character(method))) { stop("gss error in mspregpoi: inputs are of wrong types") } nobs <- dim(s)[1] nnull <- dim(s)[2] nq <- dim(q)[3] if (!((dim(s)[1]==nobs)&(dim(q)[1]==nobs)&(dim(q)[2]==nobs) &(nobs>=nnull)&(nnull>0))) { stop("gss error in sspregpoi: inputs have wrong dimensions") } ## Set method for smoothing parameter selection code <- (1:3)[c("v","m","u")==method] if (!length(code)) { stop("gss error: unsupported method for smoothing parameter selection") } eta <- rep(0,nobs) init <- 0 theta <- rep(0,nq) if (family%in%c("Gamma","inverse.gaussian")) { ywk <- log(y) if (!is.null(offset)) ywk <- ywk-offset swk <- s qwk <- q if (!is.null(wt)) { w <- sqrt(wt) ywk <- w*ywk swk <- w*swk for (i in 1:nq) qwk[,,i] <- w*t(w*qwk[,,i]) } else w <- 1 ## Call RKPACK driver DMUDR z <- .Fortran("dmudr0", as.integer(code), as.double(swk), # s as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(qwk), # q as.integer(nobs), as.integer(nobs), as.integer(nq), as.double(ywk), # y as.double(0), as.integer(init), as.double(prec), as.integer(maxiter), theta=as.double(theta), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), integer(nnull+nq), double(nobs*nobs*(nq+2)), info=integer(1),PACKAGE="gss")[c("theta","nlambda","c","info")] eta <- (ywk-10^z$nlambda*z$c)/w } if (family=="nbinomial") nu <- NULL else nu <- list(nu,is.null(nu)) if (family=="polr") { if (is.null(wt)) P <- apply(y,2,sum) else P <- apply(y*wt,2,sum) P <- P/sum(P) P <- cumsum(P) nnu <- length(P)-2 eta <- rep(qlogis(P[1]),nobs) nu <- diff(qlogis(P[-(nnu+2)])) } qwk <- array(0,c(nobs,nobs,nq)) iter <- 0 repeat { iter <- iter+1 dat <- switch(family, binomial=mkdata.binomial(y,eta,wt,offset), nbinomial=mkdata.nbinomial(y,eta,wt,offset,nu), polr=mkdata.polr(y,eta,wt,offset,nu), poisson=mkdata.poisson(y,eta,wt,offset), inverse.gaussian=mkdata.inverse.gaussian(y,eta,wt,offset), Gamma=mkdata.Gamma(y,eta,wt,offset), weibull=mkdata.weibull(y,eta,wt,offset,nu), lognorm=mkdata.lognorm(y,eta,wt,offset,nu), loglogis=mkdata.loglogis(y,eta,wt,offset,nu)) nu <- dat$nu w <- as.vector(sqrt(dat$wt)) ywk <- w*dat$ywk swk <- w*s for (i in 1:nq) qwk[,,i] <- w*t(w*q[,,i]) ## Call RKPACK driver DMUDR z <- .Fortran("dmudr0", as.integer(code), as.double(swk), # s as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(qwk), # q as.integer(nobs), as.integer(nobs), as.integer(nq), as.double(ywk), # y as.double(0), as.integer(init), as.double(prec), as.integer(maxiter), theta=as.double(theta), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), integer(nnull+nq), double(nobs*nobs*(nq+2)), info=integer(1),PACKAGE="gss")[c("theta","nlambda","c","info")] ## Check info for error if (info<-z$info) { if (info>0) stop("gss error in mspreg: matrix s is rank deficient") if (info==-2) stop("gss error in mspreg: matrix q is indefinite") if (info==-1) stop("gss error in mspreg: input data have wrong dimensions") if (info==-3) stop("gss error in mspreg: unknown method for smoothing parameter selection.") if (info==-4) stop("gss error in mspreg: iteration fails to converge, try to increase maxiter") if (info==-5) stop("gss error in mspreg: iteration fails to find a reasonable descent direction") } eta.new <- (ywk-10^z$nlambda*z$c)/w if (!is.null(offset)) eta.new <- eta.new + offset disc <- sum(dat$wt*((eta-eta.new)/(1+abs(eta)))^2)/sum(dat$wt) if (disc=maxiter) { warning("gss warning in gssanova0: performance-oriented iteration fails to converge") break } init <- 1 theta <- z$theta eta <- eta.new } qqwk <- 10^z$theta[1]*qwk[,,1] for (i in 2:nq) qqwk <- qqwk + 10^z$theta[i]*qwk[,,i] ## Call RKPACK driver DSIDR z <- .Fortran("dsidr0", as.integer(code), swk=as.double(swk), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(ywk), qwk=as.double(qqwk), as.integer(nobs), as.double(0), as.integer(0), double(2), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), qraux=double(nnull), jpvt=integer(nnull), double(3*nobs), info=integer(1),PACKAGE="gss") ## Check info for error if (info<-z$info) { if (info>0) stop("gss error in sspregpoi: matrix s is rank deficient") if (info==-2) stop("gss error in sspregpoi: matrix q is indefinite") if (info==-1) stop("gss error in sspregpoi: input data have wrong dimensions") if (info==-3) stop("gss error in sspregpoi: unknown method for smoothing parameter selection.") } ## Return the fit if (is.list(nu)) nu <- nu[[1]] c(list(method=method,theta=theta,w=as.vector(dat$wt), eta=as.vector(eta),iter=iter,nu=nu), z[c("c","d","nlambda","score","varht","swk","qraux","jpvt","qwk")]) } gss/MD50000644000176200001440000002444714467046032011377 0ustar liggesusers2a02523df5f65fade80fc61ca5d6ca0d *ChangeLog cc45f783ba92f2a0f18365370beff1b9 *DESCRIPTION 24ff2b8f15521a49b59f6d19146ae6df *INDEX 20c494cb2d9aaa1a65f87cf5afd95df6 *NAMESPACE 1d00015b10d8256aaede525722621ffc *R/cdsscden.R 03873ecc380382307d04da914fb5a866 *R/cdssden.R a4cf561453300bc881519be811e6e36c *R/dsscden.R 5f66fd9114c60674b70e12eeff2b4348 *R/dsscopu.R ba70f48201a45f359a77132e32d9362e *R/dssden.R 559874c71d989cb315af06eca7797c56 *R/family.R 8cf03c37c38512d84831d3ddad9c33b7 *R/family.cv.R e845e29cbedeefa26e421410d897ebf5 *R/family.proj.R 630dbcbb2a0ced555d40e693b7b3f4d4 *R/family.surv.R d67212f47d1a4287b478740f0fb89992 *R/fitted.R 7b557a66a85c9a87034d408e71e30a95 *R/gauss.quad.R 44820ea5c3a2830f4898feb2b0a953ec *R/gssanova.R a7d4175fd62610cc6cf16dd89370efc8 *R/gssanova0.R d808f0ceba65016c236be3c9205d0d35 *R/gssanova1.R 6c3e4ff3a275316cd1dc8a86ad5a8a1e *R/hzdrate.sshzd.R 279a226b1a90eaa6410d85d1fa2849a9 *R/hzdrate.sshzd2d.R ba480f598f999c0bd40994ec8a691265 *R/mkfun.factor.R 4c2cdef0b4e6be8ae7d13346019d1e96 *R/mkfun.poly.R c3ab6e0ee996934b2d681a99684cb120 *R/mkfun.tp.R 2f4bbe69e527ab0068a10cba01841650 *R/mkran.R fc77d100b2edf15f7250cb7af2bde8a7 *R/mkterm.R d32763a8918ad0f6ef9e4b50145e7d1f *R/mkterm.copu.R 31a34905a534717e3a46d00c318da735 *R/nlm0.R d0a27b81504af2d1dd02c301a9e6a5ed *R/predict.ssanova.R 4075695b83a644ae4481fe43d19d5e6f *R/predict.ssanova0.R a5f376202a80abde5e4806400f20e069 *R/predict.sscox.R 69a1b4f7f840ea940e8c59d75097f260 *R/predict.ssllrm.R 1d5e86d04a2da11fc571099520dcdf2e *R/predict1.ssanova.R 1ed0d07ad9a5774cbe3fc86b90c3afcb *R/predict9.gssanova.R 7920112ccf98cfed9741685643f65c2a *R/print.R 161939fa752eeb960a58bf176dd8a1a2 *R/project.gssanova.R 500416a79d3297d43b5f35c78b640fda *R/project.ssanova.R 023ed96bb4991e538c3f38a7a8bb3224 *R/project.ssanova9.R 5a78c5b0ac10960f45efb305efa74b00 *R/project.sscden.R efcfe6ca48d01c38d4db04c26e138805 *R/project.sscden1.R 50ed5e000696a4ec366834a09673e448 *R/project.sscox.R 89a6175fe772e65c76ab3eb644acd316 *R/project.ssden.R 8133bee08081d95af25fd6d2a1f905de *R/project.ssden1.R fdc26fdef9a730f792d3c3bd146c0940 *R/project.sshzd.R 794230b5f6c1e47dfca0fef94ebbf311 *R/project.sshzd1.R bf5f875bbef9fb78e75bafa5aa4be563 *R/project.ssllrm.R d44fab9e998870ebdb9a3c393d0ef756 *R/smolyak.R 130bccf11eaaafdb66f68400922fb136 *R/ssanova.R dd4aa54b10ec5e2a8b0cdff18780d562 *R/ssanova0.R 9be84d7ff1b4e8a5922bd678ace8b40f *R/ssanova9.R e1116b822c3eb69277327986d68a3442 *R/sscden.R ee6cf7aa7fb80d9d31eab3bf3a10c1db *R/sscden1.R 468b6ff1613445eb7dd882e25af66657 *R/sscomp.R 58bfc87ec8debc40bdf3ad95f4df085e *R/sscopu.R 111d09029fc69db43413326a418fb286 *R/sscopu2.R 546fb2d365d07ba2fe8c849fc61fc535 *R/sscox.R eca55daa6a2f41af5fe5fd7638355067 *R/ssden.R 2e0ef078199d518ec290ee53b0f670de *R/ssden1.R 7ef60ce2b228eae4b80aa8aff8f09613 *R/sshzd.R 509dfe0ae1377f1ea3217c895ac479c1 *R/sshzd1.R 034ccfa7456e792c0b3d7eb713b81e66 *R/sshzd2d.R 7c2a581bcccafc22c2a86e9400b28d29 *R/sshzd2d1.R 2a68981c695d7a44c1f226ff25408e18 *R/ssllrm.R fac24e981530048b0cdf9980a60126e2 *R/summary.gssanova.R dc973dd626db68af7585fa0233b266de *R/summary.gssanova0.R f9805d33f3e9d8013a2af47d14dc19a1 *R/summary.ssanova.R 40f6550ca74d0c14b1717ca3a0ea1fcf *R/summary.ssanova0.R 78ea076049b4b5ee299b7afb350eeb66 *R/summary.ssanova9.R f77abe1a673b168b75abc39f7fa9a727 *R/summary.sscopu.R 9ce9ec1d9250c18ad44e72ee8c541e4a *data/ColoCan.rda 70d168f39751ee7f0dbb7d93af803f68 *data/DiaRet.rda 3145712024c9dedd15cf60dc0fb64ecd *data/LakeAcidity.rda ad80f968d57f05c7ebed283c7915b802 *data/NO2.rda d8ccc78c8920c5cbcf6aa0e6811ed2f3 *data/Sachs.rda e57c8caa375d9f1430075eb220b6b4bb *data/aids.rda 89a53b248dac7ca367716e53b9f9ee2d *data/bacteriuria.rda edc0fa56c6ed3105c5ef0db23f1db754 *data/buffalo.rda 80fbfa46478519bfef63f7273c26426a *data/clim.rda 859000aac78d9cf4daf9dccaee10fc05 *data/datalist ef02087079a643407bdc46053a4151d1 *data/esc.rda 0214cbea0edd4053ff98fd6879da055f *data/eyetrack.rda 2fda763174a42f62e4f3099099fa16e9 *data/gastric.rda 14b1a52200df8d0bb414a67e7225f168 *data/nox.rda 14d1a99e253cfaca9ed3b844c56f56f6 *data/ozone.rda 76ee41bd2ae5e4e529083f7674654008 *data/penny.rda d6adf9da6fe5ecce007f045571b3446c *data/stan.rda 8673483e369552cb0e689f3b6cc6d51a *data/wesdr.rda 7acbab4695c3b911d69cf247b69307a6 *data/wesdr1.rda d2a45ced740b76cad374d3d92c00e2cc *inst/CITATION 32d73dfce00a970c059641055a5b649b *man/ColoCan.Rd a45646c483d0bf6db3e2895d5465f584 *man/DiaRet.Rd 793f6947019c179822061319b015d57c *man/LakeAcid.Rd d5a2a41462333c2bbaa0444a74b087dd *man/NO2.Rd d04b205cce2af540f0afa08176afd0fc *man/Sachs.Rd 55ee7c180c457d46907a6ff14771804b *man/aids.Rd ffb9bbbf8ef1fbbed74487941bb5cfb3 *man/bacteriuria.Rd 1b0fc9c7907479928613d262fa968c5d *man/buffalo.Rd 64ef61142b7165f4121f7f21e821e16e *man/cdsscden.Rd d8dde63ddeb054d13a13a0e16d1ebfe7 *man/cdsscopu.Rd bd92f0ddbeec75e6440c38931d18af0b *man/cdssden.Rd 1b62cd411e4c41b609b3612f1361fda4 *man/clim.Rd 64e72138ea19c94dcd982f953e9bc1de *man/drkpk.Rd 5136c9fcf98724df23adbfaa0f1a3031 *man/dsscden.Rd 13843cbb1bb87239b6726e6b36cfaea5 *man/dsscopu.Rd 82d09278017ba1cdddaa4af1a373dd8b *man/dssden.Rd 114f4cc486a64d7674ccaeb0b857debb *man/esc.Rd 686bb2d546beb831a4fe7ba867d2756e *man/eyetrack.Rd f9cece6cc9c9ce2d58f6dc5de15fd559 *man/family.Rd dda15a9a83ecb188869a62fe8c365bbc *man/fitted.ssanova.Rd bc0e697ece8b40036c0622eb991f9891 *man/gastric.Rd e9293dcf07871dc5bcdbcd7b9c3fe0b5 *man/gauss.quad.Rd 3d41238bda91330ba7c93eb8d35f5336 *man/gssanova.Rd d070e2db6575d29260e58784ac602b00 *man/gssanova0.Rd 26b2145d58e43e389ba617d56d94f8f9 *man/hzdrate.sshzd.Rd 7eb11c08fd862bb9e8d002f32f30cc70 *man/hzdrate.sshzd2d.Rd 00cb17012b3ee831dfd9af1132dee904 *man/mkcov.Rd 4a3c621489c9591aab9e4e81c4d7405b *man/mkfun.poly.Rd a9e4bf00e16efd673ccd3671701b86df *man/mkfun.tp.Rd bc0e6abaa2ebea0f31a44a64a949e06b *man/mkint.Rd 1af33c60eb4473b4e42b77be33bae270 *man/mkran.Rd 38b7a5e17d1b385ff685a05809a6be5d *man/mkrk.nominal.Rd 13383217513ca37d629f66987fb20764 *man/mkterm.Rd d9acdbbba9d1394e05e4d4e60bc7fbb6 *man/mkterm.copu.Rd 1fc2a21bfc2a4e3c0c40a037683092b8 *man/nlm0.Rd 8ffe3ac3ec02519e6d8a0e0920756bd3 *man/nox.Rd 1ced7f15a22206d634646c7d91fa8be4 *man/ozone.Rd 1830f01cdebb34dfe0dd85c63967ca95 *man/penny.Rd d9a9349af46dd349bd7661af553b224e *man/predict.ssanova.Rd f1031a154441bfa546dbed6aaba1f850 *man/predict.sscox.Rd c2845df2c4abe914df8da3987878c04f *man/predict.ssllrm.Rd 69213523b385d0dc1b60953c91af9d4f *man/predict9.gssanova.Rd 5150517560e37ede041a844416192beb *man/print.Rd 23a1e477e5b118d1959c03e3dc763415 *man/project.Rd ae30483040f94edd5bc1b7ccf0a20e3b *man/rkpk.Rd 3b0f5a8fc36d87f14e4db4c5a1964031 *man/rkpk0.Rd 32edd24c1adea47f5e0f670b038cd1fe *man/smolyak.Rd ea1852ffb73163612798d83f5fcd234e *man/ssanova.Rd e2f739c757a04a968ec837b15ed91985 *man/ssanova0.Rd e54aa57ed8c94851cb790cd9de84b871 *man/ssanova9.Rd a56a56fb459ddc58c95c27e8b9e37ef8 *man/sscden.Rd 1d92a0c060573da3d08e81b383fdbab9 *man/sscomp.Rd 142a1be80d200caf0cbd80218c2db7bc *man/sscopu.Rd 4df29e6fff4a4655285f24904cb212c3 *man/sscox.Rd 97f4d0c57cfa8fac287275a9588eca88 *man/ssden.Rd 70d5daebdaa78461edd01971b5ae0eb8 *man/sshzd.Rd 513254fc2353d48651af7ee5f8e37738 *man/sshzd2d.Rd 7866d530cb82a79cd0391f8ec15e7310 *man/ssllrm.Rd c6978a9dac3ca67cbbcbed67eceda37c *man/stan.Rd d7fbd3d264c4cee3e7f28f35a242d4d3 *man/summary.gssanova.Rd 501dd64ca6915a4f948de0da284d1adb *man/summary.gssanova0.Rd 072eb87b44b0ee5e1b3c2fc1071597fb *man/summary.ssanova.Rd b0e7665b79306793fbd628809d571433 *man/summary.sscopu.Rd 059d93eed2184e0a2c369361c320f7c1 *man/wesdr.Rd b764b3c234f939a11cd1ccee3b232504 *man/wesdr1.Rd 3996e7c16bfb96fad295ee425815cb4d *src/Makevars 37dca64bf73d7909f27cbd6d2cd3f2f0 *src/cdennewton.f 4e67ce7d8cc4fd22060332890775b0f6 *src/cdennewton10.f f1383a9db3a2c3f57344e7d543304f69 *src/copu2newton.f 49a626d6c2996e9689d6407d13ef3208 *src/dchdc0.f 4b13a03ed2b66fe6609b5bbedaf5d4aa *src/dcoef.f 0397f8ad2f424a537596daf5648c5788 *src/dcore.f b05ac68613d1536384c72933d4d089be *src/dcrdr.f 968096f8478576a7498a40d2add915ef *src/ddeev.f 0fd549e321be807aa972cceb1a9664bf *src/deval.f a94132bb1ece837eaddf785cf86b1428 *src/dgold.f d7f744ee2a26b279ae01823b7c071cc0 *src/dmcdc.f 4ee8f16224deb7d3166028232a777a47 *src/dmudr0.f 00c69302ead7f29aa45e3ec7dcc66830 *src/dmudr1.f 06b253fca493cf38fd5f210dbfb81ec5 *src/dnewton.f 5b0ab36ba00b9a5a7dabbc1b6692aaff *src/dnewton10.f 578daa3fc73da505c7fe8147b6d0cf5c *src/dprmut.f 45037df0af9f0aae663bf7ceac7477ff *src/dqrslm.f ccc38fe95e3e064831f2801ac62e4740 *src/drkl.f 5b1127dd13305626b234153828681e80 *src/dset.f 850413eb424e68f885ee2069a819bd41 *src/dsidr0.f 7357046ce5ccc305ed8332c3bed8afa8 *src/dsms.f fcef4ec86358606bab842a5eb96e27cb *src/dstup.f 9e3973564e31c2dff1657737f949c80f *src/dsytr.f 6ccc43719ebac5b1c12931866f7787f9 *src/dtrev.f 20be902775d8abbf49e6bbbc786123ba *src/gaussq.f 53df31681eb9b0911ec8bb3b5e9cc0c5 *src/hzdaux.f 03ff521546b84739f3fc89c7bc792739 *src/hzdnewton.f 06ab6f66d7719b6b9bd51934acf20344 *src/hzdnewton10.f f3314da76ddac6f573346ba745289e56 *src/init.c c37f1e2c7bacbb8efe5d4e0b76fdbd7b *src/llrmnewton.f 934daea975278086d73e39bde021d31d *src/ratfor/cdennewton.r 7dc90bb33c247261b8a7a3d842feeaa6 *src/ratfor/cdennewton10.r 790bb03fc8ca8f227716448825557de7 *src/ratfor/copu2newton.r 57513875ad06d41c764fcb0836199c72 *src/ratfor/dcoef.r 12e1a53c32afb2d47052dfc20c4123bb *src/ratfor/dcore.r a9e6c989d58c2f3f2b43225ce9f57f92 *src/ratfor/dcrdr.r a8c4f9f02a85391693329789f3bbb3d9 *src/ratfor/ddeev.r a70f06d98f350507cf546180e258c97b *src/ratfor/deval.r 39957e2b161d7124f09a0c54d85044de *src/ratfor/dgold.r 242ec1b116c8ab74c8ffdd4bf2d6bd7f *src/ratfor/dmcdc.r 8b6267008c0053f4a01bb41c6a7ebf23 *src/ratfor/dmudr0.r f9e9d9298d2a377c3a2368689aa37f1c *src/ratfor/dmudr1.r 68101b908c8b51ae1b047938803b562e *src/ratfor/dnewton.r 4fe3f3a7a9869bceee52349a60b4daf3 *src/ratfor/dnewton10.r 690c1d1d61531b1b4eb1f9736fc1baa1 *src/ratfor/dqrslm.r 06be81c74d6587e2ddffe8022990f619 *src/ratfor/drkl.r 7c881780b5711e7f018c229552236376 *src/ratfor/dsidr0.r fc30b77cb526b372b560f473cdf286c6 *src/ratfor/dsms.r 3179f245153d887b2cf940a26f4cc8ee *src/ratfor/dstup.r 156ccddfe52ab269f286bdb05b155219 *src/ratfor/dsytr.r 76331632a7746e8c50d16b393d086238 *src/ratfor/dtrev.r bcdbcc551d93478fb042faab91d07de3 *src/ratfor/hzdaux.r 2cf5fc690923931e670ec32df73ba609 *src/ratfor/hzdnewton.r 467f442b1c5762e5fe70af473b424c2e *src/ratfor/hzdnewton10.r 7802710a510909897dc228a963955481 *src/ratfor/llrmnewton.r 1adfc4d2c5221073ab11fead8e648a23 *src/ratfor/reg.r 2bc24e9a922a2c13117e11cc60e2d6ba *src/reg.f c2cd8d4526f5d60b5582ac3aa1554ada *src/smolyak.c gss/INDEX0000644000176200001440000003654013663110330011644 0ustar liggesusers## SSANOVA, GSSANOVA, SSDEN, SSCDEN, SSLLRM, SSHZD, AND SSCOX SUITES ssanova Fitting smoothing spline ANOVA models predict.ssanova Predicting from ssanova fits predict1.ssanova Predicting from ssanova fits summary.ssanova Summarizing ssanova fits project.ssanova Projecting ssanova fits for model diagnostic ssanova9 Fitting smoothing spline ANOVA models with correlated data summary.ssanova9 Summarizing ssanova9 fits project.ssanova9 Projecting ssanova9 fits for model diagnostic ssanova0 Fitting smoothing spline ANOVA models predict.ssanova0 Predicting from ssanova0 fits summary.ssanova0 Summarizing ssanova0 fits residuals.ssanova Extracting the residuals from ssanova objects fitted.ssanova Extracting the fitted values from ssanova objects print.ssanova Print function for ssanova objects print.ssanova0 Print function for ssanova0 objects print.summary.ssanova Print function for summary.ssanova objects gssanova Fitting smoothing spline ANOVA models with non Gaussian data gssanova1 Fitting smoothing spline ANOVA models with non Gaussian data predict9.gssanova Predicting from gssanova fits summary.gssanova Summarizing gssanova fits project.gssanova Projecting gssanova1 fits for model diagnostic gssanova0 Fitting smoothing spline ANOVA models with non Gaussian data summary.gssanova0 Summarizing gssanova0 fits residuals.gssanova Extracting the residuals from gssanova objects fitted.gssanova Extracting the fitted values from gssanova objects print.gssanova Print function for gssanova objects print.summary.gssanova Print function for summary.gssanova objects print.summary.gssanova0 Print function for summary.gssanova0 objects ssden Estimating probability density using smoothing splines d.ssden Evaluating pdf of ssden estimates project.ssden Projecting ssden fits for model diagnostic ssden1 Estimating probability density using smoothing splines d.ssden1 Evaluating pdf of ssden1 estimates project.ssden1 Projecting ssden1 fits for model diagnostic dssden Evaluating pdf of ssden estimates pssden Evaluating cdf of 1-D ssden estimates qssden Evaluating quantiles of 1-D ssden estimates cdssden Evaluating conditional pdf of ssden estimates cpssden Evaluating 1-D conditional cdf of ssden estimates cqssden Evaluating 1-D conditional quantiles of ssden estimates print.ssden Print function for ssden objects sscomp Estimating composition with one sample sscomp2 Estimating composition with multiple samples sscden Estimating conditional density using smoothing splines d.sscden Evaluating pdf of sscden estimates project.sscden Projecting sscden fits for model diagnostic sscden1 Estimating conditional density using smoothing splines d.sscden1 Evaluating pdf of sscden1 estimates project.sscden1 Projecting sscden1 fits for model diagnostic dsscden Evaluating pdf of sscden estimates psscden Evaluating cdf of sscden estimates with 1-D Y qsscden Evaluating quantiles of ssden estimates with 1-D Y cdsscden Evaluating conditional pdf of sscden estimates cpsscden Evaluating 1-D conditional cdf of sscden estimates cqsscden Evaluating 1-D conditional quantiles of sscden estimates print.sscden Print function for sscden objects ssllrm Fitting smoothing spline log-linear regression models predict.ssllrm Evaluating log-linear regression model fits project.ssllrm Projecting ssllrm fits for model diagnostic print.ssllrm Print function for ssllrm objects sshzd Estimating hazard function using smoothing splines project.sshzd Projecting sshzd fits for model diagnostic sshzd1 Estimating hazard function using smoothing splines project.sshzd1 Projecting sshzd1 fits for model diagnostic hzdrate.sshzd Evaluating hazard estimates hzdcurve.sshzd Evaluating hazard curves survexp.sshzd Computing expected survivals print.sshzd Print function for sshzd objects sscox Estimating relative risk using smoothing splines predict.sscox Projecting sscox fits for model diagnostic project.sscox Predicting from sscox fits print.sscox Print function for sscox objects ## SSCOPU, SSCOPU2, SSHZD2D, AND SSHZD2D1 SUITES sscopu Fitting copula density using smoothing splines sscopu2 Fitting 2-D copula density using smoothing splines dsscopu Evaluating pdf of sscopu estimates cdsscopu Evaluating 1-D conditional pdf of sscopu estimates cpsscopu Evaluating 1-D conditional cdf of sscopu estimates cqsscopu Evaluating 1-D conditional quantiles of sscopu estimates summary.sscopu Calculating Kendall's tau and Spearman's rho of sscopu estimates print.sscopu Print function for sscopu objects sshzd2d Estimating 2-D hazard function using smoothing splines sshzd2d1 Estimating 2-D hazard function using smoothing splines hzdrate.sshzd2d Evaluating 2-D hazard estimates survexp.sshzd2d Evaluating 2-D survival estimates print.sshzd2d Print function for sshzd2d objects ## UTILITIES FOR MAKING MODEL TERMS mkterm Making model terms mkterm.copu Making model terms for sscopu/sscopu2 mkphi.cubic Making phi function for cubic splines mkrk.cubic Making RK function for cubic splines mkrk.cubic.per Making RK function for periodic cubic splines mkrk.linear Making RK function for linear splines mkrk.linear.per Making RK function for periodic linear splines mkphi.tp Making phi functions for thin-plate splines mkphi.tp.p Making pseudo phi functions for thin-plate splines mkrk.tp Making RK functions for thin-plate splines mkrk.tp.p Making pseudo RK functions for thin-plate splines mkrk.sphere Making RK functions for spherical splines mkrk.nominal Making RK function for nominal factors mkrk.ordinal Making RK function for ordinal factors mkran Generating random effects in mixed-effect models mkran1 Combining random effects in mixed-effect models mkcov.arma Making covariance function for ARMA models mkcov.long Making covariance function for longitudinal data mkcov.known Passing known covariance function to ssanova9 mkint Generating integrals of basis terms for ssden1 suite mkint2 Generating integrals of basis terms for ssden1 suite ## UTILITIES FOR DISTRIBUTION FAMILIES mkdata.binomial Making pseudo data for logistic regression dev.resid.binomial Deviance residuals for logistic regression dev.null.binomial Null model deviance for logistic regression cv.binomial CV score for logistic regression y0.binomial Preparing for KL projection of logistic fit proj0.binomial Making pseudo data for projection of logistic fit kl.binomial Computing KL distance between logistic fits cfit.binomial Computing constant logistic fit mkdata.poisson Making pseudo data for Poisson regression dev.resid.poisson Deviance residuals for Poisson regression dev.null.poisson Null model deviance for Poisson regression cv.poisson CV score for Poisson regression y0.poisson Preparing for KL projection of Poisson fit proj0.poisson Making pseudo data for projection of Poisson fit kl.poisson Computing KL distance between Poisson fits cfit.poisson Computing constant Poisson fit mkdata.Gamma Making pseudo data for Gamma regression dev.resid.Gamma Deviance residuals for Gamma regression dev.null.Gamma Null model deviance for Gamma regression cv.Gamma CV score for Gamma regression y0.Gamma Preparing for KL projection of Gamma fit proj0.Gamma Making pseudo data for projection of Gamma fit kl.Gamma Computing KL distance between Gamma fits cfit.Gamma Computing constant Gamma fit mkdata.inverse.gaussian Making pseudo data for IG regression dev.resid.inverse.gaussian Deviance residuals for IG regression dev.null.inverse.gaussian Null model deviance for IG regression cv.inverse.gaussian CV score for IG regression y0.inverse.gaussian Preparing for KL projection of IG fit proj0.inverse.gaussian Making pseudo data for projection of IG fit kl.inverse.gaussian Computing KL distance between IG fits cfit.inverse.gaussian Computing constant IG fit mkdata.nbinomial Making pseudo data for negative binomial regression dev.resid.nbinomial Deviance residuals for negative binomial regression dev.null.nbinomial Null model deviance for negative binomial regression cv.nbinomial CV score for negative binomial regression y0.nbinomial Preparing for KL projection of negative binomial fit proj0.nbinomial Making pseudo data for projection of negative binomial fit kl.nbinomial Computing KL distance between negative binomial fits cfit.nbinomial Computing constant negative binomial fit mkdata.polr Making pseudo data for proportional odds regression dev.resid.polr Deviance residuals for proportional odds regression dev.null.polr Null model deviance for proportional odds regression cv.polr CV score for proportional odds regression y0.polr Preparing for KL projection of proportional odds fit proj0.polr Making pseudo data for projection of proportional odds fit kl.polr Computing KL distance between proportional odds fits cfit.polr Computing constant proportional odds fit mkdata.weibull Making pseudo data for Weibull regression dev.resid.weibull Deviance residuals for Weibull regression dev.null.weibull Null model deviance for Weibull regression cv.weibull CV score for Weibull regression y0.weibull Preparing for KL projection of Weibull fit proj0.weibull Making pseudo data for projection of Weibull fit kl.weibull Computing KL distance between Weibull fits cfit.weibull Computing constant Weibull fit mkdata.lognorm Making pseudo data for log normal regression dev.resid.lognorm Deviance residuals for log normal regression dev0.resid.lognorm Pseudo deviance residuals for log normal regression dev.null.lognorm Null model deviance for log normal regression cv.lognorm CV score for log normal regression y0.lognorm Preparing for KL projection of log normal fit proj0.lognorm Making pseudo data for projection of log normal fit kl.lognorm Computing KL distance between log normal fits cfit.lognorm Computing constant log normal fit mkdata.loglogis Making pseudo data for log logistic regression dev.resid.loglogis Deviance residuals for log logistic regression dev0.resid.loglogis Pseudo deviance residuals for log logistic regression dev.null.loglogis Null model deviance for log logistic regression cv.loglogis CV score for log logistic regression y0.loglogis Preparing for KL projection of log logistic fit proj0.loglogis Making pseudo data for projection of log logistic fit kl.loglogis Computing KL distance between log logistic fits cfit.loglogis Computing constant log logistic fit ## UTILITIES FOR NUMERICAL INTEGRATION gauss.quad Generating Gauss-Legendre quadrature smolyak.quad Generating Smolyak cubature smolyak.size Getting the size of Smolyak cubature ## UTILITY FOR OPTIMIZATION nlm0 Minimizing univariate functions on finite intervals ## NUMERICAL ENGINE sspreg0 An interface to RKPACK driver DSIDR mspreg0 An interface to RKPACK driver DMUDR sspregpoi Performance-oriented iteration using RKPACK driver DSIDR mspregpoi Performance-oriented iteration using RKPACK driver DMUDR getcrdr An interface to RKPACK utility DCRDR getsms An interface to RKPACK utility DSMS sspreg1 Compute regression estimate with single smoothing parameter mspreg1 Compute regression estimate with multiple smoothing parameters sspreg91 Compute regression estimate with single smoothing parameter mspreg91 Compute regression estimate with multiple smoothing parameters sspngreg Compute NG regression estimate with single smoothing parameter mspngreg Compute NG regression estimate with single smoothing parameter ngreg Newton iteration for NG regression with fixed smoothing parameter ngreg1 Performance-oriented iteration using sspreg1 and mspreg1 regaux Obtain auxiliary information needed for se calculation ngreg.proj Calculate Kullback-Leibler projection for NG regression sspdsty Compute density estimate with single smoothing parameter mspdsty Compute density estimate with multiple smoothing parameters sspdsty1 Compute density estimate with single smoothing parameter mspdsty1 Compute density estimate with multiple smoothing parameters mspcdsty Compute conditional density estimate mspcdsty1 Compute conditional density estimate msphzd Compute hazard estimate with single or multiple smoothing parameters msphzd1 Compute hazard estimate with single or multiple smoothing parameters sspcox Compute relative risk estimate with single smoothing parameter mspcox Compute relative risk estimate with multiple smoothing parameters mspllrm Compute log-linear regression model with multiple smoothing parameters mspcopu2 Compute 2-D copula density estimate under censoring/truncation gss/inst/0000755000176200001440000000000014404125167012027 5ustar liggesusersgss/inst/CITATION0000644000176200001440000000112314404125167013161 0ustar liggesuserscitHeader("To cite gss in publications use:") bibentry(bibtype = "Article", title = "Smoothing Spline {ANOVA} Models: {R} Package {gss}", author = c("Chong Gu"), journal = "Journal of Statistical Software", year = "2014", volume = "58", number = "5", pages = "1--25", url = "https://www.jstatsoft.org/v58/i05/", textVersion = paste("Chong Gu (2014).", "Smoothing Spline ANOVA Models: R Package gss.", "Journal of Statistical Software, 58(5), 1-25.", "URL http://www.jstatsoft.org/v58/i05/.") )