geepack/0000755000176200001440000000000014166452400011653 5ustar liggesusersgeepack/NAMESPACE0000644000176200001440000000260714165262714013105 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(QIC,geeglm) S3method(QIC,geekin) S3method(QIC,ordgee) S3method(anova,geeglm) S3method(plot,geeglm) S3method(print,geeglm) S3method(print,geese) S3method(print,summary.geeglm) S3method(print,summary.geese) S3method(residuals,geeglm) S3method(summary,geeglm) S3method(summary,geese) S3method(vcov,geeglm) export("%>%") export(QIC) export(compCoef) export(fixed2Zcor) export(geeglm) export(geese) export(geese.control) export(geese.fit) export(genZcor) export(ordgee) export(relRisk) export(tidy) import(methods) importFrom(MASS,ginv) importFrom(broom,tidy) importFrom(graphics,abline) importFrom(graphics,lines) importFrom(graphics,plot) importFrom(magrittr,"%>%") importFrom(stats,binomial) importFrom(stats,coef) importFrom(stats,family) importFrom(stats,fitted) importFrom(stats,formula) importFrom(stats,gaussian) importFrom(stats,glm.fit) importFrom(stats,is.empty.model) importFrom(stats,lm.fit) importFrom(stats,lowess) importFrom(stats,model.extract) importFrom(stats,model.matrix) importFrom(stats,model.offset) importFrom(stats,model.response) importFrom(stats,model.weights) importFrom(stats,na.omit) importFrom(stats,naresid) importFrom(stats,pchisq) importFrom(stats,printCoefmat) importFrom(stats,quasi) importFrom(stats,residuals) importFrom(stats,summary.glm) importFrom(stats,var) importFrom(utils,head) importFrom(utils,str) useDynLib(geepack) geepack/ChangeLog0000644000176200001440000001663614165262714013447 0ustar liggesusers2019-12-18 Søren Højsgaard * Improved doc of dietox. 2019-12-10 Søren Højsgaard * PROTECT / UNPROTECT imbalance fixed * Version 1.3-1 uploaded 2019-12-10 Søren Højsgaard * Migrated to use roxygen * Improved documentation of geeglm * Check for data being sorted by 'id' i geeglm; a warning is issued if not. * QIC added; thanks to Claus Ekstrøm who is now a contributor. * tidy function from broom package is imported. * muscatine data added * Version 1.3-0 uploaded 2014-09-13 Søren Højsgaard * geeglm objects now inherits from lm also (to prevent warning when calling predict). * Version 1.2-1 uploaded 2014-09-13 Søren Højsgaard * Maintainer of geepack is now Søren Højsgaard * Location of vignette fixed * Version 1.2-0 uploaded 2012-01-27 Jun Yan * Commented out #undef NDEBUG in geesubs.cc. * Added a VecPrint function in utils.cc to print DVector; this replaces usage of cerr. 2012-01-09 Jun Yan * Thank Jeffrey Horner and Cole Beck for fixing the undefined symbol error (see 2011-11-14 entry: _Z5ValidIiEN3TNT6VectorIT_EERS3_RNS1_IiEE). The template function "Valid" (in original geesubs.cc) should actually be in the header file. This may fix the compilation error on ubuntu 11.10 too. 2011-11-21 Jun Yan * Added an example to function relRisk. 2011-11-21 Jun Yan * Added an example to function compCoef. * Changed the JSS paper year from 2005 to 2006 in CITATION. 2011-11-16 Jun Yan * Added function relRisk for relative risk regression --- regression for binary response with log link. * Added function relRisk for relative risk regression --- regression for binary response with log link. * Added function compCoef for comparing coefficients of the same sets of covariates between nested models. This implements the method of Yan, Aseltine, and Harel (2011, JEBS); for independent data, the method reduces to Allison (1995, American Journal of Sociology). * Fixed a bug in c++ code in constructing the working covariance structure using the regression model of scale. Simulation tests show improved efficiency in mean parameter estimation when scale regression is present. 2011-11-15 Soren Hojsgaard * Dependence on the doBy package has been removed. 2011-11-14 Jun Yan * Added NAMESPACE for to comply with the requirement of R-2.14.0. * Removed the "assert" lines in utils.cc in order not to crash R, which is quite rude practice. A "-DNDEBUG" has been added to the cppflags in Makevars for a better solution. Due to many asserts in tnt, we cannot get rid of the NOTE message completely: Found ‘_ZSt4cerr’, possibly from ‘std::cerr’ (C++) Found ‘__assert_fail’, possibly from ‘assert’ (C) * Added quote in statements like extract(m, "response") to get rid of NOTE: geese: no visible binding for global variable ‘response’ * Added a line of #undef NDEBUG to the beginning of geesubs.cc; thank Brian Ripley for the NMU. Still unclear why the error without this line: undefined symbol: _Z5ValidIiEN3TNT6VectorIT_EERS3_RNS1_IiEE 2011-02-23 Søren Højsgaard * In geeglm is checked if the model matrix is rank deficient; if so then geeglm exits. Thanks to Jason D Thorpe for pointing this out. * Bug in anova fixed. Thanks to Stefan Boehringer for pointing this out. * Version 1.0-18 uploaded. 2010-01-26 Søren Højsgaard * fixed2Zcor function has been added. This function makes it easier to work with a fixed correlation matrix (in particular when cluster sizes are not equal). * A vignette on models with unequal cluster size, fixed correlation matrices etc. has been added. * Version 1.0-17 uploaded 2008-12-08 Søren Højsgaard * Bugfix in 1.0.15 caused problem in binomial case using cbind(pos,neg). Thanks to Tobias Verbeke. Fixed now. * Bugfix in 1.0.15 caused problem when using variables derived from gam package call to geeglm. Thanks to Eric Rexstad. Fixed now. * Using scale.fix argument gave problem in geeglm. Thanks to Tobias Verbeke. Fixed now. * Fitting large data set with binomial model and 3 measurements per unit using unstructured correlation crashes R. Thanks to Tobias Verbeke. Problem has *NOT* been solved but a remark has been added to doc file. * Version 1.0-16 uploaded 2008-12-01 Søren Højsgaard * When a factor has unused levels, the underlying C code fails. This is now catured in geeglm. Thanks to Janet Young * tests directory added to package * Version 1.0-15 uploaded 2007-07-13 Søren Højsgaard * Smaller 'standardization' changes implemented. Thanks to Achim * Version 1.0-14 uploaded 2007-03-21 Søren Højsgaard * A remark on fixed correlation structures has been added to the geeglm.Rd doc file. * A Wishlist file has been added * Version 1.0-13 uploaded 2007-03-21 Søren Højsgaard * Bug in geeglm fixed so that it now works with a fixed correlation structure. Thanks to Ulrich Halekoh for the fix. 2006-02-13 Jun Yan * Bug in genZcor and genZodds fixed. Thanks to Chongzhi Di . Previously, the matrice generated by genZcor/genZodds are wrong when the number of unique waves is greater than or equal to 10. 2006-01-24 Søren Højsgaard * Bug in anova.geeglm fixed (showed up when there was only one term on the right hand side of ~). * geeglm only works on complete data. This has been pointed out in the man pages. (At some point of time, a proper na.action should be taken). * All datasets are saved as .txt files (previously some were saved as .rda files but that caused problems in building the package on windows xp). 2005-08-13 Jun Yan * The working correlation structure can now be "fixed". 2005-06-13 Søren Højsgaard * Søren Højsgaard has modified the geeglm function so that it can take the 'waves' argument which is used for explicitely specifying the ordering of repeated measurements on the same unit. geeglm can also take the 'zcor' argument for a user defined working correlation structure. * A documentation file for the genZcor function has been added. * All data sets provided are now saved as text files. * ordgee has been modified to check if the response variable is an ordered factor. * geeglm can now take the argument std.err which specifies the type of variance estimate to be calculated. 2005-05-11 Søren Højsgaard * Søren Højsgaard has modified the anova function to make it calculate the correct degrees of freedom. 2005-04-11 Jun Yan * Søren Højsgaard made some minor changes to geeglm - basically, that geese.control did not work. Now it does. 2005-02-09 Jun Yan * Søren Højsgaard joined the development with geeglm, which "works like" glm and returns an object which is similar to a glm object. Residuals and predicted values can be extracted using the generic functions as with a glm object. * An important feature of geeglm, is that an anova method exists for these models. geepack/README.md0000644000176200001440000000005314165262714013136 0ustar liggesusers# geepack Generalized Estimating Equations geepack/data/0000755000176200001440000000000014165262714012572 5ustar liggesusersgeepack/data/dietox.rda0000755000176200001440000001107414165262714014564 0ustar liggesusers7zXZi"6!X])TW"nRʟ)'dz$&}TyiYˆi; fˢer}oSblF/נ.)ho8i`~-TMwJGX\%h*?<6pDOѯ/wrN X󠌣*Mĭ_lb?djJ}/ -84PSn:kgg1j>D.8'7a&+#\yjhqyLahO.-|!vc}b6s5ǭwj6,pec:TTkhae\R` .jNS VYDEa8_ Y'!˹Һ.D om \H>]nh>PDaxss9b)-Q8h&0}2R?´YN~`BSR%L `@a,yc2˳HXVdfc(&E*=P917aZ=k/(jaH ;=pE}+cڒ͡C dF*?.fHV"# >c Y0D7zJNJU|_]k}i*y43(ūd}\ԧb۞TZ췹2@HVg *a&lwBRa;;8VG-65㰾D`߀.4ื_Ob)s]U[ڷJ ;z~dH[8\W=?L8Nwp#[E 2hk@Z"xSrW? XT46Ǹ[=DRMc lUy1B!J]0E.@ eDN0x> s9[!םI-pD.UO/࠽,/@ĦߞdR=xwF”XO\Dwg;%OD `fiƵ~1:j峍%^Q-NDXle]02 *'g-{ UMVeɯ6r':Ei{H dX?MךiK1a);0qWc_%[}\N'Mb@YX'0t T>3mĀ֛"gB`ICf,dׅ ؤ ݓ{ BV"m.CAƼķ7[5)!A^abq0U-6t7p7,C E5Na pd?4˳~k рj8xAB_\+Z"EUj &1mNۉOlΡ-@{kZؒ.6[/_"k0 Ea(q6`֛U"b۳ӭ^)WVͧ7)ItZ =in}N\s. 'Jx `2Iʼ RfD L+ϫBgr foF>1dm7e%pxgt &؞}],s+$>I9 5US. 0J8ʼPN3 HRό0; %"u:qoajhjHn$ytkɯ̲}봆d,g_eN(A9P,%Exl(IG几j$'CэϏ]yM8#cP 9iMk_FhMxى25" |) K,;$!(' xviz<ϴ~*D&tY۬Y _SR==p~1< ׆qb?_ nhK, >!I,M)3,GlltΕEc=\1*gn[ذ*/!\[H!k Qrp\zʝ SeD|..='9|r#U2hj`+Ù<(;rbQdF/,_h 'f",Xb]:Z2MyWƂGF3 Pt*XTQT8bU їM8-F{r8*D$e)&3D$gˋRL T903z )tm?u?"Df+hbj̪ϵsM~8Z_l.ˑ|YI{@!Lgjgw<3$y@S# &FFry>G ]⿐<d;6lx}8zI&ƀ!CrpT_w}zK`tB>ЉlYx>7"N=+ i6uCKwL˲UobBnME8HTQ$hEC~w?ItMA%Ѐan F̙Mp$.vdM!Q/Z_?eir0ȇwj6iM52}޺_`S 6iK9 i!sbHd?(`kGuRs> ;,'03172Jc|E/,K0u*" La'`vD]*̺)Pm?WԘͼZ@+p: EC3b(^23+0 YZgeepack/data/muscatine.rda0000644000176200001440000002606014165262714015256 0ustar liggesusersUe6D00N000EL DZ TDNn ї<~W%溏t]~ֳfץ^IIIJK,%5;wjߢuIIjeJKj-;?lHnCUMʊe'UꨁڨP sAc4c4łX c, ͱ8X Kc,6@l6A{lͰ9 5=:3v肝3v +@7tGD/F쉾 {cb` P p?8018 cq8p48p2N8 p68Dž\p9 W\p=n 7܊p; w܋p?xLx <4x2^x 6x|1>D|90_|=~3~ S1[RTCu@MBmA]\h1`^̇bA,bhXK`I, rX+`Eh VjhձZhzX 6D[l=6f[`Kl`[l;`GtN`W{zzD_셽11`0`(a8F`_~@Qq8pQ8XqNI8TqY8\qB\q .eWJ\q u7F܄q nmwN܅q}A<&Q<SxY<^KxU[x]>G`">g_KLW w?GLOWVoW+E5TG D-FE=̅h0 | )BX`Q,fhűRX`Y,VJhX`UVXk`MX`]`CF cSlͱV耭 v vD석 vn];z'z7`O^0cbcHqA8Pa1GHq q8'Dq Ni8gLqy8`<.ER\qUZ\qnMV܆q]^܇Cx`cxOI< sx/E ^kxoM{xC| &S|$|[|~ ~oiʶJQ Q5Q QuQs>!F#̃hy1h"Xcq,%2XayZ%V*XVXk5:Xa}l6m6F;lasl-:`klm:b{tBg;ag]vGWn^>}F? }1aqFa4!8cpp8Ghcq 8'dSqN8glsq q.%r\+q5z܀qn-v܁;q=~<#GxOiG`">g_KLW w?GLOWVl^P5PPuP0bn4!a#8aF`C1a,8#q18xqN)8t3q98|\b\Kq.Wj\kq 7f܂[qnwn܃{qxa< xq<'3xy^+xu7;x}|>'O>&k|oS~/a*U(ۮW(E5TG D-FE=̅h0 | )BX`Q,fhűRX`Y,VJhX`UVXk`MX`]`CF cSlͱV耭 v vD석 vn];z'z7`O^0cbcHqA8Pa1GHq q8'Dq Ni8gLqy8`<.ER\qUZ\qnMV܆q]^܇Cx`cxOI< sx/E ^kxoM{xC| &S|$|[|~ ~oiʶJQ Q5Q QuQs>!F#̃hy1h"Xcq,%2XayZ%V*XVXk5:Xa}l6m6F;lasl-:`klm:b{tBg;ag]vGWn^>}F? }1aqFa4!8cpp8Ghcq 8'dSqN8glsq q.%r\+q5z܀qn-v܁;q=~<#GxOiG`">g_KLW w?GLOWVl+^P5PPuP0bn4!a#8aF`C1a,8#q18xqN)8t3q98|\b\Kq.Wj\kq 7f܂[qnwn܃{qxa< xq<'3xy^+xu7;x}|>'O>&k|oS~/a*U(~W(E5TG D-FE=̅h0 | )BX`Q,fhűRX`Y,VJhX`UVXk`MX`]`CF cSlͱV耭 v vD석 vn];z'z7`O^0cbcHqA8Pa1GHq q8'Dq Ni8gLqy8`<.ER\qUZ\qnMV܆q]^܇Cx`cxOI< sx/E ^kxoM{xC| &S|$|[|~ ~oiʶJQ Q5Q QuQs>!F#̃hy1h"Xcq,%2XayZ%V*XVXk5:Xa}l6m6F;lasl-:`klm:b{tBg;ag]vGWn^>}F? }1aqFa4!8cpp8Ghcq 8'dSqN8glsq q.%r\+q5z܀qn-v܁;q=~<#GxOiG`">g_KLW w?GLOWVlk]P5PPuP0bn4!a#8aF`C1a,8#q18xqN)8t3q98|\b\Kq.Wj\kq 7f܂[qnwn܃{qxa< xq<'3xy^+xu7;x}|>'O>&k|oS~/a*U(NW(E5TG D-FE=̅h0 | )BX`Q,fhűRX`Y,VJhX`UVXk`MX`]`CF cSlͱV耭 v vD석 vn];z'z7`O^0cbcHqA8Pa1GHq q8'Dq Ni8gLqy8`<.ER\qUZ\qnMV܆q]^܇Cx`cxOI< sx/E ^kxoM{xC| &S|$|[|~ ~oiʶJQ Q5Q QuQs>!F#̃hy1h"Xcq,%2XayZ%V*XVXk5:Xa}l6m6F;lasl-:`klm:b{tBg;ag]vGWn^>}F? }1aqFa4!8cpp8Ghcq 8'dSqN8glsq q.%r\+q5z܀qn-v܁;q=~<#GxOiG`">g_KLW w?GLOWVl\P5PPuP0bn4!a#8aF`C1a,8#q18xqN)8t3q98|\b\Kq.Wj\kq 7f܂[qnwn܃{qxa< xq<'3xy^+xu7;x}|>'O>&k|oS~/a*U(W(E5TG D-FE=̅h0 | )BX`Q,fhűRX`Y,VJhX`UVXk`MX`]`CF cSlͱV耭 v vD석 vn];z'z7`O^0cbcHqA8Pa1GHq q8'Dq Ni8gLqy8`<.ER\qUZ\qnMV܆q]^܇Cx`cxOI< sx/E ^kxoM{xC| &S|$|[|~Ĕ e_l?^RZRao w^}z jt6S+QܪEDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD̀GO߻Ғ%uˎޫߐO[ڡ<ѯېO_wC.KSZOT1o_5f{?3u)U֮BiM(Ե^gyFΓsb۷QUާŠ׽bT﯋Uר?zPOe_Cz_0_|DĜwDDD!"""KQ?ߎ7 s$}QF1sν߬?Kſ,nv_ }oWūkaČ*u2"fB;FDR{zOi>3r*oΟʸ/Q"^"}HY54ku1+{+9_̯]e\ .sα9ɬ~_kOnYuϬqV?WŰuuV/}[ތٯê֟b3'W3ru(kV*3=5'c܈[ňʤߗ 󫈈(.RDTnG~R }7z폈YkF!3g43TEY=O{*'(}IDT'(vUy;#חYZßPU΁BUYf6ϟB?Ũsʧ 1U{^^Q׏ʤPU_ ~WkĜ圌q^QŨ{ÿAII%UYˏH.?6LبcJg{?3uU^ʲ&Z\ {U3Iyn<#ɌZ~NۋQާŐWl2_PQe ޟyʾI߻S|$''Bc!#-%''''<'>sbJɳ?5499yKaw֥}`1\f5r.crqbXg$õ2998'ZeYϊ{fU2a )}vK mrrrrb'}Gr䙵/\ U2bX3s_<ɹnΩײon)s,9bX uML}V}?khb rkWbxQl؜g^uܞzgsU ^Wgkw~bޛɹFW\ O9is^bf8#{bT5pN]3=Rs~&\s1ɕ%g=rrrrrrFU6gLɕ+>sps1IKNNWOזf~)U-ϊfU>M\}f.kPr?3oINN: 9W\_fkQ BW:a6{ηY}s\lbwHu#sR=œa ,\ kHeŰU509נ|S׷sڕ\k~eŰ.\ ÿXv,-SL91NO6?ӏ% ǩ]sDT-ŗG133.p.MGDDDDDDDDDDDDD?&999999999`yyMN'qrrrrrrrrrrrrrrJ*}91~Lrq,ɥ;~LNNNNNNyjU8}\\LJg^]$''\ki˾sJ̹'999@{EIytsѼE#""""""""""""b0INNNNNNNN yZrQ<Ś'''''''''''':O\KNtNϿ:?N.\\199999yv鏫%'Y.{#9999994(ZԨVfZYh{_R#{ ',ջ[ef~s1sq=O{?j=>}鋵/bY7O>jM?sbK_Rz>ӧO>}ԗL?__ӧO?OBӧO~FL&d2L&d2L&d2L&d2L&d2L&d2L&d26qO>}ӧO>}ӧO>}US8ӧO?;>O>}ӧO>}ӧO>}ӧO>}UˏO_I_9ZҧO?%O2>}ӧO>}ӧO>}_}ӧO>}ӧO~fbӧO>KJҧO>}ӧO>}ӧO˿c9c9VcO_}5}ӧ}Oz/Xޗ̜^ӧO>}9/>oOώO>}g2L&d2L&d2L&d2L&d2L&d2L&d2L&)8}ӧO>}ӧO>}B߳ӧOu=M>}ӧO>}ӧO>}ӧ}?ӧ/|WGӧ}ӧO}O>}ӧO>}ӧO>}UO>}ӧO>ޗJ>}bKJҧO>}ӧO>}/)Q/%5JkֿאϚ^Vszէ׀OT{!vk= ;p@;{!uѲ7/7UGAAAAJAAAAjAZA;L 3w-Skݍk/̟׍ӳG' 㓣sIcGǷNOo6$,A] g`#hf`+n2@; t3@? 308 L30~2Pޓf}x>fCp.g |$2 \'2 |*d |:g3 |>_3 |9J@fkx<OdFSfog;ng3_ԸS5^K~KV:2.4BSh M)4BSh ͻ߿'Poh;BSh M)4BSh MyW.No^mVݿ|V_.~Ul?zEjL ϧ_{N'􏋿?U7~.]^|xjqyqwz ʪ꒑bۯU&3`1CpjxuWXᏪ.w'_^ިF/{dXqc%GU,|X Xvc0bojO}5D>c_|{vz?3条/Cb1CNg S C?C.mC1H0~&;:Ї|})yic}#nf>rRs~ZI.t]ƶ="Gs }z!}1<<"Џ5G}u駝odް_1n^i rq߸:lA=amچҎ/쩇=lrAn dQ\G~R3q+ZFm"?v10՟̧p/zC)1g{I-z~vnZ{D}fg|5_p#?I#q~G/̻[1՛lݗڱJb_FOisځx~a_^ں__J ?FZyyEҶCʅG#ľЋz)zC?SߑWsqmQH"/5OG^c5N.ZG]'g;ڣqL?6?U%ʑQ7?͟;kՓ~WV_ڛ|M? |8]coḬ)¯غ:{s-j$c]cޫU_کuz|vvvq㨫߶7/ȣ~۲0NoV`=`JqvezwֱcہЫ릿˶ C?Nyڹz6_ܯc!#ǒssZXg#x]Z/h~Y;/?7'ɇr2;Ϻ0}`]]#Ǻ1QvsO7g~WE}wͣ+^|4CNQ7xb~aCڅ?vuwod=[=ڹ<3?ڦsGeko2zn}=ڣ]m^><[y\Ens=ooiso{nl}lkwo]7X%npt3>1b嚿mvu﮽tONx~LwoG\=Mx<;},Ȱݻgޏ"/fqgeepack/data/respdis.RData0000755000176200001440000000074014165262714015164 0ustar liggesusersJ0Uā {+o6_^|S: Y~ӓ35: !*Qוw"ŎOz.D}6}VVi 5mƟafy ]6Z_|>Z=5[EϺgԴ]þCCǯ귯.mz}c?7{m7yv&_:ˋcCR$M2T/fo&||qt1YLf ߟMS.ߐy2O@f_f^\>C̳n$Vװ5dII0P Ca( 0Cch 14` a0 0`X a1,ŰbX 0pa8 0cx 1<#`0F#`D1"FĈ#bDKlJT%MDW/1Xhi ҞqӅgeepack/data/ohio.RData0000755000176200001440000000244314165262714014453 0ustar liggesusersyUs;we}C!k!-BLL$%Q֔KD(P!ZB%[RhDdyϹwι>Ϲ9Zwl1#H$D2p6-YxHK=sԚE2ىH$D"H$D^nq{YXjZ}.}d2-{4{qH$D">vwNJ纕{L(^clKi%6K/~\ע2\.Tʣ*"DTE5TG D-FE=l 6& 6[ak46hm)ͰvFs]Z`w쁖>58`Cqh#p1hcqG't A7tG胾E?|R| wX?`VG kO)H"i(򨀊HG*22QUQ Q5Q QuQ`Clh 6EClͱV c[l&hvD3석`W{%D+셽~hqA8PqHE;q ڣ:X qDd$tE6r =q2z7/r Sqt 8Cplasqa.H%r\+1cp5z܀qnX܂[1vwa&nLdL=~L4<cfa/>:geepack/data/respiratory.RData0000755000176200001440000000161414165262714016077 0ustar liggesusersYo@Fv$le_۲o% ;BBoHE٦?ങƞNEh,ēsΌj7p]G8n;bRv/?pj1s=3Rb)\0 45P 0 9p')p̃3,8΃ ".+* pp<1hOS </K`ן]v\y]MOuy/gOWt>?+UϲiGowRtؿsN;a?z49Q/v .E}i[un(_xW}g\?L:} oJ s$љR >SY|J(mPa|tCR GnZCe>utx(0?-xI_oq~0_J:R_JSl=ǃ=G)R6@'zS:dtR3QJN*tE;W׻|wm[VYƫ;?yoEϺ=~t}?xM}~(ӭ/x'f)_۲-۲-۲-a7_[1:ݷMgS$W:M5YdNʌQn>|%F1iҖ}إ_Z9K{~7f|=l$&&p4ޖׁ5:oG~0,9 i n[~-S;#}ڽ-?-dcËz,#Zp~@Ap9geepack/data/koch.RData0000755000176200001440000000207014165262714014435 0ustar liggesusersoURhYʾ}+mc/ey橯QTJ#Uof $lwfg3'MۿuݤN'dN?vno[?uj̥妫ofc/}huúvy].oeއ&#ٰn<nڮm4z*tt_3뇖:Csvx hgع=z;c{>t;=qC7_#C:ަeMJ.H\<(ٓK<,$,yD1+'$OJ<-yF9$/J^,*yE57$oJޒ-yG=5뒙$. IJJK撅CG%H>|&\KW%H|w6gwt~=]9=9>Y8t/~=zH}xyW<=`ֆֆކZZZZzzzzFFFFffffVVVV۷nߺ}[w޺֝uhŽjl;ƭ?C o;~~'~_====sџ@}| _k5| _k5| _k5| _k5| _k5:|_u:|_u:|_u:|_u:|_u|߀o7 |߀o7 |߀o7 |߀o7 |߀o7 &| ߄o7M&| ߄o7M&| ߄o7M&| ߄o7M&| ߄o7M| ߂o[-| ߂o[-| ߂o[-| ߂o[-| ߂o[-÷o=|{÷_vݟ1I geepack/data/seizure.RData0000755000176200001440000000114214165262714015176 0ustar liggesusersŕnAk81n0q@,!l#'ނ'0U쎹HfrZX$8Q1'Tʺ߿̦"Iö③H.\Շ3e#mE_UɟCbx%.rB*z&ۦȂbV^a[BYcD焘)Mn_oޮ+gIϰɂES E p {]!gG>t2\*ؘew_u׈_|5F|y^pw Y?>g!gu+ȹ%M^x)FARgֺ\u|=s~S ||ޅ_?sݧD ߐ=x?gmg3`}~So%X޵u[D6۟XMī{-5Ά8>$V|-|[{>[9~ ѷ6q\ls 's.2vw%Wҽt,f d>ut3ۏqed1ʹ +?g\Bgeepack/data/sitka89.RData0000755000176200001440000000335114165262714015010 0ustar liggesusers;lUǻvM{wg7 \H ᭤Jfe֒d h"QCISJ:54#af1V8-Yǝ{sFٓϝ5,şh:-խGGEQS+iȮ\;~黐];k!/5.߄SWBSKRyp ĺöonq=_r! ;ҕ/?<2͛O9rכw]*($79>#̴~>s!Y9B/L~_ T0|kW_7182}\'s~͞S/؛Oa }w(}Pzu#2ָxa闈׮7}$Z'sŮK\*SKϜe <'&5kD&ȶOzIJz^ܤ84'|*Nsy-/'m-;c~uů4y+Mb_`ߔ|qjiT1IJ]zX<%~g \+N,ir٫yuoK[ޒ_;#ohNcWg)u COv6{kvğ9k\<.{u/NQ^2)^{INJ/ҫ+>HdjD)C7׌Hh),O臟s.;=[y[ག#=-ۼ8~A^S\ѻރx1~ɷ-#L}wi_bO[0G3? u:L}_ZV+ocx^0gs2/7xCąn/>\TXO~V>A{(IcUj⑽w(oBN~}_߯}hAAvpYsu^;Xprvq;:H2E~8xCvG,981;8 <)O;8g<9;8%^spI;x)-o;xs?Iq5jԨQƿw5ۿgZ<^ی|iO6t:~q\yrfymɃ6hyk}8U~qtai]\sz13hlە>mlsW֛Xk__n;E2geepack/man/0000755000176200001440000000000014165262714012434 5ustar liggesusersgeepack/man/respiratory.Rd0000755000176200001440000000414614165262714015316 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-geepack.R \docType{data} \name{respiratory} \alias{respiratory} \alias{respiratoryWide} \title{Data from a clinical trial comparing two treatments for a respiratory illness} \format{ A data frame with 444 observations on the following 8 variables. \describe{ \item{center}{a numeric vector} \item{id}{a numeric vector} \item{treat}{treatment or placebo} \item{sex}{M or F} \item{age}{in years at baseline} \item{baseline}{resporatory status at baseline} \item{visit}{id of each of four visits} \item{outcome}{respiratory status at each visit} } } \usage{ respiratory } \description{ The data are from a clinical trial of patients with respiratory illness, where 111 patients from two different clinics were randomized to receive either placebo or an active treatment. Patients were examined at baseline and at four visits during treatment. The respiratory status (categorized as 1 = good, 0 = poor) was determined at each visit. } \examples{ data(respiratory) data(respiratory, package="geepack") respiratory$center <- factor(respiratory$center) head(respiratory) m1 <- glm(outcome ~ center + treat + age + baseline, data=respiratory, family=binomial()) gee.ind <- geeglm(outcome ~ center + treat + age + baseline, data=respiratory, id=id, family=binomial(), corstr="independence") gee.exc <- geeglm(outcome ~ center + treat + age + baseline, data=respiratory, id=id, family=binomial(), corstr="exchangeable") gee.uns <- geeglm(outcome ~ center + treat + age + baseline, data=respiratory, id=id, family=binomial(), corstr="unstructured") gee.ar1 <- geeglm(outcome ~ center + treat + age + baseline, data=respiratory, id=id, family=binomial(), corstr="ar1") mlist <- list(gee.ind, gee.exc, gee.uns, gee.ar1) do.call(rbind, lapply(mlist, QIC)) lapply(mlist, tidy) } \keyword{datasets} geepack/man/spruce.Rd0000755000176200001440000000313014165262714014224 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-geepack.R \docType{data} \name{spruce} \alias{spruce} \title{Log-size of 79 Sitka spruce trees} \format{ This data frame contains the following columns: \describe{ \item{chamber}{a numeric vector of chamber numbers} \item{ozone}{a factor with levels \code{enriched} and \code{normal}} \item{id}{a numeric vector of tree id} \item{time}{a numeric vector of the time when the measurements were taken, measured in days since Jan. 1, 1988} \item{wave}{a numeric vector of the measurement number} \item{logsize}{a numeric vector of the log-size} } } \source{ Diggle, P.J., Liang, K.Y., and Zeger, S.L. (1994) Analysis of Longitudinal Data, Clarendon Press. } \usage{ spruce } \description{ The \code{spruce} data frame has 1027 rows and 6 columns. The data consists of measurements on 79 sitka spruce trees over two growing seasons. The trees were grown in four controlled environment chambers, of which the first two, containing 27 trees each, were treated with introduced ozone at 70 ppb whilst the remaining two, containing 12 and 13 trees, were controls. } \examples{ data(spruce) spruce$contr <- ifelse(spruce$ozone=="enriched", 0, 1) sitka88 <- spruce[spruce$wave <= 5,] sitka89 <- spruce[spruce$wave > 5,] fit.88 <- geese(logsize ~ as.factor(wave) + contr + I(time/100*contr) - 1, id=id, data=sitka88, corstr="ar1") summary(fit.88) fit.89 <- geese(logsize ~ as.factor(wave) + contr - 1, id=id, data=sitka89, corstr="ar1") summary(fit.89) } \keyword{datasets} geepack/man/sitka89.Rd0000755000176200001440000000110114165262714014213 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-geepack.R \docType{data} \name{sitka89} \alias{sitka89} \title{Growth of Sitka Spruce Trees} \format{ A dataframe \describe{ \item{size:}{size of the tree measured in \eqn{log(height*diamter^2)}} \item{time:}{days after the 1st january, 1988} \item{tree:}{id number of a tree} \item{treat:}{ozone: grown under ozone environment, control: ozone free} } } \usage{ sitka89 } \description{ Impact of ozone on the growth of sitka spruce trees. } \examples{ data(sitka89) } \keyword{datasets} geepack/man/respdis.Rd0000755000176200001440000000333414165262714014402 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-geepack.R \docType{data} \name{respdis} \alias{respdis} \title{Clustered Ordinal Respiratory Disorder} \format{ This data frame contains the following columns: \describe{ \item{y1, y2, y3, y4}{ordered factor measured at 4 visits for the response with levels, \code{1} < \code{2} < \code{3}, 1 = poor, 2 = good, and 3 = excellent} \item{trt}{a factor for treatment with levels, 1 = active, 0 = placebo.} } } \usage{ respdis } \description{ The \code{respdis} data frame has 111 rows and 3 columns. The study described in Miller et. al. (1993) is a randomized clinical trial of a new treatment of respiratory disorder. The study was conducted in 111 patients who were randomly assigned to one of two treatments (active, placebo). At each of four visits during the follow-up period, the response status of each patients was classified on an ordinal scale. } \examples{ data(respdis) resp.l <- reshape(respdis, varying = list(c("y1", "y2", "y3", "y4")), v.names = "resp", direction = "long") resp.l <- resp.l[order(resp.l$id, resp.l$time),] fit <- ordgee(ordered(resp) ~ trt, id = id, data = resp.l, int.const = FALSE) summary(fit) z <- model.matrix( ~ trt - 1, data = respdis) ind <- rep(1:111, 4*3/2 * 2^2) zmat <- z[ind,,drop=FALSE] fit <- ordgee(ordered(resp) ~ trt, id = id, data = resp.l, int.const = FALSE, z = zmat, corstr = "exchangeable") summary(fit) } \references{ Miller, M.E., David, C.S., and Landis, R.J. (1993) The analysis of longitudinal polytomous data: Generalized estimating equation and connections with weighted least squares, \emph{Biometrics} \bold{49}: 1033-1048. } \keyword{datasets} geepack/man/geese.Rd0000644000176200001440000002174714165262714014026 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/geese.R \name{geese} \alias{geese} \alias{geese.fit} \alias{print.geese} \alias{summary.geese} \alias{print.summary.geese} \title{Function to fit a Generalized Estimating Equation Model} \usage{ geese( formula = formula(data), sformula = ~1, id, waves = NULL, data = parent.frame(), subset = NULL, na.action = na.omit, contrasts = NULL, weights = NULL, zcor = NULL, corp = NULL, control = geese.control(...), b = NULL, alpha = NULL, gm = NULL, family = gaussian(), mean.link = NULL, variance = NULL, cor.link = "identity", sca.link = "identity", link.same = TRUE, scale.fix = FALSE, scale.value = 1, corstr = "independence", ... ) } \arguments{ \item{formula}{a formula expression as for \code{glm}, of the form \code{response ~ predictors}. See the documentation of lm and formula for details. As for glm, this specifies the linear predictor for modeling the mean. A term of the form \code{offset(expression)} is allowed.} \item{sformula}{a formula expression of the form \code{ ~ predictor}, the response being ignored. This specifies the linear predictor for modeling the dispersion. A term of the form \code{offset(expression)} is allowed.} \item{id}{a vector which identifies the clusters. The length of `id' should be the same as the number of observations. Data are assumed to be sorted so that observations on a cluster are contiguous rows for all entities in the formula.} \item{waves}{an integer vector which identifies components in clusters. The length of \code{waves} should be the same as the number of observation. components with the same \code{waves} value will have the same link functions.} \item{data}{an optional data frame in which to interpret the variables occurring in the \code{formula}, along with the \code{id} and \code{n} variables.} \item{subset}{expression saying which subset of the rows of the data should be used in the fit. This can be a logical vector (which is replicated to have length equal to the number of observations), or a numeric vector indicating which observation numbers are to be included, or a character vector of the row names to be included. All observations are included by default.} \item{na.action}{a function to filter missing data. For \code{gee} only \code{na.omit} should be used here.} \item{contrasts}{a list giving contrasts for some or all of the factors appearing in the model formula. The elements of the list should have the same name as the variable and should be either a contrast matrix (specifically, any full-rank matrix with as many rows as there are levels in the factor), or else a function to compute such a matrix given the number of levels.} \item{weights}{an optional vector of weights to be used in the fitting process. The length of \code{weights} should be the same as the number of observations. This weights is not (yet) the weight as in sas proc genmod, and hence is not recommended to use.} \item{zcor}{a design matrix for correlation parameters.} \item{corp}{known parameters such as coordinates used for correlation coefficients.} \item{control}{a list of iteration and algorithmic constants. See \code{\link{geese.control}} for their names and default values. These can also be set as arguments to \code{geese} itself.} \item{b}{an initial estimate for the mean parameters.} \item{alpha}{an initial estimate for the correlation parameters.} \item{gm}{an initial estimate for the scale parameters.} \item{family}{a description of the error distribution and link function to be used in the model, as for \code{\link{glm}}.} \item{mean.link}{a character string specifying the link function for the means. The following are allowed: \code{"identity"}, \code{"logit"}, \code{"probit"}, \code{"cloglog"}, \code{"log"}, and \code{"inverse"}. The default value is determined from family.} \item{variance}{a character string specifying the variance function in terms of the mean. The following are allowed: \code{"gaussian"}, \code{"binomial"}, \code{"poisson"}, and \code{"gamma"}. The default value is determined from family.} \item{cor.link}{a character string specifying the link function for the correlation coefficients. The following are allowed: \code{"identity"}, and \code{"fisherz"}.} \item{sca.link}{a character string specifying the link function for the scales. The following are allowed: \code{"identity"}, and \code{"log"}.} \item{link.same}{a logical indicating if all the components in a cluster should use the same link.} \item{scale.fix}{a logical variable; if true, the scale parameter is fixed at the value of \code{scale.value}.} \item{scale.value}{numeric variable giving the value to which the scale parameter should be fixed; used only if \code{scale.fix == TRUE}.} \item{corstr}{a character string specifying the correlation structure. The following are permitted: \code{"independence"}, \code{"exchangeable"}, \code{"ar1"}, \code{"unstructured"}, \code{"userdefined"}, and \code{"fixed"}} \item{\dots}{further arguments passed to or from other methods.} } \value{ An object of class \code{"geese"} representing the fit. } \description{ Produces an object of class `geese' which is a Generalized Estimating Equation fit of the data. } \details{ when the correlation structure is \code{fixed}, the specification of \code{Zcor} should be a vector of length \code{sum(clusz * (clusz - 1)) / 2.} } \examples{ data(seizure) ## Diggle, Liang, and Zeger (1994) pp166-168, compare Table 8.10 seiz.l <- reshape(seizure, varying=list(c("base","y1", "y2", "y3", "y4")), v.names="y", times=0:4, direction="long") seiz.l <- seiz.l[order(seiz.l$id, seiz.l$time),] seiz.l$t <- ifelse(seiz.l$time == 0, 8, 2) seiz.l$x <- ifelse(seiz.l$time == 0, 0, 1) m1 <- geese(y ~ offset(log(t)) + x + trt + x:trt, id = id, data=seiz.l, corstr="exch", family=poisson) summary(m1) m2 <- geese(y ~ offset(log(t)) + x + trt + x:trt, id = id, data = seiz.l, subset = id!=49, corstr = "exch", family=poisson) summary(m2) ## Using fixed correlation matrix cor.fixed <- matrix(c(1, 0.5, 0.25, 0.125, 0.125, 0.5, 1, 0.25, 0.125, 0.125, 0.25, 0.25, 1, 0.5, 0.125, 0.125, 0.125, 0.5, 1, 0.125, 0.125, 0.125, 0.125, 0.125, 1), 5, 5) cor.fixed zcor <- rep(cor.fixed[lower.tri(cor.fixed)], 59) m3 <- geese(y ~ offset(log(t)) + x + trt + x:trt, id = id, data = seiz.l, family = poisson, corstr = "fixed", zcor = zcor) summary(m3) data(ohio) fit <- geese(resp ~ age + smoke + age:smoke, id=id, data=ohio, family=binomial, corstr="exch", scale.fix=TRUE) summary(fit) fit.ar1 <- geese(resp ~ age + smoke + age:smoke, id=id, data=ohio, family=binomial, corstr="ar1", scale.fix=TRUE) summary(fit.ar1) ###### simulated data ## a function to generate a dataset gendat <- function() { id <- gl(50, 4, 200) visit <- rep(1:4, 50) x1 <- rbinom(200, 1, 0.6) ## within cluster varying binary covariate x2 <- runif(200, 0, 1) ## within cluster varying continuous covariate phi <- 1 + 2 * x1 ## true scale model ## the true correlation coefficient rho for an ar(1) ## correlation structure is 0.667. rhomat <- 0.667 ^ outer(1:4, 1:4, function(x, y) abs(x - y)) chol.u <- chol(rhomat) noise <- as.vector(sapply(1:50, function(x) chol.u \%*\% rnorm(4))) e <- sqrt(phi) * noise y <- 1 + 3 * x1 - 2 * x2 + e dat <- data.frame(y, id, visit, x1, x2) dat } dat <- gendat() fit <- geese(y ~ x1 + x2, id = id, data = dat, sformula = ~ x1, corstr = "ar1", jack = TRUE, j1s = TRUE, fij = TRUE) summary(fit) #### create user-defined design matrix of unstrctured correlation. #### in this case, zcor has 4*3/2 = 6 columns, and 50 * 6 = 300 rows zcor <- genZcor(clusz = rep(4, 50), waves = dat$visit, "unstr") zfit <- geese(y ~ x1 + x2, id = id, data = dat, sformula = ~ x1, corstr = "userdefined", zcor = zcor, jack = TRUE, j1s = TRUE, fij = TRUE) summary(zfit) #### Now, suppose that we want the correlation of 1-2, 2-3, and 3-4 #### to be the same. Then zcor should have 4 columns. z2 <- matrix(NA, 300, 4) z2[,1] <- zcor[,1] + zcor[,4] + zcor[,6] z2[,2:4] <- zcor[, c(2, 3, 5)] summary(geese(y ~ x1 + x2, id = id, data = dat, sformula = ~ x1, corstr = "userdefined", zcor = z2, jack = TRUE, j1s = TRUE, fij = TRUE)) #### Next, we introduce non-constant cluster sizes by #### randomly selecting 60 percent of the data good <- sort(sample(1:nrow(dat), .6 * nrow(dat))) mdat <- dat[good,] summary(geese(y ~ x1 + x2, id = id, data = mdat, waves = visit, sformula = ~ x1, corstr="ar1", jack = TRUE, j1s = TRUE, fij = TRUE)) } \references{ Yan, J. and J.P. Fine (2004) Estimating Equations for Association Structures. \emph{Statistics in Medicine}, \bold{23}, 859--880. } \seealso{ \code{\link{glm}}, \code{\link{lm}}, \code{\link{ordgee}}. } \author{ Jun Yan \email{jyan.stat@gmail.com} } \keyword{models} \keyword{nonlinear} geepack/man/geepack-internal.Rd0000644000176200001440000000121214165262714016130 0ustar liggesusers\name{geepack-internal} \alias{internal} \alias{tidy} \alias{\%>\%} \alias{crossutri} \alias{genZodds} \alias{anova.geeglm} \alias{anovageePrim2} \alias{anova.geeglmlist} \alias{plot.geeglm} \alias{print.geeglm} \alias{eprint} \alias{print.summary.geeglm} \alias{residuals.geeglm} \alias{summary.geeglm} \alias{vcov.geeglm} \title{Internal functions for the geepack package} \description{Internal functions called by other functions.} \usage{ crossutri(wave) genZcor(clusz, waves, corstrv) genZodds(clusz, waves, corstrv, ncat) } \details{ These are not to be called directly by the user. } \keyword{internal}% at least one, from doc/KEYWORDS geepack/man/koch.Rd0000755000176200001440000000117414165262714013655 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-geepack.R \docType{data} \name{koch} \alias{koch} \title{Ordinal Data from Koch} \format{ This data frame contains the following columns: \describe{ \item{trt}{a numeric vector} \item{day}{a numeric vector} \item{y}{an ordered factor with levels: \code{1} < \code{2} < \code{3}} \item{id}{a numeric vector} } } \usage{ koch } \description{ The \code{koch} data frame has 288 rows and 4 columns. } \examples{ data(koch) fit <- ordgee(ordered(y) ~ trt + as.factor(day), id=id, data=koch, corstr="exch") summary(fit) } \keyword{datasets} geepack/man/geeglm.Rd0000755000176200001440000001132514165262714014170 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/geeglm.R \name{geeglm} \alias{geeglm} \title{Fit Generalized Estimating Equations (GEE)} \usage{ geeglm( formula, family = gaussian, data = parent.frame(), weights, subset, na.action, start = NULL, etastart, mustart, offset, control = geese.control(...), method = "glm.fit", contrasts = NULL, id, waves = NULL, zcor = NULL, corstr = "independence", scale.fix = FALSE, scale.value = 1, std.err = "san.se", ... ) } \arguments{ \item{formula}{See corresponding documentation to \code{glm}} \item{family}{See corresponding documentation to \code{glm}} \item{data}{See corresponding documentation to \code{glm}} \item{weights}{See corresponding documentation to \code{glm}} \item{subset}{See corresponding documentation to \code{glm}} \item{na.action}{No action is taken. Indeed geeglm only works on complete data.} \item{start}{See corresponding documentation to \code{glm}} \item{etastart}{See corresponding documentation to \code{glm}} \item{mustart}{See corresponding documentation to \code{glm}} \item{offset}{See corresponding documentation to \code{glm}} \item{control}{See corresponding documentation to \code{glm}} \item{method}{See corresponding documentation to \code{glm}} \item{contrasts}{See corresponding documentation to \code{glm}} \item{id}{a vector which identifies the clusters. The length of `id' should be the same as the number of observations. Data are assumed to be sorted so that observations on each cluster appear as contiguous rows in data. If data is not sorted this way, the function will not identify the clusters correctly. If data is not sorted this way, a warning will be issued. Please consult the package vignette for details.} \item{waves}{Wariable specifying the ordering of repeated mesurements on the same unit. Also used in connection with missing values. Please consult the package vignette for details.} \item{zcor}{Used for entering a user defined working correlation structure.} \item{corstr}{a character string specifying the correlation structure. The following are permitted: '"independence"', '"exchangeable"', '"ar1"', '"unstructured"' and '"userdefined"'} \item{scale.fix}{a logical variable; if true, the scale parameter is fixed at the value of 'scale.value'.} \item{scale.value}{numeric variable giving the value to which the scale parameter should be fixed; used only if 'scale.fix = TRUE'.} \item{std.err}{Type of standard error to be calculated. Defualt 'san.se' is the usual robust estimate. Other options are 'jack': if approximate jackknife variance estimate should be computed. 'j1s': if 1-step jackknife variance estimate should be computed. 'fij': logical indicating if fully iterated jackknife variance estimate should be computed.} \item{\dots}{further arguments passed to or from other methods.} } \value{ An object of type 'geeglm' } \description{ The geeglm function fits generalized estimating equations using the 'geese.fit' function of the 'geepack' package for doing the actual computations. geeglm has a syntax similar to glm and returns an object similar to a glm object. An important feature of geeglm, is that an anova method exists for these models. } \details{ In the case of corstr="fixed" one must provide the zcor vector if the clusters have unequal sizes. Clusters with size one must not be represented in zcor. } \note{ See the documentation for the 'geese' function for additional information. geeglm only works for complete data. Thus if there are NA's in data you can specify data=na.omit(mydata). } \section{Warning }{ Use "unstructured" correlation structure only with great care. (It may cause R to crash). } \examples{ data(dietox) dietox$Cu <- as.factor(dietox$Cu) mf <- formula(Weight ~ Cu * (Time + I(Time^2) + I(Time^3))) gee1 <- geeglm(mf, data=dietox, id=Pig, family=poisson("identity"), corstr="ar1") gee1 coef(gee1) vcov(gee1) summary(gee1) coef(summary(gee1)) mf2 <- formula(Weight ~ Cu * Time + I(Time^2) + I(Time^3)) gee2 <- geeglm(mf2, data=dietox, id=Pig, family=poisson("identity"), corstr="ar1") anova(gee2) } \references{ Halekoh, U.; Højsgaard, S. and Yan, J (2006) The R Package geepack for Generalized Estimating Equations. Journal of Statistical Software, 15, 2, 1-11" Liang, K.Y. and Zeger, S.L. (1986) Longitudinal data analysis using generalized linear models. Biometrika, *73* 13-22. Prentice, R.L. and Zhao, L.P. (1991). Estimating equations for parameters in means and covariances of multivariate discrete and continuous responses. Biometrics, *47* 825-839. } \seealso{ \code{\link{geese}}, \code{\link{glm}}, \code{\link{anova.geeglm}} } \author{ Søren Højsgaard, \email{sorenh@math.aau.dk} } \keyword{models} geepack/man/muscatine.Rd0000644000176200001440000000533714165262714014723 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-geepack.R \docType{data} \name{muscatine} \alias{muscatine} \title{Data on Obesity from the Muscatine Coronary Risk Factor Study.} \format{ A dataframe with 14568 rows and 7 variables: \describe{ \item{id}{identifier of child.} \item{gender}{gender of child} \item{base_age}{baseline age} \item{age}{current age} \item{occasion}{identifier of occasion of recording} \item{obese}{'yes' or 'no'} \item{numobese}{obese in numerical form: 1 corresponds to 'yes' and 0 corresponds to 'no'.} } } \source{ \url{https://content.sph.harvard.edu/fitzmaur/ala2e/muscatine.txt} Woolson, R.F. and Clarke, W.R. (1984). Analysis of categorical incompletel longitudinal data. Journal of the Royal Statistical Society, Series A, 147, 87-99. } \usage{ muscatine } \description{ The data are from the Muscatine Coronary Risk Factor (MCRF) study, a longitudinal survey of school-age children in Muscatine, Iowa. The MCRF study had the goal of examining the development and persistence of risk factors for coronary disease in children. In the MCRF study, weight and height measurements of five cohorts of children, initially aged 5-7, 7-9, 9-11, 11-13, and 13-15 years, were obtained biennially from 1977 to 1981. Data were collected on 4856 boys and girls. On the basis of a comparison of their weight to age-gender specific norms, children were classified as obese or not obese. } \examples{ muscatine$cage <- muscatine$age - 12 muscatine$cage2 <- muscatine$cage^2 f1 <- numobese ~ gender f2 <- numobese ~ gender + cage + cage2 + gender:cage + gender:cage2 gee1 <- geeglm(formula = f1, id = id, waves = occasion, data = muscatine, family = binomial(), corstr = "independence") gee2 <- geeglm(formula = f2, id = id, waves = occasion, data = muscatine, family = binomial(), corstr = "independence") tidy(gee1) tidy(gee2) QIC(gee1) QIC(gee2) } \keyword{datasets} geepack/man/QIC.Rd0000644000176200001440000000505214165262714013341 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/qic.R \name{QIC.geeglm} \alias{QIC.geeglm} \alias{QIC} \alias{QIC.geekin} \alias{QIC.ordgee} \title{Quasi Information Criterion} \usage{ \method{QIC}{geeglm}(object, tol = .Machine$double.eps, ...) \method{QIC}{ordgee}(object, tol = .Machine$double.eps, ...) \method{QIC}{geekin}(object, tol = .Machine$double.eps, ...) QIC(object, tol = .Machine$double.eps, ...) } \arguments{ \item{object}{a fitted GEE model from the geepack package. Currently only works on geeglm objects} \item{tol}{the tolerance used for matrix inversion} \item{\dots}{optionally more fitted geeglm model objects} } \value{ A vector or matrix with the QIC, QICu, quasi likelihood, CIC, the number of mean effect parameters, and the corrected QIC for each GEE object } \description{ Function for calculating the quasi-likelihood under the independence model information criterion (QIC), quasi-likelihood, correlation information criterion (CIC), and corrected QIC for one or several fitted geeglm model object from the geepack package. } \details{ QIC is used to select a correlation structure. The QICu is used to compare models that have the same working correlation matrix and the same quasi-likelihood form but different mean specifications. CIC has been suggested as a more robust alternative to QIC when the model for the mean may not fit the data very well and when models with different correlation structures are compared. Models with smaller values of QIC, CIC, QICu, or QICC are preferred. If the MASS package is loaded then the \code{\link{ginv}} function is used for matrix inversion. Otherwise the standard \code{\link{solve}} function is used. } \examples{ library(geepack) data(ohio) fit <- geeglm(resp ~ age + smoke + age:smoke, id=id, data=ohio, family=binomial, corstr="exch", scale.fix=TRUE) QIC(fit) } \references{ Pan, W. (2001). \emph{Akaike's information criterion in generalized estimating equations}. Biometrics, 57, 120-125.\cr Hardin, J.W. and Hilbe, J.M. (2012). \emph{Generalized Estimating Equations, 2nd Edition}, Chapman and Hall/CRC: New York. \cr Hin, L.-Y. and Wang, Y-G. (2009). \emph{Working-correlation-structure identification in generalized estimating equations}, Statistics in Medicine 28: 642-658. \cr Thall, P.F. and Vail, S.C. (1990). \emph{Some Covariance Models for Longitudinal Count Data with Overdispersion}. Biometrics, 46, 657-671. } \seealso{ \code{geeglm} } \author{ Claus Ekstrom \email{claus@rprimer.dk} } \keyword{htest} geepack/man/geese.control.Rd0000644000176200001440000000272614165262714015501 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/geese.R \name{geese.control} \alias{geese.control} \title{Auxiliary for Controlling GEE Fitting} \usage{ geese.control( epsilon = 1e-04, maxit = 25, trace = FALSE, scale.fix = FALSE, jack = FALSE, j1s = FALSE, fij = FALSE ) } \arguments{ \item{epsilon}{positive convergence tolerance epsilon; the iterations converge when the absolute value of the difference in parameter estimate is below \code{epsilon}.} \item{maxit}{integer giving the maximal number of Fisher Scoring iteration.} \item{trace}{logical indicating if output should be produced for each iteration.} \item{scale.fix}{logical indicating if the scale should be fixed.} \item{jack}{logical indicating if approximate jackknife variance estimate should be computed.} \item{j1s}{logical indicating if 1-step jackknife variance estimate should be computed.} \item{fij}{logical indicating if fully iterated jackknife variance estimate should be computed.} } \value{ A list with the arguments as components. } \description{ Auxiliary function as user interface for `gee' fitting. Only used when calling `geese' or `geese.fit'. } \details{ When `trace' is true, output for each iteration is printed to the screen by the c++ code. Hence, `options(digits = *)' does not control the precision. } \seealso{ `geese.fit', the fitting procedure used by `geese'. } \author{ Jun Yan \email{jyan.stat@gmail.com} } \keyword{models} \keyword{optimize} geepack/man/genZcor.Rd0000644000176200001440000000364014165262714014335 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/genZcor.R \name{genZcor} \alias{genZcor} \alias{humbelbee} \title{genZcor} \usage{ genZcor(clusz, waves, corstrv) } \arguments{ \item{clusz}{integer vector giving the number of observations in each cluster} \item{waves}{integer vector, obervations in the same cluster with values of wave i and j have the correlation \eqn{latex}{sigma_ij}} \item{corstrv}{correlation structures: 1=independence,2=exchangeable,3=ar1, 4=unstructured} } \value{ \item{}{the design matrix for the correlation structure} } \description{ constructs the design matrix for the correlation structures: independence, echangeable, ar1 and unstructured The user will need this function only as a basis to construct a user defined correlation structure: use genZcor to get the design matrix Z for the unstructured correlation and define the specific correlation structure by linear combinations of the columns of Z. } \examples{ #example to construct a Toeplitz correlation structure # sigma_ij=sigma_|i-j| #data set with 5 clusters and maximally 4 observations (visits) per cluster gendat <- function() { id <- gl(5, 4, 20) visit <- rep(1:4, 5) y <- rnorm(id) dat <- data.frame(y, id, visit)[c(-2,-9),] } set.seed(88) dat<-gendat() #generating the design matrix for the unstructured correlation zcor <- genZcor(clusz = table(dat$id), waves = dat$visit, corstrv=4) # defining the Toeplitz structure zcor.toep<-matrix(NA, nrow(zcor),3) zcor.toep[,1]<-apply(zcor[,c(1,4,6)],1,sum) zcor.toep[,2]<-apply(zcor[,c(2,5)],1,sum) zcor.toep[,3]<-zcor[,3] zfit1 <- geese(y ~ 1,id = id, data = dat, corstr = "userdefined", zcor = zcor.toep) zfit2 <- geeglm(y ~ 1,id = id, data = dat, corstr = "userdefined", zcor = zcor.toep) } \seealso{ \code{\link{fixed2Zcor}} } \author{ Jun Yan \email{jyan.stat@gmail.com} } \keyword{regression} geepack/man/seizure.Rd0000755000176200001440000000553714165262714014426 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-geepack.R \docType{data} \name{seizure} \alias{seizure} \title{Epiliptic Seizures} \format{ This data frame contains the following columns: \describe{ \item{y1}{the number of epiliptic seizures in the 1st 2-week interval} \item{y2}{the number of epiliptic seizures in the 2nd 2-week interval} \item{y3}{the number of epiliptic seizures in the 3rd 2-week interval} \item{y4}{the number of epiliptic seizures in the 4th 2-week interval} \item{trt}{an indicator of treatment} \item{base}{the number of epilitic seizures in a baseline 8-week interval} \item{age}{a numeric vector of subject age} } } \source{ Thall, P.F. and Vail S.C. (1990) Some covariance models for longitudinal count data with overdispersion. \emph{Biometrics} \bold{46}: 657--671. } \usage{ seizure } \description{ The \code{seizure} data frame has 59 rows and 7 columns. The dataset has the number of epiliptic seizures in each of four two-week intervals, and in a baseline eight-week inverval, for treatment and control groups with a total of 59 individuals. } \examples{ data(seizure) ## Diggle, Liang, and Zeger (1994) pp166-168, compare Table 8.10 seiz.l <- reshape(seizure, varying=list(c("base","y1", "y2", "y3", "y4")), v.names="y", times=0:4, direction="long") seiz.l <- seiz.l[order(seiz.l$id, seiz.l$time),] seiz.l$t <- ifelse(seiz.l$time == 0, 8, 2) seiz.l$x <- ifelse(seiz.l$time == 0, 0, 1) m1 <- geese(y ~ offset(log(t)) + x + trt + x:trt, id = id, data=seiz.l, corstr="exch", family=poisson) summary(m1) m2 <- geese(y ~ offset(log(t)) + x + trt + x:trt, id = id, data = seiz.l, subset = id!=49, corstr = "exch", family=poisson) summary(m2) ## Thall and Vail (1990) seiz.l <- reshape(seizure, varying=list(c("y1","y2","y3","y4")), v.names="y", direction="long") seiz.l <- seiz.l[order(seiz.l$id, seiz.l$time),] seiz.l$lbase <- log(seiz.l$base / 4) seiz.l$lage <- log(seiz.l$age) seiz.l$v4 <- ifelse(seiz.l$time == 4, 1, 0) m3 <- geese(y ~ lbase + trt + lbase:trt + lage + v4, sformula = ~ as.factor(time) - 1, id = id, data = seiz.l, corstr = "exchangeable", family=poisson) ## compare to Model 13 in Table 4, noticeable difference summary(m3) ## set up a design matrix for the correlation z <- model.matrix(~ age, data = seizure) # data is not seiz.l ## just to illustrate the scale link and correlation link m4 <- geese(y ~ lbase + trt + lbase:trt + lage + v4, sformula = ~ as.factor(time)-1, id = id, data = seiz.l, corstr = "ar1", family = poisson, zcor = z, cor.link = "fisherz", sca.link = "log") summary(m4) } \references{ Diggle, P.J., Liang, K.Y., and Zeger, S.L. (1994) Analysis of Longitudinal Data. Clarendon Press. } \keyword{datasets} geepack/man/relRisk.Rd0000644000176200001440000000433214165262714014340 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/relative-risk-regression.R \name{relRisk} \alias{relRisk} \title{Fit a Relative Risk Model for Binary data with Log Link} \usage{ relRisk( formula, id, waves = NULL, data = parent.frame(), subset = NULL, contrasts = NULL, na.action = na.omit, corstr = "indep", ncopy = 1000, control = geese.control(), b = NULL, alpha = NULL ) } \arguments{ \item{formula}{same as in \code{geese}} \item{id}{same as in \code{geese}} \item{waves}{same as in \code{geese}} \item{data}{same as in \code{geese}} \item{subset}{same as in \code{geese}} \item{contrasts}{same as in \code{geese}} \item{na.action}{same as in \code{geese}} \item{corstr}{same as in \code{geese}} \item{ncopy}{the number of copies of the original data in constructing weight.} \item{control}{same as in \code{geese}} \item{b}{initial values for regression coefficients as in \code{geese} but more difficult to obtain due to the log link.} \item{alpha}{same as in \code{geese}} } \value{ An object of class \code{"geese"} representing the fit. } \description{ Fit a Relative Risk Model for Binary data with Log Link using the COPY method. } \examples{ ## this example was used in Yu and Yan (2010, techreport) data(respiratory) respiratory$treat <- relevel(respiratory$treat, ref = "P") respiratory$sex <- relevel(respiratory$sex, ref = "M") respiratory$center <- as.factor(respiratory$center) ## 1 will be the reference level fit <- relRisk(outcome ~ treat + center + sex + age + baseline + visit, id = id, corstr = "ar1", data = respiratory, ncopy=10000) summary(fit) ## fit <- relRisk(outcome ~ treat + center + sex + age + baseline + visit, ## id = id, corstr = "ex", data = respiratory) ## summary(fit) ## fit <- relRisk(outcome ~ treat + center + sex + age + baseline + visit, ## id = id, corstr = "indep", data = respiratory) ## summary(fit) } \references{ Lumley, T., Kornmal, R. and Ma, S. (2006). Relative risk regression in medical research: models, contrasts, estimators, and algorithms. UW Biostatistics Working Paper Series 293, University of Washington. } \author{ Jun Yan \email{jyan.stat@gmail.com} } \keyword{models} geepack/man/fixed2Zcor.Rd0000755000176200001440000000304114165262714014743 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fixed2Zcor.R \name{fixed2Zcor} \alias{fixed2Zcor} \title{Construct zcor vector} \usage{ fixed2Zcor(cor.fixed, id, waves) } \arguments{ \item{cor.fixed}{Matrix} \item{id}{Clusters} \item{waves}{Vector giving the ordering of observations within clusters.} } \value{ A vector which can be passed as the zcor argument to geeglm. } \description{ Construct zcor vector (of fixed correlations) from a fixed working correlation matrix, a specification of clusters and a specifcation of waves. } \examples{ timeorder <- rep(1:5, 6) tvar <- timeorder + rnorm(length(timeorder)) idvar <- rep(1:6, each=5) uuu <- rep(rnorm(6), each=5) yvar <- 1 + 2*tvar + uuu + rnorm(length(tvar)) simdat <- data.frame(idvar, timeorder, tvar, yvar) head(simdat,12) simdatPerm <- simdat[sample(nrow(simdat)),] simdatPerm <- simdatPerm[order(simdatPerm$idvar),] head(simdatPerm) cor.fixed <- matrix(c(1 , 0.5 , 0.25, 0.125, 0.125, 0.5 , 1 , 0.25, 0.125, 0.125, 0.25 , 0.25 , 1 , 0.5 , 0.125, 0.125, 0.125, 0.5 , 1 , 0.125, 0.125, 0.125, 0.125, 0.125, 1 ), nrow=5, ncol=5) cor.fixed zcor <- fixed2Zcor(cor.fixed, id=simdatPerm$idvar, waves=simdatPerm$timeorder) zcor mod4 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="fixed", zcor=zcor) mod4 } \seealso{ \code{\link{genZcor}}, \code{\link{geeglm}} } \author{ Søren Højsgaard, \email{sorenh@math.aau.dk} } \keyword{regression} geepack/man/compCoef.Rd0000644000176200001440000000434114165262714014460 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/geese.R \name{compCoef} \alias{compCoef} \title{Compare Regression Coefficiente between Nested Models} \usage{ compCoef(fit0, fit1) } \arguments{ \item{fit0}{a fitted object of class \code{geese}} \item{fit1}{another fitted object of class \code{geese}} } \value{ a list of two components: \item{delta}{estimated difference in the coefficients of common covariates from \code{fit0} and \code{fit1}} \item{variance}{estimated variance matrix of delta} } \description{ Comparing regression coefficients between models when one model is nested within another for clustered data. } \examples{ ## generate clustered data gendat <- function(ncl, clsz) { ## ncl: number of clusters ## clsz: cluster size (all equal) id <- rep(1:ncl, each = clsz) visit <- rep(1:clsz, ncl) n <- ncl * clsz x1 <- rbinom(n, 1, 0.5) ## within cluster varying binary covariate x2 <- runif(n, 0, 1) ## within cluster varying continuous covariate ## the true correlation coefficient rho for an ar(1) ## correlation structure is 2/3 rho <- 2/3 rhomat <- rho ^ outer(1:4, 1:4, function(x, y) abs(x - y)) chol.u <- chol(rhomat) noise <- as.vector(sapply(1:ncl, function(x) chol.u \%*\% rnorm(clsz))) y <- 1 + 3 * x1 - 2 * x2 + noise dat <- data.frame(y, id, visit, x1, x2) dat } simdat <- gendat(100, 4) fit0 <- geese(y ~ x1, id = id, data = simdat, corstr = "un") fit1 <- geese(y ~ x1 + x2, id = id, data = simdat, corstr = "un") compCoef(fit0, fit1) } \references{ Allison, P. D. (1995). The impact of random predictors on comparisons of coefficients between models: Comment on Clogg, Petkova, and Haritou. \emph{American Journal of Sociology}, \bold{100}(5), 1294--1305. Clogg, C. C., Petkova, E., and Haritou, A. (1995). Statistical methods for comparing regression coefficients between models. \emph{American Journal of Sociology}, \bold{100}(5), 1261--1293. Yan, J., Aseltine, R., and Harel, O. (2011). Comparing Regression Coefficients Between Nested Linear Models for Clustered Data with Generalized Estimating Equations. \emph{Journal of Educational and Behaviorial Statistics}, Forthcoming. } \author{ Jun Yan \email{jyan.stat@gmail.com} } \keyword{models} geepack/man/ohio.Rd0000755000176200001440000000220414165262714013662 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-geepack.R \docType{data} \name{ohio} \alias{ohio} \title{Ohio Children Wheeze Status} \format{ This data frame contains the following columns: \describe{ \item{resp}{an indicator of wheeze status (1=yes, 0=no)} \item{id}{a numeric vector for subject id} \item{age}{a numeric vector of age, 0 is 9 years old} \item{smoke}{an indicator of maternal smoking at the first year of the study} } } \usage{ ohio } \description{ The \code{ohio} data frame has 2148 rows and 4 columns. The dataset is a subset of the six-city study, a longitudinal study of the health effects of air pollution. } \examples{ data(ohio) fit.ex <- geeglm(resp ~ age + smoke + age:smoke, id=id, data=ohio, family=binomial, corstr="exch", scale.fix=TRUE) QIC(fit.ex) fit.ar <- geeglm(resp ~ age + smoke + age:smoke, id=id, data=ohio, family=binomial, corstr="ar1", scale.fix=TRUE) QIC(fit.ex) } \references{ Fitzmaurice, G.M. and Laird, N.M. (1993) A likelihood-based method for analyzing longitudinal binary responses, \emph{Biometrika} \bold{80}: 141--151. } \keyword{datasets} geepack/man/dietox.Rd0000644000176200001440000000317614165262714014226 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data-geepack.R \docType{data} \name{dietox} \alias{dietox} \title{Growth curves of pigs in a 3x3 factorial experiment} \format{ This data frame contains the following columns: \describe{ \item{Weight}{Weight in Kg} \item{Feed}{Cumulated feed intake in Kg} \item{Time}{Time (in weeks) in the experiment} \item{Pig}{Factor; id of each pig} \item{Evit}{Factor; vitamin E dose; see 'details'.} \item{Cu}{Factor, copper dose; see 'details'} \item{Start}{Start weight in experiment, i.e. weight at week 1.} \item{Litter}{Factor, id of litter of each pig} } } \source{ Lauridsen, C., Højsgaard, S.,Sørensen, M.T. C. (1999) Influence of Dietary Rapeseed Oli, Vitamin E, and Copper on Performance and Antioxidant and Oxidative Status of Pigs. J. Anim. Sci.77:906-916 } \usage{ dietox } \description{ The \code{dietox} data frame has 861 rows and 7 columns. } \details{ Data contains weight of slaughter pigs measured weekly for 12 weeks. Data also contains the startweight (i.e. the weight at week 1). The treatments are 3 different levels of Evit = vitamin E (dose: 0, 100, 200 mg dl-alpha-tocopheryl acetat /kg feed) in combination with 3 different levels of Cu=copper (dose: 0, 35, 175 mg/kg feed) in the feed. The cumulated feed intake is also recorded. The pigs are littermates. } \examples{ data(dietox) head(dietox) \dontrun{ if (require(ggplot2)){ qplot(Time, Weight, data=dietox, col=Pig) + geom_line() + theme(legend.position = "none") + facet_grid(Evit~Cu) } else { coplot(Weight ~ Time | Evit * Cu, data=dietox) } } } \keyword{datasets} geepack/man/ordgee.Rd0000644000176200001440000001146614165262714014200 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ordgee.R \name{ordgee} \alias{ordgee} \title{GEE for Clustered Ordinal Responses} \usage{ ordgee( formula = formula(data), ooffset = NULL, id, waves = NULL, data = parent.frame, subset = NULL, na.action = na.omit, contrasts = NULL, weights = NULL, z = NULL, mean.link = "logit", corstr = "independence", control = geese.control(...), b = NA, alpha = NA, scale.fix = TRUE, scale.val = 1, int.const = TRUE, rev = FALSE, ... ) } \arguments{ \item{formula}{a formula expression as for \code{glm}, of the form \code{response ~ predictors}. See the documentation of lm and formula for details. As for glm, this specifies the linear predictor for modelling the mean. A term of the form \code{offset(expression)} is allowed.} \item{ooffset}{vector of offset for the odds ratio model.} \item{id}{a vector which identifies the clusters. The length of `id' should be the same as the number of observations. Data are assumed to be sorted so that observations on a cluster are contiguous rows for all entities in the formula.} \item{waves}{an integer vector which identifies components in clusters. The length of \code{waves} should be the same as the number of observation. components with the same \code{waves} value will have the same link functions.} \item{data}{an optional data frame in which to interpret the variables occurring in the \code{formula}, along with the \code{id} and \code{n} variables.} \item{subset}{expression saying which subset of the rows of the data should be used in the fit. This can be a logical vector (which is replicated to have length equal to the number of observations), or a numeric vector indicating which observation numbers are to be included, or a character vector of the row names to be included. All observations are included by default.} \item{na.action}{a function to filter missing data. For \code{gee} only \code{na.omit} should be used here.} \item{contrasts}{a list giving contrasts for some or all of the factors appearing in the model formula. The elements of the list should have the same name as the variable and should be either a contrast matrix (specifically, any full-rank matrix with as many rows as there are levels in the factor), or else a function to compute such a matrix given the number of levels.} \item{weights}{an optional vector of weights to be used in the fitting process. The length of \code{weights} should be the same as the number of observations.} \item{z}{a design matrix for the odds ratio model. The number of rows of z is \deqn{c^2 \sum n_i(n_i - 1)/2,} where \eqn{n_i} is the cluster size, and \eqn{c} is the number of categories minus 1.} \item{mean.link}{a character string specifying the link function for the means. The following are allowed: \code{"logit"}, \code{"probit"}, and \code{"cloglog"}.} \item{corstr}{a character string specifying the log odds. The following are allowed: \code{"independence"}, \code{"exchangeable"}, \code{"unstructured"}, and \code{"userdefined"}.} \item{control}{a list of iteration and algorithmic constants. See \code{\link{geese.control}} for their names and default values. These can also be set as arguments to \code{geese} itself.} \item{b}{an initial estimate for the mean parameters.} \item{alpha}{an initial estimate for the odds ratio parameters.} \item{scale.fix}{a logical variable indicating if scale is fixed; it is set at TRUE currently (it can not be FALSE yet!).} \item{scale.val}{this argument is ignored currently.} \item{int.const}{a logical variable; if true, the intercepts are constant, and if false, the intercepts are different for different components in the response.} \item{rev}{a logical variable. For example, for a three level ordered response Y = 2, the accumulated indicator is coded as (1, 0, 0) if true and (0, 1, 1) if false.} \item{\dots}{further arguments passed to or from other methods.} } \value{ An object of class \code{"geese"} representing the fit. } \description{ Produces an object of class `geese' which is a Generalized Estimating Equation fit of the clustered ordinal data. } \examples{ data(respdis) resp.l <- reshape(respdis, varying =list(c("y1", "y2", "y3", "y4")), v.names = "resp", direction = "long") resp.l <- resp.l[order(resp.l$id, resp.l$time),] fit <- ordgee(ordered(resp) ~ trt, id=id, data=resp.l, int.const=FALSE) summary(fit) data(ohio) ohio$resp <- ordered(as.factor(ohio$resp)) fit <- ordgee(resp ~ age + smoke + age:smoke, id = id, data=ohio) summary(fit) } \references{ Heagerty, P.J. and Zeger, S.L. (1996) Marginal regression models for clustered ordinal measurements. \emph{JASA}, \bold{91} 1024--1036. } \seealso{ \code{\link{glm}}, \code{\link{lm}}, \code{\link{geese}}. } \author{ Jun Yan \email{jyan.stat@gmail.com} } \keyword{models} \keyword{nonlinear} geepack/DESCRIPTION0000644000176200001440000000240614166452400013363 0ustar liggesusersPackage: geepack Version: 1.3.3 Title: Generalized Estimating Equation Package Authors@R: c( person(given = "Søren", family = "Højsgaard", email = "sorenh@math.aau.dk", role = c("aut", "cre", "cph")), person(given = "Ulrich", family = "Halekoh", email = "uhalekoh@health.sdu.dk", role = c("aut", "cph")), person(given = "Jun", family = "Yan", email = "jun.yan@uconn.edu", role = c("aut", "cph")), person(given = "Claus", family = "Ekstrøm", email = "ekstrom@sund.ku.dk", role = c("ctb")) ) Maintainer: Søren Højsgaard Description: Generalized estimating equations solver for parameters in mean, scale, and correlation structures, through mean link, scale link, and correlation link. Can also handle clustered categorical responses. See e.g. Halekoh and Højsgaard, (2005, ), for details. Encoding: UTF-8 LazyData: true License: GPL (>= 3) NeedsCompilation: yes Depends: R (>= 3.5.0), methods Imports: MASS, broom, magrittr RoxygenNote: 7.1.1 Packaged: 2022-01-07 09:12:18 UTC; sorenh Author: Søren Højsgaard [aut, cre, cph], Ulrich Halekoh [aut, cph], Jun Yan [aut, cph], Claus Ekstrøm [ctb] Repository: CRAN Date/Publication: 2022-01-09 03:22:40 UTC geepack/build/0000755000176200001440000000000014166001762012753 5ustar liggesusersgeepack/build/vignette.rds0000644000176200001440000000041114166001762015306 0ustar liggesusersN1ĄH})^ ȵnݬzY(&i;w3&P%tOB22y{n׺ٛXH6"&q%lnz97W$ԠEgi@@J~`KeŽ%[~4^kA\ Q+?$3|ϘA`T*'}Ya.-bdM˸&koP ybMFgeepack/src/0000755000176200001440000000000014166001762012443 5ustar liggesusersgeepack/src/param.cc0000755000176200001440000000423114165262714014062 0ustar liggesusersusing namespace std; #include "tntsupp.h" #include "geese.h" #include "param.h" //class Control Control::Control(int trace, int ajs, int j1s, int fij, int maxiter, double tol) : _trace(trace), _ajs(ajs), _j1s(j1s), _fij(fij), _maxiter(maxiter), _tol(tol){} Control::Control(int *con, double tol) { _trace = con[0]; _ajs = con[1]; _j1s = con[2]; _fij = con[3]; _maxiter = con[4]; _tol = tol; } Control::Control(const Control &C) : //{ _trace(C.trace()), _ajs(C.ajs()), _j1s(C.j1s()), _fij(C.fij()), _maxiter(C.maxiter()), _tol(C.tol()) {} // _trace = C.trace(); _ajs = C.ajs(); _j1s = C.j1s(); //_fij = C.fij(); _maxiter = C.maxiter(); _tol = C.tol(); //} //class GeeParam GeeParam::GeeParam(DVector Beta, DVector Alpha, DVector Gamma): _beta(Beta), _alpha(Alpha), _gamma(Gamma), _err(0) { int p = Beta.size(), q = Alpha.size(), r = Gamma.size(); DMatrix vb(p,p), va(q,q), vg(r,r); _vbeta = vb; _vbeta_naiv = vb; _vbeta_ajs = vb; _vbeta_j1s = vb; _vbeta_fij = vb; _valpha = va; _valpha_naiv = va; _valpha_ajs = va; _valpha_j1s = va; _valpha_fij = va; _valpha_stab = va; _vgamma = vg; _vgamma_ajs = vg; _vgamma_j1s = vg; _vgamma_fij = vg; } GeeParam::GeeParam(DVector Beta, DVector Alpha, DVector Gamma, DMatrix VBeta, DMatrix VBeta_naiv, DMatrix VBeta_ajs, DMatrix VBeta_j1s, DMatrix VBeta_fij, DMatrix VAlpha, DMatrix VAlpha_stab, DMatrix VAlpha_naiv, DMatrix VAlpha_ajs, DMatrix VAlpha_j1s, DMatrix VAlpha_fij, DMatrix VGamma, DMatrix VGamma_ajs, DMatrix VGamma_j1s, DMatrix VGamma_fij): _beta(Beta), _alpha(Alpha), _gamma(Gamma), _vbeta(VBeta), _vbeta_naiv(VBeta_naiv), _vbeta_ajs(VBeta_ajs), _vbeta_j1s(VBeta_j1s), _vbeta_fij(VBeta_fij), _valpha(VAlpha), _valpha_stab(VAlpha_stab), _valpha_naiv(VAlpha_naiv), _valpha_ajs(VAlpha_ajs), _valpha_j1s(VAlpha_j1s), _valpha_fij(VAlpha_fij), _vgamma(VGamma), _vgamma_ajs(VGamma_ajs), _vgamma_j1s(VGamma_j1s), _vgamma_fij(VGamma_fij) {} /* GeeParam(int p, int q, double *beta, double *alpha, double *vbeta, double *vbeta_naiv, double *valpha, double *valpha_stab, double *valpha_naiv) { _beta(beta, p); _alpha(alpha, q); _vbeta(vbeta, p, p); } */ geepack/src/gee2.cc0000755000176200001440000004444314165262714013615 0ustar liggesusers// using namespace std; // #include "tntsupp.h" // #include "geese.h" // extern "C"{ // #include // #include // #include // } // #include "famstr.h" // #include "param.h" // #include "inter.h" // #include "utils.h" // #include "geesubs.h" #include "gee2.h" IVector comp_lev(GeeStr &geestr, Corr &cor) { IVector level(2); if (geestr.ScaleFix() != 1) level(1) = 1; if (cor.nparam() > 0) level(2) = 1; return level; } DMatrix gee_infls(DVector &Y, DMatrix &X, DVector &Offset, DVector &Doffset, DVector &W, IVector &LinkWave, DMatrix &Zsca, DMatrix &Zcor, DVector &CorP, IVector &Clusz, GeeStr &geestr, Corr &cor, GeeParam &par, Control &con) { Hess Hi(par), H(par); Grad Gi(par); int n = Clusz.size(); IVector ZcorSize(n); //if (cor.nparam() > 1) if (cor.corst() > AR1) // == UNSTRUCTRUED || USERDEFINED || FIXED for (int i = 1; i <= n; i++) ZcorSize(i) = Clusz(i) * (Clusz(i) - 1) / 2; else ZcorSize = 1; IVector level(2); level = 0; if (geestr.ScaleFix() != 1) level(1) = 1; if (cor.nparam() > 0) level(2) = 1; int p = par.p(), q = par.q(), r = par.r(); DMatrix L11(p,p), L12(p,r), L13(p,q), L22(r,r), L23(r,q), L33(q,q); int l = p + q + r; DMatrix infls(l, n), HH(l, l); Index1D I(0,0), J(0,0); Index1D I1(0, 0), JJ(0, 0), I2(0, 0), I3(0, 0); I1 = Index1D(1, p); I2 = Index1D(p + 1, p + r); I3 = Index1D(p + r + 1, p + r + q); for (int i = 1; i <= n; i++) { int s1 = Clusz(i), s2 = ZcorSize(i), crs = s1 * (s1 - 1) / 2;; I = Index1D(1, s1) + I.ubound(); if (s2 > 0) J = Index1D(1, s2) + J.ubound(); DVector PRi(s1), Vi(s1), V_Mui(s1); DMatrix Di(s1,p); gee_prep(Y, X, Offset, I, LinkWave, par, geestr, PRi, Di, Vi, V_Mui); DVector Phii(s1); DMatrix D2i(s1, r); PhiandD2(I, LinkWave, Doffset, Zsca, par, geestr, Phii, D2i); DMatrix R(s1, s1), E(crs, q); RandE(Zcor, I, J, CorP, par, geestr, cor, R, E); //cout << "i = " << i; DVector Wi = asVec(VecSubs(W, I)); HiandGi(PRi, Phii, Di, R, Vi, V_Mui, D2i, E, Wi, level, Hi, Gi); //cout << "Hi = " << Hi; cout << "H = " << H; //cout << "Gi = " << Gi; H.inc(Hi); JJ = Index1D(i, i); infls(I1, JJ) = asColMat(Gi.U1()); if (level(1) == 1) infls(I2, JJ) = asColMat(Gi.U2()); if (level(2) == 1) infls(I3, JJ) = asColMat(Gi.U3()); } Hess Hinv = inv(H, level); I1 = Index1D(1, p); HH(I1, I1) = Hinv.A(); if (level(1) == 1) { HH(I2, I1) = Hinv.B(); HH(I2, I2) = Hinv.C(); } if (level(2) == 1) { HH(I3, I1) = Hinv.D(); HH(I3, I3) = Hinv.F(); if (level(1) == 1) HH(I3, I2) = Hinv.E(); } infls = HH * infls; return infls; } void gee_var(DVector &Y, DMatrix &X, DVector &Offset, DVector &Doffset, DVector &W, IVector &LinkWave, DMatrix &Zsca, DMatrix &Zcor, DVector &CorP, IVector &Clusz, IVector &ZcorSize, GeeStr &geestr, Corr &cor, GeeParam &par, Control &con) { Hess Hi(par), H(par); Grad Gi(par); IVector level(2); level = 0; if (geestr.ScaleFix() != 1) level(1) = 1; if (cor.nparam() > 0) level(2) = 1; int p = par.p(), q = par.q(), r = par.r(); DMatrix L11(p,p), L12(p,r), L13(p,q), L22(r,r), L23(r,q), L33(q,q); Index1D I(0,0), J(0,0); for (int i = 1; i <= Clusz.size(); i++) { int s1 = Clusz(i), s2 = ZcorSize(i), crs = s1 * (s1 - 1) / 2;; I = Index1D(1, s1) + I.ubound(); if (s2 > 0) J = Index1D(1, s2) + J.ubound(); DVector PRi(s1), Vi(s1), V_Mui(s1); DMatrix Di(s1,p); gee_prep(Y, X, Offset, I, LinkWave, par, geestr, PRi, Di, Vi, V_Mui); DVector Phii(s1); DMatrix D2i(s1, r); PhiandD2(I, LinkWave, Doffset, Zsca, par, geestr, Phii, D2i); DMatrix R(s1, s1), E(crs, q); RandE(Zcor, I, J, CorP, par, geestr, cor, R, E); //cout << "i = " << i; DVector Wi = asVec(VecSubs(W, I)); HiandGi(PRi, Phii, Di, R, Vi, V_Mui, D2i, E, Wi, level, Hi, Gi); //cout << "Hi = " << Hi; cout << "H = " << H; //cout << "Gi = " << Gi; H.inc(Hi); L11 = L11 + outerprod(Gi.U1()); if (level(1) == 1) { L12 = L12 + outerprod(Gi.U1(), Gi.U2()); L22 = L22 + outerprod(Gi.U2()); } if (level(2) == 1) { L13 = L13 + outerprod(Gi.U1(), Gi.U3()); L33 = L33 + outerprod(Gi.U3()); if (level(1) == 1) L23 = L23 + outerprod(Gi.U2(), Gi.U3()); } } //Vbeta: Hess Hinv = inv(H, level); par.set_vbeta_naiv(Hinv.A()); par.set_vbeta(Hinv.A() * L11 * Hinv.A()); //Vgamma: if (level(1) == 1) { par.set_vgamma((Hinv.B() * L11 + Hinv.C() * transpose(L12)) * transpose(Hinv.B()) + (Hinv.B() * L12 + Hinv.C() * L22) * Hinv.C()); } //Valpha: if (level(2) == 1) { par.set_valpha_naiv(Hinv.F()); par.set_valpha_stab(Hinv.F() * L33 * Hinv.F()); par.set_valpha((Hinv.D() * L11 + Hinv.E() * transpose(L12) + Hinv.F() * transpose(L13)) * transpose(Hinv.D()) + (Hinv.D() * L12 + Hinv.E() * L22 + Hinv.F() * transpose(L23)) * transpose(Hinv.E()) + (Hinv.D() * L13 + Hinv.E() * L23 + Hinv.F() * L33) * Hinv.F()); } } double update_beta(DVector &Y, DMatrix &X, DVector &Offset, DVector &W, DVector &Phi, IVector &LinkWave, DVector &CorP, DMatrix &Zcor, IVector &Clusz, IVector &ZcorSize, IVector &Jack, GeeParam &par, GeeStr &geestr, Corr &cor) { double del = 0; // DVector alp = par.alpha(); int p = par.p(); DMatrix H(p,p); DVector G(p); int n = Clusz.size(); Index1D I(0,0), J(0,0); for (int i = 1; i <= n; i++) { int s1 = Clusz(i), s2 = ZcorSize(i); I = Index1D(1, s1) + I.ubound(); if (s2 > 0) J = Index1D(1, s2) + J.ubound(); //?? what is s2 == 0 ?? if (Jack(i) == 1) continue; DVector PRi(s1); DMatrix Di(s1,p); PRandD(Y, X, Offset, I, LinkWave, par, geestr, PRi, Di); DVector rootInvPhii = sqrt(recip(asVec(VecSubs(Phi, I)))); DVector rootWi = sqrt(asVec(VecSubs(W, I))); Di = SMult(rootWi, Di); PRi = SMult(rootWi, PRi); Di = SMult(rootInvPhii, Di); PRi = SMult(rootInvPhii, PRi); DMatrix R = getR(Zcor, I, J, CorP, par, geestr, cor); H = H + AtBiC(Di, R, Di); G = G + AtBiC(Di, R, PRi); } DVector Del = solve(H, G); DVector Bnew = par.beta() + Del; while (1) { // cerr << "in updating beta: " << "Del = " << Del << endl; DVector Eta = X * Bnew + Offset; DVector Mu = geestr.MeanLinkinv(Eta, LinkWave); if (geestr.validMu(Mu, LinkWave)) break; Del = 0.5 * Del; Bnew = par.beta() + Del; } par.set_beta(Bnew); del = fmax(fabs(Del)); return del; } double update_gamma(DVector &PR, DVector &W, IVector &LinkWave, IVector &Clusz, IVector &Jack, DVector &Doffset, DMatrix &Zsca, GeeParam &par, GeeStr &geestr) { double del = 0; int r = par.r(), n = Clusz.size(); // double adj = (double) (PR.size()) / (double)(PR.size() - par.p()); if (geestr.ScaleFix() == 1) return del; DMatrix H(r,r); DVector G(r); Index1D I(0,0); for (int i = 1; i <= n; i++) { int s1 = Clusz(i); I = Index1D(1, s1) + I.ubound(); if (Jack(i) == 1) continue; DVector Phii(s1), Si(s1); DMatrix D2i(s1, r); gm_prep(PR, I, LinkWave, Doffset, Zsca, par, geestr, Phii, Si, D2i); //DMatrix V2 = diag(2.0 * Phii); //independence working structure only now, so no inverting below DVector WiV2inv = SMult(asVec(VecSubs(W, I)), recip(2.0 * Phii)); H = H + Transpose_view(D2i) * SMult(WiV2inv, D2i); G = G + Transpose_view(D2i) * SMult(WiV2inv, Si - Phii); //adj * Si //H = H + AtBiC(D2i, WiV2, D2i); //G = G + AtBiC(D2i, WiV2, Si - Phii); } DVector Del = solve(H, G); //cout << "H = " << H << "G = " << G; //par.set_gamma((double) N / (double)(N - p) * (par.gamma() + Del)); par.set_gamma(par.gamma() + Del); del = fmax(fabs(Del)); return del; } double update_alpha(DVector &PR, DVector &Phi, DVector &CorP, DVector &W, IVector &Clusz, IVector &ZcorSize, IVector &Jack, DMatrix &Zcor, GeeParam &par, GeeStr &geestr, Corr &cor) { double del = 0; int q = par.q(), n = Clusz.size(); if (cor.nparam() == 0) return del; DMatrix H(q,q); DVector G(q); Index1D I(0,0), J(0,0); for (int i = 1; i <= n; i++) { int s1 = Clusz(i), s2 = ZcorSize(i), crs = s1 * (s1 - 1) / 2; I = Index1D(1, s1) + I.ubound(); if (s2 > 0) J = Index1D(1, s2) + J.ubound(); if (Jack(i) == 1) continue; if (s1 == 1) continue; DVector PRi = asVec(VecSubs(PR, I)); DVector Phii = asVec(VecSubs(Phi, I)); DVector sPRi = SMult(reciproot(Phii), PRi); DVector zi = genzi(sPRi); DMatrix R(s1, s1), E(crs, q); RandE(Zcor, I, J, CorP, par, geestr, cor, R, E); DVector rhoi = utri(R); DVector Wi = asVec(VecSubs(W, I)); //DMatrix V3 = diag(genzi(rootWi)); //independence working correlation only now, no need of inverting below DVector WiV3inv = genzi(Wi); H = H + Transpose_view(E) * SMult(WiV3inv, E); G = G + Transpose_view(E) * SMult(WiV3inv, zi - rhoi); //H = H + AtBiC(E, V3, E); //G = G + AtBiC(E, V3, zi - rhoi); } DVector Del = solve(H, G); par.set_alpha(par.alpha() + Del); del = fmax(fabs(Del)); return del; } /********************************************************* Input: Y: response vector; X: covariate matrix for mean structure; LinkWave: determines which link to apply on each response component; Weight: weight, to be implemented ... ... ???; Offset: offset, to be implemented ... ... ???; Zsca: covariate matrix for scale structure; Zcor: covariate matrix for correlation structure; Corp: correlation parameters to feed cor.mat(rho, .), can be distances for spatial correlation; it is now a vector, which can not really handle >=2 spatial correlations; it really should be a matrix which contains the data to feed cor.mat(rho, .); it actually is the same as LinkWave now, but should be more general to contain high dimensional data, such as coordinates in R x R. Clusz: cluster sizes; ZcorSize: number of rows in Zcor for each cluster; geestr: GEE structure, contains links, variances for each wave; cor: correlation structure; par: parameter values; Jack: Jackknife indicator; con: control parameters: ScaleFix, ajs, j1s, fij, tol, maxiter; *********************************************************/ void gee_est(DVector &Y, DMatrix &X, DVector &Offset, DVector &Doffset, DVector &W, IVector &LinkWave, DMatrix &Zsca, DMatrix &Zcor, DVector &CorP, IVector &Clusz, IVector &ZcorSize, GeeStr &geestr, Corr &cor, GeeParam &par, IVector &Jack, Control &con) { DVector Del(3); int N = Y.size(); DVector PR(N), Phi(N); int iter; double del; for (iter = 0; iter < con.maxiter(); iter++) { if (con.trace() == 1) { //cerr << "iter " << iter << endl; //cerr << "beta = " << par.beta() << "gamma = " << par.gamma() << "alpha = " << par.alpha(); Rprintf("iter = %d\n", iter); Rprintf("beta = "); VecPrint(par.beta()); Rprintf("gamma = "); VecPrint(par.gamma()); Rprintf("alpha = "); VecPrint(par.alpha()); } //updating beta; Phi = getPhi(Doffset, Zsca, LinkWave, par, geestr); Del(1) = update_beta(Y, X, Offset, W, Phi, LinkWave, CorP, Zcor, Clusz, ZcorSize, Jack, par, geestr, cor); //updating gamma; PR = getPR(Y, X, Offset, LinkWave, par, geestr); //cout << "PR = " << PR; //PR = (double) (N / (N - p)) * PR; //df adjusting Del(2) = update_gamma(PR, W, LinkWave, Clusz, Jack, Doffset, Zsca, par, geestr); //updating alpha; Phi = getPhi(Doffset, Zsca, LinkWave, par, geestr); Del(3) = update_alpha(PR, Phi, CorP, W, Clusz, ZcorSize, Jack, Zcor, par, geestr, cor); del = fmax(Del); if (del <= con.tol()) break; } if (iter == con.maxiter()) par.set_err(1); } void getJackVar(Vector &beta_i, Vector &alpha_i, Vector &gamma_i, GeeParam &par, int jack) { //jack = 1, 2, 3 for ajs, j1s, fij int I = beta_i.size(), p = par.p(), q = par.q(), r = par.r(); DMatrix vb(p,p), va(q,q), vc(r,r); //cout << par.beta(); for (int i = 1; i <= I; i++) { //cout << "i = " << i << " " << beta_i(i); vb = vb + outerprod(beta_i(i) - par.beta()); //can use level as in gee2_var va = va + outerprod(alpha_i(i) - par.alpha()); vc = vc + outerprod(gamma_i(i) - par.gamma()); } double f = (double) (I - p - q - r) / I; if (jack == 3) {//fij par.set_vbeta_fij(f * vb); par.set_valpha_fij(f * va); par.set_vgamma_fij(f * vc); } else if (jack == 2) { //j1s par.set_vbeta_j1s(f * vb); par.set_valpha_j1s(f * va); par.set_vgamma_j1s(f * vc); } else {//ajs par.set_vbeta_ajs(f * vb); par.set_valpha_ajs(f * va); par.set_vgamma_ajs(f * vc); } } void gee_jack(DVector &Y, DMatrix &Xmat, DVector &Offset, DVector &Doffset, DVector &W, IVector &LinkWave, DMatrix &Zsca, DMatrix &Zcor, DVector &CorP, IVector &Clusz, IVector &ZcorSize, GeeStr &geestr, Corr &cor, GeeParam &par, Control &con) { int I = Clusz.size(); // int p = par.p(), q = par.q(), r = par.r(); IVector Jack(I); Vector beta_i(I), alpha_i(I), gamma_i(I); Vector beta_fi(I), alpha_fi(I), gamma_fi(I); //DVector b0(p), a0(q), c0(r); //beta_i = b0; alpha_i(I) = a0; gamma_i(I) = c0; //beta_fi = b0; alpha_fi(I) = a0; gamma_fi(I) = c0; Control con1(con); con1.set_maxiter(1); //for j1s for (int i = 1; i <= I; i++) { Jack(i) = 1; GeeParam par_i(par.beta(), par.alpha(), par.gamma()); if (con.j1s() == 1) { gee_est(Y, Xmat, Offset, Doffset, W, LinkWave, Zsca, Zcor, CorP, Clusz, ZcorSize, geestr, cor, par_i, Jack, con1); //1-step beta_i(i) = par_i.beta(); alpha_i(i) = par_i.alpha(); gamma_i(i) = par_i.gamma(); } if (con.fij() == 1) { gee_est(Y, Xmat, Offset, Doffset, W, LinkWave, Zsca, Zcor, CorP, Clusz, ZcorSize, geestr, cor, par_i, Jack, con); //full iterated beta_fi(i) = par_i.beta(); alpha_fi(i) = par_i.alpha(); gamma_fi(i) = par_i.gamma(); } Jack(i) = 0; } if (con.j1s() == 1) getJackVar(beta_i, alpha_i, gamma_i, par, 2); if (con.fij() == 1) getJackVar(beta_fi, alpha_fi, gamma_fi, par, 3); } void jack_ajs(DVector &Y, DMatrix &X, DVector &Offset, DVector &Doffset, DVector &W, IVector &LinkWave, DMatrix &Zsca, DMatrix &Zcor, DVector &CorP, IVector &Clusz, IVector &ZcorSize, GeeStr &geestr, Corr &cor, GeeParam &par, Control &con) {//con is not used int I = Clusz.size(), p = par.p(), q = par.q(), r = par.r(); Vector His(I); Vector Gis(I); IVector level = comp_lev(geestr, cor), Scur(Y.size()); Scur = 1; HisandGis(Y, X, Offset, Doffset, W, LinkWave, Clusz, ZcorSize, Zsca, Zcor, CorP, par, geestr, cor, Scur, level, His, Gis); Hess Hn(par); for (int i = 1; i <= I; i++) Hn.inc(His(i)); Vector beta_i(I), alpha_i(I), gamma_i(I); DVector b0(p), a0(q), c0(r); beta_i = b0; alpha_i(I) = a0; gamma_i(I) = c0; DMatrix vb(p,p), va(q,q), vc(r,r); for (int i = 1; i <= I; i++) { Hess H_i = Hn - His(i); H_i = inv(H_i, level); beta_i(i) = H_i.A() * Gis(i).U1(); gamma_i(i) = H_i.B() * Gis(i).U1() + H_i.C() * Gis(i).U2(); alpha_i(i) = H_i.D() * Gis(i).U1() + H_i.E() * Gis(i).U2() + H_i.F() * Gis(i).U3(); vb = vb + outerprod(beta_i(i)); //can use level as in gee2_var va = va + outerprod(alpha_i(i)); vc = vc + outerprod(gamma_i(i)); } double f = (double) (I - p - q - r) / I; par.set_vbeta_ajs(f * vb); par.set_valpha_ajs(f * va); par.set_vgamma_ajs(f * vc); } void gee_top(DVector &Y, DMatrix &Xmat, DVector &Offset, DVector &Doffset, DVector &W, IVector &LinkWave, DMatrix &Zsca, DMatrix &Zcor, DVector &CorP, IVector &Clusz, GeeStr &geestr, Corr &cor, GeeParam &par, Control &con) { int I = Clusz.size(); IVector Jack(I), ZcorSize(I); //initializing ZcorSize //if (cor.nparam() > 1) if (cor.corst() > AR1) // == UNSTRUCTRUED || USERDEFINED || FIXED for (int i = 1; i <= I; i++) ZcorSize(i) = Clusz(i) * (Clusz(i) - 1) / 2; else ZcorSize = 1; gee_est(Y, Xmat, Offset, Doffset, W, LinkWave, Zsca, Zcor, CorP, Clusz, ZcorSize, geestr, cor, par, Jack, con); gee_var(Y, Xmat, Offset, Doffset, W, LinkWave, Zsca, Zcor, CorP, Clusz, ZcorSize, geestr, cor, par, con); if (con.ajs() == 1) jack_ajs(Y, Xmat, Offset, Doffset, W, LinkWave, Zsca, Zcor, CorP, Clusz, ZcorSize, geestr, cor, par, con); if (con.j1s() + con.fij() > 0) gee_jack(Y, Xmat, Offset, Doffset, W, LinkWave, Zsca, Zcor, CorP, Clusz, ZcorSize, geestr, cor, par, con); } extern "C" { SEXP gee_rap(SEXP y, SEXP x, SEXP offset, SEXP doffset, SEXP w, SEXP linkwave, SEXP zsca, SEXP zcor, SEXP corp, SEXP clusz, SEXP geestr, SEXP cor, SEXP par, SEXP con) { DVector Y = asDVector(y), Offset = asDVector(offset), Doffset = asDVector(doffset), W = asDVector(w); IVector LinkWave = asIVector(linkwave); DVector CorP = asDVector(corp); DMatrix X = asDMatrix(x), Zsca = asDMatrix(zsca), Zcor = asDMatrix(zcor); IVector Clusz = asIVector(clusz); // ZcorSize = asIVector(zcorsize); Control Con = asControl(con); GeeParam Par = asGeeParam(par); SEXP geestr_protect; PROTECT(geestr_protect = geestr); GeeStr Geestr = asGeeStr(geestr_protect); UNPROTECT(1); //GeeStr Geestr = asGeeStr(geestr); Corr Cor = asCorr(cor); gee_top(Y, X, Offset, Doffset, W, LinkWave, Zsca, Zcor, CorP, Clusz, Geestr, Cor, Par, Con); SEXP ans = asSEXP(Par); return ans; } /* return the influence functions for parameters */ SEXP infls_rap(SEXP y, SEXP x, SEXP offset, SEXP doffset, SEXP w, SEXP linkwave, SEXP zsca, SEXP zcor, SEXP corp, SEXP clusz, SEXP geestr, SEXP cor, SEXP par, SEXP con) { DVector Y = asDVector(y), Offset = asDVector(offset), Doffset = asDVector(doffset), W = asDVector(w); IVector LinkWave = asIVector(linkwave); DVector CorP = asDVector(corp); DMatrix X = asDMatrix(x), Zsca = asDMatrix(zsca), Zcor = asDMatrix(zcor); IVector Clusz = asIVector(clusz); // ZcorSize = asIVector(zcorsize); Control Con = asControl(con); GeeParam Par = asGeeParam(par); SEXP geestr_protect; PROTECT(geestr_protect = geestr); GeeStr Geestr = asGeeStr(geestr_protect); UNPROTECT(1); //GeeStr Geestr = asGeeStr(geestr); Corr Cor = asCorr(cor); DMatrix infls = gee_infls(Y, X, Offset, Doffset, W, LinkWave, Zsca, Zcor, CorP, Clusz, Geestr, Cor, Par, Con); SEXP ans = asSEXP(infls); return ans; } } geepack/src/utils.cc0000755000176200001440000001104214165262714014120 0ustar liggesusers// using namespace std; #include #include #include "tntsupp.h" #include "geese.h" void VecPrint(const DVector &v) { for (int i = 0; i < v.dim(); i++) Rprintf("%f ", v[i]); Rprintf("\n"); } Fortran_Matrix ident (int n) { Fortran_Matrix ans(n,n); for (int i = 1; i <= n; i++) ans(i,i) = 1.0; return ans; } Fortran_Matrix MatRowCol(const Fortran_Matrix &mat, const Vector &r, const Vector &c) { int m = r.size(), n = c.size(); Fortran_Matrix ans(m,n); for (int i = 1; i <= m; i++) for (int j = 1; j <= n; j++) ans(i,j) = mat((int) r(i), (int) c(j)); return ans; } Fortran_Matrix rho2mat(const Vector &rho) { int s = rho.size(); // s = n(n-1)/2 int n = (int) (0.5 * ( 1 + sqrt(1.0 + 8 * s))); Fortran_Matrix fullmat = ident(n); int k = 1; for (int i = 1; i <= n - 1; i++) for (int j = i + 1; j <= n; j++) { fullmat(i, j) = rho(k++); fullmat(j, i) = fullmat(i, j); } return fullmat; } //solve(a, b = ident(n)) DMatrix solve(const DMatrix &a, const DMatrix &b) { Subscript m = a.dim(1); // assert(m == a.dim(2)); Subscript n = b.dim(1); // assert(m == n); Subscript l = b.dim(2); Vector index(m); DMatrix T(a), B(b); DMatrix ans(n,l); if (LU_factor(T, index) != 0) { // cerr << "LU_factor() failed." << endl; return ans; } DVector v(m); for (int i = 1; i <= l; i++) { v = asVec(MatCol(B,i)); LU_solve(T, index, v); MatCol(ans, i) = asColMat(v); } return ans; } DVector solve(const DMatrix &A, const DVector &b) { DMatrix T(A); Vector index(b.size()); DVector ans(b); if (LU_factor(T, index) !=0) { //cerr << "LU_factor() failed." << endl; return ans; } if (LU_solve(T, index, ans) != 0) { //cerr << "LU_Solve() failed." << endl; return ans; } return ans; } DMatrix solve(const DMatrix &a) { DMatrix b = ident(a.dim(1)); return solve(a, b); } DMatrix AtBiC(const DMatrix &A, const DMatrix &B, const DMatrix &C) { DMatrix BiC = solve(B, C); return Transpose_view(A) * BiC; } DVector AtBiC(const DMatrix &A, const DMatrix &B, const DVector &C) { DVector BiC = solve(B, C); return Transpose_view(A) * BiC; } DMatrix apply_elwise(const DMatrix &x, double f(double)) { DMatrix ans = x; for (int i = 1; i <= x.dim(1); i++) for (int j = 1; j <= x.dim(2); j++) ans(i, j) = f(x(i, j)); return ans; } /* DMatrix apply_elwise(DMatrix &x, double f(double)) { return apply_elwise(x, f); } */ DVector apply_elwise(const DVector &x, double f(double)) { DVector ans = x; for (int i = 1; i <= x.dim(); i++) ans(i) = f(x(i)); return ans; } /* DVector apply_elwise(DVector &x, double f(double)) { return apply_elwise(x, f); } */ DVector sqrt(const DVector &x) { return apply_elwise(x, sqrt); } double square(double x) { return x * x; } DVector square(const DVector &x) { return apply_elwise(x, square); } double reciproot(double x) { return 1./sqrt(x); } DVector reciproot(const DVector &x) { return apply_elwise(x, reciproot); } double recip(double x) {return 1./x;} DVector recip(const DVector &x) { return apply_elwise(x, recip); } int cluscount(DVector &ID) { int ans = 1; for (int i = 1; i < ID.dim(); i++) if (ID(i - 1) != ID(i)) ans++; return ans; } Vector clussize(DVector &ID) { int K = ID.size(); Vector ans(K); ans = 1; //double id = ID(0); int k = 1; for (int i = 1; i <= (ID.dim() - 1); i++) { if (ID(i + 1) == ID(i)) ans(k) += 1; else k++; } return ans; } DVector SMult(const DVector &v1, const DVector &v2) { // assert (v1.dim() == v2.dim()); DVector ans = v1; for (int i = 1; i <= v1.dim(); i++) ans(i) = v1(i) * v2(i); return ans; } DMatrix SMult(const DVector &v, const DMatrix &m) { // assert (v.dim() == m.dim(1)); DMatrix tmp = m; for (int i = 1; i <= m.dim(1); i++) for (int j = 1; j <= m.dim(2); j++) tmp(i, j) = v(i) * m(i, j); return tmp; } DMatrix operator*(const DVector &v, const DMatrix &m) { return SMult(v, m); } DMatrix diag(const DVector &v) { int n = v.dim(); DMatrix ans(n, n); ans = .0; for (int i = 1; i <= n; i++) ans(i, i) = v(i); return ans; } DVector diag(const DMatrix &m) { int n = m.dim(1); //assert m.dim(0) == m.dim(1); DVector ans(n); ans = .0; for (int i = 1; i <= n; i++) ans(i) = m(i,i); return ans; } DMatrix inv(const DMatrix &x) { return solve(x); } DMatrix fabs(const DMatrix &m) { return apply_elwise(m, fabs); } DVector fabs(const DVector &v) { return apply_elwise(v, fabs); } geepack/src/init.c0000644000176200001440000000154014165262714013557 0ustar liggesusers#include #include #include // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .Call calls */ extern SEXP gee_rap(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP infls_rap(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP ordgee_rap(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); static const R_CallMethodDef CallEntries[] = { {"gee_rap", (DL_FUNC) &gee_rap, 14}, {"infls_rap", (DL_FUNC) &infls_rap, 14}, {"ordgee_rap", (DL_FUNC) &ordgee_rap, 14}, {NULL, NULL, 0} }; void R_init_geepack(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } geepack/src/inter.cc0000755000176200001440000001333514165262714014110 0ustar liggesusersusing namespace std; #include "tntsupp.h" #include "geese.h" #include #include #include #include "famstr.h" #include "param.h" #include "inter.h" DMatrix asDMatrix(SEXP a) { double *x; x = NUMERIC_POINTER(AS_NUMERIC(a)); int *dims = INTEGER_POINTER(AS_INTEGER(GET_DIM(a))); DMatrix ans(dims[0], dims[1], x); return ans; } DVector asDVector(SEXP a) { double *x; x = NUMERIC_POINTER(AS_NUMERIC(a)); int len = GET_LENGTH(a); DVector ans(len, x); return ans; } IVector asIVector(SEXP a) { int *x; x = INTEGER_POINTER(AS_INTEGER(a)); int len = GET_LENGTH(a); IVector ans(len, x); return ans; } Vector asVDVector(SEXP a) {//a is a matrix double *x; x = NUMERIC_POINTER(AS_NUMERIC(a)); int *dims = INTEGER_POINTER(AS_INTEGER(GET_DIM(a))); Vector ans(dims[1]); for (int i = 1; i <= ans.size(); i++) { DVector tmp(dims[0], x); ans(i) = tmp; x += dims[0]; } return ans; } SEXP asSEXP(const DMatrix &a) { int size = a.num_cols() * a.num_rows(); SEXP val; PROTECT(val = NEW_NUMERIC(size)); double *p = NUMERIC_POINTER(val); const double *q = a.begin(); for (int i = 0; i < size; i++) p[i] = q[i]; // SET_CLASS(val, ScalarString(mkChar("matrix"))); SEXP dim; PROTECT(dim = NEW_INTEGER(2)); INTEGER(dim)[0] = a.num_rows(); INTEGER(dim)[1] = a.num_cols(); SET_DIM(val, dim); UNPROTECT(2); return val; } SEXP asSEXP(const DVector &a) { int size = a.size(); SEXP val; PROTECT(val = NEW_NUMERIC(size)); double *p = NUMERIC_POINTER(val); const double *q = a.begin(); for (int i = 0; i < size; i++) p[i] = q[i]; // SET_CLASS(val, ScalarString(mkChar("vector"))); SEXP len; PROTECT(len = NEW_INTEGER(1)); INTEGER(len)[0] = size; SET_LENGTH(val, size); UNPROTECT(2); return val; } SEXP asSEXP(const IVector &a) { int size = a.size(); SEXP val; PROTECT(val = NEW_INTEGER(size)); int *p = INTEGER_POINTER(val); const int *q = a.begin(); for (int i = 0; i < size; i++) p[i] = q[i]; // SET_CLASS(val, ScalarString(mkChar("vector"))); SEXP len; PROTECT(len = NEW_INTEGER(1)); INTEGER(len)[0] = size; SET_LENGTH(val, size); UNPROTECT(2); return val; } Control asControl(SEXP con) { //con is a list of trace, jack, j1s, fij, maxiter, epsilon int trace, jack, j1s, fij, maxiter; double tol; trace = INTEGER(VECTOR_ELT(con, 0))[0]; jack = INTEGER(VECTOR_ELT(con, 1))[0]; j1s = INTEGER(VECTOR_ELT(con, 2))[0]; fij = INTEGER(VECTOR_ELT(con, 3))[0]; maxiter = INTEGER(VECTOR_ELT(con, 4))[0]; tol = REAL(VECTOR_ELT(con, 5))[0]; Control Con(trace, jack, j1s, fij, maxiter, tol); return Con; } GeeParam asGeeParam(SEXP par) { //par is a list of beta, alpha, gamma; DVector Beta = asDVector(VECTOR_ELT(par, 0)); DVector Alpha = asDVector(VECTOR_ELT(par, 1)); DVector Gamma = asDVector(VECTOR_ELT(par, 2)); GeeParam Par(Beta, Alpha, Gamma); return Par; } GeeStr asGeeStr(SEXP geestr) { //geestr is a list of maxwave, meanlink, v, scalelink, corrlink, scale.fix; int maxwave = INTEGER(AS_INTEGER(VECTOR_ELT(geestr, 0)))[0]; IVector MeanLink, V, ScaleLink; // FIXME: rchk gives warning here ... //MeanLink = asIVector(AS_INTEGER(VECTOR_ELT(geestr, 1))); //V = asIVector(AS_INTEGER(VECTOR_ELT(geestr, 2))); //ScaleLink = asIVector(AS_INTEGER(VECTOR_ELT(geestr, 3))); // and to here // Attempted fix SEXP ML, VV, SL; PROTECT(ML = AS_INTEGER(VECTOR_ELT(geestr, 1))); PROTECT(VV = AS_INTEGER(VECTOR_ELT(geestr, 2))); PROTECT(SL = AS_INTEGER(VECTOR_ELT(geestr, 3))); MeanLink = asIVector(ML); V = asIVector(VV); ScaleLink = asIVector(SL); // to here int corrlink = INTEGER(AS_INTEGER(VECTOR_ELT(geestr, 4)))[0]; int scalefix = INTEGER(AS_INTEGER(VECTOR_ELT(geestr, 5)))[0]; GeeStr G(maxwave, MeanLink, V, ScaleLink, corrlink, scalefix); UNPROTECT(3); return G; } // GeeStr asGeeStr(SEXP geestr) { // //geestr is a list of maxwave, meanlink, v, scalelink, corrlink, scale.fix; // int maxwave = INTEGER(AS_INTEGER(VECTOR_ELT(geestr, 0)))[0]; // IVector MeanLink = asIVector(AS_INTEGER(VECTOR_ELT(geestr, 1))); // IVector V = asIVector(AS_INTEGER(VECTOR_ELT(geestr, 2))); // IVector ScaleLink = asIVector(AS_INTEGER(VECTOR_ELT(geestr, 3))); // int corrlink = INTEGER(AS_INTEGER(VECTOR_ELT(geestr, 4)))[0]; // int scalefix = INTEGER(AS_INTEGER(VECTOR_ELT(geestr, 5)))[0]; // GeeStr G(maxwave, MeanLink, V, ScaleLink, corrlink, scalefix); // return G; // } Corr asCorr(SEXP cor) { //cor is a list of corst, maxwave int corstr, maxwave; corstr = INTEGER(VECTOR_ELT(cor, 0))[0]; maxwave = INTEGER(VECTOR_ELT(cor, 1))[0]; Corr Cor(corstr, maxwave); return Cor; } SEXP asSEXP(GeeParam &Par) { SEXP ans; PROTECT(ans = NEW_LIST(19)); SET_VECTOR_ELT(ans, 0, asSEXP(Par.beta())); SET_VECTOR_ELT(ans, 1, asSEXP(Par.alpha())); SET_VECTOR_ELT(ans, 2, asSEXP(Par.gamma())); SET_VECTOR_ELT(ans, 3, asSEXP(Par.vbeta())); SET_VECTOR_ELT(ans, 4, asSEXP(Par.valpha())); SET_VECTOR_ELT(ans, 5, asSEXP(Par.vgamma())); SET_VECTOR_ELT(ans, 6, asSEXP(Par.vbeta_naiv())); SET_VECTOR_ELT(ans, 7, asSEXP(Par.valpha_naiv())); SET_VECTOR_ELT(ans, 8, asSEXP(Par.valpha_stab())); SET_VECTOR_ELT(ans, 9, asSEXP(Par.vbeta_ajs())); SET_VECTOR_ELT(ans, 10, asSEXP(Par.valpha_ajs())); SET_VECTOR_ELT(ans, 11, asSEXP(Par.vgamma_ajs())); SET_VECTOR_ELT(ans, 12, asSEXP(Par.vbeta_j1s())); SET_VECTOR_ELT(ans, 13, asSEXP(Par.valpha_j1s())); SET_VECTOR_ELT(ans, 14, asSEXP(Par.vgamma_j1s())); SET_VECTOR_ELT(ans, 15, asSEXP(Par.vbeta_fij())); SET_VECTOR_ELT(ans, 16, asSEXP(Par.valpha_fij())); SET_VECTOR_ELT(ans, 17, asSEXP(Par.vgamma_fij())); IVector Err(1); Err(1) = Par.err(); SET_VECTOR_ELT(ans, 18, asSEXP(Err)); UNPROTECT(1); return ans; } geepack/src/Makevars0000755000176200001440000000005214165262714014144 0ustar liggesusersPKG_CPPFLAGS = -I../inst/include -DNDEBUG geepack/src/ordgee.cc0000755000176200001440000005364614165262714014245 0ustar liggesusers// using namespace std; // #include "tnt/region1d.h" // #include "tntsupp.h" // #include "geese.h" // extern "C"{ // #include // #include // #include // } // #include "famstr.h" // #include "param.h" // #include "inter.h" // #include "utils.h" // #include "geesubs.h" #include "ordgee.h" double odds2p11(double psi, double mu1, double mu2) { if (fabs(psi - 1.0) < .001) return mu1 * mu2; else { double exp1 = 1 + (mu1 + mu2) * ( psi - 1); double s = exp1 * exp1 + 4 * psi * (1 - psi) * mu1 * mu2; s = sqrt(s); return .5 / (psi - 1) * (exp1 - s); } } DMatrix odds2p11(DVector &Psi, DVector &Mu1, DVector &Mu2) { //Psi is c^2 by 1, contains odds ratio in the sequence: 1-1, 1-2, 2-1, 2-2 //which can be viewed as the result of hvec of PSI matrix int c = Mu1.size(), k = 1; DMatrix ans(c, c); for (int i = 1; i <= c; i++) for (int j = 1; j <= c; j++) ans(i, j) = odds2p11(Psi(k++), Mu1(i), Mu2(j)); return ans; } /* get derivative from R function f <- deriv( ~ .5 / (psi - 1) * (1 + (mu1 + mu2) * ( psi - 1) - (((1 + (mu1 + mu2) * ( psi - 1))^ 2 + 4 * psi * (1 - psi) * mu1 * mu2))^.5), c("psi", "mu1", "mu2"), function(psi, mu1, mu2){}) */ double p11_odds(double psi, double mu1, double mu2) { if (fabs(psi - 1.0) < .001) return mu1*mu2*( - (mu1 + mu2) + mu1*mu2 + 1); else { double expr1 = psi - 1.0; double expr2 = .5 / expr1; double expr3 = mu1 + mu2; double expr5 = 1 + expr3 * expr1; double expr7 = 4 * psi; double expr8 = 1 - psi; double expr9 = expr7 * expr8; double expr10 = expr9 * mu1; double expr12 = pow(expr5, 2.0) + expr10 * mu2; double expr14 = expr5 - pow(expr12, 0.5); double expr23 = pow(expr12, -0.5); //double expr33 = 2 * (expr1 * expr5); //.value <- .expr2 * .expr14 double ans = expr2 * (expr3 - 0.5 * ((2 * (expr3 * expr5) + (4 * expr8 - expr7) * mu1 * mu2) * expr23)) - 0.5/pow(expr1, 2.0) * expr14; return ans; } } DVector p11_mu(double psi, double mu1, double mu2) { DVector ans(2); if (fabs(psi - 1.0) < .001) { ans(1) = mu2; ans(2) = mu1; return ans; } double expr1 = psi - 1.0; double expr2 = .5 / expr1; double expr3 = mu1 + mu2; double expr5 = 1 + expr3 * expr1; double expr7 = 4 * psi; double expr8 = 1 - psi; double expr9 = expr7 * expr8; double expr10 = expr9 * mu1; double expr12 = pow(expr5, 2.0) + expr10 * mu2; // double expr14 = expr5 - pow(expr12, 0.5); double expr23 = pow(expr12, -0.5); double expr33 = 2 * (expr1 * expr5); // .grad[, "mu1"] <- .expr2 * (.expr1 - 0.5 * ((.expr33 + .expr9 * mu2) * .expr23)) ans(1) = expr2 * (expr1 - 0.5 * ((expr33 + expr9 * mu2) * expr23)); // .grad[, "mu2"] <- .expr2 * (.expr1 - 0.5 * ((.expr33 + .expr10) * .expr23)) ans(2) = expr2 * (expr1 - 0.5 * ((expr33 + expr10) * expr23)); return ans; } DVector p11_odds(DVector &Psi, DVector &Mu1, DVector &Mu2) { //Mu1 and Mu2 are c x 1, Psi is c^2 x 1 int c = Mu1.size(), k = 1; DVector ans(c * c); for (int i = 1; i <= c; i++) for (int j = 1; j <= c; j++) { ans(k) = p11_odds(Psi(k), Mu1(i), Mu2(j)); //need more attention to the ordering of Mu1 and Mu2, row-major or col-major; this is row major!!! k++; } return ans; } /* DMatrix Vijj(DVector &Mu) { int c = Mu.size(); DMatrix ans(c,c); for (int i = 1; i <= c; i++) for (int j = 1; j <= c; j++) ans(i,j) = Mu(fmax(i, j)) - Mu(i) * Mu(j); return ans; } */ DMatrix Vijj(DVector &Mu, bool rev) { //rev = false: usual cumulated ordering; //rev = true: Heagerty and Zeger (1996) int c = Mu.size(), ij; DMatrix ans(c,c); for (int i = 1; i <= c; i++) for (int j = 1; j <= c; j++) { if (rev) ij = fmax(i, j); else ij = fmin(i, j); ans(i,j) = Mu(ij) - Mu(i) * Mu(j); } return ans; } DMatrix Vijk(DVector &Mu1, DVector &Mu2, DVector &Psi) { //Psi is a c^2 by 1 vector; int c = Mu1.size(); DMatrix ans(c,c); int k = 1; for (int i = 1; i <= c; i++) { for (int j = 1; j <= c; j++) { double psi = Psi(k++); double p11 = odds2p11(psi, Mu1(i), Mu2(j)); ans(i, j) = p11 - Mu1(i) * Mu2(j); } } return ans; } DMatrix getU3_Beta(DVector &Mu1, DVector &Mu2, DVector &Psi, DMatrix &D1, DMatrix &D2, DVector &PR1, DVector &PR2) { int c = Mu1.size(), p = D1.num_cols(); DMatrix ans(c * c, p); int k = 1; for (int i = 1; i <= c; i++) { DMatrix D1i = asMat(MatRow(D1,i)); for (int j = 1; j <= c; j++) { DMatrix D2j = asMat(MatRow(D2,j)); double psi = Psi(k); DVector P11_Mu = p11_mu(psi, Mu1(i), Mu2(j)); P11_Mu(1) = P11_Mu(1) - Mu2(j); P11_Mu(2) = P11_Mu(2) - Mu1(i); //MatRow(ans, k) = P11_Mu(1) * D1i + P11_Mu(2) * D2j; MatRow(ans, k) = (- PR2(j) - P11_Mu(1)) * D1i + (-PR1(i) - P11_Mu(2)) * D2j; k++; } } return ans; } DMatrix ord2V1(DVector &Mu, DVector &Psi, int clusz, bool rev) { //Mu is (ni*c) x 1, Psi is (choose(ni,2)*c^2) * 1 //This function should be named as ord2V1 instead of ord_V1, since it is forming V1 rather than taking derivatives int c = Mu.size() / clusz; DMatrix ans(Mu.size(), Mu.size()); Index1D I(0,0), K(0,0); for (int i = 1; i <= clusz; i++) { I = Index1D(1, c) + I.ubound(); Index1D J = I; DVector Mui = asVec(VecSubs(Mu, I)); ans(I, I) = Vijj(Mui, rev); for (int j = i + 1; j <= clusz; j++) { J = Index1D(1, c) + J.ubound(); DVector Muj = asVec(VecSubs(Mu, J)); K = Index1D(1, c*c) + K.ubound(); DVector Psik = asVec(VecSubs(Psi, K)); ans(I, J) = Vijk(Mui, Muj, Psik); ans(J, I) = ans(I, J); } } return ans; } DMatrix Mu2V1(DVector &Mu, int clusz, bool rev) { int c = Mu.dim() / clusz; DMatrix ans(Mu.dim(), Mu.dim()); ans = .0; Index1D I(0,0); for (int i = 1; i <= clusz; i++) { I = Index1D(1, c) + I.ubound(); DVector Mui = asVec(VecSubs(Mu, I)); ans(I, I) = Vijj(Mui, rev); } return ans; } void ord_prep_beta(DVector &Yi, DMatrix &Xi, DVector &Offseti, DMatrix &Zi, DVector &Ooffseti, int clusz, int c, bool rev, IVector &LinkWavei, GeeParam &par, GeeStr &geestr, Corr &cor, //output DMatrix &Di, DVector &PRi, DMatrix &Vi) { DVector Etai = Xi * par.beta() + Offseti; DVector Mui = geestr.MeanLinkinv(Etai, LinkWavei); DVector Mu_Etai = geestr.MeanMu_eta(Etai, LinkWavei); PRi = Yi - Mui; Di = SMult(Mu_Etai, Xi); if (clusz == 1) Vi = Vijj(Mui, rev); else if (cor.nparam() == 0) Vi = Mu2V1(Mui, clusz, rev); else { //cluster size greater than 1; DVector Psii = geestr.CorrLinkinv(Zi * par.alpha() + Ooffseti); Vi = ord2V1(Mui, Psii, clusz, rev); } } void ord_prep_beta(DVector &Y, DMatrix &X, DVector &Offset, DMatrix &Z, DVector &Ooffset, Index1D &I, Index1D &J, int clusz, int c, bool rev, IVector &LinkWave, GeeParam &par, GeeStr &geestr, Corr &cor, //output DMatrix &Di, DVector &PRi, DMatrix &Vi) { DVector Yi = asVec(VecSubs(Y, I)); DMatrix Xi = asMat(MatRows(X, I)); DVector Offseti = asVec(VecSubs(Offset, I)); IVector LinkWavei = asVec(VecSubs(LinkWave, I)); //cout << "Xi = " << Xi << "par.beta() = " << par.beta(); DVector Etai = Xi * par.beta() + Offseti; DVector Mui = geestr.MeanLinkinv(Etai, LinkWavei); DVector Mu_Etai = geestr.MeanMu_eta(Etai, LinkWavei); PRi = Yi - Mui; Di = SMult(Mu_Etai, Xi); //if (I.lbound() == 1) cout << "Yi = " << Yi << "Xi = " << Xi << "Etai = " << Etai << "Mui = " << Mui; if (clusz == 1) Vi = Vijj(Mui, rev); else if (cor.nparam() == 0) Vi = Mu2V1(Mui, clusz, rev); else { //cluster size greater than 1; DMatrix Zi = asMat(MatRows(Z, J)); DVector Ooffseti = asVec(VecSubs(Ooffset, J)); DVector Psii = geestr.CorrLinkinv(Zi * par.alpha() + Ooffseti); Vi = ord2V1(Mui, Psii, clusz, rev); } } double update_beta(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset, DVector &W, IVector &LinkWave, //DVector &CorP, DMatrix &Z, IVector &Clusz, int c, bool rev, //IVector &ZcorSize, IVector &Jack, GeeParam &par, GeeStr &geestr, Corr &cor) { double del = 0; int p = par.p(), n = Clusz.size(); DMatrix H(p,p); DVector G(p); Index1D I(0,0), J(0,0); for (int i = 1; i <= n; i++) { int s1 = Clusz(i); int s2 = s1 * (s1 - 1) / 2; I = Index1D(1, s1 * c) + I.ubound(); if (s2 > 0) J = Index1D(1, s2 * c * c) + J.ubound(); // cout << "i = " << i << " J.lbound = " << J.lbound() << " J.ubound = " << J.ubound() << endl; DVector PRi(s1 * c); DMatrix Di(s1 * c, p), Vi(s1 * c, s1 * c); DVector Yi = asVec(VecSubs(Y, I)); DMatrix Xi = asMat(MatRows(X, I)); DVector Offseti = asVec(VecSubs(Offset, I)); IVector LinkWavei = asVec(VecSubs(LinkWave, I)); DMatrix Zi; DVector Ooffseti; if (cor.nparam() == 0 || s2 == 0) { Zi = DMatrix(1,1); Ooffseti = DVector(1); } else { Zi = asMat(MatRows(Z, J)); Ooffseti = asVec(VecSubs(Ooffset, J)); } ord_prep_beta(Yi, Xi, Offseti, Zi, Ooffseti, s1, c, rev, LinkWavei, par, geestr, cor, Di, PRi, Vi); //if (i == 1) cout << "PRi = " << PRi << "Di = " << Di << "Vi = " << Vi; DVector rootWi = sqrt(asVec(VecSubs(W, I))); Di = SMult(rootWi, Di); PRi = SMult(rootWi, PRi); H = H + AtBiC(Di, Vi, Di); G = G + AtBiC(Di, Vi, PRi); } DVector Del = solve(H, G); par.set_beta(par.beta() + Del); del = fmax(fabs(Del)); return del; } DVector kronecker(const DVector &v1, const DVector &v2) { int n1 = v1.size(), n2 = v2.size(); DVector ans(n1 * n2); Index1D I(0,0); for (int i = 1; i <= n1; i++) { I = Index1D(1, n2) + I.ubound(); VecSubs(ans, I) = v1(i) * v2; } return ans; } DVector vec(const DMatrix &m) { int r = m.num_rows(), c = m.num_cols(); DVector ans(r * c, m.begin()); return ans; } DVector hvec(const DMatrix &m) { int r = m.num_rows(), c = m.num_cols(), k = 1; DVector ans(r * c); for (int i = 1; i <= r; i++) for (int j = 1; j <= c; j++) ans(k++) = m(i, j); return ans; } DMatrix ESSTijk(DVector &Mu1, DVector &Mu2, DMatrix &P11, int c1, int c3, bool rev) { //P11 is c x c matrix int c = Mu1.size(), c13, c24; if (rev) c13 = fmax(c1, c3); else c13 = fmin(c1, c3); DMatrix ans(c, c); for (int c2 = 1; c2 <= c; c2++) { for (int c4 = c2; c4 <= c; c4++) { if (rev) c24 = fmax(c2, c4); else c24 = fmin(c2, c4); ans(c2, c4) = P11(c13, c24) - P11(c13, c2) * Mu2(c4) - P11(c13, c4) * Mu2(c2) + Mu1(c13) * Mu2(c2) * Mu2(c4) - P11(c1, c24) * Mu1(c3) + P11(c1, c2) * Mu1(c3) * Mu2(c4) + P11(c1, c4) * Mu1(c3) * Mu2(c2) - 3 * Mu1(c1) * Mu1(c3) * Mu2(c2) * Mu2(c4) - P11(c3, c24) * Mu1(c1) + P11(c3, c2) * Mu1(c1) * Mu2(c4) + P11(c3, c4) * Mu1(c1) * Mu2(c2) + Mu1(c1) * Mu1(c3) * Mu2(c24); if (c4 > c2) ans(c4, c2) = ans(c2, c4); } } return ans; } DMatrix ESST(DVector &Mu1, DVector &Mu2, DMatrix &P11, bool rev) { int c = Mu1.size(); DMatrix ans(c*c, c*c); Index1D I(0,0), J(0,0); for (int c1 = 1; c1 <= c; c1++) { J = I; I = Index1D(1, c) + I.ubound(); for (int c3 = c1; c3 <= c; c3++) { J = Index1D(1, c) + J.ubound(); ans(I, J) = ESSTijk(Mu1, Mu2, P11, c1, c3, rev); if (c3 > c1) ans(J, I) = ans(I, J); } } return ans; } void ord_prep_alpha(DVector &PR1, DVector &PR2, //DMatrix &V, DVector &Mu1, DVector &Mu2, //c^2 x 1 c x 1 c x 1 DMatrix &Z, DVector &Ooffset, bool rev, GeeParam &par, GeeStr &geestr, //output DVector &U2, DMatrix &V2, DMatrix &D2) { DVector Zeta = Z * par.alpha() + Ooffset; //Z is C^2 x q; DVector Psi = geestr.CorrLinkinv(Zeta); //cout << "PR1 = " << PR1 << "PR2 = " << PR2; DVector S = kronecker(PR1, PR2); //cout << "S = " << S; DMatrix V = Vijk(Mu1, Mu2, Psi); // cout << "V = " << V; DVector Sigma = hvec(V); U2 = S - Sigma; DVector P11_Odds = p11_odds(Psi, Mu1, Mu2); DVector Odds_Zeta = geestr.CorrMu_eta(Zeta); D2 = SMult(SMult(P11_Odds, Odds_Zeta), Z); //D2 = d V / d alpha = d(P11 - mu1 * mu2) / d alpha = d P11 / d alpha DMatrix P11 = odds2p11(Psi, Mu1, Mu2); V2 = ESST(Mu1, Mu2, P11, rev) - outerprod(Sigma); } double update_alpha(DVector &PR, DVector &Mu, DVector &W, DMatrix &Z, DVector &Ooffset, IVector &Clusz, int c, bool rev, GeeParam &par, GeeStr &geestr, Corr &cor) { double del = 0; int q = par.q(), n = Clusz.size(); if (cor.nparam() == 0) return del; DMatrix H(q,q); DVector G(q); Index1D I(0,0), J(0,0); for (int i = 1; i <= n; i++) { int s1 = Clusz(i); int s2 = s1 * (s1 - 1) / 2; I = Index1D(1, s1 * c) + I.ubound(); if (s2 > 0) J = Index1D(1, s2 * c * c) + J.ubound(); if (s1 == 1) continue; DVector PRi = asVec(VecSubs(PR, I)); DVector Mui = asVec(VecSubs(Mu, I)); DMatrix Zi = asMat(MatRows(Z, J)); DVector Ooffseti = asVec(VecSubs(Ooffset, J)); Index1D K(0,0); for (int j = 1; j <= s1 - 1; j++) { Index1D I1((j - 1) * c + 1, j * c); DVector PR1 = asVec(VecSubs(PRi, I1)); DVector Mu1 = asVec(VecSubs(Mui, I1)); for (int k = j + 1; k <= s1; k++) { Index1D I2((k - 1) * c + 1, k * c); DVector PR2 = asVec(VecSubs(PRi, I2)); DVector Mu2 = asVec(VecSubs(Mui, I2)); K = Index1D(1,c*c) + K.ubound(); DVector Ooffsetijk = asVec(VecSubs(Ooffseti, K)); DMatrix Zijk = asMat(MatRows(Zi, K)); DVector U2(c*c, 1); DMatrix V2(c*c, c*c), D2(c*c, q); //cout << "i = " << i << " j = " << j << " k = " << k; ord_prep_alpha(PR1, PR2, Mu1, Mu2, Zijk, Ooffsetijk, rev, par, geestr, U2, V2, D2); //if (i == 1) cout << "U2 = " << U2 << "D2 = " << D2 << "V2 = "<< V2; H = H + AtBiC(D2, V2, D2); //cout << " AtBiC(D2, V2, D2) = " << AtBiC(D2, V2, D2); //if (i == 37) cout << "V2 = "<< V2; G = G + AtBiC(D2, V2, U2); } } } //cout << "H = " << H; DVector Del = solve(H, G); par.set_alpha(par.alpha() + Del); del = fmax(fabs(Del)); return del; } /* the following estimation procedure assumed that each cluster has size at least 1. Nov. 6, 2002. */ void ordgee_est(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset, DVector &W, IVector &LinkWave, DMatrix &Z, IVector &Clusz, int c, bool rev, GeeStr &geestr, Corr &cor, GeeParam &par, Control &con) { DVector Del(3); Del = 0.0; int N = Y.size(); // N = sum(n_i) * c; DVector PR(N), Mu(N); int iter; double del; for (iter = 0; iter < con.maxiter(); iter++) { if (con.trace() == 1) { //cerr << "iter " << iter << endl; //cerr << "beta = " << par.beta() << "gamma = " << par.gamma() << "alpha = " << par.alpha(); Rprintf("iter = %d\n", iter); Rprintf("beta = "); VecPrint(par.beta()); Rprintf("gamma = "); VecPrint(par.gamma()); Rprintf("alpha = "); VecPrint(par.alpha()); } //updating beta; Del(1) = update_beta(Y, X, Offset, Ooffset, W, LinkWave, Z, Clusz, c, rev, par, geestr, cor); //no updating gamma; //updating alpha; Mu = geestr.MeanLinkinv(X * par.beta() + Offset, LinkWave); PR = Y - Mu; Del(3) = update_alpha(PR, Mu, W, Z, Ooffset, Clusz, c, rev, par, geestr, cor); del = fmax(Del); if (del <= con.tol()) break; } if (iter == con.maxiter()) par.set_err(1); } void HiandGi(DVector &Yi, DMatrix &Xi, DVector &Offseti, DVector &Ooffseti, IVector &LinkWavei, DMatrix &Zi, int s1, int c, bool rev, //Index1D &I, Index1D &J, GeeParam &par, GeeStr &geestr, Corr &cor, //output Hess &Hi, Grad &Gi) { //need D1, V1, U1, D2, V2, U2, Sig_Beta for H and G int p = par.p(), q = par.q(); DVector PRi(s1 * c); DMatrix D1i(s1 * c, p), V1i(s1 * c, s1 * c); ord_prep_beta(Yi, Xi, Offseti, Zi, Ooffseti, s1, c, rev, LinkWavei, par, geestr, cor, D1i, PRi, V1i); Hi.set_A(AtBiC(D1i, V1i, D1i)); Gi.set_U1(AtBiC(D1i, V1i, PRi)); if (s1 == 1) return; if (cor.nparam() == 0) return; DVector Mui = Yi - PRi; Index1D K(0,0); for (int j = 1; j <= s1 - 1; j++) { Index1D I1((j - 1) * c + 1, j * c); DVector PR1 = asVec(VecSubs(PRi, I1)); DVector Mu1 = asVec(VecSubs(Mui, I1)); DMatrix D1j = asMat(MatRows(D1i, I1)); for (int k = j + 1; k <= s1; k++) { Index1D I2((k - 1) * c + 1, k * c); DVector PR2 = asVec(VecSubs(PRi, I2)); DVector Mu2 = asVec(VecSubs(Mui, I2)); DMatrix D1k = asMat(MatRows(D1i, I2)); K = Index1D(1,c*c) + K.ubound(); DVector Ooffsetijk = asVec(VecSubs(Ooffseti, K)); DMatrix Zijk = asMat(MatRows(Zi, K)); DVector U3i(c*c, 1); DMatrix V3i(c*c, c*c), D3i(c*c, q); ord_prep_alpha(PR1, PR2, Mu1, Mu2, Zijk, Ooffsetijk, rev, par, geestr, U3i, V3i, D3i); Hi.inc_F(AtBiC(D3i, V3i, D3i)); Gi.set_U3(Gi.U3() + AtBiC(D3i, V3i, U3i)); DVector Zeta = Zi * par.alpha() + Ooffseti; //Z is C^2 x q; DVector Psi = geestr.CorrLinkinv(Zeta); DMatrix U3_Beta = getU3_Beta(Mu1, Mu2, Psi, D1j, D1k, PR1, PR2); Hi.inc_D(AtBiC(D3i, V3i, -1.0 * U3_Beta)); } } } void HnandGis(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset, IVector &LinkWave, DMatrix &Z, IVector &Clusz, int c, bool rev, GeeParam &par, GeeStr &geestr, Corr &cor, Hess &Hn, Vector &Gis) { // Hess H(par), Hi(par); Grad Gi(par); // Index1D I(0,0), J(0,0); // int N = Clusz.size(); // for (int i = 1; i <= N; i++) { // int s1 = Clusz(i); // int s2 = s1 * (s1 - 1) / 2; // I = Index1D(1, s1 * c) + I.ubound(); // if (s2 > 0) J = Index1D(1, s2 * c * c) + J.ubound(); // Hess Hi(par); Grad Gi(par); // HiandGi(Y, X, Offset, Ooffset, LinkWave, Z, s1, c, I, J, // par, geestr, cor, Hi, Gi); // H.inc(Hi); Gis(i) = Gi; // } // Hn = (1.0/(double) N) * H; IVector Scur(Y.size() / c); Scur = 1; HnandGis(Y, X, Offset, Ooffset, LinkWave, Z, Clusz, c, rev, par, geestr, cor, Scur, Hn, Gis); } void HnandGis(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset, IVector &LinkWave, DMatrix &Z, IVector &Clusz, int c, bool rev, GeeParam &par, GeeStr &geestr, Corr &cor, IVector &Scur, Hess &Hn, Vector &Gis) { Hess H(par), Hi(par); Grad Gi(par); Index1D I(0,0), J(0,0), K(0,0); int N = Clusz.size(); for (int i = 1; i <= N; i++) { int s1 = Clusz(i); int s2 = s1 * (s1 - 1) / 2; K = Index1D(1, s1) + K.ubound(); I = Index1D(1, s1 * c) + I.ubound(); if (s2 > 0) J = Index1D(1, s2 * c * c) + J.ubound(); IVector Scuri = asVec(VecSubs(Scur, K)); int clsz = sum(Scuri); //this is the new cluster size that should be passed down!!!!!!! if (clsz == 0) continue; //get dat i DVector Yi = asVec(VecSubs(Y, I)); DMatrix Xi = asMat(MatRows(X, I)); DVector Offseti = asVec(VecSubs(Offset, I)); IVector LinkWavei = asVec(VecSubs(LinkWave, I)); DMatrix Zi; DVector Ooffseti; if (cor.nparam() == 0 || s2 == 0) { Zi = DMatrix(1,1); Ooffseti = DVector(1); } else { Zi = asMat(MatRows(Z, J)); Ooffseti = asVec(VecSubs(Ooffset, J)); } //valid data i IVector VI = genVI(Scuri, c), VJ = genCrossVI(Scuri, c); DVector VYi = Valid(Yi, VI), VOffseti = Valid(Offseti, VI); IVector VLinkWavei = Valid(LinkWavei, VI); DMatrix VXi = Valid(Xi, VI); DMatrix VZi; DVector VOoffseti; if (cor.nparam() == 0 || clsz == 1) {//clsz == 1: no need to go association VZi = DMatrix(1,1); VOoffseti = DVector(1); } else { VZi = Valid(Zi, VJ); VOoffseti = Valid(Ooffseti, VJ); } Hess Hi(par); Grad Gi(par); HiandGi(VYi, VXi, VOffseti, VOoffseti, VLinkWavei, VZi, clsz, c, rev, par, geestr, cor, Hi, Gi); H.inc(Hi); Gis(i) = Gi; } Hn = (1.0/(double) N) * H; } void ordgee_var(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset, DVector &W, IVector &LinkWave, DMatrix &Z, IVector &Clusz, int c, bool rev, GeeStr &geestr, Corr &cor, GeeParam &par) { int N = Clusz.size(), p = par.p(), q = par.q(); Hess Hn(par); Vector Gis(N); Grad G0(par); Gis = G0; HnandGis(Y, X, Offset, Ooffset, LinkWave, Z, Clusz, c, rev, par, geestr, cor, Hn, Gis); IVector level(2); level(2) = 1; Hess Hinv = inv(Hn, level); Vector Beta_infs(N), Alpha_infs(N); DMatrix VB(p,p), VA(q,q); for (int i = 1; i <= N; i++) { Beta_infs(i) = Hinv.A() * Gis(i).U1(); VB = VB + outerprod(Beta_infs(i)); if (cor.nparam() == 0) continue; Alpha_infs(i) = Hinv.D() * Gis(i).U1() + Hinv.F() * Gis(i).U3(); VA = VA + outerprod(Alpha_infs(i)); } par.set_vbeta_naiv(1.0/N * Hinv.A()); par.set_vbeta(1.0/N/N * VB); if (cor.nparam() == 0) return; //only those cluster with size 2 or more contributes to the variance of alpha //int Nalp = 0; //for (int i = 1; i <= N; i++) if (Clusz(i) > 1) Nalp++; par.set_valpha_naiv(1.0/N * Hinv.F()); //par.set_valpha(1.0/Nalp/Nalp * VA); par.set_valpha(1.0/N/N * VA); } void ordgee_top(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset, DVector &W, IVector &LinkWave, DMatrix &Z, IVector &Clusz, int c, bool rev, GeeStr &geestr, Corr &cor, GeeParam &par, Control &con) { ordgee_est(Y, X, Offset, Ooffset, W, LinkWave, Z, Clusz, c, rev, geestr, cor, par, con); ordgee_var(Y, X, Offset, Ooffset, W, LinkWave, Z, Clusz, c, rev, geestr, cor, par); } extern "C" { SEXP ordgee_rap(SEXP y, SEXP x, SEXP offset, SEXP doffset, SEXP w, SEXP linkwave, SEXP z, SEXP clusz, SEXP ncat, SEXP rev, SEXP geestr, SEXP cor, SEXP par, SEXP con) { DVector Y = asDVector(y), Offset = asDVector(offset), Doffset = asDVector(doffset), W = asDVector(w); IVector LinkWave = asIVector(linkwave); DMatrix X = asDMatrix(x), Z = asDMatrix(z); IVector Clusz = asIVector(clusz); int C = INTEGER(AS_INTEGER(ncat))[0]; bool Rev = LOGICAL(AS_LOGICAL(rev))[0]; Control Con = asControl(con); GeeParam Par = asGeeParam(par); SEXP geestr_protect; PROTECT(geestr_protect = geestr); GeeStr Geestr = asGeeStr(geestr_protect); UNPROTECT(1); //GeeStr Geestr = asGeeStr(geestr); Corr Cor = asCorr(cor); ordgee_top(Y, X, Offset, Doffset, W, LinkWave, Z, Clusz, C, Rev, Geestr, Cor, Par, Con); SEXP ans = asSEXP(Par); return ans; } } geepack/src/famstr.cc0000755000176200001440000002641514165262714014266 0ustar liggesusersusing namespace std; #include "tntsupp.h" #include "geese.h" #include "utils.h" #include "famstr.h" #include #include /* typedef double fun1(double); typedef double fun2(double, int); DVector Apply_elt(const DVector &V, fun1* f) { DVector ans(V.size()); for (int i = 1; i <= V.size(); i++) ans(i) = f(V(i)); return ans; } DVector Apply_elt(const DVector &V, const DVector &Wave, fun2* f) { DVector ans(V.size()); for (int i = 1; i <= V.size(); i++) ans(i) = f(V(i), (int)Wave(i)); return ans; } */ /* double dnorm(double x) {return dnorm4(x, 0, 1, 0);} double pnorm(double x) {return pnorm5(x, 0, 1, 1, 0);} double qnorm(double x) {return qnorm5(x, 0, 1, 1, 0);} */ //link functions // logit double linkfun_logit(double mu) {return log(mu/(1 - mu));} double linkinv_logit(double eta) { double thres = - log(DBL_EPSILON); eta = (eta > thres) ? thres : eta; eta = (eta < - thres) ? -thres : eta; return exp(eta)/(1 + exp(eta)); } double mu_eta_logit(double eta) { double thres = - log(DBL_EPSILON); if (fabs(eta) >= thres) return DBL_EPSILON; else return exp(eta)/pow(1 + exp(eta), 2); } bool valideta_logit(double eta) {return true;} //probit double linkfun_probit(double mu) {return qnorm(mu,0,1,1,0);} double linkinv_probit(double eta) { double thres = -qnorm(DBL_EPSILON,0,1,1,0); eta = min(thres, max(eta, -thres)); return pnorm(eta,0,1,1,0); } double mu_eta_probit(double eta) { return max(dnorm(eta,0,1,0), DBL_EPSILON); } bool valideta_probit(double eta) {return true;} //cloglog double linkfun_cloglog(double mu) {return log(-log(1 - mu));} double linkinv_cloglog(double eta) { double ans = 1 - exp(- exp(eta)); ans = min(1 - DBL_EPSILON, ans); return max(DBL_EPSILON, ans); } double mu_eta_cloglog(double eta) { eta = min(eta, 700.0); return max(DBL_EPSILON, exp(eta) * exp(-exp(eta))); } bool valideta_cloglog(double eta) {return true;} //ident double linkfun_ident(double mu) {return mu;} double linkinv_ident(double eta) {return eta;} double mu_eta_ident(double eta) {return 1.0;} bool valideta_ident(double eta) {return true;} //log double linkfun_log(double mu) {return log(mu);} double linkinv_log(double eta) {return max(DBL_EPSILON, exp(eta));} double mu_eta_log(double eta) {return max(DBL_EPSILON, exp(eta));} bool valideta_log(double eta) {return true;} //sqrt double linkfun_sqrt(double mu) {return sqrt(mu);} double inkinv_sqrt(double eta) {return eta * eta;} double mu_eta_sqrt(double eta) {return 2 * eta;} bool valideta_sqrt(double eta) {return eta > 0;} //recipsquare double linkfun_recipsquare(double mu) {return 1 / mu / mu;} double linkinv_recipsquare(double eta) {return 1 / sqrt(eta);} double mu_eta_recipsquare(double eta) {return -1 / (2 * pow(eta, 1.5));} bool valideta_recipsquare(double eta) {return eta > 0;} //inverse double linkfun_inverse(double mu) {return 1 / mu;} double linkinv_inverse(double eta) {return 1 / eta;} double mu_eta_inverse(double eta) {return -1 / eta / eta;} bool valideta_inverse(double eta) {return eta != 0;} //fisherz double linkfun_fisherz(double mu) {return log(2/(1 - mu) - 1);} double linkinv_fisherz(double eta) { double thres = - log(DBL_EPSILON); eta = (eta > thres) ? thres : eta; eta = (eta < - thres) ? -thres : eta; return 1 - 2 / (exp(eta) + 1); } double mu_eta_fisherz(double eta) { double thres = - log(DBL_EPSILON); if (fabs(eta) >= thres) return DBL_EPSILON; return 2 * exp(eta) / pow(1 + exp(eta), 2); } bool valideta_fisherz(double eta) {return true;} //Lin, Wei, Ying double linkfun_lwyBC2(double mu) { return log(sqrt(mu + 1) - 1); } double linkinv_lwyBC2(double eta) { double foo = max(DBL_EPSILON, exp(eta)); return pow(1 + foo, 2.0) - 1; } double mu_eta_lwyBC2(double eta) { double foo = exp(eta); return max(DBL_EPSILON, 2 * (1 + foo) * foo); } double linkfun_lwylog(double mu) { return log(exp(mu) - 1); } double linkinv_lwylog(double eta) { return log(exp(eta) + 1); } double mu_eta_lwylog(double eta) { double foo = exp(eta); return foo/(foo + 1); } //variance functions double variance_binomial(double mu) {return mu * (1 - mu);} double v_mu_binomial(double mu) {return 1 - 2 * mu;} bool validmu_binomial(double mu) {return mu > 0 && mu < 1;} double variance_gaussian(double mu) {return 1.0;} double v_mu_gaussian(double mu) {return .0;} bool validmu_gaussian(double mu) {return true;} double variance_poisson(double mu) {return mu;} double v_mu_poisson(double mu) {return 1.0;} bool validmu_poisson(double mu) {return mu > 0;} double variance_inverse_gaussian(double mu) {return pow(mu, 3);} double v_mu_inverse_gaussian(double mu) {return 3 * mu * mu;} bool validmu_inverse_gaussian(double mu) {return true;} double variance_Gamma(double mu) {return mu * mu;} double v_mu_Gamma(double mu) {return 2 * mu;} bool validmu_Gamma(double mu) {return mu > 0;} DMatrix cor_exch(const DVector &rho, const DVector &wave) { int n = wave.size(); DMatrix ans(n,n); for (int i = 1; i <= n; i++) for (int j = 1; j <= n; j++) ans(i,j) = (i == j) ? 1.0 : rho(1); return ans; } DMatrix cor_rho_exch(const DVector &rho, const DVector &wave) { int n = wave.size(); DMatrix ans(n * (n - 1) / 2, 1); ans = 1.0; return ans; } DMatrix cor_indep(const DVector &, const DVector &wave) { return ident(wave.size()); } DMatrix cor_rho_indep(const DVector &, const DVector &) { return ident(0); } DMatrix cor_fixed(const DVector &rho, const DVector &wave) { return cor_unstr(rho, wave); } DMatrix cor_rho_fixed(const DVector &, const DVector &) { return ident(0); } DMatrix cor_ar1(const DVector &rho, const DVector &wave) { int n = wave.size(); DMatrix ans(n,n); for (int i = 1; i <= n; i++) for (int j = 1; j <= n; j++) ans(i,j) = (i == j) ? 1.0 : pow(rho(1), fabs(wave(j) - wave(i))); return ans; } DMatrix cor_rho_ar1(const DVector &rho, const DVector &wave) { int n = wave.size(); DMatrix ans(n * (n - 1) / 2, 1); int k = 1; for (int i = 1; i <= n - 1; i++) { for (int j = i + 1; j <= n; j ++) { double tmp = fabs(wave(j) - wave(i)); ans(k, 1) = (tmp == 1.0) ? 1.0 : (tmp * pow(rho(1), tmp - 1.0)); k++; } } return ans; } DMatrix cor_unstr(const DVector &rho, const DVector &wave) { DMatrix fullmat = rho2mat(rho); return MatRowCol(fullmat, wave, wave); } DMatrix cor_rho_unstr(const DVector &rho, const DVector &wave) { int n = wave.size(); return ident(n * (n - 1) / 2); } //class Corr Corr:: Corr(int corst, int maxwave): _corst(corst), _maxwave(maxwave) { switch(corst) { case INDEPENDENCE: _nparam = 0; init(cor_indep, cor_rho_indep); break; case EXCHANGEABLE: _nparam = 1; init(cor_exch, cor_rho_exch); break; case AR1: _nparam = 1; init(cor_ar1, cor_rho_ar1); break; case UNSTRUCTURED: case USERDEFINED: _nparam = maxwave; init(cor_unstr, cor_rho_unstr); break; case FIXED: _nparam = 0; init(cor_fixed, cor_rho_fixed); break; } } //class Link //Link::Link() { Link(IDENT); } //Link::Link(int link) { Link::Link(int link) { switch(link) { case LOGIT: init(linkfun_logit, linkinv_logit, mu_eta_logit); break; case IDENT: init(linkfun_ident, linkinv_ident, mu_eta_ident); break; case PROBIT: init(linkfun_probit, linkinv_probit, mu_eta_probit); break; case CLOGLOG: init(linkfun_cloglog, linkinv_cloglog, mu_eta_cloglog); break; case LOG: init(linkfun_log, linkinv_log, mu_eta_log); break; case INVERSE: init(linkfun_inverse, linkinv_inverse, mu_eta_inverse); break; case FISHERZ: init(linkfun_fisherz, linkinv_fisherz, mu_eta_fisherz); break; case LWYBC2: init(linkfun_lwyBC2, linkinv_lwyBC2, mu_eta_lwyBC2); break; case LWYLOG: init(linkfun_lwylog, linkinv_lwylog, mu_eta_lwylog); break; } } Link::Link(fun1* linkfun, fun1* linkinv, fun1* mu_eta) { init(linkfun, linkinv, mu_eta); } //class Variance //Variance::Variance() {Variance(GAUSSIAN); } Variance::Variance(int var) { //Variance::Variance(int var) { switch(var) { case GAUSSIAN: init(variance_gaussian, v_mu_gaussian, validmu_gaussian); break; case BINOMIAL: init(variance_binomial, v_mu_binomial, validmu_binomial); break; case POISSON: init(variance_poisson, v_mu_poisson, validmu_poisson); break; case GAMMA: init(variance_Gamma, v_mu_Gamma, validmu_Gamma); break; } } //class GeeStr GeeStr::GeeStr(int n, Vector meanlink, Vector v, Vector scalelink, int corrlink, int scalefix) : CorrLink(corrlink), ScaleFix_(scalefix) { //int n = meanlink.size(); //MeanLink.newsize(n); V.newsize(n); ScaleLink.newsize(n); Vector ML(n), SL(n); Vector VS(n); for (int i = 1; i <= n; i++) { Link ml(meanlink(i)), sl(scalelink(i)); Variance vi(v(i)); ML(i) = ml; //MeanLink(i) = LINK[meanlink(i) - 1]; VS(i) = vi; //V(i) = VARIANCE[v(i) - 1]; SL(i) = sl; //ScaleLink(i) = LINK[scalelink(i) - 1]; } MeanLink = ML; V = VS; ScaleLink = SL; } DVector GeeStr::MeanLinkfun(const DVector &Mu, const IVector &Wave) { int size = Mu.size(); DVector ans(size); for (int i = 1; i <= size; i++) ans(i) = MeanLink(Wave(i)).linkfun(Mu(i)); return ans; } DVector GeeStr::MeanLinkinv(const DVector &Eta, const IVector &Wave) { int size = Eta.size(); DVector ans(size); for (int i = 1; i <= size; i++) ans(i) = MeanLink(Wave(i)).linkinv(Eta(i)); return ans; } DVector GeeStr::MeanMu_eta(const DVector &Eta, const IVector &Wave) { int size = Eta.size(); DVector ans(size); for (int i = 1; i <= size; i++) ans(i) = MeanLink(Wave(i)).mu_eta(Eta(i)); return ans; } DVector GeeStr::ScaleLinkfun(const DVector &Mu, const IVector &Wave) { int size = Mu.size(); DVector ans(size); for (int i = 1; i <= size; i++) ans(i) = ScaleLink(Wave(i)).linkfun(Mu(i)); return ans; } DVector GeeStr::ScaleLinkinv(const DVector &Eta, const IVector &Wave) { int size = Eta.size(); DVector ans(size); for (int i = 1; i <= size; i++) ans(i) = ScaleLink(Wave(i)).linkinv(Eta(i)); return ans; } DVector GeeStr::ScaleMu_eta(const DVector &Eta, const IVector &Wave) { int size = Eta.size(); DVector ans(size); for (int i = 1; i <= size; i++) ans(i) = ScaleLink(Wave(i)).mu_eta(Eta(i)); return ans; } DVector GeeStr::CorrLinkfun(const DVector &Mu) { int size = Mu.size(); DVector ans(size); for (int i = 1; i <= size; i++) ans(i) = CorrLink.linkfun(Mu(i)); return ans; } DVector GeeStr::CorrLinkinv(const DVector &Eta) { int size = Eta.size(); DVector ans(size); for (int i = 1; i <= size; i++) ans(i) = CorrLink.linkinv(Eta(i)); return ans; } DVector GeeStr::CorrMu_eta(const DVector &Eta) { int size = Eta.size(); DVector ans(size); for (int i = 1; i <= size; i++) ans(i) = CorrLink.mu_eta(Eta(i)); return ans; } DVector GeeStr::v(const DVector &Mu, const IVector &Wave) { int size = Mu.size(); DVector ans(size); for (int i = 1; i <= size; i++) ans(i) = V(Wave(i)).v(Mu(i)); return ans; } DVector GeeStr::v_mu(const DVector &Mu, const IVector &Wave) { int size = Mu.size(); DVector ans(size); for (int i = 1; i <= size; i++) ans(i) = V(Wave(i)).v_mu(Mu(i)); return ans; } bool GeeStr::validMu(const DVector &Mu, const IVector &Wave) { int size = Mu.size(); bool ans = true; for (int i = 1; i <= size; i++) { if ( !( V(Wave(i)).validmu(Mu(i)) ) ) { ans = false; break; } } return ans; } geepack/src/geesubs.cc0000755000176200001440000004176014165262714014427 0ustar liggesusers// Sep. 17, 2012: // workaround since it does not compile otherwise --- Thank B. Ripley // I spent hours but could not figure out why it would not work // without this undef. Should keep it in mind. // Jan. 26, 2012: // This line is commented out to remove NOTE of assert // from R CMD check, as suggested by K. Hornik and B. Ripley. // #undef NDEBUG using namespace std; #include "tntsupp.h" #include "geese.h" #include "famstr.h" #include "param.h" #include "geesubs.h" #include "utils.h" #include "inter.h" //#include "lgtdl.h" //#include "fgee.h" /*******************************************************************/ Grad & Grad::operator=(const Grad &G) { U1_ = G.U1_; U2_ = G.U2_; U3_ = G.U3_; return *this; } ostream& operator<<(ostream& s, const Grad &G) { s << "U1 = " << G.U1() << "U2 = " << G.U2() << "U3 = " << G.U3(); return s; } Hess operator-(Hess &H1, Hess &H2) { Hess ans(H1); ans.dec(H2); return ans; } Hess inv(Hess &H, IVector &level) { Hess ans(H); ans.set_A(inv(H.A())); if (level(1) == 1) { ans.set_C(inv(H.C())); ans.set_B(-1.0 * ans.C() * H.B() * ans.A()); } if (level(2) == 1) { ans.set_F(inv(H.F())); ans.set_E(-1.0 * ans.F() * H.E() * ans.C()); ans.set_D(-1.0 * ans.F() * (H.D() * ans.A() + H.E() * ans.B())); } return ans; } Hess operator*(const double &x, const Hess &H) { Hess ans(H); ans.set_A(x * H.A()); ans.set_B(x * H.B()); ans.set_C(x * H.C()); ans.set_D(x * H.D()); ans.set_E(x * H.E()); ans.set_F(x * H.F()); return ans; } ostream& operator<<(ostream& s, const Hess &H) { s << "A = " << H.A() << "B = " << H.B() << "C = " << H.C() << "D = " << H.D()<< "E = " << H.E() << "F = " << H.F(); return s; } DVector genzi(const DVector &PR) { int n = PR.size(); DVector ans(n * (n - 1)/2); int k = 1; for (int i = 1; i <= n - 1; i++) for (int j = i + 1; j <= n; j++) ans(k++) = PR(i) * PR(j); return ans; } DVector utri(const DMatrix &R) { int n = R.dim(1); //assert (n > 1); DVector ans(n * (n - 1) / 2); int k = 1; for (int i = 1; i <= n - 1; i++) for (int j = i + 1; j <= n; j++) ans(k++) = R(i,j); return ans; } DMatrix getZ_Beta(DMatrix &D, DVector &PR, DVector &V, DVector &V_Mu, DVector &z) { //note: this is the version which excludes phi in the formula DMatrix ans(z.size(), D.dim(2)); int k = 1, n = PR.size(); for (int i = 1; i <= n - 1; i++) { DMatrix Di = asMat(MatRow(D,i)); for (int j = i + 1; j <= n; j++) { DMatrix Dj = asMat(MatRow(D,j)); DMatrix foo = V_Mu(i) * reciproot(V(i)) * Di + V_Mu(j) * reciproot(V(j)) * Dj; DMatrix bar = - PR(i) * Di - PR(j) * Dj - 0.5 * PR(i) * PR(j) * foo; //cout << "bar = " << bar << "k = " << k; MatRow(ans, k) = bar; //cout << " ans = " << ans; k++; } } return ans; } DMatrix getZ_Gamma(DMatrix &D, DVector &PR, DVector &Phi, DVector &z) { DMatrix ans(z.size(), D.dim(2)); int k = 1, n = PR.size(); for (int i = 1; i <= n - 1; i++) { DMatrix Di = asMat(MatRow(D,i)); for (int j = i + 1; j <= n; j++) { DMatrix Dj = asMat(MatRow(D,j)); //MatRow(ans, k) = -0.5 * z(k) * (sqrt(Phi(j)/Phi(i)) * Di + //sqrt(Phi(i)/Phi(j)) * Dj); //This has caused the scale problem; The first time, scale problem was caused by operator * for Hess, where one component did not get touched, in the old geese (LAPACK); MatRow(ans, k) = -0.5 * z(k) * (1.0 / Phi(i) * Di + 1.0 / Phi(j) * Dj); k++; } } return ans; } DMatrix getS_Beta(DMatrix &D, DVector &PR, DVector &V, DVector &V_Mu) { DMatrix ans(D); for (int i = 1; i <= ans.dim(1); i++) { DMatrix Di = asMat(MatRow(D,i)); double f = -2 * PR(i) / sqrt(V(i)) - PR(i) * PR(i)/V(i) * V_Mu(i); MatRow(ans, i) = f * Di; } return ans; } void HiandGi(DVector &PRi, DVector &Phii, DMatrix &Di, DMatrix &R, DVector &Vi, DVector &V_Mui, DMatrix &D2i, DMatrix &E, DVector &Wi, IVector &level, //output Hess &H, Grad &G) { int s = PRi.size(); //beta DVector rootPhii = sqrt(Phii); DMatrix V1 = diag(rootPhii) * R * diag(rootPhii); DVector rootWi = sqrt(Wi); DMatrix rootWD = SMult(rootWi, Di); DVector rootWPR = SMult(rootWi, PRi); H.set_A(AtBiC(rootWD, V1, rootWD)); G.set_U1(AtBiC(rootWD, V1, rootWPR)); //H.set_A(AtBiC(Di, V1, Di)); //G.set_U1(AtBiC(Di, V1, PRi)); //gamma if (level(1) == 1) {//if (par.ScaleFix() != 1) { DVector Si = square(PRi); DVector WiV2inv = SMult(Wi, recip(2.0 * Phii)); H.set_C(Transpose_view(D2i) * SMult(WiV2inv, D2i)); DMatrix S_Beta = getS_Beta(Di, PRi, Vi, V_Mui); H.set_B(Transpose_view(D2i) * SMult(-1.0 * WiV2inv, S_Beta)); G.set_U2(Transpose_view(D2i) * SMult(WiV2inv, Si - Phii)); //DMatrix V2 = diag(2.0 * Phii); //H.set_C(AtBiC(D2i, V2, D2i)); //DMatrix S_Beta = getS_Beta(Di, PRi, Vi, V_Mui); //H.set_B(AtBiC(D2i, V2, S_Beta)); //G.set_U2(AtBiC(D2i, V2, S - Phii)); } //alpha if (level(2) == 1) {//if (cor.nparam() > 0) { if (s == 1) return; DVector sPRi = SMult(reciproot(Phii), PRi); DVector zi = genzi(sPRi); DVector rhoi = utri(R); //DMatrix W = ident(s * (s - 1) / 2); DVector Sca = genzi(reciproot(Phii)); DVector WiV3inv = genzi(Wi); //H.set_F(AtBiC(E, W, E)); H.set_F(Transpose_view(E) * SMult(WiV3inv, E)); DMatrix Z_Beta = getZ_Beta(Di, PRi, Vi, V_Mui, zi); Z_Beta = SMult(Sca, Z_Beta); //H.set_D(AtBiC(E, W, Z_Beta)); H.set_D(Transpose_view(E) * SMult(-1.0 * WiV3inv, Z_Beta)); //G.set_U3(AtBiC(E, W, zi - rhoi)); G.set_U3(Transpose_view(E) * SMult(WiV3inv, zi - rhoi)); if (level(1) == 1) {//if (par.ScaleFix() != 1) { DMatrix Z_Gamma = getZ_Gamma(D2i, PRi, Phii, zi); //H.set_E(AtBiC(E, W, Z_Gamma)); H.set_E(Transpose_view(E) * SMult(-1.0 * WiV3inv, Z_Gamma)); } } } void PRandD(DVector &Yi, DMatrix &Xi, DVector &Offseti, IVector &Wavei, GeeParam &par, GeeStr &geestr, DVector &PRi, DMatrix &Di) { DVector Eta = Xi * par.beta() + Offseti; DVector Mu = geestr.MeanLinkinv(Eta, Wavei); DVector V = geestr.v(Mu, Wavei); DVector Mu_Eta = geestr.MeanMu_eta(Eta, Wavei); DVector InvRootV = reciproot(V); Di = SMult(InvRootV, SMult(Mu_Eta, Xi)); PRi = SMult(InvRootV, Yi - Mu); } void PRandD(DVector &Y, DMatrix &X, DVector &Offset, Index1D &I, IVector &LinkWave, GeeParam &par, GeeStr &geestr, DVector &PRi, DMatrix &Di) { DVector Yi = asVec(VecSubs(Y, I)); DMatrix Xi = asMat(MatRows(X, I)); DVector Offseti = asVec(VecSubs(Offset, I)); IVector Wavei = asVec(VecSubs(LinkWave, I)); DVector Eta = Xi * par.beta() + Offseti; DVector Mu = geestr.MeanLinkinv(Eta, Wavei); DVector V = geestr.v(Mu, Wavei); DVector Mu_Eta = geestr.MeanMu_eta(Eta, Wavei); DVector InvRootV = reciproot(V); Di = SMult(InvRootV, SMult(Mu_Eta, Xi)); PRi = SMult(InvRootV, Yi - Mu); } void gee_prep(DVector &Yi, DMatrix &Xi, DVector &Offseti, IVector &Wavei, GeeParam &par, GeeStr &geestr, DVector &PRi, DMatrix &Di, DVector &Vi, DVector &V_Mui) { DVector Eta = Xi * par.beta() + Offseti; DVector Mu = geestr.MeanLinkinv(Eta, Wavei); DVector V = geestr.v(Mu, Wavei); DVector Mu_Eta = geestr.MeanMu_eta(Eta, Wavei); DVector InvRootV = reciproot(V); Di = SMult(InvRootV, SMult(Mu_Eta, Xi)); PRi = SMult(InvRootV, Yi - Mu); Vi = geestr.v(Mu, Wavei); V_Mui = geestr.v_mu(Mu, Wavei); } void gee_prep(DVector &Y, DMatrix &X, DVector &Offset, Index1D &I, IVector &LinkWave, GeeParam &par, GeeStr &geestr, DVector &PRi, DMatrix &Di, DVector &Vi, DVector &V_Mui) { DVector Yi = asVec(VecSubs(Y, I)); DMatrix Xi = asMat(MatRows(X, I)); DVector Offseti = asVec(VecSubs(Offset, I)); IVector Wavei = asVec(VecSubs(LinkWave, I)); DVector Eta = Xi * par.beta() + Offseti; DVector Mu = geestr.MeanLinkinv(Eta, Wavei); DVector V = geestr.v(Mu, Wavei); DVector Mu_Eta = geestr.MeanMu_eta(Eta, Wavei); DVector InvRootV = reciproot(V); Di = SMult(InvRootV, SMult(Mu_Eta, Xi)); PRi = SMult(InvRootV, Yi - Mu); Vi = geestr.v(Mu, Wavei); V_Mui = geestr.v_mu(Mu, Wavei); } DMatrix getR(DMatrix &Zmati, DVector &corp, GeeParam &par, GeeStr &geestr, Corr &cor) { DVector alp = par.alpha(); int s = corp.dim(); // corp should determine meta par for R if (s == 1) return ident(1); else if (cor.corst() == INDEPENDENCE) //indenpendence return cor.mat(alp, corp); else { DVector Eta = Zmati * alp; DVector Rho = geestr.CorrLinkinv(Eta); return cor.mat(Rho, corp); } } DMatrix getR(DMatrix &Zmat, Index1D &I, Index1D &J, DVector &CorP, GeeParam &par, GeeStr &geestr, Corr &cor) { DVector alp = par.alpha(); DVector corp = asVec(VecSubs(CorP, I)); int s = corp.dim(); // corp should determine meta par for R if (s == 1) return ident(1); else if (cor.corst() == INDEPENDENCE) //indenpendence return cor.mat(alp, corp); else{ DMatrix Zmati = asMat(MatRows(Zmat, J)); DVector Eta = Zmati * alp; DVector Rho = geestr.CorrLinkinv(Eta); return cor.mat(Rho, corp); } } int RandE(DMatrix &Zmati, DVector &corp, GeeParam &par, GeeStr &geestr, Corr &cor, DMatrix &R, DMatrix &E) { DVector alp = par.alpha(); //DVector corp = asVec(VecSubs(CorP, I)); int s = corp.dim(); if (s == 1) { R = ident(1); return 0; } else if (cor.corst() == INDEPENDENCE) { //no need for E R = cor.mat(alp, corp); return 0; } else if (cor.corst() == FIXED) { DVector Eta = Zmati * alp; DVector Rho = geestr.CorrLinkinv(Eta); R = cor.mat(Rho, corp); return 0; } else { //DMatrix Zmati = asMat(MatRows(Zmat, J)); DVector Eta = Zmati * alp; DVector Rho = geestr.CorrLinkinv(Eta); R = cor.mat(Rho, corp); DVector Rho_Alp = geestr.CorrMu_eta(Eta); DMatrix Cor_Rho = cor.cor_rho(Rho, corp); E = Cor_Rho * SMult(Rho_Alp, Zmati); return 0; } } int RandE(DMatrix &Zmat, Index1D &I, Index1D &J, DVector &CorP, GeeParam &par, GeeStr &geestr, Corr &cor, DMatrix &R, DMatrix &E) { DVector alp = par.alpha(); DVector corp = asVec(VecSubs(CorP, I)); int s = corp.dim(); if (s == 1) { R = ident(1); return 0; } else if (cor.corst() == INDEPENDENCE) { //no need for E R = cor.mat(alp, corp); return 0; } else if (cor.corst() == FIXED) { DMatrix Zmati = asMat(MatRows(Zmat, J)); DVector Eta = Zmati * alp; DVector Rho = geestr.CorrLinkinv(Eta); R = cor.mat(Rho, corp); return 0; } else { DMatrix Zmati = asMat(MatRows(Zmat, J)); DVector Eta = Zmati * alp; DVector Rho = geestr.CorrLinkinv(Eta); R = cor.mat(Rho, corp); DVector Rho_Alp = geestr.CorrMu_eta(Eta); DMatrix Cor_Rho = cor.cor_rho(Rho, corp); E = Cor_Rho * SMult(Rho_Alp, Zmati); return 0; } } void gm_prep(DVector &PRi, IVector &Wavei, DVector &Doffseti, DMatrix &Zi, GeeParam &par, GeeStr &geestr, DVector &Phii, DVector &Si, DMatrix &D2i) { DVector Zeta = Zi * par.gamma() + Doffseti; DVector Phi_Zeta = geestr.ScaleMu_eta(Zeta, Wavei); Phii = geestr.ScaleLinkinv(Zeta, Wavei); Si = square(PRi); D2i = Phi_Zeta * Zi; } void gm_prep(DVector &PR, Index1D &I, IVector &LinkWave, DVector &Doffset, DMatrix &Zsca, GeeParam &par, GeeStr &geestr, DVector &Phii, DVector &Si, DMatrix &D2i) { DMatrix Zi = asMat(MatRows(Zsca, I)); DVector Doffseti = asVec(VecSubs(Doffset, I)); IVector Wavei = asVec(VecSubs(LinkWave, I)); DVector Zeta = Zi * par.gamma() + Doffseti; DVector Phi_Zeta = geestr.ScaleMu_eta(Zeta, Wavei); DVector PRi = asVec(VecSubs(PR, I)); Phii = geestr.ScaleLinkinv(Zeta, Wavei); Si = square(PRi); D2i = Phi_Zeta * Zi; } void PhiandD2(IVector &Wavei, DVector &Doffseti, DMatrix &Zi, GeeParam &par, GeeStr &geestr, DVector &Phii, DMatrix &D2i) { DVector Zeta = Zi * par.gamma() + Doffseti; Phii = geestr.ScaleLinkinv(Zeta, Wavei); if (geestr.ScaleFix() == 1) return; DVector Phi_Zeta = geestr.ScaleMu_eta(Zeta, Wavei); D2i = Phi_Zeta * Zi; } void PhiandD2(Index1D &I, IVector &LinkWave, DVector &Doffset, DMatrix &Zsca, GeeParam &par, GeeStr &geestr, DVector &Phii, DMatrix &D2i) { DMatrix Zi = asMat(MatRows(Zsca, I)); DVector Doffseti = asVec(VecSubs(Doffset, I)); IVector Wavei = asVec(VecSubs(LinkWave, I)); DVector Zeta = Zi * par.gamma() + Doffseti; Phii = geestr.ScaleLinkinv(Zeta, Wavei); if (geestr.ScaleFix() == 1) return; DVector Phi_Zeta = geestr.ScaleMu_eta(Zeta, Wavei); D2i = Phi_Zeta * Zi; } DVector getPR(DVector &Y, DMatrix &X, DVector &Offset, IVector &LinkWave, GeeParam &par, GeeStr &geestr) { DVector Eta = X * par.beta() + Offset; DVector Mu = geestr.MeanLinkinv(Eta, LinkWave); DVector V = geestr.v(Mu, LinkWave); DVector InvRootV = reciproot(V); return SMult(InvRootV, Y - Mu); } DVector getPhi(DVector &Doffset, DMatrix &Zsca, IVector &LinkWave, GeeParam &par, GeeStr &geestr) { DVector Zeta = Zsca * par.gamma() + Doffset; return geestr.ScaleLinkinv(Zeta, LinkWave); } void getDatI(DVector &Y, DVector &Offset, DVector &Doffset, DVector &W, DVector &CorP, DMatrix &X, DMatrix &Zsca, DMatrix &Zcor, IVector &LinkWave, //extract indicator Index1D &I, Index1D &J, IVector Scuri, Corr &cor, //output DVector &VYi, DVector &VOffseti, DVector &VDoffseti, DVector &VWi, DVector &VCorPi, DMatrix &VXi, DMatrix &VZscai, DMatrix &VZcori, IVector &VLinkWavei) { int s = Scuri.size(); //get dat i DVector Yi = asVec(VecSubs(Y, I)); DVector Offseti = asVec(VecSubs(Offset, I)); DVector Wi = asVec(VecSubs(W, I)); DVector CorPi = asVec(VecSubs(CorP, I)); DMatrix Xi = asMat(MatRows(X, I)); DMatrix Zscai = asMat(MatRows(Zsca, I)); IVector LinkWavei = asVec(VecSubs(LinkWave, I)); DMatrix Zcori; DVector Doffseti; if (cor.corst() > INDEPENDENCE && s > 1 ) { Zcori = asMat(MatRows(Zcor, J)); } Doffseti = asVec(VecSubs(Doffset, I)); //valid dat i IVector VI = genVI(Scuri), VJ = genCrossVI(Scuri); VYi = Valid(Yi, VI); VOffseti = Valid(Offseti, VI); VWi = Valid(Wi, VI); VCorPi = Valid(CorPi, VI); VXi = Valid(Xi, VI); VZscai = Valid(Zscai, VI); VLinkWavei = Valid(LinkWavei, VI); if (cor.corst() > INDEPENDENCE && s > 1) { if (cor.nparam() == 1) VZcori = Zcori; else VZcori = Valid(Zcori, VJ); //VDoffseti = Valid(Doffseti, VJ); //this is for log odds for ordinal } VDoffseti = Valid(Doffseti, VI); } void HnandGis(DVector &Y, DMatrix &X, DVector &Offset, DVector &Doffset, DVector &W, IVector &LinkWave, IVector &Clusz, IVector &ZcorSize, DMatrix &Zsca, DMatrix &Zcor, DVector &CorP, GeeParam &par, GeeStr &geestr, Corr &cor, IVector &Scur, IVector &level, //Scur is the valid data indicator //output Hess &Hn, Vector &Gis) { int N = Clusz.size(); Hess H(par); Vector His(N); His = H; HisandGis(Y, X, Offset, Doffset, W, LinkWave, Clusz, ZcorSize, Zsca, Zcor, CorP, par, geestr, cor, Scur, level, His, Gis); for (int i = 1; i <= N; i++) H.inc(His(i)); Hn = (1.0/(double) N) * H; } void HisandGis(DVector &Y, DMatrix &X, DVector &Offset, DVector &Doffset, DVector &W, IVector &LinkWave, IVector &Clusz, IVector &ZcorSize, DMatrix &Zsca, DMatrix &Zcor, DVector &CorP, GeeParam &par, GeeStr &geestr, Corr &cor, IVector &Scur, IVector &level, //output Vector &His, Vector &Gis) { Index1D I(0,0), J(0,0); int N = Clusz.size(); int pb = par.p(), pg = par.r(), pa = par.q(); DVector V0(pb); Hess H(par), Hi(par); Grad Gi(par); //cout << "N = " << N; for (int i = 1; i <= N; i++) { int s1 = Clusz(i), s2 = ZcorSize(i); I = Index1D(1, s1) + I.ubound(); if (s2 > 0) J = Index1D(1, s2) + J.ubound(); IVector Scuri = asVec(VecSubs(Scur, I)); if (sum(Scuri) == 0) continue; //get and valid data i DVector Yi, Offseti, Doffseti, Wi, CorPi; DMatrix Xi, Zscai, Zcori; IVector LinkWavei; getDatI(Y, Offset, Doffset, W, CorP, X, Zsca, Zcor, LinkWave, I, J, Scuri, cor, Yi, Offseti, Doffseti, Wi, CorPi, Xi, Zscai, Zcori, LinkWavei); DVector PRi(s1), Vi(s1), V_Mui(s1); DMatrix Di(s1,pb); gee_prep(Yi, Xi, Offseti, LinkWavei, par, geestr, PRi, Di, Vi, V_Mui); DVector Phii(s1); DMatrix D2i(s1, pg); PhiandD2(LinkWavei, Doffseti, Zscai, par, geestr, Phii, D2i); DMatrix R(s1, s1), E(s2, pa); RandE(Zcori, CorPi, par, geestr, cor, R, E); HiandGi(PRi, Phii, Di, R, Vi, V_Mui, D2i, E, Wi, level, Hi, Gi); His(i) = Hi; Gis(i) = Gi; } } IVector genVI(IVector &Si, int c) { int s = Si.size(), k = 1; IVector ans(s * c); ans = 0; for (int i = 1; i <= s; i++) { if (Si(i) == 1) { for (int j = 1; j <= c; j++) { ans(k) = 1; k++; } } } return ans; } IVector genCrossVI(IVector &Si, int c) { int s = Si.size(); IVector ans(s * (s - 1) * c * c / 2); ans = 0; IVector vv(c * c); vv = 1; Index1D I(0,0); for (int i = 1; i <= s - 1; i++) { for (int j = i + 1; j <= s; j++) { I = Index1D(1, c * c) + I.ubound(); if (Si(i) == 1 && Si(j) == 1) VecSubs(ans, I) = vv; } } return ans; } geepack/vignettes/0000755000176200001440000000000014166001762013664 5ustar liggesusersgeepack/vignettes/geepack-manual.Rnw0000755000176200001440000001165014165262714017241 0ustar liggesusers% \VignetteIndexEntry{Users guide to geepack} % \VignetteKeyword{Generalized Estimating Equation} % \VignetteKeyword{Working correlation matrix} \documentclass{article} \usepackage{boxedminipage,color,a4,shortvrb,hyperref} %\usepackage[latin1]{inputenc} \usepackage[T1]{fontenc} \usepackage[utf8]{inputenc} \MakeShortVerb| \def\pkg#1{{\bf #1}} <>= require( geepack ) prettyVersion <- packageDescription("geepack")$Version prettyDate <- format(Sys.Date()) @ \SweaveOpts{keep.source=T,prefix.string=figures/LSmeans} \title{On the usage of the \texttt{geepack} } \author{S\o ren H\o jsgaard and Ulrich Halekoh} \date{\pkg{geepack} version \Sexpr{prettyVersion} as of \Sexpr{prettyDate}} \begin{document} \parindent0pt\parskip4pt %% Efter preamble \definecolor{myGray}{rgb}{0.95,0.95,0.95} \makeatletter \renewenvironment{Schunk}{ \begin{lrbox}{\@tempboxa} \begin{boxedminipage} {\columnwidth}\scriptsize} {\end{boxedminipage} \end{lrbox}% \colorbox{myGray}{\usebox{\@tempboxa}} } \makeatother \maketitle \tableofcontents \section{Introduction} \label{sec:introduction} This note contains a few extra examples. We illustrate the usage of a the |waves| argument and the |zcor| argument together with a fixed working correlation matrix for the |geeglm()| function. \label{sec:intro} \section{Citing \texttt{geepack}} The primary reference for the |geepack| package is \begin{quote} Halekoh, U., H\o jsgaard, S., Yan, J. (2006) {\em The R Package geepack for Generalized Estimating Equations (2006)} Journal of Statistical Software \url{https://www.jstatsoft.org/article/view/v015i02} \end{quote} @ <<>>= library(geepack) citation("geepack") @ %def If you use |geepack| in your own work, please do cite the above reference. \section{Simulating a dataset} \label{sec:simulating} To illustrate the usage of the |waves| argument and the |zcor| argument together with a fixed working correlation matrix for the |geeglm()| we simulate some data suitable for a regression model. @ <<>>= library(geepack) timeorder <- rep(1:5, 6) tvar <- timeorder + rnorm(length(timeorder)) idvar <- rep(1:6, each=5) uuu <- rep(rnorm(6), each=5) yvar <- 1 + 2*tvar + uuu + rnorm(length(tvar)) simdat <- data.frame(idvar, timeorder, tvar, yvar) head(simdat,12) @ %def Notice that clusters of data appear together in |simdat| and that observations are ordered (according to |timeorder|) within clusters. We can fit a model with an AR(1) error structure as @ <<>>= mod1 <- geeglm(yvar~tvar, id=idvar, data=simdat, corstr="ar1") mod1 @ %def This works because observations are ordered according to time within each subject in the dataset. \section{Using the \texttt{waves} argument} \label{sec:xxx} If observatios were not ordered according to cluster and time within cluster we would get the wrong result: @ <<>>= set.seed(123) ## library(doBy) simdatPerm <- simdat[sample(nrow(simdat)),] ## simdatPerm <- orderBy(~idvar, simdatPerm) simdatPerm <- simdatPerm[order(simdatPerm$idvar),] head(simdatPerm) @ %def Notice that in |simdatPerm| data is ordered according to subject but the time ordering within subject is random. Fitting the model as before gives @ <<>>= mod2 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="ar1") mod2 @ %def Likewise if clusters do not appear contigously in data we also get the wrong result (the clusters are not recognized): @ <<>>= ## simdatPerm2 <- orderBy(~timeorder, data=simdat) simdatPerm2 <- simdat[order(simdat$timeorder),] geeglm(yvar~tvar, id=idvar, data=simdatPerm2, corstr="ar1") @ %def To obtain the right result we must give the |waves| argument: @ <<>>= wav <- simdatPerm$timeorder wav mod3 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="ar1", waves=wav) mod3 @ %def \section{Using a fixed correlation matrix and the \texttt{zcor} argument} \label{sec:xxx} Suppose we want to use a fixed working correlation matrix: @ <<>>= cor.fixed <- matrix(c(1 , 0.5 , 0.25, 0.125, 0.125, 0.5 , 1 , 0.25, 0.125, 0.125, 0.25 , 0.25 , 1 , 0.5 , 0.125, 0.125, 0.125, 0.5 , 1 , 0.125, 0.125, 0.125, 0.125, 0.125, 1 ), 5, 5) cor.fixed @ %def Such a working correlation matrix has to be passed to |geeglm()| as a vector in the |zcor| argument. This vector can be created using the |fixed2Zcor()| function: @ <<>>= zcor <- fixed2Zcor(cor.fixed, id=simdatPerm$idvar, waves=simdatPerm$timeorder) zcor @ %def Notice that |zcor| contains correlations between measurements within the same cluster. Hence if a cluster contains only one observation, then there will be generated no entry in |zcor| for that cluster. Now we can fit the model with: @ <<>>= mod4 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="fixed", zcor=zcor) mod4 @ %def \section{When do GEE's work best?} \label{sec:when-do-gees} GEEs work best when you have relatively many relativly small clusters in your data. \end{document} geepack/R/0000755000176200001440000000000014165262714012062 5ustar liggesusersgeepack/R/geeglm.R0000755000176200001440000005314014165262714013453 0ustar liggesusers#' @title Fit Generalized Estimating Equations (GEE) #' #' @description The geeglm function fits generalized estimating equations using #' the 'geese.fit' function of the 'geepack' package for doing the actual #' computations. geeglm has a syntax similar to glm and returns an object #' similar to a glm object. An important feature of geeglm, is that an #' anova method exists for these models. #' #' @name geeglm #' #' @details In the case of corstr="fixed" one must provide the zcor vector if #' the clusters have unequal sizes. Clusters with size one must not be #' represented in zcor. #' #' @param formula See corresponding documentation to \code{glm} #' @param family See corresponding documentation to \code{glm} #' @param data See corresponding documentation to \code{glm} #' @param weights See corresponding documentation to \code{glm} #' @param subset See corresponding documentation to \code{glm} #' @param na.action No action is taken. Indeed geeglm only works on complete #' data. #' @param start See corresponding documentation to \code{glm} #' @param etastart See corresponding documentation to \code{glm} #' @param mustart See corresponding documentation to \code{glm} #' @param offset See corresponding documentation to \code{glm} #' @param control See corresponding documentation to \code{glm} #' @param method See corresponding documentation to \code{glm} ## #' @param x See corresponding documentation to \code{glm} ## #' @param y See corresponding documentation to \code{glm} #' @param contrasts See corresponding documentation to \code{glm} #' #' @param id a vector which identifies the clusters. The length of #' `id' should be the same as the number of observations. Data #' are assumed to be sorted so that observations on each cluster #' appear as contiguous rows in data. If data is not sorted this #' way, the function will not identify the clusters correctly. If #' data is not sorted this way, a warning will be issued. Please #' consult the package vignette for details. #' #' @param waves Wariable specifying the ordering of repeated #' mesurements on the same unit. Also used in connection with #' missing values. Please consult the package vignette for details. #' #' @param zcor Used for entering a user defined working correlation #' structure. #' @param corstr a character string specifying the correlation #' structure. The following are permitted: '"independence"', #' '"exchangeable"', '"ar1"', '"unstructured"' and '"userdefined"' #' @param scale.fix a logical variable; if true, the scale parameter #' is fixed at the value of 'scale.value'. #' @param scale.value numeric variable giving the value to which the #' scale parameter should be fixed; used only if 'scale.fix = #' TRUE'. #' @param std.err Type of standard error to be calculated. Defualt #' 'san.se' is the usual robust estimate. Other options are #' 'jack': if approximate jackknife variance estimate should be #' computed. 'j1s': if 1-step jackknife variance estimate should #' be computed. 'fij': logical indicating if fully iterated #' jackknife variance estimate should be computed. #' @param \dots further arguments passed to or from other methods. #' @return An object of type 'geeglm' #' #' @note See the documentation for the 'geese' function for additional #' information. geeglm only works for complete data. Thus if there are NA's #' in data you can specify data=na.omit(mydata). #' #' @section Warning : Use "unstructured" correlation structure only with great #' care. (It may cause R to crash). #' #' @author Søren Højsgaard, \email{sorenh@@math.aau.dk} #' #' @seealso \code{\link{geese}}, \code{\link{glm}}, \code{\link{anova.geeglm}} #' #' @references #' #' Halekoh, U.; Højsgaard, S. and Yan, J (2006) #' The R Package geepack for Generalized Estimating Equations. #' Journal of Statistical Software, 15, 2, 1-11" #' #' Liang, K.Y. and Zeger, S.L. (1986) Longitudinal data analysis using #' generalized linear models. Biometrika, *73* 13-22. #' #' Prentice, R.L. and Zhao, L.P. (1991). Estimating equations for #' parameters in means and covariances of multivariate discrete and #' continuous responses. Biometrics, *47* 825-839. #' #' @keywords models #' @examples #' #' data(dietox) #' dietox$Cu <- as.factor(dietox$Cu) #' mf <- formula(Weight ~ Cu * (Time + I(Time^2) + I(Time^3))) #' gee1 <- geeglm(mf, data=dietox, id=Pig, family=poisson("identity"), corstr="ar1") #' gee1 #' coef(gee1) #' vcov(gee1) #' summary(gee1) #' coef(summary(gee1)) #' #' mf2 <- formula(Weight ~ Cu * Time + I(Time^2) + I(Time^3)) #' gee2 <- geeglm(mf2, data=dietox, id=Pig, family=poisson("identity"), corstr="ar1") #' anova(gee2) #' #' @export geeglm geeglm<- function (formula, family = gaussian, data = parent.frame(), weights, subset, na.action, start = NULL, etastart, mustart, offset, control = geese.control(...), method = "glm.fit", ##x = FALSE, y = TRUE, contrasts = NULL, id, waves = NULL, zcor = NULL, corstr = "independence", scale.fix = FALSE, scale.value = 1, std.err = "san.se", ...) { ## Standard errors STDERRS <- c("san.se", "jack", "j1s", "fij") stderrv <- pmatch(std.err, STDERRS, -1) std.err <- STDERRS[stderrv] jackB <- j1sB <- fijB <- FALSE if (std.err == "jack") jackB <- TRUE if (std.err == "j1s") j1sB <- TRUE if (std.err == "fij") fijB <- TRUE control$jack <- as.integer(jackB) control$j1s <- as.integer(j1sB) control$fij <- as.integer(fijB) if (corstr=="fixed" && is.null(zcor)){ stop("When corstr is 'fixed' then 'zcor' must be given\n") } ## Working correlation structures CORSTRS <- c("independence", "exchangeable", "ar1", "unstructured", "userdefined", "fixed") corstrv <- pmatch(corstr, CORSTRS, -1) corstr <- CORSTRS[corstrv] ## Dummy glm object call <- match.call(expand.dots = TRUE) glmcall <- call glmcall$id <- glmcall$jack <- glmcall$control <- glmcall$corstr <- glmcall$waves <- glmcall$zcor <- glmcall$std.err <- glmcall$scale.fix <- glmcall$scale.value <- NULL glmcall[[1]] <- as.name("glm") glmFit <- eval(glmcall, parent.frame()) modelmat <- model.matrix(glmFit) qqrr <- qr(modelmat) if (qqrr$rank < ncol(modelmat)){ print(head(modelmat)) stop("Model matrix is rank deficient; geeglm can not proceed\n") } mf <- call mf[[1]] <- as.name("model.frame") mftmp <- mf to_delete <- c("family", "corstr", "control", "zcor", "std.err", "scale.fix") mftmp[match(to_delete, names(mftmp))] <- NULL ## mftmp$family <- mftmp$corstr <- mftmp$control <- mftmp$zcor <- mftmp$std.err <- NULL ## mftmp$scale.fix <- NULL mf <- eval(mftmp, parent.frame()) ## Clustering variable id <- model.extract(mf, id) if (is.null(id)) stop("id variable not found.") ## Waves waves <- model.extract(mf, waves) if (!is.null(waves)) waves <- as.factor(waves) ## Construct X and Y mt <- attr(mf, "terms") Y <- model.response(mf, "numeric") X <- if (!is.empty.model(mt)) model.matrix(mt, mf, contrasts) else matrix(, NROW(Y), 0) ## Check that factors in model do not have unused levels in data ## (otherwise R crashes). vars <- all.vars(formula) stopIt <- FALSE for(ii in seq_along(vars)){ vv <- vars[ii] if(!is.na(match(vv, names(mf))) && is.factor(mf[,vv])){ if (length(unique(mf[,vv])) != length(levels(mf[,vv]))){ cat("Factors not allowed to have unused levels...\n") cat(" Levels of factor", vv,":", paste(levels(mf[, vv]), sep=' '),"\n") cat(" Used levels of factor", vv,":", paste(unique(mf[, vv]), sep=' '),"\n") stopIt <- TRUE } } } if (stopIt) stop("Can not continue...\n") N <- NROW(Y) yy <- Y xx <- X soffset <- rep(0, N) mnames <- c("", "formula", "data", "offset", "weights", "subset", "na.action") cnames <- names(call) cnames <- cnames[match(mnames, cnames, 0)] mcall <- call[cnames] mcall$drop.unused.levels <- TRUE mcall[[1]] <- as.name("model.frame") mcall$formula <- formula sformula <- ~1 mcall$formula[3] <- switch(match(length(sformula), c(0, 2, 3)), 1, sformula[2], sformula[3]) m <- eval(mcall, parent.frame()) terms <- attr(m, "terms") zsca <- model.matrix(terms, m, contrasts) colnames(zsca) <- c("(Intercept)") w <- model.weights(mf) if (is.null(w)) w <- rep(1, N) offset <- model.offset(mf) if (is.null(offset)) offset <- rep(0, N) if (glmFit$family$family == "binomial") { if (is.matrix(yy) && ncol(yy) == 2) { w <- apply(yy, 1, sum) yy <- yy[, 1] / w } } family <- glmFit$family nacoef <- as.numeric(which(is.na(glmFit$coef))) xx <- as.data.frame(xx) xx[, nacoef] <- NULL xx <- as.matrix(xx) if (is.null(start)) start <- glmFit$coef ans <- geese.fit(xx, yy, id, offset, soffset, w, waves = waves, zsca, zcor = zcor, corp = NULL, control = control, b = start, alpha = NULL, gm = NULL, family, mean.link = NULL, variance = NULL, cor.link = "identity", sca.link = "identity", link.same = TRUE, scale.fix = scale.fix, scale.value = scale.value, corstr, ...) ans <- c(ans, list(call = call, formula = formula)) class(ans) <- "geese" ans$X <- xx ans$id <- id ans$weights <- w out <- glmFit ## glmFit: Dummy object created in the beginning toDelete <- c("R", "deviance", "aic", "null.deviance", "iter", "df.null", "converged", "boundary") out[match(toDelete, names(out))] <- NULL out$method <- "geese.fit" out$geese <- ans out$weights <- ans$weights out$coefficients <- ans$beta out$offset <- offset if (is.null(out$offset)){ out$linear.predictors <- ans$X %*% ans$beta } else { out$linear.predictors <- out$offset + ans$X %*% ans$beta } out$fitted.values <- family(out)$linkinv(out$linear.predictors) out$modelInfo <- ans$model out$id <- ans$id out$call <- ans$call out$corstr <- ans$model$corstr out$cor.link <- ans$model$cor.link out$control <- ans$control out$std.err <- std.err class(out) <- c("geeglm", "gee", "glm", "lm") out } #' @export vcov.geeglm <- function(object, ...){ out <- switch(object$std.err, 'jack'={object$geese$vbeta.ajs}, 'j1s' ={object$geese$vbeta.j1s}, 'fij' ={object$geese$vbeta.fij}, object$geese$vbeta ) pn <- names(coef(object)) dimnames(out) <- list(pn, pn) out } #' @export summary.geeglm <- function(object,...){ class(object) <- "glm" value <- summary.glm(object) class(object) <- c("geeglm","glm") class(value) <- "summary.geeglm" toDelete <- c("deviance", "aic", "null.deviance", "iter", "df.residual", "df.null", "converged", "boundary") idx <- match(toDelete, names(value)) value[idx] <- NULL covmat <- switch(object$std.err, 'jack'={object$geese$vbeta.ajs}, 'j1s' ={object$geese$vbeta.j1s}, 'fij' ={object$geese$vbeta.fij}, object$geese$vbeta ) value$cov.scaled <- value$cov.unscaled <- covmat mean.sum <- data.frame(estimate = object$geese$beta, std.err=sqrt(diag(covmat))) mean.sum$wald <- (mean.sum$estimate / mean.sum$std.err)^2 mean.sum$p <- 1 - pchisq(mean.sum$wald, df=1) ## names(mean.sum) <- c("Estimate", "Std.err", "Wald", "p(>W)") names(mean.sum) <- c("Estimate", "Std.err", "Wald", "Pr(>|W|)") ## Thanks, Achim value$coefficients <- mean.sum covmatgam <- switch(object$std.err, 'jack'={object$geese$vgamma.ajs}, 'j1s' ={object$geese$vgamma.j1s}, 'fij' ={object$geese$vgamma.fij}, object$geese$vgamma ) scale.sum <- data.frame(Estimate = object$geese$gamma, Std.err=sqrt(diag(covmatgam))) ##scale.sum$wald <- (scale.sum$Estimate / scale.sum$Std.err)^2 ##scale.sum$p <- 1 - pchisq(scale.sum$wald, df=1) if (!is.null(object$geese$zsca.names)) rownames(scale.sum) <- object$geese$zsca.names value$dispersion <- scale.sum covmatalpha <- switch(object$std.err, 'jack'={object$geese$valpha.ajs}, 'j1s' ={object$geese$valpha.j1s}, 'fij' ={object$geese$valpha.fij}, object$geese$valpha ) corr.sum <- data.frame(Estimate = object$geese$alpha, Std.err=sqrt(diag(covmatalpha))) ##corr.sum$wald <- (corr.sum$Estimate / corr.sum$Std.err)^2 ##corr.sum$p <- 1 - pchisq(corr.sum$wald, df=1) ##if (nrow(corr.sum) > 0) rownames(corr.sum) <- object$geese$zcor.names value$corr <- corr.sum value$corstr <- object$geese$model$corstr value$scale.fix <- object$geese$model$scale.fix value$cor.link <- object$geese$model$cor.link v1 <- summary.geese(object$geese) value$clusz <- v1$clusz value$error <- object$geese$error value$geese <- v1 return(value) } # colnames(mean.sum) <- c("Estimate","Std.Error","ajs.SE","j1s.SE","fij.SE", # "Wald","Pr(>|z|)") #' @export print.summary.geeglm <- function (x, digits = max(3, getOption("digits") - 3), quote = FALSE, prefix = "", ...) # Thanks, Achim... #print.summary.geeglm <- function (x, digits = NULL, quote = FALSE, prefix = "", ...) { if (is.null(digits)) digits <- options()$digits else options(digits = digits) cat("\nCall:\n"); print(x$call) cat("\n Coefficients:\n"); ##print(as.matrix(x$coef), digits = digits) printCoefmat(as.matrix(x$coef), digits = digits) ## Thanks, Achim cat("\nCorrelation structure =", x$corstr, "\n") if (!(x$scale.fix)) { cat("Estimated Scale Parameters:\n\n") print(x$dispersion[1:2], digits = digits) } else cat("Scale is fixed.\n\n") if (pmatch(x$corstr, "independence", 0) == 0) { cat(" Link =", x$cor.link, "\n") cat("\nEstimated Correlation Parameters:\n") print(x$corr, digits = digits) } cat("Number of clusters: ", length(x$clusz), " Maximum cluster size:", max(x$clusz), "\n") #cat("\nReturned Error Value: ") #cat(x$error, "\n") invisible(x) } #' @export print.geeglm <- function (x, digits = NULL, quote = FALSE, prefix = "", ...) { xg <- x$geese if (is.null(digits)) digits <- options()$digits else options(digits = digits) cat("\nCall:\n") print(x$call) cat("\nCoefficients:\n") print(unclass(x$coefficients), digits = digits) cat("\nDegrees of Freedom:", length(x$y), "Total (i.e. Null); ", x$df.residual, "Residual\n") if (!xg$model$scale.fix) { cat("\nScale Link: ", xg$model$sca.link) cat("\nEstimated Scale Parameters: ") print(as.numeric(unclass(xg$gamma)), digits = digits) } else cat("\nScale is fixed.\n") cat("\nCorrelation: Structure =",xg$model$corstr, " ") if (pmatch(xg$model$corstr, "independence", 0) == 0) { cat(" Link =", xg$model$cor.link, "\n") cat("Estimated Correlation Parameters:\n") print(unclass(xg$alpha), digits = digits) } cat("\nNumber of clusters: ", length(xg$clusz), " Maximum cluster size:", max(xg$clusz), "\n\n") invisible(x) } #' @export residuals.geeglm <- function (object, type = c("pearson", "working", "response"), ...) { type <- match.arg(type) y <- object$y r <- object$residuals mu <- object$fitted.values wts <- object$prior.weights res <- switch(type, # deviance = if (object$df.res > 0) { # d.res <- sqrt(pmax((object$family$dev.resids)(y, mu, # wts), 0)) # ifelse(y > mu, d.res, -d.res) # } # else rep.int(0, length(mu)), pearson = (y - mu) * sqrt(wts)/sqrt(object$family$variance(mu)), working = r, response = y - mu, partial = r) if (!is.null(object$na.action)) res <- naresid(object$na.action, res) # if (type == "partial") # res <- res + predict(object, type = "terms") res } #' @export plot.geeglm <- function(x,...){ xx <- fitted(x) rp <- residuals(x, "pearson") plot(xx, rp, ylab="Pearson residuals", xlab="Fitted values") abline(h = 0) m <- lowess(rp ~ xx) lines(m) } eprint <- function(x){ #print(x) } # geeglm <- function (formula, family = gaussian, data=parent.frame(), weights, subset, # na.action, start = NULL, etastart, mustart, offset, # control = geese.control(...), # method = "glm.fit", x = FALSE, y = TRUE, # contrasts = NULL, # id, waves = NULL, # zcor=NULL, # corstr = "independence", # scale.fix = FALSE, # scale.value =1, # std.err = 'san.se', # ...) # { # STDERRS <- c("san.se", "jack", "j1s", "fij") # stderrv <- pmatch(std.err, STDERRS, -1) # std.err <- STDERRS[stderrv] # jackB <- j1sB <- fijB <- FALSE # if (std.err=='jack') jackB <- TRUE # if (std.err=='j1s') j1sB <- TRUE # if (std.err=='fij') fijB <- TRUE # control$jack <- as.integer(jackB) # control$j1s <- as.integer(j1sB) # control$fij <- as.integer(fijB) # CORSTRS <- c("independence", "exchangeable", "ar1", "unstructured", "userdefined") # eprint("SHDgeese.fit - corstr") # corstrv <- pmatch(corstr, CORSTRS, -1) # corstr<-CORSTRS[corstrv] # eprint("geeglm is called") # call <- match.call(expand.dots=TRUE) # glmcall <- call # glmcall$id <- glmcall$jack <- glmcall$control <- glmcall$corstr <- glmcall$waves <- glmcall$zcor<- glmcall$std.err <- glmcall$scale.fix <- glmcall$scale.value <- NULL # glmcall[[1]] <- as.name("glm") # glmFit <- eval(glmcall, parent.frame()) # mf <- call # ##call$data <- mf$data <- na.omit(eval(mf$data)) # mf[[1]] <- as.name("model.frame") # mftmp <- mf # mftmp$family <- mftmp$corstr <- mftmp$control <- mftmp$zcor<- mftmp$std.err <- NULL # mf <- eval(mftmp, parent.frame()) # ### Copy from "geese" starts here # ################################# # id <- model.extract(mf, id) # if (is.null(id)) # stop("id variable not found.") # waves <- model.extract(mf, waves) # if (!is.null(waves)) # waves <- as.factor(waves) # mt <- attr(mf, "terms") # Y <- model.response(mf, "numeric") # X <- if (!is.empty.model(mt)) # model.matrix(mt, mf, contrasts) # else matrix(, NROW(Y), 0) # N <- NROW(Y) # yy <- Y # xx <- X # soffset <- rep(0, N) # mnames <- c("", "formula", "data", "offset", "weights", "subset", "na.action") # cnames <- names(call) # cnames <- cnames[match(mnames, cnames, 0)] # mcall <- call[cnames] # mcall$drop.unused.levels <- TRUE # mcall[[1]] <- as.name("model.frame") # mcall$formula <- formula # sformula <- ~1 # mcall$formula[3] <- # switch(match(length(sformula), # c(0, 2, 3)), 1, sformula[2], sformula[3]) # m <- eval(mcall, parent.frame()) # terms <- attr(m, "terms") # zsca <- model.matrix(terms, m, contrasts) # colnames(zsca) <- c("(Intercept)") # #corstr <- "independence" # w <- model.weights(mf) # if (is.null(w)) # w <- rep(1, N) # offset <- model.offset(mf) # if (is.null(offset)) # offset <- rep(0, N) # if (glmFit$family$family=="binomial"){ # if (is.matrix(yy) && ncol(yy)==2){ # w <- apply(yy,1,sum) # yy<- yy[,1]/w # } # } # family <- glmFit$family # nacoef <- as.numeric(which(is.na(glmFit$coef))) # xx <- as.data.frame(xx) # xx[,nacoef] <- NULL # xx <- as.matrix(xx) # if (is.null(start)) # start <- glmFit$coef # ans <- geese.fit(xx, yy, id, offset, soffset, w, waves=waves, zsca, # zcor=zcor, corp=NULL, control=control, # b=start, # alpha=NULL, gm=NULL, family, mean.link=NULL, # variance=NULL, # cor.link="identity", sca.link="identity", # link.same=TRUE, scale.fix=scale.fix, scale.value=scale.value, # corstr, ...) # ans <- c(ans, list(call = call, formula = formula)) # class(ans) <- "geese" # ### Copy from geese ends here # ############################# # ans$X <- xx # ans$id <- id # ans$weights <- w # value <- glmFit # toDelete <- c("R","deviance","aic","null.deviance","iter","df.null", # "converged","boundary") # value[match(toDelete,names(value))] <- NULL # value$method <- "geese.fit" # value$geese <- ans # value$weights <- ans$weights # value$coefficients <- ans$beta # ## Kludgy.. # value$offset <- offset # if(is.null(value$offset)) # value$linear.predictors <- ans$X %*% ans$beta # else # value$linear.predictors <- value$offset + ans$X %*% ans$beta # value$fitted.values <- family(value)$linkinv(value$linear.predictors) # value$modelInfo <- ans$model # value$id <- ans$id # value$call <- ans$call # value$corstr <- ans$model$corstr # value$cor.link <- ans$model$cor.link # value$control <- ans$control # value$std.err <- std.err # class(value) <- c("geeglm", "gee", "glm") # return(value) # } geepack/R/zzz.R0000755000176200001440000000012514165262714013043 0ustar liggesusers## .First.lib <- function(lib, pkg) { ## library.dynam("geepack", pkg, lib) ## } geepack/R/genZcor.R0000755000176200001440000000645214165262714013626 0ustar liggesusers #' genZcor #' #' constructs the design matrix for the correlation structures: independence, #' echangeable, ar1 and unstructured The user will need this function only as a #' basis to construct a user defined correlation structure: use genZcor to get #' the design matrix Z for the unstructured correlation and define the specific #' correlation structure by linear combinations of the columns of Z. #' #' #' @aliases genZcor humbelbee #' @param clusz integer vector giving the number of observations in #' each cluster #' @param waves integer vector, obervations in the same cluster with #' values of wave i and j have the correlation #' \eqn{latex}{sigma_ij} #' @param corstrv correlation structures: #' 1=independence,2=exchangeable,3=ar1, 4=unstructured #' @return \item{}{the design matrix for the correlation structure} #' @author Jun Yan \email{jyan.stat@@gmail.com} #' @seealso \code{\link{fixed2Zcor}} #' @keywords regression #' @examples #' #' #example to construct a Toeplitz correlation structure #' # sigma_ij=sigma_|i-j| #' #' #data set with 5 clusters and maximally 4 observations (visits) per cluster #' gendat <- function() { #' id <- gl(5, 4, 20) #' visit <- rep(1:4, 5) #' y <- rnorm(id) #' dat <- data.frame(y, id, visit)[c(-2,-9),] #' } #' #' set.seed(88) #' dat<-gendat() #' #' #generating the design matrix for the unstructured correlation #' zcor <- genZcor(clusz = table(dat$id), waves = dat$visit, corstrv=4) #' # defining the Toeplitz structure #' zcor.toep<-matrix(NA, nrow(zcor),3) #' zcor.toep[,1]<-apply(zcor[,c(1,4,6)],1,sum) #' zcor.toep[,2]<-apply(zcor[,c(2,5)],1,sum) #' zcor.toep[,3]<-zcor[,3] #' #' zfit1 <- geese(y ~ 1,id = id, data = dat, #' corstr = "userdefined", zcor = zcor.toep) #' #' #' zfit2 <- geeglm(y ~ 1,id = id, data = dat, #' corstr = "userdefined", zcor = zcor.toep) #' #' #' #' @export genZcor genZcor <- function(clusz, waves, corstrv) { if (corstrv == 1) return (matrix(0,0,0)) crs <- clusz * (clusz - 1) / 2 if (corstrv == 2 || corstrv == 3) { ans <- matrix(1, length(clusz), 1) ##ans <- matrix(1, sum(crs), 1) colnames(ans) <- c("alpha") } else { id <- rep(1:length(clusz), clusz) z1 <- unlist(lapply(split(waves, id), crossutri)) z2 <- unlist(crossutri(1:max(clusz))) z <- factor(z1,levels=unique.default(z2)) ans <- model.matrix(~z - 1) znames <- paste("alpha", z2, sep = ".") colnames(ans) <- znames } ans } genZodds <- function(clusz, waves, corstrv, ncat) { if (corstrv == 1) return (matrix(0,0,0)) crs <- clusz * (clusz - 1) / 2 c2 <- ncat * ncat if (corstrv == 2 | corstrv == 3) { ans <- matrix(1, sum(crs) * c2, 1) colnames(ans) <- c("alpha") } else { id <- rep(1:length(clusz), clusz) z1 <- unlist(lapply(split(waves, id), crossutri)) z2 <- unlist(crossutri(1:max(clusz))) z <- factor(z1,levels=unique.default(z2)) z <- model.matrix(~z - 1) ind <- gl(sum(crs), c2) ans <- z[ind,] colnames(ans) <- paste("alpha", 1:dim(ans)[2], sep=".") } ans } crossutri <- function(wave) { n <- length(wave) if (n == 1) return(NULL) ans <- rep(0, n*(n-1)/2) k <- 1 for (i in 1:(n-1)) for (j in (i+1):n) { ans[k] <- paste(wave[i], wave[j], sep=":") k <- k + 1 } ans } geepack/R/geese.R0000755000176200001440000005470614165262714013314 0ustar liggesusers#' @title Function to fit a Generalized Estimating Equation Model #' #' @description Produces an object of class `geese' which is a Generalized Estimating #' Equation fit of the data. #' #' @details #' when the correlation structure is \code{fixed}, the specification of #' \code{Zcor} should be a vector of length \code{sum(clusz * (clusz - 1)) / #' 2.} #' #' @aliases geese geese.fit print.geese summary.geese #' print.summary.geese #' #' @param formula a formula expression as for \code{glm}, of the form #' \code{response ~ predictors}. See the documentation of lm and #' formula for details. As for glm, this specifies the linear #' predictor for modeling the mean. A term of the form #' \code{offset(expression)} is allowed. #' @param sformula a formula expression of the form \code{ ~ #' predictor}, the response being ignored. This specifies the #' linear predictor for modeling the dispersion. A term of the #' form \code{offset(expression)} is allowed. #' @param id a vector which identifies the clusters. The length of #' `id' should be the same as the number of observations. Data #' are assumed to be sorted so that observations on a cluster are #' contiguous rows for all entities in the formula. #' @param waves an integer vector which identifies components in #' clusters. The length of \code{waves} should be the same as the #' number of observation. components with the same \code{waves} #' value will have the same link functions. #' @param data an optional data frame in which to interpret the #' variables occurring in the \code{formula}, along with the #' \code{id} and \code{n} variables. #' @param subset expression saying which subset of the rows of the #' data should be used in the fit. This can be a logical vector #' (which is replicated to have length equal to the number of #' observations), or a numeric vector indicating which observation #' numbers are to be included, or a character vector of the row #' names to be included. All observations are included by #' default. #' @param na.action a function to filter missing data. For \code{gee} #' only \code{na.omit} should be used here. #' @param contrasts a list giving contrasts for some or all of the #' factors appearing in the model formula. The elements of the #' list should have the same name as the variable and should be #' either a contrast matrix (specifically, any full-rank matrix #' with as many rows as there are levels in the factor), or else a #' function to compute such a matrix given the number of levels. #' @param weights an optional vector of weights to be used in the #' fitting process. The length of \code{weights} should be the #' same as the number of observations. This weights is not (yet) #' the weight as in sas proc genmod, and hence is not recommended #' to use. #' @param zcor a design matrix for correlation parameters. #' @param corp known parameters such as coordinates used for #' correlation coefficients. #' @param control a list of iteration and algorithmic constants. See #' \code{\link{geese.control}} for their names and default #' values. These can also be set as arguments to \code{geese} #' itself. #' @param b an initial estimate for the mean parameters. #' @param alpha an initial estimate for the correlation parameters. #' @param gm an initial estimate for the scale parameters. #' @param family a description of the error distribution and link #' function to be used in the model, as for \code{\link{glm}}. #' @param mean.link a character string specifying the link function #' for the means. The following are allowed: \code{"identity"}, #' \code{"logit"}, \code{"probit"}, \code{"cloglog"}, #' \code{"log"}, and \code{"inverse"}. The default value is #' determined from family. #' @param variance a character string specifying the variance function #' in terms of the mean. The following are allowed: #' \code{"gaussian"}, \code{"binomial"}, \code{"poisson"}, and #' \code{"gamma"}. The default value is determined from family. #' @param cor.link a character string specifying the link function for #' the correlation coefficients. The following are allowed: #' \code{"identity"}, and \code{"fisherz"}. #' @param sca.link a character string specifying the link function for #' the scales. The following are allowed: \code{"identity"}, and #' \code{"log"}. #' @param link.same a logical indicating if all the components in a #' cluster should use the same link. #' @param scale.fix a logical variable; if true, the scale parameter #' is fixed at the value of \code{scale.value}. #' @param scale.value numeric variable giving the value to which the #' scale parameter should be fixed; used only if \code{scale.fix #' == TRUE}. #' @param corstr a character string specifying the correlation #' structure. The following are permitted: \code{"independence"}, #' \code{"exchangeable"}, \code{"ar1"}, \code{"unstructured"}, #' \code{"userdefined"}, and \code{"fixed"} ## ' @param x,y \code{x} is a design matrix of dimension \code{n * p}, ## ' and \code{y} is a vector of observations of length \code{n}. ## ' @param offset,soffset vector of offset for the mean and for the ## ' scale, respectively. ## ' @param zsca a design matrix of dimension \code{n * r} for the ## ' scales. #' @param \dots further arguments passed to or from other methods. #' @return An object of class \code{"geese"} representing the fit. #' @author Jun Yan \email{jyan.stat@@gmail.com} #' @seealso \code{\link{glm}}, \code{\link{lm}}, \code{\link{ordgee}}. #' @references Yan, J. and J.P. Fine (2004) Estimating Equations for #' Association Structures. \emph{Statistics in Medicine}, #' \bold{23}, 859--880. #' @keywords nonlinear models #' @examples #' #' data(seizure) #' ## Diggle, Liang, and Zeger (1994) pp166-168, compare Table 8.10 #' seiz.l <- reshape(seizure, #' varying=list(c("base","y1", "y2", "y3", "y4")), #' v.names="y", times=0:4, direction="long") #' seiz.l <- seiz.l[order(seiz.l$id, seiz.l$time),] #' seiz.l$t <- ifelse(seiz.l$time == 0, 8, 2) #' seiz.l$x <- ifelse(seiz.l$time == 0, 0, 1) #' m1 <- geese(y ~ offset(log(t)) + x + trt + x:trt, id = id, #' data=seiz.l, corstr="exch", family=poisson) #' summary(m1) #' m2 <- geese(y ~ offset(log(t)) + x + trt + x:trt, id = id, #' data = seiz.l, subset = id!=49, #' corstr = "exch", family=poisson) #' summary(m2) #' ## Using fixed correlation matrix #' cor.fixed <- matrix(c(1, 0.5, 0.25, 0.125, 0.125, #' 0.5, 1, 0.25, 0.125, 0.125, #' 0.25, 0.25, 1, 0.5, 0.125, #' 0.125, 0.125, 0.5, 1, 0.125, #' 0.125, 0.125, 0.125, 0.125, 1), 5, 5) #' cor.fixed #' zcor <- rep(cor.fixed[lower.tri(cor.fixed)], 59) #' m3 <- geese(y ~ offset(log(t)) + x + trt + x:trt, id = id, #' data = seiz.l, family = poisson, #' corstr = "fixed", zcor = zcor) #' summary(m3) #' #' data(ohio) #' fit <- geese(resp ~ age + smoke + age:smoke, id=id, data=ohio, #' family=binomial, corstr="exch", scale.fix=TRUE) #' summary(fit) #' fit.ar1 <- geese(resp ~ age + smoke + age:smoke, id=id, data=ohio, #' family=binomial, corstr="ar1", scale.fix=TRUE) #' summary(fit.ar1) #' #' ###### simulated data #' ## a function to generate a dataset #' gendat <- function() { #' id <- gl(50, 4, 200) #' visit <- rep(1:4, 50) #' x1 <- rbinom(200, 1, 0.6) ## within cluster varying binary covariate #' x2 <- runif(200, 0, 1) ## within cluster varying continuous covariate #' phi <- 1 + 2 * x1 ## true scale model #' ## the true correlation coefficient rho for an ar(1) #' ## correlation structure is 0.667. #' rhomat <- 0.667 ^ outer(1:4, 1:4, function(x, y) abs(x - y)) #' chol.u <- chol(rhomat) #' noise <- as.vector(sapply(1:50, function(x) chol.u %*% rnorm(4))) #' e <- sqrt(phi) * noise #' y <- 1 + 3 * x1 - 2 * x2 + e #' dat <- data.frame(y, id, visit, x1, x2) #' dat #' } #' #' dat <- gendat() #' fit <- geese(y ~ x1 + x2, id = id, data = dat, sformula = ~ x1, #' corstr = "ar1", jack = TRUE, j1s = TRUE, fij = TRUE) #' summary(fit) #' #' #' #### create user-defined design matrix of unstrctured correlation. #' #### in this case, zcor has 4*3/2 = 6 columns, and 50 * 6 = 300 rows #' zcor <- genZcor(clusz = rep(4, 50), waves = dat$visit, "unstr") #' zfit <- geese(y ~ x1 + x2, id = id, data = dat, sformula = ~ x1, #' corstr = "userdefined", zcor = zcor, #' jack = TRUE, j1s = TRUE, fij = TRUE) #' summary(zfit) #' #' #### Now, suppose that we want the correlation of 1-2, 2-3, and 3-4 #' #### to be the same. Then zcor should have 4 columns. #' z2 <- matrix(NA, 300, 4) #' z2[,1] <- zcor[,1] + zcor[,4] + zcor[,6] #' z2[,2:4] <- zcor[, c(2, 3, 5)] #' summary(geese(y ~ x1 + x2, id = id, data = dat, sformula = ~ x1, #' corstr = "userdefined", zcor = z2, #' jack = TRUE, j1s = TRUE, fij = TRUE)) #' #' #### Next, we introduce non-constant cluster sizes by #' #### randomly selecting 60 percent of the data #' good <- sort(sample(1:nrow(dat), .6 * nrow(dat))) #' mdat <- dat[good,] #' #' summary(geese(y ~ x1 + x2, id = id, data = mdat, waves = visit, #' sformula = ~ x1, corstr="ar1", #' jack = TRUE, j1s = TRUE, fij = TRUE)) #' #' #' @export geese geese <- function(formula = formula(data), sformula = ~ 1, id, waves = NULL, data = parent.frame(), subset = NULL, na.action = na.omit, contrasts = NULL, weights = NULL, ## zcor is design matrix for alpha, ## corp is known paratemers to correlation coef. rho zcor = NULL, corp = NULL, ## zsca is constructed from sformula ## control parameters control = geese.control(...), ## param b = NULL, alpha = NULL, gm = NULL, ## geestr family = gaussian(), mean.link = NULL, variance = NULL, cor.link = "identity", sca.link = "identity", link.same = TRUE, scale.fix = FALSE, scale.value = 1.0, ## corr corstr = "independence", ...) { scall <- match.call() mnames <- c("", "formula", "data", "offset", "weights", "subset", "na.action", "id", "waves", "corp") cnames <- names(scall) cnames <- cnames[match(mnames,cnames,0)] mcall <- scall[cnames] if (is.null(mcall$id)) mcall$id <- as.name("id") mcall[[1]] <- as.name("model.frame") m <- eval(mcall, parent.frame()) y <- model.extract(m, "response") if (is.null(dim(y))) N <- length(y) else N <- dim(y)[1] mterms <- attr(m, "terms") x <- model.matrix(mterms, m, contrasts) offset <- model.extract(m, "offset") if (is.null(offset)) offset <- rep(0, N) w <- model.extract(m, "weights") if (is.null(w)) w <- rep(1, N) id <- model.extract(m, id) waves <- model.extract(m, "waves") corp <- model.extract(m, "corp") if (is.null(id)) stop("id variable not found.") ##print(control) ## setting up the scale model; ## borrowed idea from S+ function dglm by Gordon Smyth mcall$formula <- formula mcall$formula[3] <- switch(match(length(sformula), c(0,2,3)), 1, sformula[2], sformula[3]) m <- eval(mcall, parent.frame()) terms <- attr(m, "terms") zsca <- model.matrix(terms, m, contrasts) soffset <- model.extract(m, "offset") if (is.null(soffset)) soffset <- rep(0, N) if (is.character(family)) family <- get(family) if (is.function(family)) family <- family() ans <- geese.fit(x, y, id, offset, soffset, w, waves, zsca, zcor, corp, control, b, alpha, gm, family, mean.link, variance, cor.link, sca.link, link.same, scale.fix, scale.value, corstr, ...) ans <- c(ans, list(call=scall, formula=formula)) class(ans) <- "geese" ans } #' @export geese.fit <- function(x, y, id, offset=rep(0,N), soffset=rep(0,N), weights=rep(1,N), waves = NULL, zsca = matrix(1,N,1), zcor = NULL, corp = NULL, control = geese.control(...), ## param b = NULL, alpha = NULL, gm = NULL, ## geestr family = gaussian(), mean.link = NULL, variance = NULL, cor.link = "identity", sca.link = "identity", link.same = TRUE, scale.fix = FALSE, scale.value = 1.0, ## corr corstr = "independence", ...) { N <- length(id) ##clusz <- unlist(lapply(split(id, id), length)) clusnew <- c(which(diff(as.numeric(id)) != 0), length(id)) clusz <- c(clusnew[1], diff(clusnew)) maxclsz <- max(clusz) if (is.null(waves)) waves <- unlist(sapply(clusz, function(x) 1:x)) waves <- as.integer(waves) LINKS <- c("identity", "logit", "probit", "cloglog", "log", "inverse", "fisherz", "lwybc2", "lwylog") VARIANCES <- c("gaussian", "binomial", "poisson", "Gamma") ## quasi is not supported yet if (is.null(mean.link)) mean.link <- family$link if (is.null(variance)) variance <- family$family mean.link.v <- pmatch(mean.link, LINKS, -1, TRUE) cor.link.v <- pmatch(cor.link, LINKS, -1, TRUE) sca.link.v <- pmatch(sca.link, LINKS, -1, TRUE) variance.v <- pmatch(variance, VARIANCES, -1, TRUE) if (any(mean.link.v == -1)) stop("mean.link invalid.") if (any(cor.link.v == -1)) stop("cor.link invalid.") if (any(sca.link.v == -1)) stop("sca.link invalid.") if (any(variance.v == -1)) stop("variance invalid.") if (length(mean.link.v) != length(variance.v)) stop("mean.link and variance not same length.") if (length(mean.link.v) != length(sca.link.v)) stop("mean.link and sca.link not same lehgnt.") if (length(id) != length(y)) stop("id and y not same length.") if (length(offset) != length(y)) stop("offset and y not same length") if (length(soffset) != length(y)) stop("sca.offset and y not same length") if (nrow(zsca) != length(y)) stop("nrow(zsca) and length(y) not match") if (link.same) linkwaves <- rep(1, N) else { if (max(waves) != maxclsz) stop("maximum waves and maximum cluster size not equal") if (length(mean.link.v) != maxclsz) stop("length of mean.link not equal to the maximum cluster size.") linkwaves <- waves } linkwaves <- as.integer(linkwaves) geestr <- list(length(mean.link.v), as.integer(mean.link.v), as.integer(variance.v), as.integer(sca.link.v), as.integer(cor.link.v), as.integer(scale.fix)) CORSTRS <- c("independence", "exchangeable", "ar1", "unstructured", "userdefined", "fixed") corstrv <- pmatch(corstr, CORSTRS, -1) if (corstrv == -1) stop("invalid corstr.") corr <- list(as.integer(corstrv), maxclsz) if (is.null(zcor)) { if (corstrv == 5) stop("need zcor matrix for userdefined corstr.") else zcor <- genZcor(clusz, waves, corstrv) } else { if (!is.matrix(zcor)) zcor <- as.matrix(zcor) if (corstrv >= 4 && nrow(zcor) != sum(clusz * (clusz - 1) / 2)) stop("nrow(zcor) need to be equal sum(clusz * (clusz - 1) / 2) for unstructured or userdefined corstr.") if (corstrv %in% c(2,3) && nrow(zcor) != length(clusz)) stop("nrow(zcor) need to be equal to the number of clusters for exchangeable or ar1 corstr.") } if (!is.matrix(zcor)) zcor <- as.matrix(zcor) if (is.null(corp)) corp <- as.double(waves) p <- ncol(x) q <- ncol(zcor) r <- ncol(zsca) ## Initial values setup ## This may fail for binomial model with log link (relative risk) ## fit0 <- glm.fit(x, y, weights=weights, offset=offset, family=family) if (is.null(b)){ ##b <- rep(1,p) fit0 <- glm.fit(x, y, weights=weights, offset=offset, family=family) b <- fit0$coef } if (is.null(alpha)) { if (corstrv == 6) alpha <- 1 else alpha <- rep(0,q) } if (is.null(gm)) { ##gm <- rep(scale.value, r) qlf <- quasi(LINKS[sca.link.v])$linkfun ## pr2 <- (residuals.glm(fit0, type="pearson")) ^ 2 mu <- quasi(LINKS[mean.link.v])$linkinv(x %*% b) pr2 <- (y - mu) ^ 2 / family$variance(mu) gm <- lm.fit(zsca, qlf(pr2), offset = soffset)$coef } param <- list(b, alpha, gm) ans <- .Call("gee_rap", y, x, offset, soffset, weights, linkwaves, zsca, zcor, corp, clusz, geestr, corr, param, control, PACKAGE = "geepack") names(ans) <- c("beta", "alpha", "gamma", "vbeta", "valpha", "vgamma", "vbeta.naiv", "valpha.naiv", "valpha.stab", "vbeta.ajs", "valpha.ajs", "vgamma.ajs", "vbeta.j1s", "valpha.j1s", "vgamma.j1s", "vbeta.fij", "valpha.fij", "vgamma.fij", "error") ans$xnames <- dimnames(x)[[2]] ans$zsca.names <- dimnames(zsca)[[2]] ans$zcor.names <- dimnames(zcor)[[2]] if (is.null(ans$zcor.names)) ans$zcor.names = paste("alpha", 1:ncol(zcor), sep=":") names(ans$beta) <- ans$xnames names(ans$gamma) <- ans$zsca.names if (length(ans$alpha) > 0) names(ans$alpha) <- ans$zcor.names param <- list(ans$beta, ans$alpha, ans$gamma) infls <- .Call("infls_rap", y, x, offset, soffset, weights, linkwaves, zsca, zcor, corp, clusz, geestr, corr, param, control, PACKAGE = "geepack") rownames(infls) <- c(paste("beta", names(ans$beta), sep="_"), if (length(ans$gamma) > 0) paste("gamma", names(ans$gamma), sep="_") else NULL, if (length(ans$alpha) > 0) paste("alpha", names(ans$alpha), sep="_") else NULL) ans <- c(ans, list(infls=infls, clusz=clusz, control=control, model=list(mean.link=mean.link, variance=variance, sca.link=sca.link, cor.link=cor.link, corstr=corstr, scale.fix=scale.fix))) ans } #' @title Auxiliary for Controlling GEE Fitting #' #' @description Auxiliary function as user interface for `gee' fitting. Only used when #' calling `geese' or `geese.fit'. #' #' @details When `trace' is true, output for each iteration is printed to the screen by #' the c++ code. Hence, `options(digits = *)' does not control the precision. #' #' @param epsilon positive convergence tolerance epsilon; the #' iterations converge when the absolute value of the difference #' in parameter estimate is below \code{epsilon}. #' @param maxit integer giving the maximal number of Fisher Scoring #' iteration. #' @param trace logical indicating if output should be produced for #' each iteration. #' @param scale.fix logical indicating if the scale should be fixed. #' @param jack logical indicating if approximate jackknife variance #' estimate should be computed. #' @param j1s logical indicating if 1-step jackknife variance estimate #' should be computed. #' @param fij logical indicating if fully iterated jackknife variance #' estimate should be computed. #' @return A list with the arguments as components. #' @author Jun Yan \email{jyan.stat@@gmail.com} #' @seealso `geese.fit', the fitting procedure used by `geese'. #' @keywords optimize models #' #' @export geese.control geese.control <- function (epsilon = 1e-04, maxit = 25, trace = FALSE, scale.fix = FALSE, jack = FALSE, j1s = FALSE, fij = FALSE) { if (!is.numeric(epsilon) || epsilon <= 0) stop("value of epsilon must be > 0") if (!is.numeric(maxit) || maxit <= 0) stop("maximum number of iterations must be > 0") list(trace = as.integer(trace), jack = as.integer(jack), j1s = as.integer(j1s), fij = as.integer(fij), maxit = as.integer(maxit), epsilon = epsilon) } ## compare coefficients #' @title Compare Regression Coefficiente between Nested Models #' #' @description Comparing regression coefficients between models when one model is nested #' within another for clustered data. #' #' @param fit0 a fitted object of class \code{geese} #' @param fit1 another fitted object of class \code{geese} #' #' @return a list of two components: \item{delta}{estimated difference #' in the coefficients of common covariates from \code{fit0} and #' \code{fit1}} \item{variance}{estimated variance matrix of #' delta} #' @author Jun Yan \email{jyan.stat@@gmail.com} #' @references Allison, P. D. (1995). The impact of random predictors #' on comparisons of coefficients between models: Comment on #' Clogg, Petkova, and Haritou. \emph{American Journal of #' Sociology}, \bold{100}(5), 1294--1305. #' #' Clogg, C. C., Petkova, E., and Haritou, A. (1995). Statistical methods for #' comparing regression coefficients between models. \emph{American Journal of #' Sociology}, \bold{100}(5), 1261--1293. #' #' Yan, J., Aseltine, R., and Harel, O. (2011). Comparing Regression #' Coefficients Between Nested Linear Models for Clustered Data with #' Generalized Estimating Equations. \emph{Journal of Educational and #' Behaviorial Statistics}, Forthcoming. #' #' @keywords models #' @examples #' #' ## generate clustered data #' gendat <- function(ncl, clsz) { #' ## ncl: number of clusters #' ## clsz: cluster size (all equal) #' id <- rep(1:ncl, each = clsz) #' visit <- rep(1:clsz, ncl) #' n <- ncl * clsz #' x1 <- rbinom(n, 1, 0.5) ## within cluster varying binary covariate #' x2 <- runif(n, 0, 1) ## within cluster varying continuous covariate #' ## the true correlation coefficient rho for an ar(1) #' ## correlation structure is 2/3 #' rho <- 2/3 #' rhomat <- rho ^ outer(1:4, 1:4, function(x, y) abs(x - y)) #' chol.u <- chol(rhomat) #' noise <- as.vector(sapply(1:ncl, function(x) chol.u %*% rnorm(clsz))) #' y <- 1 + 3 * x1 - 2 * x2 + noise #' dat <- data.frame(y, id, visit, x1, x2) #' dat #' } #' #' simdat <- gendat(100, 4) #' fit0 <- geese(y ~ x1, id = id, data = simdat, corstr = "un") #' fit1 <- geese(y ~ x1 + x2, id = id, data = simdat, corstr = "un") #' compCoef(fit0, fit1) #' #' @export compCoef #' compCoef <- function(fit0, fit1) { v0 <- names(fit0$beta) v1 <- names(fit1$beta) v0idx <- (1:length(v0))[v0 %in% v1] v1idx <- (1:length(v1))[v1 %in% v0] delta <- fit0$beta[v0idx] - fit1$beta[v1idx] infls <- fit0$infls[v0idx,] - fit1$infls[v1idx,] robvar <- infls %*% t(infls) list(delta = delta, variance = robvar) } geepack/R/fixed2Zcor.R0000755000176200001440000000407514165262714014235 0ustar liggesusers## ## Generate zcor vector from ## 1) fixed correlation matrix ## 2) id information ## 3) waves information ## The zcor-vector contrains entries only for clusters ## of size larger than 1 #' @title Construct zcor vector #' #' @description Construct zcor vector (of fixed correlations) from a fixed #' working correlation matrix, a specification of clusters and a #' specifcation of waves. #' #' @param cor.fixed Matrix #' @param id Clusters #' @param waves Vector giving the ordering of observations within clusters. #' @return A vector which can be passed as the zcor argument to geeglm. #' @author Søren Højsgaard, \email{sorenh@@math.aau.dk} #' @seealso \code{\link{genZcor}}, \code{\link{geeglm}} #' @keywords regression #' @examples #' #' timeorder <- rep(1:5, 6) #' tvar <- timeorder + rnorm(length(timeorder)) #' idvar <- rep(1:6, each=5) #' uuu <- rep(rnorm(6), each=5) #' yvar <- 1 + 2*tvar + uuu + rnorm(length(tvar)) #' simdat <- data.frame(idvar, timeorder, tvar, yvar) #' head(simdat,12) #' #' simdatPerm <- simdat[sample(nrow(simdat)),] #' simdatPerm <- simdatPerm[order(simdatPerm$idvar),] #' head(simdatPerm) #' #' cor.fixed <- matrix(c(1 , 0.5 , 0.25, 0.125, 0.125, #' 0.5 , 1 , 0.25, 0.125, 0.125, #' 0.25 , 0.25 , 1 , 0.5 , 0.125, #' 0.125, 0.125, 0.5 , 1 , 0.125, #' 0.125, 0.125, 0.125, 0.125, 1 ), nrow=5, ncol=5) #' cor.fixed #' #' zcor <- fixed2Zcor(cor.fixed, id=simdatPerm$idvar, waves=simdatPerm$timeorder) #' zcor #' #' mod4 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="fixed", zcor=zcor) #' mod4 #' #' @export fixed2Zcor fixed2Zcor <- function(cor.fixed, id, waves){ zcor <- NULL cnt <- 1 uniq.id <- unique(id) for (ii in uniq.id){ cwaves <- waves[id==ii] if (length(cwaves) > 1) { for (kk in 1:(length(cwaves) - 1)){ for (mm in (kk + 1):length(cwaves)){ vvv <- cor.fixed[cwaves[mm], cwaves[kk]] zcor<-c(zcor, vvv) } } } } zcor } geepack/R/geeglm-anova.R0000755000176200001440000002441514165262714014560 0ustar liggesusersanovageePrim2 <- function(m1, m2,...){ mm1 <- model.matrix(m1) mm2 <- model.matrix(m2) P1 <- mm1 %*% solve(t(mm1)%*%mm1) %*% t(mm1) P2 <- mm2 %*% solve(t(mm2)%*%mm2) %*% t(mm2) e2 <- mm2 - P1 %*% mm2 e1 <- mm1 - P2 %*% mm1 m2inm1 <- all(apply(e2,2,var) < 1e-10) m1inm2 <- all(apply(e1,2,var) < 1e-10) if (!any(c(m2inm1,m1inm2))) cat("Models not nested\n") else if (all(c(m2inm1,m1inm2))) cat("Models are identical\n") else { if (m1inm2){ tmp <- m1 m1 <- m2 m2 <- tmp } ## Now mm2 < mm1 mm1 <- model.matrix(m1) mm2 <- model.matrix(m2) ## What is this? I wonder mf1 <- paste(paste(formula(m1))[c(2,1,3)],collapse=" ") mf2 <- paste(paste(formula(m2))[c(2,1,3)],collapse=" ") ## Reparametrize the model mm <- cbind(mm2,mm1) qmm <- qr(mm) qmmq <- qr.Q(qmm) nymm1 <- as.data.frame(qmmq[,1:qmm$rank]) colnames(nymm1) <- paste("parm",1:ncol(nymm1),sep=".") nymm2 <- nymm1[,1:ncol(mm2),drop=FALSE] formula1 <- formula(paste(formula(m1)[[2]],formula(m1)[[1]], paste(c("-1",colnames(nymm1)),collapse="+"),collapse="")) m1call <- m1$call ## BUGFIX provided by Stefan Boehringer ##nymm1[,paste(formula(m1call)[[2]])] <- m1$y nymm1[, paste(formula(m1)[[2]])] <- m1$y nymm1[,paste(m1call$id)] <- m1$id m1call$offset <- m1$offset m1call$weights <- m1$weights m1call$formula <- formula1 m1call$data <- nymm1 m1ny <- eval(m1call) ## Calculate wald statistic beta <- coef(m1ny) vbeta <- summary(m1ny)$cov.unscaled df <- dim(mm1)[2] - dim(mm2)[2] rbeta <- rep(1, length(beta)) rbeta[1:df] <- 0 beta0 <- rev(rbeta) zeroidx <- beta0 == 0 ##X2 <- t(beta[zeroidx]) %*% solve(vbeta[zeroidx, zeroidx, drop=FALSE]) %*% beta[zeroidx] ##X2 <- t(beta[zeroidx]) %*% solve(vbeta[zeroidx, zeroidx, drop=FALSE], beta[zeroidx]) ## FIX; February 2017: Use generalized inverse instead: ## FIXME: Somehow the formal dof's should also be written V0 <- vbeta[zeroidx, zeroidx, drop=FALSE] b0 <- beta[zeroidx] ##bv <<- list(b0=b0, V0=V0) ##X2 <- t(b0) %*% solve(V0, b0) X2 <- as.numeric( t(b0) %*% ginv(V0) %*% b0) ev <- eigen(V0, only.values=TRUE)$values df.real <- sum(ev > 1e-12) ## Make table with results topnote <- paste("Model 1", mf1,"\nModel 2", mf2) title <- "Analysis of 'Wald statistic' Table\n" table <- data.frame(Df=df.real, X2=X2, p=1 - pchisq(X2, df.real)) dimnames(table) <- list("1", c("Df", "X2", "P(>|Chi|)")) val <- structure(table, heading = c(title, topnote), class = c("anova", "data.frame")) return(val) } } anova.geeglmlist <- function (object, ..., dispersion = NULL, test = NULL) { responses <- as.character(lapply(object, function(x) { deparse(formula(x)[[2]]) })) sameresp <- responses == responses[1] if (!all(sameresp)) { object <- object[sameresp] warning("Models with response ", deparse(responses[!sameresp]), " removed because response differs from ", "model 1") } ns <- sapply(object, function(x) length(x$residuals)) if (any(ns != ns[1])) stop("models were not all fitted to the same size of dataset") objects <- list(object,...) m1 <- objects[[1]][[1]] if (length(objects[[1]])>1) m2 <- objects[[1]][[2]] else m2 <- NULL value <- anovageePrim2(m1,m2) return(value) } #' @export anova.geeglm<-function (object, ..., dispersion = NULL, test = NULL) { dotargs <- list(...) named <- if (is.null(names(dotargs))) rep(FALSE, length(dotargs)) else (names(dotargs) != "") if (any(named)) warning("The following arguments to anova.glm(..) are invalid and dropped: ", paste(deparse(dotargs[named]), collapse = ", ")) dotargs <- dotargs[!named] is.glm <- unlist(lapply(dotargs, function(x) inherits(x, "glm"))) dotargs <- dotargs[is.glm] if (length(dotargs) > 0) return(anova.geeglmlist(c(list(object), dotargs), dispersion = dispersion, test = test)) varlist <- attr(object$terms, "variables") ##print(varlist) x <- if (n <- match("x", names(object), 0)) object[[n]] else model.matrix(object) varseq <- attr(x, "assign") nvars <- max(0, varseq) betaList <- vbetaList <- NULL if (nvars > 1) { method <- object$method if (!is.function(method)) method <- get(method, mode = "function", envir = parent.frame()) for (i in 1:(nvars - 1)) { eprint("calling fit....") ##print(length(object$y)) fit <- method(x = x[, varseq <= i, drop = FALSE], y = object$y, weights = object$prior.weights, corstr = object$corstr, start = object$start, offset = object$offset, id=object$id, family = object$family, control = object$control) betaList <- c(betaList,list(fit$beta)) vbetaList <- c(vbetaList,list(fit$vbeta)) } } betaList <- c(betaList, list( object$geese$beta )) vbetaList <- c(vbetaList, list( object$geese$vbeta )) hasIntercept <- (length(grep("(Intercept)",names(betaList[[1]])))!=0) dimVec <- unlist(lapply(betaList,length)) if (hasIntercept){ dfVec <- dimVec[1]-1 } else { dfVec <- dimVec[1] } if (length(dimVec)>1){ for (i in 2:length(dimVec)) dfVec <- c(dfVec,dimVec[i]-dimVec[i-1]) } ##print(dfVec) X2Vec <- NULL ## Calculate Wald statistics for (i in 1:length(dfVec)){ beta <- betaList[[i]] vbeta <- vbetaList[[i]] beta0 <- rep(1,length(beta)) beta0[1:dfVec[i]] <- 0 beta0 <- rev(beta0) zeroidx <- beta0==0 X2 <- t(beta[zeroidx])%*%solve(vbeta[zeroidx,zeroidx,drop=FALSE])%*%beta[zeroidx] X2Vec <- c(X2Vec,X2) } resdf <- dfVec resdev <- X2Vec table <- data.frame(resdf, resdev, 1-pchisq(resdev,resdf)) tl <- attr(object$terms, "term.labels") #print(table) if (length(tl) == 0) table <- table[1, , drop = FALSE] dimnames(table) <- list(c(tl), c("Df", "X2", "P(>|Chi|)")) title <- paste("Analysis of 'Wald statistic' Table", "\nModel: ", object$family$family, ", link: ", object$family$link, "\nResponse: ", as.character(varlist[-1])[1], "\nTerms added sequentially (first to last)\n", sep = "") structure(table, heading = title, class = c("anova", "data.frame")) } # anova.geeglm <- function(object, ...){ # anovaPgee (object, ...) # } # anovaPgee <- function(object, ...){ # #cat("anova.gee\n") # m1 <- object # objects <- list(object,...) # if (length(objects)>1) # m2 <- objects[[2]] # else # m2 <- NULL # if (is.null(m2)){ # term <- attr(object$terms,"term.labels") # resp <- paste(formula(object))[2] # rhs <- lapply(1:length(term), function(i) paste(term[1:i],collapse=" + ")) # print(rhs) # model.list <- c(paste(resp,"~ 1"), paste(resp,"~", rhs)) # value <- NULL # for (i in 2:length(model.list)){ # if (i==2){ # mf1 <- model.list[i-1] # mf2 <- model.list[i] # ##print(mf1); print(mf2) # #print(mf1) # #print(object) # m1 <- update(object,formula=as.formula(mf1)) # m2 <- update(object,formula=as.formula(mf2)) # } else { # m1 <- m2 # m2 <- update(object,formula=as.formula(model.list[i])) # ##print(formula(m1)[1:3]); print(formula(m2)[1:3]) # } # value <- rbind(value,anovageePrim(m1,m2)) # } # rownames(value) <- term # attr(value,"model1") <- NULL # attr(value,"model2") <- NULL # } else { # value <- anovageePrim(object,m2) # } # value[,3] <- round(value[,3],5) # return(value) # } # anovageePrim <- function(m1, m2,...){ # mm1 <- model.matrix(m1) # mm2 <- model.matrix(m2) # P1 <- mm1 %*% solve(t(mm1)%*%mm1) %*% t(mm1) # P2 <- mm2 %*% solve(t(mm2)%*%mm2) %*% t(mm2) # e2 <- mm2 - P1 %*% mm2 # e1 <- mm1 - P2 %*% mm1 # #print(mm1[c(1:5,100:105),]); print(mm2[c(1:5,100:105),]) # m2inm1 <- all(apply(e2,2,var) < 1e-10) # m1inm2 <- all(apply(e1,2,var) < 1e-10) # #print(apply(e2,2,var)) # #print(apply(e1,2,var)) # #print(m2inm1) # #print(m1inm2) # if (!any(c(m2inm1,m1inm2))) # cat("Models not nested\n") # else # if (all(c(m2inm1,m1inm2))) # cat("Models are identical\n") # else { # if (m1inm2){ # tmp <- m1 # m1 <- m2 # m2 <- tmp # } # mm1 <- model.matrix(m1) # mm2 <- model.matrix(m2) # mf1 <- paste(paste(formula(m1))[c(2,1,3)],collapse=" ") # mf2 <- paste(paste(formula(m2))[c(2,1,3)],collapse=" ") # mm <- cbind(mm2,mm1) # qmm <- qr(mm) # qmmq <- qr.Q(qmm) # nymm1 <- as.data.frame(qmmq[,1:qmm$rank]) # colnames(nymm1) <- paste("parm",1:ncol(nymm1),sep=".") # nymm2 <- nymm1[,1:ncol(mm2),drop=FALSE] # dimDiff <- ncol(nymm1)-ncol(nymm2) # D <- diag(dimDiff) # L <- cbind(matrix(0,ncol=ncol(nymm2),nrow=nrow(D)),D) # formula1 <- formula(paste(formula(m1)[[2]],formula(m1)[[1]], # paste(c("-1",colnames(nymm1)),collapse="+"),collapse="")) # m1call <- m1$call # #print(formula(m1call)[[2]]) # #print(nymm1[1:10,]) # #print(paste(m1call$formula[[2]])) # #nymm1[,paste(m1call$formula[[2]])] <- m1$y # nymm1[,paste(formula(m1call)[[2]])] <- m1$y # nymm1[,paste(m1call$id)] <- m1$id # m1call$offset <- m1$offset # m1call$weights <- m1$weights # m1call$formula <- formula1 # m1call$data <- nymm1 # m1ny <- eval(m1call) # #print(class(m1ny)) # val <- esticon(m1ny,L,joint.test=TRUE) # rownames(val)<-"" # class(val) <- c("anova.gee","data.frame") # attr(val,"model1") <- mf1 # attr(val,"model2") <- mf2 # return(val) # } # } # print.anova.geeglm <- function(x,...){ # cat("Analysis table for GEE models\n\n") # if (!is.null(attr(x,"model1"))){ # cat("Model 1: "); cat(attr(x,"model1"), "\n") # cat("Model 2: "); cat(attr(x,"model2"), "\n\n") # } # print.data.frame(x) # } geepack/R/qic.R0000644000176200001440000002652014165262714012766 0ustar liggesusers#' Quasi Information Criterion #' #' Function for calculating the quasi-likelihood under the independence model #' information criterion (QIC), quasi-likelihood, correlation information #' criterion (CIC), and corrected QIC for one or several fitted geeglm model #' object from the geepack package. #' #' QIC is used to select a correlation structure. The QICu is used to compare #' models that have the same working correlation matrix and the same #' quasi-likelihood form but different mean specifications. CIC has been #' suggested as a more robust alternative to QIC when the model for the mean #' may not fit the data very well and when models with different correlation #' structures are compared. #' #' Models with smaller values of QIC, CIC, QICu, or QICC are preferred. #' #' If the MASS package is loaded then the \code{\link{ginv}} function is used #' for matrix inversion. Otherwise the standard \code{\link{solve}} function is #' used. #' #' @aliases QIC QIC.geeglm QIC.geekin QIC.ordgee #' @param object a fitted GEE model from the geepack #' package. Currently only works on geeglm objects #' @param tol the tolerance used for matrix inversion #' @param \dots optionally more fitted geeglm model objects #' @return A vector or matrix with the QIC, QICu, quasi likelihood, #' CIC, the number of mean effect parameters, and the corrected #' QIC for each GEE object #' @author Claus Ekstrom \email{claus@@rprimer.dk} #' @seealso \code{geeglm} #' @references Pan, W. (2001). \emph{Akaike's information criterion in #' generalized estimating equations}. Biometrics, 57, 120-125.\cr #' Hardin, J.W. and Hilbe, J.M. (2012). \emph{Generalized #' Estimating Equations, 2nd Edition}, Chapman and Hall/CRC: New #' York. \cr #' #' Hin, L.-Y. and Wang, Y-G. #' (2009). \emph{Working-correlation-structure identification in #' generalized estimating equations}, Statistics in Medicine 28: #' 642-658. \cr Thall, P.F. and Vail, S.C. (1990). \emph{Some #' Covariance Models for Longitudinal Count Data with #' Overdispersion}. Biometrics, 46, 657-671. #' @keywords htest #' @examples #' #' library(geepack) #' data(ohio) #' fit <- geeglm(resp ~ age + smoke + age:smoke, id=id, data=ohio, #' family=binomial, corstr="exch", scale.fix=TRUE) #' QIC(fit) #' #' @rdname QIC #' @export QIC.geeglm <- function(object, tol=.Machine$double.eps, ...) { # # The majority of this code was taken from the internet # I added a bit of functionality and made the whole interface smoother if (! ("geeglm" %in% class(object)) ) { stop("QIC requires a geeglm object as input") } # Setup functions invert <- if ("MASS" %in% loadedNamespaces()) { MASS::ginv } else { solve } # Missing: # Check correct handling of link and family functions # Create function to make the computations computeqic <- function(object) { # Fitted and observed values for quasi likelihood mu <- object$fitted.values y <- object$y # Quasi Likelihood for Poisson # quasi.R <- sum((y*log(mu.R)) - mu.R) # poisson()$dev.resids - scale and weights = 1 type <- family(object)$family quasi <- switch(type, poisson = sum((y*log(mu)) - mu), gaussian = sum(((y - mu)^2)/-2), binomial = sum(y*log(mu/(1 - mu)) + log(1 - mu)), Gamma = sum(-y/(mu - log(mu))), stop("Error: distribution not recognized")) # Fit model with independence correlation structure object$call$corstr <- "independence" object$call$zcor <- NULL model.indep <- eval(object, parent.frame()) # model.indep <- update(object, corstr="independence",zcorr=NULL) # Trace term (penalty for model complexity) AIinverse <- invert(model.indep$geese$vbeta.naiv, tol=tol) Vr <- object$geese$vbeta trace <- sum(diag(AIinverse %*% Vr)) params <- length(coef(object)) # Mean parameters in the model kpm <- params+length(object$geese$alpha) # QIC QIC <- -2*(quasi - trace) QICu <- -2*(quasi - params) QICC <- QIC + (2*kpm*(kpm+1))/(length(object$residuals)-kpm-1) output <- c(QIC, QICu, quasi, trace, params, QICC) names(output) <- c("QIC", "QICu", "Quasi Lik", "CIC", "params", "QICC") output } if (length(list(...))) { # Make the computations results <- lapply(list(object, ...), computeqic) # Check same data size check <- sapply(list(object, ...), function(x) { length(x$y) }) if (any(check != check[1])) warning("models are not all fitted to the same number of observations") # Merge the results together in a data.matrix res <- do.call("rbind", results) # Set the row names corresponding to the models Call <- match.call() Call$k <- NULL row.names(res) <- as.character(Call[-1L]) res } else { computeqic(object) } } #' @rdname QIC #' @export QIC.ordgee <- function(object, tol = .Machine$double.eps, ...) { # # The majority of this code was taken from the internet # I added a bit of functionality and made the whole interface smoother if (! ("geeglm" %in% class(object)) ) { stop("QIC requires a geeglm object as input") } # Setup functions invert <- if ("MASS" %in% loadedNamespaces()) { MASS::ginv } else { solve } # Missing: # Check correct handling of link and family functions # Create function to make the computations computeqic <- function(object) { # Fitted and observed values for quasi likelihood mu <- object$fitted.values y <- object$y # Quasi Likelihood for Poisson # quasi.R <- sum((y*log(mu.R)) - mu.R) # poisson()$dev.resids - scale and weights = 1 type <- family(object)$family quasi <- switch(type, poisson = sum((y*log(mu)) - mu), gaussian = sum(((y - mu)^2)/-2), binomial = sum(y*log(mu/(1 - mu)) + log(1 - mu)), Gamma = sum(-y/(mu - log(mu))), stop("Error: distribution not recognized")) # Fit model with independence correlation structure object$call$corstr <- "independence" object$call$zcor <- NULL model.indep <- eval(object, parent.frame()) # model.indep <- update(object, corstr="independence",zcorr=NULL) # Trace term (penalty for model complexity) AIinverse <- invert(model.indep$geese$vbeta.naiv) Vr <- object$geese$vbeta trace <- sum(diag(AIinverse %*% Vr)) params <- length(coef(object)) # Mean parameters in the model kpm <- params+length(object$geese$alpha) # QIC QIC <- -2*(quasi - trace) QICu <- -2*(quasi - params) QICC <- QIC + (2*kpm*(kpm+1))/(length(object$residuals)-kpm-1) output <- c(QIC, QICu, quasi, trace, params, QICC) names(output) <- c("QIC", "QICu", "Quasi Lik", "CIC", "params", "QICC") output } if (length(list(...))) { # Make the computations results <- lapply(list(object, ...), computeqic) # Check same data size check <- sapply(list(object, ...), function(x) { length(x$y) }) if (any(check != check[1])) warning("models are not all fitted to the same number of observations") # Merge the results together in a data.matrix res <- do.call("rbind", results) # Set the row names corresponding to the models Call <- match.call() Call$k <- NULL row.names(res) <- as.character(Call[-1L]) res } else { computeqic(object) } } ## QIC.binomial <- function(object, ...) { ## # ## # The majority of this code was taken from the internet ## # I added a bit of functionality and made the whole interface smoother ## if (! ("geese" %in% class(object)) ) { ## stop("QIC requires a geese object as input") ## } ## # Setup functions ## invert <- if ("MASS" %in% loadedNamespaces()) { ## MASS:::ginv ## } else { solve } ## # Missing: ## # Check correct handling of link and family functions ## # Create function to make the computations ## computeqic <- function(object) { ## # Fitted and observed values for quasi likelihood ## # Compute the linear predictor ## glmcall <- object$call ## glmcall$id <- glmcall$jack <- glmcall$control <- glmcall$corstr <- glmcall$waves <- glmcall$zcor <- glmcall$std.err <- glmcall$scale.fix <- glmcall$scale.value<- glmcall$z <- glmcall$family <- NULL ## glmcall[[1]] <- as.name("model.frame") ## mf <- eval(glmcall, parent.frame()) ## X <- model.matrix(formula(object), data=mf) ## N <- nrow(X) ## offset <- model.offset(mf) ## if (is.null(offset)) ## offset <- rep(0, N) ## if (is.null(object$call$offset)) ## mu <- as.vector(X %*% object$beta) else mu <- offset + X %*% object$beta ## y <- as.numeric(levels(mf[,1]))[mf[,1]] ## if (length(unique(y))!=2) ## stop("QIC.binomial only works for binary data") ## # Quasi Likelihood for Poisson ## # quasi.R <- sum((y*log(mu.R)) - mu.R) # poisson()$dev.resids - scale and weights = 1 ## # type <- family(object)$family ## type <- "binomial" ## quasi <- switch(type, ## poisson = sum((y*log(mu)) - mu), ## gaussian = sum(((y - mu)^2)/-2), ## binomial = sum(y*mu + log(1 - exp(mu)/(1+exp(mu)))), ## Gamma = sum(-y/(mu - log(mu))), ## stop("Error: distribution not recognized")) ## # Fit model with independence correlation structure ## object$call$corstr <- "independence" ## object$call$zcor <- object$call$z <- NULL ## model.indep <- eval(object$call, parent.frame()) ## # model.indep <- update(object, corstr="independence") ## # Trace term (penalty for model complexity) ## AIinverse <- invert(model.indep$vbeta.naiv) ## Vr <- object$vbeta ## trace <- sum(diag(AIinverse %*% Vr)) ## params <- length(object$beta) # Mean parameters in the model ## kpm <- params+length(object$alpha) ## # QIC ## QIC <- -2*(quasi - trace) ## QICu <- -2*(quasi - params) ## QICC <- QIC - (2*kpm*(kpm+1))/(length(object$residuals)-kpm-1) ## output <- c(QIC, QICu, quasi, trace, params, QICC) ## names(output) <- c("QIC", "QICu", "Quasi Lik", "CIC", "params", "QICC") ## output ## } ## if (length(list(...))) { ## # Make the computations ## results <- lapply(list(object, ...), computeqic) ## # Check same data size ## check <- sapply(list(object, ...), function(x) { ## n <- length(x$y) ## }) ## if (any(check != check[1])) ## warning("models are not all fitted to the same number of observations") ## # Merge the results together in a data.matrix ## res <- do.call("rbind", results) ## # Set the row names corresponding to the models ## Call <- match.call() ## Call$k <- NULL ## row.names(res) <- as.character(Call[-1L]) ## res ## } else { ## computeqic(object) ## } ## } #' @rdname QIC #' @export QIC.geekin <- function(object, tol = .Machine$double.eps, ...) { # This functions is only needed to replace class # geeglm to make sure the regular # QIC function works if (! ("geeglm" %in% class(object)) ) { stop("QIC requires a geekin object as input") } object$call[[1]] <- as.name("geeglm") object$call$varlist <- NULL object$call$na.action <- NULL # Swap class around class(object) <- c("geeglm", unique(class(object))) QIC(object) } #' @rdname QIC #' @export QIC <- function(object, tol = .Machine$double.eps, ...) { UseMethod("QIC") } geepack/R/ordgee.R0000755000176200001440000002511114165262714013455 0ustar liggesusers#' @title GEE for Clustered Ordinal Responses #' #' @description Produces an object of class `geese' which is a #' Generalized Estimating Equation fit of the clustered ordinal #' data. #' #' #' @param formula a formula expression as for \code{glm}, of the form #' \code{response ~ predictors}. See the documentation of lm and #' formula for details. As for glm, this specifies the linear #' predictor for modelling the mean. A term of the form #' \code{offset(expression)} is allowed. #' @param ooffset vector of offset for the odds ratio model. #' @param id a vector which identifies the clusters. The length of #' `id' should be the same as the number of observations. Data #' are assumed to be sorted so that observations on a cluster are #' contiguous rows for all entities in the formula. #' @param waves an integer vector which identifies components in #' clusters. The length of \code{waves} should be the same as the #' number of observation. components with the same \code{waves} #' value will have the same link functions. #' @param data an optional data frame in which to interpret the #' variables occurring in the \code{formula}, along with the #' \code{id} and \code{n} variables. #' @param subset expression saying which subset of the rows of the #' data should be used in the fit. This can be a logical vector #' (which is replicated to have length equal to the number of #' observations), or a numeric vector indicating which observation #' numbers are to be included, or a character vector of the row #' names to be included. All observations are included by #' default. #' @param na.action a function to filter missing data. For \code{gee} #' only \code{na.omit} should be used here. #' @param contrasts a list giving contrasts for some or all of the #' factors appearing in the model formula. The elements of the #' list should have the same name as the variable and should be #' either a contrast matrix (specifically, any full-rank matrix #' with as many rows as there are levels in the factor), or else a #' function to compute such a matrix given the number of levels. #' @param weights an optional vector of weights to be used in the #' fitting process. The length of \code{weights} should be the #' same as the number of observations. #' @param z a design matrix for the odds ratio model. The number of #' rows of z is \deqn{c^2 \sum n_i(n_i - 1)/2,} where \eqn{n_i} is #' the cluster size, and \eqn{c} is the number of categories minus #' 1. #' @param mean.link a character string specifying the link function #' for the means. The following are allowed: \code{"logit"}, #' \code{"probit"}, and \code{"cloglog"}. #' @param corstr a character string specifying the log odds. The #' following are allowed: \code{"independence"}, #' \code{"exchangeable"}, \code{"unstructured"}, and #' \code{"userdefined"}. #' @param control a list of iteration and algorithmic constants. See #' \code{\link{geese.control}} for their names and default #' values. These can also be set as arguments to \code{geese} #' itself. #' @param b an initial estimate for the mean parameters. #' @param alpha an initial estimate for the odds ratio parameters. #' @param scale.fix a logical variable indicating if scale is fixed; #' it is set at TRUE currently (it can not be FALSE yet!). #' @param scale.val this argument is ignored currently. #' @param int.const a logical variable; if true, the intercepts are #' constant, and if false, the intercepts are different for #' different components in the response. #' @param rev a logical variable. For example, for a three level #' ordered response Y = 2, the accumulated indicator is coded as #' (1, 0, 0) if true and (0, 1, 1) if false. #' @param \dots further arguments passed to or from other methods. #' @return An object of class \code{"geese"} representing the fit. #' @author Jun Yan \email{jyan.stat@@gmail.com} #' @seealso \code{\link{glm}}, \code{\link{lm}}, \code{\link{geese}}. #' @references Heagerty, P.J. and Zeger, S.L. (1996) Marginal #' regression models for clustered ordinal measurements. #' \emph{JASA}, \bold{91} 1024--1036. #' @keywords nonlinear models #' @examples #' #' data(respdis) #' resp.l <- reshape(respdis, varying =list(c("y1", "y2", "y3", "y4")), #' v.names = "resp", direction = "long") #' resp.l <- resp.l[order(resp.l$id, resp.l$time),] #' fit <- ordgee(ordered(resp) ~ trt, id=id, data=resp.l, int.const=FALSE) #' summary(fit) #' #' data(ohio) #' ohio$resp <- ordered(as.factor(ohio$resp)) #' fit <- ordgee(resp ~ age + smoke + age:smoke, id = id, data=ohio) #' summary(fit) #' #' @export ordgee ordgee <- function(formula = formula(data), ooffset = NULL, id, waves = NULL, data=parent.frame, subset=NULL, na.action=na.omit, contrasts=NULL, weights=NULL, z=NULL, ##family=binomial(), mean.link="logit", corstr="independence", control=geese.control(...), b=NA, alpha=NA, scale.fix=TRUE, scale.val=1, int.const=TRUE, rev=FALSE, ##rev TRUE for coding in HZ 1996. ...) { ### y is sum(n_i) * c x 1 ### x is sum(n_i) * c x (p + c) scall <- match.call() mnames <- c("", "formula", "data", "offset", "weights", "subset", "id", "waves") cnames <- names(scall) cnames <- cnames[match(mnames,cnames,0)] mcall <- scall[cnames] if (is.null(mcall$id)) mcall$id <- as.name("id") mcall[[1]] <- as.name("model.frame") m <- eval(mcall, parent.frame()) id <- model.extract(m, "id") ## N <- length(unique(id)) clusz <- unlist(lapply(split(id, id), length)) maxclsz <- max(clusz) if (is.null(waves)) waves <- unlist(sapply(clusz, function(x) 1:x)) else waves <- model.extract(m, "waves") # if (is.na(b)){ # foo <- polr(formula, data, ...) # b <- c(foo$zeta, foo$coef) # } y <- model.extract(m, "response") if (length(y) != length(id)) stop("response and id are not of the same length.") if (class(y)[1] != 'ordered') stop("response is not an ordered factor.") lev <- levels(y) nlev <- length(lev) ncat <- nlev - 1 y <- unclass(y) Y <- rep(y, rep(ncat, sum(clusz))) if (rev) Y <- as.double(Y <= rep(1:ncat, sum(clusz))) else Y <- as.double(Y > rep(1:ncat, sum(clusz))) mterms <- attr(m, "terms") x <- model.matrix(mterms, m, contrasts) xvars <- as.character(attr(mterms, "variables"))[-1] if ((yvar <- attr(mterms, "response")) > 0) xvars <- xvars[-yvar] xlev <- if (length(xvars) > 0) { xlev <- lapply(m[xvars], levels) xlev[!sapply(xlev, is.null)] } xint <- match("(Intercept)", colnames(x), nomatch = 0) n <- nrow(x) pc <- ncol(x) if (xint > 0) { x <- x[, -xint, drop = FALSE] pc <- pc - 1 } else warning("an intercept is needed and assumed") ind <- gl(sum(clusz), ncat) x <- x[ind,, drop=FALSE] if (int.const) { xc <- matrix(diag(ncat), sum(clusz) * ncat, ncat, byrow=TRUE) colnames(xc) <- paste("Inter", lev[1:ncat], sep=":") } else { foo <- sapply(waves, function(x, maxclsz, ncat) { bar <- matrix(0, maxclsz*ncat, ncat) bar[(x-1)*ncat + 1:ncat,] <- diag(ncat) bar }, maxclsz=maxclsz, ncat=ncat) xc <- matrix(unlist(foo), ncol=maxclsz*ncat, byrow=TRUE) colnames(xc) <- paste("Inter", paste(rep(1:maxclsz, rep(ncat, maxclsz)), rep(lev[1:ncat], maxclsz), sep=":"), sep=":") ##b <- c(rep(b[1:ncat], maxclsz), b[-(1:ncat)]) } xmat <- cbind(xc, x) # note the negate sign!!! p <- ncol(xmat) offset <- model.extract(m, "offset") if (is.null(offset)) offset <- rep(0, length(id)) offset <- - rep(offset, rep(ncat, sum(clusz))) w <- model.extract(m, "weights") if (is.null(w)) w <- rep(1, length(id)) w <- rep(w, rep(ncat, sum(clusz))) CORSTRS <- c("independence", "exchangeable", "NA_ar1", "unstructured", "userdefined") CORSTRS.ALLOWED <- c("independence", "exchangeable", "unstructured", "userdefined") corstrv <- pmatch(corstr, CORSTRS.ALLOWED, -1) if (corstrv == -1) stop("invalid corstr.") corstrv <- pmatch(corstr, CORSTRS) corr <- list(as.integer(corstrv), maxclsz) if (is.null(ooffset)) ooffset <- rep(0, sum(clusz*(clusz-1)/2) * ncat^2) if (is.null(z)) { if (corstrv == 5) stop("need z matrix for userdefined corstr.") else z <- genZodds(clusz, waves, corstrv, ncat) } if (length(ooffset) != sum(clusz*(clusz-1)/2) * ncat^2) stop("length(ooffset) != sum(clusz*(clusz-1)) * ncat^2 detected.") if (corstrv > 1 && nrow(z) != sum(clusz*(clusz-1)/2) * ncat^2) stop("nrow(z) != sum(clusz*(clusz-1)) * ncat^2 detected.") waves <- rep(waves, rep(ncat, sum(clusz))) if (is.null(id)) stop("ID variable not found.") LINKS <- c("NA_identity", "logit", "probit", "cloglog", "NA_log", "NA_inverse", "NA_fisherz", "NA_lwybc2", "NA_lwylog") LINKS.ALLOWED <- c("logit", "probit", "cloglog") mean.link.v <- pmatch(mean.link, LINKS.ALLOWED, -1) if (mean.link.v == -1) stop("mean.link invalid.") mean.link.v <- pmatch(mean.link, LINKS, -1) geestr <- list(maxwave=maxclsz, mean.link=rep(mean.link.v, maxclsz), variance=rep(2, maxclsz), sca.link=rep(1, maxclsz), cor.link=5, scale.fix=as.integer(scale.fix)) p <- ncol(xmat) q <- ncol(z) if (!is.matrix(z)) z <- as.matrix(z) if (is.na(b)) { link <- mean.link b <- glm.fit(xmat, Y, w, family=binomial(link))$coef } if (is.na(alpha)) alpha <- rep(0,q); param <- list(b, alpha, gm=rep(scale.val, 1)) ans <- .Call("ordgee_rap", Y, xmat, offset, ooffset, w, waves, z, clusz, ncat, rev, geestr, corr, param, control, PACKAGE = "geepack") names(ans) <- c("beta", "alpha", "gamma", "vbeta", "valpha", "vgamma", "vbeta.naiv", "valpha.naiv", "valpha.stab", "vbeta.ajs", "valpha.ajs", "vgamma.ajs", "vbeta.j1s", "valpha.j1s", "vgamma.j1s", "vbeta.fij", "valpha.fij", "vgamma.fij", "error") ans$xnames <- dimnames(xmat)[[2]] ans$zcor.names <- dimnames(z)[[2]] names(ans$beta) <- ans$xnames names(ans$alpha) <- ans$zcor.names ans <- c(ans, list(call=scall, clusz=clusz, control=control, model=list(mean.link=mean.link, variance="binomial", sca.link=NULL, cor.link="log", corstr=corstr, scale.fix=scale.fix))) class(ans) <- "geese" ans } geepack/R/geepack-package.R0000755000176200001440000000045414165262714015203 0ustar liggesusers #' Internal geepack functions #' #' Internal functions called by other functions. #' #' #' @aliases anova.geeglm anovageePrim2 anova.geeglmlist plot.geeglm #' print.geeglm eprint print.summary.geeglm residuals.geeglm #' summary.geeglm crossutri genZodds #' #' #' @keywords internal geepack/R/NAMESPACE.R0000644000176200001440000000106114165262714013477 0ustar liggesusers#' @useDynLib geepack #' @import methods #' @importFrom MASS ginv #' #' @importFrom graphics abline lines plot #' #' @importFrom stats binomial coef fitted formula gaussian #' glm.fit is.empty.model lm.fit lowess #' model.extract model.matrix model.offset #' model.response model.weights na.omit naresid #' pchisq printCoefmat quasi residuals summary.glm #' var family #' #' @importFrom utils head str #' @importFrom broom tidy #' @export tidy #' @importFrom magrittr %>% #' @export %>% .dumfunction_afterimportFrom <- function(){} geepack/R/summary.R0000755000176200001440000001106514165262714013710 0ustar liggesusers#' @export summary.geese <- function(object, ...) { mean.sum <- data.frame(estimate = object$beta, # nai.se = sqrt(diag(object$vbeta.naiv)), san.se = sqrt(diag(object$vbeta)), ajs.se = sqrt(diag(object$vbeta.ajs)), j1s.se = sqrt(diag(object$vbeta.j1s)), fij.se = sqrt(diag(object$vbeta.fij))) mean.sum$wald <- (mean.sum$estimate / mean.sum$san.se)^2 mean.sum$p <- 1 - pchisq(mean.sum$wald, df=1) rownames(mean.sum) <- object$xnames corr.sum <- data.frame(estimate = object$alpha, # nai.se = sqrt(diag(object$valpha.naiv)), san.se = sqrt(diag(object$valpha)), ajs.se = sqrt(diag(object$valpha.ajs)), j1s.se = sqrt(diag(object$valpha.j1s)), fij.se = sqrt(diag(object$valpha.fij))) corr.sum$wald <- (corr.sum$estimate / corr.sum$san.se)^2 corr.sum$p <- 1 - pchisq(corr.sum$wald, df=1) if (nrow(corr.sum) > 0) rownames(corr.sum) <- object$zcor.names scale.sum <- data.frame(estimate = object$gamma, san.se = sqrt(diag(object$vgamma)), ajs.se = sqrt(diag(object$vgamma.ajs)), j1s.se = sqrt(diag(object$vgamma.j1s)), fij.se = sqrt(diag(object$vgamma.fij))) scale.sum$wald <- (scale.sum$estimate / scale.sum$san.se)^2 scale.sum$p <- 1 - pchisq(scale.sum$wald, df=1) if (!is.null(object$zsca.names)) rownames(scale.sum) <- object$zsca.names drop <- ifelse(c(object$control$jack, object$control$j1s, object$control$fij)== 0, TRUE, FALSE) if (any(drop)) { drop <- (3:5)[drop] mean.sum <- mean.sum[,-drop] corr.sum <- corr.sum[,-drop] scale.sum <- scale.sum[,-drop] } ans <- list(mean=mean.sum, correlation=corr.sum, scale=scale.sum, call=object$call, model=object$model, control=object$control, error=object$err, clusz=object$clusz) class(ans) <- "summary.geese" ans } #' @export print.geese <- function(x, digits = NULL, quote = FALSE, prefix = "", ...) { if(is.null(digits)) digits <- options()$digits else options(digits = digits) cat("\nCall:\n") dput(x$call) cat("\nMean Model:\n") cat(" Mean Link: ", x$model$mean.link, "\n") cat(" Variance to Mean Relation:", x$model$variance, "\n") cat("\n Coefficients:\n") print(unclass(x$beta), digits = digits) if (!x$model$scale.fix) { cat("\nScale Model:\n") cat(" Scale Link: ", x$model$sca.link, "\n") cat("\n Estimated Scale Parameters:\n") print(unclass(x$gamma), digits = digits) } else cat("\nScale is fixed.\n") cat("\nCorrelation Model:\n") cat(" Correlation Structure: ", x$model$corstr, "\n") if (pmatch(x$model$corstr, c("independence", "fixed"), 0) == 0) { cat(" Correlation Link: ", x$model$cor.link, "\n") cat("\n Estimated Correlation Parameters:\n") print(unclass(x$alpha), digits = digits) } ##cat("\nNumber of observations : ", x$nobs, "\n") ##cat("\nMaximum cluster size : ", x$max.id, "\n") cat("\nReturned Error Value: ") cat(x$error, "\n") cat("Number of clusters: ", length(x$clusz), " Maximum cluster size:", max(x$clusz), "\n\n") invisible(x) } #' @export print.summary.geese <- function(x, digits = NULL, quote = FALSE, prefix = "", ... ) { if(is.null(digits)) digits <- options()$digits else options(digits = digits) cat("\nCall:\n") dput(x$call) cat("\nMean Model:\n") cat(" Mean Link: ", x$model$mean.link, "\n") cat(" Variance to Mean Relation:", x$model$variance, "\n") cat("\n Coefficients:\n") print(x$mean, digits = digits) if (x$model$scale.fix == FALSE) { cat("\nScale Model:\n") cat(" Scale Link: ", x$model$sca.link, "\n") cat("\n Estimated Scale Parameters:\n") print(x$scale, digits = digits) } else cat("\nScale is fixed.\n") cat("\nCorrelation Model:\n") cat(" Correlation Structure: ", x$model$corstr, "\n") if (pmatch(x$model$corstr, c("independence", "fixed"), 0) == 0) { cat(" Correlation Link: ", x$model$cor.link, "\n") cat("\n Estimated Correlation Parameters:\n") print(x$corr, digits = digits) } ##cat("\nNumber of observations : ", x$nobs, "\n") ##cat("\nMaximum cluster size : ", x$max.id, "\n") cat("\nReturned Error Value: ") cat(x$error, "\n") cat("Number of clusters: ", length(x$clusz), " Maximum cluster size:", max(x$clusz), "\n\n") invisible(x) } geepack/R/relative-risk-regression.R0000755000176200001440000000742714165262714017161 0ustar liggesusers## This is a wrapper function for relative risk regression ## for binary data with log link using the copy method #' @title Fit a Relative Risk Model for Binary data with Log Link #' #' @description Fit a Relative Risk Model for Binary data with Log #' Link using the COPY method. #' #' @param formula same as in \code{geese} #' @param id same as in \code{geese} #' @param waves same as in \code{geese} #' @param data same as in \code{geese} #' @param subset same as in \code{geese} #' @param contrasts same as in \code{geese} #' @param na.action same as in \code{geese} #' @param corstr same as in \code{geese} #' @param ncopy the number of copies of the original data in #' constructing weight. #' @param control same as in \code{geese} #' @param b initial values for regression coefficients as in #' \code{geese} but more difficult to obtain due to the log link. #' @param alpha same as in \code{geese} #' @return An object of class \code{"geese"} representing the fit. #' @author Jun Yan \email{jyan.stat@@gmail.com} #' #' @references Lumley, T., Kornmal, R. and Ma, S. (2006). Relative #' risk regression in medical research: models, contrasts, #' estimators, and algorithms. UW Biostatistics Working Paper #' Series 293, University of Washington. #' @keywords models #' @examples #' #' ## this example was used in Yu and Yan (2010, techreport) #' data(respiratory) #' respiratory$treat <- relevel(respiratory$treat, ref = "P") #' respiratory$sex <- relevel(respiratory$sex, ref = "M") #' respiratory$center <- as.factor(respiratory$center) #' ## 1 will be the reference level #' #' fit <- relRisk(outcome ~ treat + center + sex + age + baseline + visit, #' id = id, corstr = "ar1", data = respiratory, ncopy=10000) #' summary(fit) #' ## fit <- relRisk(outcome ~ treat + center + sex + age + baseline + visit, #' ## id = id, corstr = "ex", data = respiratory) #' ## summary(fit) #' ## fit <- relRisk(outcome ~ treat + center + sex + age + baseline + visit, #' ## id = id, corstr = "indep", data = respiratory) #' ## summary(fit) #' #' @export relRisk relRisk<- function(formula, id, waves = NULL, data = parent.frame(), subset = NULL, contrasts = NULL, na.action = na.omit, corstr = "indep", ncopy = 1000, control = geese.control(), b = NULL, alpha = NULL) { family <- binomial("log") ## fixed scall <- match.call() mnames <- c("", "formula", "data", "offset", "subset", "na.action", "id", "waves") cnames <- names(scall) cnames <- cnames[match(mnames,cnames,0)] mcall <- scall[cnames] if (is.null(mcall$id)) mcall$id <- as.name("id") mcall[[1]] <- as.name("model.frame") m <- eval(mcall, parent.frame()) y <- model.extract(m, "response") if (is.null(dim(y))) N <- length(y) else N <- dim(y)[1] mterms <- attr(m, "terms") x <- model.matrix(mterms, m, contrasts) offset <- model.extract(m, "offset") if (is.null(offset)) offset <- rep(0, N) w <- rep(1 - 1 / ncopy, N) w.copy <- rep(1 / ncopy, N) y.copy <- 1 - y id <- model.extract(m, id) waves <- model.extract(m, waves) ## augmented data Y <- c(y, y.copy) W <- c(w, w.copy) X <- rbind(x, x) ID <- c(id, id + max(id)) Waves <- c(waves, waves) Offset <- c(offset, offset) Freq <- rep(c(2, 1), each = N) ## get initial values fit0 <- glm.fit(X, Y, offset = Offset, weights = Freq, family = family) fit1 <- glm.fit(X, Y, offset = Offset, family = family, weights = W, start = fit0$coefficients) ## feed geese ans <- geese.fit(X, Y, ID, Offset, weights = W, waves = Waves, family = family, control = control, corstr = corstr, b = fit1$coefficients, scale.fix = TRUE) ans <- c(ans, list(call=scall, formula=formula)) class(ans) <- "geese" ans } geepack/R/data-geepack.R0000644000176200001440000003507414165262714014524 0ustar liggesusers#' Growth curves of pigs in a 3x3 factorial experiment #' #' The \code{dietox} data frame has 861 rows and 7 columns. #' #' @details Data contains weight of slaughter pigs measured weekly for 12 #' weeks. Data also contains the startweight (i.e. the weight at week #' 1). The treatments are 3 different levels of Evit = vitamin E (dose: 0, #' 100, 200 mg dl-alpha-tocopheryl acetat /kg feed) in combination with 3 #' different levels of Cu=copper (dose: 0, 35, 175 mg/kg feed) in the feed. #' The cumulated feed intake is also recorded. The pigs are littermates. #' #' #' @format This data frame contains the following columns: #' #' \describe{ #' \item{Weight}{Weight in Kg} #' \item{Feed}{Cumulated feed intake in Kg} #' \item{Time}{Time (in weeks) in the experiment} #' \item{Pig}{Factor; id of each pig} #' \item{Evit}{Factor; vitamin E dose; see 'details'.} #' \item{Cu}{Factor, copper dose; see 'details'} #' \item{Start}{Start weight in experiment, i.e. weight at week 1.} #' \item{Litter}{Factor, id of litter of each pig} #' } #' #' @source Lauridsen, C., Højsgaard, S.,Sørensen, M.T. C. (1999) Influence of #' Dietary Rapeseed Oli, Vitamin E, and Copper on Performance and #' Antioxidant and Oxidative Status of Pigs. J. Anim. Sci.77:906-916 #' @keywords datasets #' @examples #' #' data(dietox) #' head(dietox) #' \dontrun{ #' if (require(ggplot2)){ #' qplot(Time, Weight, data=dietox, col=Pig) + geom_line() + #' theme(legend.position = "none") + facet_grid(Evit~Cu) #' } else { #' coplot(Weight ~ Time | Evit * Cu, data=dietox) #' } #' } "dietox" #' Ordinal Data from Koch #' #' The \code{koch} data frame has 288 rows and 4 columns. #' #' @format This data frame contains the following columns: #' \describe{ #' \item{trt}{a numeric vector} #' \item{day}{a numeric vector} #' \item{y}{an ordered factor with levels: \code{1} < \code{2} < \code{3}} #' \item{id}{a numeric vector} #' } #' #' @keywords datasets #' @examples #' #' data(koch) #' fit <- ordgee(ordered(y) ~ trt + as.factor(day), id=id, data=koch, corstr="exch") #' summary(fit) #' "koch" #' Data on Obesity from the Muscatine Coronary Risk Factor Study. #' #' The data are from the Muscatine Coronary Risk Factor (MCRF) study, #' a longitudinal survey of school-age children in Muscatine, Iowa. #' The MCRF study had the goal of examining the development and #' persistence of risk factors for coronary disease in children. In #' the MCRF study, weight and height measurements of five cohorts of #' children, initially aged 5-7, 7-9, 9-11, 11-13, and 13-15 years, #' were obtained biennially from 1977 to 1981. Data were collected on #' 4856 boys and girls. On the basis of a comparison of their weight #' to age-gender specific norms, children were classified as obese or #' not obese. #' #' @format A dataframe with 14568 rows and 7 variables: #' \describe{ #' \item{id}{identifier of child.} #' #' \item{gender}{gender of child} #' #' \item{base_age}{baseline age} #' #' \item{age}{current age} #' #' \item{occasion}{identifier of occasion of recording} #' #' \item{obese}{'yes' or 'no'} #' #' \item{numobese}{obese in numerical form: 1 corresponds to 'yes' #' and 0 corresponds to 'no'.} #' #' } #' @source #' #' \url{https://content.sph.harvard.edu/fitzmaur/ala2e/muscatine.txt} #' #' Woolson, R.F. and Clarke, W.R. (1984). Analysis of categorical #' incompletel longitudinal data. Journal of the Royal Statistical Society, #' Series A, 147, 87-99. #' #' @examples #' muscatine$cage <- muscatine$age - 12 #' muscatine$cage2 <- muscatine$cage^2 #' #' f1 <- numobese ~ gender #' f2 <- numobese ~ gender + cage + cage2 + #' gender:cage + gender:cage2 #' #' gee1 <- geeglm(formula = f1, id = id, #' waves = occasion, data = muscatine, family = binomial(), #' corstr = "independence") #' #' gee2 <- geeglm(formula = f2, id = id, #' waves = occasion, data = muscatine, family = binomial(), #' corstr = "independence") #' #' tidy(gee1) #' tidy(gee2) #' QIC(gee1) #' QIC(gee2) #' #' "muscatine" #' Ohio Children Wheeze Status #' #' The \code{ohio} data frame has 2148 rows and 4 columns. The dataset is a #' subset of the six-city study, a longitudinal study of the health effects of #' air pollution. #' #' @format This data frame contains the following columns: #' #' \describe{ #' #' \item{resp}{an indicator of wheeze status (1=yes, 0=no)} #' #' \item{id}{a numeric vector for subject id} #' #' \item{age}{a numeric vector of age, 0 is 9 years old} #' #' \item{smoke}{an indicator of maternal smoking at the first #' year of the study} #' } #' #' @references Fitzmaurice, G.M. and Laird, N.M. (1993) A likelihood-based #' method for analyzing longitudinal binary responses, \emph{Biometrika} #' \bold{80}: 141--151. #' #' @keywords datasets #' @examples #' #' data(ohio) #' #' fit.ex <- geeglm(resp ~ age + smoke + age:smoke, id=id, data=ohio, #' family=binomial, corstr="exch", scale.fix=TRUE) #' QIC(fit.ex) #' #' fit.ar <- geeglm(resp ~ age + smoke + age:smoke, id=id, data=ohio, #' family=binomial, corstr="ar1", scale.fix=TRUE) #' QIC(fit.ex) "ohio" #' Clustered Ordinal Respiratory Disorder #' #' The \code{respdis} data frame has 111 rows and 3 columns. The study described #' in Miller et. al. (1993) is a randomized clinical trial of a new treatment of #' respiratory disorder. The study was conducted in 111 patients who were #' randomly assigned to one of two treatments (active, placebo). At each of four #' visits during the follow-up period, the response status of each patients was #' classified on an ordinal scale. #' #' #' @format This data frame contains the following columns: #' \describe{ #' #' \item{y1, y2, y3, y4}{ordered factor measured at 4 visits for the response with #' levels, \code{1} < \code{2} < \code{3}, 1 = poor, 2 = good, and 3 = #' excellent} #' #' \item{trt}{a factor for treatment with levels, 1 = active, 0 = #' placebo.} #' #' } #' #' @references Miller, M.E., David, C.S., and Landis, R.J. (1993) The analysis #' of longitudinal polytomous data: Generalized estimating equation and #' connections with weighted least squares, \emph{Biometrics} \bold{49}: #' 1033-1048. #' @keywords datasets #' @examples #' #' data(respdis) #' resp.l <- reshape(respdis, varying = list(c("y1", "y2", "y3", "y4")), #' v.names = "resp", direction = "long") #' resp.l <- resp.l[order(resp.l$id, resp.l$time),] #' fit <- ordgee(ordered(resp) ~ trt, id = id, data = resp.l, int.const = FALSE) #' summary(fit) #' #' z <- model.matrix( ~ trt - 1, data = respdis) #' ind <- rep(1:111, 4*3/2 * 2^2) #' zmat <- z[ind,,drop=FALSE] #' fit <- ordgee(ordered(resp) ~ trt, id = id, data = resp.l, int.const = FALSE, #' z = zmat, corstr = "exchangeable") #' summary(fit) #' "respdis" #' Data from a clinical trial comparing two treatments for a respiratory #' illness #' #' The data are from a clinical trial of patients with respiratory illness, #' where 111 patients from two different clinics were randomized to receive #' either placebo or an active treatment. Patients were examined at baseline #' and at four visits during treatment. The respiratory #' status (categorized as 1 = good, 0 = poor) was determined at each #' visit. #' #' @name respiratory #' @aliases respiratory respiratoryWide #' @docType data #' #' @format A data frame with 444 observations on the following 8 variables. #' #' \describe{ #' #' \item{center}{a numeric vector} #' \item{id}{a numeric vector} #' \item{treat}{treatment or placebo} #' \item{sex}{M or F} #' \item{age}{in years at baseline} #' \item{baseline}{resporatory status at baseline} #' \item{visit}{id of each of four visits} #' \item{outcome}{respiratory status at each visit} #' #' } #' #' @keywords datasets #' @examples #' #' data(respiratory) #' data(respiratory, package="geepack") #' respiratory$center <- factor(respiratory$center) #' head(respiratory) #' #' m1 <- glm(outcome ~ center + treat + age + baseline, data=respiratory, #' family=binomial()) #' gee.ind <- geeglm(outcome ~ center + treat + age + baseline, data=respiratory, id=id, #' family=binomial(), corstr="independence") #' gee.exc <- geeglm(outcome ~ center + treat + age + baseline, data=respiratory, id=id, #' family=binomial(), corstr="exchangeable") #' gee.uns <- geeglm(outcome ~ center + treat + age + baseline, data=respiratory, id=id, #' family=binomial(), corstr="unstructured") #' gee.ar1 <- geeglm(outcome ~ center + treat + age + baseline, data=respiratory, id=id, #' family=binomial(), corstr="ar1") #' #' mlist <- list(gee.ind, gee.exc, gee.uns, gee.ar1) #' do.call(rbind, lapply(mlist, QIC)) #' lapply(mlist, tidy) #' "respiratory" #' Epiliptic Seizures #' #' The \code{seizure} data frame has 59 rows and 7 columns. The dataset has the #' number of epiliptic seizures in each of four two-week intervals, and in a #' baseline eight-week inverval, for treatment and control groups with a total #' of 59 individuals. #' #' @format This data frame contains the following columns: \describe{ #' \item{y1}{the number of epiliptic seizures in the 1st 2-week interval} #' \item{y2}{the number of epiliptic seizures in the 2nd 2-week interval} #' \item{y3}{the number of epiliptic seizures in the 3rd 2-week interval} #' \item{y4}{the number of epiliptic seizures in the 4th 2-week interval} #' \item{trt}{an indicator of treatment} \item{base}{the number of epilitic #' seizures in a baseline 8-week interval} \item{age}{a numeric vector of #' subject age} } #' @references Diggle, P.J., Liang, K.Y., and Zeger, S.L. (1994) Analysis of #' Longitudinal Data. Clarendon Press. #' @source Thall, P.F. and Vail S.C. (1990) Some covariance models for #' longitudinal count data with overdispersion. \emph{Biometrics} \bold{46}: #' 657--671. #' @keywords datasets #' @examples #' #' data(seizure) #' ## Diggle, Liang, and Zeger (1994) pp166-168, compare Table 8.10 #' seiz.l <- reshape(seizure, #' varying=list(c("base","y1", "y2", "y3", "y4")), #' v.names="y", times=0:4, direction="long") #' seiz.l <- seiz.l[order(seiz.l$id, seiz.l$time),] #' seiz.l$t <- ifelse(seiz.l$time == 0, 8, 2) #' seiz.l$x <- ifelse(seiz.l$time == 0, 0, 1) #' m1 <- geese(y ~ offset(log(t)) + x + trt + x:trt, id = id, #' data=seiz.l, corstr="exch", family=poisson) #' summary(m1) #' m2 <- geese(y ~ offset(log(t)) + x + trt + x:trt, id = id, #' data = seiz.l, subset = id!=49, #' corstr = "exch", family=poisson) #' summary(m2) #' #' ## Thall and Vail (1990) #' seiz.l <- reshape(seizure, varying=list(c("y1","y2","y3","y4")), #' v.names="y", direction="long") #' seiz.l <- seiz.l[order(seiz.l$id, seiz.l$time),] #' seiz.l$lbase <- log(seiz.l$base / 4) #' seiz.l$lage <- log(seiz.l$age) #' seiz.l$v4 <- ifelse(seiz.l$time == 4, 1, 0) #' m3 <- geese(y ~ lbase + trt + lbase:trt + lage + v4, #' sformula = ~ as.factor(time) - 1, id = id, #' data = seiz.l, corstr = "exchangeable", family=poisson) #' ## compare to Model 13 in Table 4, noticeable difference #' summary(m3) #' #' ## set up a design matrix for the correlation #' z <- model.matrix(~ age, data = seizure) # data is not seiz.l #' ## just to illustrate the scale link and correlation link #' m4 <- geese(y ~ lbase + trt + lbase:trt + lage + v4, #' sformula = ~ as.factor(time)-1, id = id, #' data = seiz.l, corstr = "ar1", family = poisson, #' zcor = z, cor.link = "fisherz", sca.link = "log") #' summary(m4) #' "seizure" #' Growth of Sitka Spruce Trees #' #' Impact of ozone on the growth of sitka spruce trees. #' #' @format A dataframe #' #' \describe{ #' \item{size:}{size of the tree measured in \eqn{log(height*diamter^2)}} #' #' \item{time:}{days after the 1st january, 1988} #' #' \item{tree:}{id number of a tree} #' #' \item{treat:}{ozone: grown under ozone environment, control: ozone free} #' #' } #' @keywords datasets #' @examples #' #' data(sitka89) #' "sitka89" #' Log-size of 79 Sitka spruce trees #' #' The \code{spruce} data frame has 1027 rows and 6 columns. The data consists #' of measurements on 79 sitka spruce trees over two growing seasons. The trees #' were grown in four controlled environment chambers, of which the first two, #' containing 27 trees each, were treated with introduced ozone at 70 ppb whilst #' the remaining two, containing 12 and 13 trees, were controls. #' #' #' @format This data frame contains the following columns: #' #' \describe{ #' #' \item{chamber}{a numeric vector of chamber numbers} #' #' \item{ozone}{a factor with levels \code{enriched} and \code{normal}} #' #' \item{id}{a numeric vector of tree id} #' #' \item{time}{a numeric vector of the time when the #' measurements were taken, measured in days since Jan. 1, 1988} #' #' \item{wave}{a numeric vector of the measurement number} \item{logsize}{a #' numeric vector of the log-size} #' #' } #' #' @source Diggle, P.J., Liang, K.Y., and Zeger, S.L. (1994) Analysis of #' Longitudinal Data, Clarendon Press. #' @keywords datasets #' @examples #' #' data(spruce) #' spruce$contr <- ifelse(spruce$ozone=="enriched", 0, 1) #' sitka88 <- spruce[spruce$wave <= 5,] #' sitka89 <- spruce[spruce$wave > 5,] #' fit.88 <- geese(logsize ~ as.factor(wave) + contr + #' I(time/100*contr) - 1, #' id=id, data=sitka88, corstr="ar1") #' summary(fit.88) #' #' fit.89 <- geese(logsize ~ as.factor(wave) + contr - 1, #' id=id, data=sitka89, corstr="ar1") #' summary(fit.89) #' "spruce" geepack/NEWS.md0000644000176200001440000001714214165313570012761 0ustar liggesusers* geepack v1.3.3 (2022-01-04) * Minor documentation updates * Minor polishing of code * geepack v1.3.2 (Release date: 2020-12-18) * NAMESPACE and all .Rd files are now auto generated. * PROTECT / UNPROTECT issue fixed (in file inter.cc) * Improved documentation of dietox. * geepack v1.3.1 (Release date: 2019-12-13) * PROTECT / UNPROTECT imbalance fixed * Version 1.3-1 uploaded * geepack v1.3.0 (Release date: 2019-12-10) * Migrated to use roxygen * Improved documentation of geeglm * Check for data being sorted by 'id' i geeglm; a warning is issued if not. * QIC added; thanks to Claus Ekstrøm who is now a contributor. * tidy function from broom package is imported. * muscatine data added * Version 1.3-0 uploaded * geepack v1.2.1 (Release date: 2014-09-13) * geeglm objects now inherits from lm also (to prevent warning when calling predict). * geepack v1.2.0 (Release date: 2014-09-13) * Maintainer of geepack is now Søren Højsgaard * Location of vignette fixed * Version 1.2-0 uploaded * Legacy from when Jun Yan was maintainer: 2012-01-27 Jun Yan * Commented out #undef NDEBUG in geesubs.cc. * Added a VecPrint function in utils.cc to print DVector; this replaces usage of cerr. 2012-01-09 Jun Yan * Thank Jeffrey Horner and Cole Beck for fixing the undefined symbol error (see 2011-11-14 entry: _Z5ValidIiEN3TNT6VectorIT_EERS3_RNS1_IiEE). The template function "Valid" (in original geesubs.cc) should actually be in the header file. This may fix the compilation error on ubuntu 11.10 too. 2011-11-21 Jun Yan * Added an example to function relRisk. 2011-11-21 Jun Yan * Added an example to function compCoef. * Changed the JSS paper year from 2005 to 2006 in CITATION. 2011-11-16 Jun Yan * Added function relRisk for relative risk regression --- regression for binary response with log link. * Added function relRisk for relative risk regression --- regression for binary response with log link. * Added function compCoef for comparing coefficients of the same sets of covariates between nested models. This implements the method of Yan, Aseltine, and Harel (2011, JEBS); for independent data, the method reduces to Allison (1995, American Journal of Sociology). * Fixed a bug in c++ code in constructing the working covariance structure using the regression model of scale. Simulation tests show improved efficiency in mean parameter estimation when scale regression is present. 2011-11-15 Soren Hojsgaard * Dependence on the doBy package has been removed. 2011-11-14 Jun Yan * Added NAMESPACE for to comply with the requirement of R-2.14.0. * Removed the "assert" lines in utils.cc in order not to crash R, which is quite rude practice. A "-DNDEBUG" has been added to the cppflags in Makevars for a better solution. Due to many asserts in tnt, we cannot get rid of the NOTE message completely: Found ‘_ZSt4cerr’, possibly from ‘std::cerr’ (C++) Found ‘__assert_fail’, possibly from ‘assert’ (C) * Added quote in statements like extract(m, "response") to get rid of NOTE: geese: no visible binding for global variable ‘response’ * Added a line of #undef NDEBUG to the beginning of geesubs.cc; thank Brian Ripley for the NMU. Still unclear why the error without this line: undefined symbol: _Z5ValidIiEN3TNT6VectorIT_EERS3_RNS1_IiEE 2011-02-23 Søren Højsgaard * In geeglm is checked if the model matrix is rank deficient; if so then geeglm exits. Thanks to Jason D Thorpe for pointing this out. * Bug in anova fixed. Thanks to Stefan Boehringer for pointing this out. * Version 1.0-18 uploaded. 2010-01-26 Søren Højsgaard * fixed2Zcor function has been added. This function makes it easier to work with a fixed correlation matrix (in particular when cluster sizes are not equal). * A vignette on models with unequal cluster size, fixed correlation matrices etc. has been added. * Version 1.0-17 uploaded 2008-12-08 Søren Højsgaard * Bugfix in 1.0.15 caused problem in binomial case using cbind(pos,neg). Thanks to Tobias Verbeke. Fixed now. * Bugfix in 1.0.15 caused problem when using variables derived from gam package call to geeglm. Thanks to Eric Rexstad. Fixed now. * Using scale.fix argument gave problem in geeglm. Thanks to Tobias Verbeke. Fixed now. * Fitting large data set with binomial model and 3 measurements per unit using unstructured correlation crashes R. Thanks to Tobias Verbeke. Problem has *NOT* been solved but a remark has been added to doc file. * Version 1.0-16 uploaded 2008-12-01 Søren Højsgaard * When a factor has unused levels, the underlying C code fails. This is now catured in geeglm. Thanks to Janet Young * tests directory added to package * Version 1.0-15 uploaded 2007-07-13 Søren Højsgaard * Smaller 'standardization' changes implemented. Thanks to Achim * Version 1.0-14 uploaded 2007-03-21 Søren Højsgaard * A remark on fixed correlation structures has been added to the geeglm.Rd doc file. * A Wishlist file has been added * Version 1.0-13 uploaded 2007-03-21 Søren Højsgaard * Bug in geeglm fixed so that it now works with a fixed correlation structure. Thanks to Ulrich Halekoh for the fix. 2006-02-13 Jun Yan * Bug in genZcor and genZodds fixed. Thanks to Chongzhi Di . Previously, the matrice generated by genZcor/genZodds are wrong when the number of unique waves is greater than or equal to 10. 2006-01-24 Søren Højsgaard * Bug in anova.geeglm fixed (showed up when there was only one term on the right hand side of ~). * geeglm only works on complete data. This has been pointed out in the man pages. (At some point of time, a proper na.action should be taken). * All datasets are saved as .txt files (previously some were saved as .rda files but that caused problems in building the package on windows xp). 2005-08-13 Jun Yan * The working correlation structure can now be "fixed". 2005-06-13 Søren Højsgaard * Søren Højsgaard has modified the geeglm function so that it can take the 'waves' argument which is used for explicitely specifying the ordering of repeated measurements on the same unit. geeglm can also take the 'zcor' argument for a user defined working correlation structure. * A documentation file for the genZcor function has been added. * All data sets provided are now saved as text files. * ordgee has been modified to check if the response variable is an ordered factor. * geeglm can now take the argument std.err which specifies the type of variance estimate to be calculated. 2005-05-11 Søren Højsgaard * Søren Højsgaard has modified the anova function to make it calculate the correct degrees of freedom. 2005-04-11 Jun Yan * Søren Højsgaard made some minor changes to geeglm - basically, that geese.control did not work. Now it does. 2005-02-09 Jun Yan * Søren Højsgaard joined the development with geeglm, which "works like" glm and returns an object which is similar to a glm object. Residuals and predicted values can be extracted using the generic functions as with a glm object. * An important feature of geeglm, is that an anova method exists for these models. geepack/MD50000644000176200001440000001146114166452400012166 0ustar liggesusers2c7ec897a3bb657e2353fc328fb40ab5 *ChangeLog c12ad485693c98f002c8dc40837def7a *DESCRIPTION 883312468fef336ca79944040ab1a68b *NAMESPACE 27904c38a89b72c80ac21ede7f360f23 *NEWS.md 0a48d3c82f8be0d26ed94eb3808b2c25 *R/NAMESPACE.R 0eb1bec600f9f4b30342b62b0eb6d48c *R/data-geepack.R 146562842fedadc277416dbbbdce1be1 *R/fixed2Zcor.R 445c4293d9603e4818df48a352ec3c32 *R/geeglm-anova.R e3329819985575a6f71d9cc1cbeee89f *R/geeglm.R f847934588f95a5754e8524f4015382c *R/geepack-package.R e06964d406046a745ffe88f2278a82e8 *R/geese.R d48fd13031191743c51f8b5fe3c5bfba *R/genZcor.R de7d23a336fdac7cb4fa286070d1d0f0 *R/ordgee.R eb39939c02f905d3d6de878a88555a97 *R/qic.R 72fa2bc5761ae49107cd18252263ff8c *R/relative-risk-regression.R 903668733f4bb12da2f0f83a65931116 *R/summary.R 6505166c78c1a08e723f0ab1ab6c1608 *R/zzz.R 09025c52708dd8f6d43340f2828e57d6 *README.md 4e6d5fac538fdb6aff2d1714d4ec7b4c *build/vignette.rds 830f7fc69c5afa1a23e8991d77e0b101 *data/dietox.rda 4db449d2d05821a059969ee34818c48a *data/koch.RData 331c55a17b264d413792bc3503e6c7df *data/muscatine.rda 0db8ec836610c00dbf2291c316f7558a *data/ohio.RData c5c74995959496a594d75aaee98eea7f *data/respdis.RData 07d09021bfce445f94319499defe3137 *data/respiratory.RData 344743cddf1a27b7b9d5dae851d8495e *data/seizure.RData 8a96e06b08ac07da63c409f539a6a969 *data/sitka89.RData c573873a4bf48e2169119cfea4496143 *data/spruce.RData 6143f183f04ed5831f485164d9e39c17 *inst/CITATION 1c3565e2258a180cd9dc80a1b1c94c6a *inst/doc/geepack-manual.R ad435dfdb769fa1e9d406a5eadb0e308 *inst/doc/geepack-manual.Rnw 353b201341edb210169af52ea945b3c8 *inst/doc/geepack-manual.pdf 9828f5a1fa7e645dee75d7651986c9d0 *inst/include/famstr.h 17b2a8381b909ce542221d3cc6a2ca86 *inst/include/gee2.h 7d1cfd53a00f4edb17e31b0ac3fadd26 *inst/include/geese.h df7fb36edc7174c1a26d0e79234676cd *inst/include/geesubs.h 519867c1874b173cd9660a1300332f37 *inst/include/inter.h 5392bf061700d0003e339c181fd4d104 *inst/include/ordgee.h a579ea72e62d3982786e82fbdc4b3536 *inst/include/param.h f21fe6de4a69d3a20e29a72a8e1ac639 *inst/include/tnt/cholesky.h 66693b8465fe9f07be45da9f6f8c21e0 *inst/include/tnt/cmat.h 9a7af772a44566294b05e3e78892b42c *inst/include/tnt/fcscmat.h c811f95c924bc28132ff7b93d1010b1e *inst/include/tnt/fmat.h 12fa3a18590c3364536fbb6d62884bfc *inst/include/tnt/fortran.h d29fbf416f699a91682bc9e895bbf9e5 *inst/include/tnt/fspvec.h 9a0bab7161ed03dfd07c5b0edf001c21 *inst/include/tnt/index.h 3f70399c03bfcb5e60c2fdcb5a4f00b5 *inst/include/tnt/lapack.h 26f4d7328659fe70385d226605178102 *inst/include/tnt/lu.h a7da1898f0ba581bf82f145d2c3651ce *inst/include/tnt/qr.h c813389ff962e9e2dda1081026b0c603 *inst/include/tnt/region1d.h e25241f9c8cbce4111c58f92b04035e9 *inst/include/tnt/region2d.h 43c8743ed6bbda44c49da9053217267f *inst/include/tnt/stopwatch.h 24e268cfe72fe89f420e867c8b49f614 *inst/include/tnt/subscript.h 4c7b27b0462a34ee887090ccc8169cc5 *inst/include/tnt/tnt.h f8c7a408e6abc48024983fe82482d673 *inst/include/tnt/tntmath.h 5a4fd2e78c2bbe039ed2446f7a49ea7e *inst/include/tnt/tntreqs.h 58cabe5fb834e0017256f3205edda11d *inst/include/tnt/transv.h 3ade8b6a72dc42a12be780316deecb45 *inst/include/tnt/triang.h f7be8d905e6320d2b01f6119c10fbc8a *inst/include/tnt/trisolve.h b692f65accfbaec20a6c9ef1a6038e26 *inst/include/tnt/vec.h 2f9d702f3e5a0fa587658b834e737767 *inst/include/tnt/vecadaptor.h ab5be7c78471fb94e662157f3aa1ddc2 *inst/include/tnt/version.h 53e679a09c916c1eeba60897a83b3fcb *inst/include/tntsupp.h 047879e877ce84a2a9f9aec073ea4478 *inst/include/utils.h 8bc41533c252039da9c281986016fe33 *man/QIC.Rd dbf80500a44743bab74e96dbdd1efd29 *man/compCoef.Rd c7656f8709a83d94f8a8d538c5ed4c64 *man/dietox.Rd 4776c4c312fbb0da835c05074b495f9a *man/fixed2Zcor.Rd 6dbb878cc505ac1d10b1de93cc514a57 *man/geeglm.Rd 02fc86310bdffb9b7a04b81b1128ffde *man/geepack-internal.Rd f05480355f1795500beecc3470aaf528 *man/geese.Rd 2b182fc1f37be8266a0f0c3c18686562 *man/geese.control.Rd e13e2ee40cd61f5fdd3d4538e7c6d2f0 *man/genZcor.Rd 79ed548437238dd87136c8f4b6fa29a6 *man/koch.Rd 5bddd7bb33d4bd17d450cf40c52a7fbb *man/muscatine.Rd 4329e14dacdfd0067a0236ecc71c2031 *man/ohio.Rd e0b11254f10f6603fa3249a486f02f0b *man/ordgee.Rd 0fdb92fead1de05d14468ef135297eac *man/relRisk.Rd 27b78f03c75e708aa0dbcccf3486b983 *man/respdis.Rd e291c80dba9d4a9b1aa49be9d88c2c46 *man/respiratory.Rd fcaf82388434308232e83636002cec39 *man/seizure.Rd b534395033d50fd0eedacc1dff559b7c *man/sitka89.Rd 5e340fecd2453fc2a22e83f70cbaa8d8 *man/spruce.Rd 8bb53f14cf0f67b02bdd966aadb484a2 *src/Makevars cdc0cc143af33cd5665ac112d92afdc9 *src/famstr.cc 5168e2d9f382ebf53283c076b9b98515 *src/gee2.cc a03f71117e827c1b67df1c8d0b2ebc50 *src/geesubs.cc 4396f72dfbbdf9480432e6eb1422d549 *src/init.c 17a857f9403c048971f3be32702cc5aa *src/inter.cc 2ab3cc479e9a32206dae9c3405bdf61d *src/ordgee.cc cc4f054a5e831b0dccda7ffe2398143b *src/param.cc aa7d692722f3b034aa4ff9dbe6851947 *src/utils.cc ad435dfdb769fa1e9d406a5eadb0e308 *vignettes/geepack-manual.Rnw geepack/inst/0000755000176200001440000000000014166001762012631 5ustar liggesusersgeepack/inst/doc/0000755000176200001440000000000014166001762013376 5ustar liggesusersgeepack/inst/doc/geepack-manual.pdf0000644000176200001440000037310714166001762016756 0ustar liggesusers%PDF-1.5 % 36 0 obj << /Length 1243 /Filter /FlateDecode >> stream xڕVKs6 WVLE)ti.4tԵ{WV~$j%{I( lL2?;թLUB+g2SA Y4Jcu!}ݬ0R U~} aᒆ= ()'Jʀ (ZsCBFfJFB#RYaUEaGi,|. g{4O;x]zW(&Z|F\lnf,+* iP%BVT'?<أ06ʈ`OsjJ|SHxV[Gb|V<~А 裦$D(u;$˩Y$07" a#, h>& "J['l>p#d7QTajake-G2 V@k52S#0-|gqL9 ٿߢE e$Nɀ?Jb*/ڎsԩ6Τ\{"z\^^WAr+`BVIk8GKךqnixy8a1։N.> stream xYr#7}Wta#oFޚd2Jč;u/8"pͪunAR( *r_]\vKP̨'1`|&"t/qoJa*pHa!AA4ߜCKIb%mҸrOk搆iл jzs٥wK=TV&qP1r<Ij8e?8bb6 紭TUsj! CCDaP!``zW8xJ;!mNBY%;x7*(a=,jնRzpV(*_zWѤzjf#SSR^܊p)uQ*WAnV_]R$> dMm/!-B(}Ҿ* YZmХ> )T6VZRilUAk_'BI:M;{‽/}2u);q2kN}<(EZ)Xa4/cV>fMX+xjW?~y\ɢ cKnWaGNerwe=h#œj#nR2`:WGdtDV\ьx 2q M+T 4Vߚ5 1; VIMg Z= ?ՔK KG1*M=A: 2w& X`4Eh>YB !Z8@3<0vyCE:{8@c7qZh0Jr9uL7%re"tȒCL#G@M5NbdD5ut-2P}NAo@ à sr!K?r_k("UjX~ؤ=~ uzGJu!^g7tď*JEP5 ^كE>4m><-hMo#&6WujsV:6# Y:YHxw~npp‰`͟J=c-_]mOh$k>V]d}l:K$w^:pj|sV_RfijE}Y=`:v^ qXaKdw  gwz endstream endobj 57 0 obj << /Length 1690 /Filter /FlateDecode >> stream xWKs6Wp!^>IN:m'ՓMҲ=Rۻ/Q<@ŷI4觓ƙW=z7xI"TF.r**f'mRg>Dʇ8 >VҸ]Ȣg8J~if`yN XsSއؙ1u]nC;eTiri3]Bs14+y=%L\xOwHY;xit5KX;."젖Q JAwuz53FC#YσdИư+N_likRq9ePA$;֐>!g<eV-θڟD= /sXVdl7aeA noޠ{6~M*|Q}@5 wh $yM>IڗNb4w)| D𯽃wD" պ(hk6yM>)qy+Ѡ'WƸB2'՜?z_ܦ*G UG spsSgU"u&>HN1NvSZxGMJB'?zRS.ݛA=&;X"R׭ slѭ$s8FeSmg\C4ysVqM;uikɼnuCi(xӝFZ4MOJeDȼ@ocjޑ: o9T:ĐvoOk87'|Q FDw|3r/:N$zF0t +[a+!O%g^48uEAXM{~1nnj6a*K,;6.N7qQM:/TJQ)G3Sk-M}`K!/ЇXu6?$u)eD`i7P>Hʯ?g\cmެx!rܺO>~0_0Q|@|,CxImZRj.)%E+ sڊ v0"e<ţ'^͆b@hCkLX*Ji#Nfɲ]0fRiI뼀U L0LT`KB[P}R|LHBӌFd: CvQPG5(t IZZ +̩' HShǘz!3dOvo(I}hv&vC-C))hH`𯑚9򺇔BCKqr9 Z@f9+!Dk^dV7 ޡdj\u=mWarlb\lbF60UzCemH{0g *sH)w@頺ֱR42%@ !(BTQr9pD8I endstream endobj 61 0 obj << /Length 1312 /Filter /FlateDecode >> stream xWIs6W`!@pƝvҎ )e=m IKr\]r oϾZ(_0ۯB>`WZiHYy:jVp9BʼnI s58"{^8eť2 [=~Ku>q@ #O|HȈы\CVAs0<`QL];&WGz0 L'<]4j>|`Ha0>hB|| d/EvLeOL$ZTg=Z~C.r eU zdނʸ()j) 0@>R,\NKTeT3J%E60_dlb%Q`fq1t^VYRs&&س~=Et{p!ÚxW24Hb'SC#m*NiVuӳE3D1ll-0 6o[a,uDAwLMz3KcC蛂bq~5`)`2i b`BpIk@_4UؠŊFpu)6ۇo)0|q;XfoJiz#W, GRz fR6;E-@jI9Ä(Œ1Yyh i"Jnk9 L䉹\O/ Z&J<}$?͵MrP<},٦d-z/ ZZ:{vz,>͋=KԾzdøܛŁ/"u|Ș<>5,8?bqy.A2MdIkin-As>{CvvspZÁҥ%+G쥥.j ПI ӣ[9Ѷջo&,#[zzdvX GZE!xaQP$Xҳ~N{A>i7ki=> stream xYIs6WR9ř䐥'IubG6E٪ңv>o$edX$Hy&3-mMZ#F3 D")e%ƪT,g83y(-ҼTɪI&g&q(ɤ(,/D݌D2j]QA<>gȌE4(eR! / Er=f9gLKqr3|hP|:ͅN=VHR-b`KC&)!yXIaW1lLE *Bg>>:xC׼y4tG__ GiLf R (U!=2H,ȂrtJQ2alM\l<huz[/DF5y{X 2 SpRT$ aZbqPx8#]uz\UNX {066AV*ݣ#p*F"A ]k\dE˲lS:1B1zprtBPUD}!w@)JvbBcv))bn{dG,vqi cAa55O(f/S^ǫMVST AJ6N6}f̟o3s}uλEq{tսGKޞHawl/Z{̈lL t'/U>fafG/rQo:9 nf{p^?-^p ,{zKgO |~y!KJYwK_<a݁js]X``Zi' XY<w׍P!97]tWżIqC Ng/FMv+G@*+bHmaHFI+U84Y3~q1sjFr$jn;m D;W`G{0 d{DG,@_}d$sz&E{:Vm'SxD'?txw8o%>9|$aZ9#eZd&6_ć$PU6 endstream endobj 69 0 obj << /Length 994 /Filter /FlateDecode >> stream xڝVKo@WHֻvyI@ZC`a'8}ˍӢpxwvy|_-F~i?Bݑ|yί<_eN&1*oF(\8Q&q`Tǝ~IT8E]8W M%i6p<~kugI:rC׳a GCTAfsaSkլP$׌QY.`Zy -k02-0;=F0_ uE4bc D.b ܕ"! 7TBM0dlj # SE'|N7]_pI?ec"n$MA,; /|#}˟%OB&LӬ%XZvMR.:H-n/)/eixkq5D8 VTWr*6e5 l[_GO[m0f?t7un)Wu֡Wera=79:i(56>`! *">:7㶬IHt/2T߆{4CßQm&aѨy9'~ L4\GiYe~̮4I^#ֺ`enJacnA+ tAA .?YDX(t(hpYh S"$9̑{%ϼfﬓWF:N?B)che[,V$$& /F6 %E[5go%d<& fAs& }LM hbS_eXGFlmJ uySL endstream endobj 71 0 obj << /Length 95 /Filter /FlateDecode >> stream x36г0S0P04R0!csCB. P*ɥ`ƥU()*Mw pV0wQ6T0tQ0``/ endstream endobj 84 0 obj << /Length1 1920 /Length2 12547 /Length3 0 /Length 13739 /Filter /FlateDecode >> stream xڍPk.\8[pNq)Aŋ[q)nÖL\}_k%"SRe1$!vL@fV>(ʆDEf -F9:YAe 2v~;C.`rXYy7v23d!v '$*1kyК܌DlAVvycgKkFSc0@bjr|,,nnnƶNG !:F%@rth`l 3f$*_rU#*[^=\@U9=/c  Ode)`n%嘝ݝvf ƮV`cW?+7H(_='SG+{g'f'+-% ;g'?r_7kcq[ٙф= HFoW?2 3 9@,WSځ=`d 8;|o̬L& +;Awr貾r`'WzAy,* u(`bdY_s>w%c9W?Mڿ߱ h!+'1(7$]?մ?jc[+uq~yoSM_C+ oYsVNV 3%+gS˿\[ف NV,^uq8Oun;)c;:{ ^+x_' ',vWks>s# `CHq,R v+RqXA15x_?bzgG,fA@6 '=z_M,9,%[z[,^eV |:p, :b,ھ~KZ?Zq#dCy%|5 |CxU:\_S{- /צ]_pXhAH S ꠖJB7Q)mT:&V{It3E07%h>,>y6վ hYebi~XޡHM/1"ڇ'o &vY."?L2EGNSd;3#cO_]Oaf~f@9fYg\)Scs#Kŝ**Z_ ꉟOI 1I0O#4a:!A *2O(2${ Vׂ2ch$8:Qog`AWRO4),e~BE? ;̗(nmD aɈ׽`f10C;$jLvf#$Bw-\܄]H;޻bƓd ZEe4K>Q痭z`[+^ ڥXM0Z:#*ʣRħ-Mq3'۲-Zܥwe5ax[U Izw>)61̷o F_}7VKi&Aa<٧.?A9\RE:ߵtfk⹤帲+Q iVPֿ>/1zpv>:sЎߜWrAq}v׉=5h ܾ?n<)є="Ge)Ib\*65 ]~CL9UnN Lrq5pKǓ`(ԮќaO_ `9hsfw30D'u8#J5Ei.}t=6;3x?f't "V"fa>'G+8HK9,Dn ~c˸:ai}7) SRӼFsb%_t%UK]doH#ũN'7@2hq&\"WRGHujWv= pie.@'pѽBݢj"rZ9W!^e՝â鹹DN MCR<~~x:7 We}7Ĺui#>ɱ9w*\8U|Govi[].8:/r#@7tt1nk2mѾJEWy Hsc,Lc.qF_g#dS*bu\BhޜfI"kL(_l 09]ٸ.w-hL}BR{ԮFd=Edߍ~F[DN*N'bs05F]VL?Ǿ^}d%'U;tW#gb&-`[gǯ%p!\u[u.'7Bk; [ZdķO*8!2rZ׺?:Q`S"GZ aL\]{At$dth c@&tWaSt +9!68ZD/E^!}wh%[%l&ٝ)-h>9i!" MiE&oLx}B<\ /ULQvx#oODj-OW97+OVBxeNYiLO> mʩz_AA#Hj" <{-. ʝzB1,nrϕ ӭ_V`F8)&ڔsnҎw{\Uc7P_秽eR 2Pt8qNG~g{!Kb+<)Hly~aS£8g5Hxdi S[M O% ΄ͽ2{3ƛqo8d1~>itLhcD޾*PˎN>F_uww^+%W:cε'U"wI[p x6!% |>.!J06S\RQmq?xP+~ҋojGy#+Ya=>Q(һdfH<~$v':l-n;#tXow>׺xtK&԰ܯ`|]L5gj*NQ0aMs<9<Ҟ,,jL,7Y{þxnVH5-ۨJش%$ژ f]Јwy/f%y&g0*'z)鄌uI0\|U;Ll 2MQ'V#ethI5\$uBJ8}OOx'"Q'p?Kx]~u&\mg=,%_饧Wc 1Q3T"Ww)@*ޏLZ&QF+h@̽ur8AK-x3UP#7տM'%_F>2E7'6N</噂CaJ>_Mꌳ ~Vt3x}!|cUH<&nr;N ˨4tl|+ =Ի8g ?bfίDlp6c(1n\Qa 8e9#qt0j†B K,PD*Òc~KnlBVqKȻS~0՚%xL4>NN4DQ]BI}s È=WcomθUnem4B)':~7sݍ+R8޻_dD֞x{ !j|< 'TyY)s?I? >e2ɷ:6xڝ`"%|zq7G}t[M 0T󎊴PEw\ć6J 8Np+W:q?RڢzaF(ڕӾҤ4R 1 o[4Z%qPDO6m^B;rсz~dCh`cs&g4XJ]3aӳXdd[ʱ[`7$JŸ]L|da;NЪ,}{)TŽFd9~CP8g0̵xj){Nj@;XU6 TTv|m6:1R,!WL2*vo,wd ^>kkY/nE T"b|@4pS wAK؄'1kDD-ț4NRBW5l *_N7ji.nl(J*cx>0IsޱŖ +,:qhИߝVL7ұ䋂G`;c?n{Z' ԡEr>W) ^ FR6wsoY2 5I>\\r~d*#cdGY8le.ZfRpV\j+ǖ]᯵،%vԠ0`ﰭ}- 2Y l8}pdMGi }Ս҈4J}\˼ -M:!rzAwA}6? /5Mq>R4SP-qV[y-FCT]6365'| 1wPH݆JhT:` ?a`Rp/.wS"rӰ@CӤ;aTVSDQ&>, {樹^ E9X1Ǯq.66^.#*[eN vKYbda啶pmH\it3Ij-8OHBl{1o3sq@/&LAҋ~EN>T,1H> ]a wV?sZУE^+| bbw쏼y}9Q'[v*ADmf)pToy\/ڑ*b9Ewi~r mT3qD"fTAmbya.;J|_;1o(kzIdї VTkfY9$D\2#3 y} qp9@\%gԿ۵R8SU +FQ͟QPY1Uʾ%'vI*MA%s1s\5q8/8ZeMzgp˗Df̘8Ho躒3Ih07p/%0`ﺏ)YB,G{"vpN'É`_W!:[3̑"BF/BlY!+ 8?%n9)?%ўT&vo汴.v̿2,$d~ֺR%ɑ3xtC˩ )6b-}o[vƩ9,%N'9#Yř5]AͣU QfXw᧷$T8Ǥ"Ē䩤ծ&f7Ļ T&gw^hIgz~/#>;T-\&k#GyWt\e0Ek.$q{R =\ؓ|olL&$;7\P%fSc48ze W~KpGbM-a@ޯ)?s1DB0hTl\,t®#B.h˥spW 1:4d e>_.4P'Aݒ\/} gK61> Z~{ K)N'ch>E'ZZEܮ>]on|LƽyM(6} jskes^Fъf vIv=FUVe}'c 9QϓEP?hM~/,w.qͅRSs5sAY#z-,蠐s^G7=y/ zX%T` ~2bR- )v/ '2䨿#̻ΒTZd=Ԝ5H'pb%X꺐o끴硑i' ˧ XmL}%ZR$B!FĬ&Z#(n8z]CK6-d% gb@"tvUNNӍ/:1Xۑaj1l5eJzE/p$a+ 5Vyv)A!*;(e:+uikIq#IU!hLmP_cj b s>*N*RP#${t.s9|bl0;nm4h.=Z1,S(iNt&5B2*^YX;omDkmU||=E:J|S@,~Mߙ=)yЀn&p ej uHldPY}e~NܲxHcthasZcxuxd6FZ$_ 5&!YN!j WQPҼ)Bq@C/g6efcZіy7{L&MՋ!vޕZ:Ƥnq^B'QG>C2`ˍ[TdoದjO҆O"$H.pգU $ў;';5Cہ JUv Yd0  Gj^K zvZ3`~$z%}3e#.BG]P; 3}̐(Q ۻgBR̮8w*]FjI TC? |s௩zt@1Qϸ$y~rX|KdEx19ijm 7&5j̩"]Փe?fp.Rv懆|JܺU1U΍?s0RhHS[PvHBL7m7{yr8 u*κ~"tҼm3gpSvEq { ؒB1,'(<βB!4Xa58QZ G0VAUZ!F2fnNheSo3[/!S_:}p'X}~JYeXIe]o2}8躡GH 1@l)z1a.9rPw(HlzK\B}>nL.@G\;'i.!:{ ,;Pv.|bD}D1`gb@ݛ y&4_!:@3TH[(9K+-OĘ_ZF"c(@œ{=Srr3\=񄾜?:2H5==F WIv_4B!2pb^La3~P9ѺrMOK:[קo <'J@tXq|i!TZǷ3f QVDCF+|b{lV2YbWDX 0=:'vxJI݆#A_tUګfe%u}ZgoIE- eAMXbL٬Mm(Ibo0/%WzM1bpRB="o,AB+H`~IY4ɄNF-W#+R-,{F{Nm^d2k(Rԏz}оލXƀ[bv@5ÒK9Ȅ l!~QJ9Ͳ<WtjaM=="W2fcs$ݱ_mI[at2>Txɳ̦ sckD=*O8>76SgP#q Sj]0k3J)m.*Lm MQ"i|޼wvЉ?*獦iH0lgR:ߨ[kwqKQ>XebWY;vrhu5~$}{:I瘚|oi(?$>^ Lv巖t0(50({aѹ8p1p-knŷtmђjDɩdӒ4p`"]N؜^TP-nEdoqYT'WVǂ[5z} olԬ/WM1o U[[R j&\Ll2J\pEJUZ"oKmW#(w"<1c B?XܩN(Hu"ea5\</OT N_G|jqLL;/CCO&i&|5i dyaju*äIF2E˯E1 ʞ..X;p& q4{-oa[*k>(د%~V(D泓85DyՊ|=֑VCM=UeO޷w`2|EvVf̝ `N>f[ךlc,RE9a^Y!IȾR܅;n@uAC\(}eDbpI_!OQ+.uw& m, ZxeDž*~l9߾Y[jLA5썪}[R}EXyА/-9s¶9R7!KO$PYFm w`ȯ˳͘ yјq2y`|iq8z9Q"쇈8]7MDRJfg; $bSJnrjEtLfyڬ0_IΫNY%lA:~Ý[=|>ꌛݖ"yQ@y5|OɂKgX#$=)5ɭ$а;c><#MwCѭ$#%Llm}g ;߷{9}W+']ڙd%"pAE$iΕ'`|e'-lLDJtΩOת閅9WFcdSJw>Bc[xEhv[t UL(lV! ?՜P^b_ !4fItWB+aa|*oT`OFEOde)n$<`~J2( W.j,c7xJ\O"S Aik }I9 +EXte*r! uNͧپ-r[aY#F񜫫"f?xR{Dgłq-NFPq` ehi7OɊMsbN>ɓ:%Լ4f~+Ey&RvpcB:_NI5t8VQ8S1N21g'L,2?)ϛYi~\Ф7_-TXN/|;?.'jnL/)_;@=ź=oOt$z#\Itۣn?{(^lQs\!l>K^GZ=Ɩ endstream endobj 86 0 obj << /Length1 2201 /Length2 18569 /Length3 0 /Length 19886 /Filter /FlateDecode >> stream xڌP[ Cp :kp $@ kpwww\{kfާmӫ %aS;c3 #3/@T3 3Bl B#]&fn'og qX8yYx@S_ F61ST-@NU̜݌w5hbk tP(m1ǀXY?ldbbgcod5E 9Fgwgz_FNvFF k#w37H+ #ى dE¼WYThW~b G{=Y+[;7[3_$L]lA.@ífff.6t7`+=o%_w>^vw@pvtx[< d 0lDr0 ˤ$FDD^ Vf_M(ƿ|mTMA.6W+l>¶-#I4U9X-2k-P Z0_ѽpzoɿUGؙۚ5b#GG#K~G/Y4&F[;w;=#_7`K0q1$  `L;I0A&"((*{?=O? g_33-M8u&v ;_? {O|sv.71|?O6-<-xߋk/_;{?}I0+VbsK뿘=ſ GRE̊Ht*6+ AjzeT`棖űcSP]hR`vFOn,:+˼)IPΣ:4(K߹B<Ɋ_g2NnPg%RQc/:@/MYK+@&k^ЄF  ,7Ul¯~vsIqm=v8K2ӉaY$~'Գy%o OHj@ؔ5{GIAáY?v!Eb4D|ib!WTAYkѰZ$!۔ '!q t4Q3+>*ݸe>ٿ.9Y?6ƻ` 2ƒ*asI+Nz⪍bTfbiGUy)a-dO#}D+WdTLѷrstg lJl$=Xۉ'0?4DH$"?+Kdbzh<-Kah\s,^=oJN@߳$%p( rɴ\91AEԛS_c*#9 oqK:6&Ġ (FZvjF|',bdؽ s^+Cr}l<kKr_enFbϚaٱ@Μf9z>tnY+,o[Dە.؏ P rm#>Aa,c|M6$8- [wW5 &XR +O{˻dQBoq:p/ fk\Vv?J"/?va%ZN%^170i'r“ET Gۗ8AuD&Q~i(5:rXf., 0›{ya(B*lCi%ZWo~u!4`d8Q 4nt,ŁIxE S∴ 4jiDG9T΢Xa7WÈ %Y4;GMY4"mu}>5N!;aPL2,e 3}%~Kpib"k*|ɺ2g%0lrG3ŰS e"T3H-7z@D zU1[Q0G6i:t @q׹/Lf>l)ۤEeTfN03Ěj/>Ϸu Z=u3$R瑊Ro_ #ª.d]VaD->p$Wv/IiTZπ,gzhm^+O}P@l8?aelmܰJ:od9fZk+!Zǹс>BűaZYʶ#b ewx3n:N_UٴG$52vL=efbH2uP1PBaK`A7|wgPzH.EکB m}ah խz6rO62قARB+fA/VSn^\mѨFUZF=qⱲnDkzm+$]8 $S`Y򟐝f^7G.7ؿTن< CX> ?.O5Iq@@H;:  k\JVw/&OдQ nnycL`>A⅝Qc1hs-ytf \`Uqxdi︙+l}pw񀔦N|kD+(0 BWukъk{);MeuYg7t YzB9~PO)c" -cNXTxzN^'ԉ>bR(rrP)'bקy\ &y6f[Z$/ OEW߇"O&)r e ]g?5>9j5֥V"s2]ct#m7Oz]R?GS/wN8S^"}6%xBӗ{,eLK,3?|on7I':|MDƣMnRZe.%- Xs叄S2t%{ῚZ`іnv9]UTP-%J=~6Ur,|gj,rE.}x&* +rBdL8_װ0ܑo ||nz'57k"L:F ` |-Aɇ*tUvl,N5IQwN&/3@L' r4ec>wƯlW*#Ŗƨ2q0LCYogk]zMЭ4[uziv(:Y|( T蠢*NK OB  o0*U4-smfMb 1ˌ 5hU&Bl|^µ1'D+?C<}硕f%Z=gS[=#j1r^8D#΍FS~a10ûajITnЏdI,$W6iD؇]wHONl zDYMkA0y܅ knܜNiBLJ Q%7s%d_kfyd+k,78emwT):+kjK˟Ln)6NZVDT8xB:kIzRkT[Ww4zaiQnХ4Q! $eZyy؎I|¦ҢL> pNOaK䑗TYv<YU<]rbIG욉sօ )%N SAjA4qy"_2~R+7mAXomT-{ۻMAGv*zWJۧX_Tʪy u "r_49M6HʱeWD(WFBZT5:?4g>#ZIO3J> }-&HTHh1[mbSڅߡAWߛ~}: pH:5љ heCi1OAIϘ4 X$|8SpE#Ж,l+U8|bny[*wBBRZa!wyJTr}P_Ll\E{$6 *L3y +(:O%sp5=Ӡ>t0W#bjzV(sT)(_~m5}Jq 9@{6NncW-Y\>ڬ wZEߴTZ23Uufq*,>!t./ܚם]SʅUu/bw?p`>_mw|jaRPkݴ^)j3QBpһe!L,؅*1ֈȶ0¤Ze4cU5Sa)v5f{WCC҅ ~'h4vvy}g]^ư7Ğ0jb~?dG.7O;Әg$3w|/Hɷ2کdñ~,!;Ƙ>ԅ/ DɃb5KL1bu&ac+!\< 7θ(qZ/QA5\?o63ۊe[Wʉ #/kz*ǻnN Nd-ߚR5h_1%:ۧxN/ &8$0UAVTRNvP;-@UBIX}=-cJ1$65 w`Ad9kpK j4%Ft觍g%O%G|7vF,Ob+Pb6;4Jo; gU+]px2sbmOJ%#k4/AW%d;*2Ø^@ɽ˼:u&UG!aA!r3hxI\BυuUu-RمSwTs[Cs;C%F.и|U-~ m.J{@&7̶ N L΋0V!0BB5B'DY5A#Hhy.xgj¥r/,QhVwf@i+߃,i/_Bj]Gt&㪢xcIϲnW:;z)1bAE]875>do0 |._CcAaۢ`2Z-kqk1V-@Gbbsm~Y .cϰ΄0Y,$T2u{No=+OTWanZJߋ䳔SeE=|;VhV^L.JHz^yS* Phj`}>OIe!qr!V7rQ)V1Ȁz&L /,o([W{e6onpr*]Oֻ%4s l͜`@xn[Q3-= ܔ/p U0!zdHda{Į~ӅoNśN|z`=#CxQCMNE3+F9?~y E>Gc.{JU|hg=@N.c;{^JkȮ,jyj{Ic7KejS_0+ZV9crVάN -w:hcV2[P?Ӊ~1AGɰ&t/nKUg_ s({t~mV ~9 gT2aֻ4K4,e>|Oj1T:O0Z'lLI]8n! ¥h4~(; i}\BSloq9COA0W(NrrZ#;yX('jp_4!Yw"ɽBr&B; d2?J^zQA>ڼNUS*WM2&.;y38N按+9Ϳ&&݌8Ʀ>iuF#naVgBuCs:)xͮ&χ>]#*PƉa0_c۲:yHIp͖t|"篃@uZ\u;b앞 ͧ1ӗ;V{DzS2ד'Y o;w㢐\NUξ%[z"Pʺs ͎ؖDi i [ +uG&_"S~ =,JaaVCPzs(O)B4Iĕ-Ar n ٲ0z=P l쨓&%wЪhF~i5 c= OusYf& o>ȉQ࣪du>ۧ^[(A2>}gs]8cou mI(8=V4D`뀴 AIq&W9XH?c]T|äx>vSgJY!3PV3[A]u2 C*=:KDp{|Tpxּ͠"0Q/IZ'I̴Ucצ)U̫ňB-aw}`@(p{G_=[úǞoNJS2~2\wg,u`}|ONДlElLۏ>h& rЎ22JoGl؝mT+\a4d{"q͓UwvQh{GYH|;͡I~b3`Vx~&򅼪xޟMVnǕ><%[i@xͰL~kAD\uxbUm&p edj۠)u;efFqPuthi\VJᓋdaRl": D 򟗧VV *(jHi\2dX-BPO#s= '9xjhfGfz5#ȼe9c~MKNնe U#^8qu fxպD\1ӤeXs %oьp _czV5Yr^ m%e +ETK^q9[loC-J*MF{:ßKV\gAHgȋx/`to'OEڬ.S97E:29$pI`cc[Xe ۳9@_YQʳӁng883 :ˇv?9 \RY-ZcKǧ'[ʄѭtrdRϖGCD[PˢU8V/{.BbzѳDl܁IW6DxmUh >e|>C$G!Z,4Se~ٍ~ooC'V/P?wȪk.>Dp}ti9@CZbv^G>:^Bl'z[D^(9n"%ն ݡ _C87W{tG^aq:,s~I?)HLGNf47s(4Y ` LA+YݲĖlSUhk#kv'b(!_񒾇aAMZ݇TH& lV@k;ut![ёXu+Ehī.-v[%Q]-%sP(#LEs@B}JBPPۻ3VЂIo\ʠtQV k_?-SE"{1kSzk¯Z\Pq3 v-*UV[Xf U> QL* +%gs~&kNJ:\-aNmlI\4glT}tڳDȶd Ompҍ^5( a漋__P.yS~3AW@6RhQȰGC$~"CH%sX;c&*&dt qJ3ـU,tyOk){ V ['D vU]HX{xy˔*/#gseTSÞӴ۰BT߄?0HΦz(}F_b)QT wAuԍy`WZ:3Ҟ$}RA|+noF[kEM\5|oEQJZ.SGiIAӧN܈x)x̒ELTY۬@P=bW˱F@Meיx)1*H)A9_izA'km7nC鍌v!t堖l„^^29fNeG.WJ@giՌ֨\Y+Ds; .)UźdKs뵯ͿuYDW)E81]V7eЕ Si ʮ{oWdSY#/(I-1J'}>(,#V}tzjL%BK Ī^lΰP vHr_K1){kQ e'}bF7u/2,sLx#wf*x"ҞjE"6XZ\@qg(:7.#Z4Dwq:_S]"dz[=EiW,>w+;q i ;blB,6ꢕ<9G] t=j;R=v '7oF>`!6T=O!TSI:r>DY/!%+o? TGO-;WB5)~B`y OДszDNjTU.yoΕ/ir2(mFulpJ N,LlUMοpI=J~ Vl9܌(#2y(*?F]ua͚[iOoجP}. A y!)QkBt䈯,+:J"Th8o7ށٴ*T`tI&v˟;L^YvD{Tr_e7s zN FOA'qnWa I0&L55E+0 ~w:m$JWqrGME~mL<WtDaTblr |eϐ]2B/zj,p/§n6w5w4dkѾsmK ðbp}~/FaQje߃W0HnᇙrǦ=ZD94CRtŲ;2q4K^A3 :;B2#R,-?֣UB[]=f uCg?>ռ^f|:dƞ CHpnD2JڐVT{ $%.h'U^J0!f؞]uf (4vN+Ҷp kDRjQkI lIQϬ%gK*AF5 TܺN{LQ yl3%LΰH-Ogg?ԥveDslU4!iftV5?n2tBUraYƹ@2BQ. 0&@D:_`߀Ǭl1u[a[:fXBLWEpo@A+7;q~9''670gi܀D^n Sw݁W<I7ӥCAL"(B8ጿ !2]E8M$iÂ_m?/= T؇׃=fཿ2u99x!pBKˎ2$SXak kxsL6vܾ!7 pߺKb%Z.)ER)UF֠ZVȢz?x1W.LxQ3dUr 6c\E*iFy>Ϙz8^n9z׍ԅOPatg:ZJ2L]ѷOShf+ᐈIhbAܡJe^i W]Hr\{:B =57˜^1HzmeƤ+\DnqbӪ¹psWz< 0 5jGx3ݒ䡺'$oW6TeY/$#z )0|kymTjmt~8V~r{)/d<~y$3zRx̩-5P]M2R~jc@ۤl]A\!&yT#a0zDJr[y2Pݟb+RY{̔&Ta'rk[1)5D;rg\w6\vnvOpu"3/pYM+ęK::Ԅm3CRªx9d>4JRy_ͱk@ܕM'yAOAŖ䔘BLaMM:SlTI~ ]ӖG[bbpD.tAȣsH:6!JYc~~o"0v1ze|Y>цzăZw7פKdDeF>OQ"n:CLGƃZ+vwiZY;2B~jy:]:xHO&YxҌC/ Kꢻ[ABB,OҵI^kQr$e^1DhԸ[I,UPR Il}*oZޅU~R@)ݍ v{rh09֧xbkf} 1p#7#kPE 6{$ۂ0-\Č1 SWb~}vkgJx-$: sTqRMBOj4jYdAy.$2eԝdiD{8pjEwh2 u`nEvc v8wn.Q@jBbp{@~V5ՃbϙGhc획ϨTSljl2$fΥP'6Os$UYYw\Đ^oG=HN%ؠ'Dw}bzuBN]Noa̛Ťx8P v]Cf7WY)JEno lz!'JX)k39hBZ,.<-?x_ }<=Ua'%^ f5j  %r&ՅJԋwA`ňµm5>1,A|fK h^D$?E4mOT1 abXFO+V/k"B$sVS3 Ǜ~^Ԡi)%5u[jjI~Uqmh^]FG|v#)'&wG#z=*Q"pޛM6; (gkBb w$:)B̄ -?T+>Ȧ $[LIrYI=qo)xDz\tשOa%XE" 8*R 2U6j-fڙ~׮0BBBO!H0MJEj4hv~̌-)]ճD\I0r13B,J!r($~~,)]aEJbNgqpE>0ODU}XSњ@!;QG-42CcsbU3U+6p"> yiuǮJHM$5 *k? |zg17`S|ț`?CKtsT%֛e& i7|&K #2Y3T͵񷑶X^V[>;f;6+$vk_BX B쉵CMBς!1K3`NbgK嘋3RTꛊxgx! $""|L*6˸̴~{N0k{Cp ꤜrǵ(T 48఻:ՈljciA^4^jGTɹcG t .JμQDVo\;>kP}'F=Ы=!BrtX:³`XoH+2lW),j&9DbdgL IҊLs0Kn֋pnuM/EnIpyHc8!2jXy0=%YM5ۇŸ'(T 6B~`Xe '7-ϻrL30yմ!v$mGwAްȽFۆM_I:OYѝ WLl!]$$[`¾}Ucu.w8H˥#cbu l00w!Eb5JiQ2`<=zV3_c$WՑ՜ŌϤ q~=cF"Cer;pp% 4m)\ k=<< +흠p/ Rt9?8u0Ĥbc<yT'$X8Esa-JS m' @(t;<NmUn*x߷emTW] mk+B ԵE.&x_6f[8:؍UK`ðT&o4&:T0IV~?lE݄<SуRk676rƶ-L_qVUpd_& 4"_B$ bi:J%o5p5hz-#GcԸ׈Qɬ竸]ST%*&0KUѳ!^E~"QX%[;+Vyj ?TUW-NyA^EgLr^ONsߎ97)Ġ]59A&OfvjI}:sal?pȋZH9d xPH>q~k^] >&'ѭ4,-p.^Gi^GK1pKqQl ]{;8ZQp46Ewp&Ŭ,%O4ǓzvݗX@> stream xڍP-EWC,J) bLZ?q?3?5l3g]l5 Φ{ No O)d`H X8GY6ϗ陑@ϋ)e  0ut4@e&'y ?8 `c;?X;('M`شF|6or6  /_9 7oj|txylυ lϕ+칋7|w5uW=ɠ7@lVYҥ*^E)hO34yfY^Frf!{s5sy53D#K3J[N."j"Wd8^{) s^Ek:6s{h\;Ҍ bǓ^kKDĝu.bĬ~R@ͩCǯe ӰObX 54 `ȐtoZ~u _yK9>$?s9hwrai?й;#2Mih٫nMΑFc"""sh!A$Jՠ6hlXsƐYzWU$QUE9. .lc̅@vbCPz'lC!<>4\|a 0k${\lxX#^GO?ߠ?yFKge׈E;ٍRSjt{C"DBDj[pO5հ>qVKMρV}s^~~vH8ݎFsRnCC,y|SaPoHId}Ǐg4'_a;zaf .;iHB8r΍T] _~`ׄ,L$μcҌJR`]n6mO%!OjR7日Kuٺ3RSRbFZ;V-' b +K0ƒ)rٸA r9)yvFT.9 qD;k?oGL= Oo!8NWwc^)ߔNk ]ӑq~ `'ScFM&Hq-w|&mn=)K -(֮]M\vt#cCl2}=@GW[ u9 _ eiE< zǼć?i|K;ZH²YRˏ<,$8Z@AlIJ_LH[HkINK\ս%V}|InƓZ^hmdf\*ctgV9\l;㷑;esaa"'BU"cӶ]͛A{u, G{9BlSZ1Yhmb:GF`~ o_}Hdj/b04T:SO4Oi|hO0"?c&SVt-&d1]ZQlY.li2@ƸxFS{<7 +FTx4vBigA@ur "^9;M91O`M ~;[؆ J(oP-;UcQUi97cA呦;WA*(i+qIw}1nSb%ZO\UDŽFKM˒Q XԼl;b2Fq~Ż&5ECܯN"zz &~Ls$6jK 0wsl}*f$zuj9|?KvyD«BHwG3 1ѢqPy jzr ]>zX2*JX "))I/2nkl.yR'Mlߢ7Wfbh̳릗!@$b?X.EG,qW7(=ee]E > FB2^s8 I *paYH~uGfL2^YZ:[9},r^8]%yN&|@qyTUyUɆP;,R̵WO+BVn?/m.̻xa4*(֯jxqЅu5d4˰W{ea;395Y]3+n5^⺇ySc}v19{MfV8 ^qkl&Lj\Ab0=]kt# 2st P854ɮ{n/e=C }_xFi.R@n.fe4f8ьVt09NJ*'W!_ĬڄK^D1m_GzjeDm 6&J&k(ŔUss%7zyUL YQ#U(vg<\"r<JQW1HydNu_tStI=您/~5CLJEm+ĺOcI YdK]>cW==q9iJ̐i1#Rj ˳텰ϮCS4[> E@ED>du8v-lIci3 U7D;AO_IiAŮfd4zCLA%FςtBlk}C7œy֗tzW91d޻8:1W-6}!M,%u#wp%j>ދyVY}b@c҅G۵-jhdW cb!q eK?e-5q9BVꈐR1V35P48rh egdDX[{{ע&4"}Z0.M W#ˣavu47m9uSx"jR>Ɯ˃36xphBYD"vunք+; l7glқ x?६u|/_e:OKRkF>@%Ifz~Z7YFϚ1x{RE`hEqC_U}+7AՅ=YH$xQc\ ,ؕ-p$iA>5GȷۦA$dbY5^Hb®!"ky3hQ;N,EW@&0o͜9  ̟`P#`  6JgR1]v~K[^yʂq y{墑p 1WJe@0@I\C2p`m9zn+4\~vT,s!cx>?2_GM9CZEM1t&<3.C;z1>SF"Bs* ݣkrd+NY"N Q+B%1s՝%Jқb-/}l,\WFqC10B㌰F?MeɁJeu|.&w '+wv!P1nbugM/7]T$~֝kGS΀2t|=Ʋ2|8":ػ~ F^~v,7($:Se]S!AD0@=J(})Rla¾){ @qUdQ{EUkaHײ֢]y3Gtx6'd§Q±cxN.4 7vxp zT]U1m`#ҟ fz9 DZN󿞝}˼b @b"L042YˣWY-.dOk[MHǠCOɰwf~D)؆Ii '"OҚojRw~$zWVm=QM1+%Ihs+t>;.Wv0|!r (;2+B-6$"# V ' Ka#ďL ?ؗǟ"'`h G,6c ?vx˭~;> CI̭r褿{mZ*'X]{xtaE^q33u*p&ɷpCaM~ -"݉_:ERaBS kMd sO4%z 9}4C[w7P&jktpX.m:2#ҷ2e4ҍWe7/f1ʜ!eKŌN:bT(ޡEqH]^{? \',XP \db x<17si7"țl3H:$9s!)q 9Ym2_T͞0M >]~[GR|/5 1<~ ucÐX[fIj2D4N7^o I|rP%?~V6aSOT.^Et[.KcźM'a`HZW;븣PGQU1U={˯~~mҍGhkKrkbǩ(Q^"&f 89{zfbO\Z$NhfEHޤ^4\}NjwڃϡJp!Dq6ZF*=A<:Q&ZoҰKHO٦G$Y$,4XƖoJ^ @u] .& mdϡ%qrrM{ B"JFF]{c-(o'h,ja%*놮s _\v| AyBuVASR,"ނ "f|s?E# 6akwlP/>~qc7&?'>صXBNTe D'Tp\Ee%1V1Ywk'bĂTq'a#+A`24*w88㵲>ob:Sv`K/44 3F'P64tTX\ď"B.R80},ju&a}h'G$f v-"l= UJB6hnE}>01@JDb ]dRP9˶m>7&UBF D g»k6*Z5ہ'ʾ8Cc[ M~mhŖ aWc0ƀ! 239BawL]?ŌŞ&-l^8/\2q<=0q&_s/ur y-4D*t2}q-+*‚̩b&}[ q(?ak#sP!3)@BQTe?\Z4le{0erD}E&(ǽ;FEu >VfHh!*QX/C~;tȂ7`H0WP5arH`rvCϹM3{uG)&7j`U`¹fXϟ&Y+њXePKuQr~7 S7+ -'uOpl1qnauEaH;B^ [B,[#U!zYeECe[Ghł{/_k>gz&R}70IW:y A^퇒S#2 IjE| :hB^Iq+)'[d!Fu{wP!iQG)H\mM%R:`.w/7Թl4otfiQ}EwHH\/F `1&XȽr(&>?4XnyI1ce 0r R~czk1(z;j9O(X =+yTL 5"|1qkؤ$btvsݦ.4#AŰp *mY^6%>RytsC$^07mX|,-H;WsQBpؗ8kΞq+g$GvL"#kE)g};ɅᒟȑfU zgQx{~*u~!1zb.$^L9D3쒙lZ7( x7m@ӲU?LV)Ti1Zu]-5*@٤1^a1:`}r>dB6\Zp,%@4/~:j/'s-,4 Pɭkn_o#l4yPKA]' LWg2 Seȫ?OsWOK^(@U&a&1QJמSJOSY[JT/獡}Q,yRsZp3=MB $5ͶS4ϱi[._ab@WF-__>ahiHu@lvIHFO1ƉIړ} =)+4#s~U*G/76zM"cbf-57F@0mOm,]c:KB1Nkbԏh#K2S+[|c!rڈ4iPMnq׳X8E|I_TW)6-b)7Oqa181~ِUҝgg =`/ڦK?X ׹>#uWd =jzǑ%oԧC'=Iîi݀rL/-hq)\4k!e7flZ㌔v\ZTSNw%a:ʲUڭ {W b2qr' QEעZܾO1R4`>_rUsIAmcЛ$!XY{,x=v<]mf;%4Ha;1e߮K Zmn@p#ks"?σ j^*YVf KLӄ lĹ=?ƇzH^dqݛ@)NukFpQ~3 y簒}P/c[QR*ہ[UlX  `tcWZ'miZޫ2rVKC|!w\+ȼw()?"CS[ai5[/r " C2P'Ѫ?Qا'St~NYڗwBpW ;b%//PZ`{ T`9%_lbGaAVyGϸ(m_mS@2U6 NfۘKUfNlۙGC Ku$EVxF[L)04].zs.Kzz[g|<3?i4=Tz?w4֕Ej6u5O g+iX2r8> stream xڍT6L41t"ݝ2Cݝ%HH#!-t")9gk}zךzg 6%,rpsҪZ ``Ёڃc0聝] 0? ' N(y/@(/C@r`P 4bmt̿>,nAA~?I3\mO'Z0 B0ظ: qqyxxp\8ab, @ vv[~ P9cqK r9O{;h+пU2`7';daspA Pk PStte A.';b229 ' =wy.GWN~y,R`O xj_<>+wn\PXQo'd`W`O uܿO8VOE V  puvS` p!PDOwx^ ~eD/K?˥h`bWII<>> @  ̄h g" +٧.+an;쉴`8n Z`?pqBaO.V0gpA.п߸<.@^?  7| pp>WnOOs` 0 PЏ׵; ;,>nب,59kΗ#[K>?[Q#ڒ5|_'jMc,|"*)0@N#W/KM[ڣ_޳axo5/1+f8tc sIhQ\9(X=q..g0xK}y{TtғP"^O3H}OS"S6sA)d? cAt'vRUfr=1*[t#Z70Cy6M XeہtY<kعs:!Q^EBIOu@s@!!ޚƬxRQ.WLNobf1N? c;\~Qݼ+-WU@ؠ2e$ߑbqKSk~gm$OExS%y-vvpC˸?w"%ǵMiXI"y2 yg MP}Zԭ7Qkf_j 9ai6B3[ձB!ylyK%'!R{(EvlU`#[5hrI6YA>0%bv$*g,ҘSztp7{4JeWcᒧv|fy_uUt;{n؛ ch3IW7\7]}FTLi;jĕyDȦDhQE,AB{| L %57/0 N< _.xz"@VG1E.$2hS>^m)[8ԁ زτ:b u.?~Q0`(qm=0A$=^F$\v|%t̤T : -B]A 14t|RW473pJZwE$%> ʵy%@29&[qbvEot|EK aVܼhP:H7:((x k|>uUC&jBhף+oh*s=%K.h᧴&I݇`Rgg$Kv\b${lҜM O?,xUX2d۲{F|XqlYTLc:3P-w'. Lap ~v{,M+əEM,E5rJR>x77>i)k m)`YjoI;2#Yt/ _8GuR۬ࢬtybn~H˂653hHudS,:kfE&|ytGq_JhkJc3?Pn7v"(7(ۏHIܿFh,A"+'CiY.@ .ZdؠOt:bXKdѾbPP/'Q$[ 7G o4]/[T'$uZ2Qp"}Ho{g_)6wBZ;yIs#i9|Ujܘח;7yRB_6fo_#.sMHRB&g -IR>ce1OU2QI؁r7`DO [~Pa|jCGxv b*OD}whLJ$q]nч j!|H nO[2̲"M+omH%UCQUgeZioNnP[%xC?! JV@ ЗQ $kFU q8fEE.-Ob1׳64!cdnr5 (hbZϋB;åU.vC##+)Oɫ뾰`)0"CcPɻ)ќ>Vȟ~c]Y1PUWgFF{*>?en6A Mu!}!#{,y=Q! ؉)LNt}3ŤCpeC<ւE">2~n ǡؚPax4c_ ?A.FD'=r|bgAo ߆i@RU}{nx6ӼD·; ݍeQڢF7I~X83|$l׸^&gc״i 1m<Ɗ$OH7? biTM~_m\F gU͊tA?}q f+=PU/#JcKC-! Mqd/2<*c $ϯh!M7pr2N|$i*ŸӝGhs-M\i: ؗﹶY3i{P>kKhbt ATc_m~ g.DRn!h^/YJ77$./2 3=[h{s n{ UDn` .LߴM{j^WWB%7Vkq4)ԝn̨P 0EbQ4X`uXn>քYS9q:7K/w1kW;qfmvnRy8iMΠ隀FeyԈD[FaX+E@ Obw}FdmoLλ_aA/aG[!T:TIkNògPX̅AL$1˜#?0VI.m3rfo{+=rK̰Ө^TLJuMdhjz@u [\]e>d/?.Mh !M澖[b/%D/ag-6S<-\8c bymn<<ߪYD<0ʀd@*i;v v$[s,5"AOF'MrǴ-7tJqL~zEhOX;Թ`oݣplB?Jg^FIgLb{ĈSjaO@6-,Qҋ*d?-fճjI)6B4pmQ.Jrܾ*l  b0T C%bH8Wb-鲉iDQ n.?|E68lDW-&W2ǝzo=xՐP`W!>Er6j"/wft2سX$y/~byC#WgN&,z^LO@xU(ΐ['=סrv\bR<#YN(6L04gOVGmo&|1β;tK6'9::JmJQ/"O߱ex[/8h>?ruhv;PZثIgs;*f%DaB4 xi Lܞ;n#cڴ 'B.uBpUV#L[djR0Q _(!\BըӬE+GWG=8~3^'Ȥ=ecLpYZEs2t VcAS߅Tx )HAxvJ{DDrꐢ_#A7([P )<gФ +vwFܣ}yȡ_F"r U)D }IāTׄteu'ҋү od.>/=Vq~0TN4[J:Ww:åN1W QП4HDA,8%0dwlkd1Ԩ783/RM3EPUKW!n}UӏtpX6K\$r8a*g 79

ݍn^ݺ`%zP K'|w l05UuULsRb] ݗ"9%Gǵ"Z@\ NaIlD/X9Пb| ]o A@ea,wn"]{]2+W̝9kcǾ6r1"jZ;T$G>&z}cGa<@m%ϵָavQ5'y\r]5}T?eN} 흱n~ .mf;+}6XҠXV#"K\Tܓ`$][8(p2$k\-89%ANX촛d 7@U$iǏ CeDpDjc%8#:VS++Ie:6IKM`<>!%޻e3q P>a% Zq Z0eT\܈cAm >9b|Vk1Q-p՟֚ba#٩ QT-: jP*⍪uhZ'{eCE*,Qqv|mD,՝{꧳!6;F[>ou@$DB~| ۭIgd,/ )4\(]-̓%+ ͠~Dh* u՟"Dw\C\<\쇒"~r|U>:wu(b%yE}%x`=Wjjyo^$eyۏ%.A0KV:0~gdJ})vAw<W'~4@W@tY`؜vf*!$})^0Ag6 e$sqZ^( f 8ne+5nk[r. xwp88Λ;pR9#&qɁsd>j`"zopivj#}#ۈs َ#g֙2 |87هAFDf#d>!'V *7T\[r{L^[B^dwV yMu4Wg4*eסa[{q#Sq T;} ~e/FC*fV-L&BTH +)amΥ9~`wĭh)AIjʨyq\m\ސ>ó/ތ݉ЬF~j9sژ”#oo]~ ށCXGk^,l]XP2x5iYP -B_)Љ% lͼEbEgF5tͻ?DNlCEN>jGA6 v}-Bbfu)c괟nL3va8 L7DEkG&Uzua3@qɬsfT\:^ ^OL.TcءQ:Q[hr_ aU~C[qoB}^Me=Suq!~mC 2}kYfbeCq4FzS%;e73NəkI -^%r(  endstream endobj 92 0 obj << /Length1 2239 /Length2 13369 /Length3 0 /Length 14720 /Filter /FlateDecode >> stream xڍveT\ٶ.<8;wwp(!;w$ ;{s;}{?ި1>ڛLEI dٻ0144X̬HTTV.?$*-Ȟ_6N@cLlȹ8ll<vVV19$ݬ9=Jdea?t6>>ƿv@'+Sc{%2xWw..,,v ' !:F%@ tr~ P23@o:  lL`'W{3.Pvm#?1?޿Yllj s0[R ..c{߆ƶ Rcpřw,À-io&ڻ8#O h '?Glcrͭbio XGftpzZNK[ 02݀'WfV.=ҟ`1o f@LB6? <3z1Ydeԥi `bpH?U^f?{BXJ 0?|gb5/GI/ 1,l=c xA॰ߦXhfj.SoL/-vV@t]3_'`vW鿳Jڛ~;7L*v..7x9̀lrANH"[eHΦVm̀9#r `1]9͞|8)<rr:$YZ@NWl?Ndgnǃ`?zMZ <,ˬCDnpGXw3J X@?7G ~qG^0@<$[?5sG rkl`. X (yd6,.Nhwпcu_<1dxi wZTSW'|\S[?'%4EZ X7t׉3~ּ}u%DfW³)'tÛ#2n)T O(n'  %IpNvu !/-PsX挬VJH|S= O| GHRYX|0OLJ+TYOhuPx\O.rVu*0i$sBr_]"ݐQ4WţwK Љ~N<Q 71BCQҭ-eNcryʏFgeh0gzfQ)}|I2\|Q;jP&T6aW;a>\M4 9} #2D߬^!щm<o'[G6Ry_^gX4CB{&I jJDtQE}$.f=dh8V?4؎NPfe }u ^+Dzv U!1=P.a=GN56|u6&cq㈙ׇ&dX$n*Z33, O *&Ү`&bf]t>>4Q~$H x476ֵ8;ҸLg<2Q׆짆Y1w_cH?ƣvNj]g= jް~aƧSg6nE2;匇r.$ sw˕묓܂A Q3i 7  Ez(_WF㗪";Z7\vZ1rV6է qhp6m$th}j:f7)>=0-SKpJX3CQ +lD~GC5Lf_3CŔ"AB!J7?DNeH( R !OЗ JVŗ%HYه^gEvQ}zbVOHE m81Y2ݤ =%'zqJ n"Y斛.T 7{M{e\TK'ϝΉ"Oސa90d\ $US@ķz9G7RIY:Gu!%Y>rV˛O1I ")s8f?|:Q2 Cc4S'?H@bh"\zs&~a1&bD*&4avɢw=y^w ~l$MZ%禝8G1*K{j1ʎ Yb۶x|o\!q$@>-|kYblN}ot#{ޝI*3@vFh>qe<5{9}t(Imq7`gb= M1 Ɛ(c9QrpCC}Gʢv5Ix 9xi2eJ r5 ʾDNܥOQskzla,xw*o YT}o肜-`A͑j;_zzi6+(iX!<;PwDc p8[?$,т}l̵.Mԡ3{Mɴ}7͒ڪۃD_|,gu#a@h:br[B2l*_+x(r:PD%GL:捒>\O(H'y]~ͫ\۷h6I0"[zS:PȇdieHtTʐ'|Nf (u²q,FAǝ+tx~ϬbVҏ#Iᱏ]3dR0&qqJL*Hٴs޿ްD|JeL4xx90~PDQ9!s[XWX(+h"&M|?@sSs ƙPhCe^_;G0Y_MDkY^!~EՇDvEG)՜;ֽy8U+!jpX|\lM*+ڪi+8õ`G|,z!n\^L\_ TM!#MUH"Lxֽ ^*E3n7/H(g=U\Qw5-,ygC of cp[X3"r Z4IeD7bcKǙ%Z kYDX!v8]`N]&^Q>߻Z-OԶbpdmtUqG霶@&rp`H*6-'pع֓)_@>D3_W2鳛m](uOߤDsMXfzS3|iϽjp67:'!0˔ˬ}dPy ̧<~2E%Cs{{7^Vn[ ^WkXp6czQM^{x 6; 2s Zˍaq殟Zljd gs*f6q:pګpb};[U O GbE WyrOG}Z,b B\^B<MN1q$a=7ƼϿKtgҭw=@Hb TruͨH$oqrUT9pY@ gU)CJ̰ 0٥X32ZKG4$81,U0CfL _[cܻ#ݭ\ԨCԇViRlƷ*;}.!S~*\Sd.TBJC ,|S=Kjֶ57p(az`rܽqZ2a'\opZۖx|b1; Q66*oׄo6": Z2oW~a{ԤTR* Fy&W[uXXn3ha%P'CQi,.)o)-5 {|2{$Pasi9EW_Y D@_d5{7dU~/s} r͠PW%&3%-騚) qeD"/Y#D%ϯ s.~􃱦D"Y[QOs{HѮ#B)jDE[js"*Bqץl0KThR.)k=֍@+#'|_%]UfUW8n‘e*[x_5bl1j #DN$`-F&{KUUx[g-@kuU۶NrrSj-3Q T} wʌAIilTȜKH#Z{o4m5RܿǁpdvևxsR#SH_`x\ˌ?ߺN;dN~~Oc|3Qp}τ~0rrauUOR l#9D,TX_fA7bvA ]7iT8#EYC<<ig#A9H}3,t|r=xzru z1@nTcxX Z2~{Ȕp>o^|_CqkT]/Q5:W၁1Ii@NnW*JltzugˁrF+vC8dhWZ)I.hKn*b?x v\ #ꢏEXBs-JlFIxEttHVW^C. ػog}^sORe2Seg̉]`ʏg#!SaS#:X(G%z|k)/&\sXg&hxkcBT>L)z/ny |G"luu(AA [dHE\\H_DF{ͭ^ &FB1p4&rN[{CU_0"9OBDy,ZVzX1r'J\ӎ&9kBיiH[mgtV II?TZ]gy_ih F}yI4MfvD(:!Iʱvy Ux*nE3J|^5yﱸu? D`UuR>di0g?wV!d+H/8L3;{V^-h7т~NՁnjBaҟ?Z Y"FaWOq]S$|:,Ky>kTuM_{"^@jHA+/C$u*D97Z?fcKTuD%zm_Ni;ˀ&IY.eeT#4KhOGP/ ѵ|u†~yV$Ylz12Ή8 w+3aAYezЅ>Wb!@SԻ8# =v'}kSd=fC-N @MM:O&x= ,é1DYZ!^2/[Ci/_2 Ϲz }{7CvU {;aϓ:,왌@f1X%7Z4Eʼn^zv*,öۥ;S?te&CNjbƾ,O@bHsYv멈D_f6:">O~^q[#w@IчO 78A!k<Z i2}ن aj v*׃PQ#7DsŐ&H.yq_;iGBau MS=x%Yhxkʥ{l=藼+ `z+PRI?Ʉ\uh:4U-`+] uF Y<;"Q _>e'䈳`nx$(9ټ\lSՖgeADmS=9&&}xY Vs4xW8"^WBqdo!Eng)Sȹ2 Jq܅ƣ=wLcA2 4IטadI3O>>b rc1 ewwu%3hƅ<7NV1ՐխB0Ac,M5DPF>>]^j:2}Tp;PvY/E Hintq !=MiHQFtۭevq/|?d-$a^rpԵtRpg0dbFE[,H`/X"b2K7{9b1TT W:倈cVk#%+c2YL1~׀rX"0[&,QeCI8 {Zl]BfBK0;5/O<2nj`ŀIc1"T~t[ɐzVkpȉQ6bf/GClKK&;dfCv@5)z ~Etuy&ZeT+oڂF)$ @NU?)''UELoMI`[,@ #?wtXfE1MZgq ;cလ H^TW*d+Gx(l\(EgT޲2x52BE^{\c&q*x!Qf+߼?ItY84*n, I CJ("ɩc6)Hzv•H;݅ 1;D :1<ΛZ_uQl kwUe?mt񒫢|~4mM6.Q) 649f[߈삿0K{iW*0 }; } 9eڸ,d( 5Fˡ)*OoD$žmZg X2rnQAN!ô-R1kEC$˼!J$h@wU3dA Bкs)ch2j0ED;gAY5FVhyx R][O N%]a R=:^ZpWWo#/7I(54^Ji?JL"ux|EIYnIϢ7ts-&΍M;"dvu'1_H!ql`Pn*qެĺΑ<%#sjڴ]`oiEb_ HDbớq_~B`CVհ+ܒNy Rǻv͢uX*ϚKLWd %OR`?tP~iQ(*\#)ubU(fOZׅ'N&%$u;^5Q=?ĭ 5́^f$q~$i&sckh*&.HT"zr٪˞ڧk#1e]^7N ʣNA)us Z^﮷߬m(B0$xQr!s[84 Հo :XUL3)5=t[7ncxXCNɔ%2eH)bu\`J;ɒ {b-KXu>>lkEc+Ctu§Tvj? Y1T~h+@J$svNɁ>a9(9H{ɔ !OD.4xqYa\D:( y83[ͥ}?8]:^܍//:64eX E*\4wPc3Q?8 R %΁E|K8%y}C9Ժ-Y z4imltnHEte>bT3k4׽g_\'ir#NQDx~Gm֧F YkecKXkߡf{D_ }XD|etYq!Y|fC] /+E0lt$f✁sҒC{k+9 * q15ՎA<dąM^*nbkAj&Oq;oۑuƪ{d:GhpJ_ݬ 6:8+qش5?jsXԛF9 \Wqxtb5υ [ؖG4C JEn_{ aS;7"ڻpiG}e6H븷{LWܺI \`Q|}jiS2:')u=tE棒1L}rωd~hSrBմɓqz$Y}7aw@ΆˉQ0~ ?k h#,#wƵ'd=Ժ1SH zz/y }Ubޘ cr\8W|Kph+m`‡w7J_Q) e 0Cʑe4ůB#[|M,=I3q'Dݳ:(ۂ6(!J(Ôn 3ތqj5%)e~Yc 5Bܥ endstream endobj 94 0 obj << /Length1 1824 /Length2 12980 /Length3 0 /Length 14128 /Filter /FlateDecode >> stream xڍP\ w'qwww@# {pBpwww#sz{c5檦$UQg57JكYX,v&6DJJ -?vDJ-qGM-P sXXXXl,, wHL9{0 Rdi?3Z+//7ßQ;# P4qڽu43ۛSFف͍ΉRr@s#LƄH а9Ppv3q 3 -ltu*࿂ `rL-w@?ML %d (K)09;3L:ٿ囸lMLnUM|Nf g'&'32Q5K`g'?Ifo݃õۻ,@`s?0wq`>e%y3!c:8YXXxxO 4<:Y0`x z9Ύ.@;!AfS%O73/v w˛X,|d0s{?1"#)&fbd0qXY8o>[G7ʂ-}{Oh^ZRS.@Y8Y޾X?ϔ*/#)[?4M@G)m vC"b&o |S4#+ _vhr6K557[byba?%3yEޤ CWlfoDzqrLM< qX߶L`{ی> {G?,O `/a0j /7V菩zZ -X rAommy̶o4o |a/Fῐ--mKq/_!mqsvn6?퍦?:?0sq|i? t!./؛YW1Oq ^F\ޓ$p=T xbϋ\;|h0 p y(3ԥtc]$~!⼂UEeᓬ3{ .6U!J=%?ᑸz;@TʦUE%˙JD}ḩ_+`d8ۏ n ^2z yToD_1Kze8SKĊNTC( .6^S&qY{H(C]%Z%y:BtEQiPcV|DMyZ %.(J1w<a}7weO 4$#yZ//.Z}t*qwI /O|?YAnVצS~1Y5I!m`R_y>(O2BPl7]jWDlU pzmDcߜIs Z$/MO,w2+.Xllkq(5 ^⇨&U3q0̚k!3ȗkId⒱_3޴jŬc OmIˉ=Zz̧_`(A୙w쳂487i,ܴ'J!f[v(yr]mU4i #Zwt0M&.Y#v>Qp\RNp̡2$խ,>ulYbRǀ@OC_s>5Ug>֍P(@; \QIa'_QW %:ϲuIv |<NZçwc$(NMs+.FpͅHuV'cNyTk&+!߭ҿAT=hP^8daYѵa0.o14mm 魴(J4,N]a)x9wrf[C8 0u ńUޭqd!SQr|G.hl)H_iNP+)Lu"DLq-RJ=-@s8˺RI;~BH7#!fe#~?u* 6nfV__^vT:7SG0'$pwL($>5Q˾ZPKtϒ˙&i-wBGj@H5u68B/m&lK仇û]j`n5!~ b3ϖݛGRv' %t\ԠHaOƊ 8 abU3{/]zJj%Am(Y Άvc~k䦊{E0E$CLcŜ_jŸ6 Đ]l)Z޳xخu:ą.IISH|v3-3y:7p$1#h`jSrSNKo,fK7ۃyu8ϧ2#6\u#ac6*۷F?w1pR \BѯF6W'x59ZfQOzfhpvۏ|ͬsMP(x>cRơ ],wfM{\n0z''`BW5(E5CN+f;?U7'i.n{K*TxI6+Wf-#$R>pA>RkߵčFr:8l5Q,6;eE|ajO'-Fj@Lz1, "[mў9"-]!6VnImqAzX}S{ԤD4_lT@G@N˗0נNZzj>Ounm΋Ow7T3P ϴ;:_<> xFNwEVQ&C e7Vׅh9L$]9o:]%"JdфܸfR9!y5߅f)VD6Ytw&aqO)_" A/ϷX#_hM %.9~ m&ćƞ$d3 ^ _ _^߿aqtn69͏~]lvW~wZԳ$:ޠ  gϩ( }>jupxx0pdJbf!Qãr3טU`~29_եE[S'w6fC7&{2xɷhS[2҆_gFNsҙ@VYi"Ϡ{"x ^-nLM4L@Pte AYpUE8`__aKKEh}4EHu%^) AREHDœeMR*T3aNqFlzªXs#sm ~INO(EK\RȮOa(v۬Pi&F(^F]DlTUcts&sN)3"<,xr3Wr;&F?xxyr^HAO{ZyXM"KpҼy >Tg3ോCj)5 X&Vm ^(P Gj˼UXA]~F> aOlP ^Cyixff$ѹLXNB dqҥMH Ӟwip%֔?gt~k?dz^Eo$08tf3q^>  ԡ_R|ؐ!\4US\󝜉ɤ46K%N.,m&'AY=/K_^AwZ]b:3Z<9VFUWa_4bD QmدYakgrGhyJ\sxZդaYa2_&Sc1kE|N486dž&ji%Ca] &b(H] E=ռPre.§ӝNgؗˀ0,"M,c2Ӎko=>i\nmʲ~ VmaW8kWV~3Zd2*iVu1lnN)78%sek6P]V1[9.;]suhX-vpKĒW%6*K?.%`#I]vS @yѽ`2O˧iYyܡ?89b(ɣR9Ǥr$;<!,FW9<4)ZBԡO>&7&]p)S5+,(wǖ8J}4k@D*fllv#=5оEQ c_0[:xe2Gn~Ul,;Mhq*ı+5>]P'>HG#%l #O)(Tٸ7(7(Nb|Yiw&e.,tR!d#Qtj=hs]vi*$~|^ғ"$Ϋ{ҧ 8tC&@)M;-/Rt,p>ZMOؐgYQ }#G[c 56ҼuEAHTEѽ~Z šώGv^7 DCdB6xRy=XYX'|Qd<[mOi0X VM{grഉ7eS}]ǒ@x M*8:&_ H8v*Tt7b+:XqHSw0=LDI܎QH`}2شw=M~:5n+W'v/{7LjAF+i ب*-HV\azUGLC [_Ui>ęS318ߓ->7.Bdؑ} [^o恶 yFiWH^+8pnep%wИU&"!~Si[djz}O0Q\$܁ɻ{$ٸ9OuQt8tAYvP_eW)`@Ƞ#-{c̴po;yqrNhmjYA&}@SLC"3= J;6u*fgsUf|(u㿍b:f\*ڈW ?=dq g'Qd)1Ic9]q.},o#"T|_r3OUmrd )|:0氰. 4CJ˝ʔMgHw5.SmTbۆj]GԻ8 1vIщ,MǙ%C8s~K (02 G_x Gbt<{]'G2Bӥiv"ZP5zK!Mvn&a1K-O$ME" 3G Lxf1=WtAfے /W slvǻ GKC׊3g#o㌞yҦ\G@Z.XGXAg-&HJNMm|l1aq变8uS'[Pro( 0'W3>ǭ]zn1B){2CD&JރvPB:IQ5~]^wz<w0-_HJ ^7,q\- *{m^*haE~b 0UME5߾)09c9L;-\#/$[O3OUt=uR~QU" . ZZa3DXG Aa5orceu@I-1ҞYTӎ*εcFBOO"d D>J֑$RA ohQ jl/qI3c2sܧ"LeTZUjoX]J:𽏦vwPHM~ y !ΉDG̅%S}`P\/¢ pic?C@V s`OB*֞ ·e׹}Kh|6/ȑmѦKBX_63sGfb&W؍||$g'e') JݪDt8u=Y6XvT<f_\[!m֥G$~~/-~{|bo&7RT9؜paڒ FH\&<\Ө8}_QtS{*oD]a2Ne#lhXMƒg42ʆf\ǨƽUsgW8eo?0-$xױtT.vG&XpcJsAD8tLIb}CMHe 3]vs\,~L@ p7L>{Fm҈`fJgaorھ/$)yq+9PQQAdyq?5SӇf褞ܓKzc;""妳q+w}c!qvZCta1؇XI8WTGh/YIOcL,Ą"ٳx^-sɔ:<㷗X҃˞n+AԚ1UmV %=l|?:p(5gƒ>,\!?)pGڡ$hiH|Mou.2JcwfyŸhD< )TdiY9f7e Z[l"JR4DQ0n#ςO\N5 D _'_[/Z+Y_~JSmVtP!v8`q@MKK+/_4QBbOӚp}oi =mFZt_ZRG͋׌OJ #M,_Wp4`M㳻VSW+A{?:4lSv֛mQҚfih76ܽF0?[]&q7J'^ Z-KD4vqxL|puE+ 2-QAyVQ^O`)$sݬj1/MfsV%A,YM<;ͼ֙:JOߔ`#6[t4_gcF_!)W>FRWf;VVn b[}_KMz>!G#Z pk+"AD4$nn/28w|zf!-ϵ]rZ^ɞ)d*bv*O+VtoB}n'JE^v-%OsGtf;CF_n[ن!0v7ReE:uçP껡 axݒ/QE?8OM$)SdL0GvU%@|flͬX;/dGQiK72b `чUweџ}RCyu2]|yMj ڇ;!\]A?le 1lvcnUg\=z Hc*CKPd*3~ʵ;)aXcr)M>w@ԜEtߋoej<Q0XHLJYפN2ҀĐ)G 9Eū`_|3<{4*|0OsDy;B̓ÊԽR܋ʹ"Nmee*s@Uj""PnI&tXt_)$Bܮ}H`GHwR3啀8-#%O=Vvǃb :˶۲A('ͪdQ ~B8 ($E*Iishux69 ӣd\?ң _ VЌ0ϹěM O"] QVV4kG[++oXʩ6͊?~7k~AHDJ+Cĝf){ :ؐ  mbOZ/3i;ic@YWuwI"DbZ>to#rʺ\]8ԙt 4+@W tRU=wY~UO2{)g*[$0ܱOVl_ f Ea8"%-TbpX}wծ"gj")i*' sI oT4\.AYDHX0ߘ[ۦlkg1"Qγ e@k*WDQ"G ,mX]#(mQ )-8hC.#mP7W zJsBY| ΨH9oVTSp zaBG[y+TELiZ޵yD)s'z$&{Ր>~4@ ,aKŎl H/b~$L,wMӶzb<3qG+^ AT6&}G-EE3 >Z2Kj51{o endstream endobj 96 0 obj << /Length1 1861 /Length2 11851 /Length3 0 /Length 13017 /Filter /FlateDecode >> stream xڍP\ w .w 5 #szvU=9sUSS3CLAR{& 3+@\QC `eegfeeC؂cG99!|w$L\^!9W[rXYyqH9=Zry]?Z3:t lfbP4qٽhfb PA.SVŁݝΙd)DpX@ '79%;ԘV` w'` 6;ڛe  `9 3d33'`]<\&:C^ML&nU2řlG?ʼn8dG`'{}6w{ 4]X4 Yc^M,A.NVVVv60bc OПNW+ /Bv6q\\Av/B`3)lOW3/zN`>?~*boOG̢#*7: o&;;**&࿻WWVAZJW݂+'L?v$jkWݺ΀"uo6U]WuD-m`g)\bf62k1g`{ `pټίz]Q bǐqrLLjG mWm{y4SiC6?8Up$Z7@D¤!`%Gʃs/Q7Pcc9]2WtdĂT LFnꑸHUmPHzG40;>sKrw'iM*4n"6Wϝ]8R*_wNDyL1bMQi9;K#}yPdm+N]mЁxh|bɉcsdQz9n>DH rh SүȠ{TK/3PS l~)*xU?NݠǔqoUkCkK@ni]%i{7crhl4<&Cްjexx;324Ga׼[;.t촃S`*%R}opRi35|[& 6R-?ka{m^{ş ruț)Niif}rB{GY"ܢ+*ѫeF!:5Y_npwtu$\9~ĊɶnFKrT;8X͠eR8\u;Ҳv2]gGF?g[]F4fl>'G6jAP)=/20缄.Gst]DC-yroQ`yzv?Ƃk#K20Lؘ Դc[͕i`TljL?/VPM8)31?03 =f;0'KlC5 ]xFHI@]қC0)3?A{NE3Xw j>iAhFDgs-_O4ܒ‡b c.92-wIB{ٳ:(G|lxmj{חF_l2 .'D0 MblE:TJxfp?jF0CҨht3|PBcvC tl7o{ nKſVq> <$vD2Dw(򥖯Vf6Yl@˸FnH.#X&x=d$eywݍS!Cc2zĊ9{Ry 94l %F>}uvi65tLg :Q4?Rot/lMJǿ+Uj:LWT\n) 4•5uJFow՘M5 v0溷!~5ް2DEЈ- lr}ӗcz )&s[G+^hv͔+k S?&%c?Ouy 0mI>sxq|o}Hg*2߲13]udLf(W l"))K_#:N5 ,*&t^X>̛0#B~}Hl:܎5 Oj}!PǴIޢoIXY cD>PņE.lEhoֱZpl8ߧɾ!(& qTymKլEKm!*St={ K2f3$OB&@5ޥy00DCcv%r[z#gq2k?|J0v#|SoFxcim{S]q؄>:J1فD_#bM n}t$s^`3bԒ%Wޗe nHOi ڙu -trQO3XnH(j݆I>#iT8vOr/eQI"AFX-(^'C*aJl}^eQIzr&hO-{u*:6U \C1 z{Ta_ŀc_ 9q?U1rX8=3>zT,{jrqgTVTdM3*rI 0&VK&; |aꖙD.WZ6h/`t݊.^֚ӛc`.+/ׂX $G઱N{$hLJ1D1-FBXoЀP;T' z+f #O Pnհ d+5l<ҭ-Md0!le0I.pp*+2<`\62afl ih^+wXZ$*O;nQz67A-˩hRWAw.yJ^fmiE'6gle$^4]|;S&ڢB O0rd2ax<źM8Sޏ5Lo\^f}U\<yH~l2|5v]} #&o(>ha ya>0DI9r")G¦Sٺ+m.C=6´sVr$]mJ Rs]tn`;9 0b0@iѸj:igY\S}GǨ8N*)s#sd#DCq-U]˟~ O'4 ;"wU]Fʲ-DS,ޱp^LNhĹr3Ks7%4oZLΙ٨8 5p‹x[v"M#9Rj+Y`1KξTV{ԡGE$w͛coP]z7](KŸ̏^+k"!ɺ!cv!\D zX -Ӱ#Or9(cH j6J !r=Z|heFDvC'͕wG#CL.V* )R<yd? rFY-b0}@f:XelOÃ78\ZQIAVr>1GCDo`GR5MwW]]EgcE;{m{Wwۀ`u.t3PIO;1] K8e_|\ ɰ) y¶3B#`."zYRuN\Y XIڎ9=/o18#%0FE$_aYT/\-.idڶGpKSGjsEfHJL'.9q;b sznX-6Xr`/6ODг{Ib,9 Wآ,y9mO~c'l[^/D\WӔ+(d^%,"/x\f?ݑ|{pćgK YڍA>q^RڈIdFS6>Rgwa) e IVp Sfi/TrD$|0ؗteL*JVQg#Y F#ݑ3ԇnn"SQO٩o*+s=`O͟wwBX~fL|W4>, 3;){SGl#zyrE6߰,.<'PJ~h\F*_W&\R:;OWz>? P09ddO2xOާ~zW^o4oÂf([Ҷ7QRuM5Um pK36TԃCVqgZ~$X%+4h"137X[D{_]{B?¯?7>S\}Gzf ߬4{-^ ܣL@' OB;!6Pf4PyL.j {gWYaU ľ4iӓꉏ G(g#/N.v"pN&0rԓNO,+^ n HYXIG+} 669n{L/xsKI首] z֚2JۭSq-=B beHLc~ŧ_xKT=bĀi1ƒs}iTBp3{n*?`z͸䟱2ʛTus[.arFCĐMLn>RA{\um[;ڿ) dwD\#%sXw S2~ @q:]z ,j)EM!\.{n?gIxё}as_awd@ 8̪ض:mH_|{1v?L)>xPH8~MvNv7VKuqsv_yd)X6|l.Y%:K:iLx6{dlcmN\^jbf[y歹p'1Y; ۙlE>a~;Ş4MJ<,o7;Vx&Sρ͇K@4rLd\ 麠MLH>_wbLo ']-*L@y5^v xPi߰CXQХ„=1P>\ݹuo]R=?2X;%MxjXN sg%Y#% maA bZJ7W=M +3X:znHeOa\a* S O0`?~+tʱ Es9n7o5r-: QK_i*?W׭!Qڛd6~gBܫg h- =;ߡPْGw4jgMo=#3$kЭlClڵ?>wGzX5><=ˁIO-@18EvfPj'p{Td A++ 5yUAZsmoBO.§țn"F?=-2_^d2'7hw[DxPIðFUB6u>xlFEvFNcX@YZob."4AS:VԮlqpyjpG.ip+*K+}W7JAeH@RRGq\Nd:7~3n$,>%d/OSj 1_> Yoxa˹XE5?BKhC{TgNT̸p#K ٖn 9($Wr'3!r@c*#w4h`?IReBglLo]g$w>eSB?\1l,q>KDI_C݆:7!4;Ǡ n-S! t,Q(Ü:P?Qs?KtKa^>њ`{_Z֌y 5[o̔x {#M1lbyRU m|0 l1/k=[\UT4%H3[ɯ$gcxy&9~ڞYp!{RxTHvNΙ+k=y96$ ?ֳ@J@G[2+|Og,!t{އTb8z,ZNOWp\h_-oD=Rx8[za9øy:H3b)'ꖯVDsU37+Z47zQr8jƓfJ;yn~X ZeNp5=QWT;s*җ/=~A/qSENW1nLq_D~3ABx_##Y[t}9ܯJMN+>p.ޠŶJl[誵U OQ9Ҟ BA4cmO/8AG6 4ѻpp6=fd+_;*5SGÙCcH0 /bvѰ75OLbkfJ{$!%W*X>5!;pP[$3!?0 XpX=@5R!;LDy6pJth=1sYїy6@P\kotOzz2^fG_\ؘGdW)%Q _9+vڑpxwriTh3sW|aʕo|ogO0UHFp2nY7I- f ]k\΃]2-¤ňQ (#;[db+ _k||JZ¶A76;1D_6WaXuZ񼪃ƪ?{g-WoQ3USGilh;kT/V֜&og3f{$_R-e(7[IM;b'x.~4O6V_aD\_( uJLg9gUfy0ZyR~ P A ':h3%O:Ѥjnf=0$1ݪ~'"M%~9dҚc`J3紅6w-w~`wx #e,k?dXWmGnkAH0=8#ܳ0^ B%^HreZ cz f'Sr@[t`*z VkނDdw.0%fյ}۝! Av ~> e Ezs}&RZ@"ӛ/:EP0kĨ,gVt'q0|fKe6.ķl<1He>s%<*4iDnjtx0B]<_$Uo}Pĸa:Y$T,Ut]O}ghG[Adnyss!jҧ[1LY +T?SNCUIzۡH?µ;^>i-}49mA-=oHN$s}Xt# V'; E ]?1ߑޝ\lf~kpn*4L%*LD"xTL+#%\γ}glPx+YV-_Bؔ#cֶe}:c0yV^7*YN:&gf ; c Yp7״X_x :](ϙ摣Ixӓ;ɥD=hmpUįIkB =Q8r7sAzfշ'Lo,`L= l+T 8 /s#Sb9zՏwy(Y~fr fQOb78[0Y~_䨷|{V-i)%OowGTfRvH[hu 6;Qpǚ*oh2R%w\ 4ӣV= ^/OaIʪjhy) vOLM<ֻ&GkFEl 0rO@q@%wOƌ->F>0~׋[k'q?( u̷+c6VMCD@/FcF=IFpDan:Ċ$d30Oԑ k睩S!,^sN.¥ٛ鰪|fOGz 0飳', %@T:wfWǗb_Z^F/}]av1Xk9:-9vd | 4HSHn XKZލp {7!d>]YbՌpδƙ8QוP尐e=27W;^_=Kr@uSO~z." &X! GM{3償޽p e[lnK S<2:R tv 2C$>3+Eod΁ѝ{&ͤI<ФÙS9/0.pL G^0ho0օ&{JX SrBlB5ICwÞ9iƤ^",Jodh[8a1ol W Ԙ[zqqCWb Ԝ=2+@&HcsnJUR~ԊAI@wvvա 4n4[yF}n 5P6bj0i24xG|ϚSpAE?^iYﮚ٨Klpkd,69il~(0oϣ™sm0~N,jGzԊ{4 w>ҍ V1K74PgJN^8D> stream xڍT 8}F*de7faF;YC303cf{!WZleoR zϹs~y%mz8'hL&ѡe``@p2HK;D"Ri2I7Й6C I"s"Ph  pD2U0p2`N&4D%xyә|B]]Mi#,Xaޠ/D,ؓG 9-o:1 e/ML:(0to )CoÞ30T`,H1CI8 0O,k HAAP6 ی^OD mcX/C "<Ɩ@!։"̌`D'Q:0ֳ07a L#{aو3 $: ^! bsm^ Dx _oO&A3Me PQ@? zpNĺCXL60dABhS"X: zH_ٙf3J\L!7wpd1}a6Nz-'!PE(*VGaf64#ɀbSYp6C3!2S Knp| go__e c| ĠMStX@7 V o=AhƄ@gCc7|x}ψhCֿ,\.AcJr2wHX2n}ɐ(4R1A8SIH A0n)tf. +UW`u Sp07~P_j7`ߠ*Q<~2 *x:֟Je:s7>6 b!_QKjDv*Wy#Z_Tr_5<#{c0R{5[J|+i1zc*$ЧJGynJ~3/2Md* x.[>\vTvEeu?3OmJk<'HPsM%V»K\i{,u#F«EDEyҞ0[1Z**Z9U:bq6rμݤZk2w>G!*/#Pp}¶|}GhYf!3/{wɫ!"Q>Sv/ 39[cϾ]yM47[>=ܿم} Vm<84&PɊPr-/a_)"$ZFtqυ'uxA KT^ñZ4 lv4o q~X?wl}fOƦJR"z&DPwΩRٶVdsR@LU]tc>h 7JrF? ub>UAX<~%{K׹'M^mvE;.M>xkh衇 y([5O?Vdu5Cs}!=ak|܋ܘSS4f|LiKL&]]v\9Wd4xVf`v}S,&Gk(lMqdw EJbG ONy -'&>(UcN?llwD \([FEV-9^[K  H%ovFi\7uaެꅵokn `)`)3^]8V-*r"q.i )qpr{{];i'YBǘ5/ҢV=<m}ۖ 4E j & 5;}mX_ܳ8jmlP}{g]V¬56:g̍y K"z3ehW9"P\i(wª z 8NwJd ^\cH Y]>%COt?P|#.Br9u էXr@]5=׼u9_awEldwdUY[ְ Aýlg >\R#GUǶU H5"mK #n\x #bq@6`[)֢g)/o깍. /)%L BZV]x&A1cKPy$Ō\m7O7V6u)qegCVzf=m˾MY^SPLҚ)٤dU^~'_-gP5㧍HW.xԕzNCڅG k۽Ц0>靗ɨE{Ӆ7}_̕;OCHUm PÚ3ּN=[M9b' k˺nek~^{=٭NrnSfм+R8. i]i&' xrV TqTziP>%|f z/V:vnz_s2MHhX endstream endobj 100 0 obj << /Length1 2532 /Length2 11387 /Length3 0 /Length 12846 /Filter /FlateDecode >> stream xڍT. KqJ)) @ $+R{)Z t}6=׺we$3μGC"a 5B!.,)mm~;;+;;' 6F B0r]`2i N (8|NvvB@7%@hN`kX[08rH؃@@be`qqqdcswwg;BE`&. ]+ @\ jt`; pX-èz`7?޿!9-,@'b ہjʬ.. ! v@s_́Y V?9[8\YvKdeqqFOݓ@!oV`",]t `GW?&0ڣaggb  =@)9~aq:`E|V g yl0Y!habvN`!;l8?3%bhi˪J0]:II wu 쏞 +(@o&?Oj0;*6 [8/6KH/5_h6.W–zWVd v_ kv{,.6 b+fԡw tΰyKgX@-'/Dc' l-AM0u`Nh&[7I>">#I?"̿&8lr&l `ٕ,#eW?"XGˠ`ZG` E\0Kl[rp-=¬N@ [b(WY@` 7o#߃/-H6l[ ۵GX]`ܬn:3~[~4y 뽍 L˜#c^Xv7Q#<ł6= Gv0gjNX2X'N)72쵁q`rt,8rX13Gy`Aaz=l.6N?V;X ? ]n@3?H w,\`}uYz<@h3P 5A$HYG81{NPdH65Or$Nm_,zdOnk;9\p3*ͮ+R[ҚQL|x}:m[NaHd821??ƓV jɩ/ '#d݃W2LҬu}zKo<3bh@pOp8ڔJҽR‘mt>,Y1驲9U/p_8Mm-TˊQ - 4yɄ9?I XrM\{ I5njhw87krqF4saFLѤB|.ouOn_U"܆stICQ+Z>19۫PJ-] ϙyH킾W%>dhUEw?+,t{9?=왎mf}%>j@5ƒKeEIow'奂MMmIFPMqO0U Br C x6ˬ>Xo\ nx4ogGyv]Ϋ9 qZ1v7Z< fb{zgSh'u/ A3K2~E̒ )&'f iոhǟ`gs,dKYhyCM;ԭ"+QDޞIoU/5 y =dSqŞTxLH _Tcs'oۅN<5V˘@|W3g~Ճ垚 P O=(KZCx:M93"N.cTџ2hc;hW%Ф[0AA~Vfn"IS.7\i8V9Q,_k1<+t1*kא|4@ kHL@=eLGi4ILwWFL>u1P[WX#$piEglU:R%{)`JG7:P8; LmݭA~E9iqP~}usO>ZnWm1x;*_ƊW!+}$ҏ>p Z,U܂$Ug+HkM\(yOik'S%r-˗d#`B*^4ʹpF.Φx,yZF#@5Htq)xӵt`\]↱)2rjl#sv 퉻2nT6pK3m@"G,GCh1d|5✾{8- vb/;Zv5W":rF҇1f&SG0OFS[8<[)ԢX;^70 %nS}#E-YrJ a'U}5 MڣP)<1 MA* gOPt~TaNIg;$O4c7{o/~:#ʇ^}uxq %vSEߺg&3=|"l?F d9sU01#VጫS"{оZ"s%xw<=‹"ZJ׆ ;$_-3k e݂ݥL:N"ّ5>!^RWR=PPtΕˀ }ʫ-(63ɸ.kMJŽ;iS 0 k%ǡބ"a?o L?L1Ñvr|mωOV׻bsV?sރ&bv# ~3CNVRa$@?/~Sf*k$;իG|+.>RuhU඼u}x<$J a69V_9Ш;F6xH&eD#jČ[NZB43-#$?<>PmjNEujw;l'܆C : ^~ڬq+yI8JVOTA.F] t3s|)E*!%7 PK0:o1O^zs X>E Vo"9U>27|'b 9 m]Tb'$(I4 d8EZHyKO~.m_ox14uz \С[. uuRV lp~2$sڕnIDskq ?_|G8a)V{&[}|^½)n|'\QV^k*wj-R}OL?4,q-ON:gq7nݪ¥tZf>)99M7 TV鏣rVSY 7t{x_Y¶W~zzLh)ii֜`2rvB9(4On8;aL- ibPmʝaJ&`A©)r ^Gn@X_q{3n쑦,ނ}ìidLzql:rrؒq]W<"I_ID)MDq$:_F n5x8|H3Fy{xB;2hI8j{ުrtǭ: "ut'sj,J9.mBV\y?F%]>%}rA4{W:K+j"͖uc2;eXR['KΜ2?约?~*sTv쩬r67[$#;1DԹ:*2M"ʥpQ,o_..L wԡe[kILJ)^Y Ʀ{?+hX|:;"C(kesD~ L6ߪ5aNQ;͍`7]Nu Q+f8K]|7A^3 gCV$ӶVyo;42;B2ɰyܜ4 =a^M6XD ՟tvvq9^-l0\c/ԣ?׸^zt-[0r郢Ahc~l0/>:C .TIrttq ]A%\拖Uv}R4r 9ߌeVs#Z%~ZTW\JyK]NJ?ySL.x*KN9Uj Ǔu׍^x&/D'2&ANT6HTFUX#?ܢt}!o-B<%_;O~*oHV&mz۴3v%!Qxul&"who[vowL'{yPѵVݤE|Ea褛B7Z|W '꺶]t|mkUTN3ݷfV7*"}"@˲jnmhՋcϱ3unQhG1"f$ݾg0ڢ^XN@ AO!jXdW#|_ŝ,J[AbO|p|9NJi8yRq:HvЦPlol{AšxV2Q\=@k8d|'H/pKysN8J5Zĵ$G:H`a,4l6f֦Ny\N%rF-21v]Q|FnFgԝRӬж K9gõϻ9c9AZfMʄXxZM,7%D9e&@/K{q&| K ia܅MPEwTx\ DP@u//]pRx-2Y9܆0&kςC?'{G[GY_vpvn3p{:y8"te5_*?~Q w,0+;gDr9)P$5奪sR{`W@C,pMTr|4ZC\\zlV l 4SyԈÑ?4Mb,,TU߸,9MH-3l8mgԪ9buWGdƘ}\-~AVAIuc! x\pi#[YiQnqiźѷ"NzNΚeZrr$kD"/'^hmh0PNThTAx)J8zUB諈$*r:/zeL!@\}n$Vۇ2mM4۩y߁B|Б9H ' | -PNh[U0?3FQ1$-UU$AT4HEپ ?rB֏/sn>68 R߄NxUt'MC!F/Ib/W* ȋ+4G[&J7}`uSnȐ!*?OegS S* zJezrSWNHG;I6O?x;Yi-k/~\C\**EFUU5'$}niW`˹:zYm$SL6x/Gnqk٪ۑZCq6Si|NI)Oh WRj .ZOPtphlI*&yoh8Ǯ{Ds}ͦ[8P a0Q,=N{[.>ܠU .l#ħKbhB͛i}*%KHgM4gϓֻR-u7q_jut0~ =(E -8Swq?0iUhژo[:iy3"uT(p~􌑦섽mз%faҤv:8Rgfqw5?%S1(ѐVo \D5TbEM/|'qr@V r;PZy=3Eb]% 5\ 4 w#%b`3Bo3y7h$z{䤂_ljEjuЂOHp U6JŁ)˕g}} ~maW&Qc"9]Dc6w^ , ]A٣;ʟ~JȸgkI0M]UoBDw H3̱GOoz3>6uD镍pc KԒ뚺K@-R{Ru:2, T Zx~=e%X>ƕC]OS0hC@[1[ӤRo>9=Aga $ lUT 9cY%9B_x-Cr?t۹ h\Nyk(&Ӳ:? 8iVoĻ;Y7+"|ݴ߁bLV@ z˟S%ioj^Ñ.N"?FKH%Qh:$K9m~@izWKp+uzOv~.WXW`Ӏ%Z}_t b+ó~Sj1+LY*J;id?^vpFKfvEUh³kt͊TfU2<zf"i&}_ϖzݶsMo5Ϋ]|r}dӉY\;2ixgܧb&:?$,B1ڭ]gkm4_?K=Gz1/?4{KjZK+PՑɖ,xy/̎ÚɎ{<]+6F{)i6B-p. &򯾳.A྽gGm`'u1_ggpQxqE/T< ~.=Ɵ6RDZn =6pd!TdNz!)3£#fku "6YCPL, )ݮ͙-x{ ϯ*Qf̯v˵ODTq]笇Z|4)Cj͂ _0'ϖ|_7P0XS O_ҸJ'K"!ʗ/',i 6M7> KYAڅA LZf;NKmizMI+3" v0gn̝$Ċ%VLulMgV3PV냻a{Y2:ZR^]N!0ulvm0;fi~7l9)n%V(;\ԗߓ̾_Dnq gYS=/tpdGSEo502! V&cȧF xInSUR¨WU[lpQ ̿&w.3BlA2ʚ (JƧE{b[8 ʻ) L2O(zugwvJe>H˵eq4f (yD)גp q+f7x09EC?Z;ԷC*Cqb)i_ժY˸&Ne:}_҄ ~~^+pb(؅+|C!lw(thuJC ?)".B"ێ,gDYsEE@r1Q7s.yBa]__,~W9-Cp}NDyX>Ofw.IH:V=Lsb,.H\|1JD)ePǪGW[y,Bt_XtdN~Ct͑c*ֵXX@:_N̙,I%aE[GҶK֒u7w4I7NaH7*1^< ӂw(axXxfPGqU3ѶUYeVvή/Fnȹ1PƄmn]}$.(-hϵ9+T=".K|Zlt8u#!q\-PN"=7Qm endstream endobj 109 0 obj << /Producer (pdfTeX-1.40.20) /Author()/Title()/Subject()/Creator(LaTeX with hyperref)/Keywords() /CreationDate (D:20220107101218+01'00') /ModDate (D:20220107101218+01'00') /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.14159265-2.6-1.40.20 (TeX Live 2019/Debian) kpathsea version 6.3.1) >> endobj 2 0 obj << /Type /ObjStm /N 91 /First 727 /Length 3375 /Filter /FlateDecode >> stream x[Ys8~ׯƻlx屝FblMd);__DQ"ٙ}HDhu^02˴a9DʼdB1!qSd*L*A</pLiˤcʁ,cF3k-R2j`:TIDj; 2FB D go:*MGYU9T%9U;(uXyܙ+HE` 'J**D`}h J2 PbOx⹏u5:H{Zele˴뺜ђ^7;Z p<}OU;KҷI[gۤ9oE*J{((7MAɨL[i468 c7g*c)mi f́#8V,M V&46ͪ;7"U𻲉2[}(8~ wGpɖHxypfl o,Ԩ:e~Y\忈{4IB04gj/@.<5$#*\ {,lű'|%ß~("5xawԣ+ W/[ko{0v:T}ةKCfkTL ۜgiQs5š!v4粐 3XZ,@S.ě\,np(U S@D,= R œWY]0g}:kYZ3O1ɑ$Klk+6Js Ė蓖q 5P┆Sr!UvVWa ^!4?#k2aʛfY`[4x4 0+If(VP'ÈU:ԍYlG,Ụ g'ƿv=E\8"gُ۬i|׆Qq 9Fd sCk\j12f2F5Iȼ*SD0iml;:8xyێifkblüm'ĂyT'\4`C6e߯^"3fq\Ta8Eӯ7 1*LAx>.rlgAQaN'q?guj0)c6}l=K_^:ܣX<9X-e(<}(_JrrlxҚͅc|_XnAgEOc(uPd͈q< 銀(LM",\Ug4[*ynDkEvU6hA9 LF~[n}r`]vq4Omimk{y=im"^`q8H ./a{Hx}ôG+iA|G~T'.4gaQ2^vݽ,ƒ{!"tl`b}`Mtd-6%}G?˶ڱdl5eln^vkO(ۋldl=KKjWzv;n//śNW 6%|)[!< oEfpo, JzbBß{ͯ C녂WjLZ갸 ki}-j:NfWkٱ>.\LTqٚ~%!2f|:>}Il]f\&D.3*ng.$`B <uWڡO*nrܡuC1z>Z}"?_)Y[nwS~螺V mA[MUnS %/ #jl7glO }PfnA}|4ȍ;q^[F鳅:΋#^|*XT endstream endobj 110 0 obj << /Type /XRef /Index [0 111] /Size 111 /W [1 3 1] /Root 108 0 R /Info 109 0 R /ID [<77C26B28F753ECCEEEBD8A31D0533191> <77C26B28F753ECCEEEBD8A31D0533191>] /Length 267 /Filter /FlateDecode >> stream xҹ2`KĒ{k[+5:ΘQ4Ehmiy̙3&}>yN!%GP eC!TBTCj"2񗆡 6a6` aad_i-؃Q.YhWpg}0ȣb!Y4aYk ! 0 S0 )H BFO9Y!xd^RkINy-Kw^+*)9\%\I?,J" endstream endobj startxref 128060 %%EOF geepack/inst/doc/geepack-manual.R0000644000176200001440000000630714166001762016401 0ustar liggesusers### R code from vignette source 'geepack-manual.Rnw' ################################################### ### code chunk number 1: geepack-manual.Rnw:16-19 ################################################### require( geepack ) prettyVersion <- packageDescription("geepack")$Version prettyDate <- format(Sys.Date()) ################################################### ### code chunk number 2: geepack-manual.Rnw:73-75 ################################################### library(geepack) citation("geepack") ################################################### ### code chunk number 3: geepack-manual.Rnw:92-100 ################################################### library(geepack) timeorder <- rep(1:5, 6) tvar <- timeorder + rnorm(length(timeorder)) idvar <- rep(1:6, each=5) uuu <- rep(rnorm(6), each=5) yvar <- 1 + 2*tvar + uuu + rnorm(length(tvar)) simdat <- data.frame(idvar, timeorder, tvar, yvar) head(simdat,12) ################################################### ### code chunk number 4: geepack-manual.Rnw:109-111 ################################################### mod1 <- geeglm(yvar~tvar, id=idvar, data=simdat, corstr="ar1") mod1 ################################################### ### code chunk number 5: geepack-manual.Rnw:127-133 ################################################### set.seed(123) ## library(doBy) simdatPerm <- simdat[sample(nrow(simdat)),] ## simdatPerm <- orderBy(~idvar, simdatPerm) simdatPerm <- simdatPerm[order(simdatPerm$idvar),] head(simdatPerm) ################################################### ### code chunk number 6: geepack-manual.Rnw:143-145 ################################################### mod2 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="ar1") mod2 ################################################### ### code chunk number 7: geepack-manual.Rnw:152-155 ################################################### ## simdatPerm2 <- orderBy(~timeorder, data=simdat) simdatPerm2 <- simdat[order(simdat$timeorder),] geeglm(yvar~tvar, id=idvar, data=simdatPerm2, corstr="ar1") ################################################### ### code chunk number 8: geepack-manual.Rnw:162-166 ################################################### wav <- simdatPerm$timeorder wav mod3 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="ar1", waves=wav) mod3 ################################################### ### code chunk number 9: geepack-manual.Rnw:175-181 ################################################### cor.fixed <- matrix(c(1 , 0.5 , 0.25, 0.125, 0.125, 0.5 , 1 , 0.25, 0.125, 0.125, 0.25 , 0.25 , 1 , 0.5 , 0.125, 0.125, 0.125, 0.5 , 1 , 0.125, 0.125, 0.125, 0.125, 0.125, 1 ), 5, 5) cor.fixed ################################################### ### code chunk number 10: geepack-manual.Rnw:189-191 ################################################### zcor <- fixed2Zcor(cor.fixed, id=simdatPerm$idvar, waves=simdatPerm$timeorder) zcor ################################################### ### code chunk number 11: geepack-manual.Rnw:200-202 ################################################### mod4 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="fixed", zcor=zcor) mod4 geepack/inst/doc/geepack-manual.Rnw0000755000176200001440000001165014165262714016753 0ustar liggesusers% \VignetteIndexEntry{Users guide to geepack} % \VignetteKeyword{Generalized Estimating Equation} % \VignetteKeyword{Working correlation matrix} \documentclass{article} \usepackage{boxedminipage,color,a4,shortvrb,hyperref} %\usepackage[latin1]{inputenc} \usepackage[T1]{fontenc} \usepackage[utf8]{inputenc} \MakeShortVerb| \def\pkg#1{{\bf #1}} <>= require( geepack ) prettyVersion <- packageDescription("geepack")$Version prettyDate <- format(Sys.Date()) @ \SweaveOpts{keep.source=T,prefix.string=figures/LSmeans} \title{On the usage of the \texttt{geepack} } \author{S\o ren H\o jsgaard and Ulrich Halekoh} \date{\pkg{geepack} version \Sexpr{prettyVersion} as of \Sexpr{prettyDate}} \begin{document} \parindent0pt\parskip4pt %% Efter preamble \definecolor{myGray}{rgb}{0.95,0.95,0.95} \makeatletter \renewenvironment{Schunk}{ \begin{lrbox}{\@tempboxa} \begin{boxedminipage} {\columnwidth}\scriptsize} {\end{boxedminipage} \end{lrbox}% \colorbox{myGray}{\usebox{\@tempboxa}} } \makeatother \maketitle \tableofcontents \section{Introduction} \label{sec:introduction} This note contains a few extra examples. We illustrate the usage of a the |waves| argument and the |zcor| argument together with a fixed working correlation matrix for the |geeglm()| function. \label{sec:intro} \section{Citing \texttt{geepack}} The primary reference for the |geepack| package is \begin{quote} Halekoh, U., H\o jsgaard, S., Yan, J. (2006) {\em The R Package geepack for Generalized Estimating Equations (2006)} Journal of Statistical Software \url{https://www.jstatsoft.org/article/view/v015i02} \end{quote} @ <<>>= library(geepack) citation("geepack") @ %def If you use |geepack| in your own work, please do cite the above reference. \section{Simulating a dataset} \label{sec:simulating} To illustrate the usage of the |waves| argument and the |zcor| argument together with a fixed working correlation matrix for the |geeglm()| we simulate some data suitable for a regression model. @ <<>>= library(geepack) timeorder <- rep(1:5, 6) tvar <- timeorder + rnorm(length(timeorder)) idvar <- rep(1:6, each=5) uuu <- rep(rnorm(6), each=5) yvar <- 1 + 2*tvar + uuu + rnorm(length(tvar)) simdat <- data.frame(idvar, timeorder, tvar, yvar) head(simdat,12) @ %def Notice that clusters of data appear together in |simdat| and that observations are ordered (according to |timeorder|) within clusters. We can fit a model with an AR(1) error structure as @ <<>>= mod1 <- geeglm(yvar~tvar, id=idvar, data=simdat, corstr="ar1") mod1 @ %def This works because observations are ordered according to time within each subject in the dataset. \section{Using the \texttt{waves} argument} \label{sec:xxx} If observatios were not ordered according to cluster and time within cluster we would get the wrong result: @ <<>>= set.seed(123) ## library(doBy) simdatPerm <- simdat[sample(nrow(simdat)),] ## simdatPerm <- orderBy(~idvar, simdatPerm) simdatPerm <- simdatPerm[order(simdatPerm$idvar),] head(simdatPerm) @ %def Notice that in |simdatPerm| data is ordered according to subject but the time ordering within subject is random. Fitting the model as before gives @ <<>>= mod2 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="ar1") mod2 @ %def Likewise if clusters do not appear contigously in data we also get the wrong result (the clusters are not recognized): @ <<>>= ## simdatPerm2 <- orderBy(~timeorder, data=simdat) simdatPerm2 <- simdat[order(simdat$timeorder),] geeglm(yvar~tvar, id=idvar, data=simdatPerm2, corstr="ar1") @ %def To obtain the right result we must give the |waves| argument: @ <<>>= wav <- simdatPerm$timeorder wav mod3 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="ar1", waves=wav) mod3 @ %def \section{Using a fixed correlation matrix and the \texttt{zcor} argument} \label{sec:xxx} Suppose we want to use a fixed working correlation matrix: @ <<>>= cor.fixed <- matrix(c(1 , 0.5 , 0.25, 0.125, 0.125, 0.5 , 1 , 0.25, 0.125, 0.125, 0.25 , 0.25 , 1 , 0.5 , 0.125, 0.125, 0.125, 0.5 , 1 , 0.125, 0.125, 0.125, 0.125, 0.125, 1 ), 5, 5) cor.fixed @ %def Such a working correlation matrix has to be passed to |geeglm()| as a vector in the |zcor| argument. This vector can be created using the |fixed2Zcor()| function: @ <<>>= zcor <- fixed2Zcor(cor.fixed, id=simdatPerm$idvar, waves=simdatPerm$timeorder) zcor @ %def Notice that |zcor| contains correlations between measurements within the same cluster. Hence if a cluster contains only one observation, then there will be generated no entry in |zcor| for that cluster. Now we can fit the model with: @ <<>>= mod4 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="fixed", zcor=zcor) mod4 @ %def \section{When do GEE's work best?} \label{sec:when-do-gees} GEEs work best when you have relatively many relativly small clusters in your data. \end{document} geepack/inst/include/0000755000176200001440000000000014165262714014261 5ustar liggesusersgeepack/inst/include/param.h0000755000176200001440000000656014165262714015544 0ustar liggesusers#ifndef PARAM_H #define PARAM_H #include "tntsupp.h" #include "geese.h" class Control{ protected: int _trace; int _ajs; int _j1s; int _fij; int _maxiter; double _tol; public: Control(int trace, int ajs, int j1s, int fij, int maxiter, double tol); Control(int *con, double tol); Control(const Control &C); int trace() const {return _trace;} int ajs() const {return _ajs;} int j1s() const {return _j1s;} int fij() const {return _fij;} int maxiter() const {return _maxiter;} double tol() const {return _tol;} void set_maxiter(int mit) {_maxiter = mit;} }; class GeeParam{ protected: DVector _beta; DVector _alpha; DVector _gamma; DMatrix _vbeta; DMatrix _vbeta_naiv; DMatrix _vbeta_ajs; DMatrix _vbeta_j1s; DMatrix _vbeta_fij; DMatrix _valpha; DMatrix _valpha_stab; DMatrix _valpha_naiv; DMatrix _valpha_ajs; DMatrix _valpha_j1s; DMatrix _valpha_fij; DMatrix _vgamma; DMatrix _vgamma_ajs; DMatrix _vgamma_j1s; DMatrix _vgamma_fij; //int _ScaleFix; int _err; public: GeeParam(DVector Beta, DVector Alpha, DVector Gamma); GeeParam(DVector Beta, DVector Alpha, DVector Gamma, DMatrix VBeta, DMatrix VBeta_naiv, DMatrix VBeta_ajs, DMatrix VBeta_j1s, DMatrix VBeta_fij, DMatrix VAlpha, DMatrix VAlpha_stab, DMatrix VAlpha_naiv, DMatrix VAlpha_ajs, DMatrix VAlpha_j1s, DMatrix VAlpha_fij, DMatrix VGamma, DMatrix VGamma_ajs, DMatrix VGamma_j1s, DMatrix VGamma_fij); ~GeeParam() {} void set_beta(const DVector &v) {_beta = v;} void set_alpha(const DVector &v) {_alpha = v;} void set_vbeta(const DMatrix &m) {_vbeta = m;} void set_vbeta_naiv(const DMatrix &m) {_vbeta_naiv = m;} void set_vbeta_ajs(const DMatrix &m) {_vbeta_ajs = m;} void set_vbeta_j1s(const DMatrix &m) {_vbeta_j1s = m;} void set_vbeta_fij(const DMatrix &m) {_vbeta_fij = m;} void set_valpha(const DMatrix &m) {_valpha = m;} void set_valpha_stab(const DMatrix &m) {_valpha_stab = m;} void set_valpha_naiv(const DMatrix &m) {_valpha_naiv = m;} void set_valpha_ajs(const DMatrix &m) {_valpha_ajs = m;} void set_valpha_j1s(const DMatrix &m) {_valpha_j1s = m;} void set_valpha_fij(const DMatrix &m) {_valpha_fij = m;} void set_gamma(const DVector &v) {_gamma = v;} void set_vgamma(const DMatrix &m) {_vgamma = m;} void set_vgamma_ajs(const DMatrix &m) {_vgamma_ajs = m;} void set_vgamma_j1s(const DMatrix &m) {_vgamma_j1s = m;} void set_vgamma_fij(const DMatrix &m) {_vgamma_fij = m;} void set_err(int e) {_err = e;} DVector beta() {return _beta;} DVector alpha() {return _alpha;} DVector gamma() {return _gamma;} DMatrix vbeta() {return _vbeta;} DMatrix valpha() {return _valpha;} DMatrix vbeta_naiv() {return _vbeta_naiv;} DMatrix vbeta_ajs() {return _vbeta_ajs;} DMatrix vbeta_j1s() {return _vbeta_j1s;} DMatrix vbeta_fij() {return _vbeta_fij;} DMatrix valpha_stab() {return _valpha_stab;} DMatrix valpha_naiv() {return _valpha_naiv;} DMatrix valpha_ajs() {return _valpha_ajs;} DMatrix valpha_j1s() {return _valpha_j1s;} DMatrix valpha_fij() {return _valpha_fij;} DMatrix vgamma() {return _vgamma;} DMatrix vgamma_ajs() {return _vgamma_ajs;} DMatrix vgamma_j1s() {return _vgamma_j1s;} DMatrix vgamma_fij() {return _vgamma_fij;} //int ScaleFix() {return _ScaleFix;} int p() {return _beta.dim();} int r() {return _gamma.dim();} int q() {return _alpha.dim();} int err() {return _err;} }; #endif //PARAM_H geepack/inst/include/geesubs.h0000755000176200001440000001775714165262714016113 0ustar liggesusers#ifndef GEESUBS_H #define GEESUBS_H #include "tntsupp.h" #include "geese.h" #include "famstr.h" #include "param.h" //#include "lgtdl.h" class Grad{ protected: DVector U1_, U2_, U3_; public: Grad(int p, int r, int q) { DVector U1(p), U2(r), U3(q); U1_ = U1; U2_ = U2; U3_ = U3; } Grad(GeeParam &par) { int p = par.p(), q = par.q(), r = par.r(); DVector U1(p), U2(r), U3(q); U1_ = U1; U2_ = U2; U3_ = U3; } Grad() { Grad(0, 0, 0); } ~Grad() {} Grad & operator=(const Grad &G); void set_U1(const DVector &u) {U1_ = u;} void set_U2(const DVector &u) {U2_ = u;} void set_U3(const DVector &u) {U3_ = u;} DVector U1() const {return U1_;} DVector U2() const {return U2_;} DVector U3() const {return U3_;} friend ostream& operator<<(ostream&, const Grad&); }; class Hess{ protected: DMatrix A_, B_, C_, D_, E_, F_; public: Hess(DMatrix &A, DMatrix &B, DMatrix &C, DMatrix &D, DMatrix &E, DMatrix &F) : A_(A), B_(B), C_(C), D_(D), E_(E), F_(F) {} Hess(int p, int r, int q) { DMatrix A(p,p), B(r,p), C(r,r), D(q,p), E(q,r), F(q,q); A_ = A; B_ = B; C_ = C; D_ = D; E_ = E; F_ = F; } Hess(GeeParam &par) { int p = par.p(), q = par.q(), r = par.r(); DMatrix A(p,p), B(r,p), C(r,r), D(q,p), E(q,r), F(q,q); A_ = A; B_ = B; C_ = C; D_ = D; E_ = E; F_ = F; } Hess(const Hess &H): A_(H.A()), B_(H.B()), C_(H.C()), D_(H.D()), E_(H.E()), F_(H.F()) { //A_ = H.A(); B_ = H.B(); C_ = H.C(); //D_ = H.D(); E_ = H.E(); F_ = H.F(); } Hess() { Hess(0, 0, 0); } ~Hess() {} DMatrix A() const {return A_;} DMatrix B() const {return B_;} DMatrix C() const {return C_;} DMatrix D() const {return D_;} DMatrix E() const {return E_;} DMatrix F() const {return F_;} void set_A(const DMatrix &a) {A_ = a;} void set_B(const DMatrix &b) {B_ = b;} void set_C(const DMatrix &c) {C_ = c;} void set_D(const DMatrix &d) {D_ = d;} void set_E(const DMatrix &e) {E_ = e;} void set_F(const DMatrix &f) {F_ = f;} void inc_A(const DMatrix &a) {A_ = A_ + a;} void inc_B(const DMatrix &b) {B_ = B_ + b;} void inc_C(const DMatrix &c) {C_ = C_ + c;} void inc_D(const DMatrix &d) {D_ = D_ + d;} void inc_E(const DMatrix &e) {E_ = E_ + e;} void inc_F(const DMatrix &f) {F_ = F_ + f;} void inc(Hess &H) { inc_A(H.A()); inc_B(H.B()); inc_C(H.C()); inc_D(H.D()); inc_E(H.E()); inc_F(H.F()); } void dec_A(const DMatrix &a) {A_ = A_ - a;} void dec_B(const DMatrix &b) {B_ = B_ - b;} void dec_C(const DMatrix &c) {C_ = C_ - c;} void dec_D(const DMatrix &d) {D_ = D_ - d;} void dec_E(const DMatrix &e) {E_ = E_ - e;} void dec_F(const DMatrix &f) {F_ = F_ - f;} void dec(Hess &H) { dec_A(H.A()); dec_B(H.B()); dec_C(H.C()); dec_D(H.D()); dec_E(H.E()); dec_F(H.F()); } Hess& operator=(const Hess &H) { A_ = H.A(); B_ = H.B(); C_ = H.C(); D_ = H.D(); E_ = H.E(); F_ = H.F(); return *this; } friend ostream& operator<<(ostream&, const Hess&); }; Hess operator-(Hess &H1, Hess &H2); Hess inv(Hess &H, IVector &level); Hess operator*(const double &x, const Hess &H); ostream& operator<<(ostream& s, const Hess &H); DVector genzi(const DVector &PR); DVector utri(const DMatrix &R); DMatrix getZ_Beta(DMatrix &D, DVector &PR, DVector &V, DVector &V_Mu, DVector &z); DMatrix getZ_Gamma(DMatrix &D, DVector &PR, DVector &Phi, DVector &z); DMatrix getS_Beta(DMatrix &D, DVector &PR, DVector &V, DVector &V_Mu); void HiandGi(DVector &PRi, DVector &Phii, DMatrix &Di, DMatrix &R, DVector &Vi, DVector &V_Mui, DMatrix &D2i, DMatrix &E, DVector &Wi, IVector &level, //output Hess &H, Grad &G); void PRandD(DVector &Y, DMatrix &X, DVector &Offset, Index1D &I, IVector &LinkWave, GeeParam &par, GeeStr &geestr, DVector &PRi, DMatrix &Di); void gee_prep(DVector &Y, DMatrix &X, DVector &Offset, Index1D &I, IVector &LinkWave, GeeParam &par, GeeStr &geestr, DVector &PRi, DMatrix &Di, DVector &Vi, DVector &V_Mui); DMatrix getR(DMatrix &Zmat, Index1D &I, Index1D &J, DVector &CorP, GeeParam &par, GeeStr &geestr, Corr &cor); int RandE(DMatrix &Zmat, Index1D &I, Index1D &J, DVector &CorP, GeeParam &par, GeeStr &geestr, Corr &cor, DMatrix &R, DMatrix &E); void gm_prep(DVector &PR, Index1D &I, IVector &LinkWave, DVector &Doffset, DMatrix &Zsca, GeeParam &par, GeeStr &geestr, DVector &Phii, DVector &Si, DMatrix &D2i); void PhiandD2(Index1D &I, IVector &LinkWave, DVector &Doffset, DMatrix &Zsca, GeeParam &par, GeeStr &geestr, DVector &Phii, DMatrix &D2i); DVector getPR(DVector &Y, DMatrix &X, DVector &Offset, IVector &LinkWave, GeeParam &par, GeeStr &geestr); DVector getPhi(DVector &Doffset, DMatrix &Zsca, IVector &LinkWave, GeeParam &par, GeeStr &geestr); void HnandGis(DVector &Ycur, DMatrix &X, DVector &Offset, DVector &Doffset, DVector &W, IVector &LinkWave, IVector &Clusz, IVector &ZcorSize, DMatrix &Zsca, DMatrix &Zcor, DVector &CorP, GeeParam &par, GeeStr &geestr, Corr &cor, IVector &Scur, IVector &level, //output Hess &H, Vector &Gis); void HisandGis(DVector &Ycur, DMatrix &X, DVector &Offset, DVector &Doffset, DVector &W, IVector &LinkWave, IVector &Clusz, IVector &ZcorSize, DMatrix &Zsca, DMatrix &Zcor, DVector &CorP, GeeParam &par, GeeStr &geestr, Corr &cor, IVector &Scur, IVector &level, //output Vector &His, Vector &Gis); /* DVector interpprev(double t, Vector &VV, DVector &tis); double interpprev(double t, DVector &v, DVector &tis); DVector getY(double t, DVector &Yall); IVector getS(double t, DVector &S); void AandCis(Vector &Yall, DMatrix &X, Vector &Offset, Vector &Doffset, Vector &Weight, IVector &LinkWave, IVector &Clusz, IVector &ZcorSize, DMatrix &Zsca, DMatrix &Zcor, DVector &CorP, Vector &Beta, Vector &Gamma, Vector &Alpha, DVector &W, DVector &S, DVector &Tis, DVector &Tlim, int l, DVector &Ita, GeeStr &geestr, Corr &cor, int ndivs, int fgconf, //output: DMatrix &A, Vector &Cis); */ /* This fix was suggested by Jeffrey Horner and Cole Beck . Cole Beck's email on Jan. 4, 2012 explains why: I believe the function definition for the template function "Valid" (see geesubs.cc) should actually be in the header file. Taken from http://www.cplusplus.com/doc/tutorial/templates/: Because templates are compiled when required, this forces a restriction for multi-file projects: the implementation (definition) of a template class or function must be in the same file as its declaration. That means that we cannot separate the interface in a separate header file, and that we must include both interface and implementation in any file that uses the templates. */ //get the valid components in X by valid indicator VI template Vector Valid(Vector &X, IVector &VI) { int l = sum(VI), k = 1; Vector ans(l); for (int i = 1; i <= VI.dim(); i++) { if (VI(i) == 1) ans(k++) = X(i); } return ans; } template Fortran_Matrix Valid(Fortran_Matrix &X, IVector &VI) { int l = sum(VI), k = 1, nc = X.num_cols(); Fortran_Matrix ans(l, nc); for (int i = 1; i <= VI.dim(); i++) { if (VI(i) == 1) { for (int j = 1; j <= nc; j++) ans(k, j) = X(i, j); k++; } } return ans; } IVector genVI(IVector &Si, int c = 1); IVector genCrossVI(IVector &Si, int c = 1); void getDatI(DVector &Y, DVector &Offset, DVector &Doffset, DVector &W, DVector &CorP, DMatrix &X, DMatrix &Zsca, DMatrix &Zcor, IVector &LinkWave, //extract indicator Index1D &I, Index1D &J, IVector Scuri, Corr &cor, //output DVector &VYi, DVector &VOffseti, DVector &VDoffseti, DVector &VWi, DVector &VCorPi, DMatrix &VXi, DMatrix &VZscai, DMatrix &VZcori, IVector &VLinkWavei); #endif //GEESUBS_H geepack/inst/include/gee2.h0000755000176200001440000000511014165262714015254 0ustar liggesusers#ifndef GEE2_H #define GEE2_H #include "tntsupp.h" #include "geese.h" // extern "C"{ #include #include #include // } #include "famstr.h" #include "param.h" #include "inter.h" #include "utils.h" #include "geesubs.h" IVector comp_lev(GeeStr &geestr, Corr &cor); void gee_var(DVector &Y, DMatrix &X, DVector &Offset, DVector &Doffset, DVector &W, IVector &LinkWave, DMatrix &Zsca, DMatrix &Zcor, DVector &CorP, IVector &Clusz, IVector &ZcorSize, GeeStr &geestr, Corr &cor, GeeParam &par, Control &con); double update_beta(DVector &Y, DMatrix &X, DVector &Offset, DVector &W, IVector &LinkWave, DVector &CorP, DMatrix &Zcor, IVector &Clusz, IVector &ZcorSize, IVector &Jack, GeeParam &par, GeeStr &geestr, Corr &cor); double update_gamma(DVector &PR, DVector &W, IVector &LinkWave, IVector &Clusz, IVector &Jack, DVector &Doffset, DMatrix &Zsca, GeeParam &par, GeeStr &geestr); double update_alpha(DVector &PR, DVector &Phi, DVector &CorP, DVector &W, IVector &Clusz, IVector &ZcorSize, IVector &Jack, DMatrix &Zcor, GeeParam &par, GeeStr &geestr, Corr &cor); void gee_est(DVector &Y, DMatrix &X, DVector &Offset, DVector &Doffset, DVector &W, IVector &LinkWave, DMatrix &Zsca, DMatrix &Zcor, DVector &CorP, IVector &Clusz, IVector &ZcorSize, GeeStr &geestr, Corr &cor, GeeParam &par, IVector &Jack, Control &con); void getJackVar(Vector &beta_i, Vector &alpha_i, Vector &gamma_i, GeeParam &par, int jack); void gee_jack(DVector &Y, DMatrix &Xmat, DVector &Offset, DVector &Doffset, DVector &W, IVector &LinkWave, DMatrix &Zsca, DMatrix &Zcor, DVector &CorP, IVector &Clusz, IVector &ZcorSize, GeeStr &geestr, Corr &cor, GeeParam &par, Control &con); void jack_ajs(DVector &Y, DMatrix &X, DVector &Offset, DVector &Doffset, DVector &W, IVector &LinkWave, DMatrix &Zsca, DMatrix &Zcor, DVector &CorP, IVector &Clusz, IVector &ZcorSize, GeeStr &geestr, Corr &cor, GeeParam &par, Control &con); void gee_top(DVector &Y, DMatrix &Xmat, DVector &Offset, DVector &Doffset, DVector &W, IVector &LinkWave, DMatrix &Zsca, DMatrix &Zcor, DVector &CorP, IVector &Clusz, GeeStr &geestr, Corr &cor, GeeParam &par, Control &con); extern "C" { SEXP gee_rap(SEXP y, SEXP x, SEXP offset, SEXP doffset, SEXP w, SEXP linkwave, SEXP zsca, SEXP zcor, SEXP corp, SEXP clusz, SEXP geestr, SEXP cor, SEXP par, SEXP con); } #endif //GEE2_H geepack/inst/include/utils.h0000755000176200001440000000254114165262714015577 0ustar liggesusers#ifndef UTILS_H #define UTILS_H #include "tntsupp.h" #include "geese.h" void VecPrint(const DVector &v); Fortran_Matrix ident (int n); Fortran_Matrix MatRowCol(const Fortran_Matrix &mat, const Vector &r, const Vector &c); Fortran_Matrix rho2mat(const Vector &rho); //solve(a, b = ident(n)) DMatrix solve(const DMatrix &a, const DMatrix &b); DVector solve(const DMatrix &A, const DVector &b); DMatrix solve(const DMatrix &a); DMatrix AtBiC(const DMatrix &A, const DMatrix &B, const DMatrix &C); DVector AtBiC(const DMatrix &A, const DMatrix &B, const DVector &C); DMatrix apply_elwise(const DMatrix &x, double f(double)); DVector apply_elwise(const DVector &x, double f(double)); DVector sqrt(const DVector &x); double square(double x); DVector square(const DVector &x); double reciproot(double x); DVector reciproot(const DVector &x); double recip(double x); DVector recip(const DVector &x); int cluscount(DVector &ID); Vector clussize(DVector &ID); DVector SMult(const DVector &v1, const DVector &v2); DMatrix SMult(const DVector &v, const DMatrix &m); DMatrix operator*(const DVector &v, const DMatrix &m); DMatrix diag(const DVector &v); DVector diag(const DMatrix &m); DMatrix inv(const DMatrix &x); DMatrix fabs(const DMatrix &m); DVector fabs(const DVector &v); #endif //UTILS_H geepack/inst/include/tnt/0000755000176200001440000000000014165262714015066 5ustar liggesusersgeepack/inst/include/tnt/cmat.h0000755000176200001440000002607514165262714016200 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ // C compatible matrix: row-oriented, 0-based [i][j] and 1-based (i,j) indexing // #ifndef CMAT_H #define CMAT_H #include "tnt/subscript.h" #include "tnt/vec.h" #include #include #include #include #ifdef TNT_USE_REGIONS #include "tnt/region2d.h" #endif namespace TNT { template class Matrix { public: typedef Subscript size_type; typedef T value_type; typedef T element_type; typedef T* pointer; typedef T* iterator; typedef T& reference; typedef const T* const_iterator; typedef const T& const_reference; Subscript lbound() const { return 1;} protected: Subscript m_; Subscript n_; Subscript mn_; // total size T* v_; T** row_; T* vm1_ ; // these point to the same data, but are 1-based T** rowm1_; // internal helper function to create the array // of row pointers void initialize(Subscript M, Subscript N) { mn_ = M*N; m_ = M; n_ = N; v_ = new T[mn_]; row_ = new T*[M]; rowm1_ = new T*[M]; assert(v_ != NULL); assert(row_ != NULL); assert(rowm1_ != NULL); T* p = v_; vm1_ = v_ - 1; for (Subscript i=0; i &A) { initialize(A.m_, A.n_); copy(A.v_); } Matrix(Subscript M, Subscript N, const T& value = T()) { initialize(M,N); set(value); } Matrix(Subscript M, Subscript N, const T* v) { initialize(M,N); copy(v); } Matrix(Subscript M, Subscript N, const char *s) { initialize(M,N); std::istrstream ins(s); Subscript i, j; for (i=0; i> row_[i][j]; } // destructor // ~Matrix() { destroy(); } // reallocating // Matrix& newsize(Subscript M, Subscript N) { if (num_rows() == M && num_cols() == N) return *this; destroy(); initialize(M,N); return *this; } // assignments // Matrix& operator=(const Matrix &A) { if (v_ == A.v_) return *this; if (m_ == A.m_ && n_ == A.n_) // no need to re-alloc copy(A.v_); else { destroy(); initialize(A.m_, A.n_); copy(A.v_); } return *this; } Matrix& operator=(const T& scalar) { set(scalar); return *this; } Subscript dim(Subscript d) const { #ifdef TNT_BOUNDS_CHECK assert( d >= 1); assert( d <= 2); #endif return (d==1) ? m_ : ((d==2) ? n_ : 0); } Subscript num_rows() const { return m_; } Subscript num_cols() const { return n_; } inline T* operator[](Subscript i) { #ifdef TNT_BOUNDS_CHECK assert(0<=i); assert(i < m_) ; #endif return row_[i]; } inline const T* operator[](Subscript i) const { #ifdef TNT_BOUNDS_CHECK assert(0<=i); assert(i < m_) ; #endif return row_[i]; } inline reference operator()(Subscript i) { #ifdef TNT_BOUNDS_CHECK assert(1<=i); assert(i <= mn_) ; #endif return vm1_[i]; } inline const_reference operator()(Subscript i) const { #ifdef TNT_BOUNDS_CHECK assert(1<=i); assert(i <= mn_) ; #endif return vm1_[i]; } inline reference operator()(Subscript i, Subscript j) { #ifdef TNT_BOUNDS_CHECK assert(1<=i); assert(i <= m_) ; assert(1<=j); assert(j <= n_); #endif return rowm1_[i][j]; } inline const_reference operator() (Subscript i, Subscript j) const { #ifdef TNT_BOUNDS_CHECK assert(1<=i); assert(i <= m_) ; assert(1<=j); assert(j <= n_); #endif return rowm1_[i][j]; } #ifdef TNT_USE_REGIONS typedef Region2D > Region; Region operator()(const Index1D &I, const Index1D &J) { return Region(*this, I,J); } typedef const_Region2D< Matrix > const_Region; const_Region operator()(const Index1D &I, const Index1D &J) const { return const_Region(*this, I,J); } #endif }; /* *************************** I/O ********************************/ template std::ostream& operator<<(std::ostream &s, const Matrix &A) { Subscript M=A.num_rows(); Subscript N=A.num_cols(); s << M << " " << N << "\n"; for (Subscript i=0; i std::istream& operator>>(std::istream &s, Matrix &A) { Subscript M, N; s >> M >> N; if ( !(M == A.num_rows() && N == A.num_cols() )) { A.newsize(M,N); } for (Subscript i=0; i> A[i][j]; } return s; } // *******************[ basic matrix algorithms ]*************************** template Matrix operator+(const Matrix &A, const Matrix &B) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(M==B.num_rows()); assert(N==B.num_cols()); Matrix tmp(M,N); Subscript i,j; for (i=0; i Matrix operator-(const Matrix &A, const Matrix &B) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(M==B.num_rows()); assert(N==B.num_cols()); Matrix tmp(M,N); Subscript i,j; for (i=0; i Matrix mult_element(const Matrix &A, const Matrix &B) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(M==B.num_rows()); assert(N==B.num_cols()); Matrix tmp(M,N); Subscript i,j; for (i=0; i Matrix transpose(const Matrix &A) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); Matrix S(N,M); Subscript i, j; for (i=0; i inline Matrix matmult(const Matrix &A, const Matrix &B) { #ifdef TNT_BOUNDS_CHECK assert(A.num_cols() == B.num_rows()); #endif Subscript M = A.num_rows(); Subscript N = A.num_cols(); Subscript K = B.num_cols(); Matrix tmp(M,K); T sum; for (Subscript i=0; i inline Matrix operator*(const Matrix &A, const Matrix &B) { return matmult(A,B); } template inline int matmult(Matrix& C, const Matrix &A, const Matrix &B) { assert(A.num_cols() == B.num_rows()); Subscript M = A.num_rows(); Subscript N = A.num_cols(); Subscript K = B.num_cols(); C.newsize(M,K); T sum; const T* row_i; const T* col_k; for (Subscript i=0; i Vector matmult(const Matrix &A, const Vector &x) { #ifdef TNT_BOUNDS_CHECK assert(A.num_cols() == x.dim()); #endif Subscript M = A.num_rows(); Subscript N = A.num_cols(); Vector tmp(M); T sum; for (Subscript i=0; i inline Vector operator*(const Matrix &A, const Vector &x) { return matmult(A,x); } } // namespace TNT #endif // CMAT_H geepack/inst/include/tnt/region1d.h0000755000176200001440000002217514165262714016761 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ #ifndef REGION1D_H #define REGION1D_H #include "tnt/subscript.h" #include "tnt/index.h" #include #include namespace TNT { template class const_Region1D; template class Region1D { protected: Array1D & A_; Subscript offset_; // 0-based Subscript dim_; typedef typename Array1D::element_type T; public: const Array1D & array() const { return A_; } Subscript offset() const { return offset_;} Subscript dim() const { return dim_; } Subscript offset(Subscript i) const { #ifdef TNT_BOUNDS_CHECK assert(i==TNT_BASE_OFFSET); #endif return offset_; } Subscript dim(Subscript i) const { #ifdef TNT_BOUNDS_CHECK assert(i== TNT_BASE_OFFSET); #endif return offset_; } Region1D(Array1D &A, Subscript i1, Subscript i2) : A_(A) { #ifdef TNT_BOUNDS_CHECK assert(TNT_BASE_OFFSET <= i1 ); assert(i2 <= A.dim() + (TNT_BASE_OFFSET-1)); assert(i1 <= i2); #endif offset_ = i1 - TNT_BASE_OFFSET; dim_ = i2-i1 + 1; } Region1D(Array1D &A, const Index1D &I) : A_(A) { #ifdef TNT_BOUNDS_CHECK assert(TNT_BASE_OFFSET <=I.lbound()); assert(I.ubound() <= A.dim() + (TNT_BASE_OFFSET-1)); assert(I.lbound() <= I.ubound()); #endif offset_ = I.lbound() - TNT_BASE_OFFSET; dim_ = I.ubound() - I.lbound() + 1; } Region1D(Region1D &A, Subscript i1, Subscript i2) : A_(A.A_) { #ifdef TNT_BOUNDS_CHECK assert(TNT_BASE_OFFSET <= i1 ); assert(i2 <= A.dim() + (TNT_BASE_OFFSET - 1)); assert(i1 <= i2); #endif // (old-offset) (new-offset) // offset_ = (i1 - TNT_BASE_OFFSET) + A.offset_; dim_ = i2-i1 + 1; } Region1D operator()(Subscript i1, Subscript i2) { #ifdef TNT_BOUNDS_CHECK assert(TNT_BASE_OFFSET <= i1); assert(i2 <= dim() + (TNT_BASE_OFFSET -1)); assert(i1 <= i2); #endif // offset_ is 0-based, so no need for // ( - TNT_BASE_OFFSET) // return Region1D(A_, i1+offset_, offset_ + i2); } Region1D operator()(const Index1D &I) { #ifdef TNT_BOUNDS_CHECK assert(TNT_BASE_OFFSET<=I.lbound()); assert(I.ubound() <= dim() + (TNT_BASE_OFFSET-1)); assert(I.lbound() <= I.ubound()); #endif return Region1D(A_, I.lbound()+offset_, offset_ + I.ubound()); } T & operator()(Subscript i) { #ifdef TNT_BOUNDS_CHECK assert(TNT_BASE_OFFSET <= i); assert(i <= dim() + (TNT_BASE_OFFSET-1)); #endif return A_(i+offset_); } const T & operator() (Subscript i) const { #ifdef TNT_BOUNDS_CHECK assert(TNT_BASE_OFFSET <= i); assert(i <= dim() + (TNT_BASE_OFFSET-1)); #endif return A_(i+offset_); } Region1D & operator=(const Region1D &R) { // make sure both sides conform assert(dim() == R.dim()); Subscript N = dim(); Subscript i; Subscript istart = TNT_BASE_OFFSET; Subscript iend = istart + N-1; for (i=istart; i<=iend; i++) (*this)(i) = R(i); return *this; } Region1D & operator=(const const_Region1D &R) { // make sure both sides conform assert(dim() == R.dim()); Subscript N = dim(); Subscript i; Subscript istart = TNT_BASE_OFFSET; Subscript iend = istart + N-1; for (i=istart; i<=iend; i++) (*this)(i) = R(i); return *this; } Region1D & operator=(const T& t) { Subscript N=dim(); Subscript i; Subscript istart = TNT_BASE_OFFSET; Subscript iend = istart + N-1; for (i=istart; i<= iend; i++) (*this)(i) = t; return *this; } Region1D & operator=(const Array1D &R) { // make sure both sides conform Subscript N = dim(); assert(dim() == R.dim()); Subscript i; Subscript istart = TNT_BASE_OFFSET; Subscript iend = istart + N-1; for (i=istart; i<=iend; i++) (*this)(i) = R(i); return *this; } }; template std::ostream& operator<<(std::ostream &s, Region1D &A) { Subscript N=A.dim(); Subscript istart = TNT_BASE_OFFSET; Subscript iend = N - 1 + TNT_BASE_OFFSET; for (Subscript i=istart; i<=iend; i++) s << A(i) << endl; return s; } /* --------- class const_Region1D ------------ */ template class const_Region1D { protected: const Array1D & A_; Subscript offset_; // 0-based Subscript dim_; typedef typename Array1D::element_type T; public: const Array1D & array() const { return A_; } Subscript offset() const { return offset_;} Subscript dim() const { return dim_; } Subscript offset(Subscript i) const { #ifdef TNT_BOUNDS_CHECK assert(i==TNT_BASE_OFFSET); #endif return offset_; } Subscript dim(Subscript i) const { #ifdef TNT_BOUNDS_CHECK assert(i== TNT_BASE_OFFSET); #endif return offset_; } const_Region1D(const Array1D &A, Subscript i1, Subscript i2) : A_(A) { #ifdef TNT_BOUNDS_CHECK assert(TNT_BASE_OFFSET <= i1 ); assert(i2 <= A.dim() + (TNT_BASE_OFFSET-1)); assert(i1 <= i2); #endif offset_ = i1 - TNT_BASE_OFFSET; dim_ = i2-i1 + 1; } const_Region1D(const Array1D &A, const Index1D &I) : A_(A) { #ifdef TNT_BOUNDS_CHECK assert(TNT_BASE_OFFSET <=I.lbound()); assert(I.ubound() <= A.dim() + (TNT_BASE_OFFSET-1)); assert(I.lbound() <= I.ubound()); #endif offset_ = I.lbound() - TNT_BASE_OFFSET; dim_ = I.ubound() - I.lbound() + 1; } const_Region1D(const_Region1D &A, Subscript i1, Subscript i2) : A_(A.A_) { #ifdef TNT_BOUNDS_CHECK assert(TNT_BASE_OFFSET <= i1 ); assert(i2 <= A.dim() + (TNT_BASE_OFFSET - 1)); assert(i1 <= i2); #endif // (old-offset) (new-offset) // offset_ = (i1 - TNT_BASE_OFFSET) + A.offset_; dim_ = i2-i1 + 1; } const_Region1D operator()(Subscript i1, Subscript i2) { #ifdef TNT_BOUNDS_CHECK assert(TNT_BASE_OFFSET <= i1); assert(i2 <= dim() + (TNT_BASE_OFFSET -1)); assert(i1 <= i2); #endif // offset_ is 0-based, so no need for // ( - TNT_BASE_OFFSET) // return const_Region1D(A_, i1+offset_, offset_ + i2); } const_Region1D operator()(const Index1D &I) { #ifdef TNT_BOUNDS_CHECK assert(TNT_BASE_OFFSET<=I.lbound()); assert(I.ubound() <= dim() + (TNT_BASE_OFFSET-1)); assert(I.lbound() <= I.ubound()); #endif return const_Region1D(A_, I.lbound()+offset_, offset_ + I.ubound()); } const T & operator() (Subscript i) const { #ifdef TNT_BOUNDS_CHECK assert(TNT_BASE_OFFSET <= i); assert(i <= dim() + (TNT_BASE_OFFSET-1)); #endif return A_(i+offset_); } }; template std::ostream& operator<<(std::ostream &s, const_Region1D &A) { Subscript N=A.dim(); for (Subscript i=1; i<=N; i++) s << A(i) << endl; return s; } } // namespace TNT #endif // const_Region1D_H geepack/inst/include/tnt/transv.h0000755000176200001440000000713614165262714016566 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ // Matrix Transpose Views #ifndef TRANSV_H #define TRANSV_H #include #include #include "tnt/vec.h" namespace TNT { template class Transpose_View { protected: const Array2D & A_; public: typedef typename Array2D::element_type T; typedef T value_type; typedef T element_type; typedef T* pointer; typedef T* iterator; typedef T& reference; typedef const T* const_iterator; typedef const T& const_reference; const Array2D & array() const { return A_; } Subscript num_rows() const { return A_.num_cols();} Subscript num_cols() const { return A_.num_rows();} Subscript lbound() const { return A_.lbound(); } Subscript dim(Subscript i) const { #ifdef TNT_BOUNDS_CHECK assert( A_.lbound() <= i); assert( i<= A_.lbound()+1); #endif if (i== A_.lbound()) return num_rows(); else return num_cols(); } Transpose_View(const Transpose_View &A) : A_(A.A_) {}; Transpose_View(const Array2D &A) : A_(A) {}; inline const typename Array2D::element_type & operator()( Subscript i, Subscript j) const { #ifdef TNT_BOUNDS_CHECK assert(lbound()<=i); assert(i<=A_.num_cols() + lbound() - 1); assert(lbound()<=j); assert(j<=A_.num_rows() + lbound() - 1); #endif return A_(j,i); } }; template Transpose_View Transpose_view(const Matrix &A) { return Transpose_View(A); } template Vector matmult( const Transpose_View & A, const Vector &B) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(B.dim() == N); Vector x(M); Subscript i, j; T tmp = 0; for (i=1; i<=M; i++) { tmp = 0; for (j=1; j<=N; j++) tmp += A(i,j) * B(j); x(i) = tmp; } return x; } template inline Vector operator*(const Transpose_View & A, const Vector &B) { return matmult(A,B); } template std::ostream& operator<<(std::ostream &s, const Transpose_View &A) { Subscript M=A.num_rows(); Subscript N=A.num_cols(); Subscript start = A.lbound(); Subscript Mend = M + A.lbound() - 1; Subscript Nend = N + A.lbound() - 1; s << M << " " << N << endl; for (Subscript i=start; i<=Mend; i++) { for (Subscript j=start; j<=Nend; j++) { s << A(i,j) << " "; } s << endl; } return s; } } // namespace TNT #endif // TRANSV_H geepack/inst/include/tnt/stopwatch.h0000755000176200001440000000441514165262714017262 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ #ifndef STPWATCH_H #define STPWATCH_H // for clock() and CLOCKS_PER_SEC #include namespace TNT { /* Simple stopwatch object: void start() : start timing double stop() : stop timing void reset() : set elapsed time to 0.0 double read() : read elapsed time (in seconds) */ inline double seconds(void) { static const double secs_per_tick = 1.0 / CLOCKS_PER_SEC; return ( (double) clock() ) * secs_per_tick; } class stopwatch { private: int running; double last_time; double total; public: stopwatch() : running(0), last_time(0.0), total(0.0) {} void reset() { running = 0; last_time = 0.0; total=0.0; } void start() { if (!running) { last_time = seconds(); running = 1;}} double stop() { if (running) { total += seconds() - last_time; running = 0; } return total; } double read() { if (running) { total+= seconds() - last_time; last_time = seconds(); } return total; } }; } // namespace TNT #endif geepack/inst/include/tnt/fcscmat.h0000755000176200001440000001102214165262714016656 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ // Templated compressed sparse column matrix (Fortran conventions). // uses 1-based offsets in storing row indices. // Used primarily to interface with Fortran sparse matrix libaries. // (CANNOT BE USED AS AN STL CONTAINER.) #ifndef FCSCMAT_H #define FCSCMAT_H #include #include #include "tnt/tnt.h" #include "tnt/vec.h" using namespace std; namespace TNT { template class Fortran_Sparse_Col_Matrix { protected: Vector val_; // data values (nz_ elements) Vector rowind_; // row_ind (nz_ elements) Vector colptr_; // col_ptr (n_+1 elements) int nz_; // number of nonzeros Subscript m_; // global dimensions Subscript n_; public: Fortran_Sparse_Col_Matrix(void); Fortran_Sparse_Col_Matrix(const Fortran_Sparse_Col_Matrix &S) : val_(S.val_), rowind_(S.rowind_), colptr_(S.colptr_), nz_(S.nz_), m_(S.m_), n_(S.n_) {}; Fortran_Sparse_Col_Matrix(Subscript M, Subscript N, Subscript nz, const T *val, const Subscript *r, const Subscript *c) : val_(nz, val), rowind_(nz, r), colptr_(N+1, c), nz_(nz), m_(M), n_(N) {}; Fortran_Sparse_Col_Matrix(Subscript M, Subscript N, Subscript nz, char *val, char *r, char *c) : val_(nz, val), rowind_(nz, r), colptr_(N+1, c), nz_(nz), m_(M), n_(N) {}; Fortran_Sparse_Col_Matrix(Subscript M, Subscript N, Subscript nz, const T *val, Subscript *r, Subscript *c) : val_(nz, val), rowind_(nz, r), colptr_(N+1, c), nz_(nz), m_(M), n_(N) {}; ~Fortran_Sparse_Col_Matrix() {}; T & val(Subscript i) { return val_(i); } const T & val(Subscript i) const { return val_(i); } Subscript & row_ind(Subscript i) { return rowind_(i); } const Subscript & row_ind(Subscript i) const { return rowind_(i); } Subscript col_ptr(Subscript i) { return colptr_(i);} const Subscript col_ptr(Subscript i) const { return colptr_(i);} Subscript num_cols() const { return m_;} Subscript num_rows() const { return n_; } Subscript dim(Subscript i) const { #ifdef TNT_BOUNDS_CHECK assert( 1 <= i ); assert( i <= 2 ); #endif if (i==1) return m_; else if (i==2) return m_; else return 0; } Subscript num_nonzeros() const {return nz_;}; Subscript lbound() const {return 1;} Fortran_Sparse_Col_Matrix& operator=(const Fortran_Sparse_Col_Matrix &C) { val_ = C.val_; rowind_ = C.rowind_; colptr_ = C.colptr_; nz_ = C.nz_; m_ = C.m_; n_ = C.n_; return *this; } Fortran_Sparse_Col_Matrix& newsize(Subscript M, Subscript N, Subscript nz) { val_.newsize(nz); rowind_.newsize(nz); colptr_.newsize(N+1); return *this; } }; template ostream& operator<<(ostream &s, const Fortran_Sparse_Col_Matrix &A) { Subscript M=A.num_rows(); Subscript N=A.num_cols(); s << M << " " << N << " " << A.num_nonzeros() << endl; for (Subscript k=1; k<=N; k++) { Subscript start = A.col_ptr(k); Subscript end = A.col_ptr(k+1); for (Subscript i= start; i #include namespace TNT { template class const_Region2D; template class Region2D { protected: Array2D & A_; Subscript offset_[2]; // 0-offset internally Subscript dim_[2]; public: typedef typename Array2D::value_type T; typedef Subscript size_type; typedef T value_type; typedef T element_type; typedef T* pointer; typedef T* iterator; typedef T& reference; typedef const T* const_iterator; typedef const T& const_reference; Array2D & array() { return A_; } const Array2D & array() const { return A_; } Subscript lbound() const { return A_.lbound(); } Subscript num_rows() const { return dim_[0]; } Subscript num_cols() const { return dim_[1]; } Subscript offset(Subscript i) const // 1-offset { #ifdef TNT_BOUNDS_CHECK assert( A_.lbound() <= i); assert( i<= dim_[0] + A_.lbound()-1); #endif return offset_[i-A_.lbound()]; } Subscript dim(Subscript i) const { #ifdef TNT_BOUNDS_CHECK assert( A_.lbound() <= i); assert( i<= dim_[0] + A_.lbound()-1); #endif return dim_[i-A_.lbound()]; } Region2D(Array2D &A, Subscript i1, Subscript i2, Subscript j1, Subscript j2) : A_(A) { #ifdef TNT_BOUNDS_CHECK assert( i1 <= i2 ); assert( j1 <= j2); assert( A.lbound() <= i1); assert( i2<= A.dim(A.lbound()) + A.lbound()-1); assert( A.lbound() <= j1); assert( j2<= A.dim(A.lbound()+1) + A.lbound()-1 ); #endif offset_[0] = i1-A.lbound(); offset_[1] = j1-A.lbound(); dim_[0] = i2-i1+1; dim_[1] = j2-j1+1; } Region2D(Array2D &A, const Index1D &I, const Index1D &J) : A_(A) { #ifdef TNT_BOUNDS_CHECK assert( I.lbound() <= I.ubound() ); assert( J.lbound() <= J.ubound() ); assert( A.lbound() <= I.lbound()); assert( I.ubound()<= A.dim(A.lbound()) + A.lbound()-1); assert( A.lbound() <= J.lbound()); assert( J.ubound() <= A.dim(A.lbound()+1) + A.lbound()-1 ); #endif offset_[0] = I.lbound()-A.lbound(); offset_[1] = J.lbound()-A.lbound(); dim_[0] = I.ubound() - I.lbound() + 1; dim_[1] = J.ubound() - J.lbound() + 1; } Region2D(Region2D &A, Subscript i1, Subscript i2, Subscript j1, Subscript j2) : A_(A.A_) { #ifdef TNT_BOUNDS_CHECK assert( i1 <= i2 ); assert( j1 <= j2); assert( A.lbound() <= i1); assert( i2<= A.dim(A.lbound()) + A.lbound()-1); assert( A.lbound() <= j1); assert( j2<= A.dim(A.lbound()+1) + A.lbound()-1 ); #endif offset_[0] = (i1 - A.lbound()) + A.offset_[0]; offset_[1] = (j1 - A.lbound()) + A.offset_[1]; dim_[0] = i2-i1 + 1; dim_[1] = j2-j1+1; } Region2D operator()(Subscript i1, Subscript i2, Subscript j1, Subscript j2) { #ifdef TNT_BOUNDS_CHECK assert( i1 <= i2 ); assert( j1 <= j2); assert( A_.lbound() <= i1); assert( i2<= dim_[0] + A_.lbound()-1); assert( A_.lbound() <= j1); assert( j2<= dim_[1] + A_.lbound()-1 ); #endif return Region2D(A_, i1+offset_[0], offset_[0] + i2, j1+offset_[1], offset_[1] + j2); } Region2D operator()(const Index1D &I, const Index1D &J) { #ifdef TNT_BOUNDS_CHECK assert( I.lbound() <= I.ubound() ); assert( J.lbound() <= J.ubound() ); assert( A_.lbound() <= I.lbound()); assert( I.ubound()<= dim_[0] + A_.lbound()-1); assert( A_.lbound() <= J.lbound()); assert( J.ubound() <= dim_[1] + A_.lbound()-1 ); #endif return Region2D(A_, I.lbound()+offset_[0], offset_[0] + I.ubound(), offset_[1]+J.lbound(), offset_[1] + J.ubound()); } inline T & operator()(Subscript i, Subscript j) { #ifdef TNT_BOUNDS_CHECK assert( A_.lbound() <= i); assert( i<= dim_[0] + A_.lbound()-1); assert( A_.lbound() <= j); assert( j<= dim_[1] + A_.lbound()-1 ); #endif return A_(i+offset_[0], j+offset_[1]); } inline const T & operator() (Subscript i, Subscript j) const { #ifdef TNT_BOUNDS_CHECK assert( A_.lbound() <= i); assert( i<= dim_[0] + A_.lbound()-1); assert( A_.lbound() <= j); assert( j<= dim_[1] + A_.lbound()-1 ); #endif return A_(i+offset_[0], j+offset_[1]); } Region2D & operator=(const Region2D &R) { Subscript M = num_rows(); Subscript N = num_cols(); // make sure both sides conform assert(M == R.num_rows()); assert(N == R.num_cols()); Subscript start = R.lbound(); Subscript Mend = start + M - 1; Subscript Nend = start + N - 1; for (Subscript i=start; i<=Mend; i++) for (Subscript j=start; j<=Nend; j++) (*this)(i,j) = R(i,j); return *this; } Region2D & operator=(const const_Region2D &R) { Subscript M = num_rows(); Subscript N = num_cols(); // make sure both sides conform assert(M == R.num_rows()); assert(N == R.num_cols()); Subscript start = R.lbound(); Subscript Mend = start + M - 1; Subscript Nend = start + N - 1; for (Subscript i=start; i<=Mend; i++) for (Subscript j=start; j<=Nend; j++) (*this)(i,j) = R(i,j); return *this; } Region2D & operator=(const Array2D &R) { Subscript M = num_rows(); Subscript N = num_cols(); // make sure both sides conform assert(M == R.num_rows()); assert(N == R.num_cols()); Subscript start = R.lbound(); Subscript Mend = start + M - 1; Subscript Nend = start + N - 1; for (Subscript i=start; i<=Mend; i++) for (Subscript j=start; j<=Nend; j++) (*this)(i,j) = R(i,j); return *this; } Region2D & operator=(const T &scalar) { Subscript start = lbound(); Subscript Mend = lbound() + num_rows() - 1; Subscript Nend = lbound() + num_cols() - 1; for (Subscript i=start; i<=Mend; i++) for (Subscript j=start; j<=Nend; j++) (*this)(i,j) = scalar; return *this; } }; //************************ template class const_Region2D { protected: const Array2D & A_; Subscript offset_[2]; // 0-offset internally Subscript dim_[2]; public: typedef typename Array2D::value_type T; typedef T value_type; typedef T element_type; typedef const T* const_iterator; typedef const T& const_reference; const Array2D & array() const { return A_; } Subscript lbound() const { return A_.lbound(); } Subscript num_rows() const { return dim_[0]; } Subscript num_cols() const { return dim_[1]; } Subscript offset(Subscript i) const // 1-offset { #ifdef TNT_BOUNDS_CHECK assert( TNT_BASE_OFFSET <= i); assert( i<= dim_[0] + TNT_BASE_OFFSET-1); #endif return offset_[i-TNT_BASE_OFFSET]; } Subscript dim(Subscript i) const { #ifdef TNT_BOUNDS_CHECK assert( TNT_BASE_OFFSET <= i); assert( i<= dim_[0] + TNT_BASE_OFFSET-1); #endif return dim_[i-TNT_BASE_OFFSET]; } const_Region2D(const Array2D &A, Subscript i1, Subscript i2, Subscript j1, Subscript j2) : A_(A) { #ifdef TNT_BOUNDS_CHECK assert( i1 <= i2 ); assert( j1 <= j2); assert( TNT_BASE_OFFSET <= i1); assert( i2<= A.dim(TNT_BASE_OFFSET) + TNT_BASE_OFFSET-1); assert( TNT_BASE_OFFSET <= j1); assert( j2<= A.dim(TNT_BASE_OFFSET+1) + TNT_BASE_OFFSET-1 ); #endif offset_[0] = i1-TNT_BASE_OFFSET; offset_[1] = j1-TNT_BASE_OFFSET; dim_[0] = i2-i1+1; dim_[1] = j2-j1+1; } const_Region2D(const Array2D &A, const Index1D &I, const Index1D &J) : A_(A) { #ifdef TNT_BOUNDS_CHECK assert( I.lbound() <= I.ubound() ); assert( J.lbound() <= J.ubound() ); assert( TNT_BASE_OFFSET <= I.lbound()); assert( I.ubound()<= A.dim(TNT_BASE_OFFSET) + TNT_BASE_OFFSET-1); assert( TNT_BASE_OFFSET <= J.lbound()); assert( J.ubound() <= A.dim(TNT_BASE_OFFSET+1) + TNT_BASE_OFFSET-1 ); #endif offset_[0] = I.lbound()-TNT_BASE_OFFSET; offset_[1] = J.lbound()-TNT_BASE_OFFSET; dim_[0] = I.ubound() - I.lbound() + 1; dim_[1] = J.ubound() - J.lbound() + 1; } const_Region2D(const_Region2D &A, Subscript i1, Subscript i2, Subscript j1, Subscript j2) : A_(A.A_) { #ifdef TNT_BOUNDS_CHECK assert( i1 <= i2 ); assert( j1 <= j2); assert( TNT_BASE_OFFSET <= i1); assert( i2<= A.dim(TNT_BASE_OFFSET) + TNT_BASE_OFFSET-1); assert( TNT_BASE_OFFSET <= j1); assert( j2<= A.dim(TNT_BASE_OFFSET+1) + TNT_BASE_OFFSET-1 ); #endif offset_[0] = (i1 - TNT_BASE_OFFSET) + A.offset_[0]; offset_[1] = (j1 - TNT_BASE_OFFSET) + A.offset_[1]; dim_[0] = i2-i1 + 1; dim_[1] = j2-j1+1; } const_Region2D operator()(Subscript i1, Subscript i2, Subscript j1, Subscript j2) { #ifdef TNT_BOUNDS_CHECK assert( i1 <= i2 ); assert( j1 <= j2); assert( TNT_BASE_OFFSET <= i1); assert( i2<= dim_[0] + TNT_BASE_OFFSET-1); assert( TNT_BASE_OFFSET <= j1); assert( j2<= dim_[0] + TNT_BASE_OFFSET-1 ); #endif return const_Region2D(A_, i1+offset_[0], offset_[0] + i2, j1+offset_[1], offset_[1] + j2); } const_Region2D operator()(const Index1D &I, const Index1D &J) { #ifdef TNT_BOUNDS_CHECK assert( I.lbound() <= I.ubound() ); assert( J.lbound() <= J.ubound() ); assert( TNT_BASE_OFFSET <= I.lbound()); assert( I.ubound()<= dim_[0] + TNT_BASE_OFFSET-1); assert( TNT_BASE_OFFSET <= J.lbound()); assert( J.ubound() <= dim_[1] + TNT_BASE_OFFSET-1 ); #endif return const_Region2D(A_, I.lbound()+offset_[0], offset_[0] + I.ubound(), offset_[1]+J.lbound(), offset_[1] + J.ubound()); } inline const T & operator() (Subscript i, Subscript j) const { #ifdef TNT_BOUNDS_CHECK assert( TNT_BASE_OFFSET <= i); assert( i<= dim_[0] + TNT_BASE_OFFSET-1); assert( TNT_BASE_OFFSET <= j); assert( j<= dim_[1] + TNT_BASE_OFFSET-1 ); #endif return A_(i+offset_[0], j+offset_[1]); } }; // ************** std::ostream algorithms ******************************* template std::ostream& operator<<(std::ostream &s, const const_Region2D &A) { Subscript start = A.lbound(); Subscript Mend=A.lbound()+ A.num_rows() - 1; Subscript Nend=A.lbound() + A.num_cols() - 1; s << A.num_rows() << " " << A.num_cols() << "\n"; for (Subscript i=start; i<=Mend; i++) { for (Subscript j=start; j<=Nend; j++) { s << A(i,j) << " "; } s << "\n"; } return s; } template std::ostream& operator<<(std::ostream &s, const Region2D &A) { Subscript start = A.lbound(); Subscript Mend=A.lbound()+ A.num_rows() - 1; Subscript Nend=A.lbound() + A.num_cols() - 1; s << A.num_rows() << " " << A.num_cols() << "\n"; for (Subscript i=start; i<=Mend; i++) { for (Subscript j=start; j<=Nend; j++) { s << A(i,j) << " "; } s << "\n"; } return s; } } // namespace TNT #endif // REGION2D_H geepack/inst/include/tnt/triang.h0000755000176200001440000003345614165262714016541 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ // Triangular Matrices (Views and Adpators) #ifndef TRIANG_H #define TRIANG_H // default to use lower-triangular portions of arrays // for symmetric matrices. namespace TNT { template class LowerTriangularView { protected: const MaTRiX &A_; const typename MaTRiX::element_type zero_; public: typedef typename MaTRiX::const_reference const_reference; typedef const typename MaTRiX::element_type element_type; typedef const typename MaTRiX::element_type value_type; typedef element_type T; Subscript dim(Subscript d) const { return A_.dim(d); } Subscript lbound() const { return A_.lbound(); } Subscript num_rows() const { return A_.num_rows(); } Subscript num_cols() const { return A_.num_cols(); } // constructors LowerTriangularView(/*const*/ MaTRiX &A) : A_(A), zero_(0) {} inline const_reference get(Subscript i, Subscript j) const { #ifdef TNT_BOUNDS_CHECK assert(lbound()<=i); assert(i<=A_.num_rows() + lbound() - 1); assert(lbound()<=j); assert(j<=A_.num_cols() + lbound() - 1); #endif if (i > const_Region; const_Region operator()(/*const*/ Index1D &I, /*const*/ Index1D &J) const { return const_Region(*this, I, J); } const_Region operator()(Subscript i1, Subscript i2, Subscript j1, Subscript j2) const { return const_Region(*this, i1, i2, j1, j2); } #endif // TNT_USE_REGIONS }; /* *********** Lower_triangular_view() algorithms ****************** */ template VecToR matmult(/*const*/ LowerTriangularView &A, VecToR &x) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(N == x.dim()); Subscript i, j; typename MaTRiX::element_type sum=0.0; VecToR result(M); Subscript start = A.lbound(); Subscript Mend = M + A.lbound() -1 ; for (i=start; i<=Mend; i++) { sum = 0.0; for (j=start; j<=i; j++) sum = sum + A(i,j)*x(j); result(i) = sum; } return result; } template inline VecToR operator*(/*const*/ LowerTriangularView &A, VecToR &x) { return matmult(A,x); } template class UnitLowerTriangularView { protected: const MaTRiX &A_; const typename MaTRiX::element_type zero; const typename MaTRiX::element_type one; public: typedef typename MaTRiX::const_reference const_reference; typedef typename MaTRiX::element_type element_type; typedef typename MaTRiX::element_type value_type; typedef element_type T; Subscript lbound() const { return 1; } Subscript dim(Subscript d) const { return A_.dim(d); } Subscript num_rows() const { return A_.num_rows(); } Subscript num_cols() const { return A_.num_cols(); } // constructors UnitLowerTriangularView(/*const*/ MaTRiX &A) : A_(A), zero(0), one(1) {} inline const_reference get(Subscript i, Subscript j) const { #ifdef TNT_BOUNDS_CHECK assert(1<=i); assert(i<=A_.dim(1)); assert(1<=j); assert(j<=A_.dim(2)); assert(0<=i && ij) return A_(i,j); else if (i==j) return one; else return zero; } inline const_reference operator() (Subscript i, Subscript j) const { #ifdef TNT_BOUNDS_CHECK assert(1<=i); assert(i<=A_.dim(1)); assert(1<=j); assert(j<=A_.dim(2)); #endif if (i>j) return A_(i,j); else if (i==j) return one; else return zero; } #ifdef TNT_USE_REGIONS // These are the "index-aware" features typedef const_Region2D< UnitLowerTriangularView > const_Region; const_Region operator()(/*const*/ Index1D &I, /*const*/ Index1D &J) const { return const_Region(*this, I, J); } const_Region operator()(Subscript i1, Subscript i2, Subscript j1, Subscript j2) const { return const_Region(*this, i1, i2, j1, j2); } #endif // TNT_USE_REGIONS }; template LowerTriangularView Lower_triangular_view( /*const*/ MaTRiX &A) { return LowerTriangularView(A); } template UnitLowerTriangularView Unit_lower_triangular_view( /*const*/ MaTRiX &A) { return UnitLowerTriangularView(A); } template VecToR matmult(const UnitLowerTriangularView &A, VecToR &x) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(N == x.dim()); Subscript i, j; typename MaTRiX::element_type sum=0.0; VecToR result(M); Subscript start = A.lbound(); Subscript Mend = M + A.lbound() -1 ; for (i=start; i<=Mend; i++) { sum = 0.0; for (j=start; j inline VecToR operator*(const UnitLowerTriangularView &A, VecToR &x) { return matmult(A,x); } //********************** Algorithms ************************************* template std::ostream& operator<<(std::ostream &s, const LowerTriangularView&A) { Subscript M=A.num_rows(); Subscript N=A.num_cols(); s << M << " " << N << endl; for (Subscript i=1; i<=M; i++) { for (Subscript j=1; j<=N; j++) { s << A(i,j) << " "; } s << endl; } return s; } template std::ostream& operator<<(std::ostream &s, const UnitLowerTriangularView&A) { Subscript M=A.num_rows(); Subscript N=A.num_cols(); s << M << " " << N << endl; for (Subscript i=1; i<=M; i++) { for (Subscript j=1; j<=N; j++) { s << A(i,j) << " "; } s << endl; } return s; } // ******************* Upper Triangular Section ************************** template class UpperTriangularView { protected: /*const*/ MaTRiX &A_; /*const*/ typename MaTRiX::element_type zero_; public: typedef typename MaTRiX::const_reference const_reference; typedef /*const*/ typename MaTRiX::element_type element_type; typedef /*const*/ typename MaTRiX::element_type value_type; typedef element_type T; Subscript dim(Subscript d) const { return A_.dim(d); } Subscript lbound() const { return A_.lbound(); } Subscript num_rows() const { return A_.num_rows(); } Subscript num_cols() const { return A_.num_cols(); } // constructors UpperTriangularView(/*const*/ MaTRiX &A) : A_(A), zero_(0) {} inline const_reference get(Subscript i, Subscript j) const { #ifdef TNT_BOUNDS_CHECK assert(lbound()<=i); assert(i<=A_.num_rows() + lbound() - 1); assert(lbound()<=j); assert(j<=A_.num_cols() + lbound() - 1); #endif if (i>j) return zero_; else return A_(i,j); } inline const_reference operator() (Subscript i, Subscript j) const { #ifdef TNT_BOUNDS_CHECK assert(lbound()<=i); assert(i<=A_.num_rows() + lbound() - 1); assert(lbound()<=j); assert(j<=A_.num_cols() + lbound() - 1); #endif if (i>j) return zero_; else return A_(i,j); } #ifdef TNT_USE_REGIONS typedef const_Region2D< UpperTriangularView > const_Region; const_Region operator()(const Index1D &I, const Index1D &J) const { return const_Region(*this, I, J); } const_Region operator()(Subscript i1, Subscript i2, Subscript j1, Subscript j2) const { return const_Region(*this, i1, i2, j1, j2); } #endif // TNT_USE_REGIONS }; /* *********** Upper_triangular_view() algorithms ****************** */ template VecToR matmult(/*const*/ UpperTriangularView &A, VecToR &x) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(N == x.dim()); Subscript i, j; typename VecToR::element_type sum=0.0; VecToR result(M); Subscript start = A.lbound(); Subscript Mend = M + A.lbound() -1 ; for (i=start; i<=Mend; i++) { sum = 0.0; for (j=i; j<=N; j++) sum = sum + A(i,j)*x(j); result(i) = sum; } return result; } template inline VecToR operator*(/*const*/ UpperTriangularView &A, VecToR &x) { return matmult(A,x); } template class UnitUpperTriangularView { protected: const MaTRiX &A_; const typename MaTRiX::element_type zero; const typename MaTRiX::element_type one; public: typedef typename MaTRiX::const_reference const_reference; typedef typename MaTRiX::element_type element_type; typedef typename MaTRiX::element_type value_type; typedef element_type T; Subscript lbound() const { return 1; } Subscript dim(Subscript d) const { return A_.dim(d); } Subscript num_rows() const { return A_.num_rows(); } Subscript num_cols() const { return A_.num_cols(); } // constructors UnitUpperTriangularView(/*const*/ MaTRiX &A) : A_(A), zero(0), one(1) {} inline const_reference get(Subscript i, Subscript j) const { #ifdef TNT_BOUNDS_CHECK assert(1<=i); assert(i<=A_.dim(1)); assert(1<=j); assert(j<=A_.dim(2)); assert(0<=i && i > const_Region; const_Region operator()(const Index1D &I, const Index1D &J) const { return const_Region(*this, I, J); } const_Region operator()(Subscript i1, Subscript i2, Subscript j1, Subscript j2) const { return const_Region(*this, i1, i2, j1, j2); } #endif // TNT_USE_REGIONS }; template UpperTriangularView Upper_triangular_view( /*const*/ MaTRiX &A) { return UpperTriangularView(A); } template UnitUpperTriangularView Unit_upper_triangular_view( /*const*/ MaTRiX &A) { return UnitUpperTriangularView(A); } template VecToR matmult(/*const*/ UnitUpperTriangularView &A, VecToR &x) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(N == x.dim()); Subscript i, j; typename VecToR::element_type sum=0.0; VecToR result(M); Subscript start = A.lbound(); Subscript Mend = M + A.lbound() -1 ; for (i=start; i<=Mend; i++) { sum = x(i); for (j=i+1; j<=N; j++) sum = sum + A(i,j)*x(j); result(i) = sum + x(i); } return result; } template inline VecToR operator*(/*const*/ UnitUpperTriangularView &A, VecToR &x) { return matmult(A,x); } //********************** Algorithms ************************************* template std::ostream& operator<<(std::ostream &s, /*const*/ UpperTriangularView&A) { Subscript M=A.num_rows(); Subscript N=A.num_cols(); s << M << " " << N << endl; for (Subscript i=1; i<=M; i++) { for (Subscript j=1; j<=N; j++) { s << A(i,j) << " "; } s << endl; } return s; } template std::ostream& operator<<(std::ostream &s, /*const*/ UnitUpperTriangularView&A) { Subscript M=A.num_rows(); Subscript N=A.num_cols(); s << M << " " << N << endl; for (Subscript i=1; i<=M; i++) { for (Subscript j=1; j<=N; j++) { s << A(i,j) << " "; } s << endl; } return s; } } // namespace TNT #endif //TRIANG_H geepack/inst/include/tnt/qr.h0000755000176200001440000001327214165262714015671 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ #ifndef QR_H #define QR_H // Classical QR factorization example, based on Stewart[1973]. // // // This algorithm computes the factorization of a matrix A // into a product of an orthognal matrix (Q) and an upper triangular // matrix (R), such that QR = A. // // Parameters: // // A (in): Matrix(1:N, 1:N) // // Q (output): Matrix(1:N, 1:N), collection of Householder // column vectors Q1, Q2, ... QN // // R (output): upper triangular Matrix(1:N, 1:N) // // Returns: // // 0 if successful, 1 if A is detected to be singular // #include //for sqrt() & fabs() #include "tnt/tntmath.h" // for sign() // Classical QR factorization, based on Stewart[1973]. // // // This algorithm computes the factorization of a matrix A // into a product of an orthognal matrix (Q) and an upper triangular // matrix (R), such that QR = A. // // Parameters: // // A (in/out): On input, A is square, Matrix(1:N, 1:N), that represents // the matrix to be factored. // // On output, Q and R is encoded in the same Matrix(1:N,1:N) // in the following manner: // // R is contained in the upper triangular section of A, // except that R's main diagonal is in D. The lower // triangular section of A represents Q, where each // column j is the vector Qj = I - uj*uj'/pi_j. // // C (output): vector of Pi[j] // D (output): main diagonal of R, i.e. D(i) is R(i,i) // // Returns: // // 0 if successful, 1 if A is detected to be singular // namespace TNT { template int QR_factor(MaTRiX &A, Vector& C, Vector &D) { assert(A.lbound() == 1); // ensure these are all assert(C.lbound() == 1); // 1-based arrays and vectors assert(D.lbound() == 1); Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(M == N); // make sure A is square Subscript i,j,k; typename MaTRiX::element_type eta, sigma, sum; // adjust the shape of C and D, if needed... if (N != C.size()) C.newsize(N); if (N != D.size()) D.newsize(N); for (k=1; k eta ? absA : eta ); } if (eta == 0) // matrix is singular { cerr << "QR: k=" << k << "\n"; return 1; } // form Qk and premiltiply M by it // for(i=k; i<=N; i++) A(i,k) = A(i,k) / eta; sum = 0; for (i=k; i<=N; i++) sum = sum + A(i,k)*A(i,k); sigma = sign(A(k,k)) * sqrt(sum); A(k,k) = A(k,k) + sigma; C(k) = sigma * A(k,k); D(k) = -eta * sigma; for (j=k+1; j<=N; j++) { sum = 0; for (i=k; i<=N; i++) sum = sum + A(i,k)*A(i,j); sum = sum / C(k); for (i=k; i<=N; i++) A(i,j) = A(i,j) - sum * A(i,k); } D(N) = A(N,N); } return 0; } // modified form of upper triangular solve, except that the main diagonal // of R (upper portion of A) is in D. // template int R_solve(const MaTRiX &A, /*const*/ Vector &D, Vector &b) { assert(A.lbound() == 1); // ensure these are all assert(D.lbound() == 1); // 1-based arrays and vectors assert(b.lbound() == 1); Subscript i,j; Subscript N = A.num_rows(); assert(N == A.num_cols()); assert(N == D.dim()); assert(N == b.dim()); typename MaTRiX::element_type sum; if (D(N) == 0) return 1; b(N) = b(N) / D(N); for (i=N-1; i>=1; i--) { if (D(i) == 0) return 1; sum = 0; for (j=i+1; j<=N; j++) sum = sum + A(i,j)*b(j); b(i) = ( b(i) - sum ) / D(i); } return 0; } template int QR_solve(const MaTRiX &A, const Vector &c, /*const*/ Vector &d, Vector &b) { assert(A.lbound() == 1); // ensure these are all assert(c.lbound() == 1); // 1-based arrays and vectors assert(d.lbound() == 1); Subscript N=A.num_rows(); assert(N == A.num_cols()); assert(N == c.dim()); assert(N == d.dim()); assert(N == b.dim()); Subscript i,j; typename MaTRiX::element_type sum, tau; for (j=1; j #include #include #include #ifdef TNT_USE_REGIONS #include "tnt/region2d.h" #endif // simple 1-based, column oriented Matrix class namespace TNT { template class Fortran_Matrix { public: typedef T value_type; typedef T element_type; typedef T* pointer; typedef T* iterator; typedef T& reference; typedef const T* const_iterator; typedef const T& const_reference; Subscript lbound() const { return 1;} protected: T* v_; // these are adjusted to simulate 1-offset Subscript m_; Subscript n_; T** col_; // these are adjusted to simulate 1-offset // internal helper function to create the array // of row pointers void initialize(Subscript M, Subscript N) { // adjust col_[] pointers so that they are 1-offset: // col_[j][i] is really col_[j-1][i-1]; // // v_[] is the internal contiguous array, it is still 0-offset // v_ = new T[M*N]; col_ = new T*[N]; assert(v_ != NULL); assert(col_ != NULL); m_ = M; n_ = N; T* p = v_ - 1; for (Subscript i=0; i &A) { initialize(A.m_, A.n_); copy(A.v_); } Fortran_Matrix(Subscript M, Subscript N, const T& value = T()) { initialize(M,N); set(value); } Fortran_Matrix(Subscript M, Subscript N, const T* v) { initialize(M,N); copy(v); } Fortran_Matrix(Subscript M, Subscript N, char *s) { initialize(M,N); std::istringstream ins(s); Subscript i, j; for (i=1; i<=M; i++) for (j=1; j<=N; j++) ins >> (*this)(i,j); } // destructor ~Fortran_Matrix() { destroy(); } // assignments // Fortran_Matrix& operator=(const Fortran_Matrix &A) { if (v_ == A.v_) return *this; if (m_ == A.m_ && n_ == A.n_) // no need to re-alloc copy(A.v_); else { destroy(); initialize(A.m_, A.n_); copy(A.v_); } return *this; } Fortran_Matrix& operator=(const T& scalar) { set(scalar); return *this; } Subscript dim(Subscript d) const { #ifdef TNT_BOUNDS_CHECK assert( d >= 1); assert( d <= 2); #endif return (d==1) ? m_ : ((d==2) ? n_ : 0); } Subscript num_rows() const { return m_; } Subscript num_cols() const { return n_; } Fortran_Matrix& newsize(Subscript M, Subscript N) { if (num_rows() == M && num_cols() == N) return *this; destroy(); initialize(M,N); return *this; } // 1-based element access // inline reference operator()(Subscript i, Subscript j) { #ifdef TNT_BOUNDS_CHECK assert(1<=i); assert(i <= m_) ; assert(1<=j); assert(j <= n_); #endif return col_[j][i]; } inline const_reference operator() (Subscript i, Subscript j) const { #ifdef TNT_BOUNDS_CHECK assert(1<=i); assert(i <= m_) ; assert(1<=j); assert(j <= n_); #endif return col_[j][i]; } #ifdef TNT_USE_REGIONS typedef Region2D > Region; typedef const_Region2D< Fortran_Matrix > const_Region; Region operator()(const Index1D &I, const Index1D &J) { return Region(*this, I,J); } const_Region operator()(const Index1D &I, const Index1D &J) const { return const_Region(*this, I,J); } #endif }; /* *************************** I/O ********************************/ template std::ostream& operator<<(std::ostream &s, const Fortran_Matrix &A) { Subscript M=A.num_rows(); Subscript N=A.num_cols(); s << M << " " << N << "\n"; for (Subscript i=1; i<=M; i++) { for (Subscript j=1; j<=N; j++) { s << A(i,j) << " "; } s << "\n"; } return s; } template std::istream& operator>>(std::istream &s, Fortran_Matrix &A) { Subscript M, N; s >> M >> N; if ( !(M == A.num_rows() && N == A.num_cols())) { A.newsize(M,N); } for (Subscript i=1; i<=M; i++) for (Subscript j=1; j<=N; j++) { s >> A(i,j); } return s; } // *******************[ basic matrix algorithms ]*************************** template Fortran_Matrix operator+(const Fortran_Matrix &A, const Fortran_Matrix &B) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(M==B.num_rows()); assert(N==B.num_cols()); Fortran_Matrix tmp(M,N); Subscript i,j; for (i=1; i<=M; i++) for (j=1; j<=N; j++) tmp(i,j) = A(i,j) + B(i,j); return tmp; } template Fortran_Matrix operator-(const Fortran_Matrix &A, const Fortran_Matrix &B) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(M==B.num_rows()); assert(N==B.num_cols()); Fortran_Matrix tmp(M,N); Subscript i,j; for (i=1; i<=M; i++) for (j=1; j<=N; j++) tmp(i,j) = A(i,j) - B(i,j); return tmp; } // element-wise multiplication (use matmult() below for matrix // multiplication in the linear algebra sense.) // // template Fortran_Matrix mult_element(const Fortran_Matrix &A, const Fortran_Matrix &B) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(M==B.num_rows()); assert(N==B.num_cols()); Fortran_Matrix tmp(M,N); Subscript i,j; for (i=1; i<=M; i++) for (j=1; j<=N; j++) tmp(i,j) = A(i,j) * B(i,j); return tmp; } template Fortran_Matrix transpose(const Fortran_Matrix &A) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); Fortran_Matrix S(N,M); Subscript i, j; for (i=1; i<=M; i++) for (j=1; j<=N; j++) S(j,i) = A(i,j); return S; } template inline Fortran_Matrix matmult(const Fortran_Matrix &A, const Fortran_Matrix &B) { #ifdef TNT_BOUNDS_CHECK assert(A.num_cols() == B.num_rows()); #endif Subscript M = A.num_rows(); Subscript N = A.num_cols(); Subscript K = B.num_cols(); Fortran_Matrix tmp(M,K); T sum; for (Subscript i=1; i<=M; i++) for (Subscript k=1; k<=K; k++) { sum = 0; for (Subscript j=1; j<=N; j++) sum = sum + A(i,j) * B(j,k); tmp(i,k) = sum; } return tmp; } template inline Fortran_Matrix operator*(const Fortran_Matrix &A, const Fortran_Matrix &B) { return matmult(A,B); } template inline int matmult(Fortran_Matrix& C, const Fortran_Matrix &A, const Fortran_Matrix &B) { assert(A.num_cols() == B.num_rows()); Subscript M = A.num_rows(); Subscript N = A.num_cols(); Subscript K = B.num_cols(); C.newsize(M,K); // adjust shape of C, if necessary T sum; const T* row_i; const T* col_k; for (Subscript i=1; i<=M; i++) { for (Subscript k=1; k<=K; k++) { row_i = &A(i,1); col_k = &B(1,k); sum = 0; for (Subscript j=1; j<=N; j++) { sum += *row_i * *col_k; row_i += M; col_k ++; } C(i,k) = sum; } } return 0; } template Vector matmult(const Fortran_Matrix &A, const Vector &x) { #ifdef TNT_BOUNDS_CHECK assert(A.num_cols() == x.dim()); #endif Subscript M = A.num_rows(); Subscript N = A.num_cols(); Vector tmp(M); T sum; for (Subscript i=1; i<=M; i++) { sum = 0; for (Subscript j=1; j<=N; j++) sum = sum + A(i,j) * x(j); tmp(i) = sum; } return tmp; } template inline Vector operator*(const Fortran_Matrix &A, const Vector &x) { return matmult(A,x); } template inline Fortran_Matrix operator*(const Fortran_Matrix &A, const T &x) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); //Subscript MN = M*N; Fortran_Matrix res(M,N); const T* a = A.begin(); T* t = res.begin(); T* tend = res.end(); for (t=res.begin(); t < tend; t++, a++) *t = *a * x; return res; } } // namespace TNT #endif // FMAT_H geepack/inst/include/tnt/index.h0000755000176200001440000000354214165262714016355 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ // Vector/Matrix/Array Index Module #ifndef INDEX_H #define INDEX_H #include "tnt/subscript.h" namespace TNT { class Index1D { Subscript lbound_; Subscript ubound_; public: Subscript lbound() const { return lbound_; } Subscript ubound() const { return ubound_; } Index1D(const Index1D &D) : lbound_(D.lbound_), ubound_(D.ubound_) {} Index1D(Subscript i1, Subscript i2) : lbound_(i1), ubound_(i2) {} Index1D & operator=(const Index1D &D) { lbound_ = D.lbound_; ubound_ = D.ubound_; return *this; } }; inline Index1D operator+(const Index1D &D, Subscript i) { return Index1D(i+D.lbound(), i+D.ubound()); } inline Index1D operator+(Subscript i, const Index1D &D) { return Index1D(i+D.lbound(), i+D.ubound()); } inline Index1D operator-(Index1D &D, Subscript i) { return Index1D(D.lbound()-i, D.ubound()-i); } inline Index1D operator-(Subscript i, Index1D &D) { return Index1D(i-D.lbound(), i-D.ubound()); } } // namespace TNT #endif geepack/inst/include/tnt/fortran.h0000755000176200001440000000421014165262714016712 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ // Header file to define C/Fortran conventions (Platform specific) #ifndef FORTRAN_H #define FORTRAN_H // help map between C/C++ data types and Fortran types typedef int Fortran_integer; typedef float Fortran_float; typedef double Fortran_double; typedef Fortran_double *fda_; // (in/out) double precision array typedef const Fortran_double *cfda_; // (in) double precsion array typedef Fortran_double *fd_; // (in/out) single double precision typedef const Fortran_double *cfd_; // (in) single double precision typedef Fortran_float *ffa_; // (in/out) float precision array typedef const Fortran_float *cffa_; // (in) float precsion array typedef Fortran_float *ff_; // (in/out) single float precision typedef const Fortran_float *cff_; // (in) single float precision typedef Fortran_integer *fia_; // (in/out) single integer array typedef const Fortran_integer *cfia_; // (in) single integer array typedef Fortran_integer *fi_; // (in/out) single integer typedef const Fortran_integer *cfi_; // (in) single integer typedef char *fch_; // (in/out) single character typedef char *cfch_; // (in) single character #ifndef TNT_SUBSCRIPT_TYPE #define TNT_SUBSCRIPT_TYPE TNT::Fortran_integer #endif #endif // FORTRAN_H geepack/inst/include/tnt/version.h0000755000176200001440000000072014165262714016726 0ustar liggesusers// Template Numerical Toolkit (TNT) for Linear Algebra // // BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE // Please see http://math.nist.gov/tnt for updates // // R. Pozo // Mathematical and Computational Sciences Division // National Institute of Standards and Technology #ifndef TNT_VERSION_H #define TNT_VERSION_H #define TNT_MAJOR_VERSION '0' #define TNT_MINOR_VERSION '9' #define TNT_SUBMINOR_VERSION '4' #define TNT_VERSION_STRING "0.9.4" #endif geepack/inst/include/tnt/cholesky.h0000755000176200001440000000406714165262714017072 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ #ifndef CHOLESKY_H #define CHOLESKY_H #include // index method namespace TNT { // // Only upper part of A is used. Cholesky factor is returned in // lower part of L. Returns 0 if successful, 1 otherwise. // template int Cholesky_upper_factorization(SPDMatrix &A, SymmMatrix &L) { Subscript M = A.dim(1); Subscript N = A.dim(2); assert(M == N); // make sure A is square // readjust size of L, if necessary if (M != L.dim(1) || N != L.dim(2)) L = SymmMatrix(N,N); Subscript i,j,k; typename SPDMatrix::element_type dot=0; for (j=1; j<=N; j++) // form column j of L { dot= 0; for (i=1; i #include #include #include namespace TNT { template class Vector { public: typedef Subscript size_type; typedef T value_type; typedef T element_type; typedef T* pointer; typedef T* iterator; typedef T& reference; typedef const T* const_iterator; typedef const T& const_reference; Subscript lbound() const { return 1;} protected: T* v_; T* vm1_; // pointer adjustment for optimzied 1-offset indexing Subscript n_; // internal helper function to create the array // of row pointers void initialize(Subscript N) { // adjust pointers so that they are 1-offset: // v_[] is the internal contiguous array, it is still 0-offset // assert(v_ == NULL); v_ = new T[N]; assert(v_ != NULL); vm1_ = v_-1; n_ = N; } void copy(const T* v) { Subscript N = n_; Subscript i; #ifdef TNT_UNROLL_LOOPS Subscript Nmod4 = N & 3; Subscript N4 = N - Nmod4; for (i=0; i &A) : v_(0), vm1_(0), n_(0) { initialize(A.n_); copy(A.v_); } Vector(Subscript N, const T& value = T()) : v_(0), vm1_(0), n_(0) { initialize(N); set(value); } Vector(Subscript N, const T* v) : v_(0), vm1_(0), n_(0) { initialize(N); copy(v); } Vector(Subscript N, char *s) : v_(0), vm1_(0), n_(0) { initialize(N); std::istringstream ins(s); Subscript i; for (i=0; i> v_[i]; } // methods // Vector& newsize(Subscript N) { if (n_ == N) return *this; destroy(); initialize(N); return *this; } // assignments // Vector& operator=(const Vector &A) { if (v_ == A.v_) return *this; if (n_ == A.n_) // no need to re-alloc copy(A.v_); else { destroy(); initialize(A.n_); copy(A.v_); } return *this; } Vector& operator=(const T& scalar) { set(scalar); return *this; } inline Subscript dim() const { return n_; } inline Subscript size() const { return n_; } inline reference operator()(Subscript i) { #ifdef TNT_BOUNDS_CHECK assert(1<=i); assert(i <= n_) ; #endif return vm1_[i]; } inline const_reference operator() (Subscript i) const { #ifdef TNT_BOUNDS_CHECK assert(1<=i); assert(i <= n_) ; #endif return vm1_[i]; } inline reference operator[](Subscript i) { #ifdef TNT_BOUNDS_CHECK assert(0<=i); assert(i < n_) ; #endif return v_[i]; } inline const_reference operator[](Subscript i) const { #ifdef TNT_BOUNDS_CHECK assert(0<=i); assert(i < n_) ; #endif return v_[i]; } }; /* *************************** I/O ********************************/ template std::ostream& operator<<(std::ostream &s, const Vector &A) { Subscript N=A.dim(); s << N << endl; for (Subscript i=0; i std::istream & operator>>(std::istream &s, Vector &A) { Subscript N; s >> N; if ( !(N == A.size() )) { A.newsize(N); } for (Subscript i=0; i> A[i]; return s; } // *******************[ basic matrix algorithms ]*************************** template Vector operator+(const Vector &A, const Vector &B) { Subscript N = A.dim(); assert(N==B.dim()); Vector tmp(N); Subscript i; for (i=0; i Vector operator-(const Vector &A, const Vector &B) { Subscript N = A.dim(); assert(N==B.dim()); Vector tmp(N); Subscript i; for (i=0; i Vector operator*(const Vector &A, const Vector &B) { Subscript N = A.dim(); assert(N==B.dim()); Vector tmp(N); Subscript i; for (i=0; i T dot_prod(const Vector &A, const Vector &B) { Subscript N = A.dim(); assert(N == B.dim()); Subscript i; T sum = 0; for (i=0; i VecToR Lower_triangular_solve(const MaTriX &A, const VecToR &b) { Subscript N = A.num_rows(); // make sure matrix sizes agree; A must be square assert(A.num_cols() == N); assert(b.dim() == N); VecToR x(N); Subscript i; for (i=1; i<=N; i++) { typename MaTriX::element_type tmp=0; for (Subscript j=1; j VecToR Unit_lower_triangular_solve(const MaTriX &A, const VecToR &b) { Subscript N = A.num_rows(); // make sure matrix sizes agree; A must be square assert(A.num_cols() == N); assert(b.dim() == N); VecToR x(N); Subscript i; for (i=1; i<=N; i++) { typename MaTriX::element_type tmp=0; for (Subscript j=1; j VecToR linear_solve(const LowerTriangularView &A, const VecToR &b) { return Lower_triangular_solve(A, b); } template VecToR linear_solve(const UnitLowerTriangularView &A, const VecToR &b) { return Unit_lower_triangular_solve(A, b); } //********************** Upper triangular section **************** template VecToR Upper_triangular_solve(const MaTriX &A, const VecToR &b) { Subscript N = A.num_rows(); // make sure matrix sizes agree; A must be square assert(A.num_cols() == N); assert(b.dim() == N); VecToR x(N); Subscript i; for (i=N; i>=1; i--) { typename MaTriX::element_type tmp=0; for (Subscript j=i+1; j<=N; j++) tmp = tmp + A(i,j)*x(j); x(i) = (b(i) - tmp)/ A(i,i); } return x; } template VecToR Unit_upper_triangular_solve(const MaTriX &A, const VecToR &b) { Subscript N = A.num_rows(); // make sure matrix sizes agree; A must be square assert(A.num_cols() == N); assert(b.dim() == N); VecToR x(N); Subscript i; for (i=N; i>=1; i--) { typename MaTriX::element_type tmp=0; for (Subscript j=i+1; j VecToR linear_solve(const UpperTriangularView &A, const VecToR &b) { return Upper_triangular_solve(A, b); } template VecToR linear_solve(const UnitUpperTriangularView &A, const VecToR &b) { return Unit_upper_triangular_solve(A, b); } } // namespace TNT #endif // TRISLV_H geepack/inst/include/tnt/tnt.h0000755000176200001440000000577314165262714016063 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ #ifndef TNT_H #define TNT_H //--------------------------------------------------------------------- // tnt.h TNT general header file. Defines default types // and conventions. //--------------------------------------------------------------------- //--------------------------------------------------------------------- // Include current version //--------------------------------------------------------------------- #include "tnt/version.h" //--------------------------------------------------------------------- // Define the data type used for matrix and vector Subscripts. // This will default to "int", but it can be overriden at compile time, // e.g. // // g++ -DTNT_SUBSCRIPT_TYPE='unsinged long' ... // // See subscript.h for details. //--------------------------------------------------------------------- #include "tnt/subscript.h" //--------------------------------------------------------------------- // Define this macro if you want TNT to ensure all refernces // are within the bounds of the array. This encurs a run-time // overhead, of course, but is recommended while developing // code. It can be turned off for production runs. // // #define TNT_BOUNDS_CHECK //--------------------------------------------------------------------- // #define TNT_BOUNDS_CHECK #ifdef TNT_NO_BOUNDS_CHECK #undef TNT_BOUNDS_CHECK #endif //--------------------------------------------------------------------- // Define this macro if you want to utilize matrix and vector // regions. This is typically on, but you can save some // compilation time by turning it off. If you do this and // attempt to use regions you will get an error message. // // #define TNT_USE_REGIONS //--------------------------------------------------------------------- // #define TNT_USE_REGIONS //--------------------------------------------------------------------- // //--------------------------------------------------------------------- // if your system doesn't have abs() min(), and max() uncoment the following //--------------------------------------------------------------------- // // //#define __NEED_ABS_MIN_MAX_ #include "tnt/tntmath.h" #endif // TNT_H geepack/inst/include/tnt/tntmath.h0000755000176200001440000000311414165262714016720 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ // Header file for scalar math functions #ifndef TNTMATH_H #define TNTMATH_H // conventional functions required by several matrix algorithms namespace TNT { inline double abs(double t) { return ( t > 0 ? t : -t); } inline double min(double a, double b) { return (a < b ? a : b); } inline double max(double a, double b) { return (a > b ? a : b); } inline float abs(float t) { return ( t > 0 ? t : -t); } inline float min(float a, float b) { return (a < b ? a : b); } inline float max(float a, float b) { return (a > b ? a : b); } inline double sign(double a) { return (a > 0 ? 1.0 : -1.0); } inline float sign(float a) { return (a > 0.0 ? 1.0f : -1.0f); } } /* namespace TNT */ #endif /* TNTMATH_H */ geepack/inst/include/tnt/subscript.h0000755000176200001440000000332514165262714017263 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ #ifndef SUBSCRPT_H #define SUBSCRPT_H //--------------------------------------------------------------------- // This definition describes the default TNT data type used for // indexing into TNT matrices and vectors. The data type should // be wide enough to index into large arrays. It defaults to an // "int", but can be overriden at compile time redefining TNT_SUBSCRIPT_TYPE, // e.g. // // g++ -DTNT_SUBSCRIPT_TYPE='unsigned int' ... // //--------------------------------------------------------------------- // #ifndef TNT_SUBSCRIPT_TYPE #define TNT_SUBSCRIPT_TYPE int #endif namespace TNT { typedef TNT_SUBSCRIPT_TYPE Subscript; } // () indexing in TNT means 1-offset, i.e. x(1) and A(1,1) are the // first elements. This offset is left as a macro for future // purposes, but should not be changed in the current release. // // #define TNT_BASE_OFFSET (1) #endif geepack/inst/include/tnt/fspvec.h0000755000176200001440000000767014165262714016542 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ // Templated sparse vector (Fortran conventions). // Used primarily to interface with Fortran sparse matrix libaries. // (CANNOT BE USED AS AN STL CONTAINER.) #ifndef FSPVEC_H #define FSPVEC_H #include "tnt/tnt.h" #include "tnt/vec.h" #include #include #include #include using namespace std; namespace TNT { template class Fortran_Sparse_Vector { public: typedef Subscript size_type; typedef T value_type; typedef T element_type; typedef T* pointer; typedef T* iterator; typedef T& reference; typedef const T* const_iterator; typedef const T& const_reference; Subscript lbound() const { return 1;} protected: Vector val_; Vector index_; Subscript dim_; // prescribed dimension public: // size and shape information Subscript dim() const { return dim_; } Subscript num_nonzeros() const { return val_.dim(); } // access T& val(Subscript i) { return val_(i); } const T& val(Subscript i) const { return val_(i); } Subscript &index(Subscript i) { return index_(i); } const Subscript &index(Subscript i) const { return index_(i); } // constructors Fortran_Sparse_Vector() : val_(), index_(), dim_(0) {}; Fortran_Sparse_Vector(Subscript N, Subscript nz) : val_(nz), index_(nz), dim_(N) {}; Fortran_Sparse_Vector(Subscript N, Subscript nz, const T *values, const Subscript *indices): val_(nz, values), index_(nz, indices), dim_(N) {} Fortran_Sparse_Vector(const Fortran_Sparse_Vector &S): val_(S.val_), index_(S.index_), dim_(S.dim_) {} // initialize from string, e.g. // // Fortran_Sparse_Vector A(N, 2, "1.0 2.1", "1 3"); // Fortran_Sparse_Vector(Subscript N, Subscript nz, char *v, char *ind) : val_(nz, v), index_(nz, ind), dim_(N) {} // assignments Fortran_Sparse_Vector & newsize(Subscript N, Subscript nz) { val_.newsize(nz); index_.newsize(nz); dim_ = N; return *this; } Fortran_Sparse_Vector & operator=( const Fortran_Sparse_Vector &A) { val_ = A.val_; index_ = A.index_; dim_ = A.dim_; return *this; } // methods }; /* *************************** I/O ********************************/ template ostream& operator<<(ostream &s, const Fortran_Sparse_Vector &A) { // output format is : N nz val1 ind1 val2 ind2 ... Subscript nz=A.num_nonzeros(); s << A.dim() << " " << nz << endl; for (Subscript i=1; i<=nz; i++) s << A.val(i) << " " << A.index(i) << endl; s << endl; return s; } template istream& operator>>(istream &s, Fortran_Sparse_Vector &A) { // output format is : N nz val1 ind1 val2 ind2 ... Subscript N; Subscript nz; s >> N >> nz; A.newsize(N, nz); for (Subscript i=1; i<=nz; i++) s >> A.val(i) >> A.index(i); return s; } } // namespace TNT #endif // FSPVEC_H geepack/inst/include/tnt/lapack.h0000755000176200001440000001146314165262714016502 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ // Header file for Fortran Lapack #ifndef LAPACK_H #define LAPACK_H // This file incomplete and included here to only demonstrate the // basic framework for linking with the Fortran Lapack routines. #include "tnt/fortran.h" #include "tnt/vec.h" #include "tnt/fmat.h" #define F77_DGESV dgesv_ #define F77_DGELS dgels_ #define F77_DSYEV dsyev_ #define F77_DGEEV dgeev_ extern "C" { // linear equations (general) using LU factorizaiton // void F77_DGESV(cfi_ N, cfi_ nrhs, fda_ A, cfi_ lda, fia_ ipiv, fda_ b, cfi_ ldb, fi_ info); // solve linear least squares using QR or LU factorization // void F77_DGELS(cfch_ trans, cfi_ M, cfi_ N, cfi_ nrhs, fda_ A, cfi_ lda, fda_ B, cfi_ ldb, fda_ work, cfi_ lwork, fi_ info); // solve symmetric eigenvalues // void F77_DSYEV( cfch_ jobz, cfch_ uplo, cfi_ N, fda_ A, cfi_ lda, fda_ W, fda_ work, cfi_ lwork, fi_ info); // solve unsymmetric eigenvalues // void F77_DGEEV(cfch_ jobvl, cfch_ jobvr, cfi_ N, fda_ A, cfi_ lda, fda_ wr, fda_ wi, fda_ vl, cfi_ ldvl, fda_ vr, cfi_ ldvr, fda_ work, cfi_ lwork, fi_ info); } // solve linear equations using LU factorization using namespace TNT; Vector Lapack_LU_linear_solve(const Fortran_Matrix &A, const Vector &b) { const Fortran_integer one=1; Subscript M=A.num_rows(); Subscript N=A.num_cols(); Fortran_Matrix Tmp(A); Vector x(b); Vector index(M); Fortran_integer info = 0; F77_DGESV(&N, &one, &Tmp(1,1), &M, &index(1), &x(1), &M, &info); if (info != 0) return Vector(0); else return x; } // solve linear least squares problem using QR factorization // Vector Lapack_LLS_QR_linear_solve(const Fortran_Matrix &A, const Vector &b) { const Fortran_integer one=1; Subscript M=A.num_rows(); Subscript N=A.num_cols(); Fortran_Matrix Tmp(A); Vector x(b); Fortran_integer info = 0; char transp = 'N'; Fortran_integer lwork = 5 * (M+N); // temporary work space Vector work(lwork); F77_DGELS(&transp, &M, &N, &one, &Tmp(1,1), &M, &x(1), &M, &work(1), &lwork, &info); if (info != 0) return Vector(0); else return x; } // *********************** Eigenvalue problems ******************* // solve symmetric eigenvalue problem (eigenvalues only) // Vector Upper_symmetric_eigenvalue_solve(const Fortran_Matrix &A) { char jobz = 'N'; char uplo = 'U'; Subscript N = A.num_rows(); assert(N == A.num_cols()); Vector eigvals(N); Fortran_integer worksize = 3*N; Fortran_integer info = 0; Vector work(worksize); Fortran_Matrix Tmp = A; F77_DSYEV(&jobz, &uplo, &N, &Tmp(1,1), &N, eigvals.begin(), work.begin(), &worksize, &info); if (info != 0) return Vector(); else return eigvals; } // solve unsymmetric eigenvalue problems // int eigenvalue_solve(const Fortran_Matrix &A, Vector &wr, Vector &wi) { char jobvl = 'N'; char jobvr = 'N'; Fortran_integer N = A.num_rows(); assert(N == A.num_cols()); if (N<1) return 1; Fortran_Matrix vl(1,N); /* should be NxN ? **** */ Fortran_Matrix vr(1,N); Fortran_integer one = 1; Fortran_integer worksize = 5*N; Fortran_integer info = 0; Vector work(worksize, 0.0); Fortran_Matrix Tmp = A; wr.newsize(N); wi.newsize(N); // void F77_DGEEV(cfch_ jobvl, cfch_ jobvr, cfi_ N, fda_ A, cfi_ lda, // fda_ wr, fda_ wi, fda_ vl, cfi_ ldvl, fda_ vr, // cfi_ ldvr, fda_ work, cfi_ lwork, fi_ info); F77_DGEEV(&jobvl, &jobvr, &N, &Tmp(1,1), &N, &(wr(1)), &(wi(1)), &(vl(1,1)), &one, &(vr(1,1)), &one, &(work(1)), &worksize, &info); return (info==0 ? 0: 1); } #endif // LAPACK_H geepack/inst/include/tnt/tntreqs.h0000755000176200001440000000455514165262714016753 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ // The requirements for a bare-bones vector class: // // // o) must have 0-based [] indexing for const and // non-const objects (i.e. operator[] defined) // // o) must have size() method to denote the number of // elements // o) must clean up after itself when destructed // (i.e. no memory leaks) // // -) must have begin() and end() methods (The begin() // method is necessary, because relying on // &v_[0] may not work on a empty vector (i.e. v_ is NULL.) // // o) must be templated // o) must have X::value_type defined to be the types of elements // o) must have X::X(const &x) copy constructor (by *value*) // o) must have X::X(int N) constructor to N-length vector // (NOTE: this constructor need *NOT* initalize elements) // // -) must have X::X(int N, T scalar) constructor to initalize // elements to value of "scalar". // // ( removed, because valarray<> class uses (scalar, N) rather // than (N, scalar) ) // -) must have X::X(int N, const T* scalars) constructor to copy from // any C linear array // // ( removed, because of same reverse order of valarray<> ) // // o) must have assignment A=B, by value // // NOTE: this class is *NOT* meant to be derived from, // so its methods (particularly indexing) need not be // declared virtual. // // // Some things it *DOES NOT* need to do are // // o) bounds checking // o) array referencing (e.g. reference counting) // o) support () indexing // o) I/O // geepack/inst/include/tnt/lu.h0000755000176200001440000001163014165262714015663 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ #ifndef LU_H #define LU_H // Solve system of linear equations Ax = b. // // Typical usage: // // Matrix(double) A; // Vector(Subscript) ipiv; // Vector(double) b; // // 1) LU_Factor(A,ipiv); // 2) LU_Solve(A,ipiv,b); // // Now b has the solution x. Note that both A and b // are overwritten. If these values need to be preserved, // one can make temporary copies, as in // // O) Matrix(double) T = A; // 1) LU_Factor(T,ipiv); // 1a) Vector(double) x=b; // 2) LU_Solve(T,ipiv,x); // // See details below. // // for fabs() // #include // right-looking LU factorization algorithm (unblocked) // // Factors matrix A into lower and upper triangular matrices // (L and U respectively) in solving the linear equation Ax=b. // // // Args: // // A (input/output) Matrix(1:n, 1:n) In input, matrix to be // factored. On output, overwritten with lower and // upper triangular factors. // // indx (output) Vector(1:n) Pivot vector. Describes how // the rows of A were reordered to increase // numerical stability. // // Return value: // // int (0 if successful, 1 otherwise) // // namespace TNT { template int LU_factor( MaTRiX &A, VecToRSubscript &indx) { assert(A.lbound() == 1); // currently for 1-offset assert(indx.lbound() == 1); // vectors and matrices Subscript M = A.num_rows(); Subscript N = A.num_cols(); if (M == 0 || N==0) return 0; if (indx.dim() != M) indx.newsize(M); Subscript i=0,j=0,k=0; Subscript jp=0; typename MaTRiX::element_type t; Subscript minMN = (M < N ? M : N) ; // min(M,N); for (j=1; j<= minMN; j++) { // find pivot in column j and test for singularity. jp = j; t = fabs(A(j,j)); for (i=j+1; i<=M; i++) if ( fabs(A(i,j)) > t) { jp = i; t = fabs(A(i,j)); } indx(j) = jp; // jp now has the index of maximum element // of column j, below the diagonal if ( A(jp,j) == 0 ) return 1; // factorization failed because of zero pivot if (jp != j) // swap rows j and jp for (k=1; k<=N; k++) { t = A(j,k); A(j,k) = A(jp,k); A(jp,k) =t; } if (j int LU_solve(const MaTRiX &A, const VecToRSubscripts &indx, VecToR &b) { assert(A.lbound() == 1); // currently for 1-offset assert(indx.lbound() == 1); // vectors and matrices assert(b.lbound() == 1); Subscript i,ii=0,ip,j; Subscript n = b.dim(); typename MaTRiX::element_type sum = 0.0; for (i=1;i<=n;i++) { ip=indx(i); sum=b(ip); b(ip)=b(i); if (ii) for (j=ii;j<=i-1;j++) sum -= A(i,j)*b(j); else if (sum) ii=i; b(i)=sum; } for (i=n;i>=1;i--) { sum=b(i); for (j=i+1;j<=n;j++) sum -= A(i,j)*b(j); b(i)=sum/A(i,i); } return 0; } } // namespace TNT #endif // LU_H geepack/inst/include/tnt/vecadaptor.h0000755000176200001440000001604314165262714017376 0ustar liggesusers/* * * Template Numerical Toolkit (TNT): Linear Algebra Module * * Mathematical and Computational Sciences Division * National Institute of Technology, * Gaithersburg, MD USA * * * This software was developed at the National Institute of Standards and * Technology (NIST) by employees of the Federal Government in the course * of their official duties. Pursuant to title 17 Section 105 of the * United States Code, this software is not subject to copyright protection * and is in the public domain. The Template Numerical Toolkit (TNT) is * an experimental system. NIST assumes no responsibility whatsoever for * its use by other parties, and makes no guarantees, expressed or implied, * about its quality, reliability, or any other characteristic. * * BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE * see http://math.nist.gov/tnt for latest updates. * */ #ifndef VECADAPTOR_H #define VECADAPTOR_H #include #include #include #include #include "tnt/subscript.h" #ifdef TNT_USE_REGIONS #include "tnt/region1d.h" #endif namespace TNT { // see "tntreq.h" for TNT requirements for underlying vector // class. This need NOT be the STL vector<> class, but a subset // that provides minimal services. // // This is a container adaptor that provides the following services. // // o) adds 1-offset operator() access ([] is always 0 offset) // o) adds TNT_BOUNDS_CHECK to () and [] // o) adds initialization from strings, e.g. "1.0 2.0 3.0"; // o) adds newsize(N) function (does not preserve previous values) // o) adds dim() and dim(1) // o) adds free() function to release memory used by vector // o) adds regions, e.g. A(Index(1,10)) = ... // o) add getVector() method to return adapted container // o) adds simple I/O for ostreams template class Vector_Adaptor { public: typedef typename BBVec::value_type T; typedef T value_type; typedef T element_type; typedef T* pointer; typedef T* iterator; typedef T& reference; typedef const T* const_iterator; typedef const T& const_reference; Subscript lbound() const { return 1; } protected: BBVec v_; T* vm1_; public: Subscript size() const { return v_.size(); } // These were removed so that the ANSI C++ valarray class // would work as a possible storage container. // // //iterator begin() { return v_.begin();} //iterator begin() { return &v_[0];} // //iterator end() { return v_.end(); } //iterator end() { return &v_[0] + v_.size(); } // //const_iterator begin() const { return v_.begin();} //const_iterator begin() const { return &v_[0];} // //const_iterator end() const { return v_.end(); } //const_iterator end() const { return &v_[0] + v_.size(); } BBVec& getVector() { return v_; } Subscript dim() const { return v_.size(); } Subscript dim(Subscript i) { #ifdef TNT_BOUNDS_CHECK assert(i==TNT_BASE_OFFSET); #endif return (i==TNT_BASE_OFFSET ? v_.size() : 0 ); } Vector_Adaptor() : v_() {}; Vector_Adaptor(const Vector_Adaptor &A) : v_(A.v_) { vm1_ = ( v_.size() > 0 ? &(v_[0]) -1 : NULL); } Vector_Adaptor(Subscript N, /*const*/ char *s) : v_(N) { istrstream ins(s); for (Subscript i=0; i> v_[i] ; vm1_ = ( v_.size() > 0 ? &(v_[0]) -1 : NULL); }; Vector_Adaptor(Subscript N, const T& value = T()) : v_(N) { for (Subscript i=0; i 0 ? &(v_[0]) -1 : NULL); } Vector_Adaptor(Subscript N, const T* values) : v_(N) { for (Subscript i=0; i 0 ? &(v_[0]) -1 : NULL); } Vector_Adaptor(const BBVec & A) : v_(A) { vm1_ = ( v_.size() > 0 ? &(v_[0]) -1 : NULL); } // NOTE: this assumes that BBVec(0) constructor creates an // null vector that does not take up space... It would be // great to require that BBVec have a corresponding free() // function, but in particular STL vectors do not. // Vector_Adaptor& free() { return *this = Vector_Adaptor(0); } Vector_Adaptor& operator=(const Vector_Adaptor &A) { v_ = A.v_ ; vm1_ = ( v_.size() > 0 ? &(v_[0]) -1 : NULL); return *this; } Vector_Adaptor& newsize(Subscript N) { // NOTE: this is not as efficient as it could be // but to retain compatiblity with STL interface // we cannot assume underlying implementation // has a newsize() function. return *this = Vector_Adaptor(N); } Vector_Adaptor& operator=(const T &a) { Subscript i; Subscript N = v_.size(); for (i=0; i& resize(Subscript N) { if (N == size()) return *this; Vector_Adaptor tmp(N); Subscript n = (N < size() ? N : size()); // min(N, size()); Subscript i; for (i=0; i > Region; typedef const_Region1D< Vector_Adaptor > const_Region; Region operator()(const Index1D &I) { return Region(*this, I); } Region operator()(const Subscript i1, Subscript i2) { return Region(*this, i1, i2); } const_Region operator()(const Index1D &I) const { return const_Region(*this, I); } const_Region operator()(const Subscript i1, Subscript i2) const { return const_Region(*this, i1, i2); } #endif // TNT_USE_REGIONS }; #include template std::ostream& operator<<(std::ostream &s, const Vector_Adaptor &A) { Subscript M=A.size(); s << M << endl; for (Subscript i=1; i<=M; i++) s << A(i) << endl; return s; } template std::istream& operator>>(std::istream &s, Vector_Adaptor &A) { Subscript N; s >> N; A.resize(N); for (Subscript i=1; i<=N; i++) s >> A(i); return s; } } // namespace TNT #endif geepack/inst/include/inter.h0000755000176200001440000000114714165262714015561 0ustar liggesusers#ifndef INTER_H #define INTER_H // extern "C" { #include #include // } #include "tntsupp.h" #include "geese.h" #include "famstr.h" #include "param.h" #include "geesubs.h" DMatrix asDMatrix(SEXP a); DVector asDVector(SEXP a); IVector asIVector(SEXP a); Vector asVDVector(SEXP a); SEXP asSEXP(const DMatrix &a); SEXP asSEXP(const DVector &a); SEXP asSEXP(const IVector &a); SEXP asSEXP(const Vector &a); Control asControl(SEXP con); GeeParam asGeeParam(SEXP par); GeeStr asGeeStr(SEXP geestr); Corr asCorr(SEXP cor); SEXP asSEXP(GeeParam &Par); #endif //INTER_H geepack/inst/include/tntsupp.h0000755000176200001440000002735114165262714016162 0ustar liggesusers#ifndef TNTSUPP_H #define TNTSUPP_H using namespace std; #include #include "tnt/subscript.h" #include "tnt/tnt.h" #include "tnt/vec.h" #include "tnt/fmat.h" #include "tnt/region1d.h" #include "tnt/region2d.h" #include "tnt/transv.h" #include "tnt/lu.h" namespace TNT { typedef Vector DVector; typedef Vector IVector; typedef Fortran_Matrix DMatrix; template inline T fmin(T a, T b) { return (a < b ? a : b); } template inline T fmax(T a, T b) { return (a > b ? a : b); } //typedef Region1D subDVector; //typedef Region2D subDMatrix; //matrix operation on Region2D; template Fortran_Matrix operator+(const_Region2D > &A, const_Region2D > &B) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(M==B.num_rows()); assert(N==B.num_cols()); Fortran_Matrix ans(M, N); for (Subscript i = 1; i <= M; i++) for (Subscript j = 1; j <= N; j++) ans(i, j) = A(i, j) + B(i, j); return ans; } template Fortran_Matrix operator+(const Region2D > &A, const Region2D > &B) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(M==B.num_rows()); assert(N==B.num_cols()); Fortran_Matrix ans(M, N); for (Subscript i = 1; i <= M; i++) for (Subscript j = 1; j <= N; j++) ans(i, j) = A(i, j) + B(i, j); return ans; } template Fortran_Matrix operator-(const_Region2D > &A, const_Region2D > &B) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(M==B.num_rows()); assert(N==B.num_cols()); Fortran_Matrix ans(M, N); for (Subscript i = 1; i <= M; i++) for (Subscript j = 1; j <= N; j++) ans(i, j) = A(i, j) - B(i, j); return ans; } template Fortran_Matrix operator-(const Region2D > &A, const Region2D > &B) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(M==B.num_rows()); assert(N==B.num_cols()); Fortran_Matrix ans(M, N); for (Subscript i = 1; i <= M; i++) for (Subscript j = 1; j <= N; j++) ans(i, j) = A(i, j) - B(i, j); return ans; } template Fortran_Matrix mult_element(const Region2D > &A, const Region2D > &B) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(M==B.num_rows()); assert(N==B.num_cols()); Fortran_Matrix tmp(M,N); Subscript i,j; for (i=1; i<=M; i++) for (j=1; j<=N; j++) tmp(i,j) = A(i,j) * B(i,j); return tmp; } template Fortran_Matrix transpose(const Region2D > &A) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); Fortran_Matrix S(N,M); Subscript i, j; for (i=1; i<=M; i++) for (j=1; j<=N; j++) S(j,i) = A(i,j); return S; } template inline Fortran_Matrix matmult(const Region2D > &A, const Region2D > &B) { #ifdef TNT_BOUNDS_CHECK assert(A.num_cols() == B.num_rows()); #endif Subscript M = A.num_rows(); Subscript N = A.num_cols(); Subscript K = B.num_cols(); Fortran_Matrix tmp(M,K); T sum; for (Subscript i=1; i<=M; i++) for (Subscript k=1; k<=K; k++) { sum = 0; for (Subscript j=1; j<=N; j++) sum = sum + A(i,j) * B(j,k); tmp(i,k) = sum; } return tmp; } template inline Fortran_Matrix operator*(const Region2D > &A, const Region2D > &B) { return matmult(A,B); } template inline int matmult(Fortran_Matrix& C, const Region2D >&A, const Region2D >&B) { assert(A.num_cols() == B.num_rows()); Subscript M = A.num_rows(); Subscript N = A.num_cols(); Subscript K = B.num_cols(); C.newsize(M,K); // adjust shape of C, if necessary T sum; const T* row_i; const T* col_k; for (Subscript i=1; i<=M; i++) { for (Subscript k=1; k<=K; k++) { row_i = &A(i,1); col_k = &B(1,k); sum = 0; for (Subscript j=1; j<=N; j++) { sum += *row_i * *col_k; row_i += M; col_k ++; } C(i,k) = sum; } } return 0; } template Vector matmult(const Region2D > &A, const Vector &x) { #ifdef TNT_BOUNDS_CHECK assert(A.num_cols() == x.dim()); #endif Subscript M = A.num_rows(); Subscript N = A.num_cols(); Vector tmp(M); T sum; for (Subscript i=1; i<=M; i++) { sum = 0; for (Subscript j=1; j<=N; j++) sum = sum + A(i,j) * x(j); tmp(i) = sum; } return tmp; } template inline Vector operator*(const Region2D > &A, const Vector &x) { return matmult(A,x); } template inline Fortran_Matrix operator*(const Region2D > &A, const T &x) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); Subscript MN = M*N; Fortran_Matrix res(M,N); const T* a = A.begin(); T* t = res.begin(); T* tend = res.end(); for (t=res.begin(); t < tend; t++, a++) *t = *a * x; return res; } //convert Region2D to matrix or vector template Fortran_Matrix asMat(const Region2D > &A) { Subscript m = A.num_rows(), n = A.num_cols(); Fortran_Matrix ans(m, n); for (Subscript i = 1; i <= m; i++) for (Subscript j = 1; j <= n; j++) ans(i, j) = A(i, j); return ans; } template Fortran_Matrix asMat(const_Region2D > &A) { Subscript m = A.num_rows(), n = A.num_cols(); Fortran_Matrix ans(m, n); for (Subscript i = 1; i <= m; i++) for (Subscript j = 1; j <= n; j++) ans(i, j) = A(i, j); return ans; } template Vector asVec(const Region2D > &A) { // A is 1 row or 1 col Subscript m = A.num_rows(), n = A.num_cols(); if (m == 1) { Vector ans(n); for (Subscript i = 1; i <= n; i++) ans(i) = A(1,i); return ans; } else { Vector ans(m); for (Subscript i = 1; i <= m; i++) ans(i) = A(i,1); return ans; } } template Vector asVec(const_Region2D > A) { // A is 1 row or 1 col Subscript m = A.num_rows(), n = A.num_cols(); if (m == 1) { Vector ans(n); for (Subscript i = 1; i <= n; i++) ans(i) = A(1,i); return ans; } else { Vector ans(m); for (Subscript i = 1; i <= m; i++) ans(i) = A(i,1); return ans; } } //convert vector to matrix template Fortran_Matrix asRowMat(const Vector &v) { Subscript n = v.size(); Fortran_Matrix ans(1,n); for (Subscript i = 1; i <= n; i++) ans(1,i) = v(i); return ans; } template Fortran_Matrix asColMat(const Vector &v) { Subscript n = v.size(); Fortran_Matrix ans(n,1); for (Subscript i = 1; i <= n; i++) ans(i,1) = v(i); return ans; } //scalar multiplication template inline Vector operator*(const Vector &v, const T &x) { Subscript m = v.size(); Vector ans(m); for (Subscript i = 1; i <= m; i++) ans(i) = v(i) * x; return ans; } template inline Vector operator*(const T &x, const Vector &v) { return v * x; } template inline Fortran_Matrix operator*(const T &x, const Fortran_Matrix &A) { Fortran_Matrix ans = A * x; return ans; } // utilities: template Region2D > MatSubs(Fortran_Matrix &x, const Index1D &I, const Index1D &J) { return x(I, J); } template Region2D > MatRow(Fortran_Matrix &x, int i) { int n = x.num_cols(); Index1D I(i,i), J(1,n); return x(I,J); } template Region2D > MatCol(Fortran_Matrix &x, int i) { int m = x.num_rows(); Index1D I(1,m), J(i,i); return x(I,J); } template Region2D > MatRows(Fortran_Matrix &x, const Index1D &I) { int n = x.num_cols(); Index1D J(1,n); return x(I,J); } template Region2D > MatCols(Fortran_Matrix &x, const Index1D &J) { int m = x.num_rows(); Index1D I(1,m); return x(I,J); } template Region1D > VecSubs(Vector &x, const Index1D &I) { return Region1D >(x, I); } template Vector asVec(const Region1D > &x) { Vector ans(x.dim()); for (int i = 1; i <= ans.size(); i++) ans(i) = x(i); return ans; } // transp(A) * inv(B) * C template Fortran_Matrix matmult( const Transpose_View & A, const Fortran_Matrix &B) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(B.num_rows() == N); Subscript L = B.num_cols(); Fortran_Matrix x(M,L); Subscript i, j, k; T tmp = 0; for (i=1; i<=M; i++) { for (j=1; j<=L; j++) { tmp = 0; for (k = 1; k <= N; k++) tmp += A(i,k) * B(k,j); x(i,j) = tmp; } } return x; } template Fortran_Matrix matmult( const Fortran_Matrix & A, const Transpose_View &B) { Subscript M = A.num_rows(); Subscript N = A.num_cols(); assert(B.num_rows() == N); Subscript L = B.num_cols(); Fortran_Matrix x(M,L); Subscript i, j, k; T tmp = 0; for (i=1; i<=M; i++) { for (j=1; j<=L; j++) { tmp = 0; for (k = 1; k <= N; k++) tmp += A(i,k) * B(k,j); x(i,j) = tmp; } } return x; } template inline Fortran_Matrix operator*(const Transpose_View & A, const Fortran_Matrix &B) { return matmult(A,B); } template inline Fortran_Matrix operator*(const Fortran_Matrix & A, const Transpose_View &B) { return matmult(A,B); } //crossprod template Fortran_Matrix crossprod(const Fortran_Matrix &B) { return matmult(Transpose_View >(B), B); } //outerprod template Fortran_Matrix outerprod(const Vector &v) { int n = v.size(); Fortran_Matrix ans(n,n); for (int i = 1; i <= n; i++) for (int j = 1; j <= n; j++) ans(i,j) = v(i) * v(j); return ans; } template Fortran_Matrix outerprod(const Vector &v1, const Vector &v2) { int m = v1.size(), n = v2.size(); Fortran_Matrix ans(m,n); for (int i = 1; i <= m; i++) for (int j = 1; j <= n; j++) ans(i,j) = v1(i) * v2(j); return ans; } template T fmax(const Vector & v) { T ans = v(1); for (int i = 1; i <= v.dim(); i++) if (ans < v(i)) ans = v(i); return ans; } template T fmin(const Vector & v) { T ans = v(1); for (int i = 1; i <= v.dim(); i++) if (ans > v(i)) ans = v(i); return ans; } template T fmax(const Fortran_Matrix &m) { T ans = m(1, 1); for (int i = 1; i <= m.dim(1); i++) for (int j = 1; j <= m.dim(2); j++) if (ans < m(i, j)) ans = m(i, j); return ans; } template T fmin(const Fortran_Matrix &m) { T ans = m(1, 1); for (int i = 1; i <= m.dim(1); i++) for (int j = 1; j <= m.dim(2); j++) if (ans > m(i, j)) ans = m(i, j); return ans; } template T sum(const Vector &v) { T ans = 0; for (int i = 1; i <= v.dim(); i++) ans += v(i); return ans; } template T sum(const Fortran_Matrix &m) { T ans = 0; for (int i = 1; i <= m.dim(1); i++) for (int j = 1; j <= m.dim(2); j++) ans += m(i, j); return ans; } } //namespace TNT #endif //TNTSUPP_H geepack/inst/include/geese.h0000755000176200001440000000013614165262714015525 0ustar liggesusers#ifndef GEESE_H #define GEESE_H using namespace std; using namespace TNT; #endif //GEESE_H geepack/inst/include/famstr.h0000755000176200001440000001013714165262714015733 0ustar liggesusers#ifndef FAMSTR_H #define FAMSTR_H #include "tntsupp.h" #include "geese.h" typedef double fun1(double); typedef bool fun2(double); enum links {L_0, IDENT, LOGIT, PROBIT, CLOGLOG, LOG, INVERSE, FISHERZ, LWYBC2, LWYLOG}; enum variances {V_0, GAUSSIAN, BINOMIAL, POISSON, GAMMA}; enum correlations {C_0, INDEPENDENCE, EXCHANGEABLE, AR1, UNSTRUCTURED, USERDEFINED, FIXED}; DMatrix cor_exch(const DVector &rho, const DVector &wave); DMatrix cor_rho_exch(const DVector &rho, const DVector &wave); DMatrix cor_indep(const DVector &, const DVector &wave); DMatrix cor_rho_indep(const DVector &, const DVector &); DMatrix cor_ar1(const DVector &rho, const DVector &wave); DMatrix cor_rho_ar1(const DVector &rho, const DVector &wave); DMatrix cor_unstr(const DVector &rho, const DVector &wave); DMatrix cor_rho_unstr(const DVector &rho, const DVector &wave); DMatrix cor_fixed(const DVector &, const DVector &wave); //get cor matrix DMatrix cor_rho_fixed(const DVector &, const DVector &); //derivative class Corr{ public: typedef DMatrix matfun(const DVector &, const DVector&); typedef DMatrix cor_rho_fun(const DVector &, const DVector&); protected: int _corst, _nparam, _maxwave; matfun *_mat; cor_rho_fun *_cor_rho; void init(matfun *mat, cor_rho_fun *cor_rho) { _mat = mat; _cor_rho = cor_rho; } public: Corr(int corst, int maxwave); ~Corr() {} DMatrix mat(DVector &rho, DVector &wave) { return _mat(rho, wave); } DMatrix cor_rho(DVector &rho, DVector &wave) { return _cor_rho(rho, wave); } int nparam(){return _nparam;} int corst() {return _corst; } }; class Link{ protected: fun1 *_linkfun, *_linkinv, *_mu_eta; void init(fun1* linkfun, fun1* linkinv, fun1* mu_eta) { _linkfun = linkfun; _linkinv = linkinv; _mu_eta = mu_eta; } public: //Link(int link); //Link() {int link = IDENT; Link(link); } Link(int link = IDENT); Link(fun1* linkfun, fun1* linkinv, fun1* mu_eta); ~Link() {} double linkfun(double mu) {return _linkfun(mu);} double linkinv(double eta) {return _linkinv(eta);} double mu_eta(double eta) {return _mu_eta(eta);} }; class Variance{ protected: fun1 *_v, *_v_mu; fun2 *_validmu; void init(fun1* v, fun1* v_mu, fun2 validmu) { _v = v; _v_mu = v_mu; _validmu = validmu; } public: Variance(fun1* v, fun1* v_mu, fun2* validmu) { init(v, v_mu, validmu); } //Variance(int var); //Variance() {int var = GAUSSIAN; Variance(var);} Variance(int var = GAUSSIAN); ~Variance() {} double v(double mu) {return _v(mu);} double v_mu(double mu) {return _v_mu(mu);} bool validmu(double mu) {return _validmu(mu);} }; /* static Link Ident(1), Logit(2), Probit(3), Cloglog(4), Log(5), Inverse(6), Fisherz(7); static Variance Gaussian(1), Binomial(2), Poisson(3), Gamma(4); static Link LINK[] = {Ident, Logit, Probit, Cloglog, Log, Inverse, Fisherz}; static Variance VARIANCE[] = {Gaussian, Binomial, Poisson, Gamma}; */ class GeeStr{ Vector MeanLink; Vector V; Vector ScaleLink; Link CorrLink; int ScaleFix_; public: GeeStr(int n, Vector meanlink, Vector v, Vector scalelink, int corrlink, int scalefix); ~GeeStr() {} int ScaleFix() {return ScaleFix_;} double MeanLinkfun(double mu, int wave) { return MeanLink(wave).linkfun(mu); } double MeanLinkinv(double eta, int wave) { return MeanLink(wave).linkinv(eta); } double MeanMu_Eta(double eta, int wave) { return MeanLink(wave).mu_eta(eta); } DVector MeanLinkfun(const DVector &Mu, const IVector &Wave); DVector MeanLinkinv(const DVector &Eta, const IVector &Wave); DVector MeanMu_eta(const DVector &Eta, const IVector &Wave); DVector ScaleLinkfun(const DVector &Mu, const IVector &Wave); DVector ScaleLinkinv(const DVector &Eta, const IVector &Wave); DVector ScaleMu_eta(const DVector &Eta, const IVector &Wave); DVector CorrLinkfun(const DVector &Mu); DVector CorrLinkinv(const DVector &Eta); DVector CorrMu_eta(const DVector &Eta); DVector v(const DVector &Mu, const IVector &Wave); DVector v_mu(const DVector &Mu, const IVector &Wave); bool validMu(const DVector &Mu, const IVector &Wave); }; #endif //FAMSTR_H geepack/inst/include/ordgee.h0000755000176200001440000000645314165262714015712 0ustar liggesusers#ifndef ORDGEE_H #define ORDGEE_H //#include "tnt/region1d.h" #include "tntsupp.h" #include "geese.h" // extern "C"{ #include #include #include // } #include "famstr.h" #include "param.h" #include "inter.h" #include "utils.h" #include "geesubs.h" double odds2p11(double psi, double mu1, double mu2); DMatrix odds2p11(DVector &Psi, DVector &Mu1, DVector &Mu2); double p11_odds(double psi, double mu1, double mu2); DVector p11_mu(double psi, double mu1, double mu2); DVector p11_odds(DVector &Psi, DVector &Mu1, DVector &Mu2); DMatrix Vijj(DVector &Mu, bool rev); DMatrix Vijk(DVector &Mu1, DVector &Mu2, DVector &Psi); DMatrix getU3_Beta(DVector &Mu1, DVector &Mu2, DVector &Psi, DMatrix &D1, DMatrix &D2, DVector &PR1, DVector &PR2); DMatrix ord2V1(DVector &Mu, DVector &Psi, int clusz, bool rev); DMatrix Mu2V1(DVector &Mu, int clusz, bool rev); void ord_prep_beta(DVector &Y, DMatrix &X, DVector &Offset, DMatrix &Z, DVector &Ooffset, Index1D &I, Index1D &J, int clusz, int c, bool rev, IVector &LinkWave, GeeParam &par, GeeStr &geestr, Corr &cor, //output DMatrix &Di, DVector &PRi, DMatrix &Vi); double update_beta(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset, DVector &W, IVector &LinkWave, //DVector &CorP, DMatrix &Z, IVector &Clusz, int c, bool rev, //IVector &ZcorSize, IVector &Jack, GeeParam &par, GeeStr &geestr, Corr &cor); DVector kronecker(const DVector &v1, const DVector &v2); DVector vec(const DMatrix &m); DMatrix ESSTijk(DVector &Mu1, DVector &Mu2, DMatrix &P11, int c1, int c3, bool rev); DMatrix ESST(DVector &Mu1, DVector &Mu2, DMatrix &P11, bool rev); void ord_prep_alpha(DVector &PR1, DVector &PR2, //DMatrix &V, DVector &Mu1, DVector &Mu2, //c^2 x 1 c x 1 c x 1 DMatrix &Z, DVector &Ooffset, bool rev, GeeParam &par, GeeStr &geestr, //output DVector &U2, DMatrix &V2, DMatrix &D2); double update_alpha(DVector &PR, DVector &Mu, DVector &W, DMatrix &Z, DVector &Ooffset, IVector &Clusz, int c, bool rev, GeeParam &par, GeeStr &geestr, Corr &cor); void ordgee_est(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset, DVector &W, IVector &LinkWave, DMatrix &Z, IVector &Clusz, int c, bool rev, GeeStr &geestr, Corr &cor, GeeParam &par, Control &con); void HiandGi(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset, IVector &LinkWave, DMatrix &Z, int s1, int c, bool rev, Index1D &I, Index1D &J, GeeParam &par, GeeStr &geestr, Corr &cor, //output Hess &Hi, Grad &Gi); void HnandGis(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset, IVector &LinkWave, DMatrix &Z, IVector &Clusz, int c, bool rev, GeeParam &par, GeeStr &geestr, Corr &cor, IVector &Scur, Hess &Hn, Vector &Gis); void HnandGis(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset, IVector &LinkWave, DMatrix &Z, IVector &Clusz, int c, bool rev, GeeParam &par, GeeStr &geestr, Corr &cor, Hess &Hn, Vector &Gis); extern "C" { SEXP ordgee_rap(SEXP y, SEXP x, SEXP offset, SEXP doffset, SEXP w, SEXP linkwave, SEXP z, SEXP clusz, SEXP ncat, SEXP rev, SEXP geestr, SEXP cor, SEXP par, SEXP con); } #endif //ORDGEE_H geepack/inst/CITATION0000755000176200001440000000326714165262714014006 0ustar liggesuserscitHeader("To cite geepack in publications use:") citEntry(entry="Article", title = "The R Package geepack for Generalized Estimating Equations", author = personList(as.person("Ulrich Halekoh"), as.person("Søren Højsgaard"), as.person("Jun Yan")), year = 2006, journal = "Journal of Statistical Software", volume = "15/2", pages = "1--11", textVersion = paste("Højsgaard, S., Halekoh, U. & Yan J. (2006)", "The R Package geepack for Generalized Estimating Equations", "Journal of Statistical Software, 15, 2, pp1--11") ) citEntry(entry="Article", title = "Estimating Equations for Association Structures", author = personList(as.person("Jun Yan"), as.person("Jason P. Fine")), year = "2004", journal = "Statistics in Medicine", volume = "23", pages = "859--880", textVersion = paste("Yan, J. & Fine, J.P. (2004)", "Estimating Equations for Association Structures", "Statistics in Medicine, 23, pp859--880.") ) citEntry(entry="Article", title = "geepack: Yet Another Package for Generalized Estimating Equations", author = personList(as.person("Jun Yan")), year = "2002", journal = "R-News", volume = "2/3", pages = "12--14", textVersion = paste("Yan, J (2002)", "geepack: Yet Another Package for Generalized Estimating Equations", "R-News, 2/3, pp12-14.") )