mets/0000755000176200001440000000000013623150474011227 5ustar liggesusersmets/NAMESPACE0000644000176200001440000002405513623061405012447 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(bootstrap,timemets) S3method(coef,biprobit) S3method(coef,cor) S3method(coef,mets.twostage) S3method(coef,phreg) S3method(coef,phreg.par) S3method(coef,randomcif) S3method(coef,randomcifrv) S3method(coef,survd) S3method(coef,survival.twostage.fullse) S3method(coef,timemets) S3method(coef,twinlm) S3method(coef,twinlm.strata) S3method(compare,twinlm) S3method(concordance,cor) S3method(gof,phreg) S3method(iid,binreg) S3method(iid,phreg) S3method(iid,phreg.par) S3method(iid,twinlm) S3method(lifetable,formula) S3method(lifetable,matrix) S3method(lines,phreg) S3method(logLik,biprobit) S3method(logLik,phreg.par) S3method(logLik,twinlm) S3method(logLik,twinlm.strata) S3method(model.frame,bptwin) S3method(model.frame,phreg.par) S3method(model.frame,twinlm) S3method(plot,BiRecurrent) S3method(plot,bptwin) S3method(plot,casewise) S3method(plot,claytonoakes) S3method(plot,covariance.recurrent) S3method(plot,cumh) S3method(plot,eventpois) S3method(plot,gof.phreg) S3method(plot,mets.twostage) S3method(plot,phreg) S3method(plot,predictphreg) S3method(plot,timemets) S3method(plot,twinlm) S3method(plot,twinlm.strata) S3method(predict,binreg) S3method(predict,biprobit) S3method(predict,mets.twostage) S3method(predict,phreg) S3method(predict,phreg.par) S3method(print,Print) S3method(print,binreg) S3method(print,biprobit) S3method(print,casewise) S3method(print,claytonoakes) S3method(print,cor) S3method(print,cumh) S3method(print,daggregate) S3method(print,do.twinlm.strata) S3method(print,dreg) S3method(print,dtable) S3method(print,gof.phreg) S3method(print,mets.twostage) S3method(print,pc.twostage) S3method(print,phreg) S3method(print,phreg.par) S3method(print,randomcif) S3method(print,randomcifrv) S3method(print,summary.biprobit) S3method(print,summary.bptwin) S3method(print,summary.claytonoakes) S3method(print,summary.cor) S3method(print,summary.pc.twostage) S3method(print,summary.phreg) S3method(print,summary.twinlm) S3method(print,summary.twinlm.group) S3method(print,survd) S3method(print,survival.twostage.fullse) S3method(print,timemets) S3method(print,twinlm) S3method(print,twinlm.strata) S3method(residuals,phreg) S3method(score,biprobit) S3method(score,twinlm) S3method(score,twinlm.strata) S3method(sim,cox) S3method(simulate,bptwin) S3method(simulate,cox) S3method(summary,binreg) S3method(summary,biprobit) S3method(summary,bptwin) S3method(summary,casewise) S3method(summary,claytonoakes) S3method(summary,cor) S3method(summary,cumh) S3method(summary,dreg) S3method(summary,gof.phreg) S3method(summary,mets.twostage) S3method(summary,pc.twostage) S3method(summary,phreg) S3method(summary,randomcif) S3method(summary,randomcifrv) S3method(summary,survd) S3method(summary,survival.twostage.fullse) S3method(summary,timemets) S3method(summary,twinlm) S3method(summary,twinlm.strata) S3method(twostage,aalen) S3method(twostage,cox.aalen) S3method(twostage,coxph) S3method(twostage,phreg) S3method(vcov,binreg) S3method(vcov,biprobit) S3method(vcov,phreg) S3method(vcov,phreg.par) S3method(vcov,survd) S3method(vcov,timemets) S3method(vcov,twinlm) export("dby2<-") export("dby<-") export("dcut<-") export("ddrop<-") export("dfactor<-") export("dkeep<-") export("dlag<-") export("dnames<-") export("dnumeric<-") export("drelev<-") export("drelevel<-") export("drename<-") export("drm<-") export("dsort<-") export("dspline<-") export("dtrans<-") export("dtransform<-") export(Bootcovariancerecurrence) export(BootcovariancerecurrenceS) export(Bootphreg) export(CCbinomial.twostage) export(ClaytonOakes) export(Dbvn) export(EVaddGam) export(FastCoxPLstrataR) export(Grandom.cif) export(Interval) export(LinSpline) export(aalenfrailty) export(ace.family.design) export(addCums) export(alpha2kendall) export(alpha2spear) export(ascertained.pairs) export(back2timereg) export(basecumhaz) export(basehazplot.phreg) export(bicomprisk) export(binomial.twostage) export(binomial.twostage.time) export(binreg) export(biprobit) export(biprobit.time) export(biprobit.vector) export(blocksample) export(bplot) export(bptwin) export(bptwin.time) export(casewise) export(casewise.bin) export(casewise.test) export(cif) export(cifreg) export(cluster.index) export(coarse.clust) export(coefmat) export(concordanceCor) export(concordanceTwinACE) export(concordanceTwostage) export(cor.cif) export(corsim.prostate) export(corsim.prostate.random) export(count.history) export(countID) export(covIntH1dM1IntH2dM2) export(covarianceRecurrent) export(covarianceRecurrentS) export(covfr) export(covfridstrata) export(covfridstrataCov) export(cumContr) export(cumsumidstratasum) export(cumsumidstratasumCov) export(cumsumstrata) export(cumsumstratasum) export(dInterval) export(daggr) export(daggregate) export(dby) export(dby2) export(dbyr) export(dcor) export(dcount) export(dcut) export(ddrop) export(deval) export(deval2) export(dfactor) export(dhead) export(divide.conquer) export(divide.conquer.timereg) export(dkeep) export(dlag) export(dlev) export(dlevel) export(dlevels) export(dlist) export(dmean) export(dmeansd) export(dmvn) export(dnames) export(dnumeric) export(dprint) export(dquantile) export(dreg) export(drelev) export(drelevel) export(drename) export(dreshape) export(drm) export(dsample) export(dscalar) export(dsd) export(dsort) export(dsort2) export(dspline) export(dstr) export(dsubset) export(dsum) export(dsummary) export(dtab) export(dtable) export(dtail) export(dtrans) export(dtransform) export(dunique) export(easy.binomial.twostage) export(easy.survival.twostage) export(eventpois) export(extendCums) export(familycluster.index) export(familyclusterWithProbands.index) export(fast.approx) export(fast.cluster) export(fast.pattern) export(fast.reshape) export(faster.reshape) export(folds) export(force.same.cens) export(gofG.phreg) export(gofM.phreg) export(gofZ.phreg) export(grouptable) export(haplo.surv.discrete) export(ilap) export(interval.logitsurv.discrete) export(ipw) export(ipw2) export(jumptimes) export(kendall.ClaytonOakes.twin.ace) export(kendall.normal.twin.ace) export(km) export(lifecourse) export(lifetable) export(logitSurv) export(loglikMVN) export(make.pairwise.design) export(make.pairwise.design.competing) export(matdoubleindex) export(matplot.mets.twostage) export(mdi) export(mets.options) export(mlogit) export(mystrata) export(nonparcuminc) export(npc) export(object.defined) export(or.cif) export(or2prob) export(p11.binomial.twostage.RV) export(pairRisk) export(pbvn) export(pcif) export(phreg) export(phreg.par) export(phregR) export(piecewise.data) export(piecewise.twostage) export(plack.cif) export(plack.cif2) export(plotConfRegion) export(plotSurvd) export(plotcr) export(pmvn) export(pred.cif.boot) export(predictPairPlack) export(predictSurvd) export(predictlogitSurvd) export(prob.exceed.recurrent) export(prob.exceedBiRecurrent) export(prob.exceedBiRecurrentStrata) export(prob.exceedRecurrent) export(prob.exceedRecurrentStrata) export(procform) export(procform3) export(procformdata) export(random.cif) export(randomDes) export(readPhreg) export(recmarg) export(recurrentMarginal) export(recurrentMarginalIPCW) export(recurrentMarginalgam) export(revcumsum) export(revcumsumidstratasum) export(revcumsumidstratasumCov) export(revcumsumstrata) export(revcumsumstratasum) export(rmvn) export(robust.basehaz.phreg) export(robust.phreg) export(rpch) export(rr.cif) export(scoreMVN) export(showfitsim) export(simAalenFrailty) export(simBinFam) export(simBinFam2) export(simBinPlack) export(simClaytonOakes) export(simClaytonOakes.family.ace) export(simClaytonOakes.twin.ace) export(simClaytonOakesLam) export(simClaytonOakesWei) export(simCompete.simple) export(simCompete.twin.ace) export(simCox) export(simFrailty.simple) export(simMultistate) export(simRecurrent) export(simRecurrentGamma) export(simRecurrentII) export(simRecurrentTS) export(simSurvFam) export(simTTP) export(simbinClaytonOakes.family.ace) export(simbinClaytonOakes.pairs) export(simbinClaytonOakes.twin.ace) export(simlogitSurvd) export(simnordic) export(simnordic.random) export(slope.process) export(squareintHdM) export(sumstrata) export(surv.boxarea) export(survival.iterative) export(survival.twostage) export(survival.twostage.fullse) export(tailstrata) export(test.conc) export(tetrachoric) export(tie.breaker) export(twin.clustertrunc) export(twin.polygen.design) export(twinlm) export(twinlm.strata) export(twinlm.time) export(twinsim) export(twostageMLE) import(Rcpp) import(mvtnorm) import(splines) import(stats) import(timereg) importFrom(grDevices,dev.interactive) importFrom(grDevices,dev.list) importFrom(grDevices,devAskNewPage) importFrom(graphics,abline) importFrom(graphics,legend) importFrom(graphics,lines) importFrom(graphics,matlines) importFrom(graphics,matplot) importFrom(graphics,par) importFrom(graphics,plot) importFrom(graphics,points) importFrom(graphics,polygon) importFrom(graphics,title) importFrom(lava,"%++%") importFrom(lava,"%ni%") importFrom(lava,"addvar<-") importFrom(lava,"constrain<-") importFrom(lava,"covariance<-") importFrom(lava,"distribution<-") importFrom(lava,"intercept<-") importFrom(lava,"kill<-") importFrom(lava,"latent<-") importFrom(lava,"parameter<-") importFrom(lava,"regression<-") importFrom(lava,Col) importFrom(lava,Expand) importFrom(lava,Inverse) importFrom(lava,Model) importFrom(lava,blockdiag) importFrom(lava,bootstrap) importFrom(lava,cancel) importFrom(lava,compare) importFrom(lava,confband) importFrom(lava,constraints) importFrom(lava,covariance) importFrom(lava,coxWeibull.lvm) importFrom(lava,devcoords) importFrom(lava,endogenous) importFrom(lava,estimate) importFrom(lava,eventTime) importFrom(lava,getoutcome) importFrom(lava,gof) importFrom(lava,iid) importFrom(lava,information) importFrom(lava,latent) importFrom(lava,lava.options) importFrom(lava,lvm) importFrom(lava,multigroup) importFrom(lava,pars) importFrom(lava,regression) importFrom(lava,revdiag) importFrom(lava,score) importFrom(lava,sim) importFrom(lava,trim) importFrom(lava,twostage) importFrom(survival,Surv) importFrom(survival,concordance) importFrom(survival,is.Surv) importFrom(utils,capture.output) importFrom(utils,getS3method) importFrom(utils,glob2rx) importFrom(utils,head) importFrom(utils,tail) useDynLib(mets, .registration=TRUE) mets/demo/0000755000176200001440000000000013623061405012146 5ustar liggesusersmets/demo/models.R0000644000176200001440000000052613623061405013557 0ustar liggesusersmessage("Bivariate Probit models") example(biprobit) message("Polygenic models") example(bptwin) example(twinlm) message("Clayton-Oakes, Two-stage") example(ClaytonOakes) example(twostage) message("Pairwise-Odds-Ratio") example(binomial.twostage) example(easy.binomial.twostage) message("Bivariate competing risks") example(bicomprisk) mets/demo/tools.R0000644000176200001440000000013113623061405013424 0ustar liggesusers example(fast.reshape) example(fast.approx) example(fast.pattern) example(lifetable) mets/demo/mets.R0000644000176200001440000000004713623061405013242 0ustar liggesusersdemo(mets:::models) demo(mets:::tools) mets/demo/00Index0000644000176200001440000000005413623061405013277 0ustar liggesusersmets All demos models Models tools Tools mets/data/0000755000176200001440000000000013623061756012144 5ustar liggesusersmets/data/datalist0000644000176200001440000000023213623061753013666 0ustar liggesusersbase1cumhaz base44cumhaz base4cumhaz dermalridges dermalridgesMZ drcumhaz hapfreqs haploX hHaplos: ghaplos mena migr multcif np prt ttpd twinbmi twinstut mets/data/multcif.txt.xz0000644000176200001440000002664013623061754015016 0ustar liggesusers7zXZi"6!X-a] &wNpt` L6b<8:ɽ~MMaGxm5Dha&ox񵖯c1^s_3sߖE/ <͙PfKnJnP5AƐ:3U-sd~B6cu Gn&PIL%"yHKHR/-T󿡮聙 KqUBѳBo??EzDE mbc[ tW{iz$3'j-Sg7ӕgĈKB j0-ŧ h=nE|X[Mj be; JVs俭QQUA}jIbᚄ#6O2^ӷH*EVU> fnhS< _-{ K (^YOY\R٦'3Tb⤹!%k4s^e6W)]hk;cf/L+2z/G"u]3AJiwh+C&~y@?slBZnYFFc[Kbn*1]Z6YPkkrNCNJN)<Ι w5M|Vܷ?0f{Qñ'o Z$_<,|/`HdDos6&O%-MàxB{wkf0v: ԛc ,(0\E8+^⬭ yP(&|9Nx>ߔnvLk [ǫ""aAΛ[@ i^)W¿OgbX ӑwS j*KyeuYZ dQ+eIV+ {+׾/2x nfg>㎻ܷ cLeT KCY 3"ZvqMх4}u/Uz*h|/L ]ȇ )Bk$F]׾Yvr?e^ a)Ql!95n|fAylr*G'Mh/R{yuOA߱X @KEoՁ6Ybg=TXb0f*Im9JSC};Gz'VC"% {Jt/w<ٿ:$Dȑ|;![U{$CJ-xAH -݇.AHDAղoq4,ɋ Fտ2 Vp^$D[$C)*XPGE+wbGR"z֒xmy_mvEH-8xJ3Z. ^B*HFsE<->?e~9^Ri-tmC|<ېsNvnSCfh|[7n4cA"͖avI9O6H-ed'QaO-lUABr ϭ~0]x%/CRQ&Ұ_q*^&ׁ.`* _9r8 ُ+ˡ^-ID@S[Lyo0a"hZCҠ4vb,Zx;Μ5l bul#फUmNDt )M%d{k4~_b.H_iޚQ\ w]u4;zLO`Z"1UF>w_&Ȏz&hD&ǝ1s'1=8D fWiT2޶H[I3 A`w+-˺.|O3[:>e1 I']d:z [я2gDa(]81k>mT|$ }ܱ fnajR+KV/<+lL3C5 D_HxF,ȗ5`7қKMXڥ2!=P|%yVj )ܯ{6KDr>7ЯcQq7@'P{%rfO،Ǫx3^xR085=>q\g4MNyFd7)%=CVȇ}lZ,kJvyY4;dԄ Qgkug]Da"mB6 ūmKdx|elŕuwLߎ_l]71pkcBsFEw"@hOA)$T$Zd'sHm{ gUfaf%MK*D7pl~9HYӄ̄gvkK+[]*$moV""P֍?0`F;XIs>J4@#Wrxw)T-nS:Nn{O!A(*Vo M0gʅaWGǢP.M]p/y.0ǿ-fڕnQM"k BTF;9X%kX;pr{>@g O9MэqnK2DX0;%sW8j5_5e݁l(DE: E쒷!/xYG =!Ȟ\Nil)JC8 *jEMvr4[ZzLA k.m]6DKp5.k7fKR8#SfZK{оp8y+Y6 .0=/J0Zy: MC%,' D7P XM9SI !jILqy$# Z *H>BGh槤.R3d ىMrbpӢ! b(v $E|3X$·#&vr@Ati -ߩP`9>HA<R0'es66ʲw"9D;^cc҄yJh7 jyny/i^ʾ5qeet g?~I [ 췭@JܧvIh_c7z{#Qۡ.P؈z2N Ý˝B~?mlɴRvEZx#+>1CG,p<@Q`fŜ軸EF#p]h Eg2#Gc=@>잠w.&ugݣ3,}ˏѨXJE;t(E7U4YmjPi^ ,dԼ&V}=+D=QR٦'2S!y&eUڐQWlk;[`+AAgNecVģ3 .%nt,gH',FY'XU9g5Q}v F;2f|u/6Ƽah6:f2*%7ЫHp\ʞUŸ)$0R *.C ,jM^/h V}L ,"[E s'vS|}WZnr1e1yi]1B"M].@Mėmrm]2D3|0Fg7$Ow/>m]_SgCv*R3p/_Ov>7ş(q^ԙw.{#$QˠŃ3z?-GӰ^{3ehKa/2ZլuB#ļOh]G*ܰ~Mci)n6/fpMVm}a|{IYKM7=1 #NYʜ@ʜ0dJC^xhl{ZD;?H;݂wZ?誳2\Iv] K%AK[1"yo;@elpH$u[ou1>~_GEb0i0BPھb zU'485n|{38.I7շ|j0WsE416܃ٲ7|xchfuR2[eEo}߿#~s0<=i²?DQMhWr}ywDHYC) jX#8&ǔ]Y5-LeԜEu.0ڤC8Lg۞RVa(?:Hj8k׋ C)7ouSm𫭂Y[l?9PMwMe+K9HCa&" IyBh0oxk- + *}㌢oiäG+džT+w#\`:\t!=^tѣo353JZ+&/4GΏ)4M:r$'z4󕪖Lo.kClo-Ud8BP`s%mcCR6Lg,`&>>xUtW p*=6FTVdR7{-h6seV 4"?v ]у|x/tP4?`VpGtK6AgM(-z]klzrD^"`RNBhԁ&W#E?ܽIÄ"&j1T@6%~Z+p5"aQG+ ޞٶ8㪖y,1? aL4Dn<+FO\-+&+ؐ^'"" DK߹A#(5adN%)Cv#ރу1B:oEUÝV6X͘ Se0 O˴9@iҷWi0SG %%s\urs!)@n"j"A2>Hvv_C|ں-"V:kZXԉ=WN-$d$1y(!`d4bd{y|^:ZQ܏Ѽڤ^w209rVP0؀U++C j=?׊dmeUu8:9m[ryap3syH,ȭ@3'&_(TZOCAV pq:@00]Urֵ73{ӝXtgyX'|3OF;2V2uF' ek!WdyCM&l}F$wQ5-{/aA.:ҊPl`89^ḆuMg; ;..l`.r'xrB::R+7I9pA_QVm/ ~U0r[ pUN#yCLd1Uϰ)?ju _9JO XTpEF} {xqӚV8g>:T) (xufVˎ~}nRDݩp'}{Ėmeܷ $R1G:B˲Mt uotܝuN<3Uǝk ,>PT2 -'3؁Haէ%L)P:ԥBӴF % gk2Qj'ٔO7Nb{v*%c*?yV5}Ӻ䣶؏\|N @*"kL=w_;R**-g$| i 5a0F!U(JvX>Pu&߿~r ꓘ=֦F8{12tj1eC&k|b엔pj v8?ʻ0h_qe`VF׾+6 ;MIdU0Q%)As{˧tM}wRE >=^={ ȒyWtsj\'HmFJY؁ftQŏ/sGmlkv+RzgSR2 `I#غH4Prߗ1#Y4Yi4?Ҝ WقPЃi/n W UiaC.Ïe>FESϒ\*Oҿ#ƶHa1E`hª U>0{@gucj=}"Q\\J9GȆD TTL%ԛg"줙T7 VRU<+r旜!;ܪR4ef}$ I 1z}2En8z"%(AZ!Ʋ͋:iTsRuOڰFmG Hbatl&$MڒP-w>~-rbV7t +)vQ!^D|@|&D,2yPÃMȮ-+i3P o¡_=b9=ρuzIz],:5Ue&ցey,gA " 2P 6 -AÙ"pTb7Đ4<&ϋpn)DUWG*Eﱂx?`3ͬ<O+8ۮ`l f2o\R%"r"ۓSg3Eu,Խ%U(IjIIrJft-YgZ U{zȚV4FRrӆfxVGALmT!k0?،AǤtQYןC FXܗK1a\ bƺg%94~ڂ7}TWXZvIv05iŃՃa~%e|UbP-ʞ;_+X\amoTIԚ`%EG?Sͽr='Ht?ړ ԟs*Ģ|FgjcX2[PJ (_&OJ0ۉ8} BxO|HEEӣ^95œp,@R_öh[R"T$3qrαMZ5z>0 YZmets/data/dermalridges.rda0000644000176200001440000000226013623061756015276 0ustar liggesusers}SIГ*;NAЃx^VIh" Rzg~rg_N=SٝA0($R1oX\_6CIj=Zj_޶RY jh~h漦YF٘fIդ5 iS%p25 h\ϳ`gWO0$H 04X< "xMhZ 8=s=~ 2{z3AZpN d5U f8^<89aT&~)n&iNj[ksm-x2^2Fr},X8o' PmׇD~gf|g֋A۽۸6Q6ڂ3I|Iv[郊v|wշ(eQ{˘LZ*L %KK"Z4)RʤTMKR@ oui)e"2M˷M۩Qn'xKiR3wVꏶJהR(-Nˤi[~{eͣ;xvϚgm vӖvgh71/ؤE&1^4 "f}1j/M |9Q {ij(EGw~wW\~hE$f;~zq$lqa| }N|>/^ t =7G C9#aJN z z =^B1[>h zz:`蠡C^3tn舡7 M:j蘡N4*ARvT5"4kVEh`*BQ`R`SXW_:s>V9s'>w=wTx}uGcWת}c~m%P,WK^FQZpYrcj(_LU~Q6H%8ܨ~ U7?0[k[/Sl}[+wTgTͿ8mets/data/migr.txt.xz0000644000176200001440000003144013623061754014303 0ustar liggesusers7zXZi"6!X7w2] "'Hd@ǟ *&Iƈ?T]b46jy v/OI]:H#jv{:t9? FMt~e %p?J5IAx  <؊%'7QHk?bB ]}`^Nd%NCNb Qc0шa<#0m49ﷱwlPB5-P>ւ;6zG.ABPij>Ae6elY6{ q΢,Uː#,O!J9MW=0hA~?NDжBHlbYy]$2_iW.~%L4iu\vKi+Cz1*G\U؝QJw|\]zy U+z sO e' fs ΁gR kԺ-ĠNUTNX;{)2ڕ6 Wsq?βڬcb@erVnFt>Dh=$ yI{5ŠmLba¬>hlT+ݥRϠ C*~ӺwuW ?|^Lz'0{JһnSZ1eT&2$G{IwϣQt@9aHgtފ:FSs7gN|S˝f!#%={N(+J1M H"Y>eOsU.v& jrų6קI ݛ%-71+m;tGyIYlWy]U- _ ֏9P$gfq}ԑH,+$ۤQ?">zKn}ݳL17{AQT"}.LiE;[D#Q]M2U\Y2)sՆn ѻ`l@9ĭyRSn2lpp5O]\i&)fʚu""ڏ45(T1 )"۷ګX^.5RQ L_39sʞ;̷\oy/0A>Um0<z{GuL,֘/Xz 嗆-aWCwDa+U(goZ(L/Pfc+/,L{W^i ҟNuK5vy}vhgeIfHpUGz+.tYHFvb*ك18&fArW+pЈpz<|0)w/Uߋ,!Nj>ꄞqK\s]:}ϬE=rmD#ҽAAh8:>u]%戲d* ȴf5pO/qE&D-9r+`Ӯ_4)Dž'3 >z4Nі5J_=vwG?YSa!,X^Qd`A)ɢ IL5X p; / ßt&jk)FMljVsmMrE\%2k; c+&'S/g*vENO0LGNmf-,9wMoLP#0ۉIg|lO g2Hk{NNLM?腡6I=GTyTGvgD`7p%.HSC)SVibTp`/7Xbq0)BvKcqd"(ky1(=_ƌ?.1 Xa,>hdO&''VI<}n +h"h)^~-7ڽcP)_&9mM5Y lӛվDHɬ_L&9ѲV =})mCoMϬPC; #zz*5=6_쨰a!KuCynC -S+ Ӥ(="u!$Խas5O[١%y.ii1&r*seILc!\~ F7kEp4wWnb_Jnk0Ŭ(~,#*( S3XyI>6l(>~JXQW}MQERDc&广 toQ00&Biʐ qhtfMj1ȹY1edZE`-.|d=y]ӥgeMi/A}U=~~!+ڝO+?1Qֿq>P(+Kk z=_I3zה! E3̻-[=(T?τ(QJpvK9`e$*i 5E8dwW`ojhTgmjH${_Nf"%DQ NL ?fO5JB')>MefOAfD{&}8c)i_FMԋ-h\5S"X@ZUxS~^I`_: g72 'AyXmk~hz v*/;z}"}\éSxIڮUr!NtjЁ=o}R]ź75pU]uN_pφm0!Z-{ 1Άek_OƀIks%r X ȕ=~sEz  <V{v>X?S385KtW2fx@R:ʙ 7;'Љ?M: %p |ZHA21Z^v Pšg(AFyDjIXãM2 rTlg AF {:!I.q(/fP7ˑ;zwЙ+675&+H&LM^(YnisSyOrU.jyhvRWx݁7"7d\F0VpZZ! PXtG?< l' BGIԪ '.|Sh'x @ȜAw N^K I~{mi"j4-r'UP4xuV}kCLGںU 7 M%.{JV5B]* Y|wfKCHDR(ჀٽK%2Pam=pw&YuBiu7`oXB xcA v3D?|v@iaNEw Ü#]ΛNF%gqwޞew p[r >u]FOU8*>un+[`wyՎ <`Jk:HФFJB51d/O{hk׹Qك+qњaY"[ "_0HoL 9(dU &&q5ڑ\^ՠs+wp>xc Xd.J^妭c--bfsջe >-5Vh-Uh_wٞiAcQP&mթ=\uORm 5[q ':J\靍"|NB:q"Qf:M:>^FU.B`9~fUl(R]{̴0'~e2#6lxpx0tn߆PKj\4a ^H-" -,ȓGMaf4]|A? KY=(v`h_tj^:f)6e :y3i[@3Adq0gKcƭ)A(w'Lmmip5 @ʃ(_:AXkgE_ 6 2U 6@:qf{W<8녌a)|E_ #=`&{ˡI%gd]f@fOVeiX[٬vOC)+b^ƼY#/]I= 2KJrkKbc ?Sje)bw/Y:#wPid2ͣ6'sT۱\Uz 3ºGkg lj;'_c.Wx0nRyr-]{Ur3!p\^itϿWn ܺZqD5O,v/^!&HsHZK .9 ~ӕ #Ɯ2ޑwΜoU[ɌNQ@On_Q&vX^}'*~@)R]6[M;i#urе*AJSY$S"ѱ!|QTc^⳩Вx!YǼ/_h pSmZRwz|,%%Y̞v/jmCa w@trQO2o tLϗEӇ)Lt; H̑"'#}G5 X OUl d`pԣzd?4M?~:^i뽓K"ξi:Tߑ `VVܛ&ۺa5odb0ngNM|&%NYf 0! X"%D ?s -@9!ҹU9p9VISW'KD(eg GN\@lA£a#[,EF CԞ_YU^ XW!#{{6L8 qw𝛥v p/ ~_Ct8y](Vg=4BI `'$s2^4Hp*eu0֛nFcɵ'Ϳ.p=N,^a 7R 7"M & 5_5&)n5WK5T>ǒmTa|g[\ty/ C.I]X绮*8lM}?-O_0{8ptxVᅑ'ao.(_s4ڭP4uJ!ʄBCpR&[.Vpe65 puK-ޡ;` ЃOI)pcAyW~n$i-qq[-~Š}L?XۮSࡪf`n7D֗oRLڈUAՠquܕHU t2K,KMf ֲ i$-5Wy ,N-uZJX EReÓ?ׂ=/GY7_71A7LEcH\ pV7_X/#ٌQ'`Px!E'l487ˋ^}2f)jyIv" znOL}-@R_6 \@]ZZnT4 Z e$_iItD2x,6-Mi'uK3Bq2܍ބ 19x0 Fm/ex_'ל7BMJhUf>]{*Y>ȋAG*\1p@<*܊9Ie#uyv.-D+1(#*3[;%|A@ˇ^w#/#oI}Bt);)De@]kCh~y;(*X F]w{+5)"L#q7lѡïS'J- #+ zвLOQ 2^E*ؽٷ1$SuXZwϻ=J퓢dl$P`4yRT:\ĴW,ýk5nAb[0r]ZmHTNR0b!zm Kdg|>=!W\6{3")Ϥι< Hˀ;{@!lֈE.t8f)wTV <T~CC<[$FSW,;q& Nx@Q#,PRMշMyp,Y1NnʃՄ1(!8P9B7篏BGmEi0tdrrS ,jquס(N}{axLs' F*hBF@PUl/tk WX`W\pnTBAO_)QG|pM-|*RMTԦCoC4¶+2.;h<:-Ќb<(*l3Ȝ`,=2O8vWm!I-p*`&Etz-@\tR;qIktu>qEi66SGWm3 (ݾ)Qa wIDE8) truJPFd1GI%'*>#b~lDvY:@dVQpˡS'gPـdN.tWVPSuR%_0V\  ĿMEE;&r[of5%vWA g[5^}9RCJzw)@yFq_Wxʃ1UWyxpw:DwʹϨ~Ee(f7rx,OVX/+TȾˆ i64l7*_[v+|(zbQ/ӳP 7ɾ&6.D~T?7C1ť0 YZmets/data/mena.rda0000644000176200001440000005741013623061756013563 0ustar liggesusers7zXZi"6!XN^])TW"nRʟKMd[_;zuq1Sm}Er^0Gl UQF0Dfv 7QcdR~am#af36bg1yF/el>4\Fas9,q=Hxjׁ< ~oTkeKBN5~ҁ^wC O #o^ b |-" W҅L1 9_W,_.stsG>{gn"g?:;6䡞Vuˈk^1ԭQ|m$MseM!qM1dWôlKOfZbM\?59l-;G-1]Ht8[="Ѷ!2/_.A$x~Rv޻2`!dgzNOuƹ ݧO`Î\넗7Cn_T+$rM~)D?3p`tˎYмo(+EU &}veY"|iRMO9X1V5%m*0N﹪k{3EXľb6+ouD?Fp,~* 9|sªI|ASי*k8c״lIX0(j$,>Kd9X#>:X'wƕF4k P!fR\w…-k@6zd煰I<`'/&)!jWf g^].-R`G>'9mP`cCDŽS#+k4P ,'.>/zu9%\fF O'hv;p˰BB}Mbp{E+$~.97  &R^gWc3XGIg%,rI?p xy 0 et-Y. ?ҿ5bPIEC޼`2sDCSD Z("ͯ~BPգb,9ru\B=ȒveLeIZ<9,\fS^$VgS5,>cm8'n:NQ-'`v2cCn+yEtcnn߫kwT3%d%ÃN'XI7F:ҽ;:=a>0Y%x s~AtꯎuDp}XfEC`G d]U'<|WEֹ& ݵ ʂtXH{CGjF}"eJ>>#=Y|TL2sNds/N7*+jWVv^Dw4rMG.aW:'<ʪ9 V'}Yf )+|B2]w0a C}u ~hNRq5n%c?M}j:JaV;p25K'/Kn[x5݁,(%߽o9o~取ğ:"{܅=XQ;UQ+h1,洉E|~iCQ^@]OcrBwJF xXm6xȼ7yOvz& 珘5㝷X`ԑ$5 !֏×14֬ Oq2ȳ&D')zgVsNMu)̝|@Ev|@@DCJg ώ25~AEP2Fȼ3Bp^V `eCI*kS*lg3#W=7 03;TN/B[V24&`_hQxLku9N3:A/Fyb\qO݂:آݩ#zYpMe{ΚMT&M؂5q#c2xt4fJ.mx= E8P]W Z0,z{]TH I:(7&[~сfV](C.L|_Oׇ;bmԎL6f䢃"dsa%:njQ46%IGRgW.Z@ / \Ijo6rjDQx"J,Y9W~vT21׊ʼnd:8hK` ?GKaΌojm{IF3>;a əǾ?M[P-FHȖ4V65 419!k44ؖ ]Z*j5T4~5=ċ~Ue ^"犦R=hr/Բ^L3+Os20HY|_Lz=" W ]ktj69N~LU+Ylb}ZK%ǰO:Cڝ)MЋZz*R@ #H .HCCʵL΁ּ"-[Z%?N_ 2Dz3ф|؍ٍm/!{8xzq<ɸ kݵU:PPž"YaR+(&ѐx_xWT8iX٩-j+ 2]z*A<&cnd siZ{4X1D HqV>y'6"5zl@^T[bzB2T&8p@@@< tw֕Ob n?X$,zӁrnI R>6IW 8 a .\ lUhxO>oY/Zx|~jN2NTuE&Dj 3ՒA.5n&,_+. ѓv1^B J3RF8E6#5}xʼnIcg| ×K-ͻU,xag>7.բ|e-2"~Pw>ƔS9aVK? ?d&J;AAXB$5>T#hG;\[c<4F%b%-UZSe, ؍O*]P/<¥<N["fݩlY;IsebtLIJG+\zU7퓔zQ P`g|0C߿ڝI^:j.P#Wh ͵1DhҺ`+" KvyFS1AU9&i}b2d M5$o `3i-", jK? ;v dF/i6B]F@DGFcDD>HR\k?W(&) (w=L\#^E[(g}b֮CsAb.us~Jx^>^fEJ.6na ʼn~dZV\E\jy/k6<`a+[XO6#xJX@."d0C678SOtuq أsm7E Y<Wv[{Tu˚2DODRܼ\&Ѓơ_Aşkܩ6J-WQI1O2@[P>7mOb;$Y\cLibiXR;曽IRRc SDjWc6xOdqMG;t0l{[4fQHhD9I؆۳%۝.,>N .rP n#K3[DP)%v,yN3S|5{IlmryR+ OO(*O=)2]:dy7@&;31M2nNƼLj¶DE~`N49IT+d OB) +XWԤ™W׎%|p}d1+*TEvfy7٠K#4!7]{2]eH(3=ONA py*hE lsp_5Z[$r:s۟myhwsWpVƈt=| [}lnI Þ>uj糒X Rz_)VEDANRsa1BCT+t >N=;?0s)Q1n#{b낖TTP8_uj*S2 MHOwp}+zm.4&i !uڗ Tc~yO^euސ6i0]ܕL-.ӟdro L3+9eԿ:FW=Rr3Q-`yKP&#Dih.rh @$:idVN.O~@/K+<裯:AkWWN\a0_^s3zw1!I!?x6AúK܌V6y}*ȅ{X>?tvP)ngRE1xbvoqMJEkQ lM[ 6?EhF+ `Iѓ_@cI>qڧ.|87piIN=li/RC }e&__jum 0D[ iIrh׷loRGE4;ݴN5ehZ/K3Q|<+{F+ ?bD: PӻW8>9PSO7ʚp[GFZW6rF| OL$XlhFIOaψcq',09,44yN..UN;_Քʏ$X$܈]{(gUXڞ!j0ˌ%݉#m~8>eזu="7|Euzms%EX-q=vjGAFߡiſ>PDtDI%Pc*9~=} 5O; Ktv?JG {T`F+YBoзPvɷRR Xd DUHܲ.BǖZR 6ҤHؾ:C 7 /MYIύqәIcؐCc#"y<>O8غ5T֝ՙ/SOPYQ<7=H`OcSJ1RK<}Wi7}o87Z2yE=vgm8wF~a| # s::Hw@ [YRp;̞pf&CzհaL FG@fAlGl koǧs7$lLTSlJYʖu&(cpТ]Ϗx^j" Xh!VdzO# #/U.*o 4?7f00z!2z}TA ʪn2zGrb;<5ggYJ ے@#4;Zҭ#L~Sf1M})Lڑ"y9q*K_|D@JmݨUWo?, UhX<mj?|ETj+/U`vk6K צ׷]X?}xBޝ5N5rgLhKZJE>VHG0EpadT0ŻBYn20/j 1rx5Z* u_l(:(9 u-%װ*B T \7A]9Ms7CeՔWCSk$Ƽؚx R_{ܶ z>]rWK΄tb&:ZT_Ou:+6H dGh]5iT2٪QFpIQC@ڻ\N],qUuEѺqu~U +4, 42cI1o(B+1qs Mxj\U2;I)DHA^`>5C'b*5Q0Zb|V TFa1[z!My^L,.l$ڻ|% ?凌a|°2bg8myi'9 5[~h IY3kV㈳28XX XeʹSJYN31æ!iJ[M~ Q V_HC6US*xu4h>x k~k }%eq8@o?05|Ȥ3v nJ tIGAK7=etDs,6[yS~Wav{A,[m` *Ԛ]*ٱHF+2w헡btBStS#PpKzzq}@&5!ީO}7]ӘAtR1#]5ns球TG^ 2KfaRX-L]_P'{h 7 8i0T5Ao% rKdEtg ԑUM OV71X)FiHy~t= 2ceIkGt3b0_n^/"OB=԰sM^J3y`h"vrrcrqyiLIܒ^#Ùq̵a/ySʢ`xLnP(cgY{%zDY(UW/YK䫘Pa.RdjHy};{0*DPS$YeYާGٍh{0zȒt /[N3&;Su:*Q@Ͱe1|Xq[K W*B,]d7lfk.bV"z[CRźaR.;iuBz_q `Cs9[DCI,{ 7 R-x(XM.QW鐾U;w[' Y0җ; حH"/R=A=:FcN@Fkaq|S:9hn4n(Q ) {41'MyZ^R>+Ŧxyw3q*0짻|ꊳ\IV}5͢ `X+Un^'y Y\s 9;>Y.SJJ _Ջ ;Kҁul(iBS$Ns[ö(EG=bN^B!`U3Y8BX֌|{чMAS`KV~L&.Qsli榦,}}Bпm-Ga]V+[Pȉ)N65p DV1(]!c!ZBj /𮒂Dli] $h>VI/\-ݎ@VbV(񢉋m,6l{ky~- #>pFɜ%oC/PX(m$>18`<+[uIՎū s 1`.Y۱ PEsQd쭅MR?&]ɄҘ2!'k3`Ay] u|*=FlQޏӼĀ,6{T!39KܨZ QI#BC_,L3$:Dt,1ZhLQ^`ph#&{%?`L,0*/aLï&z&Xb"[onc]o,YZ8Yyۗbf3?TZL|HO/^' w.y4RYG18s*Aڏ뭀ڝB^sUWpqFaĽ}>C^4`@xwLByqsv) S0Y ۶ Rl@9.: ^ h6 VmܦIt9"<¨t;YtrZL~0dud`UJ~A"}GqBY "C\sTJY09G84SʺiZ;6{ I*LTdhgÖ5#mTmTZJ }TeRfK R4qx2r.aۄP$=pyp.Ł N& @tv+0[CRsPnW6#('Ispoӷcnҵc/ma)TT^S^bjqǣG*n􌁇̓V?E; s5;ە:4 @Fu^)pQtstcdg7ӫWMs>٦( P;5&\$Z3PWP#hxᴇW[0g~0-k/ 9-RhF["Ws@R`Ak9peruаKt͞nQRPOr}xQ +fy;91[ZӖ=HX5iF5Bue)\6$RS7w-ՙ<<_}K S{eİ^a܆̳4P{N` F<[_I58<Bުɬ:ή?/{ɋw!B7pX]Z糹Uq?4s>9jTj~@ =}XjK6mZ[ا 0*N=[b-N —s1rFnm=#irT~pR Ǚ/\#'Ԣ K rJet/N75jt PKTk2dJCl2LGLc~y \+]jZiԓH@ӽWCQ_Ѩ+mNW# V9)xMZ6j X neot5 +RܪKWY],ܣgyZw6J R˫REr5!*O٩ 9X;O".&ϨZJ ʲy¶L[˘ ծʝGևUd)mOzc]t8 8jezjVY9]-,ڙ'$ nMxG@ڰbusG[:jqAw(Ls#Xryp]^N<'F5WxdjV80E=y7צX\!T'6BTq5퀦:22q\Mj7ݹd(,Sa&.ŁYd?LAf d_ug3njMҊmKӟn#Kk & ͊ #>JpY.`ԍ$K䒓183~~/(gdx9V{L!pxMJ I?^5F߿[q:JVÑLi1[0c!eE I<>b]'o3S/ST:p~41:,39 m`WC&f&GF3()fSr)IWԓ~˸⿓^Q޼7keAĐno4հoDJU΄'I mD?>27L,$T۠QbQƭw Jޝ!K$'[$Ŧ4<i DccbU %LقF1SrDm8x ̟~PLva8/ue%c9%A/ O4Lnf\bNQ{-#9BѨ!u 1 w?JCZ\On#ؔ&%"Fʘ #vXe:/GUg16MZA3'uPg0; B9nRȕj{INVf zx dЪWQ{ވhU~\\6ᩡX`jZ|F,I5Gx 3Z}B=q躧 odI6 >SӴ z SpI6$rjS=nNI=qM;:xwev[3r":p*aG}%rm}_=m02~ wa?vN(xRYqzjs> +SӖc0" URp7O8 u=!䈃,Y7^a˺AlڸytiZLnfZ姗ܛɰ\f PYpv04Ydck ZI9e >2uo 6uI `[CEU%g T?i5&)b yh"@AjKP0%(XM :KfRcp]y l[t]oQeݞ`ǚulM/ԶWAfog G4W11c_Es.ޘ>0M~j-" i TDocO}^#v(v ֥}88%kNஃ ,T@ Ǖ#Os`0/TfM&acoSC$At#׈ 5oC.} þB_\JYNB?uxuޓE2v3 0}w(O#=~~Bs:Z $ W @jN8uh5:߅ Ңwj#J)9P7`0XtbN_`dދl1Jb_<v/9EϺݖuZv7@RgOkFњGwqyX}  =K ,4QNem;۔y1;lZ)uFfV/eqsaKUMeՏ1@d-`΢W!=PW1~# Ո~_Ħ.£ց:35(B \[TUWViy_*gw{ͣ FWM] C"I$;`7IR pĒ3EKW:)m'﫨pS,dr(j&i_0?y[ PZmZIv\t,Nӹ tMT1=t.7c(s0Y R1Oo>T ~IE' ",/]SRp^i0泸%Aw&rYThVhњT`D{[C.RHx ?wJdV*ng$F(Th-ۥ͒B(ߢۃa2<ID`977qVDU-O m$s3N .DP*{lh3XGoU2gjh> YʵҀ&Fer. ᘤKi%5ƩEΒk~b MΊ/7R;p)גa9bL>teސI{V"GYrQx/@t~@nrn8J.ɥz`#n ?ɂ;Z蝪w+e蹟m+Tdryc^a&7Q?ݨNyo(L[u̽W dT>'w3 m`4@Qv_s z>HcoMOvZ{Cr{ -Hsn3r#*+DBG*cydM.COBM&{B'A71rJLSܙT|SoeYOQ)W{{Rr#2AȇW R`tuߕc-̊%$n҆vyZؖO)UкJsz~J!+R X, bMLY ׊嬽xlCoNdse>C M+)Lj# 7vj_e7cÉEN_Y1L@ )N2Q/%$cj::$#M9O_P`? )U?j8oL(eO!E=wA@4Wժ|Z^3yO2V>1m'.Z CeJ6wrdXel&T!|'l QL*lF$B]e(_.6+rЊXSLe!ndzsK횶|qLaCN)Ժ5K4[98>\Ih..iPÒ/L| ;ogHwaU̽Kr:88]@$XîLg}r@e @6\Oos?6gc)юb DK'xu`J.֑LuIz)6g{?,=i9g $-^hݙ||vuB0m2y-!a&y3:r-0 z7#䷌.OgrM1A1J RI( ̽Wze#xP'L]>a5F^0rk[2HEc?' 9^[;k"4W;5lDI7aܪ) Wm^hE1[fC6jlpݯvia>ˍCȂ뛕6 fufYöYxYT{6=p ]Q/g"ˊD"'YIl`?Z&+ kꧾG#"mɛ|7xuK#QA 슴>[.+~>hs$۵)|U%#,鸋)XXT7bM۵9#m` GN?N*g[CX`=X/PZhN9JCI7+[\v[KO79M2u/ǬHDk 05|k:~̊S{K &*ĨYd pB:<=1UHE!2tq;׭٤v^ sρ?) ?][N(+7agà+};/([ZjU6M5Eot2=LBFYܧcV< <4 n1iG"!6ⱒ`F{'9#pȶnA{> T@VEh G\}P槶:wU;ZIrwsGRcjp^--6 MڏlNJab(@> zWH\ {b螡~2bfi}ågIhRla럧e](%Fv"htJ1A1ŀy7YբhJƽ#dE`x$a̬e\\|dh۫(yψZ2Wh,Iq:7XMxaya;op5F'x*49C#(R297]UFp2#6õȏݭ(B줟@ҠTGQ?{yp?0M(ɵw#]8V|11اnS9ڼrrb΃=DR>|ͅII!%Tbtl"0}bXhkr2LD3~~S󶋯nHng_leD*}.ȱ%[jE:J-2u NYEN[A&B߅IHR5ӧ Dą 8όحo>"``u^=E _׸mT|fBcMgj(!j'Nմ-0(:1Qsݺ2X*obqIkChY}mt(oyhYŔI]; VeTpFol޿8DtRe[--jo[l͢;lՃAh /SƁ)E,CwoԑmT;@ḥJn$melrz_CtT~X_NMPIbb @m@B%{SەKa&TH:҃Cu7 x_tjHI|bdXN}?Znm9K\I~vzBzBoԠ߶]*djV@z.Œ]t{9@'V_`R`C\ |*ABJYS>_=%{ ;pKVӯjS::?k=kQ3 LJvI&,_Mo?J j[/e?;a+]3+e1%5G)_ϑwF[)C !n'I< eeS1 -K+180s8 \\[&!fS? '}$0٥eQq#y)po (ge0L[s#|Xɳs~rD%h496/[':v,։S9p:X?V}i{ގYRڵhZ{"uY/hp͊D 8mb!Zc?+kuT-/ 4O-hۆ#yFӝ8Hm(Ae7<pԲiJ`nn_}c!P 0ߣKxmUtnޗ​Uf9#c"27X2ǡ[RHVâ\¾L;z!~#e[ׅJŭg罕,6&5ҩ5e(bEc?'@Ex\=Ԋ#Z$wCV[KOŃ:KA29D ͰjNdwB#ː%y"Nh8H|VG\  I$HY7_Y(2?bP1*E.w:CJ-V7|_,VlvDqz~!Нp| ɇ:~1E%νv⿾wWd*#ŔK6Lt-ki0Y5GUSaah- *B>b1v&/<$W3xZ 7e rw{惖|.dŒ]KT=p~1XX%M7GeQ_el*IWb+w=4P^!=CAeom$aWı?;zH(qbdVg0yOs]@wK󑖶$:$Ԡ@U+^mx˨m KΔײ:Mm'pgwuȚX*?ҡFͷFœz=Jo u70\ҸWM=FoLnY7bEdUMENnѨN9WbF6Cy,zǡkј'kOe%^K<&Q`I,YtjYqF;%OJ[sR\}BSn%~.@WM0M^>ShYIDSJqIvbl/7& 4g&xG{i܅Z#8y9]!$1hK98Ab ~ڱ΁\iX }aU!E `lѶ#M u4Q!~S4=,Dt'K =lİo`$[LBg&l6~Ɓk"0;ȹ]kgf}ñNiBtU mޭVC,{ _N!nܢYLušLqeSc?ASSQ"d&0DdLg30_;Q"?fΪ*s3bL͛bt,]g^7GH!Q8bGڤUƒ:,qhw}^I!Үa>T7#d7 '`\ >sL!ʙEdFunn rlK҉Iʐ]Nɺ:+-L3vJRZ8%YMPfҥhQ6=}r<v="Fg~EIV}3d4'EHt uࢲvF|DJ 㡖=J,.atoV}Foi3uДRZ0lLoO&j).ʽӶ\e mb+@Vkw&<25wmo(ڕ~^Hj_n^諜P Z\bAIVA킢F 8EX9KJ/{cTN#39[;ů7M>{ZmD#O.!m1E`܊$dagjj<۠pb/lt))SD&ncw/$1rSBn*/d:^d[Mu| yf"}m ҋTuxӚqF9ʻ|o` Ԩi7H`\e_T5C39s{+._@޷V\- Lbn`a& >0 YZmets/data/ttpd.rda0000644000176200001440000000664013623061756013615 0ustar liggesusersBZh91AY&SYV.x|u1ĩ  UOPh=@JyRхތSj@=Cl)4? !A暛J6SF&LO54OODmOS cCT* ɑME4hhEIj&5&&&`2dd F0L&CL&&FFFM40&C&рdUѓMD`ژ10CLC#d4hiP24`0i2&##M0 &BBMlePUcQؘWhk\ɛchbhkTW(Jtk%ګ [Q60Jn\p3uq0 i Xj4u3,55#ܥrq-)kP.wt VҊk.&ct+Cs5wnى2cRqĻ-#5"\ܨBYmYmrMfVZn]Lf Mշ3fܦ6ۙ[jj%9wsYC.n`݆n0Le-mS6mZf.W]uͦnAfFkcT2 R(RȚkQiUf!Y2Eel+m6)ERbmk7..XCYXj %EBu@xr@/N2ɭ☥ֲj8 s+,U\C'&OB ¡ SEdFJݦ8 $Ǔ8؜ )3PG(A@ Ab`Dc) c$Bo{Ħ ݠDS!6Tuylm;q_]>bBWorq-501;n!ˊO!w$%<&O_e渺__hyr"}xhl$@ ӔU6-֞p`^NL9 b9SjE}:A bGF%s:?*hk}QE9+bN g8*ء[$$r8_ثؚM5FmZ\*V),ə$1BqXjy}ÓL7  p$PݤlĴ(-Sw_ݦɛ ,Cv]ʀ)ը(wDiiM5Hgz$P9.SmU Kf¹LU CH%ii_WVk;2]v& (+1qK.\yK*C)@jfOi=U"E$lZͱeep dgT]gEdԉ>J(EY|! f)E1,ܽzlY2ۺEqyb4K8*PF &Q!00 e:1B-#&S*^xE^VXxcfU$*7f\#t!*+-3P;%oNT)6雿t; YAQEs+ПA P@'{leO1ހd*DA?,cg YO (!B/<?8ҟxVyH@ B Hrz&(B$!1 JIlbLVB2$8 i!HR Hp!BCRBHa! !a !i H$2$$$$X$ 0I 1(bHI H@$0H2I HRb@@@A p!Hp!BAa$B!HBD !$$@kvBT($:*Oֵ@P*b1MSqXciD$FtEfW YY1o[B)j%2U1;+`}`€R0mRrDQ!*bТZ\j&!B<9" yVgJ] 75%%HAӁg#Y;[$/Rՙ VP kkk+z%嶸v Rfۥ:m]`_j h T䜉Wn,WUK[Qb]k- x<= ]VTܙcv 5A3.xd0°X,w~c[ JXHKaZYDfI&*$CBCn ĸḫr0z֧Yz7Xr'zqwҢy+zWEyG6R̝=_i@gA,4m)h\=޷sjDžs$;IЫM RtI=O^r.Q (S( Twpʲ RsH=( OE¦`H>\e=ː}&q1x Uh[˯ PHM.́c8rv LXhÎFa0(jQ!`t¨͔;S`Jb:= =m z[gTyϛaTm23zqrG묂%y}"NB59e+jpHN͡ǵ]]ܸ2^p֩?Zۺ8yN]0 5Dks0СVC{x_cW6*xfM"]c籨2iNT38ZK^dݜP斓~{',MbȬ/dѳz۠#b|D;r-za3?8V=hѣtm2$^ TN|(p*Qͧ6!HJ\A+EԊxQ9Px/.q6)4v^Xi|HL꣥m4Nl [ Dq> 00rE@_E1$_X -.}-W`X2 !4k{A~lwvώ]|npqwUR (xBw°`eZLhyy.9 ۶}S㶖pGg|1ǽbn[.51CM*_ `4@V)-mfUPO=yy,ПQvdN[LS?q")dljsu;$)m:ŷrE_1]kjIw;hJK sqƾQzN_Q'*(&8h %8 Q)|>Ѯf Q,]!cBXس,Y煄͏TPY*G`d椤\`Q  Y3ðK-ΟD*. A^@3nҌnx}rjZf_J0uyI,zC"+e ?W7߹ eKn}*4 |a 7Â'p21hw J)+5`)// +vUGΣE6bFɷ!?*WqPt1_>/] ֠o %H>0 YZmets/data/drcumhaz.txt.xz0000644000176200001440000000666413623061754015174 0ustar liggesusers7zXZi"6!X* u] &wNϨ 0oo CZ;xvA3O]JLs!7`G`u3hsh7ݤ yt)UMBtS⢚X|01%_rBGaY>ttTo>~$#HO3)wBg' fV V%HG:=1f5Ț8pb#4/fc]S@X -=K*1QplΧKj7s<@rM`'Aևn*A-nU~GO#Z?)ZR/hD5@b ֥:;e6ט!Zi` Vn]G9H ڴ^&Z0zgJAQYʶMd薗'J_iO#Fh3Pۈj Zm[u4Ó{b3rrU]Pq ;Yr W|L,%~V5e\~`20>2Xji\!Y)AļD9r'urlNJEb؈!q%9RW՚OI{싡^o*BIoK=kX5KOXĽ%1)fJ& .WKXJEUm#\ph C ?yJ墴`y c!-uK}Ȥa۸FE=huZjg`赮~3Q!O[Gz3f/D'WD }Y]ћNx]>}l/h2R'>А_׃Jwr(4kN7H_8͵J'__㈚*[ð_XҼJ5UX E\fP-AsK-oo _^iS5j:uXcB> ?ʊa M}},;jF}u>8&ѐ%8G&=bbN~$Z!&IP ;Gr"s0ȉ># yoвM,)abxףg9'ښ8m(mƛfڷ*6-G]9/nW 8L љC?~˖slv!e_EJhs)\NN\ܹʮ2,Vc;Lf+=!јC*g&-qjF!f #/e&$p+;OyAU $-6B{z9TNZb d D¯;/EOaċlwPT(spգJlҁZ^Zrh & :kv҇dEHKH+>f~}P2?T6ߕQt$ vedq4U`ȼ=O-meih8Cp6}au*%]TtuM^33(+@@*>[6Aff]\lp56LwYO ]=zh.=z PoBжF (#JNjlAycV'V?יX?e:S*H}޴Jl%Bq= ['yi2jH:|a떼w3} ZZb/Ft-H/];?lt"xo5Gyey;fM)*x.[=E}2ۈ/Dei罼50㳉1&YmO&kYK%Z38;`_؛j7_?&DPWrl>|D_??aqW-\<[kћ;h,1H9S3~ c?`px y?crQ\DIr#6Ipf \ ܈(l_xj "6PW,8nh 'n3W:b0ޫR~׳p`X[l@2ȃZf yS|Gn%EM./'(*s$s"#DG+j80;6zD#C7 Na=XUU!+ynx~im[ GA4T,Ok~C}gl ?V? @S$67ѽXW ` pْGlm9 ^ٟ)O&0s18aFջ^5UԾD #{Aj sTUX3D/ݻ`;2tS=(laPTIipoycu[.c gjfX>Aל >*AlC[~z+h.SA |)?-3xN};<|{]DYmp)js/CGR܁bX@^ :#ѵ1)9{/d8̩β>ێ:*2ϱYD8kdd*7Y (`1;2]b`\FTz"H>0 YZmets/data/np.txt.xz0000644000176200001440000031076013623061754013767 0ustar liggesusers7zXZi"6!X>]Ike| nhFۘ67 Ux)v,H?k+J&MNdePZbpv"q'}JeEXm0;y yd=5.m⸓ܗ+Oe).<€(39I"wX37[;㎢ܲۦY 9\iقm َ38ePԡ\['M,qaNwZ[& @0zɇJI7Qùx7kL\3FhO#E=~w|ѐ^X>&gN-Uy4Zco6bQ+]XhX@rn%/OŧEuI퓽x""b^j V h4t9h^'zY=arlv 8Z fs!;#G C n"o#,G[ztl:QFp+ڔ _Fjc-N#Ҁ#`[jⱹ^CfVDŽkMiI¢6[=#r!CpDz %*=e(T.FmafKܞ+d4D cYHO5Wg? YȅArP`/mP2̎p焺{<"Z[B]Ix;J$RJX ]3BǺaPny!/jr;U/¼31:+?w!/72~Z XbJP[k==MB@^~g#.55yhNxg†TW!D!@0/8 ӝԖrlQY@)ȑ*+W; (% Mgh~ȱXJu{` ,@kƝpqHT)gsVyIJy`=7)Y<ȏȥѣ/u =cΖxHvE!*: ~f>\el^2)IW(j~7 !sٳT QIFqQhccd |T͐&^<X={0M>< Um~!Qf) ~P-tPS.:w`t96o͖dUO"= MH[맮}_ɠѠN\B必vB9Z=,!Ew=5g8ͻvuӧ4 wFfj"n0,w@(U1/}jĶRHr2hټ"2RV/qpA ,hR9œ:~QeDq7؊Qd y0omHLݩ(B6~H6 F_ D0̰FibJi7Zθ)O{Fmt _`#jM;8(t@Vםd$&w;+H&Dy D5ڽ%e(8R>WԡG?)f~*EZʊj7U,l / J Ѵp`W(9{h?;~u *%+0ʮR8;zoaxk {Z38r)]~t1e#^q^ؠ0s.}-5 2ɬHX}ƽNЕa ꙿf ykɘϖFo9I:*~ ] tZ<:2>b?̣'$ !FnBDfiѢ\qn)땸>4z!9!'n45x{(3N.6sC72!gW̭}wN(G-KD; y|~`m 8cFrFT[[#D=@[6-OڗwuY 6U,gőrR'(8ϋڊ fNoJ!RNO5+&FA!R*8S֖=4_:w6V2j%u#mGz_qk6M|RѪJArVjeb$MX+g's+sJL&_~!>c6=˥n ^, !APGm_ۊ%+K9?7W-qu~wl虠e[.9mbzi VN$xf፡Ѿg:8JDHuAUc?.*Ԋ-~hn8+fN:B +[ЁKprJ)hrbu;fϴh =k! {Gk'UKEs,8G[Fp?cXO8w.vS Ŵ!Jk!Xw\_%E9|K'I74s/seejPaa;x=>CdXTvA S<4Jklʘf6}ⵍy3#\d#|,XumH̭yJGcl'G%pZ>[5fT,buHX[FA痷& t3I!Ҝ>aYg(&jTҷv Gsߛk'0_waQ=QmՄk-kuvx&|LpY}m+X2Ch|?3C3aŽ&>8۔.Mwye!<_Jy y5Kh)x~b ^hjE\ bohh4wa(c?  Y(;)<ЉrZw54ECzvtb vg7^"N^3HN)9KJA")KUK4Ǯ3ݙvH]m^8,aN2.zȧVξt:qStgOV7I$H$Z'#bX+@Z|J}<BtS1o:,.؈;tBa=~+" ܗD)+iBVHsmX^[&1sZU@ u}hf͹a' d?J_Ց-!fЌ>j+'>@zes v3\9RP5i⛻eJoQgi_?nMwY~<3` 1ϫ؟|7Vw/sj V69<[IG7GN{}ytrv&ߚ _})[zȘ?AnIqۧɈn_c%kĉWsUO(<@ߪW?|#Y$$ȿ=Xhu礧@ye[ܷ P}ѫ(L{NA.IJ9FXP^0h"'ID9B'6<yEC"Ű{q:a=(?|(ޞUmvl DCC TH.d}Pd '̜+{JgHJm?<Ff6E PΙAhCVWSKU>vk?Eva(\p*}'[@}ޕ[ EɴAy?WB[-'h^?L@K<,츯kյ552Vէ'ͅ #8t+6鞈~ 9&h;M^G/LbWԉX$l+$qrRvЗMa) XHVy.[g*"Kvd2)%;)zyU @Gk/I<8EPtZ~r-U#OuF2R;W$7Zv5"y.BDE'"'Y I*[XZ^ hK,Z{thomak}nPCɢF̚JIZeUMDn#ϷbD9T5U\@fgپn`d>%H%{cK=,E"c*^K@hhx?y78@n D+oۛA˿Ik Zo,d-M>ifE5r"} q,_W(:hxޱ?زցs<u;[G_AJb p>_![8 `V|lJGY_>iCay5<8rqVѯd SX"jh:>~W ;;]7pQl-\љ i-Mm:< A%k˽ lVmЁFĪuk#!&ඃ;K&t x{4nY_d}1&4%FP2#ӑ`⧕H…~O؝[ ѳN~T/Eu+|%Vt;c5NB_Cj[odTn+q;AYs{(l 0iIdF򌻜gvJ;vʺ)I@% Xf1H ezcg8Kqȫτ_\!z‡.PLѭa-¤GQ^sigls#%i5+ U` h6`WMr3;:x{Pv ^Nu%V+5@_AsIhә + u#X=p7gMcH9..l~q ܎8tvKr"_Ϛ1VYs#xL{7_}ȍD :U6{Y(Ty̟egq¿; 6Pb۔M[30.HvU60)FX"!Y%\DU?l AKczuH%ڊ9Ǭ N["5ުI.8 >5 [,Z( X[.:fӘ#az6lF;I-}HYYĴzjp6NTp&%3yӤ"YSb>LpPGn9^o㲦R2";P;!0*r'_CDSfA}Vdhi'lYR^y3¢dt5q?ZCZ 0K9MfYg; =_yյDa`/-^,M*!_vɪʌ d\Pfhj`,_zgbi <ٚ@Q3њ8Un'ċQr52H+V_3i|(Z> .*JO|6LNjkcX }qϳ_\Uy BB磗9H0XzBA-ت LCWZs 2\lkJ @ȏ"#`m msLB+47FŝT5Os,cJeJX &t0Y`e5Ed"-llQ QWg. y&A4吨;nDyٸv 0,bb~M~!i=~HZ>`D@]m͉ -̮'kw hƻ[" Flr4I׫`ypF:(j%~)[-=Iebި.9'nX*~WMyU£4Q\l9$s-?MEMdUȫ>)Tɔ`w"]0;nU iTPT[?; E&+ewJA *C+$¾px1=bNMsa+k ?E?o!1,"6Zso+n31V| A=eCh#X~p+_ $U8px6Q6GԾz^\^WXL??H h/4Q(oZ@9tvT+$:^Eʩ ^\,=ASrSBHՙ6O% " vc*y?4d>E]{eX <j]m+ָB鴶Y_s9X}EPyIva8Bh>{$u])(3;$bH~6D) ؓC2!(.v^h3*Q%:AA<KF#}%Sɸй4SO-"F3S.8p ,Hrm~ mԶ9"͈&i VZ4$/=ceFtnh,:n8,^],fKL:@ VH1TB>j؝/z.5-2k0E>;6GY?/r.Fǣ[?<h"(Ag);[16P<" DQ짜Yydrw-]~(<# ]4 0$߯i5OT):^i,jO}܋?v+Z7Y0q+dxN^ C,?<7B:Z8@ű2]OOΦߖD0zNvkFc¿!_oIN 8"zhpk+mwON| X fY 51ɲ{vCνf?'ggf}wI}6 hW=9Y GsY'* 꾃[iiL|~ ms v)ly ~lP[|Q^ 换SM&W0h\o (W2'tSb 9g2eiTsvl v &u}!CE*J:3Cɶ;QVI91ΒY\ޓZ}NEU e'Q%}IUɧ V``jP]}?T]ID/2u9񞿧5\ 2'divEjg%"6  .٫8xs #q"e9o*l cf&wwmvQ;!o뽹}r?0bd*n=p x":)(mM[Զ]@օnuZS1$ܠDY" is$7z655Pan`eϾ *u\jUc8Ep![*`VؐV%G_Ϫ,QVc/*DǓI! BCճSI29W3Xr#]QVi֨2bk0)^j2raWEʫzWWlFvvZuAxXQNҁT8K M!w Q5bQI87Qg88jA#81[Ґ7I`zK8Ru1[eBK1a2 % %njJDx g{y. vVVy!kw:V_Y9&"*nkn_sesٽAؼll؆0i-*h7SjrǤ[W1~bdoB z8j/H{ )oqaBt=LD ,ej.J3+FމS`ZJ^;5bF+j_x%'X *\V`DSh$8C^pنO\aw .8%rLR<Q;@}Ml݊xAO1S;!j<]́V{.Bv#U3d *sd^L〉⫮HƾTjInҀ/FԺhf԰Dllβ(b꟦hfKbmI/ֲEK0Y sT0½r?_ݳ7-x<oMAL :4 mHr_fȹkXΓPL5Mm 0Wv?)O:#&A6(+R*@kNRv}Lʡ\ ȁQ^FuWqW clU֞ζٰJڸgtwp0.42so&@v]7kna'fo_=x{Vɹ O&kWk6#a}>\#'w(nn WW$ SӋX!ϱAI\]>2VY:7 M AhhAzs~FT}L%rY`?tJ@l0~+nQe!1|;,V(GU_nQ`uf-OkʲzH>X c@+7WZ`e=)K=`>m+xR yN"L2ɣ#L4 {,7UZ7oEnw=}Y!0$VƫblYZp:%9c%mtܨ|Jjȗ"˯mm}[A [DuQw(,`LiiIWۍu͋4Ee7UI09E_j$RU"[s{إ!ERi+ڈfMkU2?, 4X0F u|_7 Z"$~F%>@3]ڭEJKG] q*1t80iө 78ִQ P7[cC KiYnνGMwNtp4DTt Ԙi~H"AʷY+bУóSC6$xKcg9 t[l/'}BUe|=mxB+\ Y gf\θVLPKFT'(›B~"/Ec!|řfAI .Ԯ+]ԥ{R&+aŌ%d+|`Ji wSځ[i|E9= k=V / .4gS4v, WxU~yQzxgq[h l{5W#+&N>Ţ-"_ͨG50\]"4|XO;3Bņ K+s5vUA\) '7()=|KA_Ja9pZ!K 8 OZK2ؔi*20L4QH ^a0^`0L!X2:4:d%g+:dK~f`a.л;O){NqZ)"}^|;c}/(^llZ5Ö޽dLxR!&mkc\I-t| BeB=B[ni/֜-~} ! |Z yk&uhiC?[+ wzaV]8Fӝm#w՝ַW^@!A~M쎓Gy6$_#\WZukrj`ktޣGH+u?J7ɻz%vv,_fΟW?g$,(hr#h:%^c yK-f$; ?j1K #WL{yI=xe#VԏE l;^ݴНs w> CRf[?ꓼe`@磃ZfsAH0<֐B_0tTT N1T!OhTaR!q;2c-ԇh c xwz`ȸq`Bx)pZ^] q?`հQ- <#J&oǘ@F 1 Q3$,Wv G]p-TxU K {"6i)xE<M'bA?LY8c ^;'6y\'Bwdsl:tW)4 %GX\0k~TОfJ~QR?Qi3quIm!ww Z]+^LP8a*c0,8I8 w_Ԋn'BywzhG_BeF5|Wzq,1!l[O!,$tf޾7DN*G_9 As#& /u^H ~Ɉ} =2$=,"cRr5ËDIJbpeyYMdM4C]ܞqLSzX@tǠ!Ofcم.ɱ*w$wn`B޹(Ӧ5<5b<hH|bŸ XPV̢[2$v/$jͤnψVkVu]횓0%t*Tɿj`!muXF-cM50>2L_I5a RbGoPހm2z4 P2`D4֪aZ#5*z᭘Ld>5[uKWӝ P*9^QzDzDg:+ۦvKuhlT 0lJ7.L)?>WV= 6s{|Om =U2%y'xR"=f&o{a+J*Tdo[o䆚In'yF%i($Cgс|X?2^3B哲$6՝3U+lC b(ץ&2L-q:f_r 8{5˟}'mxx}` #Ơ:?mfBG ';6X%Q˺uzVBf'!QL5;e(_ cZ?MjlQ7o5Ď6/eblW,,:A&kmv&yXlC ^Þ4$bH[IlWζ3?Fx?}5js(\KGW[ W?‰ovv'ļ=0; 6LoZ[\{ YH`P, a{odm0dq7P^ܭ| !fUx6oyKp#R; =QN(1`~ע]CBmn#Haf! q(KJ#RSI8m!b'h}ERkzKPʫ;p68Aеlbx\;FW)Y:h'nXv*$^EpR)v\\?ș!Xk=b7ik69uvKIv) W"./Hl-Hp$%A6-Le+7$-NJ]o5$ѕW}|8[Td2e!|ȂVLw~(`1!rԨ޸)<IR:y"62Uշjx~=]Q '%Iq$9>t<_`1RNNlJiە3& $`ar9X""sZx#s?]2H_Zf^=䳱WL`u?:wC+M-ZYu Ə>D si4m =pIr㔶#-”x%-AMQ|{ U<:# PV $R{s[e(9a;-0B϶^aC{M p=1z_nTngx.PM55SŠM >,7pTsW-˩>_R'.^bbi"fQJoMu @~- ҆x̕& U@ pIJ!MpТ) [0p[|[j3yY^h>p>1T2=jڅ).fHnR|+lW󉁧$Pa$GЅ|VJXˈr? di[hO2zP %j3Xrhq4,j5|BE"b$?py{N3@ﷂ 'G0#(\s.^Fj9 'ڸ[i.gKLas1=D(k*֨ɉl2Ct9bT@{(U39BH_\Ht ACQ#\ߺC~^a~ ǽ>VX{E;1MM8F=&*ISg' 9ln(jjd dpoudDlj\4a^-#uz!qѢsavb9}suP}EAIǭt5YYj Vq.'e24dkr:{d0EP6BON\W~ah +.弮T\" ) ;FD]JH\4`U7)FZa=s$ ŪH*b8t&Lޗ&>9-M7z%e6N9|Q<2SmN'|6.Ә7%;n0b=8fxrS<]-ǀO;M/ [R*K#I/Cʰ|&Z󫎣+GOGURh8k`!;ȼjw*d_4 iэ.cPϕ4P'/0ƫy;ޞ(WIdp'TWQRNk=0#Z{CSy+_Ij';z6pj? TOtc/pa9S$l-KG&)]0z/ʛaڊ~æJ" `o3n?w>>#AeյQX{]^H|.U~;t>,/~Yq9ee2cxny-ּ:)רQQ"|L瑷w! EQne*{!(ُ ~}#"Mҝe4I?hVNbo2{,"^ L]eȵ":Z$OgHŎpRTUMaØ|V(#35e{S8fPt(䭇mNh|CDzNg[UP)u>]6 Uto+^a<̊D֜YՀr+@Kw?rmg53ߍPOl/>lĞFV@7Ѯ ]SV?>ׄFY?!uyRmX@>1vj-E=ƕk~8}_\SWgaT9aDO'Z1b-r{>e5yŪ[!ƙ5oVNϵhV^#"@B6~P_򷜙>Fj*P1?f&'[L^9}~`huM$m>lͫmPs` 򥣰)5銷F' L\+Y$ݰB<"W-;X3x& m| :Gici&J2(p K.OBAllu{ )yzރަZ7 mRt|0lgnUi\]1U+\ <˿9"\2 355LjA6PW`c7.QR0~ٶK*F>Ϥ-+zcEG#%5VFBA.tN~D8w/|SpUuGuc~19[:\ie.7bzC"ff~=ˊSpZsLQ2m9XKN"?^5@sOx ~դJ6aje 0 ->Z嚚i|t.F/KI)ødHDx$mk/hQd>5" y k{pGӞfǙ!wg3Alo'h+]A.X{7+?xqiK~P#u*ߐ{~&_.VzkE|P>ɷO7` SDc2PNl-:1 oTkiOW&cfĪ>zvKat-N }1PC 6C' }[0$~_ШFތ jmb!Ү&~?Bgt9_&_|L~M 7U6wk:s7$|0U{q`n54X"]&\>)W f2:E)]10lc5huc{⿙ЈMմ̸24D/ZC>amK ޤ}}<ҀKכhU#?w#F*Ҁ^FIĬ:``4Dj!~ ;ϮYޜ9ZLL% 7ť\>!EaTt@K< NAEc}െK_nNI!sdƃt{38!?_I Ӊin4LuNh?ۜvEJ#$:*qt!ѓ כgrg6s16oo|~+ϯ+Eт(P5O5y[}DrH법 %ni։)yx/R3U/ J*'foMox|b`Q+J][~ỵa£.ySp`2y{lsh^nrI}$5Mר!}s@apjE}% nDǟ/N8i{ړk3UKov`Xݾ0F٭KouM#ΠJd2~]h IuKFzZhn' 幧n `@yeY̞A5:¿PJ3 0 1Jgc +}s+Ӿe? ʠ@rjC8q?4R;q`tN|} i[Rzef2p;ѮJ.V|.'Iȱ\Y}QϽB%[2ۤkbs&(k\^V֝7*@cyߘ HfwAY8WPz J5T8q`ZY)-e3E֊ Gu4}>熜sۺO f*K?P&w|'Ne%0RT]Ǥnٱ:$N5|t17#E l^sL pAܜ_] 30߽XD藬` C+: 0ncA8Bq'uu5l$>Vy :gknd<1IA C Rq%`95ZR+w4ܻgh! 2e,3 3O.ۆēVS?/,ljhe)8::m5Y⇙i:3~6XdՐEf9fk؀%a 6^:#i]o߻D'K4dTreswlt9o:Ul+נgD{wddl>^S ~Ê*HB k!XժNulKVsLjJi_x1ԓoSSȏґhoGTI8$(.s5/ ٭\ |4ZӉ }=,ryH:4}lAt ]q&)A ~KH)!ǭ"5 GJ.6_(ocQ6 ]SЏֶ!u ȂYd2:fK>RY`~O"7ƩNz{Mss <Y`8C9XZ C7@ Z3f?S?oJK)vTAʐI\ӥ00lszjmca{\ MZM6X1O,,T2F.M;\-Jblu|C LB wmz,BB{ QgJ. ;^4<=r-:%dJZ0q p|qqY}[`F U˜FIJˈлԫ˷q 'T񫽲K"@)oVѮް `ɝ2_K7( t=i:)/[RQ5"RG|UDZwQRrn*AhJ_&0֚t@?^v`Í=MǑPH-g8o-H ӟ³'d;X󲒒9AV9HRrUJ%&8JPRjnbCiߎejgO4Kܸrb~ tŞai- w*xfg?ԓ IO9793f*t RW'ۦLme@+I7?抶qW_qM&F4ZRtie>$WS갣\(=AckNT,j 2zI\qvJMb{ :q'gE^a +sqtwdo!dkb1Ai{W5(_HMayJ9e |F "3/SQqPX@_T}Sކ!\I -d%#Xݶ>NT q [rAQyxz``++6| a0[yzg}Pi-'qE:S<+n 77bJE'0d]ݧ$9`XJ {<+ ޷k3[ - oq[>t2TbBPAXe>OҚ2 qqdq.5ԟcQ'X|QvG(p>A ] 5}ui[q5&j7(CEA->VbIz.sPEϔ>;瀽WJ07 L>)LNTۃCo ח},=H\ udy|t䆘29i҆eGf.F < vAQ](׵-N߻_}[迕:DY"#^7h:x&mbFQ@T;;[D`",g'}/q˪+UڦbL Nw^jBR1otFL1J +VI9 ˈgPba:Ϧ',qXIK:z[giEL/T)/dhE"6s FT%*Ss1zg2K d[AxFD𨷸5p9>+/^܊X|i ^h.@QH$ǃ8aw0jT/({@Hrw3g''Zn^WUh OG/ J@ 4eH TBC}$]6E~.5`nh ]&h^׋xsL\y>f0Lԕ.\noOF]xKs=m^"z/c}\evLRnP6sNaꮒ@U$.8봖Ӑ\K,4#S5D-?f@A}Kސ C_)LM[NC}G ܬ*78iMsF=&qF.-T94cibWhzʯ,:27Q(s`[ʔoc"_Hr?:(T6 XRM~<*o w2d5 I(!#>u]Р xB -|ڀ Pka~iEO ~=`w^l;^}>'R t~\vYkD0F}w"Z o_IU- lZLJZ+ D5Y 0ػ$!Q;f1嶋yR=XXi0;D_Y+0F֥oxK쀳97 W{47D뻺\JQܑ{r$xCf^ XB(NO&:/@[Oq$fl?u>eW)@o)rg B }V1Ƥekr࿑-Ȅ1uN-e ?S?(m}JW/HEOg%^>a dgNVu=dpdD% ԉg6[>!$ɺ 8r6Ё!;0/ +RQ.3{钝dm/;&͏{B~Qm*2؀*NWCoujVkK/:xw:1t9dR_m``יF`kWq膕E DriY:FC ݇Zfq -p^1)ё/RCVjeg*a޸c=xx|#{f끃ms~z%}@u6oHpٟ:ޢ#o$, SAҼ9nh2))Tzg[u|\Yc<4<OXAcu L\ۜ2+?z[ƏZ&V4A!qIɱB*EDsEfHs_c2r_ Leh[GnB6ɩ%k-xr2h>[ l<;R%lǮ+[2st]kX}mTcpk܈۷ y?D[:s:m# !b7)o 9ɘCY Qfp3ƒ܉]_6k&R_胦9ʶ6L+yעtn:ZA'O\R { Pvi); "Mp='R'J_[XǭhBn,}h leͧ.Dd>pj]p#]tS$Ra/KgشV-E!CVBѷnL @Hgua9 [.N+ .-M>߾_ Ga{rx_|A˅NEeqvg򤊡؂˰EGWñ{'9&Q0n Vd.tAtN~4Hv3g7 vAADH,?1 rC,Z;Nf̟W q _CIgc|wMp_}S(# QcJa($?,#_,R|sC&x~vךVgk|WIVnl<,|(S@TZ|γvd)ݼoT,uW}: t?W)4Hqp$Â]n_*z-:-Ґ/W('mm%{&6dForNaUƵ{]kZ!5Gh,?W/nf7Ve]u>MKk k9oOwk]3#0_>ܦI5(ӫ _kKh;Qb1\ckSC[cEMj%m6P2v~ݭ}QrC?54Lfi/>1u,4+|ZMh2 5#-^MBt/HYP.<ݓnS:!E|}N8l 3$HP)b ]XRS4gh4ĵiXehM-o>TfzµN!r֮ Pg8g@wiQ1sI.q3+U\V6 b4Axuq ǝ@ ,9qRo!quL;79oǻ߇Zؐcpt8{ؔt<\PGɣg})`l1rC$@!s_4y75sFa},hN ]ɦQ,Ko$fuR4d WN4!7FK?&%ܸSK>[}֖KD5 UCBc#r핓̚r} 5 אɡa?zO}Z&d1Wcwt[-T`׺P_񰖎K:UeԊ1rk;VK G@^ځ\ lӖw Z&8$j|C~O=`2M wzȜ\Wq-MRՐ3I#bXbӁZa1q֢Z܏ f]D|qR'SUQ]"3R Uxש\2xL3vܸD'xOe{9j!/B퍚 8<%6HE% B7)3Sʬ絛2½/ X ㌇K-$6Ve;!$`P^x+m+ʴ 1nEQ 9"ffPmZU#+>Ϙݟ"2DBY U LiґC6.T[1dyt%&M#Kޭ:Fx~ J)B\Eu,z4>kbcR2n62^>c 94ֱ\zU_ Rpe c+OƚmF|0B4&P00 MyYZ2h]KkSu5ᤒFƥºЉZ{?"⻐꿍x;)>yOZ@Y8PCL1gB{:uރ:'"aR3"H$%L="y}Hm{)I;r*4#qbE)|!B >Pפױ,Ts9wj)1>X 9|TGfRɖf!gfQ_YDK8UU@@š}CuVDRߍhL\@j+J}ʮJ*XiФF9"?S)ii\`}bjwҜON= `!,͋qB='.Ϸ\p_ ?W D=,NA2@ %|S[Ǥ\6qY S\X%x[Pi3 vtSyDYGn J]wsqCh&)XK'ZHk_N&]Z,nnWP3~wY 4?r2ƒʈbz;eF gmj쾛vf j:~q&=o8/ů-}+J۹C(],D-RQK Pi[ߖH<;Fi-DY U1TJ::RE/œf;d&6Fyqt|1!e&iRuaa,rZbǯݘh҃#Yw rqtzB"p 5> >ZݲmL@'PMc-NѴ< NCgC?c2ָΞt^ y\|V9J[2CQWƘ\=%}{B/I;jd~k$P1[-x\/N+hT-YD7&0u f#`Ye(]m OcHAKsuxa)^ ir/XmMZZ]8߱3 ni dTP/pf$lU&=#.o:Y߂Bv*e߆εX~=!Mv&3qL0~yԸykOȝnM.ªӱj6J{YDqqR;21u_j&}8{af.+#JZSzzze%X MU.Uʄ/M[: 8d5B ĕ >k;T /cAG|Ӕ}&&~W Iphr =pi ÆÚT$o +SE=٩2/@tW𖩯ۤg,?\:SQv3)M2M[kdh|BjD?&nR[Kl|wZZeŧ݀&!c8̑NT.O(ȭR1Y'fSN4,n;hIjsb9 >iWWo>=Gs ӕtF:1`OPdf0I#rT1ACX3}\YLs4~.wHa;p67=5E!.әLOK?}@[Qd'7Te5ߵ{U_=R c­_U!_L+0%hCYySͽ93"撆^24cf{by@jC5c)~-Qn~U!iI!j4Q2 I@f@6eKׇ*FPa\: <7d-/_CT`@s=ݙ؋dL5%QM M 9T_]G?G}3PO#x.Rm Ƌ;V |tnk ,vVd#L櫇L^lZ@JHOW7Doϔ nyYE@$16??ܓKWɷX$ʙnE_9L9AEW'ʬ֩I^epكRNȕ#7l3.'h>)ϗ|)S zI-lFq]ۈE`׭@!*U;@)?6 unFi7za@Wnpfy]H|oYKe2ZaM.Θ>z]|@~QL 73i]5LW^@Lg>_.j$eHhʣNY NZ Y@5,OϹHM}8!g| 9Ae2ND`a K4.uę`u̽d۰y R瑦:ZM,P@_J{m_=U3jt~ 6%)+,gdr#9f}(fBdO>y"8F;݅_ 9k7|׭Gj j44l< Uu'GH%;A\fAVQa%˟,P?aGu_U~9_2}&e2,V|xn8M 5&,=ŶKu}EJs&'ףsj,~TڅM2Pd\ Ez,̬<nHs'ױj4Bf3Yoe+qBĚuk,hXCt찴*#sЊ7ݴYp[G4tr3qֵ#?_{Y*b$91I"޻5{P2uENЩE^Xd W `鴊`%"'\~f%r[&]u,uMÙ}@؀Cg=.NtɊ 0EhOJyiha?DkO{m7V]E^=^ۧ9W:Df4uU׈[ǁyeLZFcN?6%? % j(Bʖ4{m.T}E毢 wCWi ,/[v l 75t U%d4f2prjE9ir߅ɫf>el^s<'bRn3O~^\x МT.e7෋mB=YGI̴#1\^D jSk*'04E.7 ")p|Yt="1LW4&JV5J>I)Huq&5X0t 2 WnǤ\6HƜwF,2<pGVҕ1"߻!GxT-% ƹό<8 K߻4A3 B;6W ̱f5Pqe_gf>]Q&;J 욛EeGQH@H Ƅӛ#d$~}yPѣ:M Rf3:MZģ!vg21" v"7;L$ o׿z,m@zj "S,E,~B BC(V p-[ 뽵.?1|O_;V*?S#bignYW,Y9k$ $^MlbK1ci3p'ܵI,[p)\kŪB#tCMxsd!dؖ<՞eMj4'uH;T{ 2DupvoPS\?A*$Pl="p,z_A6I(qcaa d*lm$-_\̕ chiYBPis/0U7HA˵(>GpPm!p|YE/ނQsS۱zzOhs apAwrlbf5R`v m;`A+iMrg ?\tb/.(w6C1Qz% YCIOLELC,_Md؅AH>.4a˧%>s@+`ij٧ńЀ:ԨW5L͸d4q>G"˥o&ύwKO B;/ފB5A='2=42.0%ڪ\ t F>8a:1(卩i!1D3M,OBݝs_*/Dy&`yTaB7{~p-:Y2kkjBuqL*Z~(@}5U_CH2cB[;+I&LlΊx`]M\0l{uNpNY"_ Vj:u qb4~RUV&rY&kNy9 kؑ s)j# z5e4PӁGJR]t>28of{'JWz/aXR)g3΄>]~tcWazL\Cc0^Al&!X|cRV=#H.g"lc:F孕!ouo8Ndgv1Uͳ.EsxQ"U(s]q!f*B) f~aTJgB )|5gIօ· ϥ8(]ɗ=l2fT=2 Ŀ́߁|ˣ^.1`)bkć}"=Ewms9ّ)0WuXayߩ2lvBLw.xg35HԲ$/f .SWaiV NrWQcK5NX׺{$ ~~Q̴1!vccj񄵜ϓGINS&/N zu%)4cL::.+>әt#vjZfgU WkҦ!lB-`EMuF2:`\LRnS^ɠfHD o1 4X0+X葍| TP.2aX~He|A %77吹T >}L+ҺVDLT(8׊nLyUr:᝹-Wn\8Yn"1?&,2ҨTuèe#Jz)),Yicm5aQfv @p^Btt}xMH⯎blHI7Ba4}M{v`fDDirG❆rTE(WM+_,Y[lvr9}/\'Vރ1/WtfY%$vzW #wvMC6<8g]Pcܲ_ˆPW/I`F0e-#óWT~"HdHML2-3\@\ij'6֞Jc$y%LOK ๋K9Uja~CAe$CO)n\8ʩ~Ysjr33Eqw#e)oW=S9f7DUi*=; :qTg߾"{/_fK˪i 7/fjɢ+_MI7'L'M=<ʔh,m kLޏ{)յ3<g3l*b!x xJ6d \z T6t LdixKwGctNf;@L%ZG,v(Ս4lY06RbJb; ЕPT8M`ے ڃ}c3UbQb$LRu@Ys@z6j?cHB9GjTqGe) *"R-uh hiH"7 }Sޒ$9--$Jq"dQA;/Z QETCI#`WY NC"@B84ȏ iekK+^qO8 oI)Tw-WgNw< fڒxVqVR k(Ļm`_$p[|/L.{E $adɁ+T,[m4IG/\1g5oRԊoͱɒhM-}`]Xerғ/45^ 0=z l (V=()Bj "ZѮFiBm<̗Uo)k`vxz,Pr^8Dv 6R pGKV7v's0# B+/tVN\=,ܕ%VN gtE9kg_zXƋdrQ-q9B38Cx6߹IxCk[B5,utWoS!?Z87UHşNkhe^-7/AxR̖Z1ȮsNaoj0lTCw-7[4CHYAN %KLctݫ"DŕПjdI+3  UPd-qKV@F)50jCǚ)Bx/vf?Q@T?by0nˆMOݰ7։ߥmiEl 4]X<רatKP/ug\ ̈́*i~mTGO:MBڑg];i* Jf؆'Q_ h~m/` p& /x^b yd7 PW8Ik"c9M G/|L{x׎"|VIwhfyp_T|d FZ֎@*oy0NO{Lf%.QHsӊrzе&S_Ɉ68EJo0O=2 Duuno{aWjRAs(c?tOY:gA@Ƶ{^>> 2zip)a0{g~'{S DM]-m>V(9H->oM}Bt8.6 HߝnRn+i 'F+!IɨYSҙ*KӜ5̶? `#*#n2 ab-pb m0b!Wh0ksXZcy$^"Uk nqF·jFxf5 ]W?# @c1xyQ]A\$lLԘ{U]+>p=q [̣b%3 8ndu$^Obu+x23:e*GfiXvՅ)GPV&t쳑a?x\8Fx [8ZYITߢG߯oCoj&M h>W+DZb@x9KHD7=F jiDjy \/L6 AmɸS=qh36܅!J /UqW鉈\OAk?ڳ*t/sT¡yBm>cd+[鿔Y@]&h12R>v.$RUz'ԕS1W};<>sIE7L6u$h9^YyU߬HV2nW 4ek`/PhW!,(b?~ad s@ &w=Mk8xEUgN_\O1S|xppBv />l^rU4 ̊DQ[ts1[G_'AG)|vb*3gb wjR3r;רNwW2M\QFC)<9P'N#L\6\Wqjӗ^AͥfXɳSCqV""@z^j --6.7ds`7"F$%AB0zh'QHJm̠DwlXd^Pzେ7ZW*@K+\,wE#>HōG_k v4{*.>/FyRC]hǺg-~;MahM(xA+n;qyUyGͭ9{8y Y6uCPIlc-*\Vo/D$gwmX ~8ʠiz0SƢG8!Cϧȉ8b*'(᭄+`*Fef;.3{wеn_]mZbS*/}L 7m_XFy2n)>e67F3ҎEa<{G~ 6s. D".||= e-VlvoBnױL|'^S%5l\ŏlt;Ъ\~T,9:,͞J瘛E*;kx:iqZGQuJQcrV5>aP E7Я?w-> ĤTOYhxۄKHsd#HHL:lQgd;\5,苕Kȏ Dsl3ZQPz-q pEjMMzl@0ڙLQew98K$h YL?va]i f69|SA-tH:vANR 8`ְ\YөNZ5+]f7I:Ɨ蓕yҢC0[r^,t8y!zt>2X*(jI5{Ҏ5ܮToILP2&*R3ZT]}ʹc"צLDT<%sd71U=n1V7Q a^UO cJbuhWjw{B;nSw֜Un_hkv}WsJcg *ՆE(J#f׵cJ.ۂ#tr#~xg:'?]+bPj?A- 9A%M-dF4y{# {5ebH2SQrn fCE|xHKލ)ES#!Roӹt`IM,ї( ;Td&DZ {e4+{W6Ņy^U~:<^8l,,TQr踒y 5g4Knh|#&+ܡKO⿖0 ;*I̧_N&]jxo7;QpPތ?qɚ L+20YZ]A@?+2a =\{._QXcxM瑦F>aj)3}UQ]m'\Վt?Pf4)GO$9.{0]EY`c5x7c¶ou`tzҭCV/+ G3h`v_fçڜ8gYWP;j1,DCdJj櫢=CTHWԷnxJB }r'*/ݹ h .a5s}W_z:6S7ԝ[^q@6ks=ZucOUawF( |I/H%pW7'٭ޑaՔg9IUį.^̨|;t;/L`xI@ʛ;KT=h@,ɺg@hVD,7(q =lx>.H@h mp|beU'dIpU(mg6Q~X|_R#=Km (øe ;_r$ 0=;!"l[N_2H?aJRFpwtD=xQ ȕRtr4M=琻[H~ -{(g?E~56}^4qU^ 9f! ^8Çz t$']8|]aڟnV̊3cTmog91i_k⊰bBv6P"dpr_c;洋SLr.۔b6薸:s qCq}8| L'=QE|D[[nIFckݪ"x D4^di[ s'G749"%Ԃk'5 5av`yxwF=Ǭ ,AZxd uB8Vc=yͺЃvu<@zhNX`;xSoB V_NBӂL]Αg͘鈷#_X;˚SpX̬ZAwIm?z~& מ\ÓK|@ ah,>}#tC_`h#ZG  `v-vs 3 s"F~Y;ݝ4Lˌ`E+Ry]+}I9I0ChװeBVrE{JYi:޽hYkJ=y+ߕ-WQ}; $b :C,xKɾNNw4*ZZ,s\5N[̽%,Za|g"Lj 帝Ou8K <]lJr vyC/tty;X(KŊtLJZhۅU;\ (Зmaẙӡhr!EF񩣉w1BA~Ԟyƪ5eWgCna>1^1bUA`T.| 8sfcWJ` C~",.#PO3'S7s ҞY\}WІ-[)' ] >?н}gLi<^rտU>BdY*?ՀJES%sArjRI]k^%U+g-Te*Az>h1=V}m_u-.CagKOaykܾktB&f|/"?<  .|]s%CPz=OdNUh>E@QL%yĜ=aUK쾆*_1'{"4q-BA^` SK|ߨǤꊱ J$3hؒ)VD GS,|޵9LBY/ B` S}"E;ET]cX|KƏ^T 4|N3`)l[+~8/\Z$,k!Oy aPS02 4(߅rdv;;n ئ~R=.5C5L~pg%C116vNJTA/SmIG:wcj_0T*Jl噑eѽ6YBme5F6Riۢ,7N:as1ruEll.HZK︸ϔZ/*s@~g:!5\ }/{,f#c1*}KꠖՌ]Dumwny+~UNĺyliL5Yp23b3?~jϾ.#lEr xVAܧ.~"fNU MmQY5O <2݀XU'l5p1G:ێhwtIzWq%qʰ2 a0>iqϘ~(,zI/v#d/ 16e$t>GhUMRqMr?>7k"W'f#? \W nf!!Y ۴8y^6OOe#Mva/F>vy{8P?4f_2oN?ZH^GGL+~OcaVxPf8ژuw 2S=!2t7Be([TDoag|9*g?,:rldY~Ua7. *x4pK8ѻg/uˆwaMF93e(^sdpUksz)s}v*MLjq&Gf1YԬ aGK'[Oh p W eqйZsTo<\fe(usʤ2AJRIBR 09|^YSPA0|Ok7B~\_ӣ9b*3"n9Ie*Jͱ5a\RK-dk410;PBH_DJ{n9 8kf >C>\5%rY<-03JF y N3H9 ˳IɁyxO#S &_2wPJ{ؾ_BYc k*hfQ\LY, "ik"~a7wEҥUDr[kr*hlX7~}8}'ɀʴUDψ-gT z<(|^)bns<ˋf4NQ֑-0gu-[pEAE.T9oU/ڽ80k"ݱ-pQy.Ry&t ]j9\K?D%G7c0\mP##alP gFX`# BS Li fIƇ?/R ǿy[[>f\^Q@>$ek3e`yr8A R,A*A>f8!#(5K!>XwA x cOvD,8v2¦'U8ɋ GX;ׯ[눴9~/)h^RP>QL!i>UbS֍+8u9wn)iq[̰r+ong2:3^nTMɂРP,x*m_:_Nդ`4YUexY*r!2mgx.:aL5g,d MA qyJ6F+(='ӏU MVO*.gr1"kbYO7.r:FzT]-V{Б!,e@x0,pGsS 쇡h$v*juo,!&+m~u=m-E ؽ/vapIQ|'Rǰt}(;zAm-m.rf^Η |R\I0bR_4?U;td ϸ3ѐ+3A`5[yGɰ㿱X}鲗 Q`:\ُ 1{1g/y,E$i5qQtHBb[[x%4F\-҇bKČzF;ϟckSP26!А^)$QVc]HK38\ r{ƧYf/Z)Idp~a0AA?3{OjgɕZM VY]99 VDdT>(Ж$3(l$@?Yf͐`ɷ\dG =r <s?1-u@'%~O-Crr/@Y3ygU|3yj 1u8މ 2fLΓnG[n`@dREeibך#{>zW`ujb!KO$/jkj FscOb؁V|$rxN}V²7R ǫE=g9AAmbյ@04{^ևPdu^_Mc3$뺄o!4lJbvՎb[#^d[-yxnmT*rkOx  IOZL0T2;T6!9sd'$(Sm9Vk*Ɓ'*^j'_ R v !\w!HVj(ls*-%2!X͡X\&Xzyٳ[n1Q)4 N&n9/4)xsYjѺuj} @%x%4C̜C "40V'`M=% ɭ惪0rs3:I&>VY#ɾQK짊) +U65h-+237r~ y9IЍOIf#*_6&G\q:w&ĺB~Wذ7:Z]Jfs&WAzI]ƠWe͓?u0p)]Q8S?`Qij+[c4 s-"29NHɽ_A"0mnT(ZNZv&0\r(tnszx9Q~ :\Yjmt{|iT14sz3{EzK}=)pH%QI /r %n~\dSI-qokĭiӴm~Q+tgcQ(C'{%Iy^Ĭގ@<_CYP;uW ooࠛȜ2wŤx5|.9gm"#Ū̄d=rwT?H_R/,s?ǁ@ıx㝆B~n2H`Xəm|1r]p&hˏ>X V7kO] Kp~9kn\-qê `x.V([iz8C׷Vj/˹ :G&ֶJ.|G-B\S7u7)ִ%oC2C]u;}%P{doP^}L9p\BK#=t)C6=|*|I6¡1yis\yv:{e*z`nW@W2S}%7&3x,D^by !i+p,B|VE$P$/ c Wx; ]|g供b5&bvf9+0k^ϾDM˛ס@51E%Q0-) ~y*s8pܗS+|+ OA~3\՗K4f|fȀj8}U| ЍXFB_~wVp]ȋp\}2LO27L\qy BЕ'28ڲZ-Y!{,=ťVb@ @ ৵6oL1c!@[3'SzF]_g፫ЂV @ÕAD*a&gx3CP&xe4؀3?e7 @b)'E){uro1ʣlڦ lCoDcrFw L #BWxˍdlVxu.i ()1$ǕŸZaąP88NE3,TnYT~A>j=WH mro0&ꓲ#=8 $"ȍ| 486BYΰKI'$Yͩѷm-K>0E|qCf8Dl]X?m& tt0ť]9w2SdCZ#|$ 2N$υE eDD~SP0*h }{|7H#7Q^7A.t$V'"n%Tslp%1&հ*3m(ʵuS5l;1Tr3B ${AMJ\2MӚ U7Xު6uCB( K-4P.|V},5C!L''8iPkS< fsq oN .U-SlFu(^-.!'ß-tu,SyCߒI4 Ѻr_ PL Exם7~ z˷웩h(o"\ %Yeܙy`7DY܄,Θ~һ>ِWЏt=x[K=Y"}sggaV5+UXB+60sy+7BGW;#h *ʻ&EYz?b ]~X%T >!܈ 4/](L_$rdX7V4ؘ-yCl 6 ^ۨzSC5lif9hnOFGAK"u3^>c.r_ ^Rcx5U;j̐/UboXH5>XEO}2.A$Kj\VT fiWLҿlMax4z_0Tр i*K5;{ϸ(HD\"tA7 =bYzЊmE2 Kfn/|pɸ%@ZE;vr\];;A|OnPS]S5;.6|!=o`RnbgƊDfv<9<=V!1ŢH7r f$G(ZjaO-$l["hB@ ,8*N[4 brgpufIK3EZҚy̾7ُLr=Kwjc98:^ܠ{%RNTjf*|ӽV%aԚ< r 93/##|-ݢ^2Sh3$lSZ~?+QDZ_iTz(Th♛:7TM<%7;@ӗAn痊[,w :awb14xiC]?\_fa<I@ \ QnH#$BKT٤ϥe ^NUdjqA1#0 @O,Ҥ޻S_kUР hYI7,2knKib [yq\6gȩ? n~^ Y& \ln4[ç!'^yM:)V.Nf᳸6{'GV9v}+쯑Nl9ee9KEO>Hiv,~%bD J23[PSlT47.gt"QcO:ǍN$p{=cSbfg<C/ ؎ځ _.K1cyF-:,1'(>փI4]1pQޯذy-rB ؘbV~:KPUtڏCSn~%' u5 Y"9-hE%CCS'ԄN&^&= O:T!^H6zH#WT 5mT92L$y5 [N;wF(KD?z-x(bE(x@7ڶWsPwQRlC}%*!Zgff檘%vg(%afH@/@\]*OV I:P'ņUTU$EˑBOo}CAҰH ݕ6zconQgcc^mUȴɎ5ros HU=s^-eu+ >FNBLl̢HFu22KesCi SAY>}(,7I;s2sY W#Sih#1:&ZosKx5٦5 -(*/9I"%h(Bt/kLXcSb/jSoQWW1([&@noHv'ݩ'KRg/ⵖEu1X(=(' $~kVGB8Fz^z.ob Cf LxsE Jmsh)3Ay4UeN,O6lj#$ݲD }]cAjsnK<y z~mT119RX$qh<zʨvoL4 ѨK#(ܳ!ZLh1}A-W0]i\`|y, `fx1\wuHX&Ѣyۢ&i7 6֠;q<4w / YZ9jkTpv{fs#GާF{D_!ĶKnL͌><:ѢoR/r 6:ڈꂐ+%@oB(PQA'L?$FpstA@ ?hӈ1FF/ ɎRZSCVXTMqOlqIx zSb58&ǭ@ogY?D U}=Q |1m6>Rը_T-`t5q 01Rщ*+Իp57;n?5KX{:D^ @ض/E 2Fy#G.4x,wW\wXa]-s6ծnɝzhKE˵ k rUd YjVt|i7#6P ^bߞde,9tѴN))BI|N/J!޻YEl62?%$6(HGDN.)b>ԽA_z.ξ?eXl5)Ep$䒘7@"KS>2`X_d [ԌHkUY@x'FF~sR5ړO5bG+^o@S!|ڕ&/i9Hr>'BΦ ITE暿D9ڦc2!_'aZ1X4Vc SKӃŎlmC)Er@Gc[Z1D|hr'A ֡6HU3;$6 \ {_4܉1inD Q@fĵ)TK|D.hbjKL%'479^v9JB6Krr*/2lCW/ O8}ʖC7m+Sez6](p"l繋|~-u3z,- +L$yLȆWO+*NMe?5q8dP"h9$ې `tn~"z B2PBFf#j&)3nB@_ k-ePq^>y\c"IJf()Ypq0y:tlDHK`VZlv DA ua'UªC.v}6k7]鷉{4ĉӷB% &(bC-G˥g<-vqcyE"lLfk&q8r0owNIy62[bf;~0!YJ}2"#xQE~||*H-jFن/N\ $.V*l |)m$^x,3hL=^ƿĮϒeNtQ.ŠԚ Ag Fp4_E]Uxseߨzi$=?F4ǝ } n>/LNߍcL$m y=({&8šO+4% ;ʓXiiŠ?ϩ= gy k̖}S13o"dL#f.RlVT!'OI[r}V0`aٌ il(=^LʿU,6;W7OCӅ{,A9Fْ$nI"&o%e ̙=Jk%C!G½R`B#NVj7ti+cZ[Є?< 4bVH 哵QbdFXF5Jn7V$ɡy)C2<F!^[ghɅ J*'‹^ 7C /f ìFm*˹& L )^:r} >^ z|;A[`Nx`?nNoSzce)U!x60 x),yZ0' DϞ*SfPj Dʨ2ҕXwxޅC&Bo$tc%|ʌMJR|V(j2ZKI?g4}Hoa?Z.:}/_RY량ňW nmE/Oj,d聟P@o?c<XC Ma;} (Wr'IWN* b9,aBQ`܃ɏ U<f~N?>h`̰]u>U䀮2 hd XU`¢L4wexoQTzV1,yN-w@#c/1m 7󭾁2WiWZ PC AYچDpBRiW;MK|`MެCjdCzt''9Wk>v(>gko8@}.B<6E&>E:ŗC+wXKs"3w"²>+cSXXTr,<0^&KaubĬɊZ:Ȋ'=kܙ!nժ'}Q6tH Gm#bLw@u8>K1GIYCJY#GT$tѾ:sP`F|K [߁9I3SP`QYiXB #(QfՔ]y?k1odyK5'X#dRfC9[܀DŽ)ˢmY %QX{iUHKUU쵩CBma占Tkb 4Rk{+ؓ^\;Vuwt$P+waߟ6*d44дG?|;q8Tͬ5Bo%W lB>H3r닙lij∪3>ۡITܑE{5 R egqPz"5H .8$UرH `.ow5( 1@|Lo<ɼMXѻ;>gTG%8;"$ǩ u5,Y(,*3~'62Ir~cXpGZdeErG6f)sVo:4F䥅'n? F uydDT^$gUlhYs۶(=5j7,G\!uMĜm`>v9joE;8'kuը&υ`Ηli(bAGGx`MĒ# ,q Z}N^*AEB-a)c56m*É7D+ {aFĺFC:Al آVq.C1i^?M=ޗS \]H-xwIv'kYWteԥ |al~5*J& +;-Ggp\d6i5Y68!;:~Z8+ *(@w hJ \ "ʳjuR`L:z: h[G8^& ;͵Ư"RToY%F;>liQrV+_\]'%l;J=-Xk+#_z?)YYq+~-1!t%EJF5M%v#[) `9RֹЇ-D# MR*WSS UM^}} %v|Ϛd#F㭧ZJtݚ}zUAt .;CD\D(NRG0A]KXAn r(;l(:'kLdhzg=9ĉůMb"y]nt>nJHwv_9h`/=( efJVrM(9AD 7wr eGu)ε"FIq4O'Q/I8!?܆оܻv^^L.w9EiMVz{{b`Ί UrؓD^ԧA>5łhMj0i}5,I;`qU&ʍ"z-HV0% NbV2!emjI#6e%R.ڍ/á[o; ۦE(qgq4$ f|la"%,ɶCuXM>dfyklrLgPu^xUW\/Yt|;gi-,l*`M7WZ22yf: FM}fx!8ζĕ|Ξ 2GĔghu"x?1zoHZWA?kj<G] ͵^6wmsh&e0; Q#ǟow[ե#Bq+TdWQ/.0 Sdɗ;:ī ':+} MVF5_gй.DoTY,0>!5y$/gPϔI gXbwlRڃWV6q]dzIF(SAvNk%AMI(&uG\XfBprR@ԟ~#NH;VJ> #+eԀp 2eg~)wJp4A2Rn[}m3^L"7YӞ؀4O>l1 djv.3jyO۩ lO(oWai}`Mܚ) '[p{efP40 ~feB-/fQV/𴏎"o`zON >Q;z$|m; )ecm. α QI$}1+Bs2e]pp{CiW?<,3BP'0R F+1 L@J&] t$8 b-jFJ1׫ykn@^#9ON^.!uY[ٴeE*Egǘ`}eq%߈Όid ޜy)l<}ᇐc}y0-Q་ $9H3Qs#‚7DP²wb1LIفQleT2+N^u;p2s&4 +J,MG%[ë2!0U Ɂ?f9d€z'\N_Mȥ^H CG' ~";?"pXWeP^2%soE@TNI*`1 yH/&>37LS rE Pr8fwʪ)ɷPM|>琴,$l>;UoYS. ׶LcKpknCVؤ_2I @mv"s~RF+flu{pJ͛0q+oN\A'7C`h)%[Sϻ 7|.\B\@.Pz=ea85RP>ֽb`a8T1&\2pJ ižpZZc{bìoؖ6^j^Ar¸.4@x3a@q T }r,†!Ucn{{SDOM9G?ѝd>#b7f Ukla(hzÔ7ѪbYll+|]w-Bbmq"{N'Mt:^FyU&y?Tv)"FU=]`m%“Eor˒Y!zvF亠:sD%f;u_ {,`* ^ dTd@uݳ_pusqnl#L+Xsl ow3}u/^t$T6߀00!F3ZU_-Ц&b2 Ug9 E>cż5" DL y9ˑMkLo ==5QHcI>@/6]h 2 ^ kqs4%!|5&Bz-M#,'s"ᡛ|WC("K]IKu [_,I@{JU-QdFCOecl0=}F@8< { &߹k8bzU$5\b9\b8Prt&ᒅIv&֜\ ǐY\雓UUI1P`qS;VP~*V!LyPt`eߞ`,oEyghBr-*6I;+-%3 gQ4|Fq,O )6/}P r9 T!҅hx*&GUeqaL7QJIzắœi}^yů2>!?XJ.QzEd}qǙ<'25rww(q]Mac2Z$g{ooG ?sNA]}ئF*͚O8+4qN 3ݘ2B /ɕw |t[HPiȉDm/!R^P{t<\{ljfK b EM=5)-o5]<& ܂#+%qvf s[nZ5*I~f/4x3I[I>,wjoE,$5RbF*ZBDDfr:0*$*F/ J+\oEYMtlN^Ed@4#He*hl^Oyˬ~m'^?-Ez[b7 iXuUJNj7Um;V#vE4BUȏCq4 pT->R!޹.d-r 70\mB׻x(VcFUpDDw/R/5x41TD7Ɖ>kO ˩'j\;-*݄-q fPb]%h+lӌ(( 8-2C5t~*dXuBڔ' Y?azJm_-,F-[ Dݐ) 9Vtw{q#:cG,$>-Rz(й6i-רnȇ*n0 3^ ~uދnn @>~$RS6%D)phCTMdβV[J$ c' r]K˲ֲ**x"|8Q,`K4Xc9':C:3pCkg2N\}B4T#Z`mCzO rSCA˴pLyO6z@ÞZ耄 =3CsQḧ/\mm!SyCU؞l|R]S SIMGMtћ&_}.ͺxw‘1H*S,xYF~y.t7g1О"vZ 'IG?Dfs?8׋M[ &A{GsQ5STnɸ{x"ΠE6"Rif={fbrj:tS瀶a8T{5ra2  RߧuQCC8ߍҨ [ ;ai2B96(δ%^i4tz.1a쌠$bgm\h5FH%p *0S8),ᡀ@`XE5Zyhj xIкp:︟0eOdƫ[C' #ۘ1 b:|^K#@ we֊)z- *V/&΀=fSbt^)A\e`ߪu4?eF-dzk2 A1N_3KsT1|YWbklm1xL0%d䚐Yؽ\m {H>ڦZ1d 8$_iBPDcVQ >Qr.:⪆|V3#`ՠiظʢQ!m6Bk(9]|\I}0/@#a45Wu5)Vd~Ȥ"8z ~..|>?rޓ_Se=`j 2R~ x x\]݉#OhDn=%v0n}吢әI &wG8"mG +Jև1FFUwG hie u߾c!;J8UX^i0=DmkxW|,кjZ+AܟH05Kf&7wEVl鋗NE< ?`8=Qkv03n~*ӕiiewQ|gg@#*&@MewN @/j4\nG2:=H'gR)݇el/ Je;JG~'86V7ަ.rTޭ&ǻKre{F^4Őe$Ǧۣ~ώlI υ' tmE;"JPɖ #6DY(kbFޓ!pzbWʀD@Gb<*Aꑶ`Ni#iXȍ(nLx65Gc)ɰYPqIָ*U`c.%F[]Ds'CnV[!_ 0踱aqC7 st>;VƔ>MCIb@*` =v V{W/uJbJM;i$")?pǸSkeH/-W5 }6G/S΢*q4oVNՔڗr JMa]z?_Uχ]0wy6jji M`h/0]pd#3Ks3bG+ex @ u`܅)X5bc!3p;{PIkGHd'g{+iȡgV{9Эܢ,d;q͒켋B $RDrMDi*Y*(ºMDDSNy0+Z(H]TO.LC>|O5>d2 .&fDQAkTNDb$7ċ݇bg1}EvIh9]kڳl׌sA~ ^ɟvj>7ǔ_jA3:0(X2lk;LT6Jw3;KFp;"yzoI n}amD1H#AJuO3,O>x n6-SR1VhFfkXHF9oUA$JHpH^QLکB5*a)U1ꥪky6%}8VYcڈ=+ZD*l0 ;hB򵄢& Ń[ (pqs<:eӝ~˜\' 网ʒz3hYmU=iZ党79%N%+92ӝ]xU|a_Ajm&V^<,<kKr@z/s7*]$*S{Ib9:%'07zMGoV[*4]9B*&(M9:fq GO'=C.?WQK\x>^/Kf *>5/ɉܮraJT˜_& 'kll{D:h3Ζo[٪Xۛ J\pW5Jdl.VT4"8"eT ~I;6Ͱ  9 ANpmKi}4V2_wL hjNx"= G~:[Is@&Ks9"=Z_&%%(֋MO>a݇vlRRq{PX @oJƢЇ-.rNrhF͌N?YKH.0YZg:d_G>eAS0. IG^/r*#Jz{,X`*8h΍[/A_4"?09Lȷ/!PpL_j,rŁf-A`*1Btf8 01z/s|4d+=;m9O]=@i|ý\'Vu#ABB)3;Dh`ilnM &Ġ0mU“{5fDl[C^%nD9 ĀWæ^`48n]dzϑWݧK<\~*i D9o!tjkBa;$,e ^bM  5,@ç7uJh !qȶ@Us<1]!&R^/LjrぞV L! )]AeB췡hap*$*[9P$~Mгtr\)AU-b兟#XxrPC' 6`=.Ac;ij<צKpJ1S(c*Ȳb瀇`~ȯ#2Cky7,ukw *geUBOpdU&6m ϥ6cU#x<ݺ ;ǒ"znM^3rv lQ =}#/W :dB.!HA|ț:d}W)wUߛB–v5QX 2=@." ~mp8 =ƮJ}0m -K/1ʩ)wp~Yxde5l,xF,Bm9abo5.û Wo~Z1F,5{`.VŃEdT?hv]rj$T|lZdeKL~~ymһW锂:s x;Kq5G7vGJ&J=-1Fl\@({ւѧ\&ufT_롈1cyo齈~&{ KaCd:Cm>{S4-;W;3#{`F&r0e{=_NJP$oq\Um_%yX'3Cʒ|PGݔ ZŠk+*]l;]+Wl 0lV Fk":` "wUF]j<F@6a'uzUz`=5wR`<$.L ^ٹ/arнRC)9LL9Z(e™Om@Ͷgz(!:Ũ%F`~6>"]mrh4) n/Lu*W;8~暦ddter n>;jX2uw`K*|+qs"RxqI@ǖFvB)5{tw_oAFsuѺCܲ{Wf;.$iȠx"z%-AnS Ǿ3*|ͦ,&g})asW^ 24izIm4b2lk1 ~"DUtT0Rv0.O;//NuavqqlL=N_h}'\m/ObiQ>;pxa,?jP`_bW ~И!)\%=65G-;֐ÚaȔ tx-T+^*cCbTbȗ1͹nFxeiVNqdzGXj ilԋ޷D'g̱ۚFG~x aR`~=ZTH<[$9}-n%/0W4<*`lo[>sYؑ\ <@ףz.:L,0_&ia#`3&H;D[t'FjE5X?0hxN5,(\F'"WS'p6;y@-QL@=\\D%W4ՀQ@Ra"I jyz2;⎉q:tdK!VOhL?jc6uuh$ddVmhED~=p"NL9%5$l|D\%߈И?KŬD#,3-켵K@3%+@ cݍ<1mNfֳ֬(XeCJlQKh󶗴Nr8zQ˶z)'5+C+(Emp 9:i|jtA2ߗ] M&-%_3;h˥˜AokjYB*[S_ϸnз#Nb#Ye6?.ncUIBmEf:7dl^xIV;|i鏌lEB6#|Pz7{z$ wi<11C=b&;ȯ {ϋ<4$Pis _& 2 }M1lT2iDR5tjА:>;oI(ʲU1\Ǭg #!n~e82 \5Ďq!5H[ 󛅚MxH#'~^h֋B ݓD[[DJvӇBGrꘞAc%.֓܍Uv"=]W?fee#M}{rX\hKe(,kDVȾv,3 S E`r jm+~q:dtʹ6r1nάy9¦Xm쇁;ru!?:]V];]YbHŢ+7R 'ETH*vvq?B*\\j$D,?s]r< cB ;OcMlIZ ×Q<,r*3nޣ}$@>l723[4radjz&)ŴU)lEWŚoG^ahQJK7xoWVyDT^Rk˘;MzˎqNMR9.NiηBǰڽ2yWQ:}0XJs$f$Cgc|zc=E$yQ^ S:WWP dJְ1!x3Ma1a#7J23)ц3沐  zAXpL%`)O/ߵ7do hug ~ɶ0A`B64FJЧ;l޻o:RvJp?ǐ]c^KD<)&Jm Kև -?;FxV)LSsf͖n dL$N}9ᆅЫOS%>21 6X#d <\'/S_gʻ/`#Ҟ e .sIش_]!X;bl 94R*Zz0? ϊ0cCN|Į#!SM`" :%1 ͮyeX(C<3C |3PB j̶F+A̗U61J؊0›mY 5A"鲣x6ߒGa3wqn;AɊ_4H'\&LUIi7Sc^[≠%6xԌ@cLo5H;~q=E DqtgnXoA w3[. "EKNT4Uނ P.(B̅YhBB ڰnA&DD\`IT)Q!aFجn'ySk1<=ciq]8 <Wq.S† Ǖœݝ)xcߗOn^2lfn}KkІcⱱ$T_J[^70J.&6SgrvPel d|5ch0r%E^ڟkHPbo3ӧmf,!X1A|^K DQ+YX\o]ۘh㼒>,֏1hW,QǕ;mحKgeNo-2:NN7Zd;VDw:l[(m^jI˜Up+??6\Ğ5>h8+ir&^s!s6夝vP_/DHeeo;&_wP9/q𠁴q}FKp7_o>ᝢ >jo5gų_h=mo1b42'.e>C(Cg<9HnocA bz}``6O"G(2.(a9NMG;8/ں@[W#T`yT!1kvG',>uvu eێS?^%i *IxIbhb-9tTuIPYzԀVkBeCS|eƞc~"Md~|̵c,Ou9us_qYㅪ>_>*\="G3] k[ToWda)jDj384ºAuSCR!. CWթ> 9xSӋj A[7dGuZ,Ӹ]gLN\+lZ{c{a7t9&Y%6{?ڒ qG!PF dkk΋FtD=dYd07eOZuKp9Q<;M`/X}fɐ|)ǧ^޻qls󸩖dK*ڣr~*߳+Sם1vi*4.S=u\+alѕXZp5Q'8 !:}8, @kqC1 [8eg`gdQfS]imuYru2pvJ.G,iEdן:=QU2L|!N!OAܴ&[oXmM!qn.B5UIpՐJl` dۡr7o[neuL/De>oH  iT)^j=a|Tju8d1S}&Ss_ ޤ ^)gg- "m1퍋TlgÖ|Ȕ#wmxn#H[ۈrR~pܥa{c:U#XIcEP $AAn L]wyxUD6k*3c6NwUsLkMVakKWi(+eUwM>PYI!(?٠ ~[G&yUaJfQrQ[ )%v<_Q<} 13^9~: 1+)G}纝pAfF*Fŋ,BhOa D!aL&1Nő ϯVa:\%)z{?_Xu{6x/\/V(w_ܕVgW3G,mnKh vSX7nsEpMiemxҺUAA/ފ * MH}a4ujС~3U;\ Ӟ5RM죇&NSa^:odjD W,.o5CZ7KJ\ hU_zO63tG< bQ[HcX{܇DtIw 54=L!{ 9@X&< T`.HDk$rխ3@dJ-PI2 h\R n jWը]|%5xl?O/^e*87EtL[B=t(kGީ1XRȞy$.(}"p>kY$<@=aRmTy;z :}a2C",^Ig?Z<Rx>i~Ա|~w 4{S'KjBj [ o5cgK"ž9 reMF&%όEZ{ޓOS( fl-@a>z֠墡s236ˍP5Gp KNHHݷ":3^_ŀӽKm̃'G::Zاd}',KiVkpA:CThK{Xo9a.DhGsg݈jΰo/ryޚXމf" ~ ;}CĴT|f矗dk_G6;YJPSGä1SV{gͿ}5ld;"<`v'tP98-rzٰKV t3ۤU(B*k:~]Ja"r^+1m 뮭;x&ġ#!D33"3S[D/9PK-42f8$) I)H&ƋHy;Lԧ[w`G$5?>  amH*[4L3,o`\^k3͚5\}|elS(&I_pCXS:G2R '{1w b0#C1{"I֩002w^(9 ~؟yX˺G3tLEއbVUj\! ~KeW=Xb${!]_%k3ʜ9z56H>I̢Biv=3ǚ9$G p:pc!m6/8,"jW0FK=;8]?eBwuupHdrMr8R[24.uoW pq&T˃'Xd)\#2Bp s7Sٴ4#iU"dY^ ]dyގH}|qyw"|P#rI͵?=(?1@ ٠&(RhEFh%[">U}Koa~&R:nMiصJL\lb'"Pi:$lk. ad;9u=`ŸU0wCkwl^HjDA/^3O;1}dŽrף5+s2!"hnhk'- Kzy6C (&L? LkHc&64Srp̸|AGtk11-S40鴑μ5Od)4g/&ex%|j80rkr(]|8yrR:e,pFw^Kb;f-&4%Pbv͛jh> 7āֆeYl K]uhnHQ0!W\VvzG#8M+V HnsBT1k=&~^a:u>`Lk'^Wk]vbkb<`d-Cȟg]Dr< LBSuEb6/>A؉iԢaώ[bP 1釺,4+$Ω8\+װewGPzD{B2 pCn:(Z2X=4H ؿ9ݘ_{=w&o˓]H.Brf̕&/]y2ERK˓c]ypcc]U)efFW <X%FT􎂿J{RA$هH5IEg:O|gRG/fK.Om}[Q5 gF)1lxޥGAlMD.jn8/PK6 :HCWYU:롖+q"b"A5 f§:d\i¥~.a&<0[k` ~xPC>m?r Фf&&J9ɴEΊ'*% jTcl4\C$. `5V{Qnh=8Uz(X}s0{7sS69 ʼh<6ԩ p}+lr!d2p ~EIC;(o`kA^wJRdO/t5 o@ɍYRL9\묩;p %TɵqL1 NneU! ޙWb/xb/y/8)1mӅX nA XbxoC qV;EPJNimXFT&?Th#9jdӡ&8|OT+ ~lT-9Qrr% V? o*A|R=2 <-byl B ܾLٳ|c5 $aݭfhLw6o !Í[owKnoz<(I g`;bm̖NzT]l'ï^m E.W*[<k&AF$2rIJݎ0oRp9(_D"oZ3慝&LK z\'&G9㡙 6y !O9DW9gSM+JLt><'r }\gT#LH#M,+u[Q"L([GFX+B뿅LG{eJa}irI`)[ ŲTnJ l`'*^ڱ"3%^N*)z k02?k 9dW :Ėݿq1n&Y٠k+FH=?۸8Dx@5m^WD|%Ok|[rUܓ$fD>UpNZ~F]_?X>JaH-TrU|dKE ӕ KG#QM2pS􊆳gQFU{G V[z'mq'ABKNJ`mތm JK^ЛA#Ezrt"qvf wSrbetVܚBQT >lq(CHmYGa\:jh-1ƶV6뺏9ZaɯLr '\'u+0}+Vnݔ|G9]mofLAW>4#1NXhM*VPT:c 3b)D(X),@Wv Y"EP@@%ߑ]r}A]@UՕcDk༹euqݔy[!Kar`a"x#K=s XֶA.3m_#ؗ RSa%fLSrM>*^MK4G Z#A׽P/6 f_(–CUj!̬̽& US\N[#4r^jJrv,XFh#22p2u6Ke h )ZE7.WͲFEf,2P>Mh%/:  LE"i`ذ#h,`cQH<q`M$/}rm|2*QrTm0G4.t-0g٬-sBƯj +>hBc>[X=v.փ&׳p}VeB#Q>eM.^x ׆MIT֓3FyZ?F\*=5=rw|51Isfqj?v+- 3Zv8zD^%Hw7J@h|x;XD0;D+'V)L(٢ÿ=bWk xN uSF0Z<,k?^E-^ 7/ڡGDXu(E'):Po)[2 E_%赍)V,n:SN"@C{+R|ވBm(JE r}4+%iC˃8j=."BT˰Ѩ4qF+ }1I2PൃznwJ5ߝ= Hͺ "FP}]|z eI}lLU$E:"r'UL^iりMp5f@ )Q}`F6ly҉M`RIT :_ˏgTbQ,_L&I)- Uʏq6&2)Jd] )j v1+g~txy ZSŹCeût9fy~>R௢bq\uvߞr/<B{WqQ³XY! l{c6 [ MWuy+/qz"Z#+sB%_dp.EhkGs1|%t k3h4x_WKg&!!j=f4&앙@*UOڙ\v >PM0F}ow%Gl;zI_ }.'~ >]?l< ٧,ov}1^ PЪQ0G m϶>"&@"L`rs!Ĉ M°ı_iV?^T(k}8cw279JN;[h+A5 $,GnDLy{Xh;\Wa4 Y28B(\Y!3{h+吏a=kZUd .A(|I+Yh[e}'`__v╠]tX]ӧx) !mC a OSP/M-hՆOo5ɿul Ubj4Rd:ߢ +gЍMlN7Ha>3iV2,z)Sܸ8>u}7Qge۶{aҟ٤}>Y"iOx$xˉI:s=X^ Ӫ+ଞh$7F rHSh\ >%rQ1ĨSK@A,.5j{tQhFNpuj![ Ww*`g4nXsnKyy$KM08n #B&-AnX,]~Oܑi155<;m[Vf9I^鈲8C B=߮Hf]3Wpmc:,q޹ΦhƊDzO_w; W\r8?v0wg]*<O=͵4\#%KCjeO]XHx:KK'%vyˀ{3l#7 B60H7EwF,twlМTU=p*x0iR4T?~)4osa9H0b7ucIkH}^-7"QC79$暽4ǨQ6ܨۛ2\y%MufM̺Ilo1c%@Ҭ1%zA+!1`i!hyynY=IUG0>[;0rEspSX_1naJ]'+<{ aXC.iR;6ˤU&ұ@~ ~°{V6_/f; ZA59{ p&:.t&)i[N9 [H?Npf]))=vsׄ,I?;uA QݿT}x1g`?J$1ߣcմA2zK5AiYZsWU@*x(Sr*ݬٰ2Huk.J0%t|Z5#]M]hJZf~y N")>۬ F5w~X?ѭq"1d-F׊ HѬ7`o=GN7J@ h4]@`(>gxYgj#ʃqW!w>OQD* :e=z9Xih0`^ʷuh j:-|Sn(8;^` Ԭ C"ut!8Q|az )nB>U`E! bl2U| G NXb4oR&MIo-e`HJ"/LZM꣐e"'Ұy 4 igΉZ<4W3EQxy Ϸ sƆɷ;L>7Tչ;e biV`Y>8Khp4SHFi wY}Ťܕ~h b 6 hBu/ lyV`&N"2?q?Ї"j5@zF?6xbH" ҷ` 2C?֭ `= Rur-5VgL z0ݕPǃ3~Zcיn_ٝ$*%&Y-o7^i{f^QㅖDaj\#%ׄ. v$shTO:v3ll6GAV3E: W:w\z"2 P"9fPT`Z3׽G1cbOkbK\>#PbMV7'ٷ22d=@\ߥ-U~CP]NOs6Bp4y#%3{eW6S3.NTMn?(*#"^F 8j;Amꇑr\5$"6q[ &c+=f7͉];|f&pyn DZea8UD gЅZP,wU&紋ye8 'jhhϔFL6C\;A~*u!/W;oI6^EB,N^%2(࿟J05`9h0 }ٵN(.|//PEfOEGW7a' &:k:ȥ췁ĎXQ°'ոm. O,Nӓ| 1{s܋g <4Ψɬ@v4k6V^ М:SrN">]fDIYc5\W=GW}тe-z,g7pG [hcq©FP ]m[yMoF`%Λmk9@~ hKZk}V.mf~aqh_ߥIe̿_M,w;12T,ag6NU fo5PN<۠! 'x,2LI5L4ъZ#+ FE'DDHMB38̓YHI>  3L$oS{CY 6Sȟ;Tr +_:\沭7d%]&WR} $>$>TdAp$M7L6aE_s?(1#/ްQ'5fצ$ZY­iFKc^\҅n~]6ܐUd,oCBT[,G-XbSWG^E OK>bg6PjIbZd.tB[AE2\Ig"0^xs#CK/! }ƴp~F@@n$nlwg>?fQkȑjLp84)+'OGl2,nWˆK4k m])ruk=;*!y_ΦPj77F GeHz/?*j( Z%E|#9O "ʅt;z1O]?+79RNAHt=AAkEŚE\;JhWFrj `$,C0I`a=mO>J=$%&ݺ> jvv'.Q^Qrpz1tVSل9tlb˴˘dX~6o}Au#Daq"q!בwd!0QA["F[A,ZěZm\.,~ʣm:͘KeO7`i !`[i?7"*ˣmRC[}7!g MEyZh8sOK2 *uM'5XtO9,5ʫ샀 B;bg1-2Εߢ=OT`uٱjZ"fb]߇?c[v$ Խ(9;3o{JRg@Qs'@Uv832 BpY(Pc[ks1O(8]G,m#r BzM@9y(H!k|d8oei6t!R#߀G4$T0""IƴF8* o웩:th >+9랭\4׋1$Lv_~C(z=L/Y"gƝbTәzI (>.:20 HFÛrcZaIyuii _r[˔L_jP_ ݬ{mEMYׄ&Y. iYJ%JsIAَܮZ \G5j\:'p|s;pJ1*Ѥ۶ʐjXj,IkV5^0`5 Sg&EDu=o8f}@M\ 7fѣةv #!0x4.% Kch}[9ʭJ "QGe2|:ypev`A~ ƈrI8q/[w ?=(stڝQ5U[Ei0a>ljLjGoT@p/XҊn씙҈Gg"Pb#3l*,O{fjI@Sec؛od90J{?*@_ 9݅N+9*%fw3=0fRUjw"/-Bb:_(5Tkub}/('ypXKƁe )zskZGmRbVKT_jETcS 3­qXI Vcy2SKorea- 6hOtJ1Hbx|ؽCtm‚3 $Ft.$Knw?IDQ?*M+^g9U-m42gj?[ggŭ;q'*uƑs 5Ht‘Ң.\ߦfe ixA%S'ύ[gy|bL XrYO ɯnucjyO 30v}/oǾpf`85$@Ч78WU* U!ݳ$[)$\[yR~l)"3{vkmPxDbfs?R,\ rzo~_O"4pocTFWEHWr%/$]7_y:liQboNlG{#̇;ɓm?K)L1PviUI\&O):()c0VFD)KߋΨL؉5qo_/Cx[fa*TnqĴFiLoȏ{NY"i!{Mef^AQYt=u}_гچ*TnV9=ruk'i;iF|C.Ԛc<v& 4@Cgi'^%$#35(!Ed-,@3B3kF+4#U832&/ӗ/ܿ,_+̆kOYT 2Wͥ~a 7 R۷ΡmX2”fPK47~,hÑL10hG3S43S z7W&|"gfQ/&/jNxK@9] քH$JJ2Vݛ>4ӑX:BW4Hu.1LtFSud2fS F4r^ JVDyf7СXLUeCT:Ζ55otXc{=n6@)kr*mLZgm+r{wȐ'4B{9>%A͑C^>4c@xc4ҤZBm}E?ᝐn#`cWk*Nv%6(%׿ԫ MK4wTZ׸@LS(T XQiW'D@ܽ@,}#S3< F5{w{{@A8}6#hɘ4&y+{;JU~WGTD'vjX H/RGBF}YK{KMPk}wҹQλ,hM:y;%`}7C(~ZMgFX| qV;Yfݽa/!f4')ZJ@!f.fŦuQB̄ڲ/%<0<YN 뷈U/+ko(0l ny A)qVx yAh53s<2`o!/ f Iy W郤.I~6!hqաg$-4ߚ.U)ԈL3VٲAJ$wU*- B'; z]̫: @c2(ج11+R (K^˟`|K"5+޴#1;#S]Qt6)wlWU?^̣mƠ`w^Rcs=Ni”oN- (矆rڱa# aKts[c!ul+J#6E+?X`ݱ,x)G}l] s U %˳-/!6(4Tp?gWygމI/Rc{(eEj/NvQ9"~|fkת"Fk}hBo#AL-./r"gѥuUi{* KN^/ ~`e6xX^{bdPq^Zdǘ퇹`!`% IN7(@" Tq֬J](,[`Wgŋe"s'pR`Ϸ ~ i=tR˕C#NW1-a[?'Я^Q/P֛^ p8!L&G8ܭ}D:C/(zb5_muvr Kt%e])x+ɤᚿgfohJ"q(4 - o㫞P䟯+Eke=dO%IxOb>`P^M40 On< tB 0$ WQ7 vO,AP=9O`}gJ&dAE?3v(JcLGE4^n uJXs0܀Mj8@W8i?o\Nb078K70ګU_]M_6Tj4Ɲ2wb:LUՙP4%Ől x|;v gbr&}NnoP}Q,K9z Tvy M>ޜgzLyPݨ^6}vmgEy Ѥ5'3%Ogar᳠j#X:%w[y!%>7- -*∮Ic𗏹"ħM, 8a& [Iʖ-0y'~<(yM7eyX9D1ҳ\Jp*ʔT Pq3uY!q[2+J  =qupgXc]Gɒ* 5y5`o^H\]iR7pH]zeOjhm@W~8ջC/x-:޵ a/Je@1ɨ$ԟd‘ $^NP|S1Z7p&K]mݧg!~FgKŞ{lX(FK|\f(xJjƭ Dx,fVARꥋ{ouDy \w>%+fƒFx6Uq2N>5Yy\+1ʿ"2Ȥs)I+EuI~Q\kZt97 c&#lS{6# p} nG'Ar!rn`~ V\#xq|r#FC}7Qr{S̳"֞HR86[]Pg~7ԯJV!T'[ *ko{8*(f Wjv͸~l wOQj2r4.BVHOMàhh TTvW_v ~̗MLS)DRM z9x`8{brY2Z >@ r`;l}Vfok|$ˡLM~6vLuzd{Z OUC"UthE@2Kưb:047XB^E [8pq+Yާ{4?pxݧ_,sn? @WCƇT K^K= "ii7W"H1-% :}DP6fUH|t }nHf x<xE`?eÞpͩFNV:X1m-Δ 6G-\EdDyX  .𖞇o@4B0'=iwX>.9Mv=Ik Py),}C|oBĸGZ$5x2ZMo+-33x1APW}-bH=(aĺxA΄! g_KʵZo;GWwұMQI iI7qdK_e(ͪteD͘7$vqF15CwL%93}unO?unUA* iRW<*CxK`bCлz +&3] |R'4{8m]U*Ts&Tt?nz(tZbsOyE$vZ`~\V K$uGxxp5@)mqMŊ Kx/=u>Q:Ц*GPQڽH#3@"j* pdj)yУl>4,O>P3(۶5Ս[DۉIG!#GCAA=$>Di.ΘC\3nS@ ^U6bL AT}/[:{ 'ߔb'!qȈ Q=ԭd\݃TƤwS_8q1~|ԌȆ"pqIq |fy)(<^{ګbTUBܐ7=Ph$^9!ܗcHwkU3RutAldAc7Y3+ۤ|8xY="-$O5 4 Kȷw5W gMүy{cX#ϕ3E!jj7E!B0NBQ iLXx"xGVb;tPfwveaƎv9xvuQN=Vzyev@i؂RB,7|7aBnGT+\\1K0=4>tF'BjgirD0>@G!bێ S Rnޗ%> #Ueڐ']%q<[ =07*hƜ[A12r]Z.h ŐD\X %,NcSIdP#5 KӠ2 lbF! =L. Yk8-Eך)=f\EfpnFƢow"r@hW DdĽ b${_ xܥ,DaV۩/411Vz`LZE=Bw+O-majq8ۧZI 1)Cm~t=ʼS vKVv#X|4O_0zU@ ,£DO{{>'tX F]Ө5sBYom;H,Mv{Kow[h~0<_G2:RHxh3=hɼ84PCe0'*epj]ה_|nٿ)ںUS.Y;#F t.(aٖ8ZHV/^Y7-)! ԊpSRC%gYSsZY߈KF7Wz԰;dn\7pn"{Z#?s `xS('d,g ]&HyѦrrLf8k8bD6ćy(>^nӋS(XT%ҿ]g)!FB4ME d̢Š.6C'!?xА9pŶY1''ޣ]cD(q y oWOpsip4* l$kJsT9ƞ ;2K?J܌XYP|t"h@Q궀cȔVmPg<RI<%65C潕P0e4N sF"ky[K ˳ 6;:r7;k೟+M6w<1𩁻qµV-D2qpc]e}G}~yfԣu7O gb: ɻY O 3˅܈ @`A"ӐEIWږWA%w*m/`eh]S KF1NO:b^Oe~1[{Y A\ gF>_{Хw%BJs_=33B8vi/.Nφi~&c8bP@)h6 d@ɃG?,Vb qy0*:lsVvϒX+8eGHdƙR@h8kI`踣?!ˢYkUܿ&Ŧ]u|5=lNҺq1 zT7Wt1}e_Q+8*M+veYJ? Te21Ew[+(Ι[.廫I}3x.$S ٯ~Sռ8Rc]n%@=aH r '%9׿0괮xˆH 9j׮{ AeOɪ`ÿ&CǎTfM[zdwyŌU>Hf@1 .^8: ^w&8B)T4O_Z&rSph(OXoqͮA+)E6VT[˫ܽe D nlbSTBUZcy;qu)-[d1J$?lwo2 =@:Y{R&ޖwۋzg;qQp;tsIn4VT%I4NՅgՀIS  j(q >2KIl1P5h踏ExVqũ C&'ICTu@8@` C2= fvG.0<&}PPUgtUUys(qbw>"^W: @``~ڐF.Hq.D[kao6[ikPzbTpȁ/[Lh] $0Dy:cs{Zx[P`IyA(Ձ2#&ebqQYIG];m(4jDipa=W0N oNx|sֈ,fתKV|sޗOU_d9VzH$oܻNN0 ^S$]E`a 74G{S VR /^b92Ź@E'$rG]7 C$5q7?{ Wmsn?Zd~YrKoA|t.%"6U7Fх2ZAdRI޻cie)FGk Ʉ𝃟VmX:@^"wҺR`Ab@(/股B4]ZH[U8Gg ylLQqM_΍(߾Á*8*!Ȫy'pJ ?Wp}Ъ, ?^C)q|Ru_mВYE%=#ԯ:RY>^y_תN2"I5{`v(5lMuα{q1`H1(U }s֟߼q"3Amfl]Lک .x(zwAm8Hi|6ApqU^T@&3 ̤3iיz9w;b`Ȳi8me~,C aˑ`SuN@bĔoT'ܒ>82$-`NgQwpå 0AH4E.cZ}&{WWzY/sT yfwmWoL+$FXIqF>NCQq(p}upZٗGI^Ƀ%^זN $(2;ETfBuZ j/a1S!;7H쨏$c4zruQ:fPKq_I/hTC bG}ҟ^eKFFjRЀw_ $IC V]ʐ;AߴgHolisM Ahx]БTZJF}C\ٸHMCQoU-k*SoE>F h.U wb nx.%O: oiZqC'NPrrZm0ٞz"òF *m!ne9E%h(;Y2ojIqJKI2y!+8K}1 c\ JA>/L-x?lR[~~xcOc l^kF U]%ֈ;Db H\jXRIb*"1dlCb4e^B{Vs`c'(mmrPooACp$~MPM[^=Jm3$FfFOѠviZ$0 );HP/W(eWQo-}d 7qՐ+& ئ%4~CrQ>o__0RR+<IޡsG|}i n$ ̼cW'IRm̠(oSc c1 prGmj}p4?*% E<{Pjfh4' `4: TV<6Ҽt=XZ1*T-nIxctD[z<6{Qُ a廙T0nIAnjjʂ81AG!erd`_e2j-?Nk\kbN[Lmghܙ|?'#YjVRd/Ngeˣ>0 YZmets/data/twinstut.txt.xz0000644000176200001440000026312413623061756015256 0ustar liggesusers7zXZi"6!X.] "'Ë?sRff$P$IfgkA1mrH6*a? Xmݥ#UK[0*`mCk@R x{GM4h4YuPh,V{ DI#U?nyV Cȶ!SVOmXg'm2à2g.wx3aUǔ-Ga&;ڲߒ3(HLP2QZ‚~ߕgYDž[0mp`9Gj*sChQ&*Yr4TbH*&-2oB&c,3ElKP҃ |ȏI0wGF7@($w9Xaɯ_qiw铭@篊YLiy]}䫾pMrsd(>/] 0,myȄ' @|?v-'΋1N08Jk.j6wAyh&tE6Y y(~xUarP. Q"~0갔 TAfImFJ&FޝH1%\S$3H$v Ю4Epv[(Fs#{Dc ;0 \\ʘx Ñ/.&fZ}ɃƼ<(@2#sO9IĴQ[~)F3b\(J?٠Pyk絰N.P,z4НK!ZYb@dB5F{h3"Dccc— \!C'BҋC)qi3O8U߯,,@qk +ǛA~31XP)'L[H ,}8χBӚZ3NǶFK‰vV6S3ĘJ_7֝ċн|aJxG7hivn>)[X Wj->5]p9I~4luy_{F(;+r\Sj& lҸ!=>a[;,ʼ0)CEB=ZZFIf2[ q3U003- c]@Dby>Ry σ0W3h.2,j-r0Rbk c'3ŋ\-o5B,,yWFeM/Aq6!H}V[G8!q e@\.4FE†8k-ÑA N҃9luX5̱hZ*OxaGLL&'bd'o%z۫;u'KYd," I( Hrоjt m^Ⴕz'euAd@Sjtp@\Pw%Wئl4@6fa!1OV+4cj$􁘜 E_^mǔWBш&!PaH˾)iRRӇ} (-5ݫQ;8`ǁ4ء29(vWa Vz<mL_UE;a;ñ{N$C '8R 0[(e?HC@:A۶(.bygVܢbfPs KÖq}}Ì B4P(.-$ui鎣Cvf\14w +]׵`M/^]2.3d9ץU V,8;ϧ'\Ʀ+h/Y9#>V-VYd@ @v]$IKJ wJ> yƅwN.̺CY<`gFլtkP u. 9)MBcx4?堞+$TOhVEI6PԗM>];Hb]Wԁ 92+y#\G X=ݫ|'胉찚thHvLX~8-(FX#PN*ő#FJFBXfv'U]e6o@VCE<丏gUlVz+i/ Źhs^}~bugDF%HKpa RJbgpJe0 *퓫|4t) XdF&D52E epX H\U[q,`q1En};t&|%6S;B/'̬ \%0Â+Հ f-Ah[?5_-l5R_3 e]qhS@T*9ɗαR (Q"Mv'X1]z!UTJ/b3F1P,)Cdrm n)mPor"O3縓Ng.0e۴hB6ɳ۸?I_0֙+cA]20u℞;ԯ2d7|x$q)L^4bԠXS!977߉X$&Gԃ]FCH sJc4RL",yXVTPkAx3gsd8YwWF>MxF֌,_HŽma I(sdVJ|L>_ďQ"&ȧР?z gFdWpdFhpos SJ}ki& G}vy~|tL9fΰS9#9?m1LK_҂U)6MOkh:Z{>C̙- ϷQ~~Ij6E*+3 Τ95еY M604)۪Po''[w&s6仇Mp^͐/8Am+1ƙ.e%'˭,*֣y+FdEcO oꃺj@ыZjd^V?q ӂK!({j0iɏ}r9EsOW ,^ + 3`bX&[Nu Wl}Ւn=H#sW 84lj܍qb2-l -#rW3u}v^:s)Tnfsd"׳K=5vZLT Ⱦ2^eR͆/;G`@ @M0HVa1<{ME8iBĸA0q'g#L0BӒlO$=8U`/;AV*s(o ?^drb~?Dݎc:Sb߽ X#.jJ>XgDҩr1+vX4jѷRrBDǮȒ"GO-ȝ&cgTcgRBCqB4^fsn_cx~ШZ$c>MȅP3;3(2!B0gRn<=|g6<?R]LQh"x4Q=VMPF?dшpbefMZ6V;OY6/kpb09pUMo`_ę!WAcc)q\[UT^+蜸z˿CggzRh147[%6Ou pau_7fa@$յG"?#&vUFZALpB+'` gՌ8ֆZ,Wn}dMYW%g$O eXo!VV eazn-~"wt=Vm}( v6M WYujԋ-{~+W[KpZ !|`bKW+Ae粠\]<Yw'$H^Y1WJiA\wkY7Hb~'N0%D gKvv6P&VpTSVƘok*䡆C2\5c8^*o}Ӂ#3B.GӄB1K̛ 8+t٘)ku1&Z)J̻=btV`ypafb.;6 5 xj/}m+N(6|9|+2~)f$K=R&ˬcdՖ`SpP+?{.t< 9| #;L,i}>Sug\tfg${{D 9C(J@(t,RQO:6or2BF1T;>N>VPNhy%d牑 8ख.)zy0bЂnCt)Rvv0$y)אY MN5\6^:G8/j8NI.|۞y)ڪMeEC^@U0 JvPnLhiB)soïgU_rmcW/yDHOf`1" F ArG &Ϸ\+ ꥿ئ3!R{'c\VtUD98T c"yZLZ|Sd>6}*C1D¥놾'C oP vAxZ7 ]x:)bK tCNӵ#h)%GȳDH&Z!j U+U0!g=Ñ0lȂ}If#wYi2ewv9h99 gNܡt=ѩ ~=;\6ugUdT; 1.61-GF}YBP2-&1zoJ1P? 64.S nn=џ>4A$ڒ-%yI2mӉ9``y" {ot'&3a#kK 0odZ\ ܾr㠛8npdBpU[Q>~0 wm'?IҏFȗk\2S>S [!0!^sGnH#2T|Fn&L$r)JLNxVyG2BbF* |s](8yɛ::A{hN%Bj7HfVl*Ѭeq&g_ts8k6Lx KaECIllO .DAB/(pl %ʚF$ ej@"O;Vl[m} ?Or>+P-B\KEuы {# ([:LL}M 826W+ Fr8)O^78dVw)}y~my\6]$St0cGG@,+CBwOZh࠻T{ -*5|?-wGr客Ipc .%?17o,Bc4XIaWa{Gmse ݠi!Wv}W*Ց 0#<Tojh"G%ftdzOe>(Ͱ#4@a&$G$W X4^>HP2˾L1JbfNuʼ(KRW+(S~j s@eN70Oy4Leg:ڴ4,|gKg$P#JlpA=oZINwG'>.G xirwO9o!u_e9y\14!wkZӆ녅d!BĶ'[ſ$2%1լ_W0,RD@z4۔Raq,+k!T>q=[)fn̓rbYнpru#@3)o3-FR|fjq#tٵBVJ#j0՛L:Uyʱ] n2 /Ӷnod [O[ u?9~-/MpEt}N~$_{Ǖב>v!%b ެ;T_PgOz^ic(kOt+mh@\sz6Q uxr!k\\/:#Iw>>F$iBG9h .=3! Ih_=,ux>Kk5soS&-O}&Vc|p<Y:?d2v'{pRAu:&0.}4Յ[]v{!%WʶI;s9dٷ+[w´o4fd( &a╍k $]"~U IO" o]Etro'tyt1PGfѲ0 i`ϗ|J ncd2yq7/jGэ&W:J x69XeWSrP cUR^ͳ]CVo=+i"9ms ktIڃ@0rͅQÑUmVU[9YÕqCho\+/wO3Б7<\~0K]y!A Tْo^E5|4s|s{qޟm?$E*~1.0$DjVV#CnoZ0UT[CGXƾny]xTq ! ,EGae] ϨLi6VL;6v>8FcHDۅY,1AgjH?sob/-ۭ3?`TbC 척e)|]_c350%oZY)0y1r2U2< bD%vd/[fRPȃdADZԋDmnɇ};~ 0_vWUh Bt/mq^'# -ںoj;SL mw)Զ>6&Tƅ߽؇'>6&{#ic;)uB%yugnDMﾉvAkLG "M꫌y2x{ `lxٛ2MHw2ioN0_EzIs{Qǟ+M鴮$aAW4t:ZqCv9qCП!zoH!H<3 *i!l)[Xl3 թ*1o Ge'`4kf aM8) BP;Oel0¤ܕ$ OYЂq8(_X4'>t W\JЁ>(5vާLiWW`p3ڡ;pY!d|il\H|)LDGđ0.;+| /m*QC)8GD~}'N$'X2\QMWŮϯa^94z""5}eE>,)*X bd[ʚ;=ep;G&V f1ģmx&}"h!SƷM@qXt-%d GDxmkebWu)%V ejCNC~eam.ujC6l$LĈHf\ 5󐻝b*cqQy걤EpXpaI:U2/ ;u$lg=I`r"$rP1L=D  g[M9VTȌ^ھ8 f>bQa ߷M9Sudu-x~JY;t9\phq1pi7p KFRKl?@3Ÿ!4ΆNb!@y<Rw:C\&CH_ " m?|p8;ĥyKDfO\ 봈`*Q{ƿӝ+kg7]SJVu;Ca?N4{DTUߎڱs֟jםvuoR槏[9ͺN kfPPYqįjVBNJ5d^h{.2Ն(O(\J!"{ E<[ȋC}qA7˷~N(Go*2I}AtгzjͥKEr_L)I 9/1ʜL5vrst.a M۠p[8 +,Cɒ('»E>ږ|H<oqch^bȓK}A( s"PgƑ0ܠQg*bE3boplЪ&imU әM]wԉd hvv:>^S8" x~zͱIjtbz%(s=5K9Emyhja-c4{5uߟqq9Zj>?#®&5iꕩVCxW.SiMZ"}}1;mN(ϯ6ҶlA_9%R áfi-|i?P'9VKu{lIroinϙդAŵN}_ՕxYw +jӡ?g}X]Le:kn`SBI$S¥A` /IUJeTKjCt#nQ)PusLȐn$xiDc50t7 F]3{9\"0lMMX:w@-@0h7ee :FR{<.Jm3{c _sBC@ׇZrt;\(hH`@ HvSb,e,/J}K476R613WH޲phA.<=@7*ǼQ/ɺNlPiYK#ul+Ji T曆@ 9MX`f1s=F;h1tlg{ V+By sp(p$V\:/Y6{mx;+u_9$%!{Y^gߓdL#(ZfRW* 5jhh5 "/ΦN9WA4<3t3/ieSCq<لG~X<%֧Igʷ]9-S#uHGTxJS)C^-vWhaIOYK]~ʃ3(oJq ?5uq{6572%dQ@.sNdg%)l`QREI=̈*▊eh [20ꠐx(j$u ?G_1qk5].;wJ7F"z"g5Ģ/e` (o$ ? it0 ?(V\^)?^p$rp3XKVmup@B,&:` }bsk]kA+!j %ZZtX"H3GF `ew8/Pj(P?XG6#tXҝ8W2)~>E+0RaK103sNF \|mM[Q~ 2d4Tptn]≔Xe,鄋?_ΠKud|m\`LT<4ANiS6|:Q UsDBz' \п5^x EE(Ʌ7R۱uq6Ykl蹐 84Rr-\ ,r$A[> J2~3z''֦5Q:} m(Bj}2k@Nj#EP[6Ki//Ckh_(5f7Ho eH?EV漷 =^,sT΋Qڑ )a)=[:TqC&j ,r 1"['y8"\Ϸ`M?ߋDoWYNi*`C0K%GpFT&i[B$3T/`ɻhu~`#<գ I%XYYlTjBNAkAaѠo-!Z[=n΢“R;Dǝv0IzrR4^w)Djkwkq7A0+p76VHFqnDODRdNp?J OcΘGPTqKT(p< щX4ȴkYϴVef'AϿ K<kQl΁r7ŜRJ|tA@SOr:I{X~8d ܰ)"u;nW,Pkrф庮ܟ,uSIk`D\Q]b/|)o·S)p$* }5 ڛ^-*oW^`%_5Dg'W+E:EsxA۾p=4 >O-<4J#4Ƃt=*aC̙BN_ 7YE ~`ƺ&tRyy}͸Kg?wpwoO$߹J#kHi2ܛEi6|A=!f{n $%Fcd.O*'')A S?,)"gcqGy壊s"nU!~?r>*.- N0p= bS&}mȮEN4[wk>P\ ]us:&6D<TЙ.C#\͟vgPG_nqin$3[ ȏʥ0-qg5rNx&iD/O*# 3 0~~&G_{F!~:y ;td6Z,XWφbHj?١ hE~>Wb$w:t r|;0 5%aDu ۗ"ZD׎.po>CKB1TjFmyJuذ3Prz\|k^hA^> ?5E L%щfc9,9I9x=- +%٥}# _۳ ۦԚL0M y{Vz ,<Bg00 j0LL0w/< :E&LPhQ.GRSlAC.ZHǐ}esɛ:Jn/ZWcjc&&l Ʈc4 l[>iȊM{GJ `iwCs2"ƗHƢrಜ%a|CQ伃t0[ &T*Zg<9JVXAmpԭ[ɭ*PlJկvy Mё=!Z+;  pקh?UF2.Z\A[0DDM BsB -VfvYٯƫNUINJ۝7Y@R(('ͮT\w=x U qŷ]ȚPiD0dX\<{g@{[{p]#|.W ]3Q~91Vb坷ێwlNА_o-0yPߑv~*>1JC,ȾFzBɰx"g( 7mam4ލy>FԘ.lѐq D/x ?*ޯc/Bd r sQ߿\2*\߃:%l+p9M7.Hݹ>jk[-xk{uWt<_aW1`e]Yi葉 3sHiD !T71[tXё|J7s4 0LȀHOXO]beNrZoG|б /K1SX_ʯm5[p\6 3h7Su*{lq@`xb}VT9:Q7v4D%{s K/T~@ȢmyQ*rBD8brZWONKPdf6ur5~r)%PVAu}-|Kzd;@~ 8ƻ% cw=5S ͗y`ۏi:V7|?/qH费ڙXfDھ]F+SaYh8(- $h)( 3Ӆz'DӷD!ҳhg&1qRYry\:Lj5]d T{彛-+MMS̢|7LL“'B ! 81l D.P l8I L'))8b'%> 2L9AWEc'xͬLݶ ̇˂,Y`O˟ʉ ||paҽ0aj2xTMi Ô taU/v$gwҜb'; 6nb""N`4`R=.X`N<;Jܚ|ZP8U{=77$x|7c]DžNc~ cMjoH"kS?GX$ 8xJMI@8OO#>Do?Ē~}!|:R.@6zzN>HT%}tMvt3H*7z$LNX$,ȝICpݮTb\-KG8zrC),)N<֟e'߃/!^qW F.~gjXdcJP@ b)'`x'I#.gaL[Sո 5glNAN[Sn3E{FՍPl2_ n)E7ߛ#FF'!#pv0O^ޣeFά@3ЙLAkx+f;{o1 qNsF}jQ'fQKX,=K| "h*lq$ǽ%} ~DީMGcMzJ衣Ď޳=Y" RGlx.nn1 gf?Iz+(.3xjR˶DlF|;@-=q).v։rzP'dwh7i[}{ICM=[W6qݰ F"MxvPk.Fr.ިDWQ; RAE'9qlvঝvl??MCNUKF퇔p횭r4N5{R׹Ď,3CӐ2|z 7lU/'DM+lC'v9 )ߖ% nɞAyR \#7gܴ(kSh3?QgRDcqwסV k(X c>yY'y1!r%JHf ꖝ5$GC?´ u|wU4z؂\8~B `;'KRڀQ^3Gu('SU+%NJt2n KS P'Ż31 9Hb}x6n6xK ip]b< A i?LܲѨmG\e >Gf*aͫN!Cwj_%7vCeO^?WD^bBъ^hTvlu?.J{(M@ \Soxgd_ tZwq[$k#y}WƬ} nB1ݛ=@U+VFa~P9s7apU`0~d+("rq9[o:tO+6b(kML̀y rUjxUآc|rfwvp o2u?oS U]y(tƟx^ݻ7slJ8_|8ӗ;@e3 BO%> THzenvg\ ]{bVR dD2~+&oXl5[o5+q'(9ks 1frbFGR0;fo+qU|oϛLA,V4UѼ"QeBXUH^7ad_~Ò9ZJM#M.:%KSTiN_eR J3[::chSIwJw_N%jݟ0.FՕ 0>F~|z'+o{j, C5Bs wȈ,Ȫ_v_%c8<؁o 'Njo߸QA53hʨ_%l$|yKp`K|whlcFF ELsLä4˱dMޘ87{Vk:,];P{lM N@q,_CJҶ7seoE[r^):U:O6!XcU~ Q 6\svάȮ7֌I)!9 >EiGL̶PrLޤ\L9k_#m#2MSdzsflWxMNHmtl]:&'=[[p _Nh~U{LsrM aG0QUx]ￋ's]Z,~C:3ƷXdCf,ϣvZvaT%<SrR;<+;XoNar!~2ѣ/m/GI(!tJ_`d PAYJ*UĆPymK jPq]BGOƧ8YypLfatQٰkW3Nri+ۍS &r`zBXr0i8S\RH osa5zw6]u!ƏCP}zJ Rs|uRڡ9- b(~56i+3l,'h ,R"bUŲJ |[u=;V֦?--4ܸ]Dz YZE+fŖ~L]"P-kMXZH0|\ ~( I1RoDbGcOt|G%=CMλv&C l7H۴B`C H$n-FK u@u{t$ݼ~*O 8e H3BQ&;? zG"P/HT0%LeSKfyd[67: T/lrك15 #gAE|?a0| dT}Dpi!AuHm&tjvmn?}m\ޮiy'O'LkCp6qkfOhQBýQ*gPv_${/ORST ^[V}9ϻ6ok8›/%IclƣF2R)ƮpLX=H=6YxLSɘ'7v61a`PDj=Μ"Tp ʭ^,ꚒA_m<)(!PHw9/!lx,7᧭ Mh܈_i(ӊʊ([uMt">B͒mиPF/O2!Bϣ\c+w/= 1$IeAܓhFN\L!'%2ۦ(( 94lX.Ÿl:%j7Xi!U"E빂!uwvA^MBAzX Ey(/h'OX~ M!VKFXKHQ=$<㎝ƮFb1;!݅eiw™/$읅(pv=Qm"} *]ylZ,--`fmAl) 59LfzsZڈ2}*:|Æ8Fg~Cȩ#6 J=ٟe]M>vC U18:[RTM<2?hh꯸#MTMwlA%=~|3% ]}P*G yhNУ:}1t SԂ2. Uʖhed5'v"˭?x1k\w3@D)4!tqb{WWt^yl*QdCCP5>{ g\)L)JɺWp5kw I r|xҙL]F='KաՂsqQ:y% ׈/]I}bA W])}-Hsd+ޖխ(`rC:GDKr"l$iτ/ Mr\rPqљÖdfs eC0w71kf2ldz!St:/OIp<wt4:#>q0%b $^62z ~&7p5n/Bih0o4+ȭVh~JkmGEo*^܆ Ң ;S/ u^ (i>x":Bb?V1`3h+Df et:]@?2{W/(qGmVi7pVT5nM`K|Z_U"ᖀ<^Ĕ/ ;̕3˘2ʁ=6d02`)-oqwErɨ,qgW޿$a{r : Ix+ض]Ӥ|ՐϘ )Fn`!.Ba"+];&t[\dX so2 \NRu""m60Ru@ʜw+j+s܈oVޟ"8s,.M%p9;߲hK5javACU 1߂Ws"rAN8 !){`^~gIJIkrze >H{࠯pEnh_: I˘*]XxsPA<XBs/iH+F 'lL6Ųg Au.z}o 'Acׁz%gFɱf߂9] N0jOg&QvȦEtPL_LWߔu-o(0֮+w֟^lI2ß6LZf\Q 1,dxF(NYɿ܌p a+g/EiXF@\XʈJsn C?x p։q i!4eh 8[!.u>n1ZA[T4])Bc۫9xzcl&y+ Τc1D L<7c{~lE%.4z y< g#صX*߳vkp\\=Emg[2]c\$cxY^ƘfEø+5+foG++z/>W&k6}2j4P㺪iTW.QY4d31x/A=܌\n VIf9vxY4mSKu3!ѕI7$&;AïהtT$!hRJޓ͊8(KX&ʇ߭ucCZ-0Chz*uf<# K=UD{G>&>̲HКtP[*e2F&vÔ.ɗ уĹ 1AT8ŒP1eםEDyerQ55kMZUn.0,Jq>ſ,;wg!"4F=j1rھM) Үܡ3e)0&5ir%)5{GdAU0gcRIq !AհfDںvΓ(\^}(~5?KU1&2TNBYCtQ_Y;ㅖiWlx׳(T'%eDkl|JW!eD kt~z^II+ITLSQLrƚPE:hj|y(dm ;FW@Zepj6-WӞ:xg 99sQFQYq&s̆!/j5Q?oImH^(k󡝎7J~dAnfnCNfj͒WA>@Qo<~Wz(8uגWZ,>7|Ye3S1n0:cHnϨd1=oޖV&J *DZi[:MCvӅyce˂mi5㢇yԪuT )$HO^/c9"clq&fr&ce| ٬O(s""(9/FȺ@Wma-z,+mD["ܧN\5qc櫓n轴4`rq"Czk\hO[#_ )Eo*7Lw>aGu/SOhgun\5iS=H4J0+$qR-*&Me(ʈfR74ƒۯıIlȜovig)mz3~UOE"1:88t1qxCɋհ\L y +WBbA4Qs5t}U::?:{!EuAbH )Jt)F_n6Jdq wp}K/'YXaWzʩ*2]N"|C⺥rb$ Ȟ8?-'v$αfV{]Or(-Anm*4 Cͪ_<4Xc,3M*EJhg ^@'NY$Ěq^O0l |0T=dy= OjozH zm0/A-Zܼ'D$Xr8b󩽔"Pv[Ѽ7'F| REf1M5&k\en:ؽlyuI2PVAÎSzP@ qM%yb?4/VKѺ~`  IbV`v>n@Od+1LE79_Aidn\x:zp7Oll2vua7a":ve-BDp4d# yAԣ,a! * fb23!/C?@k , _ C{TWwD " ӮÅŔ3ÜU 4~Sxȳf,$ Q6񻟎\bT/~dd&zg|a/m |yfVA'$K/| FnOZ?NjñB`9tm|K;1mLUfUoVhlVrr]F3dOIj<KEhm0 gk_1(v4O`^j\j>21.M[2ˆE'XD]i9?qBad6L=Khzml[G:oEߢ7RP/rԘ :cyK? _ J;񄭎\A_Rg ĒH\QWKFګ69!keK/Wi+8r@횓*k;̀8{a T Kew-I\˸}zaOqBL Y5!B6IQbocM%ztS{)P1Ⱦ0g>լvs}q ^ryx)L+{UŒ#B!걝ʱXݫy 뺧~RN7)~t]%vL=[ VT(a^!_=WMݍ;[a *{s1?;Fӄm?: |F"5-q*tIGF'(F&MQos 8VU[lh$LvUHmvW_x+X!m+S5wi8}%5P+dterZ6UF{@F&40jTqt@1?1X;iޓoPVE$I&ݸUt=sG$*ĉ^gJ{&ZTD0{[ogV7E Iը=EQ{N\v0& { jGM\ Aƍ cǟf0|  bs=؈L4V0" ԻqC7EyL<bg<ZQ Slys$a-zouӹ/m{ɊhfT=b0#~E)etJĔjyxw][)0I:ni.]0Hէ'bwc1|ه6vYkfGfVy 8^=D溚\TfEwGTPLCm?N:vٯWyHX'<EQS@`2Ʊr4f:.Vx$e܈Scl1SvWg4^0bf5GJP^E >~?.M 홱b<5Ti/a\a=ɥ2圲!uԦJ9 fHA=DX 6oNq5bz'Ch,_g/X 7au}|?{h&@@mUQ+ 9{[ogb*tD(UH,Z+45lPgY8&DF΅ xFy`UbU!^e0z,~W6-99w<` p^9zΕSI9^-(4o2~6+6/4]hTGRagI䌒MZY'6ֲڻG^f>* 1hph(Z^C%P *, thY.HVf? zu"EB ͵YIuXSN2 &vU.-3+Dn_tbr[~ZK?q\/9iģsLi42+_R)eB[#[3q!@p ìS\gPR$OyrsGi2Ȕcm:I qԃF5rOqvƞYYbxc_/7if_mŽ]\]RŇ͵~9-/[@@juXݮXGnyI#n><M}'JroOcyGSƗK5nin|Ur#'LUؙ̓d6gp9dAg IEbE@Ǩsbu#<@ *wI7K$(a"G2g錺͔9~f48^6^Rؠ,MKaK72 "߁uj̢6±M=f6)eɿiLLK4^D4kաio̯y6/ť (DQkPj*gA,M6 0|Yqus G+WSFr;W-;R X; K}+ ,75 ** U JI):/`Kqm, 6@x'& 7=b,jP~ڎD6kDԞǭM &qAmw}D=J‡ذ#+| {[4skL4d1f08zB!z % S9e(` Vƕp Pf[No}w,>k0q@( $;Mh10k/gnQn5D݌}EW΍[Rݐ~|vHV7-rzz9'K匬h歷t?ǫ?U)+-aGXŶE99ǖ;3AGd1t,~-A@KCkMFXD + i@5sDoGӮ : -TG6¸yśM:%>F2w{=SSK\W[M4{mC1|bDᐒMZzzJA?)wc(TZy` Rrv ӕ ZE:2w}Z"L2xbn?: 4hT R) Gmpv'$YĄӂ6() c8Ԟ Vű[Ng$W`z!S #rܑώ )-!@O 򰱾Hɭ#0Hd4u<ۭXRC_ T6Yܨa920nLX耗]yЗSL8M%pold~$$%HX\i^&U 7쇢Y\-l~#&5rQQ%­1jqц@"o{ WxgJ@cBPLf!R|飌dR[0ON;b?%w. e&>'*|bmغ$X'j^{PZn"u\52/K//\-Acxk1)Ao3W~v`#̓@w;Uz+ =>5WyJxULj +Y=2}dޗy:^N^.BQ~zAy[4&%j CwʚO2vvtm9o.oXxE-l4{#o<BVp-»ZDW;I"UoJ \H{0 _8R{w w#J^ k"xlX۞wi-9t-qT3jz0yF\ (zDN'O#B.di^qBpPBu@.|!!5?xm%c͇nziMeb ;qo1r|G. 5*ՆO]yWH85@sNYO)6zCuk]#Bcχt3S69ĪjF]IQ Vt"6R4I=cШ"wBub~tA@mM:yHg&T>ͯe|{hNͼ?c ~m[lIȒ݄@{P6.įTցu8>Cۨh+ 6:`p"mh\}$Jb[%` ůe|81(~ҷr!{ #%]cFB VV.M)#jp!/ZQ7H&E)44I$k-M,UN}.KnْxՇ4XcEۦ.Jr2Y-io] -h[~2H۷OOv kwOVz*ݧVς}|Ct5FnK&ɭmƕv,$MȰ/B6`ő{qdp,4يXBgAHmٴ[SII0SJI3WU[7!+۔謷^/:N%wOkhbB2ct>^%QvBեx )~2%|*I$9u 'nOoʼn!^?4>:z1܎ETAl,@"$%n(>K F9ٯH8,8#=EƂR *" ڵ) sPph4k(DPƵR֫8N{J/vFZ0 `4d͜; [8M}($OϿewq(?!=(p9TLU&I& |nm [{2W{} /ϒrFgd ̑G8KӅ,"%{iۨk*9\$2qOo#?1PWL9%,#ț d6fzKN}mY;cJ}3piӊ>y=d!яXJ  `oQ S0y9|,+viɄG. Te=/S`Ws4l&c:$EJæ0w ^H-$PJ&-X}ԥEN:Ӯi,:i[lHK;J k5m](>,ScPêC Xj+cr&{ˆM0. _W.1? iP1|30Ċsػ":A6SY8iJ3/3?L3/O-sCBګ9V'_H>d=/s,v",V<>Dt`"?N>j3,|,&i[eX1oڴҼLZ".֩xw}r%ALYt$3f!i@q -ŵS|}+҃0:s׃LcЖI:-kCGu$KVzr/ 0cpEf:Y x97/n [%:p]}3UPM j0LMjO&HP=- `JE9cG!`mȊn*،b&c:*4ʓ8zwY +ώ[#o+CrY:8Bi#-2Gg`:wxۿ«<(hxH< 7ן>S=2W5Æ39kȢ[19aӻWL{[`9v]+<~;7ɮC+s8`s "P40=7B^[=sCK'd3{7ۏnܸȳVAs$VON4 iJG$vt.bUsP'?AO[%B+%z8{F#hr2DeWBBl)0=ͮRM$ƭ AFe~xH0;Z1 i@ tll{,{x~-FL G詄/-2\HlJ[ 8Ģ1ѱ+߀P+?6 (lPb!%&=loBz1S^`baaקgg ST0v)x߷VEfŬ;W3ec,tcs@tTֿd#~21npM t'xs&]{ىoTeAuD -xEE^ϣ@ywS당+2% 1s]R#};=00ɵ8mGfqh>\˄#;|譧Y8n|O7nv&b֡eY 6T5%K82cNK;eq,a쯢6z:WCD2V[&礩IT ^-=!vm$;yHEVԚ7䖫#(.s$ugP0+fwC9`1pMuՉ(u8CRCXg^ORSBd*qŧ\\xS ƈ~buE7NgmWK/Z9jW9 :ū*$N-^FWPTj5zκ#Nj54ASFǼFC_ۘG1?cg^QF:#mmVZ!"\zˀVKno/$SnlV>V<@f~y Ħỵu':w5eh62T=;fU-eqa`LPGMjt G BwV } M0]D9 @=B-1\E9⷇(4}l&fTc1MM[Jyd۰k=ĎG#I3WnxZTDG4. Q #kESO"3֧ `1NBrbh-|$INCQ[ 2imwgJlK6#l\7](Bp({4aZGQ yKǰo)xwo3ynxLm?4/.__s{Nf.:3kgq0VAS\8ȒN2d'E ~SotxϠ\ 3#<iDc{\{d+ub۷=; V`&޿"GM{ֹѓVek_vݵW<<I81'dy)]Su?1.8Zվ A`!O7]y`9)*l?I 8[xҢ_yňX#/Lt4ZCԅ[04',r`m9[51i2/lC5Z!d/b?CS0ߝ "W55Oz|z1R2w|!v+eyɒUQpj+ʣF>pjY+mf6hꮈ}_$#LE]ۧg_ȧD ՜_Vo!:ieIh<) 49eE(SE0F)f]7mQY#@A[ԁQZ-hz*'`5lO'hyp ,&8{x)@z@£W%gF9i`/{MX6L_ќNGuPX4^,i}=8jcԎh;>:~\ n_y7'L}u{Uw Đp^;m諓V=H9'[{i2-+¼Oٳ ]A'TYR^v6ܤ4pEύ'h1Ϯغ)@IYze1al/>JbԘtNі'>/'4Ū7tOXgQdxz[)M~E=M 9C8s) ]펼!Jb->ҦIx$4irf`-\!03091;a™?%y ;ҟ8['0o(x8M+IJߗ1^+꼛Z-jYx_.{`/fM|mO+AYdHG2^ccxzZP:6M3yOFAB$IaSoŭ(&Wmf;RbZ15 PW_9mDݸ[e:A DKUB2#`XÂy ϳōVGBaΜry;َ֞М;1U+)v3 u4w*EިŎb=kIOqv%rS'WxIy##JJp35] %ߗ1a ^kJǞ̙R6+rJVi6b"Kb9w6"P㹜=LrVXbH88}D'n ڇUr\t}7X[<)nەk]6l`Kc1@XvTO1 tΆ%]rIsXğ IYj&7K`pi  i[cǎNd%撫Oְu:L@㾼`E?BFg-gLFҙu8RkuO;&/6~pc8lec{P8; o>ȷ8)TLпF=^zdlocMza, oe0t},m '\n1g!ѝρDqREZ_C礭#ZĺjŮa~ lcfq.8ɬ q%\g|LGw[ j~WTD:Wꃞ~ʼnUλ-5ބ}{iݧxwO^N||0/Tt8;rN$Th!8.(`uvnv]eIDQbcӑ jxV(OO^/)-אɽ;;eDhG;X=bf>0 徙Q"o^xm cKpө qWUz*% "rJcgx{ZvIq .55LȰ"nukBc^"_[g1鵸ٻB2 ?]oRzTQ ͱ*z͠lE~eYMnc?ȑxcHOT ;ᡥ+랢X3! <C0!P-pE(K5j/–l(Ʀ0Q'+5Ԥ+E5z5'ˮ @+P# *d$ ʳ*)xhx/<)clvudV{sg}TVlZX!jP),a8ee"ՂOT;؞C"U CCtg@Ok׵s 'J^!u;PǾkxb K2CJ]^oh kvLJZQ@Ǹ[V~a QrNxy~F^N0={3<;mQIVuJxvqV87ID )22HӄtXlCAȑFJ(vD?"q@+ljÏ Rsrao>1ZtrHŧl; /2,Y._Y %/s6S=߿ YZSb@ =H*1~p4-2<18t8+ _GSQrү XRkUJ.U:a⣂wb/޴65Ts/ n4aD\t ޙPBtҼPGddEw_t6ݷ߷ oK#Su$ 6 @&&068TUc=xnMJ5(<;, 9[նǤ{"0%ףq7Ĕ3pWT F I@(5;M8ܷ/*@<8#M8PՄpX똓-x@Qv`ɶPb1cVc-/rK h4̃#߱gYސ}<<ƓΕǼr{Oe.-dfP:ә)rKl]Cg l̴LJƓ8%0'JڨVEyC`%$;դoZsh7&z7%mjl90ؿ ϰyJOpߧ!<ߺvP>g??.Nӟq\5J`Yt#u{hh_*[)UݹĵW` )CGW>X>yA-mZBqofpGg~W]Tԁu=~ MmϚ7yA#OWp)Ohx,V>HB=WbK/m, Yyҁ|CVo0φOj Վ#Kj7;Ɣom߇Ӡl@('6,r4U'&hQ$orɫfet+G8*S_~ \H- F)U7?` "q栵uris m>f=S׸QDI}V2ȼS71\m[, e?GAT@;' A5C=sH 4GYBV+3 P5;8Ͼ -KΔE#*r2Qa|9vc! rp̬FydPoG=!|Rx~O?H>:֑XG\AgoFq#l (bͺV=43! }RiO.|vY\DEaO5*d5w5#Qv$-PdJN[Ӄ0>k+$8Պ_jNdbx̑ƫp Xx(iӟJoJZkQ,CZ@(/ ^]c T8?tƭt-"k%ݼNp%X:xt>@:tN19G-2ɀ3vcx]9c4,B,}eFSuR^1Ssn[ό  q7#&$DPIm(nc K =Ez>uzc <=;jaC2w|j05L!F*\1t_?,"dU㻦$޵'\9T}pk+1DwG'uc]g9\+![!BT"!@y-N88 -9<YoA1Q6grm`qp>Evtpέ]0W EV_Efo.ꖟQHE >p{SؤbfO#fЍD?RҼO- fEX(YR^DZ7`YN 1!_a ɓR?ۇ%|3'su;k'v~UXM &^Wg1ɗlN0H ^금KQ}]_Y8'_ Ğ, g:RY=dFRC^^dnaJkͪfR}^f|zY\6Ot2*ʠqt|„u:0|C>b ~Ɍ @SKlut8r{ҮG"~-ut:M`{ioV/Ddժ.̹oTA\CZR~AdƑށ꤀⫲A^X-FAr-cEȊ$ Q{Ϝ T-)։y~7no%f+hbֱZ_18n'ܯB&|6gGZFAڛOoip> \$1H wW:_ t-~jk7y Y`{,?5gx_|z'>؄LeiaȂ߄ZKsc&?0&:i:(x7$34e(PH$}n[m9@\cP\F[J3Fe% ͬH?zFb Aw]T]#-zMP2i"/˰! N<QyL+7bh+h F| IgCnMw} ^K@(C**3 Ϋ"Qt4F0}wo@zQ8ٳ)j؟cר0%qKl p'$FI#s!*{Yq q-W'Mk1itiwgKŧ#zZ}l'I`1Zq̂>re忐`1baBryù,fe+GU^|UHm74WK0M.P(& T(P'tf4dzu,үM[v*}S4~`5>ͺLm$<&!ƧDkkݭs=LjtkYn@#GZQx@@ -u?˪;F|bx5e`YqvK8]pb\/E&-tߧqRscYk5qa@{vؾ-~H ˀjYSq=R&sJ,R _+t[ pYq\;J5 K);W`O+LfC6e-D(RE%7Q7> DXML<n@P$AԠxJr#S* ~7fwt;Ƌ!SF1S΋y75Q?&I(MG,"³j+X̡E;eg |""Bmٻ4*>!E!őY1ώEXh#VyRas=IA`tr%P_nb{LR ksȜUQ {P1,F 7usROΣ Vos%#oXG~JVn8F'3J|2 "Ȣ4 (9V#\n߁[K7[hmۇp-bp E^~ -u8܎"樧L\Sk u '8G =Y\ u\8ZE|m]?>kZ5*"жʾ_X=CpZZ7R}fH&eM+R'b@e|ل`W> j/vmU*ֆ>Rw6i!iS? dL-! hq(lU||~WGKR 9::|.'SU{&3v3Jyz<.I;UtE'$/H)LڔIqI5 ,CFۉѶ|:^,8qFgr5؀uYhDAmb&NHddF* MLtqy|+x =o;ش+[ZM( ^ko,-2wZI۩R{{5]=Dgf``k[^ZvAm0bi~ԟ=Pu|@Cw6=v05)֭ب(ĎD2Hiޚ)lΥvݖk}љes,u iqtVG}#p5`6OZǒL@]'}kw9E"t|]P ?)ZnG5P+Q H'7-ښ)w2I~%pZ 23k ?IxxN03"&G&frb볇,h~*DPS?¾? tjRe.#{YnkzVNXUOvoy@F?)+!HݬؠmuR`0ߠOj6w_Nib׈JZEu" ~ knyLPA pa>ܾJ̮7sIc& 4ThRZIALVˍzhP1;,7[MiUt &sI&@Ja@C1z|5H"G^+>'0ZI6}]=fV4gS>|޸yt"ӐXpLq>;*,|Zl_:GNV&j '9mR 5Zm?ng6J3ѥ@zXW 詟ܛ<֛I)0`[:Zt'7b!b@Ă̅ t7T'D/$U7rH6 ݧSayGyDy$>G9ӄxm2n0u,($1V\OֿIXrorS.@3YyCf+/ >(6fhA˻@Amߴ ۹%h;"nCX3WAn!,s<:ҘO˹1IjyBqTɏIݸ<eÔxvSNU=8xdff!ض]bEB0B%\aCn eFb&>cï[uh&&*OA(Ӷ@0 2Mv/4I8i! e^uXvEIGm.9w~X{4{u+ vu4R}s6FʞO 'd"rO"yMmʅXTS6};@#@p˯.3EE5K6\/|hF+݄Hynb,Ct"JK!GU4Tx^|$R\2dùSAm`}װ%wqj1?˻4 OFrTټ%rмoyF @*Q\_u5[`GZPNE;-WUnT,tteqz OZZ|Y_[8nnj"h`'SUx&)m ø3``M ^h ޗF=dn:]ݔcx` 酌./)+bg@ $268Ckr_v)/DmkN hp㇗^cs0԰pV='%jO|o ,]so^:78>yޛvg3XFJ#.U)[͎tPd`ŀVH7;ۨ#{GvCIΕ>pj ,w>o't6h`/ۃ{i1>UJZaYh J-ЕiLw/ȅ|bԣfNgu1u&xT*%(?|)fUZ$Kn y3(9Him;W^;9뼴_(ȿ,C# bKRI0?ټ elxr4=&u4MZ#??P}ϧhRDG%i1 =TH<͓aQymv'N6?)0Z#FqìUX Xm(oHaؚ= j_!`(HgjIrيA<Tj6x_aq!!ڥ x:Kmz? !^ё@* n#;\锠 WNo MCQ^PLM p)L.]J=y=19vKђ`0?] (2;THdf:-*oJ°ɼ3B%k" ~%Wt~PFT3'I_xW~pѳxlP!V"="ъ` ҲX*s Z_PB+&9-?&r鿢6{ GqN *~BK]ۻBkݽs6v<`t ~>˺kC:V5ͿFӟa)v}d&J5:E٠s9mi&y\4Had&O'g vM.8OUPܮLHx]fIūDze;QJ)KUZ KIx)2~3*Nw]}"xn\-#&?W=m@۬,DSx{ђ/ ovI;1nϙۖr1et"YaېA@`j;o$q(wJ$4ߴm)b׶MvB[KsMT jώ1N"X MK̕Kq  3,̈́v`Mgd$!uɾc7V\~1E|5h)'2g=RuXVP<,G 6IdE׿ `&ku٨NNy{!8zHu1MOZ.A]4ΔfBj߻~d-u 1Px CpaYאWsGdnV4"v#ATgn?Qmm2)CԜk)am&(, x#]ê/${Q;TUQ?!-(j:tG!{ !J΀r;-˱KksC~zϐ!¡N7w2﫞 ,Cè|z pZ(On*yek" Pz(3pd`Y[-۠ Z,H e|ڢ򘡏J:仟0tONH6-z;I3j5+Pdo* 'BfA6|)L2Qrc1tPGA%1.=]j4V41jbMx>?4Z^7$/Am(d7liks Ab'z#80sq(|* H5u7C1\OOpFm F,aW,{HduzkGǒgbK?tkߘ:v@yI(x1lӝrjjKYO]3Ԍ*߭hf؎mgYa %N=8KSZ49ŌD ,d}>s4Te߸Uv %z7%c1uzWP`,++%ugBJ)cԙnÜ b/RZM-Ob$wȻ6$ GUo!7MWJRk|W.щV3[. pk'J ?xH(tVbJ 324YZV8%9(]yEU^>xL~J9A;}3 JQֳɭ @$|<le&}ӿ6¬m |5!jWµ A!$N~b<ќMe}`ԣq.9Αu_>v2jeE>)@G Bwi謐8I`vkX"t'ͬ8ח2 [xcr9mѱ7vC1Mmn0> +]+0uЎ9ہSpk fmI5.SPKW+1:wnq9Z g :c3=ꃧp {Aj&e@l&dNpΟ) }DJg_nL ae(^%j.OǔsB3-d_Zl.W2mq&:*]sھuDj!EGxUe(X7eRTH""ʀg݀T.]0)vϽWMk"yv)YʁqS!F) ^ ;IbR_{cr';;*蓹h~Z5B9qϙ%LdXq" Cӕ\ [Q+|_2= 3o/*<=|^ߊ/ĕ։eczua]΍%|T֐UJVA)sMuE{S6qw"vƋpoO=yw**[U,Q\zdȭVț=uN"ښ$!ʹ}r@MBǙFA (9T f·է (T`$~{JƦOԴl/۫kg]z>$,y1$3}k0aiZɕ5.Lܽ%^>sZ󣃌+o<'~FX1Rbv}hHzu5=.D(utyζ$:(yE{Wp4f4$3?]]N`%^b8~`nTy{[IW]M#ڬR1x˰ՋQ [BYX*RŚsӬkfff"s ;õ?Rdg9mZ$5 eA$>foE:lgϔ0sNN%=>ɩZvfg& Y`w'&brzsebHJ-Ų(n-<07 *z1wrLӞ]A] i7DN.t!9bte[j^ V55(*G|MQGxv>#[F]رpï$Pw}e<:_6E]< U$_y`@eCĦ^S^?mf5%?Q|z]Tº /8 hG3I735b %3|䣶] F?둶rUNTv9 6Z!ISkZm@y\9?N9e):' rz'׷b :ۭowE m?$ӑ*[BLff st-^9_wG_$7`q3-Qڴ"׸ L&`xMg3[z9AMތghkP$'-7E)ZgBA*[ǼM=} kn,/ݭk^4豌L"1e!Ãjć%+ռ6%YIvVOMCl7]]s|ӉyE̗Y>!/IlknUh?0+a[sPBwO<:( ~u+0 U $'mARaO~'qb 53\eջnc%*ѢY"mzesv\0doZ(`|эSL<jj%%Ђa>MM⇂/V??'z"q{t|bI|M 92\}s'K:/Jԙ_"ab?S 0| EF7^bRT[#nSz2,d7yd0*JU%+@%+OťңIs!#K^W"Kuܓ"nb g툖 yiH1UՐ8"m`j y?\bsHߎ-k| >e-; Ҩ5lCU:Y,YXOdCR7Rj2A ~OMtb+E {PKNzq9x o /y*ǽVu7ܨ 1$\oPC5V&(NhZ<*y?`:3mM)+5vfajfHά\~L(S@"뒊*S7S["Qe5 |]"hjԷiz,Gd;+ JH0T$:WXvN/O[ t"%5pb+}U-h"V r-~Ïе8ϭ0\R:b\XX"|l0+=fZiA-b_&|3fCgu(`#! LX|6XguCu2,w|FYX}lpY,]tph:KRpU -vy1KCM Bz ~N̮= $Iy2=it헥[+&\78j@:F>?j%nF] U GjmL'.uzrG%cJ$N2̵/X"*̦$wx}.J# 0'>&~@#ϋHVo'Jz+᯲i"LA'( q0C\gcIEf7XII4,ڠ2'Jwy02o31ƝC^+!&g{ҼOpn! T&!}8M ]od<8ThO䖼kV4XɥH~a(a5 m$q.젥@9.FU?0ԅI:uG$BM|?V 0Xb#D;cߺĄ1G'n MJ{GR"pdO2@ctJ8HWĀD 㠶>^\awwӀ$ސG&׻lN`|餋 ~2ڽ{-}S<Ф_Eߊ.C`Rʔ:-OL/~ʅ0]kf,0mMÇsDLF8wըC^klXOp0`)J,+{/PшRcűj_A2Ej|Iok=䒹ŵgQ7bխ?um[^|=6k p7 i\zd3vjdyIՓ7ufeBxHpLR/%M܃a%܇oej=,k}}r=$7/kH&J@eb?̲Bl=ցciWijpyN5D+92=$W48yzr1ɥVX.Q|ͥ~djn~@|oDȜm{ϐױ/ώe Mpjȴ\t2NJ.LnCAXqnGS=d& En?JgHк51uܳQ2ե>;H=z^Fڊ JhÍjѪ4C6xḚā؈X&ůU/QѸ䔀~MbzF<`r:]A9*\ȖbG!¾_yKT[ 6!_ v9nYHBʲ\ QuC4NL4{5=`>Ƅհt#)p4V) ?EٖٚZuel?'LiI)Y|QEQv4!| :rG LHa8`2X8&U[;aqN)(MNj``pSCyn[lp=E"?§Թ`9}BEKjH،>:qw0~Ӕu?~k]e12nU+^ࡂë+q (=~ ;4WV2V1-$)e>I]>_C(`Ao/r5]u6͗PTu/WVud6 nDjܙ;X6> y ~<VHܫ&]qv^@w\@E\rNJJCm }كy:pU&;% ry3-aFK 1!ޭ?.pP7yEKȋ+Gy<.a~z/aX(B$w"8bAiY=qSȩz>k~:tL, 9jW?w-UIwHq'޻M,.$鿶^f z%[x޷j`T@{;~u{>):R+PP DP]*GT|a F\g@n9%W4R?bQR9PerLS51U?%נ{TXl4( B<0SO/CkjST 1#ꩺ"TvlN0 vJĕzl{6)WF K˄ 8>)c(dy$?"y5%j,7џuI@W/LKbiNJ,|hbq,Mƨ&+\yp.&v tY۹3};}"B+dX% 9Oˬ)"nm LvŌn/keUv = \wն,a 4lIXN"`א(v (:]iϠ?3Yxg9m/M~܀ԳFwVp;}}ԬG& cP1s|b̂ =go3UPhGat:!@aBYaf4APGk#Q][x9`gҹE$gFd_ Ew{ڂ0,1[触,?zȆJLssTˢU Rh '9(޸jضTSq^|x>*WҔ@{ wjNEh E>= W~aRZ[.-OKc᧟&_TfK8U<"TwW)HT/4(7M'YN!A1C¼ekku id~=,?M!룲s:+ӠEIȈ5йeZ 95uMgx33vRּo*FZB}5 F嘿b>p@ g,$rfٶϴtXN􅔍.a=fS"jOg@Us4_5$%hTƞcʡaa"OM& Ũ(vf6wkuIWcCѝ9@Z9P  Ocu1h7{B=k0BxC ?|1bocs#Ǵ RHT䀶K**I3ۢ{EI|T$0Jcj($LbWd<d rDmml!=Ϸ}"~' 8SMJݯM'Z' +eͷ@͂DWʮyLSklMId<VJU|{$B(NeuV+eAODtqp1ݻLK$c1_o&Q8ڲs&Gw*quG̜@l[G.NEJy:IPqtV_C2=*r!m‡ͣPv7- 'XEtKdgӺR`6a5@~,lYƁ Mt{(E>v&)9ܬW26T \yWԔf?mszyPJ9v:RŎĜτ îsg)fO cށ4:1U߾`0tD@^¢4i ~ŠΧ;F[B آ%e6b3//6tA =MWC  I«]X⧁, &1mOs2ݬ# mudwΠ#y1""ФvomQ!&JOl³W=tV%le/K#~`[˪>ǎ/G:OEk&lmI5bRptk],QaiB pgKH,K^FTi8?ք@G|Xca7fXjB~MϐO7QIZmi܊)ɨO`- /X2rp)1DjyR;XuA H6tEuq>#: ŠiqD/؎S]{|ug@C0 &<*N ]U GMw"z{ж!FBL!5]䧀785^MQv\c0]@zK+\Sߨ⺗]ڎlrKz^ۆ˸vo"]BL e6™'׾L"ka0t27UX̒=pj/;ft9o0Mʷ,kJ<沽{,s|Z9ګ/!xKtq8 t35(G1 ΂U2K<\k_5]̼NCRn>*1fLiGY7Ob*so,3(NU,ඪn1#@ u޸{*:@vŰkJ{:v{d }aVk&h!-@m*]ZwN5N`]ʙ#I,=\jЃaƷ-? ~ZI1fYYf=A8yxm]'>d[v<oY n3u,IVM?^s3խ0~Pп/|)&y?AZgVA|mvB/̀R۠"Ll&(=ϯ~ XLe]5yykk`'vrLS?A(:# 7ظ&sR$%NVҞsPHv9@jcp~v8 E8ݝ z^ycUGB%F!;%WnKZMb8"7u 4,tH޸2!|NCc5\>ᄖEh!M{l /)pןWAb}1ˎ_[o|[T/|_e>SS\h_CriK@naK!sɇASZ825sb'0ŝԿ~  L g838΄`_7" $I\U/pfq!Wr7}RQ\k#ܞl2CxgByĎ H^d|өFQM_!5 `ҒR,~ "8/L6~$2R+Vޥj,'IIv.*O>Rלl󡁸ـlae0^˜v3g7UZZ.ш@3<NVXNBR-pY{P(A\2-EK@MEƄ 8N,6HszqGIKtG(U*-#яl,<}m=I&L$ Wtϡd@AKkc˒dzԶoQQ!yQE >mm[+l"g>{0̕`"? |Kr]Rz5ajPZ*Dd0OA ?tYӝ_k-J6;\면aa!!]sp!L{=$1Lޠ!Ć&qʖotn?4rtC1_A!l봕##Y+z zdj-PռA#D j0j%9 kW"~D,=_'|sYʝyυ'nb@_OCSY}SZ;|xTKZ qYI=Q/'G{KWn(H_L#€wvt;(hs:㍃]9Hl?KiK>nɔ 1}2[ NHfo'<3X'+2-[O{9׺%QǹnV.<  0'!c^-玞˱)U@A`G,Y߱Bj~[Ee-0q V r#'_8TcَPժ XXu >4Z7zӭO<&EkpCQ_U*F2LogYhE; [po 1oHU %mR}DSrZMux n݅э!\UPAPJڐ)ztE eIϣQ# YWR2IF¶ET$hfF~běR@C+/D5ZS;D`K^vN><|C,˥Gz㓎P6XfYfpoEiiZ;zR/{|Jh1 i6z4hZǑG׋T-N8z=(WuIHF poCt`x!pa~OA{A>_^nIFk\yg$ZOIMd3'E4M:Ke*H͏ɳ FDϯ[30Ҥ\|{/݅ ?wp:N_P[`$EWiHe yՎiAR3-}O{n5i+]↲RBZ"Ili5*2>$)b)w?{R Z&lRGз2Sƀ*@foI"䴎f%W _H"9H:ۖ9hra~WKٷ&?!=v E*0RXSC'Z8MY?+lM~nc^D~̛u3Db !kpxNqnXT=_>۳B1x?涅TYͷv;1E<'(IpVUdKpvp(W-{~"38j]f:/&Z$5]d5"gR¯65!GB -r%L=bd+MET;S3gSĮX~/Iw":4=vϻu B0a=sOgA^4ۤO?U2 .#rzy.Wy5l}+9D4 ] U`+aJCAW<wD?F0;t~ 494BZVf{oxBm\`_SU,<-3+H;gUԒ>,x_wDuedGw;i1?]:zu7B2C5Yvnlo(SxDW9"]۷UG< T3\ yc eўrhNsXB4Bp$ko%~5 ʚ$nytV^h&%*9u$JG?X%MA$\n'JWrx$ Ff`J#h죈gs y:MXpd0$bC|D׺dȷ Q`#mY *}no}M *fGVDhqMҔ!ܬR۱uQ^y7<d~$h6yo_ߗ.] ٚv>[mZ$ݣTA~ͮEu'0zcC{)䣗It_BQ?*qr9}.!,P p{inV|< Q cяp))D^D"B5MQ;j'JaL:`%S*TЅx 6r4=3;o!nzlR0J~QE :H%d@B>VדpfQgg]k ,ՙ g XY,Q?cs+r_/b/x'bx]t,jݻlٍ^#ZLþO9D"l(؈G>\F=9-uݡUU#99r$ӪԀ@3"d75|;h/H(Up|J3pB!_~s~2轪5n^:̷%ݞ| qNʟ*rX2zij&aEQ cxU-?(Ss]@i'wBLG߉cP׶"Dzq,za܆A?gBC F \c:.4"^j܋"K;icp *X1鶵)b,Xp+:I(CwpuCj<1}\~v$~+(}9raώPػ?.n 󾮶z,Z/NAV6~89Lg~)`z0=\{;VX.aiU4(yQڠ:N c/[!#xUfv/-J҆XWQ榌S(^9? )ӱ{e/ p>޻TZf~8LtB-Ɓ6:pU#%m^jױk#wu#~CEJBmH@AVpKȨco|[nQꀡ5Ǝ0(0>ev.KzP6 6bg_yǟqWG%VU|Ipe'm~=dm1BZ&(Ao2;竁(fXJ[#e=921,7vj cCSeE;_/.Yc08%&U,<Ĩdp.c~O4^[lmV _ lP#@{`Ƚ.5D vJGVYF%[ѐ̍r)Z;OGo&Ri 1].nr.m%k\]N<>^˂6<%_| /-h c$;# vyhW+wܤy-;zP\:^0ζB_*dP2@Աg`Inx 8q3K 沶>j9 F6*]TW&WyS&ޮܤnݺjvS(:K{"k=%1Bgw,v)KgaTz<lKq x;mXƳfl˰NvR0/}L)mpePtI-Zw7Οf<4fY_:Q ȗnz w[on)aCB0UfͼSr-Z xYڷSMLX0PE,] *8Dfs,@+Hhڣњ.RfxQqˆg^w: ͳiYqkD-הʄ !7SaLV?,ȧ bb?g7#J,-]uk<0؅ːA ?ŋz}eZXnu脇g;Iu0P2(J%J"TXqT KH~SdxEyVvŝD%=eŃ[,_,v7̦xDXa XZPc%$cw/w yqs?+Ϟ[0b+'e,5u]wZXLlwֺ'=Y ԁ?u B <;bd[(ʙ{k2K ٕ^E-Hx1MW@ z4L#(EkSŇ :. up Aso6GgF,?&h:Y!*SVGku=V Hmpm<2ٯĩȨQޱ/>HٔX{ !n4D C R!,W fkCN.zHxN`iEdɈA+O AU?Kl`s@(;IhѲo)_En@, g6Rw$4EDb>^squ4EJէHB\KwqgTck?``$!FާHeZ"'U5 ]𬒕7hWR4][93h('D>C E b<sp]vmiLOP=FvdӞyW73"XWQ*U}t7]溯WdNMKؖv'};[{ RSߎ/SyMP`$CF'\iN_pZa,:)\YKdj7@qCsz+˕n M i3Lh=)je9v?4P1}֭!B]R) na('G7`ػQ 쁪CS=*A"'^qw"&9FeK.-yU6x95~h^[ܢ&zct ߢv~NLtUQ5ZJxg=6m{LzVxwlx\ڣRXF;ch e>xp)LBpvԊTXoSaŻAh~=~g[8< %%ʓNb"Agc*O)0VQmӔ>x F"?OQ zP]bȾ$꞊%R+Iｄk&dzU7oR@tI iE%@uWdR]vpF6ѼjJ7ٍ uT/})GfC {,fD>^%ZQVv%rK'9cx ufGIEnE2tM!of2˴ʞp Á3ܽO^x ׉U2kike U1zl v77Q(ic ("@h_ŃRK!̥bu(z?LTp a gISF`ǧ϶j*θ:fekoNǧ23B$k3;>t"!\Vǀ3h3[!Ǯy}k9 $H~}pT* CB+L)|[} "+~I^hBSzP͠A܎QXehB,ޭa ڒumm!FvC}HyWgO%+ ETWflؗ*pTS\vdXaT?v\ͅ+vU6|%[$yrZLBX4I:;%xK7>>Δt^o=1<]Dyf'P_E *bcfo}-Xm0b^(G@tHtBO$LTG==vϢze 9UvL#a|,vԣTn-U Xm4~Gb] i(v,\6j=F}gPX/h-#4b;e aGշڶvKjJg?ᅅXnWLA6F l eu6._6?,+ u#0%8JGJ 僈51 ca:Xz5Img_`mdGkqZQ}zz8 p8AO[-MU;x6 x_ե6hC\YCB-Z'W:d> 9A3[*NŻEu͗9J/tZ=G ^:i~q<ݔ9Ãɜ9A\ēlseu7[јx>^yƞKE[x*XD^4R d!J:w5.Goq/qU+*LǞȇzG)dt"Ү?U{nGD}1{Jbj7uip4v)H[oot5Sw骕D CI]^ZPV 0Lސc_h^i9,JiuOGY` N.]WL\(P⳶R=Z4~F!.D'u8)1؛2/M11q^|g 7n]_4ꏎ: 3 y}AHxX, rFșuJw C?1Em _rʑd8y70.gu>^,}[ox)V/M~<%)4aBI/MB|7ǯmzkգ:Rm4j }mgFh;1MUpKhfw/#Hp-z`8:.C/^xTdvLdBܟ5x4 u^o'9m'@&Nh(7 *D |{PaPpْkBd5qFqK/`Aܮ6tmMCcZ(\P2VHwveuyGpy$]cװBV&mH^2!ՀSV.;S EF^/4Q! u{mBR\X[ n(e8F<թVJO"]:#{/TWUpP;//."RVe|pb3M=>Bd4vvW. ԡ`ǗВ%ѱhYHRQ9@YL"W2o`qKzJD8!~P{1SJ*gm[/y~/VJB?GtaV>#/x h y Ѯ|ySBo/52Ƽ<d^;Wgt6ٳy>l@:h 2 ǐ,^wxc9xa _os6ܴs+L+*cÇlp"يJrkjUaY7}2cg./X,su| tiK)OᶋvX mIw ;#Pxe_(r 'en!K_'eO>"xvҼsV;26A[]9|d b49oe.SWG ^P#S >૒^W&'b5>ݏSћf3GZM*Ir+a?p2-nP!,Z]N)7N&ݡ:<ب] siݣdXH0ֳ(-%mL$F"[բ/ęaŷя=rg\sc%d_IݡPg}OK.[q*x?'8~C}\{4齇WXttk9>l fBXÅpd֗ 1pQ-_ft2\}Fkdle5:Aħљ_C֭r%5y{%~I 2f- F? 4ES B͟FΒI_2RyRm={?#d*lƀ+P7g1h@Ă.a ;*!%WWXW;Ma j#rk݅zԸR.W6xsC"E'b8ڞ$`b7\ZK8b\ Qر;Ynl7z;xsh튱#D9Zsf~y{En\PtLlE.a3mzz.aޥ|Դ`Ha }%ܑ 'i6IGU| 1B!f"&T>R*£YCd62RD=2P[H/2ઙhWvE#r@:=0Jh1AarRN)!4PDb7y@c1G {w!Fͳ7IHFiZHB+*:#ϔ|! ${]bW.V -004?==93 2ўÍ~`FwWk Oo)zɀ;4f9u:#0nܚFC,"uWNv+7[OB[IJiCoi:daay q ]dG; (yϓ;J߻cN]8O$%C"RԏĜ1=쾈/pzRgoLș0lUl`| e' }",&'ɃFyTFI|&< c5m OtRZRO'\̈́ HK6`ل&>\M³ fNRrE-t #|tٓ:qZƽ)6z]q#v|Y8p&ln~=R^`J}zIDZ;Ao0CsbCϝvzG'Aj;S3-I٭]9tQ;1tԒ~;r/\8Bt]$*yt]?LH:5ޘK#_ #KSNH)K xћ;`83vf;s2XJl2ĉ^Tr2?Vg @ͳpVsH*T]UKz*_=UfNHnt7: Ͱ),^u,[cf?boc#KpAu e0 هrcP`Ix+sv2I!6J}𵭒;}[n .[؝R3dw[cfn!DzTZBJ-? 8N"6˰ᓿ ʪQ22HQ6?zFka< #PNZ!-faSCt5(m1N[d2IO GZ5I(@XjwCRD]ɩ[^YJC=y}܅N?*`wWp> ߇wHBM d5)TD[=^j6R18y9zh..ڿTq" 1+Vc3ehe /=n^oFݹԛL8z bSi@&Ie%2Of+GZ^&;V;I5z9HaLSL3u?EͦqZ4Udǃ5l剃ga [#RAA}|qHǻgo1Jʐ2 ٹvQ?>F0뀎EtӒ9Ԝ_Y}7cTyVbP>|csd*4ErgId"6j#H^"qz^rySc25Chl"JnDh>D5~"x/oK!☽#F d.UHc잌Gnҭ>yk6ExМ 7DܣuGԾsA[%+t߾M4 p /%^8ؑ5`4& v?A =!wi.ʒY o 囱ȓ!2]iش#l\=[MwF$w4ܑ|bqra.K a;?;8;˂QC`W ` Z <0F=ΒyLв$5E/qȳڥyo+w_""Q`8uP4*z{moO@.Sf_tٺ){ʗvB}+o"6x!M䬺k)=:^@[x@ۡ=oՠZχ DaqLW\3LؾCi<>ШU+ɸj?`S!婢f^y+Md設IrNm%%LKS \{sY+:Z_^k:+gMʺ A/ ϙS|"iM!L 7վ@>^Ȭ(;Ip$]{ٳ~BATxR p$Ι`3=-q)1  " l-d?2Xm3 ʰCj ۑ' N5>_ȑ)!G0@)$ Ghƈt(v|vs | +$ڳ-\pd @$i'#VWYpq{O1[p #w:oŒLRR- s y ۗ+H\4i %çzkk{#IF?[Mjbc6` v !n׋"܆|/IYC>MN) tQno/Q2?eշASvRU)՝lbZJ% BUhU `\k - mGpnGxUz] dd@B@١ڜ7v7FMb~y55>]ç9kE}PrLIkwUD W(Q,9vj&T졏om ZQ*Z\ '_hD-(НB$*& 헣wƃTΕx%aKdslYM>k cCF\nRO\jz!-ϒmFUS3OcǔBV+aCᅀ0nlah( ~9 F"9Dh\k$iƬ^Vn%=f&U"yk~-O =P({滬%.W^*ZDMfiKf;,&H1JߵxܯwD9īs!&'dǤ<  #t:]{ºMyCWkʂW /*z@f{P+_ A.ܕ܎ }EjRh㨄 u٠ m_8^`hFC | ТM2ʭ``IȪR0ΛYlE'U@L#/1Z;f:Ê^ e5TeTXW7{s2@ &Q farUYB ׅ|h{Q;֐o0X  oYü%pqZ9O|$RO5Dw]wj`Zm4A䐴NYq"7m}PL lQ *$.e3I3o?h0sK ݅!:[f,|d#ȋC8\/N 9&Č8 B:iBL|I-hE)?bնrZnئtҚr&d\w+,e%d;Q8hqd! NJ歆n,\2fp@H?u~F4 f(27;k;_Qq.Kc$9 -]XDTn>fQGJ΀k14=Ziu,ҽaBH\e@ZH>_c9Cu-Ǔךy2]yjZ1!UziTPp%vtLQΕg#F7-dx:b~pT C3GМ^dԋֵV5w/LB₷UJobB@"ZG9sYuhDphI*8NNs약/`RdݒI_HV1TJkXKcm'HT$4q)ۺUEoo1ca D-4:Ge [biF:N U_; ]rGm) JQXR8z' gmǙ`T>S}{|:2Ѣ}dZڬP;E(&A68쫳: tW5JTό7r H-Msij{!ϻ}5& d.n4AM [a9{j~a{ A_2 __궬U,Aq2Ck* ;rV;"{i皩Pb*=`U\r.s0HJ;/E!,"MQ75a ds{njz0h*ˆ ^.j%Eem 븝f;2c#JTvey[negz_*[i&P`W;3{:ZS-Ǝí(A{ȀP*%#pZlo«DFL pw57 q|ɦ2^'emHu9ckZ-fmNR' 7kksaq/U@ Awf= Q%s|\YOey? H-g]@0 wzMs1Pµ3Y̤ٱ=̱u wZgi/4JXcyݭ[Gm+4!RX )oI<̉:v1R)k,!BYbrٶ[(5}RC U#bNCn_] J]KQHZ‡ aˠF~n-C( K:s(9'C>HLApEEVV"jʙ%@3ެO>2 ~dtj],&.;q;Q&NE[GBՁ[_^ i,8J$GN_Dp]hEيm1nSiVGkұ]ozn9X 2+,|?rnޣ rхDX A1mfD;kЫh]P̦ԌCpMzz-Ɨp4g*]D@ %LE 34;2u&鸤g)^*ɊA]"=(K&.#4{#1,_* ޅu>]? ,TĥOI@Ux{j3/ kTc1:$(;Su2y5Sg %bFG}&0:O¾"k򣘳>PV,U ly/78u yyk!TN$+2=Hҿ8ݸ fm(%f_c* Zh%!8Y-<UKҥpѻ<ߡ;L@qʌ1S xT [>yr+YntQ>`yC _tH8ҍSH0C£ *sL`TW;E8/[r(8 jߟ SF^eк4a,Z['[6f[y=N([hrJ?Tym*uX"oJ\51Ya4l̳Q(`/_1FL?̂g}fţD {2EJ\-fg+#dri]1AXvIA{h&ӤIY7v/lz+\bW'&q#d$P~+GǷdYXDs"j2jD7aIפ|(FP^fM5ïq8Ω N0LMJOE5J;N -gy;_;EcxgQo+,So}ZN>S*d=!ShYbC8wQ~iFOMEl]뿝@152wS{*҇3pǡ 3+ҌSdb}<&(7BݨQIe :x`z-6eB^- ࿢i5fw,V`* j|ugIasC@*[}ё³bBNBǾKCjvD:9C?o8fu/6ܾ J)s?3%:bߔ%rgӶ'Ka\%M_^SB"ՍA U22;iKa[roë꽝.9ty#sQr2 f.gW-;k2B4D"xj}I*ո`Wa5Pc DGxhp'~tP N6Q?V6:vݻ{jRm>y(.ZN}FϡSq Q.)kxC\9$݌{a{>ygL\9%66[O'Tdj9v@}@^/t?t:jr?Rzӥ|`RHǼt#v§M-Qrğ(Ԫ ]% |$LPk`*cR~cO꬙YqO7=^)d $RQy\8,|SXi"хqm\x:D1w>9\ /$5aT̝㒈_bnt5?ܢWB5Y( Oya+5X$/Kиd8ná߱6%q7#|a %8!2gG0e:c͈,蜍,W[/ (e È Ujቱ(#DS2idPY .}7XLͳ8 bVAގ)\KI􉳍ft e!eCM㲘&Ȳ,vٻ$YO'4ե?4^{rDrQVgn{ 160swTGBPF" $eP ()?zs\[ 6&I5I+yrQf%dGyr3@޲:;^e1_Pi K/󇜂>V%R3SPƺR^|? =1%T b?]>k$y O-axDeu[v0ؑ{e &ƙ3voYگ8ŷeL\、s~i3 re+i7zBaޫ&Id}o(hi<rD"8aAq |ٕODy&"7%P]ږ yEM<3G/("Wی_gza#K|8->0Vh5s A*v?ᆽV=+*_![}X I*#̄t0! ELNfq*Lz29庫o'8WtYpQ2w i4Ă]QPaB4[DsSCqn2lDK [ONp ;mo݄MyD$CΠSRr;*?ynY#+Gum cؾ q>ƺ߀#8H+8v<QϜGs&brYb-aF䮞ٙ M9V P'RҫRM`ze=l1=RFzI3?3Jw1_Ql)0TShkLq K+NM`"h9trl?#o^&&B4?uS>cPGXO)keHLIʭǢG=2+=S֩Q+8];>QqySM&ٟE/\uN/½=B4e'pXHN Fs{1tl n&'ԩowR]qYNȀ}G d| XV;aT9TN2̽پseNdu&t?4ۆxR]}rB5[ɏ7xO5=).@\h9?^?1aA`} Xq܇R:!bm^x̎|"r'*-ݛsyi U=2&9?DILFH(R7& \Zw!ΊüG&kY-F ¬}֪R6CyPٌ>w׌IoDX_`^v=cyhuU ;4w.M!37<H cc4ʧc$To8ˢ#J_i%g|}JU9#mO#o3 Ac÷ (gc60,8HjeLbwh}\fA'}xQ{CGplәxS#.A[`aو%.ѧu5Vp^H$X:ڣv^ۍ:B 2|\qm< x0jv>=.[+/&rbm?1W)78rGC9{J; Nc۾սe[|x7BƬLzq6|"_{b/!D;Sa.%^cj9 ?(CĦu'< Zj-tqȅZפɣZ#k_ke΍)UEFy_^pt@pmtΤtxf @*g)y _.b"xeDvk9@| ^,4D^N™_ ]DXLcI28i~ǚ؀fI JۏQy7;YnͿf_TNeo,Fu_ps<6hK 7iqDz&%|ʸ +.1owƆN^!LaܑO D/.- L$ :vq󛃤ߢv8=SɄHvcA= 9 3<ƺp iNrUQR@rz]=&2x $$Tp[\w7,~Oyu s"BrCuJ;}bՓHOmzI6g UùyՈ.n6!+?~xٯ' XTkPO"' ULϭ_όgV߄Ɍ)Hr &2g{wZBxDByR,Otx -͕$Cc>$r?B53}hc82l>Hcߍ_Mh64_J-Rr!x gm ,:IRZ%{~1kn}1d7p<;չ+D"(t8}׊iUdއG#E}}Q_Q[{_t{S6;"F66K["|ỵH>yDkmS ?srvK]JBXs_mFm\I@/q9Z6UaF65ާ%<8}Ymᶏ\uù;~n@dc1?RaHmRqk ej~.W֢@pf&xIoGmf"5{9",q f38c z#ޞ!zU.-UP7Vh"ʼnʡPrGG*PIwʒd)x0.wmtڪ7Y, y4Q4 .D}TS>eâ9uٿ14FͅhS) )jž*:Yq3y/~gRZDLa: V]d.6ꓫRc$ZZsaEMG>bbztD1 1U|^3"PƐݯ όF3ix 1G:V¤Qqժ$,lŜO}f%4V#~_b<&1QO|B>&M90皅cS_0]\A =`O g}lm*>6sxP;i26܋C2Ϻ(Xo&qf6Fܺۦ¬v*XM@Н@Ԃ[PsULXF.<|J./#u_1W!q`zuɠOj@]A⏖ӵ2L#ǖ,sQsSFI#1 I;^PS͛11d V(]FiL1*`.` t6EX_ mZ.H !Ŵ2JܫB5W&P51%V)rUi*ٌ鍃'C|Q76SOlQHZ[nȲX}&i!;~ID@M?X@k0@_.8'bˏiVLY kyP$ղ*jïIWeP#r^45X"elɢ%tgEVS)>)%@/ ͅZiΖ5~QdҮ֢bHhZt{.9$T8& b8ꋜ ߣ#-*N"kZ8k;hq>m㳿PFxpŋ;(4]` ~tZ8ۚ*Fd + B㒷BbB*k?д[#0%iYE[6ηV#c$,kjYvR ihapQ@=e>>mJ=M}vz yj7`~:@tZ 9UYEzpy8,k`IVܔ8 "Iձ?8D;_NTN( M]226}pD-v~h{.qjz`V+@zJ}vIN<$Qb:]whnE\^Њ,lEKynm"$5$0#ȑ_qBCCi7{.'Հh.PVle5C;R#MQ=׸_5]~s7}A<8<'_0#C.,3f%+a8{7,jŭZjS҅E>bUQwGv)y=l}IW$iDxk8n#RXD"3z>F$MtƩ?BlB9 I]8S |ǃr'Saw/xh{ rBIorN%aȔ*F:jЬaC߂8l~z}tHJ&[ 4AKNqJ#7iL$F+ϥ_ y|)&=UqKOƩ 9dY9.Xtg `}},yTHna@m@M#xSևZ8y 8L%=wGH^,a]k0&B%uI|-E[pg/" ={stVsX%i0j6LLiW٥Xǡ*+]f^*ȝ%7,/^Ae-l{-o[7? %H|R^Ma8{M~#Q1}B 5n#<nOஊ Ⱦ+d٧`slItRMdG,_Y[7/d:֗,|yGI*x WVS%}λXZ3hz Pxpy3%hs5H6d ?f |&^@`V~4s.&^n " =Ofs@wSH۾5T8"_ Z62aIזdyx7bq!bcUk$%׳iA{a]@Syd@ ߑ e?uJcKItxYtP;yKJ`i p'$X_vcM$\E F7g8 Ư*c7O!'rklf!OSPFCN0Rʴk.7S ld KXM^ÙC@?-R\zAOa? qRlEt\u%/D*K#}+j-mCԚ@Bd "IBV< LM(rn44հr'ʰra5‘>z7џ[Z*1:STѧ }t"Qx;hmAIx XCGoW@Y=$\rh͔TJBrחb6 /\4Pqv$TwEDxD~v%^SPcdY"f?& [lgߎnݯ{z߀v %$օw~%ZdMWBe4r rDHI>0 YZmets/data/haploX.rda0000644000176200001440000001330513623061756014071 0ustar liggesusersBZh91AY&SYj+^ @ <绕RrTDJTOP 4Qm<63)Sު?AS=MdjOOTMB50PF?*O*?UP~Ph*CITA h@ISFz&SҞH64  4 hѠdhѦ  4ɐId@?OꪢL0DSTyO&cSe6=FL#@iڑLi=C HAM3BOF24iz!!'dK[BM jPVҬY*]e%JRIntѣMJ*˶VEwE&սU NnR5Z֪aW)[.]. iꭍU- .ݕի*ҩ,kJꦩMQU! @PTo;8UZ+@ b D(ƠFQcTT("].A(U4hhREADSbE"`PUPR5EDEUAU\!ݧhRڪ.ڋI؛PW,ZjdzRݬj5VZuhfZ[*muZoFJk]mBb(*ZѫjjҺv:گgIq7v)kU`jmrE:6ejkN uC[+M fi 5RjZ/kִ1j)cִ2M emmT;Ur7UiTZUGr)eI$U7Bf")BB@(䨄eNMI(=ÊAܒk[Ii&A[3 %u)ZT;ժ;a-(IJ{#]uE5iLL-IXoɿxK@W {ZGBGĔRUqJ!|s> /r<)O0n dx.Cy4הIIGO}t~tƹ_x\H}$?#FPBNN(^%Oڒ~M'NH^~&$:4Du'I:ԓ$1 Uv'I؄?I]Y'I fv7]" P~har W9l+ .RH\p͜"0&.Ay \. \&C!\\ß Lnr S0 E0̂ a盓1r f f!\&a9N \^  |#!Oa3 r fA}T &f3! Vd!&C!fY& '13! `. ݋a fAy.. xfAqyL qs028a0a079\̂ a fAr &da)r \9ȸ S0"0LuMz x79zM4M4M,M4M49ÇD!@ B  /}o}}r#]:nݻv۷nݻv˛!A1Baaa0 0V,Gbŋ,l7%UUUOf%88^znݻvۗdI4TEr"*I$\rF˗;)Lii5I$I$I$˙i\lbbbvxxxxxsM0q41E0abŋɓ BZ/j b!{{=\n.xvvpÇZjիVZիV`ڵkPf͛6lٳjږYe.O'2Y,eYex_ ߜŞ>%)J, 0zy?O|JR)JxTskZֵkZֵF@,jVue,<<<뮻ݖYevYe[.:뺞y6lvmےI$ݹ$N?}6%sss͹r{.\r˗u]nލ>|ҵkZֵkZԣ!B!OD1B)eYeYeYe+\uׯ^znݻqqvXcEVZ^VZh&[[[[[P LXh R)Kт@c5 cW^z׼B^z( \wpB!B()JRR8!9c1c1c~kׯWbM;}15ª+DdDDvgIkz;HMHBEPP6[ Ng]fK+6$eVj6 sjɍk3cZف[qit=^3ٰw6hp[q[J3Э;n,qe9<WaxBT)_ 8=ҧHSCyJ)"_Q>)PETJ jϞΑEQ}=ﮕ<*ZW}s+Ge޺'xVWLT'BWy[D;x=V''TӚ[XP^3o^E #yjU%$Dxy5|3+J$g4 pICƇfش^_I&zދhCX9P*g.z39AkYѡ2#gv@MΫL\w7q8[M s^-= zuJ `;m &YCpIY1('.i3nuF\z4Hlؠ%?3b< ou+R(tErtznf| 鎴-e}tsvff>:'-iVA}+ Jmnƫ*ԟ8x hU]`V^D ق#J가 85BƐdRNlDnJxNYÝ`"g ee /:_բNDBQ]H:9S2> -z0um $'~؇ 6 2#ܢ*3 TI7W%3\Ӣ܎8.:]œbz=Ξ쁛r|R" ^YmԂ#`}9!t=` B[_4;CElL6r,"G'7V|.b=(gI9 1C4՜d3wDYmets/data/dermalridgesMZ.rda0000644000176200001440000000103113623061756015540 0ustar liggesusers]S@MZmD|Hq( 0+tɤے4apOg7vys69Gn1ƙS;$]Ne%3= 0 z60[ o#m';ϿMk{}׮96հQ,yzY/E"B9.("(I0 xfC0 =xT\a E?ӹI083 /g[J<G#,ډWzDHS3~N`jV6yŔ>SuӨQ[ZVZ3jݨQ56zmyFn< 27{^U +_.;&mets/data/twinbmi.txt.xz0000644000176200001440000035024413623061754015024 0ustar liggesusers7zXZi"6!X] "'Á#bL`ÑJcƺō!T4u/[jeH̹-povp ' ӼHT #hU,HbHzD,3LJFF b2oDG[Ybx={S|sɚZzY$B[a/~k>bգ[vO\%PCs[J;qTu!̭PN54J?c>dΚ`i5QkdezmD6dh8@q6U Ojd7~NsEC.cU'kї{^+U Sn a2*Yg6~ Tn-fIР#VX%#7ګIW҇AI{mRܔQN1@FløI6BG> .8ypSִڽ>)ڰI@ a/)L(3`^D#zŇYnKG~[^ e٦u~Sݼ..S7B5uPIL krm}(+Cr_&[axQZ1ℒ2K)SsS}ڙ0R喊Wt5-)=9n%CχM9_ՐRyujYA>.,znry~A^" ڞeгq"CB1h:2A'0x1_IyᚋgO ^yaX̘jAvn$mӺttY xn7 v8&fG{z ɨکlHk}e} sjCRѰ3D4WsϭUZB3D!F?װrTOss.6asת##'Iجlr$9;¿=]oU`tBYq#%Nu7Z0#L8oq4lw(5 eږN ̭ꝅ|z5Ѕv/]^fq!"n(4OQBMy׋#c^/i&q` ' x+Yֽ %uPl̮gwCWP?pG.&~Fy~phNTj'D* مPKk;_btAy=eUTʓZfܔGKm}黁V'g!Z6cJINEK b*(ط~\>!~cF![@:;x}`NK lP>JNN풷;b& :At9x "KFi>=9fF>5qhN֘ gjm޶ A[B-!Dk0iqR.4_ދ;NGg J)x|-[ 构?Wk_aA22^> $fus6;"G vOa(O)ЫbnH@8waO,4E{( ; oAbu굙B\RF 6Papëz"ۺ]aOd:7 7XvGƁFƎ>hLMziE&Mp$ ތ6f^@!!E`CA~6ߦDi#qcIgLm [)/j[JT׶b"р Vc{YCg~W͋  Jw1SNgC0 ?uAF1?4y!PXZr#J0*`#\%󖐮=xGeoD"A:Zxo`?ÃlxGt!~6<1v6ICBVݥ=1jB":.k[{m='Y 1U-eCNV_m&E"Υ}`=Q9[d/ "9`l@mt67љDdAjO?z-zÃv=Nf _8f ^p[d3:,5=6gL_$*5Hzlfтǹᄕkƹ=za»3h\\ =|>J+u)hD9YmD[py 㰝X>L zS(.v0cZCFͱONcT|`$=>pr305iF MzXKae"G?Mcqq&vJ2%)s&PњV*5]CN7)O7]3l?g@l~Xh3 hɃ$[AaK=% :I䀸 R  O;J7yۧ&ih!uOB(vʉC_~(kyHVhnaMSJޛ]Dr)xšq?oS+D@wg[薤x6 Rp-5bO5A3p CpbP}VD oDs=?.Z!Gl_11>(rǷ KWXa.1& Do)'D>8,G{|Ȃj迹'&c5b݌a';﮶t@ȻW=f kYa㏀D2LgVE W I >IiɄ YFSCE$H7ϊSu4g3{Yo{k4+g1xlN(/lH _yrwrr[4 X%z c1d~Wu,dJ h!;#8=&ɰMŞ;'[ӴKiUnY-UyILV> ni x:5|zg.j˱+3¥sXh4LZH;չyT]`~(O@߽Ѻԟi`Va L!5Ku@/Ihʛ57Eo h\rW1 kx9~fWSE#3BӰaO:K{h ^KuïI8; cGn5f{gk!+N*bY5n%|EG Rs:A1[`FdY8n lG+tz骡 t:5wȓ@ };0eXr`cb~֑n5] xܞ{5fT:l6/ٮ#KJ,B+\۴1(ve)!0z7{?"Ū~a)wƕG:Z~9 sMt P)#5{Ohc|3r5:4q) !K#dYgqVMu'yl)¬ilv~BX&+ck`t֍޼|Y;hX2Xm290;l#?=wPZ*X^m\U[zK!'d αo )j{T\[\2!FL>TncEJ ll:sD+ AKT wni,E=5QƒsTggoL+ºU;.AXj x6$HB`؟RTAej* [;^tٕ M[7Yj {-/Ȝ ߬=_/[HC>싞 GV X]B 8 )ޛ{F{u7hdžJz[Mj_dNs.䁪10rOCw$gf҇"a7_cjuJ5'YdC/1wAȗ6M_4ߥUUC l|pBR@b]ӂGEF{6gU3`!1͉ iGSռ_n6Կϵ+gB9Cwê)n%V̲]uV7hz5?2CE 幎x]"?o;j }'N\r]^MmX:R6( D'PM(t%i`zJZtn%$|t?NsC|i*Ha> Et/c݁\yY!㟄9ɄM_"Ml p0M4J L  >ƵƑFP?1Ҝ«a[(qoB^y*6 :H `)&rso $Z3kw֝sC=[kjiar#k_ Hq|!˃T]^ ^]鐡;eZ>]/L ޭ=^書!ku-f$b߅*&?[Bi|m476'4䙭?IaCnb*ۗjbEg(u+|};hΣ=숍4^yVv':A*h-i\k {a te":;r3ga).)I"{TR8fn% Zd!]Af6ɩ72K'{m!鎌pțXd5U{8rO ;!JwLaӅv3ԮC*;Xn%גlŽIQ7P@Y+! )%7{+8==Ai] ɇ-y9d&5/`wTS6ZA4 EP?fydQ頢[0v{8aYܩOVХ llj%؜d޿T^Egl[~a,&x8H%uBro%Y4|<ְĕ$>!dhؒ* %"eO; V sZwNܝQn-3%hqJW6m`:>Awibhc~6,f8N™k _}_utRVm5ȵvu"{Mtl!Iv!ÃB 2mg64^hes+ӑ'4ͭ82Z*VkTafYR9ȿ4S#oن+lt29mᘸ^#׏'uܝ1PYC~OBh=#~%$%( C)ErB5sZ|w7ʹh=MYVJg`V 6qyʑD]$%+3H2fa^P0H JB1]=#t9Mj. w՛ՀBW`  ol@rpaI4 qLl(:?NW! c4@L=mbVWY @I a"#+`%3i3|D^A cԐLongnh)W>7boq_4~oGJ2bʍ uGf  N? *5 Eu\ؕ+05(Ib,wu y蚢޴ ,mQP;܁,ӍB}vFBȂogb$S@6B pA,E$0cM+g?K 6gϙD vmTY{"d/Jߙھ8q(eFSAT2'UK d:ehsqǛ^|`0tP J #;p@ Ɵ@ 3b$0>H4^1҅ =/ұo ee%ct ]ERYCw =E[5'|+p]g#>*µ 7=WcՕJ-m~CU3= E%&tg^$ O#Q+zBgTtslCV%<2МQL}CzY8)uH+sb;rͥA{[ciy意$)`K010L~ vA0y"υ8] +, z@+ai ;bZ62:5xb+MԞF 37CmIƻe\L+nE,aIN0?sXDM'I+{pPNe? Px4x yu6C7\b~8L0!V [P߷qe8f@e\mDԦV+AŹހqa%KR e "ɤcnuC*%,&X0G(A ,G]N, WL(Q-F6?MMYK-pVN*eX vZ*g;,v3J Ѵ(){aL7@1H@Ayq-NH>Fwj%P۵>Cg`„Ro\|}ᦴYksKh}@*8#4o'n;s"daUߠV&3U -:q='*s (eOm>J^?et0N#9%W7 .m [|/ڑ*0(N_[l\n_i(N |;$3RTBD tk$Pˆ{:9ܶnRJEd~+=t(^ݎ=d6Sv,@& ZX \+K8,gH JΓw$,1J46GΘ4}wm/!sWEQK&FVtfF81t)<Ț/$nӃbca&{j\ IOe?0ۭ3AIxaKBչ.E!>|_.CѪl(AVPB!;Bì0>n5B5oӑ|;άK6r+ݸnz~]*."VDz+9!WlȾ# 68[8f,yX` 3@r9*ӽǶF tg{>sqz謸wU{0#-"W, 9Sl?v5秄Z!S =t,.^n(ˈ dL# d :¤lµ(e5l.jO%00k6']!5Ea%F[XǶdgHa _]׈R2*7K4ů7;[s×_l25d@gFFmS./pi| c#yZL:\J v O=O/|(mF>} &nX)a!'TPBO {GKy#QZC 5af"@W2FP"7oŮ1: ƞ \),qWY(^XV"fL0.( )btQAS'#$EP($͊یdfsVMr&W Nvps OrFk#PeS隶IK3"yBz9MJ'籓 "^{4fMP{3m$1Ja'XϨo.u.@'`2~1DKvQq?ꖁJ^^"{g )R28J$a |yu9Iw[=aj~B,\#PK/;-8?l.#ϰXG=A) KF:${%XNdE̼qY\ }DhKweCeX6Zbe&fΉ9gW mr9x{yš!/YxNc#(#ËC){DT _8va5x̛鄑J<>[:w=ؕe#7ߦ ͩ آ@/9nаӆ6W(wN<ɇsxW2ݛlX˳#̼u=6ZuU՚pzG.Mk6 ,U!ηz=!+XwBأ_]6QT 9rfwPu⇗k.Q󘌅 .VJ{C%H߹fh v1GJap%=iE_*M/W% gEqJnpjw_0\XDL G8Ǽ=F]!QTz} adX&Qv'o- 2"DdRkC.V= n+1{;{@N^E%Eӕӱ`RW8{eq>t,?YTt+5ܳ-=I6 }5X#{ .!*dVF*cAj`AA ژAhN]]7X/F%U:o櫴qdY&"!?V8A7d@c64F/0J ZÅ̇^0~r ^=r1FG dnO%>xEV29::f<@װ,E83D,)bā1 4lNgU z`~MP>0K8T՚Z_AE3D؛-tI<ҡm`n_=l꟱ݳYES8zq"8MA,4V`0iKL"V҉Z3E Є03q:y ;*Ǽ/EJ`(a cԒd2A Z`YpY/Çۣ 3P&BJWcC=ר? U\J7.?x87Ѩ‡iҜo UZGOrjR.hLsVKn Ӈz>?tח2M/ ;n3k7/.嚧+ \MW?JT$Yetdܪ )vc 6Nn(Vao>E]Ձ\׶ͲԫIZ]7B-xF.nA4ГͩE_H&ז GyW:rOWzEx(ZCõƐ;6V"n 4#ɬNjs ]ܤMϿܦ`ߙa2GsV =Z~lQbd"&p7!Ǘl@,Y\fW3i+cE /JĞGRsrvR:͖{fߚAfITH[vqw+9J(lF`CTjбYZj~0断TDobrOV6;S6Fv:Pgr3a2F02N @t's4q"*գU>Lv Gz(*{4eƖvW IBX'j=hډZp>}1MʿbOD>l5]V;;1zwKp$Жm}KPi@ uxrUE8ޱC0G7=T 2?h 0X9 B/wu(Җv,?dXd–qV6J> :(D>Ծը|tפJN9!DoMD5Kku"J1#X~A>t)LW啋v %ru6 \IH*YzhGc/ 6Qg$$̼* &.5?#T;|K>)c@/']u@b:Æ:vÓ62 ڍ4sё82vW-PAw[ 2dș=-95$%DUymdfPHxȶ߷KFIGȵ;v;]i/0\=/#e)5@A"3F4n% HS,!I!Qΰt=w &{mǯ I&r;O$xD5Ȓ |j˄!;w : 7 TjpUl#!FibyjN,8Axv}L:eUV# 뜺B0X[$"y"|i@~c&/)-TV$o ϞX%#[i2qMy)OvFG,zڒQ0 !Bf򆝓H3/fSBg6$HX ;݌Z(Y9%e^uLU`ǥPↄ$iY ̢skSZXc`1z56DZ cCw+YF1\X\+(Wkaŵjc"b0`uqKN+nn/pIw)OFm@ 8#9/SdW쩵0P{]OЗ]=;!TuҬ %AqFq璉d\:#c8h*:nzpSzm,̜PR5zf" S&b (q(ڑtlO.nDÚ*łA 'Y`JDzJ2–gu.HGD 8PJÊVl8 PXtH949믯rhhJvF%'ŮA kG>Ph(?QA&7n]2C;/ ^!BQqVݜ+ܙ}Fa:*?L{(<wV/WX ,mu40{s`HXV>DbNPa p/P  F_4Mæs673b3#Vqp^}?R[{JlvQ@:̾΄ tnZ[e֗B&v,8O>Ąfy" ??[L%QS6VBmOEF tA/yd@aE*4f{0/?Vx4BfE%Bg2]:2P詣D:w0읒ner 3@!Az90?7j)Ü.ok `Cmi]D=(Pyl{!dpn e N迦XLH!cMlˁHwQ)cn؛ʌ'Y8uM7:$Rh%dV&Ϗ4*ѣaVX|h\GȋfTޔ-5 ٤\F+)u42/ t ᧨HM'¯aL<-G2amAL_ ;1}ƑRF19fR+=.2!9JygbR%6!,!2"keo)HMSqnRߵ k6eitY .PI8%Gt;ny. c|3uh3:шP-ԂL#U9]}#2&jwAiׁ&ȽjžZ'aM> ׭,Co噖+sRwD$`c$ubNQM"guIJ-Km:Qxm26 CH"\Q@AJp17d[/hL &:u]\9+Z[︌VؕdjE|,Ą1b~b8NS`Sz ވ]3^0FuP>۲Lh8$d9~9v e]h`Jջ.D1gNQ$/Y5 d2a3^?`Hyzzs!dSn0[@ɉ)0.6_~g8ͱ˫JgysT֜L %h'n1k%FqMoؽߞ ڰU`FAbסL%#um}N[ۮn&1룩RoH߀۴M gQ#])` )4=;UP3^ 0N<|ᰉv  uͧHTqOn E&W{?Zްoc:($ڑqvv.eu)&W٥~}8wZZ,m SRʲ7L:zpyY,ltϛ\e19E)gkׇl~-JTJ 4V$))_!=S: 8ODֳaE֑ 5Bg 7˄ ɲy#c >xd7T.5ymH*;n8/&KHQD!Y)>K#U˟%v=+ ܴ4xǫ [45pŻLW+ a!+D[+ menQ:zA^AO d&&$MK^ UəS~hS> >&'੔||ኬޘ6JҤIZv#|4!ލt(IuZP)=ÊBȋ.|n™TA𑿺C^T2SMmI,T8oc `=M\ä6deGl7W IW1sU~5K͠Cw ZVzY^4MH^{TM(f[չ:_+CqMB)TECl6X\Ѣ]+tEyvC8TPt(N"lBoF~A{v[*ҲJ9״ŝ)@ٽ*wչLQ~.U(rM&Z X5[Cfzam^'˦B`jtkAB# u:zkFӀ'3 gВszvZz߶(਽"Gػ=0v0/C?rR9.D` YڟLmUɺN/&`"܉ut!alϡ/W%SEbo Le:S]J7fPd{]!g!j6a PVGoyR۱} NH0}s `zYqwrLw /)q+[gw*MDyMF50.4`bGcI^I&Ma@Q=FurM+\eT#NPޭ-0>o)r/he6(Q$<8/27qcSHEĉT U4x06%,.4l^Td[ֶ7B+$b9-CvaY;}*~%tͧO,GN6%@jB"OjX7 6JZ7S-Ùy^0cF8QQRïNE_y6۪tՐJOC,$FX֕&6${e6Nr{ 7؋#F]1;Fmw5k/W=08evVB x΀޺:#աخcL 37߇B_ŚufiFF6SGd>bZ~A3DM\|9>cMQ8)R:&Z0H82NE";`gSV?w/a3;H@zmiSOFYHh;gyZ~]^!}(o;lM`)s&߆ 8ѿړ&+v7>Ą ﱧPb#2 dzrj5ly0,Ei+:X% ✨'DTvRi51/XIL< r q原F$"x^] ⤞ Eފ@`]PW!>@lqqZ1G FƼ?'|>FXCqo 2^SE Pxr$Q+%{hةAv\^ٕӅJ@˦UbƟDKqo&汦Yk=T1gXo1|"_Y`+g"].CdOپrt'A[F56ynE1f'{yDhH#"C6lw ia{Lzh7O7e.]it1落O(,MMHRAdIJ/&qQ;`w Υ"r@?U"RPPﹲObE pϊ+cZ`_/~_IxN`k6mj1_T}1.B7DX ]A`e){ |swl'c_I !ݕө(;pw`ˋL+(,n'{OZjsXŻEfSR``}RPU9G6MZZ%u L*z > Xh|YUk-izqg4@SMYY>p[H~TLk/o!wXi(ބ|A EԬ=riBFQKwsR:!5-/WY;yB0T) yy ƒ{-9;)*2go$/v^/KhcyVGS݊H7Ku">@|*2()a_s$™c3gը^.8s8P;?_Cu R,:$c.@# aL74 hge#$3mf*Ĝw-bxN ôΏ)5!`jvA*ڬ-@J謟PnĀHWC"S ,x#N6.^)Ee\sj$u³aNMMco:bنϚ7; PAS.D+sB37ı?b6uGQ͠$i7GGSD𨎙X0㌬5*"7=rdts"*  [9iJZB) h|ԱBlA2&9 zV̖xKT Ɔ>8EQHV l)†`UKYqqsu^Ҕ.p9p8v{qe(8 x{{Z/ws;n晩;W!N8AZ獶ƭd]zWhe%YR3 ȍka8qX1VE1Fd(@zF-_lV.z"|ōfq!_ǵ$Ȃi C Ck5i͵]uJ L>*UOKS1ϸWO6U}FJpX'5}rqLm >xo{E/ENl4rh$<%9H3AV rx,}X9]fzI/FTPNCd:W.#!,)s|e6 1*{fH0 sNF>/kW;gc_'ڰP~ Af )La˅> 6g*?fm3]}اw<sBret '`ƽT&bgPF^i.&}i1^&4B>ɗp1ֆ<η\4aڤ쮊oYb^o v,Ri'%mdCPPpuyx[!Dh-< _V| R-.[MTnQ$.2c؂zs~ZNA{CqWѸ(n% v+,!v,a 5Ģqʲ;Y !CN|ďj"EWyM/6xkby&;zU&8y{^5KHXI@%(bC3 -T7W5#tGQqpO?y1ym:A Ƨ9T/6s BU>nN^I|iՇ"w 1zgWUi"!A*: t8vᄏlأP'H'Kn"fXN0&K3](abSk'[S *1YD å'ߋ ] fw\{>閄LCSٗ&;^lozrH ^дx|(?wg8鄗,0C!S=mt4;*ړr>3CtxU_Κ!^W $bբ=-kN8Vǜ#>0b *vG9:{!4w?q(7de -*.cNVpԷg X<∗ހ6 bgS>/yo=/ ҄D Zyؤh[Lc߆v 'LNՍx_yC2m32DQу(`7~p?Ogj$V2ʤmՑm5(joTYV٤w.A[J)ΖL@>{?7ė IF8V{l j/QlW/\~!LAOpֿ&Y_DkzJpl׺Dl)X/5zxOpqf{.-3KGu;>9}u`FH`O *3#e3}8\%Q3=80yNÉ nIŷPc^`a/#OGe6Sg32TxES| n& j}3+4'ʛa7Oq ٢pi,xM-_@n_} <3P h ;WvTΏVuq5?&F7 h (6۠=&&ua0 WTn3fnaK7' [8_rH瘁EVN1#xr)ҧ.pCF7w(ơkyQ_Kb&)J4>upS,^]W3=8H<5Guj!9&+k?A?_Zc6BW=>8X unΛ$jAHsi`оyq U>E#1=jN6w5Ku]+^jPNΤ ;"L2 r ~")SިAP*=b0[oI>zΆq-qo&#I| w8@fĜeZUHXf&ryx1a!:z(0"\8kjk5R .#ԝ琢8o7ke;\Ҙa υL 3HR_;}A1MOg[)|Jz#"1RG#Yk\͹ouf(@ ض2?=skG;S{#*} o,$F_Iwd.%a[QG_!u)W!`Opu6~n{D+KᏞ̰$T(co~ ίb( PZWZxo`C1Q"?,AbSh4G?f|8T7먇WECJN~NrP/m;#_ E'L,gYl^+D g' r  i79pѱ~KTfqz+C:lY&[Vgj>FWlŁih0ƹ)`L ¨w .[+=ck5SLO+< P?p$NyP y 'WCGU[a_rAkY|(u6&\j,w,KΧYO(u!,+n(et2ߔ`H^!?@ L_wҧ{e =/Z:"Jw޵@d|d0&=ǽ| %JSE>ʫ>7R_N8$;&DL3ʼn!iȑq|}Ceh#Af-I='.--ecz<(#{&ړw/q*E`kX [wrεo49Y@g@&%.)j^9ʔz#O3&0WQSӭ #y7 +R2B}"'=d `Z( beT)VOh֣t~cp)W ן6Ev'I KX}[,YڒtRo=ƀʡ"Qmm|G=07i@ĄP|?bzLCLf}nlg1%ԔN=S3ht-ZC}r~g~LɢϾEK`Q_ȌHI0xx 6fϱ8EဃYk]S6%5_ݓDSQ JDo2%d@L=SJd93 it% ^![(LvG|.:,CY/&o X!mey|z(p7tv֯*s8?&,Sεq "lΠ„֮HԵD)xrk}Tl*Aj v?u8bvT'b b!2o3*x{ 4Uʅ.A>jÚH.gkyTqyZ+oS=T"8nu@T9|W+~H`L@'5Mv5zwcbdʝN%%T{<=|R;>fWvCQqCe!L~rZ.s(%:Q.BCVU*dk@U`:J?owK܍nsP%;{g׿ډ^UMQ9UP)5 "AEK~.Mc8tsz@b oMm1 O`}KTF%77H7vo9xKoT)ޥ42IP͕~Lĕse[8KgIy +q'6[!Ϲ]Cp3PPh ψĀ=]Ę`m_i>2!A^Z~XmMJb}BBO)ݪ9; kE>1&tKl6ˇc|n"]&O+wa\{9k&KV>%QsYJQ*78#Uâ|a2K^2cqc/#5^fYм? 6UCº˺k[x1IBcUf|+g1lvpҙU/|ѡ)4X@5א~kpQݫHitPg8U-\0pIȂ(1|8(jȤ]*;29#&_il_qX9>[BI 6#wRoE2g-$]pN7|# B'P i4qIzq07U*c)ɼDg6ne!St=U@UM~B`hܳrpݗ'p"08V߃Sl4CJhi4gsLrܺ$B׍nH2J`P8/e*ԍu03׍C̷hfl.޲m2}&`@?2 käѓ6Wʾ W aqӷfQK6=C{!)f7s % 5lVF4&,8O|avFha] ȳXߔߦ%"ɠxWh%N$3:;}zԎZޯbO2g]vК܊]?{Jn:OQt+))BЍAx0^^.^Y7o1{vEeZbR{oм`܀-4Fchy=[ gyv, &r]Yl-e1u} {`FP|佱xCDS?,wbM'ONTI oY< 1yVЭY' A/t헁$M ̑^AN"Ur= ?Cqg=^OFQ-F"Y<l @)McE~3j  + o5: ?;-P΃?u+9{SL_.Hܙ~ ͣ%g=tdH ;l=t}M$P {vnsި氄Xae,XPw_B.coBH4o~osx -C"MíҞ. M!ij-e>&/iJO4^^ê,Ы+0i4Ccw#Z Nd<8TPkL(F0 YUֳg*t0RhuKOnigJx6ZbxzI¢U>)czU;NnRN0W)"{'q;9IiI6UIJcsO(ԩ.1 N䐫2jOu9 Jy'KS?GLv3_ǒ;Uh=L1o%7~UlVEg jۊW0 |g9&Z;.''\gFWyȈ~u"F,"(.yn.ԯB_[O,%c)HmH|Za":lmJMjo(:yqD芟DxAg|O l_HJ+r/>3%ؚq}J,erI}1Ǐz\ťԝ,ֹ%;zWIU2"6]]^,tvLN2y#'mc$m@~. 6 VcZPMf]fj)71g;#&@dϟ̴09ZSڭC)*|/n(ns ڰPm{s} on*9 [*;{Gkm~t_)>r7D/pL|2H>p" P\gc^ .{WĊ4K,M*Hk7<m۱?G!?|GG>eFl3Шve$^/sgG*!Ȱir[t=<Kw Q0kXpÊb2ħ3@KrK Gz*Y^ !YRY4X%J$.E/ݪ>x=%-舅Y5 Bqm+k`wxdjSo奡P&|C V>UP%$諂+P~@Qq./ztm҂SR͉Hiu' DX𧋐]]?*S#w7ҧ4Rމm]1 ?c0//:df9[{tn] : ؆=,ufVH8(ٚQ#W?d>8$?G^'^DZHΉ_Pڧ Z3Au )Whcs\{A4޼'[6#;~Cozc[2gõ$5AZb5}@0ꥫ:u?N#%wW zChv(8>å=+8ibhB%NElVTn|8d6#90lQG4#1{^&%rq|^ݭwTɇ'(ڔYͽ`?h=SosYG>MŞ\{Hñ){GozՅ8Aw&ڝUx3 ְ(I8H#zk"kz)DJv d?  Ԛ)y3 97ni![-E]}R}ɍ[ԧv^YTafQO'&8V TTNe=\|ExXh)~p:\ǦS p;3G*Kŀ)RjZEkTdAAe*d3qX[4ї ;s 'O,mJ(XLM\eh3[6FpJgj_NIƵt|=#u:c{aO8N^fQv18*2Miyd%%v< } w:%n̏CrVe KSePhfkI Wf# Z[tZ?KڷnK0ۓGUˍ$QlHo^fIkr3Hr+c:U>y;b[5MO!M*sb@\ ?jAK-40'A5DDW܀OJzt[ [Wc}j}]>acG튜o&;ǟ0 9!xEPm L9|UuDIEiNFὉ4'(5xnkȯk(}0",ًwGoDD-C6ÅBEEXeܔ!/ K6$iO 8v!YGU6zV"sKAm0(@!nx4m=jn.3SUWEULKO+wMF{1~{9Ql2A] ʊu@[h[R ;:@&52Z.j%kStR6Þ,]!+)4Ské)wSm[M/gc<<"?h~Oj߯4+zH'>RTty2*ud$m;^&$ƻ_-pR s*b8gRy3 4|ĚC[ϥ%9 R̜\Xavyr_P̿ٻas1:hLɔl홾GM䬚yoaWCo,uj*j.I+׷<ܾ 6r)iҦ=$Y;Ően~hn+(pa~k W-7sT}r SxJW)^se]:p1% -;׻{uỴtye~|"\`PKRh9xr*F:cb} մՐd18u|zZ?ɝ<ʚHS';*l6 #|H5: [%Ê,@kVNKby9 [ԥO&lTJ>#e!u<"܆ hk zHߊ rV,1(Qq(|?zRCf3=gW"IQկ{2e5~LyQn5`~Aoc^ʻʧX)c %`\?Y'_6)G*e-r!PA6#yLD܀>jqFIW'IηρpXN3)2*qB;%O:7/eɴmQ=BT go+i ⇝>$hR>TKؒ(GuFw_kd g˷J02wUd;V_)lۦJJ no5^ño+/'7J/1b+ E͸/]}TRq$9P7-;uODq5g5Hc㑩,hg?g,_}u`d"?Mٛ|Hyއ AA@3TLrR 05 E8IZe|Asih!t%U@9sc w]e ǒjQBc#ZH [s(gyĹ]dݸwĞdf,*#x'\cD#W2J*O8߸NU;DY7qFgz?}(Z4ՒIC°_*EF՟& z_g `K:KH5Vu;/EQ>QţMmXogYú;^3=)-o0KlNK'Zk5yS9ZF>޵kG'Ecck'PY|kG}oQuh^{. F&M`3S ՚yj\'Ւ:wr$5!ݔBgoX_U _uAewf19Ne2\ F(b#YY4A>_9PfٛkIrO_X;0JA>rzh7 /qr^TP@PӦ0(A jAutg2pӱ\Ru -:~%`*/)q}0yёA(vGN&Jy 4c؈fGg.a*#B "F!O=@@t]Jʗ~ae )@$؞U'!0ZQ5wĬg(`|{"d3E$J*wvˎ%"lᑥ FTЋ#"=yNv U10[n, !A#6 {yqFGA._=Xp.s "la䂡;5w{g k3 uABtRem!ues|# rRL̷[KRrT#tgx?>}s{zfzmV4^~$ ,t~WE0j'С@Fv[C+.l& 8!uhf]EmoL.[EW O(Z-Uї[$K^AY"ÁO)MCKї&,|GV`IHS\ T{+{ZW7k؉b]*FRicOkhLe8!sn!v[Wu՘n"'w&-2XU$OԊۤ^O@4ho=E(Q|q/-߮RD1d5 P. ˄™@'5EIdӤ6aY@/ ޜ!dg͝Ԛ]} pygAͨVXxVm3x'{.|Θ ϒthҨF@?kqK(B bqx%Ņ3nua+Bc\.ұb!4&@4D0F-KAmb@14he6d}A8IPHu-?!YFoҠ/q 3cމ 7]4*5U^_:1j1XDK3]ig@V/GgJ]L"`3BIޓAiDO`웫`=s`_ (O(JhCEJƤj,} tyGT6zgU0Ahڧ^֔We š}قv}D)cFny 5’v;.8hRԔѰCu&gsl,qz%Ԃ&r۞ ] Du_xXSVfX #^ӌٶ>NNM{zS*M?*vDGY7@E@&|]+m_LcQk9g< WB©D?K3AΌ J! hrZϱA%@nm> L "j.NuY),+y{7b֫}J0Us#9c|yk{E4q$G0]kjɑЈUa7K9NvԦfôWWEp{xݱ-`: 1=Dvὐ=?HH\ +fdc^B@apm2ټ9iТCE AՎl&RڭTgOu t2;680 ˒?7 EjvRoq ;`*OTh:CSQaڻmY4*܂q?++*Gh0qeZ[zzp9_oʊkNU:Y`QH!0Y‰nlR?xT ]u0 Z8S!~]ˉm V޹48GB'fYֆ~~?Өqxc[pQX7#ns2!͂7ZX(ⳅ\Sep1?Y0(GCv`",X À2y&v QH91l/2]>Of$B9aqqc2C֎*L#\37KF:·X6'p,ÎR!bO`*T` WMʷ<6 >V `=%Z xXf.O3K6 %T`_o #iNzC.6<%tUQgBV%Aݎ4 1UwWYli/y -VX ko`3}KDdLuau^>D'#PA^E \L%ӵ?m'M3s I2T:SkɱDClY7ha|Dp؉i F@:"FLi4u F19Nz.fKO= E=4 US@~)Gt=uq=C\tAuoxca_d'Aq9@Q\*Ӵ0k VW2يv( 9kc&2lԥ;ܧyM(&%ܕs|ۖLVQIÓoI3u:p0⢭8t2>8 n"뇕]eswp>`W&+1Q(& /DHuAU˕w!*aM7Xh HY^w[gs _*-6KX/~KhHE0LOƟDzp9O̴FvexdXOvtismBE J,5͚3e!8m\I.sU5*n݁YWE]Hg}Yb78aYyGJ~ߚ܍'_귲 #ꏍ\X@턭ZOnނ"ז̴ ӑKLn 4" C(FR胒 A5꠶H~WZ330pi*(vvpZMb.jFhNhՖjv8R7ss\ '8Hw|ϰMD98M@0Ů',j#{7 QZDky@׺aZ9UvM=K/1AS5 *p {{z|Tl(.`4.x[HlZվ(/tvrNa s/c:t=wMnn}? LiOGh lڿ'Yw]b|1:8#t"[DdO{7D4=>lhH%5 Gru@`C鉕ꑨBA@&U~ZTO|nn'/"L>UjPkJcKnUȇC&S| F&Fͥh87_NmWU/Ţ^tT_[r L$h/h-`m;Oudٕ|xVWhCp q頠UƣJZnCw5C7l#cOxf}E߼ ڶyYezH ljYD!We2ѨNjCA u1ֱX `nsҨHW]x Y|BF,mgSmΈ4\KM|;S) 6eZ &Du)Bc0tϸxah43,7 .8 *SE\W+R[$w$&}@pZ()yK+*R:p_p!KMQ63xL=`oeƭR"8[Yf E\KX =~  A 9I0Nns!鮪wȬbQ0KA`y.`i׭saUƆt7nVNhO&[ 'zB75p4HbP!3F-B4.l&'ֱE bdqp9^].iМ4uEL/<jeHaˉV}m5Mͣ"BT̻F,p +F XȦh^f ^'h^¿Rx?FwAˮ POx0_1m!*'N =;@1\)32FOֶ,F| X^Oa;Xt^{>9ERms>twdc{Wg}3o[df FRDÒbnX#ܰKn/1Z%Lއ-ۙ+rlvO4 ؐF}?5Zۄ tK =i+{p9|O'ﶉb>(}zCuN: |IlљY1 wS9GzvPCK(mQ*"8q-pxX$$o5@"ONuDaKz ]Kmj.z}] Q }M Gɔr̲.Գ*R@*3X8#e9kU @b9CЎr,Bt찟,n@Jb6/! ݛtTcѐݞIkC_պ\=™<Yw{| ^_$j/ BJV(,(߃mpOߨ< e6<'6s}#༞n$ _)#☇zSFAu'*ZCv]/ .!\}G, C8V6vL wYu:o@띋1=Ϝ0W,t5o?St+k,X'KgVt{yƵ) -pL)L籓Lv 7 E jXl--ywfX&'dr8%|ӧ\Awu:)|ֻGngt tC˄) Զo-E~q0 sZΘT\PObcS\ [#2H"6IO)ő*<⬦0D+}3rq_< fWhlwгH`zP}ְ@q <3 $^)iX?S&pM<i^OdcA8q?CdB:%L ]ZOPvɞ|qאE皬IgEHs-;.KǹWbV{)QrzOYE!Y2nx~_͕r=b7Oƴ2#0'>*o',]2ǡ"܈?b6HUݏELCj~XtfS9[3*`&߳}RHhMyKF4i p^Q+ޔc"&;juyʥ\>D/q(Y% Q^3@ y Me@=be2PqF_ j7lV'Y{q.+ 3HgsXΠd`o157j][/ɇU' 3ƚTl-sMAŏC' Ihka>W{(\Yoż^?'6WnI`ct;/_'Ì_K^~ZƬQkeoգ$=hB?ul7p`%c:hJQCYpr@ʲ&SXxyr6gJK3\Me9~xRR&laP|ajsD1˴s~{:7#;Mm,<Ѭ њEΡ{*(j>ɪ%k?W#qxMοhJ,$S=[.<x -ρr@VqYTG;+D&mFL> '*]flϘ0搎&XW&i .RG_~;PQ9Mlۚ\ֈ~ґ8p.ht*ыG ەI0*(Gl=VT0fnt~bKO-wQJG+P,gč'{k~y'_' }] yM:^RA}aST=]3} b>#p?|DYʄ3tfY_ q@00 'DPe܎<6M]- t( ^/`\6SRrW[ЗLKmן X5r[P4*'2󘱨~ zgPy/PwټOd-mGC*ArZ*rt`SCۑ-/T6nDF#wy&ȸ*P L9EgpcXl"ׄ^d8? Gƴ1ŬFqE`N?s`{Q|S+IR~~[ucю(HC.inmpv#!f*oM>uQK 7RCT$Q"փxx6Nl!/J"zjbk,3D9sŠ)'FJSHt[(us$0əcD LweRŸ ITF:'ᤉlvyz*8L~l;!4VoJnpN KWQe 6JL:(Z#Ԡ2?bc.ߕ #6xpv YyZ>-=&gF$Og{)No{ h41Bk%W88|'l|!@p.ˉMIJ)|7 iE]R܇֡aU^욘M<!ww!M๡qek eUJ;{nQc- M54äCPiXjg3'0{+@7w u'NJUըCS/#35d Ow:3'5B 6wPž3~C-j(nRc/(yǴ;}$NB\qHAtX- [هeȵmpLL YC02/ نEN}nˏrVgߢH%dzj`-`Kr8լM~ /Oj%R^B "PQTm΢aN;vK0l(29MxZLmգs3"}?Szj>ԯ̏}#8iWfV"~?t0>~$)IBQ!i@ηg)s%qc^S}'/\rN;:E 8q x>"6S!0#;7*%*|*g̕Bq)\ 94߰sD+'3N0ٽnǕ$*2׬itB]O:<>YМF sגъW|x" A;ʖiV9mvBwHۆ^]Mry@F>ZVQPIZ]vY4W.5VH[W5ÉHT\Lp\7RCU&[ fA$x}m3+pGl:_,3_1(T4fyũQq2FA.TqKck zuIp;p+7|KmA#5geXjGӆКX)X@qoJ (L>X鉲Dd&, ͓ ]ȝAVҊp(̆1>z.Gq&/*A˳CB[-J՜tEIAb\,E%n*eġ ygkN9af~n/EB hlfGC7ۓ"!5 a . !=D֔ "BπЩ"{}և@"W3֨>8x!uo*r'zpdv|3@PuK̊ApF%F2BߕjǯyP1lFtmc @PG&5X[`^XpIٚti8#bffigܥ/Ė ť"[=_Y 1xێqs4'Q034]-hؒsCz=@|v/3bU̻TB*v2*D˒p{*6ѼIo pwp~ZXn|o Wr|^qwꗇ s,QmZ?ג}:ja$+e}"ZW1heHX܊Y8{*"|%33C+Z WE^hj/iVJ)lB:Y8QcZj֭Zv o=g`TazW'F7Xv*Bx|a7zM|߀Y_.}wO,_*:<[RUiAIqD-/L+!s/ϊ. 2 p[k|P{}5XuFVnW̖Ԕt/ hP .ӗ3ύP ]ͼ<ry'ejvzx=YtUc!2%$xmz#HSjk*(ܓpԮėf-I&8NxƣQD#b:X %ΚU:kl6vDr`v\y(6sjp #qT3+#(E=f š}Y`l >4څr. Y衭9lۓcc筿)o8moi%N| #CyY!Ԝm [ֲ-b%iElQ4:yߩ%kߑNsR6d iR^RTG)Ys#sꡏLgZ =t` օ i(e@ޞ7}]KuvFqi7|-X)0S ^yoJUڏ.S]mvXuǟ"IY`M1;Y^~^ Q|F.3 U(Ub>~`u1!\?BL q7ZJh#ىS[@׭w%m)K}7hըI̅:>c>ZCz?Ԏ1Vj5ߏ(|Urf%ǫZ*&C2})(i G@o 4ȜD$Ftdm'Nfv3Uҫ*@5jXBv?m /ڊ鿡؅.l%4գKG8wNƪy8;wryK?QL p_') {Ҫeg+'l1SLpеdõGzLn*ʚffK23x*E/At6Nk|!2ؠ Om S>20@s-5l7*24n3MUS=CqE~Vfʨ Rz`BX4aI|ȣ^GbǠ0}.IAV"H9붜?ao- 71ΥJD'Ci3w6E;jZe[pVXWq6&+3i&٦jjIpEAͷujw Oj4_FDVI%EZpܣV$4g(a78jG Rj1dƅxf]j4LѢa^d Yɘi4R XaЍI59^ZWP6qQM5%4ݓj'atbuVuuO.gK wޟnBͫчyX(:bZuUP"v.ulʛ}}۸Z4a_((I!Q&҉Fxъ / C҈L#xXŢe*Er`LRA.Ҝj)g_YI^r mW0YQI|!H(PK@뜹,rXhHB.\jvC<#M=I|цPN2V;P}6#=꼄(-&Iw1BGf db1hR\j,WMǓι8wIq B}vUer-3?kkac'淤Ν%ڻ)1wpL>YqVtD[ _W"%ɅB \O۝  b.؁ wuMFxvWtT4?Y1.*5 0* JI+ܚ8ytT.=Ҙ|wbNʰ]u^uAR=m^_!,nb)5 ZJ 2WWAq9s$ku=QRqzmg8贉2; tV$51cc}ljWS Gh1C;_ATH݉m ~bK-lKp4+1>F(=Q4 wPmnְL:t[drbNA)S:,B@%cFN6JP/~iHZR1lG+”2񾽹/ lʋtzZ\1҈"¡UMu1jO4Ҿ+AIk~<T=ƨqӺ)Awh^@si } Icڛ:i/WA .:)WrC7Pe% y.r4ǡCs<.WsfEx: l\FYY-{H H2+'iRuVAPږf"M[θs<)g{cSs$WU~hhf t£HNzLTA~~ҝ gsA7ή)&~zoaX/iE L|wcw^(: Zs!bdèY$0LP\/閽 rDW4>270~nG~T.Va$"⟀`_.:C#~VUu )~CCaѫm]A"9 `BA/XGx3a!ZK|y`Z @"/q/Vśdc$?Tt-tFY;^5D>Hm7>8wRЄZ>3 `=4SF< +ZV]JŮqQz\ߩJ|ع^LFPq3/gFQCn=z7 >^h<\I$(r?sWr3c;6LvWUDO22 iPӤl/ĭ *ƸjV"`6kVVOdV/̔6w)x"*/!c<&- QoV|_Az_My,.3:Uf݅[osGM?M!ЮeH +79@i uughqEV/0 ١fnyF5bu*SϹ]fR =ce 4q:zx69[a->Ut/J*/$䩦yJz>aa{j^|RcF+uB`ֱIPK?LDVC7U]}LBJIa-lxг@AҊ_#0vG8j"fRp3%oWiQ^J3]ҷ dӜx`6T[b5E>ei@L< n57t[GU؉Svɍt^Dr]k\#"Wm>IS19kb\wP"VnH0[}#":_x20# e<G2 `z笯!1?! ;A@9qF'?}eU2``;;zLv12cٸͅ{"E'a*CkazŬKeJw8n%ӗ::'1dֲ@*H6Slm!e`RԄdJ5 < n%YZ[Ƀ{< <"s&m!Х50Mpl z n?"sas,ϦA$^T4t%g`cV'^iU{boMIBd|_"GDи#rR|㷵"sp<# {|<_}kl_}$G!Q}mF]:'uq:倣hCq"Ǥ:j^G"D0)76 +'!9A/\]3E< M2N| 7x'X{kb#퇭;ہm M@ JvVHI#nFU #ص:Q;zMBgFP !/(D;LjZ ȟ t'N.jK*T`V$xu@$'܆"%J"`IZi9&;s4yWK -qJr1q8yur{XȃѣzOJr}}4@Qg}>ڹ]f /r-<ςO0ƛ R !,;Ś`aʩicøyۼk:-D̰k3˱%[BGl2;h) o|&kwɆ^F>y;R+6Z n>f6K 9}mDK\J6sJTS"zQT3_rœ@ ɋ tYqfn24?57I9dad l.1SC-r}4m̑&,ko`Jğ;*>ےQty.c(pYdufL^m5bϧn4#'m_|:=wѻ@eJۄ"gczʱ8z}e9\1|w\ ՛Π4bץY7AI I=k}D%lAƋ!U07b3e0*4d ~zz *C;RSAӅ"nB EDÛN p-ZȦ]uGzeKBsH"_VKw҆{'@dj:UdZ|l T >yޜQRӈz[C}Uյ)߼NAd,-a#j7jpH͉` RQe즲H(QѶ3֪ = qֹ4˜xpf;!BB6ڣa`l3}Zi6,rҿ[ۇYZHKwW+\R݀8VHAZh^K{XA%ݲ&i1䰽Fp]4qMH):כJ-7PT/Y9WݚQ} ~f/QC6lCđlKsM{2o_,U(h2pAdg nV1BЇoъx`,(u$]9!FgL|3pk6Ea#C%4#i|[2($֙uK2Xαj_t-Hw_vP_Rn YǬhmiH4 @j%ut >?=8/ bcHujqBUO}kqN=Y|ȤrsIa"t*ORzk4 qP%|P(RYAA˓ggݨ{<3RG?>=ו)&* I*+xBEt3|F(S1~RщA|'Q/o[d37VyuEA5/qH ,$jt߱r[j&M(64-JMzBkmԝrjY&͂ [ ^~nwA*![:`_{J&ߗy:m^E3_Lswϟ7#37ћSi;f/4 ðB Ȭ6 6uX(t~2Ő|@([iaPϧô;pUaǢ[YwnE?@y4JL :n8Hw:_\*vtM`ƚc-fFd!F>t($a 7=# ({O47!y]pç3Q? n(EVaBSK_UW!ZQa y nD;vN ;wT`ȵlB˥U 5e Dŏd%0) NI"!` |;IOZ ]1sȸVqsC%ض`ʛ+S07!DjNc>yH2@MgYNFC*LЖ8Y 0 5NV*)߇Xjz}xl?9+ m~>w6 6 $<\ޏA٠dW" (pS/|z&e]ΨEk>,xeAnHB9qnh|'dOgu`:iI"81,ZɭGm?pݻwE<Oط^ی=jgQ㎎0G -gw44=u#chRX0{35Vx\7O9kVwi\&ڍ-(œv ~cdG9 ϮY:U8 vst<ݸ! 'G] ?5Q>.oo/"Қg;Or2D@Ԏ1f.ޗWc]M{fE 5tc҆:HZ k'-͚B((D.2%U/4`߷mAdv8p& 6,/ݍZ88".)+?oSxd8Ix;()GʳoG 5#?H˰Jo5"Jڟb+iZX:~\e"!'du$,q2t01w|fB9$)L+zAS[GAp&}3fT(}WX+{4'!KEa<ᢍv/VB׈-,]q8t\ELaP~<HsZ,=TOoA/t |i)jIeS{zب-! 8rC,8:P 7Ow(nh%yQ&>hTjӬ gzslţ;N%RFP^.h]Z]ћB--8Pƾj e>)JYլFyc-83t,݇:))T#|NJG 5\}HzWV~%ф%nb4ɨ,2VsQ,VmbO^2yFT:*5^ѯzQF0Hk6#KbחD5Iq"0_k\ҍ>*%́ŃRh.z݊MI^e.?l8PFYhfs̊a$'J$K_]t#! ՞^yPz&Zn_gæmOae93ƅ45.YφyisP7 E8ݟGXֵ+Zk$iWOg8-DxVS}LJTϕ&fuQd Y&Tp_߰XM!x$e`7)nU0 }NF'r&٦1}WQm0飲B5˪MT9]a|A~%5s)$C?Bw&i-K7]I;ω$ijEUG@jϐ.i`]㜈 6Vnd"ҿ KhVhF{).!vʸyZU9ٻXZT@a}` 見ڧ-=(eq qH f,N!狔^[|e7h^D8/3`I"r9O13*iBߍi[iJwl̰ٟ#uX5Tl@喰A#tBږ\MIX ,C*߬ԇhPWϫKx¥RbcҾo!ߺ$4akVqЯrV sNhiA\u)~24 pS%둡 R8y-`P2H`!PED NMRbwUnX9 '&ܜ/ \ݑ)yJo&-LzO0MRl.p_ʮ/{'"[wWK!ҁ|YB6H{$ (߾ᩐJ ;&ԍnfُ5v?7h + K<ʏ\ z_JP[mz>_Sd Ф45&#X؛3]Md9b!Ȩ(wר %qoGF+mʈ8 *bXgA%@yA;He )H?A)aj;]N"bmk;d&qF?'N†neE8P+h:EwuƳ4l Nrs|,BFA\Vdp{ f)Qi͏J ;y6a \,F8qc|tVvYbvxh x2Y;"t㰃N c۸dkMx sXlYHg 1[!8?GC?߲j5XNzbK$vt2F3>~XPcB%Q>Q*?E$_؄CNCκ^Ҁߘ^ $٧DLs ƮU)m9e֎ge[nd[ _kVN:9&+&@1RHTsϨ gu^Ӕ9I2YH!ퟭEre^~FIJb sJ|a:,(Dԗ:O~D'@/)!nbWN3?(\iױ6)qqsR3<-Կ{i9?@ARpv|TQi$xROw#'J/ ._,,޵ߟ|k@U#-JWQq]X`֥&8DZ61[HsͳS`׈D+`e3$lJ6GFB8Z@#x5k 2.0c >AyrCGtq r᪈2T'}3(lshxԣqLD|ڹ$_dsL1IԄFjyX⟓J liCl>I 2FQ<_lg5p@ s5acPZ|-İ]ա1"j&GndE:=uLk6<̅w#I7;OtP0 ,w%?Rʌz !)>4jLaA 'a5G؀$꾀ȬİM>,MKM9FG!|nɍ"t?5J_ )E~,Qs8T#pϙ |)ZYz/|RAN%+K#`̾.s$~yZJT@2anb"{)}[&X^kiC?#_zCb rwoYy}Cy1dAA>9}!E)<\&6^9(h3rZUod1FqlXN܅ $/M?mh$q>-o}M5n1Eb$7DpqQdL,זLY!?srZ, r}R1sBa̗^j@l6o4@[` +ʉʧqppK]E|+m5-2h٤l!.>ή[h5$4o @YK&s7%jN2{8!KEӰ|iZtҝR_nOؠxwA D?VCC.rq,VS-a<\o#ߧEEdz[e B‚H)u0.$z&[&l.=]kxY+\-JE4oƙUZА< 4cLh߅m#p*p6 OJzJ4Lh)vQVJ/}v{n~IQ}B 4K+j(k;('{Wczw'#twsMVv}tˊtvPHV0d4kJdATӂŇ]e/y@ސv 3aĊ;=.u2k#(N`f9ef:LnKÝfuf3 Q0 g6*mMl3w59? P U5pKR4z)eX֐li57s 3VĞ<%]$bZO7`zfHΉSg&m, '-5SHdkQ` Eh>pp`wb{~GI]uYۂ'5 46 %xwMϜ)07^ui1*aT@%lm NK ` 䛙=v sH4)Q\X%MUʧ-@2tDra*.QPA'zv t'RX0dra5|dD?JçN0`;WKAoMTO{ Q8L?i!^:qjhVh1Q>v0q?:Ջ>0,\l_ O zsH{T4J1ٱj\ثt+m~4`k>xJaO^?$_ BB~h?[*pw3ʈ{험}WÅA|(S?kW1) OڏQL =gl϶^Ĕ\n2VZcTrMs[>R <}r+n7fW(@\btчK@q$64m\S:m];!ٽe;_$4 hdZBaRLu97٬ 0,68U[FN>'t'˴"a&PD$X/(v}9q4~1g.cHޜY-ފ6rk}zI v)Ma2w3c C^Jſvg=qHCWOxmW V |"L'8 OWμ>Bw@{h ϴ/Z XkCg\ݴU2 *$w2Q%AomE7ߡ! 5¿"9ީZJp_C3W1:я)ꏰx/p])l5_QGA;ߘxIxt=I|g5x!;òqN(7?zc]c Fzt H*zMIy%:{=q#^DǣN[ԿAV@^㗈E]BcBJсLG"Ap ?J^CrWԴKn<:h3V_Om J DЭ_dL$vmZ;6SpnjM;kx:R@cYY&|}at?eN tl]B/#^M^b]#{KǍo[@{Oi}8RD2Q@S9>Q@NVau徴gj?jJbVDMYu{~w+hu4m3(Awя)UiX. ՙ6ۺXa'%">E5t~gRf[%;?F$<~SdLh- RPwD24Oz!\%yz)T$OCti]@oIK-c7Ko.$E*V DS>Dk~'_Ǟ/NF/A 3Vrj^QIXZ6G:SCm볯%Nmk/0GY1h-8_?\j7=_44X[rǑwgal E|h~5S5ƩW+8Z)4JoA~}p6/Qnn tCvsDB/|u e>2Jd;<(;MՄ /ƈRB~i&m+]7 S 5VtKvPQhKC&h<k e[97%` mر(?ܾIbj0t{듐gWei |(V.fUOeakILd\iZmf= A, DL`S"aD]oy!'0pٺ8(/B4%f$o EhRayӘS ..S)3Yo{mqOp{KO #٢;w1 42fEH GIhA&#qe␱4V?6{ћr2+eEБ 0F.7'1D_)8ngWqϓgRkntp+*S 8lg!g=_L(HSr_s<;(b|,0o,zTir$qXuWzBtn>a:\[~RlMqkt(68nd^:>P給ba_$*<Mtݭ-LB3]Ul~,ۼƇis:"F0ʨ69GɨKӳ-V)zخ2aۥpz竒xT%fxh 6ih FgYVu2a ߙ>؝'`@KQ={78:q5Tgy*8 +Z֡P!&E *(j==Rt<pȅtk2T `T֠ZQ_z!^8u I:^ƴZzBÖohމGg$s066',нx9*Ͱǿ:\K9g"X2OAQ}@D0eR_ȲWT^x^hR@6|h */ikݸż.NqȓF1K"*$Sy,!6 O"waBam"}΅3̃)=d>&5} r4/BU@.;V?c}B~a͛m[r7p/sl .NdPt.4rZαH5X]ߜ:ʴtR!wGwrnɂ76Z|z ,/AAd9CU:?S"=rXWL3♁@*>)S1%O/9@<$]ϘP/ ~a$?^ ]$KsŻ_]팈RY^ Ǽ;SŽͣ /Amy?Ebʭ q2|0:>GA CY/ǯlZ`ma2DU> rArgu};o}>AVU"fǔVFٚ|=>m;˄Z HmZX# |0jԽs!5))m5d높.ZT!}^ 8vՅ5Jk e {Lr_a91s"yOjXzsQ+OMt.&q⽽V3H5  ʼn&Um㍎Jϔ`%&5jBۈg"4D/ӉA.͇ظaq.TѾ:RXZT熮:PnXl_rO[=u=A294gJ $N1X:#4yZsv`V-}{ O$$-;wvM>_Z^W]df¼$]g{hn]bUZ:E' - wN1އ/kn(l\Rځ'19C<+=7Rx^DRva݈.Y[a[iR*ߵW߲d| Mds,!OԠ.X Aр6ǑX% 7W.&A as:f;Vg#,7! \U2^i|j׮krmVG_`״D-!Gv WzC,_ ,4IeJ:GƐb@kBui~{<Ң ڽu9y`3cnvkT53R:AJe[yO^Hbh_qgH'88۳&G.I&O@F7$q[V8)Džt'ONN[~ᗣAFYVlLWߜ#a04jQE@uZ%1 ^n?vW'TҎ#la區ٌ8KgA?o M؂[?!ϣ3!x]U\qXnf/\yMd+!{ׯLɓ`*r اJ}\!Ah.!(KP7M S[6ZʖNTv#(kʝK 0z;缽7`$jV\JpXPgvT` k>남)9^UÝ}=-5vud콁5,~7JnjLX%p;ŗ8tVqz' JxOnBS14 6z)v]Pxsvu{toO'q/ P6%߰K weEPOfv PA|^Dv[~#6 Ř2/ RO~(93 _ wZ4'ELS?߷4 lk!$,$8xz- =9j1"ZtcHN*^f[99%MO;XqPkT& }vnwM))m/rj֋ ex!@iL',+ ;.G}`(6h(>Ro#$Tv7s/CUXtTp~\?HpEeN0?0]1mEW;ЖO˜(K`B'=/WBk%] Lp`iWfEb3t^%_, i`Aҽ-m#ns4"<'z;}=fs]o"2n0‘(^/GiHq!^ziUY,1գ ?G GIh*{d0 ԉ"%X@R M `8PDK{^bd*|F loLS'*@43]LyST^RuS 3ݮ9%CpOۊê: iTrMƮ ,ᙸ J`h=iM085+>mN"`Rs(:\Lj=8hob$_xJDm/*\"8v,m'}O+hP0h= sτқ'>dlo:ődBop(хaGGc4~")Q#pܺnIC-P"D% U]UلH[2f>"UfU#QV}H(7粰AMW'Iv?AJpUGb\pHʝwx ^1jv ]1ه^ܐJܗCq~mBXDT{GRsg1HʃnOj cJ@i2f19D=hVG<ě}Ͻ;DIgZ3Kb619CŅy*'D볍_A9"::nV3JPٌC½Fh#":mxV ^:Xr#V Ig)٪p6 GZ7m;󦝑J" :j|"z<5u D( Ͱ2Wҗ0u]c`&fУHs˽ N* '9'/ZGmN⭓4Es[A'hۀ?H>LK[ 14;kgi'g% 7@ٓd#eamZjzMǏHsyzS7ZY~#gA* .uH72䠮Gj|[Gm=:32+T)3A<QkդJ&y Ke*V:t|Dn f21rZ{r^{B/ Pq`k-Z8z1='hę ywu>!Wteΰ8U+n$wf?u(xPd?{t/'\;QR]`mwI(_%!]^eAlʠgd1%Ør00Fu4ƺ WwND..H7l QeXɣt˥z;sҋG^ݍ;pV,Ɗ2aSVT%A2vh{m_۟)NN/{#n.zO{i\؂9{_v2 r{t³ˆ[h]*%J~ZSY*8M->sup͟FLرʼ#ۏٹ:HʗYk OT&s)j$ߛEhh?&ǩ'zK}zJ+GψB&ξ "ٛ ]vJ }FQ$7.pE͎5]sÕS>5)5Sڝ՛V= ٠5~s*c#똢 Q$|B]TE}҄~0]T}j_?f,T(A+bVv:bo#sHMԾwƪuMus<;HOKN-;_y-5[* ^NCTGKBVm*B/'>@mVM^JYaP3^$ IT}C :9]no&j3q=L\1LZ= L(Qoit-Lg)US-(Ljd=]C[о JDDz,1lWi.Fѽ(?}m*>"WU1f5BpcXx/šgǪJhp c[ngJ;zېpׄM 3 ^X-= x=g A*UQqlq9Ћq#2#fu[9*җ&CUUJH88!-NH$AMAO?95]7`8MĺfnjrPv92RGHy:Z,f{3 } i!0Y2OX!)J^t %`pK⚛GR.?+$LyZ]/y5<$tۇiّtC Lq&LGk{'.}T/y-Ǿge-qh>MO \I2V9)p54 Z}$ jJLcO>o .Gxlf\{5] Gk3ךC3~DW?JF?}_#ir IDhMT-Y/YǦ2,UyvT/@Ey6 S&E`BE N]XB>/m&m?dbhmT,M늦Z.uFr}M o}Er8%-?k%aCS pa3F} "JǢa3nsV{H`.㽍y`| őe9**p jX2OD(w4f]^G?3ޅm Q(Rᷛ-Le^M:4Ԫ@{8$*&248 O L.w|FBG8Z=&xV#@KV7}IIL^^"vMn?A:Ap@`IǰьI14M} we9>]}a1,4+X49 [%(ň+=#;M ls%pIHrE P_quӖ.G%;b bVڍ9,9C'>%q8AƙV;C`>ê#9زeA:[z`!t mJ#_Z*cqS }ufhAفD֗d9؟,||&MojUusg6RF#s>GgUT87ɪGl^-k:`X$*̝CmӠKl}eD/euHO7,~+f)J%g|JB9q^6xnYs (Š7##U+ٱv[D.ic|lha%.<)<1~w=Jaz:{mP6oso |t !YSޮ䗧{}"Y.,0Wx!t>*t~X\l/V\CIȈKDXKq82ZÙYU#3N[mwğ;@V<ڊ!C:LwhYZE}xP]5<$PrE c$qPkt-i!L, Rbn =K]50X8Nd3V׫\YfzQ uSׂD>zͯlfe~Rn5rYOUK@@녞,R+y曏E L{H%zv2ۏ\D9^qsyg^*JA7V\^-:rJAsЊDBҊDO{\VD~I♴hÐN)L<A\La^MJC&^зޘ[pj)2ksꩡsΖ$8" )m_p =rn.]a?dҲCft9$&y.7lc^c?GTU)V>c83k-nYެ\707% ga!=jEُ@&0VVv,?7:T7oH]>?.-Wlڡ8fDrHPAJqqsS`5X˕%Z>EG1Je҄:e<3?;Q|:3~v^n :ZWVxwUpۀvm\t >Cm~9-Bޯ"'+Aq>q Kj|ZKtmMGo$R#)J~;S3;qTrAcɜz[-:ax=bIPx!UTbeߴ^$R體>}m4fI,?1&;&6.o?^.)\vi@4>$@ׯxlMUQrxA2Tв!>RyGNɫgxi>S k :1$$$Uscy)Pm޹!W9ŮTB5 Rh#6Z &Or_ qLN׬iYS[(B.OAxo.w~!eDbGu7 #II1l~s tq6ӥ"#̯57Jx0 ߵ3iXg,R¯#; l`,cu)5Ek I-aJi!A更\y '9[ mC;Ԕm#50a1Ch m^P,;-n0xŨg#&U.<*,P9i ք clK>#]smj(>w`c%S?$1ބo19b F[dlɊn͌U Y9yy*2*>.N, Ho>wfSjD+1I0R%yyAd2tGRT+:RpH^AqKS_pE3 r(r3yU\{{2IWnZEiwqZCV!ĺoY2L<}:26;+N\rZzFg~I|"` ,Lwώ(gBU(O'"vS4!v6z/UX3n+EC: -\iM,ۘh14Z W')aWzto^>ꩲ0?.W?p=7.1}YM\qz.]U9Z$W[I16;*ȷnYD8mp?͌?'hOJ|9Нfn8",dz^ v*Rȟܒ1<vLb/<Kr_Woh8Ij TUR1vhR۔ ݸ]SMO ff,";sX(l!tn))G 2X+U )Le9ȋ Ơa$ZdUt Ό.xȭ1Ru.mto57R1dSRXwl[;Z۵noQ~+ UQ"n}f6=ReG hS `.1(QKLF6k綿3J#ހ˱fMQi*ͣ3h7nF~l[@ +TJ'{u/N xbeӐ+t4ՠpؼJʱwM+Ԃ',!.7ʟ%ޫԫV !xNzƵ_{0Gcҕ>rŘPWӱy17"NJ- fZt\ibv?x4Ve%gl>檜t~6E*"0Cg"G 5;xtNi.MCA^gm$@k1F8?3BVg+4Uu6{zF.~-(3tr t7KhMoe9)G2MQ+F\G!cZ I֞# iΥ VS2B~u(f] C0]q@$o{oA`tN? ?R4%RB?ET@4H2" R3DK;՞~ݝ" C%}F,0.íXCV<rZItP[≀34]A"rho|*mj Jidk{ s=/sk1x;Su&Hb "ffrپɣn(AFSN~6MjP6\/ aibOB&u{~ "c˛8E\ZV. $ZIo9Z:(Mπg i.'P9c_vEn,ƐZuXXc[Bŝ6㝇Y%|i F85CZDS fU)MH54׬Mli=\ٲro-0 Nesp ASⳈH;h -]̒yvHJ u 3;NdlL{@xj퍄9ak>_Uu5G^:i TMĩˋ?繍4r0 iUq5՘t:ݏ%s*=-+nI(9Sexiy+F}\PNcL\RǜN11GvG*X?>VQ0h+L0d蓙ojbNJ9]U${gԿuh4NC'āэ C'Q{Q^ZY]1}E ۀh'_In((,LoS 瞤׷]cVJ ;)ZP(LXZ.W_|I=oX(WĩU羡yjʮ5܉G^5q/ZOC пdf-7WHHz:6~?|b[C97\DwՇعsg[\x-s{s,덾bwIB24>)2M+?L?z+۩gA"dPK4ny#@,XpP6E<Ȣ@ TW+Xw$e?;i}MINjNMUN5Rn_R64)G_@liԋⲖC[4Tr;Jգ1WT{Ȅ ViX<:|?b,4~K,KoDI9 ulV.:v&e]}pk5!:#̃2l-=Kфh\vSuQެd4\Q>|XWݸ"O=Nu &_WA6uB2JaϘ=E<O>7Z 8E,WL^NrhI  7}SwU.ƍCUɨ߃>q1' Pu&Gup1#%t6"NfDTEq"_50#uӒVz+ Jju`^7]#Qփ.eO'$z]}aʞdʓ#DԲ5zW~Leb3 45[ͺ.%8  } oiMf1AmN)$0-09e5S(3QJP5PVע }MKaSC]) 4uʚ?tZE'ШuzIL;YʺɆ#7IsbՔbxd[|?Q\W %g7A\| יA@! f ɠժE 3<ɫg`r)fy>'7S}G!MijMjD ESn%4sbZOm%S,m٧l1୯CofQYkW#rU+;Vjrw%C!\.pޠM* ӀM)ғ=鐘&%*/3cpZ!*- _1(]^[^ ]/q6{xWFNBgi7i%wz]׌.zB+:YGtlwJQ8cwbZw~d>~5cR|s Ú̫fpl NfMzZ==sCzb#J)%6-br E2,.q\K /Tw$TK*Z]nx+h1dχw|Sw_4Vmavo>5xp_M(aܦdk\X[ P4$WVhg\Wڣ#~;J$mSd6S8Un^զ>Ss[:2 >KTc ׎w&X< U,5}܋|U!3FS)4`PJeq bHn┝o d*.dIyn35vX>:rFl1č7``U':xR:R#E6HGsۃ)0VW8|qby|+UB/Ɯ&~3@H !2ntbI[ о2QvIqb=M{O,b@x_sd=h0M@vw&ǣ:sy 3EU<#W^i H։>LJmեa&A2H~2$ ̷ㅰn' m9dȲSͥ#VN\X3ĀF~]'3d&aE ~r :dXoP)]S'kc8Lk^/ΟSF$0`)YVo16Ε9Y'T"yTg,fxRV"59inp͍<{K^1ˊ&c$NMO>[}T %?,8OirKJ7Σ=M@w))ߩ2:^7 a.h KCό/4xoo["u6g5oUisb5j{XEt[l4ŖC\ӢyF4N:ҲXa.D3ړ\sٮ 3FOCӋgFM"9C`]ڊ!֖K[-q7#iihd\ZѾ(ɶ~Mq'AESyʬ_.2c]W[0&I)Rk]ez4"X ɳ` /۰'aAem[ѻ+]7匩FYehRp2p $nkl> ]0VmVND& ښs̽MB.w##y6\b <~F@DZWd WkFbVU0Tp69[z4y:p5'~Е.ǮHB0{v,P^eةDW!=h[J xϓa= žKp N,`Ab=g:pF2I653L㏎Դ&Nt{h.j E)?{2?1UASO@\,lW+i.ܛJsNNO3̠Rsm=CfY _дDN %ч+-Z-pus-Y|l$}^/Q׿Y\~o@dTfQB`1 2ZkN]HD,ؤ yaX r_Y,:ګDo C Th{DbV(bk8p<8߲&-k!Ҫtfv[9Jtaa}K r:8LM&qc M 1 9Byi"=mSM(;6؆82+l2C!T ѾO⬷r:cR #y`+ .gӋK]Mƀ'8ܾ}t뫚^nr)jg6Ymh@HVN]0cNXӭҾvTkz:-<eGʋ߮p.9m2`Y g%Xϧjfcz <j# !R,L7#[޵N3R Q SX F>OewRwD)w[NH4 2鬐;Lv;Se3&VQkNlO UWyedz6luvF{׿^MqP0(0tFh/ԅ3rvK:`[āy9z(o`d-a9c/1-x5%VBaְGlWz'm<~I Ѫ5şN #C8yOd DϞjop((S hcOKNג$eg9.MI m#W:HY]p*yYZ|kN`1 oX;Mt1s43ceh~? v%)[@ޕ3($)9ɗ .sCt0d2 Vɫvkb gAS!߂qz) '_ʲmBHnp ɀ$jOg1sY=ᚘb?QϮ^q]Z?j& DRni8ڦ.Riugথ0A-g] d@_)^,TCBDJ?'R-T4|gɇiãbȊ)p­ j&()aM+v!FVt UܫWs߳aW(J77D~]l[)ֵƛ߉TGlu~a3뻜`(QE)[pkЕPx}h& k{T ,xՀ~D"%?+:$ʱՂa[o$5ک{ӦB{cCR# d~=W81l6 LBgUjYGuz?a}J7#:ݮpHxa%0Eqك%aK<+p>(ejM09#cE Xeqx 5`HJy:FwGKnUv{>4?q1ro/Cy8ڍUwNGH 0*Xo;$U:1n~(s]t78l !*uz)97KJf182ͫ3̎ M?t+c(uUY_ʣlu>+W 0o/x$ٵ3 %uAtxsf 3A'/N)XI UZz-eP7p]o"}~8 4eUY; v8{hނ&tgC@ }3D}a5z;)|43SU =6Jk51HUY\no:6X<,k-Lx5;h݇\k? HFšgȩbR,(K|}DuR?OW-\ 869*hDK&jRJCj ~%4g! aYœ= ZM>}a: Q/<2,6B)D{o͚D.b gƋ¨tuj`pէ: 1nU Lt(3$gO [B5ΨY·h-5^I1Cq=%z{tnE1:"fsw*-SL@]E$^`@ZxrHJg0MϷSaNabɥ#P_GC͓V *p F (^q ۏXM`fkpN'C謿5vulk}_DIdk恵Rӕ*̿m;ȷBꏛ7+?53n5"yVdypD0b/XBfeQQ8ٞL7 Ї'xkUC@i.6 W\|o#xa'b!>39$8:+dBݮqPX,Zu:4H(e=`t{lvqvo@;?yTo20>XSNӟPkt]0d0Ög 1wj.N o'l{]fԝ"!f6{Qɤ#`>.j:tc=SvmqT մDNXu-)1*6F wGz?NcL%} Do`ھR2pHZ5s|I[\TlT-< z=Q/mPrFwXCFhp0͙zs@kNUnkU03fO8'f[0 ڼ3Hy~đ3!4)29=p9dRCq<9cA ֻ.gy+9p-vƫ%J>S>Zڬy;Z @U-tRcG͟*1!j@?2́z޵; Ga X nSY+*hDʀ ۱q+sАLŢP$*uHn)#' po^j6l0r)l1ӦbrUIתMq:aEK1 lvjJ'ӛ@ŞPݯf%Q Ｂ "=WŽ{eJ-@Jvgj6E@Ej%2`HH*$ɖg*bK!N[Oޙ*sc結%%F2 rAt>~\}n94% |UF2oobb8HLRij 3i  yI%R _Uc"[yķyYiԞuس)l{DCeIX`"3Oi 'دD?`MڟwǃFTO6C-J_n6}xlg3< < E 0C$wRdg N" 0Z46|9_ao0 %!*< Q,[>^:Zㅡ7OZF/U@ҬIh]|{MHkj\+BLTMQ3kyutC4xYT8}|xR^hAn "T{d/"6YWe=~[Gy흎rmgX;Q:YczU F M=Ĩc86AɏZ`\ Ւ#;bC6z/vK8T ;P5#p.?e{🽋+8MTn3əMTAҫsur% KBѿ Y$gCe9 A E➙4%_czhQ4u,n)s̚zAUH)BSpɬ 5G@i\7ҹ :O:eq9}>q%D0R `{2qgi]{'h=i $A1fZ*+ttzHR~r: *V|m6<-8i؝Qk%WAEX@xp:$:I!tDoZ\\q0>os+*ki^LZ>z!y!5-\c*Ď%H_d-d.[ D[ Ba&'P=ƃ=MAO}-dp_˃](^c:5C-'xL ?dAQauĝq=_P$p'UȬQG*¶D=rx#*hgі?ДUE:Muq3+Ia 5#IQ,D:LS (;py>kQlı'ٜh>2 Hc U%@L2׷/R 5ƫbǩV$5en9FQp dN_60m+~NL[~XL.P)*-/8<<$Lּϣ*SBk9rvwN#)3il4}B|z-//Gw < ^kEoa ?P:qjtشSsˀ-`FMTp~i& kj4d]!/K7ԑ}֕t'`?._IYai Qp\L/Yp:}%V8S:Ry$m|Wq+%HI͞2vfËYL2C ! ~ [Gՠj?uAUHk1>.k m$V)Z,%Ox[ߟguN4z&|x~M3oZ31]ʅ*jF>2Ե,*vF-urenNj`y$ q;N+10ƫ'o _0:XKnk2|W_?@]s.Ys>g8T)ۼA%HyiTzv3S[ͅc\L#*DS\J\,yxcE?rѹJ>_m,JfwI\zIOoYV{Ѯgb* On|FuʽN\'W pC;OE0uTMF˥Ԋ}Pk;ݘTnR@,^;N8-iK m.߂<(w-I.EM2ܗ! IuyfICע-M\/ Ga8rA&Br>PJrFBU7$قM≲}oH4rH1J?@Txy^m3aۉ!؝|M vx/_ױː,>{4m :pi<7m4p|UL5"IWN^~ gI]<8j Уaz:Gk\CuPoq.x{Z9?C@0O%{6C16,OHpO Iؼ.I(z=(luWā6!^ۙ.)/o,{sl:{ ߊ'%,CʌxBi,U;m#P+R`r\I&d&=EUR.at%bۇ_mܡYV-n!fA }+َOި~W+Kktل/eMq_ Lp Lzh73ZW_%P ISnmΤ_"ڧ'C>dYS^&T "Rٌ M}@? |T40ڛ &,+*ZM>$N(RU^E<_ϧ,ع-(S,Cv;QjK_2>͍s$kz`݅sY}ևk&yP|r \r0`̆i}D>,fZρ+=ݸ=)ܝ-L~(g,;p:(gעv޿,מ 8CH땳4ٟo`E.ASqp(2cyzoMW ݖ 뮋ilR:FxɦH˴ʬQЁge/fuOH%MWD^m90-ЬO7C*JR靸G{H!i [HOEPcef@AMbAqN!Bx 7,c"[DV %MGfiT!덱a㶺3j24kܙ#bV>fvk2w=YS,Eqpj4/`wJg!0f$)xGpdmr?apOY L &aZ iC;,aeδKiDy,y[ב>GO5ξ!C_)= E譱&dF'41o_{ުsʤcƬ.i8p.±fG)tT.#7fAP QVd ,DB{+xm=Ǽdu:rӊ.jFHOrm78s{^e5;_k}Һ.[:I`tO-I`(S:Kca :6|%T '6i7!AUCZE(ݳ۾AdTӬ)v<=K-7qTfYW_-cJ]с*W*MԹĦ&mAGb+Cنw%QH}/F̔NK^Z ܈ܥe<34m~ޙ"^N ",M=vG@^&`+x ]t\[@;И i3N1yr@ d1a=V#,`I؁N̝*\5  ED{EÆcDYժZ5F~(S/]ѺVyiDT/Oe$h @f Dg8v0{L $yK |>{A:pF681]Jr(?Ƚ i3| }U2+^kPMdz(;z8"(oD'-J|e] S]c%JLqw[^@_uKSf R-UQ;pa&N E*[9m54m*gb#?Zm9ۀwt,^1a ςkRD2eL0U_?7džA*I{ѝl:iؙ'NQ ^ 2I%%d<_K9VXXWP v*4R͇vw)AAه?I$fWHSSYr հ<^`6Vze5Qq+Y+A4%N3NjWa׺ P*^OY &b8\:G7)@ڔj|.y*rHze"3 yU&;ucmcY>P*@r{썥ESزI.kQƵ~ⲼY9胣~LX?U('6(A@ џPFuJmj椐LۢY1FHݜ1;Pz.gfZM 'E9WK  qLRq,&B7o"ay3 `!FQbۯ3>{L-grz_+Bayq:ϴ? A@ GU,I Ȱ'vyF!dPOzx&}0v!ѭ|]wg83#9p=,-Iu3r˥W'aSS+vtʐoE [`%'{kK~xVQ2IPo-c.`:X2E{#d C1mХd¶)֩ZJsZ5rv7{,Q2m6ӧ$V_-hY |Bq>,pnx3vM\t\GXDjsOHO{@)#`U PI~ ll8iSFEf,{Z7eF.0t;pdؽ㮐G!Ɇ쓬¸zjR $:#{5i| |E6 0cm!Bz9-/d n4$%n_=3waW4H?<)kaI7^̦k[55KU)[l.DjTi rXQ²Lf/S-Č[ѕGw9Y{y}ŜZ} <гc%RT 4 lQm Wo.MƯQ=tZtJq{p(|w#|$+5;jR: pAw[>h"юCCL@M8g+)ħ- p_ v Ъ R'Ml]b%8)~nDUNU^BS֦ ьusPerqw y[STݓ:- jD ¡1 𸓶4ia4?"W%i8:-@ +Ғ 0í0Dfy" ܍d=i5ImWNG݉6pY[]a_c miJ-}τy=煝Gji^jIÂ9 gR& Jb_m P! /xiju2+Ɲ&ӆQxc b4QGuuogT90N:: rhz&^]QxwTZkkBxV"Qm-&=55㳏wOGhZ:0 nKZyV_I[l J9Nv!fߊw SR{;џpN쑒p["~{_=j c+6 ᖬ.19 V ^j8ɓ~E 9,"AMFzM7J"%w'm PbUS*)<#j 9Z۳NNqKz f Q|>a}2nFj,Lj˞©܊\,ճ.ą\TlV~Y9Tsj`&Ug ֓SP=ee6W(g7iATc;4 | )5֪woyD#]o8v5']I?ԍm㯻m}ٿwaݒ*'V;0 Zn))Xbr?%YʂK|mfwz!#_\6Tz*tO;_s վh0c/jϏZCDKHيph^#Z;%z9L|@eo܎m{#!>V{)I MbdGeݢ5 kOaЄ H#ԯ'03TTWR%t<SpYbAfȂ)`yRô(\DT0p &CŇ 3ڒ%Ti+RL񰕗Arr#Đ#a3:<*ph10GM&oˆ>ÈG Cm3ES[51.j^aWdїiGc]n=~}4[o*B(x49`E\ >cL îs=תI 3(2<þ]<r`2H5cP d+Ic۞Z8Lt*/jKw7o6ۣAH)';Q!E1/Gk1pJ*.TxoШΗgFE#"=R 45|ť_!'Չd}0M1d^Q Sn+kѫ}\EמWQ׺{^8E>c2!k'+yq5)&O2%ROgSR^fr肚:muYcUyF% a l yg<:ac@;)v̚yݦX=d@|MI`[v(<'mFe4 v` GT^ "M;=>1r,wnGe$b7dI\z r6ʐ@#0`4Jsd`FCeRUwq䗅-^ xME( zj b|YxN8w2 dO K6M.ݤUYIw6ԨLe;}bl7^ Jꂩl='"1[i\mEW2|=CX14.Uu74X>\Eㅝ4)%U:(sŬ3ȿ {>ָ ũmEl+V*W%S)a $b8q2A-DOĽ!)MFN/U[F߂"P GZtq-}hQ慉CyLc9 q5\r?Eٝ.UDv wֱ%?"ٺCԕtquf|l,V tٞF W=79kFR Af5685$JD⠺;0ނABRNDLۍ,+鬤"+%i7IJJfz׀b_\.m>A7Ӫ$0'%Q#[v;09eu:py5I}Ӯ(/ KqBtVW%0=XAFk8s{t԰kt%}y b+p&S1?tVUF ̚|[!`;h"/NΣ;6)$Wbs/99n!QZCڔJ:_=Yw ;E,B } 0F`klWCe}Q QCY[s5#==&f0G*DLrpv" cG/)xd#MGq?IhUP^q  ȍxv醋B ,*{ ~erGrŠĨk65oie/|ZB)Cy\[u ڸH&B1L< k&JBj;S e? }&c#K(t&5X"KpaH nȔ_@}]o $M> oɃu&QbSMTlNMA)%爦^.LdG3(SZMm=q/pw=ט7p$J9,*%_xjJ I뻆Ul~@l*.^W\:]"nEbèsc+d w[E$-Yi-͚v<~MMQV`+[2\Q*,3)̓Ddm?}> ux@Hc" 7 i9 ܎@탁Gj JoX3_(` /I6 ȡ&]Za` =يݽxO.1KAs4$sTHpC9~5)gF0֘F+Y ĴgyHѾfnES*]dl?.26hD#2`b熮<-rm$S%+"sklKʛ! ϑN)H8=QfHb!mI2nz78=l+`j2t-s.w`Vp2؃LCQmc$] "Sa}`}ɚLZOP8PC~k))%lJ?_☼-]'߶xZ'd ؏d*ZF5DnPLձv/C`B"ߘH~и<gm &0C]RwR=ݧ@l\'qwnpɺ\ۀA<歰O,(Fw߶$z5У0e>3jKUB?r+9$h7lGnȣk[5X㦄G&1c$&Gܠ['yE,#+- +Z߯Y\/Kl%Md8\_/:C)Fu gAng=Hu6Ur3f:V V$m~e3eGANݾxIu 0}}93upW'=TDvRc;c@ ,DVd:l*nOzd"/. s)ʯof*to9e] LXl9LCpטx~Ri1x= | |/سRf=#TT4egwsX^hZks>uЉ^#|!Zj3Bfk߼d,1X$NI7Ui<1mg|HQrkʜjeCSg=/'v %%=]kHZU) AzpE\K)Ou&[ߔT ުxzke5ڨf}̌]P#e28LuhXڛi+oL_;hh cry ؅*gBgeCmG};=rBoUϗ>n!6skjm0jz_2 ~J(UD{7{?ׇä4ϡ/D%B[pX֖w`ZmTl8a}%1i NA=Yc0pxwj:u yX Q{tՎd8"w >죘L}\99 N1*J!Vw*BmJ*C#iF;N"+hb cadotiyWNEPuK9"O& ByWr+r¥58T}V%qL{:ccr4:;p ۭqDZMJpkEФy#up嘦,L,N |}q[GxD΁@рL.6GHﲳS15S)O l3QJ2BZ p_ʜBWWE߲UM(g@OQm5nɁkb8l̾x!#ɸN1H$cYpcS{Ӌ*6dceJ!J)Vjʽʆ߃;&ПǢ_*A.ʬFٓL6EXZaEC64Ro5hp~[&A:7>J*NZ:WCiIXq!.}|wm#9BӓH52g&l}7m%aR-⻫-hqK9ַSZ$u^45YV l=#f 0Om?Y'6 @_2OaK\JLr9n#ӊ0z!ԡL>A}M1u@ԃG`^۝ ^w19Wta:l7taV/J@0pj$YӘrv}keVG A4#&O_F6~:|;A 'dzkhwU`Y$1X2qW g պJ~| 변+1PJq`! dABz*_8Ta)d˅/uѨg_{e}0y8J*nB{W5V 5~y 54c0R-j.Sxux_?Ff-#O@6&*ͺoN)Z"ˤ˖F}oJh4nJWU9Qb#8Ol(P039rx=~22_ӿWTDt P9wL-⟻=hN#e.,#Bo9zo 錯ĮZcJ ` Fь'gvͫ9_ZHa*qi8Q9H7gX 5N*u ~8^A#jrmy-aX W#~+-kd'Άc'oi  E1=v#5(K!]uD0(ȤODuA^4r&h^EaL| le"t5wg VEx C:/E#K6u 8>8b:Aw`*dƵ>QAXsi4%Ieh}[?o<SCh¯0fO?rHLY=d#x_,l'́5o`D/)7X;ӐY5ĉ iMoUd~}U]qW(?"=2v {}`uj4LLH!4뀟B݄r+1Vvq~*VeYz4)YFiT!D!fpK&+iU-NjbA˅TtЍE0E5*;bV>4u^a6쐳ci|loc6v;.$.:T63bRŘz#>1SA[.;)(֓&'mIpֿ+hqۛXe6w4Uʂ2w0s|1K6T%5CggN[8c&,IioJL0M S'CQ8p=,l2к\|L&Ä$/M"d5BFxѫVh\6$'emH׷2lTBC  Z#|?TFx8 owF e-S<jU̢KJ ~55&:<*j96'"xzu7?BT}K+75/<3ϩRI|u`n㔵ʨ1?#|Ns@Q~?}` ky//z%hjL%% N-k#5ljo2 |1Tmf?WgzefM7m)pd* Q#DsbqEY?DT 1׿ q36j]2}KQL Foђͥ|-2\eॲO[4xsB*M_mKE@%E>,t{UwTZ.4\iq N򼼩nxcs}±q+fV<_W]6g>ǭ'F愢P׋zwÇ{pE<{|9EH0M!v1(UX: hYڏRs9{̧%í@Ʒh> IIV>ׂ3^TVZIPj1S#?TfZ)+ VD y|ziO NUB}FhJw(|K1H}ATDVc$_!y$Eu&pV|5`f$([Xmwŗ#qAo|{E% _NvN&@4 *壾8/HXL߻o,)$RaFXYeS [_EFPHQǎS2Z nx;|V@+fJY6lI$t!8qNGnS]x}4O'w[1*j0ck'ܴSH3H%oR F 9men>Pksq@(l!W=:8[lݜDx +]n~ҖV m:ks@^6;u%%+GxGosxnV,];D禯,er1#}BGZU5o@mZEA]Et:O9_IȈS*]XW;5J\ZM@y*F!Цf6Օ];^&{ ]FL cyZj 7OcV,JlOP CiogăHHaG҉:h{-NW#x;ɰ)K˞nDSȗo*q}s6C2QyJO {ш7#޸=aUyq:fv O61~ys"y} e5$ݮɦQS@eXw +b}\hK9udIXa33˗b9X1SP@׭,j#}śy =xF48ا،)k j_Aq\B4Ήo^]Z-}OM*@3TuuLcsIO}W֑8xl,9z#>~tBя5YHMd~sb<ޱ}57=j9!6Mmٓr~Qv,WQ+^'So;S teԫjx.Np U+H=~zv35߈Ö_ecp-+䌭b+#e̥5"&?[7c wY:xxySSyX!_3iG?9߂TP?RMCUQ㷩妵Q85\POKL8ߗ*'xiڄ~ ksrjt0z̲ \ݵ51Jb6ﮒs1+-)|6ҥɪ-1qPwRC|$β9^ƽ@Gë3{ь{k%B`J*g.k$ 4Wrl*KZ8\Zcm !Ϭ&{ QPP_0? Q ]K{a5CF'YEJe]L`TY }d[.|(< I3t_We$IZI^M3IgC᭴cCSuoj;W5 ƒ.YPlz8Z3ЂSg/"Zv?ddǘuV쭂V|*}:4m+ aCMahYpY֗5NϨfQpoM5Oj%mt嬊d0}9@K9;N!o/@CR[e#AT}v[MQF~3Oʲ&`71Qx:*ղ}WFr=mHAVЛ..ʤ_Aͪ_Ev#5K^xW|FpT|=K '"*Zݒ ONIsxm m\݋ }A:˕f$iN.^Ono3zMOOnH+:)!|5C9@iD+F&olo"xlO0vw}FJ] Z9Lt"B_%I~.HUU8ސI06ѳGEx$ځ̻j{b:Q`s[y 1 =54}" )Pe<7K:Pk cT+Rj4\'H Pէho9PL17t ZVnQDz hz5Z~ۑz f ƵND+NQ`aʔܻCl&8;$M85@aDַ?#WV(bInٍ)/lBLPp "? ;WA:#c'ye3@⸟`wʼn]0|<,FJT&O.iF7=:Hb` S ||U}D+ËUΦ m̈&92ő%1\X- 8y'? ~.g|Ѻn?ēBBWkqGm?f7N_y4wJђt ")3!gXwb;es,yO_ ҍ!(3:>e"(ddZeB\&tm})NW![5[x|ٖͥ{|r7~S"Gޞ1SauOM !&Yj\:}H@5+sOM?DЎb'{XRT+`~MA2#93\Φ,Wr] 9+rR iD|&k̦ur6EҡW&;$T.^o=Ԕ@UFt^`! yLx*26AܚX@.6揫]l\vw>|˜b/hBt:Qo﵁x蛥f=Jdye= 氤Q[[=˛HGcQA  4$jv8 Jr=y=_GKѓJ\WU] ,K‡YQQ$Z!9̤xjt2l;q%.H&V/ qqSVn M<59]fO*|06 ~z,D&wh w6.X|dVS%lo#^h7 xކ,\hk'oR<_{]y()8 XKR݀5ea% ,? G(\TZmlOV#{+$wlg@@?c#8y/+:^:r:0f(c /{Y\B|,!-V:~Xi\^)!5K꣊$6^d/k*8G{V@ݽ :3,V(-;dGr4~Xqt7qƫ3hj<0JaS^0gѥ%~>` F9YopGB<\ѴZA.ZИ(%GٖcLQF |u{UТ:?HxXUB! J ˪frB .VU8T |B10;xy8̤,WՍzKfW'*@om`6R ZooZ  ,Q9xU(B)̭u:}B;pqmZbKS1nvt9eߌX ƨ;jǾS>k0J&Hf *Y2@n(c}`R.͍w1?1SxIN(yh>HxdID ! \^Zߔ^' Iv[\.sX:W?cwXlЇI[S<7Glw TbTqmQH$7w{xn'SVgӉ8w08̅Ds}ɡ,)ꬕ,-Ȣ8f4%9łf@Ơzـl!poQffhܨW2V9*#B"7\5?TmL Gb`veՆ8Q?zaLD.hl(@k3ٿkY20Fs͚m-=(lFZ(+3ji9mx+g{n1VSe'!oki2Z-E}A͡fj?^v_w  ݶ,K$]2RbY쀒3T1|BU;꺣)c7|6^PGWl~15}T˲-U=©yC b݌ї+~škN=%4 9S= N}QsRcbn>sKUH_.L.(EU%||=n\ėKSuS!_)$ W"y"f`+n']<5IT8S3:;HۆjU=l2"& Qꮬ|reK>0m{q@"eBZvfAY\[KOHM`h'Н6Εk5yIբ# i̋KZcq}vSe{:J+UeXp͡ޑ@ZFl(cXM2& )rEm(J-R5h+2ܿ% %77y&KdHPqvN\3`>~-JIni˼1\5X%lj<Ixi[6V% bz#Wv8Π3oPiЦh5ja&f>E_)1d4dmgXq8'ax/(ex] 鯰ڢ㕣ET;euF=_3 mmԓ=֥@tM[{4wm ~$vMh[ۥK2j!Uz9s$<݁-KNr(;*1[Pן@*"EZymVld}k2\ȃ8,r* Kl,|cڍ-Jeu2d"z2OhN%:=%F03/7J+w@[nrnاKlJzrg-cG! CV?NLB&zѤRLV+=L[ET(S>0A8Ws{Cxg17{tO4;Xa60cxDr=//u_!P nf Ѕdī*Hk7qRTɺPMhMDؿ=v a҆9nei.OV햮bmuJ@rd|Ln4pH]Tînye; +**K%`d P7@I=H' hvMY& wAj!Fb<_=+[5܇Y{e5"!M= akA,56Htv:kO⿨l."zHN|U ˌ?}:S"|3BB-D,-i*`_]n.Wrd\`ח 5׳\bס ,mj̄PcbSu*;*G q &+ȩ-Bw=JFnRKV:vLV z&|Jx4qbޖqo/vvK4yuS3`X8N녖h"7%]b3\F?eQ-g@cc5uPs9pA޵ WNB=%LHFt9U>ac 0B:|`1P;gؤ %yy=F[a<;ͩ)U6ڼǸ$q.;@6mgvW!- L܈E"sIKi&Yl<ϸ\:I$4^A.i֗ Pދ7(¯} 08i>ޕ+z:*B;>:yLm$C5 3Uh8sl0ЉGy؈gSuѶ!h8#n{8ڹ sXL= &)C@D) oa 1O.9P6\(#r=TNN.4lUEM~|ظd2'Mow[LGmfotG d_c;=FL7L0TkD;q' dXk^vڱ6H5Y%AӌߤElf?gk@i\/}# +h]BX5b\<_b8UyA܂?77b ZZzw0-E5*3@:nM>͗GK'أz<.3V[hd \%Ɖ ͢vOf'>m435gtp)]`P/um %OV1"EJTU.2 ~zg0 g@ 5U&]ngkmDѶο>g}u'Fq]1貱wٿXݱKH(ZOgi;xU0i3jpFj%ᨮ\`@0php;_Bx6 }>;,]/ 7rA/H ŭCMC_\af&5/\{޳N4(ɪ a{b1mH[&q*ϨMEzgC^y,?k+ [bxMn뛜*iYHmGbELaML~=z}@5_R+lx*x}e% ݒP Y@lTrp'h?jN2"RIU#ފ8xKK< *,rZΥ_܏khf˷ֆګ5ĭGŸTqg",&<$jY\c旈nA3RD|Ms {0d.7Oy"<hڀmX!VAۍOᲯD'"']/!c^,6Fᙜz 0S+G҄v l'yUv&!9ʛ/Rq~{qkO`-I7DM "S,qK+8Di/"K3|WA%tS[ ]0obM$+`X}s)oyF㨄ټg~6~yyqahm.2 U)?`Ņ|F@oDlc ڐkR[~n#;`b _ou!?%TI$ lYmhH ռ48'ե/qa[{?ň˘½,4Q tSg /!dVwJ&GPpe//|'` J>0 YZmets/data/base1cumhaz.txt.xz0000644000176200001440000002133413623061753015550 0ustar liggesusers7zXZi"6!Xu"] &wNϨ 0 Ӭ Z,gs'Ζq{2m6#c+s65mC ln[k3ףdr;fJW%%ƀAQco3EBmւ߸-|mPoYց{I zFљW(;e} 0:n0R1uYȻ}k#;V nbmЮ޹؟Smh]AS=6iU:xuܿ_z~duPxHjqFyq6%.\)j5RwExA'm]>HK2uyMݝENm` X0_6: ?1uhskki NbocqpsdOyVuc>p1Jh$Rֶu:h\a\Mnno_xy ˶x(UaOj]@L*QUJ<^R~"ɖ_͈%d-9G 7OGb-w}|c4ӇUq\4i hBDjeш'ƛD 3OwT?Vx~fʲލD jТա.Td.r,wsPZG}3Q*Z>LV5ϕ{ ^k'²X(?2]ƤWF4q"YH8=C89&L>5;; QQQZKF * VllIV۶G6H%狰\\;aĈϲ1Aq$&ƆH ᦥM;HQ~OOC4g[~<&ɷ5'epHBV*DE펪-pA~\pӘ Xd;~EAe@Zf͊|?m$KadYv۸V 1GD\/aF(>'u¦`OSe-cч 7MɪL(7Cן&6`([\ #m`ggɾ`IN =ӕߜ m}(+<$(6̤ȕ1>xh`ϑH%(AQuoLwIk5=ԓ,.QF۰Ē) ؏a؍3eh)4%'cz境5-!R*7{]1įүaN>OXwFGR? q\ W^zU/t~59s1a'?4D|AH8O" K|qk"Аĕ4L 0 yDױd4_|tH&S sˊan„$h2Ÿ,u T:tTIy) {x\ {ktrnjh9hڠNGwt!*yH[ 8ɖ<cBu0*3R) BIS?c|N:h`mQDH83Q4ch:e78\Em !gV7;etp BG괅VRg4PPx*K. b:2̭ ԭ3Z7z\#JZ\ X2?x'㴥*<ׁokbe1mY4óέ T2b*k@YbB;$t@trz˳J $ѡcjVq$ˣ7^od!`RlYu-'M>"e#ȩT4E5Ab“"G.V$uU/M)>_b.GyJa=NRHɫeV0>XHJZnfu3{9-K|6hąZ.NJ(WL,B*$&z^} AA3Lґ .sߍ[?CtxJh@ITm3= :&KΗQ k_t_2e`W^= S@ORu!?p]!Q̻mCV[^ZhB BT%+; #-M79t>u!;tf m%Yh+Eѡn"FAЬ uIn *߂{m{291.ycpsc߳go[HMD W/2b*bΦ7zp5z4@ngZ\la;C-=rnXE 6y9[0wQC:+|)>1(2B%`29Fo*Ap>}#c bǸ'485O'!,FU\?v`f6tɅo&I|1t&@׎ߩ4EMVpsBW)r8"/_&?*:#IP\P>.X/ݪ}F-pWgxZ4^$9Խ?938n&/2el$ur-gpcĖ}xv >g0?lคs xs17^> U8 ;9֡ډv Wdb83svJskT$[oQܻlڲ> mv #NEŢ yuQ(t%po; I{?8W8;*3}2]%-^HF7[[ٳJ3VA;7d9\\1FF 3YN|/zN~[joQ xhP0s3ҍXc )(u[G'-(q/m_;>|cC6}Tx쐤3$~uG6X- ' :T^߄z "2rXiНOQ*2FZ]x؃& k1;SӞ=N.s\F@  Yl12ѥ`nNs Pl(4oaP z 8.ƦjD߅=ZtzK2W2)qFIc!U཯"G*+BZPG`)S4 -fK$d#=s$H#܎M o;m^EEfR&%F &=:L# v:DPegEZʂ_|e_yմ.ҡwR4T<>ȠR Ibɡ0ěMI6.DMc M1o8"2@6z[~G%;v˴;-4YR;;Mwnr 벆Ft^KgI QyH9eCpzib蝏k1}?z;t gSX`)#~KcS]i##}ωwdn-j'ߣ(N76X,};߀ҙӉ9 6@Kg2E_ Lj-=i 79 ` h3X*.&Iخw_i KyWGHm9 g>,wJ/2I uh!P{ P䆧HBNu3SjOtp !au4DO.?Ed<.3yhk&a.gyh/[1+<ӲO^%ױ.gu. Yv3a27͍9{9H!BCY(3i}`H= ;q(ȓpzcĚ]泌Sg!di`zwg+d@r CA` =[:* J" W!ia!5>/&``v?u*89=1*541v=))XL^$~sF-lD-LVzOKdQflLHgtȴa%UVd3O(<έ'3h5 L"/!I/>#n<<¢/-P<áY0֯+ҚZxȋ YrB4yfo2eYƓ&AFu( Nٓ*%OmQ #KHBG$&/6G@L2"OLyYc'E h7!=ɑ#!Y*P ",`vS!{2w@@Oqb@d?rV澐rCA4DAYVFSO2;.~$OUmm0!o!2V憶W}@rdta2 fLrn3F ~dK/aHiϊ0>1 ]n_1߸%yy<;;+V/3YE mṔ4sCە=^Pgn]w=}#uVTlIۺnׄcG{tZX7VBG3dFF;Q<>iB+$&*h Նʣ32*eDFwnI$ ճ!Q#E|+v8ڑL0Lt|oZ~"rAAPۋ?EiI~xl8<\Qm`I~* sp#;AN 'YS꩟J3&x%7 LÙAGmg djpfj5sbT-{aRH"}]}Q.Eԩb(w|v-Lj*KjWgrlZ+BelF߻fz}t|*OukdK-4ȻXIM!Gtm_ RVY2<Ÿ0bi%)#\qϵ`sяT;vm@17(w+9_z|9қH2g=1GM 1I gMy5=KnRT+Q\Ӝo{ ?P)m1,4_C\ zjՑA 6"4\|BTai,'_$쬝׸/^t,u $ pϠ6szPzsC2JM ?4*^)B5*BA? Of"Ed@ʛASA'fE})?>Ko :.BH7/Ӂ''Fp8ZK*# fdmyˤ-x":? uoU r wWL.8a bVtxll@e̳7+]u;&~k2E}xujݑJ(ly͕R"$~bixFwk!Jzt'SVI| VuqqPhO5i_Oy:QVO!d#0ó q`L,'/?gh,Ɠz؂ /Ly,Ӛ{sIXj*Mί:BM5vKf&iҬvi?\qŚu+Ӆk8~%a2<`8. T$u028˹,%z; 轒8Yz(U3W.(mD4&h(F#$lΪP>i'nN GM>!˷V/S4n/Wzeά Sų]z)E,>0 YZmets/data/hHaplos.rda0000644000176200001440000000645313623061756014242 0ustar liggesusersBZh91AY&SYbh3i ǀ&k|T` U"))Fh4hah @ ! M ѡ4=M4hdމ='4ddɈ ` 4S4Lzz=LA4yFOQi#ɄC2d2 4 Ɉ=LSi<h @6 z4 4S„b'Q444hDMS =LM4hh idz@h4zFF dbf&OSi0xM1d4?P4cP)AMYיDaflJ5VX48ڢ0(V:ڊ1d#^of X!m͢ 9k<-dm %V*s&b3Dj mq&]9ޙ4 jf]bQkܽ`2lP,jHJ60a&45,:Ma:<# Vkl3h(PL$ S#&4jaf6Ҷ V`Ni gB[ bnL"j#r+(CH7 /`Va,\V1ah hH`j,B2. :XA4PDBWa L$ i6 G$4cUF N%PB Y$2 8D* BHd;4I6XA d˻)c{!ɫ\^RA]jm\*FDB͙J6"Arրh-,Kw5l+5$VVR&Y=uNUHi MFsM򼴩PT&Ƣ&U"L  r)* stŌEݛHl^_`m٦f w=.1C9sF8u/$ވh4]BE(=^5G%'ؤKق4>6m Nƃr!OCry\dNx'%xiILPOGPUړBzTU`EaY1Y[+̺ 쾡dɜIn6ZM\%""cYX  @`d 9ZP Fp wr E,Q@hAxDDDFoďU|}EQɠA{~8pޯS睛^؀6ZEIJ5%4(Pzhq MI|]7{}]EIx1=DE'iEeJIJta[XKz"bYe= KcL\\S6B097$DE'&Uetl`<8[3Z0L4a-322VYUUV _.$#ݢKˈBf%+ir]H̝wpa1 7Gd.FpoʬTeE?p[pb1y";793.O|TXqQ~|'J*K&*<7R9@ Xz^_NvEUAWFiVu-`iVK :(>$Gbhd/QDr%sJ  G::|R]ͪsޯvگ 8H7}\ n 6DF7Ufhe9B KoS3{ʍM-qn-oʒVٮ"S& xqt[:NDV%Z|4ݵiMTIs K+]#g w|[wIA7] p#t`0Wy Ie~f/}i7rm8 &%`$",wx!-Rܨowv^ =PPav5f\1+\:ա\^ÓkJC^֊ַa):k]1$3^Pgbw " sU&"+\8S G& 80IeoQ'Lذ}$V{]P1K ѝj|:qg+$lX噆wQAnw$S &0mets/data/prt.rda0000644000176200001440000075061413623061756013456 0ustar liggesusers7zXZi"6!X,])TW"nRʟKMd[_;zk ~-E*2ךb[OМ,AHb\Pse=9Jo>\=SR&Xe3 N$eZ4$6Rj3.l(F/mI)>q'1uGB܇n#FIiP,0F-AHWr[)U=:ڊE޿`ʀqݭAzB!yZx_0gm >lvqa9T~F4!+3 0?~lVrA_!Oa /GJ @s2 "SS` 4@xNqjy!w࠳̟ܵ??!7%]<[4Q ^ڧ=Má7@@E[sg:uKyewpCԏɸ !Oa/MQ6]^Ol̶Zz6*k 9 jX,K5 %>]c (v4dJk3^Wrןu@CZ(Eܯvxkڪx]ί}Dm3.au-ܧilT?'JTqm=-wCH}" E|%}F)Rv:*vld!f=v*AG<%XyUDVfqS$GлM#I6܃{g^hKT^Jz5|ƂO` ^ 4nYS-3 hM*2KW7^6 {&o2K\6tw  oD#=W "i\c;.e?b8ۅiFS8|3B]OSqP4n2wVc͛smf9[hR1Ti[tŁG*b!@0n :'zܣu"]1Geϒ0:}(I"הZw\bk>_12GgyHR3mr8sItM0M"X+QMy9)Gc{o7hU򵪒x[]8Y7v'Rۊ;8]T]Db=%R:/]:{MNqƘ ɣ~~HuGZܳ6+./4ۍ2n+ʅ6Ybkޕv,ly!AJ2q~N__gwC=ul,^ko+ܡ d([4C1= VT2?.% e?drI&v\WM C/dhHP-~>Qe}HkQ@6D"23*ECl*azPe NQ/0{P_Pwt1@RQm- ~P3ۑ]G76 ,>}IcGвYed.%A6HkU koGb1{N[caJVn$ؠ uϛjȐ `S; &xm:kScq+⊫f1wFa(&[EA(.F@;58#}Sawwch )#2f4 qsn-2Lh-:{1,7o"|s;]F]=!Y2Ƿ2B3ܽ*lH+X1B}>UK-jjl VV-Qd{!GosBHo w _ϥ%#xgRMT;ENIM_&sT Y]^`> дzxe@0}BE݂ w4vj&5A[t cV/#R mL.e؛Day ~P4[J~ `%a#jRMZ2N7î VXDTٰ,~Ua᧿r-760~1 JЈ[.oĽaT{SC:oxnE[f#2G4%_ 1zZ6x^Ou#-w{Fxar |Eo7[O+ۥjfR{JW+JҮ⊔סT|wI~ tR "*i!$W􏔲4LL[i %wt"~E4,UR2L ѩN|od@uWGR"zw#fˆ27UO@jmM;p~ X4w#-ϓւ6vпƫBɪ9I-flݥf䩲v-enVh4^2qBe7V{c|PGLa*7$;)⥏U}7X(tHw"P`Xt3/k_7)9%h̾%E s x(.\_.F6[Vٖ8|]<1^{8TNE}ΟrOA[>Ũ*a ḱH0 /C|S4N;Mi M<cy{`z0PpL͊qKxyk0LӶ/ޏoWZV0QhXO蒙׹x*> E:ɛĐ{r| Tb|ymz)Al8lzs`mc=!eǯZ }CQ8\ W3 \5VUWqȹґ$cy&4_a9=YlOQ]J#Xw_sA]q"|]Zv?IC#Zp [Aѷ A#cH9X\uH#`N;b(!_L*D{9uBRͪVg L@c@F4<1r v)C.y>]vȜM:Vܛ:LZőY"zPnnG %z\3?"J<0# oe1զGc(:),Xֶ2,rZ=pgu"tWvscjz"ѧ̥*\8e6GR˲}Y[XL91S\!bUgW7WtvZg Y[ shdA:_ʧ|@>Q l(H]/b8ebƪ`zF 7-Ui^ ${G6$r.ND@u+(0շj*Os3RJ%ʐ<Ҧ(Y:2S4 v CR.2ublocq':Iٖc@E;^Gv7VLr>"<]F6O{$?~d<1~OuS)(HRV57F"$Nc\mb+;Jf 8f?\יּ=DFV ҳ$6ҙg\8S~滧ʢ򐼑5%34>jҧKb2:PV /cw?3θ v|+2DҸ @u!%!a\Z\!e]>}v1I鬕f7FB53%J*)jO[ IQkB\Rb)e:!U6vݣ2{0yY'P 19mG?E&KҔlc\}+ilTcLG"`FMGjL~71%@R:7viEWJA֫k2V2/9ºFR'W3zR nGJ}E&!),; j-9eU#  _pʈ^H">uCՁ/ wuDm&k^!}oʫp#LH[r2R)TExlנaMst" T!K= 7c!poT@L[BrU-j"*33 sŧC߼nʨB9~G\iQؑN]hfY'Xfg\ jQẻ,ͫ zGkd ;+x6/nA_= ^zcɜN|p7$swօ9{0Hjj.oK)т1GCDv+y~i˰(0@GJ0.ʼ|Q`[͑j9;Fa\057|/L+biwY鲋M+ q@ȩ?WI)q1m[f$ҏ(kKftAW+!d_`/ ` AAI+6r]aQx&;6ٻ7W@2+ i:WsC4_X8& y?mGb!oe>]2㱡Pz [Z MK (kwMU?IKsqH)!DG dVܺ4EzǍ40Ғ)z7̛6.O rU/-"7DP@0 ʗ#!!<XH΅u k70\e96 hE/(9ꗬ䌈t)GKD1.H<\.#C i!}fcslѮM#8I}!e=K<,5#zw0FY5'\[l C $60_ټm11]Kt2MYaNE 4tLkEFʯbWXr(s1g-,:D>< ^uQ)FK#=4rh|'pt(%ɓl .a !GbЧbsM!%7H{AB@oLh̓nΊB0QєC' !S67%qZF|{t!!:NҍDcV̦RjFx*u@rF@:"OUcR>oal@c,@% xɣ`.'"sK%݁;X}f,ԛRRvЄ=X*EV T8n\I-"kPHC:twP}N_%&BYVVV%|dgJ?5ݵ\? miN&87JNzբ%28VjPxNjWh.evuB] Nutͥ|YJe2?痣ײA/߮(:|F|u1ȥ#U8sd F' V8r޷\KWs68(\AV ~ />xy\Ji=>7)k ʻPk0ڏUcu]eCC#=i:^}E疋{cP}kv3uG*zGVr!\Ǯ3wffqwN'R?955WIrJf7K5f۲lq+7SR%J9pzx~ .=]|j{SI&MFf^TvB2S6 )`9ZHϡC*wIR&i(k˚THzECAyO/Qu4 ED(:eYY0 l%H.iBWtbR~֒BJ9 nu*\ TΣ+H:ٝ"%Z4ɣ )?G*ͭ0TM9w*OB7ޠǮ!~KA :1R|\su2pN^"@ȒD z.PoBu5ϥj !by»gvIId@!+B`|c+\$y?n=Cw/b*c\D.K SlXRb$UAeap /{VGwn 9}RտoOs6gic5M ܌ 5Vopb+4RH¾'4jz!xҜ1O-й]1ߡ?q>"Hv̆U@{t&]?T J3toRj0|):iHrbg=7\i\z5$850Xmً13+ƢI[cYZcX.GP>]FSQ-.*o%wfx"ٖD G;j(ՠ騣EЎW&Ý%'P llNz^NWg [޾=P}|^L&H~!}¥/eB'B#g=Ṷ޵6Q}i7jސȮ ,Iy1* VkPaSˎ'FQ[5AÍt\rd],0]HqTgރon!ؙvo`7ePM]Mxk?[>/kŐBvđg4'MWBw~2=$&B8/)@6?o8H>Hwq^-,n%AajPesx+ڼ@fNbZgR^rkɲ[y䪍b}Bg4<^ˬ*'i_ԙ MSE;J}|f`U^DR#,5onl8+ VgC`-#9 ?2wϝ茹() 6ۄu; W :HK0{ӕWФIb?r$B=K؏l LQ>jTSl cM _D[Yx޹m~<:j!cl{`cTkK)8"z`}ԩw¯?뜿󧠿6[aRfwց(hEA$Lī~ouОN'b7"m.\)oX\N0mftݦ8Ov7_7dP* ?8LHbfWzdGm0i#w©[RD4!rĵ."`&2S9YJ, lQ) Ax|3fYw"ealQ =j/hM=lOlB.Gd}+VáF q!֤%?zN!RSBrn ¿ȚN["k!lnΗឦIdf1xi QkC h3_Yٷ>JX^/gPHö-G:Q;.Wwu-o~+Q>[Q>M[mdLag=cB Z11~=j)oo!qU!:[Pޅ$PD q9UYʋ)+Sʻ#ưe/o,F/R"GTڬC:[+/y/dړiFb":u{/D.Ɓ.Ë~Ttisʦm޹+7VU7ĺ;#izr' 0T.<+U}o}BxsM߿=}yn덠!Q?.x[͈3 o#=np;Jqw0 E|FJ-cL_<tQ>〟"Sv>wg)=RS&,? $X9y #_~=M6BK9^=AI@&3iWqwI;@.>og9hߚ#Rh B,@F-RQ:KI6&|w:ҰP\*Js&Fx9*bO/M%#h!mj`3?s 9 F1k %% w&:|p>|0|`Z{Y:*{ujy: yQWscMnwZYaa.֯:I򬍪F6(QC8/e?ޏ)A5ɪ"dR6jr ŕ|t4H)N-=F'3RLW*ĒLߌεK .9Yg#^Sϡh{Q(W#1_^ŨIHwnօR*dVA##Ɛ4ۮ6Ç|cjl|Bq/-|`Sc (u]xWPGAW,F<͸2 Ն\P♰,faPpP,Ca~}FyQO3Gh}3R@,H^F^HZr%g*T3\jOA&8&+-KdlDSz9q`nykGmsQ6d;g~1+6ET퓬a"7#SAD\P1Er^aFtn+ʗ T-YVsaB}dʋt9U8#FHTn :KѮj,&J5~[i@ÜfcZd8;Ƚ#t}K8(N'ob-]ϔSaNE ucBϯ"s>{e%B2_oN^Sz33ҵ?K"s,r& Z2Eɴ~]H>%u`h͡#5hj e`UpK{h#|+'TDPN=|]k>СnzXMT{R+YO8d" kT.\3?wx6>vyedVD{v#ݾgi$ɽG[~4Ney@Y)så Whwx>?C-Bc$F)CX IdhƲ3'R@|I=8-b@̭5)IOttܘai胶A_[kjڠGf^KPfm+gjG.FOof]x ?ʠ~=zmZg):!y7=Ʊ!z4Qg*aka"wokgsx:؉{ϟ"k3\c5^2_c5'7@1pu ۳Į |a1BfxȞBN9fTj~S`VZ&zgVʺi `̥s UCF4a0l_??:Z +M!fSLPy=TE^*is'R`XXo/RzBvlk0y^ui10#k j+qvNuOoyk x<&lܓj"J?d*M)IIl$SAL֏cS2_/o#x=f [*6(>0_ȟ_'G#|񁝉9(f+qpf (w*Pxc̾GW@gjU5v/}{G=g5<jz04rDKӞA`DLI22_!XnRe,Ms泤|f 4ofN/J>YČNF_IΘ1`N(+֐(FǩzJ\~<@la5Rrf78An@c=(}L1:v ܮ& 1t#,G\0ߙ{?pjD{pU++O!|m :vq q#;jj#Crx6 C(f ׼VsPi|G"၃x#օh  `%o ߀ lВB* 0WN ;RzOT͟t'Gg)+U9+[TT 0Wm_|32V|!@SAxyqkx;fI2bNBmԭV$+`hUmSG|/ nDrh_h|B<'( \kQ%'6hwʹoccrC.8x0j-0Qo.D435&(HU+rĦsݘx> %8?9H% 4)#2Z֜?bE>~E.? l قr8zpu>p/y%b/YT1.Xƀ%SP{34@a?INfF`]3K!xYkt/WM5&:OnO1I4]n? g խO2I@ӶI5<?{痐&)|Q*]"u9=\K b~1vuXg~%Q3I u8}wrhȪs#I0U^%~eE>XέՔ\TC oEI E#z.p-:V0Ώ>WYE21.2)i@Rn)е⻴)Atp,7d{%H ˺@$yb192.1Tqlr ,eKfdOU2|SNFc< 0=CBp]= "$>x&"i@Qo KeZ>8봷Aѻq&(2NcCB<<(.lB m^ (SLa Wrpf9?"p_Nd/Rm/X1z5Rx]6"s'%czFleqjRA3: ѥ ;|&~~88[7ػuFwe UoKWs{]>`vVB^]Ws9vCP'ZkPHCx,<G 8v i?4T2pBX1jJX<qOok VxaiЗm0 Tbw:>Źpb 9WC=\݈2%! :Zp(7 Qٯp eX0zSjg ZRHkPg4d,ZG0Ţ(^=ɱ"z/zby"X_Rۼvx?^W|uzX`wB,i?x#эEttH,Cx[_ Q"́pD_'o tЎR%$l%<aZ2U[D,mEz${Tgi=&-]HsUl& 뗪 XlZ1mBU5<q?ZCLN#sL ML )Sޏ&Juj@[<2KY [$g5b5I l Y}b$95k2W]nz)תm28 S0fAWmI-YaҷV7߯ c~~+F(ڹ Ƀ#bH>X+EV4F`~ 0U(;We'n_U8nfłYy3^f  hHP:8ҥTedwGHWMҮ+]U|Ўacѣ1>93+t|G>$0Z)SXb FuG}*])Gh !zV=046rF8~MƟIPEbO_y@Sc qkgN: .:EnE̛WI[$>-Lm7ϩ?u3jAi.ՔHBC97#*؃ɺT*) ?DLPP9䎲+qOZGj~7Y5h~YŌ?y/EMnrC?Em ~*T99{й~Dbm@OK$eN"j8CJ^_ Uzeς#DOᱞKR4x"$&OѧM W$!8 )k༪[;3:[޺/YDw!鐈$/#v2cI<3%2a4# ;KC]jT|Ib5뷝w? $*"PCv%揼­3(F^&j~]P j#P_o fQt='aP}CᰁWdvU^࠶wzBӅK<ۮԒL}xA"YA*Ö+mA 'p9--<&Юënfv. D22Kό9 JɅQY$ 7 _mbL 9Go?)2&V}[RqPx yuIM;oɇrFHP0P*$Q(]$&<|"G\HA`DN5\BVzI#8j 3ױO8n碡}Of]|-xAMcrǔ9Ɛc"1e>"JldKClXE⼦?:Pb x|oR#Pkf0QH:U@F*-QuZڊ@ i֓%}O#q"S=(p-^m4`1Hn^ C>symKFitC`j)hn֕B5椵ϩKT^ŀsܦ(z pJݝDP%V;59!v*6R$zvJʆDOn*$L\OFuyd3\OFuz DZ<F.˵xs @w}O!{>w,Dw _Ta0S8:'K9PSM

{gzOTŒnc)350Dŏ.T-08%6# KVʉ#x֧mԑBgl3I]M[r"Ԯp܎ʻX!kddis$2k uL?{:ED~&{|#z:k" (Ob-9;/sO܏s F3Kj6EA^& 8]?>.A=n,V:m91Xm8Cz08֊FGFrk_ұт?1a妬$Nf; "8X\tR"8b39k #+] @m-\Z%*[RU58DW mfyB"-u=t\렝oov7>/<Dbi89s,pzBupmh+}–ֆZd $.c!cYQ0A2LǣҴ\`#\ #?6y[3]זS 9ϻ޳G} m(ji:׸wg>5^C+|Eyz]&' TMİu%\dU3c* Vuh؛@ZZ>8ܓ`Ptڦݑ#I&s5{63=z-3λS"i^wF^G}uKa~RKW#E4^c,m TE!NaaD]M~NfFYH`l~ϼk[,|/ f& {RzӬ`Oeo4 !ɚ"œK*%gxړz|PJcy G]r/ ķnsEe$r e^Բ-GIϴ[ zԡɡ4YNN]k0Cahԅ_rR;ޚ:\97Λ]7}ylwi!)ǤHBjT"6ӟ['5Gq b"jH@[󎃾 `nNnnkԺ\`C%*:],`q֙Oۥ+" r.A(qOc{-o.QjeAP_w`{U2 j(uska\:oy&)MRp*YfJ#vo4•csCf"S}FѸm /T"{v);h[-1H|P5ru@h7utNBB(n:|} ٌ{fa0W}48N0yYʁBτ Sl^;ԢtYuPO$hr`Fw (6F{A`ur aڃP?/ϹyM]@rmpgZ" fh-V(3jֻ :?gBGLf -ŐP|_}uW9[Kw}BBr50evDc@,E!mv۟ٿshKj 󾙾l & JUnԻjk[!<}3LL6;(h <[|dRb6bxyo`%#ש7kIˈF+)I5?_M]F vTh"2]4chڋo$~CCt 6[eٔ1G:ǽ9mF]BB%HoO[Z0Iޡ# bcMP^]ܣSYT#W8^<{҇=!5W|z2C vaqɁ _9Zៃm^Bs5 ,Vx."8&z3iNf!Seu=SEC.HU,ռMz41Z-^I~SbSF$ 9worX M#Kk: N4`~)c(4LA>W.<ۅ t ]ٷ |-4'ʪ'mOA[-94.{X4ҧ sК@K1 '\G9$Vkk/ y (wSI@yCQh\tDŸ̗$haM*1>B.TE]VAbcyO3BGXIFe`Q@w}JZ>yTdDF{aO#BVKȇx@c~ڱADfkc?+$==+k<FGZIKBe1,4D̐U\,3]=_ZGAJR M8;R 6djp Zl6^2$H(!@Y+ӈKLD^(VM>Q5W0wqj~G/ ւ"q:%Yy9S$(Tb ș!%7@MW>[A0hg[O}peh?ox6C,>7Ȟ|x44/S3Kw;sǦ"3Yp|ӓ"^e-9F.Ï2<<9}ІaNSE%6G)EPgeH4%)ګODw?F!AVkME0FE67֒ A F:LuP̮5U8oR@Y$ f=tաo9j[[It]sfBh!IC8B+iV}e(O$'8e ҷ~VKuZjKt"GAGI m'*Ze鍳r*T~MZS>Sq3 JD[ j% 2J7S2EJ*j~D.Ҥ]>~#R5y3`8l<Zc[=rqk/,B=vL{a .4q\7N GAA;s\iffOGrp5USضn%Z;ߕMi+76BJ, q2XT:Ui [¯rDs[%vZi211VB^x9Q% Tz^f=0ҜP8xs3c aE.15)-X!W[2/ cR̭{jcsLlhYYcOd":Oszɥ Q'sNL eF6lXw'{'1ypF2R)uˏqw3@#dD,&2yc:ݟQCI!|~$eJ %O[@LD=-L=I>Qw/8-Dě+u/g^N&/BV*¿N*s?v]U‰Q "haKt/+@Vr 'ܩ?U1ȴ yF`n4O чt;?|FL/#J Di&L35vMϪ[k}+600}mSFɎn'.aD^qBJYD6a|ZE6 "zԍ%Rc7v\%sA(.gIu'Rݞ- }9DCyߓY].%#lm=9^ob=" )i%$Ә,f.5-x8q~naYdkdo`S2g|j+e@T3籂}6dbB/kԉ-')ɣܔgud>{}b@IH:U}M-u,ON'jI[mHxeڤ,})@G(;@n-̾k4F=gQ= O8ZXQܷ1SޢBQw/KxGYȨrR)е%GfE{?k*5F#'qYP%S0=89ؑ!VF}]X|ɕW/]${}4a2xHIϜnUu"=#?~y*[7RHF&4^3U-YJp+l'ұK9u@xƊ]WW+)?Pv";F:IOZ@UR8g@]\;e 1#1:9)zHX;AVYl M 1ү^9O,BROeNʔ,MƚvaDct+j5YJLtَD/+nrSNZҺ;$)d@n3[AJS+g A8@=pW]&'Yb Jerx+B8L?">'=t ܆2{$:必&G¿TXv>_D“rH@N7ZO8ڍ{P.J"MjV|pX2o82QDk]*o8tPnx9 W JKB '!j's"r1BA:TKc./%姿J()ee~hEXׯ$8H$K k|>Sjh|]'uW&ZҹTY<]o"&>n7"(lf> Hhb4sN))Sw atg6ϬQ/**G'ZZئas0`)"źmf|~kh4&|8 [yFjafϗ[6I*^HwwVF./LgD1f{ԾGȶm"Bߚx & :DF[>'ҕwDABed]HF~u#*I_I=>q7OK/h/#=<kW3wpD(!Pu@P47g4b<^?Gnwlzc('D)ɗ鄄xpvr _ ( eE~jFS#U!8h["p#DT k\!ُ}8zA@NR.sS>orG˻Fn9l]sle;Q[_vOmhXᰡ 3JQ,ėY D$کB(5*X!b1.34-)+ӓGD5!H -((1IIz֜n:r i=jf9E*. 6>oVg8WN7cqZP:/II!-ewi6LhfIщBCGns8RjJ%1COpE }@Tg> ~*S(6ALKKo ,7QBrÖK󣁿P7/^JVLK>}c4#Y*v3E;چ #͸IV qA-ìl3SMj!} "EtZVGW'AcZ '#x\2>QPD~t3?1 m>ì>-l+FL{৥aF1B^jfSUPo Iw m1@ D6l"+?UJy|75Oq q9#X׾D meR&a<ܿBDGBh\-a2'n 9:Qv~T=yY&\DD2@ɢW9?.VC}^V[RPP%F*p4yƨiC#2MD~I]qZ&APHz &ІZ6ug KQpXE{̲1tc2]*Jk~:xA@K(8|^߼{b柴@l_YߦSstHP 6L=dlEdNOQ_(G!r뙑lGl  t,;io!vbQ7[g :2tfHRIw;8r/ny}fԣa[x|,h8xk88[ڶ@)Rg{A`RvsP!{nD+pjb(ڥ%r?l'ool:ｺM)0ZҰJ~`ԝm:͗jc^iļ8#YTB@^ G;$ <5-R1{GJmZ~X'7=Wh`m,Ue[ءO׋-ceO=at:>rޒN˞>R;'4> b< @+;QD/ rº4 Q(@9sI]C]/ad]E|:UeĚȿ(39Tc278c \p֑8e84ZZe+x wu@3 ?UgdCI8 KƶqeDKE*W3gpyqw YzSdzG, U-J'ېtφoӝQbL kԩ<0ӈ͢ BdVkz)p񄀞Щ$!X.D{ljsJ`);Br҇"S"[4 hp7./?]PdKl/*+n0UBj{S;h\Y]X0pӪ5ϵktTPw,~Ly|ęS/126?_Xg=~R&麈042fl[v<,elP=ת ^a[Hd|W"Y]^iGfz> RIi|!,~}-gU'y`+8_59vgFp|]0_v^I/\Rg$5sr ~a5θ8NZ2AEUs֮7E;_}6_T LW>w KYGh|aL?dڳ[w>Z%Wtc[IoAMݿ^JqRMt&yn[Z.S49oJdQx] 7B{Ǖ~'cr8yXk.r X'՝VX{%H+6!9&YxwOwCiѸ /S>tUi58jw~5Y{G+X}@R x@gJ_+UUG~/K %A|3 }6bMա_0BMZmȣktw)`5# @P8C W.&ŁgZ!ɇlso}子%?UU>+Wo\0P=cCB$e] #lr* cn /v0X5#E_NԊ6.dٞ$⧞*f3T. 9%  X|<"'p4Qsiຏ^Ǎ>L n-r|͕*780iyLD~?Pov{& ˃"5 o/uy<(@ktLAfeWU~fx9VX8f )el!S #6s$_D蠴JVaZ)4i?!}QNހtXi,5xBLqOjZ @yi˜X`:4KH`U=;&pWNE9<.5l`,oI`?b;BfIv%Rfõu-?nv"=]2l#diXPVdaۆ9n x"gw2Y=nӮ,A2De\ĎA[,)664H v,GN`2[{lF .d_wo=7d,i$tSH4 Mtsu\Lȝ*E%N5xg"wu #w'' j&j DИ>hEad2z}\8mLF6P-| ֥Ea7qBY" P6D0RI Upٌ?\{g| T=ZrK$72nr(WQ)NXk2:yk̷o٢x?c' .USI/sT!wDE9+ԬC-{yGjlvk1ghKy( ۍ.J0y,P ln=dn4c(sM>F^NUvil+‘)JIC[a' xg6 ތĒDܹ&f~3L'm2dyGDh0)ugCӠ6YaK>gFVMc%uYc)ތ/̿ji͢Xac?elՓ/C%qB&\0bBudnͺW> 8 26ē+یg||FC[O {*tViֻD*<&NN#lj|Sх&E4qMAa'bP IѲ,_+Iu<Xa6B ]HGVאm8r0`w0V&iAX^[}㠶Ë$)d-@x+ t iedbt!J|qc77׉!5kZL8H,+1m%?3C"9v!kx1f'>Yu_jl,}}5oaw=y-Ѽ8ySSK@Rw_*Uxs{/U &sV[nrS (c@`;!2)|?>Q? 4iVMGS,Ǿ٬ls#:/(Π2+=CSq"`(b,RutkX|GyN,pYǿ9"c)4ī܃pDx(V >/Zi^\xL543aS<Qm~lAfH?A;eF6<H#AJ@{|*_ȸ|2= mA2ddo N hqKZ~-}uvp|{%[ bPeZMLRfZ_$i~Eq#vXDB_=P:ZEtG XXb5 QUH u#>`;pc;-KwJXM*@o0px?w qu,"\RɈYOWY1A窹}&sݶc=SG5<{ft[,Wta z9°+Y=/dtƘ/yz>ԥN_kP;ͽx<9۱ktCJDŽ( ZkV3@ X҂Gڈ\p&]kT+eNRFKF_l6]gbKg"=G3vszs9EK? =3EOmS?Æ);SӘ Q)5ZqMCJLus^ ڳ%?I<o M9򂁌u$'Dt$9Jtsgךp}ӳD@$ˁ $A녾R)c'=|v} vݾ /|Ai 6!O |?.ǡa KL6| C..ԆGxT$59VG9 2/cԠ@^ ջ_^gD1%%Xx}٣Q$&OESΞ:_KJKeC?<d v,TD0FzzH*I}\[]4Sq4 TL)̛!}t4k-Ҹr"mE$o`GÑ-AyYlp΅(ثKqIpZ /j~8^I{|> xX Ɛ5ğ9Ҍ&2|vXb!1I^D[\]qG:/F1i z;bQK^,[#ښz}uu]J4~N|3iLp Wl?&jN!ڌw5iﯨ@^q1dXF$8ܘ&\޴|K.:Z\fMIR*hTWF9P'6~9tZ`Īptgw<4k ~FXJxvze~KdIYe&%u7uP^Q޸f?7`f DcG/fvF3Hlh=o !}QևnX(I LE nu?9㒃f )N9&CN Tio.ro!.=5=|Cj$%3;*Tyu4:h 5mIGG!{z~Zf~N\.r#b RjOןp2-Ji+olC Fˏi{e#c-zGu*[ X|fK`8),|ĥ%9uQ{aTYpش󷏛//{OP{ c+J*'yS+D&Z"_Yys[:r8 +7$ȀƆ.aL&vlk P$?zRq;uS᭖ZծLGcפY]Ks,PPT3o`K),|et< )M÷lXo<ꔅ^-% 5E@˶{CK1(1ud 2|"OQ8yIlwaY5N8L*{tGdP%IuBHs)4%" |&w;$}\fG Q9gCL1B-@; !rc HMOh>?a`/s>+ r4xN8tbI;r輶JS$]8q$W ߤN0:=fa=x0j g.‚^Hʆ^ <?KΊv %<S.)gHx.ê|]Ot7/{tl4F:b-'-hc0y]2MZZ졨݈@l(_ smC-kN}ڲbTlfl(:837` -f9ٸ|1&אw}#&{`j_ 7H4lg{ܦ*l5jL'BEZ #h u2:ZfDld a 2,M`sR)gmQX✪LBH׎#|Sж.]rӎٲO\P=5'AZõo]-e",{u3ᱷX\fv;~Eil(GTQKB8)M5~ڲ- qZ>9q4Ż^4i%>jg\_dbI(>aFV.98cyNzуl"?W" M>a6η]ɉ0 km>hۊ ]݆2ϥā4 SNX{BUi'W᫰|!HcZLQ7NlCk}VK'A3׫1vDY,Ha5Jmi4b7Пr30KYUL_ ~6ejEOR2_&u1nâhUu?E-%ʇ&-(c.¬&_3\#V[80 U>%̼tH2Lદk3`BXlcQ hۑ,Yˀ!MKd!iE6M29aoQ4UdM,ڐn>p0@,P0oij/>wT5 {R^<.&EٴIQH>g#v% _?MJoND~HZ1|9%^*<ȗMq"`FCK4& 9p|B1!],yS|@W ujƼZ_ d%@|aHC o,xɶ "—D`\HiǦXKXݐd( "S_wS^BtXyKOHט2yǟZU X4Q{9y\3F.(w-fRK΄.1f4b  p5x0(K ȶ:/ԃ,dti.M!TS덹?uXx-G z>4L"h{oVU$nPrT a>?7Km!}!%D$0,ŬgBx q/-Daw^Wygmn&e P |V^ayĺ:w )~KNE@ݤtɂh=-}Iچr-!\Pk wͱaxa6M5(Dv8#z =V!Ap;UWzנZ.s0$ c ^|P0cYis8 wJV0djFKY}S\9/հ,|\l\w!EE&FPAf<ͼB!GH*c_:[vȦPBW{]s5!A~e s7Gi.5kKY?

1q PJ/ +~AxTWy V0 MHHРwhAZrFہ3t$̄?$4th63ꅎlN4i Z]/LOүns:nK7!E9 adW$-2B+}h~@>-;7"c&L5SV+hUl07;B^06bYx7շW&[+\q7l>TF5}'8ii8a S͙v M!^?k9c̎>}$MBhE6!L4?n[ ΋STq` %,©?Oh|׉N mJh Ym-i7y:jfe?Kvg[R{'`?{^O޴rcp ˢMpP%4yM67%x-x.MW,x[

X{ijj+Rܸx#Q=DȏXhۥd`s#D]B==Gv,9ޞ,TT^u\o3Ҥa1Zti\=TS|_( C &6+ooY{kVR Z)ߦ.۳_u PP?] J8`=u5Pxe_E9qOiT nU%`.L<8ěBq@wvv{_ ZD8'!GuBco ^2ker*8>AWZXl<hTe#.(vbEJZdgohZbݯ%"/%dh[t= t BsUzWJg; T6to#9-]A$EN#}]>N^9>'ՐLŇS);UdCEv$NOzhIƼU_HݷiTD+kJuiRBQ:E%Ã|Z=JFe}I?lNmҮQMPXBZ(Gq6ۤ[9%~n[l#HfiƀE];wk%s"fUh\ 7Gb'iU#-&(TSNѤ⻫ UkrJ)aFz{+^|1> 9toʯK .O]jvL;LWWN4wr2ke7ro"][6Cde4DvVQᢒ1뮮;z܎xVe3GC!HS2$QH졲 F}TXPJ#)Pp.e˻emݱ(G3M8o6,K,KĩB &}$S.,s= ܄9f蠺 1_V-7ɮS[@@ d"j"q`x }(':n^NѺ.EQjJfOQE. K|Bm_Ҿ̒;ˍdk.qv!dn0Ч?;iqFgvyNO7o:*uխ9Ԛ2kVnT(*0'#Mb7zGh7znS V%cC]9vsB0)t4Ƴ2>Cs5,ۭL#-Ђ18<cVLmje%-ѯB坚(ՂzPB nsE)*T`u&(/$'tt)Lm;Bhc|gVqME8\F)諑V+XQԖd"^zZH8ŋI#t0ٖ ר&ֶ_]uWMd%?D_:ROP<'qQl#, A^;AY:' sA,bAsx6{ ptr @qOwE̚(KdtVݟhUKx3>gX$Z#*{,t cNF:Uҫ8b`˴lK8ePۗIв.,u1?*%|p䵌jby a *҆$J{ e 'yigITLMYE5w$h J\!!A A>˜+SN;dʊWN珬Jt@S7G9,O%;@>ʜ*Q(1F竩 RryHf<E>Ϛ5 h2Yf#X6.efoNV階zWG2Z =)ʸ>}y@Q4{dR3oVdt_ y[_HRN4jzζ &yP<+ti7zcO(B߫ZqgMbЫ]6}3s`5}kqaJ͂&A:gaîNe7Ŝ)yFmR@۞F6j>M\W qQ̢Clox ]+)dҵ @jKNXJr;'ȗV[o\Q0 }YQ"@dȶepGHr{+/>l\[& bL_.цRrupD 1>Lz2Uq_6Ov},g5vZ0n5`ow*vG出Y}Lj7##p)!RUryaBIfw_u 5‘ٌk9d/%k|!iT BAr1XC5G :r!]cNXmX2|7UIE kB.HeUFm}1s{ˆ ʅd_we)-ux:.i4{692>IR-dFb˖;-g뿖g^1~ ֏K̋N}z>c)QuE2+vmS>FT ZIՉ% xS@T؀T|E,2xd^\!xqV UM2E.Z`tBDx V00&x(I}9=$/iy,=[ɻlhoT z.Q*W[%bAɺ -ڡh8Y:y}mE$<> lm_OLEޜc]| զlۮ8KйґW+?ieG8rq=%5$SL@kv(v#7nƁEVrml]]&eoǙWȳ;NW@Jv뵼3V&*!'ʳB'aL [pt*ߐtItԣ)%;{ Uݖ'؍G_3y YLڱrr{+Li\)-kn߅n9rFWA=LŸ`Zf_cJĂx Q_#OBX1ۥzbsa6 dz[j4"J՟E#:ٝ降-~'J4Ku#?.~ޛŌ0m?Wg)L_K!kbkwԕ:HAGCk)p5۰ mI:E 5_WΰoqC_*w@/>9e}lB"Ă\"[9}T״O pzgdMRh7WD7-_ UV]zFuwLp)ՊCC- %58\y88bi)1+Yy3 dr Q͹عU,+ h6+0D)&"-Bͤ]{L^HIύG'ŷI]w!yMFI&?_S1dx/EWT K-N=Ա;%3'IIў0U !_6Y~ŧH΄Tv9Mrt!<1a <LBG xj ̾~ i"dZ t4)C @ЧGf3RePMeޮ䲯th'~Rc]4wKP5'"]b€hKfQ&RlЂڭ+N)*#[szt7a..>qTO-$DOJ@W_Lj\J$myQZMXn+Kr2\F*W-vn æ?#J"Jm{ɚER`elAG~}+MaM%`vm Iu`m_V̍goÂb 8$y) T.hdIHu̚Jzb{trbrJ`E(ڳ=x+(pRn pL}zd́n`/{\ "ی/zss +F/ nK'$M[fXaoeu@q&$@ &W;\oQ{zpR}У%5m| fA]^X/:A%J(P(GE@AD'&!EF,˝GY!] E7Q2laHQ[ⲧQ22MD\!=ÛS-;~Ma<}_?t>Vx+>lQO(mv RgQ}(d!;1Cn/L^[4e HF.x HC1;]T[ǫfeVvN3%_6!l;LDEulHtmnlAtGہag ΋]dz %Ց>t!֎O ]|;[um%?tJ=*<1*8뒩I_\L3@(x 8`vfahS41qQAO1Dq5,0S"Z$'H' 'Ψ RX$C٪:휗(,k/q͒)ӷYjBCH oD`d8$?jDj;[4jh`GNUbaWhu6""jv_VJ*N.Yh'xK1Q<$7~4xfQ-L@Ne:L?BjN!!5dކ櫺{G~n~1+.7b=yaSpSiV( GoAbJlӶ6 &zH<$ $w%>Z!p9]H7ALֲK!'δ}?wμJ_xO\^ e M}@7&K5 P7A `K|r^ n Bf{zI$aV.;f y^@)t*tqg3PDu~}$x?Xpsb)3rcud(@2&p}f Eo*IUiz%/Yg6oX c0I%0:$~1_G/$Vƶ!w;#UUrV ird٘(ky>ƜN_P0H\lʇ elNsLi E+;e׉^#8)M"ʢ|d-`M6[22i2H6 ESEw7T`~I|RlWKrr4 $ipw oؤU v=ǒbYӪ:iJO eA̼t.tFVV> {K׋)fsD>%F+_+D&uw/("iMbNLp׌`ok<m|~}"2N<ͫiO P7 b^A=Ȱݷ)࠷|GuDS)Ut]zr ҃U^:u|z9yp-e׵_, <òutM|4PZijeBT3PL__ŀK Oc$%ݑbABz=Dh feWd8msL*;A od7+Ë5κ'/4E6M]1rrA+7$waDZ*'9Fw`/e6 l#9) ubj[G-_Oəo i* ׆d5toĜ]%T懓Er\M=`0 7fmN!%_g"z"Dp }V_վ2ejO]`Ӟ/B``Fs= 3LagTHr/r  ~;O]j/N?J_+gm*&P,c,ER^P G溫㘚 )Ii<͚v+Hcyf¨bWЗIAOjU"Yuȏ rDC7M;1Yݰmb_&ϬvLLx{*O|MCaǡX A\,:DOi[ث IɡZu0kA9'0FWWh@6z= J9 eZIǬ( hSX_] јMY^sI.![f 黃Qo'6!F]"iR]7'7b.n°+E4.6?*X9,ir,ӥ-أv({5g.7bͰ̏ݙX9i^PozA_C':\Aʅx]%O<lg\fiVt;Gi) AL#*iDYVB޺'*3ꛦ1~JVFQ|>TnWV1DuWגX f _Xn E :CFȵ9H('/G:R_>,/mHsM,QnF≧b|7"i/~o魻 ^ " ZR P'iqAΉDXדϘMY30l,SVY8#ohغJ8n| Ws$p?cZ 6C :1S򗱒OD` #VO 6&Yb3y@!*R<_֣ߨ*k7w>$%}ԂŃ wh!f N htȒΤmȖnw&39 +1jJEhI| ۍ1Τoώ\6s \LR|t<}VbDڣ˖OC1h!b~8^C*Cԯ% a")\mb>Wť+?MծJ@E99ȵ"z cZ'EZ$w5Tdph^TR-Ok%j  t45\??u^z-v,sL~D3EN*7Wc- |J.]?L.7#F}) -4#3vTy\ϝѴ'uc{B:A&>x[6Uhٵ;(]>:MS^^EڜV}=j6>hS? p?i);!+JzY0\ƒrQ lU| |:%@pІ3KH@JW#Di2]p}1 s0pU;s^ֲ'p20P[UEdLߎ<#?> '+s Y pzU}ކRӔ!q!f`B sj~vClmI5 kY@P /JXs~M./P ;i,"V3Sa4;|4X9%;rYWB߈v]3^z@8A][z3`9DN6+質Bn:%1y塮jT:#|yG!rTun)x Fh"3hL<<ȒزW&^3? $+.W,Re`dTk6߬`}QalpGR%:w#Ogo2Zs5|} /۴SIax++yK#ιֈ];siBK`O@)ᬏTDPVj44/1ze=*}?FrjB++Bgq6៬Q J:X_ԤS.$௦ސ:i_dؤgk8{CBfs4V>[bf Ovn _Y8u9Xؽzd3 [k녃`/"-\9+Uj 6EF WE\Ba} ?]!Hd"֤wߑ11mLS.:yP'!OL ҿ[BOe!!ElX$~ ԹߏB˦&CQ|TpJ}GwS9pE,0龉2KV^H`(uIGTٔǴav?bBjlQiy:{_ǘ729V'7a_D*<@@WRQ>O>A@[j`\4ϊawۻqk>{gsonI d %\ZY7*Mz5jaS銁ΌGڇ~$V+~#AB0Ŭ"dž5lT='O*Y 6Ft>ϙy s\"Y5.Bef=# /ʼn/#qf3v,6fh[n#T_XТ71k'ZXh9OΩ4>v@o~}ޕv `?<ɧc<2dһ;T&4K*f?V߉ףb(/RE'w !k^ WA?#R0\M{-!Lj!Zpޜ!(3lQʝ3$&FhcFU Uĭ!2S@pj7.@/Z=Dc̻fH*\Y97kTSi Mn_aHKKBC`9qiUȔJǝ^xgT\qۨ<(qG8QoC֗C/:e\멗@:"2/t(Al-rmimE3NGS=Mu VU4]=sᅲ: p>qc|aqTta]KɮM2^^̀iBʔ+3xw)T*5Ji "THV9ƽ XF^Z!0%BrBej9G&cZ󅑫`<2ji _`* h84HI1#6H4' AG>_~Fpq3 zPb =7 ok1𗽻 Sa~i =撖25{"LuUPJUa?7yl3(V/,ynYmlI1y6 \h(W(s:*+9:ZLHΆ ١RM$aI9):K>h]}B*s?SU`;࠸,'=a@Y[@E)*\mR'lBOS@ ]PbDg"bF/}An}=a23^YP!4gRB,H{Cu!ymKZĂt?Jfh Pˀ?tB-KhY* m! 2ͩn#ƕ=6(׈n ѼF੫6}iA<}`o^%iye"_+jJC8g8z[!|itW9j~\: =>PT+k@ɚn=Z6.遖*G7Gz(=I:7[=T{IfeW$^U.cVI{,<2>F[L}H\we tC~4{XLF:XBLn2z1&k˾(-Jh |&ϡ]Ggqv?EG_=y뒖KK网u\>!|'  k͘$O+JuD*m3*(:{k0. A!= H5_L^)noy 9%ЄSE_kPٱ/,7/=~^Ho j]2^܈i6JwJ2J/ۺ9t(Fp,HL9u'Z[jceʆ)%Cg_k~C Gzi,Si [+>6س̅;6'j0=qKΪ岯|]4$x㢫@:AC:p^}gg./` p[1MBӐUw3i+īupB.uܗcL*L1pWgwE3OE>,2HDsM\rĽR E7*d%@(V2Eҟĕ c) fo5! ڛ)ngƈ 2v9Π8(W W-7}RƮ|&>֩SS{/0+Q-#m-﹜~ӆ{d͙dVlS_hfʳ ~Z M.bצ3*#' Hsl'e8s{V<(LHúh0iO^ľT 5 Yip$V&%vӅ$'ɔA R<𡉄H+M~N}8yꦢ WbAFǚkbE4OfOx3I.ۓ,_G92egՕ/R!>N N^s8`)jvKć(afֻĥ;bCIFtp " [kzIˁ86bsBCw+@a2.~?ƼBS0J(d<QuS![F^DD>v@;lSޟyR gAُ[޳u@6LGhTwD/;wۖN45Qvc"M1$DCx-:\ I^:U)6A^U3/rV#D˙= "sai$,dn>\}4XgJvևdʏtT ?2)< 1t6ܔ4\h1M#3- y?^Ejd^%^aQn xebǬ;~-*1~U`K r}•v3`-* z; 4_s򶖑v, wF1nTO"b9h˼?3{xSP| ~ #'GC|Fȸw\*lz Yt_A0oz!Ck ! 9 ^U8#9<ֿ젟kD-lo/y]Wt$ЖE+/1K{6/x^q=;~c^mⰔ]>_Dt-̆'~/ O|*[dSTO3ߥEV;-1wxJ\a3G'MUNJi/=-I{Q.xȃ?%oP4$̖O^o?u*aTWOk&evZy_A`]etٗ[z@js&w1)ںpvftM D} EYZy* wOdI-ƹ.UVyX_*Jm[j־=%^r/O%R5C!>>EPƨ4rs.*OGqWt]9r?mg1"38jj4^L..Q dOjc%zdM)`G " JΩoHw !ǭWe9,>ʨv魋bY7x|Hk)Mc)|MzWСKZ@kf~4*W3y7"5/Y-Ghr,Q<9YjNK(y{m HΎVP^Rg i/#r9O{w`GQq0v^c;ad㇫SٕwG4W3JscjkiJw4xoj/６QqOGy[9HCAW߰`;%xO_Lf@(c,i JF_w6FVoRav^r=P)ݨkya2D Z@hb`z> bsImo8~^xt/Sn^6B,.LXIPoeGkoCr_Fz3O:F~a$`1 $7zx9eɚ뎳%{{F^0MIw'kkF)'/S ⫮*g}njۖ缎KEB T^wX ]N"<[q̐f_#Ӷ>A?iYb&5!j `ٸNwAqtWoW@:fpGg9NC@)7=*Pv^4#*]վ'5c\c `tO_[EϦae[WK{w}Rָ1њ(JP lNĆ_pTFIIR2bsA"*~X2yI'? /~rY".yP8mdwA;E0 a˟ NY’, v cU,e]]>eB#d꣏(Bb'c\ޘE]o)y Lm*'1%  Xt*| "gu{z}2p)cZ%$ FPl:?~pJSȯo!~sru-m=:%B4/Y?Z30=d]#K[\voji/S$5GPUЮUKG7lȊV(4eA'{$|m%coXlRL1&8J_?J\o%?~ +|hE\AB Xl_~N("7 q'i?gP[yX e$Ie$؞z͊odԁ&Y2_@7E9wonl$)&JYj6iQ? 'cHJ[(h+H]J_hs&)*շ&xMW:7Hzj>R,}:vS.-Yn;~~pN"4ۜf$:s+Pʚ7 0+sO~ cur{k1?O뮡OH^:#e_6\?'Pl0(9Z&\SDBNŜ"`FD4je;mhK 1V0Prpt%b\,%5/kYʪ+Xm#''5W7[KabfЃy8&I}dUBg ֨t2'z1?m&zo(;u,欁y`| CPmQe_ٝ+"%лګ{!"dvD4ֶjc M{aQXG1Ne68x̀U+r9T0^6627?1†e z6 qiKK'HX2lY(ڔ4bnv< x[} 9#M>N)!>jě;R{([~O-MPD.::ϪsNTHu8pPُu(&;ӬR뇿=ABmYʞc'3'UMfꂫΪN&Nd\>,Im S՗~[xCT͟`{)>?._8.fv*L%?.eUpH[s A'Aw\`j#)=,Z'X*m`'VI'i8 dM @^K3wE HSM̟3^^@o޴9< bmFT-86-EWqz>tZ>'|CN ت)/~tUTy<Nm$^)4"*qz)A)V=[^xy(-SJ;[șȞVyhn-ܹi\|~]VI0\i}me]&&=+1x6iΦ#V XЏ&1Iq݈?VW#5?q ?x5 /P[XgEYtON9\(7'JIImP ʅs%{Cבn g:HOZrTAD2M9 ϻy(W~\Yᮾ?\E^L}GXN^G"̭c̑G-Iy,Pr+ߢ|s8m2bkBGh{"HX`P=dK>@&Pz|X^,E y!ğAϝb7\PalBl>Bnma^/^Ŀ\ǯ2JPN^ڿt jMhw&4Աo!_zZěEj;|7D0}Ka D ;_@$8x˴`cy%`:I@iF65)t)[eG(輏#܁F:#sٵ'huVkg#Q3T/useS6wU.d(ޡ P.+bW߭"W0}*d is))?14TzXtɞt2Bdl5"W>}eMm+! Vl@}c@*4)oz Vfl>Ѹ L>sO028Vk/UR~0zl& @C`sY 9f2P_.5xg['=vdF k)\a:a !ĺ-̧ F6м18ʭ PKYcUZ3>4W@gȊmrPoɟ0lkq<nB?{I1 nH- r8=ėD۞xiuϴW\uZyǫ{q  W䳍U?E(eD㧺k8 _FOZ1)Ku:ro-ñG+6IY*IGƲoJGy~#0{j+xdZ':W^g"Q 87'0 jt%@Πfئ>`44f;?XN0[:kCkUdz]Equ=l^~cVL{W(otdn[{%|j|ge&9)__^J;l*lELƖ_@+Uja3=7#iep-xS{ l+MbuevEU LW& rMq} 2v-K@na+#~^q)j]6caP^ѿ#e"b=}Zy=2 a[ | g_il#iU F Cp:L. *:Dn͗Րu旾ώ\vS liL5Z_o2kk|cOEF?(g r4bɹ [h=Ȗͨ%@ryZAүDF ![@dJsƲVcASp-F"߳!#)+]u!zqg^2/@qF" 2'ל)%a7Ʋ|06G( ~Cw&4kQ7Nf]&FcbU['\X CxP)QD_㞭rO`ÝF)4_"L0 !~ I|Զy$[#Ij[&1-֊u \@v/v )ld raF2/rfE m MMc5XH{(~' B,?3Ur-w|=e.񊿅;B9p h~Œ3LkhY[vERJè΋DGDmx.^PBaS^{3v-Z%풸b2 |Z[0~ Id:0! -e);G0 ^"FH]=9ӭwIZAQ%SMknQ* 0tC9_?ƎkQSȗDAUL NZ \go3nCr _h6X@ vJֿ<ڡ<c$@è8뿃h{XjQì|`YJx&9=a٭;p%s\GH]arC؞c[0(ѱ9nV+pRSYYY$c?I+-y9bc% Hy&p#aA eu|!/,zQm9\F+ICźEZDP zӉ ݌1iERi<ęWHn͗P?$pd*qx-Sx{獈HC\[X0n5JUˇ2͜WWFo[7pGCSjd uPAᤳi ~Yzw5hq#S2ؼeZ/X.MU(ӡ|މ 3+Yd>*9O5 !GϽp4Ss6\kvkaD*ɲ*\뵜Vd+_M_mbZyG 8\e[N4R/>'=?IAabL-~[?U5MuwX LxL@Zk2QoH9 % ӶEvd{eEZ9;>\s8m؄hnmpیdžL6{,P cHkpl{ђk[m/"Y`)5*-kE`3h^u^|ofp8pImLbgTO# G4 T+l zu/>7۠,(a)' SA!gΏO1^II.bɢrth]&[QƑFRUzj0#:"ѻ8d†ALke2{$1ެ^fG6W06qU W8n& ܼdyE 3$VL2Z<is`ݬV+:uƱR8+$r]xP!Hu]@òoHNݶ eޖU a̲ ,ɺ #HQR9Qbڲ)݂? pp00`LeyTJ*?FSZg85<"J%an )F7΍)3vy N޿(#MRxL6sЅ=iS,n?{j4vV:kx!{c܈Uq F0V?\eW3j ZVPc*CB86}3?lTyP JC>١P|gX6Lg1". P/vVi8R-*4]* *NgB)gdDuS6uZ}X( .@#桳Jh.L.#p~e>Pnigf*@;n a2{O^tvFA`g]rPf}(& T{wn\{$N4$zi/Wnnё;}?2 <], Wt>ŽD9vF{{!تfK$Aq} J{՛=%=6*g 6 VVAҥ[=Gw`'/dV/P'b{jIu(U @w;GJ7\dF8Z&l{rMEa.^fY{L):p 窖2W+gmp&m&j>08Wkg+u_x, 9 +YtE%7˯`sziDߕRL:~;гlK'"4!UnF]DNFAU[?o&Le p#f%laFsBy7> M*^ƥ-\K/Y:X.nбpF̯9*t섛CT דIҗH Ib4(G/Hnps(^/]G7[o8rnj*ICs 9O]B`!%ОDu*x 5>#>GDL+!ǝ@ǁMɲOqՀ{۹οN{C9C!GxM^!ҷ8|O#vALX:R~@MW(Oڱ|^s=k:{ yG.LLnfB 4hHQ];Ӊ3޹ ͽb|Ԝl/MX9G3Ρ!4rwF(✑]4 Cw;YV'ylbb=i3 [d[K%+͵~U%k;d*,OWMh^pcu[%2@vYLs ^{\m8]'icnsm얧7:[YwV A41l9b`X }5 UvfLkߣ(PmWG5{kHWed!Vs<|œ|jc\GmNA&}oZN8*Y]9IW\sjI;C+2jh*qCO6EH7zywwB+:jI~Lj-F5p0YALGdiӂu%=e"$P\˷sH>)tbfwxXFJ:H9ETSC֜zΖOHiXf;| 9Riť;78j`5w-L7BеbtnzL"-xڒʥiK("^t[ `9Tijf՗'Pg7=R !PO t $`q~u ]p]m/,#SNGgJ,!ظj4'LCsy! v9m/ 㥔^Hv';$ZۨLߠQ0+fOm˦cqd}|b/ b.bEg fGbAޞ\FML"@Q]>%%:A%`ɔ/R5t/Vc]I9`V ح;j:2mGFa#W%&}#wtSnYe+M(tCk$+0nehK&.b}*ن_Q~1DpY|!Ǎj$*) JP."&]^Q"Ee4bA5̒\[Ѷ`_DU$Z(Ql>{q<7 ^*L׳Aڸdӛ=Zgsώ*rYwX܋X:BP}~{%A +~5 D?AD4a#HQr;th 8/tqʼnC?%y[42c'#gQ !h5htfvgT(vdj2itTGPY>#8 BlPtH6 enVzZC/7\4b@v;0tuh(Js(fJ?Utos+x5,ςnǹ( {( ؈^A1+Kq88R8@-KYY:6nA7h -(eKUw,%O|&f' m q}Lu苧1\ȺKx/`2`=u >p{?@W8LI^cϱA!jSgѝrSx~Rn -RL&_#{R&h,gO/D f,;sKsr`yўHQnDՂd[NcɌUYӲe_v/H*gC-t^?rj+޳|GQGT!M+D_etqA0m~e3{gRd\} Mꧽ%)@S`7"4T]v{&ڄTJ6E]hRx%+ÎTglW=R|͘MA`AXq l5+eA.R[ ȶK>:q^Ub+ߍxkHk" n__a5kJyFT*&(TPLTsGEVZ:ah[gle|5#ZKOĥߔ(Z>X* ;yZdgb>e! !ZR;Κ$\ m4%aΉgch|SIvX(l<2櫬+=Y\^@IU1[=ҦWk{ l*Gx>,s4}g59wV7?b᜖v)i[Co}rafL$p)'t2c|YoG73Ӓ=kLn~g45hS*"|z!!_Z-<ͨK{?Ko$cNKK-.UZCTIc0.J]KiG7IV-%pҞ(} _35^ڛyn n ,̾aGSAFMOo3%Q|b?SkR&yh)yωe>:HRR5“2[o>3<~O.͚ƥw~,R`Ӱé~532sJ~4Po{mߟV@`Ҷ87D!_h]|)Br#*BeËb鵌VombpQ]x wia$(Ktg0F,6&Gx>Hbo,Ditxmql A fykt*b&8'" / QΜ酋.+7Y:$k| nۃZ+q3}ثq%8p23)8ufn?Ҩf" /԰ƳVp¹=}L?`M:w"v>Jbq Ξт`4"N @"…~HL*W@f %qtY <.;R̺ L$[UmD~=vS@\;FKJ@ maQGBӔFF<{iLpt$wp\M|{:Esj8hg&ZG|,t l6o6w#]HIG~j rb=Wӂi1n񑛣ZB~p#{YDC`w*%+v&S;&:;;<q~%}= ,^fg4g4شz{E̴3Ptmdmpys"E𮊍f#l"~3L1۲y}ie[J =)ʰnQ|(ջ,(C_@ub(}Nqҍ]>&ze e[<X\aaRZWCif04 ܳCtt4bGHuyǠp#o`ytHM*w*VگT`n6;Qq #S[(yUGKGk+Lx7m^,$*Ё8[]^Pt*WbLomZ:.CyQ|N8ͫgQ7 g /uM^(݃ŖvJoV\{)P޼k8AS)2^72!HdSWu?, ZsCh(q!T2Q`4gqٔmW#JdžiOrAK;[Փ<5![NDMֲ,ZtT6$֟\*P+]|.ȫf=Kioqݧ $BgwǬ̛Jx >>:,iJ @S_ e*WZ]EU>X/3DTٲL6& ]iQ9=j{J_[[bЁR_f fVLńI!o">OLTɔcp;.aau*5a妾"<Ŷ/zɵAj`C1T NL^c0 }.emFgmYRiGNd>4j)DaۓLPEm6=b9XA @A!hp {wE#RtT*!e^o%{8ƃ+(ϨX, +zB>mZ^lE0N)ξ˗; @.zwp+ .7.'i`s(_SΙ SchJ9[EXM˚>l rWEt/%4x|SP\rxkNR ųdYO?NNq²*Y)g3۶mQ K"Eߧzy-mgwOH+iuaxjM_<jȊ5 B;¥=żqrKLteԬu~KE<}bg zB3fuB=w 'Yr_Xsj/d=:!!Z?U؎cO Nv[)+\2F\_{ #?,]D<'i&Rʲj-yXOWq|ٷ9c3E^ɍ=!}!bLХBJ$+#{bB#/( t¾ fjv A}QɭԄ! 󡞘,@6gخ29H*KѲK+Nw{XH=Q !2nZ3WUA7&xc$6n3 6Gxr"{kPd;N{Γ QN{++P.K.rW+@ud4z:kćl= LM$G9Ci 6H7[ԵJ@ҵw9VH9b}Ў`G"(GkdA"D rџgU"?Qni\嵔zf{Ћ~Jk$sRݝciRp 3~Siwʋ0ٱ,Xc{ZN⥳0y$ 8 $=jC*GE_Gi\XPyWʲ@+lVf\1]S J_D&>9%C0q]ߗT6?e1L*Oaak71PTSyCl[#e33+YֆXB„AL}erAx-(eOYfh2).}&Š&}0l-vFӘPaW&ř!CLq,5w`ov_BQ\}?::tlP6 2Z3Ҍ?ȵG#k(%ϥI$f넂I0#.|9jt`Hh.o4$x;.7µѯP I ~:b]-g_>jiS\CߕVӖT pLQ4nw)[[DDr(ɵD1pH~b,pL¿7RZhHpGs^wAֳB|6/;#KW&ýTo8 `԰|LeDԽp1ī~Dbsdf/M]֮GoTXӟ{j./(9; {j2-~/~,5/c|ݎ8G w`CFfVϠN?eD[62Bי[ۢ5p.$n=8,iTߚ;I ?CPJ>۩yw>bP.*+ X RucdDDlk+E1^׮֍$Tw {}o:J_lv<{54˪ )l3ViE̊۹e?eʯgݑO,Qm˅>^&bA9qDCe%ޥE`Bw v~t@9aqz y9l\71eXލ>g&`i޿ysdnꆗ.YY%oI#09gS#7>ѣmڪ ~lU@/Lه5#zB@"BhOЩ̘Ug:tO}l9 `?^cK\_f'a.jplƢپR"3B>9' [EZ#*O'mM=?H>$.fвg2">4=Z0Yd@ V%q5c`!'KˮMȞێϫ7wy`#ǽM`ZDLh{ZJJNIyuGyC7t(LG5y8UHؖiWν:qH!M64V삣uѱR:dǓ&hx5MTbPv1ehze:d$?{|R0cIdV2V~]D2"\X8qF096֗\ƈU,u _dCA|[Ʃs^~c2*o.IAdd \E<)x;1m15 B4Eix}L8#3i-[s]F (8m7EǻB4o0Azٸ&.-$# t͒ѮH|J/0ʟ*}FŢ?02S\to 6D%Cܖ"nHz3p^cuaHu>14}z>BV/IhQ/&{}Чe>֥ iw7g7ظ<*f"@Qd(I=i瑒,ϩ$^3QwE"'F;>DIU)dRT)YU!ZxޓhT_ s rSLtp~h+^_rФ=Ax<b)Ŝw1%H5]%؝X5iӶ\}RHbkNviEͿ)NT@ip"3fhF#ztX6eu+QՏfBߦҷDCJy| `3-ߴϟ=.gƺ=UcMCNK#9@$'F0o2&$ iŲIˀ\~5/)5)X>pƴ;9B4 }AeyK8؊- ['86tVo=癇jr;$[ou5v#; Cżj5D2`mzBۇYR$I  IDS KL'+YyZ13xݢ~-%޴ޏ޺10&u HFsP~ÎC^oSX}O9]]gv(a4W+Q _\Grpiq=dkL*>eA_on.d&lT_z8"*?5_lSkE0;=k#&P8="RZYjQ#3It8ѵ_:5VbC1l|~y{GҪF|2ިQI({z}H= :Uu{}򲆙* Q ")SFe]ڰaB i Ȗs>Y"jXN͞S$u8ZT`] >vJn^sIŠF8T-(ޔ#uphCU\<;n'?%)$Q ̤:\< G1} P0n ŬyU!b_Pou'wM-Ӵd+@'8ghv5ϘTp sAy-oc83\* Za\'(b3zy.Ip8F]tCst5H+[ϘJՑȽ:R/#9AS]Gq 3'yVSkI[J* w0aaJ{ qtc)iwNEFaUl`XY__%?0 Y- h0ϕN''1f‡:П4WJ81Ͱ;CV?N(2xbm_m387d7r,Eֈ^k-6 Ñ< 8[,Jr0!T\ߎ*4ǿCVv2D_?LǦߐ;%ڼ=T=1*hC (c*Ml#h9eddM&EJY1J0iuy3B1}G|D:3O"9&{ճ4"` ?ǥ@1b"Vխ{_-59#nl=e17gA. !n'MT\ z $ Im!]RC"禠DILI{^qjAⵕaTQ?ޙ3 '=U-xhtgMX\D@`Ҙf,?uȿ XFm*S5 KRkڅd=;VL dʽxRJDS$:j`rIVY|0R(7c ,paNgoM~m+]jZ"YRxtCOwGeu4&tSb ve.SUKhb)*)ozhRHC0GJ*vCטY:K1P cW<"?>xb4Po3^ Y%ώ1)hXσ\ܰ[R( 5W-z#fG35N =86Yq.D)8k ]X':(Z\OMzVڹgWa'3%zM}4weY}8嶻hrnFja"}X6IŊf e!X_'47%0i%8~9[޿p'>pA [2SFܔ0Y z)BE=K^ENaˮA\h~c=3Ɛmy{e6"xn|_)[7E.0ijSmWA&_K+f_ž- 1Z30ΰl-p v{X }w^'a4ؾM4v A1vЀ{oѿk&@7@ܡf,{|X8aSOf0 )BdxS{PH5|RH,6 AaU~/<«D9N"=Ucq^ȃgR25[vsٔRS4;n h.aAfyrB- JM]itWȪX׻2;cBjZCO{l((}PD|1G3]I 69ғ.8e?S*ÌyW(;,^}tИ?#w3M|:)/Q>Q(ǝV1jXcEwacF a<4;sԪ},B]Y"i"É֪  /;rK[cH X2c>n6bR)y%HO;Mfn v@Ž/M&ɳaXw˿;V+Nk3ݟLgH=r[t WSm?PdoFu4,ky/sTzs73D/ ^?3zZֆPXRtGV2X;Zh_jt -jǐ!HckͩQ9i3ŭb~yKU+?H<[1w1?Jϼ0|/SF #xZix+ ֤)9 * yRBWYV 2 owuڌ6Q2z L,VwL 08Wltw)V11m;jkƯ<'.NKڦx{>;[jmK7ѷ7n|qnG^)2au8 *?a<2UNk6ߍn FOf;q̋E\`B&ii /#~E""R6_9D*9]jxakHoder$(6b62I=W*NXM^>?qKW`ZSe餰|¹-c  J/zKG Xhmpx0ԚRfbU"%hR o(chl(A:7 ΒK5Ĵ1|T\js$hBB:a{Ȯ藖*OzдԤ,6n BP"АqP'5#Eȭh=,(G?s7bУvg-鑳رyJ+XU4ˎ~#*n~y`YPmji .&X'R-o TS|?$m̓$YqSPJ1rϤz MȳQ@ӑ`_&cy4"/H&9H p5FgY!Jq #"р'`hw ȝv9nH3ΟևΊ*8Ko@FCS$+G$l ;BfeAX ) )oa?S:_%*)׻ anL|҉̟m:uϵxB6Х^Koppu) fzaFkxUЇF 18"@FпߌݿvNmnP:Q.c6p/M^Raw?r1'׻\-[?8spj7%F]pJ9O턷᷹M< V}$ v 4׼;W?#fNf[IO8ʢK-@|;1x-R^4FbJ:Qs l]cz&X"I~F^ߖMt4 LrD| \kք5($s%CkQV'Jv Τ0^ࡼ~tg Z쫗;#țC7, r ^>}XfyM"!AT|L*P˄va]p-Ϋr$d4٦B-Z[XLuw-9/>,{3A&_Ǐ0fBĒk3 >}T9M].Q{@6#Ld. Dd%䔫{Ҙ YI!qIteb9_Ir-~|}*KH/PWm:v#{8-iKP 4e>,1:]R 6dYK9 M]:-VΆ~YgBvtUIs+͎l' v$<H Yyf+[yc]R/T!QpgT*.iEOܤ;:3=ZžSHɨ\eLxRA#&'rB}odâlQL-;C )(M~ ppo@5k un0i:Ǟ W,0/T z?t谮<k%/ySnFX}n |n Ψr_SC eI'R:Vq̼2a5wTΘ@;χ=Z{Pkm$t.ft).{ SXǽZ՝|%>?f Ƕ9SylLi`j)0< ip,=~ɢv=v$,j lז!~v -+'ϾcT(F"5V]y/2p)+mUt Uj˂JVX R齪xȩ4& CfMq4w,Yc1# \I. ֤0Ϳrܯ7Lvvn rצ{xoZ ,qymRE 1SV,'IǮB~,1ȓ,l:jC td$UNIºccޒEťI.ӑPVM)č>M/2y;Ff8|w8*FS Jshf0y.'kJQF9j UF@fELR3q?0~Q'0ͥc (-i-,B A'Sk;}LM\cֵoZGVc*C972}|H6ho{nI͓6iLFܢ$o p/-$l`'0a5}3lw~<<dI Hrh=jjL] MpY)K=wنp4b(.=|4lШ Rn}MVOIOT;kiU8b(6kM\Z|Sy[JAHU鶪,2oTN^OќO y<WxARHW0WJ=zpB.4lItO>q̌rOgskU|m7ս_-#_YQ޻"˧9͚r cvxPA^Pb0ו3JhR6z}PG.lޯ;'{C\~:=n>g:vp3 臆b 7[ܢ}ooX36wDhv6Km|"[pV+6^c`r~Ӥ;ߓ/eݯ{Zo? Q}!\5>&{D//TP<]OQ$y¼8f2{,Q@c+W^%Gh*a掌Jfrz`r7Y={IXc[p1w 4Ves:PELPr'MP!{%ν5 8䆨%!~<'!L-jI3 NMP}Y7Y:M]OG+ZluGuNR?$;@+a~ecڼb[lG-C|[h@*!FgB<3Wq/<N =q=J}1jfOz %$9uG m:r@ _ ȮB@p`BO>(Er|e?J*Zo/'/9݃R~fY )EGheTF/|YQmSL2o px\ZbYS@zwբselAl(ׯV媺:zC'Ɗ@RHO`=~՝J,,uK3.5s:.;)zA%GD$hIYefe/ -?FqR1K_lgQ%U9V8VmY3E]c{Cz/0/C_LidNݙcrZ_?} 8=^+3:'A_ j49-8֞\̰'wkB̉ .z윫jT :<( 8Ji;)"9&Q*y3^߂ݍze \ew:8 \yS5ɳ\geoh-u۲іS+3ӧh/?E٬W(ϰP<)XUݫdKJ X#rX>"Q`f Eӂ{)&}h[^f{i? zB.iJT"O*2B≃'N BLmUYXa)Jl-iond)4 ?Q[sQ) !jp4vµgf@FiEC5Ӿd=H5| { \^ pN'&( 3/w'8#^)UmCw%jjZ]XһSk`n]8S"044ĤdU LO̼ף94[XN= м C9]eM^ɱ>JVf wU:L,gnMA!tj&+w? d{_&42wˆ m>=">a[SqWH늉 ,׵_iR0(%LX*XygtٳM I.\E5k{:?XHV~Ԃ|itFW*k[uV}g01cu;`[ѣo<9"PJ,xP[W R(Q7(nGPp ~*QR.Baa.;ҝz\ 9^ ݿ)2vX ij~4F/q >^{2 |+64?fe[XKpmNBif:ֱEnSٞװQ,dp$2)8kJyYː%Zc:r\dj4eσ.`J!H`@xvo0]Lrj bEIEA⿩F'nGĀ]G tRFwU/Mo^'0[4w[P lG~gdK<ѕJ{/72e*@D)#ˆZjw{^?٪0T}Sd/wUbO XCIrLCǺ ,q˙u0dL!uP0 41Uq)۷QZtO\g!pul`hs=\gtcS /5BKr㯴n౓(j:4/JOxb]LWīК"eOY EH@=دz 4=&#ɿ hkEgY%zPJÏ{ ?8ih4v=}(FZ|KŸdt0z r6!NJ ŏB h.`iυ7nwV!p<x~j?tami}ivJWbiꃩ@&]O*v]oNfI\1wrt)x3i EϓC)vT޷[|- ]>asѵk ҩ]\G6+fB!Z*{G"gA-` ?`$]m*NaEIMEZ8G[9#z67p lSe]nl>"as`Mi*b/( 6qHM7 ojk ՛eOY`w`ݧŎ€Z=O-5yk[e;*ӫ*' ]F?T7Ј>:E|7[M!lJZ1C]@L"Zk~tCj&ޯKȣ sH06udL5EGDfz)ZdRմ Z)";*Ϲu[\ X :M8k\ K+]g4La1A/;F5ߘsr'mwH䂤BʽfrA v֒TɝMwwܮ)UEp=WL۳+RA+OюݭpYbUW9'b!I6q 6w%SWZƴU8$p:Y@xGi)d.>4)`vW,Ɇ)"sPl2͠s( n5-/xB05- ,Ģ],REQ#rJM4Hw]C$SsR#3Cf5cM5 *{2̥ޭ.l^'ɏShzY[m! 5zh Ee ]Wha[򢌶jBw:p?p hjE Z(Z<A>5NݕkeX'/LqcBh!L%?P+ѕ^F+^sղz>ɭXcN>!(0vF\#7=gXb2<)RKw)U;}C=Ffp8sO,,A$k%0*dl+B e賰r*-zEKBY| %(Eެ׍G$:#|O~R,؅ B4-Ds難ܷDUi7 ]t5tYBm=H@f*!)X@U6ka6qA>OC$ZlNY$ 3c^.hؠ@y'JeȭtI4|"Y? S4r5gῬse?E[[N$&A"9Uϋ۟p+u">U]Jx8jT Oʷƞ6uh2:4u-Lԛ@50ϰfbJdUx+6"TWJ-xk5ŷ gnϠa#E$s+NBM5SU~ptEYf f" '牄D\4@Dzy{~.CUmi] |4 F 1NԏLc,ɾ0fH^X!%@/f#0g@`^(@ KLDYc|X(?BJ KAoFHcGo ̄<l%irsZ6zsHUm(V%Su㚵NU\QIiO"9J7plk`wjvnE) rM8I8'2axoOz0%50V]??1ayy vX^ef1u4.r,m"ڠyy"D[Բv#$(wCR[+X{G ~-Ѐ mqmcq=@zulQ6YsY.QϞᆦ]3sG 2_\ř΍'KL*%=.CUȥ^S2 xzЛtMEU]2UB0Md/5 rH _mUtGK*J_ɃGa/]͎;B")˹*D&/YE)V#}c^HT[ZwS!˭:,EWS WD,]Q,ʞGiy2Lwx%3oUS%WfmpJN8qʑ!LA g+hϹ"R]Yf4g2!\e6x0n( GEh_eOgg[DrEt5ΎB Md;Jd;8Q)ݐXa8u4;{+*\]@?Fmp 0ea߂.y]oٳO:ktNcN4y(ϲe'чtx>7$:.Ȉ 0Gsgfaߝ9rcDLwIy(3ZEXt Xlܰy0vĉ@{bwЀ1 M*e@5yL!e h#5hl/.`ؠaftSζNMFւmc2XԶPk|-;>f=Č>-LY ; H̔FcDž^H4:@"|)58|Z母svƶ:;8IA]uD7$[wy_f S&m Y.NueR?ɽ%ܖ}d`I |X/\O;u˄êb6I-ӣyhw zbqG jq€ygXiݿBG8jNIsV yexD~<4ɺmP͛K$<$Psxؼp:qM9 a)s^.cSqUٖ\!EyM L4/:A04-DGjD]stnNYX.ߵʄ|Rp bSj׌p?KS<ߟ` cq)ˠu8g,q7,myUU}Mbs׮.XTa]M)odZdY?G/;U2zq.Ӂpv ׄbx=)vAk<F;u[ hOr٪z(Qѻʋ 0eUfv g8.2q\6#M\D< x9wi!Y6_!fqn^pyuPΜd~f}9&VX[N'G6˰kzvP?Ҡos%WOCoٵgC6/s=C"ױK*QJgmQӍ$k:w/XSu:0Ҋ! CZ/Zw'q\?A] \zYy'0f( Tl5i:(1A{~)kʇa P:)c?S~4 1_/ߊcki-rtĵDV‚9 d2g-x㓅C`Ƿ>dSk@^$ŗsvW/g+!˾8czeR~BJhx5TmpcO*EwWZ)yFځOu[ȣ[7Nyt A!ތ;nLbٞ!W\.;F<ӛ&txN_pc` S $)_lEsj:ӱtzoͿ܃_4Samk@)Np*QFG=EtOtg0#*!%E q"GV=) aPZ! PI`WYO*?0jeV[I&= ᥈q: @tBp^qV-Zۧvkɣ5ᕪk2>5U>Ww^3ZЎ-ԫ 2,w"934/}tQV2yc5ރʕU-?&,2nVl6}Q?4&ta]<Oq+"".b &?;~}XQm854BRI5!NE>}`XyζFt5{h %T=7n_<3etA8)ӟRiqa垌z΋03g/d]?y*Z$[F˚RVꖹKᱎPp>i@، pݭ7UKrY.D=Y.7Sґ%rOB7r ~,.McaM-R~2`[+dzr(fAwbV '.U~Q}OdJ紖Z_RN`ld J{C'N>TBT2$e&7k2}85 (DiY=4i` mn!gcB_Ɓ+N{h˵M- ܨ#(K][CbV,μ J8.5îH=QCاE2~nB<_=Z'HIDvv/>,,ǜSyO~@X,K"Y-C_d}CY{B~#8ua.A쨀i' |rRn &ts9Y)CY-a0~DK-:L{&Nu>  "Qڡ"WRh42*/Gq14BJڐFR#VVքB=a qpy T _/ qbqL]R LJ!qӸb7D(%Bg͝k =@ O؛/ Hfy9%$0t kT;v:ӕKR϶g#vxk A8=>ƛ ]=3y/lZ!YS}r8\dY5@I,S n@F9NA]p*|3†YvX^%⎔? f5,u\㯮MCֆygF6\5@Ą~\.:(Gq*<9.r^\@`&ǙcH5ǐ(S/O6F@"R9FqjߏUk,ۋLPU|=kة坫jco.RnUjahp+S qܽ>G2AB F;ϖǤx8Ld 3nK%*@Y{/*eLYْmPVV^ZB4;(ܶBf;G;oT!/5GNA$Rfy!7::*Z?eZK/[7dvC$z.pd7*R07ah̿tw+[6= yrǀ$5._푧 tyVG"$k{n,0s5iG4ּ!东mY57ףԬZZ$6TA-.A3.Ҵjd6ws6 }:Yи9Fa0{o^X B|E#_Fi1},,CNNPIVKRrK ti[Y\hf?LA[_f?S;Azp.YQ9j|MhڨΈb(DGgmu?@SgOفT J*ww3Fn"~O'~G5* 7lɚ;@T< &X4KTsžph~/'4U^`@)ZaEft|JAMdguL"ryx%bJZ/^ZV C67 :ThՋuR*)3o?*G뮆?=귀G f* &}0wJOGT >eXx`Ⱥ>E6#ĚKKGN&>#@ƈ| g;<3c㹂y5W,,f5'U#rnGI㙫\m^14SOOqS pEz/Κ/Szn'ҷJx4FGL_7oone8h_~#la9ru+- e.ٌJD-pIo΁5$gEҰ;ޝultqYx%dm)dI"]|I'ؘ55OqVqԙZg%z0 D =FĢ(2}Q ǁXeTٵIJ״":0Y`I8k*ˬG3sQ?FnOo ;ڌhDUPv*%  `2G 6IκX2f;ҙO/ ޛT' '#PJ;sD*tib#Rʔ wZᡪzM/AҠHb-Sv R҃ʝbnіU5r"Yok,i1B!K~ { s6CD߶>Xp- -44'AsAel8^jqDǡ{/nJu(sgIyNCT۷>x2sxqͥN%b[kh×@`f>HI,9OOD M!K/WX \}*2a\UDQ?‘eN3!hW-(`&0Bϔ<ªnv|S,/m&TQa3 XN?O{}l&垺r-<<qX`S߮X|<+V|VAtGҞrQRE.#Ꞃw.ɷhQ D!-/-8W %ֶMq%:~S %bN,Yc^ޛj27M% 6.Sѐq: c7q񥯖ܖ0N^=Z~5or䱟,\'#KqJQi(yEcMo8wwZL`$B^{^WN`G&vʧ`SMHZnY zhnP?~\<>=v_ FiğJ't؛<7O?*o3Rp"P6LָfuTI/'-9>&(r.\:4C >ֶp^ځS4A}F0n[ {C!GCG lpJ\:<+ jbr}SՈj9^(=}!>$TT/XaPGt::HCc2yy.|ٕb8ё8DcmΑ/ҲWL(1;d/:sCLi Y5aE فtCi% '7KYcx9/AQtػ4ڿ_0!,EK5K ),ٿHZ&$4(1Hׇz1ɲ֗T>4e*Pe` H{u.5i{&dD2E&87UXVX_5}+}픗pT GF8۷\7*a Jpo%?0D\k{Kws7r=/R*\HvG(8Hy2cyOk?d05E.3Kf56*f |'WF\3ɴ f`RSȼEא׵^h,Iec@ӊу-JɼгͲW-̪|7wY[KO_0j6_(4SV'%cNY?Z@&.D{ L`-/74Wu;},xUm#_кUO:mO9 my#v;||9=]z2HQe!b sxv' I,.:A`愩(4tHN‰}YŚd̾ҋrXF<1f.i&&܅%%O'#KabeN|&_;Ow|X*GZ.\OcOW!I& %A`? 5p6Lm!(uפ6{'3,*\]&F M^vVi;YޙM'(@TB=)> \?SPoqCkКtM4B拄 ,A{&Pg?qk/B;rbK40 E721luŒ'!@NK xgu&NJ<:v\?!6F Ć7_Lj_d?53D/8bqW8J6QJq1U˩A:tК''&sK0S^uJ3і Ȁ'kP.ڄ l{*#rvW^_e- rK%l|iUMzp^f({!kIruùRw_ Ry9jj֩al5O_{k7g`f1Mx_˖Cl`w #豩XnlDV;.[\֨]u7Jn%Spw!Q"'Ul&'uH<,x8afވ69F(YJ޿Ӓ֚رltETLֹn র?.L&o}NC!R1%Ϻ[7Q*wjM]f!e~ݿ%w,쎯g[@Vi *{ HR9~y4Ƌ%/ҜiU)~!}+$}xe1Rl$ܾsw;./fGncRgM?:Ai!jW |[iIKT WIG|#+0iS˟o;өCq8y͹V}DJʌ_KEu'm=Yncₚ}.):ݛiS#  N:Ț⌽.^t`ǿLJꇏ9=m$1?)B]]^wtKCQw"'ny@,w`G|ю5,[-Y`@1"um(Ąb 7obLϑu8X5֟beuM=TpPHw3z8}==JA݈{AB[#GF[Xck RSKزA̷ MD{r_~W:Yܘ˟'1nt:%%gz2!4^)L@#NO?ѻAS&9ݶ`^CejLBiZC/ORPc6~E$>`sƆn E)KCEߨ;~wF-4oe2A [{˓ӥ̡f ^ⴡu`JT5&]ͼƋ.}RvA\BD/w8g++WTgza(X)mu*qP%|ДdI"EeOI#L94Aߠ(.ճHOcPNH,kcy_*a,)R 㫃허dr !6h$s2ڿwש`W{ݬD;2AU7V+pd[l/=`-5edDPBiNл $HH)?gt7gF*^_CϙK [S?çn='S(9 (PY?u)^T{Gx"1&^~H:bֽl9F!R!GL0ѳs$7oQ6PN9%HNu`b| 0x8!1GqXaҼ!'mԿnTk0YXJ.ϐD;@г5qY(L l4;LWo)am$ើQi1Cv4"b>OndF>j>^[t 9"hUO?w'}8_F2Dv׷A /L2\7V>뚢~lC:, '(#툹An]/mŊ*ӞeF4OCgpkO/}>3-M.@}B)$s[N+$QR$vHsy2ym5AgAۜVz)wXW ?*S'&,> `@3gKx5_glN(7K6AĢxvIK^Ӏqc3YdW b,pTdv5XBaR@wͬI ̐b8% ;12`At!hj_?r*h0Z\vW}5.l8d&Џ~_`av[aBRITЌMvВ$@*sRYDi~>Mf7wO6Rk;{g4/k[qW#-a*З^HFJ$Z_gSe\rKvu@*\$T9[4 ʃ>DQC8 z :M@M`M(_6r\|֏QWZoQP lo%o RfYlfp`T2;7͍T|-A= ϴ2XndaH|hL)Cn(LJ|Dp{d@ؘ]+|`袏TSye7]]' y+LܓM8>y@F_2C9My=4)ݮJMR]]^کCLjA~9NN'Ciҋeq /JK6cG!@AgCPP!9rN`2}Xm 1h Z&mh&Cڻ*4u0 h7|xfql8mYؕ^dM,:o`G(L?ζ8]SMLj>VQW'@սYu.F.{+VMsJ(k8t[U?zvkB{^e[rLګqŗ(3+Gj _ CGh]4Ȳ*($Mɀ>_R:>X8#SEe6P)ЪF{GJf>\1vhaSL<#_6*n<7Ul%{go!މe?w+jK123w}F`0Bl-3±pS9t$,!"!NJhC߹`B2ŐUC?oqޒ5N 2kWɠV"H;5taKRն)@ʼn:^ǀ;cF6-vQ"8P[_ޓ䚌΃n\|פ`N:ruL, -DHfGU#ajZJNBK[r$@k5&Ix"ĵ$i#pFk3&l@ ˷٤gV鹵ZAT7?=) 7F4%482ml;+hs a07[_@LMY䁌TC9`n&IdiKQuXB Yc[V5CdMфdf)e*jվ f( K6礕Z=]V(ڴUN{3i2a=޷F.LAe"}’nl4nX>?A1= @D[;%> bijXrC5ZB(čdmY7'xYd,YCx9ϮW[Mr3'Eh>]wǛy!/Pӕe-<^L̩3׈_GH(F{p|MzxXE6x *$d /R{4KL3h.n5 r-RC;;pfwFocr9̪z籁4:*7HzE$zP#W>hIW? ]:V*"K?+Sx(PMs#q@b&%7H[WgLW@:^N%--B?r{ @%LYWrPj&(kn;c$; }7,*7M&OF5MHFM Jt2'=\D QYRe_y#ze~MRC8cG:x}._0׉$$ *ky5*IcvFIķK<[}XE2ج^@5?Y С |6L]OW፳od8ip~mb[ljSDO/,;GTKr6;B_b16l41qˑ|hî#`򡠦(9$]^m#GHF}V,5ۍҏȇX|ϼZ/g` Ǎ)767}<PQKe%7^j^ĶZkp]}Ơؽ0ZDLr4#[oy*?xzz_.vW0c%Ԩwv w岩.$`{=9~Rxd+bm*۱*s\nl1]F(䱍4xqʥ`֠G"<0!'D7{5E/O,nn"G s/Yhds.‹2M?y\!YuR›w= L{Frt?r`UUIevivQA;Bw lY+⨥i}K㶥d`[M]eʦMmˁnrZ,d!(Cr2<#J:{Gii=8 oFAm;zHkjc''pF'!Av# x5m|]^4%nG 3mש\ՠÿ=>u& /y?$>8۫;zݱ5' jN 2 )?/`r'qIUC:2zrit癖ط4ԇx/|E|5 BLNcR;@B3xMOROI6 Zw)`4ŹC Z7v|XʝS{f uB$\ F=LyI]o:1FHgA:S&ػw7cP ,5n O)6-c)J8l9L!O4G1Xb3.0 berK5ּ<ΰeNraW6 [pݳehUe٬.kne;9MHjrj4%- OPsmPYCY{ 98ix$+Pb*{5U 3nB(+%ҙ^Pףc+|Dž'C$KE6ÅY.yF< g6}Yzߙݐ_iە%>y+i$uwQG: 6Y-AIbiH+@ CBH;E10bi|޶´Wpj|O,h;'1 a.rEV7^ ɩQKQ~mǏ#1wGzbiڪֆb47k*5/;V#^! >#v}K?ҏ~G)q2g= !|E>&" M K)>Jߺ31)̋3%㘛x>xc7SzDx>Wc)XQ\,\I4fupX8aAQmG9Q!և_]vW*u$NЕBu1m3%4Z(ˉ.:RdVY3 Dނp3n1p(8@S[V٩2U6P'8n£A#Jy#צC,Rء`h}Z0RwYr̿ħ y @ &?cwc NzpaG8)ѳy$*YL>a^j޿5}ז^[sݟ֤( N)OnudaMNڼК=X7ȕLo&HEq.==՗ZM"X+ N eHyYPF*@6ȋFszc(.[Ν&Z\PU%G.-ͮFE6Tpy zqG<8Gz0Ԯ8! ?^S,yXrh4~HqUMEo)3j`m`{Ԏ)iZȿ 4`tC v> | GMZZ 2ǶRS(eZlQRif%Im3Z3ը]JTj vI+'Z$B'A6M_,k-=]}(9[d{&1Vd7_!uNQgWJUfNcm(lǭFu~dn@_+CM|0ߟ|]%=&:5-R"w3>-Ұ L)d+-!2#A7+xg`2x4px? dJ`^~["(Sr!4rx+#`Z{,¨u蘛XR.4JvR= hf5`?炵EڶAC03@W.Ȇ[S iaqdnx~Tc[">lD_nT5=! oXk#D~!gb{h[fA=nбgڅߡA;W~=ߴ/If?R4"ǝul[@M9-H6˪[cۘ5;F/he` H <4< D:)nmS/ aGnBZ&TW _jIt*Dd4Qjb":15F?͙LٗzbɯZJ^传'-AЖH @B2k>uDZ,N;BA~n5/ѷcTʑic6e)R^#3 2vtөą K}(/Oq$i}~p(P7RQn1@mѳCcD"u31uҳ1sy >&xK!FpwX D  T_H~(t3A!U8Eət+[7`t ){VݵtW+/^8& s,e fU{6N:l[e\[OFAț sܕ7|̢vW/jTD^,fҦ"kC~ (vSk[|4u[/:yC9"}i{1܅ @IL ŧm_N,WxƸ`3o,Y#p4 J΀Uׇ|ӓ݇%WLSP h_YQ-/@/t`S$۳ ڒ"X]w݊Ww Bc z<u@'q5Y8fP堞BQ\F4Q=x$ͪ@胶zv;-צO108Jbhp;1푃$ sAؑ\Nmy|O2[rrcqLw4P忹zX<14}-W} P u +W4`8Lk>%f : $ީ_.k b |3ƗgjT^ |GZ0% =HZo=sZqb_aU-8:x]GwE|0|@*R2'24CӺ ?GM097~=4?WN}@=Xͽr5u^@݊`l?QgwG&Y*O2<JK\2w E5(yebn ;%XK,YbXeVaiC2 #8iG_7TAbvCZ mҵ4fOG2sjѼ~v=)vO ]_'|wNbIlE+W-0܌t&O}s=f9hxՊo:zC=aWP0P) Ut'l]*\磙.%ڞ͝'ωcUmg +/шUb]h:l5tq!ɟ;*U?)1ʼ䞀 /F{GW;9x5|sʏ_L`pxt5}VYOW^5@Npn8|ݼTһykPDӴ@?OLb&17(l ~$1KIGC4Y?ܿq|hr&_ 4ӕQ.@ݒ@:$Yi¤@}.wrI|bqRf)u v쥧ղ&VuyTjvwy)_5ZAm//ȏؑu 1ۼves{P}knnZRw,-[~ᓗ=sR }9 5)K7WY T|*^e.#Z=Sŵ*Yx-UAoY TǤ @iEuA7]10;:1tB;\bn{A=dK~]0wřgb zZdyGKW( ;ŭ7Xa~v1vR(nn*n_緯V 'lz(*|R{Z` °;{ *m\|{Hݬ+c-ki#D:iT5y;V\Z-{ak,;,CJ\o7b؎*.u+UF>u1Ѻ%\A΁LMO$$ƉgP%?@ǤWX2xЌF&Ǫ6ȹvB|?q=,Lo*4pЪ%NA@F-e fQWdCi=~ Ԝ+ JbgM4V|ބ1@Zŀf ŖC'wh[.y>U:cz-^d6J{ku؍6Əi Uq-DOe2I@(@Fh_P(1d:fSZd*v/\:`^MhH}!lfV"iosYXK͝$Ht'0z@ڞ~>2rGPp4aj0;Fp@ s|k.*ESH jA)s *=ؾL@63:[*4irWy*5H{( ɽ":xRʨ*LJ5x!9!F-iLtwtL&BGR좭̕T\\Madn:Dv/e sЉ] _۸o!=^}7@Jޫ`iX_I+xtV|rHh7kzE ru1K'_!i0HP&)lh64nc Mc[A9jHAkY"2Qcl>pC\̜ƽ5K= <9ϻU 3sMk3EOȂHGѣBt;BehJ%#_h; JpS%ϏG6D˫'gU ,VeLԋ+b0<_NW:c&;eGm:(Y Tbh _.ό 7~p$6_Ez!i[XkM*'.b JװW  urfo` r+c4 U=G9i$"P@P'6cLD2uʝ%Rf㥖 ]Nj ʷW/#X-87/m4E;FA2O#O` }мb$ c{q^fkoԣfO>&2}RJL{0^s-ݷ~aa Qwzq2L\j흡{ʯ-留-[2p(͉<%J΄Pl ⑸Ư,T͘w: N9V|Ay|n7NiQѭEW~{q!pTgJzJӻ~YShDږwKSӽM5r})mL,e+2$_OWzW<=,^ŴTyB'~E R +f-`co=L"C8 ^2P1SX ,) D ͹(]_*,|}Cd%Wo+gW/r]xi͠ETTOY==0ëy@78ʧ@}'P>M4ilcIsY7'Թ.,*QyE$$@'Q ..C =4604}aꞾwsv-Msc52buw؝Pc pNmT=+OJ&GPf;WRhB;Bϫ/PRR2"KGv4?!7#w^ViTU0H/:4~\jwTxRB9.sU3GR]ɡB4>j˛/*A(fd @6sh?)Xq<$KU^s0?g,BQ ONZZv@'$_wذ/_E{?D̓pIP"J|lhɰ{YF\x[TWtKz !,$Ɵ⒑-% qk V*3n,g/ъ2]v@@_:]!a{K01y!FB8yTdTٮ>W ^4ȞN{?(bFw%9哚>1ґ@ <%K@l칓 7-\z/EwF55-[݃GJ?KIzk躛naWV qƹth*@_lpYI7i6vΈ<8C?;=^F^LPV_&2!]5yж^_C|v$^m*LiTHɌeHH?H&#SKݷG* $/.5bg:XP}'0j3{0/ 邈kI pz25?F"CL ҵC:gN UK /yVҐYp_F$U8q䠓rr:E6 C>*@ n2y%DYTnvާ sz9s aȖo@B!5 8 (Ι'ZݩaZwŷVa<]Cs>]^بW<7P$XFg-ӸH e,gA7`#A Ë*&ݮ%(9z(k]a*YjdkoiTDS@ brZF^N8ejڴwTa,j[j8NI\CNюgxy !U 71r/ .|%Qs3E+s <^Xhq‘V`ByEu23?ɨ?|JƵЋ(cuI|$(4_dM"rZ YCYk]=VgTlEUkN:ucmw~~L.~!'IIn ðC:CKeMO~vwkf^,z{84:ɼd [;ň2 >x2%JgEB砀BY/QW6ˢc-1 ˸j9Ca` lb tiJsxf+빼B 1( ar П,˟ʳ^SVR)[ ?02h`dNPѣMsoQR(Ѿlд-cVbS="*>Bp2;Աc0N~?E6rSW;:eR[':v7Ea* >}o~sه;qT=}0^(Vc}YnFR\周W': bɽb9W\lmV6}X11EQ U%$0fv&l'k\l:jN;"ZOiQDJ|oP2Vofa婻i0WHӌ'L:8W&0SL*P [Y$a/`Ajau T GpU&Zf`1̠2{OXc!p]+]e6.}YN,~ uNY晤<ʋH N4]:8? _'x6z}2UDV.hM;HU@ADv¢Hg3-YCzd @ d$|]3?Ejs MYHXNߋ[ xX u9[u^BW}HZ_~͕\GF^ґ+'D*yjuTqzu0s *tY&e.e}WSp' f clܟOWVX#ArMBGzE sM7o +< kn5~Suр9F0 /k؂-v6)|PO(/ho}`~~vqZc;AwHW?hs括|ltkupPQ& RU9x:5oCƛ}ݿ}FXpz=r)#q)u-,OmL|亢62ABe~ȋ*5#= 8Op3",<ZWP2^{mEy߮Etm6gw4ȕISޕC檅q xP_cJV50Al'[s&Jd) 1յh-F&a>/˻X[TQyO~+^ϒa?D NW8 ("lPn.Lao8<~۩Z<#nv",)<8ͻCRvTDpS5lOVz:? ˧pszO1`gt&߻bTkcn$'@+V0蝍kKv^=$5+i<23\HxќŝI&`玤ogF].y/RyMuC.x-ѹ2/!)Rxl&A2d~R Btfu20$=˟Wƶ~qy런S7uv+r\hC˞g;Ym+p1tx}FA$v0Ҟ(9Y]w !9xϝ@Jz$lGcYdm{ڧ]zNkC<@A*!nx{M]IL"b|{:[6X#(Tb!N؎ʶ!8E*J_I \/Z) p;_PNH+wp7N@΀?tt?#zWC/);kUi/1UͩA)|+L>xyGf޳P#S E3ulMQŒa[&_Ěۮ{B:B#z ׶dbur={UϲicAinZKGo. \S+E.xE#?J ԠYmF s9ˏ6A+cUpW aFk=3qQA^lإt\.+Oۊz߄QcWqTY 9" Mq(+K=KSnܒ8"iJz#9bk!@t[b `j ʳuÉH>|wS01Y?GтXR~=i@h}Fu'! o@ =ɰ/RD$PHKD 99ܡKo~^F1Bfwp'n_J7D=~gݤ 7^<Bfw DQNZ EP'L2-. dB(Al5oqVQ+F\31&e5Kq8IS[ F$*] sbW}C_S @5iw ~/y Ƕ7ղϱ#'Q۶h)o + M\۱S N5x8b>(X%w.%|&Y ẏ$y{c sHT| e@; ( !-+%UtVfѨt'V퐹v$e6hL3r| "5 v7pde[-7]Ƞ*ǖgoW3jҬUY%pA&,k;0Z xs-[-ϛ0㆒-@tҩp|AgYE'2qk)~SKE,Y|zĩoE6 <цI9ew^2ZlZ-lxT=s110_ $#Rl=2)qE ZeA+{3`W Šñ;bۂS8*!IH,dlSNR)dXc ukJ[yTwݾ I0nM E;a׵&FF⼋gݵ4K\+}*ێipKp"0JDC)o?YҨ$Is= z.R\2ÞC:v7p܀"KP>$Κ jۊ/k5ΈJyADbJA&'Q^s;EuIQތ{2|Y90 bFmV`ud y^^I& %PǸXx WFF܍ M&!@"seDP7zPM5 "eqPy~ax /'V ڔfU1df*,F†x VUسuqc sc4j=l {Rd5P(Jei]4adϹuqD@b !;*R"nkUGFh/X/ iԩOi@lPbA?) 74+cGqCzP/;w> JXh !ّ#qTz] ٷHG=S;<65~ >,<fQsTGh$#h7 __ʺGm]PWVNRJV4aφ>ꎱ|si ӓ1:Jɴǔ/BbT[Wi-jԱ=sli- n!sB;Vo7@]H?}n`HLfPz ”ٵ[یjP2`0%rU!BRٻh 6v쁳]zqԩO ,rB%o)(컳,( McOc* h %r\7"l5AoE &4ní#^,4}15T$Jh{z2Fn]IKLG-y^WljNŗvdm rWE%_9Kͥ@#YS邸k6AHӔuɨT8./wf0ϻL*,`i*pI"dp~PߘCӪr];hQ$Z21`ИX"Gkz8OY2RjpCH|D"ԍ@w#f٣ NЕRͧv&1ܜS!^u :z+l˵f@B ~X?YOG%`v2UXv+$rf{Φ" ' LtNL^6`X׽6r\#k 7=.#:-h`rBdbA#7Tv:_Gׄ֎R!8G_?)մrֳ7H 5̴bSG^ٛ"`?[xa ͗)@=- ꜦzBimybИN,AdnW%(h=*>NU9)Pjr&[b9A.lQrG3M(V-]jˍC",pA@.6J'ECSU^ٰe,ْ˼g@Е%Ftn58xӵ&|9@NFn?M@wOC0il`4$y$( -L\"p@@$r%g5VPF AW}#a-P}ʇa ߾lFbpK [K^EW"W6g1^x DGTkhx\֛wfC&vg^ j kPHf#I\#m-i1nl`1\Q&&k܇^Mh/56]c"3ыZCf. Vyϲdˎ[ז0N Oͧ<5L=^.UW~;^p0.[6r ڊ9]D `-+QWƄLRE J~=?.VkȯomE/ѓ3XZH6&R#ף$bl!FE/ #D `}N]ABdzsQmnUj9ȵݭѰ$QSLY8ûJ]oVX zv49_1@Be,ibZ+ Sg~iѦEk|9rjٖܴFs-vL(2vUI I0}NnS Z p5Ă0*:"M"'[IWɭ 2ȄLlRlkι'I1E4+h1rbϴfe 'vbSnRt;3!pC`=[Z/YXBTp?a ȷ!"%hA>HY'4dj 'Ӳw$֍1p8ґW.W jKJV]:7 !m ϝ{ o~(Rʚx7V!xxZ@N%$eӸ{6u ɑ+@e+p~8fd^jTH^禁oe+@c^u/맬 7r@ q8G..!.>(9imgGt/l V0d~&]t66TW 0#{tz[]4{|Њ9opHy!eA#|_܆q:K j2b+^#|{sBC*}PR$[@%u[Ih3<:h!/Fܵ/4@C>Ijt|Ci@:\5U@vo&VdB*%DkWG:T*J81FZkJO\\}'ۊ&^盎)N4d+_~k ?| 0 1QK?_~2cd."L6:\i&pϷ7v[",#n (d[Sw&P1}BmW?".;i *6c <1iߗ3J[P>nW]xj#0-ِ&[y[4 @.&n_U_*ZNNaG|hV"=k4(Mh^cUO5QZIS32vƅ-cۛNpY ԕַ{zϑ0Dv)R8eBt@2 [DY4'`9/vǡԩu[ڀ]%Y9ݓheD^gôS|"eQ@xMž'O+r`67W$;Zp Gbr 'B o'R eƾ'mt^] ESdK0J/g[;vKLGlFLq:qG!hԿƒ:}jPlSSKp1J{˫7OAo lr 52U(Hu,9Zqa2 ^Ȱh/"1;^Vu;֓PBjC8;9JF?^h\ +ɟ<,-0->Nݸ$Y,Sy9bgbnT(,aojܩ›A#DfM;*ؿQ !j.BMʽҩq,eyoūDf'[+cEY2+ŀ-.ۦ_\ǣZ)3Xo.aT?-;G'UބtQJ]C ?%OUn4c}puv #?74 ++ W[Kц~IRhTë;!OѲm)Ś' zv-BzN"-O7KQY2bN|fjP<ұ](z8 XL%^NrW0 ѳq4!Y 9("N`[Eq?DEd/]aJiR>O2)!  {1eȴ*+@(MqՍp1Q,_=1MgTlܘ\ǔIlP^A1PB{IF2H^y\ʽ ȐeAu)ndCzrRImLC,1vMQƒx]\oKa?և+I 0o¡~ `GI\*1 {dUeqh M,}?E3"c4'ML%܀нNuM ՞ F܊ :ԗ{&b _wq~Ƒ)6ҹqGwsvmzU /:I@Ngة"mKһNPv@7XxeWxˠAΧN!jrI"Ne )J+?/OSbTR}a/5]K o'VՉ,!xT@6ZVQn葳hŬ $/KiIS!]23ēCfw _v<%#iY4:-\G?D-1 dGBw >QJՠ'9>y$1SCDSFƩ|JjN䨾~ S n=[Eq_MβoUq!Uڼ|HHc1qJTmۘGO:';ץm\ ^ۜ0ۍe*d雭:3y1k̈́`bdm5z*`@H1) RSs;Q6+!&у7IjnS*Ui~B W6mˀ\Hq8"Aw~I%7Wt8#- b16yped2h$v,Qە7={fWTԧܠRf)KôRr& 67Z;V&d"5XI1=4[E׍pJaOGzZ6M7nş< &N+'1ck>Q`f-GLt=@ G9/3[Iz 8wOv/mRKWKz͞|'P/:(sm"$ȣ@;.g*s`oA${0~_ltyOB9|Tp>AmO^3Ғtdy/PnDSKbg٢5H~M^Ya#;35Y7zWى1A2/WEn|Ƴ=2ڄPDU<5"gy֫b>RjV=$"D%eu $d$rhbx)$Ny"V!YRN(ᳰԥcBnJV []xS}Rnzrͤ_"h ΜgbIϽ [9e&MU#WLO_$@uѻ*| D[4'Eeca >TS]o4ѳg#d)Ӭ;2n vC-mŐ PL d_}Ux=^ 3&J1Kp =*ZP+7|$PK u+mDpK!ղP]dsݬW*Gb-wdx8z~fڀê]%x:JR_[>SǦZB(101_sb 9t/ ^/ĸ R 5]\]*gɕ0Ps\x]~FE izNFcqչDql4Y*͛eQV”2Y+'lƖSK@Fpxc;9FR;FJ3i`ZzcJV8Jӷ2u/Mas~-F,EܳcZņK)ؗǎTDT\~¢fo-se1C=1/je3 k7,F߷fL)7l-珴JZsz]Mx[ -6M[IJ(o[H;hZ»@ שd.YR"5ȴkСZt&PG~/IťZ g!R܄U KfثЦ&5Q81yDG1 FrLpDkAV:F #9łbENzTe ˈ 2P3panl})hώWI˱9C\/ɼ!F{=+wH[nvA"f5:0uvDԠH#э"iX@a}Rnp.4|dJ5Zˮ"{_ Iϕ!aoc7jnjAā;f j@KcG?JOv%)2vΡRn?i 54. ̃<@mXːʍ kiB1|2 O94`DБj7 '5\'5̸LF kJ@06~݈s廲Y ٵC%^P_T兺VX/\!oj C{z9\޽P*ڭ~9=ӧAYe:VĺJ 0ac:OgPۊ _1W|)Ƭy6mI'`:mTfBӀ.cj9`=߀J6$S6ǭQlA6e$9-tUR5|3=]`#=!yf+ `@xT1Rp3GuQ/>`e62.I C ܃':W@5Ѝ@G!?S3z@Y؛ =wr#Q- \4⻂ 8[5; wQR#|ì.rj p2߃>Ex`|k@9fDcKm#۰k,ŇdB*tݦTep!yǰvA=SqRhz>]?[#a#k*Sqxgv# W8B!0=~"x~k=# yPpmj};c3حr1K l:mĂ:<;C): *Ir- 8z|yM~$G4t 2Ρ+9, YY(<~WC$b1#t76\\E+Tn&E6th#頠'"NͰ@$t9_&bӏƹOraRj0޿9_dL#eS_8EEBlV>K~לppCϦk!t 1ź[*ՒLa[DA Lz`xު-JХ.7 p;}Hi;_Y/r<dT;yqP rKQmR,njhvcc=h)ۻ ߕBf/\#K'$X7^d`ٻw08=K;/GM_u0Ц呠Q*]Uld4әX, cT֭7:`ߪ|g 1DYV@ZMiێ_8|Kэ6\w>1~:NoZK۲"J$@z0!Rlq~ sk{ @OSnmCvYW`ys~#f|JmG\Z: \#>h>Pc =wCq]ڸGVL1r$.iۖ|F}2%~x"j5p,z Bצ-A=:c -_K WlJ*Wl<&lcAWnfh:^ t)皆s3\ 8 Jj2Pa?hNR} z6 |U;ń]=|.9ef6sQO' cf"srooyhϦXwI2;ClG u݂ P"pҼB}<2 [yU $H/a`fu]XE6M9o SuZ>d1bT_ּ} [ʉ:"A-!4޾,3a 0ny XKKc]cP =xH}n)uYA2#l*[ϊaUziG)KNv,fa6ܧ [L*8xY,HZpM ;N5);%.k)EmsԔ5ibYDyO=6,׶xd;0|8Tk7%Z!hn>bqܤq() ![e]t4F_{ELIv{?/H2!J>l=Fͤuųώ/w+7R2n>x|忹Mdw[Z@>jkr.g$% +M$H6^b(}N{:$Eu_VZ8 <4=} 4uꪍM5(RDi1xmRdBNq I"Q8yMY5ގe^FA:}Ίw7}O* F0 Sm wԞ|@,u!q=4۠qJ[~}C[Y7{eJ~S[=zWJ_qL}t5yu:!4M5F0utyTB8d7L!h07(t3t!C|TI?=3džߗ4gfoc|Cy]u4:(h3%#,jY*cmޯvԒ=n4m⢗`'YAs{W1cW% 2"r1h){bҒMCwlf SO$k~#ǁ!HՄ9v{柼GQ?wz8̂㌤EݍFV606a=Bb?A0vѮ+U O2ѽݼ"V3j|g/Wde}/'.Vl{E&ѽi⸥K,Ç5Wr"g=}GuC,\`V1*=^_}Qe-m]ÉW"p{b[hkcG*o6m4x?iɇdoYkit{u;YAŒ. >kspS[Ȃ[ׇݩJW[}M3 +A}:0§{̤K@nb|õHSPDz#[ A_RJ@XKw=KFg'%'c)m | 7cQh'n? ='_I}țs$f?z:۾H/IQ̅8/@S38?<<'rn}S忇^AWdr]7EHNUfi0o|[=~(dg)5kQ6^o+z[NMr$x6M빝,·= KZg pQv)뫃7>~"o8dje1.EۭU]-`hp.@2WcY1N N잟<&CU#"L Ly]mWp + *gӃ{6p 苔OXу &khۂ@s>@D-+h2 st@2w1QNMq4m:dB$NfWeOAme,o>گó./%auD\1+ҁustuRŚ9ί<.Bnݍ+Nvwb6w9]2tud"3( ȝ_ti-F seDƸ;Wn`?E)*7$o ˎh(v򌓪ϠL,3V:^7ry{df ѾtJ{s_m'|Km޿mʐTVZQ5XG䱸u5yYlid՟Wd]%(U4#4%BҢDN+ą[])T:*ERsuk4/()ʷ]LNzR¸ q=L?\x$\{;@i5*TeSK늼qh}YC_U߾Ls>Fe]"Kjvobe,\T3Xqmv'<|܏(2EAA.:x%TRp(maEaՈg®1j׃wHvqx{B,vXBPl[ҽ+` x,[#MƧ- Ҟ6;1x{n;e_ڠmuγ :=4j4IΘlhk*!H?K|0vnDŽ6O%) YCMDtN'-nSDSb&u{*1~Ѝ7l묔* :A*345y7пYui+)0o:,<5MԔj\+:q]cjf+ Q`[T6K,X,ύlihc#&ۂb\pR%?wsf4|2FZ*rʒnW-ZGh5<NPHQ$sx/qZiLX :ҵRV,dH&VݒdʨU[PrۃEhUGV uv1|0iVTQPՑ&fmJcυ7rvmC2-)JrV)FQVXA n@s2/dW4_Zm1ʉo$oPA4g* muv:q=Ch~#w8#5.i`"?!"=0@\׭ .EDvGelTe2?;2P7u^1W¯K70ྷl& Ptֲit>foĤZ9Hk_n,1}q7`\ n`r.D)2Vg}b{KL`RsYx=cÀsXϱR h1(E6BSRtٳ}jRTyCs2W%[@RPq\˝-XM[?},*xąuiyEaa5=#S]M2I$>\qPAiWѐJqН s}0NIضmّja&F()@EɀmM}ADE{Dz^[R4Ԭxec ~-#*V,hI$ym#QkGY?ko@%bt[ٔw8рEꓞ;#D猫|r,2y^sNdcDׅ^ \GL8-`Qaб,a,D))X ѺpY<2z0ww:2!T N'6eCxHz`CvpSOg||ZZXwU.1+*s;oc ۶+uu 5 x;X6 +>icbk+3a,Y ;]myhaGWx@UAf?6~򥊯3}k\8Lp;-MaGsB%*uX32U H`qXA}(؞ `=SM.;[ 0;(3, # ~+!>ӛwy=/@+Nu5nvt+YzPA#Zx} y c@fboEKQQ Ҟu),KHIT$C(Ãv5}EV2 n\ma{i>NU-շ}Usm @#Hy' ΩN7A%yNmj)'kWO6 ݗ8WؗT*#s>zJ/Z ~{L\' =SІw-FޏP>a+A`{Z*"gNLY*U[.3ө i$ 悘x*)QȬN'm,43 ҕԖ֖ MDNKoDWH[\B]ձ`.WG\xoKfr}KL69[x]# g)Tj K//+O3QpӲu=pWb +dnܧ`8#@8Tuz⎖f"wւ!Y9w+bR;JѴ7[{:5&|qtjSVd^8܆71C0jΛXQ-La +K$55;$2p %|>j_+d=7FsI9 o1&U]7m0BiqGs&h{#rJ 5&X٦0B՗?>B&g!),rbƗy<.С|JRcb P9O.=L ?vaR :ܓHۨ}OKU\>GHܡծoFtR b`?V%Qi]&nfLaDl 6ǵLgsX4<ۂFD둽ήuޭCz `!n:mrzDjb94INp8"hځ'ot*2Go[0Eߩ;K=3SxE +mm:%lajsXF뭊r"o\QA[kxp.FaX7<7iyzi,WpO4'T@'47.Z`j-n+E'x X vdrRW Pe&D f|>j)I|#'qF2jn4p@l}ئOJ=s &3%2 Ym5K ɂ8Y|)l=hU,WU0Iָ:<2Q$N $I0;0 xi_"Mטxʙ;[^<\}X h W ԍ\Kq' +x~~/7ؽ_ ]a_/Զ r#xc~K(ˆ,ʑe7퍝]Lv&C '69:#q+0VX b#ჶcf-6C=5 ê4C2J/"V6Ii•OqlAH};A Ui"ۮEVnr~0g2rL%D mk,>Bz A'nڂM&M .=g&+ۙVY?m-u$^ҧZj 51'z6ޯcM(_LJuD*Y} k_7Hɬ, Vd7: b^a8f$-K$<sL>`3 _;pD-K J 3o)>'pEۆN\>{ 8Ƶ* 9SaM>! ((Ż.&E4H2HqOX*<-1KO9{Fʒf08?xm[&g&6[kTF!1CèaŬ 6ޣn~#k'GʹdgFu}7Q-Ny+-;ü9&jS.2?j]!63ׯɳ,,G :Ͼjo\ X!lI2Tf8D?*GBe,jdCZr(w"_Z}9$A=ěj 9D].qm"МdqEVŕ,׈$жU&:мfT>޵!cLY.*8` T ׸ϧ)45н;q߻^w-N4*Ե L5}2Vq #Jl/&ى"O`Rl/KA lz0۶-Q_ zƖFqAN7I`s>IUP=n)UI=*I6lQqoj`ucT/guE٫\Z50/Ib* ^ vw?8#GqN!%o@G U_'}o +:1T(,!czW,꣓Pv>x4Ц(]axL\!*esR DRX.KHńkW#x|[Vw'2xxQ[d F"[Y1&{vO 3 2/ٮ>ޝt]ӏ 7?4K8$n"mS\ *t#i. q̀Vx'JDA/oZ-+dq;Θ[UOKL4oȯ2_%w_mh*ank7\ 1HW}Mlȯ񢍬ՠ){/r7FO16~7#y썀KE /)lܯӓp3X!nZ8Y?X#pۂR7+R(ξ T?ÀޣqcM_ҷc/kzג7+Q$(g#Gcp1Aiy' L%)ەDrD ~f'-<];Y ~QDFE  HC7ƾ}QQhA0TjtGIG ![* Uy%43~#`t\ AX d fyZ{oo,tBa"QE L>1mo7!" sC 7&]%=h9?:MI(VΣB0'ET֥󿡤7~ه X~l^uH9<9-? *'I )x6UrN16#_d\v헮g>ڨ iS5x"ǖ!`}E?mQل7;Űr9lȗxg0l݆u$Pq{fl.k?p. ,f>e2X\}PQfDr/[ ܘYZ)7W.ViJL@:ݐU=:@v}a4j&;j+F EIvu E̝FubLVGK|sEr E2E+: 'xI=P0;d^܃y$Ԥ٪G0nD֔:sh3J,?E3Ԇ۰@kfLAs.ZxåC" 7bR%V;K+N*ZIgO#6W5m$?sa/4d+N]vbK=v6:X@JL y[7Z͜cW dk.0︎* q/U]Ͷ%LBh&BܦBt:ƐXuzH3Ɂ)Rqt$&b_Ӏ% 䉨=kTi NM-In!H@K_r-K+K #>x 3G+^r6HC\:M87=w+E!{,iQ7ocHI`4&HwaFP%IVaAd.!mY6>&{6sX [L icNXw2uXQxMUnю ߈/k7u?3Pfv58jMڗ('ye.$BTMLq}4;UxDmp :hsylvJ5~?,Faiޕ^od_1(oncnD()zZ ޢoSp3JWD*C]c?~*hK]OU.S>} $db] }4|y0N0x U+anNN #^07i _eޝ=!'27Ԕ=<cN_޴`55@GP!-0G0i[enݾ1-Nqs2ۣ?,y5~{܂$9Lnw灢׼K$3., h?(nT\":Fn'-RYׯ+[I9sJ`R5;1m."c fMؒ[s^cB}+Sni |gG0Ԅ'+ VqZ,ߥ';G:od}F<7ڊ괉1nrsԌ:M{pƶ4+sHi?h,MR=:$&f$[Yt?+ |ઙ"9>Y0%Zռ9(\Хɱl{֖~30+R)5V :\/:ߵ nm y\{7\6FN msfs[J^ ]Ajiߏ(vURX>m}^(J?.MndN`=Ԛ'̩؇TFH5rPCD v녴ȝAK'8HDz&0YنQHVoMV|O7}9I@yCK7ذ9Uy'H5S+p&m,ĵ_1{VEx wGs0[BJ{mV01GA_=[|9*+<fgOͼKxP/l H;{IvHV6ԇ߉)S~bfF[R &/O, x]Wwդӊ}߿3P48>E U,ovG1=+԰-Pzu3џjS{ZIކOh[>'O,GX^:p׿D7=0m&!9mr.rTq$zDHUvZ !N9~>@@\T\>jY04ެ`e M}"֠ _KQgWr}eD$X ?Hf1B`6N6VYOض@jc`䐵# bJ2X5JyZ볼 "_2A0BKӒΘrzbC<)% AcxʝBeZwѳv J(&Nr 8lkZ)ky|yPGڏ?*qp1IʨPpD \g55>+>&P3mx&EdP|TcÅAǰ B!h/OkRw*S/P\hy8%'d4D̂"XdǕrbpS"{U0[qŢ 2ҌN" J/E!keR!$wǍ5wk^M? )2㝍Owhr0+gPV'oQxUΩ/U#PfHFXLHO,wPg qRL9NY`/̺jpGUQ{2|"ekZRA j%|i{̑^RfBpuyJr%8>tOVsWTˊu>|m_\Ҷ$:f]"1~1401&D~A30h\QWJjֹ?L^V]98=d9'Uţa4P?7/o[';Rk=]x^E%Aӵ:7%rQF-CҬޮ\k!oeehz (p !SY]>.%_ՆXK;ǍSs  i)1R m~"6X;6=Dan-U|ʊXxe>0bu;" R$MP誶l0:d="2].Аa~=R~-D Mͧ/8T&ya$Ӌv|}!-r*\> V_:l lf8d/bUa&bD>L[[">\Yqc cj:z+KYm@^{0n6]5BUZ]cyv 59ӋGGQC'Ou^& YG9A`TQT+HCgؙK  /t ʖfڇFf ܻ-P栻v0s ,ZtF#TPJ' \U ]!G0jJ+^@LR$ <۪v()u(cChn: w+ >+ȮF *JJ)T]l )N?poGiT VmrMFJw&y.j?k%<;تdCq.Uu;kL1S *K&WXҿFFk0%};E#Yw,!K+h&\z1c=K΅$0qkd)g(CIXx7(a*^LbgxL>ܩލ?P#>:*\2f v1ga:NҼENY-qP`X\G"y7>Ϛ$./:LFRy -xA7URI$蝘 8Pc)m!74H;+:;aᏓOG]2K0tRr-  rMo6& RQLHu@\C` *ҳ9Kn:Xk]s轗E8kjH6zm$t,z6|vd+|(VG*_MH΃#WLiE!O<hx@+4qW H70A&2dћ< )y[L(9_D_<ԢUCL sXC K@VWNkš:但Kw.g~ 2+0堂{;\.q[݌?ŰS4tPC\M@U|Tk&fEHkP{`(,J( z;(WH٣v0?)P&fs<@o]/Źt_bo O<_$5T$Ȉi tw$ʟ3JtSĆ/z~탚ta@ :ԣ!Կ_jBH/it Op,/9蛯S)-cJ3oxK]+J-̂3+oBnR$/Fl~(uxK9]X'Z/MH!ėnSf6"g>}D.W[׈a*%/V^p=6펀(+Ѵa'D,WX{·+W;hQ'y eUƮK4z3.9gWzOm~nlWL4y ){E&f]k`  ԯR_t]~4fAE{YRН.15!?1yCL,n]9XF ^ϐA2r5Ϝ|B-5xԟ:N>Bz`;:f)dmuUUO(3j(!-Oz?l ${N.m Wܓ8ĉ'CDpoG#,$#O%ӤGrC˥?ƒW,~ݒ..y.CU7FSf F] MY/ e?G({EmG-"t`$IxLjm7^4).5C\Hij_ovDn"HiG8< vTdd &z%A]++J[&QN2e4+KZ8SΠT7u{@ t.K[1fZybe0:dyJ€![34/gqt:;ˮ+x rχf9_I ~_㘾JI"SM-'9p>Wҫ#ߢa#]$ոmo~~T k7x6-cŪ_Bv%h(=XHil9Zʄ p,Mq/rAn, ,;MTbz18т{MTjU9Poj)ڰl/'>4Tsf"JISD4ٰ,;va$ dP&e!. ӞTExѦAEUPL'5qsB~q~ƃpֈс?\5sdN{͍i3;<~_2nm2Gkm{R WhI~!ǜ2SYٸ|9c~?@rERN} ښh%'ɃGR<%Zu:#׃?&%#F"!%^Fw$[؉<mwFM>J}nsrR:.j4n}3] H!ᄵy+FC><$LiD0(7Yڞw Z_49t϶\ jagiEd~( Fl(Bھ;ѣ1D8|c kKd;>6M$yF,\C:RO265Bƣx Zף}8'F!Zh E |FƎe9CZDt`Biҷ;Ng;̙ӥZE;`’,'J]DoҥbԱSPbRq}eԸ*M ݤ<Oب)|7#!L&نRf51U~% r79ʋ}S{5GdO9 ]7ci,ǟO:/S_+yՃdɚ 8O /1lB q9I/x9mHwĞm~3aOmf,9M*#>%P(`D`ɹcn(Ȭ8(hI񬠣:?VyfZӱ#*oO`U_džWJ-Ta`s>J@\%ѡy}> wu1kj5fӮCz(^: p:ne+%uQx '.#$H0A808V´)'ד ˰5748f%ZϏ;>^ĈjI~L9GmJu~4IӵޗA>k|Nי4Ο92LBp̩5z(޴3\qy6ż0K6p<=+>*0"+6296ojqZP<|7 |6a6<oBȈOqtMTְCt7VQV\hAk,𤴇,M[^9sg'iMx3^ ǁy-W`fc}^9D`_3ȵB6۰@MxΒ ?%p5~RpnrIe,R k4,}]EGxt y6WiFY/bS|=d YFE+@{Ky~5;:u",*ܦ?AB }pv4M4Q_(.ͪFa6sLUWPP632cT#`j<}UQPedQ޽&L-%g7ɳdћ= 0Z6$NI60&O?_㮏0TYS5ն.Gu7M6@JDv-Yi? q="ݗֲT"ǼnT,A|$X&CA[o؎g|BE^~QRƪ|*w,<֧wm։ ֣<[K LwM'yـ4B9*"b7Mli>Ly-d#~ \C- 7+ Sk9vq$ j)rz"ϖCmHڄUeK|`RJ-ߞVsyhRzRiWb$rby õ{mƟ;7š]F`+; FH ' +PTAԆX|I:T+`ǖQ[/DŽD)ȧIì&d8G]CS$!( r 0^V i,Ds*9yB<~皖gHQBY[Z]]8z~:ҳ>xݕ?wJɛ*^YY=َ' VʽL6!`Ahg{6 <7r]p=3LPۚ}UjVzvH`3+>ˆ$dAšUUЊg G%? 86-0(Wq=ii5} ևm`o$lg>x!F֬fGjOH.?ļIDVԺz6f]tt/d͜#-N6A, @8-2v+>]sUpH4SJֻhݙjy'V{NKa/x0?5WB~kX6AƷ&><q-Sj7qՅ2kH6\>\*T;h]AUPh6<SkxOB HvbѠaX[1 L'QA=:6nN6MY{k`ҭ 0G*_N$vw)yo,zqZ)Q/ ;sUh8Z_ 0Ԣȟ8<8浐CMacZ64G rAk}fAQziL_b"@PK`k6~ Ѻ/HPg\0tP5ȧGvCϓ9?Ət@213ϱJ3Q3 +{fG:DFjT}=Y#ʛ@*1'?V"Me s#qpp:Xc2f땋9˅KKF=HyWN5".Rjhlp70zU&_^rn5V2$f`ڸ)vA.uf[Ȩ>a?K.?"AbV]wteCwJbfs]8]\UUDꕱ4`i?qBxbBkgOVS[RYǛzI=Px@U۾[҃ $n>CIv_%>Ge$:F@[(deY-L, v2w:hu[WZ&;ө~hgZ1n/,yW&OGl=3N 3c1@b;Y`'+m\y2+:P=D*f}".ߝحڸp8 cٰi=TEu@A:$ -$Ǩ]DoDpѼe!l|!vt 4Q7{ùwK_9t @%wMtS{%LwaPJ [sx;9; Lj_/)* RImd>]-'9M{ӂkȏY&Aؔ@ğjP|Q4sK_4#"N~oPh؞Nj7э#a)㐙5l|Ҡ&/3e J-dC-"u#8J/閏=mxP\r}b+M,f*>i{oZxzwOÈd;]F; Z{ZB D(S,8 Er+ƹ  P[jX,kY 1;V~BLbHMfEo?/xgH&#}Mao,i+mY~1&tnF*1LRNbpBc{&]6-Ԕ<%]xxXd%" y~ޚ ?,pA 6$h$׭f/MB/ڒ#l.VeI0M a}v۱yJB]ήu۬yyAc_ӥ| r3z]CV;GaU 4܁[C|*?*- iVh*+#Ջ0+Jw"acSqw!A?>6N)[9|O®^\It sfo}ӅPjX|p6v?XSbVhB+.50V +HM)LĽ*Z^ms]΁j H.a"6vll&Vp_"n (=} Ȝ&u I~-`a8-lcw͔1Z1J |:H3=#!^:s5WEvdyp-0qW{?3C%F2GvJ<bMRIg˭:C$A[+㬸 vCd^}q5@"Di'L|,mLKI+/=-nйm;!{=Dy*8%Lg&a oo~%WL+q*Q]3~\7JN^_O;s@#zo-JG~lKkO\`,nP sd}<^Dr1&,#T/۬qSKDkIiF߉CzYd=fJR/hg`wi)N3j%'ŽR" HkTv.7aOcO.v8K5 Y1Gc% _스)/mEJű{j‘xbr.VWVӋ6ndHe^<Z%葻-l-Tzփե\5:P |0UtT jh<#6 4@<¤ڥ:ges Y⏊ F S&dg5_xYYв|lqsf\dm 2*l_Jznb-+u:ߐ{aώ{F%o,M % -g0zgo'"@SwoA$tponvjb[ᔉd`%j7mpk=K#*s"dL+EU/DL i6ӔXVdS/VWl`$*J~R* zo 1ϒ]Cq 'bl|??Ҝߡ`˓Q@10*JY5 uz?`PGdBH-1h4$ kXU=B3T y\=\ÿ~sOj㏾xt"ؼ2RzaCljeBc$WcFϡ ?۩vS>jk&Чb <3y~JS”"D}e;Ptqt\ʏ 5PaY:6Ӫ2k)E:ștND~m{$}뽊OqTD^!q_k'‘XjymEX `W}rC/sB E}= d|kWbRIXA%C|g{X\f|I)l1mJ ЪӴbw:HaG }xs3OrLȤ:kh>Hݘ,͆ ,{}4~>ܰ5Tz6dE=yΚ8ɤu^ocue[zoͳz@ս˄!7>+-o)YW.8ZQ7Auޤ:i$mPu-g{P͵d#:39܌qäDeg?$U/+`64dxOI<в{\qC  1R1Fs 7t94:is;Gz=[I4.S. S~RlɯGH`x WjQY#L+>T1UBu=C[qt: D: dQ ގ>fТO]PAp{ƈ.lNPJ}Il2f|^_!(5?){K#uhT!T |v31չd3*VoazSY{6 ӤaOq-;319[YS\ruʕ_h=5kޔ忽P͹^C$~y#iKEH,;;`qijxL̾0`@13 &rk|Y_3'X tZaa+gwe+q[;lO%´c BMA:o&oq Vr W H}?twf*aiЂk)bͦJ sMzWTHjrpr{Y-y^ʲP# foLCwf) ,pHo R@A< xK"5+n3|&SbZz b% =}zFdt ԾVz\OK6 _م➻WP5p}lKwr(w3T{K2\.pS>zUfY](dhLkx m5fM:nk'k|N87-r^p~V.| k ZU Ԯ!!v- x7+ j?3n$4wR,U]pJuxVj;**k$D+&RTXf|s:Dih:hN͞\Eg%ĜtrfD}XVӟp^[yTto`  oFpSn'xG1XaaMx;=_D֩{14+90c]],7S{uc1!C/eH lK7qeݾ="3wGUv%ei1ې  f_Yîp Etj>Ɗ3\^}3J]Z`ڌi~jWk;K%3֒ϗAt"A[bO?FT"Ǧ%6.wܢ}\#Q>urZ<[px#rcI9*!!:c"'zЩY8#L͜+g$eq^?l)F*vLizv 1q/6 '=C7)oc2:4~%"#ZAw3Q*IE :M_pMҏ'[^B54.:<=uW|oVt1oTݠrsCQ%qp:Q9#z sV_F%Ld x5<|jBR)0pCRM:*ɐk`hQ{:Sk\WDRR'*u)Q{'05!7u9.e0;Vgð } ܕ՜w /f<, je'wSf!Q~QӭXୁ!j\kޔ!oc?+ P=RyqǎڀRYO癝zF#&[eI%˓WXbcϪQC̙RS }VԜ^hu jEfmL_ "0 u6kαqdIxq6B1uŎ2 Q %cM3r ch ۅhlB cXzz,Cg`F:H%C%,m박{[DX#!?t"z/yzs=SGޛVdH{'}61Ha㏈0^Wew8^xqwtex(6ۙǓhBSs<..l~ANv5XiCy|W{p -|}I1p?Š;X79*im B SW"?:גFET=|R9I +3MG0~%n%*Vw5csiʚ&= g*yGE8 ^;WSw$|v%(ތiRj{z$.[\}zvWjؐ9!jHįyQ8gk?Чod>tޥwɨVna֨"Nz@p-]{C5RUԳi#T4󱴠}PWr"}ۇ',71lQ.w'to6<2^~g-"-5ۊf{{BijI:!D0BknÉةZq!{P%ZʆÞBS YA@RH -}&,_R:.Q{e4X}anX ۫pBNh$ɝvEY3r6lzXލdux# 6 v! zCP 4@O..^e(RUobWx0RXxXo*)tnio3N*8n)!7dȁO=+6)q>"lFqg[ܭ'ѵ9|]{ ](D&;)HѺ>zSʖY&N҈E*`'Ǒ0$0E:8QqB;H#xBgޫ;8 ETSލ32y$(hȀE%;HeNz_]~'TA2)|#Yp ;vKs*/R;T>/ ਕE(\7֒qcN,n=ߩ/3PSA cCöZbw\39#GZ7rVh&}_BrH{0% .`n"b8i.Hjh)vaͱ;+1VXwaHeN!Skbb]2Yч(pQ-YbZP0Ožن~ J#$ _ 6 L%j`-d~%0 d,n˾3G1(8:]e{hIZhw*J38ˆsnQ&rVryVY#j@oz0V!CgSlf~5.zfx=2|.f39OjaU4 $&JHnDCWpTD6{HIW)mi)o˕U #mFЏ]!N#jA~QWRi}Xe\S)&lTFD €6tUiK=|wNbUǮxPpnAru:tI[CCKz1uI>*xjV IJ,薝 LlFCD#(VD&}S-;DECyH%w @ qNU(< PGG[a h#h2DI V-ާsnI@7y2ؘ]w.QƈoTi̬јվNc#Lǚ[UKүSdqϝi \8 =QrAGI`*"CZ,刻R%e"Tk[v&N[qҏzPLY|~F.Y+ >&eI1^^o XهF%bi4; (mι'2syJQP0fC N4nQ\9C&D=.&<mlW: BmX-E4bz;He^31l~ nPWDm}}6P1Ƨc\UHi׹Fk_fu#m0LQ/8$ 9m WG9 7nDsC㇡45@u%A$lQl9sLо5dB{ C)W?_n @SUdzᐹnDHQ9dL)~(ei "~L/c03C(1i<4ܦP_﷞PiP\'gj"\XDmz-"nȻC]3ׄ3idؒriz`JrJC&57Nn-9\y6g//g㱚˜ұoVy _+d"W{tژ>>Wzn\g(XޘR|afp{B~ UCO;,2ÞBʚP(b6 `&Sv}%5e*kz' LҢ-SLi5;gO,悬M:,W"@t=mkW++;@/,FȚK#J2/iLS8$˺~S8. e6KLf9^JjX#' ;_ X!+[CwI~ 'Cٰ@8  lC,>rD{VГ)#'{4qlw[Y08Kd$$O蕞e;b%zhy8W'+mRC=;~5/Σtю˘eN1oyJpC;)ľpQO?%.3;t{|.jqxOi(['3^l+Yi({8 ~4QKB\nTMa6J$:v\_ĞX_25f%cԦ>w,ہPxopWE1)Ndduf:Hͳscj9wD&mL#PC7vx D*u58c `+N]W^ZbsشTd4G"'zq[ANF:""gaoH;@>O.U$_m{S6jjJ7(C(to b{Am¤8z%]8zV$R)qf&"0roPֈځgt*dbײoXǴ<XG"*Kj۱_r8&bا!nibjS4s-E"p쎢T.i,ĺ9RAMgT_uoZT5nG,@hRZy2L6]|[!4=S>fx\▵ooƜ1|p^5~'^|y{k@R&s2 /ݠqu #Bʪ 37!3FqCCa. PJ`&Sz$JI m=?HuD-I1y)k D% !AE/}}:?Ax:Y+L X/q:Qi:-\%:2P(a"?YR҂$e}_zt Z"m!Mܥ@dWͺ}M9-<$I`'A1+stWgpo'3xq+BoOfJ<hz3O#lT@iۨ SYҦPZ7Pđ% 0;rE͒sz"\/~eKmnCRzYvaŲߔ4]c撼O̒d:jc3:i^ d)g6F7G`yC2a"PzxJN~5{^n`Scc9@BXJ"Hlc+G@k*4Q) _ܧbKs1gYiXсWFy(Uޖ7%ݟL<,A$Iy~=`|X ,\MuӋ EnZ y@ad%ǃp`)i<Ƚ7V Ǩg3\7] DToS`qjf4U_jfCw ZR3d$CnL'c{Y;^^D!*:ܑTL@nZ E'j%ʒD\XFTӼ\Q5HKyJ%}\uTI:h(k3~g"P贈8xqnęf뷊Q#0IxcԥGl9q3#kxYY]BM& GĴ(!TH[ pu52 ѫHK ž-ߍZDթY;o efP `_cZ4GWy_ MO+$]eQhYrϥ'|B3܋.Wڵ'Frm/ӂ\x[aOR#940|̘nL/s<+1J?;AhS\KZghs{ݞUd("d+o CxjuNHtP/~ג`{k1Ĕ : ey#E܆e,rXwlNo  &ȓZ.h[doTp=fUZCjh`@ffn w!U#n;&.5:qlS>z"ـ( M;^xX0Ez?6 V[SíÄJO߯^G 3(?("YR ZiVCH/ 繲}-UR NflFbj6t{ej/_ ,7qMϧ#"r&mljyú<ΚSB|P"t3$޶\ ʹH5t+"MNlTB)Ì %#拪ql vxpi890/u&AXldQ8-g-pk 7EOA@lu$39CcϯRW  )\S%_?t⻠ENgrZ_V'Q51j7rL6= Nqlئ A %`Bs5WA|ceWPNk.J]l=#ii5@ٱ'8nǖV9d ޹&/IzOLj RL U05:xns$t7N9_/sq4 r_h[sI'~~(M|y-f${Q9j"!-LfOAM#y]Z<(e0H#-w?L@@Lp),`k{No7Eu 5|{zF V\qr4 "mN&Q *K7Sw6SѺQjG޹Yu:nja*7k 0z@.آ`=YYǴ+M*7#N}H2aZ?KK$&Hrb` _~+O5\ߤ"8c ke {yt*CSxyʱYuv[\gؙx/q603Q_TuSp؍j̑NCYqZ'KjZSaV1H )-h?ۑ·ȼe⌒8dI@-q 7/{]?7GzyQeL(;ykxY,uXK/$ytHÆGȼԎn= {_ E6DT܄f-lJY6a3o6?x-3E*`5IvE"FiAۖophO?bK3T-oH;AhXȮn.J{Yn%/YcV$Khkfk_ 1O*#!%Kxf׭lUD\v8-@+b``^cT;)3OG$ߕ >Y72羶89j񛊭-%<"4H{XӖ(_X:/Qy9_C*WR}hvå_+vɺof:-mW X Rc9ğ2:tm( FcCs Q8=ߤ:ҊvcwSjǥwlZ|n ДF| lR@\qBu`ghe6CUI^ؙK?f ',۔,+Q cbTQ|H+y%%`l 9z#{soO $y9z-3 ZgS)T T ])25nh*"5,G%֔3$ p\cWb䉮JY1H7Gf]h@OMMҡӤ$6эm7J“2J !KLkݶGERÏ+M(b(U)I,@;#zvn?!{jZ姭A^nj}`#ȶ x}0mG@HPP6}JGSGD< 3P 'MmRd_@[..[^\9CiߞQ`?V'uiTƟWLTNU%X%r/&D=zIg 5tEY0J$ z ՑMKAov< l{R}F+ClJUs5o7'==Qz0KBĪd/p_K~ß 0s~\&Kx?A@$=~ԚLx}8~&1i zJBf;mp5X?'S1v vq6ޯ.bYU35 n䚽.4Ȕ7אog-G30\kmIo ˙6B62*eS̃!RWI1n 4ζO͐kѫG|߉6Ѳ]-|+4$m*T'qIw x[ldsOUTzaEpfN^'+cv[/ Sv 5oZ Y hT#`[ٳmaC29Y=N3c:B<*Wqٵ:Bn \[TT;^aoM$/hBO.AHj"}to&Ze:^nXhy,P>>Ĭʮ3* ”a\?Sq=$J;^S1\Mpq䞻QNn7]'![:1*[@Pĭ{=!ݪ c1S+-R6O9;˒q$5|dϘe# ,DduMkS^;&"a2Y9p)!YM]9YiZۙ# wVpyxuefCN(%fqa9r >&d8?T^ \A+_ 1c",#VTLM&V@*IʂW{"24EB,꣞vszLU~~jw*\+ţRuuD;_*6IcW6sml) Azbß=ê zJNJ*ZC.OyȌyP0`O*%,\̧W[Pkɓ6 89klW؋:DuRNfx{d i{KG{ʦ흟i?(|q%D*X"nOO?Ky靬r_^iT2DXխ*]" Q;]*x ~qS(@w'7ُx@'Z`fM;aɹ?\Njh#MW\gkJBͣ yAH־|/7[]pA,b ̯tɑmg3-͈ 1c`9yM,4NDnhڨN&}BIbX3֤̓=99C&nOPX)9H)Ou \\dLipԮöȲQ?NեN$~O8GnU}QPK:2U',mt{(5%}Fˑg~,+ۓ׿%Ѧ߫d}&0[[1M*u<]+;qV \ʚ$3zWd_zI7+~JՆ?/5n R>uI?6 x|dGhC?ai C h9c Y汻? UU*n85F&q2IdYOHͧUT ѥUM3#fAlk眕h@+tcyk!ʷ?%YE)eU yCNsQѕaWlaC8XKܰ0?G_ߠ#d`- "O]=z'-Drl4W} B7c߰f@{ndzV=nǠ"cU ıb"rmK*Vby3˛4Ӈ1RVkфjO{yQ Y<:4tu7Uڑk6<^6L(zgMQ`pG0 x]|Y+b=`A6BK܎l+8 ɅZzOŅЙ4 iAb̾n7Ƌk )|M|c Omkϡ~9Z|k,;q.1,76,rEU4gY(XbUNC g|F^ B1WDmAQc3>$H2+ k Y~ Te=Zpqji4پ[ڣ۳d:v 5ݗ$Ջ/t$li8"mc%G{?U.){ PB,o^6fZx aݣ[9yǦ(5RˇC@<Ca"LT0gU(g꫁Dd:߄h_$;ҡ4"-X/:'BYP ` 6UkK?RȠRSA,uda N]WYp/ωÉZqnj04 w@cgPGelYD*'qBR30n_S} \rGFwB+w tv)ꌦo{2O>}ÝNrDE |MouVCYVߏ™=*խMvM?)ҁ?o L[b l*tnTOxri?Y.=и@ߍ]Y,S ES]r/0)Tț!؀ɦ< @2iQhN5ktï755x L1zx qG.)Li4#ڡ<5$̯Q% J(]hfXv?jb+R=c RE|pi =.gh!C#glBF ѹ"iQUUOwx7ipk+h|%\PSD>@JL8DtTB)ζwRq+絨P+qZ_dֵM.a!>nl28W%`|VB:{YA֮%`2F {RyV*{VcN!~WȬE7Qa8ۂys?-gqs@~K*v\q]\**BTXWnj22\y.W6 pai^+(8 +eb/,ΰvzgE&'*Y.Ͷ3;$-ƞ-}=挂&Vvf^޿V)nM:D2s&|Pme?L&w0_C\W\eFg#zY,%m@3VnWx&B>k$Q euZg1XSd:,#n]m֤3SU2 חk.` `1u/ed!Mg.-pS/52ZN68iq6$x+ :gfIkB43{Hhl0#ZWv4e2aq"VZ7% | >ambEوPm lƍ`#~[:(ށ$~EF|k>]\-/V /Bꔬ+t~Jۓ\q vYʠwCOQBXs߬@h;ē 2AR傸=U)kEkAG':~0f5 g1B=(7߇lӞ"UB't'TzGHwӕj Je@NlϋɅd8 [eLF+xm?e00 L a\t}Z ôCtpe0 :S %3_PsEI&X<3a QmdP}8; w % ]I=Ow}b"0&'( \) BATr088yũzClL:X[ Rэ4k,%XzloI.LWmM9}I%|gPP4󊫰E3vCcL"OeQ2VGFU- rŽY΅$ď†FL/X6[3HWpPF~5Hz@1+mw8-Յ`k(Vb<Ny.oPEvg昖%E?6ǼW^Ro;Ъ 5=׬p_S6 `ɩ:m}g["!ƄdPeiQʗ=GD#cґG.UЗ:\' ޣ .Zleg K 2vT}> bb|FhЊC=ƺ.FN7b8 iKf%&mV+R.7CJτIڝzh>M.ĝqɅTոr &3*7k@Uㇼj v^_eFY8:AdX @L% >ʽ}Ji.k_[<ϥC6%8pBrxoAOqYJ;q2.9@)5Sڗʭ'B >DR3S!Âuq?d}}d fBgɕm5b1jMʋ^toﵙc^f#8b@4WXQؖ 1K9hz!÷ 6ql0\ƛr~tڊƳp|~*3V!ﹽk Ceu~=n%-u!yL-[M*"RRK o-5+={^nq ӻXLbn7&mi<(HRy7zMd446& >x+R;ȊCKX#)hST8y6йL= i 3]?&"5xMPdAxs\J,0PbtmGkR,1nz"4&oiZҾFUqP* $kdOiSWLՐtDsn W|TJ*W+aV*(!Q^͌h?9U]ustKvmO]1A%c@iA`ہ)^/YY\UKC2k:)yя+!nMj,nKs^HmNY\rOtp9Ns?2e#N.M4]0,l52ޗL>yj32W~s>Ҳd!Fy|[k\!Sf{#9| (Qz7[۷cH lqHxA|q$zSS"đqtI etJ~yrjptKS+[?"m(oSylCȭ׈6As\1@חhӖI;& ঘ!)Me{`w# 2+~lڛZ-1Z5ت` p!! [! f]ض1 {d !qfZ%O- d~aޔ˄(͜r),n'(cq2* Ѕ7qδu,@apV^aL"7 Gs"\+u#/5xjCɔJ}(/$BDٹ4{w#T=ɔpj$cgHIw X2ڜ, C+څ22,B#6 B1f u: ^cl anr$ϜNph.]^uH9u#2}@k">ة3M֋3%1]< EKBNt?G xKFC ]FL, TKmtUDy]`/. 73gؠ@8 So `B--υlzptK7Y)2ZC^=F^I ~_g[iCh%S~ 7;w0Dq6Oŗ*xrCSI?3^, hE^+SdB,a Vq]%~qƇ qD_6@N?x $YKt$ϥIKr^e;S<#mZ>{pQ#AْS{3̧7%}m=*^i"#b86p-RKd`ض;TZ5XT?izoktEKܯvYl cCѭ,(6P-cI5ywǏw-XHryG_woOrw3**%2n N;Vg&eDZT>~RTВQYAEiXyFf]U8d?f eԁ].4c1G,6gDϒݼ~!ܼ}@@#o</tަ=l~yid0ݘnAN)<n{׵=^Y͜U\$4wfJD\P֧skz7Cj܂\$w{;0,.Ikdwҥiiq|Y^<, ?b Xv[oЅQZoe\"6k* 7Jogc0D{%F?JΩ_'9y}-'<+uׅ_‹OW co=nL2 _jtE5scg,~<)ë́NNq\0@ |ύO:!nj ܮt?izլjpp -mn5KPsd˪fEafT.lCf]sC疲xLC\4I,as* ^Zd"SM[Fj!Em .O^&FnA ʘrb3l|BSfbvhvUL怳]1i>o۝@34E$pnTeVzblA["z+Q}땄XR%@U(XFmsF+X=m9ifJBgW3K?}%> qQ &fct%KY@x 2wm $٪eH/\lQӂfgx"y_l(K婜I#yx7ꝋ?0J&Ø8I )7o -#(pA_';-.F|dW$xS^Dna0ZYU(!]bY*" کRD(7a_X х7KٵJyNkT|g@ܩt(mk|N6?dWãtp՟(^jt~g-sM4aݠ]Ogц" %B֡jfnm+SֱEAQ(l--0^*5PFi\Kz5@ISbUb5:bK7z*o(5چ"C:]޳ލK$:'-M!*74e_z^-WA KMU^QƇ|ykR)hP|4sȄUr.,:Bm|3U,:2<Y7ؖCxbŠi ] kxl+eOq mIvW/l+d)=val]`о$Vjީ8aRc;vjV-'8I roB6!<{*-V%AW ѥ )( ?ӇUtYt[I3e3bnZFф)1ު _.|MFvIѦ4uwGQ+mBܗO d8_Wf/әؕ:&,<ݍW$2~uYD&JrQT?%:{j dJP1ULT)r=V˜jx\}gF*hǠ3+&ߴ멁1 C8D[Z#H9NLD}+ѼW1)z2X,%vOz,Y%"oj< 'k?Z8$4Τ. ^;:/h.rg$J[4A'Ȯy4 9%FU\A +t ptۢ7hgrT!+ uJELm #thL>ᆮyj3̟4G}ɖeAY5Uht|.!qa򽆷x*@:a,8/Yͫ30!*bNBXqw[^ ^iUW٩e&+ѵU:dnI`TS@]@+;ͪͷYl{;a9nQ=hFZ\r+CagՋD Ol!0 R4WGH+TLml7p:DrH*_?= ]W[zQ[O1}*37)^uɖG0oa_ҦuBH`ͣZ2}TY]|bx+]Ej#H`mbk;ZGk+/Ɠ:[PD,On|'4zX;ٝZj{7V򀕌xr7 @8QDJ7%rC&B4l\%ݷH{F2guܽDZ~?Y.@3ks~oҒG!1PJ5'PkYgT.{<;K$8-'C]d3q;Ըus*%xJ+{Iz =IVv0rhճae`D.;0Tڕ\ /[@D5S٘ L` !x7jbZvrW#tx4KzX{ŕL0w {C|2T$-|=SrLU>!Χc[#kijNolX38uJ1*8(<*W3E Ô ydQv?ɺ+`u>JX"{;AK0uWHB%` ǻɺB eQGtgONd~ctW<ԟ֕-8@#YhB8)i.u^뼐Lt]X=Ҿ*zstȢձ)ݵ_u']`G[)TT*95~Th Epӣ,Gp2LrŤ2[o>!XZfJA8xZɶ!Tg hT~^^ЄKvTcm9q;g*tQGsAް#mk·83b 8 v;Ϧhmގ z\/Wũ270**G~ևh֤L5Amƃ@~T@FP ײƾP}tp@'Dۂyܦ14E!`StzOE4£&TOSGfmx#(9*BnMZE)PU hn667 p`h% bqtd (RE d,hx)_n *-A5AJϢ;fz: ߺ%o??ELY6!t~󏛌Rev/ sawY 9C/YŁAyY|g6V0Y*<5Mb of1;* cnoȒX0,1 m`59I᫹cz<vIc8:5&bq?eCB]%h~"[WUn5`Kخe1$Yqԁ6Ky);lbGC#-edk8Ks^:E3h T'^Na9 V8X>V.(Htk H.CW|!D]owJsK)<̗'ԩEI7[&aPԶ]ha{}#  `tPt)*9Ym&kH<5JE/Ai6|{ڶ)_c J[Vwk 3|Fj ]h7d͎CM֗UHG RyYE9}A+u'訫 \ r_ PX6'qSJG/)2'I+S餴 PtAAՕlv"gVyc]YEA_Np;Aujj8w ۝Z:oBxeFj"n yZ %ev8sS{tUMHhOq/^7} x͑5wv?-3!=YXP\bc^ wMX *AgQ,}<{uvE"T>q7I;Z  ixDAN˞b/ 'zs 7[t+,Vi8Ip!q%b@JMMͼ_7V[i]ƫtJ-׿+ A :+;IJ>5wqWq0gʮq@4W7|]! EJΌEv~mTcpt2EܲE 5Վ֒.JP:eӛE TFf: >X4\v,(I*Y۲8 Ƽ1JOQe tjKo_y)P3CDBoxL|"Fe~H q`)CNX<@lXIx5{f2Wau]|7Rڳ 5U TvesWrB<#Q|Kv?T)G}⟆!qG'>[[阏`6v5F]2ӃF@Lۄ (cdc`}5vtU\[nvOF܎v3L{zS vݘ{1ϡm yۋނ</XuE?WV.h_&)7'l$Jڙ_^X[4 Xf=#Z{V3C磔X+og usn/uU~MVE^Rf+% A\`BVNS GEvZ($Zy`gc &EQ9&u߾cL:pӄݦ?7 JJyH7ʡUSѵ|j ]{ndSl++swhu mﲁ2a(|o'׼/o TN uŽ9Uw#Jfͨ XySuEx-[q1@hu-tc PX#!_px5JQb7"8(_!i-U-.9_O5ϰizgxT7Ar' hAM{tLuCiK [Ҧ,]2=Am@}"U$9enZȊ>eo~oxuzsoB?3ܡsH=@=T#u~;;r)riPwFՁ ^ rPPdAmF IZ;Rn q\=JըtȌthIX^F?:+{Tzw寗m@ex;: we5k+2+_WIvσcND)ќ;cbL/^!>m YgMp b \UFcwZ!^ wԺx,_!L;o9?>;# }MS*!|A[?i̸os=]ZQk}#I<+Pe^ Nzg^eiUaLuez#.RI&G`vl9o[-q@F+ju-Q0@!㪼 . P)}m #Yθ=;dyۊghpj_ߛ/gB4 sjƨ`0̈́+1ǁ$tqm"ɣ+o:lRJ>%DʘKЌ~(( uB~^KeiϵZ/"$2$#@?x[aZV\jUDd+hNr'3?|DIa6腨>wa 'Yw6:&#fۜ=k ,pDfs]',9sm1.[3JfM y!)RhWcR#zZvg&ӷ%T !,5[Ѿ[$ku;.Ġ[Lpm̀0]泑4U4h5 5 E8&sh7g.qTC(:Yl=t3"-STq,w1 8 #lZ"=e`6D5rΕt|0⠃+}G|qQ#Сd̈Gjj@MQ6'WtOɪacg.,1`9T˨Xһ_Q1a҇N }h|ޭ]Hh$" 6}(.m\z'?Z4/xJ!(A+ƚ2(X8:_<7/ҡ2r]1@^Aټc-5'rUySbd vO: rW L ^䱺|˚uSvl+W}͇[py"\#R]HK1l}{Ǽ*6ә:6Ŷ}#FbZ x%ư˴Nz0 ;zxmF!="0ju<)Iީ~y/nGxjI [r֚3*98W69R."0B5sVZ[} ̰Ek^q7%>|Te,ɻPf!PiMNOZD)ŪcH5 >ABK=!&$ Bmaw%Wl_&apE~3vstΙ_Ms8-9wFh5ϳbnХSF% Ei7Z&t*[$̌W#d]X%U'di?$eQufmLU$vD Dy-6ط> {]NGC$20캉/UBxq3DQ~Msz}8$nDG 2AN] %_Wf:1,$"aݒz?{/-joS5n;eWbWA=.7g}lߞgzTbǦt 1fB&yÙAɧ[  Ii}``Tp?(8asg% $}!dD/[8[iw Tԍa[ꩄ)n<;b߲0_o^xLP<.4..h>Uw_.۪w"ACnH]aGe'L(1/2orxIMM\{d ~n12go8)3F쮄ktR_G9s[YL+xvrj&Y舔^Ѱ(:~&bTՉbI5; 9R.{٬nM:Vj1Sbփ0тLeӕd;XXGʰE>JX#bFЫ,ԷZQ=spԆy<փ/OJW#-x{=<\ui>@晅`9cEyluE /ҍmPDI9.Ȼw /ɗhɬTt͸I,'=(R@,Mdb?C}v g$K+?wgx=.V7g>ΒdY7eVs6"& ˒cXWmeS\LNDeT}d>u0 ^Ulǔֈ" GOr`ѵl T)>MS +T.yf̈1X]ŽƝ-&3"o?gq&m XQplBI$Al<:?LBCVqkX@ߕ)L@>{jJѡHi樕\%pvT׵$Ml.Ztn0k3,G G#B&jTK<+mbAuY}ق62'}CiT#.o$XΛ)τ zVJKi U%ckvTJ*vRJ~#B|+̲UwYj2QbU,UJKQB'67e!߳ķut% e`g\A +[/~2{}gVDŽrm>ᑯvX0+ppH&%AQRjU.ׅ; No8&اGXZ`BK + MD&LL/S\?L65ǖG_؀2l R [y5(t`bNH,KPQC8{2u h\r7Đs1Wh5 y-8 혟AR^\o-{ML琤&|)5ƘU4˸ت,Od^`NmCKSDVYԄ%7b >$pF5\[LnTn}]7H).[IzJCb*1İ 6,DW.gɁXF4N]TO/ M`.6F]^F Ecr!c&gJR̝NsȠ@cg\os\ t.4v+}5/6Vk 5 :dzھa.!(_/d{I}ږżp 桎Ԋe%iO(C})c*V'Uw"L6yJ m@1x(8x,wQhïB6(cw$cs_*-{ e6/k#X겚>]۝VWg7һ@ުӒ=J?:ɖ3*K=[Y!l6d)>o$GS۞>A1ۼcZS ϋ ʨ1V`],x5-R?"U {^J~1}pR?ńVST6x[}PR7jE: KoHnCǟ~|3 C7_iO\Cqz`z2y\*N*Nsp;Tyd-N[~DUw ,LBJIi䩅,06}uydZZG<R>T7#ڀ?''c޸l:%1/5~)/)݂A1aZC+ g}"Dڍ0zﵵDljSJ&G#]4_ ]kH}Y۵ 4$G(C*M:>8fL:`mpƬ:*\\6OE9%SWȲ*dxP9Pr$+ƞ-BEj{xHAץˈɈ|P8<"6Qԉ{jcZzMDt1~݋RK{;ϓs0n="z̮%"I)-'j䝍M ?ͪ)TG.> +ի-d= yBXrakNCSXfo'ͯ$7JPEEƢ YnI|u pnjP:m:-)pY-=/,+0߳LjVl8HPyUΊJqu7uy{Z=`LOiδ#$XO/ _*(ww:Wlj}ߴy%oJp]f ˦eo3.Kq|[PV>MVvf]_3yL+gygLZ\N`ѩ2馚rZyҡ7NWZ{7@e {yHúwfYT>fǻ +mDO6bzg"ǫ+MfRFPdϨ>*D"ID ȍRcH:Kunct2&Ʌʚp&-1qkJLR3<꠼W~8a$X.seyu7]?.[o7n!UsifR d Ǎm޳.;LoQ3 znTmpƚ@>\8l KiiGe*ݫIt$+gyS.C I[ ݙWyX3bE Ŀ=b!O5ba1סy&-p(cI0g&e̫0_3UN#S]=\`/] Iȿ7aw&cz=A lK 枸W@sj^ C\?HSK#RfDl'i=ˆh$'v6+k)aQGT!Z},eb@$or;@s>QwP Iil!mp))RtA&@!|蘘NrߴcՉAsĤmDj=Te+ieN:_d?>rȹz%ZnX0/y7t F2Blmh\ }_pJ f,}yb AT(ڐ¨BE%9Ya(PͥdlnSI| qm3l#gdhwV1PdBj?tLYΌ9|ex:`],:y[zZlV b~A?@x~+9{ޟ~Q^u>oEf-l1{H‹T\@s9¥ K(X҃5'zmΆ"+=*:rO( 'L`m]!p*Ψ%&eLA7ljnYtZ T-iN_}y4+<-ʕu3@`8]ˬʧlGY3[!a+dxv[\(MWK[I$btHdtg󯜇ctxgހn²24u[k"V& MV@֭5^eZ0`ϔZ뉂  L 8B=wED<@Mv5P AzPxfm{0"͉*mDXgB O4sŁ?`5b%0To@{N/OԨp <;ňh }JtvJפ.f#.=dF,6gM6*Xb@fxnB3,hm-P\4 |(AumY/T4C5byC|㋎? D۷op QjW -Aپbj'W׾ DaC]6UtVj`@`dHQ00P؊GbG2/9:^uf÷T^).fX2@׶RX9 9vK32A4hl(wn .$>_SĹ|&:g2 ^JCq#%> ھ'|/:Fnb [THӆo}|Wbi"aWlZ,$(!.="eTm=/6W_c?] Xmּ(guY[οg^u8ɐe`Ob:1LQ5f!a'e!9))H 4Z̆OQU4}8jGY:t_ajL fW^g=@( %`hdCkI\Vs'4$*Pdym7(\a~֞'k >jA<ԩO⯶*- [R`ډ߫PWS~7بNq͑Ļ}!Wu[?./y;bێnW, dVөڛ˶[~&G_ɕB=AR%볦& w2מҀ8{Lhz@z>j2xR Uj-*ELlSj3mB21vb>@PLٕU:0Vljt,}d$;;2YԶS?SU1`$'p1b[EkVddH=]G^})USCEԧ.Ǒ疥Z G0Aђt+$jevFb_v0*g;!]~F5JIñ48TF=2:W}M9`i/n)gNjv?h8Pj Ǡ v]E22'dG(œQZw(@U# F9$öN - |ֻ/}_aQ}T[!L {g F{A*`F?hH>)*اܤYm sE|A^DK#." < KGp? xbf2jlȈW $^D -!qbn #}.cU$JLg ^DI?>nCUgU9ǴAYk. ȶs@-6lzh5 -̸8L̬»ō<:?h0#+7 !m{cs(}Λô;-Ҟ]1dXb@AMNCkfT.@㩎vB@?g?e0C] 4g=(Lw-cfU_eWiO̎X`Hma‚XKxc ȓ_v| E=6uީL!t# &Dg#&eH(]VewxqfĪ` WJs*%;n"SB8/@qek"d@`R;?E 5nx_ؚsт6Sxw - qAӌ7UzS5ƫ 7;.7b"))?eRG ֿ]9;1?kP·GDd) I*6Yӆ Kc¦ UZKG tF ‰,e'Jػ0v5f[ȃU~Ǥ]/o;WUgƵ)3>4਋4PCR{lAa.h[h jBlPfoɃȧh.^ySJT.KQdцKP郝 2y BBRprfYh(pᬏ6"(#D-ƺ,$:ԄWu U| mPN[il278]y*pE[ ]#RƼ4\]cV1p ^S4<l=R_ w{9R՜fvagh=c`0LWBKb`ņ57 3Nԝ lTtԗGϱ*%(m(4JWLWqgh||F4$#wHJoӥ 5E `uua0g|kMR|ۤ,Okc"b8ԨM'A,;5|$>eJG$d^ࡣK3ϧY_M#(z3,T]HXR%8`Z e4#4i 8 W2]9gbodGǶfX=})} aL#kzn >w](9侨h%h` L0K;"ހCOWٜm3)ڥ};;_yu0~/\ uNͺ6@ƣIG%=ɭ2 0lkŽ@|" 8:Х1;{ΏLhH~q{LU|ohg6?'Fc݈eh*ùӒ;/.b}n,KOҖXƢ.IP3@Ǥঅ#5p|odWKSK j)#煎8H俐#2}P`~r3{Y rO?+8AE<+Ap w/#2@BzXԩ\R&dt l1'>Xgh`wPqdE{6 ߥeǤ,o=򒚑jTjk/UXRTGPIyLIJA$ |+X^(s`vU_6qd<%kfMOtJ;-ЮA̞c@}1 wV̹)I|PB5 IЎW'_'yqRt} ُ][M? 6nmҒ=0lJjc m$H4>Oki +nX_s=+Z>cfh  (`Ͽ y?XPxUc+6uwXz9: JD`ysmq 2,9|(gsCxA|WyP%Iy~\/Mi>QH0d0טҀ2}& I13]y5%j;9IX:.E3S5NaBr#ۧOj<~GoY@{^}Un `ɡ fRa€ny\wX( :=n݈Xo} -9hX [BѢ?r8vA&G/85`T|p۹K=s=Q?N+Z :nY׏ >1AL66{w䘪Ҧ.,\\BX^t4kPjSàCvɀM/voͻuD/L1giϾ DRhwUzzR-ڻA.+mp'Dqvݝ7Y؎,lP@bo}v1z|;d+qt/iyx(r]9SR yMDuAVR!j ٹ婫zbpxJlQ$w3PJ rȭS{Op+| W3P0ˈ! e;?M,'lEKЭS||pبG{Qs$@pv+ٰ֋ydQNg+6FND(^,%Mܔ +0g`vy"Xn^ԑvlvq"S|2ZB9p:E @R\n;!C/鮻, ɗpw"GUo"}cX(`NhE2+Ԕރ=2ժ(G84sMth{Y +HCf\'9q2@~(t?ob6QBR<꼰E8!t8A"{CD+=4\9É9._2=KMD}HX,#gZ[-{ݶe{`)Z^#Ow<4S#@ C I_5o )Ȩj5AC3CِJ-xs }RUAƼ6>p@8g].r)׺JSM]E1 -X*<%`m3uAul#Ux 56:0H})j7娛H4AEXGX*Er HBw7p4|W\3Ξ i~ʶPb-vwP n ᘐ|{׵dRF+mVZ lԑ-թ$cU`JE=wHwINXCYCv'`[ىEihR@;՚U~!x`~ѣg 14*VLi"c3%A5Ǖ>*t% *|wوEBcj7yp/gV67rTX],=PW'6~6X\+CL.Z(#0?MP /A+(QrLE MGB2'?S+~҃ 4F[ٕP?]ZZ{SxaxZ݌RԲ+ UV`W_}&{1OV%?wg>ah%sغ 9 mTܠIB]@FU- ~q4VbpO[ Z`Xzǣ* l}]^&Q:+Io RH-O[ИdH.efsCؒY̍,ِ0%Mj /j1\{l,[QsucvͿSMG$Ձ$@UD^{ýx(Fρ9SDleJI9T#tOrIPF0*7XɋPX ǝ*ah )`pŦ ^ l7ӟ^78Qy╞2|Zk)G1&K)f.3Gx?`^F;+JȩodνF@P1"P!C% zl5Z~Plrhn(8^VO};wB'=ycה!B4{jkț=9C l/˱%Bq$w z RLڲ>UA;Qz" _! ^Kq:UbJi`F.L0+d6;Mk} G;tՓq<'ս JKzARCVQ6PRe R>|]%KՓM>iOJC| 7LʐT鱊L3Sä[ +%z샭.-B*8P,j~=3 oןlowU8jH׌ g|W_"G}HI572 $+a3V_mo"BNXgZ lK0mnube9Zw $4SFM5Ј@<2~Y)ly~̻h#X&DLu8-R8[ofcJ-Pd[r_Ki+b^]z4 ' 1{~7xeGmD7YzUC ͙-xZT=8y:I۪hrXyY4F,yg4Ss'xs8SQV0 QeEˆҳr _P-QavR f6;5<*ZqaYmӨuw퀣$蜄հ:\G9!*mf H{۟5DU[]}4sѥ4G['M5Fw/ԇ*`Gʢx.ZzD3u2z @n "(If?ꋺp"m,k]lK^]"zAզ.-S^myTZ:R9CM&&I'eGwj0W^Ĝr(G!DTUu&f= Yu R^>PYyYx Ib'_!ucd^Y6bUN`SmpW5ڄ&}'+Z.w\RM-?ݜ-&\7YHfHׁ*Yf`fV؊@`ms,@H KM>t_ z@]0a޷~~wQC1( bJC (q 2` lJl&=T_aJ8jiBNn$R\.kIVq)[4 k֪D!=i~:_!ߥgS}#RU%Uohⵞ@mz8Z :؈d֓ kdi?OCFF=", @hlsrTy*XEby1{.8`[@8E@5`0{um{zj4Р4XuIhf <&ܩ@toM3<gM NҰ8$&֬[69(b\ꞓ ,ŋ/LVa+ ;m uhiɀ?2EBW@{NuhM E[5y/R&b1_{R/Q<^y t7`Lk5`.Je%:Y]iH s n+Q5L6Ġ)by 򫥰&uZk6s]2H\K#pшˤ/CE<ήk]C6fByk4tMshk.np $E <1M^SX$"FKB/3ֺUddR>>8֞7-xumɦv&i6*SU 5c g+8CշSqnFE(H%~uIj\ ş1N/0I;])$/?R_!%j @)E>`>-KKHg:IIfM7Qɸ<=Kqȗuã pR9>Uľ0@1G^y9 6h3M R{ݮG Hiu^0V1ts4 k<95_=l$ P#9h[FF#0P}ׂZz?ad>~+UQ^U`M{1s"˓Ou׻>902M&L EpTFS\I"Ky]RQ Um-,x8 i{ٚټw\H^>Jo[0f%BJdCN" J0&ٶ`ž>'-pͽ+EQKLe MBų ;i^P:e9L*QԪzDt\)ِCԻCu(,0La{*)8 ;D?mH lءɺ/gE|ꃼFvf+r{Zʴ.%^J ʰIl*nbIjG¸3FZ 7|SrTx= Q(ppH tVvgaslNB'R'iD%r<}+G{f Mk!ܡMѰ{Z7ƢxCc KG砲P+lOÜ~訮#><5!0JJ1PPӰ"U8LUhIUVQ E/PU:ek7b ]"IST2۬G%GN눿*#A?O3JgeJAc8 ޥ:u SBܻ$):jMtQ-4s0]J ^3ޤiG4?}Ϛ6}Ә&3߰Bxbb]Efax /@+Rv.9\OzG „!U#$jdA$nAYFq܀ fx8ld5qZ Q*߁C{yHonM;sUXn`[#\ްψxH$t&a )vL1@p/>2r|mF.65b tTǀhyrشd(0)Ɏ1›WT5z@sqsNv뎚[R3@͝/q|z<$~yYܾl%kgˈlF\߽NN" ͣ3o7V S)Jy`O%էq ?!iw88(Pioʁф(ofa4%m\߲?< 8$ dބg7'7n0 Y(7y^~Hݬ^c; gX/3<[1vIW1:aبB`f(7HlKj R_j$}Ӛ9l$+ږZTmpmܵNE U?ZdmN4jBk{B#+@tJڂ|#f}BL܉-Z ư%&g1v2rgu9"ε"`fmQrhlAh*m+9VL/q/S@rOWE1_9 {" Z鸙yÛ(T#h^zhm!#╥c;DB*ZtsMn ȫǘbK`BDgh(PG6I)MF?2T[5zY)HpNX*ip\A(4TGeLk*0eV#)݌F Ah\S4o+_I{597RD ~X#xNZw:eb\Hz8:lIIr Sn}1*| ~йtE7'OMi WB0@'`i82/ urIvjRCz=8nv +iuAsd0R巿RL$pdYzfB Vc+Cwez5B2}Jk6.Iθi cmrG}|yPqShn&MIp" KA3eʂ@e:g5B ?0JbRˀ@dեzLFo"Iv.(a#Aԥ_>gicr.͵F:N@^+)cH@RP!*bE<ԖX ^vHXHg~FHboc HLmb.}|oW98Arh *^V~pTv{QvfH-J\h׆͐ uTD=i2mе*@iOq_78sp n8` QRT`zZ+<Kc:W{ɞ++ȶ#*a oYaie@(a9[`JH>™)x lCc E# 0! +ҤO; 3nϷq.=V%t0L։3R /f '  z"rCkN2pN:s'A1 λK JV'vke?X(Pə꾘U'CZC3FSf /-3)-qɧ>*C)ݜ8gneiRXsFX{\FnN^74m%7|^AUZ) qp ԘrorISl`Q8tqU(˂ 2B+޳e+zQQ]!`=IX{Ŏ>b̖:~$MRK4>@(J~ۀ+nx<7j?y} i97ʑLhˊk2׾:so@!2J渆6q8Gwy'`h΋H @_P|`Vk(Y{iUך)?1iy 댾f$)N\U ^/G6 Ct3OR 8Y,p@ԭ^Ԅ.A:U" w^tr/AKcHw(K5!69u9 k}'@ƧŽy %I}ኧ1FHQ6 $׬ǟaxyo= C*]"%ZJ>@{pHF"5 A-#_`͎"?3(ImdR {f%d;*\GƛZbK`sDO`UBM@=J.&pﵕ37ova-\2jO2*Ñܽ$WrŒ+}7TR%>a Uҏ okhJ\  xCeӺ"ŦUBY|Xh|'~Z )::"!!TsTO[ J HޡtF ެm qlͷFB~uFS윑S#Y1D4D-1TC-8Ԑ$>,8nʈk3c0]%̖N9%Ꭺ0pDqD8:nKY Vɮ-Lݙ+EBJHBK~>2Q۹4?C(nJ@u%yTu0MZY`_A9bDŽ7{p 8n'x9ZJ7/HFMK!ܲ>`kCE.wE#,[ϟ"z;xFBtBIF*S;[ #2+}\~em +x]6w0 zf s~ G_f%|gCk.6CMNyڅ^k}t0T~l<ՋyAk$ND'Pq)^E7$tBIF*+NW!kHBNuFƵ:xy`w rOߵF8ebԏƒ\,>WOn# @1ݕSֿَ݁icUqQ{fϒ5p+k|0eSԻOi߁CnRО9'Yaw*v(3FTv2dNK{$sې# jnqwOn"iڊl(@[[B Y@c(rRm9tCvQBV˴.h>1aU t YOT:Vl='O{SdQTX?AE?K$ruL5[d[8陱fڮf];'X7? :$~@B=w V]M/~4V9M.aX+3N"/ٟn0,'MKa"#[ z֢>xH ,twG5fVuYmzl$ɤMxU / S%m\:\r >Kq,A5xB*:s4 U1a5Ű/%뜑3)Sj?VF8JH~Ym y6VL9Leh=QOܲWzU3a -.d1rR]' \RGp/+Ц4 rmA7P4P!]em&AkVKtwH9Uz{Ŏ"O uC-8hl/Yr-mnr0Za0!KajBn\,;χ\@G4NB,{2m ͧO#"qj:@^yxv=Lё.6Ɲ3f,H, 䵪\,T؃yxc; R IfxUg@r=X6&/f8~?lfs0 K,e pm4F_ZLĴge(4w&."ՕjRloW-=\SD5joFНrQ"U ~%p~ӈ*[$_\YB9O`r ㍲S'?}9M>Q:{.д &J9's}چ@Y-Ϣ77EXWuڡ)*kfaBrzOОd@(?~8& ͐ې^qR׼;hL|!5Oj"tmU-8*6rʼnT-D(? :?CV/˿vY~ JۮvVSrԬ~"VXIKwLӘ_M,v:`ro߸?a9C3iԜ%y(֧ .K ՕNk*顸qQ \}9at Elѵ|fxpYvь2s R6JqIJ'AW^2 DroZ(Wv?H:K,c]O՗8Zء x-+-b 1J95` ٰ=gF|/'XwBP5x5@Sfja,T&![C4N{Đy VuyX;EUsܲ9ksE:vRGGi假EzU Q\)sp^fje`T/]0JOk&o* ¼gwaxyV~pRF2׋$΍^iCW3BOjQgFKQlyIS[w@9iAu.Dժ)aIiJJT="bɯyCkb}T hwuٌKcv$QcF>@Zzo4-J%,>TH_IO`^ ϕ.I}7\W5Ȅ7 fܷ,ۛTM&.UB g4-0SgKGOQMv4Y1:6! =i[J+*'eP$݅IQM;8խm JrpZdfeKN% N*5gc+1JSeE*ɾw}5lUJ{dy{Tc΃vy鼤I7JSXdN.11o8ѮŨr,,dX.eC!HLU{mlJ;]i-ʼrjO۞iy{|hqnJ# Vf ,%ռj $RL/\$XQi,Z2%f",% K(XNLvı ˊC04Ew 0÷8j(^*4ʻ8*w5{׹FK9'&ꀑҿuĊ`(22ūy/@(&vk0f]z*V9T;)VádRms %!+`mϰbtv)zɡ` d *c%llv0¡ny|}>=>ъ|p\wL|: ߺ[A" J="IR9^}j:V@٩n68Ё,6vsE/@Iƿԉqh2"KE0f[bLnK~vzslN!\tnJFnd6H#VC:~¿ 4b]Þ)jIzCNåMIǥbTac@b 5ɭ ݑSw)݇ɈFvZQr/ !8L#to]܃H_"֏PiAm셕5;lS`Z54z鮻\V|-_ aV"ͪJ ="#/ Mot7{'ߚ";Z9#Ƙ”Q=WN]Hȁ|@8a%D n(9-!sgX>ҷ~7%>k"|4Уܹ6V5Yy/]<Gq$xeaNTmS)sX?z4Jt ljeC PUi͎qFPbE/W!L?GWi/ UOׂU k`E\2צ*Ih!i`tj3Tf<(S2?hXW"qWC9O'ԒlR$LcUXBE$3W/ ll\_pP-.o<3HKG:pүpHxBNT/2 0t 9QH^v \bPCw[VHk[Y Do*!r9~R(#`"Mfgm?f}]96z?wY!eF6ɡ&,HYb>TE;v:Ý^D{׋/Frep-A0_:fle@=ViS8_GhOJmNCaX9pB!t v+W Ap'\&6Q2bfj?#fw9ǃ!,ʑךq>^.?5djuD# ŴPT]2s?T4?//r+(Ҏ>XM6mҋFc =yF1fwTx 6#O\Tg`KliDafzbia[1woY/T$AC^nmW!H3ZdN`wmPu8[ ʌB$ #3³d&Q2m u}W%fk[,:Xl1Bj|8A9{AsDaxX5 Y4Eg]+?jI$0ѦvR9cg;h*KS3L Th>e  ~&QIڡ;'{qvDGc6֬^N-7-݈dycs*(`) _=dmK+ l15}~ӭ7*0"(LjJ(vZ'f15Jؤ OMnU{OW12&bUJ*8bxeZb ^< '":q(f]]lNV0ɊM^@0qL"k2!uS73o &Hp"4dH8m #te?e[Ev۔Şyػ8JL/PUղ`VèN#dDZQ|ۉϟ|Ћ>~ɜszl͙w :7ujUw][1HWAuo 34R@]7(3oϫeq6}Q- .(G%YV{z'Cf'nMk];^%EA =똄XYaej~knR#o3YeNy,)o o.>f~SܝL-fI؛6;|_LܚG)od򉱥ιm&ҁp⻬.,9E^F݉0JoAR|ӮZ5uB4յSxַis1TU))7ȍ?$ N-o)owL,F&ڲMEEB1EMX'gKh.@t+P]Eַ+_gȌ=a 3#YP*\ڤ+LS> `<=t|pSV=u1ǚE4&=0z@k-T3"c~ e,<(%ttk7O%MFaB,L-% P~,Z\Fa9Vb?r}W8UfWIfzhN3A`D-w@!\7rKCեX2y ao  fqSLSA#(\C|X_oyZ޼FeR38!Fdn`:Fָ~/n.3o1 1SLL k$6-R$#M#{Ws` yR6 ^+7p<* ʅ|= M؅ C@^_oMk5HPS6FքDr᠁²E)A=5.1":^[%{uUP'|3|b׮SdW<$jRg;9>WTL,Qm/>Fz2%X\um(q`*W%@|J:V*(TopETm0Cl) a%ȿmdOZ^DUd(RT]`l$ 0bH  )#?ً~ RbPLj+u R*@9įm\[*Ɏs '/eHY7N,lȰЈ]#}CfMlhE ȴH{؀~58#xZ[ԟAg8Hɮ?4Y{hZܜK0V F>}:727Q2/}Ha @%[޲ A Kaf,xH׋ַJ`96>|:Ha(? * ]s.(oVAua+2VTfWwj%:BQwWH=| &jS|DsC3@R46b?jdٻS QxUB9OhR$e IkmGe!ξ&iWW Gfo2PޗZoˬ{7l*D*:dqYITY4i>&9g+}5] F\cz#uH10 kWC1"8l}Ns`ἥ{JC `n0ַΪۤ5)nE8xН.~cw1 '$vM^ٺ|pSrg?o ߲̙q\X{X{?X4HѾ%|/E(F!BeAyZvR A0:Bw^.Lxjو#5Mj[ﱁK}!6)]ؿ\yg_G8,جF:6=q;,@تHT,*E'7lc$iܕ*U2Ӽ"r 3{GZk:dȳ4۬gR4 RۜM6$ '0y ܑzO^IyFm`2)1[8(f3fM'QA1N.?7K56ֽRxTMc!re}(HfmgۼVK#@@Bxr|7?D78tɹŤyop*~fTx JM.w}[@_ʄL,*NS5 "^dCH9IT,0,|CŹgk<32~ۛLָ7预9auFϝ4 $8S,́<_X+<Ȏ=_]rngl>pcMh!Kf´-p 2 q!-s5ɇLJ9"]Ziܨ%+q{zF3U*۹If (yg;> Q\62! %2SGbV߬gm?5#wVV*>@Ju B|{hKCHHmrvzWp  [m)kSs^;*4T;PX|M?D~`][tZkukFKOjL~f7b:eq?4 hqTcABk7JxicyT -#p D_p _VŹl.ȝ"Y l3߃Fŕ+&3UX9A9\saFk}|y ۤtin 4`5 / $Z^ ]yȞknڄV?[ASg=ҫYL>?ᮝ0\4&MI-Q3̈cdV:+!oX|"7 aCuF,Ev^ a`c _.HoRޗYɉDe˒_o(bx:гzp;oڹ%:ܚCu{vscsF_,/I>0xvۣ} MctA޺!h3zr[mbBʮ8YU۵4 {cSQ k&ڙ9ƀ)At\Q❆KRO+ci*>i%,!=T)[w<$!F ii4MUu$}ceޙ$j (2Q<}"L7}x3[~16Пvҹh>:uGdm!+-Jp4cޭ2@{Mp9(t+me1?rtwG= c`EK C9oʩBHp|~9TgeO!V\IW42œM46E ܟZoWD<22'Me&^̻TdTP}̽sFa5 0A{qbF11 ,Cw@1M J0,(ɆO-Ȳ˻Ӑ4C'r dYvU.BΔֺ:+5ue[f.D?i0L$Z#9N\Ϻ6N0m5_X̪%;q*x׸ESӭEH?/݆EY|LHR+ u2\3gvid?]p{tjJ\ױ$G󺴋vaȀeB'rn$s_b&vpHu 5yHtjG'Ȋ7\(T=]t/vo˸.o(d{6J&*&?ީ z-q^!HY2I 1h}F:fFT-:5^Bq\`݅I?I(h@rA۠WE١F75~@asKN y\oA2l>νU~eд رxM>ڤ0ՙ DMNaJo'%~VV;()KPmdz"!Ρ-&@2aYF%kqR E;,HP,T@қVx-X1H39`|Y"փBƠ HWR)u  +ݓ [$" {0gWlqhD3@.%pn?S*<5 zwߔP$Ǖ'*Jf0\S륍;0k1Fca94]d𬾔)P]s?( QVl"eL^jэw r\ı:ٗ慮%ZT6!sN#CE?1r%ܬNRu]}%JoNb9^oAOIVGe*,q[ΎZFAd4 -5FR6Bu4+D&4a[{}0jǯZ4Kæg}[f-] VU(Tpa?T)k nk e+!e2E4Qݿ0YR*46(Xu&#Ԟ,{[_50[ Ot9F7ȿmwkTMAWoAJqRxՉs>o)Ӄ[PU>ևSc-G\J$u\U<9cՏѸrtο3 jn1'wYPrRbH*`;/D#ަdVWO?T|grOe_TSʍh5v{ң^**Y0FGBխH]@v-2NԺ A_k%sXp~ 2_J<<ޠvhȲxP4)-͚Nq&߳r{!0OS}O&p^MlP1]-epB@ [ɫy!xem 8&@ g΄.\Knb!N?^5.]Shb\?Lܘ1[PVRq,/#9"vLТaD!O `-6rOb$.6vPHYpe<5q@*ù^>_+T>0ωEwJY> ;+gD@}*v|F(PU* [ҊO:Gazݗ5ߘbQ&Gxk7ퟔWHGv8# =7eh76M݄Mfc"9g[9tŗ3<&GNPgq|53?4׳7ѼA)w*:>`RuOqlj2j^7# Pa~ 6d>3G|fWu!9f)F`…R"8}Gɬ%1Kz1umD 6`\H8ؠD8Rqkc1H/t! 8n`.JÞ:".VlbPJ̄ =uo"x ^ĿD b5똷&`8͏e"Yͬ~z6u2f4M769N2,RgU@krH|){[E_O5$|uHJ"Nkj9 jŶEi};~/H;dI$ߔĉ@۲eЀYѢO@]~ӂ֢R9#1|,W$7,+戟Cg!]^6}1t%)u]F|_Rрv: hTOj7q"Oe(~Dty &1&%c\#*?쐝 ?U$[#CxJ54?Ң #2 }}=Ɗݡ^WS[{})ؤ)mm["o*Py!DV>s9iE n\*r?$o M u>m?ҌwPDYKa^7vge8eSmǽ捻M@2Ƙi~: F9Ϥ{.w7DAjT0uʚ,9\VH:!;\َL:M+57Ϛw8+8;퍧ػ:ל !X5A0m3g?Exb.J6܍ Pغ@s$w>W9Np.YVí zTH%,#&?R44}B&xis\1eؒŸ( CeGq'`U9U٥76΋BSS+nv1>|DFܶ.h!!0mŜɇ~]EK]2'ˤ4XpK1[O-hg9ũDv ##р ,>F$0M6W[ vz#n`t^lL\Sʨئ|`Vk 46Bx 2ĎV{cz,> Ф*ꝿƮ pU'\ʉ/U =\ID`B,:?:-~-I^x[|F9Jm7r1@X6?HD"~ E.Nʑ0gݷ2 h^DF]X}bC -bMǥvjt%,=4! 긐xϫR8] hZߕqbTf WdձnAKOˀ%XʇZ.RB QY0KA*2zjJq& o<0#\ zː* -xYCBXXZǿ,L$F=9#թ[/p l+V1x#&M#ۏT;7DwS%?m">б̯?f_x dyN*c3(w;$R̼Uw REC( AOb]e|f,o.+q?(` axʛxpOCuUO,maQhNrܷiWZIg:[;`d0"qjՋBf2f9?v=c 0nL32|/{#; >'r*$&lW"53-S8eq/%ćeLlHv\yS0ϺE27}2~Lc'/ߖv_G+'!$Ql9IpLU(.TN@lqe/ 1˭\&T2H5P8dVϟz@z[;:.W_Q Y2[ADxHzM]l)1y8~t ՔsG/!bi@[!h#1`{X%,ZҪaW!i>@lbq{0=dP&o;kttbkwa2ΡoJ݊د$KͧЎz΅Nó{fQ-4VSnC'jq@ǧ2_%9)[.Y}}pEפ=?|{ݭcpfC>/ѴRc]D,L ^=I5ڣ,#:AV|YW ⡡z^aIFxϏ6JdJ619U7/Q}yF  ڥoC Q Rwȼ~3X^;ǁfEa^,3ݍvBXp7 ~#jh]`ʹ/ i!5wz?9 .ߕNgPegUZx@óv \!orNs7laWby'rPK? "n#3#d;-[ebDߗi RSėZE`8z6sǮDYXЃscDq@.ob>+%y')pŹ;:ñHϋCgX:N'+=`DtsIJ!FUlyG Cg:$j/V"#+d0T`U)W+!*ho#g+W՗Y ;+O0a&[l¸)q|0s3%w(%o0"ӣSkgur<Λ{jY]=p馋̰Sb6{wh1d>ӗ`m Gd'c^޷Ckxi)WN!?%z~ic 5UAf`o$8&ez3dCuLd&{QK b߹)TJT\8ڻ zf:Ճ`i3E#Ll>KOպ[g1JSgpwq )Bo5^`?Sz|@w..$_0(e_!rp/ۅw:͋ȑtWдh;H4x' .#C-:GeϲC[47V!hEb1A_p}cTL"D m -dIڥ~3s\K:QnjvW5]|!"ue2[Jos`:!Ch %LyaKWۑ|j*H4a2,'@KኜWy=bAJfNLOހq!Ite!!KLҚQtQw_A"d1ˣk8 {o79#~~d4D YJNa.QMM,2Wm?^+E;c(X1kL /DӹUw8BΛԹ\͝>4Mɴ@giѴӧش}J,qf<5-|fKgG*EPdӡ+Dd28 "C__%P'3Tiw16ψoя~2Ws&dq`֭G :u;NL,q[!MKBߏ{`ޝ*'B dp4{yJ].K0bGi)XK ).LU T:5N Z8`@Oʽ6Aƕ15Cȇ]Ӌ}_[u(\\N=1-m]JW0tqk0ćܬ3Z@H%Bg-}\yVe]p_Og/xzz0׶J ę_nF&*nBҖd\ hxh A+J9;Tg=o I-ãAP"8> { s8sm %_Enm.WG>{<´_1x*mWOUW!pkFyEkݓD>Pϩp?ry=&b#?XHox(2kgt_h CHD\ ⽑u MerrfWF[RI߽@Ega5iŇKH6auL&"VX` Y)4*f@<+ivaaZ309: VZZ6Fa3Xv%R}>Jdm@Bhkaiψu OPh/-޼|ҕI'5akrw[L4?KZHi}"/~rX>>JUOkB>D4)(4C!TIX-K8c'x7]˗^ G@5wE3B>yomHK5%[d9>(!BTKõp+B*5 y%U\fh},;yA%,^-IPFޥJ\H}'m{i&FqD#{ !'r/hncNg%_aA=aeߺ}>^ Ros;:f\j@6rS9EsL8q#rk _?~ćɳP >@0=A7Q*DXq$ Oa熢Yq<]iwX[qU?ɫ c&^J/~ qg UE:Q5qY\sr&NxrldteDp 61Av,y|9UL,3E`b ;x۳r'}B_fv9wH^3nT t__Ocvs8쟱0i>fl hVp3K~W.!߷}FHDx5 Qdc(wzo-ˊ8(Zh6EKd+>l7i5:ͳr)Y@*WnE⾬C(b[9e;Q_-:\N@xVTnxbyt~*"2D(2f2Yi,$R)~I.Gf$ڸ*b&ggpN ϡ8Ta%Ͱf){i-zTFw u{W bf a}aX-nj}ܹ+y|cm OHаQWjD.Ɂ~s#)ՙX;ºKxUz⫧1 2I&4"x@=3iS~OCUv] 5iYm &  wS,uu\>?nSBjZS=ct8J%H.=|Oū|982Ki W>ދ};QbFQ>n۵Uq&H&L `0ySF(kEKy#XX_sKhG_>Z?nt+pR8YGmrW}OT)D'a%X^ Rpq}a.~@Ud=-׹bwcgn d"5R SK;t#kSO/bS:mLmmk$(g65Dnu"?YT1<0r+T Iwɣ&rSp7f KG/gDJ>9DOMÞ#Dɋ_(`?ic6L5) njD؛/`3rD tnb^TpC T?U#33(Tһ[?^ڙ+IjC_ϺH|F~Oџh c\3yD 1nvaѱA~0eJ,SOҴŒ!gI=PףMQWOĔU1~j{.җTwZ փP* `h4bܙ⻢ P9b(TB_yڅ[d62eO@WUL!蔕T9]sZTʁgݶߍ)= :W1~H~X}Nd_^mb'ߴt>qqD$G  A"݃/{\#a1 OOZnӒH}WAC=GJZiLD_'h '^Cpʙn1#|'ԗ@5Xx;My6960Mqd,2Ԅw-"UV 3i2$B9ttS/xNT751E?M X|lL) Wp͛) u3CM&I?m6r iǿTt"jP岜44'6}FJZ ( PFVciY8k19ؼ=G'o^o\-k!Hwuίbx]7\}ohh(ڴOK{Jgk{H@3T`ʷx}>z91J\4lLe Ӷ6FGz9I~ *-P̐NѠBL]j .6T~HxfZy* +csPKr?ȝt6ykk u"dZ{w,pX6G,"_̱ɎNxq > \pZh$j(s>e?]=,,o|סǜ|IPp.k8s #zZ#m4+ΦfeZmܞ0RD;3-ӈ$aƏoK,Rʹ`_z \dw\R)!Eլ剷0L{!s7?f= H{s l4-J#h"se Hw qv.-kS4@1~;6HE@puN ӑ4]LO a4S+TOYD$ }RK|ur=1JK>$AѼ ]#'i~m Z k ݪ2@pRno#@I8?YP~|V Fի4D CWXp_Pc@{RY7Wx&+s;$Il2yCGqM=IiiIT=ta 뿄Q.%ZfN^@PWLY믷rHxD'Ht(Ss`v܅%cktj6oPE?Oo4DY37ɯ7& Ə B%LqӻL8E׸2+njJäj$7E vnυD8a]@%g|Ŵ}^o#C > q1.0!p-%zCȁC`~w:FgE<$I}ct,wR(a_UaP J Eq=D͛E7\,k qH- 6TUGJ P[*ioH=(MGD8S~H>k- d&<U MrkcG? Mv(8lqTznh?A'taђ9TaA/zȞXm  -Rr¸QCO޳a }"CJ  JbS*f i"v/gb0eC}VK#}9D>r}J CrF!H_lKzFu_`Ff@u-씺p#+>a3SϹ9,#SDH;~b uҰ^N/P/഍.KzE*|4VOTU6=w_,L\-3<.$YV&ؒ[LƯf{ \M_n4l:lnի Ay#k2FNDJf^-_#}VtyF)PjXUnA~:-R:x܍rw1c g41B#is9XqLꄼ@LKGQ6J:ϜRӾHP%R0?$!jO`ɯp LDŎS4>R[kz Xg΋D*>r@I: OטiFI٫C0  x>#$wڪ f)Mt?oot)mO#p'ֆ9)4c[KglZSD*NH }' ^V>)bfo$^tKLxPCȩK/fuh/US^=วtD?(k: /@J>f_/'k!-E?}r['!uZA Mmg "_V;`v2Kr UM4Dag53'B vzEYF5T,,_;F@6YϨX֖?qzM纕acaR+M-ca*M2:ۊ@*wšҘ i uy.1#uǎ6}Y7ľg %gKNK80 =٤/ӏ, Ho&&t%a+xiNJV5VZ}y}xtbK+=ԷQf"bKzloN6n)Ub"~4Y; #5pU(C^&YzUkWn!FsZ4IaFX'j57iվj\,Y.v%hTA1稤)^ACFk'75'K_N W } #E(s_̼deZ/i2tS"b=iϑkRFr^ 57=0#4Q]zXSUG!뢁b[]hNC!O-]m{aFaW WQzO 7Iٔu*\/c\E TlzpKv~+#&ć@/FDqB.x=+#iO6HC"gqEDMVA^t坮 gR[ħYԾu;|OPJGtIŎ-MqEG#DF-D)CV7+o9[H.:0 YZmets/man/0000755000176200001440000000000013623061405011775 5ustar liggesusersmets/man/dcut.Rd0000644000176200001440000000502613623061405013226 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dutils.R \name{dcut} \alias{dcut} \alias{dcut<-} \alias{dunique} \alias{drm} \alias{drm<-} \alias{dnames} \alias{dnames<-} \alias{drename} \alias{drename<-} \alias{dkeep} \alias{dkeep<-} \alias{ddrop} \alias{ddrop<-} \title{Cutting, sorting, rm (removing), rename for data frames} \usage{ dcut(data, y = NULL, x = NULL, breaks = 4, probs = NULL, equi = FALSE, regex = mets.options()$regex, sep = NULL, na.rm = TRUE, labels = NULL, all = FALSE, ...) } \arguments{ \item{data}{if x is formula or names for data frame then data frame is needed.} \item{y}{name of variable, or fomula, or names of variables on data frame.} \item{x}{name of variable, or fomula, or names of variables on data frame.} \item{breaks}{number of breaks, for variables or vector of break points,} \item{probs}{groups defined from quantiles} \item{equi}{for equi-spaced breaks} \item{regex}{for regular expressions.} \item{sep}{seperator for naming of cut names.} \item{na.rm}{to remove NA for grouping variables.} \item{labels}{to use for cut groups} \item{all}{to do all variables, even when breaks are not unique} \item{...}{Optional additional arguments} } \description{ Cut variables, if breaks are given these are used, otherwise cuts into using group size given by probs, or equispace groups on range. Default is equally sized groups if possible } \examples{ data("sTRACE",package="timereg") sTRACE$age2 <- sTRACE$age^2 sTRACE$age3 <- sTRACE$age^3 mm <- dcut(sTRACE,~age+wmi) head(mm) mm <- dcut(sTRACE,catage4+wmi4~age+wmi) head(mm) mm <- dcut(sTRACE,~age+wmi,breaks=c(2,4)) head(mm) mm <- dcut(sTRACE,c("age","wmi")) head(mm) mm <- dcut(sTRACE,~.) head(mm) mm <- dcut(sTRACE,c("age","wmi"),breaks=c(2,4)) head(mm) gx <- dcut(sTRACE$age) head(gx) ## Removes all cuts variables with these names wildcards mm1 <- drm(mm,c("*.2","*.4")) head(mm1) ## wildcards, for age, age2, age4 and wmi head(dcut(mm,c("a*","?m*"))) ## with direct asignment drm(mm) <- c("*.2","*.4") head(mm) dcut(mm) <- c("age","*m*") dcut(mm) <- ageg1+wmig1~age+wmi head(mm) ############################ ## renaming ############################ head(mm) drename(mm, ~Age+Wmi) <- c("wmi","age") head(mm) mm1 <- mm ## all names to lower drename(mm1) <- ~. head(mm1) ## A* to lower mm2 <- drename(mm,c("A*","W*")) head(mm2) drename(mm) <- "A*" head(mm) dd <- data.frame(A_1=1:2,B_1=1:2) funn <- function(x) gsub("_",".",x) drename(dd) <- ~. drename(dd,fun=funn) <- ~. names(dd) } \author{ Klaus K. Holst and Thomas Scheike } mets/man/dsort.Rd0000644000176200001440000000132613623061405013421 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dsort.R \name{dsort} \alias{dsort} \alias{dsort2} \alias{dsort<-} \title{Sort data frame} \usage{ dsort(data, x, ..., decreasing = FALSE, return.order = FALSE) } \arguments{ \item{data}{Data frame} \item{x}{variable to order by} \item{...}{additional variables to order by} \item{decreasing}{sort order (vector of length x)} \item{return.order}{return order} } \value{ data.frame } \description{ Sort data according to columns in data frame } \examples{ data(data="hubble",package="lava") dsort(hubble, "sigma") dsort(hubble, hubble$sigma,"v") dsort(hubble,~sigma+v) dsort(hubble,~sigma-v) ## with direct asignment dsort(hubble) <- ~sigma-v } mets/man/cluster.index.Rd0000644000176200001440000000205513623061405015055 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/clusterindex-reshape.R \name{cluster.index} \alias{cluster.index} \alias{countID} \alias{pairRisk} \alias{mystrata} \title{Finds subjects related to same cluster} \usage{ cluster.index(clusters, index.type = FALSE, num = NULL, Rindex = 0, mat = NULL, return.all = FALSE, code.na = NA) } \arguments{ \item{clusters}{list of indeces} \item{index.type}{if TRUE then already list of integers of index.type} \item{num}{to get numbering according to num-type in separate columns} \item{Rindex}{index starts with 1, in C is it is 0} \item{mat}{to return matrix of indeces} \item{return.all}{return all arguments} \item{code.na}{how to code missing values} } \description{ Finds subjects related to same cluster } \examples{ i<-c(1,1,2,2,1,3) d<- cluster.index(i) print(d) type<-c("m","f","m","c","c","c") d<- cluster.index(i,num=type,Rindex=1) print(d) } \references{ Cluster indeces } \seealso{ familycluster.index familyclusterWithProbands.index } \author{ Klaus Holst, Thomas Scheike } mets/man/twinlm.Rd0000644000176200001440000000744013623061405013603 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/twinlm.R \name{twinlm} \alias{twinlm} \alias{twinlm.strata} \title{Classic twin model for quantitative traits} \usage{ twinlm(formula, data, id, zyg, DZ, group = NULL, group.equal = FALSE, strata = NULL, weights = NULL, type = c("ace"), twinnum = "twinnum", binary = FALSE, ordinal = 0, keep = weights, estimator = NULL, constrain = TRUE, control = list(), messages = 1, ...) } \arguments{ \item{formula}{Formula specifying effects of covariates on the response} \item{data}{\code{data.frame} with one observation pr row. In addition a column with the zygosity (DZ or MZ given as a factor) of each individual much be specified as well as a twin id variable giving a unique pair of numbers/factors to each twin pair} \item{id}{The name of the column in the dataset containing the twin-id variable.} \item{zyg}{The name of the column in the dataset containing the zygosity variable} \item{DZ}{Character defining the level in the zyg variable corresponding to the dyzogitic twins. If this argument is missing, the reference level (i.e. the first level) will be interpreted as the dyzogitic twins} \item{group}{Optional. Variable name defining group for interaction analysis (e.g., gender)} \item{group.equal}{If TRUE marginals of groups are asummed to be the same} \item{strata}{Strata variable name} \item{weights}{Weights matrix if needed by the chosen estimator. For use with Inverse Probability Weights} \item{type}{Character defining the type of analysis to be performed. Should be a subset of "aced" (additive genetic factors, common environmental factors, unique environmental factors, dominant genetic factors).} \item{twinnum}{The name of the column in the dataset numbering the twins (1,2). If it does not exist in \code{data} it will automatically be created.} \item{binary}{If \code{TRUE} a liability model is fitted. Note that if the right-hand-side of the formula is a factor, character vector, og logical variable, then the liability model is automatically chosen (wrapper of the \code{bptwin} function).} \item{ordinal}{If non-zero (number of bins) a liability model is fitted.} \item{keep}{Vector of variables from \code{data} that are not specified in \code{formula}, to be added to data.frame of the SEM} \item{estimator}{Choice of estimator/model} \item{constrain}{Development argument} \item{control}{Control argument parsed on to the optimization routine} \item{messages}{Control amount of messages shown} \item{...}{Additional arguments parsed on to lower-level functions} } \value{ Returns an object of class \code{twinlm}. } \description{ Fits a classical twin model for quantitative traits. } \examples{ ## Simulate data set.seed(1) d <- twinsim(1000,b1=c(1,-1),b2=c(),acde=c(1,1,0,1)) ## E(y|z1,z2) = z1 - z2. var(A) = var(C) = var(E) = 1 ## E.g to fit the data to an ACE-model without any confounders we simply write ace <- twinlm(y ~ 1, data=d, DZ="DZ", zyg="zyg", id="id") ace ## An AE-model could be fitted as ae <- twinlm(y ~ 1, data=d, DZ="DZ", zyg="zyg", id="id", type="ae") ## LRT: lava::compare(ae,ace) ## AIC AIC(ae)-AIC(ace) ## To adjust for the covariates we simply alter the formula statement ace2 <- twinlm(y ~ x1+x2, data=d, DZ="DZ", zyg="zyg", id="id", type="ace") ## Summary/GOF summary(ace2) \donttest{ ## Reduce Ex.Timings ## An interaction could be analyzed as: ace3 <- twinlm(y ~ x1+x2 + x1:I(x2<0), data=d, DZ="DZ", zyg="zyg", id="id", type="ace") ace3 ## Categorical variables are also supported d2 <- transform(d,x2cat=cut(x2,3,labels=c("Low","Med","High"))) ace4 <- twinlm(y ~ x1+x2cat, data=d2, DZ="DZ", zyg="zyg", id="id", type="ace") } } \seealso{ \code{\link{bptwin}}, \code{\link{twinlm.time}}, \code{\link{twinlm.strata}}, \code{\link{twinsim}} } \author{ Klaus K. Holst } \keyword{models} \keyword{regression} mets/man/binreg.Rd0000644000176200001440000000332713623061405013537 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/binomial.regression.R \name{binreg} \alias{binreg} \title{Binomial Regression for censored competing risks data} \usage{ binreg(formula, data, cause = 1, time = NULL, beta = NULL, offset = NULL, weights = NULL, cens.weights = NULL, cens.model = ~+1, se = TRUE, kaplan.meier = TRUE, cens.code = 0, no.opt = FALSE, method = "nr", ...) } \arguments{ \item{formula}{formula with outcome (see \code{coxph})} \item{data}{data frame} \item{cause}{cause of interest} \item{time}{time of interest} \item{beta}{starting values} \item{offset}{offsets for partial likelihood} \item{weights}{for score equations} \item{cens.weights}{censoring weights} \item{cens.model}{stratified cox model} \item{se}{to compute se's based on IPCW} \item{kaplan.meier}{uses Kaplan-Meier for baseline than standard Cox} \item{cens.code}{gives censoring code} \item{no.opt}{to not optimize} \item{method}{for optimization} \item{...}{Additional arguments to lower level funtions} } \description{ Simple version of comp.risk function of timereg for just one time-point thus fitting the model \deqn{P(T \leq t, \epsilon=1 | X ) = expit( X^T beta) } } \details{ Based on binomial regresion IPCW response estimating equation: \deqn{ X ( \Delta I(T \leq t, \epsilon=1 )/G_c(T_i-) - expit( X^T beta)) = 0 } for IPCW adjusted responses. } \examples{ data(bmt) # logistic regresion with IPCW binomial regression out <- binreg(Event(time,cause)~tcell+platelet,bmt,time=50) summary(out) predict(out,data.frame(tcell=c(0,1),platelet=c(1,1)),se=TRUE) outs <- binreg(Event(time,cause)~tcell+platelet,bmt,time=50,cens.model=~strata(tcell,platelet)) summary(outs) } \author{ Thomas Scheike } mets/man/lifetable.matrix.Rd0000644000176200001440000000203613623061405015517 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifetable.R \name{lifetable.matrix} \alias{lifetable.matrix} \alias{lifetable} \alias{lifetable.formula} \title{Life table} \usage{ \method{lifetable}{matrix}(x, strata = list(), breaks = c(), weights=NULL, confint = FALSE, ...) \method{lifetable}{formula}(x, data=parent.frame(), breaks = c(), weights=NULL, confint = FALSE, ...) } \arguments{ \item{x}{time formula (Surv) or matrix/data.frame with columns time,status or entry,exit,status} \item{strata}{strata} \item{breaks}{time intervals} \item{weights}{weights variable} \item{confint}{if TRUE 95\% confidence limits are calculated} \item{...}{additional arguments to lower level functions} \item{data}{data.frame} } \description{ Create simple life table } \examples{ library(timereg) data(TRACE) d <- with(TRACE,lifetable(Surv(time,status==9)~sex+vf,breaks=c(0,0.2,0.5,8.5))) summary(glm(events ~ offset(log(atrisk))+factor(int.end)*vf + sex*vf, data=d,poisson)) } \author{ Klaus K. Holst } mets/man/dermalridges.Rd0000644000176200001440000000137713623061405014736 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mets-package.R \docType{data} \name{dermalridges} \alias{dermalridges} \title{Dermal ridges data (families)} \format{Data on 50 families with ridge counts in left and right hand for moter, father and each child. Family id in 'family' and gender and child number in 'sex' and 'child'.} \source{ Sarah B. Holt (1952). Genetics of dermal ridges: bilateral asymmetry in finger ridge-counts. Annals of Eugenics 17 (1), pp.211--231. DOI: 10.1111/j.1469-1809.1952.tb02513.x } \description{ Data on dermal ridge counts in left and right hand in (nuclear) families } \examples{ data(dermalridges) fast.reshape(dermalridges,id="family",varying=c("child.left","child.right","sex")) } \keyword{data} mets/man/ClaytonOakes.Rd0000644000176200001440000000465613623061405014673 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/claytonakes.R \name{ClaytonOakes} \alias{ClaytonOakes} \title{Clayton-Oakes model with piece-wise constant hazards} \usage{ ClaytonOakes(formula, data = parent.frame(), cluster, var.formula = ~1, cuts = NULL, type = "piecewise", start, control = list(), var.invlink = exp, ...) } \arguments{ \item{formula}{formula specifying the marginal proportional (piecewise constant) hazard structure with the right-hand-side being a survival object (Surv) specifying the entry time (optional), the follow-up time, and event/censoring status at follow-up. The clustering can be specified using the special function \code{cluster} (see example below).} \item{data}{Data frame} \item{cluster}{Variable defining the clustering (if not given in the formula)} \item{var.formula}{Formula specifying the variance component structure (if not given via the cluster special function in the formula) using a linear model with log-link.} \item{cuts}{Cut points defining the piecewise constant hazard} \item{type}{when equal to \code{two.stage}, the Clayton-Oakes-Glidden estimator will be calculated via the \code{timereg} package} \item{start}{Optional starting values} \item{control}{Control parameters to the optimization routine} \item{var.invlink}{Inverse link function for variance structure model} \item{...}{Additional arguments} } \description{ Clayton-Oakes frailty model } \examples{ set.seed(1) d <- subset(simClaytonOakes(500,4,2,1,stoptime=2,left=2),truncated) e <- ClaytonOakes(survival::Surv(lefttime,time,status)~x+cluster(~1,cluster), cuts=c(0,0.5,1,2),data=d) e d2 <- simClaytonOakes(500,4,2,1,stoptime=2,left=0) d2$z <- rep(1,nrow(d2)); d2$z[d2$cluster\%in\%sample(d2$cluster,100)] <- 0 ## Marginal=Cox Proportional Hazards model: ts <- ClaytonOakes(survival::Surv(time,status)~timereg::prop(x)+cluster(~1,cluster), data=d2,type="two.stage") ## Marginal=Aalens additive model: ts2 <- ClaytonOakes(survival::Surv(time,status)~x+cluster(~1,cluster), data=d2,type="two.stage") ## Marginal=Piecewise constant: e2 <- ClaytonOakes(survival::Surv(time,status)~x+cluster(~-1+factor(z),cluster), cuts=c(0,0.5,1,2),data=d2) e2 plot(ts) plot(e2,add=TRUE) e3 <- ClaytonOakes(survival::Surv(time,status)~x+cluster(~1,cluster),cuts=c(0,0.5,1,2), data=d,var.invlink=identity) e3 } \author{ Klaus K. Holst } mets/man/base1cumhaz.Rd0000644000176200001440000000045613623061405014474 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mets-package.R \docType{data} \name{base1cumhaz} \alias{base1cumhaz} \title{rate of CRBSI for HPN patients of Copenhagen} \source{ Estimated data } \description{ rate of CRBSI for HPN patients of Copenhagen } \keyword{data} mets/man/daggregate.Rd0000644000176200001440000000453413623061405014364 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/daggregate.R \name{daggregate} \alias{daggregate} \alias{daggr} \title{aggregating for for data frames} \usage{ daggregate(data, y = NULL, x = NULL, subset, ..., fun = "summary", regex = mets.options()$regex, missing = FALSE, remove.empty = FALSE, matrix = FALSE, silent = FALSE, na.action = na.pass, convert = NULL) } \arguments{ \item{data}{data.frame} \item{y}{name of variable, or formula, or names of variables on data frame.} \item{x}{name of variable, or formula, or names of variables on data frame.} \item{subset}{subset expression} \item{...}{additional arguments to lower level functions} \item{fun}{function defining aggregation} \item{regex}{interpret x,y as regular expressions} \item{missing}{Missing used in groups (x)} \item{remove.empty}{remove empty groups from output} \item{matrix}{if TRUE a matrix is returned instead of an array} \item{silent}{suppress messages} \item{na.action}{How model.frame deals with 'NA's} \item{convert}{if TRUE try to coerce result into matrix. Can also be a user-defined function} } \description{ aggregating for for data frames } \examples{ data("sTRACE",package="timereg") daggregate(iris, "^.e.al", x="Species", fun=cor, regex=TRUE) daggregate(iris, Sepal.Length+Petal.Length ~Species, fun=summary) daggregate(iris, log(Sepal.Length)+I(Petal.Length>1.5) ~ Species, fun=summary) daggregate(iris, "*Length*", x="Species", fun=head) daggregate(iris, "^.e.al", x="Species", fun=tail, regex=TRUE) daggregate(sTRACE, status~ diabetes, fun=table) daggregate(sTRACE, status~ diabetes+sex, fun=table) daggregate(sTRACE, status + diabetes+sex ~ vf+I(wmi>1.4), fun=table) daggregate(iris, "^.e.al", x="Species",regex=TRUE) dlist(iris,Petal.Length+Sepal.Length ~ Species |Petal.Length>1.3 & Sepal.Length>5, n=list(1:3,-(3:1))) daggregate(iris, I(Sepal.Length>7)~Species | I(Petal.Length>1.5)) daggregate(iris, I(Sepal.Length>7)~Species | I(Petal.Length>1.5), fun=table) dsum(iris, .~Species, matrix=TRUE, missing=TRUE) par(mfrow=c(1,2)) data(iris) drename(iris) <- ~. daggregate(iris,'sepal*'~species|species!="virginica",fun=plot) daggregate(iris,'sepal*'~I(as.numeric(species))|I(as.numeric(species))!=1,fun=summary) dnumeric(iris) <- ~species daggregate(iris,'sepal*'~species.n|species.n!=1,fun=summary) } mets/man/blocksample.Rd0000644000176200001440000000215413623061405014562 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/blocksample.R \name{blocksample} \alias{blocksample} \alias{dsample} \title{Block sampling} \usage{ blocksample(data, size, idvar = NULL, replace = TRUE, ...) } \arguments{ \item{data}{Data frame} \item{size}{Size of samples} \item{idvar}{Column defining the clusters} \item{replace}{Logical indicating wether to sample with replacement} \item{\dots}{additional arguments to lower level functions} } \value{ \code{data.frame} } \description{ Sample blockwise from clustered data } \details{ Original id is stored in the attribute 'id' } \examples{ d <- data.frame(x=rnorm(5), z=rnorm(5), id=c(4,10,10,5,5), v=rnorm(5)) (dd <- blocksample(d,size=20,~id)) attributes(dd)$id \dontrun{ blocksample(data.table::data.table(d),1e6,~id) } d <- data.frame(x=c(1,rnorm(9)), z=rnorm(10), id=c(4,10,10,5,5,4,4,5,10,5), id2=c(1,1,2,1,2,1,1,1,1,2), v=rnorm(10)) dsample(d,~id, size=2) dsample(d,.~id+id2) dsample(d,x+z~id|x>0,size=5) } \author{ Klaus K. Holst } \keyword{models} \keyword{utilities} mets/man/km.Rd0000644000176200001440000000170113623061405012672 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phreg.R \name{km} \alias{km} \title{Kaplan-Meier with robust standard errors} \usage{ km(formula, data = data, conf.type = "log", conf.int = 0.95, robust = TRUE, ...) } \arguments{ \item{formula}{formula with 'Surv' outcome (see \code{coxph})} \item{data}{data frame} \item{conf.type}{transformation} \item{conf.int}{level of confidence intervals} \item{robust}{for robust standard errors based on martingales} \item{...}{Additional arguments to lower level funtions} } \description{ Kaplan-Meier with robust standard errors Robust variance is default variance with the summary. } \examples{ data(TRACE) TRACE$cluster <- sample(1:100,1878,replace=TRUE) out1 <- km(Surv(time,status==9)~strata(vf,chf),data=TRACE) out2 <- km(Surv(time,status==9)~strata(vf,chf)+cluster(cluster),data=TRACE) par(mfrow=c(1,2)) bplot(out1,se=TRUE) bplot(out2,se=TRUE) } \author{ Thomas Scheike } mets/man/eventpois.Rd0000644000176200001440000000160113623061405014276 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifetable.R \name{eventpois} \alias{eventpois} \alias{pcif} \title{Extract survival estimates from lifetable analysis} \usage{ eventpois(object, ..., timevar, time, int.len, confint = FALSE, level = 0.95, individual = FALSE, length.out = 25) } \arguments{ \item{object}{glm object (poisson regression)} \item{...}{Contrast arguments} \item{timevar}{Name of time variable} \item{time}{Time points (optional)} \item{int.len}{Time interval length (optional)} \item{confint}{If TRUE confidence limits are supplied} \item{level}{Level of confidence limits} \item{individual}{Individual predictions} \item{length.out}{Length of time vector} } \description{ Summary for survival analyses via the 'lifetable' function } \details{ Summary for survival analyses via the 'lifetable' function } \author{ Klaus K. Holst } mets/man/dermalridgesMZ.Rd0000644000176200001440000000124313623061405015175 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mets-package.R \docType{data} \name{dermalridgesMZ} \alias{dermalridgesMZ} \title{Dermal ridges data (monozygotic twins)} \format{Data on dermal ridge counts (left and right hand) in 18 monozygotic twin pairs.} \source{ Sarah B. Holt (1952). Genetics of dermal ridges: bilateral asymmetry in finger ridge-counts. Annals of Eugenics 17 (1), pp.211--231. DOI: 10.1111/j.1469-1809.1952.tb02513.x } \description{ Data on dermal ridge counts in left and right hand in (nuclear) families } \examples{ data(dermalridgesMZ) fast.reshape(dermalridgesMZ,id="id",varying=c("left","right")) } \keyword{data} mets/man/familycluster.index.Rd0000644000176200001440000000130413623061405016253 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/clusterindex-reshape.R \name{familycluster.index} \alias{familycluster.index} \title{Finds all pairs within a cluster (family)} \usage{ familycluster.index(clusters, index.type = FALSE, num = NULL, Rindex = 1) } \arguments{ \item{clusters}{list of indeces} \item{index.type}{argument of cluster index} \item{num}{num} \item{Rindex}{index starts with 1 in R, and 0 in C} } \description{ Finds all pairs within a cluster (family) } \examples{ i<-c(1,1,2,2,1,3) d<- familycluster.index(i) print(d) } \references{ Cluster indeces } \seealso{ cluster.index familyclusterWithProbands.index } \author{ Klaus Holst, Thomas Scheike } mets/man/twinbmi.Rd0000644000176200001440000000060213623061405013733 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mets-package.R \docType{data} \name{twinbmi} \alias{twinbmi} \title{BMI data set} \format{Self-reported BMI-values on 11,411 subjects tvparnr: twin id bmi: BMI (m/kg^2) age: Age gender: (male/female) zyg: zygosity, MZ:=mz, DZ(same sex):=dz, DZ(opposite sex):=os} \description{ BMI data set } \keyword{data} mets/man/simRecurrentTS.Rd0000644000176200001440000000431113623061405015214 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/recurrent.marginal.R \name{simRecurrentTS} \alias{simRecurrentTS} \title{Simulation of recurrent events data based on cumulative hazards: Two-stage model} \usage{ simRecurrentTS(n, cumhaz, cumhaz2, death.cumhaz = NULL, nu = rep(1, 3), share1 = 0.3, vargamD = 2, vargam12 = 0.5, gap.time = FALSE, max.recurrent = 100, cens = NULL, ...) } \arguments{ \item{n}{number of id's} \item{cumhaz}{cumulative hazard of recurrent events} \item{cumhaz2}{cumulative hazard of recurrent events of type 2} \item{death.cumhaz}{cumulative hazard of death} \item{nu}{powers of random effects where nu > -1/shape} \item{share1}{how random effect for death splits into two parts} \item{vargamD}{variance of random effect for death} \item{vargam12}{shared random effect for N1 and N2} \item{gap.time}{if true simulates gap-times with specified cumulative hazard} \item{max.recurrent}{limits number recurrent events to 100} \item{cens}{rate of censoring exponential distribution} \item{...}{Additional arguments to lower level funtions} } \description{ Simulation of recurrent events data based on cumulative hazards } \details{ Model is constructed such that marginals are on specified form by linear approximations of cumulative hazards that are on a specific form to make them equivalent to marginals after integrating out. Must give hazard of death and two recurrent events. Possible with two event types and their dependence can be specified but the two recurrent events need to share random effect. Random effect to death Z.death=(Zd1+Zd2), Z1=(Zd1^nu1) Z12, Z2=(Zd2^nu2) Z12^nu3 \deqn{Z.death=Zd1+Zd2} gamma distributions \deqn{Zdj} gamma distribution with mean parameters (sharej), vargamD, share2=1-share1 \deqn{Z12} gamma distribution with mean 1 and variance vargam12 } \examples{ ######################################## ## getting some rates to mimick ######################################## data(base1cumhaz) data(base4cumhaz) data(drcumhaz) dr <- drcumhaz base1 <- base1cumhaz base4 <- base4cumhaz rr <- simRecurrentTS(1000,base1,base4,death.cumhaz=dr) dtable(rr,~death+status) showfitsim(causes=2,rr,dr,base1,base4) } \author{ Thomas Scheike } mets/man/survival.twostage.Rd0000644000176200001440000003000113623061405015765 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/twostage.R \name{survival.twostage} \alias{survival.twostage} \alias{survival.twostage.fullse} \alias{twostage.aalen} \alias{twostage.cox.aalen} \alias{twostage.coxph} \alias{twostage.phreg} \alias{randomDes} \title{Twostage survival model for multivariate survival data} \usage{ survival.twostage(margsurv, data = sys.parent(), score.method = "fisher.scoring", Nit = 60, detail = 0, clusters = NULL, silent = 1, weights = NULL, control = list(), theta = NULL, theta.des = NULL, var.link = 1, iid = 1, step = 0.5, model = "clayton.oakes", marginal.trunc = NULL, marginal.survival = NULL, marginal.status = NULL, strata = NULL, se.clusters = NULL, numDeriv = 0, random.design = NULL, pairs = NULL, pairs.rvs = NULL, numDeriv.method = "simple", additive.gamma.sum = NULL, var.par = 1, cr.models = NULL, case.control = 0, ascertained = 0, shut.up = 0) } \arguments{ \item{margsurv}{Marginal model} \item{data}{data frame} \item{score.method}{Scoring method "fisher.scoring", "nlminb", "optimize", "nlm"} \item{Nit}{Number of iterations} \item{detail}{Detail} \item{clusters}{Cluster variable} \item{silent}{Debug information} \item{weights}{Weights} \item{control}{Optimization arguments} \item{theta}{Starting values for variance components} \item{theta.des}{design for dependence parameters, when pairs are given this is could be a (pairs) x (numer of parameters) x (max number random effects) matrix} \item{var.link}{Link function for variance} \item{iid}{Calculate i.i.d. decomposition} \item{step}{Step size} \item{model}{model} \item{marginal.trunc}{marginal left truncation probabilities} \item{marginal.survival}{optional vector of marginal survival probabilities} \item{marginal.status}{related to marginal survival probabilities} \item{strata}{strata for fitting, see example} \item{se.clusters}{for clusters for se calculation with iid} \item{numDeriv}{to get numDeriv version of second derivative, otherwise uses sum of squared score} \item{random.design}{random effect design for additive gamma model, when pairs are given this is a (pairs) x (2) x (max number random effects) matrix, see pairs.rvs below} \item{pairs}{matrix with rows of indeces (two-columns) for the pairs considered in the pairwise composite score, useful for case-control sampling when marginal is known.} \item{pairs.rvs}{for additive gamma model and random.design and theta.des are given as arrays, this specifice number of random effects for each pair.} \item{numDeriv.method}{uses simple to speed up things and second derivative not so important.} \item{additive.gamma.sum}{for two.stage=0, this is specification of the lamtot in the models via a matrix that is multiplied onto the parameters theta (dimensions=(number random effects x number of theta parameters), when null then sums all parameters.} \item{var.par}{is 1 for the default parametrization with the variances of the random effects, var.par=0 specifies that the \eqn{\lambda_j}'s are used as parameters.} \item{cr.models}{competing risks models for two.stage=0, should be given as a list with models for each cause} \item{case.control}{assumes case control structure for "pairs" with second column being the probands, when this options is used the twostage model is profiled out via the paired estimating equations for the survival model.} \item{ascertained}{if the pair are sampled only when there is an event. This is in contrast to case.control sampling where a proband is given. This can be combined with control probands. Pair-call of twostage is needed and second column of pairs are the first jump time with an event for ascertained pairs, or time of control proband.} \item{shut.up}{to make the program more silent in the context of iterative procedures for case-control and ascertained sampling} } \description{ Fits Clayton-Oakes or bivariate Plackett models for bivariate survival data using marginals that are on Cox form. The dependence can be modelled via \enumerate{ \item Regression design on dependence parameter. \item Random effects, additive gamma model. } If clusters contain more than two subjects, we use a composite likelihood based on the pairwise bivariate models, for MLE see twostageMLE. The two-stage model is constructed such that given the gamma distributed random effects it is assumed that the survival functions are indpendent, and that the marginal survival functions are on Cox form (or additive form) \deqn{ P(T > t| x) = S(t|x)= exp( -exp(x^T \beta) A_0(t) ) } One possibility is to model the variance within clusters via a regression design, and then one can specify a regression structure for the indenpendent gamma distributed random effect for each cluster, such that the variance is given by \deqn{ \theta = z_j^T \alpha } where \eqn{z} is specified by theta.des The reported standard errors are based on the estimated information from the likelihood assuming that the marginals are known. Can also fit a structured additive gamma random effects model, such as the ACE, ADE model for survival data. In this case the random.design specificies the random effects for each subject within a cluster. This is a matrix of 1's and 0's with dimension n x d. With d random effects. For a cluster with two subjects, we let the random.design rows be \eqn{v_1} and \eqn{v_2}. Such that the random effects for subject 1 is \deqn{v_1^T (Z_1,...,Z_d)}, for d random effects. Each random effect has an associated parameter \eqn{(\lambda_1,...,\lambda_d)}. By construction subjects 1's random effect are Gamma distributed with mean \eqn{\lambda_j/v_1^T \lambda} and variance \eqn{\lambda_j/(v_1^T \lambda)^2}. Note that the random effect \eqn{v_1^T (Z_1,...,Z_d)} has mean 1 and variance \eqn{1/(v_1^T \lambda)}. It is here asssumed that \eqn{lamtot=v_1^T \lambda} is fixed within clusters as it would be for the ACE model below. Based on these parameters the relative contribution (the heritability, h) is equivalent to the expected values of the random effects: \eqn{\lambda_j/v_1^T \lambda} The DEFAULT parametrization (var.par=1) uses the variances of the random effecs \deqn{ \theta_j = \lambda_j/(v_1^T \lambda)^2 } For alternative parametrizations one can specify how the parameters relate to \eqn{\lambda_j} with the argument var.par=0. For both types of models the basic model assumptions are that given the random effects of the clusters the survival distributions within a cluster are independent and ' on the form \deqn{ P(T > t| x,z) = exp( -Z \cdot Laplace^{-1}(lamtot,lamtot,S(t|x)) ) } with the inverse laplace of the gamma distribution with mean 1 and variance 1/lamtot. The parameters \eqn{(\lambda_1,...,\lambda_d)} are related to the parameters of the model by a regression construction \eqn{pard} (d x k), that links the \eqn{d} \eqn{\lambda} parameters with the (k) underlying \eqn{\theta} parameters \deqn{ \lambda = theta.des \theta } here using theta.des to specify these low-dimension association. Default is a diagonal matrix. This can be used to make structural assumptions about the variances of the random-effects as is needed for the ACE model for example. The case.control option that can be used with the pair specification of the pairwise parts of the estimating equations. Here it is assumed that the second subject of each pair is the proband. } \examples{ data(diabetes) # Marginal Cox model with treat as covariate margph <- phreg(Surv(time,status)~treat+cluster(id),data=diabetes) ### Clayton-Oakes, MLE fitco1<-twostageMLE(margph,data=diabetes,theta=1.0) summary(fitco1) ### Plackett model mph <- phreg(Surv(time,status)~treat+cluster(id),data=diabetes) fitp <- survival.twostage(mph,data=diabetes,theta=3.0,Nit=40, clusters=diabetes$id,var.link=1,model="plackett") summary(fitp) ### Clayton-Oakes fitco2 <- survival.twostage(mph,data=diabetes,theta=0.0,detail=0, clusters=diabetes$id,var.link=1,model="clayton.oakes") summary(fitco2) fitco3 <- survival.twostage(margph,data=diabetes,theta=1.0,detail=0, clusters=diabetes$id,var.link=0,model="clayton.oakes") summary(fitco3) ### without covariates but with stratafied marg <- phreg(Surv(time,status)~+strata(treat)+cluster(id),data=diabetes) fitpa <- survival.twostage(marg,data=diabetes,theta=1.0, clusters=diabetes$id,score.method="optimize") summary(fitpa) fitcoa <- survival.twostage(marg,data=diabetes,theta=1.0,clusters=diabetes$id, model="clayton.oakes") summary(fitcoa) ### Piecewise constant cross hazards ratio modelling ######################################################## d <- subset(simClaytonOakes(2000,2,0.5,0,stoptime=2,left=0),!truncated) udp <- piecewise.twostage(c(0,0.5,2),data=d,score.method="optimize", id="cluster",timevar="time", status="status",model="clayton.oakes",silent=0) summary(udp) \donttest{ ## Reduce Ex.Timings ### Same model using the strata option, a bit slower ######################################################## ## makes the survival pieces for different areas in the plane ##ud1=surv.boxarea(c(0,0),c(0.5,0.5),data=d,id="cluster",timevar="time",status="status") ##ud2=surv.boxarea(c(0,0.5),c(0.5,2),data=d,id="cluster",timevar="time",status="status") ##ud3=surv.boxarea(c(0.5,0),c(2,0.5),data=d,id="cluster",timevar="time",status="status") ##ud4=surv.boxarea(c(0.5,0.5),c(2,2),data=d,id="cluster",timevar="time",status="status") ## everything done in one call ud <- piecewise.data(c(0,0.5,2),data=d,timevar="time",status="status",id="cluster") ud$strata <- factor(ud$strata); ud$intstrata <- factor(ud$intstrata) ## makes strata specific id variable to identify pairs within strata ## se's computed based on the id variable across strata "cluster" ud$idstrata <- ud$id+(as.numeric(ud$strata)-1)*2000 marg2 <- aalen(Surv(boxtime,status)~-1+factor(num):factor(intstrata), data=ud,n.sim=0,robust=0) tdes <- model.matrix(~-1+factor(strata),data=ud) fitp2 <- survival.twostage(marg2,data=ud,se.clusters=ud$cluster,clusters=ud$idstrata, score.method="fisher.scoring",model="clayton.oakes", theta.des=tdes,step=0.5) summary(fitp2) ### now fitting the model with symmetry, i.e. strata 2 and 3 same effect ud$stratas <- ud$strata; ud$stratas[ud$strata=="0.5-2,0-0.5"] <- "0-0.5,0.5-2" tdes2 <- model.matrix(~-1+factor(stratas),data=ud) fitp3 <- survival.twostage(marg2,data=ud,clusters=ud$idstrata,se.cluster=ud$cluster, score.method="fisher.scoring",model="clayton.oakes", theta.des=tdes2,step=0.5) summary(fitp3) ### same model using strata option, a bit slower fitp4 <- survival.twostage(marg2,data=ud,clusters=ud$cluster,se.cluster=ud$cluster, score.method="fisher.scoring",model="clayton.oakes", theta.des=tdes2,step=0.5,strata=ud$strata) summary(fitp4) } \donttest{ ## Reduce Ex.Timings ### structured random effects model additive gamma ACE ### simulate structured two-stage additive gamma ACE model data <- simClaytonOakes.twin.ace(4000,2,1,0,3) out <- twin.polygen.design(data,id="cluster") pardes <- out$pardes pardes des.rv <- out$des.rv head(des.rv) aa <- phreg(Surv(time,status)~x+cluster(cluster),data=data,robust=0) ts <- survival.twostage(aa,data=data,clusters=data$cluster,detail=0, theta=c(2,1),var.link=0,step=0.5, random.design=des.rv,theta.des=pardes) summary(ts) } } \references{ Twostage estimation of additive gamma frailty models for survival data. Scheike (2019), work in progress Shih and Louis (1995) Inference on the association parameter in copula models for bivariate survival data, Biometrics, (1995). Glidden (2000), A Two-Stage estimator of the dependence parameter for the Clayton Oakes model, LIDA, (2000). Measuring early or late dependence for bivariate twin data Scheike, Holst, Hjelmborg (2015), LIDA Estimating heritability for cause specific mortality based on twins studies Scheike, Holst, Hjelmborg (2014), LIDA Additive Gamma frailty models for competing risks data, Biometrics (2015) Eriksson and Scheike (2015), } \author{ Thomas Scheike } \keyword{survival} mets/man/dlag.Rd0000644000176200001440000000131013623061405013166 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dutils.R \name{dlag} \alias{dlag} \alias{dlag<-} \title{Lag operator} \usage{ dlag(data, x, k = 1, combine = TRUE, simplify = TRUE, names, ...) } \arguments{ \item{data}{data.frame or vector} \item{x}{optional column names or formula} \item{k}{lag (vector of integers)} \item{combine}{combine results with original data.frame} \item{simplify}{Return vector if possible} \item{names}{optional new column names} \item{...}{additional arguments to lower level functions} } \description{ Lag operator } \examples{ d <- data.frame(y=1:10,x=c(10:1)) dlag(d,k=1:2) dlag(d,~x,k=0:1) dlag(d$x,k=1) dlag(d$x,k=-1:2, names=letters[1:4]) } mets/man/familyclusterWithProbands.index.Rd0000644000176200001440000000175613623061405020613 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/clusterindex-reshape.R \name{familyclusterWithProbands.index} \alias{familyclusterWithProbands.index} \title{Finds all pairs within a cluster (famly) with the proband (case/control)} \usage{ familyclusterWithProbands.index(clusters, probands, index.type = FALSE, num = NULL, Rindex = 1) } \arguments{ \item{clusters}{list of indeces giving the clusters (families)} \item{probands}{list of 0,1 where 1 specifices which of the subjects that are probands} \item{index.type}{argument passed to other functions} \item{num}{argument passed to other functions} \item{Rindex}{index starts with 1, in C is it is 0} } \description{ second column of pairs are the probands and the first column the related subjects } \examples{ i<-c(1,1,2,2,1,3) p<-c(1,0,0,1,0,1) d<- familyclusterWithProbands.index(i,p) print(d) } \references{ Cluster indeces } \seealso{ familycluster.index cluster.index } \author{ Klaus Holst, Thomas Scheike } mets/man/basehazplot.phreg.Rd0000644000176200001440000000311313623061405015702 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phreg.R \name{basehazplot.phreg} \alias{basehazplot.phreg} \alias{bplot} \alias{basecumhaz} \alias{plotConfRegion} \title{Plotting the baslines of stratified Cox} \usage{ basehazplot.phreg(x, se = FALSE, time = NULL, add = FALSE, ylim = NULL, xlim = NULL, lty = NULL, col = NULL, legend = TRUE, ylab = NULL, xlab = NULL, polygon = TRUE, level = 0.95, stratas = NULL, robust = FALSE, ...) } \arguments{ \item{x}{phreg object} \item{se}{to include standard errors} \item{time}{to plot for specific time variables} \item{add}{to add to previous plot} \item{ylim}{to give ylim} \item{xlim}{to give xlim} \item{lty}{to specify lty of components} \item{col}{to specify col of components} \item{legend}{to specify col of components} \item{ylab}{to specify ylab} \item{xlab}{to specify xlab} \item{polygon}{to get standard error in shaded form} \item{level}{of standard errors} \item{stratas}{wich strata to plot} \item{robust}{to use robust standard errors if possible} \item{...}{Additional arguments to lower level funtions} } \description{ Plotting the baslines of stratified Cox } \examples{ data(TRACE) dcut(TRACE) <- ~. out1 <- phreg(Surv(time,status==9)~vf+chf+strata(wmicat.4),data=TRACE) par(mfrow=c(2,2)) bplot(out1) bplot(out1,stratas=c(0,3)) bplot(out1,stratas=c(0,3),col=2:3,lty=1:2,se=TRUE) bplot(out1,stratas=c(0),col=2,lty=2,se=TRUE,polygon=FALSE) bplot(out1,stratas=c(0),col=matrix(c(2,1,3),1,3), lty=matrix(c(1,2,3),1,3),se=TRUE,polygon=FALSE) } \author{ Klaus K. Holst, Thomas Scheike } mets/man/internal.Rd0000644000176200001440000000271613623061405014106 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mets-package.R \name{npc} \alias{npc} \alias{plotcr} \alias{nonparcuminc} \alias{simnordic} \alias{corsim.prostate} \alias{alpha2kendall} \alias{alpha2spear} \alias{coefmat} \alias{piecewise.twostage} \alias{surv.boxarea} \alias{faster.reshape} \alias{piecewise.data} \alias{simBinPlack} \alias{simBinFam} \alias{simBinFam2} \alias{simSurvFam} \alias{corsim.prostate.random} \alias{simnordic.random} \alias{simCox} \alias{sim} \alias{grouptable} \alias{jumptimes} \alias{folds} \alias{ace.family.design} \alias{ascertained.pairs} \alias{CCbinomial.twostage} \alias{coarse.clust} \alias{concordanceTwinACE} \alias{concordanceTwostage} \alias{fast.cluster} \alias{force.same.cens} \alias{ilap} \alias{kendall.ClaytonOakes.twin.ace} \alias{kendall.normal.twin.ace} \alias{make.pairwise.design} \alias{make.pairwise.design.competing} \alias{matplot.mets.twostage} \alias{object.defined} \alias{p11.binomial.twostage.RV} \alias{predictPairPlack} \alias{simbinClaytonOakes.family.ace} \alias{simbinClaytonOakes.pairs} \alias{simbinClaytonOakes.twin.ace} \alias{simClaytonOakes.family.ace} \alias{simClaytonOakes.twin.ace} \alias{simFrailty.simple} \alias{simCompete.simple} \alias{simCompete.twin.ace} \alias{twin.polygen.design} \alias{twostage.fullse} \alias{procform} \alias{procform3} \alias{procformdata} \title{For internal use} \description{ For internal use } \author{ Klaus K. Holst } \keyword{utilities} mets/man/ipw.Rd0000644000176200001440000000377113623061405013073 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ipw.R \name{ipw} \alias{ipw} \title{Inverse Probability of Censoring Weights} \usage{ ipw(formula, data, cluster, same.cens = FALSE, obs.only = TRUE, weight.name = "w", trunc.prob = FALSE, weight.name2 = "wt", indi.weight = "pr", cens.model = "aalen", pairs = FALSE, theta.formula = ~1, ...) } \arguments{ \item{formula}{Formula specifying the censoring model} \item{data}{data frame} \item{cluster}{clustering variable} \item{same.cens}{For clustered data, should same censoring be assumed (bivariate probability calculated as mininum of the marginal probabilities)} \item{obs.only}{Return data with uncensored observations only} \item{weight.name}{Name of weight variable in the new data.frame} \item{trunc.prob}{If TRUE truncation probabilities are also calculated and stored in 'weight.name2' (based on Clayton-Oakes gamma frailty model)} \item{weight.name2}{Name of truncation probabilities} \item{indi.weight}{Name of individual censoring weight in the new data.frame} \item{cens.model}{Censoring model (default Aalens additive model)} \item{pairs}{For paired data (e.g. twins) only the complete pairs are returned (With pairs=TRUE)} \item{theta.formula}{Model for the dependence parameter in the Clayton-Oakes model (truncation only)} \item{...}{Additional arguments to censoring model} } \description{ Internal function. Calculates Inverse Probability of Censoring Weights (IPCW) and adds them to a data.frame } \examples{ \dontrun{ data("prt",package="mets") prtw <- ipw(Surv(time,status==0)~country, data=prt[sample(nrow(prt),5000),], cluster="id",weight.name="w") plot(0,type="n",xlim=range(prtw$time),ylim=c(0,1),xlab="Age",ylab="Probability") count <- 0 for (l in unique(prtw$country)) { count <- count+1 prtw <- prtw[order(prtw$time),] with(subset(prtw,country==l), lines(time,w,col=count,lwd=2)) } legend("topright",legend=unique(prtw$country),col=1:4,pch=-1,lty=1) } } \author{ Klaus K. Holst } mets/man/back2timereg.Rd0000644000176200001440000000044513623061405014626 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/casewise.R \name{back2timereg} \alias{back2timereg} \title{Convert to timereg object} \usage{ back2timereg(obj) } \arguments{ \item{obj}{no use} } \description{ convert to timereg object } \author{ Thomas Scheike } mets/man/print.casewise.Rd0000644000176200001440000000065713623061405015232 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/casewise.R \name{print.casewise} \alias{print.casewise} \title{prints Concordance test} \usage{ \method{print}{casewise}(x, digits = 3, ...) } \arguments{ \item{x}{output from casewise.test} \item{digits}{number of digits} \item{\dots}{Additional arguments to lower level functions} } \description{ prints Concordance test } \author{ Thomas Scheike } mets/man/bptwin.Rd0000644000176200001440000000557313623061405013601 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bptwin.R \name{bptwin} \alias{bptwin} \alias{twinlm.time} \alias{bptwin.time} \title{Liability model for twin data} \usage{ bptwin(x, data, id, zyg, DZ, group = NULL, num = NULL, weights = NULL, biweight = function(x) 1/min(x), strata = NULL, messages = 1, control = list(trace = 0), type = "ace", eqmean = TRUE, pairs.only = FALSE, samecens = TRUE, allmarg = samecens & !is.null(weights), stderr = TRUE, robustvar = TRUE, p, indiv = FALSE, constrain, bound = FALSE, varlink, ...) } \arguments{ \item{x}{Formula specifying effects of covariates on the response.} \item{data}{\code{data.frame} with one observation pr row. In addition a column with the zygosity (DZ or MZ given as a factor) of each individual much be specified as well as a twin id variable giving a unique pair of numbers/factors to each twin pair.} \item{id}{The name of the column in the dataset containing the twin-id variable.} \item{zyg}{The name of the column in the dataset containing the zygosity variable.} \item{DZ}{Character defining the level in the zyg variable corresponding to the dyzogitic twins.} \item{group}{Optional. Variable name defining group for interaction analysis (e.g., gender)} \item{num}{Optional twin number variable} \item{weights}{Weight matrix if needed by the chosen estimator (IPCW)} \item{biweight}{Function defining the bivariate weight in each cluster} \item{strata}{Strata} \item{messages}{Control amount of messages shown} \item{control}{Control argument parsed on to the optimization routine. Starting values may be parsed as '\code{start}'.} \item{type}{Character defining the type of analysis to be performed. Should be a subset of "acde" (additive genetic factors, common environmental factors, dominant genetic factors, unique environmental factors).} \item{eqmean}{Equal means (with type="cor")?} \item{pairs.only}{Include complete pairs only?} \item{samecens}{Same censoring} \item{allmarg}{Should all marginal terms be included} \item{stderr}{Should standard errors be calculated?} \item{robustvar}{If TRUE robust (sandwich) variance estimates of the variance are used} \item{p}{Parameter vector p in which to evaluate log-Likelihood and score function} \item{indiv}{If TRUE the score and log-Likelihood contribution of each twin-pair} \item{constrain}{Development argument} \item{bound}{Development argument} \item{varlink}{Link function for variance parameters} \item{...}{Additional arguments to lower level functions} } \description{ Liability-threshold model for twin data } \examples{ data(twinstut) b0 <- bptwin(stutter~sex, data=droplevels(subset(twinstut,zyg\%in\%c("mz","dz"))), id="tvparnr",zyg="zyg",DZ="dz",type="ae") summary(b0) } \seealso{ \code{\link{twinlm}}, \code{\link{twinlm.time}}, \code{\link{twinlm.strata}}, \code{\link{twinsim}} } \author{ Klaus K. Holst } mets/man/mets.options.Rd0000644000176200001440000000116513623061405014731 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/options.R \name{mets.options} \alias{mets.options} \title{Set global options for \code{mets}} \usage{ mets.options(...) } \arguments{ \item{...}{Arguments} } \value{ \code{list} of parameters } \description{ Extract and set global parameters of \code{mets}. } \details{ \itemize{ \item \code{regex}: If TRUE character vectors will be interpreted as regular expressions (\code{dby}, \code{dcut}, ...) \item \code{silent}: Set to \code{FALSE} to disable various output messages } } \examples{ \dontrun{ mets.options(regex=TRUE) } } \keyword{models} mets/man/ipw2.Rd0000644000176200001440000000655013623061405013153 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ipw.R \name{ipw2} \alias{ipw2} \title{Inverse Probability of Censoring Weights} \usage{ ipw2(data, times = NULL, entrytime = NULL, time = "time", cause = "cause", same.cens = FALSE, cluster = NULL, pairs = FALSE, strata = NULL, obs.only = TRUE, cens.formula = NULL, cens.code = 0, pair.cweight = "pcw", pair.tweight = "ptw", pair.weight = "weights", cname = "cweights", tname = "tweights", weight.name = "indi.weights", prec.factor = 100, ...) } \arguments{ \item{data}{data frame} \item{times}{possible time argument for speciying a maximum value of time tau=max(times), to specify when things are considered censored or not.} \item{entrytime}{nam of entry-time for truncation.} \item{time}{name of time variable on data frame.} \item{cause}{name of cause indicator on data frame.} \item{same.cens}{For clustered data, should same censoring be assumed and same truncation (bivariate probability calculated as mininum of the marginal probabilities)} \item{cluster}{name of clustering variable} \item{pairs}{For paired data (e.g. twins) only the complete pairs are returned (With pairs=TRUE)} \item{strata}{name of strata variable to get weights stratified.} \item{obs.only}{Return data with uncensored observations only} \item{cens.formula}{model for Cox models for truncation and right censoring times.} \item{cens.code}{censoring.code} \item{pair.cweight}{Name of weight variable in the new data.frame for right censorig of pairs} \item{pair.tweight}{Name of weight variable in the new data.frame for left truncation of pairs} \item{pair.weight}{Name of weight variable in the new data.frame for right censoring and left truncation of pairs} \item{cname}{Name of weight variable in the new data.frame for right censoring of individuals} \item{tname}{Name of weight variable in the new data.frame for left truncation of individuals} \item{weight.name}{Name of weight variable in the new data.frame for right censoring and left truncation of individuals} \item{prec.factor}{To let tied censoring and truncation times come after the death times.} \item{...}{Additional arguments to censoring model} } \description{ Internal function. Calculates Inverse Probability of Censoring and Truncation Weights and adds them to a data.frame } \examples{ library("timereg") d <- simnordic.random(3000,delayed=TRUE,ptrunc=0.7, cordz=0.5,cormz=2,lam0=0.3,country=FALSE) d$strata <- as.numeric(d$country)+(d$zyg=="MZ")*4 times <- seq(60,100,by=10) c1 <- comp.risk(Event(time,cause)~1+cluster(id),data=d,cause=1, model="fg",times=times,max.clust=NULL,n.sim=0) mm=model.matrix(~-1+zyg,data=d) out1<-random.cif(c1,data=d,cause1=1,cause2=1,same.cens=TRUE,theta.des=mm) summary(out1) pc1 <- predict(c1,X=1,se=0) plot(pc1) dl <- d[!d$truncated,] dl <- ipw2(dl,cluster="id",same.cens=TRUE,time="time",entrytime="entry",cause="cause", strata="strata",prec.factor=100) cl <- comp.risk(Event(time,cause)~+1+ cluster(id), data=dl,cause=1,model="fg", weights=dl$indi.weights,cens.weights=rep(1,nrow(dl)), times=times,max.clust=NULL,n.sim=0) pcl <- predict(cl,X=1,se=0) lines(pcl$time,pcl$P1,col=2) mm=model.matrix(~-1+factor(zyg),data=dl) out2<-random.cif(cl,data=dl,cause1=1,cause2=1,theta.des=mm, weights=dl$weights,censoring.weights=rep(1,nrow(dl))) summary(out2) } \author{ Thomas Scheike } mets/man/bicomprisk.Rd0000644000176200001440000000702613623061405014433 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bicomprisk.R \name{bicomprisk} \alias{bicomprisk} \title{Estimation of concordance in bivariate competing risks data} \usage{ bicomprisk(formula, data, cause = c(1, 1), cens = 0, causes, indiv, strata = NULL, id, num, max.clust = 1000, marg = NULL, se.clusters = NULL, wname = NULL, prodlim = FALSE, messages = TRUE, model, return.data = 0, uniform = 0, conservative = 1, resample.iid = 1, ...) } \arguments{ \item{formula}{Formula with left-hand-side being a \code{Event} object (see example below) and the left-hand-side specying the covariate structure} \item{data}{Data frame} \item{cause}{Causes (default (1,1)) for which to estimate the bivariate cumulative incidence} \item{cens}{The censoring code} \item{causes}{causes} \item{indiv}{indiv} \item{strata}{Strata} \item{id}{Clustering variable} \item{num}{num} \item{max.clust}{max number of clusters in comp.risk call for iid decompostion, max.clust=NULL uses all clusters otherwise rougher grouping.} \item{marg}{marginal cumulative incidence to make stanard errors for same clusters for subsequent use in casewise.test()} \item{se.clusters}{to specify clusters for standard errors. Either a vector of cluster indices or a column name in \code{data}. Defaults to the \code{id} variable.} \item{wname}{name of additonal weight used for paired competing risks data.} \item{prodlim}{prodlim to use prodlim estimator (Aalen-Johansen) rather than IPCW weighted estimator based on comp.risk function.These are equivalent in the case of no covariates. These esimators are the same in the case of stratified fitting.} \item{messages}{Control amount of output} \item{model}{Type of competing risk model (default is Fine-Gray model "fg", see comp.risk).} \item{return.data}{Should data be returned (skipping modeling)} \item{uniform}{to compute uniform standard errors for concordance estimates based on resampling.} \item{conservative}{for conservative standard errors, recommended for larger data-sets.} \item{resample.iid}{to return iid residual processes for further computations such as tests.} \item{...}{Additional arguments to comp.risk function} } \description{ Estimation of concordance in bivariate competing risks data } \examples{ library("timereg") ## Simulated data example prt <- simnordic.random(2000,delayed=TRUE,ptrunc=0.7, cordz=0.5,cormz=2,lam0=0.3) ## Bivariate competing risk, concordance estimates p11 <- bicomprisk(Event(time,cause)~strata(zyg)+id(id),data=prt,cause=c(1,1)) p11mz <- p11$model$"MZ" p11dz <- p11$model$"DZ" par(mfrow=c(1,2)) ## Concordance plot(p11mz,ylim=c(0,0.1)); plot(p11dz,ylim=c(0,0.1)); ## entry time, truncation weighting ### other weighting procedure prtl <- prt[!prt$truncated,] prt2 <- ipw2(prtl,cluster="id",same.cens=TRUE, time="time",cause="cause",entrytime="entry", pairs=TRUE,strata="zyg",obs.only=TRUE) prt22 <- fast.reshape(prt2,id="id") prt22$event <- (prt22$cause1==1)*(prt22$cause2==1)*1 prt22$timel <- pmax(prt22$time1,prt22$time2) ipwc <- comp.risk(Event(timel,event)~-1+factor(zyg1), data=prt22,cause=1,n.sim=0,model="rcif2",times=50:90, weights=prt22$weights1,cens.weights=rep(1,nrow(prt22))) p11wmz <- ipwc$cum[,2] p11wdz <- ipwc$cum[,3] lines(ipwc$cum[,1],p11wmz,col=3) lines(ipwc$cum[,1],p11wdz,col=3) } \references{ Scheike, T. H.; Holst, K. K. & Hjelmborg, J. B. Estimating twin concordance for bivariate competing risks twin data Statistics in Medicine, Wiley Online Library, 2014 , 33 , 1193-204 } \author{ Thomas Scheike, Klaus K. Holst } mets/man/haploX.Rd0000644000176200001440000000052413623061405013520 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mets-package.R \docType{data} \name{haploX} \alias{haploX} \title{haploX covariates and response for haplo survival discrete survival} \source{ Simulated data } \description{ haploX covariates and response for haplo survival discrete survival } \keyword{data} mets/man/fast.pattern.Rd0000644000176200001440000000134613623061405014701 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fastpattern.R \name{fast.pattern} \alias{fast.pattern} \title{Fast pattern} \usage{ fast.pattern(x, y, categories = 2, ...) } \arguments{ \item{x}{Matrix (binary) of patterns. Optionally if \code{y} is also passed as argument, then the pattern matrix is defined as the elements agreeing in the two matrices.} \item{y}{Optional matrix argument with same dimensions as \code{x} (see above)} \item{categories}{Default 2 (binary)} \item{...}{Optional additional arguments} } \description{ Fast pattern } \examples{ X <- matrix(rbinom(100,1,0.5),ncol=4) fast.pattern(X) X <- matrix(rbinom(100,3,0.5),ncol=4) fast.pattern(X,categories=4) } \author{ Klaus K. Holst } mets/man/survival.iterative.Rd0000644000176200001440000001617513623061405016144 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/twostage.R \name{survival.iterative} \alias{survival.iterative} \title{Survival model for multivariate survival data} \usage{ survival.iterative(margsurv, data = sys.parent(), score.method = "fisher.scoring", Nit = 60, detail = 0, clusters = NULL, silent = 1, weights = NULL, control = list(), theta = NULL, theta.des = NULL, var.link = 1, iid = 1, step = 0.5, model = "clayton.oakes", marginal.trunc = NULL, marginal.survival = NULL, marginal.status = NULL, strata = NULL, se.clusters = NULL, max.clust = NULL, numDeriv = 0, random.design = NULL, pairs = NULL, pairs.rvs = NULL, numDeriv.method = "simple", additive.gamma.sum = NULL, var.par = 1, cr.models = NULL, case.control = 0, ascertained = 0, shut.up = 0) } \arguments{ \item{margsurv}{Marginal model} \item{data}{data frame} \item{score.method}{Scoring method "fisher.scoring", "nlminb", "optimize", "nlm"} \item{Nit}{Number of iterations} \item{detail}{Detail} \item{clusters}{Cluster variable} \item{silent}{Debug information} \item{weights}{Weights} \item{control}{Optimization arguments} \item{theta}{Starting values for variance components} \item{theta.des}{design for dependence parameters, when pairs are given this is could be a (pairs) x (numer of parameters) x (max number random effects) matrix} \item{var.link}{Link function for variance} \item{iid}{Calculate i.i.d. decomposition} \item{step}{Step size} \item{model}{model} \item{marginal.trunc}{marginal left truncation probabilities} \item{marginal.survival}{optional vector of marginal survival probabilities} \item{marginal.status}{related to marginal survival probabilities} \item{strata}{strata for fitting, see example} \item{se.clusters}{for clusters for se calculation with iid} \item{max.clust}{max se.clusters for se calculation with iid} \item{numDeriv}{to get numDeriv version of second derivative, otherwise uses sum of squared score} \item{random.design}{random effect design for additive gamma model, when pairs are given this is a (pairs) x (2) x (max number random effects) matrix, see pairs.rvs below} \item{pairs}{matrix with rows of indeces (two-columns) for the pairs considered in the pairwise composite score, useful for case-control sampling when marginal is known.} \item{pairs.rvs}{for additive gamma model and random.design and theta.des are given as arrays, this specifice number of random effects for each pair.} \item{numDeriv.method}{uses simple to speed up things and second derivative not so important.} \item{additive.gamma.sum}{for two.stage=0, this is specification of the lamtot in the models via a matrix that is multiplied onto the parameters theta (dimensions=(number random effects x number of theta parameters), when null then sums all parameters.} \item{var.par}{is 1 for the default parametrization with the variances of the random effects, var.par=0 specifies that the \eqn{\lambda_j}'s are used as parameters.} \item{cr.models}{competing risks models for two.stage=0, should be given as a list with models for each cause} \item{case.control}{assumes case control structure for "pairs" with second column being the probands, when this options is used the twostage model is profiled out via the paired estimating equations for the survival model.} \item{ascertained}{if the pair are sampled only when there is an event. This is in contrast to case.control sampling where a proband is given. This can be combined with control probands. Pair-call of twostage is needed and second column of pairs are the first jump time with an event for ascertained pairs, or time of control proband.} \item{shut.up}{to make the program more silent in the context of iterative procedures for case-control and ascertained sampling} } \description{ Fits additive gamma frailty model with additive hazard condtional on the random effects \deqn{ \lambda_{ij} = (V_{ij}^T Z) (X_{ij}^T \alpha(t)) } The baseline \eqn{\alpha(t)} is profiled out using marginal modelling adjusted for the random effects structure as in Eriksson and Scheike (2015). One advantage of the standard frailty model is that one can deal with competing risks for this model. For all models the standard errors do not reflect this uncertainty of the baseline estimates, and might therefore be a bit to small. To remedy this one can do bootstrapping or use survival.twostage.fullse function when possible. If clusters contain more than two times, we use a composite likelihood based on the pairwise bivariate models. Can also fit a additive gamma random effects model described in detail below. We allow a regression structure for the indenpendent gamma distributed random effects and their variances that may depend on cluster covariates. So \deqn{ \theta = z_j^T \alpha } where \eqn{z} is specified by theta.des The reported standard errors are based on the estimated information from the likelihood assuming that the marginals are known. Can also fit a structured additive gamma random effects model, such as the ACE, ADE model for survival data. Now random.design specificies the random effects for each subject within a cluster. This is a matrix of 1's and 0's with dimension n x d. With d random effects. For a cluster with two subjects, we let the random.design rows be \eqn{v_1} and \eqn{v_2}. Such that the random effects for subject 1 is \deqn{v_1^T (Z_1,...,Z_d)}, for d random effects. Each random effect has an associated parameter \eqn{(\lambda_1,...,\lambda_d)}. By construction subjects 1's random effect are Gamma distributed with mean \eqn{\lambda_j/v_1^T \lambda} and variance \eqn{\lambda_j/(v_1^T \lambda)^2}. Note that the random effect \eqn{v_1^T (Z_1,...,Z_d)} has mean 1 and variance \eqn{1/(v_1^T \lambda)}. It is here asssumed that \eqn{lamtot=v_1^T \lambda} is fixed over all clusters as it would be for the ACE model below. The lamtot parameter may be specified separately for some sets of the parameter is the additive.gamma.sum (ags) matrix is specified and then lamtot for the j'th random effect is \eqn{ags_j^T \lambda}. Based on these parameters the relative contribution (the heritability, h) is equivalent to the expected values of the random effects \eqn{\lambda_j/v_1^T \lambda} The DEFAULT parametrization uses the variances of the random effecs \deqn{ \theta_j = \lambda_j/(v_1^T \lambda)^2 } For alternative parametrizations one can specify how the parameters relate to \eqn{\lambda_j} with the function Given the random effects the survival distributions with a cluster are independent and on the form \deqn{ P(T > t| x,z) = exp( -Z A(t) \exp( Z^t beta)) } The parameters \eqn{(\lambda_1,...,\lambda_d)} are related to the parameters of the model by a regression construction \eqn{pard} (d x k), that links the \eqn{d} \eqn{\lambda} parameters with the (k) underlying \eqn{\theta} parameters \deqn{ \lambda = theta.des \theta } here using theta.des to specify these low-dimension association. Default is a diagonal matrix. The case.control option that can be used with the pair specification of the pairwise parts of the estimating equations. Here it is assumed that the second subject of each pair is the proband. } \author{ Thomas Scheike } \keyword{survival} mets/man/dspline.Rd0000644000176200001440000000327313623061405013727 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dutils.R \name{dspline} \alias{dspline} \alias{dspline<-} \title{Simple linear spline} \usage{ dspline(data, y = NULL, x = NULL, breaks = 4, probs = NULL, equi = FALSE, regex = mets.options()$regex, sep = NULL, na.rm = TRUE, labels = NULL, all = FALSE, ...) } \arguments{ \item{data}{if x is formula or names for data frame then data frame is needed.} \item{y}{name of variable, or fomula, or names of variables on data frame.} \item{x}{name of variable, or fomula, or names of variables on data frame.} \item{breaks}{number of breaks, for variables or vector of break points,} \item{probs}{groups defined from quantiles} \item{equi}{for equi-spaced breaks} \item{regex}{for regular expressions.} \item{sep}{seperator for naming of cut names.} \item{na.rm}{to remove NA for grouping variables.} \item{labels}{to use for cut groups} \item{all}{to do all variables, even when breaks are not unique} \item{...}{Optional additional arguments} } \description{ Constructs simple linear spline on a data frame using the formula syntax of dutils that is adds (x-cuti)* (x>cuti) to the data-set for each knot of the spline. The full spline is thus given by x and spline variables added to the data-set. } \examples{ data(TRACE) TRACE <- dspline(TRACE,~wmi,breaks=c(1,1.3,1.7)) cca <- coxph(Surv(time,status==9)~age+vf+chf+wmi,data=TRACE) cca2 <- coxph(Surv(time,status==9)~age+wmi+vf+chf+wmi.spline1+wmi.spline2+wmi.spline3,data=TRACE) anova(cca,cca2) nd=data.frame(age=50,vf=0,chf=0,wmi=seq(0.4,3,by=0.01)) nd <- dspline(nd,~wmi,breaks=c(1,1.3,1.7)) pl <- predict(cca2,newdata=nd) plot(nd$wmi,pl,type="l") } \author{ Thomas Scheike } mets/man/EVaddGam.Rd0000644000176200001440000000332113623061405013673 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/twostage.R \name{EVaddGam} \alias{EVaddGam} \title{Relative risk for additive gamma model} \usage{ EVaddGam(theta, x1, x2, thetades, ags) } \arguments{ \item{theta}{theta} \item{x1}{x1} \item{x2}{x2} \item{thetades}{thetades} \item{ags}{ags} } \description{ Computes the relative risk for additive gamma model at time 0 } \examples{ lam0 <- c(0.5,0.3) pars <- c(1,1,1,1,0,1) ## genetic random effects, cause1, cause2 and overall parg <- pars[c(1,3,5)] ## environmental random effects, cause1, cause2 and overall parc <- pars[c(2,4,6)] ## simulate competing risks with two causes with hazards 0.5 and 0.3 ## ace for each cause, and overall ace out <- simCompete.twin.ace(10000,parg,parc,0,2,lam0=lam0,overall=1,all.sum=1) ## setting up design for running the model mm <- familycluster.index(out$cluster) head(mm$familypairindex,n=10) pairs <- matrix(mm$familypairindex,ncol=2,byrow=TRUE) tail(pairs,n=12) # kinship <- (out[pairs[,1],"zyg"]=="MZ")+ (out[pairs[,1],"zyg"]=="DZ")*0.5 # dout <- make.pairwise.design.competing(pairs,kinship, # type="ace",compete=length(lam0),overall=1) # head(dout$ant.rvs) ## MZ # dim(dout$theta.des) # dout$random.design[,,1] ## DZ # dout$theta.des[,,nrow(pairs)] # dout$random.design[,,nrow(pairs)] # # thetades <- dout$theta.des[,,1] # x <- dout$random.design[,,1] # x ##EVaddGam(rep(1,6),x[1,],x[3,],thetades,matrix(1,18,6)) # thetades <- dout$theta.des[,,nrow(out)/2] # x <- dout$random.design[,,nrow(out)/2] ##EVaddGam(rep(1,6),x[1,],x[4,],thetades,matrix(1,18,6)) } \references{ Eriksson and Scheike (2015), Additive Gamma frailty models for competing risks data, Biometrics (2015) } \author{ Thomas Scheike } mets/man/cor.cif.Rd0000644000176200001440000001775713623061405013630 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cor.R \name{cor.cif} \alias{cor.cif} \alias{or.cif} \alias{rr.cif} \title{Cross-odds-ratio, OR or RR risk regression for competing risks} \usage{ cor.cif(cif, data, cause = NULL, times = NULL, cause1 = 1, cause2 = 1, cens.code = NULL, cens.model = "KM", Nit = 40, detail = 0, clusters = NULL, theta = NULL, theta.des = NULL, step = 1, sym = 0, weights = NULL, par.func = NULL, dpar.func = NULL, dimpar = NULL, score.method = "nlminb", same.cens = FALSE, censoring.weights = NULL, silent = 1, ...) } \arguments{ \item{cif}{a model object from the comp.risk function with the marginal cumulative incidence of cause1, i.e., the event of interest, and whose odds the comparision is compared to the conditional odds given cause2} \item{data}{a data.frame with the variables.} \item{cause}{specifies the causes related to the death times, the value cens.code is the censoring value. When missing it comes from marginal cif.} \item{times}{time-vector that specifies the times used for the estimating euqations for the cross-odds-ratio estimation.} \item{cause1}{specificies the cause considered.} \item{cause2}{specificies the cause that is conditioned on.} \item{cens.code}{specificies the code for the censoring if NULL then uses the one from the marginal cif model.} \item{cens.model}{specified which model to use for the ICPW, KM is Kaplan-Meier alternatively it may be "cox"} \item{Nit}{number of iterations for Newton-Raphson algorithm.} \item{detail}{if 0 no details are printed during iterations, if 1 details are given.} \item{clusters}{specifies the cluster structure.} \item{theta}{specifies starting values for the cross-odds-ratio parameters of the model.} \item{theta.des}{specifies a regression design for the cross-odds-ratio parameters.} \item{step}{specifies the step size for the Newton-Raphson algorithm.} \item{sym}{specifies if symmetry is used in the model.} \item{weights}{weights for estimating equations.} \item{par.func}{parfunc} \item{dpar.func}{dparfunc} \item{dimpar}{dimpar} \item{score.method}{"nlminb", can also use "fisher-scoring".} \item{same.cens}{if true then censoring within clusters are assumed to be the same variable, default is independent censoring.} \item{censoring.weights}{these probabilities are used for the bivariate censoring dist.} \item{silent}{1 to suppress output about convergence related issues.} \item{...}{Not used.} } \value{ returns an object of type 'cor'. With the following arguments: \item{theta}{estimate of proportional odds parameters of model.} \item{var.theta}{variance for gamma. } \item{hess}{the derivative of the used score.} \item{score}{scores at final stage.} \item{score}{scores at final stage.} \item{theta.iid}{matrix of iid decomposition of parametric effects.} } \description{ Fits a parametric model for the log-cross-odds-ratio for the predictive effect of for the cumulative incidence curves for \eqn{T_1} experiencing cause i given that \eqn{T_2} has experienced a cause k : \deqn{ \log(COR(i|k)) = h(\theta,z_1,i,z_2,k,t)=_{default} \theta^T z = } with the log cross odds ratio being \deqn{ COR(i|k) = \frac{O(T_1 \leq t,cause_1=i | T_2 \leq t,cause_2=k)}{ O(T_1 \leq t,cause_1=i)} } the conditional odds divided by the unconditional odds, with the odds being, respectively \deqn{ O(T_1 \leq t,cause_1=i | T_2 \leq t,cause_1=k) = \frac{ P_x(T_1 \leq t,cause_1=i | T_2 \leq t,cause_2=k)}{ P_x((T_1 \leq t,cause_1=i)^c | T_2 \leq t,cause_2=k)} } and \deqn{ O(T_1 \leq t,cause_1=i) = \frac{P_x(T_1 \leq t,cause_1=i )}{P_x((T_1 \leq t,cause_1=i)^c )}. } Here \eqn{B^c} is the complement event of \eqn{B}, \eqn{P_x} is the distribution given covariates (\eqn{x} are subject specific and \eqn{z} are cluster specific covariates), and \eqn{h()} is a function that is the simple identity \eqn{\theta^T z} by default. } \details{ The OR dependence measure is given by \deqn{ OR(i,k) = \log ( \frac{O(T_1 \leq t,cause_1=i | T_2 \leq t,cause_2=k)}{ O(T_1 \leq t,cause_1=i) | T_2 \leq t,cause_2=k)} } This measure is numerically more stabile than the COR measure, and is symetric in i,k. The RR dependence measure is given by \deqn{ RR(i,k) = \log ( \frac{P(T_1 \leq t,cause_1=i , T_2 \leq t,cause_2=k)}{ P(T_1 \leq t,cause_1=i) P(T_2 \leq t,cause_2=k)} } This measure is numerically more stabile than the COR measure, and is symetric in i,k. The model is fitted under symmetry (sym=1), i.e., such that it is assumed that \eqn{T_1} and \eqn{T_2} can be interchanged and leads to the same cross-odd-ratio (i.e. \eqn{COR(i|k) = COR(k|i))}, as would be expected for twins or without symmetry as might be the case with mothers and daughters (sym=0). \eqn{h()} may be specified as an R-function of the parameters, see example below, but the default is that it is simply \eqn{\theta^T z}. } \examples{ library("timereg") data(multcif); multcif$cause[multcif$cause==0] <- 2 zyg <- rep(rbinom(200,1,0.5),each=2) theta.des <- model.matrix(~-1+factor(zyg)) times=seq(0.05,1,by=0.05) # to speed up computations use only these time-points add<-comp.risk(Event(time,cause)~+1+cluster(id),data=multcif,cause=1, n.sim=0,times=times,model="fg",max.clust=NULL) add2<-comp.risk(Event(time,cause)~+1+cluster(id),data=multcif,cause=2, n.sim=0,times=times,model="fg",max.clust=NULL) out1<-cor.cif(add,data=multcif,cause1=1,cause2=1) summary(out1) out2<-cor.cif(add,data=multcif,cause1=1,cause2=1,theta.des=theta.des) summary(out2) ##out3<-cor.cif(add,data=multcif,cause1=1,cause2=2,cif2=add2) ##summary(out3) ########################################################### # investigating further models using parfunc and dparfunc ########################################################### \donttest{ ## Reduce Ex.Timings set.seed(100) prt<-simnordic.random(2000,cordz=2,cormz=5) prt$status <-prt$cause table(prt$status) times <- seq(40,100,by=10) cifmod <- comp.risk(Event(time,cause)~+1+cluster(id),data=prt, cause=1,n.sim=0, times=times,conservative=1,max.clust=NULL,model="fg") theta.des <- model.matrix(~-1+factor(zyg),data=prt) parfunc <- function(par,t,pardes) { par <- pardes \%*\% c(par[1],par[2]) + pardes \%*\% c( par[3]*(t-60)/12,par[4]*(t-60)/12) par } head(parfunc(c(0.1,1,0.1,1),50,theta.des)) dparfunc <- function(par,t,pardes) { dpar <- cbind(pardes, t(t(pardes) * c( (t-60)/12,(t-60)/12)) ) dpar } head(dparfunc(c(0.1,1,0.1,1),50,theta.des)) names(prt) or1 <- or.cif(cifmod,data=prt,cause1=1,cause2=1,theta.des=theta.des, same.cens=TRUE,theta=c(0.6,1.1,0.1,0.1), par.func=parfunc,dpar.func=dparfunc,dimpar=4, score.method="fisher.scoring",detail=1) summary(or1) cor1 <- cor.cif(cifmod,data=prt,cause1=1,cause2=1,theta.des=theta.des, same.cens=TRUE,theta=c(0.5,1.0,0.1,0.1), par.func=parfunc,dpar.func=dparfunc,dimpar=4, control=list(trace=TRUE),detail=1) summary(cor1) ### piecewise contant OR model gparfunc <- function(par,t,pardes) { cuts <- c(0,80,90,120) grop <- diff(t15) dsummary(xx,ll+ll2~I(agemena>15)) } mets/man/np.Rd0000644000176200001440000000033213623061405012677 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mets-package.R \docType{data} \name{np} \alias{np} \title{np data set} \source{ Simulated data } \description{ np data set } \keyword{data} mets/man/cifreg.Rd0000644000176200001440000000344213623061405013526 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cifreg.R \name{cifreg} \alias{cifreg} \title{CIF regression} \usage{ cifreg(formula, data = data, cause = 1, cens.code = 0, weights = NULL, offset = NULL, Gc = NULL, propodds = 1, ...) } \arguments{ \item{formula}{formula with 'Event' outcome} \item{data}{data frame} \item{cause}{of interest} \item{cens.code}{code of censoring} \item{weights}{weights for Cox score equations} \item{offset}{offsets for cox model} \item{Gc}{censoring weights for time argument, default is to calculate these with a Kaplan-Meier estimator, should then give G_c(T_i-)} \item{propodds}{1 is logistic model, NULL is fine-gray model} \item{...}{Additional arguments to lower level funtions} } \description{ CIF logistic for propodds=1 default CIF Fine-Gray (cloglog) regression for propodds=NULL } \details{ For FG model: \deqn{ \int (X - E ) Y_1(t) w(t) dM_1 } is computed and summed over clusters and returned multiplied with inverse of second derivative as iid.naive The iid decomposition of the beta's, however, also have a censoring term that is also is computed and added to UUiid (still scaled with inverse second derivative) \deqn{ \int (X - E ) Y_1(t) w(t) dM_1 + \int q(s)/p(s) dM_c } and returned as iid } \examples{ ## data with no ties data(bmt,package="timereg") bmt$time <- bmt$time+runif(nrow(bmt))*0.01 bmt$id <- 1:nrow(bmt) ## logistic link OR interpretation ll=cifreg(Event(time,cause)~tcell+platelet+age,data=bmt,cause=1) bplot(ll) nd <- data.frame(tcell=c(1,0),platelet=0,age=0) pll <- predict(ll,nd) plot(pll) ## Fine-Gray model llfg=cifreg(Event(time,cause)~tcell+platelet+age,data=bmt,cause=1,propodds=NULL) bplot(ll) nd <- data.frame(tcell=c(1,0),platelet=0,age=0) pll <- predict(ll,nd) plot(pll) } \author{ Thomas Scheike } mets/man/test.conc.Rd0000644000176200001440000000103413623061405014162 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/casewise.R \name{test.conc} \alias{test.conc} \title{Concordance test Compares two concordance estimates} \usage{ test.conc(conc1, conc2, same.cluster = FALSE) } \arguments{ \item{conc1}{Concordance estimate of group 1} \item{conc2}{Concordance estimate of group 2} \item{same.cluster}{if FALSE then groups are independent, otherwise estimates are based on same data.} } \description{ .. content for description (no empty lines) .. } \author{ Thomas Scheike } mets/man/easy.binomial.twostage.Rd0000644000176200001440000001622713623061405016662 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/binomial.twostage.R \name{easy.binomial.twostage} \alias{easy.binomial.twostage} \title{Fits two-stage binomial for describing depdendence in binomial data using marginals that are on logistic form using the binomial.twostage funcion, but call is different and easier and the data manipulation is build into the function. Useful in particular for family design data.} \usage{ easy.binomial.twostage(margbin = NULL, data = sys.parent(), score.method = "fisher.scoring", response = "response", id = "id", Nit = 60, detail = 0, silent = 1, weights = NULL, control = list(), theta = NULL, theta.formula = NULL, desnames = NULL, deshelp = 0, var.link = 1, iid = 1, step = 1, model = "plackett", marginal.p = NULL, strata = NULL, max.clust = NULL, se.clusters = NULL) } \arguments{ \item{margbin}{Marginal binomial model} \item{data}{data frame} \item{score.method}{Scoring method} \item{response}{name of response variable in data frame} \item{id}{name of cluster variable in data frame} \item{Nit}{Number of iterations} \item{detail}{Detail for more output for iterations} \item{silent}{Debug information} \item{weights}{Weights for log-likelihood, can be used for each type of outcome in 2x2 tables.} \item{control}{Optimization arguments} \item{theta}{Starting values for variance components} \item{theta.formula}{design for depedence, either formula or design function} \item{desnames}{names for dependence parameters} \item{deshelp}{if 1 then prints out some data sets that are used, on on which the design function operates} \item{var.link}{Link function for variance} \item{iid}{Calculate i.i.d. decomposition} \item{step}{Step size} \item{model}{model} \item{marginal.p}{vector of marginal probabilities} \item{strata}{strata for fitting} \item{max.clust}{max clusters used for i.i.d. decompostion} \item{se.clusters}{clusters for iid decomposition for roubst standard errors} } \description{ If clusters contain more than two times, the algoritm uses a compososite likelihood based on the pairwise bivariate models. } \details{ The reported standard errors are based on the estimated information from the likelihood assuming that the marginals are known. This gives correct standard errors in the case of the plackett distribution (OR model for dependence), but incorrect for the clayton-oakes types model. The OR model is often known as the ALR model. Our fitting procedures gives correct standard errors due to the ortogonality and is fast. } \examples{ data(twinstut) twinstut0 <- subset(twinstut, tvparnr<2300000) twinstut <- twinstut0 twinstut$binstut <- (twinstut$stutter=="yes")*1 theta.des <- model.matrix( ~-1+factor(zyg),data=twinstut) margbin <- glm(binstut~factor(sex)+age,data=twinstut,family=binomial()) bin <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,theta.des=theta.des,detail=0, score.method="fisher.scoring") summary(bin) lava::estimate(coef=bin$theta,vcov=bin$var.theta,f=function(p) exp(p)) twinstut$cage <- scale(twinstut$age) theta.des <- model.matrix( ~-1+factor(zyg)+cage,data=twinstut) bina <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,theta.des=theta.des,detail=0) summary(bina) theta.des <- model.matrix( ~-1+factor(zyg)+factor(zyg)*cage,data=twinstut) bina <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,theta.des=theta.des) summary(bina) out <- easy.binomial.twostage(stutter~factor(sex)+age,data=twinstut, response="binstut",id="tvparnr",var.link=1, theta.formula=~-1+factor(zyg1)) summary(out) ## refers to zygosity of first subject in eash pair : zyg1 ## could also use zyg2 (since zyg2=zyg1 within twinpair's)) desfs <- function(x,num1="zyg1",namesdes=c("mz","dz","os")) c(x[num1]=="mz",x[num1]=="dz",x[num1]=="os")*1 out3 <- easy.binomial.twostage(binstut~factor(sex)+age, data=twinstut, response="binstut",id="tvparnr", var.link=1,theta.formula=desfs, desnames=c("mz","dz","os")) summary(out3) \donttest{ ## Reduce Ex.Timings n <- 10000 set.seed(100) dd <- simBinFam(n,beta=0.3) binfam <- fast.reshape(dd,varying=c("age","x","y")) ## mother, father, children (ordered) head(binfam) ########### ########### ########### ########### ########### ########### #### simple analyses of binomial family data ########### ########### ########### ########### ########### ########### desfs <- function(x,num1="num1",num2="num2") { pp <- 1*(((x[num1]=="m")*(x[num2]=="f"))|(x[num1]=="f")*(x[num2]=="m")) pc <- (x[num1]=="m" | x[num1]=="f")*(x[num2]=="b1" | x[num2]=="b2")*1 cc <- (x[num1]=="b1")*(x[num2]=="b1" | x[num2]=="b2")*1 c(pp,pc,cc) } ud <- easy.binomial.twostage(y~+1,data=binfam, response="y",id="id", theta.formula=desfs,desnames=c("pp","pc","cc")) summary(ud) udx <- easy.binomial.twostage(y~+x,data=binfam, response="y",id="id", theta.formula=desfs,desnames=c("pp","pc","cc")) summary(udx) ########### ########### ########### ########### ########### ########### #### now allowing parent child POR to be different for mother and father ########### ########### ########### ########### ########### ########### desfsi <- function(x,num1="num1",num2="num2") { pp <- (x[num1]=="m")*(x[num2]=="f")*1 mc <- (x[num1]=="m")*(x[num2]=="b1" | x[num2]=="b2")*1 fc <- (x[num1]=="f")*(x[num2]=="b1" | x[num2]=="b2")*1 cc <- (x[num1]=="b1")*(x[num2]=="b1" | x[num2]=="b2")*1 c(pp,mc,fc,cc) } udi <- easy.binomial.twostage(y~+1,data=binfam, response="y",id="id", theta.formula=desfsi,desnames=c("pp","mother-child","father-child","cc")) summary(udi) ##now looking to see if interactions with age or age influences marginal models ##converting factors to numeric to make all involved covariates numeric ##to use desfai2 rather then desfai that works on binfam nbinfam <- binfam nbinfam$num <- as.numeric(binfam$num) head(nbinfam) desfsai <- function(x,num1="num1",num2="num2") { pp <- (x[num1]=="m")*(x[num2]=="f")*1 ### av age for pp=1 i.e parent pairs agepp <- ((as.numeric(x["age1"])+as.numeric(x["age2"]))/2-30)*pp mc <- (x[num1]=="m")*(x[num2]=="b1" | x[num2]=="b2")*1 fc <- (x[num1]=="f")*(x[num2]=="b1" | x[num2]=="b2")*1 cc <- (x[num1]=="b1")*(x[num2]=="b1" | x[num2]=="b2")*1 agecc <- ((as.numeric(x["age1"])+as.numeric(x["age2"]))/2-12)*cc c(pp,agepp,mc,fc,cc,agecc) } desfsai2 <- function(x,num1="num1",num2="num2") { pp <- (x[num1]==1)*(x[num2]==2)*1 agepp <- (((x["age1"]+x["age2"]))/2-30)*pp ### av age for pp=1 i.e parent pairs mc <- (x[num1]==1)*(x[num2]==3 | x[num2]==4)*1 fc <- (x[num1]==2)*(x[num2]==3 | x[num2]==4)*1 cc <- (x[num1]==3)*(x[num2]==3 | x[num2]==4)*1 agecc <- ((x["age1"]+x["age2"])/2-12)*cc ### av age for children c(pp,agepp,mc,fc,cc,agecc) } udxai2 <- easy.binomial.twostage(y~+x+age,data=binfam, response="y",id="id", theta.formula=desfsai, desnames=c("pp","pp-age","mother-child","father-child","cc","cc-age")) summary(udxai2) } } \keyword{binomial} \keyword{regression} mets/man/predict.phreg.Rd0000644000176200001440000000305713623061405015027 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phreg.R \name{predict.phreg} \alias{predict.phreg} \alias{tailstrata} \alias{revcumsumstrata} \alias{revcumsumstratasum} \alias{cumsumstrata} \alias{sumstrata} \alias{covfr} \alias{covfridstrata} \alias{covfridstrataCov} \alias{cumsumidstratasum} \alias{cumsumidstratasumCov} \alias{cumsumstratasum} \alias{revcumsum} \alias{revcumsumidstratasum} \alias{revcumsumidstratasumCov} \alias{robust.basehaz.phreg} \alias{matdoubleindex} \alias{mdi} \title{Predictions from proportional hazards model} \usage{ \method{predict}{phreg}(object, newdata, times = NULL, individual.time = FALSE, tminus = FALSE, se = TRUE, robust = FALSE, conf.type = "log", conf.int = 0.95, km = FALSE, ...) } \arguments{ \item{object}{phreg object} \item{newdata}{data.frame} \item{times}{Time where to predict variable, default is all time-points from the object sorted} \item{individual.time}{when TRUE then newdata and times have same length and makes only predictions for these individual times.} \item{tminus}{to make predictions in T- that is just before, useful for IPCW techniques} \item{se}{with standard errors and upper and lower confidence intervals.} \item{robust}{to get robust se's.} \item{conf.type}{transformation for suvival estimates, default is log} \item{conf.int}{significance level} \item{km}{to use Kaplan-Meier for baseline \deqn{S_{s0}(t)= (1 - dA_{s0}(t))} where s is strata.} \item{...}{Additional arguments to plot functions} } \description{ Predictions from proportional hazards model } mets/man/ghaplos.Rd0000644000176200001440000000045613623061405013726 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mets-package.R \docType{data} \name{ghaplos} \alias{ghaplos} \title{ghaplos haplo-types for subjects of haploX data} \source{ Simulated data } \description{ ghaplos haplo-types for subjects of haploX data } \keyword{data} mets/man/Bootphreg.Rd0000644000176200001440000000333613623061405014222 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/wild-phreg.R \name{Bootphreg} \alias{Bootphreg} \alias{pred.cif.boot} \title{Wild bootstrap for Cox PH regression} \usage{ Bootphreg(formula, data, offset = NULL, weights = NULL, B = 1000, type = c("exp", "poisson", "normal"), ...) } \arguments{ \item{formula}{formula with 'Surv' outcome (see \code{coxph})} \item{data}{data frame} \item{offset}{offsets for cox model} \item{weights}{weights for Cox score equations} \item{B}{bootstraps} \item{type}{distribution for multiplier} \item{...}{Additional arguments to lower level funtions} } \description{ wild bootstrap for uniform bands for Cox models } \examples{ n <- 100 x <- 4*rnorm(n) time1 <- 2*rexp(n)/exp(x*0.3) time2 <- 2*rexp(n)/exp(x*(-0.3)) status <- ifelse(time1=1, when iid=2 then avoids adding the uncertainty for marginal paramters for additive gamma model (default).} \item{step}{Step size} \item{notaylor}{Taylor expansion} \item{model}{model} \item{marginal.p}{vector of marginal probabilities} \item{beta.iid}{iid decomposition of marginal probability estimates for each subject, if based on GLM model this is computed.} \item{Dbeta.iid}{derivatives of marginal model wrt marginal parameters, if based on GLM model this is computed.} \item{strata}{strata for fitting: considers only pairs where both are from same strata} \item{max.clust}{max clusters} \item{se.clusters}{clusters for iid decomposition for roubst standard errors} \item{numDeriv}{uses Fisher scoring aprox of second derivative if 0, otherwise numerical derivatives} \item{random.design}{random effect design for additive gamma model, when pairs are given this is a (pairs) x (2) x (max number random effects) matrix, see pairs.rvs below} \item{pairs}{matrix with rows of indeces (two-columns) for the pairs considered in the pairwise composite score, useful for case-control sampling when marginal is known.} \item{pairs.rvs}{for additive gamma model and random.design and theta.des are given as arrays, this specifice number of random effects for each pair.} \item{additive.gamma.sum}{this is specification of the lamtot in the models via a matrix that is multiplied onto the parameters theta (dimensions=(number random effects x number of theta parameters), when null then sums all parameters. Default is a matrix of 1's} \item{pair.ascertained}{if pairs are sampled only when there are events in the pair i.e. Y1+Y2>=1.} \item{case.control}{if data is case control data for pair call, and here 2nd column of pairs are probands (cases or controls)} \item{twostage}{default twostage=1, to fit MLE use twostage=0} \item{beta}{is starting value for beta for MLE version} } \description{ The pairwise pairwise odds ratio model provides an alternative to the alternating logistic regression (ALR). } \details{ The reported standard errors are based on a cluster corrected score equations from the pairwise likelihoods assuming that the marginals are known. This gives correct standard errors in the case of the Odds-Ratio model (Plackett distribution) for dependence, but incorrect standard errors for the Clayton-Oakes types model (that is also called "gamma"-frailty). For the additive gamma version of the standard errors are adjusted for the uncertainty in the marginal models via an iid deomposition using the iid() function of lava. For the clayton oakes model that is not speicifed via the random effects these can be fixed subsequently using the iid influence functions for the marginal model, but typically this does not change much. For the Clayton-Oakes version of the model, given the gamma distributed random effects it is assumed that the probabilities are indpendent, and that the marginal survival functions are on logistic form \deqn{ logit(P(Y=1|X)) = \alpha + x^T \beta } therefore conditional on the random effect the probability of the event is \deqn{ logit(P(Y=1|X,Z)) = exp( -Z \cdot Laplace^{-1}(lamtot,lamtot,P(Y=1|x)) ) } Can also fit a structured additive gamma random effects model, such the ACE, ADE model for survival data: Now random.design specificies the random effects for each subject within a cluster. This is a matrix of 1's and 0's with dimension n x d. With d random effects. For a cluster with two subjects, we let the random.design rows be \eqn{v_1} and \eqn{v_2}. Such that the random effects for subject 1 is \deqn{v_1^T (Z_1,...,Z_d)}, for d random effects. Each random effect has an associated parameter \eqn{(\lambda_1,...,\lambda_d)}. By construction subjects 1's random effect are Gamma distributed with mean \eqn{\lambda_j/v_1^T \lambda} and variance \eqn{\lambda_j/(v_1^T \lambda)^2}. Note that the random effect \eqn{v_1^T (Z_1,...,Z_d)} has mean 1 and variance \eqn{1/(v_1^T \lambda)}. It is here asssumed that \eqn{lamtot=v_1^T \lambda} is fixed over all clusters as it would be for the ACE model below. The DEFAULT parametrization uses the variances of the random effecs (var.par=1) \deqn{ \theta_j = \lambda_j/(v_1^T \lambda)^2 } For alternative parametrizations (var.par=0) one can specify how the parameters relate to \eqn{\lambda_j} with the function Based on these parameters the relative contribution (the heritability, h) is equivalent to the expected values of the random effects \eqn{\lambda_j/v_1^T \lambda} Given the random effects the probabilities are independent and on the form \deqn{ logit(P(Y=1|X)) = exp( - Laplace^{-1}(lamtot,lamtot,P(Y=1|x)) ) } with the inverse laplace of the gamma distribution with mean 1 and variance lamtot. The parameters \eqn{(\lambda_1,...,\lambda_d)} are related to the parameters of the model by a regression construction \eqn{pard} (d x k), that links the \eqn{d} \eqn{\lambda} parameters with the (k) underlying \eqn{\theta} parameters \deqn{ \lambda = theta.des \theta } here using theta.des to specify these low-dimension association. Default is a diagonal matrix. } \examples{ library("timereg") data("twinstut",package="mets") twinstut0 <- subset(twinstut, tvparnr<2300000) twinstut <- twinstut0 twinstut$binstut <- (twinstut$stutter=="yes")*1 theta.des <- model.matrix( ~-1+factor(zyg),data=twinstut) margbin <- glm(binstut~factor(sex)+age,data=twinstut,family=binomial()) bin <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,theta.des=theta.des,detail=0, score.method="fisher.scoring") summary(bin) twinstut$cage <- scale(twinstut$age) theta.des <- model.matrix( ~-1+factor(zyg)+cage,data=twinstut) bina <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,theta.des=theta.des) summary(bina) theta.des <- model.matrix( ~-1+factor(zyg)+factor(zyg)*cage,data=twinstut) bina <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,theta.des=theta.des) summary(bina) ## refers to zygosity of first subject in eash pair : zyg1 ## could also use zyg2 (since zyg2=zyg1 within twinpair's)) out <- easy.binomial.twostage(stutter~factor(sex)+age,data=twinstut, response="binstut",id="tvparnr",var.link=1, theta.formula=~-1+factor(zyg1)) summary(out) ## refers to zygosity of first subject in eash pair : zyg1 ## could also use zyg2 (since zyg2=zyg1 within twinpair's)) desfs<-function(x,num1="zyg1",num2="zyg2") c(x[num1]=="dz",x[num1]=="mz",x[num1]=="os")*1 out3 <- easy.binomial.twostage(binstut~factor(sex)+age, data=twinstut,response="binstut",id="tvparnr",var.link=1, theta.formula=desfs,desnames=c("mz","dz","os")) summary(out3) ### use of clayton oakes binomial additive gamma model ########################################################### \donttest{ ## Reduce Ex.Timings data <- simbinClaytonOakes.family.ace(10000,2,1,beta=NULL,alpha=NULL) margbin <- glm(ybin~x,data=data,family=binomial()) margbin head(data) data$number <- c(1,2,3,4) data$child <- 1*(data$number==3) ### make ace random effects design out <- ace.family.design(data,member="type",id="cluster") out$pardes head(out$des.rv) bints <- binomial.twostage(margbin,data=data, clusters=data$cluster,detail=0,var.par=1, theta=c(2,1),var.link=0, random.design=out$des.rv,theta.des=out$pardes) summary(bints) data <- simbinClaytonOakes.twin.ace(10000,2,1,beta=NULL,alpha=NULL) out <- twin.polygen.design(data,id="cluster",zygname="zygosity") out$pardes head(out$des.rv) margbin <- glm(ybin~x,data=data,family=binomial()) bintwin <- binomial.twostage(margbin,data=data, clusters=data$cluster,detail=1,var.par=1, theta=c(2,1),random.design=out$des.rv,theta.des=out$pardes) summary(bintwin) concordanceTwinACE(bintwin) } } \references{ Two-stage binomial modelling } \author{ Thomas Scheike } \keyword{binomial} \keyword{regression} mets/man/fast.reshape.Rd0000644000176200001440000000656613623061405014664 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fastreshape.R \name{fast.reshape} \alias{fast.reshape} \alias{dreshape} \title{Fast reshape} \usage{ fast.reshape(data, varying, id, num, sep = "", keep, idname = "id", numname = "num", factor = FALSE, idcombine = TRUE, labelnum = FALSE, labels, regex = mets.options()$regex, dropid = FALSE, ...) } \arguments{ \item{data}{data.frame or matrix} \item{varying}{Vector of prefix-names of the time varying variables. Optional for Long->Wide reshaping.} \item{id}{id-variable. If omitted then reshape Wide->Long.} \item{num}{Optional number/time variable} \item{sep}{String seperating prefix-name with number/time} \item{keep}{Vector of column names to keep} \item{idname}{Name of id-variable (Wide->Long)} \item{numname}{Name of number-variable (Wide->Long)} \item{factor}{If true all factors are kept (otherwise treated as character)} \item{idcombine}{If TRUE and \code{id} is vector of several variables, the unique id is combined from all the variables. Otherwise the first variable is only used as identifier.} \item{labelnum}{If TRUE varying variables in wide format (going from long->wide) are labeled 1,2,3,... otherwise use 'num' variable. In long-format (going from wide->long) varying variables matching 'varying' prefix are only selected if their postfix is a number.} \item{labels}{Optional labels for the number variable} \item{regex}{Use regular expressions} \item{dropid}{Drop id in long format (default FALSE)} \item{...}{Optional additional arguments} } \description{ Fast reshape/tranpose of data } \examples{ library("lava") m <- lvm(c(y1,y2,y3,y4)~x) d <- sim(m,5) d fast.reshape(d,"y") fast.reshape(fast.reshape(d,"y"),id="id") ##### From wide-format (dd <- fast.reshape(d,"y")) ## Same with explicit setting new id and number variable/column names ## and seperator "" (default) and dropping x fast.reshape(d,"y",idname="a",timevar="b",sep="",keep=c()) ## Same with 'reshape' list-syntax fast.reshape(d,list(c("y1","y2","y3","y4")),labelnum=TRUE) ##### From long-format fast.reshape(dd,id="id") ## Restrict set up within-cluster varying variables fast.reshape(dd,"y",id="id") fast.reshape(dd,"y",id="id",keep="x",sep=".") ##### x <- data.frame(id=c(5,5,6,6,7),y=1:5,x=1:5,tv=c(1,2,2,1,2)) x (xw <- fast.reshape(x,id="id")) (xl <- fast.reshape(xw,c("y","x"),idname="id2",keep=c())) (xl <- fast.reshape(xw,c("y","x","tv"))) (xw2 <- fast.reshape(xl,id="id",num="num")) fast.reshape(xw2,c("y","x"),idname="id") ### more generally: ### varying=list(c("ym","yf","yb1","yb2"), c("zm","zf","zb1","zb2")) ### varying=list(c("ym","yf","yb1","yb2"))) ##### Family cluster example d <- mets:::simBinFam(3) d fast.reshape(d,var="y") fast.reshape(d,varying=list(c("ym","yf","yb1","yb2"))) d <- sim(lvm(~y1+y2+ya),10) d (dd <- fast.reshape(d,"y")) fast.reshape(d,"y",labelnum=TRUE) fast.reshape(dd,id="id",num="num") fast.reshape(dd,id="id",num="num",labelnum=TRUE) fast.reshape(d,c(a="y"),labelnum=TRUE) ## New column name ##### Unbalanced data m <- lvm(c(y1,y2,y3,y4)~ x+z1+z3+z5) d <- sim(m,3) d fast.reshape(d,c("y","z")) ##### not-varying syntax: fast.reshape(d,-c("x")) ##### Automatically define varying variables from trailing digits fast.reshape(d) ##### Prostate cancer example data(prt) head(prtw <- fast.reshape(prt,"cancer",id="id")) ftable(cancer1~cancer2,data=prtw) rm(prtw) } \author{ Thomas Scheike, Klaus K. Holst } mets/man/plack.cif.Rd0000644000176200001440000000104013623061405014111 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cor.R \name{plack.cif} \alias{plack.cif} \alias{plack.cif2} \title{plack Computes concordance for or.cif based model, that is Plackett random effects model} \usage{ plack.cif(cif1, cif2, object) } \arguments{ \item{cif1}{Cumulative incidence of first argument.} \item{cif2}{Cumulative incidence of second argument.} \item{object}{or.cif object with dependence parameters.} } \description{ .. content for description (no empty lines) .. } \author{ Thomas Scheike } mets/man/phreg.Rd0000644000176200001440000000244613623061405013377 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phreg.R \name{phreg} \alias{phreg} \alias{phreg.par} \alias{robust.phreg} \alias{readPhreg} \title{Fast Cox PH regression} \usage{ phreg(formula, data, offset = NULL, weights = NULL, ...) } \arguments{ \item{formula}{formula with 'Surv' outcome (see \code{coxph})} \item{data}{data frame} \item{offset}{offsets for cox model} \item{weights}{weights for Cox score equations} \item{...}{Additional arguments to lower level funtions} } \description{ Fast Cox PH regression Robust variance is default variance with the summary. } \details{ influence functions (iid) will follow numerical order of given cluster variable so ordering after $id will give iid in order of data-set. } \examples{ data(TRACE) dcut(TRACE) <- ~. out1 <- phreg(Surv(time,status==9)~vf+chf+strata(wmicat.4),data=TRACE) ## tracesim <- timereg::sim.cox(out1,1000) ## sout1 <- phreg(Surv(time,status==1)~vf+chf+strata(wmicat.4),data=tracesim) ## robust standard errors default summary(out1) par(mfrow=c(1,2)) bplot(out1) ## bplot(sout1,se=TRUE) ## computing robust variance for baseline rob1 <- robust.phreg(out1) bplot(rob1,se=TRUE,robust=TRUE) ## making iid decomposition of regression parameters betaiiid <- iid(out1) } \author{ Klaus K. Holst, Thomas Scheike } mets/man/rpch.Rd0000644000176200001440000000056613623061405013227 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pch.R \name{rpch} \alias{rpch} \alias{ppch} \title{Piecewise constant hazard distribution} \usage{ rpch(n, lambda = 1, breaks = c(0, Inf)) } \arguments{ \item{n}{sample size} \item{lambda}{rate parameters} \item{breaks}{time cut-points} } \description{ Piecewise constant hazard distribution } mets/man/dreg.Rd0000644000176200001440000001013013623061405013200 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dreg.R \name{dreg} \alias{dreg} \title{Regression for data frames with dutility call} \usage{ dreg(data, y, x = NULL, z = NULL, x.oneatatime = TRUE, x.base.names = NULL, z.arg = c("clever", "base", "group", "condition"), fun. = lm, summary. = summary, regex = FALSE, convert = NULL, doSummary = TRUE, special = NULL, equal = TRUE, test = 1, ...) } \arguments{ \item{data}{data frame} \item{y}{name of variable, or fomula, or names of variables on data frame.} \item{x}{name of variable, or fomula, or names of variables on data frame.} \item{z}{name of variable, or fomula, or names of variables on data frame.} \item{x.oneatatime}{x's one at a time} \item{x.base.names}{base covarirates} \item{z.arg}{what is Z, c("clever","base","group","condition"), clever decides based on type of Z, base means that Z is used as fixed baseline covaraites for all X, group means the analyses is done based on groups of Z, and condition means that Z specifies a condition on the data} \item{fun.}{function lm is default} \item{summary.}{summary to use} \item{regex}{regex} \item{convert}{convert} \item{doSummary}{doSummary or not} \item{special}{special's} \item{equal}{to do pairwise stuff} \item{test}{development argument} \item{...}{Additional arguments for fun} } \description{ Regression for data frames with dutility call } \examples{ ##' data(iris) data <- iris drename(iris) <- ~. names(iris) set.seed(1) iris$time <- runif(nrow(iris)) iris$time1 <- runif(nrow(iris)) iris$status <- rbinom(nrow(iris),1,0.5) iris$S1 <- with(iris,Surv(time,status)) iris$S2 <- with(iris,Surv(time1,status)) iris$id <- 1:nrow(iris) mm <- dreg(iris,"*.length"~"*.width"|I(species=="setosa" & status==1)) mm <- dreg(iris,"*.length"~"*.width"|species+status) mm <- dreg(iris,"*.length"~"*.width"|species) mm <- dreg(iris,"*.length"~"*.width"|species+status,z.arg="group") \donttest{ ## Reduce Ex.Timings y <- "S*"~"*.width" xs <- dreg(iris,y,fun.=phreg) xs <- dreg(iris,y,fun.=survdiff) y <- "S*"~"*.width" xs <- dreg(iris,y,x.oneatatime=FALSE,fun.=phreg) ## under condition y <- S1~"*.width"|I(species=="setosa" & sepal.width>3) xs <- dreg(iris,y,z.arg="condition",fun.=phreg) xs <- dreg(iris,y,fun.=phreg) ## under condition y <- S1~"*.width"|species=="setosa" xs <- dreg(iris,y,z.arg="condition",fun.=phreg) xs <- dreg(iris,y,fun.=phreg) ## with baseline after | y <- S1~"*.width"|sepal.length xs <- dreg(iris,y,fun.=phreg) ## by group by species, not working y <- S1~"*.width"|species ss <- split(iris,paste(iris$species,iris$status)) xs <- dreg(iris,y,fun.=phreg) ## species as base, species is factor so assumes that this is grouping y <- S1~"*.width"|species xs <- dreg(iris,y,z.arg="base",fun.=phreg) ## background var after | and then one of x's at at time y <- S1~"*.width"|status+"sepal*" xs <- dreg(iris,y,fun.=phreg) ## background var after | and then one of x's at at time ##y <- S1~"*.width"|status+"sepal*" ##xs <- dreg(iris,y,x.oneatatime=FALSE,fun.=phreg) ##xs <- dreg(iris,y,fun.=phreg) ## background var after | and then one of x's at at time ##y <- S1~"*.width"+factor(species) ##xs <- dreg(iris,y,fun.=phreg) ##xs <- dreg(iris,y,fun.=phreg,x.oneatatime=FALSE) y <- S1~"*.width"|factor(species) xs <- dreg(iris,y,z.arg="base",fun.=phreg) y <- S1~"*.width"|cluster(id)+factor(species) xs <- dreg(iris,y,z.arg="base",fun.=phreg) xs <- dreg(iris,y,z.arg="base",fun.=coxph) ## under condition with groups y <- S1~"*.width"|I(sepal.length>4) xs <- dreg(subset(iris,species=="setosa"),y,z.arg="group",fun.=phreg) ## under condition with groups y <- S1~"*.width"+I(log(sepal.length))|I(sepal.length>4) xs <- dreg(subset(iris,species=="setosa"),y,z.arg="group",fun.=phreg) y <- S1~"*.width"+I(dcut(sepal.length))|I(sepal.length>4) xs <- dreg(subset(iris,species=="setosa"),y,z.arg="group",fun.=phreg) ff <- function(formula,data,...) { ss <- survfit(formula,data,...) kmplot(ss,...) return(ss) } if (interactive()) { dcut(iris) <- ~"*.width" y <- S1~"*.4"|I(sepal.length>4) par(mfrow=c(1,2)) xs <- dreg(iris,y,fun.=ff) } } } \author{ Klaus K. Holst, Thomas Scheike } mets/man/simAalenFrailty.Rd0000644000176200001440000000137413623061405015355 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/aalenfrailty.R \name{simAalenFrailty} \alias{simAalenFrailty} \title{Simulate from the Aalen Frailty model} \usage{ simAalenFrailty(n = 5000, theta = 0.3, K = 2, beta0 = 1.5, beta = 1, cens = 1.5, cuts = 0, ...) } \arguments{ \item{n}{Number of observations in each cluster} \item{theta}{Dependence paramter (variance of frailty)} \item{K}{Number of clusters} \item{beta0}{Baseline (intercept)} \item{beta}{Effect (log hazard ratio) of covariate} \item{cens}{Censoring rate} \item{cuts}{time cuts} \item{...}{Additional arguments} } \description{ Simulate observations from Aalen Frailty model with Gamma distributed frailty and constant intensity. } \author{ Klaus K. Holst } mets/man/hapfreqs.Rd0000644000176200001440000000036213623061405014076 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mets-package.R \docType{data} \name{hapfreqs} \alias{hapfreqs} \title{hapfreqs data set} \source{ Simulated data } \description{ hapfreqs data set } \keyword{data} mets/man/random.cif.Rd0000644000176200001440000001056313623061405014311 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cor.R \name{random.cif} \alias{random.cif} \title{Random effects model for competing risks data} \usage{ random.cif(cif, data, cause = NULL, cif2 = NULL, cause1 = 1, cause2 = 1, cens.code = NULL, cens.model = "KM", Nit = 40, detail = 0, clusters = NULL, theta = NULL, theta.des = NULL, sym = 1, step = 1, same.cens = FALSE, var.link = 0, score.method = "fisher.scoring", entry = NULL, trunkp = 1, ...) } \arguments{ \item{cif}{a model object from the comp.risk function with the marginal cumulative incidence of cause2, i.e., the event that is conditioned on, and whose odds the comparision is made with respect to} \item{data}{a data.frame with the variables.} \item{cause}{specifies the causes related to the death times, the value cens.code is the censoring value.} \item{cif2}{specificies model for cause2 if different from cause1.} \item{cause1}{cause of first coordinate.} \item{cause2}{cause of second coordinate.} \item{cens.code}{specificies the code for the censoring if NULL then uses the one from the marginal cif model.} \item{cens.model}{specified which model to use for the ICPW, KM is Kaplan-Meier alternatively it may be "cox"} \item{Nit}{number of iterations for Newton-Raphson algorithm.} \item{detail}{if 0 no details are printed during iterations, if 1 details are given.} \item{clusters}{specifies the cluster structure.} \item{theta}{specifies starting values for the cross-odds-ratio parameters of the model.} \item{theta.des}{specifies a regression design for the cross-odds-ratio parameters.} \item{sym}{1 for symmetry 0 otherwise} \item{step}{specifies the step size for the Newton-Raphson algorith.m} \item{same.cens}{if true then censoring within clusters are assumed to be the same variable, default is independent censoring.} \item{var.link}{if var.link=1 then var is on log-scale.} \item{score.method}{default uses "nlminb" optimzer, alternatively, use the "fisher-scoring" algorithm.} \item{entry}{entry-age in case of delayed entry. Then two causes must be given.} \item{trunkp}{gives probability of survival for delayed entry, and related to entry-ages given above.} \item{...}{extra arguments.} } \value{ returns an object of type 'cor'. With the following arguments: \item{theta}{estimate of proportional odds parameters of model.} \item{var.theta}{variance for gamma. } \item{hess}{the derivative of the used score.} \item{score}{scores at final stage.} \item{score}{scores at final stage.} \item{theta.iid}{matrix of iid decomposition of parametric effects.} } \description{ Fits a random effects model describing the dependence in the cumulative incidence curves for subjects within a cluster. Given the gamma distributed random effects it is assumed that the cumulative incidence curves are indpendent, and that the marginal cumulative incidence curves are on the form \deqn{ P(T \leq t, cause=1 | x,z) = P_1(t,x,z) = 1- exp( -x^T A(t) exp(z^T \beta)) } We allow a regression structure for the random effects variances that may depend on cluster covariates. } \examples{ \donttest{ ## Reduce Ex.Timings library("timereg") d <- simnordic.random(4000,delayed=TRUE, cordz=0.5,cormz=2,lam0=0.3,country=TRUE) times <- seq(50,90,by=10) add1<-comp.risk(Event(time,cause)~-1+factor(country)+cluster(id),data=d, times=times,cause=1,max.clust=NULL) ### making group indidcator mm <- model.matrix(~-1+factor(zyg),d) out1<-random.cif(add1,data=d,cause1=1,cause2=1,theta=1,same.cens=TRUE) summary(out1) out2<-random.cif(add1,data=d,cause1=1,cause2=1,theta=1, theta.des=mm,same.cens=TRUE) summary(out2) ######################################### ##### 2 different causes ######################################### add2<-comp.risk(Event(time,cause)~const(country)+cluster(id),data=d, times=times,cause=2,max.clust=NULL) out3<-random.cif(add1,data=d,cause1=1,cause2=2,cif2=add2,sym=1,same.cens=TRUE) summary(out3) ## negative dependence out4<-random.cif(add1,data=d,cause1=1,cause2=2,cif2=add2,theta.des=mm,sym=1,same.cens=TRUE) summary(out4) ## negative dependence } } \references{ A Semiparametric Random Effects Model for Multivariate Competing Risks Data, Scheike, Zhang, Sun, Jensen (2010), Biometrika. Cross odds ratio Modelling of dependence for Multivariate Competing Risks Data, Scheike and Sun (2012), work in progress. } \author{ Thomas Scheike } \keyword{survival} mets/man/dcor.Rd0000644000176200001440000000204313623061405013212 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/daggregate.R \name{dcor} \alias{dcor} \alias{dsummary} \alias{dstr} \alias{dsubset} \alias{dquantile} \alias{dcount} \alias{dmean} \alias{dmeansd} \alias{dscalar} \alias{deval} \alias{deval2} \alias{dsum} \alias{dsd} \title{summary, tables, and correlations for data frames} \usage{ dcor(data, y = NULL, x = NULL, use = "pairwise.complete.obs", ...) } \arguments{ \item{data}{if x is formula or names for data frame then data frame is needed.} \item{y}{name of variable, or fomula, or names of variables on data frame.} \item{x}{possible group variable} \item{use}{how to handle missing values} \item{...}{Optional additional arguments} } \description{ summary, tables, and correlations for data frames } \examples{ data("sTRACE",package="timereg") dt<- sTRACE dt$time2 <- dt$time^2 dt$wmi2 <- dt$wmi^2 head(dt) dcor(dt) dcor(dt,~time+wmi) dcor(dt,~time+wmi,~vf+chf) dcor(dt,time+wmi~vf+chf) dcor(dt,c("time*","wmi*"),~vf+chf) } \author{ Klaus K. Holst and Thomas Scheike } mets/man/logitSurv.Rd0000644000176200001440000000174213623061405014266 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phreg.R \name{logitSurv} \alias{logitSurv} \title{Proportional odds survival model} \usage{ logitSurv(formula, data, offset = NULL, weights = NULL, ...) } \arguments{ \item{formula}{formula with 'Surv' outcome (see \code{coxph})} \item{data}{data frame} \item{offset}{offsets for exp(x beta) terms} \item{weights}{weights for score equations} \item{...}{Additional arguments to lower level funtions} } \description{ Semiparametric Proportional odds model, that has the advantage that \deqn{ logit(S(t|x)) = \log(\Lambda(t)) + x \beta } so covariate effects give OR of survival. } \details{ This is equivalent to using a hazards model \deqn{ Z \lambda(t) \exp(x \beta) } where Z is gamma distributed with mean and variance 1. } \examples{ data(TRACE) dcut(TRACE) <- ~. out1 <- logitSurv(Surv(time,status==9)~vf+chf+strata(wmicat.4),data=TRACE) summary(out1) gof(out1) bplot(out1) } \author{ Thomas Scheike } mets/man/phregR.Rd0000644000176200001440000000161213623061405013513 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phreg.R \name{phregR} \alias{phregR} \alias{FastCoxPLstrataR} \title{Fast Cox PH regression and calculations done in R to make play and adjustments easy} \usage{ phregR(formula, data, offset = NULL, weights = NULL, ...) } \arguments{ \item{formula}{formula with 'Surv' outcome (see \code{coxph})} \item{data}{data frame} \item{offset}{offsets for cox model} \item{weights}{weights for Cox score equations} \item{...}{Additional arguments to lower level funtions} } \description{ Fast Cox PH regression with R implementation to play and adjust in R function: FastCoxPLstrataR } \details{ Robust variance is default variance with the summary. influence functions (iid) will follow numerical order of given cluster variable so ordering after $id will give iid in order of data-set. } \author{ Klaus K. Holst, Thomas Scheike } mets/man/recurrentMarginal.Rd0000644000176200001440000000766213623061405015763 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/recurrent.marginal.R \name{recurrentMarginal} \alias{recurrentMarginal} \alias{tie.breaker} \alias{recmarg} \alias{recurrentMarginalIPCW} \title{Fast recurrent marginal mean when death is possible} \usage{ recurrentMarginal(recurrent, death, fixbeta = NULL, km = TRUE, ...) } \arguments{ \item{recurrent}{phreg object with recurrent events} \item{death}{phreg object with deaths} \item{fixbeta}{to force the estimation of standard errors to think of regression coefficients as known/fixed} \item{km}{if true then uses Kaplan-Meier for death, otherwise exp(- Nelson-Aalen )} \item{...}{Additional arguments to lower level funtions} } \description{ Fast Marginal means of recurrent events. Using the Lin and Ghosh (2000) standard errors. Fitting two models for death and recurent events these are combined to prducte the estimator \deqn{ \int_0^t S(u|x=0) dR(u|x=0) } the mean number of recurrent events, here \deqn{ S(u|x=0) } is the probability of survival for the baseline group, and \deqn{ dR(u|x=0) } is the hazard rate of an event among survivors for the baseline. Here \deqn{ S(u|x=0) } is estimated by \deqn{ exp(-\Lambda_d(u|x=0) } with \deqn{\Lambda_d(u|x=0) } being the cumulative baseline for death. } \details{ Assumes no ties in the sense that jump times needs to be unique, this is particularly so for the stratified version. } \examples{ data(base1cumhaz) data(base4cumhaz) data(drcumhaz) dr <- drcumhaz base1 <- base1cumhaz base4 <- base4cumhaz rr <- simRecurrent(1000,base1,death.cumhaz=dr) rr$x <- rnorm(nrow(rr)) rr$strata <- floor((rr$id-0.01)/500) ## to fit non-parametric models with just a baseline xr <- phreg(Surv(entry,time,status)~cluster(id),data=rr) dr <- phreg(Surv(entry,time,death)~cluster(id),data=rr) par(mfrow=c(1,3)) bplot(dr,se=TRUE) title(main="death") bplot(xr,se=TRUE) ### robust standard errors rxr <- robust.phreg(xr,fixbeta=1) bplot(rxr,se=TRUE,robust=TRUE,add=TRUE,col=4) ## marginal mean of expected number of recurrent events out <- recurrentMarginal(xr,dr) bplot(out,se=TRUE,ylab="marginal mean",col=2) ######################################################################## ### with strata ################################################## ######################################################################## xr <- phreg(Surv(entry,time,status)~strata(strata)+cluster(id),data=rr) dr <- phreg(Surv(entry,time,death)~strata(strata)+cluster(id),data=rr) par(mfrow=c(1,3)) bplot(dr,se=TRUE) title(main="death") bplot(xr,se=TRUE) rxr <- robust.phreg(xr,fixbeta=1) bplot(rxr,se=TRUE,robust=TRUE,add=TRUE,col=1:2) out <- recurrentMarginal(xr,dr) bplot(out,se=TRUE,ylab="marginal mean",col=1:2) ######################################################################## ### cox case ################################################## ######################################################################## xr <- phreg(Surv(entry,time,status)~x+cluster(id),data=rr) dr <- phreg(Surv(entry,time,death)~x+cluster(id),data=rr) par(mfrow=c(1,3)) bplot(dr,se=TRUE) title(main="death") bplot(xr,se=TRUE) rxr <- robust.phreg(xr) bplot(rxr,se=TRUE,robust=TRUE,add=TRUE,col=1:2) out <- recurrentMarginal(xr,dr) bplot(out,se=TRUE,ylab="marginal mean",col=1:2) ######################################################################## ### CIF ############################################################# ######################################################################## ### use of function to compute cumulative incidence (cif) with robust standard errors data(bmt) bmt$id <- 1:nrow(bmt) xr <- phreg(Surv(time,cause==1)~cluster(id),data=bmt) dr <- phreg(Surv(time,cause!=0)~cluster(id),data=bmt) out <- recurrentMarginal(xr,dr,km=TRUE) bplot(out,se=TRUE,ylab="cumulative incidence") } \references{ Ghosh and Lin (2002) Nonparametric Analysis of Recurrent events and death, Biometrics, 554--562. } \author{ Thomas Scheike } mets/man/Grandom.cif.Rd0000644000176200001440000001457313623061405014425 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cor.R \name{Grandom.cif} \alias{Grandom.cif} \title{Additive Random effects model for competing risks data for polygenetic modelling} \usage{ Grandom.cif(cif, data, cause = NULL, cif2 = NULL, times = NULL, cause1 = 1, cause2 = 1, cens.code = NULL, cens.model = "KM", Nit = 40, detail = 0, clusters = NULL, theta = NULL, theta.des = NULL, weights = NULL, step = 1, sym = 0, same.cens = FALSE, censoring.weights = NULL, silent = 1, var.link = 0, score.method = "fisher.scoring", entry = NULL, estimator = 1, trunkp = 1, admin.cens = NULL, random.design = NULL, ...) } \arguments{ \item{cif}{a model object from the comp.risk function with the marginal cumulative incidence of cause2, i.e., the event that is conditioned on, and whose odds the comparision is made with respect to} \item{data}{a data.frame with the variables.} \item{cause}{specifies the causes related to the death times, the value cens.code is the censoring value.} \item{cif2}{specificies model for cause2 if different from cause1.} \item{times}{time points} \item{cause1}{cause of first coordinate.} \item{cause2}{cause of second coordinate.} \item{cens.code}{specificies the code for the censoring if NULL then uses the one from the marginal cif model.} \item{cens.model}{specified which model to use for the ICPW, KM is Kaplan-Meier alternatively it may be "cox"} \item{Nit}{number of iterations for Newton-Raphson algorithm.} \item{detail}{if 0 no details are printed during iterations, if 1 details are given.} \item{clusters}{specifies the cluster structure.} \item{theta}{specifies starting values for the cross-odds-ratio parameters of the model.} \item{theta.des}{specifies a regression design for the cross-odds-ratio parameters.} \item{weights}{weights for score equations.} \item{step}{specifies the step size for the Newton-Raphson algorith.m} \item{sym}{1 for symmetri and 0 otherwise} \item{same.cens}{if true then censoring within clusters are assumed to be the same variable, default is independent censoring.} \item{censoring.weights}{Censoring probabilities} \item{silent}{debug information} \item{var.link}{if var.link=1 then var is on log-scale.} \item{score.method}{default uses "nlminb" optimzer, alternatively, use the "fisher-scoring" algorithm.} \item{entry}{entry-age in case of delayed entry. Then two causes must be given.} \item{estimator}{estimator} \item{trunkp}{gives probability of survival for delayed entry, and related to entry-ages given above.} \item{admin.cens}{Administrative censoring} \item{random.design}{specifies a regression design of 0/1's for the random effects.} \item{...}{extra arguments.} } \value{ returns an object of type 'random.cif'. With the following arguments: \item{theta}{estimate of parameters of model.} \item{var.theta}{variance for gamma. } \item{hess}{the derivative of the used score.} \item{score}{scores at final stage.} \item{theta.iid}{matrix of iid decomposition of parametric effects.} } \description{ Fits a random effects model describing the dependence in the cumulative incidence curves for subjects within a cluster. Given the gamma distributed random effects it is assumed that the cumulative incidence curves are indpendent, and that the marginal cumulative incidence curves are on additive form \deqn{ P(T \leq t, cause=1 | x,z) = P_1(t,x,z) = 1- exp( -x^T A(t) - t z^T \beta) } } \details{ We allow a regression structure for the indenpendent gamma distributed random effects and their variances that may depend on cluster covariates. random.design specificies the random effects for each subject within a cluster. This is a matrix of 1's and 0's with dimension n x d. With d random effects. For a cluster with two subjects, we let the random.design rows be \eqn{v_1} and \eqn{v_2}. Such that the random effects for subject 1 is \deqn{v_1^T (Z_1,...,Z_d)}, for d random effects. Each random effect has an associated parameter \eqn{(\lambda_1,...,\lambda_d)}. By construction subjects 1's random effect are Gamma distributed with mean \eqn{\lambda_1/v_1^T \lambda} and variance \eqn{\lambda_1/(v_1^T \lambda)^2}. Note that the random effect \eqn{v_1^T (Z_1,...,Z_d)} has mean 1 and variance \eqn{1/(v_1^T \lambda)}. The parameters \eqn{(\lambda_1,...,\lambda_d)} are related to the parameters of the model by a regression construction \eqn{pard} (d x k), that links the \eqn{d} \eqn{\lambda} parameters with the (k) underlying \eqn{\theta} parameters \deqn{ \lambda = pard \theta } } \examples{ \donttest{ ## Reduce Ex.Timings d <- simnordic.random(5000,delayed=TRUE, cordz=1.0,cormz=2,lam0=0.3,country=TRUE) times <- seq(50,90,by=10) addm<-comp.risk(Event(time,cause)~-1+factor(country)+cluster(id),data=d, times=times,cause=1,max.clust=NULL) ### making group indidcator mm <- model.matrix(~-1+factor(zyg),d) out1m<-random.cif(addm,data=d,cause1=1,cause2=1,theta=1, theta.des=mm,same.cens=TRUE) summary(out1m) ## this model can also be formulated as a random effects model ## but with different parameters out2m<-Grandom.cif(addm,data=d,cause1=1,cause2=1, theta=c(0.5,1),step=1.0, random.design=mm,same.cens=TRUE) summary(out2m) 1/out2m$theta out1m$theta #################################################################### ################### ACE modelling of twin data ##################### #################################################################### ### assume that zygbin gives the zygosity of mono and dizygotic twins ### 0 for mono and 1 for dizygotic twins. We now formulate and AC model zygbin <- d$zyg=="DZ" n <- nrow(d) ### random effects for each cluster des.rv <- cbind(mm,(zygbin==1)*rep(c(1,0)),(zygbin==1)*rep(c(0,1)),1) ### design making parameters half the variance for dizygotic components pardes <- rbind(c(1,0), c(0.5,0),c(0.5,0), c(0.5,0), c(0,1)) outacem <-Grandom.cif(addm,data=d,cause1=1,cause2=1, same.cens=TRUE,theta=c(0.35,0.15), step=1.0,theta.des=pardes,random.design=des.rv) summary(outacem) } } \references{ A Semiparametric Random Effects Model for Multivariate Competing Risks Data, Scheike, Zhang, Sun, Jensen (2010), Biometrika. Cross odds ratio Modelling of dependence for Multivariate Competing Risks Data, Scheike and Sun (2013), Biostatitistics. Scheike, Holst, Hjelmborg (2014), LIDA, Estimating heritability for cause specific hazards based on twin data } \author{ Thomas Scheike } \keyword{survival} mets/man/biprobit.Rd0000644000176200001440000001051313623061405014076 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/biprobit.R \name{biprobit} \alias{biprobit} \alias{biprobit.vector} \alias{biprobit.time} \title{Bivariate Probit model} \usage{ biprobit(x, data, id, rho = ~1, num = NULL, strata = NULL, eqmarg = TRUE, indep = FALSE, weights = NULL, biweight, samecens = TRUE, randomeffect = FALSE, vcov = "robust", pairs.only = FALSE, allmarg = samecens & !is.null(weights), control = list(trace = 0), messages = 1, constrain = NULL, table = pairs.only, p = NULL, ...) } \arguments{ \item{x}{formula (or vector)} \item{data}{data.frame} \item{id}{The name of the column in the dataset containing the cluster id-variable.} \item{rho}{Formula specifying the regression model for the dependence parameter} \item{num}{Optional name of order variable} \item{strata}{Strata} \item{eqmarg}{If TRUE same marginals are assumed (exchangeable)} \item{indep}{Independence} \item{weights}{Weights} \item{biweight}{Function defining the bivariate weight in each cluster} \item{samecens}{Same censoring} \item{randomeffect}{If TRUE a random effect model is used (otherwise correlation parameter is estimated allowing for both negative and positive dependence)} \item{vcov}{Type of standard errors to be calculated} \item{pairs.only}{Include complete pairs only?} \item{allmarg}{Should all marginal terms be included} \item{control}{Control argument parsed on to the optimization routine. Starting values may be parsed as '\code{start}'.} \item{messages}{Control amount of messages shown} \item{constrain}{Vector of parameter constraints (NA where free). Use this to set an offset.} \item{table}{Type of estimation procedure} \item{p}{Parameter vector p in which to evaluate log-Likelihood and score function} \item{...}{Optional arguments} } \description{ Bivariate Probit model } \examples{ data(prt) prt0 <- subset(prt,country=="Denmark") a <- biprobit(cancer~1+zyg, ~1+zyg, data=prt0, id="id") b <- biprobit(cancer~1+zyg, ~1+zyg, data=prt0, id="id",pairs.only=TRUE) predict(b,newdata=lava::Expand(prt,zyg=c("MZ"))) predict(b,newdata=lava::Expand(prt,zyg=c("MZ","DZ"))) \donttest{ ## Reduce Ex.Timings library(lava) m <- lvm(c(y1,y2)~x) covariance(m,y1~y2) <- "r" constrain(m,r~x+a+b) <- function(x) tanh(x[2]+x[3]*x[1]) distribution(m,~x) <- uniform.lvm(a=-1,b=1) ordinal(m) <- ~y1+y2 d <- sim(m,1000,p=c(a=0,b=-1)); d <- d[order(d$x),] dd <- fast.reshape(d) a <- biprobit(y~1+x,rho=~1+x,data=dd,id="id") summary(a, mean.contrast=c(1,.5), cor.contrast=c(1,.5)) with(predict(a,data.frame(x=seq(-1,1,by=.1))), plot(p00~x,type="l")) pp <- predict(a,data.frame(x=seq(-1,1,by=.1)),which=c(1)) plot(pp[,1]~pp$x, type="l", xlab="x", ylab="Concordance", lwd=2, xaxs="i") confband(pp$x,pp[,2],pp[,3],polygon=TRUE,lty=0,col=Col(1)) pp <- predict(a,data.frame(x=seq(-1,1,by=.1)),which=c(9)) ## rho plot(pp[,1]~pp$x, type="l", xlab="x", ylab="Correlation", lwd=2, xaxs="i") confband(pp$x,pp[,2],pp[,3],polygon=TRUE,lty=0,col=Col(1)) with(pp, lines(x,tanh(-x),lwd=2,lty=2)) xp <- seq(-1,1,length.out=6); delta <- mean(diff(xp)) a2 <- biprobit(y~1+x,rho=~1+I(cut(x,breaks=xp)),data=dd,id="id") pp2 <- predict(a2,data.frame(x=xp[-1]-delta/2),which=c(9)) ## rho confband(pp2$x,pp2[,2],pp2[,3],center=pp2[,1]) } ## Time \dontrun{ a <- biprobit.time(cancer~1, rho=~1+zyg, id="id", data=prt, eqmarg=TRUE, cens.formula=Surv(time,status==0)~1, breaks=seq(75,100,by=3),fix.censweights=TRUE) a <- biprobit.time2(cancer~1+zyg, rho=~1+zyg, id="id", data=prt0, eqmarg=TRUE, cens.formula=Surv(time,status==0)~zyg, breaks=100) a1 <- biprobit.time2(cancer~1, rho=~1, id="id", data=subset(prt0,zyg=="MZ"), eqmarg=TRUE, cens.formula=Surv(time,status==0)~1, breaks=100,pairs.only=TRUE) a2 <- biprobit.time2(cancer~1, rho=~1, id="id", data=subset(prt0,zyg=="DZ"), eqmarg=TRUE, cens.formula=Surv(time,status==0)~1, breaks=100,pairs.only=TRUE) prt0$trunc <- prt0$time*runif(nrow(prt0))*rbinom(nrow(prt0),1,0.5) a3 <- biprobit.time(cancer~1, rho=~1, id="id", data=subset(prt0,zyg=="DZ"), eqmarg=TRUE, cens.formula=Surv(trunc,time,status==0)~1, breaks=100,pairs.only=TRUE) plot(a,which=3,ylim=c(0,0.1)) } } mets/man/aalenfrailty.Rd0000644000176200001440000000312413623061405014737 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/aalenfrailty.R \name{aalenfrailty} \alias{aalenfrailty} \title{Aalen frailty model} \usage{ aalenfrailty(time, status, X, id, theta, B = NULL, ...) } \arguments{ \item{time}{Time variable} \item{status}{Status variable (0,1)} \item{X}{Covariate design matrix} \item{id}{cluster variable} \item{theta}{list of thetas (returns score evaluated here), or starting point for optimization (defaults to magic number 0.1)} \item{B}{(optional) Cumulative coefficients (update theta by fixing B)} \item{...}{Additional arguments to lower level functions} } \value{ Parameter estimates } \description{ Additive hazards model with (gamma) frailty } \details{ Aalen frailty model } \examples{ library("timereg") dd <- simAalenFrailty(5000) f <- ~1##+x X <- model.matrix(f,dd) ## design matrix for non-parametric terms system.time(out<-aalen(update(f,Surv(time,status)~.),dd,n.sim=0,robust=0)) dix <- which(dd$status==1) t1 <- system.time(bb <- .Call("Bhat",as.integer(dd$status), X,0.2,as.integer(dd$id),NULL,NULL, PACKAGE="mets")) spec <- 1 ##plot(out,spec=spec) ## plot(dd$time[dix],bb$B2[,spec],col="red",type="s", ## ylim=c(0,max(dd$time)*c(beta0,beta)[spec])) ## abline(a=0,b=c(beta0,beta)[spec]) ##' \dontrun{ thetas <- seq(0.1,2,length.out=10) Us <- unlist(aalenfrailty(dd$time,dd$status,X,dd$id,as.list(thetas))) ##plot(thetas,Us,type="l",ylim=c(-.5,1)); abline(h=0,lty=2); abline(v=theta,lty=2) op <- aalenfrailty(dd$time,dd$status,X,dd$id) op } } \author{ Klaus K. Holst } mets/man/dprint.Rd0000644000176200001440000000221213623061405013561 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dprint.R \name{dprint} \alias{dprint} \alias{dlist} \alias{dhead} \alias{dtail} \title{list, head, print, tail} \usage{ dprint(data, y = NULL, n = 0, ..., x = NULL) } \arguments{ \item{data}{if x is formula or names for data frame then data frame is needed.} \item{y}{name of variable, or fomula, or names of variables on data frame.} \item{n}{Index of observations to print (default c(1:nfirst, n-nlast:nlast)} \item{...}{Optional additional arguments (nfirst,nlast, and print options)} \item{x}{possible group variable} } \description{ listing for data frames } \examples{ n <- 20 m <- lava::lvm(letters) d <- lava::sim(m,n) dlist(d,~a+b+c) dlist(d,~a+b+c|a<0 & b>0) ## listing all : dlist(d,~a+b+c|a<0 & b>0,n=0) dlist(d,a+b+c~I(d>0)|a<0 & b>0) dlist(d,.~I(d>0)|a<0 & b>0) dlist(d,~a+b+c|a<0 & b>0, nlast=0) dlist(d,~a+b+c|a<0 & b>0, nfirst=3, nlast=3) dlist(d,~a+b+c|a<0 & b>0, 1:5) dlist(d,~a+b+c|a<0 & b>0, -(5:1)) dlist(d,~a+b+c|a<0 & b>0, list(1:5,50:55,-(5:1))) dprint(d,a+b+c ~ I(d>0) |a<0 & b>0, list(1:5,50:55,-(5:1))) } \author{ Klaus K. Holst and Thomas Scheike } mets/man/dtable.Rd0000644000176200001440000000411713623061405013522 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dtable.R \name{dtable} \alias{dtable} \alias{dtab} \title{tables for data frames} \usage{ dtable(data, y = NULL, x = NULL, ..., level = -1, response = NULL, flat = TRUE, total = FALSE, prop = FALSE, summary = NULL) } \arguments{ \item{data}{if x is formula or names for data frame then data frame is needed.} \item{y}{name of variable, or fomula, or names of variables on data frame.} \item{x}{name of variable, or fomula, or names of variables on data frame.} \item{...}{Optional additional arguments} \item{level}{1 for all marginal tables, 2 for all 2 by 2 tables, and null for the full table, possible versus group variable} \item{response}{For level=2, only produce tables with columns given by 'response' (index)} \item{flat}{produce flat tables} \item{total}{add total counts/proportions} \item{prop}{Proportions instead of counts (vector of margins)} \item{summary}{summary function} } \description{ tables for data frames } \examples{ data("sTRACE",package="timereg") dtable(sTRACE,~status) dtable(sTRACE,~status+vf) dtable(sTRACE,~status+vf,level=1) dtable(sTRACE,~status+vf,~chf+diabetes) dtable(sTRACE,c("*f*","status"),~diabetes) dtable(sTRACE,c("*f*","status"),~diabetes, level=2) dtable(sTRACE,c("*f*","status"),level=1) dtable(sTRACE,~"*f*"+status,level=1) dtable(sTRACE,~"*f*"+status+I(wmi>1.4)|age>60,level=2) dtable(sTRACE,"*f*"+status~I(wmi>0.5)|age>60,level=1) dtable(sTRACE,status~dcut(age)) dtable(sTRACE,~status+vf+sex|age>60) dtable(sTRACE,status+vf+sex~+1|age>60, level=2) dtable(sTRACE,.~status+vf+sex|age>60,level=1) dtable(sTRACE,status+vf+sex~diabetes|age>60) dtable(sTRACE,status+vf+sex~diabetes|age>60, flat=FALSE) dtable(sTRACE,status+vf+sex~diabetes|age>60, level=1) dtable(sTRACE,status+vf+sex~diabetes|age>60, level=2) dtable(sTRACE,status+vf+sex~diabetes|age>60, level=2, prop=1, total=TRUE) dtable(sTRACE,status+vf+sex~diabetes|age>60, level=2, prop=2, total=TRUE) dtable(sTRACE,status+vf+sex~diabetes|age>60, level=2, prop=1:2, summary=summary) } \author{ Klaus K. Holst and Thomas Scheike } mets/man/divide.conquer.timereg.Rd0000644000176200001440000000200413623061405016632 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/divide.conquer.R \name{divide.conquer.timereg} \alias{divide.conquer.timereg} \title{Split a data set and run function from timereg and aggregate} \usage{ divide.conquer.timereg(func = NULL, data, size, ...) } \arguments{ \item{func}{called function} \item{data}{data-frame} \item{size}{size of splits} \item{...}{Additional arguments to lower level functions} } \description{ Split a data set and run function of cox-aalen type and aggregate results } \examples{ library(timereg) data(TRACE) a <- divide.conquer.timereg(prop.odds,TRACE, formula=Event(time,status==9)~chf+vf+age,n.sim=0,size=200) coef(a) a2 <- divide.conquer.timereg(prop.odds,TRACE, formula=Event(time,status==9)~chf+vf+age,n.sim=0,size=500) coef(a2) if (interactive()) { par(mfrow=c(1,1)) plot(a,xlim=c(0,8),ylim=c(0,0.01)) par(new=TRUE) plot(a2,xlim=c(0,8),ylim=c(0,0.01)) } } \author{ Thomas Scheike, Klaus K. Holst } mets/man/simClaytonOakesWei.Rd0000644000176200001440000000151213623061405016035 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sim.clayton.oakes.R \name{simClaytonOakesWei} \alias{simClaytonOakesWei} \title{Simulate from the Clayton-Oakes frailty model} \usage{ simClaytonOakesWei(K, n, eta, beta, stoptime, weiscale = 1, weishape = 2, left = 0, pairleft = 0) } \arguments{ \item{K}{Number of clusters} \item{n}{Number of observations in each cluster} \item{eta}{1/variance} \item{beta}{Effect (log hazard ratio) of covariate} \item{stoptime}{Stopping time} \item{weiscale}{weibull scale parameter} \item{weishape}{weibull shape parameter} \item{left}{Left truncation} \item{pairleft}{pairwise (1) left truncation or individual (0)} } \description{ Simulate observations from the Clayton-Oakes copula model with Weibull type baseline and Cox marginals. } \author{ Klaus K. Holst } mets/man/LinSpline.Rd0000644000176200001440000000074313623061405014165 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dutils.R \name{LinSpline} \alias{LinSpline} \title{Simple linear spline} \usage{ LinSpline(x, knots, num = TRUE, name = "Spline") } \arguments{ \item{x}{variable to make into spline} \item{knots}{cut points} \item{num}{to give names x1 x2 and so forth} \item{name}{name of spline expansion name.1 name.2 and so forth} } \description{ Simple linear spline } \author{ Thomas Scheike } \keyword{survival} mets/man/mlogit.Rd0000644000176200001440000000262613623061405013565 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mutinomialreg.R \name{mlogit} \alias{mlogit} \title{Multinomial regression based on phreg regression} \usage{ mlogit(formula, data, offset = NULL, weights = NULL, ...) } \arguments{ \item{formula}{formula with outcome (see \code{coxph})} \item{data}{data frame} \item{offset}{offsets for partial likelihood} \item{weights}{for score equations} \item{...}{Additional arguments to lower level funtions} } \description{ Fits multinomial regression model \deqn{ P_i = \frac{ \exp( X^\beta_i ) }{ \sum_{j=1}^K \exp( X^\beta_j ) }} for \deqn{i=1,..,K} where \deqn{\beta_1 = 0}, such that \deqn{\sum_j P_j = 1} using phreg function. Thefore the ratio \deqn{\frac{P_i}{P_1} = \exp( X^\beta_i )} } \details{ Coefficients give log-Relative-Risk relative to baseline group (first level of factor, so that it can reset by relevel command). Standard errors computed based on sandwhich form \deqn{ DU^-1 \sum U_i^2 DU^-1}. Can also get influence functions (possibly robust) via iid() function, response should be a factor. } \examples{ data(bmt) dfactor(bmt) <- cause1f~cause drelevel(bmt,ref=3) <- cause3f~cause dlevels(bmt) mreg <- mlogit(cause1f~tcell+platelet,bmt) summary(mreg) mreg3 <- mlogit(cause3f~tcell+platelet,bmt) summary(mreg3) ## inverse information standard errors estimate(coef=mreg3$coef,vcov=mreg3$II) } \author{ Thomas Scheike } mets/man/base44cumhaz.Rd0000644000176200001440000000060013623061405014552 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mets-package.R \docType{data} \name{base44cumhaz} \alias{base44cumhaz} \title{rate of Occlusion/Thrombosis complication for catheter of HPN patients of Copenhagen} \source{ Estimated data } \description{ rate of Occlusion/Thrombosis complication for catheter of HPN patients of Copenhagen } \keyword{data} mets/man/drcumhaz.Rd0000644000176200001440000000047613623061405014110 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mets-package.R \docType{data} \name{drcumhaz} \alias{drcumhaz} \title{Rate for leaving HPN program for patients of Copenhagen} \source{ Estimated data } \description{ Rate for leaving HPN program for patients of Copenhagen } \keyword{data} mets/man/pmvn.Rd0000644000176200001440000000137013623061405013245 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pmvn.R \name{pmvn} \alias{pmvn} \alias{pbvn} \alias{loglikMVN} \alias{scoreMVN} \alias{dmvn} \alias{rmvn} \title{Multivariate normal distribution function} \usage{ pmvn(lower, upper, mu, sigma, cor = FALSE) } \arguments{ \item{lower}{lower limits} \item{upper}{upper limits} \item{mu}{mean vector} \item{sigma}{variance matrix or vector of correlation coefficients} \item{cor}{if TRUE sigma is treated as standardized (correlation matrix)} } \description{ Multivariate normal distribution function } \examples{ lower <- rbind(c(0,-Inf),c(-Inf,0)) upper <- rbind(c(Inf,0),c(0,Inf)) mu <- rbind(c(1,1),c(-1,1)) sigma <- diag(2)+1 pmvn(lower=lower,upper=upper,mu=mu,sigma=sigma) } mets/man/lifecourse.Rd0000644000176200001440000000372713623061405014435 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lifecourse.R \name{lifecourse} \alias{lifecourse} \title{Life-course plot} \usage{ lifecourse(formula, data, id = "id", group = NULL, type = "l", lty = 1, col = 1:10, alpha = 0.3, lwd = 1, recurrent.col = NULL, recurrent.lty = NULL, legend = NULL, pchlegend = NULL, by = NULL, status.legend = NULL, place.sl = "bottomright", xlab = "Time", ylab = "", add = FALSE, ...) } \arguments{ \item{formula}{Formula (Event(start,slut,status) ~ ...)} \item{data}{data.frame} \item{id}{Id variable} \item{group}{group variable} \item{type}{Type (line 'l', stair 's', ...)} \item{lty}{Line type} \item{col}{Colour} \item{alpha}{transparency (0-1)} \item{lwd}{Line width} \item{recurrent.col}{col of recurrence type} \item{recurrent.lty}{lty's of of recurrence type} \item{legend}{position of optional id legend} \item{pchlegend}{point type legends} \item{by}{make separate plot for each level in 'by' (formula, name of column, or vector)} \item{status.legend}{Status legend} \item{place.sl}{Placement of status legend} \item{xlab}{Label of X-axis} \item{ylab}{Label of Y-axis} \item{add}{Add to existing device} \item{...}{Additional arguments to lower level arguments} } \description{ Life-course plot for event life data with recurrent events } \examples{ data = data.frame(id=c(1,1,1,2,2),start=c(0,1,2,3,4),slut=c(1,2,4,4,7), type=c(1,2,3,2,3),status=c(0,1,2,1,2),group=c(1,1,1,2,2)) ll = lifecourse(Event(start,slut,status)~id,data,id="id") ll = lifecourse(Event(start,slut,status)~id,data,id="id",recurrent.col="type") ll = lifecourse(Event(start,slut,status)~id,data,id="id",group=~group,col=1:2) op <- par(mfrow=c(1,2)) ll = lifecourse(Event(start,slut,status)~id,data,id="id",by=~group) par(op) legends=c("censored","pregnant","married") ll = lifecourse(Event(start,slut,status)~id,data,id="id",group=~group,col=1:2,status.legend=legends) } \author{ Thomas Scheike, Klaus K. Holst } mets/man/ttpd.Rd0000644000176200001440000000044013623061405013235 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mets-package.R \docType{data} \name{ttpd} \alias{ttpd} \title{ttpd discrete survival data on interval form} \source{ Simulated data } \description{ ttpd discrete survival data on interval form } \keyword{data} mets/man/twinstut.Rd0000644000176200001440000000065413623061405014172 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mets-package.R \docType{data} \name{twinstut} \alias{twinstut} \title{Stutter data set} \format{tvparnr: twin-pair id zyg: zygosity, MZ:=mz, DZ(same sex):=dz, DZ(opposite sex):=os stutter: stutter status (yes/no) age: age nr: number within twin-pair} \description{ Based on nation-wide questionnaire answers from 33,317 Danish twins } \keyword{data} mets/man/simRecurrentII.Rd0000644000176200001440000000545313623061405015177 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/recurrent.marginal.R \name{simRecurrentII} \alias{simRecurrentII} \title{Simulation of recurrent events data based on cumulative hazards II} \usage{ simRecurrentII(n, cumhaz, cumhaz2, death.cumhaz = NULL, gap.time = FALSE, max.recurrent = 100, dhaz = NULL, haz2 = NULL, dependence = 0, var.z = 0.22, cor.mat = NULL, cens = NULL, ...) } \arguments{ \item{n}{number of id's} \item{cumhaz}{cumulative hazard of recurrent events} \item{cumhaz2}{cumulative hazard of recurrent events of type 2} \item{death.cumhaz}{cumulative hazard of death} \item{gap.time}{if true simulates gap-times with specified cumulative hazard} \item{max.recurrent}{limits number recurrent events to 100} \item{dhaz}{rate for death hazard if it is extended to time-range of first event} \item{haz2}{rate of second cause if it is extended to time-range of first event} \item{dependence}{0:independence; 1:all share same random effect with variance var.z; 2:random effect exp(normal) with correlation structure from cor.mat; 3:additive gamma distributed random effects, z1= (z11+ z12)/2 such that mean is 1 , z2= (z11^cor.mat(1,2)+ z13)/2, z3= (z12^(cor.mat(2,3)+z13^cor.mat(1,3))/2, with z11 z12 z13 are gamma with mean and variance 1 , first random effect is z1 and for N1 second random effect is z2 and for N2 third random effect is for death} \item{var.z}{variance of random effects} \item{cor.mat}{correlation matrix for var.z variance of random effects} \item{cens}{rate of censoring exponential distribution} \item{...}{Additional arguments to lower level funtions} } \description{ Simulation of recurrent events data based on cumulative hazards } \details{ Must give hazard of death and two recurrent events. Possible with two event types and their dependence can be specified but the two recurrent events need to share random effect. Based on drawing the from cumhaz and cumhaz2 and taking the first event rather the cumulative and then distributing it out. Key advantage of this is that there is more flexibility wrt random effects } \examples{ ######################################## ## getting some rates to mimick ######################################## data(base1cumhaz) data(base4cumhaz) data(drcumhaz) dr <- drcumhaz base1 <- base1cumhaz base4 <- base4cumhaz cor.mat <- corM <- rbind(c(1.0, 0.6, 0.9), c(0.6, 1.0, 0.5), c(0.9, 0.5, 1.0)) ###################################################################### ### simulating simple model that mimicks data ### now with two event types and second type has same rate as death rate ###################################################################### rr <- simRecurrentII(1000,base1,base4,death.cumhaz=dr) dtable(rr,~death+status) par(mfrow=c(2,2)) showfitsim(causes=2,rr,dr,base1,base4) } \author{ Thomas Scheike } mets/man/casewise.Rd0000644000176200001440000000246013623061405014071 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/casewise.R \name{casewise} \alias{casewise} \title{Estimates the casewise concordance based on Concordance and marginal estimate using prodlim but no testing} \usage{ casewise(conc, marg, cause.marg) } \arguments{ \item{conc}{Concordance} \item{marg}{Marginal estimate} \item{cause.marg}{specififes which cause that should be used for marginal cif based on prodlim} } \description{ .. content for description (no empty lines) .. } \examples{ \donttest{ ## Reduce Ex.Timings library(prodlim) data(prt); ### marginal cumulative incidence of prostate cancer##' outm <- prodlim(Hist(time,status)~+1,data=prt) times <- 60:100 cifmz <- predict(outm,cause=2,time=times,newdata=data.frame(zyg="MZ")) ## cause is 2 (second cause) cifdz <- predict(outm,cause=2,time=times,newdata=data.frame(zyg="DZ")) ### concordance for MZ and DZ twins cc <- bicomprisk(Event(time,status)~strata(zyg)+id(id),data=prt,cause=c(2,2),prodlim=TRUE) cdz <- cc$model$"DZ" cmz <- cc$model$"MZ" cdz <- casewise(cdz,outm,cause.marg=2) cmz <- casewise(cmz,outm,cause.marg=2) plot(cmz,ci=NULL,ylim=c(0,0.5),xlim=c(60,100),legend=TRUE,col=c(3,2,1)) par(new=TRUE) plot(cdz,ci=NULL,ylim=c(0,0.5),xlim=c(60,100),legend=TRUE) summary(cdz) summary(cmz) } } \author{ Thomas Scheike } mets/man/cif.Rd0000644000176200001440000000177113623061405013033 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phreg.R \name{cif} \alias{cif} \title{Cumulative incidence with robust standard errors} \usage{ cif(formula, data = data, cause = 1, cens.code = 0, ...) } \arguments{ \item{formula}{formula with 'Surv' outcome (see \code{coxph})} \item{data}{data frame} \item{cause}{NULL looks at all, otherwise specify which cause to consider} \item{cens.code}{censoring code "0" is default} \item{...}{Additional arguments to lower level funtions} } \description{ Cumulative incidence with robust standard errors } \examples{ data(TRACE) TRACE$cluster <- sample(1:100,1878,replace=TRUE) out1 <- cif(Event(time,status)~+1,data=TRACE,cause=9) out2 <- cif(Event(time,status)~+1+cluster(cluster),data=TRACE,cause=9) out1 <- cif(Event(time,status)~strata(vf,chf),data=TRACE,cause=9) out2 <- cif(Event(time,status)~strata(vf,chf)+cluster(cluster),data=TRACE,cause=9) par(mfrow=c(1,2)) bplot(out1,se=TRUE) bplot(out2,se=TRUE) } \author{ Thomas Scheike } mets/man/interval.logitsurv.discrete.Rd0000644000176200001440000000453113623061405017751 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/discrete-survival-haplo.R \name{interval.logitsurv.discrete} \alias{interval.logitsurv.discrete} \alias{Interval} \alias{dInterval} \alias{simlogitSurvd} \alias{predictlogitSurvd} \title{## uses HaploSurvival package of github install via devtools ## devtools::install_github("scheike/HaploSurvival") ## this is only used for simulations ## out <- simHaplo(1,100,tcoef,hapfreqs) Discrete time to event interval censored data} \usage{ interval.logitsurv.discrete(formula, data, beta = NULL, no.opt = FALSE, method = "NR", stderr = TRUE, weights = NULL, offsets = NULL, exp.link = 1, increment = 1, ...) } \arguments{ \item{formula}{formula} \item{data}{data} \item{beta}{starting values} \item{no.opt}{optimization TRUE/FALSE} \item{method}{NR, nlm} \item{stderr}{to return only estimate} \item{weights}{weights following id for GLM} \item{offsets}{following id for GLM} \item{exp.link}{parametrize increments exp(alpha) > 0} \item{increment}{using increments dG(t)=exp(alpha) as parameters} \item{...}{Additional arguments to lower level funtions lava::NR optimizer or nlm} } \description{ \deqn{ logit(P(T >t | x)) = log(G(t)) + x \beta } \deqn{ P(T >t | x) = \frac{1}{1 + G(t) exp( x \beta) } } } \details{ Input are intervals given by ]t_l,t_r] where t_r can be infinity for right-censored intervals When truly discrete ]0,1] will be an observation at 1, and ]j,j+1] will be an observation at j+1 Likelihood is maximized: \deqn{ \prod P(T_i >t_{il} | x) - P(T_I> t_{ir}| x) } } \examples{ data(ttpd) out <- interval.logitsurv.discrete(Interval(entry,time2)~X1+X2+X3+X4,ttpd) summary(out) n <- 100 Z <- matrix(rbinom(n*4,1,0.5),n,4) outsim <- simlogitSurvd(out$coef,Z) outsim <- transform(outsim,left=time,right=time+1) outsim <- dtransform(outsim,right=Inf,status==0) outss <- interval.logitsurv.discrete(Interval(left,right)~+X1+X2+X3+X4,outsim) Z <- matrix(0,5,4) Z[2:5,1:4] <- diag(4) pred <- predictlogitSurvd(out,se=FALSE) plotSurvd(pred) ## simulations n <- 100 Z <- matrix(rbinom(n*4,1,0.5),n,4) outsim <- simlogitSurvd(out$coef,Z) ### outsim <- transform(outsim,left=time,right=time+1) outsim <- dtransform(outsim,right=Inf,status==0) out$coef outss <- interval.logitsurv.discrete(Interval(left,right)~+X1+X2+X3+X4,outsim) summary(outss) } \author{ Thomas Scheike } mets/man/count.history.Rd0000644000176200001440000000255713623061405015125 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/recurrent.marginal.R \name{count.history} \alias{count.history} \title{Counts the number of previous events of two types for recurrent events processes} \usage{ count.history(data, status = "status", id = "id", types = 1:2, names.count = "Count", lag = TRUE) } \arguments{ \item{data}{data-frame} \item{status}{name of status} \item{id}{id} \item{types}{types of the events (code) related to status} \item{names.count}{name of Counts, for example Count1 Count2 when types=c(1,2)} \item{lag}{if true counts previously observed, and if lag=FALSE counts up to know} } \description{ Counts the number of previous events of two types for recurrent events processes } \examples{ ######################################## ## getting some rates to mimick ######################################## data(base1cumhaz) data(base4cumhaz) data(drcumhaz) dr <- drcumhaz base1 <- base1cumhaz base4 <- base4cumhaz ###################################################################### ### simulating simple model that mimicks data ### now with two event types and second type has same rate as death rate ###################################################################### rr <- simRecurrentII(1000,base1,base4,death.cumhaz=dr) rr <- count.history(rr) dtable(rr,~"Count*"+status,level=1) } \author{ Thomas Scheike } mets/man/base4cumhaz.Rd0000644000176200001440000000060613623061405014474 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mets-package.R \docType{data} \name{base4cumhaz} \alias{base4cumhaz} \title{rate of Mechanical (hole/defect) complication for catheter of HPN patients of Copenhagen} \source{ Estimated data } \description{ rate of Mechanical (hole/defect) complication for catheter of HPN patients of Copenhagen } \keyword{data} mets/man/Dbvn.Rd0000644000176200001440000000143613623061405013161 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Dbvn.R \name{Dbvn} \alias{Dbvn} \title{Derivatives of the bivariate normal cumulative distribution function} \usage{ Dbvn(p,design=function(p,...) { return(list(mu=cbind(p[1],p[1]), dmu=cbind(1,1), S=matrix(c(p[2],p[3],p[3],p[4]),ncol=2), dS=rbind(c(1,0,0,0),c(0,1,1,0),c(0,0,0,1))) )}, Y=cbind(0,0)) } \arguments{ \item{p}{Parameter vector} \item{design}{Design function with defines mean, derivative of mean, variance, and derivative of variance with respect to the parameter p} \item{Y}{column vector where the CDF is evaluated} } \description{ Derivatives of the bivariate normal cumulative distribution function } \author{ Klaus K. Holst } mets/man/gof.phreg.Rd0000644000176200001440000000216013623061405014142 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gof-phreg.R \name{gof.phreg} \alias{gof.phreg} \title{GOF for Cox PH regression} \usage{ \method{gof}{phreg}(object, n.sim = 1000, silent = 1, robust = NULL, ...) } \arguments{ \item{object}{is phreg object} \item{n.sim}{number of simulations for score processes} \item{silent}{to show timing estimate will be produced for longer jobs} \item{robust}{to control wether robust dM_i(t) or dN_i are used for simulations} \item{...}{Additional arguments to lower level funtions} } \description{ Cumulative score process residuals for Cox PH regression p-values based on Lin, Wei, Ying resampling. } \examples{ data(TRACE) m1 <- phreg(Surv(time,status==9)~vf+chf+diabetes,data=TRACE) gg <- gof(m1) par(mfrow=c(1,3)) plot(gg) m1 <- phreg(Surv(time,status==9)~strata(vf)+chf+diabetes,data=TRACE) ## to get Martingale ~ dN based simulations gg <- gof(m1) ## to get Martingale robust simulations, specify cluster in call m1 <- phreg(Surv(time,status==9)~chf+diabetes+cluster(id),data=TRACE) gg <- gof(m1) } \author{ Thomas Scheike and Klaus K. Holst } mets/man/easy.survival.twostage.Rd0000644000176200001440000000673313623061405016744 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/twostage.R \name{easy.survival.twostage} \alias{easy.survival.twostage} \title{Wrapper for easy fitting of Clayton-Oakes or bivariate Plackett models for bivariate survival data} \usage{ easy.survival.twostage(margsurv = NULL, data = sys.parent(), score.method = "nlminb", status = "status", time = "time", entry = NULL, id = "id", Nit = 60, detail = 0, silent = 1, weights = NULL, control = list(), theta = NULL, theta.formula = NULL, desnames = NULL, deshelp = 0, var.link = 1, iid = 1, step = 0.5, model = "plackett", marginal.surv = NULL, strata = NULL, se.clusters = NULL) } \arguments{ \item{margsurv}{model} \item{data}{data frame} \item{score.method}{Scoring method} \item{status}{Status at exit time} \item{time}{Exit time} \item{entry}{Entry time} \item{id}{name of cluster variable in data frame} \item{Nit}{Number of iterations} \item{detail}{Detail for more output for iterations} \item{silent}{Debug information} \item{weights}{Weights for log-likelihood, can be used for each type of outcome in 2x2 tables.} \item{control}{Optimization arguments} \item{theta}{Starting values for variance components} \item{theta.formula}{design for depedence, either formula or design function} \item{desnames}{names for dependence parameters} \item{deshelp}{if 1 then prints out some data sets that are used, on on which the design function operates} \item{var.link}{Link function for variance (exp link)} \item{iid}{Calculate i.i.d. decomposition} \item{step}{Step size for newton-raphson} \item{model}{plackett or clayton-oakes model} \item{marginal.surv}{vector of marginal survival probabilities} \item{strata}{strata for fitting} \item{se.clusters}{clusters for iid decomposition for roubst standard errors} } \description{ Fits two-stage model for describing depdendence in survival data using marginals that are on cox or aalen form using the twostage funcion, but call is different and easier and the data manipulation build into the function. Useful in particular for family design data. } \details{ If clusters contain more than two times, the algoritm uses a composite likelihood based on the pairwise bivariate models. The reported standard errors are based on the estimated information from the likelihood assuming that the marginals are known. } \examples{ library(mets) data("prt",package="mets") prtsam <- blocksample(prt,idvar="id",1e3,replace=FALSE) margp <- coxph(Surv(time,status==1)~factor(country),data=prtsam) fitco <- survival.twostage(margp,data=prtsam,clusters=prtsam$id) summary(fitco) des <- model.matrix(~-1+factor(zyg),data=prtsam); fitco <- survival.twostage(margp,data=prtsam,theta.des=des,clusters=prtsam$id) summary(fitco) rm(prtsam) dfam <- simSurvFam(1000) dfam <- fast.reshape(dfam,var=c("x","time","status")) desfs <- function(x,num1="num1",num2="num2") { pp <- (x[num1]=="m")*(x[num2]=="f")*1 ## mother-father pc <- (x[num1]=="m" | x[num1]=="f")*(x[num2]=="b1" | x[num2]=="b2")*1 ## mother-child cc <- (x[num1]=="b1")*(x[num2]=="b1" | x[num2]=="b2")*1 ## child-child c(pp,pc,cc) } marg <- coxph(Surv(time,status)~factor(num),data=dfam) out3 <- easy.survival.twostage(marg,data=dfam,time="time",status="status",id="id", deshelp=0, score.method="fisher.scoring",theta.formula=desfs, model="plackett", desnames=c("parent-parent","parent-child","child-cild"),iid=1) summary(out3) } \keyword{survival} \keyword{twostage} mets/man/migr.Rd0000644000176200001440000000031013623061405013214 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mets-package.R \docType{data} \name{migr} \alias{migr} \title{Migraine data} \description{ Migraine data } \keyword{data} mets/man/concordanceCor.Rd0000644000176200001440000000304113623061405015204 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cor.R \name{concordanceCor} \alias{concordanceCor} \alias{concordance.cor} \title{Concordance Computes concordance and casewise concordance} \usage{ concordanceCor(object, cif1, cif2 = NULL, messages = TRUE, model = NULL, coefs = NULL, ...) } \arguments{ \item{object}{Output from the cor.cif, rr.cif or or.cif function} \item{cif1}{Marginal cumulative incidence} \item{cif2}{Marginal cumulative incidence of other cause (cause2) if it is different from cause1} \item{messages}{To print messages} \item{model}{Specfifies wich model that is considered if object not given.} \item{coefs}{Specfifies dependence parameters if object is not given.} \item{...}{Extra arguments, not used.} } \description{ Concordance for Twins } \details{ The concordance is the probability that both twins have experienced the event of interest and is defined as \deqn{ cor(t) = P(T_1 \leq t, \epsilon_1 =1 , T_2 \leq t, \epsilon_2=1) } Similarly, the casewise concordance is \deqn{ casewise(t) = \frac{cor(t)}{P(T_1 \leq t, \epsilon_1=1) } } that is the probability that twin "2" has the event given that twins "1" has. } \references{ Estimating twin concordance for bivariate competing risks twin data Thomas H. Scheike, Klaus K. Holst and Jacob B. Hjelmborg, Statistics in Medicine 2014, 1193-1204 Estimating Twin Pair Concordance for Age of Onset. Thomas H. Scheike, Jacob V B Hjelmborg, Klaus K. Holst, 2015 in Behavior genetics DOI:10.1007/s10519-015-9729-3 } \author{ Thomas Scheike } mets/man/drelevel.Rd0000644000176200001440000000522413623061405014071 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dutils.R \name{drelevel} \alias{drelevel} \alias{dlevels} \alias{dlevel} \alias{dlev} \alias{drelev} \alias{dlev<-} \alias{dlevel<-} \alias{drelev<-} \alias{drelevel<-} \alias{dfactor} \alias{dfactor<-} \alias{dnumeric} \alias{dnumeric<-} \title{relev levels for data frames} \usage{ drelevel(data, y = NULL, x = NULL, ref = NULL, newlevels = NULL, regex = mets.options()$regex, sep = NULL, overwrite = FALSE, ...) } \arguments{ \item{data}{if x is formula or names for data frame then data frame is needed.} \item{y}{name of variable, or fomula, or names of variables on data frame.} \item{x}{name of variable, or fomula, or names of variables on data frame.} \item{ref}{new reference variable} \item{newlevels}{to combine levels of factor in data frame} \item{regex}{for regular expressions.} \item{sep}{seperator for naming of cut names.} \item{overwrite}{to overwrite variable} \item{...}{Optional additional arguments} } \description{ levels shows levels for variables in data frame, relevel relevels a factor in data.frame } \examples{ data(mena) dstr(mena) dfactor(mena) <- ~twinnum dnumeric(mena) <- ~twinnum.f dstr(mena) mena2 <- drelevel(mena,"cohort",ref="(1980,1982]") mena2 <- drelevel(mena,~cohort,ref="(1980,1982]") mena2 <- drelevel(mena,cohortII~cohort,ref="(1980,1982]") dlevels(mena) dlevels(mena2) drelevel(mena,ref="(1975,1977]") <- ~cohort drelevel(mena,ref="(1980,1982]") <- ~cohort dlevels(mena,"coh*") dtable(mena,"coh*",level=1) ### level 1 of zyg as baseline for new variable drelevel(mena,ref=1) <- ~zyg drelevel(mena,ref=c("DZ","[1973,1975]")) <- ~ zyg+cohort drelevel(mena,ref=c("DZ","[1973,1975]")) <- zygdz+cohort.early~ zyg+cohort ### level 2 of zyg and cohort as baseline for new variables drelevel(mena,ref=2) <- ~ zyg+cohort dlevels(mena) ##################### combining factor levels with newlevels argument dcut(mena,labels=c("I","II","III","IV")) <- cat4~agemena dlevels(drelevel(mena,~cat4,newlevels=1:3)) dlevels(drelevel(mena,ncat4~cat4,newlevels=3:2)) drelevel(mena,newlevels=3:2) <- ncat4~cat4 dlevels(mena) dlevels(drelevel(mena,nca4~cat4,newlevels=list(c(1,4),2:3))) drelevel(mena,newlevels=list(c(1,4),2:3)) <- nca4..2 ~ cat4 dlevels(mena) drelevel(mena,newlevels=list("I-III"=c("I","II","III"),"IV"="IV")) <- nca4..3 ~ cat4 dlevels(mena) drelevel(mena,newlevels=list("I-III"=c("I","II","III"))) <- nca4..4 ~ cat4 dlevels(mena) drelevel(mena,newlevels=list(group1=c("I","II","III"))) <- nca4..5 ~ cat4 dlevels(mena) drelevel(mena,newlevels=list(g1=c("I","II","III"),g2="IV")) <- nca4..6 ~ cat4 dlevels(mena) } \author{ Klaus K. Holst and Thomas Scheike } mets/man/gofM.phreg.Rd0000644000176200001440000000364613623061405014271 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gof-phreg.R \name{gofM.phreg} \alias{gofM.phreg} \title{GOF for Cox covariates in PH regression} \usage{ gofM.phreg(formula, data, offset = NULL, weights = NULL, modelmatrix = NULL, n.sim = 1000, silent = 1, ...) } \arguments{ \item{formula}{formula for cox regression} \item{data}{data for model} \item{offset}{offset} \item{weights}{weights} \item{modelmatrix}{matrix for cumulating residuals} \item{n.sim}{number of simulations for score processes} \item{silent}{to keep it absolutely silent, otherwise timing estimate will be prduced for longer jobs.} \item{...}{Additional arguments to lower level funtions} } \description{ Cumulative residuals after model matrix for Cox PH regression p-values based on Lin, Wei, Ying resampling. } \details{ That is, computes \deqn{ U(t) = \int_0^t M^t d \hat M } and resamples its asymptotic distribution. This will show if the residuals are consistent with the model. Typically, M will be a design matrix for the continous covariates that gives for example the quartiles, and then the plot will show if for the different quartiles of the covariate the risk prediction is consistent over time (time x covariate interaction). } \examples{ library(mets) data(TRACE) set.seed(1) TRACEsam <- blocksample(TRACE,idvar="id",replace=FALSE,100) dcut(TRACEsam) <- ~. mm <- model.matrix(~-1+factor(wmicat.4),data=TRACEsam) m1 <- gofM.phreg(Surv(time,status==9)~vf+chf+wmi,data=TRACEsam,modelmatrix=mm) summary(m1) if (interactive()) { par(mfrow=c(2,2)) plot(m1) } m1 <- gofM.phreg(Surv(time,status==9)~strata(vf)+chf+wmi,data=TRACEsam,modelmatrix=mm) summary(m1) ## cumulative sums in covariates, via design matrix mm mm <- cumContr(TRACEsam$wmi,breaks=10,equi=TRUE) m1 <- gofM.phreg(Surv(time,status==9)~strata(vf)+chf+wmi,data=TRACEsam, modelmatrix=mm,silent=0) summary(m1) } \author{ Thomas Scheike and Klaus K. Holst } mets/man/summary.cor.Rd0000644000176200001440000000417313623061405014550 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cor.R \name{summary.cor} \alias{summary.cor} \title{Summary for dependence models for competing risks} \usage{ \method{summary}{cor}(object, marg.cif = NULL, marg.cif2 = NULL, digits = 3, ...) } \arguments{ \item{object}{object from cor.cif rr.cif or or.cif for dependence between competing risks data for two causes.} \item{marg.cif}{a number that gives the cumulative incidence in one time point for which concordance and casewise concordance are computed.} \item{marg.cif2}{the cumulative incidence for cause 2 for concordance and casewise concordance are computed. Default is that it is the same as marg.cif.} \item{digits}{digits in output.} \item{...}{Additional arguments.} } \value{ prints summary for dependence model. \item{casewise}{gives casewise concordance that is, probability of cause 2 (related to cif2) given that cause 1 (related to cif1) has occured.} \item{concordance}{gives concordance that is, probability of cause 2 (related to cif2) and cause 1 (related to cif1).} \item{cif1}{cumulative incidence for cause1.} \item{cif2}{cumulative incidence for cause1.} } \description{ Computes concordance and casewise concordance for dependence models for competing risks models of the type cor.cif, rr.cif or or.cif for the given cumulative incidences and the different dependence measures in the object. } \examples{ library("timereg") data("multcif",package="mets") # simulated data multcif$cause[multcif$cause==0] <- 2 times=seq(0.1,3,by=0.1) # to speed up computations use only these time-points add<-comp.risk(Event(time,cause)~+1+cluster(id),data=multcif, n.sim=0,times=times,cause=1) ### out1<-cor.cif(add,data=multcif,cause1=1,cause2=1,theta=log(2+1)) summary(out1) pad <- predict(add,X=1,se=0,uniform=0) summary(out1,marg.cif=pad) } \references{ Cross odds ratio Modelling of dependence for Multivariate Competing Risks Data, Scheike and Sun (2012), Biostatistics. A Semiparametric Random Effects Model for Multivariate Competing Risks Data, Scheike, Zhang, Sun, Jensen (2010), Biometrika. } \author{ Thomas Scheike } \keyword{survival} mets/man/simRecurrent.Rd0000644000176200001440000000630213623061405014747 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/recurrent.marginal.R \name{simRecurrent} \alias{simRecurrent} \alias{showfitsim} \alias{simRecurrentGamma} \alias{covIntH1dM1IntH2dM2} \alias{recurrentMarginalgam} \alias{squareintHdM} \alias{addCums} \title{Simulation of recurrent events data based on cumulative hazards} \usage{ simRecurrent(n, cumhaz, death.cumhaz = NULL, cumhaz2 = NULL, gap.time = FALSE, max.recurrent = 100, dhaz = NULL, haz2 = NULL, dependence = 0, var.z = 2, cor.mat = NULL, ...) } \arguments{ \item{n}{number of id's} \item{cumhaz}{cumulative hazard of recurrent events} \item{death.cumhaz}{cumulative hazard of death} \item{cumhaz2}{cumulative hazard of recurrent events of type 2} \item{gap.time}{if true simulates gap-times with specified cumulative hazard} \item{max.recurrent}{limits number recurrent events to 100} \item{dhaz}{rate for death hazard if it is extended to time-range of first event} \item{haz2}{rate of second cause if it is extended to time-range of first event} \item{dependence}{=0 independence, =1 all share same random effect with variance var.z =2 random effect exp(normal) with correlation structure from cor.mat, first random effect is z1 and shared for a possible second cause, second random effect is for death} \item{var.z}{variance of random effects} \item{cor.mat}{correlation matrix for var.z variance of random effects} \item{...}{Additional arguments to lower level funtions} } \description{ Simulation of recurrent events data based on cumulative hazards } \details{ Must give hazard of death and recurrent events. Possible with two event types and their dependence can be specified but the two recurrent events need to have the same random effect, simRecurrentII more flexible ! } \examples{ ######################################## ## getting some rates to mimick ######################################## data(base1cumhaz) data(base4cumhaz) data(drcumhaz) dr <- drcumhaz base1 <- base1cumhaz base4 <- base4cumhaz ###################################################################### ### simulating simple model that mimicks data ###################################################################### rr <- simRecurrent(5,base1,death.cumhaz=dr) dlist(rr,.~id,n=0) rr <- simRecurrent(1000,base1,death.cumhaz=dr) par(mfrow=c(1,3)) showfitsim(causes=1,rr,dr,base1,base1) ###################################################################### ### simulating simple model that mimicks data ### now with two event types and second type has same rate as death rate ###################################################################### rr <- simRecurrent(1000,base1,death.cumhaz=dr,cumhaz2=base4) dtable(rr,~death+status) par(mfrow=c(2,2)) showfitsim(causes=2,rr,dr,base1,base4) ###################################################################### ### simulating simple model ### random effect for all causes (Z shared for death and recurrent) ###################################################################### rr <- simRecurrent(1000,base1,death.cumhaz=dr,dependence=1,var.gamma=0.4) ### marginals do fit after input after integrating out par(mfrow=c(2,2)) showfitsim(causes=1,rr,dr,base1,base1) } \author{ Thomas Scheike } mets/man/gofG.phreg.Rd0000644000176200001440000000203613623061405014253 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gof-phreg.R \name{gofG.phreg} \alias{gofG.phreg} \title{Stratified baseline graphical GOF test for Cox covariates in PH regression} \usage{ gofG.phreg(x, sim = 0, silent = 1, lm = TRUE, ...) } \arguments{ \item{x}{phreg object} \item{sim}{to simulate som variation from cox model to put on graph} \item{silent}{to keep it absolutely silent} \item{lm}{addd line to plot, regressing the cumulatives on each other} \item{...}{Additional arguments to lower level funtions} } \description{ Looks at stratified baseline in Cox model and plots all baselines versus each other to see if lines are straight, with 50 resample versions under the assumptiosn that the stratified Cox is correct } \examples{ data(TRACE) m1 <- phreg(Surv(time,status==9)~strata(vf)+chf+wmi,data=TRACE) m2 <- phreg(Surv(time,status==9)~vf+strata(chf)+wmi,data=TRACE) par(mfrow=c(2,2)) gofG.phreg(m1) gofG.phreg(m2) bplot(m1,log="y") bplot(m2,log="y") } \author{ Thomas Scheike and Klaus K. Holst } mets/man/haplo.surv.discrete.Rd0000644000176200001440000000762413623061405016177 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/discrete-survival-haplo.R \name{haplo.surv.discrete} \alias{haplo.surv.discrete} \alias{simTTP} \alias{predictSurvd} \alias{plotSurvd} \title{Discrete time to event haplo type analysis} \usage{ haplo.surv.discrete(X = NULL, y = "y", time.name = "time", Haplos = NULL, id = "id", desnames = NULL, designfunc = NULL, beta = NULL, no.opt = FALSE, method = "NR", stderr = TRUE, designMatrix = NULL, response = NULL, idhap = NULL, design.only = FALSE, covnames = NULL, fam = binomial, weights = NULL, offsets = NULL, idhapweights = NULL, ...) } \arguments{ \item{X}{design matrix data-frame (sorted after id and time variable) with id time response and desnames} \item{y}{name of response (binary response with logistic link) from X} \item{time.name}{to sort after time for X} \item{Haplos}{(data.frame with id, haplo1, haplo2 (haplotypes (h)) and p=P(h|G)) haplotypes given as factor.} \item{id}{name of id variale from X} \item{desnames}{names for design matrix} \item{designfunc}{function that computes design given haplotypes h=(h1,h2) x(h)} \item{beta}{starting values} \item{no.opt}{optimization TRUE/FALSE} \item{method}{NR, nlm} \item{stderr}{to return only estimate} \item{designMatrix}{gives response and designMatrix directly not implemented (mush contain: p, id, idhap)} \item{response}{gives response and design directly designMatrix not implemented} \item{idhap}{name of id-hap variable to specify different haplotypes for different id} \item{design.only}{to return only design matrices for haplo-type analyses.} \item{covnames}{names of covariates to extract from object for regression} \item{fam}{family of models, now binomial default and only option} \item{weights}{weights following id for GLM} \item{offsets}{following id for GLM} \item{idhapweights}{weights following id-hap for GLM (WIP)} \item{...}{Additional arguments to lower level funtions lava::NR optimizer or nlm} } \description{ Can be used for logistic regression when time variable is "1" for all id. } \details{ Cycle-specific logistic regression of haplo-type effects with known haplo-type probabilities. Given observed genotype G and unobserved haplotypes H we here mix out over the possible haplotypes using that P(H|G) is provided. \deqn{ S(t|x,G)) = E( S(t|x,H) | G) = \sum_{h \in G} P(h|G) S(t|z,h) } so survival can be computed by mixing out over possible h given g. Survival is based on logistic regression for the discrete hazard function of the form \deqn{ logit(P(T=t| T \geq t, x,h)) = \alpha_t + x(h) \beta } where x(h) is a regression design of x and haplotypes \eqn{h=(h_1,h_2)} Likelihood is maximized and standard errors assumes that P(H|G) is known. The design over the possible haplotypes is constructed by merging X with Haplos and can be viewed by design.only=TRUE } \examples{ ## some haplotypes of interest types <- c("DCGCGCTCACG","DTCCGCTGACG","ITCAGTTGACG","ITCCGCTGAGG") ## some haplotypes frequencies for simulations data(hapfreqs) www <-which(hapfreqs$haplotype \%in\% types) hapfreqs$freq[www] baseline=hapfreqs$haplotype[9] baseline designftypes <- function(x,sm=0) {# {{{ hap1=x[1] hap2=x[2] if (sm==0) y <- 1*( (hap1==types) | (hap2==types)) if (sm==1) y <- 1*(hap1==types) + 1*(hap2==types) return(y) }# }}} tcoef=c(-1.93110204,-0.47531630,-0.04118204,-1.57872602,-0.22176426,-0.13836416, 0.88830288,0.60756224,0.39802821,0.32706859) data(hHaplos) data(haploX) haploX$time <- haploX$times Xdes <- model.matrix(~factor(time),haploX) colnames(Xdes) <- paste("X",1:ncol(Xdes),sep="") X <- dkeep(haploX,~id+y+time) X <- cbind(X,Xdes) Haplos <- dkeep(ghaplos,~id+"haplo*"+p) desnames=paste("X",1:6,sep="") # six X's related to 6 cycles out <- haplo.surv.discrete(X=X,y="y",time.name="time", Haplos=Haplos,desnames=desnames,designfunc=designftypes) names(out$coef) <- c(desnames,types) out$coef summary(out) } \author{ Thomas Scheike } mets/man/simMultistate.Rd0000644000176200001440000000563313623061405015137 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/recurrent.marginal.R \name{simMultistate} \alias{simMultistate} \alias{extendCums} \title{Simulation of illness-death model} \usage{ simMultistate(n, cumhaz, cumhaz2, death.cumhaz, death.cumhaz2, rr = NULL, rr2 = NULL, rd = NULL, rd2 = NULL, gap.time = FALSE, max.recurrent = 100, dependence = 0, var.z = 0.22, cor.mat = NULL, cens = NULL, ...) } \arguments{ \item{n}{number of id's} \item{cumhaz}{cumulative hazard of recurrent events} \item{cumhaz2}{cumulative hazard of recurrent events of type 2} \item{death.cumhaz}{cumulative hazard of death from state 1} \item{death.cumhaz2}{cumulative hazard of death from state 2} \item{rr}{relative risk adjustment for cumhaz} \item{rr2}{relative risk adjustment for cumhaz2} \item{rd}{relative risk adjustment for death.cumhaz} \item{rd2}{relative risk adjustment for death.cumhaz2} \item{gap.time}{if true simulates gap-times with specified cumulative hazard} \item{max.recurrent}{limits number recurrent events to 100} \item{dependence}{0:independence; 1:all share same random effect with variance var.z; 2:random effect exp(normal) with correlation structure from cor.mat; 3:additive gamma distributed random effects, z1= (z11+ z12)/2 such that mean is 1 , z2= (z11^cor.mat(1,2)+ z13)/2, z3= (z12^(cor.mat(2,3)+z13^cor.mat(1,3))/2, with z11 z12 z13 are gamma with mean and variance 1 , first random effect is z1 and for N1 second random effect is z2 and for N2 third random effect is for death} \item{var.z}{variance of random effects} \item{cor.mat}{correlation matrix for var.z variance of random effects} \item{cens}{rate of censoring exponential distribution} \item{...}{Additional arguments to lower level funtions} } \description{ Simulation of illness-death model } \details{ simMultistate with same death intensity from states 1 and 2 simMultistateII with different death intensities from states 1 and 2 Must give cumulative hazards on some time-range } \examples{ ######################################## ## getting some rates to mimick ######################################## data(base1cumhaz) data(base4cumhaz) data(drcumhaz) dr <- drcumhaz dr2 <- drcumhaz dr2[,2] <- 1.5*drcumhaz[,2] base1 <- base1cumhaz base4 <- base4cumhaz cens <- rbind(c(0,0),c(2000,0.5),c(5110,3)) iddata <- simMultistate(100,base1,base1,dr,dr2,cens=cens) dlist(iddata,.~id|id<3,n=0) ### estimating rates from simulated data c0 <- phreg(Surv(start,stop,status==0)~+1,iddata) c3 <- phreg(Surv(start,stop,status==3)~+strata(from),iddata) c1 <- phreg(Surv(start,stop,status==1)~+1,subset(iddata,from==2)) c2 <- phreg(Surv(start,stop,status==2)~+1,subset(iddata,from==1)) ### par(mfrow=c(2,3)) bplot(c0) lines(cens,col=2) bplot(c3,main="rates 1-> 3 , 2->3") lines(dr,col=1,lwd=2) lines(dr2,col=2,lwd=2) ### bplot(c1,main="rate 1->2") lines(base1,lwd=2) ### bplot(c2,main="rate 2->1") lines(base1,lwd=2) } \author{ Thomas Scheike } mets/man/prob.exceed.recurrent.Rd0000644000176200001440000000614413623061405016477 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/recurrent.marginal.R \name{prob.exceed.recurrent} \alias{prob.exceed.recurrent} \alias{prob.exceedRecurrent} \alias{prob.exceedBiRecurrent} \alias{prob.exceedRecurrentStrata} \alias{prob.exceedBiRecurrentStrata} \title{Estimation of probability of more that k events for recurrent events process} \usage{ prob.exceed.recurrent(data, type, status = "status", death = "death", start = "start", stop = "stop", id = "id", times = NULL, exceed = NULL, cifmets = FALSE, strata = NULL, all.cifs = FALSE, ...) } \arguments{ \item{data}{data-frame} \item{type}{type of evnent (code) related to status} \item{status}{name of status} \item{death}{name of death indicator} \item{start}{start stop call of Hist() of prodlim} \item{stop}{start stop call of Hist() of prodlim} \item{id}{id} \item{times}{time at which to get probabilites P(N1(t) >= n)} \item{exceed}{n's for which which to compute probabilites P(N1(t) >= n)} \item{cifmets}{if true uses cif of mets package rather than prodlim} \item{strata}{to stratify according to variable, only for cifmets=TRUE, when strata is given then only consider the output in the all.cifs} \item{all.cifs}{if true then returns list of all fitted objects in cif.exceed} \item{...}{Additional arguments to lower level funtions} } \description{ Estimation of probability of more that k events for recurrent events process where there is terminal event, based on this also estimate of variance of recurrent events. The estimator is based on cumulative incidence of exceeding "k" events. In contrast the probability of exceeding k events can also be computed as a counting process integral, and this is implemented in prob.exceedRecurrent } \examples{ ######################################## ## getting some rates to mimick ######################################## data(base1cumhaz) data(base4cumhaz) data(drcumhaz) dr <- drcumhaz base1 <- base1cumhaz base4 <- base4cumhaz cor.mat <- corM <- rbind(c(1.0, 0.6, 0.9), c(0.6, 1.0, 0.5), c(0.9, 0.5, 1.0)) rr <- simRecurrent(1000,base1,cumhaz2=base4,death.cumhaz=dr) rr <- count.history(rr) dtable(rr,~death+status) oo <- prob.exceedRecurrent(rr,1) bplot(oo) par(mfrow=c(1,2)) with(oo,plot(time,mu,col=2,type="l")) ### with(oo,plot(time,varN,type="l")) ### Bivariate probability of exceeding oo <- prob.exceedBiRecurrent(rr,1,2,exceed1=c(1,5,10),exceed2=c(1,2,3)) with(oo, matplot(time,pe1e2,type="s")) nc <- ncol(oo$pe1e2) legend("topleft",legend=colnames(oo$pe1e2),lty=1:nc,col=1:nc) \donttest{ ### do not test to avoid dependence on prodlim ### now estimation based on cumualative incidence, but do not test to avoid dependence on prodlim library(prodlim) pp <- prob.exceed.recurrent(rr,1,status="status",death="death",start="entry",stop="time",id="id") with(pp, matplot(times,prob,type="s")) ### with(pp, matlines(times,se.lower,type="s")) with(pp, matlines(times,se.upper,type="s")) } } \references{ Scheike, Eriksson, Tribler (2019) The mean, variance and correlation for bivariate recurrent events with a terminal event, JRSS-C } \author{ Thomas Scheike } mets/man/multcif.Rd0000644000176200001440000000050413623061405013726 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mets-package.R \docType{data} \name{multcif} \alias{multcif} \title{Multivariate Cumulative Incidence Function example data set} \source{ Simulated data } \description{ Multivariate Cumulative Incidence Function example data set } \keyword{data} mets/man/twinsim.Rd0000644000176200001440000000241213623061405013755 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/twinsim.R \name{twinsim} \alias{twinsim} \title{Simulate twin data} \usage{ twinsim(nMZ = 100, nDZ = nMZ, b1 = c(), b2 = c(), mu = 0, acde = c(1, 1, 0, 1), randomslope = NULL, threshold = 0, cens = FALSE, wide = FALSE, ...) } \arguments{ \item{nMZ}{Number of monozygotic twin pairs} \item{nDZ}{Number of dizygotic twin pairs} \item{b1}{Effect of covariates (labelled x1,x2,...) of type 1. One distinct covariate value for each twin/individual.} \item{b2}{Effect of covariates (labelled g1,g2,...) of type 2. One covariate value for each twin pair.} \item{mu}{Intercept parameter.} \item{acde}{Variance of random effects (in the order A,C,D,E)} \item{randomslope}{Logical indicating wether to include random slopes of the variance components w.r.t. x1,x2,...} \item{threshold}{Treshold used to define binary outcome y0} \item{cens}{Logical variable indicating whether to censor outcome} \item{wide}{Logical indicating if wide data format should be returned} \item{...}{Additional arguments parsed on to lower-level functions} } \description{ Simulate twin data from a linear normal ACE/ADE/AE model. } \seealso{ \code{\link{twinlm}} } \author{ Klaus K. Holst } \keyword{models} \keyword{regression} mets/man/dby.Rd0000644000176200001440000000500713623061405013044 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dby.R \name{dby} \alias{dby} \alias{dby<-} \alias{dby2} \alias{dby2<-} \alias{dbyr} \title{Calculate summary statistics grouped by} \usage{ dby(data, INPUT, ..., ID = NULL, ORDER = NULL, SUBSET = NULL, SORT = 0, COMBINE = !REDUCE, NOCHECK = FALSE, ARGS = NULL, NAMES, COLUMN = FALSE, REDUCE = FALSE, REGEX = mets.options()$regex, ALL = TRUE) } \arguments{ \item{data}{Data.frame} \item{INPUT}{Input variables (character or formula)} \item{...}{functions} \item{ID}{id variable} \item{ORDER}{(optional) order variable} \item{SUBSET}{(optional) subset expression} \item{SORT}{sort order (id+order variable)} \item{COMBINE}{If TRUE result is appended to data} \item{NOCHECK}{No sorting or check for missing data} \item{ARGS}{Optional list of arguments to functions (...)} \item{NAMES}{Optional vector of column names} \item{COLUMN}{If TRUE do the calculations for each column} \item{REDUCE}{Reduce number of redundant rows} \item{REGEX}{Allow regular expressions} \item{ALL}{if FALSE only the subset will be returned} } \description{ Calculate summary statistics grouped by variable } \details{ Calculate summary statistics grouped by dby2 for column-wise calculations } \examples{ n <- 4 k <- c(3,rbinom(n-1,3,0.5)+1) N <- sum(k) d <- data.frame(y=rnorm(N),x=rnorm(N),id=rep(seq(n),k),num=unlist(sapply(k,seq))) d2 <- d[sample(nrow(d)),] dby(d2, y~id, mean) dby(d2, y~id + order(num), cumsum) dby(d,y ~ id + order(num), dlag) dby(d,y ~ id + order(num), dlag, ARGS=list(k=1:2)) dby(d,y ~ id + order(num), dlag, ARGS=list(k=1:2), NAMES=c("l1","l2")) dby(d, y~id + order(num), mean=mean, csum=cumsum, n=length) dby(d2, y~id + order(num), a=cumsum, b=mean, N=length, l1=function(x) c(NA,x)[-length(x)]) dby(d, y~id + order(num), nn=seq_along, n=length) dby(d, y~id + order(num), nn=seq_along, n=length) d <- d[,1:4] dby(d, x<0) <- list(z=mean) d <- dby(d, is.na(z), z=1) f <- function(x) apply(x,1,min) dby(d, y+x~id, min=f) dby(d,y+x~id+order(num), function(x) x) f <- function(x) { cbind(cumsum(x[,1]),cumsum(x[,2]))/sum(x)} dby(d, y+x~id, f) ## column-wise a <- d dby2(a, mean, median, REGEX=TRUE) <- '^[y|x]'~id a ## wildcards dby2(a,'y*'+'x*'~id,mean) ## subset dby(d, x<0) <- list(z=NA) d dby(d, y~id|x>-1, v=mean,z=1) dby(d, y+x~id|x>-1, mean, median, COLUMN=TRUE) dby2(d, y+x~id|x>0, mean, REDUCE=TRUE) dby(d,y~id|x<0,mean,ALL=FALSE) a <- iris a <- dby(a,y=1) dby(a,Species=="versicolor") <- list(y=2) } \author{ Klaus K. Holst and Thomas Scheike } mets/DESCRIPTION0000644000176200001440000000245013623150473012735 0ustar liggesusersPackage: mets Type: Package Title: Analysis of Multivariate Event Times Version: 1.2.7 Date: 2020-02-18 Author: Klaus K. Holst and Thomas Scheike Maintainer: Klaus K. Holst Description: Implementation of various statistical models for multivariate event history data . Including multivariate cumulative incidence models , and bivariate random effects probit models (Liability models) . Also contains two-stage binomial modelling that can do pairwise odds-ratio dependence modelling based marginal logistic regression models. This is an alternative to the alternating logistic regression approach (ALR). License: GPL (>= 2) LazyLoad: yes URL: https://github.com/kkholst/mets BugReports: https://github.com/kkholst/mets/issues Depends: R (>= 3.5.0), timereg (>= 1.9.4), lava (>= 1.6.6) Imports: mvtnorm, numDeriv, compiler, Rcpp, splines, survival (>= 2.43-1), Suggests: prodlim, testthat (>= 0.11), ucminf, R.rsp (>= 0.40) VignetteBuilder: R.rsp ByteCompile: yes LinkingTo: Rcpp, RcppArmadillo, mvtnorm SystemRequirements: C++11 Encoding: UTF-8 RoxygenNote: 6.1.1 NeedsCompilation: yes Packaged: 2020-02-18 22:23:39 UTC; klaus Repository: CRAN Date/Publication: 2020-02-19 06:10:03 UTC mets/build/0000755000176200001440000000000013623061747012332 5ustar liggesusersmets/build/vignette.rds0000644000176200001440000000105413623061747014671 0ustar liggesusersUo0m)[Ť0..Hܦ]`M=:il'Yo)vj7NJH;`QE?E964kl(DI,425a, ('k)X *RrSȐӋIWY"j@9@۸>п^רAcIL/%M )MJ1-^䵮Ұ*deFa=خk!8)Y8H*H]Nk<\* fnAST| 6Gr$BVቂ,gp>cY!]_MͻȷzK$ީa_h[DQu|M>v˃n[d~tILSWYqD|(5{Ԙ:QjQjƸ?J_%kl+z)Zͻ\'7,\҉'%8O?Ü>G= J2rpl 3S/'4r;Щ;3lg7y>H~npmets/tests/0000755000176200001440000000000013623061405012364 5ustar liggesusersmets/tests/test-all.R0000644000176200001440000000016113623061405014232 0ustar liggesusersif (require(testthat)) { library("mets") library("lava") library("timereg") test_check("mets") } mets/tests/testthat/0000755000176200001440000000000013623061405014224 5ustar liggesusersmets/tests/testthat/test_dutils.R0000644000176200001440000000366613623061405016725 0ustar liggesuserscontext("dutils") test_that("dsort", { data("hubble",package="lava") expect_equivalent(order(dsort(hubble, ~sigma)$sigma), seq_len(nrow(hubble))) }) test_that("dsort", { data("hubble",package="lava") h1 <- hubble drename(h1,fun=toupper) <- ~. expect_equivalent(colnames(h1),toupper(names(hubble))) }) test_that("daggregate", { dd <- data.frame(a=1:20,b=20:1, g1=rep(0:1,10), g2=rep(0:1,each=10), g3=rbinom(20,1,0.5)) dd$g1[1:2] <- NA dd$g2[2:3] <- NA dd$a[3:7] <- NA ##dcor(dd,.~g1+g2) dcor(dd, "[acg][12]*$", regex=TRUE, use="pairwise") dcor(dd, "[ab]",subset=is.na(g1), regex=TRUE, use="pairwise") dcor(dd, ~.|is.na(g1)|is.na(g2)) dcor(dd, use="pairwise") }) test_that("dby", { dd <- dby2(iris, . ~ Species, mean, median, REDUCE=T) val <- dreshape(dd,varying=list(mean="mean*",median="median*"),dropid=TRUE) val$num <- gsub("mean.","",val$num) val <- dreshape(dd,varying=c("mean","median"),dropid=TRUE) val$num <- gsub("^.","",val$num) expect_true(ncol(val)==4) expect_true(nrow(val)==3*4) val0 <- subset(val, Species=="setosa" & num=="Sepal.Width") val1 <- subset(iris, Species=="setosa", select="Sepal.Width")[,1] expect_true(abs(val0[1,"mean"]-mean(val1))<1e-16) expect_true(abs(val0[1,"median"]-median(val1))<1e-16) }) test_that("dsample", { n <- 10 d <- data.frame(id=rep(0:1,5),x=seq(0,1,length.out=10),y=seq(1,0,length.out=10), id2=rep(1:5,each=2)) d1 <- dsample(d, ~id, size=3) expect_true(ncol(d1)==5) expect_true(nrow(d1)==15) d2 <- dsample(d, .~id|x>0.5, size=3) expect_true(ncol(d2)==4) expect_true(all(d2$x>0)) d3 <- dsample(d, .~id+id2, size=3) expect_true(ncol(d3)==3) d4 <- dsample(d, .~id+id2|x>0, size=3) expect_true(ncol(d4)==3) expect_true(all(d4$x>0)) }) mets/tests/testthat/test_reshape.R0000644000176200001440000000407713623061405017045 0ustar liggesuserscontext("Reshaping data") test_that("fast reshape I", { m <- lvm() regression(m,c(y1,y2,y3)~x) <- c(1,10,100) distribution(m,~x) <- f <- function(n,...) rbinom(n,1,0.5)+1 d <- sim(m,10); dd <- fast.reshape(d,var="y") d1 <- fast.reshape(dd,id="id") expect_true(sum((d[,endogenous(m)]-d1[,endogenous(m)])^2)<1e-20) d2 <- fast.reshape(dd,id="id",var="y",num="num") expect_true(sum((d-d2[,colnames(d)])^2)<1e-20) }) test_that("fast reshape II", { testdata <- data.frame(hour=c(12,13,14,11,12,14,15,16),id=c(1,1,1,2,2,3,3,3),y=round(rnorm(8),2)) widetest <- reshape(testdata,v.names="y",idvar="id",direction="wide",timevar="hour") wide <- fast.reshape(testdata,varying="y",id="id",num="hour",sep=".") expect_equivalent(widetest,wide[,colnames(widetest)]) }) test_that("fast rehape: different data types", { d <- data.frame(time1=c(1:5), time2=c(6.070311, 2.026996, 7.584480, 8.630120, 8.193392)) dd <- mets::fast.reshape(d) expect_equivalent(dd[,1],as.vector(t(d))) d <- data.frame(time1=c(TRUE,FALSE,TRUE,FALSE,TRUE), time2=c(6.070311, 2.026996, 7.584480, 8.630120, 8.193392)) dd <- mets::fast.reshape(d) expect_equivalent(dd[,1],as.vector(t(d))) }) ## fast.reshape(fast.reshape(d,var=c("y","z","w")),id="id",var=c("y","z","w")) ## library(mets) ## x <- matrix(1:10,5,2) ## x[3,2] <- 8 ## x[3,2] <- NA ## cluster <- c(1,1,2,2,3) ## x <- cbind(x,cluster) ## x ## ud <- fast.reshape(data.frame(x),"cluster") ## ud ## ### ## out=cluster.index(cluster) ## out ## ### ## ud <- faster.reshape(x,cluster) ## ud ## ud <- faster.reshape(data.frame(x),cluster) ## ud ## ### ## colnames(x) <- c("y1","y2","cluster") ## x ## ud <- fast.reshape(data.frame(x),"cluster") ## ud ## ### ## num <- c(2,1,1,2,2) ## x ## out <- faster.reshape(x,cluster) ## out ## out <- faster.reshape(x,cluster,num=num) ## out mets/tests/testthat/test_claytonoakes.R0000644000176200001440000000027113623061405020102 0ustar liggesuserscontext("Clayton-Oakes") test_that("Clayton-Oakes I", { ## expect_equivalent(coef(e)[[1]][1:2,1],coef(lm(y~x,d))) ## expect_equivalent(coef(e)[[2]][1:2,1],coef(lm(y~x,d))) }) mets/tests/testthat/test_approx.R0000644000176200001440000000103013623061405016711 0ustar liggesuserscontext("Fast.approx") test_that("fast approx I", { set.seed(1) x <- sort(rnorm(1e5)) y <- rnorm(1e3) val <- x[fast.approx(x,y)] val2 <- sapply(y, function(y) x[which.min(abs(x-y))]) expect_identical(val,val2) ##rbenchmark::benchmark(fast.approx(x,y,type="left"),replications=1000) ##rbenchmark::benchmark(prodlim::sindex(x,y),replications=1000) val <- fast.approx(x,y,type="left") # Number of observations in x less than y val3 <- prodlim::sindex(x,y) expect_identical(val,val3) }) mets/src/0000755000176200001440000000000013623061753012017 5ustar liggesusersmets/src/claytonoakes.cpp0000644000176200001440000001301713623061405015213 0ustar liggesusers#include #include #include #include #include #include using namespace arma; using namespace Rcpp; typedef std::complex cx; RcppExport SEXP claytonoakes(SEXP ds, SEXP ts, SEXP es, SEXP allcs, SEXP cs, SEXP cuts, SEXP hs, SEXP mulths, SEXP var ) { BEGIN_RCPP // {{{ // try { colvec event = Rcpp::as(ds); colvec time = Rcpp::as(ts); colvec entry = Rcpp::as(es); colvec uniqueclusters = Rcpp::as(cs); colvec clusters = Rcpp::as(allcs); NumericVector cut = Rcpp::as(cuts); colvec basehaz = Rcpp::as(hs); colvec mhaz = Rcpp::as(mulths); colvec theta0 = Rcpp::as(var); unsigned ncluster = uniqueclusters.n_rows; unsigned n = time.n_rows; unsigned ncuts = cut.size(); colvec dt(ncuts-1); for (unsigned i=1; i0) Haz1 += L1(pos-1); if (e>0) { // Truncation it = std::lower_bound(cut.begin(), cut.end(), e); epos= int(it-cut.begin())-1; Haz0 += 1/(curtheta0)*exp(curtheta0*multhaz*L00(epos))* (exp(curtheta0*multhaz*(basehaz(epos)*(e-cut(epos))))-1); if (epos>0) Haz0 += L1(epos-1); } j++; if (j==n) break; } while (clusters(j)==curcluster); logLik += -(1/curtheta0+nevent)*log(1+curtheta0*Haz1); // Survival logLik += (1/curtheta0)*log(1+curtheta0*Haz0); // Truncation logLik += nevent*log(curtheta0); logLik += lgammaratio; } return(Rcpp::List::create(Rcpp::Named("logLik")=logLik)); END_RCPP } // }}} RcppExport SEXP claytonoakes_cx(SEXP ds, SEXP ts, SEXP es, SEXP allcs, SEXP cs, SEXP cuts, SEXP hs, SEXP mulths, SEXP var ) { BEGIN_RCPP // {{{ // try { colvec event = Rcpp::as(ds); colvec time = Rcpp::as(ts); colvec entry = Rcpp::as(es); colvec uniqueclusters = Rcpp::as(cs); colvec clusters = Rcpp::as(allcs); NumericVector cut = Rcpp::as(cuts); cx_colvec basehaz = Rcpp::as(hs); cx_colvec mhaz = Rcpp::as(mulths); cx_colvec theta0 = Rcpp::as(var); unsigned ncluster = uniqueclusters.n_rows; unsigned n = time.n_rows; unsigned ncuts = cut.size(); colvec dt(ncuts-1); for (unsigned i=1; i0) Haz1 += L1(pos-1.0); if (e>0) { // Truncation it = std::lower_bound(cut.begin(), cut.end(), e); epos= int(it-cut.begin())-1.0; Haz0 += 1.0/(curtheta0)*exp(curtheta0*multhaz*L00(epos))* (exp(curtheta0*multhaz*(basehaz(epos)*(e-cut(epos))))-1.0); if (epos>0) Haz0 += L1(epos-1.0); } j++; if (j==n) break; } while (clusters(j)==curcluster); logLik += -(1.0/curtheta0+(cx)nevent)*log(1.0+curtheta0*Haz1); // Survival logLik += (1.0/curtheta0)*log(1.0+curtheta0*Haz0); // Truncation logLik += (cx)nevent*log(curtheta0); logLik += lgammaratio; } return(Rcpp::List::create(Rcpp::Named("logLik")=logLik)); END_RCPP } // }}} mets/src/biprobit.cpp0000644000176200001440000002440613623061405014335 0ustar liggesusers#include "mvn.h" using namespace std; using namespace Rcpp; using namespace arma; // {{{ uniprobit RcppExport SEXP uniprobit(SEXP m, SEXP dm, SEXP s, SEXP ds, SEXP y, SEXP w, SEXP std, SEXP eqmarg) { BEGIN_RCPP NumericMatrix mm(m); NumericMatrix dss(ds); NumericMatrix dmm(dm); NumericMatrix yy(y); double S = Rcpp::as(s); mat mu(mm.begin(), mm.nrow(), mm.ncol(), false); mat dS(dss.begin(), dss.nrow(), dss.ncol(), false); mat tdmu(dmm.begin(), dmm.nrow(), dmm.ncol(), false); mat Y(yy.begin(), yy.nrow(), yy.ncol(), false); bool weights = Rcpp::as(std); unsigned n = mm.nrow(); NumericVector W; if (weights) { NumericVector W0(w); W=W0; } double sigma = sqrt(S); colvec alpha(n), alpha0(n), M(n); for (unsigned i=0; i0) { colvec V = S*alpha0+mu%M; mat U2 = 0.5*trans(dS)*trans(-alpha0+V/S)/S; U1 = join_cols(U1,U2); } mat logLik = log(alpha); for (unsigned i=0; i(std); bool OneWeight = Rcpp::as(sameweight); mat U; mat W; List res; if (weights) { NumericMatrix ww(w); mat W0(ww.begin(), ww.nrow(), ww.ncol(), false); W = W0; // WW = trans(reshape(W1,2,N/2)); } if (OneWeight & weights) { vecmat U0 = score(Y,mu,X,S,dS,U); res["loglik"] = log(U0.V)%W.col(0); for (unsigned i=0; i(std); bool OneWeight = Rcpp::as(eqweight); bool EqMarginal = Rcpp::as(eqmarg); bool Cor = Rcpp::as(correlation); vecmat U0; mat W,U; List res; if (weights) { NumericMatrix ww(w); mat W0(ww.begin(), ww.nrow(), ww.ncol(), false); W = W0; // WW = trans(reshape(W1,2,N/2)); } if (OneWeight & weights) { if (Cor) { U0 = scorecor(Y,mu,dmu,S,dS,U,EqMarginal); } else { U0 = score2(Y,mu,dmu,S,dS,U,EqMarginal); } res["loglik"] = log(U0.V)%W.col(0); for (unsigned i=0; i #include #include using namespace Rcpp; using namespace arma; /* how many are there of the different clusters, similar to table(clusters) */ RcppExport SEXP nclust(SEXP iclusters) { // {{{ BEGIN_RCPP IntegerVector clusters(iclusters); int n = clusters.size(); int uniqueclust=0; int maxclust=0; IntegerVector nclust(n,0); for (int i=0;imaxclust) maxclust=nclust[clusters[i]]; } return(List::create(Named("maxclust")=maxclust, Named("nclust")=nclust, Named("uniqueclust")=uniqueclust)); END_RCPP } // }}} /* organize indeces to different clusters in matrix of size nclust x maxclust */ /* If optionally matrix 'mat' is supplied, the rows of mat corresponding to clusters is returned */ RcppExport SEXP clusterindexM(SEXP iclusters, SEXP imednum, SEXP inum, SEXP x, SEXP all) { // {{{ BEGIN_RCPP IntegerVector clusters(iclusters); int n = clusters.size(); bool All = Rcpp::as(all); int uniqueclust=0; int maxclust=0; IntegerVector nclust(n,0); bool hasX = !((Rf_isNull)(x)); for (int i=0;imaxclust) maxclust=nclust[clusters[i]]; } IntegerVector num(inum); int mednum = Rcpp::as(imednum); Row unum; if (mednum==1) { // unum = unique(num); // maxclust = unum.n_elem; maxclust = max(num)+1; } Mat idclust = Mat(uniqueclust,maxclust); idclust.fill(NA_INTEGER); IntegerVector clustsize(uniqueclust,0); IntegerVector firstclustid(uniqueclust,0); if (mednum==0) { for (int i=0;i(x); //if (X.n_rows!=n) mat res(uniqueclust,X.n_cols); res.fill(0); for (unsigned i=0; i(iclustmat); int uniqueclust=clustmat.n_rows; int numfamindex= Rcpp::as(inumfamindex); IntegerVector famclustindex(numfamindex,0); IntegerVector subfamilyindex(numfamindex,0); int i,j,v=0,h=0; for (i=0;i=2) for (j=0;j<(clustsize(i)-1);j++) for (int k=j+1;kmaxclust) maxclust=nclust[clusters[i]]; } IntegerVector num(inum); int mednum = Rcpp::as(imednum); Mat idclust = Mat(uniqueclust,maxclust); idclust.fill(NA_INTEGER); IntegerVector clustsize(uniqueclust,0); mat data = Rcpp::as(idata); int p= data.n_cols; mat nydata(uniqueclust,maxclust*p); nydata.fill(NA_REAL); if (mednum==0) { for (int i=0;i #include #include #include // const double epsilon=1.0e-16; using namespace std; using namespace Rcpp; // [[Rcpp::export(name = ".ApplyBy2")]] NumericMatrix ApplyBy2(NumericMatrix idata, NumericVector icluster, SEXP F, Environment Env, std::string Argument="x", int Columnwise=0, int Reduce=0, double epsilon=1.0e-16 ) { BEGIN_RCPP unsigned n = idata.nrow(); unsigned posstart=0; unsigned p = idata.ncol(); if (Columnwise==0) { Env[Argument] = idata( Range(0,0), Range(0, idata.ncol()-1) ); } else { Env[Argument] = 1; } NumericVector res1(Rf_eval(F,Env)); unsigned nf = res1.size(); unsigned P=nf; if (Columnwise!=0) { P *= idata.ncol(); } // First we get the number of clusters double curcluster=icluster[0]; double prevcluster=icluster[0]; unsigned nclusters=1; for (unsigned i=0; iepsilon) { nclusters++; } prevcluster=curcluster; } unsigned clpos=0; NumericVector clustersize(nclusters); curcluster=icluster[0]; prevcluster=icluster[0]; NumericMatrix res(n,P); for (unsigned i=0; i<=n; i++) { if (iepsilon || i==n) { if (i=(nr*nf)); } else { // Apply function on each column val = NumericVector(nr*P); valsize = 1; for (unsigned k=0; k DH and Y > DK. * Note: Prob( X < DH, Y < DK ) = BVND( -DH, -DK, R ). * * Parameters * * DH DOUBLE PRECISION, integration limit * DK DOUBLE PRECISION, integration limit * R DOUBLE PRECISION, correlation coefficient * DOUBLE PRECISION DH, DK, R, TWOPI INTEGER I, IS, LG, NG PARAMETER ( TWOPI = 6.283185307179586D0 ) DOUBLE PRECISION X(10,3), W(10,3), AS, A, B, C, D, RS, XS, BVN DOUBLE PRECISION PHID, SN, ASR, H, K, BS, HS, HK * Gauss Legendre Points and Weights, N = 6 DATA ( W(I,1), X(I,1), I = 1,3) / & 0.1713244923791705D+00,-0.9324695142031522D+00, & 0.3607615730481384D+00,-0.6612093864662647D+00, & 0.4679139345726904D+00,-0.2386191860831970D+00/ * Gauss Legendre Points and Weights, N = 12 DATA ( W(I,2), X(I,2), I = 1,6) / & 0.4717533638651177D-01,-0.9815606342467191D+00, & 0.1069393259953183D+00,-0.9041172563704750D+00, & 0.1600783285433464D+00,-0.7699026741943050D+00, & 0.2031674267230659D+00,-0.5873179542866171D+00, & 0.2334925365383547D+00,-0.3678314989981802D+00, & 0.2491470458134029D+00,-0.1252334085114692D+00/ * Gauss Legendre Points and Weights, N = 20 DATA ( W(I,3), X(I,3), I = 1, 10 ) / & 0.1761400713915212D-01,-0.9931285991850949D+00, & 0.4060142980038694D-01,-0.9639719272779138D+00, & 0.6267204833410906D-01,-0.9122344282513259D+00, & 0.8327674157670475D-01,-0.8391169718222188D+00, & 0.1019301198172404D+00,-0.7463319064601508D+00, & 0.1181945319615184D+00,-0.6360536807265150D+00, & 0.1316886384491766D+00,-0.5108670019508271D+00, & 0.1420961093183821D+00,-0.3737060887154196D+00, & 0.1491729864726037D+00,-0.2277858511416451D+00, & 0.1527533871307259D+00,-0.7652652113349733D-01/ SAVE X, W IF ( ABS(R) .LT. 0.3 ) THEN NG = 1 LG = 3 ELSE IF ( ABS(R) .LT. 0.75 ) THEN NG = 2 LG = 6 ELSE NG = 3 LG = 10 ENDIF H = DH K = DK HK = H*K BVN = 0 IF ( ABS(R) .LT. 0.925 ) THEN IF ( ABS(R) .GT. 0 ) THEN HS = ( H*H + K*K )/2 ASR = ASIN(R) DO I = 1, LG DO IS = -1, 1, 2 SN = SIN( ASR*( IS*X(I,NG) + 1 )/2 ) BVN = BVN + W(I,NG)*EXP( ( SN*HK-HS )/( 1-SN*SN ) ) END DO END DO BVN = BVN*ASR/( 2*TWOPI ) ENDIF BVN = BVN + PHID(-H)*PHID(-K) ELSE IF ( R .LT. 0 ) THEN K = -K HK = -HK ENDIF IF ( ABS(R) .LT. 1 ) THEN AS = ( 1 - R )*( 1 + R ) A = SQRT(AS) BS = ( H - K )**2 C = ( 4 - HK )/8 D = ( 12 - HK )/16 ASR = -( BS/AS + HK )/2 IF ( ASR .GT. -100 ) BVN = A*EXP(ASR) & *( 1 - C*( BS - AS )*( 1 - D*BS/5 )/3 + C*D*AS*AS/5 ) IF ( -HK .LT. 100 ) THEN B = SQRT(BS) BVN = BVN - EXP( -HK/2 )*SQRT(TWOPI)*PHID(-B/A)*B & *( 1 - C*BS*( 1 - D*BS/5 )/3 ) ENDIF A = A/2 DO I = 1, LG DO IS = -1, 1, 2 XS = ( A*( IS*X(I,NG) + 1 ) )**2 RS = SQRT( 1 - XS ) ASR = -( BS/XS + HK )/2 IF ( ASR .GT. -100 ) THEN BVN = BVN + A*W(I,NG)*EXP( ASR ) & *( EXP( -HK*( 1 - RS )/( 2*( 1 + RS ) ) )/RS & - ( 1 + C*XS*( 1 + D*XS ) ) ) END IF END DO END DO BVN = -BVN/TWOPI ENDIF IF ( R .GT. 0 ) THEN BVN = BVN + PHID( -MAX( H, K ) ) ELSE BVN = -BVN IF ( K .GT. H ) BVN = BVN + PHID(K) - PHID(H) ENDIF ENDIF BVND = BVN END mets/src/prop-odd.cpp0000644000176200001440000001061513623061405014244 0ustar liggesusers#include #include #include using namespace arma; RcppExport SEXP pBhat(SEXP ds, SEXP Xs, SEXP beta, SEXP id, SEXP ididx, SEXP idsize) { try { uvec event = Rcpp::as(ds); mat X = Rcpp::as(Xs); mat Xc = zeros(X.n_cols,X.n_cols); vec betahat = Rcpp::as(beta); unsigned stop,start = X.n_rows; uvec eventpos = find(event==1); mat dB = zeros(eventpos.n_elem,X.n_cols); uvec cluster = Rcpp::as(id); double thetahat=1; uvec clustersize, clustpos; umat clusterindex; bool doclust = (Rf_isNull)(idsize); if (!doclust) { clustersize = Rcpp::as(idsize); clusterindex = Rcpp::as(ididx); } // Obtain usual estimates of increments, dB, of the // cumulative time-varying effects in Aalens Additive Model for (unsigned ij=0; ij::from(clusterindex.submat(i,0,i,csize-1)); } uvec posL = find(clustpos=ij); // later/current events within cluster unsigned Ni = 0; // Number of events in cluster before current event,time t- double Hi = 0 ; // Sum of cum.haz. within cluster up to time t- if (posL.n_elem>0) { Ni = sum(event.elem(clustpos.elem(posL))); Hi = sum(Hij.elem(clustpos.elem(posL))); } uvec pos; if (posR.n_elem>0 && k>0) { pos = clustpos.elem(posR); mat Xi = X.rows(pos); Hij.elem(pos) = Xi*trans(B2.row(k-1)); Hi += sum(Hij.elem(pos)); } double psi = (1/thetahat+Ni)/(1/thetahat+fmax(0,Hi)); B2.row(k) = dB.row(k)/psi; if (k>0) { B2.row(k) += B2.row(k-1); } } return(Rcpp::List::create(Rcpp::Named("dB")=dB, Rcpp::Named("B2")=B2 )); } catch( std::exception &ex ) { forward_exception_to_r( ex ); } catch(...) { ::Rf_error( "c++ exception (unknown reason)" ); } return R_NilValue; // -Wall } RcppExport SEXP UhatPropOdd(SEXP ds, SEXP H, SEXP theta, SEXP id, SEXP idsize) { try { uvec event = Rcpp::as(ds); vec Hij = Rcpp::as(H); double thetahat = Rcpp::as(theta); umat cluster = Rcpp::as(id); uvec clustersize, ucluster, clustpos; unsigned nclust; bool doclust = (Rf_isNull)(idsize); //bool doclust = (cluster.n_cols==1); if (doclust) { ucluster = unique(cluster); nclust = ucluster.n_elem; } else { clustersize = Rcpp::as(idsize); nclust = cluster.n_rows; } vec res(nclust); for (unsigned i=0; i::from(cluster.submat(i,0,i,csize-1)); //cluster(span(i,i),span(0,csize-1)); } double Ni = sum(event.elem(clustpos)); double Hi = sum(Hij.elem(clustpos)); double thetaH = thetahat*Hi+1; double R = (log(thetaH)/thetahat + (Ni-Hi)/(thetaH)); for (unsigned h=0; h #include /* required by R */ #include #include int _mvt_maxpts=25000; double _mvt_abseps=0.001; double _mvt_releps=0; int _mvt_df = 0; int _mvt_inform; double _mvt_error[3]; double mvtdst(int* n, int* nu, // Degrees of freedom (0=MVN) double* lower, // Lower integration bounds double* upper, // Upper integration bounds int* infin, // Infinity argument, ith element 0: ]-inf,up[i]], 1: [lo[i],inf[, 2: [lo[i],up[i]], 3: ]-inf,inf[ double* correl, // Correlation coefficients (upper-tri) double* delta, // non-central parameter int* maxpts, // Max function evalutions (quasi-mc) double* abseps, // Tolerance absolute error double* releps, // Tolerance relative error double* error, // estimated abs. error. with 99% confidence interval double* value, // result int* inform) // Message (0 success) { // *value = 1; // return(*value); if (*n==1 && *nu==0) { // 0: right, 1: left, 2: interval switch (*infin) { case 0: *value = Rf_pnorm5(*upper,0.0,1.0,1,0); break; case 1: *value = 1-Rf_pnorm5(*lower,0.0,1.0,1,0); break; case 2: *value = Rf_pnorm5(*upper,0.0,1.0,1,0)-Rf_pnorm5(*lower,0.0,1,1,0); break; // default: *value = 0; } //cerr << "infin=" << *infin << " value=" << *value << " upper=" << *upper << " lower=" << *lower << endl; return(*value); } // cerr << "fortran to be called...\n"; // mvtdst_(n, nu, // lower, upper, infin, correl, delta, // maxpts, abseps, releps, // error, value, inform); int rnd=1; /* mvtnorm_C_mvtdst is defined in mvtnorm/inst/include/mvtnormAPI.h */ mvtnorm_C_mvtdst(n, nu, lower, upper, infin, correl, delta, maxpts, abseps, releps, error, value, inform, &rnd); switch (*inform) { case 0: return *value; case 1: case 2: case 3: return -1.0; }; return *value; } double dmvn(const vec &y, const mat &W, bool log=true, double logdet=datum::inf) { int n = W.n_rows; double res = -0.5*n*log2pi; if (logdet!=datum::inf) { res += -0.5*(logdet + as_scalar(trans(y)*W*y)); } else { double sign=0; mat iW = inv(W); log_det(logdet,sign,W); res += -0.5*(logdet + as_scalar(trans(y)*iW*y)); } if (!log) res = exp(res); return(res); } double cdfmvn(mat &upper, mat &cor) { double val=0; int n = cor.n_cols; rowvec _mvt_delta(n); _mvt_delta.fill(0); unsigned ncor = n*(n-1)/2; rowvec Cor(ncor); int j = 0; for (int r=0; r infin(n); infin.fill(0); // mvtdst(&n, &_mvt_df, &upper[0], // Lower, ignored &upper[0], &infin[0], // Infinity argument (all 0 since CDF) &Cor[0], &_mvt_delta[0], &_mvt_maxpts, &_mvt_abseps, &_mvt_releps, &_mvt_error[0], &val, &_mvt_inform); return(val); } RcppExport SEXP Dpmvn (SEXP lower, SEXP upper, SEXP mu, SEXP sigma, SEXP std) { BEGIN_RCPP colvec y = Rcpp::as(upper); NumericVector Lower(lower); bool Std = Rcpp::as(std); mat S = Rcpp::as(sigma); colvec Mu = Rcpp::as(mu); int n = S.n_cols; vec L(n); for (int j=0; j1); // uvec NonObs = find(Status>0); // int nObs = Obs.size(); // int nNonObs = NonObs.size(); // int nOrd = Ord.size(); // int nu = Su.n_cols; // bool nonconstvar = (nu>0); // double sign, logdetS0; // mat Se,S0,iS0; // vec loglik(n); loglik.fill(0); // // return(loglik); // if (nObs>0) { // mat Y0 = Yl.cols(Obs)-Mu.cols(Obs); // Se = S0 = S.submat(Obs,Obs); // iS0 = inv(S0); // log_det(logdetS0,sign,S0); // double normconst = -0.5*nObs*log2pi; // for (int i=0; i1); uvec NonObs = find(Status>0); int nObs = Obs.size(); int nNonObs = NonObs.size(); int nOrd = Ord.size(); int nu = Su.n_cols; bool nonconstvar = (nu>0); double sign, logdetS0; mat Se,S0,iS0; vec loglik(n); loglik.fill(0); // return(loglik); if (nObs>0) { mat Y0 = Yl.cols(Obs)-Mu.cols(Obs); Se = S0 = S.submat(Obs,Obs); iS0 = inv(S0); log_det(logdetS0,sign,S0); double normconst = -0.5*nObs*log2pi; for (int i=0; i0) { rowvec _mvt_delta(nNonObs); _mvt_delta.fill(0); mat MuNonObs = Mu.cols(NonObs); mat SNonObs = S.submat(NonObs,NonObs); if ((nObs>0) & (!nonconstvar)) { // Calculate conditional on observed mat S01 = S.submat(NonObs,Obs); mat iS1 = inv(S.submat(Obs,Obs)); MuNonObs = MuNonObs + trans(S01*iS1*trans(Yl.cols(Obs)-Mu.cols(Obs))); // MuNonObs.each_row() += Mu.(NonObs); SNonObs = SNonObs - S01*iS1*trans(S01); } vec il = 1/sqrt(diagvec(SNonObs)); mat iL = diagmat(il); Se = S0 = iL*SNonObs*iL; // Correlation matrix int ncor = nNonObs*(nNonObs-1)/2; rowvec Cor(ncor); if (ncor>0) { int j = 0; for (int r=0; r0) { OrdNonObs = find(Status.elem(NonObs)>1); Thres = Threshold.rows(Ord); } rowvec lower(nNonObs); rowvec upper(nNonObs); Row infin(nNonObs); // 0: right, 1: left, 2: interval uvec currow(1); for (int i=0; i0) { S0 = SS.submat(NonObs,NonObs); mat S01 = SS.submat(NonObs,Obs); mat iS1 = inv(SS.submat(Obs,Obs)); Mi = Mi + trans(S01*iS1*trans(Yl.submat(currow,Obs)-Mu.submat(currow,Obs))); SNonObs = S0 - S01*iS1*trans(S01); } else { SNonObs = SS; } il = 1/sqrt(diagvec(SNonObs)); iL = diagmat(il); Se = S0 = iL*SNonObs*iL; // Correlation matrix if (ncor>0) { int j = 0; for (int r=0; r0) { infin.elem(infplus) -= 1; } // if (infminus.size()>0) { infin.elem(infminus) -= 2; } if (nOrd>0) { for (int j=0; j1 if (yval>=nthresmax) { // Y=k (last) double val = Thres(j,yval-1); infin(jj) = 1; // Integrate over right tail lower(jj) = val; } else { double val = Thres(j,yval-1); double val2 = Thres(j,yval); if (val>=val2) { // Also Y=k (last) infin(jj) = 1; lower(jj) = val; } else { //Y=k-i (in between) lower(jj) = val; upper(jj) = val2; } } } } } lower = (lower-Mi)%trans(il); upper = (upper-Mi)%trans(il); double val; val = mvtdst(&nNonObs, &_mvt_df, &lower[0], &upper[0], &infin[0], &Cor[0], &_mvt_delta[0], &_mvt_maxpts, &_mvt_abseps, &_mvt_releps, &_mvt_error[0], &val, &_mvt_inform); // if (isnan(val)) { // cerr << "***i=" << i << endl; // cerr << "Threshold=" << Threshold << endl; // cerr << "Thres=" << Thres << endl; // cerr << "status=" << Status; // cerr << "yl=" << Yl.row(i); // cerr << "yu=" << Yu.row(i); // cerr << "lower=" << lower; // cerr << "upper=" << upper; // cerr << "infin=" << infin; // cerr << "Cor=\n" << Cor; // cerr << " val=" << val << endl; // // } // cerr << " 1:loglik(i)=" << loglik(i) << endl; loglik(i) += log(val); // cerr << " 2:loglik(i)=" << loglik(i) << endl; // } } } return(loglik); } // RcppExport SEXP loglikMVN(SEXP yl, SEXP yu, // SEXP status, // SEXP mu, SEXP dmu, // SEXP s, SEXP ds, // SEXP z, SEXP su, SEXP dsu, // SEXP threshold, SEXP dthreshold, SEXP score) { // [[Rcpp::export(name = ".loglikMVN")]] arma::mat loglikMVN(arma::mat Yl, SEXP yu, SEXP status, arma::mat Mu, SEXP dmu, arma::mat S, SEXP ds, SEXP z, SEXP su, SEXP dsu, SEXP threshold, SEXP dthreshold, bool Score) { // mat Yl = Rcpp::as(yl); // mat Mu = Rcpp::as(mu); // mat S = Rcpp::as(s); // bool Score = Rcpp::as(score); if (Score) { mat dS = Rcpp::as(ds); mat dMu = Rcpp::as(dmu); mat U = scoremvn(Yl, Mu, dMu, S, dS); // Z, Su, dSu, // Threshold, dThreshold) { return(U); } uvec Status = Rcpp::as(status); mat Yu = Rcpp::as(yu); if ((Mu.n_cols!=Yl.n_cols) || (Mu.n_rows!=Yl.n_rows)) throw(Rcpp::exception("Dimension of 'mu' and 'yl' did not agree","mvn.cpp",1)); if (Status.size()!=Yl.n_cols) throw(Rcpp::exception("Dimension of 'status' and 'yl' did not agree","mvn.cpp",1)); uvec Cens = find(Status==1); uvec Obs = find(Status==0); uvec NonObs = find(Status>0); uvec Ord = find(Status>1); // int nObs = Obs.size(); // int nNonObs = NonObs.size(); int nOrd = Ord.size(); int nCens = Cens.size(); unsigned n = Yl.n_rows; mat Z,Zsub; mat Su; if (!Rf_isNull(z)) { Z = Rcpp::as(z); Su = Rcpp::as(su); if (Z.n_cols!=(Yl.n_cols/Su.n_cols)) throw(Rcpp::exception("Dimension of 'z' and 'su' did not agree","mvn.cpp",1)); if (Z.n_rows!=n) throw(Rcpp::exception("Dimension of 'z' and 'yl' did not agree","mvn.cpp",1)); } mat Threshold; if (nOrd>0) { Threshold = Rcpp::as(threshold); if (Threshold.n_rows!=Yl.n_cols) throw(Rcpp::exception("Dimension of 'threshold' and 'yl' did not agree","mvn.cpp",1)); } vec loglik(n); loglik.fill(0); if (nCens>0) { if ((Yl.n_cols!=Yu.n_cols) || (Yl.n_rows!=Yu.n_rows)) throw(Rcpp::exception("Dimension of 'yl' and 'yu' did not agree","mvn.cpp",1)); umat stat = (Yl.cols(Cens)==Yu.cols(Cens)); uvec group(n); umat pattern; fastpattern(stat,pattern,group); uvec NewStatus = Status; unsigned K = pattern.n_rows; for (unsigned i=0; i(sigma); bool asCor = Rcpp::as(cor); mat Mu = Rcpp::as(mu); mat Lower = Rcpp::as(lower); mat Upper = Rcpp::as(upper); unsigned n = Mu.n_rows; int p = Mu.n_cols; unsigned ncor = p*(p-1)/2; bool nSigma = false; if ((asCor && Sigma.n_rows>1) || (!asCor && Sigma.n_cols==unsigned(p*p) && Sigma.n_rows>1)) { nSigma = true; n = Sigma.n_rows; } rowvec _mvt_delta(p); _mvt_delta.fill(0); // Non-centrality par. rowvec Cor(ncor); // Vector of correlation coefficients (upper-tri, colwise) rowvec L(p); // Std.deviations //bool nSigma = Sigma.n_rows==n && Sigma.n_cols!=(unsigned)p; if (!nSigma) { if (!asCor) { cov2cor0(Sigma,Cor,L,true); } else { Cor = Sigma.row(0); } } Row infin(p); infin.fill(2); // for (unsigned j=0; j<(unsigned)p; j++) { if (Upper(0,j)==datum::inf) infin(j) = 1; if (Lower(0,j)==-datum::inf) infin(j) = 0; } rowvec Lower0(p); rowvec Upper0(p); rowvec Mu0 = Mu.row(0); vec res(n); for (unsigned i=0; i1) Mu0 = Mu.row(i); if (Lower.n_rows==n) { Lower0 = Lower.row(i)-Mu0; Upper0 = Upper.row(i)-Mu0; infin.fill(2); // (a,b) for (unsigned j=0; j<(unsigned)p; j++) { if (Upper0(0,j)==datum::inf) infin(j) = 1; // (a,Inf) if (Lower0(0,j)==-datum::inf) { if (infin(j)==1) infin(j) = -1; // (-Inf,Inf) else infin(j) = 0; // (-Inf,b) } } } else { Lower0 = Lower.row(0)-Mu0; Upper0 = Upper.row(0)-Mu0; } // We use that Phi(a,b,S,mu) = Phi(L(a-mu),L(b-mu),R,0); R=LSL if (nSigma) { if (asCor) { Cor = Sigma.row(i); } else { // p*p row mat Sigma0 = Sigma.row(i); Sigma0.reshape(p,p); cov2cor0(Sigma0,Cor,L,true); } } if (!asCor) { Lower0 = Lower0%L; Upper0 = Upper0%L; } // std::cerr << "Lower" << Lower0; // std::cerr << "Upper" << Upper0; // std::cerr << "Infin" << infin; // std::cerr << "Cor" << Cor; // std::cerr << "mvtdelta" << _mvt_delta; // std::cerr << "mvt_df" << _mvt_df; mvtdst(&p, &_mvt_df, &Lower0[0], &Upper0[0], &infin[0], &Cor[0], &_mvt_delta[0], &_mvt_maxpts, &_mvt_abseps, &_mvt_releps, &_mvt_error[0], &val, &_mvt_inform); res(i) = val; } return(Rcpp::wrap(res)); END_RCPP } ////////////////////////////////////////////////// // Bivariate case ////////////////////////////////////////////////// RcppExport SEXP bvncdf(SEXP a, SEXP b, SEXP r) { // double u[2]; // u[0] = Rcpp::as(a); // u[1] = Rcpp::as(b); // double cr = Rcpp::as(r); // double val; // int n = 2; // int inttype[2]; // inttype[0] = 0; // inttype[1] = 0; // double _mvt_delta[2]; // Non-centrality parameter // void C_bvtlr (int *NU, double *DH, double *DK, double *R, double *BVTL); // _mvt_delta[0] = 0; // _mvt_delta[1] = 0; // val = mvtdst(&n, &_mvt_df, // &u[0], &u[0], // &inttype[0], &cr, // &_mvt_delta[0], &_mvt_maxpts, // &_mvt_abseps, &_mvt_releps, // &_mvt_error[0], &val, &_mvt_inform); double u1 = -Rcpp::as(a); double u2 = -Rcpp::as(b); double rho = Rcpp::as(r); double val = bvnd_(&u1, &u2, &rho); NumericVector res(1); res[0] = val; return(res); } double dbvnorm(double y1, double y2, double R) { double detR = 1-R*R; // inv(R) = [1 -r; -r 1]/detR (prove by gauss elim.) double res = 1/(2*M_PI*sqrt(detR))*exp(-0.5/detR*(y1*y1+y2*y2-2*R*y1*y2)); return(res); } vecmat Dbvn(double y1, double y2, double R) { vec DP(2); double R2 = R*R; DP(0) = Rf_dnorm4(y1,0.0,1.0,0)*Rf_pnorm5(y2-R*y1,0.0,sqrt(1-R2),1,0); DP(1) = Rf_dnorm4(y2,0.0,1.0,0)*Rf_pnorm5(y1-R*y2,0.0,sqrt(1-R2),1,0); mat HP(2,2); HP(1,0) = HP(0,1) = dbvnorm(y1,y2,R); HP(0,0) = -y1*DP(0) - R*HP(1,0); HP(1,1) = -y2*DP(1) - R*HP(1,0); vecmat res; res.V = DP; res.M= HP; return(res); } double Sbvn(double &l1, double &l2, double &r) { // int n = 2; // double l[] = {l1, l2}; // int inttype[] = {1, 1}; // double _mvt_delta[] {0.0, 0.0}; // Non-centrality parameter // double val; // val = mvtdst(&n, &_mvt_df, // &l[0], &l[0], // &inttype[0], &r, // &_mvt_delta[0], &_mvt_maxpts, // &_mvt_abseps, &_mvt_releps, // &_mvt_error[0], &val, &_mvt_inform); double val = bvnd_(&l1, &l2, &r); return(val); } ////////////////////////////////////////////////// // Density with varying correlation structure ////////////////////////////////////////////////// // [[Rcpp::export(name = ".dmvn")]] NumericVector dmvn(arma::mat u, arma::mat mu, arma::mat rho) { unsigned n = u.n_rows; unsigned p = u.n_cols; NumericVector res(n); arma::mat R = arma::eye(p,p); double logdetR = 0; arma::mat invR = R; arma::rowvec mu_i(p); for (unsigned i=0; i #include #include // for NULL #include /* .Call calls */ extern SEXP Bhat(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP BhatAddGam(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP BhatAddGamCC(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP biprobit0(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP biprobit2(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP bvncdf(SEXP, SEXP, SEXP); extern SEXP claytonoakes(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP claytonoakesbinRV(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP claytonoakesR(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP clusterindexdata(SEXP, SEXP, SEXP, SEXP); extern SEXP clusterindexM(SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP cor(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP familypairindex(SEXP, SEXP, SEXP); extern SEXP FastApprox(SEXP, SEXP, SEXP, SEXP); extern SEXP FastCluster(SEXP); extern SEXP FastCoxPL(SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP FastCoxPLstrata(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP,SEXP,SEXP,SEXP,SEXP); extern SEXP FastCoxPLstrataPO(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP,SEXP,SEXP,SEXP,SEXP); extern SEXP FastCoxPLstrataAddGam(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP,SEXP,SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP ); extern SEXP FastCoxPrep(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP FastCoxPrepStrata(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP,SEXP,SEXP,SEXP,SEXP,SEXP); extern SEXP FastLong2(SEXP, SEXP, SEXP, SEXP); extern SEXP FastPattern(SEXP, SEXP, SEXP); extern SEXP MatxCube(SEXP, SEXP, SEXP); extern SEXP _mets_ApplyBy(SEXP, SEXP, SEXP); extern SEXP _mets_ApplyBy2(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP _mets_loglikMVN(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP _mets_RcppExport_registerCCallable(); extern SEXP pBhat(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP pmvn0(SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP Dpmvn(SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP survivalRV(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP RsurvivalRVCmarg(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP survivalRV2(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP survivalloglikeRVpairs(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP twostageloglikebin(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP twostageloglikebinpairs(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP twostageloglikeRV(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP twostageloglikeRVpairs(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP Uhat(SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP uniprobit(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP CubeVec(SEXP, SEXP); extern SEXP vecMatMat(SEXP, SEXP); extern SEXP OutCov(SEXP, SEXP); extern SEXP MatxCube(SEXP, SEXP, SEXP); extern SEXP Matdoubleindex(SEXP, SEXP, SEXP,SEXP,SEXP,SEXP); extern SEXP CubeMat(SEXP, SEXP); extern SEXP PropTestCox(SEXP, SEXP,SEXP,SEXP); extern SEXP PropTestCoxClust(SEXP, SEXP, SEXP, SEXP,SEXP,SEXP, SEXP, SEXP, SEXP, SEXP,SEXP,SEXP, SEXP); extern SEXP ModelMatrixTestCox(SEXP,SEXP,SEXP,SEXP,SEXP); //extern SEXP simBandCumHazCox(SEXP,SEXP,SEXP,SEXP,SEXP,SEXP); extern SEXP revcumsumR(SEXP); extern SEXP revcumsumstrataR(SEXP,SEXP, SEXP); extern SEXP tailstrataR(SEXP,SEXP, SEXP); extern SEXP revcumsumstratasumR(SEXP,SEXP, SEXP); extern SEXP revcumsumidstratasumR(SEXP,SEXP, SEXP,SEXP, SEXP); extern SEXP revcumsumidstratasumCovR(SEXP,SEXP,SEXP, SEXP,SEXP, SEXP); extern SEXP cumsumstrataR(SEXP,SEXP, SEXP); extern SEXP cumsumstrataPOR(SEXP,SEXP,SEXP,SEXP,SEXP,SEXP); extern SEXP DLambetaR(SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP); extern SEXP riskstrataR(SEXP,SEXP,SEXP); extern SEXP meanriskR(SEXP,SEXP,SEXP,SEXP,SEXP); extern SEXP wherestrataR(SEXP,SEXP,SEXP,SEXP); extern SEXP maxminidR(SEXP,SEXP,SEXP); extern SEXP cumsumstratasumR(SEXP,SEXP, SEXP); extern SEXP cumsumidstratasumR(SEXP,SEXP, SEXP,SEXP, SEXP); extern SEXP cumsumASR(SEXP,SEXP, SEXP); extern SEXP cumsumidstratasumCovR(SEXP, SEXP,SEXP, SEXP,SEXP, SEXP); extern SEXP covrfR( SEXP,SEXP,SEXP, SEXP); extern SEXP covrfstrataR( SEXP,SEXP,SEXP,SEXP,SEXP, SEXP); extern SEXP covrfstrataCovR(SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP, SEXP); extern SEXP sumstrataR(SEXP,SEXP, SEXP); extern SEXP XBmindex(SEXP,SEXP, SEXP); //extern SEXP backfitEaEt(SEXP,SEXP, SEXP,SEXP,SEXP, SEXP, SEXP, SEXP,SEXP); static const R_CallMethodDef CallEntries[] = { {"Bhat", (DL_FUNC) &Bhat, 6}, {"BhatAddGam", (DL_FUNC) &BhatAddGam, 14}, {"BhatAddGamCC", (DL_FUNC) &BhatAddGamCC, 17}, // {"backfitEaEt", (DL_FUNC) &backfitEaEtt, 9}, {"biprobit0", (DL_FUNC) &biprobit0, 8}, {"biprobit2", (DL_FUNC) &biprobit2, 10}, {"bvncdf", (DL_FUNC) &bvncdf, 3}, {"claytonoakes", (DL_FUNC) &claytonoakes, 9}, {"claytonoakesbinRV", (DL_FUNC) &claytonoakesbinRV, 10}, {"claytonoakesR", (DL_FUNC) &claytonoakesR, 6}, {"clusterindexdata", (DL_FUNC) &clusterindexdata, 4}, {"clusterindexM", (DL_FUNC) &clusterindexM, 5}, {"cor", (DL_FUNC) &cor, 40}, {"CubeVec", (DL_FUNC) &CubeVec, 2}, {"CubeMat", (DL_FUNC) &CubeMat, 2}, {"familypairindex", (DL_FUNC) &familypairindex, 3}, {"FastApprox", (DL_FUNC) &FastApprox, 4}, {"FastCluster", (DL_FUNC) &FastCluster, 1}, {"FastCoxPL", (DL_FUNC) &FastCoxPL, 5}, {"FastCoxPLstrata", (DL_FUNC) &FastCoxPLstrata, 11}, {"FastCoxPLstrataPO", (DL_FUNC) &FastCoxPLstrataPO, 11}, {"FastCoxPLstrataAddGam", (DL_FUNC) &FastCoxPLstrataAddGam, 18}, {"FastCoxPrep", (DL_FUNC) &FastCoxPrep, 6}, {"FastCoxPrepStrata", (DL_FUNC) &FastCoxPrepStrata, 11}, {"FastLong2", (DL_FUNC) &FastLong2, 4}, {"FastPattern", (DL_FUNC) &FastPattern, 3}, {"MatxCube", (DL_FUNC) &MatxCube, 3}, {"meanriskR", (DL_FUNC) &meanriskR, 5}, {"wherestrataR", (DL_FUNC) &wherestrataR, 4}, {"maxminidR", (DL_FUNC) &maxminidR, 3}, {"Matdoubleindex", (DL_FUNC) &Matdoubleindex, 6}, {"_mets_ApplyBy", (DL_FUNC) &_mets_ApplyBy, 3}, {"_mets_ApplyBy2", (DL_FUNC) &_mets_ApplyBy2, 8}, {"_mets_loglikMVN", (DL_FUNC) &_mets_loglikMVN, 13}, {"_mets_RcppExport_registerCCallable", (DL_FUNC) &_mets_RcppExport_registerCCallable,0}, {"pBhat", (DL_FUNC) &pBhat, 6}, {"PropTestCox", (DL_FUNC) &PropTestCox, 4}, {"PropTestCoxClust", (DL_FUNC) &PropTestCoxClust, 13}, {"ModelMatrixTestCox", (DL_FUNC) &ModelMatrixTestCox, 5}, {"pmvn0", (DL_FUNC) &pmvn0, 5}, {"revcumsumR", (DL_FUNC) &revcumsumR, 1}, {"revcumsumstrataR", (DL_FUNC) &revcumsumstrataR, 3}, {"riskstrataR", (DL_FUNC) &riskstrataR, 3}, {"revcumsumstratasumR", (DL_FUNC) &revcumsumstratasumR, 3}, {"cumsumstratasumR", (DL_FUNC) &cumsumstratasumR, 3}, {"cumsumstrataPOR", (DL_FUNC) &cumsumstrataPOR, 6}, {"DLambetaR", (DL_FUNC) &DLambetaR, 8}, {"cumsumidstratasumR", (DL_FUNC) &cumsumidstratasumR, 5}, {"cumsumASR", (DL_FUNC) &cumsumidstratasumR, 3}, {"tailstrataR", (DL_FUNC) &tailstrataR, 3}, {"cumsumidstratasumCovR", (DL_FUNC) &cumsumidstratasumCovR, 6}, {"revcumsumidstratasumR", (DL_FUNC) &revcumsumidstratasumR, 5}, {"revcumsumidstratasumCovR", (DL_FUNC) &revcumsumidstratasumCovR, 6}, {"covrfR", (DL_FUNC) &covrfR, 4}, {"covrfstrataR", (DL_FUNC) &covrfstrataR, 6}, {"covrfstrataCovR", (DL_FUNC) &covrfstrataCovR, 8}, {"cumsumstrataR", (DL_FUNC) &cumsumstrataR, 3}, {"sumstrataR", (DL_FUNC) &sumstrataR, 3}, {"Dpmvn", (DL_FUNC) &Dpmvn, 5}, // {"simBandCumHazCox", (DL_FUNC) &simBandCumHazCox, 5}, {"RsurvivalRVCmarg", (DL_FUNC) &RsurvivalRVCmarg, 7}, {"survivalRV", (DL_FUNC) &survivalRV, 10}, {"survivalRV2", (DL_FUNC) &survivalRV2, 10}, {"survivalloglikeRVpairs", (DL_FUNC) &survivalloglikeRVpairs, 25}, {"twostageloglikebin", (DL_FUNC) &twostageloglikebin, 24}, {"twostageloglikebinpairs", (DL_FUNC) &twostageloglikebinpairs, 28}, {"twostageloglikeRV", (DL_FUNC) &twostageloglikeRV, 22}, {"twostageloglikeRVpairs", (DL_FUNC) &twostageloglikeRVpairs, 25}, {"Uhat", (DL_FUNC) &Uhat, 5}, {"uniprobit", (DL_FUNC) &uniprobit, 8}, {"vecMatMat", (DL_FUNC) &vecMatMat, 2}, {"OutCov", (DL_FUNC) &OutCov, 2}, {"XBmindex", (DL_FUNC) &XBmindex, 3}, {NULL, NULL, 0} }; void R_init_mets(DllInfo *dll) { R_registerRoutines(dll, NULL, /* slot for .C */ CallEntries, /* slot for .Call */ NULL, /* slot for .Fortran */ NULL); /* slot for .External */ R_useDynamicSymbols(dll, TRUE); /* visibility */ } mets/src/quadrule.h0000644000176200001440000001731113623061405014007 0ustar liggesusers#ifndef GAUSSHERMITE_H #define GAUSSHERMITE_H #include #include class QuadRule { private: arma::vec x; arma::vec w; public: arma::vec Weight() { return(w); } arma::vec Abscissa() { return(x); } QuadRule(int n=1) : x(std::min(n+(n%2==0),21)), w(std::min(n+(n%2==0),21)) { switch(n) { case 0: break; case 1: x[0] = 0; w[0] = 1.77245385090552; break; case 2: case 3: x[0] = 1.22474487139159; x[1] = 8.88178419700125e-16; x[2] = -1.22474487139159; w[0] = 0.29540897515092; w[1] = 1.18163590060368; w[2] = 0.295408975150921; break; case 4: case 5: x[0] = 2.02018287045609; x[1] = 0.95857246461382; x[2] = 8.88178419700125e-16; x[3] = -0.958572464613816; x[4] = -2.02018287045608; w[0] = 0.0199532420590458; w[1] = 0.39361932315224; w[2] = 0.945308720482942; w[3] = 0.393619323152242; w[4] = 0.0199532420590459; break; case 6: case 7: x[0] = 2.65196135683523; x[1] = 1.67355162876747; x[2] = 0.816287882858967; x[3] = 1.33226762955019e-15; x[4] = -0.816287882858962; x[5] = -1.67355162876746; x[6] = -2.65196135683523; w[0] = 0.000971781245099515; w[1] = 0.0545155828191268; w[2] = 0.425607252610126; w[3] = 0.810264617556808; w[4] = 0.425607252610129; w[5] = 0.0545155828191272; w[6] = 0.000971781245099528; break; case 8: case 9: x[0] = 3.19099320178153; x[1] = 2.26658058453184; x[2] = 1.46855328921667; x[3] = 0.723551018752838; x[4] = 0; x[5] = -0.723551018752837; x[6] = -1.46855328921667; x[7] = -2.26658058453184; x[8] = -3.19099320178153; w[0] = 3.96069772632642e-05; w[1] = 0.00494362427553695; w[2] = 0.088474527394377; w[3] = 0.432651559002555; w[4] = 0.720235215606052; w[5] = 0.432651559002555; w[6] = 0.0884745273943762; w[7] = 0.00494362427553692; w[8] = 3.96069772632637e-05; break; case 10: case 11: x[0] = 3.66847084655958; x[1] = 2.78329009978165; x[2] = 2.02594801582575; x[3] = 1.32655708449493; x[4] = 0.6568095668821; x[5] = 8.88178419700125e-16; x[6] = -0.656809566882099; x[7] = -1.32655708449493; x[8] = -2.02594801582576; x[9] = -2.78329009978165; x[10] = -3.66847084655958; w[0] = 1.43956039371425e-06; w[1] = 0.000346819466323343; w[2] = 0.0119113954449115; w[3] = 0.117227875167709; w[4] = 0.429359752356122; w[5] = 0.654759286914593; w[6] = 0.429359752356126; w[7] = 0.117227875167708; w[8] = 0.0119113954449111; w[9] = 0.000346819466323334; w[10] = 1.43956039371421e-06; break; case 12: case 13: x[0] = 4.10133759617864; x[1] = 3.24660897837241; x[2] = 2.51973568567824; x[3] = 1.85310765160151; x[4] = 1.22005503659075; x[5] = 0.605763879171061; x[6] = 8.88178419700125e-16; x[7] = -0.605763879171056; x[8] = -1.22005503659075; x[9] = -1.85310765160151; x[10] = -2.51973568567824; x[11] = -3.24660897837241; x[12] = -4.10133759617864; w[0] = 4.82573185007318e-08; w[1] = 2.04303604027071e-05; w[2] = 0.00120745999271939; w[3] = 0.02086277529617; w[4] = 0.140323320687024; w[5] = 0.42161629689854; w[6] = 0.604393187921162; w[7] = 0.421616296898545; w[8] = 0.140323320687024; w[9] = 0.0208627752961696; w[10] = 0.00120745999271937; w[11] = 2.04303604027065e-05; w[12] = 4.82573185007304e-08; break; case 14: case 15: x[0] = 4.49999070730939; x[1] = 3.66995037340445; x[2] = 2.96716692790561; x[3] = 2.32573248617386; x[4] = 1.71999257518649; x[5] = 1.13611558521092; x[6] = 0.565069583255578; x[7] = 3.5527136788005e-15; x[8] = -0.565069583255571; x[9] = -1.13611558521092; x[10] = -1.71999257518648; x[11] = -2.32573248617385; x[12] = -2.9671669279056; x[13] = -3.66995037340444; x[14] = -4.49999070730938; w[0] = 1.52247580425353e-09; w[1] = 1.05911554771107e-06; w[2] = 0.0001000044412325; w[3] = 0.00277806884291275; w[4] = 0.0307800338725461; w[5] = 0.158488915795935; w[6] = 0.412028687498897; w[7] = 0.564100308726416; w[8] = 0.412028687498902; w[9] = 0.158488915795936; w[10] = 0.0307800338725457; w[11] = 0.00277806884291278; w[12] = 0.0001000044412325; w[13] = 1.05911554771112e-06; w[14] = 1.52247580425367e-09; break; case 16: case 17: x[0] = 4.8713451936744; x[1] = 4.06194667587547; x[2] = 3.37893209114149; x[3] = 2.75776291570389; x[4] = 2.17350282666662; x[5] = 1.61292431422123; x[6] = 1.06764872574345; x[7] = 0.531633001342657; x[8] = 8.88178419700125e-16; x[9] = -0.531633001342652; x[10] = -1.06764872574345; x[11] = -1.61292431422123; x[12] = -2.17350282666662; x[13] = -2.75776291570389; x[14] = -3.37893209114149; x[15] = -4.06194667587547; x[16] = -4.8713451936744; w[0] = 4.58057893079867e-11; w[1] = 4.97707898163089e-08; w[2] = 7.11228914002143e-06; w[3] = 0.000298643286697756; w[4] = 0.00506734995762757; w[5] = 0.0409200341497567; w[6] = 0.172648297670097; w[7] = 0.401826469470411; w[8] = 0.530917937624859; w[9] = 0.401826469470415; w[10] = 0.172648297670098; w[11] = 0.0409200341497562; w[12] = 0.00506734995762745; w[13] = 0.000298643286697756; w[14] = 7.11228914002152e-06; w[15] = 4.97707898163081e-08; w[16] = 4.58057893079847e-11; break; case 18: case 19: x[0] = 5.22027169053748; x[1] = 4.42853280660378; x[2] = 3.76218735196402; x[3] = 3.1578488183476; x[4] = 2.59113378979454; x[5] = 2.04923170985062; x[6] = 1.52417061939354; x[7] = 1.01036838713431; x[8] = 0.503520163423889; x[9] = 0; x[10] = -0.503520163423885; x[11] = -1.01036838713431; x[12] = -1.52417061939353; x[13] = -2.04923170985062; x[14] = -2.59113378979454; x[15] = -3.1578488183476; x[16] = -3.76218735196401; x[17] = -4.42853280660377; x[18] = -5.22027169053748; w[0] = 1.32629709449852e-12; w[1] = 2.16305100986354e-09; w[2] = 4.48824314722315e-07; w[3] = 2.72091977631616e-05; w[4] = 0.000670877521407184; w[5] = 0.00798886677772307; w[6] = 0.0508103869090527; w[7] = 0.183632701306996; w[8] = 0.391608988613028; w[9] = 0.502974888276183; w[10] = 0.391608988613033; w[11] = 0.183632701306998; w[12] = 0.0508103869090517; w[13] = 0.00798886677772294; w[14] = 0.000670877521407195; w[15] = 2.72091977631622e-05; w[16] = 4.48824314722318e-07; w[17] = 2.1630510098636e-09; w[18] = 1.32629709449851e-12; break; default: x[0] = 5.55035187326468; x[1] = 4.77399234341122; x[2] = 4.12199554749184; x[3] = 3.53197287713768; x[4] = 2.9799912077046; x[5] = 2.45355212451284; x[6] = 1.94496294918625; x[7] = 1.44893425065073; x[8] = 0.96149963441837; x[9] = 0.479450707079108; x[10] = 0; x[11] = -0.479450707079105; x[12] = -0.961499634418367; x[13] = -1.44893425065073; x[14] = -1.94496294918625; x[15] = -2.45355212451284; x[16] = -2.9799912077046; x[17] = -3.53197287713767; x[18] = -4.12199554749184; x[19] = -4.77399234341122; x[20] = -5.55035187326468; w[0] = 3.72036507013603e-14; w[1] = 8.81861124205004e-11; w[2] = 2.5712301800593e-08; w[3] = 2.17188489805666e-06; w[4] = 7.47839886731003e-05; w[5] = 0.00125498204172641; w[6] = 0.0114140658374345; w[7] = 0.0601796466589129; w[8] = 0.192120324066999; w[9] = 0.381669073613499; w[10] = 0.479023703120173; w[11] = 0.381669073613504; w[12] = 0.192120324067; w[13] = 0.0601796466589117; w[14] = 0.0114140658374341; w[15] = 0.0012549820417264; w[16] = 7.47839886730978e-05; w[17] = 2.17188489805664e-06; w[18] = 2.57123018005922e-08; w[19] = 8.81861124204988e-11; w[20] = 3.72036507013564e-14; break; } } }; #endif /* GAUSSHERMITE_H */ mets/src/pch.cpp0000644000176200001440000000174513623061405013276 0ustar liggesusers// [[Rcpp::interfaces(cpp)]] // [[Rcpp::plugins(cpp11)]] #include #include using namespace Rcpp; using arma::datum; // [[Rcpp::export(name = ".rpch")]] arma::vec rpch(unsigned n, std::vector lambda, std::vector time) { auto K = lambda.size(); arma::vec res = -log(runif(n))/lambda[0] + time[0]; for (unsigned i=0; i lambda, std::vector time) { auto K = lambda.size(); auto n = x.size(); arma::vec res(n); res.fill(0); for (unsigned k=0; k= time[k]); for (unsigned i=0; i0) { double t0 = std::fmin(x[i]-time[k], time[k+1]-time[k]); res[i] += lambda[k]*t0; } } } return ( res ); } mets/src/tools.cpp0000644000176200001440000002446313623061405013666 0ustar liggesusers// [[Rcpp::interfaces(r, cpp)]] #include "tools.h" #include SEXP FastLong2(SEXP idata, SEXP inclust, SEXP infixed, SEXP invarying) { BEGIN_RCPP unsigned nvarying = Rcpp::as(invarying); // Number of varying var unsigned nfixed = Rcpp::as(infixed); // Number of non-varying unsigned nclust = Rcpp::as(inclust); // Number within cluster Rcpp::DataFrame d = Rcpp::as(idata); // Wide data //bool Missing = Rcpp::as(missing); unsigned n= d.nrows(); unsigned M = nclust*n; unsigned K = nvarying+nfixed+2; Row idx(nvarying); uvec mis(M); mis.fill(0); for (unsigned k=0; k(d[k]); myList[k] = Rcpp::rep_each(mm,nclust); } else if (Rf_isInteger(d[k])) { IntegerVector mm = Rcpp::as(d[k]); myList[k] = Rcpp::rep_each(mm,nclust); } else if (Rf_isNumeric(d[k])) { NumericVector mm = Rcpp::as(d[k]); myList[k] = Rcpp::rep_each(mm,nclust); } else if (Rf_isComplex(d[k])) { ComplexVector mm = Rcpp::as(d[k]); myList[k] = Rcpp::rep_each(mm,nclust); } else if (Rf_isString(d[k]) || Rf_isFactor(d[k])) { CharacterVector mm = Rcpp::as(d[k]); myList[k] = Rcpp::rep_each(mm,nclust); } } for (unsigned k=0; k(d[idx[k]+i]); myList[nfixed+k] = Rcpp::LogicalVector(mm.begin(),mm.end()); } else if (type==2) { IntegerMatrix mm(nclust,n); for (unsigned i=0; i(d[idx[k]+i]); myList[nfixed+k] = Rcpp::IntegerVector(mm.begin(),mm.end()); } else if (type==3) { NumericMatrix mm(nclust,n); for (unsigned i=0; i(d[idx[k]+i]); //myList[nfixed+k] = Rcpp::NumericMatrix(M,1,mm.begin()); myList[nfixed+k] = Rcpp::NumericVector(mm.begin(),mm.end()); } else if (type==4) { ComplexMatrix mm(nclust,n); for (unsigned i=0; i(d[idx[k]+i]); myList[nfixed+k] = Rcpp::ComplexVector(mm.begin(),mm.end()); } else if (type==5) { CharacterMatrix mm(nclust,n); for (unsigned i=0; i(d[idx[k]+i]); myList[nfixed+k] = Rcpp::CharacterVector(mm.begin(),mm.end()); } } // IntegerVector Id = Rcpp::seq_len(n); IntegerVector Id = Rcpp::rep_each(Rcpp::seq_len(n),nclust); IntegerVector Num = Rcpp::rep(Rcpp::seq_len(nclust),n); myList[K-2] = Id; myList[K-1] = Num; myList.attr("names") = Rcpp::seq_len(K); myList.attr("row.names") = Rcpp::seq_len(M); myList.attr("class") = "data.frame"; return(Rcpp::wrap(myList)); END_RCPP } SEXP FastLong(SEXP idata, SEXP inclust, SEXP infixed, SEXP invarying, SEXP missing) { BEGIN_RCPP unsigned nvarying = Rcpp::as(invarying); // Number of varying var unsigned nfixed = Rcpp::as(infixed); // Number of non-varying unsigned nclust = Rcpp::as(inclust); // Number within cluster mat d = Rcpp::as(idata); // Wide data bool Missing = Rcpp::as(missing); unsigned M = nclust*d.n_rows; unsigned K = nvarying+nfixed+2; mat dd(M,K); // Long data uvec idx(nvarying); uvec mis(M); mis.fill(0); // NA_INTEGER for (unsigned k=0; k0); k(y1); unsigned n = Y1.n_rows; unsigned k = Y1.n_cols; unsigned Cat = Rcpp::as(cat); umat stat; if (!Rf_isNull(y2)) { mat Y2 = Rcpp::as(y2); if ((Y2.n_rows!=n) || (Y2.n_cols!=k)) throw(Rcpp::exception("Dimension did not agree","tools.cpp",1)); stat = (Y1==Y2); } else { stat = conv_to::from(Y1); } uvec group(n); // unsigned npattern = (unsigned) pow(2,(double) k); umat pattern; //(npattern,k); fastpattern(stat,pattern,group,Cat); return(Rcpp::List::create( Rcpp::Named("pattern")=pattern, Rcpp::Named("group")=wrap(group) )); END_RCPP } RcppExport SEXP FastCluster(const SEXP x) { BEGIN_RCPP arma::Row xx = as >(x); vector cpos, csize; unsigned val=0, prev=0, cursize=0; for (unsigned i=0; i >::from(xx), Rcpp::Named("cluster.first")=cpos, Rcpp::Named("cluster.size")=csize )); // return( wrap(list(xx,) ); END_RCPP } RcppExport SEXP FastApprox(const SEXP time, const SEXP newtime, const SEXP equal, const SEXP type // (0: nearest, 1: right, 2: left) ) {/*{{{*/ BEGIN_RCPP unsigned Type = Rcpp::as(type); NumericVector NewTime(newtime); NumericVector Sorted(time); // IntegerVector Order; // NumericVector Sorted = Time; // std::sort(Sorted.begin(), Sorted.end()); // // .sort(); // IntegerVector Order = match(Sorted, Time); // return(Rcpp::wrap(Time)); bool Equal = Rcpp::as(equal); vector idx(NewTime.size()); vector eq(NewTime.size()); double vmax = Sorted[Sorted.size()-1]; NumericVector::iterator it; double upper=0.0; int pos=0; for (int i=0; ivmax) { pos = Sorted.size()-1; } else { it = lower_bound(Sorted.begin(), Sorted.end(), NewTime[i]); upper = *it; if (it == Sorted.begin()) { pos = 0; if (Equal && (NewTime[i]==upper)) { eq[i] = 1; } } // else if (int(it-Sorted.end())==0) { // pos = Sorted.size()-1; // } else { pos = int(it-Sorted.begin()); if (Type==0 && fabs(NewTime[i]-Sorted[pos-1])(type); // NumericVector NewTime(newtime); // NumericVector Sorted(time); // // IntegerVector Order; // // NumericVector Sorted = Time; // // std::sort(Sorted.begin(), Sorted.end()); // // // .sort(); // // IntegerVector Order = match(Sorted, Time); // // return(Rcpp::wrap(Time)); // unsigned Equal = Rcpp::as(equal); //// bool Equal = Rcpp::as(equal); // vector eq(NewTime.size()); // // vector idx(NewTime.size()); //// IntegerVector idx(NewTime.size(),0); // // double vmax = Sorted[Sorted.size()-1]; // NumericVector::iterator it; // double upper=0.0; int pos=0; // for (int i=0; ivmax) { // pos = Sorted.size()-1; // } else { // it = lower_bound(Sorted.begin(), Sorted.end(), NewTime[i]); // upper = *it; // if (it == Sorted.begin()) { // pos = 0; // if ((Equal==1) && (NewTime[i]==upper)) { eq[i] = 1; } // } // // else if (int(it-Sorted.end())==0) { // // pos = Sorted.size()-1; // // } // else { // pos = int(it-Sorted.begin()); // if (Type==0 && fabs(NewTime[i]-Sorted[pos-1]) #include #include /* #include */ /* #include */ /* #include */ using namespace std; using namespace Rcpp; using namespace arma; const double twopi = 2*M_PI; //datum::pi; const double itwopi = 0.5/M_PI; //datum::pi; const double log2pi = log(twopi); struct vecmat { vec V; mat M; }; RcppExport SEXP pmvn(SEXP lower, SEXP upper, SEXP mu, SEXP sigma, SEXP cor); RcppExport SEXP Dpmvn(SEXP lower, SEXP upper, SEXP mu, SEXP sigma, SEXP std); /* RcppExport SEXP loglikMVN(SEXP yl, SEXP yu, */ /* SEXP status, */ /* SEXP mu, SEXP dmu, */ /* SEXP s, SEXP ds, */ /* SEXP z, SEXP su, SEXP dsu, */ /* SEXP threshold, SEXP dthreshold, */ /* SEXP score); */ RcppExport SEXP bvncdf(SEXP a, SEXP b, SEXP r); double Sbvn(double &l1, double &l2,double &r); inline double Fbvn(double u1, double u2, double r) { u1 *= -1; u2 *= -1; return(Sbvn(u1,u2,r)); } vecmat Dbvn(double y1, double y2, double R); double dbvnorm(double y1, double y2, double R); double mvtdst(int* n, int* nu, double* lower, double* upper, int* infin, double* correl, double* delta, int* maxpts, double* abseps, double* releps, double* error, double* value, int* inform); extern "C" double bvnd_(const double *dh, const double *dk, const double *r); #endif /* MVN_H */ mets/src/Makevars0000644000176200001440000000032513623061405013505 0ustar liggesusers## Use the R_HOME indirection to support installations of multiple R version PKG_CPPFLAGS = -I../inst/include -DNDEBUG PKG_LIBS = `$(R_HOME)/bin/Rscript -e "Rcpp:::LdFlags()"` $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) mets/src/cor.cpp0000644000176200001440000011556313623061405013313 0ustar liggesusers #include #include #include #include #include #include using namespace arma; using namespace Rcpp; // {{{ laplace and derivatives for structured random cif double lapgam(double alpha,double beta,double t) { double val; val=exp(alpha*(log(beta)-log(beta+t))); return(val); } double ilapgam(double alpha,double beta,double y) { double val; val=beta*(exp(-log(y)/alpha)-1); return(val); } double Dilapgam(double alpha,double beta,double y) { double val; val=beta*exp(-log(y)/alpha)*(log(y)/(alpha*alpha)); return(val); } double Dbetailapgam(double alpha,double beta,double y) { double val; val=(exp(-log(y)/alpha)-1); return(val); } double Dalphalapgam(double alpha,double beta,double t) { double val; val=exp(alpha*(log(beta)-log(beta+t))); val=(log(beta)-log(beta+t))*val; return(val); } double Dbetalapgam(double alpha,double beta,double t) { double val; val=exp(alpha*(log(beta)-log(beta+t))); val=alpha*(1/beta-1/(beta+t))*val; return(val); } double Dtlapgam(double alpha,double beta,double t) { double val; val=exp(alpha*(log(beta)-log(beta+t))); val=-alpha*(1/(beta+t))*val; return(val); } // }}} // {{{ Complex laplace and derivatives for structured random cif cx_double Clapgam(cx_double alpha,cx_double beta,cx_double t) { cx_double val; val=exp(alpha*(log(beta)-log(beta+t))); return(val); } cx_double Cilapgam(cx_double alpha,cx_double beta,cx_double y) { cx_double val; val=beta*(exp(-log(y)/alpha)- (cx_double) 1); return(val); } cx_double CDilapgam(cx_double alpha,cx_double beta,cx_double y) { cx_double val; val=beta*exp(-log(y)/alpha)*(log(y)/(alpha*alpha)); return(val); } cx_double CDbetailapgam(cx_double alpha,cx_double beta,cx_double y) { cx_double val; val=(exp(-log(y)/alpha)-(cx_double) 1); return(val); } cx_double CDalphalapgam(cx_double alpha,cx_double beta,cx_double t) { cx_double val; val=exp(alpha*(log(beta)-log(beta+t))); val=(log(beta)-log(beta+t))*val; return(val); } //cx_double CDbetalapgam(cx_double alpha,cx_double beta,cx_double t) //{ //cx_double val; //val=exp(alpha*(log(beta)-log(beta+t))); //val=alpha*(1/beta-1/(beta+t))*val; //return(val); //} // // //cx_double CDtlapgam(cx_double alpha,cx_double beta,cx_double t) //{ //cx_double val; //val=exp(alpha*(log(beta)-log(beta+t))); //val=-alpha*(1/(beta+t))*val; //return(val); //} // }}} void ckrvdes(vec &alphai,vec &alphak, // {{{ double beta, double x,double y, vec &ckij, vec &dckij,vec &rvi,vec &rvk) { double val,val1,val2,val3,alphi=0,alphk=0,alph=0; double test=1; // lapgam(),ilapgam(),Dtlapgam(),Dalphalapgam(),Dilapgam(); int prv,k; if (test<1) { Rprintf("ckr \n"); //print_vec(dckij); print_vec(rvk); print_vec(rvi); print_vec(alphai); print_vec(alphak); } // fix denne i CPP version //alphi=trans(rvi) * alphai; alphk= trans(rvk) * alphak; //if (test<1) Rprintf("=============================ckr %lf %lf \n",alphi,alphk); prv=rvi.n_rows; vec Dphi(prv),Dphk(prv); val=1; for (k=0;k0) { val1=rvi(k)*ilapgam(alphi,beta,exp(-x))+ rvk(k)*ilapgam(alphk,beta,exp(-y)); if (rvi(k)>0) alph=alphai(k); else alph=alphak(k); val1=lapgam(alph,beta,val1); val=val*val1; } ckij(0)=1-exp(-x)-exp(-y)+val; if (test<1) Rprintf(" %lf ckij \n",ckij(0)); val1=0; for (k=0;k0) { if (rvi(k)>0) alph=alphai(k); else alph=alphak(k); val2=rvi(k)*ilapgam(alphi,beta,exp(-x))+rvk(k)*ilapgam(alphk,beta,exp(-y)); val1= Dtlapgam(alph,beta,val2); val3= lapgam(alph,beta,val2); dckij(k)=dckij(k)+Dalphalapgam(alph,beta,val2)/val3; Dphi=Dphi+(val1*rvi(k)*Dilapgam(alphi,beta,exp(-x))/val3)*rvi; //scl_vec_mult(val1*rvi(k)*Dilapgam(alphi,beta,exp(-x))/val3,rvi,Dphi); Dphk=Dphk+(val1*rvk(k)*Dilapgam(alphk,beta,exp(-y))/val3)*rvk; dckij=dckij+Dphi+Dphk; //vec_add(Dphi,dckij,dckij); vec_add(Dphk,dckij,dckij); }; dckij=val*dckij; //scl_vec_mult(val,dckij,dckij); val2=rvi(k)*ilapgam(alphi,beta,exp(-x))+rvk(k)*ilapgam(alphk,beta,exp(-y)); val1= Dtlapgam(alph,beta,val2); val3= lapgam(alph,beta,val2); dckij(k)=dckij(k)+Dalphalapgam(alph,beta,val2)/val3; Dphi=val1*rvi*rvi(k)*Dilapgam(alphi,beta,exp(-x))/val3; Dphk=val1*rvk*rvk(k)*Dilapgam(alphk,beta,exp(-y))/val3; dckij=(dckij+Dphi+Dphk); dckij=val*dckij; //if (test<1) print_vec(dckij); //free_vecs(&Dphi,&Dphk,NULL); if (test<1) Rprintf("=============================================== ude af cvrks \n"); } // }}} void funkdes2(vec &alphai,vec &alphak, // {{{ double beta, double x,double y, vec &ckij, vec &dckij,vec &rvi,vec &rvk) { double val,val1,alphi,alphk,alph,betai,betak; double test=1; // lapgam(),ilapgam(),Dtlapgam(), Dalphalapgam(),Dilapgam(),Dbetalapgam(),Dbetailapgam(); int prv,k; if (test<1) { Rprintf("ckr \n"); //print_vec(dckij); print_vec(rvk); print_vec(rvi); print_vec(alphai); print_vec(alphak); } alphi=dot(rvi,alphai); alphk=dot(rvk,alphak); betai=alphi; betak=alphk; if (test<1) Rprintf("=============================ckr %lf %lf \n",alphi,alphk); prv=rvk.n_rows; val=1; for (k=0;k0) { val1=rvi(k)*ilapgam(alphi,betai,exp(-x))+ rvk(k)*ilapgam(alphk,betak,exp(-y)); if (rvi(k)>0) alph=alphai(k); else alph=alphak(k); val1=lapgam(alph,betai,val1); val=val*val1; } ckij(0)=1-exp(-x)-exp(-y)+val; } // }}} void ckrvdes2(vec &alphai,vec &alphak, // {{{ double beta, double x,double y, vec &ckij, vec &dckij,vec &rvi,vec &rvk) { double val,val1,alphi=0,alphk=0,alph,betai,betak; double test=1; //lapgam(),ilapgam(),Dtlapgam(), Dalphalapgam(),Dilapgam(),Dbetalapgam(),Dbetailapgam(); int prv,k,nn,i; //void funkdes2(); if (test<1) { Rprintf("ckr \n"); //print_vec(dckij); print_vec(rvk); print_vec(rvi); print_vec(alphai); print_vec(alphak); } // fix denne i CPP version //rvi.print("ckrv rvi"); //alphai.print("alph ckrv rvi"); nn=rvi.n_rows; for (k=0;k< nn;k++) { alphi=alphi+rvi(k)*alphai(k); alphk=alphk+rvk(k)*alphak(k); } //alphi=sum(rvi % alphai); alphk=sum(rvk% alphak); //alphi=trans(rvi) * alphai; alphk=trans(rvk) * alphak; betai=alphi; betak=alphk; prv=rvi.n_rows; vec Dphi(prv),Dphk(prv); Dphi.fill(0); Dphk.fill(0); val=1; for (k=0;k0) { val1=rvi(k)*ilapgam(alphi,betai,exp(-x))+ rvk(k)*ilapgam(alphk,betak,exp(-y)); if (rvi(k)>0) alph=alphai(k); else alph=alphak(k); val1=lapgam(alph,betai,val1); val=val*val1; } ckij(0)=1-exp(-x)-exp(-y)+val; // computation of derivatives using cx_double numbers and cx_double functions // goes through the values and adds epislon*i //double epsilon=0; double epsilon=1E-20; epsilon=1E-6; //double Calpht,Calphit,Calphkt,Cbetait,Cbetakt; //vec Calphait(prv),Calphakt(prv); // //nn=prv; //for (i=0;i< prv;i++) { // {{{ // for (k=0;k< prv;k++) { // Calphait(k)=alphai(k); // Calphakt(k)=alphak(k); // } //// if ((alphai(i)!=0)) // Calphait(i)=alphai(i)+epsilon; //// if ((alphak(i)!=0)) // Calphakt(i)=alphak(i)+epsilon; // // Calphit=0; Calphkt=0; // for (k=0;k< nn;k++) { // Calphit=Calphit+rvi(k)*Calphait(k); // Calphkt=Calphit+rvk(k)*Calphakt(k); // } // Cbetait=Calphit; Cbetakt=Calphkt; // // double Cval1t,Cvalt=1,Cft; // for (k=0;k0) // { // Cval1t=rvi(k)*ilapgam(Calphit,Cbetait,exp(-x))+rvk(k)*ilapgam(Calphkt,Cbetakt,exp(-y)); // if (rvi(k)>0) Calpht=Calphait(k); else Calpht=Calphakt(k); // Cval1t=lapgam(Calpht,Cbetait,Cval1t); // Cvalt=Cvalt*Cval1t; // } // Cft=1-exp(-x)-exp(-y); // Cft=Cft+Cvalt; // dckij(i)= (Cft-ckij(0))/epsilon; // printf(" %d %lf \n",i,dckij(i)); //} // }}} // // computation of derivatives using cx_double numbers and cx_double functions // goes through the values and adds epislon*i //double epsilon=0; //double epsilon=1E-20; epsilon=1E-20; cx_double Calph,Calphi,Calphk,Cbetai,Cbetak; cx_vec Calphai(prv),Calphak(prv); nn=prv; for (i=0;i< prv;i++) { for (k=0;k< prv;k++) { Calphai(k)=cx_double(alphai(k),0); Calphak(k)=cx_double(alphak(k),0); } Calphai(i)=cx_double(alphai(i),epsilon); Calphak(i)=cx_double(alphak(i),epsilon); // sum af alpha'er Calphi=0; Calphk=0; for (k=0;k< nn;k++) { Calphi=Calphi+rvi(k)*Calphai(k); Calphk=Calphk+rvk(k)*Calphak(k); } Cbetai=Calphi; Cbetak=Calphk; cx_double Cval1,Cval=1,Cf; for (k=0;k0) { Cval1=rvi(k)*Cilapgam(Calphi,Cbetai,exp(-x))+rvk(k)*Cilapgam(Calphk,Cbetak,exp(-y)); if (rvi(k)>0) Calph=Calphai(k); else Calph=Calphak(k); Cval1=Clapgam(Calph,Cbetai,Cval1); Cval=Cval*Cval1; } Cf=(cx_double) 1-exp(-x)-exp(-y); Cf=Cf+Cval; dckij(i)= imag(Cf)/epsilon; } } // }}} void ckrvdestheta(mat &thetades,vec &theta, // {{{ int inverse, double x,double y, vec &ckij, vec &dckij,vec &rvi,vec &rvk) { double val,val1,alphi=0,alphk=0,alph,betai,betak; double test=1; //lapgam(),ilapgam(),Dtlapgam(), Dalphalapgam(),Dilapgam(),Dbetalapgam(),Dbetailapgam(); int ntheta,prv,k,nn,i; //void funkdes2(); if (test<1) { Rprintf("ckr \n"); //print_vec(dckij); print_vec(rvk); print_vec(rvi); print_vec(alphai); print_vec(alphak); } nn=rvi.n_rows; prv=nn; ntheta=theta.n_rows; vec theta2(ntheta); if (inverse==1) theta2=exp(theta); else theta2=theta; vec alphai(prv),alphak(prv); alphai= thetades * theta2; alphak= thetades * theta2; // fix denne i CPP version //rvi.print("ckrv rvi"); //alphai.print("alph ckrv rvi"); nn=rvi.n_rows; for (k=0;k< nn;k++) { alphi=alphi+rvi(k)*alphai(k); alphk=alphk+rvk(k)*alphak(k); } //alphi=sum(rvi % alphai); alphk=sum(rvk% alphak); //alphi=trans(rvi) * alphai; alphk=trans(rvk) * alphak; betai=alphi; betak=alphk; prv=rvi.n_rows; vec Dphi(prv),Dphk(prv); Dphi.fill(0); Dphk.fill(0); val=1; for (k=0;k0) { val1=rvi(k)*ilapgam(alphi,betai,exp(-x))+rvk(k)*ilapgam(alphk,betak,exp(-y)); if (rvi(k)>0) alph=alphai(k); else alph=alphak(k); val1=lapgam(alph,betai,val1); val=val*val1; } ckij(0)=1-exp(-x)-exp(-y)+val; // computation of derivatives using cx_double numbers and cx_double functions // goes through the values and adds epislon*i double epsilon=1E-20; cx_double Calph,Calphi,Calphk,Cbetai,Cbetak; cx_vec Calphai(prv),Calphak(prv); cx_vec Ctheta(ntheta),Ctheta2(ntheta); nn=prv; for (i=0;i< ntheta;i++) { for (k=0;k< ntheta;k++) Ctheta(k)=cx_double(theta(k),0); Ctheta(i)=cx_double(theta(i),epsilon); if (inverse==1) Ctheta2=exp(Ctheta); else Ctheta2=Ctheta; Calphai= thetades * Ctheta2; Calphak= thetades * Ctheta2; // sum af alpha'er Calphi=0; Calphk=0; for (k=0;k< nn;k++) { Calphi=Calphi+rvi(k)*Calphai(k); Calphk=Calphk+rvk(k)*Calphak(k); } Cbetai=Calphi; Cbetak=Calphk; cx_double Cval1,Cval=1,Cf; for (k=0;k0) { Cval1=rvi(k)*Cilapgam(Calphi,Cbetai,exp(-x))+rvk(k)*Cilapgam(Calphk,Cbetak,exp(-y)); if (rvi(k)>0) Calph=Calphai(k); else Calph=Calphak(k); Cval1=Clapgam(Calph,Cbetai,Cval1); Cval=Cval*Cval1; } Cf=(cx_double) 1-exp(-x)-exp(-y); Cf=Cf+Cval; dckij(i)= imag(Cf)/epsilon; } } // }}} RcppExport SEXP ckrvdesthetaR(SEXP ithetades,SEXP itheta, SEXP iinverse, SEXP isx,SEXP isy, // SEXP ickij,SEXP idckij, SEXP irvi,SEXP irvk) { // {{{ mat thetades = Rcpp::as(ithetades); colvec theta = Rcpp::as(itheta); // colvec cif2 = Rcpp::as(icif2); // colvec istatus1 = Rcpp::as(iistatus1); // colvec istatus2 = Rcpp::as(iistatus2); int inverse=Rcpp::as(iinverse); double sx =Rcpp::as(isx); double sy =Rcpp::as(isy); double x=-log(1-sx); double y=-log(1-sy); // printf(" %lf %lf %lf %lf \n",x,y,exp(-x),exp(-y)); colvec rvi = Rcpp::as(irvi); colvec rvk = Rcpp::as(irvk); // thetades.print("kj"); rvi.print("kj"); rvk.print("kj"); // printf(" %lf %lf \n",x,y); double ckij = 0; colvec dckij =theta; double val,val1,alphi=0,alphk=0,alph,betai,betak; double test=1; //lapgam(),ilapgam(),Dtlapgam(), Dalphalapgam(),Dilapgam(),Dbetalapgam(),Dbetailapgam(); int ntheta,prv,k,nn,i; //void funkdes2(); if (test<1) { Rprintf("ckr \n"); //print_vec(dckij); print_vec(rvk); print_vec(rvi); print_vec(alphai); print_vec(alphak); } nn=rvi.n_rows; prv=nn; ntheta=theta.n_rows; vec theta2(ntheta); vec laps(nn); vec ilaps(nn); laps.fill(1); ilaps.fill(0); if (inverse==1) theta2=exp(theta); else theta2=theta; vec alphai(prv),alphak(prv); alphai= thetades * theta2; alphak= thetades * theta2; //alphai.print("pari rvi"); //alphak.print("park rvi"); // fix denne i CPP version //rvi.print("ckrv rvi"); //alphai.print("alph ckrv rvi"); nn=rvi.n_rows; for (k=0;k< nn;k++) { alphi=alphi+rvi(k)*alphai(k); alphk=alphk+rvk(k)*alphak(k); } //alphi=sum(rvi % alphai); alphk=sum(rvk% alphak); //alphi=trans(rvi) * alphai; alphk=trans(rvk) * alphak; betai=alphi; betak=alphk; prv=rvi.n_rows; vec Dphi(prv),Dphk(prv); Dphi.fill(0); Dphk.fill(0); //printf(" %lf %lf %lf %lf \n",alphi,alphk,betai,betak); //printf(" %lf %lf \n",exp(-x),exp(-y)); double ii1=ilapgam(alphi,betai,exp(-x)); double ii2=ilapgam(alphk,betak,exp(-y)); val=1; for (k=0;k0) { val1=rvi(k)*ii1+rvk(k)*ii2; if (rvi(k)>0) alph=alphai(k); else alph=alphak(k); //printf("%d %lf %lf %lf %lf \n",k,alph,val1,rvi(k),rvk(k)); ilaps(k)=val1; val1=lapgam(alph,betai,val1); laps(k)=val1; val=val*val1; } ckij=1-exp(-x)-exp(-y)+val; // computation of derivatives using cx_double numbers and cx_double functions // goes through the values and adds epislon*i double epsilon=1E-20; cx_double Calph,Calphi,Calphk,Cbetai,Cbetak; cx_vec Calphai(prv),Calphak(prv); cx_vec Ctheta(ntheta),Ctheta2(ntheta); nn=prv; for (i=0;i< ntheta;i++) { // {{{ for (k=0;k< ntheta;k++) Ctheta(k)=cx_double(theta(k),0); Ctheta(i)=cx_double(theta(i),epsilon); if (inverse==1) Ctheta2=exp(Ctheta); else Ctheta2=Ctheta; Calphai= thetades * Ctheta2; Calphak= thetades * Ctheta2; // sum af alpha'er Calphi=0; Calphk=0; for (k=0;k< nn;k++) { Calphi=Calphi+rvi(k)*Calphai(k); Calphk=Calphk+rvk(k)*Calphak(k); } Cbetai=Calphi; Cbetak=Calphk; cx_double Cval1,Cval=1,Cf; for (k=0;k0) { Cval1=rvi(k)*Cilapgam(Calphi,Cbetai,exp(-x))+rvk(k)*Cilapgam(Calphk,Cbetak,exp(-y)); if (rvi(k)>0) Calph=Calphai(k); else Calph=Calphak(k); Cval1=Clapgam(Calph,Cbetai,Cval1); Cval=Cval*Cval1; } Cf=(cx_double) 1-exp(-x)-exp(-y); Cf=Cf+Cval; dckij(i)= imag(Cf)/epsilon; } // }}} List res; res["like"]=ckij; res["ssdob"]=val; res["sx"]=sx; res["sy"]=sy; res["par"]=alphai; res["laps"]=laps; res["ilaps"]=ilaps; res["rv1"]=rvi; res["rv2"]=rvk; res["lamtot"]=betai; res["ii1"]=ii1; res["ii2"]=ii2; res["dlike"]=dckij; return(res); } // }}} double ckrvdesp11t(vec &theta,mat &thetades,int inverse, // {{{ double x,double y, vec &rvi,vec &rvk) { double p11,val,val1,alphi=0,alphk=0,alph,betai,betak; double test=1; //lapgam(),ilapgam(),Dtlapgam(), Dalphalapgam(),Dilapgam(),Dbetalapgam(),Dbetailapgam(); int prv,k,nn; nn=rvi.n_rows; colvec alphai(nn),alphak(nn),vtheta2(nn); // if (inverse==1) vtheta2=exp(theta); else vtheta2=theta; alphai= thetades * vtheta2; alphak= thetades * vtheta2; if (test<1) { Rprintf("ckr \n"); //print_vec(dckij); print_vec(rvk); print_vec(rvi); print_vec(alphai); print_vec(alphak); } for (k=0;k< nn;k++) { alphi=alphi+rvi(k)*alphai(k); alphk=alphk+rvk(k)*alphak(k); } //alphi=sum(rvi % alphai); alphk=sum(rvk% alphak); //alphi=trans(rvi) * alphai; alphk=trans(rvk) * alphak; betai=alphi; betak=alphk; prv=rvi.n_rows; vec Dphi(prv),Dphk(prv); Dphi.fill(0); Dphk.fill(0); val=1; for (k=0;k0) { val1=rvi(k)*ilapgam(alphi,betai,exp(-x))+ rvk(k)*ilapgam(alphk,betak,exp(-y)); if (rvi(k)>0) alph=alphai(k); else alph=alphak(k); val1=lapgam(alph,betai,val1); val=val*val1; } p11=1-exp(-x)-exp(-y)+val; return(p11); } // }}} void ckrvdes3(vec &theta,mat &thetades, // {{{ int inverse, double x,double y, vec &ckij, vec &dckij,vec &rvi,vec &rvk) { //double val,val1,val2,val3,alphi=0,alphk=0,alph,betai,betak; //double lapgam(),ilapgam(),Dtlapgam(), Dalphalapgam(),Dilapgam(),Dbetalapgam(),Dbetailapgam(); int k,nn; //void funkdes2(); // ckij(0)= ckrvdesp11t(theta,thetades,inverse,x,y,rvi,rvk); nn=theta.n_rows; for (k=0;k< nn;k++) { colvec thetad=theta; thetad(k)+=0.01; dckij(k)=(ckrvdesp11t(thetad,thetades,inverse,x,y,rvi,rvk)-ckij(0))/0.01; } } // }}} // {{{ Laplace for random-cif model double laplace(double t,double x) { // {{{ double val,val1; val=(1+x*t); if (val<0) val=0; //if (fabs(t)< 0.000000000000001) val1=0; else val1=exp(-log(val)*(1/t)); val1=exp(-log(val)*(1/t)); // Rprintf("laplace %lf %lf \n",val,val3); return(val1); } // }}} double ilaplace(double t,double y) { // {{{ double val; //,laplace(); val=exp(-log(y)*t); val= (val-1)/t; // Rprintf("ilaplace y^(1/t) %lf %lf \n",exp(log(y)/t),pow(y,1.0/t)); // Rprintf("ilaplace %lf %lf \n",val,val1); return(val); } // }}} double Dilaplace(double theta,double y) { // {{{ double val4,val2,val,val1; val=exp(log(y)/theta); val2=-log(y)*val/(theta*theta); val4=(1-val)+theta*val2; val1=(val4+log(y)*(1-val)/theta)/val; return(val1); } // }}} double Dlaplace(double theta,double t) { // {{{ double val,val1; val=1+t/theta; val1=theta*val-log(val); val=val1*laplace(theta,t); return(val); } // }}} double D2laplace(double theta,double t) { // {{{ double val,val1,val2,val3; val=1+t/theta; val1=theta*val-log(val); val3=(t/(theta*theta))/val+(val+t/theta)/(val*val); val2=Dlaplace(theta,t)*val1+laplace(theta,t)*val3; return(val2); } // }}} // }}} void ckf(double t,double x,double y,vec &ckij,vec &dckij) { // {{{ double val,val2,val3,val4; //double laplace(),ilaplace(),Dilaplace(),Dlaplace(),D2laplace(); double t0; if (x<0) x=0.0001; if (y<0) y=0.0001; val=ilaplace(t,exp(-x))+ilaplace(t,exp(-y)); val2=laplace(t,val); ckij(0)=1-exp(-x)-exp(-y)+val2; val3=exp(x*t)+exp(y*t)-1; val4=val3*log(val3)+exp(x*t)*(-x*t)+exp(y*t)*(-y*t); // t0 =exp(-log(t)*2)*exp(log(val3)*(-1/t-1))*val4; t0 =pow(1/t,2)*exp(log(val3)*(-1/t-1))*val4; dckij(0)=t0; } // }}} void DUetagamma(double t, double x,double y,vec &xi,vec &xk) { // {{{ double y1,y2,t1,val3,val4; y1=exp(-x); y2=exp(-y); val3=exp(x*t)+exp(y*t)-1; val4 =exp(log(val3)*(-1/t)); t1=val4/(val3); //if (isnan(t1)) { //Rprintf(" missing values in DUetagamma \n"); //Rprintf(" t x y val3=exp(x*t)+exp(y*t)-1 %lf %lf %lf %lf \n",t,x,y,val3); ////print_vec(xi); ////print_vec(xk); //}; xi= (y1-t1*exp(t*x))*xi; xk= (y2-t1*exp(t*y))*xk; xi=xi+xk; } // }}} double plack(double theta,double cif1,double cif2,vec &dp) { // {{{ double valr,valn,val1,cifs, thetad,val1d,valnd,valrd,d, cif1d, cif2d, cifsd; cifs=cif1+cif2; // {{{ if (theta!=1) { valn=2*(theta-1); val1=(1+(theta-1)*(cifs))-pow( pow((1+(theta-1)*cifs),2)-4*cif1*cif2*theta*(theta-1),0.5); valr=val1/valn; } else { valr=cif1*cif2; } // }}} d=0.000001; thetad=theta+d; // {{{ if (thetad!=1) { valnd=2*(thetad-1); val1d=(1+(thetad-1)*(cifs))-pow( pow((1+(thetad-1)*cifs),2)-4*cif1*cif2*thetad*(thetad-1),0.5); valrd=val1d/valnd; } else { valrd=cif1*cif2; } // }}} dp(0)=(valrd-valr)/d; cif1d=cif1+d; cifsd=cif1d+cif2; // {{{ if (theta!=1) { valnd=2*(theta-1); val1d=(1+(theta-1)*(cifsd))-pow( pow((1+(theta-1)*cifsd),2)-4*cif1d*cif2*theta*(theta-1),0.5); valrd=val1d/valnd; } else { valrd=cif1d*cif2; } // }}} dp(1)=(valrd-valr)/d; cif2d=cif2+d; cifsd=cif1+cif2d; // {{{ if (theta!=1) { valnd=2*(theta-1); val1d=(1+(theta-1)*(cifsd))-pow( pow((1+(theta-1)*cifsd),2)-4*cif1d*cif2*theta*(theta-1),0.5); valrd=val1d/valnd; } else { valrd=cif1d*cif2; } // }}} dp(2)=(valrd-valr)/d; //if (theta!=1) { //dval1= cifs-(2*(1+(theta-1)*cifs)*cifs-4*2*cif1*cif2*theta+4*cif1*cif2)/ // (2*pow( pow((1+(theta-1)*cifs),2)-4*cif1*cif2*theta*(theta-1),0.5)); //val=valn*dval1-val1*2; //dp(0)= val/pow(valn,2); //dp(0)=(valrd-valr)/0.000001; //} else { //dp(0)=1; //} return(valr); } // }}} double min(double a, double b) { if (ab) return(a); else return(b); } RcppExport SEXP cor(SEXP itimes,SEXP iy,SEXP icause, SEXP iCA1, SEXP iKMc, SEXP iz, SEXP iest,SEXP iZgamma, SEXP isemi,SEXP izsem, // detail,biid,gamiid,timepow,theta,vartheta, SEXP itheta, SEXP iXtheta, SEXP iDXtheta, SEXP idimDX, SEXP ithetades, SEXP icluster,SEXP iclustsize,SEXP iclusterindex, SEXP iinverse,SEXP iCA2, SEXP ix2, // SEXP iz2, SEXP isemi2, SEXP iest2,SEXP iZ2gamma2, // b2iid, gam2iid, SEXP htheta,SEXP dhtheta,SEXP rhoR, SEXP iflexfunc, SEXP iiid, SEXP isym,SEXP iweights, SEXP isamecens, SEXP istabcens,SEXP iKMtimes,SEXP isilent,SEXP icifmodel, SEXP idepmodel, SEXP iestimator, SEXP ientryage,SEXP icif1entry,SEXP icif2entry,SEXP itrunkp, SEXP irvdes ) // {{{ { // {{{ setting matrices and vectors, and exporting to armadillo matrices //mat z2 = Rcpp::as(iz2); mat est = Rcpp::as(iest); mat est2 = Rcpp::as(iest2); mat z = Rcpp::as(iz); mat zsem = Rcpp::as(izsem); mat z2 = Rcpp::as(ix2); mat thetades = Rcpp::as(ithetades); mat clusterindex = Rcpp::as(iclusterindex); mat rvdes= Rcpp::as(irvdes); colvec theta = Rcpp::as(itheta); colvec y = Rcpp::as(iy); colvec clustsize = Rcpp::as(iclustsize); int antclust = clusterindex.n_rows; colvec times = Rcpp::as(itimes); int Ntimes=times.n_rows; colvec cause = Rcpp::as(icause); colvec cluster = Rcpp::as(icluster); colvec Zgamma = Rcpp::as(iZgamma); colvec KMtimes = Rcpp::as(iKMtimes ); colvec Z2gamma2 = Rcpp::as(iZ2gamma2); colvec KMc= Rcpp::as(iKMc); colvec weights = Rcpp::as(iweights); colvec entryage = Rcpp::as(ientryage); colvec cif1entry = Rcpp::as(icif1entry); colvec cif2entry = Rcpp::as(icif2entry); colvec trunkp = Rcpp::as(itrunkp); vec cif1lin=-log(1-cif1entry); // array for derivative of flexible design NumericVector DXthetavec(iDXtheta); IntegerVector arrayDims(idimDX); arma::cube DXtheta(DXthetavec.begin(), arrayDims[0], arrayDims[1], arrayDims[2], false); int samecens = Rcpp::as(isamecens); int inverse= Rcpp::as(iinverse); int semi = Rcpp::as(isemi); int semi2 = Rcpp::as(isemi2); int flexfunc = Rcpp::as(iflexfunc); int stabcens = Rcpp::as(istabcens); int silent = Rcpp::as(isilent); int cifmodel = Rcpp::as(icifmodel); int CA1 = Rcpp::as(iCA1); int CA2 = Rcpp::as(iCA2); int sym = Rcpp::as(isym); int depmodel= Rcpp::as(idepmodel); int estimator= Rcpp::as(iestimator); int iid= Rcpp::as(iiid); mat Xtheta = Rcpp::as(iXtheta); int udtest=0; if (udtest==1) { // {{{ Rprintf(" %d %d %d %d %d %d %d \n",samecens,inverse,semi,semi2,flexfunc,stabcens,silent); Rprintf(" %d %d %d %d %d %d %d \n",cifmodel,CA1,CA2,sym,depmodel,estimator,iid); est.print("est"); est2.print("est2"); z.print("z"); zsem.print("zsemi"); z2.print("z2"); thetades.print("theta.des"); clusterindex.print("clusterindex"); rvdes.print("rvdes"); theta.print("theta"); Xtheta.print("Xtheta"); y.print("y-times"); clustsize.print("clustsize"); times.print("times"); cause.print("cause"); cluster.print("cluster"); Zgamma.print("zgam"); Z2gamma2.print("zgam2"); KMtimes.print("KMtimes"); KMc.print("KMc"); weights.print("weights"); entryage.print("entryage"); cif1entry.print("cif1entry"); cif2entry.print("cif2entry"); trunkp.print("trunkp"); } else if (udtest==2) { Rprintf(" %d %d %d %d %d %d %d \n",samecens,inverse,semi,semi2,flexfunc,stabcens,silent); Rprintf(" %d %d %d %d %d %d %d \n",cifmodel,CA1,CA2,sym,depmodel,estimator,iid); Rprintf("est %lf \n",mean(mean(est))); Rprintf("est2 %lf \n",mean(mean(est2))); Rprintf("z %lf \n",mean(mean(z))); Rprintf("zsem %lf \n",mean(mean(zsem))); Rprintf("z2 %lf \n",mean(mean(z2))); mat mt=mean(thetades); mt.print("meancol thetades"); Rprintf("ci %lf \n",mean(mean(clusterindex))); Rprintf("rvdes %lf \n",mean(mean(rvdes))); Rprintf("theta %lf \n",mean(theta)); Rprintf("Xtheta %lf \n",mean(mean(Xtheta))); Rprintf("y %lf \n",mean(y)); Rprintf("ci %lf \n",mean(clustsize)); Rprintf("times %lf \n",mean(times)); Rprintf("cause %lf \n",mean(cause)); Rprintf("cluster %lf \n",mean(cluster)); Rprintf("Zgamma %lf \n",mean(Zgamma)); Rprintf("Z2gamma2 %lf \n",mean(Z2gamma2)); Rprintf("KMtimes %lf \n",mean(KMtimes)); Rprintf("KMc %lf \n",mean(KMc)); Rprintf("weights %lf \n",mean(weights)); Rprintf("entry %lf \n",mean(entryage)); Rprintf("cif1entry %lf \n",mean(cif1entry)); Rprintf("cif2entry %lf \n",mean(cif2entry)); Rprintf("trunkp %lf \n",mean(trunkp)); } // }}} int nr,ci,ck,i,j,c,s,k,v,c1,v1; double Li,Lk,weight=0,p11t,ormarg=0,sdj,diff,cweight2,time,resp1,resp2; // double resp3; double Dinverse=1,DDinverse=1,ddd,edd,ssf=0,response=0,thetak=0,respst=0; // double plack(); vec dplack(4); dplack.fill(0); int pt=theta.n_rows; vec ckij(4),dckij(4),ckijvv(4),dckijvv(4),ckijtv(4),dckijtv(4),ckijvt(4),dckijvt(4); i=silent+1; mat thetiid(antclust,pt); if (iid==1) thetiid.fill(0); colvec p11tvec(antclust); // p11tvec=0; // Rprintf(" %d \n",pt); colvec Utheta(pt); colvec vthetascore(pt); colvec pthetavec(pt); vec vtheta2(pt); mat DUtheta(pt,pt); DUtheta.fill(0); Utheta.fill(0); if (!Utheta.is_finite()) { Rprintf(" NA's i def U\n"); Utheta.print("U"); } if (!DUtheta.is_finite()) { Rprintf(" NA's i def DU\n"); DUtheta.print("DU"); } rowvec bhatt2 = est.row(est2.n_cols-1); colvec pbhat2(z.n_rows); // depmodel=5 // rvdes.print("rvdes"); // thetades.print("ttt"); nr=rvdes.n_cols; vec alphaj(nr),alphai(nr),alpha(nr), rvvec(nr),rvvec1(nr),rvvec2vv(nr),rvvec2vt(nr),rvvec2tv(nr); vec rvvec2(nr); // }}} for (s=0;s0) { R_CheckUserInterrupt(); time=times(s); rowvec bhatt = est.row(s); vec pbhat = z * trans(bhatt); if ((semi==1) & (cifmodel==1)) pbhat = pbhat + Zgamma*time; if ((semi==1) & (cifmodel==2)) pbhat=pbhat%exp(Zgamma); if ((CA1!=CA2)) { bhatt2 = est2.row(s); pbhat2 = z2 * trans(bhatt2); if ((semi2==1) & (cifmodel==1)) pbhat2 = pbhat2 + Z2gamma2*time; if ((semi2==1) & (cifmodel==2)) pbhat2=pbhat2%exp(Z2gamma2); } for (j=0;j=2) { diff=0; sdj=0; if (depmodel==5) { // {{{ if (inverse==1) vtheta2=exp(theta); else vtheta2=theta; alphai= thetades * vtheta2; alphaj= thetades * vtheta2; } // }}} for (c=0;c 0) && (KMc(k) > 0)) { ci=cause(i); ck=cause(k); resp1= ((y(k)<=time) && (ck==CA2)); resp2= ((y(i)<=time) && (ci==CA1))* ((y(k)<=time) && (ck==CA2)); respst=((y(i)<=entryage(i)) && (ci==CA1))* ((y(k)<=time) && (ck==CA2)) + ((y(i)<=time) && (ci==CA1))* ((y(k)<=entryage(k)) && (ck==CA2)) ; if (depmodel!=5) { // {{{ if (flexfunc==0) { thetak=Xtheta(i,0); pthetavec= trans(thetades.row(i)); } else { thetak=Xtheta(i,s); // pthetavec = DXtheta(span(s),span(i),span(0,pt-1)); pthetavec = DXtheta(span(s),span(i),span::all); // if (j==1) { printf(" %lf %d \n",time,i); pthetavec.print("pt"); } } } // }}} Li=pbhat(i); Lk=pbhat(k); if (CA1!=CA2) { // if (c>v) { // if (ci==CA1) Li=pbhat(i); else Li=pbhat2(i); // if (ck==CA1) Lk=pbhat(k); else Lk=pbhat2(k); // } else Lk=pbhat2(k); // if (j< 10) printf("s=%d i=%d k=%d %lf %lf \n",s,i,k,Lk,pbhat2(k)); Lk=pbhat2(k); } if (depmodel==1) ormarg=(1-exp(-Li))/exp(-Li); else if (depmodel==2) ormarg=(1-exp(-Li))*(1-exp(-Lk)); else if (depmodel==3) ormarg=(1-exp(-Li))*(1-exp(-Lk)); int nocens= (ci!=0)+(ck!=0); nocens=min(nocens,2); if (depmodel==1) { // cor model // {{{ if (stabcens==0) { // {{{ responses if (samecens==1) { resp2=resp2/min(KMc(i),KMc(k)); respst=respst/min(KMc(i),KMc(k)); } else { resp2=resp2/(KMc(i)*KMc(k)); respst=respst/(KMc(i)*KMc(k)); } resp1=resp1/KMtimes(k); } else { // cweight1= max(KMtimes[s],KMc(k)); cweight2= max(KMtimes[s],KMc(i)); if (samecens==1) { resp2=resp2/min(cweight2,cweight2); respst=respst/min(cweight2,cweight2); } resp1=resp1/KMtimes(k); } // }}} if (trunkp(i)<1) { // DENNE skal tilpasse COR modellen FIXES response=weight*(resp2- exp(thetak)*(ormarg+cif1entry(i)*cif2entry(k) -(1-exp(-Li))*cif2entry(k)-(1-exp(-Lk))*cif1entry(i))/trunkp(i)); diff=diff+response; sdj=sdj- weight*exp(thetak)*(ormarg+cif1entry(i)*cif2entry(k)- (1-exp(-Li))*cif2entry(k)- (1-exp(-Lk))*cif1entry(i))/trunkp(i); //resp3=-exp(thetak); } else { double nn=(exp(-Li)+exp(thetak)*(1-exp(-Li))); double nt=(1-exp(-Li))*(1-exp(-Lk))*exp(thetak); p11t=nt/nn; p11tvec(j)=p11t; ssf+=weights(i)*pow(resp2-p11t,2); if (inverse==1) { double dp11t=(nn*(1-exp(-Li))*(1-exp(-Lk))*exp(thetak)-nt*exp(thetak)*(1-exp(-Li)))/pow(nn,2); response= 2*dp11t*(resp2-p11t); sdj=sdj-2*pow(dp11t,2); //resp3=0; } else { response=exp(thetak)*(exp(thetak)*ormarg*(resp1-resp2)-resp2); sdj=sdj+2*exp(2*thetak)*ormarg*(resp1-resp2)-exp(thetak)*resp2; //resp3=exp(2*thetak)*(resp1-resp2)*exp(Li); } diff=diff+response; } // }}} } else if (depmodel==2) { // RR model // {{{ if (estimator==1) { if (samecens==1) { resp2=resp2/min(KMc(i),KMc(k)); respst=respst/min(KMc(i),KMc(k)); } else { resp2=resp2/(KMc(i)*KMc(k)); respst=respst/(KMc(i)*KMc(k)); } weight=1; } else if (estimator==0){ if (samecens==1) weight=1/min(KMc(i),KMc(k)); else weight=1/(KMc(i)*KMc(k)); } else { weight=(time #include #include #include #include #include using namespace std; using namespace Rcpp; using namespace arma; RcppExport SEXP FastLong2(SEXP idata, SEXP inclust, SEXP infixed, SEXP invarying); RcppExport SEXP FastLong(SEXP idata, SEXP inclust, SEXP infixed, SEXP invarying, SEXP missing); RcppExport SEXP FastApprox(const SEXP time, const SEXP newtime, const SEXP equal, const SEXP type); RcppExport SEXP FastPattern(SEXP y1,SEXP y2, SEXP cat); RcppExport SEXP FastCluster(SEXP x); void fastpattern(const umat &y, umat &pattern, uvec &group, unsigned categories=2); template string numStr(T x) { ostringstream nmbstr; nmbstr << x; string ss = nmbstr.str(); return ss; } #endif /* TOOLS_H */ mets/src/fastcox.cpp0000644000176200001440000014356613623061405014203 0ustar liggesusers// [[Rcpp::depends("RcppArmadillo")]] #include #include #include "twostage.h" //#include "fastcox.h" using namespace Rcpp; using namespace arma; RcppExport SEXP FastCoxPrep(SEXP EntrySEXP, SEXP ExitSEXP, SEXP StatusSEXP, SEXP XSEXP, SEXP IdSEXP, SEXP TruncationSEXP) { BEGIN_RCPP arma::vec Entry = Rcpp::as(EntrySEXP); arma::vec Exit = Rcpp::as(ExitSEXP); arma::Col Status= Rcpp::as >(StatusSEXP); arma::mat X = Rcpp::as(XSEXP); try { arma::Col Id = Rcpp::as >(IdSEXP); } catch(...) {} //bool haveId = Rcpp::as(haveIdSEXP); bool Truncation = Rcpp::as(TruncationSEXP); // vec Exit = Rcpp::as(exit); // ivec Status = Rcpp::as(status); // mat X = Rcpp::as(x); // bool haveId = (Rf_isNull)(id); // bool Truncation = !((Rf_isNull)(entry)); // bool Truncation = Entry.n_elem>0; // bool haveId = Id.n_elem>0; // unsigned p = X.n_cols; unsigned n = Exit.n_elem; if (Truncation) n *= 2; //Rcout << "n=" << X.n_rows << ", p=" << X.n_cols << std::endl; mat XX(n, X.n_cols*X.n_cols); // Calculate XX' at each time-point for (unsigned i=0; i Sign; if (Truncation) { // vec Entry = Rcpp::as(entry); Exit.insert_rows(0,Entry); X.insert_rows(0,X); Status.insert_rows(0,Status); Sign.reshape(n,1); Sign.fill(1); for (unsigned i=0; i<(n/2); i++) Sign(i) = -1; Status = Status%(1+Sign); } //Rcout << "Status=" << Status << std::endl; arma::uvec idx0 = sort_index(Status,"descend"); arma::uvec idx = stable_sort_index(Exit.elem(idx0),"ascend"); idx = idx0.elem(idx); //Rcout << "idx=" << idx << std::endl; if (Truncation) { Sign = Sign.elem(idx); } if (X.n_rows>0) { XX = XX.rows(idx); X = X.rows(idx); } Status = Status.elem(idx); arma::uvec jumps = find(Status>0); //Rprintf("jumps"); arma::Col newId; // if (haveId) { // // uvec Id = Rcpp::as(id); // if (Truncation) { // Id.insert_rows(0,Id); // } // newId = Id.elem(idx); // } return(Rcpp::wrap(Rcpp::List::create(Rcpp::Named("XX")=XX, Rcpp::Named("X")=X, Rcpp::Named("jumps")=jumps, Rcpp::Named("sign")=Sign, Rcpp::Named("ord")=idx, Rcpp::Named("time")=Exit, Rcpp::Named("id")=newId ))); END_RCPP } RcppExport SEXP FastCoxPrepStrata(SEXP EntrySEXP, SEXP ExitSEXP, SEXP StatusSEXP, SEXP XSEXP, SEXP IdSEXP, SEXP TruncationSEXP, SEXP strataSEXP, SEXP weightsSEXP, SEXP offsetsSEXP, SEXP ZSEXP, SEXP caseweightsSEXP ) {/*{{{*/ BEGIN_RCPP arma::vec Entry = Rcpp::as(EntrySEXP); arma::vec Exit = Rcpp::as(ExitSEXP); arma::Col Status= Rcpp::as >(StatusSEXP); arma::mat X = Rcpp::as(XSEXP); arma::mat Z = Rcpp::as(ZSEXP); arma::Col strata= Rcpp::as >(strataSEXP); arma::Col Id= Rcpp::as >(IdSEXP); // arma::uvec idx = Rcpp::as >(sortid); // try { // arma::Col Id = Rcpp::as >(IdSEXP); // } // catch(...) {} colvec weights = Rcpp::as(weightsSEXP); colvec offsets = Rcpp::as(offsetsSEXP); colvec caseweights = Rcpp::as(caseweightsSEXP); //bool haveId = Rcpp::as(haveIdSEXP); bool Truncation = Rcpp::as(TruncationSEXP); // vec Exit = Rcpp::as(exit); // ivec Status = Rcpp::as(status); // mat X = Rcpp::as(x); // bool haveId = (Rf_isNull)(id); // bool Truncation = !((Rf_isNull)(entry)); // bool Truncation = Entry.n_elem>0; // bool haveId = Id.n_elem>0; // unsigned p = X.n_cols; unsigned n = Exit.n_elem; if (Truncation) n *= 2; //Rcout << "n=" << X.n_rows << ", p=" << X.n_cols << std::endl; mat XX(n, X.n_cols*X.n_cols); // Calculate XX' at each time-point for (unsigned i=0; i Sign; Sign.reshape(n,1); Sign.fill(1); if (Truncation) { // vec Entry = Rcpp::as(entry); Exit.insert_rows(0,Entry); X.insert_rows(0,X); Z.insert_rows(0,Z); Status.insert_rows(0,Status); Id.insert_rows(0,Id); strata.insert_rows(0,strata); weights.insert_rows(0,weights); caseweights.insert_rows(0,caseweights); offsets.insert_rows(0,offsets); for (unsigned i=0; i<(n/2); i++) Sign(i) = -1; Status = Status%(1+Sign); } //Rcout << "Status=" << Status << std::endl; // also sorting after id to use multiple phregs together // ts 20/3-2018 arma::uvec idx00 = sort_index(Id,"ascend"); arma::uvec idx0 = stable_sort_index(Status.elem(idx00),"descend"); idx0 = idx00.elem(idx0); arma::uvec idx = stable_sort_index(Exit.elem(idx0),"ascend"); idx = idx0.elem(idx); // arma::uvec idx0 = stable_sort_index(Status.elem(idx00),"descend"); // arma::uvec idx0 = sort_index(Status,"descend"); // arma::uvec idx = stable_sort_index(Exit.elem(idx0),"ascend"); // idx = idx0.elem(idx); // arma::uvec idx00 = stable_sort_index(Id.elem(idx),"ascend"); // idx = idx00.elem(idx); //Rcout << "idx=" << idx << std::endl; if (Truncation) { Sign = Sign.elem(idx); } if (X.n_rows>0) { XX = XX.rows(idx); X = X.rows(idx); } if (Z.n_rows==X.n_rows) { Z = Z.rows(idx); } if ((ZX.n_rows==XX.n_rows) & (XX.n_rows>0)) { ZX = ZX.rows(idx); } Exit = Exit.elem(idx); weights = weights.elem(idx); caseweights = caseweights.elem(idx); offsets = offsets.elem(idx); Status = Status.elem(idx); Id = Id.elem(idx); strata = strata.elem(idx); arma::uvec jumps = find(Status>0); //Rprintf("jumps"); // arma::Col newId; // if (haveId) { // // uvec Id = Rcpp::as(id); // if (Truncation) { // Id.insert_rows(0,Id); // } // newId = Id.elem(idx); // } return(Rcpp::wrap(Rcpp::List::create(Rcpp::Named("XX")=XX, Rcpp::Named("X")=X, Rcpp::Named("jumps")=jumps, Rcpp::Named("sign")=Sign, Rcpp::Named("ord")=idx, Rcpp::Named("time")=Exit, Rcpp::Named("id")=Id, Rcpp::Named("weights")=weights, Rcpp::Named("caseweights")=caseweights, Rcpp::Named("offset")=offsets, Rcpp::Named("strata")=strata, Rcpp::Named("ZX")=ZX, Rcpp::Named("Z")=Z ))); END_RCPP }/*}}}*/ colvec whichi(IntegerVector a,int n, int j) { colvec res(n); for (int i=0; i(ia); unsigned n = a.n_rows; colvec res = a; double prev=0; for (unsigned i=0; i(ia); IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); unsigned n = a.n_rows; colvec tmpsum(nstrata); tmpsum.zeros(); for (unsigned i=0; i=0)) tmpsum(ss) += a(i); } List rres; rres["res"]=tmpsum; return(rres); } colvec sumstrata(colvec a,IntegerVector strata,int nstrata) { unsigned n = a.n_rows; colvec tmpsum(nstrata); tmpsum.zeros(); tmpsum.zeros(); for (unsigned i=0; i=0)) tmpsum(ss) += a(i); } return(tmpsum); } RcppExport SEXP cumsumstrataR(SEXP ia,SEXP istrata, SEXP instrata) { colvec a = Rcpp::as(ia); IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); unsigned n = a.n_rows; colvec tmpsum(nstrata); tmpsum.zeros(); colvec res = a; for (unsigned i=0; i=0)) { tmpsum(ss) += a(i); res(i) = tmpsum(ss); } } List rres; rres["res"]=res; return(rres); } RcppExport SEXP tailstrataR(SEXP in, SEXP istrata, SEXP instrata) { IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); int n = Rcpp::as(in); int nfound=0; colvec tmpsum(nstrata); tmpsum.zeros(); colvec foundss(nstrata); foundss.zeros(); colvec wheress(nstrata); foundss.zeros(); for (signed i=0; i=0)) { tmpsum(ss) += a(i); res(i) = tmpsum(ss); } } return(res); } colvec cumsumstrataPO(colvec w,colvec S0,IntegerVector strata,int nstrata,double propodds,colvec exb) { unsigned n = S0.n_rows; colvec tmpsum(nstrata); tmpsum.zeros(); colvec res = S0; colvec pow = S0; for (unsigned i=0; i=0)) { if (propodds>0) pow(i)=(1+propodds*exb(i)*tmpsum(ss)); tmpsum(ss) += pow(i)*w(i)/S0(i); res(i) = tmpsum(ss); } } return(pow); } RcppExport SEXP cumsumstrataPOR(SEXP iw,SEXP iS0,SEXP istrata,SEXP instrata,SEXP ipropodds,SEXP iexb) { colvec w = Rcpp::as(iw); colvec S0 = Rcpp::as(iS0); colvec exb = Rcpp::as(iexb); IntegerVector strata(istrata); int nstrata = Rcpp::as(instrata); double propodds = Rcpp::as(ipropodds); colvec pow= cumsumstrataPO(w,S0,strata,nstrata,propodds,exb); List rres; rres["pow"]=pow; return(rres); } mat DLambeta(colvec weights,colvec S0,mat E,mat Xi,IntegerVector strata,int nstrata,double propodds,colvec exb) { unsigned n = S0.n_rows; unsigned p = E.n_cols; colvec tmpsum(nstrata); tmpsum.zeros(); mat dLbetatminus(nstrata,p); dLbetatminus.zeros(); colvec res = S0; colvec pow = S0; mat dLbeta(n,p); dLbeta.zeros(); for (unsigned i=0; i0) pow(i)=(1+propodds*exb(i)*tmpsum(ss)); dLbeta.row(i) = dLbetatminus.row(ss)+weights(i)* ( (dLbetatminus.row(ss)*exb(i)+Xi.row(i)*(pow(i)-1))/S0(i)-E.row(i)*pow(i)/S0(i)); tmpsum(ss) += weights(i)*pow(i)/S0(i); res(i) = tmpsum(ss); dLbetatminus.row(ss) = dLbeta.row(i); } return(dLbeta); } RcppExport SEXP DLambetaR(SEXP iweights,SEXP iS0,SEXP iE,SEXP iXi,SEXP istrata,SEXP instrata,SEXP ipropodds,SEXP iexb) { colvec weights = Rcpp::as(iweights); colvec S0 = Rcpp::as(iS0); colvec exb = Rcpp::as(iexb); mat E = Rcpp::as(iE); mat Xi = Rcpp::as(iXi); IntegerVector strata(istrata); int nstrata = Rcpp::as(instrata); double propodds = Rcpp::as(ipropodds); mat dLam= DLambeta(weights,S0,E,Xi,strata,nstrata,propodds,exb); List rres; rres["res"]=dLam; return(rres); } colvec cumsumstrataAddGam(colvec a,IntegerVector strata,int nstrata, colvec exb,colvec etheta,cube thetades,cube rv,mat ags, uvec Jumps) { unsigned n = a.n_rows; colvec tmpsum(nstrata); tmpsum.zeros(); tmpsum.zeros(); colvec res = a; colvec pow = a; vec allvec(6); vec DthetaS(etheta.n_elem),DthetaDtS(etheta.n_elem); colvec exbs(2); for (unsigned i=0; i=0)) { tmpsum(ss) += pow(i)/a(i); res(i) = tmpsum(ss); } } return(pow); } RcppExport SEXP revcumsumstrataR(SEXP ia,SEXP istrata, SEXP instrata) { colvec a = Rcpp::as(ia); IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); unsigned n = a.n_rows; colvec tmpsum(nstrata); tmpsum.zeros(); colvec res = a; for (unsigned i=0; i=0)) { tmpsum(ss) += a(n-i-1); res(n-i-1) = tmpsum(ss); } } List rres; rres["res"]=res; return(rres); } RcppExport SEXP wherestrataR(SEXP ir,SEXP ia,SEXP istrata, SEXP instrata) { colvec a = Rcpp::as(ia); colvec r = Rcpp::as(ir); IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); unsigned n = a.n_rows; colvec tmpsum(nstrata); tmpsum.zeros(); colvec nsum(nstrata); nsum.zeros(); colvec maxv(nstrata); maxv.zeros(); colvec minv(nstrata); minv.zeros(); for (unsigned i=0; i maxv(ss)) | (nsum(ss)==0)) maxv(ss)=a(i); if ((a(i) < minv(ss)) | (nsum(ss)==0)) minv(ss)=a(i); if (irs>a(i)) tmpsum(ss)=nsum(ss); nsum(ss)+=1; } List rres; rres["where"]=tmpsum; rres["max"]=maxv; rres["min"]=minv; rres["nstrata"]=nsum; return(rres); } RcppExport SEXP maxminidR(SEXP ia,SEXP istrata, SEXP instrata) { colvec a = Rcpp::as(ia); IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); unsigned n = a.n_rows; colvec nsum(nstrata); nsum.zeros(); colvec maxv(nstrata); maxv.zeros(); colvec minv(nstrata); minv.zeros(); for (unsigned i=0; i maxv(ss)) | (nsum(ss)==0)) maxv(ss)=a(i); if ((a(i) < minv(ss)) | (nsum(ss)==0)) minv(ss)=a(i); nsum(ss)+=1; } List rres; rres["max"]=maxv; rres["min"]=minv; rres["nstrata"]=nsum; return(rres); } RcppExport SEXP riskstrataR(SEXP ia,SEXP istrata, SEXP instrata) { colvec a = Rcpp::as(ia); IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); unsigned n = a.n_rows; colvec tmpsum(nstrata); tmpsum.zeros(); // colvec res = a; mat res(n,nstrata); res.zeros(); for (unsigned i=0; i(ia); // IntegerVector intstrata(istrata); // int nstrata = Rcpp::as(instrata); // unsigned n = a.n_rows; // int nid = Rcpp::as(inid); // IntegerVector id(iid); // int ss,lid; // // mat tmpsuma(nstrata,nid); tmpsuma.zeros(); //// colvec res = a; // mat res(n,nid); res.zeros(); // for (unsigned i=0; i=0)) { tmpsum(ss) += a(n-i-1); res(n-i-1) = tmpsum(ss); } } return(res); }// colvec revcumsumstrata1(const colvec &a,const colvec &v1,const colvec &v2, IntegerVector strata,int nstrata) { return(revcumsumstrata(a%v1,strata,nstrata)/v2); } colvec revcumsumstratalag(const colvec &a,IntegerVector strata,int nstrata) { unsigned n = a.n_rows; colvec tmpsum(nstrata); tmpsum.zeros(); colvec res = a; for (unsigned i=0; i(ia); // mat b = Rcpp::as(ib); IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); unsigned n = a.n_rows; colvec tmpsum(nstrata); tmpsum.zeros(); colvec ressum = a; colvec lagressum = a; colvec ressqu = a; double cumsum=0; int first=0,ss; for (unsigned i=0; i0.1) & (i>=1)& (ss=0)) ressqu(i)=ressqu(i-1)+pow(a(i),2)+2*a(i)*tmpsum(ss); if ((ss=0)) { lagressum(i)=tmpsum(ss); tmpsum(ss) += a(i); cumsum+=a(i); if (first<0.1) ressqu(i) = pow(a(i),2); first=1; } ressum(i) = cumsum; } List rres; rres["sumsquare"]=ressqu; rres["sum"]=ressum; rres["lagsum"]=lagressum; return(rres); } RcppExport SEXP revcumsumstratasumR(SEXP ia,SEXP istrata, SEXP instrata) { colvec a = Rcpp::as(ia); IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); unsigned n = a.n_rows; colvec tmpsum(nstrata); tmpsum.zeros(); colvec tmpsqr(nstrata); tmpsqr.zeros(); colvec cumsum(nstrata); cumsum.zeros(); colvec ressum = a; colvec lagressum = a; colvec ressqu = a; colvec lagressqu(n); int ss; for (unsigned i=0; i(ia); colvec b = Rcpp::as(ib); // mat b = Rcpp::as(ib); IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); unsigned n = a.n_rows; colvec tmpsumrev(nstrata); tmpsumrev.zeros(); colvec ressqu = a; int ss; for (unsigned i=0; i=0)) tmpsumrev(ss) += b(n-i-1); } colvec tmpsum(nstrata); tmpsum.zeros(); colvec tmpsqr(nstrata); tmpsqr.zeros(); // colvec first(nstrata); first.zeros(); for (unsigned i=0; i=0))) { ressqu(i)=tmpsqr(ss)-a(i)*tmpsumrev(ss)+b(i)*tmpsum(ss)+a(i)*b(i); tmpsumrev(ss) -= b(i); tmpsum(ss) += a(i); tmpsqr(ss)=ressqu(i); } } List rres; rres["covs"]=ressqu; return(rres); } RcppExport SEXP cumsumidstratasumCovR(SEXP ia,SEXP ib,SEXP iid,SEXP inid,SEXP istrata, SEXP instrata) { colvec a = Rcpp::as(ia); colvec b = Rcpp::as(ib); // mat b = Rcpp::as(ib); IntegerVector id(iid); int nid = Rcpp::as(inid); IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); unsigned n = a.n_rows; int lid,ss; mat tmpsuma(nstrata,nid); tmpsuma.zeros(); mat tmpsumb(nstrata,nid); tmpsumb.zeros(); colvec tmpsqr(nstrata); tmpsqr.zeros(); // colvec ressqu = a; colvec ressumu = a; colvec ressuma = a; colvec ressumb = b; colvec ressqu = a; colvec cumsuma(nstrata); cumsuma.zeros(); colvec cumsumb(nstrata); cumsumb.zeros(); colvec first(nstrata); first.zeros(); for (unsigned i=0; i=0)) { ressqu(i)=tmpsqr(ss)+a(i)*b(i)+a(i)*tmpsumb(ss,lid)+b(i)*tmpsuma(ss,lid); tmpsuma(ss,lid) += a(i); tmpsumb(ss,lid) += b(i); cumsuma(ss) += a(i); cumsumb(ss) += b(i); ressuma(i) = cumsum(ss); ressumb(i) = cumsum(ss); tmpsqr(ss)=ressqu(i); } } List rres; rres["sumsquare"]=ressqu; rres["suma"]=ressuma; rres["sumb"]=ressumb; return(rres); } RcppExport SEXP cumsumidstratasumR(SEXP ia,SEXP iid,SEXP inid,SEXP istrata, SEXP instrata) { colvec a = Rcpp::as(ia); // mat b = Rcpp::as(ib); IntegerVector id(iid); int nid = Rcpp::as(inid); IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); unsigned n = a.n_rows; int lid,ss; mat tmpsum(nstrata,nid); tmpsum.zeros(); colvec tmpsqr(nstrata); tmpsqr.zeros(); // colvec ressqu = a; colvec ressumu = a; colvec ressum = a; colvec ressumid = a; colvec lagressumid = a; colvec lagressum = a; colvec ressqu = a; colvec cumsum(nstrata); cumsum.zeros(); colvec first(nstrata); first.zeros(); for (unsigned i=0; i(ia); // mat b = Rcpp::as(ib); IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); unsigned n = a.n_rows; a.print("a"); colvec tmpsum(nstrata); tmpsum.zeros(); colvec ressum = a; double sums=0; for (unsigned i=0; i(ia); // IntegerVector a = Rcpp::as(ia); // IntegerVector a(ia); // int n = a1.n_rows; int n = a.n_rows; IntegerVector id(iid); int nid = Rcpp::as(inid); IntegerVector strata(istrata); int nstrata = Rcpp::as(instrata); colvec res=a; colvec mean(n); mean.zeros(); colvec tot(n); tot.zeros(); for (int i=0; i0) mean=mean+i*res; tot=tot+res; } mean=mean/tot; List rres; rres["meanrisk"]=mean; rres["risk"]=tot; return(rres); } RcppExport SEXP revcumsumidstratasumR(SEXP ia,SEXP iid, SEXP inid, SEXP istrata, SEXP instrata) { colvec a = Rcpp::as(ia); // mat b = Rcpp::as(ib); IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); unsigned n = a.n_rows; IntegerVector id(iid); int nid = Rcpp::as(inid); int lid,ss; mat tmpsum(nstrata,nid); tmpsum.zeros(); colvec tmpsqr(nstrata); tmpsqr.zeros(); // colvec ressqu = a; colvec ressumu = a; colvec ressum = a; colvec ressumid = a; colvec lagressum(n); colvec ressqu = a; colvec lagressqu(n); // lagressqu.zeros colvec cumsum(nstrata); cumsum.zeros(); colvec first(nstrata); first.zeros(); for (unsigned i=0; i(ia); colvec b = Rcpp::as(ib); // mat b = Rcpp::as(ib); IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); unsigned n = a.n_rows; IntegerVector id(iid); int nid = Rcpp::as(inid); int lid,ss; mat tmpsuma(nstrata,nid); tmpsuma.zeros(); mat tmpsumb(nstrata,nid); tmpsumb.zeros(); colvec cumsuma(nstrata); cumsuma.zeros(); colvec cumsumb(nstrata); cumsumb.zeros(); colvec tmpsqr(nstrata); tmpsqr.zeros(); // colvec ressqu = a; colvec ressumu = a; colvec ressum = a; colvec lagressum(n); colvec ressqu = a; colvec lagressqu(n); // lagressqu.zeros colvec first(nstrata); first.zeros(); for (unsigned i=0; i=0)) { // if ((first(ss)>0.1)) { lagressqu(n-i-1)=tmpsqr(ss); // previous from lagressum(n-i-1)=cumsum(ss); // previous sum from ressqu(n-i-1)=tmpsqr(ss)+a(n-i-1)*b(n-i-1)+a(n-i-1)*tmpsumb(ss,lid)+b(n-i-1)*tmpsuma(ss,lid); // } tmpsuma(ss,lid) += a(n-i-1); tmpsumb(ss,lid) += b(n-i-1); // cumsuma(ss)+=a(n-i-1); // cumsumb(ss)+=b(n-i-1); // first // if (first(ss)<0.1) {ressqu(n-i-1)=a(n-i-1)*b(n-i-1); first(ss)=1; lagressqu(n-i-1)=0; lagressum(n-i-1)=0; } // ressqu(n-i-1) = sum(tmpsum%tmpsum); // tmpsum.print("pp"); // ressuma(n-i-1)=cumsum(ss); // ressumb(n-i-1)=cumsum(ss); tmpsqr(ss)=ressqu(n-i-1); } } List rres; rres["sumsquare"]=ressqu; rres["lagsumsquare"]=lagressqu; return(rres); } RcppExport SEXP covrfstrataR(SEXP ia,SEXP ib, SEXP iid,SEXP inid, SEXP istrata, SEXP instrata) { colvec a = Rcpp::as(ia); colvec b = Rcpp::as(ib); // mat b = Rcpp::as(ib); IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); unsigned n = a.n_rows; IntegerVector id(iid); int nid = Rcpp::as(inid); int lid,ss; mat tmpsumrev(nstrata,nid); tmpsumrev.zeros(); mat tmpsum(nstrata,nid); tmpsum.zeros(); colvec tmpcov(nstrata); tmpcov.zeros(); colvec ressum = a; colvec rescov = a; colvec cumsum(nstrata); cumsum.zeros(); colvec first(nstrata); first.zeros(); for (unsigned i=0; i(ia); colvec b = Rcpp::as(ib); colvec a2 = Rcpp::as(ia2); colvec b2 = Rcpp::as(ib2); // mat b = Rcpp::as(ib); IntegerVector intstrata(istrata); int nstrata = Rcpp::as(instrata); unsigned n = a.n_rows; IntegerVector id(iid); int nid = Rcpp::as(inid); int lid,ss; mat tmpsumrev(nstrata,nid); tmpsumrev.zeros(); mat tmpsumrev2(nstrata,nid); tmpsumrev2.zeros(); mat tmpsum(nstrata,nid); tmpsum.zeros(); mat tmpsum2(nstrata,nid); tmpsum2.zeros(); colvec tmpsqr(nstrata); tmpsqr.zeros(); // colvec ressqu = a; colvec ressumu = a; colvec ressum = a; colvec ressqu = a; colvec cumsum(nstrata); cumsum.zeros(); colvec first(nstrata); first.zeros(); for (unsigned i=0; i(betaSEXP); mat X = Rcpp::as(XSEXP); mat XX = Rcpp::as(XXSEXP); arma::uvec Jumps = Rcpp::as(JumpsSEXP); arma::Col Sign = Rcpp::as >(SignSEXP); // unsigned n = X.n_rows; unsigned p = X.n_cols; colvec Xb = X*beta; colvec eXb = exp(Xb); if (Sign.n_rows==eXb.n_rows) { // Truncation eXb = Sign%eXb; } colvec S0 = revcumsum(eXb); mat E(X.n_rows,p); // S1/S0(s) for (unsigned j=0; j(betaSEXP); mat X = Rcpp::as(XSEXP); mat XX = Rcpp::as(XXSEXP); mat ZX = Rcpp::as(ZXSEXP); arma::uvec Jumps = Rcpp::as(JumpsSEXP); arma::Col Sign = Rcpp::as >(SignSEXP); IntegerVector strata(strataSEXP); int nstrata = Rcpp::as(nstrataSEXP); // unsigned n = X.n_rows; unsigned p = X.n_cols; colvec weights = Rcpp::as(weightsSEXP); colvec offsets = Rcpp::as(offsetsSEXP); colvec caseweights = Rcpp::as(caseweightsSEXP); colvec Xb = X*beta+offsets; colvec eXb = exp(Xb)%weights; if (Sign.n_rows==eXb.n_rows) { // Truncation eXb = Sign%eXb; } colvec S0 = revcumsumstrata(eXb,strata,nstrata); mat E=revcumsumstrataMatCols(X,eXb,S0,strata,nstrata); E = E.rows(Jumps); mat E2(E.n_rows, E.n_cols*E.n_cols); // Calculate E' E at each time-point for (unsigned i=0; i(betaSEXP); mat X = Rcpp::as(XSEXP); mat XX = Rcpp::as(XXSEXP); mat ZX = Rcpp::as(ZXSEXP); arma::uvec Jumps = Rcpp::as(JumpsSEXP); arma::Col Sign = Rcpp::as >(SignSEXP); IntegerVector strata(strataSEXP); int nstrata = Rcpp::as(nstrataSEXP); double propodds = Rcpp::as(propoddsSEXP); // unsigned n = X.n_rows; unsigned p = X.n_cols; colvec weights = Rcpp::as(weightsSEXP); colvec offsets = Rcpp::as(offsetsSEXP); colvec Xb = X*beta+offsets; colvec eXbnow = exp(Xb); colvec eXb = exp(Xb)%weights; if (Sign.n_rows==eXb.n_rows) { // Truncation eXb = Sign%eXb; } colvec S0 = revcumsumstrata(eXb,strata,nstrata); mat E=revcumsumstrataMatCols(X,eXb,S0,strata,nstrata); E = E.rows(Jumps); mat E2(E.n_rows, E.n_cols*E.n_cols); // Calculate E' E at each time-point for (unsigned i=0; i(betaSEXP); mat X = Rcpp::as(XSEXP); mat XX = Rcpp::as(XXSEXP); mat ZX = Rcpp::as(ZXSEXP); arma::uvec Jumps = Rcpp::as(JumpsSEXP); arma::Col Sign = Rcpp::as >(SignSEXP); IntegerVector strata(strataSEXP); int nstrata = Rcpp::as(nstrataSEXP); // double propodds = Rcpp::as(propoddsSEXP); // unsigned n = X.n_rows; unsigned p = X.n_cols; colvec weights = Rcpp::as(weightsSEXP); colvec offsets = Rcpp::as(offsetsSEXP); // reading in matrices and cubes for AddGam cause is in strata vec theta = Rcpp::as(itheta); mat ags = Rcpp::as(iags); int varlink = Rcpp::as(ivarlink); // array for xjump covariates of jump subject, for all causes // NumericVector vxjump(ixjump); // IntegerVector arrayDims(idimxjump); // arma::cube xjump(vxjump.begin(), arrayDims[0], arrayDims[1], arrayDims[2], false); // array for xjump covariates of jump subject, for all causes NumericVector vecthetades(ithetades); IntegerVector arrayDims1(idimthetades); arma::cube thetades(vecthetades.begin(), arrayDims1[0], arrayDims1[1], arrayDims1[2], false); // array for xjump covariates of jump subject, for all causes NumericVector vrv(ijumprv); IntegerVector arrayDims2(idimjumprv); arma::cube rv(vrv.begin(), arrayDims2[0], arrayDims2[1], arrayDims2[2], false); // indeces of the causes relatd to the two jumps arma::umat JumpsCauses = Rcpp::as(iJumpsCauses); // arma::uvec ij1 = JumpsCauses.col(0); // arma::uvec ij2 = JumpsCauses.col(1); // vec etheta=theta; if (varlink==1) etheta=exp(theta); colvec Xb = X*beta+offsets; colvec eXb = exp(Xb)%weights; if (Sign.n_rows==eXb.n_rows) { // Truncation eXb = Sign%eXb; } colvec S0 = revcumsumstrata(eXb,strata,nstrata); mat E=revcumsumstrataMatCols(X,eXb,S0,strata,nstrata); // for (unsigned j=0; j(im); IntegerVector rows(irow); IntegerVector cols(icols); colvec xvec = Rcpp::as(ixvec); unsigned l = Rcpp::as(ilength); unsigned assign = Rcpp::as(iassign); vec res(l); vec where(l); List rres; int mn = m.n_rows; int mp = m.n_cols; for (unsigned i=0; i -1) & (rows(i)< mn)) * ((cols(i) > -1) & (cols(i)< mp)) ; if (assign==0) { for (unsigned i=0; i0) { res(i)=m(rows(i),cols(i)); } else res(i)=0; rres["mat"]=res; } else { for (unsigned i=0; i0) { m(rows(i),cols(i))=xvec(i); } rres["mat"]=m; } return(rres); } mat CubeVecC(mat XX, vec beta,int dim1) { unsigned p = beta.n_rows; unsigned n = XX.n_rows; mat XXbeta(n,dim1); for (unsigned j=0; j(betaSEXP); mat XX = Rcpp::as(XXSEXP); mat beta = Rcpp::as(betaSEXP); unsigned p = beta.n_cols; unsigned n = XX.n_rows; mat XXbeta(n,p); mat iXXbeta(n,p*p); for (unsigned j=0; j(XXSEXP); mat X = Rcpp::as(XSEXP); unsigned p = X.n_cols; unsigned n = XX.n_rows; mat XXX(n,p*p); for (unsigned j=0; j(iX); mat Z = Rcpp::as(iZ); mat res=vecmatmat(X,Z); return(Rcpp::List::create(Rcpp::Named("vXZ")=res)); END_RCPP } RcppExport SEXP OutCov(SEXP XSEXP, SEXP ZSEXP) { BEGIN_RCPP mat X = Rcpp::as(XSEXP); mat Z = Rcpp::as(ZSEXP); // unsigned px = X.n_cols; // unsigned pz = Z.n_cols; unsigned nx = X.n_rows; unsigned nz = Z.n_rows; mat XoZ(nx,nz); for (unsigned j=0; j(iU); mat dUt = Rcpp::as(idUt); arma::vec osup = Rcpp::as(iobssup); unsigned nsim = Rcpp::as(insim); unsigned p = U.n_cols; unsigned n = U.n_rows; vec pval(p); pval.zeros(); mat Uti(n,p); mat sup(nsim,p); mat simUti(n,50*p); GetRNGstate(); /* to use R random normals */ for (unsigned j=0; j=osup(k))) { pval(k)++; } if (j<50) { simUti.col(j*p+k)=Uthati.col(k); } } } pval=pval/nsim; PutRNGstate(); /* to use R random normals */ return(Rcpp::List::create(Rcpp::Named("supUsim")=sup, Rcpp::Named("simUt")=simUti, Rcpp::Named("pval")=pval)); END_RCPP } RcppExport SEXP PropTestCoxClust(SEXP iU, SEXP idUt, SEXP iwrr, SEXP iZ, SEXP iLam, SEXP iEdLam, SEXP insim, SEXP iobssup, SEXP inclust,SEXP iid, SEXP istrata,SEXP instrata, SEXP iJumps) { BEGIN_RCPP mat U = Rcpp::as(iU); mat dUt = Rcpp::as(idUt); arma::vec wrr = Rcpp::as(iwrr); arma::vec Lam = Rcpp::as(iLam); mat EdLam = Rcpp::as(iEdLam); mat Z = Rcpp::as(iZ); IntegerVector id(iid); arma::vec osup = Rcpp::as(iobssup); unsigned nsim = Rcpp::as(insim); unsigned nclust = Rcpp::as(inclust); unsigned p = U.n_cols; unsigned n = U.n_rows; IntegerVector strata(istrata); arma::uvec Jumps = Rcpp::as(iJumps); int nstrata = Rcpp::as(instrata); vec pval(p); pval.zeros(); mat Uti(n,p); mat E1(n,p); mat E2(n,p); mat sup(nsim,p); int nj=dUt.n_rows; mat simUti(nj,50*p); vec nr(n); GetRNGstate(); /* to use R random normals */ // vec vvv=revcumsumstratalag(wrr,strata,nstrata); // vvv.print("vvv"); for (unsigned j=0; j=osup(k))) { pval(k)++; } if (j<50) { simUti.col(j*p+k)=Uthati.col(k); } } } pval=pval/nsim; PutRNGstate(); /* to use R random normals */ return(Rcpp::List::create(Rcpp::Named("supUsim")=sup, Rcpp::Named("simUt")=simUti, Rcpp::Named("pval")=pval)); END_RCPP } RcppExport SEXP ModelMatrixTestCox(SEXP iU, SEXP idUt,SEXP ibetaiid, SEXP insim, SEXP iobssup) { BEGIN_RCPP mat U = Rcpp::as(iU); mat dUt = Rcpp::as(idUt); mat betaiid = Rcpp::as(ibetaiid); arma::vec osup = Rcpp::as(iobssup); unsigned nsim = Rcpp::as(insim); unsigned mp = U.n_cols; unsigned p = betaiid.n_cols; unsigned n = U.n_rows; vec pval(mp); pval.zeros(); // mat Uthati(n,mp); mat Uti(n,mp); mat betati(n,p); mat sup(nsim,mp); mat last(nsim,mp); mat simUti(n,50*mp); GetRNGstate(); /* to use R random normals */ colvec nr(Uti.n_rows); for (unsigned j=0;j=osup(k))) {pval(k)++;} if (j<50) { simUti.col(j*mp+k)=Uthati.col(k); } } } pval=pval/nsim; PutRNGstate(); /* to use R random normals */ return(Rcpp::List::create(Rcpp::Named("supUsim")=sup, Rcpp::Named("last")=last, Rcpp::Named("simUt")=simUti, Rcpp::Named("pval")=pval)); END_RCPP } //RcppExport SEXP simBandCumHazCox(SEXP iU, SEXP idUt,SEXP ibetaiid, SEXP insim, SEXP isecum) { //BEGIN_RCPP // mat U = Rcpp::as(iU); // mat dUt = Rcpp::as(idUt); // mat betaiid = Rcpp::as(ibetaiid); // arma::vec secum = Rcpp::as(isecum); // unsigned nsim = Rcpp::as(insim); // unsigned mp = U.n_cols; // unsigned p = betaiid.n_cols; // unsigned n = U.n_rows; // //// vec pval(mp); pval.zeros(); mat Uthati(n,mp); mat simUti(n,50*mp); // mat Uti(n,mp); // mat betati(n,p); // mat sup(nsim,mp); // mat simUti(n,50*mp); // // GetRNGstate(); /* to use R random normals */ // colvec nr(Uti.n_rows); // // for (unsigned j=0;j #include void F77_SUB(rndstart)(void) { GetRNGstate(); } void F77_SUB(rndend)(void) { PutRNGstate(); } double F77_SUB(unifrnd)(void) { return unif_rand(); } double F77_SUB(phid)(double *x){ return pnorm(*x, 0.0, 1.0, 1, 0); } double F77_SUB(studnt)(int *nu, double *x){ return pt(*x, *nu, 1, 0); } mets/src/Makevars.win0000644000176200001440000000050113623061405014275 0ustar liggesusers## This assumes that we can call Rscript to ask Rcpp about its locations ## Use the R_HOME indirection to support installations of multiple R version PKG_LIBS = $(shell "${R_HOME}/bin${R_ARCH_BIN}/Rscript.exe" -e "Rcpp:::LdFlags()") PKG_CPPFLAGS = -I../inst/include -I. PKG_LIBS += $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) mets/src/fastcox.h0000644000176200001440000000053713623061405013636 0ustar liggesusers#ifndef FASTCOX_H #define FASTCOX_H #include #include using namespace Rcpp; using namespace arma; RcppExport SEXP FastCoxPrep( SEXP entry, SEXP exit, SEXP status, SEXP X, SEXP id, SEXP haveid, SEXP truncation); RcppExport SEXP FastCoxPL( SEXP b, SEXP x, SEXP xx, SEXP sgn, SEXP jumps); #endif /* FASTCOX_H */ mets/src/binomial-twostage.cpp0000644000176200001440000011230413623061405016143 0ustar liggesusers#include #include #include #include #include #include #include "twostage.h" using namespace arma; using namespace Rcpp; double claytonoakesP(double theta,int status1,int status2,double cif1,double cif2,vec &dp,vec &ps,vec &dp00) { // {{{ double valr=1,x,y,z; double p00,p10,p01,p11; //double cifs=cif1+cif2; //double S=1+(cifs*(theta-1)); x=theta; y=cif1; z=cif2; valr= pow((1/pow(y,1/x) + 1/pow(z,1/x)) - 1,-x); dp(0)= (-((x*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x))) - log(-1 + pow(y,-1/x) + pow(z,-1/x)))/pow(-1 + pow(y,-1/x) + pow(z,-1/x),x); p11=valr; p10=cif1-p11; p01=cif2-p11; p00=1-cif1-cif2+p11; ps(0)=p00; ps(1)=p10; ps(2)=p01; ps(3)=p11; dp00(0)=dp(0); //printf(" %lf %lf %lf %lf %lf %lf %lf \n",theta,y,z,p11,p10,p01,p00); if (status1==1 && status2==1) { valr=p11; dp(0)= dp(0); } if (status1==1 && status2==0) { valr=p10; dp(0)=-dp(0); } if (status1==0 && status2==1) { valr=p01; dp(0)=-dp(0); } if (status1==0 && status2==0) { valr=p00; dp(0)= dp(0); } //printf(" %lf \n",valr); //if (status1==0 && status2==0) { // {{{ //valr= pow((1/pow(y,1/x) + 1/pow(z,1/x)) - 1,-x); //dp(0)= (-((x*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x))) - log(-1 + pow(y,-1/x) + pow(z,-1/x)))/pow(-1 + pow(y,-1/x) + pow(z,-1/x),x); //} // }}} // //if (status1==1 && status2==0) { // {{{ //valr=pow(y,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x); //dp(0)=(pow(y,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x)*log(y))/pow(x,2) + pow(y,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x)*(((-1 - x)*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x)) - log(-1 + pow(y,-1/x) + pow(z,-1/x))); //} // }}} // //if (status1==0 && status2==1) { // {{{ //valr=pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x); //dp(0)=(pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x)*log(z))/pow(x,2) + pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x)*(((-1 - x)*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x)) - log(-1 + pow(y,-1/x) + pow(z,-1/x))); //} // }}} // //if (status1==1 && status2==1) { // {{{ //valr= -(((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x))/x); //dp(0)=((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x))/pow(x,2) + (pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x))/x - ((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x)*log(y))/pow(x,3) - ((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x)*log(z))/pow(x,3) - ((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x)*(((-2 - x)*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x)) - log(-1 + pow(y,-1/x) + pow(z,-1/x))))/x; //} // }}} return(valr); } // }}} double placklikeP(double theta,int status1,int status2,double cif1,double cif2,vec &dp,vec &ps,vec &dp00) { // {{{ //double S,S2,a; //S=1+cifs*(theta-1); S2=4*cif1*cif2*theta*(theta-1); double x,y,z,valr=1,p11,p10,p01,p00; //double cifs=cif1+cif2; //a=(1+(theta-1)*(cifs)); x=theta; y=cif1; z=cif2; dp(0)=0; if (theta!=1) { p11=(1+(y+z)*(x-1)-sqrt(pow(1+(y+z)*(x-1),2)-4*x*(x-1)*y*z))/(2*(x-1)); dp(0)= (y + z - (-4*(-1 + x)*y*z - 4*x*y*z + 2*(y + z)*(1 + (-1 + x)*(y + z)))/(2.*sqrt(-4*(-1 + x)*x*y*z + pow(1 + ( -1 + x)*(y + z),2))))/(2.*(-1 + x)) - (1 + (-1 + x)*(y + z) - sqrt(-4*(-1 + x)*x*y*z + pow(1 + (-1 + x)*(y + z ),2)))/(2.*pow(-1 + x,2)); } else p11=cif1*cif2; p10=y-p11; p01=z-p11; p00=1-y-z+p11; ps(0)=p00; ps(1)=p10; ps(2)=p01; ps(3)=p11; dp00(0)=dp(0); if (status1==1 && status2==1) { valr=p11; dp(0)= dp(0); } if (status1==1 && status2==0) { valr=p10; dp(0)=-dp(0); } if (status1==0 && status2==1) { valr=p01; dp(0)=-dp(0); } if (status1==0 && status2==0) { valr=p00; dp(0)= dp(0); } return(valr); } // }}} //RcppExport SEXP claytonoakesPR(SEXP itheta,SEXP istatus1,SEXP istatus2,SEXP icif1,SEXP icif2) //{ // {{{ // colvec theta = Rcpp::as(itheta); // colvec cif1 = Rcpp::as(icif1); // colvec cif2 = Rcpp::as(icif2); // colvec status1 = Rcpp::as(iistatus1); // colvec status2 = Rcpp::as(iistatus2); // // colvec L=theta; // colvec dL=theta; // int n=cif1.size(); // //double valr=1,x,y,z; //double p00,p10,p01,p11; // ////double cifs=cif1+cif2; //double S=1+(cifs*(theta-1)); //x=theta; y=cif1; z=cif2; // //valr= pow((1/pow(y,1/x) + 1/pow(z,1/x)) - 1,-x); //dp(0)= (-((x*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x))) - log(-1 + pow(y,-1/x) + pow(z,-1/x)))/pow(-1 + pow(y,-1/x) + pow(z,-1/x),x); // //p11=valr; //p10=x-p11; //p01=y-p11; //p00=1-x-y+p11; // //if (status1==1 && status2==1) { valr=p11; dp(0)= dp(0); } //if (status1==1 && status2==0) { valr=p10; dp(0)=-dp(0); } //if (status1==0 && status2==1) { valr=p01; dp(0)=-dp(0); } //if (status1==0 && status2==0) { valr=p00; dp(0)= dp(0); } // //if (status1==0 && status2==0) { // {{{ //valr= pow((1/pow(y,1/x) + 1/pow(z,1/x)) - 1,-x); //dp(0)= (-((x*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x))) - log(-1 + pow(y,-1/x) + pow(z,-1/x)))/pow(-1 + pow(y,-1/x) + pow(z,-1/x),x); //} // }}} // //if (status1==1 && status2==0) { // {{{ //valr=pow(y,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x); //dp(0)=(pow(y,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x)*log(y))/pow(x,2) + pow(y,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x)*(((-1 - x)*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x)) - log(-1 + pow(y,-1/x) + pow(z,-1/x))); //} // }}} // //if (status1==0 && status2==1) { // {{{ //valr=pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x); //dp(0)=(pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x)*log(z))/pow(x,2) + pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x)*(((-1 - x)*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x)) - log(-1 + pow(y,-1/x) + pow(z,-1/x))); //} // }}} // //if (status1==1 && status2==1) { // {{{ //valr= -(((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x))/x); //dp(0)=((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x))/pow(x,2) + (pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x))/x - ((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x)*log(y))/pow(x,3) - ((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x)*log(z))/pow(x,3) - ((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x)*(((-2 - x)*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x)) - log(-1 + pow(y,-1/x) + pow(z,-1/x))))/x; //} // }}} // //return(valr); //} // }}} // //RcppExport SEXP placklikePR(SEXP itheta,SEXP istatus1,SEXP istatus2,SEXP icif1,SEXP icif2) //{ // {{{ ////double S,S2,a; ////S=1+cifs*(theta-1); S2=4*cif1*cif2*theta*(theta-1); //double x,y,z,valr=1,p11,p10,p01,p00; ////double cifs=cif1+cif2; ////a=(1+(theta-1)*(cifs)); //x=theta; y=cif1; z=cif2; // //dp(0)=0; // //if (theta!=1) { //p11=(1+(y+z)*(x-1)-sqrt(pow(1+(y+z)*(x-1),2)-4*x*(x-1)*y*z))/(2*(x-1)); //dp(0)= (y + z - (-4*(-1 + x)*y*z - 4*x*y*z + 2*(y + z)*(1 + (-1 + x)*(y + z)))/(2.*sqrt(-4*(-1 + x)*x*y*z + pow(1 + ( -1 + x)*(y + z),2))))/(2.*(-1 + x)) - (1 + (-1 + x)*(y + z) - sqrt(-4*(-1 + x)*x*y*z + pow(1 + (-1 + x)*(y + z ),2)))/(2.*pow(-1 + x,2)); //} else p11=cif1*cif2; // //p11=p11; //p10=y-p11; //p01=z-p11; //p00=1-y-z+p11; // //if (status1==1 && status2==1) { valr=p11; dp(0)= dp(0); } //if (status1==1 && status2==0) { valr=p10; dp(0)=-dp(0); } //if (status1==0 && status2==1) { valr=p01; dp(0)=-dp(0); } //if (status1==0 && status2==0) { valr=p00; dp(0)= dp(0); } // //return(valr); //} // }}} // double CclaytonoakesP(double theta,int status1,int status2,double cif1,double cif2,vec &dp) //{ // {{{ //double valr=1,x,y,z; //double p00,p10,p01,p11; // ////double cifs=cif1+cif2; //double S=1+(cifs*(theta-1)); //x=theta; y=cif1; z=cif2; // //valr= pow((1/pow(y,1/x) + 1/pow(z,1/x)) - 1,-x); //dp(0)= (-((x*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x))) - log(-1 + pow(y,-1/x) + pow(z,-1/x)))/pow(-1 + pow(y,-1/x) + pow(z,-1/x),x); // //p11=valr; //p10=x-p11; //p01=y-p11; //p00=1-x-y+p11; // //double epsilon=1E-20; //cx_double Ctheta,Cvalr,Cy,Cz; //Ctheta=cx_double(theta,epsilon); //Cy=cx_double(y,0); //Cz=cx_double(z,0); // //printf(" mig \n"); ////Cvalr= pow((1/pow(Cy,1/Ctheta) + 1/pow(Cz,1/Ctheta)) - 1,-Ctheta); //double dd=imag(Cvalr)/epsilon; // //printf("complex %lf ",dd); // //if (status1==1 && status2==1) { valr=p11; dp(0)= dp(0); } //if (status1==1 && status2==0) { valr=p10; dp(0)=-dp(0); } //if (status1==0 && status2==1) { valr=p01; dp(0)=-dp(0); } //if (status1==0 && status2==0) { valr=p00; dp(0)= dp(0); } // //if (status1==0 && status2==0) { // {{{ //valr= pow((1/pow(y,1/x) + 1/pow(z,1/x)) - 1,-x); //dp(0)= (-((x*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x))) - log(-1 + pow(y,-1/x) + pow(z,-1/x)))/pow(-1 + pow(y,-1/x) + pow(z,-1/x),x); //} // }}} // //if (status1==1 && status2==0) { // {{{ //valr=pow(y,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x); //dp(0)=(pow(y,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x)*log(y))/pow(x,2) + pow(y,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x)*(((-1 - x)*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x)) - log(-1 + pow(y,-1/x) + pow(z,-1/x))); //} // }}} // //if (status1==0 && status2==1) { // {{{ //valr=pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x); //dp(0)=(pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x)*log(z))/pow(x,2) + pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x)*(((-1 - x)*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x)) - log(-1 + pow(y,-1/x) + pow(z,-1/x))); //} // }}} // //if (status1==1 && status2==1) { // {{{ //valr= -(((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x))/x); //dp(0)=((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x))/pow(x,2) + (pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x))/x - ((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x)*log(y))/pow(x,3) - ((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x)*log(z))/pow(x,3) - ((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x)*(((-2 - x)*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x)) - log(-1 + pow(y,-1/x) + pow(z,-1/x))))/x; //} // }}} // //printf(" %lf \n",dp(0)); //return(valr); //} // }}} cx_double Cpij(cx_double x, cx_double y, cx_double z,int status1, int status2) { // {{{ cx_double p11,one,two,four; one=cx_double(1,0); two=cx_double(2,0); four=cx_double(4,0); //p11=(1+(y+z)*(x-1)-sqrt(exp(ln(1+(y+z)*(x-1))*2)-4*x*(x-1)*y*z))/(2*(x-1)); p11=(one+(y+z)*(x-one)-sqrt(pow((one+(y+z)*(x-one)),two)-four*x*(x-one)*y*z)); //p11=one+(y+z)*(x-one); p11=p11/(two*(x-one)); // calculates probs depending on status if (status1==1 && status2==0) p11=y-p11; if (status1==0 && status2==1) p11=z-p11; if (status1==0 && status2==0) p11=one-y-z+p11; return(p11); } // }}} double CplacklikeP(double theta,int status1,int status2,double cif1,double cif2,vec &dp) { // {{{ //double S,S2,a; //S=1+cifs*(theta-1); S2=4*cif1*cif2*theta*(theta-1); double x,y,z,valr=1,p11,p10,p01,p00; //double cifs=cif1+cif2; //a=(1+(theta-1)*(cifs)); x=theta; y=cif1; z=cif2; dp(0)=0; if (theta!=1) { p11=(1+(y+z)*(x-1)-sqrt(pow(1+(y+z)*(x-1),2)-4*x*(x-1)*y*z))/(2*(x-1)); dp(0)= (y + z - (-4*(-1 + x)*y*z - 4*x*y*z + 2*(y + z)*(1 + (-1 + x)*(y + z)))/(2.*sqrt(-4*(-1 + x)*x*y*z + pow(1 + ( -1 + x)*(y + z),2))))/(2.*(-1 + x)) - (1 + (-1 + x)*(y + z) - sqrt(-4*(-1 + x)*x*y*z + pow(1 + (-1 + x)*(y + z ),2)))/(2.*pow(-1 + x,2)); } else p11=cif1*cif2; ////det komplekse trick, derivative wrt y og zi, dvs D_1 P(y,z,theta) og D_2 P //cx_double CCp11,Ctheta,Cy,Cz; //Ctheta=cx_double(theta,0); //Cy=cx_double(y,1E-20); //Cz=(cx_double) z; //CCp11=Cpij(Ctheta,Cy,Cz,status1,status2); //dp(1)=imag(CCp11)/1E-20; //Cz=cx_double(z,1E-20); //Cy=(cx_double) y; //CCp11=Cpij(Ctheta,Cy,Cz,status1,status2); //dp(2)=imag(CCp11)/1E-20; //printf(" %lf ",imag(CCp11)/1E-20); p10=y-p11; p01=z-p11; p00=1-y-z+p11; if (status1==1 && status2==1) { valr=p11; dp(0)= dp(0); } if (status1==1 && status2==0) { valr=p10; dp(0)=-dp(0); } if (status1==0 && status2==1) { valr=p01; dp(0)=-dp(0); } if (status1==0 && status2==0) { valr=p00; dp(0)= dp(0); } //printf(" %lf \n",dp(0)); return(valr); } // }}} //double min(double a, double b) { if (ab) return(a); else return(b); } RcppExport SEXP twostageloglikebin( SEXP icause, SEXP ipmargsurv, SEXP itheta, SEXP iXtheta, SEXP iDXtheta, SEXP idimDX, SEXP ithetades, SEXP icluster,SEXP iclustsize,SEXP iclusterindex, SEXP ivarlink, SEXP iiid, SEXP iweights, SEXP isilent, SEXP idepmodel, // SEXP ientryage, SEXP itrunkp , SEXP istrata, SEXP isecluster, SEXP iantiid , SEXP irvdes, SEXP iags, SEXP ibetaiid, SEXP ipairascertained, SEXP itwostage ) // {{{ { try { // {{{ setting matrices and vectors, and exporting to armadillo matrices mat thetades = Rcpp::as(ithetades); mat clusterindex = Rcpp::as(iclusterindex); colvec theta = Rcpp::as(itheta); mat ags= Rcpp::as(iags); int pt=theta.n_rows; colvec clustsize = Rcpp::as(iclustsize); int antclust = clusterindex.n_rows; colvec cause = Rcpp::as(icause); colvec pmargsurv = Rcpp::as(ipmargsurv); colvec cluster = Rcpp::as(icluster); colvec weights = Rcpp::as(iweights); // colvec entryage = Rcpp::as(ientryage); colvec trunkp = Rcpp::as(itrunkp); colvec secluster = Rcpp::as(isecluster); mat rvdes= Rcpp::as(irvdes); int depmodel= Rcpp::as(idepmodel); int twostage= Rcpp::as(itwostage); int pairascertained = Rcpp::as(ipairascertained); // array for derivative of flexible design NumericVector DXthetavec(iDXtheta); IntegerVector arrayDims(idimDX); arma::cube DXtheta(DXthetavec.begin(), arrayDims[0], arrayDims[1], arrayDims[2], false); IntegerVector strata(istrata); int varlink= Rcpp::as(ivarlink); int silent = Rcpp::as(isilent); int iid= Rcpp::as(iiid); int antiid = Rcpp::as(iantiid); double loglikecont=0; mat Xtheta = Rcpp::as(iXtheta); int udtest=0; if (udtest==1) { // {{{ // Rprintf(" %d %d %d %d %d %d %d \n",samecens,inverse,semi,semi2,flexfunc,stabcens,silent); // Rprintf(" %d %d %d %d %d %d %d \n",cifmodel,CA1,CA2,sym,depmodel,estimator,iid); // est.print("est"); // est2.print("est2"); // z.print("z"); // zsem.print("zsemi"); // z2.print("z2"); thetades.print("theta.des"); clusterindex.print("clusterindex"); // rvdes.print("rvdes"); theta.print("theta"); Xtheta.print("Xtheta"); // y.print("y-times"); clustsize.print("clustsize"); pmargsurv.print("margsurv"); cause.print("cause"); cluster.print("cluster"); // Zgamma.print("zgam"); // Z2gamma2.print("zgam2"); // KMtimes.print("KMtimes"); // KMc.print("KMc"); weights.print("weights"); // entryage.print("entryage"); // cif1entry.print("cif1entry"); // cif2entry.print("cif2entry"); trunkp.print("trunkp"); } else if (udtest==2) { // Rprintf(" %d %d %d %d %d %d %d \n",samecens,inverse,semi,semi2,flexfunc,stabcens,silent); // Rprintf(" %d %d %d %d %d %d %d \n",cifmodel,CA1,CA2,sym,depmodel,estimator,iid); // Rprintf("est %lf \n",mean(mean(est))); // Rprintf("est2 %lf \n",mean(mean(est2))); // Rprintf("z %lf \n",mean(mean(z))); // Rprintf("zsem %lf \n",mean(mean(zsem))); // Rprintf("z2 %lf \n",mean(mean(z2))); mat mt=mean(thetades); mt.print("meancol thetades"); // Rprintf("theatdes %lf \n",mean(mean(thetades))); Rprintf("ci %lf \n",mean(mean(clusterindex))); // Rprintf("rvdes %lf \n",mean(mean(rvdes))); Rprintf("theta %lf \n",mean(theta)); Rprintf("Xtheta %lf \n",mean(mean(Xtheta))); // Rprintf("y %lf \n",mean(y)); Rprintf("ci %lf \n",mean(clustsize)); // Rprintf("times %lf \n",mean(times)); Rprintf("cause %lf \n",mean(cause)); Rprintf("cluster %lf \n",mean(cluster)); // Rprintf("Zgamma %lf \n",mean(Zgamma)); // Rprintf("Z2gamma2 %lf \n",mean(Z2gamma2)); // Rprintf("KMtimes %lf \n",mean(KMtimes)); // Rprintf("KMc %lf \n",mean(KMc)); Rprintf("weights %lf \n",mean(weights)); // Rprintf("entry %lf \n",mean(entryage)); // Rprintf("cif1entry %lf \n",mean(cif1entry)); // Rprintf("cif2entry %lf \n",mean(cif2entry)); Rprintf("trunkp %lf \n",mean(trunkp)); } // }}} int ci,ck,i,j,c,s=0,k,v,c1; double ll=1,llt=1,Li,Lk,diff=0; //double sdj=0; // double Lit=1,Lkt=1,llt=1; double deppar=1,ssf=0,thetak=0; // double plack(); vec dplack(pt); dplack.fill(pt); vec dp00(pt); vec ps(8); vec ckij(4),dckij(4),ckijvv(4),dckijvv(4),ckijtv(4),dckijtv(4),ckijvt(4),dckijvt(4); i=silent+1; mat betaiid= Rcpp::as(ibetaiid); int dimbeta=betaiid.n_cols; // printf("%d %d \n",pt,dimbeta); mat DbetaDtheta(pt,dimbeta); vec vDbetaDtheta(2*pt); DbetaDtheta.fill(0); vec Du1(pt),Du2(pt); colvec p11tvec(antclust); // p11tvec=0; // Rprintf(" %d \n",pt); int scoredim; if (twostage==1) scoredim=pt; else scoredim=pt+dimbeta; // printf("========= %d %d \n",pt,scoredim); colvec Utheta(scoredim); colvec vthetascore(scoredim); colvec pthetavec(scoredim); vec vtheta2(scoredim); mat DUtheta(scoredim,scoredim); DUtheta.fill(0); Utheta.fill(0); mat thetiid(antiid,scoredim); colvec loglikeiid(antiid); if (iid==1) { thetiid.fill(0); loglikeiid.fill(0); } int nr=rvdes.n_cols; // if (depmodel==3) nr=arrayDD[2]; vec rv2(nr),rv1(nr); vec etheta=theta; // if (!Utheta.is_finite()) { Rprintf(" NA's i def U\n"); Utheta.print("U"); } // if (!DUtheta.is_finite()) { Rprintf(" NA's i def DU\n"); DUtheta.print("DU"); } // }}} // double claytonoakesbinRVC(); colvec likepairs(antclust); for (j=0;j=2) { R_CheckUserInterrupt(); diff=0; //sdj=0; for (c=0;c(ithetades); IntegerVector nrvs(inrvs); mat clusterindex = Rcpp::as(iclusterindex); colvec theta = Rcpp::as(itheta); mat ags= Rcpp::as(iags); int pt=theta.n_rows; colvec clustsize = Rcpp::as(iclustsize); // this is number of pairs (rather than clusters) int antclust = clusterindex.n_rows; colvec cause = Rcpp::as(icause); colvec pmargsurv = Rcpp::as(ipmargsurv); colvec cluster = Rcpp::as(icluster); colvec weights = Rcpp::as(iweights); // colvec entryage = Rcpp::as(ientryage); colvec trunkp = Rcpp::as(itrunkp); colvec secluster = Rcpp::as(isecluster); // mat rvdes= Rcpp::as(irvdes); int depmodel= Rcpp::as(idepmodel); IntegerVector strata(istrata); // uvec cause = Rcpp::as(icause); uvec pairascertained = Rcpp::as(ipairascertained); uvec casecontrol = Rcpp::as(icasecontrol); // array for derivative of flexible design NumericVector DXthetavec(iDXtheta); IntegerVector arrayDims(idimDX); arma::cube DXtheta(DXthetavec.begin(), arrayDims[0], arrayDims[1], arrayDims[2], false); // mat thetades = Rcpp::as(ithetades); // array for parameter restrictions (one for each pair) pairs * (ant random effects)* (ant par) NumericVector thetadesvec(ithetades); IntegerVector arrayDims1(idimthetades); IntegerVector arrayDD(3); //printf(" mig thetades 222222\n"); if (depmodel==3) { arrayDD[0]=arrayDims1[0]; arrayDD[1]=arrayDims1[1]; arrayDD[2]=arrayDims1[2]; } else { arrayDD[0]=1; arrayDD[1]=1; arrayDD[2]=1; } arma::cube thetadesi(thetadesvec.begin(), arrayDD[0], arrayDD[1], arrayDD[2], false); //printf(" mig cube thetades 222222\n"); mat thetades=mat(thetadesvec.begin(),arrayDims1[0],arrayDims1[1]*arrayDD[2],false); // array for pairwise random effects (two vectors for each pair) pairs * 2* (ant random effects) NumericVector rvdesvec(irvdes); IntegerVector arrayDims2(idimrvdes); if (depmodel==3) { arrayDD[0]=arrayDims2[0]; arrayDD[1]=arrayDims2[1]; arrayDD[2]=arrayDims2[2]; } else { arrayDD[0]=1; arrayDD[1]=1; arrayDD[2]=1; } // printf(" %d %d %d \n",arrayDD[0], arrayDD[1], arrayDD[2]); arma::cube rvdesC(rvdesvec.begin(), arrayDD[0], arrayDD[1], arrayDD[2], false); mat rvdes=mat(rvdesvec.begin(),arrayDims2[0],arrayDims2[1]*arrayDD[2],false); // mat rvdes= Rcpp::as(irvdes); int varlink= Rcpp::as(ivarlink); int silent = Rcpp::as(isilent); int iid= Rcpp::as(iiid); int antiid = Rcpp::as(iantiid); double loglikecont=0; mat Xtheta = Rcpp::as(iXtheta); int twostage= Rcpp::as(itwostage); int udtest=0; if (udtest==1) { // {{{ // Rprintf(" %d %d %d %d %d %d %d \n",samecens,inverse,semi,semi2,flexfunc,stabcens,silent); // Rprintf(" %d %d %d %d %d %d %d \n",cifmodel,CA1,CA2,sym,depmodel,estimator,iid); // est.print("est"); // est2.print("est2"); // z.print("z"); // zsem.print("zsemi"); // z2.print("z2"); thetades.print("theta.des"); clusterindex.print("clusterindex"); // rvdes.print("rvdes"); theta.print("theta"); Xtheta.print("Xtheta"); // y.print("y-times"); clustsize.print("clustsize"); pmargsurv.print("margsurv"); cause.print("cause"); cluster.print("cluster"); // Zgamma.print("zgam"); // Z2gamma2.print("zgam2"); // KMtimes.print("KMtimes"); // KMc.print("KMc"); weights.print("weights"); // entryage.print("entryage"); // cif1entry.print("cif1entry"); // cif2entry.print("cif2entry"); trunkp.print("trunkp"); } else if (udtest==2) { // Rprintf(" %d %d %d %d %d %d %d \n",samecens,inverse,semi,semi2,flexfunc,stabcens,silent); // Rprintf(" %d %d %d %d %d %d %d \n",cifmodel,CA1,CA2,sym,depmodel,estimator,iid); // Rprintf("est %lf \n",mean(mean(est))); // Rprintf("est2 %lf \n",mean(mean(est2))); // Rprintf("z %lf \n",mean(mean(z))); // Rprintf("zsem %lf \n",mean(mean(zsem))); // Rprintf("z2 %lf \n",mean(mean(z2))); mat mt=mean(thetades); mt.print("meancol thetades"); // Rprintf("theatdes %lf \n",mean(mean(thetades))); Rprintf("ci %lf \n",mean(mean(clusterindex))); // Rprintf("rvdes %lf \n",mean(mean(rvdes))); Rprintf("theta %lf \n",mean(theta)); Rprintf("Xtheta %lf \n",mean(mean(Xtheta))); // Rprintf("y %lf \n",mean(y)); Rprintf("ci %lf \n",mean(clustsize)); // Rprintf("times %lf \n",mean(times)); Rprintf("cause %lf \n",mean(cause)); Rprintf("cluster %lf \n",mean(cluster)); // Rprintf("Zgamma %lf \n",mean(Zgamma)); // Rprintf("Z2gamma2 %lf \n",mean(Z2gamma2)); // Rprintf("KMtimes %lf \n",mean(KMtimes)); // Rprintf("KMc %lf \n",mean(KMc)); Rprintf("weights %lf \n",mean(weights)); // Rprintf("entry %lf \n",mean(entryage)); // Rprintf("cif1entry %lf \n",mean(cif1entry)); // Rprintf("cif2entry %lf \n",mean(cif2entry)); Rprintf("trunkp %lf \n",mean(trunkp)); } // }}} int sss=1,ci,ck,i,j,s=0,k,c1; double llt=1,ll=1,Li,Lk,diff=0; double deppar=1,ssf=0,thetak=0; vec dplack(pt); dplack.fill(0); vec dp00(pt); dp00.fill(0); vec ps(8); ps.fill(0); vec ckij(4),dckij(4),ckijvv(4),dckijvv(4),ckijtv(4),dckijtv(4),ckijvt(4),dckijvt(4); i=silent+1; colvec p11tvec(antclust); // p11tvec=0; // Rprintf(" %d \n",pt); int scoredim; mat betaiid= Rcpp::as(ibetaiid); int dimbeta=betaiid.n_cols; if (twostage==1) scoredim=pt; else scoredim=pt+dimbeta; colvec Utheta(scoredim); colvec vthetascore(scoredim); colvec pthetavec(scoredim); vec vtheta2(scoredim); mat DUtheta(scoredim,scoredim); DUtheta.fill(0); Utheta.fill(0); mat thetiid(antiid,scoredim); colvec loglikeiid(antiid); if (iid==1) { thetiid.fill(0); loglikeiid.fill(0); } int nr=1; if (depmodel==3) nr=arrayDD[2]; vec rv2(nr),rv1(nr); mat DbetaDtheta(pt,dimbeta); vec vDbetaDtheta(2*pt); DbetaDtheta.fill(0); vec Du1(pt),Du2(pt); vec etheta=theta; // if (!Utheta.is_finite()) { Rprintf(" NA's i def U\n"); Utheta.print("U"); } // if (!DUtheta.is_finite()) { Rprintf(" NA's i def DU\n"); DUtheta.print("DU"); } // }}} colvec likepairs(antclust); // double claytonoakesbinRVC(); // Rprintf("--------%d \n",antclust); for (j=0;j #include #include #include "twostage.h" using namespace arma; RcppExport SEXP Bhat(SEXP ds, SEXP Xs, SEXP theta, SEXP id, SEXP ididx, SEXP idsize) { // {{{ try { uvec event = Rcpp::as(ds); mat X = Rcpp::as(Xs); mat Xc = zeros(X.n_cols,X.n_cols); double thetahat = Rcpp::as(theta); unsigned stop,start = X.n_rows; uvec eventpos = find(event==1); mat dB = zeros(eventpos.n_elem,X.n_cols); uvec cluster = Rcpp::as(id); uvec clustersize, clustpos; umat clusterindex; bool doclust = (Rf_isNull)(idsize); if (!doclust) { clustersize = Rcpp::as(idsize); clusterindex = Rcpp::as(ididx); } // Obtain usual estimates of increments, dB, of the // cumulative time-varying effects in Aalens Additive Model for (unsigned ij=0; ij::from(clusterindex.submat(i,0,i,csize-1)); } uvec posL = find(clustpos=ij); // later/current events within cluster unsigned Ni = 0; // Number of events in cluster before current event,time t- double Hi = 0 ; // Sum of cum.haz. within cluster up to time t- if (posL.n_elem>0) { Ni = sum(event.elem(clustpos.elem(posL))); Hi = sum(Hij.elem(clustpos.elem(posL))); } uvec pos; if (posR.n_elem>0 && k>0) { pos = clustpos.elem(posR); mat Xi = X.rows(pos); Hij.elem(pos) = Xi*trans(B2.row(k-1)); Hi += sum(Hij.elem(pos)); } double psi = (1/thetahat+Ni)/(1/thetahat+fmax(0,Hi)); B2.row(k) = dB.row(k)/psi; if (k>0) { B2.row(k) += B2.row(k-1); } } return(Rcpp::List::create(Rcpp::Named("dB")=dB, //Increments of marg. aalen Rcpp::Named("B2")=B2 // Cum.coef of frailty aalen )); } catch( std::exception &ex ) { forward_exception_to_r( ex ); } catch(...) { ::Rf_error( "c++ exception (unknown reason)" ); } return R_NilValue; // -Wall } // }}} RcppExport SEXP Uhat(SEXP ds, SEXP H, SEXP theta, SEXP id, SEXP idsize) { try { // {{{ uvec event = Rcpp::as(ds); vec Hij = Rcpp::as(H); double thetahat = Rcpp::as(theta); umat cluster = Rcpp::as(id); uvec clustersize, ucluster, clustpos; unsigned nclust; bool doclust = (Rf_isNull)(idsize); //bool doclust = (cluster.n_cols==1); if (doclust) { ucluster = unique(cluster); nclust = ucluster.n_elem; } else { clustersize = Rcpp::as(idsize); nclust = cluster.n_rows; } vec res(nclust); for (unsigned i=0; i::from(cluster.submat(i,0,i,csize-1)); //cluster(span(i,i),span(0,csize-1)); } double Ni = sum(event.elem(clustpos)); double Hi = sum(Hij.elem(clustpos)); double thetaH = thetahat*Hi+1; double R = (log(thetaH)/thetahat + (Ni-Hi)/(thetaH)); for (unsigned h=0; h(imat); NumericVector vDBhat(iDBhat); IntegerVector arrayDims(idim); arma::cube DBhat(vDBhat.begin(), arrayDims[0], arrayDims[1], arrayDims[2], false); mat X(arrayDims[2],arrayDims[0]); for (int k=0; k(idBaalen); uvec cause = Rcpp::as(icause); vec theta = Rcpp::as(itheta); mat ags = Rcpp::as(iags); int varlink = Rcpp::as(ivarlink); int it = Rcpp::as(iit); int recursive = Rcpp::as(irecursive); mat Bit = Rcpp::as(iBit); if (recursive==1) it=1; // array for xjump covariates of jump subject, for all causes NumericVector vxjump(ixjump); IntegerVector arrayDims(idimxjump); arma::cube xjump(vxjump.begin(), arrayDims[0], arrayDims[1], arrayDims[2], false); // array for xjump covariates of jump subject, for all causes NumericVector vecthetades(ithetades); IntegerVector arrayDims1(idimthetades); arma::cube thetades(vecthetades.begin(), arrayDims1[0], arrayDims1[1], arrayDims1[2], false); // array for xjump covariates of jump subject, for all causes NumericVector vrv(ijumprv); IntegerVector arrayDims2(idimjumprv); arma::cube rv(vrv.begin(), arrayDims2[0], arrayDims2[1], arrayDims2[2], false); // }}} // double nt = timer.toc(); // printf("timer-ind %lf \n",nt); vec casev(cause.n_elem); vec etheta=theta; if (varlink==1) etheta=exp(theta); // xjump for each jump contains matrix of covariates such that vec cumhaz1= xjump.slice(s) * Bhat mat Bhat(dBaalen.n_rows, dBaalen.n_cols); // mat Bhatmarg(dBaalen.n_rows, dBaalen.n_cols); // cube DthetaBhat(theta.n_elem, dBaalen.n_cols,dBaalen.n_rows); // vec dBB(theta.n_elem); // Bhat.fill(0); // initialize // vec DthetaS(theta.n_elem),DthetaDtS(theta.n_elem),DthetaW(theta.n_elem); vec allvec(6); int ncr=rv.n_rows; vec cumhaz(ncr); cumhaz.fill(0); vec Dcumhaz1(ncr); // vec cumhaz2(ncr); cumhaz2.fill(0); double caseweight=1,ll; // mat rv2=0*rv.slice(0); mat rv1=rv.slice(0); // rv1.print("rv1"); // cumhaz1.print("ch1"); // ags.print("ags"); // wall_clock timer; // timer.tic(); for (int i=0; i0) { Bhat.row(k) += Bhat.row(k-1); } // if (k>0) { DthetaBhat.slice(k)+= DthetaBhat.slice(k-1)+ // (dBB * dBaalen.row(k)); // } // mat xj=xjump.slice(k); // xj.print("xj"); // vec bb=trans(Bhat.row(k)); // bb.print("bb"); // cumulative hazard at time t- for all causes if (recursive==1) cumhaz=xjump.slice(k) * trans(Bhat.row(k)); // update Bit Bit.row(k)=Bhat.row(k); // mat pp=DthetaBhat.slice(k); // pp.print("pp"); Dcumhaz1.print("Dcumhaz1"); } // }}} } // double nt2 = timer.toc(); // printf("Bhat-profile timer-loop %lf \n",nt2); return(Rcpp::List::create(Rcpp::Named("B")=Bhat, Rcpp::Named("caseweights")=casev) // Rcpp::Named("DthetaBhat")=-1*DthetaBhat) ); } catch( std::exception &ex ) { forward_exception_to_r( ex ); } catch(...) { ::Rf_error( "c++ exception (unknown reason)" ); } return R_NilValue; // -Wall } // }}} // marginal hazard estimation via iterative estimator // pairs where we condition on second subjects // ascertainment correction is equivalent to case-control sampling // (except for delayed entry) RcppExport SEXP BhatAddGamCC(SEXP itwostage,SEXP idBaalen,SEXP icause, SEXP idimxjump,SEXP ixjump, // cube SEXP itheta, SEXP idimthetades,SEXP ithetades, // cube SEXP iags, SEXP ivarlink, SEXP idimjumprv,SEXP ijumprv, SEXP inrvs, SEXP iit, SEXP iBit, SEXP iBcaseit, SEXP icausecase) // cube { // {{{ try { // wall_clock timer; // timer.tic(); // {{{ reading in matrices and cubes int twostage = Rcpp::as(itwostage); mat dBaalen = Rcpp::as(idBaalen); uvec cause = Rcpp::as(icause); vec theta = Rcpp::as(itheta); mat ags = Rcpp::as(iags); //int varlink = Rcpp::as(ivarlink); uvec nrvs = Rcpp::as(inrvs); int it = Rcpp::as(iit); mat Bit = Rcpp::as(iBit); mat Bcaseit = Rcpp::as(iBcaseit); uvec causecase = Rcpp::as(icausecase); // if it>=1 then uses iterative estimator rather than recursive // for baseline, case/proband is handled via iterative int recursive=1;int ascertainment=1; if (twostage==-2) { recursive=1; ascertainment=1;it=1;} // not two stage model if (twostage==-1) { recursive=0; ascertainment=0; } // not two stage model if (twostage==0) { recursive=1; ascertainment=0;it=1;} // not two stage model if (twostage==1) { recursive=1; ascertainment=0;it=1;} // two-stage if (twostage==2) { recursive=0; ascertainment=0; } // two-stage if (twostage==3) { recursive=1; ascertainment=1;it=1;} // two-stage it=1; // xjump for each jump contains matrix of covariates such that vec cumhaz1= xjump.slice(s) * Bhat // array for xjump covariates of jump subject, for all causes NumericVector vxjump(ixjump); IntegerVector arrayDims(idimxjump); arma::cube xjump(vxjump.begin(), arrayDims[0], arrayDims[1], arrayDims[2], false); // array for xjump covariates of jump subject, for all causes NumericVector vecthetades(ithetades); IntegerVector arrayDims1(idimthetades); arma::cube thetades(vecthetades.begin(), arrayDims1[0], arrayDims1[1], arrayDims1[2], false); // array for xjump covariates of jump subject, for all causes NumericVector vrv(ijumprv); IntegerVector arrayDims2(idimjumprv); arma::cube rv(vrv.begin(), arrayDims2[0], arrayDims2[1], arrayDims2[2], false); // }}} // double nt = timer.toc(); printf("timer-ind %lf \n",nt); vec casev(cause.n_elem); vec etheta=theta; // if (varlink==1) etheta=exp(theta); mat Bhat(dBaalen.n_rows, dBaalen.n_cols); // cube DthetaBhat(theta.n_elem, dBaalen.n_cols,dBaalen.n_rows); // vec dBB(theta.n_elem); // Bhat.fill(0); // initialize vec DthetaS(theta.n_elem); // ,DthetaDtS(theta.n_elem),DthetaW(theta.n_elem); vec allvec(6), allvect(6); int ncr=rv.n_rows/2; // printf(" %d \n",ncr); vec cumhaz(ncr); cumhaz.fill(0); vec cumhazt(ncr); cumhazt.fill(0); // vec Dcumhaz1(ncr); // vec cumhaz2(ncr); cumhaz2.fill(0); double s1=1,s2=1,caseweight=1,ll=1; double llt=1; //s1t=1, // mat rv2=0*rv.slice(0); // mat rv1=rv.slice(0); // rv1.print("rv1"); cumhaz1.print("ch1"); ags.print("ags"); // wall_clock timer; // timer.tic(); mat rrv1,rrv2; vec rv1,rv2; for (int i=0; i0)) cumhaz=xjump.slice(k)*trans(Bit.row(k)); cumhazt=xjump.slice(k)*trans(Bit.row(k)); //int lnrv= nrvs(k)-1; // number of random effects for this cluster mat rvm=rv.slice(k); int nnn=rvm.n_rows; // rvm.print("rvm"); // first half of rows for person1 and second half for subject 2 // nn number of competing risks if (twostage<=0) { rrv1= rvm.rows(0,nnn/2-1); rrv2= rvm.rows(nnn/2,nnn-1); } else { rv1= trans(rvm.row(0)); rv2= trans(rvm.row(1)); // rv1.print("rv1"); rv2.print("rv2"); // rv1.print("rv1"); thetadesv.print("thetades"); } mat thetadesv=thetades.slice(k); if (twostage<=0) { ll=survivalRVC2all(etheta,thetadesv,ags,cause(k),causecase(k),cumhaz,cumhazcase,rrv1,rrv2,DthetaS,allvec); if (ascertainment==0) caseweight=allvec(4)/(ll); if (ascertainment==1) { // s1t=exp(-cumhazt(0)); llt=survivalRVC2all(etheta,thetadesv,ags,0,causecase(k),cumhaz,cumhazcase,rrv1,rrv2,DthetaS,allvect); caseweight=(allvec(4)+llt)/(ll); } } else { s1=exp(-cumhaz(0)); // survival to clayton-oakes s2=exp(-cumhazcase(0)); // cases via iterative, one-dimensional only (survival) // printf(" %d %d %lf %lf \n",cause(k),causecase(k),s1,s2); // etheta.print("hlj"); ags.print("ags"); ll=claytonoakesRVC(etheta,thetadesv,ags,cause(k),causecase(k),s1,s2,rv1,rv2,DthetaS,allvec); if (ascertainment==0) caseweight=allvec(0)/(s1*ll); if (ascertainment==1) { // s1t=exp(-cumhazt(0)); llt=claytonoakesRVC(etheta,thetadesv,ags,0,causecase(k),s1,s2,rv1,rv2,DthetaS,allvect); caseweight=(s1*allvec(0)+s2*llt)/(s2*s1*ll); } // printf("caseweight %lf %lf \n",caseweight,ll); } // either S / D1 S, when cause2=0, or D2 S / D1D2S, when cause2=1 casev(k)=caseweight; // increments Bhat.row(k)=dBaalen.row(k)*caseweight; // DthetaBhat.slice(k)= DthetaW * dBaalen.row(k); // derivative of baseline wrt theta // mat dBthetamat=xjump.slice(k) * trans(DthetaBhat.slice(k)); // dBB = trans(dBthetamat) *Dcumhaz1; // cumulative for all causes if (k>0) { Bhat.row(k) += Bhat.row(k-1); } // if (k>0) { DthetaBhat.slice(k)+= DthetaBhat.slice(k-1)+ // (dBB * dBaalen.row(k)); // } mat xj=xjump.slice(k); // vec bb=trans(Bhat.row(k)); // bb.print("bb"); // cumulative hazard at time t- for all causes if (recursive==1) cumhaz=xjump.slice(k)*trans(Bhat.row(k)); // else { // printf("sono qui \n"); // update Bit Bit.row(k)=Bhat.row(k); // } // mat pp=DthetaBhat.slice(k); // pp.print("pp"); Dcumhaz1.print("Dcumhaz1"); // trans(sum(dBthetamat,0)); } // }}} } // double nt2 = timer.toc(); // printf("Bhat-profile timer-loop %lf \n",nt2); return(Rcpp::List::create(Rcpp::Named("B")=Bhat, Rcpp::Named("caseweights")=casev) // Rcpp::Named("DthetaBhat")=-1*DthetaBhat) ); } catch( std::exception &ex ) { forward_exception_to_r( ex ); } catch(...) { ::Rf_error( "c++ exception (unknown reason)" ); } return R_NilValue; // -Wall } // }}} RcppExport SEXP XBmindex(SEXP imindex,SEXP iX,SEXP icumt) { // {{{ try { mat index = Rcpp::as(imindex); mat cumt = Rcpp::as(icumt); mat X = Rcpp::as(iX); int n=index.n_rows; int p=X.n_cols; mat XBmindex(n,n); vec vcumt(p); // XBmindex.print("XB"); for (int r=0; r0) { vcumt=trans(cumt.row(ii)); // vcumt.print("vcum"); // Xvec.print("Xv"); // printf(" %d %d \n",r,c); mat out = Xvec*vcumt; XBmindex(r,c)= out(0,0); } } } return(Rcpp::List::create(Rcpp::Named("XBmindex")=XBmindex)); } catch( std::exception &ex ) { forward_exception_to_r( ex ); } catch(...) { ::Rf_error( "c++ exception (unknown reason)" ); } return R_NilValue; // -Wall } // }}} //RcppExport SEXP backfitEaEt(SEXP iYt,SEXP iage0, SEXP iagenull, SEXP iage, // SEXP itime0, SEXP itime, SEXP iajumps, SEXP itjumps,SEXP ia0) //{ // {{{ //try { // // vec Yt = Rcpp::as(iYt); // vec age = Rcpp::as(iage); // vec age0 = Rcpp::as(iage0); // vec agenull = Rcpp::as(iagenull); // vec time = Rcpp::as(itime); // vec time0 = Rcpp::as(itime0); // vec ajumps = Rcpp::as(iajumps); // vec tjumps = Rcpp::as(itjumps); // double a0= Rcpp::as(ia0); // // int n=Yt.n_rows; // mat Ea(n,n); Ea.zeros(); // mat Et(n,n); Et.zeros(); // double ao,to,nn,ttt; // // for (int i=0; iage0)*(to+agenull<=age); // vec top=who*(a0-agenull0) Et(i,j)=ttt; // vec aaa=ao-agenull; //// ### aaa[aaa<0] <- 0 //// arma::uvec fff = FastApproxC(jumps,aaa,TRUE,2); //// vec yaai=Yt.elem(fff); // vec yaai=(top>0); // vec ww=(yaai>0); //// ### at risk at time a // who=(ao-agenull>time0)*(ao-agenull0) ttt+=top(k)/yaai(k); // Ea(j,i) = ttt; // } // } // // return(Rcpp::List::create(Rcpp::Named("Et")=Et, Rcpp::Named("Ea")=Ea)); // } catch( std::exception &ex ) { // forward_exception_to_r( ex ); // } catch(...) { // ::Rf_error( "c++ exception (unknown reason)" ); // } // return R_NilValue; // -Wall //} // }}} //arma::uvec FastApproxC(vec time, vec newtime,int equal,int type // // (0: nearest, 1: right, 2: left) // ) {/*{{{*/ // int Type = Rcpp::as(type); // NumericVector NewTime(newtime); // NumericVector Sorted(time); // // IntegerVector Order; // // NumericVector Sorted = Time; // // std::sort(Sorted.begin(), Sorted.end()); // // // .sort(); // // IntegerVector Order = match(Sorted, Time); // // return(Rcpp::wrap(Time)); // int Equal = Rcpp::as(equal); //// bool Equal = Rcpp::as(equal); // vector eq(NewTime.size()); // vector idx(NewTime.size()); //// IntegerVector idx(NewTime.size(),0); // // double vmax = Sorted[Sorted.size()-1]; // NumericVector::iterator it; // double upper=0.0; int pos=0; // for (int i=0; ivmax) { // pos = Sorted.size()-1; // } else { // it = lower_bound(Sorted.begin(), Sorted.end(), NewTime[i]); // upper = *it; // if (it == Sorted.begin()) { // pos = 0; // if ((Equal==1) && (NewTime[i]==upper)) { eq[i] = 1; } // } // // else if (int(it-Sorted.end())==0) { // // pos = Sorted.size()-1; // // } // else { // pos = int(it-Sorted.begin()); // if (Type==0 && fabs(NewTime[i]-Sorted[pos-1]) #include using namespace arma; using namespace Rcpp; RcppExport SEXP claytonoakesR(SEXP itheta,SEXP iistatus1,SEXP iistatus2,SEXP icif1,SEXP icif2); RcppExport SEXP claytonoakesbinRV(SEXP itheta,SEXP istatus1,SEXP istatus2,SEXP icif1,SEXP icif2, SEXP irv1, SEXP irv2,SEXP ithetades,SEXP iags, SEXP ivarlink); double claytonoakesbinRVC(vec theta,mat thetades,mat ags,int status1,int status2,double cif1,double cif2,vec x1, vec x2, vec &dp,vec &DbetaDtheta,vec &ps,vec &dp00) ; double survivalRVC(vec theta,mat thetades,mat ags,int cause1,int cause2,vec cif1,vec cif2,mat x1, mat x2, vec &dp, vec &alllike); double survivalRVCmarg(vec theta,mat thetades,mat ags,int cause1,vec cif1,mat x1, vec &dp,vec &ddp, vec &alllike); double survivalRVC2all(vec theta,mat thetades,mat ags,int cause1,int cause2,vec cif1,vec cif2,mat x1, mat x2, vec &dp, vec &alllike); double claytonoakesRVC(vec theta,mat thetades,mat ags, int status1,int status2, double cif1,double cif2,vec x1, vec x2, vec &dp,vec &ccw); double ilapsf(double y, double x, double z); double lapsf(double y,double x, double z) ; vec Dlapsf(double y, double x, double z); vec D2lapsf(double y, double x, double z) ; vec Dilapsf(double y, double x, double z) ; vec D2ilapsf(double y, double x, double z) ; mets/src/RcppExports.cpp0000644000176200001440000002621213623061405015011 0ustar liggesusers// Generated by using Rcpp::compileAttributes() -> do not edit by hand // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 #include "../inst/include/mets.h" #include #include #include #include using namespace Rcpp; // ApplyBy2 NumericMatrix ApplyBy2(NumericMatrix idata, NumericVector icluster, SEXP F, Environment Env, std::string Argument, int Columnwise, int Reduce, double epsilon); RcppExport SEXP _mets_ApplyBy2(SEXP idataSEXP, SEXP iclusterSEXP, SEXP FSEXP, SEXP EnvSEXP, SEXP ArgumentSEXP, SEXP ColumnwiseSEXP, SEXP ReduceSEXP, SEXP epsilonSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type idata(idataSEXP); Rcpp::traits::input_parameter< NumericVector >::type icluster(iclusterSEXP); Rcpp::traits::input_parameter< SEXP >::type F(FSEXP); Rcpp::traits::input_parameter< Environment >::type Env(EnvSEXP); Rcpp::traits::input_parameter< std::string >::type Argument(ArgumentSEXP); Rcpp::traits::input_parameter< int >::type Columnwise(ColumnwiseSEXP); Rcpp::traits::input_parameter< int >::type Reduce(ReduceSEXP); Rcpp::traits::input_parameter< double >::type epsilon(epsilonSEXP); rcpp_result_gen = Rcpp::wrap(ApplyBy2(idata, icluster, F, Env, Argument, Columnwise, Reduce, epsilon)); return rcpp_result_gen; END_RCPP } // ApplyBy NumericMatrix ApplyBy(NumericMatrix idata, IntegerVector icluster, Function f); RcppExport SEXP _mets_ApplyBy(SEXP idataSEXP, SEXP iclusterSEXP, SEXP fSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type idata(idataSEXP); Rcpp::traits::input_parameter< IntegerVector >::type icluster(iclusterSEXP); Rcpp::traits::input_parameter< Function >::type f(fSEXP); rcpp_result_gen = Rcpp::wrap(ApplyBy(idata, icluster, f)); return rcpp_result_gen; END_RCPP } // loglikMVN arma::mat loglikMVN(arma::mat Yl, SEXP yu, SEXP status, arma::mat Mu, SEXP dmu, arma::mat S, SEXP ds, SEXP z, SEXP su, SEXP dsu, SEXP threshold, SEXP dthreshold, bool Score); static SEXP _mets_loglikMVN_try(SEXP YlSEXP, SEXP yuSEXP, SEXP statusSEXP, SEXP MuSEXP, SEXP dmuSEXP, SEXP SSEXP, SEXP dsSEXP, SEXP zSEXP, SEXP suSEXP, SEXP dsuSEXP, SEXP thresholdSEXP, SEXP dthresholdSEXP, SEXP ScoreSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< arma::mat >::type Yl(YlSEXP); Rcpp::traits::input_parameter< SEXP >::type yu(yuSEXP); Rcpp::traits::input_parameter< SEXP >::type status(statusSEXP); Rcpp::traits::input_parameter< arma::mat >::type Mu(MuSEXP); Rcpp::traits::input_parameter< SEXP >::type dmu(dmuSEXP); Rcpp::traits::input_parameter< arma::mat >::type S(SSEXP); Rcpp::traits::input_parameter< SEXP >::type ds(dsSEXP); Rcpp::traits::input_parameter< SEXP >::type z(zSEXP); Rcpp::traits::input_parameter< SEXP >::type su(suSEXP); Rcpp::traits::input_parameter< SEXP >::type dsu(dsuSEXP); Rcpp::traits::input_parameter< SEXP >::type threshold(thresholdSEXP); Rcpp::traits::input_parameter< SEXP >::type dthreshold(dthresholdSEXP); Rcpp::traits::input_parameter< bool >::type Score(ScoreSEXP); rcpp_result_gen = Rcpp::wrap(loglikMVN(Yl, yu, status, Mu, dmu, S, ds, z, su, dsu, threshold, dthreshold, Score)); return rcpp_result_gen; END_RCPP_RETURN_ERROR } RcppExport SEXP _mets_loglikMVN(SEXP YlSEXP, SEXP yuSEXP, SEXP statusSEXP, SEXP MuSEXP, SEXP dmuSEXP, SEXP SSEXP, SEXP dsSEXP, SEXP zSEXP, SEXP suSEXP, SEXP dsuSEXP, SEXP thresholdSEXP, SEXP dthresholdSEXP, SEXP ScoreSEXP) { SEXP rcpp_result_gen; { Rcpp::RNGScope rcpp_rngScope_gen; rcpp_result_gen = PROTECT(_mets_loglikMVN_try(YlSEXP, yuSEXP, statusSEXP, MuSEXP, dmuSEXP, SSEXP, dsSEXP, zSEXP, suSEXP, dsuSEXP, thresholdSEXP, dthresholdSEXP, ScoreSEXP)); } Rboolean rcpp_isInterrupt_gen = Rf_inherits(rcpp_result_gen, "interrupted-error"); if (rcpp_isInterrupt_gen) { UNPROTECT(1); Rf_onintr(); } bool rcpp_isLongjump_gen = Rcpp::internal::isLongjumpSentinel(rcpp_result_gen); if (rcpp_isLongjump_gen) { Rcpp::internal::resumeJump(rcpp_result_gen); } Rboolean rcpp_isError_gen = Rf_inherits(rcpp_result_gen, "try-error"); if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); Rf_error(CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; } // dmvn NumericVector dmvn(arma::mat u, arma::mat mu, arma::mat rho); static SEXP _mets_dmvn_try(SEXP uSEXP, SEXP muSEXP, SEXP rhoSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< arma::mat >::type u(uSEXP); Rcpp::traits::input_parameter< arma::mat >::type mu(muSEXP); Rcpp::traits::input_parameter< arma::mat >::type rho(rhoSEXP); rcpp_result_gen = Rcpp::wrap(dmvn(u, mu, rho)); return rcpp_result_gen; END_RCPP_RETURN_ERROR } RcppExport SEXP _mets_dmvn(SEXP uSEXP, SEXP muSEXP, SEXP rhoSEXP) { SEXP rcpp_result_gen; { Rcpp::RNGScope rcpp_rngScope_gen; rcpp_result_gen = PROTECT(_mets_dmvn_try(uSEXP, muSEXP, rhoSEXP)); } Rboolean rcpp_isInterrupt_gen = Rf_inherits(rcpp_result_gen, "interrupted-error"); if (rcpp_isInterrupt_gen) { UNPROTECT(1); Rf_onintr(); } bool rcpp_isLongjump_gen = Rcpp::internal::isLongjumpSentinel(rcpp_result_gen); if (rcpp_isLongjump_gen) { Rcpp::internal::resumeJump(rcpp_result_gen); } Rboolean rcpp_isError_gen = Rf_inherits(rcpp_result_gen, "try-error"); if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); Rf_error(CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; } // rmvn arma::mat rmvn(unsigned n, arma::mat mu, arma::mat rho); static SEXP _mets_rmvn_try(SEXP nSEXP, SEXP muSEXP, SEXP rhoSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< unsigned >::type n(nSEXP); Rcpp::traits::input_parameter< arma::mat >::type mu(muSEXP); Rcpp::traits::input_parameter< arma::mat >::type rho(rhoSEXP); rcpp_result_gen = Rcpp::wrap(rmvn(n, mu, rho)); return rcpp_result_gen; END_RCPP_RETURN_ERROR } RcppExport SEXP _mets_rmvn(SEXP nSEXP, SEXP muSEXP, SEXP rhoSEXP) { SEXP rcpp_result_gen; { Rcpp::RNGScope rcpp_rngScope_gen; rcpp_result_gen = PROTECT(_mets_rmvn_try(nSEXP, muSEXP, rhoSEXP)); } Rboolean rcpp_isInterrupt_gen = Rf_inherits(rcpp_result_gen, "interrupted-error"); if (rcpp_isInterrupt_gen) { UNPROTECT(1); Rf_onintr(); } bool rcpp_isLongjump_gen = Rcpp::internal::isLongjumpSentinel(rcpp_result_gen); if (rcpp_isLongjump_gen) { Rcpp::internal::resumeJump(rcpp_result_gen); } Rboolean rcpp_isError_gen = Rf_inherits(rcpp_result_gen, "try-error"); if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); Rf_error(CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; } // rpch arma::vec rpch(unsigned n, std::vector lambda, std::vector time); static SEXP _mets_rpch_try(SEXP nSEXP, SEXP lambdaSEXP, SEXP timeSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< unsigned >::type n(nSEXP); Rcpp::traits::input_parameter< std::vector >::type lambda(lambdaSEXP); Rcpp::traits::input_parameter< std::vector >::type time(timeSEXP); rcpp_result_gen = Rcpp::wrap(rpch(n, lambda, time)); return rcpp_result_gen; END_RCPP_RETURN_ERROR } RcppExport SEXP _mets_rpch(SEXP nSEXP, SEXP lambdaSEXP, SEXP timeSEXP) { SEXP rcpp_result_gen; { Rcpp::RNGScope rcpp_rngScope_gen; rcpp_result_gen = PROTECT(_mets_rpch_try(nSEXP, lambdaSEXP, timeSEXP)); } Rboolean rcpp_isInterrupt_gen = Rf_inherits(rcpp_result_gen, "interrupted-error"); if (rcpp_isInterrupt_gen) { UNPROTECT(1); Rf_onintr(); } bool rcpp_isLongjump_gen = Rcpp::internal::isLongjumpSentinel(rcpp_result_gen); if (rcpp_isLongjump_gen) { Rcpp::internal::resumeJump(rcpp_result_gen); } Rboolean rcpp_isError_gen = Rf_inherits(rcpp_result_gen, "try-error"); if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); Rf_error(CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; } // cpch arma::vec cpch(arma::vec& x, std::vector lambda, std::vector time); static SEXP _mets_cpch_try(SEXP xSEXP, SEXP lambdaSEXP, SEXP timeSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::traits::input_parameter< arma::vec& >::type x(xSEXP); Rcpp::traits::input_parameter< std::vector >::type lambda(lambdaSEXP); Rcpp::traits::input_parameter< std::vector >::type time(timeSEXP); rcpp_result_gen = Rcpp::wrap(cpch(x, lambda, time)); return rcpp_result_gen; END_RCPP_RETURN_ERROR } RcppExport SEXP _mets_cpch(SEXP xSEXP, SEXP lambdaSEXP, SEXP timeSEXP) { SEXP rcpp_result_gen; { Rcpp::RNGScope rcpp_rngScope_gen; rcpp_result_gen = PROTECT(_mets_cpch_try(xSEXP, lambdaSEXP, timeSEXP)); } Rboolean rcpp_isInterrupt_gen = Rf_inherits(rcpp_result_gen, "interrupted-error"); if (rcpp_isInterrupt_gen) { UNPROTECT(1); Rf_onintr(); } bool rcpp_isLongjump_gen = Rcpp::internal::isLongjumpSentinel(rcpp_result_gen); if (rcpp_isLongjump_gen) { Rcpp::internal::resumeJump(rcpp_result_gen); } Rboolean rcpp_isError_gen = Rf_inherits(rcpp_result_gen, "try-error"); if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); Rf_error(CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; } // validate (ensure exported C++ functions exist before calling them) static int _mets_RcppExport_validate(const char* sig) { static std::set signatures; if (signatures.empty()) { signatures.insert("arma::mat(*.loglikMVN)(arma::mat,SEXP,SEXP,arma::mat,SEXP,arma::mat,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,bool)"); signatures.insert("NumericVector(*.dmvn)(arma::mat,arma::mat,arma::mat)"); signatures.insert("arma::mat(*.rmvn)(unsigned,arma::mat,arma::mat)"); signatures.insert("arma::vec(*.rpch)(unsigned,std::vector,std::vector)"); signatures.insert("arma::vec(*.cpch)(arma::vec&,std::vector,std::vector)"); } return signatures.find(sig) != signatures.end(); } // registerCCallable (register entry points for exported C++ functions) RcppExport SEXP _mets_RcppExport_registerCCallable() { R_RegisterCCallable("mets", "_mets_.loglikMVN", (DL_FUNC)_mets_loglikMVN_try); R_RegisterCCallable("mets", "_mets_.dmvn", (DL_FUNC)_mets_dmvn_try); R_RegisterCCallable("mets", "_mets_.rmvn", (DL_FUNC)_mets_rmvn_try); R_RegisterCCallable("mets", "_mets_.rpch", (DL_FUNC)_mets_rpch_try); R_RegisterCCallable("mets", "_mets_.cpch", (DL_FUNC)_mets_cpch_try); R_RegisterCCallable("mets", "_mets_RcppExport_validate", (DL_FUNC)_mets_RcppExport_validate); return R_NilValue; } mets/src/survival-twostage.cpp0000644000176200001440000032624013623061405016232 0ustar liggesusers#include #include #include #include #include using namespace arma; using namespace Rcpp; double claytonoakes(double theta,int status1,int status2,double cif1,double cif2,vec &dp) { // {{{ double valr=1,x,y,z; //double cifs=cif1+cif2; //double S=1+(cifs*(theta-1)); // theta is 1/variance, which is how this function is called x=theta; y=cif1; z=cif2; if (status1==0 && status2==0) { // {{{ valr= pow((1/pow(y,1/x) + 1/pow(z,1/x)) - 1,-x); dp(0)= (-((x*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x))) - log(-1 + pow(y,-1/x) + pow(z,-1/x)))/pow(-1 + pow(y,-1/x) + pow(z,-1/x),x); } // }}} if (status1==1 && status2==0) { // {{{ valr=pow(y,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x); dp(0)=(pow(y,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x)*log(y))/pow(x,2) + pow(y,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x)*(((-1 - x)*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x)) - log(-1 + pow(y,-1/x) + pow(z,-1/x))); } // }}} if (status1==0 && status2==1) { // {{{ valr=pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x); dp(0)=(pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x)*log(z))/pow(x,2) + pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-1 - x)*(((-1 - x)*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x)) - log(-1 + pow(y,-1/x) + pow(z,-1/x))); } // }}} if (status1==1 && status2==1) { // {{{ valr= -(((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x))/x); dp(0)=((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x))/pow(x,2) + (pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x))/x - ((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x)*log(y))/pow(x,3) - ((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x)*log(z))/pow(x,3) - ((-1 - x)*pow(y,-1 - 1/x)*pow(z,-1 - 1/x)*pow(-1 + pow(y,-1/x) + pow(z,-1/x),-2 - x)*(((-2 - x)*(log(y)/(pow(x,2)*pow(y,1/x)) + log(z)/(pow(x,2)*pow(z,1/x))))/(-1 + pow(y,-1/x) + pow(z,-1/x)) - log(-1 + pow(y,-1/x) + pow(z,-1/x))))/x; } // }}} return(valr); } // }}} //extern "C" double RcppExport SEXP claytonoakesR(SEXP itheta,SEXP iistatus1,SEXP iistatus2,SEXP icif1,SEXP icif2,SEXP ivarlink) { // {{{ colvec theta = Rcpp::as(itheta); colvec cif1 = Rcpp::as(icif1); colvec cif2 = Rcpp::as(icif2); colvec istatus1 = Rcpp::as(iistatus1); colvec istatus2 = Rcpp::as(iistatus2); int varlink = Rcpp::as(ivarlink); // parametrization of Clayton-Oakes model if (varlink==1) theta=1/exp(theta); else theta=1/theta; colvec L=theta; colvec dL=theta; colvec logL=theta; colvec dlogL=theta; int n=cif1.size(); double valr=1; double x,y,z; int status1,status2; colvec vdp(1); // theta.print("theta"); // istatus1.print("theta"); istatus2.print("theta"); cif1.print("cif1 "); cif2.print("cif2 "); for (int i=0;ib) return(a); else return(b); } // {{{ laplace and derivatives double ilapsf(double y, double x, double z) { return( exp((y*log(x)-log(z))/y)-x ); } double lapsf(double y,double x, double z) { return( pow(x,y)/pow((z + x),y)); } //double lapsf(double y,double x, double z) //{ //return( exp(log(x)*y)/exp(log(z + x)*y)); //} vec DlapsfOrig(double y, double x, double z) { vec dL(3); dL(0) =(pow(z+x,y)*log(x)*pow(x,y) - pow(x,y)*log(x+z)*pow(z+x,y))/pow((z + x),(2*y)); dL(1) =(pow(z+x,y)*(y/x)*pow(x,y) - pow(x,y)*(y/(x+z))*pow(z+x,y))/pow((z+x),(2*y)); dL(2) =(- pow(x,y)*(y/(x+z))*pow(z+x,y))/pow(z+x,(2*y)); return(dL); } vec D2lapsfOrig(double y, double x, double z) { vec dL(6); // D13 dL(0)= pow(x,y)* pow(x+z,(-y-1))* (y* log(x+z)-y* log(x)-1) ; // D23 dL(1)= y* pow(x,(y-1))* pow(x+z,(-y-2))*(x-y* z) ; // D33 dL(2)= y* (y+1)* pow(x,y)*pow((x+z),(-y-2)); // D133 dL(4)= pow(y,2)* (y+1)* pow(x,(y-1))* pow(x+z,(-y-2))+(-y-2)* y* (y+1)* pow(x,y)* pow(x+z,(-y-3)); // D233 dL(3)= y* pow(x,y)* pow(x+z,(-y-2))+(y+1)*pow(x,y)* pow(x+z,(-y-2))+y* (y+1)* pow(x,y) *log(x)* pow(x+z,(-y-2))-y *(y+1)* pow(x,y)* pow(x+z,(-y-2))* log(x+z); // D333 dL(5)= y* (y+1)* (y+2)* (-pow(x,y))* pow(x+z,(-y-3)); return(dL); } vec Dlapsf(double y, double x, double z) { vec dL(3); double zxiy=pow(z+x,y),xiy=pow(x,y),zxi2y=pow((z + x),(2*y)); double ydxz=y/(x+z); //printf("%lf %lf %lf %lf %lf \n",y,x,z,ydxz,zxi2y); double p2=xiy*zxiy; //if (zxi2y>0.000000000001) { dL(0) =p2*(log(x) - log(x+z))/zxi2y; dL(1) =p2*((y/x) - ydxz)/zxi2y; dL(2) =p2*(-ydxz)/zxi2y; //} return(dL); } vec D2lapsf(double y, double x, double z) { vec dL(6); double zximym2=pow(z+x,-y-2), zximym1=pow(z+x,-y-1), zximym3=pow(z+x,-y-3), xiym1=pow(x,y-1), xiy=pow(x,y), lxz=log(x+z), lx=log(x),yp1=y+1, ygyp1=y*(y+1); double p3=ygyp1*xiy; // D13 dL(0)= xiy* zximym1* (y* lxz-y* lx-1) ; // D23 dL(1)= y* xiym1* zximym2*(x-y* z) ; // D33 dL(2)= y* yp1*xiy*zximym2; // D133 dL(4)= pow(y,2)* yp1* xiym1* zximym2+(-y-2)* p3* zximym3; // D233 dL(3)= zximym2*( y* xiy+(y+1)*xiy + p3 *lx - p3 * lxz); // D333 dL(5)= ygyp1 * (y+2)* (-xiy* zximym3); return(dL); } vec Dilapsf(double y, double x, double z) { vec dL(3); dL(0) = (x* pow(z,(-1/y))* log(z))/pow(y,2); dL(1) = pow(z,(-1/y))-1; dL(2) = -(x* pow(z,(-(y+1)/y)))/y; return(dL); } vec D2ilapsf(double y, double x, double z) { vec dL(6); dL(0)=(x* pow(z,(-(y+1)/y))* (y-log(z)))/pow(y,3); dL(1)= - pow(z,(-(y+1)/y))/y; dL(2)= (x* (y+1)* pow(z,(-1/y-2)))/pow(y,2); dL(4)= ((y+1)* pow(z,(-1/y-2)))/pow(y,2); dL(3)= -(x* pow(z,(-1/y-2))* (y* (y+2)-(y+1)* log(z)))/pow(y,4); dL(5)= -(x*(y+1)* (2* y+1)* pow(z,(-1/y-3)))/pow(y,3); return(dL); } // }}} cube vcrossmat(vec d, mat x1x2) { // {{{ cube dd(d.n_elem,x1x2.n_rows,2); dd.slice(0)=d * trans(x1x2.col(0)); dd.slice(1)=d * trans(x1x2.col(1)); return(dd); } // }}} double survivalRVC(vec theta,mat thetades,mat ags,int cause1,int cause2,vec cif1,vec cif2,mat x1, mat x2, vec &dp, vec &alllike) { // {{{ double lamtot1=1,valr=1; // index variable som angiver cause, men hvis cause==0 er index -1 int icause1,icause2; icause1=cause1; icause2=cause2; if (cause1==0) icause1=1; if (cause2==0) icause2=1; int test=0,itest=0; if (itest==1) { // {{{ theta.print("theta"); thetades.print("theta-des"); Rprintf(" %d %d \n",cause1,cause2); cif1.print("ci1"); cif2.print("ci1"); x1.print("x1"); x2.print("x2"); ags.print("ags"); } // }}} vec dL=theta; dL.fill(0); vec par = thetades * theta; if (test==1) { cif1.print("c1"); x1.print("x1"); } if (test==1) { theta.print("theta"); thetades.print("t-des "); par.print("pp"); } // nn number of parameters, ncr number of competing risks, lpar number of parameters pars=thetades * theta int nn=thetades.n_rows,lpar=thetades.n_cols; // x1 = ncr x nrvs , Dcif1=ntheta x ncr vec sumtheta=ags * theta; // test=3; // wall_clock timer; // timer.tic(); // {{{ first basic laplace derivatives vec resv(nn); // resv.fill(0); //if (test==1) { x1.print("x1"); cif1.print("cif1"); } // x1 = ncr x nrvs , cif1=ncr vec x1f1, x2f2; x1f1= trans(x1) * cif1; x2f2= trans(x2) * cif2; //if (test==1) { x1f1.print("x1f1"); } //ags.print("ags"); theta.print("par"); vec D1(nn),D2(nn),D3(nn); vec D13(nn),D23(nn),D33(nn),D133(nn),D233(nn),D333(nn); vec res(6),res0(6); res.fill(0); res0.fill(0); //double x,y,z; double like=1,iisum; int i; for (i=0;i(itheta); mat thetades = Rcpp::as(ithetades); mat x1= Rcpp::as(irv1); mat ags= Rcpp::as(iags); vec cif1 = Rcpp::as(icif1); int varlink = Rcpp::as(ivarlink); int status1 = Rcpp::as(istatus1); // IntegerVector status1(istatus1); // int nn=status1.n_rows(); // int nn2=cif1.n_rows(); // printf(" %d %d \n",nn,nn2); int test=0; if (test==1) { theta.print("the"); thetades.print("the"); ags.print("ags"); x1.print("x1 "); cif1.print("cif"); } int lpar=thetades.n_cols; vec dp(lpar); dp.fill(0); vec ddp(lpar); ddp.fill(0); vec all(6); //vec like(nn); //for (int i=0; i(itheta); mat thetades = Rcpp::as(ithetades); mat x1= Rcpp::as(irv1); mat x2= Rcpp::as(irv2); mat ags= Rcpp::as(iags); // colvec x2= Rcpp::as(irv2); vec cif1 = Rcpp::as(icif1); vec cif2 = Rcpp::as(icif2); int varlink = Rcpp::as(ivarlink); int status1 = Rcpp::as(istatus1); int status2 = Rcpp::as(istatus2); int test=0; if (test==1) { theta.print("the"); thetades.print("the"); ags.print("ags"); x1.print("x1 "); x2.print("x2 "); cif1.print("cif"); cif2.print("cif"); } List ressl; ressl["par"]=theta; if (varlink==1) theta=exp(theta); colvec dL=theta; dL.fill(0); // double f1,f2; //double cifs=cif1+cif2; //double S=1+(cifs*(theta-1)); colvec par = thetades * theta; int lpar=thetades.n_cols; vec dp(lpar); dp.fill(0); vec all(6); double like=0; if (status1==0 && status2==0) { // {{{ like=survivalRVC(theta,thetades,ags,0,0,cif1,cif2,x1,x2,dp,all) ; } // }}} if (status1==0 && status2!=0) { // {{{ like=survivalRVC(theta,thetades,ags,0,status2,cif1,cif2,x1,x2,dp,all) ; } // }}} if (status1!=0 && status2==0) { // {{{ like=survivalRVC(theta,thetades,ags,status1,0,cif1,cif2,x1,x2,dp,all) ; } // }}} if (status1!=0 && status2!=0) { // {{{ like=survivalRVC(theta,thetades,ags,status1,status2,cif1,cif2,x1,x2,dp,all); } // }}} ressl["like"]=like; if (varlink==1) dp=dp % theta; ressl["dlike"]=dp; ressl["theta"]=theta; ressl["par.des"]=thetades; ressl["varlink"]=varlink; ressl["alllike"]=all; return(ressl); } catch( std::exception &ex ) { forward_exception_to_r( ex ); } catch(...) { ::Rf_error( "c++ exception (unknown reason)" ); } return R_NilValue; // -Wall } // }}} RcppExport SEXP survivalRV2(SEXP itheta,SEXP istatus1,SEXP istatus2, SEXP icif1,SEXP icif2, SEXP irv1, SEXP irv2,SEXP ithetades, SEXP iags, SEXP ivarlink) { // {{{ try { colvec theta = Rcpp::as(itheta); mat thetades = Rcpp::as(ithetades); mat x1= Rcpp::as(irv1); mat x2= Rcpp::as(irv2); mat ags= Rcpp::as(iags); // colvec x2= Rcpp::as(irv2); vec cif1 = Rcpp::as(icif1); vec cif2 = Rcpp::as(icif2); int varlink = Rcpp::as(ivarlink); int status1 = Rcpp::as(istatus1); int status2 = Rcpp::as(istatus2); // int test=1; // if (test==1) { // theta.print("the"); // thetades.print("the"); // ags.print("ags"); // x1.print("x1 "); // x2.print("x2 "); // cif1.print("cif"); // cif2.print("cif"); // } List ressl; ressl["par"]=theta; if (varlink==1) theta=exp(theta); colvec dL=theta; dL.fill(0); // double f1,f2; //double cifs=cif1+cif2; //double S=1+(cifs*(theta-1)); colvec par = thetades * theta; int lpar=thetades.n_cols; vec dp(lpar); dp.fill(0); vec all(6); double like=0; if (status1==0 && status2==0) { // {{{ like=survivalRVC2(theta,thetades,ags,0,0,cif1,cif2,x1,x2,dp,all) ; } // }}} if (status1==0 && status2!=0) { // {{{ like=survivalRVC2(theta,thetades,ags,0,status2,cif1,cif2,x1,x2,dp,all) ; } // }}} if (status1!=0 && status2==0) { // {{{ like=survivalRVC2(theta,thetades,ags,status1,0,cif1,cif2,x1,x2,dp,all) ; } // }}} if (status1!=0 && status2!=0) { // {{{ like=survivalRVC2(theta,thetades,ags,status1,status2,cif1,cif2,x1,x2,dp,all); } // }}} ressl["like"]=like; if (varlink==1) dp=dp % theta; ressl["dlike"]=dp; ressl["theta"]=theta; ressl["par.des"]=thetades; ressl["varlink"]=varlink; ressl["alllike"]=all; return(ressl); } catch( std::exception &ex ) { forward_exception_to_r( ex ); } catch(...) { ::Rf_error( "c++ exception (unknown reason)" ); } return R_NilValue; // -Wall } // }}} double claytonoakesRVC(vec theta,mat thetades,mat ags, int status1,int status2,double cif1,double cif2,vec x1,vec x2,vec &dp,vec &ccw) { // {{{ double valr=1; colvec dL=theta; dL.fill(0); double f1,f2; f1=cif1; f2=cif2; colvec par = thetades * theta; int nn=thetades.n_rows; int lpar=thetades.n_cols; // {{{ first basic laplace derivatives //double lamtot1= trans(ags.row(0)) * par; // changed to the below 17-08-2018 double lamtot1= sum(x1 % par); // lamtot same within cluster double ii1 = ilapsf(lamtot1,lamtot1,f1); double ii2 = ilapsf(lamtot1,lamtot1,f2); // printf(" lamtot %lf ",lamtot1); vec part = trans( x1.t() * thetades); // part.print("pp"); // ags.row(0)=part.t(); // ags.row(1)=part.t(); vec resv(nn); resv.fill(0); vec iresv(nn); iresv.fill(0); double like=1,iisum; int i; for (i=0;i(itheta); mat thetades = Rcpp::as(ithetades); mat ags= Rcpp::as(iags); colvec x1= Rcpp::as(irv1); colvec x2= Rcpp::as(irv2); double cif1 = Rcpp::as(icif1); double cif2 = Rcpp::as(icif2); int varlink = Rcpp::as(ivarlink); int status1 = Rcpp::as(istatus1); int status2 = Rcpp::as(istatus2); vec ccw= Rcpp::as(iccw); List ressl; ressl["par"]=theta; if (varlink==1) theta=exp(theta); colvec dL=theta; dL.fill(0); double f1,f2; f1=cif1; f2=cif2; colvec par = thetades * theta; //int nn=thetades.n_rows; int lpar=thetades.n_cols; vec dp(lpar); dp.fill(0); vec DbetaDtheta(2*lpar); if (status1==0 && status2==0) { // {{{ double like=claytonoakesRVC(theta,thetades,ags,0,0,f1,f2,x1,x2,dp,ccw) ; ressl["like"]=like; if (varlink==1) dp=dp % theta; ressl["dlike"]=dp; } // }}} if (status1==0 && status2==1) { // {{{ double like=claytonoakesRVC(theta,thetades,ags,0,1,f1,f2,x1,x2,dp,ccw) ; ressl["like"]=like; if (varlink==1) dp=dp % theta; ressl["dlike"]=dp; } // }}} if (status1==1 && status2==0) { // {{{ double like=claytonoakesRVC(theta,thetades,ags,1,0,f1,f2,x1,x2,dp,ccw) ; ressl["like"]=like; if (varlink==1) dp=dp % theta; ressl["dlike"]=dp; } // }}} if (status1==1 && status2==1) { // {{{ double like=claytonoakesRVC(theta,thetades,ags,1,1,f1,f2,x1,x2,dp,ccw) ; ressl["like"]=like; if (varlink==1) dp=dp % theta; ressl["dlike"]=dp; } // }}} ressl["theta"]=theta; ressl["par.des"]=thetades; vec obs(4); obs(0)=status1; obs(1)=f1; obs(2)=status2; obs(3)=f2; ressl["obs"]=obs; ressl["varlink"]=varlink; return(ressl); } // }}} // for binary case, additive gamma from twostage survival double claytonoakesbinRVC(vec theta,mat thetades,mat ags,int status1,int status2,double cif1,double cif2,vec x1, vec x2, vec &dp,vec &DbetaDtheta,vec &ps,vec &dp00) { // {{{ double f1,f2,valr=1; colvec dL=theta; dL.fill(0); f1=cif1; f2=cif2; colvec par = thetades * theta; int nn=thetades.n_rows; int lpar=thetades.n_cols; // {{{ first basic laplace derivatives double lamtot1= sum(x1 % par); double ii1 = ilapsf(lamtot1,lamtot1,f1); double ii2 = ilapsf(lamtot1,lamtot1,f2); vec part = trans( x1.t() * thetades); vec resv(nn); resv.fill(0); vec iresv(nn); iresv.fill(0); double like=1,iisum; int i; for (i=0;i(itheta); mat thetades = Rcpp::as(ithetades); mat ags = Rcpp::as(iags); colvec x1= Rcpp::as(irv1); colvec x2= Rcpp::as(irv2); double cif1 = Rcpp::as(icif1); double cif2 = Rcpp::as(icif2); int varlink = Rcpp::as(ivarlink); int status1 = Rcpp::as(istatus1); int status2 = Rcpp::as(istatus2); List ressl; ressl["par"]=theta; if (varlink==1) theta=exp(theta); colvec dL=theta; dL.fill(0); double f1,f2; //double cifs=cif1+cif2; //double S=1+(cifs*(theta-1)); f1=cif1; f2=cif2; colvec par = thetades * theta; //int nn=thetades.n_rows; int lpar=thetades.n_cols; vec dp(lpar); dp.fill(0); vec dp00(lpar); dp00.fill(0); vec ps(8); dp.fill(0); vec DbetaDtheta(2*lpar); double like; if (status1==0 && status2==0) { // {{{ like=claytonoakesbinRVC(theta,thetades,ags,0,0,f1,f2,x1,x2,dp,DbetaDtheta,ps,dp00) ; } // }}} if (status1==0 && status2==1) { // {{{ like=claytonoakesbinRVC(theta,thetades,ags,0,1,f1,f2,x1,x2,dp,DbetaDtheta,ps,dp00) ; } // }}} if (status1==1 && status2==0) { // {{{ like=claytonoakesbinRVC(theta,thetades,ags,1,0,f1,f2,x1,x2,dp,DbetaDtheta,ps,dp00) ; } // }}} if (status1==1 && status2==1) { // {{{ like=claytonoakesbinRVC(theta,thetades,ags,1,1,f1,f2,x1,x2,dp,DbetaDtheta,ps,dp00) ; } // }}} ressl["like"]=like; if (varlink==1) dp=dp % theta; ressl["dlike"]=dp; ressl["ps"]=ps; ressl["dp00"]=dp00; ressl["theta"]=theta; ressl["par.des"]=thetades; vec obs(4); obs(0)=status1; obs(1)=f1; obs(2)=status2; obs(3)=f2; ressl["obs"]=obs; ressl["varlink"]=varlink; return(ressl); } catch( std::exception &ex ) { forward_exception_to_r( ex ); } catch(...) { ::Rf_error( "c++ exception (unknown reason)" ); } return R_NilValue; // -Wall } // }}} RcppExport SEXP twostageloglike( SEXP icause, SEXP ipmargsurv, SEXP itheta, SEXP iXtheta, SEXP iDXtheta, SEXP idimDX, SEXP ithetades, SEXP icluster,SEXP iclustsize,SEXP iclusterindex, SEXP ivarlink, SEXP iiid, SEXP iweights, SEXP isilent, SEXP idepmodel, // SEXP ientryage, SEXP itrunkp , SEXP istrata, SEXP isecluster, SEXP iantiid ) // {{{ { try { // {{{ setting matrices and vectors, and exporting to armadillo matrices mat thetades = Rcpp::as(ithetades); mat clusterindex = Rcpp::as(iclusterindex); colvec theta = Rcpp::as(itheta); colvec clustsize = Rcpp::as(iclustsize); int antclust = clusterindex.n_rows; colvec cause = Rcpp::as(icause); colvec pmargsurv = Rcpp::as(ipmargsurv); colvec cluster = Rcpp::as(icluster); colvec weights = Rcpp::as(iweights); // colvec entryage = Rcpp::as(ientryage); colvec trunkp = Rcpp::as(itrunkp); colvec secluster = Rcpp::as(isecluster); // array for derivative of flexible design NumericVector DXthetavec(iDXtheta); IntegerVector arrayDims(idimDX); arma::cube DXtheta(DXthetavec.begin(), arrayDims[0], arrayDims[1], arrayDims[2], false); IntegerVector strata(istrata); int varlink= Rcpp::as(ivarlink); int silent = Rcpp::as(isilent); int depmodel= Rcpp::as(idepmodel); int iid= Rcpp::as(iiid); int antiid = Rcpp::as(iantiid); mat Xtheta = Rcpp::as(iXtheta); int udtest=0; if (udtest==1) { // {{{ // Rprintf(" %d %d %d %d %d %d %d \n",samecens,inverse,semi,semi2,flexfunc,stabcens,silent); // Rprintf(" %d %d %d %d %d %d %d \n",cifmodel,CA1,CA2,sym,depmodel,estimator,iid); // est.print("est"); // est2.print("est2"); // z.print("z"); // zsem.print("zsemi"); // z2.print("z2"); thetades.print("theta.des"); clusterindex.print("clusterindex"); // rvdes.print("rvdes"); theta.print("theta"); Xtheta.print("Xtheta"); // y.print("y-times"); clustsize.print("clustsize"); pmargsurv.print("margsurv"); cause.print("cause"); cluster.print("cluster"); // Zgamma.print("zgam"); // Z2gamma2.print("zgam2"); // KMtimes.print("KMtimes"); // KMc.print("KMc"); weights.print("weights"); // entryage.print("entryage"); // cif1entry.print("cif1entry"); // cif2entry.print("cif2entry"); trunkp.print("trunkp"); } else if (udtest==2) { // Rprintf(" %d %d %d %d %d %d %d \n",samecens,inverse,semi,semi2,flexfunc,stabcens,silent); // Rprintf(" %d %d %d %d %d %d %d \n",cifmodel,CA1,CA2,sym,depmodel,estimator,iid); // Rprintf("est %lf \n",mean(mean(est))); // Rprintf("est2 %lf \n",mean(mean(est2))); // Rprintf("z %lf \n",mean(mean(z))); // Rprintf("zsem %lf \n",mean(mean(zsem))); // Rprintf("z2 %lf \n",mean(mean(z2))); mat mt=mean(thetades); mt.print("meancol thetades"); // Rprintf("theatdes %lf \n",mean(mean(thetades))); Rprintf("ci %lf \n",mean(mean(clusterindex))); // Rprintf("rvdes %lf \n",mean(mean(rvdes))); Rprintf("theta %lf \n",mean(theta)); Rprintf("Xtheta %lf \n",mean(mean(Xtheta))); // Rprintf("y %lf \n",mean(y)); Rprintf("ci %lf \n",mean(clustsize)); // Rprintf("times %lf \n",mean(times)); Rprintf("cause %lf \n",mean(cause)); Rprintf("cluster %lf \n",mean(cluster)); // Rprintf("Zgamma %lf \n",mean(Zgamma)); // Rprintf("Z2gamma2 %lf \n",mean(Z2gamma2)); // Rprintf("KMtimes %lf \n",mean(KMtimes)); // Rprintf("KMc %lf \n",mean(KMc)); Rprintf("weights %lf \n",mean(weights)); // Rprintf("entry %lf \n",mean(entryage)); // Rprintf("cif1entry %lf \n",mean(cif1entry)); // Rprintf("cif2entry %lf \n",mean(cif2entry)); Rprintf("trunkp %lf \n",mean(trunkp)); } // }}} int ci,ck,i,j,c,s=0,k,v,c1; // double asign=-1; if (ascertained==2) asign=1; // double ll=1,Li,Lk,sdj=0,diff=0,loglikecont=0; // double Lit=1,Lkt=1,llt=1,deppar=1,ssf=0,thetak=0; double dl1,dl2,ll1,ll2,ll=1,Li,Lk,sdj=0,diff=0,loglikecont=0; double Lit=1,Lkt=1,llt=1,deppar=1,ssf=0,thetak=0,dddl=0.000001; double d2=0,asign=-1; // double plack(); int pt=theta.n_rows; vec dplack(pt); dplack.fill(pt); vec dplackt(pt); dplackt.fill(pt); vec dplackt1(pt); dplackt1.fill(0); vec dplackt2(pt); dplackt2.fill(0); // mat dp1(pmargsurv.n_rows,2); dp1.fill(0); mat dp1(pmargsurv.n_rows,pt); dp1.fill(0); mat dp2(pmargsurv.n_rows,pt); dp2.fill(0); // vec ckij(pt),dckij(pt),ckijvv(pt),dckijvv(pt),ckijtv(pt),dckijtv(pt),ckijvt(pt),dckijvt(pt); i=silent+1; mat thetiid(antiid,pt); colvec loglikeiid(antiid); if (iid==1) { thetiid.fill(0); loglikeiid.fill(0); } colvec p11tvec(antclust); // p11tvec=0; // Rprintf(" %d \n",pt); colvec Utheta(pt); colvec vthetascore(pt); colvec pthetavec(pt); vec vtheta2(pt); mat DUtheta(pt,pt); DUtheta.fill(0); Utheta.fill(0); // if (!Utheta.is_finite()) { Rprintf(" NA's i def U\n"); Utheta.print("U"); } // if (!DUtheta.is_finite()) { Rprintf(" NA's i def DU\n"); DUtheta.print("DU"); } // rowvec bhatt2 = est.row(est2.n_cols); // colvec pbhat2(z.n_rows); // depmodel=5 // rvdes.print("rvdes"); // thetades.print("ttt"); // nr=rvdes.n_cols; // vec alphaj(nr),alphai(nr),alpha(nr), // rvvec(nr),rvvec1(nr),rvvec2vv(nr),rvvec2vt(nr),rvvec2tv(nr); // vec rvvec2(nr); // }}} for (j=0;j=2) { R_CheckUserInterrupt(); diff=0; sdj=0; for (c=0;c(ithetades); mat clusterindex = Rcpp::as(iclusterindex); colvec theta = Rcpp::as(itheta); colvec clustsize = Rcpp::as(iclustsize); int antclust = clusterindex.n_rows; IntegerVector cause(icause); colvec pmargsurv = Rcpp::as(ipmargsurv); IntegerVector cluster(icluster); colvec weights = Rcpp::as(iweights); // colvec entryage = Rcpp::as(ientryage); colvec trunkp = Rcpp::as(itrunkp); colvec secluster = Rcpp::as(isecluster); mat rvdes= Rcpp::as(irvdes); mat ags = Rcpp::as(iags); int ascertained= Rcpp::as(iascertained); // array for derivative of flexible design NumericVector DXthetavec(iDXtheta); IntegerVector arrayDims(idimDX); arma::cube DXtheta(DXthetavec.begin(), arrayDims[0], arrayDims[1], arrayDims[2], false); IntegerVector strata(istrata); int varlink= Rcpp::as(ivarlink); int silent = Rcpp::as(isilent); int depmodel= Rcpp::as(idepmodel); int iid= Rcpp::as(iiid); int antiid = Rcpp::as(iantiid); mat Xtheta = Rcpp::as(iXtheta); int udtest=0; if (udtest==1) { // {{{ // Rprintf(" %d %d %d %d %d %d %d \n",samecens,inverse,semi,semi2,flexfunc,stabcens,silent); // Rprintf(" %d %d %d %d %d %d %d \n",cifmodel,CA1,CA2,sym,depmodel,estimator,iid); // est.print("est"); // est2.print("est2"); // z.print("z"); // zsem.print("zsemi"); // z2.print("z2"); thetades.print("theta.des"); clusterindex.print("clusterindex"); // rvdes.print("rvdes"); theta.print("theta"); Xtheta.print("Xtheta"); // y.print("y-times"); clustsize.print("clustsize"); pmargsurv.print("margsurv"); // cause.print("cause"); // cluster.print("cluster"); // Zgamma.print("zgam"); // Z2gamma2.print("zgam2"); // KMtimes.print("KMtimes"); // KMc.print("KMc"); weights.print("weights"); // entryage.print("entryage"); // cif1entry.print("cif1entry"); // cif2entry.print("cif2entry"); trunkp.print("trunkp"); } else if (udtest==2) { // Rprintf(" %d %d %d %d %d %d %d \n",samecens,inverse,semi,semi2,flexfunc,stabcens,silent); // Rprintf(" %d %d %d %d %d %d %d \n",cifmodel,CA1,CA2,sym,depmodel,estimator,iid); // Rprintf("est %lf \n",mean(mean(est))); // Rprintf("est2 %lf \n",mean(mean(est2))); // Rprintf("z %lf \n",mean(mean(z))); // Rprintf("zsem %lf \n",mean(mean(zsem))); // Rprintf("z2 %lf \n",mean(mean(z2))); mat mt=mean(thetades); mt.print("meancol thetades"); // Rprintf("theatdes %lf \n",mean(mean(thetades))); Rprintf("ci %lf \n",mean(mean(clusterindex))); // Rprintf("rvdes %lf \n",mean(mean(rvdes))); Rprintf("theta %lf \n",mean(theta)); Rprintf("Xtheta %lf \n",mean(mean(Xtheta))); // Rprintf("y %lf \n",mean(y)); Rprintf("ci %lf \n",mean(clustsize)); // Rprintf("times %lf \n",mean(times)); // Rprintf("cause %lf \n",mean(cause)); // Rprintf("cluster %lf \n",mean(cluster)); // Rprintf("Zgamma %lf \n",mean(Zgamma)); // Rprintf("Z2gamma2 %lf \n",mean(Z2gamma2)); // Rprintf("KMtimes %lf \n",mean(KMtimes)); // Rprintf("KMc %lf \n",mean(KMc)); Rprintf("weights %lf \n",mean(weights)); // Rprintf("entry %lf \n",mean(entryage)); // Rprintf("cif1entry %lf \n",mean(cif1entry)); // Rprintf("cif2entry %lf \n",mean(cif2entry)); Rprintf("trunkp %lf \n",mean(trunkp)); } // }}} int ci,ck,i,j,c,s=0,k,v,c1; // double ll=1,Li,Lk,diff=0,loglikecont=0,sdj=0; double dl1,dl2,ll1,ll2,ll=1,Li,Lk,diff=0,loglikecont=0,sdj; double Lit=1,Lkt=1,llt=1,deppar=1,ssf=0,thetak=0,dddl=0.000001; // double plack(); int pt=theta.n_rows; double d2=0,asign=-1; if (ascertained==2) asign=1; vec dplack(pt); dplack.fill(0); vec dplackt(pt); dplackt.fill(0); vec dplackt1(pt); dplackt1.fill(0); vec dplackt2(pt); dplackt2.fill(0); // mat dp1(pmargsurv.n_rows,2); dp1.fill(0); mat dp1(pmargsurv.n_rows,pt); dp1.fill(0); mat dp2(pmargsurv.n_rows,pt); dp2.fill(0); // vec ckij(pt),dckij(4),ckijvv(4),dckijvv(4),ckijtv(4),dckijtv(4),ckijvt(4),dckijvt(4); i=silent+1; mat thetiid(antiid,pt); colvec loglikeiid(antclust); colvec trunclikeiid(antclust); if (iid==1) { thetiid.fill(0); loglikeiid.fill(0); trunclikeiid.fill(0); } vec p11tvec(antclust); vec Utheta(pt); vec vthetascore(pt); vec pthetavec(pt); vec vtheta2(pt); mat DUtheta(pt,pt); DUtheta.fill(0); Utheta.fill(0); // if (!Utheta.is_finite()) { Rprintf(" NA's i def U\n"); Utheta.print("U"); } // if (!DUtheta.is_finite()) { Rprintf(" NA's i def DU\n"); DUtheta.print("DU"); } int nr=rvdes.n_cols; vec rv2(nr),rv1(nr); vec etheta=theta; vec wwc(4); // }}} for (j=0;j=2) { R_CheckUserInterrupt(); diff=0; for (c=0;c(inrvs); IntegerVector nrvs(inrvs); mat clusterindex = Rcpp::as(iclusterindex); colvec theta = Rcpp::as(itheta); int pt=theta.n_rows; mat ags = Rcpp::as(iags); colvec clustsize = Rcpp::as(iclustsize); // this is number of pairs (rather than clusters) int antclust= clusterindex.n_rows; colvec cause = Rcpp::as(icause); colvec pmargsurv = Rcpp::as(ipmargsurv); colvec cluster = Rcpp::as(icluster); colvec weights = Rcpp::as(iweights); // colvec entryage = Rcpp::as(ientryage); colvec trunkp = Rcpp::as(itrunkp); colvec secluster = Rcpp::as(isecluster); // mat rvdes= Rcpp::as(irvdes); int depmodel= Rcpp::as(idepmodel); int ascertained= Rcpp::as(iascertained); IntegerVector strata(istrata); // array for derivative of flexible design NumericVector DXthetavec(iDXtheta); IntegerVector arrayDims(idimDX); arma::cube DXtheta(DXthetavec.begin(), arrayDims[0], arrayDims[1], arrayDims[2], false); //printf(" mig thetades 222222\n"); // array for parameter restrictions (one for each pair) pairs * (ant random effects)* (ant par) NumericVector thetadesvec(ithetades); IntegerVector arrayDims1(idimthetades); IntegerVector arrayDD(3); //printf(" mig thetades 222222\n"); //printf(" %d %d %d \n",arrayDims1[0],arrayDims1[1],arrayDims1[2]); arrayDD[2]=1; if (depmodel==3) { arrayDD[0]=arrayDims1[0]; arrayDD[1]=arrayDims1[1]; arrayDD[2]=arrayDims1[2]; } else { arrayDD[0]=1; arrayDD[1]=1; arrayDD[2]=1; } arma::cube thetadesi(thetadesvec.begin(), arrayDD[0], arrayDD[1], arrayDD[2], false); //printf(" mig cube thetades 222222\n"); // mat thetades(arrayDD[0],arrayDD[1]); // if (depmodel!=3) // mat thetades=mat(arrayDims1[0],arrayDims1[1]*arrayDD[2],thetadesvec.begin()); mat thetades=mat(thetadesvec.begin(),arrayDims1[0],arrayDims1[1]*arrayDD[2],false); //printf(" mig rvdes \n"); // array for parameter restrictions (one for each pair) pairs * (ant random effects)* (ant par) // array for pairwise random effects (two vectors for each pair) pairs * 2* (ant random effects) // mat rvdes= Rcpp::as(irvdes); NumericVector rvdesvec(irvdes); IntegerVector arrayDims2(idimrvdes); if (depmodel==3) { arrayDD[0]=arrayDims2[0]; arrayDD[1]=arrayDims2[1]; arrayDD[2]=arrayDims2[2]; } else { arrayDD[0]=1; arrayDD[1]=1; arrayDD[2]=1; } // printf("rvdesC %d %d %d \n",arrayDD[0], arrayDD[1], arrayDD[2]); arma::cube rvdesC(rvdesvec.begin(), arrayDD[0], arrayDD[1], arrayDD[2], false); // mat B=rvdesC.slice(1); B.print("rv.1"); // mat A=rvdesC.slice(0); A.print("rv.1"); // printf(" her er lidt knas\n"); mat rvdes=mat(rvdesvec.begin(),arrayDims2[0],arrayDims2[1]*arrayDD[2],false); // if (depmodel!=3) { // mat rvdes = Rcpp::as(irvdes); // } else mat rvdes(arrayDims2[1],arrayDims2[2]); // printf(" not !\n"); // thetades.fill(0); int varlink= Rcpp::as(ivarlink); int silent = Rcpp::as(isilent); int iid= Rcpp::as(iiid); int antiid = Rcpp::as(iantiid); mat Xtheta = Rcpp::as(iXtheta); int ci,ck,i,j,s=0,k,c1; double dl1,dl2,ll1,ll2,ll=1,Li,Lk,sdj=0,diff=0,loglikecont=0; double Lit=1,Lkt=1,llt=1,deppar=1,ssf=0,thetak=0,dddl=0.000001; double d2=0,asign=-1; if (ascertained==2) asign=1; // double plack(); vec dplack(pt); dplack.fill(0); vec dplackt(pt); dplackt.fill(0); vec dplackt1(pt); dplackt1.fill(0); vec dplackt2(pt); dplackt2.fill(0); mat dp1(pmargsurv.n_rows,pt); dp1.fill(0); mat dp2(pmargsurv.n_rows,pt); dp2.fill(0); i=silent+1; mat thetiid(antiid,pt); colvec loglikeiid(antclust); colvec trunclikeiid(antclust); if (iid==1) { thetiid.fill(0); loglikeiid.fill(0); trunclikeiid.fill(0); } colvec p11tvec(antclust); colvec Utheta(pt); colvec vthetascore(pt); colvec pthetavec(pt); vec vtheta2(pt); mat DUtheta(pt,pt); DUtheta.fill(0); Utheta.fill(0); // if (!Utheta.is_finite()) { Rprintf(" NA's i def U\n"); Utheta.print("U"); } // if (!DUtheta.is_finite()) { Rprintf(" NA's i def DU\n"); DUtheta.print("DU"); } int nr=1; if (depmodel==3) nr=arrayDD[2]; vec rv2(nr),rv1(nr); vec etheta=theta; vec wwc(2); // // // }}} colvec likepairs(antclust); for (j=0;jT2, // since T2 is the first jump) // we handle this by giving the cumulatives of ascertainment // pairs/controls appropriately RcppExport SEXP survivalloglikeRVpairs( SEXP icause, SEXP ipmargsurv, SEXP itheta, SEXP iXtheta, SEXP iDXtheta, SEXP idimDX, SEXP ithetades,SEXP icluster,SEXP iclustsize,SEXP iclusterindex, SEXP iiid, SEXP iweights, SEXP isilent, SEXP idepmodel, // SEXP ientryage, SEXP itrunkp , SEXP istrata, SEXP isecluster, SEXP iantiid, SEXP irvdes, SEXP idimthetades, SEXP idimrvdes, SEXP inrvs , SEXP iags,SEXP ientrycause, SEXP iascertained ) { // {{{ try { // {{{ // setting matrices and vectors, and exporting to armadillo matrices // // {{{ // colvec nrvs = Rcpp::as(inrvs); int ascertained= Rcpp::as(iascertained); // 1= ascertained or casecontrol, controlled via trunkp IntegerVector nrvs(inrvs); IntegerVector entrycause(ientrycause); IntegerVector cause(icause); mat clusterindex = Rcpp::as(iclusterindex); colvec theta = Rcpp::as(itheta); int pt=theta.n_rows; colvec clustsize = Rcpp::as(iclustsize); // this is number of pairs (rather than clusters) int antclust = clusterindex.n_rows; mat pmargsurv = Rcpp::as(ipmargsurv); mat trunkp = Rcpp::as(itrunkp); mat ags = Rcpp::as(iags); colvec cluster = Rcpp::as(icluster); colvec weights = Rcpp::as(iweights); colvec secluster = Rcpp::as(isecluster); // mat rvdes= Rcpp::as(irvdes); // colvec entryage = Rcpp::as(ientryage); int depmodel = Rcpp::as(idepmodel); IntegerVector strata(istrata); vec all(4); // array for derivative of flexible design NumericVector DXthetavec(iDXtheta); IntegerVector arrayDims(idimDX); arma::cube DXtheta(DXthetavec.begin(), arrayDims[0], arrayDims[1], arrayDims[2], false); // array for parameter restrictions (one for each pair) pairs * (ant random effects)* (ant par) NumericVector thetadesvec(ithetades); IntegerVector arrayDims1(idimthetades); IntegerVector arrayDD(3); //printf(" %d %d %d \n",arrayDims1[0],arrayDims1[1],arrayDims1[2]); if (depmodel==3) { arrayDD[0]=arrayDims1[0]; arrayDD[1]=arrayDims1[1]; arrayDD[2]=arrayDims1[2]; } else { arrayDD[0]=1; arrayDD[1]=1; arrayDD[2]=1; } arma::cube thetadesi(thetadesvec.begin(), arrayDD[0], arrayDD[1], arrayDD[2], false); //printf(" mig cube thetades 222222\n"); // mat thetades(arrayDD[0],arrayDD[1]); // if (depmodel!=3) // mat thetades=mat(arrayDims1[0],arrayDims1[1]*arrayDD[2],thetadesvec.begin()); mat thetades=mat(thetadesvec.begin(),arrayDims1[0],arrayDims1[1]*arrayDD[2],false); //printf(" %d %d %d \n",arrayDD[0], arrayDD[1], arrayDD[2]); //printf(" mig rvdes \n"); // array for parameter restrictions (one for each pair) pairs * (ant random effects)* (ant par) // array for pairwise random effects (two vectors for each pair) pairs * 2* (ant random effects) // mat rvdes= Rcpp::as(irvdes); NumericVector rvdesvec(irvdes); IntegerVector arrayDims2(idimrvdes); if (depmodel==3) { arrayDD[0]=arrayDims2[0]; arrayDD[1]=arrayDims2[1]; arrayDD[2]=arrayDims2[2]; } else { arrayDD[0]=1; arrayDD[1]=1; arrayDD[2]=1; } // printf(" %d %d %d \n",arrayDD[0], arrayDD[1], arrayDD[2]); arma::cube rvdesC(rvdesvec.begin(), arrayDD[0], arrayDD[1], arrayDD[2], false); mat rvdes=mat(rvdesvec.begin(),arrayDims2[0],arrayDims2[1]*arrayDD[2],false); int silent = Rcpp::as(isilent); int iid= Rcpp::as(iiid); int antiid = Rcpp::as(iantiid); mat Xtheta = Rcpp::as(iXtheta); int ci,ck,i,j,s=0,k,c1; double ll=1,loglikecont=0; double llt=1,ssf=0,thetak; vec dplack(pt); dplack.fill(0); vec dplackt(pt); dplackt.fill(0); i=silent+1; mat thetiid(antiid,pt); colvec loglikeiid(antiid); colvec trunclikeiid(antiid); if (iid==1) { thetiid.fill(0); loglikeiid.fill(0); trunclikeiid.fill(0); } colvec p11tvec(antclust); // colvec Utheta(pt); colvec vthetascore(pt); colvec pthetavec(pt); vec vtheta2(pt); mat DUtheta(pt,pt); DUtheta.fill(0); Utheta.fill(0); // printf("2 her er lidt knas\n"); vec etheta=theta; mat Dcif(arrayDims2[0]/2,pt); // Dcif.print("Dcif"); // // }}} colvec likepairs(antclust); mat matlikepairs(antclust,6); vec allvec(6); // wall_clock timer; timer.tic(); //printf(" thomas \n"); for (j=0;j0) || any(trunkp.row(k)>0)) { // /*{{{*/ vec Lit=trans(trunkp.row(i)); vec Lkt=trans(trunkp.row(k)); if (j<-10) { Rprintf(" så betinges der ! %d %d %d %d \n",entrycause(i),entrycause(k),cause(i),cause(k)); Lit.print("Lit"); Lkt.print("Lkt"); Lk.print("Lk"); } if (ascertained==0) // standard left truncation, both surviving Lit, Lkt llt=survivalRVC2(etheta,thetadesv,ags,0,0,Lit,Lkt,rv1,rv2,dplackt,allvec); if (ascertained==1) // ascertainment correction depending on cumulative hazards of proband Lkt // case control adjustment depending on cumulative hazards of proband Lkt llt=survivalRVC2(etheta,thetadesv,ags,0,cause(k),Lit,Lkt,rv1,rv2,dplackt,allvec); ll=survivalRVC2(etheta,thetadesv,ags,cause(i),cause(k),Li,Lk,rv1,rv2,dplack,allvec); // printf("%d %lf %lf \n",j,ll,llt); // printf(" så betinges der ! %d %d %d %d \n",entrycause(i),entrycause(k),cause(i),cause(k)); // Li.print("Li"); Lk.print("Lk"); Lit.print("Lit"); Lkt.print("Lkt"); ssf+=weights(i)*(log(ll)-log(llt)); loglikecont=(log(ll)-log(llt)); vthetascore=dplack/ll-dplackt/llt; /*}}}*/ } else {/*{{{*/ // printf("hhhhh %d %d %d %d %d \n",ascertained,i,k,(int) ci,(int) ck); ll=survivalRVC2(etheta,thetadesv,ags,cause(i),cause(k),Li,Lk,rv1,rv2,dplack,allvec); ssf+=weights(i)*log(ll); loglikecont=log(ll); if (j<-10) { etheta.print("theta"); Li.print("Li"); Lk.print("Lk"); Rprintf("%d %d %lf %lf \n",cause(i),cause(k),weights(i),ll); allvec.print("allvec"); dplack.print("dll"); } vthetascore=dplack/ll; } /*}}}*/ // }}} } else if (depmodel==2) { // not possible only additive gamma model } if (depmodel!=3) { } else { // additive gamma structure DUtheta+=weights(i)*vthetascore*trans(vthetascore); vthetascore=weights(i)*vthetascore; Utheta=Utheta+vthetascore; } if (iid==1) { for (c1=0;c1]@!<Śg=sZnKT}<ɴ0m9FIJ(/WWҮH-B[H6Y xZQ@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@)o/%[2A8ry VG&\E'V0?4(C(M~. "M4?)imu,ڶ;C' 8z*)e1-@qhC#<[ F?M~_~ZPG%?7&J4oMk@h?(5ERլu6-.R봩Ps5vri.kb ( ( Okq) R*z?-jPhO&Jo'[4P7%Z7?~Ig_~p]K"9O0UsQ V?O~$hF5okJ-Nwc\^ c@He9 89 s(Jo'H-gKX+9 Nrq8 M4?)?4*MFL捷(z}ޥZҥ1;72Χ{qQ.F +GRQߗi4 x#xkb2?(4Qߗk^G/ F?M~_z(#~G%?7& 7{I(H`Ҭ>_I(((({wek[57067E4ad:W![ ŀ-*pA)WUD<3BQ5jDtM?KwY2АjG((ExV]IU/(lXsY VFR1{1v_:Ǹ,@ wfu_ ?GG(V θFc 0GSEǁ win72\0x#(?9/Y:46Wwh8iPEPEPA u8EVH1@9jї5X9jї5@Q@Q@fo_5+J|RM&ďUgAhFN_pxEu"wH(wG((Z4+ӭ,o< t3uCZ𭎻yԒ^Pر u_ ?GG(8x]e;FKlDg9[J`<`F0HP[u9>WU` €(\xJv`p@XC!%#9o?˚_A]WT~q=s4"#<,TN]:Т((BBf 2I@p?"d~G {ZT*mױ4#C آ((5˫KH0Y #vLVVnBjFUg,P8bI*H$CHkNJӵTDl-oUn!YQW;_:Ʊ[5j.mnL[Nzk` €]? ?&i~EZF͹%@?+Q ?u_ ?@XjZ2pczm}ׯ8aGBj~g$˖LB Ty5?+Q ?u_ ?@">nkDi W8T8oN¥5a ?QEQETayA zVn [B$imw_c2=h|S"k[nޏCZؠ((((((f@3Y_6_n&Q'V i)`g R^EA 69jї5X9jї5@Q@Q@cA҈bI oYDtEPEPEPEPEPEPYʖf,#*$m:fz{\}_v uj^:+Ynh[#Ib=zYcXm4f$h b.NYrORkkHLj??'6((ִJm%Ļx(vlR6rio4FWs#9` 7-@@> υ(Gs[Ճ [w5@Q@Q@Q@Q@Q@ +28*K21ltι_#J(((((wpc}9>\] kَ=;J DwvU9E}W["Gho/vTgǥGXMeIw˫cT;P*h>F\c>F\QEKVm7M! 9`2H3ppPGut溒I.X[*0vᔌVwut kjwN Һe  XTtEQEQEQEQEQEEspdS ]^饸0<#'j$G0oV?3o ?QEQEQEQE LY< (O`;I؛I].&,<@'?S,X[2R,b:G5^{,V2\귪yP H˜dN$%.~y\'z;TE]38&;E{M:P HYĒW?(tv*Z^QZBO䵱X!'Zؠ(((cCRz>!ȏ?5+((((( ]M)f{Vi$j[pNGT5FJ{`YQܓS7>  Z~a\ݦ{7 #ŧ,x.Ak /PmslfI+Z?elV=Z?elPEPEP\cak*e  XTtEQEQEQEQEV7nПv=@9'Gu3*+M.=y5I$SC"D|?1% d{PP*ZѠ/AYp+4B tjǶS}ǶS}((+-aQC\cak*:( ( ( ( (*jS,demp~l6nLL]D,ϻJ|w>P:GlZgs}^>%iH-HF;ܓq@2"Ɗ00:(}#C ج}#C آ((6jɧ O5cc  G9zխ Z=)cyc&搹H.Imۓ<|NdJGB =4:*m i5wpe}͖r',hկa}6WTe6-.GXz|A! Q淨(((nfb?1TĀ2N-FQݶD=M)(^y>IݡN%>ۘiiZt6pk;}3䜒}Md[/x̵[̞CMtGPYqO&ih}*`vLM|wR*P0jZŠ( }j-lV>_I(((("=Ԯ_#J(((ksP[ɘEG`뺓vm=ì`zV3'jii|6Vq(\evlu$ܓ[D^`W+J5 ( (1BO䵱X!'Zؠ(( :u&&Hcb k3AӯtfK- Ey?.xFc!ȏ?5+/&D'XWi@Q@Q@Q@f^nXZȱ!v\[iqJK T9bEP+KU>olUw,Q,jN1֞iVkkjŞF'%%PpKXq&Fa{ ڳI),2;thUa3Z(( {o?˚ج{o?˚ؠ((*Ut5xAV?Ҩ((((ojG~Cn:R~@pmK_%m٣&5| dxrEr 7ٮAoC*p:%QEc[c@QEQEQE`C>oV?3o ?QEQEԦ(秽OXzߓŐ#0+#c4LʮjlU2NO,q R]/Saxrܘ$䍣k`n>]e4a PVZqZMb(OEQaEPEP>_I+@گ$K[QEQEɡ HR2H>DcӬmCV1F:n#S("=Ԯ_#J((S ['4F\Q+cuf<\/"4@@5oSMKq=Ă(`nlq$Tz&>u]9m`7zvq@D>qkND1zSDTldzTQEQEm#`Os[m#`Os[QEU oKΑq`g _2 t;)-o2_4`Ƨj >\I=Up^S؝{3G̶W_\cak*:( ( ( (, M#FMyՎu9PXa ?c{Ukb ( +:ƋAhK)In XqQ޴4맾.’LI1PJ8(Q@/އFt|BjWO@Q@Q@g˺@/\zeF\=k̆S3W 嶂+qA@N`\HG [g[A$J̱ +XE A  ۉ<=?Z}Q@Q@Q@9jї5X9jї5@W;_3D")!yhq6mzPEEP\cak*e  XTtEQEQEQEUf0X1W_Ozo6E C2^8R8ykwP@Dc^k[$`@5/ ~{,g81(>P7kШ((}#C ج}#C آ((J°agt?ZHid IiP?3o ?`C>oPEPEBc s}--}r# m&4=:XmɊ,ԞI~&;S4:t"f^2$}ʟ ]lCVhg [袊@(((@گ$K[}W%(_!ȏ?5+cCRz((~q3Gk=Z[ Y 8E%:`]$ϴ0$vgd6VVVЪy2q4gXC7984Q@Q@Q@Q@9jї5X9jї5@r7FIHf ٙFcnGkVmlFJu-a>u<AwQExAV?Ҩ롮{_ G@ Q@Q@Q@q_&EʗU6Fk43W]y"l<:urJ(;b4PE$Q* ;``U@U0K@Q@Q@c~Gc~GQ@ޭ&ӼOeuoo`+3*qyWZY-LѫM¨V/ڻ (|-aG;ެg#(*mc4*$NXcWr {y\]ʖ>3N=3S'etLKy%( \8 F ǿͿB+ >;xB$繭:qVVǕ$QE2((( }j-lV>_I((k \}}E۸3ZtiE,(cs)PA8k4kIYU(̛vsI+wLO&J`|;j(cCRz>!ȏ?5+(* DpnaP*]~ $I*1w.>Z#=+f^ߺan`?*s]X (((((G-O2+G-O2([V6ޣ  UEܶ[KiaVI9Ă쨢+-aQC\cak*:( ( ()kcOpj ; ¹OKas![QAuTTI7Ҽ>FA0(. S]}0N2F1 4QEQEQEc[c@QEs:5ϋje8Up;XpG 8M\G-ƶ k5Hɏ0i0*@#Vdc(?؅RǠ5uZ%B}Tb=A.դg=Zl)‹~%UQ@Q@Q@Q@!'Zج}j-lPEP%]6ѯ*Yd!$#|ו )_9E@IwyRMvV$D<`~!#Xt(3$*>`@"[^ 2GcyPaEPEPEYp쪱9n@j~)īV 1Wb~ ]q?-}>_HV@ܰa>m@Q@Q@Q@c~Gc~GQ@񕴰O$.0^Y ݍɉ3D&Fp}sZ:OiѾ<,?( uGU7B>ɧ޹Ay|Qnv4襆xcL1)W,H tVSVӍ3?o&ݩF\c>F\H|`'(Eb ; >_jUQrwV<?t3^EP\cak*e  XTtEQEW&D`r꒭lMkK7P5oMa,u B."AS&k*,hP:{~­EQEQEQEc[c@QEs:5ϋje8Up;XpG 8MEQE [w5X> υ(Gs[QE2N_S"U[E%8AkSd>"5Bm } 9kꜻ_QEfEPEPEPEP>_I+@گ$K[QEQEQE|BjWO\/އFtTsa*Jnֺ@$_&$Sd|* 3{h?PkSl}ܹ5fdV*k@Q@Q@Q@Q@Q@9jї5X9jї5@Q@Q@s2U?:k-aQCEPEPK1Oj|ϩj#%V&{i 1C*=)EhP}7z;lsLj(ǫ*xtY D002}OhV(((( x#xkb x#xhb((( g#|-aG;ޠ7wMD|jr2nF&VEXjfb*6{–O-/ :o_I(((("=Ԯ_#J/T]SĶl2F U4a@ kbBJ ˧D5$ZuMT"-PEPEPEPEPEP=Z?elV=Z?elPEPEP\cak*e  XTtEQExN? hJ~Wkˀ9}&MoV<t)B7I1PEPEPEPEPXG_I(((2D&Hwf7ڥʺQFTRF3}B v` i-Ņ0L`H# lAfh:]%Iġc\;vo#1h&u -GCsg\%_BoѝjP ~DZ1b鴣n?~uXzBgg~"VQEQEQEQEQEQEc>F\c>F\QEvqu_I+@گ$K[QEQEQE|BjWO\/އFt^R#~rGG1:ܬO|)NMf>c٫n ( ( ( ( ( (1ri.kbri.kb ( ( e  XTu=/XZJ(S.=oy-,zm@LWIei x$iQ7{}J ,`d M]QEQEQEQEQEc[c@QEQEVP::zd)rh`H€j(+E&M4aEUQEQEQEQEQEc{UkbBO䵱@Q@Q@Q@/އFt71Y\]Jq1}?ʹ_#Jf;=B@xrE`C>KỸcGT٪/g#C.[(5lHE5>gW~QVhQEQEQEQEQEQEc{UkbBO䵱@Q@Q@Q@/އF^G:{\B~!O lV>!O lQEQEQE [w56n˸ > υ(GsSrNBrZ\ILJQ=k3~fQVhQEQEQEQEQEQEc{UkbBO䵱@Q@Q@Q@/އF^ֹ<<KiBjUxF\\!jQ@Q@Q@Q@Q@Q@Q@9jї5X9jї5@Q@Q@s2U?:k-aQxHʉ|y8q Т,hT`0oY#Q񎃦f>{SciK]-QEQEQEQEQEQEc[c@QEQET֚}@2M E2xAwnG42 ea/?3o ?,rLᲂ?琟?3o ?\D=f=ĭnFg=3^(4 ( ( ( ( ( (1BO䵱X!'Zؠ(( C&z44 %S9a5{KkT)hNkOvq6M41A$3"QцC) JaayF g,I2hzׇmb#4X>O׏2!fO*WN[S"k[QEQEQEQEQEQEQEm#`Os[m#`Os[QEU-]oLiV+wm21gEfhkM39&LwNBGhٮdA;1ğG@ҥz,(!4y*բ((((((+HLj??'+HLj??'6((#–eٸ7 ZY82sx<6ѾD$64ݸA;gk{ "&ʁQ,q¢ =gT:!ڭ,ⶏRinʘ 9-n5 $uoˎEj!OAzؤvaESQEQEQEQEQEQE}W%>a ?QEQEQEWQaCR>:MzeŒBbƳv-.DJꪔΡ%S1+;H #  #4~?Z/Pt &rKu('h N ׿kp.XCn~%Cy{jCua^`wg'jYAl^6,*TAP?!gk<KFYκ/ *fݭ%?Lovk>= P}>]7m!ۭm;p <⺩dHbyd`YK4@H{$O(c~Tlg7 3(?Cy{jX s+hmC2 #uFAK@͏,Oks1):;3-}jCy{k~, O,K3u4,67:pu2 :w3~^ڗ 2 'ߕ3qEiR$1PA"f>WݹqhCy{j`]CNX.u߳.1cc?uP!gk<ַ;[kzv 7W\@#1fƒ@xVnkb4E7k7dyv =6VZiI2ډ}'#Mq$ʹ.K;@{Un^07I9WxW5{MKId JdhQ@Q@Q@.T(̍uld ^c8%Mθ\'W<{uuuJWT[(ːI@ܤaA3?[3~^߬wMh$&hLa6vPI'k #oskw< p*!gk<"Dgx1ypHoOgnqqZ]Eso IFR2(|#z}κoVCo['vpy]?Lov Cy{jsܨzj鮮{جh9ڥI>²ϋtA%yNg)~'E~?Z/ջ_WQAr+@ N8JFv@k:؍_c |2~w3~^ߢ0??[~ukZ(X3ϥlj -/nS F0J<[&A"yyQ;f446Kh-V@F21K9$unXjV/-*6#)l`AtQEQEQEVeoi=K31쉈c<8:(KE%IfyQ㉣Cn^7(o {KWLX2* a~\dsSE 8/dIbvvOߘaF6_((_HYki(9Ex0wEs/}9^χN-܏ǟHGYBB4,Qp7''ߊӢ ( ( ( Ҵ;}"Ifti "8бT\ܜ~+N+.B DW10@e#+ZP3o}:eACnۼSVZ~men%0'jOTPEP7P}I o>\xL$..4(͆@@l(|WQEaXV.cvt^w!ƒVPEPN]uپc7{6m 1`9k(dzdsiA$Ws0EA@utW ( ( ( ( ( ( aEKʯ[FG5EqmiM* 0>O ɔ ПW_߼k?_c]0mݐsӌVQEQEQEQEQEQEQEQEQEQE{}JKUҤ.U'ɑP n܂{g%V\7 PXc2r~WEaxuuMɸZqnU+݃+v(((((((((gWϴ||۸ٟ3{;~nZP("eY>|둿s?'\~,)x'HE[89~$b(-rs 3-iFvXq _:^5F'[.75@wQu{=J{k2;nhRTF;qwf;ǵY.a,Џ1dJuIEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEmets/vignettes/binomial-twin.ltx0000644000176200001440000010207413623061405016540 0ustar liggesusers%\VignetteIndexEntry{Analysis of bivariate binomial data: Twin analysis} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Analysis of bivariate binomial data: Twin analysis} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Analysis of bivariate binomial data: Twin analysis}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Overview} \label{sec:orgc699b56} When looking at bivariate binomial data with the aim of learning about the dependence that is present, possibly after correcting for some covariates many models are available. \begin{itemize} \item Random-effects models logistic regression covered elsewhere (glmer in lme4). \end{itemize} in the mets package you can fit the \begin{itemize} \item Pairwise odds ratio model \item Bivariate Probit model \begin{itemize} \item With random effects \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \item Additive gamma random effects model \begin{itemize} \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \end{itemize} Typically it can be hard or impossible to specify random effects models with special structure among the parameters of the random effects. This is possible in our models. To be concrete about the model structure assume that we have paired binomial data \(Y_1, Y_2, X_1, X_2\) where the responses are \(Y_1, Y_2\) and we have covariates \(X_1, X_2\). We start by giving a brief description of these different models. First we for bivariate data one can specify the marginal probability using logistic regression models \[ logit(P(Y_i=1|X_i)) = \alpha_i + X_i^T \beta i=1,2. \] These model can be estimated under working independence \cite{zeger-liang-86}. A typical twin analysis will typically consist of looking at both \begin{itemize} \item Pairwise odds ratio model \item Bivariate Probit model \end{itemize} The additive gamma can be used for the same as the bivariate probit model but is more restrictive in terms of dependence structure, but is nevertheless still valuable to have also as a check of results of the bivariate probit model. \subsection*{Biprobit with random effects} \label{sec:org86402a4} For these model we assume that given random effects \(Z\) and a covariate vector \(V_{12}\) we have independent logistic regression models \[ probit(P(Y_i=1|X_i, Z)) = \alpha_i + X_i^T \beta + V_{12}^T Z i=1,2. \] where \(Z\) is a bivariate normal distribution with some covariance \(\Sigma\). The general covariance structure \(\Sigma\) makes the model very flexible. We note that \begin{itemize} \item Paramters \(\beta\) are subject specific \item The \(\Sigma\) will reflect dependence \end{itemize} The more standard link function \(logit\) rather than the \(probit\) link is often used and implemented in for example \cite{mm}. The advantage is that one now gets an odds-ratio interpretation of the subject specific effects, but one then needs numerical integration to fit the model. \#We note that \subsection*{Pairwise odds ratio model} \label{sec:orgf29d361} Now the pairwise odds ratio model the specifies that given \(X_1, X_2\) the marginal models are \[ logit(P(Y_i=1|X_i)) = \alpha_i + X_i^T \beta i=1,2 \] The primary object of interest are the odds ratio between \(Y_{1}\) and \(Y_{2}\) \[ \gamma_{12} = \frac{ P( Y_{ki} =1 , Y_{kj} =1) P( Y_{ki} =0 , Y_{kj} =0) }{ P( Y_{ki} =1 , Y_{kj} =0) P( Y_{ki} =0 , Y_{kj} =1) } \] given \(X_{ki}\), \(X_{kj}\), and \(Z_{kji}\). We model the odds ratio with the regression \[ \gamma_{12} = \exp( Z_{12}^T \lambda) \] Where \(Z_{12}\) are some covarites that may influence the odds-ratio between between \(Y_{1}\) and \(Y_{2}\) and contains the marginal covariates, \cite{carey-1993,dale1986global,palmgren1989,molenberghs1994marginal}. This odds-ratio is given covariates as well as marginal covariates. The odds-ratio and marginals specify the joint bivariate distribution via the so-called Placckett-distribution. One way of fitting this model is the ALR algoritm, the alternating logistic regression ahd this has been described in several papers \cite{kuk2004permutation,kuk2007hybrid,qaqish2012orthogonalized}. We here simply estimate the parameters in a two stage-procedure \begin{itemize} \item Estimating the marginal parameters via GEE \item Using marginal estimates, estimate dependence parameters \end{itemize} This gives efficient estimates of the dependence parameters because of orthogonality, but some efficiency may be gained for the marginal parameters by using the full likelihood or iterative fitting such as for the ALR. The pairwise odds-ratio model is very useful, but one do not have a random effects model. \subsection*{Additive gamma model} \label{sec:orgdb54e35} Again we operate under marginal logistic regression models are \[ logit(P(Y_i=1|X_i)) = \alpha_i + X_i^T \beta i=1,2 \] First with just one random effect \(Z\) we assume that conditional on \(Z\) the responses are independent and follow the model \[ logit(P(Y_i=1|X_i,Z)) = exp( -Z \cdot \Psi^{-1}(\lambda_{\bullet},\lambda_{\bullet},P(Y_i=1|X_i)) ) \] where \(\Psi\) is the laplace transform of \(Z\) where we assume that \(Z\) is gamma distributed with variance \(\lambda_{\bullet}^{-1}\) and mean 1. In general \(\Psi(\lambda_1,\lambda_2)\) is the laplace transform of a Gamma distributed random effect with \(Z\) with mean \(\lambda_1/\lambda_2\) and variance \(\lambda_1/\lambda_2^2\). We fit this model by \begin{itemize} \item Estimating the marginal parameters via GEE \item Using marginal estimates, estimate dependence parameters \end{itemize} To deal with multiple random effects we consider random effects \(Z_i i=1,...,d\) such that \(Z_i\) is gamma distributed with mean \(\lambda_j/\lambda_{\bullet}\) and variance \(\lambda_j/\lambda_{\bullet}^2\), where we define the scalar \(\lambda_{\bullet}\) below. Now given a cluster-specific design vector \(V_{12}\) we assume that \[ V_{12}^T Z \] is gamma distributed with mean 1 and variance \(\lambda_{\bullet}^{-1}\) such that critically the random effect variance is the same for all clusters. That is \[ \lambda_{\bullet} = V_{12}^T (\lambda_1,...,\lambda_d)^T \] We return to some specific models below, and show how to fit the ACE and AE model using this set-up. One last option in the model-specification is to specify how the parameters \(\lambda_1,...,\lambda_d\) are related. We thus can specify a matrix \(M\) of dimension \(p \times d\) such that \[ (\lambda_1,...,\lambda_d)^T = M \theta \] where \(\theta\) is d-dimensional. If \(M\) is diagonal we have no restrictions on parameters. This parametrization is obtained with the var.par=0 option that thus estimates \(\theta\). The DEFAULT parametrization instead estimates the variances of the random effecs (var.par=1) via the parameters \(\nu\) \[ M \nu = ( \lambda_1/\lambda_{\bullet}^2, ...,\lambda_d/\lambda_{\bullet}^2)^T \] The basic modelling assumption is now that given random effects \(Z=(Z_1,...,Z_d)\) we have independent probabilites \[ logit(P(Y_i=1|X_i,Z)) = exp( -V_{12,i}^T Z \cdot \Psi^{-1}(\lambda_{\bullet},\lambda_{\bullet},P(Y_i=1|X_i)) ) i=1,2 \] We fit this model by \begin{itemize} \item Estimating the marginal parameters via GEE \item Using marginal estimates, estimate dependence parameters \end{itemize} Even though the model not formaly in this formulation allows negative correlation in practice the paramters can be negative and this reflects negative correlation. An advanatage is that no numerical integration is needed. \section*{The twin-stutter data} \label{sec:orgf3a7afd} We consider the twin-stutter where for pairs of twins that are either dizygotic or monozygotic we have recorded whether the twins are stuttering \cite{twinstut-ref} We here consider MZ and same sex DZ twins. Looking at the data \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) data(twinstut) twinstut$binstut <- 1*(twinstut$stutter=="yes") twinsall <- twinstut twinstut <- subset(twinstut,zyg%in%c("mz","dz")) head(twinstut) \end{lstlisting} \begin{verbatim} Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.5.1 mets version 1.2.1.2 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined Warning message: failed to assign RegisteredNativeSymbol for cor to cor since cor is already defined in the ‘mets’ namespace tvparnr zyg stutter sex age nr binstut 1 2001005 mz no female 71 1 0 2 2001005 mz no female 71 2 0 3 2001006 dz no female 71 1 0 8 2001012 mz no female 71 1 0 9 2001012 mz no female 71 2 0 11 2001015 dz no male 71 1 0 \end{verbatim} \section*{Pairwise odds ratio model} \label{sec:orgbf74e81} We start by fitting an overall dependence OR for both MZ and DZ even though the dependence is expected to be different across zygosity. The first step is to fit the marginal model adjusting for marginal covariates. We here note that there is a rather strong gender effect in the risk of stuttering. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} margbin <- glm(binstut~factor(sex)+age,data=twinstut,family=binomial()) summary(margbin) \end{lstlisting} \begin{verbatim} Call: glm(formula = binstut ~ factor(sex) + age, family = binomial(), data = twinstut) Deviance Residuals: Min 1Q Median 3Q Max -0.4419 -0.4078 -0.2842 -0.2672 2.6395 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) -3.027625 0.104012 -29.108 < 2e-16 *** factor(sex)male 0.869826 0.062197 13.985 < 2e-16 *** age -0.005983 0.002172 -2.754 0.00588 ** --- Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 9328.6 on 21287 degrees of freedom Residual deviance: 9117.0 on 21285 degrees of freedom AIC: 9123 Number of Fisher Scoring iterations: 6 \end{verbatim} Now estimating the OR parameter. We see a strong dependence with an OR at around 8 that is clearly significant. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} bina <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,detail=0) summary(bina) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se dependence1 2.085347 0.1274536 $or Estimate Std.Err 2.5% 97.5% P-value dependence1 8.05 1.03 6.04 10.1 4.3e-15 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} Now, and more interestingly, we consider an OR that depends on zygosity and note that MZ have a much larger OR than DZ twins. This type of trait is somewhat complicated to interpret, but clearly, one option is that that there is a genetic effect, alternatively there might be a stronger environmental effect for MZ twins. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # design for OR dependence theta.des <- model.matrix( ~-1+factor(zyg),data=twinstut) bin <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,theta.des=theta.des) summary(bin) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(zyg)dz 0.5221651 0.2401355 factor(zyg)mz 3.4853933 0.1866076 $or Estimate Std.Err 2.5% 97.5% P-value factor(zyg)dz 1.69 0.405 0.892 2.48 3.12e-05 factor(zyg)mz 32.64 6.090 20.699 44.57 8.38e-08 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} We now consider further regression modelling of the OR structure by considering possible interactions between sex and zygozsity. We see that MZ has a much higher dependence and that males have a much lower dependence. We tested for interaction in this model and these were not significant. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} twinstut$cage <- scale(twinstut$age) theta.des <- model.matrix( ~-1+factor(zyg)+factor(sex),data=twinstut) bina <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,theta.des=theta.des) summary(bina) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(zyg)dz 0.8098841 0.3138423 factor(zyg)mz 3.7318076 0.2632250 factor(sex)male -0.4075409 0.3055349 $or Estimate Std.Err 2.5% 97.5% P-value factor(zyg)dz 2.248 0.705 0.865 3.63 0.001441 factor(zyg)mz 41.755 10.991 20.213 63.30 0.000145 factor(sex)male 0.665 0.203 0.267 1.06 0.001064 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \subsection*{Alternative syntax} \label{sec:org3f01206} We now demonstrate how the models can fitted jointly and with anohter syntax, that ofcourse just fits the marginal model and subsequently fits the pairwise OR model. First noticing as before that MZ twins have a much higher dependence. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # refers to zygosity of first subject in eash pair : zyg1 # could also use zyg2 (since zyg2=zyg1 within twinpair's) out <- easy.binomial.twostage(stutter~factor(sex)+age,data=twinstut, response="binstut",id="tvparnr",var.link=1, theta.formula=~-1+factor(zyg1)) summary(out) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(zyg1)dz 0.5221651 0.2401355 factor(zyg1)mz 3.4853933 0.1866076 $or Estimate Std.Err 2.5% 97.5% P-value factor(zyg1)dz 1.69 0.405 0.892 2.48 3.12e-05 factor(zyg1)mz 32.64 6.090 20.699 44.57 8.38e-08 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} Now considering all data and estimating separate effects for the OR for opposite sex DZ twins and same sex twins. We here find that os twins are not markedly different from the same sex DZ twins. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # refers to zygosity of first subject in eash pair : zyg1 # could also use zyg2 (since zyg2=zyg1 within twinpair's)) desfs<-function(x,num1="zyg1",num2="zyg2") c(x[num1]=="dz",x[num1]=="mz",x[num1]=="os")*1 margbinall <- glm(binstut~factor(sex)+age,data=twinsall,family=binomial()) out3 <- easy.binomial.twostage(binstut~factor(sex)+age, data=twinsall,response="binstut",id="tvparnr",var.link=1, theta.formula=desfs,desnames=c("dz","mz","os")) summary(out3) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se dz 0.5278527 0.2396796 mz 3.4850037 0.1864190 os 0.7802940 0.2894394 $or Estimate Std.Err 2.5% 97.5% P-value dz 1.70 0.406 0.899 2.49 3.02e-05 mz 32.62 6.081 20.703 44.54 8.13e-08 os 2.18 0.632 0.944 3.42 5.50e-04 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \section*{Bivariate Probit model} \label{sec:org1b646d8} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) data(twinstut) twinstut <- subset(twinstut,zyg%in%c("mz","dz")) twinstut$binstut <- 1*(twinstut$stutter=="yes") head(twinstut) \end{lstlisting} \begin{verbatim} tvparnr zyg stutter sex age nr binstut 1 2001005 mz no female 71 1 0 2 2001005 mz no female 71 2 0 3 2001006 dz no female 71 1 0 8 2001012 mz no female 71 1 0 9 2001012 mz no female 71 2 0 11 2001015 dz no male 71 1 0 \end{verbatim} First testing for same dependence in MZ and DZ that we recommend doing by comparing the correlations of MZ and DZ twins. Apart from regression correction in the mean this is an un-structured model, and the useful concordance and casewise concordance estimates can be reported from this analysis. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} b1 <- bptwin(binstut~sex,data=twinstut,id="tvparnr",zyg="zyg",DZ="dz",type="un") summary(b1) \end{lstlisting} \begin{verbatim} Estimate Std.Err Z p-value (Intercept) -1.794823 0.023289 -77.066728 0.0000 sexmale 0.401432 0.030179 13.301813 0.0000 atanh(rho) MZ 1.096916 0.073574 14.909087 0.0000 atanh(rho) DZ 0.132458 0.062516 2.118800 0.0341 Total MZ/DZ Complete pairs MZ/DZ 8777/12511 3255/4058 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.79939 0.74101 0.84577 Tetrachoric correlation DZ 0.13169 0.00993 0.24960 MZ: Estimate 2.5% 97.5% Concordance 0.01698 0.01411 0.02042 Casewise Concordance 0.46730 0.40383 0.53185 Marginal 0.03634 0.03287 0.04016 Rel.Recur.Risk 12.85882 10.87510 14.84253 log(OR) 3.75632 3.37975 4.13289 DZ: Estimate 2.5% 97.5% Concordance 0.00235 0.00140 0.00393 Casewise Concordance 0.06456 0.03937 0.10413 Marginal 0.03634 0.03287 0.04016 Rel.Recur.Risk 1.77662 0.92746 2.62577 log(OR) 0.63527 0.09013 1.18040 Estimate 2.5% 97.5% Broad-sense heritability 1 NaN NaN \end{verbatim} \subsection*{Polygenic modelling} \label{sec:org8788a7d} We now turn attention to specific polygenic modelling where special random effects are used to specify ACE, AE, ADE models and so forth. This is very easy with the bptwin function. The key parts of the output are the sizes of the genetic component A and the environmental component, and we can compare with the results of the unstructed model above. Also formally we can test if this submodel is acceptable by a likelihood ratio test. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} b1 <- bptwin(binstut~sex,data=twinstut,id="tvparnr",zyg="zyg",DZ="dz",type="ace") summary(b1) \end{lstlisting} \begin{verbatim} Estimate Std.Err Z p-value (Intercept) -3.70371 0.24449 -15.14855 0 sexmale 0.83310 0.08255 10.09201 0 log(var(A)) 1.18278 0.17179 6.88512 0 log(var(C)) -29.99519 NA NA NA Total MZ/DZ Complete pairs MZ/DZ 8777/12511 3255/4058 Estimate 2.5% 97.5% A 0.76545 0.70500 0.82590 C 0.00000 0.00000 0.00000 E 0.23455 0.17410 0.29500 MZ Tetrachoric Cor 0.76545 0.69793 0.81948 DZ Tetrachoric Cor 0.38272 0.35210 0.41253 MZ: Estimate 2.5% 97.5% Concordance 0.01560 0.01273 0.01912 Casewise Concordance 0.42830 0.36248 0.49677 Marginal 0.03643 0.03294 0.04027 Rel.Recur.Risk 11.75741 9.77237 13.74246 log(OR) 3.52382 3.13466 3.91298 DZ: Estimate 2.5% 97.5% Concordance 0.00558 0.00465 0.00670 Casewise Concordance 0.15327 0.13749 0.17050 Marginal 0.03643 0.03294 0.04027 Rel.Recur.Risk 4.20744 3.78588 4.62900 log(OR) 1.69996 1.57262 1.82730 Estimate 2.5% 97.5% Broad-sense heritability 0.76545 0.70500 0.82590 \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} b0 <- bptwin(binstut~sex,data=twinstut,id="tvparnr",zyg="zyg",DZ="dz",type="ae") summary(b0) \end{lstlisting} \begin{verbatim} Estimate Std.Err Z p-value (Intercept) -3.70371 0.24449 -15.14855 0 sexmale 0.83310 0.08255 10.09201 0 log(var(A)) 1.18278 0.17179 6.88512 0 Total MZ/DZ Complete pairs MZ/DZ 8777/12511 3255/4058 Estimate 2.5% 97.5% A 0.76545 0.70500 0.82590 E 0.23455 0.17410 0.29500 MZ Tetrachoric Cor 0.76545 0.69793 0.81948 DZ Tetrachoric Cor 0.38272 0.35210 0.41253 MZ: Estimate 2.5% 97.5% Concordance 0.01560 0.01273 0.01912 Casewise Concordance 0.42830 0.36248 0.49677 Marginal 0.03643 0.03294 0.04027 Rel.Recur.Risk 11.75741 9.77237 13.74246 log(OR) 3.52382 3.13466 3.91298 DZ: Estimate 2.5% 97.5% Concordance 0.00558 0.00465 0.00670 Casewise Concordance 0.15327 0.13749 0.17050 Marginal 0.03643 0.03294 0.04027 Rel.Recur.Risk 4.20744 3.78588 4.62900 log(OR) 1.69996 1.57262 1.82730 Estimate 2.5% 97.5% Broad-sense heritability 0.76545 0.70500 0.82590 \end{verbatim} \section*{Additive gamma random effects} \label{sec:orgff761d3} Fitting first a model with different size random effects for MZ and DZ. We note that as before in the OR and biprobit model the dependence is much stronger for MZ twins. We also test if these are the same by parametrizing the OR model with an intercept. This clearly shows a significant difference. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} theta.des <- model.matrix( ~-1+factor(zyg),data=twinstut) margbin <- glm(binstut~sex,data=twinstut,family=binomial()) bintwin <- binomial.twostage(margbin,data=twinstut,model="gamma", clusters=twinstut$tvparnr,detail=0,theta=c(0.1)/1,var.link=1, theta.des=theta.des) summary(bintwin) # test for same dependence in MZ and DZ theta.des <- model.matrix( ~factor(zyg),data=twinstut) margbin <- glm(binstut~sex,data=twinstut,family=binomial()) bintwin <- binomial.twostage(margbin,data=twinstut,model="gamma", clusters=twinstut$tvparnr,detail=0,theta=c(0.1)/1,var.link=1, theta.des=theta.des) summary(bintwin) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates theta se factor(zyg)dz -2.61194495 0.4854454 factor(zyg)mz -0.01817181 0.1030735 $vargam Estimate Std.Err 2.5% 97.5% P-value factor(zyg)dz 0.0734 0.0356 0.00356 0.143 3.94e-02 factor(zyg)mz 0.9820 0.1012 0.78361 1.180 2.96e-22 $type [1] "gamma" attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates theta se (Intercept) -2.611945 0.4854454 factor(zyg)mz 2.593773 0.4962675 $vargam Estimate Std.Err 2.5% 97.5% P-value (Intercept) 0.0734 0.0356 0.00356 0.143 0.0394 factor(zyg)mz 13.3802 6.6401 0.36573 26.395 0.0439 $type [1] "gamma" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \subsection*{Polygenic modelling} \label{sec:orgc97abc0} First setting up the random effects design for the random effects and the the relationship between variance parameters. We see that the genetic random effect has size one for MZ and 0.5 for DZ subjects, that have shared and non-shared genetic components with variance 0.5 such that the total genetic variance is the same for all subjects. The shared environmental effect is the samme for all. Thus two parameters with these bands. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} out <- twin.polygen.design(twinstut,id="tvparnr",zygname="zyg",zyg="dz",type="ace") head(cbind(out$des.rv,twinstut$tvparnr),10) out$pardes \end{lstlisting} \begin{verbatim} MZ DZ DZns1 DZns2 env 1 1 0 0 0 1 2001005 2 1 0 0 0 1 2001005 3 0 1 1 0 1 2001006 8 1 0 0 0 1 2001012 9 1 0 0 0 1 2001012 11 0 1 1 0 1 2001015 12 0 1 1 0 1 2001016 13 0 1 0 1 1 2001016 15 0 1 1 0 1 2001020 18 0 1 1 0 1 2001022 [,1] [,2] [1,] 1.0 0 [2,] 0.5 0 [3,] 0.5 0 [4,] 0.5 0 [5,] 0.0 1 \end{verbatim} Now, fitting the ACE model, we see that the variance of the genetic, component, is 1.5 and the environmental variance is -0.5. Thus suggesting that the ACE model does not fit the data. When the random design is given we automatically use the gamma fralty model. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} margbin <- glm(binstut~sex,data=twinstut,family=binomial()) bintwin1 <- binomial.twostage(margbin,data=twinstut, clusters=twinstut$tvparnr,detail=0,theta=c(0.1)/1,var.link=0, random.design=out$des.rv,theta.des=out$pardes) summary(bintwin1) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 1.5261839 0.2475041 dependence2 -0.5447955 0.1942159 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1.555 0.187 1.189 1.922 9.11e-17 dependence2 -0.555 0.187 -0.922 -0.189 2.99e-03 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.981 0.102 0.781 1.18 8.29e-22 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} For this model we estimate the concordance and casewise concordance as well as the marginal rates of stuttering for females. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} concordanceTwinACE(bintwin1,type="ace") \end{lstlisting} \begin{verbatim} $MZ Estimate Std.Err 2.5% 97.5% P-value concordance 0.0182 0.00147 0.0153 0.0211 2.61e-35 casewise concordance 0.5033 0.03256 0.4395 0.5672 6.49e-54 marginal 0.0362 0.00188 0.0325 0.0399 7.15e-83 $DZ Estimate Std.Err 2.5% 97.5% P-value concordance 0.00235 0.000589 0.0012 0.00351 6.45e-05 casewise concordance 0.06501 0.015836 0.0340 0.09604 4.04e-05 marginal 0.03620 0.001877 0.0325 0.03988 7.15e-83 \end{verbatim} The E component was not consistent with the fit of the data and we now consider instead the AE model. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} out <- twin.polygen.design(twinstut,id="tvparnr",zygname="zyg",zyg="dz",type="ae") bintwin <- binomial.twostage(margbin,data=twinstut, clusters=twinstut$tvparnr,detail=0,theta=c(0.1)/1,var.link=0, random.design=out$des.rv,theta.des=out$pardes) summary(bintwin) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.9094847 0.09536268 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.909 0.0954 0.723 1.1 1.47e-21 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} Again, the concordance can be computed: \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} concordanceTwinACE(bintwin,type="ae") \end{lstlisting} \begin{verbatim} $MZ Estimate Std.Err 2.5% 97.5% P-value concordance 0.0174 0.00143 0.0146 0.0202 5.00e-34 casewise concordance 0.4795 0.03272 0.4154 0.5437 1.20e-48 marginal 0.0362 0.00188 0.0325 0.0399 7.15e-83 $DZ Estimate Std.Err 2.5% 97.5% P-value concordance 0.00477 0.000393 0.0040 0.00554 5.94e-34 casewise concordance 0.13175 0.005417 0.1211 0.14237 1.14e-130 marginal 0.03620 0.001877 0.0325 0.03988 7.15e-83 \end{verbatim} \end{document}mets/vignettes/mets.bib0000644000176200001440000007276413623061405014700 0ustar liggesusers@Article{hjelmborg_bmi_2008, Title = {{{G}enetic influences on growth traits of {B}{M}{I}: a longitudinal study of adult twins}}, Author = {Hjelmborg, J. v. and Fagnani, C. and Silventoinen, K. and McGue, M. and Korkeila, M. and Christensen, K. and Rissanen, A. and Kaprio, J. }, Journal = {Obesity (Silver Spring)}, Year = {2008}, Month = {Apr}, Number = {4}, Pages = {847--852}, Volume = {16} } @Article{korkeila_bmi_1991, Title = {{{E}ffects of gender and age on the heritability of body mass index}}, Author = {Korkeila, M. and Kaprio, J. and Rissanen, A. and Koskenvuo, M. }, Journal = {Int J Obes}, Year = {1991}, Month = {Oct}, Number = {10}, Pages = {647--654}, Volume = {15} } @article{twinstutter, author = {Corrado Fagnani and Steen Fibiger and Axel Skytthe and Jacob V. B. Hjelmborg}, title = {Heritability and environmental effects for self-reported periods with stuttering: A twin study from Denmark}, journal = {Logopedics Phoniatrics Vocology}, volume = {36}, number = {3}, pages = {114-120}, year = {2011}, doi = {10.3109/14015439.2010.534503}, abstract = { AbstractGenetic influence for stuttering was studied based on adult self-reporting. Using nation-wide questionnaire answers from 33,317 Danish twins, a univariate biometric analysis based on the liability threshold model was performed in order to estimate the heritability of stuttering. The self-reported incidences for stuttering were from less than 4\% for females to near 9\% for males. Both probandwise concordance rate and tetrachoric correlation were substantially higher for monozygotic compared to dizygotic pairs, indicating substantial genetic influence on individual liability. Univariate biometric analyses showed that additive genetic and unique environmental factors best explained the observed concordance patterns. Heritability estimates for males/females were 0.84/0.81. Moderate unique environmental effects were also found. } } @Article{TRACE, Title = {Does in-hospital ventricular fibrillation affect prognosis after myocardial infarction?}, Author = {Jensen, G.V. and Torp-Pedersen, C. and Hildebrandt, P. and Kober, L. and Nielsen, F. E. and Melchior, T. and Joen, T. and P. K. Andersen}, Journal = {European Heart Journal}, Year = {1997}, Pages = {919-924}, Volume = {18} } @Article{Cederkvist2018, author = {Cederkvist, Luise and Holst, Klaus K and Andersen, Klaus K and Scheike, Thomas H}, title = {Modeling the cumulative incidence function of multivariate competing risks data allowing for within-cluster dependence of risk and timing}, journal = {Biostatistics}, year = {2018}, __markedentry = {[bhd252:6]}, } @Article{Cederkvist2017, author = {Luise Cederkvist and Holst, {Klaus K.} and Andersen, {Klaus K.} and Glidden, {David V.} and Kirsten Frederiksen and Kjaer, {Susanne K.} and Scheike, {Thomas H.}}, title = {Incorporation of the time aspect into the liability-threshold model for case-control-family data}, journal = {Statistics in Medicine}, year = {2017}, month = {1}, note = {Copyright © 2017 John Wiley \& Sons, Ltd.}, issn = {0277-6715}, doi = {10.1002/sim.7229}, abstract = {Familial aggregation and the role of genetic and environmental factors can be investigated through family studies analysed using the liability-threshold model. The liability-threshold model ignores the timing of events including the age of disease onset and right censoring, which can lead to estimates that are difficult to interpret and are potentially biased. We incorporate the time aspect into the liability-threshold model for case-control-family data following the same approach that has been applied in the twin setting. Thus, the data are considered as arising from a competing risks setting and inverse probability of censoring weights are used to adjust for right censoring. In the case-control-family setting, recognising the existence of competing events is highly relevant to the sampling of control probands. Because of the presence of multiple family members who may be censored at different ages, the estimation of inverse probability of censoring weights is not as straightforward as in the twin setting but requires consideration. We propose to employ a composite likelihood conditioning on proband status that markedly simplifies adjustment for right censoring. We assess the proposed approach using simulation studies and apply it in the analysis of two Danish register-based case-control-family studies: one on cancer diagnosed in childhood and adolescence, and one on early-onset breast cancer. Copyright © 2017 John Wiley & Sons, Ltd.}, publisher = {JohnWiley \& Sons Ltd.}, } @Article{Hjelmborg2016, author = {Jacob Hjelmborg and Tellervo Korhonen and Klaus Holst and Axel Skytthe and Eero Pukkala and Julia Kutschke and Harris, {Jennifer R.} and Mucci, {Lorelei A.} and Kaare Christensen and Kamila Czene and Adami, {Hans Olov} and Thomas Scheike and Jaakko Kaprio}, title = {Lung cancer, genetic predisposition and smoking: The Nordic Twin Study of Cancer}, journal = {Thorax}, year = {2016}, month = {11}, pages = {1--7}, issn = {0040-6376}, doi = {10.1136/thoraxjnl-2015-207921}, abstract = {Background: We aimed to disentangle genetic and environmental causes in lung cancer while considering smoking status. Methods: Four Nordic twin cohorts (43 512 monozygotic (MZ) and 71 895 same sex dizygotic (DZ) twin individuals) had smoking data before cancer diagnosis. We used time-to-event analyses accounting for censoring and competing risk of death to estimate incidence, concordance risk and heritability of liability to develop lung cancer by smoking status. Results: During a median of 28.5 years of follow-up, we recorded 1508 incident lung cancers. Of the 30 MZ and 28 DZ pairs concordant for lung cancer, nearly all were current smokers at baseline and only one concordant pair was seen among never smokers. Among ever smokers, the case-wise concordance of lung cancer, that is the risk before a certain age conditional on lung cancer in the co-twin before that age, was significantly increased compared with the cumulative incidence for both MZ and DZ pairs. This ratio, the relative recurrence risk, significantly decreased by age for MZ but was constant for DZ pairs. Heritability of lung cancer was 0.41 (95% CI 0.26 to 0.56) for currently smoking and 0.37 (95% CI 0.25 to 0.49) for ever smoking pairs. Among smoking discordant pairs, the pairwise HR for lung cancer of the ever smoker twin compared to the never smoker co-twin was 5.4 (95% CI 2.1 to 14.0) in MZ pairs and 5.0 (95% CI 3.2 to 7.9) in DZ pairs. Conclusions: The contribution of familial effects appears to decrease by age. The discordant pair analysis confirms that smoking causes lung cancer.}, publisher = {B M J Group}, } @Article{Holst2016, author = {Holst, {Klaus K.} and Thomas Scheike and Hjelmborg, {Jacob B.}}, title = {The liability threshold model for censored twin data}, journal = {Computational Statistics \& Data Analysis}, year = {2016}, volume = {93}, month = {1}, pages = {324–335}, issn = {0167-9473}, doi = {10.1016/j.csda.2015.01.014}, abstract = {Family studies provide an important tool for understanding etiology of diseases, with the key aim of discovering evidence of family aggregation and to determine if such aggregation can be attributed to genetic components. Heritability and concordance estimates are routinely calculated in twin studies of diseases, as a way of quantifying such genetic contribution. The endpoint in these studies are typically defined as occurrence of a disease versus death without the disease. However, a large fraction of the subjects may still be alive at the time of follow-up without having experienced the disease thus still being at risk. Ignoring this right-censoring can lead to severely biased estimates. The classical liability threshold model can be extended with inverse probability of censoring weighting of complete observations. This leads to a flexible way of modelling twin concordance and obtaining consistent estimates of heritability. The method is demonstrated in simulations and applied to data from the population based Danish twin cohort to describe the dependence in prostate cancer occurrence in twins.}, keywords = {Competing risks, Cumulative incidence, Heritability, Liability-threshold, Polygenic model, Probit model, Random effects, Right censoring, Twins}, publisher = {Elsevier BV}, } @Article{Martinussen2016, author = {Torben Martinussen and Holst, {Klaus K.} and Scheike, {Thomas H.}}, title = {Cox regression with missing covariate data using a modified partial likelihood method}, journal = {Lifetime Data Analysis}, year = {2016}, volume = {22}, number = {4}, month = {10}, pages = {570–588}, issn = {1380-7870}, doi = {10.1007/s10985-015-9351-y}, abstract = {Missing covariate values is a common problem in survival analysis. In this paper we propose a novel method for the Cox regression model that is close to maximum likelihood but avoids the use of the EM-algorithm. It exploits that the observed hazard function is multiplicative in the baseline hazard function with the idea being to profile out this function before carrying out the estimation of the parameter of interest. In this step one uses a Breslow type estimator to estimate the cumulative baseline hazard function. We focus on the situation where the observed covariates are categorical which allows us to calculate estimators without having to assume anything about the distribution of the covariates. We show that the proposed estimator is consistent and asymptotically normal, and derive a consistent estimator of the variance-covariance matrix that does not involve any choice of a perturbation parameter. Moderate sample size performance of the estimators is investigated via simulation and by application to a real data example.}, publisher = {Springer New York LLC}, } @Article{Mucci2016, author = {Mucci, {Lorelei A.} and Hjelmborg, {Jacob B.} and Harris, {Jennifer R.} and Kamila Czene and Havelick, {David J.} and Thomas Scheike and Graff, {Rebecca E.} and Klaus Holst and Søren Møller and Unger, {Robert H.} and Christina McIntosh and Elizabeth Nuttall and Ingunn Brandt and Penney, {Kathryn L.} and Mikael Hartman and Peter Kraft and Giovanni Parmigiani and Kaare Christensen and Markku Koskenvuo and Holm, {Niels V.} and Kauko Heikkila and Eero Pukkala and Axel Skytthe and Hans-Olov Adami and Jaakko Kaprio}, title = {Familial Risk and Heritability of Cancer Among Twins in Nordic Countries}, journal = {J A M A: The Journal of the American Medical Association}, year = {2016}, volume = {315}, number = {1}, month = {1}, pages = {68--76}, issn = {0098-7484}, doi = {10.1001/jama.2015.17703}, abstract = {Importance: Estimates of familial cancer risk from population-based studies are essential components of cancer risk prediction.Objective: To estimate familial risk and heritability of cancer types in a large twin cohort.Design, Setting, and Participants: Prospective study of 80 309 monozygotic and 123 382 same-sex dizygotic twin individuals (N = 203 691) within the population-based registers of Denmark, Finland, Norway, and Sweden. Twins were followed up a median of 32 years between 1943 and 2010. There were 50 990 individuals who died of any cause, and 3804 who emigrated and were lost to follow-up.Exposures: Shared environmental and heritable risk factors among pairs of twins.Main Outcomes and Measures: The main outcome was incident cancer. Time-to-event analyses were used to estimate familial risk (risk of cancer in an individual given a twin’s development of cancer) and heritability (proportion of variance in cancer risk due to interindividual genetic differences) with follow-up via cancer registries. Statistical models adjusted for age and follow-up time, and accounted for censoring and competing risk of death.Results: A total of 27 156 incident cancers were diagnosed in 23 980 individuals, translating to a cumulative incidence of 32%. Cancer was diagnosed in both twins among 1383 monozygotic (2766 individuals) and 1933 dizygotic (2866 individuals) pairs. Of these, 38% of monozygotic and 26% of dizygotic pairs were diagnosed with the same cancer type. There was an excess cancer risk in twins whose co-twin was diagnosed with cancer, with estimated cumulative risks that were an absolute 5% (95% CI, 4%-6%) higher in dizygotic (37%; 95% CI, 36%-38%) and an absolute 14% (95% CI, 12%-16%) higher in monozygotic twins (46%; 95% CI, 44%-48%) whose twin also developed cancer compared with the cumulative risk in the overall cohort (32%). For most cancer types, there were significant familial risks and the cumulative risks were higher in monozygotic than dizygotic twins. Heritability of cancer overall was 33% (95% CI, 30%-37%). Significant heritability was observed for the cancer types of skin melanoma (58%; 95% CI, 43%-73%), prostate (57%; 95% CI, 51%-63%), nonmelanoma skin (43%; 95% CI, 26%-59%), ovary (39%; 95% CI, 23%-55%), kidney (38%; 95% CI, 21%-55%), breast (31%; 95% CI, 11%-51%), and corpus uteri (27%; 95% CI, 11%-43%).Conclusions and Relevance: In this long-term follow-up study among Nordic twins, there was significant excess familial risk for cancer overall and for specific types of cancer, including prostate, melanoma, breast, ovary, and uterus. This information about hereditary risks of cancers may be helpful in patient education and cancer risk counseling.}, publisher = {American Medical Association}, } @Article{Moeller2016, author = {Sören Möller and Mucci, {Lorelei A} and Harris, {Jennifer R} and Thomas Scheike and Klaus Holst and Ulrich Halekoh and Hans-Olov Adami and Kamila Czene and Kaare Christensen and Holm, {Niels V} and Eero Pukkala and Axel Skytthe and Jaakko Kaprio and Hjelmborg, {Jacob B}}, title = {The Heritability of Breast Cancer among women in the Nordic Twin Study of Cancer.}, journal = {Cancer Epidemiology, Biomarkers \& Prevention}, year = {2016}, volume = {25}, month = {1}, pages = {145--150}, issn = {1055-9965}, doi = {10.1158/1055-9965.EPI-15-0913}, abstract = {Background Family history is an established risk factor for breast cancer. Although some important genetic factors have been identified, the extent to which familial risk can be attributed to genetic factors versus common environment remains unclear. Methods We estimated the familial concordance and heritability of breast cancer among 21,054 monozygotic and 30,939 dizygotic female twin pairs from the Nordic Twin Study of Cancer, the largest twin study of cancer in the world. We accounted for left-censoring, right-censoring, as well as the competing risk of death. Results From 1943 through 2010, 3,933 twins were diagnosed with breast cancer. The cumulative lifetime incidence of breast cancer taking competing risk of death into account was 8.1% for both zygosities, while the cumulative risk for twins whose co-twins had breast cancer was 28% among monozygotic and 20% among dizygotic twins. The heritability of liability to breast cancer was 31% (95% CI 10% - 51%) and the common environmental component was 16% (95% CI 10% - 32%). For pre-menopausal breast cancer these estimates were 27% and 12%, respectively and for postmenopausal breast cancer 22% and 16%, respectively. The relative contributions of genetic and environmental factors were constant between ages 50 and 96. Our results are compatible with the Peto-Mack hypothesis. Conclusion Our findings indicate that familial factors explain almost half of the variation in liability to develop breast cancer, and results were similar for pre- and post-menopausal breast cancer. Impact We estimate heritability of breast cancer, taking until now ignored sources of bias into account.}, publisher = {American Association for Cancer Research (A A C R)}, } @Article{holst-hjelmborg-scheike-2014, author = {Holst, Klaus K. and Scheike, Thomas H. and Hjelmborg, Jacob B.}, title = {The Liability Threshold Model for Censored Twin Data}, journal = {Computational Statistics and Data Analysis}, year = {2015}, volume = {to appear}, doi = {10.1016/j.csda.2015.01.014}, url = {http://dx.doi.org/10.1016/j.csda.2015.01.014}, } @Article{behav-scheike-hjelmborg-holst-2015, author = {Scheike, {Thomas H} and Hjelmborg, {Jacob B} and Holst, {Klaus K}}, title = {Estimating Twin Pair Concordance for Age of Onset}, journal = {Behavior Genetics}, year = {2015}, issn = {0001-8244}, doi = {10.1007/s10519-015-9729-3}, keywords = {FIRST}, owner = {first}, publisher = {Springer New York LLC}, } @Article{Scheike2015, author = {Thomas Scheike and Holst, {Klaus K} and Hjelmborg, {Jacob B}}, title = {Measuring early or late dependence for bivariate lifetimes of twins}, journal = {Lifetime Data Analysis}, year = {2015}, volume = {21}, number = {2}, month = {4}, pages = {280--299}, issn = {1380-7870}, doi = {10.1007/s10985-014-9309-5}, abstract = {We consider data from the Danish twin registry and aim to study in detail how lifetimes for twin-pairs are correlated. We consider models where we specify the marginals using a regression structure, here Cox's regression model or the additive hazards model. The best known such model is the Clayton-Oakes model. This model can be extended in several directions. One extension is to allow the dependence parameter to depend on covariates. Another extension is to model dependence via piecewise constant cross-hazard ratio models. We show how both these models can be implemented for large sample data, and suggest a computational solution for obtaining standard errors for such models for large registry data. In addition we consider alternative models that have some computational advantages and with different dependence parameters based on odds ratios of the survival function using the Plackett distribution. We also suggest a way of assessing how and if the dependence is changing over time, by considering either truncated or right-censored versions of the data to measure late or early dependence. This can be used for formally testing if the dependence is constant, or decreasing/increasing. The proposed procedures are applied to Danish twin data to describe dependence in the lifetimes of the twins. Here we show that the early deaths are more correlated than the later deaths, and by comparing MZ and DZ associations we suggest that early deaths might be more driven by genetic factors. This conclusion requires models that are able to look at more local dependence measures. We further show that the dependence differs for MZ and DZ twins and appears to be the same for males and females, and that there are indications that the dependence increases over calendar time.}, owner = {first}, publisher = {Springer New York LLC}, } @Article{Eriksen2015, author = {Eriksen, Marie and Jensen, David H and Tribler, Siri and Holst, Jens J and Madsbad, Sten and Krarup, Thure}, title = {Reduction of insulinotropic properties of GLP-1 and GIP after glucocorticoid-induced insulin resistance}, journal = {Diabetologia}, year = {2015}, volume = {58}, number = {5}, pages = {920--928}, publisher = {Springer}, } @InProceedings{Hvistendahl2015, author = {Hvistendahl, Mark and Brandt, Christopher F and Tribler, Siri and Naimi, Rahim and Hartmann, Bolette and Holst, Jens Juul and Rehfeld, Jens Frederik and Hornum, Mads and Andersen, Jens Rikardt and Mortensen, Per B and others}, title = {The glucagon-like peptide-1 receptor agonist liraglutide reduces jejunostomy output and improves intestinal absorption in short bowel syndrome patients with intestinal failure: A pilot study}, booktitle = {{\AA}rsm{\o}de i Dansk Selskab for Klinisk Ern{\ae}ring}, year = {2015}, } @Article{hjelmborg-prostate-et-al-2013, author = {Hjelmborg, Jacob B. and Scheike, Thomas and Holst, Klaus and Skytthe, Axel and Penney, Kathryn L. and Graff, Rebecca E. and Pukkala, Eero and Christensen, Kaare and Adami, Hans-Olov and Holm, Niels V. and Nuttall, Elizabeth and Hansen, Steinbjorn and Hartman, Mikael and Czene, Kamila and Harris, Jennifer R. and Kaprio, Jaakko and Mucci, Lorelei A.}, title = {The Heritability of Prostate Cancer in the Nordic Twin Study of Cancer}, journal = {Cancer Epidemiology Biomarkers \& Prevention}, year = {2014}, doi = {10.1158/1055-9965.EPI-13-0568}, eprint = {http://cebp.aacrjournals.org/content/early/2014/05/08/1055-9965.EPI-13-0568.full.pdf+html}, url = {http://cebp.aacrjournals.org/content/early/2014/05/08/1055-9965.EPI-13-0568.abstract}, abstract = {Background: Prostate cancer is thought to be the most heritable cancer, although little is known about how this genetic contribution varies across age. Methods: To address this question, we undertook the world's largest prospective study in the Nordic Twin Study of Cancer cohort, including 18,680 monozygotic and 30,054 dizygotic same sex male twin pairs. We incorporated time-to-event analyses to estimate the risk concordance and heritability while accounting for censoring and competing risks of death, essential sources of biases that have not been accounted for in previous twin studies modeling cancer risk and liability. Results: The cumulative risk of prostate cancer was similar to that of the background population. The cumulative risk for twins whose co-twin was diagnosed with prostate cancer was greater for MZ than for DZ twins across all ages. Among concordantly affected pairs, the time between diagnoses was significantly shorter for MZ than DZ pairs (median 3.8 versus 6.5 years, respectively). Genetic differences contributed substantially to variation in both the risk and the liability (heritability=58% (95% CI 52%-63%) of developing prostate cancer. The relative contribution of genetic factors was constant across age through late life with substantial genetic heterogeneity even when diagnosis and screening procedures vary. Conclusions: Results from the population based twin cohort, indicate a greater genetic contribution to the risk of developing prostate cancer when addressing sources of bias. The role of genetic factors is consistently high across age Impact: Findings impact the search for genetic and epigenetic markers and frame prevention efforts.}, bdsk-url-1 = {http://cebp.aacrjournals.org/content/early/2014/05/08/1055-9965.EPI-13-0568.abstract}, bdsk-url-2 = {http://dx.doi.org/10.1158/1055-9965.EPI-13-0568}, } @Manual{metsR, author = {Klaus K. Holst and Thomas Scheike}, title = {mets: Analysis of Multivariate Event Times}, year = {2014}, note = {R package version 1.2.4}, url = {http://lava.r-forge.r-project.org/}, bdsk-url-1 = {http://lava.r-forge.r-project.org/}, } @Article{scheike-holst-hjelmborg-2010, author = {Scheike, T. H. and Holst, K. and Hjelmborg, J. V.}, title = {Estimating heritability for cause specific mortality based on twin studies}, journal = {Lifetime Data Anal.}, year = {2014}, volume = {20}, number = {2}, pages = {210-233}, bdsk-file-1 = {YnBsaXN0MDDUAQIDBAUGJCVYJHZlcnNpb25YJG9iamVjdHNZJGFyY2hpdmVyVCR0b3ASAAGGoKgHCBMUFRYaIVUkbnVsbNMJCgsMDRBWJGNsYXNzV05TLmtleXNaTlMub2JqZWN0c4AHog4PgAKAA6IREoAEgAVccmVsYXRpdmVQYXRoWWFsaWFzRGF0YV8QLXBkZl9saWIvc2NoZWlrZS1ob2xzdC1oamVsbWJvcmctbGlkYS0yMDEzLnBkZtIJFxgZV05TLmRhdGGABk8RAewAAAAAAewAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAAMpgFWJIKwAAABc02B9zY2hlaWtlLWhvbHN0LWhqZWxtYiNBNjFEOTMucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAph2Tzet+U2FsaXNNQUNTAAEAAwAACSAAAAAAAAAAAAAAAAAAAAAHcGRmX2xpYgAAEAAIAADKX/lCAAAAEQAIAADN62IzAAAAAQAUABc02AAXMT4AFs+TAAco1gAFY7cAAgBPTWFjaW50b3NoIEhEOlVzZXJzOgBiaGQyNTI6AHRzOgBsYXRleDoAcGRmX2xpYjoAc2NoZWlrZS1ob2xzdC1oamVsbWIjQTYxRDkzLnBkZgAADgBMACUAcwBjAGgAZQBpAGsAZQAtAGgAbwBsAHMAdAAtAGgAagBlAGwAbQBiAG8AcgBnAC0AbABpAGQAYQAtADIAMAAxADMALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAENVc2Vycy9iaGQyNTIvdHMvbGF0ZXgvcGRmX2xpYi9zY2hlaWtlLWhvbHN0LWhqZWxtYm9yZy1saWRhLTIwMTMucGRmAAATAAEvAAAVAAIADf//AADSGxwdHlokY2xhc3NuYW1lWCRjbGFzc2VzXU5TTXV0YWJsZURhdGGjHR8gVk5TRGF0YVhOU09iamVjdNIbHCIjXE5TRGljdGlvbmFyeaIiIF8QD05TS2V5ZWRBcmNoaXZlctEmJ1Ryb290gAEACAARABoAIwAtADIANwBAAEYATQBUAFwAZwBpAGwAbgBwAHMAdQB3AIQAjgC+AMMAywDNAr0CwgLNAtYC5ALoAu8C+AL9AwoDDQMfAyIDJwAAAAAAAAIBAAAAAAAAACgAAAAAAAAAAAAAAAAAAAMp}, booktitle = {Estimating heritability for cause specific mortality based on twin studies}, date-added = {2013-04-24 11:08:06 +0000}, date-modified = {2013-04-24 11:08:06 +0000}, keywords = {teoretisk statistik peer review}, own = {first}, owner = {first}, } @Article{scheike-holst-hjelmborg-2011, author = {Scheike, Thomas H and Holst, Klaus K and Hjelmborg, Jacob B}, title = {Estimating twin concordance for bivariate competing risks twin data}, journal = {Statistics in Medicine}, year = {2014}, volume = {33}, pages = {1193-204}, date-added = {2013-10-27 18:17:17 +0000}, date-modified = {2013-10-27 18:18:14 +0000}, keywords = {teoretisk statistik peer review}, own = {first}, owner = {first}, publisher = {Wiley Online Library}, } @Article{Hjelmborg2014, author = {Hjelmborg, {Jacob B} and Thomas Scheike and Klaus Holst and Axel Skytthe and Penney, {Kathryn L} and Graff, {Rebecca E} and Eero Pukkala and Kaare Christensen and Hans-Olov Adami and Holm, {Niels V} and Elizabeth Nuttall and Steinbjorn Hansen and Mikael Hartman and Kamila Czene and Harris, {Jennifer R} and Jaakko Kaprio and Mucci, {Lorelei a}}, title = {The Heritability of Prostate Cancer in the Nordic Twin Study of Cancer.}, journal = {Cancer Epidemiology, Biomarkers \& Prevention}, year = {2014}, volume = {23}, number = {11}, month = {11}, pages = {2303--2310}, issn = {1055-9965}, doi = {10.1158/1055-9965.EPI-13-0568}, abstract = {Background: Prostate cancer is thought to be the most heritable cancer, although little is known about how this genetic contribution varies across age. Methods: To address this question, we undertook the world's largest prospective study in the Nordic Twin Study of Cancer cohort, including 18,680 monozygotic and 30,054 dizygotic same sex male twin pairs. We incorporated time-to-event analyses to estimate the risk concordance and heritability while accounting for censoring and competing risks of death, essential sources of biases that have not been accounted for in previous twin studies modeling cancer risk and liability. Results: The cumulative risk of prostate cancer was similar to that of the background population. The cumulative risk for twins whose co-twin was diagnosed with prostate cancer was greater for MZ than for DZ twins across all ages. Among concordantly affected pairs, the time between diagnoses was significantly shorter for MZ than DZ pairs (median 3.8 versus 6.5 years, respectively). Genetic differences contributed substantially to variation in both the risk and the liability (heritability=58% (95% CI 52%-63%) of developing prostate cancer. The relative contribution of genetic factors was constant across age through late life with substantial genetic heterogeneity even when diagnosis and screening procedures vary. Conclusions: Results from the population based twin cohort, indicate a greater genetic contribution to the risk of developing prostate cancer when addressing sources of bias. The role of genetic factors is consistently high across age Impact: Findings impact the search for genetic and epigenetic markers and frame prevention efforts.}, publisher = {American Association for Cancer Research (A A C R)}, } @Article{Scheike2014, author = {Thomas Scheike and Holst, {Klaus K.} and Hjelmborg, {Jacob B.}}, title = {Estimating heritability for cause specific mortality based on twin studies}, journal = {Lifetime Data Analysis}, year = {2014}, volume = {20}, number = {2}, month = {4}, pages = {210--233}, issn = {1380-7870}, doi = {10.1007/s10985-013-9244-x}, keywords = {Cause specific hazards, Competing risks, Delayed entry, Left truncation, Heritability, Survival analysis}, owner = {first}, publisher = {Springer New York LLC}, } @Comment{jabref-meta: databaseType:biblatex;} @Article{, title={The Liability Threshold Model for Censored Twin Data}, author={Holst, Klaus K. and Scheike, Thomas H. and Hjelmborg, Jacob B.}, year={2015}, doi={10.1016/j.csda.2015.01.014}, url={http://dx.doi.org/10.1016/j.csda.2015.01.014}, journal={Computational Statistics and Data Analysis} } @Article{, title={Estimating heritability for cause specific mortality based on twin studies}, author={Scheike, Thomas H. and Holst, Klaus K. and Hjelmborg, Jacob B.}, year={2013}, issn={1380-7870}, journal={Lifetime Data Analysis}, doi={10.1007/s10985-013-9244-x}, url={http://dx.doi.org/10.1007/s10985-013-9244-x}, publisher={Springer US}, keywords={Cause specific hazards; Competing risks; Delayed entry; Left truncation; Heritability; Survival analysis}, pages={1-24}, language={English} } mets/vignettes/twostage-survival.org0000644000176200001440000012127713623061405017463 0ustar liggesusers#+TITLE: Analysis of multivariate survival data #+AUTHOR: Klaus Holst & Thomas Scheike #+PROPERTY: header-args:R :session *R* :cache no :width 550 :height 450 #+PROPERTY: header-args :eval never-export :exports both :results output :tangle yes :comments yes #+PROPERTY: header-args:R+ :colnames yes :rownames no :hlines yes #+INCLUDE: header.org #+OPTIONS: toc:nil timestamp:nil #+BEGIN_SRC emacs-lisp :results silent :exports results :eval (setq org-latex-listings t) (setq org-latex-compiler-file-string "%%\\VignetteIndexEntry{Analysis of multivariate survival data}\n%%\\VignetteEngine{R.rsp::tex}\n%%\\VignetteKeyword{R}\n%%\\VignetteKeyword{package}\n%%\\VignetteKeyword{vignette}\n%%\\VignetteKeyword{LaTeX}\n") #+END_SRC ----- # +LaTeX: \clearpage * Overview When looking at multivariate survival data with the aim of learning about the dependence that is present, possibly after correcting for some covariates different approaches are available in the mets package - Binary models and adjust for censoring with inverse probabilty of censoring weighting - biprobit model - Bivariate surival models of Clayton-Oakes type - With regression structure on dependence parameter - With additive gamma distributed random effects - Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. - Plackett OR model model - With regression structure on OR dependence parameter - Cluster stratified Cox Typically it can be hard or impossible to specify random effects models with special structure among the parameters of the random effects. This is possible for our specification of the random effects models. To be concrete about the model structure assume that we have paired binomial data \( T_1, \delta_1, T_2, \delta_2, X_1, X_2 \) where the censored survival responses are \( T_1, \delta_1, T_2, \delta_2 \) and we have covariates \( X_1, X_2 \). The basic models assumes that each subject has a marginal on Cox-form \[ \lambda_{s(k,i)}(t) \exp( X_{ki}^T \beta) \] where $s(k,i)$ is a strata variable. ** Gamma distributed frailties The focus of this vignette is describe how to work on bivariate survival data using the addtive gamma-random effects models. We present two different ways of specifying different dependence structures. - Univariate models with a single random effect for each cluster and with a regression design on the variance. - Multivariate models with multiple random effects for each cluster. The univariate models are then given a given cluster random effects $Z_k$ with parameter $\theta$ the joint survival function is given by the Clayton copula and on the form \[ \psi(\theta, \psi^{-1}(\theta,S_1(t,X_{k1}) ) + \psi^{-1}(\theta, S_1(t,X_{k1}) ) \] where \( \psi \) is the Laplace transform of a gamma distributed random variable with mean 1 and variance $\theta$. We then model the variance within clusters by a cluster specific regression design such that \[ \theta = z_j^T \alpha \] where $z$ is the regression design (specified by theta.des in the software). This model can be fitted using a pairwise likelihood or the pseudo-likelihood using either - twostage - twostageMLE To make the twostage approach possible we need a model with specific structure for the marginals. Therefore given the random effect of the clusters the survival distributions within a cluster are independent and on the form \[ P(T_j > t| X_j,Z) = exp( -Z \cdot \Psi^{-1}(\nu^{-1},S(t|X_j)) ) \] with $\Psi$ the laplace of the gamma distribution with mean 1 and variance $1/\nu$. ** Additive Gamma frailties For the multivariate models we are given a multivarite random effect each cluster \(Z=(Z_1,...,Z_d) \) with d random effects. The total random effect for each subject $j$ in a cluster is then specified using a regression design on these random effects, with a regression vector \( V_j \) such that the total random effect is \( V_j^T (Z_1,...,Z_d) \). The elements of $V_J$ are 1/0. The random effects \( (Z_1,...,Z_d) \) has associated parameters \( (\lambda_1,...,\lambda_d) \) and \( Z_j \) is Gamma distributed with - mean \( \lambda_j/V_1^T \lambda \) - variance \( \lambda_j/(V_1^T \lambda)^2 \) The key assumption to make the two-stage fitting possible is that \[ \nu =V_j^T \lambda \] is constant within clusters. The consequence of this is that the total random effect for each subject within a cluster, \( V_j^T (Z_1,...,Z_d) \) , is gamma distributed with variance $1/\nu$. The DEFAULT parametrization (var.par=1) uses the variances of the random effecs \[ \theta_j = \lambda_j/\nu^2 \] For alternative parametrizations one can specify that the parameters are $\theta_j=\lambda_j$ with the argument var.par=0. Finally the parameters \( (\theta_1,...,\theta_d) \) are related to the parameters of the model by a regression construction \( M \) (d x k), that links the \( d \) \( \theta \) parameters with the \( k \) underlying \( \alpha \) parameters \[ \theta = M \alpha. \] The default is a diagonal matrix for $M$. This can be used to make structural assumptions about the variances of the random-effects as is needed for the ACE model for example. In the software \( M \) is called theta.des # We consider $K$ independent clusters, with $n_k$ subject within each cluster. # For each cluster we are given a set of independent random effects $Z = (Z_1,\dots , Z_d)^T$. # We let $(Z_1,\dots,Z_d)^T$ be independent Gamma distributed # with $Z_l \sim \Gamma(\eta_l , \nu_l), l = 1,\dots,p$ independent gamma distributed random variables # such that $E(V_l) = \eta_l /\nu$ and $Var(V_l ) = \eta_l /\nu^2$. # To facilitate our two-stage construction we also assume that # $\nu=Q_i^T \eta$ for all $i=1,\dots,n_k$ such that # $Q_i^T V$ is also Gamma distributed with $\Gamma(1, \nu)$, that is has variance $\nu^{-1}$ and mean 1. # Let $\Psi(\eta_l,\nu,\cdot)$ denote the Laplace transform of the # Gamma distribution $\Gamma(\eta_l,\nu)$, and let its inverse be $\Psi^{-1}(\eta_l,\nu,\cdot)$. # For simplicity we also assume that $\eta$ is the same across clusters. Assume that the marginal survival distribution for subject $i$ within cluster $k$ is given by $S_{X_{k,i}}(t)$ given covariates $X_{k,i}$. Now given the random effects of the cluster $Z_k$ and the covariates$X_{k,i}$ $i=1,\dots,n_k$ we assume that subjects within the cluster are independent with survival distributions \begin{align*} \exp(- ( V_{k,i} Z_k) \Psi^{-1} (\nu,S_{X_{k,i}}(t)) ). \end{align*} A consequence of this is that the hazards given the covariates $X_{k,i}$ and the random effects $Z_k$ are given by \begin{align} \lambda_{k,i}(t;X_{k,i},Z_{k,i}) = ( V_{k,i} V_k) D_3 \Psi^{-1} (\nu,S_{X_{k,i}}(t)) D_t S_{X_{k,i}}(t) \label{eq-cond-haz} \end{align} where $D_t$ and $D_3$ denotes the partial derivatives with respect to $t$ and the third argument, respectively. Further, we can express the multivariate survival distribution as \begin{align} S(t_1,\dots,t_m) & = \exp( -\sum_{i=1}^m (V_i Z) \Psi^{-1}(\eta_l,\nu_l,S_{X_{k,i}}(t_i)) ) \nonumber \\ & = \prod_{l=1}^p \Psi(\eta_l,\eta , \sum_{i=1}^m Q_{k,i} \Psi^{-1}(\eta,\eta,S_{X_{k,i}}(t_i))). \label{eq-multivariate-surv} \end{align} In the case of considering just pairs, we write this function as $C(S_{k,i}(t),S_{k,j}(t))$. In addition to survival times from this model, we assume that we independent right censoring present $U_{k,i}$ such that the given $V_k$ and the covariates$X_{k,i}$ $i=1,\dots,n_k$ $(U_{k,1},\dots,U_{k,n_k})$ of $(T_{k,1},\dots,T_{k,n_k})$, and the conditional censoring distribution do not depend on $V_k$. # We can also express this via counting processes $N_{k,i}(t)=I(T_{k,i}t,U_{k,i}>t)$, and the censoring indicators # $\delta_{k,i}=I(T_{k,i} 16f32e6bd553427d5e9e74660b682f6b63e39c2d]: #+begin_example Loading required package: timereg Loading required package: survival Loading required package: lava mets version 1.2.4 Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 0.9526614 0.3543033 2.68883 0.007170289 0.322645 0.08127892 $type NULL attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates log-Coef. SE z P-val Kendall tau SE dependence1 -0.04849523 0.330665 -0.1466597 0.8834006 0.3226451 0.07226526 $vargam Estimate Std.Err 2.5% 97.5% P-value dependence1 0.9527 0.315 0.3352 1.57 0.002493 $type [1] "clayton.oakes" attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 0.9526619 0.3150119 3.024209 0.002492843 0.3226451 0.07226526 $type [1] "clayton.oakes" attr(,"class") [1] "summary.mets.twostage" #+end_example The marginal models can be either structured Cox model or as here with a baseline for each strata. This gives quite similar results to those before. #+BEGIN_SRC R :results output :exports both :session *R* :cache no # without covariates but marginal model stratified marg <- phreg(Surv(time,status)~+strata(treat)+cluster(id),data=diabetes) fitcoa <- survival.twostage(marg,data=diabetes,theta=1.0,clusters=diabetes$id, model="clayton.oakes") summary(fitcoa) #+END_SRC #+RESULTS[<2018-09-11 09:09:49> 79897f72f7b29f3a6df3a880f92ed9c05a6ce060]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates log-Coef. SE z P-val Kendall tau SE dependence1 -0.05683996 0.3322322 -0.171085 0.8641569 0.3208241 0.07239207 $vargam Estimate Std.Err 2.5% 97.5% P-value dependence1 0.9447 0.3139 0.3296 1.56 0.002613 $type [1] "clayton.oakes" attr(,"class") [1] "summary.mets.twostage" #+end_example ** Piecewise constant Clayton-Oakes model Let the cross-hazard ratio (CHR) be defined as \begin{align} \eta(t_1,t_2) = \frac{ \lambda_1(t_1| T_2=t_2)}{ \lambda_1(t_1| T_2 \ge t_2)} = \frac{ \lambda_2(t_2| T_1=t_1)}{ \lambda_2(t_2| T_1 \ge t_1)} \end{align} where $\lambda_1$ and $\lambda_2$ are the conditional hazard functions of $T_1$ and $T_2$ given covariates. For the Clayton-Oakes model this ratio is $\eta(t_1,t_2) = 1+\theta$, and as a consequence we see that if the co-twin is dead at any time we would increase our risk assessment on the hazard scale with the constant $\eta(t_1,t_2)$. The Clayton-Oakes model also has the nice property that Kendall's tau is linked directly to the dependence parameter $\theta$ and is $1/(1+2/\theta)$. A very useful extension of the model the constant cross-hazard ratio (CHR) model is the piecewise constant cross-hazard ratio (CHR) for bivariate survival data \cite{nan2006piecewise}, and this model was extended to competing risks in \cite{shih2010modeling}. In the survival setting we let the CHR \begin{align} \eta(t_1,t_2) & = \sum \eta_{i,j} I(t_1 \in I_i, t_2 \in I_j) \end{align} The model lets the CHR by constant in different part of the plane. This can be thought of also as having a separate Clayton-Oakes model for each of the regions specified in the plane here by the cut-points \( c(0,0.5,2) \) thus defining 9 regions. This provides a constructive goodness of fit test for the whether the Clayton-Oakes model is valid. Indeed if valid the parameter should be the same in all regions. First we generate some data from the Clayton-Oakes model with variance $0.5$ and 2000 pairs. And fit the related model. #+BEGIN_SRC R :results output :exports both :session *R* :cache no d <- simClaytonOakes(2000,2,0.5,0,3) margph <- phreg(Surv(time,status)~x+cluster(cluster),data=d) # Clayton-Oakes, MLE fitco1<-twostageMLE(margph,data=d) summary(fitco1) #+END_SRC #+RESULTS: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.01888 0.08970192 22.50654 0 0.5023489 0.01110764 $type NULL attr(,"class") [1] "summary.mets.twostage" #+end_example Now we cut the region at the cut-points \( c(0,0.5,2) \) thus defining 9 regions and fit a separate model for each region. We see that the parameter is indeed rather constant over the 9 regions. A formal test can be constructed. #+BEGIN_SRC R :results output :exports both :session *R* :cache no udp <- piecewise.twostage(c(0,0.5,2),data=d,score.method="optimize", id="cluster",timevar="time", status="status",model="clayton.oakes",silent=0) summary(udp) #+END_SRC #+RESULTS[<2018-09-11 09:09:50> 7d2ab8fcfa35afc8358eb1426f471ba00efa1d47]: #+begin_example Data-set 1 out of 4 Number of joint events: 518 of 2000 Data-set 2 out of 4 Number of joint events: 274 of 1232 Data-set 3 out of 4 Number of joint events: 247 of 1203 Data-set 4 out of 4 Number of joint events: 594 of 953 [1] 1 Dependence parameter for Clayton-Oakes model Score of log-likelihood for parameter estimates (too large?) 0 - 0.5 0.5 - 2 0 - 0.5 0.0019673733 0.001451886 0.5 - 2 0.0007297083 0.003142920 log-coefficient for dependence parameter (SE) 0 - 0.5 0.5 - 2 0 - 0.5 0.687 (0.069) 0.677 (0.093) 0.5 - 2 0.733 (0.100) 0.718 (0.060) Kendall's tau (SE) 0 - 0.5 0.5 - 2 0 - 0.5 0.498 (0.017) 0.496 (0.023) 0.5 - 2 0.51 (0.025) 0.506 (0.015) #+end_example ** Multivariate gamma twostage models To illustrate how the multivariate models can be used, we first set up some twin data with ACE structure. That is two shared random effects, one being the genes $\sigma_g^2$ and one the environmental effect $\sigma_e^2$. Monozygotic twins share all genes whereas the dizygotic twins only share half the genes. This can be expressed via 5 random effect for each twin pair (for example). We start by setting this up. The pardes matrix tells how the the parameters of the 5 random effects are related, and the matrix her first has one random effect with parameter $\theta_1$ (here the $\sigma_g^2$), then the next 3 random effects have parameters $0.5 \theta_1$ (here $0.5 \sigma_g^2$), and the last random effect that is given by its own parameter $\theta_2$ (here $\sigma_e^2$). #+BEGIN_SRC R :results output :exports both :session *R* :cache no data <- simClaytonOakes.twin.ace(2000,2,1,0,3) out <- twin.polygen.design(data,id="cluster") pardes <- out$pardes pardes #+END_SRC #+RESULTS: : [,1] [,2] : [1,] 1.0 0 : [2,] 0.5 0 : [3,] 0.5 0 : [4,] 0.5 0 : [5,] 0.0 1 The last part of the model structure is to decide how the random effects are shared for the different pairs (MZ and DZ), this is specfied by the random effects design ($V_1$ and $V_2$) for each pair. This is here specified by an overall designmatrix for each subject (since they enter all pairs with the same random effects design). For an MZ pair the two share the full gene random effect and the full environmental random effect. In contrast the DZ pairs share the 2nd random effect with half the gene-variance and have both a non-shared gene-random effect with half the variance, and finally a fully shared environmental random effect. #+BEGIN_SRC R :results output :exports both :session *R* :cache no des.rv <- out$des.rv # MZ head(des.rv,2) # DZ tail(des.rv,2) #+END_SRC #+RESULTS: : MZ DZ DZns1 DZns2 env : 1 1 0 0 0 1 : 2 1 0 0 0 1 : MZ DZ DZns1 DZns2 env : 3999 0 1 1 0 1 : 4000 0 1 0 1 1 Now we call the twostage function. We see that we essentially recover the true values, and note that the output also compares the sizes of the genetic and environmental random effect. This number is sometimes called the heritability. In addition the total variance for each subject is also computed and is here around $3$, as we indeed constructed. #+BEGIN_SRC R :results output :exports both :session *R* :cache no aa <- phreg(Surv(time,status)~x+cluster(cluster),data=data) ts <- twostage(aa,data=data,clusters=data$cluster,detail=0, theta=c(2,1),var.link=0,step=0.5, random.design=des.rv,theta.des=pardes) summary(ts) #+END_SRC #+RESULTS[<2018-09-11 09:09:52> 3f8f687ca867317f3f1fb6d33c650e6c5d9aa5c7]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.2111163 0.2219525 9.962113 0.000000e+00 0.5250665 0.02503201 dependence2 0.7431872 0.1706430 4.355217 1.329349e-05 0.2709211 0.04535315 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.7484 0.05898 0.6328 0.8640 6.669e-37 dependence2 0.2516 0.05898 0.1360 0.3672 1.995e-05 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 2.954 0.1426 2.675 3.234 2.514e-95 attr(,"class") [1] "summary.mets.twostage" #+end_example The estimates can be transformed into Kendall's tau estimates for MZ and DZ twins. The Kendall's tau in the above output reflects how a gamma distributed random effect in the normal Clayton-Oakes model is related to the Kendall's tau. In this setting the Kendall's of MZ and DZ, however, should reflect both random effects. We do this based on simulations. The Kendall's tau of the MZ is around 0.60, and for DZ around 0.33. Both are quite high and this is due to a large shared environmental effect and large genetic effect. #+BEGIN_SRC R :results output :exports both :session *R* :cache no kendall.ClaytonOakes.twin.ace(ts$theta[1],ts$theta[2],K=10000) #+END_SRC #+RESULTS: : $mz.kendall : [1] 0.5984888 : : $dz.kendall : [1] 0.3257834 ** Family data For family data, things are quite similar since we use only the pairwise structure. We show how the designs are specified. First we simulate data from an ACE model. 2000 families with two-parents that share only the environment, and two-children that share genes with their parents. #+BEGIN_SRC R :results output :exports both :session *R* :cache no library(mets) set.seed(1000) data <- simClaytonOakes.family.ace(2000,2,1,0,3) head(data) data$number <- c(1,2,3,4) data$child <- 1*(data$number==3) #+END_SRC #+RESULTS: : time status x cluster type mintime lefttime truncated : 1 0.26343780 1 1 1 mother 0.26343780 0 0 : 2 1.14490828 1 1 1 father 0.26343780 0 0 : 3 0.86649229 1 1 1 child 0.26343780 0 0 : 4 0.30843425 1 0 1 child 0.26343780 0 0 : 5 3.00000000 0 0 2 mother 0.07739746 0 0 : 6 0.07739746 1 0 2 father 0.07739746 0 0 To set up the random effects some functions can be used. We here set up the ACE model that has 9 random effects with one shared environmental effect (the last random effect) and 4 genetic random effects for each parent, with variance $\sigma_g^2/4$. The random effect is again set-up with an overall designmatrix because it is again the same for each subject for all comparisons across family members. We below demonstrate how the model can be specified in various other ways. Each child share 2 genetic random effects with each parent, and also share 2 genetic random effects with his/her sibling. #+BEGIN_SRC R :results output :exports both :session *R* :cache no out <- ace.family.design(data,member="type",id="cluster") out$pardes head(out$des.rv,4) #+END_SRC #+RESULTS: #+begin_example [,1] [,2] [1,] 0.25 0 [2,] 0.25 0 [3,] 0.25 0 [4,] 0.25 0 [5,] 0.25 0 [6,] 0.25 0 [7,] 0.25 0 [8,] 0.25 0 [9,] 0.00 1 m1 m2 m3 m4 f1 f2 f3 f4 env [1,] 1 1 1 1 0 0 0 0 1 [2,] 0 0 0 0 1 1 1 1 1 [3,] 1 1 0 0 1 1 0 0 1 [4,] 1 0 1 0 1 0 1 0 1 #+end_example Then we fit the model #+BEGIN_SRC R :results output :exports both :session *R* :cache no pa <- phreg(Surv(time,status)~+1+cluster(cluster),data=data) aa <- aalen(Surv(time,status)~+1,data=data,robust=0) # make ace random effects design ts <- twostage(pa,data=data,clusters=data$cluster, var.par=1,var.link=0,theta=c(2,1), random.design=out$des.rv,theta.des=out$pardes) summary(ts) #+END_SRC #+RESULTS[<2018-09-11 10:11:08> c274b904f15c48471f5830235a45bd9c6327b662]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.185967 0.19164670 11.40623 0 0.5222132 0.02187458 dependence2 0.947110 0.07648339 12.38321 0 0.3213691 0.01761183 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.6977 0.02997 0.6390 0.7564 7.182e-120 dependence2 0.3023 0.02997 0.2436 0.3610 6.359e-24 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.133 0.1737 2.793 3.474 1.074e-72 attr(,"class") [1] "summary.mets.twostage" #+end_example The model can also be fitted by specifying the pairs that one wants for the pairwise likelhood. This is done by specifying the pairs argument. We start by considering all pairs as we also did before. All pairs can be written up by calling the familycluster.index function. There are 12000 pairs to consider and the last 12 pairs for the last family is written out here. #+BEGIN_SRC R :results output :exports both :session *R* :cache no # now specify fitting via specific pairs # first all pairs mm <- familycluster.index(data$cluster) head(mm$familypairindex,n=10) pairs <- matrix(mm$familypairindex,ncol=2,byrow=TRUE) tail(pairs,n=12) #+END_SRC #+RESULTS: #+begin_example [1] 1 2 1 3 1 4 2 3 2 4 [,1] [,2] [11989,] 7993 7994 [11990,] 7993 7995 [11991,] 7993 7996 [11992,] 7994 7995 [11993,] 7994 7996 [11994,] 7995 7996 [11995,] 7997 7998 [11996,] 7997 7999 [11997,] 7997 8000 [11998,] 7998 7999 [11999,] 7998 8000 [12000,] 7999 8000 #+end_example Then fitting the model using only specified pairs #+BEGIN_SRC R :results output :exports both :session *R* :cache no ts <- twostage(pa,data=data,clusters=data$cluster, theta=c(2,1),var.link=0,step=1.0, random.design=out$des.rv, theta.des=out$pardes,pairs=pairs) summary(ts) #+END_SRC #+RESULTS: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.185967 0.18986604 11.51321 0 0.5222132 0.02167133 dependence2 0.947110 0.07929082 11.94476 0 0.3213691 0.01825829 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.6977 0.03044 0.6381 0.7574 2.659e-116 dependence2 0.3023 0.03044 0.2426 0.3619 3.010e-23 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.133 0.1713 2.797 3.469 1.057e-74 attr(,"class") [1] "summary.mets.twostage" #+end_example Now we only use a random sample of the pairs by sampling these. The pairs picked still refers to the data given in the data argument, and clusters (families) are also specified as before. #+BEGIN_SRC R :results output :exports both :session *R* :cache no ssid <- sort(sample(1:12000,2000)) tsd <- twostage(aa,data=data,clusters=data$cluster, theta=c(2,1)/10,var.link=0,step=1.0, random.design=out$des.rv,iid=1, theta.des=out$pardes,pairs=pairs[ssid,]) summary(tsd) #+END_SRC #+RESULTS: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.655 0.05345 0.5502 0.7598 1.606e-34 dependence2 0.345 0.05345 0.2402 0.4498 1.089e-10 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.055 0.3253 2.418 3.693 5.923e-21 attr(,"class") [1] "summary.mets.twostage" #+end_example Sometimes one only has the data from the pairs in addition to for example a cohort estimate of the marginal surival models. We now demonstrate how this is dealt with. Everything is essentially as before but need to organize the design differently compared to before we specified the design for everybody in the cohort. #+BEGIN_SRC R :results output :exports both :session *R* :cache no ids <- sort(unique(c(pairs[ssid,]))) pairsids <- c(pairs[ssid,]) pair.new <- matrix(fast.approx(ids,c(pairs[ssid,])),ncol=2) head(pair.new) # this requires that pair.new refers to id's in dataid (survival, status and so forth) # random.design and theta.des are constructed to be the array 3 dims via individual specfication from ace.family.design dataid <- dsort(data[ids,],"cluster") outid <- ace.family.design(dataid,member="type",id="cluster") outid$pardes head(outid$des.rv) #+END_SRC #+RESULTS: #+begin_example [,1] [,2] [1,] 1 2 [2,] 3 4 [3,] 3 5 [4,] 4 6 [5,] 7 8 [6,] 9 10 [,1] [,2] [1,] 0.25 0 [2,] 0.25 0 [3,] 0.25 0 [4,] 0.25 0 [5,] 0.25 0 [6,] 0.25 0 [7,] 0.25 0 [8,] 0.25 0 [9,] 0.00 1 m1 m2 m3 m4 f1 f2 f3 f4 env [1,] 1 1 1 1 0 0 0 0 1 [2,] 0 0 0 0 1 1 1 1 1 [3,] 1 1 1 1 0 0 0 0 1 [4,] 0 0 0 0 1 1 1 1 1 [5,] 1 1 0 0 1 1 0 0 1 [6,] 1 0 1 0 1 0 1 0 1 #+end_example Now fitting the model using only the pair data. #+BEGIN_SRC R :results output :exports both :session *R* :cache no tsdid <- twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1)/10,var.link=0,step=1.0, random.design=outid$des.rv,iid=1, theta.des=outid$pardes,pairs=pair.new) summary(tsdid) coef(tsdid) coef(tsd) #+END_SRC #+RESULTS[<2018-09-11 10:11:09> 91163f7afe117aad70174aad4fa38fb55c0a98ba]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.655 0.05345 0.5502 0.7598 1.606e-34 dependence2 0.345 0.05345 0.2402 0.4498 1.089e-10 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.055 0.3253 2.418 3.693 5.923e-21 attr(,"class") [1] "summary.mets.twostage" Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 #+end_example Now we illustrate how one can also directly specify the random.design and theta.design for each pair, rather than taking the rows of the des.rv for the relevant pairs. This can be much simpler in some situations. #+BEGIN_SRC R :results output :exports both :session *R* :cache no pair.types <- matrix(dataid[c(t(pair.new)),"type"],byrow=T,ncol=2) head(pair.new) head(pair.types) # here makes pairwise design , simpler random.design og pardes, parameters # stil varg, varc # mother, child, share half rvm=c(1,1,0) rvc=c(1,0,1), # thetadesmcf=rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) # # father, child, share half rvf=c(1,1,0) rvc=c(1,0,1), # thetadescf=rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) # # child, child, share half rvc=c(1,1,0) rvc=c(1,0,1), # thetadesmf=rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) # # mother, father, share 0 rvm=c(1,0) rvf=c(0,1), # thetadesmf=rbind(c(1,0),c(1,0),c(0,1)) theta.des <- array(0,c(4,2,nrow(pair.new))) random.des <- array(0,c(2,4,nrow(pair.new))) # random variables in each pair rvs <- c() for (i in 1:nrow(pair.new)) { if (pair.types[i,1]=="mother" & pair.types[i,2]=="father") { theta.des[,,i] <- rbind(c(1,0),c(1,0),c(0,1),c(0,0)) random.des[,,i] <- rbind(c(1,0,1,0),c(0,1,1,0)) rvs <- c(rvs,3) } else { theta.des[,,i] <- rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) random.des[,,i] <- rbind(c(1,1,0,1),c(1,0,1,1)) rvs <- c(rvs,4) } } # 3 rvs here random.des[,,7] theta.des[,,7] # 4 rvs here random.des[,,1] theta.des[,,1] head(rvs) #+END_SRC #+RESULTS[<2018-09-11 09:10:41> 001e65d71cb0632d0a202ea875e6794f628fd8ba]: #+begin_example [,1] [,2] [1,] 1 2 [2,] 3 4 [3,] 3 5 [4,] 4 6 [5,] 7 8 [6,] 9 10 [,1] [,2] [1,] "mother" "father" [2,] "mother" "father" [3,] "mother" "child" [4,] "father" "child" [5,] "child" "child" [6,] "child" "child" [,1] [,2] [,3] [,4] [1,] 1 1 0 1 [2,] 1 0 1 1 [,1] [,2] [1,] 0.5 0 [2,] 0.5 0 [3,] 0.5 0 [4,] 0.0 1 [,1] [,2] [,3] [,4] [1,] 1 0 1 0 [2,] 0 1 1 0 [,1] [,2] [1,] 1 0 [2,] 1 0 [3,] 0 1 [4,] 0 0 [1] 3 3 4 4 4 4 #+end_example And fitting again the same model as before #+BEGIN_SRC R :results output :exports both :session *R* :cache no tsdid2 <- twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1)/10,var.link=0,step=1.0, random.design=random.des, theta.des=theta.des,pairs=pair.new,pairs.rvs=rvs) summary(tsdid2) tsd$theta tsdid2$theta tsdid$theta #+END_SRC #+RESULTS[<2018-09-11 10:18:07> c05cfac52e5637e7068a37c12499455107563f9b]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.655 0.05345 0.5502 0.7598 1.606e-34 dependence2 0.345 0.05345 0.2402 0.4498 1.089e-10 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.055 0.3253 2.418 3.693 5.923e-21 attr(,"class") [1] "summary.mets.twostage" [,1] dependence1 2.001187 dependence2 1.054030 [,1] dependence1 2.001187 dependence2 1.054030 [,1] dependence1 2.001187 dependence2 1.054030 #+end_example Finally the same model structure can be setup based on a Kinship coefficient. #+BEGIN_SRC R :results output :exports both :session *R* :cache no # simpler specification via kinship coefficient for each pair kinship <- c() for (i in 1:nrow(pair.new)) { if (pair.types[i,1]=="mother" & pair.types[i,2]=="father") pk1 <- 0 else pk1 <- 0.5 kinship <- c(kinship,pk1) } head(kinship,n=10) out <- make.pairwise.design(pair.new,kinship,type="ace") names(out) # 4 rvs here , here independence since shared component has variance 0 ! out$random.des[,,9] out$theta.des[,,9] #+END_SRC #+RESULTS: #+begin_example [1] 0.0 0.0 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 [1] "random.design" "theta.des" "ant.rvs" [,1] [,2] [,3] [,4] [1,] 1 1 0 1 [2,] 1 0 1 1 [,1] [,2] [1,] 0.5 0 [2,] 0.5 0 [3,] 0.5 0 [4,] 0.0 1 #+end_example Same same #+BEGIN_SRC R :results output :exports both :session *R* :cache no tsdid3 <- twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1)/10,var.link=0,step=1.0, random.design=out$random.design, theta.des=out$theta.des,pairs=pair.new,pairs.rvs=out$ant.rvs) summary(tsdid3) coef(tsdid3) #+END_SRC #+RESULTS[<2018-09-11 09:10:44> 3a0beff321d7e6151d20d574d3ea93a51dfb7919]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.655 0.05345 0.5502 0.7598 1.606e-34 dependence2 0.345 0.05345 0.2402 0.4498 1.089e-10 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.055 0.3253 2.418 3.693 5.923e-21 attr(,"class") [1] "summary.mets.twostage" Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 #+end_example ** Univariate plackett model twostage models The copula known as the Plackett distribution, see \cite{plackett1965,anderson1992time,ghosh2006sjs}, is on the form \begin{align} C(u,v; \theta) = \begin{cases} \frac{ S - (S^2 - 4 u v \theta (\theta-a))}{2 (\theta -1)} & \mbox{ if } \theta \ne 1 \\ u v & \mbox{ if } \theta = 1 \end{cases} \end{align} with $S=1+(\theta-1) (u + v)$. With marginals $S_i$ we now define the bivariate survival function as $C(u_1,u_2)=H(S_1(t_1),S_2(t_2))$ with $u_i=S_i(t_i)$. The dependence parameter $\theta$ has the nice interpretation that the it is equivalent to the odds-ratio of all $2 \times 2$ tables for surviving past any cut of the plane $(t_1,t_2)$, that is $$ \theta = \frac{ P(T_1 > t_1 | T_2 >t_2) P(T_1 \leq t_1 | T_2>t_2) }{P(T_1 > t_1 | T_2 \leq t_2) P(T_1 \leq t_1 | T_2 \leq t_2 ) }. $$ One additional nice feature of the odds-ratio measure it that it is directly linked to the Spearman correlation, $\rho$, that can be computed as \begin{align} \frac{\theta+1}{\theta -1} - \frac{2 \theta}{(\theta-1)^2} \log(\theta) \end{align} when $\theta \ne 1$, if $\theta=1$ then $\rho=0$. This model has a more free parameter than the Clayton-Oakes model. #+BEGIN_SRC R :results output :exports both :session *R* :cache no library(mets) data(diabetes) # Marginal Cox model with treat as covariate margph <- phreg(Surv(time,status)~treat+cluster(id),data=diabetes) # Clayton-Oakes, MLE fitco1<-twostageMLE(margph,data=diabetes,theta=1.0) summary(fitco1) # Plackett model mph <- phreg(Surv(time,status)~treat+cluster(id),data=diabetes) fitp <- survival.twostage(mph,data=diabetes,theta=3.0,Nit=40, clusters=diabetes$id,var.link=1,model="plackett") summary(fitp) # without covariates but with stratafied marg <- phreg(Surv(time,status)~+strata(treat)+cluster(id),data=diabetes) fitpa <- survival.twostage(marg,data=diabetes,theta=1.0, clusters=diabetes$id,score.method="optimize") summary(fitpa) fitcoa <- survival.twostage(marg,data=diabetes,theta=1.0,clusters=diabetes$id, model="clayton.oakes") summary(fitcoa) #+END_SRC #+RESULTS: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 0.9526614 0.3543033 2.68883 0.007170289 0.322645 0.08127892 $type NULL attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates log-Coef. SE z P-val Spearman Corr. SE dependence1 1.14188 0.2784057 4.101497 4.104867e-05 0.3648217 0.08158643 $or Estimate Std.Err 2.5% 97.5% P-value dependence1 3.133 0.8721 1.423 4.842 0.0003283 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates log-Coef. SE z P-val Kendall tau SE dependence1 -0.05683487 0.3239422 -0.1754476 0.8607279 0.3208252 0.07058583 $vargam Estimate Std.Err 2.5% 97.5% P-value dependence1 0.9448 0.306 0.3449 1.545 0.002022 $type [1] "clayton.oakes" attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates log-Coef. SE z P-val Kendall tau SE dependence1 -0.05683996 0.3322322 -0.171085 0.8641569 0.3208241 0.07239207 $vargam Estimate Std.Err 2.5% 97.5% P-value dependence1 0.9447 0.3139 0.3296 1.56 0.002613 $type [1] "clayton.oakes" attr(,"class") [1] "summary.mets.twostage" #+end_example With a regression design #+BEGIN_SRC R :results output :exports both :session *R* :cache no mm <- model.matrix(~-1+factor(adult),diabetes) fitp <- survival.twostage(mph,data=diabetes,theta=3.0,Nit=40, clusters=diabetes$id,var.link=1,model="plackett", theta.des=mm) summary(fitp) #+END_SRC #+RESULTS: #+begin_example Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates log-Coef. SE z P-val Spearman Corr. factor(adult)1 1.098333 0.3436264 3.196298 0.001392032 0.3519988 factor(adult)2 1.231962 0.4938132 2.494794 0.012603018 0.3909505 SE factor(adult)1 0.1016635 factor(adult)2 0.1417283 $or Estimate Std.Err 2.5% 97.5% P-value factor(adult)1 2.999 1.031 0.9792 5.019 0.003613 factor(adult)2 3.428 1.693 0.1102 6.746 0.042861 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" #+end_example #+BEGIN_SRC R :results output :exports both :session *R* :cache no # Piecewise constant cross hazards ratio modelling d <- subset(simClaytonOakes(2000,2,0.5,0,stoptime=2,left=0),!truncated) udp <- piecewise.twostage(c(0,0.5,2),data=d,score.method="optimize", id="cluster",timevar="time", status="status",model="plackett",silent=0) summary(udp) #+END_SRC #+RESULTS[<2018-09-11 09:10:44> 317374c26093d716d9ba134f652d6b5470e9dbe9]: #+begin_example Data-set 1 out of 4 Number of joint events: 529 of 2000 Data-set 2 out of 4 Number of joint events: 248 of 1212 Data-set 3 out of 4 Number of joint events: 254 of 1219 Data-set 4 out of 4 Number of joint events: 633 of 960 [1] 1 Dependence parameter for Plackett model log-coefficient for dependence parameter (SE) 0 - 0.5 0.5 - 2 0 - 0.5 1.761 (0.083) 1.628 (0.128) 0.5 - 2 1.74 (0.128) 2.017 (0.092) Spearman Correlation (SE) 0 - 0.5 0.5 - 2 0 - 0.5 0.532 (0.020) 0.499 (0.033) 0.5 - 2 0.527 (0.032) 0.593 (0.021) #+end_example mets/vignettes/twostage-survival.ltx0000644000176200001440000013131313623061405017473 0ustar liggesusers%\VignetteIndexEntry{Analysis of multivariate survival data} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Analysis of multivariate survival data} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Analysis of multivariate survival data}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Overview} \label{sec:org3befec5} When looking at multivariate survival data with the aim of learning about the dependence that is present, possibly after correcting for some covariates different approaches are available in the mets package \begin{itemize} \item Binary models and adjust for censoring with inverse probabilty of censoring weighting \begin{itemize} \item biprobit model \end{itemize} \item Bivariate surival models of Clayton-Oakes type \begin{itemize} \item With regression structure on dependence parameter \item With additive gamma distributed random effects \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \item Plackett OR model model \begin{itemize} \item With regression structure on OR dependence parameter \end{itemize} \item Cluster stratified Cox \end{itemize} Typically it can be hard or impossible to specify random effects models with special structure among the parameters of the random effects. This is possible for our specification of the random effects models. To be concrete about the model structure assume that we have paired binomial data \(T_1, \delta_1, T_2, \delta_2, X_1, X_2\) where the censored survival responses are \(T_1, \delta_1, T_2, \delta_2\) and we have covariates \(X_1, X_2\). The basic models assumes that each subject has a marginal on Cox-form \[ \lambda_{s(k,i)}(t) \exp( X_{ki}^T \beta) \] where \(s(k,i)\) is a strata variable. \subsection*{Gamma distributed frailties} \label{sec:org3bb9661} The focus of this vignette is describe how to work on bivariate survival data using the addtive gamma-random effects models. We present two different ways of specifying different dependence structures. \begin{itemize} \item Univariate models with a single random effect for each cluster and with a regression design on the variance. \item Multivariate models with multiple random effects for each cluster. \end{itemize} The univariate models are then given a given cluster random effects \(Z_k\) with parameter \(\theta\) the joint survival function is given by the Clayton copula and on the form \[ \psi(\theta, \psi^{-1}(\theta,S_1(t,X_{k1}) ) + \psi^{-1}(\theta, S_1(t,X_{k1}) ) \] where \(\psi\) is the Laplace transform of a gamma distributed random variable with mean 1 and variance \(\theta\). We then model the variance within clusters by a cluster specific regression design such that \[ \theta = z_j^T \alpha \] where \(z\) is the regression design (specified by theta.des in the software). This model can be fitted using a pairwise likelihood or the pseudo-likelihood using either \begin{itemize} \item twostage \item twostageMLE \end{itemize} To make the twostage approach possible we need a model with specific structure for the marginals. Therefore given the random effect of the clusters the survival distributions within a cluster are independent and on the form \[ P(T_j > t| X_j,Z) = exp( -Z \cdot \Psi^{-1}(\nu^{-1},S(t|X_j)) ) \] with \(\Psi\) the laplace of the gamma distribution with mean 1 and variance \(1/\nu\). \subsection*{Additive Gamma frailties} \label{sec:orge7e6b98} For the multivariate models we are given a multivarite random effect each cluster \(Z=(Z_1,...,Z_d)\) with d random effects. The total random effect for each subject \(j\) in a cluster is then specified using a regression design on these random effects, with a regression vector \(V_j\) such that the total random effect is \(V_j^T (Z_1,...,Z_d)\). The elements of \(V_J\) are 1/0. The random effects \((Z_1,...,Z_d)\) has associated parameters \((\lambda_1,...,\lambda_d)\) and \(Z_j\) is Gamma distributed with \begin{itemize} \item mean \(\lambda_j/V_1^T \lambda\) \item variance \(\lambda_j/(V_1^T \lambda)^2\) \end{itemize} The key assumption to make the two-stage fitting possible is that \[ \nu =V_j^T \lambda \] is constant within clusters. The consequence of this is that the total random effect for each subject within a cluster, \(V_j^T (Z_1,...,Z_d)\) , is gamma distributed with variance \(1/\nu\). The DEFAULT parametrization (var.par=1) uses the variances of the random effecs \[ \theta_j = \lambda_j/\nu^2 \] For alternative parametrizations one can specify that the parameters are \(\theta_j=\lambda_j\) with the argument var.par=0. Finally the parameters \((\theta_1,...,\theta_d)\) are related to the parameters of the model by a regression construction \(M\) (d x k), that links the \(d\) \(\theta\) parameters with the \(k\) underlying \(\alpha\) parameters \[ \theta = M \alpha. \] The default is a diagonal matrix for \(M\). This can be used to make structural assumptions about the variances of the random-effects as is needed for the ACE model for example. In the software \(M\) is called theta.des Assume that the marginal survival distribution for subject \(i\) within cluster \(k\) is given by \(S_{X_{k,i}}(t)\) given covariates \(X_{k,i}\). Now given the random effects of the cluster \(Z_k\) and the covariates\(X_{k,i}\) \(i=1,\dots,n_k\) we assume that subjects within the cluster are independent with survival distributions \begin{align*} \exp(- ( V_{k,i} Z_k) \Psi^{-1} (\nu,S_{X_{k,i}}(t)) ). \end{align*} A consequence of this is that the hazards given the covariates \(X_{k,i}\) and the random effects \(Z_k\) are given by \begin{align} \lambda_{k,i}(t;X_{k,i},Z_{k,i}) = ( V_{k,i} V_k) D_3 \Psi^{-1} (\nu,S_{X_{k,i}}(t)) D_t S_{X_{k,i}}(t) \label{eq-cond-haz} \end{align} where \(D_t\) and \(D_3\) denotes the partial derivatives with respect to \(t\) and the third argument, respectively. Further, we can express the multivariate survival distribution as \begin{align} S(t_1,\dots,t_m) & = \exp( -\sum_{i=1}^m (V_i Z) \Psi^{-1}(\eta_l,\nu_l,S_{X_{k,i}}(t_i)) ) \nonumber \\ & = \prod_{l=1}^p \Psi(\eta_l,\eta , \sum_{i=1}^m Q_{k,i} \Psi^{-1}(\eta,\eta,S_{X_{k,i}}(t_i))). \label{eq-multivariate-surv} \end{align} In the case of considering just pairs, we write this function as \(C(S_{k,i}(t),S_{k,j}(t))\). In addition to survival times from this model, we assume that we independent right censoring present \(U_{k,i}\) such that the given \(V_k\) and the covariates\(X_{k,i}\) \(i=1,\dots,n_k\) \((U_{k,1},\dots,U_{k,n_k})\) of \((T_{k,1},\dots,T_{k,n_k})\), and the conditional censoring distribution do not depend on \(V_k\). One consequence of the model strucure is that the Kendall's can be computed for two-subjects \((i,j)\) across two clusters ``1'' and ``2'' as \begin{align} E( \frac{( V_{1i} Z_1- V_{1j}Z_2)( V_{2i}Z_1 - V_{2j}Z_2 )}{( V_{1i}Z_1 + V_{2i}Z_2 ) ( V_{1j}Z_1 + V_{2j}Z_2 )} ) \end{align} under the assumption that that we compare pairs with equivalent marginals, \(S_{X_{1,i}}(t)= S_{X_{2,i}}(t)\) and \(S_{X_{1,j}}(t)= S_{X_{2,j}}(t)\), and that \(S_{X_{1,i}}(\infty)= S_{X_{1,j}}(\infty)=0\). Here we also use that \(\eta\) is the same across clusters. The Kendall's tau would be the same for \eqref{frailty-model} due to the same additive structure for the frailty terms, and the random effects thus have the same interpretation in terms of Kendall's tau. \subsection*{Univariate gamma (clayton-oakes) model twostage models} \label{sec:org138bf8c} We start by fitting simple Clayton-Oakes models for the data, that is with an overall random effect that is Gamma distrubuted with variance \(\theta\). We can fit the model by a pseudo-MLE (twostageMLE) and a pairwise composite likelihood approach (twostage). The pseudo-liklihood and the composite pairwise likelhood gives quite similar results in this case. In addition the log-parametrization is illustrated with the var.link=1 option. In addition it is specified that we want a "clayton.oakes" model. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) data(diabetes) # Marginal Cox model with treat as covariate margph <- phreg(Surv(time,status)~treat+cluster(id),data=diabetes) # Clayton-Oakes, MLE fitco1<-twostageMLE(margph,data=diabetes,theta=1.0) summary(fitco1) # Clayton-Oakes fitco2 <- survival.twostage(margph,data=diabetes,theta=0.0,detail=0, clusters=diabetes$id,var.link=1,model="clayton.oakes") summary(fitco2) fitco3 <- survival.twostage(margph,data=diabetes,theta=1.0,detail=0, clusters=diabetes$id,var.link=0,model="clayton.oakes") summary(fitco3) \end{lstlisting} \begin{verbatim} Loading required package: timereg Loading required package: survival Loading required package: lava mets version 1.2.4 Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 0.9526614 0.3543033 2.68883 0.007170289 0.322645 0.08127892 $type NULL attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates log-Coef. SE z P-val Kendall tau SE dependence1 -0.04849523 0.330665 -0.1466597 0.8834006 0.3226451 0.07226526 $vargam Estimate Std.Err 2.5% 97.5% P-value dependence1 0.9527 0.315 0.3352 1.57 0.002493 $type [1] "clayton.oakes" attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 0.9526619 0.3150119 3.024209 0.002492843 0.3226451 0.07226526 $type [1] "clayton.oakes" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} The marginal models can be either structured Cox model or as here with a baseline for each strata. This gives quite similar results to those before. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # without covariates but marginal model stratified marg <- phreg(Surv(time,status)~+strata(treat)+cluster(id),data=diabetes) fitcoa <- survival.twostage(marg,data=diabetes,theta=1.0,clusters=diabetes$id, model="clayton.oakes") summary(fitcoa) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates log-Coef. SE z P-val Kendall tau SE dependence1 -0.05683996 0.3322322 -0.171085 0.8641569 0.3208241 0.07239207 $vargam Estimate Std.Err 2.5% 97.5% P-value dependence1 0.9447 0.3139 0.3296 1.56 0.002613 $type [1] "clayton.oakes" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \subsection*{Piecewise constant Clayton-Oakes model} \label{sec:orgedb6727} Let the cross-hazard ratio (CHR) be defined as \begin{align} \eta(t_1,t_2) = \frac{ \lambda_1(t_1| T_2=t_2)}{ \lambda_1(t_1| T_2 \ge t_2)} = \frac{ \lambda_2(t_2| T_1=t_1)}{ \lambda_2(t_2| T_1 \ge t_1)} \end{align} where \(\lambda_1\) and \(\lambda_2\) are the conditional hazard functions of \(T_1\) and \(T_2\) given covariates. For the Clayton-Oakes model this ratio is \(\eta(t_1,t_2) = 1+\theta\), and as a consequence we see that if the co-twin is dead at any time we would increase our risk assessment on the hazard scale with the constant \(\eta(t_1,t_2)\). The Clayton-Oakes model also has the nice property that Kendall's tau is linked directly to the dependence parameter \(\theta\) and is \(1/(1+2/\theta)\). A very useful extension of the model the constant cross-hazard ratio (CHR) model is the piecewise constant cross-hazard ratio (CHR) for bivariate survival data \cite{nan2006piecewise}, and this model was extended to competing risks in \cite{shih2010modeling}. In the survival setting we let the CHR \begin{align} \eta(t_1,t_2) & = \sum \eta_{i,j} I(t_1 \in I_i, t_2 \in I_j) \end{align} The model lets the CHR by constant in different part of the plane. This can be thought of also as having a separate Clayton-Oakes model for each of the regions specified in the plane here by the cut-points \(c(0,0.5,2)\) thus defining 9 regions. This provides a constructive goodness of fit test for the whether the Clayton-Oakes model is valid. Indeed if valid the parameter should be the same in all regions. First we generate some data from the Clayton-Oakes model with variance \(0.5\) and 2000 pairs. And fit the related model. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} d <- simClaytonOakes(2000,2,0.5,0,3) margph <- phreg(Surv(time,status)~x+cluster(cluster),data=d) # Clayton-Oakes, MLE fitco1<-twostageMLE(margph,data=d) summary(fitco1) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.01888 0.08970192 22.50654 0 0.5023489 0.01110764 $type NULL attr(,"class") [1] "summary.mets.twostage" \end{verbatim} Now we cut the region at the cut-points \(c(0,0.5,2)\) thus defining 9 regions and fit a separate model for each region. We see that the parameter is indeed rather constant over the 9 regions. A formal test can be constructed. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} udp <- piecewise.twostage(c(0,0.5,2),data=d,score.method="optimize", id="cluster",timevar="time", status="status",model="clayton.oakes",silent=0) summary(udp) \end{lstlisting} \begin{verbatim} Data-set 1 out of 4 Number of joint events: 518 of 2000 Data-set 2 out of 4 Number of joint events: 274 of 1232 Data-set 3 out of 4 Number of joint events: 247 of 1203 Data-set 4 out of 4 Number of joint events: 594 of 953 [1] 1 Dependence parameter for Clayton-Oakes model Score of log-likelihood for parameter estimates (too large?) 0 - 0.5 0.5 - 2 0 - 0.5 0.0019673733 0.001451886 0.5 - 2 0.0007297083 0.003142920 log-coefficient for dependence parameter (SE) 0 - 0.5 0.5 - 2 0 - 0.5 0.687 (0.069) 0.677 (0.093) 0.5 - 2 0.733 (0.100) 0.718 (0.060) Kendall's tau (SE) 0 - 0.5 0.5 - 2 0 - 0.5 0.498 (0.017) 0.496 (0.023) 0.5 - 2 0.51 (0.025) 0.506 (0.015) \end{verbatim} \subsection*{Multivariate gamma twostage models} \label{sec:org1b5ea9b} To illustrate how the multivariate models can be used, we first set up some twin data with ACE structure. That is two shared random effects, one being the genes \(\sigma_g^2\) and one the environmental effect \(\sigma_e^2\). Monozygotic twins share all genes whereas the dizygotic twins only share half the genes. This can be expressed via 5 random effect for each twin pair (for example). We start by setting this up. The pardes matrix tells how the the parameters of the 5 random effects are related, and the matrix her first has one random effect with parameter \(\theta_1\) (here the \(\sigma_g^2\)), then the next 3 random effects have parameters \(0.5 \theta_1\) (here \(0.5 \sigma_g^2\)), and the last random effect that is given by its own parameter \(\theta_2\) (here \(\sigma_e^2\)). \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data <- simClaytonOakes.twin.ace(2000,2,1,0,3) out <- twin.polygen.design(data,id="cluster") pardes <- out$pardes pardes \end{lstlisting} \begin{verbatim} [,1] [,2] [1,] 1.0 0 [2,] 0.5 0 [3,] 0.5 0 [4,] 0.5 0 [5,] 0.0 1 \end{verbatim} The last part of the model structure is to decide how the random effects are shared for the different pairs (MZ and DZ), this is specfied by the random effects design (\(V_1\) and \(V_2\)) for each pair. This is here specified by an overall designmatrix for each subject (since they enter all pairs with the same random effects design). For an MZ pair the two share the full gene random effect and the full environmental random effect. In contrast the DZ pairs share the 2nd random effect with half the gene-variance and have both a non-shared gene-random effect with half the variance, and finally a fully shared environmental random effect. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} des.rv <- out$des.rv # MZ head(des.rv,2) # DZ tail(des.rv,2) \end{lstlisting} \begin{verbatim} MZ DZ DZns1 DZns2 env 1 1 0 0 0 1 2 1 0 0 0 1 MZ DZ DZns1 DZns2 env 3999 0 1 1 0 1 4000 0 1 0 1 1 \end{verbatim} Now we call the twostage function. We see that we essentially recover the true values, and note that the output also compares the sizes of the genetic and environmental random effect. This number is sometimes called the heritability. In addition the total variance for each subject is also computed and is here around \(3\), as we indeed constructed. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} aa <- phreg(Surv(time,status)~x+cluster(cluster),data=data) ts <- twostage(aa,data=data,clusters=data$cluster,detail=0, theta=c(2,1),var.link=0,step=0.5, random.design=des.rv,theta.des=pardes) summary(ts) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.2111163 0.2219525 9.962113 0.000000e+00 0.5250665 0.02503201 dependence2 0.7431872 0.1706430 4.355217 1.329349e-05 0.2709211 0.04535315 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.7484 0.05898 0.6328 0.8640 6.669e-37 dependence2 0.2516 0.05898 0.1360 0.3672 1.995e-05 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 2.954 0.1426 2.675 3.234 2.514e-95 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} The estimates can be transformed into Kendall's tau estimates for MZ and DZ twins. The Kendall's tau in the above output reflects how a gamma distributed random effect in the normal Clayton-Oakes model is related to the Kendall's tau. In this setting the Kendall's of MZ and DZ, however, should reflect both random effects. We do this based on simulations. The Kendall's tau of the MZ is around 0.60, and for DZ around 0.33. Both are quite high and this is due to a large shared environmental effect and large genetic effect. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} kendall.ClaytonOakes.twin.ace(ts$theta[1],ts$theta[2],K=10000) \end{lstlisting} \begin{verbatim} $mz.kendall [1] 0.5984888 $dz.kendall [1] 0.3257834 \end{verbatim} \subsection*{Family data} \label{sec:orga7a0fcf} For family data, things are quite similar since we use only the pairwise structure. We show how the designs are specified. First we simulate data from an ACE model. 2000 families with two-parents that share only the environment, and two-children that share genes with their parents. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) set.seed(1000) data <- simClaytonOakes.family.ace(2000,2,1,0,3) head(data) data$number <- c(1,2,3,4) data$child <- 1*(data$number==3) \end{lstlisting} \begin{verbatim} time status x cluster type mintime lefttime truncated 1 0.26343780 1 1 1 mother 0.26343780 0 0 2 1.14490828 1 1 1 father 0.26343780 0 0 3 0.86649229 1 1 1 child 0.26343780 0 0 4 0.30843425 1 0 1 child 0.26343780 0 0 5 3.00000000 0 0 2 mother 0.07739746 0 0 6 0.07739746 1 0 2 father 0.07739746 0 0 \end{verbatim} To set up the random effects some functions can be used. We here set up the ACE model that has 9 random effects with one shared environmental effect (the last random effect) and 4 genetic random effects for each parent, with variance \(\sigma_g^2/4\). The random effect is again set-up with an overall designmatrix because it is again the same for each subject for all comparisons across family members. We below demonstrate how the model can be specified in various other ways. Each child share 2 genetic random effects with each parent, and also share 2 genetic random effects with his/her sibling. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} out <- ace.family.design(data,member="type",id="cluster") out$pardes head(out$des.rv,4) \end{lstlisting} \begin{verbatim} [,1] [,2] [1,] 0.25 0 [2,] 0.25 0 [3,] 0.25 0 [4,] 0.25 0 [5,] 0.25 0 [6,] 0.25 0 [7,] 0.25 0 [8,] 0.25 0 [9,] 0.00 1 m1 m2 m3 m4 f1 f2 f3 f4 env [1,] 1 1 1 1 0 0 0 0 1 [2,] 0 0 0 0 1 1 1 1 1 [3,] 1 1 0 0 1 1 0 0 1 [4,] 1 0 1 0 1 0 1 0 1 \end{verbatim} Then we fit the model \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} pa <- phreg(Surv(time,status)~+1+cluster(cluster),data=data) aa <- aalen(Surv(time,status)~+1,data=data,robust=0) # make ace random effects design ts <- twostage(pa,data=data,clusters=data$cluster, var.par=1,var.link=0,theta=c(2,1), random.design=out$des.rv,theta.des=out$pardes) summary(ts) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.185967 0.19164670 11.40623 0 0.5222132 0.02187458 dependence2 0.947110 0.07648339 12.38321 0 0.3213691 0.01761183 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.6977 0.02997 0.6390 0.7564 7.182e-120 dependence2 0.3023 0.02997 0.2436 0.3610 6.359e-24 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.133 0.1737 2.793 3.474 1.074e-72 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} The model can also be fitted by specifying the pairs that one wants for the pairwise likelhood. This is done by specifying the pairs argument. We start by considering all pairs as we also did before. All pairs can be written up by calling the familycluster.index function. There are 12000 pairs to consider and the last 12 pairs for the last family is written out here. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # now specify fitting via specific pairs # first all pairs mm <- familycluster.index(data$cluster) head(mm$familypairindex,n=10) pairs <- matrix(mm$familypairindex,ncol=2,byrow=TRUE) tail(pairs,n=12) \end{lstlisting} \begin{verbatim} [1] 1 2 1 3 1 4 2 3 2 4 [,1] [,2] [11989,] 7993 7994 [11990,] 7993 7995 [11991,] 7993 7996 [11992,] 7994 7995 [11993,] 7994 7996 [11994,] 7995 7996 [11995,] 7997 7998 [11996,] 7997 7999 [11997,] 7997 8000 [11998,] 7998 7999 [11999,] 7998 8000 [12000,] 7999 8000 \end{verbatim} Then fitting the model using only specified pairs \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} ts <- twostage(pa,data=data,clusters=data$cluster, theta=c(2,1),var.link=0,step=1.0, random.design=out$des.rv, theta.des=out$pardes,pairs=pairs) summary(ts) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.185967 0.18986604 11.51321 0 0.5222132 0.02167133 dependence2 0.947110 0.07929082 11.94476 0 0.3213691 0.01825829 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.6977 0.03044 0.6381 0.7574 2.659e-116 dependence2 0.3023 0.03044 0.2426 0.3619 3.010e-23 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.133 0.1713 2.797 3.469 1.057e-74 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} Now we only use a random sample of the pairs by sampling these. The pairs picked still refers to the data given in the data argument, and clusters (families) are also specified as before. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} ssid <- sort(sample(1:12000,2000)) tsd <- twostage(aa,data=data,clusters=data$cluster, theta=c(2,1)/10,var.link=0,step=1.0, random.design=out$des.rv,iid=1, theta.des=out$pardes,pairs=pairs[ssid,]) summary(tsd) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.655 0.05345 0.5502 0.7598 1.606e-34 dependence2 0.345 0.05345 0.2402 0.4498 1.089e-10 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.055 0.3253 2.418 3.693 5.923e-21 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} Sometimes one only has the data from the pairs in addition to for example a cohort estimate of the marginal surival models. We now demonstrate how this is dealt with. Everything is essentially as before but need to organize the design differently compared to before we specified the design for everybody in the cohort. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} ids <- sort(unique(c(pairs[ssid,]))) pairsids <- c(pairs[ssid,]) pair.new <- matrix(fast.approx(ids,c(pairs[ssid,])),ncol=2) head(pair.new) # this requires that pair.new refers to id's in dataid (survival, status and so forth) # random.design and theta.des are constructed to be the array 3 dims via individual specfication from ace.family.design dataid <- dsort(data[ids,],"cluster") outid <- ace.family.design(dataid,member="type",id="cluster") outid$pardes head(outid$des.rv) \end{lstlisting} \begin{verbatim} [,1] [,2] [1,] 1 2 [2,] 3 4 [3,] 3 5 [4,] 4 6 [5,] 7 8 [6,] 9 10 [,1] [,2] [1,] 0.25 0 [2,] 0.25 0 [3,] 0.25 0 [4,] 0.25 0 [5,] 0.25 0 [6,] 0.25 0 [7,] 0.25 0 [8,] 0.25 0 [9,] 0.00 1 m1 m2 m3 m4 f1 f2 f3 f4 env [1,] 1 1 1 1 0 0 0 0 1 [2,] 0 0 0 0 1 1 1 1 1 [3,] 1 1 1 1 0 0 0 0 1 [4,] 0 0 0 0 1 1 1 1 1 [5,] 1 1 0 0 1 1 0 0 1 [6,] 1 0 1 0 1 0 1 0 1 \end{verbatim} Now fitting the model using only the pair data. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tsdid <- twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1)/10,var.link=0,step=1.0, random.design=outid$des.rv,iid=1, theta.des=outid$pardes,pairs=pair.new) summary(tsdid) coef(tsdid) coef(tsd) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.655 0.05345 0.5502 0.7598 1.606e-34 dependence2 0.345 0.05345 0.2402 0.4498 1.089e-10 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.055 0.3253 2.418 3.693 5.923e-21 attr(,"class") [1] "summary.mets.twostage" Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 \end{verbatim} Now we illustrate how one can also directly specify the random.design and theta.design for each pair, rather than taking the rows of the des.rv for the relevant pairs. This can be much simpler in some situations. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} pair.types <- matrix(dataid[c(t(pair.new)),"type"],byrow=T,ncol=2) head(pair.new) head(pair.types) # here makes pairwise design , simpler random.design og pardes, parameters # stil varg, varc # mother, child, share half rvm=c(1,1,0) rvc=c(1,0,1), # thetadesmcf=rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) # # father, child, share half rvf=c(1,1,0) rvc=c(1,0,1), # thetadescf=rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) # # child, child, share half rvc=c(1,1,0) rvc=c(1,0,1), # thetadesmf=rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) # # mother, father, share 0 rvm=c(1,0) rvf=c(0,1), # thetadesmf=rbind(c(1,0),c(1,0),c(0,1)) theta.des <- array(0,c(4,2,nrow(pair.new))) random.des <- array(0,c(2,4,nrow(pair.new))) # random variables in each pair rvs <- c() for (i in 1:nrow(pair.new)) { if (pair.types[i,1]=="mother" & pair.types[i,2]=="father") { theta.des[,,i] <- rbind(c(1,0),c(1,0),c(0,1),c(0,0)) random.des[,,i] <- rbind(c(1,0,1,0),c(0,1,1,0)) rvs <- c(rvs,3) } else { theta.des[,,i] <- rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) random.des[,,i] <- rbind(c(1,1,0,1),c(1,0,1,1)) rvs <- c(rvs,4) } } # 3 rvs here random.des[,,7] theta.des[,,7] # 4 rvs here random.des[,,1] theta.des[,,1] head(rvs) \end{lstlisting} \begin{verbatim} [,1] [,2] [1,] 1 2 [2,] 3 4 [3,] 3 5 [4,] 4 6 [5,] 7 8 [6,] 9 10 [,1] [,2] [1,] "mother" "father" [2,] "mother" "father" [3,] "mother" "child" [4,] "father" "child" [5,] "child" "child" [6,] "child" "child" [,1] [,2] [,3] [,4] [1,] 1 1 0 1 [2,] 1 0 1 1 [,1] [,2] [1,] 0.5 0 [2,] 0.5 0 [3,] 0.5 0 [4,] 0.0 1 [,1] [,2] [,3] [,4] [1,] 1 0 1 0 [2,] 0 1 1 0 [,1] [,2] [1,] 1 0 [2,] 1 0 [3,] 0 1 [4,] 0 0 [1] 3 3 4 4 4 4 \end{verbatim} And fitting again the same model as before \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tsdid2 <- twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1)/10,var.link=0,step=1.0, random.design=random.des, theta.des=theta.des,pairs=pair.new,pairs.rvs=rvs) summary(tsdid2) tsd$theta tsdid2$theta tsdid$theta \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.655 0.05345 0.5502 0.7598 1.606e-34 dependence2 0.345 0.05345 0.2402 0.4498 1.089e-10 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.055 0.3253 2.418 3.693 5.923e-21 attr(,"class") [1] "summary.mets.twostage" [,1] dependence1 2.001187 dependence2 1.054030 [,1] dependence1 2.001187 dependence2 1.054030 [,1] dependence1 2.001187 dependence2 1.054030 \end{verbatim} Finally the same model structure can be setup based on a Kinship coefficient. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # simpler specification via kinship coefficient for each pair kinship <- c() for (i in 1:nrow(pair.new)) { if (pair.types[i,1]=="mother" & pair.types[i,2]=="father") pk1 <- 0 else pk1 <- 0.5 kinship <- c(kinship,pk1) } head(kinship,n=10) out <- make.pairwise.design(pair.new,kinship,type="ace") names(out) # 4 rvs here , here independence since shared component has variance 0 ! out$random.des[,,9] out$theta.des[,,9] \end{lstlisting} \begin{verbatim} [1] 0.0 0.0 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 [1] "random.design" "theta.des" "ant.rvs" [,1] [,2] [,3] [,4] [1,] 1 1 0 1 [2,] 1 0 1 1 [,1] [,2] [1,] 0.5 0 [2,] 0.5 0 [3,] 0.5 0 [4,] 0.0 1 \end{verbatim} Same same \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tsdid3 <- twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1)/10,var.link=0,step=1.0, random.design=out$random.design, theta.des=out$theta.des,pairs=pair.new,pairs.rvs=out$ant.rvs) summary(tsdid3) coef(tsdid3) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.655 0.05345 0.5502 0.7598 1.606e-34 dependence2 0.345 0.05345 0.2402 0.4498 1.089e-10 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.055 0.3253 2.418 3.693 5.923e-21 attr(,"class") [1] "summary.mets.twostage" Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 \end{verbatim} \subsection*{Univariate plackett model twostage models} \label{sec:org5250adb} The copula known as the Plackett distribution, see \cite{plackett1965,anderson1992time,ghosh2006sjs}, is on the form \begin{align} C(u,v; \theta) = \begin{cases} \frac{ S - (S^2 - 4 u v \theta (\theta-a))}{2 (\theta -1)} & \mbox{ if } \theta \ne 1 \\ u v & \mbox{ if } \theta = 1 \end{cases} \end{align} with \(S=1+(\theta-1) (u + v)\). With marginals \(S_i\) we now define the bivariate survival function as \(C(u_1,u_2)=H(S_1(t_1),S_2(t_2))\) with \(u_i=S_i(t_i)\). The dependence parameter \(\theta\) has the nice interpretation that the it is equivalent to the odds-ratio of all \(2 \times 2\) tables for surviving past any cut of the plane \((t_1,t_2)\), that is $$ \theta = \frac{ P(T_1 > t_1 | T_2 >t_2) P(T_1 \leq t_1 | T_2>t_2) }{P(T_1 > t_1 | T_2 \leq t_2) P(T_1 \leq t_1 | T_2 \leq t_2 ) }. $$ One additional nice feature of the odds-ratio measure it that it is directly linked to the Spearman correlation, \(\rho\), that can be computed as \begin{align} \frac{\theta+1}{\theta -1} - \frac{2 \theta}{(\theta-1)^2} \log(\theta) \end{align} when \(\theta \ne 1\), if \(\theta=1\) then \(\rho=0\). This model has a more free parameter than the Clayton-Oakes model. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) data(diabetes) # Marginal Cox model with treat as covariate margph <- phreg(Surv(time,status)~treat+cluster(id),data=diabetes) # Clayton-Oakes, MLE fitco1<-twostageMLE(margph,data=diabetes,theta=1.0) summary(fitco1) # Plackett model mph <- phreg(Surv(time,status)~treat+cluster(id),data=diabetes) fitp <- survival.twostage(mph,data=diabetes,theta=3.0,Nit=40, clusters=diabetes$id,var.link=1,model="plackett") summary(fitp) # without covariates but with stratafied marg <- phreg(Surv(time,status)~+strata(treat)+cluster(id),data=diabetes) fitpa <- survival.twostage(marg,data=diabetes,theta=1.0, clusters=diabetes$id,score.method="optimize") summary(fitpa) fitcoa <- survival.twostage(marg,data=diabetes,theta=1.0,clusters=diabetes$id, model="clayton.oakes") summary(fitcoa) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 0.9526614 0.3543033 2.68883 0.007170289 0.322645 0.08127892 $type NULL attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates log-Coef. SE z P-val Spearman Corr. SE dependence1 1.14188 0.2784057 4.101497 4.104867e-05 0.3648217 0.08158643 $or Estimate Std.Err 2.5% 97.5% P-value dependence1 3.133 0.8721 1.423 4.842 0.0003283 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates log-Coef. SE z P-val Kendall tau SE dependence1 -0.05683487 0.3239422 -0.1754476 0.8607279 0.3208252 0.07058583 $vargam Estimate Std.Err 2.5% 97.5% P-value dependence1 0.9448 0.306 0.3449 1.545 0.002022 $type [1] "clayton.oakes" attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates log-Coef. SE z P-val Kendall tau SE dependence1 -0.05683996 0.3322322 -0.171085 0.8641569 0.3208241 0.07239207 $vargam Estimate Std.Err 2.5% 97.5% P-value dependence1 0.9447 0.3139 0.3296 1.56 0.002613 $type [1] "clayton.oakes" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} With a regression design \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} mm <- model.matrix(~-1+factor(adult),diabetes) fitp <- survival.twostage(mph,data=diabetes,theta=3.0,Nit=40, clusters=diabetes$id,var.link=1,model="plackett", theta.des=mm) summary(fitp) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates log-Coef. SE z P-val Spearman Corr. factor(adult)1 1.098333 0.3436264 3.196298 0.001392032 0.3519988 factor(adult)2 1.231962 0.4938132 2.494794 0.012603018 0.3909505 SE factor(adult)1 0.1016635 factor(adult)2 0.1417283 $or Estimate Std.Err 2.5% 97.5% P-value factor(adult)1 2.999 1.031 0.9792 5.019 0.003613 factor(adult)2 3.428 1.693 0.1102 6.746 0.042861 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # Piecewise constant cross hazards ratio modelling d <- subset(simClaytonOakes(2000,2,0.5,0,stoptime=2,left=0),!truncated) udp <- piecewise.twostage(c(0,0.5,2),data=d,score.method="optimize", id="cluster",timevar="time", status="status",model="plackett",silent=0) summary(udp) \end{lstlisting} \begin{verbatim} Data-set 1 out of 4 Number of joint events: 529 of 2000 Data-set 2 out of 4 Number of joint events: 248 of 1212 Data-set 3 out of 4 Number of joint events: 254 of 1219 Data-set 4 out of 4 Number of joint events: 633 of 960 [1] 1 Dependence parameter for Plackett model log-coefficient for dependence parameter (SE) 0 - 0.5 0.5 - 2 0 - 0.5 1.761 (0.083) 1.628 (0.128) 0.5 - 2 1.74 (0.128) 2.017 (0.092) Spearman Correlation (SE) 0 - 0.5 0.5 - 2 0 - 0.5 0.532 (0.020) 0.499 (0.033) 0.5 - 2 0.527 (0.032) 0.593 (0.021) \end{verbatim} \end{document}mets/vignettes/rec1.jpg0000644000176200001440000005276313623061405014603 0ustar liggesusersJFIFC    $.' ",#(7),01444'9=82<.342C  2!!22222222222222222222222222222222222222222222222222&" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( jox؋KE<}F-d9K3An33P|F] E5ð(1\DK#n>]@!<Śg=sZnKT}<ɴ0m9FIJ(/WWҮH-B[H6Y xZQ@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@)o/%[2A8ry VG&\E'V0?4(C(M~. "M4?)imu,ڶ;C' 8z*)e1-@qhC#<[ F?M~_~ZPG%?7&J4oMk@h?(5ERլu6-.R봩Ps5vri.kb ( ( Okq) R*z?-jPhO&Jo'[4P7%Z7?~Ig_~p]K"9O0UsQ V?O~$hF5okJ-Nwc\^ c@He9 89 s(Jo'H-gKX+9 Nrq8 M4?)?4*MFL捷(z}ޥZҥ1;72Χ{qQ.F +GRQߗi4 x#xkb2?(4Qߗk^G/ F?M~_z(#~G%?7& 7{I(H`Ҭ>_I(((({wek[57067E4ad:W![ ŀ-*pA)WUD<3BQ5jDtM?KwY2АjG((ExV]IU/(lXsY VFR1{1v_:Ǹ,@ wfu_ ?GG(V θFc 0GSEǁ win72\0x#(?9/Y:46Wwh8iPEPEPA u8EVH1@9jї5X9jї5@Q@Q@fo_5+J|RM&ďUgAhFN_pxEu"wH(wG((Z4+ӭ,o< t3uCZ𭎻yԒ^Pر u_ ?GG(8x]e;FKlDg9[J`<`F0HP[u9>WU` €(\xJv`p@XC!%#9o?˚_A]WT~q=s4"#<,TN]:Т((BB$$Y'VN!O $yJUݵz9HLj??'QQEHQ@]_ZZD(Y۴Z`Zrpx{T5j9gV IR@i$  ׅ(GsZV6wʫyi©ʉsZk \V|ŴGַG(j㌜]ӳ%{D>n--aF9+ a>VG((%EʵI+JMڏ,5-YfIg1R6ל0#5Z?eF@P!y<(fPdQ2e)\P ; x;L/6*ʌRWH<-` A]WPi~GQttqI!O d_K %ccܟSZG υ(Gs[Ճ [w5@Q@Q@Q@Q@Q@85JY>X ֫ԶoNXTOJ 8kV8׫1o..ulZN`ywu{ʜ }W%>a ?hqQ@Q@i"ɕnL!/>8 V+̈ +l  nQEqtWOz %ʃ?Նڻ*>!ȏ?5+(((((*iPqv4kdH< f:*+y%ۓTf O_otmywmRqg&%O1QPH@ 4m#`Os[m#`Os[QEU-Z6[d*6@ I@֟]ӚKO&,b>Ul XcR2qY%%Y.u;4$FO#/J+-aQCEPEPEPEPEPE[Bd8`u4]4GsN+ӯpj,i(2ZVX7mtl杮˫jiZp!jp˸bu:%1M 1"AxX(n+_~z54 $ 3TGRU):RlF순yf,D7;8- iVh< '-Y8i#摏SmdwFy]~dVwS\CwIx1|ܒIbFxx_ڂZݪiJZ!'Zج}j-lVQEQEQE|BjWO\/އFtQEQEQEQEQE QJeI9&`TzCQm.dI%8 RIu&)wс4~Bw!յ&x3 4Yןf6Io#poPEPEPEPEP&m1VU6p}I$AW.$GEu_kk10c<\+곛va駬ݏm--2NLQ z' *Xi99QS25R 5nLlX#Z}ZG4_Dc{UkbBO䵱L(((>!ȏ?5+cCRz((((* Lp |v}vb ފIM/ORmkU+)`V>Gr@9;#8 Q[ii&x>41Y+nc'>lbZtjESА+Z8Q\z\ 28+Z1ri.kbri.kb ( ( e  XTu=/XZJ((((( 'em~U?5vmxYS4]d v}QwDSs3>?FM&bJd #Yg?R+ש/Vt {REqc[c@QEQEbx6 Y4IbP a#ZG,o;Lcd I-ry8皞OP bx?)RAV`G&CX #F Xs#2i躤Sťk^@|A! Q淨(((LzTd _|JMݔ+X2]U϶HXGagy!,zԓ~Q9m{<{?R;֊3#w5 _y&Y00) R։XQE1BO䵱X!'Zؠ(((cCRz>!ȏ?5+(((*),z@o&bAOŭ=ZD,q*Mj3brOzW[4zeF#A"A@=464)y$bZGbY$$ռQk{ª-m]HA21һ/ǸQEPV>!O lV>!O lQEQEQE [w5X> υ(Gs[QEQEQE˕@cWRP[mUqXOZ3)-#0TQtЧTf<8یORwvGu(Ǟ]?2坤V6[B=X'5B%'VMy5v* ((>a ?c{Ukb ( ( *3\0[`X#u 7yNӥ.1gV˸S"=Ԯk}BׅZ(k7JGK̥dE#">>Gj݂ ௩و%_"D@QZEPEP>_I+@گ$K[QEQEɡ HR2H>DcӬmCV1F:n#S("=Ԯ_#J((S ['4F\Q+buf@O9-F iG%A0C|N70$z @{xg(n/3ӰjJPsZpB!>c-u%QEQEc>F\c>F\QEC[Ƴ\X@ı!W E]Kux̗"1ګA?ROzvo6W%'k^s-=/XZJ((((K*HQ^ew9PiLaMEt)-y8ܑ̯+;dZX{Qvj db3]twJU:_2^[EW!AEPXGa ?c{Ukb ( +:ƋAhK)In XqQ޴4맾.’LI1PJ8(Q@/އFt|BjWO@Q@Q@g˺@/\zeF\=k̟f=Y(,r[h q`h k31fP\C p{)q!_+{($Y6QekHAh8?![pD9EQEQEm#`Os[m#`Os[QEs%ރ4B+YZkP#mۆќ7tTQExAV?Ҩ롮{_ G@ Q@Q@Q@UmBc>һnkm*"/.rݯ]3Mw-Fs\Gm[X0Ws8>@]t+TEW)AEPXG_I+@گ$K[QEx;,,xVptn$qjўyt->KpѴFOGk4gQ$\2݆9 O +'g[ jQE|BjWO\/އFtQEQEJg܏+jzε,[c m-HEv7?ZKۿ M6w7$6GYZ4VЪy2q4gXC7984Q@Q@Q@Q@9jї5X9jї5@r7FIHf ٙFcnGkVmlFJu-a>u<AwQExAV?Ҩ롮{_ G@ Q@Q@Q@q'K+o.MNs#rǴ}R+F]o\6+ WrA4c7 >wSG[a[ijj ;qW ;R υ(Gs[Ճ [w5@Q@G;msIY^ 1.i6U?JN攠5ԫnD_dߪZeV CơNMN(0 ( ( (1BO䵱X!'Zؠ( =+s5mdtS: nnkiuZ\C#ɍ̥A㹬Oӭ%eW\2oU '_w@2Q>g(La(M:g;P(9_#J"=Ԯ ( (.ˑ1@w;+kl'Hg֮! %\߄7bЅyT~U #PEPEPEPEP=Z?elV=Z?elP\.l5;+FZ W@mE+7Ʒ%݌/p­r&/8 r##i{u4QEW=/XZJ*Ut4QEQEQES.Mwc ; ¹Kcs![IAudTI/ڣ4%| Fl2 Agz+mgapq1PDQErQEQEc[c@QEs:5ϋje8Up;XpG 8M\G-ƶ k5Hɏ0i0*@#*gQEQEQEQE}W%>a ?QEr^>kmaŖBB7˽y\B@_ieZD'x9z/gej-IDCf; r>^-.5H#1@K(0!ȏ?5+/%0H??^k(Rv{}-~ܜƷˁy5[ofe:vrk_1![zQ=0xoOfig!Hw{jZ ^zs ( ( ( (1ri.kbri.kb "6Wbo&ECT} 2˚kư,'to5"wlH$PQE[P{%}>(Qʫsn3z\cak*h7Zo9@!r| t5֎Kq؁rfBLx;A?J((([[IgvUTRrք"u6U,UT }'׈oz+}n^kjy 1ɴrkN]?񸣰QE0((}#C ج}#C آ(42i] 1?t7C]14FhCk\Y_Y\i2Z7"YŁs(['4{21/?ӎ&آO pɖ&82*1UAjpge9,f;WWX> υ(Gs[QE[PKM>{4.@2JZ{ ҜgIxj97R8RFwq+VMF:~=_}QVsQ@Q@Q@Q@!'Zج}j-lPEP=ӡYgE̟g(Q02q8іDUU<ۃ$5 :{./>q υ(Gs[Ճ [w5@PNMb_bz|ȉd #[ufZ/PknYӈQEYQEQEQEQEc{UkbBO䵱@Q@Q@Q@/އFt|BjWO@G;f@⤬ i]!EbU8&G l{u qς  G`smuX0ƊāFciEPEPEPEPEP=Z?elV=Z?elPEPEP\cak*e  XTtEQERII=k>Y[3 hY@2VO~,.r6ҹڀcՈoúL:&i(1}}]h6vSR(qQ@Q@Q@c~Gc~GQ@Q@Q@> υ(Gs[Ճ [w5@V.OO37 Ҭ/\M7Rq#*dmB u{uOڽoOw!ȏ?5+R5Oi U4jR "MuR,V(S\׃ilVUķ=9!_X>ZhUG@1KEQEQEQEQEQEm#`Os[m#`Os[QEQEW=/XZJ*Ut4QEQEr~*Sxú*Zq˄?J+k?5@CaXB7> ޿p+Q@Q@Q@c~Gc~GQ@Q@Oa,҅ͻO +7!GI]\iqOvu`P1$$vHJQ#āH:Ϯ;Tklė &Y1$B*a0K^8jVK/6!VL%V9'$ Ç7(L.3Wb?[lv'dxi3t~i-Q-ZGMNs}lQEg0QEQEQEQEQE}W%>a ?QEQEQEsGz1 D{ѩ]=s4r|>։;m)c]O5enƈ:}aϊ+r7[*gA@Q@Q@Q@Q@Q@Q@9jї5X9jї5@Q@Q@s2U?:k-aQCEPU2smi_?Ҭ/~-*0[8kJPSؗ|7>>ϙ!κ:@U0KJ+QPEPEPEPXGoPnq%9QGcOE[KK(-]j=j]N=(?Wz:'Ҍ{Š(9Š((((( }j-lV>_I(((2D&Hwf7ڥʺQFTRF3}B v` i-Ņ0L`H# lAfh:]%Iġc\;vo#1h&5 6[AwCse\(*.jWS@-ǞʼnҮ߆zOρv|Jܠ(((((( {o?˚ج{o?˚ؠ(.Peªrx-WΫ26YX2 n&PQc 0AX^2U?:Ӵm(\]n&YU.`vW9J;-B=6/NbaQ!&<4QEW'w"D;mK'}qWT;UQOa\kNX\Fԓ޷U>_7}(QEQEQEQEc[c@QEQEQE`C>oV?3o ?e<\1 ,U.OZ^QJğԵicj^KAEUQ@Q@Q@Q@Q@!'Zج}j-lPEPEPEP1 D{ѩ]=sGz{}N<79[tQEQEQEQEQEQEm#`Os[m#`Os[QEQEW=/XZJ*Ut4QEr9tTl+}ʶqeV?tVvX[@b5rdM^l{5d2qqفAa]Ɵ_ĻQ\ ( ( ( ( ?1Iᭊ?1I ( ( +(N^=2FI'0# ARsqV|>ChJ/dܛnX2h?3o ?r߈3o7HKKi$hqir8fPkԮMyta)7er)(m?L #mqZuWMz]0|*($]i)T[]QTdQEQEQEQEQEc{UkbBO䵱@Q@Q@Q@/އFt71Ou)1}?ʹ_#Jk< }J?ZÖi}&QHl:((((((( {o?˚ج{o?˚ؠ((*Ut5xAV?ҨsUC.))o`2Y*rHZxKZbPRlR= Vb4j&^>;{Z񕧹'F._+f*'799>AETQEQEQEQEV>!O lV>!O lQEQEOPP f !͊XH FAa=i6Qo;(fb6Y}I$5f|-aG;|-_l٪?3o ?k涶u{1\jgl?c(((((((>a ?c{Ukb ( ( (9_#Jt3xf?Gz{ğ=KZ*D4EPEPEPEPEPEPEP=Z?elV=Z?elPEPEP\cak*e  XTt;(ε{goo`O|8~U<[[q3$.z*kv'EKIP.xiNuJ/EAEV# ( ( ( ( ( ?1Iᭊ?1I ( ( (0|A! Qj#~-!'̭S|-aG;9;%w>t`2ڏ*(((((((>a ?c{Ukb ( ( (9_#Jsxy{A>ӟQ"=ԫN"B'ՠ ( ( ( ( ( ( (1ri.kbri.kb ( ( e  XTu=/XZJ"WoXǓf~+}UQBj_D@V[_3R=1sW~QEb0(((((}#C ج}#C آ((Ђi.OA> t9e$+PG1|A! QDvKHOZ [w5v5W#VKgF(2 ( ( ( ( ( (1BO䵱X!'Zؠ(( C&z44 %S9a5{KkT)hNkOvq6M41A$3"QцC) JaayF g,I2hzׇmb#4X>O׏2!fO*WN[S"k[QEQEQEQEQEQEQEm#`Os[m#`Os[QEU-]oLiV+wm21gEfhkM39&LwNBGhٮdA;1ğG@i KSUqs0ĠsGYUER*@(((((+HLj??'+HLj??'6((#–eٸ7 ZY82sx<6ѾD$64ݸA;gk{ "&ʁQ,q¢ =gT:!ڭ,ⶏRinʘKVF`~71lU;Tu x{ +iu (!EPEPEPEPEPEP>_I+@گ$K[QEQEQE^ F[KfQ H \V5륖[Km ڏ0p#+Pj7:1LZ0Į 66 (8'o!gk<ַ;[BY'h.nBJ,v , -;03^]au tsW?[tA%yNg1+|{gy[9xزR  Az@-P>f:0vxs(3~^ڥF-AtޭnxO2ꥑ!呂)fc,!2W m>ٮnu<ĦLw?[l$1<0TE,{+Fomm$/7UCy{j_K4@H{$O(c~Tlg᝹yk[EwmͼHfA$nH#cYZ:[i n3iۀew3~^ߢ0??[Z`V%λrlkwx9/'bj>$ >-[ 8q+|{!gk<ַ;V|G^Gm41:q(I1pxxKү O8-c:@*nW ?wF\nr1m.ݠY33ǩ,պaZp̨FNwmvzbj(G𽎇$&K0E#/2I({(((( ]T{fb%?1ydq1ZtQ@wϸ"!ɂ)\Jͷ>gO^ k7mFTvwg+ OıFP (JlOMWra H.VY.^2`ː1q[9M,kY%Y?~b*c݅Q~3sh(}"-fѭxtx0)w>V̿z7[>8;r>_~OҴ;}"Ifti "8бD\ܜ~+N(((+3J$xeMѤ*$ BQp{rr}:( {CsI_dDsǥjQ@Ϳ?}]n2;=N1[6qi}"x(?AS@Q@AgM$%KK0'&PB~_M]~!G\evvCN1[PEPEPEPEPEPEPEPEPEPEP/+-WJtYT&EB˂%r )[s|DD%B cgO9=]׃]6&Jkƪ-iV$6v(((((((((u_>?~7nf|6}ckQ@lsEdB9FqTx7i⸞I"6hBοin[h*Oʭ7lϸ%lr>}`:$|hxq@Bl^@J|߷8RvkEqmG)$M$QIS# ydLB sI.hT/wov*y;ިE\^RKdJ$`+cIvX[A[\叩=IMiF|tpcۥ׭*B(((kj:U݅H][,̲$;eNO]#PH XfdE*1Yx$,n,&`?i23K^G|2i,ڞewB hX6G;x Z?!5=7P<4.0ȡ\g4O@Ifyۢ62xEQEQEQEQEQEQEQEQEQER;hTd8zw70Mup8!FG=@?;4KY,%܆7%|ӯIڭѷ`#Y."nqHeף)Ej[Ǵ_Y$[W)ZPQEQEQEQEQEh=?1l[POEPEPEPEPEPEPEPEPY:!ţ n}??@M2k/E2q\"(\` #7-b(G7ocuWhQ7%[Sk ƫ8OhpDE* S覢)ޟQE33F+n5X6_uᭊ((((+?5ktxhf:z( ( ( ( ( ( ( ( ( (nMg7u})A(U,8A ιJ}oxl"YڙAG`"$tbKצAުZvim #oWbJެǒ`qWh3ğ+j7j{EUCğ+j7j{ET%Q@Q@Q@Q@/u'M]emo٧T]W$ 1j3EsO,R(d2=#J"MJkXg($`.\8l WVfÐ[;8frһ6nU2Nq@uh=?յ}A,9aZI0Rq=ᛸ|k♣IH h(((((((v4ykLF#NyA6,\C[;FY@ݾOjkk [4I=a_kcƟs@կ4EQEQEQEQEQEQEQEQE5cFw`$gꚸ;xmYbPH'] IaDv'$rUE]ĜEO5zy8QEfxEm_ _hʨxEm_ _hʀ$((((_QOmH6ؑ7mF $& oW1\Ԟ]̈q!OD++v+{O-cE?趠((((((__(eC(SHzRj""V \篰I) ut5.d^G'o[#hA%=.?ᗒon$ėeu1\ԚEҲQE ( (1?mҿ[y#n^_ؠ(((sƓuZAq؋&oc+ ˗māp֡a_kcƟs@կ4EQEQEQEQEQEQEV'mL˨bp#`oz& HW5YDud*N~b0sRHQ@Q@Q@$[W)W/$[W)W/ ((((}YR=/^.+<{~T.6A {4S,0<(qlyS TvL,-([߀#~Yhmkb K1cO@ ҭuFʹ!+ =8l|k`6hy+H~wbMuh=?EQEQEQE^+ W\8TQv=Grj.[{w/ڮ$ir<}s!?z1HxyqoW[VJ'WWQEQQEQEQEQEQEy#n^_ج{tpQEQEQEAqykhb70fqbG E}Zi[Nl>i8_AT*En-(]9d<Gе5-N{fheb͖?Q9}VEq-$ma=>r Bo ^w4QEQEQEQEQEQEQEP/dӴ+@i5= *]64.3!R{gt7I_xO179((('ڿyMo?P'ڿyMo?IEPEPEPEPEP\Ƌ#ߊݳm]=s/~)vEtQEQEQECX{}6A 0zӯW*Վ}i?|zq}۱v6K\ж;xWlqUޥ&waEP (((((F+n5X6_uᭊ((((+?5ktxhf:z( ( ( ( ( ( (MvFB/ԍ cnh4C}wZB\Ĝ*w)ƐđF#E  uQEQEQEfxEm_ _hʨxEm_ _hʀ$((((|_m[t"KPw9m+SWӣ*9e)"tub;ArGgںz4_Sj袊((\Ioe$Hg [Ck"8Qc\Kky1O5P? +Njm?v 7Š(1 ( ( ( ( ( (1?mҿ[y#n^_ؠ(xm$.T89sVpn  c:OEQEW1Oj?5ktQEQEQEQEQEQE2Yc'WX@Yԓڱ9\C66q6#d (>EIod!tg*?(((('ڿyMo?P'ڿyMo?IEPEP~7/.,tϽso|JWSԴ3bz,H-9ijk)xUESe@S~F/{U i$E0'dRr8@?c;SEP ^-o;u|^K42bsW48Z<6^LqylXir Y%;?O'f?l&կn/5I僬+\Fwm 'cnCYine1Gl+rI圖={5tVnYH>S\MM@b",W1l[POEPEPUu 8M ,qܜ*$V6'Z72}yTKLRrecOq$I7qڭQE42raES$((((((ǼJ[ lV=Wz8kb (!7+e9HF||dktko_^>m;MVXu8"( HՏ5k<-&V{_2Ps #1( @AAxE?\錍4F<-"Y#z`;r*<9wj+z6D,m>&>cTe@`,wvxhf9yxy f@s*{qZtQ@Q@Q@Q@Q@$[W)W/$[W)W/ ((}aiIgmͬ !+`zS|7h >Y嗂BW tjQ@Q@Q@s/~)vEth=?EQEVfu1(OxL{7M^ycX-myI-U (!]D}yz/v_mQEF!EPEPEPEPEPEPEP=Wz8kb?mҿ[QEWye3B%q#*ct1+ ( ( EQEQEQEQEQEfxEm_ _hʨxEm_ _hʀ$(((()7|@<^"#V2`AO _ FaմF+*C"&$oݫ7,dUW|Z hy7Ȟr!8#}kvů^6"+o)'bO(cOagPA9{ڇ7.OQEF!EPEPEPEPEPEPEPEP=Wz8kb?mҿ[QEQEQEQX~&h[Bd牉xq|arUw_k \PH8,10uN9I4W1OjYG|"P}O+D:Iٶax9=̭(((({^ͻ˂2dw'S|~Fok-7s0v@ zçmHyzĄׄyݠ(((((( ȭהUȭהPQEQEQEQEQEh=?1l[POEPev? q7NIc_ZӬlZCq ֕LvsjK>QEQQEQEQEQEQEQEQEQEy#n^_ج{tpQEQEQEQExhfzڗ4TE tEFAEPEPEPEPEPEPEPEPEP=Wz8kb?mҿ[QEQEQEQEW1Oj?5ktQEQEQEWNsAU?Yin-5+;G4I,f\KiѲ#+.#x ( ( ( ( ( ( (3}@rZF&hEF!EPEPEPEPEPEPEPEPEP=Wz8kb?mҿ[QEQEQEQ\׉5t[kۻ ;fYeDHw+V23U4oXF<-w"Tb:2I4W1Ojq 5x&Vnaw-P(((sP#O2T#0w7*c09"Lq2kqCobOBO%8USG c[Xa7lX5j((((((((3ğ+j7j{EUCğ+j7j{ET%Q@Q@Q@Q@vwzEc̐ 5oov (XB8 4_Sj{O-U %sE,I5SFa5oњfhmGvkFKKQEFAEPEPEPEPEPEPEPEPEP=Wz8kb?mҿ[QEQEQEQEW1Oj?5ktQEQXw6L-~zSq"8rr8l#wRď泀e9a85ƨUm;NҬ= fbrǫ1zzպ(((((((('ڿyMo?P'ڿyMo?IEPEPEPEPEP\Ƌ#ߊݳm]=s/~)vEkj=Λi.0Tghs~h;[ZG0~uRl֦|7V ((((((((((ǼJ[ lV=Wz8kb ( ( ( ( ]JGʣOmSQ[>yvo(=O8!M^t4Ao63 GNdRI|멜s92z`0ڴ((((((((((3ğ+j7j{EUCğ+j7j{ET%Q@Q@Q@Q@*g4VԡVKq ǽN̑K`FV㼶e+"debBG[VZ~2\e=cٹ-OR@O3Wh6v.ݬ6[,T3U3^\A}iܻ]^9w(TVT@bpm@us4v v%P>TgpqW##K-ƝoQ3$R)Hyc܂$@ltl^O>y} 34A#IpL*''9SS]+}ZmG_K,S Pbf;FuS%ӼKk[v2.$Jj(EQEs>2+v^b͚1ycyBvҀ:j+&::b^uWo sSs62pr2;Vt֩xr]Mm5!So31t8b04W]h^ke׭DC;B?X^@Q@Q@Q@Q@Q@Ww7.[mzNf"!e1Oϸ0@@+}B/j6a= @UY8LZh8Ե cbygy N3*aU99j\wj>Yg"4 J10 z .]_FwVZSΏ!Yw1'VmPGJ(+ ]gg$ޥpHcݢI_Jӯ5{z}Its  >7'#RMkT<9{umw6)7y1PlZ+/5vktvb!FS,|}dq@()?ڤ~+-5 x~5ŭMKIye1eiڴҵ+jwk,hi&O,"K 98E)n՗M}5`ˉ%Y~nwypZuqu73%׆ȵ.'⸿iϫhQ6mSL;Ԃ%z#?osX\cff*]˂qiY˟5h ((((((((((((((((((((((((3ğ+j7j{EUCğ+j7j{ET%Q@Q@Q@Q@kޣ=h-[. [>AH\`ևm4(XP0h ĜA1 >ԮHLy|z浭ഷ% qUP:P[&RtiB@?.1eUG@~Ӥ>|Ns$X|# rs׌\ZHYoxen`;n?} |ӯ^י6g:+N5m!-.RGn:{p?#޺zQqvaEP (((((((((((((((((((((((3ğ+j7j{EUCğ+j7j{ET%Q@Q@Q@Q@Q@s/~)vEth=?EQEV]=Bk>N=JՕH'tM2Ysvkx;#U+ ^qqV7j6qn S}ꎯ >Y<q؎?^¸hܺ-b ]8<6z`fTz]QL((((((((((((((((((((((('ڿyMo?P'ڿyMo?IEPEPk]2KٖxF ddYjses e@~qX,5k5Go&h!&2 bD2v |G5i~[RwM[W%26a@ QEQEh=?1l[POEPEPMuQ@Zk[ged?~&ukS2p0{ j2w:G?/V.`0PZ8d`Kk6E1t`tzۉ $=`u+C4Y<1"!c=GZ.4f!EPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPg?Vo?VoJ( (9Cd󡱗ˑwM{@9#{8uMͻֺ œx/!{Ρe5r;C*Rq#k2n GC 4ֲfxK(`邛rrڊ(roM/ G y$ XuURI< ֶi۬YJJ]X+2}r凂-WHe1Gq695hc[qfYKb$'ԀiW1l[VnNR>sqvА}+?|Oyw˥Kg2݉q$H\ee;(9HoL]*I{kˉ.햮dVv,Aeqp2jthyRΩw;Ab+J+{O-cE?趠(((<( 3O9cޟC[1$@o-&`U-6- S C5}r{ |YWu?O7'{}zǝ{{t-⺁ yGKSyвHRxNG脕E#K¾*MBm˸T~-o^Š(((((((((((((((((((((3ğ+j7j{EUCğ+j7j{ET%Q@Q@>3 |+v ʬ@@`0Aۃ5 ڞ}E$8ٔ7F*|rFJt]YKRn0z7itav{|0wQ"uUy|2}h(*bOjZ+{O-cE?趠((((( זqЎeq%)9Cܼsl*2uڳ]%`NAoHW)΀NI“=}VEAékP =ETd6qBMBu׏½þ'i[[zzv:ӯoہ/N=))ƪsڨ;Þ-h+́8یc ~=y+s..( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (3>qF>͹<8=iA̗6]\4Lw:1l[POEPEPEPEPEPAEPE2`ه,/weYY$q+FHD*ÊȽxgYa'=MIG3fu-^ %} Ě 7? Z&gUz 7IlH8e=3 ZDQi?k YqL̾QJ]{÷]x$~l|(qPtqe]@qaޤ0ωфa=9*&;Xa9E :qqta88=I ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (3D5[\]3.IOi,xDwȃ U[RrEAxrL֭VM>&K6gq. q$(((cE?趮Ggڀ:z( ( ( ( ( ( lU( -L9oB*J|uVeLco%ۣ^tpl3r I,g==jnݹۑOA4Џ.7Vhde!];;꾉K:G:}c|׌W[u:Oz|K #%>E%3ҵ]Z?6قn#z^/k]i10يG0qk|`/12/#vǧCEȝGeE2)c1$2$?1 ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (3LgqHWUk ]B1 ( >r: v6gǙh^$ػm]`{ݺs]+RgR1?jCN1[~__І FPmW1l[WO\Ƌ#ߊݳm@=Q@Q@Q@Q@Q@Q@Q@Q@0yQ@+$d S*\je,88CVWd/ zrь!Y0MfqLcԃ*Ͷ7a2cq ,kVvjyi)ݺ9̒zԕ&ǘk *@+ awz$7d Bݻ ?W#kګ|+kxeKi|߃JFNM%'$v>:~emᗧoǨ⼿RƓtrdi ! 'lzU( .U{`nwq)ҌTWx!iFRp1ýu:w,5$S߇JfEP@QEQEQEQEQEQEQEQEQEQEQEQEO@5~=p*O@5~=p*((((qN;ڦKulBC(2HGW6hp<IOcnFP[rI;o믮cE?趠((((((((((IȸaJqp9hI5f> ̙Fn7צ{{c:<0’Ϩ3遘68 >Vg(.2s$<%`7m2Xkc53ʶobf-ߠ"Lz~Ҩv$C? }j*}y-Ta{2Uocx$7'N?Zxe"ND3O^^]x_P҆[d?DӨSxlGS׊ EI{sS]k³?ʟ1{⋑* lz]x3uf`rClYLHHꓐ~|3' .QA!EPEPEPEPEPEPEPEPEPg?Vo?VoJ( ( ( ( ( 4_Sj{O-((((((((((((DyTn4ĐQ0Ѣ q )=RA[q1#>*GE*hGY5FqEXWW\{VKiN E͸+cw==(ݯ +uFAtcQ5r-AgT95#->ҮZ#mCEcEsyKnW%{-MIV\jJ;3ʧ54Fm6Cv\³e,hEr1FQ׏P?{=G=(xcAY0ϯ4h˩6m؄O En%vUy?+~N]]υtbۋD0r ƿ 1Mĸ[FsӖвHt<9۷Z܆Au J c^+. i} }aY2&o+#-8e!l{E䶾,;]¡w q !#ċcmRAϷaEt&nEw`;7]fĊWg?Zfn] j*8n BM F}8($((((('ڿyMo?P'ڿyMo?IEPEPEPEPEP\Ƌ#ߊݳm]=s/~)vEtQEQEQEQEQEQEQEQEQEQEQEQEQEQE ih^'TÀH?QZTTnk +`>-,UTԃ[t j}[61MJe`)@9P{{fMb"Ae"0c_b k/ztrl;؜QR0ȑ-pQ6 :t"\˓ÂNq?Q5ȤtY2R2soQ'wAai~nwӐ(xgJ~ct+́lЬ㎕oe\Lg"me,7Usk)lqoՄU;Y]>qY ,.UY {^k/ܐ02?p~6Ed^|7n?6saF(/I# ӼD#8om.\Pdr8)Τ1a39"?|ITA?J{H:+-})$͏'סal3HvLq{h+̢l̳M)?޷ = *|NV|OA4ODz i=5 m<REa%ȭהUȭהPI%Q@Q@Q@Q@*g4VԡVKq ǽN̑K`FV㼶e+"debBG[VZ~2\e=cٹ-OR@TLtjҢgmB_uس:zI6s^ךҢI7@gk'^N>+k6Q\JyghQEw_wykwI8= |9q*1Qf"mf HJ(\Ozk[Vh\H6GqZy/٢uEXmfxEm_ _hʨxEm_ _hʘ((((#u2t%.$oZYر gAFCaJ3:BN *(}?F]g?[y/t̚: P?XOr8}cYFF|@GW_G!_E|_MoQX?xO}4?_GW_G!_E|_MoQX?xO}4?_Zx7]R&ގcH-ʡ I$ g_B<'Bޢ / h#+/ + Я/&B<'Bޢ / h#+/ + Я/&^KidގT cھDGdB<'B? / hz#+/ Я/&7B<'B? / hz#+/ Я/&73 l/wa}xD>@V!_E|_MoQX?xO}4?_GW_G!_E|_MoQX?xO}4?_GW_Y^o4Kb,PI+ɠΊ#+/ Я/&7B<'B? / hz#+/ Я/&7B<'B?|/ޏce`^ vtV!_E|_MxO}4E`?_GW_@V!_E|_MxO}4E`?_GW_@WbLH<9E'-F䱉N 2$~5?@xEm_ _hʲτ6AQ 0QEQEQEQEQEQEW9S-ΧBO=hD:˒8 qYkj tyjn|sK!N Os@ .]_FwVZSΏ!Yw1'VmPEPEPEkͩ (vVɧMuv@ĩ ;z WEq7ZI5-B%~3FҀ]y Gدl+n7 s|d1DpVW9*UOQEQEQEQ\׈P^xu[ ȸq3͜m/LڝS-ΧBO=hD:˒8 q@a3FOrU'nEPEPE\]5Pv酠]N~cgOtW-^W!V{g-PnHCԴ :m-/9>PFI$rhQ@Q@Q@+cDlKړ4EBdc9[qV]|M{un͜0QLH于6lNh(t ( ( :d c`v23QܶZjZ%Ԭ]\\< Pل kEpomΫ|aԭ bEH,Qm`e'9EwQEQEQEQI4{O(lI6 #<{+Z3j B[yB0a,G(p7 8ܲjڍͻZ$v@Jy*''9zQ@Q@Q@Q@Q@Q@Q@=*WHocfXIG+FnWBN pHQb Qh> loo, gXJҴ[ 9R'S+v9,@ghQEQEQEh:n"| !2$mlnRPTeO" Zoͱh(*ز @F2V4*H6QFs#wcՙcxr(((scmy-ǽf;Y3_sT|=obY}q"2H221|NzQ@YY[iPB»QOEQEQEUy,m xso?*Rv/_OX1/<%_kyܨ;w+PV0mpAj(((( NޭՒFpeXm!NKӯ4<%LmL57\Hwʲ|߼Zۢ ( ( (4)qJ E(2r+6ZAaSV21 ! p8+;[P7"7~hicݰ|glEQEQE坶e5+5RHpzǵgo<0?7GrFbt0H -;ZjAjV˶LQY] ڥR5EQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEW4<[hii;QA,p98"'&~mr2;u|k`ڟ(4|[waفr1j:OJ4 -Z8ૹ].F:@Ey,~l[cX3h.Iăn#WK+ -.59R&aX].K#6H*c<h(((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((mets/vignettes/recurrent-events.org0000644000176200001440000006626213623061405017272 0ustar liggesusers#+TITLE: Recurrent Events #+AUTHOR: Klaus Holst & Thomas Scheike #+PROPERTY: header-args:R :session *R* :cache no :width 550 :height 450 #+PROPERTY: header-args :eval never-export :exports both :results output :tangle yes :comments yes #+PROPERTY: header-args:R+ :colnames yes :rownames no :hlines yes #+INCLUDE: header.org #+OPTIONS: toc:nil timestamp:nil #+BEGIN_SRC emacs-lisp :results silent :exports results :eval (setq org-latex-listings t) (setq org-latex-compiler-file-string "%%\\VignetteIndexEntry{Recurrent Events}\n%%\\VignetteEngine{R.rsp::tex}\n%%\\VignetteKeyword{R}\n%%\\VignetteKeyword{package}\n%%\\VignetteKeyword{vignette}\n%%\\VignetteKeyword{LaTeX}\n") #+END_SRC ----- # +LaTeX: \clearpage ** Overview For recurrent events data it is often of interest to compute basis descriptive quantities as a first go at getting some basic understanding of the phenonmenon studied. We here demonstrate how one can compute - the marginal mean - the variance - the probability of exceeding k events In addition several tools can be used for simulating recurrent events and bivariate recurrent events data, in the case with a possible terminating event. For bivariate recurrent events we also compute summary measures that describe their dependence such as - the covariance - directional dependence - the bivariate probability of exceeding $(k_1,k_2)$ events ** Simulation of recurrents events We start by simulating some recurrent events data with two type of events with cumulative hazards - $\Lambda_1(t)$ (rate among survivors) - $\Lambda_2(t)$ (rate among survivors) - $\Lambda_D(t)$ where we consider types 1 and 2 and with a rate of the terminal event given by $\Lambda_D(t)$. We let the events be independent, but could also specify a random effects structure to generate dependence. When simulating data we can impose various random-effects structures to generate dependence - We can draw normally distributed random effects $Z_1,Z_2,Z_d$ were the variance (var.z) and correlation can be specified (cor.mat) (dependence=2). Then the intensities are - $\exp(Z_1) \lambda_1(t)$ - $\exp(Z_2) \lambda_2(t)$ - $\exp(Z_3) \lambda_D(t)$ - We can one gamma distributed random effects $Z$. Then the intensities are (dependence=1) - $Z \lambda_1(t)$ - $Z \lambda_2(t)$ - $Z \lambda_D(t)$ - We can draw gamma distributed random effects $Z_1,Z_2,Z_d$ were the sum-structure can be speicifed via a matrix cor.mat. Then we compute $\tilde Z_j = \sum_k Z_k^{cor.mat(j,k)}$ for $j=1,2,3$ (dependence=3) Then the intensities are - $\tilde Z_1 \lambda_1(t)$ - $\tilde Z_2 \lambda_2(t)$ - $\tilde Z_3 \lambda_D(t)$ - The intensities can be independent (dependence=0) We return to how to run the different set-ups later and start by simulating independent processes. ** Utility functions We here mention two utility functions - tie.breaker for breaking ties among jump-times which is expected in the functions below. - count.history that counts the number of jumps previous for each subject that is $N_1(t-)$ and $N_2(t-)$. ** Marginal Mean We start by estimating the marginal mean $E(N_1(t \wedge D))$ where $D$ is the timing of the terminal event. This is based on a rate model for - the type 1 events $ \sim E(dN_1(t) | D > t)$ - the terminal event $ \sim E(dN_d(t) | D > t)$ and is defined as $\mu_1(t)=E(N_1^*(t))$ \begin{align} \int_0^t S(u) d R_1(u) \end{align} where $S(t)=P(D \geq t)$ and $dR_1(t) = E(dN_1^*(t) | D > t)$ and can therefore be estimated by a - Kaplan-Meier estimator, $\hat S(u)$ - Nelson-Aalen estimator for $R_1(t)$ \begin{align} \hat R_1(t) & = \sum_i \int_0^t \frac{1}{Y_\bullet (s)} dN_{1i}(s) \end{align} where $Y_{\bullet}(t)= \sum_i Y_i(t)$ such that the estimator is \begin{align} \hat \mu_1(t) & = \int_0^t \hat S(u) d\hat R_1(u). \end{align} Cook & Lawless (1997), and developed further in Gosh & Lin (2000). The variance can be estimated based on the asymptotic expansion of $\hat \mu_1(t) - \mu_1(t)$ \begin{align*} & \sum_i \int_0^t \frac{S(s)}{\pi(s)} dM_{i1} - \mu_1(t) \int_0^t \frac{1}{\pi(s)} dM_i^d + \int_0^t \frac{\mu_1(s) }{\pi(s)} dM_i^d, \end{align*} with mean-zero processes - $M_i^d(t) = N_i^D(t)- \int_0^t Y_i(s) d \Lambda^D(s)$, - $M_{i1}(t) = N_{i1}(t) - \int_0^t Y_{i}(s) dR_1(s)$. as in Gosh & Lin (2000) *** Generating data We start by generating some data to illustrate the computation of the marginal mean #+BEGIN_SRC R :exports code :ravel echo=FALSE library(mets) set.seed(1000) # to control output in simulatins for p-values below. #+END_SRC #+RESULTS: #+begin_example Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.6.3 mets version 1.2.5 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined #+end_example #+BEGIN_SRC R :results output :exports both :session *R* :cache no data(base1cumhaz) data(base4cumhaz) data(drcumhaz) ddr <- drcumhaz base1 <- base1cumhaz base4 <- base4cumhaz rr <- simRecurrent(1000,base1,death.cumhaz=ddr) rr$x <- rnorm(nrow(rr)) rr$strata <- floor((rr$id-0.01)/500) dlist(rr,.~id| id %in% c(1,7,9)) #+END_SRC #+RESULTS: #+begin_example id: 1 entry time status rr dtime fdeath death start stop x strata 1 0 133.1 0 1 133.1 1 1 0 133.1 1.185 0 ------------------------------------------------------------ id: 7 entry time status rr dtime fdeath death start stop x strata 7 0.0 813.3 1 1 1729 1 0 0.0 813.3 1.5495 0 1004 813.3 1288.4 1 1 1729 1 0 813.3 1288.4 1.0535 0 1658 1288.4 1315.4 1 1 1729 1 0 1288.4 1315.4 1.5330 0 2150 1315.4 1449.4 1 1 1729 1 0 1315.4 1449.4 0.8944 0 2539 1449.4 1726.1 1 1 1729 1 0 1449.4 1726.1 -0.1931 0 2851 1726.1 1729.4 0 1 1729 1 1 1726.1 1729.4 0.4081 0 ------------------------------------------------------------ id: 9 entry time status rr dtime fdeath death start stop x strata 9 0.0 433.5 1 1 5110 0 0 0.0 433.5 -0.4660 0 1006 433.5 2451.1 1 1 5110 0 0 433.5 2451.1 1.0647 0 1659 2451.1 3629.7 1 1 5110 0 0 2451.1 3629.7 -0.2506 0 2151 3629.7 3644.7 1 1 5110 0 0 3629.7 3644.7 -0.6748 0 2540 3644.7 3695.8 1 1 5110 0 0 3644.7 3695.8 0.6510 0 2852 3695.8 3890.7 1 1 5110 0 0 3695.8 3890.7 -0.2033 0 3112 3890.7 5110.0 0 1 5110 0 0 3890.7 5110.0 -1.6981 0 #+end_example The status variable keeps track of the recurrent evnts and their type, and death the timing of death. To compute the marginal mean we simly estimate the two rates functions of the number of events of interest and death by using the phreg function (to start without covariates). Then the estimates are combined with standard error computation in the recurrentMarginal function #+NAME: rec1 #+BEGIN_SRC R :exports both :results output graphics :file rec1.jpg :ravel fig=TRUE,include=FALSE # to fit non-parametric models with just a baseline xr <- phreg(Surv(entry,time,status)~cluster(id),data=rr) dr <- phreg(Surv(entry,time,death)~cluster(id),data=rr) par(mfrow=c(1,3)) bplot(dr,se=TRUE) title(main="death") bplot(xr,se=TRUE) # robust standard errors rxr <- robust.phreg(xr,fixbeta=1) bplot(rxr,se=TRUE,robust=TRUE,add=TRUE,col=4) # marginal mean of expected number of recurrent events out <- recurrentMarginal(xr,dr) bplot(out,se=TRUE,ylab="marginal mean",col=2) #+END_SRC #+BEGIN_marginfigure # +CAPTION: Marginal mean for number of type 1 events, rate for death (panel (a)), rate for type 1 among survivors (panel (b)), and marginal mean (panel (c)) label:fig:rec1 #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: rec1 [[file:rec1.jpg]] #+LATEX: \captionof{figure}{Marginal mean for number of type 1 events, rate for death (panel (a)), rate for type 1 among survivors (panel (b)), and marginal mean (panel (c)).} label:fig:rec #+END_marginfigure We can do the same with strata #+NAME: rec2 #+BEGIN_SRC R :exports both :results output graphics :file rec2.jpg :ravel fig=TRUE,include=FALSE xr <- phreg(Surv(entry,time,status)~strata(strata)+cluster(id),data=rr) dr <- phreg(Surv(entry,time,death)~strata(strata)+cluster(id),data=rr) par(mfrow=c(1,3)) bplot(dr,se=TRUE) title(main="death") bplot(xr,se=TRUE) rxr <- robust.phreg(xr,fixbeta=1) bplot(rxr,se=TRUE,robust=TRUE,add=TRUE,col=1:2) out <- recurrentMarginal(xr,dr) bplot(out,se=TRUE,ylab="marginal mean",col=1:2) #+END_SRC #+BEGIN_marginfigure # +CAPTION: Recurrent events label:fig:rec2 #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: rec2 [[file:rec2.jpg]] #+LATEX: \captionof{figure}{Recurrent events} label:fig:rec2 #+END_marginfigure Furhter, if we adjust for covariates for the two rates we can still do predictions of marginal mean, what can be plotted is the baseline marginal mean, that is for the covariates equal to 0 for both models. Predictions for specific covariates can also be obtained with the recmarg (recurren marginal mean used solely for predictions without standard error computation). #+NAME: rec3 #+BEGIN_SRC R :exports both :results output graphics :file rec3.jpg :ravel fig=TRUE,include=FALSE # cox case xr <- phreg(Surv(entry,time,status)~x+cluster(id),data=rr) dr <- phreg(Surv(entry,time,death)~x+cluster(id),data=rr) par(mfrow=c(1,3)) bplot(dr,se=TRUE) title(main="death") bplot(xr,se=TRUE) rxr <- robust.phreg(xr) bplot(rxr,se=TRUE,robust=TRUE,add=TRUE,col=1:2) out <- recurrentMarginal(xr,dr) bplot(out,se=TRUE,ylab="marginal mean",col=1:2) # predictions witout se's outX <- recmarg(xr,dr,Xr=1,Xd=1) bplot(outX,add=TRUE,col=3) #+END_SRC #+BEGIN_marginfigure # +CAPTION: Recurrent events label:fig:rec3 #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: rec3 [[file:rec3.jpg]] #+LATEX: \captionof{figure}{Recurrent events with cox models for rates.} label:fig:rec3 #+END_marginfigure ** Other marginal properties The mean is a useful summary measure but it is very easy and useful to look at other simple summary measures such as the probability of exceeding $k$ events - $P(N_1^*(t) \ge k)$ - cumulative incidence of $T_{k} = \inf \{ t: N_1^*(t)=k \}$ with competing $D$. that is thus equivalent to a certain cumulative incidence of $T_k$ occurring before $D$. We denote this cumulative incidence as $\hat F_k(t)$. We note also that $N_1^*(t)^2$ can be written as \begin{align*} \sum_{k=0}^K \int_0^t I(D > s) I(N_1^*(s-)=k) f(k) dN_1^*(s) \end{align*} with $f(k)=(k+1)^2 - k^2$, such that its mean can be written as \begin{align*} \sum_{k=0}^K \int_0^t S(s) f(k) P(N_1^*(s-)= k | D \geq s) E( dN_1^*(s) | N_1^*(s-)=k, D> s) \end{align*} and estimated by \begin{align*} \tilde \mu_{1,2}(t) & = \sum_{k=0}^K \int_0^t \hat S(s) f(k) \frac{Y_{1\bullet}^k(s)}{Y_\bullet (s)} \frac{1}{Y_{1\bullet}^k(s)} d N_{1\bullet}^k(s)= \sum_{i=1}^n \int_0^t \hat S(s) f(N_{i1}(s-)) \frac{1}{Y_\bullet (s)} d N_{i1}(s), \end{align*} That is very similar to the "product-limit" estimator for $E( (N_1^*(t))^2 )$ \begin{align} \hat \mu_{1,2}(t) & = \sum_{k=0}^K k^2 ( \hat F_{k}(t) - \hat F_{k+1}(t) ). \end{align} We use the esimator of the probabilty of exceeding "k" events based on the fact that $I(N_1^*(t) \geq k)$ is equivalent to \begin{align*} \int_0^t I(D > s) I(N_1^*(s-)=k-1) dN_1^*(s), \end{align*} suggesting that its mean can be computed as \begin{align*} \int_0^t S(s) P(N_1^*(s-)= k-1 | D \geq s) E( dN_1^*(s) | N_1^*(s-)=k-1, D> s) \end{align*} and estimated by \begin{align*} \tilde F_k(t) = \int_0^t \hat S(s) \frac{Y_{1\bullet}^{k-1}(s)}{Y_\bullet (s)} \frac{1}{Y_{1\bullet}^{k-1}(s)} d N_{1\bullet}^{k-1}(s). \end{align*} To compute these estimators we need to set up the data by computing the number of previous events of type "1" by the count.history function #+NAME: rec4 #+BEGIN_SRC R :exports both :results output graphics :file rec4.jpg :ravel fig=TRUE,include=FALSE ###cor.mat <- corM <- rbind(c(1.0, 0.6, 0.9), c(0.6, 1.0, 0.5), c(0.9, 0.5, 1.0)) ###rr <- simRecurrent(1000,base1,cumhaz2=base4,death.cumhaz=ddr) rr <- count.history(rr) dtable(rr,~death+status) oo <- prob.exceedRecurrent(rr,1) bplot(oo) #+END_SRC #+BEGIN_marginfigure # +CAPTION: Recurrent events label:fig:rec4 #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: rec4 [[file:rec4.jpg]] #+LATEX: \captionof{figure}{Recurrent events: probability of exceeding k events} label:fig:rec4 #+END_marginfigure We can also look at the mean and variance based on the estimators just described #+NAME: rec4MV #+BEGIN_SRC R :exports both :results output graphics :file rec4MV.jpg :ravel fig=TRUE,include=FALSE par(mfrow=c(1,2)) with(oo,plot(time,mu,col=2,type="l")) # with(oo,plot(time,varN,type="l")) #+END_SRC #+BEGIN_marginfigure # +CAPTION: Recurrent events, mean and variance label:fig:rec4MV #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: rec4MV [[file:rec4MV.jpg]] #+LATEX: \captionof{figure}{Recurrent events: mean and variance} label:fig:rec4MV #+END_marginfigure ** Multiple events We now generate recurrent events with two types of events. We start by generating data as before where all events are independent. #+BEGIN_SRC R :results output :exports both :session *R* :cache no rr <- simRecurrent(1000,base1,cumhaz2=base4,death.cumhaz=ddr) rr <- count.history(rr) dtable(rr,~death+status) #+END_SRC #+RESULTS: : : status 0 1 2 : death : 0 124 3052 405 : 1 876 0 0 Based on this we can estimate also the joint distribution function, that is the probability that $(N_1(t) \geq k_1, N_2(t) \geq k_2)$ #+NAME: rec4Bi #+BEGIN_SRC R :exports both :results output graphics :file rec4Bi.jpg :ravel fig=TRUE,include=FALSE # Bivariate probability of exceeding oo <- prob.exceedBiRecurrent(rr,1,2,exceed1=c(1,5,10),exceed2=c(1,2,3)) with(oo, matplot(time,pe1e2,type="s")) nc <- ncol(oo$pe1e2) legend("topleft",legend=colnames(oo$pe1e2),lty=1:nc,col=1:nc) #+END_SRC #+BEGIN_marginfigure # +CAPTION: Recurrent events label:fig:rec4Bi #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: rec4Bi [[file:rec4Bi.jpg]] #+LATEX: \captionof{figure}{Recurrent events: probability of exceeding $(k_1,k_2)$ events} label:fig:rec4Bi #+END_marginfigure ** Dependence between events: Covariance The dependence can also be summarised in other ways. For example by computing the covariance and comparing it to the covariance under the assumption of independence among survivors. Covariance among two types of events \begin{align} \rho(t) & = \frac{ E(N_1^*(t) N_2^*(t) ) - \mu_1(t) \mu_2(t) }{ \mbox{sd}(N_1^*(t)) \mbox{sd}(N_2^*(t)) } \end{align} where $E(N_1^*(t) N_2^*(t))$ can be computed as \begin{align*} E(N_1^*(t) N_2^*(t)) & = E( \int_0^t N_1^*(s-) dN_2^*(s) ) + E( \int_0^t N_2^*(s-) dN_1^*(s) ) \end{align*} Recall that we might have a terminal event present such that we only see $N_1^*(t \wedge D)$ and $N_2^*(t \wedge D)$. To compute the covariance we thus compute \begin{align*} E(\int_0^t N_1^*(s-) dN_2^*(s) ) & = \sum_k E( \int_0^t k I(N_1^*(s-)=k) I(D \geq s) dN_2^*(s) ) \end{align*} \begin{align*} = \sum_k \int_0^t S(s) k P(N_1^*(s-)= k | D \geq s) E( dN_2^*(s) | N_1^*(s-)=k, D \geq s) \end{align*} estimated by \begin{align*} & \sum_k \int_0^t \hat S(s) k \frac{Y_1^k(s)}{Y_\bullet (s)} \frac{1}{Y_1^k(s)} d \tilde N_{2,k}(s), \end{align*} - $Y_j^k(t) = \sum Y_i(t) I( N_{ji}^*(s-)=k)$ for $j=1,2$, - $\tilde N_{j,k}(t) = \sum_i \int_0^t I(N_{ij^o}(s-)=k) dN_{ij}(s)$ - $j^o$ gives the other type so that $1^o=2$ and $2^o=1$. We thus estimate $ E(N_1^*(t) N_2^*(t))$ by \begin{align*} \sum_k \int_0^t \hat S(s) k \frac{Y_1^k(s)}{Y_\bullet (s)} \frac{1}{Y_1^k(s)} d \tilde N_{2,k}(s) + \sum_k \int_0^t \hat S(s) k \frac{Y_2^k(s)}{Y_\bullet (s)} \frac{1}{Y_2^k(s)} d \tilde N_{1,k}(s). \end{align*} - Without terminating event covariance is a useful nonparametric measure. - With terminating event dependence can be generated terminating event. - In reality what is of interest would be independence among survivors that is if - $N_1$ is not predicitive for $N_2$ \begin{align} E( dN_2^*(t) | N_1^*(t-)=k, D \geq t) = E( dN_2^*(t) | D \geq t) \end{align} - $N_2$ is not predicitive for $N_1$ \begin{align} E( dN_1^*(t) | N_2^*(t-)=k, D \geq t) = E( dN_1^*(t) | D \geq t) \end{align} If the two processes are independent among survivors then \begin{align} E( dN_2^*(t) | N_1^*(t-)=k, D \geq t) = E( dN_2^*(t) | D \geq t) \end{align} so \begin{align*} E( \int_0^t N_1^*(s-) dN_2^*(s) ) & = \int_0^t S(s) E(N_1^*(s-) | D \geq s) E( dN_2^*(s) | D \geq s) \end{align*} and \begin{align*} \int_0^t \hat S(s) \{ \sum_k k \frac{Y_1^k(s)}{Y_\bullet (s)} \} \frac{1}{Y_\bullet (s)} dN_{2\bullet}(s), \end{align*} where $N_{j\bullet}(t) = \sum_i \int_0^t dN_{j,i}(s)$. Under the independence $E(N_1^*(t) N_2^*(t))$ is estimated \begin{align*} \int_0^t \hat S(s) \{ \sum_k k \frac{Y_1^k(s)}{Y_\bullet (s)} \} \frac{1}{Y_\bullet (s)} dN_{2\bullet}(s) + \int_0^t \hat S(s) \{ \sum_k k \frac{Y_2^k(s)}{Y_\bullet (s)} \} \frac{1}{Y_\bullet (s)} dN_{1\bullet}(s). \end{align*} Both estimators, $\hat E(N_1^*(t) N_2^*(t))$ and $\hat E_I(N_1^*(t) N_2^*(t))$, as well as $\hat E(N_1^*(t))$ and $\hat E(N_2^*(t))$, have asymptotic expansions that can be written as a sum of iid processes, similarly to the arguments of Ghosh & Lin 2000, $\sum_i \Psi_i(t)$. We here, however, use a simple block bootstrap to get standard errors. We can thus estimate the standard errors and of the estimators and their difference $\hat E(N_1^*(t) N_2^*(t))- \hat E_I(N_1^*(t) N_2^*(t))$. Note that we have terms for whether - $N_1$ is predicitive for $N_2$ - N1 -> N2 : $E( \int_0^t N_1^*(s-) dN_2^*(s) )$ - this is equivalent to a weighted log-rank test - $N_2$ is predicitive for $N_1$ - N2 -> N1 : $E( \int_0^t N_2^*(s-) dN_1^*(s) )$ - this is equivalent to a weighted log-rank test #+NAME: rec5 #+BEGIN_SRC R :exports both :results output graphics :file rec5.jpg :ravel fig=TRUE,include=FALSE rr$strata <- 1 dtable(rr,~death+status) covrp <- covarianceRecurrent(rr,1,2,status="status",death="death", start="entry",stop="time",id="id",names.count="Count") par(mfrow=c(1,3)) plot(covrp) # with strata, each strata in matrix column, provides basis for fast Bootstrap covrpS <- covarianceRecurrentS(rr,1,2,status="status",death="death", start="entry",stop="time",strata="strata",id="id",names.count="Count") #+END_SRC #+BEGIN_marginfigure # +CAPTION: Recurrent events label:fig:rec5 #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: rec5 [[file:rec5.jpg]] #+LATEX: \captionof{figure}{Covariance between events} label:fig:rec5 #+END_marginfigure ** Bootstrap standard errors for terms First fitting the model again to get our estimates of interst, and then computing them for some specific time-points #+BEGIN_SRC R :results output :exports both :session *R* :cache no times <- seq(500,5000,500) coo1 <- covarianceRecurrent(rr,1,2,status="status",start="entry",stop="time") # mug <- Cpred(cbind(coo1$time,coo1$EN1N2),times)[,2] mui <- Cpred(cbind(coo1$time,coo1$EIN1N2),times)[,2] mu2.1 <- Cpred(cbind(coo1$time,coo1$mu2.1),times)[,2] mu2.i <- Cpred(cbind(coo1$time,coo1$mu2.i),times)[,2] mu1.2 <- Cpred(cbind(coo1$time,coo1$mu1.2),times)[,2] mu1.i <- Cpred(cbind(coo1$time,coo1$mu1.i),times)[,2] cbind(times,mu2.1,mu2.i) cbind(times,mu1.2,mu1.i) #+END_SRC #+RESULTS: #+begin_example times mu2.1 mu2.i [1,] 500 0.03100697 0.03667899 [2,] 1000 0.12005101 0.11639334 [3,] 1500 0.27816419 0.25970625 [4,] 2000 0.39427551 0.36855802 [5,] 2500 0.62555191 0.59880569 [6,] 3000 0.87389364 0.85299235 [7,] 3500 1.05720576 1.04841424 [8,] 4000 1.17544378 1.17621886 [9,] 4500 1.24059951 1.24523661 [10,] 5000 1.41706642 1.44651653 times mu1.2 mu1.i [1,] 500 0.03600846 0.03183231 [2,] 1000 0.09403891 0.09621167 [3,] 1500 0.21312456 0.20444188 [4,] 2000 0.33724372 0.32986794 [5,] 2500 0.48942767 0.46709378 [6,] 3000 0.65365335 0.62713754 [7,] 3500 0.83195803 0.80087980 [8,] 4000 1.01132903 0.98848325 [9,] 4500 1.12459563 1.11010693 [10,] 5000 1.21985056 1.20821774 #+end_example To get the bootstrap standard errors there is a quick memory demanding function (with S for speed and strata) BootcovariancerecurrenceS and slow function that goes through the loops in R Bootcovariancerecurrence. #+BEGIN_SRC R :results output :exports both :session *R* :cache no bt1 <- BootcovariancerecurrenceS(rr,1,2,status="status",start="entry",stop="time",K=100,times=times) #bt1 <- Bootcovariancerecurrence(rr,1,2,status="status",start="entry",stop="time",K=K,times=times) output <- list(bt1=bt1,mug=mug,mui=mui, bse.mug=bt1$se.mug,bse.mui=bt1$se.mui, dmugi=mug-mui, bse.dmugi=apply(bt1$EN1N2-bt1$EIN1N2,1,sd), mu2.1 = mu2.1 , mu2.i = mu2.i , dmu2.i=mu2.1-mu2.i, mu1.2 = mu1.2 , mu1.i = mu1.i , dmu1.i=mu1.2-mu1.i, bse.mu2.1=apply(bt1$mu2.i,1,sd), bse.mu2.1=apply(bt1$mu2.1,1,sd), bse.dmu2.i=apply(bt1$mu2.1-bt1$mu2.i,1,sd), bse.mu1.2=apply(bt1$mu1.2,1,sd), bse.mu1.i=apply(bt1$mu1.i,1,sd), bse.dmu1.i=apply(bt1$mu1.2-bt1$mu1.i,1,sd) ) #+END_SRC #+RESULTS: We then look at the test for overall dependence in the different time-points. We here have no suggestion of dependence. #+BEGIN_SRC R :results output :exports both :session *R* :cache no tt <- output$dmugi/output$bse.dmugi cbind(times,2*(1-pnorm(abs(tt)))) #+END_SRC #+RESULTS: #+begin_example times [1,] 500 0.8652172 [2,] 1000 0.9250943 [3,] 1500 0.1774924 [4,] 2000 0.2034490 [5,] 2500 0.1802523 [6,] 3000 0.2713296 [7,] 3500 0.4340546 [8,] 4000 0.6915646 [9,] 4500 0.8700063 [10,] 5000 0.7841112 #+end_example We can also take out the specific components for whether $N_1$ is predictive for $N_2$ and vice versa. We here have no suggestion of dependence. #+BEGIN_SRC R :results output :exports both :session *R* :cache no t21 <- output$dmu1.i/output$bse.dmu1.i t12 <- output$dmu2.i/output$bse.dmu2.i cbind(times,2*(1-pnorm(abs(t21))),2*(1-pnorm(abs(t12)))) #+END_SRC #+RESULTS: #+begin_example times [1,] 500 0.5394804 0.3045120 [2,] 1000 0.8365802 0.7652914 [3,] 1500 0.5888113 0.2033822 [4,] 2000 0.7192628 0.1715893 [5,] 2500 0.3472740 0.3594882 [6,] 3000 0.3640448 0.5241137 [7,] 3500 0.3862490 0.8133454 [8,] 4000 0.5228586 0.9858764 [9,] 4500 0.7008942 0.9175257 [10,] 5000 0.7704913 0.5327502 #+end_example We finally plot the boostrap samples #+NAME: rec6 #+BEGIN_SRC R :exports both :results output graphics :file rec6.jpg :ravel fig=TRUE,include=FALSE par(mfrow=c(1,2)) matplot(bt1$time,bt1$EN1N2,type="l",lwd=0.3) matplot(bt1$time,bt1$EIN1N2,type="l",lwd=0.3) #+END_SRC #+BEGIN_marginfigure # +CAPTION: Recurrent events label:fig:rec6 #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: rec6 [[file:rec6.jpg]] #+LATEX: \captionof{figure}{Bootstrap samples} label:fig:rec6 #+END_marginfigure ** Looking at other simulations with dependence Using the normally distributed random effects we plot 4 different settings. We have variance $0.5$ for all random effects and change the correlation. We let the correlation between the random effect associated with $N_1$ and $N_2$ be denoted $\rho_{12}$ and the correlation between the random effects associated between $N_j$ and $D$ the terminal event be denoted as $\rho_{j3}$, and organize all correlation in a vector $\rho=(\rho_{12},\rho_{13},\rho_{23})$. - Scenario I $\rho=(0,0.0,0.0)$ Independence among all efects. #+NAME: rec7 #+BEGIN_SRC R :exports both :results output graphics :file rec7.jpg :ravel fig=TRUE,include=FALSE data(base1cumhaz) data(base4cumhaz) data(drcumhaz) dr <- drcumhaz base1 <- base1cumhaz base4 <- base4cumhaz par(mfrow=c(1,3)) var.z <- c(0.5,0.5,0.5) # death related to both causes in same way cor.mat <- corM <- rbind(c(1.0, 0.0, 0.0), c(0.0, 1.0, 0.0), c(0.0, 0.0, 1.0)) rr <- simRecurrentII(3000,base1,base4,death.cumhaz=dr,var.z=var.z,cor.mat=cor.mat,dependence=2) rr <- count.history(rr,types=1:2) cor(attr(rr,"z")) coo <- covarianceRecurrent(rr,1,2,status="status",start="entry",stop="time") plot(coo,main ="Scenario I") #+END_SRC #+BEGIN_marginfigure # +CAPTION: Covariance: Scenario I label:fig:rec7 #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: rec7 [[file:rec7.jpg]] #+LATEX: \captionof{figure}{Covariance: Scenario I} label:fig:rec7 #+END_marginfigure - Scenario II $\rho=(0,0.5,0.5)$ Independence among survivors but dependence on terminal event #+NAME: rec8 #+BEGIN_SRC R :exports both :results output graphics :file rec8.jpg :ravel fig=TRUE,include=FALSE var.z <- c(0.5,0.5,0.5) # death related to both causes in same way cor.mat <- corM <- rbind(c(1.0, 0.0, 0.5), c(0.0, 1.0, 0.5), c(0.5, 0.5, 1.0)) rr <- simRecurrentII(3000,base1,base4,death.cumhaz=dr,var.z=var.z,cor.mat=cor.mat,dependence=2) rr <- count.history(rr,types=1:2) coo <- covarianceRecurrent(rr,1,2,status="status",start="entry",stop="time") par(mfrow=c(1,3)) plot(coo,main ="Scenario II") #+END_SRC #+BEGIN_marginfigure # +CAPTION: Covariance: Scenario II label:fig:rec8 #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: rec8 [[file:rec8.jpg]] #+LATEX: \captionof{figure}{Covariance: Scenario II} label:fig:rec8 #+END_marginfigure - Scenario III $\rho=(0.5,0.5,0.5)$ Positive dependence among survivors and dependence on terminal event #+NAME: rec9 #+BEGIN_SRC R :exports both :results output graphics :file rec9.jpg :ravel fig=TRUE,include=FALSE var.z <- c(0.5,0.5,0.5) # positive dependence for N1 and N2 all related in same way cor.mat <- corM <- rbind(c(1.0, 0.5, 0.5), c(0.5, 1.0, 0.5), c(0.5, 0.5, 1.0)) rr <- simRecurrentII(3000,base1,base4,death.cumhaz=dr,var.z=var.z,cor.mat=cor.mat,dependence=2) rr <- count.history(rr,types=1:2) coo <- covarianceRecurrent(rr,1,2,status="status",start="entry",stop="time") par(mfrow=c(1,3)) plot(coo,main="Scenario III") #+END_SRC #+BEGIN_marginfigure # +CAPTION: Covariance: Scenario III label:fig:rec9 #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: rec9 [[file:rec9.jpg]] #+LATEX: \captionof{figure}{Covariance: Scenario III} label:fig:rec9 #+END_marginfigure - Scenario IV $\rho=(-0.4,0.5,0.5)$ Negative dependence among survivors and positive dependence on terminal event #+NAME: rec10 #+BEGIN_SRC R :exports both :results output graphics :file rec10.jpg :ravel fig=TRUE,include=FALSE var.z <- c(0.5,0.5,0.5) # negative dependence for N1 and N2 all related in same way cor.mat <- corM <- rbind(c(1.0, -0.4, 0.5), c(-0.4, 1.0, 0.5), c(0.5, 0.5, 1.0)) rr <- simRecurrentII(3000,base1,base4,death.cumhaz=dr,var.z=var.z,cor.mat=cor.mat,dependence=2) rr <- count.history(rr,types=1:2) coo <- covarianceRecurrent(rr,1,2,status="status",start="entry",stop="time") par(mfrow=c(1,3)) plot(coo,main="Scenario IV") #+END_SRC #+BEGIN_marginfigure # +CAPTION: Covariance: Scenario IV label:fig:rec10 #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: rec10 [[file:rec10.jpg]] #+LATEX: \captionof{figure}{Covariance: Scenario IV} label:fig:rec10 #+END_marginfigure mets/vignettes/binomial-family.org0000644000176200001440000004677013623061405017032 0ustar liggesusers #+TITLE: Analysis of multivariate binomial data: family analysis #+AUTHOR: Klaus Holst & Thomas Scheike #+PROPERTY: header-args:R :session *R* :cache no :width 550 :height 450 #+PROPERTY: header-args :eval never-export :exports both :results output :tangle yes :comments yes #+PROPERTY: header-args:R+ :colnames yes :rownames no :hlines yes #+INCLUDE: header.org #+OPTIONS: toc:nil timestamp:nil #+BEGIN_SRC emacs-lisp :results silent :exports results :eval (setq org-latex-listings t) (setq org-latex-compiler-file-string "%%\\VignetteIndexEntry{Analysis of multivariate binomial data: family analysis}\n%%\\VignetteEngine{R.rsp::tex}\n%%\\VignetteKeyword{R}\n%%\\VignetteKeyword{package}\n%%\\VignetteKeyword{vignette}\n%%\\VignetteKeyword{LaTeX}\n") #+END_SRC ----- # +LaTeX: \clearpage * Overview When looking at multivariate binomial data with the aim of learning about the dependence that is present, possibly after correcting for some covariates many models are available. - Random-effects models logistic regression covered elsewhere (glmer in lme4). in the mets package you can fit the - Pairwise odds ratio model - Bivariate Probit model - With random effects - Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. - Additive gamma random effects model - Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. These last three models are all fitted in the mets package using composite likelihoods for pairs of data. The models can be fitted specifically based on specifying which pairs one wants to use for the composite score. The models are described in futher details in the binomial-twin vignette. * Simulated family data We start by simulating family data with and additive gamma structure on ACE form. Here 40000 families consisting of two parents and two children. The response is ybin and there is one covariate x. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes library(mets) set.seed(100) data <- simbinClaytonOakes.family.ace(40000,2,1,beta=NULL,alpha=NULL) data$number <- c(1,2,3,4) data$child <- 1*(data$number==3) head(data) #+END_SRC #+RESULTS[27e4ff59d6c57b64dfea494da55eefcc71265da6]: #+begin_example Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.5.1 mets version 1.2.1.2 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined Warning message: failed to assign RegisteredNativeSymbol for cor to cor since cor is already defined in the ‘mets’ namespace ybin x type cluster number child 1 1 0 mother 1 1 0 2 1 1 father 1 2 0 3 1 1 child 1 3 1 4 1 1 child 1 4 0 5 0 0 mother 2 1 0 6 1 1 father 2 2 0 #+end_example We fit the marginal models, and here find a covariate effect at 0.3 for x. The marginals can be specified excatly as one wants. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes aa <- margbin <- glm(ybin~x,data=data,family=binomial()) summary(aa) #+END_SRC #+RESULTS[590c57384c65b5b484a3d1c9cf1242b039c5bff4]: #+begin_example Call: glm(formula = ybin ~ x, family = binomial(), data = data) Deviance Residuals: Min 1Q Median 3Q Max -1.5283 -1.3910 0.8632 0.9779 0.9779 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) 0.489258 0.007291 67.1 <2e-16 *** x 0.306070 0.010553 29.0 <2e-16 *** --- Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 206272 on 159999 degrees of freedom Residual deviance: 205428 on 159998 degrees of freedom AIC: 205432 Number of Fisher Scoring iterations: 4 #+end_example * Additive gamma model For the additive gamma of this type we set-up the random effects included in such a family to make the ACE valid using some special functions for this. The model is constructe with one enviromental effect shared by all in the family and 8 genetic random effects with size (1/4) genetic variance. Looking at the first family we see that the mother and father both share half the genes with the children and that the two children also share half their genes with this specification. Below we also show an alternative specification of this model using all pairs. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes # make ace random effects design out <- ace.family.design(data,member="type",id="cluster") out$pardes head(out$des.rv,4) #+END_SRC #+RESULTS[eda2ae38cebdf87ea316bd53b74f9a35b064608c]: #+begin_example [,1] [,2] [1,] 0.25 0 [2,] 0.25 0 [3,] 0.25 0 [4,] 0.25 0 [5,] 0.25 0 [6,] 0.25 0 [7,] 0.25 0 [8,] 0.25 0 [9,] 0.00 1 m1 m2 m3 m4 f1 f2 f3 f4 env [1,] 1 1 1 1 0 0 0 0 1 [2,] 0 0 0 0 1 1 1 1 1 [3,] 1 1 0 0 1 1 0 0 1 [4,] 1 0 1 0 1 0 1 0 1 #+end_example We can now fit the model calling the two-stage function #+BEGIN_SRC R :results output :exports both :session *R* :cache yes # fitting ace model for family structure ts <- binomial.twostage(margbin,data=data,clusters=data$cluster, theta=c(2,1), random.design=out$des.rv,theta.des=out$pardes) summary(ts) # true variance parameters c(2,1) # total variance 3 #+END_SRC #+RESULTS[61bb5855b777de8534d2c14e627e9fa56b2a4828]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.2425610 0.03747680 dependence2 0.1255742 0.01607478 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.659 0.0611 0.539 0.779 4.25e-27 dependence2 0.341 0.0611 0.221 0.461 2.39e-08 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.368 0.0252 0.319 0.418 3.31e-48 attr(,"class") [1] "summary.mets.twostage" [1] 0.2222222 0.1111111 [1] 0.3333333 #+end_example ** Pairwise fitting We now specify the same model via extracting all pairs. The random effecs structure is simpler when just looking at pairs. A special function writes up all combinations of pairs. There are 6 pairs within each family, and we keep track of who belongs to the different families. We first simply give the pairs and we then should get the same result as before. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes mm <- familycluster.index(data$cluster) head(mm$familypairindex,n=20) pairs <- mm$pairs dim(pairs) head(pairs,12) #+END_SRC #+RESULTS[d36e9dab79ac94bc13d0fad305a098ba343ea904]: #+begin_example [1] 1 2 1 3 1 4 2 3 2 4 3 4 5 6 5 7 5 8 6 7 [1] 240000 2 [,1] [,2] [1,] 1 2 [2,] 1 3 [3,] 1 4 [4,] 2 3 [5,] 2 4 [6,] 3 4 [7,] 5 6 [8,] 5 7 [9,] 5 8 [10,] 6 7 [11,] 6 8 [12,] 7 8 #+end_example Now with the pairs we fit the model #+BEGIN_SRC R :results output :exports both :session *R* :cache yes tsp <- binomial.twostage(margbin,data=data, clusters=data$cluster, theta=c(2,1),detail=0, random.design=out$des.rv,theta.des=out$pardes,pairs=pairs) summary(tsp) #+END_SRC #+RESULTS[38e726dc0ad121df87192fbd8f65f499ae2c367a]: : Dependence parameter for Clayton-Oakes model : Variance of Gamma distributed random effects : Error in theta.des %*% theta : non-conformable arguments Here a random sample of pairs are given instead and we get other estimates. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes set.seed(100) ssid <- sort(sample(1:nrow(pairs),nrow(pairs)/2)) tsd <- binomial.twostage(aa,data=data,clusters=data$cluster, theta=c(2,1),step=1.0, random.design=out$des.rv,iid=1,Nit=10, theta.des=out$pardes,pairs=pairs[ssid,]) summary(tsd) #+END_SRC #+RESULTS[ac77be6001e9390c518f184e1c3e980f09e0d98f]: : Dependence parameter for Clayton-Oakes model : Variance of Gamma distributed random effects : Error in theta.des %*% theta : non-conformable arguments To specify such a model when only the pairs are availble we show how to specify the model. We here use the same marginal "aa" to make the results comparable. The marginal can also be fitted based on available data. We start by selecting the data related to the pairs, and sets up new id's and to start we specify the model using the full design with 9 random effects. Below we show how one can use with only the random effects needed for each pair, which is typically simpler. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes head(pairs[ssid,]) ids <- sort(unique(c(pairs[ssid,]))) pairsids <- c(pairs[ssid,]) pair.new <- matrix(fast.approx(ids,c(pairs[ssid,])),ncol=2) head(pair.new) dataid <- dsort(data[ids,],"cluster") outid <- ace.family.design(dataid,member="type",id="cluster") outid$pardes head(outid$des.rv) #+END_SRC #+RESULTS[26b3d1289180f1990078bf8d031288608d7fe438]: #+begin_example [,1] [,2] [1,] 1 2 [2,] 1 3 [3,] 2 4 [4,] 3 4 [5,] 5 6 [6,] 5 7 [,1] [,2] [1,] 1 2 [2,] 1 3 [3,] 2 4 [4,] 3 4 [5,] 5 6 [6,] 5 7 [,1] [,2] [1,] 0.25 0 [2,] 0.25 0 [3,] 0.25 0 [4,] 0.25 0 [5,] 0.25 0 [6,] 0.25 0 [7,] 0.25 0 [8,] 0.25 0 [9,] 0.00 1 m1 m2 m3 m4 f1 f2 f3 f4 env [1,] 1 1 1 1 0 0 0 0 1 [2,] 0 0 0 0 1 1 1 1 1 [3,] 1 1 0 0 1 1 0 0 1 [4,] 1 0 1 0 1 0 1 0 1 [5,] 1 1 1 1 0 0 0 0 1 [6,] 0 0 0 0 1 1 1 1 1 #+end_example Now fitting the model with the data set up #+BEGIN_SRC R :results output :exports both :session *R* :cache yes tsdid <- binomial.twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1), random.design=outid$des.rv,theta.des=outid$pardes,pairs=pair.new) summary(tsdid) #+END_SRC #+RESULTS[7a9e897d1493321500a094c04471dc9bfd3fcbce]: : Dependence parameter for Clayton-Oakes model : Variance of Gamma distributed random effects : Error in theta.des %*% theta : non-conformable arguments We now specify the design specifically using the pairs. The random.design and design on the parameters are now given for each pair, as a 3 dimensional matrix. with a direct specification of random.design and the design on the parameters theta.design. In addition we need also to give the number of random effects for each pair. These basic things are constructed by certain functions for the ACE design. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes pair.types <- matrix(dataid[c(t(pair.new)),"type"],byrow=T,ncol=2) head(pair.new,7) head(pair.types,7) theta.des <- array(0,c(4,2,nrow(pair.new))) random.des <- array(0,c(2,4,nrow(pair.new))) # random variables in each pair rvs <- c() for (i in 1:nrow(pair.new)) { if (pair.types[i,1]=="mother" & pair.types[i,2]=="father") { theta.des[,,i] <- rbind(c(1,0),c(1,0),c(0,1),c(0,0)) random.des[,,i] <- rbind(c(1,0,1,0),c(0,1,1,0)) rvs <- c(rvs,3) } else { theta.des[,,i] <- rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) random.des[,,i] <- rbind(c(1,1,0,1),c(1,0,1,1)) rvs <- c(rvs,4) } } #+END_SRC #+RESULTS[906e24ad3e6fa43248975dfcf2d2a93237d25f83]: #+begin_example [,1] [,2] [1,] 1 2 [2,] 1 3 [3,] 2 4 [4,] 3 4 [5,] 5 6 [6,] 5 7 [7,] 5 8 [,1] [,2] [1,] "mother" "father" [2,] "mother" "child" [3,] "father" "child" [4,] "child" "child" [5,] "mother" "father" [6,] "mother" "child" [7,] "mother" "child" #+end_example For pair 1 that is a mother/farther pair, we see that they share 1 environmental random effect of size 1. There are also two genetic effects that are unshared between the two. So a total of 3 random effects are needed here. The theta.des relates the 3 random effects to possible relationships in the parameters. Here the genetic effects are full and so is the environmental effect. In contrast we also consider a mother/child pair that share half the genes, now with random effects with (1/2) gene variance. We there need 4 random effects, 2 non-shared half-gene, 1 shared half-gene, and one shared full environmental effect. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes # 3 rvs here random.des[,,1] theta.des[,,1] # 4 rvs here random.des[,,2] theta.des[,,2] head(rvs) #+END_SRC #+RESULTS[05d72dd3c5c9565fa8590ffc8fc85a71abee3772]: #+begin_example [,1] [,2] [,3] [,4] [1,] 1 0 1 0 [2,] 0 1 1 0 [,1] [,2] [1,] 1 0 [2,] 1 0 [3,] 0 1 [4,] 0 0 [,1] [,2] [,3] [,4] [1,] 1 1 0 1 [2,] 1 0 1 1 [,1] [,2] [1,] 0.5 0 [2,] 0.5 0 [3,] 0.5 0 [4,] 0.0 1 [1] 3 4 4 4 3 4 #+end_example Now fitting the model, and we see that it is a lot quicker due to the fewer random effects needed for pairs. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes tsdid2 <- binomial.twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1), random.design=random.des, theta.des=theta.des,pairs=pair.new,pairs.rvs=rvs) summary(tsdid2) #+END_SRC #+RESULTS[dd95dd23d99675ae36e3239b4aeec50fa989eeec]: : Dependence parameter for Clayton-Oakes model : Variance of Gamma distributed random effects : Error in theta.des %*% theta : non-conformable arguments The same model can be specifed even simpler via the kinship coefficient. For this speicification there are 4 random effects for each pair, but some have variance 0. The mother-father pair, here shares a random effect with variance 0, and have two non-shared genetic effects with full variance, in addition to a fully shared environmental effect. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes kinship <- c() for (i in 1:nrow(pair.new)) { if (pair.types[i,1]=="mother" & pair.types[i,2]=="father") pk1 <- 0 else pk1 <- 0.5 kinship <- c(kinship,pk1) } head(kinship,n=10) out <- make.pairwise.design(pair.new,kinship,type="ace") names(out) out$random.des[,,1] out$theta.des[,,1] #+END_SRC #+RESULTS[11c9949740bb3fe5d415b91c9f4d99b0565bd7d9]: #+begin_example [1] 0.0 0.5 0.5 0.5 0.0 0.5 0.5 0.5 0.5 0.5 [1] "random.design" "theta.des" "ant.rvs" [,1] [,2] [,3] [,4] [1,] 1 1 0 1 [2,] 1 0 1 1 [,1] [,2] [1,] 0 0 [2,] 1 0 [3,] 1 0 [4,] 0 1 #+end_example Now, fitting the model we get the results from before. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes tsdid3 <- binomial.twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1)/9,random.design=out$random.design, theta.des=out$theta.des,pairs=pair.new,pairs.rvs=out$ant.rvs) summary(tsdid3) #+END_SRC #+RESULTS[6f93e6815d5d4e5b174712b4163c9d0d59ba977a]: : Dependence parameter for Clayton-Oakes model : Variance of Gamma distributed random effects : Error in theta.des %*% theta : non-conformable arguments * Pairwise odds ratio model To fit the pairwise odds-ratio model in the case of a pair-specification there are two options for fitting the model. 1. One option is to set up some artificial data similar to twin data with - a pair-cluster-id (clusters) - with a cluster-id to get GEE type standard errors (se.cluster) - We can also use the specify the design via the theta.des that is also a matrix of dimension pairs x design with the design for POR model. Starting by the second option. We need to start by specify the design of the odds-ratio of each pair. We set up the data and find all combinations within the pairs. Subsequently, we remove all the empty groups, by grouping together the factor levels 4:9, and then we construct the design. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes tdp <-cbind( dataid[pair.new[,1],],dataid[pair.new[,2],]) names(tdp) <- c(paste(names(dataid),"1",sep=""), paste(names(dataid),"2",sep="")) tdp <-transform(tdp,tt=interaction(type1,type2)) dlevel(tdp) drelevel(tdp,newlevels=list(mother.father=4:9)) <- obs.types~tt dtable(tdp,~tt+obs.types) tdp <- model.matrix(~-1+factor(obs.types),tdp) #+END_SRC #+RESULTS[9a469da2b726c7c7e4093e1f3e61d751fdd46384]: #+begin_example type1 #levels=:3 [1] "child" "father" "mother" ----------------------------------------- type2 #levels=:3 [1] "child" "father" "mother" ----------------------------------------- tt #levels=:9 [1] "child.child" "father.child" "mother.child" "child.father" [5] "father.father" "mother.father" "child.mother" "father.mother" [9] "mother.mother" ----------------------------------------- obs.types mother.father child.child father.child mother.child tt child.child 0 19991 0 0 father.child 0 0 39837 0 mother.child 0 0 0 40212 child.father 0 0 0 0 father.father 0 0 0 0 mother.father 19960 0 0 0 child.mother 0 0 0 0 father.mother 0 0 0 0 mother.mother 0 0 0 0 #+end_example We then can fit the pairwise model using the pairs and the pair-design for descrbing the OR. The results are consistent with the the ACE model as the mother-father have a lower dependence as is due only the environmental effects. All other combinations should have the same dependence as also seem to be the case. To fit the OR model it is generally recommended to use the var.link to use the parmetrization with log-odd-ratio regression. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes porpair <- binomial.twostage(aa,data=dataid,clusters=dataid$cluster, theta.des=tdp,pairs=pair.new,model="or",var.link=1) summary(porpair) #+END_SRC #+RESULTS[c4026bc9a6236f8e96b140585e44876e3bcce6a5]: #+begin_example Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(obs.types)mother.father 0.1269881 0.03132228 factor(obs.types)child.child 0.3819107 0.03108233 factor(obs.types)father.child 0.3046284 0.02239909 factor(obs.types)mother.child 0.3293741 0.02233648 $or Estimate Std.Err 2.5% 97.5% P-value factor(obs.types)moth.... 1.14 0.0356 1.07 1.21 1.16e-223 factor(obs.types)chil.... 1.47 0.0455 1.38 1.55 4.26e-227 factor(obs.types)fath.... 1.36 0.0304 1.30 1.42 0.00e+00 factor(obs.types)moth.....1 1.39 0.0310 1.33 1.45 0.00e+00 $type [1] "or" attr(,"class") [1] "summary.mets.twostage" #+end_example * COMMENT mets/vignettes/rec5.jpg0000644000176200001440000006125313623061405014601 0ustar liggesusersJFIFC    $.' ",#(7),01444'9=82<.342C  2!!22222222222222222222222222222222222222222222222222&" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( yg%hqesvͨ[4BQyuTpq]W"Ҵh|7k:u$6i?wb 3#mOS+. EH#T~_̭W9@Y>8o$Z8mؙt>U򔖉y*W8?( 6 G<+8[ha^<Ovju]:yM_6X\,h X: VԞ'Ӡqrq0, ^tDF 2'APEPEPEPEPEPEPEPEP[g_֖Gd֒ۋ?'(Ƚ>a}צ@]uxu S-O sfa26b*2dP~9%6 xXɦ)Dʭ&[C r8(&'|yoi6ڑT ƟU0cd>YNN3zQ񕔷6r\ihi,#nc ,#^Eyu?\x"tӁpGRbC(((((((+ͼW7 Tխ4J 2D;^1^Ey__o^Z+_#+0/'ˎk^tCsmF3V*Bb , Q@bSp]>. ҖV.6F%\|ہ@sþ5^w;`E ZRIwtPEPEPEPEPEPEP{m2[DV N2p8H ???I_=+ M4?)?4+~CM~. " M4?)?4+~CM~. " M4?)hw ",#>Dcc@n{QߗhG/ֽ F?M~_~ZP+ ZSiRH.J88 pp#WkG-O2((&.xX[T9A0QԊP^^su % <09EAjCRf4'$S,Xrxe<vmR F4U߉?٢1*ѿğMhO&h oJo'G%Z7?(~I V?O~$kfF4U߉?٢1^,k$wee #w%?7&&k[ F?M~_~ZPG%?7&Xjvzr=U?l=?[}#C آ(((G5RK'`PIXM4?)_k#CM~. " M4?)?4+E{EԎB o#*2vSzL5ZoҺ oZ=-ț?eɚ3}+v{hyF1I&>ݭ MZ&[ +-'%F!#HF='4}b/1LbpWH&/ Qw&^=*6 ݃idLqD7NN93@TW5 >t+;F,vH2ѷ;Gauױꭼ+ ijVܙcA$ GLmEy|_W9緂&c]5/ 8,Y_wI7`g+/m"X67N2Hŷ ǧ<tY~^jDS8 nƔv_t9jї5X9jї5L(*ft;vo+Y9ڭ@tȮ"Ssmon!o.s*cg%5iE%^krQ1*;J'i_5hZ{-0[7`Kohh^_]db8dcxLo3Imm?װjTTk#t%F |x' lΓoo;:W1[zykx]1BH rˀvQ^{iataD- n=9G({k\۸_;"6AwRWr@j-[ťfx%KՁ14iݰJ?x}Eq ߴEVp$ąb2kGI֡yb%O\$@'"n`X7C}Zؠ( Wf{8a,=9j!O gW}NؚqtA<`S?V!O JwH{,lQEFAEPEP?5o ?֝jZ"B>p8k#{_*:hsi?ZoS7 лM_4.&Os%K'Ԁ5Hj͵ّΚ\WE$rsxT-FdD90 d.\g'QG#sIuJ :}*^܀E˿]MO+4h0%ۑ@)ީ n#3~ͽQ -JbY~]H/q$DÜAtGaq=<ܭ8#8ZVY"dBGv6q7^j|$[ b$\mYvt?t Y9`VCĠ+׮9\sEc)k+{L2;q$ң%܎n=ADFwi4;gH~kTr]*AEPEPXơ@艫bh??"j4BO䵱X!'Zؠ((M !fu)RXdc AWM"+s3 7RLI g<P7O(Jy"iI@Q@ZK אZ[ ]hX%]>;XU22:昷vǥXD 䁀H#Uu*2"X1PXp9PHʬ0yJlRj/n#8 zج zآ([FҬQZ l ( ji6_= HΙƹui֭)ecəe`f.8A~k#i{SG-O2+G-O2*B((|AmV'i_5hZ(%K[% 6r|%4X<n-il~izwl8zPvwkS΍dzFqS2 0dGqҚeLHYPH2?1Oڻq)hE,sĒ"dt9  PH$t4U,B[@KEcOD-kb'"n`@V~s]2O-`IIjʌ\,w1/a^,Kl`c#C .PlUzfCGARcJ;Y7m6( (դ]"U‰! +d;2ttd,$] @v 8qP-aG;ٝnG3|L+{kñiWqjn|3[y#f5/Rjjſ+ROo9S #ge?5 1 kkRN34s8  '"5=@휣gߥIO6i=+`B1=#> kkhk__ _(t}oY˷F6f$2vkKdk3S[wo)r 6(ۀCZb((+Ȳ:>-4[G p3|ljR4ILrj8|[{qhnnJ~ҡ8 g0V][PԴLKhmL9qHWJJ[{UkbBO䵱LaEPEPEP7O( ya) ?0EsW"xpp Y8nWhvw'._EOmm<kn *WhG@+4Qnܿfu]NG6nis?zvi~-CPFY5CXH 8'|f?ҿ>O3L-kbX,~A>z|YqFARy^m 7̅{_1' hwBd G@+4y#v累{Zyix[2P0rq8:?4Բ{eTliHQ##n9G@+4y#vcj:}e%(ҳ1 A_7?=|;J?OYMQJπHv3@ 66s]\H wc55s5Eb! (JgޓvW*r'nS{J&qh z*KuV0}MDUU6=:9jї5X9jї5L((+'i_5kZ<_q-m$Fʩ-:(shf)f,W/nU'*/1s~*?ҿ>O3G?i_'#QY[E[y^Kqcz|Yau8n$ٺp}<ڟWhG@+4ұ9ufC'!f`%a .(oro.)e O5@\aAQTs]_?i_'#|>50[2Y|Ĝ6ݢE  qԃ=+ὶ֞}^-Eo6̡T 6\|9]?i_'idiكOґ .FF/\sXڭmhY`b |f?ҿ>O3@ ?t?赭ɦh:u%p/BU@${qWj=oO6MjQJ4.[#'=kw:Lj$jn'h~m~7HLj??'+HLj??'آ((;Xa8*d 'Om/Op !g?Q@> υ(Gs[Ճ [w5@Q@Q@Q@Q@Q@U ntB+o#=78qI+61 7nb+~\ºxWLzLznlVtߩZoY}W%>a ?jnQEQEQEsGz1 D{ѩ]=QEQEQEQEQEi.'mg4vcơ]ۦ9+m2) `$I$$ssKc?52դmIR| -QTbc>F\c>F\QEQExAV?Ҩ롮{_ G@ Q@Q@Q@Q@Q@Q@`x03xb]-I@*5? y#"XP',@j]z%8v`1U?hiEkc~Gc~GQEQEQE`C>oV?3o ?QEQEQEQEQExoHO\nw_*<1ǡPMum$ 31u$y%7E'62'm~DtғE6X1zkQET"иAB*+dQEQF>_I+@گ$K[QEQEQE|BjWO\/އFtQEQEQEQEW/D37,ڢFPߡ}^sy=v_$L5DkjuQEQQEm#`Os[m#`Os[QEQEAyy3,j@;P$ I Nhze  XTuc[0L#uհ pAЊ-aQCEPEPEPEPEZLC2pI$rI$s@tkɩ<;ʀXDl}k?1s\,$i1{ҷ*a#v (+HLj??'+HLj??'6(( 0X2?GБMm,ʋb5b|-aG;ެg#((((+ϼ7s/>&kz3-,Oc/wLI4 cɮ7d2Ay:Fvk0lsyc+c(>a ?c{Ukb ( (#xg H]U$M7Y՚eF0xH 3ʰ>HϖXǻמPEPEPEPEP\a=J!gUs߈XC]EYdF ;X]|;LFzoS-6e/+}.tQEQQEm#`Os[m#`Os[QEU gȸ3M{ {` A2# =/XZJ((((\ZIm34o%y̋"uK\ͽ5Q[#]/Zmn4;:tT*v(}#C ج}#C آ(((Hkz|A! Q淨((((|^c{2q1K¶=j^v@#$~f_ hդK^ʃ$lkWUuWo߫QEQEc{UkbBO䵱@Q@Q@Q@/އFt|BjWO@Q@Q@Q@Q@*k? ^f>nO3 Xma+I?oV?3o ?QEQEQEQY_Z@끐8q^\+fs寗Ȑz5r? 4"7;yާgǟXk Q[EP>_I+@گ$K[QEQEQE|BjWO\/އFtQEQEQEQE2iIu(Իd@څ$@D-S+D^ȅe`ywa3Mu51m[F ((ǶS}ǶS}((+-aQC\cak*:( ( ( (9a.;xauMoñ8}`ʕ6_QTbQEc[c@QEQETu;=*R#*3A$ץIgy۳4lH*AGjݧv\#GwF̠cs5>NE6T7.\JyrIygxC>oW)X[3I\jbV KP79&(((+r-H%W#~8Ҹ_*{n*ͪmqq&Kҭ,#V袴TRH1QQL(@گ$K[}W%(c՚ѴBāT;q# U @q*Ə%%7OmLp\ӎNc+2٣O cמOJϣJb"Ggdʃ#{* ۆHZw&bOvsҲ|7#̑"*2r6]2p__#J"=Ԯ ( ( ( |ỈeptlY+K7Vr^#/j Cm"9I%WBz,FG?w'erǞj,#x{c*U3Hg%?Т.y9w (!EP=Z?elV=Z?elPYzՒo6 4kWkxRYq-Ooc9v#)S(+-aQC\cak*:( ( ( +[in'c$/#EP2I*J|su_ ?`uĄ#ROCvb[ͭxJH:t/%lug y83{ Ӭ&Y/Y^bAۖ8_I((qIgdpC0 Q+ozVe핋(%NPĶ~Rj6̢/C϶qYZOu.nHuc7F.FPy?{ڷ(/&n/LnNy0b{~kcCRz(((+]O֤<޲E"c* ޵݋ P,To#';N0|xFZ~yI'̉|Cj^#jzBR}.nEF!EPEP=Z?elV=Z?elP\ϊbO;,9vSnDR!:]5QEW=/XZJ*Ut4QEQEQE?[Q8Ы3]5s~ ?|5bz̷?2?4m~N(1 ( ( ?1Iᭊ?1I (8MGR?~PW+]GJ'8' @8k[vkxyAQE [w5X> υ(Gs[QEQEQEQ>7:Kç&5*t*~az湟ZExvA)$П":>Vi珽ZR_QEltQ@W?i] 0D?ݑIlT%cZteQIj-lV>_I*(((cCRz>!ȏ?5+(((kNëkWvD+ k?&s$tO4Yfk͹d1WWR&m-)EwmKŠ(1 ( (1ri.kbri.kb ( ( e  XTu=/XZJ(((#a*[Of22.>kK }VA-&R0do8¤k2mEZmQTbQEQEc[c@QEQEQE`C>oV?3o ?QEQEQEp3e0e oew?nZ[W#zAl- }j-lV>_I*P((("=Ԯ_#J((_fh7kw("H(;5jpf^}EuBz8b̄bN@nC? sjIC7 (((ǶS}ǶS}((_[iowy2n #t Ԋ\cak*5mN˄}:WoW'hU<3wgY[ɩh`Tv䜰9 (((okKUA嵳|g2c1 ٯ=xZETmٚT8W~sb9EZTzW, &G=XW?MuuOJ~ih Q*9sW*hƜSt J1{mo$ȱwcrI+Y|SǤF|AʝȿvCC0ʴվDQ|OwAvA(x'5uf0$0E_OR}Y*pKDam^؇5}ߛYhQEYc{UkbBO䵱@Q@Q@fpm8/[ֽ]ZY"V82Nzۀ#Zwqaq &&H>[@oYyrRq(EX-ݻz {ii}B+1{s:5W1 D{ѩ]=QEQExg}*KOEnevb;.ºzD pxH52ւ}5:XaBEEFmŠ(AEPEP=Z?elV=Z?elPEPY^$0 6qBvBBHUĀpkVȻE ?4cO\#uQ_Z5![F㿕vxAV?Ҩ(((~avdF=0o<1'FHwHXgjºftQeKQEQQEQEV>!O lV>!O lQEQEQE [w5X> υ(Gs[QEQEWg^27[G1U|9+j>$pz(T`ʬf,{_{ܰcl$Q0T@YS[ ՛HӃy< X#tϰ`ith-O6~d^drϩ5f.(W̄g@J ݎےO#j0wߥ( (@گ$K[}W%(((>!ȏ?5+cCRz((+:s7 ؄= qٷ}N^j2ELs 'xO:Ot<菎5/V=r}?W}QTbQEQEQEc>F\c>F\QEQExAV?Ҩ롮{_ G@ Q@Q@VG5WӭaՔ7-#(_,y,@\<Ҁ*BS䋎eMt5KcgXZO0F/n#6Z٩KvEUQ@Q@c~Gc~GQ@Q@Q@> υ(Gs[Ճ [w5@Q@Q@]\Gii5̬8i`I_ᦚt0eER4>Cbo5E,a2~uE{;FaTlx\/Z?oɜޮdZ^JR' r B~Uk_W toG=d`b(9$4]֤"d0W#7$Ө#e{y[پyGE*"0(N ((@گ$K[}W%(((>!ȏ?5+cCRz((=>mge ZF33bO$ƀ9[T~t$%483(5?3o ?QE5i{ *<2Ba@vsҽX~&̹e'AqXonF9#GOeigˆ0@1\z}Ņ&S$Y`+[XKu/A'ԮG^!wQh䖔ߡNUٲI; "ƊUF Z(N0(((@گ$K[}W%((+9'RG" GZ4usu<6077lɫP1 D{ѩ]=sGzEP\RȀ$ltnrvFy\㢶 ۫)o w ?ʩxfɬ<3[@.NO3蚗}n]?5h((((G-O2+G-O2((({_ G] s2U?:h*+,e!%/$pIkrZi6[ԯaE+$=@V7erJ+ ^6MsRlH6ءX /GB+vPXAfgrzO$Պ"Y)KOQL(((+HLj??'+HLj??'6(((|-aG;ެg#(}{ories*$|>WZ{G6reTnE>.H7D?7@ cRkWE }ڌ9ږ#Aԑ\yG?2)Q'hO[ #>/֥@v:bO w>KH]*O\C,{jk]Me9rC_d(9((( }j-lV>_I(((("=Ԯ_#J+;Yngpąݏ`MIds2c&X/!bUHQ\Džl>( [E>P=j(((((G-O2+G-O2((({_ G] s2U?:h+/M&#i+ϜZF=ULj|C$Zmmjoubn=HMFV"$,rO$Rv7䃛_4((((}#C ج}#C آ(((Hkz|A! Q淨>tkhMN1[E!O lV>!O lQEQEQP^_Zi hA4'oqݺ\[M2F#@ υ(Gs[Ճ [w5@ wXѝ*(%FguNO܅fu$ZA* ?Ќtrz{Rn+$)NNRwl(dQ@Q@Q@Q@!'Zج}j-lPEPEP=\ڍ6OwPDz+]VɃc&dqg~q U:Q;[jX2kx8$U7Jm8s$]sՙܚE++ܷRN<(@QEQEQEQEQEV>!O lV>!O lQEQEG-ˋpn@#Ʋ 6>pd!>Rxm}6Hmiyqwg88N1Z740E sXd׮[lY-&,k7jv$ R``rIӼ#I}wjܰ:1/<ַ;R胭J8c>V>+R ereR%X@  "1?[Z7`} t^f}>fѻ Kk0??[ZDŽ`M.uv"cn. uRȐQ1SXhm+HQ8ٝˍxE~?Z/xGT._gT*H7n\nr1ؠOP q [wk\c[?߯xCy{k~?Lov nkfJdγv LS[ӴQ7-~>?Vh柣Y-YUY؅љsp=M_VFF\H 2%[ 25v ( ( iڥW1WܭV 2ATP)oHd5\bY57cj!gk<㵥csIcŮ# J`a`pH] Cy{jC}si [8[wm7 3+Z+hmC2 #uFAsτC}>]7o!nxNnUCy{k~?Lovj>d%λ@s/+;gƃX+,DorW$rw}:P_~?Z/[{u,һġ$`8iZhsLenz־ /JEz^poΜܝ߾{<}ni1b7B73;bp嘞j(ddܥw!sm]2ArtvIU\A0ˌk9!g]5,RS(ҋqsCEQEk6m4 Nx#"_sJ͟[߹/?{tPfH4HTHAƅ"ZtQ@Q@Q@Q@,K&#d~c+I $b袀2t(/oq " $E~CR99o}:eACnۼSWMEAcgY[!b1ڠ=PL<؞=̛8#=@xL\:]ef*!Pc 3$s/YvMy{$K~Tǻ 1g5@Q@gDZͣ[MVQEQEQEVfH4HTHAƅZtPYwϸ"!ɂ)\JԢ9d-?b -6#veNwmvzblk+pD6,Q9;T2~ (!6HKx9~`Sdq$IqviDV@l0`(@⺊( ¶vsӰ{Geui008h (2uK?o . $`{>q^>ѳnQys]5GL##,O$ $b*jEQEQEQEQEQEQEVv -v*] fU~$r29(kO-nIUHXɁ| `NL^F_C0!o'nbh(((((((((( _W:Z$p>LKvߎ+9-RP?0J7ss;z( ëmnMĕˍUN[vҬI\mQ[Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@`UOm2KT- ErqAG7M&bG2\6:={juueӟfY$2e|F x"6+w9z(((((((((((((((((((((((((((((((((((((((((mets/vignettes/quantitative-twin.org0000644000176200001440000003134013623061405017441 0ustar liggesusers#+TITLE: Twin analysis #+AUTHOR: Klaus Holst & Thomas Scheike #+PROPERTY: header-args:R :session *R* :cache no :width 550 :height 450 #+PROPERTY: header-args :eval never-export :exports both :results output :tangle yes :comments yes #+PROPERTY: header-args:R+ :colnames yes :rownames no :hlines yes #+INCLUDE: header.org #+LATEX_HEADER: \usepackage{units} #+OPTIONS: toc:nil #+BEGIN_SRC emacs-lisp :results silent :exports results :eval (setq org-latex-listings t) (setq org-latex-compiler-file-string "%%\\VignetteIndexEntry{Twin analysis of quantitative outcomes}\n%%\\VignetteEngine{R.rsp::tex}\n%%\\VignetteKeyword{R}\n%%\\VignetteKeyword{package}\n%%\\VignetteKeyword{vignette}\n%%\\VignetteKeyword{LaTeX}\n") #+END_SRC ----- # +LaTeX: \clearpage * Mets package This document provides a brief tutorial to analyzing twin data using the *=mets=* package: #+BEGIN_SRC R :exports code :ravel echo=FALSE library("mets") options(warn=-1) #+END_SRC #+RESULTS: #+begin_example Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.6.3 mets version 1.2.5 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined #+end_example The development version may be installed from /github/, i.e., with the =devtools= package: #+BEGIN_SRC R :eval never :exports code :ravel eval=FALSE devtools::install_github("kkholst/lava") devtools::install_github("kkholst/mets") #+END_SRC * Twin analysis, continuous traits In the following we examine the heritability of Body Mass Index\n{}cite:korkeila_bmi_1991 cite:hjelmborg_bmi_2008, based on data on self-reported BMI-values from a random sample of 11,411 same-sex twins. First, we will load data #+BEGIN_SRC R data("twinbmi") head(twinbmi) #+END_SRC #+RESULTS: : tvparnr bmi age gender zyg id num : 1 1 26.33289 57.51212 male DZ 1 1 : 2 1 25.46939 57.51212 male DZ 1 2 : 3 2 28.65014 56.62696 male MZ 2 1 : 5 3 28.40909 57.73097 male DZ 3 1 : 7 4 27.25089 53.68683 male DZ 4 1 : 8 4 28.07504 53.68683 male DZ 4 2 The data is on /long/ format with one subject per row. #+BEGIN_mnote + *=tvparnr=* :: twin id + *=bmi=* :: Body Mass Index (\(\unitfrac{kg}{m^2}\)) + *=age=* :: Age (years) + *=gender=* :: Gender factor (male,female) + *=zyg=* :: zygosity (MZ,DZ) #+END_mnote we transpose the data allowing us to do pairwise analyses #+BEGIN_SRC R twinwide <- fast.reshape(twinbmi, id="tvparnr",varying=c("bmi")) head(twinwide) #+END_SRC #+RESULTS: : tvparnr bmi1 age gender zyg id num bmi2 : 1 1 26.33289 57.51212 male DZ 1 1 25.46939 : 3 2 28.65014 56.62696 male MZ 2 1 NA : 5 3 28.40909 57.73097 male DZ 3 1 NA : 7 4 27.25089 53.68683 male DZ 4 1 28.07504 : 9 5 27.77778 52.55838 male DZ 5 1 NA : 11 6 28.04282 52.52231 male DZ 6 1 22.30936 Next we plot the association within each zygosity group #+BEGIN_SRC R :exports code library("cowplot") scatterdens <- function(x) { sp <- ggplot(x, aes_string(colnames(x)[1], colnames(x)[2])) + theme_minimal() + geom_point(alpha=0.3) + geom_density_2d() xdens <- ggplot(x, aes_string(colnames(x)[1],fill=1)) + theme_minimal() + geom_density(alpha=.5)+ theme(axis.text.x = element_blank(), legend.position = "none") + labs(x=NULL) ydens <- ggplot(x, aes_string(colnames(x)[2],fill=1)) + theme_minimal() + geom_density(alpha=.5) + theme(axis.text.y = element_blank(), axis.text.x = element_text(angle=90, vjust=0), legend.position = "none") + labs(x=NULL) + coord_flip() g <- plot_grid(xdens,NULL,sp,ydens, ncol=2,nrow=2, rel_widths=c(4,1.4),rel_heights=c(1.4,4)) return(g) } #+END_SRC #+RESULTS: : Loading required package: ggplot2 : Find out what's changed in ggplot2 at : http://github.com/tidyverse/ggplot2/releases. : : Attaching package: ‘cowplot’ : : The following object is masked from ‘package:ggplot2’: : : ggsave We here show the log-transformed data which is slightly more symmetric and more appropiate for the twin analysis (see Figure ref:fig:scatter1 and ref:fig:scatter2) #+NAME: scatter1 #+BEGIN_SRC R :exports both :results output graphics :file scatter1.jpg :ravel fig=TRUE,include=FALSE mz <- log(subset(twinwide, zyg=="MZ")[,c("bmi1","bmi2")]) scatterdens(mz) #+END_SRC #+BEGIN_marginfigure # +CAPTION: Scatter plot of logarithmic BMI measurements in MZ twins label:fig:scatter1 #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: scatter1 [[file:scatter1.jpg]] #+LATEX: \captionof{figure}{Scatter plot of logarithmic BMI measurements in MZ twins.} label:fig:scatter1 #+END_marginfigure #+NAME: scatter2 #+BEGIN_SRC R :exports both :results output graphics :file scatter2.jpg :ravel fig=TRUE,include=FALSE dz <- log(subset(twinwide, zyg=="DZ")[,c("bmi1","bmi2")]) scatterdens(dz) #+END_SRC #+BEGIN_marginfigure #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: scatter2 [[file:scatter2.jpg]] #+LATEX: \captionof{figure}{Scatter plot of logarithmic BMI measurements in DZ twins.} label:fig:scatter2 #+END_marginfigure The plots and raw association measures shows considerable stronger dependence in the MZ twins, thus indicating genetic influence of the trait #+BEGIN_SRC R cor.test(mz[,1],mz[,2], method="spearman") #+END_SRC #+RESULTS: : : Spearman's rank correlation rho : : data: mz[, 1] and mz[, 2] : S = 165460000, p-value < 2.2e-16 : alternative hypothesis: true rho is not equal to 0 : sample estimates: : rho : 0.6956209 #+BEGIN_SRC R cor.test(dz[,1],dz[,2], method="spearman") #+END_SRC #+RESULTS: : : Spearman's rank correlation rho : : data: dz[, 1] and dz[, 2] : S = 2162500000, p-value < 2.2e-16 : alternative hypothesis: true rho is not equal to 0 : sample estimates: : rho : 0.4012686 Ńext we examine the marginal distribution (GEE model with working independence) #+BEGIN_SRC R l0 <- lm(bmi ~ gender + I(age-40), data=twinbmi) estimate(l0, id=twinbmi$tvparnr) #+END_SRC #+RESULTS: : Estimate Std.Err 2.5% 97.5% P-value : (Intercept) 23.3687 0.054534 23.2618 23.4756 0.000e+00 : gendermale 1.4077 0.073216 1.2642 1.5512 2.230e-82 : I(age - 40) 0.1177 0.004787 0.1083 0.1271 1.499e-133 #+BEGIN_SRC R :ravel echo=FALSE library("splines") l1 <- lm(bmi ~ gender*ns(age,3), data=twinbmi) marg1 <- estimate(l1, id=twinbmi$tvparnr) #+END_SRC #+RESULTS: #+NAME: marg1 #+BEGIN_SRC R :exports both :results output graphics :file marg1.jpg :ravel include=FALSE,fig=TRUE dm <- Expand(twinbmi, bmi=0, gender=c("male"), age=seq(33,61,length.out=50)) df <- Expand(twinbmi, bmi=0, gender=c("female"), age=seq(33,61,length.out=50)) plot(marg1, function(p) model.matrix(l1,data=dm)%*%p, data=dm["age"], ylab="BMI", xlab="Age", ylim=c(22,26.5)) plot(marg1, function(p) model.matrix(l1,data=df)%*%p, data=df["age"], col="red", add=TRUE) legend("bottomright", c("Male","Female"), col=c("black","red"), lty=1, bty="n") #+END_SRC #+BEGIN_marginfigure #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: marg1 [[file:marg1.jpg]] #+LATEX: \captionof{figure}{...} label:fig:marg1 #+END_marginfigure ** Polygenic model Decompose outcome into \begin{align*} Y_i = A_i + D_i + C + E_i, \quad i=1,2 \end{align*} - \(A\) :: Additive genetic effects of alleles - \(D\) :: Dominante genetic effects of alleles - \(C\) :: Shared environmental effects - \(E\) :: Unique environmental genetic effects Dissimilarity of MZ twins arises from unshared environmental effects only! \(\cor(E_1,E_2)=0\) and \begin{align*} \cor(A_1^{MZ},A_2^{MZ}) = 1, \quad \cor(D_1^{MZ},D_2^{MZ}) = 1, \end{align*} \begin{align*} \cor(A_1^{DZ},A_2^{DZ}) = 0.5, \quad \cor(D_1^{DZ},D_2^{DZ}) = 0.25, \end{align*} \begin{align*} Y_i = A_i + C_i + D_i + E_i \end{align*} \begin{align*} A_i \sim\mathcal{N}(0,\sigma_A^2), C_i \sim\mathcal{N}(0,\sigma_C^2), D_i \sim\mathcal{N}(0,\sigma_D^2), E_i \sim\mathcal{N}(0,\sigma_E^2) \end{align*} \begin{gather*} \cov(Y_{1},Y_{2}) = \\ \begin{pmatrix} \sigma_A^2 & 2\Phi\sigma_A^2 \\ 2\Phi\sigma_A^2 & \sigma_A^2 \end{pmatrix} + \begin{pmatrix} \sigma_C^2 & \sigma_C^2 \\ \sigma_C^2 & \sigma_C^2 \end{pmatrix} + \begin{pmatrix} \sigma_D^2 & \Delta_{7}\sigma_D^2 \\ \Delta_{7}\sigma_D^2 & \sigma_D^2 \end{pmatrix} + \begin{pmatrix} \sigma_E^2 & 0 \\ 0 & \sigma_E^2 \end{pmatrix} \end{gather*} #+BEGIN_SRC R :exports code dd <- na.omit(twinbmi) l0 <- twinlm(bmi ~ age+gender, data=dd, DZ="DZ", zyg="zyg", id="tvparnr", type="sat") #+END_SRC #+RESULTS: #+BEGIN_SRC R l <- twinlm(bmi ~ ns(age,1)+gender, data=twinbmi, DZ="DZ", zyg="zyg", id="tvparnr", type="cor", missing=TRUE) summary(l) #+END_SRC #+RESULTS: #+begin_example ____________________________________________________ Group 1 Estimate Std. Error Z value Pr(>|z|) Regressions: bmi.1~ns(age, 1).1 4.16937 0.16669 25.01334 <1e-12 bmi.1~gendermale.1 1.41160 0.07284 19.37839 <1e-12 Intercepts: bmi.1 22.53618 0.07296 308.87100 <1e-12 Additional Parameters: log(var) 2.44580 0.01425 171.68256 <1e-12 atanh(rhoMZ) 0.78217 0.02290 34.16186 <1e-12 ____________________________________________________ Group 2 Estimate Std. Error Z value Pr(>|z|) Regressions: bmi.1~ns(age, 1).1 4.16937 0.16669 25.01334 <1e-12 bmi.1~gendermale.1 1.41160 0.07284 19.37839 <1e-12 Intercepts: bmi.1 22.53618 0.07296 308.87100 <1e-12 Additional Parameters: log(var) 2.44580 0.01425 171.68256 <1e-12 atanh(rhoDZ) 0.29924 0.01848 16.19580 <1e-12 Estimate 2.5% 97.5% Correlation within MZ: 0.65395 0.62751 0.67889 Correlation within DZ: 0.29061 0.25712 0.32341 'log Lik.' -29020.12 (df=6) AIC: 58052.24 BIC: 58093.29 #+end_example A formal test of genetic effects can be obtained by comparing the MZ and DZ correlation: #+BEGIN_SRC R estimate(l,contr(5:6,6)) #+END_SRC #+RESULTS: : Estimate Std.Err 2.5% 97.5% P-value : [1@atanh(rhoMZ)] - [3.... 0.4829 0.04176 0.4011 0.5648 6.325e-31 : : Null Hypothesis: : [1@atanh(rhoMZ)] - [3@atanh(rhoDZ)] = 0 #+BEGIN_SRC R l <- twinlm(bmi ~ ns(age,1)+gender, data=twinbmi, DZ="DZ", zyg="zyg", id="tvparnr", type="cor", missing=TRUE) summary(l) #+END_SRC #+RESULTS: #+begin_example ____________________________________________________ Group 1 Estimate Std. Error Z value Pr(>|z|) Regressions: bmi.1~ns(age, 1).1 4.16937 0.16669 25.01334 <1e-12 bmi.1~gendermale.1 1.41160 0.07284 19.37839 <1e-12 Intercepts: bmi.1 22.53618 0.07296 308.87100 <1e-12 Additional Parameters: log(var) 2.44580 0.01425 171.68256 <1e-12 atanh(rhoMZ) 0.78217 0.02290 34.16186 <1e-12 ____________________________________________________ Group 2 Estimate Std. Error Z value Pr(>|z|) Regressions: bmi.1~ns(age, 1).1 4.16937 0.16669 25.01334 <1e-12 bmi.1~gendermale.1 1.41160 0.07284 19.37839 <1e-12 Intercepts: bmi.1 22.53618 0.07296 308.87100 <1e-12 Additional Parameters: log(var) 2.44580 0.01425 171.68256 <1e-12 atanh(rhoDZ) 0.29924 0.01848 16.19580 <1e-12 Estimate 2.5% 97.5% Correlation within MZ: 0.65395 0.62751 0.67889 Correlation within DZ: 0.29061 0.25712 0.32341 'log Lik.' -29020.12 (df=6) AIC: 58052.24 BIC: 58093.29 #+end_example * Twin analysis, censored outcomes * Twin analysis, binary traits * Time to event * backmatter :ignore: bibliography:mets.bib bibliographystyle:plain mets/vignettes/rec2.jpg0000644000176200001440000006063513623061405014601 0ustar liggesusersJFIFC    $.' ",#(7),01444'9=82<.342C  2!!22222222222222222222222222222222222222222222222222&" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( jox؋KE<}F-d9K3An33P|F] E5ð(1\DK#n>]@!<Śg=sZnKT}<ɴ0m9FIJ(/WWҮH-B[H6Y xZQ@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@)o/%[2A8ry VG&\E'V0?4(C(M~. "M4?)ջl. 3yb2HN=*XVTll@Σ2^@4(C NуeP N8?$"aRMVK3(>r`Npu hsSiOUuR7m*_#6 pzt G@h?(5EdQߗhG/ֽZRi00 zU>a ?QEQEQEs5ZoҶnu f覌:Z{<>|&?2HQV_"wH(ai:\&YaH5+X܏+e̓yQjSQgt[eP qrxB_]`/|Yt̡ ?.@OlkF8qL09N }*oVh !•{sLlŵ|KC 'Ǡ4:jIO}uK$E㒡v Cqu8N& UA5wV_[;y]%B8~oHݫ\+AD~UJe \hh-;NMmbJ,|yNZ7AR]5,,5#+MGJg>oF^".EQEG$z4e>F\c>F\ ( ( ?-jVfo_5(e 6,ɬD<3BQ5soywDOLk0E'.$;ԤmYi^gvigcXcvڦk]%3!VT2g2hCo+s!~lkF8qL09N }K ,EQE5cB@P2Iz<ok'HLj??'$#Lg~!O lQEQEQE x[w5iڪ"j6*O+3Hk^JΚ-9i&3 GG 3OhkHٷ2[ı}HsO6[>q,?x8q&v=!ndj~Hc'` GH/|!aqio[ڪ)6TrF8svnaA<"6G 1[}j瀒+"HM,3n)#/xJ)zۭuhi#t;)m|/Z\5eXt9 085J2Zۘ |? _-ֽoWJl~xW dEd}ҿ['#?k@w!մ!BF&@#޵ťcXcjj((nzV\F#QCe'g)ZG-O2+G-O2)Q@Q@cx]&/? _-oWJl~ xW d[PuKMVD702 Fp} tPEPYȖf"~y9*ƅGS\?u M+ l8 ݑM-K9& qv%O=#C |4ZjW5Ʃqfb1ݱGvZG? _-ֽoWJl~xW dE`iZqui)\E"33(Lƿpَ-I>IU2:IcS҇e^ +1gǏJnh{UkbBO䵱TdQEQER;hTd8z[OOOD8fd } RO?GlV?]z? kb ( ( ( ( ( (1 Is˪$_JDr"9CK}ieVY>6 TI4a};o?˚ج{o?˚ث9(* lmcRڅ$I$@??ma ?(iln,ei" q`@`2`AAUKMBόQ@Q@Q@Q@Q@R 2hY&O \ל-KVҴw!>,YqXzo[#m#{eW|a3rMsz=ŞoWկI0‘p{ >=d'6V,s ? x#xk/l4̀*FԒM#C )Ō4REV QEhkܟ$c.2meǨ?6ASiZriZrYǷb3C1mU(Hkz|A! Q淨((((ɈSz/.F8>Vfq5OcQԭt]s8UPIv 0-66\>bRpOI75 i$u#A zzqޫum} P e\gc20Oi([;@گ$K[}W%((5zւC:)8drxeԯKy%†Hv$099  x ⶂ-1U U\A4xVЯ&H,Z.ZWdAn:Z뫘"=Ԯ ( ( ( ( ( uNdK5P68\X8w)6\#wVR x< IA&n^G!f?2tQ^ʰXL¤lħKaդ nb ag;>7CzG-O2+G-O2+S(*X/m1$O9>5SOls ElRp8c=: _iY^%^ęI'v3]es2U?:h((((+_HU zElWjK{A"0簤ݑp49=zגʱe%ܒ8 I&ٵ;.. 4(,+GAz73Xxfi/}1<Nz 1p1\=G hiM8PI?1I᫖6gOHLj??'oV?3o ?QEQEQEQECs(Fa7!G비xwwsu2Es&iM]ܫ鱀RY]B$ y$[]S,'n㒉02y&"ݿWGsvIDIw*,ר.at!+9vCgTcuw5%=%MrI5E7M,F)~99{Uc!"B"`;VobU$Zq!'Zج}j-lVQEQEQE|BjWO\/އFtQEQEQEQEQEW5|I>W25 }! 0}UI'n"w jYKK5HE̱Zbg) | H:Žteb(W$-ϽaQj|4ܲK9Tl8OBױʦ:][Er'S}ǶS} ( ( e  XTu=/XZJ(((((/f0Y ^An."2ǧ/Wif AOF&5~2jW](us-Ą*(Ƿ>^=,v.g (且7?9_+ea3c~QUM>r"Lֻk+HLj??'+HLj??'8( ( *PYFQ$( $*K;/VݙbG̅ AV ;PG?3o ?`C>oPEPEPEPUߠ؅RǠ5+ @NcssrȚ =ZIϗ \B1JHt 6\omG;>j8-- fZyΨ3rGO9-=N DJ,&ˡ.$,oͿ$7ۦE*"Q? 8^sޛ :jiG)ECn_ks),}W%>a ?YQEQEQEsGz1 D{ѩ]=QEQEQEQE! }VI"Ĥ^I MMzRGAӥeY=O&zpy\q45k\ondheI$/(xL)k\jI X p ;@o ęڣ''ҝ_ÕBU(v-5v̇5A9uӳ?W>F\c>F\QQEQEW=/XZJ*Ut4QEQEQEQEQLA /!Oր<=weK^n&LsU Zon!5f GNrU񮟧DTTy'W.=IS'zn 4Gϱ'?XzG Q~͈"±¤[ ?1Iᭊ?1IFQ@Q@$h6nWr7 6G@Kósa8U`C`L$N2s c(IUu\:p:7 W꒹W؞\ۭXH>N.M!'Zج}j-lS$(((>!ȏ?5+cCRz(((* 1QOXZa~*v*,F~Zxܧnm՛;7}ZԁXp6Y!myiPgl"{#GIfmfLiIǖ9oV?3o ?QEQEVBǟZ?|sb::mmƸ#U$>N=,+͏_c?dgqDqsH Q?@~L"[hK4dؐHh={?mڅT~UkHq??l֚DTX^֟Eg+w (1BO䵱X!'Zؠ(("EI#"pI5e~ew&'*8<j5mYBXS8Nk'kanXEߴꡇ͜y@!ȏ?5+/$𾠋gfltO^:PEPEPEP7 O?J2g|'ZnKEazmfwH.fnDc l%z36!QկCK&#GŽ\f<|kkMӠcsycf=؜}Fgnc@8pqW,Rwk3N=s[\ma0[$d:H(d9jї5X9jї5@Q@2Y3$$h0 ;N'ޟT].Y'k`A؀hK;=F\XAu $ :vⱼe  XTuJ44dh\>I+Gu{ss!^ncJ袊(((oI/u^>Z^Cx* ҭ q*\K }z/jcmr6kh̳0;Tn<{ ;J/nT#w-({Nz ΣN9ZڤQF001Zu춍qgRեdaR\l(dc~Gc~GQ@Q@Q@> υ(Gs[Ճ [w5@Q@Q@ f=Tc2Jaz!~D{WG|b?*QBrsN?4!v2Ze笲J^Kw, f\c1gfqF P:`vR&ªF<8$;c>Ƹ1Y\ݗ/bH# S#F{Z}h9s0)QEc{UkbBO䵱@Q@fEXx$WF, `G8ZuivrB`yIZ&$(%N@tf00:QEsGz1 D{ѩ]=QEQEZS' VkT'S֓. OROXx$.(wuyv'TpiZ|9|lXHwhr:=-`H0~''gk\ݗOIi ~vv-2ڶ#"@*9g>uQTbQEc>F\c>F\Q\|GwxVgusg' @Q@s2U?:k-aQCEPEPEPA (+M4h9oЭOy1n+köhЪ,l }:)vݺmCSx‰|ϸ ~: c$# Hř1OXޝJXw>$nEQ@c~Gc~GQ@Q@&RtOۢQ:ݽ brA9ی`ՍdM"8$rJBČ6$ۍ+gNS c'<3v "nO=3CP:L齜,H? +:kKQ]SQEjpQ@c~Gc~GQ@ޭ&ӼOeuoo`+3*qyWZY-LѫM¨V/ڻ (|-aG;ެg#(*l#jjnfDHK9PR}:T +|4$<&r#Oc+ҭ8aP>U;e%GgDB?#Ux{fT8(֮d$~y@N ( ( (1BO䵱X!'Zؠ( =+s5mdtS: nnkiuZ\C#ɍ̥A㹬Oӭ%eW\2oU '_w@2Q>g(La(M:g;P(9_#J"=Ԯ ( (h !O lV>!O lQEZ4>/MUv2s)ap5q o5נoy#;&<OC]QE`C>oV?3o ?QE+7 Es:#5I8kbKdןj%ߊma#Y#;tU2vFc4&143Jہ`c큁WFB\U"Z| ((((>a ?c{Ukb (9/5鶍}0Vb! !޼IMn /-"Ll=jofa$"!9 /e֖äYD ET%Pqߘ EP1 D{ѩ]=sGzEPYZ|уu4TL5;npHu IN<닭R])P#mZX=+hqLd,d O]E SͱPQEYQEQEQEc>F\c>F\|D6mڮŤLz$A;y;ze5/7X*NujD ;"ǮH(*Ut9Je  XTtEQEQERծRLGuEA,pdR8HVp£eD3k<=a Gڼysyׄ!MJJ -ԯ>0!Vȏi<^~T)(oWXxì/̒(N((}#C ج}#C آ(42i] 1?t7C]14FhCk\Y_Y\i2Z7"YŁs3fE 'Yu8q\j}:5%H,ɍX8*z*=T d&ozU9GqڤӢI2E\ *s1ӵeC>oW)iZx7 =ܼ3irxV$ (\F}+rj:j/} Q<Xfz"EHiHհ_ (0Gj:hsa ?QEs/ :xY y@s'yMdMOYYe[hȍ92A3Pӧ$RTrՋH>+x$- QM^Eq9u`|*Al9/ O|t.b4Վ8ԍ!8cyk 2`#ƑFơQUP0q%[;3eOҹ_#J(&p9r?^tje٥}m I߸qЁk}pmdʗro8%f|Tt;;k-.4I7%;vrO=竱ׇ\:%6ږn~oIVi;QL(((G-O2+G-O2(G%CK19G(Pd XW]Xh#I-Iaz XũXKg9c`NQ9*hzoC)2+9YI/i$vWGTxίb~_3s&>W=/XZJ((.$ԧPF={{Wo^eYMlm#t[K6YY2߭);+Q]2$1;Sa*q=WiY-d9# AӽhV.ju]ZQVsQ@Q@c~Gc~GQ@ΥMsmDڙa(U\,c,>b?1QEQE`C>oV?3o ?QH*=ɠ'󋋛 <²JdgQJWS!=+IY!xql'>ě#-dtKݤQQEYQEQEQEQEc{UkbBO䵱@Q@Q@Q@/އFt|BjWO@!!A$$ZncF!BrA@һklj-fOT!P=3e>v}wI8>xV) eԤ.u$\6PvnP"P `Vq"Ԓ(0((((G-O2+G-O2((({_ G] s2U?:h(dyE-yf >5oLk`^yg, =hf#vZ@8 OGj000*lpw_QEg(QEQEQEV>!O lV>!O lQEQEQX~)ӡ핬I8e7ʭ VV 729P{T gxIHLdooQ v υ(Gs[j#2iWȺVb-^@ 5َl#Al,mXD)]#63MpE¬K-y#{zb07å~\ 5``QTbŠ(AEPEPEPEP>_I+@گ$K[QEQEQE|BjWO\/އFt%,#Q8\ׄlqam2ݳ]NP`#_oǒ4R(oݤOAuZta"ctAQ(*`(((((G-O2+G-O2((({_ G] s2U?:h*{^"&vq ]GIJ<ڌntivW*rݔ&PI甜tن?WWtcFL'$r{IϽjZ:bQ_ *p(((}#C ج}#C آ((ED 8 >(Hkz|A! Q淨+Ě_/h%W͏~'ihVC oy$(QTqU<{)-/LY 5Ғ2T(g c]M" XrNOJt/vQEYQEQEQEQEQEc{UkbBO䵱@Q@Q@OVtkf0@,TR,>𕭍qىA@%m٤a79~BjWO\_I!}B56!'lvkhr[O&G1 tCծ6+x$ ߏSWUS֫1=B(2 ( ( ( ( (1ri.kbri.kb ( (ZldfC;! 0,\FG#4v*U_,lV/.y@ĒV0ʒq$u1 {j֟8mX8i?G;P_EP^g{%Z*  XRH"lE,q^kmRVFݏ,d!O lV>!O lQEQEQE [w5X> υ(Gs[_|DJ첰ALGk'ƞ"x`hmLF?t1ͪ((((((@گ$K[}W%((dq̋$R)GF `=*g6Vi ''ɫP1 D{ѩ]=sGz/#Ρ+m&$DF,B]Es^-@igx31]-Lv5۵ܬQEQQEQEQEQEQEm#`Os[m#`Os[QEQEW=/XZJ*Ut4QEq-eޠ8 cjn{5(i0Ek"\spA'"]Jk+8 n4FskBWuKtTz_O(9B(((( x#xkb x#xhb((uitky!7/=⪅1r'gJIİd,QXW*HSEfC>oV?3o ?֦v4*?'P ͧj7w\M8~Xe.ܣ#lq$NN;V(i[IO@)Q@Q@Q@Q@Q@!'Zج}j-lPEPEPEP1 D{ѩ]mk5Ð$gb}sGzŤky8̈́>1]6h$3Ϻkrm!QQcP*P0=ZIYX}QE ( ( ( ( (1ri.kbri.kb ( ( e  XTu=/XZJ|Aà~T.\d '}kJo'֩Xdy;]\l@c8vRғ(sDᦋ&ĻP,%;$>pBj{T:=ܺtQEQQEQEQEQEV>!O lV>!O lQEQE.֑fPe bR?s3o^~ TI{%IFp1Т9=[G'neMN@efm.Iu3EPm 'I [w4m6ݔ&1tsl)-/G0!#֟EޡEPEPEPEPEPEP>_I+@گ$K[QEQEQE|BjT7F—0li2. ?GzgRi[N1C!-/GQE30((((((G-O2+G-O2((({_ G] s2U?:kҙ5_Z i`lӌ?J맞+[yn'c$.@'[դᣩ]KsO&*%;'Ҧ[mKH/ζ(1 ( ( ( ( ( ?1Iᭊ?1I ( ( (0|A! Q6`X\R v [w4^RmftD[)liK#z(fQEQEQEQEQEQEc{UkbBO䵱@Q@Q@Q@/އFZ4k H}GzkSt3vªd֔4}ES3 ( ( ( ( ( (1ri.kbri.kb ( ( e  XTu=/XZJ}<+P cf'cP$QDE5O9Ux7곎w)A. ;ne8Š(2 ( ( ( ( ( ?1Iᭊ?1I ( ( (0|A! Q6 txJ|A! QF]#9=T@Ɠi nEŠ(((((( }j-lV>_I(((ɤ^ ITƻNX{`Fm#DZ4ӚG/0ݺcM wI ȲE"taF#ҫXivzomcei1Fp2p: _I+@گ$K[QEQEQE^ F[KfQ H \V5륖[Km ڏ0p#+Pj7:1LZ0Į 66 (8'o!gk<ַ;[BY'h.nBJ,v , -;03^]au tsW?[tA%yNg1+|{gy[9xزR  Az@-P>f:0vxs(3~^ڥF-AtޭnxO2ꥑ!呂)fc,!2W m>ٮnu<ĦLw?[l$1<0TE,{+Fomm$/7UCy{j_K4@H{$O(c~Tlg᝹yk[EwmͼHfA$nH#cYZ:[i n3iۀew3~^ߢ0??[Z`V%λrlkwx9/'bj>$ >-[ 8q+|{!gk<ַ;V|G^Gm41:q(I1pxxKү O8-c:@*nW ?wF\nr1m.ݠY33ǩ,պaZp̨FNwmvzbj(G𽎇$&K0E#/2I({(((( ]T{fb%?1ydq1ZtQ@wϸ"!ɂ)\Jͷ>gO^ k7mFTvwg+ OıFP (JlOMWra H.VY.^2`ː1q[9M,kY%Y?~b*c݅Q~3sh(}"-fѭxtx0)w>V̿z7[>8;r>_~OҴ;}"Ifti "8бD\ܜ~+N(((+3J$xeMѤ*$ BQp{rr}:( {CsI_dDsǥjQ@Ϳ?}]n2;=N1[6qi}"x(?AS@Q@AgM$%KK0'&PB~_M]~!G\evvCN1[PEPEPEPEPEPEPEPEPEPEP/+-WJtYT&EB˂%r )[s|DD%B cgO9=]׃]6&Jkƪ-iV$6v(((((((((u_>?~7nf|6}ckQ@lsEdB9FqTx7i⸞I"6hBοin[h*Oʭ7lϸ%lr>}`:$|hxq@Bl^@J|߷8RvkEqmG)$M$QIS# ydLBoAKE'(-û+)7_7|ނOS#/N%2/IQz Z(>oAX"e[kFU6P??OG>.{ΏՙAf;E=X u=N5ZY%FIms$+HSruBG2 uXܚ|$h2:}ۏE`  u's]*)ls97sG>ԴS]U#A -]idg) _I4|l)_ꗶX~i>9ONHD>9HVrbY"|g*Iinz(p~=ō:;J%;,/<甇zz7NM5t'(-'(-ݎtP?h>oAG)h7#;J)j|ނR@ z >oAKE1lnJw(JZOQz Z(9(((((((((($p(jg ss e?+*򞄞1ֹO Z]&ah>Y$L 2EXc\p@;=bhg{x>i#8`=bzgޡ$tgVm.xR;NkRf>f>~A֗sp~t~Җ?:7?O?:7?O?:leviO;/4]cjXH?2Y٤#'S_dJJ\G!طE< kK8,m$I,O%I'O&N)Զmv0 ^I$m+ǹ>c'Na2}?ZLiԝ>>->>->#iԍ@]}k%Aq3{WAO\%Z&1gxGa(GGp1 8/ ܇HG #Q8)"7zp/4]^$f>X\}NC:Ȋ*rNM5t&>C#V|}9z~'7?FP7?FPD'cNj7?FP7?FPlϰ.K@ @2G#((((((((((/0&w;Km Cl>cl6b*b_ٴ{;kylݒx-$𮋖,~\y9uK&f$ylTv=D^dV;Z-ai]GQQE????-????-NW=})??-&OOFOOKE&OOFOOKE5ja$82|G?Ӥ ~Yn{UCbn/EԺUhKJ<1#5P@VVcRBEpDE `)4WA&}4PgўzZN 3ihϱ>ƖLF}=i?? ?Ζ2J2JZ(2J2JZ(2O)}=??4_LҌҖLҌҖcSڝPq????-1EPEPEPEPEPEPEPEPEPEP'X<-mujҬ2m ux:Pp%\jg:<$`uX'TWԫ #3V+afHfrtPX/4e2Īv6O`N?#Ut/t;VYIS8$jQVآ@' /=4yѿOFM`õ+u&zR<ɣ|}0z7kw$Ԯe+i7C:ԌOq<&6&Sy[oTN/O8ii [ۦӠI=I$IvVIx/&/K S=B( P*oV՘JDCmo[FB 0KKElb&E"})ԋGҀ 2)hȣ"L23KIFE-dR@ HcF"Z(2(ȥ"Z("Җ*5hOa! "~WK|A%4z %d3z1ZB)\j8G,k$n2 PiּۗIs&>IɆ<< }l[9𺞏i҄sl8Ӓ7U"WS/r|5<ѭ mopMPmhEfh?rѹ}ihܾn_ZZ(˱Nܾ?o-&r@9QEQEQEQEQEQEQEQEQEQEQEV6R\l.WPnb@="5D"9)6  IwkSPGšN$G}خCcO?!1JzV>;|-bO A?ShEƟ)5ZwZߕ ?+{g=y?$:/4 O ?%?ƽc+N _IdZߕ =w< A?Sk?+eik~W(ϰ{Ht_ iG$:/4 OXӿQυ_>Ws!1J#xE^υ_𦶓bG}خCcO?!1JzV>;|-bO A?ShEƟ)5ZwZߕ ?+{g=y?$:/4 O׬eik~W(ӿQ`+/4 O׫+N<-/V>l]'EƟ)4CcO;|-ZwZߕ =w< A?Sk?+eik~W(ϰ{VFm<nSγfKSKk ?υ_־+u甯5?PO:_{\BOOӿQυ_sWF\Ҍ}]e ?Eur?]sl{?JNG-/V>¥RLIl5*R.ܩRFqwOHG5TQ0;h( EPEPEPEPEPEPEPEPEPEPEPEPEPEPEp?Z( ( (c$zPH*-QEQER)M-QEQESA>c uQEQERȥ((k#:uQEQEQH*-Q@Q@$2uQHE-SI!v9QEQH*-SI>`M: (=) PE7'#3@(((O~TR|ޣ-#tQG?*knuR|ޣ-7G@ Hq|ޣ@_>ݴr:zRޣ7hGG?*-1wc{{ӾoQPIzʏ~TR|ޣ4n[voQPIzʏ~TR|ޣ Ziݸr?* >Ǐ{LcnޝylQIzʏ~T3¨>XjVڔn! sgK*NbۇBwz^6Kh5fqOOݳ;{oQPIzʏ~TR|ޣ-"}Qzʚ/#>O~T|ޣET,ז$4iT ($O[7Bo$@8m'_>lݧ?vEPEPEQ#( \iF0QԞ5umU= n<zӢz9Xl jQE}E-#tQ@ EPPw)l,2~2D"Ӱ9چq2+ (2rh?oE5̑=REKHq~>OzEJzE@ L}3[hQEQEfj\ChC2C#dmldg66.krۚ4(AEP4,5i66 *>M]19(SyQq*<>gh^IHP|T_ʟE3ʏQGP<#D^%#P(zzRQq*ryQq*<>=ԐU mP2I FsbQñXdH?ʭMG*+ 2#Qi kh0@(>R>fBdF}bAp9<՚gʏRU 3[':!ʂ &hbrpxCNfcAQU%d;xTn4K-b>q4gY+Copqԓ$IRiz"؎EX_?d#Ѯ$'(sS\vԎbHU;ʏW5x}. Omf p,2p9?&jڎ&e30&F 3:֞ɯ+oQ?屆%\*d O8L{َ0 (Ցk.ynkîm%-=u"{829atRVinbOMsBF$@uqn1+Ehsḯc wj;Up}~UHu3[cs

?{Kgh4d]zcU*?/YFЅ͗a8m^k:JISCS(J;I=Uu;m2 l'sc'}:[jQ,w*#n]Tӵ@Z Mw [1M~Vooѷv7cץGg/,qTϯj}ɏ3hݏLT_ʟE3ʏR,Q":VڴZ{E#3AqZI@ TyQq*}(*7ougUk2x`* dS>"In+ikG}VeDQ2u`A}bqz~?|@t͍;U zEs}=WO Fqǧ^hs 6_J8cn } Kd'$0|YޱoRy 9$n֮۟KN_8;zqc8n:%>oj/b|TIDEA?7apyҫ|R_\Ϣ:٦"Fm:vҢR'em bUE X$1 k@`.0i^!|A4%ϳaNA'oϯnt=.Dsr]p =Ƨae+U}}MUĺrFFΪ2Z~uv(2}z:$g6L%ʺ1I Gxsau`: Om__iZ = yURIuf=qT{+|M/+Yh'+ve' O}ӿjѿZd :2gtGZ6kvQC~wC,-t?f.nOtp>@@;Jky}bέ*vO,3ð+^xݥ[XJ6dŸ195_-T629P)_(Ȗf=q|E]a]^ h6?*W"&g s=?i|"N4lW+*y/txRB[]g ctr`d䌕_[^(IX;hgI]sth:2F+Maw" /IN@'nfzm@ha`PjTˣw +G Պ 9kޝ ovDg#BC+RA]=L&qϭfZ=Ҵ Qq"3U>#EPLhE*}R'_-Q@Q@O^-bV^-bWM^g%۶8pG!A؊<)5k94Aj8Y0&SfQсUYn`ڍ&A?#FHs-N|S?ߋulOj.eHgtb~5un>(OJZD)>/JS/JZg?@(((饢'''87AdtdtPdtdtPdt'c|>}(==rJ-&OOFOOKPCg< .OOUutdu1j]" 6ykk,N]0QmxE|xYY$?f@H/kS,[K-p G aPBUGű, b*dyTnsǭfxS%}Md+匶ֵv_h;hG-t{S/=zn۟SH YM|T'5?RŜ\HX+0~Xqnyc 1H S`p:<},U#5 ;H-vYsz>b)`-u1_/2[v5 B/[ZYQdYU&$h=E7hnՂ|Mm[di RW I$=QZqvsr1$@$#?Nޏ&5NOZA*M\psul&ԭl%\sjĬxջtgk?c{޻܃e:w!xc+x~"GsDq%1LR-o7󖸆-;%9@)RѹػxB%PeW87qqj7v~g[$$B=NzN[P-[ӠTnβ(3ej*F̶|?G5.э8o(%p{||IswxhaQHF6Y_N:MkmJF=*s9}91[TO-t~#lg WslxkYuBtF8dhݴvf=\.zgw[z|ұ,Sd6a1PHQ}),u1&k.qr1ozYubPfͪA,y{hx>ⴔD''Ӧ(>" Bc[zk]4~&}ZjdVPJ6I"o+T+ON񎩣2E&d #i'? AKr7G;=V;>;i$NׯZ+{4{c >b+anSM!~q f+u1?NzsJGP_dt'_-Add4|O)ptJ}4҅'hOOjqi??3'?)%3[hQEQEQEQEQE}E-#tQ@ EPTK[buʑqWjki, rg(#R?o GҖ~R3*)f ($ZK.7<j|9ʃW5_[]4tr~y+g"<7쾵pf;%-EڷK٥zѵ]3O 9HmI8hOt~rCb(o2}4*ž):ȣ`A.Aʧ g<CwWzna7MiU<yC~7ziQe յymYa#'cNqq>*jk GT](N1W)!Ȏ[I;zeEU8.u`jw*g3w޽F(!%F˕bN@ϿoƲ]Slvgc,Mxdd p?\zB)o??秠f}&kk[כtKiEPQ\p1eƟxծn۸T04q |Eɵ3-b6%H #= =zW) ߋ%l FYy˵v.JzrAފJԭ4DM<*P7v,pf%]G\0qVs j8nF,3I< 1ֳi*k}͔r5o/m-2LqI> Ekۆϗ s=dV6̒<eD0L%t@?0'VBOju͇Q}J}#tQMߥ#!nҀ2]N[6`uI=HlS6F(S6F(;i腕sYOPͭ++\Y5 XlY,#ϷzFK1mJc~|b>ll-_o/mgi v#AOrOrO$%MJ^ @m jw 4ZP-28vu⩭颻,q Y1H:AVm{r[OEMiMui{p LIqf8'?*0ڵ6r^[PB$y8'zĺivi%AǯNyZ:w4:}҃@$?1ZSӖv;uyr|̥ ½վ;13bZ[oA3~XW8,J @מƢ5q.&-.g!Hrw`csJMVLPXKg1=x۫:/Ev//ܶD ;i;Y62!QI<ZlVchٕTsi>?Ǩ V/ @l.%h@ ;A7lLO?d ';F;3ꧧZm|,*\]x˒"SG'Q}#K?.֖L-";XfIڿ=jٯnaDP0A#Yk}m"^DVOpl H~zi|%_}(P}5~z_åסk7zn|7xb,&vm'%w'`u-q-6evy}JU:dees*s˸BED$LE3a~l?oҰ,5;\[˫K$ex ~Q5 B/ǩqqG^&b2y(ڸ$޳QOZ}3[h~tݟ?;}Z( _3h֖W+n&1eY9vYU=//}}{x[k/!*zeJXrACđtYK7 #.#aЀ{W1੬Zu `dTU H(((*b{S#PLrF/6T3-R4t({nfr2ONv@r*OOɳq622FGz!DYi!B>})۲6ukmdjC*v,*74z*\ܚ.څ(RuB v99b?kKL^GP) RR8ʫcn#N֐S?~ד#Gz[uS/o5u F .&9 68Uɮ#ETy[M2e Cqq"|YoK=,@iEpGN0s# ERiVreHѡ1LO!z=.R~?u;z20lo D8;c'1jвt{Qwcig?}pu^{`$*8CS֣2GrJ[Zpu#qׅ"okWhʆ7@$ G5oo7&tx0 0O'kmkYvwB;P1.?ҼCV{Q.T#3|uԞ1{ſkY$Wb^H8NLqE_&zluzjV'sr;p=N;fYӮnn7[䌖3G#:tӧ[8Fh&bURT8ʃz5yy}xmbL ARZ_}+y v|Ԥ[dGLJxZțYmzh=%$Nn铁Ʒ|/Y+]MJWaw VG F{>aN=k?_P4 I,uԦrP051Ҝč(MGIr:Ȭ*cP$( Gjf+MzL UrOO(YupFǠlp:ѡ!u 7|͒/Җ>(h(~"In+"In+h'5o(P+S ?xR(hARҖҖ*Kcgq5܀z0<:0"`*8DEet5"Q{n㸶9w$ea_lݯ'wZAu@ͺk8׏fB֭u>=B:!b#q\҃LfETfx<ϲo;͇vqηL4$VUd I׎ApN+t-Z[pV$ M/.pn4>+iL~QdB@QEQIzI}EP7An_QMf\GQ@:4-,aj/$kdΣ%5HfHLG-3@ (".R1B1:U(u?6;d4/OzmaLGԛ{Me!n`@ՅtQ1Bƪ"Ub^/_v۱h:΅\jo%;` >HX\~ F_qv>Ʈirz߷skϩ]e'³ᏚFOpk']Qhۉ|;˩۷j07:{vV\iz{,w,p:c9b=;笠м])l99ޙt!_g_} 'Gy 9<:`t9 =ۣH~\h|]oN?dZCv)>^ÎkA+5ئYK6xŷfC`?jh4c8&8z5&l-G>d 8 4Vs_憡[=kA[@R,4n(qn$s8薷p[ JLB8K|eo㞢*QWw|md _TW lFxCusZhiRD"LbI9QVǠkzD=KfvzoOljE"ҷk 3!f]umcXfp##} a'*W}ϲk2XX uNg?.~TEq端!Y"p 9vsq8WZkmU3Lnsry8tw_r4I|=k6ɉث *'Oj-Pi\is:?Wl5fCon!i&bB|ĶOCА:] 2$NcOFo﷿Awg/~_ &2M*4z\l8atfuxI}EVs6DJWvyg5dd%zF*ǥA$i#I>H8U(ܾcdtF:Ο}E-Q}E-Q}E-"}Q}E5Yv/#>M(ܾ~"In+"'o%Lվ!h+S!idR7 udP: Z@FRr7.E/jJL{-m{R(Pe$$I Ԛo OԵo 0,=AdhK-ƥre$l**J4GE(5%+`(((("GV>`eج(!o,6r?x0o<9p?>⫧gE'd&gz4ʩ o(/}۽m] 9t$d*.)Q E<qYZ&'R[//;.UkM|1.s 1JLr: vێqXqK6S㼾LE8]8 /~ꓜ'^qmk?j-&υE鏙ǜ{ DsKgfq qLc]6[7"0]v[IBrA NJkGpy6¤qy~0 I%ddc z;W9m  _)._=BYm h`0qy\ֱZMڍ,"ͷpy9 оա%$w;@(\sۿGqowZbT.p zqYҿ}VIk[hٷ>i'._.=)y(]7/?4S/5TBvyPۏOLo xBSH2M"n 9|T&!,,a67-䀸Yӧ&fJKt˚^c=Ci~󌩕7)^Kn{q] W2I4%@p-zs^kA4n׆xuEeKԁ{\jDL#epsd'q]tꕿko Af=Ao8!@˟BOρ Hӵ`2oUcjAŽ9#1^D 2ƆYX Y;ۓ+M[FQHhu)F8Xc kVM_י4WsMw PnG[tJgN;M|@ygsZ 0ȒYv1L|:|iN 9$^KKB!445}_S8f'$SؒƜVӭua!el5[FG%#t] k1 g}?*-'E %g[+*J2F6|ZsORo%VV7&hLPIeyq#냁GcN:i /DIokw,vK1$:`N !{dVI y*HS=+|w_MǃLGN: zlB {5\2JIWCԖ'CT$OP=##?k)IݔZ"TԯM7pPi4.{ pI81Ve9hE6eaG2;;3V|xHhn)ceP@pK@ ~#}:}QEQEP^Aal1XI㠦%ޞ6Hlr1@hPV">(S>ZtQEE 7V%mE 7V%tNjP(VAH~?xPE-'-'Ak}&MEV܎2WcQm #KbexU 4lO'6DZ?oO\]LwK;z 0`+]~W490-3[ilݬEQEQEQEQER7AOVmGN%2GЅ7T*I96|l,̈d8"w't7Qeyr ,q ; Չm:+c6ȷ @-w I_o:Vw/ {'⶟?!jY mbLDg h-z2=rERgOO&FTQ?8is1kf20^^7[ks46ш$+9PSZuzDNj4$|&..]O'i+<*R[P70?OjxHi|z*z[-" B6=֋VW #kOjv- ә > C7^{mz-^km>;[ ?-nEs<@ܸ;zkK]+8m&as27 8'ҦnRN+We|obKHn}WU)fX%bXvO=9XA}_)ceH˄W7`Vu:[Fi:̲n8^3=xyKlvdh4t$}6o䃚ɐx{E4YK/2# nq/4]OOp|õMZ)LcVY&ayѾqo=WW>1/v6_Fd^kX7~Vvhм::Cpv;? &]Ln0ӭ$gۓV' k֦ZtVmg'W9Uo1_RSխmoLn"iᄃߌ Ԍӿ}URX DFAPIlL)th-5#ۭo2I:rz^/2Y$$2w} v+O^^ZR]K⹸{f$G K K}w arbT8y2s0zg otJt(Hm(D,9Sֻ-;Nmf&rP+Tqzk/zܵ a,]H!Gϖqa֤C_3Ms|$#ջֱXP{{Bwyi Rg>v#JUQ8g_=}jyU=gܶ؁<9so_ >?_Zu h,O\(9SXj6O%l#m`fR"Kb+iMŬ34ma xtjZ^5FBgzԌ׎h$PH0##Kop+Bxqf/JJ$y XF Y`ӄFU bNx$)FG"/U" "}*͸O~$0Z\MQր'G ?> ( (!ݠMQ~%6 *zD((_o%J_o%Jվ Q@LKH~(AKP\(f8=ϵ^|-}RaEe'?Ǿކe5ʌ)izuߋVrLAHO_2yzM66om H`=i$Pč*`: e''vuF**CHt})OCHt}*J-g?袊(CѣK6A :$amWQe 0="0G6x<Dw>Uc;(c~&O6E3iP?yW66˷d(\U3xNc=feq0rO\1iJ*RI'dSR:~bo[/rB֑Ӭ^ g k {[WŮ,BǍιqiQ>i(ܖ>Rθe'ϿOLiV }|]?1`q|]XXn^$iF99:X^ ? \:u _i󸞗kz]ΑD< >ߙwY:է$+vĢm TM#T~ȗ/l$* :r;= n%>~`)l+'s=y jWwu&4O,w./ gwn><#CmyԑFX1U rI87:*\Eǝ1?{>}ol7^c<}gjAh7|oVQk`gF`OLqjiºRJ|IWh>IWCoz̩-[HڳEs- ?Vۦ=ZF$xFrsn}tRF_) VERu+.*<1纫g:qTug!vICJ33眒n˥wiq(i!!m6[> 8r^U,$xM?mL}bp>V 8kKmVqrukHy!ii67?d\,ēDw~^/cwgajזB (_.KbbI=yz4Rue$f| aGW/kaA猖iV3ٛ=ѴFbqwHĀ2OcjW3cu螺z<LpD ۏA^&uH١&4=}AwotXvw| =v0$_hGsޣCJv!ٿ`7+ hs}'VFyx9 6{?ֿZ}bY͎z4Q"C*G?AZN"tY%3`ǰ/70ڎs+㑜[QgխoRcv'9;}  4(t{ ԍ#n6P2Oֶ?y8K@ ?t]j]]fDu$ȭ@1o?٪5XcY=2c=1Ң+G٭"(%TQpy}:}3iP?yfE3/}ޕ%"}PyfE 9}h8ἕtqX7s/_ Q+sVGH7zʝ@LGHwnʝT";Kyou c/L@x`{ J;k'5LZܠ;^RR33EtZgZljK@Op88R4UT`;XJƏm6x 鿴5'0$z1'TV";ibOU?SIT3hzzSCHt}(*oW;}*Zg?袊(((pqֱ((L9ЃQm#xe6حi3Q2~#յHC9iu<|{gx>s"48+<)<.4(U3c~pxq=={[O [ q4Uٕu 2:dwOދWX%LuFOZ(ȬrWPϱZJuvv[Nf8 upsV|m#N[ZEVw7?{}>k fSIil6fe F`c8-=Fz4/52_HE{un ck)?+.g=kzŵXFCFt{iKx}n'/pax\5gkuXUA9PX>Nsi7+bu]Ѧ%֕/UY"1,@9z T+]>]]'*ލq=}Ҍ Ә8Qީj!r8 1s^NHuXc< 8On6mێy3NKZ#/9=Fg=kR X\¬ZWas+AAҗBԡL)Rs{V2Yk/jrY#̂3~jckAV cP< o; tXZrئ^qy-ξЏ%[8<.fz%ӵ=J$3˃Enn;Vdod$ ec#ОXBQ--/cM&|dk?ko[X[:HŕPՕ~cn񫵑kSzczc<ֽg)9;i%QLh=p^۾|<`ZAiAqnth>Oڵ (KH~((I?>?> ( ( DOJZ( (8|5aF[ĭ|5aF[Į? [ 6IIR4:jM>- ux%O))-=#}7rԈWӭu4;lϩU#:;{z;,!!ifo;IAZV[ooC J#B+Oƹe7-ΨGaQEIB'_-"}Ra\??ҟ@i)i-3[ilݠEQEQEQE&Rm_AFZN  !8#r۠ v\kkDK t5aaCwq؛uzI 'H7" 'NmKR[,a=)oJkrҳHts7z 2@KTc''Uړٵw/y7Uz֑鶰[erKw<~WNDa<.D (&@?ښi-߻_$_3VU jdOFLw ZV-Qͦ{OV{{~}6(ex.\I&p~`C*֕<YPdPnsu'zE[<?Zθס#]YnOmCmג8UvJgϵ?Ls˞?{+iw*c^֣^r? nc֦bKVElV$.21O>+ִy6``qab) Q/OEԂ켓 ABvl!T/l9yieGr8Tnmgg pp?ZDTna<z?>nuU水KmLmr99r@m_A@ E&m_A@ ;we0*;;(,-U'I$j 6֟Q_5_A@ E&m_A@ E&m_A@–Uw.Rm_AFRm_AF>?>WgA:~Rm_AFRm_AFFUؼ)6j Z(('/_ Q d   7ous<ͮ ׬R2\BǵtSvg=Ey_΁ Tɪ 6ͥ/;_njW/Oc(XUU:(U\}%''vob~4SWOwHdRl_ʍPq~Uؿ(Nؿ4Oʯ>QOo?bt~T_>W |:-S6~Q}(J( ( ( ( B2= -cL}?ZjH,2?(vzUi:峎s\n(# <T,q+[d %[GZ 0 AQoB+xR(P@EUt3I Q"X5b}(_> ښ $ހ~@Q@Q@Zΐuh,e$-GEiĞ\IIڠd8^uOVN{h|F]rq@he֝ PS0;w88=29ǽ[(֟L_?> ( (KH~((I?>?> ( ( DOJZ( (8|5aF[> m=mZ P~o7U?wOtkhouZ\`~'xL/t0rmm&?`ƪ퉷sJz~&z~&i?}1'@(/Җ>)hptJ}0O4GҔ4GҀ-g?袊((}Zkսᄍ HՃ s9#P3ЂI=(^=N/"T7HGQI],G~(b'xgܲ2U##\T)oҍy@n)oґ7Q@QL~o?ͿJ}yF<?o7ymR37Ojz7Oj]y@6(~)oҍy@^tnҗymPo?ͿJ7ߥ>f?>ϸG;ymPo?ͿJ7ߥ>f?>'GEPEPHq~@ EPEP=m*SJjs6C*rºc@"M-"M-1'O7hQE"}R'_-0O)~R~P?vL}Q@Q@Q@Q@Q@f(((# Zeʹk~XZ-h}N kI(aWr# R ?x::01EqFo0Fd'OK F>@GP方{Պ_rF2.~!f 0@U^rI 5kxaV_-;vT4EPEPA((oγC,!e#($G]Atؒ6yD\ KYs@*( QE#0Q SMFي:SsUu=6-N8RQ.@G\5 kq>ޔEPEPEPEPEPEPEPEPEPEPEPEPEPEP-˭2|&'lc#rxñ;^M +g3#mBaFBGVPu TH;smʦxG6H7yt.&xXYAۺ=͸0+^8HDg)܉frb@dm#V֑o;SX! $XT^.W؋hL,eܨɵ2ʎk/EVOw V5ntcKQ`d軎ĀHcV)BC$8'MT^5Y۪d\ۤDDaw6X Zܰ{>{O,JAwdp3qV( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (?mets/vignettes/marginal-cox.ltx0000644000176200001440000003164613623061405016356 0ustar liggesusers%\VignetteIndexEntry{Marginal Cox} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Marginal modelling of clustered survival data} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Marginal modelling of clustered survival data}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Overview} \label{sec:org4291342} A basic component for our modelling is that all these models are build around marginals that on Cox form. The marginal Cox model can be fitted efficiently in the mets package. The basic models assumes that each subject has a marginal on Cox-form \[ \lambda_{s(k,i)}(t) \exp( X_{ki}^T \beta). \] where \(s(k,i)\) gives the strata for the subject. We here discuss the \begin{itemize} \item robust standard errors of \begin{itemize} \item regression parameters \item baseline \end{itemize} \item cumulative residuals score test \end{itemize} First we generate some data from the Clayton-Oakes model, with \(5\) members in each cluster and a variance parameter at \(2\) \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) set.seed(1000) # to control output in simulatins for p-values below. n <- 1000 k <- 5 theta <- 2 data <- simClaytonOakes(n,k,theta,0.3,3) head(data) \end{lstlisting} \begin{verbatim} Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.6.3 mets version 1.2.4 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined time status x cluster mintime lefttime truncated 1 0.1406317 1 0 1 0.1406317 0 0 2 0.4593768 1 0 1 0.1406317 0 0 3 1.0952678 1 0 1 0.1406317 0 0 4 0.2057554 1 1 1 0.1406317 0 0 5 0.6776620 1 0 1 0.1406317 0 0 6 1.6093755 1 0 2 0.1092390 0 0 \end{verbatim} Now fitting the and producing robust standard errors for both regression parameters and baseline. Note that \begin{align} \hat A_s(t) - A_s(t) & = \sum_k \sum_i \int_0^t 1/S_{s} dM_{ki}^s - P^s(t) \beta_k \end{align} with \(P^s(t)\) a derivative wrt to \(\beta\), and \begin{align} \hat \beta - \beta & = \sum_k ( \sum_i \int_0^\tau (Z_{ik} - E_{s}) dM_{ik}^s ) \end{align} with \begin{align} M_{ki}(t) & = N_{ki}(t) - \int_0^t Y_{ki}(s) \exp( Z_{ki} \beta) d \Lambda_{s(ki)}(t) \end{align} the basic 0-mean processes, that are martingales in the iid setting. The variance of the baseline of strata s is \begin{align} \sum_{k} ( \sum_i \int_0^t 1/S_{0s(ki)} d\hat M_{ki}^s )^2 \end{align} that can be computed using the particular structure \begin{align} d \hat M_{ik}(t) & = dN_{ik}(t) - 1/S_{0s(i,k)} \exp(Z_{ik} \beta) dN_{s.}(t) \end{align} This robust variance of the baseline and the iid decomposition for \(\beta\) is computed in mets as: \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} out <- phreg(Surv(time,status)~x+cluster(cluster),data=data) summary(out) # robust standard errors attached to output rob <- robust.phreg(out) # making iid decomposition of regression parameters betaiid <- iid(out) head(betaiid) # robust standard errors crossprod(betaiid)^.5 # same as \end{lstlisting} \begin{verbatim} n events 5000 4854 1000 clusters Estimate S.E. dU^-1/2 P-value x 0.287859 0.028177 0.028897 0 [,1] 1 -3.461601e-04 2 -1.449189e-03 3 -3.898156e-05 4 4.215605e-04 5 3.425390e-04 6 -7.706668e-05 [,1] [1,] 0.02817714 \end{verbatim} Looking at the plot with robust standard errors \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{robcox1.jpg} \end{center} \captionof{figure}{Baseline with robust standard errors.} \label{fig:robcox1} \end{marginfigure} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=robcox1,caption= ,captionpos=b} \begin{lstlisting} bplot(rob,se=TRUE,robust=TRUE) \end{lstlisting} One can also make survival prediction with robust standard errors using the phreg. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} pp <- predict(out,data[1:20,],se=TRUE,robust=TRUE) \end{lstlisting} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=robcox2,caption= ,captionpos=b} \begin{lstlisting} plot(pp,se=TRUE,whichx=1:10) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{robcox2.jpg} \end{center} \captionof{figure}{Survival predictions with robust standard errors for Cox model} \label{fig:robcox2} \end{marginfigure} Finally, just to check that we can recover the model we also estimate the dependence parameter \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tt <- twostageMLE(out,data=data) summary(tt) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 0.5316753 0.03497789 15.20032 0 0.2100093 0.0109146 $type NULL attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \subsection*{Goodness of fit} \label{sec:orgb08000a} The observed score process is given by \begin{align} U(t,\hat \beta) & = \sum_k \sum_i \int_0^t (Z_{ki} - \hat E_s ) d \hat M_{ki}^s \end{align} where \(s\) is strata, this has as iid decomposition as \begin{align} \hat U(t) = \sum_k \sum_i \int_0^t (Z_{ki} - E_s) dM_{ki}^s - \sum_k I_t \beta_k \end{align} where \(\beta_k\) is the iid decomposition of the score process for the true \(\beta\) \begin{align} \beta_k & = \sum_i \int_0^t (Z_{ki} - E_s ) d M_{ki}^s \end{align} and \(I_t\) is the derivative of the total score with respect to \(\beta\). This observed score can be resampled given it is on iid form in terms of clusters. Now using the cumulative score process for checking proportional hazards \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} gout <- gof(out) gout \end{lstlisting} \begin{verbatim} Cumulative score process test for Proportionality: Sup|U(t)| pval x 30.24353 0.401 \end{verbatim} The p-value reflects wheter the observed score process is consistent with the model. \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{robgofcox1.jpg} \end{center} \captionof{figure}{Goodness of fit for clustered Cox model.} \label{fig:robcgofox1} \end{marginfigure} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=robgofcox1,caption= ,captionpos=b} \begin{lstlisting} plot(gout) \end{lstlisting} \subsection*{Cluster stratified Cox models} \label{sec:orgf70f1c5} For clustered data it is possible to estimate the regression coefficient within clusters by using Cox's partial likelihood stratified on clusters. Note, here that the data is generated with a different subject specific structure, so we will not recover the \(\beta\) at 0.3 and the model will not be a proportional Cox model, we we would also expect to reject "proportionality" with the gof-test. The model can be thought of as \[ \lambda_k(t) \exp( X_{ki}^T \beta) \] where \(\lambda_k(t)\) is some cluster specific baseline. The regression coefficient \(\beta\) can be estimated by using the partial likelihood for clusters. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} out <- phreg(Surv(time,status)~x+strata(cluster),data=data) summary(out) \end{lstlisting} \begin{verbatim} n events 5000 4854 Estimate S.E. dU^-1/2 P-value x 0.406307 0.032925 0.039226 0 \end{verbatim} The cumulative score processes can still be used to validate the model \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} gg <- gof (out) summary(gg) \end{lstlisting} \begin{verbatim} Cumulative score process test for Proportionality: Sup|U(t)| pval x 27.55616 0.195 \end{verbatim} \end{document}mets/vignettes/rec4Bi.jpg0000644000176200001440000007114513623061405015054 0ustar liggesusersJFIFC    $.' ",#(7),01444'9=82<.342C  2!!22222222222222222222222222222222222222222222222222&" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (9|_m[t"KPw9m+SWӣ*9e)"tub;A[o u-t.m j.gr;[ s@lD6suFcD.XK,sݏ^ER41/;Fqα[[+O[Em-i$ؘi'g: W+v6N_Ygks"qm5Բ'͜]'Yx-]CFMgOWRUGb3@m<]gyh ^:(yc]TThq3H.n#PS.0V*s+܎i xnPQi'lmmx,TfKegQܽ]YjG wnF$S2@tVJ"Ii bPcӎ-qvF&[! A}akO  (~.5.G>[bASc_˪߻_3@VG5 5xsϙX.HW'%PrG&6 $OcL_rx[J6EtpU!\6`p?p@-)&Ɛ0rx'#)V(3ğ+j7j{EUCğ+j7j{ET%Q@Q@Q@Q@Q@`5x[[Ճ?omM>M_TX{;9gdeB@8 #ֲ|Uqy>nE 3ZjB$ zZO}K7nԮqgEfjVmInYƪ~ ; IΐIT ǰ\.yXCغm7nBs hǾNH8m\:&}n9Wl{Miዸ-̺U6"X9k.C\*pdu3|vn\[[E}b2Y 7qS<[wL0x-OGKhnV+*Uʞz+}N$e˟Ҁ15ȼGci C4`"@fvU " ̶vz5ڝ(cnW˦2V_In..c2Hv6 7n^FZq}X݅(r60uWӿ$Z+-02=zӦogͬ wA& '#zη/Enn6hP,@m,C`u8Fm}C6%jj7 F11#=s\v6ؤ7NF $ VgmY[j2(ɮm ZƑOw6at2 t[UL 91rԿi.+brԿi.+b ( ( ( ( ( ( *e8cP8UOI7KWM/n `}X $V ֈ>Ν\͝m@qjO CrcpgJ17#ڀ+tNMq4{"m;eFX! X}W_r H|!HB(mG>ܒMI?ZPJx[Ѻh:ZU`8j((((((( ȭהUȭהPQEQEQEQEQE?ooV#W륿 9 |OZ);%OqSQIN u#Y3NQ'Eq?2OCS:_5)|kM GzƱ6iR,wkF1!X}cvڌBV.p0=eî0k#ai[بV 9a JT `Vm6PA师Qz: ͼMai{d@r(A#$c Zƣ;b(ùǯ@vI 7p#,k =΀u#VhK}uWs:>rú&pn4OS%FP8KO񮌤k,14/u}_ .w˥\ &c^J |R2px tu?oh.Ο`0&cl0o / ׅ Ʌ < &:9L/p {>.Lmm6$`֮T I.Z]C(%y- {=I06"1\*6~=9'09;'.?[W;o4<=wyg93ڛy{})*g\i}>S}8|qxCuu--ݰqep4r"Q9 t.w.{z,^Ii}[k}k`dXA*B0ZN/m`fXv)g8rs IkZw2CK("[DmPqP0IV$jwPxIftL `P AJc_p̓'GUwՈ9‰9ꧡ^`#3He$<vP{[KI4].#%v化р'qoږjav"cH\*$g!5\ k3]4knL wgck KZ5DI2K,Zq\0u$'G=xyh~מWwuEcJWUٗ)Ɓ>r&f9g!=˷kIo3Zm21jLm5I\ywFF Z&X6wᩦ?/\̋{gc -qz 3ƝcGAqo"v6Z2dB,o DfE==> M6ݮ(:{h׼A,oĚ{o;1 ,V$y@z(__Y%Fv~Eb5lہ,W=@`)hڶO#]7IΣތ:]+eY_#;qxP5Mr leF->=ɑ@KY 8ۯcgZ)>Y4xVDh̦ >^02<kt&RZ@ɰdE,qU4[1Nr1pyn'5Fw./QF|*7Ѐ#ok뛷sk:ksHXnb(F*YFpT89zEi>i$!P$.p}(е?k'OmO\]NEg*39' N0vWQկ?{dO!s'tF9۟u֞.[KԆymC<.Cn*pMeOxz] ϹXὝ7@$sd6: KMN 4jזprFUL7 N$cB 6[5Hqnսyv,B3=qڬ:Ya}GIoj.CLEg*39' N>\X죵HycCp) [1rԿi.+brԿi.+b ( ( yM?OJ7Bҏn5`61_asx3[ͺp]@8ްn;3:RYnYT'WE}N}šlvr RʄpAGeX}ݠf!9& c9HX6"uTfFczW1uiT~XMl8?Ŏ;yy?λ9Yx2:*=+%׃5cS-\Na )jW:Mn~`Dp!m@#[ |Qy1sbRBT.sCsw֙V~Pq,+$eF0>W^t6ڵՑ ձ((zH}GB8#̟jPOy<"Ye'@ zɢ[\h2jZZue-0Mo3{,Xt/HZGԚHVPXˈ-w`>p3ӚăZeo6tP36 ,A31ռ I[/5@Y.q,E#G&*H#yy:J)XHFVE'\O:eյis ʸ*VD8*d2cH]fīw:mIZkw6 <5Km#9*T,CnLmz}ɤVB_XZ-*x"H ry *߆ B=_˷QϾFc9-խ/!Q"/$\mGJϞ>_o V]pS̋x̽<pq s0XkW31ɺ[ EQKmS, v;C>gNqO7 m99Wy}dmcvGp䩊7'n%R}ǷR}(կHŢHiL[,W ķNF;WĐYI#_jA[HT̐[ڵO\8&HTcTH`yE!Ѵoev2NV@VҬMZo0@y 9<֭PEPEPEPEPEPEPEPEPEPEPEPEPEPEPg?Vo?VoJ( ( ( ( +؉,/Kh+!HĻ* Ipҵ85}:;q"R.GV*ñ q@+HE ެ#FK({&wcɦ@<}})4?R .Wkwqң@a@PZO}K7nԮqgEfjVmInYƪ~ ; ^/K][X,2m  ;5 =Lc[]J5A +a\cԎƘ%s<=Y^}V55.ss2'TETXy`d=_ev8\;W!cjwwڧiт< ^9 ;&2jT ;<#`X55[ٕZTLc>h$jlxobX33.*6r~/ERz5uY۸CI;!H}F@e8$l4;M6ڃRn'\#qo E/JNu5'fPW?0y.j-$6P-}O<:Ԏ5oEiaMR}fM;ϊ0R%KGSg4gjtyK繽7Fu1.T9둝'V;K -yR![N]ervɭ/^e{rng/ dUiTX( %J4kgFRQ.+ʱ6 0<6:ڶ:SGy՝ͻ,d.Hp+fkOFtol兤OxW]l_q? 1];A8 ejzdjVMQ1ċm"(Tdd6W'XVZ'xNDd`hw[`g}G= t#ι2Trfg}1R2w˳|Ime4L)qJ!: gԛQ2/'9r0;S/:woиImǗ$?s=]zkƲ eLuDXgZ㎹՗T-K_pkuql20_*arFPſZ?ejO{gnߔgRx#'>o(U?͏rz uKi  2`A# Tu 1+iDƾnHO76A'~$ejmO񇇼5x3L&{So BOvOE?@ڻN(y^<8 bPy=wg`bo?s1=kvX^0Ԯ8eq\g1RK{T=p*b6$oz$S4`q(!+H򣶸X'N~H'99/fLk{U2+]]UAQx= 8P1r _wzU9ԙ6S%0 AÎs}8zd7R,_67asC: 'J @_$*b{U9l$X eإ?.vOriGy!wY@ߨ-zu0K}kߝ7c;Tb=X/-,Pر2s+b̡#5mlVum(ڲ1F? 1{ɍ/#Q;W'ԞQELŠ(((3ğ+j7j{EUCğ+j7j{ET%Q@Q@xQґWQ}3tr}тEsv!/ϐR 'm3zyWLeb Upr;Š(pj{xgŜepr2N=+[J!4y$UgvR ݛ bxsv+HE ޮ:=B$mQ`ϩƊֿ8G~A5ע?/q ƀ4-ỷU)$R(eu<APXAw$s2"BAr#V`q׽Rֿ8G~A5m:&}p9T+ql`=sa%Z@ e-v{~A5?/t+[{eI8@kE"= [p [[fX3FOPhnO[u5p>$(x>j\IMww)^,dWo´?/R-}?NyZ}[ghֿ8@ o#`Oq[iwxP@ẇ@Q@Q@Q@Q@Q@Q@Q@U]BMr"i+s qgHI!aѹ8JNo..n˾yUNTO'n hmU00Q՘䟩5 V"Z(QEQEQEQEQEQEQEO@5~=p*O@5~=p*(( m]Y61UCh؎BIKI Ņmw1%ĂKc&A<|vmsifAbr0Aa9XkXq^cjR x:z( +o?c⛩Zʹ]E倩*`;''$]gcbЭU.n7X&pH4\Ƌ#ߊݳm]=s/~)vEtQEQEQEQEQEQEQEg:iK$01Dl rNOU4xaqIU$rw6]8Ҫvpz\pK@`TqS/'=]QEQEQEQEQEQEQEQEeY]R4K$ O,)fv8 ROaYj\Kxav:wSePA&-O%&g,%݁ `{W-)NLaETQEQEQEQEQEQEQEQEQEO@5~=p*O@5~=p*((((i;M_L+᳑[Ckg234d`\Zk{ ML2UUW1l[POEPEPEPEPEPEP\֠x[Hʚe/v.<dE=f^yM_S}6+a \NAm-YoZAӮt{څܟhu!U]T*$ M^[k;xL$ $=I'袀 ( ( ( ( ( ( )vU$pjzK!Z<~_#gJ RRxI I,JGb݌sZ2\js\HYy vn]o#>z X-T0z錒y' XPN:}^ bKi0H;_۹؞E2QEQEQEQEQEQEQEQQOq 7gbpshM"Z*-[DPe 68Hb9ȧ )Jmv#? ҹ~۴ʩjRVD8]+ZJ@n0( qݾ\튞c8a@ơQG@QZ k1DMlbap6Χd;t3!X&G$呷'nVksC;kM:qU&R9=-PEPEPEPEPEPEPLEڤ@94n>m牌 4[~A!e%+cgoՊ5ȼmċd4;4tE8CakFi#VY y'$olZE ucM-QEŠ(( ȭהUȭהPQEQEQEQEQEh=?1l[POEPEPEPEPE̶xWEY>mJT@-9;@%@' ?d׼^^m. ϑH?(n(HXEDQU{ iN.=sffbYĒ}M[(((((($($Tc,[/'~Dr 3]kw!"y儤O9cgmɖ`ֲP@`Z+Ik̒UZFs[pڴb(dQj3Œd詔ܕETQEQT/n-mkHd.FITosOfwf~~Ǜ&zg5sMn ,$g<[F1QǦOsEXjAll"c0ƈn\Úd7t-mBKq5¿L8?\vQg_ɥ᧹UDJcs{PmMl;q;ϩOV裕Gl5#HrK dEŠ((*%ܪA>[clN1n%MYeF:U9"WSОW#YUT]GmG=; VHT;tәn |n~?+2dȖ0yg8SR4M`?OE.f?cuȒ4yrz~5-P{*V3R|`$|g4RuP>Rأn W,nH?7Qъ5$7mE 71cO'k[(-U[ൎ9%ry8'gMEwwQEBBII5[n"(-̑$vz?E3zA mG* T3 }Pl$3ҦוA{ە1M97 n0=}j}_klswtub\D⽤A٦._n8,HdqU(rwaEP (yFeqA3i0Aҫ:ș^=*/"m̊T˶,MFV-݈\yٞa>&nI#ˉG8mu5W#g[6c'b21k,e,QGW6\}9Why9 p)hqQH(((3ğ+j7j{EUCğ+j7j{ET%Q@Q@Q@Q@^Rd9.-zór[ao2y]jZ-okVRīonX!9OS˥\i/myq%}̊ň,7N@[:4M4JQ6.vrrv,@\K}際wl gd*=8{66|SЁhDps 뫘{O-((({V6 nde fr#'71Ys;$.d=ϗIu h\mUN(KDNAh4ҍ4yGbf'B(((((d2M+5,DžM \YV^WR͵Kx k˓uFѥ3A.'@CB]-\Lt=RfrI?7Gֵlv/[(G,X'$ILXF,bV4ERu{LѩUdn )Fka8@c- ^ˌw^}_aw{K!"Gʡӱ8wScSgsSC v,q(TQ*J-Vknǻb X$jZ(Cm(QP<48#da=3([b-$Dp>75\̽ݢD$;n7"d`>&Rr#ǁJFKI*_DiLlVÏȚ s>iD~9MOEݐ+Ro1"H˕.ۘ}T$(aEPEPEPEQ1րn*b$dnzkuKT5\]xs1tESYu#{*= |Ec2yxQאUpiw~h2IsnVcUը c)8&q?QG"شN?ǚwV4(M,Gp׆)^hB9]ZѠ ȭהUȭהPQEQEQEQEQEh=?1l[POEPEPYޯkis^\Ao(M A#$(Rpx$Hy$`~vbFu]Oh̛Aut@>T\ԥ !6fH`P` (((((+4*iAQ.-Bk`yQU 6"A)0ʢ@D?{0FX63G, @2gV8"HE4P0MAi}uA8ΩA򍝬JFL"5N}>iJZfm^5*I;z5LHebRjHcUuosKr_*)N< u ;QԱ $_).ǰ=S$?,z8Vj1Ru]c#3MQG9s)!x5s2|c"aF9$I>*[qIl(aEPE$Hi$uDQf8z@Ii}wgF$u QkK׋D§ȎiaQpGL@tǖ85DVf`SOZ^BP lpHJG ܱ.;p;P4c=R^pEMjy-š; d(Ef#ksX+2(*Ǔdc֞lI+\jwۣ,JUDօ@׶ˌʧ8r9Iжin 55;UF*jH؊A7I#1d t\?2mAS6zU#JrWV:;iZ`H%pN|#UP.V<)cj|3mT rdcF>}dV16Y6N[-·׹G}>'hL򊱁ߒOz&(cˈ9瞵C/Rg /s3ğ+j7j{EUCğ+j7j{ET$(((((cE?趮Ggڀ:z( (-gQS4"7i_ `JK3 @Zk84{c]R_ô8<GL9²?}us f15䲓7A8+Z ( ( ( (w$2lW"N ,T9AM&ݐ)ҸHK3Zy+4r4/)Wb/y;'>cU =Inbw'퓨Bz1Ў=y_!2D跺ab"É\ r\[6oo vPơQ`(ޡ!eaiB8㎸)T2&C[+bU[-.[sQGJ̰Cl`Nm6H [7>'5e#Hl@}OF^k c,5ǜ?Dت\d=Ov(Jn[UfItZW_Je:r=jVI8_iEG` 55=6-Į!L,xԉo;8O '5%s0T`z=@cʑ+㷽Kf!T?jncԷ=:~4#l?7oKw4{T/Ew3gj&KnH#ByG%n'v :I-m9=94ҔTTEDn̋zUWOE[݇;#n,x'tip XY, (xQU)~³?7#āJŰ9[6{ȥHm #pW$֨\ٵmma=ǚqsi; ^'Y^Mҷ$B//LKRIV<ol 8%Ɲp DV *+sl}f?*9_ZZ{׽*7M l\e~P 㞔)Xx^RNv|#\ {N i8w8Iq;4vb "|89j_&]&7n۵qc:g_ÊW>MR8Ym~ǜ6QKf&6Ӂ2wp2:֒KqV|#>,V(81ah+ė>'̲Hp(+NsRMsg}p68S#t'c i.mوqrT}I/]R{GLkiXҸXF0q :vjU?9"K#i/bɢZ,Hxޭ븂=4G7vAlLq?}A;{__:FuA` drxq`WR PI{ձS{OF?t (V`r!bè%G`!Kk Is9 BR2H'-̒la0$r=Fr " @|5#P쑷'Z!tprD|Ğy Ol%?N5; +)K)ei|zu'FG9R59!##vOr)S.#Öw!|C:M{Y/O.Nߏ~."?KUuX2Pq|ïj,$I\CkejH%P]<z< @@Fdw(֚-ۡy37VrOJ= 4cK/v2튚Hx(8D\Ԛ7)ҬznGPa>NG+$)U-}>MEsr_x,e4m<x7g=8]:^#}?|訮h,#7=:=ߋLqX+냃A9O޿%X(Gv'Qs+\EL-Ϥ'i6}prTWȪ95S.jĀ]ˁFH4ma6+y-G\)yx9l~Ξ\$ey8%~SL%Sd`1Ix[fA@A$"=! >|q0is"N Wv D?;uљ@\16 5XdӞm0vAM6OY[0 ښ5.>^ 9-I>wW%fmbEP'@BD|1gn[0;>og96p7yW!2 Ϸ8㜃ܣ@޿Ȣ!$S7 Ȁb%w3Be/$iSM_yŰr=+Y˅AqыpS/A\ߎ*Y,e-) 31s?)0QӇ{ȡVi%BX2d~hc5Z>A@=jkiXD֪Kn[=GAqɆKd}h `cs@ m"ơ;Eo9Iyt*|wF#=sӤKʞlw'$O. v!М~sJS&UQgyLcL6#ʹ*&N'ڗp^yhk(!ϻ<'TY36։+# 9OۃH#ݔHaV!f$t㝣Sv_q>wAݕl0d,ņ145CGR@"BF8?tg}jr}; p[=3c\#6HN3ڧTeo&(Cq x##ryp{q&l&Gl$gEd)i_V4ܾ-HcYFF|1ր; + Я/&B<'Bޢ / h#+/ + Я/&B<'Bޢ / h#+/ + Я/&O =fh|7,v3:XX! @GW_G!_E|_MoQX?xO}4?_GW_G!_E|_MoQX?xO}4?_GW_G!_E|_MoQ\e|.#bo 4lb~p6 #+/ + Я/&B<'Bޢ / h#+/ + Я/&B<'Bޢ / h#+/ +|/.R pn#}ބ_B<'Bޢ / h#+/ + Я/&B<'Bޢ / h#+/ + Я/&B<'Bޢ / k+FoĞ%T cھ\gd΀;:+ Я/&B<'Bޢ / h#+/ + Я/&B<'Bޢ / h#+/ + Я/&5_xfP<1*,)2(?4(Sßҿ? E<Х +e!FA$ 椼Ώs`(INVU!]AխEe*]`jjM`\!pCp޵( ( ( (2-c1anˁU;Lm>gHb3O$պ(((((((((((((((((((((IDLIڊ c-7Op& <7Fm @0Ñۨ5[ YGmX۸]Ǿ+AQԭ}"QfIjg]@pF21׊+cƣe"QFivv"Hf$w_XIiqʑ5 rXDweIAPkEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPmets/vignettes/quantitative-twin.ltx0000644000176200001440000004342613623061405017471 0ustar liggesusers% Created 2018-11-19 Mon 19:21 %\VignetteIndexEntry{Twin analysis of quantitative outcomes} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \usepackage{units} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Twin analysis} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Twin analysis}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Mets package} \label{sec:orgeaaf733} This document provides a brief tutorial to analyzing twin data using the \textbf{\texttt{mets}} package: \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library("mets") options(warn=-1) \end{lstlisting} The development version may be installed from \emph{github}, i.e., with the \texttt{devtools} package: \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} devtools::install_github("kkholst/lava") devtools::install_github("kkholst/mets") \end{lstlisting} \section*{Twin analysis, continuous traits} \label{sec:org0778a55} In the following we examine the heritability of Body Mass Index\n{}\cite{korkeila_bmi_1991} \cite{hjelmborg_bmi_2008}, based on data on self-reported BMI-values from a random sample of 11,411 same-sex twins. First, we will load data \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data("twinbmi") head(twinbmi) \end{lstlisting} \begin{verbatim} tvparnr bmi age gender zyg id num 1 1 26.33289 57.51212 male DZ 1 1 2 1 25.46939 57.51212 male DZ 1 2 3 2 28.65014 56.62696 male MZ 2 1 5 3 28.40909 57.73097 male DZ 3 1 7 4 27.25089 53.68683 male DZ 4 1 8 4 28.07504 53.68683 male DZ 4 2 \end{verbatim} The data is on \emph{long} format with one subject per row. \begin{mnote} \begin{description} \item[{\textbf{\texttt{tvparnr}}}] twin id \item[{\textbf{\texttt{bmi}}}] Body Mass Index (\(\unitfrac{kg}{m^2}\)) \item[{\textbf{\texttt{age}}}] Age (years) \item[{\textbf{\texttt{gender}}}] Gender factor (male,female) \item[{\textbf{\texttt{zyg}}}] zygosity (MZ,DZ) \end{description} \end{mnote} we transpose the data allowing us to do pairwise analyses \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} twinwide <- fast.reshape(twinbmi, id="tvparnr",varying=c("bmi")) head(twinwide) \end{lstlisting} \begin{verbatim} tvparnr bmi1 age gender zyg id num bmi2 1 1 26.33289 57.51212 male DZ 1 1 25.46939 3 2 28.65014 56.62696 male MZ 2 1 NA 5 3 28.40909 57.73097 male DZ 3 1 NA 7 4 27.25089 53.68683 male DZ 4 1 28.07504 9 5 27.77778 52.55838 male DZ 5 1 NA 11 6 28.04282 52.52231 male DZ 6 1 22.30936 \end{verbatim} Next we plot the association within each zygosity group \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library("cowplot") scatterdens <- function(x) { sp <- ggplot(x, aes_string(colnames(x)[1], colnames(x)[2])) + theme_minimal() + geom_point(alpha=0.3) + geom_density_2d() xdens <- ggplot(x, aes_string(colnames(x)[1],fill=1)) + theme_minimal() + geom_density(alpha=.5)+ theme(axis.text.x = element_blank(), legend.position = "none") + labs(x=NULL) ydens <- ggplot(x, aes_string(colnames(x)[2],fill=1)) + theme_minimal() + geom_density(alpha=.5) + theme(axis.text.y = element_blank(), axis.text.x = element_text(angle=90, vjust=0), legend.position = "none") + labs(x=NULL) + coord_flip() g <- plot_grid(xdens,NULL,sp,ydens, ncol=2,nrow=2, rel_widths=c(4,1.4),rel_heights=c(1.4,4)) return(g) } \end{lstlisting} We here show the log-transformed data which is slightly more symmetric and more appropiate for the twin analysis (see Figure \ref{fig:scatter1} and \ref{fig:scatter2}) \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=scatter1,caption= ,captionpos=b} \begin{lstlisting} mz <- log(subset(twinwide, zyg=="MZ")[,c("bmi1","bmi2")]) scatterdens(mz) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{scatter1.jpg} \end{center} \captionof{figure}{Scatter plot of logarithmic BMI measurements in MZ twins.} \label{fig:scatter1} \end{marginfigure} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=scatter2,caption= ,captionpos=b} \begin{lstlisting} dz <- log(subset(twinwide, zyg=="DZ")[,c("bmi1","bmi2")]) scatterdens(dz) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{scatter2.jpg} \end{center} \captionof{figure}{Scatter plot of logarithmic BMI measurements in DZ twins.} \label{fig:scatter2} \end{marginfigure} The plots and raw association measures shows considerable stronger dependence in the MZ twins, thus indicating genetic influence of the trait \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} cor.test(mz[,1],mz[,2], method="spearman") \end{lstlisting} \begin{verbatim} Spearman's rank correlation rho data: mz[, 1] and mz[, 2] S = 165460000, p-value < 2.2e-16 alternative hypothesis: true rho is not equal to 0 sample estimates: rho 0.6956209 \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} cor.test(dz[,1],dz[,2], method="spearman") \end{lstlisting} \begin{verbatim} Spearman's rank correlation rho data: dz[, 1] and dz[, 2] S = 2162500000, p-value < 2.2e-16 alternative hypothesis: true rho is not equal to 0 sample estimates: rho 0.4012686 \end{verbatim} Ńext we examine the marginal distribution (GEE model with working independence) \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} l0 <- lm(bmi ~ gender + I(age-40), data=twinbmi) estimate(l0, id=twinbmi$tvparnr) \end{lstlisting} \begin{verbatim} Estimate Std.Err 2.5% 97.5% P-value (Intercept) 23.3687 0.054534 23.2618 23.4756 0.000e+00 gendermale 1.4077 0.073216 1.2642 1.5512 2.230e-82 I(age - 40) 0.1177 0.004787 0.1083 0.1271 1.499e-133 \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library("splines") l1 <- lm(bmi ~ gender*ns(age,3), data=twinbmi) marg1 <- estimate(l1, id=twinbmi$tvparnr) \end{lstlisting} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=marg1,caption= ,captionpos=b} \begin{lstlisting} dm <- Expand(twinbmi, bmi=0, gender=c("male"), age=seq(33,61,length.out=50)) df <- Expand(twinbmi, bmi=0, gender=c("female"), age=seq(33,61,length.out=50)) plot(marg1, function(p) model.matrix(l1,data=dm)%*%p, data=dm["age"], ylab="BMI", xlab="Age", ylim=c(22,26.5)) plot(marg1, function(p) model.matrix(l1,data=df)%*%p, data=df["age"], col="red", add=TRUE) legend("bottomright", c("Male","Female"), col=c("black","red"), lty=1, bty="n") \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{marg1.jpg} \end{center} \captionof{figure}{...} \label{fig:marg1} \end{marginfigure} \subsection*{Polygenic model} \label{sec:org336bb16} Decompose outcome into \begin{align*} Y_i = A_i + D_i + C + E_i, \quad i=1,2 \end{align*} \begin{description} \item[{\(A\)}] Additive genetic effects of alleles \item[{\(D\)}] Dominante genetic effects of alleles \item[{\(C\)}] Shared environmental effects \item[{\(E\)}] Unique environmental genetic effects \end{description} Dissimilarity of MZ twins arises from unshared environmental effects only! \(\cor(E_1,E_2)=0\) and \begin{align*} \cor(A_1^{MZ},A_2^{MZ}) = 1, \quad \cor(D_1^{MZ},D_2^{MZ}) = 1, \end{align*} \begin{align*} \cor(A_1^{DZ},A_2^{DZ}) = 0.5, \quad \cor(D_1^{DZ},D_2^{DZ}) = 0.25, \end{align*} \begin{align*} Y_i = A_i + C_i + D_i + E_i \end{align*} \begin{align*} A_i \sim\mathcal{N}(0,\sigma_A^2), C_i \sim\mathcal{N}(0,\sigma_C^2), D_i \sim\mathcal{N}(0,\sigma_D^2), E_i \sim\mathcal{N}(0,\sigma_E^2) \end{align*} \begin{gather*} \cov(Y_{1},Y_{2}) = \\ \begin{pmatrix} \sigma_A^2 & 2\Phi\sigma_A^2 \\ 2\Phi\sigma_A^2 & \sigma_A^2 \end{pmatrix} + \begin{pmatrix} \sigma_C^2 & \sigma_C^2 \\ \sigma_C^2 & \sigma_C^2 \end{pmatrix} + \begin{pmatrix} \sigma_D^2 & \Delta_{7}\sigma_D^2 \\ \Delta_{7}\sigma_D^2 & \sigma_D^2 \end{pmatrix} + \begin{pmatrix} \sigma_E^2 & 0 \\ 0 & \sigma_E^2 \end{pmatrix} \end{gather*} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dd <- na.omit(twinbmi) l0 <- twinlm(bmi ~ age+gender, data=dd, DZ="DZ", zyg="zyg", id="tvparnr", type="sat") \end{lstlisting} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} l <- twinlm(bmi ~ ns(age,1)+gender, data=twinbmi, DZ="DZ", zyg="zyg", id="tvparnr", type="cor", missing=TRUE) summary(l) \end{lstlisting} \begin{verbatim} ____________________________________________________ Group 1 Estimate Std. Error Z value Pr(>|z|) Regressions: bmi.1~ns(age, 1).1 4.16937 0.16669 25.01334 <1e-12 bmi.1~gendermale.1 1.41160 0.07284 19.37839 <1e-12 Intercepts: bmi.1 22.53618 0.07296 308.87100 <1e-12 Additional Parameters: log(var) 2.44580 0.01425 171.68256 <1e-12 atanh(rhoMZ) 0.78217 0.02290 34.16186 <1e-12 ____________________________________________________ Group 2 Estimate Std. Error Z value Pr(>|z|) Regressions: bmi.1~ns(age, 1).1 4.16937 0.16669 25.01334 <1e-12 bmi.1~gendermale.1 1.41160 0.07284 19.37839 <1e-12 Intercepts: bmi.1 22.53618 0.07296 308.87100 <1e-12 Additional Parameters: log(var) 2.44580 0.01425 171.68256 <1e-12 atanh(rhoDZ) 0.29924 0.01848 16.19580 <1e-12 Estimate 2.5% 97.5% Correlation within MZ: 0.65395 0.62751 0.67889 Correlation within DZ: 0.29061 0.25712 0.32341 'log Lik.' -29020.12 (df=6) AIC: 58052.24 BIC: 58093.29 \end{verbatim} A formal test of genetic effects can be obtained by comparing the MZ and DZ correlation: \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} estimate(l,contr(5:6,6)) \end{lstlisting} \begin{verbatim} Estimate Std.Err 2.5% 97.5% P-value [atanh(rhoMZ)@1] - [a.... 0.4829 0.04176 0.4011 0.5648 6.325e-31 Null Hypothesis: [atanh(rhoMZ)@1] - [atanh(rhoDZ)@3] = 0 \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} l <- twinlm(bmi ~ ns(age,1)+gender, data=twinbmi, DZ="DZ", zyg="zyg", id="tvparnr", type="cor", missing=TRUE) summary(l) \end{lstlisting} \begin{verbatim} ____________________________________________________ Group 1 Estimate Std. Error Z value Pr(>|z|) Regressions: bmi.1~ns(age, 1).1 4.16937 0.16669 25.01334 <1e-12 bmi.1~gendermale.1 1.41160 0.07284 19.37839 <1e-12 Intercepts: bmi.1 22.53618 0.07296 308.87100 <1e-12 Additional Parameters: log(var) 2.44580 0.01425 171.68256 <1e-12 atanh(rhoMZ) 0.78217 0.02290 34.16186 <1e-12 ____________________________________________________ Group 2 Estimate Std. Error Z value Pr(>|z|) Regressions: bmi.1~ns(age, 1).1 4.16937 0.16669 25.01334 <1e-12 bmi.1~gendermale.1 1.41160 0.07284 19.37839 <1e-12 Intercepts: bmi.1 22.53618 0.07296 308.87100 <1e-12 Additional Parameters: log(var) 2.44580 0.01425 171.68256 <1e-12 atanh(rhoDZ) 0.29924 0.01848 16.19580 <1e-12 Estimate 2.5% 97.5% Correlation within MZ: 0.65395 0.62751 0.67889 Correlation within DZ: 0.29061 0.25712 0.32341 'log Lik.' -29020.12 (df=6) AIC: 58052.24 BIC: 58093.29 \end{verbatim} \section*{Twin analysis, censored outcomes} \label{sec:org4b5f762} \section*{Twin analysis, binary traits} \label{sec:org4c17447} \section*{Time to event} \label{sec:org843c812} \bibliography{mets} \bibliographystyle{plain} \end{document}mets/vignettes/binomial-case-control-ascertainment.org0000644000176200001440000006173013623061405022766 0ustar liggesusers#+TITLE: Analysis of multivariate binomial data: case control or ascertainment sampling #+AUTHOR: Klaus Holst & Thomas Scheike #+PROPERTY: header-args:R :session *R* :cache no :width 550 :height 450 #+PROPERTY: header-args :eval never-export :exports both :results output :tangle yes :comments yes #+PROPERTY: header-args:R+ :colnames yes :rownames no :hlines yes #+INCLUDE: header.org #+OPTIONS: toc:nil timestamp:nil #+BEGIN_SRC emacs-lisp :results silent :exports results :eval (setq org-latex-listings t) (setq org-latex-compiler-file-string "%%\\VignetteIndexEntry{Analysis of multivariate binomial data: case control or ascertainment sampling}\n%%\\VignetteEngine{R.rsp::tex}\n%%\\VignetteKeyword{R}\n%%\\VignetteKeyword{package}\n%%\\VignetteKeyword{vignette}\n%%\\VignetteKeyword{LaTeX}\n") #+END_SRC ----- # +LaTeX: \clearpage * Overview When looking at multivariate binomial data with the aim of learning about the dependence that is present, possibly after correcting for some covariates many models are available. - Random-effects models logistic regression covered elsewhere (glmer in lme4). in the mets package you can fit the - Pairwise odds ratio model - Bivariate Probit model - With random effects - Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. - Additive gamma random effects model - Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. These last three models are all fitted in the mets package using composite likelihoods for pairs of data. The models can be fitted specifically based on specifying which pairs one wants to use for the composite score. The models are described in futher details in the binomial-twin vignette. ** Case-Control Sampling Sometimes, pairs are recruited after a case-proband is selected. This proband, can be either a - case: must be representative of cases or a - control: must be representative of controls First thinking about pairs, we estimate parameters using the conditional likelihood given sampling wich for a binary 2 x 2 table can be written as \[ \frac{P(i,j)}{P(j)} \] the probailty of seeing \( (i,j) \) for the pair, given that the proband was observed as \( (j) \). We note that if the marginal is known, or possibly estimated from the full cohort. Then we can estimate dependence parameters using just the terms \( P(i,j) \) for the pairs. We can thus ignore the special sampling for models with marginal specification. If the marginal can not be obtained from other sources we need to maximize the full-pairwise-likelihood in all parameters, that is both dependence and marginal parameters. Similary, one can select a whole family based on having selected a proband, that is selected a representative member of either cases or controls. In this case we fit the models by using composited likelihoods, considering all pairs that involves the probands. This will give some lacking efficiency compared to looking at the full likelihood of the family given the proband. ** Ascertainment Sampling Similarly, in the setting of pairs we can select all pairs where there is at least one event of interest. First thinking about pairs, we estimate parameters using the conditional likelihood given sampling wich for a binary 2 x 2 table can be written as \[ \frac{P(i,j)}{1-P(0,0)} \] the probailty of seeing \( (i,j) \) for the pair, given that it is sampled. If the marginal can estimated from a full sample we can then estimate the dependence parameter using the ascertainment likelihood. Generally, when whole families are ascertained the computation of the true truncation probability can be hard to the fact that families are hard to define in the real world. Nevertheless, if a random sample of such family is at hand. We suggest to in these families take out all pairs that satisfies the ascertainment criterion. With a family, with given size \( n \) we have binary observations \( (Y_1,...,Y_n) \). The family is sampled or a random sample of families such that \[ \sum_{i=1}^n Y_i \geq 1. \] We let the conditional distribution given sampling, be denoted as \[ P^O(\cdot) = P(\cdot | \sum_{i=1}^n Y_i \geq 1) \] Now, we note that all pairs within these family that satisfies that \( Y_i+Y_j \geq 1 \), will have distribution \begin{align*} P^O(Y_i=o_1, Y_j=o_2 | Y_i+Y_j \geq 1) & = \frac{P^O(o_1,o_2)}{P^O( Y_i+Y_j \geq 1)} \\ & = \frac{P(Y_i=o_1,Y_j=o_2, \sum_{i=1}^n Y_i \geq 1)}{ P( Y_i+Y_j \geq 1, \sum_{i=1}^n Y_i \geq 1)} \\ & = \frac{P(Y_i=o_1,Y_j=o_2) }{ P( Y_i+Y_j \geq 1)} = \frac{P(o_1,o_2)}{1 - P(0,0)} \end{align*} since we only consider the probabilities where \( o_1+o_2 \geq 1 \). Also here we could condition on covariates. So considering these pairs, or a random sample of them should yield valid inference. When standard errors are computed we need to rely on GEE type arguments. An advantage of this is that the ascertainment probability is much easier to get for the pairs. Again using the pairwise structure will lead to loss of efficiency compared to using the full likelihood of the ascertained families. In addition we note that when looking at one pair that has been ascertained then \begin{align*} P(Y_i=o_1,Y_j=o_2 | Y_i+Y_j \geq 1) & = \sum_{k=1}^2 P(Y_i=o_1,Y_j=o_2 | Y_i+Y_j = k ) P( Y_i + Y_j =k | Y_i + Y_j \geq 1 ). \end{align*} where \( o_1+ o_2 \geq 1 \). Note that the dependence will affect the probabilities \( P(Y_i+Y_j=2)/( P(Y_i+Y_j=2)+ P(Y_i+Y_j=1)) \) and \( P(Y_i+Y_j=1)/( P(Y_i+Y_j=2)+ P(Y_i+Y_j=1)) \). In particular when the marginal parameters are known the dependence parameters can be estimated using the proportion of concordant pairs compared to the non-concordant pairs with respect to the outcome. When considering the pairs with different responses we learn "only" (up to model specification) about covariate effects. For example when \( \mbox{logit}(P(Y_i=1 | \alpha_k )) = \alpha_{k} + \beta X_i \) for \( i=1,2 \) with \( \alpha_k \) a pair (cluster) specific effect and subject specific covariates $X_i$ for \( i=1,2 \), then \( P(Y_i=1,Y_j=0)/P(Y_i+Y_j=1) = \mbox{expit}((X_i - X_j) \beta) \), and with the standard definitions \( \mbox{logit}(p) = \log(p/(1-p)) \) and \( \mbox{expit}(x) = \exp(x)/(1+\exp(x)) \). * The twin-stutter data We consider the twin-stutter where for pairs of twins that are either dizygotic or monozygotic we have recorded whether the twins are stuttering \cite{twinstut-ref} We here consider MZ and same sex DZ twins. Looking at the data #+BEGIN_SRC R :results output :exports both :session *R* :cache no library(mets) data(twinstut) twinstut$binstut <- 1*(twinstut$stutter=="yes") twinstut <- subset(twinstut,zyg%in%c("mz","dz")) head(twinstut) #+END_SRC #+RESULTS[4c41ab99466bf4a108ce410bed6469f1a5a75e08]: #+begin_example Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.6 mets version 1.2.3 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined tvparnr zyg stutter sex age nr binstut 1 1 mz no female 71 1 0 2 1 mz no female 71 2 0 3 2 dz no female 71 1 0 8 5 mz no female 71 1 0 9 5 mz no female 71 2 0 11 7 dz no male 71 1 0 #+end_example - First, we select an ascertaiment sample of the data, thus selecting a random sample of all ascertained pairs. - Secondly, we select a case-control sample of this data to illustrate the use of the methods. * Ascertaiment Sampling Selecting the ascertained pairs #+BEGIN_SRC R :results output :exports both :session *R* :cache no library(mets) data(twinstut) twinstut$binstut <- 1*(twinstut$stutter=="yes") twinstut <- subset(twinstut,zyg%in%c("mz","dz")) dnumeric(twinstut) <- ~. dfactor(twinstut,labels=c("DZ","MZ")) <- binzyg~zyg.n ddrop(twinstut) <- ~"*.n" twinstut <- dby(twinstut,binstut~tvparnr,stuttot=sum,nn=seq_along,n=length) twina <- subset(twinstut,n==2 & stuttot>=1) #+END_SRC #+RESULTS[708d8d2a3d568c08b0831320a0c05425b3b4a4f9]: Selecting on the pairs where there is stuttering at taking a look at the tables of discordance and concordance for the twins. #+BEGIN_SRC R :results output :exports both :session *R* :cache no twinda <- fast.reshape(twina,id="tvparnr") twind <- fast.reshape(twinstut,id="tvparnr") dtable(twind,"binst*"~I(stuttot1>=1)) dtable(twinda,~"binst*") #+END_SRC #+RESULTS[35fcd3ee8431268e066816a5b4dc83d3466d57bd]: #+begin_example I(stuttot1 >= 1): FALSE binstut2 0 binstut1 0 6632 ------------------------------------------------------------ I(stuttot1 >= 1): TRUE binstut2 0 1 binstut1 0 0 289 1 281 111 binstut2 0 1 binstut1 0 0 289 1 281 111 #+end_example Now doing the analyses ** Biprobit model Looking at the full data for comparison. We estimate an unstructured probit model with different correlations for MZ and DZ twins. #+BEGIN_SRC R :results output :exports both :session *R* :cache no b1 <- biprobit(binstut~sex,~-1+binzyg,data=twinstut,id="tvparnr") summary(b1) #+END_SRC #+RESULTS[de1a8dfd25cb6147320d5d9861f6daf5e594585d]: #+begin_example Estimate Std.Err Z p-value (Intercept) -1.794821 0.023289 -77.066826 0.0000 sexmale 0.401430 0.030179 13.301756 0.0000 r:binzygDZ 0.132458 0.062516 2.118802 0.0341 r:binzygMZ 1.096915 0.073574 14.909085 0.0000 logLik: -4400.536 mean(score^2): 1.022e-06 n pairs 21288 7313 Contrast: Dependence [binzygDZ] Mean [(Intercept)] Estimate 2.5% 97.5% Rel.Recur.Risk 1.77662 0.92746 2.62577 OR 1.88752 1.09432 3.25566 Tetrachoric correlation 0.13169 0.00993 0.24960 Concordance 0.00235 0.00140 0.00393 Casewise Concordance 0.06456 0.03937 0.10413 Marginal 0.03634 0.03287 0.04016 #+end_example Note, that the Casewise Concordance is a consistently estimated under complete ascertainment, i.e., when we consider a random sample of affected twins (at least on of the twins must have the event). ** Odd-Ratio modelling First looking at the marginal model based on the full data we find the overall level of stuttering and also that males have a much higher stuttering risk. #+BEGIN_SRC R :results output :exports both :session *R* :cache no margbin <- glm(binstut~factor(sex),data=twinstut,family=binomial()) summary(margbin) #+END_SRC #+RESULTS[5c622eb4645658450203040164fd3ef28aafcf35]: #+begin_example Call: glm(formula = binstut ~ factor(sex), family = binomial(), data = twinstut) Deviance Residuals: Min 1Q Median 3Q Max -0.4127 -0.4127 -0.2716 -0.2716 2.5763 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) -3.28191 0.05000 -65.64 <2e-16 *** factor(sex)male 0.86171 0.06211 13.87 <2e-16 *** --- Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 9328.6 on 21287 degrees of freedom Residual deviance: 9124.7 on 21286 degrees of freedom AIC: 9128.7 Number of Fisher Scoring iterations: 6 #+end_example First, fitting the OR model for MZ and DZ for the full data, we find that MZ have a much higher dependence than DZ twins. #+BEGIN_SRC R :results output :exports both :session *R* :cache no theta.des <- model.matrix( ~-1+factor(zyg),data=twinstut) bin <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,theta.des=theta.des) summary(bin) #+END_SRC #+RESULTS[4268bb77084537539e34cdd71bc77fd15b77c50b]: #+begin_example Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(zyg)dz 0.5238541 0.2400861 factor(zyg)mz 3.4930902 0.1865567 $or Estimate Std.Err 2.5% 97.5% P-value factor(zyg)dz 1.689 0.4054 0.894 2.483 3.111e-05 factor(zyg)mz 32.887 6.1354 20.862 44.913 8.308e-08 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" #+end_example Now, using the overall marginal we look at the adjusted likelihood and find very similar results on the ascertained sample. Note, that the marginals are crucial for this analysis to give useful results. #+BEGIN_SRC R :results output :exports both :session *R* :cache no theta.des <- model.matrix( ~-1+factor(zyg),data=twina) bina <- binomial.twostage(margbin,data=twina,var.link=1, clusters=twina$tvparnr,theta.des=theta.des, pair.ascertained=1) summary(bina) #+END_SRC #+RESULTS[<2018-02-05 11:48:56> a426c94a6fcc7a60b969a4c6d2dc827c33dab896]: #+begin_example Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(zyg)dz 0.4874213 0.2472523 factor(zyg)mz 3.4753766 0.1985974 $or Estimate Std.Err 2.5% 97.5% P-value factor(zyg)dz 1.628 0.4026 0.8391 2.417 5.245e-05 factor(zyg)mz 32.310 6.4167 19.7335 44.886 4.771e-07 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" #+end_example ** Additive gamma modelling First, again for comparision fitting the full data for the AE model. We get the size of the genetic variance in this model. #+BEGIN_SRC R :results output :exports both :session *R* :cache no out <- twin.polygen.design(twinstut,id="tvparnr",zygname="zyg",zyg="dz",type="ae") bintwin <- binomial.twostage(margbin,data=twinstut, clusters=twinstut$tvparnr,detail=0,theta=c(0.1)/1,var.link=0, random.design=out$des.rv,theta.des=out$pardes) summary(bintwin) #+END_SRC #+RESULTS[850aeaf3f26b8ce7689814808e139a60ee679365]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.9094847 0.09536268 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.9095 0.09536 0.7226 1.096 1.469e-21 attr(,"class") [1] "summary.mets.twostage" #+end_example We first here take at the look at the marginal model for the ascertained sample, and note as expected that this sample give highly biased estimated for the marginal model. #+BEGIN_SRC R :results output :exports both :session *R* :cache no outa <- twin.polygen.design(twina,id="tvparnr",zygname="zyg",zyg="dz",type="ae") marga <- glm(binstut~sex,data=twina,family=binomial()) summary(marga) #+END_SRC #+RESULTS[e12e7a711b5694f9fd66796e492527f064f099fc]: #+begin_example Call: glm(formula = binstut ~ sex, family = binomial(), data = twina) Deviance Residuals: Min 1Q Median 3Q Max -1.334 -1.298 1.028 1.028 1.061 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) 0.27895 0.08739 3.192 0.00141 ** sexmale 0.08242 0.11237 0.733 0.46328 --- Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 1851.8 on 1361 degrees of freedom Residual deviance: 1851.2 on 1360 degrees of freedom AIC: 1855.2 Number of Fisher Scoring iterations: 4 #+end_example Now, using the overall marginal model we look at the adjusted likelihood and find very similar results on the ascertained sample. Note, that the marginals are crucial for this analysis to give useful results. #+BEGIN_SRC R :results output :exports both :session *R* :cache no abintwin1 <- binomial.twostage(margbin,data=twina, clusters=twina$tvparnr,detail=0,theta=c(0.1)/1,var.link=0, random.design=outa$des.rv,theta.des=outa$pardes,pair.ascertained=1) summary(abintwin1) #+END_SRC #+RESULTS[30009e0cbff60c162c2b35ad4fd0fdc7dd0958de]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.8920274 0.09732786 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.892 0.09733 0.7013 1.083 4.946e-20 attr(,"class") [1] "summary.mets.twostage" #+end_example In fact for this model we can also do a full-MLE fitting jointly the dependence parameters and the marginal model. This is based on the twostage option (twostage=0 is MLE). Here the starting value is given at the marginal model for the ascertained model. This gives quite similar results to the previous analyses with a genetic variance around 1. #+BEGIN_SRC R :results output :exports both :session *R* :cache no aabintwin1 <- binomial.twostage(marga,data=twina, clusters=twina$tvparnr,detail=0,theta=c(0.1)/1,var.link=0, random.design=outa$des.rv,theta.des=outa$pardes,pair.ascertained=1,twostage=0) summary(aabintwin1) coef(marga) coef(margbin) #+END_SRC #+RESULTS[391071c5ee9508d90ec0f05e51ced1e4b7748914]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 1.014398 0.1045593 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 1.014 0.1046 0.8095 1.219 2.967e-22 attr(,"class") [1] "summary.mets.twostage" (Intercept) sexmale 0.2789484 0.0824214 (Intercept) factor(sex)male -3.2819072 0.8617053 #+end_example * Case Control Sampling First, taking out all cases and one control for each case, we establish the pairs of these probands. This is based on keeping track of the twin related to the proband. Here using some utility functions in the mets packages. Then we write up the random design vectors and the parameter design for each pair using the kinship coefficient. When specifying the pairs in the case-control setup the second column should be the probands. #+BEGIN_SRC R :results output :exports both :session *R* :cache no library(mets) data(twinstut) twinstut$binstut <- 1*(twinstut$stutter=="yes") twinstut <- subset(twinstut,zyg%in%c("mz","dz")) dnumeric(twinstut) <- ~. dfactor(twinstut,labels=c("DZ","MZ")) <- binzyg~zyg.n ddrop(twinstut) <- ~"*.n" twinstut <- dby(twinstut,binstut~tvparnr,stuttot=sum,nn=seq_along,n=length) twinstut <- subset(twinstut,n==2) twinstut <- dtransform(twinstut,nnrow=1:nrow(twinstut)) twinstut <- dby(twinstut,binstut~tvparnr,nnn=seq_along) twinstut <- dby2(twinstut,nnrow~tvparnr,pairnr=rev) cases <- which(twinstut$binstut==1) controls <- sample(which(twinstut$binstut==0),1217) rowsca <- with(twinstut,nnrow[cases]) rowsco <- with(twinstut,nnrow[controls]) rpairs <- c(rowsca,rowsco) cc.pairs <- cbind( with(twinstut,pairnr.nnrow[rpairs]),rpairs) ids <- sort(unique(c(cc.pairs))) pairsids <- c(cc.pairs) pair.new <- matrix(fast.approx(ids,pairsids),ncol=2) head(pair.new) dataid <- dsort(twinstut[ids,],"tvparnr") dataid=dtransform(dataid,kinship=0.5) dataid=dtransform(dataid,kinship=1,binzyg=="MZ") kinship <- dataid$kinship[pair.new[,2]] out <- make.pairwise.design(pair.new,kinship,type="ae") names(out) out$random.des[,,1] out$theta.des[,,1] #+END_SRC #+RESULTS[<2018-02-20 13:45:29> c4f8b836d16b386e597249418622af02fada445c]: #+begin_example [,1] [,2] [1,] 4 3 [2,] 16 15 [3,] 18 17 [4,] 32 31 [5,] 38 37 [6,] 44 43 [1] "random.design" "theta.des" "ant.rvs" [,1] [,2] [,3] [1,] 1 1 0 [2,] 1 0 1 [1] 0.5 0.5 0.5 #+end_example Now doing the analyses, first with know marginals, that is marginals from the full data. For this analysis, since marginals do not contain dependence parameters we do not need to specify that this is case-control sampling. Having a correct is crucial for this to work, but this is certainly often possible in register based studies where a full cohort is also available. #+BEGIN_SRC R :results output :exports both :session *R* :cache no cc <- binomial.twostage(margbin,data=dataid,clusters=dataid$tvparnr,pairs=pair.new, random.design=out$random.design,theta.des=out$theta.des, pairs.rvs=out$ant.rvs,case.control=0,twostage=1) summary(cc) #+END_SRC #+RESULTS[<2018-02-20 13:51:39> 40511f7b24b7d6f42175d24ffd37ba9025cb10b4]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.8791843 0.09707036 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.8792 0.09707 0.6889 1.069 1.339e-19 attr(,"class") [1] "summary.mets.twostage" #+end_example We now do the same analysis specifying the case-control sampling. This should result in the same dependence parameters as is also the case. #+BEGIN_SRC R :results output :exports both :session *R* :cache no cc3 <- binomial.twostage(margbin,data=dataid, clusters=dataid$tvparnr, pairs=pair.new, random.design=out$random.design, theta.des=out$theta.des, pairs.rvs=out$ant.rvs, case.control=1,twostage=1) summary(cc3) #+END_SRC #+RESULTS[<2018-02-05 11:48:56> d9aed82aa1d6bf7ad52c62a4d34cfbdd5f589c7a]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.8791843 0.09707036 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.8792 0.09707 0.6889 1.069 1.339e-19 attr(,"class") [1] "summary.mets.twostage" #+end_example This model can also be fitted using a full likelhood of both dependence parameters and marginal parameters. Here there is no need to have a correctly specified marginal. We here use the marginal fitting from the case-control data as as starting values. Again we find a genetic variance around 1. The marginal parameters are also consistent with the results from the full analyses for the marginal parameters. #+BEGIN_SRC R :results output :exports both :session *R* :cache no marga <- glm(binstut~sex,data=dataid,family=binomial()) cc3 <- binomial.twostage(marga,data=dataid, clusters=dataid$tvparnr, pairs=pair.new, random.design=out$random.design, theta.des=out$theta.des, pairs.rvs=out$ant.rvs, case.control=1,twostage=0) summary(cc3) #+END_SRC #+RESULTS[422c3590cd02fa9a235febac6c0b4334239a7fac]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.9222504 0.09729347 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.9223 0.09729 0.7316 1.113 2.566e-21 attr(,"class") [1] "summary.mets.twostage" #+end_example When probands are related, here we may choose both case and controls from the same twin-pair then we need to adjust standard errors by grouping together contribution from related probands. This can be done using the se.cluster option that specifies how to cluster in the computation of the standard errors. In this case, however, this will be same as the clusters since these also are identical across pairs. * Combining Case Control and Ascertainment Sampling When specifying such models based on the pairs, it is in fact possible to combine ascertained pairs with case-control sampling by specifing vectors as the case.control=c(1,0,1,0) and pair.ascertained=c(0,1,0,1) arguments. Here with two case-control pairs, and two ascertained pairs. mets/vignettes/robgofcox1.jpg0000644000176200001440000010564413623061405016017 0ustar liggesusersJFIFC    $.' ",#(7),01444'9=82<.342C  2!!22222222222222222222222222222222222222222222222222&" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (o]Kx̩Ғ0ps=v{KfK[{] "fbog;?״(((((((((((((((((((((((((((((((((Im He{WUv\ zjբ9;M.^Yn_"&U 2 Nk((((((((((((((((((((KrPKXm-pI$jݢ?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5עV-sO/oSZFkx$+Y U'j"b𣞬}Q@Q@Q@Q@Q@c2?ج}?F]g?@QEQEQEQEQEQEQEQEQEqKTY8Q؜LJS'be+Q%InԹZi4("82ON46[GZ)(m>f^si\W(c ( ( ( ( ( ( ( ( ( ( ( ( (3T$LsqaNX^Ӧ|KT1;T$)—|g~ ҷ.&ܾM*XVf`6|yBjXq-X?)񲼒:0l|Fku+\Z8L6 :jV@XʝʱƂG|['##לƗ4b-z DY9<Њcl zdՈ\rܓWRs88yEXqVLLAŸVXQEQEQEQEQEQEQEQEQEQEQEQEQEO@5~=p*O@5~=p*((((15;D\]3帴k(tgbw+#C rf+Aw? v1y7DJʤŏ@9Su #xch|(wANGkPN=M>ug ۴l:<;5xV[$"M Q\Ƌ#ߊݳm@=Q@Q@-nU 8.v[J0sЀ[e6=YLtEpcZoӐ9ww0w=\Fa(:ʡ#Ut@WwRVvjy+y$sU$fd6lza1[lg?~C!C$-T$t8^ [@H#fp8#Pr-Z%{IQTY d!t!SN0H9:~2g',y Ǿj܈WrKfOʧ$c*J)H& sUԭjlR8' Y_B6N ~n @iSP]J1mZ$YypUa|I;qZ5ۍTM}ypAϵ5K׊o] jb{_ O5xFA ~.bO2B<~ݿhԑ́@J(=x<w検~D<1>F2u4iH$p1QܳG;A~5RܴQE#0E,⨡j aRcN:Ҳne9?/'ЗH2),$`!"= h0!8)` ;$gGR2E'Ðp1'&AxsI{? M4CQEQEQEQEQEQEQEQEQEQEQEfxEm_ _hʨxEm_ _hʀ$(((((cE?趮Ggڀ:z( sx$9AƮUkΙ~Xџw0?L˩-Miqsi-f/-ùAF2*e`8kkgD`6̧,XU[TW~WƏZXxTǩoH`IrzuG\])d@ ſ WIyZvRֹ6НrKrsѶ{a_(9<*/sKK+Hp@#rg ݎ͘wD{P"s<\X9D[uM,eW A@~ym܏HzUzEsߺ$vG1>-4z"A]+ChWw<:,K*XVU9jcؘRK`s$~<8Ɲ$s00U3n^zҮM)Ґ1̓|Xt班Y{8J22g GsMI:{U2Y E;[-~`FN8栲YҙG9jfL'BXǫDIXorzdP=yS iqA?R6w/FM HorqRSr rAX \rA9 Y#mTg7c~|Vp 1 jW1l[Vk:-ǟUT C}_AȚ3h(cl-hbq^9iI*C#D=c]SxԆvmuX~/s Cy{\U.gU ~;X6{ʸU__ݑONiSə^s@|DƕG0issH)[_霓~֚>[ZnQtKiUGywn-uʲb LtP4|5OQ]kTMn"1 &0zv$Ʋ|u VWGa@Vt{9rOD3*5)9OL>xMoJmbZ}|1ukׂ$n2$e>Vmدci3,16NAd\w^n:'ɑ8ܧs䞧stI5^\ԖAj%LlH=yUԆ+ teb}AUm@>ffU/?ʭj6 U*N?,s\S9%O:jY~qo5D[|-uKnɭgM=QH̪pZ O=5Ӈ G~?)^[`ܛtYB`{5콬w#E]hϺ]4)Px3/ovPpON#; uI9ЯVFfB\HF8`N?gVR6Ö$pq۩$W%Ye8  ϸ\ERvSnySpjeu @o!w38;v9t*/Ա2rht^dy6aNTבt={ֲ5[ޘFC#v9ZQ:Uj R1jM;*E!V$OZ&8T楫lܺpZ̝Nn] 4qP;w~aڰwj O®4hΎ˖L>?-*N@}I8ݿfrm &$D:d!ypX܃g] WU%:FL*~|:Ui.~b)L՝n=KŞFM@9xܧ>ϭ~(j\1:bi`Wl+?axOB՜Js=IKđ1?E_KPx~ʹ;H,2*~\m>"m2KK\YHg!@9aI?Shofz^7OԒ_vU 3-~#..d. "Uqw5_[=xwt>RMu,7/!$=쓌_P{'ק+^ZiLΐ`< ~z.-Ao I&yF0\OO+k=^QER;~]?@s]~t9[<># ,ӏ+iI-ooOuꗶw G ,oPAGG _XquIs"hikt0Bn|1Ywd`}i<7(9RA?ֳh?# # ]&%< I[׮+5:k0K6nCr"p$!YNC.x?5jzYs"q~b;rs/3R|UVIT179U;.A.nu <(>-ڧᶹF?TΦ*6N}GKQINB f6s0YF1^=c5מl{mq1Pq߅{6!ȱ/Fq6-FeQpS˒1(`TprBOoX7de~nKo,ydh]ČrA+{]MQX`G (U+z *oC/O{1 \uw*ͽijTd$7Ύ+TN$XI=:p\ϸSW;-+z]G{A_< զe'; gYzVei$rvc)[YBx c~N+Z7,iKuu !Q"N2N__UI[yEsϿN 9̌GV,-O6b7yU髽SMq@=І!W9*fڑJv8$tE2V+ ;)23+6~pAZs%2[JP# xllV5 2_֨{x #c?.*}n9oUm7NxA{urTsyƾV/s|CK+Jⵎ)ڣh'^3]Ý!D8)! C=vki[_%LHqb)ck]TXLK6m$c f-JM?3ԩ%1$w%H$G*].Nnaܱ7z@lΌn>&/$aB2'kt\s=^6<I %}}N$4;ہ3%g P3X]*w@TVvb?TooEaߴA f`>+NO}3}kZ&Cɩ(褶hሾh;>,3LNLJ]W*IҸoT5-,_\iA9ڻ]I-廴]ڳNpBFtBTVT}VU+!;x%>}-}m%>]ʳi=>XCu(Gw? Q~`cU5B!N0JI>:osb8PJ۱ly>[MFF"WFsW}Y%W^g^j>z_mtH-nvʂHQGןz䣷T2 X,b@1">:}-,<* tZ!X.cK`gqU8 }>cQZt˱"teʣoȆUh (UkR^V?L~#G=Ÿ`H'L9O'ג+kҸE1(' 徲#0 I*ܶ*_OH9Σqg| rmm%t H*q֧]N /!+fuS*j[FX]Z&J{y4ɡ?c#y1`dUI5NKVC8~j^M`o)۷%Px'ҴI})D̓ui1|za0 rCǵRӄ򬅖eWc G犩C۴hCH1(stì|pqbG>>:muYTkKL[NFv?VMr_!"s"1Ǩ6*&RD6mF lj/>-/MRJG@b>R#ܹ]ӆ[]Λθ{%RKy-!cZ]h۶d#SiBb%͕f$ssleIL Nx86=ZtvkJH"\CU4뭲I"k'Hʷ7r`IG> [.eXA3ߞwu67w۲ԻF Xۜ3"II*2{~DnTp1۟T`.w,>6I}jI%Mc1-hGI%\ckGVJWjSݠGWQԎZEfOQק J#a)\tֺ~'Im6<k.\4ϓ 7np35Բ1'~fKce=-3@#jqxiRwI PqY*+ם$FJT՟|, ?< ?̓hF;ȠNa}kGEѬTí-qe(;Fyl9:*dEtf`H?xO׌["\w'c&Y,yzg*F=s֜Kzf)»!~UR>[L)N%4CmnbTJIƤo3 2mgFѬg{i *@w8 ֭ضFdu$'A#ˏUGͰhpLj:d?мyqk]i67+I7#i=;3^ߢHL|cv@RA %\ӞޢJb[L*9 238 ]g)(UҭRST[W{_oK IbaU}n1W.b.YvC{V=|'fhd/ѷ SwxN]Dfч#q^+.QZy^J+V5B,bEGTS eۃ=I,jb W;2I?/ҙxZFW,qGjp궗->,̫ye+Ў?ҫ'+Nzk^E8Ěvf؀I#ĚYZ#C$#zp#@hDwEFN6:X/,.$A0 Pܓk;?c+`T%ڻjU3XKso61I&>*L^/·w=}+$;JڌŌۡ$>G*Qf̽h7ɋ {!f'_n\[Ibe '2!(ڱU 8$tNWgC8խ`H5@CǖB 2pG]NVuR+^.\i6)x*ؒ?Ouv ۥD`QVws:$i3 c2Aߚ<1[.8!\jW+ik%G$nWgI;:&A‡U}8&KI^ f~wrP =NK2 `|o$Aa^-1DQu\0FzgI)')mA%%)y܊xbBfPxnuRi=s&bO0y Ce eIuU8OCYgDW\b0瞿ZJI&2JK]^0ƕ,{pϝhr9_]/AFX繆 ƢHvbO><-~$/uS;N&$+eFS̋w^CbO=oYdY ʃr ZPZjFqT֎#Mq .uO|eYU{gju/๷ӡxK2we=3ʕ sMpzƇ{|B_7uDW06MS| 4͐X0A21x8Cf2;7t848Srӥ)s/=b6U &Vr1ޒ;&G˷HA+qɧ{'4Z`ȿ1<#jj,LXG>Dlyi_񨨡 _gUScb-4vۼԂsii›m7*3װ8uj1 >U hّlN=8sԼA^X2\B.G9+e̵fw%'Y5?MҴnm;yZ;n5I[lrm9N{WCoEܒx؉7BBѐ >Wz՞suv4z܎5W&6%K 22~R[sF\T4QZFfYCD.9o鞵x6=A8;YI8$*2:Bl<3\$ :\i gx0Z8쿭:uC~CͩĊ 23@r@S>"ҵ{[)vEw 4pNBH`=pw5"7Iz8 + [$;ָKz;Uot{f[w|ho#sW(\S5hFڭȶ-y7#1GZ.~$Ʊ(ٴm*3{$74 Hp;·EѧѯoD$fB_S?~m$+ӬͶm 4р_0,ǾOL imUZⷆ,ntR㿀M ʶc0X NsYg\U!`>f=+ʵ^P)T0x {*h|yuXu)4PŨRndϘxjhRGTUY0T iV&8qퟭp5t֞u_Ȱ_$qOͫ4QZԐ{zb$;?s~50h[iv20pXi ʌېgВtZÖcX2o1:HA8AֶND]ѷESO@5~=p*O@5~=p*(((( Uе56WiӂsZqȒƲF2B r:ޙq|Uƒח\7-\ȬXxd ճ#DѡDݝSbwg!W'jPs/~)vElq7=4aIghwO+Hqut2ϺKEV 'j.:zN=CO NN $^Va7^)gA2iQRcdVc;ǧ34mn2_6*i3g^= 13N 9ky&#ﶖ_oMLLxm4]@THģ,HqY3Z&#AiSǧ4F3l N1M%}Ũدwuoy\$cB>կYʑwGInBU~bCb~Mt& m%3EVn3iьkORog]D4 w2g<W5yfZpYش33w8G]4m(\rܫ뱇o!iA#傫m8ZUi{Gj>謯7^$LF1|-k72M-1UXr8cX]]K5Z۬n>SnSysW?6r4F$xٕYm61+ ]|0v<rF1:eGg`$XVEFB2rӯ*nI#&t$~;.t2Oʗ郴$n/z-o/@@#2sя=8/=zu۴6s0$9*AҼ-%ՎbI$IpTӰ>*5VߗX]%QDed,yqBk~xGW F;/jR twa6$k60p}IyX7 ؚK(F8Rr@$I"&ʍrezc'֛2Z]QKKMYu0xxiG9w'k)rMT0Lq㩩Il1!_93`pNyw?&y"͔ʈߗ##U'9Y>5jT*[ %V@ F =?Z|K]N :U*0,f..ȇax =Qw٦/ rr)+Ûhsr#U5m"M2X*9H*H׭`_x_]2ɤè6x5PJp@Nk`ٚ7X%qlQmqb|,0qGja~Ҥa?S^e5 -^̨ $y85/ ͯ___J A<ܙ&=N0F9LZV6Wv7_nաg'{1\V-)4-)/n ^\wKQ>d@ ہW`M/S4M&jxBSHk|;<0甖w` ژx2ztW9=.j3$ф#xJܔj9uoG`qU˯)GSˀsd*@[,d@ 8w7BSlVȣg UpԫU$gq+~;rE3;'5fχhǯrsj-\]?t2>^ #.K?(ݑ5W/J Il֕=5EqfИ2FIn7=EO_ ^25_k@ v@5cO֑sVʒEKԈ(.p-_ۜ+]X^Uuoݪk,Q?+vKl+yʘ=c?M&m<kk"ƤdΜGwQr(T{~^czȬ!{G=Ui7^.u86gL0x_SxRZ+"rbf)D[@5KXଂ`}?Ҋ%}Z3N }Z3!;ax<>d6tSA,,qz*Of ɨGg}n?0 +^I-\FE i0*武xfGh7YS@9cǃ\49hQ)rl8Z[ +ĩ_ Ѵ(.~fpٕB:;tJA>֑DiҒ)>Vl_κ%^/(0?td@"o]]+} ¿unmvc7nh;pßƽڵ`6w, PxЮC&q~쳇&Ix)o}ݮ rU=s鄕HM5߽sCO4`rpsk2%.s89_pY&Y yprUHCT}:aʩZ2j-YdD[HPz.? o<=9QmG<&@; h-?~b(d?1{h>6+˯i$i! ];zQM['9k-s_s*_q{#e~OCn~Na'ɽ`e|UƥK5+^R14e"9Jr>. UXđȍ(M<ņ1휦y>bǞy#2!yꨐŸ)$0PkL^ո4SV` 8'鎼~]sTmFkRY$hǂ0?-倴Kw nIp;OnXO8WSүIO-43(10nryOګXo4a&zsUxۙGn۾8 3Uvq]B9$+{^rz\hu]ԢLlTAdU2<V^#:},Eq5y2kO=9ޏc={w2m?%Zo9?*Iq-+[ TNT*i𛆷*l:(ۂ;qInQ*cfo$1*`zOGqJ{'DBdXw#]6d;~a~Z/ʲN<)-0rzoZ@ҳ%I>F8=O'U\ Z0ݪ$Pm :5-!gVRфi ),@>ǵijDu+wX,{˃@b:TaU.HI.P7)^; 7JNM.r''m-6b曅(Poc$w+uG,r!2F#`ֵ-cT@~zM"9%nOE"q4pZ []3; uA *xשR֬[ӗr<m]FK pas-c<|OaA*Ty)m1L]6(,N2A ?š[{-FXۨzE$,\v_ʣ_M 3$yvB {:4k)b[F%=3Ej)jJE bT%B?KEIhVFg?Vo?Vo(((((Ggںz4_SjOd@-"d~KPv(eRHJ"k*u).8n)S]UTٽeVFOSư*GfrqXdxfa[o+.q1d7M>St'}F$U#?5%\Y̑'NcAi8<c^;d?1Q'%S^HchbPoq[:S-D?;0)G"٦yJř;%r֯PN-,Ō# #~mM8ltRN>[fm4H$r!۟Ұ4ƊϘ263Cc[vO8 <%'Zr6u,ir:={ߥiQ_kXkd<\C&$"BG8m?LU=?T6+H!$=>#Ԥ5g%)h׏4ʋ0 ǶGZl[$\!Ga[=>l{ F3+w<[N庘%Q$7qI.?ϭoN1tRk:BRZ5mvHSrH8 {4mq4G<_k0bN@zjIٙ$q"+i 87Q EM`(߁X$&${)-5{]mbXB]bJMJKQA'W1˫xDcbr_Têԓ+[d^\\Me<,}7WTN[v罛sZ~мUV&Oߞh#:NNҝem:k22GLZ? [5F)9ڣs>_ĺƞKrFZ9 QFAs[aF7уZ/kQO.[!!9N;zfZE RU-.HDe-[*hH~Kcڃ(#xp:k:$NJK;Kk$Fo%n}IK4j<7PXM!TJ(4_Ԋ^u3,Ew:ym  l:08P$abdxb)lnAe[:B |6H c=HMeĒŷyHŤ,GLr~VVQJK8L+%s=:kBDMd?J![ֆ+BC K#ҜڸX,sak*_yE-﹏%d$\T=y5 "? l/{vUk qNaP+(0ڻeu,n El `z#=33_ ͉"i fIH G'~h^PU2TH#$<5Vbk%%1(n|n9Oxފ$LL֟tfEP€qMA+ܥ bȜ+, 2ǽO _ܼ;\%$k*1(ǧWb<˴'O\?*#Ye2`޸'&\8('ZE lĪª "9'+cޝEUv[Tzu1@H9)SYQ@Š(( ȭהUȭהPQEQEQEQEW=''M?Aյ(`BS$R FAm3Qմ-nYJȥYX+І(s/~)vEth=?E^'No9>~GATtySz1WY2?KIz1?&5Je$>SƩseɌUڴ?S+ykd;.6B]jߥtQ#gD5!wjcYY)_m ֖e0y*1C5ZͼjdQo\~&jܱA8?S,qX~Ҿbn82:qsP5k9&md3XC,3KK@1Pᗓ?+P%$Ďl q­j M:6Ure9־>i^/}/rhm,M,T+69$1S~SmMfdULl`RݽƠxxLPJ8,iۤ%rۮLLI?[6SK_mJ -q0PF@O=I I$mq>/_z\o[cd\+Soo m\~U.LZ亼DbFk&5|W}`j|?麦,q)w2`TVjWs܆]H[7qe@ҁ~uy{e^I%2f (08 j_Iy 9r]~1][,rmrx,o߿i]mhig1H|בޒr\1E\?/ !&g7M*]wa^KBFbl+A'WȺYyv#ׂ?j Xw8]q8T΅EN\wvteFVڰ(.0\YbI2O;˯ l 1#HJᙑݑxd9R:Pгckg DKAǩ=q=Z(E\(YcS{ZRO:` Y&y_3Nҫgi=qΛuV xZw4YpU*o/짙btdْIjطYy,򏔌2x)l ic "PRbCnڕv[ͭԆ=vɴMor(N=@5%+FKʄ99R4qMtrǴz{}M# o[!AY$-דt:f Hyx?s_ qi$`4_Sj袊2Ky asVs4{yGV9;@g'κe;1"}P60\:#Ėጰ w}To_Ǔ5 `w12 e@@늌CT,B JHG֒IE` dw/ӃjGSuG+۾۽2}2оҰ. ɇ O>1NUꖷX;HI*O,Wi9?<՟7ZՁ'qъ5QnSQu[Ԯ 灗Q9k_TM}Uu U2 +q{㎧7#4O97/8=IWHDi-NgH>.RM63Y^{g?K$Q0rr׽otsH 8:ǿѼ;f`yOTN>*sx/ >},b$ŏ?^=Nk p4R-Ӯr=9AMkEsI7=Cg?PCVL7&y|͸\>Q:qjVF[k&)"ч0E])p @#LR#8lXIʙ7֩}pNH'J@_~B2kXS}NaK]GB?c00=9{mV<Poc'8)Xɕvc=~lηƎ]e'*U</ªti?aܬQ\O,L1*p R,#$yA۰s;ܾm4rzF>Zӭ渴XfK\-QRѝZWk}=l3AgŎOusYP_$?33Mh.6 B "獠TzĐX0O Y?ur?t( t;=#Mr>#ab"뿑|ik(W& m>`ϩ`[sZTjqc?hT'Y?$9bdΟ$}>G)e{-d+ۿݺpY&Kw\Y6-G%Gx_HMeuˌ X~6?Yjns*MR~NZ_c %wt21 $~$ˤPU- l }*)y/Χ{G߅Wh%H2QO^?3KJv88YmFIcҫ%, ˇFg%z֭P(O,H>%aܱg&IsTUbg+4A$ 6o@s'Xd;O219<{j">V"Vo7Kb'eR,Q=0űzu񩠸QjvoOǷb# Łs,Z+mf0O!㧾Ui&ZSMIzx6ym!$CNXPpNA?54rk"R((((((((('ڿyMo?P'ڿyMo?IEPEPEPEPEP\Ƌ#ߊݳm]=s/~)vEtQEStFe, ^3fn4 m`+g$Zb[wR3qgR*% KЉ3|ǏM ܾHo-^1 k=Kh2ppOZ.]|x+rF!`[85IQg?A5s',!ċG_$7l iOI`9 E<K3z&0N}?JәBlמ4ٻ~4Dq9f#f70C,f:%*wZk|F ֮0 1@[ rA8UFiKkF#Ok2u&-u=E%Omx&*)plǠ'5gWk "2% ZD$d1,llZ8me)%Kkihu!8ƹNM[Kn Խ v側z5u0;2{w^UWir"5Kck[.ȡĊ0y?FSr W rpAb~U>te0s&dĮ}ƵƏ?tS{H_R#O<o1b $bxT\ ~G>%-֤E#ns'?XvKC$p2l劣iN#$ L{d>GMtkO%obeRK$7 Icg3MpRF8\?PEsڽ\q+E ;4B0UN~]>}KqH$WP]I`GOͻOs?+:o K)*grIh] ;˕t'm}j)B@<zo?shלJq{Dwt\t-ˑjZ&3.lP~Ucw ߀:{UTJ bfFYlǁ[@[8e2@SV}F#jaW4sSΗd :1V#QI$A4{+,Vv .]s֫Fq{b X||?/jAhu?g{7VKkei# /1aϾRۑM٪ș鮣m[LDbAw35g%MC}A4nK 5=_Hb@.iF_ŠIoTYL:ŭKWH,N1gSb5\vq/ ʲBQBfXb)ڬC ןev98@Z\OUx'ki ב }A4Fh\219a8ш&w {rJLi!c8@?7?sTpJ+j׷j](Oecx67: qv1?IWJ4ES_S*+9Xw|}Ej`z斮QE B dasd*w=ERS9'ˈ .MBww yNn1m\m'ܙʂvGAK;XنC<ZA qڥ7r%M6 A#-UQ@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@$[W)W/$[W)W/ ((((3Eyާ߲\jwگtmn6[_\h``AT85rLm.Y%MvuEf,ܰU!A<5k{O-~͕nd d 7ۘ.o-hٍѰa((kqsY^k[ic,+^HFV'nVre8xϱӥ5b_L[z*,d2s3*qUNqU떑Č"Ĝ#΋ !Qo4!$¹`֟8)ji|+C&vĥw+azU{( dYyc$fM|vuPwfNe zi=pY*+&Io~;ζngЫ~oqK8lʪ>X>`A?C.fЉPΈ&|m@vb%8wn{#{W`c.7:Kk+~6"۵rTM'Q_4T_"5eHIU-Ud6׌ygq?W"Sj`wi^)8_((((((((((((((((((('ڿyMo?P'ڿyMo?IEPEPEPEP-kiA{mUifa7FqԐO#ӴM'Okh ''p2I?XtIU A@KmB:oPqN PZXH j۬}?F]g?@QEQEJu0GA?Ү^ mPJF8듅u[PmVmAjc+CP(GNEGuXÔܤn8-VQspv`b!/j'] Vaʅ {9!G(πuiy/Q,,R.JݸNQLaEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPg?Vo?VoJ( ( ( ( ( e݃A5X&6(()F%8EPjQ@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@$[W)W/$[W)W/ (((((+OYvgh:>q&l&Gl$gEd)i_V4ܾ-)#cʺX9ZSßҿ? b9%'j'ފtN. ˻HmnckgGʬ+c ((5Mu +dӦk;D tUbTh˛_]g[o w?fbi@pA\<JWO7VWF{8++*{c'訢(((kOC/ :g-kd\yfp6yN)Ssqoo{q'N"fHep}ׇP ͰZEy#V'*޷h((_P.;XOat.VFn'?13'ր:Z+}c ֐No=3g(w7LO$WCZ}he6şk(#q$py94~(((iݿ"6ZIF"BvV1򜀭x>&P}Nf(&$r]G`L6@'4P:Q@Q@Q@#|kw-֚ihuyu+4WW;;T&va>e84\[s1_>u+{{wXR0ku;XIy]QEQEQQmo1b“?E'Z+м\lڄɧ Dד{"j7W+5^FWm[iڬC;B?IYQEQEQEQEQEQEQER=^!cq$m]e8$d#Dbļ~U-.Vruܬ B;xq[kQDD `; S((( -;>zVK}:Ŗc崅9,ONӤ12;h$q!ފw*~}kn(((dХA(&9H#Ȭ;dAj5Kslc}NEX4)Eo@ڃQ#}:O-Pv5EQEQER2GPE-g OtbMԬbc_d0=L|5Q5#jM`Lrz֢ ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (?mets/vignettes/header.org0000644000176200001440000000241413623061405015174 0ustar liggesusers#+LATEX_CLASS: tufte-handout+listings #+LATEX_CLASS_OPTIONS: [a4paper] #+PROPERTY: header-args:R :session *R* :cache no :width 550 :height 450 #+PROPERTY: header-args :eval never-export :exports both :results output :tangle yes :comments yes #+PROPERTY: header-args:R+ :colnames yes :rownames no :hlines yes #+PROPERTY: header-args:R+ :wrap example #+PROPERTY: tangle yes #+OPTIONS: timestamp:t title:t date:t author:t creator:nil toc:t #+OPTIONS: h:4 num:t tags:nil d:t #+LATEX_HEADER: \setlength{\parindent}{0pt} % Kills annoying indents. #+LATEX_HEADER: \newcommand{\n}{} #+STARTUP: hideall #+OPTIONS: toc:t h:4 num:nil #+HTML_HEAD: #+HTML_HEAD: #+BEGIN_EXPORT html \( \newcommand{\cov}{\mathbb{C}\text{ov}} \newcommand{\cor}{\mathbb{C}\text{or}} \newcommand{\var}{\mathbb{V}\text{ar}} \newcommand{\E}{\mathbb{E}} \newcommand{\unitfrac}[2]{#1/#2} \newcommand{\n}{} \) #+END_EXPORT mets/vignettes/basic-dutils.ltx0000644000176200001440000010177113623061405016355 0ustar liggesusers%\VignetteIndexEntry{Manipulation of data-frame data with dutility functions} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Manipulation of data-frame data with dutility functions} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Manipulation of data-frame data with dutility functions}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Simple data manipulation for data-frames} \label{sec:orge9cc1d9} \begin{itemize} \item Renaming variables, Deleting variables \item Looking at the data \item Making new variales for the analysis \item Making factors (groupings) \item Working with factors \item Making a factor from existing numeric variable and vice versa \end{itemize} Here are some key data-manipulation steps on a data-frame which is how we typically organize our data in R. After having read the data into R it will typically be a data-frame, if not we can force it to be a data-frame. The basic idea of the utility functions is to get a simple and easy to type way of making simple data-manipulation on a data-frame much like what is possible in SAS or STATA. The functions, say, dcut, dfactor and so on are all functions that basically does what the base R cut, factor do, but are easier to use in the context of data-frames and have additional functionality. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) data(melanoma) \end{lstlisting} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} is.data.frame(melanoma) \end{lstlisting} \begin{verbatim} [1] TRUE \end{verbatim} Here we work on the melanoma data that is already read into R and is a data-frame. \section*{dUtility functions} \label{sec:org995ef5a} The structure for all functions is \begin{itemize} \item dfunction(dataframe,y\textasciitilde{}x|ifcond,\ldots{}) \end{itemize} to use the function on y in a dataframe grouped by x if condition ifcond is valid. The basic functions are Data processing \begin{itemize} \item dsort \item dreshape \item dcut \item drm, drename, ddrop, dkeep, dsubset \item drelevel \item dlag \item dfactor, dnumeric \end{itemize} Data aggregation \begin{itemize} \item dby, dby2 \item dscalar, deval, daggregate \item dmean, dsd, dsum, dquantile, dcor \item dtable, dcount \end{itemize} Data summaries \begin{itemize} \item dhead, dtail, \item dsummary, \item dprint, dlist, dlevels, dunique \end{itemize} A generic function daggregate, daggr, can be called with a function as the argument \begin{itemize} \item daggregate(dataframe,y\textasciitilde{}x|ifcond,fun=function,\ldots{}) \end{itemize} without the grouping variable (x) \begin{itemize} \item daggregate(dataframe,\textasciitilde{}y|ifcond,fun=function,\ldots{}) \end{itemize} A useful feature is that y and x as well as the subset condition can be specified using regular-expressions or by wildcards (default). Here to illustrate this, we compute the means of certain variables. First just oveall \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dmean(melanoma,~thick+I(log(thick))) \end{lstlisting} \begin{verbatim} thick I(log(thick)) 291.985366 5.223341 \end{verbatim} now only when days>500 \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dmean(melanoma,~thick+I(log(thick))|I(days>500)) \end{lstlisting} \begin{verbatim} thick I(log(thick)) 271.582011 5.168691 \end{verbatim} and now after sex but only when days>500 \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dmean(melanoma,thick+I(log(thick))~sex|I(days>500)) \end{lstlisting} \begin{verbatim} sex thick I(log(thick)) 1 0 242.9580 5.060086 2 1 320.2429 5.353321 \end{verbatim} and finally after quartiles of days (via the dcut function) \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dmean(melanoma,thick+I(log(thick))~I(dcut(days))) \end{lstlisting} \begin{verbatim} I(dcut(days)) thick I(log(thick)) 1 [10,1.52e+03] 482.1731 5.799525 2 (1.52e+03,2e+03] 208.5490 4.987652 3 (2e+03,3.04e+03] 223.2941 4.974759 4 (3.04e+03,5.56e+03] 250.1961 5.120129 \end{verbatim} or summary of all variables starting with "s" and that contains "a" \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dmean(melanoma,"s*"+"*a*"~sex|I(days>500)) \end{lstlisting} \begin{verbatim} sex status days 1 0 1.831933 2399.143 2 1 1.714286 2169.800 \end{verbatim} \section*{Renaming, deleting, keeping, dropping variables} \label{sec:orgb2de04c} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} melanoma=drename(melanoma,tykkelse~thick) names(melanoma) \end{lstlisting} \begin{verbatim} [1] "no" "status" "days" "ulc" "tykkelse" "sex" \end{verbatim} Deleting variables \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) melanoma=drm(melanoma,~thick+sex) names(melanoma) \end{lstlisting} \begin{verbatim} [1] "no" "status" "days" "ulc" \end{verbatim} or sas style \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) melanoma=ddrop(melanoma,~thick+sex) names(melanoma) \end{lstlisting} \begin{verbatim} [1] "no" "status" "days" "ulc" \end{verbatim} alternatively we can also keep certain variables \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) melanoma=dkeep(melanoma,~thick+sex+status+days) names(melanoma) \end{lstlisting} \begin{verbatim} [1] "thick" "sex" "status" "days" \end{verbatim} This can also be done with direct asignment \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) ddrop(melanoma) <- ~thick+sex names(melanoma) \end{lstlisting} \begin{verbatim} [1] "no" "status" "days" "ulc" \end{verbatim} \section*{Looking at the data} \label{sec:orgae42906} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) dstr(melanoma) \end{lstlisting} \begin{verbatim} 'data.frame': 205 obs. of 6 variables: $ no : int 789 13 97 16 21 469 685 7 932 944 ... $ status: int 3 3 2 3 1 1 1 1 3 1 ... $ days : int 10 30 35 99 185 204 210 232 232 279 ... $ ulc : int 1 0 0 0 1 1 1 1 1 1 ... $ thick : int 676 65 134 290 1208 484 516 1288 322 741 ... $ sex : int 1 1 1 0 1 1 1 1 0 0 ... \end{verbatim} The data can in Rstudio be seen as a data-table but to list certain parts of the data in output window \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dlist(melanoma) \end{lstlisting} \begin{verbatim} no status days ulc thick sex 1 789 3 10 1 676 1 2 13 3 30 0 65 1 3 97 2 35 0 134 1 4 16 3 99 0 290 0 5 21 1 185 1 1208 1 --- 201 317 2 4492 1 706 1 202 798 2 4668 0 612 0 203 806 2 4688 0 48 0 204 606 2 4926 0 226 0 205 328 2 5565 0 290 0 \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dlist(melanoma, ~.|sex==1) \end{lstlisting} \begin{verbatim} no status days ulc thick 1 789 3 10 1 676 2 13 3 30 0 65 3 97 2 35 0 134 5 21 1 185 1 1208 6 469 1 204 1 484 --- 191 445 2 3909 1 806 195 415 2 4119 0 65 197 175 2 4207 0 65 198 493 2 4310 0 210 201 317 2 4492 1 706 \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dlist(melanoma, ~ulc+days+thick+sex|sex==1) \end{lstlisting} \begin{verbatim} ulc days thick sex 1 1 10 676 1 2 0 30 65 1 3 0 35 134 1 5 1 185 1208 1 6 1 204 484 1 --- 191 1 3909 806 1 195 0 4119 65 1 197 0 4207 65 1 198 0 4310 210 1 201 1 4492 706 1 \end{verbatim} Getting summaries \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dsummary(melanoma) \end{lstlisting} \begin{verbatim} no status days ulc thick Min. : 2.0 Min. :1.00 Min. : 10 Min. :0.000 Min. : 10 1st Qu.:222.0 1st Qu.:1.00 1st Qu.:1525 1st Qu.:0.000 1st Qu.: 97 Median :469.0 Median :2.00 Median :2005 Median :0.000 Median : 194 Mean :463.9 Mean :1.79 Mean :2153 Mean :0.439 Mean : 292 3rd Qu.:731.0 3rd Qu.:2.00 3rd Qu.:3042 3rd Qu.:1.000 3rd Qu.: 356 Max. :992.0 Max. :3.00 Max. :5565 Max. :1.000 Max. :1742 sex Min. :0.0000 1st Qu.:0.0000 Median :0.0000 Mean :0.3854 3rd Qu.:1.0000 Max. :1.0000 \end{verbatim} or for specfic variables \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dsummary(melanoma,~thick+status+sex) \end{lstlisting} \begin{verbatim} thick status sex Min. : 10 Min. :1.00 Min. :0.0000 1st Qu.: 97 1st Qu.:1.00 1st Qu.:0.0000 Median : 194 Median :2.00 Median :0.0000 Mean : 292 Mean :1.79 Mean :0.3854 3rd Qu.: 356 3rd Qu.:2.00 3rd Qu.:1.0000 Max. :1742 Max. :3.00 Max. :1.0000 \end{verbatim} Summaries in different groups (sex) \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dsummary(melanoma,thick+days+status~sex) \end{lstlisting} \begin{verbatim} sex: 0 thick days status Min. : 10.0 Min. : 99 Min. :1.000 1st Qu.: 97.0 1st Qu.:1636 1st Qu.:2.000 Median : 162.0 Median :2059 Median :2.000 Mean : 248.6 Mean :2283 Mean :1.833 3rd Qu.: 306.0 3rd Qu.:3131 3rd Qu.:2.000 Max. :1742.0 Max. :5565 Max. :3.000 ------------------------------------------------------------ sex: 1 thick days status Min. : 16.0 Min. : 10 Min. :1.000 1st Qu.: 105.0 1st Qu.:1052 1st Qu.:1.000 Median : 258.0 Median :1860 Median :2.000 Mean : 361.1 Mean :1946 Mean :1.722 3rd Qu.: 484.0 3rd Qu.:2784 3rd Qu.:2.000 Max. :1466.0 Max. :4492 Max. :3.000 \end{verbatim} and only among those with thin-tumours or only females (sex==1) \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dsummary(melanoma,thick+days+status~sex|thick<97) \end{lstlisting} \begin{verbatim} sex: 0 thick days status Min. :10.00 Min. : 355 Min. :1.000 1st Qu.:32.00 1st Qu.:1762 1st Qu.:2.000 Median :64.00 Median :2227 Median :2.000 Mean :51.48 Mean :2425 Mean :2.034 3rd Qu.:65.00 3rd Qu.:3185 3rd Qu.:2.000 Max. :81.00 Max. :4688 Max. :3.000 ------------------------------------------------------------ sex: 1 thick days status Min. :16.00 Min. : 30 Min. :1.000 1st Qu.:30.00 1st Qu.:1820 1st Qu.:2.000 Median :65.00 Median :2886 Median :2.000 Mean :55.75 Mean :2632 Mean :1.875 3rd Qu.:81.00 3rd Qu.:3328 3rd Qu.:2.000 Max. :81.00 Max. :4207 Max. :3.000 \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dsummary(melanoma,thick+status~+1|sex==1) \end{lstlisting} \begin{verbatim} thick status Min. : 16.0 Min. :1.000 1st Qu.: 105.0 1st Qu.:1.000 Median : 258.0 Median :2.000 Mean : 361.1 Mean :1.722 3rd Qu.: 484.0 3rd Qu.:2.000 Max. :1466.0 Max. :3.000 \end{verbatim} or \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dsummary(melanoma,~thick+status|sex==1) \end{lstlisting} \begin{verbatim} thick status Min. : 16.0 Min. :1.000 1st Qu.: 105.0 1st Qu.:1.000 Median : 258.0 Median :2.000 Mean : 361.1 Mean :1.722 3rd Qu.: 484.0 3rd Qu.:2.000 Max. :1466.0 Max. :3.000 \end{verbatim} To make more complex conditions need to use the I() \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dsummary(melanoma,thick+days+status~sex|I(thick<97 & sex==1)) \end{lstlisting} \begin{verbatim} sex: 1 thick days status Min. :16.00 Min. : 30 Min. :1.000 1st Qu.:30.00 1st Qu.:1820 1st Qu.:2.000 Median :65.00 Median :2886 Median :2.000 Mean :55.75 Mean :2632 Mean :1.875 3rd Qu.:81.00 3rd Qu.:3328 3rd Qu.:2.000 Max. :81.00 Max. :4207 Max. :3.000 \end{verbatim} Tables between variables \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dtable(melanoma,~status+sex) \end{lstlisting} \begin{verbatim} sex 0 1 status 1 28 29 2 91 43 3 7 7 \end{verbatim} All bivariate tables \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dtable(melanoma,~status+sex+ulc,level=2) \end{lstlisting} \begin{verbatim} status sex 1 2 3 0 28 91 7 1 29 43 7 status ulc 1 2 3 0 16 92 7 1 41 42 7 sex ulc 0 1 0 79 36 1 47 43 \end{verbatim} All univariate tables \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dtable(melanoma,~status+sex+ulc,level=1) \end{lstlisting} \begin{verbatim} status 1 2 3 57 134 14 sex 0 1 126 79 ulc 0 1 115 90 \end{verbatim} and with new variables \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dtable(melanoma,~status+sex+ulc+dcut(days)+I(days>300),level=1) \end{lstlisting} \begin{verbatim} status 1 2 3 57 134 14 sex 0 1 126 79 ulc 0 1 115 90 dcut(days) [10,1.52e+03] (1.52e+03,2e+03] (2e+03,3.04e+03] (3.04e+03,5.56e+03] 52 51 51 51 I(days > 300) FALSE TRUE 11 194 \end{verbatim} \section*{Sorting the data} \label{sec:org4adbc9e} To sort the data \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) mel= dsort(melanoma,~days) dsort(melanoma) <- ~days head(mel) \end{lstlisting} \begin{verbatim} no status days ulc thick sex 1 789 3 10 1 676 1 2 13 3 30 0 65 1 3 97 2 35 0 134 1 4 16 3 99 0 290 0 5 21 1 185 1 1208 1 6 469 1 204 1 484 1 \end{verbatim} and to sort after multiple variables increasing and decreasing \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dsort(melanoma) <- ~days-status head(melanoma) \end{lstlisting} \begin{verbatim} no status days ulc thick sex 1 789 3 10 1 676 1 2 13 3 30 0 65 1 3 97 2 35 0 134 1 4 16 3 99 0 290 0 5 21 1 185 1 1208 1 6 469 1 204 1 484 1 \end{verbatim} \section*{Making new variales for the analysis} \label{sec:orgb492e14} To define a bunch of new covariates within a data-frame \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) melanoma= transform(melanoma, thick2=thick^2, lthick=log(thick) ) dhead(melanoma) \end{lstlisting} \begin{verbatim} no status days ulc thick sex thick2 lthick 1 789 3 10 1 676 1 456976 6.516193 2 13 3 30 0 65 1 4225 4.174387 3 97 2 35 0 134 1 17956 4.897840 4 16 3 99 0 290 0 84100 5.669881 5 21 1 185 1 1208 1 1459264 7.096721 6 469 1 204 1 484 1 234256 6.182085 \end{verbatim} When the above definitions are done using a condition this can be achieved using the dtransform function that extends transform with a possible condition \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} melanoma=dtransform(melanoma,ll=thick*1.05^ulc,sex==1) melanoma=dtransform(melanoma,ll=thick,sex!=1) dmean(melanoma,ll~sex+ulc) \end{lstlisting} \begin{verbatim} sex ulc ll 1 0 0 173.7342 2 1 0 197.3611 3 0 1 374.5532 4 1 1 523.1198 \end{verbatim} \section*{Making factors (groupings)} \label{sec:orgca893e7} On the melanoma data the variable thick gives the thickness of the melanom tumour. For some analyses we would like to make a factor depending on the thickness. This can be done in several different ways \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} melanoma=dcut(melanoma,~thick,breaks=c(0,200,500,800,2000)) \end{lstlisting} New variable is named thickcat.0 by default. To see levels of factors in data-frame \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat.0 #levels=:4 [1] "[0,200]" "(200,500]" "(500,800]" "(800,2e+03]" ----------------------------------------- \end{verbatim} Checking group sizes \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dtable(melanoma,~thickcat.0) \end{lstlisting} \begin{verbatim} thickcat.0 [0,200] (200,500] (500,800] (800,2e+03] 109 64 20 12 \end{verbatim} With adding to the data-frame directly \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dcut(melanoma,breaks=c(0,200,500,800,2000)) <- gr.thick1~thick dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat.0 #levels=:4 [1] "[0,200]" "(200,500]" "(500,800]" "(800,2e+03]" ----------------------------------------- gr.thick1 #levels=:4 [1] "[0,200]" "(200,500]" "(500,800]" "(800,2e+03]" ----------------------------------------- \end{verbatim} new variable is named thickcat.0 (after first cut-point), or to get quartiles with default names thick.cat.4 \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dcut(melanoma) <- ~ thick # new variable is thickcat.4 dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat.0 #levels=:4 [1] "[0,200]" "(200,500]" "(500,800]" "(800,2e+03]" ----------------------------------------- gr.thick1 #levels=:4 [1] "[0,200]" "(200,500]" "(500,800]" "(800,2e+03]" ----------------------------------------- thickcat.4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- \end{verbatim} or median groups, here starting again with the original data, \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) dcut(melanoma,breaks=2) <- ~ thick # new variable is thick.2 dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat.2 #levels=:2 [1] "[10,194]" "(194,1.74e+03]" ----------------------------------------- \end{verbatim} to control new names \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) mela= dcut(melanoma,thickcat4+dayscat4~thick+days,breaks=4) dlevels(mela) \end{lstlisting} \begin{verbatim} thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- dayscat4 #levels=:4 [1] "[10,1.52e+03]" "(1.52e+03,2e+03]" "(2e+03,3.04e+03]" [4] "(3.04e+03,5.56e+03]" ----------------------------------------- \end{verbatim} or \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) dcut(melanoma,breaks=4) <- thickcat4+dayscat4~thick+days dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- dayscat4 #levels=:4 [1] "[10,1.52e+03]" "(1.52e+03,2e+03]" "(2e+03,3.04e+03]" [4] "(3.04e+03,5.56e+03]" ----------------------------------------- \end{verbatim} This can also be typed out more specifically \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} melanoma$gthick = cut(melanoma$thick,breaks=c(0,200,500,800,2000)) melanoma$gthick = cut(melanoma$thick,breaks=quantile(melanoma$thick),include.lowest=TRUE) \end{lstlisting} \section*{Working with factors} \label{sec:orgb002bf7} To see levels of covariates in data-frame \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) dcut(melanoma,breaks=4) <- thickcat4~thick dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- \end{verbatim} To relevel the factor \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dtable(melanoma,~thickcat4) melanoma = drelevel(melanoma,~thickcat4,ref="(194,356]") dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat4 [10,97] (97,194] (194,356] (356,1.74e+03] 56 53 45 51 thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- thickcat4.(194,356] #levels=:4 [1] "(194,356]" "[10,97]" "(97,194]" "(356,1.74e+03]" ----------------------------------------- \end{verbatim} or to take the third level in the list of levels, same as above, \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} melanoma = drelevel(melanoma,~thickcat4,ref=2) dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- thickcat4.(194,356] #levels=:4 [1] "(194,356]" "[10,97]" "(97,194]" "(356,1.74e+03]" ----------------------------------------- thickcat4.2 #levels=:4 [1] "(97,194]" "[10,97]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- \end{verbatim} To combine levels of a factor (first combinining first 3 groups into one) \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} melanoma = drelevel(melanoma,~thickcat4,newlevels=1:3) dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- thickcat4.(194,356] #levels=:4 [1] "(194,356]" "[10,97]" "(97,194]" "(356,1.74e+03]" ----------------------------------------- thickcat4.2 #levels=:4 [1] "(97,194]" "[10,97]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- thickcat4.1:3 #levels=:2 [1] "[10,97]-(194,356]" "(356,1.74e+03]" ----------------------------------------- \end{verbatim} or to combine groups 1 and 2 into one group and 3 and 4 into another \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dkeep(melanoma) <- ~thick+thickcat4 melanoma = drelevel(melanoma,gthick2~thickcat4,newlevels=list(1:2,3:4)) dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- gthick2 #levels=:2 [1] "[10,97]-(97,194]" "(194,356]-(356,1.74e+03]" ----------------------------------------- \end{verbatim} Changing order of factor levels \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dfactor(melanoma,levels=c(3,1,2,4)) <- thickcat4.2~thickcat4 dlevel(melanoma,~ "thickcat4*") dtable(melanoma,~thickcat4+thickcat4.2) \end{lstlisting} \begin{verbatim} thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- thickcat4.2 #levels=:4 [1] "(194,356]" "[10,97]" "(97,194]" "(356,1.74e+03]" ----------------------------------------- thickcat4.2 (194,356] [10,97] (97,194] (356,1.74e+03] thickcat4 [10,97] 0 56 0 0 (97,194] 0 0 53 0 (194,356] 45 0 0 0 (356,1.74e+03] 0 0 0 51 \end{verbatim} Combine levels but now control factor-level names \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} melanoma=drelevel(melanoma,gthick3~thickcat4,newlevels=list(group1.2=1:2,group3.4=3:4)) dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- gthick2 #levels=:2 [1] "[10,97]-(97,194]" "(194,356]-(356,1.74e+03]" ----------------------------------------- thickcat4.2 #levels=:4 [1] "(194,356]" "[10,97]" "(97,194]" "(356,1.74e+03]" ----------------------------------------- gthick3 #levels=:2 [1] "group1.2" "group3.4" ----------------------------------------- \end{verbatim} \section*{Making a factor from existing numeric variable and vice versa} \label{sec:orgdcd4633} A numeric variable "status" with values 1,2,3 into a factor by \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) melanoma = dfactor(melanoma,~status, labels=c("malignant-melanoma","censoring","dead-other")) melanoma = dfactor(melanoma,sexl~sex,labels=c("females","males")) dtable(melanoma,~sexl+status.f) \end{lstlisting} \begin{verbatim} status.f malignant-melanoma censoring dead-other sexl females 28 91 7 males 29 43 7 \end{verbatim} A gender factor with values "M", "F" can be converted into numerics by \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} melanoma = dnumeric(melanoma,~sexl) dstr(melanoma,"sex*") dtable(melanoma,~'sex*',level=2) \end{lstlisting} \begin{verbatim} 'data.frame': 205 obs. of 3 variables: $ sex : int 1 1 1 0 1 1 1 1 0 0 ... $ sexl : Factor w/ 2 levels "females","males": 2 2 2 1 2 2 2 2 1 1 ... $ sexl.n: num 2 2 2 1 2 2 2 2 1 1 ... sex sexl 0 1 females 126 0 males 0 79 sex sexl.n 0 1 1 126 0 2 0 79 sexl sexl.n females males 1 126 0 2 0 79 \end{verbatim} \end{document}mets/vignettes/rec6.jpg0000644000176200001440000005770113623061405014605 0ustar liggesusersJFIFC    $.' ",#(7),01444'9=82<.342C  2!!22222222222222222222222222222222222222222222222222&" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ('}R\ej9bI'ڀ7hkk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5עS]Aqo3*c kv ( ( ( ( (vlXe8|MCx J+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5sU\֑ % kUIں((&EPEPEPEPEyݭ,|Su+\9Khr|%Lx+пԝwWpb/ G@ՏˬkYDUϩc鮯Md` ( ( ( ( ( ( ( ( ( ( B 'ނBf 2IQD2# a'(6F+n5X6_uᭊQEQEQEW3)+>O3Wh6v.ݬ6[,T3U3^\A}iܻ]^9w(TVT@bpm@ucج}33@QEQEQEQEQEQEQEQEQEQEQP͙\@:>0o j̧ ACZV?Voօ{ET%Q@Q@Q@Q@8/u B 5tKYL%M2\;@+/P͵[I\\ &7D]0>U"(UQ*z}+^X\)rEsaٝ Q k{O-(((((((((gaC;ƾg}~E?7?z[B(:LKd鸻 ~'ȚE ҷL ajeZJ[ lV=Wz8kbaEPEPEP&iv6:k_]$~p۸䃓P9lV~Kk^Isőkbop,e?ŌL^-!@ &7OcKe>buT||̣ϧM< s@0Lr27A;Lt[!ʤr Wk\Ǎ>a_h((((((((((H#Bdw=65,?3)\~G *סlڜb7ʼɼ@O j!f 5o?dj1k<ɳQkǴ_IQEQEQEQEQEW1l[WO\Ƌ#ߊݳm@=Q@Q@Q@Q@Q@Q@Q@Q@T-#H" /ҁq.b u`=OD?s{}94`lUSk]ć8b+jEy.VI.}@3=[8ڨ>.d;^#o!5.^2 R=B TZ -6>Sm};0&{7Wܿtpcۥ׭+#@((((cƟs@կ51Oj袊((((((((* [&v=>˭+H81~DEblf_ W(/hC+PprF{jb!U{uck@Z/138sߥn}t̞w lߧH?o?dj$sڵ/ Q%Q@Q@Q@Q@}zvi 1.{[ՌH[+tw#v&Cq?EM;ApCA 4_Sj*`>Al6((((((()f8dbX[#ډ`vӱF"`D\G / 8=GWj)&;*\?SO@A-埸SVm2@'i;VJ bpOcOOWq-^U-IGЏt6q\b&^ħU!L%ln#2ymmksHiԢ(vIrA9=' Ei%<© GzzM:խ+H˶-׏A׏sHA_jۥ׭+F+n5Y(((([Ś橢]A-ŻXݒI8@2sQvTVj7ڕx[EȕEڋ*rW`:)I߫/ i~f殡<|8]6AV{{#V5`#{"ڳ$(QEQEQEGAo5 ǶV*'sN7hA8kx6-OÂ#.1hce[0I=tF˄]-HAE$E NOk'M]^OdS<*GEsa d1_݅uh=?EQEQEQEQEQEQET2_I#,Fq簪ٗ?~;?„;\U2*cu|TJȇ}q|a}On?p ܶ3="Ǿ"/ɇ<;AUd7_w~Mf .ʇ cc;mG1y0y=rAZX>`_!H`{Ri!.!dIfv?>;Wm_S~^I{#d@I$vԟnܶ5t y#BO>KO#*H:WY0 H`؏Bkj8ѮUl,{tk6^Lu_rJ[ lV=Wz8kb((( ]kY,t6+۴UY^+ȅ %-" |s8+sKaKWeÒNh`hY|| r@aɐ<)$Ǟ#8zY[{;YK Q98"ff6~wV9 {qG*ss۹ s?[*Z+Krjz`Cϩ"F<k^r@T{atW oihTq{ rg7޵lm JZDF٥|r8tQ{_[M ,k7 W: F}vkJ=p*sQE((((+{O-cE?趠(((((()ldWЍ4ŏ܇?jyrm囇]*Nq֫*%e)U'd\twV߾,bfo^Ј\PIȣq+M69eԒG}­Nwr,x4]TgH@,h*`|5`Xactqs$G[ju߷EwzA kvmnir?rà cvm#Ckhq.z=Zgm426}\FUp0~\~~F5TUHֳ擻3/?mҿ[y#n^_جQEQEQEQExhfzi4rFdI'f9;s`gO_:&ݼ 9>ޝ:&H2w~^^Сri$z}x6ïpG*LYpmLOƔ1yP sq#> UTJƵG'VX|#D@#5o?gº)kB=p*DQEQEQEQEWi_b7RÛi4''RT wNNH" [ I|uw +\.pH4\Ƌ#ߊݳm]=s/~)vEtQEQEQEQEQEQE 6B7 G\}*EV;(JhQ NE,+vzn.8bpwnw}sV-M.7(dO*ܲ=lw%k5k+qbͷ y9O,z w3/g_HdGtT,8Pz$?SMmI?lLuarbj *sV<׮}!&IIsgvA}:`s7h ץ%o?Wh2 2=Җl` 8xVI.'=?dº3FKqt#g(f;O_|*%.+wwvl I9KH2ը we 9aI';Gze$&F+n5X6_uᭊ ( ( ( +e Վ'[OI n -*@ԯ.u Sմn]l *+* pT8^6y}VO\Ǎ>a_h((((((kۢϙp ?s:L$j;Wwƒ1mJZidgpC.}H"X[F!W >g <ԒJOp-ʳM޹nX12s2mY"B7.pNSq^%sr~i2pNn1MȭהV>Չ?b IEPEPEs$olu-+N{&.oў=˷lJ.]sUͩxE(`K+/K4rB3F:r((źjs5imwi7ڭc TNv oqmZZG ^]bBʷ2(a `7ܒ{[I 1["$0I  >=gv0xB#3ci0YZmG a;Ggڀ:z( ( ( ( ( (vp2h4 S?Xڦ;d@cyz8ϥi:, 3ןOo¸wVwm(>S Oz֔}BRN}^zw-D6wҦCx7~pz=Iᐠ} [' $`sMY#a*vq'-ojwaP_,i2>m"0 iА\[I0Ls=EFO-FYPϜ^ϧM yAVr85]x :G6db'NHFvq֑I`X{#QQr~P9ֱΓ$)B28<z4]]pAҥhfxEm_ _hʨxEm_ _hʀ$((mZ;rĹ 6%@DebXcG~zU? XxIMn6om<A w@^pRxt4xO|u ,03ڏ 6ZZ4'07!-~s1(((cE?趮Ggڀ:z( ( ( ( ( RcX\2Fc3Q]UPG Vy,|+vrI#Oz[lVgE`ێ?v=p}k~ M"o!ʜ 1'mUZ?̒/&EV!n=3&`!p277Z6 `vtgSՃwfhEL@z(((ǼJ[ lV=Wz8kb (*fo9.&ӕ 9bGkȢ5,X#nKm&?笫ǥ{+ȰHPwM[223#\͍&Gt{&'>xF@UQ@Q@s4}VOEPEPEPEPEPEP2T}t5xR9 WɞHB~t) S&6ד`X`۷.F=)ڭhmWpÁz7:u_]y1b"Vć)b; lf9XmV~T. D\.>E r}r^PK+IǦ3׾9n|&#NHf.xVw^5$r@Q!v.T(? R_D`2ޟAڤ,('ڿyMo?P'ڿyMo?IEPEP?eY"Ic*#+#S^M{mEwFSF['Zrܻ5'XO źEEuvkB73~_{2C ʃTU?\{߇FGv gR88mٷṭpÆ-=+Xm% $e|$yn8վ`t˖6tlFHXv ù9np+O:$5 !h*WqGvh@FaE_ҭE֠#PXG >^FN3Cᮩ>_('7mip,JºZ0 "nUt@!BL:fv6Ē|W,InsjJG57GӬT{dq\lm4 +X-Ј"cvW1l[POEPEPEPEPHHU,H ij $gi=ٙOq ef"Lc)Ͽ_e,MRVtgo0E#X}AWB{;}̦] }6ǞSrR2J`LJisKWy7-MRƒ#Ѱ}Mu}B#=9-otHcw~, x@)+S0$c;'KhÄq 0~5%P6ˡ3y}a3F61yۜqI\_~unl%HY, n>/+jx"w Eq(4 Drl kcƟs@կ4EQEQEQEQEG9gjFL{pKp>Aga{u!Ġzg5 uGe>\R+ߖ];~T$#ý~ŤBh<$~QŽsg{jJ(0((3ğ+j7j{EUCğ+j7j{ET%Q@Q@l4!sv5ИbӮkz݁(F`)czw~m<F=i0#^ܞqOR}B(aEPEPEP=Wz8kb?mҿ[QEēIYc Y xndu y_[Zjv ;F!dHf>O;jrv'\[ yH7Yr1GC\|=Ҟkd$񸓷9 !z8ю1mI=I&w'E ( ( (3,PkzbkLC9o;+m>B9+U3zۈ!-tlۡ]wUpl +}VO\Ǎ>a_h((((gz0A<Zq۷_Lˁki$ǪּƷͨ_ǥ@J,g,8kF SeqKCͼiؠo Y~m9#J4a%w!Pc!_H0>/v^]CAYA8ʩRzm $(,T#,} ՛m}Ȇl$d0RJ'/jzEP@ -sQEQEQEQEO@5~=p*O@5~=p*((((iS~uk>ºZ0 "nUt@!BL:fv6Ē|W,InsjJG57GӬT{dq\lm4 +X-Ј"cvW1l[POEPEPEPT|Å'-죯\66lUxhx?6)(E]mMufYcu'PSWUm&IHiJb 3Ƹ '.lKCpOJ]MMKHF ݏl޺k/ut&zOPbmT v T"ьzӫQEQEQEQEQEy#n^_ج{tpQEQEQEck1f4cc{/}m^xfT.L`ⶨ緊xHaAxB$'m\do\Ǎ>a_h(((yVN3P=]Z+l[I 0L#@nd  j8=+!Ē68?\}81r|xToyO`,=0+o$hR9b8?`6 pϠ>~88*(VT໿?y?-W9!EPEPEPEPEPEPEP=Wz8kb?mҿ[QEQEQEx^nH.4xd ev0r7MV{΋Gf/؊zw>n|W,QG,k"7Uq lZ)lj~B{xnx.!h\aC+Bh:>&=cm0m #c'1Oj袊(ZIqph>'F6rOn+˴kN3 41+{7r={1Aԗ\scyWxO6M2n+dǑ:ǰTaʾ'_թi'߆!߷lv1ozqzZ-rQEQEQEQEQEQEQEfxEm_ _hʨxEm_ _hʀ$(((((cE?趮Ggڀ:z(w'de g$GZi6솓n_Gӥfm[cӹ#ʼ;_xYE˿-<͞T 3$fqS a<:itKmKN|NK$9$J6OztwvpZGmn#A袹n(QEQEQEQEQEQEQEcۥ׭+F+n5@Q@Q@Q@Q@s4}VOE 6qs*uf4W$y$/#*X _\bEk5ʲOÌxWYJQ8ֵh$(((((((((ǼJ[ lV=Wz8kb ( ( ( +dXԦ\:d|Yݹ[h^ᘮAkfvfwrh;dI\ uxhfzYk(捣5?6 x-c5 ?!@ =7P<4.0ȡ\ί].{]Oe!$VȬ9@-ͽ70 hé#'?4(Sßҿ? z++үt,0"B8Ί#+/ Я/&7B<'B? / hz.<q>D7L,bX=FZ#+/ + Я/&B<'Bޢ / k+Jo5 "kQxN'MvtV!_E|_MxO}4E`?_GW_@I"^SǴ_\|-|3`:cEk8=}0QEQEQEQEQEQEQ\h8yuG KrOZ:Jԯ|?mߵϖᤚ<$1,2")n՗M}5`ˉ%Y~nwypZJ+ W^Cs3$776g9i)XOzF+K6!r)a9Eyzw:jS4k[L3rwTZt]ޯ} V\A9I r3. aFH< Q^U&jetMBa]L6@z@xZ[KFI vM?MJH )m\sМ /KS#n Nk}hmhFG' 8^uw{y ^ӣ 2c##=4-Q dյkwI,SUr0NNs (<ϋ,um?췶S^XD{0 n n}zOf>I`cHqqm5-Bzؽ}F^fhFLJUr0NNsz+V]ޮϟ1 < >s +)VkR {۫ճuy&4Q&rrzEso]MzKeS pЁ* LhtW_yjWYtpMYEY ssq]'dZ业?P0A$a)0X20$h(((((D>"è[hDȒ*İȈc c<+$֟% ' 1IǖI's@ GXI$P]>Gݰ'$ \S֩iwF[ʴ.ɱ~bT@EyRͫ/Q k狗Kh15%wCNbf˂QH4VW/|'7CV0.>f@Ǐx^Ú+$ |8̌pu'آ@%}LoKx'o⼻$Ѯ9@T#|鯵-4^ȸs47Ff\Œx%AHMkT<9{umw6)7y1PlQҀ +}c ֐No=3g(w7LO$V.jޟz-ydy3( mT!㓚+/5vktvb!FS,|}dqG:>w,ymsn#E*tRJF s@EPEPEPEPEPEPTlkduNneڠ`zU(/ 6՞ VsMK-ZGW67)e l Hls٢2o<3=Ř/ ,jFDdSUHWPykQEe" HՑ^)䅊67)(8SJ-ܶKbH"CFU!]Tjآ2.5W&0|]gi`8 F@EtMU(-J9vɕ+9˲;TT{(_izI *̹$apr=ACxtP\ҥ >c.hrX;m*U}J RN]drrN,zJ(/K$'u ̮B bB.O\jԢȴcBХgu?dBvlZK? w1$Gi9چ$"r~U(/ 6՞ VV(((((^Kk,{YN6LvՊ(.ORU{RnϚ vd[xwJ_Rԭӗl*K@'kR;h-Bs+DWڵ(0MY-n7[%vSKg];_.#"G?PĄNOʸձEcE]:ZrҙgI61ہ*Zi6f{gggbrYf'Ԓj坶e5+5RHpżz,6WV詙渒Y~y\#Ec LM?Rc:J%99 Ғš%ݍ[`FTlnRA*5E68(8R4UT`:)YUAR@2xgHO&Ւ{ttٙ]He$##˟ hv6rYm8DReQK)`dCcy ,xQcP2#"ʬB Z(/V;I,O$MIFʞ:S./Mo,+x$Xݑ !#*yk@rxwJXړv>|\.3# wúUndPX*=ZPEPEPEPEPEPEPEPEPEPEP{+}Fn$!fe U=AqxH=)3JA 0(\d @N{EC}B4/+fX8gaEb93<9Ǥ<6RwY1D[L!ыHA7aGZg\z`5Ķ`y#y|i0AnaN[h#;x|gc!̵Kxa@h$TH4eSDʒIܬz85F& ~[3[Yl7"JUw;RԴk.V˧*!',+5 G}^^\i+ޘۛoƮ3<O mOf-c2nIhWGB=vРsI,( \sZQEQEQEQEQEQEQEQEQEQEQEQEQEQEQE}p z~(((((((((((((((((D(X`2(((((((((((((((((((((((((((((((((((((((((((mets/vignettes/binomial-family.ltx0000644000176200001440000005721713623061405017050 0ustar liggesusers%\VignetteIndexEntry{Analysis of multivariate binomial data: family analysis} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Analysis of multivariate binomial data: family analysis} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Analysis of multivariate binomial data: family analysis}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Overview} \label{sec:org413d47e} When looking at multivariate binomial data with the aim of learning about the dependence that is present, possibly after correcting for some covariates many models are available. \begin{itemize} \item Random-effects models logistic regression covered elsewhere (glmer in lme4). \end{itemize} in the mets package you can fit the \begin{itemize} \item Pairwise odds ratio model \item Bivariate Probit model \begin{itemize} \item With random effects \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \item Additive gamma random effects model \begin{itemize} \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \end{itemize} These last three models are all fitted in the mets package using composite likelihoods for pairs of data. The models can be fitted specifically based on specifying which pairs one wants to use for the composite score. The models are described in futher details in the binomial-twin vignette. \section*{Simulated family data} \label{sec:org9bae582} We start by simulating family data with and additive gamma structure on ACE form. Here 40000 families consisting of two parents and two children. The response is ybin and there is one covariate x. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) set.seed(100) data <- simbinClaytonOakes.family.ace(40000,2,1,beta=NULL,alpha=NULL) data$number <- c(1,2,3,4) data$child <- 1*(data$number==3) head(data) \end{lstlisting} \begin{verbatim} Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.5.1 mets version 1.2.1.2 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined Warning message: failed to assign RegisteredNativeSymbol for cor to cor since cor is already defined in the ‘mets’ namespace ybin x type cluster number child 1 1 0 mother 1 1 0 2 1 1 father 1 2 0 3 1 1 child 1 3 1 4 1 1 child 1 4 0 5 0 0 mother 2 1 0 6 1 1 father 2 2 0 \end{verbatim} We fit the marginal models, and here find a covariate effect at 0.3 for x. The marginals can be specified excatly as one wants. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} aa <- margbin <- glm(ybin~x,data=data,family=binomial()) summary(aa) \end{lstlisting} \begin{verbatim} Call: glm(formula = ybin ~ x, family = binomial(), data = data) Deviance Residuals: Min 1Q Median 3Q Max -1.5283 -1.3910 0.8632 0.9779 0.9779 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) 0.489258 0.007291 67.1 <2e-16 *** x 0.306070 0.010553 29.0 <2e-16 *** --- Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 206272 on 159999 degrees of freedom Residual deviance: 205428 on 159998 degrees of freedom AIC: 205432 Number of Fisher Scoring iterations: 4 \end{verbatim} \section*{Additive gamma model} \label{sec:org85bea3a} For the additive gamma of this type we set-up the random effects included in such a family to make the ACE valid using some special functions for this. The model is constructe with one enviromental effect shared by all in the family and 8 genetic random effects with size (1/4) genetic variance. Looking at the first family we see that the mother and father both share half the genes with the children and that the two children also share half their genes with this specification. Below we also show an alternative specification of this model using all pairs. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # make ace random effects design out <- ace.family.design(data,member="type",id="cluster") out$pardes head(out$des.rv,4) \end{lstlisting} \begin{verbatim} [,1] [,2] [1,] 0.25 0 [2,] 0.25 0 [3,] 0.25 0 [4,] 0.25 0 [5,] 0.25 0 [6,] 0.25 0 [7,] 0.25 0 [8,] 0.25 0 [9,] 0.00 1 m1 m2 m3 m4 f1 f2 f3 f4 env [1,] 1 1 1 1 0 0 0 0 1 [2,] 0 0 0 0 1 1 1 1 1 [3,] 1 1 0 0 1 1 0 0 1 [4,] 1 0 1 0 1 0 1 0 1 \end{verbatim} We can now fit the model calling the two-stage function \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # fitting ace model for family structure ts <- binomial.twostage(margbin,data=data,clusters=data$cluster, theta=c(2,1), random.design=out$des.rv,theta.des=out$pardes) summary(ts) # true variance parameters c(2,1) # total variance 3 \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.2425610 0.03747680 dependence2 0.1255742 0.01607478 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.659 0.0611 0.539 0.779 4.25e-27 dependence2 0.341 0.0611 0.221 0.461 2.39e-08 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.368 0.0252 0.319 0.418 3.31e-48 attr(,"class") [1] "summary.mets.twostage" [1] 0.2222222 0.1111111 [1] 0.3333333 \end{verbatim} \subsection*{Pairwise fitting} \label{sec:orged91ad8} We now specify the same model via extracting all pairs. The random effecs structure is simpler when just looking at pairs. A special function writes up all combinations of pairs. There are 6 pairs within each family, and we keep track of who belongs to the different families. We first simply give the pairs and we then should get the same result as before. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} mm <- familycluster.index(data$cluster) head(mm$familypairindex,n=20) pairs <- mm$pairs dim(pairs) head(pairs,12) \end{lstlisting} \begin{verbatim} [1] 1 2 1 3 1 4 2 3 2 4 3 4 5 6 5 7 5 8 6 7 [1] 240000 2 [,1] [,2] [1,] 1 2 [2,] 1 3 [3,] 1 4 [4,] 2 3 [5,] 2 4 [6,] 3 4 [7,] 5 6 [8,] 5 7 [9,] 5 8 [10,] 6 7 [11,] 6 8 [12,] 7 8 \end{verbatim} Now with the pairs we fit the model \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tsp <- binomial.twostage(margbin,data=data, clusters=data$cluster, theta=c(2,1),detail=0, random.design=out$des.rv,theta.des=out$pardes,pairs=pairs) summary(tsp) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects Error in theta.des %*% theta : non-conformable arguments \end{verbatim} Here a random sample of pairs are given instead and we get other estimates. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} set.seed(100) ssid <- sort(sample(1:nrow(pairs),nrow(pairs)/2)) tsd <- binomial.twostage(aa,data=data,clusters=data$cluster, theta=c(2,1),step=1.0, random.design=out$des.rv,iid=1,Nit=10, theta.des=out$pardes,pairs=pairs[ssid,]) summary(tsd) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects Error in theta.des %*% theta : non-conformable arguments \end{verbatim} To specify such a model when only the pairs are availble we show how to specify the model. We here use the same marginal "aa" to make the results comparable. The marginal can also be fitted based on available data. We start by selecting the data related to the pairs, and sets up new id's and to start we specify the model using the full design with 9 random effects. Below we show how one can use with only the random effects needed for each pair, which is typically simpler. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} head(pairs[ssid,]) ids <- sort(unique(c(pairs[ssid,]))) pairsids <- c(pairs[ssid,]) pair.new <- matrix(fast.approx(ids,c(pairs[ssid,])),ncol=2) head(pair.new) dataid <- dsort(data[ids,],"cluster") outid <- ace.family.design(dataid,member="type",id="cluster") outid$pardes head(outid$des.rv) \end{lstlisting} \begin{verbatim} [,1] [,2] [1,] 1 2 [2,] 1 3 [3,] 2 4 [4,] 3 4 [5,] 5 6 [6,] 5 7 [,1] [,2] [1,] 1 2 [2,] 1 3 [3,] 2 4 [4,] 3 4 [5,] 5 6 [6,] 5 7 [,1] [,2] [1,] 0.25 0 [2,] 0.25 0 [3,] 0.25 0 [4,] 0.25 0 [5,] 0.25 0 [6,] 0.25 0 [7,] 0.25 0 [8,] 0.25 0 [9,] 0.00 1 m1 m2 m3 m4 f1 f2 f3 f4 env [1,] 1 1 1 1 0 0 0 0 1 [2,] 0 0 0 0 1 1 1 1 1 [3,] 1 1 0 0 1 1 0 0 1 [4,] 1 0 1 0 1 0 1 0 1 [5,] 1 1 1 1 0 0 0 0 1 [6,] 0 0 0 0 1 1 1 1 1 \end{verbatim} Now fitting the model with the data set up \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tsdid <- binomial.twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1), random.design=outid$des.rv,theta.des=outid$pardes,pairs=pair.new) summary(tsdid) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects Error in theta.des %*% theta : non-conformable arguments \end{verbatim} We now specify the design specifically using the pairs. The random.design and design on the parameters are now given for each pair, as a 3 dimensional matrix. with a direct specification of random.design and the design on the parameters theta.design. In addition we need also to give the number of random effects for each pair. These basic things are constructed by certain functions for the ACE design. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} pair.types <- matrix(dataid[c(t(pair.new)),"type"],byrow=T,ncol=2) head(pair.new,7) head(pair.types,7) theta.des <- array(0,c(4,2,nrow(pair.new))) random.des <- array(0,c(2,4,nrow(pair.new))) # random variables in each pair rvs <- c() for (i in 1:nrow(pair.new)) { if (pair.types[i,1]=="mother" & pair.types[i,2]=="father") { theta.des[,,i] <- rbind(c(1,0),c(1,0),c(0,1),c(0,0)) random.des[,,i] <- rbind(c(1,0,1,0),c(0,1,1,0)) rvs <- c(rvs,3) } else { theta.des[,,i] <- rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) random.des[,,i] <- rbind(c(1,1,0,1),c(1,0,1,1)) rvs <- c(rvs,4) } } \end{lstlisting} \begin{verbatim} [,1] [,2] [1,] 1 2 [2,] 1 3 [3,] 2 4 [4,] 3 4 [5,] 5 6 [6,] 5 7 [7,] 5 8 [,1] [,2] [1,] "mother" "father" [2,] "mother" "child" [3,] "father" "child" [4,] "child" "child" [5,] "mother" "father" [6,] "mother" "child" [7,] "mother" "child" \end{verbatim} For pair 1 that is a mother/farther pair, we see that they share 1 environmental random effect of size 1. There are also two genetic effects that are unshared between the two. So a total of 3 random effects are needed here. The theta.des relates the 3 random effects to possible relationships in the parameters. Here the genetic effects are full and so is the environmental effect. In contrast we also consider a mother/child pair that share half the genes, now with random effects with (1/2) gene variance. We there need 4 random effects, 2 non-shared half-gene, 1 shared half-gene, and one shared full environmental effect. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # 3 rvs here random.des[,,1] theta.des[,,1] # 4 rvs here random.des[,,2] theta.des[,,2] head(rvs) \end{lstlisting} \begin{verbatim} [,1] [,2] [,3] [,4] [1,] 1 0 1 0 [2,] 0 1 1 0 [,1] [,2] [1,] 1 0 [2,] 1 0 [3,] 0 1 [4,] 0 0 [,1] [,2] [,3] [,4] [1,] 1 1 0 1 [2,] 1 0 1 1 [,1] [,2] [1,] 0.5 0 [2,] 0.5 0 [3,] 0.5 0 [4,] 0.0 1 [1] 3 4 4 4 3 4 \end{verbatim} Now fitting the model, and we see that it is a lot quicker due to the fewer random effects needed for pairs. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tsdid2 <- binomial.twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1), random.design=random.des, theta.des=theta.des,pairs=pair.new,pairs.rvs=rvs) summary(tsdid2) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects Error in theta.des %*% theta : non-conformable arguments \end{verbatim} The same model can be specifed even simpler via the kinship coefficient. For this speicification there are 4 random effects for each pair, but some have variance 0. The mother-father pair, here shares a random effect with variance 0, and have two non-shared genetic effects with full variance, in addition to a fully shared environmental effect. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} kinship <- c() for (i in 1:nrow(pair.new)) { if (pair.types[i,1]=="mother" & pair.types[i,2]=="father") pk1 <- 0 else pk1 <- 0.5 kinship <- c(kinship,pk1) } head(kinship,n=10) out <- make.pairwise.design(pair.new,kinship,type="ace") names(out) out$random.des[,,1] out$theta.des[,,1] \end{lstlisting} \begin{verbatim} [1] 0.0 0.5 0.5 0.5 0.0 0.5 0.5 0.5 0.5 0.5 [1] "random.design" "theta.des" "ant.rvs" [,1] [,2] [,3] [,4] [1,] 1 1 0 1 [2,] 1 0 1 1 [,1] [,2] [1,] 0 0 [2,] 1 0 [3,] 1 0 [4,] 0 1 \end{verbatim} Now, fitting the model we get the results from before. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tsdid3 <- binomial.twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1)/9,random.design=out$random.design, theta.des=out$theta.des,pairs=pair.new,pairs.rvs=out$ant.rvs) summary(tsdid3) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects Error in theta.des %*% theta : non-conformable arguments \end{verbatim} \section*{Pairwise odds ratio model} \label{sec:org2ddc2cf} To fit the pairwise odds-ratio model in the case of a pair-specification there are two options for fitting the model. \begin{enumerate} \item One option is to set up some artificial data similar to twin data with \begin{itemize} \item a pair-cluster-id (clusters) \item with a cluster-id to get GEE type standard errors (se.cluster) \end{itemize} \item We can also use the specify the design via the theta.des that is also a matrix of dimension pairs x design with the design for POR model. \end{enumerate} Starting by the second option. We need to start by specify the design of the odds-ratio of each pair. We set up the data and find all combinations within the pairs. Subsequently, we remove all the empty groups, by grouping together the factor levels 4:9, and then we construct the design. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tdp <-cbind( dataid[pair.new[,1],],dataid[pair.new[,2],]) names(tdp) <- c(paste(names(dataid),"1",sep=""), paste(names(dataid),"2",sep="")) tdp <-transform(tdp,tt=interaction(type1,type2)) dlevel(tdp) drelevel(tdp,newlevels=list(mother.father=4:9)) <- obs.types~tt dtable(tdp,~tt+obs.types) tdp <- model.matrix(~-1+factor(obs.types),tdp) \end{lstlisting} \begin{verbatim} type1 #levels=:3 [1] "child" "father" "mother" ----------------------------------------- type2 #levels=:3 [1] "child" "father" "mother" ----------------------------------------- tt #levels=:9 [1] "child.child" "father.child" "mother.child" "child.father" [5] "father.father" "mother.father" "child.mother" "father.mother" [9] "mother.mother" ----------------------------------------- obs.types mother.father child.child father.child mother.child tt child.child 0 19991 0 0 father.child 0 0 39837 0 mother.child 0 0 0 40212 child.father 0 0 0 0 father.father 0 0 0 0 mother.father 19960 0 0 0 child.mother 0 0 0 0 father.mother 0 0 0 0 mother.mother 0 0 0 0 \end{verbatim} We then can fit the pairwise model using the pairs and the pair-design for descrbing the OR. The results are consistent with the the ACE model as the mother-father have a lower dependence as is due only the environmental effects. All other combinations should have the same dependence as also seem to be the case. To fit the OR model it is generally recommended to use the var.link to use the parmetrization with log-odd-ratio regression. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} porpair <- binomial.twostage(aa,data=dataid,clusters=dataid$cluster, theta.des=tdp,pairs=pair.new,model="or",var.link=1) summary(porpair) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(obs.types)mother.father 0.1269881 0.03132228 factor(obs.types)child.child 0.3819107 0.03108233 factor(obs.types)father.child 0.3046284 0.02239909 factor(obs.types)mother.child 0.3293741 0.02233648 $or Estimate Std.Err 2.5% 97.5% P-value factor(obs.types)moth.... 1.14 0.0356 1.07 1.21 1.16e-223 factor(obs.types)chil.... 1.47 0.0455 1.38 1.55 4.26e-227 factor(obs.types)fath.... 1.36 0.0304 1.30 1.42 0.00e+00 factor(obs.types)moth.....1 1.39 0.0310 1.33 1.45 0.00e+00 $type [1] "or" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \end{document}mets/vignettes/binomial-case-control-ascertainment.ltx0000644000176200001440000007154713623061405023015 0ustar liggesusers%\VignetteIndexEntry{Analysis of multivariate binomial data: case control or ascertainment sampling} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Analysis of multivariate binomial data: case control or ascertainment sampling} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Analysis of multivariate binomial data: case control or ascertainment sampling}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Overview} \label{sec:orgad14f2c} When looking at multivariate binomial data with the aim of learning about the dependence that is present, possibly after correcting for some covariates many models are available. \begin{itemize} \item Random-effects models logistic regression covered elsewhere (glmer in lme4). \end{itemize} in the mets package you can fit the \begin{itemize} \item Pairwise odds ratio model \item Bivariate Probit model \begin{itemize} \item With random effects \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \item Additive gamma random effects model \begin{itemize} \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \end{itemize} These last three models are all fitted in the mets package using composite likelihoods for pairs of data. The models can be fitted specifically based on specifying which pairs one wants to use for the composite score. The models are described in futher details in the binomial-twin vignette. \subsection*{Case-Control Sampling} \label{sec:org93e2d83} Sometimes, pairs are recruited after a case-proband is selected. This proband, can be either a \begin{itemize} \item case: must be representative of cases \end{itemize} or a \begin{itemize} \item control: must be representative of controls \end{itemize} First thinking about pairs, we estimate parameters using the conditional likelihood given sampling wich for a binary 2 x 2 table can be written as \[ \frac{P(i,j)}{P(j)} \] the probailty of seeing \((i,j)\) for the pair, given that the proband was observed as \((j)\). We note that if the marginal is known, or possibly estimated from the full cohort. Then we can estimate dependence parameters using just the terms \(P(i,j)\) for the pairs. We can thus ignore the special sampling for models with marginal specification. If the marginal can not be obtained from other sources we need to maximize the full-pairwise-likelihood in all parameters, that is both dependence and marginal parameters. Similary, one can select a whole family based on having selected a proband, that is selected a representative member of either cases or controls. In this case we fit the models by using composited likelihoods, considering all pairs that involves the probands. This will give some lacking efficiency compared to looking at the full likelihood of the family given the proband. \subsection*{Ascertainment Sampling} \label{sec:org6773872} Similarly, in the setting of pairs we can select all pairs where there is at least one event of interest. First thinking about pairs, we estimate parameters using the conditional likelihood given sampling wich for a binary 2 x 2 table can be written as \[ \frac{P(i,j)}{1-P(0,0)} \] the probailty of seeing \((i,j)\) for the pair, given that it is sampled. If the marginal can estimated from a full sample we can then estimate the dependence parameter using the ascertainment likelihood. Generally, when whole families are ascertained the computation of the true truncation probability can be hard to the fact that families are hard to define in the real world. Nevertheless, if a random sample of such family is at hand. We suggest to in these families take out all pairs that satisfies the ascertainment criterion. With a family, with given size \(n\) we have binary observations \((Y_1,...,Y_n)\). The family is sampled or a random sample of families such that \[ \sum_{i=1}^n Y_i \geq 1. \] We let the conditional distribution given sampling, be denoted as \[ P^O(\cdot) = P(\cdot | \sum_{i=1}^n Y_i \geq 1) \] Now, we note that all pairs within these family that satisfies that \(Y_i+Y_j \geq 1\), will have distribution \begin{align*} P^O(Y_i=o_1, Y_j=o_2 | Y_i+Y_j \geq 1) & = \frac{P^O(o_1,o_2)}{P^O( Y_i+Y_j \geq 1)} \\ & = \frac{P(Y_i=o_1,Y_j=o_2, \sum_{i=1}^n Y_i \geq 1)}{ P( Y_i+Y_j \geq 1, \sum_{i=1}^n Y_i \geq 1)} \\ & = \frac{P(Y_i=o_1,Y_j=o_2) }{ P( Y_i+Y_j \geq 1)} = \frac{P(o_1,o_2)}{1 - P(0,0)} \end{align*} since we only consider the probabilities where \(o_1+o_2 \geq 1\). Also here we could condition on covariates. So considering these pairs, or a random sample of them should yield valid inference. When standard errors are computed we need to rely on GEE type arguments. An advantage of this is that the ascertainment probability is much easier to get for the pairs. Again using the pairwise structure will lead to loss of efficiency compared to using the full likelihood of the ascertained families. In addition we note that when looking at one pair that has been ascertained then \begin{align*} P(Y_i=o_1,Y_j=o_2 | Y_i+Y_j \geq 1) & = \sum_{k=1}^2 P(Y_i=o_1,Y_j=o_2 | Y_i+Y_j = k ) P( Y_i + Y_j =k | Y_i + Y_j \geq 1 ). \end{align*} where \(o_1+ o_2 \geq 1\). Note that the dependence will affect the probabilities \(P(Y_i+Y_j=2)/( P(Y_i+Y_j=2)+ P(Y_i+Y_j=1))\) and \(P(Y_i+Y_j=1)/( P(Y_i+Y_j=2)+ P(Y_i+Y_j=1))\). In particular when the marginal parameters are known the dependence parameters can be estimated using the proportion of concordant pairs compared to the non-concordant pairs with respect to the outcome. When considering the pairs with different responses we learn "only" (up to model specification) about covariate effects. For example when \(\mbox{logit}(P(Y_i=1 | \alpha_k )) = \alpha_{k} + \beta X_i\) for \(i=1,2\) with \(\alpha_k\) a pair (cluster) specific effect and subject specific covariates \(X_i\) for \(i=1,2\), then \(P(Y_i=1,Y_j=0)/P(Y_i+Y_j=1) = \mbox{expit}((X_i - X_j) \beta)\), and with the standard definitions \(\mbox{logit}(p) = \log(p/(1-p))\) and \(\mbox{expit}(x) = \exp(x)/(1+\exp(x))\). \section*{The twin-stutter data} \label{sec:org51abefd} We consider the twin-stutter where for pairs of twins that are either dizygotic or monozygotic we have recorded whether the twins are stuttering \cite{twinstut-ref} We here consider MZ and same sex DZ twins. Looking at the data \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) data(twinstut) twinstut$binstut <- 1*(twinstut$stutter=="yes") twinstut <- subset(twinstut,zyg%in%c("mz","dz")) head(twinstut) \end{lstlisting} \begin{verbatim} Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.6 mets version 1.2.3 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined tvparnr zyg stutter sex age nr binstut 1 1 mz no female 71 1 0 2 1 mz no female 71 2 0 3 2 dz no female 71 1 0 8 5 mz no female 71 1 0 9 5 mz no female 71 2 0 11 7 dz no male 71 1 0 \end{verbatim} \begin{itemize} \item First, we select an ascertaiment sample of the data, thus selecting a random sample of all ascertained pairs. \item Secondly, we select a case-control sample of this data to illustrate the use of the methods. \end{itemize} \section*{Ascertaiment Sampling} \label{sec:orgaa08da8} Selecting the ascertained pairs \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) data(twinstut) twinstut$binstut <- 1*(twinstut$stutter=="yes") twinstut <- subset(twinstut,zyg%in%c("mz","dz")) dnumeric(twinstut) <- ~. dfactor(twinstut,labels=c("DZ","MZ")) <- binzyg~zyg.n ddrop(twinstut) <- ~"*.n" twinstut <- dby(twinstut,binstut~tvparnr,stuttot=sum,nn=seq_along,n=length) twina <- subset(twinstut,n==2 & stuttot>=1) \end{lstlisting} Selecting on the pairs where there is stuttering at taking a look at the tables of discordance and concordance for the twins. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} twinda <- fast.reshape(twina,id="tvparnr") twind <- fast.reshape(twinstut,id="tvparnr") dtable(twind,"binst*"~I(stuttot1>=1)) dtable(twinda,~"binst*") \end{lstlisting} \begin{verbatim} I(stuttot1 >= 1): FALSE binstut2 0 binstut1 0 6632 ------------------------------------------------------------ I(stuttot1 >= 1): TRUE binstut2 0 1 binstut1 0 0 289 1 281 111 binstut2 0 1 binstut1 0 0 289 1 281 111 \end{verbatim} Now doing the analyses \subsection*{Biprobit model} \label{sec:orgb7a66bb} Looking at the full data for comparison. We estimate an unstructured probit model with different correlations for MZ and DZ twins. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} b1 <- biprobit(binstut~sex,~-1+binzyg,data=twinstut,id="tvparnr") summary(b1) \end{lstlisting} \begin{verbatim} Estimate Std.Err Z p-value (Intercept) -1.794821 0.023289 -77.066826 0.0000 sexmale 0.401430 0.030179 13.301756 0.0000 r:binzygDZ 0.132458 0.062516 2.118802 0.0341 r:binzygMZ 1.096915 0.073574 14.909085 0.0000 logLik: -4400.536 mean(score^2): 1.022e-06 n pairs 21288 7313 Contrast: Dependence [binzygDZ] Mean [(Intercept)] Estimate 2.5% 97.5% Rel.Recur.Risk 1.77662 0.92746 2.62577 OR 1.88752 1.09432 3.25566 Tetrachoric correlation 0.13169 0.00993 0.24960 Concordance 0.00235 0.00140 0.00393 Casewise Concordance 0.06456 0.03937 0.10413 Marginal 0.03634 0.03287 0.04016 \end{verbatim} Note, that the Casewise Concordance is a consistently estimated under complete ascertainment, i.e., when we consider a random sample of affected twins (at least on of the twins must have the event). \subsection*{Odd-Ratio modelling} \label{sec:org1c452c4} First looking at the marginal model based on the full data we find the overall level of stuttering and also that males have a much higher stuttering risk. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} margbin <- glm(binstut~factor(sex),data=twinstut,family=binomial()) summary(margbin) \end{lstlisting} \begin{verbatim} Call: glm(formula = binstut ~ factor(sex), family = binomial(), data = twinstut) Deviance Residuals: Min 1Q Median 3Q Max -0.4127 -0.4127 -0.2716 -0.2716 2.5763 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) -3.28191 0.05000 -65.64 <2e-16 *** factor(sex)male 0.86171 0.06211 13.87 <2e-16 *** --- Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 9328.6 on 21287 degrees of freedom Residual deviance: 9124.7 on 21286 degrees of freedom AIC: 9128.7 Number of Fisher Scoring iterations: 6 \end{verbatim} First, fitting the OR model for MZ and DZ for the full data, we find that MZ have a much higher dependence than DZ twins. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} theta.des <- model.matrix( ~-1+factor(zyg),data=twinstut) bin <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,theta.des=theta.des) summary(bin) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(zyg)dz 0.5238541 0.2400861 factor(zyg)mz 3.4930902 0.1865567 $or Estimate Std.Err 2.5% 97.5% P-value factor(zyg)dz 1.689 0.4054 0.894 2.483 3.111e-05 factor(zyg)mz 32.887 6.1354 20.862 44.913 8.308e-08 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} Now, using the overall marginal we look at the adjusted likelihood and find very similar results on the ascertained sample. Note, that the marginals are crucial for this analysis to give useful results. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} theta.des <- model.matrix( ~-1+factor(zyg),data=twina) bina <- binomial.twostage(margbin,data=twina,var.link=1, clusters=twina$tvparnr,theta.des=theta.des, pair.ascertained=1) summary(bina) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(zyg)dz 0.4874213 0.2472523 factor(zyg)mz 3.4753766 0.1985974 $or Estimate Std.Err 2.5% 97.5% P-value factor(zyg)dz 1.628 0.4026 0.8391 2.417 5.245e-05 factor(zyg)mz 32.310 6.4167 19.7335 44.886 4.771e-07 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \subsection*{Additive gamma modelling} \label{sec:org524055f} First, again for comparision fitting the full data for the AE model. We get the size of the genetic variance in this model. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} out <- twin.polygen.design(twinstut,id="tvparnr",zygname="zyg",zyg="dz",type="ae") bintwin <- binomial.twostage(margbin,data=twinstut, clusters=twinstut$tvparnr,detail=0,theta=c(0.1)/1,var.link=0, random.design=out$des.rv,theta.des=out$pardes) summary(bintwin) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.9094847 0.09536268 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.9095 0.09536 0.7226 1.096 1.469e-21 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} We first here take at the look at the marginal model for the ascertained sample, and note as expected that this sample give highly biased estimated for the marginal model. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} outa <- twin.polygen.design(twina,id="tvparnr",zygname="zyg",zyg="dz",type="ae") marga <- glm(binstut~sex,data=twina,family=binomial()) summary(marga) \end{lstlisting} \begin{verbatim} Call: glm(formula = binstut ~ sex, family = binomial(), data = twina) Deviance Residuals: Min 1Q Median 3Q Max -1.334 -1.298 1.028 1.028 1.061 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) 0.27895 0.08739 3.192 0.00141 ** sexmale 0.08242 0.11237 0.733 0.46328 --- Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 1851.8 on 1361 degrees of freedom Residual deviance: 1851.2 on 1360 degrees of freedom AIC: 1855.2 Number of Fisher Scoring iterations: 4 \end{verbatim} Now, using the overall marginal model we look at the adjusted likelihood and find very similar results on the ascertained sample. Note, that the marginals are crucial for this analysis to give useful results. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} abintwin1 <- binomial.twostage(margbin,data=twina, clusters=twina$tvparnr,detail=0,theta=c(0.1)/1,var.link=0, random.design=outa$des.rv,theta.des=outa$pardes,pair.ascertained=1) summary(abintwin1) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.8920274 0.09732786 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.892 0.09733 0.7013 1.083 4.946e-20 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} In fact for this model we can also do a full-MLE fitting jointly the dependence parameters and the marginal model. This is based on the twostage option (twostage=0 is MLE). Here the starting value is given at the marginal model for the ascertained model. This gives quite similar results to the previous analyses with a genetic variance around 1. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} aabintwin1 <- binomial.twostage(marga,data=twina, clusters=twina$tvparnr,detail=0,theta=c(0.1)/1,var.link=0, random.design=outa$des.rv,theta.des=outa$pardes,pair.ascertained=1,twostage=0) summary(aabintwin1) coef(marga) coef(margbin) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 1.014398 0.1045593 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 1.014 0.1046 0.8095 1.219 2.967e-22 attr(,"class") [1] "summary.mets.twostage" (Intercept) sexmale 0.2789484 0.0824214 (Intercept) factor(sex)male -3.2819072 0.8617053 \end{verbatim} \section*{Case Control Sampling} \label{sec:org56e8f5e} First, taking out all cases and one control for each case, we establish the pairs of these probands. This is based on keeping track of the twin related to the proband. Here using some utility functions in the mets packages. Then we write up the random design vectors and the parameter design for each pair using the kinship coefficient. When specifying the pairs in the case-control setup the second column should be the probands. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) data(twinstut) twinstut$binstut <- 1*(twinstut$stutter=="yes") twinstut <- subset(twinstut,zyg%in%c("mz","dz")) dnumeric(twinstut) <- ~. dfactor(twinstut,labels=c("DZ","MZ")) <- binzyg~zyg.n ddrop(twinstut) <- ~"*.n" twinstut <- dby(twinstut,binstut~tvparnr,stuttot=sum,nn=seq_along,n=length) twinstut <- subset(twinstut,n==2) twinstut <- dtransform(twinstut,nnrow=1:nrow(twinstut)) twinstut <- dby(twinstut,binstut~tvparnr,nnn=seq_along) twinstut <- dby2(twinstut,nnrow~tvparnr,pairnr=rev) cases <- which(twinstut$binstut==1) controls <- sample(which(twinstut$binstut==0),1217) rowsca <- with(twinstut,nnrow[cases]) rowsco <- with(twinstut,nnrow[controls]) rpairs <- c(rowsca,rowsco) cc.pairs <- cbind( with(twinstut,pairnr.nnrow[rpairs]),rpairs) ids <- sort(unique(c(cc.pairs))) pairsids <- c(cc.pairs) pair.new <- matrix(fast.approx(ids,pairsids),ncol=2) head(pair.new) dataid <- dsort(twinstut[ids,],"tvparnr") dataid=dtransform(dataid,kinship=0.5) dataid=dtransform(dataid,kinship=1,binzyg=="MZ") kinship <- dataid$kinship[pair.new[,2]] out <- make.pairwise.design(pair.new,kinship,type="ae") names(out) out$random.des[,,1] out$theta.des[,,1] \end{lstlisting} \begin{verbatim} [,1] [,2] [1,] 4 3 [2,] 16 15 [3,] 18 17 [4,] 32 31 [5,] 38 37 [6,] 44 43 [1] "random.design" "theta.des" "ant.rvs" [,1] [,2] [,3] [1,] 1 1 0 [2,] 1 0 1 [1] 0.5 0.5 0.5 \end{verbatim} Now doing the analyses, first with know marginals, that is marginals from the full data. For this analysis, since marginals do not contain dependence parameters we do not need to specify that this is case-control sampling. Having a correct is crucial for this to work, but this is certainly often possible in register based studies where a full cohort is also available. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} cc <- binomial.twostage(margbin,data=dataid,clusters=dataid$tvparnr,pairs=pair.new, random.design=out$random.design,theta.des=out$theta.des, pairs.rvs=out$ant.rvs,case.control=0,twostage=1) summary(cc) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.8791843 0.09707036 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.8792 0.09707 0.6889 1.069 1.339e-19 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} We now do the same analysis specifying the case-control sampling. This should result in the same dependence parameters as is also the case. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} cc3 <- binomial.twostage(margbin,data=dataid, clusters=dataid$tvparnr, pairs=pair.new, random.design=out$random.design, theta.des=out$theta.des, pairs.rvs=out$ant.rvs, case.control=1,twostage=1) summary(cc3) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.8791843 0.09707036 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.8792 0.09707 0.6889 1.069 1.339e-19 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} This model can also be fitted using a full likelhood of both dependence parameters and marginal parameters. Here there is no need to have a correctly specified marginal. We here use the marginal fitting from the case-control data as as starting values. Again we find a genetic variance around 1. The marginal parameters are also consistent with the results from the full analyses for the marginal parameters. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} marga <- glm(binstut~sex,data=dataid,family=binomial()) cc3 <- binomial.twostage(marga,data=dataid, clusters=dataid$tvparnr, pairs=pair.new, random.design=out$random.design, theta.des=out$theta.des, pairs.rvs=out$ant.rvs, case.control=1,twostage=0) summary(cc3) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.9222504 0.09729347 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.9223 0.09729 0.7316 1.113 2.566e-21 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} When probands are related, here we may choose both case and controls from the same twin-pair then we need to adjust standard errors by grouping together contribution from related probands. This can be done using the se.cluster option that specifies how to cluster in the computation of the standard errors. In this case, however, this will be same as the clusters since these also are identical across pairs. \section*{Combining Case Control and Ascertainment Sampling} \label{sec:orgff68ee7} When specifying such models based on the pairs, it is in fact possible to combine ascertained pairs with case-control sampling by specifing vectors as the case.control=c(1,0,1,0) and pair.ascertained=c(0,1,0,1) arguments. Here with two case-control pairs, and two ascertained pairs. \end{document}mets/vignettes/competing.org0000644000176200001440000000412013623061405015725 0ustar liggesusers#+TITLE: Analysis of multivariate competing risks data #+AUTHOR: Klaus Holst & Thomas Scheike #+PROPERTY: header-args:R :session *R* :cache no :width 550 :height 450 #+PROPERTY: header-args :eval never-export :exports both :results output :tangle yes :comments yes #+PROPERTY: header-args:R+ :colnames yes :rownames no :hlines yes #+INCLUDE: header.org #+OPTIONS: toc:nil timestamp:nil #+BEGIN_SRC emacs-lisp :results silent :exports results :eval (setq org-latex-listings t) (setq org-latex-compiler-file-string "%%\\VignetteIndexEntry{Analysis of multivariate competing riks data}\n%%\\VignetteEngine{R.rsp::tex}\n%%\\VignetteKeyword{R}\n%%\\VignetteKeyword{package}\n%%\\VignetteKeyword{vignette}\n%%\\VignetteKeyword{LaTeX}\n") #+END_SRC ----- # +LaTeX: \clearpage * Overview - marginal modelling with standard errors cif, - cause specific hazards - cumulative incidence modelling - random effects simple cif - Luise model When looking at multivariate survival data with the aim of learning about the dependence that is present, possibly after correcting for some covariates different approaches are available in the mets package - Binary models and adjust for censoring with inverse probabilty of censoring weighting - Bivariate surival models of Clayton-Oakes type - With regression structure on dependence parameter - With additive gamma distributed random effects - Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. - Plackett OR model model - With regression structure on OR dependence parameter - Cluster stratified Cox Typically it can be hard or impossible to specify random effects models with special structure among the parameters of the random effects. This is possible for our specification of the random effects models. To be concrete about the model structure assume that we have paired binomial data \( T_1, \delta_1, T_2, \delta_2, X_1, X_2 \) where the censored survival responses are \( T_1, \delta_1, T_2, \delta_2 \) and we have covariates \( X_1, X_2 \). mets/vignettes/surv-cc-base.jpg0000644000176200001440000004041113623061405016226 0ustar liggesusersJFIFC    $.' ",#(7),01444'9=82<.342C  2!!22222222222222222222222222222222222222222222222222&" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (WFqῇΫhJHuFvݟ€:+/Aur4|$VIrĶ'sdGSZgeq[?I4n4>\r~y' ExG>#k>K]7WZ]Wm62C_kZ/燬n,,l.5עҜm!$V*!8hh6Ş8֯]'L&4{XeHid8NF>Qg .{;lR/YH>BA+?a[״?Z~A]T@ oeʞGGb1UR$SjI<@`6I=|]e$iWjHS'=Zh(((((((((((((((((((((((((((((Pxzrvw xU+V-< oM:hwgLf2ę+< 8w{쿇-\:B"dy;T1]%[.-t4xo5DLKf稍9Zolzu<>d̙b hGVS]B [+)nA8ý&+KKI-VɎsyF=:0}뭢cϥ&WeBr{Q]:N\T-\ny]ϤϨig`ѕ<&S]2LȭהUȭהPQEQEQEQERM]FG=vRXX[iv1YFc<I$I$I$I&@s/~)vEth=?EQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEUk]2[ْxsz}=s,'kɓXj=Xyž36GzHpFN$T ަm?__ccRMdRi:TC7O#d L)Ci:J2ڝ[Ip\y=C-\} |ڮs8S|"zn*UΏi4s(溌[.]퓞Ozj=IV*vF6escڽ_+$inph D:(ffxEm_ _hʨxEm_ _hʀ$(((((cE?趮Ggڀ:z( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (SZUD^@LV`.:zpr(Eo <H݂Ԓz u?>4f-^x3ʹ `y@' /`]dϘ-6@ #iS{X!h 3t*>/Cʎ|uaiD[Y-lOx{W|+AEsPd~5¯? 8R՜EPEPg?Vo?VoJ( ( ( (8{ xPteyŴ1"C1c);8ȭ xn'vG~o5"b |r5 v?j&h![Pcھc q1p0#jxOQt] =،cʐ4oV @d7ۘ.o-hٍѰa馴 ot.7b)HbHmʊVޔQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQYaFl;)y(3u?J:|E-$0w%~IVi rcg9پHp_d[d gq F$zI𶡬4I, Ç땐Fp0+炒e֥W'(,p70xڠǰҟџZB7њg͸Ltzz:hQEQQEQEQEO@5~=p*O@5~=p*((^f7Lʌ|mRvsVb5_iixaU²qaKuQEQEh=?1l[POEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEk2bN߳A*Ǡcrx inT!)E0U,$c@Q; a g 7+f^>#ӕDab2ǧ˂A+Wox;MЖ96-rqBI,F2fWgR֥pr\ y莸Q#>ZJ8!Y]!7188zi%J (EPEPEPEPg?Vo?VoJ( (1|Y]VK+٢jm݂QV.YOܶ;a8;ֶԧHeyLU%Aqh/cl5+9 H缈yLF Ddx9袊(z}K%̷dK[9 ynѶs+BQe Uס~;@1l[WO\Ƌ#ߊݳm@=Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@SK="^̱Gܻ'W9v @R0 >v1בl<'5?ܼmp zCAp$ RDmi.iN4 H`sɕcpah_Q$՝gpF ݜrUoRyMҬAmco2UU0!y :Qu%DHl 㰠 :,Zea_c{7\2Ii=bsG]us/~)vEtQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQ\7#Z=} aQsr`[P \]gN-Mƣu 1>HUǥyLj|O㫉,?l:pb\zg,^^+ğrٛr2GQ.9 ϥAinФ06qUQN7j4_ۿcׁ4B>EN$FquTQM+h''-Š(HQEQEQEQEQEQEQEO@5~=p*O@5~=p*(({R:ܒkW\1ZNIooFRaɬk$3!(V\9䲋ÚfKQza>5x?MF~˩At/'yoV"4c$O 0((Ggںz4_Sj袊(((((((((((((((@M-fk^ ÿQAq\B :?yvbg{O>.*鐤ױA*Ki S ֹxQӧGkkU`&09x @(>MHS:閆Su䨔qZLvGV4EL.OANy98̽W=j][Plo.bsql8?0?63Z6zevvZZǝ$ O@_El/,P>a=JI"E\RO6kFGI{rŸū/'Kֺp;-C!~J,-c8 a#BOE43IOp)QEQEQEQEQEQEQEQEQEQEQEQEfxEm_ _hʨxEm_ _hʀ$((7?:m=B[rV\ I>Z6qgCX6Nmp"DMљ|Բo~G]~18~ۗkrֹoix.}UՍi RN@;((cE?趮Ggڀ:z( ( ( ( ( ( ( ( ( ( ( +7ZYR+x?3{*?qE@䃙7H?}qRƓkZ/nK/3lږN"@v*(((((((((((((( ȭהUȭהPQEQEdx?[gwEYG܂p5Cvke/i22Kv]lӮ[͞,D̷̑85-=Ӊ[uܻLI78RFO=mQE{+O$fƋ#%s8 tqGu*-trڋ *J bNVP qGJ/qJ}RҭuFʹ1+ =8l|k`6hy+H~wbMuh=?EQEQEQEQEQEQEQER3R@P2I+Ğ,<+hjWL6 }{zW$4o@f> iPgտN&i nJ.KWzԺG.R'!}zV 3BY5MjNd.gϢv9k{Lt{$ӭcNIkv9rCoQEQQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEO@5~=p*O@5~=p*(((((Ggںz4_Sj袊((((((Gd%0Ņ+rO`zinTa);ERHĊYP:OA\-_K%†).r1m;XFsN|'T-UţZqXqֻ( $R8*RZW}~_yxsvZ=jܜ{rrGE4"sQE ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (3f<\/uOMuIA$<9zUZ\^ϩ.ٮ$ldda9OZnƪc._H|m+2dE.$q̽21Fsu74Kx=&e@:$ZqE,PƱƃ 0SԲ冋o( (((((((((((((((((((((((3ğ+j7j{EUCğ+j7j{ET%Q@Q@Q@Q@^#1_Yh%UkQX`铵s0j wn#B.FV*GbH?J%:m2FM0 $]Ҷth"`-wyIm) %X1%@/1l[Vƥ H>V|+ɯ\ "ьmqv_9w i;UwPucˆX/r:I;^Ǝk 㷓͹&w/^BqְGJ&toMRQ> ӌiW־{ϩ&]y=:tҳ{s迯kioclְ ,q*jw iw iꌛmݛ4V7ۼC@KO7GۼC@KO7@+!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  +!% !%  I"^SǴ_\Lj/u֪$ѭU _@yǗtPQEQEQEQEs}VvNv&@k 5iI1X]T.YܻaG 2tEˬkb4PEcs6[A3Т?4+o n_Ҟ/lk(Ϙ8Z(B<'B? / hz#+/ Я/&7B<'B? / hz#+/ Я/&72>,!>Kcjʆ-@_B<'Bޢ / h#+/ + Я/&B<'Bޢ / h#+/ + Я/&^MW\Gގ*DGdB<'B? / hz#+/ Я/&7B<'B? / hz#+/ Я/&73Co<7UwXpZxO}4E`?_GW_@V!_E|_MxO}4E`?_GW_@V!_E|_MexwJgz;W/c8~X?xO}4?_GW_G!_E|_MoQX?xO}4?_GW_G!_E|_MoQ\g<y'M7y%w{3JkW Я/&7B<'B? / hz#+/ Я/&7B<'B? / hzxZ- P? hm#+-@Wíal[@1)$ڀ.xEm_ _hʲτ6AQ 0QEQEQEQEQEQEV':UZɨ^vDVhE$`W'?{R_OOhD wQ\qEjMځ.4C"0 Yg =k((+5 u?IO3\ܽƎtcPpF 'x#tTW-sk:4#l EI;Kc*CV%wy=ݶ5ķWMl6q0Wkh/GJkY5 n {yt +#:ݸ9y S<[8gZנ((+KN?ZX<fO\̑?bzbFxxi/l&hH%˞8 cԴK G9;PA`8q](((a|PZjs,­V 3ܯʀ(jqKiMy4sÂ0L`l(Q,Irry<7 +Dc,at,J88B(((WD֣/w(08#8=Bͻt ɉ(,d ?29b};Lҭ~g".ݝݏVfbY$պ((((ōO-%3@w4dvhMre<"d` >RsEAeeoYiij $}O$MOEQEQEUwQ1I o tƟP=@'` :Jse`J `ZE$Q"hQ`(>(((җUS8G\$n-a@ b晨[PI"\ .7 #nvVHbHEHBP:)Q@Q@Q@biҴug;嶥pn|>SHSsֶ Y%$-<ˉQ>n:Zڢ(((ŵd mm,bh ̿Ho/mhdj[tN| YA ̀f1ƴ(((((((((((((((((((( k_ڵtgi!uTeն;;S5=FHoWe[)$!@"Eǯ8*x {xyt˔8Գ;xec'//{>˿>?qo{wŠuK[$k]r;E{Y^ï'9 ja2ѵ;$PgXwc $~lTQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEmets/vignettes/rec7.jpg0000644000176200001440000006100013623061405014571 0ustar liggesusersJFIFC    $.' ",#(7),01444'9=82<.342C  2!!22222222222222222222222222222222222222222222222222&" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( }m[ymqe8lҶҟ::M^T{$|-%߰n `VoωK.p2yQ<lg+R6dޫ:յ+auO\3.B^y[Gyrvri<_r8 (⻯uXRG5w@2O-ӨZr@'<3ҟ::M^T{$|-%߰n `^Ey )e."EzYF|;|G/ F?M~_z(#~G%?7& Vҥ ]v*pp@F=Z?elPEPEPP^^su % <09EOYyJ~I V?O~$kfF4U߉?٢1*ѿğMhO&h oJo'G%Z7?(~I V?O~$kfƏz$G' Ў)hO ț>ElPG%?7&J4oMk@haqsV7U< 5n x#xhb((( ZcyI,TxFr͂A'c4)|A! Q淨M~. "M4?)ߢ0?4(CR:~gk X%8˅:O2H.!I:dg hsSiOUHt{iǚ1\N:QO}̡/K 9d@4(C(M~. "M4?)ߢ0?4(C(M~. "MȑU;S}˓qVc_ D~Ri00 zU>a ?QEQEQEs5ZoҺ k"Gm]q= <@QYn &Y\jH-I v`#Ĥ#XKSvno>1 r8?֫ꊍ{na;ϓ/d_[V2FG`"U|''@ +冟g:_;$@Wh۝#@k:`QVYԫnL|p@#h>/߫Gy1I,$3[w엶,VF$J@ӞTz:z|?Pԯ5 "K^)GrKDPCbNl3Z^ EPU.(MO2ċuC¬P*[K&u|@ }N;>ƴm쿥S}ǶS} (m>qܦ8IL q޸Rpq޵*Xo-pN9A }i&HV?j^[a ijnF85C!V#2$q)Ǡc=g,۶3wa׺F6xJ2O@, ف1'&vt?Zcķϥ,Xc;4838R%jt$\[yzsʏ\POEpֹqY-,wE_$m̂,`䁌6ZJ<\K bbh aN~׿i'Hf6YI$ - 9$d֎y{uB$K.$1I;I;I 3Ҁ-xOD-kb'"n`@Q@%qMP?1If&g|~gQi~GN4 QE30((HkNJӵTDl-oUn!YQVg?5o ?ֽկڕG4X9OI7]? ?&i~EZF͹%@$5fM.Ns+"lF h9CJn@"߇'`|4Cm ST7ܙvfި%,̿._]eWi"YGThqAcaA VCR͸xXĞ^bnVw Vo,mI~ײB;}o8 މ5Y-y.IP6ك:ƀ:,[v+!Ppw9QʎU` ŊFiQGU 7uR "}#C4y㝄Rf?5*Y.ph((}oB+Za&@گ$K[}W%(((k"GtEi뽿J((+Va C`paasV ڋ~GާkʶAACV<ٞq8b2(<0 d~bʮXR0APUK* ")U2#MX%E7PrAm]c8[@QEEsq6RqYu֑*[)wLfurVf{$>i1? ·6(7zIH1F3 8XFݤwE[>F\c>F\QQEQEVO?jֵd=-?FkQEV6$ku䡆Q/$<űV3͏1o_0.3Jv6; yѬOU*fUa:SL#"K*=G)Wy}q9-ȥxXY#u !{qUb 9P rHih  ț>ElV?Moֶ(]7ueBcb#t#3“vW.9gaۋSg-n?cUmEe[mTE2j.}ʱcDUJW[QL(vzT)-GTggr I88J Ufhؑ!B$U  ]A"[Q,{F'ԒI$s@ޱi~"ŽӦ!hY t( Tx,Ai 3 bC7§ֿG@5 oaɸ_"K1]cpmooER *@>pAI?'Y#[*{7LsW 1 kkb[+dYO3G?i_'fr] 51,R? = k,‚ <FrB=۴H`N2z{`#v<;J?sW{m=<[pl-Bl\8xs֝jY=2*ZF`㴤H  #v<;J?_[>X Y |f, fmHY%Awg$q (Ē% yaC0 GRHP<{wD˦R:]j7m *s.1ߚ魭⳵ (ƃT VX*v5cgv=P2I"ϞmǶS}ǶS}faEPEPY> KOѫZՁmi $6UIiFHC@71K4Ab{vw?OU~{APy#v<;J?&i*r/:[ ;up&<[.yN?ҿ>O3G?i_'˯0}J< 5q+ p6aGx[|9w,0ıK(X|.6 ;J?|fCܵk$.X(S1_ m+ye apqZ|;J?|f0#MK'PKH|vu26z㞺ltkEbK'PPG@+4y#vO ț>ElUM3AӬ%ey-mcz#ۊ@`_a]LJ xId#j8淫d υ(Gs[QEQEQEQEQEQE@ik9WiXQFnZ~ki0z*~m{7.ml0~yIJORzmc}0 /~>_I+@گ$K[QEQE^\r,V^3bmAȌRA`Fpq[TPIφ/E;o_vu|BjWO@Q@Q@Q@Q@Q@`jǧƂW'̸zo5\G[6:^L8Ϲ& ?'TtiKswDΙZ;oStNKtcօU9jї5X9jї5@Q@VG=sѹA vP $<s2U?:XCozw-V1F@UO'g 6I%kUc&>>O,{((((((o~ė3 $ ~nߝu $:\ׁH@{K/U5c~Gc~GQEQEQE`C>oV?3o ?QEQEQEQEQE}DdV0:n~dVr^9!mEX[2C~.YVmAwߡ"N4ݷz}~[ 9mtZ6G+PYD$R0Uʂ& )EY*)Et1BO䵱X!'Zئ0((("=Ԯ_#J(((((''r tzr\!Ϡ1$OĚI(3+Bga! DլTi.T( $ §y?v_סEU9jї5X9jї5@Q@CukAq& > 6&B}S4+_ G] s2U?:h((((( )V*n-:Uo (v T5d 5шt $ ܁ 璾isUG:[h!@`T[f#5dc[cT`lQEQEQE [w5X> υ(Gs[QEQEQEQEQEW zDRdmoV!+}Iw"h4 ׊@2rG-5~xݯԮ_Ln?}pq0U~VvY.rގ(΃@گ$K[}W%(((>!ȏ?5+cCRz(((((fc/]MLzZrDz_QEFF=Z?elV=Z?elPEPEP\cak*e  XTtEQEQEQEQEVE˪jSY̰Z[*9n.pA;^M3Rom,VPWcS^}jeHޓ䋩Y/_ot=Kdv#5VN\ J,(G$IjwaXG2VPF# H(R4P0€9][Y|I[kx9 Z\YX> υ(Gs[QEQEQEQEQE2z d ? idZh;╉w?5p]_BvֳjM4q,a,:ѰAzcCXswa֟?kQ[!'Zج}j-lPEPEPEP1 D{ѩ]=sGzEPEPEPEPE ZZMs!DhM#|kĘ,xo1Mi56$yH1cJ:mZ *{o?˚ج{o?˚ؠ(*+--h1F =I< *UmYZj I I #|e  XTtEQEQEQEQE4\9e6?\ o¨>bR ~j`kcX޹)v!ݹ20#d3(4P*;T[f=F7:(1 ?1Iᭊ?1I ( ( (0|A! Q淫Hkz ( ( ( ( ׮š^N3DUVq?5tt$ViQ@U!#F>ڦ~85MwC Wﶡ}!\}b1cjd}k MxKHҜ%q>?nsZJ*1QJ+QEc{UkbBO䵱@Q@Q@^aasy6|xWjN?*k&O*xvƓ!g#}mcvh\ҘYdv1YF\c>F\QEMFY<ȶU1|ֵ)FFʊ 2@ gq0!coN7$lq*ݱi'=X94C#or>°|e  XTtEQEQEQEQEfmWQ\E]-N=\ kƵm>(2 ?1Iᭊ?1I ( ( (0|A! Q淫Hkz ( ( ( ( ־&gIC`39y?H7mCx^ ;Sp<# ~V5ucmgc((>a ?c{Ukb ( ( (9_#J"=Ԯ ( ( ( ( 5BV=yrMY"6@rK|QDmKE)y~z~W:((ǶS}ǶS}((+-aQC\cak*:( ( ( ( k;*I=:[tl%L-W-I+NoPEPEPEPEP]qE!=BQ$ǸEH=WS x{P8+nO3:n9?coEZ~oQEQE}W%>a ?QEQEQEsGz1 D{ѩ]=QEQEQEQEx;7Z+QЀHeV9n\X`Kܜ d ,dIH§I7 (G-O2+G-O2((({_ G] s2U?:h(((+ű|>%Ͳ [xg״]=jh=je/}KtQEQQEV>!O lV>!O lQEQEjsvн_-c6 f h,FsRWis,KueG.V+bAAEr߈3o7HKKi,hqir8fPkg#(((('<|낱FX?Q]MX[EpD/@W'χ4\2?"OkaI?E7 EVEP>_I+@گ$K[QEǫ5ݣi҅vFJd+ SUKK on6 QsY)E[kkWieGʞ F '@ǯ=)G$EcɕG tQEsGz1 D{ѩ]=QEQEQEQEs2yb^FcPKD)O@3= _|QnٵM#_`*B( {o?˚ج{o?˚ؠ#$m݌i i ֯3^1ƥp<[3= $) r#6FR:S%(#2M"FY2p9>$uχռ߰S0 ovQ7P]@IH$+_ GW_%xE&MDE:@?KlK;5ױīvL}<|X@}Q@Q@Q@Q@s-.׵bRV,$dV52c%?߿us+K;%kjqHN-Xvҵ.lXA.p:%$V(+ ɲ"62vT5ԥi=Ъ;G3Fīgi7a'xPW/އFt|BjWO@Q@Q@Q@TKee54-ucrx8ɤnm -čaܐǽ뫮kօ-nmpa {yVWKSfݶ ((ǶS}ǶS}+LWg{G7`YnmȊD=7`G^+ `( e  XTu=/XZJ(((( ?-eX͏Z6kH`^+Ƒ-׆i m ]è*) |L_(2 ( ?1Iᭊ?1I (8MGR?~PW+]GJ'8' @8k[vkxyAQE [w5X> υ(Gs[QEQEQEV'9YTֶr=׳m1Xuo.~4?SO:k((>a ?c{Ukb ( (#-1F썛hc884+YWJDCk6I<#9ǵk@_K}BjBAfq]sGzEPEPEPX>)a}z[^uVv9+oo C.tn}>7[t[KIX<sjUQ@Q@9jї5X9jї5@Q@Q@s2U?:k-aQCEPEPEPEWS]7Jd.a ?YQEQEQEsGz1 D{ѩ]=QEQEQEGd7S~YYFoaK,+By.'" Yc[C>>>3ػiN6zRwóJ(1 ( (1ri.kbri.kb ( (. {^I*$(Ze  XTug}i[+.a$$2\#-aQCEPEPEPX.5KsGVyva[ukr>HET98P=7u S=>ڝ=QTbQEQEc[c@QEQEgkt6oh.daS!@>V<gnќX ~.ĉVT $qWSVaJE$ҴE=6nzuu [w5@Q@Q@Q@Ϗ0x2c,R?v5ieZ Ai ľ}?ZT x;3O F7.}~50֤_žg/EkQ[Ess 7,pĥ(w]]̐wsj+{munne\ZA/j%+h:hP\v Y_&IaQ@?S]%``QN1V"gZ.ˢ- }j-lV>_I*B(((cCRz>!ȏ?5+(((W%o5ig%?WU\Ө&+(KRv&?Kr?]eL{VѨ_[QTbQEQEc>F\c>F\QEh :`UPO GѠF"2t[Iri.xsJ`bMXd[Y /{Hdc˳vxAV?Ҩ(((WÊo|S Qಋ8؎TGA溪|L{4M^F9T6%/QTbQEQEc[c@QEQEQE`C>oV?3o ?QEQEQLT &f=&9 GFP8 ]=s"XOw,[1b7~ O~o)>2YR^Y\$h9$Mq4%ԙr>}i9r3GWh[쿭iZru^:UR<#ϰUQBUEl/wQEY}W%>a ?QEQEQEsGz1 D{ѩ]=QEQEWQ6Z|UhN79GHZ_sU_O MO)= (9ݩ/m^^n޳O!ٸG+5Qc~-4r{(QEQEm#`Os[m#`Os[QEQEW=/XZJ*Ut4QEQEQEbko\=:JQ1"A;үi6_ٺ=THqY$e<=o xnyHT?#tu+YKݤ}EQTbQEQEc[c@QEQEQE`C>oV?3o ?QEQEmtIq~%f #۽o//tM7v\e]]t1 >Um?;-EjҭQEhI+"{\^6ؠck3VSZh1Mwޱ'01Ua ?c{Ukb ( (#[$1! *kZYc'Lgk.7) Q4֖F rd6;Xkq 1Z\4o‡dSz ԚO_#J|/Ht?6_buvQEQEW,Ծ$åXM#`@,;!86o&9}H G\YRiCݧ)w:z((((ǶS}ǶS}((+-aQC\cak*:( ( (f dP9D]E;l-[$ v?:IXZn$4 VLvvQEF!EPEPXGoPEPEP\_Ղ i5~SV]^Tc,{~5/V;O=\pc/zWmEF=Eꉢzd#ongܐ+B;۸!ȏ?5+cCRz((|fuie%.V#%!`}@GEGDUG@A\Vv&>oHi[!#ISu6ߛQTbQEQEQEc>F\c>F\QEf̓H v O>!ȏ?5+cCRz(+3_%tyfU{ Vl+E϶X iF6|#_6}H lkE'+׮LFl*{}I>EVm;(QEQEQEm#`Os[m#`Os[QES%9hE7dqG(+kk{8 X"%āT~e  XTu=/XZJ(( o뫢؁yglzW >kDƕXXaAHoBOrjWK(&Y;d4CkrjmRЊoaEUQ@Q@Q@c~Gc~GQ@Q@Q@> υ(Gs[Ճ [w5@Q@s~11h`5J)?u?1Oj+GQJ@DZ^dkiAu˯zhF#4`W;H5|=i'ԙIoE5n-?=e|~u$G&M+Jjo3Pc=[:aN^[u/װޏh_3Y"cB0:+S(((>a ?c{Ukb ( ( (9_#J"=Ԯ (Q݂N8 kk3/^s?詁ϭ/[[; u9<(pV̭q[jQ@ ;/QEF!EPEPEPEP=Z?elV=Z?elPEPEP\cak*e  XTtEVf6fDpdTdr}:j->ͤmrHxڥTqMS'Ҋo[-|sA&,\]}C=Ԡ`4}+R)mQE ( ( ( ?1Iᭊ?1I ( ( (0|A! Q淫Hkz (1OD%-s!ۢPsoa冚cI'NAXd8]/DV>G=Ȁ{vR]ͰiH)9X'ʤ7%WэiKSKͿ_4뻋_I(((cFw`%֪z~}!5 SpN(CRz>!ȏ?5+jyt[b* E؞j͖w#o|7QG,k7OoI5iLM~`2G !RDk+sozMiw)<ƪRm)p9X,GV ܢiY9)QEQEQEQEc>F\c>F\QEQQ\\Ain3G 10UQIPxAV?ҨjPWP\IHdFG/XZJ+3Tm4H[dRZ 9p)6F2Q6,:}^j*L/P?C(~5kEGecw>T?jڔa܋w8q=krW՚Tqۯ.EUQ@Q@Q@Q@c~Gc~GQ@Q@Q@> υ(Gs[Ճ [w5@s%tfծƿ}:Gcxtc5-c''Ong&a ?QEQESͨoch-)=YI_yw"wٙ6qF\c>F\QEMV!/zzZbh)QddEcxe$\jjdi7yidMwcj#f]lL;0.c#c?tp,EKcfxA҈ڂ]lӥӡ+,H 4 +̔I-3Nۤ VsOi.^U (QEQEQEQEQEV>!O lV>!O lQEQE.֑fPe bR?s3o^I["n,Wv78qWh[S]ROp%ۦ#)عE w+/4;&rhe_s֬?IÝYEIY74tWsڢq`dR$AEUQEQEQEQEQE}W%>a ?QEQEQEWQaCR>:MzeŒbƳv-.DJꪓj+f?jcnvۻwmp3Po!gk<ַ;[BY'h.nBJ,v , -;04kv3\cj!gk<!n:00IÌ?oqҵ, [g/\*ARU B(3~^ڥxFPE[gݭm(3~^ڥxFѯ]7b&0 ݎ82U, O,K3u5 f vѐBoʍܸ݌_~?Z/O4yHuBQhP_vg#p|5-m]?Lov Cy{j1ƶlL7l[D-uxӦ%ꕆci1Q  IV fַ;G!gk<㵿Ym²ϋtA%yNg)~'E~?Z/ջ_WQAr+@ N8JFv@k:؍_c |2~w3~^ߢ0??[^u=A%־ ~Fb̓k -/nS F0J<[&A"yyQ;f446Kh-V@F21K9$unXjV/-*6#)l`AtQEQEQEVchv.dF'c9c8y:(KE%IfyQ㉣Cn^7Ѻűߘ|WMEfiZ$ I4DhX.onNOEQEQEQEkj|D"b6G2,N9+N(.B DW10@e#+YӬ[~Zmt>Fʜ8tP6qi}"x(?ASES͉ɹJC3Z}7t=ӥ۫&QVbr0?.2Kg9wmtחK$K;;'EL{J/ys] QEV~E5N"Fe;ЊТ9>үFsgçwG~cqZzVoI#,n!Q!G(8ۓi@Q@Q@Q@fiZ$ I4DhX.onNOE{A{|o|nqI"+̘ 2ȕxJ(>gO^ k7mFTvwg+~-?OCoc@'*z((>lǍßpGu< GDkMEdf x 6>^+0|+gaz1]; dv];VA ӎ+v(('YM!P`˜FGk>OhMj16 ۰}g5Q@t2=294O If+":vQ@Q@Q@Q@Q@Q@Q@gkO`aeW@-##Ѣ8؏&tT'b fuOk髯o5/1 6v`9+v((((((((((=sRN *ȨYpAnA=Ⳓ+ucȈA,` w1I90:kI_-|Tm*ĕnEQEQEQEQEQEQEQEQEQEVu[$UIJ r [P'.dstf,s,!M`0#׶WV]9eK&W̎4`W#bwsע ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (?mets/vignettes/robcox1.jpg0000644000176200001440000003535713623061405015326 0ustar liggesusersJFIFC    $.' ",#(7),01444'9=82<.342C  2!!22222222222222222222222222222222222222222222222222&" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (6}JZ[hm= I`I$@VO5 _/ _chA4EdWE>l"kQY?`6?Əj@VO5 _/ _cjkɮXlHm7$JtVG~A5?/q Əkk4Edg___?ZkYhֿ8@VG~A5?/q Əkk4Edg___?ZkYhֿ8@VG~A5?/q Əkk4Edg___?ZkYhֿ8@VG~A5?/q Əkk4Edg___?ZkYhֿ8@VG~A5?/q Əkk4Edg___?ZkYhֿ8@VG~A5?/q Əkk4EsZ柤^ަI(V\N>DG=YA4( ( ( ( ( c~&#OYAע=\I5_2z]\UKrn](ٖh- ;D_p_ _SEѯK{0 E,@8u2J;\ w\AT.<iqWV n 2ָG}?DIMm$z^yJDG YTqE^ n4uu{ ,a8.PƇј, )ip@v@Elr-ƑKg<;RZ&9 'B[<eVS(ƉT 袊((((((((((((((((((($p*gޠf.5.I$.ǟ2<:d3gljA @zVR[JinX(.`J,ic<Y6pJ$]UPNkRWerifxEm_ _hʨxEm_ _hʵ6$((((f&qpΖVy;܀ rI |mz+g]ɻ %F0d`[}K3oLc񃐌wHO5cLm>+Ea y#{f,K33I$IM6{FS 0V w~Ÿ%{* 2OUuuh=?EQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQE!!FI͸m^$r9K*w"i/=4 9rڄl*JasX9bڡfvbNN3 1±DQz ߩBjZq{[W*AG;t=oO@5~=p*O@5~=p*(((((+{O-cE?趠((((((((((((((((((((((*)+_ZMMsȩUgaMUcڤ4|eҲ1K+ ʊY $³HV x,N 8W|Hr}:}kBYE_* DP-9Q&[~>c &lL֬\Ҁ` Z((ȭהUȭהPQEQEQEQEP46wڥbfQwA\DZ <HD` +/j6 5+9axу\s 3dw_ YAnY۴3JQT;m1l[Vi-ȸˌ*YGQN?1{ Ygr.II?d{i5DDuIDf$2 y̾:V2[NZk0Wv ăc qRY%ys$A*ʪU `08zcO[V6ҞܚQtFåQVXQEQEO@5~=p*O@5~=p*(((("; ~+F?[Qi#K^Z;bDݵ&wTo+Q\rWRywG2"5Ć0y=8(cE?趮Ggڀ:z( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ưI8-…$H(c ( ( (3AH\`ֶE|4%x؃0pGQs0xXV/!kgTEW$t|;$ƶ$04 `|Y6n;r84\Ƌ#ߊݳm[Wj:+譔=} W=bV':E司ݲh((((((((((((((((I'֓vv%P68N31)Eοxn§Vr2Tq]9$N.]8N]@ĝsӥh*85/%ZSE+[YGl༓8?5$pm9lj4)5QP` uVEPEPEPEPEPEPEPg?Vo?VoJ( (0|gDžn;HUΒ#*IU2\JNqް<#in)f[a\_sJ$+l%kJ|CIZlՌj,ulec2v_c(TGs?M43R$!p9sҵ(Ggںz4_Sj袊(((((((((((((()I(P`RтF񦢬QVXQEQEQEQEQEQEQEQEQEQEQEQEO@5~=p*O@5~=p*(( O? NVckmu*, bJ̮%XMfD=vkK) , Gp#ȱhsڽdV9qxdxBM,̖-tIZF u8c@Q@Q@s/~)vEth=?EQEQEQEQEQEQEQEQEQEQE1T( q`$T\`{w~D3\c>Z{ L "v5/jU[v*ͻA\Cu-`"pw>>*ݝpgSr}zcK^ijƤa}iQ[Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@$[W)W/$[W)W/ ((u\]C}~`kXVGER qYZ4[u'ڨ!#}E}Mi;ϝ뎞aT;3֒B|Dc:EZ}K;iI9$ONTU`((((((((((((((((('ڿyMo?P'ڿyMo?IEPEPEPEPi2K#A'+zLVfl$24ň ?O'M_^^j-XWR"<@0O8jݱNb;|ٞV9,z4 |hݜm{l?nqme)YKV(((((((((((((((((('ڿyMo?P'ڿyMo?IEPEPEPEPEP\Ƌ#ߊݳm]=s/~)vEtQEQEQEQEQEQER3*f]G6f+*7oSS)HvZ2Qd>Vq7c[@{ҧ[MQ裰kMUTaF+>YOrΦv*Cm@w>>oV)+#hEYQL((((((((((((((((((3ğ+j7j{EUCğ+j7j{ET%Q@Q@Q@Q@}zvi 1.{[ՌH[+tw#v&Cq?EM;ApCA 4_Sj{O-((((FeE ZwAf'K@$ &-vO~{ՋM.8#gaÊ˝H}J ۧ-o6a违hZCiHUc_sVzQN4ʅ%wQEhjQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEfxEm_ _hʨxEm_ _hʀ$((((7ڂ&!l$캄l09·qxr+K{U;-"s6dNl֔V2,+i# GК)_hfu ™Y l+͍_ek Z1\nº4_Sj袊(((h]*IY}q/Mb+_/OJMGԉQөfRЈ/3}ؐncҪ-ΤH;[=>vONZF9ysMZr9%?mH5ڣEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEO@5~=p*O@5~=p*(((((Ggںz4_Sj袊(Y {PKJƪ?܅9c=@o'4ˏ}z}zUKl%ssAY9|?s Ȫt%\CxVFUF ;(QEQaEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPEPg?Vo?VoJ( ( ( (9-p4\ hܭԅR%?~R70ttϹi7d&%[m@[W }P .~"+lڬ[Yj-#$r};UW/3rwҊ( B((((((((((((((((((((((((( ȭהUȭהPQEQEQEQEr:ޙq|Uƒח\7-\ȬXxd ճ#DѡDݝSbwg!W'jVV>#. ϼt}BM MnH(BSßҿ?i|'|[RxJxͱ#>buŠ#+/ Я/&7B<'B? / hz#+/ Я/&7B<'B? / hz-|vFxoG1* m #+/ + Я/&B<'Bޢ / h#+/ + Я/&B<'Bޢ / k+IoԵ *"~ x$IΊ#+/ Я/&7B<'B? / hz#+/ Я/&7B<'B? / hz<= ͦoGv׊ XNq =j?_GW_G!_E|_MoQX?xO}4?_GW_G!_E|_MoQX?xO}5^ iI ;Ku$vtV!_E|_MxO}4E`?_GW_@V!_E|_MxO}4E`?_=_~Ex3+Yl"UEs:*m?tfc MDX#+/ + Я/&B<'Bޢ / h#+/ + Я/&B<'Bޢx;xvX|7G"Ǖtr:?@xEm_ _hʲτ6AQ 0QEQEQEQEQEQEW9S-ΧBO=hD:˒8 qYkj tyjn|sK!N Os@ .]_FwVZSΏ!Yw1'VmPEPEPEkͩ (vVɧMuv@ĩ ;z WEq7ZI5-B%~3FҀ]y Gدl+n7 s|d1DpVW9*UOQEQEQEQ\׈P^xu[ ȸq3͜m/LڝS-ΧBO=hD:˒8 q@a3FOrU'nEPEPE\]5Pv酠]N~cgOtW-^W!V{g-PnHCԴ :m-/9>PFI$rhQ@Q@Q@+cDlKړ4EBdc9[qV]|M{un͜0QLH于6lNh(t ( ( )1F ;I([WY5-CPVђVhw.bvL|ph Ub}0V"a(6v2t"(((bŅ'~S(NWy N'VEe4#soW.j5 ^ӣYvLt##((((((((VzC{2H9Z7#rpH#GzxKZAh`{e{yf70e8:TP~hʖ1:X4,+Yb8B((([Aui AY%xkcr*x8EewJ#xmFGEPFŐR0'!< iVzE3#ij$PEPEPEP{kme=k7 Fɞ:ßZ{7P~̳[E]rsRNڈ=z(((cm.Ǜx(qUʖsz}jy-\[\<nGXv8!+h#8P0@v@Q@Q@Q@Zw4}&n7Wwu-i rXyI-cjew6ѬICUw$QEQEQEɡK$PLr)FF#Xv Ѵ$j ̊(iS\؊ߢ1ѿF@u|[Hs#<kf(((eWB# Z(&mk* 6ěY#ƾɌ`z kI:jFԛ*_ie]3/$EQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEW4<[hii;QA,p98"'&~mr2;u|k`ڟ(4|[waفr1j:OJ4 -Z8ૹ].F:@Ey,~l[cX3h.Iăn#WK+ -.59R&aX].K#6H*c<h(((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((mets/vignettes/index.html0000644000176200001440000000423113623061405015227 0ustar liggesusers mets User Guides

Analysis of Multivariate Event Times

User Guides and Package Vignettes

This page was generated by the R.rsp package.
mets/vignettes/rec4.jpg0000644000176200001440000010352613623061405014600 0ustar liggesusersJFIFC    $.' ",#(7),01444'9=82<.342C  2!!22222222222222222222222222222222222222222222222222&" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (6}JZ[hm= I`I$@VO5 _/ _chA4EdWE>l"kQY?`6?Əj@VO5 _/ _chA4EdWE>l"kQY?`6?Əj@W5.ZI3k(nghtph^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+b4"5fIBRpy&/ 9 EQEQEQEQEVF#A5YzݤwZeBA3M}!F羫k9@VG#V?U:tz9Yzoc€-W0ZC\1nU#\ '$H_w[/$Y2i#ߓ+Ku  c op(KOy,V巊KFF6 a5=>@/H睧޸M'Gӵ{мFMmZyՌ_hm Sr 2 k7!tQuʉ(nHm=h_详ƞ\[оpj[gKRrR:OMWhƥso[ov$k{imZQy>r3 lt`PeRC-IM/eG@1a@m'sOy p=[PK2;VO J$D 6J22;qy-^mI{Hg{Ɂ⌮fO?2^X]ōߋ6&)ۏCb7/F=[)#fح0g?ZʹޡohIk9\|gyt{]k7G+偷EHO>eaϥlEa )+Cii=nZ(f@n% $* {u^8e$=#+׊ܦkU}XV\ƦZrqRF3g \?n"d,q_hpKȧ t3M?.?[[DAoQDD *O-?ex| wL}45 S#_h@ŗZע2?*?1eJ Yz(fAcy Ǖ&9?Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@$[W)W/$[W)W/ ((((B@$K^sxSV&{]\]m1z20`l^i u>[x^s Ǖs?7$'v c~&_jk^]$,*})K9c\omrSQ֋qeL>~l밹s1@F19|M5X F[J8#Q[9,p@ V!> RC6y{vs5$H|WT7q̭,3.H9oǗcR<= -nIUZ229Q`HujZM> \ǥr2zNk R+Mm ժꠅ,YYz3Ѳ8E.5+wvFr 3(n^KM>("dž;>EfcX:^kp\$ $7[9o?7c]5Eqm>Mm eʐp{ "j:i1HmhF.78ۀ1m*5myQ30}ϻoeXlmD pz5=cYnmmj}NK=Vs ,>}$gnx'f 0>=ϭsiKm.62f  lI<q< 輼h =F#=tc9-2U$I,Bր5[a )((((((((((((((((((((3ğ+j7j{EUCğ+j7j{ET%Q@Q@Q@Q@/Iea}u-ź[@\RF%T(lrO;ֶۉv:VVe .x7վO*]]%Dϴn'<(&[Fj]3L僗afq>z`5x[ZOqFSm?d@ŗP$@#e>:d˕mc RrWnwc+-!g*®XQܒ$R,_x,K)p珓rO mBv%pÓ4g3ֻOy,V巊KFF6 a5=>@/H睧ހWKՎWӢ?|b{IƨdWyA$*b{V6Hua /xBq8 ႜEP??/Zج .^L@Q@Q@Q@Q@Q@Q@Q@Q@Q@"*r:ٿMw P;1SL 1/4jbX u'ҋ%]D%9'`%N(QEQEQEQEQEQEfxEm_ _hʨxEm_ _hʀ$((((AˋҮ4jEgbW' ``vI& %(s9 ;T .NtG]-P?jtB6fM\ 9C Ao2-K}? H$=Nm-^$$I `} r3 lt`PeRC-IM/eG@1a]_&>8;?6Cw۴c(oYXN%bXd0A4?i6(ԚHw(fm+^\XimҐq^ ݸ3qc?~5 Fm(iв e$ocWN"ѮnO2Ȱ w3P6N0r=g~"WZޕuim3=J*i\,F7'tQEckAsBJe[QEV{hMMMRȳER7 =ZMeVь9K$w4m*Ǖ, C˴}9_}t#ƅ݂$*&H\~pݸ昺]TkhYd28oNWmB\}N?e!G|6Kp]'xՐz9>~+> F0vqt#hYVw'bٜr-.u2/6thSc1}SR`F#lZ0jX=T$y|E@$ړj&]p?.Sj~2y\]Kq$6|?uv>"72[wnIt너md(ujkڜQkRlks H$`3ğ?̼u(  .^Lwh]:x̒A {gnߔgRx#'>o(U?͏rzqo ռ42)WE PA·Ú]2GZA4専8lA`Wo$."͒(ˬxcVoI5ZO mYO|ܯEc6v84_ cu4~#[.VǺG.- lOgޚ|;];t^G,wrk P1qҹo h귷=hL`Iqr*iY\!D!nuO\PI|Ej,Ti#P) ^ݤI7+_'U-xs+K*9 ˫20_wS56H֧主l0ϳI\FvpjW6ek{{ٳIKKyy`m8BH'(| aEq ԭ[[~T+6PFz6GtFs#.hAe<ǐ8ϛx[յuAy$2Ii"\4$$#Jnu 8WG2q391p'CVmP9,c U [hQ 붂 $(PNv&KnosTG+Rm0m#)puLzyB~&4m6O.;.̈G4aq8h[a )(((((((((((((kt]Aj`R]rj*/Enw܌*AuPgz̻w&70nzm;G2˹-o3t= h7Q'l?_ǧ߭˸ܚ@vɜV݆}:{ 8eoXv;d>eܖj87(`2G̥OiQEfxEm_ _hʨxEm_ _hʀ$((2 %mGdΒ% # >`\eZjoo͌/wT T|93:[u{mřvUސ!e $#}0y^ OVDy-˴Z!^;z(1o#JYn$Ǚ!L1͏ǮkZ Kx"PUpIE?ooV#W륿E2Ev akڠ=^~B&mt{WrHhO1v#?\ʪT`0Pջ 4l[##Q0w;pDlAQ{?iRT,r$呌?igjF p=3ҧ>,I LH ӑךs8;;*j(AʈZ)Pdg\>Sϟ&7.1cNn*Z(TBn%ly;h[` W#\0;ҦTZ@<9bXr9>Kb0Fsr''榢U9c@-S((((((('ڿyMo?P'ڿyMo?IEPEP;j|%s˃Bkr[x6[h uGkE=wwSZ-8FfػAm@GoJ]ŵ۽slĎ|~VX'5xa^\Z]T2,ƒP"n+לz Q@u-:0u0Ĥ d #\xn`{yRXdP$lXP?ooV#W륿EG4+<{r2jC-?i9=_7B[E*!1v~&=ǵM +a9&~$uwre}4_w[/$Y2i#ߓ++R`(QǾ{QE;]Դ7RID0(l唰P3`ҳt_~mսka܆ LX~qN?\Kat?g"3'<.OׇJ6wpB"A88WR&Ea[s2"nӃӊ+/vA[8'\-u f-}o#q6M,SO4 j{u[}"d'ȦGSO84>ӻa$qUӬ-`U?r߅TԼKiw1y ^<-RU26E[a ˂OpuuQ%ŵΕk`|\GH_;F3U7Z*5,cT1;y-W3ʲ2GwZ|ҰXRǰXVRQ#cjc0:Ĥ?y\ǠsPuվH2/o݇tCA[WK3$A; u#8FꖡŽ+4bA ##ך>+QFr;=UV7:g{ {87@## \ҙkb5 !{2QETrM3rO~)0d9$#t~kdI$pwc!T'Ipi\׎}C+ =I%+7YR5!osy2ˉc5Y/HdXSͅc 36X)#X˞j>D$^h|b c9VQeGLI[+vhBd-PYX'pJ䃂8PH$Pj4kkcas(m0TW\ +qvsS>]$GO XmeN 0@1g  xQuo`:kjPMk`$C#6Pms{udwCulrJ0J/QЂCkMRi"[ Bc. ݀9Ni!5[ٕZTLc>h$%iPw*Wdv3@v :=Sy,RvT@#$q ZݵivJ8 I,P5N—SxnIV{r$)u$I 23Z%kۋ)D,ʹh]ߜCa )+_ S-jM2r2z*c j̑`19nI i<Ā1bd&I_tlp;l<:ɳ{qe_9'zTQT)$AEP0(((yʍ{yolpyUli;$*ƭ+5Ρi ldTvz'մTg-!UpLҩS0r6aiXHKcv0ҽƢñRʫc'-QW.TR/wi#nxޑ4֙}B,e(Ҥ99ݞ>D'/m|ϞH5ڼ =S^31SVmllal9 \T^ +K g?3;}G4ۙ}QgwjRHK&PTE ''tsEڒ-ܔv9c=)_puF?f9n\ x4 sɨ\Xۓp@#ޮGiY I4hkǑfZ·PB³0tJAc]crj{I aͼJGvҮl0¡77`Nj{IadR]  2cnuE)Kv0*@('ڿyMo?P'ڿyMo?IEPEP_٭Lqښv \c{]*:dik>HE^#t/NH42UU*^G @Vn[kkKo-gmjT("}{son%A2O$sxIv%8tokY2,-iD)YgcuGRpFA+å%Dԯ ?R`3TQTPQEQEQE5"B:(f8P$qY{gTP>*f2Y7)A\$OǶBo!VU`G z+Of~bZnd(΋ew<NYtE\t?ZҊ9_[ۈdMCP-2 i}!ޭ[٩dž v%071oĚR&,QE@Š(() b4- J1p~U'Z(XG)#U{joi"j*9ʂ4LA$YI#PodTXs!zl94%9T :V;W5  ǿJk<[]Þ_5c 9.s݀ >8W} d B j6r7AAY4H[Ԩ-zv}3Ny1o&vњ} 7 (Fg?Vo?VoJ( ( ( ( +OMgMHT{{Hc,PyFkMk}p:;g`5x[[Ճ?omN,y8?vG(?03 b6~obR]yD@%%x:ݮ (<.1**Z(mv%mZiEe<1@+7;ϥX>Џ99=O^okOedm ZJG

R@#5|3S-&? I6Z c)yf1^὇Iէ򣹒K8Dcu\L<}k}#M6M>hE+BD#tgJOhXc.g [!3꫌€8x3@UG Id [yd g*moP2ͫ,0K+5 iʬ0;yqz﮴2Nkc$fH 曢 ԯlrZ8h~Pg;g1SS:L/#0t\5r`c2kh 5ltDZFXkh<C] Ff!Q˹IxSPn?-.< 0Qp9#f3 < a_ޡ'GH$8#> E'N6VQiwF;4&ˢYOi9/dɼ$za )+_ S-lPEPE[^I;#A~2p2GbHDafgr_@`EQ$%w8[ Jf@08gZ\j7jQE#@((3®Q0ꥆjlD^3sU(IP(0|8ݟIQ_&-~~}S[A܅8nq[_Qyx*K>ff]t.Tjg`V_ E;d9r."%r%wep*C3ğ+j7j{EUCğ+j7j{ET((((RW𝞡7{j iMp@Z4eZ𭭕-e̴DL4 3PxSi {v"#r#,I8m+LHӣUIH/#vl2YP_S:mIm?].&`ˤ^Xǔ;d:HE ?ZL~T` 9~1fV2b]`,QXZZjͭ퟉lJ[:U,9Rz=Z{{oYKww ]NsT/i<OnYJy䟐isEcZ\(#+g([1wzVvf{=Lv c՝j&Z;R5T G0"ҧy=nu]:  YZS'-UMKĺVs B%S(dXնܸ$z;+E^Xi'gZO#V͸E\x[}nf$ZI仔'Gwm䷑_*Y>~`q=iʐBJcK3rMy6VVn}zc^hcf]Te@M]7f;KP\DZ8ftܠvu5%Ui^qZVj+9Ct]Hǡ*FIW_ S-lV??/Zؠ*w<1[Rcت,8O8TbK/DxTިOnLçA ٻ;1^lI۸9=8( n[QcybjTe1QY(({$EesښMD|LMTeF;*?NUB@1ODJu%<Ϸ2Ɏq9mKl[p? 9wy#R2rNrI=J(nF**VAEP04["h 31u5Yu̎LRE(I\eĦ{ܸ_d[˞nnL#Gl瞬FOQ;r[v_3FC^fۆUl^KcY[۶]fU/WW5]IH;PDG[p([[şPʑQ'rjߗ܃>E'S.|dP1.GR*ĹfG-\i.gOȁl=HU2U `0--MŠ( ((r ږ{03Eg$_J;'~̗3~Dg,Ny~\5x+I4;=* nm%E16qLq:ƧRmF(QnK!bq܌q=:-$Q#7  IAı$2Y,)±,wg4j ?D:Un-q#| rvW TIj*ܫژLFF[woUR6~ZݹƙKq7wVb;;x NT\ma%F !n ǜm݁@-l.EF`u71H P~gA桤 qu}3O/}nd^Ͽms{udwCulrJ0J/QЂCkMRi"[ Bc. ݀9Nhׅ.-$eMn[m7M&nCБ_mƛi~$:}f[Kfb.ߔew’fk%lE/'Ѵ+&\/Pqg׺ue2<-eY"gn1<ހ$[-IQ.e&3kEdU(HiGW-qےA\auwIeAawi̷ c/FdlOmaii4A$ i `n=NNFƪ 0r}#(QQ2 NN&)IE]y$/#QԓQp#s׸H;,CnUuz|bDdv@`ibFqsBQRIˍ8-B(XQU.o'0!9cx9lu@r2KH=8_v+&.TZ213(“V{o?H|L@fh펾n+[xXPƌIbU@$2hh-?UofPqy]QH#%rI.6@OSWhoX=o*Aॲ[=6I<պ(۹2'p)S Ʊ;k}1}QC =`B@$7a=dr? 9ۓy64zy:A*dShW/gTooߘOoy}~ 4ms){Roo߈\g}2=܅{CGw`ms3}nWҮn|C^oIk6Z$4[ .zu@5a4%'E{K'|\pPc/ͪ梋*1LnA=qfH%6aQqzM 31ŒI8:30m[t/LX5?&v;:;>&}72CjX"lgܳmcd4ۃ<jJQq%ՙJ,UL;\+}H;v,^KE]4-_`k-Myd}$$۲%RܱH8q1?ZC-:GmT,w**_]=tyu$rEml%7w:1s֑f׮"+d%ZY[y'jMGHGH}6Z!H"XՎu>ٛm)(9$v4occ?Od;12N3H#$!Gn¤W~!?֣lՂiStoI\EPtQZQM2 p1i|EX)c`IEG3G~|DAҀ$̹O\X4r (%"9`1R x1@Th8JRqJa&$;>8S?9r yw^IE0 \~)Q@$[W)W/$[W)W/ ((((MwH[;!.<)v>jm >akwdia5=̋$ZH& z^~ז6, f\X Uϔ; +ԗƞ#O/ٙc==>?i_2U[_^940D{u'YL)OO1M7~#*dg iqo ռ42)WE PAhNd:feddsmnL=MWOO1G|G@+RDMҴ: *˙UTWy9YGfm-O~TV-P` Cqj|G@+Rdw"1]'K±\JNH,=x( &[Oy) r'2NC4Bk7 /RTfW PQ6sW~?i_2Q+Jb+NkGSm1L g7)V9䚎wZv-yZG"L|-N3\OO1U5mcOϽ-]Σ'Ƀ4v@^RgvW EAw=KUӴ}>bL{e@8Voψ(# 7ۤDnG;6Nj|G@+RrG'ҥP=$I)rc'<խ#GGuI繞c=$.Nª8~?i_2Q+Jb[X+ŅnvX\38 ; ,ncF@,}{Е)( 8@iO7ly0$8H6g|ncnbܪ+EYw5 U$1A=*Z(fb^O)w#W$U_7>U낿3z #k隱ieE Lnbǖv=I=_*F?uyt(|$-d9!뎿ME/#v$s jNzZ:!:Z:/QE* Šg߆*A oov>eArGaG;)ڕKd4Xh4M$HO`V_\@様Spq޶I%d!TBVp8؂pK|<.$/M+!#qJ"d2PՀ?7%_lgMҸh=w7?,bFQ&ER{$deMۜFqqyhMSPf̚.2Krx#7=wsG1 ?)}lPʠ 2I5^MF&eCU ndSN`A en$?zϮ9*ڡrrp1@Υb߶ܫ4gs.1yu+F D7MKUM~bpOg9[N(%PdN 8aG>V ~vvnΘ>cXc'&/bx>jJ((3ğ+j7j{EUCğ+j7j{ET%Q@Q@Q@Q@Q@s/~)vEth=?>ݚY(]sX74=PRRmVsdqnFOr=kۑge5+7Nޖm-cdM3M'}9w2jkƌp2M+0Q SUSr<ČD"#-^'8ܞ8<2"ƊU5m8En/ %]2F@<qzpI-KJMZ.cGy>ԅ ϼ /<|sVokH vmfmY2 iC(aoeKs!yżo"ܦ Os֋-<۪\Uj#2bI4FZ_xhbPNyTD }54`$V|!*sc#70yG"j64Dm29縠j02H6s (i|ϲ\6 ^*yq{Z=??xWy]Ρx9G+Lsn۶F:ǎ޼k*crĀPG'RKel'`S_Z#n-| Ҽp@}*I-&x1\# *ǸՇˌ=[[㖸 ֕ۘhGEoGH4<,직~閳YѦ͌ gքn8+'?-յ la ǵ/wSa"&rc?dHcP9QSDoVfxEm_ _hʨxEm_ _hʀ$(((( 5K䅶Jm,'X۸fA^!k")Bg(Yr2ĜJ~q,}viS˒_cv0: :4_SjھtdH/°9<]K9-|j$tc0EuU7+/4zHج lHzʌcswbĒA Zb`=!3zթfHW.ܞ*8`6vۮA2HsN $\Ӣ, G*u 6_ ,%SON8-Q4;R52v=8g0Y!g3d}уמi9k1I$d@:{VRf.J$2 !Wֶ*e p#޵`>Zc|`@#뚬VbPG6eo\UIvv~lӦ)g`:pQ1޵"?lqBAt.VAmewmI]_W%_%?B= ]0;@8tGPD&-,ǿn}*?+︹'dryi{ ܛ,4^%6^fXг0UQIjA$ۢo X3)j$Y o"bc'5hץe.?^Ts) =U̧bhM=`UW #jvn Da;0H/$ qXaohçhpCH:*(P?Jdb; !2BXۿ, /ۯ=*L;ʈ-cz31g<sҳn_RԵ1'0uR8E,g{0:'MI;{c%0P>˴g=F=ZboV*i(_tVQo&+=60v$ t9ϨNg֤L\m;m[09 5ΗT߭qJ\M͕dVP3L/LXrX$ ,]$leᷜtS#yo29^p6Ñ 5eX/@n7I1F\L [  d\~B$PF@Jf6νr3BM>]Ҵ4.8RsXku ?ua)V۵FHlAO9NKdƟpr0 q<)$/?5u_PT >By<=TRm6RT iX2M=@ A㞢Ljs9硄ӯALE%w EB>\H c=i/P_{3Ri'{FXJl |{n`} F7-nnW2nwԌLhڣm>lb6I'ӷPt}Zkv[A#NL[=O%J6mV!կ-}6#J(aQoؠqp98v+M%!2 1Sܒp1k=;&Elnp|ξqq@viFYq33A"B~1T7'Q_ښlvx3@6'{O-"k`O"-K`~TH -j*֞a<n\֟%?$T[ ݬe.B)v.1X's֜ZEc$ld6 3vfQj캋K9Y6>ֱ1cuJw$eom(?g'cs[Ot&pfe{xї?Ŗ {dҦT*5B7 `bS=xMڟ*[O&$F1ċnOa#ۚ识?Mmʾo5 y\&h~x.3ךWE[;Tr qʪzNm1PBG>Lp&>.Z=?̮Z_{\W2?.q,:g r3L3+M3L=|JH ̌[a@*_"舗.{oُ{H-}̡-1Zrw;4WۿW)IK-x0:ŚY6I'ӏ֏D`;s?h}{9ǷJR-[p(O!kߗ >f/gH'܃8@4|l s{?9gPpFFy \F|><:U44itfg?Vo?Vo((((?WSIp{wpIXtmm<3<;zܫ$'kŕ7$(!A<(u`MlV}惣hlnf_2ktv2Fq@VG"qcK/ ԊOOY5dgh / h#+/ + Я/&B<'Bޢ / h#+/ + Я/&B<'Bޢ / k/ &zE<Х +e!FA$ 椼Ώs`(INVU!]AխEe*]`jjM`\!pCp޵( ( ( (2-c1anˁU;Lm>gHb3O$պ(((((((((((((((((((|ceƱ yib!aWs<Q^n}siZ]vy A̠m$`Fsqitow>Si&Ĉfs<Aq[=I#I$MW,y^w&oi"s"\ v7u{kFI &; eXOH1'Os@Eydv\UOmkk5xLC;P䚭eM-ǥaq}ʑg HBI^I4ꗗ|)5Ԟ\o,pN^GV`?j?W-07!cp9G y:h7ŮYou Yb"LF`nwVF\_ e>Ǡϡ GFOݙl|ngC(~} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Recurrent Events} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Recurrent Events}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Overview} \label{sec:org01ebcd2} For recurrent events data it is often of interest to compute basis descriptive quantities as a first go at getting some basic understanding of the phenonmenon studied. We here demonstrate how one can compute \begin{itemize} \item the marginal mean \item the variance \item the probability of exceeding k events \end{itemize} In addition several tools can be used for simulating recurrent events and bivariate recurrent events data, in the case with a possible terminating event. We start by simulating some recurrent events data with two type of events with cumulative hazards \begin{itemize} \item \(\Lambda_1(t)\) \item \(\Lambda_2(t)\) \item \(\Lambda_D(t)\) \end{itemize} where we consider types 1 and 4 and with a rate of the terminal event given by \(\Lambda_D(t)\). We let the events be independent, but could also specify a random effects structure to generate dependence. When simulating data we can impose various random-effects structures to generate dependence \begin{itemize} \item We can draw normally distributed random effects \(Z_1,Z_2,Z_d\) were the variance (var.z) and correlation can be specified (cor.mat) (dependence=2). Then the intensities are \begin{itemize} \item \(\exp(Z_1) \lambda_1(t)\) \item \(\exp(Z_2) \lambda_2(t)\) \item \(\exp(Z_3) \lambda_D(t)\) \end{itemize} \item We can one gamma distributed random effects \(Z\). Then the intensities are (dependence=1) \begin{itemize} \item \(Z \lambda_1(t)\) \item \(Z \lambda_2(t)\) \item \(Z \lambda_D(t)\) \end{itemize} \item We can draw gamma distributed random effects \(Z_1,Z_2,Z_d\) were the sum-structure can be speicifed via a matrix cor.mat. Then we compute \(\tilde Z_j = \sum_k Z_k^{cor.mat(j,k)}\) for \(j=1,2,3\) (dependence=3) Then the intensities are \begin{itemize} \item \(\tilde Z_1 \lambda_1(t)\) \item \(\tilde Z_2 \lambda_2(t)\) \item \(\tilde Z_3 \lambda_D(t)\) \end{itemize} \item The intensities can be independent (dependence=0) \end{itemize} We return to how to run the different set-ups later and start by simulating independent processes. \subsection*{Utility functions} \label{sec:org9be05a8} We here mention two utility functions \begin{itemize} \item tie.breaker for breaking ties among jump-times which is expected in the functions below. \item count.history that counts the number of jumps previous for each subject that is \(N_1(t-)\) and \(N_2(t-)\). \end{itemize} \subsection*{Marginal Mean} \label{sec:orga8b27b9} We start by estimating the marginal mean \(E(N_1(t \wedge D))\) where \(D\) is the timing of the terminal event. This is based on a rate model for \begin{itemize} \item the type 1 events \item the terminal event \end{itemize} and is defined as \(\mu_1(t)=E(N_1^*(t))\) \begin{align} \int_0^t S(u) d R_1(u) \end{align} where \(S(t)=P(D \geq t)\) and \(dR_1(t) = E(dN_1^*(t) | D \geq t)\) and can therefore be estimated by a \begin{itemize} \item Kaplan-Meier estimator, \(\hat S(u)\) \item Nelson-Aalen estimator for \(R_1(t)\) \end{itemize} \begin{align} \hat R_1(t) & = \sum_i \int_0^t \frac{1}{Y_\bullet (s)} dN_{1i}(s) \end{align} where \(Y_{\bullet}(t)= \sum_i Y_i(t)\) such that the estimator is \begin{align} \hat \mu_1(t) & = \int_0^t \hat S(u) d\hat R_1(u). \end{align} Cook \& Lawless (1997), and developed further in Gosh \& Lin (2000). The variance can be estimated based on the asymptotic expansion of \(\hat \mu_1(t) - \mu_1(t)\) \begin{align*} & \sum_i \int_0^t \frac{S(s)}{\pi(s)} dM_{i1} - \mu_1(t) \int_0^t \frac{1}{\pi(s)} dM_i^d + \int_0^t \frac{\mu_1(s) }{\pi(s)} dM_i^d, \end{align*} with mean-zero processes \begin{itemize} \item \(M_i^d(t) = N_i^D(t)- \int_0^t Y_i(s) d \Lambda^D(s)\), \item \(M_{i1}(t) = N_{i1}(t) - \int_0^t Y_{i}(s) dR_1(s)\). \end{itemize} as in Gosh \& Lin (2000) \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) set.seed(1000) # to control output in simulatins for p-values below. data(base1cumhaz) data(base4cumhaz) data(drcumhaz) ddr <- drcumhaz base1 <- base1cumhaz base4 <- base4cumhaz rr <- simRecurrent(1000,base1,death.cumhaz=ddr) rr$x <- rnorm(nrow(rr)) rr$strata <- floor((rr$id-0.01)/500) dlist(rr,.~id| id %in% c(1,7,9)) \end{lstlisting} \begin{verbatim} id: 1 entry time status rr dtime fdeath death start stop x strata 1 0 133.1 0 1 133.1 1 1 0 133.1 1.185 0 ------------------------------------------------------------ id: 7 entry time status rr dtime fdeath death start stop x strata 7 0.0 813.3 1 1 1729 1 0 0.0 813.3 1.5495 0 1004 813.3 1288.4 1 1 1729 1 0 813.3 1288.4 1.0535 0 1658 1288.4 1315.4 1 1 1729 1 0 1288.4 1315.4 1.5330 0 2150 1315.4 1449.4 1 1 1729 1 0 1315.4 1449.4 0.8944 0 2539 1449.4 1726.1 1 1 1729 1 0 1449.4 1726.1 -0.1931 0 2851 1726.1 1729.4 0 1 1729 1 1 1726.1 1729.4 0.4081 0 ------------------------------------------------------------ id: 9 entry time status rr dtime fdeath death start stop x strata 9 0.0 433.5 1 1 5110 0 0 0.0 433.5 -0.4660 0 1006 433.5 2451.1 1 1 5110 0 0 433.5 2451.1 1.0647 0 1659 2451.1 3629.7 1 1 5110 0 0 2451.1 3629.7 -0.2506 0 2151 3629.7 3644.7 1 1 5110 0 0 3629.7 3644.7 -0.6748 0 2540 3644.7 3695.8 1 1 5110 0 0 3644.7 3695.8 0.6510 0 2852 3695.8 3890.7 1 1 5110 0 0 3695.8 3890.7 -0.2033 0 3112 3890.7 5110.0 0 1 5110 0 0 3890.7 5110.0 -1.6981 0 \end{verbatim} The status variable keeps track of the recurrent evnts and their type, and death the timing of death. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec1,caption= ,captionpos=b} \begin{lstlisting} # to fit non-parametric models with just a baseline xr <- phreg(Surv(entry,time,status)~cluster(id),data=rr) dr <- phreg(Surv(entry,time,death)~cluster(id),data=rr) par(mfrow=c(1,3)) bplot(dr,se=TRUE) title(main="death") bplot(xr,se=TRUE) # robust standard errors rxr <- robust.phreg(xr,fixbeta=1) bplot(rxr,se=TRUE,robust=TRUE,add=TRUE,col=4) # marginal mean of expected number of recurrent events out <- recurrentMarginal(xr,dr) bplot(out,se=TRUE,ylab="marginal mean",col=2) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{rec1.jpg} \end{center} \captionof{figure}{Marginal mean for number of type 1 events, rate for death (panel (a)), rate for type 1 among survivors (panel (b)), and marginal mean (panel (c)).} \label{fig:rec} \end{marginfigure} We can do the same with strata \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec2,caption= ,captionpos=b} \begin{lstlisting} xr <- phreg(Surv(entry,time,status)~strata(strata)+cluster(id),data=rr) dr <- phreg(Surv(entry,time,death)~strata(strata)+cluster(id),data=rr) par(mfrow=c(1,3)) bplot(dr,se=TRUE) title(main="death") bplot(xr,se=TRUE) rxr <- robust.phreg(xr,fixbeta=1) bplot(rxr,se=TRUE,robust=TRUE,add=TRUE,col=1:2) out <- recurrentMarginal(xr,dr) bplot(out,se=TRUE,ylab="marginal mean",col=1:2) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{rec2.jpg} \end{center} \captionof{figure}{Recurrent events} \label{fig:rec2} \end{marginfigure} Furhter, if we adjust for covariates for the two rates we can still do predictions of marginal mean, what can be plotted is the baseline marginal mean, that is for the covariates equal to 0 for both models. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec3,caption= ,captionpos=b} \begin{lstlisting} # cox case xr <- phreg(Surv(entry,time,status)~x+cluster(id),data=rr) dr <- phreg(Surv(entry,time,death)~x+cluster(id),data=rr) par(mfrow=c(1,3)) bplot(dr,se=TRUE) title(main="death") bplot(xr,se=TRUE) rxr <- robust.phreg(xr) bplot(rxr,se=TRUE,robust=TRUE,add=TRUE,col=1:2) out <- recurrentMarginal(xr,dr) bplot(out,se=TRUE,ylab="marginal mean",col=1:2) # predictions witout se's outX <- recmarg(xr,dr,Xr=1,Xd=1) bplot(outX,add=TRUE,col=3) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{rec3.jpg} \end{center} \captionof{figure}{Recurrent events with cox models for rates.} \label{fig:rec3} \end{marginfigure} \subsection*{Other marginal properties} \label{sec:org2fcaab7} \begin{itemize} \item \(P(N_1^*(t) \ge k)\) \begin{itemize} \item cumulative incidence of \(T_{k} = \inf \{ t: N_1^*(t)=k \}\) with competing \(D\). \end{itemize} \end{itemize} We note also that \(N_1^*(t)^2\) can be written as \begin{align*} \sum_{k=0}^K \int_0^t I(D > s) I(N_1^*(s-)=k) f(k) dN_1^*(s) \end{align*} with \(f(k)=(k+1)^2 - k^2\), such that its mean can be written as \begin{align*} \sum_{k=0}^K \int_0^t S(s) f(k) P(N_1^*(s-)= k | D \geq s) E( dN_1^*(s) | N_1^*(s-)=k, D> s) \end{align*} and estimated by \begin{align*} \hat \mu_{1,2}(t) & = \sum_{k=0}^K \int_0^t \hat S(s) f(k) \frac{Y_{1\bullet}^k(s)}{Y_\bullet (s)} \frac{1}{Y_{1\bullet}^k(s)} d N_{1\bullet}^k(s)= \sum_{i=1}^n \int_0^t \hat S(s) f(N_{i1}(s-)) \frac{1}{Y_\bullet (s)} d N_{i1}(s), \end{align*} Compared to "product-limit" estimator for \(E( (N_1^*(t))^2 )\) \begin{align} \hat \mu_{1,2}(t) & = \sum_{k=0}^K k^2 ( \hat F_{k}(t) - \hat F_{k+1}(t) ). \end{align} Probabilty of exceeding "k" Note also that \(I(N_1^*(t) \geq k)\) is \begin{align*} \int_0^t I(D > s) I(N_1^*(s-)=k-1) dN_1^*(s), \end{align*} suggesting that its mean can be computed as \begin{align*} \int_0^t S(s) P(N_1^*(s-)= k-1 | D \geq s) E( dN_1^*(s) | N_1^*(s-)=k-1, D> s) \end{align*} and estimated by \begin{align*} \tilde F_k(t) = \int_0^t \hat S(s) \frac{Y_{1\bullet}^{k-1}(s)}{Y_\bullet (s)} \frac{1}{Y_{1\bullet}^{k-1}(s)} d N_{1\bullet}^{k-1}(s). \end{align*} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec4,caption= ,captionpos=b} \begin{lstlisting} cor.mat <- corM <- rbind(c(1.0, 0.6, 0.9), c(0.6, 1.0, 0.5), c(0.9, 0.5, 1.0)) rr <- simRecurrent(1000,base1,cumhaz2=base4,death.cumhaz=ddr) rr <- count.history(rr) dtable(rr,~death+status) oo <- prob.exceedRecurrent(rr,1) bplot(oo) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{rec4.jpg} \end{center} \captionof{figure}{Recurrent events: probability of exceeding k events} \label{fig:rec4} \end{marginfigure} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec4,caption= ,captionpos=b} \begin{lstlisting} cor.mat <- corM <- rbind(c(1.0, 0.6, 0.9), c(0.6, 1.0, 0.5), c(0.9, 0.5, 1.0)) rr <- simRecurrent(1000,base1,cumhaz2=base4,death.cumhaz=ddr) rr <- count.history(rr) dtable(rr,~death+status) oo <- prob.exceedRecurrent(rr,1) bplot(oo) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{rec4MV.jpg} \end{center} \captionof{figure}{Recurrent events: probability of exceeding k events} \label{fig:rec4MV} \end{marginfigure} Mean and variance of number of recurrent events \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec4MV,caption= ,captionpos=b} \begin{lstlisting} par(mfrow=c(1,2)) with(oo,plot(time,mu,col=2,type="l")) # with(oo,plot(time,varN,type="l")) \end{lstlisting} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec4Bi,caption= ,captionpos=b} \begin{lstlisting} # Bivariate probability of exceeding oo <- prob.exceedBiRecurrent(rr,1,2,exceed1=c(1,5,10),exceed2=c(1,2,3)) with(oo, matplot(time,pe1e2,type="s")) nc <- ncol(oo$pe1e2) legend("topleft",legend=colnames(oo$pe1e2),lty=1:nc,col=1:nc) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{rec4Bi.jpg} \end{center} \captionof{figure}{Recurrent events: probability of exceeding k events} \label{fig:rec4Bi} \end{marginfigure} \subsection*{Dependence between events: Covariance} \label{sec:org0e76a6d} Covariance among two types of events \begin{align} \rho(t) & = \frac{ E(N_1^*(t) N_2^*(t) ) - \mu_1(t) \mu_2(t) }{ \mbox{sd}(N_1^*(t)) \mbox{sd}(N_2^*(t)) } \end{align} where \begin{itemize} \item \(E(N_1^*(t) N_2^*(t))\). \end{itemize} \begin{align*} E(N_1^*(t) N_2^*(t)) & = E( \int_0^t N_1^*(s-) dN_2^*(s) ) + E( \int_0^t N_2^*(s-) dN_1^*(s) ) \end{align*} Recall that \(N_1^*(t \wedge D)\) and \(N_2^*(t \wedge D)\). \begin{align*} E(\int_0^t N_1^*(s-) dN_2^*(s) ) & = \sum_k E( \int_0^t k I(N_1^*(s-)=k) I(D \geq s) dN_2^*(s) ) \end{align*} \begin{align*} = \sum_k \int_0^t S(s) k P(N_1^*(s-)= k | D \geq s) E( dN_2^*(s) | N_1^*(s-)=k, D \geq s) \end{align*} estimated by \begin{align*} & \sum_k \int_0^t \hat S(s) k \frac{Y_1^k(s)}{Y_\bullet (s)} \frac{1}{Y_1^k(s)} d \tilde N_{2,k}(s), \end{align*} \begin{itemize} \item \(Y_j^k(t) = \sum Y_i(t) I( N_{ji}^*(s-)=k)\) for \(j=1,2\), \item \(\tilde N_{j,k}(t) = \sum_i \int_0^t I(N_{ij^o}(s-)=k) dN_{ij}(s)\) \end{itemize} Estimate of \$ E(N\(_{\text{1}}^{\text{*}}\)(t) N\(_{\text{2}}^{\text{*}}\)(t))\$ \begin{align*} \sum_k \int_0^t \hat S(s) k \frac{Y_1^k(s)}{Y_\bullet (s)} \frac{1}{Y_1^k(s)} d \tilde N_{2,k}(s) + \sum_k \int_0^t \hat S(s) k \frac{Y_2^k(s)}{Y_\bullet (s)} \frac{1}{Y_2^k(s)} d \tilde N_{1,k}(s). \end{align*} \begin{itemize} \item Without terminating event covariance is useful nonpar measure \item With terminating event dependence generated by terminating event. \item In reality what is of interest would be independence among survivors \begin{itemize} \item if \(N_1\) not predicitive for \(N_2\) \end{itemize} \begin{align} E( dN_2^*(t) | N_1^*(t-)=k, D \geq t) = E( dN_2^*(t) | D \geq t) \end{align} \begin{itemize} \item if \(N_2\) not predicitive for \(N_1\) \end{itemize} \begin{align} E( dN_1^*(t) | N_2^*(t-)=k, D \geq t) = E( dN_1^*(t) | D \geq t) \end{align} \end{itemize} If the two processes are independent among survivors then \begin{align} E( dN_2^*(t) | N_1^*(t-)=k, D \geq t) = E( dN_2^*(t) | D \geq t) \end{align} so \begin{align*} E( \int_0^t N_1^*(s-) dN_2^*(s) ) & = \int_0^t S(s) E(N_1^*(s-) | D \geq s) E( dN_2^*(s) | D \geq s) \end{align*} and \begin{align*} \int_0^t \hat S(s) \{ \sum_k k \frac{Y_1^k(s)}{Y_\bullet (s)} \} \frac{1}{Y_\bullet (s)} dN_{2\bullet}(s), \end{align*} where \(N_{j\bullet}(t) = \sum_i \int_0^t dN_{j,i}(s)\). Under the independence \(E(N_1^*(t) N_2^*(t))\) is estimated \begin{align*} \int_0^t \hat S(s) \{ \sum_k k \frac{Y_1^k(s)}{Y_\bullet (s)} \} \frac{1}{Y_\bullet (s)} dN_{2\bullet}(s) + \int_0^t \hat S(s) \{ \sum_k k \frac{Y_2^k(s)}{Y_\bullet (s)} \} \frac{1}{Y_\bullet (s)} dN_{1\bullet}(s). \end{align*} Both estimators, \(\hat E(N_1^*(t) N_2^*(t))\) and \(\hat E_I(N_1^*(t) N_2^*(t))\), as well as \(\hat E(N_1^*(t))\) and \(\hat E(N_2^*(t))\), have asymptotic expansions that can be written as a sum of iid processes, similarly to the arguments of Ghosh \& Lin 2000, \(\sum_i \Psi_i(t)\). We can thus estimate the standard errors and of the estimators and their difference \(\hat E(N_1^*(t) N_2^*(t))- \hat E_I(N_1^*(t) N_2^*(t))\). Terms for \begin{itemize} \item N1 -> N2 : \(E( \int_0^t N_1^*(s-) dN_2^*(s) )\) \item N2 -> N1 : \(E( \int_0^t N_2^*(s-) dN_1^*(s) )\) \end{itemize} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec5,caption= ,captionpos=b} \begin{lstlisting} rr$strata <- 1 dtable(rr,~death+status) covrp <- covarianceRecurrent(rr,1,2,status="status",death="death", start="entry",stop="time",id="id",names.count="Count") par(mfrow=c(1,3)) plot(covrp) # with strata, each strata in matrix column, provides basis for fast Bootstrap covrpS <- covarianceRecurrentS(rr,1,2,status="status",death="death", start="entry",stop="time",strata="strata",id="id",names.count="Count") \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{rec5.jpg} \end{center} \captionof{figure}{Covariance between events} \label{fig:rec5} \end{marginfigure} \subsection*{Bootstrap standard errors for terms} \label{sec:orgc567a4f} First fitting the model again to get our estimates of interst, and then computing them for some specific time-points \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} times <- seq(500,5000,500) coo1 <- covarianceRecurrent(rr,1,2,status="status",start="entry",stop="time") # mug <- Cpred(cbind(coo1$time,coo1$EN1N2),times)[,2] mui <- Cpred(cbind(coo1$time,coo1$EIN1N2),times)[,2] mu2.1 <- Cpred(cbind(coo1$time,coo1$mu2.1),times)[,2] mu2.i <- Cpred(cbind(coo1$time,coo1$mu2.i),times)[,2] mu1.2 <- Cpred(cbind(coo1$time,coo1$mu1.2),times)[,2] mu1.i <- Cpred(cbind(coo1$time,coo1$mu1.i),times)[,2] cbind(mu2.1,mu2.i) cbind(mu1.2,mu1.i) \end{lstlisting} \begin{verbatim} mu2.1 mu2.i [1,] 0.04101096 0.03656491 [2,] 0.09303668 0.08572694 [3,] 0.22613687 0.21906324 [4,] 0.35727148 0.34562539 [5,] 0.60258982 0.59071900 [6,] 0.80089841 0.79020220 [7,] 1.03031183 1.03424672 [8,] 1.16860632 1.16686717 [9,] 1.25782175 1.25105963 [10,] 1.38716306 1.40250244 mu1.2 mu1.i [1,] 0.03501045 0.03259566 [2,] 0.08803686 0.08526834 [3,] 0.16709531 0.16634828 [4,] 0.27720710 0.29485672 [5,] 0.38034407 0.41985665 [6,] 0.53057410 0.56459585 [7,] 0.69387628 0.72234676 [8,] 0.87226707 0.88771625 [9,] 0.96949736 0.99728527 [10,] 1.06074066 1.06854228 \end{verbatim} To get the bootstrap standard errors there is a quick memory demanding function (with S for speed and strata) BootcovariancerecurrenceS and slow function that goes through the loops in R Bootcovariancerecurrence. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} bt1 <- BootcovariancerecurrenceS(rr,1,2,status="status",start="entry",stop="time",K=100,times=times) #bt1 <- BootcovariancerecurrenceS(rr,1,2,status="status",start="entry",stop="time",K=K,times=times) output <- list(bt1=bt1,mug=mug,mui=mui, bse.mug=bt1$se.mug,bse.mui=bt1$se.mui, dmugi=mug-mui, bse.dmugi=apply(bt1$EN1N2-bt1$EIN1N2,1,sd), mu2.1 = mu2.1 , mu2.i = mu2.i , dmu2.i=mu2.1-mu2.i, mu1.2 = mu1.2 , mu1.i = mu1.i , dmu1.i=mu1.2-mu1.i, bse.mu2.1=apply(bt1$mu2.i,1,sd), bse.mu2.1=apply(bt1$mu2.1,1,sd), bse.dmu2.i=apply(bt1$mu2.1-bt1$mu2.i,1,sd), bse.mu1.2=apply(bt1$mu1.2,1,sd), bse.mu1.i=apply(bt1$mu1.i,1,sd), bse.dmu1.i=apply(bt1$mu1.2-bt1$mu1.i,1,sd) ) \end{lstlisting} We then look at the test for overall dependence in the different time-points. We here have no suggestion of dependence. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tt <- output$dmugi/output$bse.dmugi cbind(times,2*(1-pnorm(abs(tt)))) \end{lstlisting} \begin{verbatim} times [1,] 500 0.3572253 [2,] 1000 0.4577012 [3,] 1500 0.7136132 [4,] 2000 0.7956959 [5,] 2500 0.3837459 [6,] 3000 0.5134406 [7,] 3500 0.4209237 [8,] 4000 0.7632914 [9,] 4500 0.6836682 [10,] 5000 0.6598813 \end{verbatim} We can also take out the specific components for whether \(N_1\) is predictive for \(N_2\) and vice versa. We here have no suggestion of dependence. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} t21 <- output$dmu1.i/output$bse.dmu1.i t12 <- output$dmu2.i/output$bse.dmu2.i cbind(times,2*(1-pnorm(abs(t21))),2*(1-pnorm(abs(t12)))) \end{lstlisting} \begin{verbatim} times [1,] 500 0.71706002 0.3918872 [2,] 1000 0.81454942 0.3202626 [3,] 1500 0.95715638 0.6006314 [4,] 2000 0.21300406 0.4942293 [5,] 2500 0.02182129 0.6086128 [6,] 3000 0.11688970 0.6805457 [7,] 3500 0.25587816 0.8965495 [8,] 4000 0.63373150 0.9578608 [9,] 4500 0.41743073 0.8548733 [10,] 5000 0.83041113 0.6805618 \end{verbatim} We finally plot the boostrap samples \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec6,caption= ,captionpos=b} \begin{lstlisting} par(mfrow=c(1,2)) matplot(bt1$time,bt1$EN1N2,type="l",lwd=0.3) matplot(bt1$time,bt1$EIN1N2,type="l",lwd=0.3) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{rec6.jpg} \end{center} \captionof{figure}{Bootstrap samples} \label{fig:rec6} \end{marginfigure} \subsection*{Looking at other simulations with dependence} \label{sec:orga99167a} Using the normally distributed random effects we plot 4 different settings. We have variance \(0.5\) for all random effects and change the correlation. We let the correlation between the random effect associated with \(N_1\) and \(N_2\) be denoted \(\rho_{12}\) and the correlation between the random effects associated between \(N_j\) and \(D\) the terminal event be denoted as \(\rho_{j3}\), and organize all correlation in a vector \(\rho=(\rho_{12},\rho_{13},\rho_{23})\). \begin{itemize} \item Scenario I \(\rho=(0,0.0,0.0)\) Independence among all efects. \item Scenario II \(\rho=(0,0.5,0.5)\) Independence among survivors but dependence on terminal event \item Scenario III \(\rho=(0.5,0.5,0.5)\) Positive dependence among survivors and dependence on terminal event \item Scenario IV \(\rho=(-0.4,0.5,0.5)\) Negative dependence among survivors and positive dependence on terminal event \end{itemize} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec7,caption= ,captionpos=b} \begin{lstlisting} par(mfrow=c(2,2)) data(base1cumhaz) data(base4cumhaz) data(drcumhaz) dr <- drcumhaz base1 <- base1cumhaz base4 <- base4cumhaz var.z <- c(0.5,0.5,0.5) # death related to both causes in same way cor.mat <- corM <- rbind(c(1.0, 0.0, 0.0), c(0.0, 1.0, 0.0), c(0.0, 0.0, 1.0)) rr <- simRecurrentII(3000,base1,base4,death.cumhaz=dr,var.z=var.z,cor.mat=cor.mat,dependence=2) rr <- count.history(rr,types=1:2) cor(attr(rr,"z")) coo <- covarianceRecurrent(rr,1,2,status="status",start="entry",stop="time") par(mfrow=c(2,2)) with(coo, { plot(time, EN1N2, type = "l", lwd = 2,lty=1,ylab="",xlab="time (a)") lines(time, EN1EN2, col = 2, lwd = 2,lty=2) lines(time, EIN1N2, col = 3, lwd = 2,lty=3) }) legend("topleft", c("E(N1N2)", "E(N1) E(N2) ", "E_I(N1 N2)-independence"),lty = 1:3, col = 1:3) title(main ="Scenario I") var.z <- c(0.5,0.5,0.5) # death related to both causes in same way cor.mat <- corM <- rbind(c(1.0, 0.0, 0.5), c(0.0, 1.0, 0.5), c(0.5, 0.5, 1.0)) rr <- simRecurrentII(3000,base1,base4,death.cumhaz=dr, var.z=var.z,cor.mat=cor.mat,dependence=2) rr <- count.history(rr,types=1:2) coo <- covarianceRecurrent(rr,1,2,status="status",start="entry",stop="time") with(coo, { plot(time, EN1N2, type = "l", lwd = 2,lty=1,ylab="",xlab="time (b)") lines(time, EN1EN2, col = 2, lwd = 2,lty=2) lines(time, EIN1N2, col = 3, lwd = 2,lty=3) }) legend("topleft", c("E(N1N2)", "E(N1) E(N2) ", "E_I(N1 N2)-independence"),lty = 1:3, col = 1:3) title(main ="Scenario II") var.z <- c(0.5,0.5,0.5) # positive dependence for N1 and N2 all related in same way cor.mat <- corM <- rbind(c(1.0, 0.5, 0.5), c(0.5, 1.0, 0.5), c(0.5, 0.5, 1.0)) rr <- simRecurrentII(3000,base1,base4,death.cumhaz=dr, var.z=var.z,cor.mat=cor.mat,dependence=2) rr <- count.history(rr,types=1:2) coo <- covarianceRecurrent(rr,1,2,status="status",start="entry",stop="time") with(coo, { plot(time, EN1N2, type = "l", lwd = 2,lty=1,ylab="",xlab="time (d)") lines(time, EN1EN2, col = 2, lwd = 2,lty=2) lines(time, EIN1N2, col = 3, lwd = 2,lty=3) }) legend("topleft", c("E(N1N2)", "E(N1) E(N2) ", "E_I(N1 N2)-independence"),lty = 1:3, col = 1:3) title(main ="Scenario III") var.z <- c(0.5,0.5,0.5) # negative dependence for N1 and N2 all related in same way cor.mat <- corM <- rbind(c(1.0, -0.4, 0.5), c(-0.4, 1.0, 0.5), c(0.5, 0.5, 1.0)) rr <- simRecurrentII(3000,base1,base4,death.cumhaz=dr, var.z=var.z,cor.mat=cor.mat,dependence=2) rr <- count.history(rr,types=1:2) coo <- covarianceRecurrent(rr,1,2,status="status",start="entry",stop="time") with(coo, { plot(time, EN1N2, type = "l", lwd = 2,lty=1,ylab="",xlab="time (d)") lines(time, EN1EN2, col = 2, lwd = 2,lty=2) lines(time, EIN1N2, col = 3, lwd = 2,lty=3) }) legend("topleft", c("E(N1N2)", "E(N1) E(N2) ", "E_I(N1 N2)-independence"),lty = 1:3, col = 1:3) title(main ="Scenario IV") \end{lstlisting} \begin{figure} \begin{center} \includegraphics[width=\textwidth]{rec7.jpg} \end{center} \captionof{figure}{Bootstrap samples} \label{fig:rec7} \end{figure} \end{document}mets/vignettes/marginal-cox.org0000644000176200001440000002227613623061405016335 0ustar liggesusers#+TITLE: Marginal modelling of clustered survival data #+AUTHOR: Klaus Holst & Thomas Scheike #+PROPERTY: header-args:R :session *R* :cache no :width 550 :height 450 #+PROPERTY: header-args :eval never-export :exports both :results output :tangle yes :comments yes #+PROPERTY: header-args:R+ :colnames yes :rownames no :hlines yes #+INCLUDE: header.org #+OPTIONS: toc:nil timestamp:nil #+BEGIN_SRC emacs-lisp :results silent :exports results :eval (setq org-latex-listings t) (setq org-latex-compiler-file-string "%%\\VignetteIndexEntry{Marginal Cox}\n%%\\VignetteEngine{R.rsp::tex}\n%%\\VignetteKeyword{R}\n%%\\VignetteKeyword{package}\n%%\\VignetteKeyword{vignette}\n%%\\VignetteKeyword{LaTeX}\n") #+END_SRC ----- # +LaTeX: \clearpage * Overview A basic component for our modelling of multivariate survival data is that many models are build around marginals that on Cox form. The marginal Cox model can be fitted efficiently in the mets package. The basic models assumes that each subject has a marginal on Cox-form \[ \lambda_{g(k,i)}(t) \exp( X_{ki}^T \beta). \] where \( g(k,i) \) gives the strata for the subject. We here discuss and show how to get - robust standard errors of - the regression parameters - the baseline and how to do goodness of fit test using - cumulative residuals score test First we generate some data from the Clayton-Oakes model, with \( 5 \) members in each cluster and a variance parameter at \( 2 \) #+BEGIN_SRC R :exports code :ravel echo=FALSE library(mets) options(warn=-1) set.seed(1000) # to control output in simulatins for p-values below. n <- 1000 k <- 5 theta <- 2 data <- simClaytonOakes(n,k,theta,0.3,3) #+END_SRC #+RESULTS: #+begin_example Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.6.3 mets version 1.2.5 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined #+end_example #+BEGIN_SRC R :results output :exports both :session *R* :cache no head(data) #+END_SRC #+RESULTS: : time status x cluster mintime lefttime truncated : 1 0.1406317 1 0 1 0.1406317 0 0 : 2 0.4593768 1 0 1 0.1406317 0 0 : 3 1.0952678 1 0 1 0.1406317 0 0 : 4 0.2057554 1 1 1 0.1406317 0 0 : 5 0.6776620 1 0 1 0.1406317 0 0 : 6 1.6093755 1 0 2 0.1092390 0 0 The data is on has one subject per row. #+BEGIN_mnote + *=time=* :: time of event + *=status=* :: 1 for event and 0 for censoring + *=x=* :: x is a binary covariate + *=cluster=* :: cluster #+END_mnote Now we fit the model and produce robust standard errors for both regression parameters and baseline. First, recall that the baseline for strata $g$ is asymptotically equivalent to \begin{align} \hat A_g(t) - A_g(t) & = \sum_k \sum_i \int_0^t \frac{1}{S_{0,g}} dM_{ki}^g - P^g(t) \beta_k \end{align} with $P^g(t)$ a derivative wrt to $\beta$, and \begin{align} \hat \beta - \beta & = \sum_k ( \sum_i \int_0^\tau (Z_{ik} - E_{g}) dM_{ik}^g ) = \sum_k \beta_{k} \end{align} with \begin{align} M_{ki}^g(t) & = N_{ki}(t) - \int_0^t Y_{ki}(s) \exp( Z_{ki} \beta) d \Lambda_{g(k,i)}(t), \beta_{k} & = \sum_i \int_0^\tau (Z_{ik} - E_{g}) dM_{ik}^g \end{align} the basic 0-mean processes, that are martingales in the iid setting. The variance of the baseline of strata g is estimated by \begin{align} \sum_{k} ( \sum_i \int_0^t \frac{1}{S_{0,g(k,i)}} d\hat M_{ki}^g - P^g(t) \beta_k )^2 \end{align} that can be computed using the particular structure of \begin{align} d \hat M_{ik}^g(t) & = dN_{ik}(t) - \frac{1}{S_{0,g(i,k)}} \exp(Z_{ik} \beta) dN_{g.}(t) \end{align} This robust variance of the baseline and the iid decomposition for $\beta$ is computed in mets as: #+BEGIN_SRC R :results output :exports both :session *R* :cache no out <- phreg(Surv(time,status)~x+cluster(cluster),data=data) summary(out) # robust standard errors attached to output rob <- robust.phreg(out) #+END_SRC #+RESULTS: : : n events : 5000 4854 : : 1000 clusters : : Estimate S.E. dU^-1/2 P-value : x 0.287859 0.028177 0.028897 0 We can get the iid decomposition of the $\hat \beta - \beta$ by #+BEGIN_SRC R :results output :exports both :session *R* :cache no # making iid decomposition of regression parameters betaiid <- iid(out) head(betaiid) # robust standard errors crossprod(betaiid)^.5 # same as #+END_SRC #+RESULTS: : [,1] : 1 -3.461601e-04 : 2 -1.449189e-03 : 3 -3.898156e-05 : 4 4.215605e-04 : 5 3.425390e-04 : 6 -7.706668e-05 : [,1] : [1,] 0.02817714 We now look at the plot with robust standard errors #+BEGIN_marginfigure #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: robcox1 [[file:robcox1.jpg]] #+LATEX: \captionof{figure}{Baseline with robust standard errors.} label:fig:robcox1 #+END_marginfigure #+NAME: robcox1 #+BEGIN_SRC R :exports both :results output graphics :file robcox1.jpg :ravel fig=TRUE,include=FALSE bplot(rob,se=TRUE,robust=TRUE,col=3) #+END_SRC We can also make survival prediction with robust standard errors using the phreg. #+NAME: robcox2 #+BEGIN_SRC R :exports both :results output graphics :file robcox2.jpg :ravel fig=TRUE,include=FALSE pp <- predict(out,data[1:20,],se=TRUE,robust=TRUE) plot(pp,se=TRUE,whichx=1:10) #+END_SRC #+BEGIN_marginfigure # +CAPTION: Survival predictions with robust standard errors for Cox model label:fig:robcox2 #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: robcox2 [[file:robcox2.jpg]] #+LATEX: \captionof{figure}{Survival predictions with robust standard errors for Cox model} label:fig:robcox2 #+END_marginfigure Finally, just to check that we can recover the model we also estimate the dependence parameter #+BEGIN_SRC R :results output :exports both :session *R* :cache no tt <- twostageMLE(out,data=data) summary(tt) #+END_SRC #+RESULTS[<2018-09-10 14:18:33> cdb331054808b11985b02b84f953da8bfc6afbd9]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 0.5316753 0.03497789 15.20032 0 0.2100093 0.0109146 $type NULL attr(,"class") [1] "summary.mets.twostage" #+end_example ** Goodness of fit The observed score process is given by \begin{align} U(t,\hat \beta) & = \sum_k \sum_i \int_0^t (Z_{ki} - \hat E_g ) d \hat M_{ki}^g \end{align} where $g$ is strata $g(k,i)$. The observed score has the iid decomposition \begin{align} \hat U(t) = \sum_k \sum_i \int_0^t (Z_{ki} - E_g) dM_{ki}^g - \sum_k I(t) \beta_k \end{align} where $\beta_k$ is the iid decomposition of the score process for the true $\beta$ \begin{align} \beta_k & = \sum_i \int_0^\tau (Z_{ki} - E_g ) d M_{ki}^g \end{align} and $I(t)$ is the derivative of the total score, $\hat U(t,\beta))$, with respect to $\beta$ evaluated at time $t$. This observed score can be resampled given it is on iid form in terms of clusters. Now using the cumulative score process for checking proportional hazards #+BEGIN_SRC R :results output :exports both :session *R* :cache no gout <- gof(out) gout #+END_SRC #+RESULTS[<2018-09-10 14:32:08> 8bde76b6fea8c56142541f6eeb247699c5236c44]: : Cumulative score process test for Proportionality: : Sup|U(t)| pval : x 30.24353 0.401 The p-value reflects wheter the observed score process is consistent with the model. #+BEGIN_marginfigure #+ATTR_LATEX: :width \textwidth :float nil :center t #+RESULTS: robgofcox1 [[file:robgofcox1.jpg]] #+LATEX: \captionof{figure}{Goodness of fit for clustered Cox model.} label:fig:robcgofox1 #+END_marginfigure #+NAME: robgofcox1 #+BEGIN_SRC R :exports both :results output graphics :file robgofcox1.jpg :ravel fig=TRUE,include=FALSE plot(gout) #+END_SRC ** Cluster stratified Cox models For clustered data it is possible to estimate the regression coefficient within clusters by using Cox's partial likelihood stratified on clusters. Note, here that the data is generated with a different subject specific structure, so we will not recover the \( \beta \) at 0.3 and the model will not be a proportional Cox model, we we would also expect to reject "proportionality" with the gof-test. The model can be thought of as \[ \lambda_k(t) \exp( X_{ki}^T \beta) \] where \( \lambda_k(t) \) is some cluster specific baseline. The regression coefficient \( \beta \) can be estimated by using the partial likelihood for clusters. #+BEGIN_SRC R :results output :exports both :session *R* :cache no out <- phreg(Surv(time,status)~x+strata(cluster),data=data) summary(out) #+END_SRC #+RESULTS[<2018-09-11 09:16:22> ca332c824091210c9d8c97177e43d7db5326a8ae]: : : n events : 5000 4854 : : Estimate S.E. dU^-1/2 P-value : x 0.406307 0.032925 0.039226 0 The cumulative score processes can still be used to validate the model #+BEGIN_SRC R :results output :exports both :session *R* :cache no gg <- gof (out) summary(gg) #+END_SRC #+RESULTS[<2018-09-11 09:16:22> 6815b9399a490044f01367d6c2ebbab00700d2fb]: : Cumulative score process test for Proportionality: : Sup|U(t)| pval : x 27.55616 0.195 mets/vignettes/marg1.jpg0000644000176200001440000004221513623061405014747 0ustar liggesusersJFIFC    $.' ",#(7),01444'9=82<.342C  2!!22222222222222222222222222222222222222222222222222&" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ('}R\ej9bI'ڀ7hkk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^ֿ8G~A5ע?/q ƀ5謏kk4g___ z+#?Zh^6:©fP2I^?Z4@$9J\:Z+](ƭSU'kk4EsZ柤^ަI(V\N>DG=YA4( ( ( ( ( e݃A5X&6((((((((((((((((((((((($ĻuAe(U)u[H<; N]{9hf$ĻuAe+U#ا cT,ŘI'tV8ϧ5BmnC dYPYqHS(&κD-\Wa@љO@5~=p*O@5~=p*IEPEPEPEPEPX&+OYvQ@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@TrO MIcC &fvs>rW-b[e ~fɩ^Hi *iMX$DMkieǙ#:nbqLMF,nCʠZF1Wq\2Y7*Fo>rW-wlP4|E67`o5%ɣn7 FcG( 5q?*If,ĒNI=/CQYOp8496 :+3&lY?(ʸo֠yId3[=wLA7cxwE[J$*944ΗlqqY}$W)]oŽQH/"83zғv*1rvE#[1?WUYۧ`/@#;D?|ʧW>ҙYcGY Ү5)5"0^pR k+4 ZdЅzT63nȭהUȭהUQEQEQEQEy֥u /^XĮmזX +*eEv=M7 7v3 \xF;Fm"Ֆ?0Fb|2.EnxNOмBK$Kq$n; iZSj:8-a^Xj~ ֥x%Y;[5W1l[POEPEPEPEPEPEPEPEPEPEPEPEPEPE5cRTu$V|ݴcA8€4IKGTXr91T]F,YRNMo˭ZBo#>)b$X:ekM-^CCEʀ5%>d\~]*:=*Pz<@rn?Y,,ǢvԦM4V&#A՝5ީN?@aOMIC l-̣Zȁlր .MzFK?F`z<kۇZtPfvn<:ܻa?ϭJZ$4g8fx@@>¶~gs} Sд̋LY?= b߼5?SǠ3L0G٢ᑜ1cӭ"t9߱ϴ?Z۫[x P%Ev2GDWfk[DR rP'LTrַ`~䲷<@bGst÷1y2W-YHT9j3A#+6vF**ƢDqʨQ~'5/yE84%-gMvOWםin-|@#G^ZzXȥ%ȭהUȭהV%Q@Q@Q@Q@Q@s/~)vEth=?EQEQEQEQEQEQEQEQEQEQEC5g@QXV=ތ?*˚bYctj3YkHu?JԬ6gN]G,~h]1#. /ր5I[tqT,Zpc}zO۞oIJZ/KL>fKf{kX㑾˷y? 9ŎyqM<kW?.mlXԧ ˍv8 Yy~!C葠P?ZdT?jZC4UAOP-ŤZE*p|3j#l-?0z$?ַ ;u I#yZN;m7TPEPEPEPHH@5V}BO7柇l/G#hPQǕoo^k2i;;GMwHм2Y;)ҌvuGD6pIzusyvOk?J:}7o;Ϩ[[4|wG8Qo.~IiA*ZDz5HUO5-op~9I47'/u(99݃ E$%η>b|:߭Ê$[W)W/$[W)W/9I(((((+{O-cE?趠((((((((BBf 2IYZ1e`kiZBtV>diUy}katIGR}4q .HEUgwlIϵwYZHOS@*GǢ[k֒u9rC>S}?iL=&WyR BfP1!1d?1؊'p!v9\c?tr~zxoۤl}˿1叹5~+iǕ2EiT~Nr9tKJ3]CPd9p֥^+XqFH?SV( ( ( ( ( (fTR@N(i Hu&Mƣxs$vQT9o <1pocY?_ATԡYfS#;OG$Vrs/]*Q4;}v(}uamv,~GSbU-7ԞOSv:9a<0gPqœdIJCw`W({VQNDw8Ef>fKb-^M)wʣ5:pngb:i3'^ EnԨ S!Db[E!']kv**{Gs3ğ+j7j{EUCğ+j7j{EUFdQEQEQEQEQEh=?1l[POEPEPEPEPEPEPEo+\4%Q!;uOk.V8YSM/4Q ;UQI W]do? ϼIu2Q՜(jGt^Ewpr> B g[ZJnag;#=@SQCLVZiZYgTinXa&m{ j҂k e|tmZhD\bGtcYt؉ ~5oĄ4d8'PU0K@ DX*(U(((((()H.`ހu6I%{|UMg#۝z5OYhh˪H3g46drTNv 2YK]qaLv8>m,:Z|Ā 'u&G;l!7'zglC Mқ#D:or>EKsYH{U8Q`*TC$͈бUz-, WjU+I?:ypV2lGm ')u-h+Q/(j;+xF 2Պ*R0Yv RE30(((3ğ+j7j{EUCğ+j7j{ET%Q@Q@Q@Q@*xTl/MK7@b@±Úօo}({ZLrlvMm BnfZBB}n nFmObuž/,VEm# gךܮcE?趭MA2.p+ōOgohB @}Q@Q@Q@Q@Q@V6 9 [ԢVE! ~KR 8Z`Y$w$ÓY/~el,OHQǰב@j{M>ݧm# 9I:]jS}Nva9h^$$V5$G#ڀ(4 ص:={_;kXmlK'jjj"ơQBQEQEQEQEQEQEQEʊY(Uʟ/Rv?_Ͼ+KJ/3!w`$Qt\XC/߇֕4# /T+ F:~''ޯTͽ?j3A0Nr}K ݩ# ዗{?*ñ\B_3!~QhS;V S)mT(-UQ@Q@Q@Q@Q@Q@$[W)W/$[W)W/ (((((+{O-cE?趠(((($ m$TdQ]]gyI(k;mr<@oG;!XosךE򕰱ѝ~d۝\m:=<hAe['zO,O*ieg}# {F׶ĹRx,f}\~mCUP+-.+P$z5~(((((((s,XvIfi7;;e\I9*HSHbޫ\Ch73@&8{>잩ͨ"`Cqp:ɻvkXx0_ήC V,PƱƽFg] _ySuj GL׻<{ y[j)cZ6fi?{UF|P3b4,jAS;񫊪T(-j= $'̃P3:y!˷0=Yiq?҅uU$ 'vMw!/z0rs%"2(cqΟEz(QEQEQEQEQEQEQEQEQEO@5~=p*O@5~=p*((O6v _MV`y\ 9ⲼH]N+beіT]ɕ% s[wjVI] fITc~_\,W[C&Vmu֑Ct01+ZNHipڔ`UqZ/eADҵacԴV)uJQEFAEPEPEPEPEPEPEPEPEPEPEPEPEPg?Vo?VoJ( ( ( (#@; cJHa!1$QHTPd=>+{O-cE?趠em Ă8vIRI5W=K8'=C8RqL>9h'&KF3Y7b:m8RZ{[cAG{Z2NC6R?S*ͮ=օiv㯊rz^p SjJ(N&waEP ((((((((((((((3ğ+j7j{EUCğ+j7j{ET%Q@Q@Q@Q@Q@s/~)vEth=?6./[5Z= oA@e!]T*v455 0PEPEPEPEPEPEJQHXړi9;"nvw?JʹrUrUmŏg{%č We8yۘ>aYJgG ]^Ej6$w>ķJS_B?8MkegI;{+R(NOҡEsUcI{W!KڀqԞ-c_ecޥDX"t1լ@*B(((((((((((((((( ȭהUȭהPQEQEQEQEQEh=?1l[POEPEPEPEPEPEPLT7V\ߤ$ap}eI+bQ)ޝ-^s}$#Oֳ.a̙®p8'>«|ZVO29?֝obsy0z(.MzPk˩ssq״ :a$Q U*M \68{ ض,z.e[VӂDzZТ$6sswaES$((((((((((((((((('ڿyMo?P'ڿyMo?IEPEPEPEP1?k;}7S *X*30.bpN+oKԡմ YJ]X+PAW!mEgu܍9[mo56+' Ԇ Mt{wvZ վS#1Dgfqqh}Șk^'Xު;l³ D կǸP"6p2X9'U_.P]ybGx=>Moc2fd{5~$mqos4׻8"XE5UQ+FNy>irޮ[~w#ҭVsϫoƢ,h : uV QEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEO@5~=p*O@5~=p*(((( #FkE v|8. eal) ,ŏI?[ 4_Sj{O-(($RjooEMTb-ToMfϨM/ m8RZE_Kyj;[FO=_Zs*oOVP 4 ?\iձkeѧo SZ*T(-I3)QE2(((((((((((((((((((( ȭהUȭהPQEQEQEQEQEh=?1l[POLh\Gn,_Ҕ˧)(Y58W! VSUnUBBII5;B $)̎=*eYXQg8o{OJ~"C=>-=|՞FyVqez_sQ{u*j]Z M1o2S~556ei\{aWKOaZ1@wH7\JZ]FOR wSV6@?vzE#ϝYOp*(((((((((((((((((((((( ȭהUȭהPQEQEQEQEQEh=?1l[POYJҬ]~;n&g1و6}utoIW1Q;Ecd 4>O ӌPr"/ucEDPT`R"4,z EO>נڽk<tMYXy@2u0yq"5c@QS9(((((((((((((((((((+*H@do.L 5'̠ Z+#_''C=nZb;@7$,񤀴Dr29O^Uwusx@ڥZ3knmPZ^ۋ;na$ 2 z $ ,m4j6pH׏$h :-ŪA>-#e@83s@]=N.1ri@c2?جG.>{̀dd4(E<9@ + ?4(^Sßҿ?OJ8€5謏E<9@ + _\vQmoZ+__ |cIy0RP pr2Ez5CDԴ :=ʹr1gI$I&EPEPEP֊M+Y b/Gn/` ;F%db8e;_jx^[}SEGnTZϙehp \q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@u-"W$Bb}IʺÂGj涶6m[#Gy"mrYX FH$s[tP!+x#8P0@v(((( alZGaxMDŽr91j/F尶13fWp !1!'i@Q@Q@Q@!ih I%gchֲ$V0 k*Hb +e!W!0opCjŸEQEQEQEi"Q7g쑳D'jP j(3KJ[F3+DWڴ袀 ( ( ((z=IyȤWHe]ej'ٴilf 䉶1)d`X1 m@ cXB" US袀 ( ( (2mJ+R.K;ﲡ;U99N=Ҽ&u$"$":((((((((((((((((((((((/\ux4륟w k>/QdZ5ۻ Kc1bc 0;g5w:k+d #y- ]FGo@Ey$+<"OiZqլwD̀Al`S=wsx[M.rgoiwyv,k\Y(((((((((((((((((((((((((((((((((((((((((((((((((((mets/vignettes/competing.ltx0000644000176200001440000006502313623061405015756 0ustar liggesusers%\VignetteIndexEntry{Analysis of multivariate competing riks data} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Analysis of multivariate competing risks data} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Analysis of multivariate competing risks data}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Overview} \label{sec:orgbe56752} \begin{itemize} \item marginal modelling with standard errors cif, \item cause specific hazards \item cumulative incidence modelling \begin{itemize} \item random effects simple cif \item Luise model \end{itemize} \end{itemize} When looking at multivariate survival data with the aim of learning about the dependence that is present, possibly after correcting for some covariates different approaches are available in the mets package \begin{itemize} \item Binary models and adjust for censoring with inverse probabilty of censoring weighting \item Bivariate surival models of Clayton-Oakes type \begin{itemize} \item With regression structure on dependence parameter \item With additive gamma distributed random effects \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \item Plackett OR model model \begin{itemize} \item With regression structure on OR dependence parameter \end{itemize} \item Cluster stratified Cox \end{itemize} Typically it can be hard or impossible to specify random effects models with special structure among the parameters of the random effects. This is possible for our specification of the random effects models. To be concrete about the model structure assume that we have paired binomial data \(T_1, \delta_1, T_2, \delta_2, X_1, X_2\) where the censored survival responses are \(T_1, \delta_1, T_2, \delta_2\) and we have covariates \(X_1, X_2\). The focus of this vignette is describe how to work on bivariate survival data using the addtive gamma-random effects models. We present two different ways of specifying different dependence structures. The basic models assumes that each subject has a marginal on Cox-form \[ \lambda_0(t) \exp( X_{ki}^T \beta) \] then two types of models can be considered. \begin{itemize} \item Univariate models with a single random effect for each cluster and with a regression design on the varince. \item Multivariate models with multiple random effects for each cluster. \end{itemize} The univariate models are then given a given cluster random effects \(Z_k\) with parameter \(\theta\) the joint survival function is given by the Clayton copula and on the form \[ \psi(\theta, \psi^{-1}(\theta,S_1(t,X_{k1}) ) + \psi^{-1}(\theta, S_1(t,X_{k1}) ) \] where \(\psi\) is the Laplace transform of a gamma distributed random variable with mean 1 and variance \(\theta\). We then model the variance within clusters by a cluster specific regression design such that \[ \theta = z_j^T \alpha \] where \(z\) is the regression design (specified by theta.des in the software). This model can be fitted using a pairwise likelihood or the pseudo-likelihood using either \begin{itemize} \item twostage \item twostageMLE \end{itemize} For the Multivariate models we are given a multivarite random effect each subject \((Z_1,...,Z_d)\) with d random effects. The total random effect for each subject is then specified using a regression design on these random effects, with a regression vector \(v_j\) such that the total random effect is \{v\(_{\text{1}}^{\text{T}}\) (Z\(_{\text{1,\ldots{},Z}}\)\(_{\text{d}}\))\}. Each random effect has an associated parameter \((\lambda_1,...,\lambda_d)\) and \(Z_j\) is Gamma distributed with \begin{itemize} \item mean \(lambda_j/v_1^T \lambda\) \item variance $\backslash$( \(\lambda_{\text{j}}\)/(v\(_{\text{1}}^{\text{T}}\) \(\lambda\))\(^{\text{2}}\)\}. \end{itemize} The key assumption to make the two-stage fitting possible is that \[ lamtot=v_j^T \lambda \] with clusters. The DEFAULT parametrization (var.par=1) uses the variances of the random effecs \[ \theta_j = \lambda_j/(v_1^T \lambda)^2 \] For alternative parametrizations one can specify how the parameters relate to \(\lambda_j\) with the argument var.par=0. For both types of models the basic model assumptions are that given the random effects of the clusters the survival distributions within a cluster are independent and ' on the form \[ P(T > t| x,z) = exp( -Z \cdot Laplace^{-1}(lamtot^{-1},S(t|x)) ) \] with the inverse laplace of the gamma distribution with mean 1 and variance 1/lamtot. Finally the parameters \((\lambda_1,...,\lambda_d)\) are related to the parameters of the model by a regression construction \(M\) (d x k), that links the \(d\) \(\lambda\) parameters with the \(k\) underlying \(\alpha\) parameters \[ \lambda = M \alpha \] here using theta.des to specify these low-dimension association. Default is a diagonal matrix. This can be used to make structural assumptions about the variances of the random-effects as is needed for the ACE model for example. In software \(M\) is called theta.des We consider \(K\) independent clusters, with \(n_k\) subject within each cluster. For each cluster we are given a set of independent random effects \(V = (V_1,\dots , V_m)^T\). We let \((V_1,\dots,V_m)^T\) be independent Gamma distributed with \(V_l \sim \Gamma(\eta_l , \nu_l), l = 1,\dots,p\) independent gamma distributed random variables such that \(E(V_l) = \eta_l /\nu\) and \(Var(V_l ) = \eta_l /\nu^2\). \%\%Let \(\nu =(\nu_1,\dots,\nu_p)\). The \(\eta=(\eta_1,\dots,\eta_m)\) parameters are given such that \(\eta=D \theta\). Letting the rows in the matrix be denoted as \(Q_i,\dots,Q_m\). \%\%\%As is commonly done \cite{korsgaard1998additive,petersen1998additive} To facilitate our two-stage construction we also assume that \(\nu=Q_i^T \eta\) for all \(i=1,\dots,n_k\) such that \(Q_i^T V\) is also Gamma distributed with \(\Gamma(1, \nu)\), that is has variance \(\nu^{-1}\) and mean 1. We get back to specific models where this is the case, but this assumption is often reasonable and needed \cite{korsgaard1998additive,petersen1998additive} Let \(\Psi(\eta_l,\nu,\cdot)\) denote the Laplace transform of the Gamma distribution \(\Gamma(\eta_l,\nu)\), and let its inverse be \(\Psi^{-1}(\eta_l,\nu,\cdot)\). For simplicity we also assume that \(\eta\) is the same across clusters. Assume that the marginal survival distribution for subject \(i\) within cluster \(k\) is given by \(S_{X_{k,i}}(t)\) given covariates \(X_{k,i}\). Now given the random effects of the cluster \(V_k\) and the covariates\(X_{k,i}\) \(i=1,\dots,n_k\) we assume that subjects within the cluster are independent with survival distributions \begin{align*} \exp(- ( Q_{k,i} V_k) \Psi^{-1} (\nu,\nu,S_{X_{k,i}}(t)) ). \end{align*} A consequence of this is that the hazards given the covariates \(X_{k,i}\) and the random effects \(V_k\) are given by \begin{align} \lambda_{k,i}(t;X_{k,i},V_{k,i}) = ( Q_{k,i} V_k) D_3 \Psi^{-1} (\nu,\nu,S_{X_{k,i}}(t)) D_t S_{X_{k,i}}(t) \label{eq-cond-haz} \end{align} where \(D_t\) and \(D_3\) denotes the partial derivatives with respect to \(t\) and the third argument, respectively. Further, we can express the multivariate survival distribution as \begin{align} S(t_1,\dots,t_m) & = \exp( -\sum_{i=1}^m (Q_i V) \Psi^{-1}(\eta_l,\nu_l,S_{X_{k,i}}(t_i)) ) \nonumber \\ & = \prod_{l=1}^p \Psi(\eta_l,\eta , \sum_{i=1}^m Q_{k,i} \Psi^{-1}(\eta,\eta,S_{X_{k,i}}(t_i))). \label{eq-multivariate-surv} \end{align} In the case of considering just pairs, we write this function as \(C(S_{k,i}(t),S_{k,j}(t))\). In addition to survival times from this model, we assume that we independent right censoring present \(U_{k,i}\) such that the given \(V_k\) and the covariates\(X_{k,i}\) \(i=1,\dots,n_k\) \((U_{k,1},\dots,U_{k,n_k})\) of \((T_{k,1},\dots,T_{k,n_k})\), and the conditional censoring distribution do not depend on \(V_k\). We can also express this via counting processes \(N_{k,i}(t)=I(T_{k,i}t,U_{k,i}>t)\), and the censoring indicators \(\delta_{k,i}=I(T_{k,i}OMZ&Czj(!eۡ.[oPeѓMSUto >ܒO@xrk]SRY"Kc`&0L*1rz)(NTikZ4o3}1Zj:M~\䱅J[!}ؑOQE*F 0]*893J{g"97#Xk)EY:OxmHͥlm[ T~;b+w$Qjed+coUaWxkxKB!&򮭘堐uS:{ rԇ+:ϙoeY HK`:Alw}w-֖LZc8RSF[-oe@ MweіKE&[oP:QEQEQEQEQEQEQEQEQEQE8VO }3zչ`p 2򟕕AOBO\.RUu4,ZIMFC"ebq8 #EO"-T'eݳϠk fBaUd)p{<BE8$Om"X" r$ ~<k1ܟ#u>-1C@<7ߧo?ͿOym>f<@-5% Zn<7ߧo?ͿOym>?nB9ؿnOo~(7ߧ g\t/JB 13Tei,x rOO{cWSdȳVOsGS۠$ ɜP}+ ПY-AԄunldtWZI+#O)(=E-1 QR@ QR@ YtM5.2 .-QvFn MX[KI՘ikVi!#Â3Aokʭ'4}cVnc@:7r1B|Eզ6u׷ס 88RF< ݷ4CPXmoi-3ymoiP7ߧY֥?ߏ oh~O6?ƍy4(oiۯԔ}7ymoiP7ߧѼ6?ƟE 9Ɩ((((((((((/0&w;Km Cl>cl6b*b_ٴ{;kylݒx-$𮋖,~\y9uK&f$ylTv=D^dV;Z-ai]GQQELfԔ ;w*Z(7{ʍ򥢀wn_J} Z7{ʍ򥢀w*Z()g^//pDID^&kv~Ҥf0ƃ/+;6lrxWl0vORp"sQC[ԗUY?eS;P}B:0:ϟcKEu$9[m݉cF}-!Ɩh<\Vg[!%wMiWvk=`G['mm#ǒZH~'HBǩBa ?JQһ@8ǥysI$0 COu or7{/nsΕGD*Fzpn*lNĒFYNAX Tn?-LfӃڤ?ߏ ;w*Z(7{ʍ򥢀wn_Oj} _@cQTPn?KEEPEPEPEPEPEPEPEPEPEP'X<-mujҬ2m ux:Pp%\jg:<$`uX'TWԫ #3V+afHfrtPX/4e2Īv6O`N?#Ut/t;VYIS8$jQVآ@' /ɦ:>?ޏh4y|}1}Gɧ@ 4EuRR|<M>gɪa=h08P*̒G O,)fv8 ROa^[jC}qfǶ*1rvDJ*{۟:o +ch=fѻw&pN= ]qJm݆Q{TSFR@ ,8R=*7ʖMph=*]uo-&Q{TPn!*Adju|?J-.?#O?LYu @$^bT2`#h#KqAN2:3ǩ<[)MsxO)UV7^㨏Su 5 2Fn;=-+enR}1ٮI6Szl._QFQz?NBxNXKvZ^Vi/`8-cb橧sr7/ܾr܎ҟH:P}ER@ }ER@9EPEPEPEPEPEPEPEPEPEPEPkce%p$3ے)}^@$B)cnp2:ԗvIo.18 {%Y@cWy ;;s3pM'I,k*I'6AH S>o;KfqT??垰-&T +eik~W(o?j"O ֫Oz}S@w@ӿQυ_𧠵<_D7]?X2)nhXm1ōzV>iZvO_RK.-Ms9>OO A?Sk?+eik~W*G]'EƟ)4CcO;|-ZwZߕ =wWsψ4^?qJ%?ƽ\ZvG—+N _G}خCcO?!1JzV>;|-bO A?ShEƟ)5ZwZߕ ?+{g=y0}?Si!1JztXןbNӿQ`+%?ƏHt_ i^υ_+N _G}خCcO?!1JzV>;k~W(ϰ{q%?ƏHt_ i^4;k~W)+{g=y?$:/4 O׬eik~W(ӿQ`+%?ƐEO?)5?ZwZߕ itT׃RԴQES%Vi՚}Q@Q@ xQE6q;89'nຶxnP4,>`N?^Z o~# V|~h[A(z}B }o@&bX(d?#U  {dr(uo"RF8)E,Q DAQ } )iۍxϯ5.8<,O:cZע/oo2grf/tNy]qc AB<C#֗ShݨQER~}QEQEQETp[,i8Q>n4O7h}m. Wܥ퍽rxE0t= _KH:PeTu6_OQE?|} -x:}2??΀H?i?-Q@Q@Q@Q@Rm_ʀ'Gr*Oؿ-bt~TRl_ʍP>RGNؿ-bt~T՚v+ i%" ǰ WkV9R>Vv/G@ E&ؿf>CL2d)qWv?,~u>*/[pml鞸]gz:\,R~}z Ӭfk;;h.l଀F $qӭ[;8nR=*FhQSVӚJ10A;vYl*ʅ UZ4&_8'f8d㧭A7&mKH`e%rQVJU'Œ+/D]W7ڊ8y )6/GFhؿ mSgV?6vy=9[TͫNؿ-sڌ0Rh[4M!V,Īnǹ]3ZїWHōi3Y4H՚3I2܈f8aݸbc#v#4;K˴x%*I=@B2v/G@ Tl5kMIKg,c9z}[Ih (ؿWR᭣WDLjGp?:Efh}5B>P \ؿ-bt~TPP!CU6ۭkx V: sK(cQv"xBn*íEs\xyU}~l_ʚr(RPlK?*dS%bt~T>wt=GOӶ/GLWiG=JFF:)6/GFh(((dsΟL~#((jZA)jxls\c$dd fm5U17 pN1cTPP^CͤJv2 OLYll- 6ɵKn99$H# {U[NN1~aO{(ȞdlP+ :phx/>ҸÄp F{Z "C wy^#X4̶hæIFy*p0n|N.n8EQEC/}ݽ:8=:((('/_ Q-4QĪ?ِ~zkeBq Y.d^h36PAվҖuo4l@(CKH~Z)tdt>~#7O:Z( ( ( + kFi.RH9,,x#]JKhYA;^2yq`"(WB21 @]<|i-Dz9#(wPMln($tM9:w?٠L4~}G?٠Ե2~/?٠L4~}W63Bfkc*)09'sc&,mSt4o4vO̚KLf-Y>U}hjf7m\~zjW! ȭѶ'PT3G,IpԨuEgLEG f Bf4# 沮>9\xHڹT)&<>DX9~i3jx\@F c"5|Lڜvjʮ_vH|4N5A8  ֬E%c@[wNQGjڴӭt0^ach[[4Ds=)@sXZ"/c!A\u (޷ê[rHllg=Tzϊ㼖dXjodLҬj/ Hn$*NduO_@k̮onZ]BO0E+fq9#==kUFVդO:=k-yGڻ.3){.%#O5Z!dV&!@2!+8+eEtwC11=q5iS}wVj{:ZioR;G?٠66=2\9Z4~A@QL4~}G?٠H3qjZ~"In+`{6-,1*d}&o;(?~oj褯sv=F k=N"+@UO9UվҸ_=;(\ك}һe^Vv7N?MیC%U@?|} -GiydtZl{mΛUo3W (~h袊(((dsΟL~#((jZA"Im& ӭl[k+|ipǹG4kT͙n,0pU$`Oj¾H%KWhʄ9 =X*<%{#Bm\42e@IvP zuKyC)H5;t0o"vfd BHU.|i! &Gz/VwPcQC4lX(CKH~Z)tdt>~#7O:Z( ( ( ( (ܿ6OOeQޟ?:Z)7Fh޿}楦]Ν?:g7Fq(`6FsR_ιnfegM#0F:9y4^,̀1[B5QbN3͉t}OHm9#6[>ecӶhM2Gj w\-G;a1~{J#uۛH`GnF:WAzMZ"GH>%:|@/ПUĖcY,8KjsXnr q؞+CޛnHc92\oiIȗ$:vW92hs߼!x'?* ֲ!.of6@ETێTo1wc*:V;c_UZhkkXXnuB H˥T:6KAwTw3j>p1gguh9&FR2#xqW붺ݼ[ym`{ga=w.ݒ7 O-gV-4N柅.x.-i*[9 u1[ՙkY3XǼIaN9֮ym%I$q-p_5p*aQ}r{֞޿- *u5,ֱf\azuǥc^#㱻HiOtRo_΍I?:7@ EqEq?zk[_X!FN+sVvp_@aI]*ÐG Ўj|Q@#'Zm@$^R2?/ukugqżY%+PG#U8'Dk ILۏ? 7a*]bo$zi_-̉iWKbgߺS'DZ5؇B2qZksdS7.;zx~t-2??Ν?:dlO>@R7O:7Mf\}wI?:7@ EPEPEPEP$tdsΟ@Q@Q@>RԴUK2P1YuNJT[;;lj':s@ 4XI%=!Pju +;G>kd3Qʊ7/&RHMT(pNXgz 'aXd}:t 3$ ;Ou(e,#,|N*qo`3j6jA&H݁p<|c9^|^ 6NVY Y_AkZIe3C5_z?N/Gpo cM&V5bZ} NߩMFV^U61w`9Z^MƫK,E:v9md2\Ww'~%tK ھBNBnu } \ۙ2oP{ņ[Nn/Zf~bd$y^_#nr5*7?aIo~͕jl rJZiᇒXir}ݸ^*.YxE`ebW)c~ճsZj6ڈAB6Pw/osֹm7Mi<-Nr&8*Dq]-low'8]~^vË+zp>0F\ہukQ R G#W+ge5˂*:_k]Kwf-Rms8#z% ?- (h((~"In+"In+h'5o)SKH:ZFKHp($%цXdEG\#a-9Oɏ5-8v:z_{]A,@YTzο)" [ {t;;V!MSO S"!p잵*MltF{L4JWK>+gDu<tdj>~#7O:Z( ( ( ( ('G$t(*å[,I܁ڮ76aIP:ր i㺁'9:155.U@`;S"FwU8]WSBhV2;Ǝq+Lј 3ǯ{Tkƃ:hPoSv.5hT;^1XZ8'iQ݌cA<ⶼMu֖z4\18Oix:0;@eL_I$*?\~_-gI4Ǽ#TڪFWzqF1UzȰVFHr$!xQ&yycu%0d.XvQCzZH,""\p8$NQay%EtɷFf2sq4x.Vb@ݜ}|{U=&i׻ (Kg'wS9JpZe4Ұu(fB/P?>+[ėVVun0ҩ,0 ~9i+Z;tߒ>:N8imu4U~x Z42k fr{c~${g`.3T럨o7/b"e+bII|z IK{u}MvEy.D&6vBFr }1ShSVڜ1}لR O^㡮Vķ )aT`G\:w.`wZx$l \rNre~+Z_ 㶘-@S[6_5E-7kəbʱR1_sU<_wwgGIAd :O &𦥧$2H9S0ˎ9̚[1ŲE[ DG^2'_=oM`)Z1AN<ķ6w.~ґG 2m芧$}]O5K& `IwGeP?u?}]?"%]>ԮbY%"8\n:),|k^i5鄡"BTg'3l{B5+ChыLLW$dgoƺgHǃ!7EF ]/_EG7825We*! ^s߯SZx`Hih6*eK=N9kYO],BTȻI'>ZvMgũ"{H[v[ G~cqnZX0Ǣץt~7I):t^4pz{F$3'am&YnbyW#VExͥs@՞QS + ?'ӡ/*fr8=20q^Qv.ռE^ֶv Np'7P\^1q]I=kYUoUWT9CV##wm+XR51O-u)eܹ1zjYTS)Mw.nCCväkm`ZKy,0Q?*;_OռbpTES?6 qޟ5:j\DE$VOKyt"6nܜdd㨭)?z[/DAum}ԯsc!\7z%ʻ~a}{uWvC'Rc~K®ޜ9޸\YjviII+|B㐧w=j{ԟ]m5i:^Z옍0xW}5^]2:,WR퍗N12Fs WaxQY_H#H@!~;$U9=k?PԴ,V[)Lp~Zz,TMNIE1>DU,TE{ ZΠ<-%qr29x'j)BCq4N&&,N[=~}8񝁵{yW_!I ӷA+ۭUڗy~_[_|[}ඁF[u*O=힕6o%4" ]9YtXi\K.(0AzgYY47H"p1#_yJ%؎5r[. sGI5+{`y'r]911Zco,GYR/.YO6_g$k/$Sl9 ܎x dv=+]q:_M-m5Sc.5)=|W-u Тu#`89V|;H!VI+'l:~]*;{.C5l6;溼{-tƭMb+ƷӥbmD@ndg ܑMZYlͲy8@$ayګxNvI:uR#vm B랕2r_usyz4o0'8G8>E{ۓoqhYSw+ =OꟉԡmH8@pF;{סK+_L2cN'i=H:sԣg5~"N79D׼Cƺ1i֮q$R8Y 3QZMRk[}N3ٗHđ.7 @nT6GG< dv\URaXW|x/rCa]@>]&*~~Oh>iBrgxc,ʇAX+})^[HԖFrqn4`ccFR:#ޯ 4yknw0>OХ2-[Td3ZYlk^",U:Ӿ\]A' '*9VI"=X<͜0Üu9יàz%$G8|d#M8H=ߕdz F4ZDf ą-z j+u qHY |9#kcE`^ckMKVvov¨}^$kO2V+Њij4][Q-5bp2K瑜*s% 5j ۷8'tuTkTT>W($͓Z>.&Ry. 9-:gm?v /}ȕl&%+L~i۬S9axU{ r+xGX3k|~T_yAڤ|7k|~TmʟE3k|~TmʟE Z( `|7M:V.J_o%Jվ!0Rry)ԃLߥ#ҝHp(FJZ(9R{HsڝH?@JsWPZlNT|.yPr*!CI1Ӻ;kqxHѾLsnQ0G6J}Bo Y^KIMFK*<BתAƲ-/.4룬^Lsw^}Ǡhg&5LEwl`"v`۰Kh9r|g?p7=0CM;{pR9r>uhMzLV й,C]UZ1iKI"F[9ֲҜW}OЕ8- "~#Iq,{㔮7x9l{YlMBc-|gfq[[G}OVIEʄݴYcHTB<OI[५}ȥy`RrQs2`Fc=Y([O#Lݰr1iS ^-XIU +9ܞz⼗V[[ xE,܎auZ%-U֣K4XBr0{f{,nsNk~m=mY.5#v`\:0r?%.#-yqj\#9{4VV[%֬U1%<h)3`9<C'>tMIX8 8SPItň*EdrI3cs-[%BQO$ٴɽtAc;;k6^^dfv ;qVUƯm+[\7 xx>+-ZeXY㇝͓OsPʹ9>ޟZV;7[{+ZKH"d.{My|DҴ"KJ"@$n>w0Ijoy|5ygs$m+'% woMubm"n6d>qZik})j܌CXm&Tdg>s]n;Ko) yP#W'i\0ji7R 8< 3uZ/ MMlw윎8=qNq暧'eV_2,ӞF~ioڭm%$qw9< T~hw1ssr|vso7.5ޮ%Y.ѷrA9HGEY)MqVE[ 4PH$_y~?)$gզ5 / S9K nKԱ@ s=cMՎxg `cj8T6ڞ%~boNH+I+>.fY]-.Wry$ktI8EgN(Hv VD&NĖ( X1:}9mݔ:**w-И]e{iڂ\c*ٸIIfi?AU4"E}rs35l}X_ۥf nROA5%m{e=3i֕ESI4pƒTS@EQEE 7V%mE 7V%tNjRu5ҖPE-'qK@"M-"M-!KHzPy]tSOX F`=j/e/:yhs2F :{Oj_ i'(&I#YX'`v+55(()7ʖF;i}:}&7(=#\!Oخ!vpv‚poϩ<1H33(%Of_v:\IU>ǹ鎴؛GUMF#$t&5H>kJ*+7؉/#*HbJ:|dg-amKn IX(Q}KQ4Cgɇ\}I$HMN `y m^@8T2ؙFb.!/"N̙#¶~:G8I>n#k!,pc,@&z m" B!:d\ǵgk~ m&j"86} qѥ hZ&݀+I俯k>VHvgv8}7⻛{߳qmdR2q?6\Nkx"+7>gnkWSv VcO+o 壕Z??K[}q\WN9$}Һc.|9hb[ )!_'N@CPZxPb18c'nEpZմ׿aVU=gϩ>X.+VYV[{a9UI#(8u1'žO{}^sPD; p;=}a?+AYFw#&qzڵEtm`b9褃8Nʬ};t-E-NZYhK(X 9UQ~s:pջܘ–+,'j/zNswY@'y9P.n"HE'qR翹zmKb/c ҕb2=@8Cwa 1!76[3LNdҷg89};VM31yp m(L"8,pAzto;"G}nmkʅ$GEbGn:Z}[z#K "5@=OS:voƥAܨL*rq7֨)>xL !6F9ԶcW//me?IXVB>xqiHGڄUs/'SiPZzұ{~ftQtߙ r%}exULnַr$g8=e4np7pz>}np-h=#KEQE|E`OQӭbgV^-bWM @<- kS c򟧥:PF~-F~-&~";=ԋ4gPO*Z zX0elësIme-k4"Oz}5Bi̷>i=XtڵOV ((((}:}2OO }7Dk Rv@]GASNNޞæOpolu<9⋓]mpvq ,a'ǿz|{cmanGp<p^znOȏCDR'=GJۢ|y~ctmmB%oƭpҷ|?jvZG#߰Bq-UaѤU298P9#DDI:n; mHgj_t~}_G֊YƳ1yb0 NN=+S]5;w{&$V`UԌY4K${JQ"o j:k-ޛ[9ǀqܾw@u0tOâkR[jI20TrQۂ9'uWw#Oh𸸸YᇰI!HfԵCKzv?蚐>L*,LX=nzm:3S1I>jf?-I3eeGR[9>NUت5K? c!+##D[>nCtJRܱpC. \v61[D#V; 9?X(mG.DbB RG' i"PܪY0NNSN2=`aX0_MH(€-QEq?zk[zk]4~Mjd-#}o~QE'qKIUkm8|Co S9?^7`J媥엗OeK]a IʟL<j؟2i|?鬫4M6-,mDUF{XJƏu&ľ$P 6d{;S]v֐ExT$ 3?b{$EQEQEC5ݵE511hs֕mx.券Gqdv7S¶x̮a\6 /9K2pTiaupczp7t*Nsڷv"+NVy_h5[[)Uew$t9+V:(74<_8<<LT ,4cUmZ1|U2A9cfiV:-2< ˑc'\7~ݓyuu'ږ,m%[9?ӥ]B+c/(` 㜎Ox55M~ kOpd' ÎHjggFd6%CH:ךi_t9/uusk6ϒ5 5 #c'wK؟V{{ C|wocXyao*Iy3?:<ߗwVAsOb\mb|pNr364[ſwSxJji,k>PTghv+м5*kz[:1, Vqc[}+8YyGF  ?3Ėæj}2he#! dAܣs.R^3I~Bi-17zϙ$02;uF'=K~+ksh+ΌpApG8j8^+ݧ]Js6VT#n189WwmOhb"1!JByJWw+t?gcM:P[H" p`pGQXi+K(좴hcfKJv\I8=>XxHYgqf褡\`=Qo[լ/t[9\ HKc)#t$Rz%Ôooge`nOq< .5yvuh# {IplxϯA+z >Ӣ׷ZDJdH@lnb,.#)-!;DLF95ݾe(}n"PmJ;srF =8 V[ͦ[ٕxP@Ď\۞= (_[kϘr*08&-Z n"W u ךQwmmjw *+8 znpF+ QV%8UQ b3v=OMu8}.g -xUfJV}Mk%DcVVÅ$cOWE?;toҳ4t)xnK#,;p[w@01}-q?zk[?37SNM H:6@:kS!ԍҍ栻IgHbQ< 嵌{!ls=OI0uo~B XGk|i xkD UR4^+[U?G|kм/y]"gbk|[;Z>aCޗgmtlm:li򟙾RQ-#tGm:FN>uJ)?o΍@((((}:}2OO) x2ukBKKQysTo%O-e ciZ֧<3@k.R0:_!4x 5V{$=V9%2pA遟WEc[Yr+ǻ vǹv {t1EQcP_sy) F0X$zz:T{k=#AyM'@`zen>?pg N[%tfVw9Li5[]jF .I՗$yA##jk.w_?;/'DcE'dtjWdžD;W*J8`WkӵmG%vh.R' ;~[+XwU*0n qߚi&[kF2 ,z[Z+c9A39#(_?q|)&G 0Vr?{QYxÚr/-!)۞+GN..=U<$uwm !|q,ŽqpnnOȤEc6 MwmYY0^2ʱ9P72Zؽg7ȵ_--KXfisG {b MV׬#hYc=EO’?|2}NYb7 qZt[˻-)R;¢ҞGI>K'ygҮi\AԂIp͒s{m;&j0Dezx9O5EAR~2-rEFSmf,үʸ''O^Us<[|#8@QGj((|- (;YgӠK ǵ^F93:(TԔPEPEP(KqX(KqXG9|AHHPĐP^^cyw3;8Գ碪I>xmL zR6c_C1?U99 xh6$j[uwՅuW5뾩 %n.@qԚ4TE 0AD\D`(CKH~Z)tdt>~#7O:Z( ( ( ( (ϱ?zOɠ&֢WO0Y`=+Kw& h-ݴuA$dc#4nd.CnyLWUzߊ:'s}jrF6y` [L|=} oCA!:Վi!wed+B/JZLP$f:cyfΥe<Ü6{:WfZ5bH=/+F)|yXv ydd##Ӛֲ>{6x%1uʏď2! j16 w.3XM:\Fv쓞#kojaZ0^h73P9$KeiX/-~ig||r;kj8 cA& QiL4g @$sӯj `0Pz3^{foȺMۗL/3~g?08ڠb{p- T'v3ۊ遼EH>7 I*eRrƢOO=oY_LΙY18iMQ60ߎs^ X\sWR;Ku jr]y~A3w<;+^w&lDP4I$POSI!pzS`d@2˳Yɠw&?AKLANɠw&56MR((?Q@?1Ĉw1UqDO$E7w&w&M7hi?AFM7wx=>M7hhɣw&"~"In+ I(I* ,O>" B_[RE O(|hVI UBSJC$''4̝=;'GOӲJdd?)ր$ntdt't)2J2JZ( ( ( ('G$ti3 iQ@Q@Ƶqe%HSvl0a@K@_;MB[+KR`,wlOj{ug~a$| , UIq-`ذ`Wv1s&c8cXEDQU{ ;6- F v9oŀ0ףdiU`?€5 `5{yCAold}!#KtִaH$ Ѹ:*_ڔh !*A2WRQ@ (牢 2TP[ [D`2Nv:a'QZnY(gn$tPEP%TJY|lFj#shc71%~O@;.BIiPb$yOn5EQE )i?AK@Q@6_OSeTwj(EQE|-Q@Q@Q@O^-U5C[qmAvi~!ԟ/hwyHZ\?<3akOI̐kmty@V< ~]@hWjyoz!xrH4>?>'GEPEPԴ5-QE՚}2_fEcFnedݴ(8<w(<3-# +2Ny~3'p9JH>(hrPH'ȮC G=;UX͑+>1ɠ hɵ఻I$w0 wZ7ҟ@Q@Q@> ZAREPMSi?ڊ;Q@Q@ )i?A@ EPEPEP[σVȟVз) DBoXI! AվҖuo4l@(CKH~Z)tdt>~#7O:Z( ( (2uK;ۻ.;y,TylFp*:#',wWBY* Go0:4PVKdV#)X-i98L [4()#:QG֝V}:}3}<ѧ@ ǫF,ziPb1F}pK@ ǫF,ziP<Ѧ[5-2_f2BPIR\e7s=:ZoFI85%,zhǫFE3}AyoԔ€VXoycտG=[4()#69n4,zhS}),zhǫFE3}<ѧ@cy4XoӇ?AK@ ǫF,ziP<Ѧ9t?jZl@ VXoQ@ ǫF,ziP<ѤtjJAP|ѣ}},zhǫFE 4Q@NJ+ZolVVmό" tRz?((((?.|&M1B g'h`xrKbo%H+‚ӌHIO׬*D کb a&>Sx=9((z( ( FPk鳬4Daesn码CW^4D8x%FJ'uWX{bf\)+!>\-،Hƀ ( 1h ( (m]CpǎRzZ+]#T>M'`H.v1'[=@+itrCDZ@YF7=(((9((aJbp3m(3"Ub,^](J@>ڀ ( 1h ( ( NIk#V*r<<=EK J=Q*Z%`Cĸ$qO֥c) bNl1lP`q{Ң(9($jPH;#'9 ֹZ*U++uVzU6Y 1$i wg<f((((((((((((((((oz֙yDny 1Xj9} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Analysis of multivariate survival data based on Case Control Data} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Analysis of multivariate survival data based on Case Control Data}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Overview} \label{sec:org37fdee6} When looking at multivariate survival data with the aim of learning about the dependence that is present, possibly after correcting for some covariates different approaches are available in the mets package \begin{itemize} \item Binary models and adjust for censoring with inverse probabilty of censoring weighting \begin{itemize} \item biprobit model \end{itemize} \item Bivariate surival models of Clayton-Oakes type \begin{itemize} \item With regression structure on dependence parameter \item With additive gamma distributed random effects \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \item Plackett OR model model \begin{itemize} \item With regression structure on OR dependence parameter \end{itemize} \item Cluster stratified Cox \end{itemize} We have discussed how to fit such models in the vignette about twostage survival modelling. Here we show what can be done if one has data available from case-control sampling. First we set up some case-control data \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) set.seed(100) ncases <- 2000 ncontrols <- ncases*5 data <- simClaytonOakes.twin.ace(100000,1,2,0,3,Cvar=1) theta <- c(1,2) cens.prob <- mean(data$status==0) # data2 <- fast.reshape(data,id="cluster") with(data2,table(status1,status2)) controls <- which(data2$status2==0) cases <- which(data2$status2==1) cases <- sample(cases,min(ncases,length(cases))) controls <- sample(controls,min(ncontrols,length(controls))) nccc <- c(length(cases),length(controls)) clustco <- data2$cluster[controls] clustca <- data2$cluster[cases] # med <- data$cluster %in% c(clustco,clustca) datacc <- data[med,] datacc2 <- fast.reshape(datacc,id="cluster") dd <- with(datacc2,table(status1,status2)) # # out <- twin.polygen.design(data,id="cluster") pardes <- out$pardes des.rv <- out$des.rv aa <- phreg(Surv(time,status)~+cluster(cluster),data=data) out <- twin.polygen.design(datacc,id="cluster") pardes <- out$pardes des.rv <- out$des.rv # # # needs to use pair structure to profile out # baseline mm <- familycluster.index(datacc$cluster) pairs <- matrix(mm$familypairindex,ncol=2,byrow=TRUE) # kinship <- rep(1,nrow(pairs)) kinship[datacc$zyg[pairs[,1]]=="DZ"] <- 0.5 table(kinship) # dout <- make.pairwise.design(pairs,kinship,type="ace") des.rv <- dout$random.design pardes <- dout$theta.des # cr.models <- list(Surv(time,status)~+1) tscce <- survival.twostage(NULL,data=datacc, clusters=datacc$cluster, theta=theta,var.link=0,step=1.0, random.design=des.rv,theta.des=pardes, pairs.rvs=dout$ant.rvs,var.par=1, pairs=pairs, case.control=1,marginal.status=datacc$status, cr.models=cr.models) summary(tscce) \end{lstlisting} \begin{verbatim} Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.6.3 mets version 1.2.4 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined status2 status1 0 1 0 16121 15661 1 15828 52390 kinship 0.5 1 5963 6037 Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 1.006966 0.08370828 12.02947 0 0.3348778 0.01851575 dependence2 1.838534 0.08963533 20.51127 0 0.4789678 0.01216686 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.3539 0.02812 0.2988 0.4090 2.496e-36 dependence2 0.6461 0.02812 0.5910 0.7012 7.193e-117 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 2.846 0.06515 2.718 2.973 0 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # known baseline from cohort aa <- aalen(Surv(time,status)~+1,data=data,robust=0) ts <- survival.twostage(aa,data=datacc, clusters=datacc$cluster, theta=theta,var.link=0,step=1.0, random.design=des.rv,theta.des=pardes, pairs.rvs=dout$ant.rvs,var.par=1, pairs=pairs, case.control=1, marginal.status=datacc$status, cr.models=cr.models) summary(ts) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 1.032045 0.07944442 12.99078 0 0.3403792 0.017283117 dependence2 1.897001 0.06795064 27.91734 0 0.4867849 0.008948751 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.3523 0.02247 0.3083 0.3964 2.030e-55 dependence2 0.6477 0.02247 0.6036 0.6917 1.079e-182 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 2.929 0.07785 2.776 3.082 0 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} Figure \ref{fig:surv-cc-base} shows the baseline \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=surv-cc-base,caption= ,captionpos=b} \begin{lstlisting} plot(aa) lines(tscce$baseline,col=2) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{surv-cc-base.jpg} \end{center} \captionof{figure}{Baseline with robust standard errors. Black based on cohort data, red based on profiling for case-control data.} \label{fig:robcox1} \end{marginfigure} \end{document}mets/vignettes/basic-dutils.org0000644000176200001440000006523013623061405016334 0ustar liggesusers#+TITLE: Manipulation of data-frame data with dutility functions #+AUTHOR: Klaus Holst & Thomas Scheike #+PROPERTY: header-args:R :session *R* :cache no :width 550 :height 450 #+PROPERTY: header-args :eval never-export :exports both :results output :tangle yes :comments yes #+PROPERTY: header-args:R+ :colnames yes :rownames no :hlines yes #+INCLUDE: header.org #+OPTIONS: toc:nil timestamp:nil #+BEGIN_SRC emacs-lisp :results silent :exports results :eval (setq org-latex-listings t) (setq org-latex-compiler-file-string "%%\\VignetteIndexEntry{Manipulation of data-frame data with dutility functions}\n%%\\VignetteEngine{R.rsp::tex}\n%%\\VignetteKeyword{R}\n%%\\VignetteKeyword{package}\n%%\\VignetteKeyword{vignette}\n%%\\VignetteKeyword{LaTeX}\n") #+END_SRC ----- # +LaTeX: \clearpage * Simple data manipulation for data-frames - Renaming variables, Deleting variables - Looking at the data - Making new variales for the analysis - Making factors (groupings) - Working with factors - Making a factor from existing numeric variable and vice versa Here are some key data-manipulation steps on a data-frame which is how we typically organize our data in R. After having read the data into R it will typically be a data-frame, if not we can force it to be a data-frame. The basic idea of the utility functions is to get a simple and easy to type way of making simple data-manipulation on a data-frame much like what is possible in SAS or STATA. The functions, say, dcut, dfactor and so on are all functions that basically does what the base R cut, factor do, but are easier to use in the context of data-frames and have additional functionality. #+BEGIN_SRC R :results no :exports code :session *R* :cache no library(mets) data(melanoma) #+END_SRC #+RESULTS: #+begin_example Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.6.3 mets version 1.2.5 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined #+end_example #+BEGIN_SRC R :results output :exports both :session *R* :cache no is.data.frame(melanoma) #+END_SRC #+RESULTS: : [1] TRUE Here we work on the melanoma data that is already read into R and is a data-frame. * dUtility functions The structure for all functions is - dfunction(dataframe,y~x|ifcond,...) to use the function on y in a dataframe grouped by x if condition ifcond is valid. The basic functions are Data processing - dsort - dreshape - dcut - drm, drename, ddrop, dkeep, dsubset - drelevel - dlag - dfactor, dnumeric Data aggregation - dby, dby2 - dscalar, deval, daggregate - dmean, dsd, dsum, dquantile, dcor - dtable, dcount Data summaries - dhead, dtail, - dsummary, - dprint, dlist, dlevels, dunique A generic function daggregate, daggr, can be called with a function as the argument - daggregate(dataframe,y~x|ifcond,fun=function,...) without the grouping variable (x) - daggregate(dataframe,~y|ifcond,fun=function,...) A useful feature is that y and x as well as the subset condition can be specified using regular-expressions or by wildcards (default). Here to illustrate this, we compute the means of certain variables. First just oveall #+BEGIN_SRC R :results output :exports both :session *R* :cache no dmean(melanoma,~thick+I(log(thick))) #+END_SRC #+RESULTS: : thick I(log(thick)) : 291.985366 5.223341 now only when days>500 #+BEGIN_SRC R :results output :exports both :session *R* :cache no dmean(melanoma,~thick+I(log(thick))|I(days>500)) #+END_SRC #+RESULTS: : thick I(log(thick)) : 271.582011 5.168691 and now after sex but only when days>500 #+BEGIN_SRC R :results output :exports both :session *R* :cache no dmean(melanoma,thick+I(log(thick))~sex|I(days>500)) #+END_SRC #+RESULTS: : sex thick I(log(thick)) : 1 0 242.9580 5.060086 : 2 1 320.2429 5.353321 and finally after quartiles of days (via the dcut function) #+BEGIN_SRC R :results output :exports both :session *R* :cache no dmean(melanoma,thick+I(log(thick))~I(dcut(days))) #+END_SRC #+RESULTS: : I(dcut(days)) thick I(log(thick)) : 1 [10,1.52e+03] 482.1731 5.799525 : 2 (1.52e+03,2e+03] 208.5490 4.987652 : 3 (2e+03,3.04e+03] 223.2941 4.974759 : 4 (3.04e+03,5.56e+03] 250.1961 5.120129 or summary of all variables starting with "s" and that contains "a" #+BEGIN_SRC R :results output :exports both :session *R* :cache no dmean(melanoma,"s*"+"*a*"~sex|I(days>500)) #+END_SRC #+RESULTS: : sex status days : 1 0 1.831933 2399.143 : 2 1 1.714286 2169.800 * Renaming, deleting, keeping, dropping variables #+BEGIN_SRC R :results output :exports both :session *R* :cache no melanoma=drename(melanoma,tykkelse~thick) names(melanoma) #+END_SRC #+RESULTS: : [1] "no" "status" "days" "ulc" "tykkelse" "sex" Deleting variables #+BEGIN_SRC R :results output :exports both :session *R* :cache no data(melanoma) melanoma=drm(melanoma,~thick+sex) names(melanoma) #+END_SRC #+RESULTS: : [1] "no" "status" "days" "ulc" or sas style #+BEGIN_SRC R :results output :exports both :session *R* :cache no data(melanoma) melanoma=ddrop(melanoma,~thick+sex) names(melanoma) #+END_SRC #+RESULTS: : [1] "no" "status" "days" "ulc" alternatively we can also keep certain variables #+BEGIN_SRC R :results output :exports both :session *R* :cache no data(melanoma) melanoma=dkeep(melanoma,~thick+sex+status+days) names(melanoma) #+END_SRC #+RESULTS: : [1] "thick" "sex" "status" "days" This can also be done with direct asignment #+BEGIN_SRC R :results output :exports both :session *R* :cache no data(melanoma) ddrop(melanoma) <- ~thick+sex names(melanoma) #+END_SRC #+RESULTS: : [1] "no" "status" "days" "ulc" * Looking at the data #+BEGIN_SRC R :results output :exports both :session *R* :cache no data(melanoma) dstr(melanoma) #+END_SRC #+RESULTS: #+begin_example 'data.frame': 205 obs. of 6 variables: $ no : int 789 13 97 16 21 469 685 7 932 944 ... $ status: int 3 3 2 3 1 1 1 1 3 1 ... $ days : int 10 30 35 99 185 204 210 232 232 279 ... $ ulc : int 1 0 0 0 1 1 1 1 1 1 ... $ thick : int 676 65 134 290 1208 484 516 1288 322 741 ... $ sex : int 1 1 1 0 1 1 1 1 0 0 ... Warning message: In structure(res, ngroupvar = 0, class = c("daggregate", class(res))) : Calling 'structure(NULL, *)' is deprecated, as NULL cannot have attributes. Consider 'structure(list(), *)' instead. #+end_example The data can in Rstudio be seen as a data-table but to list certain parts of the data in output window #+BEGIN_SRC R :results output :exports both :session *R* :cache no dlist(melanoma) #+END_SRC #+RESULTS: #+begin_example no status days ulc thick sex 1 789 3 10 1 676 1 2 13 3 30 0 65 1 3 97 2 35 0 134 1 4 16 3 99 0 290 0 5 21 1 185 1 1208 1 --- 201 317 2 4492 1 706 1 202 798 2 4668 0 612 0 203 806 2 4688 0 48 0 204 606 2 4926 0 226 0 205 328 2 5565 0 290 0 #+end_example #+BEGIN_SRC R :results output :exports both :session *R* :cache no dlist(melanoma, ~.|sex==1) #+END_SRC #+RESULTS: #+begin_example no status days ulc thick 1 789 3 10 1 676 2 13 3 30 0 65 3 97 2 35 0 134 5 21 1 185 1 1208 6 469 1 204 1 484 --- 191 445 2 3909 1 806 195 415 2 4119 0 65 197 175 2 4207 0 65 198 493 2 4310 0 210 201 317 2 4492 1 706 #+end_example #+BEGIN_SRC R :results output :exports both :session *R* :cache no dlist(melanoma, ~ulc+days+thick+sex|sex==1) #+END_SRC #+RESULTS: #+begin_example ulc days thick sex 1 1 10 676 1 2 0 30 65 1 3 0 35 134 1 5 1 185 1208 1 6 1 204 484 1 --- 191 1 3909 806 1 195 0 4119 65 1 197 0 4207 65 1 198 0 4310 210 1 201 1 4492 706 1 #+end_example Getting summaries #+BEGIN_SRC R :results output :exports both :session *R* :cache no dsummary(melanoma) #+END_SRC #+RESULTS: #+begin_example no status days ulc thick Min. : 2.0 Min. :1.00 Min. : 10 Min. :0.000 Min. : 10 1st Qu.:222.0 1st Qu.:1.00 1st Qu.:1525 1st Qu.:0.000 1st Qu.: 97 Median :469.0 Median :2.00 Median :2005 Median :0.000 Median : 194 Mean :463.9 Mean :1.79 Mean :2153 Mean :0.439 Mean : 292 3rd Qu.:731.0 3rd Qu.:2.00 3rd Qu.:3042 3rd Qu.:1.000 3rd Qu.: 356 Max. :992.0 Max. :3.00 Max. :5565 Max. :1.000 Max. :1742 sex Min. :0.0000 1st Qu.:0.0000 Median :0.0000 Mean :0.3854 3rd Qu.:1.0000 Max. :1.0000 #+end_example or for specfic variables #+BEGIN_SRC R :results output :exports both :session *R* :cache no dsummary(melanoma,~thick+status+sex) #+END_SRC #+RESULTS: : thick status sex : Min. : 10 Min. :1.00 Min. :0.0000 : 1st Qu.: 97 1st Qu.:1.00 1st Qu.:0.0000 : Median : 194 Median :2.00 Median :0.0000 : Mean : 292 Mean :1.79 Mean :0.3854 : 3rd Qu.: 356 3rd Qu.:2.00 3rd Qu.:1.0000 : Max. :1742 Max. :3.00 Max. :1.0000 Summaries in different groups (sex) #+BEGIN_SRC R :results output :exports both :session *R* :cache no dsummary(melanoma,thick+days+status~sex) #+END_SRC #+RESULTS: #+begin_example sex: 0 thick days status Min. : 10.0 Min. : 99 Min. :1.000 1st Qu.: 97.0 1st Qu.:1636 1st Qu.:2.000 Median : 162.0 Median :2059 Median :2.000 Mean : 248.6 Mean :2283 Mean :1.833 3rd Qu.: 306.0 3rd Qu.:3131 3rd Qu.:2.000 Max. :1742.0 Max. :5565 Max. :3.000 ------------------------------------------------------------ sex: 1 thick days status Min. : 16.0 Min. : 10 Min. :1.000 1st Qu.: 105.0 1st Qu.:1052 1st Qu.:1.000 Median : 258.0 Median :1860 Median :2.000 Mean : 361.1 Mean :1946 Mean :1.722 3rd Qu.: 484.0 3rd Qu.:2784 3rd Qu.:2.000 Max. :1466.0 Max. :4492 Max. :3.000 #+end_example and only among those with thin-tumours or only females (sex==1) #+BEGIN_SRC R :results output :exports both :session *R* :cache no dsummary(melanoma,thick+days+status~sex|thick<97) #+END_SRC #+RESULTS: #+begin_example sex: 0 thick days status Min. :10.00 Min. : 355 Min. :1.000 1st Qu.:32.00 1st Qu.:1762 1st Qu.:2.000 Median :64.00 Median :2227 Median :2.000 Mean :51.48 Mean :2425 Mean :2.034 3rd Qu.:65.00 3rd Qu.:3185 3rd Qu.:2.000 Max. :81.00 Max. :4688 Max. :3.000 ------------------------------------------------------------ sex: 1 thick days status Min. :16.00 Min. : 30 Min. :1.000 1st Qu.:30.00 1st Qu.:1820 1st Qu.:2.000 Median :65.00 Median :2886 Median :2.000 Mean :55.75 Mean :2632 Mean :1.875 3rd Qu.:81.00 3rd Qu.:3328 3rd Qu.:2.000 Max. :81.00 Max. :4207 Max. :3.000 #+end_example #+BEGIN_SRC R :results output :exports both :session *R* :cache no dsummary(melanoma,thick+status~+1|sex==1) #+END_SRC #+RESULTS: : thick status : Min. : 16.0 Min. :1.000 : 1st Qu.: 105.0 1st Qu.:1.000 : Median : 258.0 Median :2.000 : Mean : 361.1 Mean :1.722 : 3rd Qu.: 484.0 3rd Qu.:2.000 : Max. :1466.0 Max. :3.000 or #+BEGIN_SRC R :results output :exports both :session *R* :cache no dsummary(melanoma,~thick+status|sex==1) #+END_SRC #+RESULTS: : thick status : Min. : 16.0 Min. :1.000 : 1st Qu.: 105.0 1st Qu.:1.000 : Median : 258.0 Median :2.000 : Mean : 361.1 Mean :1.722 : 3rd Qu.: 484.0 3rd Qu.:2.000 : Max. :1466.0 Max. :3.000 To make more complex conditions need to use the I() #+BEGIN_SRC R :results output :exports both :session *R* :cache no dsummary(melanoma,thick+days+status~sex|I(thick<97 & sex==1)) #+END_SRC #+RESULTS: : sex: 1 : thick days status : Min. :16.00 Min. : 30 Min. :1.000 : 1st Qu.:30.00 1st Qu.:1820 1st Qu.:2.000 : Median :65.00 Median :2886 Median :2.000 : Mean :55.75 Mean :2632 Mean :1.875 : 3rd Qu.:81.00 3rd Qu.:3328 3rd Qu.:2.000 : Max. :81.00 Max. :4207 Max. :3.000 Tables between variables #+BEGIN_SRC R :results output :exports both :session *R* :cache no dtable(melanoma,~status+sex) #+END_SRC #+RESULTS: : : sex 0 1 : status : 1 28 29 : 2 91 43 : 3 7 7 All bivariate tables #+BEGIN_SRC R :results output :exports both :session *R* :cache no dtable(melanoma,~status+sex+ulc,level=2) #+END_SRC #+RESULTS: #+begin_example status sex 1 2 3 0 28 91 7 1 29 43 7 status ulc 1 2 3 0 16 92 7 1 41 42 7 sex ulc 0 1 0 79 36 1 47 43 #+end_example All univariate tables #+BEGIN_SRC R :results output :exports both :session *R* :cache no dtable(melanoma,~status+sex+ulc,level=1) #+END_SRC #+RESULTS: #+begin_example status 1 2 3 57 134 14 sex 0 1 126 79 ulc 0 1 115 90 #+end_example and with new variables #+BEGIN_SRC R :results output :exports both :session *R* :cache no dtable(melanoma,~status+sex+ulc+dcut(days)+I(days>300),level=1) #+END_SRC #+RESULTS: #+begin_example status 1 2 3 57 134 14 sex 0 1 126 79 ulc 0 1 115 90 dcut(days) [10,1.52e+03] (1.52e+03,2e+03] (2e+03,3.04e+03] (3.04e+03,5.56e+03] 52 51 51 51 I(days > 300) FALSE TRUE 11 194 #+end_example * Sorting the data To sort the data #+BEGIN_SRC R :results output :exports both :session *R* :cache no data(melanoma) mel= dsort(melanoma,~days) dsort(melanoma) <- ~days head(mel) #+END_SRC #+RESULTS: : no status days ulc thick sex : 1 789 3 10 1 676 1 : 2 13 3 30 0 65 1 : 3 97 2 35 0 134 1 : 4 16 3 99 0 290 0 : 5 21 1 185 1 1208 1 : 6 469 1 204 1 484 1 and to sort after multiple variables increasing and decreasing #+BEGIN_SRC R :results output :exports both :session *R* :cache no dsort(melanoma) <- ~days-status head(melanoma) #+END_SRC #+RESULTS: : no status days ulc thick sex : 1 789 3 10 1 676 1 : 2 13 3 30 0 65 1 : 3 97 2 35 0 134 1 : 4 16 3 99 0 290 0 : 5 21 1 185 1 1208 1 : 6 469 1 204 1 484 1 * Making new variales for the analysis To define a bunch of new covariates within a data-frame #+BEGIN_SRC R :results output :exports both :session *R* :cache no data(melanoma) melanoma= transform(melanoma, thick2=thick^2, lthick=log(thick) ) dhead(melanoma) #+END_SRC #+RESULTS: : no status days ulc thick sex thick2 lthick : 1 789 3 10 1 676 1 456976 6.516193 : 2 13 3 30 0 65 1 4225 4.174387 : 3 97 2 35 0 134 1 17956 4.897840 : 4 16 3 99 0 290 0 84100 5.669881 : 5 21 1 185 1 1208 1 1459264 7.096721 : 6 469 1 204 1 484 1 234256 6.182085 When the above definitions are done using a condition this can be achieved using the dtransform function that extends transform with a possible condition #+BEGIN_SRC R :results output :exports both :session *R* :cache no melanoma=dtransform(melanoma,ll=thick*1.05^ulc,sex==1) melanoma=dtransform(melanoma,ll=thick,sex!=1) dmean(melanoma,ll~sex+ulc) #+END_SRC #+RESULTS: : sex ulc ll : 1 0 0 173.7342 : 2 1 0 197.3611 : 3 0 1 374.5532 : 4 1 1 523.1198 * Making factors (groupings) On the melanoma data the variable thick gives the thickness of the melanom tumour. For some analyses we would like to make a factor depending on the thickness. This can be done in several different ways #+BEGIN_SRC R :results output :exports both :session *R* :cache no melanoma=dcut(melanoma,~thick,breaks=c(0,200,500,800,2000)) #+END_SRC #+RESULTS: New variable is named thickcat.0 by default. To see levels of factors in data-frame #+BEGIN_SRC R :results output :exports both :session *R* :cache no dlevels(melanoma) #+END_SRC #+RESULTS: : thickcat.0 #levels=:4 : [1] "[0,200]" "(200,500]" "(500,800]" "(800,2e+03]" : ----------------------------------------- Checking group sizes #+BEGIN_SRC R :results output :exports both :session *R* :cache no dtable(melanoma,~thickcat.0) #+END_SRC #+RESULTS: : : thickcat.0 : [0,200] (200,500] (500,800] (800,2e+03] : 109 64 20 12 With adding to the data-frame directly #+BEGIN_SRC R :results output :exports both :session *R* :cache no dcut(melanoma,breaks=c(0,200,500,800,2000)) <- gr.thick1~thick dlevels(melanoma) #+END_SRC #+RESULTS: : thickcat.0 #levels=:4 : [1] "[0,200]" "(200,500]" "(500,800]" "(800,2e+03]" : ----------------------------------------- : gr.thick1 #levels=:4 : [1] "[0,200]" "(200,500]" "(500,800]" "(800,2e+03]" : ----------------------------------------- new variable is named thickcat.0 (after first cut-point), or to get quartiles with default names thick.cat.4 #+BEGIN_SRC R :results output :exports both :session *R* :cache no dcut(melanoma) <- ~ thick # new variable is thickcat.4 dlevels(melanoma) #+END_SRC #+RESULTS: : thickcat.0 #levels=:4 : [1] "[0,200]" "(200,500]" "(500,800]" "(800,2e+03]" : ----------------------------------------- : gr.thick1 #levels=:4 : [1] "[0,200]" "(200,500]" "(500,800]" "(800,2e+03]" : ----------------------------------------- : thickcat.4 #levels=:4 : [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" : ----------------------------------------- or median groups, here starting again with the original data, #+BEGIN_SRC R :results output :exports both :session *R* :cache no data(melanoma) dcut(melanoma,breaks=2) <- ~ thick # new variable is thick.2 dlevels(melanoma) #+END_SRC #+RESULTS: : thickcat.2 #levels=:2 : [1] "[10,194]" "(194,1.74e+03]" : ----------------------------------------- to control new names #+BEGIN_SRC R :results output :exports both :session *R* :cache no data(melanoma) mela= dcut(melanoma,thickcat4+dayscat4~thick+days,breaks=4) dlevels(mela) #+END_SRC #+RESULTS: : thickcat4 #levels=:4 : [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" : ----------------------------------------- : dayscat4 #levels=:4 : [1] "[10,1.52e+03]" "(1.52e+03,2e+03]" "(2e+03,3.04e+03]" : [4] "(3.04e+03,5.56e+03]" : ----------------------------------------- or #+BEGIN_SRC R :results output :exports both :session *R* :cache no data(melanoma) dcut(melanoma,breaks=4) <- thickcat4+dayscat4~thick+days dlevels(melanoma) #+END_SRC #+RESULTS: : thickcat4 #levels=:4 : [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" : ----------------------------------------- : dayscat4 #levels=:4 : [1] "[10,1.52e+03]" "(1.52e+03,2e+03]" "(2e+03,3.04e+03]" : [4] "(3.04e+03,5.56e+03]" : ----------------------------------------- This can also be typed out more specifically #+BEGIN_SRC R :results output :exports both :session *R* :cache no melanoma$gthick = cut(melanoma$thick,breaks=c(0,200,500,800,2000)) melanoma$gthick = cut(melanoma$thick,breaks=quantile(melanoma$thick),include.lowest=TRUE) #+END_SRC #+RESULTS: * Working with factors To see levels of covariates in data-frame #+BEGIN_SRC R :results output :exports both :session *R* :cache no data(melanoma) dcut(melanoma,breaks=4) <- thickcat4~thick dlevels(melanoma) #+END_SRC #+RESULTS: : thickcat4 #levels=:4 : [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" : ----------------------------------------- To relevel the factor #+BEGIN_SRC R :results output :exports both :session *R* :cache no dtable(melanoma,~thickcat4) melanoma = drelevel(melanoma,~thickcat4,ref="(194,356]") dlevels(melanoma) #+END_SRC #+RESULTS: #+begin_example thickcat4 [10,97] (97,194] (194,356] (356,1.74e+03] 56 53 45 51 thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- thickcat4.(194,356] #levels=:4 [1] "(194,356]" "[10,97]" "(97,194]" "(356,1.74e+03]" ----------------------------------------- #+end_example or to take the third level in the list of levels, same as above, #+BEGIN_SRC R :results output :exports both :session *R* :cache no melanoma = drelevel(melanoma,~thickcat4,ref=2) dlevels(melanoma) #+END_SRC #+RESULTS: : thickcat4 #levels=:4 : [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" : ----------------------------------------- : thickcat4.(194,356] #levels=:4 : [1] "(194,356]" "[10,97]" "(97,194]" "(356,1.74e+03]" : ----------------------------------------- : thickcat4.2 #levels=:4 : [1] "(97,194]" "[10,97]" "(194,356]" "(356,1.74e+03]" : ----------------------------------------- To combine levels of a factor (first combinining first 3 groups into one) #+BEGIN_SRC R :results output :exports both :session *R* :cache no melanoma = drelevel(melanoma,~thickcat4,newlevels=1:3) dlevels(melanoma) #+END_SRC #+RESULTS: #+begin_example thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- thickcat4.(194,356] #levels=:4 [1] "(194,356]" "[10,97]" "(97,194]" "(356,1.74e+03]" ----------------------------------------- thickcat4.2 #levels=:4 [1] "(97,194]" "[10,97]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- thickcat4.1:3 #levels=:2 [1] "[10,97]-(194,356]" "(356,1.74e+03]" ----------------------------------------- #+end_example or to combine groups 1 and 2 into one group and 3 and 4 into another #+BEGIN_SRC R :results output :exports both :session *R* :cache no dkeep(melanoma) <- ~thick+thickcat4 melanoma = drelevel(melanoma,gthick2~thickcat4,newlevels=list(1:2,3:4)) dlevels(melanoma) #+END_SRC #+RESULTS: : thickcat4 #levels=:4 : [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" : ----------------------------------------- : gthick2 #levels=:2 : [1] "[10,97]-(97,194]" "(194,356]-(356,1.74e+03]" : ----------------------------------------- Changing order of factor levels #+BEGIN_SRC R :results output :exports both :session *R* :cache no dfactor(melanoma,levels=c(3,1,2,4)) <- thickcat4.2~thickcat4 dlevel(melanoma,~ "thickcat4*") dtable(melanoma,~thickcat4+thickcat4.2) #+END_SRC #+RESULTS: #+begin_example thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- thickcat4.2 #levels=:4 [1] "(194,356]" "[10,97]" "(97,194]" "(356,1.74e+03]" ----------------------------------------- thickcat4.2 (194,356] [10,97] (97,194] (356,1.74e+03] thickcat4 [10,97] 0 56 0 0 (97,194] 0 0 53 0 (194,356] 45 0 0 0 (356,1.74e+03] 0 0 0 51 #+end_example Combine levels but now control factor-level names #+BEGIN_SRC R :results output :exports both :session *R* :cache no melanoma=drelevel(melanoma,gthick3~thickcat4,newlevels=list(group1.2=1:2,group3.4=3:4)) dlevels(melanoma) #+END_SRC #+RESULTS: #+begin_example thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- gthick2 #levels=:2 [1] "[10,97]-(97,194]" "(194,356]-(356,1.74e+03]" ----------------------------------------- thickcat4.2 #levels=:4 [1] "(194,356]" "[10,97]" "(97,194]" "(356,1.74e+03]" ----------------------------------------- gthick3 #levels=:2 [1] "group1.2" "group3.4" ----------------------------------------- #+end_example * Making a factor from existing numeric variable and vice versa A numeric variable "status" with values 1,2,3 into a factor by #+BEGIN_SRC R :results output :exports both :session *R* :cache no data(melanoma) melanoma = dfactor(melanoma,~status, labels=c("malignant-melanoma","censoring","dead-other")) melanoma = dfactor(melanoma,sexl~sex,labels=c("females","males")) dtable(melanoma,~sexl+status.f) #+END_SRC #+RESULTS: : : status.f malignant-melanoma censoring dead-other : sexl : females 28 91 7 : males 29 43 7 A gender factor with values "M", "F" can be converted into numerics by #+BEGIN_SRC R :results output :exports both :session *R* :cache no melanoma = dnumeric(melanoma,~sexl) dstr(melanoma,"sex*") dtable(melanoma,~'sex*',level=2) #+END_SRC #+RESULTS: #+begin_example 'data.frame': 205 obs. of 3 variables: $ sex : int 1 1 1 0 1 1 1 1 0 0 ... $ sexl : Factor w/ 2 levels "females","males": 2 2 2 1 2 2 2 2 1 1 ... $ sexl.n: num 2 2 2 1 2 2 2 2 1 1 ... Warning message: In structure(res, ngroupvar = 0, class = c("daggregate", class(res))) : Calling 'structure(NULL, *)' is deprecated, as NULL cannot have attributes. Consider 'structure(list(), *)' instead. sex sexl 0 1 females 126 0 males 0 79 sex sexl.n 0 1 1 126 0 2 0 79 sexl sexl.n females males 1 126 0 2 0 79 #+end_example mets/vignettes/binomial-twin.org0000644000176200001440000007306213623061405016524 0ustar liggesusers#+TITLE: Analysis of bivariate binomial data: Twin analysis #+AUTHOR: Klaus Holst & Thomas Scheike #+PROPERTY: header-args:R :session *R* :cache no :width 550 :height 450 #+PROPERTY: header-args :eval never-export :exports both :results output :tangle yes :comments yes #+PROPERTY: header-args:R+ :colnames yes :rownames no :hlines yes #+INCLUDE: header.org #+OPTIONS: toc:nil timestamp:nil #+BEGIN_SRC emacs-lisp :results silent :exports results :eval (setq org-latex-listings t) (setq org-latex-compiler-file-string "%%\\VignetteIndexEntry{Analysis of bivariate binomial data: Twin analysis}\n%%\\VignetteEngine{R.rsp::tex}\n%%\\VignetteKeyword{R}\n%%\\VignetteKeyword{package}\n%%\\VignetteKeyword{vignette}\n%%\\VignetteKeyword{LaTeX}\n") #+END_SRC ----- # +LaTeX: \clearpage * Overview When looking at bivariate binomial data with the aim of learning about the dependence that is present, possibly after correcting for some covariates many models are available. - Random-effects models logistic regression covered elsewhere (glmer in lme4). in the mets package you can fit the - Pairwise odds ratio model - Bivariate Probit model - With random effects - Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. - Additive gamma random effects model - Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. Typically it can be hard or impossible to specify random effects models with special structure among the parameters of the random effects. This is possible in our models. To be concrete about the model structure assume that we have paired binomial data \( Y_1, Y_2, X_1, X_2 \) where the responses are \( Y_1, Y_2 \) and we have covariates \( X_1, X_2 \). We start by giving a brief description of these different models. First we for bivariate data one can specify the marginal probability using logistic regression models \[ logit(P(Y_i=1|X_i)) = \alpha_i + X_i^T \beta i=1,2. \] These model can be estimated under working independence \cite{zeger-liang-86}. A typical twin analysis will typically consist of looking at both - Pairwise odds ratio model - Bivariate Probit model The additive gamma can be used for the same as the bivariate probit model but is more restrictive in terms of dependence structure, but is nevertheless still valuable to have also as a check of results of the bivariate probit model. ** Biprobit with random effects For these model we assume that given random effects $Z$ and a covariate vector \( V_{12} \) we have independent logistic regression models \[ probit(P(Y_i=1|X_i, Z)) = \alpha_i + X_i^T \beta + V_{12}^T Z i=1,2. \] where \( Z \) is a bivariate normal distribution with some covariance \( \Sigma \). The general covariance structure \( \Sigma \) makes the model very flexible. We note that - Paramters \( \beta \) are subject specific - The \( \Sigma \) will reflect dependence The more standard link function \( logit \) rather than the \( probit \) link is often used and implemented in for example \cite{mm}. The advantage is that one now gets an odds-ratio interpretation of the subject specific effects, but one then needs numerical integration to fit the model. #We note that # # - Numerical integration is involved and this can be difficult for many random # effects. ** Pairwise odds ratio model Now the pairwise odds ratio model the specifies that given \( X_1, X_2 \) the marginal models are \[ logit(P(Y_i=1|X_i)) = \alpha_i + X_i^T \beta i=1,2 \] The primary object of interest are the odds ratio between \(Y_{1}\) and \(Y_{2}\) \[ \gamma_{12} = \frac{ P( Y_{ki} =1 , Y_{kj} =1) P( Y_{ki} =0 , Y_{kj} =0) }{ P( Y_{ki} =1 , Y_{kj} =0) P( Y_{ki} =0 , Y_{kj} =1) } \] given \(X_{ki}\), \(X_{kj}\), and \(Z_{kji}\). We model the odds ratio with the regression \[ \gamma_{12} = \exp( Z_{12}^T \lambda) \] Where \( Z_{12} \) are some covarites that may influence the odds-ratio between between \(Y_{1}\) and \(Y_{2}\) and contains the marginal covariates, \cite{carey-1993,dale1986global,palmgren1989,molenberghs1994marginal}. This odds-ratio is given covariates as well as marginal covariates. The odds-ratio and marginals specify the joint bivariate distribution via the so-called Placckett-distribution. One way of fitting this model is the ALR algoritm, the alternating logistic regression ahd this has been described in several papers \cite{kuk2004permutation,kuk2007hybrid,qaqish2012orthogonalized}. We here simply estimate the parameters in a two stage-procedure - Estimating the marginal parameters via GEE - Using marginal estimates, estimate dependence parameters This gives efficient estimates of the dependence parameters because of orthogonality, but some efficiency may be gained for the marginal parameters by using the full likelihood or iterative fitting such as for the ALR. The pairwise odds-ratio model is very useful, but one do not have a random effects model. ** Additive gamma model Again we operate under marginal logistic regression models are \[ logit(P(Y_i=1|X_i)) = \alpha_i + X_i^T \beta i=1,2 \] First with just one random effect \( Z \) we assume that conditional on \( Z \) the responses are independent and follow the model \[ logit(P(Y_i=1|X_i,Z)) = exp( -Z \cdot \Psi^{-1}(\lambda_{\bullet},\lambda_{\bullet},P(Y_i=1|X_i)) ) \] where \( \Psi \) is the laplace transform of \( Z \) where we assume that \( Z \) is gamma distributed with variance \( \lambda_{\bullet}^{-1} \) and mean 1. In general \( \Psi(\lambda_1,\lambda_2) \) is the laplace transform of a Gamma distributed random effect with \( Z \) with mean \( \lambda_1/\lambda_2 \) and variance \( \lambda_1/\lambda_2^2 \). We fit this model by - Estimating the marginal parameters via GEE - Using marginal estimates, estimate dependence parameters To deal with multiple random effects we consider random effects \( Z_i i=1,...,d \) such that \( Z_i \) is gamma distributed with mean \( \lambda_j/\lambda_{\bullet} \) and variance \( \lambda_j/\lambda_{\bullet}^2 \), where we define the scalar \( \lambda_{\bullet} \) below. Now given a cluster-specific design vector \( V_{12} \) we assume that \[ V_{12}^T Z \] is gamma distributed with mean 1 and variance \( \lambda_{\bullet}^{-1} \) such that critically the random effect variance is the same for all clusters. That is \[ \lambda_{\bullet} = V_{12}^T (\lambda_1,...,\lambda_d)^T \] We return to some specific models below, and show how to fit the ACE and AE model using this set-up. One last option in the model-specification is to specify how the parameters \( \lambda_1,...,\lambda_d \) are related. We thus can specify a matrix \( M \) of dimension \( p \times d \) such that \[ (\lambda_1,...,\lambda_d)^T = M \theta \] where \( \theta \) is d-dimensional. If \( M \) is diagonal we have no restrictions on parameters. This parametrization is obtained with the var.par=0 option that thus estimates \( \theta \). The DEFAULT parametrization instead estimates the variances of the random effecs (var.par=1) via the parameters \( \nu \) \[ M \nu = ( \lambda_1/\lambda_{\bullet}^2, ...,\lambda_d/\lambda_{\bullet}^2)^T \] The basic modelling assumption is now that given random effects \(Z=(Z_1,...,Z_d)\) we have independent probabilites \[ logit(P(Y_i=1|X_i,Z)) = exp( -V_{12,i}^T Z \cdot \Psi^{-1}(\lambda_{\bullet},\lambda_{\bullet},P(Y_i=1|X_i)) ) i=1,2 \] We fit this model by - Estimating the marginal parameters via GEE - Using marginal estimates, estimate dependence parameters Even though the model not formaly in this formulation allows negative correlation in practice the paramters can be negative and this reflects negative correlation. An advanatage is that no numerical integration is needed. * The twin-stutter data We consider the twin-stutter where for pairs of twins that are either dizygotic or monozygotic we have recorded whether the twins are stuttering \cite{twinstut-ref} We here consider MZ and same sex DZ twins. Looking at the data #+BEGIN_SRC R :results output :exports both :session *R* :cache yes library(mets) data(twinstut) twinstut$binstut <- 1*(twinstut$stutter=="yes") twinsall <- twinstut twinstut <- subset(twinstut,zyg%in%c("mz","dz")) head(twinstut) #+END_SRC #+RESULTS[9949cf8d9d2aaad53abb274bed18baea16f4e110]: #+begin_example tvparnr zyg stutter sex age nr binstut 1 1 mz no female 71 1 0 2 1 mz no female 71 2 0 3 2 dz no female 71 1 0 8 5 mz no female 71 1 0 9 5 mz no female 71 2 0 11 7 dz no male 71 1 0 #+end_example * Pairwise odds ratio model We start by fitting an overall dependence OR for both MZ and DZ even though the dependence is expected to be different across zygosity. The first step is to fit the marginal model adjusting for marginal covariates. We here note that there is a rather strong gender effect in the risk of stuttering. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes margbin <- glm(binstut~factor(sex)+age,data=twinstut,family=binomial()) summary(margbin) #+END_SRC #+RESULTS[d7ee0e2a1c7ce11cbee6bef6130d1b6d298cfb0c]: #+begin_example Call: glm(formula = binstut ~ factor(sex) + age, family = binomial(), data = twinstut) Deviance Residuals: Min 1Q Median 3Q Max -0.4419 -0.4078 -0.2842 -0.2672 2.6395 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) -3.027625 0.104012 -29.108 < 2e-16 *** factor(sex)male 0.869826 0.062197 13.985 < 2e-16 *** age -0.005983 0.002172 -2.754 0.00588 ** --- Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 9328.6 on 21287 degrees of freedom Residual deviance: 9117.0 on 21285 degrees of freedom AIC: 9123 Number of Fisher Scoring iterations: 6 #+end_example Now estimating the OR parameter. We see a strong dependence with an OR at around 8 that is clearly significant. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes bina <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,detail=0) summary(bina) #+END_SRC #+RESULTS[f4450da3e8f5b38bdcf307346f9090ad59a689fa]: #+begin_example Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se dependence1 2.085347 0.1274536 $or Estimate Std.Err 2.5% 97.5% P-value dependence1 8.05 1.03 6.04 10.1 4.3e-15 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" #+end_example Now, and more interestingly, we consider an OR that depends on zygosity and note that MZ have a much larger OR than DZ twins. This type of trait is somewhat complicated to interpret, but clearly, one option is that that there is a genetic effect, alternatively there might be a stronger environmental effect for MZ twins. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes # design for OR dependence theta.des <- model.matrix( ~-1+factor(zyg),data=twinstut) bin <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,theta.des=theta.des) summary(bin) #+END_SRC #+RESULTS[252013ed4e3d7459c1b5e59d1eb3ec053d71a367]: #+begin_example Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(zyg)dz 0.5221651 0.2401355 factor(zyg)mz 3.4853933 0.1866076 $or Estimate Std.Err 2.5% 97.5% P-value factor(zyg)dz 1.69 0.405 0.892 2.48 3.12e-05 factor(zyg)mz 32.64 6.090 20.699 44.57 8.38e-08 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" #+end_example We now consider further regression modelling of the OR structure by considering possible interactions between sex and zygozsity. We see that MZ has a much higher dependence and that males have a much lower dependence. We tested for interaction in this model and these were not significant. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes twinstut$cage <- scale(twinstut$age) theta.des <- model.matrix( ~-1+factor(zyg)+factor(sex),data=twinstut) bina <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,theta.des=theta.des) summary(bina) #+END_SRC #+RESULTS[f12b874bc6e09b656a63ed81039a73362628c588]: #+begin_example Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(zyg)dz 0.8098841 0.3138423 factor(zyg)mz 3.7318076 0.2632250 factor(sex)male -0.4075409 0.3055349 $or Estimate Std.Err 2.5% 97.5% P-value factor(zyg)dz 2.248 0.705 0.865 3.63 0.001441 factor(zyg)mz 41.755 10.991 20.213 63.30 0.000145 factor(sex)male 0.665 0.203 0.267 1.06 0.001064 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" #+end_example ** Alternative syntax We now demonstrate how the models can fitted jointly and with anohter syntax, that ofcourse just fits the marginal model and subsequently fits the pairwise OR model. First noticing as before that MZ twins have a much higher dependence. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes # refers to zygosity of first subject in eash pair : zyg1 # could also use zyg2 (since zyg2=zyg1 within twinpair's) out <- easy.binomial.twostage(stutter~factor(sex)+age,data=twinstut, response="binstut",id="tvparnr",var.link=1, theta.formula=~-1+factor(zyg1)) summary(out) #+END_SRC #+RESULTS[9b2592b96c25b34e8d66101f639ba885c137d9c6]: #+begin_example Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(zyg1)dz 0.5221651 0.2401355 factor(zyg1)mz 3.4853933 0.1866076 $or Estimate Std.Err 2.5% 97.5% P-value factor(zyg1)dz 1.69 0.405 0.892 2.48 3.12e-05 factor(zyg1)mz 32.64 6.090 20.699 44.57 8.38e-08 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" #+end_example Now considering all data and estimating separate effects for the OR for opposite sex DZ twins and same sex twins. We here find that os twins are not markedly different from the same sex DZ twins. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes # refers to zygosity of first subject in eash pair : zyg1 # could also use zyg2 (since zyg2=zyg1 within twinpair's)) desfs<-function(x,num1="zyg1",num2="zyg2") c(x[num1]=="dz",x[num1]=="mz",x[num1]=="os")*1 margbinall <- glm(binstut~factor(sex)+age,data=twinsall,family=binomial()) out3 <- easy.binomial.twostage(binstut~factor(sex)+age, data=twinsall,response="binstut",id="tvparnr",var.link=1, theta.formula=desfs,desnames=c("dz","mz","os")) summary(out3) #+END_SRC #+RESULTS[21d70482c6a40770f5ed94e778e47808db7228a2]: #+begin_example Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se dz 0.5278527 0.2396796 mz 3.4850037 0.1864190 os 0.7802940 0.2894394 $or Estimate Std.Err 2.5% 97.5% P-value dz 1.70 0.406 0.899 2.49 3.02e-05 mz 32.62 6.081 20.703 44.54 8.13e-08 os 2.18 0.632 0.944 3.42 5.50e-04 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" #+end_example * Bivariate Probit model #+BEGIN_SRC R :results output :exports both :session *R* :cache yes library(mets) data(twinstut) twinstut <- subset(twinstut,zyg%in%c("mz","dz")) twinstut$binstut <- 1*(twinstut$stutter=="yes") head(twinstut) #+END_SRC #+RESULTS[4e32c4fd9dd33864fd59d4ef493048607c4f2ac2]: : tvparnr zyg stutter sex age nr binstut : 1 2001005 mz no female 71 1 0 : 2 2001005 mz no female 71 2 0 : 3 2001006 dz no female 71 1 0 : 8 2001012 mz no female 71 1 0 : 9 2001012 mz no female 71 2 0 : 11 2001015 dz no male 71 1 0 First testing for same dependence in MZ and DZ that we recommend doing by comparing the correlations of MZ and DZ twins. Apart from regression correction in the mean this is an un-structured model, and the useful concordance and casewise concordance estimates can be reported from this analysis. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes b1 <- bptwin(binstut~sex,data=twinstut,id="tvparnr",zyg="zyg",DZ="dz",type="un") summary(b1) #+END_SRC #+RESULTS[5188e3b434027f5abc5fae0d144e44651cefd1f0]: #+begin_example Estimate Std.Err Z p-value (Intercept) -1.794823 0.023289 -77.066728 0.0000 sexmale 0.401432 0.030179 13.301813 0.0000 atanh(rho) MZ 1.096916 0.073574 14.909087 0.0000 atanh(rho) DZ 0.132458 0.062516 2.118800 0.0341 Total MZ/DZ Complete pairs MZ/DZ 8777/12511 3255/4058 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.79939 0.74101 0.84577 Tetrachoric correlation DZ 0.13169 0.00993 0.24960 MZ: Estimate 2.5% 97.5% Concordance 0.01698 0.01411 0.02042 Casewise Concordance 0.46730 0.40383 0.53185 Marginal 0.03634 0.03287 0.04016 Rel.Recur.Risk 12.85882 10.87510 14.84253 log(OR) 3.75632 3.37975 4.13289 DZ: Estimate 2.5% 97.5% Concordance 0.00235 0.00140 0.00393 Casewise Concordance 0.06456 0.03937 0.10413 Marginal 0.03634 0.03287 0.04016 Rel.Recur.Risk 1.77662 0.92746 2.62577 log(OR) 0.63527 0.09013 1.18040 Estimate 2.5% 97.5% Broad-sense heritability 1 NaN NaN #+end_example ** Polygenic modelling We now turn attention to specific polygenic modelling where special random effects are used to specify ACE, AE, ADE models and so forth. This is very easy with the bptwin function. The key parts of the output are the sizes of the genetic component A and the environmental component, and we can compare with the results of the unstructed model above. Also formally we can test if this submodel is acceptable by a likelihood ratio test. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes b1 <- bptwin(binstut~sex,data=twinstut,id="tvparnr",zyg="zyg",DZ="dz",type="ace") summary(b1) #+END_SRC #+RESULTS[68028e51ecc9e1ac66efb0b6397c86109b7523df]: #+begin_example Estimate Std.Err Z p-value (Intercept) -3.70371 0.24449 -15.14855 0 sexmale 0.83310 0.08255 10.09201 0 log(var(A)) 1.18278 0.17179 6.88512 0 log(var(C)) -29.99519 NA NA NA Total MZ/DZ Complete pairs MZ/DZ 8777/12511 3255/4058 Estimate 2.5% 97.5% A 0.76545 0.70500 0.82590 C 0.00000 0.00000 0.00000 E 0.23455 0.17410 0.29500 MZ Tetrachoric Cor 0.76545 0.69793 0.81948 DZ Tetrachoric Cor 0.38272 0.35210 0.41253 MZ: Estimate 2.5% 97.5% Concordance 0.01560 0.01273 0.01912 Casewise Concordance 0.42830 0.36248 0.49677 Marginal 0.03643 0.03294 0.04027 Rel.Recur.Risk 11.75741 9.77237 13.74246 log(OR) 3.52382 3.13466 3.91298 DZ: Estimate 2.5% 97.5% Concordance 0.00558 0.00465 0.00670 Casewise Concordance 0.15327 0.13749 0.17050 Marginal 0.03643 0.03294 0.04027 Rel.Recur.Risk 4.20744 3.78588 4.62900 log(OR) 1.69996 1.57262 1.82730 Estimate 2.5% 97.5% Broad-sense heritability 0.76545 0.70500 0.82590 #+end_example #+BEGIN_SRC R :results output :exports both :session *R* :cache yes b0 <- bptwin(binstut~sex,data=twinstut,id="tvparnr",zyg="zyg",DZ="dz",type="ae") summary(b0) #+END_SRC #+RESULTS[c0e45ba8833413d2e33cf487e1b564c90e2f2378]: #+begin_example Estimate Std.Err Z p-value (Intercept) -3.70371 0.24449 -15.14855 0 sexmale 0.83310 0.08255 10.09201 0 log(var(A)) 1.18278 0.17179 6.88512 0 Total MZ/DZ Complete pairs MZ/DZ 8777/12511 3255/4058 Estimate 2.5% 97.5% A 0.76545 0.70500 0.82590 E 0.23455 0.17410 0.29500 MZ Tetrachoric Cor 0.76545 0.69793 0.81948 DZ Tetrachoric Cor 0.38272 0.35210 0.41253 MZ: Estimate 2.5% 97.5% Concordance 0.01560 0.01273 0.01912 Casewise Concordance 0.42830 0.36248 0.49677 Marginal 0.03643 0.03294 0.04027 Rel.Recur.Risk 11.75741 9.77237 13.74246 log(OR) 3.52382 3.13466 3.91298 DZ: Estimate 2.5% 97.5% Concordance 0.00558 0.00465 0.00670 Casewise Concordance 0.15327 0.13749 0.17050 Marginal 0.03643 0.03294 0.04027 Rel.Recur.Risk 4.20744 3.78588 4.62900 log(OR) 1.69996 1.57262 1.82730 Estimate 2.5% 97.5% Broad-sense heritability 0.76545 0.70500 0.82590 #+end_example * Additive gamma random effects Fitting first a model with different size random effects for MZ and DZ. We note that as before in the OR and biprobit model the dependence is much stronger for MZ twins. We also test if these are the same by parametrizing the OR model with an intercept. This clearly shows a significant difference. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes theta.des <- model.matrix( ~-1+factor(zyg),data=twinstut) margbin <- glm(binstut~sex,data=twinstut,family=binomial()) bintwin <- binomial.twostage(margbin,data=twinstut,model="gamma", clusters=twinstut$tvparnr,detail=0,theta=c(0.1)/1,var.link=1, theta.des=theta.des) summary(bintwin) # test for same dependence in MZ and DZ theta.des <- model.matrix( ~factor(zyg),data=twinstut) margbin <- glm(binstut~sex,data=twinstut,family=binomial()) bintwin <- binomial.twostage(margbin,data=twinstut,model="gamma", clusters=twinstut$tvparnr,detail=0,theta=c(0.1)/1,var.link=1, theta.des=theta.des) summary(bintwin) #+END_SRC #+RESULTS[2e770040cc6e95503373b894ca170abc19468abe]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates theta se factor(zyg)dz -2.61194495 0.4854454 factor(zyg)mz -0.01817181 0.1030735 $vargam Estimate Std.Err 2.5% 97.5% P-value factor(zyg)dz 0.0734 0.0356 0.00356 0.143 3.94e-02 factor(zyg)mz 0.9820 0.1012 0.78361 1.180 2.96e-22 $type [1] "gamma" attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates theta se (Intercept) -2.611945 0.4854454 factor(zyg)mz 2.593773 0.4962675 $vargam Estimate Std.Err 2.5% 97.5% P-value (Intercept) 0.0734 0.0356 0.00356 0.143 0.0394 factor(zyg)mz 13.3802 6.6401 0.36573 26.395 0.0439 $type [1] "gamma" attr(,"class") [1] "summary.mets.twostage" #+end_example ** Polygenic modelling First setting up the random effects design for the random effects and the the relationship between variance parameters. We see that the genetic random effect has size one for MZ and 0.5 for DZ subjects, that have shared and non-shared genetic components with variance 0.5 such that the total genetic variance is the same for all subjects. The shared environmental effect is the samme for all. Thus two parameters with these bands. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes out <- twin.polygen.design(twinstut,id="tvparnr",zygname="zyg",zyg="dz",type="ace") head(cbind(out$des.rv,twinstut$tvparnr),10) out$pardes #+END_SRC #+RESULTS[5b4ecc2d5fe90ba4e492080f3b6857f1ecc92a8b]: #+begin_example MZ DZ DZns1 DZns2 env 1 1 0 0 0 1 2001005 2 1 0 0 0 1 2001005 3 0 1 1 0 1 2001006 8 1 0 0 0 1 2001012 9 1 0 0 0 1 2001012 11 0 1 1 0 1 2001015 12 0 1 1 0 1 2001016 13 0 1 0 1 1 2001016 15 0 1 1 0 1 2001020 18 0 1 1 0 1 2001022 [,1] [,2] [1,] 1.0 0 [2,] 0.5 0 [3,] 0.5 0 [4,] 0.5 0 [5,] 0.0 1 #+end_example Now, fitting the ACE model, we see that the variance of the genetic, component, is 1.5 and the environmental variance is -0.5. Thus suggesting that the ACE model does not fit the data. When the random design is given we automatically use the gamma fralty model. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes margbin <- glm(binstut~sex,data=twinstut,family=binomial()) bintwin1 <- binomial.twostage(margbin,data=twinstut, clusters=twinstut$tvparnr,detail=0,theta=c(0.1)/1,var.link=0, random.design=out$des.rv,theta.des=out$pardes) summary(bintwin1) #+END_SRC #+RESULTS[b4e825656d6fbc68289cb3007da5c7be882c530a]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 1.5261839 0.2475041 dependence2 -0.5447955 0.1942159 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1.555 0.187 1.189 1.922 9.11e-17 dependence2 -0.555 0.187 -0.922 -0.189 2.99e-03 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.981 0.102 0.781 1.18 8.29e-22 attr(,"class") [1] "summary.mets.twostage" #+end_example For this model we estimate the concordance and casewise concordance as well as the marginal rates of stuttering for females. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes concordanceTwinACE(bintwin1,type="ace") #+END_SRC #+RESULTS[c5cf06fe6ea4f093a95f84bf09f5bdec22e4659c]: #+begin_example $MZ Estimate Std.Err 2.5% 97.5% P-value concordance 0.0182 0.00147 0.0153 0.0211 2.61e-35 casewise concordance 0.5033 0.03256 0.4395 0.5672 6.49e-54 marginal 0.0362 0.00188 0.0325 0.0399 7.15e-83 $DZ Estimate Std.Err 2.5% 97.5% P-value concordance 0.00235 0.000589 0.0012 0.00351 6.45e-05 casewise concordance 0.06501 0.015836 0.0340 0.09604 4.04e-05 marginal 0.03620 0.001877 0.0325 0.03988 7.15e-83 #+end_example The E component was not consistent with the fit of the data and we now consider instead the AE model. #+BEGIN_SRC R :results output :exports both :session *R* :cache yes out <- twin.polygen.design(twinstut,id="tvparnr",zygname="zyg",zyg="dz",type="ae") bintwin <- binomial.twostage(margbin,data=twinstut, clusters=twinstut$tvparnr,detail=0,theta=c(0.1)/1,var.link=0, random.design=out$des.rv,theta.des=out$pardes) summary(bintwin) #+END_SRC #+RESULTS[11b872ba5c2c67ef5226f87056a1fbf681905039]: #+begin_example Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.9094847 0.09536268 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.909 0.0954 0.723 1.1 1.47e-21 attr(,"class") [1] "summary.mets.twostage" #+end_example Again, the concordance can be computed: #+BEGIN_SRC R :results output :exports both :session *R* :cache yes concordanceTwinACE(bintwin,type="ae") #+END_SRC #+RESULTS[4ccb3ed37a1358c4f7a471e7bed08804648d6178]: #+begin_example $MZ Estimate Std.Err 2.5% 97.5% P-value concordance 0.0174 0.00143 0.0146 0.0202 5.00e-34 casewise concordance 0.4795 0.03272 0.4154 0.5437 1.20e-48 marginal 0.0362 0.00188 0.0325 0.0399 7.15e-83 $DZ Estimate Std.Err 2.5% 97.5% P-value concordance 0.00477 0.000393 0.0040 0.00554 5.94e-34 casewise concordance 0.13175 0.005417 0.1211 0.14237 1.14e-130 marginal 0.03620 0.001877 0.0325 0.03988 7.15e-83 #+end_example * COMMENT :PROPERTIES: :BEAMER_opt: shrink=85 :END: #+BEGIN_SRC R :results graphics :cache yes :file auto/remis-km-placebo.png :exports both :session *R* par(mfrow=c(2,2)) plot(survfit(Surv(time,event)~placebo,data=remis),col=c("red","blue")) legend("topright",legend=c("Treatment","Placebo"),col=c("red","blue"),lty=c(1,1)) plot(survfit(Surv(time,event)~placebo,data=remis),col=c("red","blue"),fun="cumhaz") legend("topright",legend=c("Treatment","Placebo"),col=c("red","blue"),lty=c(1,1)) plot(survfit(Surv(time,event)~placebo,data=remis),col=c("red","blue"),fun="cloglog") legend("topright",legend=c("Treatment","Placebo"),col=c("red","blue"),lty=c(1,1)) #+END_SRC #+RESULTS[b18ba18e9bad6516327104e8dd024ea654d17568]: [[file:auto/remis-km-placebo.png]] [[file:auto/remis-km-placebo.png]] mets/NEWS0000644000176200001440000001755713623061405011740 0ustar liggesusers#-*- mode: org -*- * Version 1.2.7 <2020-02-18 Tue> - Maintenance release * Version 1.2.6 <2019-08-02 Fri> - Cumulative incidence regression cifreg function - Fine-Gray model with cloglog link of (1-F_1(t,x)) - Logit link - Prototype of wildbootstrap for Cox regression with - confidence bands for baseline - with confidenence bands cumulative incidence for two cox's - Piecewise constant hazard: rpch, ppch - Test-version of multinomial regression model (via phreg): mlogit - Simulation for illness-death model: simMultistate - Haplotype modelling for discrete time-to-pregnancy models: haplo.surv.discrete - Interval censoring for discrete time logit-survival model: interval.logitsurv.discrete - Binomial Regression for competing risks data with censoring and one time point only: binreg * Version 1.2.5 <2018-11-18 Sun> - Updated predict function for phreg - with plotting functionality - with robust standard errors - New vignettes started - phreg robust se's for marginal Cox model - twostage survival model - multivariate competing risks - recurrent events - logitSurv for fitting semiparametric proportional odds model - gof - robust standard errors for clustered case - twostageMLE for fast twostage fitting for clustered survival data with robust standard errors. - standard errors for twostage models now also with uncertainty from Cox baseline - cumulative score process test gof now also for marginal Cox models * Version 1.2.4 <2018-05-18 Wed> - functions km (Kaplan-Meier) and cif (cumulative incidence probability) with robust standard errors. - computation of probability of exceeding "k" events for recurrents processs - computation of probability of exceeding "k1" and "k2" events for bivariate recurrents processseses - dspline simple spline decomposition on a data frame - rmvn, dmvn: RNG and density for multivariate normal distribution with varying correlation coefficients. * Version 1.2.3.1 <2018-04-18 Wed> - starting values updated for twinlm method * Version 1.2.3 <2018-02-02 Mon> - twinlm now supports ordinal outcomes - optimized strata calculations in phreg - optimized robust standard errors in phreg - weights and offsets in phreg - weights argument added to lifetable - gof of phreg with fast cumulative residuals (Lin, Wei, Ying) - graphical gof of phreg - recurrent events function for marginal mean with standard errors - simulating recurrent events with possibly two recurrent events and death - covariance calculation for recurrent events data and related bootstrap * Version 1.2.2 <2017-03-18 Sat> - Vignettes updated - Compatibility with lava version 1.5 * Version 1.2.1 <2017-02-25 Sat> - New documentation/vignettes - Additional examples and unit tests - lifecourse plot function: lifecourse - block sampling function: dsample * Version 1.2.0 <2017-02-03 Fri> - Namespace cleaning (twostage)... - Dependency on R>=3.3 radix algorithm - Case-Control sampling for twostage model. - Two-stage additive gamma survival model. Additive random effects for two-stage survival model via pairwise composite likelihood. Simulation of family ace survival model. Function for computing Kendall's tau for pairs with additive gamma random effects model via simulations. - Two-stage additive gamma binomial model. Additive random effects for binomial model via pairwise composite likelihood. Simulation of family ace model. Function for computing pairwise concordance for for pairs with additive gamma random effects model. - Updated divide.conquer - Extra unit tests - force.same.cens argument with IPWC methods - New utility functions for data.frames Data processing - dsort - dreshape - dcut - drm, drename, ddrop, dkeep, dsubset - drelevel - dlag - dfactor, dnumeric Data aggregation - dby, dby2 - dscalar, deval, daggregate - dmean, dsd, dsum, dquantile, dcor - dtable, dcount Data summaries - dhead, dtail, - dsummary, - dprint, dlist, dlevels, dunique * Version 1.1.1 <2015-05-27 Wed> - Support for left-truncation * Version 1.1.0 <2015-02-16 Mon> - fast.approx with 'type' argument - scoreMV - lifetable updated and new survpois function (piecewise constant hazard) * Version 1.0.0 <2014-11-18 Tue> - New functions biprobit.time, binomial.twostage.time. Automatically samples time points (approximately equidistant) up to last double jump time. Intial support for left truncation. contrast argument added to biprobit.time. - ipw removed (from namespace) - biprobit optimized for tabular data (non-continuous covariates). Regression design for dependence parameter (tetrachoric correlation) now possible. - predict method implemented for biprobit - arc-sinus transformation used for probability estimates - updated output of bptwin with relative recurrence risk + log-OR estimates - iid method for bptwin (influence function) - survival probabilities and start and end of intervals added to lifetable - new function 'jumptimes' for extracting jump times and possibly sample (equidistant) - fast.pattern updated to handle more than two categories - demos added to the mets package - divide.conquer function, folds function * Version 0.2.8 <2014-05-07 Wed> - Normal orthant probabilities via 'pmvn' (vectorized) - Parametric proportional hazards models via 'phreg.par' - twinlm.time function for censored twin data. Wraps the 'ipw' function that now also supports parametric survival models via phreg.par. 'grouptable' for tabulating twin-data. - Relative recurrence risk ratios now reported with bptwin/twinlm. - Grandom.cif more stable * Version 0.2.7 <2014-02-18 Tue> - Adapted to changes in 'timereg::comp.risk' - cluster.index with 'mat' argument for stacking rows of a matrix according to cluster-variable - New lava-estimator: 'normal', for ordinal data (cumulative probit) - fast.reshape more robust. Now also supports 'varying arguments of the type 'varying=-c(...)' choosing everything except '...'. * Version 0.2.6 <2013-12-07 Sat> - C++ source code cleanup - Optimization of fast.reshape * Version 0.2.5 <2013-11-01 Fri> - New datasets: dermalridges, dermalridgesMZ - Grouped analysis updated in twinlm (e.g. sex limitation model) - Confidence limits for genetic and environmental effects are now based on standard (symmetric) Wald confidence limits. (use the 'transform' argument of the summary method to apply logit-transform) - Improved output in twinlm * Version 0.2.4 <2013-07-10 Wed> - fast.reshape :labelnum option for both wide and long format (see example) - Compilation flags removed from Makevars files * Version 0.2.3 <2013-05-22 Wed> - fast.reshape bug-fix (column names) * Version 0.2.2 <2013-05-21 Tue> - Updated twinlm. bptwin: OS analysis - Better starting values for twinlm - Fixed claytonaokes.cpp - New fast cox ph regression: phreg - Updated two-stage estimator - Improved fast.reshape * Version 0.2.0 <2013-03-27 Wed> - fast.reshape - easy.binomial.twostage * Version 0.1.4 <2012-09-07 Fri> - Fixed cor.cpp - New datasets: twinstut, twinbmi, prtsim * Version 0.1.3 <2012-07-05 Thu> - twinlm moved to mets package, and wraps the bptwin function * Version 0.1.2 <2012-05-14 Mon> - code clean-up and minor bug-fixes * Version 0.1.1 <2012-05-06 Sun> - Random effects CIF models moved from MultiComp to mets - new data sets: np, multcif - Documentation via roxygen2 - bug fixes * Version 0.1.0 <2012-04-25 Wed> - Initialization of the new package 'mets' with implementation of the Clayton-Oakes model with piecewise constant marginal hazards, and the bivariate probit random effects model (Liability model) for twin-data. mets/R/0000755000176200001440000000000013623061405011423 5ustar liggesusersmets/R/lifecourse.R0000644000176200001440000002343013623061405013710 0ustar liggesusers##' Life-course plot for event life data with recurrent events ##' ##' @title Life-course plot ##' @param formula Formula (Event(start,slut,status) ~ ...) ##' @param data data.frame ##' @param id Id variable ##' @param group group variable ##' @param type Type (line 'l', stair 's', ...) ##' @param lty Line type ##' @param col Colour ##' @param alpha transparency (0-1) ##' @param lwd Line width ##' @param recurrent.col col of recurrence type ##' @param recurrent.lty lty's of of recurrence type ##' @param legend position of optional id legend ##' @param pchlegend point type legends ##' @param by make separate plot for each level in 'by' (formula, name of column, or vector) ##' @param status.legend Status legend ##' @param place.sl Placement of status legend ##' @param xlab Label of X-axis ##' @param ylab Label of Y-axis ##' @param add Add to existing device ##' @param ... Additional arguments to lower level arguments ##' @author Thomas Scheike, Klaus K. Holst ##' @export ##' @examples ##' data = data.frame(id=c(1,1,1,2,2),start=c(0,1,2,3,4),slut=c(1,2,4,4,7), ##' type=c(1,2,3,2,3),status=c(0,1,2,1,2),group=c(1,1,1,2,2)) ##' ll = lifecourse(Event(start,slut,status)~id,data,id="id") ##' ll = lifecourse(Event(start,slut,status)~id,data,id="id",recurrent.col="type") ##' ##' ll = lifecourse(Event(start,slut,status)~id,data,id="id",group=~group,col=1:2) ##' op <- par(mfrow=c(1,2)) ##' ll = lifecourse(Event(start,slut,status)~id,data,id="id",by=~group) ##' par(op) ##' legends=c("censored","pregnant","married") ##' ll = lifecourse(Event(start,slut,status)~id,data,id="id",group=~group,col=1:2,status.legend=legends) ##' lifecourse <- function(formula,data,id="id",group=NULL, type="l",lty=1,col=1:10,alpha=0.3,lwd=1, recurrent.col=NULL, recurrent.lty=NULL, legend=NULL,pchlegend=NULL, by=NULL, status.legend=NULL,place.sl="bottomright", xlab="Time",ylab="",add=FALSE,...) {# {{{ if (!is.null(by)) { if (is.character(by) && length(by==1)) { by <- data[,by] } else if (inherits(by,"formula")) { by <- model.frame(by,data,na.action=na.pass) } cl <- match.call(expand.dots=TRUE) cl$by <- NULL datasets <- split(data,by) res <- c() for (d in datasets) { cl$data <- d res <- c(res, eval(cl,parent.frame())) } return(invisible(res)) } if (!is.null(group)) { if (is.character(group) && length(group==1)) { M <- data[,group] } else if (inherits(group,"formula")) { M <- model.frame(group,data,na.action=na.pass) } else { M <- group } ### if (!add) plot(formula,data=data,xlab=xlab,ylab=ylab,...,type="n") if (!add) { if (inherits(id,"formula")) id <- all.vars(id) if (inherits(group,"formula")) group <- all.vars(group) if (is.character(id) && length(id)==1) Id <- y <- getoutcome(formula) x <- attributes(y)$x if (length(x)==0) {# {{{ y <- response <- all.vars( update(formula,.~+1)) ### ccid <- cluster.index(data[,id]) ccm <- ccid$idclustmat+1 ccm <- ccm[!is.na(ccm)] ### x <- data[ccm,id] if (length(response)==3) { t1 <- data[ccm,response[1]] t2 <- data[ccm,response[2]] tstat <- data[ccm,response[3]] } else { t1 <- rep(0,length(ccm)) t2 <- data[ccm,response[1]] tstat <- data[ccm,response[2]] } X <- c(c(t1),c(t2)) Y <- rep(x,each=2) status <- tstat # }}} } else {# {{{ y <- response <- all.vars( update(formula,.~+1)) ### ccid <- cluster.index(data[,id]) ccm <- ccid$idclustmat+1 ccm <- ccm[!is.na(ccm)] if (length(response)==3) { t1 <- data[ccm,response[1]] t2 <- data[ccm,response[2]] tstat <- data[ccm,response[3]] } else { t1 <- rep(0,length(ccm)) t2 <- data[ccm,response[1]] tstat <- data[ccm,response[2]] } x <- data[ccm,x] X <- c(c(t1),c(t2)) Y <- rep(x,each=2) status <- tstat }# }}} plot(X,Y,xlab=xlab,ylab=ylab,...,type="n") if (!is.null(status.legend)) {# {{{ if (is.null(pchlegend)) { if (length(status.legend)!=length(unique(status))) { warning("Not all legends represented, legends could be wrong give pchlegend\n"); print(cbind(status.legend,sort(unique(status)))) } points(t2,x,pch=status) graphics::legend(place.sl,legend=status.legend,pch=sort(unique(status))) } else { points(t2,x,pch=pchlegend[status]) graphics::legend(place.sl,legend=status.legend,pch=pchlegend) } }# }}} } dd <- split(data,M) K <- length(dd) if (length(type)1) { fit <- lapply(seq_len(length(dd)),function(i) { if (messages>0) message("Strata '",names(dd)[i],"'") idx <- which(fac==names(dd)[i]) mycall$se.clusters <- lse.clusters[idx] mycall$formula <- formula mycall$data <- dd[[i]] eval(mycall) }) res <- list(model=fit) res$strata <- names(res$model) <- names(dd) class(res) <- c("bicomprisk.strata","twinlm.strata") res$N <- length(dd) return(res) } } covars <- as.character(attributes(terms(formula))$variables)[-(1:2)] ### adds weights, if (!is.null(wname)) covars <- c(covars,wname) indiv2 <- covars2 <- NULL data <- data[order(data[,id]),] idtab <- table(data[,id]) ##which(data[,id]%in%names(idtab==2)) data <- data[which(data[,id]%in%names(idtab==2)),] if (missing(num)) { idtab <- table(data[,id]) num <- "num" while (num%in%names(data)) num <- paste(num,"_",sep="") data[,num] <- unlist(lapply(idtab,seq_len)) } oldreshape <- 0 if (oldreshape==1) sep="." else sep="" timevar2 <- paste(timevar,1:2,sep=sep) causes2 <- paste(causes,1:2,sep=sep) if (length(covars)>0) covars2 <- paste(covars,1,sep=sep) for (i in seq_len(length(indiv))) indiv2 <- c(indiv2, paste(indiv[i],1:2,sep=sep)) if (oldreshape==1) ww0 <- reshape(data[,c(timevar,causes,covars,indiv,id,num,"lse.clusters")], direction="wide",idvar=id,timevar=num)[,c(id,"lse.clusters.1",timevar2,causes2,indiv2,covars2)] else ww0 <- fast.reshape(data[,c(timevar,causes,covars,indiv,id,num,"lse.clusters")],id=id,num=data$num,labelnum=TRUE)[,c(id,"lse.clusters1",timevar2,causes2,indiv2,covars2)] ww0 <- na.omit(ww0) status <- rep(0,nrow(ww0)) time <- ww0[,timevar2[1]] ## {{{ (i,j) causes idx2 <- which(ww0[,causes2[1]]==cause[1] & ww0[,causes2[2]]==cause[2]) if (length(idx2)>0) { status[idx2] <- 1 time[idx2] <- apply(ww0[idx2,timevar2[1:2],drop=FALSE],1,max) } ##(0,0), (0,j) idx2 <- which(ww0[,causes2[1]]==cens & (ww0[,causes2[2]]==cens | ww0[,causes2[2]]==cause[2])) if (length(idx2)>0) { status[idx2] <- 0 time[idx2] <- ww0[idx2,timevar2[1]] } ##(ic,0), (ic,j) idx2 <- which(ww0[,causes2[1]]!=cens & ww0[,causes2[1]]!=cause[1] & (ww0[,causes2[2]]==cens | ww0[,causes2[2]]==cause[2])) if (length(idx2)>0) { status[idx2] <- 2 time[idx2] <- ww0[idx2,timevar2[1]] } ##(i,0) idx2 <- which(ww0[,causes2[1]]==cause[1] & ww0[,causes2[2]]==cens) if (length(idx2)>0) { status[idx2] <- 0 time[idx2] <- ww0[idx2,timevar2[2]] } ##(ic,jc) idx2 <- which(ww0[,causes2[1]]!=cens & ww0[,causes2[1]]!=cause[1] & (ww0[,causes2[2]]!=cens & ww0[,causes2[2]]!=cause[2])) if (length(idx2)>0) { status[idx2] <- 2 time[idx2] <- apply(ww0[idx2,timevar2[1:2],drop=FALSE],1,min) } ##(0,jc),(i,jc) idx2 <- which((ww0[,causes2[1]]==cens | ww0[,causes2[1]]==cause[1]) & (ww0[,causes2[2]]!=cens & ww0[,causes2[2]]!=cause[2])) if (length(idx2)>0) { status[idx2] <- 2 time[idx2] <- ww0[idx2,timevar2[2]] } mydata0 <- mydata <- data.frame(time,status,ww0[,covars2],ww0[,indiv2]) names(mydata) <- c(timevar,causes,covars,indiv2) ## }}} if (return.data==2) return(list(data=mydata)) else { if (!prodlim) { ff <- paste("Event(",timevar,",",causes,",cens.code=",cens,") ~ 1",sep="") if (!is.null(wname)) covars <- covars[-which(covars %in% c(wname))] if (length(c(covars,indiv))>0) { xx <- c(covars,indiv2) for (i in seq_len(length(xx))) xx[i] <- paste("const(",xx[i],")",sep="") ff <- paste(c(ff,xx),collapse="+") if (missing(model)) model <- "fg" } if (missing(model)) model <- "fg" ### clusters for iid construction lse.clusters <- NULL if (!is.null(se.clusters.call)) { lse.clusters <- ww0[,"lse.clusters1"] } ### if (!(is.null(wname))) mydata <- ipw2(mydata,time=timevar,cause=causes) #,cens.code=cens) if (is.null(wname)) { add<-comp.risk(as.formula(ff),data=mydata, cause=1,n.sim=0,resample.iid=resample.iid,model=model,conservative=conservative, clusters=lse.clusters, max.clust=max.clust,...) } else { add<-comp.risk(as.formula(ff),data=mydata, cause=1,n.sim=0,resample.iid=resample.iid,model=model,conservative=conservative, clusters=lse.clusters, max.clust=max.clust, weights=mydata[,wname]*mydata$indi.weights,cens.weights=rep(1,nrow(mydata)),...) } padd <- predict(add,X=1,se=1,uniform=uniform,resample.iid=resample.iid) padd$cluster.names <- lse.clusters } else { if (!requireNamespace("prodlim",quietly=TRUE)) stop("prodlim requested but not installed") ff <- as.formula(paste("Hist(",timevar,",",causes,")~",paste(c("1",covars,indiv2),collapse="+"))) padd <- prodlim::prodlim(ff,data=mydata) } ### class(padd) <- c("bicomprisk",class(padd)) if (return.data==1) return(list(comp.risk=padd,data=mydata)) else return(padd) } ## }}} } ## plot.bicomprisk <- function(x,add=FALSE,...) { ## if ("predict.timereg"%in%class(a)) { ## if (!add) { plot.predict.timereg(x,...) } ## else { ## with(x,lines(time,P1,...)) ## } ## } else { ## plot(x,...) ## } ## return(invisible(x)) ##} mets/R/plot.bptwin.R0000644000176200001440000000217413623061405014032 0ustar liggesuserstrMean <- function(b,blen) { ## mytr <- function(x) x^2; dmytr <- function(x) 2*x mytr <- dmytr <- exp if (blen==0) return(b) k <- length(b) Bidx <- seq_len(blen)+(k-blen) b[Bidx[1]] <- mytr(b[Bidx[1]]) D <- diag(nrow=k) D[Bidx[1]:k,Bidx[1]] <- b[Bidx[1]] for (i in Bidx[-1]) { D[i:k,i] <- dmytr(b[i]) b[i] <- b[i-1]+mytr(b[i]) } attributes(b)$D <- D attributes(b)$idx <- Bidx return(b) } ##' @export plot.bptwin <- function(x,n=50,rg=range(x$B[,1]),xlab="Time",ylab="Concordance",...) { if (x$Blen>0) { ## rg <- range(x$B[,1]) t <- seq(rg[1],rg[2],length.out=n) B0 <- bs(t,degree=x$Blen) b0. <- coef(x)[x$midx0] b1. <- coef(x)[x$midx1] b0 <- trMean(b0.,x$Blen) b1 <- trMean(b1.,x$Blen) b00 <- tail(b0,x$Blen) b11 <- tail(b1,x$Blen) pr0 <- sapply(as.numeric(B0%*%b00+b0[1]), function(z) pbvn(upper=rep(z,2),sigma=x$Sigma0)) pr1 <- sapply(as.numeric(B0%*%b11+b1[1]), function(z) pbvn(upper=rep(z,2),sigma=x$Sigma1)) plot(pr0~t,type="l", xlab=xlab, ylab=ylab,...) lines(pr1~t,type="l",lty=2) } return(invisible(x)) } mets/R/sim.clayton.oakes.R0000644000176200001440000005562413623061405015123 0ustar liggesusers##' Simulate observations from the Clayton-Oakes copula model with ##' piecewise constant marginals. ##' ##' @title Simulate from the Clayton-Oakes frailty model ##' @param K Number of clusters ##' @param n Number of observations in each cluster ##' @param eta variance ##' @param beta Effect (log hazard ratio) of covariate ##' @param stoptime Stopping time ##' @param lam constant hazard ##' @param left Left truncation ##' @param pairleft pairwise (1) left truncation or individual (0) ##' @param trunc.prob Truncation probability ##' @param same if 1 then left-truncation is same also for univariate truncation ##' @author Thomas Scheike and Klaus K. Holst ##' @aliases simClaytonOakes simClaytonOakesLam ##' @export simClaytonOakes <- function(K,n,eta,beta,stoptime,lam=1,left=0,pairleft=0,trunc.prob=0.5,same=0) ## {{{ { ## K antal clustre, n=antal i clustre ### K <- 100; n=2; stoptime=2; eta=1/2; beta=0; lam=0.5;left=0.5; trunc.prob=0.5; pairleft=0; same=0 ### change such that eta is variance ### eta <- 1/eta x<-array(c(runif(n*K),rep(0,n*K),rbinom(n*K,1,0.5)),dim=c(K,n,3)) C<-matrix(stoptime,K,n); Gam1 <-matrix(rgamma(K,eta)/eta,K,n) temp<-eta*log(-log(1-x[,,1])/(eta*Gam1*lam)+1)*exp(-beta*x[,,3]) x[,,2]<-ifelse(temp<=C,1,0); x[,,1]<-pmin(temp,C) minstime <- apply(x[,,1],1,min) ud <- as.data.frame(cbind(apply(x,3,t),rep(1:K,each=n))) if (left>0) { if (pairleft==1) { lefttime <- runif(K)*(stoptime-left) left <- rbinom(K,1,trunc.prob) ## not trunation times! lefttime <- apply(cbind(lefttime*left,3),1,min) trunk <- (lefttime > minstime) medleft <- rep(trunk,each=n) } else { if (same==0) lefttime <- rexp(n*K)*left if (same==1) lefttime <- rep(rexp(K)*left,each=n) ### lefttime <- runif(K)*(stoptime-left) if (same==0) left <- rbinom(n*K,1,trunc.prob) ## not trunation times! if (same==1) left <- rep(rbinom(K,1,trunc.prob),each=n) lefttime <- lefttime*left trunk <- ud[,1] > lefttime medleft <- trunk } } else { lefttime <- trunk <- rep(0,K);} if (pairleft==1) ud <- cbind(ud,rep(minstime,each=n),rep(lefttime,each=n),rep(trunk,each=n)) else ud <- cbind(ud,rep(minstime,each=n),lefttime,trunk) ### if (left>0) { ### lefttime <- rexp(K)*left ### left <- rbinom(K,1,0.5) ## not trunation times! ### lefttime <- apply(cbind(lefttime*left,3),1,min) ### trunk <- (lefttime > minstime) ### medleft <- rep(trunk,each=n) ### } else { lefttime <- trunk <- rep(0,K);} ### ### ud <- cbind(ud,rep(minstime,each=n),rep(lefttime,each=n),rep(trunk,each=n)) names(ud)<-c("time","status","x","cluster","mintime","lefttime","truncated") return(ud) } ## }}} ##' @export simClaytonOakesLam <- function(n,k,cumhaz,vargam,entry=NULL) { ## {{{ base1 <- cumhaz dtt <- diff(c(0,base1[,1])) lams <- (diff(c(0,base1[,2]))/dtt)*exp(vargam*base1[,2]) Lams <- cbind(base1[,1],cumsum(dtt*lams)) if (is.null(entry)) entry <- rep(0,n*k) gamma <- rep(rgamma(n,1/vargam)*vargam,each=k) ddd <- pc.hazard(rbind(c(0,0),Lams),rr=gamma,entry=entry) ddd$cluster <- rep(1:n,each=k) ddd$gamma <- gamma attr(ddd,"cumhaz") <- Lams return(ddd) } ## }}} ##' Simulate observations from the Clayton-Oakes copula model with ##' Weibull type baseline and Cox marginals. ##' ##' @title Simulate from the Clayton-Oakes frailty model ##' @param K Number of clusters ##' @param n Number of observations in each cluster ##' @param eta 1/variance ##' @param beta Effect (log hazard ratio) of covariate ##' @param stoptime Stopping time ##' @param weiscale weibull scale parameter ##' @param weishape weibull shape parameter ##' @param left Left truncation ##' @param pairleft pairwise (1) left truncation or individual (0) ##' @author Klaus K. Holst ##' @export simClaytonOakesWei <- function(K,n,eta,beta,stoptime,weiscale=1,weishape=2,left=0,pairleft=0) { ## {{{ ###cat(" not quite \n"); ## K antal clustre, n=antal i clustre ### K=10; n=2; eta=1; beta=0.3; stoptime=3; lam=0.5; ### weigamma=2; left=0; pairleft=0 X <- rbinom(n*K,1,0.5) C<-rep(stoptime,n*K); Gam1 <-rep(rgamma(K,eta),each=n) temp <- rexp(K*n) ### temp <- rweibull(n*K,weishape,scale=weiscale)/(exp(X*beta)*Gam1) temp<- (eta*log(eta*temp/(eta*Gam1)+1)/(exp(beta*X)*weiscale^weishape))^{1/weishape} status<- ifelse(temp<=C,1,0); temp <- pmin(temp,C) xt <- matrix(temp,n,K) minstime <- apply(xt,2,min) id=rep(1:K,each=n) ud <- cbind(temp,status,X,id) if (left>0) { if (pairleft==1) { lefttime <- runif(K)*(stoptime-left) left <- rbinom(K,1,0.5) ## not trunation times! lefttime <- apply(cbind(lefttime*left,3),1,min) trunk <- (lefttime > minstime) medleft <- rep(trunk,each=n) } else { ### lefttime <- rexp(n*K)*left lefttime <- runif(K)*(stoptime-left) left <- rbinom(n*K,1,0.5) ## not trunation times! lefttime <- apply(cbind(lefttime*left,3),1,min) trunk <- (lefttime > ud[,1]) medleft <- trunk } } else { lefttime <- trunk <- rep(0,K);} if (pairleft==1) ud <- cbind(ud,rep(minstime,each=n),rep(lefttime,each=n),rep(trunk,each=n)) else ud <- cbind(ud,rep(minstime,each=n),lefttime,trunk) colnames(ud)<-c("time","status","x","cluster","mintime","lefttime","truncated") ud <- data.frame(ud) return(ud) } ## }}} ##' @export simClaytonOakes.twin.ace <- function(K,varg,varc,beta,stoptime,Cvar=0,left=0,pairleft=0,trunc.prob=0.5,lam0=1) ## {{{ { ## K antal clustre, n=antal i clustre n <- 2 # twins with ace structure #change parametrization sumpar <- sum(varg+varc) varg <- varg/sumpar^2; varc <- varc/sumpar^2 x<-array(c(runif(n*K),rep(0,n*K),rbinom(n*K,1,0.5)),dim=c(K,n,3)) if (Cvar==0) C<-matrix(stoptime,K,n) else C<-matrix(Cvar*runif(K*n)*stoptime,K,n) ### total variance of gene and env. ### random effects with ### means varg/(varg+varc) and variances varg/(varg+varc)^2 etao <- eta <- varc+varg if (etao==0) eta <- 1 Gams1 <-cbind( rgamma(K,varg)/eta, rgamma(K,varg*0.5)/eta, rgamma(K,varg*0.5)/eta, rgamma(K,varg*0.5)/eta, rgamma(K,varc)/eta ) ### print(apply(Gams1,2,mean)); print(apply(Gams1,2,var)) mz <- c(rep(1,K/2),rep(0,K/2)); dz <- 1-mz; mzrv <- Gams1[,1]+Gams1[,5] ### shared gene + env dzrv1 <- Gams1[,2]+Gams1[,3]+Gams1[,5] ### 0.5 shared gene + 0.5 non-shared + env dzrv2 <- Gams1[,2]+Gams1[,4]+Gams1[,5] ### 0.5 shared gene + 0.5 non-shared + env Gam1 <- cbind(mz*mzrv+dz*dzrv1,mz*mzrv+dz*dzrv2) ### print(apply(Gam1,2,mean)); print(apply(Gam1,2,var)) Gam1[Gam1==0] <- 1 ## to work also under independence ### print(mean(mzrv)); print(mean(dzrv1)); print(mean(dzrv2)); ### print(var(mzrv)); print(var(dzrv1)); print(var(dzrv2)); temp<-eta*log(-log(1-x[,,1])/(eta*Gam1)+1)*exp(-beta*x[,,3])/lam0 if (etao==0) temp <- matrix(rexp(n*K),K,n)*exp(-beta*x[,,3])/lam0 x[,,2]<-ifelse(temp<=C,1,0); x[,,1]<-pmin(temp,C) minstime <- apply(x[,,1],1,min) ud <- as.data.frame(cbind(apply(x,3,t),rep(1:K,each=n))) zyg <- c(rep("MZ",K),rep("DZ",K)) if (left>0) { ## {{{ if (pairleft==1) { lefttime <- runif(K)*(stoptime-left) left <- rbinom(K,1,trunc.prob) ## not trunation times! lefttime <- apply(cbind(lefttime*left,3),1,min) trunk <- (lefttime > minstime) medleft <- rep(trunk,each=n) } else { ### lefttime <- rexp(n*K)*left lefttime <- runif(K)*(stoptime-left) left <- rbinom(n*K,1,trunc.prob) ## not trunation times! lefttime <- apply(cbind(lefttime*left,3),1,min) trunk <- (lefttime > ud[,1]) medleft <- trunk } } else { lefttime <- trunk <- rep(0,K);} ## }}} if (pairleft==1) ud <- cbind(ud,zyg,rep(minstime,each=n),rep(lefttime,each=n),rep(trunk,each=n)) else ud <- cbind(ud,zyg,rep(minstime,each=n),lefttime,trunk) names(ud)<-c("time","status","x","cluster","zyg","mintime","lefttime","truncated") return(ud) } ## }}} ##' @export simClaytonOakes.family.ace <- function(K,varg,varc,beta,stoptime,lam0=0.5,Cvar=0,left=0,pairleft=0,trunc.prob=0.5) ## {{{ { ## K antal clustre (families), n=antal i clustre n <- 4 # twins with ace structure x<- array(c(runif(n*K),rep(0,n*K),rbinom(n*K,1,0.5)),dim=c(K,n,3)) if (Cvar==0) C<-matrix(stoptime,K,n) else C<-matrix(Cvar*runif(K*n)*stoptime,K,n) sumpar <- sum(varg+varc) varg <- varg/sumpar^2; varc <- varc/sumpar^2 ### total variance of gene and env. ### random effects with ### means varg/(varg+varc) and variances varg/(varg+varc)^2 eta <- varc+varg ### mother and father share environment ### children share half the genes with mother and father and environment mother.g <- cbind(rgamma(K,varg*0.25)/eta, rgamma(K,varg*0.25)/eta, rgamma(K,varg*0.25)/eta, rgamma(K,varg*0.25)/eta) father.g <- cbind(rgamma(K,varg*0.25)/eta, rgamma(K,varg*0.25)/eta, rgamma(K,varg*0.25)/eta, rgamma(K,varg*0.25)/eta) env <- rgamma(K,varc)/eta mother <- apply(mother.g,1,sum)+env father <- apply(father.g,1,sum)+env child1 <- apply(cbind(mother.g[,c(1,2)],father.g[,c(1,2)]),1,sum) + env child2 <- apply(cbind(mother.g[,c(1,3)],father.g[,c(1,3)]),1,sum) + env Gam1 <- cbind(mother,father,child1,child2) ### print(apply(Gam1,2,mean)); print(apply(Gam1,2,var)) temp<-eta*log(-log(1-x[,,1])/(eta*Gam1)+1)*exp(-beta*x[,,3])/lam0 x[,,2]<-ifelse(temp<=C,1,0); x[,,1]<-pmin(temp,C) minstime <- apply(x[,,1],1,min) ud <- as.data.frame(cbind(apply(x,3,t),rep(1:K,each=n))) type <- rep(c("mother","father","child","child"),K) if (left>0) { ## {{{ if (pairleft==1) { lefttime <- runif(K)*(stoptime-left) left <- rbinom(K,1,trunc.prob) ## not trunation times! lefttime <- apply(cbind(lefttime*left,3),1,min) trunk <- (lefttime > minstime) medleft <- rep(trunk,each=n) } else { ### lefttime <- rexp(n*K)*left lefttime <- runif(K)*(stoptime-left) left <- rbinom(n*K,1,trunc.prob) ## not trunation times! lefttime <- apply(cbind(lefttime*left,3),1,min) trunk <- (lefttime > ud[,1]) medleft <- trunk } } else { lefttime <- trunk <- rep(0,K);} ## }}} if (pairleft==1) ud <- cbind(ud,type,rep(minstime,each=n),rep(lefttime,each=n),rep(trunk,each=n)) else ud <- cbind(ud,type,rep(minstime,each=n),lefttime,trunk) names(ud)<-c("time","status","x","cluster","type","mintime","lefttime","truncated") return(ud) } ## }}} ##' @export simCompete.twin.ace <- function(K,varg,varc,beta,stoptime,lam0=c(0.2,0.3), Cvar=0,left=0,pairleft=0,trunc.prob=0.5,overall=1,all.sum=1) ## {{{ { ## K antal clustre, n=antal i clustre n=2 # twins with ace structure sumpar <- sum(varg+varc) varg <- varg/sumpar^2; varc <- varc/sumpar^2 ## length(lam0) competing risk with constant hazards lam0 x<-array(c(runif(n*K),rep(0,n*K),rbinom(n*K,1,0.5)),dim=c(K,n,3)) if (Cvar==0) C<-matrix(stoptime,K,n) else C<-matrix(Cvar*runif(K*n)*stoptime,K,n) ### total variance of gene and env. ### one for each cause and one shared (across causes) ### random effects with ### means varg/(varg+varc) and variances varg/(varg+varc)^2 if (length(varc)==1) varc <- rep(varc,length(lam0)+overall) if (length(varg)==1) varg <- rep(varg,length(lam0)+overall) eta <- varc+varg etat <- sum(eta) ### total variance for each cause + overall nc <- length(lam0); ### etat <- sum(eta[1:nc]) ### print(etat) ### print(varc) ### print(varg) ### print("MZ shared variance"); print(eta[1]/eta[1]^2); ### print("DZ shared variance"); ### print(c(mdz,vdz,vdz/mdz^2)); mz <- c(rep(1,K/2),rep(0,K/2)); dz <- 1-mz; ### ace overall if (overall==1) { varcl <- varc[nc+1]; vargl <- varg[nc+1] if (all.sum==1) etal <- etat else etal <- vargl+varcl Gams1 <-cbind( rgamma(K,vargl)/etal, rgamma(K,vargl*0.5)/etal, rgamma(K,vargl*0.5)/etal, rgamma(K,vargl*0.5)/etal, rgamma(K,varcl)/etal ) ### ex1 <- Gams1[,6] ### ex2 <- Gams1[,7] mzrv <- Gams1[,1]+ Gams1[,5] ### shared gene + env dzrv1 <- Gams1[,2]+Gams1[,3]+Gams1[,5] dzrv2 <- Gams1[,2]+Gams1[,4]+Gams1[,5] Gamoa <- cbind(mz*mzrv+dz*dzrv1,mz*mzrv+dz*dzrv2) } else Gamoa <- 0 temp1 <- matrix(0,K,length(lam0)) temp2 <- matrix(0,K,length(lam0)) Gamm <- c() for (i in 1:nc) { varcl <- varc[i]; vargl <- varg[i] if (all.sum==1) etal <- etat else etal <- vargl+varcl Gams1 <-cbind( rgamma(K,vargl)/etal, rgamma(K,vargl*0.5)/etal, rgamma(K,vargl*0.5)/etal, rgamma(K,vargl*0.5)/etal, rgamma(K,varcl)/etal ) ### mzrv <- Gams1[,1]+Gams1[,5] ### shared gene + env dzrv1 <- Gams1[,2]+Gams1[,3]+Gams1[,5] dzrv2 <- Gams1[,2]+Gams1[,4]+Gams1[,5] Gam1 <- cbind(mz*mzrv+dz*dzrv1,mz*mzrv+dz*dzrv2) Gam1 <- Gam1+Gamoa Gamm <- cbind(Gamm,Gam1) ### ## {{{ ### mean(mzrv) ### var(mzrv) ### var(mzrv[mz==1]) ### mean(dzrv1) ### mean(dzrv2) ### var(dzrv1) ### var(dzrv2) ### apply(Gam1,2,mean); apply(Gam1,2,var) ### apply(Gam1[mz==1,],2,mean); apply(Gam1[mz==0,],2,mean) ### var(Gam1[mz==1,]); var(Gam1[mz==0,]) ### shdz <- Gams1[,2]+Gams1[,5] ### mean(shdz) ### ###1.25/etat ### var(shdz) ### mean(shdz/0.83) ### var(shdz/0.83) ### ## }}} ttemp<-matrix(rexp(2*K),K,2)/(Gam1*exp(beta*x[,,3])*lam0[i]) temp1[,i] <- ttemp[,1] temp2[,i] <- ttemp[,2] } ### print(cov(Gamm)) ### temp0 <- cbind( temp1, temp2) ### print(cov(temp0)) temp <- cbind( apply(temp1,1,min), apply(temp2,1,min)) cause1 <- apply(temp1,1,which.min) cause2 <- apply(temp2,1,which.min) ### for (zyg in c(0,1)) ### for (i in 1:2) for (j in 1:2) { ### med <- (i==cause1) & (j==cause2) & mz==zyg ### datl <- temp[med,] ### dato <- temp0[med,] ### print(c(zyg,i,j)) ### print(cor(datl)) ### print(c(zyg,i,j)) ### print(cor(dato)) ### } ### x[,,2]<- ifelse(temp<=C,1,0)*cbind(cause1,cause2); x[,,1]<-pmin(temp,C) minstime <- apply(x[,,1],1,min) ud <- as.data.frame(cbind(apply(x,3,t),rep(1:K,each=n))) zyg <- c(rep("MZ",K),rep("DZ",K)) if (left>0) { ## {{{ if (pairleft==1) { lefttime <- runif(K)*(stoptime-left) left <- rbinom(K,1,trunc.prob) ## not trunation times! lefttime <- apply(cbind(lefttime*left,3),1,min) trunk <- (lefttime > minstime) medleft <- rep(trunk,each=n) } else { ### lefttime <- rexp(n*K)*left lefttime <- runif(K)*(stoptime-left) left <- rbinom(n*K,1,trunc.prob) ## not trunation times! lefttime <- apply(cbind(lefttime*left,3),1,min) trunk <- (lefttime > ud[,1]) medleft <- trunk } } else { lefttime <- trunk <- rep(0,K);} ## }}} if (pairleft==1) ud <- cbind(ud,zyg,rep(minstime,each=n),rep(lefttime,each=n),rep(trunk,each=n)) else ud <- cbind(ud,zyg,rep(minstime,each=n),lefttime,trunk) names(ud)<-c("time","status","x","cluster","zyg","mintime","lefttime","truncated") return(ud) } ## }}} ##' @export simCompete.simple <- function(K,varr,beta,stoptime,lam0=c(0.2,0.3), Cvar=0,left=0,pairleft=0,trunc.prob=0.5,overall=1,all.sum=1) ## {{{ { ## K antal clustre, n=antal i clustre n=2 # twins with ace structure ## length(lam0) competing risk with constant hazards lam0 x<-array(c(runif(n*K),rep(0,n*K),rbinom(n*K,1,0.5)),dim=c(K,n,3)) if (Cvar==0) C<-matrix(stoptime,K,n) else C<-matrix(Cvar*runif(K*n)*stoptime,K,n) ## variance and mean of additve gamma via paramenters sp <- sum(varr) partheta <- varr/sp^2 eta <- partheta etat <- sum(eta) ### total variance for each cause + overall nc <- length(lam0); print(eta) print(etat) mz <- c(rep(1,K/2),rep(0,K/2)); dz <- 1-mz; ### ace overall if (overall==1) { ### if (all.sum==1) etal <- etat else etal <- vargl+varcl etal <- etat Gams1 <-cbind(rgamma(K,eta[nc+1])/etal) Gamoa <- Gams1 } else Gamoa <- 0 ### print(apply(Gamoa,2,mean)) ### print(apply(Gamoa,2,var)) temp1 <- matrix(0,K,length(lam0)) temp2 <- matrix(0,K,length(lam0)) for (i in 1:nc) { etal <- etat Gams1 <-cbind(rgamma(K,eta[i])/etal) Gam1 <- Gams1+Gamoa Gam1 <- cbind(Gam1,Gam1) ### print("_________________") ### print(apply(Gam1,2,mean)) ### print(apply(Gam1,2,var)) occ <- (1:nc)[-i] for (j in occ) { print(eta[j]) Gamo <- cbind(rgamma(K,eta[j])/etal,rgamma(K,eta[j])/etal) ### print(apply(Gamo,2,mean)) ### print(apply(Gamo,2,var)) Gam1 <- Gam1+Gamo } print(apply(Gam1,2,mean)) print(apply(Gam1,2,var)) ttemp<-matrix(rexp(2*K),K,2)/(Gam1*exp(beta*x[,,3])*lam0[i]) temp1[,i] <- ttemp[,1] temp2[,i] <- ttemp[,2] } temp <- cbind( apply(temp1,1,min), apply(temp2,1,min)) cause1 <- apply(temp1,1,which.min) cause2 <- apply(temp2,1,which.min) ### x[,,2]<- ifelse(temp<=C,1,0)*cbind(cause1,cause2); x[,,1]<-pmin(temp,C) minstime <- apply(x[,,1],1,min) ud <- as.data.frame(cbind(apply(x,3,t),rep(1:K,each=n))) zyg <- c(rep("MZ",K),rep("DZ",K)) if (left>0) { ## {{{ if (pairleft==1) { lefttime <- runif(K)*(stoptime-left) left <- rbinom(K,1,trunc.prob) ## not trunation times! lefttime <- apply(cbind(lefttime*left,3),1,min) trunk <- (lefttime > minstime) medleft <- rep(trunk,each=n) } else { ### lefttime <- rexp(n*K)*left lefttime <- runif(K)*(stoptime-left) left <- rbinom(n*K,1,trunc.prob) ## not trunation times! lefttime <- apply(cbind(lefttime*left,3),1,min) trunk <- (lefttime > ud[,1]) medleft <- trunk } } else { lefttime <- trunk <- rep(0,K);} ## }}} if (pairleft==1) ud <- cbind(ud,zyg,rep(minstime,each=n),rep(lefttime,each=n),rep(trunk,each=n)) else ud <- cbind(ud,zyg,rep(minstime,each=n),lefttime,trunk) names(ud)<-c("time","status","x","cluster","zyg","mintime","lefttime","truncated") return(ud) } ## }}} ##' @export simFrailty.simple <- function(K,varr,beta,stoptime,lam0=c(0.2), Cvar=0,left=0,pairleft=0,trunc.prob=0.5,overall=1,all.sum=NULL) ## {{{ { n=2 ## length(lam0) competing risk with constant hazards lam0 x<-array(c(runif(n*K),rep(0,n*K),rbinom(n*K,1,0.5)),dim=c(K,n,3)) if (Cvar==0) C<-matrix(stoptime,K,n) else C<-matrix(Cvar*runif(K*n)*stoptime,K,n) if (length(varr)==1) varr <- rep(varr,length(lam0)+overall) eta <- varr etat <- sum(varr) if (!is.null(all.sum)) etat <- all.sum varr <- varr/etat ### total variance for each cause + overall nc <- length(lam0); mz <- c(rep(1,K/2),rep(0,K/2)); dz <- 1-mz; if (overall==1) { etal <- etat Gams1 <-cbind(rgamma(K,varr[nc+1])/etal) Gamoa <- Gams1 } else Gamoa <- 0 print(etat); print(varr) temp1 <- matrix(0,K,length(lam0)) temp2 <- matrix(0,K,length(lam0)) for (i in 1:nc) { etal <- etat Gams1 <-cbind(rgamma(K,varr[i])/etal) Gam1 <- Gams1+Gamoa Gam1 <- cbind(Gam1,Gam1) print(i); print(apply(Gam1,2,mean)); print(apply(Gam1,2,var)); print(apply(Gams1,2,mean)); print(apply(Gams1,2,var)); print(apply(as.matrix(Gamoa),2,mean)); print(apply(as.matrix(Gamoa),2,var)); ttemp<-matrix(rexp(2*K),K,2)/(Gam1*exp(beta*x[,,3])*lam0[i]) temp1[,i] <- ttemp[,1] temp2[,i] <- ttemp[,2] } temp <- cbind( apply(temp1,1,min), apply(temp2,1,min)) cause1 <- apply(temp1,1,which.min) cause2 <- apply(temp2,1,which.min) ### x[,,2]<- ifelse(temp<=C,1,0)*cbind(cause1,cause2); x[,,1]<-pmin(temp,C) minstime <- apply(x[,,1],1,min) ud <- as.data.frame(cbind(apply(x,3,t),rep(1:K,each=n))) zyg <- c(rep("MZ",K),rep("DZ",K)) if (left>0) { ## {{{ if (pairleft==1) { lefttime <- runif(K)*(stoptime-left) left <- rbinom(K,1,trunc.prob) ## not trunation times! lefttime <- apply(cbind(lefttime*left,3),1,min) trunk <- (lefttime > minstime) medleft <- rep(trunk,each=n) } else { ### lefttime <- rexp(n*K)*left lefttime <- runif(K)*(stoptime-left) left <- rbinom(n*K,1,trunc.prob) ## not trunation times! lefttime <- apply(cbind(lefttime*left,3),1,min) trunk <- (lefttime > ud[,1]) medleft <- trunk } } else { lefttime <- trunk <- rep(0,K);} ## }}} if (pairleft==1) ud <- cbind(ud,zyg,rep(minstime,each=n),rep(lefttime,each=n),rep(trunk,each=n)) else ud <- cbind(ud,zyg,rep(minstime,each=n),lefttime,trunk) names(ud)<-c("time","status","x","cluster","zyg","mintime","lefttime","truncated") return(ud) } ## }}} ##' @export kendall.ClaytonOakes.twin.ace <- function(parg,parc,K=10000,test=0) ## {{{ { ## K antal clustre, n=antal i clustre ### total variance of gene and env. ### K <- 10; varg <- 1; varc <- 1; ### random effects with ### means varg/(varg+varc) and variances varg/(varg+varc)^2 sumpar <- sum(parg+parc) parg <- parg/sumpar^2; parc <- parc/sumpar^2 K <- K*2 eta <- parc+parg Gams1 <-cbind( rgamma(K,parg)/eta, rgamma(K,parg*0.5)/eta, rgamma(K,parg*0.5)/eta, rgamma(K,parg*0.5)/eta, rgamma(K,parc)/eta ) mz <- c(rep(1,K/2),rep(0,K/2)); dz <- 1-mz; id <- rep(1:(K/2),each=2) mzrv <- Gams1[,1]+Gams1[,5] ### shared gene + env dzrv1 <- Gams1[,2]+Gams1[,3]+Gams1[,5] ### 0.5 shared gene + 0.5 non-shared + env dzrv2 <- Gams1[,2]+Gams1[,4]+Gams1[,5] ### 0.5 shared gene + 0.5 non-shared + env Gam1 <- cbind(mz*mzrv+dz*dzrv1,mz*mzrv+dz*dzrv2) if (test==1) { cat("mz cor") print(apply(Gam1[mz==1,1:2],2,var)) print(cor(Gam1[mz==1,1:2])) cat("dz cor") print(apply(Gam1[mz==0,1:2],2,var)) print(cor(Gam1[mz==0,1:2])) } Gam1 <- data.frame(cbind(Gam1,mz,id)) ## Silence false R CMD CHECK warnings: V11 <- V12 <- V21 <- V22 <- NULL gams.pair <- fast.reshape(Gam1,id="id") gams.pair <- transform(gams.pair, kendall = ((V11-V12)*(V21-V22))/((V11+V12)*(V21+V22)) ) kendall <- gams.pair$kendall mz.kendall <- mean(kendall[gams.pair$mz1==1]) dz.kendall <- mean(kendall[gams.pair$mz1==0]) return(list(mz.kendall=mz.kendall,dz.kendall=dz.kendall)) } ## }}} ##' @export kendall.normal.twin.ace <- function(parg,parc,K=10000) ## {{{ { ## K antal clustre, n=antal i clustre ### total variance of gene and env. ### K <- 10; varg <- 1; varc <- 1; ### random effects with ### means varg/(varg+varc) and variances varg/(varg+varc)^2 K <- K*2 Gams1 <-cbind( parg^.5*rnorm(K,parg), (parg*0.5)^.5*rnorm(K), (parg*0.5)^.5*rnorm(K), (parg*0.5)^.5*rnorm(K), parc^.5*rnorm(K) ) mz <- c(rep(1,K/2),rep(0,K/2)); dz <- 1-mz; id <- rep(1:(K/2),each=2) mzrv <- Gams1[,1]+Gams1[,5] ### shared gene + env dzrv1 <- Gams1[,2]+Gams1[,3]+Gams1[,5] ### 0.5 shared gene + 0.5 non-shared + env dzrv2 <- Gams1[,2]+Gams1[,4]+Gams1[,5] ### 0.5 shared gene + 0.5 non-shared + env Gam1 <- cbind(mz*mzrv+dz*dzrv1,mz*mzrv+dz*dzrv2) Gam1 <- data.frame(cbind(exp(Gam1),mz,id)) ## Silence false R CMD CHECK warnings: V11 <- V12 <- V21 <- V22 <- NULL gams.pair <- fast.reshape(Gam1,id="id") gams.pair <- transform(gams.pair, kendall = ((V11-V12)*(V21-V22))/((V11+V12)*(V21+V22)) ) kendall <- gams.pair$kendall mz <- gams.pair$mz1 mz.kendall <- mean(kendall[mz==1]) dz.kendall <- mean(kendall[mz==0]) return(list(mz.kendall=mz.kendall,dz.kendall=dz.kendall)) } ## }}} ## ###kendall.ClaytonOakes.twin.ace(2,0) ## sim.clayton <- function(n=100,K=2,eta=0.5,beta,...) { ## m <- lvm(T~x) ## rates <- c(0.3,0.5); cuts <- c(0,5) ## distribution(m,~) <- coxExponential.lvm(rate=rates,timecut=cuts) ## } mets/R/plotcr.R0000644000176200001440000000670313623061405013057 0ustar liggesusers##' @export plotcr <- function(x,col,lty,legend=TRUE,which=1:2,cause=1:2, ask = prod(par("mfcol")) < length(which) && dev.interactive(), ...) { if (inherits(try(find.package("prodlim"),silent=TRUE),"try-error")) { stop("Needs prodlim") } dots <- list(...) if (is.null(dots$xlab)) dots$xlab <- "Time" if ((!is.data.frame(x) | !is.matrix(x)) && ncol(x)<2) stop("Wrong type of data") if (ncol(x)==2) { if (is.null(dots$curvlab)) { causes <- setdiff(unique(x[,2]),0) dots$curvlab <- seq(length(causes)) } colnames(x)[1:2] <- c("t","status") co <- prodlim::prodlim(Hist(t,status)~1,data=data.frame(x)) ## co <- cuminc(x[,1],x[,2]) ## if (any(x[,1]<0)) { ## do.call(co,p) ## for (i in seq(length(co))) { ## co[[i]]$time <- co[[i]]$time[-1] ## co[[i]]$est <- co[[i]]$est[-1] ## } ##if (is.null(dots$xlim)) dots$xlim <- range(x[,1]) ## } ##do.call("plot", c(list(x=co), dots)) if (is.null(dots$lwd)) dots$lwd <- 1 if (missing(lty)) lty <- seq_len(length(co$cuminc)) if (missing(col)) col <- rep(1,length(co$cuminc)) if (is.null(dots$lwd)) dots$lwd <- 1 dots$lty <- lty[1] dots$col <- col[1] do.call("plot", c(list(x=co), dots)) dots$add <- TRUE for (i in seq_len(length(co$cuminc)-1)+1) { dots$lty <- lty[i] dots$col <- col[i] dots$cause <- i do.call("plot", c(list(x=co), dots)) } if (legend) legend("topleft",names(co$cuminc),col=col,lty=lty,pch=-1) return(invisible(co)) } if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } t <- as.matrix(x[,1:2]); cause0 <- as.matrix(x[,3:4]) causes <- sort(setdiff(unique(cause0),0)) if (is.null(dots$curvlab)) dots$curvlab <- seq(1:length(unique(causes))) if (missing(col)) col <- c("seagreen","darkred","darkblue","goldenrod","mediumpurple") if (1%in%which) { plot(t,type="n",...) count <- 1 for (i in causes) { points(t[cause0[,1]==causes[i],],col=Col(col[count],0.5),pch=2) points(t[cause0[,2]==causes[i],],col=Col(col[count],0.5),pch=6) count <- count+1 } points(t[cause0[,1]==0 & cause0[,2]==0,],col=Col("black",0.2),pch=1) if (legend) legend("topleft", c("Subj 1, Cause 1", "Subj 2, Cause 1", "Subj 1, Cause 2", "Subj 2, Cause 2", "Double Censoring"), pch=c(2,6,2,6,1), col=c(rep(col[1:length(causes)],each=2),"black")) } if (2%in%which) { dots$curvlab <- NULL colnames(x)[1:4] <- c("t1","t2","cause1","cause2") co1 <- prodlim::prodlim(Hist(t1,cause1)~1,data.frame(x)) co2 <- prodlim::prodlim(Hist(t2,cause2)~1,data.frame(x)) if (is.null(dots$lwd)) dots$lwd <- 1 if (missing(lty)) lty <- seq_len(length(co1$cuminc)) if (missing(col)) col <- rep(1,length(co1$cuminc)) if (is.null(dots$lwd)) dots$lwd <- 1 dots$lty <- lty[1] dots$col <- col[1] dots$cause <- cause[1] do.call("plot", c(list(x=co1), dots)) dots$add <- TRUE do.call("plot", c(list(x=co2), dots)) ## for (i in seq_len(length(co1$cuminc)-1)+1) { for (i in seq_len(length(cause)-1)+1) { dots$lty <- lty[i] dots$col <- col[i] dots$cause <- cause[i] do.call("plot", c(list(x=co1), dots)) do.call("plot", c(list(x=co2), dots)) } if (legend && length(cause)>1) legend("topleft",names(co1$cuminc)[cause],col=col,lty=lty,pch=-1,bg="white") } } mets/R/biprobit.strata.R0000644000176200001440000000345413623061405014663 0ustar liggesusersdo.twinlm.strata <- function(x,fun,...) { res <- lapply(x$model,function(m) do.call(fun,c(list(m),list(...)))) names(res) <- names(x$model) class(res) <- "do.twinlm.strata" newattr <- setdiff(names(attributes(x)),names(attributes(res))) attributes(res) <- c(attributes(res),attributes(x)[newattr]) return(res) } ##' @export print.do.twinlm.strata <- function(x,...) { for (i in seq_len(length(x))) { message(rep("-",60),sep="") message("Strata '",names(x)[i],"'",sep="") print(x[[i]]) } if (!is.null(attributes(x)$time)) { message(rep("-",60),sep="") cat("\n") cat("Event of interest before time ", attributes(x)$time, "\n", sep="") } return(invisible(x)) } ##' @export plot.twinlm.strata <- function(x,...) suppressMessages(do.twinlm.strata(x,"plot",...)) ##' @export print.twinlm.strata <- function(x,...) print.do.twinlm.strata(x$model,...) ##' @export summary.twinlm.strata <- function(object,...) do.twinlm.strata(object,"summary",...) ##' @export coef.twinlm.strata <- function(object,...) object$coef ##' @export logLik.twinlm.strata <- function(object,indiv=FALSE,list=FALSE,...) { ll <- lapply(object$model,function(x) logLik(x,indiv=indiv,...)) if (list) return(ll) if (!indiv) { res <- structure(sum(unlist(ll)),df=0,nall=0) for (i in seq(length(ll))) { attributes(res)$nall <- attributes(res)$nall+attributes(ll[[i]])$nall attributes(res)$df <- attributes(res)$df+attributes(ll[[i]])$df } ## attributes(res)$nobs <- attributes(res)$nall-attributes(res)$df attributes(res)$nobs <- attributes(res)$nall class(res) <- "logLik" return(res) } return(unlist(ll)) } ##' @export score.twinlm.strata <- function(x,...) { ss <- lapply(x$model,function(m) score(m,indiv=FALSE,...)) return(unlist(ss)) } mets/R/coef.biprobit.R0000644000176200001440000000017713623061405014300 0ustar liggesusers##' @export coef.biprobit <- function(object,matrix=FALSE,...) { if (matrix) return(object$coef) return(object$coef[,1]) } mets/R/fastcluster.R0000644000176200001440000000033613623061405014107 0ustar liggesusers##' @export fast.cluster <- function(x,...) { arglist <- list("FastCluster", time=as.integer(x), PACKAGE="mets") res <- do.call(".Call",arglist) return(as.vector(res)) } mets/R/biprobit.time.R0000644000176200001440000002766513623061405014335 0ustar liggesusers##' @export biprobit.time <- function(formula,data,id,..., breaks=NULL,n.times=20,pairs.only=TRUE,fix.cens.weights=FALSE, cens.formula,cens.model="aalen",weights="w",messages=FALSE, return.data=FALSE,theta.formula=~1,trunc.weights="w2", estimator="biprobit", summary.function) { ## {{{ m <- match.call(expand.dots = FALSE) m <- m[match(c("","data"),names(m),nomatch = 0)] Terms <- terms(cens.formula,data=data) m$formula <- Terms m[[1]] <- as.name("model.frame") M <- eval(m,envir=parent.frame()) censtime <- model.extract(M, "response") if (pairs.only) { ii <- sort(as.matrix(na.omit(fast.reshape(seq(nrow(data)),id=data[,id])))) data <- data[ii,,drop=FALSE] censtime <- censtime[ii] } ltimes <- 0 if (ncol(censtime)==3) {## {{{ ## Calculate probability of not being truncated via Clayton-Oakes (ad hoc combining causes) status <- censtime[,3] noncens <- !status time <- censtime[,2] ltimes <- censtime[,1] data$truncsurv <- Surv(ltimes,time,noncens) trunc.formula <- update(formula,truncsurv~.) ud.trunc <- aalen(trunc.formula,data=data,robust=0,n.sim=0,residuals=0,silent=1,max.clust=NULL, clusters=data[,id], ...) X <- model.matrix(trunc.formula,data) ##dependX0 <- model.matrix(theta.formula,data) dependX0 <- X twostage.fit <- two.stage(ud.trunc, data=data,robust=0,detail=0, theta.des=dependX0)#,Nit=20,step=1.0,notaylor=1) Xnam <- colnames(X) ww <- fast.reshape(cbind(X,".num"=seq(nrow(X)),".lefttime"=ltimes),varying=c(".num",".lefttime"),id=data[,id]) dependX <- as.matrix(ww[,Xnam,drop=FALSE]) nottruncpair.prob <- predict.two.stage(twostage.fit,X=ww[,Xnam], times=ww[,".lefttime1"],times2=ww[,".lefttime2"], theta.des=dependX)$St1t2 data[,trunc.weights] <- 0 data[ww[,".num1"],trunc.weights] <- nottruncpair.prob data[ww[,".num2"],trunc.weights] <- nottruncpair.prob } else { status <- censtime[,2] time <- censtime[,1] } ## }}} outcome <- as.character(terms(formula)[[2]]) jj <- jumptimes(time,data[,outcome],data[,id],sample=n.times) lastjump <- tail(jj,1) if (is.null(breaks)) { breaks <- jj } if (any(breaks>lastjump)) { breaks <- unique(pmin(breaks,tail(jj,1))) if (messages) message("Looking at event before time ",max(breaks)) } outcome0 <- paste(outcome,"_dummy") res <- list(); k <- 0 breaks <- rev(breaks) ids <- c() for (tau in breaks) { if (length(breaks)>1 && messages) message(tau) ## construct min(T_i,tau) or T_i and related censoring variable, ## thus G_c(min(T_i,tau)) or G_c(T_i) as weights if ((fix.cens.weights==1 & k==0) | (fix.cens.weights==0)) { data0 <- data time0 <- time status0 <- status } cond0 <- time0>tau if (!fix.cens.weights) { status0[cond0 & status==1] <- 3 ## Not-censored if T>tau } data0[,outcome] <- data[outcome] data0[cond0,outcome] <- FALSE ## Non-case if T>tau if (!fix.cens.weights) time0[cond0] <- tau if ((fix.cens.weights & k==0) | (!fix.cens.weights)) { if (ncol(censtime)==3) { ## truncation... suppressWarnings(data0$S <- Surv(ltimes,time0,status0==1)) } else { data0$S <- Surv(time0,status0==1) } ## data0$status0 <- status0 ## data0$time0 <- time0 ## data0$y0 <- data0[,outcome] dataw <- ipw(update(cens.formula,S~.), data=subset(data0,ltimes1) res <- c(res,list(summary(b,...))) } if (length(breaks)==1) { return(structure(b,time=breaks)) } if (missing(summary.function)) { summary.function <- function(x,...) x$all } mycoef <- lapply(rev(res),function(x) summary.function(x)) res <- list(varname="Time",var=rev(breaks),coef=mycoef,summary=rev(res),call=m,type="time",id=ids) class(res) <- "timemets" return(res) } ## }}} biprobit.time2 <- function(formula,data,id,..., breaks=Inf,pairs.only=TRUE, cens.formula,cens.model="aalen",weights="w") { ## {{{ m <- match.call(expand.dots = FALSE) m <- m[match(c("","data"),names(m),nomatch = 0)] Terms <- terms(cens.formula,data=data) m$formula <- Terms m[[1]] <- as.name("model.frame") M <- eval(m,envir=parent.frame()) censtime <- model.extract(M, "response") status <- censtime[,2] time <- censtime[,1] outcome <- as.character(terms(formula)[[2]]) if (is.null(breaks)) breaks <- quantile(time,c(0.25,0.5,0.75,1)) outcome0 <- paste(outcome,"_dummy") res <- list() for (tau in breaks) { if (length(breaks)>1) message(tau) data0 <- data time0 <- time cond0 <- time0>tau status0 <- status status0[cond0 & status==1] <- 3 ## Censored data0[cond0,outcome] <- FALSE time0[cond0] <- tau data0$S <- survival::Surv(time0,status0==1) dataw <- ipw(update(cens.formula,S~.), data=data0, cens.model=cens.model, cluster=id,weight.name=weights,obs.only=TRUE) message("control") suppressWarnings(b <- biprobit(formula, data=dataw, id=id, weights=weights, pairs.only=pairs.only,...)) res <- c(res,list(summary(b))) } if (length(breaks)==1) return(b) res <- list(varname="Time",var=breaks,coef=lapply(res,function(x) x$all),summary=res,call=m,type="time") class(res) <- "timemets" return(res) } ## }}} biprobit.time.trunc.test <- function(formula,data,id,..., breaks=NULL,n.times=20,pairs.only=TRUE,fix.cens.weights=FALSE, cens.formula,cens.model="aalen",weights="w",messages=FALSE, return.data=FALSE,theta.formula=~1,trunc.weights="w2", estimator="biprobit", summary.function) { ## {{{ m <- match.call(expand.dots = FALSE) m <- m[match(c("","data"),names(m),nomatch = 0)] Terms <- terms(cens.formula,data=data) m$formula <- Terms m[[1]] <- as.name("model.frame") M <- eval(m,envir=parent.frame()) censtime <- model.extract(M, "response") if (pairs.only) { ii <- sort(as.matrix(na.omit(fast.reshape(seq(nrow(data)),id=data[,id])))) data <- data[ii,,drop=FALSE] censtime <- censtime[ii] } ltimes <- 0 if (ncol(censtime)==3) { ## Calculate probability of not being truncated via Clayton-Oakes (ad hoc combining causes) status <- censtime[,3] noncens <- !status time <- censtime[,2] ltimes <- censtime[,1] data$truncsurv <- Surv(ltimes,time,noncens) trunc.formula <- update(formula,truncsurv~.) ud.trunc <- aalen(trunc.formula,data=data,robust=0,n.sim=0,residuals=0,silent=1,max.clust=NULL, clusters=data[,id], ...) X <- model.matrix(trunc.formula,data) ##dependX0 <- model.matrix(theta.formula,data) dependX0 <- X twostage.fit <- two.stage(ud.trunc, data=data,robust=0,detail=0, theta.des=dependX0)#,Nit=20,step=1.0,notaylor=1) Xnam <- colnames(X) ww <- fast.reshape(cbind(X,".num"=seq(nrow(X)),".lefttime"=ltimes),varying=c(".num",".lefttime"),id=data[,id]) dependX <- as.matrix(ww[,Xnam,drop=FALSE]) nottruncpair.prob <- predict.two.stage(twostage.fit,X=ww[,Xnam], times=ww[,".lefttime1"],times2=ww[,".lefttime2"], theta.des=dependX)$St1t2 data[,trunc.weights] <- 0 data[ww[,".num1"],trunc.weights] <- nottruncpair.prob data[ww[,".num2"],trunc.weights] <- nottruncpair.prob } else { status <- censtime[,2] time <- censtime[,1] } outcome <- as.character(terms(formula)[[2]]) jj <- jumptimes(time,data[,outcome],data[,id],sample=n.times) lastjump <- tail(jj,1) if (is.null(breaks)) { breaks <- jj } if (any(breaks>lastjump)) { breaks <- unique(pmin(breaks,tail(jj,1))) if (messages) message("Looking at event before time ",max(breaks)) } outcome0 <- paste(outcome,"_dummy") res <- list(); k <- 0 breaks <- rev(breaks) for (tau in breaks) { if (length(breaks)>1 && messages) message(tau) ## construct min(T_i,tau) or T_i and related censoring variable, ## thus G_c(min(T_i,tau)) or G_c(T_i) as weights if ((fix.cens.weights==1 & k==0) | (fix.cens.weights==0)) { data0 <- data time0 <- time status0 <- status } cond0 <- time0>tau if (!fix.cens.weights) { status0[cond0 & status==1] <- 3 ## Not-censored if T>tau } data0[,outcome] <- data[outcome] data0[cond0,outcome] <- FALSE ## Non-case if T>tau if (!fix.cens.weights) time0[cond0] <- tau if ((fix.cens.weights & k==0) | (!fix.cens.weights)) { if (ncol(censtime)==3) { ## truncation... suppressWarnings(data0$S <- Surv(ltimes,time0,status0==1)) } else { data0$S <- Surv(time0,status0==1) } ## data0$status0 <- status0 ## data0$time0 <- time0 ## data0$y0 <- data0[,outcome] dataw <- ipw(update(cens.formula,S~.), data=subset(data0,ltimes1) res <- c(res,list(summary(b,...))) } if (length(breaks)==1) { return(structure(b,time=breaks)) } if (missing(summary.function)) { summary.function <- function(x,...) x$all } mycoef <- lapply(rev(res),function(x) summary.function(x)) res <- list(varname="Time",var=rev(breaks),coef=mycoef,summary=rev(res),call=m,type="time") class(res) <- "timemets" return(res) } ## }}} mets/R/blocksample.R0000644000176200001440000000575113623061405014052 0ustar liggesusers##' @export dsample <- function(data,x,size=NULL,replace=TRUE,...) { if (missing(x)) { if (is.null(size)) size <- NROW(data) return(data[sample.int(NROW(data), size, replace=replace),,drop=FALSE]) } inp <- procform(x,data=data,return.formula=TRUE) if (length(inp$filter.expression)>0) data <- subset(data,eval(inp$filter.expression)) if (!is.null(inp$predictor)) idvar <- model.frame(inp$predictor, data=data, na.action=na.pass,...) if (!is.null(inp$response)) { if (is.null(size)) size <- NROW(data) data <- model.frame(inp$response, data=data, na.action=na.pass,...) } if (is.null(inp$predictor)) { if (is.null(size)) size <- NROW(data) return(data[sample.int(NROW(data), size, replace=replace),,drop=FALSE]) } blocksample(data,idvar=idvar,size=size,replace=replace,...) } ##' Sample blockwise from clustered data ##' ##' @title Block sampling ##' @param data Data frame ##' @param idvar Column defining the clusters ##' @param size Size of samples ##' @param replace Logical indicating wether to sample with replacement ##' @param \dots additional arguments to lower level functions ##' @return \code{data.frame} ##' @author Klaus K. Holst ##' @keywords models utilities ##' @aliases blocksample dsample ##' @details Original id is stored in the attribute 'id' ##' @export ##' @examples ##' ##' d <- data.frame(x=rnorm(5), z=rnorm(5), id=c(4,10,10,5,5), v=rnorm(5)) ##' (dd <- blocksample(d,size=20,~id)) ##' attributes(dd)$id ##' ##' \dontrun{ ##' blocksample(data.table::data.table(d),1e6,~id) ##' } ##' ##' ##' d <- data.frame(x=c(1,rnorm(9)), ##' z=rnorm(10), ##' id=c(4,10,10,5,5,4,4,5,10,5), ##' id2=c(1,1,2,1,2,1,1,1,1,2), ##' v=rnorm(10)) ##' dsample(d,~id, size=2) ##' dsample(d,.~id+id2) ##' dsample(d,x+z~id|x>0,size=5) ##' blocksample <- function(data, size, idvar=NULL, replace=TRUE, ...) { if (is.null(idvar)) { return(data[sample(NROW(data),size,replace=replace),,drop=FALSE]) } if (inherits(idvar,"formula")) { idvar <- all.vars(idvar) } if (NROW(idvar)==nrow(data)) { id0 <- idvar } else { if (inherits(data,"data.table")) { id0 <- as.data.frame(data[,idvar,with=FALSE])[,1] } else id0 <- data[,idvar] } if (NCOL(id0)>1) { id0 <- interaction(as.data.frame(id0)) } id0 <- as.matrix(id0)[,1,drop=TRUE] ii <- cluster.index(as.matrix(id0)) size <- ifelse(missing(size) || is.null(size),ii$uniqueclust,size) ids <- sample(seq(ii$uniqueclust), size=size,replace=replace) idx <- na.omit(as.vector(t(ii$idclustmat[ids,])))+1 newid <- rep(seq(size), ii$cluster.size[ids]) oldid <- id0[idx] res <- data[idx,] if (is.character(idvar) && length(idvar)==1) { res[,idvar] <- newid } else { res <- cbind(res,id=newid) colnames(res) <- make.unique(colnames(res)) } attributes(res)$id <- oldid return(res) } mets/R/pmvn.R0000644000176200001440000001016413623061405012530 0ustar liggesusers##' @export pbvn <- function(upper,rho,sigma) { if (!missing(sigma)) { rho <- cov2cor(sigma)[1,2] upper <- upper/diag(sigma)^0.5 } arglist <- list("bvncdf", a=upper[1], b=upper[2], r=rho, PACKAGE="mets") res <- do.call(".Call",arglist) return(res) } ##' Multivariate normal distribution function ##' ##' Multivariate normal distribution function ##' @aliases pmvn pbvn loglikMVN scoreMVN dmvn rmvn ##' @export ##' @examples ##' lower <- rbind(c(0,-Inf),c(-Inf,0)) ##' upper <- rbind(c(Inf,0),c(0,Inf)) ##' mu <- rbind(c(1,1),c(-1,1)) ##' sigma <- diag(2)+1 ##' pmvn(lower=lower,upper=upper,mu=mu,sigma=sigma) ##' @param lower lower limits ##' @param upper upper limits ##' @param mu mean vector ##' @param sigma variance matrix or vector of correlation coefficients ##' @param cor if TRUE sigma is treated as standardized (correlation matrix) pmvn <- function(lower,upper,mu,sigma,cor=FALSE) { if (missing(sigma)) stop("Specify variance matrix 'sigma'") if (missing(lower)) { if (missing(upper)) stop("Lower or upper integration bounds needed") lower <- upper; lower[] <- -Inf } p <- ncol(rbind(lower)) if (missing(upper)) { upper <- lower; upper[] <- Inf } if (missing(mu)) mu <- rep(0,p) sigma <- rbind(sigma) ncor <- p*(p-1)/2 if (ncol(sigma)!=p && ncol(sigma)!=ncor) stop("Incompatible dimensions of mean and variance") if (ncol(rbind(lower))!=p || ncol(rbind(upper))!=p) stop("Incompatible integration bounds") arglist <- list("pmvn0", lower=rbind(lower), upper=rbind(upper), mu=rbind(mu), sigma=rbind(sigma), cor=as.logical(cor[1]), PACKAGE="mets") res <- do.call(".Call",arglist) return(as.vector(res)) } introotpn <- function(p) { ## Find integer root of x^2-x-2*p=0 n <- 0.5*(1+sqrt(1+8*p)) if (floor(n)!=n) n <- NA return(n) } ##' @export rmvn <- function(n,mu,sigma,rho,...) { if (!missing(rho)) { if (is.vector(rho)) rho <- rbind(rho) if (missing(mu)) { p <- introotpn(NCOL(rho)) mu <- rep(0,p) } return (.Call("_mets_rmvn", n=as.integer(n), mu=rbind(mu), rho=rbind(rho))) } if (!missing(mu) && missing(sigma)) sigma <- diag(nrow=length(mu)) if (missing(sigma)) sigma <- matrix(1) if (is.vector(sigma)) sigma <- diag(sigma,ncol=length(sigma)) if (missing(mu)) mu <- rep(0,ncol(sigma)) PP <- with(svd(sigma), v%*%diag(sqrt(d),ncol=length(d))%*%t(u)) res <- matrix(rnorm(ncol(sigma)*n),ncol=ncol(sigma))%*%PP if (NROW(mu)==nrow(res) && NCOL(mu)==ncol(res)) return(res+mu) return(res+cbind(rep(1,n))%*%mu) } ##' @export dmvn <- function(x,mu,sigma,rho,log=FALSE,nan.zero=TRUE,...) { if (!missing(rho)) { if (is.vector(rho)) rho <- rbind(rho) if (is.vector(x)) x <- rbind(x) if (missing(mu)) { p <- NCOL(x) mu <- rep(0,p) } res <- .Call("_mets_dmvn", u=x, mu=rbind(mu), rho=rho) if (!log) res <- exp(res) return(res) } if (!missing(mu) && missing(sigma)) sigma <- diag(nrow=length(mu)) if (missing(sigma)) sigma <- matrix(1) if (is.vector(sigma)) sigma <- diag(sigma,ncol=length(sigma)) if (missing(mu)) mu <- rep(0,ncol(sigma)) if (length(sigma)==1) { k <- 1 isigma <- structure(cbind(1/sigma),det=as.vector(sigma)) } else { k <- ncol(sigma) isigma <- Inverse(sigma) } if (!missing(mu)) { if (NROW(mu)==NROW(x) && NCOL(mu)==NCOL(x)) { x <- x-mu } else { x <- t(t(x)-mu) } } logval <- -0.5*(base::log(2*base::pi)*k+ base::log(attributes(isigma)$det)+ rowSums((x%*%isigma)*x)) if (nan.zero) logval[is.nan(logval)] <- -Inf if (log) return(logval) return(exp(logval)) } mets/R/npc.R0000644000176200001440000000325013623061405012326 0ustar liggesusers##' @export npc <- function(T,cause,same.cens=TRUE,sep=FALSE) { mtime <- apply(T[,1:2],1,max) ot <- order(mtime) mtime <- mtime[ot] T <- T[ot,] if (!sep) { time1 <- as.vector(T[,1:2]); status1 <- as.vector(T[,3:4]) ud.cens1<-survival::survfit(Surv(time1,status1==0)~+1); Gfit1<-cbind(ud.cens1$time,ud.cens1$surv) Gfit2 <- Gfit1<-rbind(c(0,1),Gfit1); } else { time1 <- as.vector(T[,1]); status1 <- as.vector(T[,3]) ud.cens1<-survival::survfit(Surv(time1,status1==0)~+1); time2 <- as.vector(T[,2]); status2 <- as.vector(T[,4]) ud.cens2<-survival::survfit(Surv(time2,status2==0)~+1); Gfit1<-cbind(ud.cens1$time,ud.cens1$surv) Gfit1<-rbind(c(0,1),Gfit1); Gfit2<-cbind(ud.cens2$time,ud.cens2$surv) Gfit2<-rbind(c(0,1),Gfit2); } i1 <- fast.approx(Gfit1[,1],T[,1]) cweights1<-fast.approx(,Gfit1[,2])[[1]] cweights2<-fast.approx(Gfit2[,1],T[,2],Gfit2[,2])[[1]]; weight11 <- apply(cbind(cweights1,cweights2),1,min) if (same.cens) { conc <- (T[,3]==cause[1])*(T[,4]==cause[2])/weight11 } else { conc <-(T[,3]==cause[1])*(T[,4]==cause[2])/(cweights1*cweights2); } mtime <- mtime[!is.na(conc)] conc <- conc[!is.na(conc)] cbind(mtime,cumsum(conc)/length(conc)) } ##' @export nonparcuminc <- function(t,status,cens=0) { ord <- order(t); t <- t[ord]; status <- status[ord] ud.cens<-survival::survfit(Surv(t,status==cens)~1) Gfit<-cbind(ud.cens$time,ud.cens$surv) Gfit<-rbind(c(0,1),Gfit); causes <- setdiff(unique(status),cens) cweight<-fast.approx(Gfit[,1],t,Gfit[,2])[[1]]; cc <- t for (i in 1:length(causes)) { c1 <- status==causes[i] cc <- cbind(cc,cumsum(c1/cweight)/length(c1)) } return(cc) } mets/R/cumh.R0000644000176200001440000000636713623061405012516 0ustar liggesusers cumh <- function(formula,data,...,time, timestrata=quantile(data[,time],c(0.25,0.5,0.75,1)), cens.formula=NULL,cens.model="aalen", cumulative=FALSE, silent=FALSE) { time. <- substitute(time) if (!is.character(time.)) time. <- deparse(time.) time <- time. if (!is.null(cens.formula)) { m <- match.call(expand.dots = TRUE)[1:3] Terms <- terms(cens.formula, data = data) m$formula <- Terms m[[1]] <- as.name("model.frame") censMod <- eval(m, parent.frame()) censtime <- model.extract(m, "response") status <- censtime[,2] ### data[,"_status"] <- } res <- list(); i <- 0 ht <- c() outcome <- as.character(terms(formula)[[2]]) coefs <- c() y0 <- data[,outcome] for (i in seq(length(timestrata))) { t <- timestrata[i] data[,outcome] <- y0 newdata <- data if (!cumulative) { if (i==1) { idx <- data[,time]0 & missing(fillcol)) fillcol <- Col(col,alpha) count <- 0 for (tt in type) { count <- count+1 zz <- x$coeftype[[tt]][idx,,drop=FALSE] if (!add) { plot(zz[,1:2,drop=FALSE],type="l",ylim=ylim,lwd=lwd, ylab=ylab,xlab=xlab,col=col[count],...) } add <- TRUE xx <- with(x, c(zz[,1],rev(zz[,1]))) yy <- with(x, c(zz[,3],rev(zz[,4]))) polygon(xx,yy,col=fillcol[count]) lines(zz[,1:2,drop=FALSE],lwd=lwd,col=col[count],...) } if (legend) graphics::legend(legendpos,names(x$coeftype)[type],col=col,lwd=lwd,lty=1) invisible(x) } mets/R/utils.R0000644000176200001440000000444013623061405012710 0ustar liggesusers###{{{ RoundMat RoundMat <- function(cc,digits = max(3, getOption("digits") - 2),na=TRUE,...) { res <- format(round(cc,max(1,digits)),digits=digits) if (na) return(res) res[grep("NA",res)] <- "" res } ###}}} RoundMat ###{{{ multinomlogit multinomlogit <- function(x,tr=exp,dtr=exp) { n <- length(x) ex <- tr(x) dex <- dtr(x) sx <- sum(ex)+1 f <- c(ex,1) df <- c(dex,0) res <- f/sx dg <- -dex/sx^2 gradient <- matrix(ncol=n,nrow=n+1) I <- diag(n+1) for (i in seq_len(n)) { gradient[,i] <- df[i]*I[i,]/sx+dg[i]*f } attributes(res)$gradient <- gradient return(res) } ###}}} multinomlogit ###{{{ grouptable ##' @export grouptable <- function(data,id,group,var,lower=TRUE, labels,order, group.labels,group.order, combine=" & ",...) { if (!missing(order) || !missing(labels)) { data[,var] <- as.factor(data[,var]) if (missing(order)) order <- seq(length(labels)) if (missing(labels)) labels <- levels(data[,var]) data[,var] <- factor(data[,var],levels(data[,var])[order],labels=labels[order]) } wide <- fast.reshape(data,id=id,varying=-group) res <- lapply(split(wide,wide[,group]), function(x) { M <- with(x, table(get(paste(var,"1",sep="")), get(paste(var,"2",sep="")))) if (lower) { M[lower.tri(M)] <- M[lower.tri(M)]+M[upper.tri(M)] M[upper.tri(M)] <- NA } return(M) }) if (!missing(group.order) && length(group.order)==length(res)) res <- res[group.order] if (!missing(group.labels) && length(group.labels)==length(res)) names(res) <- group.labels if (length(res)==2 && !is.null(combine)) { M <- res[[1]] M[upper.tri(M)] <- res[[2]][lower.tri(res[[2]])] diag(M) <- paste(diag(M),diag(res[[2]]),sep=combine) M <- cbind(rownames(M),M) M <- rbind(c("",rownames(M)),M) colnames(M) <- rownames(M) <- rep("",nrow(M)) M[1,1] <- paste(names(res),collapse=combine) return(structure(M,class="table")) return(M); } res } ###}}} grouptable mets/R/print.biprobit.R0000644000176200001440000000014413623061405014512 0ustar liggesusers##' @export print.biprobit <- function(x,...) { printCoefmat(x$coef,...) return(invisible(x)) } mets/R/summary.biprobit.R0000644000176200001440000001633713623061405015066 0ustar liggesusers##' @export summary.biprobit <- function(object,level=0.05,transform,contrast,mean.contrast=NULL,mean.contrast2=NULL,cor.contrast=NULL,marg.idx=1,iid=FALSE,...) { alpha <- level/2 varcomp <- object$coef[length(coef(object)),1:2] varcomp <- rbind(object$model$tr(c(varcomp[1],varcomp[1]%x%cbind(1,1) + qnorm(1-alpha)*varcomp[2]%x%cbind(-1,1)))) colnames(varcomp)[2:3] <- paste(c(alpha*100,100*(1-alpha)),"%",sep="") rownames(varcomp) <- ifelse(is.null(object$model$varcompname),"Variance component",object$model$varcompname) if (!missing(contrast)) { contrast <- rbind(contrast) mean.contrast <- contrast[,seq(object$model$blen),drop=FALSE] cor.contrast <- contrast[,seq(object$model$zlen)+object$model$blen,drop=FALSE] if (!object$model$eqmarg) { mean.contrast2 <- mean.contrast[,seq(ncol(mean.contrast)/2)+ncol(mean.contrast)/2,drop=FALSE] mean.contrast <- mean.contrast[,seq(ncol(mean.contrast)/2),drop=FALSE] } } h <- function(p) log(p/(1-p)) ## logit ih <- function(z) 1/(1+exp(-z)) ## expit ##dlogit <- function(p) 1/(p*(1-p)) if (!missing(transform)) { h <- asin; ih <- sin if (is.null(transform)) { h <- ih <- identity } if (is.list(transform)) { h <- transform[[1]]; ih <- transform[[2]] } } convval <- function(val) { i1 <- which(val==1) i2 <- which(val==-1) val <- as.character(val) val[seq_len(length(val)-1)+1] <- paste("+ ", val[seq_len(length(val)-1)+1],sep="") val[i2] <- "- "; val[i1] <- "+ " val[intersect(1,i1)] <- "" return(val) } parfun <- function(p,ref=FALSE,mean.contrast,mean.contrast2,cor.contrast) { nn <- paste("[",gsub("r:","",rownames(object$coef),fixed=TRUE),"]",sep="") m <- rep(p[1],2) r <- p[object$model$blen+1] corref <- mref1 <- mref2 <- NULL if (ref) { corref <- nn[object$model$blen+1] mref1 <- mref2 <- nn[1] } if (!is.null(mean.contrast)) { m[1] <- sum(p[seq_along(mean.contrast)]*mean.contrast) if (ref) { idx1 <- which(mean.contrast!=0) mref <- nn[idx1] mref1 <- mref2 <- paste(convval(mean.contrast[idx1]),mref,sep="") } if (is.null(mean.contrast2) && !object$model$eqmarg) { idx1 <- which(mean.contrast!=0) idx2 <- idx1+1 if (length(object$npar$pred)>0) idx2 <- idx2+object$npar$pred/2 mean.contrast2 <- rep(0,object$model$blen) mean.contrast2[idx2] <- mean.contrast[idx1] } } if (!is.null(mean.contrast2)) { m[2] <- sum(p[seq_len(object$model$blen)]*mean.contrast2[seq_len(object$model$blen)]) if (ref) { idx1 <- which(mean.contrast2!=0) mref <- nn[idx1] mref2 <- paste(convval(mean.contrast2[idx1]),mref,sep="") } } else { if (object$model$eqmarg) { m <- rep(m[1],2) } } if (!object$model$eqmarg & is.null(mean.contrast) & is.null(mean.contrast2)) { idx <- 2 if (length(object$npar$pred)>0 && object$npar$pred!=0) idx <- object$npar$pred/2+1 m[2] <- p[idx] mref2 <- nn[idx] } if (!is.null(cor.contrast)) { p.idx <- seq_len(object$model$zlen)+object$model$blen if (length(cor.contrast)==length(p)) p.idx <- seq(length(p)) r <- sum(p[p.idx]*cor.contrast) if (ref) { idx1 <- which(cor.contrast!=0) corref <- nn[p.idx[idx1]] corref <- paste(convval(cor.contrast[idx1]),corref,sep="") } } return(list(m=m,r=r,mref1=mref1,mref2=mref2,corref=corref)) } probs <- function(p,...) { pp <- parfun(p,...) m <- pp[[1]] r <- pp[[2]] S <- object$SigmaFun(r,cor=FALSE) ##mu.cond <- function(x) m[1]+S[1,2]/S[2,2]*(x-m[2]) ##var.cond <- S[1,1]-S[1,2]^2/S[2,2] p11 <- pmvn(lower=c(0,0),mu=m,sigma=S) p01 <- pmvn(lower=c(-Inf,0),upper=c(0,Inf),mu=m,sigma=S) p10 <- pmvn(lower=c(0,-Inf),upper=c(Inf,0),mu=m,sigma=S) p00 <- 1-p11-p10-p01 marg1 <- p11+p10 marg2 <- p11+p01 cond1 <- p11/marg2 lambda <- cond1/marg1 discond1 <- p10/(1-marg2) logOR <- log(cond1)-log(1-cond1)-log(discond1)+log(1-discond1) ##rho <- S[1,2]/S[1,1] if (object$model$eqmarg) { return(c(h(c(p11,cond1,marg1)),lambda,logOR,r)) } return(c(h(c(p11,p10,p01,p00,marg1,marg2)),logOR,r)) } alpha <- level/2 CIlab <- paste(c(alpha*100,100*(1-alpha)),"%",sep="") mycoef <- coef(object) cor.contrast <- rbind(cor.contrast) mean.contrast <- rbind(mean.contrast) mean.contrast2 <- rbind(mean.contrast2) KK <- lapply(list(cor.contrast,mean.contrast,mean.contrast2),nrow) if (all(is.null(unlist(KK)))) K <- 1 else K <- max(unlist(KK)) IID <- res <- pa <- c() for (i in seq(K)) { prob <- probs(mycoef,cor.contrast=cor.contrast[i,],mean.contrast=mean.contrast[i,],mean.contrast2=mean.contrast2[i,]) Dprob <- numDeriv::jacobian(probs,mycoef,cor.contrast=cor.contrast[i,],mean.contrast=mean.contrast[i,],mean.contrast2=mean.contrast2[i,]) sprob <- diag((Dprob)%*%vcov(object)%*%t(Dprob))^0.5 pp <- cbind(prob,prob-qnorm(1-alpha)*sprob,prob+qnorm(1-alpha)*sprob) pp[nrow(pp),] <- object$model$tr(pp[nrow(pp),]) pp[nrow(pp)-1,] <- exp(pp[nrow(pp)-1,]) if (!object$model$eqmarg) { pp[1:6,] <- ih(pp[1:6,]) nn <- c("P(Y1=1,Y2=1)","P(Y1=1,Y2=0)","P(Y1=0,Y2=1)","P(Y1=0,Y2=0)","P(Y1=1)","P(Y2=1)","OR","Tetrachoric correlation") } else { pp[1:3,] <- ih(pp[1:3,]) nn <- c("Concordance","Casewise Concordance","Marginal","Rel.Recur.Risk","OR","Tetrachoric correlation") } if (K>1) nn <- paste("c",i,":",nn,sep="") if (nrow(pp)-length(nn)>0) nn <- c(nn,rep("",nrow(pp)-length(nn))) rownames(pp) <- nn colnames(pp) <- c("Estimate",CIlab) P <- nrow(pp) pa <- c(pa, list(parfun(object$coef[,1],ref=TRUE,cor.contrast=cor.contrast[i,],mean.contrast[i,],mean.contrast2[i,]))) res <- rbind(res,pp) if (iid) { ff <- function(p) { res <- probs(p,cor.contrast=cor.contrast[i,],mean.contrast=mean.contrast[i,],mean.contrast2=mean.contrast2[i,]) nn <- names(res) res[length(res)] <- object$model$tr(res[length(res)]) res[length(res)-1] <- exp(res[length(res)-1]) idx <- 1:6 if (object$model$eqmarg) idx <- 1:3 res[idx] <- ih(res[idx]) res } ee <- lava::estimate(object,ff,labels=nn,id=object$id) IID <- c(IID,list(ee)) } } contrast <- any(c(!is.null(cor.contrast),!is.null(mean.contrast),!is.null(mean.contrast2))) res <- list(all=res,varcomp=varcomp,prob=res,coef=object$coef,score=colSums(object$score),logLik=object$logLik,msg=object$msg,N=object$N,ncontrasts=K,nstat=P, par=pa,model=object$model,contrast=contrast, time=attributes(object)$time, estimate=IID) class(res) <- "summary.biprobit" res } mets/R/score.biprobit.R0000644000176200001440000000023013623061405014465 0ustar liggesusers##' @export score.biprobit <- function(x,indiv=FALSE,...) { if (indiv) { s <- x$score; attributes(s)$logLik <- NULL; return(s) } colSums(x$score) } mets/R/dtable.R0000644000176200001440000001372013623061405013004 0ustar liggesusers##' tables for data frames ##' ##' tables for data frames ##' @param data if x is formula or names for data frame then data frame is needed. ##' @param y name of variable, or fomula, or names of variables on data frame. ##' @param x name of variable, or fomula, or names of variables on data frame. ##' @param ... Optional additional arguments ##' @param level 1 for all marginal tables, 2 for all 2 by 2 tables, and null for the full table, possible versus group variable ##' @param response For level=2, only produce tables with columns given by 'response' (index) ##' @param flat produce flat tables ##' @param total add total counts/proportions ##' @param prop Proportions instead of counts (vector of margins) ##' @param summary summary function ##' @author Klaus K. Holst and Thomas Scheike ##' @examples ##' data("sTRACE",package="timereg") ##' ##' dtable(sTRACE,~status) ##' dtable(sTRACE,~status+vf) ##' dtable(sTRACE,~status+vf,level=1) ##' dtable(sTRACE,~status+vf,~chf+diabetes) ##' ##' dtable(sTRACE,c("*f*","status"),~diabetes) ##' dtable(sTRACE,c("*f*","status"),~diabetes, level=2) ##' dtable(sTRACE,c("*f*","status"),level=1) ##' ##' dtable(sTRACE,~"*f*"+status,level=1) ##' dtable(sTRACE,~"*f*"+status+I(wmi>1.4)|age>60,level=2) ##' dtable(sTRACE,"*f*"+status~I(wmi>0.5)|age>60,level=1) ##' dtable(sTRACE,status~dcut(age)) ##' ##' dtable(sTRACE,~status+vf+sex|age>60) ##' dtable(sTRACE,status+vf+sex~+1|age>60, level=2) ##' dtable(sTRACE,.~status+vf+sex|age>60,level=1) ##' dtable(sTRACE,status+vf+sex~diabetes|age>60) ##' dtable(sTRACE,status+vf+sex~diabetes|age>60, flat=FALSE) ##' ##' dtable(sTRACE,status+vf+sex~diabetes|age>60, level=1) ##' dtable(sTRACE,status+vf+sex~diabetes|age>60, level=2) ##' ##' dtable(sTRACE,status+vf+sex~diabetes|age>60, level=2, prop=1, total=TRUE) ##' dtable(sTRACE,status+vf+sex~diabetes|age>60, level=2, prop=2, total=TRUE) ##' dtable(sTRACE,status+vf+sex~diabetes|age>60, level=2, prop=1:2, summary=summary) ##' ##' @aliases dtable dtab ##' @export dtable <- function(data,y=NULL,x=NULL,...,level=-1,response=NULL,flat=TRUE,total=FALSE,prop=FALSE,summary=NULL) { daggregate(data,y,x,..., fun=function(z) { res <- sum <- c() if (level==1 || ncol(z)==1) { for (i in seq_len(ncol(z))) { nn <- colnames(z)[i] val <- table(z[,i],...) if (prop[1]>0) val <- prop.table(val) names(attr(val,"dimnames")) <- nn val <- list(val) names(val) <- nn res <- c(res, val) if (!is.null(summary)) { sval <- list(do.call(summary,list(val[[1]]))) names(sval) <- nn c(sum, sval) } } res <- list(table=res,summary=sum,...) class(res) <- "dtable" return(res) } if (level>1) { if (level>2) response <- ncol(z) idx1 <- seq(1,ncol(z)-1) if (level>2 || !is.null(response)) { idx1 <- response idx2 <- setdiff(seq(ncol(z)),idx1) } for (i in idx1) { if (!(level>2 || !is.null(response))) { idx2 <- seq(i+1,ncol(z)) } for (j in idx2) { n1 <- colnames(z)[j] n2 <- colnames(z)[i] val <- table(z[,c(j,i)],...) if (prop[1]>0) { if (all(1:2 %in% prop)) { val <- prop.table(val) } else { val <- prop.table(val,prop) } } if (total) { tot <- prop if (length(prop)==1) tot <- setdiff(1:2,prop) val <- addmargins(val,tot) } val <- list(val) names(val) <- paste0(n1,", ",n2) res <- c(res, val) if (!is.null(summary)) { sval <- list(do.call(summary,list(val[[1]]))) #names(sval) <- names(val) sum <- c(sum, sval) } } } res <- list(table=res,summary=sum) class(res) <- "dtable" return(res) } res <- table(z,...) if (!is.null(summary)) { sum <- do.call(summary,c(list(res),list(...))) } if (prop[1]>0) res <- prop.table(res,prop) if (total>0) res <- addmargins(res,prop) if (flat) res <- ftable(res,...) res <- list(table=res,summary=sum) class(res) <- "dtable" return(res) }) } ##' @export dtab <- function(data,y=NULL,x=NULL,...) dtable(data,y=NULL,x=NULL,...) ##' @export print.dtable <- function(x,sep="\n",...) { cat(sep) if (inherits(x$table, c("table","ftable"))) { print(x$table) if (!is.null(x$summary)) print(x$summary) return(invisible(x)) } for (i in seq_along(x$table)) { print(x$table[[i]],...) if (!is.null(x$summary)) print(x$summary[[i]],...) cat(sep) } } mets/R/recurrent.marginal.R0000644000176200001440000035557213623061405015371 0ustar liggesusers##' Fast recurrent marginal mean when death is possible ##' ##' Fast Marginal means of recurrent events. Using the Lin and Ghosh (2000) ##' standard errors. ##' Fitting two models for death and recurent events these are ##' combined to prducte the estimator ##' \deqn{ \int_0^t S(u|x=0) dR(u|x=0) } the mean number of recurrent events, here ##' \deqn{ S(u|x=0) } is the probability of survival for the baseline group, and ##' \deqn{ dR(u|x=0) } is the hazard rate of an event among survivors for the baseline. ##' Here \deqn{ S(u|x=0) } is estimated by \deqn{ exp(-\Lambda_d(u|x=0) } with ##' \deqn{\Lambda_d(u|x=0) } being the cumulative baseline for death. ##' ##' Assumes no ties in the sense that jump times needs to be unique, this is particularly so for the stratified version. ##' ##' @param recurrent phreg object with recurrent events ##' @param death phreg object with deaths ##' @param fixbeta to force the estimation of standard errors to think of regression coefficients as known/fixed ##' @param km if true then uses Kaplan-Meier for death, otherwise exp(- Nelson-Aalen ) ##' @param ... Additional arguments to lower level funtions ##' @author Thomas Scheike ##' ##' @references ##' Ghosh and Lin (2002) Nonparametric Analysis of Recurrent events and death, ##' Biometrics, 554--562. ##' @examples ##' ##' data(base1cumhaz) ##' data(base4cumhaz) ##' data(drcumhaz) ##' dr <- drcumhaz ##' base1 <- base1cumhaz ##' base4 <- base4cumhaz ##' rr <- simRecurrent(1000,base1,death.cumhaz=dr) ##' rr$x <- rnorm(nrow(rr)) ##' rr$strata <- floor((rr$id-0.01)/500) ##' ##' ## to fit non-parametric models with just a baseline ##' xr <- phreg(Surv(entry,time,status)~cluster(id),data=rr) ##' dr <- phreg(Surv(entry,time,death)~cluster(id),data=rr) ##' par(mfrow=c(1,3)) ##' bplot(dr,se=TRUE) ##' title(main="death") ##' bplot(xr,se=TRUE) ##' ### robust standard errors ##' rxr <- robust.phreg(xr,fixbeta=1) ##' bplot(rxr,se=TRUE,robust=TRUE,add=TRUE,col=4) ##' ##' ## marginal mean of expected number of recurrent events ##' out <- recurrentMarginal(xr,dr) ##' bplot(out,se=TRUE,ylab="marginal mean",col=2) ##' ##' ######################################################################## ##' ### with strata ################################################## ##' ######################################################################## ##' xr <- phreg(Surv(entry,time,status)~strata(strata)+cluster(id),data=rr) ##' dr <- phreg(Surv(entry,time,death)~strata(strata)+cluster(id),data=rr) ##' par(mfrow=c(1,3)) ##' bplot(dr,se=TRUE) ##' title(main="death") ##' bplot(xr,se=TRUE) ##' rxr <- robust.phreg(xr,fixbeta=1) ##' bplot(rxr,se=TRUE,robust=TRUE,add=TRUE,col=1:2) ##' ##' out <- recurrentMarginal(xr,dr) ##' bplot(out,se=TRUE,ylab="marginal mean",col=1:2) ##' ##' ######################################################################## ##' ### cox case ################################################## ##' ######################################################################## ##' xr <- phreg(Surv(entry,time,status)~x+cluster(id),data=rr) ##' dr <- phreg(Surv(entry,time,death)~x+cluster(id),data=rr) ##' par(mfrow=c(1,3)) ##' bplot(dr,se=TRUE) ##' title(main="death") ##' bplot(xr,se=TRUE) ##' rxr <- robust.phreg(xr) ##' bplot(rxr,se=TRUE,robust=TRUE,add=TRUE,col=1:2) ##' ##' out <- recurrentMarginal(xr,dr) ##' bplot(out,se=TRUE,ylab="marginal mean",col=1:2) ##' ##' ######################################################################## ##' ### CIF ############################################################# ##' ######################################################################## ##' ### use of function to compute cumulative incidence (cif) with robust standard errors ##' data(bmt) ##' bmt$id <- 1:nrow(bmt) ##' xr <- phreg(Surv(time,cause==1)~cluster(id),data=bmt) ##' dr <- phreg(Surv(time,cause!=0)~cluster(id),data=bmt) ##' ##' out <- recurrentMarginal(xr,dr,km=TRUE) ##' bplot(out,se=TRUE,ylab="cumulative incidence") ##' ##' @aliases tie.breaker recmarg recurrentMarginalIPCW ##' @export recurrentMarginal <- function(recurrent,death,fixbeta=NULL,km=TRUE,...) {# {{{ xr <- recurrent dr <- death ### sets fixbeta based on wheter xr has been optimized in beta (so cox case) if (is.null(fixbeta)) if (is.null(xr$opt) | is.null(xr$coef)) fixbeta<- 1 else fixbeta <- 0 ### marginal expected events int_0^t G(s) \lambda_r(s) ds # {{{ strat <- dr$strata[dr$jumps] ### x <- dr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 S0i2[xx$jumps+1] <- 1/x$S0^2 ## survival at t- to also work in competing risks situation if (!km) { cumhazD <- c(cumsumstratasum(S0i,xx$strata,xx$nstrata)$lagsum) St <- exp(-cumhazD) } else St <- c(exp(cumsumstratasum(log(1-S0i),xx$strata,xx$nstrata)$lagsum)) x <- xr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 S0i2[xx$jumps+1] <- 1/x$S0^2 cumhazR <- cbind(xx$time,cumsumstrata(S0i,xx$strata,xx$nstrata)) cumhazDR <- cbind(xx$time,cumsumstrata(St*S0i,xx$strata,xx$nstrata)) mu <- cumhazDR[,2] # }}} ### robust standard errors ### 1. sum_k ( int_0^t S(s)/S_0^r(s) dM_k.^r(s) )^2 resIM1 <- squareintHdM(xr,ft=St,fixbeta=fixbeta) ### 2. mu(t)^2 * sum_k ( int_0^t 1/S_0^d(s) dM_k.^d(s) )^2 resIM2 <- squareintHdM(dr,ft=NULL,fixbeta=fixbeta) ### 3. sum_k( int_0^t mu(s) /S_0^d(s) dM_k.^d(s))^2 resIM3 <- squareintHdM(dr,ft=mu,fixbeta=fixbeta) varA <- resIM1$varInt+mu^2*resIM2$varInt+resIM3$varInt ## covariances between different terms 13 23 12 12 ## to allow different strata for xr and dr, but still nested strata if ((xr$nstrata>1 & dr$nstrata==1)) { cM1M3 <- covIntH1dM1IntH2dM2(resIM1,resIM3,fixbeta=fixbeta,mu=NULL) cM1M2 <- covIntH1dM1IntH2dM2(resIM1,resIM2,fixbeta=fixbeta,mu=mu) } else { cM1M3 <- covIntH1dM1IntH2dM2(resIM3,resIM1,fixbeta=fixbeta,mu=NULL) cM1M2 <- covIntH1dM1IntH2dM2(resIM2,resIM1,fixbeta=fixbeta,mu=mu) } cM2M3 <- covIntH1dM1IntH2dM2(resIM2,resIM3,fixbeta=fixbeta,mu=mu) varA <- varA+2*cM1M3$cov12A-2*cM1M2$cov12A-2*cM2M3$cov12A ### varA <- varA-2*cM1M3$cov12A+2*cM1M2$cov12A+2*cM2M3$cov12A cov12aa <- cov13aa <- cov23aa <- 0 if (fixbeta==0) { varA <-varA + cM2M3$covbeta - cM1M3$covbeta + cM1M2$covbeta } varrs <- data.frame(mu=mu,cumhaz=mu,se.mu=varA^.5,time=xr$time, se.cumhaz=varA^.5,strata=xr$strata,St=St) varrs <- varrs[c(xr$cox.prep$jumps)+1,] ### to use basehazplot.phreg ### making output such that basehazplot can work also out <- list(mu=varrs$mu,se.mu=varrs$se.mu,times=varrs$time, St=varrs$St, cumhaz=cbind(varrs$time,varrs$mu),se.cumhaz=cbind(varrs$time,varrs$se.mu), strata=varrs$strata,nstrata=xr$nstrata,jumps=1:nrow(varrs), strata.name=xr$strata.name,strata.level=recurrent$strata.level) return(out) }# }}} ###recurrentMarginal <- function(recurrent,death,fixbeta=NULL,km=FALSE,...) ###{# {{{ ### xr <- recurrent ### dr <- death ### ### ### sets fixbeta based on wheter xr has been optimized in beta (so cox case) ### if (is.null(fixbeta)) ### if (is.null(xr$opt) | is.null(xr$coef)) fixbeta<- 1 else fixbeta <- 0 ### ### ### marginal expected events int_0^t G(s) \lambda_r(s) ds ### # {{{ ### strat <- dr$strata[dr$jumps] ### ### ### x <- dr ### xx <- x$cox.prep ### S0i2 <- S0i <- rep(0,length(xx$strata)) ### S0i[xx$jumps+1] <- 1/x$S0 ### S0i2[xx$jumps+1] <- 1/x$S0^2 ### ## survival at t- to also work in competing risks situation ### if (!km) { ### cumhazD <- c(cumsumstratasum(S0i,xx$strata,xx$nstrata)$lagsum) ### St <- exp(-cumhazD) ### } else St <- c(exp(cumsumstratasum(log(1-S0i),xx$strata,xx$nstrata)$lagsum)) ### x <- xr ### xx <- x$cox.prep ### S0i2 <- S0i <- rep(0,length(xx$strata)) ### S0i[xx$jumps+1] <- 1/x$S0 ### S0i2[xx$jumps+1] <- 1/x$S0^2 ### cumhazR <- cbind(xx$time,cumsumstrata(S0i,xx$strata,xx$nstrata)) ### cumhazDR <- cbind(xx$time,cumsumstrata(St*S0i,xx$strata,xx$nstrata)) ### mu <- cumhazDR[,2] #### }}} ### ### test <- 0 ### ### robust standard errors ### ### 1. sum_k ( int_0^t S(s)/S_0^r(s) dM_k.^r(s) )^2 ### if (test==1) { #### {{{ ### x <- xr ### xx <- x$cox.prep ### S0i2 <- S0i <- rep(0,length(xx$strata)) ### S0i[xx$jumps+1] <- 1/x$S0 ### S0i2[xx$jumps+1] <- 1/x$S0^2 ### Z <- xx$X ### U <- E <- matrix(0,nrow(xx$X),x$p) ### E[xx$jumps+1,] <- x$E ### U[xx$jumps+1,] <- x$U ### ### ### cumhaz <- cbind(xx$time,cumsumstrata(S0i,xx$strata,xx$nstrata)) ### cumS0i2 <- cumsumstrata(St*S0i2,xx$strata,xx$nstrata) ### if (fixbeta==0) { ### EdLam0 <- apply(E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) ### Ht <- apply(St*E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) ### HtR <- Ht ### } ### if (fixbeta==0) rr <- c(xx$sign*exp(Z %*% coef(x) + xx$offset)) ### else rr <- c(xx$sign*exp(xx$offset)) ### id <- xx$id ### mid <- max(id)+1 ### ### also weights ### w <- c(xx$weights) ### xxx <- w*(St*S0i-rr*c(cumS0i2)) ### ssf <- cumsumidstratasum(xxx,id,mid,xx$strata,xx$nstrata)$sumsquare ### ss <- c(revcumsumidstratasum(w*rr,id,mid,xx$strata,xx$nstrata)$lagsumsquare)*c(cumS0i2^2) ### covv <- covfridstrata(xxx,w*rr,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2) ### varA1 <- c(ssf+ss+2*covv) ### cumS0i2R <- cumS0i2; xxxR <- xxx; rrR <- rr ### ### if (fixbeta==0) {# {{{ ### invhess <- -solve(x$hessian) ### MGt <- U[,drop=FALSE]-(Z*cumhaz[,2]-EdLam0)*rr*c(xx$weights) ### UU <- apply(MGt,2,sumstrata,id,max(id)+1) ### betaiidR <- UU %*% invhess ###### betaiidR <- iid(x) ### vbeta <- crossprod(betaiidR) ### varbetat <- rowSums((Ht %*% vbeta)*Ht) ### ### writing each beta for all individuals ### betakt <- betaiidR[id+1,,drop=FALSE] ### ### ### covk1 <- apply(xxx*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") ### covk2 <- apply(w*rr*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") ### covk2 <- c(covk2)*c(cumS0i2) ### ### ### varA1 <- varA1+varbetat-2*apply((covk1-covk2)*Ht,1,sum) ### }# }}} #### }}} ### } ### resIM1 <- squareintHdM(xr,ft=St,fixbeta=fixbeta,...) ### ### ### ### 2. mu(t)^2 * sum_k ( int_0^t 1/S_0^d(s) dM_k.^d(s) )^2 ### resIM2 <- squareintHdM(dr,ft=NULL,fixbeta=fixbeta,...) ### ### if (test==1) { #### {{{ ### x <- dr ### xx <- x$cox.prep ### S0i2 <- S0i <- rep(0,length(xx$strata)) ### S0i[xx$jumps+1] <- 1/x$S0 ### S0i2[xx$jumps+1] <- 1/x$S0^2 ### if (fixbeta==0) { ### Z <- xx$X ### U <- E <- matrix(0,nrow(xx$X),x$p) ### E[xx$jumps+1,] <- x$E ### U[xx$jumps+1,] <- x$U ### Ht <- apply(E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) ### } ### ### ### cumhaz <- cbind(xx$time,cumsumstrata(S0i,xx$strata,xx$nstrata)) ### cumS0i2 <- cumsumstrata(S0i2,xx$strata,xx$nstrata) ### if (fixbeta==0) rr <- c(xx$sign*exp(Z %*% coef(x) + xx$offset)) ### else rr <- c(xx$sign*exp(xx$offset)) ### id <- xx$id ### mid <- max(id)+1 ### ### also weights ### w <- c(xx$weights) ### xxx1 <- w*(S0i-rr*c(cumS0i2)) ### ssf <- cumsumidstratasum(xxx1,id,mid,xx$strata,xx$nstrata)$sumsquare ### ss <- c(revcumsumidstratasum(w*rr,id,mid,xx$strata,xx$nstrata)$lagsumsquare)*c(cumS0i2^2) ### covv <- covfridstrata(xxx1,w*rr,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2) ### varA2 <- mu^2*c(ssf+ss+2*covv) ### cumS0i2D1 <- cumS0i2 ### xxxD1 <- xxx1 ### rrD1 <- rr ### if (fixbeta==0) {# {{{ ### HtD1 <- mu*Ht ### invhess <- -solve(x$hessian) ### MGt <- U[,drop=FALSE]-(Z*cumhaz[,2]-Ht)*rr*c(xx$weights) ### UU <- apply(MGt,2,sumstrata,id,max(id)+1) ### betaiidD <- UU %*% invhess ###### betaiidD1 <- iid(x) ### vbetaD <- crossprod(betaiidD) ### varbetat <- rowSums((HtD1 %*% vbetaD)*HtD1) ### ### writing each beta for all individuals ### betakt <- betaiidD[id+1,,drop=FALSE] ### ### ### covk1 <- apply(xxx1*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") ### covk2 <- apply(w*rr*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") ### covk2 <- c(covk2)*c(cumS0i2D1) ### ### ### varA2 <- varA2+varbetat-2*apply((covk1-covk2)*HtD1*mu,1,sum) ### }# }}} ### #### }}} ### } ### ### ### 3. sum_k( int_0^t mu(s) /S_0^d(s) dM_k.^d(s))^2 ### if (test==1) { #### {{{ ### x <- dr ### xx <- x$cox.prep ### S0i2 <- S0i <- rep(0,length(xx$strata)) ### S0i[xx$jumps+1] <- 1/x$S0 ### S0i2[xx$jumps+1] <- 1/x$S0^2 ### if (fixbeta==0) { ### Z <- xx$X ### U <- E <- matrix(0,nrow(xx$X),x$p) ### E[xx$jumps+1,] <- x$E ### } ###### U[xx$jumps+1,] <- x$U ### xr$cox.prep$time - xx$time ### xr$cox.prep$time[xr$cox.prep$jumps+1] ### xr$cox.prep$time[dr$cox.prep$jumps+1] ### ### ### cumhaz <- cbind(xx$time,cumsumstrata(S0i,xx$strata,xx$nstrata)) ### cumS0i2 <- cumsumstrata(mu*S0i2,xx$strata,xx$nstrata) ### ### if (fixbeta==0) { ### EdLam0 <- apply(E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) ### Ht <- apply(mu*E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) ### HtD <- Ht ### } ### if (fixbeta==0) rr <- c(xx$sign*exp(Z %*% coef(x) + xx$offset)) ### else rr <- c(xx$sign*exp(xx$offset)) ### id <- xx$id ### mid <- max(id)+1 ### ### also weights ### w <- c(xx$weights) ### xxx <- w*(mu*S0i-rr*c(cumS0i2)) ### ssf <- cumsumidstratasum(xxx,id,mid,xx$strata,xx$nstrata)$sumsquare ### ss <- c(revcumsumidstratasum(w*rr,id,mid,xx$strata,xx$nstrata)$lagsumsquare)*c(cumS0i2^2) ### covv <- covfridstrata(xxx,w*rr,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2) ### varA3 <- c(ssf+ss+2*covv) ### cumS0i2D <- cumS0i2 ### rrD <- rr ### xxxD <- xxx ### ### if (fixbeta==0) {# {{{ ### invhess <- -solve(x$hessian) ### varbetat <- rowSums((Ht %*% vbetaD)*Ht) ### ### writing each beta for all individuals ### covk1 <- apply(xxx*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") ### covk2 <- apply(w*rr*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") ### covk2 <- c(covk2)*c(cumS0i2) ### ### ### varA3 <- varA3+varbetat-2*apply((covk1-covk2)*Ht,1,sum) ### }# }}} ### varA <- varA1+varA2+varA3 #### }}} ### } ### resIM3 <- squareintHdM(dr,ft=mu,fixbeta=fixbeta,...) ### varA <- resIM1$varInt+mu^2*resIM2$varInt+resIM3$varInt ### ### if (test==1) {# {{{ ### print("=====var ================="); ### print(summary(varA1)) ### print(summary(varA2)); ### print(summary(varA3)); ### print("--------------------------"); ### print(summary(resIM1$varInt)) ### print(summary(mu^2*resIM2$varInt)) ### print(summary(resIM3$varInt)) ### print("======================"); ### }# }}} ### ### ### covariances between different terms 13 23 12 12 ### if (test==1) { ### # {{{ ### cov23<-c(cumsumidstratasumCov(xxxD,xxxD1,id,mid,xx$strata,xx$nstrata)$sumsquare) ### cov232<-c(revcumsumidstratasum(w*rrD,id,mid,xx$strata,xx$nstrata)$lagsumsquare)*c(cumS0i2D*cumS0i2D1) ###### cov232<-c(revcumsumidstratasumCov(w*rrD,w*w*rrD,id,mid,xx$strata,xx$nstrata)$lagsumsquare)*c(cumS0i2D*cumS0i2D1) ### cov233 <- covfridstrata(xxxD,w*rrD1,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2D1) ###### cov233 <- covfridstrataCov(xxxD,w*rrD1,xxxD1,w*rrD1,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2D1) ### cov234 <- covfridstrata(xxxD1,w*rrD1,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2D) ###### cov234 <- covfridstrataCov(xxxD1,w*rrD1,xxxD,w*rrD,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2D) ### cov23A <- -c(cov23+(cov232+cov233+cov234))*mu ###### print(summary(cov23)) ###### print(summary(cov232)) ###### print(summary(cov233)) ###### print(summary(cov234)) ###### print(" ====================== 23 slut ") ###### ### ### cov12 <- c(cumsumidstratasumCov(xxxR,xxxD1,id,mid,xx$strata,xx$nstrata)$sumsquare) ### cov122 <- c(revcumsumidstratasumCov(w*rrR,w*rrD1,id,mid,xx$strata,xx$nstrata)$lagsumsquare)*c(cumS0i2R*cumS0i2D1) ### cov123 <- covfridstrataCov(xxxR,w*rrR,xxxD1,w*rrD1,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2D1) ### cov124 <- covfridstrataCov(xxxD1,w*rrD1,xxxR,w*rrR,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2R) ### cov12A <- -c(cov12+cov122+cov123+cov124)*mu ### print("________________12____________________"); ### print(summary(c(xxxR))); print(summary(c(xxxD1))); ### print(summary(c(rrD1))); print(summary(c(rrR))) ### print(summary(c(cumS0i2R))); print(summary(c(cumS0i2D1))) ### print(summary(cov12)); ### print(summary(cov122)); ### print(summary(c(cov123))); ### print(summary(c(cov124))); ### print("______________________________________"); ### ###### ### cov13 <- c(cumsumidstratasumCov(xxxR,xxxD,id,mid,xx$strata,xx$nstrata)$sumsquare) ### cov132 <- c(revcumsumidstratasumCov(w*rrR,w*rrD,id,mid,xx$strata,xx$nstrata)$lagsumsquare)*c(cumS0i2R*cumS0i2D) ### cov133 <- covfridstrataCov(xxxR,w*rrR,xxxD,w*rrD,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2D) ### cov134 <- covfridstrataCov(xxxD,w*rrD,xxxR,w*rrR,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2R) ###### ### cov13A <- c(cov13+(cov132+cov133+cov134)) ### varAg <- varA+2*cov12A+2*cov23A+2*cov13A #### }}} ### } ### ### ###cM1M3 <- covIntH1dM1IntH2dM2(resIM3,resIM1,fixbeta=fixbeta,mu=NULL) ###cM1M2 <- covIntH1dM1IntH2dM2(resIM2,resIM1,fixbeta=fixbeta,mu=mu) ###cM2M3 <- covIntH1dM1IntH2dM2(resIM2,resIM3,fixbeta=fixbeta,mu=mu) ### ######print(lapply(cM1M3,summary)) ######cM1M3 <- covIntH1dM1IntH2dM2(resIM1,resIM3,fixbeta=fixbeta,mu=NULL) ######print(lapply(cM1M3,summary)) ######print("____________________________") ######print(lapply(cM1M2,summary)) ######cM1M2 <- covIntH1dM1IntH2dM2(resIM1,resIM2,fixbeta=fixbeta,mu=mu) ######print(lapply(cM1M2,summary)) ######print("____________________________") ###### ######print(lapply(cM2M3,summary)) ######cM2M3 <- covIntH1dM1IntH2dM2(resIM2,resIM3,fixbeta=fixbeta,mu=mu) ######print(lapply(cM2M3,summary)) ######print("____________________________") ### ### ### if (test==1) {# {{{ ### print("=======cov AAA==============="); ### print(summary(cov13A)) ### print(summary(cov12A)) ### print(summary(cov23A)) ### print("_______________________________"); ### print(summary(cM1M3$cov12A)) ### print(summary(-1*cM1M2$cov12A)) ### print(summary(-1*cM2M3$cov12A)) ### print("======================"); ### }# }}} ### varA <- varA+2*cM1M3$cov12A-2*cM1M2$cov12A-2*cM2M3$cov12A ### ### if (test==1) {# {{{ ### print(" var Ag"); ### print(summary(varAg)); ### print(" var A"); ### print(summary(varA)); ### }# }}} ### ### cov12aa <- cov13aa <- cov23aa <- 0 ### if (fixbeta==0 & test==1 ) { ### ### covariances between different terms and beta's ### # {{{ ### covbetaRD <- t(betaiidR) %*% betaiidD ### DHt <- HtD1-HtD ### ### covbeta1.23 <- -2*rowSums((HtR %*% covbetaRD)*DHt) ### covbeta1.12 <- -2*rowSums((HtR %*% covbetaRD)*HtD1) ### covbeta1.13 <- 2*rowSums((HtR %*% covbetaRD)*HtD) ### covbetaD.23 <- -2*rowSums((HtD %*% vbetaD)*(HtD1)) ### ### ### D versus betaD from two terms cov23 wrt beta ### betakt <- betaiidD[id+1,,drop=FALSE] ### covk1 <-apply(xxxD1*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") ### covk2 <-apply(w*rrD1*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") ### covk2 <- c(covk2)*c(cumS0i2D1) ### covD1.D <- 2*apply((covk1-covk2)*mu*HtD,1,sum) ### ### ### covk1 <-apply(xxxD*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") ### covk2 <-apply(w*rrD*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") ### covk2 <- c(covk2)*c(cumS0i2D) ### covD.D1 <- 2*apply((covk1-covk2)*HtD1,1,sum) ### cov23aa <- covbetaD.23 + covD1.D + covD.D1 ### ### ### cov12 wrt betaD and betaR ### betakt <- betaiidD[id+1,,drop=FALSE] ### covk1 <-apply(xxxR*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") ### covk2 <-apply(w*rrR*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") ### covk2 <- c(covk2)*c(cumS0i2R) ### covRD12 <- 2*apply((covk1-covk2)*HtD1,1,sum) ### ### ### betakt <- betaiidR[id+1,,drop=FALSE] ### covk1 <-apply(xxxD1*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") ### covk2 <-apply(w*rrD1*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") ### covk2 <- c(covk2)*c(cumS0i2D1) ### covRD21 <- 2*apply((covk1-covk2)*mu*HtR,1,sum) ### cov12aa <- covbeta1.12 + covRD12+covRD21 ###### print("--------12------") ###### print(summary(covbeta1.12)) ###### print(summary(covRD12)) ###### print(summary(covRD21)) ###### print("--------------") ### ### ### ### cov13 wrt betaD and betaR ### betakt <- betaiidD[id+1,,drop=FALSE] ### covk1 <-apply(xxxR*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") ### covk2 <-apply(w*rrR*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") ### covk2 <- c(covk2)*c(cumS0i2R) ### covRD13 <- -2*apply((covk1-covk2)*HtD,1,sum) ### ### ### betakt <- betaiidR[id+1,,drop=FALSE] ### covk1 <-apply(xxxD*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") ### covk2 <-apply(w*rrD*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") ### covk2 <- c(covk2)*c(cumS0i2D) ### covRD31 <- -2*apply((covk1-covk2)*HtR,1,sum) ### cov13aa <- covbeta1.13 + covRD13+covRD31 ### varAg <-varA+ cov23aa+cov13aa+cov12aa #### }}} ### } ### ### if (test==1) { ### print("=========cov beta============"); ### print(summary(cov13aa)) ### print(summary(cov12aa)) ### print(summary(cov23aa)) ### print("_______________________________"); ### print(summary(-1*cM1M3$covbeta)); ### print(summary(cM1M2$covbeta)) ### print(summary(cM2M3$covbeta)); ### print("======================"); ### } ### ### if (fixbeta==0) { ### varA <-varA+ cM2M3$covbeta - cM1M3$covbeta + cM1M2$covbeta ### if (test==1) { ### print(summary(varAg)) ### print(summary(varA)) ### } ### } ### ### varrs <- data.frame(mu=mu,cumhaz=mu,se.mu=varA^.5,time=xr$time, ### se.cumhaz=varA^.5,strata=xr$strata,St=St) ### varrs <- varrs[c(xr$cox.prep$jumps)+1,] ### ### ### to use basehazplot.phreg ### ### making output such that basehazplot can work also ### out <- list(mu=varrs$mu,se.mu=varrs$se.mu,times=varrs$time, ### St=varrs$St, ### cumhaz=cbind(varrs$time,varrs$mu),se.cumhaz=cbind(varrs$time,varrs$se.mu), ### strata=varrs$strata,nstrata=xr$nstrata,jumps=1:nrow(varrs), ### strata.name=xr$strata.name,strata.level=recurrent$strata.level) ### return(out) ###}# }}} ##' @export recurrentMarginalIPCW <- function(rr,km=TRUE,times=NULL,...) {# {{{ # to ovoid R check warning death <- revnr <- NULL rr$revnr <- NULL rr$cens <- 0 rr <- count.history(rr) ### dsort(rr) <- ~id-start nid <- max(rr$id) rr$revnr <- cumsumstrata(rep(1,nrow(rr)),rr$id-1,nid) dsort(rr) <- ~id+start rr <- dtransform(rr,cens=1,revnr==1 & death==0) xr <- phreg(Surv(entry,time,status==1)~Count1+death+cluster(id),data=rr,no.opt=TRUE) cr <- phreg(Surv(entry,time,cens)~cluster(id),data=rr) dr <- phreg(Surv(entry,time,death)~cluster(id),data=rr) ### censoring weights strat <- cr$strata[cr$jumps] ### x <- cr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 S0i2[xx$jumps+1] <- 1/x$S0^2 ## survival at t- to also work in competing risks situation if (!km) { cumhazD <- c(cumsumstratasum(S0i,xx$strata,xx$nstrata)$lagsum) St <- exp(-cumhazD) } else St <- c(exp(cumsumstratasum(log(1-S0i),xx$strata,xx$nstrata)$lagsum)) #### x <- xr xx <- xr$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 S0i2[xx$jumps+1] <- 1/x$S0^2 ## stay with N(D_i) when t is large so no -1 when death signm <- xx$sign signm[xx$X[,2]==1 & xx$sign==-1] <- 0 ### Nt <- revcumsumstrata(xx$X[,1]*xx$sign,xx$strata,xx$nstrata) Nt <- Nt/St ## counting N(D) forward in time skal ikke checke ud når man dør N_(D_i) er i spil efter D_i NtD <- cumsumstrata(xx$X[,1]*(xx$X[,2]==1)*(xx$sign==1)/St,xx$strata,xx$nstrata) risk <- revcumsumstrata(xx$sign,xx$strata,xx$nstrata) timeJ <- xx$time[xx$jumps+1] avNtD <- (NtD+Nt)[xx$jumps+1]/nid xxJ <- xx$jumps+1 cumhaz <- cbind(timeJ,avNtD) ## correction for censoring terms ### x <- cr ### xx <- x$cox.prep ### E <- S0i2 <- S0i <- rep(0,length(xx$strata)) ### S0i[xx$jumps+1] <- 1/x$S0 ### S0i2[xx$jumps+1] <- x$E ### E[xx$jumps+1] <- 1/x$S0^2 ### ### ### cumS0i2 <- c(cumsumstrata(xx$X[,1]*risk*S0i2,xx$strata,xx$nstrata)) ### cor1 <- (cumsum(E - cumsum(E*risk*cumS0i2)) ### corMC <- (-cor1)/nid ### xrc <- phreg(Surv(entry,time,status==1)~Count1+cluster(id),data=rr,no.opt=TRUE) ### corMC <- cumsum(c(xrc$E)) ### corMC <- Cpred(cbind(xrc$jumptimes,corMC),timeJ)[,2] ### ### cumhaz.eff <- cbind(timeJ,avNtD+corMC) ### return(list(cumhaz=cumhaz,cumhaz.eff=cumhaz.eff)) return(list(cumhaz=cumhaz)) }# }}} ##' @export recurrentMarginalgam <- function(recurrent,death,fixbeta=NULL,km=TRUE,...) {# {{{ xr <- recurrent dr <- death ### sets fixbeta based on wheter xr has been optimized in beta (so cox case) if (is.null(fixbeta)) if (is.null(xr$opt) | is.null(xr$coef)) fixbeta<- 1 else fixbeta <- 0 ### marginal expected events int_0^t G(s) \lambda_r(s) ds # {{{ strat <- dr$strata[dr$jumps] ### x <- dr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 S0i2[xx$jumps+1] <- 1/x$S0^2 ## survival at t- to also work in competing risks situation if (!km) { cumhazD <- c(cumsumstratasum(S0i,xx$strata,xx$nstrata)$lagsum) St <- exp(-cumhazD) } else St <- c(exp(cumsumstratasum(log(1-S0i),xx$strata,xx$nstrata)$lagsum)) x <- xr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 S0i2[xx$jumps+1] <- 1/x$S0^2 cumhazR <- cbind(xx$time,cumsumstrata(S0i,xx$strata,xx$nstrata)) cumhazDR <- cbind(xx$time,cumsumstrata(St*S0i,xx$strata,xx$nstrata)) mu <- cumhazDR[,2] # }}} ### robust standard errors ### 1. sum_k ( int_0^t S(s)/S_0^r(s) dM_k.^r(s) )^2 # {{{ x <- xr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 S0i2[xx$jumps+1] <- 1/x$S0^2 Z <- xx$X U <- E <- matrix(0,nrow(xx$X),x$p) E[xx$jumps+1,] <- x$E U[xx$jumps+1,] <- x$U ### cumhaz <- cbind(xx$time,cumsumstrata(S0i,xx$strata,xx$nstrata)) cumS0i2 <- cumsumstrata(St*S0i2,xx$strata,xx$nstrata) if (fixbeta==0) { EdLam0 <- apply(E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) Ht <- apply(St*E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) HtR <- Ht } if (fixbeta==0) rr <- c(xx$sign*exp(Z %*% coef(x) + xx$offset)) else rr <- c(xx$sign*exp(xx$offset)) id <- xx$id mid <- max(id)+1 ### also weights w <- c(xx$weights) xxx <- w*(St*S0i-rr*c(cumS0i2)) ssf <- cumsumidstratasum(xxx,id,mid,xx$strata,xx$nstrata)$sumsquare ss <- c(revcumsumidstratasum(w*rr,id,mid,xx$strata,xx$nstrata)$lagsumsquare)*c(cumS0i2^2) covv <- covfridstrata(xxx,w*rr,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2) varA1 <- c(ssf+ss+2*covv) cumS0i2R <- cumS0i2; xxxR <- xxx; rrR <- rr if (fixbeta==0) {# {{{ invhess <- -solve(x$hessian) MGt <- U[,drop=FALSE]-(Z*cumhaz[,2]-EdLam0)*rr*c(xx$weights) UU <- apply(MGt,2,sumstrata,id,max(id)+1) betaiidR <- UU %*% invhess ### betaiidR <- iid(x) vbeta <- crossprod(betaiidR) varbetat <- rowSums((Ht %*% vbeta)*Ht) ### writing each beta for all individuals betakt <- betaiidR[id+1,,drop=FALSE] ### covk1 <- apply(xxx*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") covk2 <- apply(w*rr*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") covk2 <- c(covk2)*c(cumS0i2) ### varA1 <- varA1+varbetat-2*apply((covk1-covk2)*Ht,1,sum) }# }}} # }}} ### 2. mu(t)^2 * sum_k ( int_0^t 1/S_0^d(s) dM_k.^d(s) )^2 # {{{ x <- dr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 S0i2[xx$jumps+1] <- 1/x$S0^2 if (fixbeta==0) { Z <- xx$X U <- E <- matrix(0,nrow(xx$X),x$p) E[xx$jumps+1,] <- x$E U[xx$jumps+1,] <- x$U Ht <- apply(E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) } ### cumhaz <- cbind(xx$time,cumsumstrata(S0i,xx$strata,xx$nstrata)) cumS0i2 <- cumsumstrata(S0i2,xx$strata,xx$nstrata) if (fixbeta==0) rr <- c(xx$sign*exp(Z %*% coef(x) + xx$offset)) else rr <- c(xx$sign*exp(xx$offset)) id <- xx$id mid <- max(id)+1 ### also weights w <- c(xx$weights) xxx1 <- w*(S0i-rr*c(cumS0i2)) ssf <- cumsumidstratasum(xxx1,id,mid,xx$strata,xx$nstrata)$sumsquare ss <- c(revcumsumidstratasum(w*rr,id,mid,xx$strata,xx$nstrata)$lagsumsquare)*c(cumS0i2^2) covv <- covfridstrata(xxx1,w*rr,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2) varA2 <- mu^2*c(ssf+ss+2*covv) cumS0i2D1 <- cumS0i2 xxxD1 <- xxx1 rrD1 <- rr if (fixbeta==0) {# {{{ HtD1 <- mu*Ht invhess <- -solve(x$hessian) MGt <- U[,drop=FALSE]-(Z*cumhaz[,2]-Ht)*rr*c(xx$weights) UU <- apply(MGt,2,sumstrata,id,max(id)+1) betaiidD <- UU %*% invhess ### betaiidD1 <- iid(x) vbetaD <- crossprod(betaiidD) varbetat <- rowSums((HtD1 %*% vbetaD)*HtD1) ### writing each beta for all individuals betakt <- betaiidD[id+1,,drop=FALSE] ### covk1 <- apply(xxx1*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") covk2 <- apply(w*rr*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") covk2 <- c(covk2)*c(cumS0i2D1) ### varA2 <- varA2+varbetat-2*apply((covk1-covk2)*HtD1*mu,1,sum) }# }}} # }}} ### 3. sum_k( int_0^t mu(s) /S_0^d(s) dM_k.^d(s))^2 # {{{ x <- dr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 S0i2[xx$jumps+1] <- 1/x$S0^2 if (fixbeta==0) { Z <- xx$X U <- E <- matrix(0,nrow(xx$X),x$p) E[xx$jumps+1,] <- x$E } ### U[xx$jumps+1,] <- x$U xr$cox.prep$time - xx$time xr$cox.prep$time[xr$cox.prep$jumps+1] xr$cox.prep$time[dr$cox.prep$jumps+1] ### cumhaz <- cbind(xx$time,cumsumstrata(S0i,xx$strata,xx$nstrata)) cumS0i2 <- cumsumstrata(mu*S0i2,xx$strata,xx$nstrata) if (fixbeta==0) { EdLam0 <- apply(E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) Ht <- apply(mu*E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) HtD <- Ht } if (fixbeta==0) rr <- c(xx$sign*exp(Z %*% coef(x) + xx$offset)) else rr <- c(xx$sign*exp(xx$offset)) id <- xx$id mid <- max(id)+1 ### also weights w <- c(xx$weights) xxx <- w*(mu*S0i-rr*c(cumS0i2)) ssf <- cumsumidstratasum(xxx,id,mid,xx$strata,xx$nstrata)$sumsquare ss <- c(revcumsumidstratasum(w*rr,id,mid,xx$strata,xx$nstrata)$lagsumsquare)*c(cumS0i2^2) covv <- covfridstrata(xxx,w*rr,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2) varA3 <- c(ssf+ss+2*covv) cumS0i2D <- cumS0i2 rrD <- rr xxxD <- xxx if (fixbeta==0) {# {{{ invhess <- -solve(x$hessian) varbetat <- rowSums((Ht %*% vbetaD)*Ht) ### writing each beta for all individuals covk1 <- apply(xxx*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") covk2 <- apply(w*rr*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") covk2 <- c(covk2)*c(cumS0i2) ### varA3 <- varA3+varbetat-2*apply((covk1-covk2)*Ht,1,sum) }# }}} varA <- varA1+varA2+varA3 # }}} ### covariances between different terms 13 23 12 12 # {{{ cov23<-c(cumsumidstratasumCov(xxxD,xxxD1,id,mid,xx$strata,xx$nstrata)$sumsquare) cov232<-c(revcumsumidstratasum(w*rrD,id,mid,xx$strata,xx$nstrata)$lagsumsquare)*c(cumS0i2D*cumS0i2D1) ### cov232<-c(revcumsumidstratasumCov(w*rrD,w*w*rrD,id,mid,xx$strata,xx$nstrata)$lagsumsquare)*c(cumS0i2D*cumS0i2D1) cov233 <- covfridstrata(xxxD,w*rrD1,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2D1) ### cov233 <- covfridstrataCov(xxxD,w*rrD1,xxxD1,w*rrD1,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2D1) cov234 <- covfridstrata(xxxD1,w*rrD1,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2D) ### cov234 <- covfridstrataCov(xxxD1,w*rrD1,xxxD,w*rrD,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2D) cov23A <- -c(cov23+(cov232+cov233+cov234))*mu ### print(summary(cov23)) ### print(summary(cov232)) ### print(summary(cov233)) ### print(summary(cov234)) ### print(" ====================== 23 slut ") ### cov12 <- c(cumsumidstratasumCov(xxxR,xxxD1,id,mid,xx$strata,xx$nstrata)$sumsquare) cov122 <- c(revcumsumidstratasumCov(w*rrR,w*rrD1,id,mid,xx$strata,xx$nstrata)$lagsumsquare)*c(cumS0i2R*cumS0i2D1) cov123 <- covfridstrataCov(xxxR,w*rrR,xxxD,w*rrD1,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2D1) cov124 <- covfridstrataCov(xxxD1,w*rrD1,xxxR,w*rrR,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2R) cov12A <- -c(cov12+(cov122+cov123+cov124))*mu ### cov13 <- c(cumsumidstratasumCov(xxxR,xxxD,id,mid,xx$strata,xx$nstrata)$sumsquare) cov132 <- c(revcumsumidstratasumCov(w*rrR,w*rrD,id,mid,xx$strata,xx$nstrata)$lagsumsquare)*c(cumS0i2R*cumS0i2D) cov133 <- covfridstrataCov(xxxR,w*rrR,xxxD,w*rrD,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2D) cov134 <- covfridstrataCov(xxxD,w*rrD,xxxR,w*rrR,id,mid,xx$strata,xx$nstrata)$covs*c(cumS0i2R) ### cov13A <- c(cov13+(cov132+cov133+cov134)) varA <- varA+2*cov12A+2*cov23A+2*cov13A # }}} cov12aa <- cov13aa <- cov23aa <- 0 if (fixbeta==0) { ### covariances between different terms and beta's # {{{ covbetaRD <- t(betaiidR) %*% betaiidD ### DHt <- HtD1-HtD ### covbeta1.23 <- -2*rowSums((HtR %*% covbetaRD)*DHt) covbeta1.12 <- -2*rowSums((HtR %*% covbetaRD)*HtD1) covbeta1.13 <- 2*rowSums((HtR %*% covbetaRD)*HtD) covbetaD.23 <- -2*rowSums((HtD %*% vbetaD)*(HtD1)) ### D versus betaD from two terms cov23 wrt beta betakt <- betaiidD[id+1,,drop=FALSE] covk1 <-apply(xxxD1*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") covk2 <-apply(w*rrD1*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") covk2 <- c(covk2)*c(cumS0i2D1) covD1.D <- 2*apply((covk1-covk2)*mu*HtD,1,sum) ### covk1 <-apply(xxxD*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") covk2 <-apply(w*rrD*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") covk2 <- c(covk2)*c(cumS0i2D) covD.D1 <- 2*apply((covk1-covk2)*HtD1,1,sum) cov23aa <- (covbetaD.23 + covD1.D + covD.D1) ### print("D1D_________________") ### print(summary(covbetaD.23)) ### print(summary(covD1.D)) ### print(summary(covD.D1)) ### cov12 wrt betaD and betaR betakt <- betaiidD[id+1,,drop=FALSE] covk1 <-apply(xxxR*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") covk2 <-apply(w*rrR*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") covk2 <- c(covk2)*c(cumS0i2R) covRD12 <- 2*apply((covk1-covk2)*HtD1,1,sum) ### betakt <- betaiidR[id+1,,drop=FALSE] covk1 <-apply(xxxD1*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") covk2 <-apply(w*rrD1*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") covk2 <- c(covk2)*c(cumS0i2D1) covRD21 <- 2*apply((covk1-covk2)*mu*HtR,1,sum) cov12aa <- covbeta1.12 + covRD12+covRD21 ### print("RD12_________________") ### print(summary(covbeta1.12)) ### print(summary(covRD12)) ### print(summary(covRD21)) ### cov13 wrt betaD and betaR betakt <- betaiidD[id+1,,drop=FALSE] covk1 <-apply(xxxR*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") covk2 <-apply(w*rrR*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") covk2 <- c(covk2)*c(cumS0i2R) covRD13 <- -2*apply((covk1-covk2)*HtD,1,sum) ### betakt <- betaiidR[id+1,,drop=FALSE] covk1 <-apply(xxxD*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") covk2 <-apply(w*rrD*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") covk2 <- c(covk2)*c(cumS0i2D) covRD31 <- -2*apply((covk1-covk2)*HtR,1,sum) cov13aa <- covbeta1.13 + covRD13+covRD31 ### print("RD13_________________") ### print(summary(covbeta1.13)) ### print(summary(covRD13)) ### print(summary(covRD31)) varA <-varA+ cov23aa+cov13aa+cov12aa # }}} } ### varrs <- data.frame(mu=mu,cumhaz=mu,se.mu=varA^.5,time=xr$time,se.cumhaz=varA^.5,strata=xr$strata,St=St) ### varA1=varA1,varA2=varA2,varA3=varA3,cov12=2*cov12A+cov12aa,cov13=2*cov13A+cov13aa, ### cov23=2*cov23A+cov23aa); varrs <- varrs[c(xr$cox.prep$jumps)+1,] ### to use basehazplot.phreg ### making output such that basehazplot can work also out <- list(mu=varrs$mu,se.mu=varrs$se.mu,times=varrs$time, St=varrs$St, cumhaz=cbind(varrs$time,varrs$mu),se.cumhaz=cbind(varrs$time,varrs$se.mu), strata=varrs$strata,nstrata=xr$nstrata,jumps=1:nrow(varrs),strata.name=xr$strata.name, strata.level=recurrent$strata.level) ### vari=varrs[,c("varA1","varA2","varA3")],covs=varrs[,c("cov12","cov13","cov23")]) return(out) }# }}} ##' @export recmarg <- function(recurrent,death,Xr=NULL,Xd=NULL,km=TRUE,...) {# {{{ xr <- recurrent dr <- death if (!is.null(Xr)) rr <- exp(sum(xr$coef * Xr)) else rr <- 1 if (!is.null(Xd)) rrd <- exp(sum(dr$coef * Xd)) else rrd <- 1 ### marginal expected events int_0^t G(s) \lambda_r(s) ds # {{{ strat <- dr$strata[dr$jumps] x <- dr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 S0i2[xx$jumps+1] <- 1/x$S0^2 if (!km) { cumhazD <- c(cumsumstratasum(S0i,xx$strata,xx$nstrata)$lagsum) St <- exp(-cumhazD*rrd) } else St <- exp(rrd*c(cumsumstratasum(log(1-S0i),xx$strata,xx$nstrata)$lagsum)) ### x <- xr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 S0i2[xx$jumps+1] <- 1/x$S0^2 cumhazDR <- cbind(xx$time,cumsumstrata(St*S0i,xx$strata,xx$nstrata)) mu <- rr*cumhazDR[,2] # }}} varrs <- data.frame(mu=mu,time=xr$time,strata=xr$strata,St=St) varrs <- varrs[c(xr$cox.prep$jumps)+1,] ### to use basehazplot.phreg ### making output such that basehazplot can work also out <- list(mu=varrs$mu,time=varrs$time, St=varrs$St,cumhaz=cbind(varrs$time,varrs$mu), strata=varrs$strata,nstrata=xr$nstrata,jumps=1:nrow(varrs), strata.name=xr$strata.name,strata.level=recurrent$strata.level) return(out) }# }}} ##' @export squareintHdM <- function(phreg,ft=NULL,fixbeta=NULL,...) {# {{{ ### sum_k ( int_0^t f(s)/S_0^r(s) dM_k.^r(s) )^2 ### strata "r" from object and "k" id from cluster if (class(phreg)!="phreg") stop("Must be phreg object\n"); ### sets fixbeta based on wheter xr has been optimized in beta (so cox case) if (is.null(fixbeta)) if (is.null(phreg$opt) | is.null(phreg$coef)) fixbeta<- 1 else fixbeta <- 0 x <- phreg xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 S0i2[xx$jumps+1] <- 1/x$S0^2 Z <- xx$X U <- E <- matrix(0,nrow(xx$X),x$p) E[xx$jumps+1,] <- x$E U[xx$jumps+1,] <- x$U ### cumhaz <- cbind(xx$time,cumsumstrata(S0i,xx$strata,xx$nstrata)) if (is.null(ft)) ft <- rep(1,length(xx$time)) cumS0i2 <- c(cumsumstrata(ft*S0i2,xx$strata,xx$nstrata)) if (fixbeta==0) { EdLam0 <- apply(E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) Ht <- apply(ft*E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) } else Ht <- NULL if (fixbeta==0) rr <- c(xx$sign*exp(Z %*% coef(x) + xx$offset)) else rr <- c(xx$sign*exp(xx$offset)) id <- xx$id mid <- max(id)+1 ### also weights w <- c(xx$weights) xxx <- (ft*S0i-rr*cumS0i2) ssf <- cumsumidstratasum(xxx,id,mid,xx$strata,xx$nstrata)$sumsquare ss <- revcumsumidstratasum(w*rr,id,mid,xx$strata,xx$nstrata)$lagsumsquare*cumS0i2^2 covv <- covfridstrata(xxx,w*rr,id,mid,xx$strata,xx$nstrata)$covs*cumS0i2 varA1 <- c(ssf+ss-2*covv) vbeta <- betaiidR <- NULL if (fixbeta==0) {# {{{ invhess <- -solve(x$hessian) MGt <- U[,drop=FALSE]-(Z*cumhaz[,2]-EdLam0)*rr*c(xx$weights) UU <- apply(MGt,2,sumstrata,id,mid) betaiidR <- UU %*% invhess vbeta <- crossprod(betaiidR) varbetat <- rowSums((Ht %*% vbeta)*Ht) ### writing each beta for all individuals betakt <- betaiidR[id+1,,drop=FALSE] ### covk1 <- apply(xxx*betakt,2,cumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="sum") covk2 <- apply(w*rr*betakt,2,revcumsumidstratasum,id,mid,xx$strata,xx$nstrata,type="lagsum") covk2 <- c(covk2)*cumS0i2 covv <- covk1-covk2 ### varA1 <- varA1+varbetat-2*apply(covv*Ht,1,sum) }# }}} return(list(xx=xx,Ht=Ht,varInt=varA1,xxx=xxx,rr=rr, cumhaz=cumhaz,cumS0i2=cumS0i2,mid=mid,id=id, betaiid=betaiidR,vbeta=vbeta,covv=covv)) } # }}} ##' @export covIntH1dM1IntH2dM2 <- function(square1,square2,fixbeta=1,mu=NULL) {# {{{ ### strata and id same for two objects xx <- square1$xx; xx2 <- square2$xx xxxR <- square1$xxx; xxxD1 <- square2$xxx rrR <- square1$rr; rrD1 <- square2$rr id <- id1 <- square1$id; id2 <- square2$id mid <- square1$mid; w <- c(xx$weights) if (is.null(mu)) mu <- rep(1,length(xx$strata)) cov12 <- c(cumsumidstratasumCov(xxxR,xxxD1,id,mid,xx$strata,xx$nstrata)$sumsquare) cov122 <- c(revcumsumidstratasumCov(w*rrR,w*rrD1,id,mid,xx$strata,xx$nstrata)$lagsumsquare)*c(square1$cumS0i2*square2$cumS0i2) cov123 <- covfridstrataCov(xxxR,w*rrR,xxxD1,w*rrD1,id,mid,xx$strata,xx$nstrata)$covs*c(square2$cumS0i2) cov124 <- covfridstrataCov(xxxD1,w*rrD1,xxxR,w*rrR,id,mid,xx$strata,xx$nstrata)$covs*c(square1$cumS0i2) cov12A <- c(cov12+cov122+cov123+cov124) test <- 0 if (test==1) {# {{{ print("________cov cov ___________________________"); print(summary(c(xxxR))); print(summary(c(xxxD1))); print(summary(c(rrD1))); print(summary(c(rrR))) print(summary(c(square1$cumS0i2))); print(summary(c(square2$cumS0i2))); print("-----------"); print(summary(cov12)); print(summary(cov122)); print(summary(c(cov123))); print(summary(c(cov124))); print("______________________________________"); jumps <- c(square1$xx$jumps,square2$xx$jumps)+1 print(summary(jumps)) print(summary(cov12[jumps])); print(summary(cov122[jumps])); print(summary(c(cov123[jumps]))); print(summary(c(cov124[jumps]))); }# }}} cov12aa <- 0 if (fixbeta==0) { ### covariances between different terms and beta's # {{{ betaiidR <- square1$betaiid; betaiidD <- square2$betaiid HtR <- square1$Ht; HtD <- square2$Ht covbetaRD <- t(betaiidR) %*% betaiidD covbeta <- -1*rowSums((HtR %*% covbetaRD)*HtD) ### print(summary(covbeta)) ### cov12 wrt betaD and betaR betakt <- betaiidD[id1+1,,drop=FALSE] covk1 <-apply(xxxR*betakt,2,cumsumidstratasum,id1,mid,xx$strata,xx$nstrata,type="sum") covk2 <-apply(w*rrR*betakt,2,revcumsumidstratasum,id1,mid,xx$strata,xx$nstrata,type="lagsum") covk2 <- c(covk2)*c(square1$cumS0i2) covRD12 <- apply((covk1-covk2)*HtD,1,sum) ### betakt <- betaiidR[id2+1,,drop=FALSE] covk1 <-apply(xxxD1*betakt,2,cumsumidstratasum,id2,mid,xx2$strata,xx$nstrata,type="sum") covk2 <-apply(w*rrD1*betakt,2,revcumsumidstratasum,id2,mid,xx2$strata,xx$nstrata,type="lagsum") covk2 <- c(covk2)*c(square2$cumS0i2) covRD21 <- apply((covk1-covk2)*HtR,1,sum) cov12aa <- 2*(covbeta + covRD12+covRD21) test <- 0 if (test==1) { print("--------------") print(summary(2*mu*covbeta)) print(summary(2*mu*covRD12)) print(summary(2*mu*covRD21)) print("--------------") } } # }}} cov12 <- (cov12A-cov12aa)*mu return(list(cov=cov12,cov12A=cov12A*mu,covbeta=cov12aa*mu)) } # }}} ##' @export tie.breaker <- function(data,stop="time",start="entry",status="status",id=NULL,ddt=NULL,exit.unique=TRUE) {# {{{ if (!is.null(id)) id <- data[,id] ord <- 1:nrow(data) stat <- data[,status] time <- data[,stop] dupexit <- duplicated(time) time1 <- data[stat==1,stop] time0 <- data[stat!=1,stop] lt0 <- length(time0) ddp <- duplicated(c(time0,time1)) if (exit.unique) ties <-ddp[(lt0+1):nrow(data)] else ties <- duplicated(c(time1)) nties <- sum(ties) ordties <- ord[stat==1][ties] if (is.null(ddt)) { abd <- abs(diff(data[,stop])) abd <- min(abd[abd>0]) ddt <- abd*0.5 } time[ordties] <- time[ordties]+runif(nties)*ddt data[ordties,stop] <- time[ordties] ties <- (ord %in% ordties) if (!is.null(id)) { lagties <- dlag(ties) ### also move next start time if id the same change.start <- lagties==TRUE & id==dlag(id) change.start[is.na(change.start)] <- FALSE ocs <- ord[change.start] data[ocs,start] <- data[ocs-1,stop] data[,"tiebreaker"] <- FALSE data[ocs,"tiebreaker"] <- TRUE } return(data) } # }}} ##' Simulation of recurrent events data based on cumulative hazards ##' ##' Simulation of recurrent events data based on cumulative hazards ##' ##' Must give hazard of death and recurrent events. Possible with two ##' event types and their dependence can be specified but the two recurrent events need ##' to have the same random effect, simRecurrentII more flexible ! ##' ##' @param n number of id's ##' @param cumhaz cumulative hazard of recurrent events ##' @param death.cumhaz cumulative hazard of death ##' @param cumhaz2 cumulative hazard of recurrent events of type 2 ##' @param gap.time if true simulates gap-times with specified cumulative hazard ##' @param max.recurrent limits number recurrent events to 100 ##' @param dhaz rate for death hazard if it is extended to time-range of first event ##' @param haz2 rate of second cause if it is extended to time-range of first event ##' @param dependence =0 independence, =1 all share same random effect with variance var.z ##' =2 random effect exp(normal) with correlation structure from cor.mat, ##' first random effect is z1 and shared for a possible second cause, second random effect is for death ##' @param var.z variance of random effects ##' @param cor.mat correlation matrix for var.z variance of random effects ##' @param ... Additional arguments to lower level funtions ##' @author Thomas Scheike ##' @examples ##' ######################################## ##' ## getting some rates to mimick ##' ######################################## ##' ##' data(base1cumhaz) ##' data(base4cumhaz) ##' data(drcumhaz) ##' dr <- drcumhaz ##' base1 <- base1cumhaz ##' base4 <- base4cumhaz ##' ##' ###################################################################### ##' ### simulating simple model that mimicks data ##' ###################################################################### ##' rr <- simRecurrent(5,base1,death.cumhaz=dr) ##' dlist(rr,.~id,n=0) ##' ##' rr <- simRecurrent(1000,base1,death.cumhaz=dr) ##' par(mfrow=c(1,3)) ##' showfitsim(causes=1,rr,dr,base1,base1) ##' ##' ###################################################################### ##' ### simulating simple model that mimicks data ##' ### now with two event types and second type has same rate as death rate ##' ###################################################################### ##' ##' rr <- simRecurrent(1000,base1,death.cumhaz=dr,cumhaz2=base4) ##' dtable(rr,~death+status) ##' par(mfrow=c(2,2)) ##' showfitsim(causes=2,rr,dr,base1,base4) ##' ##' ###################################################################### ##' ### simulating simple model ##' ### random effect for all causes (Z shared for death and recurrent) ##' ###################################################################### ##' ##' rr <- simRecurrent(1000,base1,death.cumhaz=dr,dependence=1,var.gamma=0.4) ##' ### marginals do fit after input after integrating out ##' par(mfrow=c(2,2)) ##' showfitsim(causes=1,rr,dr,base1,base1) ##' ##' @aliases showfitsim simRecurrentGamma covIntH1dM1IntH2dM2 recurrentMarginalgam squareintHdM addCums ##' @export simRecurrent <- function(n,cumhaz,death.cumhaz=NULL,cumhaz2=NULL, gap.time=FALSE,max.recurrent=100,dhaz=NULL,haz2=NULL, dependence=0,var.z=2,cor.mat=NULL,...) {# {{{ dtime <- NULL ## to avoid R-check ### drawing relative risk frailty terms to generate dependence if (dependence==0) { z1 <- z2 <- zd <- rep(1,n) # {{{ } else if (dependence==1) { ### zz <- rgamma(n,1/var.gamma[1])*var.gamma[1] zz <- exp(rnorm(n,1)*var.z[1]^.5) z1 <- zz; z2 <- zz; zd <- zz } else if (dependence==2) { stdevs <- var.z^.5 b <- stdevs %*% t(stdevs) covv <- b * cor.mat z <- matrix(rnorm(3*n),n,3) z <- (z%*% chol(covv)) z1 <- exp(z[,1]); zd <- exp(z[,3]) apply(exp(z),2,mean); cov(exp(z)) } else if (dependence==3) { zz <- rgamma(n,1/var.z[1])*var.z[1] z1 <- zz; z2 <- zz; zd <- rep(1,n) } # }}} cumhaz <- rbind(c(0,0),cumhaz) ## range max of cumhaz and cumhaz2 if (!is.null(cumhaz2)) { out <- extendCums(cumhaz,cumhaz2,both=TRUE,hazb=haz2) cumhaz <- out$cumA cumhaz2 <- out$cumB } ## extend cumulative for death to full range of cause 1 if (!is.null(death.cumhaz)) { out <- extendCums(cumhaz,death.cumhaz,hazb=dhaz) cumhazd <- out$cumB } ll <- nrow(cumhaz) max.time <- tail(cumhaz[,1],1) ## sum two cumulatives to get combined events if (!is.null(cumhaz2)) {# {{{ times <- sort(unique(c(cumhaz[,1],cumhaz2[,1]))) cumhaz1t <- approx(cumhaz[,1],cumhaz[,2],times,rule=2)$y cumhaz2t <- approx(cumhaz2[,1],cumhaz2[,2],times,rule=2)$y cumhaz1 <- cumhaz cumhaz <- cbind(times,cumhaz1t+cumhaz2t) }# }}} ### recurrent first time tall <- timereg::rchaz(cumhaz,z1) tall$id <- 1:n ### death time simulated if (!is.null(death.cumhaz)) { timed <- timereg::rchaz(cumhazd,zd) tall$dtime <- timed$time tall$fdeath <- timed$status } else { tall$dtime <- max.time; tall$fdeath <- 0; cumhazd <- NULL } ### fixing the first time to event tall$death <- 0 tall <- dtransform(tall,death=1,time>dtime) tall <- dtransform(tall,status=0,time>dtime) tall <- dtransform(tall,time=dtime,time>dtime) tt <- tall nrr <- n i <- 1; while (any(tt$timedtime) tt <- dtransform(tt,status=0,time>dtime) tt <- dtransform(tt,time=dtime,time>dtime) nt <- nrow(tt) tall <- rbind(tall,tt,row.names=NULL) nrr <- nrr+nt } dsort(tall) <- ~id+entry+time ### cause 2 is there then decide if jump is 1 or 2 if (!is.null(cumhaz2)) {# {{{ haz1 <- apply(cumhaz1,2,diff) haz1 <- haz1[,2]/haz1[,1] ## hazard2 at times haz2 <- apply(cumhaz2,2,diff) haz2 <- haz2[,2]/haz2[,1] ll1 <- nrow(cumhaz1) ll2 <- nrow(cumhaz2) haz1t <- timereg::Cpred(cbind(cumhaz1[-ll1,1],haz1),tall$time)[,2] haz2t <- timereg::Cpred(cbind(cumhaz2[-ll2,1],haz2),tall$time)[,2] p2t <- haz2t/(haz1t+haz2t) tall$p2t <- p2t tall$status <- (1+rbinom(nrow(tall),1,p2t))*(tall$status>=1) }# }}} tall$start <- tall$entry tall$stop <- tall$time attr(tall,"death.cumhaz") <- cumhazd attr(tall,"cumhaz") <- cumhaz attr(tall,"cumhaz2") <- cumhaz2 return(tall) }# }}} lin.approx <- function(x2,xfx,x=1) {# {{{ ### x=1 gives f(x2) ### x=-1 gives f^-1(x2) breaks <- xfx[,x] fx <- xfx[,-x] ri <- sindex.prodlim(breaks,x2) rrr <- (x2-breaks[ri])/(breaks[ri+1]-breaks[ri]) res <- rrr*(fx[ri+1]-fx[ri])+fx[ri] res[is.na(res)] <- tail(fx,1) return(res) }# ## }}} ##' @export addCums <- function(cumB,cumA,max=5) {# {{{ times <- sort(unique(c(cumB[,1],cumA[,1]))) times <- times[timesdtime) tall <- dtransform(tall,status=0,time>dtime) tall <- dtransform(tall,time=dtime,time>dtime) tt <- tall i <- 1; while (any(tt$timedtime) tt <- dtransform(tt,status=0,time>dtime) tt <- dtransform(tt,time=dtime,time>dtime) nt <- nrow(tt) tall <- rbind(tall,tt,row.names=NULL) } dsort(tall) <- ~id+entry+time ### cause 2 is there then decide if jump is 1 or 2 if (!is.null(haz2)) {# {{{ p2t <- haz2/(haz+haz2) tall$p2t <- p2t tall$status <- (1+rbinom(nrow(tall),1,p2t))*(tall$status>=1) }# }}} tall$start <- tall$entry tall$stop <- tall$time attr(tall,"death.cumhaz") <- cumhazd attr(tall,"cumhaz") <- cumhaz attr(tall,"cumhaz2") <- cumhaz2 ### haz*haz2*(var.z+1) return(tall) }# }}} ##' Simulation of recurrent events data based on cumulative hazards II ##' ##' Simulation of recurrent events data based on cumulative hazards ##' ##' Must give hazard of death and two recurrent events. Possible with two ##' event types and their dependence can be specified but the two recurrent events need ##' to share random effect. Based on drawing the from cumhaz and cumhaz2 and ##' taking the first event rather ##' the cumulative and then distributing it out. Key advantage of this is that ##' there is more flexibility wrt random effects ##' ##' @param n number of id's ##' @param cumhaz cumulative hazard of recurrent events ##' @param cumhaz2 cumulative hazard of recurrent events of type 2 ##' @param death.cumhaz cumulative hazard of death ##' @param gap.time if true simulates gap-times with specified cumulative hazard ##' @param max.recurrent limits number recurrent events to 100 ##' @param dhaz rate for death hazard if it is extended to time-range of first event ##' @param haz2 rate of second cause if it is extended to time-range of first event ##' @param dependence 0:independence; 1:all share same random effect with variance var.z; 2:random effect exp(normal) with correlation structure from cor.mat; 3:additive gamma distributed random effects, z1= (z11+ z12)/2 such that mean is 1 , z2= (z11^cor.mat(1,2)+ z13)/2, z3= (z12^(cor.mat(2,3)+z13^cor.mat(1,3))/2, with z11 z12 z13 are gamma with mean and variance 1 , first random effect is z1 and for N1 second random effect is z2 and for N2 third random effect is for death ##' @param var.z variance of random effects ##' @param cor.mat correlation matrix for var.z variance of random effects ##' @param cens rate of censoring exponential distribution ##' @param ... Additional arguments to lower level funtions ##' @author Thomas Scheike ##' @examples ##' ######################################## ##' ## getting some rates to mimick ##' ######################################## ##' ##' data(base1cumhaz) ##' data(base4cumhaz) ##' data(drcumhaz) ##' dr <- drcumhaz ##' base1 <- base1cumhaz ##' base4 <- base4cumhaz ##' ##' cor.mat <- corM <- rbind(c(1.0, 0.6, 0.9), c(0.6, 1.0, 0.5), c(0.9, 0.5, 1.0)) ##' ##' ###################################################################### ##' ### simulating simple model that mimicks data ##' ### now with two event types and second type has same rate as death rate ##' ###################################################################### ##' ##' rr <- simRecurrentII(1000,base1,base4,death.cumhaz=dr) ##' dtable(rr,~death+status) ##' par(mfrow=c(2,2)) ##' showfitsim(causes=2,rr,dr,base1,base4) ##' ##' @export simRecurrentII <- function(n,cumhaz,cumhaz2,death.cumhaz=NULL, gap.time=FALSE,max.recurrent=100,dhaz=NULL,haz2=NULL, dependence=0,var.z=0.22,cor.mat=NULL,cens=NULL,...) {# {{{ fdeath <- dtime <- NULL # to avoid R-check if (dependence==0) { z <- z1 <- z2 <- zd <- rep(1,n) # {{{ } else if (dependence==1) { z <- rgamma(n,1/var.z[1])*var.z[1] ### z <- exp(rnorm(n,1)*var.z[1]^.5) z1 <- z; z2 <- z; zd <- z if (!is.null(cor.mat)) { zd <- rep(1,n); } } else if (dependence==2) { stdevs <- var.z^.5 b <- stdevs %*% t(stdevs) covv <- b * cor.mat z <- matrix(rnorm(3*n),n,3) z <- exp(z%*% chol(covv)) ### print(summary(z)) ### print(cor(z)) z1 <- z[,1]; z2 <- z[,2]; zd <- z[,3]; } else if (dependence==3) { z <- matrix(rgamma(3*n,1),n,3) z1 <- (z[,1]^cor.mat[1,1]+z[,2]^cor.mat[1,2]+z[,3]^cor.mat[1,3]) z2 <- (z[,1]^cor.mat[2,1]+z[,2]^cor.mat[2,2]+z[,3]^cor.mat[2,3]) zd <- (z[,1]^cor.mat[3,1]+z[,2]^cor.mat[3,2]+z[,3]^cor.mat[3,3]) z <- cbind(z1,z2,zd) ### print(summary(z)) ### print(cor(z)) } else if (dependence==4) { zz <- rgamma(n,1/var.z[1])*var.z[1] z1 <- zz; z2 <- zz; zd <- rep(1,n) z <- z1 } else stop("dependence 0-4"); # }}} cumhaz <- rbind(c(0,0),cumhaz) ## range max of cumhaz and cumhaz2 out <- extendCums(cumhaz,cumhaz2,both=TRUE,hazb=haz2) cumhaz <- out$cumA cumhaz2 <- out$cumB ## extend cumulative for death to full range of cause 1 if (!is.null(death.cumhaz)) { out <- extendCums(cumhaz,death.cumhaz,hazb=dhaz) cumhazd <- out$cumB } ll <- nrow(cumhaz) max.time <- tail(cumhaz[,1],1) ### recurrent first time tall1 <- timereg::rchaz(cumhaz,z1) tall2 <- timereg::rchaz(cumhaz2,z2) tall <- tall1 tall$status <- ifelse(tall1$timectime] <- 0; tall$dtime[tall$dtime>ctime] <- ctime[tall$dtime>ctime] } } else { tall$dtime <- max.time; tall$fdeath <- 0; cumhazd <- NULL if (!is.null(cens)) { ctime <- rexp(n)/cens tall$fdeath[tall$dtime>ctime] <- 0; tall$dtime[tall$dtime>ctime] <- ctime[tall$dtime>ctime] } } ### fixing the first time to event tall$death <- 0 tall <- dtransform(tall,death=fdeath,time>dtime) tall <- dtransform(tall,status=0,time>dtime) tall <- dtransform(tall,time=dtime,time>dtime) tt <- tall ### setting aside memory tt1 <- tt2 <- tt ### gemsim <- as.data.frame(matrix(0,max.recurrent*n,ncol(tall))) ### names(gemsim) <- names(tall) ### gemsim[1:n,] <- tall; nrr <- n i <- 1; while (any(tt$timedtime) tt <- dtransform(tt,status=0,time>dtime) tt <- dtransform(tt,time=dtime,time>dtime) nt <- nrow(tt) ### gemsim[(nrr+1):(nrr+nt),] <- tt tall <- rbind(tall,tt[1:nn,],row.names=NULL) ### nrr <- nrr+nt } ### tall <- gemsim[1:nrr,] dsort(tall) <- ~id+entry+time tall$start <- tall$entry tall$stop <- tall$time attr(tall,"death.cumhaz") <- cumhazd attr(tall,"cumhaz") <- cumhaz attr(tall,"cumhaz2") <- cumhaz2 attr(tall,"z") <- z return(tall) }# }}} ##' @export showfitsim <- function(causes=2,rr,dr,base1,base4,which=1:3) {# {{{ if (1 %in% which) { drr <- phreg(Surv(entry,time,death)~cluster(id),data=rr) basehazplot.phreg(drr,ylim=c(0,8)) lines(dr,col=2) } ### if (2 %in% which) { xrr <- phreg(Surv(entry,time,status==1)~cluster(id),data=rr) basehazplot.phreg(xrr,add=TRUE) ### basehazplot.phreg(xrr) lines(base1,col=2) if (causes>=2) { xrr2 <- phreg(Surv(entry,time,status==2)~cluster(id),data=rr) basehazplot.phreg(xrr2,add=TRUE) lines(base4,col=2) } } if (3 %in% which) { meanr1 <- recurrentMarginal(xrr,drr) basehazplot.phreg(meanr1,se=TRUE) if (causes>=2) { meanr2 <- recurrentMarginal(xrr2,drr) basehazplot.phreg(meanr2,se=TRUE,add=TRUE,col=2) } } }# }}} ##' Simulation of illness-death model ##' ##' Simulation of illness-death model ##' ##' simMultistate with same death intensity from states 1 and 2 ##' simMultistateII with different death intensities from states 1 and 2 ##' ##' Must give cumulative hazards on some time-range ##' ##' @param n number of id's ##' @param cumhaz cumulative hazard of recurrent events ##' @param cumhaz2 cumulative hazard of recurrent events of type 2 ##' @param death.cumhaz cumulative hazard of death from state 1 ##' @param death.cumhaz2 cumulative hazard of death from state 2 ##' @param rr relative risk adjustment for cumhaz ##' @param rr2 relative risk adjustment for cumhaz2 ##' @param rd relative risk adjustment for death.cumhaz ##' @param rd2 relative risk adjustment for death.cumhaz2 ##' @param gap.time if true simulates gap-times with specified cumulative hazard ##' @param max.recurrent limits number recurrent events to 100 ##' @param dependence 0:independence; 1:all share same random effect with variance var.z; 2:random effect exp(normal) with correlation structure from cor.mat; 3:additive gamma distributed random effects, z1= (z11+ z12)/2 such that mean is 1 , z2= (z11^cor.mat(1,2)+ z13)/2, z3= (z12^(cor.mat(2,3)+z13^cor.mat(1,3))/2, with z11 z12 z13 are gamma with mean and variance 1 , first random effect is z1 and for N1 second random effect is z2 and for N2 third random effect is for death ##' @param var.z variance of random effects ##' @param cor.mat correlation matrix for var.z variance of random effects ##' @param cens rate of censoring exponential distribution ##' @param ... Additional arguments to lower level funtions ##' @author Thomas Scheike ##' @examples ##' ######################################## ##' ## getting some rates to mimick ##' ######################################## ##' data(base1cumhaz) ##' data(base4cumhaz) ##' data(drcumhaz) ##' dr <- drcumhaz ##' dr2 <- drcumhaz ##' dr2[,2] <- 1.5*drcumhaz[,2] ##' base1 <- base1cumhaz ##' base4 <- base4cumhaz ##' cens <- rbind(c(0,0),c(2000,0.5),c(5110,3)) ##' ##' iddata <- simMultistate(100,base1,base1,dr,dr2,cens=cens) ##' dlist(iddata,.~id|id<3,n=0) ##' ##' ### estimating rates from simulated data ##' c0 <- phreg(Surv(start,stop,status==0)~+1,iddata) ##' c3 <- phreg(Surv(start,stop,status==3)~+strata(from),iddata) ##' c1 <- phreg(Surv(start,stop,status==1)~+1,subset(iddata,from==2)) ##' c2 <- phreg(Surv(start,stop,status==2)~+1,subset(iddata,from==1)) ##' ### ##' par(mfrow=c(2,3)) ##' bplot(c0) ##' lines(cens,col=2) ##' bplot(c3,main="rates 1-> 3 , 2->3") ##' lines(dr,col=1,lwd=2) ##' lines(dr2,col=2,lwd=2) ##' ### ##' bplot(c1,main="rate 1->2") ##' lines(base1,lwd=2) ##' ### ##' bplot(c2,main="rate 2->1") ##' lines(base1,lwd=2) ##' ##' @aliases extendCums ##' @export simMultistate <- function(n,cumhaz,cumhaz2,death.cumhaz,death.cumhaz2, rr=NULL,rr2=NULL,rd=NULL,rd2=NULL, gap.time=FALSE,max.recurrent=100, dependence=0,var.z=0.22,cor.mat=NULL,cens=NULL,...) {# {{{ fdeath <- dtime <- NULL # to avoid R-check status <- dhaz <- NULL; dhaz2 <- NULL if (dependence==0) { z <- z1 <- z2 <- zd <- zd2 <- rep(1,n) # {{{ } else if (dependence==1) { z <- rgamma(n,1/var.z[1])*var.z[1] ### z <- exp(rnorm(n,1)*var.z[1]^.5) z1 <- z; z2 <- z; zd <- z if (!is.null(cor.mat)) { zd <- rep(1,n); } } else if (dependence==2) { stdevs <- var.z^.5 b <- stdevs %*% t(stdevs) covv <- b * cor.mat z <- matrix(rnorm(3*n),n,3) z <- exp(z%*% chol(covv)) ### print(summary(z)) ### print(cor(z)) z1 <- z[,1]; z2 <- z[,2]; zd <- z[,3]; } else if (dependence==3) { z <- matrix(rgamma(3*n,1),n,3) z1 <- (z[,1]^cor.mat[1,1]+z[,2]^cor.mat[1,2]+z[,3]^cor.mat[1,3]) z2 <- (z[,1]^cor.mat[2,1]+z[,2]^cor.mat[2,2]+z[,3]^cor.mat[2,3]) zd <- (z[,1]^cor.mat[3,1]+z[,2]^cor.mat[3,2]+z[,3]^cor.mat[3,3]) z <- cbind(z1,z2,zd) ### print(summary(z)) ### print(cor(z)) } else stop("dependence 0-3"); # }}} ## covariate adjustment if (is.null(rr)) rr <- z1; if (is.null(rr2)) rr2 <- z2; if (is.null(rd)) rd <- zd; if (is.null(rd2)) rd2 <- zd2; ll <- nrow(cumhaz) ### extend of cumulatives cumhaz <- rbind(c(0,0),cumhaz) cumhaz2 <- rbind(c(0,0),cumhaz2) death.cumhaz <- rbind(c(0,0),death.cumhaz) death.cumhaz2 <- rbind(c(0,0),death.cumhaz2) haz <- haz2 <- NULL ## range max of cumhaz and cumhaz2 out <- extendCums(cumhaz,cumhaz2,both=TRUE) cumhaz <- out$cumA cumhaz2 <- out$cumB ## extend cumulative for death to full range of cause 1 out <- extendCums(cumhaz,death.cumhaz,both=FALSE) cumhazd <- out$cumB ## extend cumulative for death to full range of cause 1 out <- extendCums(cumhaz,death.cumhaz2,both=FALSE) cumhazd2 <- out$cumB max.time <- tail(cumhaz[,1],1) if (!is.null(cens)) { if (is.matrix(cens)) { out <- extendCums(cumhaz,cens,both=FALSE) cens <- out$cumB } } tall <- timereg::rcrisk(cumhaz,cumhazd,rr,rd,cens=cens) tall$id <- 1:n ### fixing the first time to event tall$death <- 0 ### cause 2 is death state 3, cause 1 is state 2 tall <- dtransform(tall,status=3,status==2) tall <- dtransform(tall,death=1,status==3) tall <- dtransform(tall,status=2,status==1) ### dead or censored deadid <- (tall$status==3 | tall$status==0) tall$from <- 1 tall$to <- tall$status ## id's that are dead: tall[deadid,] ## go furhter with those that are not yet dead or censored tt <- tall[!deadid,,drop=FALSE] ## also check that we are before max.time tt <- subset(tt,tt$time0) & (i < max.recurrent)) {# {{{ i <- i+1 nn <- nrow(tt) z1r <- rr[tt$id] zdr <- rd[tt$id] z2r <- rr2[tt$id] zd2r <- rd2[tt$id] if (i%%2==0) { ## in state 2 ## out of 2 for those in 2 tt1 <- timereg::rcrisk(cumhaz2,cumhazd2,z2r,zd2r,entry=tt$time,cens=cens) tt1$death <- 0 ### status 2 is death state 3, status 1 is state 1 tt1 <- dtransform(tt1,status=3,status==2) tt1 <- dtransform(tt1,death=1,status==3) tt1$from <- 2 tt1$to <- tt1$status ## take id from tt tt1$id <- tt$id ### add to data tall <- rbind(tall,tt1,row.names=NULL) deadid <- (tt1$status==3 | tt1$status==0) ### those that are still under risk tt <- tt1[!deadid,,drop=FALSE] ## also keep only those before max.time tt <- subset(tt,tt$timectime] <- 0; tall$dtime[tall$dtime>ctime] <- ctime[tall$dtime>ctime] } } ### fixing the first time to event tall$death <- 0 tall <- dtransform(tall,death=fdeath,time>dtime) tall <- dtransform(tall,status=0,time>dtime) tall <- dtransform(tall,time=dtime,time>dtime) tt <- tall tt1 <- tt2 <- tt i <- 1; while (any(tt$timedtime) tt <- dtransform(tt,status=0,time>dtime) tt <- dtransform(tt,time=dtime,time>dtime) nt <- nrow(tt) tall <- rbind(tall,tt[1:nn,],row.names=NULL) } dsort(tall) <- ~id+entry+time tall$start <- tall$entry tall$stop <- tall$time attr(tall,"death.cumhaz") <- cumhazd attr(tall,"cumhaz") <- cumhaz attr(tall,"cumhaz2") <- cumhaz2 attr(tall,"z") <- z return(tall) }# }}} ##' @export extendCums <- function(cumA,cumB,both=TRUE,hazb=NULL,haza=NULL) {# {{{ max1 <- tail(cumA[,1],1) max2 <- tail(cumB[,1],1) ## extend to max of both or max of cumA if (both) mmax <- max(max1,max2) else mmax <- max1 ## extend cumulative for cause 2 to full range of cause 1 cumB <- rbind(c(0,0),cumB) ### linear extrapolation of mortality using given dhaz or if (tail(cumB[,1],1) -1/shape ##' @param share1 how random effect for death splits into two parts ##' @param vargamD variance of random effect for death ##' @param vargam12 shared random effect for N1 and N2 ##' @param cens rate of censoring exponential distribution ##' @param ... Additional arguments to lower level funtions ##' @author Thomas Scheike ##' @examples ##' ######################################## ##' ## getting some rates to mimick ##' ######################################## ##' ##' data(base1cumhaz) ##' data(base4cumhaz) ##' data(drcumhaz) ##' dr <- drcumhaz ##' base1 <- base1cumhaz ##' base4 <- base4cumhaz ##' ##' rr <- simRecurrentTS(1000,base1,base4,death.cumhaz=dr) ##' dtable(rr,~death+status) ##' showfitsim(causes=2,rr,dr,base1,base4) ##' ##' @export simRecurrentTS <- function(n,cumhaz,cumhaz2,death.cumhaz=NULL, nu=rep(1,3),share1=0.3,vargamD=2,vargam12=0.5, gap.time=FALSE,max.recurrent=100,cens=NULL,...) {# {{{ k <- 1 nu1 <- nu[1]; nu2 <- nu[2]; nu3 <- nu[3] ###nu1 <- 1; nu2 <- 1; nu3 <- 0.4 share2 <- (1-share1) vargam <- vargamD vargam12 <- 0.5 agam1 <- share1/vargam agam2 <- share2/vargam betagam=1/vargam gamma1 <- rep(rgamma(n,agam1)*vargam,each=k) gamma2 <- rep(rgamma(n,agam2)*vargam,each=k) agam12 <- 1/vargam12 betagam12 <- 1/vargam12 gamma12 <- rep(rgamma(n,agam12)*vargam12,each=k) ### agamD <- agam1+agam2 z1 <- (gamma1^nu1)*gamma12 z2 <- (gamma2^nu2)*gamma12^nu3 gamD <- gamma1+gamma2 zd <- gamD egamma12nu3 <- (gamma(agam12+nu3)/gamma(agam12))*1/(betagam12)^nu3 ### zs <- cbind(z1,z2,zd) fdeath <- dtime <- NULL # to avoid R-check dhaz <- haz2 <- dhaz <- NULL ### cumhaz <- rbind(c(0,0),cumhaz) ll <- nrow(cumhaz) max.time <- tail(cumhaz[,1],1) ################################################################ ### approximate hazards to make marginals fit (approximately) ################################################################ orig.death <- death.cumhaz ### base1 <- death.cumhaz gt <- exp(vargam*base1[,2]) dtt <- diff(c(0,base1[,1])) lams <- (diff(c(0,base1[,2]))/dtt)*gt death.cumhaz <- cbind(base1[,1],cumsum(dtt*lams)) base1 <- cumhaz dbase1 <- Cpred(rbind(c(0,0),death.cumhaz),base1[,1])[,2] ### dtt <- diff(c(0,base1[,1])) gt <- (gamma(agam1+nu1)/gamma(agam1))*(1/(betagam+dbase1))^nu1 lams <- (diff(c(0,base1[,2]))/dtt)*(1/gt) cumhaz <- cbind(base1[,1],cumsum(dtt*lams)) base1 <- cumhaz2 dbase1 <- Cpred(rbind(c(0,0),death.cumhaz),base1[,1])[,2] dtt <- diff(c(0,base1[,1])) gt <- (gamma(agam2+nu2)/gamma(agam2))*(1/(betagam+dbase1))^nu2 lams <-(1/egamma12nu3)*(diff(c(0,base1[,2]))/dtt)*(1/gt) cumhaz2 <- cbind(base1[,1],cumsum(dtt*lams)) cumhaz <- rbind(c(0,0),cumhaz) cumhaz2 <- rbind(c(0,0),cumhaz2) death.cumhaz <- rbind(c(0,0),death.cumhaz) ## range max of cumhaz and cumhaz2 out <- extendCums(cumhaz,cumhaz2,both=TRUE,hazb=haz2) cumhaz <- out$cumA cumhaz2 <- out$cumB ## extend cumulative for death to full range of cause 1 out <- extendCums(cumhaz,death.cumhaz,hazb=dhaz) cumhazd <- out$cumB max.time <- tail(cumhaz[,1],1) ### recurrent first time tall1 <- timereg::rchaz(cumhaz,rr=z1) tall2 <- timereg::rchaz(cumhaz2,rr=z2) tall <- tall1 tall$status <- ifelse(tall1$timectime] <- 0; tall$dtime[tall$dtime>ctime] <- ctime[tall$dtime>ctime] } } else { tall$dtime <- max.time; tall$fdeath <- 0; cumhazd <- NULL if (!is.null(cens)) { ctime <- rexp(n)/cens tall$fdeath[tall$dtime>ctime] <- 0; tall$dtime[tall$dtime>ctime] <- ctime[tall$dtime>ctime] } }# }}} ### fixing the first time to event tall$death <- 0 tall <- dtransform(tall,death=fdeath,time>dtime) tall <- dtransform(tall,status=0,time>dtime) tall <- dtransform(tall,time=dtime,time>dtime) tt <- tall ### setting aside memory tt1 <- tt2 <- tt i <- 1; while (any(tt$timedtime) tt <- dtransform(tt,status=0,time>dtime) tt <- dtransform(tt,time=dtime,time>dtime) nt <- nrow(tt) tall <- rbind(tall,tt[1:nn,],row.names=NULL) } dsort(tall) <- ~id+entry+time tall$start <- tall$entry tall$stop <- tall$time attr(tall,"death.cumhaz") <- cumhazd attr(tall,"cumhaz") <- cumhaz attr(tall,"cumhaz2") <- cumhaz2 attr(tall,"zs") <- zs attr(tall,"gamma.death") <- c(agam1,agam2,betagam,vargamD) attr(tall,"gamma.N12") <- c(agam12,betagam12,vargam12) return(tall) }# }}} ##' Counts the number of previous events of two types for recurrent events processes ##' ##' Counts the number of previous events of two types for recurrent events processes ##' ##' @param data data-frame ##' @param status name of status ##' @param id id ##' @param types types of the events (code) related to status ##' @param names.count name of Counts, for example Count1 Count2 when types=c(1,2) ##' @param lag if true counts previously observed, and if lag=FALSE counts up to know ##' @author Thomas Scheike ##' @examples ##' ######################################## ##' ## getting some rates to mimick ##' ######################################## ##' ##' data(base1cumhaz) ##' data(base4cumhaz) ##' data(drcumhaz) ##' dr <- drcumhaz ##' base1 <- base1cumhaz ##' base4 <- base4cumhaz ##' ##' ###################################################################### ##' ### simulating simple model that mimicks data ##' ### now with two event types and second type has same rate as death rate ##' ###################################################################### ##' ##' rr <- simRecurrentII(1000,base1,base4,death.cumhaz=dr) ##' rr <- count.history(rr) ##' dtable(rr,~"Count*"+status,level=1) ##' ##' @export count.history <- function(data,status="status",id="id",types=1:2,names.count="Count",lag=TRUE) {# {{{ stat <- data[,status] clusters <- data[,id] if (is.numeric(clusters)) { clusters <- fast.approx(unique(clusters), clusters) - 1 max.clust <- max(clusters) } else { max.clust <- length(unique(clusters)) clusters <- as.integer(factor(clusters, labels = seq(max.clust))) - 1 } data[,"lbnr__id"] <- cumsumstrata(rep(1,nrow(data)),clusters,max.clust+1) for (i in types) { if (lag==TRUE) data[,paste(names.count,i,sep="")] <- cumsumidstratasum((stat==i),rep(0,nrow(data)),1,clusters,max.clust+1)$lagsum else data[,paste(names.count,i,sep="")] <- cumsumidstratasum((stat==i),rep(0,nrow(data)),1,clusters,max.clust+1)$sum } return(data) }# }}} ##' Estimation of probability of more that k events for recurrent events process ##' ##' Estimation of probability of more that k events for recurrent events process ##' where there is terminal event, based on this also estimate of variance of recurrent events. The estimator is based on cumulative incidence of exceeding "k" events. ##' In contrast the probability of exceeding k events can also be computed as a ##' counting process integral, and this is implemented in prob.exceedRecurrent ##' ##' @param data data-frame ##' @param type type of evnent (code) related to status ##' @param status name of status ##' @param death name of death indicator ##' @param start start stop call of Hist() of prodlim ##' @param stop start stop call of Hist() of prodlim ##' @param id id ##' @param times time at which to get probabilites P(N1(t) >= n) ##' @param exceed n's for which which to compute probabilites P(N1(t) >= n) ##' @param cifmets if true uses cif of mets package rather than prodlim ##' @param strata to stratify according to variable, only for cifmets=TRUE, when strata is given then only consider the output in the all.cifs ##' @param all.cifs if true then returns list of all fitted objects in cif.exceed ##' @param ... Additional arguments to lower level funtions ##' @author Thomas Scheike ##' @references ##' Scheike, Eriksson, Tribler (2019) ##' The mean, variance and correlation for bivariate recurrent events ##' with a terminal event, JRSS-C ##' ##' @examples ##' ##' ######################################## ##' ## getting some rates to mimick ##' ######################################## ##' ##' data(base1cumhaz) ##' data(base4cumhaz) ##' data(drcumhaz) ##' dr <- drcumhaz ##' base1 <- base1cumhaz ##' base4 <- base4cumhaz ##' ##' cor.mat <- corM <- rbind(c(1.0, 0.6, 0.9), c(0.6, 1.0, 0.5), c(0.9, 0.5, 1.0)) ##' rr <- simRecurrent(1000,base1,cumhaz2=base4,death.cumhaz=dr) ##' rr <- count.history(rr) ##' dtable(rr,~death+status) ##' ##' oo <- prob.exceedRecurrent(rr,1) ##' bplot(oo) ##' ##' par(mfrow=c(1,2)) ##' with(oo,plot(time,mu,col=2,type="l")) ##' ### ##' with(oo,plot(time,varN,type="l")) ##' ##' ##' ### Bivariate probability of exceeding ##' oo <- prob.exceedBiRecurrent(rr,1,2,exceed1=c(1,5,10),exceed2=c(1,2,3)) ##' with(oo, matplot(time,pe1e2,type="s")) ##' nc <- ncol(oo$pe1e2) ##' legend("topleft",legend=colnames(oo$pe1e2),lty=1:nc,col=1:nc) ##' ##' ##' \donttest{ ##' ### do not test to avoid dependence on prodlim ##' ### now estimation based on cumualative incidence, but do not test to avoid dependence on prodlim ##' library(prodlim) ##' pp <- prob.exceed.recurrent(rr,1,status="status",death="death",start="entry",stop="time",id="id") ##' with(pp, matplot(times,prob,type="s")) ##' ### ##' with(pp, matlines(times,se.lower,type="s")) ##' with(pp, matlines(times,se.upper,type="s")) ##' } ##' @export ##' @aliases prob.exceedRecurrent prob.exceedBiRecurrent prob.exceedRecurrentStrata prob.exceedBiRecurrentStrata prob.exceed.recurrent <- function(data,type,status="status",death="death", start="start",stop="stop",id="id",times=NULL,exceed=NULL,cifmets=FALSE, strata=NULL,all.cifs=FALSE,...) {# {{{ ### setting up data stat <- data[,status] dd <- data[,death] tstop <- data[,stop] tstart <- data[,start] clusters <- data[,id] if (sum(stat==type)==0) stop("none of type events") if (!is.null(strata) & !cifmets) stop("strata only for cifmets=TRUE\n") if (is.numeric(clusters)) { clusters <- fast.approx(unique(clusters), clusters) - 1 max.clust <- max(clusters) } else { max.clust <- length(unique(clusters)) clusters <- as.integer(factor(clusters, labels = seq(max.clust))) - 1 } count <- cumsumstrata((stat==type),clusters,max.clust+1) ### count <- cumsumidstratasum((stat==type),rep(0,nrow(data)),1,clusters,max.clust+1)$lagsum mc <- max(count)+1 idcount <- clusters*mc + count idcount <- cumsumstrata(rep(1,length(idcount)),idcount,mc*(max.clust+1)) if (is.null(times)) times <- sort(unique(tstop[stat==type])) if (is.null(exceed)) exceed <- sort(unique(count)) if (!cifmets) { if (is.null(strata)) form <- as.formula(paste("Hist(entry=",start,",",stop,",statN)~+1",sep="")) else form <- as.formula(paste("Hist(entry=",start,",",stop,",statN)~+",strata,sep="")) } else { if (is.null(strata)) form <- as.formula(paste("Event(entry=",start,",",stop,",statN)~+1",sep="")) else form <- as.formula(paste("Event(entry=",start,",",stop,",statN)~strata(",strata,")",sep="")) } cif.exceed <- NULL if (all.cifs) cif.exceed <- list() probs.orig <- se.probs <- probs <- matrix(0,length(times),length(exceed)) se.lower <- matrix(0,length(times),length(exceed)) se.upper <- matrix(0,length(times),length(exceed)) i <- 1 for (n1 in exceed[-1]) {# {{{ i <- i+1 ### first time that get to n1 keep <- (count=",exceed[-1],sep="")) colnames(se.probs) <- c(paste("N=",exceed[1],sep=""),paste("exceed>=",exceed[-1],sep="")) return(list(time=times,times=times,prob=probs,se.prob=se.probs,meanN=meanN,probs.orig=probs.orig[,-1], se.lower=se.lower,se.upper=se.upper,meanN2=meanN2,varN=meanN2-meanN^2,exceed=exceed[-1],formula=form, cif.exceed=cif.exceed)) }# }}} ##' @export prob.exceedRecurrent <- function(data,type,km=TRUE,status="status",death="death", start="start",stop="stop",id="id",names.count="Count",...) {# {{{ formdr <- as.formula(paste("Surv(",start,",",stop,",",death,")~ cluster(",id,")",sep="")) form1 <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type,")~cluster(",id,")",sep="")) ### form1C <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type,")~strata(",names.count,type,")+cluster(",id,")",sep="")) dr <- phreg(formdr,data=data) base1 <- phreg(form1,data=data) base1.2 <- phreg(form1C,data=data) ###cc <- base1$cox.prep ###risk <- revcumsumstrata(cc$sign,cc$strata,cc$nstrata) ######### risk stratified after count 1 ###cc <- base1.2$cox.prep ###risk1 <- revcumsumstrata(cc$sign,cc$strata,cc$nstrata) ###pstrata <- risk1/risk ###pstrata[risk1==0] <- 0 ### marginal int_0^t G(s) P(N1(t-)==k|D>t) \lambda_{1,N1=k}(s) ds ### strata og count skal passe sammen # {{{ strat <- dr$strata[dr$jumps] x <- dr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 if (!km) { cumhazD <- c(cumsumstratasum(S0i,xx$strata,xx$nstrata)$lagsum) St <- exp(-cumhazD) } else St <- c(exp(cumsumstratasum(log(1-S0i),xx$strata,xx$nstrata)$lagsum)) x <- base1 xx <- x$cox.prep lss <- length(xx$strata) S0i2 <- S0i <- rep(0,lss) S0i[xx$jumps+1] <- 1/x$S0 risktot <- x$S0 mu <- c(cumsumstrata(St*S0i,xx$strata,xx$nstrata)) ### x <- base1.2 xx <- x$cox.prep lss <- length(xx$strata) ### S0i2 <- S0i <- rep(0,lss) ### S0i[xx$jumps+1] <- 1/x$S0 riskstrata <- x$S0 xstrata <- xx$strata vals1 <- sort(unique(data[,paste("Count",type,sep="")])) valjumps <- vals1[xx$strata+1] fk <- (valjumps+1)^2-valjumps^2 ### EN2 <- c(cumsumstrata(fk*St*pstrata*S0i,rep(0,lss),1)) EN2 <- c(cumsumstrata(fk*St*S0i,rep(0,lss),1)) pcumhaz <- cbind(xx$time,cumsumstrata(St*S0i,xx$strata,xx$nstrata)) # }}} EN2 <- EN2[xx$jumps+1] cumhaz <- pcumhaz[xx$jumps+1,] mu <- mu[xx$jumps+1] pstrata <- riskstrata/risktot exceed.name <- paste("Exceed>=",vals1+1,sep="") out=list(cumhaz=cumhaz,time=cumhaz[,1],varN=EN2-mu^2,mu=mu, nstrata=base1.2$nstrata,strata=base1.2$strata[xx$jumps+1], jumps=1:nrow(cumhaz),riskstrata=pstrata,risktot=risktot, strat.cox.name=base1.2$strata.name, strat.cox.level=base1.2$strata.level,exceed=vals1+1, strata.name=exceed.name,strata.level=exceed.name) ### use recurrentMarginal estimator til dette via strata i base1 ### strata og count skal passe sammen ### see beregning via recurrent marginal function ### base1$cox.prep$strata <- base1.2$cox.prep$strata ### base1$cox.prep$nstrata <- base1.2$cox.prep$nstrata ### base1$nstrata <- base1.2$cox.prep$nstrata ### base1$strata <- base1.2$strata ### base1$strata.name <- base1.2$strata.name ### base1$strata.level <- base1.2$strata.level ### mm <- recurrentMarginal(base1,dr,km=km,...) ### out=c(mm,list(varN=EN2-mu^2)) return(out) }# }}} ##' @export prob.exceedRecurrentStrata <- function(data,type,km=TRUE,status="status",death="death", start="start",stop="stop",id="id",names.count="Count",strata=NULL,...) {# {{{ if (is.null(strata)) { formdr <- as.formula(paste("Surv(",start,",",stop,",",death,")~ cluster(",id,")",sep="")) ## bring count as covariate to use later and get sorted as data form1 <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type,")~",names.count,type,"+cluster(",id,")",sep="")) } else { formdr <- as.formula(paste("Surv(",start,",",stop,",",death,")~strata(",strata,")+cluster(",id,")",sep="")) ## bring count as covariate to use later and get sorted as data form1 <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type,")~",names.count,type,"+strata(",strata,")+cluster(",id,")",sep="")) } dr <- phreg(formdr,data=data,no.opt=TRUE) base1 <- phreg(form1,data=data,no.opt=TRUE) ### marginal int_0^t G(s) P(N1(t-)==k|D>t) \lambda_{1,N1=k}(s) ds ### strata og count skal passe sammen # {{{ strat <- dr$strata[dr$jumps] x <- dr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 if (!km) { cumhazD <- c(cumsumstratasum(S0i,xx$strata,xx$nstrata)$lagsum) St <- exp(-cumhazD) } else St <- c(exp(cumsumstratasum(log(1-S0i),xx$strata,xx$nstrata)$lagsum)) x <- base1 xx <- x$cox.prep lss <- length(xx$strata) S0i2 <- S0i <- rep(0,lss) S0i[xx$jumps+1] <- 1/x$S0 risktot <- x$S0 mu <- c(cumsumstrata(St*S0i,xx$strata,xx$nstrata)) ### vals1 <- xx$X[,1] fk <- (vals1+1)^2-vals1^2 EN2 <- c(cumsumstrata(fk*St*S0i,xx$strata,xx$nstrata)) inc <- St[xx$jumps+1]*S0i[xx$jumps+1] ## new-strata names valjump <- vals1[xx$jumps+1] xxs <- xx$strata[xx$jumps+1] newstrata <- mystrata(list(id=xxs,exceed=valjump)) nnn <- !duplicated(newstrata$sindex) nnstrata <- attr(newstrata,"nlevel") newstrata <- newstrata$sindex exceed <- valjump[nnn]+1 if (!is.null(strata)) exceed.levels <- paste(base1$strata.level[xxs[nnn]+1], paste("Exceed",exceed,sep=">="),sep="-") else exceed.levels <- paste("Exceed",exceed,sep=">=") newstrata <- as.numeric(strata(xx$strata[xx$jumps+1],valjump))-1 nnstrata <- length(unique(newstrata)) pcumhaz <- cbind(x$jumptimes,cumsumstrata(inc,newstrata,nnstrata)) # }}} EN2 <- EN2[xx$jumps+1] mu <- mu[xx$jumps+1] cumhaz <- pcumhaz pstrata <- NULL out=list(cumhaz=cumhaz,time=cumhaz[,1],varN=EN2-mu^2,mu=mu, nstrata=nnstrata,strata=newstrata, strat.cox.name=base1$strata.name, strat.cox.level=base1$strata.level,exceed=exceed, jumps=1:nrow(cumhaz),riskstrata=pstrata,risktot=risktot, strata.name="",strata.level=exceed.levels) return(out) }# }}} ##' @export prob.exceedBiRecurrent <- function(data,type1,type2,km=TRUE,status="status",death="death", start="start",stop="stop",id="id",names.count="Count",exceed1=NULL,exceed2=NULL) {# {{{ formdr <- as.formula(paste("Surv(",start,",",stop,",",death,")~ cluster(",id,")",sep="")) form1 <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type1,")~cluster(",id,")",sep="")) form2 <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type2,")~cluster(",id,")",sep="")) ### ###form1C <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type1,")~strata(",names.count,type1,",",names.count,type2,")+cluster(",id,")",sep="")) ###form2C <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type2,")~ ### strata(",names.count,type1,",",names.count,type2,")+cluster(",id,")",sep="")) form2Ccc <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type2,")~ ",names.count,type1,"+",names.count,type2,"+"," strata(",names.count,type1,",",names.count,type2,")+cluster(",id,")",sep="")) form1Ccc <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type1,")~ ",names.count,type1,"+",names.count,type2,"+"," strata(",names.count,type1,",",names.count,type2,")+cluster(",id,")",sep="")) ### stratified and with counts in covariate matrix bb2.12 <- phreg(form2Ccc,data=data,no.opt=TRUE) bb1.12 <- phreg(form1Ccc,data=data,no.opt=TRUE) dr <- phreg(formdr,data=data) base1 <- phreg(form1,data=data) base2 <- phreg(form2,data=data) cc <- base1$cox.prep risk1 <- revcumsumstrata(cc$sign,cc$strata,cc$nstrata) ###### risk stratified after count 1 og count2 cc <- bb1.12$cox.prep risk1.12 <- revcumsumstrata(cc$sign,cc$strata,cc$nstrata) pstrata1 <- risk1.12/risk1 pstrata1[1] <- 0 cc <- base2$cox.prep risk2 <- revcumsumstrata(cc$sign,cc$strata,cc$nstrata) ###### risk stratified after count 1 og count2 cc <- bb2.12$cox.prep risk2.12 <- revcumsumstrata(cc$sign,cc$strata,cc$nstrata) pstrata2 <- risk2.12/risk2 pstrata2[1] <- 0 ### marginal int_0^t G(s) P(N1(t-)==k|D>t) \lambda_{1,N1=k}(s) ds ### strata og count skal passe sammen # {{{ strat <- dr$strata[dr$jumps] Gt <- exp(-dr$cumhaz[,2]) ### x <- dr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 if (!km) { cumhazD <- c(cumsumstratasum(S0i,xx$strata,xx$nstrata)$lagsum) St <- exp(-cumhazD) } else St <- c(exp(cumsumstratasum(log(1-S0i),xx$strata,xx$nstrata)$lagsum)) x <- base1 xx <- x$cox.prep lss <- length(xx$strata) S0i2 <- S0i <- rep(0,lss) S0i[xx$jumps+1] <- 1/x$S0 mu <- c(cumsumstrata(St*S0i,rep(0,lss),1)) ### x <- bb1.12 xx1 <- x$cox.prep lss <- length(xx$strata) S0i2 <- S0i <- rep(0,lss) S0i[xx1$jumps+1] <- 1/x$S0 dcumhaz1 <- cbind(xx1$time,pstrata1*St*S0i) ### cumsumstrata(pstrata1*St*S0i,xx1$strata,xx1$nstrata)) x <- bb2.12 xx2 <- x$cox.prep lss <- length(xx2$strata) S0i2 <- S0i <- rep(0,lss) S0i[xx2$jumps+1] <- 1/x$S0 dcumhaz2 <- cbind(xx2$time,pstrata2*St*S0i) ### cumsumstrata(pstrata2*St*S0i,xx2$strata,xx2$nstrata)) n1 <- length(xx1$jumps) n2 <- length(xx2$jumps) ojumps <- order(c(xx1$jumps,xx2$jumps)) jumps <- sort(c(xx1$jumps,xx2$jumps)) times <- xx1$time[jumps+1] dcumhaz1 <- dcumhaz1[jumps+1,] dcumhaz2 <- dcumhaz2[jumps+1,] x1 <- xx1$X[jumps+1,] x2 <- xx2$X[jumps+1,] ### dcumhaz1 <- dcumhaz1[xx1$jumps+1,] ### dcumhaz2 <- dcumhaz2[xx2$jumps+1,] ### x1 <- xx1$X[xx1$jumps+1,] ### x2 <- xx2$X[xx2$jumps+1,] # }}} if (is.null(exceed1)) exceed1 <- 1:max(x1[,1]) if (is.null(exceed2)) exceed2 <- 1:max(x1[,2]) pe1e2 <- matrix(0,n1+n2,length(exceed1)*length(exceed2)) m <- 0; nn <- c() for (i in exceed1) for (j in exceed2) { m <- m+1 strat1 <- (x1[,2]>=j)*(x1[,1]==(i-1)) strat2 <- (x2[,1]>=i)*(x2[,2]==(j-1)) pe1e2[,m] <- cumsum(strat1*dcumhaz1[,2]) + cumsum(strat2*dcumhaz2[,2]) nn <- c(nn,paste("N_1(t)>=",i,",N_2(t)>=",j,sep="")) } colnames(pe1e2) <- nn out=list(time=times,pe1e2=pe1e2,x1=x1,x2=x2, nstrata=base1$nstrata, strata.name=base1$strata.name,strata.level=base1$strata.levels) class(out) <- "BiRecurrent" return(out) }# }}} ##' @export plot.BiRecurrent <- function(x,stratas=NULL,add=FALSE,...) {# {{{ strat <- x$strata ## all strata if (is.null(stratas)) stratas <- 0:(x$nstrata-1) for (s in stratas) { if (add==FALSE) with(x, matplot(time[strata==s],pe1e2[strata==s,],type="s",...)) else with(x, matlines(time[strata==s],pe1e2[strata==s,],type="s",...)) nc <- ncol(x$pe1e2) legend("topleft",colnames(x$pe1e2),lty=1:nc,col=1:nc) } }# }}} ##' @export prob.exceedBiRecurrentStrata <- function(data,type1,type2,km=TRUE,status="status", death="death",start="start",stop="stop",id="id",names.count="Count", strata=NULL,twinstrata=FALSE,exceed1=NULL,exceed2=NULL) {# {{{ if (is.null(strata)) { formdr <- as.formula(paste("Surv(",start,",",stop,",",death,")~ cluster(",id,")",sep="")) ## use count and status as covariates to use later and get sorted as data form <- as.formula(paste("Surv(",start,",",stop,",",status,"!=0)~",status,"+",names.count,type1,"+",names.count,type2,"+cluster(",id,")",sep="")) } else { formdr <- as.formula(paste("Surv(",start,",",stop,",",death,")~strata(",strata,")+cluster(",id,")",sep="")) ## use count and status as covariates to use later and get sorted as data form <- as.formula(paste("Surv(",start,",",stop,",",status,"!=0)~",status,"+", names.count,type1,"+",names.count,type2,"+","strata(",strata,")+cluster(",id,")",sep="")) if (twinstrata) { ## to allow different strata for the two twins form <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type2,")~",status,"+", names.count,type1,"+",names.count,type2,"+","strata(",strata,type2,")+cluster(",id,")",sep="")) } } ###print(formdr); print(form) dr <- phreg(formdr,data=data) base <- phreg(form,data=data,no.opt=TRUE) ### P(N_1 >= k1, N2 >= k2) is estimated by ### sum_i int_0^t G_strat(s-) I(Ni1(t-)==k1-1,Ni2(t)>= k2) /Y_{strat} (s) dN_{i1,strat}(s) ### + sum_i int_0^t G_strat(s-) I(Ni1(t)>= k1,Ni2(t-)==k2-1) /Y_{strat} (s) dN_{i2,strat}(s) ### = sum_i int_0^t G_strat(s-) ( I(Ni1(t-)==k1-1,Ni2(t)>= k2,type=1) + I(Ni1(t)>= k1,Ni2(t-)==k2-1,type=2)) /Y_{strat} (s) dN_{i.,strat}(s) # {{{ strat <- dr$strata[dr$jumps] x <- dr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 if (!km) { cumhazD <- c(cumsumstratasum(S0i,xx$strata,xx$nstrata)$lagsum) St <- exp(-cumhazD) } else St <- c(exp(cumsumstratasum(log(1-S0i),xx$strata,xx$nstrata)$lagsum)) xx <- base$cox.prep lss <- length(xx$strata) xxjump <- xx$jumps+1 S0i <- 1/base$S0 times <- base$jumptimes ## jumps for N1 and N2, sorted xxstrata <- xx$strata[xxjump] St <- St[xxjump] statusj <- xx$X[xxjump,1] count1 <- xx$X[xxjump,2] count2 <- xx$X[xxjump,3] if (is.null(exceed1)) { exceed1 <- sort(unique(count1))+1 } if (is.null(exceed2)) { exceed2 <- sort(unique(count2))+1 } n <- length(xxjump) m <- 1; nn <- c(); pe1e2 <- matrix(0,n,length(exceed1)*length(exceed2)) for (i in exceed1) for (j in exceed2) { escape <- (count2>=j)*(count1==(i-1))*(statusj==1)+(count1>=i)*(count2==(j-1))*(statusj==2) pe1e2[,m] <- cumsumstrata(escape*St*S0i,xxstrata,xx$nstrata) nn <- c(nn,paste("N_1(t)>=",i,",N_2(t)>=",j,sep="")) m <- m+1 } colnames(pe1e2) <- nn # }}} out=list(time=times,pe1e2=pe1e2,strata=xxstrata,nstrata=xx$nstrata, cumhazard=cbind(times,pe1e2), jumps=1:length(times), nstrata=xx$nstrata, strata.name=base$strata.name,strata.level=base$strata.levels) class(out) <- "BiRecurrent" return(out) }# }}} ##' Estimation of covariance for bivariate recurrent events with terminal event ##' ##' Estimation of probability of more that k events for recurrent events process ##' where there is terminal event ##' ##' @param data data-frame ##' @param type1 type of first event (code) related to status ##' @param type2 type of second event (code) related to status ##' @param status name of status ##' @param death name of death indicator ##' @param start start stop call of Hist() of prodlim ##' @param stop start stop call of Hist() of prodlim ##' @param id id ##' @param names.count name of count for number of previous event of different types, here generated by count.history() ##' @author Thomas Scheike ##' @references ##' Scheike, Eriksson, Tribler (2019) ##' The mean, variance and correlation for bivariate recurrent events ##' with a terminal event, JRSS-C ##' ##' @examples ##' ##' ######################################## ##' ## getting some data to work on ##' ######################################## ##' data(base1cumhaz) ##' data(base4cumhaz) ##' data(drcumhaz) ##' dr <- drcumhaz ##' base1 <- base1cumhaz ##' base4 <- base4cumhaz ##' rr <- simRecurrent(1000,base1,cumhaz2=base4,death.cumhaz=dr) ##' rr <- count.history(rr) ##' rr$strata <- 1 ##' dtable(rr,~death+status) ##' ##' covrp <- covarianceRecurrent(rr,1,2,status="status",death="death", ##' start="entry",stop="time",id="id",names.count="Count") ##' par(mfrow=c(1,3)) ##' plot(covrp) ##' ##' ### with strata, each strata in matrix column, provides basis for fast Bootstrap ##' covrpS <- covarianceRecurrentS(rr,1,2,status="status",death="death", ##' start="entry",stop="time",strata="strata",id="id",names.count="Count") ##' ##' @aliases plot.covariace.recurrent covarianceRecurrentS Bootcovariancerecurrence BootcovariancerecurrenceS ##' @export covarianceRecurrent <- function(data,type1,type2,status="status",death="death", start="start",stop="stop",id="id",names.count="Count") {# {{{ formdr <- as.formula(paste("Surv(",start,",",stop,",",death,")~ cluster(",id,")",sep="")) form1 <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type1,")~cluster(",id,")",sep="")) form2 <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type2,")~cluster(",id,")",sep="")) ### form1C <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type1,")~strata(",names.count,type2,")+cluster(",id,")",sep="")) form2C <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type2,")~strata(",names.count,type1,")+cluster(",id,")",sep="")) dr <- phreg(formdr,data=data) ###basehazplot.phreg(dr) ### base1 <- phreg(form1,data=data) base1.2 <- phreg(form1C,data=data) ### base2 <- phreg(form2,data=data) base2.1 <- phreg(form2C,data=data) ###marginal.mean1 <- recurrentMarginal(base1,dr) ###marginal.mean2 <- recurrentMarginal(base2,dr) marginal.mean1 <- recmarg(base1,dr) marginal.mean2 <- recmarg(base2,dr) cc <- base2$cox.prep risk <- c(revcumsumstrata(cc$sign,cc$strata,cc$nstrata)) ###### risk stratified after count 1 cc <- base2.1$cox.prep risk1 <- c(revcumsumstrata(cc$sign,cc$strata,cc$nstrata)) ssshed1 <- risk1/risk ssshed1[is.na(ssshed1)] <- 1 sshed1 <- list(cumhaz=cbind(cc$time,ssshed1), strata=cc$strata,nstrata=cc$nstrata, jumps=1:length(cc$time), strata.name=paste("prob",type1,sep=""), strata.level=base2.1$strata.level) ### riskstrata <- .Call("riskstrataR",cc$sign,cc$strata,cc$nstrata)$risk nrisk <- apply(riskstrata,2,revcumsumstrata,rep(0,nrow(riskstrata)),1) ntot <- apply(nrisk,1,sum) vals1 <- sort(unique(data[,paste("Count",type1,sep="")])) mean1risk <- apply(t(nrisk)*vals1,2,sum)/ntot mean1risk[is.na(mean1risk)] <- 0 cc <- base1$cox.prep S0 <- rep(0,length(cc$strata)) risk <- c(revcumsumstrata(cc$sign,cc$strata,cc$nstrata)) ### cc <- base1.2$cox.prep S0 <- rep(0,length(cc$strata)) risk2 <- c(revcumsumstrata(cc$sign,cc$strata,cc$nstrata)) ssshed2 <- risk2/risk ssshed2[is.na(ssshed2)] <- 1 ### sshed2 <- list(cumhaz=cbind(cc$time,ssshed2), strata=cc$strata,nstrata=cc$nstrata, jumps=1:length(cc$time), strata.name=paste("prob",type2,sep=""), strata.level=base1.2$strata.level) ### riskstrata <- .Call("riskstrataR",cc$sign,cc$strata,cc$nstrata)$risk nrisk <- apply(riskstrata,2,revcumsumstrata,rep(0,nrow(riskstrata)),1) ntot <- apply(nrisk,1,sum) vals2 <- sort(unique(data[,paste("Count",type2,sep="")])) mean2risk <- apply(t(nrisk)*vals2,2,sum)/ntot mean2risk[is.na(mean2risk)] <- 0 mu1 <-timereg::Cpred(rbind(c(0,0),marginal.mean1$cumhaz),cc$time)[,2] mu2 <-timereg::Cpred(rbind(c(0,0),marginal.mean2$cumhaz),cc$time)[,2] out <- list(based=dr,base1=base1,base2=base2, base1.2=base1.2,base2.1=base2.1, marginal.mean1=marginal.mean1,marginal.mean2=marginal.mean2, prob1=sshed1,prob2=sshed2, mean1risk=mean1risk,mean2risk=mean2risk) ### marginal sum_k int_0^t G(s) k P(N1(t-)==k|D>t) \lambda_{2,N1=k}(s) ds ### strata og count skal passe sammen # {{{ strat <- dr$strata[dr$jumps] Gt <- exp(-dr$cumhaz[,2]) ### x <- dr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 cumhazD <- cbind(xx$time,cumsumstrata(S0i,xx$strata,xx$nstrata)) St <- exp(-cumhazD[,2]) ### x <- base1.2 xx <- x$cox.prep lss <- length(xx$strata) S0i2 <- S0i <- rep(0,lss) S0i[xx$jumps+1] <- 1/x$S0 xstrata <- xx$strata cumhazDR <- cbind(xx$time,cumsumstrata(vals2[xstrata+1]*St*ssshed2*S0i,rep(0,lss),1)) x <- base1 xx <- x$cox.prep lss <- length(xx$strata) S0i2 <- S0i <- rep(0,lss) S0i[xx$jumps+1] <- 1/x$S0 cumhazIDR <- cbind(xx$time,cumsumstrata(St*mean2risk*S0i,rep(0,lss),1)) mu1.i <- cumhazIDR[,2] mu1.2 <- cumhazDR[,2] ### x <- base2.1 xx <- x$cox.prep lss <- length(xx$strata) S0i2 <- S0i <- rep(0,lss) S0i[xx$jumps+1] <- 1/x$S0 cumhazDR <- cbind(xx$time,cumsumstrata(vals1[xx$strata+1]*St*ssshed1*S0i,rep(0,lss),1)) ### x <- base2 xx <- x$cox.prep lss <- length(xx$strata) S0i2 <- S0i <- rep(0,lss) S0i[xx$jumps+1] <- 1/x$S0 cumhazIDR <- cbind(xx$time,cumsumstrata(St*mean1risk*S0i,rep(0,lss),1)) mu2.i <- cumhazIDR[,2] mu2.1 <- cumhazDR[,2] # }}} out=c(out,list(EN1N2= mu1.2+mu2.1,mu2.1=mu2.1,mu1.2=mu1.2, mu2.i=mu2.i,mu1.i=mu1.i, EIN1N2=mu2.i+mu1.i,EN1EN2=mu1*mu2,time=cc$time)) class(out) <- "covariance.recurrent" return(out) }# }}} ##' @export plot.covariance.recurrent <- function(x,main="Covariance",these=1:3,...) {# {{{ legend <- NULL # to avoid R-check if ( 1 %in% these) { nna <- (!is.na(x$mu1.2)) & (!is.na(x$mu1.i)) mu1.2n <- x$mu1.2[nna] mu1.in <- x$mu1.i[nna] time <- x$time[nna] plot(time,mu1.2n,type="l",ylim=range(c(mu1.2n,mu1.in)),...) lines(time,mu1.in,col=2) legend("topleft",c(expression(integral(N[2](s)*dN[1](s),0,t)),"independence"),lty=1,col=1:2) title(main=main) } ### if (2 %in% these) { nna <- (!is.na(x$mu2.1)) & (!is.na(x$mu2.i)) mu2.1n <- x$mu2.1[nna] mu2.in <- x$mu1.i[nna] time <- x$time[nna] plot(time,mu2.1n,type="l",ylim=range(c(mu2.1n,mu2.in)),...) lines(time,mu2.in,col=2) legend("topleft",c(expression(integral(N[1](s)*dN[2](s),0,t)),"independence"),lty=1,col=1:2) title(main=main) } ### if (3 %in% these) { nna <- (!is.na(x$EN1N2)) & (!is.na(x$EIN1N2)) & (!is.na(x$EN1EN2)) EN1N2n <- x$EN1N2[nna] EIN1N2n <- x$EIN1N2[nna] EN1EN2n <- x$EN1EN2[nna] time <- x$time[nna] plot(time,EN1N2n,type="l",lwd=2,ylim=range(c(EN1N2n,EN1EN2n,EIN1N2n)),...) lines(time,EN1EN2n,col=2,lwd=2) lines(time,EIN1N2n,col=3,lwd=2) legend("topleft",c("E(N1N2)", "E(N1) E(N2) ", "E_I(N1 N2)-independence"),lty=1,col=1:3) title(main=main) } } # }}} meanRisk <- function(base1,base1.2) {# {{{ cc <- base1.2$cox.prep S0 <- rep(0,length(cc$strata)) mid <- max(cc$id)+1 risk2 <- revcumsumidstratasum(cc$sign,cc$id,mid,cc$strata,cc$nstrata)$sumidstrata means <- .Call("meanriskR",cc$sign,cc$id,mid,cc$strata,cc$nstrata) mean2risk <- means$meanrisk mean2risk[is.na(mean2risk)] <- 0 risk <- means$risk ssshed2 <- risk2/risk ssshed2[is.na(ssshed2)] <- 0 vals2 <- unique(cc$id) means2 <- list(cumhaz=cbind(cc$time,mean2risk), strata=cc$strata,nstrata=cc$nstrata, jumps=1:length(cc$time), strata.name="meansrisk", strata.level=base1.2$strata.level) sshed2 <- list(cumhaz=cbind(cc$time,ssshed2), strata=cc$id,nstrata=mid, jumps=1:length(cc$time), strata.name="prob", strata.level=paste(vals2),real.strata=cc$strata) return(list(meanrisk=means2,vals=vals2,probs=sshed2,jumps=cc$jumps+1)) }# }}} intN2dN1 <- function(dr,base1,base1.2,pm) {# {{{ x <- dr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 cumhazD <- cbind(xx$time,cumsumstrata(S0i,xx$strata,xx$nstrata)) St <- exp(-cumhazD[,2]) ### x <- base1.2 xx <- x$cox.prep xstrata <- xx$id jumps <- xx$jumps+1 mid <- max(xx$id)+1 ## risk after both id~Count and strata risk2 <- revcumsumidstratasum(xx$sign,xx$id,mid,xx$strata,xx$nstrata)$sumidstrata S0i <- 1/risk2[jumps] vals <- xx$id[jumps] St <- St[jumps] probs <- pm$probs$cumhaz[jumps,2] cumhazDR <- cbind(xx$time[jumps],cumsumstrata(St*vals*probs*S0i,xx$strata[jumps],xx$nstrata)) x <- base1 xx <- x$cox.prep S0i <- c(1/x$S0) meanrisk <- pm$meanrisk$cumhaz[jumps,2] cumhazIDR <- cbind(xx$time[jumps],cumsumstrata(St*meanrisk*S0i,xx$strata[jumps],xx$nstrata)) mu1.i <- cumhazIDR[,2] mu1.2 <- cumhazDR[,2] return(list(cumhaz=cumhazDR,cumhazI=cumhazIDR,mu1.i=mu1.i,mu1.2=mu1.2, time=cumhazDR[,1], strata=xx$strata[jumps],nstrata=xx$nstrata,jumps=1:length(mu1.i), strata.name="intN2dN1",strata.level=x$strata.level)) }# }}} recmarg2 <- function(recurrent,death,...) {# {{{ xr <- recurrent dr <- death ### marginal expected events int_0^t G(s) \lambda_r(s) ds # {{{ x <- dr xx <- x$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 cumhazD <- cbind(xx$time,cumsumstrata(S0i,xx$strata,xx$nstrata)) St <- exp(-cumhazD[,2]) ### x <- xr xx <- x$cox.prep ### S0i2 <- S0i <- rep(0,length(xx$strata)) S0i <- 1/x$S0 jumps <- xx$jumps+1 cumhazDR <- cbind(xx$time[jumps],cumsumstrata(St[jumps]*S0i,xx$strata[jumps],xx$nstrata)) mu <- cumhazDR[,2] # }}} varrs <- data.frame(mu=mu,time=cumhazDR[,1],strata=xr$strata[jumps],St=St[jumps]) out <- list(mu=varrs$mu,times=varrs$time,St=varrs$St,cumhaz=cumhazDR, strata=varrs$strata,nstrata=xr$nstrata,jumps=1:nrow(varrs), strata.name=xr$strata.name) return(out) }# }}} ##' @export covarianceRecurrentS <- function(data,type1,type2,times=NULL,status="status",death="death", start="start",stop="stop",id="id",names.count="Count", strata="NULL",plot=0,output="matrix") {# {{{ if (is.null(times)) times <- seq(0,max(data[,stop]),length=100) ### passing strata as id to be able to use for stratified calculations if (is.null(strata)) stop("must give strata, for example one strata\n"); ## uses Counts1 as cluster to pass to risk set calculations formdr <- as.formula(paste("Surv(",start,",",stop,",",death,")~strata(",strata,")",sep="")) form1 <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type1,")~strata(",strata,")",sep="")) form2 <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type2,")~strata(",strata,")",sep="")) ### form1C <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type1,")~cluster(",names.count,type2,")+strata(",strata,")",sep="")) form2C <- as.formula(paste("Surv(",start,",",stop,",",status,"==",type2,")~cluster(",names.count,type1,")+strata(",strata,")",sep="")) dr <- phreg(formdr,data=data) ###basehazplot.phreg(dr) ### base1 <- phreg(form1,data=data) base1.2 <- phreg(form1C,data=data) ### base2 <- phreg(form2,data=data) base2.1 <- phreg(form2C,data=data) rm1 <- recmarg2(base1,dr) rm2 <- recmarg2(base2,dr) if (plot==1) { basehazplot.phreg(rm1) basehazplot.phreg(rm2) } pm1 <- meanRisk(base2,base2.1) pm2 <- meanRisk(base1,base1.2) if (plot==1) { basehazplot.phreg(pm1$meanrisk) basehazplot.phreg(pm2$meanrisk) } ### marginal sum_k int_0^t G(s) k P(N1(t-)==k|D>t) \lambda_{2,N1=k}(s) ds ### sum_k int_0^t G(s) E(N1(t-)==k|D>t) \lambda_{2}(s) ds iN2dN1 <- intN2dN1(dr,base1,base1.2,pm2) iN1dN2 <- intN2dN1(dr,base2,base2.1,pm1) ###print("hej") if (plot==1) { par(mfrow=c(2,2)) basehazplot.phreg(iN2dN1) plot(iN2dN1$time,iN2dN1$cumhazI[,2],type="l") basehazplot.phreg(iN1dN2) } #### writing output in matrix form for each strata for the times mu1g <- matrix(0,length(times),rm1$nstrata) mu2g <- matrix(0,length(times),rm1$nstrata) mu1.2 <- matrix(0,length(times),rm1$nstrata) mu2.1 <- matrix(0,length(times),rm1$nstrata) mu1.i <- matrix(0,length(times),rm1$nstrata) mu2.i <- matrix(0,length(times),rm1$nstrata) mu1 <- matrix(0,length(times),rm1$nstrata) mu2 <- matrix(0,length(times),rm1$nstrata) if (output=="matrix") { all <- c() i <- 1 ### going through strata for (i in 1:rm1$nstrata) { j <- i-1 mu1[,i] <- timereg::Cpred(rm1$cumhaz[rm1$strata==j,],times)[,2] mu2[,i] <- timereg::Cpred(rm2$cumhaz[rm2$strata==j,],times)[,2] mu1.2[,i] <- timereg::Cpred( iN2dN1$cumhaz[rm1$strata==j,],times)[,2] mu1.i[,i] <- timereg::Cpred(iN2dN1$cumhazI[rm1$strata==j,],times)[,2] mu2.1[,i] <- timereg::Cpred( iN1dN2$cumhaz[rm2$strata==j,],times)[,2] mu2.i[,i] <- timereg::Cpred(iN1dN2$cumhazI[rm2$strata==j,],times)[,2] } mu1mu2 <- mu1*mu2 out=c(list(EN1N2=mu1.2+mu2.1, EIN1N2=mu1.i+mu2.i, EN1EN2=mu1mu2, mu1.2=mu1.2, mu1.i=mu1.i, mu2.1=mu2.1, mu2.i=mu2.i, mu1=mu1,mu2=mu2, nstrata=rm1$nstrata, time=times)) } else out <- list(iN2dN1=iN2dN1,iN1dN2=iN1dN2,rm1=rm1,rm2=rm2,pm1=pm1,pm2=pm2) return(out) }# }}} ##' @export BootcovariancerecurrenceS <- function(data,type1,type2,status="status",death="death", start="start",stop="stop",id="id",names.count="Count",times=NULL,K=100) {# {{{ if (is.null(times)) times <- seq(0,max(data[,stop]),length=100) mu1.2 <- matrix(0,length(times),K) mu2.1 <- matrix(0,length(times),K) mu1.i <- matrix(0,length(times),K) mu2.i <- matrix(0,length(times),K) mupi <- matrix(0,length(times),K) mupg <- matrix(0,length(times),K) mu1mu2 <- matrix(0,length(times),K) n <- length(unique(data[,id])) formid <- as.formula(paste("~",id)) rrb <- blocksample(data, size = n*K, formid) rrb$strata <- floor((rrb[,id]-0.01)/n) rrb$jump <- (rrb[,status] %in% c(type1,type2)) | (rrb[,death]==1) rrb <- tie.breaker(rrb,status="jump",start=start,stop=stop,id=id) mm <- covarianceRecurrentS(rrb,type1,type2,status=status,death=death, start=start,stop=stop,id=id,names.count=names.count, strata="strata",times=times) mm <- c(mm,list(se.mui=apply(mm$EIN1N2,1,sd),se.mug=apply(mm$EN1N2,1,sd))) return(mm) }# }}} ##' @export Bootcovariancerecurrence <- function(data,type1,type2,status="status",death="death", start="start",stop="stop",id="id",names.count="Count",times=NULL,K=100) {# {{{ strata <- NULL # to avoid R-check if (is.null(times)) times <- seq(0,max(data[,stop]),length=100) mu1.2 <- matrix(0,length(times),K) mu2.1 <- matrix(0,length(times),K) mu1.i <- matrix(0,length(times),K) mu2.i <- matrix(0,length(times),K) mupi <- matrix(0,length(times),K) mupg <- matrix(0,length(times),K) mu1mu2 <- matrix(0,length(times),K) n <- length(unique(data[,id])) formid <- as.formula(paste("~",id)) rrb <- blocksample(data, size = n*K, formid) rrb$strata <- floor((rrb[,id]-0.01)/n) ## rrb$jump <- (rrb[,status]!=0) | (rrb[,death]==1) rrb$jump <- (rrb[,status] %in% c(type1,type2)) | (rrb[,death]==1) rrb <- tie.breaker(rrb,status="jump",start=start,stop=stop,id=id) for (i in 1:K) { rrbs <- subset(rrb,strata==i-1) errb <- covarianceRecurrent(rrbs,type1,type2,status=status,death=death, start=start,stop=stop,id=id,names.count=names.count) all <- timereg::Cpred(cbind(errb$time,errb$EIN1N2,errb$EN1N2,errb$EN1EN2, errb$mu1.2,errb$mu2.1,errb$mu1.i,errb$mu2.i),times) mupi[,i] <- all[,2] mupg[,i] <- all[,3] mu1mu2[,i] <- all[,4] mu1.2[,i] <- all[,5]; mu2.1[,i] <- all[,6]; mu1.i[,i] <- all[,7]; mu2.i[,i] <- all[,8] } return(list(mupi=mupi,mupg=mupg,mu1mu2=mu1mu2,time=times, EN1N2=mupg,EIN1N2=mupi,EN1EN=mu1mu2, mu1.2=mu1.2,mu1.i=mu1.i,mu2.1=mu2.1,mu2.i=mu1.i, mup=apply(mupi,1,mean),mug=apply(mupg,1,mean), dmupg=apply(mupg-mupi,1,mean),mmu1mu2=apply(mu1mu2,1,mean), se.mui=apply(mupi,1,sd),se.mug=apply(mupg,1,sd) ### se.dmug=apply(mupg-mu1mu2,1,sd),se.dmui=apply(mupi-mu1mu2,1,sd), ### se.difmugmup=apply(mupg-mupi,1,sd), se.mu1mu2=apply(mu1mu2,1,sd) )) }# }}} iidCovarianceRecurrent <- function (rec1,death,xrS,xr,means) {# {{{ ### makes iid decompition for covariance under independence between events axr <- rec1 adr <- death St <- exp(-adr$cum[, 2]) timesr <- axr$cum[, 1] timesd <- adr$cum[, 1] times <- c(timesr[-1], timesd[-1]) or <- order(times) times <- times[or] meano <- cbind(means$time,means$mean2risk) imeano <- sindex.prodlim(means$time, times, strict = FALSE) meano <- meano[imeano,2] keepr <- order(or)[1:length(timesr[-1])] rid <- sindex.prodlim(timesd, times, strict = FALSE) rir <- sindex.prodlim(timesr, times, strict = FALSE) Stt <- St[rid] ariid <- axr$cum[rir, 2] mu <- cumsum(meano * Stt * diff(c(0, ariid))) muS <- cumsum( Stt * diff(c(0, ariid))) nc <- length(axr$B.iid) muiid <- matrix(0, length(times), nc) cc <- xrS$cox.prep rrs <- .Call("riskstrataR",cc$sign*cc$strata,cc$id,max(cc$id)+1)$risk rr <- .Call("riskstrataR",cc$sign,cc$id,max(cc$id)+1)$risk ntot <- revcumsumstrata(cc$sign,rep(0,nrow(rr)),1) rr <- apply(rr,2,revcumsumstrata,rep(0,nrow(rr)),1) rrs <- apply(rrs,2,revcumsumstrata,rep(0,nrow(rr)),1) xrid <- sindex.prodlim(cc$time, times, strict = FALSE) rr <- rr[xrid,] rrs <- rrs[xrid,] ntot <- ntot[xrid] rrs <- apply(Stt* diff(c(0,ariid))*rrs,2,cumsum) ### dmu <- diff(c(0,mu)) rrcum <- apply(Stt*meano*diff(c(0,ariid))*rr,2,cumsum) miid <- (rrs-rrcum)/ntot for (i in 1:nc) { mriid <- axr$B.iid[[i]] mdiid <- adr$B.iid[[i]] mriid <- mriid[rir] mdiid <- mdiid[rid] dmridd <- diff(c(0, mriid)) dmdidd <- diff(c(0, mdiid)) muiid[, i] <- cumsum(Stt * meano* dmridd) - mu * cumsum(dmdidd) + cumsum(mu * dmdidd) + miid[,i] } var1 <- apply(muiid^2, 1, sum) se.mu <- var1[keepr]^0.5 mu = mu[keepr] timeso <- times times <- times[keepr] out = list(iidtimes=timeso,muiid=muiid,times=times, mu = mu, var.mu = var1[keepr], se.mu = se.mu, St = St, Stt = Stt[keepr], cumhaz=cbind(times,mu),se.cumhaz=cbind(times,se.mu), nstrata=1,strata=rep(0,length(mu)),jumps=1:length(mu)) }# }}} mets/R/phreg.R0000644000176200001440000020335513623061405012663 0ustar liggesusers###{{{ phreg0 phreg0 <- function(X,entry,exit,status,id=NULL,strata=NULL,beta,stderr=TRUE,method="NR",...) {# {{{ p <- ncol(X) if (missing(beta)) beta <- rep(0,p) if (p==0) X <- cbind(rep(0,length(exit))) if (!is.null(strata)) { # {{{ stratalev <- levels(strata) strataidx <- lapply(stratalev,function(x) which(strata==x)) if (!all(unlist(lapply(strataidx,function(x) length(x)>0)))) stop("Strata without any observation") dd <- lapply(strataidx, function(ii) { entryi <- entry[ii] trunc <- !is.null(entryi) if (!trunc) entryi <- rep(0,length(exit[ii])) .Call("FastCoxPrep", entryi,exit[ii],status[ii], as.matrix(X)[ii,,drop=FALSE], id[ii], trunc, PACKAGE="mets") }) if (!is.null(id)) id <- unlist(lapply(dd,function(x) x$id[x$jumps+1])) obj <- function(pp,U=FALSE,all=FALSE) { val <- lapply(dd,function(d) with(d, .Call("FastCoxPL",pp,X,XX,sign,jumps,PACKAGE="mets"))) ploglik <- Reduce("+",lapply(val,function(x) x$ploglik)) gradient <- Reduce("+",lapply(val,function(x) x$gradient)) hessian <- Reduce("+",lapply(val,function(x) x$hessian)) if (all) { U <- do.call("rbind",lapply(val,function(x) x$U)) hessiantime <- do.call("rbind",lapply(val,function(x) x$hessianttime)) time <- lapply(dd,function(x) x$time[x$ord+1]) ord <- lapply(dd,function(x) x$ord+1) jumps <- lapply(dd,function(x) x$jumps+1) jumptimes <- lapply(dd,function(x) x$time[x$ord+1][x$jumps+1]) S0 <- lapply(val,function(x) x$S0) nevent <- unlist(lapply(S0,length)) return(list(ploglik=ploglik,gradient=gradient,hessian=hessian, U=U,S0=S0,nevent=nevent,hessianttime=hessiantime, ord=ord,time=time,jumps=jumps,jumptimes=jumptimes)) } structure(-ploglik,gradient=-gradient,hessian=-hessian) }# }}} } else { # {{{ trunc <- !is.null(entry) if (!trunc) entry <- rep(0,length(exit)) system.time(dd <- .Call("FastCoxPrep", entry,exit,status,X, as.integer(seq_along(entry)), !is.null(entry), PACKAGE="mets")) if (!is.null(id)) id <- dd$id[dd$jumps+1] obj <- function(pp,U=FALSE,all=FALSE) { val <- with(dd, .Call("FastCoxPL",pp,X,XX,sign,jumps,PACKAGE="mets")) if (all) { val$time <- dd$time[dd$ord+1] val$ord <- dd$ord+1 val$jumps <- dd$jumps+1 val$jumptimes <- val$time[val$jumps] val$nevent <- length(val$S0) return(val) } with(val, structure(-ploglik, gradient=-gradient, hessian=-hessian)) } }# }}} opt <- NULL if (p>0) { if (tolower(method)=="nr") { opt <- lava::NR(beta,obj,...) opt$estimate <- opt$par } else { opt <- nlm(obj,beta,...) opt$method <- "nlm" } cc <- opt$estimate; names(cc) <- colnames(X) if (!stderr) return(cc) val <- c(list(coef=cc),obj(opt$estimate,all=TRUE)) } else { val <- obj(0,all=TRUE) val[c("ploglik","gradient","hessian","U")] <- NULL } ### computes Breslow estimator cumhaz <- NULL res <- c(val, list(strata=strata, entry=entry, exit=exit, status=status, p=p, X=X, id=id, opt=opt,cum=cumhaz)) class(res) <- "phreg" res } # }}} ###}}} phreg0 ###{{{ phreg01 phreg01 <- function(X,entry,exit,status,id=NULL,strata=NULL,offset=NULL,weights=NULL, strata.name=NULL,cumhaz=TRUE, beta,stderr=TRUE,method="NR",no.opt=FALSE,Z=NULL,propodds=NULL,AddGam=NULL, case.weights=NULL,...) { p <- ncol(X) if (missing(beta)) beta <- rep(0,p) if (p==0) X <- cbind(rep(0,length(exit))) if (is.null(strata)) { strata <- rep(0,length(exit)); nstrata <- 1; strata.level <- NULL; } else { strata.level <- levels(strata) ustrata <- sort(unique(strata)) nstrata <- length(ustrata) strata.values <- ustrata if (is.numeric(strata)) strata <- fast.approx(ustrata,strata)-1 else { strata <- as.integer(factor(strata,labels=seq(nstrata)))-1 } } if (is.null(offset)) offset <- rep(0,length(exit)) if (is.null(weights)) weights <- rep(1,length(exit)) strata.call <- strata Zcall <- matrix(1,1,1) ## to not use for ZX products when Z is not given if (!is.null(Z)) Zcall <- Z ## possible casewights to use for bootstrapping and other things if (is.null(case.weights)) case.weights <- rep(1,length(exit)) trunc <- (!is.null(entry)) if (!trunc) entry <- rep(0,length(exit)) if (!is.null(id)) { ids <- unique(id) nid <- length(ids) if (is.numeric(id)) id <- fast.approx(ids,id)-1 else { id <- as.integer(factor(id,labels=seq(nid)))-1 } } else id <- as.integer(seq_along(entry))-1; ## orginal id coding into integers id.orig <- id+1; dd <- .Call("FastCoxPrepStrata", entry,exit,status,X, id, trunc,strata,weights,offset,Zcall,case.weights,PACKAGE="mets") dd$nstrata <- nstrata obj <- function(pp,U=FALSE,all=FALSE) {# {{{ if (is.null(propodds) & is.null(AddGam)) val <- with(dd, .Call("FastCoxPLstrata",pp,X,XX,sign,jumps, strata,nstrata,weights,offset,ZX,caseweights,PACKAGE="mets")) else if (is.null(AddGam)) val <- with(dd, .Call("FastCoxPLstrataPO",pp,X,XX,sign,jumps, strata,nstrata,weights,offset,ZX,propodds,PACKAGE="mets")) else val <- with(dd, .Call("FastCoxPLstrataAddGam",pp,X,XX,sign,jumps, strata,nstrata,weights,offset,ZX, AddGam$theta,AddGam$dimthetades,AddGam$thetades,AddGam$ags,AddGam$varlink,AddGam$dimjumprv,AddGam$jumprv,AddGam$JumpsCauses,PACKAGE="mets")) if (all) { val$time <- dd$time val$ord <- dd$ord+1 val$jumps <- dd$jumps+1 val$jumptimes <- val$time[val$jumps] val$weightsJ <- dd$weights[val$jumps] val$case.weights <- dd$case.weights[val$jumps] val$strata.jumps <- val$strata[val$jumps] val$nevent <- length(val$S0) val$nstrata <- dd$nstrata val$strata <- dd$strata return(val) } with(val,structure(-ploglik,gradient=-gradient,hessian=-hessian)) }# }}} opt <- NULL if (p>0) { if (no.opt==FALSE) { if (tolower(method)=="nr") { tim <- system.time(opt <- lava::NR(beta,obj,...)) opt$timing <- tim opt$estimate <- opt$par } else { opt <- nlm(obj,beta,...) opt$method <- "nlm" } cc <- opt$estimate; names(cc) <- colnames(X) if (!stderr) return(cc) val <- c(list(coef=cc),obj(opt$estimate,all=TRUE)) } else val <- c(list(coef=beta),obj(beta,all=TRUE)) } else { val <- obj(0,all=TRUE) } se.cumhaz <- lcumhaz <- lse.cumhaz <- NULL II <- NULL ### computes Breslow estimator if (cumhaz==TRUE) { # {{{ if (no.opt==FALSE & p!=0) { II <- - tryCatch(solve(val$hessian),error= function(e) matrix(0,nrow(val$hessian),ncol(val$hessian)) ) } else II <- matrix(0,p,p) strata <- val$strata[val$jumps] nstrata <- val$nstrata jumptimes <- val$jumptimes ## Brewslow estimator cumhaz <- cbind(jumptimes,cumsumstrata(1/val$S0,strata,nstrata)) if ((no.opt==FALSE & p!=0)) { DLambeta.t <- apply(val$E/c(val$S0),2,cumsumstrata,strata,nstrata) varbetat <- rowSums((DLambeta.t %*% II)*DLambeta.t) ### covv <- apply(covv*DLambeta.t,1,sum) Covariance is "0" by construction } else varbetat <- 0 var.cumhaz <- cumsumstrata(1/val$S0^2,strata,nstrata)+varbetat se.cumhaz <- cbind(jumptimes,(var.cumhaz)^.5) colnames(cumhaz) <- c("time","cumhaz") colnames(se.cumhaz) <- c("time","se.cumhaz") } # }}} else {cumhaz <- se.cumhaz <- lcumhaz <- lse.cumhaz <- NULL} res <- c(val, list(cox.prep=dd, strata.call=strata.call, strata.level=strata.level, entry=entry, exit=exit, status=status, p=p, X=X, offsets=offset, weights=weights, id=id.orig, opt=opt, cumhaz=cumhaz, se.cumhaz=se.cumhaz, lcumhaz=lcumhaz, lse.cumhaz=lse.cumhaz, II=II,strata.name=strata.name,propodds=propodds)) class(res) <- "phreg" res } ###}}} phreg0 ###{{{ phreg ##' Fast Cox PH regression ##' ##' Fast Cox PH regression ##' Robust variance is default variance with the summary. ##' ##' influence functions (iid) will follow numerical order of given cluster variable ##' so ordering after $id will give iid in order of data-set. ##' ##' @param formula formula with 'Surv' outcome (see \code{coxph}) ##' @param data data frame ##' @param offset offsets for cox model ##' @param weights weights for Cox score equations ##' @param ... Additional arguments to lower level funtions ##' @author Klaus K. Holst, Thomas Scheike ##' @aliases phreg phreg.par robust.phreg readPhreg ##' @examples ##' data(TRACE) ##' dcut(TRACE) <- ~. ##' out1 <- phreg(Surv(time,status==9)~vf+chf+strata(wmicat.4),data=TRACE) ##' ## tracesim <- timereg::sim.cox(out1,1000) ##' ## sout1 <- phreg(Surv(time,status==1)~vf+chf+strata(wmicat.4),data=tracesim) ##' ## robust standard errors default ##' summary(out1) ##' ##' par(mfrow=c(1,2)) ##' bplot(out1) ##' ## bplot(sout1,se=TRUE) ##' ##' ## computing robust variance for baseline ##' rob1 <- robust.phreg(out1) ##' bplot(rob1,se=TRUE,robust=TRUE) ##' ##' ## making iid decomposition of regression parameters ##' betaiiid <- iid(out1) ##' ##' @export phreg <- function(formula,data,offset=NULL,weights=NULL,...) {# {{{ cl <- match.call() m <- match.call(expand.dots = TRUE)[1:3] special <- c("strata", "cluster","offset") Terms <- terms(formula, special, data = data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) Y <- model.extract(m, "response") if (!is.Surv(Y)) stop("Expected a 'Surv'-object") if (ncol(Y)==2) { exit <- Y[,1] entry <- NULL ## rep(0,nrow(Y)) status <- Y[,2] } else { entry <- Y[,1] exit <- Y[,2] status <- Y[,3] } id <- strata <- NULL if (!is.null(attributes(Terms)$specials$cluster)) { ts <- survival::untangle.specials(Terms, "cluster") pos.cluster <- ts$terms Terms <- Terms[-ts$terms] id <- m[[ts$vars]] } else pos.cluster <- NULL if (!is.null(attributes(Terms)$specials$strata)) { ts <- survival::untangle.specials(Terms, "strata") pos.strata <- ts$terms Terms <- Terms[-ts$terms] strata <- m[[ts$vars]] strata.name <- ts$vars } else { strata.name <- NULL; pos.strata <- NULL} ### if (!is.null(attributes(Terms)$specials$offset)) { ### ts <- survival::untangle.specials(Terms, "offset") ### pos.offset <- ts$terms ### Terms <- Terms[-ts$terms] ### offset <- m[[ts$vars]] ### } else pos.offset <- NULL X <- model.matrix(Terms, m) if (!is.null(intpos <- attributes(Terms)$intercept)) X <- X[,-intpos,drop=FALSE] if (ncol(X)==0) X <- matrix(nrow=0,ncol=0) res <- c(phreg01(X,entry,exit,status,id,strata,offset,weights,strata.name,...), list(call=cl,model.frame=m,formula=formula,strata.pos=pos.strata,cluster.pos=pos.cluster)) class(res) <- "phreg" res }# }}} ##' @export readPhreg <- function (object, newdata, nr=TRUE, ...) {# {{{ exit <- entry <- status <- clusters <- NULL if (missing(newdata)) { # {{{ X <- object$X strataNew <- object$strata if (!nr) { exit <- object$exit; entry <- object$entry; status <- object$status; clusters <- object$id } } else { ## make design for newdata xlev <- lapply(object$model.frame,levels) ff <- unlist(lapply(object$model.frame,is.factor)) upf <- update(object$formula,~.) tt <- terms(upf) if (nr) tt <- delete.response(tt) X <- model.matrix(tt,data=newdata,xlev=xlev)[,-1,drop=FALSE] if (!nr) { allvar <- all.vars(tt) pr <- length(allvar)-ncol(object$model.frame)+1 if (pr==2) { exit <- newdata[,allvar[1]] status <- newdata[,allvar[2]] } else { entry <- newdata[,allvar[1]] exit <- newdata[,allvar[2]] status <- newdata[,allvar[3]] } } clusterTerm<- grep("^cluster[(][A-z0-9._:]*",colnames(X),perl=TRUE) ## remove clusterTerm from design if (length(clusterTerm)==1) { clusters <- X[,clusterTerm] X <- X[,-clusterTerm,drop=FALSE] id <- clusters id.orig <- id; if (!is.null(id)) { ids <- unique(id) nid <- length(ids) if (is.numeric(id)) id <- fast.approx(ids,id)-1 else { id <- as.integer(factor(id,labels=seq(nid)))-1 } clusters <- id } else clusters <- (1:nrow(newdata))-1 } strataTerm<- grep("^strata[(][A-z0-9._:]*",colnames(X),perl=TRUE) ## remove strataTerm from design, and construct numeric version of strata if (length(strataTerm)>=1) { strataNew <- X[,strataTerm,drop=FALSE] if (length(strataTerm)>=1) { ## construct strata levels numeric strataNew <- c(strataNew %*% seq(1,length(strataTerm))) } X <- X[,-strataTerm,drop=FALSE] } else strataNew <- rep(0,nrow(X)) }# }}} return(list(X=X,strata=strataNew,entry=entry,exit=exit,status=status, clusters=clusters)) }# }}} ###}}} phreg ###{{{ phregR ##' Fast Cox PH regression and calculations done in R to make play and adjustments easy ##' ##' Fast Cox PH regression with R implementation to play and adjust in R function: FastCoxPLstrataR ##' ##' Robust variance is default variance with the summary. ##' ##' influence functions (iid) will follow numerical order of given cluster variable ##' so ordering after $id will give iid in order of data-set. ##' ##' @param formula formula with 'Surv' outcome (see \code{coxph}) ##' @param data data frame ##' @param offset offsets for cox model ##' @param weights weights for Cox score equations ##' @param ... Additional arguments to lower level funtions ##' @author Klaus K. Holst, Thomas Scheike ##' @aliases FastCoxPLstrataR ##' ##' @export phregR <- function(formula,data,offset=NULL,weights=NULL,...) {# {{{ cl <- match.call() m <- match.call(expand.dots = TRUE)[1:3] special <- c("strata", "cluster","offset") Terms <- terms(formula, special, data = data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) Y <- model.extract(m, "response") if (!is.Surv(Y)) stop("Expected a 'Surv'-object") if (ncol(Y)==2) { exit <- Y[,1] entry <- NULL ## rep(0,nrow(Y)) status <- Y[,2] } else { entry <- Y[,1] exit <- Y[,2] status <- Y[,3] } id <- strata <- NULL if (!is.null(attributes(Terms)$specials$cluster)) { ts <- survival::untangle.specials(Terms, "cluster") pos.cluster <- ts$terms Terms <- Terms[-ts$terms] id <- m[[ts$vars]] } else pos.cluster <- NULL if (!is.null(attributes(Terms)$specials$strata)) { ts <- survival::untangle.specials(Terms, "strata") pos.strata <- ts$terms Terms <- Terms[-ts$terms] strata <- m[[ts$vars]] strata.name <- ts$vars } else { strata.name <- NULL; pos.strata <- NULL} ### if (!is.null(attributes(Terms)$specials$offset)) { ### ts <- survival::untangle.specials(Terms, "offset") ### pos.offset <- ts$terms ### Terms <- Terms[-ts$terms] ### offset <- m[[ts$vars]] ### } else pos.offset <- NULL X <- model.matrix(Terms, m) if (!is.null(intpos <- attributes(Terms)$intercept)) X <- X[,-intpos,drop=FALSE] if (ncol(X)==0) X <- matrix(nrow=0,ncol=0) res <- c(phreg01R(X,entry,exit,status,id,strata,offset,weights,strata.name,...), list(call=cl,model.frame=m,formula=formula,strata.pos=pos.strata,cluster.pos=pos.cluster)) class(res) <- "phreg" res }# }}} phreg01R <- function(X,entry,exit,status,id=NULL,strata=NULL,offset=NULL,weights=NULL, strata.name=NULL,cumhaz=TRUE, beta,stderr=TRUE,method="NR",no.opt=FALSE,Z=NULL,propodds=NULL,AddGam=NULL, case.weights=NULL,...) {# {{{ p <- ncol(X) if (missing(beta)) beta <- rep(0,p) if (p==0) X <- cbind(rep(0,length(exit))) if (is.null(strata)) { strata <- rep(0,length(exit)); nstrata <- 1; strata.level <- NULL; } else { strata.level <- levels(strata) ustrata <- sort(unique(strata)) nstrata <- length(ustrata) strata.values <- ustrata if (is.numeric(strata)) strata <- fast.approx(ustrata,strata)-1 else { strata <- as.integer(factor(strata,labels=seq(nstrata)))-1 } } if (is.null(offset)) offset <- rep(0,length(exit)) if (is.null(weights)) weights <- rep(1,length(exit)) strata.call <- strata Zcall <- matrix(1,1,1) ## to not use for ZX products when Z is not given if (!is.null(Z)) Zcall <- Z ## possible casewights to use for bootstrapping and other things if (is.null(case.weights)) case.weights <- rep(1,length(exit)) trunc <- (!is.null(entry)) if (!trunc) entry <- rep(0,length(exit)) if (!is.null(id)) { ids <- unique(id) nid <- length(ids) if (is.numeric(id)) id <- fast.approx(ids,id)-1 else { id <- as.integer(factor(id,labels=seq(nid)))-1 } } else id <- as.integer(seq_along(entry))-1; ## orginal id coding into integers id.orig <- id+1; dd <- .Call("FastCoxPrepStrata", entry,exit,status,X, id,trunc,strata,weights,offset,Zcall,case.weights,PACKAGE="mets") dd$nstrata <- nstrata obj <- function(pp,U=FALSE,all=FALSE) {# {{{ if (is.null(propodds) & is.null(AddGam)) cc <- system.time( val <- with(dd, FastCoxPLstrataR(pp,X,XX,sign,jumps, strata,nstrata,weights,offset,ZX,caseweights)) ) else if (is.null(AddGam)) val <- with(dd, .Call("FastCoxPLstrataPO",pp,X,XX,sign,jumps, strata,nstrata,weights,offset,ZX,propodds,PACKAGE="mets")) else val <- with(dd, .Call("FastCoxPLstrataAddGam",pp,X,XX,sign,jumps, strata,nstrata,weights,offset,ZX, AddGam$theta,AddGam$dimthetades,AddGam$thetades,AddGam$ags,AddGam$varlink,AddGam$dimjumprv,AddGam$jumprv,AddGam$JumpsCauses,PACKAGE="mets")) ### ccR <- ### system.time( ### valR <- with(dd, .Call("FastCoxPLstrata",pp,X,XX,sign,jumps, strata,nstrata,weights,offset,ZX,caseweights, ### PACKAGE="mets")) ### ) ### print(cc) ### print(ccR) if (all) { val$time <- dd$time val$ord <- dd$ord+1 val$jumps <- dd$jumps+1 val$jumptimes <- val$time[val$jumps] val$weightsJ <- dd$weights[val$jumps] val$case.weights <- dd$case.weights[val$jumps] val$strata.jumps <- val$strata[val$jumps] val$nevent <- length(val$S0) val$nstrata <- dd$nstrata val$strata <- dd$strata return(val) } with(val,structure(-ploglik,gradient=-gradient,hessian=-hessian)) }# }}} opt <- NULL if (p>0) { if (no.opt==FALSE) { if (tolower(method)=="nr") { tim <- system.time(opt <- lava::NR(beta,obj,...)) opt$timing <- tim opt$estimate <- opt$par } else { opt <- nlm(obj,beta,...) opt$method <- "nlm" } cc <- opt$estimate; names(cc) <- colnames(X) if (!stderr) return(cc) val <- c(list(coef=cc),obj(opt$estimate,all=TRUE)) } else val <- c(list(coef=beta),obj(beta,all=TRUE)) } else { val <- obj(0,all=TRUE) } se.cumhaz <- lcumhaz <- lse.cumhaz <- NULL II <- NULL ### computes Breslow estimator if (cumhaz==TRUE) { # {{{ if (no.opt==FALSE & p!=0) { II <- - tryCatch(solve(val$hessian),error= function(e) matrix(0,nrow(val$hessian),ncol(val$hessian)) ) } else II <- matrix(0,p,p) strata <- val$strata[val$jumps] nstrata <- val$nstrata jumptimes <- val$jumptimes ## Brewslow estimator cumhaz <- cbind(jumptimes,cumsumstrata(1/val$S0,strata,nstrata)) if ((no.opt==FALSE & p!=0)) { DLambeta.t <- apply(val$E/c(val$S0),2,cumsumstrata,strata,nstrata) varbetat <- rowSums((DLambeta.t %*% II)*DLambeta.t) ### covv <- apply(covv*DLambeta.t,1,sum) Covariance is "0" by construction } else varbetat <- 0 var.cumhaz <- cumsumstrata(1/val$S0^2,strata,nstrata)+varbetat se.cumhaz <- cbind(jumptimes,(var.cumhaz)^.5) colnames(cumhaz) <- c("time","cumhaz") colnames(se.cumhaz) <- c("time","se.cumhaz") } # }}} else {cumhaz <- se.cumhaz <- lcumhaz <- lse.cumhaz <- NULL} res <- c(val, list(cox.prep=dd, strata.call=strata.call, strata.level=strata.level, entry=entry, exit=exit, status=status, p=p, X=X, offsets=offset, weights=weights, id=id.orig, opt=opt, cumhaz=cumhaz, se.cumhaz=se.cumhaz, lcumhaz=lcumhaz, lse.cumhaz=lse.cumhaz, II=II,strata.name=strata.name,propodds=propodds)) class(res) <- "phreg" res }# }}} ##' @export FastCoxPLstrataR <- function(beta, X, XX, Sign, Jumps, strata, nstrata, weights, offsets, ZX, caseweights) {# {{{ p=length(beta) strata=c(strata) Xb = c(X %*% beta+offsets) eXb = c(exp(Xb)*weights); if (nrow((Sign))==length(eXb)) { ## Truncation eXb = c(Sign)*eXb; } S0 = c(revcumsumstrata(eXb,strata,nstrata)) E=apply(eXb*X,2,revcumsumstrata,strata,nstrata)/S0; Jumps=Jumps+1 E = E[Jumps,]; E2=.Call("vecMatMat",E,E)$vXZ; XX2=apply(XX*eXb,2,revcumsumstrata,strata,nstrata)/S0; ## mat XX2=revcumsumstrataMatCols(XX,eXb,S0,strata,nstrata); XX2 = XX2[Jumps,]; weightsJ=weights[Jumps]; caseweightsJ=caseweights[Jumps]; S0 = S0[Jumps]; grad = (X[Jumps,]-E); ## Score val = (Xb[Jumps]-log(S0)); ## Partial log-likelihood ## colvec iweightsJ=1/weightsJ; S02 = S0/(caseweightsJ*weightsJ); ## S0 with weights to estimate baseline grad2= grad*(caseweightsJ*weightsJ); ## score with weights gradient=apply(grad2,2,sum) val2 = caseweightsJ*weightsJ*val; ## Partial log-likelihood with weights hesst = -(XX2-E2); ## hessian contributions in jump times ### hess = matrix(apply(hesst,2,sum),p,p); hesst2 = hesst*(caseweightsJ*weightsJ); ## hessian over time with weights hess2 = matrix(apply(hesst2,2,sum),p,p); ## hessian with weights out=list(jumps=Jumps, ploglik=sum(val2),U=grad2, gradient=matrix(gradient,1,p), hessian=hess2, hessianttime=hesst2, S2S0=XX2, E=E, S0=S02 ) return(out) }# }}} ###}}} ###{{{ simcox ##' @export simCox <- function(n=1000, seed=1, beta=c(1,1), entry=TRUE) { if (!is.null(seed)) set.seed(seed) m <- lvm() regression(m,T~X1+X2) <- beta distribution(m,~T+C) <- coxWeibull.lvm(scale=1/100) distribution(m,~entry) <- coxWeibull.lvm(scale=1/10) m <- eventTime(m,time~min(T,C=0),"status") d <- sim(m,n); if (!entry) d$entry <- 0 else d <- subset(d, time>entry,select=-c(T,C)) return(d) } ###}}} simcox ###{{{ vcov ##' @export vcov.phreg <- function(object,...) { res <- crossprod(ii <- iid(object,...)) attributes(res)$ncluster <- attributes(ii)$ncluster attributes(res)$invhess <- attributes(ii)$invhess colnames(res) <- rownames(res) <- names(coef(object)) res } ###}}} vcov ###{{{ coef ##' @export coef.phreg <- function(object,...) { object$coef } ###}}} coef ###{{{ iid & Robust variances ##' @export iid.phreg <- function(x,type="robust",all=FALSE,...) {# {{{ invhess <- -solve(x$hessian) orig.order <- FALSE if (is.null(x$propodds)) { if (type=="robust") { # {{{ cox model xx <- x$cox.prep ii <- invhess S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 Z <- xx$X U <- E <- matrix(0,nrow(xx$X),x$p) E[xx$jumps+1,] <- x$E U[xx$jumps+1,] <- x$U cumhaz <- cbind(xx$time,cumsumstrata(S0i,xx$strata,xx$nstrata)) EdLam0 <- apply(E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) rr <- c(xx$sign*exp(Z %*% coef(x) + xx$offset)) ### Martingale as a function of time and for all subjects to handle strata MGt <- U[,drop=FALSE]-(Z*cumhaz[,2]-EdLam0)*rr*c(xx$weights) if (orig.order) { oo <- (1:nrow(xx$X))[xx$ord+1] oo <- order(oo) ### back to order of iid variable MGt <- MGt[oo,,drop=FALSE] ## sum after id later so not needed id <- xx$id[oo] } else id <- xx$id } else { MGt <- x$U; MG.base <- 1/x$S0; }# }}} } else { if (type=="robust") { # {{{ prop-odds model logitSurv xx <- x$cox.prep ii <- invhess S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 Z <- xx$X U <- E <- matrix(0,nrow(xx$X),x$p) E[xx$jumps+1,] <- x$E U[xx$jumps+1,] <- x$U cumhazA <- cumsumstratasum(S0i,xx$strata,xx$nstrata,type="all") cumhaz <- c(cumhazA$sum) cumhazm <- cumhazA$lagsum ### EdLam0 <- apply(E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) rr <- c(xx$sign*exp(Z %*% coef(x) + xx$offset)) rro <- c(exp(Z %*% coef(x) + xx$offset)) S0star <- revcumsumstrata(rr/(1+rro*cumhazm),xx$strata,xx$nstrata) S0 <- revcumsumstrata(rr,xx$strata,xx$nstrata) S1 <- apply(Z*rr,2,revcumsumstrata,xx$strata,xx$nstrata) Et <- S1/c(S0) lt <- apply((Z-Et)*c(rr*rro/(1+rro*cumhazm)),2,revcumsumstrata,xx$strata,xx$nstrata) Estar <- S0star/S0 EstardLam <- cumsumstrata(Estar*S0i,xx$strata,xx$nstrata) k <- exp(-EstardLam) basecor <- apply(lt*c(k*S0i),2,revcumsumstrata,xx$strata,xx$nstrata) basecor <- basecor/c(k*S0) www <- x$propoddsW*x$weightsJ U[xx$jumps+1,] <- U[xx$jumps+1,] - c(www)* basecor[xx$jumps+1,] baseDLam0 <- apply(basecor*S0i,2,cumsumstrata,xx$strata,xx$nstrata) ### Martingale as a function of time and for all subjects to handle strata MGt <- U[,drop=FALSE]-(Z*cumhaz-EdLam0-baseDLam0)*rr*c(xx$weights) if (orig.order) { oo <- (1:nrow(xx$X))[xx$ord+1] oo <- order(oo) ### back to order of data-set MGt <- MGt[oo,,drop=FALSE] id <- xx$id[oo] } else id <- xx$id } else { MGt <- x$U; MG.base <- 1/x$S0; }# }}} } ncluster <- NULL if (type=="robust" & (!is.null(x$id) | any(x$entry>0))) { if (type=="martingale") id <- x$id[x$jumps] ### ii <- mets::cluster.index(id) UU <- apply(MGt,2,sumstrata,id,max(id)+1) ### names of clusters given in call if (!is.null(x$id)) rownames(UU) <- unique(x$id) ncluster <- nrow(UU) } else { UU <- MGt } structure(UU%*%invhess,invhess=invhess,ncluster=ncluster) } # }}} ##' @export residuals.phreg <- function(object,cumsum=FALSE,...) {# {{{ orig.order <- FALSE x <- object if (is.null(x$propodds)) { # {{{ cox model xx <- x$cox.prep dN <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 dN[xx$jumps+1] <- 1 cumhaz <- cumsumstrata(S0i,xx$strata,xx$nstrata) Z <- xx$X ### EdLam0 <- apply(S0i,2,cumsumstrata,xx$strata,xx$nstrata) if (is.null(coef(x))) rr <- c(xx$sign*exp(xx$offset)) else rr <- c(xx$sign*exp(Z %*% coef(x) + xx$offset)) ### dMartingale as a function of time and for all subjects to handle strata Lamt <- (cumhaz)*rr*c(xx$weights) dMGt <- dN-Lamt if (orig.order) { oo <- (1:nrow(xx$X))[xx$ord+1] oo <- order(oo) ### back to order of iid variable dMGt <- dMGt[oo,,drop=FALSE] ## sum after id later so not needed id <- xx$id[oo] } else id <- xx$id } else { ## }}} # {{{ prop-odds model logitSurv xx <- x$cox.prep dN <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 dN[xx$jumps+1] <- 1 U <- E <- matrix(0,nrow(xx$X),x$p) E[xx$jumps+1,] <- x$E U[xx$jumps+1,] <- x$U S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/x$S0 cumhazA <- cumsumstratasum(S0i,xx$strata,xx$nstrata,type="all") cumhaz <- c(cumhazA$sum) cumhazm <- cumhazA$lagsum ### EdLam0 <- apply(E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) rr <- c(xx$sign*exp(Z %*% coef(x) + xx$offset)) rro <- c(exp(Z %*% coef(x) + xx$offset)) S0star <- revcumsumstrata(rr/(1+rro*cumhazm),xx$strata,xx$nstrata) S0 <- revcumsumstrata(rr,xx$strata,xx$nstrata) S1 <- apply(Z*rr,2,revcumsumstrata,xx$strata,xx$nstrata) Et <- S1/c(S0) lt <- apply((Z-Et)*c(rr*rro/(1+rro*cumhazm)),2,revcumsumstrata,xx$strata,xx$nstrata) Estar <- S0star/S0 EstardLam <- cumsumstrata(Estar*S0i,xx$strata,xx$nstrata) k <- exp(-EstardLam) basecor <- apply(lt*c(k*S0i),2,revcumsumstrata,xx$strata,xx$nstrata) basecor <- basecor/c(k*S0) www <- x$propoddsW*x$weightsJ U[xx$jumps+1,] <- U[xx$jumps+1,] - c(www)* basecor[xx$jumps+1,] baseDLam0 <- apply(basecor*S0i,2,cumsumstrata,xx$strata,xx$nstrata) ### Martingale as a function of time and for all subjects to handle strata MGt <- U[,drop=FALSE]-(Z*cumhaz-EdLam0-baseDLam0)*rr*c(xx$weights) if (orig.order) { oo <- (1:nrow(xx$X))[xx$ord+1] oo <- order(oo) ### back to order of data-set MGt <- MGt[oo,,drop=FALSE] id <- xx$id[oo] } else id <- xx$id }# }}} ncluster <- NULL if (!cumsum) { mid <- max(id)+1 Mt <- sumstrata(dMGt,id,mid) cumhaz <- sumstrata(Lamt,id,mid) ### names of clusters given in call ### if (!is.null(x$id)) names(Mt) <- unique(x$id) ### if (!is.null(x$id)) names(cumhaz) <- unique(x$id) ### ncluster <- nrow(UU) out <- list(residuals=c(Mt),cumhaz=c(cumhaz)) } else { mid <- max(id)+1 out <- data.frame(dMGt=c(dMGt),Lamt=Lamt,status=dN, time=c(xx$time),id=c(xx$id)+1,sign=xx$sign) dsort(out) <- ~time+status+id-sign Mt <- cumsumstrata(out$dMGt,out$id-1,mid) cumhaz <- cumsumstrata(out$Lamt,out$id-1,mid) out <- cbind(out,Mt,cumhaz) out <- subset(out,sign==1) ddrop(out) <- ~sign+dMGt+Lamt } return(out) } # }}} ##' @export robust.basehaz.phreg <- function(x,type="robust",fixbeta=NULL,...) {# {{{ IsdM <- squareintHdM(x,ft=NULL,fixbeta=fixbeta,...) ### varA <- IsdM$varInt[x$jumps] strata <- x$strata[x$jumps] cumhaz <- x$cumhaz se.cumhaz <- cbind(cumhaz[,1],varA^.5) colnames(se.cumhaz) <- c("time","se.cumhaz") return(list(cumhaz=cumhaz,se.cumhaz=se.cumhaz,strata=strata)) } # }}} ##' @export robust.phreg robust.phreg <- function(x,fixbeta=NULL,...) { if (is.null(fixbeta)) if (is.null(x$opt) | is.null(x$coef)) fixbeta<- 1 else fixbeta <- 0 if (fixbeta==0) { gamma.iid <- iid.phreg(x) robvar <- crossprod(gamma.iid) } else robvar <- gamma.iid <- NULL baseline <- robust.basehaz.phreg(x,fixbeta=fixbeta,...); ## add arguments so that we can call basehazplot.phreg res <- c(x,list(gamma.iid=gamma.iid,robvar=robvar,robse.cumhaz=baseline$se.cumhaz)) class(res) <- "phreg" return(res) } ###}}} ###{{{ summary ##' @export summary.phreg <- function(object,type=c("robust","martingale"),...) { cc <- ncluster <- V <- NULL if (!is.null(object$propodds)) { cat("Proportional odds model, log-OR regression \n"); } if (length(object$p)>0 & object$p>0 & !is.null(object$opt)) { I <- -solve(object$hessian) if ( (length(class(object))==2) && class(object)[2]=="cif.reg") { V <- object$var ncluster <- nrow(object$Uiid) } else { V <- vcov(object,type=type[1]) ncluster <- object$n } cc <- cbind(coef(object),diag(V)^0.5,diag(I)^0.5) cc <- cbind(cc,2*(pnorm(abs(cc[,1]/cc[,2]),lower.tail=FALSE))) colnames(cc) <- c("Estimate","S.E.","dU^-1/2","P-value") if (length(class(object))==1) if (!is.null(ncluster <- attributes(V)$ncluster)) rownames(cc) <- names(coef(object)) } Strata <- levels(object$strata) if (!is.null(Strata)) { n <- unlist(lapply(object$time,length)) } else { n <- length(object$time) } res <- list(coef=cc,n=n,nevent=object$nevent,strata=Strata,ncluster=ncluster,var=V) class(res) <- "summary.phreg" res } ###}}} summary ###{{{ print.summary ##' @export print.summary.phreg <- function(x,max.strata=5,...) { cat("\n") nn <- cbind(x$n, x$nevent) rownames(nn) <- levels(x$strata); colnames(nn) <- c("n","events") if (is.null(rownames(nn))) rownames(nn) <- rep("",NROW(nn)) if (length(x$strata)>max.strata) { nn <- rbind(c(colSums(nn),length(x$strata))); colnames(nn) <- c("n","events","stratas") rownames(nn) <- "" } print(nn,quote=FALSE) if (!is.null(x$ncluster)) cat("\n ", x$ncluster, " clusters\n",sep="") if (!is.null(x$coef)) { cat("\n") printCoefmat(x$coef,...) } cat("\n") } ###}}} print.summary ##' @export tailstrata <- function(strata,nstrata) {# {{{ if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n"); res <- .Call("tailstrataR",length(strata),strata,nstrata,PACKAGE="mets") if (any(res$found<0.5)) { warning("Not all strata found"); cat((1:nstrata)[res$found>0.5]); } return(res$where) }# }}} ##' @export sumstrata <- function(x,strata,nstrata) {# {{{ if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n"); if (length(x)!=length(strata)) stop("length of x and strata must be same\n"); res <- .Call("sumstrataR",x,strata,nstrata,PACKAGE="mets")$res return(res) }# }}} ##' @export cumsumstrata <- function(x,strata,nstrata) {# {{{ if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n"); if (length(x)!=length(strata)) stop("length of x and strata must be same\n"); res <- .Call("cumsumstrataR",x,strata,nstrata,PACKAGE="mets")$res return(res) }# }}} ##' @export revcumsumstrata <- function(x,strata,nstrata) {# {{{ if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n"); if (length(x)!=length(strata)) stop("length of x and strata must be same\n"); res <- .Call("revcumsumstrataR",x,strata,nstrata,PACKAGE="mets")$res return(res) }# }}} ##' @export revcumsum <- function(x) {# {{{ res <- .Call("revcumsumR",x,PACKAGE="mets")$res return(res) }# }}} ##' @export revcumsumstratasum <- function(x,strata,nstrata,type="all") {# {{{ if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n"); if (length(x)!=length(strata)) stop("length of x and strata must be same\n"); if (type=="sum") res <- .Call("revcumsumstratasumR",x,strata,nstrata)$sum if (type=="lagsum") res <- .Call("revcumsumstratasumR",x,strata,nstrata)$lagsum if (type=="all") res <- .Call("revcumsumstratasumR",x,strata,nstrata) return(res) }# }}} ##' @export cumsumstratasum <- function(x,strata,nstrata,type="all") {# {{{ if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n"); if (length(x)!=length(strata)) stop("length of x and strata must be same\n"); if (type=="sum") res <- .Call("cumsumstratasumR",x,strata,nstrata)$sum if (type=="lagsum") res <- .Call("cumsumstratasumR",x,strata,nstrata)$lagsum if (type=="all") res <- .Call("cumsumstratasumR",x,strata,nstrata) return(res) }# }}} ##' @export matdoubleindex <- function(x,rows,cols,xvec=NULL) {# {{{ if (!is.matrix(x)) stop("x must be matrix") ncols <- ncol(x); nrows <- nrow(x) ###if (any(rows>nrows) | any(cols>ncols)) stop("indeces out of matrix \n"); ###if (any(rows<=0) | any(cols<=0)) stop("indeces out of matrix \n"); ## to avoid warnings when going to C, get rid of Inf cols[cols==Inf] <- ncol(x)+1; rows[rows==Inf] <- nrow(x)+1; if (length(rows)==1) rows <- rep(rows,length(cols)) if (length(cols)==1) cols <- rep(cols,length(rows)) if (length(cols)!=length(rows)) stop("rows and cols different lengths\n"); if (is.null(xvec)) { assign <- 0; xvec <- 1} else { assign <- 1; if (length(cols)!=length(xvec)) stop("rows and cols and xvec differ \n"); } res <- .Call("Matdoubleindex",x,rows-1,cols-1,length(cols),assign,xvec)$mat return(res) }# }}} ##' @export mdi <- function(x,...) matdoubleindex(x,...) ##' @export covfr <- function(x,y,strata,nstrata) {# {{{ if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n"); res <- .Call("covrfR",x,y,strata,nstrata) return(res) }# }}} ##' @export revcumsumidstratasum <- function(x,id,nid,strata,nstrata,type="all") {# {{{ if (any(id<0) | any(id>nid-1)) stop("id index not ok\n"); if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n"); if (type=="sum") res <- .Call("revcumsumidstratasumR",x,id,nid,strata,nstrata)$sum if (type=="lagsum") res <- .Call("revcumsumidstratasumR",x,id,nid,strata,nstrata)$lagsum if (type=="lagsumsquare") res <- .Call("revcumsumidstratasumR",x,id,nid,strata,nstrata)$lagsumsquare if (type=="all") res <- .Call("revcumsumidstratasumR",x,id,nid,strata,nstrata) return(res) }# }}} ##' @export revcumsumidstratasumCov <- function(x,y,id,nid,strata,nstrata,type="all") {# {{{ if (any(id<0) | any(id>nid-1)) stop("id index not ok\n"); if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n"); if (type=="sum") res <- .Call("revcumsumidstratasumCovR",x,y,id,nid,strata,nstrata)$sum if (type=="lagsum") res <- .Call("revcumsumidstratasumCovR",x,y,id,nid,strata,nstrata)$lagsum if (type=="lagsumsquare") res <- .Call("revcumsumidstratasumCovR",x,y,id,nid,strata,nstrata)$lagsumsquare if (type=="all") res <- .Call("revcumsumidstratasumCovR",x,y,id,nid,strata,nstrata) return(res) }# }}} ##' @export cumsumidstratasumCov <- function(x,y,id,nid,strata,nstrata,type="all") {# {{{ if (any(id<0) | any(id>nid-1)) stop("id index not ok\n"); if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n"); if (type=="sum") res <- .Call("cumsumidstratasumCovR",x,y,id,nid,strata,nstrata)$sum else res <- .Call("cumsumidstratasumCovR",x,y,id,nid,strata,nstrata) return(res) }# }}} ##' @export cumsumidstratasum <- function(x,id,nid,strata,nstrata,type="all") {# {{{ if (any(id<0) | any(id>nid-1)) stop("id index not ok\n"); if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n"); if (type=="sum") res <- .Call("cumsumidstratasumR",x,id,nid,strata,nstrata)$sum else res <- .Call("cumsumidstratasumR",x,id,nid,strata,nstrata) return(res) }# }}} ##' @export covfridstrata <- function(x,y,id,nid,strata,nstrata) {# {{{ if (any(id<0) | any(id>nid-1)) stop("id index not ok\n"); if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n"); res <- .Call("covrfstrataR",x,y,id,nid,strata,nstrata) return(res) }# }}} ##' @export covfridstrataCov <- function(x,y,x1,y1,id,nid,strata,nstrata) {# {{{ if (any(id<0) | any(id>nid-1)) stop("id index not ok\n"); if (any(strata<0) | any(strata>nstrata-1)) stop("strata index not ok\n"); res <- .Call("covrfstrataCovR",x,y,x1,y1,id,nid,strata,nstrata) return(res) }# }}} ##' Kaplan-Meier with robust standard errors ##' ##' Kaplan-Meier with robust standard errors ##' Robust variance is default variance with the summary. ##' @param formula formula with 'Surv' outcome (see \code{coxph}) ##' @param data data frame ##' @param conf.type transformation ##' @param conf.int level of confidence intervals ##' @param robust for robust standard errors based on martingales ##' @param ... Additional arguments to lower level funtions ##' @author Thomas Scheike ##' @aliases km ##' @examples ##' data(TRACE) ##' TRACE$cluster <- sample(1:100,1878,replace=TRUE) ##' out1 <- km(Surv(time,status==9)~strata(vf,chf),data=TRACE) ##' out2 <- km(Surv(time,status==9)~strata(vf,chf)+cluster(cluster),data=TRACE) ##' ##' par(mfrow=c(1,2)) ##' bplot(out1,se=TRUE) ##' bplot(out2,se=TRUE) ##' @export km <- function(formula,data=data,conf.type="log",conf.int=0.95,robust=TRUE,...) {# {{{ coxo <- phreg(formula,data=data) coxo <- robust.phreg(coxo) chaz <- coxo$cumhaz[,2] time <- coxo$cumhaz[,1] if (robust) std.err <- coxo$robse.cumhaz[,2] else std.err <- coxo$se.cumhaz[,2] strat <- coxo$strata[coxo$jumps] S0i <- 1/coxo$S0 kmt <- exp(cumsumstrata(log(1-S0i),strat,coxo$nstrata)) temp <- list(surv=kmt) zval <- qnorm(1 - (1 - conf.int)/2, 0, 1) ### different conf-types if (conf.type == "plain") {# {{{ temp1 <- temp$surv + zval * std.err * temp$surv temp2 <- temp$surv - zval * std.err * temp$surv temp <- c(temp, list(upper = pmin(temp1, 1), lower = pmax(temp2, 0), conf.type = "plain", conf.int = conf.int)) } if (conf.type == "log") { xx <- ifelse(temp$surv == 0, 1, temp$surv) temp1 <- ifelse(temp$surv == 0, NA, exp(log(xx) + zval * std.err)) temp2 <- ifelse(temp$surv == 0, NA, exp(log(xx) - zval * std.err)) temp <- c(temp, list(upper = pmin(temp1, 1), lower = temp2, conf.type = "log", conf.int = conf.int)) } if (conf.type == "log-log") { who <- (temp$surv == 0 | temp$surv == 1) temp3 <- ifelse(temp$surv == 0, NA, 1) xx <- ifelse(who, 0.1, temp$surv) temp1 <- exp(-exp(log(-log(xx)) + zval * std.err/log(xx))) temp1 <- ifelse(who, temp3, temp1) temp2 <- exp(-exp(log(-log(xx)) - zval * std.err/log(xx))) temp2 <- ifelse(who, temp3, temp2) temp <- c(temp, list(upper = temp1, lower = temp2, conf.type = "log-log", conf.int = conf.int)) }# }}} ### to use basehazplot.phreg temp <- c(temp, list(cumhaz=cbind(time,kmt),se.cumhaz=cbind(time,kmt*std.err),time=time, strata=strat,nstrata=coxo$nstrata, jumps=1:length(kmt),strata.name=coxo$strata.name,strata.level=coxo$strata.level)) class(temp) <- c("km","phreg") return(temp) }# }}} ##' Cumulative incidence with robust standard errors ##' ##' Cumulative incidence with robust standard errors ##' @param formula formula with 'Surv' outcome (see \code{coxph}) ##' @param data data frame ##' @param cause NULL looks at all, otherwise specify which cause to consider ##' @param cens.code censoring code "0" is default ##' @param ... Additional arguments to lower level funtions ##' @author Thomas Scheike ##' @aliases cif ##' @examples ##' data(TRACE) ##' TRACE$cluster <- sample(1:100,1878,replace=TRUE) ##' out1 <- cif(Event(time,status)~+1,data=TRACE,cause=9) ##' out2 <- cif(Event(time,status)~+1+cluster(cluster),data=TRACE,cause=9) ##' ##' out1 <- cif(Event(time,status)~strata(vf,chf),data=TRACE,cause=9) ##' out2 <- cif(Event(time,status)~strata(vf,chf)+cluster(cluster),data=TRACE,cause=9) ##' ##' par(mfrow=c(1,2)) ##' bplot(out1,se=TRUE) ##' bplot(out2,se=TRUE) ##' @export cif <- function(formula,data=data,cause=1,cens.code=0,...) {# {{{ cl <- match.call() m <- match.call(expand.dots = TRUE)[1:3] special <- c("strata", "cluster","offset") Terms <- terms(formula, special, data = data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) Y <- model.extract(m, "response") if (class(Y)!="Event") stop("Expected a 'Event'-object") if (ncol(Y)==2) { exit <- Y[,1] entry <- NULL ## rep(0,nrow(Y)) status <- Y[,2] } else { entry <- Y[,1] exit <- Y[,2] status <- Y[,3] } id <- strata <- NULL if (!is.null(attributes(Terms)$specials$cluster)) { ts <- survival::untangle.specials(Terms, "cluster") Terms <- Terms[-ts$terms] id <- m[[ts$vars]] } if (!is.null(stratapos <- attributes(Terms)$specials$strata)) { ts <- survival::untangle.specials(Terms, "strata") Terms <- Terms[-ts$terms] strata <- m[[ts$vars]] strata.name <- ts$vars } else strata.name <- NULL if (!is.null(offsetpos <- attributes(Terms)$specials$offset)) { ts <- survival::untangle.specials(Terms, "offset") Terms <- Terms[-ts$terms] offset <- m[[ts$vars]] } X <- model.matrix(Terms, m) if (!is.null(intpos <- attributes(Terms)$intercept)) X <- X[,-intpos,drop=FALSE] if (ncol(X)==0) X <- matrix(nrow=0,ncol=0) id.orig <- id; if (!is.null(id)) { ids <- sort(unique(id)) nid <- length(ids) if (is.numeric(id)) id <- fast.approx(ids,id)-1 else { id <- as.integer(factor(id,labels=seq(nid)))-1 } } else id <- as.integer(seq_along(exit))-1; statusE <- 1*(status==cause) statusD <- 1*(status!=cens.code) if (ncol(Y)==3) { if (!is.null(strata)) { formE <- as.formula(paste("Surv(entry,exit,statusE)~strata(strata)+cluster(id_1_)",sep="")) formD <- as.formula(paste("Surv(entry,exit,statusD)~strata(strata)+cluster(id_1_)",sep="")) } else { formE <- as.formula(paste("Surv(entry,exit,statusE)~1+cluster(id_1_)",sep="")) formD <- as.formula(paste("Surv(entry,exit,statusD)~1+cluster(id_1_)",sep="")) } } else { if (!is.null(strata)) { formE <- as.formula(paste("Surv(exit,statusE)~strata(strata)+cluster(id_1_)",sep="")) formD <- as.formula(paste("Surv(exit,statusD)~strata(strata)+cluster(id_1_)",sep="")) } else { formE <- as.formula(paste("Surv(exit,statusE)~cluster(id_1_)",sep="")) formD <- as.formula(paste("Surv(exit,statusD)~cluster(id_1_)",sep="")) } } data$id_1_ <- id if (sum(statusE)==0) warning("No events of type 1\n"); coxE <- phreg(formE,data=data,...) coxS <- phreg(formD,data=data,...) ### cif cifo <- recurrentMarginal(coxE,coxS) ### to use basehazplot.phreg class(cifo) <- c("cif","phreg") return(cifo) }# }}} ##' Proportional odds survival model ##' ##' Semiparametric Proportional odds model, that has the advantage that ##' \deqn{ ##' logit(S(t|x)) = \log(\Lambda(t)) + x \beta ##' } ##' so covariate effects give OR of survival. ##' ##' This is equivalent to using a hazards model ##' \deqn{ ##' Z \lambda(t) \exp(x \beta) ##' } ##' where Z is gamma distributed with mean and variance 1. ##' ##' @param formula formula with 'Surv' outcome (see \code{coxph}) ##' @param data data frame ##' @param offset offsets for exp(x beta) terms ##' @param weights weights for score equations ##' @param ... Additional arguments to lower level funtions ##' @author Thomas Scheike ##' @examples ##' data(TRACE) ##' dcut(TRACE) <- ~. ##' out1 <- logitSurv(Surv(time,status==9)~vf+chf+strata(wmicat.4),data=TRACE) ##' summary(out1) ##' gof(out1) ##' bplot(out1) ##' ##' @export logitSurv <- function(formula,data,offset=NULL,weights=NULL,...) {# {{{ out <- phreg(formula,data,offset=offset,weights=weights,propodds=1,...) return(out) }# }}} ###{{{ predict with se for baseline predictPhreg <- function(x,jumptimes,S0,beta,time=NULL,X=NULL,surv=FALSE,band=FALSE,...) { strata <- x$strata[x$jumps]# {{{ nstrata <- x$nstrata ## Brewslow estimator if (is.null(x$cumhaz)) { ##II <- x$II ##x$jumptimes II <- -solve(x$hessian) chaz <- cbind(jumptimes,cumsumstrata(1/S0,strata,nstrata)) DLambeta.t <- apply(x$E/c(x$S0),2,cumsumstrata,strata,nstrata) varbetat <- apply((DLambeta.t %*% II)*DLambeta.t,1,sum) se.chaz <- cbind(jumptimes,(cumsumstrata(1/S0^2,strata,nstrata)+varbetat)^.5) } else { chaz <- x$cumhaz se.chaz <- x$se.cumhaz } if (!is.null(time)) { ### do within strata chaz <- Cpred(chaz,time) se.chaz <- Cpred(se.chaz,time) } colnames(chaz) <- c("time","chaz") colnames(se.chaz) <- c("time","se.chaz") if (band==TRUE) { ## on log-scale for one strata# {{{ ii <- -solve(x$hessian) Ubeta <- x$U betaiid <- t(ii %*% t(Ubeta)) cumhaz <- x$cumhaz[,1,drop=FALSE] se.chaz <- x$se.cumhaz[,1] ### rr <- c( exp(sum(c(X) %*% x$coef))) Pt <- outer(cumhaz[,2],c(X)) DLambeta.t <- apply(x$E/c(x$S0),2,cumsumstrata,strata,nstrata) Pt <- DLambeta.t - Pt ### se of cumulaive hazard for this covariate , can use different versions of variance for beta varbetat <- rowSums((Pt %*% ii)*Pt) se.chazexb <- cbind(jumptimes,rr*(cumsumstrata(1/S0^2,strata,nstrata)+varbetat)^.5) ### sig <- 0.95 ### n.sim <- 1000 ### simband <- .Call("simBandCumHazCox",rr/x$S0,Pt,betaiid,n.sim,sig,se.chazexb[,2],PACKAGE="mets") ### ## coefficients for uniform bands on log-scale ### uband <- apply(simband$supUsim,2,percen,per=1-sig); }# }}} if (!is.null(X)) { H <- exp(X%*%beta) if (nrow(chaz)==length(H)) { chaz[,2] <- chaz[,2]*H } else { chaz2 <- c() X <- rbind(X) for (i in seq(nrow(X))) chaz2 <- rbind(chaz2, cbind(chaz[,1],chaz[,2]*H[i], rep(1,nrow(chaz))%x%X[i,,drop=FALSE])) chaz <- chaz2; nn <- c("time","chaz",names(beta)) colnames(chaz) <- nn } } if (surv) { chaz[,2] <- exp(-chaz[,2]) colnames(chaz)[2] <- "surv" } return(chaz) }# }}} ##' Predictions from proportional hazards model ##' ##' @param object phreg object ##' @param newdata data.frame ##' @param times Time where to predict variable, default is all time-points from the object sorted ##' @param individual.time when TRUE then newdata and times have same length and makes only predictions for these individual times. ##' @param tminus to make predictions in T- that is just before, useful for IPCW techniques ##' @param se with standard errors and upper and lower confidence intervals. ##' @param robust to get robust se's. ##' @param conf.type transformation for suvival estimates, default is log ##' @param conf.int significance level ##' @param km to use Kaplan-Meier for baseline \deqn{S_{s0}(t)= (1 - dA_{s0}(t))} where s is strata. ##' @param ... Additional arguments to plot functions ##' @aliases tailstrata revcumsumstrata revcumsumstratasum cumsumstrata sumstrata covfr covfridstrata covfridstrataCov cumsumidstratasum cumsumidstratasumCov cumsumstratasum revcumsum revcumsumidstratasum revcumsumidstratasumCov robust.basehaz.phreg matdoubleindex mdi ##' @export predict.phreg <- function(object,newdata, times=NULL,individual.time=FALSE,tminus=FALSE,se=TRUE,robust=FALSE,conf.type="log",conf.int=0.95,km=FALSE,...) {# {{{ default is all time-points from the object ### take baseline and strata from object# {{{ strata <- object$strata[object$jumps] nstrata <- object$nstrata jumptimes <- object$cumhaz[,1] chaz <- object$cumhaz[,2] if (se) { if (!robust) { se.chaz <- object$se.cumhaz[,2] varbeta <- object$II Pt <- apply(object$E/c(object$S0),2,cumsumstrata,strata,nstrata) } else { if (is.null(object$opt) | is.null(object$coef)) fixbeta<- 1 else fixbeta <- 0 IsdM <- squareintHdM(object,ft=NULL,fixbeta=fixbeta,...) ### se.chaz <- IsdM$varInt[object$jumps]^.5 covv <- IsdM$covv[object$jumps,,drop=FALSE] varbeta <- IsdM$vbeta Pt <- IsdM$Ht[object$jumps,,drop=FALSE] } } # }}} ### setting up newdata with factors and strata desX <- readPhreg(object,newdata) X <- desX$X strataNew <- desX$strata ### print(length(strata)); ### if (se) print(length(se.chaz)); ### print(dim(X)); print(head(X)); print(length(strataNew)) if (is.null(times)) times <- sort(unique(c(object$exit))) if (individual.time & is.null(times)) times <- c(object$exit) se.cumhaz <- NULL if (!individual.time) { surv <- matrix(0,nrow(X),length(times)) if (se) se.cumhaz <- matrix(0,nrow(X),length(times)) } else { surv <- matrix(0,nrow(X),1) if (se) se.cumhaz <- matrix(0,nrow(X),1) } hazt <- length(times) for (j in unique(strataNew)) { where <- sindex.prodlim(c(0,jumptimes[strata==j]),times,strict=tminus) hhazt <- hazt <- c(0,chaz[strata==j]) if (km) { hazt <- c(1,exp(cumsum(log(1-diff(hazt))))); hazt[is.na(hazt)] <- 0 } hazt <- hazt[where] hhazt <- hhazt[where] if (se) se.hazt <- c(0,se.chaz[strata==j])[where] Xs <- X[strataNew==j,,drop=FALSE] ### offs <- object$offsets[object$strata==j] if (object$p==0) RR <- rep(1,nrow(Xs)) else RR <- c(exp( Xs %*% coef(object))) if (se) { # {{{ based on Hazard's if (object$p>0) { Ps <- Pt[strata==j,,drop=FALSE] Ps <- rbind(0,Ps)[where,,drop=FALSE] ## print(Xs); print(varbeta); print(dim(Ps)); print((Xs %*% varbeta)) Xbeta <- Xs %*% varbeta seXbeta <- rowSums(Xbeta*Xs)^.5 cov2 <- cov1 <- Xbeta %*% t(Ps*hhazt) if (robust) { covvs <- covv[strata==j,,drop=FALSE] covvs <- rbind(0,covvs)[where,,drop=FALSE] covv1 <- Xs %*% t((covvs*hhazt)) cov1 <- cov1-covv1 } } else cov1 <- 0 }# }}} if (is.null(object$propodds)) { if (!km) { if (!individual.time) surv[strataNew==j,] <- exp(- RR%o%hazt) else surv[strataNew==j,] <- exp(-RR*hazt[strataNew==j]) } else { if (!individual.time) surv[strataNew==j,] <- NULL else surv[strataNew==j,] <- hazt[strataNew==j]^RR } } else { if (!individual.time) surv[strataNew==j,] <- 1/(1+RR%o%hazt) else surv[strataNew==j,] <- 1/(1+RR*hazt[strataNew==j]) } if (se) {# {{{ if (object$p>0) { if (!individual.time) se.cumhaz[strataNew==j,] <- ((RR %o% se.hazt)^2+(c(RR*seXbeta) %o% hhazt)^2-2*RR^2*cov1)^.5 else se.cumhaz[strataNew==j,] <- RR* (se.hazt^2+(c(seXbeta)*hhazt)^2-2*diag(cov1))^.5 } else { if (!individual.time) se.cumhaz[strataNew==j,] <- RR %o% (se.hazt) else se.cumhaz[strataNew==j,] <- RR* se.hazt[strataNew==j] } }# }}} } zval <- qnorm(1 - (1 - conf.int)/2, 0, 1) std.err <- se.cumhaz cisurv <- list() cisurv$upper <- NULL cisurv$lower <- NULL ### different conf-types for surv if (se) {# {{{ if (conf.type == "plain") {# {{{ temp1 <- surv + zval * std.err * surv temp2 <- surv - zval * std.err * surv cisurv <- list(upper = pmin(temp1, 1), lower = pmax(temp2, 0), conf.type = "plain", conf.int = conf.int) } if (conf.type == "log") { xx <- ifelse(surv == 0, 1, surv) temp1 <- ifelse(surv == 0, NA, exp(log(xx) + zval * std.err)) temp2 <- ifelse(surv == 0, NA, exp(log(xx) - zval * std.err)) cisurv <- list(upper = pmin(temp1, 1), lower = temp2, conf.type = "log", conf.int = conf.int) } if (conf.type == "log-log") { who <- (surv == 0 | surv == 1) temp3 <- ifelse(surv == 0, NA, 1) xx <- ifelse(who, 0.1, surv) temp1 <- exp(-exp(log(-log(xx)) + zval * std.err/log(xx))) temp1 <- ifelse(who, temp3, temp1) temp2 <- exp(-exp(log(-log(xx)) - zval * std.err/log(xx))) temp2 <- ifelse(who, temp3, temp2) cisurv <- list(upper = temp1, lower = temp2, conf.type = "log-log", conf.int = conf.int) }# }}} }# }}} if (object$p>0) RR <- exp(X %*% coef(object)) else RR <- rep(1,nrow(X)) out <- list(surv=surv,times=times, surv.upper=cisurv$upper,surv.lower=cisurv$lower,cumhaz=-log(surv),se.cumhaz=se.cumhaz, X=Xs, RR=RR) if (length(class(object))==2 && substr(class(object)[2],1,3)=="cif") { out <- c(out,list(cif=1-out$surv,cif.lower=1-out$surv.upper, cif.upper=1-out$surv.lower)) } class(out) <- c("predictphreg") if (length(class(object))==2) class(out) <- c("predictphreg",class(object)[2]) return(out) }# }}} ##' @export plot.predictphreg <- function(x,se=FALSE,add=FALSE,ylim=NULL,xlim=NULL,lty=NULL,col=NULL,type=c("surv","cumhaz","cif"),ylab=NULL,xlab=NULL, polygon=TRUE,level=0.95,whichx=NULL,robust=FALSE,...) {# {{{ if (type[1]=="surv" & is.null(ylab)) ylab <- "Survival probability" if (type[1]=="cif" & is.null(ylab)) ylab <- "Cumulative probability" if (type[1]=="surv" & length(class(x))==2) ylab <- "Cumulative probability" if (type[1]=="cumhaz" & is.null(ylab)) ylab <- "Cumulative hazard" if (is.null(xlab)) xlab <- "time" level <- -qnorm((1-level)/2) if (type[1]=="surv") rr <- c(0,1) if (type[1]=="cumhaz") rr <- range(c(0,x$cumhaz)) ylimo <- ylim if (is.null(ylim)) ylim <- rr if (is.null(xlim)) xlim <- range(x$times) if (is.null(x$se.cumhaz) & se==TRUE) { warning("predict.phreg must be with se=TRUE\n"); se <- FALSE } if (se==TRUE) { if (is.null(x$se.cumhaz)) stop("predict.phreg must be with se=TRUE\n"); if (type[1]=="surv") rrse <- range(c(x$surv.upper,x$surv.lower)) if (type[1]=="cumhaz") { cumhaz.upper <- x$cumhaz+level*x$se.cumhaz cumhaz.lower <- x$cumhaz-level*x$se.cumhaz rrse <- range(c(cumhaz.upper,cumhaz.lower)) } ### if (type[1]=="surv") rrse <- c(max(0,rrse[1]),min(rrse[2],1)) if (type[1]=="surv") rrse <- c(0,1) if (type[1]=="cumhaz") rrse <- c(max(0,rrse[1]),rrse[2]) if (is.null(ylimo)) ylim <- rrse } ## all covriates nx <- nrow(x$surv) if (is.null(whichx)) whichx <- 1:nx stratas <- whichx ltys <- lty cols <- col if (length(whichx)>0 ) { ## with X if (!is.matrix(lty)) { if (is.null(lty)) ltys <- 1:length(whichx) else if (length(lty)!=length(whichx)) ltys <- rep(lty[1],length(whichx)) else ltys <- lty } else ltys <- lty if (!is.matrix(col)) { if (is.null(col)) cols <- 1:length(stratas) else if (length(col)!=length(stratas)) cols <- rep(col[1],length(stratas)) } else cols <- col } else { if (is.matrix(col)) cols <- col if (is.null(col)) cols <- 1 else cols <- col[1] if (is.matrix(lty)) ltys <- lty if (is.null(lty)) ltys <- 1 else ltys <- lty[1] } if (!is.matrix(ltys)) ltys <- cbind(ltys,ltys,ltys) if (!is.matrix(cols)) cols <- cbind(cols,cols,cols) i <- 1 j <- whichx[i] cifreg <- FALSE if ((length(class(x))==2) && (substr(class(x)[2],1,3)=="cif")) cifreg <- TRUE if (type[1]=="surv") { xx <- x$surv if (cifreg) xx <- x$cif } else if (type[1]=="cif") { xx <- 1-x$surv } else xx <- x$cumhaz if (se) { if (type[1]=="surv") { upper <- x$surv.upper; lower <- x$surv.lower if (cifreg) { upper <- x$cif.upper; lower <- x$cif.lower} } else if (type[1]=="cif") { upper <- 1-x$surv.lower; lower <- 1-x$surv.upper } else { upper <- cumhaz.upper; lower <- cumhaz.lower} } if (!add) plot(x$times,xx[j,],type="s",lty=ltys[i,1],col=cols[i,1],ylim=ylim,ylab=ylab,xlim=xlim,xlab=xlab,...) else lines(x$times,xx[j,],type="s", lty=ltys[i,1],col=cols[i,1],...) if (length(whichx)>1) for (i in seq(2,length(whichx))) lines(x$times,xx[whichx[i],],type="s",lty=ltys[i,1],col=cols[i,1],...) if (se==TRUE) { for (i in seq(1,length(whichx))) { j <- whichx[i] ul <- upper[j,]; nl <- lower[j,]; if (!polygon) { lines(x$times,nl,type="s",lty=ltys[i,2],col=cols[i,2]) lines(x$times,ul,type="s",lty=ltys[i,3],col=cols[i,3]) } else { ll <- length(x$times) tt <- c(x$times,rev(x$times)) yy <- c(nl,rev(ul)) ttp <- c(x$times[1],rep(x$times[-c(1,ll)],each=2),x$times[ll]) tt <- c(ttp,rev(ttp)) yy <- c(rep(nl[-ll],each=rep(2)),rep(rev(ul[-ll]),each=2)) col.alpha<-0.1 col.ci<-cols[i,1] col.trans <- sapply(col.ci, FUN=function(x) do.call(grDevices::rgb,as.list(c(grDevices::col2rgb(x)/255,col.alpha)))) polygon(tt,yy,lty=0,col=col.trans) } } } where <- "topleft"; if (type[1]=="surv") where <- "topright" ### if (legend & (!add)) ### graphics::legend(where,legend=legend,col=cols[,1],lty=ltys[,1]) }# }}} ###}}} predict ###{{{ plot ##' Plotting the baslines of stratified Cox ##' ##' Plotting the baslines of stratified Cox ##' @param x phreg object ##' @param se to include standard errors ##' @param time to plot for specific time variables ##' @param add to add to previous plot ##' @param ylim to give ylim ##' @param xlim to give xlim ##' @param lty to specify lty of components ##' @param col to specify col of components ##' @param legend to specify col of components ##' @param ylab to specify ylab ##' @param xlab to specify xlab ##' @param polygon to get standard error in shaded form ##' @param level of standard errors ##' @param stratas wich strata to plot ##' @param robust to use robust standard errors if possible ##' @param ... Additional arguments to lower level funtions ##' @author Klaus K. Holst, Thomas Scheike ##' @aliases basehazplot.phreg bplot basecumhaz plotConfRegion ##' @examples ##' data(TRACE) ##' dcut(TRACE) <- ~. ##' out1 <- phreg(Surv(time,status==9)~vf+chf+strata(wmicat.4),data=TRACE) ##' ##' par(mfrow=c(2,2)) ##' bplot(out1) ##' bplot(out1,stratas=c(0,3)) ##' bplot(out1,stratas=c(0,3),col=2:3,lty=1:2,se=TRUE) ##' bplot(out1,stratas=c(0),col=2,lty=2,se=TRUE,polygon=FALSE) ##' bplot(out1,stratas=c(0),col=matrix(c(2,1,3),1,3), ##' lty=matrix(c(1,2,3),1,3),se=TRUE,polygon=FALSE) ##' @export basehazplot.phreg <- function(x,se=FALSE,time=NULL,add=FALSE,ylim=NULL,xlim=NULL, lty=NULL,col=NULL,legend=TRUE,ylab=NULL,xlab=NULL, polygon=TRUE,level=0.95,stratas=NULL,robust=FALSE,...) {# {{{ if (class(x)[1]=="phreg" & is.null(ylab)) ylab <- "Cumulative hazard" if (class(x)[1]=="km" & is.null(ylab)) ylab <- "Survival probability" if (class(x)[1]=="cif" & is.null(ylab)) ylab <- "Probability" if (is.null(xlab)) xlab <- "time" level <- -qnorm((1-level)/2) ### if (log==FALSE) rr <- range(x$cumhaz[,-1]) ### else rr <- range(log(x$cumhaz[,-1]),na.rm=TRUE) strat <- x$strata[x$jumps] ylimo <- ylim if (is.null(ylim)) ylim <- rr if (is.null(xlim)) xlim <- range(x$cumhaz[,1]) if (se==TRUE) { if (is.null(x$se.cumhaz) & is.null(x$robse.cumhaz) ) stop("phreg must be with cumhazard=TRUE\n"); rrse <- range(c(x$cumhaz[,-1]+level*x$se.cumhaz[,-1])) if (class(x)[1]=="km") rrse <- c(min(x$lower,na.rm=TRUE),1) ### else rrse <- range(log(c(x$cumhaz[,-1]+level*x$se.cumhaz[,-1])),na.rm=TRUE) if (is.null(ylimo)) ylim <- rrse } ## all strata if (is.null(stratas)) stratas <- 0:(x$nstrata-1) ltys <- lty cols <- col if (length(stratas)>0 & x$nstrata>1) { ## with strata lstrata <- x$strata.level[(stratas+1)] stratn <- substring(x$strata.name,8,nchar(x$strata.name)-1) stratnames <- paste(stratn,lstrata,sep=":") if (!is.matrix(lty)) { if (is.null(lty)) ltys <- 1:length(stratas) else if (length(lty)!=length(stratas)) ltys <- rep(lty[1],length(stratas)) } else ltys <- lty if (!is.matrix(col)) { if (is.null(col)) cols <- 1:length(stratas) else if (length(col)!=length(stratas)) cols <- rep(col[1],length(stratas)) } else cols <- col } else { stratnames <- "Baseline" if (is.matrix(col)) cols <- col if (is.null(col)) cols <- 1 else cols <- col[1] if (is.matrix(lty)) ltys <- lty if (is.null(lty)) ltys <- 1 else ltys <- lty[1] } if (!is.matrix(ltys)) ltys <- cbind(ltys,ltys,ltys) if (!is.matrix(cols)) cols <- cbind(cols,cols,cols) first <- 0 for (i in seq(stratas)) { j <- stratas[i] cumhazard <- x$cumhaz[strat==j,,drop=FALSE] if (!is.null(cumhazard)) { if (nrow(cumhazard)>1) { if (add | first==1) lines(cumhazard,type="s",lty=ltys[i,1],col=cols[i,1]) else { first <- 1 plot(cumhazard,type="s",lty=ltys[i,1],col=cols[i,1],ylim=ylim,ylab=ylab,xlab=xlab, xlim=xlim,...) } if (se==TRUE) { if (robust==TRUE) secumhazard <- x$robse.cumhaz[strat==j,,drop=FALSE] else secumhazard <- x$se.cumhaz[strat==j,,drop=FALSE] ul <-cbind(cumhazard[,1],cumhazard[,2]+level*secumhazard[,2]) nl <-cbind(cumhazard[,1],cumhazard[,2]-level*secumhazard[,2]) if (class(x)[1]=="km") { ul[,2] <- x$upper[x$strata==j]; nl[,2] <- x$lower[x$strata==j]; wna <- which(is.na(ul[,2])) ul[wna,2] <- 0 nl[wna,2] <- 0 } if (!polygon) { lines(nl,type="s",lty=ltys[i,2],col=cols[i,2]) lines(ul,type="s",lty=ltys[i,3],col=cols[i,3]) } else { ## type="s" confidence regions ll <- length(nl[,1]) timess <- nl[,1] ttp <- c(timess[1],rep(timess[-c(1,ll)],each=2),timess[ll]) tt <- c(ttp,rev(ttp)) yy <- c(rep(nl[-ll,2],each=rep(2)),rep(rev(ul[-ll,2]),each=2)) ### tt <- c(nl[,1],rev(ul[,1])) ### yy <- c(nl[,2],rev(ul[,2])) col.alpha<-0.1 col.ci<-cols[j+1] col.trans <- sapply(col.ci, FUN=function(x) do.call(grDevices::rgb,as.list(c(grDevices::col2rgb(x)/255,col.alpha)))) polygon(tt,yy,lty=0,col=col.trans) } } } } } where <- "topleft"; if (class(x)[1]=="km") where <- "topright" if (legend & (!add)) graphics::legend(where,legend=stratnames,col=cols[,1],lty=ltys[,1]) }# }}} ##' @export plotConfRegion <- function(x,band,add=TRUE,polygon=TRUE,col=1,...) {# {{{ nl <- cbind(x,band[,1]) ul <- cbind(x,band[,2]) if (!polygon) { lines(nl,type="s",...) lines(ul,type="s",...) } else { ll <- length(nl[,1]) timess <- nl[,1] ttp <- c(timess[1],rep(timess[-c(1,ll)],each=2),timess[ll]) tt <- c(ttp,rev(ttp)) yy <- c(rep(nl[-ll,2],each=rep(2)),rep(rev(ul[-ll,2]),each=2)) col.alpha<-0.1 col.ci<-col[1] col.trans <- sapply(col.ci, FUN=function(x) do.call(grDevices::rgb,as.list(c(grDevices::col2rgb(x)/255,col.alpha)))) polygon(tt,yy,lty=0,col=col.trans,...) } }# }}} ##' @export bplot <- function(x,...) basehazplot.phreg(x,...) ##' @export basecumhaz <- function(x,type="matrix",robust=FALSE,...) {# {{{ ## all strata strat <- x$strata[x$jumps] stratas <- 0:(x$nstrata-1) ### se.cum <- cum <- x$cumhaz se.cum <- cum <- c() strata <- rep(0,nrow(x$cumhaz)) if (type=="matrix") { se.cum <- cum <- x$cumhazard } if (robust==TRUE) secum <- x$robse.cumhaz else secum <- x$se.cumhaz if (is.null(secum)) nose <- TRUE else nose <- FALSE start <- 1 for (i in stratas) { cumhazard <- x$cumhaz[strat==i,,drop=FALSE] if (!is.null(cumhazard)) { nr <- nrow(cumhazard) if (nr>=1) { slut <- start-1+nr ### cum[start:slut,] <- cumhazard cum <- rbind(cum,cumhazard) ### if (!nose) se.cum[start:slut,] <- secum[strat==i,] if (!nose) se.cum <- rbind(se.cum,secum[strat==i,]) strata[start:slut] <- i start <- slut+1 } } } list(cumhaz=cum,se.cumhaz=se.cum,strata=strata) }# }}} ##' @export lines.phreg <- function(x,...,add=TRUE) plot(x,...,add=add) ###}}} plot ###{{{ plot ##' @export plot.phreg <- function(x,surv=TRUE,X=NULL,time=NULL,add=FALSE,...) { if (!is.null(X) && nrow(X)>1) { P <- lapply(split(X,seq(nrow(X))),function(xx) predict(x,X=xx,time=time,surv=surv)) } else { P <- predict(x,X=X,time=time,surv=surv) } if (!is.list(P)) { if (add) { lines(P,type="s",...) } else { plot(P,type="s",...) } return(invisible(P)) } if (add) { lines(P[[1]][,1:2],type="s",lty=1,col=1,...) } else { plot((P[[1]])[,1:2],type="s",lty=1,col=1,...) } for (i in seq_len(length(P)-1)+1) { lines(P[[i]][,1:2],type="s",lty=i,col=i,...) } return(invisible(P)) } ##' @export lines.phreg <- function(x,...,add=TRUE) plot(x,...,add=add) ###}}} plot ###{{{ print ##' @export print.phreg <- function(x,...) { cat("Call:\n") dput(x$call) print(summary(x),...) } ###}}} print mets/R/sim-nordic-twin.R0000644000176200001440000002655113623061405014602 0ustar liggesusers F1addfg<-function(t,lam0=0.13,beta=c(-0.5),x=0) # FG { ## {{{ baset <- lam0*pnorm((t-.70)/0.15) return( 1 - exp(-baset*exp(c(x * beta)))) } ## }}} ##' @export corsim.prostate <- function(n,theta=1,thetaslope=0,censS=c(0,1),pcens=0.5,test=0,mt=1,same.cens=TRUE,country=TRUE, delayed=FALSE,ptrunc=0.5,lam0=0.13,truncS=c(0,1)) { ## {{{ ###n <- 10; theta <- 1; thetaslope <- 0; mt <- 1 if (country==TRUE) xl <- sample(1:4,n,replace=TRUE) else xl <- rep(1,n) x <- (xl==1) tt<-seq(0,1,length=100) ### ###n=100;theta=1;lam0=0.5;beta=0.3;crate=2 thetat <- exp(log(theta)) F11x<-F1addfg(1,x=x,lam0=lam0) F12x<-F1addfg(1,x=x,lam0=lam0) ### thetaslut <- exp(log(theta)+thetaslope*(1-1/2)) p11 <- thetaslut*F11x*F12x/((1-F11x)+thetaslut*F11x) p12 <- F11x-p11 p21 <- F12x-p11 p22 <- 1-F12x-F11x+p11 ###print(apply(cbind(p11,p12,p21),1,sum)) ###print(cbind(p11,p12,p21,p22)) if (test==1) { ## {{{ for (i in 1:2) { print(x[i,]); F11xt<-F1addfg(tt,x=x[i,]) F12xt<-F1addfg(tt,x=x[i,]) p11t <- thetat* F11xt*F12xt/((1-F11xt)+thetat*F11xt) cortt <- ((p11t)/(F12xt-p11t))/(F11xt/(1-F11xt)) ###plot(tt,log(cortt)) if (i==1) { plot(tt,p11t,type="l",ylim=c(0,0.1),xlim=c(0,mt)) ###lines(tt,F11x[i]-p11t,col=2) ###lines(tt,F12x[i]-p11t,col=2) } else lines(tt,p11t,col=2); ###if (sum(diff(p11t<0))>0) stop("dec\n"); ###p11 <- max(p11t) ###p12 <- F11x[i]-p11 ###p21 <- F12x[i]-p11 ###p22 <- 1- F12x[i]-F11x[i]+p11 ###pnn <- 1- F12x[i]-F11x[i]+p11 } } ## }}} ###apply(cbind(p11,p12,p21,p22),1,sum) ### print(table(F11x)) print(table(p11)) types <- rep(0,n) causes <- matrix(0,n,2) stime<-matrix(1+1,n,2); for (i in 1:n) { ## {{{ ptype <- runif(1) if (ptype<=p11[i]) { types[i] <- 1 myhazx<-F1addfg(tt,x=x[i,])/F12x[i] ### if (abs(max(myhazx)-1)> 0.001) stop("not dist\n"); stime[i,2]<-Cpred(cbind(myhazx,tt),runif(1))[1,2]+runif(1,0,0.001) f1<- F1addfg(tt,x=x[i,]) myhazx<- (F12x[i]/p11[i]) * (thetat*f1/((1-f1)+thetat*f1)) ### if (abs(max(myhazx)-1)> 0.001) stop("not dist\n"); stime[i,1]<-Cpred(cbind(myhazx,tt),runif(1))[1,2]+runif(1,0,0.001) causes[i,] <- c(1,1) } if ((ptype>p11[i]) & (ptype<=p12[i]+p11[i])) { types[i] <- 2 f1 <- F1addfg(tt,x=x[i,]) myhazx<- ( f1 - thetat*F12x[i]*f1/((1-f1)+thetat*f1))/p12[i]; myhazx <- f1/F11x[i] ### if (abs(max(myhazx)-1)> 0.001) stop("not dist 2 \n"); stime[i,1]<-Cpred(cbind(myhazx,tt),runif(1))[1,2]+runif(1,0,0.001) causes[i,] <- c(1,2) stime[i,2] <- runif(1)*1 } if ((ptype>p11[i]+p12[i]) && (ptype<=p21[i]+p12[i]+p11[i])) { types[i] <- 3 f2 <- F1addfg(tt,x=x[i,]) myhazx <- (f2 - (thetat*F11x[i]*f2/((1-F11x[i])+thetat*F11x[i])))/p21[i]; myhazx <- f2/F12x[i] ### if (abs(max(myhazx)-1)> 0.001) stop("not dist3 \n"); stime[i,2]<-Cpred(cbind(myhazx,tt),runif(1))[1,2]+runif(1,0,0.001) causes[i,] <- c(2,1) stime[i,1] <- runif(1)*1 } if (ptype>p11[i]+p12[i]+p21[i] ) { types[i] <- 4 causes[i,] <- c(2,2) stime[i,1:2] <- runif(2)*1 } } ## }}} stime <- c(stime) cause <- c(causes) ###print(summary(stime)) ###print(sum(stime==mt)) ###same.cens=TRUE if (same.cens==TRUE) { ctime <- rep(rbinom(n,1,pcens)*runif(n,censS),each=2) ctime[ctime==0] <- 1; } else { ctime<- rbinom(2*n,1,pcens)*runif(2*n,censS) ctime[ctime==0] <- 1; } cens <- (ctime< stime) time <- ifelse(cens,ctime,stime) cause <- ifelse(cens,0,cause) id <- rep(1:n,rep(2,n)) country <- c() country[xl==1] <- "SWE" country[xl==2] <- "DK" country[xl==3] <- "FIN" country[xl==4] <- "NOR" if (delayed) { if (same.cens==TRUE) { etime <- rep(rbinom(n,1,ptrunc)*(runif(n,truncS)),each=2) } else etime<- rbinom(2*n,1,ptrunc)*(runif(2*n,truncS)) } else etime <- rep(0,2*n) data<-data.frame(time=mt*time,cause=cause,xl=rep(xl,each=2), country=rep(country,each=2),id=id,cens=cens,stime=mt*stime,type=rep(types,each=2), f1=rep(F11x,each=2),p11=rep(p11,each=2),p12=rep(p12,each=2),p21=rep(p21,each=2), p22=rep(p22,each=2),entry=mt*etime,truncated=(time0) cause[status==0]<-0; data<-data.frame(time=time,ctime=ctime,status=status,X=x,cause=cause) return(data) } ## }}} sim.F1<-function(n,lam0=0.5,beta=0.3,Cint=c(0,1)) { ## {{{ x<-runif(n); tt<-seq(0,1,length=100) F11x<-F1(1,x=x,beta=beta,lam0=lam0) cause1<-rbinom(n,1,F11x) ### stime<-rep(2,n); for (i in 1:n) { if (cause1[i]==1) { myhazx<-F1(tt,x=x[i],beta=beta,lam0=lam0)/F11x[i] stime[i]<-Cpred(cbind(myhazx,tt),runif(1))[1,2]+runif(1,0,0.001) } } ctime<-runif(n,Cint) time<-pmin(ctime,stime) status<-(stime0) mis <- c(mis,idx[,1]) res <- c(res,list(xx)) } } mis <- unique(mis) if (length(mis)>0) { for (i in seq_along(res)) { if (length(res[[i]])>0) res[[i]] <- res[[i]][-mis,,drop=FALSE] } } if (!missing(nam)) names(res) <- nam return(res) } DD <- resh(data.frame(x),X,Z,weights,nam=c("y","x","z","w"),onecol=3) Y00 <- matrix(c(0,0, 1,0, 0,1, 1,1),ncol=2,byrow=TRUE) if (is.null(X) && is.null(Z)) { pos <- factor(interaction(DD$y)) ipos <- unique(as.numeric(pos)) Tab <- rbind(as.vector(table(DD$y))); colnames(Tab) <- c("00","10","01","11") Y0 <- Y00 NN <- as.vector(Tab) midx1 <- 1; midx2 <- 2 X0 <- matrix(1,ncol=2,nrow=4) Z0 <- matrix(1,ncol=1,nrow=4) namX <- "(Intercept)" namZ <- "r:(Intercept)" } else { pos2 <- fast.pattern(cbind(DD$x,DD$z)) pos <- interaction(interaction(DD$y),pos2$group) XZ0 <- pos2$pattern; colnames(XZ0) <- c(colnames(DD$x),colnames(DD$z)) NN2 <- unlist(by(DD$y,pos,nrow)) NN <- rep(0,4*nrow(XZ0)) ipos <- unique(as.numeric(pos)) NN[ipos] <- NN2[ipos] ## tt <- with(DD, by(y,as.list(as.data.frame(cbind(x,z))),FUN=function(x) as.vector(table(x[,1:2])),simplify=FALSE)) ## XZ0 <- do.call("expand.grid",lapply(attributes(tt)$dimnames,as.numeric)) ## rem <- which(unlist(lapply(tt,is.null))) ## if (length(rem)>0) { ## tt <- tt[-rem] ## XZ0 <- XZ0[-rem,,drop=FALSE] ## } ## NN <- Reduce("c",tt); ## Reduce("cbind",tt) suppressWarnings(Tab <- cbind(matrix(NN,ncol=4,byrow=TRUE),XZ0)); colnames(Tab)[1:4] <- c("00","10","01","11") Y0 <- matrix(rep(t(Y00),length(NN)/4),ncol=2,byrow=TRUE) if (is.null(X)) X0 <- matrix(1,ncol=2,nrow=nrow(Y0)) else { X0 <- as.matrix(XZ0[rep(seq(nrow(XZ0)),each=4),seq(ncol(X)*2),drop=FALSE]) } if (is.null(Z)) Z0 <- matrix(1,ncol=1,nrow=nrow(Y0)) else { Z1 <- as.matrix(XZ0[,ncol(XZ0)-ncol(Z)+seq(ncol(Z)),drop=FALSE]) Z0 <- Z1[rep(seq(nrow(XZ0)),each=4),,drop=FALSE] colnames(Z0) <- colnames(Z1) } } nx <- ncol(X0)/2 midx1 <- seq(nx) midx2 <- midx1+nx midx <- seq(2*nx) blen <- ifelse(eqmarg,nx,2*nx) zlen <- ncol(Z0) plen <- blen+zlen MyData <- ExMarg(Y0,X0,W0=NULL,NULL, midx1=1,midx2=2,eqmarg=eqmarg,allmarg=FALSE,Z0) datanh <- function(r) 1/(1-r^2) dtanh <- function(z) 4*exp(2*z)/(exp(2*z)+1)^2 vartr <- tanh dvartr <- dtanh; varitr <- atanh trname <- "tanh"; itrname <- "atanh" varcompname <- "Tetrachoric correlation" ##msg <- "Variance of latent residual sterm = 1 (standard probit link)" msg <- NULL model <- list(tr=vartr,name=trname,inv=itrname,invname=itrname,deriv=dvartr,varcompname=varcompname,eqmarg=eqmarg,blen=blen,zlen=zlen,...) SigmaFun <- function(p,Z=MyData$Z0,cor=TRUE,...) { if (!cor) { r <- vartr(p[1]) Sigma <- matrix(c(1,r,r,1),2) attributes(Sigma)$dvartr <- dvartr return(Sigma) } val <- Z%*%p dr <- apply(Z,2,function(x) x*dvartr(val)) structure(list(rho=vartr(val),lp=val,drho=dr),dvartr=dvartr,vartr=vartr) } if (length(weights)<2) { w0 <- NN } else { w1 <- apply(DD$w,1,biweight) w2 <- unlist(by(w1,pos,sum)) w0 <- rep(0,4*nrow(Tab)) w0[ipos] <- w2[ipos] } if (!missing(cells)) { idx <- unlist(apply(MyData$Y0,1,function(x) all(x==cells))) w0[!idx] <- 0 } if (!is.null(control$start)) { p0 <- control$start control$start <- NULL } else { p0 <- rep(0,plen) events <- Tab[,2]+Tab[,3]+2*Tab[,4] totals <- rowSums(Tab[,1:4,drop=FALSE]) if (is.null(X)) xx1 <- rep(1,length(totals)) else xx1 <- Tab[,midx1+4,drop=FALSE] b1 <- glm(cbind(events,totals)~-1+xx1,family=binomial("probit")) p0[midx1] <- coef(b1) if (!eqmarg) { if (is.null(X)) xx2 <- rep(1,length(totals)) else xx2 <- Tab[,midx2+4,drop=FALSE] b2 <- glm(cbind(events,totals)~-1+xx2,family=binomial("probit")) p0[midx2] <- coef(b2) } } U0 <- function(p) { MyData0 <- MyData MyData0$Y0[,] <- 0 val0 <- Ubiprobit(p,SigmaFun,eqmarg,nx,MyData0,indiv=TRUE) P <- exp(attr(val0,"logLik")) res <- log(1-P) dlogP <- val0 dres <- (-P/(1-P)) %x% rbind(rep(1,ncol(val0))) structure(res,score=dres) } U <- function(p,w0) { val <- Ubiprobit(p,SigmaFun,eqmarg,nx,MyData,indiv=TRUE) if (pair.ascertained) { ## log Pij - log (1-P00) ## U := Uij + dP00/(1-P00) = Uij+ DlogP00*P00/(1-P00) MyData0 <- MyData MyData0$Y0[,] <- 0 dlogP00 <- Ubiprobit(p,SigmaFun,eqmarg,nx,MyData0,indiv=TRUE) logP00 <- attr(dlogP00,"logLik") P00 <- exp(logP00) ll00 <- log(1-P00) dll00 <- -(P00/(1-P00)) %x% rbind(rep(1,ncol(dlogP00))) dll00 <- dll00 * dlogP00 val1 <- val attr(val,"logLik") <- attr(val,"logLik") - ll00 val <- val-dll00 } logl <- w0*as.vector(attributes(val)$logLik) score <- apply(val,2,function(x) w0*x) return(structure(score,logLik=logl)) } f0 <- function(p) -sum(attributes(U(p,w0))$logLik) ## f00 <- function(p) -sum(attributes(U(c(0,p),w0))$logLik) g0 <- function(p) -as.numeric(colSums(U(p,w0))) aa <- U(c(0.203,0),c(0,1,1,1)) exp(attr(aa,"logLik")) if (!is.null(p)) op <- list(par=p) else { suppressWarnings(op <- nlminb(p0,f0,gradient=g0,control=control)) } iI <- Inverse(numDeriv::jacobian(g0,op$par)) V <- iI UU <- U(op$par,w0) logLik <- sum(attributes(UU)$logLik) UU <- U(op$par,1) if (length(weights)>1) { UU <- apply(UU[pos,],2,function(x) w1*x) } else { UU <- UU[pos,] } meat <- crossprod(UU) if (length(weights>1)) V <- iI%*%meat%*%iI mycall <- match.call() cc <- cbind(op$par,sqrt(diag(V))) cc <- cbind(cc,cc[,1]/cc[,2],2*(pnorm(abs(cc[,1]/cc[,2]),lower.tail=FALSE))) colnames(cc) <- c("Estimate","Std.Err","Z","p-value") if (!eqmarg) rownames(cc) <- c(paste(namX,rep(c(1,2),each=length(namX)),sep="."), namZ) else rownames(cc) <- c(namX,namZ) rownames(V) <- colnames(V) <- rownames(cc) npar <- list(intercept=1, pred=blen-2+eqmarg) if (!eqmarg) npar <- lapply(npar,function(x) x*2) npar$var <- zlen N <- with(MyData, c(pairs=sum(NN))) val <- c(list(coef=cc, N=N, vcov=V, bread=iI, score=rbind(UU), logLik=logLik, opt=op, call=mycall, model=model, msg=msg, table=Tab, npar=npar, SigmaFun=SigmaFun),add) class(val) <- "biprobit" return(val) } ##' Bivariate Probit model ##' ##' @export ##' @aliases biprobit biprobit.vector biprobit.time ##' @param x formula (or vector) ##' @param data data.frame ##' @param id The name of the column in the dataset containing the cluster id-variable. ##' @param rho Formula specifying the regression model for the dependence parameter ##' @param num Optional name of order variable ##' @param strata Strata ##' @param eqmarg If TRUE same marginals are assumed (exchangeable) ##' @param indep Independence ##' @param weights Weights ##' @param biweight Function defining the bivariate weight in each cluster ##' @param samecens Same censoring ##' @param randomeffect If TRUE a random effect model is used (otherwise correlation parameter is estimated allowing for both negative and positive dependence) ##' @param vcov Type of standard errors to be calculated ##' @param pairs.only Include complete pairs only? ##' @param allmarg Should all marginal terms be included ##' @param control Control argument parsed on to the optimization routine. Starting values may be parsed as '\code{start}'. ##' @param messages Control amount of messages shown ##' @param constrain Vector of parameter constraints (NA where free). Use this to set an offset. ##' @param table Type of estimation procedure ##' @param p Parameter vector p in which to evaluate log-Likelihood and score function ##' @param ... Optional arguments ##' @examples ##' data(prt) ##' prt0 <- subset(prt,country=="Denmark") ##' a <- biprobit(cancer~1+zyg, ~1+zyg, data=prt0, id="id") ##' b <- biprobit(cancer~1+zyg, ~1+zyg, data=prt0, id="id",pairs.only=TRUE) ##' predict(b,newdata=lava::Expand(prt,zyg=c("MZ"))) ##' predict(b,newdata=lava::Expand(prt,zyg=c("MZ","DZ"))) ##' ##' \donttest{ ## Reduce Ex.Timings ##' library(lava) ##' m <- lvm(c(y1,y2)~x) ##' covariance(m,y1~y2) <- "r" ##' constrain(m,r~x+a+b) <- function(x) tanh(x[2]+x[3]*x[1]) ##' distribution(m,~x) <- uniform.lvm(a=-1,b=1) ##' ordinal(m) <- ~y1+y2 ##' d <- sim(m,1000,p=c(a=0,b=-1)); d <- d[order(d$x),] ##' dd <- fast.reshape(d) ##' ##' a <- biprobit(y~1+x,rho=~1+x,data=dd,id="id") ##' summary(a, mean.contrast=c(1,.5), cor.contrast=c(1,.5)) ##' with(predict(a,data.frame(x=seq(-1,1,by=.1))), plot(p00~x,type="l")) ##' ##' pp <- predict(a,data.frame(x=seq(-1,1,by=.1)),which=c(1)) ##' plot(pp[,1]~pp$x, type="l", xlab="x", ylab="Concordance", lwd=2, xaxs="i") ##' confband(pp$x,pp[,2],pp[,3],polygon=TRUE,lty=0,col=Col(1)) ##' ##' pp <- predict(a,data.frame(x=seq(-1,1,by=.1)),which=c(9)) ## rho ##' plot(pp[,1]~pp$x, type="l", xlab="x", ylab="Correlation", lwd=2, xaxs="i") ##' confband(pp$x,pp[,2],pp[,3],polygon=TRUE,lty=0,col=Col(1)) ##' with(pp, lines(x,tanh(-x),lwd=2,lty=2)) ##' ##' xp <- seq(-1,1,length.out=6); delta <- mean(diff(xp)) ##' a2 <- biprobit(y~1+x,rho=~1+I(cut(x,breaks=xp)),data=dd,id="id") ##' pp2 <- predict(a2,data.frame(x=xp[-1]-delta/2),which=c(9)) ## rho ##' confband(pp2$x,pp2[,2],pp2[,3],center=pp2[,1]) ##' ##' ##' } ##' ##' ## Time ##' \dontrun{ ##' a <- biprobit.time(cancer~1, rho=~1+zyg, id="id", data=prt, eqmarg=TRUE, ##' cens.formula=Surv(time,status==0)~1, ##' breaks=seq(75,100,by=3),fix.censweights=TRUE) ##' ##' a <- biprobit.time2(cancer~1+zyg, rho=~1+zyg, id="id", data=prt0, eqmarg=TRUE, ##' cens.formula=Surv(time,status==0)~zyg, ##' breaks=100) ##' ##' a1 <- biprobit.time2(cancer~1, rho=~1, id="id", data=subset(prt0,zyg=="MZ"), eqmarg=TRUE, ##' cens.formula=Surv(time,status==0)~1, ##' breaks=100,pairs.only=TRUE) ##' ##' a2 <- biprobit.time2(cancer~1, rho=~1, id="id", data=subset(prt0,zyg=="DZ"), eqmarg=TRUE, ##' cens.formula=Surv(time,status==0)~1, ##' breaks=100,pairs.only=TRUE) ##' ##' prt0$trunc <- prt0$time*runif(nrow(prt0))*rbinom(nrow(prt0),1,0.5) ##' a3 <- biprobit.time(cancer~1, rho=~1, id="id", data=subset(prt0,zyg=="DZ"), eqmarg=TRUE, ##' cens.formula=Surv(trunc,time,status==0)~1, ##' breaks=100,pairs.only=TRUE) # ##' ##' plot(a,which=3,ylim=c(0,0.1)) ##'} biprobit <- function(x, data, id, rho=~1, num=NULL, strata=NULL, eqmarg=TRUE, indep=FALSE, weights=NULL, biweight, samecens=TRUE, randomeffect=FALSE, vcov="robust", pairs.only=FALSE, allmarg=samecens&!is.null(weights), control=list(trace=0), messages=1, constrain=NULL, table=pairs.only, p=NULL, ...) { mycall <- match.call() if (missing(biweight)) { biweight <- mycall$biweight <- function(x) { u=min(x); ifelse(u==0,0,1/min(u)) } } formulaId <- unlist(Specials(x,"cluster")) if (is.null(formulaId)) { formulaId <- unlist(Specials(x,"id")) } ## formulaOffset <- unlist(Specials(x,"offset")) formulaStrata <- unlist(Specials(x,"strata")) formulaSt <- paste("~.-cluster(",formulaId,")", "-id(",formulaId,")", "-strata(",paste(formulaStrata,collapse="+"),")",sep="") formula <- update(x,formulaSt) if (!is.null(formulaId)) { id <- formulaId mycall$id <- id } if (!is.null(formulaStrata)) strata <- formulaStrata mycall$x <- formula if (!is.null(strata)) { dd <- split(data,interaction(data[,strata])) fit <- lapply(seq(length(dd)),function(i) { if (messages>0) message("Strata '",names(dd)[i],"'") mycall$data <- dd[[i]] eval(mycall) }) res <- list(model=fit) res$strata <- names(res$model) <- names(dd) class(res) <- c("twinlm.strata","biprobit") res$coef <- unlist(lapply(res$model,coef)) res$vcov <- blockdiag(lapply(res$model,vcov.biprobit)) res$N <- length(dd) res$idx <- seq(length(coef(res$model[[1]]))) rownames(res$vcov) <- colnames(res$vcov) <- names(res$coef) return(res) } if (missing(id)) { if (!is.null(weights)) { weights <- data[,weights] return(glm(formula,data=data,family=binomial(probit),weights=weights,...)) } return(glm(formula,data=data,family=binomial(probit),...)) } yx <- getoutcome(formula) if (pairs.only) { X <- Z <- NULL zf <- getoutcome(rho); if (length(attr(zf,"x"))>0) Z <- model.matrix(rho,data); if (table && NCOL(Z)<10 && length(unique(sample(Z,min(1000,length(Z)))))<10) { ## Not quantitative? if (!is.null(weights)) weights <- data[,weights] if (length(attr(yx,"x")>0)) X <- model.matrix(x,data); return(biprobit.vector(data[,yx],X=X,Z=Z,id=data[,id],weights,biweight=biweight,eqmarg=eqmarg,add=list(formula=formula,rho.formula=rho),control=control,p=p,...)) } } mycall <- match.call() DD <- procdatabiprobit(formula,data,id,num=num,weights=weights,pairs.only=pairs.only,rho,...) rnames1 <- DD$rnames1 nx <- length(rnames1) ## if (nx==0) stop("Zero design not allowed") midx1 <- seq(nx) midx2 <- midx1+nx midx <- seq(2*nx) blen <- ifelse(eqmarg,nx,2*nx) zlen <- ncol(DD$Z0) plen <- blen+zlen datanh <- function(r) 1/(1-r^2) dtanh <- function(z) 4*exp(2*z)/(exp(2*z)+1)^2 vartr <- tanh dvartr <- dtanh; varitr <- atanh trname <- "tanh"; itrname <- "atanh" Sigma1 <- diag(2) Sigma2 <- matrix(c(0,1,1,0),2,2) dS0 <- rbind(c(0,1,1,0)) varcompname <- "Tetrachoric correlation" msg <- NULL if (randomeffect) msg <- "Variance of latent residual term = 1 (standard probit link)" if (randomeffect) { dS0 <- rbind(rep(1,4)) vartr <- dvartr <- exp; inv <- log trname <- "exp"; itrname <- "log" Sigma2 <- 1 varcompname <- NULL } model <- list(tr=vartr,name=trname,inv=itrname,invname=itrname,deriv=dvartr,varcompname=varcompname,dS=dS0,eqmarg=eqmarg,randomeffect=randomeffect,blen=blen,zlen=zlen) MyData <- with(DD,ExMarg(Y0,XX0,W0,dS0,midx1,midx2,eqmarg=eqmarg,allmarg=allmarg,Z0,id=id)) if (samecens & !is.null(weights)) { MyData$W0 <- cbind(apply(MyData$W0,1,biweight)) if (!is.null(MyData$Y0_marg)) { MyData$W0_marg <- cbind(apply(MyData$W0_marg,1,biweight)) } } SigmaFun <- function(p,Z=MyData$Z0,cor=!randomeffect,...) { if (!cor) { r <- vartr(p[1]) Sigma <- matrix(c(1,r,r,1),2) if (indep) Sigma <- diag(2) attributes(Sigma)$dvartr <- dvartr return(Sigma) } val <- Z%*%p dr <- apply(Z,2,function(x) x*dvartr(val)) structure(list(rho=vartr(val),lp=val,drho=dr),dvartr=dvartr,vartr=vartr) } U <- function(p,indiv=FALSE) { gamma <- p[seq(zlen)+blen] ##if (bound) gamma <- min(gamma,20) Sigma <- SigmaFun(gamma) if (randomeffect) { lambda <- eigen(Sigma)$values if (any(lambda<1e-12 | lambda>1e9)) stop("Variance matrix out of bounds") } Mu_marg <- NULL if (eqmarg) { B <- cbind(p[midx1]) Mu <- with(MyData, cbind(XX0[,midx1,drop=FALSE]%*%B,XX0[,midx2,drop=FALSE]%*%B)) if (!is.null(MyData$Y0_marg)) Mu_marg <- with(MyData, XX0_marg%*%B) } else { B1 <- cbind(p[midx1]) B2 <- cbind(p[midx2]) Mu <- with(MyData, cbind(XX0[,midx1,drop=FALSE]%*%B1,XX0[,midx2,drop=FALSE]%*%B2)) if (!is.null(MyData$Y0_marg)) Mu_marg <- with(MyData, rbind(X0_marg1%*%B1,X0_marg2%*%B2)) } if (randomeffect) { U <- with(MyData, .Call("biprobit2", Mu,XX0, Sigma,dS0*attributes(Sigma)$dvartr(p[plen]),Y0,W0, !is.null(W0),TRUE,eqmarg,FALSE, PACKAGE="mets")) } else { U <- with(MyData, .Call("biprobit2", Mu,XX0, Sigma$rho,Sigma$drho, Y0,W0, !is.null(W0),TRUE,eqmarg,TRUE, PACKAGE="mets")) } if (!is.null(MyData$Y0_marg)) { if (randomeffect) { U_marg <- with(MyData, .Call("uniprobit", Mu_marg,XX0_marg, Sigma[1,1],dS0_marg*attributes(Sigma)$dvartr(p[plen]),Y0_marg, W0_marg,!is.null(W0_marg),TRUE, PACKAGE="mets")) } else { U_marg0 <- matrix(0,length(MyData$Y0_marg),ncol=plen) U_marg <- with(MyData, .Call("uniprobit", Mu_marg,XX0_marg, 1,matrix(ncol=0,nrow=0),Y0_marg, W0_marg,!is.null(W0_marg),TRUE, PACKAGE="mets")) U_marg0[,seq(blen)] <- U_marg[[1]] U_marg[[1]] <- U_marg0 } U$score <- rbind(U$score,U_marg$score) U$loglik <- c(U$loglik,U_marg$loglik) } if (indiv) { val <- U$score if (!is.null(MyData$idmarg) && !pairs.only) { val <- with(MyData, cluster.index(c(id,idmarg),mat=U$score)) } ## val <- U$score[MyData$id,,drop=FALSE] ## N <- length(MyData$id) ## idxs <- seq_len(N) ## for (i in seq_len(N)) { ## idx <- which((MyData$idmarg)==(MyData$id[i]))+N ## idxs <- c(idxs,idx) ## val[i,] <- val[i,]+colSums(U$score[idx,,drop=FALSE]) ## } ## val <- rbind(val, U$score[-idxs,,drop=FALSE]) attributes(val)$logLik <- U$loglik return(val) } val <- colSums(U$score) attributes(val)$logLik <- sum(U$loglik) return(val) } p0 <- rep(0,plen) if (!is.null(control$start)) { p0 <- control$start control$start <- NULL } else { g <- suppressWarnings(glm(formula,data,family=binomial(probit))) p0[midx1] <- coef(g) if (!eqmarg) p0[midx2] <- coef(g) } f <- function(p) crossprod(U(p))[1] f0 <- function(p) -sum(attributes(U(p))$logLik) g0 <- function(p) -as.numeric(U(p)) h0 <- function(p) crossprod(U(p,indiv=TRUE)) if (!is.null(constrain)) { if (length(constrain)!=length(p0)) stop("Wrong length of constraints (should be NA at positions not to be fixed)") fix <- which(!is.na(constrain)) free <- which(is.na(constrain)) p0 <- p0[free] U0 <- U U <- function(p,indiv=FALSE) { p1 <- constrain p1[free] <- p res <- U0(p1,indiv) if (is.matrix(res)) { return(structure(res[,free,drop=FALSE],logLik=attributes(res)$logLik)) } return(structure(res[free],logLik=attributes(res)$logLik)) } } if (is.null(control$method)) { ## control$method <- ifelse(samecens & !is.null(weights), "bhhh","quasi") control$method <- "quasi" } control$method <- tolower(control$method) if (is.null(p)) { if (control$method=="score") { control$method <- NULL op <- nlminb(p0,f,control=control,...) } else if (control$method=="quasi") { control$method <- NULL suppressWarnings(op <- nlminb(p0,f0,gradient=g0,control=control)) ## } ## else if (control$method=="bhhh") { ## controlnr <- list(stabil=FALSE, ## gamma=0.1, ## gamma2=1, ## ngamma=5, ## iter.max=200, ## epsilon=1e-12, ## tol=1e-9, ## trace=1, ## stabil=FALSE) ## controlnr[names(control)] <- control ## op <- lava:::NR(start=p0,NULL,g0, h0,control=controlnr) } else { control$method <- NULL op <- nlminb(p0,f0,control=control) } } else op <- list(par=p) UU <- U(op$par,indiv=TRUE) idx <- seq(nrow(UU)) if (!is.null(MyData$idmarg)) idx <- with(MyData,cluster.index(c(id,idmarg)))$firstclustid+1 idvar <- with(MyData, c(id0,idmarg0))[idx] J <- crossprod(UU) ## iJ <- Inverse(J) iI <- Inverse(-numDeriv::jacobian(U,op$par)) V <- switch(vcov, robust=, sandwich=iI%*%J%*%iI,##iJ%*%I%*%iJ, score=, outer=Inverse(J), hessian=iI ) cc <- cbind(op$par,sqrt(diag(V))) cc <- cbind(cc,cc[,1]/cc[,2],2*(pnorm(abs(cc[,1]/cc[,2]),lower.tail=FALSE))) if (!is.null(constrain)) { cc0 <- matrix(NA,nrow=length(constrain),ncol=4) cc0[free,] <- cc cc0[fix,1] <- constrain[fix] cc <- cc0 V0 <- matrix(0,nrow=length(constrain),ncol=length(constrain)) V0[free,free] <- V V <- V0 } colnames(cc) <- c("Estimate","Std.Err","Z","p-value") p1 <- "("; p2 <- ")" if (itrname=="log") rhonam <- "U" else { rhonam <- DD$znames p1 <- p2 <- ""; itrname <- "r:" } if (!eqmarg) rownames(cc) <- c(paste(rnames1,rep(c(1,2),each=length(rnames1)),sep="."), paste(itrname,p1,rhonam,p2,sep="")) else rownames(cc) <- c(rnames1,paste(itrname,p1,rhonam,p2,sep="")) rownames(V) <- colnames(V) <- rownames(cc) npar <- list(intercept=attributes(terms(formula))$intercept, pred=nrow(attributes(terms(formula))$factor)-1) if (!eqmarg) npar <- lapply(npar,function(x) x*2) npar$var <- 1##nrow(cc)-sum(unlist(npar)) N <- with(MyData, c(n=nrow(XX0)*2+length(margidx), pairs=nrow(XX0))) val <- list(coef=cc,N=N,vcov=V,bread=iI,score=UU,logLik=attributes(UU)$logLik,opt=op, call=mycall, model=model,msg=msg,npar=npar, SigmaFun=SigmaFun,rho.formula=rho,formula=formula,constrain=constrain, id=idvar) class(val) <- "biprobit" return(val) } procdatabiprobit <- function(formula,data,id,num=NULL,weights=NULL,pairs.only=FALSE,rho=~1,...) { data <- data[order(data[,id]),] idtab <- table(data[,id]) if (pairs.only) { data <- data[which(as.character(data[,id])%in%names(idtab)[idtab==2]),] idtab <- table(data[,id]) } ff <- paste(as.character(formula)[3],"+", paste(c(id,num),collapse="+")) yvar <- paste(deparse(formula[[2]]),collapse="") if (!is.null(weights)) ff <- paste(weights,"+",ff) ff <- paste("~",yvar,"+",ff) if (is.logical(data[,yvar])) data[,yvar] <- data[,yvar]*1 if (is.factor(data[,yvar])) data[,yvar] <- as.numeric(data[,yvar])-1 formula0 <- as.formula(ff) opt <- options(na.action="na.pass") Data <- model.matrix(formula0,data) options(opt) rnames1 <- setdiff(colnames(Data),c(yvar,num,id,weights)) X0 <- as.matrix(Data[,rnames1]) ex <- 1+!is.null(num) rho <- update(rho,paste("~.+", paste(c(id,num),collapse="+"))) Z0 <- model.matrix(rho,data); znames <- setdiff(colnames(Z0),c(id,num)) znames1 <- paste(znames,1,sep="") Z0 <- as.matrix(subset(fast.reshape(Z0,id=id),select=znames1)) colnames(Z0) <- znames1 Wide <- fast.reshape(as.data.frame(Data),id=id,num=num,sep=".",labelnum=TRUE) W0 <- NULL yidx <- paste(yvar,1:2,sep=".") rmidx <- c(id,yidx) if (!is.null(weights)) { W <- cbind(data[,weights]) widx <- paste(weights,1:2,sep=".") W0 <- as.matrix(Wide[,widx]) rmidx <- c(rmidx,widx) } Y0 <- as.matrix(Wide[,yidx]) XX0 <- as.matrix(Wide[,setdiff(colnames(Wide),rmidx)]) XX0[is.na(XX0)] <- 0 list(Y0=Y0,XX0=XX0,W0=W0,Z0=Z0,znames=znames,rnames1=rnames1,id=Wide[,id]) } Ubiprobit <- function(p,Rho,eqmarg,nx,MyData,indiv=FALSE) { midx1 <- seq(nx) midx2 <- midx1+nx midx <- seq(2*nx) blen <- ifelse(eqmarg,nx,2*nx) zlen <- length(p)-blen plen <- blen+zlen gamma <- p[blen+seq(zlen)] Sigma <- Rho(gamma) ## lambda <- eigen(Sigma)$values ## if (any(lambda<1e-12 | lambda>1e9)) stop("Variance matrix out of bounds") Mu_marg <- NULL if (eqmarg) { B <- cbind(p[midx1]) Mu <- with(MyData, cbind(XX0[,midx1,drop=FALSE]%*%B,XX0[,midx2,drop=FALSE]%*%B)) ## Mu <- with(MyData, matrix(X0%*%B,ncol=2,byrow=TRUE)) if (!is.null(MyData$Y0_marg)) Mu_marg <- with(MyData, XX0_marg%*%B) } else { B1 <- cbind(p[midx1]) B2 <- cbind(p[midx2]) Mu <- with(MyData, cbind(XX0[,midx1,drop=FALSE]%*%B1,XX0[,midx2,drop=FALSE]%*%B2)) if (!is.null(MyData$Y0_marg)) Mu_marg <- with(MyData, rbind(X0_marg1%*%B1,X0_marg2%*%B2)) } U <- with(MyData, .Call("biprobit2", Mu,XX0, Sigma$rho,Sigma$drho,Y0,W0, !is.null(W0),TRUE,eqmarg,TRUE, PACKAGE="mets")) if (!is.null(MyData$Y0_marg)) { U_marg0 <- matrix(0,length(MyData$Y0_marg),ncol=plen) U_marg <- with(MyData, .Call("uniprobit", Mu_marg,XX0_marg, 1,matrix(ncol=0,nrow=0),Y0_marg, W0_marg,!is.null(W0_marg),TRUE, PACKAGE="mets")) U_marg0[,seq(blen)] <- U_marg[[1]] U_marg[[1]] <- U_marg0 U$score <- rbind(U$score,U_marg$score) U$loglik <- c(U$loglik,U_marg$loglik) } if (indiv) { val <- with(MyData, cluster.index(c(id,idmarg),mat=U$score)) attributes(val)$logLik <- U$loglik return(val) } val <- colSums(U$score) attributes(val)$logLik <- sum(U$loglik) return(val) } mets/R/fastapprox.R0000644000176200001440000000306013623061405013734 0ustar liggesusers##' Fast approximation ##' ##' Fast approximation ##' @param time Original ordered time points ##' @param new.time New time points ##' @param equal If TRUE a list is returned with additional element ##' @param type Type of matching, nearest index, nearest greater than ##' or equal (right), number of elements smaller than y otherwise ##' the closest value above new.time is returned. ##' @param sorted Set to true if new.time is already sorted ##' @param ... Optional additional arguments ##' @author Klaus K. Holst ##' @examples ##' id <- c(1,1,2,2,7,7,10,10) ##' fast.approx(unique(id),id) ##' ##' t <- 0:6 ##' n <- c(-1,0,0.1,0.9,1,1.1,1.2,6,6.5) ##' fast.approx(t,n,type="left") ##' @export fast.approx <- function(time,new.time,equal=FALSE,type=c("nearest","right","left"),sorted=FALSE,...) { if (!sorted) { ord <- order(new.time,decreasing=FALSE) new.time <- new.time[ord] } A <- NULL if (NCOL(time)>1) { A <- time time <- A[,1,drop=TRUE] } if (is.unsorted(time)) warnings("'time' will be sorted") type <- agrep(type[1],c("nearest","right","left"))-1 arglist <- list("FastApprox", time=sort(time), newtime=new.time, equal=equal, type=type, PACKAGE="mets") res <- do.call(".Call",arglist) if (!sorted) { oord <- order(ord) if (!equal) return(res[oord]) res <- lapply(res,function(x) x[oord]) } if (!is.null(A)) { A[res,,drop=FALSE] } return(res) } mets/R/lifetable.R0000644000176200001440000004503113623061405013500 0ustar liggesusers##' @export `lifetable` <- function(x,...) UseMethod("lifetable") ##' Create simple life table ##' ##' @title Life table ##' @param x time formula (Surv) or matrix/data.frame with columns time,status or entry,exit,status ##' @param strata strata ##' @param data data.frame ##' @param breaks time intervals ##' @param weights weights variable ##' @param confint if TRUE 95\% confidence limits are calculated ##' @param ... additional arguments to lower level functions ##' @author Klaus K. Holst ##' @aliases lifetable lifetable.matrix lifetable.formula ##' @usage ##' \method{lifetable}{matrix}(x, strata = list(), breaks = c(), ##' weights=NULL, confint = FALSE, ...) ##' ##' \method{lifetable}{formula}(x, data=parent.frame(), breaks = c(), ##' weights=NULL, confint = FALSE, ...) ##' @examples ##' library(timereg) ##' data(TRACE) ##' ##' d <- with(TRACE,lifetable(Surv(time,status==9)~sex+vf,breaks=c(0,0.2,0.5,8.5))) ##' summary(glm(events ~ offset(log(atrisk))+factor(int.end)*vf + sex*vf, ##' data=d,poisson)) ##' @export lifetable.matrix <- function(x,strata=list(),breaks=c(),weights=NULL,confint=FALSE,...) { if (ncol(x)==3) { status <- x[,3] entry <- x[,1] time <- x[,2] } else { status <- x[,2] time <- x[,1] entry <- rep(0,length(time)) } LifeTable(time,status,entry,strata=strata,breaks=breaks,weights=weights,confint,...) } ##' @export lifetable.formula <- function(x,data=parent.frame(),breaks=c(),weights=NULL,confint=FALSE,...) { mf <- match.call(expand.dots = FALSE) m <- match(c("x", "data", "weights"), names(mf), 0L) mf <- mf[c(1L, m)] mf$drop.unused.levels <- TRUE mf[[1L]] <- quote(stats::model.frame) names(mf)[which(names(mf)=="x")] <- "formula" mf <- eval(mf, parent.frame()) weights <- as.vector(model.weights(mf)) ##mf <- model.frame(x,data) Y <- model.extract(mf, "response") Terms <- terms(x, data = data) if (!is.Surv(Y)) stop("Expected a 'Surv'-object") if (ncol(Y)==2) { exit <- Y[,1] entry <- NULL ## rep(0,nrow(Y)) status <- Y[,2] } else { entry <- Y[,1] exit <- Y[,2] status <- Y[,3] } strata <- list() X <- model.matrix(Terms, data) if (!is.null(intpos <- attributes(Terms)$intercept)) X <- X[,-intpos,drop=FALSE] if (ncol(X)>0) { strata <- as.list(model.frame(Terms,data)[,-1,drop=FALSE]) } LifeTable(exit,status,entry, strata=strata,breaks=breaks,weights=weights,confint=confint,...) } ## lifetable.data.table <- function(x,entry,exit,status,strata,breaks,...) { ## requireNamespace("data.table") ## breaks <- sort(unique(breaks)) ## nbreaks <- length(breaks) ## ## prs <- parse(text=paste0("pmin(x,",exit,")-pmax(x-1,",entry,")")) ## ## dt[,eval(prs),by=strata] ## system.time(dur1 <- x[, ## lapply(breaks[-1],function(x) ## eval(parse(text=paste0("pmin(x,",exit,")-pmax(x-1,",entry,")"))) ## ),by=strata]) ## dur1[dur1<0] <- NA ## system.time(endur1 <- x[, ## lapply(breaks[-nbreaks],function(x) ## eval(parse(text=paste0("x+1-pmax(x,",entry,")"))) ## ),by=strata]) ## enter <- dur1[,lapply(.SD,function(x) sum(!is.na(x))),by=strata] ## atrisk <- dur1[,lapply(.SD,function(x) sum(x,na.rm=TRUE)),by=strata] ## vidx <- seq(length(strata)+1,ncol(atrisk)) ## suppressWarnings(names(atrisk)[vidx] <- paste0("_R",seq_along(vidx))) ## system.time(eventcens <- x[, ## lapply(breaks[-1],function(x) ## eval(parse(text=paste0("((pmin(x,",exit,")-pmax(x-1,",entry,"))<(x-pmax(x-1,",entry,")))*(1+",status,")"))) ## ),by=strata]) ## lost <- eventcens[,lapply(.SD,function(x) sum(x==1,na.rm=TRUE)),by=strata] ## events <- eventcens[,lapply(.SD,function(x) sum(x==2,na.rm=TRUE)),by=strata] ## suppressWarnings(names(events)[vidx] <- paste0("_E",seq_along(vidx))) ## res <- fast.reshape(cbind(events,atrisk[,vidx,with=FALSE])) ## return(res) ## res <- subset(data.frame(enter=enter, ## atrisk=atrisk, ## lost=lost, ## events=events, ## ## int.start=c(-Inf,breaks), ## ## int.end=c(breaks,Inf), ## int.start=breaks[-length(breaks)], ## int.end=breaks[-1], ## surv=0, ## rate=events/atrisk)) ## } LifeTable <- function(time,status,entry=NULL,weights=NULL,strata=list(),breaks=c(),confint=FALSE,interval=TRUE,mesg=FALSE) { if (is.null(entry)) entry <- rep(0,NROW(time)) if (mesg) message(dim(time)) if ((is.matrix(time) || is.data.frame(time)) && ncol(time)>1) { if (ncol(time)>=3L) { if (ncol(time)==4L) weights <- time[,4] status <- time[,3] entry <- time[,1] time <- time[,2] } else { status <- time[,2] time <- time[,1] entry <- rep(0,length(time)) } } if (mesg) message(dim(time)) if ((is.matrix(time) || is.data.frame(time)) && ncol(time)>1) { if (ncol(time)==3) { status <- time[,3] entry <- time[,1] time <- time[,2] } else { status <- time[,2] time <- time[,1] entry <- rep(0,length(time)) } } if (length(strata)>0) { a <- by(cbind(entry,time,status,weights), strata, FUN=LifeTable, breaks=breaks, confint=confint) cl <- lapply(strata,class) nulls <- which(unlist(lapply(a,is.null))) nonnulls <- setdiff(seq_along(a),nulls) nn <- do.call("expand.grid",attributes(a)$dimnames) if (length(nulls)>0) nn <- nn[-nulls,,drop=FALSE] nam <- nn[rep(seq(NROW(nn)),each=NROW(a[[nonnulls[1]]])),,drop=FALSE] xx <- list() for (i in seq(ncol(nam))) { if (cl[i]%in%c("numeric","integer")) xx <- c(xx,list(as.numeric(as.character(nam[,i])))) else xx <- c(xx, list(do.call(paste("as.",as.character(cl[i]),sep=""),list(nam[,i])))) } xx <- as.data.frame(xx); colnames(xx) <- colnames(nam) res <- Reduce("rbind",a) res <- cbind(res,xx) return(res) } if (length(breaks)==0) breaks <- c(0,max(time,na.rm=TRUE)) if (length(breaks)==1) breaks <- c(0,breaks) breaks <- sort(unique(breaks)) ## en <- matrix(unlist(lapply(c(-Inf, breaks),function(x) pmax(x,entry))), ## ncol=length(breaks)+1) ## ex <- matrix(unlist(lapply(c(breaks, Inf),function(x) pmin(x,time))), ## ncol=length(breaks)+1) en <- matrix(unlist(lapply(breaks[-length(breaks)],function(x) pmax(x,entry))), ncol=length(breaks)-1) ex <- matrix(unlist(lapply(breaks[-1],function(x) pmin(x,time))), ncol=length(breaks)-1) dur <- ex-en dur[dur<=0] <- NA eventcens <- dur; eventcens[!is.na(dur)] <- 0 lastobs <- apply(eventcens,1,function(x) tail(which(!is.na(x)),1)) eventcens[cbind(seq(nrow(eventcens)),lastobs)] <- status+1 if (!is.null(weights)) { W <- weights %x% rbind(rep(1,ncol(dur))) W[is.na(dur)] <- NA enter <- colSums(W,na.rm=TRUE) atrisk <- colSums(dur*W,na.rm=TRUE) Sum <- function(x) { res <- sum(x,na.rm=TRUE); ifelse(length(res)>0L, res, 0L) } lost <- apply(eventcens, 2, function(x) res <- Sum(weights[which(x==1)])) events <- apply(eventcens, 2, function(x) res <- Sum(weights[which(x==2)])) } else { enter <- colSums(!is.na(dur)) atrisk <- colSums(dur,na.rm=TRUE) lost <- colSums(eventcens==1,na.rm=TRUE) events <- colSums(eventcens==2,na.rm=TRUE) } rate <- events/atrisk; rate[is.nan(rate)] <- 0 res <- subset(data.frame(enter=enter, atrisk=atrisk, lost=lost, events=events, ## int.start=c(-Inf,breaks), ## int.end=c(breaks,Inf), int.start=breaks[-length(breaks)], int.end=breaks[-1], rate=rate)) if (interval) res$interval <- factor(paste0("[",res$int.start,";",res$int.end,")")) cumsum.na <- function(x,...) { x[is.na(x)] <- 0; cumsum(x) } if (length(strata)==0) res$surv <- with(res, exp(-cumsum.na(rate*(int.end-int.start)))) if (confint) { ff <- events ~ offset(log(atrisk)) if (length(breaks)>2) ff <- update(ff,.~.+factor(int.end)-1) g <- glm(ff,data=res,poisson) suppressMessages(ci <- rbind(exp(stats::confint(g)))) res[,"2.5%"] <- ci[,1] res[,"97.5%"] <- ci[,2] } res } eh <- function(formula,intervals,family=poisson(log),...) { if (missing(intervals)) stop("Please supply list of time-intervals") g <- glm(formula,family=family,...) structure(g,class=c("glm","eh"),intervals=intervals) } ##' Summary for survival analyses via the 'lifetable' function ##' ##' Summary for survival analyses via the 'lifetable' function ##' @title Extract survival estimates from lifetable analysis ##' @param object glm object (poisson regression) ##' @param ... Contrast arguments ##' @param timevar Name of time variable ##' @param time Time points (optional) ##' @param int.len Time interval length (optional) ##' @param confint If TRUE confidence limits are supplied ##' @param level Level of confidence limits ##' @param individual Individual predictions ##' @param length.out Length of time vector ##' @aliases eventpois pcif ##' @export ##' @author Klaus K. Holst eventpois <- function(object,...,timevar,time,int.len,confint=FALSE,level=0.95,individual=FALSE,length.out=25) { if (missing(timevar)) { timevar <- names(attributes(object)$intervals)[1] times <- attributes(object)$intervals int.len <- diff(times) } nn <- names(coef(object)) if (is.null(timevar)) { idx <- unlist(sapply(c("\\(Intercept\\)","bs\\(","ns\\("),function(x) grep(x,nn))) keep <- setdiff(seq_along(nn),idx) cc <- estimate(object,exp,keep=keep,labels=nn[keep])$coefmat colnames(cc)[1] <- "RR" cc[,5] <- coef(summary(object))[keep,4] return(cc) } timevar_re0 <- gsub("\\$|\\^","",glob2rx(timevar)) timevar_re <- paste0(timevar_re0,"[0-9]+\\.*[0-9]*") idx <- regexpr(timevar_re,nn) dots <- list(...) if (all(idx<0)) { timevar_re0 <- gsub("\\$|\\^","",glob2rx(paste0("factor(",timevar,")"))) timevar_re <- paste0(timevar_re0,"[0-9]+\\.*[0-9]*") idx <- regexpr(timevar_re,nn) } tvar <- unique(regmatches(nn,idx)) if (missing(time)) { time <- sort(unique(as.numeric(gsub(timevar_re0,"",tvar)))) if (length(time)==0) { i0 <- seq(nrow(object$data)) ## browser() ## if ("rate"%in%colnames(object$data)) { ## ii0 <- which(object$data[,"rate"]>0) ## i0 <- intersect(i0,ii0) ## } ## for (i in seq_along(dots)) { ## i0 <- intersect(i0,which(object$data[,names(dots)[i]]==dots[[i]])) ## } rg <- range(object$data[i0,timevar],na.rm=TRUE) time <- seq(rg[1],rg[2],length.out=length.out) } else { ##time <- seq(1,rg[2]) } } if (missing(int.len)) { int.len <- diff(c(0,time)) } else if (int.len==1) int.len <- rep(int.len,nrow(res)) tt <- terms(object) offsetvar <- NULL if (attr(tt,"offset")) { offsetvar <- all.vars(tt)[attr(tt,"offset")] dots[[offsetvar]] <- 1 } responsevar <- getoutcome(tt) vv <- setdiff(all.vars(formula(tt)),c(offsetvar,responsevar)) dots0 <- dots dots[[timevar]] <- time dotnames <- c() if (individual) { newdata <- as.data.frame(dots) for (v in vv) { if (v%ni%names(dots)) newdata[,v] <- object$data[1,v] else dotnames <- c(dotnames,v) } } else { for (v in vv) { if (v%ni%names(dots)) { dots[[v]] <- object$data[1,v] } else { dotnames <- c(dotnames,v) } } args <- c(list(`_data`=model.frame(object)),dots) newdata <- do.call(Expand, args) newdata <- dsort(newdata,c(setdiff(dotnames,timevar),timevar)) } Terms <- delete.response(tt) m <- model.frame(Terms, newdata, xlev = object$xlevels) X <- model.matrix(Terms, m, contrasts.arg = object$contrasts) ## NA-robust matrix product beta0 <- coef(object); beta0[is.na(beta0)] <- -.Machine$double.xmax V <- vcov(object) V0 <- structure(matrix(0,length(beta0),length(beta0)),dimnames=list(names(beta0),names(beta0))) idx <- which(rownames(V0)%in%rownames(V)) V0[idx,idx] <- V coefs <- X%*%beta0 res <- cbind(time-int.len,int.len,exp(coefs)) colnames(res) <- c("time","int.len","rate") if (nrow(coefs)<=length(time)) { if (!confint) { res <- cbind(res,cumsum(res[,3]*int.len)) res <- cbind(res,exp(-res[,4])) } else { S0 <- X%*%V0%*%t(X) system.time(e0 <- estimate(NULL,coef=coefs,vcov=S0,function(x) cumsum(exp(x)*int.len))) ## Cumulative hazard system.time(e1 <- estimate(e0, function(x) exp(-x),level=level)) ## Survival res <- cbind(res,e0$coefmat[,1],e1$coefmat[,c(1,3:4)]) } colnames(res)[4:5] <- c("chaz","surv") } if (!is.null(offsetvar)) newdata[,offsetvar] <- NULL times <- list() if (!individual) { aa <- unique(newdata[,setdiff(dotnames,c(timevar,offsetvar)),drop=FALSE]) vv <- colnames(aa) for (i in seq(nrow(aa))) { idx <- seq(nrow(object$data)) for (j in seq_along(vv)) { val <- aa[i,j] if (is.factor(val)) val <- as.character(val) idx <- intersect(idx,which(object$data[,vv[j]]==val)) } times <- c(times, list(sort(unique(object$data[idx,timevar])))) } } structure(as.data.frame(cbind(res,newdata)), args=dots0, variables=aa, times=times, individual=individual, class=c("eventpois","data.frame") ) } ##' @export plot.eventpois <- function(x,var,confint=TRUE,cont=TRUE,length.out=200,type="surv", line.type="l",lty=c(1:8),col=1,lwd=1,add=FALSE, use.time=TRUE, legend, xlab="Time",ylab="Survival probability",xlim,ylim,...) { type <- agrep(type,c("clogclog","hazard","survival")) if (!add) { if (missing(xlim)) xlim <- c(0,max(x[,1]+x[,2])) if (missing(ylim)) { ylim <- switch(type, '1'=c(-30,max(log(sum(x[,2]*x[,3])))), '2'=c(0,max(x[,3])), c(0,1)) } plot(0,type="n",xlab=xlab,ylab=ylab,xlim=xlim,ylim=ylim,...) } ##args <- attr(x,"args") ##aa <- expand.grid(args) aa <- attr(x,"variables") vv <- colnames(aa) if (attr(x,"individual")) aa <- aa[1,,drop=FALSE] if (missing(legend)) legend <- nrow(aa)>1 if (length(lty)0)) e0 <- x[idx,,drop=FALSE] dt <- tail(e0,1) time0 <- c(e0[,1],dt[,1]+dt[,2]) if (use.time) { ##browser() time0 <- attr(x,"time")[[i]]-1 e0 <- e0[na.omit(match(time0,e0[,"time"])),,drop=FALSE] time0 <- time0[match(e0[,"time"],time0)] dt <- tail(e0,1) time0 <- c(time0,dt[,1]+dt[,2]) } chaz0 <- cumsum(e0[,3]*e0[,2]) tt <- seq(min(time0),max(time0),length.out=length.out) ff <- approxfun(time0,c(0,chaz0),method="linear") if (type==3) { lines(tt,exp(-ff(tt)),lty=lty[i],col=col[i],lwd=lwd[i],...) } else if (type==1) { lines(tt,log(ff(tt)),lty=lty[i],col=col[i],lwd=lwd[i],...) } else { lines(time0,e0[,3],lty=lty[i],col=col[i],lwd=lwd[i],...) } } if (legend) { lab <- apply(aa,1,function(x) paste(x,collapse=",")) graphics::legend("bottomleft",lab,lty=lty,col=col,lwd=lwd,bg="white") } return(aa) ## if (surv) lines(x[,c(1,5)],lty=lty[1],type=type,...) ## else lines(x[,c(1,3)],lty=lty[1],type=type,...) ## if (ncol(x)>4 && confint && surv) { ## lines(x[,c(1,6)],lty=lty[2],type=type,...) ## lines(x[,c(1,7)],lty=lty[2],type=type,...) ## } } ##' @export pcif <- function(models,timevar,survival,...,delta=0.01,stop.time,trunc=TRUE) { if (!is.list(models)) models <- list(models) ee <- lapply(models,eventpois,timevar=timevar,...) t0 <- c(0,ee[[1]][,timevar]) int.len <- diff(t0) if (!missing(survival)) { G <- c(1,eventpois(survival,...)$surv) } else { chaz <- c(0,Reduce("+",lapply(ee,function(x) x$chaz))) G <- exp(-chaz) } rates <- lapply(ee,function(x) x$rate) if (missing(stop.time)) stop.time <- max(ee[[1]][,1]) tt <- seq(0,stop.time,by=delta) GG <- approx(x=t0,y=G,xout=tt,method="linear") rr <- lapply(rates,function(rate) approx(x=t0,y=c(rate,0),xout=tt,method="constant",f=0)) FF <- lapply(rr,function(x) { cif0 <- c(0,cumsum(x$y*GG$y*delta)) cif0 <- cif0[-length(cif0)] }) S <- Reduce("+",FF) idx <- which(S>1) if (trunc & length(idx)>0) { for (i in seq_along(FF)) { FF[[i]][idx] <- FF[[i]][idx]/S[idx] } } FF0 <- Reduce(cbind,FF); colnames(FF0) <- paste0("F",seq(ncol(FF0))) as.data.frame(cbind(time=tt,FF0,G=GG$y)) } mets/R/onload.R0000644000176200001440000000072413623061405013025 0ustar liggesusers'.onAttach' <- function(libname, pkgname="mets") { desc <- utils::packageDescription(pkgname) ## packageStartupMessage("Loading '", desc$Package, "' package...\n", ## "\tVersion: ", desc$Version, "\n", ## "\tOverview: help(package=", desc$Package, ")"); packageStartupMessage(desc$Package, " version ",desc$Version); } .onUnload <- function (libpath) { library.dynam.unload("mets", libpath) } mets/R/methodstwinlm.R0000644000176200001440000003030313623061405014443 0ustar liggesusers###{{{ print.twinlm ##' @export print.twinlm <- function(x,...) { print(summary(x,...)) invisible(x) } ###}}} print.twinlm ###{{{ summary.twinlm summarygroup.twinlm <- function(object,...) { mz <- grep("MZ",names(object$model)) cc <- lapply(mz,function(i) coef(object$model[[i]],label=TRUE)) ii <- lapply(cc, function(x) sapply(x, function(i) lava::parpos(object$estimate$model,i))) c0 <- coef(object$estimate) c2 <- coef(object$estimate,level=2) pnam <- names(c0) coefs <- c() acde <- c() nn <- c() lambdas <- c("~a","~c","~d","~e") for (i in seq(length(mz))) { res <- coef(object$estimate,level=1)[ii[[i]],,drop=FALSE] pp <- sapply(lambdas,function(x) ii[[i]][grep(x,rownames(res),fixed=TRUE)]) nam <- c("A","C","D","E")[which(unlist(lapply(pp,function(x) length(x)>0)))] pp <- unlist(pp); names(pp) <- nam acde <- c(acde,list(acde.twinlm(object,pp))) nn0 <- cc[[i]] if (nn0[1]=="mu") nn0[1] <- "(Intercept)" for (k in c("a","c","d","e")) nn0 <- gsub("lambda["%++%k%++%"]","SD("%++%toupper(k)%++%"):",nn0,fixed=TRUE) nam <- rownames(res) idx <- unlist(lapply(c("Intercept","SD(","z(A):","z(D):"),function(x) grep(x,nn0,fixed=TRUE))) nam.keep.idx <- setdiff(seq(length(nam)),idx) nn0[nam.keep.idx] <- unlist(lapply(strsplit(nam[nam.keep.idx],"~"), function(x) gsub(".2|.1","",x[2]))) rownames(res) <- nn0 coefs <- c(coefs,list(res)) }; names(coefs) <- names(object$model)[mz] vcov <- vcov(object$estimate) suppressWarnings(kinship <- constraints(object$estimate)[,c(1,5,6),drop=FALSE]) fit <- c(logLik=logLik(object),AIC=AIC(object),BIC=BIC(object)) structure(list(coef=c0,coefmat=coefs,vcov=vcov,acde=acde,kinship=kinship,fit=fit),class="summary.twinlm.group") } ##' @export print.summary.twinlm.group <- function(x,...) { for (i in seq(length(x$coefmat))) { cat(names(x$coefmat)[i],"\n") printCoefmat(x$coefmat[[i]],...) print(x$acde[[i]]) cat("\n") } cat("\n") print(x$kinship) cat("\n") print(x$fit) invisible(x) } ##' @export summary.twinlm <- function(object,transform=FALSE,...) { if (!is.null(object$group) && !object$group.equal) { return(summarygroup.twinlm(object,...)) } e <- object$estimate zygtab <- object$zygtab ## zygtab <- with(object, table(data[,zyg])) ## names(zygtab) <- paste(names(zygtab),"pairs",sep="-") theta <- pars(e) theta.sd <- sqrt(diag(e$vcov)) myest <- cbind(theta,theta.sd,(Z <- theta/theta.sd),2*(pnorm(abs(Z),lower.tail=FALSE))) colnames(myest) <- c("Estimate","Std. Error", "Z value", "Pr(>|z|)") if (object$type%in%c("u","flex","sat")) { corMZ <- corDZ <- NULL if (object$constrain) { i1 <- lava::parpos(object$estimate$model,p="atanh(rhoMZ)")[1] i2 <- lava::parpos(object$estimate$model,p="atanh(rhoDZ)")[1] if (length(i1)>0) { corest <- coef(object$estimate,level=0)[c(i1,i2)] sdest <- vcov(object$estimate)[cbind(c(i1,i2),c(i1,i2))]^0.5 ciest <- tanh(cbind(corest,corest)+qnorm(0.975)*cbind(-sdest,sdest)) corest <- tanh(corest) corMZ <- c(corest[1],ciest[1,]) corDZ <- c(corest[2],ciest[2,]) } } aa <- capture.output(e) res <- list(estimate=aa, zyg=zygtab, varEst=NULL, varSigma=NULL, heritability=NULL, corMZ=corMZ, corDZ=corDZ, logLik=logLik(e), AIC=AIC(e), BIC=BIC(e), type=object$type, vcov=vcov(e) ) class(res) <- "summary.twinlm" return(res) } KinshipGroup <- NULL if (!is.null(object$group)) { zA.idx <- grep("z(A):",names(coef(object)),fixed=TRUE) zD.idx <- grep("z(A):",names(coef(object)),fixed=TRUE) KinshipGroup <- constraints(e)[,c(1,5,6),drop=FALSE] } r1 <- gsub(".1","",coef(Model(Model(e))[[1]], mean=e$meanstructure, silent=TRUE), fixed=TRUE) rownames(myest) <- seq(nrow(myest)) idx <- seq(nrow(myest)); rownames(myest)[idx] <- r1 coefpost <- paste(lava.options()$symbol[1],c("a1","c1","d1","e1"),sep="") coefpost2 <- paste(lava.options()$symbol[1],c("a2","c2","d2","e2"),sep="") myest.varpos <- unlist(sapply(coefpost,function(x) grep(x,rownames(myest)))) lambda.idx <- sapply(coefpost,function(x) grep(x,names(coef(e)))) lambda.idx2 <- sapply(coefpost2,function(x) grep(x,names(coef(e)))) for (k in seq_len(length(lambda.idx))) if (length(lambda.idx[[k]])==0) lambda.idx[[k]] <- lambda.idx2[[k]] lambda.w <- which(sapply(lambda.idx, function(x) length(x)>0)) rownames(myest)[myest.varpos] <- paste("sd(",c("A)","C)","D)","E)"),sep="")[lambda.w] varEst <- rep(0,4) varEst[lambda.w] <- myest[myest.varpos,1] varSigma <- matrix(0,4,4); varSigma[lambda.w,lambda.w] <- e$vcov[unlist(lambda.idx),unlist(lambda.idx)] L <- gaussian("identity") if (transform) L <- binomial("logit") varcomp <- c() genpos <- c() pos <- 0L { varcomp <- c() if ("a1"%in%latent(e)) { varcomp <- "lambda[a]"; pos <- pos+1 genpos <- c(genpos,pos) } if ("c1"%in%latent(e)) { varcomp <- c(varcomp,"lambda[c]"); pos <- pos+1 } if ("d1"%in%latent(e)) { varcomp <- c(varcomp,"lambda[d]"); pos <- pos+1; genpos <- c(genpos,pos) } isOrdinal <- (object$ordinal>0)*1 if (isOrdinal) varEst[4] <- 1 if ("e1"%in%latent(e) & !isOrdinal) { varcomp <- c(varcomp,"lambda[e]"); pos <- pos+1 } f <- paste("h2~",paste(varcomp,collapse="+")) constrain(e, as.formula(f)) <- function(x) { L$linkfun(sum(x[genpos]^2)/sum(x^2+isOrdinal)) } } ci.logit <- L$linkinv(constraints(e,k=1)["h2",5:6]) h <- function(x) (x[1]^2)/(sum(x^2)) dh <- function(x) { y <- x^2 cbind(1/sum(y)^2*c(2*x[1]*(sum(y)-y[1]), -2*x[2:4]*y[1])) } ## f(x1,x2,x3,x4) = x1/(x1+x2+x3+x4) = x1/s ## Quotient rule: (u/v)' = (u'v - uv')/v^2 ## f1(x1,x2,x3,x4) = (s - x1)/s^2 = (x2+x3+x4)/s^2 ## f2(x1,x2,x3,x4) = -1/(s)^2 h2 <- function(x) (x[1]^2+x[3]^2)/sum(x^2) dh2 <- function(x) { y <- x^2 cbind(1/sum(y)^2*c( 2*x[1]*(sum(y)-(y[1]+y[3])), -2*x[2]*(y[1]+y[3]), 2*x[3]*(sum(y)-(y[1]+y[3])), -2*x[4]*(y[1]+y[3]) )) } hval <- cbind(h(varEst), (t(dh(varEst))%*%varSigma%*%(dh(varEst)))^0.5) colnames(hval) <- c("Estimate", "Std.Err"); rownames(hval) <- "h squared" h2val <- cbind(h2(varEst), (t(dh2(varEst))%*%varSigma%*%(dh2(varEst)))^0.5) colnames(h2val) <- c("Estimate", "Std.Err"); rownames(h2val) <- "h squared" atanhcorMZf <- function(x) atanh(sum(x[1:3]^2)/sum(x^2)) atanhcorDZf <- function(x) atanh(sum(x[1:3]^2*c(0.5,1,0.25))/sum(x^2)) e1 <- atanhcorMZf(varEst) D1 <- numDeriv::grad(atanhcorMZf,varEst) s1 <- (t(D1)%*%varSigma%*%(D1))^0.5 ci1 <- e1+qnorm(0.975)*c(-1,1)*s1[1] e2 <- atanhcorDZf(varEst) D2 <- numDeriv::grad(atanhcorDZf,varEst) s2 <- (t(D2)%*%varSigma%*%(D2))^0.5 ci2 <- e2+qnorm(0.975)*c(-1,1)*s2[1] corMZ <- c(tanh(c(e1,ci1))) corDZ <- c(tanh(c(e2,ci2))) acde <- acde.twinlm(object,transform=transform) coef <- rbind(acde) hrow <- rbind(c(h2val,ci.logit)); rownames(hrow) <- "Broad-sense heritability" colnames(hrow)[1:2] <- c("Estimate","Std.Err") all <- rbind(hrow[,c(1,3,4),drop=FALSE],coef,corMZ,corDZ) res <- list(estimate=myest, zyg=zygtab, varEst=varEst, KinshipGroup=KinshipGroup, varSigma=varSigma, heritability=hrow, corMZ=corMZ, corDZ=corDZ, acde=acde, logLik=logLik(e), AIC=AIC(e), BIC=BIC(e), type=object$type, coef=coef, all=all, vcov=vcov(e)); class(res) <- "summary.twinlm" return(res) } ###}}} summary.twinlm ###{{{ print.summary.twinlm ##' @export print.summary.twinlm <- function(x,signif.stars=FALSE,...) { if (x$type%in%c("flex","u","sat")) { cat(x$estimate,sep="\n") } else { printCoefmat(x$estimate,signif.stars=signif.stars,...) cat("\n") print(x$zyg,quote=FALSE) if (!is.null(x$acde)) { cat("\nVariance decomposition:\n") print(RoundMat(x$acde,...),quote=FALSE) } cat("\n\n") ## cat("Broad-sense heritability (total genetic factors):\n") h <- with(x, heritability[,c(1,3,4),drop=FALSE]); h <- na.omit(h) print(RoundMat(h,...),quote=FALSE) cat("\n") } if (!is.null(x$corMZ)) { cc <- with(x, rbind(corMZ,corDZ)) rownames(cc)[1:2] <- c("Correlation within MZ:","Correlation within DZ:") if (!is.null(x$KinshipGroup)) { cc <- rbind(cc,x$KinshipGroup) } colnames(cc) <- c("Estimate","2.5%","97.5%") print(RoundMat(cc,...),quote=FALSE) } cat("\n") print(x$logLik) cat("AIC:", x$AIC, "\n") cat("BIC:", x$BIC, "\n") invisible(x) } ###}}} print.summary.twinlm ###{{{ compare.twinlm ##' @export compare.twinlm <- function(object,...) { if (length(list(...))==0) return(compare(object$estimate)) getS3method("compare","default")(object,...) } ###}}} compare.twinlm ###{{{ plot.twinlm ##' @export plot.twinlm <- function(x,diag=TRUE,labels=TRUE,...) { op <- par(mfrow=c(2,1)) plot(x$model,...) par(op) } ###}}} ###{{{ vcov.twinlm ##' @export vcov.twinlm <- function(object,...) { return(object$vcov) } ###}}} vcov.twinlm ###{{{ logLik.twinlm ##' @export logLik.twinlm <- function(object,...) logLik(object$estimate,...) ###}}} logLik.twinlm ###{{{ score.twinlm ##' @export score.twinlm <- function(x,...) score(x$estimate,...) ###}}} score.twinlm ###{{{ model.frame.twinlm ##' @export model.frame.twinlm <- function(formula,...) { return(formula$estimate$model$data) } ###}}} model.frame.twinlm ###{{{ acde ##"acde" <- function(x,...) UseMethod("acde") acde.twinlm <- function(x,index,transform=FALSE,estimate.return=FALSE,...) { if (missing(index)) { m <- x$estimate$model$lvm[[1]] lambdas <- c("lambda[a]","lambda[c]","lambda[d]","lambda[e]") pp <- sapply(lambdas,function(x) grep(x,as.vector(m$par),fixed=TRUE)) ACDE <- unlist(lapply(pp,function(x) length(x)>0)) pp <- unlist(lapply(pp[ACDE], function(x) as.vector(m$par)[x[1]])) index <- sapply(pp,function(p) lava::parpos(x$estimate$model,p)) names(index) <- c("A","C","D","E")[ACDE] } ord <- x$ordinal>0 ## f <- function(p) structure(log(p/(1-p)),grad=cbind(0,1/(p*(1-p)),0)) if (transform) { suppressWarnings(res <- estimate(x,function(p) lapply(index, function(z) lava::logit((p[z]^2/sum(c(p[index]^2,ord))))), vcov=vcov(x))) if (estimate.return) return(res) res <- res$coefmat[,c(1,3,4),drop=FALSE] res <- lava::tigol(res) } else { suppressWarnings(res <- estimate(x,function(p) lapply(index, function(z) { p[z]^2/sum(c(p[index]^2),ord) }), vcov=vcov(x))) if (estimate.return) return(res) res <- res$coefmat[,c(1,3,4),drop=FALSE] } res } ###}}} acde ##' @export coef.twinlm <- function(object,...) coef(object$estimate,...) ##' @export iid.twinlm <- function(x,...) { U <- score(x$estimate,indiv=TRUE) U <- lapply(U,function(x) {x[is.na(x)] <- 0; return(x)}) U <- Reduce(rbind,U) iI <- vcov(x) U%*%iI } mets/R/pch.R0000644000176200001440000000065113623061405012322 0ustar liggesusers##' Piecewise constant hazard distribution ##' ##' Piecewise constant hazard distribution ##' @aliases rpch ppch ##' @export ##' @param n sample size ##' @param lambda rate parameters ##' @param breaks time cut-points ##' @aliases rpch ppch rpch <- function(n, lambda=1, breaks=c(0,Inf)) { res <- .Call("_mets_rpch", n=n, lambda=lambda, time=breaks) return(res) } mets/R/sim.coxph.R0000644000176200001440000000021513623061405013454 0ustar liggesusers##' @export sim.cox <- function(x,...) { timereg::sim.cox(cox=x,...) } ##' @export simulate.cox <- function(object,...) sim(object,...) mets/R/claytonakes.R0000644000176200001440000002071213623061405014065 0ustar liggesusers##' Clayton-Oakes frailty model ##' ##' @title Clayton-Oakes model with piece-wise constant hazards ##' @param formula formula specifying the marginal proportional (piecewise constant) hazard structure with the right-hand-side being a survival object (Surv) specifying the entry time (optional), the follow-up time, and event/censoring status at follow-up. The clustering can be specified using the special function \code{cluster} (see example below). ##' @param data Data frame ##' @param cluster Variable defining the clustering (if not given in the formula) ##' @param var.formula Formula specifying the variance component structure (if not given via the cluster special function in the formula) using a linear model with log-link. ##' @param cuts Cut points defining the piecewise constant hazard ##' @param type when equal to \code{two.stage}, the Clayton-Oakes-Glidden estimator will be calculated via the \code{timereg} package ##' @param start Optional starting values ##' @param control Control parameters to the optimization routine ##' @param var.invlink Inverse link function for variance structure model ##' @param ... Additional arguments ##' @author Klaus K. Holst ##' @examples ##' set.seed(1) ##' d <- subset(simClaytonOakes(500,4,2,1,stoptime=2,left=2),truncated) ##' e <- ClaytonOakes(survival::Surv(lefttime,time,status)~x+cluster(~1,cluster), ##' cuts=c(0,0.5,1,2),data=d) ##' e ##' ##' ##' d2 <- simClaytonOakes(500,4,2,1,stoptime=2,left=0) ##' d2$z <- rep(1,nrow(d2)); d2$z[d2$cluster%in%sample(d2$cluster,100)] <- 0 ##' ## Marginal=Cox Proportional Hazards model: ##' ts <- ClaytonOakes(survival::Surv(time,status)~timereg::prop(x)+cluster(~1,cluster), ##' data=d2,type="two.stage") ##' ## Marginal=Aalens additive model: ##' ts2 <- ClaytonOakes(survival::Surv(time,status)~x+cluster(~1,cluster), ##' data=d2,type="two.stage") ##' ## Marginal=Piecewise constant: ##' e2 <- ClaytonOakes(survival::Surv(time,status)~x+cluster(~-1+factor(z),cluster), ##' cuts=c(0,0.5,1,2),data=d2) ##' e2 ##' plot(ts) ##' plot(e2,add=TRUE) ##' ##' e3 <- ClaytonOakes(survival::Surv(time,status)~x+cluster(~1,cluster),cuts=c(0,0.5,1,2), ##' data=d,var.invlink=identity) ##' e3 ##' @export ClaytonOakes <- function(formula,data=parent.frame(),cluster,var.formula=~1,cuts=NULL,type="piecewise",start,control=list(),var.invlink=exp,...) { mycall <- match.call() dots <- list(...) formulaId <- Specials(formula,"cluster") formulaStrata <- Specials(formula,"strata") formulaSt <- "~." formulaProp <- Specials(formula,"prop") if (!is.null(formulaId)) { var.formulaId <- ~1 if (length(formulaId)>1) { var.formula <- as.formula(formulaId[[1]]) formulaId <- formulaId[[2]] } cluster <- formulaId mycall$cluster <- cluster formulaSt <- paste(formulaSt,paste("-cluster(",paste(var.formula,collapse=""), ",",formulaId,")")) } formulaSt <- paste(formulaSt,paste("-strata(",paste(formulaStrata,collapse="+"),")")) formula <- update(formula,formulaSt) if (!is.null(formulaStrata)) { strata <- formulaStrata mycall$strata <- strata } if (missing(cluster)) stop("Missing 'cluster' variable") ngamma <- 0 data <- data[order(data[,cluster]),] Z <- model.matrix(var.formula,data) ngamma <- ncol(Z) if (type!="piecewise") { timeregmod <- ifelse(length(formulaProp)>0,"cox.aalen","aalen") if (is.null(dots$robust)) dots$robust <- 0 args <- c(list(formula=formula,data=data,max.clust=NULL,clusters=data[,cluster]),dots) marg <- do.call(timeregmod, args) return(two.stage(marg,data=data,theta.des=Z,var.link=1,...)) } timevar <- terms(formula)[[2]] if (is.call(timevar)) { delayedentry <- (length(timevar)==4)*1 entry <- NULL if (delayedentry==1) entry <- as.character(timevar[[2]]) causes <- timevar[[3+delayedentry]] timevar <- timevar[[2+delayedentry]] } timevar <- as.character(timevar) causes <- as.character(causes) covars <- as.character(attributes(terms(formula))$variables)[-(1:2)] X <- NULL nbeta <- 0 if (length(covars)>0) { ## X <- model.matrix(as.formula(paste("~-1+",paste(covars,collapse="+"))),data) X <- model.matrix(update(formula,.~.+1),data)[,-1,drop=FALSE] nbeta <- ncol(X) } if (is.data.frame(data)) { mydata <- data.frame(T=data[,timevar],status=data[,causes],cluster=data[,cluster],entry=0) if (!is.null(entry)) { mydata$entry <- data[,entry] } } else { mydata <- data.frame(T=get(timevar,envir=data),status=get(causes,envir=data),cluster=get(cluster,envir=data),entry=0) if (!is.null(entry)) mydata$entry <- get(entry,envir=data) } if (is.null(cuts)) { cuts <- c(0,max(mydata$T)) } if (max(mydata$T)>tail(cuts,1)) stop("Interval does not embed time observations") if (any(with(mydata, Tthreshold ee$values[idx] <- 1/ee$values[idx]; if (!all(idx)) ee$values[!idx] <- 0 V <- with(ee, vectors%*%diag(values)%*%t(vectors)) } else { V <- matrix(NA,length(p0),length(p0)) } } res <- list(coef=opt$par,vcov=V,cuts=cuts,nbeta=nbeta,ngamma=ngamma,betanames=colnames(X),gammanames=colnames(Z),opt=opt,invlink=var.invlink,invlinkname=invlinkname) class(res) <- "claytonoakes" return(res) } ################################################## ##' @export print.claytonoakes <- function(x,...) { print(summary(x)) } ##' @export print.summary.claytonoakes <- function(x,...) { printCoefmat(x$coef[,c(1,3,4)],...) cat("\nDependence parameters:\n") printCoefmat(x$var,...) invisible(x) } ##' @export summary.claytonoakes <- function(object,...) { mycoef <- matrix(nrow=length(object$coef),ncol=4) mycoef[,1:2] <- cbind(object$coef,sqrt(diag(object$vcov))) mycoef[,3:4] <- cbind(mycoef[,1]-qnorm(0.975)*mycoef[,2],mycoef[,1]+qnorm(0.975)*mycoef[,2]) colnames(mycoef) <- c("Estimate","Std.Err","2.5%","97.5%") if (length(object$cuts)) cutnames <- levels(cut(0,breaks=object$cuts)) varname <- switch(object$invlinkname,exp="log-Var:",identity="Var:",paste("inv",object$invlinkname,"-Var:",sep="")) rownames(mycoef) <- c(paste(varname,object$gammanames,sep=""),object$betanames,cutnames) mycoef[-seq(object$ngamma),] <- exp(mycoef[-seq(object$ngamma),]) varcoef <- object$invlink(mycoef[seq(object$ngamma),c(1,3,4),drop=FALSE]) rownames(varcoef) <- object$gammanames varcoef <- cbind(varcoef,1/(1+2/varcoef)) colnames(varcoef)[c(1,4)] <- c("Variance","Kendall's tau") res <- list(coef=mycoef,var=varcoef) class(res) <- "summary.claytonoakes" res } ##' @export plot.claytonoakes <- function(x,chaz=TRUE,add=!is.null(dev.list()),col="darkblue",...) { haz <- summary(x)$coef[-seq(x$nbeta+x$ngamma),,drop=FALSE] t <- x$cuts L <- approxfun(t,f=1,cumsum(c(0,haz[,1]*diff(t))),method="linear") if (add) { lines(t,L(t),col=col,...) } else { plot(t,L(t),type="l",col=col,...) } invisible(x) } predict.claytonoakes <- function(x,...) { } mets/R/casewise.R0000644000176200001440000003434713623061405013364 0ustar liggesusers##' Estimates the casewise concordance based on Concordance and marginal estimate using timereg and performs test for independence ##' ##' @title Estimates the casewise concordance based on Concordance and marginal estimate using timereg and performs test for independence ##' @details Uses cluster based conservative standard errors for marginal ##' @param conc Concordance ##' @param marg Marginal estimate ##' @param test Type of test for independence assumption. "conc" makes test on concordance scale and "case" means a test on the casewise concordance ##' @param p check that marginal probability is greater at some point than p ##' @author Thomas Scheike ##' @aliases casewise.test slope.process casewise.bin ##' @examples ##' \donttest{ ## Reduce Ex.Timings ##' library("timereg") ##' data("prt",package="mets"); ##' ##' prt <- prt[which(prt$id %in% sample(unique(prt$id),7500)),] ##' ### marginal cumulative incidence of prostate cancer ##' times <- seq(60,100,by=2) ##' outm <- comp.risk(Event(time,status)~+1,data=prt,cause=2,times=times) ##' ##' cifmz <- predict(outm,X=1,uniform=0,resample.iid=1) ##' cifdz <- predict(outm,X=1,uniform=0,resample.iid=1) ##' ##' ### concordance for MZ and DZ twins ##' cc <- bicomprisk(Event(time,status)~strata(zyg)+id(id), ##' data=prt,cause=c(2,2)) ##' cdz <- cc$model$"DZ" ##' cmz <- cc$model$"MZ" ##' ##' ### To compute casewise cluster argument must be passed on, ##' ### here with a max of 100 to limit comp-time ##' outm <-comp.risk(Event(time,status)~+1,data=prt, ##' cause=2,times=times,max.clust=100) ##' cifmz <-predict(outm,X=1,uniform=0,resample.iid=1) ##' cc <-bicomprisk(Event(time,status)~strata(zyg)+id(id),data=prt, ##' cause=c(2,2),se.clusters=outm$clusters) ##' cdz <- cc$model$"DZ" ##' cmz <- cc$model$"MZ" ##' ##' cdz <- casewise.test(cdz,cifmz,test="case") ## test based on casewise ##' cmz <- casewise.test(cmz,cifmz,test="conc") ## based on concordance ##' ##' plot(cmz,ylim=c(0,0.7),xlim=c(60,100)) ##' par(new=TRUE) ##' plot(cdz,ylim=c(0,0.7),xlim=c(60,100)) ##' ##' slope.process(cdz$casewise[,1],cdz$casewise[,2],iid=cdz$casewise.iid) ##' ##' slope.process(cmz$casewise[,1],cmz$casewise[,2],iid=cmz$casewise.iid) ##' ##' } ##' @export casewise.test <- function(conc,marg,test="no-test",p=0.01) { ## {{{ ### conc=cdz; marg=cifdz; p=0.01 ### conc=cmz; marg=cifmz ### names(cdz) ### cdz$casewise if (sum(marg$P1>p)==0) stop("No timepoints where marginal > ",p,"\n"); time1 <- conc$time; time2 <- marg$time[marg$P1>0.01] mintime <- max(time1[1],time2[1]) maxtime <- min(max(time1),max(time2)) timer <- seq(mintime, maxtime,length=100) dtimer <- timer[2]-timer[1] margtime <- Cpred(cbind(marg$time,c(marg$P1)),timer)[,2] concP1 <- Cpred(cbind(conc$time,c(conc$P1)),timer)[,2] se.margtime <- Cpred(cbind(marg$time,c(marg$se.P1)),timer) se.concP1 <- Cpred(cbind(conc$time,c(conc$se.P1)),timer) outtest <- NULL casewise.iid <- NULL casewise <- concP1/margtime se.casewise2 <- as.matrix(se.concP1[,2]/margtime,ncol=100) se.margtime <- as.matrix(se.margtime[,2],ncol=100) se.casewise <- NULL; outtest <- NULL; if (is.null(conc$P1.iid) || is.null(marg$P1.iid)) { cat("Warning, need iid decomposition for correct se's for Concordance \n"); } else { conciid <- Cpred(cbind(conc$time,conc$P1.iid),timer)[,-1] nconc <- colnames(conc$P1.iid) P1iid <- Cpred(cbind(marg$time,marg$P1.iid),timer)[,-1] P1iid2 <- 2*P1iid*margtime; se.p2 <- apply(P1iid2^2,1,sum)^.5 conciid <- (P1iid2[,nconc]-conciid) ### iid of conc-p1^2 test c.iid <- casewise.iid <- conciid/margtime - P1iid[,nconc]*casewise se.casewise <- apply(casewise.iid^2,1,sum)^.5 dif.casewise.iid <- conciid/margtime ### iid of casewise test if (test=="case") { diff.iidcase <- apply(dif.casewise.iid,2,sum)*dtimer; sd.pepem <- sum(diff.iidcase^2)^.5 diff.pepem <- sum((casewise-margtime))*dtimer z.pepem <- diff.pepem/sd.pepem pval.pepem <- 2*pnorm(-abs(z.pepem)) outtest <- cbind(diff.pepem,sd.pepem,z.pepem,pval.pepem) ### test for constant casewise concordance diff.const <- (casewise-mean(casewise)) iid.constant <- (c.iid - matrix(apply(c.iid,2,mean),nrow(c.iid),ncol(c.iid),byrow=T)) se.const <- apply(iid.constant^2,1,sum)^.5 test.constant <- max(abs(diff.const/se.const)) sim.maxs <- apply(abs(iid.constant/se.const),1,max) pval.const <- pval(sim.maxs,test.constant) outtest <- cbind(diff.pepem,sd.pepem,z.pepem,pval.pepem,test.constant,pval.const) colnames(outtest) <- c("cum dif.","sd","z","pval","constant-case","pval") rownames(outtest) <- "pepe-mori" } else if (test=="conc") { diff.iid <- apply(conciid,2,sum)*dtimer sd.pepem <- sum(diff.iid^2)^.5 diff.pepem <- sum((concP1-margtime^2))*dtimer z.pepem <- diff.pepem/sd.pepem pval.pepem <- 2*pnorm(-abs(z.pepem)) outtest <- cbind(diff.pepem,sd.pepem,z.pepem,pval.pepem) colnames(outtest) <- c("cum dif.","sd","z","pval") rownames(outtest) <- "pepe-mori" } } concout <- cbind(timer,concP1,se.concP1[,2]) colnames(concout) <- c("time","concordance","se") margout <- cbind(timer,margtime,se.margtime) colnames(margout) <- c("time","cif","se") casewiseout <- cbind(timer,casewise,se.casewise,se.casewise2) colnames(casewiseout) <- c("time","casewise","se","se2") difout <- cbind(timer,concP1-margtime^2,apply(conciid^2,1,sum)^.5) out <- list(casewise=casewiseout,marg=margout,conc=concout,casewise.iid=casewise.iid, test=outtest,mintime=mintime,maxtime=maxtime,same.cluster=TRUE,testtype=test) class(out) <- "casewise" return(out) } ## }}} ##' @export slope.process <- function(time,y,iid=NULL) { ## {{{ ctime <- scale(time) caselm <- lm(y ~ ctime) slope <- coef(caselm)[2] if (!is.null(iid)) { diff.iid <- iid lm.iid <- c() for (i in 1:ncol(iid)) { lmiid <- lm(iid[,i] ~ ctime) lm.iid <- rbind(lm.iid,coef(lmiid)) } se.slope <- apply(lm.iid,2,sd)^.5 } else {se.slop <- NULL} z.slope <- slope/se.slope[2] pval <- 2*(1-pnorm(abs(z.slope))) out <- list(intercept=coef(caselm)[1],slope=slope,se.slope=se.slope,pval.slope=pval) return(out) } ## }}} ##' .. content for description (no empty lines) .. ##' ##' @title Estimates the casewise concordance based on Concordance and marginal estimate using prodlim but no testing ##' @param conc Concordance ##' @param marg Marginal estimate ##' @param cause.marg specififes which cause that should be used for marginal cif based on prodlim ##' @author Thomas Scheike ##' @examples ##' \donttest{ ## Reduce Ex.Timings ##' library(prodlim) ##' data(prt); ##' ##' ### marginal cumulative incidence of prostate cancer##' ##' outm <- prodlim(Hist(time,status)~+1,data=prt) ##' ##' times <- 60:100 ##' cifmz <- predict(outm,cause=2,time=times,newdata=data.frame(zyg="MZ")) ## cause is 2 (second cause) ##' cifdz <- predict(outm,cause=2,time=times,newdata=data.frame(zyg="DZ")) ##' ##' ### concordance for MZ and DZ twins ##' cc <- bicomprisk(Event(time,status)~strata(zyg)+id(id),data=prt,cause=c(2,2),prodlim=TRUE) ##' cdz <- cc$model$"DZ" ##' cmz <- cc$model$"MZ" ##' ##' cdz <- casewise(cdz,outm,cause.marg=2) ##' cmz <- casewise(cmz,outm,cause.marg=2) ##' ##' plot(cmz,ci=NULL,ylim=c(0,0.5),xlim=c(60,100),legend=TRUE,col=c(3,2,1)) ##' par(new=TRUE) ##' plot(cdz,ci=NULL,ylim=c(0,0.5),xlim=c(60,100),legend=TRUE) ##' summary(cdz) ##' summary(cmz) ##' } ##' @export casewise <- function(conc,marg,cause.marg) { ## {{{ if (missing(cause.marg)) stop("Please specify cause of marginal (as given in Event object)") if ((!class(conc)=="prodlim") || (!class(marg)=="prodlim")) stop("Assumes that both models are based on prodlim function \n"); time1 <- conc$time time2 <- marg$time cause.prodlim <- match(as.character(cause.marg),levels(prodlim::getEvent(marg$model.response))) if (is.na(cause.prodlim)) stop("Cause did not match marginal model") mintime <- max(time1[1],time2[1]) maxtime <- min(max(time1),max(time2)) timer <- seq(mintime, maxtime,length=100) dtimer <- timer[2]-timer[1] out <- conc out$time <- timer if (class(marg)=="comp.risk") margtime <- Cpred(cbind(marg$time,c(marg$P1)),timer)[,2] else if (class(marg)=="prodlim") { cuminc <- data.frame(marg$cuminc)[,cause.prodlim]; se.cuminc <- data.frame(marg$se.cuminc)[,cause.prodlim]; margtime <- Cpred(cbind(marg$time,c(cuminc)),timer)[,2]; se.margtime <- Cpred(cbind(marg$time,c(se.cuminc)),timer)[,2]; } else stop("marginal cumulative incidence comp.risk or prodlim output\n"); if (class(conc)=="comprisk") concP1 <- Cpred(cbind(conc$time,c(conc$P1)),timer)[,2] else if (class(conc)=="prodlim") { conc.cuminc <- data.frame(conc$cuminc)[,1] conc.se.cuminc <- data.frame(conc$se.cuminc)[,1] se.P1 <- Cpred(cbind(conc$time,conc.se.cuminc),timer)[,2] concP1 <- Cpred(cbind(conc$time,conc.cuminc),timer)[,2] } concordance<- cbind(timer,concP1,se.P1) colnames(concordance) <- c("time","cif","se.cif") P1 <- concP1/margtime se.P1 <- se.P1/margtime med <- (margtime>0) & (concP1 > 0) out$P1 <- P1[med] out$se.P1 <- se.P1[med] out$timer <- timer[med] margout <- cbind(timer,margtime,se.margtime) colnames(margout) <- c("time","cif","se.cif") probout <- cbind(out$timer,out$P1,out$se.P1) colnames(probout) <- c("time","casewise conc","se casewise") out <- list(casewise=probout,marg=margout,concordance=concordance,test=NULL) class(out) <- "casewise" return(out) } ## }}} ##' @export casewise.bin <- function(nc,nd) { ## {{{ ud <- glm(cbind(nc,round(0.5*nd+nc))~ +1,family=binomial()) udci <- confint(ud) pud <- predict(ud,se.fit=TRUE,type="response") return(list(p.casewise=pud$fit,ci.casewise=exp(udci))) } ## }}} ##' @export plot.casewise <- function(x,ci=NULL,lty=NULL,ylim=NULL,col=NULL,xlab="time",ylab="concordance",legend=FALSE,...) { ## {{{ if (is.null(col)) col <- 1:3 if (is.null(lty)) lty <- 1:3 if (is.null(ylim)) ylim=range(c(x$casewise[,2],x$marg[,2])) plot(x$casewise[,1],x$casewise[,2],type="s",ylim=ylim,lty=lty[1],col=col[1],xlab=xlab,ylab=ylab,...) if (!is.null(ci)) { ul <- x$casewise[,2]+qnorm(1-(1-ci)/2)* x$casewise[,3] nl <- x$casewise[,2]-qnorm(1-(1-ci)/2)* x$casewise[,3] lines(x$casewise[,1],ul,type="s",ylim=ylim,lty=lty[3],col=col[3]) lines(x$casewise[,1],nl,type="s",ylim=ylim,lty=lty[3],col=col[3]) } lines(x$marg[,1],x$marg[,2],lty=lty[2],col=col[2],type="s") if (legend==TRUE) legend("topleft",lty=lty[1:2],col=col[1:2],c("Casewise concordance","Marginal estimate")) } ## }}} ##' @export summary.casewise <- function(object,marg=FALSE,...) { ## {{{ cat("Casewise concordance and standard errors \n"); print(signif(cbind(object$casewise),3)) cat("\n"); if (marg==TRUE) { cat("Marginal cumulative incidence and standard errors \n"); print(signif(cbind(object$marg),3)) } print(object,...) } ## }}} ##' prints Concordance test ##' ##' @title prints Concordance test ##' @param x output from casewise.test ##' @param digits number of digits ##' @param \dots Additional arguments to lower level functions ##' @author Thomas Scheike ##' @export print.casewise <- function(x,digits=3,...) { ## {{{ cat("\n") if (!is.null(x$test)) { cat("Pepe-Mori type test for H_0: conc_1(t)= conc_2(t)\n") if (x$same.cluster==TRUE) cat("Assuming same clusters for the two functions\n") else cat("Assuming independence for estimators\n"); cat(paste("Time.range =",signif(x$mintime,3),"--",signif(x$maxtime,3),"\n\n")); prmatrix(signif(x$test,digits)) invisible(x) } } ## }}} ##' .. content for description (no empty lines) .. ##' ##' @title Concordance test Compares two concordance estimates ##' @param conc1 Concordance estimate of group 1 ##' @param conc2 Concordance estimate of group 2 ##' @param same.cluster if FALSE then groups are independent, otherwise estimates are based on same data. ##' @author Thomas Scheike ##' @export test.conc <- function(conc1,conc2,same.cluster=FALSE) { ## {{{ time <- time1 <- conc1$time time2 <- conc2$time mintime <- max(time1[1],time2[1]) maxtime <- min(max(time1),max(time2)) timer <- seq(mintime, maxtime,length=100) dtimer <- timer[2]-timer[1] conc2timer <- Cpred(cbind(conc2$time,c(conc2$P1)),timer)[,2] conc1timer <- Cpred(cbind(conc1$time,c(conc1$P1)),timer)[,2] outtest <- NULL if (is.null(conc1$P1.iid) || is.null(conc2$P1.iid)) stop("Must give iid represenation for both estimators\n"); if (!is.null(conc1$P1.iid) && !is.null(conc2$P1.iid)) { if ( ((ncol(conc1$P1.iid[,])-ncol(conc2$P1.iid[,]))!=0) && same.cluster==TRUE) cat("Warning, not same number of iid residuals for concordance and marginal estimate\n"); } if (!is.null(conc1$P1.iid)) if (!is.null(conc2$P1.iid)) { ### iid version af integraler conc2P1.iid <- Cpred(cbind(conc2$time,conc2$P1.iid[,]),timer)[,-1] conc1P1.iid <- Cpred(cbind(conc1$time,conc1$P1.iid[,]),timer)[,-1] if ( (ncol(conc1$P1.iid)==ncol(conc2$P1.iid)) && same.cluster==TRUE) { diff.iid <- conc1P1.iid-conc2P1.iid sdiff.iid <- apply(diff.iid,2,sum)*dtimer sd.pepem <- sum(sdiff.iid^2)^.5 } else { diff2.iid <- conc2P1.iid sdiff2.iid <- apply(diff2.iid,2,sum)*dtimer var2.pepem <- sum(sdiff2.iid^2) diff1.iid <- conc1P1.iid sdiff1.iid <- apply(diff1.iid,2,sum)*dtimer var1.pepem <- sum(sdiff1.iid^2) sd.pepem <- (var1.pepem+var2.pepem)^.5 } diff.pepem <- sum(conc2timer-conc1timer)*dtimer ### print(cbind(conc2timer,conc1timer)) z.pepem <- diff.pepem/sd.pepem pval.pepem <- 2*pnorm(-abs(z.pepem)) outtest <- cbind(diff.pepem,sd.pepem,z.pepem,pval.pepem) colnames(outtest) <- c("cum dif.","sd","z","pval") rownames(outtest) <- "pepe-mori" ### print(outtest,4) ### prmatrix(outtest,3) } outtest <- list(test=outtest,mintime=mintime,maxtime=maxtime,same.cluster=same.cluster) ###attr(out,"class") <- rev(attr(out,"class")) class(outtest) <- "testconc" return(outtest) } ## }}} ##' convert to timereg object ##' ##' @title Convert to timereg object ##' @param obj no use ##' @author Thomas Scheike ##' @export back2timereg <- function(obj) { ## {{{ out <- obj attr(out,"class") <- rev(attr(out,"class")) return(out) } ## }}} mets/R/dreg.R0000644000176200001440000002206213623061405012471 0ustar liggesusers##' Regression for data frames with dutility call ##' ##' Regression for data frames with dutility call ##' @param data data frame ##' @param y name of variable, or fomula, or names of variables on data frame. ##' @param x name of variable, or fomula, or names of variables on data frame. ##' @param z name of variable, or fomula, or names of variables on data frame. ##' @param x.oneatatime x's one at a time ##' @param x.base.names base covarirates ##' @param z.arg what is Z, c("clever","base","group","condition"), clever decides based on type of Z, base means that Z is used as fixed baseline covaraites for all X, group means the analyses is done based on groups of Z, and condition means that Z specifies a condition on the data ##' @param fun. function lm is default ##' @param summary. summary to use ##' @param regex regex ##' @param convert convert ##' @param doSummary doSummary or not ##' @param special special's ##' @param equal to do pairwise stuff ##' @param test development argument ##' @param ... Additional arguments for fun ##' @author Klaus K. Holst, Thomas Scheike ##' @examples##' ##' data(iris) ##' data <- iris ##' drename(iris) <- ~. ##' names(iris) ##' set.seed(1) ##' iris$time <- runif(nrow(iris)) ##' iris$time1 <- runif(nrow(iris)) ##' iris$status <- rbinom(nrow(iris),1,0.5) ##' iris$S1 <- with(iris,Surv(time,status)) ##' iris$S2 <- with(iris,Surv(time1,status)) ##' iris$id <- 1:nrow(iris) ##' ##' mm <- dreg(iris,"*.length"~"*.width"|I(species=="setosa" & status==1)) ##' mm <- dreg(iris,"*.length"~"*.width"|species+status) ##' mm <- dreg(iris,"*.length"~"*.width"|species) ##' mm <- dreg(iris,"*.length"~"*.width"|species+status,z.arg="group") ##' ##' \donttest{ ## Reduce Ex.Timings ##' y <- "S*"~"*.width" ##' xs <- dreg(iris,y,fun.=phreg) ##' xs <- dreg(iris,y,fun.=survdiff) ##' ##' y <- "S*"~"*.width" ##' xs <- dreg(iris,y,x.oneatatime=FALSE,fun.=phreg) ##' ##' ## under condition ##' y <- S1~"*.width"|I(species=="setosa" & sepal.width>3) ##' xs <- dreg(iris,y,z.arg="condition",fun.=phreg) ##' xs <- dreg(iris,y,fun.=phreg) ##' ##' ## under condition ##' y <- S1~"*.width"|species=="setosa" ##' xs <- dreg(iris,y,z.arg="condition",fun.=phreg) ##' xs <- dreg(iris,y,fun.=phreg) ##' ##' ## with baseline after | ##' y <- S1~"*.width"|sepal.length ##' xs <- dreg(iris,y,fun.=phreg) ##' ##' ## by group by species, not working ##' y <- S1~"*.width"|species ##' ss <- split(iris,paste(iris$species,iris$status)) ##' ##' xs <- dreg(iris,y,fun.=phreg) ##' ##' ## species as base, species is factor so assumes that this is grouping ##' y <- S1~"*.width"|species ##' xs <- dreg(iris,y,z.arg="base",fun.=phreg) ##' ##' ## background var after | and then one of x's at at time ##' y <- S1~"*.width"|status+"sepal*" ##' xs <- dreg(iris,y,fun.=phreg) ##' ##' ## background var after | and then one of x's at at time ##' ##y <- S1~"*.width"|status+"sepal*" ##' ##xs <- dreg(iris,y,x.oneatatime=FALSE,fun.=phreg) ##' ##xs <- dreg(iris,y,fun.=phreg) ##' ##' ## background var after | and then one of x's at at time ##' ##y <- S1~"*.width"+factor(species) ##' ##xs <- dreg(iris,y,fun.=phreg) ##' ##xs <- dreg(iris,y,fun.=phreg,x.oneatatime=FALSE) ##' ##' y <- S1~"*.width"|factor(species) ##' xs <- dreg(iris,y,z.arg="base",fun.=phreg) ##' ##' y <- S1~"*.width"|cluster(id)+factor(species) ##' xs <- dreg(iris,y,z.arg="base",fun.=phreg) ##' xs <- dreg(iris,y,z.arg="base",fun.=coxph) ##' ##' ## under condition with groups ##' y <- S1~"*.width"|I(sepal.length>4) ##' xs <- dreg(subset(iris,species=="setosa"),y,z.arg="group",fun.=phreg) ##' ##' ## under condition with groups ##' y <- S1~"*.width"+I(log(sepal.length))|I(sepal.length>4) ##' xs <- dreg(subset(iris,species=="setosa"),y,z.arg="group",fun.=phreg) ##' ##' y <- S1~"*.width"+I(dcut(sepal.length))|I(sepal.length>4) ##' xs <- dreg(subset(iris,species=="setosa"),y,z.arg="group",fun.=phreg) ##' ##' ff <- function(formula,data,...) { ##' ss <- survfit(formula,data,...) ##' kmplot(ss,...) ##' return(ss) ##' } ##' ##' if (interactive()) { ##' dcut(iris) <- ~"*.width" ##' y <- S1~"*.4"|I(sepal.length>4) ##' par(mfrow=c(1,2)) ##' xs <- dreg(iris,y,fun.=ff) ##' } ##' } ##' ##' @export dreg <- function(data,y,x=NULL,z=NULL,x.oneatatime=TRUE, x.base.names=NULL,z.arg=c("clever","base","group","condition"), fun.=lm,summary.=summary,regex=FALSE,convert=NULL,doSummary=TRUE, special=NULL,equal=TRUE,test=1,...) {# {{{ ### z.arg=clever, if z is logical then condition ### if z is factor then group variable ### if z is numeric then baseline covariate ### ... further arguments to fun ### fun <- as.character(substitute(fun)) ### if (is.character(fun)) ### fun <- get(fun) ### if (!is.null(convert) && is.logical(convert)) { ### if (convert) ### convert <- as.matrix ### else convert <- NULL ### } ### if (!is.null(convert)) { ### fun_ <- fun ### fun <- function(x, ...) fun_(convert(x, ...)) ### } ### print(fun) ### print(str(fun)) yxzf <- procform(y,x=x,z=z,data=data,do.filter=FALSE,regex=regex) yxz <- procformdata(y,x=x,z=z,data=data,do.filter=FALSE,regex=regex) ### print(yxz) ### print(yxzf) ## remove blank, to able to use also +1 on right hand side if (any(yxzf$predictor=="")) yxzf$predictor <- yxzf$predictor[-which(yxzf$predictor=="")] yy <- yxz$response xx <- yxz$predictor ### group is list, so zz is data.frame if ((length(yxzf$filter))==0) zz <- NULL else if ((length(yxzf$filter[[1]])==1 & yxzf$filter[[1]][1]=="1")) zz <- NULL else zz <- yxz$group[[1]] if (!is.null(zz)) {# {{{ if (z.arg[1]=="clever") { if ((ncol(zz)==1) & is.logical(zz[1,1])) z.arg[1] <- "condition" else if ((ncol(zz)==1) & is.factor(zz[,1])) z.arg[1] <- "group" else z.arg[1] <- "base" } }# }}} ### print(z.arg) basen <- NULL if (z.arg[1]=="base") basen <- yxzf$filter[[1]] if (z.arg[1]=="condition") data <- subset(data,eval(yxzf$filter.expression)) if (z.arg[1]=="group") group <- interaction(zz) else group <- rep(1,nrow(data)) if (z.arg[1]=="group") levell <- levels(group) else levell <-1 res <- sum <- list() if (test==1) { if (is.null(summary)) sum <- NULL for (g in levell) {# {{{ if (equal==TRUE) datal <- subset(data,group==g) else datal <- subset(data,group!=g) for (y in yxzf$response) {# {{{ if (x.oneatatime) { for (x in yxzf$predictor) { if (length(c(x,basen))>1) basel <- paste(c(x,basen),collapse="+") else basel <- c(x,basen) form <- as.formula(paste(y,"~",basel)) if (!is.null(special)) form <- timereg::timereg.formula(form,special=special) ### val <- with(data,do.call(fun,c(list(formula=form),list(...)))) capture.output( val <- do.call(fun.,c(list(formula=form),list(data=datal),list(...)))) ### print(y) ### print(basel) ### val$call <- paste(y,"~",basel) val <- list(val) nn <- paste(y,"~",basel) if (z.arg[1]=="group") { if (equal==TRUE) nn <- paste(nn,"|",g) else nn <- paste(nn,"| not",g); } names(val) <- nn res <- c(res, val) if (doSummary) { sval <- list(do.call(summary.,list(val[[1]]))) names(sval) <- nn ### sval$call <- NULL sum <- c(sum, sval) } } } else { basel <- paste(c(yxzf$predictor,basen),collapse="+") form <- as.formula(paste(y,"~",basel)) if (!is.null(special)) form <- timereg::timereg.formula(form,special=special) capture.output( val <- do.call(fun.,c(list(formula=form),list(data=datal),list(...)))) nn <- paste(y,"~",basel) if (z.arg[1]=="group") { if (equal==TRUE) nn <- paste(nn,"|",g) else nn <- paste(nn,"| not",g); } ### val$call <- nn val <- list(val) names(val) <- paste(y,"~",basel) res <- c(res, val) if (doSummary) { sval <- list(do.call(summary.,list(val[[1]]))) names(sval) <- nn sum <- c(sum, sval) } } }# }}} }# }}} } res <- list(reg=res,summary=sum) ### res <- list(setNames(res,funn),summary=sum,...) class(res) <- "dreg" ### structure(res,ngrouvar=0,class="dreg") return(res) }# }}} ##' @export print.dreg <- function(x,sep="-",...) {# {{{ sep <- paste(rep(sep,50,sep=""),collapse="") sep <- paste(sep,"\n") nn <- names(x$reg) for (i in seq_along(x$reg)) { cat(paste("Model=",nn[i],"\n")) print(x$reg[[i]],...) cat(sep) } }# }}} ##' @export summary.dreg <- function(object,sep="-",...) {# {{{ x <- object sep <- paste(rep(sep,50,sep=""),collapse="") sep <- paste(sep,"\n") ### cat(sep) ### if (inherits(x$lm, c("lm"))) { ### print(x$lm) ### if (!is.null(x$summary)) print(x$summary) ### return(invisible(x)) ### } if (!is.null(x$summary)) { nn <- names(x$summary) for (i in seq_along(x$summary)) { cat(paste("Model=",nn[i],"\n")) if (!is.null(x$summary)) print(x$summary[[i]],...) else print(x$reg[[i]],...) cat(sep) } } }# }}} mets/R/options.R0000644000176200001440000000204113623061405013236 0ustar liggesusers##' Set global options for \code{mets} ##' ##' Extract and set global parameters of \code{mets}. ##' ##' \itemize{ ##' \item \code{regex}: If TRUE character vectors will be interpreted as regular expressions (\code{dby}, \code{dcut}, ...) ##' \item \code{silent}: Set to \code{FALSE} to disable various output messages ##' } ##' @param ... Arguments ##' @return \code{list} of parameters ##' @keywords models ##' @examples ##' \dontrun{ ##' mets.options(regex=TRUE) ##' } ##' @export mets.options <- function(...) { dots <- list(...) newopt <- curopt <- get("options",envir=mets.env) if (length(dots)==0) return(curopt) if (length(dots)==1 && is.list(dots[[1]]) && is.null(names(dots))) { dots <- dots[[1]] } idx <- which(names(dots)!="") newopt[names(dots)[idx]] <- dots[idx] assign("options",newopt,envir=mets.env) invisible(curopt) } mets.env <- new.env() assign("options", list(debug=FALSE, regex=FALSE, regex.perl=FALSE ), envir=mets.env) mets/R/mets-package.R0000644000176200001440000001367113623061405014117 0ustar liggesusers##' Analysis of Multivariate Events ##' ##' Implementation of various statistical models for multivariate ##' event history data. Including multivariate cumulative incidence models, ##' and bivariate random effects probit models (Liability models) ##' ##' @name mets-package ##' @docType package ##' @author Klaus K. Holst and Thomas Scheike ##' @useDynLib mets, .registration=TRUE ##' @import stats splines timereg Rcpp mvtnorm ##' @importFrom lava iid estimate bootstrap compare score information twostage %++% %ni% addvar<- blockdiag cancel Col ##' confband constrain<- constraints covariance covariance<- coxWeibull.lvm devcoords distribution<- ##' endogenous eventTime Expand getoutcome gof intercept<- Inverse kill<- latent latent<- lava.options lvm ##' Model multigroup parameter<- pars regression regression<- revdiag sim trim ##' @importFrom survival Surv is.Surv concordance ##' @importFrom utils head tail getS3method glob2rx capture.output ##' @importFrom graphics matplot lines plot polygon par points abline ##' title matlines legend ##' @importFrom grDevices dev.list devAskNewPage dev.interactive ##' @keywords package ##' @examples ##' ##' ## To appear ##' NULL ##' np data set ##' ##' @name np ##' @docType data ##' @keywords data ##' @source Simulated data NULL ##' Migraine data ##' ##' @name migr ##' @docType data ##' @keywords data NULL ##' Dermal ridges data (families) ##' ##' Data on dermal ridge counts in left and right hand in (nuclear) families ##' @name dermalridges ##' @docType data ##' @keywords data ##' @format Data on 50 families with ridge counts in left and right ##' hand for moter, father and each child. Family id in 'family' and ##' gender and child number in 'sex' and 'child'. ##' @source Sarah B. Holt (1952). Genetics of dermal ridges: bilateral ##' asymmetry in finger ridge-counts. Annals of Eugenics 17 (1), ##' pp.211--231. DOI: 10.1111/j.1469-1809.1952.tb02513.x ##' @examples ##' data(dermalridges) ##' fast.reshape(dermalridges,id="family",varying=c("child.left","child.right","sex")) NULL ##' Dermal ridges data (monozygotic twins) ##' ##' Data on dermal ridge counts in left and right hand in (nuclear) families ##' @name dermalridgesMZ ##' @docType data ##' @keywords data ##' @format Data on dermal ridge counts (left and right hand) in 18 ##' monozygotic twin pairs. ##' @source Sarah B. Holt (1952). Genetics of dermal ridges: bilateral ##' asymmetry in finger ridge-counts. Annals of Eugenics 17 (1), ##' pp.211--231. DOI: 10.1111/j.1469-1809.1952.tb02513.x ##' @examples ##' data(dermalridgesMZ) ##' fast.reshape(dermalridgesMZ,id="id",varying=c("left","right")) NULL ##' Menarche data set ##' ##' @name mena ##' @docType data ##' @keywords data ##' @source Simulated data NULL ##' Multivariate Cumulative Incidence Function example data set ##' ##' @name multcif ##' @docType data ##' @keywords data ##' @source Simulated data NULL ##' Stutter data set ##' ##' Based on nation-wide questionnaire answers from 33,317 Danish twins ##' @format ##' tvparnr: twin-pair id ##' zyg: zygosity, MZ:=mz, DZ(same sex):=dz, DZ(opposite sex):=os ##' stutter: stutter status (yes/no) ##' age: age ##' nr: number within twin-pair ##' @name twinstut ##' @docType data ##' @keywords data NULL ##' BMI data set ##' ##' @format ##' Self-reported BMI-values on 11,411 subjects ##' ##' tvparnr: twin id ##' bmi: BMI (m/kg^2) ##' age: Age ##' gender: (male/female) ##' zyg: zygosity, MZ:=mz, DZ(same sex):=dz, DZ(opposite sex):=os ##' @name twinbmi ##' @docType data ##' @keywords data NULL ##' Prostate data set ##' ##' @name prt ##' @docType data ##' @keywords data ##' @source Simulated data NULL ##' For internal use ##' ##' @title For internal use ##' @name npc ##' @rdname internal ##' @author Klaus K. Holst ##' @keywords utilities ##' @export ##' @aliases plotcr npc nonparcuminc simnordic corsim.prostate ##' alpha2kendall alpha2spear coefmat piecewise.twostage surv.boxarea ##' faster.reshape piecewise.data ##' simBinPlack simBinFam simBinFam2 simSurvFam corsim.prostate.random ##' simnordic.random simCox sim ##' grouptable jumptimes folds ##' ace.family.design ascertained.pairs CCbinomial.twostage ##' coarse.clust concordanceTwinACE concordanceTwostage ##' fast.cluster force.same.cens ilap ##' kendall.ClaytonOakes.twin.ace kendall.normal.twin.ace ##' make.pairwise.design make.pairwise.design.competing ##' matplot.mets.twostage object.defined p11.binomial.twostage.RV ##' predictPairPlack simbinClaytonOakes.family.ace ##' simbinClaytonOakes.pairs simbinClaytonOakes.twin.ace ##' simClaytonOakes.family.ace simClaytonOakes.twin.ace simFrailty.simple ##' simCompete.simple simCompete.twin.ace twin.polygen.design ##' twostage.fullse ##' procform procform3 procformdata NULL ##' Rate for leaving HPN program for patients of Copenhagen ##' ##' @name drcumhaz ##' @docType data ##' @keywords data ##' @source Estimated data NULL ##' rate of CRBSI for HPN patients of Copenhagen ##' ##' @name base1cumhaz ##' @docType data ##' @keywords data ##' @source Estimated data NULL ##' rate of Mechanical (hole/defect) complication for catheter of HPN patients of Copenhagen ##' ##' @name base4cumhaz ##' @docType data ##' @keywords data ##' @source Estimated data NULL ##' rate of Occlusion/Thrombosis complication for catheter of HPN patients of Copenhagen ##' ##' @name base44cumhaz ##' @docType data ##' @keywords data ##' @source Estimated data NULL ##' hapfreqs data set ##' ##' @name hapfreqs ##' @docType data ##' @keywords data ##' @source Simulated data NULL ##' haploX covariates and response for haplo survival discrete survival ##' ##' @name haploX ##' @docType data ##' @keywords data ##' @source Simulated data NULL ##' ghaplos haplo-types for subjects of haploX data ##' ##' @name ghaplos ##' @docType data ##' @keywords data ##' @source Simulated data NULL ##' ttpd discrete survival data on interval form ##' ##' @name ttpd ##' @docType data ##' @keywords data ##' @source Simulated data NULL mets/R/twin.clustertrunc.r0000644000176200001440000001547213623061405015334 0ustar liggesusers##' Estimation of twostage model with cluster truncation in bivariate situation ##' ##' @title Estimation of twostage model with cluster truncation in bivariate situation ##' @param survformula Formula with survival model aalen or cox.aalen, some limitiation on model specification due to call of fast.reshape (so for example interactions and * and : do not work here, expand prior to call) ##' @param data Data frame ##' @param theta.des design for dependence parameters in two-stage model ##' @param clusters clustering variable for twins ##' @param var.link exp link for theta ##' @param Nit number of iteration ##' @param final.fitting TRUE to do final estimation with SE and ... arguments for marginal models ##' @param ... Additional arguments to lower level functions ##' @author Thomas Scheike ##' @export ##' @examples ##' library("timereg") ##' data(diabetes) ##' v <- diabetes$time*runif(nrow(diabetes))*rbinom(nrow(diabetes),1,0.5) ##' diabetes$v <- v ##' ##' aout <- twin.clustertrunc(Surv(v,time,status)~1+treat+adult, ##' data=diabetes,clusters="id") ##' aout$two ## twostage output ##' par(mfrow=c(2,2)) ##' plot(aout$marg) ## marginal model output ##' ##' out <- twin.clustertrunc(Surv(v,time,status)~1+prop(treat)+prop(adult), ##' data=diabetes,clusters="id") ##' out$two ## twostage output ##' plot(out$marg) ## marginal model output twin.clustertrunc <- function(survformula,data=sys.parent(),theta.des=NULL,clusters=NULL,var.link=1, Nit=10,final.fitting=FALSE,...) { ## {{{ ## {{{ adding names of covariates from survival model to data frame if needed ## adds names that are not in data (typically intercept from additive) or ### expansion of factors, ## also reducing only to needed covariates survnames <- all.vars(update(survformula, .~0)) if (length(survnames)!=3) stop("Must give entry, exit and status") entry <- survnames[1] exit <- survnames[2] status <- survnames[3] tss <- terms(survformula) Znames <- attr(tss,"term.labels") ZnamesO <- Znames ### checks if cluster is given in survformula then removes clustervar <- grep("^cluster[(][A-z0-9._:]*",Znames,perl = TRUE) if (length(clustervar)>=1) Znames <- Znames[-clustervar] propvar <- grep("^prop[(][A-z0-9._:]*",Znames,perl = TRUE) if (length(propvar)>=1) model <- "cox.aalen" else model <- "aalen" ### removes prop from names if (model=="cox.aalen") { Zn <- c() nn <- length(Znames) ### droppe prop() for navne for (i in 1:nn) Zn <- c(Zn,substr(Znames[i],6,nchar(Znames[i])-1)) Znames <- Zn } clust.orig <- data[,clusters] d0 <- data[,c(entry,exit,status,clusters,Znames)] data <- d0 data$dataid <- 1:nrow(data) d2 <- fast.reshape(data,id=clusters) d2 <- na.omit(d2) ### only double entry people data <- fast.reshape(d2,labelnum=TRUE) des <- aalen.des(survformula,data=data,model=model) factornamesX <- !(des$covnamesX %in% Znames) colnames(des$X) <- des$covnamesX if (sum(factornamesX)>=1) data <- cbind(data,des$X[,factornamesX,drop=FALSE]) if (model=="cox.aalen") { factornamesZ <- !(des$covnamesZ %in% Znames) colnames(des$Z) <- des$covnamesZ if (sum(factornamesZ)>=1) data <- cbind(data,des$Z[,factornamesZ,drop=FALSE]) } namesX <- des$covnamesX namesZ <- des$covnamesZ pweight <- rep(1,nrow(data)) if (!is.null(clusters)) nclusters <- data[,clusters] else stop("must give clusters\n"); if (is.null(theta.des)) ptheta <- 0 else ptheta <- rep(0,ncol(theta.des)) ###singletons might be dropped so same for theta.des theta.des <- theta.des[data$dataid,] ## }}} assign("pweight",pweight,envir=environment(survformula)) for (i in 1:Nit) { ## {{{ if (model=="cox.aalen") { aout <- cox.aalen(survformula,data=data,weights=1/pweight,robust=0,n.sim=0,beta=0); beta <- c(aout$gamma,aout$cum[,-1]) } else { aout <- aalen(survformula,data=data,weights=1/pweight,robust=0,n.sim=0); beta <- aout$cum[,-1] } if (i==1) { if (model=="cox.aalen") pbeta <- 0*c(aout$gamma,aout$cum[,-1]) else pbeta <- 0*aout$cum[,-1] } if (i>=2) tout <- twostage(aout,data=data,clusters=nclusters,theta.des=theta.des,theta=ptheta,var.link=var.link) else tout <- twostage(aout,data=data,clusters=nclusters,theta.des=theta.des,var.link=var.link) if (!is.null(theta.des)) theta <- c(theta.des %*% tout$theta) else theta <- tout$theta ### if (attr(tout, "var.link") == 1) theta <- exp(tout$theta) data$thetades <- c(theta) data$delay <- tout$marginal.trunc data$surv <- tout$marginal.surv dd <- fast.reshape(data,id=clusters) v1 <- dd[,paste(entry,"1",sep="")]; v2 <- dd[,paste(entry,"2",sep="")] time1 <- dd[,paste(exit,"1",sep="")]; time2 <- dd[,paste(exit,"2",sep="")] status1 <- dd[,paste(status,"1",sep="")]; status2 <- dd[,paste(status,"2",sep="")] nn <- nrow(dd) ppv1t2 <- .Call("claytonoakesR",dd$thetades1,rep(0,nn),status2,dd$delay1,dd$surv2,var.link,PACKAGE="mets")$like ppv1t2[status2==0] <- ppv1t2[dd$status2==0]/dd$surv2[status2==0] ppt1v2 <- .Call("claytonoakesR",dd$thetades1,dd$status1,rep(0,nn),dd$surv1,dd$delay2,var.link,PACKAGE="mets")$like ppt1v2[status1==0] <- ppt1v2[status1==0]/dd$surv1[status1==0] dd$weight1 <- c(ppt1v2) dd$weight2 <- c(ppv1t2) nn <- nrow(dd) dd2 <- fast.reshape(dd,labelnum=TRUE) pweight <- dd2$weight dtheta <- sum(abs(tout$theta-ptheta)) dmarg <- sum(abs(beta-pbeta)) if ((dtheta+dmarg) < 0.001) break; ptheta <- tout$theta if (model=="aalen") pbeta <- aout$cum[,-1] else pbeta <- c(aout$gamma,aout$cum[,-1]) } ## }}} if (final.fitting==TRUE) { ## {{{ if (model=="cox.aalen") aout <- cox.aalen(survformula,data=data,weights=1/pweight,n.sim=0,...) else aout <- aalen(survformula,data=data,weights=1/pweight,n.sim=0,...) tout <- twostage(aout,data=data,clusters=nclusters,theta.des=theta.des,var.link=var.link) } ## }}} res <- list(marg=aout,two=tout,marg.weights=pweight,dtheta=dtheta,dmarg=dmarg,model=model) return(res) } ## }}} ##' @export ###twin.dobdata <- function(survformula,data=data,clusters=NULL, ### entry="v",exit="time",status="status") ###{ ## {{{ ##### {{{ adding names of covariates from survival model to data frame if needed ##### adds names that are not in data (typically intercept from additive) model ##### also reducing only to needed covariates ### ###d0 <- data[,c(entry,exit,status,clusters)] ### ###model <- "aalen" ###des <- aalen.des(survformula,data=data,model=model) ###X <- des$X ######med <- des$covnamesX %in% names(data) ### colnames(X) <- des$covnamesX ### d0 <- cbind(d0,X) ### ###data <- d0 ### ###d2 <- fast.reshape(data,id=clusters) ###d2 <- na.omit(d2) ###data <- fast.reshape(d2,numlabel=TRUE) ### ######theta.des <- data.frame(theta.des) ######theta.des$clusters <- data[,clusters] ###### ######t2 <- fast.reshape(theta.des,id=clusters) ######t2 <- na.omit(t2) ######theta.des <- fast.reshape(t2,numlabel=TRUE) ### ###return(data) ###} ### mets/R/twinsim.R0000644000176200001440000000613113623061405013241 0ustar liggesusers##' Simulate twin data from a linear normal ACE/ADE/AE model. ##' ##' @title Simulate twin data ##' @author Klaus K. Holst ##' @export ##' @seealso \code{\link{twinlm}} ##' @keywords models ##' @keywords regression ##' @param nMZ Number of monozygotic twin pairs ##' @param nDZ Number of dizygotic twin pairs ##' @param b1 Effect of covariates (labelled x1,x2,...) of type 1. One ##' distinct covariate value for each twin/individual. ##' @param b2 Effect of covariates (labelled g1,g2,...) of type 2. One ##' covariate value for each twin pair. ##' @param mu Intercept parameter. ##' @param acde Variance of random effects (in the order A,C,D,E) ##' @param randomslope Logical indicating wether to include random slopes of ##' the variance components w.r.t. x1,x2,... ##' @param threshold Treshold used to define binary outcome y0 ##' @param cens Logical variable indicating whether to censor outcome ##' @param wide Logical indicating if wide data format should be returned ##' @param ... Additional arguments parsed on to lower-level functions twinsim <- function(nMZ=100,nDZ=nMZ,b1=c(),b2=c(),mu=0,acde=c(1,1,0,1),randomslope=NULL,threshold=0,cens=FALSE,wide=FALSE,...) { n <- nMZ+nDZ sA <- acde[1]^0.5; sC <- acde[2]^0.5; sD <- acde[3]^0.5; sE <- acde[4]^0.5; A.MZ <- rnorm(nMZ,sd=sA); A.MZ <- cbind(A.MZ,A.MZ) D.MZ <- rnorm(nMZ,sd=sD); D.MZ <- cbind(D.MZ,D.MZ) S2 <- matrix(c(0,1,1,0),2) A.DZ <- sA*rmvn(nDZ,sigma=diag(2)+S2*0.5) D.DZ <- sD*rmvn(nDZ,sigma=diag(2)+S2*0.25) C.MZ <- rnorm(nMZ,sd=sC) C.DZ <- rnorm(nDZ,sd=sC) yMZ <- mu + A.MZ + cbind(C.MZ,C.MZ) + D.MZ + cbind(rnorm(nMZ,sd=sE),rnorm(nMZ,sd=sE)) yDZ <- mu + A.DZ + cbind(C.DZ,C.DZ) + D.DZ + cbind(rnorm(nDZ,sd=sE),rnorm(nDZ,sd=sE)) y <- rbind(yMZ,yDZ) if (length(b1)>0) { x1 <- rmvn(n,sigma=diag(length(b1))) x2 <- rmvn(n,sigma=diag(length(b1))) y <- y+cbind(x1%*%b1,x2%*%b1) } if (length(b2)>0) { g <- rmvn(n,sigma=diag(length(b2))) ge <- g%*%b2 y <- y+cbind(ge,ge) } Cens <- ifelse(cens,rep(Inf,nMZ+nDZ),rnorm(nMZ+nDZ,threshold+1)) d <- data.frame(id=seq(n),y=y,zyg=c(rep("MZ",nMZ),rep("DZ",nDZ)), cens=Cens) vary <- list(c("y1","y2")) vnames <- c("y") colnames(d)[2:3] <- vary[[1]] if (length(b1)>0) { d <- cbind(d,x1=x1,x2=x2); if (length(b1)==1) { colnames(d)[1:2+ncol(d)-2] <- c("x11","x21") } vary <- c(vary,lapply(seq(length(b1)),FUN=function(x) paste(c("x1","x2"),x,sep=""))) vnames <- c(vnames,paste("x",seq_len(length(b1)),sep="")) } if (length(b2)>0) { d <- cbind(d,g=g) } names(vary) <- vnames colnames(d) <- sub(".","",colnames(d),fixed=TRUE) if (wide) return(d) dd <- fast.reshape(d,idname="id",varying=vary) dd$status <- dd$ythreshold) dd$y1 <- (dd$y>threshold & dd$y1 mcontr2 <- !x$model$eqmarg && x$model$blen>2 mcontr1 <- x$model$eqmarg & x$model$blen>1 if (corcontr || mcontr2 || mcontr1 || x$contrast) cat("\nContrast:\n") if (corcontr || x$contrast) { cat("\tDependence ", x$par[[i]]$corref, "\n") } if (mcontr2 || (x$contrast & !x$model$eqmarg)) { cat("\tMean 1 ", x$par[[i]]$mref1, "\n") cat("\tMean 2 ", x$par[[i]]$mref2, "\n") } if (mcontr1 || (x$contrast & x$model$eqmarg)) cat("\tMean ", x$par[[i]]$mref1, "\n") if (!is.null(x$varcomp)) { cat("\n") ##res <- x$varcomp res <- c() P <- x$prob[seq(x$nstat)+x$nstat*(i-1),,drop=FALSE] if (!is.null(P)) { res <- rbind(res,P) } idx <- unlist(sapply(c("Concordance","Marginal","P\\(Y"),function(x) grep(x,rownames(res)))) idx2 <- setdiff(seq(nrow(res)),idx) res2 <- rbind(res[idx2,],rep(NA,ncol(res)),res[idx,]) nn <- rownames(res2) rownames(res2) <- unlist(lapply(nn,function(x) gsub(paste("c",i,":",sep=""),"",x))) print(RoundMat(res2,digits=digits,na=FALSE),quote=FALSE) } } if (!is.null(x$time)) { cat("\n") cat("Event of interest before time ", x$time, "\n", sep="") } } mets/R/aalenfrailty.R0000644000176200001440000001065013623061405014223 0ustar liggesusers ##' Additive hazards model with (gamma) frailty ##' ##' Aalen frailty model ##' @title Aalen frailty model ##' @param time Time variable ##' @param status Status variable (0,1) ##' @param X Covariate design matrix ##' @param id cluster variable ##' @param theta list of thetas (returns score evaluated here), or ##' starting point for optimization (defaults to magic number 0.1) ##' @param B (optional) Cumulative coefficients (update theta by fixing B) ##' @param ... Additional arguments to lower level functions ##' @return Parameter estimates ##' @author Klaus K. Holst ##' @export ##' @examples ##' library("timereg") ##' dd <- simAalenFrailty(5000) ##' f <- ~1##+x ##' X <- model.matrix(f,dd) ## design matrix for non-parametric terms ##' system.time(out<-aalen(update(f,Surv(time,status)~.),dd,n.sim=0,robust=0)) ##' dix <- which(dd$status==1) ##' t1 <- system.time(bb <- .Call("Bhat",as.integer(dd$status), ##' X,0.2,as.integer(dd$id),NULL,NULL, ##' PACKAGE="mets")) ##' spec <- 1 ##' ##plot(out,spec=spec) ##' ## plot(dd$time[dix],bb$B2[,spec],col="red",type="s", ##' ## ylim=c(0,max(dd$time)*c(beta0,beta)[spec])) ##' ## abline(a=0,b=c(beta0,beta)[spec]) ##' ##' ##' ##' \dontrun{ ##' thetas <- seq(0.1,2,length.out=10) ##' Us <- unlist(aalenfrailty(dd$time,dd$status,X,dd$id,as.list(thetas))) ##' ##plot(thetas,Us,type="l",ylim=c(-.5,1)); abline(h=0,lty=2); abline(v=theta,lty=2) ##' op <- aalenfrailty(dd$time,dd$status,X,dd$id) ##' op ##' } aalenfrailty <- function(time,status,X,id,theta,B=NULL,...) { dix <- which(status==1) cc <- cluster.index(id) ncluster <- length(cc$clusters) U <- function(theta,indiv=FALSE,Bhat=FALSE) { if (is.null(B)) { BB <- .Call("Bhat",as.integer(status),X,theta,as.integer(cc$clusters), cc$idclust,as.integer(cc$cluster.size),PACKAGE="mets")$B2 } else { BB <- B*time[dix] } Hij0 <- apply(X[dix,,drop=FALSE]*BB,1,sum) Hij <- Cpred(cbind(time[dix],Hij0),time)[,2,drop=FALSE] ## if (is.na(Hij[1])) browser() res <- .Call("Uhat",as.integer(status),Hij,theta, cc$idclust,as.integer(cc$cluster.size),PACKAGE="mets") if (!indiv) res <- mean(res,na.rm=TRUE) if (Bhat) attributes(res)$B <- BB return(res) } if (missing(theta)) theta <- 0.1 if (is.list(theta)) { cc <- lapply(theta,function(x) U(x,Bhat=TRUE,...)) BB <- Reduce("cbind",lapply(cc,function(x) attributes(x)$B)) UU <- unlist(lapply(cc,function(x) x[1])) res <- list(U=UU, B=BB, time=time, dix=dix, X=X, id=id, status=status) return(res) } op <- nlminb(theta,function(x) U(x)^2) uu <- U(op$par,TRUE) du <- numDeriv::grad(U,op$par) return(list(theta=op$par, sd=(mean(uu^2)/du^2/ncluster)^0.5)) } ##' Simulate observations from Aalen Frailty model with Gamma ##' distributed frailty and constant intensity. ##' ##' @title Simulate from the Aalen Frailty model ##' @param n Number of observations in each cluster ##' @param theta Dependence paramter (variance of frailty) ##' @param K Number of clusters ##' @param beta0 Baseline (intercept) ##' @param beta Effect (log hazard ratio) of covariate ##' @param cens Censoring rate ##' @param cuts time cuts ##' @param ... Additional arguments ##' @author Klaus K. Holst ##' @export simAalenFrailty <- function(n=5e3,theta=0.3,K=2,beta0=1.5,beta=1,cens=1.5,cuts=0,...) { ## beta0 (constant baseline intensity) ## beta (covariate effect) if (length(beta0)!=length(cuts)) stop("Number of time-intervals (cuts) does not agree with number of rate parameters (beta0)") cuts <- c(cuts,Inf) id <- rep(seq(n/K),each=K) ## Cluster indicator x <- rbinom(n,1,0.5) ## Binary covariate Z <- rep(rgamma(n/K,1/theta,1/theta),each=K) ## Frailty, mean 1, var theta Ai <- function() { vals <- matrix(0,ncol=length(beta0),nrow=n) ival <- numeric(n) for (i in seq(length(beta0))) { u <- -log(runif(n)) ##rexp(n,1) vals[,i] <- cuts[i] + u/(beta0[i]+beta*x)/Z idx <- which(vals[,i]<=cuts[i+1] & ival==0) ival[idx] <- vals[idx,i] } ival } dat <- data.frame(time=Ai(), x=x, status=1, id=id, Z=Z) if (cens==0) cens <- Inf else cens <- -log(runif(n))/cens dat$status <- (dat$time<=cens)*1 dat$time <- apply(cbind(dat$time,cens),1,min) dat <- dat[order(dat$time),] ## order after event/censoring time return(dat) } mets/R/Dbvn.R0000644000176200001440000000237113623061405012442 0ustar liggesusers##' Derivatives of the bivariate normal cumulative distribution function ##' ##' @title Derivatives of the bivariate normal cumulative distribution function ##' @param p Parameter vector ##' @param design Design function with defines mean, derivative of mean, variance, ##' and derivative of variance with respect to the parameter p ##' @param Y column vector where the CDF is evaluated ##' @author Klaus K. Holst ##' @usage ##' Dbvn(p,design=function(p,...) { ##' return(list(mu=cbind(p[1],p[1]), ##' dmu=cbind(1,1), ##' S=matrix(c(p[2],p[3],p[3],p[4]),ncol=2), ##' dS=rbind(c(1,0,0,0),c(0,1,1,0),c(0,0,0,1))) )}, ##' Y=cbind(0,0)) ##' @export Dbvn <- function(p,design=function(p,...) { return(list(mu=cbind(p[1],p[1]), dmu=cbind(1,1), S=matrix(c(p[2],p[3],p[3],p[4]),ncol=2), dS=rbind(c(1,0,0,0),c(0,1,1,0),c(0,0,0,1))) )}, Y=cbind(0,0)) { mS <- design(p) U0 <- with(mS,.Call("biprobit0", mu, S,dS,Y,dmu,NULL,FALSE,FALSE, PACKAGE="mets")); return(c(U0,mS)) } mets/R/prop-odds.R0000644000176200001440000000165613623061405013465 0ustar liggesuserspropOdds <- function(time,status,X, ...) { id <- 1:length(time) theta <- 1 dix <- which(status==1) fB <- fast.approx(time[dix],time) cc <- cluster.index(id) ncluster <- length(cc$clusters) U <- function(beta,indiv=FALSE) { B <- .Call("pBhat",as.integer(status),X,beta,as.integer(cc$clusters), cc$idclust,as.integer(cc$cluster.size),PACKAGE="mets")$B Ba <- B[fB$pos+1,,drop=FALSE] Hij <- as.vector(X*Ba) res <- .Call("Uhat",as.integer(status),Hij,theta, cc$idclust,as.integer(cc$cluster.size),PACKAGE="mets") if (!indiv) res <- mean(res) res } if (missing(theta)) theta <- 0.1 if (is.list(theta)) return(lapply(theta,function(x) U(x,...))) op <- nlminb(theta,function(x) U(x)^2) uu <- U(op$par,TRUE) du <- numDeriv::grad(U,op$par) return(list(theta=op$par, sd=(mean(uu^2)/du^2/ncluster)^0.5)) } mets/R/fastreshape.R0000644000176200001440000004115313623061405014057 0ustar liggesusers##' @export dreshape <- function(data,...) fast.reshape(data,...) ##' Fast reshape ##' ##' Fast reshape/tranpose of data ##' @param data data.frame or matrix ##' @param varying Vector of prefix-names of the time varying variables. Optional for Long->Wide reshaping. ##' @param id id-variable. If omitted then reshape Wide->Long. ##' @param num Optional number/time variable ##' @param sep String seperating prefix-name with number/time ##' @param keep Vector of column names to keep ##' @param idname Name of id-variable (Wide->Long) ##' @param numname Name of number-variable (Wide->Long) ##' @param factor If true all factors are kept (otherwise treated as character) ##' @param idcombine If TRUE and \code{id} is vector of several variables, the unique id is combined from all the variables. ##' Otherwise the first variable is only used as identifier. ##' @param labelnum If TRUE varying variables in wide format (going from long->wide) are labeled 1,2,3,... otherwise use 'num' variable. In long-format (going from wide->long) varying variables matching 'varying' prefix are only selected if their postfix is a number. ##' @param labels Optional labels for the number variable ##' @param regex Use regular expressions ##' @param dropid Drop id in long format (default FALSE) ##' @param ... Optional additional arguments ##' @author Thomas Scheike, Klaus K. Holst ##' @aliases fast.reshape dreshape ##' @export ##' @examples ##' library("lava") ##' m <- lvm(c(y1,y2,y3,y4)~x) ##' d <- sim(m,5) ##' d ##' fast.reshape(d,"y") ##' fast.reshape(fast.reshape(d,"y"),id="id") ##' ##' ##### From wide-format ##' (dd <- fast.reshape(d,"y")) ##' ## Same with explicit setting new id and number variable/column names ##' ## and seperator "" (default) and dropping x ##' fast.reshape(d,"y",idname="a",timevar="b",sep="",keep=c()) ##' ## Same with 'reshape' list-syntax ##' fast.reshape(d,list(c("y1","y2","y3","y4")),labelnum=TRUE) ##' ##' ##### From long-format ##' fast.reshape(dd,id="id") ##' ## Restrict set up within-cluster varying variables ##' fast.reshape(dd,"y",id="id") ##' fast.reshape(dd,"y",id="id",keep="x",sep=".") ##' ##' ##### ##' x <- data.frame(id=c(5,5,6,6,7),y=1:5,x=1:5,tv=c(1,2,2,1,2)) ##' x ##' (xw <- fast.reshape(x,id="id")) ##' (xl <- fast.reshape(xw,c("y","x"),idname="id2",keep=c())) ##' (xl <- fast.reshape(xw,c("y","x","tv"))) ##' (xw2 <- fast.reshape(xl,id="id",num="num")) ##' fast.reshape(xw2,c("y","x"),idname="id") ##' ##' ### more generally: ##' ### varying=list(c("ym","yf","yb1","yb2"), c("zm","zf","zb1","zb2")) ##' ### varying=list(c("ym","yf","yb1","yb2"))) ##' ##' ##### Family cluster example ##' d <- mets:::simBinFam(3) ##' d ##' fast.reshape(d,var="y") ##' fast.reshape(d,varying=list(c("ym","yf","yb1","yb2"))) ##' ##' d <- sim(lvm(~y1+y2+ya),10) ##' d ##' (dd <- fast.reshape(d,"y")) ##' fast.reshape(d,"y",labelnum=TRUE) ##' fast.reshape(dd,id="id",num="num") ##' fast.reshape(dd,id="id",num="num",labelnum=TRUE) ##' fast.reshape(d,c(a="y"),labelnum=TRUE) ## New column name ##' ##' ##' ##### Unbalanced data ##' m <- lvm(c(y1,y2,y3,y4)~ x+z1+z3+z5) ##' d <- sim(m,3) ##' d ##' fast.reshape(d,c("y","z")) ##' ##' ##### not-varying syntax: ##' fast.reshape(d,-c("x")) ##' ##' ##### Automatically define varying variables from trailing digits ##' fast.reshape(d) ##' ##' ##### Prostate cancer example ##' data(prt) ##' head(prtw <- fast.reshape(prt,"cancer",id="id")) ##' ftable(cancer1~cancer2,data=prtw) ##' rm(prtw) fast.reshape <- function(data,varying,id,num,sep="",keep, idname="id",numname="num",factor=FALSE, idcombine=TRUE,labelnum=FALSE,labels, regex=mets.options()$regex, dropid=FALSE, ...) { if (!is.data.frame(data) & is.list(data)) { data <- as.data.frame(data) } else { if (NCOL(data)==1) data <- cbind(data) } nn <- colnames(data) if (!missing(varying)) { varsubst <- substitute(varying) if (as.character(varsubst)[1]=="-") { notvarying <- varsubst[[-1]] vars0 <- setdiff(nn,eval(notvarying,parent.frame())) ##numstr <- gsub("([1-9]\\d+)$","",vars0) ##numstr_sanspre0 <- gsub("(^0+)",num) varying <- unique(gsub("([1-9]|[1-9]\\d+)$","",vars0)) } if (!missing(id)) varying <- setdiff(varying,id) if (!missing(num)) varying <- setdiff(varying,num) } if (missing(id)) { ## reshape from wide to long format. nsep <- nchar(sep) if (missing(varying)) {#stop("Prefix of time-varying variables needed") ## Find all variable names with trailing digits (and leading zeros) vars0 <- grep("([1-9]|[1-9]\\d+)$",nn); varying <- unique(gsub("([1-9]|[1-9]\\d+)$","",nn[vars0])) } if (is.list(varying)) { orig <- varying for (i in seq_along(varying)) { elem <- varying[[i]] if (is.numeric(elem[i])) { varying[[i]] <- colnames(data)[elem] } if (is.character(elem[i])) { ii <- elem%in%colnames(data) if (!all(ii)) { newelem <- c() for (j in seq_along(elem)) { if (ii[j]) newelem <- c(newelem,elem[j]) else { if (!regex) elem[j] <- glob2rx(elem[j]) newelem <- c(newelem, grep(elem[j],colnames(data),value=TRUE)) } } varying[[i]] <- newelem } } } } ## nl <- as.list(seq_along(data)); names(nl) <- nn ## varying <- eval(substitute(varying),nl,parent.frame()) vnames <- NULL ncvar <- sapply(varying,nchar) newlist <- c() numlev <- TRUE all_levels <- c() thelevels <- c() if (!is.list(varying)) { for (i in seq_len(length(varying))) { ii <- which(varying[i]==substr(nn,1,ncvar[i])) thelevel <- substring(nn[ii],ncvar[i]+1+nsep) if (labelnum) { ii0 <- suppressWarnings(which(!is.na(as.numeric(thelevel)))) ii <- ii[ii0] thelevel <- thelevel[ii0] } all_levels <- union(all_levels,thelevel) thelevels <- c(thelevels,list(thelevel)) suppressWarnings(tt <- as.numeric(thelevel)) newlist <- c(newlist,list(nn[ii[order(tt)]])) } len <- unlist(lapply(newlist,length)) for (i in seq_len(length(varying))) { if (len[i]1) || !all(classes%in%c("numeric","logical","integer","matrix","factor","character"))) { ## e.g. Surv columns oldreshape <- TRUE } ## else { ## chars <- which(classes%in%c("character")) ## factors <- which(classes%in%c("factor")) ## for (j in chars) data[,j] <- as.factor(data[,j]) ## if (length(c(chars,factors))>0) { ## for (k in varying) { ## if (any(nn[c(chars,factors)]%in%k)) { ## lev <- lapply(data[1,k],levels) ## allsame <- unlist(lapply(lev,function(x) ## identical(x,lev[[1]]))) ## if (!all(allsame)) ## for (j in k) data[,j] <- factor(data[,j],levels=lev) ## } ## } ## classes[chars] <- "factor" ## D0 <- data[1,,drop=FALSE] ## } ## data <- data.matrix(data) ## } } if (is.null(vnames)) { vnames <- unlist(lapply(varying,function(x) x[1])) if (!is.null(names(vnames))) vnames <- names(vnames) } if (oldreshape) { ## Fall-back to stats::reshape return( structure(reshape(as.data.frame(data),varying=varying,direction="long",v.names=vnames,timevar=numname,idvar=idname,...), class=c("fast.reshape","data.frame"), direction="wide", varying=varying)) } fixed <- setdiff(nn,unlist(c(varying,numname))) if (!missing(keep)) fixed <- intersect(fixed,c(keep,idname,numname)) nfixed <- length(fixed) nvarying <- length(varying) nclusts <- unlist(lapply(varying,length)) ## nclust <- length(varying[[1]]) nclust <- max(nclusts) if (any(nclusts!=nclust)) stop("Different length of varying vectors!") data <- data[,c(fixed,unlist(varying)),drop=FALSE] long <- as.data.frame(.Call("FastLong2", idata=data, inclust=as.integer(nclust), as.integer(nfixed), as.integer(nvarying),PACKAGE="mets" )); if (numname%in%fixed) { while (numname%in%c(fixed)) numname <- paste(numname,"_",sep="") } if (idname%in%fixed) { long <- long[,-(ncol(long)-1)] cnames <- c(fixed,vnames,numname) } else { cnames <- c(fixed,vnames,idname,numname) } ## while (idname%in%c(fixed,vnames,numname)) idname <- paste(idname,"_",sep="") ## while (numname%in%c(fixed,vnames)) numname <- paste(numname,"_",sep="") colnames(long) <- cnames if (!numlev) { long[,numname] <- base::factor(long[,numname],labels=thelevels) } else { if (!identical(order(thelevels),thelevels)) long[,numname] <- thelevels[long[,numname]] } if (is_df && factor) { ## Recreate classes vars.orig <- c(fixed,unlist(lapply(varying,function(x) x[1]))) vars.new <- c(fixed,vnames) factors <- which("factor"==classes[vars.orig]) lev <- lapply(data[1,factors],levels) count <- 0 for (i in factors) { count <- count+1 long[,vars.new[i]] <- base::factor(long[,vars.new[i]],levels=lev[[count]]) } } if (dropid) { ii <- which(colnames(long)%in%c(idname)) ##,numname long <- long[,-ii,drop=FALSE] } return( structure(long, class=c("fast.reshape","data.frame"), type="wide", varying=varying)) } ################################################## ### Long to wide format: ################################################## numvar <- idvar <- NULL if (is.character(id)) { idvar <- id if (length(id)==1) { id <- data[,idvar,drop=TRUE] } else { if (idcombine) id <- interaction(as.data.frame(data[,idvar,drop=FALSE]),drop=TRUE) else id <- data[,idvar[1],drop=TRUE] } } else { if (length(id)!=nrow(data)) stop("Length of ids and data-set does not agree") } unum <- NULL if (!missing(num) && !is.null(num)) { if (is.character(num)) { numvar <- num if (is.character(data[1,num,drop=TRUE])) { data[,num] <- as.factor(data[,num,drop=TRUE]) } num <- as.integer(data[,num,drop=TRUE]) if (!labelnum) unum <- sort(unique(data[,numvar,drop=TRUE])) } else { if (length(num)!=nrow(data)) stop("Length of time and data-set does not agree") if (!labelnum) unum <- unique(num) } } else { num <- NULL } if (any(nn=="")) data <- data.frame(data) clustud <- cluster.index(id,num=num) maxclust <- clustud$maxclust idclust <- clustud$idclust obs1 <- clustud$firstclustid+1 ## as.vector(apply(idclust,1,function(x) na.omit(x)[1]))+1 if (!is.null(numvar)) { ii <- which(colnames(data)==numvar) data <- data[,-ii,drop=FALSE] } if (!missing(keep)) { keepers <- c(keep,idvar) if (!missing(varying)) keepers <- c(keepers,varying) ii <- which(colnames(data)%in%keepers) data <- data[,ii,drop=FALSE] } if (missing(varying)) varying <- setdiff(colnames(data),c(idvar)) vidx <- match(varying,colnames(data)) N <- nrow(idclust) p <- length(varying) P <- NCOL(data) fixidx <- setdiff(seq(P),vidx) if (is.matrix(data) || (all(apply(data[1,,drop=FALSE],2,is.numeric)) & length(unlist(data[1,]))==length(data[1,]) )) { ## Everything numeric - we can work with matrices dataw <- matrix(NA, nrow = N, ncol = p * (maxclust-1) + ncol(data)) dataw[,fixidx] <- as.matrix(data[obs1,fixidx,drop=FALSE]) mnames <- colnames(data) if (!is.null(unum)) { mnames[vidx] <- paste(mnames[vidx],unum[1],sep=sep) } else { mnames[vidx] <- paste(mnames[vidx],1,sep=sep) } if (p>0) { for (i in seq_len(maxclust)) { idx <- idclust[, i] + 1 pos <- vidx if (i>1) { pos <- P+seq(p)+p*(i-2) } dataw[which(!is.na(idx)), pos] <- as.matrix(data[na.omit(idx),vidx,drop=FALSE]) } if (!is.null(unum)) { postn <- unum[-1] } else { postn <- seq_len(maxclust-1)+1 } ##if (is.null(numname)) postn <- idlev[postn] mnames <- c(mnames, as.vector(t(outer(postn,varying,function(x,y) paste(y,x,sep=sep))))) } colnames(dataw) <- mnames return(structure(as.data.frame(dataw),class=c("fast.reshape","data.frame"), varying=varying,direction="long")) } ## Potentially slower with data.frame where we use cbind for (i in seq_len(maxclust)) { if (i==1) { dataw <- data[obs1,,drop=FALSE] mnames <- names(data); dataw[,vidx] <- data[idclust[,i]+1,vidx,drop=FALSE] if (!is.null(unum)) mnames[vidx] <- paste(varying,sep,unum[i],sep="") else mnames[vidx] <- paste(mnames[vidx],sep,i,sep="") } else { dataw <- cbind(dataw,data[idclust[,i]+1,varying,drop=FALSE]) if (!is.null(unum)) mnames <- c(mnames,paste(varying,sep,unum[i],sep="")) else mnames <- c(mnames,paste(varying,sep,i,sep="")) } } names(dataw) <- mnames return(structure(dataw,class=c("fast.reshape","data.frame"), varying=varying,type="long")) } simple.reshape <- function (data, id = "id", num = NULL) { cud <- cluster.index(data[, c(id)], num = num, Rindex = 1) N <- nrow(cud$idclust) p <- ncol(data) dataw <- matrix(NA, nrow = N, ncol = p * cud$maxclust) for (i in seq_len(cud$maxclust)) { dataw[, seq(p) + (i - 1) * p] <- as.matrix(data[cud$idclust[, i] + 1, ]) } colnames(dataw) <- paste(names(data), rep(seq_len(cud$maxclust), each = p), sep = ".") return(dataw) } mets/R/RcppExports.R0000644000176200001440000000111313623061405014033 0ustar liggesusers# Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 .ApplyBy2 <- function(idata, icluster, F, Env, Argument = "x", Columnwise = 0L, Reduce = 0L, epsilon = 1.0e-16) { .Call(`_mets_ApplyBy2`, idata, icluster, F, Env, Argument, Columnwise, Reduce, epsilon) } .ApplyBy <- function(idata, icluster, f) { .Call(`_mets_ApplyBy`, idata, icluster, f) } # Register entry points for exported C++ functions methods::setLoadAction(function(ns) { .Call('_mets_RcppExport_registerCCallable', PACKAGE = 'mets') }) mets/R/tetrachor.R0000644000176200001440000000532613623061405013547 0ustar liggesusers##' @export or2prob <- function(OR,marg) { p1 <- marg[1]; p2 <- marg[2] if (length(marg)==1) p2 <- p1 if (OR==1) { PP <- outer(c(p1,1-p1),c(p2,1-p2)) } else { ## OR (p11*p00)/(p10*p01) = p11*(1+p11-p1-p2)/(p1-p11)*(p2-p11) ## (OR-1)p11^2-(OR(p1+p2)+(1-p1-p2))*p11+OR*p1*p2 = 0 ## (1-OR)p11^2+(OR(p1+p2)+(1-p1-p2))*p11-OR*p1*p2 = 0 a <- (1-OR) b <- 1+(p1+p2)*(OR-1) ac <- -OR*p1*p2*a d <- sqrt(b^2-4*ac) ## Only one solution p11 <- (-b+d)/(2*a) PP <- c(p11,p1-p11,p2-p11) PP <- c(PP,1-sum(PP)) } structure(matrix(PP,2),marg=c(p1,p2)) } ##' Estimate parameters from odds-ratio ##' ##' Calculate tetrachoric correlation of probabilities from odds-ratio ##' @param P Joint probabilities or marginals (if OR is given) ##' @param OR Odds-ratio ##' @param approx If TRUE an approximation of the tetrachoric correlation is used ##' @param ... Additional arguments ##' @export ##' @aliases or2prob tetrachoric ##' @examples ##' tetrachoric(0.3,1.25) # Marginal p1=p2=0.3, OR=2 ##' P <- matrix(c(0.1,0.2,0.2,0.5),2) ##' prod(diag(P))/prod(lava::revdiag(P)) ##' ##mets:::assoc(P) ##' tetrachoric(P) ##' or2prob(2,0.1) ##' or2prob(2,c(0.1,0.2)) tetrachoric <- function(P,OR,approx=0,...) { if (!missing(OR)) { ## Assuming P[1],P[2] is the marginals P <- or2prob(OR,P) p1 <- attributes(P)$marg[1] p2 <- attributes(P)$marg[2] } else { ## Assuming P contains the joint probabilities if (is.vector(P)) { if (length(P)==3) P <- c(P,1-sum(P)) P <- matrix(P,2) } if (!all.equal(sum(P),1)) stop("Not a probability matrix") p1 <- colSums(P)[1] p2 <- rowSums(P)[1] } if (approx>0) { ## Bonnet & Price 2005 k <- (1-abs(p1-p2)/5 - (.5-min(p1,p2))^2)/2 if (missing(OR)) OR <- prod(diag(P))/prod(revdiag(P)) return(cos(pi/(1+OR^k))) } q1 <- qnorm(p1) q2 <- qnorm(p2) lo <- rbind(c(0,0),c(0,-Inf),c(-Inf,0),c(-Inf,-Inf)) hi <- rbind(c(Inf,Inf),c(Inf,0),c(0,Inf),c(0,0)) mu <- cbind(q1,q2)%x%cbind(rep(1,4)) obj <- function(r) { Pr <- pmvn(lower=lo,upper=hi,mu=mu,sigma=r,cor=TRUE) return(mean(abs(P-Pr)^2)) ##(P[1,1]-pmvn(lower=c(0,0),mu=c(q1,q2),sigma=r,cor=TRUE))^2 } optimize(obj,interval=c(-1,1))$minimum } assoc <- function(x,id,...) { N <- sum(x) P <- x if (N!=1) P <- P/N p1 <- colSums(P)[1] p2 <- rowSums(P)[1] OR <- prod(diag(P))/prod(revdiag(P)) rho <- tetrachoric(P) list(P=P, OR=OR, rho=rho) } ## library(vcd) ## data(prt) ## mosaic(cancer ~country*zyg,prt) ## (ftable(cancer ~ country, prt)) ## grouptable(...) mets/R/cifreg.R0000644000176200001440000003332313623061405013011 0ustar liggesusers##' CIF regression ##' ##' CIF logistic for propodds=1 default ##' CIF Fine-Gray (cloglog) regression for propodds=NULL ##' ##' For FG model: ##' \deqn{ ##' \int (X - E ) Y_1(t) w(t) dM_1 ##' } ##' is computed and summed over clusters and returned multiplied with inverse ##' of second derivative as iid.naive ##' ##' The iid decomposition of the beta's, however, also have a censoring term that is also ##' is computed and added to UUiid (still scaled with inverse second derivative) ##' \deqn{ ##' \int (X - E ) Y_1(t) w(t) dM_1 + \int q(s)/p(s) dM_c ##' } ##' and returned as iid ##' ##' ##' @param formula formula with 'Event' outcome ##' @param data data frame ##' @param cause of interest ##' @param cens.code code of censoring ##' @param offset offsets for cox model ##' @param weights weights for Cox score equations ##' @param Gc censoring weights for time argument, default is to calculate these with a Kaplan-Meier estimator, should then give G_c(T_i-) ##' @param propodds 1 is logistic model, NULL is fine-gray model ##' @param ... Additional arguments to lower level funtions ##' @author Thomas Scheike ##' @examples ##' ## data with no ties ##' data(bmt,package="timereg") ##' bmt$time <- bmt$time+runif(nrow(bmt))*0.01 ##' bmt$id <- 1:nrow(bmt) ##' ##' ## logistic link OR interpretation ##' ll=cifreg(Event(time,cause)~tcell+platelet+age,data=bmt,cause=1) ##' bplot(ll) ##' nd <- data.frame(tcell=c(1,0),platelet=0,age=0) ##' pll <- predict(ll,nd) ##' plot(pll) ##' ##' ## Fine-Gray model ##' llfg=cifreg(Event(time,cause)~tcell+platelet+age,data=bmt,cause=1,propodds=NULL) ##' bplot(ll) ##' nd <- data.frame(tcell=c(1,0),platelet=0,age=0) ##' pll <- predict(ll,nd) ##' plot(pll) ##' ##' @export cifreg <- function(formula,data=data,cause=1,cens.code=0, weights=NULL,offset=NULL,Gc=NULL,propodds=1,...) {# {{{ cl <- match.call()# {{{ m <- match.call(expand.dots = TRUE)[1:3] special <- c("strata", "cluster","offset") Terms <- terms(formula, special, data = data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) Y <- model.extract(m, "response") if (class(Y)!="Event") stop("Expected a 'Event'-object") if (ncol(Y)==2) { exit <- Y[,1] entry <- NULL ## rep(0,nrow(Y)) status <- Y[,2] } else { entry <- Y[,1] exit <- Y[,2] status <- Y[,3] } id <- strata <- NULL if (!is.null(attributes(Terms)$specials$cluster)) { ts <- survival::untangle.specials(Terms, "cluster") pos.cluster <- ts$terms Terms <- Terms[-ts$terms] id <- m[[ts$vars]] } else pos.cluster <- NULL if (!is.null(stratapos <- attributes(Terms)$specials$strata)) { ts <- survival::untangle.specials(Terms, "strata") pos.strata <- ts$terms Terms <- Terms[-ts$terms] strata <- m[[ts$vars]] strata.name <- ts$vars } else { strata.name <- NULL; pos.strata <- NULL} if (!is.null(offsetpos <- attributes(Terms)$specials$offset)) { ts <- survival::untangle.specials(Terms, "offset") Terms <- Terms[-ts$terms] offset <- m[[ts$vars]] } X <- model.matrix(Terms, m) if (!is.null(intpos <- attributes(Terms)$intercept)) X <- X[,-intpos,drop=FALSE] if (ncol(X)==0) X <- matrix(nrow=0,ncol=0) ### if (!is.null(id)) { ### ids <- sort(unique(id)) ### nid <- length(ids) ### if (is.numeric(id)) id <- fast.approx(ids,id)-1 else { ### id <- as.integer(factor(id,labels=seq(nid)))-1 ### } ### } else id <- as.integer(seq_along(exit))-1; ### ### id from call coded as numeric 1 -> ### id.orig <- id; # }}} res <- c(cifreg01(data,X,exit,status,id,strata,offset,weights,strata.name, cause=cause,cens.code=cens.code,Gc=Gc,propodds=propodds,...), list(call=cl,model.frame=m,formula=formula,strata.pos=pos.strata,cluster.pos=pos.cluster) ) class(res) <- c("phreg","cif.reg") return(res) }# }}} cifreg01 <- function(data,X,exit,status,id=NULL,strata=NULL,offset=NULL,weights=NULL, strata.name=NULL,beta,stderr=TRUE,method="NR",no.opt=FALSE,propodds=1,profile=0, case.weights=NULL,cause=1,cens.code=0,Gc=NULL,...) {# {{{ ## setting up weights, strata, beta and so forth before the action starts# {{{ p <- ncol(X) if (missing(beta)) beta <- rep(0,p) if (p==0) X <- cbind(rep(0,length(exit))) cause.jumps <- which(status==cause) max.jump <- max(exit[cause.jumps]) other <- which((!(status %in% c(cens.code,cause)) ) & (exit< max.jump)) entry <- NULL n <- length(exit) trunc <- (!is.null(entry)) if (is.null(strata)) { strata <- rep(0,length(exit)); nstrata <- 1; strata.level <- NULL; } else { strata.level <- levels(strata) ustrata <- sort(unique(strata)) nstrata <- length(ustrata) strata.values <- ustrata if (is.numeric(strata)) strata <- fast.approx(ustrata,strata)-1 else { strata <- as.integer(factor(strata,labels=seq(nstrata)))-1 } } if (!trunc) entry <- rep(0,length(exit)) if (is.null(offset)) offset <- rep(0,length(exit)) if (is.null(weights)) weights <- rep(1,length(exit)) if (is.null(case.weights)) case.weights <- rep(1,length(exit)) strata.call <- strata Zcall <- matrix(1,1,1) ## to not use for ZX products when Z is not given if (!is.null(id)) { ids <- unique(id) nid <- length(ids) if (is.numeric(id)) id <- fast.approx(ids,id)-1 else { id <- as.integer(factor(id,labels=seq(nid)))-1 } } else id <- as.integer(seq_along(entry))-1; ## orginal id coding into integers 1:... id.orig <- id+1; # }}} ### censoring weights constructed whereC <- which(status==cens.code) time <- exit if (is.null(Gc)) { cens.model <- km(Surv(exit,status==cens.code)~+1,data=data) wpredS <- fast.approx(c(0,cens.model$time),exit,type="left") ### wpredS <- timereg:::sindex.prodlim(c(0,cens.model$time),exit) Stime <- c(1,cens.model$surv)[wpredS] } else { if (length(whereC)>0) Ctimes <- sort(unique(exit[whereC])) else Ctimes <- 0 Stime <- Gc } ## setting up all jumps of type "cause", need S0, S1, S2 at jumps of "cause" stat1 <- 1*(status==cause) xx2 <- .Call("FastCoxPrepStrata",entry,exit,stat1,X,id, trunc,strata,weights,offset,Zcall,case.weights,PACKAGE="mets") xx2$nstrata <- nstrata jumps <- xx2$jumps+1 jumptimes <- xx2$time[jumps] Xj <- xx2$X[jumps,,drop=FALSE] ## G(T_j-) at jumps of type "cause" if (length(whereC)>0) { whereJ <- fast.approx(c(0,cens.model$time),jumptimes,type="left") Gjumps <- c(1,cens.model$surv)[whereJ] } else { Gjumps <- rep(1,length(jumptimes)) } ## computing terms for those experiencing another cause, need S0, S1, S2 if ( length(other)>=1) {# {{{ trunc <- TRUE weightso <- 1/Stime[other] timeoo <- rep(max(exit)+1,length(other)) statuso <- rep(0,length(other)) Xo <- X[other,,drop=FALSE] offseto <- offset[other] entryo <- exit[other] ido <- id[other] stratao <- strata[other] ### xx <- .Call("FastCoxPrepStrata",entryo,timeoo,statuso,Xo, ido,trunc,stratao,weightso,offseto,Zcall,case.weights[other],PACKAGE="mets") xx$nstrata <- nstrata timeo <- xx$time ## use right here because T_jump is larger than the T_(other) som står i listen ## timeo where <- fast.approx(c(0,timeo),jumptimes,type="right") }# }}} obj <- function(pp,all=FALSE) {# {{{ if (length(other)>=1) { rr <- c(xx$sign*exp(xx$X %*% pp + xx$offset)*xx$weights) S0no <- revcumsumstrata(rr,xx$strata,xx$nstrata) S1no <- apply(xx$X*rr,2,revcumsumstrata,xx$strata,xx$nstrata); S2no <- apply(xx$XX*rr,2,revcumsumstrata,xx$strata,xx$nstrata); ## look at jumptimes S0no <- c(0,S0no)[where] S1no <- rbind(0,S1no)[where,,drop=FALSE] S2no <- rbind(0,S2no)[where,,drop=FALSE] } else { Gjumps <- S0no <- S1no <- S2no <- 0} rr2 <- c(xx2$sign*exp(xx2$X %*% pp + xx2$offset)*xx2$weights) rr2now <- c(xx2$sign*exp(xx2$X %*% pp + xx2$offset)) S0oo <- revcumsumstrata(rr2,xx2$strata,xx2$nstrata) S1oo <- apply(xx2$X*rr2,2,revcumsumstrata,xx2$strata,xx2$nstrata); S2oo <- apply(xx2$XX*rr2,2,revcumsumstrata,xx2$strata,xx2$nstrata); S0oo <- S0oo[jumps,] S1oo <- S1oo[jumps,,drop=FALSE] S2oo <- S2oo[jumps,,drop=FALSE] S0 <- c(S0oo+S0no*Gjumps) E <- (S1oo+S1no*Gjumps)/S0 weightsJ <- xx2$weights[jumps] caseweightsJ <- xx2$caseweights[jumps] strataJ <- xx2$strata[jumps] rr2now <- rr2now[jumps] U <- (Xj-E) ploglik <- (log(rr2now)-log(S0))*weightsJ*caseweightsJ; if (!is.null(propodds)) { pow <- c(.Call("cumsumstrataPOR",weightsJ,S0,strataJ,nstrata,propodds,rr2now,PACKAGE="mets")$pow); DLam <-.Call("DLambetaR",weightsJ,S0,E,Xj,strataJ,nstrata,propodds,rr2now,PACKAGE="mets")$res; Dwbeta <- DLam*rr2now+(pow-1)*Xj DUadj <- .Call("vecMatMat",Dwbeta,U,PACKAGE="mets")$vXZ } Ut <- caseweightsJ*weightsJ*U ## E^2, as n x (pxp) Et2 <- .Call("vecMatMat",E,E,PACKAGE="mets")$vXZ S2S0 <- (S2oo+S2no*Gjumps)/S0 DUt <- -(S2S0-Et2) if (!is.null(propodds)) { Ut <- pow*Ut S0 <- S0/pow DUt <- pow*DUt DUt <- DUt+DUadj if (profile==1) { Ut <- Ut+c(ploglik)*Dwbeta ## not implemented DUt <- DUt } ploglik <- pow*ploglik } U <- apply(Ut,2,sum) DUt <- caseweightsJ*weightsJ*DUt DU <- -matrix(apply(DUt,2,sum),p,p) ploglik <- sum(ploglik) out <- list(ploglik=ploglik,gradient=U,hessian=-DU,cox.prep=xx2, hessiantime=DUt,weightsJ=weightsJ,caseweightsJ=caseweightsJ, jumptimes=jumptimes,strata=strataJ,nstrata=nstrata, time=jumptimes,S0=S0/(caseweightsJ*weightsJ),S2S0=S2S0,E=E,U=Ut,X=Xj,Gjumps=Gjumps) if (all) return(out) else with(out,structure(-ploglik, gradient=-gradient, hessian=-hessian)) }# }}} if (length(jumps)==0) no.opt <- TRUE opt <- NULL if (p>0) {# {{{ if (no.opt==FALSE) { if (tolower(method)=="nr") { opt <- lava::NR(beta,obj,...) opt$estimate <- opt$par } else { opt <- nlm(obj,beta,...) opt$method <- "nlm" } cc <- opt$estimate; names(cc) <- colnames(X) if (!stderr) return(cc) val <- c(list(coef=cc),obj(opt$estimate,all=TRUE)) } else val <- c(list(coef=beta),obj(beta,all=TRUE)) } else { val <- obj(0,all=TRUE) }# }}} ### opt <- lava::NR(beta,obj); beta.s <- opt$par beta.s <- val$coef ## getting final S's opt <- obj(beta.s,all=TRUE) ### iid version # {{{ ### iid.phreg ##iid robust phreg Gt <- S0i <- rep(0,length(xx2$strata)) S0i[jumps] <- 1/opt$S0 Z <- xx2$X U <- E <- matrix(0,nrow(Z),p) E[jumps,] <- opt$E U[jumps,] <- opt$U Gt[jumps] <- Gjumps ### cumhazA <- cumsumstratasum(S0i,xx2$strata,xx2$nstrata,type="all") cumhaz <- c(cumhazA$sum) rr <- c(xx2$sign*exp(Z %*% beta.s + xx2$offset)) if (!is.null(propodds)) { cumhazm <- c(cumhazA$lagsum) S0star <- cumsumstrata(rr/(1+rr*cumhazm),xx2$strata,xx2$nstrata) } EdLam0 <- apply(E*S0i,2,cumsumstrata,xx2$strata,xx2$nstrata) ### Martingale as a function of time and for all subjects to handle strata MGt <- U[,drop=FALSE]-(Z*cumhaz-EdLam0)*rr*c(xx2$weights) mid <- max(xx2$id) UU <- apply(MGt,2,sumstrata,xx2$id,mid+1) if (length(other)>=1) { ### T_j for jumps of other type where <- fast.approx(c(0,xx2$time),entryo,type="right") ### rcumhazGt <- c(revcumsumstrata(S0i*Gt,xx2$strata,xx2$nstrata)) rEdLam0Gt <- apply(E*S0i*Gt,2,revcumsumstrata,xx2$strata,xx2$nstrata) ### rcumhazGtx <- c(rcumhazGt[1],rcumhazGt)[where] rEdLam0Gtx <- rbind(rEdLam0Gt[1],rEdLam0Gt)[where,] ### rrx <- c(exp(Xo %*% beta.s + offseto)*weightso) if (!is.null(propodds)) { } ### MGtGtx <- -(Xo*rcumhazGtx-rEdLam0Gtx)*rrx UU2 <- apply(MGtGtx,2,sumstrata,ido,mid+1) UU <- UU+UU2 } # }}} if ((length(other)>=1) & (length(whereC)>0)) { ### Censoring adjustment for jumps of other type {{{ where <- fast.approx(xx2$time,entryo,type="right") rrrx <- rep(0,length(xx2$strata)) rrrx[where] <- rrx Xos <- matrix(0,length(xx2$time),ncol(Xo)); Xos[where,] <- Xo ### Xos <- apply(Xos,2,cumsum) rro <- cumsum(rrrx) ### q <- -(Xos*rcumhazGt-rEdLam0Gt*rro) idloc__ <- id cens.mgs = phreg(Surv(exit,status==0)~+cluster(idloc__),data=data,no.opt=TRUE) cxx <- cens.mgs$cox.prep ### Gt <- S0i <- S0i2 <- rep(0,length(cxx$strata)) S0i[cxx$jumps+1] <- 1/cens.mgs$S0 S0i2[cxx$jumps+1] <- 1/cens.mgs$S0^2 qc <- matrix(0,nrow(q),ncol(q)) ## sort q after censoring times qc[cxx$jumps+1,] <- q[cxx$jumps+1] ### EdLam0q <- apply(qc*S0i2,2,cumsumstrata,cxx$strata,cxx$nstrata) ### Martingale as a function of time and for all subjects to handle strata MGc <- qc[,drop=FALSE]*S0i-EdLam0q MGc <- apply(MGc,2,sumstrata,cxx$id,mid+1) ### print(crossprod(MGc)) ### print(crossprod(UU)) ### print(t(UU) %*% MGc ) # }}} } else MGc <- 0 iH <- - tryCatch(solve(opt$hessian),error= function(e) matrix(0,nrow(opt$hessian),ncol(opt$hessian)) ) Uiid <- (UU+MGc) %*% iH UUiid <- UU %*% iH var1 <- crossprod(UUiid) varm <- crossprod(Uiid) strata <- xx2$strata[jumps] cumhaz <- cbind(opt$time,cumsumstrata(1/opt$S0,strata,nstrata)) colnames(cumhaz) <- c("time","cumhaz") ## SE of estimator ignoring some censoring terms if (no.opt==FALSE & p!=0) { DLambeta.t <- apply(opt$E/c(opt$S0),2,cumsumstrata,strata,nstrata) varbetat <- rowSums((DLambeta.t %*% iH)*DLambeta.t) ### covariance is 0 for cox model ### covv <- apply(covv*DLambeta.t,1,sum) Covariance is "0" by construction } else varbetat <- 0 var.cumhaz <- cumsumstrata(1/opt$S0^2,strata,nstrata)+varbetat se.cumhaz <- cbind(jumptimes,(var.cumhaz)^.5) colnames(se.cumhaz) <- c("time","se.cumhaz") out <- list(coef=beta.s,var=varm,se.coef=diag(varm)^.5,iid.naive=UUiid, iid=Uiid, ihessian=iH,hessian=opt$hessian,var1=var1,se1.coef=diag(var1)^.5, ploglik=opt$ploglik,gradient=opt$gradient, cumhaz=cumhaz, se.cumhaz=se.cumhaz, strata=xx2$strata,nstrata=nstrata,strata.name=strata.name, strata.level=strata.level,propodds=propodds, S0=opt$S0,E=opt$E,S2S0=opt$S2S0,time=opt$time,Ut=opt$U, jumps=jumps,II=iH,exit=exit,p=p,opt=opt,n=nrow(X),nevent=length(jumps) ) return(out) }# }}} mets/R/gof-phreg.R0000644000176200001440000004362213623061405013433 0ustar liggesusers##' GOF for Cox PH regression ##' ##' Cumulative score process residuals for Cox PH regression ##' p-values based on Lin, Wei, Ying resampling. ##' @param object is phreg object ##' @param n.sim number of simulations for score processes ##' @param silent to show timing estimate will be produced for longer jobs ##' @param robust to control wether robust dM_i(t) or dN_i are used for simulations ##' @param ... Additional arguments to lower level funtions ##' @author Thomas Scheike and Klaus K. Holst ##' @export ##' @aliases gof.phreg ##' @examples ##' data(TRACE) ##' ##' m1 <- phreg(Surv(time,status==9)~vf+chf+diabetes,data=TRACE) ##' gg <- gof(m1) ##' par(mfrow=c(1,3)) ##' plot(gg) ##' ##' m1 <- phreg(Surv(time,status==9)~strata(vf)+chf+diabetes,data=TRACE) ##' ## to get Martingale ~ dN based simulations ##' gg <- gof(m1) ##' ##' ## to get Martingale robust simulations, specify cluster in call ##' m1 <- phreg(Surv(time,status==9)~chf+diabetes+cluster(id),data=TRACE) ##' gg <- gof(m1) ##' ##' @export gof.phreg <- function(object,n.sim=1000,silent=1,robust=NULL,...) {# {{{ ### test for proportionality p <- length(object$coef) nnames <- names(object$coef) ii <- solve(object$hessian) jumptimes <- object$jumptimes Pt <- object$hessianttime U <- object$U Pt <- apply(Pt,2,cumsum) Ut <- apply(U,2,cumsum) nd <- nrow(object$U) Pt <- .Call("CubeMat",Pt,ii,PACKAGE="mets")$XXX sup <- matrix(0,n.sim,nrow(ii)) hatti <- matrix(0,nd,nrow(ii)) obs <- apply(abs(Ut),2,max) if (is.null(robust)) if (!is.null(object$id)) robust <- TRUE else robust <- FALSE ### cluster call or robust \hat M_i(t) based if (robust) { xx <- object$cox.prep S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+ 1] <- 1/object$S0 Z <- xx$X ZdN <- U <- E <- matrix(0, nrow(xx$X), object$p) E[xx$jumps + 1, ] <- object$E U[xx$jumps + 1, ] <- object$U cumhaz <- c(cumsumstrata(S0i, xx$strata, xx$nstrata)) EdLam0 <- apply(E * S0i, 2, cumsumstrata, xx$strata, xx$nstrata) rr <- c(xx$sign * exp(Z %*% coef(object) + xx$offset)) MGt <- U[, drop = FALSE] - (Z * cumhaz - EdLam0) * rr * c(xx$weights) ### also weights w <- c(xx$weights) nn <- nrow(Z) tt <- system.time(simcox1<- .Call("PropTestCoxClust",MGt,Pt,w*rr,Z,cumhaz,EdLam0,10,obs,nn,xx$id,xx$strata,xx$nstrata,xx$jumps)) prt <- n.sim*tt[3]/(10*60) if (prt>1 & silent==0) cat(paste("Predicted time minutes",signif(prt,2),"\n")) simcox <- .Call("PropTestCoxClust",MGt,Pt,w*rr,Z,cumhaz,EdLam0,n.sim,obs,nn,xx$id,rep(0,nn),1,xx$jumps) } else { ### no or dN_i based tt <- system.time(simcox1<-.Call("PropTestCox",U,Pt,10,obs,PACKAGE="mets")) prt <- n.sim*tt[3]/(10*60) if (prt>1 & silent==0) cat(paste("Predicted time minutes",signif(prt,2),"\n")) simcox <- .Call("PropTestCox",U,Pt,n.sim,obs,PACKAGE="mets") } sup <- simcox$supUsim res <- cbind(obs,simcox$pval) colnames(res) <- c("Sup|U(t)|","pval") rownames(res) <- nnames if (silent==0) { cat("Cumulative score process test for Proportionality:\n") prmatrix(round(res,digits=2)) } out <- list(jumptimes=object$jumptimes,supUsim=sup,res=res,supU=obs, pvals=simcox$pval,score=Ut,simUt=simcox$simUt,type="prop",robust=robust) class(out) <- "gof.phreg" return(out) }# }}} ##' GOF for Cox covariates in PH regression ##' ##' Cumulative residuals after model matrix for Cox PH regression ##' p-values based on Lin, Wei, Ying resampling. ##' ##' That is, computes ##' \deqn{ ##' U(t) = \int_0^t M^t d \hat M ##' } ##' and resamples its asymptotic distribution. ##' ##' This will show if the residuals are consistent with the model. Typically, ##' M will be a design matrix for the continous covariates that gives for example ##' the quartiles, and then the plot will show if for the different quartiles of the covariate the risk ##' prediction is consistent over time (time x covariate interaction). ##' ##' @param formula formula for cox regression ##' @param data data for model ##' @param offset offset ##' @param weights weights ##' @param modelmatrix matrix for cumulating residuals ##' @param n.sim number of simulations for score processes ##' @param silent to keep it absolutely silent, otherwise timing estimate will be prduced for longer jobs. ##' @param ... Additional arguments to lower level funtions ##' @author Thomas Scheike and Klaus K. Holst ##' @export ##' @examples ##' library(mets) ##' data(TRACE) ##' set.seed(1) ##' TRACEsam <- blocksample(TRACE,idvar="id",replace=FALSE,100) ##' ##' dcut(TRACEsam) <- ~. ##' mm <- model.matrix(~-1+factor(wmicat.4),data=TRACEsam) ##' m1 <- gofM.phreg(Surv(time,status==9)~vf+chf+wmi,data=TRACEsam,modelmatrix=mm) ##' summary(m1) ##' if (interactive()) { ##' par(mfrow=c(2,2)) ##' plot(m1) ##' } ##' ##' m1 <- gofM.phreg(Surv(time,status==9)~strata(vf)+chf+wmi,data=TRACEsam,modelmatrix=mm) ##' summary(m1) ##' ##' ## cumulative sums in covariates, via design matrix mm ##' mm <- cumContr(TRACEsam$wmi,breaks=10,equi=TRUE) ##' m1 <- gofM.phreg(Surv(time,status==9)~strata(vf)+chf+wmi,data=TRACEsam, ##' modelmatrix=mm,silent=0) ##' summary(m1) ##' ##' @export gofM.phreg <- function(formula,data,offset=NULL,weights=NULL,modelmatrix=NULL, n.sim=1000,silent=1,...) {# {{{ if (is.null(modelmatrix)) stop(" must give matrix for cumulating residuals\n"); cox1 <- phreg(formula,data,offset=NULL,weights=NULL,Z=modelmatrix,cumhaz=FALSE,...) offsets <- cox1$X %*% cox1$coef if (!is.null(offset)) offsets <- offsets*offset if (!is.null(cox1$strata)) coxM <- phreg(cox1$model.frame[,1]~modelmatrix+strata(cox1$strata),data,offset=offsets,weights=weights,no.opt=TRUE,cumhaz=FALSE,...) else coxM <- phreg(cox1$model.frame[,1]~modelmatrix,data,offset=offsets,weights=weights,no.opt=TRUE,cumhaz=FALSE,...) nnames <- colnames(modelmatrix) Ut <- apply(coxM$U,2,cumsum) jumptimes <- coxM$jumptimes U <- coxM$U Ubeta <- cox1$U ii <- -solve(cox1$hessian) EE <- .Call("vecMatMat",coxM$E,cox1$E,PACKAGE="mets")$vXZ; ###print(dim(EE)) ###print(cox1$ZX) Pt <- cox1$ZX - EE Pt <- apply(Pt,2,cumsum) betaiid <- t(ii %*% t(Ubeta)) obs <- apply(abs(Ut),2,max) simcox <- .Call("ModelMatrixTestCox",U,Pt,betaiid,n.sim,obs,PACKAGE="mets") sup <- simcox$supUsim res <- cbind(obs,simcox$pval) colnames(res) <- c("Sup_t |U(t)|","pval") rownames(res) <- nnames if (silent==0) { cat("Cumulative score process test for modelmatrix:\n") prmatrix(round(res,digits=2)) } ## pvals efter z i model.matrix sup_z | M(z,tau) | Utlast <- max(abs(tail(Ut,1))) maxlast <- apply(abs(simcox$last),1,max) pval.last <- mean(maxlast>=Utlast) res.last <- matrix(c(Utlast,pval.last),1,2) colnames(res.last) <- c("Sup_z |U(tau,z)|","pval") rownames(res.last) <- "matrixZ" out <- list(jumptimes=jumptimes,supUsim=simcox$supUsim,res=res,supU=obs, pvals=simcox$pval,score=Ut,simUt=simcox$simUt, simUtlast=simcox$last,Utlast=Utlast,pval.last=pval.last, res.last=res.last, type="modelmatrix") class(out) <- "gof.phreg" return(out) }# }}} ##' GOF for Cox covariates in PH regression ##' ##' That is, computes ##' \deqn{ ##' U(z,\tau) = \int_0^\tau M(z)^t d \hat M ##' } ##' and resamples its asymptotic distribution. ##' ##' This will show if the residuals are consistent with the model evaulated in the z covariate. ##' M is here chosen based on a grid (z_1, ..., z_m) and the different columns are \eqn{I(Z_i \leq z_l)}. ##' for \eqn{l=1,...,m}. ##' The process in z is resampled to find extreme values. The time-points of evuluation is by default ##' 50 points, chosen as 2%,4%,..., percentiles of the covariates. ##' ##' The p-value is valid but depends on the chosen grid. When the number of break points are high ##' this will give the orginal test of Lin, Wei and Ying for linearity, that is also computed in ##' the timereg package. ##' ##' @param formula formula for cox regression ##' @param data data for model ##' @param vars which variables to test for linearity ##' @param offset offset ##' @param weights weights ##' @param breaks number of breaks for cumulatives in covarirate direction ##' @param equi equidistant breaks or not ##' @param n.sim number of simulations for score processes ##' @param silent to keep it absolutely silent, otherwise timing estimate will be prduced for longer jobs. ##' @param ... Additional arguments to lower level funtions ##' @author Thomas Scheike and Klaus K. Holst ##' @export ##' @examples ##' library(mets) ##' data(TRACE) ##' set.seed(1) ##' TRACEsam <- blocksample(TRACE,idvar="id",replace=FALSE,100) ##' ##' ## cumulative sums in covariates, via design matrix mm ##' \donttest{ ## Reduce Ex.Timings ##' m1 <- gofZ.phreg(Surv(time,status==9)~strata(vf)+chf+wmi+age,data=TRACEsam) ##' summary(m1) ##' plot(m1,type="z") ##' } ##' @aliases cumContr ##' @export gofZ.phreg <- function(formula,data,vars=NULL,offset=NULL,weights=NULL,breaks=50,equi=FALSE, n.sim=1000,silent=1,...) {# {{{ if (is.null(vars)) { vars <- NULL ## find strata var's yxzf <- procform(formula,x=NULL,z=NULL,data=data,do.filter=FALSE) avars <- all.vars(formula[-2]) svar <- grep("strata",yxzf$predictor) if (length(svar)>=1) { avars <- avars[-svar] } ## check that it is not a factor and that there are more than 2 levels for (vv in avars) { if (length(unique(data[,vv]))>2 & !is.factor(data[,vv])) vars <- c(vars,vv) } } gres <- list() res <- matrix(0,length(vars),2) colnames(res) <- c("Sup_z |U(tau,z)|","pval") rownames(res) <- vars i <- 1 for (vv in vars) { modelmatrix <- cumContr(data[,vv],breaks=breaks,equi=equi) lres <- gofM.phreg(formula,data,modelmatrix=modelmatrix) lres$xaxs <- attr(modelmatrix,"breaks") res[i,] <- c(lres$Utlast,lres$pval.last) i <- i+1 lres <- list(lres) names(lres) <- vv gres <- c(gres,lres) } out <- list(res=res,Zres=gres,type="Zmodelmatrix") class(out) <- c("gof.phreg") return(out) }# }}} ###gofZ.phregGam <- function(formula,data,vars,offset=NULL,weights=NULL,breaks=40,equi=TRUE, ### n.sim=1000,silent=1,...) ###{# {{{ ### ### res <- matrix(0,length(vars),2) ### colnames(res) <- c("Sup_z |U(tau,z)|","pval") ### rownames(res) <- vars ### ### i <- 1 ###for (vv in vars) { ### modelmatrix <- cumContr(data[,vv],breaks=breaks,equi=equi) ### ###cox1 <- phreg(formula,data,offset=NULL,weights=NULL,Z=modelmatrix,cumhaz=FALSE,...) ###offsets <- cox1$X %*% cox1$coe ###if (!is.null(offset)) offsets <- offsets*offset ### ###if (!is.null(cox1$strata)) ### coxM <- phreg(cox1$model.frame[,1]~modelmatrix+strata(cox1$strata),data,offset=offsets,weights=weights,no.opt=TRUE,cumhaz=FALSE,...) ###else coxM <- phreg(cox1$model.frame[,1]~modelmatrix,data,offset=offsets,weights=weights,no.opt=TRUE,cumhaz=FALSE,...) ###nnames <- colnames(modelmatrix) ### ###Ut <- apply(coxM$U,2,cumsum) ###jumptimes <- coxM$jumptimes ###U <- coxM$U ###Ubeta <- cox1$U ###ii <- -solve(cox1$hessian) ###EE <- .Call("vecMatMat",coxM$E,cox1$E,PACKAGE="mets")$vXZ; ###Pt <- cox1$ZX - EE ###Pt <- apply(Pt,2,cumsum) ###betaiid <- t(ii %*% t(Ubeta)) ###obs <- apply(abs(Ut),2,max) ###simcox <- .Call("ModelMatrixTestCox",U,Pt,betaiid,n.sim,obs,PACKAGE="mets") ### ### ## pvals efter z i model.matrix sup_z | M(z,tau) | ### Utlast <- max(abs(tail(Ut,1))) ### maxlast <- apply(abs(simcox$last),1,max) ### pval.last <- mean(maxlast>=Utlast) ### res[i,] <- c(Utlast,pval.last) ### i <- i+1 ###} ### ###out <- list(res=res, type="modelmatrix") ###class(out) <- "gof.phreg" ### ###return(out) ###}# }}} ### ##' @export cumContr <- function(data,breaks=4,probs=NULL,equi=TRUE,na.rm=TRUE,unique.breaks=TRUE,...) {# {{{ if (is.vector(data)) { if (is.list(breaks)) breaks <- unlist(breaks) if (length(breaks) == 1) { if (!is.null(probs)) { breaks <- quantile(data, probs, na.rm = na.rm,...) breaks <- breaks[-1] } else { if (!equi) { probs <- seq(0, 1, length.out = breaks + 1) breaks <- quantile(data, probs, na.rm = na.rm, ...) if (unique.breaks) breaks <- unique(breaks) breaks <- breaks[-1] } if (equi) { rr <- range(data, na.rm = na.rm) breaks <- seq(rr[1], rr[2], length.out = breaks + 1) breaks <- breaks[-1] } } } if (sum(duplicated(breaks)) == 0) { i <- 0; gm <- matrix(0,length(data),length(breaks)) for (bb in breaks) { i <- i+1 gm[,i] <- (data <= bb)*1 } } else { wd <- which(duplicated(breaks)) mb <- min(diff(breaks[-wd])) breaks[wd] <- breaks[wd] + (mb/2) * seq(length(wd))/length(wd) i <- 0; gm <- matrix(0,length(data),length(breaks)) for (bb in breaks) { i <- i+1 gm[,i] <- (data <= bb)*1 } warning(paste("breaks duplicated")) } colnames(gm) <- paste("<=",breaks,sep="") attr(gm,"breaks") <- breaks return(gm) } }# }}} ##' Stratified baseline graphical GOF test for Cox covariates in PH regression ##' ##' Looks at stratified baseline in Cox model and plots all baselines versus each ##' other to see if lines are straight, with 50 resample versions under the ##' assumptiosn that the stratified Cox is correct ##' ##' @param x phreg object ##' @param sim to simulate som variation from cox model to put on graph ##' @param silent to keep it absolutely silent ##' @param lm addd line to plot, regressing the cumulatives on each other ##' @param ... Additional arguments to lower level funtions ##' @author Thomas Scheike and Klaus K. Holst ##' @export ##' @examples ##' data(TRACE) ##' ##' m1 <- phreg(Surv(time,status==9)~strata(vf)+chf+wmi,data=TRACE) ##' m2 <- phreg(Surv(time,status==9)~vf+strata(chf)+wmi,data=TRACE) ##' par(mfrow=c(2,2)) ##' ##' gofG.phreg(m1) ##' gofG.phreg(m2) ##' ##' bplot(m1,log="y") ##' bplot(m2,log="y") ##' @export gofG.phreg <- function(x,sim=0,silent=1,lm=TRUE,...) {# {{{ p <- length(x$coef) nnames <- names(x$coef) strata <- x$strata[x$jumps] nstrata <- x$nstrata jumptimes <- x$jumptimes cumhaz <- x$cumhaz ms <- match(x$strata.name,names(x$model.frame)) lstrata <- levels(x$model.frame[,ms]) stratn <- substring(x$strata.name,8,nchar(x$strata.name)-1) stratnames <- paste(stratn,lstrata,sep=":") if (is.null(cumhaz)) stop("Must run phreg with cumhaz=TRUE (default)"); if (nstrata==1) stop("Stratified Cox to look at baselines"); ### if (is.null(x$opt) | is.null(x$coef)) fixbeta<- 1 else fixbeta <- 0 for (i in 0:(nstrata-2)) for (j in (i+1):(nstrata-1)) { iij <- which(strata %in% c(i,j)) ii <- which(strata %in% i) ij <- which(strata %in% j) dijjumps <- jumptimes[iij] cumhazi <- Cpred(cumhaz[ii,],dijjumps,strict=FALSE) cumhazj <- Cpred(cumhaz[ij,],dijjumps,strict=FALSE) plot(cumhazj[,2],cumhazi[,2],type="s",lwd=2,xlab=stratnames[j+1],ylab=stratnames[i+1]) graphics::title(paste("Stratified baselines for",stratn)) if ((fixbeta==0 | sim==0) & lm ) graphics::legend("topleft",c("Nonparametric","lm"),lty=1,col=1:2) ### graphics::legend("topleft",c("Nonparametric","Stratified-Cox-Sim"),lty=1,col=1:3) ab <- lm(cumhazi[,2]~-1+cumhazj[,2]) if (sim==1 & fixbeta==0) { Pt <- DLambeta.t <- apply(x$E/c(x$S0),2,cumsumstrata,strata,nstrata) II <- -solve(x$hessian) betaiid <- t(II %*% t(x$U)) simband <- .Call("simBandCumHazCox",1/x$S0,Pt,betaiid,50,rep(1,nrow(Pt)),PACKAGE="mets") simU <-simband$simUt for (k in 1:50) { di <- Cpred(cbind(jumptimes[ii],simU[ii,k]),dijjumps,strict=FALSE)[,2] dj <- Cpred(cbind(jumptimes[ij],simU[ij,k]),dijjumps,strict=FALSE)[,2] lines(cumhazj[,2]+dj,cumhazi[,2]+di,type="s",lwd=0.1,col=3) } } lines(cumhazj[,2],cumhazi[,2],type="s",lwd=2,col=1) if (lm==TRUE) abline(c(0,coef(ab)),col=2,lwd=2) } }# }}} ##' @export plot.gof.phreg <- function(x,col=3,type=NULL,...) {# {{{ if (is.null(type)) { if (x$type=="prop") type <- "time" if (x$type=="modelmatrix" ) type <- "modelmatrix" if (x$type=="Zmodelmatrix") type <- "z" } if (type=="time" || type=="modelmatrix") { p <- ncol(x$score) for (i in 1:p) { simU <- x$simUt[,(0:49)*p+i] rsU <- max(abs(simU)) rsU <- max(rsU,abs(x$score[,i])) plot(x$jumptimes,x$score[,i],type="s",ylim=c(-rsU,rsU),xlab="",ylab="") title(main=rownames(x$res)[i]) matlines(x$jumptimes,simU,type="s",lwd=0.3,col=col) lines(x$jumptimes,x$score[,i],type="s",lwd=1.5) } } else { if (type=="modelmatrix") { obsz <- c(tail(x$score,1)) times <- 1:length(obsz) rsU <- max(max(abs(obsz)),max(abs(x$simUtlast[1:50,]))) plot(times,obsz,type="l",ylim=c(-rsU,rsU),xlab="",ylab="") matlines(times,t(x$simUtlast[1:50,]),type="l",lwd=0.3,col=col) ## redraw with thick to make observed clear lines(times,obsz,lwd=2,col=1) } else { for (i in 1:length(x$Zres)) { xr <- x$Zres[[i]] obsz <- c(tail(xr$score,1)) ### times <- 1:length(obsz) times <- xr$xaxs rsU <- max(max(abs(obsz)),max(abs(xr$simUtlast[1:50,]))) plot(times,obsz,type="l",ylim=c(-rsU,rsU),xlab="",ylab="") title(main=rownames(x$res)[i]) matlines(times,t(xr$simUtlast[1:50,]),type="l",lwd=0.3,col=col) ## redraw with thick to make observed clear lines(times,obsz,lwd=2,col=1) } } } }# }}} ##' @export summary.gof.phreg <- function(object,...) {# {{{ if (object$type=="prop") cat("Cumulative score process test for Proportionality:\n") else cat("Cumulative residuals versus modelmatrix :\n") print(object$res) if (!is.null(object$res.last)) { cat("\n") cat("Cumulative score process versus covariates (discrete z via model.matrix):\n") print(object$res.last) } } # }}} ##' @export print.gof.phreg <- function(x,...) {# {{{ if (x$type=="prop") cat("Cumulative score process test for Proportionality:\n") else cat("Cumulative residuals versus modelmatrix :\n") print(x$res) if (!is.null(x$res.last)) { cat("\n") cat("Cumulative score process versus covariates (discrete z via model.matrix):\n") print(x$res.last) } } # }}} mets/R/dprint.R0000644000176200001440000000451613623061405013054 0ustar liggesusersPrint <- function(x,n=NULL,nfirst=5,nlast=nfirst,digits=max(3,getOption("digits")-3),...) { mat <- !is.null(dim(x)) if (!mat) { x <- cbind(x) colnames(x) <- "" } if (is.null(n)) { if (NROW(x)<=(nfirst+nlast)) n <- list(seq(NROW(x))) else { n <- c() if (nfirst>0) n <- c(n,list(seq(nfirst))) if (nlast>0) n <- c(n,list(-rev(seq(nlast)))) } } if (is.null(n) || !is.list(n) && length(n)==1 && n==0) return(x) if (!is.list(n)) n <- list(n) d <- lapply(n,function(idx) { N <- NROW(x) idx <- idx[idx!=0 & abs(idx)<=N] idx[idx<0] <- N+idx[idx<0]+1 base::format(x[idx,,drop=FALSE],digits=digits,...) }) val <- c() sep <- rbind("---"=rep('',ncol(x))) for (i in seq_along(d)) { if (i>1) val <- rbind(val,sep) val <- rbind(val,base::as.matrix(d[[i]])) } return(structure(val,class=c("Print",class(val)))) } ##' @export print.Print <- function(x,quote=FALSE,...) { class(x) <- class(x)[-1] print(x,quote=quote,...) } ##' list, head, print, tail ##' ##' listing for data frames ##' @param data if x is formula or names for data frame then data frame is needed. ##' @param y name of variable, or fomula, or names of variables on data frame. ##' @param n Index of observations to print (default c(1:nfirst, n-nlast:nlast) ##' @param ... Optional additional arguments (nfirst,nlast, and print options) ##' @param x possible group variable ##' @author Klaus K. Holst and Thomas Scheike ##' @examples ##' n <- 20 ##' m <- lava::lvm(letters) ##' d <- lava::sim(m,n) ##' ##' dlist(d,~a+b+c) ##' dlist(d,~a+b+c|a<0 & b>0) ##' ## listing all : ##' dlist(d,~a+b+c|a<0 & b>0,n=0) ##' dlist(d,a+b+c~I(d>0)|a<0 & b>0) ##' dlist(d,.~I(d>0)|a<0 & b>0) ##' dlist(d,~a+b+c|a<0 & b>0, nlast=0) ##' dlist(d,~a+b+c|a<0 & b>0, nfirst=3, nlast=3) ##' dlist(d,~a+b+c|a<0 & b>0, 1:5) ##' dlist(d,~a+b+c|a<0 & b>0, -(5:1)) ##' dlist(d,~a+b+c|a<0 & b>0, list(1:5,50:55,-(5:1))) ##' dprint(d,a+b+c ~ I(d>0) |a<0 & b>0, list(1:5,50:55,-(5:1))) ##' @aliases dprint dlist dhead dtail ##' @export dprint <- function(data,y=NULL,n=0,...,x=NULL) daggregate(data,y,x,...,fun=function(z,...) Print(z,n=n,...),silent=FALSE) ##' @export dlist <- function(data,y=NULL,n=NULL,...) dprint(data,y=y,n=n,...) mets/R/bicomprisksim.R0000644000176200001440000002736613623061405014437 0ustar liggesusers ## n <- 1e4; ACE <- c(1,1,1)/3 ## logscale <- -4.5; logshape <- .7 ## p2 <- .065 ## a2 <- -10; b2 <- 0.15 ## a1 <- 85; b1 <- 0.1 ## pmvn(upper=c(q2,q2),sigma=diag(2)*(1-2/3)+2/3) ## pmvn(c(q2,q2),sigma=diag(2)*(1-2/3)+2/3) ## pnorm(q2,sd=1) ## Marginal / Perfect dependence ## pmvn(upper=c(q2,q2),sigma=diag(2)*(1-2/3)+2/3) ## Concordance ## pnorm(q2,sd=1)^2 ## Independence ## (lambdaR <- pmvn(upper=c(q2,q2),sigma=diag(2)*(1-2/3)+2/3)/pnorm(q2,sd=1)^2) bicomprisksim <- function(n=1e4, ACE=c(1/3,1/3,1/3), logscale=-4.5,logshape=.7, a1=85,b1=0.1, a2=-10,b2=0.15, p2=.065, tt, ...) { ACE <- ACE/sum(ACE) ialpha <- function(v,a,b) -(log(-v)+a)/b q2 <- qnorm(p2) ## p2: Prostata cancer prevalence p1 <- 1-p2; q1 <- qnorm(p1) ## Death without cancer alpha <- function(t,a,b) -exp(-(b*t+a)) F2s <- function(t) pnorm(alpha(t,b=b2,a=a2)+q2) ## Marginal Cumulative Incidence (cancer) ### Random effects R <- diag(2)*.5+.5 J <- matrix(1,ncol=2,nrow=2) I <- diag(2) zyg <- rep(c(0,1),each=n) A <- rbind(rmvn(n,sigma=R*ACE[1]),rmvn(n,sigma=J*ACE[1])) C <- rmvn(2*n,sigma=J*ACE[2]) ### Random effects 'death' eta1 <- C ### Random effects 'cancer' eta2 <- A+C; ### Subject-specific probability of lifetime cancer probcanc <- pnorm(q2+eta2,sd=ACE[3]^.5) ### Cancer/Death without cancer realizations cancertrue <- (runif(length(probcanc))cens] <- 0 t <- pmin(t0,cens) (censtab <- table(cause)/length(cause)) ### Data.frame d <- data.frame(t,cause,zyg,cancertrue-1,cens[,1],t0[,1],t0[,2]); names(d) <- c("time1","time2","cause1","cause2","zyg","cancertrue1","cancertrue2","cens.time","T01","T02") ### Long format dd <- fast.reshape(d) dd$cancer <- (dd$cause==2)*1 if (missing(tt)) tt <- seq(0,max(dd$time)) Smz <- J*ACE[1]+J*ACE[2]+I*ACE[3] Sdz <- R*ACE[1]+J*ACE[2]+I*ACE[3] rr <- alpha(tt,b=b2,a=a2)+q2 Cmz <- pmvn(upper=cbind(rr,rr),mu=matrix(0,ncol=2,nrow=length(rr)),sigma=Smz) Cdz <- pmvn(upper=cbind(rr,rr),mu=matrix(0,ncol=2,nrow=length(rr)),sigma=Sdz) true <- list(p2=p2, p22mz=pmvn(lower=c(-Inf,-Inf),upper=c(q2,q2),sigma=Smz), p12mz=pmvn(lower=c(q2,-Inf),upper=c(Inf,q2),sigma=Smz), p12mz=pmvn(lower=c(q2,-Inf),upper=c(Inf,q2),sigma=Smz), p11mz=pmvn(lower=c(q2,q2),upper=c(Inf,Inf),sigma=Smz), p22dz=pmvn(lower=c(-Inf,-Inf),upper=c(q2,q2),sigma=Sdz), p12dz=pmvn(lower=c(q2,-Inf),upper=c(Inf,q2),sigma=Sdz), p12dz=pmvn(lower=c(q2,-Inf),upper=c(Inf,q2),sigma=Sdz), p11dz=pmvn(lower=c(q2,q2),upper=c(Inf,Inf),sigma=Sdz), time=tt, F2=F2s(tt), Cmz=Cmz, Cdz=Cdz ) attributes(dd) <- c(attributes(dd),true) return(dd) } ################################################## ################################################## ################################################## ################################################## ################################################## ### simulation for gamma distributed cif model ################################################## ### ##### {{{ ###lap<-function(theta,t) { ### return( (1+t/theta)^(-theta)) ###} ###ilap<-function(theta,t) { ### itheta<-1/theta; return((t^(-itheta)-1)/(itheta)) ###} ### ###F1clust<-function(t,rtheta=1,theta=1,lam0=0.5,beta=0.3,x=0) { ### return(1-exp(-rtheta*ilap(theta,exp(-t*lam0-t*x*beta)))) ###} ### ###################################################################### ###F1<-function(t,lam0=0.5,beta=0.3,x=0) { # additive version ### return( 1 - exp(-t*lam0-t*x*beta)) ###} ### ######F1<-function(t,lam0=0.5,beta=0.3,x=0) # proportional version ######{ return( 1 - exp(-(t*lam0)*exp(x*beta))) } ### ###sim.F1<-function(n,theta=1,lam0=0.5,beta=0.3,crate=2) { ### x<-runif(n); tt<-seq(0,1,length=100) ### F11x<-F1(1,x=x,beta=beta,lam0=lam0) ### cause1<-rbinom(n,1,F11x) ### ### stime<-rep(100,n); ### for (i in 1:n) ### { ### if (cause1[i]==1) { ### myhazx<-F1(tt,x=x[i],beta=beta,lam0=lam0)/F11x[i] ### stime[i]<-Cpred(cbind(myhazx,tt),runif(1))[1,2]+runif(1,0,0.001) ### } ### } ### ctime<-runif(n)*crate ### time<-apply(cbind(ctime,stime),1,min) ### status<-(stime1) message(tau) data0 <- data[var==tau,,drop=FALSE] suppressWarnings(b <- twinlm(formula,data=data0,...)) res <- c(res,list(summary(b))) } if (length(lev)==1) return(b) if (!missing(breaks)) lev <- breaks coef <- c(lapply(res,function(x) x$all),list(res[[length(res)]]$all)) res <- list(varname=varname,var=lev,coef=coef,summary=res,type="strata") class(res) <- "timemets" return(res) } ## data(prt) ## bb <- twinlm.time(cancer~country,data=prt,id="id",zyg="zyg",DZ="DZ",cens.formula=Surv(time,status==0)~zyg,breaks=seq(70,90,by=4)) ## plot(bb,which=c(7,11),ylim=c(0,28),legendpos="topright",col=c("darkred","darkblue"),lty=c(1,2),legend=c("MZ","DZ"),ylab="Relative recurrence risk ratio") ## plot(bb,which=c(7,11),ylim=c(0,28),legendpos="topright",col=c("darkred","darkblue"),lty=c(1,2),legend=c("MZ","DZ"),ylab="Relative recurrence risk ratio",type="l") ##' @export twinlm.time <- function(formula,...) { biprobit.time(formula,estimator="bptwin",...) } ##' @export bptwin.time <- function(formula,...) { biprobit.time(formula,estimator="bptwin",...) } ##' @export summary.timemets <- function(object,which=seq(nrow(object$coef[[1]])),...) { res <- list() for (i in which) { rr <- matrix(unlist(lapply(object$coef,function(z) z[i,])),ncol=3,byrow=TRUE) colnames(rr) <- colnames(object$coef[[1]]) rr <- cbind(object$var,as.data.frame(rr[seq_along(object$var),,drop=FALSE])) colnames(rr)[1] <- object$varname res <- c(res,list(rr)) } names(res) <- rownames(object$coef[[1]])[which] return(res) } ##' @export print.timemets <- function(x,tail,row.names=FALSE,digits=4,width=10,...) { res <- summary(x,...) if (length(res)==0) { return(invisible(print(x$coef))) } if (!is.null(x$summary[[1]]$ncontrast) && x$summary[[1]]$ncontrast>1) { cat("Contrasts:\n") for (i in seq(x$summary[[1]]$ncontrasts)) { cat(" c",i,":\n",sep="") cat("\tDependence ", x$summary[[1]]$par[[i]]$corref, "\n") if (x$summary[[1]]$model$eqmarg) { cat("\tMean ", x$summary[[1]]$par[[i]]$mref1, "\n") } else { cat("\tMean 1 ", x$summary[[1]]$par[[i]]$mref1, "\n") cat("\tMean 2 ", x$summary[[1]]$par[[i]]$mref2, "\n") } } } ## } ## if (mcontr2 || (x$contrast & !x$model$eqmarg)) { ## cat("\tMean 1 ", x$par[[i]]$mref1, "\n") ## cat("\tMean 2 ", x$par[[i]]$mref2, "\n") ## } ## if (mcontr1 || (x$contrast & x$model$eqmarg)) ## cat("\tMean ", x$par[[i]]$mref1, "\n") M <- res[[1]][,1] nn <- c() for (i in seq_along(res)) { nn <- c(nn,names(res)[i]) M <- cbind(M,res[[i]][,2]) } nn0 <- cbind(paste(seq(ncol(M)-1),":",nn,sep="")) colnames(nn0) <- ""; rownames(nn0) <- rep("",nrow(nn0)) print(nn0,quote=FALSE) cat("\n") nn <- unlist(lapply(nn, function(x) { res <- toString(x,width) if (nchar(res)==nchar(x)) return(x) substr(res,1,nchar(res)-1) })) nn <- paste(seq(ncol(M)-1),":",nn,sep="") colnames(M) <- c("Time",nn) if (!missing(tail)) { print(utils::tail(round(M,digits=digits),tail),row.names=row.names) } else { print(round(M,digits=digits),row.names=row.names) } invisible(M) } ##' @export plot.timemets <- function(x,...,which=1, type="s", lwd=2,lty=1,col,fillcol,alpha=0.2, xlab=x$varname, ylab="",idx=seq_along(x$var), lasttick=TRUE,add=FALSE, legend=TRUE,legendpos="topleft") { ss <- summary(x,which) if (missing(col)) col <- seq_along(which) if (length(col)==1) col <- rep(col,length(which)) if (length(lwd)==1) lwd <- rep(lwd,length(which)) if (length(lty)==1) lty <- rep(lty,length(which)) if (alpha>0 & missing(fillcol)) fillcol <- Col(col,alpha) count <- 0 if (add) dev <- devcoords() for (tt in seq_along(which)) { count <- count+1 zz <- ss[[tt]][idx,,drop=FALSE] if (!add) { plot(zz[,1:2,drop=FALSE],lty=0, ylab=ylab,xlab=xlab,type="n",...) dev <- devcoords() } if (lasttick && type=="s" && !is.factor(zz[,1])) { zz2 <- rbind(zz,tail(zz,1)) zz2[nrow(zz2),1] <- dev$fig.x2 confband(zz2[,1],zz2[,3],zz2[,4],polygon=TRUE,step=(type=="s"),col=fillcol[count],border=0) } else { if (is.factor(zz[,1])) { confband(x=seq(nrow(zz)),lower=zz[,3],upper=zz[,4],center=zz[,2],col=col[count],lwd=lwd[count],lty=lty[count],...) } else { confband(zz[,1],zz[,3],zz[,4],polygon=TRUE,step=(type=="s"),col=fillcol[count],border=0) } } add <- TRUE ## if (lasttick && type=="s") { ## axis(4,at=zz[nrow(zz),3],labels=FALSE, ## lwd=lwd[count],col=fillcol[count],tcl=.5,...) ## axis(4,at=zz[nrow(zz),4],labels=FALSE, ## lwd=lwd[count],col=fillcol[count],tcl=.5,...) ## } if (!is.factor(zz[,1])) lines(zz[,1:2,drop=FALSE],lwd=lwd[count],lty=lty[count],col=col[count],type=type,...) } if (!is.null(legend) || (is.logical(legend) && !legend[1])) { if (is.logical(legend) || length(legend)==1) legend <- rownames(x$coef[[1]])[which] graphics::legend(legendpos,legend=legend,col=col,lwd=lwd,lty=lty) } invisible(x) } ##' @export bootstrap.timemets <- function(x,R=1000,...) { } mets/R/twostage.R0000644000176200001440000055540613623061405013422 0ustar liggesusers##' @title Twostage survival model for multivariate survival data ##' ##' @description ##' Fits Clayton-Oakes or bivariate Plackett models for bivariate survival data ##' using marginals that are on Cox form. The dependence can be ##' modelled via ##' \enumerate{ ##' \item Regression design on dependence parameter. ##' \item Random effects, additive gamma model. ##' } ##' ##' If clusters contain more than two subjects, we use a composite likelihood ##' based on the pairwise bivariate models, for MLE see twostageMLE. ##' ##' The two-stage model is constructed such that ##' given the gamma distributed random effects it is assumed that the survival functions ##' are indpendent, and that the marginal survival functions are on Cox form (or additive form) ##' \deqn{ ##' P(T > t| x) = S(t|x)= exp( -exp(x^T \beta) A_0(t) ) ##' } ##' ##' One possibility is to model the variance within clusters via a regression design, and ##' then one can specify a regression structure for the indenpendent gamma distributed ##' random effect for each cluster, such that the variance is given by ##' \deqn{ ##' \theta = z_j^T \alpha ##' } ##' where \eqn{z} is specified by theta.des ##' The reported standard errors are based on the estimated information from the ##' likelihood assuming that the marginals are known. ##' ##' Can also fit a structured additive gamma random effects model, such ##' as the ACE, ADE model for survival data. In this case the ##' random.design specificies the random effects for each subject within a cluster. This is ##' a matrix of 1's and 0's with dimension n x d. With d random effects. ##' For a cluster with two subjects, we let the random.design rows be ##' \eqn{v_1} and \eqn{v_2}. ##' Such that the random effects for subject ##' 1 is \deqn{v_1^T (Z_1,...,Z_d)}, for d random effects. Each random effect ##' has an associated parameter \eqn{(\lambda_1,...,\lambda_d)}. ##' By construction subjects 1's random effect are Gamma distributed with ##' mean \eqn{\lambda_j/v_1^T \lambda} ##' and variance \eqn{\lambda_j/(v_1^T \lambda)^2}. Note that the random effect ##' \eqn{v_1^T (Z_1,...,Z_d)} has mean 1 and variance \eqn{1/(v_1^T \lambda)}. ##' It is here asssumed that \eqn{lamtot=v_1^T \lambda} is fixed within clusters ##' as it would be for the ACE model below. ##' ##' Based on these parameters the relative contribution (the heritability, h) is ##' equivalent to the expected values of the random effects: \eqn{\lambda_j/v_1^T \lambda} ##' ##' The DEFAULT parametrization (var.par=1) uses the variances of the random effecs ##' \deqn{ ##' \theta_j = \lambda_j/(v_1^T \lambda)^2 ##' } ##' For alternative parametrizations one can specify how the parameters relate to \eqn{\lambda_j} ##' with the argument var.par=0. ##' ##' For both types of models the basic model assumptions are that ##' given the random effects of the clusters the survival distributions within a cluster ##' are independent and ' on the form ##' \deqn{ ##' P(T > t| x,z) = exp( -Z \cdot Laplace^{-1}(lamtot,lamtot,S(t|x)) ) ##' } ##' with the inverse laplace of the gamma distribution with mean 1 and variance 1/lamtot. ##' ##' The parameters \eqn{(\lambda_1,...,\lambda_d)} are related to the parameters of the model ##' by a regression construction \eqn{pard} (d x k), that links the \eqn{d} ##' \eqn{\lambda} parameters ##' with the (k) underlying \eqn{\theta} parameters ##' \deqn{ ##' \lambda = theta.des \theta ##' } ##' here using theta.des to specify these low-dimension association. Default is a diagonal matrix. ##' This can be used to make structural assumptions about the variances of the random-effects ##' as is needed for the ACE model for example. ##' ##' The case.control option that can be used with the pair specification of the pairwise parts ##' of the estimating equations. Here it is assumed that the second subject of each pair is the proband. ##' ##' @references ##' ##' Twostage estimation of additive gamma frailty models for survival data. ##' Scheike (2019), work in progress ##' ##' Shih and Louis (1995) Inference on the association parameter in copula models for bivariate ##' survival data, Biometrics, (1995). ##' ##' Glidden (2000), A Two-Stage estimator of the dependence ##' parameter for the Clayton Oakes model, LIDA, (2000). ##' ##' Measuring early or late dependence for bivariate twin data ##' Scheike, Holst, Hjelmborg (2015), LIDA ##' ##' Estimating heritability for cause specific mortality based on twins studies ##' Scheike, Holst, Hjelmborg (2014), LIDA ##' ##' Additive Gamma frailty models for competing risks data, Biometrics (2015) ##' Eriksson and Scheike (2015), ##' ##' @examples ##' data(diabetes) ##' ##' # Marginal Cox model with treat as covariate ##' margph <- phreg(Surv(time,status)~treat+cluster(id),data=diabetes) ##' ### Clayton-Oakes, MLE ##' fitco1<-twostageMLE(margph,data=diabetes,theta=1.0) ##' summary(fitco1) ##' ##' ### Plackett model ##' mph <- phreg(Surv(time,status)~treat+cluster(id),data=diabetes) ##' fitp <- survival.twostage(mph,data=diabetes,theta=3.0,Nit=40, ##' clusters=diabetes$id,var.link=1,model="plackett") ##' summary(fitp) ##' ##' ### Clayton-Oakes ##' fitco2 <- survival.twostage(mph,data=diabetes,theta=0.0,detail=0, ##' clusters=diabetes$id,var.link=1,model="clayton.oakes") ##' summary(fitco2) ##' fitco3 <- survival.twostage(margph,data=diabetes,theta=1.0,detail=0, ##' clusters=diabetes$id,var.link=0,model="clayton.oakes") ##' summary(fitco3) ##' ##' ### without covariates but with stratafied ##' marg <- phreg(Surv(time,status)~+strata(treat)+cluster(id),data=diabetes) ##' fitpa <- survival.twostage(marg,data=diabetes,theta=1.0, ##' clusters=diabetes$id,score.method="optimize") ##' summary(fitpa) ##' ##' fitcoa <- survival.twostage(marg,data=diabetes,theta=1.0,clusters=diabetes$id, ##' model="clayton.oakes") ##' summary(fitcoa) ##' ##' ### Piecewise constant cross hazards ratio modelling ##' ######################################################## ##' ##' d <- subset(simClaytonOakes(2000,2,0.5,0,stoptime=2,left=0),!truncated) ##' udp <- piecewise.twostage(c(0,0.5,2),data=d,score.method="optimize", ##' id="cluster",timevar="time", ##' status="status",model="clayton.oakes",silent=0) ##' summary(udp) ##' ##' \donttest{ ## Reduce Ex.Timings ##' ### Same model using the strata option, a bit slower ##' ######################################################## ##' ## makes the survival pieces for different areas in the plane ##' ##ud1=surv.boxarea(c(0,0),c(0.5,0.5),data=d,id="cluster",timevar="time",status="status") ##' ##ud2=surv.boxarea(c(0,0.5),c(0.5,2),data=d,id="cluster",timevar="time",status="status") ##' ##ud3=surv.boxarea(c(0.5,0),c(2,0.5),data=d,id="cluster",timevar="time",status="status") ##' ##ud4=surv.boxarea(c(0.5,0.5),c(2,2),data=d,id="cluster",timevar="time",status="status") ##' ##' ## everything done in one call ##' ud <- piecewise.data(c(0,0.5,2),data=d,timevar="time",status="status",id="cluster") ##' ud$strata <- factor(ud$strata); ##' ud$intstrata <- factor(ud$intstrata) ##' ##' ## makes strata specific id variable to identify pairs within strata ##' ## se's computed based on the id variable across strata "cluster" ##' ud$idstrata <- ud$id+(as.numeric(ud$strata)-1)*2000 ##' ##' marg2 <- aalen(Surv(boxtime,status)~-1+factor(num):factor(intstrata), ##' data=ud,n.sim=0,robust=0) ##' tdes <- model.matrix(~-1+factor(strata),data=ud) ##' fitp2 <- survival.twostage(marg2,data=ud,se.clusters=ud$cluster,clusters=ud$idstrata, ##' score.method="fisher.scoring",model="clayton.oakes", ##' theta.des=tdes,step=0.5) ##' summary(fitp2) ##' ##' ### now fitting the model with symmetry, i.e. strata 2 and 3 same effect ##' ud$stratas <- ud$strata; ##' ud$stratas[ud$strata=="0.5-2,0-0.5"] <- "0-0.5,0.5-2" ##' tdes2 <- model.matrix(~-1+factor(stratas),data=ud) ##' fitp3 <- survival.twostage(marg2,data=ud,clusters=ud$idstrata,se.cluster=ud$cluster, ##' score.method="fisher.scoring",model="clayton.oakes", ##' theta.des=tdes2,step=0.5) ##' summary(fitp3) ##' ##' ### same model using strata option, a bit slower ##' fitp4 <- survival.twostage(marg2,data=ud,clusters=ud$cluster,se.cluster=ud$cluster, ##' score.method="fisher.scoring",model="clayton.oakes", ##' theta.des=tdes2,step=0.5,strata=ud$strata) ##' summary(fitp4) ##' } ##' ##' \donttest{ ## Reduce Ex.Timings ##' ### structured random effects model additive gamma ACE ##' ### simulate structured two-stage additive gamma ACE model ##' data <- simClaytonOakes.twin.ace(4000,2,1,0,3) ##' out <- twin.polygen.design(data,id="cluster") ##' pardes <- out$pardes ##' pardes ##' des.rv <- out$des.rv ##' head(des.rv) ##' aa <- phreg(Surv(time,status)~x+cluster(cluster),data=data,robust=0) ##' ts <- survival.twostage(aa,data=data,clusters=data$cluster,detail=0, ##' theta=c(2,1),var.link=0,step=0.5, ##' random.design=des.rv,theta.des=pardes) ##' summary(ts) ##' } ##' ##' @keywords survival ##' @author Thomas Scheike ##' @param margsurv Marginal model ##' @param data data frame ##' @param score.method Scoring method "fisher.scoring", "nlminb", "optimize", "nlm" ##' @param Nit Number of iterations ##' @param detail Detail ##' @param clusters Cluster variable ##' @param silent Debug information ##' @param weights Weights ##' @param control Optimization arguments ##' @param theta Starting values for variance components ##' @param theta.des design for dependence parameters, when pairs are given this is could be a ##' (pairs) x (numer of parameters) x (max number random effects) matrix ##' @param var.link Link function for variance ##' @param iid Calculate i.i.d. decomposition ##' @param step Step size ##' @param model model ##' @param marginal.trunc marginal left truncation probabilities ##' @param marginal.survival optional vector of marginal survival probabilities ##' @param marginal.status related to marginal survival probabilities ##' @param strata strata for fitting, see example ##' @param se.clusters for clusters for se calculation with iid ##' @param numDeriv to get numDeriv version of second derivative, otherwise uses sum of squared score ##' @param random.design random effect design for additive gamma model, when pairs are given this is ##' a (pairs) x (2) x (max number random effects) matrix, see pairs.rvs below ##' @param pairs matrix with rows of indeces (two-columns) for the pairs considered in the pairwise ##' composite score, useful for case-control sampling when marginal is known. ##' @param pairs.rvs for additive gamma model and random.design and theta.des are given as arrays, ##' this specifice number of random effects for each pair. ##' @param numDeriv.method uses simple to speed up things and second derivative not so important. ##' @param additive.gamma.sum for two.stage=0, this is specification of the lamtot in the models via ##' a matrix that is multiplied onto the parameters theta (dimensions=(number random effects x number ##' of theta parameters), when null then sums all parameters. ##' @param var.par is 1 for the default parametrization with the variances of the random effects, ##' var.par=0 specifies that the \eqn{\lambda_j}'s are used as parameters. ##' @param cr.models competing risks models for two.stage=0, should be given as a list with models for each cause ##' @param case.control assumes case control structure for "pairs" with second column being the probands, ##' when this options is used the twostage model is profiled out via the paired estimating equations for the ##' survival model. ##' @param ascertained if the pair are sampled only when there is an event. This is in contrast to ##' case.control sampling where a proband is given. This can be combined with control probands. Pair-call ##' of twostage is needed and second column of pairs are the first jump time with an event for ascertained pairs, ##' or time of control proband. ##' @param shut.up to make the program more silent in the context of iterative procedures for case-control ##' and ascertained sampling ##' @aliases survival.twostage survival.twostage.fullse twostage.aalen twostage.cox.aalen twostage.coxph twostage.phreg randomDes ##' @export survival.twostage survival.twostage <- function(margsurv,data=sys.parent(), score.method="fisher.scoring",Nit=60,detail=0,clusters=NULL, silent=1,weights=NULL, control=list(),theta=NULL,theta.des=NULL, var.link=1,iid=1,step=0.5,model="clayton.oakes", marginal.trunc=NULL,marginal.survival=NULL,marginal.status=NULL,strata=NULL, se.clusters=NULL,numDeriv=0,random.design=NULL,pairs=NULL,pairs.rvs=NULL, numDeriv.method="simple",additive.gamma.sum=NULL,var.par=1,cr.models=NULL, case.control=0,ascertained=0,shut.up=0) {## {{{ ## {{{ seting up design and variables two.stage <- 1; rate.sim <- 1; sym=1; var.func <- NULL if (model=="clayton.oakes" || model=="gamma") dep.model <- 1 else if (model=="plackett" || model=="or") dep.model <- 2 else stop("Model must by either clayton.oakes or plackett \n"); start.time <- NULL; ptrunc <- NULL; psurvmarg <- NULL; status <- NULL; score.iid <- NULL fix.baseline <- 0; convergence.bp <- 1; ### to control if baseline profiler converges if ((!is.null(margsurv)) | (!is.null(marginal.survival))) fix.baseline <- 1 antpers <- nrow(data); RR <- rep(1,antpers); if (!is.null(margsurv)) { rrr <- readmargsurv(margsurv,data,clusters) psurvmarg <- rrr$psurvmarg; ptrunc <- rrr$ptrunc; start.time <- rrr$entry; time2 <- rrr$exit; status <- rrr$status; clusters <- rrr$clusters } if (is.null(psurvmarg)) psurvmarg <- rep(1,antpers); if (!is.null(marginal.survival)) psurvmarg <- marginal.survival if (!is.null(marginal.trunc)) ptrunc <- marginal.trunc if (is.null(ptrunc)) ptrunc <- rep(1,length(psurvmarg)) if (!is.null(marginal.status)) status <- marginal.status if (is.null(status) & is.null(cr.models)) stop("must give status variable for survival via either margninal model (margsurv), marginal.status or as cr.models \n"); if (is.null(weights)==TRUE) weights <- rep(1,antpers); if (is.null(strata)==TRUE) strata<- rep(1,antpers); if (length(strata)!=antpers) stop("Strata must have length equal to number of data points \n"); ## {{{ cluster set up cluster.call <- clusters out.clust <- cluster.index(clusters); clusters <- out.clust$clusters maxclust <- out.clust$maxclust antclust <- out.clust$cluster.size clusterindex <- out.clust$idclust clustsize <- out.clust$cluster.size call.secluster <- se.clusters if (is.null(se.clusters)) { se.clusters <- clusters; antiid <- nrow(clusterindex);} else { iids <- unique(se.clusters); antiid <- length(iids); if (is.numeric(se.clusters)) se.clusters <- fast.approx(iids,se.clusters)-1 else se.clusters <- as.integer(factor(se.clusters, labels = seq(antiid)))-1 } if (length(se.clusters)!=length(clusters)) stop("Length of seclusters and clusters must be same\n"); ### if ((!is.null(max.clust))) if (max.clust< antiid) { ### coarse.clust <- TRUE ### qq <- unique(quantile(se.clusters, probs = seq(0, 1, by = 1/max.clust))) ### qqc <- cut(se.clusters, breaks = qq, include.lowest = TRUE) ### se.clusters <- as.integer(qqc)-1 ### max.clusters <- length(unique(se.clusters)) ### maxclust <- max.clust ### antiid <- max.clusters ### } ### if (maxclust==1) stop("No clusters, maxclust size=1\n"); ## }}} ### setting design for random variables, in particular with pairs are given ddd <- randomDes(dep.model,random.design,theta.des,theta,antpers,additive.gamma.sum,pairs,pairs.rvs,var.link,clusterindex) random.design=ddd$random.design;clusterindex=ddd$clusterindex; antpairs=ddd$antpairs; pairs.rvs=ddd$pairs.rvs; theta=ddd$theta;ptheta=ddd$ptheta;theta.des=ddd$theta.des pair.structure=ddd$pair.structure; dep.model=ddd$dep.model dim.rv <- ddd$dim.rv; additive.gamma.sum=ddd$additive.gamma.sum theta.score<-rep(0,ptheta);Stheta<-var.theta<-matrix(0,ptheta,ptheta); ## }}} ### setting up arguments for Aalen baseline profile estimates if (fix.baseline==0) { ## {{{ when baseline is estimated if (is.null(cr.models)) stop("give hazard models for different causes, ex cr.models=list(Surv(time,status==1)~+1,Surv(time,status==2)~+1) \n") if (case.control==0 & ascertained==0) { ## {{{ #### organize subject specific random variables and design ### for additive gamma model ## {{{ dimt <- dim(theta.des[,,1,drop=FALSE])[-3] dimr <- dim(random.design[,,,drop=FALSE]) mtheta.des <- array(0,c(dimt,nrow(data))) mrv.des <- array(0,c(dimr[1]/2,dimr[2],nrow(data))) nrv.des <- rep(0,nrow(data)) nrv.des[pairs[,1]] <- pairs.rvs nrv.des[pairs[,2]] <- pairs.rvs mtheta.des[,,pairs[,1]] <- theta.des mtheta.des[,,pairs[,2]] <- theta.des mrv.des[,,pairs[,1]] <- random.design[1:(dimr[1]/2),,,drop=FALSE] mrv.des[,,pairs[,2]] <- random.design[(dimr[1]/2+1):dimr[1],,,drop=FALSE] ### array thetades to jump times (subjects) mtheta.des <- mtheta.des[,,ids,drop=FALSE] ### array randomdes to jump times (subjects) mrv.des <- mrv.des[,,ids,drop=FALSE] nrv.des <- pairs.rvs[ids] ## }}} } ## }}} if (case.control==1 || ascertained==1) { ## {{{ ### print(dim(data)); print(summary(pairs)) data1 <- data[pairs[,1],] data.proband <- data[pairs[,2],] weights1 <- weights[pairs[,1]] ### print(summary(data.proband)); print(summary(data1)) ## {{{ setting up designs for jump times timestatus <- all.vars(cr.models[[1]]) if (is.null(status)) status <- data[,timestatus[2]] alltimes <- data[,timestatus[1]] times <- data1[,timestatus[1]] lstatus <- data1[,timestatus[2]] timescase <- data.proband[,timestatus[1]] lstatuscase <- data.proband[,timestatus[2]] ### organize increments according to overall jump-times jumps <- lstatus!=0 dtimes <- times[jumps] dtimescase <- timescase[jumps] st <- order(dtimes) dtimesst <- dtimes[st] dtimesstcase <- dtimescase[st] dcauses <- lstatus[jumps][st] dcausescase <- lstatuscase[jumps][st] ids <- (1:nrow(data1))[jumps][st] ### ### delayed entry for case because of ascertained sampling ### controls are however control probands, and have entry=0 entry <- timescase*lstatuscase data1$entry <- entry cr.models2 <- list() if (ascertained==1) { for (i in 1:length(cr.models)) { cr.models2[[i]] <- update(cr.models[[i]],as.formula(paste("Surv(entry,",timestatus[1],",",timestatus[2],")~.",sep=""))) } } else cr.models2 <- cr.models nc <- 0 for (i in 1:length(cr.models)) { X <- aalen.des(as.formula(cr.models[[i]]),data=data1)$X nc <- nc+ncol(X) } dBaalen <- matrix(0,length(dtimes),nc) xjump <- array(0,c(length(cr.models),nc,length(ids))) xjumpcase <- array(0,c(length(cr.models),nc,length(ids))) ## first compute marginal aalen models for all causes a <- list(); da <- list(); ### starting values for iteration Bit <- Bitcase <- c() for (i in 1:length(cr.models)) { ## {{{ a[[i]] <- aalen(as.formula(cr.models2[[i]]),data=data1,robust=0,weights=weights1) da[[i]] <- apply(a[[i]]$cum[,-1,drop=FALSE],2,diff) jumpsi <- (1:length(dtimes))[dcauses==i] X <- aalen.des(as.formula(cr.models[[i]]),data=data1)$X Xcase <- aalen.des(as.formula(cr.models[[i]]),data=data.proband)$X if (i==1) fp <- 1 indexc <- fp:(fp+ncol(X)-1) dBaalen[jumpsi,indexc] <- da[[i]] xjump[i,indexc,] <- t(X[ids,]) xjumpcase[i,indexc,] <- t(Xcase[ids,]) fp <- fp+ncol(X) ### starting values Bit <- cbind(Bit,Cpred(a[[i]]$cum,dtimesst)[,-1,drop=FALSE]) } ## }}} Bit.ini <- Bit ## }}} #### organize subject specific random variables and design #### already done in basic pairwise setup mtheta.des <- theta.des[,,ids,drop=FALSE] ### array randomdes to jump times (subjects) mrv.des <- random.design[,,ids,drop=FALSE] nrv.des <- pairs.rvs[ids] } ## }}} } else { mrv.des <- array(0,c(1,1,1)); mtheta.des <- array(0,c(1,1,1)); margthetades <- array(0,c(1,1,1)); xjump <- array(0,c(1,1,1)); dBaalen <- matrix(0,1,1); nrv.des <- 3 } ## }}} loglike <- function(par) { ## {{{ if (pair.structure==0 | dep.model!=3) Xtheta <- as.matrix(theta.des) %*% matrix(c(par),nrow=ptheta,ncol=1); if (pair.structure==1 & dep.model==3) Xtheta <- matrix(0,antpers,1); ## not needed DXtheta <- array(0,c(1,1,1)); if (var.link==1 & dep.model==3) epar <- c(exp(par)) else epar <- c(par) partheta <- epar if (var.par==1 & dep.model==3) { ## from variances to if (is.null(var.func)) { sp <- sum(epar) partheta <- epar/sp^2 } else partheta <- epar ## par.func(epar) } if (pair.structure==0) {# {{{ outl<-.Call("twostageloglikeRV", ## {{{ only two stage model for this option icause=status,ipmargsurv=psurvmarg, itheta=c(partheta),iXtheta=Xtheta,iDXtheta=DXtheta,idimDX=dim(DXtheta),ithetades=theta.des, icluster=clusters,iclustsize=clustsize,iclusterindex=clusterindex, ivarlink=var.link,iid=iid,iweights=weights,isilent=silent,idepmodel=dep.model, itrunkp=ptrunc,istrata=as.numeric(strata),iseclusters=se.clusters,iantiid=antiid, irvdes=random.design,iags=additive.gamma.sum,iascertained=ascertained, PACKAGE="mets") ## }}} }# }}} else { ## {{{ pair-structure ## twostage model, case.control option, profile out baseline ## conditional model, case.control option, profile out baseline if (fix.baseline==0) ## if baseline is not given { cum1 <- cbind(dtimesst,Bit) if ( (case.control==1 || ascertained==1) & (convergence.bp==1)) { ## {{{ profiles out baseline under case-control/ascertainment sampling ### ## initial values , only one cr.model for survival ### Bit <- cbind(Cpred(a[[1]]$cum,dtimesst)[,-1]) if (detail>1) plot(dtimesst,Bit,type="l",main="Bit") if (ncol(Bit)==0) Bit <- Bit.ini Bitcase <- Cpred(cbind(dtimesst,Bit),dtimesstcase)[,-1,drop=FALSE] Bitcase <- .Call("MatxCube",Bitcase,dim(xjumpcase),xjumpcase,PACKAGE="mets")$X for (j in 1:5) { ## {{{ profile via iteration cncc <- .Call("BhatAddGamCC",1,dBaalen,dcauses,dim(xjump),xjump, c(partheta),dim(mtheta.des),mtheta.des,additive.gamma.sum,var.link, dim(mrv.des),mrv.des,nrv.des,1,Bit,Bitcase,dcausescase,PACKAGE="mets") d <- max(abs(Bit-cncc$B)) if (detail>1) print(d) Bit <- cncc$B ### if (detail>1) print(c(par,epar,partheta)); ### if (detail>1) print(summary(Bit)); if (detail>1) print(summary(cncc$caseweights)) cum1 <- cbind(dtimesst,cncc$B) Bitcase <-cbind(Cpred(cum1,dtimesstcase)[,-1]) ### if (detail>1) print(summary(Bitcase)) if (detail>1) lines(dtimesst,Bit,col=j+1); if (is.na(d)) { if (shut.up==0) cat("Baseline profiler gives missing values\n"); Bit <- Bit.ini; cum1 <- cbind(dtimesst,Bit); convergence.bp <<- 0; break; } Bitcase <- .Call("MatxCube",Bitcase,dim(xjumpcase),xjumpcase,PACKAGE="mets")$X if (d<0.00001) break; } ## }}} nulrow <- rep(0,ncol(Bit)+1) pbases <- Cpred(rbind(nulrow,cbind(dtimesst,Bit)),alltimes)[,-1,drop=FALSE] X <- aalen.des(as.formula(cr.models[[1]]),data=data)$X psurvmarg <- exp(-apply(X*pbases,1,sum)) ## psurv given baseline if (ascertained==1) { Xcase <- aalen.des(as.formula(cr.models[[1]]),data=data.proband)$X X <- aalen.des(as.formula(cr.models[[1]]),data=data1)$X pba.case <- Cpred(rbind(nulrow,cbind(dtimesst,Bit)),entry)[,-1,drop=FALSE] ptrunc <- rep(0,nrow(data)) ### for control probands ptrunc=1, thus no adjustment ptrunc[pairs[,1]] <- exp(-apply(X* pba.case,1,sum)*lstatuscase) ## delayed entry at time of ascertainment proband ptrunc[pairs[,2]] <- exp(-apply(Xcase*pba.case,1,sum)*lstatuscase) } } ## }}} } outl<-.Call("twostageloglikeRVpairs", ## {{{ icause=status,ipmargsurv=psurvmarg, itheta=c(partheta),iXtheta=Xtheta,iDXtheta=DXtheta,idimDX=dim(DXtheta), ithetades=theta.des, icluster=clusters,iclustsize=clustsize,iclusterindex=clusterindex, ivarlink=var.link,iiid=iid,iweights=weights,isilent=silent,idepmodel=dep.model, itrunkp=ptrunc,istrata=as.numeric(strata),iseclusters=se.clusters,iantiid=antiid, irvdes=random.design, idimthetades=dim(theta.des),idimrvdes=dim(random.design),irvs=pairs.rvs, iags=additive.gamma.sum, iascertained=ascertained,PACKAGE="mets") ## }}} if (fix.baseline==0) { outl$baseline <- cum1; outl$marginal.surv <- psurvmarg; outl$marginal.trunc <- ptrunc } } ## }}} if (detail==3) print(c(partheta,outl$loglike)) ## variance parametrization, and inverse.link if (dep.model==3) {# {{{ if (var.par==1) { ## from variances to and with sum for all random effects if (is.null(var.func)) { if (var.link==0) { ### print(c(sp,epar)) mm <- matrix(-epar*2*sp,length(epar),length(epar)) diag(mm) <- sp^2-epar*2*sp ### print(mm) } else { mm <- -c(epar) %o% c(epar)*2*sp diag(mm) <- epar*sp^2-epar^2*2*sp ### print(mm) } mm <- mm/sp^4 } else mm <- numDeriv::hessian(var.func,par) } else { if (var.link==0) mm <- diag(length(epar)) else mm <- diag(length(c(epar)))*c(epar) } }# }}} if (dep.model==3) {# {{{ outl$score <- t(mm) %*% outl$score outl$Dscore <- t(mm) %*% outl$Dscore %*% mm if (iid==1) { outl$score.iid <- t(t(mm) %*% t(outl$score.iid)) if (class(margsurv)=="phreg") { outl$D1thetal <- t(t(mm) %*% t(outl$D1thetal)) outl$D2thetal <- t(t(mm) %*% t(outl$D2thetal)) } } }# }}} attr(outl,"gradient") <-outl$score if (oout==0) ret <- c(-1*outl$loglike) else if (oout==1) ret <- sum(outl$score^2) else if (oout==2) ret <- outl else ret <- outl$score return(ret) } ## }}} if (score.method=="optimize" && ptheta!=1) { cat("optimize only works for d==1, score.mehod set to nlminb \n"); score.method <- "nlminb"; } score1 <- NULL theta.iid <- NULL logl <- NULL p <- theta if (score.method=="fisher.scoring") { ## {{{ oout <- 2; ### output control for obj if (Nit>0) for (i in 1:Nit) { out <- loglike(p) ## updating starting values for cumulative baselines if (fix.baseline==0) Bit <- out$baseline[,-1,drop=FALSE] if (fix.baseline==1) hess <- out$Dscore ### uses simple second derivative for computing derivative of score if (numDeriv==2 || (((fix.baseline==0)) & (i==1))) { oout <- 3 hess <- numDeriv::jacobian(loglike,p,method="simple") oout <- 2 } if (!is.na(sum(hess))) hessi <- lava::Inverse(hess) else hessi <- hess if (detail==1) {## {{{ cat(paste("Fisher-Scoring ===================: it=",i,"\n")); cat("theta:");print(c(theta)) cat("loglike:");cat(c(out$loglike),"\n"); cat("score:");cat(c(out$score),"\n"); cat("hess:\n"); cat(hess,"\n"); }## }}} delta <- step*( hessi %*% out$score ) ### update p, but note that score and derivative in fact related to previous p ### unless Nit=0, if (Nit>0) { p <- p - delta theta <- p; } if (is.nan(sum(out$score))) break; if (sum(abs(out$score))<0.00001) break; if (max(theta)>20 & var.link==1) { cat("theta too large lacking convergence \n"); break; } } if (!is.nan(sum(p))) { if (detail==1 && iid==1) cat("iid decomposition\n"); out <- loglike(p) logl <- out$loglike score1 <- score <- out$score oout <- 0; hess1 <- hess <- -1*out$Dscore if (iid==1) { ## {{{ score.iid <- out$score.iid out$theta.iid <- score.iid theta.iid <- score.iid ucc <- unique(cluster.call) if (length(ucc)== nrow(theta.iid)) rownames(theta.iid) <- unique(cluster.call) ### lets iid for theta be just score to start, correction for marginal for phreg call if (class(margsurv)=="phreg") { ## {{{ if (is.null(margsurv$opt) | is.null(margsurv$coef)) fixbeta<- 1 else fixbeta <- 0 xx <- margsurv$cox.prep id <- xx$id+1 cumhazt <- c(rrr$cum) rr <- c(rrr$RR) ### print(clusters) ### print(clusterindex) ## these refers to id given in cluster.call xx <- margsurv$cox.prep D1thetal<- out$D1thetal D2thetal<- out$D2thetal Dlamthetal <- -(D1thetal+D2thetal) ## ordered as original data Fbeta <- t(Dlamthetal) %*% (margsurv$X *cumhazt*psurvmarg*rr) ### timeordered ### Gbasem <- apply(-Dlamthetal[xx$ord+1,,drop=FALSE]*psurvmarg[xx$ord+1]*rr[xx$ord+1],2,cumsumstratasum,xx$strata,xx$nstrata,type="lagsum") ## t- not needed because using S(T-) for survival already Gbasedt <- Dlamthetal[xx$ord+1,,drop=FALSE]*psurvmarg[xx$ord+1]*rr[xx$ord+1] ### Gbase <- apply(Gbasedt,2,cumsumstrata,xx$strata,xx$nstrata) ## new Gbase <- apply(Gbasedt,2,revcumsumstrata,xx$strata,xx$nstrata) ### print(c(Gbase)); print(Fbeta) if (fixbeta==0) { # {{{ iid after beta of marginal model Z <- xx$X U <- E <- matrix(0,nrow(xx$X),margsurv$p) E[xx$jumps+1,] <- margsurv$E U[xx$jumps+1,] <- margsurv$U invhess <- -solve(margsurv$hessian) S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/margsurv$S0 cumhaz <- c(cumsumstrata(S0i,xx$strata,xx$nstrata)) EdLam0 <- apply(E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) rr <- c(xx$sign*exp(Z %*% coef(margsurv) + xx$offset)) ### Martingale for all subjects MGt <- U[,drop=FALSE]-(Z*cumhaz-EdLam0)*rr*c(xx$weights) UUbeta <- apply(MGt,2,sumstrata,id-1,max(id)) UUbeta <- UUbeta %*% invhess GbaseEdLam0 <- t(Gbasedt) %*% (E*S0i) Fbeta <- Fbeta + GbaseEdLam0 Fbetaiid <- UUbeta %*% t(Fbeta) }# }}} ### \int_0^\tau (GBase(s) / S_0(s)) dN_i(s) - dLamba_i(s) xx <- margsurv$cox.prep S0i <- S0i2 <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/margsurv$S0 S0i2[xx$jumps+1] <- 1/margsurv$S0^2 ### dN <- S0i; dLam0 <- cumsumstrata(S0i2,xx$strata,xx$nstrata) GbasedN <- Gbase*S0i GbasedLam0 <- apply(Gbase*S0i2,2,cumsumstrata,xx$strata,xx$nstrata) if (fixbeta==0) rr <- c(xx$sign*exp(Z %*% coef(margsurv) + xx$offset)) else rr <- c(xx$sign*exp( xx$offset)) MGt <- (GbasedN[,drop=FALSE]-GbasedLam0*rr)*c(xx$weights) MGti <- apply(MGt,2,sumstrata,id-1,max(id)) ### if (fixbeta==1) uxid <- unique(margsurv$id) ### rownames(MGti) <- uxid theta.iid <- -theta.iid + MGti if (fixbeta==0) theta.iid <- theta.iid + Fbetaiid ## add id's after rownames that may not be exactly the same in marginal model and in pairs for fitting ### if (all.equal(uxid,ucc)==TRUE) { ### theta.iid <- theta.iid + MGti ### if (fixbeta==0) theta.iid <- theta.iid - Fbetaiid ### } else { ### allid <- unique(c(uxid,ucc)) ### theta.iid <- matrix(0,length(allid),ncol(theta.iid)) ### rownames(theta.iid) <- allid ### theta.iid[rownames(score.iid),] <- score.iid ### theta.iid[rownames(MGti),] <- theta.iid[rownames(MGti),] + MGti ### if (fixbeta==0) theta.iid[rownames(MGti),] <- theta.iid[rownames(MGti),]+Fbetaiid ### } out$theta.iid <- -theta.iid } ## }}} } ## }}} if (detail==1 && iid==1) cat("finished iid decomposition\n"); ### for profile solutions update second derivative at final if (numDeriv==2 || ((fix.baseline==0))) { oout <- 3 hess <- numDeriv::jacobian(loglike,p,method="simple") oout <- 2 } } if (numDeriv>=1) { if (detail==1 ) cat("starting numDeriv for second derivative \n"); oout <- 0; score2 <- numDeriv::jacobian(loglike,p) score1 <- matrix(score2,ncol=1) oout <- 3 hess <- numDeriv::jacobian(loglike,p,method="simple") if (detail==1 ) cat("finished numDeriv for second derivative \n"); } if (detail==1 & Nit==0) {## {{{ cat(paste("Fisher-Scoring ===================: final","\n")); cat("theta:");print(c(p)) cat("loglike:");cat(c(out$loglike),"\n"); cat("score:");cat(c(out$score),"\n"); cat("hess:\n"); cat(hess,"\n"); }## }}} if (!is.na(sum(hess))) hessi <- lava::Inverse(hess) else hessi <- diag(nrow(hess)) ## }}} } else if (score.method=="nlminb") { ## {{{ nlminb optimizer oout <- 0; tryCatch(opt <- nlminb(theta,loglike,control=control),error=function(x) NA) if (detail==1) print(opt); if (detail==1 && iid==1) cat("iid decomposition\n"); oout <- 2 theta <- opt$par out <- loglike(opt$par) logl <- out$loglike score1 <- score <- out$score hess1 <- hess <- -1* out$Dscore if (iid==1) { theta.iid <- out$score.iid; score.iid <- out$score.iid } if (numDeriv==1) { if (detail==1 ) cat("numDeriv hessian start\n"); oout <- 3; ## returns score hess <- numDeriv::jacobian(loglike,opt$par) if (detail==1 ) cat("numDeriv hessian done\n"); } hessi <- lava::Inverse(hess); ## }}} } else if (score.method=="optimize" && ptheta==1) { ## {{{ optimizer oout <- 0; if (var.link==1) {mino <- -20; maxo <- 10;} else {mino <- 0.001; maxo <- 100;} tryCatch(opt <- optimize(loglike,c(mino,maxo))); if (detail==1) print(opt); opt$par <- opt$minimum theta <- opt$par if (detail==1 && iid==1) cat("iid decomposition\n"); oout <- 2 out <- loglike(opt$par) logl <- out$loglike score1 <- score <- out$score hess1 <- hess <- -1* out$Dscore if (numDeriv==1) { if (detail==1 ) cat("numDeriv hessian start\n"); oout <- 3; ## to get jacobian hess <- numDeriv::jacobian(loglike,theta) if (detail==1 ) cat("numDeriv hessian done\n"); } hessi <- lava::Inverse(hess); if (iid==1) { theta.iid <- out$score.iid; score.iid <- out$score.iid } ## }}} } else if (score.method=="nlm") { ## {{{ nlm optimizer iid <- 0; oout <- 0; tryCatch(opt <- nlm(loglike,theta,hessian=TRUE,print.level=detail),error=function(x) NA) iid <- 1; hess <- opt$hessian score <- opt$gradient if (detail==1) print(opt); hessi <- lava::Inverse(hess); theta <- opt$estimate if (detail==1 && iid==1) cat("iid decomposition\n"); oout <- 2 out <- loglike(opt$estimate) logl <- out$loglike score1 <- out$score hess1 <- out$Dscore if (iid==1) { theta.iid <- out$score.iid; score.iid <- out$score.iid } ## }}} } else stop("score.methods = optimize(dim=1) nlm nlminb fisher.scoring\n"); ## {{{ handling output loglikeiid <- NULL robvar.theta <- NULL likepairs <- NULL if (fix.baseline==1) { marginal.surv <- psurvmarg; marginal.trunc <- ptrunc; } else { marginal.surv <- out$marginal.surv; marginal.trunc <- out$marginal.trunc;} if (iid==1) { if (dep.model==3 & pair.structure==1) likepairs <- out$likepairs if (dep.model==3 & two.stage==0) {# {{{ hessi <- -1*hessi all.likepairs <- out$all.likepairs colnames(all.likepairs) <- c("surv","dt","ds","dtds","cause1","cause2") }# }}} theta.iid <- -out$theta.iid %*% hessi ### rownames not set to make more robust ### if (is.null(call.secluster)) rownames(theta.iid) <- unique(cluster.call) else rownames(theta.iid) <- unique(se.clusters) robvar.theta <- crossprod(theta.iid) loglikeiid <- out$loglikeiid } else { all.likepairs <- NULL} var.theta <- robvar.theta if (is.null(robvar.theta)) var.theta <- hessi if (!is.null(colnames(theta.des))) thetanames <- colnames(theta.des) else thetanames <- paste("dependence",1:length(theta),sep="") theta <- matrix(theta,length(c(theta)),1) if (length(thetanames)==nrow(theta)) { rownames(theta) <- thetanames; rownames(var.theta) <- colnames(var.theta) <- thetanames; } if (!is.null(logl)) logl <- -1*logl if (convergence.bp==0) theta <- rep(NA,length(theta)) ud <- list(theta=theta,score=score,hess=hess,hessi=hessi,var.theta=var.theta, model=model,robvar.theta=robvar.theta, theta.iid=theta.iid,loglikeiid=loglikeiid,likepairs=likepairs, thetanames=thetanames,loglike=logl,score1=score1,Dscore=out$Dscore, marginal.surv=marginal.surv,marginal.trunc=marginal.trunc, baseline=out$baseline,se=diag(robvar.theta)^.5, score.iid=-score.iid,theta.des=theta.des,random.design=random.design) class(ud) <- "mets.twostage" attr(ud,"response") <- "survival" attr(ud,"Formula") <- formula attr(ud,"clusters") <- clusters attr(ud,"cluster.call") <- cluster.call attr(ud,"secluster") <- c(se.clusters) attr(ud,"sym")<-sym; attr(ud,"var.link")<-var.link; attr(ud,"var.par")<-var.par; attr(ud,"var.func")<-var.func; attr(ud,"ptheta")<-ptheta attr(ud,"antpers")<-antpers; attr(ud,"antclust")<-antclust; attr(ud,"Type") <- model attr(ud,"twostage") <- two.stage attr(ud,"additive-gamma") <- (dep.model==3)*1 if (!is.null(marginal.trunc)) attr(ud,"trunclikeiid")<- out$trunclikeiid if (dep.model==3 & two.stage==0) attr(ud,"all.likepairs")<- all.likepairs if (dep.model==3 ) attr(ud,"additive.gamma.sum") <- additive.gamma.sum #likepairs=likepairs,## if (dep.model==3 & pair.structure==1) attr(ud, "likepairs") <- c(out$likepairs) if (dep.model==3 & pair.structure==0) attr(ud, "pardes") <- theta.des if (dep.model==3 & pair.structure==0) attr(ud, "theta.des") <- theta.des if (dep.model==3 & pair.structure==1) attr(ud, "pardes") <- theta.des[,,1] if (dep.model==3 & pair.structure==1) attr(ud, "theta.des") <- theta.des[,,1] if (dep.model==3 & pair.structure==0) attr(ud, "rv1") <- random.design[1,,drop=FALSE] if (dep.model==3 & pair.structure==1) attr(ud, "rv1") <- random.design[,,1] return(ud); ## }}} } ## }}} ##' @export randomDes <- function(dep.model,random.design,theta.des,theta,antpers,ags,pairs,pairs.rvs,var.link,clusterindex) {# {{{ additive.gamma.sum <- ags if (!is.null(random.design)) { ### different parameters for Additive random effects # {{{ dep.model <- 3 dim.rv <- ncol(random.design); if (is.null(theta.des)) theta.des<-diag(dim.rv); } else { random.design <- matrix(0,1,1); dim.rv <- 1; additive.gamma.sum <- matrix(1,1,1); } if (is.null(theta.des)) ptheta<-1; if (is.null(theta.des)) theta.des<-matrix(1,antpers,ptheta); ### else theta.des<-as.matrix(theta.des); if (length(dim(theta.des))==3) ptheta<-dim(theta.des)[2] else if (length(dim(theta.des))==2) ptheta<-ncol(theta.des) ### if (nrow(theta.des)!=antpers & dep.model!=3 ) stop("Theta design does not have correct dim"); if (length(dim(theta.des))!=3) theta.des <- as.matrix(theta.des) if (is.null(theta)==TRUE) { if (var.link==1) theta<- rep(-0.7,ptheta); if (var.link==0) theta<- rep(exp(-0.7),ptheta); } if (length(theta)!=ptheta) { ### warning("dimensions of theta.des and theta do not match\n"); theta<-rep(theta[1],ptheta); } theta.score<-rep(0,ptheta);Stheta<-var.theta<-matrix(0,ptheta,ptheta); antpairs <- 1; ### to define if (is.null(additive.gamma.sum)) additive.gamma.sum <- matrix(1,dim.rv,ptheta) if (!is.null(pairs)) { pair.structure <- 1;} else pair.structure <- 0; if (pair.structure==1 & dep.model==3) { ## {{{ ### something with dimensions of rv.des antpairs <- nrow(pairs); if ( (length(dim(theta.des))!=3) & (length(dim(random.design))==3) ) { Ptheta.des <- array(0,c(nrow(theta.des),ncol(theta.des),antpairs)) for (i in 1:antpairs) Ptheta.des[,,i] <- theta.des theta.des <- Ptheta.des } if ( (length(dim(theta.des))==3) & (length(dim(random.design))!=3) ) { rv.des <- array(0,c(2,ncol(random.design),antpairs)) for (i in 1:antpairs) { rv.des[1,,i] <- random.design[pairs[i,1],] rv.des[2,,i] <- random.design[pairs[i,2],] } random.design <- rv.des } if ( (length(dim(theta.des))!=3) & (length(dim(random.design))!=3) ) { Ptheta.des <- array(0,c(nrow(theta.des),ncol(theta.des),antpairs)) rv.des <- array(0,c(2,ncol(random.design),antpairs)) for (i in 1:antpairs) { rv.des[1,,i] <- random.design[pairs[i,1],] rv.des[2,,i] <- random.design[pairs[i,2],] Ptheta.des[,,i] <- theta.des } theta.des <- Ptheta.des random.design <- rv.des } if (max(pairs)>antpers) stop("Indices of pairs should refer to given data \n"); if (is.null(pairs.rvs)) pairs.rvs <- rep(dim(random.design)[2],antpairs) clusterindex <- pairs-1; } ## }}} if (pair.structure==1 & dep.model!=3) { clusterindex <- pairs-1; antpairs <- nrow(pairs); pairs.rvs <- 1 }# }}} if (is.null(pairs.rvs)) pairs.rvs <- 1 return(list(random.design=random.design,clusterindex=clusterindex, antpairs=antpairs,pair.structure=pair.structure, dep.model=dep.model,dim.rv=dim.rv, additive.gamma.sum=additive.gamma.sum, pairs.rvs=pairs.rvs,theta=theta,ptheta=ptheta,theta.des=theta.des)) }# }}} readmargsurv <- function(margsurv,data,clusters) {# {{{ start.time <- 0 if (class(margsurv)=="aalen" || class(margsurv)=="cox.aalen") {# {{{ formula<-attr(margsurv,"Formula"); beta.fixed <- attr(margsurv,"beta.fixed") if (is.null(beta.fixed)) beta.fixed <- 1; ldata<-aalen.des(formula,data=data,model="cox.aalen"); id <- attr(margsurv,"id"); mclusters <- attr(margsurv,"cluster.call") X<-ldata$X; time<-ldata$time2; Z<-ldata$Z; status<-ldata$status; time2 <- attr(margsurv,"stop"); start.time <- attr(margsurv,"start") antpers<-nrow(X); if (is.null(Z)==TRUE) {npar<-TRUE; semi<-0;} else { Z<-as.matrix(Z); npar<-FALSE; semi<-1;} if (npar==TRUE) {Z<-matrix(0,antpers,1); pz<-1; fixed<-0;} else {fixed<-1;pz<-ncol(Z);} px<-ncol(X); if (is.null(clusters) && is.null(mclusters)) stop("No cluster variabel specified in marginal or twostage call\n"); if (is.null(clusters)) clusters <- mclusters if (nrow(X)!=length(clusters)) stop("Length of Marginal survival data not consistent with cluster length\n"); # }}} } else if (class(margsurv)=="phreg") { # {{{ ### setting up newdata with factors and strata antpers <- nrow(data) rr <- readPhreg(margsurv,data,nr=FALSE) time2 <- rr$exit if (!is.null(rr$entry)) start.time <- rr$entry else start.time <- rep(0,antpers); status <- rr$status if (is.null(clusters)) clusters <- rr$clusters ### clusters <- rr$clusters ### print(lapply(rr,summary)) # }}} } else { ### coxph {{{ antpers <- margsurv$n id <- 0:(antpers-1) mt <- model.frame(margsurv) Y <- model.extract(mt, "response") if (!inherits(Y, "Surv")) stop("Response must be a survival object") if (attr(Y, "type") == "right") { time2 <- Y[, "time"]; status <- Y[, "status"] start.time <- rep(0,antpers); } else { start.time <- Y[, 1]; time2 <- Y[, 2]; status <- Y[, 3]; } ### Z <- na.omit(model.matrix(margsurv)[,-1]) ## Discard intercept Z <- matrix(1,antpers,length(coef(margsurv))); if (is.null(clusters)) stop("must give clusters for coxph\n"); cluster.call <- clusters; X <- matrix(1,antpers,1); ### Z <- matrix(0,antpers,1); ### no use for these px <- 1; pz <- ncol(Z); start <- rep(0,antpers); beta.fixed <- 0 semi <- 1 }# }}} if (!is.null(start.time)) { if (any(abs(start.time)>0)) lefttrunk <- 1 else lefttrunk <- 0; } else lefttrunk <- 0 if (!is.null(margsurv)) { if (class(margsurv)=="aalen" || class(margsurv)=="cox.aalen") { # {{{ resi <- residualsTimereg(margsurv,data=data) RR <- resi$RR cum <- resi$cumhaz/RR psurvmarg <- exp(-resi$cumhaz); ptrunc <- rep(1,length(psurvmarg)); if (lefttrunk==1) ptrunc <- exp(-resi$cumhazleft); # }}} } else if (class(margsurv)=="coxph") { # {{{ ### some problems here when data is different from data used in margsurv residuals <- residuals(margsurv) cum <- cumhaz <- status-residuals psurvmarg <- exp(-cumhaz); cumhazleft <- rep(0,antpers) ptrunc <- rep(1,length(psurvmarg)); RR<- exp(margsurv$linear.predictors+sum(margsurv$means*coef(margsurv))) cum <- cum/RR if ((lefttrunk==1)) { stop("Use cox.aalen function for truncation case \n"); baseout <- survival::basehaz(margsurv,centered=FALSE); cumt <- cbind(baseout$time,baseout$hazard) cumt <- Cpred(cumt,start.time)[,2] ptrunc <- exp(-cumt * RR) }# }}} } else if (class(margsurv)=="phreg") { ppsurvmarg <- predict(margsurv,data,tminus=TRUE,times=time2,individual.time=TRUE,se=FALSE) psurvmarg <- ppsurvmarg$surv cum <- ppsurvmarg$cumhaz RR <- ppsurvmarg$RR ptrunc <- rep(1,length(psurvmarg)); if ((lefttrunk==1)) { ptrunc <- predict(margsurv,data,tminus=TRUE,times=start.time,individual.time=TRUE,se=FALSE)$surv } } } if (is.null(clusters) & class(margsurv)!="phreg") stop("must give clusters") return(list(psurvmarg=psurvmarg,ptrunc=ptrunc,entry=start.time,exit=time2, status=status,clusters=clusters,cum=cum,RR=RR)) } ## }}} ###survival.twostageG <- function(margsurv,data=sys.parent(),score.method="fisher.scoring",Nit=60,detail=0,clusters=NULL, ### silent=1,weights=NULL, control=list(),theta=NULL,theta.des=NULL, ### var.link=1,iid=1,step=0.5,notaylor=0,model="clayton.oakes", ### marginal.trunc=NULL,marginal.survival=NULL,marginal.status=NULL,strata=NULL, ### se.clusters=NULL,numDeriv=0,random.design=NULL,pairs=NULL,pairs.rvs=NULL,numDeriv.method="simple", ### additive.gamma.sum=NULL,var.par=1,cr.models=NULL,case.control=0,ascertained=0,shut.up=0) ###{## {{{ ##### {{{ seting up design and variables ###score.iid <- NULL; two.stage <- 1; rate.sim <- 1; sym=1; var.func <- NULL ###if (model=="clayton.oakes" || model=="gamma") dep.model <- 1 ###else if (model=="plackett" || model=="or") dep.model <- 2 ###else stop("Model must by either clayton.oakes or plackett \n"); ###start.time <- NULL; ptrunc <- NULL; psurvmarg <- NULL; status <- NULL ###fix.baseline <- 0; ###convergence.bp <- 1; ### to control if baseline profiler converges ###if ((!is.null(margsurv)) | (!is.null(marginal.survival))) fix.baseline <- 1 ### ### ###if (!is.null(margsurv)) { ###if (class(margsurv)=="aalen" || class(margsurv)=="cox.aalen") { ## {{{ ### formula<-attr(margsurv,"Formula"); ### beta.fixed <- attr(margsurv,"beta.fixed") ### if (is.null(beta.fixed)) beta.fixed <- 1; ### ldata<-aalen.des(formula,data=data,model="cox.aalen"); ### id <- attr(margsurv,"id"); ### mclusters <- attr(margsurv,"cluster.call") ### X<-ldata$X; ### time<-ldata$time2; ### Z<-ldata$Z; ### status<-ldata$status; ### time2 <- attr(margsurv,"stop"); ### start.time <- attr(margsurv,"start") ### antpers<-nrow(X); ### if (is.null(Z)==TRUE) {npar<-TRUE; semi<-0;} else { Z<-as.matrix(Z); npar<-FALSE; semi<-1;} ### if (npar==TRUE) {Z<-matrix(0,antpers,1); pz<-1; fixed<-0;} else {fixed<-1;pz<-ncol(Z);} ### px<-ncol(X); ### ### if (is.null(clusters) && is.null(mclusters)) stop("No cluster variabel specified in marginal or twostage call\n"); ### if (is.null(clusters)) clusters <- mclusters ### if (nrow(X)!=length(clusters)) stop("Length of Marginal survival data not consistent with cluster length\n"); ##### }}} ### } else if (class(margsurv)=="phreg") { ## {{{ ### antpers <- length(margsurv$id) ### start.time <- margsurv$entry ###} else { ### coxph ## {{{ ### notaylor <- 1 ### antpers <- margsurv$n ### id <- 0:(antpers-1) ### mt <- model.frame(margsurv) ### Y <- model.extract(mt, "response") ### if (!inherits(Y, "Surv")) stop("Response must be a survival object") ### if (attr(Y, "type") == "right") { ### time2 <- Y[, "time"]; ### status <- Y[, "status"] ### start.time <- rep(0,antpers); ### } else { ### start.time <- Y[, 1]; ### time2 <- Y[, 2]; ### status <- Y[, 3]; ### } ###### Z <- na.omit(model.matrix(margsurv)[,-1]) ## Discard intercept ### Z <- matrix(1,antpers,length(coef(margsurv))); ### ### if (is.null(clusters)) stop("must give clusters for coxph\n"); ### cluster.call <- clusters; ### X <- matrix(1,antpers,1); ### Z <- matrix(0,antpers,1); ### no use for these ### px <- 1; pz <- ncol(Z); ### start <- rep(0,antpers); ### beta.fixed <- 0 ### semi <- 1 ###### start.time <- 0 ###} ## }}} ###} else { start.time<- 0} ### ######print("00"); print(summary(psurvmarg)); print(summary(ptrunc)) ### ### if (any(abs(start.time)>0)) lefttrunk <- 1 else lefttrunk <- 0 ### if (!is.null(start.time)) { ### if (any(abs(start.time)>0)) lefttrunk <- 1 else lefttrunk <- 0; ### } else lefttrunk <- 0 ### ###if (!is.null(margsurv)) { ### if (class(margsurv)=="aalen" || class(margsurv)=="cox.aalen") { ## {{{ ### resi <- residualsTimereg(margsurv,data=data) ### RR <- resi$RR ### psurvmarg <- exp(-resi$cumhaz); ### ptrunc <- rep(1,length(psurvmarg)); ### if (lefttrunk==1) ptrunc <- exp(-resi$cumhazleft); ### } ## }}} ### else if (class(margsurv)=="coxph") { ## {{{ ### ### some problems here when data is different from data used in margsurv ### notaylor <- 1 ### residuals <- residuals(margsurv) ### cumhaz <- status-residuals ### psurvmarg <- exp(-cumhaz); ### cumhazleft <- rep(0,antpers) ### ptrunc <- rep(1,length(psurvmarg)); ### RR<- exp(margsurv$linear.predictors-sum(margsurv$means*coef(margsurv))) ### if ((lefttrunk==1)) { ### stop("Use cox.aalen function for truncation case \n"); ### baseout <- survival::basehaz(margsurv,centered=FALSE); ### cum <- cbind(baseout$time,baseout$hazard) ### cum <- Cpred(cum,start.time)[,2] ### ptrunc <- exp(-cum * RR) ### } ### } ### else if (class(margsurv)=="phreg") { ## {{{ ### xx <- margsurv$cox.prep ### S0i2 <- S0i <- rep(0,length(xx$strata)) ### S0i[xx$jumps+1] <- 1/margsurv$S0 ### if (!is.null(margsurv$coef)) ### rr <- c(exp(margsurv$X %*% margsurv$coef)) ### else rr <- rep(1,antpers) ###### ### back to original order ### cumhazt <- cumsumstratasum(S0i,xx$strata,xx$nstrata)$lagsum ### orig.o <- (1:nrow(xx$X))[xx$ord+1] ### bto <- order(orig.o) ### cumhazt <- cumhazt[bto] ### psurvmarg <- c(exp(-cumhazt*rr)) ### ptrunc <- rep(1,length(psurvmarg)); ### start.time <- c(margsurv$entry) ### status <- c(margsurv$status) ### } ## }}} ###} ## }}} ### ###### print(head(cbind(psurvmarg,status))) ### ### antpers <- nrow(data); ## mydim(marginal.survival)[1] ### RR <- rep(1,antpers); ### ### if (is.null(psurvmarg)) psurvmarg <- rep(1,antpers); ### if (!is.null(marginal.survival)) psurvmarg <- marginal.survival ### if (!is.null(marginal.trunc)) ptrunc <- marginal.trunc ### if (is.null(ptrunc)) ptrunc <- rep(1,length(psurvmarg)) ### ###### print(summary(psurvmarg)); print(summary(ptrunc)) ### ### if (!is.null(marginal.status)) status <- marginal.status ### if (is.null(status) & is.null(cr.models)) stop("must give status variable for survival via either margninal model (margsurv), marginal.status or as cr.models \n"); ### ### if (is.null(weights)==TRUE) weights <- rep(1,antpers); ### if (is.null(strata)==TRUE) strata<- rep(1,antpers); ### if (length(strata)!=antpers) stop("Strata must have length equal to number of data points \n"); ### ### ## {{{ cluster set up ### cluster.call <- clusters ### out.clust <- cluster.index(clusters); ### clusters <- out.clust$clusters ### maxclust <- out.clust$maxclust ### antclust <- out.clust$cluster.size ### clusterindex <- out.clust$idclust ### clustsize <- out.clust$cluster.size ### call.secluster <- se.clusters ### ### if (is.null(se.clusters)) { se.clusters <- clusters; antiid <- nrow(clusterindex);} else { ### iids <- unique(se.clusters); ### antiid <- length(iids); ### if (is.numeric(se.clusters)) se.clusters <- fast.approx(iids,se.clusters)-1 ### else se.clusters <- as.integer(factor(se.clusters, labels = seq(antiid)))-1 ### } ### if (length(se.clusters)!=length(clusters)) stop("Length of seclusters and clusters must be same\n"); ### ###### if ((!is.null(max.clust))) if (max.clust< antiid) { ###### coarse.clust <- TRUE ###### qq <- unique(quantile(se.clusters, probs = seq(0, 1, by = 1/max.clust))) ###### qqc <- cut(se.clusters, breaks = qq, include.lowest = TRUE) ###### se.clusters <- as.integer(qqc)-1 ###### max.clusters <- length(unique(se.clusters)) ###### maxclust <- max.clust ###### antiid <- max.clusters ###### } ### ## }}} ### ###### pxz <- px + pz; ### ### if (!is.null(random.design)) { ### different parameters for Additive random effects # {{{ ### dep.model <- 3 ### ###### if (is.null(random.design)) random.design <- matrix(1,antpers,1); ### dim.rv <- ncol(random.design); ### if (is.null(theta.des)) theta.des<-diag(dim.rv); ### ### ###### ptheta <- dimpar <- ncol(theta.des); ###### if (dim(theta.des)[2]!=ncol(random.design)) ###### stop("nrow(theta.des)!= ncol(random.design),\nspecifies restrictions on paramters, if theta.des not given =diag (free)\n"); ### } else { random.design <- matrix(0,1,1); dim.rv <- 1; ### additive.gamma.sum <- matrix(1,1,1); ### } ### ### if (is.null(theta.des)) ptheta<-1; ### if (is.null(theta.des)) theta.des<-matrix(1,antpers,ptheta); ### else theta.des<-as.matrix(theta.des); ###### ptheta<-ncol(theta.des); ###### if (nrow(theta.des)!=antpers) stop("Theta design does not have correct dim"); ### ### if (length(dim(theta.des))==3) ptheta<-dim(theta.des)[2] else if (length(dim(theta.des))==2) ptheta<-ncol(theta.des) ### if (nrow(theta.des)!=antpers & dep.model!=3 ) stop("Theta design does not have correct dim"); ### ### if (length(dim(theta.des))!=3) theta.des <- as.matrix(theta.des) ### ### if (is.null(theta)==TRUE) { ### if (var.link==1) theta<- rep(-0.7,ptheta); ### if (var.link==0) theta<- rep(exp(-0.7),ptheta); ### } ### ### if (length(theta)!=ptheta) { ###### warning("dimensions of theta.des and theta do not match\n"); ###### print(theta); ### theta<-rep(theta[1],ptheta); ### } ### theta.score<-rep(0,ptheta);Stheta<-var.theta<-matrix(0,ptheta,ptheta); ### ### if (maxclust==1) stop("No clusters, maxclust size=1\n"); ### ### antpairs <- 1; ### to define ### if (is.null(additive.gamma.sum)) additive.gamma.sum <- matrix(1,dim.rv,ptheta) ### ### if (!is.null(pairs)) { pair.structure <- 1;} else pair.structure <- 0; ### ##### ppprint ###### print(c(pair.structure,dep.model,fix.baseline)) ###### print(head(theta.des)) ###### print(c(case.control,ascertained)) ### ### if (pair.structure==1 & dep.model==3) { ## {{{ ###### something with dimensions of rv.des ###### theta.des ### antpairs <- nrow(pairs); ### if ( (length(dim(theta.des))!=3) & (length(dim(random.design))==3) ) ### { ### Ptheta.des <- array(0,c(nrow(theta.des),ncol(theta.des),antpairs)) ### for (i in 1:antpairs) Ptheta.des[,,i] <- theta.des ### theta.des <- Ptheta.des ### } ### if ( (length(dim(theta.des))==3) & (length(dim(random.design))!=3) ) ### { ### rv.des <- array(0,c(2,ncol(random.design),antpairs)) ### for (i in 1:antpairs) { ### rv.des[1,,i] <- random.design[pairs[i,1],] ### rv.des[2,,i] <- random.design[pairs[i,2],] ### } ### random.design <- rv.des ### } ### if ( (length(dim(theta.des))!=3) & (length(dim(random.design))!=3) ) ### { ###### print("laver 3-dim design "); ### Ptheta.des <- array(0,c(nrow(theta.des),ncol(theta.des),antpairs)) ### rv.des <- array(0,c(2,ncol(random.design),antpairs)) ### for (i in 1:antpairs) { ### rv.des[1,,i] <- random.design[pairs[i,1],] ### rv.des[2,,i] <- random.design[pairs[i,2],] ### Ptheta.des[,,i] <- theta.des ### } ### theta.des <- Ptheta.des ### random.design <- rv.des ### } ### if (max(pairs)>antpers) stop("Indices of pairs should refer to given data \n"); ### if (is.null(pairs.rvs)) pairs.rvs <- rep(dim(random.design)[2],antpairs) ###### if (max(pairs.rvs)> dim(random.design)[3] | max(pairs.rvs)>ncol(theta.des[1,,])) ###### stop("random variables for each cluster higher than possible, pair.rvs not consistent with random.design or theta.des\n"); ### clusterindex <- pairs-1; ### } ## }}} ### ### if (pair.structure==1 & dep.model!=3) { ### clusterindex <- pairs-1; ### antpairs <- nrow(pairs); ### pairs.rvs <- 1 ### }# }}} ### ### ## }}} ### ###### setting up arguments for Aalen baseline profile estimates ### if (fix.baseline==0) { ## {{{ when baseline is estimated when baseline is estimated ### if (is.null(cr.models)) stop("give hazard models for different causes, ex cr.models=list(Surv(time,status==1)~+1,Surv(time,status==2)~+1) \n") ### ### if (case.control==0 & ascertained==0) { ## {{{ ##### {{{ setting up random effects and covariates for marginal modelling ### timestatus <- all.vars(cr.models[[1]]) ### times <- data[,timestatus[1]] ### if (is.null(status)) status <- data[,timestatus[2]] ### lstatus <- data[,timestatus[2]] ### ### organize increments according to overall jump-times ### jumps <- lstatus!=0 ### dtimes <- times[jumps] ### st <- order(dtimes) ### dtimesst <- dtimes[st] ### dcauses <- lstatus[jumps][st] ### ids <- (1:nrow(data))[jumps][st] ### ### nc <- 0 ### for (i in 1:length(cr.models)) { ### a2 <- aalen.des(as.formula(cr.models[[i]]),data=data) ### X <- a2$X ### nc <- nc+ncol(X) ### } ### dBaalen <- matrix(0,length(dtimes),nc) ### xjump <- array(0,c(length(cr.models),nc,length(ids))) ### ### ## first compute marginal aalen models for all causes ### a <- list(); da <- list(); ### for (i in 1:length(cr.models)) { ### a[[i]] <- aalen(as.formula(cr.models[[i]]),data=data,robust=0,weights=weights) ### a2 <- aalen.des(as.formula(cr.models[[i]]),data=data) ### X <- a2$X ### da[[i]] <- apply(a[[i]]$cum[,-1,drop=FALSE],2,diff) ### jumpsi <- (1:length(dtimes))[dcauses==i] ### if (i==1) fp <- 1 ### indexc <- fp:(fp+ncol(X)-1) ### dBaalen[jumpsi,indexc] <- da[[i]] ### xjump[i,indexc,] <- t(X[ids,]) ### fp <- ncol(X)+1 ### } ### ### ## }}} ### ### #### organize subject specific random variables and design ### ### for additive gamma model ### ## {{{ ### dimt <- dim(theta.des[,,1,drop=FALSE])[-3] ### dimr <- dim(random.design[,,,drop=FALSE]) ### mtheta.des <- array(0,c(dimt,nrow(data))) ### mrv.des <- array(0,c(dimr[1]/2,dimr[2],nrow(data))) ### nrv.des <- rep(0,nrow(data)) ### nrv.des[pairs[,1]] <- pairs.rvs ### nrv.des[pairs[,2]] <- pairs.rvs ### mtheta.des[,,pairs[,1]] <- theta.des ### mtheta.des[,,pairs[,2]] <- theta.des ### mrv.des[,,pairs[,1]] <- random.design[1:(dimr[1]/2),,,drop=FALSE] ### mrv.des[,,pairs[,2]] <- random.design[(dimr[1]/2+1):dimr[1],,,drop=FALSE] ### ### array thetades to jump times (subjects) ### mtheta.des <- mtheta.des[,,ids,drop=FALSE] ### ### array randomdes to jump times (subjects) ### mrv.des <- mrv.des[,,ids,drop=FALSE] ### nrv.des <- pairs.rvs[ids] ### ## }}} ### ###### #### organize subject specific random variables and design ###### ### for additive gamma model ###### ## {{{ ###### dimt <- dim(theta.des[,,1]) ###### dimr <- dim(random.design[,,]) ###### mtheta.des <- array(0,c(dimt,nrow(data))) ###### mrv.des <- array(0,c(dimr[1]/2,dimr[2],nrow(data))) ###### mtheta.des[,,pairs[,1]] <- theta.des ###### mtheta.des[,,pairs[,2]] <- theta.des ###### mrv.des[,,pairs[,1]] <- random.design[1:(dimr[1]/2),,,drop=FALSE] ###### mrv.des[,,pairs[,2]] <- random.design[(dimr[1]/2+1):dimr[1],,,drop=FALSE] ###### nrv.des <- rep(0,nrow(data)) ###### nrv.des[pairs[,1]] <- pairs.rvs ###### nrv.des[pairs[,2]] <- pairs.rvs ###### ### array thetades to jump times (subjects) ###### mtheta.des <- mtheta.des[,,ids,drop=FALSE] ###### ### array randomdes to jump times (subjects) ###### mrv.des <- mrv.des[,,ids,drop=FALSE] ###### nrv.des <- pairs.rvs[ids] ###### ## }}} ### ### } ## }}} ### ### if (case.control==1 || ascertained==1) { ## {{{ ### ###### print(dim(data)); print(summary(pairs)) ### data1 <- data[pairs[,1],] ### data.proband <- data[pairs[,2],] ### weights1 <- weights[pairs[,1]] ###### print(summary(data.proband)); print(summary(data1)) ### ##### {{{ setting up designs for jump times ### timestatus <- all.vars(cr.models[[1]]) ### if (is.null(status)) status <- data[,timestatus[2]] ### alltimes <- data[,timestatus[1]] ### times <- data1[,timestatus[1]] ### lstatus <- data1[,timestatus[2]] ### timescase <- data.proband[,timestatus[1]] ### lstatuscase <- data.proband[,timestatus[2]] ### ### organize increments according to overall jump-times ### jumps <- lstatus!=0 ### dtimes <- times[jumps] ### dtimescase <- timescase[jumps] ### st <- order(dtimes) ### dtimesst <- dtimes[st] ### dtimesstcase <- dtimescase[st] ### dcauses <- lstatus[jumps][st] ### dcausescase <- lstatuscase[jumps][st] ### ids <- (1:nrow(data1))[jumps][st] ### ### ### ### delayed entry for case because of ascertained sampling ### ### controls are however control probands, and have entry=0 ### entry <- timescase*lstatuscase ### data1$entry <- entry ### cr.models2 <- list() ### if (ascertained==1) { ### for (i in 1:length(cr.models)) { ### cr.models2[[i]] <- update(cr.models[[i]],as.formula(paste("Surv(entry,",timestatus[1],",",timestatus[2],")~.",sep=""))) ### } ### } else cr.models2 <- cr.models ### ### nc <- 0 ### for (i in 1:length(cr.models)) { ### X <- aalen.des(as.formula(cr.models[[i]]),data=data1)$X ### nc <- nc+ncol(X) ### } ### dBaalen <- matrix(0,length(dtimes),nc) ### xjump <- array(0,c(length(cr.models),nc,length(ids))) ### xjumpcase <- array(0,c(length(cr.models),nc,length(ids))) ### ### ## first compute marginal aalen models for all causes ### a <- list(); da <- list(); ### ### starting values for iteration ### Bit <- Bitcase <- c() ### for (i in 1:length(cr.models)) { ## {{{ ### a[[i]] <- aalen(as.formula(cr.models2[[i]]),data=data1,robust=0,weights=weights1) ### da[[i]] <- apply(a[[i]]$cum[,-1,drop=FALSE],2,diff) ### jumpsi <- (1:length(dtimes))[dcauses==i] ### X <- aalen.des(as.formula(cr.models[[i]]),data=data1)$X ### Xcase <- aalen.des(as.formula(cr.models[[i]]),data=data.proband)$X ### if (i==1) fp <- 1 ### indexc <- fp:(fp+ncol(X)-1) ### dBaalen[jumpsi,indexc] <- da[[i]] ### xjump[i,indexc,] <- t(X[ids,]) ### xjumpcase[i,indexc,] <- t(Xcase[ids,]) ### fp <- fp+ncol(X) ### ### starting values ### Bit <- cbind(Bit,Cpred(a[[i]]$cum,dtimesst)[,-1,drop=FALSE]) ### } ## }}} ### Bit.ini <- Bit ### ## }}} ### ####### organize subject specific random variables and design ####### already done in basic pairwise setup ### mtheta.des <- theta.des[,,ids,drop=FALSE] ### ### array randomdes to jump times (subjects) ### mrv.des <- random.design[,,ids,drop=FALSE] ### nrv.des <- pairs.rvs[ids] ### } ## }}} ### ### } else { ### mrv.des <- array(0,c(1,1,1)); mtheta.des <- array(0,c(1,1,1)); margthetades <- array(0,c(1,1,1)); ### xjump <- array(0,c(1,1,1)); dBaalen <- matrix(0,1,1); nrv.des <- 3 ### } ## }}} ### ### loglike <- function(par) ### { ## {{{ ### ### if (pair.structure==0 | dep.model!=3) Xtheta <- as.matrix(theta.des) %*% matrix(c(par),nrow=ptheta,ncol=1); ### if (pair.structure==1 & dep.model==3) Xtheta <- matrix(0,antpers,1); ## not needed ### DXtheta <- array(0,c(1,1,1)); ### ### if (var.link==1 & dep.model==3) epar <- c(exp(par)) else epar <- c(par) ### partheta <- epar ### ### if (var.par==1 & dep.model==3) { ### ## from variances to ### if (is.null(var.func)) { ### sp <- sum(epar) ### partheta <- epar/sp^2 ### } else partheta <- epar ## par.func(epar) ### } ### ### ### if (pair.structure==0) { ### outl<-.Call("twostageloglikeRV", ## {{{ only two stage model for this option ### icause=status,ipmargsurv=psurvmarg, ### itheta=c(partheta),iXtheta=Xtheta,iDXtheta=DXtheta,idimDX=dim(DXtheta),ithetades=theta.des, ### icluster=clusters,iclustsize=clustsize,iclusterindex=clusterindex, ### ivarlink=var.link,iid=iid,iweights=weights,isilent=silent,idepmodel=dep.model, ### itrunkp=ptrunc,istrata=as.numeric(strata),iseclusters=se.clusters,iantiid=antiid, ### irvdes=random.design,iags=additive.gamma.sum,iascertained=ascertained, ### PACKAGE="mets") ## }}} ### } ### else { ## pair-structure ### ## twostage model, case.control option, profile out baseline ### ## conditional model, case.control option, profile out baseline ### if (fix.baseline==0) ## if baseline is not given ### { ### cum1 <- cbind(dtimesst,Bit) ### if ( (case.control==1 || ascertained==1) & (convergence.bp==1)) { ## {{{ profiles out baseline under case-control/ascertainment sampling ### ###### ## initial values , only one cr.model for survival ###### Bit <- cbind(Cpred(a[[1]]$cum,dtimesst)[,-1]) ### if (detail>1) plot(dtimesst,Bit,type="l",main="Bit") ### ### if (ncol(Bit)==0) Bit <- Bit.ini ### Bitcase <- Cpred(cbind(dtimesst,Bit),dtimesstcase)[,-1,drop=FALSE] ### Bitcase <- .Call("MatxCube",Bitcase,dim(xjumpcase),xjumpcase,PACKAGE="mets")$X ### ### for (j in 1:5) { ## {{{ profile via iteration ### cncc <- .Call("BhatAddGamCC",1,dBaalen,dcauses,dim(xjump),xjump, ### c(partheta),dim(mtheta.des),mtheta.des,additive.gamma.sum,var.link, ### dim(mrv.des),mrv.des,nrv.des,1,Bit,Bitcase,dcausescase,PACKAGE="mets") ### d <- max(abs(Bit-cncc$B)) ### if (detail>1) print(d) ### Bit <- cncc$B ###### if (detail>1) print(c(par,epar,partheta)); ###### if (detail>1) print(summary(Bit)); ### if (detail>1) print(summary(cncc$caseweights)) ### cum1 <- cbind(dtimesst,cncc$B) ### Bitcase <-cbind(Cpred(cum1,dtimesstcase)[,-1]) ###### if (detail>1) print(summary(Bitcase)) ### if (detail>1) lines(dtimesst,Bit,col=j+1); ### if (is.na(d)) { ### if (shut.up==0) cat("Baseline profiler gives missing values\n"); ### Bit <- Bit.ini; cum1 <- cbind(dtimesst,Bit); convergence.bp <<- 0; break; ### } ### Bitcase <- .Call("MatxCube",Bitcase,dim(xjumpcase),xjumpcase,PACKAGE="mets")$X ### if (d<0.00001) break; ### } ## }}} ### ### ### nulrow <- rep(0,ncol(Bit)+1) ### pbases <- Cpred(rbind(nulrow,cbind(dtimesst,Bit)),alltimes)[,-1,drop=FALSE] ### X <- aalen.des(as.formula(cr.models[[1]]),data=data)$X ### psurvmarg <- exp(-apply(X*pbases,1,sum)) ## psurv given baseline ### if (ascertained==1) { ### Xcase <- aalen.des(as.formula(cr.models[[1]]),data=data.proband)$X ### X <- aalen.des(as.formula(cr.models[[1]]),data=data1)$X ### pba.case <- Cpred(rbind(nulrow,cbind(dtimesst,Bit)),entry)[,-1,drop=FALSE] ### ptrunc <- rep(0,nrow(data)) ### ### for control probands ptrunc=1, thus no adjustment ### ptrunc[pairs[,1]] <- exp(-apply(X* pba.case,1,sum)*lstatuscase) ## delayed entry at time of ascertainment proband ### ptrunc[pairs[,2]] <- exp(-apply(Xcase*pba.case,1,sum)*lstatuscase) ### } ###### print(head(cbind(psurvmarg,ptrunc))) ###### print(summary(psurvmarg)) ###### print(summary(ptrunc)) ###### print(dim(pbases)); ### ### } ## }}} ### } ### ###### browser() ###### print(dim(random.design)) ###### print(summary(status)); print(summary(psurvmarg)); print(summary(clusters)); print(summary(random.design)); ###### print(random.design) ###### print(theta.des) ### ### outl<-.Call("twostageloglikeRVpairs", ## {{{ ### icause=status,ipmargsurv=psurvmarg, ### itheta=c(partheta),iXtheta=Xtheta,iDXtheta=DXtheta,idimDX=dim(DXtheta), ### ithetades=theta.des, ### icluster=clusters,iclustsize=clustsize,iclusterindex=clusterindex, ### ivarlink=var.link,iiid=iid,iweights=weights,isilent=silent,idepmodel=dep.model, ### itrunkp=ptrunc,istrata=as.numeric(strata),iseclusters=se.clusters,iantiid=antiid, ### irvdes=random.design, ### idimthetades=dim(theta.des),idimrvdes=dim(random.design),irvs=pairs.rvs,iags=additive.gamma.sum, ### iascertained=ascertained,PACKAGE="mets") ### ## }}} ### ### ### if (fix.baseline==0) { ### outl$baseline <- cum1; ### outl$marginal.surv <- psurvmarg; ### outl$marginal.trunc <- ptrunc ### } ### ### } ## }}} ### ### if (detail==3) print(c(partheta,outl$loglike)) ### ### ## variance parametrization, and inverse.link ### if (dep.model==3) {# {{{ ### if (var.par==1) { ### ## from variances to and with sum for all random effects ### if (is.null(var.func)) { ### if (var.link==0) { ###### print(c(sp,epar)) ### mm <- matrix(-epar*2*sp,length(epar),length(epar)) ### diag(mm) <- sp^2-epar*2*sp ###### print(mm) ### } else { ### mm <- -c(epar) %o% c(epar)*2*sp ### diag(mm) <- epar*sp^2-epar^2*2*sp ###### print(mm) ### } ### mm <- mm/sp^4 ### } else mm <- numDeriv::hessian(var.func,par) ### } else { ### if (var.link==0) mm <- diag(length(epar)) else ### mm <- diag(length(c(epar)))*c(epar) ### } ### }# }}} ### ###### print(c(var.link,dep.model,var.par)) ###### print("hh"); print(mm); print(outl$score) ### ### if (dep.model==3) {# {{{ ### outl$score <- t(mm) %*% outl$score ### outl$Dscore <- t(mm) %*% outl$Dscore %*% mm ### if (iid==1) { outl$theta.iid <- t(t(mm) %*% t(outl$theta.iid)) ### if (class(margsurv)=="phreg") { ###### print(dim(mm)) ### outl$D1thetal <- t(t(mm) %*% t(outl$D1thetal)) ### outl$D2thetal <- t(t(mm) %*% t(outl$D2thetal)) ### } ### } ### ###### print(crossprod(outl$theta.iid)); print(outl$Dscore) ###### print(c(outl$score)) ###### print(apply(outl$theta.iid,2,sum)) ### }# }}} ### ### attr(outl,"gradient") <-outl$score ### if (oout==0) ret <- c(-1*outl$loglike) else if (oout==1) ret <- sum(outl$score^2) else if (oout==2) ret <- outl else ret <- outl$score ### return(ret) ### } ## }}} ### ### if (score.method=="optimize" && ptheta!=1) { ### cat("optimize only works for d==1, score.mehod set to nlminb \n"); ### score.method <- "nlminb"; ### } ### ### score1 <- NULL ### theta.iid <- NULL ### logl <- NULL ### p <- theta ### ### if (score.method=="fisher.scoring") { ## {{{ ### oout <- 2; ### output control for obj ### if (Nit>0) ### for (i in 1:Nit) ### { ### out <- loglike(p) ### ## updating starting values for cumulative baselines ### if (fix.baseline==0) Bit <- out$baseline[,-1,drop=FALSE] ### if (fix.baseline==1) hess <- out$Dscore ### ### uses simple second derivative for computing derivative of score ### if (numDeriv==2 || (((fix.baseline==0)) & (i==1))) { ### oout <- 3 ### hess <- numDeriv::jacobian(loglike,p,method="simple") ### oout <- 2 ### } ### if (!is.na(sum(hess))) hessi <- lava::Inverse(hess) else hessi <- hess ### if (detail==1) {## {{{ ### cat(paste("Fisher-Scoring ===================: it=",i,"\n")); ### cat("theta:");print(c(theta)) ### cat("loglike:");cat(c(out$loglike),"\n"); ### cat("score:");cat(c(out$score),"\n"); ### cat("hess:\n"); cat(hess,"\n"); ### }## }}} ### delta <- step*( hessi %*% out$score ) ### ### update p, but note that score and derivative in fact related to previous p ### ### unless Nit=0, ### if (Nit>0) { ### p <- p - delta ### theta <- p; ### } ### if (is.nan(sum(out$score))) break; ### if (sum(abs(out$score))<0.00001) break; ### if (max(theta)>20 & var.link==1) { cat("theta too large lacking convergence \n"); break; } ### } ### if (!is.nan(sum(p))) { ### if (detail==1 && iid==1) cat("iid decomposition\n"); ### out <- loglike(p) ### logl <- out$loglike ### score1 <- score <- out$score ### oout <- 0; ### hess1 <- hess <- -1*out$Dscore ### ### if (iid==1) { ## {{{ ### theta.iid <- out$theta.iid ### score.iid <- theta.iid ### ### if (class(margsurv)=="phreg") { ## {{{ ### ### if (is.null(margsurv$opt) | is.null(margsurv$coef)) fixbeta<- 1 else fixbeta <- 0 ### id <- xx$id+1 ### ### xx <- margsurv$cox.prep ### D1thetal<- out$D1thetal ### D2thetal<- out$D2thetal ### Dlamthetal <- (D1thetal+D2thetal) ###### print(mydim(Dlamthetal)) ### ### Fbeta <- - t(Dlamtheta1) %*% (margsurv$X *cumhazt*psurvmarg*rr) ### ### ### time-ordered ### ### Gbasem <- apply(-Dlamthetal[xx$ord+1,,drop=FALSE]*psurvmarg[xx$ord+1]*rr[xx$ord+1],2,revcumsumstratasum,xx$strata,xx$nstrata,type="lagsum") ### Gbase <- apply(-Dlamthetal[xx$ord+1,,drop=FALSE]*psurvmarg[xx$ord+1]*rr[xx$ord+1],2,revcumsumstrata,xx$strata,xx$nstrata) ### ###### print(c(Gbase)) print(Fbeta) ### ### if (fixbeta==0) {# {{{ ### Z <- xx$X ### U <- E <- matrix(0,nrow(xx$X),margsurv$p) ### E[xx$jumps+1,] <- margsurv$E ### U[xx$jumps+1,] <- margsurv$U ### invhess <- -solve(margsurv$hessian) ### S0i <- rep(0,length(xx$strata)) ### S0i[xx$jumps+1] <- 1/margsurv$S0 ### cumhaz <- c(cumsumstrata(S0i,xx$strata,xx$nstrata)) ### EdLam0 <- apply(E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) ### rr <- c(xx$sign*exp(Z %*% coef(margsurv) + xx$offset)) ### ### Martingale as a function of time and for all subjects to handle strata ### MGt <- U[,drop=FALSE]-(Z*cumhaz-EdLam0)*rr*c(xx$weights) ### UUbeta <- apply(MGt,2,sumstrata,id-1,max(id)) ### UUbeta <- UUbeta %*% invhess ### GbaseEdLam0 <- t(Gbase) %*% (E*S0i) ### Fbeta <- Fbeta - GbaseEdLam0 ### Fbetaiid <- UUbeta %*% t(Fbeta) ### }# }}} ### ### ### \int_0^\tau (GBasem(s) / S_0(s)) dN_i(s) - dLamba_i(s) ### xx <- margsurv$cox.prep ### S0i <- rep(0,length(xx$strata)) ### S0i[xx$jumps+1] <- 1/margsurv$S0 ### S0i2[xx$jumps+1] <- 1/margsurv$S0^2 ### ### dN <- S0i ### dLam0 <- apply(S0i2,2,cumsumstrata,xx$strata,xx$nstrata) ### ### GbasedN <- Gbasem*S0i ### GbasedLam0 <- apply(Gbasem*S0i2,2,cumsumstrata,xx$strata,xx$nstrata) ### ### if (fixbeta==0) rr <- c(xx$sign*exp(Z %*% coef(margsurv) + xx$offset)) else rr <- c(xx$sign*exp( xx$offset)) ### MGt <- (GbasedN[,drop=FALSE]-GbasedLam0*rr)*c(xx$weights) ### Mt <- (dN[,drop=FALSE]-dLam0*rr)*c(xx$weights) ### Mt <- c(tail(Gbase,1)) %*% c(Mt) ### MGti <- apply(Mt-MGt,2,sumstrata,id-1,max(id)) ### ### ### print(cbind(theta.iid,MGti,Fbetaiid)) ### ### theta.iid <- theta.iid + MGti ### if (fixbeta==0) theta.iid <- theta.iid + Fbetaiid ### out$theta.iid <- theta.iid ### } ## }}} ### } ## }}} ### ### ### if (detail==1 && iid==1) cat("finished iid decomposition\n"); ### ### for profile solutions update second derivative at final ### if (numDeriv==2 || ((fix.baseline==0))) { ### oout <- 3 ### hess <- numDeriv::jacobian(loglike,p,method="simple") ### oout <- 2 ### } ### } ### if (numDeriv>=1) { ### if (detail==1 ) cat("starting numDeriv for second derivative \n"); ### oout <- 0; ### score2 <- numDeriv::jacobian(loglike,p) ### score1 <- matrix(score2,ncol=1) ### oout <- 3 ### hess <- numDeriv::jacobian(loglike,p,method="simple") ### if (detail==1 ) cat("finished numDeriv for second derivative \n"); ### } ### if (detail==1 & Nit==0) {## {{{ ### cat(paste("Fisher-Scoring ===================: final","\n")); ### cat("theta:");print(c(p)) ### cat("loglike:");cat(c(out$loglike),"\n"); ### cat("score:");cat(c(out$score),"\n"); ### cat("hess:\n"); cat(hess,"\n"); ### }## }}} ### if (!is.na(sum(hess))) hessi <- lava::Inverse(hess) else hessi <- diag(nrow(hess)) ### ## }}} ### } else if (score.method=="nlminb") { ## {{{ nlminb optimizer ### oout <- 0; ### tryCatch(opt <- nlminb(theta,loglike,control=control),error=function(x) NA) ### if (detail==1) print(opt); ### if (detail==1 && iid==1) cat("iid decomposition\n"); ### oout <- 2 ### theta <- opt$par ### out <- loglike(opt$par) ### logl <- out$loglike ### score1 <- score <- out$score ### hess1 <- hess <- -1* out$Dscore ### if (iid==1) { theta.iid <- out$theta.iid; score.iid <- out$theta.iid } ### if (numDeriv==1) { ### if (detail==1 ) cat("numDeriv hessian start\n"); ### oout <- 3; ## returns score ### hess <- numDeriv::jacobian(loglike,opt$par) ### if (detail==1 ) cat("numDeriv hessian done\n"); ### } ### hessi <- lava::Inverse(hess); ### ## }}} ### } else if (score.method=="optimize" && ptheta==1) { ## {{{ optimizer ### oout <- 0; ### if (var.link==1) {mino <- -20; maxo <- 10;} else {mino <- 0.001; maxo <- 100;} ### tryCatch(opt <- optimize(loglike,c(mino,maxo))); ### if (detail==1) print(opt); ### opt$par <- opt$minimum ### theta <- opt$par ### if (detail==1 && iid==1) cat("iid decomposition\n"); ### oout <- 2 ### out <- loglike(opt$par) ### logl <- out$loglike ### score1 <- score <- out$score ### hess1 <- hess <- -1* out$Dscore ### if (numDeriv==1) { ### if (detail==1 ) cat("numDeriv hessian start\n"); ### oout <- 3; ## to get jacobian ### hess <- numDeriv::jacobian(loglike,theta) ### if (detail==1 ) cat("numDeriv hessian done\n"); ### } ### hessi <- lava::Inverse(hess); ### if (iid==1) { theta.iid <- out$theta.iid; score.iid <- out$theta.iid } ### ## }}} ### } else if (score.method=="nlm") { ## {{{ nlm optimizer ### iid <- 0; oout <- 0; ### tryCatch(opt <- nlm(loglike,theta,hessian=TRUE,print.level=detail),error=function(x) NA) ### iid <- 1; ### hess <- opt$hessian ### score <- opt$gradient ### if (detail==1) print(opt); ### hessi <- lava::Inverse(hess); ### theta <- opt$estimate ### if (detail==1 && iid==1) cat("iid decomposition\n"); ### oout <- 2 ### out <- loglike(opt$estimate) ### logl <- out$loglike ### score1 <- out$score ### hess1 <- out$Dscore ### if (iid==1) { theta.iid <- out$theta.iid; score.iid <- out$theta.iid } ### ## }}} ### } else stop("score.methods = optimize(dim=1) nlm nlminb fisher.scoring\n"); ### ##### {{{ handling output ### loglikeiid <- NULL ### robvar.theta <- NULL ### likepairs <- NULL ### if (fix.baseline==1) { marginal.surv <- psurvmarg; marginal.trunc <- ptrunc; } else { marginal.surv <- out$marginal.surv; marginal.trunc <- out$marginal.trunc;} ### ### if (iid==1) { ### if (dep.model==3 & pair.structure==1) likepairs <- out$likepairs ### if (dep.model==3 & two.stage==0) {# {{{ ### hessi <- -1*hessi ### all.likepairs <- out$all.likepairs ### colnames(all.likepairs) <- c("surv","dt","ds","dtds","cause1","cause2") ### }# }}} ###### print(crossprod(out$theta.iid) %*% hessi) ### theta.iid <- out$theta.iid %*% hessi ### if (is.null(call.secluster)) rownames(theta.iid) <- unique(cluster.call) else rownames(theta.iid) <- unique(se.clusters) ### robvar.theta <- crossprod(theta.iid) ### loglikeiid <- out$loglikeiid ### } else { all.likepairs <- NULL} ### var.theta <- robvar.theta ### if (is.null(robvar.theta)) var.theta <- hessi ### ### if (!is.null(colnames(theta.des))) thetanames <- colnames(theta.des) else thetanames <- paste("dependence",1:length(theta),sep="") ### theta <- matrix(theta,length(c(theta)),1) ### if (length(thetanames)==nrow(theta)) { rownames(theta) <- thetanames; rownames(var.theta) <- colnames(var.theta) <- thetanames; } ### if (!is.null(logl)) logl <- -1*logl ### ### if (convergence.bp==0) theta <- rep(NA,length(theta)) ### ud <- list(theta=theta,score=score,hess=hess,hessi=hessi,var.theta=var.theta, ### model=model,robvar.theta=robvar.theta, ### theta.iid=theta.iid,loglikeiid=loglikeiid,likepairs=likepairs, ### thetanames=thetanames,loglike=logl,score1=score1,Dscore=out$Dscore, ### marginal.surv=marginal.surv,marginal.trunc=marginal.trunc, ### baseline=out$baseline,se=diag(robvar.theta)^.5, ### score.iid=score.iid) ### class(ud) <- "mets.twostage" ### attr(ud,"response") <- "survival" ### attr(ud,"Formula") <- formula ### attr(ud,"clusters") <- clusters ### attr(ud,"cluster.call") <- cluster.call ### attr(ud,"secluster") <- c(se.clusters) ### attr(ud,"sym")<-sym; ### attr(ud,"var.link")<-var.link; ### attr(ud,"var.par")<-var.par; ### attr(ud,"var.func")<-var.func; ### attr(ud,"ptheta")<-ptheta ### attr(ud,"antpers")<-antpers; ### attr(ud,"antclust")<-antclust; ### attr(ud,"Type") <- model ### attr(ud,"twostage") <- two.stage ### attr(ud,"additive-gamma") <- (dep.model==3)*1 ### if (!is.null(marginal.trunc)) attr(ud,"trunclikeiid")<- out$trunclikeiid ### if (dep.model==3 & two.stage==0) attr(ud,"all.likepairs")<- all.likepairs ### if (dep.model==3 ) attr(ud,"additive.gamma.sum") <- additive.gamma.sum ### #likepairs=likepairs,## if (dep.model==3 & pair.structure==1) attr(ud, "likepairs") <- c(out$likepairs) ### if (dep.model==3 & pair.structure==0) attr(ud, "pardes") <- theta.des ### if (dep.model==3 & pair.structure==0) attr(ud, "theta.des") <- theta.des ### if (dep.model==3 & pair.structure==1) attr(ud, "pardes") <- theta.des[,,1] ### if (dep.model==3 & pair.structure==1) attr(ud, "theta.des") <- theta.des[,,1] ### if (dep.model==3 & pair.structure==0) attr(ud, "rv1") <- random.design[1,] ### if (dep.model==3 & pair.structure==1) attr(ud, "rv1") <- random.design[,,1] ### return(ud); ### ## }}} ### ###} ## }}} ##' @title Twostage survival model fitted by pseudo MLE ##' ##' @description ##' Fits Clayton-Oakes clustered survival data ##' using marginals that are on Cox form in the likelihood for the dependence parameter ##' as in Glidden (2000). The dependence can be modelled via a ##' \enumerate{ ##' \item Regression design on dependence parameter. ##' } ##' ##' We allow a regression structure for the indenpendent gamma distributed ##' random effects and their variances that may depend on cluster covariates. So ##' \deqn{ ##' \theta = h( z_j^T \alpha) ##' } ##' where \eqn{z} is specified by theta.des . The link function can be the exp when var.link=1 ##' @references ##' ##' Measuring early or late dependence for bivariate twin data ##' Scheike, Holst, Hjelmborg (2015), LIDA ##' ##' Twostage modelling of additive gamma frailty models for survival data. ##' Scheike and Holst, working paper ##' ##' Shih and Louis (1995) Inference on the association parameter in copula models for bivariate ##' survival data, Biometrics, (1995). ##' ##' Glidden (2000), A Two-Stage estimator of the dependence ##' parameter for the Clayton Oakes model, LIDA, (2000). ##' ##' @examples ##' data(diabetes) ##' dd <- phreg(Surv(time,status==1)~treat+cluster(id),diabetes) ##' oo <- twostageMLE(dd,data=diabetes) ##' summary(oo) ##' ##' theta.des <- model.matrix(~-1+factor(adult),diabetes) ##' ##' oo <-twostageMLE(dd,data=diabetes,theta.des=theta.des) ##' summary(oo) ##' @keywords survival ##' @author Thomas Scheike ##' @param margsurv Marginal model from phreg ##' @param data data frame ##' @param theta Starting values for variance components ##' @param theta.des design for dependence parameters, when pairs are given this is could be a ##' (pairs) x (numer of parameters) x (max number random effects) matrix ##' @param var.link Link function for variance if 1 then uses exp link ##' @param method type of opitmizer, default is Newton-Raphson "NR" ##' @param no.opt to not optimize, for example to get score and iid for specific theta ##' @param weights cluster specific weights, but given with length equivalent to data-set, weights for score equations ##' @param ... arguments to be passed to optimizer ##' @export twostageMLE <-function(margsurv,data=sys.parent(), theta=NULL,theta.des=NULL,var.link=0,method="NR",no.opt=FALSE,weights=NULL,...) {# {{{ if (class(margsurv)!="phreg") stop("Must use phreg for this \n"); clusters <- margsurv$cox.prep$id n <- nrow(margsurv$cox.prep$X) secluster <- NULL if (is.null(theta.des)==TRUE) ptheta<-1; if (is.null(theta.des)==TRUE) theta.des<-matrix(1,n,ptheta) else theta.des<-as.matrix(theta.des); ptheta<-ncol(theta.des); if (nrow(theta.des)!=n) stop("Theta design does not have correct dim"); if (is.null(theta)==TRUE) { if (var.link==1) theta<- rep(0.0,ptheta); if (var.link==0) theta<- rep(1.0,ptheta); } if (length(theta)!=ptheta) theta<-rep(theta[1],ptheta); theta.score<-rep(0,ptheta);Stheta<-var.theta<-matrix(0,ptheta,ptheta); max.clust <- length(unique(clusters)) theta.iid <- matrix(0,max.clust,ptheta) xx <- margsurv$cox.prep nn <- length(xx$strata) if (is.null(weights)) weights <- rep(1,nn) if (length(weights)!=nn) stop("Weights do not have right length") statusxx <- rep(0,length(xx$strata)) statusxx[xx$jumps+1] <- 1 xx$status <- statusxx mid <- max(xx$id)+1 ## Ni.(t-), Ni.(t) Nsum <- cumsumstratasum(statusxx,xx$id,mid,type="all") ## Ni.(tau) Ni.tau <- sumstrata(statusxx,xx$id,mid) ## cumahz(T_i-) S0i2 <- S0i <- rep(0, length(xx$strata)) S0i[xx$jumps + 1] <- 1/margsurv$S0 cumhazD <- cumsumstratasum(S0i, xx$strata, xx$nstrata)$lagsum if (!is.null(margsurv$coef)) RR <- exp(xx$X %*% margsurv$coef) else RR <- rep(1,nn) H <- c(cumhazD * RR) cc <- cluster.index(xx$id) firstid <- cc$firstclustid+1 if (max(cc$cluster.size)==1) stop("No clusters !, maxclust size=1\n"); ### order after time-sorted data theta.des <- theta.des[xx$ord+1,,drop=FALSE] weightsid <- weights <- weights[xx$ord+1] ### clusterspecific weights weights <- weights[firstid] ### par <- c(2,2,0.1) ### par <- 2 obj <- function(par,all=FALSE) {# {{{ if (var.link==1) epar <- c(exp(par)) else epar <- c(par) thetaX<- as.matrix(theta.des[firstid,,drop=FALSE]) thetav <- c(as.matrix(theta.des) %*% c(epar)) thetai <-thetav[firstid] Hs <- sumstrata(H*exp(thetav*H),xx$id,mid) R <- sumstrata((exp(thetav*H)-1),xx$id,mid) + 1 H2 <- sumstrata(H^2*exp(thetav*H),xx$id,mid) l1 <- sumstrata(log(1+thetav*Nsum$lagsum)*statusxx,xx$id,mid) l2 <- sumstrata(statusxx*H,xx$id,mid) l3 <- -((thetai)^{-1}+Ni.tau) * log(R) logliid <- (l1 + thetai* l2 + l3)*c(weights) ###cbind(logliid,fit2$loglikeiid,Ni.tau) logl <- sum(logliid) ploglik <- logl ## first derivative l1s <- sumstrata(Nsum$lagsum/(1+thetav*Nsum$lagsum)*statusxx,xx$id,mid) l2s <- (thetai^{-2}) * log(R) l3s <- -(thetai^{-1}+Ni.tau) * Hs / R Dltheta <- (l1s+l2s+l3s+l2)*c(weights) scoreiid <- thetaX* c(Dltheta) ## second derivative D2N <- -sumstrata(Nsum$lagsum^2/(1+thetav*Nsum$lagsum)^2*statusxx,xx$id,mid) Dhes <- c(D2N+(2/thetai^2)*Hs/R-(2/thetai^3)*log(R)-(1/thetai+Ni.tau)*(H2*R-Hs*Hs)/R^2) Dhes <- Dhes * c(weights) if (var.link==1) { scoreiid <- scoreiid * c(exp(par)); Dhes<- Dhes* thetai^2 + thetai * Dltheta } gradient <- apply(scoreiid,2,sum) hessian <- crossprod(thetaX,thetaX*c(Dhes)) hess2 <- crossprod(scoreiid) val <- list(id=xx$id,score.iid=scoreiid,logl.iid=logliid,ploglik=ploglik, gradient=-gradient,hessian=hessian,hess2=hess2) if (all) return(val); with(val, structure(-ploglik,gradient=-gradient,hessian=hessian)) }# }}} opt <- NULL if (no.opt==FALSE) { if (tolower(method)=="nr") { opt <- lava::NR(theta,obj,...) ### opt <- lava::NR(theta,obj) opt$estimate <- opt$par } else { opt <- nlm(obj,theta,...) opt$method <- "nlm" } cc <- opt$estimate; ### names(cc) <- colnames(theta.des) val <- c(list(coef=cc),obj(opt$estimate,all=TRUE)) } else val <- c(list(coef=theta),obj(theta,all=TRUE)) val$score <- val$gradient theta <- matrix(c(val$coef),length(c(val$coef)),1) if (!is.null(colnames(theta.des))) thetanames <- colnames(theta.des) else thetanames <- paste("dependence",1:length(c(theta)),sep="") if (length(thetanames)==length(c(theta))) { rownames(theta) <- thetanames; rownames(var.theta) <- colnames(var.theta) <- thetanames; } hessianI <- solve(val$hessian) val$theta.iid.naive <- val$score.iid %*% hessianI ### iid due to Marginal model biid <- 1 if (biid==1) { # {{{ if (is.null(margsurv$opt) | is.null(margsurv$coef)) fixbeta<- 1 else fixbeta <- 0 id <- xx$id+1 if (var.link==1) epar <- c(exp(theta)) else epar <- c(theta) thetaX<- as.matrix(theta.des[firstid,,drop=FALSE]) thetav <- c(as.matrix(theta.des) %*% c(epar)) Hs <- c(sumstrata(H*exp(thetav*H),xx$id,mid)) R <- c(sumstrata((exp(thetav*H)-1),xx$id,mid)) + 1 H2 <- c(sumstrata(H^2*exp(thetav*H),xx$id,mid) ) Ft <- ((1/(thetav*R[id]))*exp(thetav*H)-(1/thetav+Ni.tau[id])*(1+thetav*H)*exp(thetav*H)/R[id]+statusxx+(1+thetav*Ni.tau[id])*exp(thetav*H)*Hs[id]/R[id]^2) if (var.link==1) { Ft <- Ft * c(exp(par)); } Gt <- c(RR *Ft * xx$sign * weightsid) Ft <- c( Ft * H * weightsid ) ### oi <- order(id) ###print(round(cbind(id,Ft,thetav,H,R[id],Hs[id],statusxx,Ni.tau[id],xx$X)[oi,],4)) ###print(round(cbind(id,Ft,xx$X,Ft*xx$X)[oi,],4)) ### pit <- revcumsumstrata(Ft* RR* theta.des,xx$strata,xx$nstrata) Gbase <- apply(Gt* theta.des,2,revcumsumstrata,xx$strata,xx$nstrata) Fbeta <- t(theta.des) %*% ( xx$X * Ft ) ### print(c(Gbase)); print(Fbeta) ### beta part if (fixbeta==0) { Z <- xx$X U <- E <- matrix(0,nrow(xx$X),margsurv$p) E[xx$jumps+1,] <- margsurv$E U[xx$jumps+1,] <- margsurv$U invhess <- -solve(margsurv$hessian) S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/margsurv$S0 cumhaz <- c(cumsumstrata(S0i,xx$strata,xx$nstrata)) EdLam0 <- apply(E*S0i,2,cumsumstrata,xx$strata,xx$nstrata) rr <- c(xx$sign*exp(Z %*% coef(margsurv) + xx$offset)) ### Martingale as a function of time and for all subjects to handle strata MGt <- U[,drop=FALSE]-(Z*cumhaz-EdLam0)*rr*c(xx$weights) UUbeta <- apply(MGt,2,sumstrata,id-1,max(id)) UUbeta <- UUbeta %*% invhess GbaseEdLam0 <- t(Gbase) %*% (E*S0i) Fbeta <- Fbeta - GbaseEdLam0 Fbetaiid <- UUbeta %*% t(Fbeta) } ### \int_0^\tau (GBase(s) / S_0(s)) dN_i(s) - dLamba_i(s) xx <- margsurv$cox.prep S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/margsurv$S0 S0i2[xx$jumps+1] <- 1/margsurv$S0^2 GbasedN <- Gbase*S0i GbasedLam0 <- apply(Gbase*S0i2,2,cumsumstrata,xx$strata,xx$nstrata) if (fixbeta==0) rr <- c(xx$sign*exp(Z %*% coef(margsurv) + xx$offset)) else rr <- c(xx$sign*exp( xx$offset)) MGt <- (GbasedN[,drop=FALSE]-GbasedLam0*rr)*c(xx$weights) MGti <- apply(MGt,2,sumstrata,id-1,max(id)) ### if (fixbeta==0) print(cbind(val$score.iid,MGti,Fbetaiid)) else print(cbind(val$score.iid,MGti)) theta.iid <- val$score.iid + MGti if (fixbeta==0) theta.iid <- theta.iid + Fbetaiid theta.iid <- theta.iid %*% hessianI ## take names from phreg call if (!is.null(margsurv$id)) rownames(theta.iid) <- unique(margsurv$id) val$theta.iid <- theta.iid # }}} } var <- robvar.theta <- var.theta <- crossprod(val$theta.iid) naive.var <- crossprod(val$theta.iid.naive) val <- c(val,list(theta=theta,var.theta=var.theta,robvar.theta=robvar.theta, var=var,thetanames=thetanames,model="clayton.oakes", se=diag(robvar.theta)^.5), var.naive=naive.var) class(val) <- "mets.twostage" attr(val,"clusters") <- clusters ### attr(val,"secluster") <- c(se.clusters) attr(val,"var.link")<-var.link; attr(val,"ptheta")<-ptheta attr(val,"n")<-n ; attr(val,"response")<- "survival" attr(val,"additive-gamma")<-0 attr(val,"twostage") <- "two.stage" return(val) }# }}} ##' @title Survival model for multivariate survival data ##' ##' @description ##' Fits additive gamma frailty model ##' with additive hazard condtional on the random effects ##' \deqn{ ##' \lambda_{ij} = (V_{ij}^T Z) (X_{ij}^T \alpha(t)) ##' } ##' The baseline \eqn{\alpha(t)} is profiled out using ##' marginal modelling adjusted for the random effects structure as in Eriksson and Scheike (2015). ##' One advantage of the standard frailty model is that one can deal with competing risks ##' for this model. ##' ##' For all models the ##' standard errors do not reflect this uncertainty of the baseline estimates, and might therefore be a bit to small. ##' To remedy this one can do bootstrapping or use survival.twostage.fullse function when possible. ##' ##' If clusters contain more than two times, we use a composite likelihood ##' based on the pairwise bivariate models. Can also fit a additive gamma random ##' effects model described in detail below. ##' ##' We allow a regression structure for the indenpendent gamma distributed ##' random effects and their variances that may depend on cluster covariates. So ##' \deqn{ ##' \theta = z_j^T \alpha ##' } ##' where \eqn{z} is specified by theta.des ##' The reported standard errors are based on the estimated information from the ##' likelihood assuming that the marginals are known. ##' ##' Can also fit a structured additive gamma random effects model, such ##' as the ACE, ADE model for survival data. ##' ##' Now random.design specificies the random effects for each subject within a cluster. This is ##' a matrix of 1's and 0's with dimension n x d. With d random effects. ##' For a cluster with two subjects, we let the random.design rows be ##' \eqn{v_1} and \eqn{v_2}. ##' Such that the random effects for subject ##' 1 is \deqn{v_1^T (Z_1,...,Z_d)}, for d random effects. Each random effect ##' has an associated parameter \eqn{(\lambda_1,...,\lambda_d)}. ##' By construction subjects 1's random effect are Gamma distributed with ##' mean \eqn{\lambda_j/v_1^T \lambda} ##' and variance \eqn{\lambda_j/(v_1^T \lambda)^2}. Note that the random effect ##' \eqn{v_1^T (Z_1,...,Z_d)} has mean 1 and variance \eqn{1/(v_1^T \lambda)}. ##' It is here asssumed that \eqn{lamtot=v_1^T \lambda} is fixed over all clusters ##' as it would be for the ACE model below. ##' The lamtot parameter may be specified separately for some sets of the parameter ##' is the additive.gamma.sum (ags) matrix is specified and then lamtot for the ##' j'th random effect is \eqn{ags_j^T \lambda}. ##' ##' Based on these parameters the relative contribution (the heritability, h) is ##' equivalent to the expected values of the random effects \eqn{\lambda_j/v_1^T \lambda} ##' ##' The DEFAULT parametrization uses the variances of the random effecs ##' \deqn{ ##' \theta_j = \lambda_j/(v_1^T \lambda)^2 ##' } ##' For alternative parametrizations one can specify how the parameters relate to \eqn{\lambda_j} ##' with the function ##' ##' Given the random effects the survival distributions with a cluster are independent and ##' on the form ##' \deqn{ ##' P(T > t| x,z) = exp( -Z A(t) \exp( Z^t beta)) ##' } ##' ##' The parameters \eqn{(\lambda_1,...,\lambda_d)} ##' are related to the parameters of the model ##' by a regression construction \eqn{pard} (d x k), that links the \eqn{d} ##' \eqn{\lambda} parameters ##' with the (k) underlying \eqn{\theta} parameters ##' \deqn{ ##' \lambda = theta.des \theta ##' } ##' here using theta.des to specify these low-dimension association. Default is a diagonal matrix. ##' ##' The case.control option that can be used with the pair specification of the pairwise parts ##' of the estimating equations. Here it is assumed that the second subject of each pair is the ##' proband. ##' @keywords survival ##' @author Thomas Scheike ##' @param margsurv Marginal model ##' @param data data frame ##' @param score.method Scoring method "fisher.scoring", "nlminb", "optimize", "nlm" ##' @param Nit Number of iterations ##' @param detail Detail ##' @param clusters Cluster variable ##' @param silent Debug information ##' @param weights Weights ##' @param control Optimization arguments ##' @param theta Starting values for variance components ##' @param theta.des design for dependence parameters, when pairs are given this is could be a ##' (pairs) x (numer of parameters) x (max number random effects) matrix ##' @param var.link Link function for variance ##' @param iid Calculate i.i.d. decomposition ##' @param step Step size ##' @param model model ##' @param marginal.trunc marginal left truncation probabilities ##' @param marginal.survival optional vector of marginal survival probabilities ##' @param marginal.status related to marginal survival probabilities ##' @param strata strata for fitting, see example ##' @param se.clusters for clusters for se calculation with iid ##' @param max.clust max se.clusters for se calculation with iid ##' @param numDeriv to get numDeriv version of second derivative, otherwise uses sum of squared score ##' @param random.design random effect design for additive gamma model, when pairs are given this is ##' a (pairs) x (2) x (max number random effects) matrix, see pairs.rvs below ##' @param pairs matrix with rows of indeces (two-columns) for the pairs considered in the pairwise ##' composite score, useful for case-control sampling when marginal is known. ##' @param pairs.rvs for additive gamma model and random.design and theta.des are given as arrays, ##' this specifice number of random effects for each pair. ##' @param numDeriv.method uses simple to speed up things and second derivative not so important. ##' @param additive.gamma.sum for two.stage=0, this is specification of the lamtot in the models via ##' a matrix that is multiplied onto the parameters theta (dimensions=(number random effects x number ##' of theta parameters), when null then sums all parameters. ##' @param var.par is 1 for the default parametrization with the variances of the random effects, ##' var.par=0 specifies that the \eqn{\lambda_j}'s are used as parameters. ##' @param cr.models competing risks models for two.stage=0, should be given as a list with models for each cause ##' @param case.control assumes case control structure for "pairs" with second column being the probands, ##' when this options is used the twostage model is profiled out via the paired estimating equations for the ##' survival model. ##' @param ascertained if the pair are sampled only when there is an event. This is in contrast to ##' case.control sampling where a proband is given. This can be combined with control probands. Pair-call ##' of twostage is needed and second column of pairs are the first jump time with an event for ascertained pairs, ##' or time of control proband. ##' @param shut.up to make the program more silent in the context of iterative procedures for case-control ##' and ascertained sampling ##' @export survival.iterative <- function(margsurv,data=sys.parent(),score.method="fisher.scoring",Nit=60,detail=0,clusters=NULL, silent=1,weights=NULL, control=list(),theta=NULL,theta.des=NULL, var.link=1,iid=1,step=0.5,model="clayton.oakes", marginal.trunc=NULL,marginal.survival=NULL,marginal.status=NULL,strata=NULL, se.clusters=NULL,max.clust=NULL,numDeriv=0,random.design=NULL,pairs=NULL,pairs.rvs=NULL,numDeriv.method="simple", additive.gamma.sum=NULL,var.par=1,cr.models=NULL,case.control=0,ascertained=0,shut.up=0) { ## {{{ ## {{{ seting up design and variables two.stage <- 0; rate.sim <- 1; sym=1; var.func <- NULL if (model=="clayton.oakes" || model=="gamma") dep.model <- 1 else if (model=="plackett" || model=="or") dep.model <- 2 else stop("Model must by either clayton.oakes or plackett \n"); start.time <- NULL; ptrunc <- NULL; psurvmarg <- NULL; status <- NULL fix.baseline <- 0; convergence.bp <- 1; ### to control if baseline profiler converges if ((!is.null(margsurv)) | (!is.null(marginal.survival))) fix.baseline <- 1 if (!is.null(margsurv)) { if (class(margsurv)=="aalen" || class(margsurv)=="cox.aalen") { ## {{{ formula<-attr(margsurv,"Formula"); beta.fixed <- attr(margsurv,"beta.fixed") if (is.null(beta.fixed)) beta.fixed <- 1; ldata<-aalen.des(formula,data=data,model="cox.aalen"); id <- attr(margsurv,"id"); mclusters <- attr(margsurv,"cluster.call") X<-ldata$X; time<-ldata$time2; Z<-ldata$Z; status<-ldata$status; time2 <- attr(margsurv,"stop"); start.time <- attr(margsurv,"start") antpers<-nrow(X); if (is.null(Z)==TRUE) {npar<-TRUE; semi<-0;} else { Z<-as.matrix(Z); npar<-FALSE; semi<-1;} if (npar==TRUE) {Z<-matrix(0,antpers,1); pz<-1; fixed<-0;} else {fixed<-1;pz<-ncol(Z);} px<-ncol(X); if (is.null(clusters) && is.null(mclusters)) stop("No cluster variabel specified in marginal or twostage call\n"); if (is.null(clusters)) clusters <- mclusters ### else if (sum(abs(clusters-mclusters))>0) ### cat("Warning: Clusters for marginal model different than those specified for two.stage\n"); ### if (!is.null(attr(margsurv,"max.clust"))) ### if ((attr(margsurv,"max.clust")< attr(margsurv,"orig.max.clust")) && (!is.null(mclusters))) ### cat("Warning: Probably want to estimate marginal model with max.clust=NULL\n"); if (nrow(X)!=length(clusters)) stop("Length of Marginal survival data not consistent with cluster length\n"); ## }}} } else { ### coxph ## {{{ notaylor <- 1 antpers <- margsurv$n id <- 0:(antpers-1) mt <- model.frame(margsurv) Y <- model.extract(mt, "response") if (!inherits(Y, "Surv")) stop("Response must be a survival object") if (attr(Y, "type") == "right") { time2 <- Y[, "time"]; status <- Y[, "status"] start.time <- rep(0,antpers); } else { start.time <- Y[, 1]; time2 <- Y[, 2]; status <- Y[, 3]; } ### Z <- na.omit(model.matrix(margsurv)[,-1]) ## Discard intercept Z <- matrix(1,antpers,length(coef(margsurv))); if (is.null(clusters)) stop("must give clusters for coxph\n"); cluster.call <- clusters; X <- matrix(1,antpers,1); ### Z <- matrix(0,antpers,1); ### no use for these px <- 1; pz <- ncol(Z); start <- rep(0,antpers); beta.fixed <- 0 semi <- 1 ### start.time <- 0 } ## }}} } else { start.time<- 0} ###print("00"); print(summary(psurvmarg)); print(summary(ptrunc)) if (any(abs(start.time)>0)) lefttrunk <- 1 else lefttrunk <- 0 if (!is.null(start.time)) { if (any(abs(start.time)>0)) lefttrunk <- 1 else lefttrunk <- 0; } else lefttrunk <- 0 if (!is.null(margsurv)) { if (class(margsurv)=="aalen" || class(margsurv)=="cox.aalen") { ## {{{ resi <- residualsTimereg(margsurv,data=data) RR <- resi$RR psurvmarg <- exp(-resi$cumhaz); ptrunc <- rep(1,length(psurvmarg)); if (lefttrunk==1) ptrunc <- exp(-resi$cumhazleft); } ## }}} else if (class(margsurv)=="coxph") { ## {{{ ### some problems here when data is different from data used in margsurv notaylor <- 1 residuals <- residuals(margsurv) cumhaz <- status-residuals psurvmarg <- exp(-cumhaz); cumhazleft <- rep(0,antpers) ptrunc <- rep(1,length(psurvmarg)); RR<- exp(margsurv$linear.predictors-sum(margsurv$means*coef(margsurv))) if ((lefttrunk==1)) { stop("Use cox.aalen function for truncation case \n"); baseout <- survival::basehaz(margsurv,centered=FALSE); cum <- cbind(baseout$time,baseout$hazard) cum <- Cpred(cum,start.time)[,2] ptrunc <- exp(-cum * RR) } } ## }}} } antpers <- nrow(data); ## mydim(marginal.survival)[1] RR <- rep(1,antpers); if (is.null(psurvmarg)) psurvmarg <- rep(1,antpers); if (!is.null(marginal.survival)) psurvmarg <- marginal.survival if (!is.null(marginal.trunc)) ptrunc <- marginal.trunc if (is.null(ptrunc)) ptrunc <- rep(1,length(psurvmarg)) ### print(summary(psurvmarg)); print(summary(ptrunc)) if (!is.null(marginal.status)) status <- marginal.status if (is.null(status) & is.null(cr.models)) stop("must give status variable for survival via either margninal model (margsurv), marginal.status or as cr.models \n"); if (is.null(weights)==TRUE) weights <- rep(1,antpers); if (is.null(strata)==TRUE) strata<- rep(1,antpers); if (length(strata)!=antpers) stop("Strata must have length equal to number of data points \n"); ## {{{ cluster set up cluster.call <- clusters out.clust <- cluster.index(clusters); clusters <- out.clust$clusters maxclust <- out.clust$maxclust antclust <- out.clust$cluster.size clusterindex <- out.clust$idclust clustsize <- out.clust$cluster.size call.secluster <- se.clusters if (is.null(se.clusters)) { se.clusters <- clusters; antiid <- nrow(clusterindex);} else { iids <- unique(se.clusters); antiid <- length(iids); if (is.numeric(se.clusters)) se.clusters <- fast.approx(iids,se.clusters)-1 else se.clusters <- as.integer(factor(se.clusters, labels = seq(antiid)))-1 } if (length(se.clusters)!=length(clusters)) stop("Length of seclusters and clusters must be same\n"); if ((!is.null(max.clust))) if (max.clust< antiid) { coarse.clust <- TRUE qq <- unique(quantile(se.clusters, probs = seq(0, 1, by = 1/max.clust))) qqc <- cut(se.clusters, breaks = qq, include.lowest = TRUE) se.clusters <- as.integer(qqc)-1 max.clusters <- length(unique(se.clusters)) maxclust <- max.clust antiid <- max.clusters } ## }}} ### pxz <- px + pz; if (!is.null(random.design)) { ### different parameters for Additive random effects # {{{ dep.model <- 3 ### if (is.null(random.design)) random.design <- matrix(1,antpers,1); dim.rv <- ncol(random.design); if (is.null(theta.des)) theta.des<-diag(dim.rv); ### ptheta <- dimpar <- ncol(theta.des); ### if (dim(theta.des)[2]!=ncol(random.design)) ### stop("nrow(theta.des)!= ncol(random.design),\nspecifies restrictions on paramters, if theta.des not given =diag (free)\n"); } else { random.design <- matrix(0,1,1); dim.rv <- 1; additive.gamma.sum <- matrix(1,1,1); } if (is.null(theta.des)) ptheta<-1; if (is.null(theta.des)) theta.des<-matrix(1,antpers,ptheta); ### else theta.des<-as.matrix(theta.des); ### ptheta<-ncol(theta.des); ### if (nrow(theta.des)!=antpers) stop("Theta design does not have correct dim"); if (length(dim(theta.des))==3) ptheta<-dim(theta.des)[2] else if (length(dim(theta.des))==2) ptheta<-ncol(theta.des) if (nrow(theta.des)!=antpers & dep.model!=3 ) stop("Theta design does not have correct dim"); if (length(dim(theta.des))!=3) theta.des <- as.matrix(theta.des) if (is.null(theta)==TRUE) { if (var.link==1) theta<- rep(-0.7,ptheta); if (var.link==0) theta<- rep(exp(-0.7),ptheta); } if (length(theta)!=ptheta) { ### warning("dimensions of theta.des and theta do not match\n"); ### print(theta); theta<-rep(theta[1],ptheta); } theta.score<-rep(0,ptheta);Stheta<-var.theta<-matrix(0,ptheta,ptheta); if (maxclust==1) stop("No clusters, maxclust size=1\n"); antpairs <- 1; ### to define if (is.null(additive.gamma.sum)) additive.gamma.sum <- matrix(1,dim.rv,ptheta) if (!is.null(pairs)) { pair.structure <- 1;} else pair.structure <- 0; ## ppprint ### print(c(pair.structure,dep.model,fix.baseline)) ### print(head(theta.des)) ### print(c(case.control,ascertained)) if (pair.structure==1 & dep.model==3) { ## {{{ ### something with dimensions of rv.des ### theta.des antpairs <- nrow(pairs); if ( (length(dim(theta.des))!=3) & (length(dim(random.design))==3) ) { Ptheta.des <- array(0,c(nrow(theta.des),ncol(theta.des),antpairs)) for (i in 1:antpairs) Ptheta.des[,,i] <- theta.des theta.des <- Ptheta.des } if ( (length(dim(theta.des))==3) & (length(dim(random.design))!=3) ) { rv.des <- array(0,c(2,ncol(random.design),antpairs)) for (i in 1:antpairs) { rv.des[1,,i] <- random.design[pairs[i,1],] rv.des[2,,i] <- random.design[pairs[i,2],] } random.design <- rv.des } if ( (length(dim(theta.des))!=3) & (length(dim(random.design))!=3) ) { ### print("laver 3-dim design "); Ptheta.des <- array(0,c(nrow(theta.des),ncol(theta.des),antpairs)) rv.des <- array(0,c(2,ncol(random.design),antpairs)) for (i in 1:antpairs) { rv.des[1,,i] <- random.design[pairs[i,1],] rv.des[2,,i] <- random.design[pairs[i,2],] Ptheta.des[,,i] <- theta.des } theta.des <- Ptheta.des random.design <- rv.des } if (max(pairs)>antpers) stop("Indices of pairs should refer to given data \n"); if (is.null(pairs.rvs)) pairs.rvs <- rep(dim(random.design)[2],antpairs) ### if (max(pairs.rvs)> dim(random.design)[3] | max(pairs.rvs)>ncol(theta.des[1,,])) ### stop("random variables for each cluster higher than possible, pair.rvs not consistent with random.design or theta.des\n"); clusterindex <- pairs-1; } ## }}} if (pair.structure==1 & dep.model!=3) { clusterindex <- pairs-1; antpairs <- nrow(pairs); pairs.rvs <- 1 }# }}} ## }}} ### setting up arguments for Aalen baseline profile estimates if (fix.baseline==0) { ## {{{ when baseline is estimated when baseline is estimated if (is.null(cr.models)) stop("give hazard models for different causes, ex cr.models=list(Surv(time,status==1)~+1,Surv(time,status==2)~+1) \n") if (case.control==0 & ascertained==0) { ## {{{ ## {{{ setting up random effects and covariates for marginal modelling timestatus <- all.vars(cr.models[[1]]) times <- data[,timestatus[1]] if (is.null(status)) status <- data[,timestatus[2]] lstatus <- data[,timestatus[2]] ### organize increments according to overall jump-times jumps <- lstatus!=0 dtimes <- times[jumps] st <- order(dtimes) dtimesst <- dtimes[st] dcauses <- lstatus[jumps][st] ids <- (1:nrow(data))[jumps][st] nc <- 0 for (i in 1:length(cr.models)) { a2 <- aalen.des(as.formula(cr.models[[i]]),data=data) X <- a2$X nc <- nc+ncol(X) } dBaalen <- matrix(0,length(dtimes),nc) xjump <- array(0,c(length(cr.models),nc,length(ids))) ## first compute marginal aalen models for all causes a <- list(); da <- list(); for (i in 1:length(cr.models)) { a[[i]] <- aalen(as.formula(cr.models[[i]]),data=data,robust=0,weights=weights) a2 <- aalen.des(as.formula(cr.models[[i]]),data=data) X <- a2$X da[[i]] <- apply(a[[i]]$cum[,-1,drop=FALSE],2,diff) jumpsi <- (1:length(dtimes))[dcauses==i] if (i==1) fp <- 1 indexc <- fp:(fp+ncol(X)-1) dBaalen[jumpsi,indexc] <- da[[i]] xjump[i,indexc,] <- t(X[ids,]) fp <- ncol(X)+1 } ## }}} #### organize subject specific random variables and design ### for additive gamma model ## {{{ dimt <- dim(theta.des[,,1,drop=FALSE])[-3] dimr <- dim(random.design[,,,drop=FALSE]) mtheta.des <- array(0,c(dimt,nrow(data))) mrv.des <- array(0,c(dimr[1]/2,dimr[2],nrow(data))) nrv.des <- rep(0,nrow(data)) nrv.des[pairs[,1]] <- pairs.rvs nrv.des[pairs[,2]] <- pairs.rvs mtheta.des[,,pairs[,1]] <- theta.des mtheta.des[,,pairs[,2]] <- theta.des mrv.des[,,pairs[,1]] <- random.design[1:(dimr[1]/2),,,drop=FALSE] mrv.des[,,pairs[,2]] <- random.design[(dimr[1]/2+1):dimr[1],,,drop=FALSE] ### array thetades to jump times (subjects) mtheta.des <- mtheta.des[,,ids,drop=FALSE] ### array randomdes to jump times (subjects) mrv.des <- mrv.des[,,ids,drop=FALSE] nrv.des <- pairs.rvs[ids] ## }}} ### #### organize subject specific random variables and design ### ### for additive gamma model ### ## {{{ ### dimt <- dim(theta.des[,,1]) ### dimr <- dim(random.design[,,]) ### mtheta.des <- array(0,c(dimt,nrow(data))) ### mrv.des <- array(0,c(dimr[1]/2,dimr[2],nrow(data))) ### mtheta.des[,,pairs[,1]] <- theta.des ### mtheta.des[,,pairs[,2]] <- theta.des ### mrv.des[,,pairs[,1]] <- random.design[1:(dimr[1]/2),,,drop=FALSE] ### mrv.des[,,pairs[,2]] <- random.design[(dimr[1]/2+1):dimr[1],,,drop=FALSE] ### nrv.des <- rep(0,nrow(data)) ### nrv.des[pairs[,1]] <- pairs.rvs ### nrv.des[pairs[,2]] <- pairs.rvs ### ### array thetades to jump times (subjects) ### mtheta.des <- mtheta.des[,,ids,drop=FALSE] ### ### array randomdes to jump times (subjects) ### mrv.des <- mrv.des[,,ids,drop=FALSE] ### nrv.des <- pairs.rvs[ids] ### ## }}} } ## }}} if (case.control==1 || ascertained==1) { ## {{{ ### print(dim(data)); print(summary(pairs)) data1 <- data[pairs[,1],] data.proband <- data[pairs[,2],] weights1 <- weights[pairs[,1]] ### print(summary(data.proband)); print(summary(data1)) ## {{{ setting up designs for jump times timestatus <- all.vars(cr.models[[1]]) if (is.null(status)) status <- data[,timestatus[2]] alltimes <- data[,timestatus[1]] times <- data1[,timestatus[1]] lstatus <- data1[,timestatus[2]] timescase <- data.proband[,timestatus[1]] lstatuscase <- data.proband[,timestatus[2]] ### organize increments according to overall jump-times jumps <- lstatus!=0 dtimes <- times[jumps] dtimescase <- timescase[jumps] st <- order(dtimes) dtimesst <- dtimes[st] dtimesstcase <- dtimescase[st] dcauses <- lstatus[jumps][st] dcausescase <- lstatuscase[jumps][st] ids <- (1:nrow(data1))[jumps][st] ### ### delayed entry for case because of ascertained sampling ### controls are however control probands, and have entry=0 entry <- timescase*lstatuscase data1$entry <- entry cr.models2 <- list() if (ascertained==1) { for (i in 1:length(cr.models)) { cr.models2[[i]] <- update(cr.models[[i]],as.formula(paste("Surv(entry,",timestatus[1],",",timestatus[2],")~.",sep=""))) } } else cr.models2 <- cr.models nc <- 0 for (i in 1:length(cr.models)) { X <- aalen.des(as.formula(cr.models[[i]]),data=data1)$X nc <- nc+ncol(X) } dBaalen <- matrix(0,length(dtimes),nc) xjump <- array(0,c(length(cr.models),nc,length(ids))) xjumpcase <- array(0,c(length(cr.models),nc,length(ids))) ## first compute marginal aalen models for all causes a <- list(); da <- list(); ### starting values for iteration Bit <- Bitcase <- c() for (i in 1:length(cr.models)) { ## {{{ a[[i]] <- aalen(as.formula(cr.models2[[i]]),data=data1,robust=0,weights=weights1) da[[i]] <- apply(a[[i]]$cum[,-1,drop=FALSE],2,diff) jumpsi <- (1:length(dtimes))[dcauses==i] X <- aalen.des(as.formula(cr.models[[i]]),data=data1)$X Xcase <- aalen.des(as.formula(cr.models[[i]]),data=data.proband)$X if (i==1) fp <- 1 indexc <- fp:(fp+ncol(X)-1) dBaalen[jumpsi,indexc] <- da[[i]] xjump[i,indexc,] <- t(X[ids,]) xjumpcase[i,indexc,] <- t(Xcase[ids,]) fp <- fp+ncol(X) ### starting values Bit <- cbind(Bit,Cpred(a[[i]]$cum,dtimesst)[,-1,drop=FALSE]) } ## }}} Bit.ini <- Bit ## }}} #### organize subject specific random variables and design #### already done in basic pairwise setup mtheta.des <- theta.des[,,ids,drop=FALSE] ### array randomdes to jump times (subjects) mrv.des <- random.design[,,ids,drop=FALSE] nrv.des <- pairs.rvs[ids] } ## }}} } else { mrv.des <- array(0,c(1,1,1)); mtheta.des <- array(0,c(1,1,1)); margthetades <- array(0,c(1,1,1)); xjump <- array(0,c(1,1,1)); dBaalen <- matrix(0,1,1); nrv.des <- 3 } ## }}} loglike <- function(par) { ## {{{ if (pair.structure==0 | dep.model!=3) Xtheta <- as.matrix(theta.des) %*% matrix(c(par),nrow=ptheta,ncol=1); if (pair.structure==1 & dep.model==3) Xtheta <- matrix(0,antpers,1); ## not needed DXtheta <- array(0,c(1,1,1)); if (var.link==1 & dep.model==3) epar <- c(exp(par)) else epar <- c(par) partheta <- epar if (var.par==1 & dep.model==3) { ## from variances to if (is.null(var.func)) { sp <- sum(epar) partheta <- epar/sp^2 } else partheta <- epar ## par.func(epar) } if (pair.structure==0) { outl<-.Call("twostageloglikeRV", ## {{{ only two stage model for this option icause=status,ipmargsurv=psurvmarg, itheta=c(partheta),iXtheta=Xtheta,iDXtheta=DXtheta,idimDX=dim(DXtheta),ithetades=theta.des, icluster=clusters,iclustsize=clustsize,iclusterindex=clusterindex, ivarlink=var.link,iid=iid,iweights=weights,isilent=silent,idepmodel=dep.model, itrunkp=ptrunc,istrata=as.numeric(strata),iseclusters=se.clusters,iantiid=antiid, irvdes=random.design,iags=additive.gamma.sum,iascertained=ascertained, PACKAGE="mets") ## }}} } else { ## pair-structure ## twostage model, case.control option, profile out baseline ## conditional model, case.control option, profile out baseline if (two.stage==1) { ## {{{ two-stage model if (fix.baseline==0) ## if baseline is not given { cum1 <- cbind(dtimesst,Bit) if ( (case.control==1 || ascertained==1) & (convergence.bp==1)) { ## {{{ profiles out baseline under case-control/ascertainment sampling ### ## initial values , only one cr.model for survival ### Bit <- cbind(Cpred(a[[1]]$cum,dtimesst)[,-1]) if (detail>1) plot(dtimesst,Bit,type="l",main="Bit") if (ncol(Bit)==0) Bit <- Bit.ini Bitcase <- Cpred(cbind(dtimesst,Bit),dtimesstcase)[,-1,drop=FALSE] Bitcase <- .Call("MatxCube",Bitcase,dim(xjumpcase),xjumpcase,PACKAGE="mets")$X for (j in 1:5) { ## {{{ profile via iteration cncc <- .Call("BhatAddGamCC",1,dBaalen,dcauses,dim(xjump),xjump, c(partheta),dim(mtheta.des),mtheta.des,additive.gamma.sum,var.link, dim(mrv.des),mrv.des,nrv.des,1,Bit,Bitcase,dcausescase,PACKAGE="mets") d <- max(abs(Bit-cncc$B)) if (detail>1) print(d) Bit <- cncc$B ### if (detail>1) print(c(par,epar,partheta)); ### if (detail>1) print(summary(Bit)); if (detail>1) print(summary(cncc$caseweights)) cum1 <- cbind(dtimesst,cncc$B) Bitcase <-cbind(Cpred(cum1,dtimesstcase)[,-1]) ### if (detail>1) print(summary(Bitcase)) if (detail>1) lines(dtimesst,Bit,col=j+1); if (is.na(d)) { if (shut.up==0) cat("Baseline profiler gives missing values\n"); Bit <- Bit.ini; cum1 <- cbind(dtimesst,Bit); convergence.bp <<- 0; break; } Bitcase <- .Call("MatxCube",Bitcase,dim(xjumpcase),xjumpcase,PACKAGE="mets")$X if (d<0.00001) break; } ## }}} nulrow <- rep(0,ncol(Bit)+1) pbases <- Cpred(rbind(nulrow,cbind(dtimesst,Bit)),alltimes)[,-1,drop=FALSE] X <- aalen.des(as.formula(cr.models[[1]]),data=data)$X psurvmarg <- exp(-apply(X*pbases,1,sum)) ## psurv given baseline if (ascertained==1) { Xcase <- aalen.des(as.formula(cr.models[[1]]),data=data.proband)$X X <- aalen.des(as.formula(cr.models[[1]]),data=data1)$X pba.case <- Cpred(rbind(nulrow,cbind(dtimesst,Bit)),entry)[,-1,drop=FALSE] ptrunc <- rep(0,nrow(data)) ### for control probands ptrunc=1, thus no adjustment ptrunc[pairs[,1]] <- exp(-apply(X* pba.case,1,sum)*lstatuscase) ## delayed entry at time of ascertainment proband ptrunc[pairs[,2]] <- exp(-apply(Xcase*pba.case,1,sum)*lstatuscase) } ### print(head(cbind(psurvmarg,ptrunc))) ### print(summary(psurvmarg)) ### print(summary(ptrunc)) ### print(dim(pbases)); } ## }}} } ### browser() ### print(dim(random.design)) outl<-.Call("twostageloglikeRVpairs", ## {{{ icause=status,ipmargsurv=psurvmarg, itheta=c(partheta),iXtheta=Xtheta,iDXtheta=DXtheta,idimDX=dim(DXtheta),ithetades=theta.des, icluster=clusters,iclustsize=clustsize,iclusterindex=clusterindex, ivarlink=var.link,iiid=iid,iweights=weights,isilent=silent,idepmodel=dep.model, itrunkp=ptrunc,istrata=as.numeric(strata),iseclusters=se.clusters,iantiid=antiid, irvdes=random.design, idimthetades=dim(theta.des),idimrvdes=dim(random.design),irvs=pairs.rvs,iags=additive.gamma.sum, iascertained=ascertained,PACKAGE="mets") ## }}} if (fix.baseline==0) { outl$baseline <- cum1; outl$marginal.surv <- psurvmarg; outl$marginal.trunc <- ptrunc } } ## }}} else { ## {{{ survival model two.stage==0 ### cum1 <- cbind(dtimesst,Bit) entry.cause <- rep(0,nrow(data)) ### proband.time <- rep(0,nrow(data)) ### update aalen type baseline if (fix.baseline==0) { ## {{{ if ((case.control==1 || ascertained==1) & (convergence.bp==1)) { ## {{{ profiles out baseline under case-control/ascertainment sampling if (detail>1) print(summary(Bit)) if (detail>1) matplot(dtimesst,Bit,type="l",main="Bit",ylim=c(0,2)) if (ncol(Bit)==0) Bit <- Bit.ini Bitcase <- Cpred(cbind(dtimesst,Bit),dtimesstcase)[,-1,drop=FALSE] Bitcase <- .Call("MatxCube",Bitcase,dim(xjumpcase),xjumpcase,PACKAGE="mets")$X for (j in 1:10) { ## {{{ profile via iteration profile.baseline <- .Call("BhatAddGamCC",0,dBaalen,dcauses,dim(xjump),xjump, c(partheta), dim(mtheta.des),mtheta.des, additive.gamma.sum,var.link, dim(mrv.des),mrv.des,nrv.des,1,Bit,Bitcase,dcausescase,PACKAGE="mets") d <- max(abs(Bit-profile.baseline$B)) Bit <- profile.baseline$B cum1 <- cbind(dtimesst,Bit) Bitcase <-cbind(Cpred(cum1,dtimesstcase)[,-1]) ### matlines(dtimesst,Bit,type="l",col=j+1) if (detail>1) matlines(dtimesst,Bit,col=j+1); if (is.na(d)) { if (shut.up==0) cat("Baseline profiler gives missing values\n"); Bit <- Bit.ini; cum1 <- cbind(dtimesst,Bit); convergence.bp <<- 0; break; } Bitcase <- .Call("MatxCube",Bitcase,dim(xjumpcase),xjumpcase,PACKAGE="mets")$X if (d<0.00001) break; } ## }}} ### print("profile slut"); ### plot(cum1); abline(c(0,1)) ### makes cumulative hazard for all subjects nulrow <- rep(0,ncol(Bit)+1) pbases <- Cpred(rbind(nulrow,cbind(dtimesst,Bit)),alltimes)[,-1,drop=FALSE] psurvmarg <- c() ### update psurvmarg if (ascertained==1 || case.control==1) { ### sets up truncation probabilities to match situation pbase.case <- Cpred(rbind(nulrow,cbind(dtimesst,Bit)),timescase)[,-1,drop=FALSE] ptrunc <- c() ### update ptrunc } for (i in 1:length(cr.models)) { if (i==1) fp <- 1 a2 <- aalen.des(as.formula(cr.models[[i]]),data=data) X <- a2$X indexc <- fp:(fp+ncol(X)-1) psurvmarg <- cbind(psurvmarg,apply(X*pbases[,indexc],1,sum)) if (ascertained==1 || case.control==1) { Xcase <- aalen.des(as.formula(cr.models[[i]]),data=data.proband)$X X <- aalen.des(as.formula(cr.models[[i]]),data=data1)$X ### print(dim(Xcase)); print(dim(pbase.case[,indexc,drop=FALSE])) ptrunc.new <- rep(0,length(alltimes)) ## delayed entry at time of ascertainment proband, for case control no adjustment for first if (ascertained==1) ptrunc.new[pairs[,1]] <- apply(X*pbase.case[,indexc,drop=FALSE],1,sum)*lstatuscase else ptrunc.new[pairs[,1]] <- 0 ## for second component adjustment for marginal or ascertainment ptrunc.new[pairs[,2]] <- apply(Xcase*pbase.case[,indexc,drop=FALSE],1,sum) ptrunc <- cbind(ptrunc,ptrunc.new) } fp <- fp+ncol(X) } } ## }}} else { ## {{{ profile out baseline, recursive estimator profile.baseline <- .Call("BhatAddGam",recursive=1, dBaalen,dcauses,dim(xjump),xjump,c(partheta), dim(mtheta.des),mtheta.des, additive.gamma.sum,0,dim(mrv.des),mrv.des,0,matrix(0,1,1),PACKAGE="mets") ### print(summary(cbind(dtimesst,profile.baseline$B))) ### matplot(dtimesst,profile.baseline$B,type="l") ### print(head(profile.baseline$B)) ### abline(c(0,0.2),col=3) ### abline(c(0,0.4),col=3) marg.model <- "no-cox" if (marg.model=="cox") {# {{{ Bit <- profile.baseline$B Bit <- .Call("MatxCube",Bit,dim(xjump),xjump,PACKAGE="mets")$X caseweights <- profile.baseline$caseweights pp <- timereg.formula(as.formula(cr.models[[i]])) profile.cox <- cox.aalen(pp,data=data,robust=0,caseweight=caseweights) print(summary(profile.cox)) plot(profile.cox) }# }}} nulrow <- rep(0,ncol(dBaalen)+1) pbases <- Cpred(rbind(nulrow,cbind(dtimesst,profile.baseline$B)),times)[,-1,drop=FALSE] psurvmarg <- c() for (i in 1:length(cr.models)) { if (i==1) fp <- 1 a2 <- aalen.des(as.formula(cr.models[[i]]),data=data) X <- a2$X indexc <- fp:(fp+ncol(X)-1) psurvmarg <- cbind(psurvmarg,apply(X*pbases[,indexc],1,sum)) fp <- fp+ncol(X) } ### no truncation in this case ? ptrunc <- 0*psurvmarg } ## }}} } ## }}} ### if (fix.baseline==1) if (is.null(psurvmarg)) stop("must provide baselines or set fix.baseline=0\n"); ### print("er vi her surv "); ### print(fix.baseline) ### print(dim(as.matrix(psurvmarg))); print(dim(as.matrix(ptrunc))) ### print(dim(pairs)) ### print(head(pairs)) ### print(summary(psurvmarg[pairs,])); print(summary(ptrunc[pairs,])) ### cumulative hazard for this model when fix.baseline==1 if (fix.baseline==1 ) { psurvmarg <- -log(psurvmarg); ptrunc <- -log(ptrunc); } outl<-.Call("survivalloglikeRVpairs",icause=status,ipmargsurv=as.matrix(psurvmarg), itheta=c(partheta),iXtheta=Xtheta,iDXtheta=DXtheta,idimDX=dim(DXtheta),ithetades=theta.des, icluster=clusters,iclustsize=clustsize,iclusterindex=clusterindex, iiid=iid,iweights=weights,isilent=silent,idepmodel=dep.model, itrunkp=as.matrix(ptrunc),istrata=as.numeric(strata),iseclusters=se.clusters,iantiid=antiid, irvdes=random.design, idimthetades=dim(theta.des),idimrvdes=dim(random.design), irvs=pairs.rvs,iags=additive.gamma.sum,ientry.cause=entry.cause,iascertained=(ascertained+case.control>0)*1, PACKAGE="mets") if (fix.baseline==0) { outl$baseline <- cbind(dtimesst,profile.baseline$B); outl$marginal.surv <- psurvmarg; outl$marginal.trunc <- ptrunc } } ## }}} } if (detail==3) print(c(partheta,outl$loglike)) ## variance parametrization, and inverse.link if (dep.model==3) {# {{{ if (var.par==1) { ## from variances to and with sum for all random effects if (is.null(var.func)) { if (var.link==0) { ### print(c(sp,epar)) mm <- matrix(-epar*2*sp,length(epar),length(epar)) diag(mm) <- sp^2-epar*2*sp ### print(mm) } else { mm <- -c(epar) %o% c(epar)*2*sp diag(mm) <- epar*sp^2-epar^2*2*sp ### print(mm) } mm <- mm/sp^4 } else mm <- numDeriv::hessian(var.func,par) } else { if (var.link==0) mm <- diag(length(epar)) else mm <- diag(length(c(epar)))*c(epar) } }# }}} ### print(c(var.link,dep.model,var.par)) ### print("hh"); print(mm); print(outl$score) if (dep.model==3) {# {{{ ### print(dim(mm)) outl$score <- t(mm) %*% outl$score outl$Dscore <- t(mm) %*% outl$Dscore %*% mm if (iid==1) outl$theta.iid <- t(t(mm) %*% t(outl$theta.iid)) ### print(crossprod(outl$theta.iid)); print(outl$Dscore) ### print(c(outl$score)) ### print(apply(outl$theta.iid,2,sum)) }# }}} attr(outl,"gradient") <-outl$score if (oout==0) ret <- c(-1*outl$loglike) else if (oout==1) ret <- sum(outl$score^2) else if (oout==2) ret <- outl else ret <- outl$score return(ret) } ## }}} if (score.method=="optimize" && ptheta!=1) { cat("optimize only works for d==1, score.mehod set to nlminb \n"); score.method <- "nlminb"; } score1 <- NULL theta.iid <- NULL logl <- NULL p <- theta if (score.method=="fisher.scoring") { ## {{{ oout <- 2; ### output control for obj if (Nit>0) for (i in 1:Nit) { out <- loglike(p) ## updating starting values for cumulative baselines if (fix.baseline==0) Bit <- out$baseline[,-1,drop=FALSE] if (fix.baseline==1) hess <- out$Dscore ### uses simple second derivative for computing derivative of score if (numDeriv==2 || (((fix.baseline==0)) & (i==1))) { oout <- 3 hess <- numDeriv::jacobian(loglike,p,method="simple") oout <- 2 } if (!is.na(sum(hess))) hessi <- lava::Inverse(hess) else hessi <- hess if (detail==1) {## {{{ cat(paste("Fisher-Scoring ===================: it=",i,"\n")); cat("theta:");print(c(theta)) cat("loglike:");cat(c(out$loglike),"\n"); cat("score:");cat(c(out$score),"\n"); cat("hess:\n"); cat(hess,"\n"); }## }}} delta <- step*( hessi %*% out$score ) ### update p, but note that score and derivative in fact related to previous p ### unless Nit=0, if (Nit>0) { p <- p - delta theta <- p; } if (is.nan(sum(out$score))) break; if (sum(abs(out$score))<0.00001) break; if (max(theta)>20 & var.link==1) { cat("theta too large lacking convergence \n"); break; } } if (!is.nan(sum(p))) { if (detail==1 && iid==1) cat("iid decomposition\n"); out <- loglike(p) logl <- out$loglike score1 <- score <- out$score oout <- 0; hess1 <- hess <- -1*out$Dscore if (iid==1) { theta.iid <- out$theta.iid if (class(margsurv)=="phreg") { ## {{{ ## order after time D1dltheta1 <- out$D1dltheta1[xx$order+1,] D2dltheta1 <- out$D1dltheta1[xx$order+1,] ### baseline iid xx <- margsurv$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/margsurv$S0 rr <- exp(margsurv$cox.prep$X %*% margsurv$coef) cumhazt <- cumsumstratasum(S0i,xx$strata,xx$nstrata)$lagsum psurvmarg <- exp(-cumhazt*rr) } ## }}} } if (detail==1 && iid==1) cat("finished iid decomposition\n"); ### for profile solutions update second derivative at final if (numDeriv==2 || ((fix.baseline==0))) { oout <- 3 hess <- numDeriv::jacobian(loglike,p,method="simple") oout <- 2 } } if (numDeriv>=1) { if (detail==1 ) cat("starting numDeriv for second derivative \n"); oout <- 0; score2 <- numDeriv::jacobian(loglike,p) score1 <- matrix(score2,ncol=1) oout <- 3 hess <- numDeriv::jacobian(loglike,p,method="simple") if (detail==1 ) cat("finished numDeriv for second derivative \n"); } if (detail==1 & Nit==0) {## {{{ cat(paste("Fisher-Scoring ===================: final","\n")); cat("theta:");print(c(p)) cat("loglike:");cat(c(out$loglike),"\n"); cat("score:");cat(c(out$score),"\n"); cat("hess:\n"); cat(hess,"\n"); }## }}} if (!is.na(sum(hess))) hessi <- lava::Inverse(hess) else hessi <- diag(nrow(hess)) ## }}} } else if (score.method=="nlminb") { ## {{{ nlminb optimizer oout <- 0; if (two.stage==0) oout <- 1 ## score tryCatch(opt <- nlminb(theta,loglike,control=control),error=function(x) NA) if (detail==1) print(opt); if (detail==1 && iid==1) cat("iid decomposition\n"); oout <- 2 theta <- opt$par out <- loglike(opt$par) logl <- out$loglike score1 <- score <- out$score hess1 <- hess <- -1* out$Dscore if (iid==1) theta.iid <- out$theta.iid if (numDeriv==1) { if (detail==1 ) cat("numDeriv hessian start\n"); oout <- 3; ## returns score hess <- numDeriv::jacobian(loglike,opt$par) if (detail==1 ) cat("numDeriv hessian done\n"); } hessi <- lava::Inverse(hess); ## }}} } else if (score.method=="optimize" && ptheta==1) { ## {{{ optimizer oout <- 0; if (var.link==1) {mino <- -20; maxo <- 10;} else {mino <- 0.001; maxo <- 100;} tryCatch(opt <- optimize(loglike,c(mino,maxo))); if (detail==1) print(opt); opt$par <- opt$minimum theta <- opt$par if (detail==1 && iid==1) cat("iid decomposition\n"); oout <- 2 out <- loglike(opt$par) logl <- out$loglike score1 <- score <- out$score hess1 <- hess <- -1* out$Dscore if (numDeriv==1) { if (detail==1 ) cat("numDeriv hessian start\n"); oout <- 3; ## to get jacobian hess <- numDeriv::jacobian(loglike,theta) if (detail==1 ) cat("numDeriv hessian done\n"); } hessi <- lava::Inverse(hess); if (iid==1) theta.iid <- out$theta.iid ## }}} } else if (score.method=="nlm") { ## {{{ nlm optimizer iid <- 0; oout <- 0; tryCatch(opt <- nlm(loglike,theta,hessian=TRUE,print.level=detail),error=function(x) NA) iid <- 1; hess <- opt$hessian score <- opt$gradient if (detail==1) print(opt); hessi <- lava::Inverse(hess); theta <- opt$estimate if (detail==1 && iid==1) cat("iid decomposition\n"); oout <- 2 out <- loglike(opt$estimate) logl <- out$loglike score1 <- out$score hess1 <- out$Dscore if (iid==1) theta.iid <- out$theta.iid ## }}} } else stop("score.methods = optimize(dim=1) nlm nlminb fisher.scoring\n"); ## {{{ handling output loglikeiid <- NULL robvar.theta <- NULL likepairs <- NULL if (fix.baseline==1) { marginal.surv <- psurvmarg; marginal.trunc <- ptrunc; } else { marginal.surv <- out$marginal.surv; marginal.trunc <- out$marginal.trunc;} if (iid==1) { if (dep.model==3 & pair.structure==1) likepairs <- out$likepairs if (dep.model==3 & two.stage==0) { hessi <- -1*hessi all.likepairs <- out$all.likepairs colnames(all.likepairs) <- c("surv","dt","ds","dtds","cause1","cause2") } ### print(crossprod(out$theta.iid) %*% hessi) theta.iid <- out$theta.iid %*% hessi if (is.null(call.secluster) & is.null(max.clust)) rownames(theta.iid) <- unique(cluster.call) else rownames(theta.iid) <- unique(se.clusters) robvar.theta <- crossprod(theta.iid) loglikeiid <- out$loglikeiid } else { all.likepairs <- NULL} var.theta <- robvar.theta if (is.null(robvar.theta)) var.theta <- hessi if (!is.null(colnames(theta.des))) thetanames <- colnames(theta.des) else thetanames <- paste("dependence",1:length(theta),sep="") theta <- matrix(theta,length(c(theta)),1) if (length(thetanames)==nrow(theta)) { rownames(theta) <- thetanames; rownames(var.theta) <- colnames(var.theta) <- thetanames; } if (!is.null(logl)) logl <- -1*logl if (convergence.bp==0) theta <- rep(NA,length(theta)) ud <- list(theta=theta,score=score,hess=hess,hessi=hessi,var.theta=var.theta,model=model,robvar.theta=robvar.theta, theta.iid=theta.iid,loglikeiid=loglikeiid,likepairs=likepairs, thetanames=thetanames,loglike=logl,score1=score1,Dscore=out$Dscore, marginal.surv=marginal.surv,marginal.trunc=marginal.trunc,baseline=out$baseline, se=diag(robvar.theta)^.5) class(ud) <- "mets.twostage" attr(ud,"response") <- "survival" attr(ud,"Formula") <- formula attr(ud,"clusters") <- clusters attr(ud,"cluster.call") <- cluster.call attr(ud,"secluster") <- c(se.clusters) attr(ud,"sym")<-sym; attr(ud,"var.link")<-var.link; attr(ud,"var.par")<-var.par; attr(ud,"var.func")<-var.func; attr(ud,"ptheta")<-ptheta attr(ud,"antpers")<-antpers; attr(ud,"antclust")<-antclust; attr(ud,"Type") <- model attr(ud,"twostage") <- two.stage attr(ud,"additive-gamma") <- (dep.model==3)*1 if (!is.null(marginal.trunc)) attr(ud,"trunclikeiid")<- out$trunclikeiid if (dep.model==3 & two.stage==0) attr(ud,"all.likepairs")<- all.likepairs if (dep.model==3 ) attr(ud,"additive.gamma.sum") <- additive.gamma.sum #likepairs=likepairs,## if (dep.model==3 & pair.structure==1) attr(ud, "likepairs") <- c(out$likepairs) if (dep.model==3 & pair.structure==0) attr(ud, "pardes") <- theta.des if (dep.model==3 & pair.structure==0) attr(ud, "theta.des") <- theta.des if (dep.model==3 & pair.structure==1) attr(ud, "pardes") <- theta.des[,,1] if (dep.model==3 & pair.structure==1) attr(ud, "theta.des") <- theta.des[,,1] if (dep.model==3 & pair.structure==0) attr(ud, "rv1") <- random.design[1,] if (dep.model==3 & pair.structure==1) attr(ud, "rv1") <- random.design[,,1] return(ud); ## }}} } ## }}} ##' @export summary.mets.twostage <- function(object,digits = 3,silent=0,...) { ## {{{ if (!(inherits(object,"mets.twostage"))) stop("Must be a Two-Stage object") var.link<-attr(object,"var.link"); var.par <- attr(object,"var.par"); model <- object$model if ((model=="plackett" || model=="or") ) model <- "or" if ((model=="clayton.oakes" || model=="gamma") ) model <- "gamma" if ((attr(object,"additive-gamma")==1) & (silent==0)) addgam <- TRUE else addgam <- FALSE if ((model=="or") && (silent==0)) cat("Dependence parameter for Odds-Ratio (Plackett) model \n"); if (attr(object,"response")=="binomial") response <- "binomial" else response <- "survival" if ((model=="gamma") && (silent==0)) { cat("Dependence parameter for Clayton-Oakes model\n") if (var.par==1 || !addgam) cat("Variance of Gamma distributed random effects \n"); if (var.par==0 && addgam) cat("Inverse of variance of Gamma distributed random effects \n"); } if (var.link==1 && silent==0) cat("With log-link \n") if ((sum(abs(object$score))>0.0001) & (silent==0)) { cat(" Variance parameters did not converge, allow more iterations.\n"); cat(paste(" Score:",object$score," \n")); } theta <- object$theta if (is.null(rownames(theta))) rownames(theta) <- paste("dependence",1:nrow(theta),sep="") ### print(theta) coefs <- coef.mets.twostage(object,response=response,...); if (attr(object,"additive-gamma")==1 & (!is.null(object$robvar.theta)) ) { var.link <- attr(object,"var.link"); var.par <- attr(object,"var.par"); rv1 <- attr(object,"rv1"); if (is.matrix(rv1)) rv1 <- rv1[1,] theta.des <- attr(object,"pardes"); ags <- attr(object,"additive.gamma.sum"); ptheta <- attr(object,"ptheta") npar <- nrow(object$theta) theta <- object$theta[seq(1,ptheta),1,drop=FALSE] ### print(theta.des); print(theta); print(theta.des %*% theta); print(rv1); robvar.theta <- object$robvar.theta[seq(1,ptheta),seq(1,ptheta)] if (var.link==1) par <- theta.des %*% exp(theta) else par <- theta.des %*% theta if (model=="or" || model=="plackett") var.par<-1 ## same as var.par=0 for this model if (attr(object,"twostage")==0) { ### cat("MLE estimates of marginal parameters\n"); ### var.gamma <- object$robvar.theta[seq(ptheta+1,npar),seq(ptheta+1,npar)] ### obj.marginal <- list(gamma=object$theta[seq(ptheta+1,npar),1],var.gamma=var.gamma,robvar.gamma=var.gamma) ### marginal <- coefBase(obj.marginal) } if (var.par==0) { ## {{{ if (var.link==1) { fp <- function(p,d,t){ res <- exp(p*t)/(sum(rv1* c(theta.des %*% matrix(exp(p),ncol=1))))^d; if (t==0) res <- res[1]; return(res); } pare <- lava::estimate(coef=theta,vcov=robvar.theta,f=function(p) exp(p),labels=rownames(theta)) } else { fp <- function(p,d,t) { res <- (p^t)/(sum(rv1* c(theta.des %*% matrix(p,ncol=1))))^d; if (t==0) res <- res[1]; return(res); } pare <- NULL } e <- lava::estimate(coef=theta,vcov=robvar.theta,f=function(p) fp(p,1,1),labels=rownames(theta)) vare <- lava::estimate(coef=theta,vcov=robvar.theta,f=function(p) fp(p,2,1),labels=rownames(theta)) vartot <- lava::estimate(coef=theta,vcov=robvar.theta,f=function(p) fp(p,1,0)) } ## }}} if (var.par==1) { ## {{{ if (var.link==1) { ## {{{ fp <- function(p,d,t){ res <- exp(p*t)/(sum(rv1* c(theta.des %*% matrix(exp(p),ncol=1))))^d; if (t==0) res <- res[1]; return(res); } e <- lava::estimate(coef=theta,vcov=robvar.theta,f=function(p) fp(p,1,1),labels=rownames(theta)) vare <- lava::estimate(coef=theta,vcov=robvar.theta,f=function(p) exp(p),labels=rownames(theta)) vartot <- lava::estimate(coef=theta,vcov=robvar.theta,f=function(p) sum(exp(p))) ### names(e) <- names(vare) <- colnames(coefs) } else { fp <- function(p,d,t) { res <- (p^t)/(sum(rv1* c(theta.des %*% matrix(p,ncol=1))))^d; if (t==0) res <- res[1]; return(res); } e <- lava::estimate(coef=theta,vcov=robvar.theta,f=function(p) fp(p,1,1),labels=rownames(theta)) pare <- lava::estimate(coef=theta,vcov=robvar.theta,f=function(p) fp(p,2,1),labels=rownames(theta)) vartot <- lava::estimate(coef=theta,vcov=robvar.theta,f=function(p) sum(p)) vare <- NULL ### names(e) <- names(pare) <- colnames(coefs) } ## }}} } ## }}} res <- list(estimates=coefs, type=attr(object,"Type"),h=e,vare=vare,vartot=vartot) } else { if (var.link==1) { ## {{{ if (model=="or") { or <- lava::estimate(coef=object$theta,vcov=object$var.theta,f=function(p) exp(p),labels=rownames(theta)) res <- list(estimates=coefs,or=or,type=attr(object,"Type")) } else { vargam <- lava::estimate(coef=object$theta,vcov=object$var.theta,f=function(p) exp(p),labels=rownames(theta)) ### names(vargam) <- colnames(coefs) res <- list(estimates=coefs,vargam=vargam, type=attr(object,"Type")) } } else { if (model=="or") { lor <- lava::estimate(coef=object$theta,vcov=object$var.theta,f=function(p) log(p),labels=rownames(theta)) ### names(lor) <- colnames(coefs) res <- list(estimates=coefs,log.or=lor,type=attr(object,"Type")) } else { res <- list(estimates=coefs,type=attr(object,"Type")) } } ## }}} } ### if (attr(object,"twostage")==0) res <- c(res,list(marginal=marginal)) class(res) <- "summary.mets.twostage" res } ## }}} ##' @export coef.mets.twostage <- function(object,var.link=NULL,response="survival",...) { ## {{{ pt <- attr(object,"ptheta") theta <- object$theta[seq(pt),1] if (is.null(object$robvar.theta)) var.theta <- object$var.theta[seq(1,pt),seq(1,pt),drop=FALSE] else var.theta <- object$robvar.theta[seq(1,pt),seq(1,pt),drop=FALSE] se <- diag(var.theta)^.5 if (is.null(var.link)) if (attr(object,"var.link")==1) vlink <- 1 else vlink <- 0 else vlink <- var.link res <- cbind(theta, se ) wald <- theta/se waldp <- (1 - pnorm(abs(wald))) * 2 if (response=="survival") { if (object$model=="plackett") { spearman <- alpha2spear(theta,link=vlink) Dspear <- numDeriv::jacobian(alpha2spear,theta,link=vlink) var.spearman <- Dspear %*% var.theta %*% Dspear se.spearman <- diag(var.spearman)^.5 res <- as.matrix(cbind(res, wald, waldp,spearman,se.spearman)) if (vlink==1) colnames(res) <- c("log-Coef.", "SE","z", "P-val","Spearman Corr.","SE") else colnames(res) <- c("Coef.", "SE","z", "P-val","Spearman Corr.","SE") if ((!is.null(object$thetanames)) & (nrow(res)==length(object$thetanames))) rownames(res)<-object$thetanames } if (object$model=="clayton.oakes") { kendall <- alpha2kendall(theta,link=vlink) Dken <- numDeriv::jacobian(alpha2kendall,theta,link=vlink) var.kendall<- Dken %*% var.theta %*% Dken se.kendall <- diag(var.kendall)^.5 res <- as.matrix(cbind(res, wald, waldp,kendall,se.kendall)) if (vlink==1) colnames(res) <- c("log-Coef.", "SE","z", "P-val","Kendall tau","SE") else colnames(res) <- c("Coef.", "SE","z", "P-val","Kendall tau","SE") if ((!is.null(object$thetanames)) & (nrow(res)==length(object$thetanames))) rownames(res)<-object$thetanames } } return(res) } ## }}} ##' @export print.mets.twostage<-function(x,digits=3,...) { ## {{{ ### print(x$call); cat("\n") print(summary(x,silent=0)); } ## }}} ##' @export plot.mets.twostage<-function(x,pointwise.ci=1,robust=0,specific.comps=FALSE, level=0.05, start.time=0,stop.time=0,add.to.plot=FALSE,mains=TRUE, xlab="Time",ylab ="Cumulative regression function",...) { ## {{{ if (!(inherits(x, 'two.stage'))) stop("Must be a Two-Stage object") object <- x; rm(x); B<-object$cum; V<-object$var.cum; p<-dim(B)[[2]]; if (robust>=1) V<-object$robvar.cum; if (sum(specific.comps)==FALSE) comp<-2:p else comp<-specific.comps+1 if (stop.time==0) stop.time<-max(B[,1]); med<-B[,1]<=stop.time & B[,1]>=start.time B<-B[med,]; Bs<-B[1,]; B<-t(t(B)-Bs); B[,1]<-B[,1]+Bs[1]; V<-V[med,]; Vs<-V[1,]; V<-t( t(V)-Vs); Vrob<-object$robvar.cum; Vrob<-Vrob[med,]; Vrobs<-Vrob[1,]; Vrob<-t( t(Vrob)-Vrobs); c.alpha<- qnorm(1-level/2) for (v in comp) { c.alpha<- qnorm(1-level/2) est<-B[,v];ul<-B[,v]+c.alpha*V[,v]^.5;nl<-B[,v]-c.alpha*V[,v]^.5; if (add.to.plot==FALSE) { plot(B[,1],est,ylim=1.05*range(ul,nl),type="s",xlab=xlab,ylab=ylab) if (mains==TRUE) title(main=colnames(B)[v]); } else lines(B[,1],est,type="s"); if (pointwise.ci>=1) { lines(B[,1],ul,lty=pointwise.ci,type="s"); lines(B[,1],nl,lty=pointwise.ci,type="s"); } if (robust>=1) { lines(B[,1],ul,lty=robust,type="s"); lines(B[,1],nl,lty=robust,type="s"); } abline(h=0); } } ## }}} ##' @export matplot.mets.twostage <- function(object,...) { ## {{{ B <- object$baseline matplot(B[,1],B[,-1],type="s",...) } ## }}} ##' @export predict.mets.twostage <- function(object,X=NULL,Z=NULL,times=NULL,times2=NULL,theta.des=NULL,diag=TRUE,...) { ## {{{ time.coef <- data.frame(object$cum) if (!is.null(times)) { cum <- Cpred(object$cum,times); cum2 <- Cpred(object$cum,times); } else { cum <- object$cum; cum2 <- object$cum } if (!is.null(times2)) cum2 <- Cpred(object$cum,times2); if (is.null(X)) X <- 1; if (is.null(X) & (!is.null(Z))) { Z <- as.matrix(Z); X <- matrix(1,nrow(Z),1)} if (is.null(Z) & (!is.null(X))) {X <- as.matrix(X); Z <- matrix(0,nrow(X),1); gamma <- 0} if (diag==FALSE) { time.part <- X %*% t(cum[,-1]) time.part2 <- X %*% t(cum2[,-1]) if (!is.null(object$gamma)) { RR <- exp( Z %*% gamma ); cumhaz <- t( t(time.part) * RR ); cumhaz2 <- t( t(time.part2) * RR )} else { cumhaz <- time.part; cumhaz2 <- time.part2; } } else { time.part <- apply(as.matrix(X*cum[,-1]),1,sum) time.part2 <- apply(as.matrix(X*cum2[,-1]),1,sum) } if (!is.null(object$gamma)) { RR<- exp(Z%*%gamma); cumhaz <- t( t(time.part) * RR ); cumhaz2 <- t( t(time.part2) * RR )} else { cumhaz <- time.part; cumhaz2 <- time.part2; } S1 <- exp(-cumhaz); S2 <- exp(-cumhaz2) if (attr(object,"var.link")==1) theta <- exp(object$theta) else theta <- object$theta if (!is.null(theta.des)) theta <- c(theta.des %*% object$theta) if (diag==FALSE) St1t2<- (outer(c(S1)^{-(theta)},c(S2)^{-(theta)},FUN="+") - 1)^(-(1/theta)) else St1t2<- ((S1^{-(theta)}+S2^{-(theta)})-1)^(-(1/theta)) out=list(St1t2=St1t2,S1=S1,S2=S2,times=times,times2=times2,theta=theta) return(out) } ## }}} ##' @export ascertained.pairs ascertained.pairs <-function (pairs,data,cr.models,bin=FALSE) {# {{{ timestatus <- all.vars(cr.models) ### let first event by second column and only ### use pairs where first is event apairs <- pairs if (bin==TRUE) fj <- ifelse(data[pairs[,1],timestatus[1]] > data[pairs[,2],timestatus[1]],1,2) else fj <- ifelse(data[pairs[,1],timestatus[1]] < data[pairs[,2],timestatus[1]],1,2) ### change order when 1st comes first apairs[fj==1,1] <- pairs[fj==1,2] apairs[fj==1,2] <- pairs[fj==1,1] ### only take pairs where first is a jump if (bin==FALSE) { jmpf <- (data[apairs[,2],timestatus[2]]==1) apairs <- apairs[data[apairs[,2],timestatus[2]]==1,] attr(pairs,"jump-first") <- jmpf } pairs <- apairs return(pairs) } # }}} ##' @export alpha2spear <- function(theta,link=1) { ## {{{ if (link==1) theta <- exp(theta) if (length(theta)>1) { out <- c() for (thet in theta) { if (thet!=1) out <- c(out,( (thet+1)/(thet-1) -2* thet* log(thet)/ (thet-1)^2)) else out <- c(out,0) } } else { if (theta!=1) out <- ( (theta+1)/(theta-1) -2* theta* log(theta)/ (theta-1)^2) } return(out) } ## }}} ##' @export alpha2kendall <- function(theta,link=0) { ## {{{ if (link==1) theta <- exp(theta) return(1/(1+2/theta)) } ## }}} ##' @export piecewise.twostage piecewise.twostage <- function(cut1,cut2,data=sys.parent(),timevar="time",status="status",id="id",covars=NULL,covars.pairs=NULL,num=NULL, score.method="optimize",Nit=100,detail=0,silent=1,weights=NULL, control=list(),theta=NULL,theta.des=NULL,var.link=1,iid=1,step=0.5,model="plackett",data.return=0) { ## {{{ ud <- list() if (missing(cut2)) cut2 <- cut1; nc1 <- length(cut1); nc2 <- length(cut2) names1 <- names2 <- c() theta.mat <- se.theta.mat <- cor.mat <- score.mat <- se.cor.mat <- matrix(0,nc1-1,nc2-1); clusters <- data[,id] cluster.call <- clusters idi <- unique(data[,id]); ###print(head(idi)) ## {{{ ### se.clusters=NULL,max.clust=1000, ### evt saette cluster se max.clust paa ### if (is.null(se.clusters)) { se.clusters <- clusters; antiid <- nrow(clusterindex);} else { ### iids <- unique(seclusters); ### antiid <- length(iids); ### if (is.numeric(seclusters)) se.clusters <- fast.approx(iids,se.clusters)-1 ### else se.clusters <- as.integer(factor(se.clusters, labels = seq(antiid)))-1 ### } ### if (length(se.clusters)!=length(clusters)) stop("Length of seclusters and clusters must be same\n"); ### ### if ((!is.null(max.clust))) if (max.clust< antiid) { ### coarse.clust <- TRUE ### qq <- unique(quantile(se.clusters, probs = seq(0, 1, by = 1/max.clust))) ### qqc <- cut(se.clusters, breaks = qq, include.lowest = TRUE) ### se.clusters <- as.integer(qqc)-1 ### max.clusters <- length(unique(se.clusters)) ### maxclust <- max.clust ### antiid <- max.clusters ### } ## }}} if (iid==1) { theta.iid <- matrix(0,length(idi),(nc1-1)*(nc2-1)); rownames(theta.iid) <- idi } else theta.iid <- NULL thetal <- c() k <- 0; for (i1 in 2:nc1) for (i2 in 2:nc2) { k <-(i1-2)*(nc2-1)+(i2-1) if (silent<=0) cat(paste("Data-set ",k,"out of ",(nc1-1)*(nc2-1)),"\n"); datalr <- surv.boxarea(c(cut1[i1-1],cut2[i2-1]),c(cut1[i1],cut2[i2]),data,timevar=timevar, status=status,id=id,covars=covars,covars.pairs=covars.pairs,num=num,silent=silent) if (silent<=-1) print("back in piecewise.twostage"); if (silent<=-1) print(summary(datalr)); if (silent<=-1) print(head(datalr)); if (silent<=-1) print(summary(datalr[,id])); boxlr <- list(left=c(cut1[i1-1],cut2[i2-1]),right=c(cut1[i1],cut2[i2])) datalr$tstime <- datalr[,timevar] datalr$tsstatus <- datalr[,status] datalr$tsid <- datalr[,id] ### if (is.null(covars)) f <- as.formula(with(attributes(datalr),paste("Surv(",time,",",status,")~-1+factor(",num,")"))) else f <- as.formula(with(attributes(datalr),paste("Surv(",time,",",status,")~-1+factor(",num,"):",covars))) marg1 <- aalen(f,data=datalr,n.sim=0,robust=0) fitlr<- survival.twostage(marg1,data=datalr,clusters=datalr$tsid,model=model,score.method=score.method, Nit=Nit,detail=detail,silent=silent,weights=weights, control=control,theta=theta,theta.des=theta.des,var.link=var.link,iid=iid,step=step) #### coef <- coef(fitlr) theta.mat[i1-1,i2-1] <- fitlr$theta se.theta.mat[i1-1,i2-1] <- fitlr$var.theta^.5 cor.mat[i1-1,i2-1] <- coef[1,5] se.cor.mat[i1-1,i2-1] <- coef[1,6] score.mat[i1-1,i2-1] <- fitlr$score if (data.return==0) ud[[k]] <- list(index=c(i1,i2),left=c(cut1[i1-1],cut2[i2-1]),right=c(cut1[i1],cut2[i2]),fitlr=fitlr) if (data.return==1) ud[[k]] <- list(index=c(i1,i2),left=c(cut1[i1-1],cut2[i2-1]),right=c(cut1[i1],cut2[i2]),fitlr=fitlr,data=datalr) if (i2==2) names1 <- c(names1, paste(cut1[i1-1],"-",cut1[i1])) if (i1==2) names2 <- c(names2, paste(cut2[i2-1],"-",cut2[i2])) thetal <- c(thetal,fitlr$theta) if ((silent<=-1) & (iid==1)) print(head(fitlr$theta.iid)); if ((silent<=-1) & (iid==1)) { print(idi) ; print(datalr$tsid) print(dim(fitlr$theta.iid)) print(head(fitlr$theta.iid)) print(dim(theta.iid)) print(length( idi %in% unique(datalr$tsid))) } if (iid==1) theta.iid[idi %in% unique(datalr$tsid),k] <-c(fitlr$theta.iid) ###if (iid==1) theta.iid[rownames(fitlr$theta.iid),k] <- fitlr$theta.iid } var.thetal <- NULL if (iid==1) var.thetal <- t(theta.iid) %*% theta.iid colnames(score.mat) <- colnames(cor.mat) <- colnames(se.cor.mat) <- colnames(se.theta.mat) <- colnames(theta.mat) <- names1; rownames(score.mat) <- rownames(cor.mat) <- rownames(se.cor.mat) <- rownames(se.theta.mat) <- rownames(theta.mat) <- names2; ud <- list(model.fits=ud,theta=theta.mat,var.theta=se.theta.mat^2, se.theta=se.theta.mat,thetal=thetal,thetal.iid=theta.iid,var.thetal=var.thetal,model=model, cor=cor.mat,se.cor=se.cor.mat,score=score.mat); class(ud)<-"pc.twostage" attr(ud,"var.link")<-var.link; attr(ud, "Type") <- model return(ud); } ## }}} ##' @export piecewise.data piecewise.data <- function(cut1,cut2,data=sys.parent(),timevar="time",status="status",id="id",covars=NULL,covars.pairs=NULL,num=NULL,silent=1) { ## {{{ ud <- list() if (missing(cut2)) cut2 <- cut1; nc1 <- length(cut1); nc2 <- length(cut2) dataud <- c() k <- 0; for (i1 in 2:nc1) for (i2 in 2:nc2) { k <-(i1-2)*(nc2-1)+(i2-1) if (silent<=0) cat(paste("Data-set ",k,"out of ",(nc1-1)*(nc2-1)),"\n"); datalr <- surv.boxarea(c(cut1[i1-1],cut2[i2-1]),c(cut1[i1],cut2[i2]),data,timevar=timevar, status=status,id=id,covars=covars,covars.pairs=covars.pairs,num=num,silent=silent) if (silent<=-1) print(summary(datalr)); if (silent<=-1) print(head(datalr)); datalr$tstime <- datalr[,timevar] datalr$tsstatus <- datalr[,status] datalr$tsid <- datalr[,id] ### datalr$strata <- paste( c(cut1[i1-1],cut2[i2-1]),c(cut1[i1],cut2[i2]),collapse=",",sep="-") datalr$intstrata <- c(paste(c(cut1[i1-1],cut1[i1]),collapse=",",sep="-"),paste( c(cut2[i2-1],cut2[i2]),collapse=",",sep="-")) if (silent<=-1) print(head(datalr)); dataud <- rbind(dataud,datalr) } return(data.frame(dataud)) } ## }}} ##' @export summary.pc.twostage <- function(object,var.link=NULL,...) { ## {{{ if (!(inherits(object,"pc.twostage"))) stop("Must be a Piecewise constant two-Stage object") res <- list(estimates=object$theta,se=object$se.theta,cor=object$cor,se.cor=object$se.cor, model=object$model,score=object$score) class(res) <- "summary.pc.twostage" attr(res,"var.link")<-attr(object,"var.link"); attr(res, "Type") <- object$model res } ## }}} ##' @export print.pc.twostage <- function(x,var.link=NULL,...) { ## {{{ if (!(inherits(x,"pc.twostage"))) stop("Must be a Piecewise constant two-Stage object") print( summary(x,var.link=var.link,...)) } ## }}} ##' @export print.summary.pc.twostage <- function(x,var.link=NULL, digits=3,...) { ## {{{ if (is.null(var.link)) { if (attr(x,"var.link")==1) vlink <- 1 else vlink <- 0; } else vlink <- var.link print(vlink) if (x$model=="plackett") cat("Dependence parameter for Plackett model \n"); if (x$model=="clayton.oakes") cat("Dependence parameter for Clayton-Oakes model \n"); if (max(x$score)>0.001) { cat("Score of log-likelihood for parameter estimates (too large?)\n"); print(x$score);cat("\n\n");} if (vlink==1) cat("log-coefficient for dependence parameter (SE) \n") else cat("Dependence parameter (SE) \n"); print(coefmat(x$estimate,x$se,digits=digits,...)) cat("\n") if (x$model=="plackett") {cat("Spearman Correlation (SE) \n");cor.type <- "Spearman Correlation"; } if (x$model=="clayton.oakes") {cat("Kendall's tau (SE) \n"); cor.type <- "Kendall's tau";} print(coefmat(x$cor,x$se.cor,digits,...)) cat("\n") } ## }}} ##' @export coefmat <- function(est,stderr,digits=3,...) { ## {{{ myest <- round(10^digits*(est))/10^digits; myest <- paste(ifelse(myest<0,""," "),myest,sep="") mysd <- round(10^digits*(stderr))/10^digits; res <- matrix(paste(format(myest)," (",format(mysd),")",sep=""),ncol=ncol(est)) dimnames(res) <- dimnames(est) colnames(res) <- paste("",colnames(res)) noquote(res) } ## }}} ##' Wrapper for easy fitting of Clayton-Oakes or bivariate Plackett models for bivariate survival data ##' ##' Fits two-stage model for describing depdendence in survival data ##' using marginals that are on cox or aalen form using the twostage funcion, but ##' call is different and easier and the data manipulation build into the function. ##' Useful in particular for family design data. ##' ##' If clusters contain more than two times, the algoritm uses a composite likelihood ##' based on the pairwise bivariate models. ##' ##' The reported standard errors are based on the estimated information from the ##' likelihood assuming that the marginals are known. ##' ##' @examples ##' library(mets) ##' data("prt",package="mets") ##' prtsam <- blocksample(prt,idvar="id",1e3,replace=FALSE) ##' margp <- coxph(Surv(time,status==1)~factor(country),data=prtsam) ##' fitco <- survival.twostage(margp,data=prtsam,clusters=prtsam$id) ##' summary(fitco) ##' ##' des <- model.matrix(~-1+factor(zyg),data=prtsam); ##' fitco <- survival.twostage(margp,data=prtsam,theta.des=des,clusters=prtsam$id) ##' summary(fitco) ##' rm(prtsam) ##' ##' dfam <- simSurvFam(1000) ##' dfam <- fast.reshape(dfam,var=c("x","time","status")) ##' ##' desfs <- function(x,num1="num1",num2="num2") ##' { ##' pp <- (x[num1]=="m")*(x[num2]=="f")*1 ## mother-father ##' pc <- (x[num1]=="m" | x[num1]=="f")*(x[num2]=="b1" | x[num2]=="b2")*1 ## mother-child ##' cc <- (x[num1]=="b1")*(x[num2]=="b1" | x[num2]=="b2")*1 ## child-child ##' c(pp,pc,cc) ##' } ##' ##' marg <- coxph(Surv(time,status)~factor(num),data=dfam) ##' out3 <- easy.survival.twostage(marg,data=dfam,time="time",status="status",id="id", ##' deshelp=0, ##' score.method="fisher.scoring",theta.formula=desfs, ##' model="plackett", ##' desnames=c("parent-parent","parent-child","child-cild"),iid=1) ##' summary(out3) ##' ##' @keywords survival twostage ##' @export easy.survival.twostage ##' @param margsurv model ##' @param data data frame ##' @param score.method Scoring method ##' @param status Status at exit time ##' @param time Exit time ##' @param entry Entry time ##' @param id name of cluster variable in data frame ##' @param Nit Number of iterations ##' @param detail Detail for more output for iterations ##' @param silent Debug information ##' @param weights Weights for log-likelihood, can be used for each type of outcome in 2x2 tables. ##' @param control Optimization arguments ##' @param theta Starting values for variance components ##' @param theta.formula design for depedence, either formula or design function ##' @param desnames names for dependence parameters ##' @param deshelp if 1 then prints out some data sets that are used, on on which the design function operates ##' @param var.link Link function for variance (exp link) ##' @param iid Calculate i.i.d. decomposition ##' @param step Step size for newton-raphson ##' @param model plackett or clayton-oakes model ##' @param marginal.surv vector of marginal survival probabilities ##' @param strata strata for fitting ##' @param se.clusters clusters for iid decomposition for roubst standard errors easy.survival.twostage <- function(margsurv=NULL,data=sys.parent(),score.method="nlminb", status="status",time="time",entry=NULL,id="id", Nit=60,detail=0, silent=1,weights=NULL, control=list(), theta=NULL,theta.formula=NULL,desnames=NULL,deshelp=0,var.link=1,iid=1, step=0.5,model="plackett",marginal.surv=NULL,strata=NULL,se.clusters=NULL) { ## {{{ ### marginal trunction probabilty, to be computed from model pentry <- NULL if (is.null(marginal.surv)) if (class(margsurv)[1]=="coxph") { ## {{{ ### ps <- survfit(margsurv)$surv coxformula <- margsurv$formula X <- model.matrix(coxformula,data=data)[,-1]; baseout <- survival::basehaz(margsurv,centered=FALSE); baseout <- cbind(baseout$time,baseout$hazard) cumh <- Cpred(baseout,data[,time])[,2] RR<-exp(X %*% coef(margsurv)) ps<-exp(-cumh*RR) ## }}} } else if (class(margsurv)[1]=="phreg") { ## {{{ if (!is.null(margsurv$coef)) rr <- c(exp(margsurv$X %*% margsurv$coef)) else rr <- rep(1,nrow(margsurv$X)) ps <- exp(-rr * Cpred(margsurv$cumhaz,margsurv$exit)[,2]) } ## }}} else stop("marginal survival probabilities must be given as marginal.sur or margsurv \n"); data <- cbind(data,ps) if (!is.null(pentry)) data <- cbind(data,pentry) ### make all pairs in the families, fam <- familycluster.index(data[,id]) data.fam <- data[fam$familypairindex,] data.fam$subfam <- fam$subfamilyindex ### make dependency design using wide format for all pairs data.fam.clust <- fast.reshape(data.fam,id="subfam") if (is.function(theta.formula)) { desfunction <- compiler::cmpfun(theta.formula) if (deshelp==1){ cat("These names appear in wide version of pairs for dependence \n") cat("design function must be defined in terms of these: \n") cat(names(data.fam.clust)); cat("\n") cat("Here is head of wide version with pairs\n") print(head(data.fam.clust)); cat("\n") } des.theta <- t( apply(data.fam.clust,1,desfunction)) colnames(des.theta) <- desnames desnames <- desnames } else { if (is.null(theta.formula)) theta.formula <- ~+1 des.theta <- model.matrix(theta.formula,data=data.fam.clust) desnames <- colnames(des.theta); } data.fam.clust <- cbind(data.fam.clust,des.theta) if (deshelp==1) { cat("These names appear in wide version of pairs for dependence \n") print(head(data.fam.clust)) } ### back to long format keeping only needed variables if (is.null(pentry)) data.fam <- fast.reshape(data.fam.clust,varying=c(id,"ps",status)) else data.fam <- fast.reshape(data.fam.clust,varying=c(id,"ps",status,"pentry")) if (deshelp==1) { cat("Back to long format for twostage (head)\n"); print(head(data.fam)); cat("\n") ### cat(paste("twostage, called with reponse",response,"\n")); cat(paste("cluster=",id,", subcluster (pairs)=subfam \n")); cat(paste("design variables =")); cat(desnames) cat("\n") } if (is.null(pentry)) ptrunc <- NULL else ptrunc <- data.fam[,pentry] out <- survival.twostage(NULL,data=data.fam, clusters=data.fam$subfam, theta.des=as.matrix(data.fam[,desnames]), detail=detail, score.method=score.method, Nit=Nit,step=step, iid=iid,theta=theta, var.link=var.link,model=model, marginal.survival=data.fam[,"ps"], marginal.status=data.fam[,status], marginal.trunc=ptrunc, se.clusters=data.fam[,id]) return(out) } ## }}} ##' @export simSurvFam <- function(n,beta=0.0,theta=1,lam0=0.5,lam1=1,lam2=1,ctime=10,...) { ## {{{ ### n=10; beta=0; theta=1; lam1=1;lam2=1; ctime=10; lam0=0.5 xm <- rbinom(n,1,0.5); xf <- rbinom(n,1,0.5); xb1 <- rbinom(n,1,0.5); xb2 <- rbinom(n,1,0.5); ### zf <- rgamma(n,shape=lam1); zb <- rgamma(n,shape=lam2); tm <- rexp(n)/(zf*exp(xm*beta)*lam0) tf <- rexp(n)/(zf*exp(xf*beta)*lam0) tb1 <- rexp(n)/((zf+zb)*exp(xb1*beta)*2*lam0) tb2 <- rexp(n)/((zf+zb)*exp(xb2*beta)*2*lam0) cm <- ifelse(tm0) { Y0_marg <- cbind(c(Y0[ii1,1],Y0[ii2,2])) idmarg0 <- c(id[ii1],id[ii2]) X0_marg1 <- XX0[ii1,midx1,drop=FALSE] X0_marg2 <- XX0[ii2,midx2,drop=FALSE] dS0_marg <- dS0[,1,drop=FALSE] if (eqmarg) { XX0_marg <- rbind(X0_marg1,X0_marg2) } else { XX0_marg <- XX0[c(ii1,ii2),,drop=FALSE] } if (!is.null(W0)) { W0_marg <- cbind(c(W0[ii1,1],W0[ii2,2])) W0 <- W0[-c(margidx,ii0),,drop=FALSE] } id0 <- id[-c(margidx,ii0)] Y0 <- Y0[-c(margidx,ii0),,drop=FALSE] if (!is.null(Z0)) Z0 <- Z0[-c(margidx,ii0),,drop=FALSE] XX0 <- XX0[-c(margidx,ii0),,drop=FALSE] } res <- list(Y0=Y0,XX0=XX0,W0=W0, Y0_marg=Y0_marg, XX0_marg=XX0_marg, X0_marg1=X0_marg1, X0_marg2=X0_marg2, dS0_marg=dS0_marg, W0_marg=W0_marg, id=idB, idmarg=c(id1,id2), ii1=ii1, id0=id0,idmarg0=idmarg0, ## Original id's margidx=margidx, Z0=Z0) } mets/R/dby.R0000644000176200001440000002327013623061405012330 0ustar liggesusers##' Calculate summary statistics grouped by variable ##' ##' Calculate summary statistics grouped by ##' @title Calculate summary statistics grouped by ##' @param data Data.frame ##' @param INPUT Input variables (character or formula) ##' @param ... functions ##' @param ID id variable ##' @param ORDER (optional) order variable ##' @param SUBSET (optional) subset expression ##' @param SORT sort order (id+order variable) ##' @param COMBINE If TRUE result is appended to data ##' @param NOCHECK No sorting or check for missing data ##' @param ARGS Optional list of arguments to functions (...) ##' @param NAMES Optional vector of column names ##' @param COLUMN If TRUE do the calculations for each column ##' @param REDUCE Reduce number of redundant rows ##' @param REGEX Allow regular expressions ##' @param ALL if FALSE only the subset will be returned ##' @export ##' @author Klaus K. Holst and Thomas Scheike ##' @details ##' dby2 for column-wise calculations ##' @aliases dby dby<- dby2 dby2<- dbyr ##' @examples ##' n <- 4 ##' k <- c(3,rbinom(n-1,3,0.5)+1) ##' N <- sum(k) ##' d <- data.frame(y=rnorm(N),x=rnorm(N),id=rep(seq(n),k),num=unlist(sapply(k,seq))) ##' d2 <- d[sample(nrow(d)),] ##' ##' dby(d2, y~id, mean) ##' dby(d2, y~id + order(num), cumsum) ##' ##' dby(d,y ~ id + order(num), dlag) ##' dby(d,y ~ id + order(num), dlag, ARGS=list(k=1:2)) ##' dby(d,y ~ id + order(num), dlag, ARGS=list(k=1:2), NAMES=c("l1","l2")) ##' ##' dby(d, y~id + order(num), mean=mean, csum=cumsum, n=length) ##' dby(d2, y~id + order(num), a=cumsum, b=mean, N=length, l1=function(x) c(NA,x)[-length(x)]) ##' ##' dby(d, y~id + order(num), nn=seq_along, n=length) ##' dby(d, y~id + order(num), nn=seq_along, n=length) ##' ##' d <- d[,1:4] ##' dby(d, x<0) <- list(z=mean) ##' d <- dby(d, is.na(z), z=1) ##' ##' f <- function(x) apply(x,1,min) ##' dby(d, y+x~id, min=f) ##' ##' dby(d,y+x~id+order(num), function(x) x) ##' ##' f <- function(x) { cbind(cumsum(x[,1]),cumsum(x[,2]))/sum(x)} ##' dby(d, y+x~id, f) ##' ##' ## column-wise ##' a <- d ##' dby2(a, mean, median, REGEX=TRUE) <- '^[y|x]'~id ##' a ##' ## wildcards ##' dby2(a,'y*'+'x*'~id,mean) ##' ##' ##' ## subset ##' dby(d, x<0) <- list(z=NA) ##' d ##' dby(d, y~id|x>-1, v=mean,z=1) ##' dby(d, y+x~id|x>-1, mean, median, COLUMN=TRUE) ##' ##' dby2(d, y+x~id|x>0, mean, REDUCE=TRUE) ##' ##' dby(d,y~id|x<0,mean,ALL=FALSE) ##' ##' a <- iris ##' a <- dby(a,y=1) ##' dby(a,Species=="versicolor") <- list(y=2) dby <- function(data,INPUT,...,ID=NULL,ORDER=NULL,SUBSET=NULL,SORT=0,COMBINE=!REDUCE,NOCHECK=FALSE,ARGS=NULL,NAMES,COLUMN=FALSE,REDUCE=FALSE,REGEX=mets.options()$regex,ALL=TRUE) { if (missing(INPUT)) INPUT <- .~1 val <- substitute(INPUT) INPUT <- try(eval(val),silent=TRUE) funs <- substitute(list(...))[-1] if (inherits(INPUT,"try-error")) { INPUT <- as.formula(paste0(".~1|",deparse(val))) } if (inherits(INPUT,c("formula","character"))) { INPUT <- procformdata(INPUT,sep="\\|",data=data,na.action=na.pass,do.filter=FALSE,regex=REGEX,specials="order") if (is.null(ID)) ID <- INPUT$predictor if (is.null(SUBSET)) { if (length(INPUT$group)!=0) SUBSET <- INPUT$group[[1]] } if (is.null(ORDER)) { if (length(INPUT$specials$order)!=0) ORDER <- INPUT$specials$order[[1]] } INPUT <- INPUT$response } if (inherits(ID,"formula")) ID <- model.frame(ID,data=data,na.action=na.pass) if (inherits(ORDER,"formula")) ORDER <- model.frame(ORDER,data=data,na.action=na.pass) if (inherits(SUBSET,"formula")) SUBSET <- model.frame(SUBSET,data=data,na.action=na.pass) if (is.null(INPUT)) { INPUT <- ID ID <- NULL } noID <- FALSE if (length(ID)==0) { noID <- TRUE ID = rep(1,NROW(INPUT)) } group <- NULL if (!COMBINE || length(funs)==0) group <- ID if (NCOL(ID)>1) ID <- interaction(ID) if (is.data.frame(ID)) { ID <- as.numeric(ID[,1,drop=TRUE]) } else { ID <- as.numeric(ID) } if (is.data.frame(ORDER)) { ORDER <- ORDER[,1,drop=TRUE] } if (!NOCHECK) { if (length(ORDER)>0) { ord <- order(ID,ORDER,decreasing=SORT,method="radix") } else { ord <- order(ID,decreasing=SORT,method="radix") } numerics <- unlist(lapply(INPUT[1,],is.numeric)) INPUT <- as.matrix(INPUT[ord,which(numerics),drop=FALSE]) ID <- ID[ord] if (is.null(group)) data <- data[ord,,drop=FALSE] else { if (is.vector(group)) group <- group[ord] else group <- group[ord,,drop=FALSE] } na.idx <- which(is.na(ID)) } else { INPUT <- as.matrix(INPUT) } if (length(SUBSET)>0) { SUBSET <- which(as.matrix(SUBSET)) INPUT <- INPUT[SUBSET,,drop=FALSE] ID <- ID[SUBSET] } if (length(funs)==0) { if (noID) return(INPUT) return(cbind(INPUT,group)) } if (NROW(INPUT)>0) { resl <- lapply(funs, function(fun_) { env <- new.env() isfun <- tryCatch(is.function(eval(fun_)),error=function(...) FALSE) if (isfun) { env$fun_ <- eval(fun_) if (length(ARGS)>0) { fun_ <- eval(fun_) ff <- function(...) do.call(fun_,c(list(...),ARGS)) expr <- quote(ff(x)) } else { expr <- quote(fun_(x)) } } else { expr <- fun_ } .ApplyBy2(INPUT,ID,F=expr,Env=env,Argument="x",Columnwise=COLUMN) }) res <- Reduce(cbind,resl) } else { resl <- NULL res <- NULL } dn <- NULL ## Setting column names if (missing(NAMES)) { a <- match.call(expand.dots=FALSE) ff <- lapply(a[["..."]],deparse) fn <- lapply(ff,deparse) dn <- names(ff) if (is.null(dn)) dn <- rep("",length(ff)) idx <- which(dn=="") if (length(idx)>0) { newn <- unlist(ff[idx]) dn[idx] <- newn[seq_along(idx)] fcall <- grepl("^function",dn) if (any(fcall)) dn[which(fcall)] <- which(fcall) } numcolf <- unlist(lapply(resl, NCOL)) nn <- c() if (COLUMN) { colnames(INPUT) dn <- unlist(lapply(dn, function(x) paste(x,colnames(INPUT),sep="."))) } for (i in seq_along(resl)) { nc <- numcolf[i] curnam <- dn[i] if (COLUMN) { nc <- nc/NCOL(INPUT) pos <- NCOL(INPUT)*(i-1)+1 pos <- seq(pos,pos+NCOL(INPUT)-1) curnam <- dn[pos] } if (nc>1) { nn <- c(nn, unlist(lapply(curnam, function(x) paste0(x,seq(nc))))) } else nn <- c(nn,curnam) } NAMES <- nn } try(colnames(res) <- NAMES,silent=TRUE) numidx <- grep("^[0-9]",colnames(res)) ## column names starting with digit if (length(numidx)>0) colnames(res)[numidx] <- paste0("_",colnames(res)[numidx]) if (!NOCHECK && length(na.idx)>0) { res[na.idx,] <- NA } cl <- attr(resl[[1L]],"clustersize") if (COMBINE) { if (is.null(NAMES) & is.null(res) & length(dn)>0) { res <- matrix(NA,nrow(data),length(dn)) colnames(res) <- dn } nn <- colnames(res) nc <- ifelse(is.null(res), 0, ncol(res)) res0 <- matrix(NA,nrow(data),nc) colnames(res0) <- nn didx <- which(colnames(data)%in%nn) if (length(didx)>0) { ridx <- match(colnames(data)[didx],nn) res0[,ridx] <- as.matrix(data[,didx]) data <- data[,-didx,drop=FALSE] } if (length(SUBSET)>0) { res0[SUBSET,] <- res res <- cbind(data,res0) } else { if (!is.null(res)) res <- cbind(data,res) else res <- data } } else { if (!noID) { if (length(SUBSET)>0) group <- group[SUBSET,,drop=FALSE] res <- cbind(group,res) } } if (REDUCE!=0) { if (REDUCE<0) { # Grab the last observation idx <- cumsum(cl) } else { # Grab the first idx <- cumsum(c(1,cl[-length(cl)])) } res <- res[unique(idx),,drop=FALSE] if (NROW(res)==1) { rownames(res) <- "" } else { rownames(res) <- NULL } } if (!ALL) { return(res[SUBSET,,drop=FALSE]) } return(res) } ##' @export "dby<-" <- function(data,INPUT,...,value) { cl <- match.call() cl[[1L]] <- substitute(dby) a <- substitute(value) if (inherits(value,"formula")) { cl["value"] <- NULL names(cl)[names(cl)=="INPUT"] <- "" cl[["INPUT"]] <- value } else { if (is.list(value)) { cl[which(names(cl)=="value")] <- NULL start <- length(cl) for (i in seq_along(value)) { cl[start+i] <- value[i] } if (length(names(value))>0) names(cl)[start+seq_along(value)] <- names(value) } else { names(cl)[which(names(cl)=="value")] <- "" } } eval.parent(cl) } ##' @export dby2 <- function(data,INPUT,...) { cl <- match.call() cl[[1L]] <- substitute(dby) cl[["COLUMN"]] <- TRUE eval.parent(cl) } ##' @export "dby2<-" <- function(data,INPUT,...,value) { cl <- match.call() cl[[1L]] <- substitute(`dby<-`) cl[["COLUMN"]] <- TRUE eval.parent(cl) } ##' @export dbyr <- function(data,INPUT,...,COLUMN=FALSE) { cl <- match.call() cl[[1L]] <- substitute(`dby`) cl[["REDUCE"]] <- TRUE cl[["COLUMN"]] <- COLUMN eval.parent(cl) } mets/R/binomial.regression.R0000644000176200001440000002360513623061405015525 0ustar liggesusers##' Binomial Regression for censored competing risks data ##' ##' Simple version of comp.risk function of timereg for just one time-point thus fitting the model ##' \deqn{P(T \leq t, \epsilon=1 | X ) = expit( X^T beta) } ##' ##' Based on binomial regresion IPCW response estimating equation: ##' \deqn{ X ( \Delta I(T \leq t, \epsilon=1 )/G_c(T_i-) - expit( X^T beta)) = 0 } ##' for IPCW adjusted responses. ##' ##' @param formula formula with outcome (see \code{coxph}) ##' @param data data frame ##' @param cause cause of interest ##' @param time time of interest ##' @param beta starting values ##' @param offset offsets for partial likelihood ##' @param weights for score equations ##' @param cens.weights censoring weights ##' @param cens.model stratified cox model ##' @param se to compute se's based on IPCW ##' @param kaplan.meier uses Kaplan-Meier for baseline than standard Cox ##' @param cens.code gives censoring code ##' @param no.opt to not optimize ##' @param method for optimization ##' @param ... Additional arguments to lower level funtions ##' @author Thomas Scheike ##' @examples ##' ##' data(bmt) ##' # logistic regresion with IPCW binomial regression ##' out <- binreg(Event(time,cause)~tcell+platelet,bmt,time=50) ##' summary(out) ##' predict(out,data.frame(tcell=c(0,1),platelet=c(1,1)),se=TRUE) ##' ##' outs <- binreg(Event(time,cause)~tcell+platelet,bmt,time=50,cens.model=~strata(tcell,platelet)) ##' summary(outs) ##' ##' @export binreg <- function(formula,data,cause=1,time=NULL,beta=NULL, offset=NULL,weights=NULL,cens.weights=NULL,cens.model=~+1,se=TRUE, kaplan.meier=TRUE,cens.code=0,no.opt=FALSE,method="nr",...) {# {{{ cl <- match.call()# {{{ m <- match.call(expand.dots = TRUE)[1:3] special <- c("strata", "cluster","offset") Terms <- terms(formula, special, data = data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) Y <- model.extract(m, "response") if (class(Y)!="Event") stop("Expected a 'Event'-object") if (ncol(Y)==2) { exit <- Y[,1] entry <- NULL ## rep(0,nrow(Y)) status <- Y[,2] } else { stop("only right censored data, will not work for delayed entry\n"); entry <- Y[,1] exit <- Y[,2] status <- Y[,3] } id <- strata <- NULL if (!is.null(attributes(Terms)$specials$cluster)) { ts <- survival::untangle.specials(Terms, "cluster") pos.cluster <- ts$terms Terms <- Terms[-ts$terms] id <- m[[ts$vars]] } else pos.cluster <- NULL if (!is.null(stratapos <- attributes(Terms)$specials$strata)) { ts <- survival::untangle.specials(Terms, "strata") pos.strata <- ts$terms Terms <- Terms[-ts$terms] strata <- m[[ts$vars]] strata.name <- ts$vars } else { strata.name <- NULL; pos.strata <- NULL} if (!is.null(offsetpos <- attributes(Terms)$specials$offset)) { ts <- survival::untangle.specials(Terms, "offset") Terms <- Terms[-ts$terms] offset <- m[[ts$vars]] } X <- model.matrix(Terms, m) if (ncol(X)==0) X <- matrix(nrow=0,ncol=0) ### possible handling of id to code from 0:(antid-1) if (!is.null(id)) { ids <- sort(unique(id)) nid <- length(ids) if (is.numeric(id)) id <- fast.approx(ids,id)-1 else { id <- as.integer(factor(id,labels=seq(nid)))-1 } } else id <- as.integer(seq_along(exit))-1; ### id from call coded as numeric 1 -> id.orig <- id; if (is.null(offset)) offset <- rep(0,length(exit)) if (is.null(weights)) weights <- rep(1,length(exit)) # }}} if (is.null(time)) stop("Must give time for logistic modelling \n"); statusC <- (status==cens.code) statusE <- (status==cause) & (exit<= time) if (sum(statusE)==0) stop("No events of type 1 before time \n"); kmt <- kaplan.meier statusC <- (status==cens.code) data$id <- id data$exit <- exit data$statusC <- statusC cens.strata <- cens.nstrata <- NULL if (is.null(cens.weights)) { formC <- update.formula(cens.model,Surv(exit,statusC)~ . +cluster(id)) resC <- phreg(formC,data) if (resC$p>0) kmt <- FALSE cens.weights <- predict(resC,data,times=exit,tminus=TRUE,individual.time=TRUE,se=FALSE,km=kmt)$surv ## strata from original data cens.strata <- resC$strata[resC$ord] cens.nstrata <- resC$nstrata } else formC <- NULL expit <- function(z) 1/(1+exp(-z)) ## expit if (is.null(beta)) beta <- rep(0,ncol(X)) p <- ncol(X) X <- as.matrix(X) X2 <- .Call("vecMatMat",X,X)$vXZ ###mm <- .Call("CubeVec",D2logl,Dlogl) obj <- function(pp,all=FALSE) { # {{{ lp <- c(X %*% pp) p <- expit(lp) ### Y <- c((status==cause)*(exit<=time)/cens.weights) ploglik <- sum(weights*(Y-p)^2) Dlogl <- weights*X*c(Y-p) D2logl <- c(weights*p/(1+exp(lp)))*X2 D2log <- apply(D2logl,2,sum) ### gradient <- apply(Dlogl,2,sum) hessian <- matrix(D2log,length(pp),length(pp)) if (all) { ihess <- solve(hessian) beta.iid <- Dlogl %*% ihess ## %*% t(Dlogl) beta.iid <- apply(beta.iid,2,sumstrata,id,max(id)+1) robvar <- crossprod(beta.iid) val <- list(par=pp,ploglik=ploglik,gradient=gradient,hessian=hessian,ihessian=ihess, id=id,Dlogl=Dlogl, iid=beta.iid,robvar=robvar,var=robvar, se=diag(robvar)^.5,se.robust=diag(robvar)^.5) return(val) } structure(-ploglik,gradient=-gradient,hessian=hessian) }# }}} p <- ncol(X) opt <- NULL if (p>0) { if (no.opt==FALSE) { if (tolower(method)=="nr") { tim <- system.time(opt <- lava::NR(beta,obj,...)) opt$timing <- tim opt$estimate <- opt$par } else { opt <- nlm(obj,beta,...) opt$method <- "nlm" } cc <- opt$estimate; if (!se) return(cc) val <- c(list(coef=cc),obj(opt$estimate,all=TRUE)) } else val <- c(list(coef=beta),obj(beta,all=TRUE)) } else { val <- obj(0,all=TRUE) } if (length(val$coef)==length(colnames(X))) names(val$coef) <- colnames(X) val <- c(val,list(time=time,formula=formula,formC=formC, exit=exit, cens.weights=cens.weights, cens.strata=cens.strata, cens.nstrata=cens.nstrata, model.frame=m)) if (se) {## {{{ censoring adjustment of variance ord <- resC$cox.prep$ord+1 X <- X[ord,,drop=FALSE] status <- status[ord] exit <- exit[ord] cens.weights <- cens.weights[ord] lp <- c(X %*% val$coef) p <- expit(lp) Y <- c((status==cause)*(exit<=time)/cens.weights) Dlogl <- weights*X*c(Y-p) hessian <- val$hessian xx <- resC$cox.prep S0i2 <- S0i <- rep(0,length(xx$strata)) S0i[xx$jumps+1] <- 1/resC$S0 S0i2[xx$jumps+1] <- 1/resC$S0^2 U <- matrix(0,nrow(xx$X),ncol(X)) ### Ys <- revcumsumstrata(xx$sign,xx$strata,xx$nstrata) ## compute function h(s) = \sum_i X_i Y_i(t) I(s \leq T_i \leq t) ## to make \int h(s)/Ys dM_i^C(s) h <- apply(X*Y,2,revcumsumstrata,xx$strata,xx$nstrata) h2 <- .Call("vecMatMat",h,h)$vXZ U[xx$jumps+1,] <- h[xx$jumps+1]/resC$S0 ### Cens-Martingale as a function of time and for all subjects to handle strata ## to make \int h(s)/Ys dM_i^C(s) = \int h(s)/Ys dN_i^C(s) - dLambda_i^C(s) IhdLam0 <- apply(h*S0i2,2,cumsumstrata,xx$strata,xx$nstrata) MGt <- (U[,drop=FALSE]-IhdLam0)*c(xx$weights) ### Censoring Variance Adjustment \int h^2(s) / y.(s) d Lam_c(s) estimated by \int h^2(s) / y.(s)^2 d N.^C(s) Ih2dLam0 <- apply(h2*S0i2,2,sum) varadjC <- matrix(Ih2dLam0,length(val$coef),length(val$coef)) id <- xx$id MGCiid <- apply(MGt,2,sumstrata,id,max(id)+1) val$varadjC <- val$ihessian %*% varadjC %*% val$ihessian val$MGtid <- id val$nc.iid <- val$iid beta.iid <- val$iid+(MGCiid %*% val$ihessian) val$iid <- beta.iid val$naive.var <- val$var val$var <- val$var - val$varadjC robvar <- crossprod(beta.iid) val$robvar <- robvar val$se.robust <- diag(robvar)^.5 val$se <- diag(val$var)^.5 } ## }}} class(val) <- "binreg" return(val) }# }}} ##' @export iid.binreg <- function(x,...) {# {{{ x$iid }# }}} ##' @export print.binreg <- function(x,...) {# {{{ print(summary(x),...) }# }}} ##' @export summary.binreg <- function(object,or=TRUE,...) {# {{{ if (or) { cat("OR estimates \n"); estimate(coef=object$coef,vcov=object$var,f=function(p) exp(p)) } else { cat("log-OR estimates \n"); estimate(coef=object$coef,vcov=object$var) } }# }}} ##' @export vcov.binreg <- function(object,...) {# {{{ return(object$var) }# }}} ##' @export predict.binreg <- function(object,newdata,se=TRUE,...) {# {{{ xlev <- lapply(object$model.frame,levels) ff <- unlist(lapply(object$model.frame,is.factor)) upf <- update(object$formula,~.) tt <- terms(upf) tt <- delete.response(tt) Z <- model.matrix(tt,data=newdata,xlev=xlev) Z <- as.matrix(Z) expit <- function(z) 1/(1+exp(-z)) ## expit lp <- c(Z %*% object$coef) p <- expit(lp) preds <- p if (se) { preds <- c() for (i in 1:length(lp)) { if (is.null(object$var)) covv <- vcov(object) else covv <- object$var Dp <- Z[i,]*exp(-lp[i])*p[i]^2 se <- (Dp %*% covv %*% Dp)^.5 cmat <- data.frame(pred=p[i],se=se,lower=p[i]-1.96*se,upper=p[i]+1.96*se) names(cmat)[1:4] <- c("pred","se","lower","upper") preds <- rbind(preds,cmat) } } return(preds) } # }}} ###predict.binreg <- function(x,newdata,se=TRUE,...) ###{# {{{ ### Z <- as.matrix(model.matrix(x$formula,newdata)) ### expit <- function(z) 1/(1+exp(-z)) ## expit ### lp <- c(Z %*% x$coef) ### p <- expit(lp) ### preds <- p ### ### if (se) { ### Ft <- function(p,lpi=1) ### {# {{{ ### p <- expit(lpi) ### return(p) ### }# }}} ### ### preds <- c() ### for (i in 1:length(lp)) { ### if (is.null(x$var)) covv <- vcov(x) else covv <- x$var ### eud <- estimate(coef=x$coef,vcov=covv,f=function(p) Ft(p,lpi=lp[i])) ### cmat <- data.frame(eud$coefmat) ### names(cmat)[1:4] <- c("pred","se","lower","upper") ### preds <- rbind(preds,cmat) ### } ### } ### ###return(preds) ###} # }}} ### mets/R/vcov.biprobit.R0000644000176200001440000000007613623061405014337 0ustar liggesusers##' @export vcov.biprobit <- function(object,...) object$vcov mets/R/phreg.par.R0000644000176200001440000002753013623061405013443 0ustar liggesusers## library(lava) ## m <- lvm(y~x) ## distribution(m,~y) <- coxWeibull.lvm(shape=3,scale=5) ## transform(m,~status) <- function(...) TRUE ## d <- sim(m,2e4,p=c("y~x"=2)) ## library(eha) ## with(d,phreg.par(y,status,cbind(x))) ## weibreg(Surv(y,status)~x,data=d) ## ## Note in simulation A(t) = lambda*t^scale ## ## but here A(t) (scale*t)^shape, hence ## ## lambda := scale^(1/shape) ## tt <- seq(0,100,length.out=100) ## plot(tt,exp(-(exp(-4)*tt)^exp(.5)) ## y <- runif(2e4,0,100) ## (op <- phreg.par(y,TRUE)) ## tt <- seq(0,100,length.out=100) ## cc <- coxph(Surv(y,rep(TRUE,length(y)))~1) ## plot(survfit(cc),mark.time=FALSE) ## lines(tt,exp(-(exp(-4)*tt)^exp(.484)),col="red") ##(op <- phreg.weibull(d$y,TRUE,cbind(d$x))) ## (a <- survival::survreg(Surv(y,status)~1+x,dist="weibull",data=d)) ## (e <- eha::weibreg(Surv(y,status)~x,data=d)) ###{{{ Weibull info.weibull <- function(...) { list(npar=2, start=c(-1,-1), name="weibull", partrans=function(theta) { exp(theta) }, cumhaz=function(t,theta) { (theta[1]*t)^theta[2] } ) } logl.weibull <- function(theta,time,status,X=NULL,theta.idx=NULL,indiv=FALSE) { if (!is.null(theta.idx)) { offsets <- which(is.na(theta.idx)) theta <- theta[theta.idx] theta[offsets] <- 1 } lambda <- exp(theta[1]) p <- exp(theta[2]) if (is.null(X)) { eta <- 0 } else { beta <- theta[-c(1:2)] eta <- X%*%beta } val <- status*log(lambda*p) + status*(p-1)*log(lambda*time) + status*eta - (lambda*time)^p*exp(eta) if (indiv) return(val) sum(val) } obj.weibull <- function(...) -logl.weibull(...) score.weibull <- function(theta,time,status,X=NULL,theta.idx=NULL,indiv=FALSE) { if (!is.null(theta.idx)) { offsets <- which(is.na(theta.idx)) theta <- theta[theta.idx] theta[offsets] <- 1 } lambda <- exp(theta[1]) p <- exp(theta[2]) lambdaT <- lambda*time loglambdaT <- log(lambdaT) lambdaTp <- exp(loglambdaT*p) if (is.null(X)) { eta <- 0; expeta <- 1 dbeta <- NULL } else { beta <- theta[-c(1:2)] eta <- X%*%beta expeta <- exp(eta) dbeta <- ((status-expeta*lambdaTp)%x%rbind(rep(1,NCOL(X))))*X } dp <- status*(1/p + loglambdaT) - loglambdaT*lambdaTp*expeta dlogp <- p*dp dlambda <- status*(p/lambda) - p*lambdaTp/lambda*expeta dloglambda <- lambda*dlambda S <- cbind(dloglambda,dlogp,dbeta) if (!is.null(theta.idx)) { u.idx <- na.omit(unique(theta.idx)) newS <- matrix(0,ncol=length(u.idx),nrow=nrow(S)) for (i in u.idx) { newS[,i] <- cbind(rowSums(S[,which(theta.idx==i),drop=FALSE])) } S <- newS } if (indiv) return(S) colSums(S) } hessian.weibull <- function(theta,time,status,X=NULL,theta.idx=NULL,all=FALSE) { if (!is.null(theta.idx)) { offsets <- which(is.na(theta.idx)) theta <- theta[theta.idx] theta[offsets] <- 1 } lambda <- exp(theta[1]) p <- exp(theta[2]) lambdaT <- lambda*time loglambdaT <- log(lambdaT) Tp <- time^p lambdaTp <- lambda^p*Tp if (is.null(X)) { eta <- 0; expeta <- 1 d2dlogpdbeta <- d2dlogpdbeta <- d2beta <- NULL } else { beta <- theta[-c(1:2)] eta <- X%*%beta expeta <- exp(eta) ## D(beta,beta) U <- ((expeta*Tp)%x%rbind(rep(1,NCOL(X))))*X d2beta <- -t(lambda^p*U)%*%X ## D(p,beta) d2dpdbeta <- colSums(-((loglambdaT*lambdaTp*expeta)%x%rbind(rep(1,NCOL(X))))*X) d2dlogpdbeta <- d2dpdbeta*p ## D(lambda,beta) d2dlambdadbeta <- -U*p*lambda^(p-1) d2dloglambdadbeta <- colSums(d2dlambdadbeta)*lambda } ## D(p,p) dp <- status*(1/p + loglambdaT) - loglambdaT*lambdaTp*expeta d2p <- -sum(status/(p^2) + loglambdaT^2*expeta*lambdaTp) dlogp <- p*dp d2logp <- sum(dlogp)+p^2*d2p ## D(lambda,lambda) dlambda <- status*(p/lambda) - p*lambdaTp/lambda*expeta d2lambda <- -sum(status*(p/lambda^2) + p*(p-1)*lambdaTp/(lambda^2)*expeta) dloglambda <- lambda*dlambda d2loglambda <- sum(dloglambda)+lambda^2*d2lambda ## D(p,lambda) d2dpdlambda <- -status/(p^2) - loglambdaT^2*expeta*lambdaTp d2dpdlambda <- status/lambda - lambdaTp/lambda*expeta - p*loglambdaT*lambdaTp/lambda*expeta d2dlogpdloglambda <- sum(d2dpdlambda)*p*lambda ## Hessian: H <- matrix(0,length(theta),length(theta)) H[1,1] <- d2loglambda H[2,2] <- d2logp H[1,2] <- H[2,1] <- d2dlogpdloglambda if (!is.null(X)) { H[3:length(theta),3:length(theta)] <- d2beta H[2,3:length(theta)] <- H[3:length(theta),2] <- d2dlogpdbeta H[1,3:length(theta)] <- H[3:length(theta),1] <- d2dloglambdadbeta } if (!is.null(theta.idx)) { u.idx <- na.omit(unique(theta.idx)) newH <- matrix(0,length(u.idx),length(u.idx)) for (i in u.idx) { for (j in u.idx) { newH[i,j] <- sum(H[which(theta.idx==i),which(theta.idx==j)]) } } H <- newH } if (all) { ## Score: if (is.null(X)) dbeta <- NULL else dbeta <- status*X-lambda^p*U S <- cbind(dloglambda,dlogp,dbeta) if (!is.null(theta.idx)) { u.idx <- na.omit(unique(theta.idx)) newS <- matrix(0,ncol=length(u.idx),nrow=nrow(S)) for (i in u.idx) { newS[,i] <- cbind(rowSums(S[,which(theta.idx==i),drop=FALSE])) } S <- newS } attributes(H)$grad <- colSums(S) attributes(H)$score <- S ## LogLik attributes(H)$logL <- sum(status*log(lambda*p) + status*(p-1)*loglambdaT + status*eta - lambdaTp*expeta) } return(H) } ###}}} Weibull ###{{{ Generalized-Gamma ## http://www.stanford.edu/~lutian/coursepdf/unit1.pdf gengamma.f <- function(t,p,lambda,alpha,...) { p*lambda*(lambda*t)^(alpha-1)*exp(-(lambda*t)^p)/gamma(alpha/p) } ## incomplete gamma gamma(s,x) = pgamma(x,s) gengamma.F <- function(t,p,lambda,alpha,...) { pgamma((lambda*t)^p,alpha/p)/gamma(alpha/p) } ## incomplete gamma gamma(s,x) = pgamma(x,s) gengamma.h <- function(t,p,lambda,alpha,...) { p*lambda*(lambda*t)^(alpha-1)*exp(-(lambda*t)^p)/pgamma((lambda*t)^p,alpha/p) } logl.gengamma <- function(theta,time,status,X=NULL,indiv=FALSE,...) { ## suppressMessages(browser()) p <- exp(theta[1]) lambda <- exp(theta[2]) alpha <- exp(theta[3]) eta <- 0 if (!is.null(X)) { beta <- theta[seq(length(theta)-3)+3] eta <-X%*%beta } res <- log(gengamma.f(time,p,lambda,alpha))*status + status*eta + log(1-gengamma.F(time,p,lambda,alpha)*exp(eta)) if (indiv) return(res) return(sum(res)) } score.gengamma <- function(theta,...) { numDeriv::jacobian(logl.gengamma,theta,...) } hessian.gengamma <- function(theta,...) { numDeriv::hessian(logl.gengamma,theta,...) } info.gengamma <- function(...) { list(npar=3,start=c(-1,-1,-1),name="gengamma") } ###}}} Generalized-Gamma ##' @export predict.phreg.par <- function(object,p=coef(object),X=object$X,time=object$time,...) { info <- do.call(paste("info",object$model,sep="."),list()) cc <- coef(object) eta <- 0 if (length(cc)>info$npar) { eta <- X%*%p[-seq(info$npar)] } exp(-(info$cumhaz(time,info$partrans(p))*exp(eta))) } ###{{{ phreg.par + methods ##' @export phreg.par <- function(formula,data=parent.frame(), time,status,X=NULL,model="weibull", theta.idx=NULL,theta0,niter=100,tol1=1e-9,tol2=1e-9,lambda1=0.5,lambda2=1,trace=0,...) { if (!missing(formula)) { cl <- match.call() m <- match.call(expand.dots = TRUE)[1:3] special <- c("strata", "cluster") Terms <- terms(formula, special, data = data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) Y <- model.extract(m, "response") if (!is.Surv(Y)) stop("Expected a 'Surv'-object") if (ncol(Y)==2) { exit <- eval(Y[,1],data) entry <- NULL ## rep(0,nrow(Y)) status <- Y[,2] } else { entry <- Y[,1] exit <- Y[,2] status <- Y[,3] } id <- strata <- NULL if (!is.null(attributes(Terms)$specials$cluster)) { ts <- survival::untangle.specials(Terms, "cluster") Terms <- Terms[-ts$terms] id <- m[[ts$vars]] } if (!is.null(stratapos <- attributes(Terms)$specials$strata)) { ts <- survival::untangle.specials(Terms, "strata") Terms <- Terms[-ts$terms] strata <- m[[ts$vars]] } X <- model.matrix(Terms, m) if (!is.null(intpos <- attributes(Terms)$intercept)) X <- X[,-intpos,drop=FALSE] if (ncol(X)==0) X <- NULL time <- exit } myinfo <- do.call(paste("info",model,sep="."),list()) if (is.null(X)) { theta0 <- myinfo$start } else { if (missing(theta0)) theta0 <- rep(0,ifelse(is.null(theta.idx), myinfo$npar+NCOL(X),length(unique(na.omit(theta.idx))))) } hess <- paste("hessian",model,sep=".") scor <- paste("score",model,sep=".") logl <- paste("logl",model,sep=".") thetas <- theta0; logL <- c() for (i in 1:niter) { H <- do.call(hess, list(theta=theta0,all=TRUE,time=time,status=status,X=X,theta.idx=theta.idx)) if (!is.null(attributes(H)$score)) { S <- colSums(attributes(H)$score) } else { S <- do.call(scor, list(theta=theta0,time=time,status=status,X=X)) } gamma <- 0 if (lambda2>0) gamma <- lambda2*sqrt((t(S)%*%S)[1])*diag(NROW(H)) theta0 <- theta0 - lambda1*solve(H-gamma)%*%S thetas <- rbind(thetas,as.vector(theta0)) if (!is.null(attributes(H)$logL)) { logL <- c(logL, attributes(H)$logL) } else { logL <- c(logL,do.call(logl, list(theta=theta0,time=time,status=status,X=X))) } if(trace>0) if (i%%trace==0) { cat("Iter=",i, ", logLik=",tail(logL,1),"\n",sep="") cat("theta=(",paste(formatC(theta0),collapse=";"),")\n",sep="") } if (i>1) if (sum(abs(S^2))info$npar) { eta <- X%*%p[-seq(info$npar)] } exp(-(info$cumhaz(time,info$partrans(p))*exp(eta))) } mets/R/wild-phreg.R0000644000176200001440000002406213623061405013614 0ustar liggesusers##' Wild bootstrap for Cox PH regression ##' ##' wild bootstrap for uniform bands for Cox models ##' @param formula formula with 'Surv' outcome (see \code{coxph}) ##' @param data data frame ##' @param offset offsets for cox model ##' @param weights weights for Cox score equations ##' @param B bootstraps ##' @param type distribution for multiplier ##' @param ... Additional arguments to lower level funtions ##' @author Klaus K. Holst, Thomas Scheike ##' @examples ##' ##' n <- 100 ##' x <- 4*rnorm(n) ##' time1 <- 2*rexp(n)/exp(x*0.3) ##' time2 <- 2*rexp(n)/exp(x*(-0.3)) ##' status <- ifelse(time10) { if (no.opt==FALSE) { if (tolower(method)=="nr") { opt <- lava::NR(beta,obj,...) opt$estimate <- opt$par } else { opt <- nlm(obj,beta,...) opt$method <- "nlm" } cc <- opt$estimate; names(cc) <- colnames(X) if (!stderr) return(cc) val <- c(list(coef=cc),obj(opt$estimate,all=TRUE)) } else val <- c(list(coef=beta),obj(beta,all=TRUE)) } else { val <- obj(beta,all=TRUE) ### val[c("ploglik","gradient","hessian","U")] <- NULL } se.cumhaz <- lcumhaz <- lse.cumhaz <- NULL II <- NULL ### computes Breslow estimator ### if (no.opt==FALSE & p!=0) II <- -solve(val$hessian) else II <- matrix(0,p,p) strata <- val$strata[val$jumps] nstrata <- val$nstrata jumptimes <- val$jumptimes ## Brewslow estimator cumhaz <- cbind(jumptimes,cumsumstrata(1/val$S0,strata,nstrata)) ### varbetat <- 0 ### if (no.opt==FALSE & p!=0) { ### DLambeta.t <- apply(val$E/c(val$S0),2,cumsumstrata,strata,nstrata) ### varbetat <- rowSums((DLambeta.t %*% II)*DLambeta.t) ### } ### covv <- apply(covv*DLambeta.t,1,sum) Covariance is "0" by construction ### var.cumhaz <- cumsumstrata(1/val$S0^2,strata,nstrata)+varbetat ### se.cumhaz <- cbind(jumptimes,(var.cumhaz)^.5) colnames(cumhaz) <- c("time","cumhaz") ### colnames(se.cumhaz) <- c("time","se.cumhaz") res[[i]] <- list(coef=cc,cumhaz=cumhaz[,2]) } names(res) <- 1:B return(res) } ###}}} phreg0 ##' @export pred.cif.boot <- function(b1,b2,c1,c2,gplot=1) {# {{{ B <- length(b1) times1 <- c1$cumhaz[,1] times2 <- c2$cumhaz[,1] coef1 <- do.call("rbind",lapply(b1,function(x) x$coef)) coef2 <- do.call("rbind",lapply(b2,function(x) x$coef)) ### ###cums1 <- do.call("cbind",lapply(b1,function(x) Cpred(rbind(c(0,0),x$cumhaz),xx)[,2])) ###cums2 <- do.call("cbind",lapply(b2,function(x) Cpred(rbind(c(0,0),x$cumhaz),xx)[,2])) bcums1 <- do.call("cbind",lapply(b1,function(x) x$cumhaz)) bcums2 <- do.call("cbind",lapply(b2,function(x) x$cumhaz)) where2 <- sindex.prodlim(c(0,times2),times1,strict=TRUE) cums2 <- c(0,c2$cumhaz[,2]) cums2 <- cums2[where2] cums1 <- c1$cumhaz[,2] bcums2 <- rbind(0,bcums2)[where2,] n <- length(times1) cif1 <- cumsum( exp(-c(0,cums1[-n])-cums2)*diff(c(0,cums1))) ccoef1 <- c1$coef ccoef2 <- c2$coef ### bcifs <- apply(exp(-rbind(0,bcums1[-n,])-bcums2)*apply(rbind(0,bcums1),2,diff),2,cumsum) if (gplot==1) { matplot(times1,bcifs,type="s",lwd=0.2) lines(times1,cif1,type="s",lwd=2) } cumx <- cif1 ccums <- bcifs-cif1 sdcumb <- apply(ccums,1,sd) zcums <- ccums/sdcumb ### log-scale lcum <- log(cif1) lccums <- log(bcifs)-lcum sdlogcumb <- apply(lccums,1,sd) zlogcums <- lccums/sdlogcumb cumx.inv <- 1/cumx # in order to not divide by 0 cumx.inv[cumx.inv == 0] <- 1 # In fact: here we use the same quantiles independent of log or not log. # Therefore: A division by cumx is required in the definition of the log bands. pcumsdb.EE <- percen(c(apply(abs(zcums),2,max, na.rm=TRUE)),0.95) pcumsdb.EE.log <- percen(apply(abs(zcums),2,max, na.rm=TRUE),0.95) pcumsdb.EE.log.o <- percen(apply(abs(zlogcums),2,max, na.rm=TRUE),0.95) band.EE <- cbind( cumx - sdcumb * pcumsdb.EE , cumx + sdcumb * pcumsdb.EE) band.EE.log <- cbind( cumx*exp(- pcumsdb.EE.log * sdcumb * cumx.inv) ,cumx*exp( pcumsdb.EE.log * sdcumb * cumx.inv )) band.EE.log.o <- cbind(exp(lcum - sdlogcumb* pcumsdb.EE.log.o), exp(lcum + sdlogcumb* pcumsdb.EE.log.o)) return(list(time=times1,cif=cif1, sdcif=sdcumb,sdlogcif=sdlogcumb,bcifs=bcifs, band.EE=band.EE,band.EE.log=band.EE.log, band.EE.log.o=band.EE.log.o)) }# }}} mets/R/force.same.cens.R0000644000176200001440000000324713623061405014525 0ustar liggesusers ##' @export force.same.cens <- function(data,id="id", time="time",cause="cause",entrytime=NULL,cens.code=0) { ## {{{ ### no missing values ### handle time-variables separately data <- dsort(data,id) w <- which(names(data) %in% c(time,cause,entrytime,id) ) datao <- data[,-w] data <- data[,c(time,cause,entrytime,id)] if (is.null(entrytime)) entry <- rep(0,nrow(data)) else entry <- data[,entrytime] censo <- (data[,cause]==cens.code) Wide <- fast.reshape(data,id=id) time1 <- paste(time,1,sep="") time2 <- paste(time,2,sep="") stat1 <- paste(cause,1,sep="") stat2 <- paste(cause,2,sep="") ### enforce same censoring ## {{{ mintime <- pmin(Wide[,time1],Wide[,time2]) statmin <- ifelse(Wide[,time1]0) nn <- nn[-nulls,,drop=FALSE] res <- Reduce("rbind",x) if (is.null(colnames(res)) && !missing(nam)) { colnames(res) <- nam[seq(length(ncol(res)))] } suppressWarnings(res <- cbind(nn,res)) ## no warnings on row-names for (i in seq(ncol(res)-1)+1) { if (is.list(res[,i])) { if (!is.null(nn <- names(res[,i][[1]]))) colnames(res)[i] <- paste0(colnames(res)[i],"(",paste0(nn,collapse=","),")") } } a <- rownames(x[[1]]) res$"_var" <- a rownames(res) <- seq(nrow(res)) return(res) } ##' aggregating for for data frames ##' ##' aggregating for for data frames ##' @examples ##' data("sTRACE",package="timereg") ##' daggregate(iris, "^.e.al", x="Species", fun=cor, regex=TRUE) ##' daggregate(iris, Sepal.Length+Petal.Length ~Species, fun=summary) ##' daggregate(iris, log(Sepal.Length)+I(Petal.Length>1.5) ~ Species, ##' fun=summary) ##' daggregate(iris, "*Length*", x="Species", fun=head) ##' daggregate(iris, "^.e.al", x="Species", fun=tail, regex=TRUE) ##' daggregate(sTRACE, status~ diabetes, fun=table) ##' daggregate(sTRACE, status~ diabetes+sex, fun=table) ##' daggregate(sTRACE, status + diabetes+sex ~ vf+I(wmi>1.4), fun=table) ##' daggregate(iris, "^.e.al", x="Species",regex=TRUE) ##' dlist(iris,Petal.Length+Sepal.Length ~ Species |Petal.Length>1.3 & Sepal.Length>5, ##' n=list(1:3,-(3:1))) ##' daggregate(iris, I(Sepal.Length>7)~Species | I(Petal.Length>1.5)) ##' daggregate(iris, I(Sepal.Length>7)~Species | I(Petal.Length>1.5), ##' fun=table) ##' ##' dsum(iris, .~Species, matrix=TRUE, missing=TRUE) ##' ##' par(mfrow=c(1,2)) ##' data(iris) ##' drename(iris) <- ~. ##' daggregate(iris,'sepal*'~species|species!="virginica",fun=plot) ##' daggregate(iris,'sepal*'~I(as.numeric(species))|I(as.numeric(species))!=1,fun=summary) ##' ##' dnumeric(iris) <- ~species ##' daggregate(iris,'sepal*'~species.n|species.n!=1,fun=summary) ##' ##' @export ##' @param data data.frame ##' @param y name of variable, or formula, or names of variables on data frame. ##' @param x name of variable, or formula, or names of variables on data frame. ##' @param subset subset expression ##' @param ... additional arguments to lower level functions ##' @param fun function defining aggregation ##' @param regex interpret x,y as regular expressions ##' @param missing Missing used in groups (x) ##' @param remove.empty remove empty groups from output ##' @param matrix if TRUE a matrix is returned instead of an array ##' @param silent suppress messages ##' @param na.action How model.frame deals with 'NA's ##' @param convert if TRUE try to coerce result into matrix. Can also be a user-defined function ##' @aliases daggr daggregate <- function(data,y=NULL,x=NULL,subset,...,fun="summary",regex=mets.options()$regex, missing=FALSE, remove.empty=FALSE, matrix=FALSE, silent=FALSE, na.action=na.pass, convert=NULL) {# {{{ if (is.vector(data)) data <- data.frame(data) subs <- substitute(subset) if (!base::missing(subs)) { expr <- suppressWarnings(inherits(try(subset,silent=TRUE),"try-error")) if (expr) data <- data[which(eval(subs,envir=data)),,drop=FALSE] else data[subset,,drop=FALSE] } if (is.null(y)) y <- colnames(data) if (inherits(y,"formula")) { yx <- procformdata(y,sep="\\|",data=data,na.action=na.action,regex=regex,...) y <- yx$response x0 <- yx$predictor if (is.null(x) && length(y)>0) x <- x0 if (NCOL(x)==0) x <- NULL if (length(y)==0) { y <- x0 } } else { yy <- c() for (y0 in y) { if (!regex) y0 <- glob2rx(y0) n <- grep(y0,names(data),perl=mets.options()$regex.perl) yy <- union(yy,names(data)[n]) } y <- data[,yy,drop=FALSE] } if (is.character(x) && length(x)0) y <- y[,-xidx,drop=FALSE] } if (is.character(fun)) fun <- get(fun) if (!is.null(convert) && is.logical(convert)) { if (convert) convert <- as.matrix else convert <- NULL } if (!is.null(convert)) { fun_ <- fun fun <- function(x,...) fun_(convert(x,...)) } if (!is.null(x)) { if (missing) { x[is.na(x)] <- 'NA' } if (silent) { capture.output(res <- by(y,x,fun,...)) } else { res <- by(y,x,fun,...) } if (remove.empty) { # ... need to abandon 'by'? } if (matrix) { res <- by2mat(res,colnames(y)) } return(structure(res,ngroupvar=NCOL(x),class=c("daggregate",class(res)))) } if (silent) capture.output(res <- do.call(fun, c(list(y),list(...)))) else res <- do.call(fun, c(list(y),list(...))) res structure(res, ngroupvar=0, class=c("daggregate",class(res))) }# }}} ##' @export daggr <- function(data,...,convert=as.matrix) daggregate(data,...,convert=convert) ##' @export print.daggregate <- function(x,quote=FALSE,...) { attr(x,c("ngroupvar")) <- NULL class(x) <- class(x)[-1] print(x,quote=quote,...) } ##' @export dhead <- function(data,y=NULL,x=NULL,...) daggregate(data,y,x,fun=function(z) utils::head(z,...)) ##' @export dtail <- function(data,y=NULL,x=NULL,...) daggregate(data,y,x,fun=function(z) utils::tail(z,...)) ##' @export dsummary <- function(data=NULL,y=NULL,x=NULL,...) daggregate(data,y,x,fun=function(z) base::summary(z,...)) ##' @export dstr <- function(data,y=NULL,x=NULL,...) invisible(daggregate(data,y,x,fun=function(z) utils::str(z,...))) ##' @export dunique <- function(data,y=NULL,x=NULL,...) invisible(daggregate(data,y,x,fun=function(z) base::unique(z,...))) ##' summary, tables, and correlations for data frames ##' ##' summary, tables, and correlations for data frames ##' @param data if x is formula or names for data frame then data frame is needed. ##' @param y name of variable, or fomula, or names of variables on data frame. ##' @param x possible group variable ##' @param use how to handle missing values ##' @param ... Optional additional arguments ##' @author Klaus K. Holst and Thomas Scheike ##' @examples ##' data("sTRACE",package="timereg") ##' dt<- sTRACE ##' dt$time2 <- dt$time^2 ##' dt$wmi2 <- dt$wmi^2 ##' head(dt) ##' ##' dcor(dt) ##' ##' dcor(dt,~time+wmi) ##' dcor(dt,~time+wmi,~vf+chf) ##' dcor(dt,time+wmi~vf+chf) ##' ##' dcor(dt,c("time*","wmi*"),~vf+chf) ##' @aliases dsummary dstr dcor dsubset dquantile dcount dmean dmeansd dscalar deval deval2 dsum dsd ##' @export dcor <- function(data,y=NULL,x=NULL,use="pairwise.complete.obs",...) daggregate(data,y,x,...,fun=function(z,...) stats::cor(z,use=use,...)) ##' @export dscalar <- function(data,y=NULL,x=NULL,...,na.rm=TRUE,matrix=TRUE,fun=base::mean) { daggregate(data,y,x,matrix=matrix,..., fun=function(z,...) { if (is.matrix(z)) { apply(z,2,function(x) suppressWarnings(tryCatch(fun(x,na.rm=na.rm,...),error=function(e) return(NA)))) } else { unlist(lapply(z,function(x) { suppressWarnings(tryCatch(fun(x,na.rm=na.rm,...),error=function(e) return(NA))) })) } }) } Summary <- function(object,na.rm=TRUE,...) { if (is.numeric(object)) { x <- c(summary(object,...),sd=sd(object,na.rm=TRUE)) } else { x <- summary(object,...) } ## Formatting xx <- x if (is.numeric(x) || is.complex(x)) { finite <- is.finite(x) xx[finite] <- zapsmall(x[finite]) } m <- match("NA's", names(xx), 0) if (inherits(x, "Date") || inherits(x, "POSIXct")) { xx <- if (length(a <- attr(x, "NAs"))) c(format(xx), `NA's` = as.character(a)) else format(xx) } else if (m && !is.character(x)) xx <- c(format(xx[-m]), `NA's` = as.character(xx[m])) xx } ##' @export deval2 <- function(data,...,matrix=simplify,simplify=TRUE) deval(data,matrix=TRUE,simplify=TRUE,...) ##' @export deval <- function(data,y=NULL,x=NULL,...,matrix=FALSE,fun=Summary,simplify=FALSE) { if (is.list(fun)) { newf <- function(x,...) { unlist(lapply(fun,function(f) f(x,...), ...)) } } else newf <- fun res <- daggregate(data,y,x,matrix=matrix,..., fun=function(z) lapply(z,function(x) { suppressWarnings(tryCatch(newf(x,...),error=function(e) return(NA))) })) if (simplify) { for (i in seq_len(ncol(res))) { if (is.list(res[,i])) res[,i] <- unlist(res[,i]) } ## Dim <- function(x) { ## val <- dim(x) ## if (is.null(val)) val <- c(1,length(x)) ## val ## } ## dm <- Dim(res[[1]]) ## dims <- unlist(lapply(res,function(x) identical(Dim(x),dm))) ## if (all(dims)) { ## Res <- res ## n <- length(res) ## res <- array(NA,dim=c(n,dm)) ## for (i in seq(n)) { ## browser() ## } ## } ## } } res } ##' @export dmeansd <- function(data,...) { mm <- dscalar(data,fun=base::mean,...) vv <- dscalar(data,fun=stats::sd,...) colnames(vv) <- paste("sd.",colnames(vv),sep="") cbind(mm,vv) } ##' @export dmean <- function(data,...) dscalar(data,fun=base::mean,...) ##' @export dsum <- function(data,...) dscalar(data,fun=base::sum,...) ##' @export dsd <- function(data,...) dscalar(data,fun=stats::sd,...) ##' @export dcount <- function(data,x=NULL,...,na.rm=TRUE) { res <- rbind(daggregate(data,x=x,matrix=TRUE,...,fun=function(z,...) NROW(z))) res[is.na(res)] <- 0 rownames(res) <- seq(nrow(res)) colnames(res)[ncol(res)] <- "count" res } ##' @export dsubset <- function(data,...) { daggregate(data,...,fun=function(z) z) } ##' @export dquantile <- function(data,y=NULL,x=NULL,probs=seq(0,1,by=1/breaks),breaks=4,matrix=TRUE,reshape=FALSE,...,na.rm=TRUE) { a <- daggregate(data,y,x,matrix=FALSE,...,fun=function(z,...) apply(z,2,function(x,...) quantile(x,probs=probs,na.rm=na.rm,...))) if (matrix) { res <- by2mat(a) xidx <- seq_len(attr(a, "ngroupvar")) if (!reshape || is.null(res[,"_var"]) || length(xidx)==0) return(res) res <- dreshape(res, id=colnames(res)[xidx], num="_var",sep="_") return(res) } return(a) } mets/R/dtransform.R0000644000176200001440000000541213623061405013727 0ustar liggesusers##' Transform that allows condition ##' ##' Defines new variables under condition for data frame ##' @param data is data frame ##' @param ... new variable definitions including possible if condition ##' @examples ##' data(mena) ##' ##' xx <- dtransform(mena,ll=log(agemena)+twinnum) ##' ##' xx <- dtransform(mena,ll=log(agemena)+twinnum,agemena<15) ##' xx <- dtransform(xx ,ll=100+agemena,ll2=1000,agemena>15) ##' dsummary(xx,ll+ll2~I(agemena>15)) ##' @aliases dtransform dtransform<- dtrans dtrans<- ##' @export dtransform <- function(data,...) {# {{{ if (is.vector(data)) data <- data.frame(data) ### if (is.list(...)) e <- eval(substitute(...), data, parent.frame()) else ### if (!missing(EXPRLIST)) { ### e <- eval(substitute(c(list(...),EXPRLIST)), data, parent.frame()) ### } else e <- eval(substitute(list(...)), data, parent.frame()) tags <- names(e) condn <- match("",tags) if (!is.na(condn)) { condition <- TRUE cond <- e[[condn[1]]]; whereT <- which(cond) e[[condn]] <- NULL tags <- tags[-condn] } else condition <- FALSE inx <- match(tags, names(data)) matched <- !is.na(inx) matchedtags <- seq(length(e))[matched] if (any(matched)) { ### new values replaces old values k <- 1 if (condition==TRUE) { for (i in inx[matched]) { mk <- matchedtags[k] if (length(e[[mk]])==1) data[whereT,i] <- e[[mk]] else data[whereT,i] <- e[[mk]][whereT] k <- k+1 } } else data[inx[matched]] <- e[matched] data <- data.frame(data) } ### no matched, all new variables if (!all(matched)) { if (condition) for (i in seq(length(e))[!matched]) { if (length(e[[i]])==1) e[[i]] <- rep(e[[i]],nrow(data)) e[[i]][!cond] <- NA } data <- cbind(data,data.frame(e[!matched])) } return(data) }# }}} ##' @export dtrans <- function(data,...) dtransform(data,...) ##' @export `dtrans<-` <- function(data,...,value) { dtransform(data,...) <- value return(data) } ##' @export `dtransform<-` <- function(data,...,value) { cl <- match.call() cl[[1L]] <- substitute(dtransform) a <- substitute(value) if (inherits(value,"function")) { cl["value"] <- NULL names(cl)[names(cl)=="INPUT"] <- "" cl[["INPUT"]] <- value } else { if (is.list(value)) { cl[which(names(cl)=="value")] <- NULL start <- length(cl) for (i in seq_along(value)) { cl[start+i] <- value[i] } if (length(names(value))>0) names(cl)[start+seq_along(value)] <- names(value) } else { names(cl)[which(names(cl)=="value")] <- "" } } eval.parent(cl) } mets/R/mutinomialreg.R0000644000176200001440000001127013623061405014423 0ustar liggesusers##' Multinomial regression based on phreg regression ##' ##' Fits multinomial regression model ##' \deqn{ P_i = \frac{ \exp( X^\beta_i ) }{ \sum_{j=1}^K \exp( X^\beta_j ) }} ##' for \deqn{i=1,..,K} ##' where \deqn{\beta_1 = 0}, such that \deqn{\sum_j P_j = 1} using phreg function. ##' Thefore the ratio \deqn{\frac{P_i}{P_1} = \exp( X^\beta_i )} ##' ##' Coefficients give log-Relative-Risk relative to baseline group (first level of factor, so that it can reset by relevel command). ##' Standard errors computed based on sandwhich form \deqn{ DU^-1 \sum U_i^2 DU^-1}. ##' ##' Can also get influence functions (possibly robust) via iid() function, response should be a factor. ##' ##' @param formula formula with outcome (see \code{coxph}) ##' @param data data frame ##' @param weights for score equations ##' @param offset offsets for partial likelihood ##' @param ... Additional arguments to lower level funtions ##' @author Thomas Scheike ##' @examples ##' ##' data(bmt) ##' dfactor(bmt) <- cause1f~cause ##' drelevel(bmt,ref=3) <- cause3f~cause ##' dlevels(bmt) ##' ##' mreg <- mlogit(cause1f~tcell+platelet,bmt) ##' summary(mreg) ##' ##' mreg3 <- mlogit(cause3f~tcell+platelet,bmt) ##' summary(mreg3) ##' ##' ## inverse information standard errors ##' estimate(coef=mreg3$coef,vcov=mreg3$II) ##' ##' @export mlogit <- function(formula,data,offset=NULL,weights=NULL,...) {# {{{ cl <- match.call() m <- match.call(expand.dots = TRUE)[1:3] special <- c("strata", "cluster","offset") Terms <- terms(formula, special, data = data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) Y <- model.extract(m, "response") id <- strata <- NULL if (!is.null(attributes(Terms)$specials$cluster)) { ts <- survival::untangle.specials(Terms, "cluster") pos.cluster <- ts$terms Terms <- Terms[-ts$terms] id <- m[[ts$vars]] } else pos.cluster <- NULL if (!is.null(attributes(Terms)$specials$strata)) { ts <- survival::untangle.specials(Terms, "strata") pos.strata <- ts$terms Terms <- Terms[-ts$terms] strata <- m[[ts$vars]] strata.name <- ts$vars } else { strata.name <- NULL; pos.strata <- NULL} X <- model.matrix(Terms, m) ### if (!is.null(intpos <- attributes(Terms)$intercept)) ### X <- X[,-intpos,drop=FALSE] if (ncol(X)==0) X <- matrix(nrow=0,ncol=0) ### print(list(...)) res <- mlogit01(X,Y,id=id,strata=strata,offset=offset,weights=weights,strata.name=strata.name,...) ###, ### list(call=cl,model.frame=m,formula=formula,strata.pos=pos.strata,cluster.pos=pos.cluster)) return(res) }# }}} mlogit01 <- function(X,Y,id=NULL,strata=NULL,offset=NULL,weights=NULL, strata.name=NULL,cumhaz=FALSE, beta,stderr=TRUE,method="NR",no.opt=FALSE,Z=NULL,propodds=NULL,AddGam=NULL, case.weights=NULL,...) {# {{{ ### print(list(...)) p <- ncol(X) if (missing(beta)) beta <- rep(0,p) if (p==0) X <- cbind(rep(0,length(Y))) ### if (is.null(strata)) { strata <- rep(0,length(Y)); nstrata <- 1; strata.level <- NULL; } else { ### strata.level <- levels(strata) ### ustrata <- sort(unique(strata)) ### nstrata <- length(ustrata) ### strata.values <- ustrata ### if (is.numeric(strata)) strata <- fast.approx(ustrata,strata)-1 else { ### strata <- as.integer(factor(strata,labels=seq(nstrata)))-1 ### } ### } if (is.null(offset)) offset <- rep(0,length(Y)) if (is.null(weights)) weights <- rep(1,length(Y)) strata.call <- strata Zcall <- matrix(1,1,1) ## to not use for ZX products when Z is not given if (!is.null(Z)) Zcall <- Z ## possible casewights to use for bootstrapping and other things if (is.null(case.weights)) case.weights <- rep(1,length(Y)) if (!is.null(id)) { ids <- unique(id) nid <- length(ids) if (is.numeric(id)) id <- fast.approx(ids,id)-1 else { id <- as.integer(factor(id,labels=seq(nid)))-1 } } else id <- as.integer(seq_along(Y))-1; ## orginal id coding into integers id.orig <- id+1; types <- unique(as.numeric(Y)) nlev <- length(types) nX <- nrow(X) idrow <- rep(1:nX,each=nlev) X <- X[idrow,,drop=FALSE] Y <- Y[idrow] id <- id[idrow] status <- rep(0,nrow(X)) nY <- as.numeric(Y) refg <- 1 ### else refg <- match(ref,types) nrefs <- (1:nlev)[-refg] for (i in 1:nlev) status[nY==i] <- rep(((1:nlev)==i),sum(nY==i)/nlev) time <- id strat <- rep(1:nlev,nX) XX <- c() for (i in nrefs) XX <- cbind(XX,X*(strat==i)) rownames(XX) <- NULL datph=data.frame(time=time,status=status,XX=XX,id=id,idrow=idrow) loffset <- offset[idrow] lweights<- weights[idrow] ### print(list(...)) res <- phreg(Surv(time,status)~XX+strata(idrow)+cluster(id),datph,weights=lweights,offset=loffset,...) return(res) }# }}} mets/R/clusterindex-reshape.R0000644000176200001440000002422213623061405015706 0ustar liggesusers##' Finds subjects related to same cluster ##' ##' @references ##' Cluster indeces ##' @examples ##' i<-c(1,1,2,2,1,3) ##' d<- cluster.index(i) ##' print(d) ##' ##' type<-c("m","f","m","c","c","c") ##' d<- cluster.index(i,num=type,Rindex=1) ##' print(d) ##' @seealso familycluster.index familyclusterWithProbands.index ##' @author Klaus Holst, Thomas Scheike ##' @param clusters list of indeces ##' @param index.type if TRUE then already list of integers of index.type ##' @param num to get numbering according to num-type in separate columns ##' @param Rindex index starts with 1, in C is it is 0 ##' @param mat to return matrix of indeces ##' @param return.all return all arguments ##' @param code.na how to code missing values ##' @aliases countID pairRisk mystrata ##' @export cluster.index <- function(clusters,index.type=FALSE,num=NULL,Rindex=0,mat=NULL,return.all=FALSE,code.na=NA) { ## {{{ n <- length(clusters) if (index.type==FALSE) { if (is.numeric(clusters)) clusters <- fast.approx(unique(clusters),clusters)-1 else { max.clust <- length(unique(clusters)) clusters <- as.integer(factor(clusters, labels = seq(max.clust)))-1 } } if ((!is.null(num))) { ### different types in different columns mednum <- 1 if (is.numeric(num)) numnum <- fast.approx(unique(num),num)-1 else { numnum <- as.integer(factor(num, labels = seq(length(unique(clusters))))) -1 } } else { numnum <- 0; mednum <- 0; } clustud <- .Call("clusterindexM",as.integer(clusters),as.integer(mednum), as.integer(numnum),mat,return.all,PACKAGE="mets") if (!is.null(mat) && !return.all) return(clustud) if (Rindex==1) clustud$idclust <- clustud$idclustmat+1 if (Rindex==1) clustud$firstclustid <- clustud$firstclustid +1 ### avoid NA's for C call if (Rindex==0 & !is.na(code.na)) clustud$idclust[is.na(clustud$idclust)] <- code.na clustud } ## }}} ##' @export countID <- function(data,id="id",names.count="Count",total.count="Total",index.name="index",reverse=TRUE,sep="",addid=TRUE) {# {{{ clusters <- data[,id] if (is.numeric(clusters)) { ## integeres from 0 to max.clust uc <- unique(clusters) max.clust <- length(uc) clusters <- fast.approx(uc, clusters) - 1 } else { max.clust <- length(unique(clusters)) clusters <- as.integer(factor(clusters, labels = seq(max.clust))) - 1 } ###tabid <- table(clusters) nclust <- table(clusters) if (addid) { name1 <- paste(names.count,id,sep=sep) name2 <- paste("index",id,sep=sep) name3 <- paste(total.count,id,sep=sep) } else { name1 <- names.count name2 <- index.name name3 <- total.count } out <- data[,id,drop=FALSE] out[,name1]=cumsumstrata(rep(1,nrow(data)),clusters,max.clust) out[,name2]=clusters out[,name3]=nclust[clusters+1] attr(out,"max.clust") <- max.clust return(out) }# }}} ##' @export pairRisk <- function(start,stop,status,expo,clust) {# {{{ n <- length(start) id <- 1:n nclust <- length(unique(clust)) sig <- c(rep(-1, each = n), rep(1, each = n)) clust.seq <- c(as.numeric(as.factor(clust)), as.numeric(as.factor(clust))) clust <- c(clust, clust) expo <- c(expo, expo) id <- c(id, id) sstatus <- c(rep(0, length(start)), status) tts <- c(start, stop) ot <- order(clust.seq, tts, -rank(sstatus)) tts <- tts[ot] sstatus <- sstatus[ot] sig <- sig[ot] expo <- expo[ot] clust <- clust[ot] clust.seq <- clust.seq[ot] id <- id[ot] cbind(id,sig,start,stop,expo,sstatus) cc <- c(mets::revcumsumstrata(sig * expo * 10 + sig * (expo == 0), clust.seq - 1, nclust)) ### both under risk when cc>10 pair.risk <- which(cc > 10) clustpl <- clust[pair.risk] weightpl <- cc[pair.risk] - 10 caseweightpl <- rep(-1, length(weightpl)) casepl <- expo[pair.risk] caseweightpl[casepl == 1] <- weightpl[casepl == 1] ttexit <- tts[pair.risk] ttentry <- tts[pair.risk - 1] ttid <- id[pair.risk] tstatus <- sstatus[pair.risk] timesout <- cbind(rep(ttentry, times = weightpl), rep(ttexit, times = weightpl)) whichnotsame <- which(timesout[, 1] != timesout[, 2]) caseweightrep <- rep(caseweightpl, times = weightpl) * (!duplicated(cbind(rep(ttexit, times = weightpl), rep(clustpl, time = weightpl)))) * 1 weightstatusrep <- rep(tstatus, times = weightpl) * (caseweightrep != 0) idout <- rep(ttid, times = weightpl) * (caseweightrep != 0) clustplrep <- rep(clustpl, times = weightpl) out <- data.frame(timesout, weightstatusrep, caseweightrep, clustplrep, idout, stringsAsFactors = FALSE)[whichnotsame, ] out <- out[order(out[, 5]), ] return(out) }# }}} ##' @export mystrata <- function(ll,sort=TRUE) {# {{{ for (j in seq(1,length(ll))) if (!is.factor(ll[[j]])) ll[[j]] <- factor(ll[[j]]) nll <- length(ll[[1]]) ss <- rep(0,nll) nl <- unlist(lapply(ll,nlevels)) poss <- exp(revcumsum(log(nl))) for (j in seq(1,length(ll))) { ss <- ss+as.numeric(ll[[j]])*poss[j] } uss <- unique(ss) nindex <- length(uss) sindex <- fast.approx(uss,ss) attr(sindex,"nlevel") <- nindex attr(sindex,"levels") <- nl return(sindex) } # }}} ###mystrata <- function(ll,sort=TRUE) {# {{{ ### if (!is.factor(ll[[1]])) ll[[1]] <- factor(ll[[1]]) ### id <- as.numeric(ll[[1]]) ### ss <- id ### for (j in seq(2,length(ll))) { ### if (!is.factor(ll[[j]])) ll[[j]] <- factor(ll[[j]]) ### mm <- 1/nlevels(ll[[j]]) ### ## two decimals for each level ### dec <- as.numeric(ll[[j]])/(nlevels(ll[[j]]))-mm/2 ### ss <- ss+dec/100^{j-2} ### } ### uss <- unique(ss) ### nindex <- length(uss) ### sindex <- fast.approx(uss,ss) ### dd <- data.frame(id=id,sindex=sindex) ### attr(dd,"nlevel") <- nindex ### return(dd) ###} # }}} ### ##' Finds all pairs within a cluster (family) ##' ##' @references ##' Cluster indeces ##' @examples ##' i<-c(1,1,2,2,1,3) ##' d<- familycluster.index(i) ##' print(d) ##' @seealso cluster.index familyclusterWithProbands.index ##' @author Klaus Holst, Thomas Scheike ##' @param clusters list of indeces ##' @param index.type argument of cluster index ##' @param num num ##' @param Rindex index starts with 1 in R, and 0 in C ##' @export familycluster.index <- function(clusters,index.type=FALSE,num=NULL,Rindex=1) { ## {{{ clusters <- cluster.index(clusters,Rindex=Rindex) totpairs <- sum(clusters$cluster.size*(clusters$cluster.size-1)/2) clustud <- .Call("familypairindex",clusters$idclust,clusters$cluster.size,as.integer(2*totpairs),PACKAGE="mets") clustud$pairs <- matrix(clustud$familypairindex,ncol=2,byrow=TRUE) clustud$clusters <- clusters$clusters[clustud$pairs[,2]]+1 invisible(clustud) } ## }}} ##' Finds all pairs within a cluster (famly) with the proband (case/control) ##' ##' second column of pairs are the probands and the first column the related subjects ##' ##' @references ##' Cluster indeces ##' @examples ##' i<-c(1,1,2,2,1,3) ##' p<-c(1,0,0,1,0,1) ##' d<- familyclusterWithProbands.index(i,p) ##' print(d) ##' @author Klaus Holst, Thomas Scheike ##' @seealso familycluster.index cluster.index ##' @param clusters list of indeces giving the clusters (families) ##' @param probands list of 0,1 where 1 specifices which of the subjects that are probands ##' @param index.type argument passed to other functions ##' @param num argument passed to other functions ##' @param Rindex index starts with 1, in C is it is 0 ##' @export familyclusterWithProbands.index <- function(clusters,probands,index.type=FALSE,num=NULL,Rindex=1) { ## {{{ famc <-familycluster.index(clusters,index.type=index.type,num=num,Rindex=Rindex) if (length(probands)!=length(clusters)) stop("clusters and probands not same length\n"); index.probs <- (1:length(clusters))[probands==1] subfamsWprobands <-famc$subfamilyindex[ famc$familypairindex %in% index.probs ] indexWproband <- famc$subfamilyindex %in% subfamsWprobands famc$subfamilyindex <- famc$subfamilyindex[indexWproband] famc$familypairindex <- famc$familypairindex[indexWproband] pairs <- matrix(famc$familypairindex,ncol=2,byrow=TRUE) ipi1 <- pairs[,1] %in% index.probs gem2 <- pairs[,2] pairs[ipi1,2] <- pairs[ipi1,1] pairs[ipi1,1] <- gem2[ipi1] famc$pairs <- pairs famc$clusters <- famc$clusters[ipi1] famc$familypairindex <- c(t(pairs)) invisible(famc) } ## }}} ##' @export coarse.clust <- function(clusters,max.clust=100) { ## {{{ if (is.numeric(clusters)) clusters <- sindex.prodlim(unique(clusters),clusters) cluster.size <- length(unique(clusters)) qq <- unique(quantile(clusters, probs = seq(0, 1, by = 1/max.clust))) qqc <- cut(clusters, breaks = qq, include.lowest = TRUE) cclusters <- as.integer(qqc)-1 return(cclusters) } ## }}} ##' @export faster.reshape <- function(data,clusters,index.type=FALSE,num=NULL,Rindex=1) { ## {{{ if (NCOL(data)==1) data <- cbind(data) ### uses data.matrix if (!is.matrix(data)) data <- data.matrix(data) if (is.character(clusters)) clusters <- data[,clusters] n <- length(clusters) if (nrow(data)!=n) stop("nrow(data) and clusters of different lengths\n"); if (index.type==FALSE) { max.clust <- length(unique(clusters)) if (is.numeric(clusters)) clusters <- fast.approx(unique(clusters),clusters)-1 else { max.clust <- length(unique(clusters)) clusters <- as.integer(factor(clusters, labels = 1:max.clust))-1 } } if ((!is.null(num))) { ### different types in different columns if (length(num)!=n) stop("clusters and num of different lengths\n"); mednum <- 1 if (is.numeric(num)) num <- fast.approx(unique(num),num)-1 else num <- as.integer(factor(num, labels = seq(length(unique(clusters))))) -1 } else { num <- 0; mednum <- 0; } clustud <- .Call("clusterindexdata",as.integer(clusters),as.integer(mednum), as.integer(num),iddata=data,PACKAGE="mets") if (Rindex==1) clustud$idclust <- clustud$idclust+1 ### if(Rindex==1) idclust[idclust==0] <- NA maxclust <- clustud$maxclust xny <- clustud$iddata xnames <- colnames(data); missingname <- (colnames(data)=="") xnames[missingname] <- paste(seq_len(maxclust))[missingname] xny <- data.frame(xny) mm <- as.vector(outer(xnames,seq_len(maxclust),function(...) paste(...,sep="."))) names(xny) <- mm return(xny); } ## }}} mets/R/logLik.biprobit.R0000644000176200001440000000050113623061405014574 0ustar liggesusers##' @export logLik.biprobit <- function(object,indiv=FALSE,...) { if (indiv) return(object$logLik) n <- sum(object$N[1]) p <- length(coef(object)) loglik <- sum(object$logLik) attr(loglik, "nall") <- n attr(loglik, "nobs") <- n attr(loglik, "df") <- p class(loglik) <- "logLik" return(loglik) } mets/R/binomial.twostage.R0000644000176200001440000016470313623061405015207 0ustar liggesusers##' Fits Clayton-Oakes or bivariate Plackett (OR) models for binary data ##' using marginals that are on logistic form. ##' If clusters contain more than two times, the algoritm uses a compososite likelihood ##' based on all pairwise bivariate models. ##' ##' The pairwise pairwise odds ratio model provides an alternative to the alternating logistic ##' regression (ALR). ##' ##' The reported standard errors are based on a cluster corrected score equations from the ##' pairwise likelihoods assuming that the marginals are known. This gives correct standard errors ##' in the case of the Odds-Ratio model (Plackett distribution) for dependence, but incorrect standard ##' errors for the Clayton-Oakes types model (that is also called "gamma"-frailty). For the additive gamma version of the ##' standard errors ##' are adjusted for the uncertainty in the marginal models via an iid deomposition using the iid() function of ##' lava. For the clayton oakes model that is not speicifed via the random effects these can be ##' fixed subsequently using the iid influence functions for the marginal model, but typically this does not ##' change much. ##' ##' For the Clayton-Oakes version of the model, given the gamma distributed random effects it is ##' assumed that the probabilities are indpendent, and that the marginal survival functions are on logistic form ##' \deqn{ ##' logit(P(Y=1|X)) = \alpha + x^T \beta ##' } ##' therefore conditional on the random effect the probability of the event is ##' \deqn{ ##' logit(P(Y=1|X,Z)) = exp( -Z \cdot Laplace^{-1}(lamtot,lamtot,P(Y=1|x)) ) ##' } ##' ##' Can also fit a structured additive gamma random effects model, such ##' the ACE, ADE model for survival data: ##' ##' Now random.design specificies the random effects for each subject within a cluster. This is ##' a matrix of 1's and 0's with dimension n x d. With d random effects. ##' For a cluster with two subjects, we let the random.design rows be ##' \eqn{v_1} and \eqn{v_2}. ##' Such that the random effects for subject ##' 1 is \deqn{v_1^T (Z_1,...,Z_d)}, for d random effects. Each random effect ##' has an associated parameter \eqn{(\lambda_1,...,\lambda_d)}. By construction ##' subjects 1's random effect are Gamma distributed with ##' mean \eqn{\lambda_j/v_1^T \lambda} ##' and variance \eqn{\lambda_j/(v_1^T \lambda)^2}. Note that the random effect ##' \eqn{v_1^T (Z_1,...,Z_d)} has mean 1 and variance \eqn{1/(v_1^T \lambda)}. ##' It is here asssumed that \eqn{lamtot=v_1^T \lambda} is fixed over all clusters ##' as it would be for the ACE model below. ##' ##' The DEFAULT parametrization uses the variances of the random effecs (var.par=1) ##' \deqn{ ##' \theta_j = \lambda_j/(v_1^T \lambda)^2 ##' } ##' ##' For alternative parametrizations (var.par=0) one can specify how the parameters relate ##' to \eqn{\lambda_j} with the function ##' ##' Based on these parameters the relative contribution (the heritability, h) is ##' equivalent to the expected values of the random effects \eqn{\lambda_j/v_1^T \lambda} ##' ##' Given the random effects the probabilities are independent and on the form ##' \deqn{ ##' logit(P(Y=1|X)) = exp( - Laplace^{-1}(lamtot,lamtot,P(Y=1|x)) ) ##' } ##' with the inverse laplace of the gamma distribution with mean 1 and variance lamtot. ##' ##' The parameters \eqn{(\lambda_1,...,\lambda_d)} ##' are related to the parameters of the model ##' by a regression construction \eqn{pard} (d x k), that links the \eqn{d} ##' \eqn{\lambda} parameters ##' with the (k) underlying \eqn{\theta} parameters ##' \deqn{ ##' \lambda = theta.des \theta ##' } ##' here using theta.des to specify these low-dimension association. Default is a diagonal matrix. ##' ##' @export ##' @aliases binomial.twostage binomial.twostage.time ##' @references ##' Two-stage binomial modelling ##' @examples ##' library("timereg") ##' data("twinstut",package="mets") ##' twinstut0 <- subset(twinstut, tvparnr<2300000) ##' twinstut <- twinstut0 ##' twinstut$binstut <- (twinstut$stutter=="yes")*1 ##' theta.des <- model.matrix( ~-1+factor(zyg),data=twinstut) ##' margbin <- glm(binstut~factor(sex)+age,data=twinstut,family=binomial()) ##' bin <- binomial.twostage(margbin,data=twinstut,var.link=1, ##' clusters=twinstut$tvparnr,theta.des=theta.des,detail=0, ##' score.method="fisher.scoring") ##' summary(bin) ##' ##' twinstut$cage <- scale(twinstut$age) ##' theta.des <- model.matrix( ~-1+factor(zyg)+cage,data=twinstut) ##' bina <- binomial.twostage(margbin,data=twinstut,var.link=1, ##' clusters=twinstut$tvparnr,theta.des=theta.des) ##' summary(bina) ##' ##' theta.des <- model.matrix( ~-1+factor(zyg)+factor(zyg)*cage,data=twinstut) ##' bina <- binomial.twostage(margbin,data=twinstut,var.link=1, ##' clusters=twinstut$tvparnr,theta.des=theta.des) ##' summary(bina) ##' ##' ## refers to zygosity of first subject in eash pair : zyg1 ##' ## could also use zyg2 (since zyg2=zyg1 within twinpair's)) ##' out <- easy.binomial.twostage(stutter~factor(sex)+age,data=twinstut, ##' response="binstut",id="tvparnr",var.link=1, ##' theta.formula=~-1+factor(zyg1)) ##' summary(out) ##' ##' ## refers to zygosity of first subject in eash pair : zyg1 ##' ## could also use zyg2 (since zyg2=zyg1 within twinpair's)) ##' desfs<-function(x,num1="zyg1",num2="zyg2") ##' c(x[num1]=="dz",x[num1]=="mz",x[num1]=="os")*1 ##' ##' out3 <- easy.binomial.twostage(binstut~factor(sex)+age, ##' data=twinstut,response="binstut",id="tvparnr",var.link=1, ##' theta.formula=desfs,desnames=c("mz","dz","os")) ##' summary(out3) ##' ##' ### use of clayton oakes binomial additive gamma model ##' ########################################################### ##' \donttest{ ## Reduce Ex.Timings ##' data <- simbinClaytonOakes.family.ace(10000,2,1,beta=NULL,alpha=NULL) ##' margbin <- glm(ybin~x,data=data,family=binomial()) ##' margbin ##' ##' head(data) ##' data$number <- c(1,2,3,4) ##' data$child <- 1*(data$number==3) ##' ##' ### make ace random effects design ##' out <- ace.family.design(data,member="type",id="cluster") ##' out$pardes ##' head(out$des.rv) ##' ##' bints <- binomial.twostage(margbin,data=data, ##' clusters=data$cluster,detail=0,var.par=1, ##' theta=c(2,1),var.link=0, ##' random.design=out$des.rv,theta.des=out$pardes) ##' summary(bints) ##' ##' data <- simbinClaytonOakes.twin.ace(10000,2,1,beta=NULL,alpha=NULL) ##' out <- twin.polygen.design(data,id="cluster",zygname="zygosity") ##' out$pardes ##' head(out$des.rv) ##' margbin <- glm(ybin~x,data=data,family=binomial()) ##' ##' bintwin <- binomial.twostage(margbin,data=data, ##' clusters=data$cluster,detail=1,var.par=1, ##' theta=c(2,1),random.design=out$des.rv,theta.des=out$pardes) ##' summary(bintwin) ##' concordanceTwinACE(bintwin) ##' } ##' ##' @keywords binomial regression ##' @author Thomas Scheike ##' @export ##' @param margbin Marginal binomial model ##' @param data data frame ##' @param score.method Scoring method default is "fisher.scoring" among "fisher.scoring","nlminb","optimize","nlm" ##' @param Nit Number of iterations ##' @param detail Detail ##' @param clusters Cluster variable ##' @param silent Debug information ##' @param weights Weights for log-likelihood, can be used for each type of outcome in 2x2 tables. ##' @param control Optimization arguments ##' @param theta Starting values for variance components ##' @param theta.des design for dependence parameters, when pairs are given this is could be a (pairs) x (numer of parameters) x (max number random effects) matrix ##' @param var.link Link function for variance ##' @param var.par parametrization ##' @param var.func when alternative parametrizations are used this function can specify how the paramters are related to the \eqn{\lambda_j}'s. ##' @param iid Calculate i.i.d. decomposition when iid>=1, when iid=2 then avoids adding the uncertainty for marginal paramters for additive gamma model (default). ##' @param step Step size ##' @param notaylor Taylor expansion ##' @param model model ##' @param marginal.p vector of marginal probabilities ##' @param beta.iid iid decomposition of marginal probability estimates for each subject, if based on GLM model this is computed. ##' @param Dbeta.iid derivatives of marginal model wrt marginal parameters, if based on GLM model this is computed. ##' @param strata strata for fitting: considers only pairs where both are from same strata ##' @param max.clust max clusters ##' @param se.clusters clusters for iid decomposition for roubst standard errors ##' @param numDeriv uses Fisher scoring aprox of second derivative if 0, otherwise numerical derivatives ##' @param random.design random effect design for additive gamma model, when pairs are given this is a (pairs) x (2) x (max number random effects) matrix, see pairs.rvs below ##' @param pairs matrix with rows of indeces (two-columns) for the pairs considered in the pairwise composite score, useful for case-control sampling when marginal is known. ##' @param pairs.rvs for additive gamma model and random.design and theta.des are given as arrays, this specifice number of random effects for each pair. ##' @param additive.gamma.sum this is specification of the lamtot in the models via a matrix that is multiplied onto the parameters theta (dimensions=(number random effects x number of theta parameters), when null then sums all parameters. Default is a matrix of 1's ##' @param pair.ascertained if pairs are sampled only when there are events in the pair i.e. Y1+Y2>=1. ##' @param case.control if data is case control data for pair call, and here 2nd column of pairs are probands (cases or controls) ##' @param twostage default twostage=1, to fit MLE use twostage=0 ##' @param beta is starting value for beta for MLE version binomial.twostage <- function(margbin,data=sys.parent(), score.method="fisher.scoring",Nit=60,detail=0,clusters=NULL,silent=1,weights=NULL, control=list(),theta=NULL,theta.des=NULL,var.link=0,var.par=1,var.func=NULL, iid=1,step=1.0,notaylor=1,model="plackett",marginal.p=NULL,beta.iid=NULL,Dbeta.iid=NULL, strata=NULL,max.clust=NULL,se.clusters=NULL,numDeriv=0, random.design=NULL,pairs=NULL,pairs.rvs=NULL,additive.gamma.sum=NULL, pair.ascertained=0,case.control=0, twostage=1,beta=NULL) { ## {{{ ## {{{ seting up design and variables rate.sim <- 1; sym=1; if (model=="clayton.oakes" || model=="gamma") dep.model <- 1 else if (model=="plackett" || model=="or") dep.model <- 2 else stop("Model must by either clayton.oakes or plackett \n"); antpers <- NROW(data); if (!is.null(pairs)) nn <- NROW(pairs) else nn <- 1 ### marginal prediction and binomial response, two types of calls ## {{{ if (class(margbin)[1]=="glm") { ps <- predict(margbin,newdata=data,type="response") if (margbin$family$family!="binomial") warning("not binomial family\n"); ### takes data to extract response and predictions, these could be different for pairs call ### cause <- margbin$y ### print(all.vars(margbin$formula)[1]) cause <- data[,all.vars(margbin$formula)[1]] if (!is.numeric(cause)) stop(paste("response in data",margbin$formula)[1],"not numeric\n"); if (is.null(beta.iid)) beta.iid <- iid(margbin,id=clusters) if (is.null(Dbeta.iid)) Dbeta.iid <- model.matrix(margbin$formula,data=data) * ps if (twostage==0) Xbeta <- model.matrix(margbin$formula,data=data) } else if (class(margbin)[1]=="formula") { margbin <- glm(margbin,data=data,family=binomial()) ps <- predict(margbin,type="response") cause <- margbin$y if (twostage==0) Xbeta <- model.matrix(margbin$formula,data=data) if (is.null(Dbeta.iid)) Dbeta.iid <- model.matrix(margbin$formula,data=data) * ps if (is.null(beta.iid)) beta.iid <- iid(margbin,id=clusters) } else if (is.null(marginal.p)) stop("without marginal model, marginal p's must be given\n"); if (!is.null(marginal.p)) { if (length(margbin)!=antpers) stop("with marginal margbin is response \n") else cause <- margbin if (length(marginal.p)!=antpers) stop("length same as data dimension \n") else ps <- marginal.p } ## }}} notaylor <- 1 if (is.null(weights)==TRUE) weights <- rep(1,antpers); if (is.null(strata)==TRUE) strata<- rep(1,antpers); if (length(strata)!=antpers) stop("Strata must have length equal to number of data points \n"); # {{{ cluster setup out.clust <- cluster.index(clusters); clusters <- out.clust$clusters maxclust <- out.clust$maxclust antclust <- out.clust$cluster.size clusterindex <- out.clust$idclust clustsize <- out.clust$cluster.size call.secluster <- se.clusters if (is.null(se.clusters)) { se.clusters <- clusters; antiid <- nrow(clusterindex);} else { iids <- unique(se.clusters); antiid <- length(iids); if (is.numeric(se.clusters)) se.clusters <- fast.approx(iids,se.clusters)-1 else se.clusters <- as.integer(factor(se.clusters, labels = seq(antiid)))-1 } if (length(se.clusters)!=length(clusters)) stop("Length of seclusters and clusters must be same\n"); if ((!is.null(max.clust))) if (max.clust< antiid) { coarse.clust <- TRUE qq <- unique(quantile(se.clusters, probs = seq(0, 1, by = 1/max.clust))) qqc <- cut(se.clusters, breaks = qq, include.lowest = TRUE) se.clusters <- as.integer(qqc)-1 max.clusters <- length(unique(se.clusters)) maxclust <- max.clust antiid <- max.clusters } # }}} if (is.null(beta)==TRUE & twostage==0) beta <- coef(margbin) else beta <- 0 ## }}} dimbeta <- length(beta); ### ### if (!is.null(random.design)) { ### different parameters for Additive random effects # {{{ ### dep.model <- 3 ###### if (is.null(random.design)) random.design <- matrix(1,antpers,1); ### dim.rv <- ncol(random.design); ### if (is.null(theta.des)) theta.des<-diag(dim.rv); ###### ptheta <- dimpar <- ncol(theta.des); ### ###### if (dim(theta.des)[2]!=ncol(random.design)) ###### stop("nrow(theta.des)!= ncol(random.design),\nspecifies restrictions on paramters, if theta.des not given =diag (free)\n"); ### } else { random.design <- matrix(0,1,1); dim.rv <- 1; } ### ### if (is.null(theta.des)==TRUE) ptheta<-1; ### if (is.null(theta.des)==TRUE) theta.des<-matrix(1,antpers,ptheta) ### else theta.des<-as.matrix(theta.des); ###### ptheta<-ncol(theta.des); ###### if (nrow(theta.des)!=antpers) stop("Theta design does not have correct dim"); ### ### if (!is.null(pairs)) { pair.structure <- 1; } else pair.structure <- 0; ### if (length(dim(theta.des))==3) ptheta<-dim(theta.des)[2] else if (length(dim(theta.des))==2) ptheta<-ncol(theta.des) ### if (nrow(theta.des)!=antpers & dep.model!=3 & pair.structure==0 ) stop("Theta design does not have correct dim"); ### if (nrow(theta.des)!=nn & dep.model!=3 & pair.structure==1 ) stop("Theta design does not have correct dim"); ### ### if (length(dim(theta.des))!=3) theta.des <- as.matrix(theta.des) ###### theta.des <- as.matrix(theta.des) ### ### dimbeta <- length(beta); ### if (is.null(theta)==TRUE) { ### if (var.link==1) theta<- rep(-0.7,ptheta); ### if (var.link==0) theta<- rep(exp(-0.7),ptheta); ### } ### if (length(theta)!=ptheta) theta<-rep(theta[1],ptheta); ### theta.score<-rep(0,ptheta);Stheta<-var.theta<-matrix(0,ptheta,ptheta); ### ### if (maxclust==1) stop("No clusters, maxclust size=1\n"); ### ### antpairs <- 1; ### to define ### if (is.null(additive.gamma.sum)) additive.gamma.sum <- matrix(1,dim.rv,ptheta) ### ### ### if (pair.structure==1 & dep.model==3) { ## {{{ ###### something with dimensions of rv.des ###### theta.des ### antpairs <- nrow(pairs); ### if ( (length(dim(theta.des))!=3) & (length(dim(random.design))==3) ) ### { ### Ptheta.des <- array(0,c(nrow(theta.des),ncol(theta.des),antpairs)) ### for (i in 1:antpairs) Ptheta.des[,,i] <- theta.des ### theta.des <- Ptheta.des ### } ### if ( (length(dim(theta.des))==3) & (length(dim(random.design))!=3) ) ### { ### rv.des <- array(0,c(2,ncol(random.design),antpairs)) ### for (i in 1:antpairs) { ### rv.des[1,,i] <- random.design[pairs[i,1],] ### rv.des[2,,i] <- random.design[pairs[i,2],] ### } ### random.design <- rv.des ### } ### if ( (length(dim(theta.des))!=3) & (length(dim(random.design))!=3) ) ### { ### Ptheta.des <- array(0,c(nrow(theta.des),ncol(theta.des),antpairs)) ### rv.des <- array(0,c(2,ncol(random.design),antpairs)) ### for (i in 1:antpairs) { ### rv.des[1,,i] <- random.design[pairs[i,1],] ### rv.des[2,,i] <- random.design[pairs[i,2],] ### Ptheta.des[,,i] <- theta.des ### } ### theta.des <- Ptheta.des ### random.design <- rv.des ### } ### ### if (max(pairs)>antpers) stop("Indices of pairs should refer to given data \n"); ### if (is.null(pairs.rvs)) pairs.rvs <- rep(dim(random.design)[2],antpairs) ###### if (max(pairs.rvs)> dim(random.design)[3] | max(pairs.rvs)>ncol(theta.des[1,,])) ###### stop("random variables for each cluster higher than possible, pair.rvs not consistent with random.design or theta.des\n"); ### clusterindex <- pairs-1; ### } ## }}} ### ### if (pair.structure==1 & dep.model!=3) { ### clusterindex <- pairs-1; ### antpairs <- nrow(pairs); ### pairs.rvs <- 1 ### } ### ### if (pair.structure==1) { ### if (length(case.control)!=antpairs) case.control <- rep(case.control[1],antpairs) ### if (length(pair.ascertained)!=antpairs) pair.ascertained <- rep(pair.ascertained[1],antpairs) ### if (any(case.control+pair.ascertained==2)) stop("Each pair is either case.control pair or pair.ascertained \n"); ### } ### ### if (is.null(Dbeta.iid)) Dbeta.iid <- matrix(0,length(cause),1); ### ptrunc <- rep(1,antpers); #### }}} ### ### setting design for random variables, in particular with pairs are given ddd <- randomDes(dep.model,random.design,theta.des,theta,antpers,additive.gamma.sum,pairs,pairs.rvs,var.link,clusterindex) random.design=ddd$random.design;clusterindex=ddd$clusterindex; antpairs=ddd$antpairs; pairs.rvs=ddd$pairs.rvs; theta=ddd$theta;ptheta=ddd$ptheta;theta.des=ddd$theta.des pair.structure=ddd$pair.structure; dep.model=ddd$dep.model dim.rv <- ddd$dim.rv; additive.gamma.sum=ddd$additive.gamma.sum ### print(dep.model); print(theta); print(head(theta.des)); if (dep.model==3) model <- "clayton.oakes" if (pair.structure==1) { if (length(case.control)!=antpairs) case.control <- rep(case.control[1],antpairs) if (length(pair.ascertained)!=antpairs) pair.ascertained <- rep(pair.ascertained[1],antpairs) if (any(case.control+pair.ascertained==2)) stop("Each pair is either case.control pair or pair.ascertained \n"); } if (is.null(Dbeta.iid)) Dbeta.iid <- matrix(0,length(cause),1); ptrunc <- rep(1,antpers); theta.score<-rep(0,ptheta);Stheta<-var.theta<-matrix(0,ptheta,ptheta); loglike <- function(par) { ## {{{ if (pair.structure==0 | dep.model!=3) Xtheta <- as.matrix(theta.des) %*% matrix(c(par[seq(1,ptheta)]),nrow=ptheta,ncol=1); if (pair.structure==1 & dep.model==3) Xtheta <- matrix(0,antpers,1); ## not needed if (pair.structure==1 & dep.model!=3) Xtheta <- as.matrix(theta.des) %*% matrix(c(par[seq(1,ptheta)]),nrow=ptheta,ncol=1); DXtheta <- array(0,c(1,1,1)); if (twostage==0) epar <- par[seq(1,ptheta)] else epar <- par if (twostage==0) { ### update, marginal.p og score for logistic model ### print(c(ptheta+1,ptheta+dimbeta)) beta <- par[seq(ptheta+1,ptheta+dimbeta)] lp <- c(Xbeta %*% beta) ### print(summary(ps)) psu <- exp(lp)/(1+exp(lp)) ### print(summary(psu)) dpsu <- psu/(1+exp(lp)) ### update predictions and DbetaP ### print(beta); print(dim(Xbeta)); print(length(dpsu)); Dbeta.iid <- Xbeta * dpsu ### print(Dbeta.iid) ### print(apply(Dbeta.iid,2,sum)) ps <- psu } if (var.link==1 & dep.model==3) epar <- c(exp(epar)) else epar <- c(epar) partheta <- epar if (var.par==1 & dep.model==3) { ## from variances to if (is.null(var.func)) { sp <- sum(epar) partheta <- epar/sp^2 } else partheta <- epar; ## par.func(epar) } if (pair.structure==0) outl<-.Call("twostageloglikebin", ## {{{ icause=cause,ipmargsurv=ps, itheta=c(partheta),iXtheta=Xtheta,iDXtheta=DXtheta,idimDX=dim(DXtheta),ithetades=theta.des, icluster=clusters,iclustsize=clustsize,iclusterindex=clusterindex, ivarlink=var.link,iiid=iid,iweights=weights,isilent=silent,idepmodel=dep.model, itrunkp=ptrunc,istrata=strata,iseclusters=se.clusters,iantiid=antiid, irvdes=random.design,iags=additive.gamma.sum,ibetaiid=Dbeta.iid,pa=pair.ascertained,twostage=twostage, PACKAGE="mets") ## }}} else outl<-.Call("twostageloglikebinpairs", ## {{{ icause=cause,ipmargsurv=ps, itheta=c(partheta),iXtheta=Xtheta,iDXtheta=DXtheta,idimDX=dim(DXtheta),ithetades=theta.des, icluster=clusters,iclustsize=clustsize,iclusterindex=clusterindex, ivarlink=var.link,iiid=iid,iweights=weights,isilent=silent,idepmodel=dep.model, itrunkp=ptrunc,istrata=strata,iseclusters=se.clusters,iantiid=antiid, irvdes=random.design, idimthetades=dim(theta.des),idimrvdes=dim(random.design),irvs=pairs.rvs, iags=additive.gamma.sum,ibetaiid=Dbeta.iid,pa=pair.ascertained,twostage=twostage, icasecontrol=case.control, PACKAGE="mets") ## }}} if (detail==3) print(c(par,outl$loglike)) ## variance parametrization, and inverse.link if (dep.model==3) {# {{{ if (var.par==1) { ## from variances to and with sum for all random effects if (is.null(var.func)) { if (var.link==0) { ### print(c(sp,epar)) mm <- matrix(-epar*2*sp,length(epar),length(epar)) diag(mm) <- sp^2-epar*2*sp } else { mm <- -c(epar) %o% c(epar)*2*sp diag(mm) <- epar*sp^2-epar^2*2*sp } mm <- mm/sp^4 } else mm <- numDeriv::hessian(var.func,par) } else { if (var.link==0) mm <- diag(length(epar)) else mm <- diag(length(c(epar)))*c(epar) } if (twostage==0) { ### beta for logistic regression also part of model mm0 <- diag(length(par)) mm0[1:nrow(mm),1:nrow(mm)] <- mm mm <- mm0 } }# }}} if (dep.model==3) {# {{{ outl$score <- t(mm) %*% outl$score if (twostage==1) outl$DbetaDtheta <- t(mm) %*% outl$DbetaDtheta outl$Dscore <- t(mm) %*% outl$Dscore %*% mm if (iid==1) outl$theta.iid <- t(t(mm) %*% t(outl$theta.iid)) ### print(crossprod(outl$theta.iid)); print(outl$Dscore) ### print(c(outl$score)) ### print(apply(outl$theta.iid,2,sum)) }# }}} attr(outl,"grad") <- attr(outl,"gradient") <-outl$score attr(outl,"hessian") <- outl$Dscore if (oout==0) ret <- c(-1*outl$loglike) else if (oout==1) ret <- sum(outl$score^2) else if (oout==3) ret <- outl$score else ret <- outl return(ret) } ## }}} if (score.method=="optimize" && ptheta!=1) {cat("optimize only works for d==1, score.mehod set to nlminb \n"); score.method <- "nlminb";} theta.iid <- NULL logl <- NULL p <- theta if (twostage==0) p <- c(p,beta); theta <- p if (score.method=="fisher.scoring") { ## {{{ oout <- 2; ### output control for obj if (Nit>0) for (i in 1:Nit) { out <- loglike(p) hess <- -1* out$Dscore if (!is.na(sum(hess))) hessi <- lava::Inverse(out$Dscore) else hessi <- hess if (detail==1) {## {{{ cat(paste("Fisher-Scoring ===================: it=",i,"\n")); cat("theta:");print(c(p)) cat("loglike:");cat(c(out$loglike),"\n"); cat("score:");cat(c(out$score),"\n"); cat("hess:\n"); cat(out$Dscore,"\n"); }## }}} delta <- hessi %*% out$score *step if (Nit>0) { p <- p + delta* step theta <- p; } if (is.nan(sum(out$score))) break; if (sum(abs(out$score))<0.00001) break; if (max(abs(theta))>20 & var.link==0) { cat("theta too large lacking convergence \n"); break; } } if (!is.nan(sum(p))) { if (detail==1 && iid==1) cat("iid decomposition\n"); out <- loglike(p) logl <- out$loglike score1 <- score <- out$score oout <- 0; hess1 <- hess <- -1*out$Dscore ### if (iid==1) theta.iid <- out$theta.iid if (detail==1 && iid==1) cat("finished iid decomposition\n"); } if (numDeriv==1) { if (detail==1 ) cat("starting numDeriv for second derivative \n"); oout <- 0; score2 <- numDeriv::jacobian(loglike,p) if (detail==1) { cat("Derivative\n"); cat(c(out$score)) cat("\n Numerical Derivative\n"); cat(c(score2)) cat("\n") } score1 <- matrix(score2,ncol=1) oout <- 3 hess <- numDeriv::jacobian(loglike,p) if (detail==1 ){ cat("finished numDeriv for second derivative \n"); cat("Numerical derivative second derivative \n"); print(hess) cat("average second moment, for fisher-scoring\n"); print(out$Dscore) } } if (detail==1 & Nit==0) {## {{{ cat(paste("Fisher-Scoring ===================: final","\n")); cat("theta:");print(c(p)) cat("loglike:");cat(c(out$loglike),"\n"); cat("score:");cat(c(out$score),"\n"); cat("hess:\n"); cat(out$Dscore,"\n"); }## }}} if (!is.na(sum(hess))) hessi <- lava::Inverse(hess) else hessi <- diag(nrow(hess)) ## }}} } else if (score.method=="nlminb") { ## {{{ nlminb optimizer oout <- 0; tryCatch(opt <- nlminb(theta,loglike,control=control),error=function(x) NA) if (detail==1) print(opt); if (detail==1 && iid==1) cat("iid decomposition\n"); oout <- 2 theta <- opt$par out <- loglike(opt$par) logl <- out$loglike score1 <- score <- out$score hess1 <- hess <- - out$Dscore if (iid==1) theta.iid <- out$theta.iid if (numDeriv==1) { oout <- 3; p <- theta hess <- -1 * numDeriv::jacobian(loglike,theta) } hessi <- lava::Inverse(hess); ## }}} } else if (score.method=="optimize" && ptheta==1) { ## {{{ optimizer oout <- 0; if (var.link==1) {mino <- -20; maxo <- 10;} else {mino <- 0.001; maxo <- 100;} tryCatch(opt <- optimize(loglike,c(mino,maxo))); if (detail==1) print(opt); opt$par <- opt$minimum theta <- opt$par if (detail==1 && iid==1) cat("iid decomposition\n"); oout <- 2 out <- loglike(opt$par) logl <- out$loglike score1 <- score <- out$score hess1 <- hess <- - out$Dscore if (iid==1) theta.iid <- out$theta.iid if (numDeriv==1) { oout <- 3; p <- opt$par hess <- -1* numDeriv::jacobian(loglike,p) } hessi <- lava::Inverse(hess); ## }}} } else if (score.method=="nlm") { ## {{{ nlm optimizer iid <- 0; oout <- 0; tryCatch(opt <- nlm(loglike,theta,hessian=TRUE,print.level=detail),error=function(x) NA) iid <- 1; hess <- opt$hessian score <- opt$gradient if (detail==1) print(opt); hessi <- lava::Inverse(hess); theta <- opt$estimate if (detail==1 && iid==1) cat("iid decomposition\n"); oout <- 2 out <- loglike(opt$estimate) logl <- out$loglike score1 <- out$score hess1 <- -1* out$Dscore if (iid==1) theta.iid <- out$theta.iid ## }}} } else stop("score.methods = optimize(dim=1) nlm nlminb fisher.scoring\n"); ## {{{ handling output iid.tot <- NULL var.tot <- robvar.theta <- NULL beta <- NULL if (iid>=1) { theta.iid <- out$theta.iid %*% hessi if (dep.model==3 & iid!=2 & (!is.null(beta.iid))) if (nrow(beta.iid)==nrow(out$theta.iid) & twostage==1) { theta.beta.iid <- (beta.iid %*% t(out$DbetaDtheta) ) %*% hessi theta.iid <- theta.iid+theta.beta.iid iid.tot <- cbind(theta.iid,beta.iid) var.tot <- crossprod(iid.tot) } var.theta <- robvar.theta <- (t(theta.iid) %*% theta.iid) if (is.null(var.tot)) var.tot <- var.theta } else var.theta <- -1* hessi if (class(margbin)[1]=="glm") beta <- coef(margbin); if (twostage==0) beta <- theta[seq(ptheta,ptheta+dimbeta)] if (iid==1) var.theta <- robvar.theta else var.theta <- -hessi if (!is.null(colnames(theta.des))) thetanames <- colnames(theta.des) else thetanames <- paste("dependence",1:length(theta),sep="") ### fix names !!! ### theta <- matrix(theta,length(c(theta)),1) if (length(thetanames)==nrow(theta)) { rownames(theta) <- thetanames; rownames(var.theta) <- colnames(var.theta) <- thetanames; } ud <- list(theta=theta,score=score,hess=hess,hessi=hessi,var.theta=var.theta,model=model,robvar.theta=robvar.theta, theta.iid=theta.iid,thetanames=thetanames, loglike=-logl,score1=score1,Dscore=out$Dscore, margsurv=ps,iid.tot=iid.tot,var.tot=var.tot,beta=beta); class(ud)<-"mets.twostage" attr(ud, "binomial") <- TRUE attr(ud, "ptheta") <- ptheta attr(ud, "Formula") <- formula attr(ud, "Clusters") <- clusters attr(ud,"sym")<-sym; attr(ud,"var.link")<-var.link; attr(ud,"var.par")<-var.par; attr(ud,"var.func")<-var.func; attr(ud,"antpers")<-antpers; attr(ud,"antclust")<-antclust; attr(ud, "Type") <- model attr(ud,"DbetaDtheta")<-out$DbetaDtheta; attr(ud,"ags")<- additive.gamma.sum attr(ud,"twostage")<- twostage attr(ud,"pair.ascertained")<- pair.ascertained ### to be consistent with structure for survival twostage model attr(ud, "additive-gamma") <- (dep.model==3)*1 if (dep.model==3 & pair.structure==1) attr(ud, "likepairs") <- c(out$likepairs) if (dep.model==3 & pair.structure==0) attr(ud, "pardes") <- theta.des if (dep.model==3 & pair.structure==0) attr(ud, "theta.des") <- theta.des if (dep.model==3 & pair.structure==1) attr(ud, "pardes") <- theta.des[,,1] if (dep.model==3 & pair.structure==1) attr(ud, "theta.des") <- theta.des[,,1] if (dep.model==3 & pair.structure==0) attr(ud, "rv1") <- random.design[1,,drop=FALSE] if (dep.model==3 & pair.structure==1) attr(ud, "rv1") <- random.design[,,1] attr(ud, "response") <- "binomial" return(ud); ## }}} } ## }}} ##' @export p11.binomial.twostage.RV <- function(theta,rv1,rv2,p1,p2,pardes,ags=NULL,link=0,i=1,j=1) { ## {{{ ## computes p11 pij for additive gamma binary random effects model if (is.null(ags)) ags <- matrix(1,dim(pardes)) out <- .Call("claytonoakesbinRV",theta,i,j,p1,p2,rv1,rv2,pardes,ags,link,PACKAGE="mets")$like return(out) } ## }}} ##' @export concordanceTwostage<- function(theta,p,rv1,rv2,theta.des,additive.gamma.sum=NULL,link=0,var.par=0,...) {# {{{ ### takes dependence paramter from output ptheta <- length(theta) ### ptheta <- attr(object,"ptheta") ### theta <- object$theta[seq(1,ptheta)] ### robvar.theta <- object$robvar.theta[seq(1,ptheta),seq(1,ptheta)] if (var.par==1) theta <- theta/sum(theta)^2 nn <- nrow(as.matrix(rv1)) if (is.matrix(p)==FALSE) { ll <- length(p); p <- matrix(p,ll,2); } if (ncol(p)!=2) p <- matrix(p,ncol=2) if (is.matrix(rv1)==FALSE) rv1 <- matrix(rv1,nn,length(rv1),byrow=TRUE) if (is.matrix(rv2)==FALSE) rv2 <- matrix(rv2,nn,length(rv1),byrow=TRUE) if (is.null(additive.gamma.sum)) ags <- matrix(1,ncol(rv1),ptheta) else ags <- additive.gamma.sum tabs <- list() for (i in 1:nn) { p1 <- p[i,1] p2 <- p[i,2] p11 <- p11.binomial.twostage.RV(theta,rv1[i,],rv2[i,],p1,p2,theta.des,ags=ags,link=link) p01 <- p[i,1]-p11 p10 <- p[i,2]-p11 p00 <- 1-p01-p10+p11 tabs[[i]] <- list(pmat=matrix(c(p00,p10,p01,p11),2,2),casewise=c(p11/p1,p11/p2),marg=c(p1,p2)) } return(tabs) } # }}} ##' @export concordanceTwinACE<- function(object,rv1=NULL,rv2=NULL,xmarg=NULL,type="ace",...) {# {{{ if (type=="ace" | type=="ade") { if (is.null(rv1)) rv1 <- rbind(c(1,0,0,0,1),c(0,1,1,0,1)) if (is.null(rv2)) rv2 <- rbind(c(1,0,0,0,1),c(0,1,0,1,1)) } if (type=="ae" | type=="de") { if (is.null(rv1)) rv1 <- rbind(c(1,0,0,0),c(0,1,1,0)) if (is.null(rv2)) rv2 <- rbind(c(1,0,0,0),c(0,1,0,1)) } var.par <- attr(object,"var.par") var.link <- attr(object,"var.link") theta.des <- attr(object,"theta.des") twostage <- attr(object,"twostage") if (twostage==0) { pt <- attr(object,"ptheta") theta <- object$theta[seq(1,pt)] beta <- object$theta[seq(pt+1,length(object$theta))] var.theta <- object$robvar.theta[seq(1,pt),seq(1,pt)] var.tot <- object$var.theta } else { theta <- object$theta; beta <- object$beta var.theta <- object$var.theta; var.tot <- object$var.tot } if (var.link==1) theta <- exp(theta) ###print(beta) ags <- attr(object,"ags"); if (is.null(xmarg)) {xmarg <- rep(0,length(beta)); xmarg[1] <- 1;} nn <- nrow(rv1) if (is.matrix(rv1)==FALSE) rv1 <- matrix(rv1,nn,length(rv1),byrow=TRUE) if (is.matrix(rv2)==FALSE) rv2 <- matrix(rv2,nn,length(rv1),byrow=TRUE) if (is.null(ags)) ags <- matrix(1,ncol(rv1),length(theta)); fp <- function(par) {# {{{ pp <- par[1:length(theta)]; beta <- par[(length(theta)+1):length(par)]; xp <- sum(xmarg*beta); pm <- exp(xp)/(1+exp(xp)); if (var.par==1) pp <- pp/sum(pp)^2 p11 <- p11.binomial.twostage.RV(pp,rv1l,rv2l,pm,pm,theta.des,ags=ags,link=0) casewise <- p11/pm ret <- c(p11,casewise,pm) names(ret) <- c("concordance","casewise concordance","marginal") return(ret) }# }}} nnn<-c("MZ","DZ") tabs <- list() for (i in 1:nn) { rv1l <- rv1[i,] rv2l <- rv2[i,] tabs<-c(tabs,setNames(list(tabs[[i]] <- lava::estimate(coef=c(theta,beta),vcov=var.tot,f=function(p) fp(p))), nnn[i])) } return(tabs) } # }}} ##' @export binomial.twostage.time <- function(formula,data,id,...,silent=1,fix.censweights=1, breaks=Inf,pairsonly=TRUE,fix.marg=NULL,cens.formula,cens.model="aalen",weights="w") { ## {{{ m <- match.call(expand.dots = FALSE) m <- m[match(c("","data"),names(m),nomatch = 0)] Terms <- terms(cens.formula,data=data) m$formula <- Terms m[[1]] <- as.name("model.frame") M <- eval(m,envir=parent.frame()) censtime <- model.extract(M, "response") status <- censtime[,2] time <- censtime[,1] timevar <- colnames(censtime)[1] outcome <- as.character(terms(formula)[[2]]) if (is.null(breaks)) breaks <- quantile(time,c(0.25,0.5,0.75,1)) outcome0 <- paste(outcome,"_dummy") res <- list() logor <- cif <- conc <- c() k <- 0 for (tau in rev(breaks)) { if ((length(breaks)>1) & (silent==0)) message(tau) ### construct min(T_i,tau) or T_i and related censoring variable, ### thus G_c(min(T_i,tau)) or G_c(T_i) as weights if ((fix.censweights==1 & k==0) | (fix.censweights==0)) { data0 <- data time0 <- time status0 <- status } cond0 <- (time>tau) if ((fix.censweights==1 & k==0) | (fix.censweights==0)) status0[cond0 & status==1] <- 3 if (fix.censweights==0) status0[cond0 & status==1] <- 3 data0[,outcome] <- data[,outcome] data0[cond0,outcome] <- FALSE if ((fix.censweights==1 & k==0) | (fix.censweights==0)) time0[cond0] <- tau ### if (fix.censweights==0 ) time0[cond0] <- tau if ((fix.censweights==1 & k==0) | (fix.censweights==0)) { data0$S <- survival::Surv(time0,status0==1) } if ((fix.censweights==1 & k==0) | (fix.censweights==0)) dataw <- ipw(update(cens.formula,S~.),data=data0,cens.model=cens.model, obsonly=TRUE) if ((fix.censweights==1)) dataw[,outcome] <- (dataw[,outcome])*(dataw[,timevar]0) { sts <- strsplit(st,"[\"']")[[1]] foundsep <- any(grepl("|", sts, fixed=TRUE)) p <- length(quotepos) ##repl <- rep(c("(\"","\")"),p) for (i in seq(p/2)*2-1) { sts[i] <- paste0(sts[i],"(\"") sts[i+1] <- paste0(sts[i+1],"\")") } ## To handle regular expression entered as strings in the formula, we add a 'filter' expression at the end of the formula if (!foundsep) sts <- c(sts,"|1") formula <- as.formula(paste(sts,collapse="")) } } aa <- attributes(terms(formula,data=data,specials="regex")) if (aa$response == 0) { res <- NULL } else { res <- paste(deparse(formula[[2]]), collapse = "") } filter.expression <- NULL foundsep <- FALSE pred <- filter <- c() if (!is.null(sep) && length(aa$term.labels) > 0) { foundsep <- any(grepl(sep,aa$term.labels)) if (foundsep) { if (nsep>1) { xc <- gsub(" ","",unlist(lapply(aa$term.labels, function(z) strsplit(z,sep)[[1]]))) pred <- xc[1] filter <- xc[-1] } else { xc <- gsub(" ","",unlist(lapply(aa$term.labels, function(z) { spl <- regexpr(sep,z) ## first appearance pred <- substr(z,1,spl-1) filter <- substr(z,spl+1,nchar(z)) return(c(pred,filter)) }))) pred <- xc[1] filter <- xc[2] } if (any(pred==".")) { f <- as.formula(paste0(paste0(c(res,filter),collapse="+"),"~.")) x <- attributes(terms(f,data=data))$term.labels pred <- x } if (filter%in%c("0","-1")) { filter <- list() filter.expression <- NULL } else { filter.expression <- parse(text=filter) filter <- as.list(filter) } } } if (!foundsep) pred <- aa$term.labels expandst <- function(st) { st <- res <- unlist(strsplit(gsub(" ","",st),"\\+")) if (any(unlist(lapply(st, function(x) grepl("^\\(",x))))) { res <- c() for (x in st) { if (grepl("^\\(",x)) { x <- gsub('\\"',"",x) x <- gsub('^\\(',"",x) x <- gsub('\\)$',"",x) res <- c(res,unlist(procform(x,data=data,regex=regex, no.match=FALSE)$response)) } else { res <- c(res,x) } res <- unique(res) } } return(res) } res <- expandst(res) pred <- expandst(pred) if (any(res==".")) { diffset <- c(".",setdiff(pred,res)) res <- setdiff(union(res,colnames(data)),diffset) } filter <- lapply(filter, expandst) if (!is.null(specials)) { foundspec <- replicate(length(specials),c()) names(foundspec) <- specials rmidx <- c() spec <- paste0("^",specials,"\\(") val <- lapply(spec, function(x) which(grepl(x,pred))) for (i in seq_along(val)) { if (length(val[[i]])>0) { # special function found rmidx <- c(rmidx,val[[i]]) cleanpred <- gsub("\\)$","",gsub(spec[i],"",pred[val[[i]]])) foundspec[[i]] <- c(foundspec[[i]],cleanpred) } } if (length(rmidx)>0) pred <- pred[-rmidx] if (length(pred)==0) pred <- NULL specials <- foundspec for (i in seq_along(specials)) if (is.null(specials[[i]])) specials[i] <- NULL if (length(specials)==0) specials <- NULL } if (return.formula) { if (foundsep && !is.null(filter)) { filter <- lapply(filter, function(z) as.formula(paste0(c("~", paste0(z,collapse="+"))))) } if (length(pred)>0) pred <- as.formula(paste0(c("~", paste0(pred,collapse="+")))) if (length(res)>0) res <- as.formula(paste0(c("~", paste0(res,collapse="+")))) if (!is.null(specials)) { specials <- lapply(specials,function(x) as.formula(paste0(c("~", paste0(x,collapse="+"))))) } } res <- list(response=res, predictor=pred, filter=filter, filter.expression=filter.expression, specials=specials) if (!return.list) return(unlist(unique(res))) return(res) } ##' @export procformdata <- function(formula,data,sep="\\|", na.action=na.pass, do.filter=TRUE, ...) { res <- procform(formula,sep=sep,data=data,return.formula=TRUE,...) if (inherits(res,"formula")) { res <- list(response=res) } y <- x <- NULL filter <- res$filter.expression if (!do.filter) { filter <- NULL } ### print(filter); print(missing(filter)); print(is.null(filter)); print(filter[[1]]) ### when filter.expression is expression(1) then also no filter, ts if ((!missing(filter))) if (!is.null(filter)) if (as.character(filter)=="1") filter <- NULL if (length(res$response)>0) { if (is.null(filter)) y <- model.frame(res$response,data=data,na.action=na.action) else y <- model.frame(res$response,data=subset(data,eval(filter)),na.action=na.action) } if (length(res$predictor)>0) { if (is.null(filter)) x <- model.frame(res$predictor,data=data,na.action=na.action) else x <- model.frame(res$predictor,data=subset(data,eval(filter)),na.action=na.action) } specials <- NULL if (!is.null(res$specials)) { specials <- lapply(res$specials, function(x) { if (is.null(filter)) model.frame(x,data=data,na.action=na.action) else model.frame(x,data=subset(data,eval(filter)),na.action=na.action) }) } if (!do.filter) { group <- lapply(res$filter, function(x) model.frame(x,data=data,na.action=na.action)) return(list(response=y,predictor=x,group=group,specials=specials)) } return(list(response=y,predictor=x,specials=specials)) }# }}} procform2 <- function(y,x=NULL,z=NULL,...) {# {{{ yx <- procform(y,return.formula=FALSE,...) y <- yx$response x0 <- yx$predictor z0 <- NULL if (length(yx$filter)>0) z0 <- yx$filter[[1]] if (is.null(x) && length(y)>0) x <- x0 if (NCOL(x)==0) x <- NULL if (length(y)==0) y <- x0 if (!is.null(x)) { x <- unlist(procform(x,return.formula=FALSE,...)) } if (is.null(z)) z <- z0 if (!is.null(z)) { zz <- unlist(procform(z,return.formula=FALSE,...)) } if (is.null(z)) z <- z0 return(list(y=y,x=x,z=z)) }# }}} ##' @export procform3 <- function(y,x=NULL,z=NULL,...) {# {{{ yx <- procform(y,return.formula=FALSE,...) x0 <- yx$predictor y <- yx$response if (is.null(yx$predictor)) { x0 <- yx$response ; y <- NULL} if (is.null(y)) if (!is.null(x)) { x <- procform(x,return.formula=FALSE,...) y <- c(x$predictor,x$response) } return(list(y=y,x=x0,z=z)) }# }}} ## Specials <- function(f,spec,split2="+",...) { ## tt <- terms(f,spec) ## pos <- attributes(tt)$specials[[spec]] ## if (is.null(pos)) return(NULL) ## x <- rownames(attributes(tt)$factors)[pos] ## st <- gsub(" ","",x) ## res <- unlist(strsplit(st,"[()]"))[2] ## if (is.null(split2)) return(res) ## unlist(strsplit(res,"+",fixed=TRUE)) ## } ## f <- Surv(lefttime,time,status)~x1+id(~1+z,cluster) ## spec <- "id" ## split1="," ## split2="+" ## myspecials <- c("id","strata","f") ## f <- Event(leftime,time,cause) ~ id(~1+z+z2,cluster) + strata(~s1+s2) + f(a) + z*x ## ff <- Specials(f,"id",split2=",") Specials <- function(f,spec,split1=",",split2=NULL,...) {# {{{ tt <- terms(f,spec) pos <- attributes(tt)$specials[[spec]] if (is.null(pos)) return(NULL) x <- rownames(attributes(tt)$factors)[pos] st <- gsub(" ","",x) ## trim ## res <- unlist(strsplit(st,"[()]")) spec <- unlist(strsplit(st,"[()]"))[[1]] res <- substr(st,nchar(spec)+2,nchar(st)-1) if (!is.null(split1)) res <- unlist(strsplit(res,split1)) res <- as.list(res) for (i in seq(length(res))) { if (length(grep("~",res[[i]]))>0) res[[i]] <- as.formula(res[[i]]) } return(res) }# }}} decomp.specials <- function (x, pattern = "[()]", sep = ",", ...) { st <- gsub(" ", "", x) if (!is.null(pattern)) st <- rev(unlist(strsplit(st, pattern, ...)))[1] unlist(strsplit(st, sep, ...)) } mets/R/marginalprobit.R0000644000176200001440000000107413623061405014562 0ustar liggesusers marginalprobit <- function(mu,dmu,S,dS,y,w=NULL,indiv=FALSE,...) { sigma <- S^0.5 alpha <- alpha0 <- pnorm(mu,sd=sigma) alpha[y==0] <- 1-alpha[y==0] M <- -sigma*dnorm(mu/sigma) V <- S*alpha0+mu*M U1 <- 0.5*t(dS)%*%(-alpha0+V/S)/S U <- matrix(0,ncol(dmu)+nrow(U1),ncol(U1)) if (is.null(w)) w <- rep(1,ncol(U)) for (i in seq(ncol(U))) { U[,i] <- c(- dmu[i,,drop=FALSE]*(1/S*M[i]),U1[,i])/alpha[i]* ifelse(y[i]==0,-1,1)*w[i] } if (indiv) return(structure(t(U),logLik=log(alpha))) return(structure(rowSums(U),logLik=sum(log(alpha)))) } mets/R/discrete-survival-haplo.R0000644000176200001440000010711413623061405016326 0ustar liggesusers##' Discrete time to event haplo type analysis ##' ##' Can be used for logistic regression when time variable is "1" for all id. ##' ##' Cycle-specific logistic regression of haplo-type effects with known ##' haplo-type probabilities. Given observed genotype G and unobserved haplotypes H ##' we here mix out over the possible haplotypes using that P(H|G) is provided. ##' ##' \deqn{ ##' S(t|x,G)) = E( S(t|x,H) | G) = \sum_{h \in G} P(h|G) S(t|z,h) ##' } ##' so survival can be computed by mixing out over possible h given g. ##' ##' Survival is based on logistic regression for the discrete hazard function of the ##' form ##' \deqn{ ##' logit(P(T=t| T \geq t, x,h)) = \alpha_t + x(h) \beta ##' } ##' where x(h) is a regression design of x and haplotypes \eqn{h=(h_1,h_2)} ##' ##' Likelihood is maximized and standard errors assumes that P(H|G) is known. ##' ##' The design over the possible haplotypes is constructed by merging X with Haplos and ##' can be viewed by design.only=TRUE ##' ##' @param X design matrix data-frame (sorted after id and time variable) with id time response and desnames ##' @param y name of response (binary response with logistic link) from X ##' @param time.name to sort after time for X ##' @param Haplos (data.frame with id, haplo1, haplo2 (haplotypes (h)) and p=P(h|G)) haplotypes given as factor. ##' @param id name of id variale from X ##' @param desnames names for design matrix ##' @param designfunc function that computes design given haplotypes h=(h1,h2) x(h) ##' @param beta starting values ##' @param no.opt optimization TRUE/FALSE ##' @param method NR, nlm ##' @param stderr to return only estimate ##' @param designMatrix gives response and designMatrix directly not implemented (mush contain: p, id, idhap) ##' @param response gives response and design directly designMatrix not implemented ##' @param idhap name of id-hap variable to specify different haplotypes for different id ##' @param design.only to return only design matrices for haplo-type analyses. ##' @param covnames names of covariates to extract from object for regression ##' @param fam family of models, now binomial default and only option ##' @param weights weights following id for GLM ##' @param offsets following id for GLM ##' @param idhapweights weights following id-hap for GLM (WIP) ##' @param ... Additional arguments to lower level funtions lava::NR optimizer or nlm ##' @author Thomas Scheike ##' @examples ##' ## some haplotypes of interest ##' types <- c("DCGCGCTCACG","DTCCGCTGACG","ITCAGTTGACG","ITCCGCTGAGG") ##' ##' ## some haplotypes frequencies for simulations ##' data(hapfreqs) ##' ##' www <-which(hapfreqs$haplotype %in% types) ##' hapfreqs$freq[www] ##' ##' baseline=hapfreqs$haplotype[9] ##' baseline ##' ##' designftypes <- function(x,sm=0) {# {{{ ##' hap1=x[1] ##' hap2=x[2] ##' if (sm==0) y <- 1*( (hap1==types) | (hap2==types)) ##' if (sm==1) y <- 1*(hap1==types) + 1*(hap2==types) ##' return(y) ##' }# }}} ##' ##' tcoef=c(-1.93110204,-0.47531630,-0.04118204,-1.57872602,-0.22176426,-0.13836416, ##' 0.88830288,0.60756224,0.39802821,0.32706859) ##' ##' data(hHaplos) ##' data(haploX) ##' ##' haploX$time <- haploX$times ##' Xdes <- model.matrix(~factor(time),haploX) ##' colnames(Xdes) <- paste("X",1:ncol(Xdes),sep="") ##' X <- dkeep(haploX,~id+y+time) ##' X <- cbind(X,Xdes) ##' Haplos <- dkeep(ghaplos,~id+"haplo*"+p) ##' desnames=paste("X",1:6,sep="") # six X's related to 6 cycles ##' out <- haplo.surv.discrete(X=X,y="y",time.name="time", ##' Haplos=Haplos,desnames=desnames,designfunc=designftypes) ##' names(out$coef) <- c(desnames,types) ##' out$coef ##' summary(out) ##' @aliases simTTP predictSurvd plotSurvd ##' @export haplo.surv.discrete <- function (X=NULL,y="y",time.name="time",Haplos=NULL,id="id",desnames=NULL,designfunc=NULL, beta=NULL,no.opt=FALSE,method="NR",stderr=TRUE,designMatrix=NULL,response=NULL,idhap=NULL,design.only=FALSE, covnames=NULL,fam=binomial,weights=NULL,offsets=NULL,idhapweights=NULL,...) { ## {{{ cond=NULL if (is.null(designMatrix)) { if (!is.null(Haplos)) { ## with haplo-types {{{ ## X: y, Xdes, id ## Haplos, haplo1, haplo2, id, p (HgivenG) bothid <- intersect(X$id,Haplos$id) X <- subset(X,id %in% bothid) Haplos <- subset(Haplos,id %in% bothid) ## new iid starts at 1 Haplos$id <- fast.approx(bothid,Haplos$id) iiid <- Haplos$id-1 X$id <- fast.approx(bothid,X$id) Xo <- X Xhap <- merge(X,Haplos,by.x="id",by.y="id") Xhap <- dsort2(Xhap,~id+"haplo*"+time) Haplos <- dsort2(Haplos,~id+"haplo*") time <- Xhap[,time.name] tn <- match(time.name,names(Xhap)) Xhap <- Xhap[,-tn] response <- Xhap[,y] yn <- match(y,names(Xhap)) Xhap <- Xhap[,-yn] mm <- grep("haplo*",names(Xhap)) Xhaps <- Xhap[,mm] if (!is.null(designfunc)) { Xo <- X <- as.matrix(apply(Xhap[,mm],1,designfunc)) if (ncol(X)==nrow(Xhap)) X <- t(X) colnames(X) <- paste("haplo",1:ncol(X),sep="") X <- as.matrix(cbind(Xhap[,desnames],X)) } else Xo <- X <- as.matrix(Xhap[,desnames]) ## X(i)^T %*% X(i) for each row X2 <- .Call("vecMatMat",X,X)$vXZ ## creates sub-index for haplo-types within each id nmm <- names(Xhap)[mm] ### lll <- lapply(Xhap[,c("id",nmm)],as.numeric) ### stratidhap <- as.numeric(survival::strata(lll)) ms <- mystrata(Xhap[,c("id",nmm)]) stratidhap <- ms ###nidhap <- length(unique(stratidhap)) nidhap <- attr(ms,"nlevel") nid <- length(unique(Haplos$id)) ## weights will follow id if (is.null(weights)) wiid <- rep(1,nid) else wiid <- weights ## idhap weights will follow id-hap if (is.null(idhapweights)) whapiid <- rep(1,nidhap) else whapiid <- idhapweights ## offsets can follow both Haplo or X design and will then appear in mixed design if (is.null(offsets)) offiid <- rep(0,nrow(X)) else offiid <- offsets ### to make the optimizer more flexible and use for interval censored data if (is.null(cond)) cond <- rep(0,nidhap) hgiveng <- Haplos$p # }}} } else { ## standard glm {{{ ## X: y, Xdes, id id.name <- id ## id going from 1 to #id's id <- X$id <- fast.approx(unique(X[,id]),X[,id]) Xhap <- Xo <- X iiid <- unique(X$id)-1 nid <- length(iiid) stratidhap <- id nidhap <- length(unique(stratidhap)) ### response <- Xhap[,y] yn <- match(y,names(Xhap)) Xhap <- Xhap[,-yn] X <- as.matrix(Xhap[,desnames]) ## X(i)^T %*% X(i) for each row X2 <- .Call("vecMatMat",X,X)$vXZ ## weights will follow id if (is.null(weights)) wiid <- rep(1,nid) else wiid <- weights ## idhap weights will follow id-hap if (is.null(idhapweights)) wph <- rep(1,nidhap) else wph <- idhapweights ## offsets can follow both Haplo or X design and will then appear in mixed design if (is.null(offsets)) offiid <- rep(0,nrow(X)) else offiid <- offsets if (is.null(cond)) cond <- rep(0,nidhap) hgiveng <- rep(1,nid) }# }}} } else {# {{{ hgiveng <- designMatrix$p X <- designMatrix[,desnames] id <- designMatrix[,id] iiid <- unique(id)-1 stratidhap <- designMatrix[,idhap] nidhap <- length(unique(stratidhap)) nid <- length(iiid) design.only <- FALSE ## weights will follow id if (is.null(weights)) wiid <- rep(1,nid) else wiid <- weights ## idhap weights will follow id-hap if (is.null(idhapweights)) wph <- rep(1,nidhap) else wph <- idhapweights ## offsets can follow both Haplo or X design and will then appear in mixed design if (is.null(offsets)) offiid <- rep(0,nrow(X)) else offiid <- offsets if (is.null(cond)) cond <- rep(0,nidhap) }# }}} if (!design.only) { if (is.null(beta)) beta <- rep(0,ncol(X)) expit <- function(z) 1/(1+exp(-z)) ## expit obj <- function(pp,all=FALSE) { # {{{ lp <- X %*% pp ## plp <- family$linkinv(lp) plp <- expit(lp+ offiid) nplp <- 1-plp ###lognp <- log(nplp) ### logpht <- (response - plp)/family$variance(plp) logpht <- log(plp)*response+log(nplp)*(1-response) pht <-c(exp(logpht)) Dlogpht <- X* c(response-plp) D2logpht <- c(plp/(1+exp(lp)))*X2 ph <- c(exp(sumstrata(logpht,stratidhap-1,nidhap))) pg <- c(sumstrata(ph*hgiveng,iiid,nid)) logl <- wiid*log(pg) ## Derivative Dlogph <- apply(Dlogpht,2,sumstrata,stratidhap-1,nidhap) Dph <- c(ph)*Dlogph Dpg <- apply(Dph*hgiveng,2,sumstrata,iiid,nid)# {{{}}} Dlogl <- wiid*Dpg/pg DpgDpg <- .Call("vecMatMat",Dpg,Dpg)$vXZ ## 2nd Derivative D2logph <- apply(D2logpht,2,sumstrata,stratidhap-1,nidhap) DphDlogph <- .Call("vecMatMat",Dph,Dlogph)$vXZ D2ph <- ph*D2logph+DphDlogph D2pg <-apply(D2ph*hgiveng,2,sumstrata,iiid,nid) D2logi <- wiid*(pg*D2pg-DpgDpg)/pg^2 D2log <- apply(D2logi,2,sum) D2log <- matrix(D2log,ncol(X),ncol(X)) ploglik <- sum(logl) gradient <- apply(Dlogl,2,sum) hessian <- D2log if (all) { ihess <- solve(hessian) beta.iid <- Dlogl %*% ihess ## %*% t(Dlogl) robvar <- crossprod(beta.iid) val <- list(par=pp,ploglik=ploglik,gradient=gradient,hessian=hessian,ihessian=ihess, iid=beta.iid,robvar=robvar,var=ihess, id=iiid, se=diag(ihess)^.5,se.robust=diag(robvar)^.5) return(val) } structure(-ploglik,gradient=-gradient,hessian=hessian) }# }}} p <- ncol(X) opt <- NULL if (p>0) { if (no.opt==FALSE) { if (tolower(method)=="nr") { tim <- system.time(opt <- lava::NR(beta,obj,...)) opt$timing <- tim opt$estimate <- opt$par } else { opt <- nlm(obj,beta,...) opt$method <- "nlm" } cc <- opt$estimate; if (!stderr) return(cc) val <- c(list(coef=cc),obj(opt$estimate,all=TRUE)) } else val <- c(list(coef=beta),obj(beta,all=TRUE)) } else { val <- obj(0,all=TRUE) } } else val <- NULL val <- c(list(Xhap=Xhap,X=X,Haplos=Haplos),val) class(val) <- "survd" return(val) } ## }}} ##' @export summary.survd <- function(object,...) return(lava::estimate(object,...)) ##' @export print.survd <- function(x,...) return(lava::estimate(x,...)) ##' @export vcov.survd <- function(object,...) return(object$var) ##' @export coef.survd <- function(object,...) return(object$coef) ##' @export simTTP <- function(coef=NULL,n=100,Xglm=NULL,times=NULL) {# {{{ Z <- Xglm if (!is.null(Z)) n <- nrow(Z) if (!is.null(Z)) data <- Z else data <- data.frame(id=1:n) if (!is.null(times)) { timesf <- data.frame(times=rep(times,n),id=rep(1:n,each=length(times))) data <- merge(data,timesf,by.x="id",by.y="id") mt <- model.matrix(~factor(times),data) nm <- match(c("id","times"),names(data)) Z <- cbind(mt,data[,-nm]) } expit <- function(z) 1/(1+exp(-z)) ## expit p <- c(expit(as.matrix(Z) %*% coef)) y <- rbinom(length(p),1,p) data <- cbind(y,data) data <- count.history(data,status="y",id="id",types=1) data <- subset(data,data$Count1<=0) attr(data,"coef") <- beta return(data) }# }}} ##' @export predictSurvd <- function(ds,Z,times=1:6,se=FALSE,type="prob") {# {{{ if (!is.null(Z)) n <- nrow(Z) if (!is.null(Z)) data <- Z else data <- data.frame(id=1:n) Z <- data.frame(Z) Z$id <- 1:n ccc <- ds$coef if (!se) {# {{{{{{ data <- Z if (!is.null(times)) { timesf <- data.frame(times=rep(times,n),id=rep(1:n,each=length(times))) data <- merge(data,timesf,by.x="id",by.y="id") mt <- model.matrix(~factor(times),data) nm <- match(c("id","times"),names(data)) Z <- cbind(mt,data[,-nm]) } if (ncol(Z)!=length(c(ccc))) { print(head(Z)) print(ccc) stop("dimension of Z not consistent with length of coefficients"); } p <- c(expit(as.matrix(Z) %*% ccc)) preds <- data.frame(p=p,id=data$id,times=data$times) survt <- exp(cumsumstrata(log(1-preds$p),data$id-1,6)) if (type=="prob") pred <- 1-survt if (type=="surv") pred <- survt if (type=="hazard") pred <- p if (type=="rrm") { ## restricted residual mean ll <- length(survt) pred <- cumsum(c(1,survt[-ll])) } preds <- cbind(preds,pred) # }}} } else {# {{{ expit <- function(p) exp(p)/(1+exp(p)) Ft <- function(p) { xp <- as.matrix(Zi) %*% p lam <- expit(xp) st <- cumprod(1-lam) if (type=="prob") st <- 1-st if (type=="surv") st <- st if (type=="hazard") st <- lam if (type=="rrm") { ## restricted residual mean ll <- length(st) st <- cumsum(c(1,st[-ll])) } return(st) } preds <- c() for (i in 1:nrow(Z)) { Zi <- data.frame(Z[i,,drop=FALSE]) data <- Zi if (!is.null(times)) { timesf <- data.frame(times=rep(times,n),id=rep(1:n,each=length(times))) data <- merge(data,timesf,by.x="id",by.y="id") mt <- model.matrix(~factor(times),data) nm <- match(c("id","times"),names(data)) Zi <- cbind(mt,data[,-nm]) } if (is.null(ds$var)) covv <- vcov(ds) else covv <- ds$var eud <- estimate(coef=ds$coef,vcov=covv,f=function(p) Ft(p)) cmat <- data.frame(eud$coefmat) cmat$id <- i cmat$times <- times names(cmat)[1:4] <- c("pred","se","lower","upper") preds <- rbind(preds,cmat) } }# }}} return(preds) }# }}} ## }}} ##' @export plotSurvd <- function(ds,ids=NULL,add=FALSE,se=FALSE,cols=NULL,ltys=NULL,...) {# {{{ if (is.null(ids)) ids <- unique(ds$id) if (is.null(cols)) cols <- 1:length(ids) if (is.null(ltys)) ltys <- 1:length(ids) k <- 1 fplot <- 0 for (i in ids) { timei <- ds$time[ds$id==i] predi <- ds$pred[ds$id==i] if (fplot==0) { if (!add) plot(timei,predi,type="s",col=cols[k],lty=ltys[k],...) if (add) lines(timei,predi,type="s",col=cols[k],lty=ltys[k],...) fplot <- 1 } else lines(timei,predi,type="s",col=cols[k],lty=ltys[k],...) if (se) { loweri <- ds$lower[ds$id==i] upperi <- ds$upper[ds$id==i] plotConfRegion(timei,cbind(loweri,upperi),col=cols[k]) } k <- k+1 } } ## }}} ##' ## uses HaploSurvival package of github install via devtools ##' ## devtools::install_github("scheike/HaploSurvival") ##' ## this is only used for simulations ##' ## out <- simHaplo(1,100,tcoef,hapfreqs) ###simHaplo <- function(i,n,tcoef,hapfreqs) ###{ ## {{{ ### ### haplos <- sample(19,2*n,replace=TRUE,prob=hapfreqs$freq) ### haplos <- matrix(haplos,n,2) ### hap1 <- hapfreqs$haplotype[haplos[,1]] ### hap2 <- hapfreqs$haplotype[haplos[,2]] ### ### ### X <- t(apply(cbind(hap1,hap2),1,designftypes)) ### X <- data.frame(X,id=1:n) ### sud <- simTTP(coef=tcoef,Xglm=X,n=n,times=1:6) ### ## known haplotypes ### ssud <- glm(y~factor(times)+X1+X2+X3+X4+X5,data=sud,family=binomial()) ### ### genotype <- c() ### for (i in 1:11) ### genotype <- cbind(genotype,substr(hap1,i,i), substr(hap2,i,i) ) ### ### setup <- geno.setup(genotype,haplo.baseline=baseline,sep="") ### wh <- match(setup$uniqueHaploNames,hapfreqs$haplotype) ### wwf <- wh[!is.na(wh)] ### ghaplos <- matrix(unlist(setup$HPIordered),byrow=TRUE,ncol=2) ### ghaplos <- cbind(rep(1:n,setup$nPossHaps),ghaplos) ### ghaplos <- data.frame(ghaplos) ### names(ghaplos) <- c("id","haplo1","haplo2") ### haploff <- rep(0,length(setup$uniqueHaploNames)) ### haploff[!is.na(wh)] <- hapfreqs[wwf,"freq"] ###### ### hap1f <- haploff[ghaplos[,2]] ### hap2f <- haploff[ghaplos[,3]] ### hap12f <- hap1f*hap2f ### hapsshed <- hap12f ### ghaplos$p <- hapsshed ### ghaplos <- subset(ghaplos,p>0) ### ## back to characters for indentification of design ### ghaplos$haplo1 <- as.factor(setup$uniqueHaploNames[ghaplos$haplo1]) ### ghaplos$haplo2 <- as.factor(setup$uniqueHaploNames[ghaplos$haplo2]) ### ptot <- sumstrata(ghaplos$p,ghaplos$id-1,n) ### ghaplos$p <- ghaplos$p/ptot[ghaplos$id] ### ###sud$time <- sud$times ###Xdes <- model.matrix(~factor(time),sud) ###colnames(Xdes) <- paste("X",1:ncol(Xdes),sep="") ###X <- dkeep(sud,~id+y+time) ###X <- cbind(X,Xdes) ###Haplos <- dkeep(ghaplos,~id+"haplo*"+p) ###dtable(Haplos,~"haplo*",level=1) ######Haplos ###### ###y <- "y" ###time.name="time" ###desnames=paste("X",1:6,sep="") ###### ###### ###mm <- system.time( ###mud <- haplo.surv.discrete(X=X,y="y",time.name="time",##design.only=TRUE, ### Haplos=Haplos,designfunc=designftypes,desnames=desnames) ###) ### ### ### max haplo-type ### Haplos$nhaplo1 <- as.numeric(Haplos$haplo1) ### Haplos$nhaplo2 <- as.numeric(Haplos$haplo2) ### dsort(Haplos) <- ~id+nhaplo1+nhaplo2-p ### Haplos <- count.history(Haplos,status="p",types="1") ### mHaplos <- subset(Haplos,lbnr__id==1) ### bothid <- intersect(X$id, mHaplos$id) ### X <- subset(X, id %in% bothid) ### mHaplos <- subset(mHaplos, id %in% bothid) ### Xhap <- merge(X, mHaplos, by.x = "id", by.y = "id") ### mm <- grep("haplo*", names(Xhap)) ### X <- t(as.matrix(apply(Xhap[, mm], 1, designftypes))) ### ### ### mmud <- glm(y~factor(time)+X,data=Xhap,family=binomial()) ### ###ud <- list(coef=mud$coef,se=mud$se,se.robust=mud$se.robust,mcoef=mmud$coef,kcoef=ssud$coef) ###return(ud) ###} ## }}} ### ##' Discrete time to event interval censored data ##' ##' \deqn{ ##' logit(P(T >t | x)) = log(G(t)) + x \beta ##' } ##' \deqn{ ##' P(T >t | x) = \frac{1}{1 + G(t) exp( x \beta) } ##' } ##' ##' Input are intervals given by ]t_l,t_r] where t_r can be infinity for right-censored intervals ##' When truly discrete ]0,1] will be an observation at 1, and ]j,j+1] will be an observation at j+1 ##' ##' Likelihood is maximized: ##' \deqn{ ##' \prod P(T_i >t_{il} | x) - P(T_I> t_{ir}| x) ##' } ##' ##' @param formula formula ##' @param data data ##' @param beta starting values ##' @param no.opt optimization TRUE/FALSE ##' @param method NR, nlm ##' @param stderr to return only estimate ##' @param weights weights following id for GLM ##' @param offsets following id for GLM ##' @param exp.link parametrize increments exp(alpha) > 0 ##' @param increment using increments dG(t)=exp(alpha) as parameters ##' @param ... Additional arguments to lower level funtions lava::NR optimizer or nlm ##' @author Thomas Scheike ##' @examples ##' data(ttpd) ##' out <- interval.logitsurv.discrete(Interval(entry,time2)~X1+X2+X3+X4,ttpd) ##' summary(out) ##' ##' n <- 100 ##' Z <- matrix(rbinom(n*4,1,0.5),n,4) ##' outsim <- simlogitSurvd(out$coef,Z) ##' outsim <- transform(outsim,left=time,right=time+1) ##' outsim <- dtransform(outsim,right=Inf,status==0) ##' ##' outss <- interval.logitsurv.discrete(Interval(left,right)~+X1+X2+X3+X4,outsim) ##' ##' Z <- matrix(0,5,4) ##' Z[2:5,1:4] <- diag(4) ##' pred <- predictlogitSurvd(out,se=FALSE) ##' plotSurvd(pred) ##' ##' ## simulations ##' n <- 100 ##' Z <- matrix(rbinom(n*4,1,0.5),n,4) ##' outsim <- simlogitSurvd(out$coef,Z) ##' ### ##' outsim <- transform(outsim,left=time,right=time+1) ##' outsim <- dtransform(outsim,right=Inf,status==0) ##' ##' out$coef ##' outss <- interval.logitsurv.discrete(Interval(left,right)~+X1+X2+X3+X4,outsim) ##' summary(outss) ##' ##' @aliases Interval dInterval simlogitSurvd predictlogitSurvd ##' @export interval.logitsurv.discrete <- function (formula,data,beta=NULL,no.opt=FALSE,method="NR", stderr=TRUE,weights=NULL,offsets=NULL,exp.link=1,increment=1,...) { ## {{{ cl <- match.call() m <- match.call(expand.dots = TRUE)[1:3] special <- c("strata", "cluster","offset") Terms <- terms(formula, special, data = data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) Y <- model.extract(m, "response") if (ncol(Y)==2) { time2 <- eventtime <- Y[,2] entrytime <- Y[,1] left <- 0 } else { time2 <- eventtime <- Y[,2] status <- delta <- Y[,3] entrytime <- Y[,1] left <- 1 if (max(entrytime)==0) left <- 0 } id <- strata <- NULL if (!is.null(attributes(Terms)$specials$cluster)) { ts <- survival::untangle.specials(Terms, "cluster") pos.cluster <- ts$terms Terms <- Terms[-ts$terms] id <- m[[ts$vars]] } else pos.cluster <- NULL if (!is.null(attributes(Terms)$specials$strata)) { ts <- survival::untangle.specials(Terms, "strata") pos.strata <- ts$terms Terms <- Terms[-ts$terms] strata <- m[[ts$vars]] strata.name <- ts$vars } else { strata.name <- NULL; pos.strata <- NULL} X <- model.matrix(Terms, m) if (!is.null(intpos <- attributes(Terms)$intercept)) X <- X[,-intpos,drop=FALSE] if (ncol(X)>0) X.names <- colnames(X) else X.names <- NULL ### if (ncol(X)==0) X <- NULL ## times 1 -> mutimes , 0 til start utimes <- sort(unique(c(time2,entrytime))) ### time2 <- fast.approx(utimes,time2)-1 ### entrytime <- fast.approx(utimes,entrytime)-1 mutimes <- max(utimes[utimes0) { X2 <- .Call("vecMatMat",X,X)$vXZ XtL <- .Call("vecMatMat",X,tL)$vXZ XtR <- .Call("vecMatMat",X,tR)$vXZ } tL2 <- .Call("vecMatMat",tL,tL)$vXZ tR2 <- .Call("vecMatMat",tR,tR)$vXZ ## weights/offets will follow id if (is.null(weights)) weights <- rep(1,n); # else wiid <- weights if (is.null(offsets)) offsets <- rep(0,n); # else offsets <- offsets if (is.null(beta)) beta <- rep(0,ncol(X)+mutimes) expit <- function(z) 1/(1+exp(-z)) ## expit logit <- function(p) log(p/(1-p)) ## logit beta[1:mutimes] <- (1:mutimes)*exp(logit( (sum(time20) { betal <- pp[-c(1:mutimes)] Zbeta <- c(X %*% betal+offsets) } else {Zbeta <- offsets } xltheta <- c(tL %*% theta) xrtheta <- c(tR %*% theta) EZbeta <- exp(Zbeta) GEl <- xltheta * EZbeta GEr <- xrtheta * EZbeta Stl <- 1/(1+GEl) Str <- 1/(1+GEr) ############################################ ## likelihood ############################################ # {{{ p <- Stl-Str*(time20) { DbetaStl <- -X*GEl*Stl^2 DbetaStr <- -(time20) { Dlogliid <- cbind(Dglogp*weights,Dbetalogp*weights) Dlogl <- apply(Dlogliid,2,sum) } else { Dlogliid <- Dglogp*weights Dlogl <- apply(Dlogliid,2,sum) } if (exp.link==1) { Dlogliid[,1:mutimes] <- t( t(Dlogliid[,1:mutimes])*theta) Dlogl[1:mutimes] <- Dlogl[1:mutimes]*theta } # }}} ############################################ ## 2nd Derivative ############################################ # {{{ if (ncol(X)>0) { D2betaStl <- X2*(GEl^2-GEl)*Stl^3 D2betaStr <- X2*(time20) { DbetalpDbetalp <- .Call("vecMatMat",Dbetalogp,Dbetalogp)$vXZ DbetalpDglp <- .Call("vecMatMat",Dbetalogp,Dglogp)$vXZ D2betalogp <- (D2betaStl-D2betaStr)/p - DbetalpDbetalp Dbetaglogp <- (DbetagStl-DbetagStr)/p - DbetalpDglp D2beta <- apply(weights*D2betalogp,2,sum) Dbetag <- apply(weights*Dbetaglogp,2,sum) } D2log <- matrix(0,length(pp),length(pp)) D2log[1:mutimes,1:mutimes] <- D2g if (ncol(X)>0) { ###D2log[1:mutimes,(mutimes+1):length(pp)] <- Dbetag D2log[(mutimes+1):length(pp),1:mutimes] <- Dbetag D2log[1:mutimes,(mutimes+1):length(pp)] <- t(D2log[(mutimes+1):length(pp),1:mutimes]) D2log[(mutimes+1):length(pp),(mutimes+1):length(pp)] <- D2beta } if (exp.link==1) { D2log[1:mutimes,1:mutimes] <- diag(Dlogl[1:mutimes]) + D2log[1:mutimes,1:mutimes]*(theta %o% theta) if (ncol(X)>0) { D2log[(mutimes+1):length(pp),1:mutimes] <- Dbetag*rep(theta,each=length(betal)) ###D2log[(mutimes+1):length(pp),1:mutimes] <- Dbetag*rep(theta,length(betal)) D2log[1:mutimes,(mutimes+1):length(pp)] <- t(D2log[(mutimes+1):length(pp),1:mutimes]) } } # }}} ############################################ ploglik <- sum(logl) gradient <- Dlogl hessian <- D2log if (all) { ihess <- solve(hessian) beta.iid <- Dlogliid %*% ihess ## %*% t(Dlogl) robvar <- crossprod(beta.iid) val <- list(par=pp,ploglik=ploglik,gradient=gradient,hessian=hessian,ihessian=ihess, iid=beta.iid,robvar=robvar,var=-ihess, se=diag(-ihess)^.5,se.robust=diag(robvar)^.5) return(val) } structure(-ploglik,gradient=-gradient,hessian=-hessian) }# }}} p <- ncol(X) opt <- NULL if (no.opt==FALSE) { if (tolower(method)=="nr") { tim <- system.time(opt <- lava::NR(beta,obj,...)) opt$timing <- tim opt$estimate <- opt$par } else { opt <- nlm(obj,beta,...) opt$method <- "nlm" } cc <- opt$estimate; if (!stderr) return(cc) val <- c(list(coef=cc),obj(opt$estimate,all=TRUE)) } else val <- c(list(coef=beta),obj(beta,all=TRUE)) uu <- utimes[utimes0) X.names <- colnames(X) else X.names <- NULL ###### if (ncol(X)==0) X <- NULL ### ### ## times 1 -> mutimes , 0 til start ### utimes <- sort(unique(c(time2,entrytime))) ###### time2 <- fast.approx(utimes,time2)-1 ###### entrytime <- fast.approx(utimes,entrytime)-1 ### mutimes <- max(utimes[utimes0) { ### X2 <- .Call("vecMatMat",X,X)$vXZ ### XtL <- .Call("vecMatMat",X,tL)$vXZ ### XtR <- .Call("vecMatMat",X,tR)$vXZ ### } ### tL2 <- .Call("vecMatMat",tL,tL)$vXZ ### tR2 <- .Call("vecMatMat",tR,tR)$vXZ ### ### ### ## weights/offets will follow id ### if (is.null(weights)) weights <- rep(1,n); # else wiid <- weights ### if (is.null(offsets)) offsets <- rep(0,n); # else offsets <- offsets ### if (is.null(beta)) beta <- rep(0,ncol(X)+mutimes) ### expit <- function(z) 1/(1+exp(-z)) ## expit ### ### beta[1:mutimes] <- (1:mutimes)*exp(logit( (sum(time20) { ###Zbeta <- c(X %*% betal+offsets) ###} else {Zbeta <- offsets } ###xltheta <- c(tL %*% theta) ###xrtheta <- c(tR %*% theta) ###EZbeta <- exp(Zbeta) ###GEl <- xltheta * EZbeta ###GEr <- xrtheta * EZbeta ###Stl <- 1/(1+GEl) ###Str <- 1/(1+GEr) ### ############################################### ##### likelihood ############################################### #### {{{ ###p <- Stl-Str*(time20) { ###DbetaStl <- -X*GEl*Stl^2 ###DbetaStr <- -(time20) { ###Dlogl <- c(apply(Dglogp*weights,2,sum),apply(Dbetalogp*weights,2,sum)) ###} else Dlogl <- c(apply(Dglogp*weights,2,sum)) ###if (exp.link==1) { ###Dlogl[1:mutimes] <- Dlogl[1:mutimes]*theta ###} #### }}} ############################################### ##### 2nd Derivative ############################################### #### {{{ ###if (ncol(X)>0) { ###D2betaStl <- X2*(GEl^2-GEl)*Stl^3 ###D2betaStr <- X2*(time20) { ###DbetalpDbetalp <- .Call("vecMatMat",Dbetalogp,Dbetalogp)$vXZ ###DbetalpDglp <- .Call("vecMatMat",Dbetalogp,Dglogp)$vXZ ### ###D2betalogp <- (D2betaStl-D2betaStr)/p - DbetalpDbetalp ###Dbetaglogp <- (DbetagStl-DbetagStr)/p - DbetalpDglp ###D2beta <- apply(weights*D2betalogp,2,sum) ###Dbetag <- apply(weights*Dbetaglogp,2,sum) ###} ### ### ### ###D2log <- matrix(0,length(pp),length(pp)) ###D2log[1:mutimes,1:mutimes] <- D2g ### ###if (ncol(X)>0) { ######D2log[1:mutimes,(mutimes+1):length(pp)] <- Dbetag ###D2log[(mutimes+1):length(pp),1:mutimes] <- Dbetag ###D2log[1:mutimes,(mutimes+1):length(pp)] <- t(D2log[(mutimes+1):length(pp),1:mutimes]) ###D2log[(mutimes+1):length(pp),(mutimes+1):length(pp)] <- D2beta ###} ### ###if (exp.link==1) { ###D2log[1:mutimes,1:mutimes] <- diag(Dlogl[1:mutimes]) + D2log[1:mutimes,1:mutimes]*(theta %o% theta) ###if (ncol(X)>0) { ###D2log[(mutimes+1):length(pp),1:mutimes] <- Dbetag*rep(theta,each=length(betal)) ######D2log[(mutimes+1):length(pp),1:mutimes] <- Dbetag*rep(theta,length(betal)) ###D2log[1:mutimes,(mutimes+1):length(pp)] <- t(D2log[(mutimes+1):length(pp),1:mutimes]) ###} ###} ### #### }}} ############################################### ### ###ploglik <- sum(logl) ###gradient <- Dlogl ###hessian <- D2log ### ### if (all) { ### ihess <- solve(hessian) ### beta.iid <- Dlogl %*% ihess ## %*% t(Dlogl) ### robvar <- crossprod(beta.iid) ### val <- list(par=pp,ploglik=ploglik,gradient=gradient,hessian=hessian,ihessian=ihess, ### iid=beta.iid,robvar=robvar,var=-ihess, ### se=diag(-ihess)^.5,se.robust=diag(robvar)^.5) ### return(val) ### } ### structure(-ploglik,gradient=-gradient,hessian=-hessian) ###}# }}} ### ### p <- ncol(X) ### opt <- NULL ### if (p>0) { ### if (no.opt==FALSE) { ### if (tolower(method)=="nr") { ### tim <- system.time(opt <- lava::NR(beta,obj,...)) ### opt$timing <- tim ### opt$estimate <- opt$par ### } else { ### opt <- nlm(obj,beta,...) ### opt$method <- "nlm" ### } ### cc <- opt$estimate; ### if (!stderr) return(cc) ### val <- c(list(coef=cc),obj(opt$estimate,all=TRUE)) ### } else val <- c(list(coef=beta),obj(beta,all=TRUE)) ### } else { ### val <- obj(0,all=TRUE) ### } ### ### uu <- utimes[utimes 0) cuts <- c(cut.first,cuts) ### lleft <- fast.approx(cuts,time,type="left") rright <- fast.approx(cuts,time2,type="right") out <- data.frame(time=time,time2=time2,left=lleft-1,right=rright-1) attr(out,"cuts") <- cuts out$leftd <- cuts[lleft] out$rightd <- cuts[rright] if (max(cuts)==Inf) out$right[out$rightd==Inf] <- Inf if (any(out$timeout$rightd)) warning("right not in [leftd,rightd]\n") if (show) { mtime <- mmtime <- max(cuts[cuts0) EZ <- exp(sum(Zi*beta)) else EZ <- 1 pred <- 1/(1+Gt*EZ) return(pred) }# }}} preds <- c() for (i in 1:length(EZbeta)) { if (is.null(x$var)) covv <- vcov(x) else covv <- x$var eud <- estimate(coef=x$coef,vcov=covv,f=function(p) Ft(p,Zi=Z[i,])) cmat <- data.frame(eud$coefmat) cmat$id <- i cmat$times <- times names(cmat)[1:4] <- c("pred","se","lower","upper") preds <- rbind(preds,cmat) } }# }}} return(preds) } ## }}} mets/R/twinlm.R0000644000176200001440000005750513623061405013074 0ustar liggesusers###{{{ twinlm ##' Fits a classical twin model for quantitative traits. ##' ##' @title Classic twin model for quantitative traits ##' @return Returns an object of class \code{twinlm}. ##' @author Klaus K. Holst ##' @seealso \code{\link{bptwin}}, \code{\link{twinlm.time}}, \code{\link{twinlm.strata}}, \code{\link{twinsim}} ##' @aliases twinlm twinlm.strata ##' @export ##' @examples ##' ## Simulate data ##' set.seed(1) ##' d <- twinsim(1000,b1=c(1,-1),b2=c(),acde=c(1,1,0,1)) ##' ## E(y|z1,z2) = z1 - z2. var(A) = var(C) = var(E) = 1 ##' ##' ## E.g to fit the data to an ACE-model without any confounders we simply write ##' ace <- twinlm(y ~ 1, data=d, DZ="DZ", zyg="zyg", id="id") ##' ace ##' ## An AE-model could be fitted as ##' ae <- twinlm(y ~ 1, data=d, DZ="DZ", zyg="zyg", id="id", type="ae") ##' ## LRT: ##' lava::compare(ae,ace) ##' ## AIC ##' AIC(ae)-AIC(ace) ##' ## To adjust for the covariates we simply alter the formula statement ##' ace2 <- twinlm(y ~ x1+x2, data=d, DZ="DZ", zyg="zyg", id="id", type="ace") ##' ## Summary/GOF ##' summary(ace2) ##' \donttest{ ## Reduce Ex.Timings ##' ## An interaction could be analyzed as: ##' ace3 <- twinlm(y ~ x1+x2 + x1:I(x2<0), data=d, DZ="DZ", zyg="zyg", id="id", type="ace") ##' ace3 ##' ## Categorical variables are also supported ##' d2 <- transform(d,x2cat=cut(x2,3,labels=c("Low","Med","High"))) ##' ace4 <- twinlm(y ~ x1+x2cat, data=d2, DZ="DZ", zyg="zyg", id="id", type="ace") ##' } ##' @keywords models ##' @keywords regression ##' @param formula Formula specifying effects of covariates on the response ##' @param data \code{data.frame} with one observation pr row. In ##' addition a column with the zygosity (DZ or MZ given as a factor) of ##' each individual much be ##' specified as well as a twin id variable giving a unique pair of ##' numbers/factors to each twin pair ##' @param id The name of the column in the dataset containing the twin-id variable. ##' @param zyg The name of the column in the dataset containing the ##' zygosity variable ##' @param DZ Character defining the level in the zyg variable ##' corresponding to the dyzogitic twins. If this argument is missing, ##' the reference level (i.e. the first level) will be interpreted as ##' the dyzogitic twins ##' @param group Optional. Variable name defining group for interaction analysis (e.g., gender) ##' @param group.equal If TRUE marginals of groups are asummed to be the same ##' @param strata Strata variable name ##' @param weights Weights matrix if needed by the chosen estimator. For use ##' with Inverse Probability Weights ##' @param type Character defining the type of analysis to be ##' performed. Should be a subset of "aced" (additive genetic factors, common ##' environmental factors, unique environmental factors, dominant ##' genetic factors). ##' @param twinnum The name of the column in the dataset numbering the ##' twins (1,2). If it does not exist in \code{data} it will ##' automatically be created. ##' @param binary If \code{TRUE} a liability model is fitted. Note that if the right-hand-side of the formula is a factor, character vector, og logical variable, then the liability model is automatically chosen (wrapper of the \code{bptwin} function). ##' @param ordinal If non-zero (number of bins) a liability model is fitted. ##' @param keep Vector of variables from \code{data} that are not ##' specified in \code{formula}, to be added to data.frame of the SEM ##' @param estimator Choice of estimator/model ##' @param constrain Development argument ##' @param control Control argument parsed on to the optimization routine ##' @param messages Control amount of messages shown ##' @param ... Additional arguments parsed on to lower-level functions twinlm <- function(formula, data, id, zyg, DZ, group=NULL, group.equal=FALSE, strata=NULL, weights=NULL, type=c("ace"), twinnum="twinnum", binary=FALSE,ordinal=0, keep=weights,estimator=NULL, constrain=TRUE,control=list(),messages=1,...) { cl <- match.call(expand.dots=TRUE) opt <- options(na.action="na.pass") mf <- model.frame(formula,data) mt <- attr(mf, "terms") y <- model.response(mf, "any") ## formula <- update(formula, ~ . + 1) yvar <- getoutcome(formula) if (missing(zyg)) stop("Zygosity variable not specified") if (!(zyg%in%colnames(data))) stop("'zyg' not found in data") if (!(id%in%colnames(data))) stop("'id' not found in data") if (missing(id)) stop("Twin-pair variable not specified") if (binary || ordinal || is.factor(mf[,yvar]) || is.character(mf[,yvar]) || is.logical(mf[,yvar])) { if (length(unique(mf[,yvar]))>2 || ordinal) { if (is.character(mf[,yvar])) { y <- as.factor(y) } if (ordinal<2) ordinal <- length(unique(mf[,yvar])) y <- as.numeric(y)-1 } else { args <- as.list(cl) names(args)[which(names(args)=="formula")] <- "x" args[[1]] <- NULL return(do.call("bptwin",args,envir=parent.frame())) } } cl$ordinal <- ordinal formulaId <- unlist(Specials(formula,"cluster")) formulaStrata <- unlist(Specials(formula,"strata")) formulaSt <- paste("~.-cluster(",formulaId,")-strata(",paste(formulaStrata,collapse="+"),")") formula <- update(formula,formulaSt) if (!is.null(formulaId)) { id <- formulaId cl$id <- id } if (!is.null(formulaStrata)) strata <- formulaStrata cl$formula <- formula if (!is.null(strata)) { dd <- split(data,interaction(data[,strata])) nn <- unlist(lapply(dd,nrow)) dd[which(nn==0)] <- NULL if (length(dd)>1) { fit <- lapply(seq(length(dd)),function(i) { if (messages>0) message("Strata '",names(dd)[i],"'") cl$data <- dd[[i]] eval(cl) }) res <- list(model=fit) res$strata <- names(res$model) <- names(dd) class(res) <- c("twinlm.strata","twinlm") res$coef <- unlist(lapply(res$model,coef)) res$vcov <- blockdiag(lapply(res$model,vcov)) res$N <- length(dd) res$idx <- seq(length(coef(res$model[[1]]))) rownames(res$vcov) <- colnames(res$vcov) <- names(res$coef) return(res) } } type <- tolower(type) ## if ("u" %in% type) type <- c("ue") varnames <- all.vars(formula) latentnames <- c("a1","a2","c1","c2","d1","d2","e1","e2") if (any(latentnames%in%varnames)) stop(paste(paste(latentnames,collapse=",")," reserved for names of latent variables.",sep="")) M <- model.matrix(formula,mf) options(opt) covars <- colnames(M) hasIntercept <- FALSE if (attr(terms(formula),"intercept")==1) { hasIntercept <- TRUE covars <- covars[-1] } if(length(covars)<1) covars <- NULL zygstat <- data[,zyg] if(!is.factor(zygstat)) { zygstat <- as.factor(zygstat) } zyglev <- levels(zygstat) if (length(zyglev)>2) stop("More than two zygosity levels found. For opposite sex (OS) analysis use the 'group' argument (and regroup OS group as DZ, e.g. DZ=c('OS','DZ'))") if (tolower(type)=="cor") type <- "u" if (!is.null(group) && type%in%c("u","flex","sat")) stop("Only polygenic models are allowed with 'group' ('type' subset of 'acde'). See also the 'strata' argument.") ## To wide format: num <- NULL; if (twinnum%in%colnames(data)) num <- twinnum if (!is.null(group)) data[,group] <- as.factor(data[,group]) y <- data.frame(y); names(y) <- yvar #y <- cbind(as.vector(y)); colnames(y) <- yvar data <- cbind(y,data[,c(keep,num,zyg,id,group)],M) ddd <- fast.reshape(data,id=c(id),varying=c(yvar,keep,covars,group),keep=zyg,num=num,sep=".",labelnum=TRUE) groups <- paste(group,".",1:2,sep="") outcomes <- paste(yvar,".",1:2,sep="") if (missing(DZ)) { warning("Using first level, `",zyglev[1],"', in status variable as indicator for 'dizygotic'", sep="") DZ <- zyglev[1] } MZ <- setdiff(zyglev,DZ) wide1 <- ddd[which(ddd[,zyg]==MZ),,drop=FALSE] wide2 <- ddd[which(ddd[,zyg]%in%DZ),,drop=FALSE] mm <- nn <- c() dd <- list() levgrp <- NULL if (!is.null(group)) { levgrp <- levels(data[,group]) for (i1 in levgrp) { for (i2 in levgrp) { idxMZ <- which(wide1[,groups[1]]==i1 & wide1[,groups[2]]==i2) dMZ <- wide1[idxMZ,,drop=FALSE] idxDZ <- which(wide2[,groups[1]]==i1 & wide2[,groups[2]]==i2) dDZ <- wide2[idxDZ,,drop=FALSE] m0 <- twinsem1(outcomes,c(i1,i2), levels=levgrp,covars=covars,type=type, data=list(dMZ,dDZ),constrain=constrain, equal.marg=group.equal,intercept=hasIntercept, ordinal=ordinal)$model if (length(idxMZ)>0) { nn <- c(nn,paste("MZ:",i1,sep="")) dd <- c(dd,list(dMZ)) mm <- c(mm,list(m0[[1]])) } if (length(idxDZ)>0) { nn <- c(nn,paste("DZ:",i1," ",i2,sep="")) dd <- c(dd,list(dDZ)) mm <- c(mm,list(m0[[2]])) } } }; names(mm) <- nn; names(dd) <- nn } else { mm <- twinsem1(outcomes,NULL, levels=NULL,covars=covars,type=type, data=list(wide1,wide2),constrain=constrain, intercept=hasIntercept,ordinal=ordinal)$model dd <- list(MZ=wide1,DZ=wide2) } newkeep <- unlist(sapply(keep, function(x) paste(x, 1:2, sep = "."))) if (!is.null(estimator) && (inherits(estimator,c("numeric","logical")) && !estimator)) return(multigroup(mm, dd, missing=TRUE,fix=FALSE,keep=newkeep,type=2)) optim <- list() if (is.null(control$start)) { optim <- list(start=rep(0.1,length(coef(mm[[1]]))*length(mm))) ## optim <- list(method="nlminb2",refit=FALSE,gamma=1,start=rep(0.1,length(coef(mm[[1]]))*length(mm))) optim$start <- twinlmStart(formula,na.omit(mf),type,hasIntercept, surv=inherits(data[,yvar],"Surv"),ordinal=ordinal, model=mm, group=levgrp, group.equal=group.equal) } if (length(control)>0) { optim[names(control)] <- control } if (inherits(data[,yvar],"Surv")) { ##if (!requireNamespace("lava.tobit",quietly=TRUE)) stop("lava.tobit required") if (!is.null(estimator) && estimator%in%c("gaussian","tobit")) optim$method <- "nlminb1" suppressWarnings(e <- estimate(mm,dd,control=optim,estimator=estimator,...)) } else { suppressWarnings(e <- estimate(mm,dd,weights=weights,estimator=estimator,fix=FALSE,control=optim,...)) } if (!is.null(optim$refit) && optim$refit) { optim$method <- "NR" optim$start <- pars(e) if (inherits(mf[,yvar],"Surv")) { suppressWarnings(e <- estimate(mm,dd,estimator=estimator,fix=FALSE,control=optim,...)) } else { suppressWarnings(e <- estimate(mm,dd,weights=weights,estimator=estimator,fix=FALSE,control=optim,...)) } } e$vcov <- Inverse(information(e,type="hessian")) counts <- function(dd) { dd0 <- apply(dd,2,function(x) !is.na(x)) pairs <- sum(dd0[,1]*dd0[,2]) singletons <- sum((!dd0[,1])*dd0[,2] + (!dd0[,2])*dd0[,1]) return(c(pairs,singletons)) } counts <- lapply(dd, function(x) counts(x[,outcomes])) ## mz <- counts(object$data.mz[,object$outcomes]) ## dz <- counts(object$data.dz[,object$outcomes]) if (!e$model$missing) { zygtab <- c("MZ-pairs"=counts[[1]][1],"DZ-pairs"=counts[[2]][1]) } else { zygtab <- c(paste(counts[[1]],collapse="/"),paste(counts[[2]],collapse="/")) names(zygtab) <- c("MZ-pairs/singletons","DZ-pairs/singletons") } res <- list(coefficients=e$opt$estimate, vcov=e$vcov, estimate=e, model=mm, call=cl, data=data, zyg=zyg, id=id, twinnum=twinnum, type=type, group=group, constrain=constrain, outcomes=outcomes, zygtab=zygtab, nam=nn, groups=levgrp, group.equal=group.equal, counts=counts,ordinal=ordinal) class(res) <- "twinlm" return(res) } ###}}} twinlm ###{{{ twinsem1 (create lava model) ##outcomes <- c("y1","y2"); groups <- c("M","F"); covars <- NULL; type <- "ace" ##twinsem1(c("y1","y2"),c("M","F")) twinsem1 <- function(outcomes,groups=NULL,levels=NULL,covars=NULL,type="ace",data,constrain=TRUE,equal.marg=FALSE,intercept=TRUE,ordinal=0,...) { isA <- length(grep("a",type))>0 & type!="sat" isC <- length(grep("c",type))>0 isD <- length(grep("d",type))>0 isE <- length(grep("e",type))>0 | type=="sat" | type=="u" lambdas <- c("lambda[a]","lambda[c]","lambda[d]","lambda[e]") varidx <- which(c(isA,isC,isD,isE)) vMZ1 <- c("a1","c1","d1","e1") vMZ2 <- c("a1","c1","d1","e2") vDZ2 <- c("a2","c1","d2","e2") rhoA <- rhoD <- zA <- zD <- NULL ##if (ordinal>0) { ## mm <- lapply(mm, function(x) { ## x ## }) ## } if (is.list(outcomes)) { if (!is.null(groups) & is.null(levels)) stop("missing levels") if (is.null(groups)) groups <- c("","") grp <- paste(sort(groups),collapse=" ") sameGroup <- groups[1]==groups[2] model1 <- outcomes[[1]] model2 <- outcomes[[2]] if (!is.null(levels)) { pars <- c() for (i in seq(length(levels)-1)) for (j in seq(i+1,length(levels))) pars <- c(pars,paste(sort(levels)[c(i,j)],collapse=" ")) if (isA) { parameter(model1) <- paste("z(A):",pars,sep="") parameter(model2) <- paste("z(A):",pars,sep="") } if (isD) { parameter(model1) <- paste("z(D):",pars,sep="") parameter(model2) <- paste("z(D):",pars,sep="") } } outcomes <- endogenous(model1) if (!(type%in%c("u","flex","sat"))) { if (equal.marg) { regression(model1,to=outcomes[1],from=vMZ1[varidx]) <- lambdas[varidx] regression(model1,to=outcomes[2],from=vMZ2[varidx]) <- lambdas[varidx] regression(model2,to=outcomes[1],from=vMZ1[varidx]) <- lambdas[varidx] regression(model2,to=outcomes[2],from=vDZ2[varidx]) <- lambdas[varidx] } else { regression(model1,to=outcomes[1],from=vMZ1[varidx]) <- paste(lambdas,groups[1],sep="")[varidx] regression(model1,to=outcomes[2],from=vMZ2[varidx]) <- paste(lambdas,groups[2],sep="")[varidx] regression(model2,to=outcomes[1],from=vMZ1[varidx]) <- paste(lambdas,groups[1],sep="")[varidx] regression(model2,to=outcomes[2],from=vDZ2[varidx]) <- paste(lambdas,groups[2],sep="")[varidx] } } if (sameGroup) { if (isA) covariance(model2,a1~a2) <- 0.5 if (isD) covariance(model2,d1~d2) <- 0.25 } else { if (isA) { rhoA <- paste("Kinship[A]:",grp,sep="") zA <- paste("z(A):",grp,sep="") covariance(model2, a1~a2) <- rhoA constrain(model2, rhoA,zA) <- function(x) tanh(x) } if (isD) { rhoD <- paste("Kinship[D]:",grp,sep="") zD <- paste("z(D):",grp,sep="") covariance(model2, d1~d2) <- rhoD constrain(model2, rhoD,zD) <- function(x) tanh(x) } } if (ordinal>0) { for (i in c("model1","model2")) { model <- get(i) yy <- lava::endogenous(model) if (type=="sat") { lava::ordinal(model,K=ordinal) <- yy } else { pname <- paste0("t",seq_len(ordinal-1)) if (type=="flex") pname <- paste0(pname,gsub("model","",i)) lava::ordinal(model,K=ordinal,pname) <- yy } if (!(type%in%c("u","flex","sat"))) { lava::covariance(model,yy) <- 0 lava::regression(model,from="e1",to=yy[1]) <- 1 lava::regression(model,from="e2",to=yy[2]) <- 1 } assign(i,model) } } return(list(model=list(MZ=model1,DZ=model2), zA=zA, rhoA=rhoA, zD=zD, rhoD=rhoD)) } ### Build model from scratch.... model1<- lvm() if (!(type%in%c("u","flex","sat"))) { model1 <- regression(model1,to=outcomes[1],from=vMZ1[varidx]) model1 <- regression(model1,to=outcomes[2],from=vMZ2[varidx]) } else { addvar(model1) <- outcomes covariance(model1) <- outcomes } latent(model1) <- union(vMZ1[varidx],vMZ2[varidx]) intercept(model1,latent(model1)) <- 0 if (!is.null(covars)) for (i in 1:length(covars)) { regression(model1, from=paste(covars[i],".1",sep=""), to=outcomes[1],silent=TRUE) <- paste("beta[",i,"]",sep="") regression(model1, from=paste(covars[i],".2",sep=""), to=outcomes[2],silent=TRUE) <- paste("beta[",i,"]",sep="") } covariance(model1,outcomes) <- 0 covariance(model1, latent(model1)) <- 1 if (!type%in%c("sat","flex")) { intercept(model1,outcomes) <- "mu" } if (type%in%c("u","flex","sat")) { kill(model1) <- ~e1+e2 covariance(model1,outcomes) <- "v1" } model2 <- model1 if (!(type%in%c("u","flex","sat"))) { model2 <- cancel(model2,c(outcomes[2],vMZ2[varidx])) model2 <- regression(model2,to=outcomes[2],from=vDZ2[varidx]) latent(model2) <- vDZ2[varidx] intercept(model2, latent(model2)) <- 0 covariance(model2, latent(model2)) <- 1 } if (type=="flex") { varMZ <- paste("var(MZ)",groups,sep="") varDZ <- paste("var(DZ)",groups,sep="") intercept(model1,outcomes) <- "mu1" intercept(model2,outcomes) <- "mu2" covariance(model1,outcomes) <- varMZ covariance(model2,outcomes) <- varDZ } if (type=="sat") { varMZ <- c(paste("var(MZ)1",groups[1],""), paste("var(MZ)2",groups[2],"")) varDZ <- c(paste("var(DZ)1",groups[1],""), paste("var(DZ)2",groups[2],"")) covariance(model1,outcomes) <- varMZ covariance(model2,outcomes) <- varDZ } if (type%in%c("u","flex","sat")) { if (constrain) { if (ordinal) { covariance(model1,outcomes,pairwise=TRUE) <- "covMZ" covariance(model2,outcomes,pairwise=TRUE) <- "covDZ" constrain(model1,"atanh(rhoMZ)","covMZ") <- tanh constrain(model2,"atanh(rhoDZ)","covDZ") <- tanh } if (type=="sat") { if (!ordinal) { model1 <- covariance(model1,outcomes,constrain=TRUE,rname="atanh(rhoMZ)",cname="covMZ",lname="log(var(MZ)).1",l2name="log(var(MZ)).2") model2 <- covariance(model2,outcomes,constrain=TRUE,rname="atanh(rhoDZ)",cname="covDZ",lname="log(var(DZ)).1",l2name="log(var(DZ)).2") } } else { if (type=="flex") { if (!ordinal) { model1 <- covariance(model1,outcomes,constrain=TRUE,rname="atanh(rhoMZ)",cname="covMZ",lname="log(var(MZ))") model2 <- covariance(model2,outcomes,constrain=TRUE,rname="atanh(rhoDZ)",cname="covDZ",lname="log(var(DZ))") } } else { if (!ordinal) { model1 <- covariance(model1,outcomes,constrain=TRUE,rname="atanh(rhoMZ)",cname="covMZ",lname="log(var)") model2 <- covariance(model2,outcomes,constrain=TRUE,rname="atanh(rhoDZ)",cname="covDZ",lname="log(var)") } } } } else { covariance(model1,outcomes[1],outcomes[2]) <- "covMZ" covariance(model2,outcomes[1],outcomes[2]) <- "covDZ" } } if (!is.null(covars) & type%in%c("flex","sat")) { sta <- "" if (type=="sat") sta <- "b" for (i in 1:length(covars)) { regression(model1, from=paste(covars[i],".1",sep=""), to=outcomes[1],silent=TRUE) <- paste("beta1[",i,"]",sep="") regression(model1, from=paste(covars[i],".2",sep=""), to=outcomes[2],silent=TRUE) <- paste("beta1",sta,"[",i,"]",sep="") regression(model2, from=paste(covars[i],".1",sep=""), to=outcomes[1],silent=TRUE) <- paste("beta2[",i,"]",sep="") regression(model2, from=paste(covars[i],".2",sep=""), to=outcomes[2],silent=TRUE) <- paste("beta2",sta,"[",i,"]",sep="") } } if (!intercept) { intercept(model1,outcomes) <- 0 intercept(model2,outcomes) <- 0 } ## Full rank covariate/design matrix? if (!missing(data)) for (i in covars) { myvars <- paste(i,c(1,2),sep=".") dif <- data[[1]][,myvars[1]]-data[[1]][,myvars[2]] mykeep <- myvars if (all(na.omit(dif)==00)) { mykeep <- mykeep[-2] } trash <- setdiff(myvars,mykeep) if (length(mykeep)==1) { regression(model1, to=outcomes[2], from=mykeep) <- lava::regfix(model1)$label[trash,outcomes[2]] kill(model1) <- trash } dif <- data[[2]][,myvars[1]]-data[[2]][,myvars[2]] mykeep <- myvars if (all(na.omit(dif)==00)) { mykeep <- mykeep[-2] } trash <- setdiff(myvars,mykeep) if (length(mykeep)==1) { regression(model2, to=outcomes[2], from=mykeep) <- lava::regfix(model2)$label[trash,outcomes[2]] kill(model2) <- trash } } twinsem1(list(MZ=model1,DZ=model2),groups=groups,type=type,levels=levels,constrain=constrain,equal.marg=equal.marg,ordinal=ordinal) } ###}}} twinsem1 ###{{{ twinlmStart (starting values) twinlmStart <- function(formula,mf,type,hasIntercept,surv=FALSE,ordinal=0,model,group=NULL,group.equal,...) { if (surv) { l <- survival::survreg(formula,data=mf,dist="gaussian") beta <- coef(l) sigma <- l$scale } else { if (ordinal) { l <- lava::ordreg(formula,mf) beta <- coef(l) sigma <- 1 } else { l <- lm.fit(model.matrix(formula,mf),mf[,1]) beta <- l$coefficients sigma <- sd(l$residuals) } } intidx <- 1 if (ordinal) intidx <- seq_len(ordinal-1) start <- rep(sigma/sqrt(nchar(type)),nchar(type)) if (ordinal) start <- start[-length(start)] if (hasIntercept) { start <- c(beta[intidx],start) start <- c(start,beta[-intidx]) } else start <- c(start,beta) varp <- 0.5 if (type=="sat") { if (!ordinal) varp <- c(rep(log(sigma^2),2),varp) start <- c() if (hasIntercept) { start <- rep(beta[intidx],4) beta <- beta[-intidx] } start <- c(start,rep(c(rep(beta,2),varp),2)) } if (type=="flex") { if (!ordinal) varp <- c(log(sigma^2),varp) start <- c() if (hasIntercept) { start <- c(beta[intidx],beta[intidx]) beta <- beta[-intidx] } start <- c(start,rep(c(beta,varp),2)) } if (type=="u") { start <- c(varp,varp) if (!ordinal) start <- c(log(sigma^2),start) start <- c(beta,start) } names(start) <- NULL if (!is.null(group)) { cc <- coef(model[[1]]) iA <- grep(c("z(A):"),cc,fixed=TRUE) iD <- grep(c("z(D):"),cc,fixed=TRUE) nplus <- length(iA) + length(iD) + max(length(iA),length(iD)) start <- c(start,rep(.2,nplus)) ii <- sort(c(iA,iD)) start <- c(start[seq(ii[1]-1)],rep(0.3,length(ii)),start[seq(ii[1]+1,length(start))]) } return(start) } ###}}} twinlmStart mets/R/ipw.R0000644000176200001440000004356713623061405012364 0ustar liggesusers##' Internal function. ##' Calculates Inverse Probability of Censoring ##' Weights (IPCW) and adds them to a data.frame ##' ##' @title Inverse Probability of Censoring Weights ##' @param formula Formula specifying the censoring model ##' @param data data frame ##' @param cluster clustering variable ##' @param same.cens For clustered data, should same censoring be assumed (bivariate probability calculated as mininum of the marginal probabilities) ##' @param obs.only Return data with uncensored observations only ##' @param weight.name Name of weight variable in the new data.frame ##' @param indi.weight Name of individual censoring weight in the new data.frame ##' @param trunc.prob If TRUE truncation probabilities are also calculated and stored in 'weight.name2' (based on Clayton-Oakes gamma frailty model) ##' @param weight.name2 Name of truncation probabilities ##' @param cens.model Censoring model (default Aalens additive model) ##' @param pairs For paired data (e.g. twins) only the complete pairs are returned (With pairs=TRUE) ##' @param theta.formula Model for the dependence parameter in the Clayton-Oakes model (truncation only) ##' @param ... Additional arguments to censoring model ##' @author Klaus K. Holst ##' @examples ##' \dontrun{ ##' data("prt",package="mets") ##' prtw <- ipw(Surv(time,status==0)~country, data=prt[sample(nrow(prt),5000),], ##' cluster="id",weight.name="w") ##' plot(0,type="n",xlim=range(prtw$time),ylim=c(0,1),xlab="Age",ylab="Probability") ##' count <- 0 ##' for (l in unique(prtw$country)) { ##' count <- count+1 ##' prtw <- prtw[order(prtw$time),] ##' with(subset(prtw,country==l), ##' lines(time,w,col=count,lwd=2)) ##' } ##' legend("topright",legend=unique(prtw$country),col=1:4,pch=-1,lty=1) ##' } ##' @export ipw <- function(formula,data,cluster, same.cens=FALSE,obs.only=TRUE, weight.name="w", trunc.prob=FALSE,weight.name2="wt",indi.weight="pr", cens.model="aalen", pairs=FALSE, theta.formula=~1, ...) { ## {{{ ##iid=TRUE, ##cens.args <- c(list(formula,n.sim=0,robust=0,data=eval(data)),list(...)) if (tolower(cens.model)%in%c("weibull","phreg.par","phreg.weibull")) { ud.cens <- phreg.par(formula,data,...) pr <- predict(ud.cens) noncens <- which(!ud.cens$status) } else { ## {{{ m <- match.call(expand.dots = FALSE) m <- m[match(c("", "formula", "data", "subset", "na.action"), names(m), nomatch = 0)] special <- c("strata", "factor", "NN", "cluster", "dummy") if (missing(data)) Terms <- terms(formula) else Terms <- terms(formula, data = data) m$formula <- Terms m[[1]] <- as.name("model.frame") M <- eval(m, parent.frame()) censtime <- model.extract(M, "response") if (ncol(censtime)==3) { status <- censtime[,3] otimes <- censtime[,2] ltimes <- censtime[,1] } else { status <- censtime[,2] otimes <- censtime[,1] } noncens <- !status if (is.null(attr(terms(formula,"prop"),"specials")$prop)) { ud.cens <- aalen(formula,n.sim=0,robust=0,data=data,...) XZ <- model.matrix(formula,data) ### Gcx <- ud.cens$cum[prodlim::sindex(ud.cens$cum[,1],otimes),-1] Gcx<-Cpred(ud.cens$cum,otimes)[,-1]; Gcx<-exp(-apply(Gcx*XZ,1,sum)) } else { ud.cens <- cox.aalen(formula,n.sim=0,robust=0,data=data,...) XZ <- model.matrix(formula,data) Gcx<-Cpred(ud.cens$cum,otimes)[,-1]; Gcx<-exp(-apply(Gcx*XZ,1,sum)) } ##ud.cens <- do.call(cens.model,cens.args) Gcx[Gcx>1]<-1; Gcx[Gcx<0]<-0 pr <- Gcx data[,indi.weight] <- Gcx } ## }}} if (trunc.prob) stop("Under development\n"); if (trunc.prob & ncol(censtime)==3) { ## truncation ## {{{ data$truncsurv <- Surv(ltimes,otimes,noncens) trunc.formula <- update(formula,truncsurv~.) ud.trunc <- aalen(trunc.formula,data=data,robust=0,n.sim=0,residuals=0,silent=1) dependX0 <- model.matrix(theta.formula,data) twostage.fit <-two.stage(ud.trunc,data=data,robust=0,detail=0, clusters=data[,cluster], theta.des=dependX0)#,Nit=20,step=1.0,notaylor=1) pre.theta <- dependX0 %*% twostage.fit$theta X <- model.matrix(formula,data) Xnam <- colnames(X) X <- cbind(X,pre.theta) colnames(X)[ncol(X)] <- "pre.theta" ww <- fast.reshape(cbind(X,".num"=seq(nrow(X)),".lefttime"=ltimes),varying=c(".num",".lefttime"),id=data[,cluster]) if (anyNA(ww)) stop("not balanced for predict two stage\n"); Prob <- predict.two.stage(twostage.fit,X=ww[,Xnam], times=ww[,".lefttime1"],times2=ww[,".lefttime2"], theta=ww$pre.theta) P0 <- numeric(nrow(X)) P0[ww[,".num1"]] <- Prob$St1t2 P0[ww[,".num2"]] <- Prob$St1t2 data[,weight.name2] <- P0 print(summary(P0)) } data[,weight.name] <- pr ## }}} if (same.cens & missing(cluster)) message("no cluster for same-cens given \n"); if (same.cens & !missing(cluster)) { ## {{{ ### message("Minimum weights...") myord <- order(data[,cluster]) data <- data[myord,,drop=FALSE] id <- table(data[,cluster]) if (pairs) { gem <- data[,cluster]%in%(names(id)[id==2]) id <- id[id==2] data <- data[gem,] } d0 <- subset(data,select=c(cluster,weight.name)) noncens <- with(data,!eval(terms(formula)[[2]][[3]])) d0[,"observed."] <- noncens timevar <- paste("_",cluster,weight.name,sep="") d0[,timevar] <- unlist(lapply(id,seq)) Wide <- reshape(d0,direction="wide",timevar=timevar,idvar=cluster) W <- apply(Wide[,paste(weight.name,1:2,sep=".")],1, function(x) min(x,na.rm=TRUE)) Wmarg <- d0[,weight.name] data[,weight.name] <- 1/Wmarg Wmin <- rep(W,id) obs1only <- rep(with(Wide, observed..1 & (is.na(observed..2) | !observed..2)),id) obs2only <- rep(with(Wide, observed..2 & (is.na(observed..1) | !observed..1)),id) obsOne <- which(na.omit(obs1only|obs2only)) obsBoth <- rep(with(Wide, !is.na(observed..1) & !is.na(observed..2) & observed..2 & observed..1),id) data[obsBoth,weight.name] <- ifelse(noncens[obsBoth],1/Wmin[obsBoth],0) data[obsOne,weight.name] <- ifelse(noncens[obsOne],1/Wmarg[obsOne],0) } ## }}} if (obs.only) data <- data[noncens,,drop=FALSE] return(data) } ## }}} ##' Internal function. ##' Calculates Inverse Probability of Censoring and Truncation ##' Weights and adds them to a data.frame ##' ##' @title Inverse Probability of Censoring Weights ##' @param data data frame ##' @param times possible time argument for speciying a maximum value of time tau=max(times), to specify when things are considered censored or not. ##' @param entrytime nam of entry-time for truncation. ##' @param time name of time variable on data frame. ##' @param cause name of cause indicator on data frame. ##' @param same.cens For clustered data, should same censoring be assumed and same truncation (bivariate probability calculated as mininum of the marginal probabilities) ##' @param cluster name of clustering variable ##' @param pairs For paired data (e.g. twins) only the complete pairs are returned (With pairs=TRUE) ##' @param strata name of strata variable to get weights stratified. ##' @param obs.only Return data with uncensored observations only ##' @param cens.formula model for Cox models for truncation and right censoring times. ##' @param cens.code censoring.code ##' @param pair.cweight Name of weight variable in the new data.frame for right censorig of pairs ##' @param pair.tweight Name of weight variable in the new data.frame for left truncation of pairs ##' @param pair.weight Name of weight variable in the new data.frame for right censoring and left truncation of pairs ##' @param cname Name of weight variable in the new data.frame for right censoring of individuals ##' @param tname Name of weight variable in the new data.frame for left truncation of individuals ##' @param weight.name Name of weight variable in the new data.frame for right censoring and left truncation of individuals ##' @param prec.factor To let tied censoring and truncation times come after the death times. ##' @param ... Additional arguments to censoring model ##' @author Thomas Scheike ##' @examples ##' library("timereg") ##' d <- simnordic.random(3000,delayed=TRUE,ptrunc=0.7, ##' cordz=0.5,cormz=2,lam0=0.3,country=FALSE) ##' d$strata <- as.numeric(d$country)+(d$zyg=="MZ")*4 ##' times <- seq(60,100,by=10) ##' c1 <- comp.risk(Event(time,cause)~1+cluster(id),data=d,cause=1, ##' model="fg",times=times,max.clust=NULL,n.sim=0) ##' mm=model.matrix(~-1+zyg,data=d) ##' out1<-random.cif(c1,data=d,cause1=1,cause2=1,same.cens=TRUE,theta.des=mm) ##' summary(out1) ##' pc1 <- predict(c1,X=1,se=0) ##' plot(pc1) ##' ##' dl <- d[!d$truncated,] ##' dl <- ipw2(dl,cluster="id",same.cens=TRUE,time="time",entrytime="entry",cause="cause", ##' strata="strata",prec.factor=100) ##' cl <- comp.risk(Event(time,cause)~+1+ ##' cluster(id), ##' data=dl,cause=1,model="fg", ##' weights=dl$indi.weights,cens.weights=rep(1,nrow(dl)), ##' times=times,max.clust=NULL,n.sim=0) ##' pcl <- predict(cl,X=1,se=0) ##' lines(pcl$time,pcl$P1,col=2) ##' mm=model.matrix(~-1+factor(zyg),data=dl) ##' out2<-random.cif(cl,data=dl,cause1=1,cause2=1,theta.des=mm, ##' weights=dl$weights,censoring.weights=rep(1,nrow(dl))) ##' summary(out2) ##' @export ipw2 <- function(data,times=NULL,entrytime=NULL,time="time",cause="cause", same.cens=FALSE,cluster=NULL,pairs=FALSE, strata=NULL,obs.only=TRUE,cens.formula=NULL,cens.code=0, pair.cweight="pcw",pair.tweight="ptw",pair.weight="weights", cname="cweights",tname="tweights",weight.name="indi.weights", prec.factor=100,...) { ## {{{ ### first calculates weights based on marginal ### estimators of censoring and truncation ## {{{ weights, up at T_i or min(T_i,max(times)) if (is.null(times)) times <- max(data[,time]) if (is.null(entrytime)) entry <- rep(0,nrow(data)) else entry <- data[,entrytime] mtt <- max(times) prec <- .Machine$double.eps * prec.factor trunc.model <- cens.model <- NULL ## output of Cox models for entry cens if (is.null(cens.formula)) { if (is.null(strata)) { ## {{{ if (!is.null(entrytime)) { surv.trunc <- survival::survfit(Surv(-data[,time],-entry+prec,rep(1,nrow(data))) ~ 1) trunc.dist <- summary(surv.trunc) trunc.dist$time <- rev(-trunc.dist$time) trunc.dist$surv <- c(rev(trunc.dist$surv)[-1], 1) Lfit <-Cpred(cbind(trunc.dist$time,trunc.dist$surv),data[,time],strict=TRUE) Lw <- Lfit[,2] } else { Lw <- 1; } if (!is.null(entrytime)) ud.cens<- survival::survfit(Surv(entry,data[,time],data[,cause]==0)~+1) else ud.cens<- survival::survfit(Surv(data[,time],data[,cause]==0)~+1) Gfit<-cbind(ud.cens$time,ud.cens$surv) Gfit<-rbind(c(0,1),Gfit); Gcx<-Cpred(Gfit,pmin(mtt,data[,time]),strict=TRUE)[,2]; weights <- 1/(Lw*Gcx); cweights <- Gcx; tweights <- Lw; ### ## }}} } else { ## {{{ ### compute for each strata and combine vstrata <- as.numeric(factor(data[,strata])) weights <- rep(1,nrow(data)) cweights <- rep(1,nrow(data)) tweights <- rep(1,nrow(data)) for (i in unique(vstrata)) { ## {{{ for each strata who <- (vstrata == i) if (sum(who) <= 1) stop(paste("strata",i,"less than 1 observation\n")); datas <- subset(data,who) entrytimes <- entry[who] if (!is.null(entrytime)) { surv.trunc <- survival::survfit(Surv(-datas[,time],-entrytimes+prec,rep(1,nrow(datas))) ~ +1) trunc.dist <- summary(surv.trunc) trunc.dist$time <- rev(-trunc.dist$time) trunc.dist$surv <- c(rev(trunc.dist$surv)[-1], 1) Lfit <-Cpred(cbind(trunc.dist$time,trunc.dist$surv),datas[,time],strict=TRUE) Lw <- Lfit[,2] } else {Lw <- 1; } if (!is.null(entrytime)) ud.cens<- survival::survfit(Surv(entrytimes,datas[,time],datas[,cause]==0)~+1) else ud.cens<- survival::survfit(Surv(entrytimes,datas[,time],datas[,cause]==0)~+1) Gfit<-cbind(ud.cens$time,ud.cens$surv) Gfit<-rbind(c(0,1),Gfit); Gcx<-Cpred(Gfit,pmin(mtt,datas[,time]),strict=TRUE)[,2]; weights[who]<- 1/(Lw*Gcx); cweights[who] <- Gcx; tweights[who] <- Lw; } ## }}} } ## }}} } else { ### cens.formula Cox models ## {{{ X <- model.matrix(cens.formula,data=data)[,-1,drop=FALSE]; if (!is.null(entrytime)) { ### trunc.model <- cox.aalen(Surv(-data[,time],-entrytime+prec,rep(1,nrow(data))) ~ prop(X)) trunc.model <- survival::coxph(Surv(-data[,time],-entrytime+prec,rep(1,nrow(data))) ~ X) ### baseout <- cens.model$cum baseout <- survival::basehaz(trunc.model,centered=FALSE); baseout <- cbind(rev(-baseout$time),rev(baseout$hazard)) ### Lfit <-Cpred(baseout,data[,time],strict=TRUE)[,-1] RR<-exp(as.matrix(X) %*% coef(trunc.model)) Lfit<-exp(-Lfit*RR) Lw <- Lfit } else {Lw <- 1; } ### if (!is.null(entrytime)) cens.model <- survival::coxph(Surv(entrytime,data[,time],data[,cause]==0)~+X) else cens.model <- survival::coxph(Surv(data[,time],data[,cause]==0)~+X) baseout <- survival::basehaz(cens.model,centered=FALSE); ### baseout <- cens.model$cum baseout <- cbind(baseout$time,baseout$hazard) Gfit<-Cpred(baseout,pmin(mtt,data[,time]),strict=TRUE)[,2]; RR<-exp(as.matrix(X) %*% coef(cens.model)) Gfit<-exp(-Gfit*RR) weights <- 1/(Lw*Gfit); cweights <- Gfit tweights <- Lw } ## }}} data[,weight.name] <- weights data[,"cw"] <- 1 if (!is.null(entrytime)) { mint <- min(tweights); maxt <- min(tweights) if (mint<0 | mint>1) warning("min(truncation weights) strange, maybe prec.factor should be different\n") if (maxt<0 | maxt>1) warning("max(truncation weights) strange, maybe prec.factor should be different\n") } if (!is.null(entrytime)) { attr(data,"trunc.model") <- trunc.model attr(data,"cens.model") <- cens.model } data[,cname] <- cweights data[,tname] <- tweights ## }}} observed <- ((data[,time]>mtt & data[,cause]==cens.code)) | (data[,cause]!=cens.code) data[,"observed."] <- observed if (same.cens & is.null(cluster)) message("no cluster for same-cens given \n"); if (same.cens & !is.null(cluster)) { ## {{{ ### message("Minimum weights.cens..") ### message("Maximum weights.trunc..") myord <- order(data[,cluster]) data <- data[myord,,drop=FALSE] id <- table(data[,cluster]) observed <- ((data[,time]>mtt & data[,cause]==cens.code)) | (data[,cause]!=cens.code) d0 <- data[,c(cluster,cname,tname,time,cause,strata)] noncens <- observed d0[,"observed."] <-observed timevar <- paste("_",cluster,cname,sep="") d0[,timevar] <- unlist(lapply(id,seq)) ### print(head(d0)) ### Wide <- reshape(d0,direction="wide",timevar=timevar,idvar=cluster) Wide <- fast.reshape(d0,id=cluster) ### censoring same cens cause1 <- paste(cause,"1",sep=""); cause2 <- paste(cause,"2",sep="") obs1 <- "observed.1"; obs2 <- "observed.2" time1 <- paste(time,"1",sep=""); time2 <- paste(time,"1",sep="") ### print(c(time1,time2,cause1,cause2)) ### print(head(Wide)) ### tmax <- apply(Wide[,paste(time,1:2,sep="")],1, ### function(x) max(x)) ## NA when there is just one ### maxstat <- ifelse(Wide[,time1]> Wide[,time2],Wide[,cause1],Wide[,cause2]) ### obsstat <- ifelse(Wide[,time1]> Wide[,time2],Wide[,obs1],Wide[,obs2])*1 ### print(head(tmax,10)); print(head(maxstat,10)) ### print(names(Wide)) ### datp <- data.frame(time=tmax,cause=obsstat,strata=Wide[,paste(strata,"1",sep="")]) ### print(head(datp)) ### datp <- pred.stratKM(datp) ### print(head(tmax,datp)) ### ### ud.cens<- survival::survfit(Surv(tmax,obsstat==0)~+1) ### Gfit<-cbind(ud.cens$time,ud.cens$surv) ### Gfit<-rbind(c(0,1),Gfit); ### tmaxna <- tmax; tmaxna[is.na(tmax)] <- 0 ### Gcx<-Cpred(Gfit,pmin(mtt,tmaxna),strict=TRUE)[,2]; ### Wd <- Gcx ### ### data[,"tmax"] <- rep(tmax,id) ### data[,"stattmax"] <- rep(maxstat,id) W <- apply(Wide[,paste(cname,1:2,sep="")],1, function(x) min(x)) ## NA when there is just one ### function(x) min(x,na.rm=TRUE)) Wmin <- rep(W,id) data[,pair.cweight] <- 1/Wmin ### data[,paste(pair.cweight,"max",sep="")] <- 1/rep(Wd,id) ### when pair-weight is NA takes individual weight naW <- is.na(Wmin) data[naW,pair.cweight] <- 1/data[naW,cname] data[naW,paste(pair.cweight,"max",sep="")] <- 1/data[naW,cname] ### truncation same truncation if (!is.null(entrytime)) { Wt <- apply(Wide[,paste(tname,1:2,sep="")],1, function(x) min(x)) ## NA when there is just one ### Wtmarg <- d0[,tname] ### data[,pair.tweight] <- 0; ##1/Wtmarg Wtmax <- rep(Wt,id) data[,pair.tweight] <- 1/Wtmax ### when pair-weight is NA takes individual weight naW <- is.na(Wtmax) data[naW,pair.tweight] <- 1/data[naW,tname] } if (!is.null(entrytime)) { data[,pair.weight] <- data[,pair.cweight]*data[,pair.tweight] } else data[,pair.weight] <- data[,pair.cweight] } ## }}} if (obs.only) { data <- data[observed,] } id <- table(data[,cluster]) if (pairs) { gem <- data[,cluster]%in%(names(id)[id==2]) id <- id[id==2] data <- data[gem,] } else data[,"pairs."] <- data[,cluster]%in%(names(id)[id==2]) return(data) } ## }}} mets/R/jumptimes.R0000644000176200001440000000244713623061405013572 0ustar liggesusers##' @export jumptimes <- function(time, status=TRUE, id,cause, sample,sample.all=TRUE, strata=NULL,num=NULL, ...) { if (missing(id)) { time <- if (missing(cause)) time[status>0] else time[status==cause] } else { ww <- na.omit(fast.reshape(cbind(time=time,status=status),id=id,num=num)) statusvar <- grep("status",colnames(ww)) timevar <- grep("time",colnames(ww)) if (missing(cause)) { idx <- which(rowSums(ww[,statusvar]>0)==length(statusvar)) } else { idx <- which(apply(as.matrix(ww[,statusvar]),1,function(x) all(x==cause))) } time <- na.omit(do.call(pmax,as.list(ww[idx,timevar]))) } if (!missing(sample) && sample1]<-1; Gcx[Gcx<0]<-0 Gfit<-rbind(c(0,1),cbind(time,Gcx)); if (is.null(entry.call)==FALSE) { Gcxe<-Cpred(Gfit,entry)[,-1]; Gcxe<-exp(-apply(Gcxe*XZ,1,sum)) Gcxe[Gcxe>1]<-1; Gcxe[Gcxe<0]<-0 } Gcx <- Gcx/Gcxe; ### Gctimes<-Cpred(Gfit,times)[,2]; Gctimes<- Gcx ## }}} } } else { Gcx <- cens.weight; Gctimes <- cens.weight;} } else { Gcx <- censoring.weights Gctimes <- cens.weight } ntimes<-length(times); ## }}} ## {{{ set up cluster + theta design + define iid variables if (is.null(clusters)== TRUE) { ## take clusters from cif model clusters <- attr(cif,"clusters"); antclust<- length(unique(clusters)); max.clust <- attr(cif,"max.clust") if (attr(cif,"coarse.clust")) stop("Max.clust should be NULL in marginal model, or clusters should be given at call \n"); } else { clus<-unique(clusters); antclust<-length(clus); clusters <- as.integer(factor(clusters, labels = 1:(antclust)))-1; } outc <- cluster.index(clusters,index.type=TRUE); clustsize <- outc$cluster.size maxclust <- outc$maxclust clusterindex <- outc$idclust if (maxclust==1) stop("No clusters given \n"); if (model!="ARANCIF") { if (is.null(theta.des)==TRUE) { ptheta<-1; theta.des<-matrix(1,antpers,ptheta); colnames(theta.des) <- "intercept"; } else theta.des<-as.matrix(theta.des); ptheta<-ncol(theta.des); if (is.null(dimpar) & is.null(par.func)) dimpar<-ptheta; } if (model=="ARANCIF") { ### different parameters for Additive random effects if (is.null(random.design)) random.design <- matrix(1,antpers,1); dim.rv <- ncol(random.design); if (is.null(theta.des)==TRUE) theta.des<-diag(dim.rv); dimpar <- ncol(theta.des); if (nrow(theta.des)!=ncol(random.design)) stop("nrow(theta.des)!= ncol(random.design)"); ### score.method <- "nlminb"; ### force nlminb because derivatives are not working } else random.design <- matrix(0,1,1); if ( (!is.null(par.func)) && is.null(dimpar) ) stop("Must specify dimension of parameters when specifying R-functions\n") if ( (is.null(theta)==TRUE) && (model=="ARANCIF")) theta<-rep(0.5,dimpar); if (is.null(theta)==TRUE) theta<-rep(0.1,dimpar); if (length(theta)!=dimpar) theta<-rep(theta[1],dimpar); Biid<-c(); gamma.iid <- 0; B2iid<-c(); gamma2.iid <- 0; if (notaylor==0) { for (i in 1:antclust) Biid<-cbind(Biid,cif$B.iid[[i]]); if (npar==TRUE) gamma.iid<-0 else gamma.iid<-cif$gamma.iid; if ((model!="COR") && (cause1!=cause2)) { B2iid<-c() for (i in 1:antclust) B2iid<-cbind(B2iid,cif2$B.iid[[i]]); if (npar2==TRUE) gamma2.iid<-0 else gamma2.iid<-cif2$gamma.iid; } else { B2iid<-Biid; gamma2.iid<-gamma.iid; } } var.theta<-hess<-matrix(0,dimpar,dimpar); score<-rep(0,dimpar); time.pow<-attr(cif,"time.pow"); #if (sum(time.pow)==0) time.pow<-rep(1,pg); theta.iid<-matrix(0,antclust,dimpar); if ((nrow(theta.des)!=nrow(X)) && (model!="ARANCIF")) stop("Dependence design not consistent with data\n"); if (length(trunkp)!=antpers) trunkp <- rep(1,antpers) if (is.null(weights)==TRUE) weights <- rep(1,antpers); ## }}} ### ## {{{ function and derivative if (is.null(par.func)==FALSE) { flex.func<-1; # use flexible design if (is.null(dpar.func)) { cat("Must provide derivative that is used for iid decomposition for SE's\n"); score.method <- "nlminb" dpar.func <- par.func } ### if (score.method=="fisher.scoring") ### cat("Score.method set to nlminb for flexible modelling \n"); } ## }}} Zgamma <- c(Z %*% gamma); Z2gamma2 <- c(Z2 %*% gamma2); dep.model <- 0; dep.model <- switch(model,COR=1,RR=2,OR=3,RANCIF=4,ARANCIF=5) if (dep.model==0) stop("model must be COR, OR, RR, RANCIF, ARANCIF \n"); if (dep.model<=4) rvdes <- matrix(0,1,1); ### if (dep.model==4 & !is.null(cif2) ) dep.model <- 6 ## two cause random cif ### if (dep.model==6) stop("Different causes under development \n"); obj <- function(par) { ## {{{ if (is.null(par.func)==TRUE) { Xtheta <- theta.des %*% par; DXtheta <- array(0,c(1,1,1)); } else { Xtheta <- c(); DXtheta <- array(0,c(length(times),antpers,dimpar)); if (is.null(dpar.func)) stop("Must also provide derivative of function wrt to parameters") s <- 0 for (t in times) { s <- 1+s Xttheta <- par.func(par,t,theta.des) if (length(Xttheta)!=antpers) stop("parfunc(par,t,theta.des) must length n"); Xtheta <- cbind(Xtheta,Xttheta) Dttheta <- dpar.func(par,t,theta.des); if (dim(Dttheta)[1]!=antpers || dim(Dttheta)[2]!=dimpar) stop("dparfunc must return matrix n x dimpar when called on dparfunc(par,t,theta.des)"); DXtheta[s,,] <- Dttheta } ### print(dim(Xtheta)); print(dim(DXtheta)) } outl<-.Call("cor", ## {{{ itimes=times,iy=time,icause=cause,iCA1=cause1,iKMc=Gcx, iz=X,iest=matrix(est[,-1],ncol=ncol(est)-1),iZgamma=c(Zgamma),isemi=semi,izsem=Z, itheta=c(par),iXtheta=Xtheta,iDXtheta=DXtheta,idimDX=dim(DXtheta), ithetades=theta.des, icluster=clusters,iclustsize=clustsize,iclusterindex=clusterindex, iinverse=inverse,iCA2=cause2, ix2=X2,isemi2=semi2,iest2=as.matrix(est2[,-1]),iZgamma2=c(Z2gamma2), iflexfunc=flex.func,iiid=iid,isym=sym,iweights=weights, isamecens=as.numeric(same.cens),istabcens=as.numeric(stab.cens), iKMtimes=Gctimes,isilent=silent, icifmodel=cif.model,idepmodel=dep.model, iestimator=estimator,ientryage=entry,icif1entry=cif1entry, icif2entry=cif2entry,itrunkp=trunkp,irvdes=random.design, ## Biid,gamma.iid,time.pow, ## B2iid,gamma2.iid,body(htheta),body(dhtheta),new.env(), PACKAGE="mets" ) ## }}} attr(outl,"gradient") <-outl$score if (oout==0) return(outl$ssf) else if (oout==1) return(sum(outl$score^2)) else return(outl) } ## }}} p <- theta iid <- 0; ###no-iid representation for iterations if (score.method=="fisher.scoring") { ## {{{ oout <- 2; ### output control for obj if (Nit>0) for (i in 1:Nit) { oout <- 2 out <- obj(p) hess <- out$Dscore if (!is.na(sum(hess))) hessi <- lava::Inverse(out$Dscore) else hessi <- hess if (detail==1) {## {{{ print(paste("Fisher-Scoring ===================: it=",i)); cat("theta:");print(c(p)) cat("score:");print(c(out$score)); cat("hess:"); print(hess); }## }}} delta <- hessi %*% out$score ### for test purposes ### oout <- 0; ### output control for obj ### score1 <- numDeriv::jacobian(obj,p) ### hess1 <- numDeriv::hessian(obj,p) ### print(score1) ### print(hess1) ## do not update last iteration if (i20) { cat("NR increment > 20, lower step zize, increment= \n"); cat(delta); break; } } if (!is.nan(sum(p))) { ## {{{ iid decomposition oout <- 2 theta <- p iid <- 1; out <- obj(p) score <- out$score hess <- out$Dscore } ## }}} if (detail==1 & Nit==0) {## {{{ print(paste("Fisher-Scoring ===================: final")); cat("theta:");print(c(p)) cat("score:");print(c(out$score)); cat("hess:"); print(hess); ### oout <- 0; hess1 <- numDeriv::hessian(obj,p); print(hess1) }## }}} if (!is.na(sum(hess))) hessi <- lava::Inverse(out$Dscore) else hessi <- diag(nrow(hess)) ### score1 <- numDeriv::jacobian(obj,p) score1 <- score; ## }}} } else if (score.method=="nlminb") { ## {{{ nlminb optimizer iid <- 0; oout <- 0; tryCatch(opt <- nlminb(theta,obj,control=control),error=function(x) NA) if (detail==1) print(opt); iid <- 1; hess <- numDeriv::hessian(obj,opt$par) score <- numDeriv::jacobian(obj,opt$par) hessi <- lava::Inverse(hess); theta <- opt$par if (detail==1) cat("iid decomposition\n"); oout <- 2; out <- obj(opt$par) score1 <- out$score ## }}} } else if (score.method=="nlm") { ## {{{ nlm optimizer iid <- 0; oout <- 0; tryCatch(opt <- nlm(obj,theta,hessian=TRUE,print.level=detail),error=function(x) NA) iid <- 1; hess <- opt$hessian score <- opt$gradient if (detail==1) print(opt); hessi <- lava::Inverse(hess); theta <- opt$estimate if (detail==1) cat("iid decomposition\n"); oout <- 2; out <- obj(opt$estimate) score1 <- out$score ## }}} } else stop("score.methods = nlm nlminb fisher.scoring\n"); theta.iid <- out$theta.iid %*% hessi if (is.null(par.func)) var.theta <- t(theta.iid) %*% theta.iid else var.theta <- hessi var.theta <- t(theta.iid) %*% theta.iid if (is.null(par.func)) thetanames <- colnames(theta.des) else thetanames <- rep("R-func",dimpar) ud <- list(theta=theta,score=score,hess=hess,hessi=hessi,var.theta=var.theta, theta.iid=theta.iid,score1=c(score1),thetanames=thetanames, brierscore=out$ssf,p11=out$p11); if (dep.model<=3) class(ud)<-"cor" else if (dep.model==4) class(ud) <- "randomcif" else if (dep.model==6) class(ud) <- "randomcif" else if (dep.model==5) class(ud) <- "randomcifrv" attr(ud, "Formula") <- formula attr(ud, "Clusters") <- clusters attr(ud,"cause1")<-cause1; attr(ud,"cause2")<-cause2 attr(ud,"sym")<-sym; attr(ud,"inverse")<-inverse; attr(ud,"antpers")<-antpers; attr(ud,"antclust")<-antclust; attr(ud,"var.link")<-var.link; if (dep.model==4) attr(ud, "Type") <- "randomcif" if (dep.model==6) attr(ud, "Type") <- "randomcif" if (model=="COR") attr(ud, "Type") <- "cor" if (model=="RR") attr(ud, "Type") <- "RR" if (model=="OR") attr(ud, "Type") <- "OR-cif" if (dep.model==5) attr(ud, "pardes") <- theta.des if (dep.model==5) attr(ud, "rv1") <- random.design[1,] return(ud); } ## }}} ###mysolve <- function(A) ###{ ### ee <- eigen(A); ### threshold <- 1e-12 ### idx <- ee$values>threshold ### ee$values[idx] <- 1/ee$values[idx]; ### if (!all(idx)) ### ee$values[!idx] <- 0 ### V <- with(ee, vectors%*%diag(values)%*%t(vectors)) ### return(V) ###} ##' Fits a parametric model for the log-cross-odds-ratio for the ##' predictive effect of for the cumulative incidence curves for \eqn{T_1} ##' experiencing cause i given that \eqn{T_2} has experienced a cause k : ##' \deqn{ ##' \log(COR(i|k)) = h(\theta,z_1,i,z_2,k,t)=_{default} \theta^T z = ##' } ##' with the log cross odds ratio being ##' \deqn{ ##' COR(i|k) = ##' \frac{O(T_1 \leq t,cause_1=i | T_2 \leq t,cause_2=k)}{ ##' O(T_1 \leq t,cause_1=i)} ##' } ##' the conditional odds divided by the unconditional odds, with the odds ##' being, respectively ##' \deqn{ ##' O(T_1 \leq t,cause_1=i | T_2 \leq t,cause_1=k) = ##' \frac{ ##' P_x(T_1 \leq t,cause_1=i | T_2 \leq t,cause_2=k)}{ ##' P_x((T_1 \leq t,cause_1=i)^c | T_2 \leq t,cause_2=k)} ##' } ##' and ##' \deqn{ ##' O(T_1 \leq t,cause_1=i) = ##' \frac{P_x(T_1 \leq t,cause_1=i )}{P_x((T_1 \leq t,cause_1=i)^c )}. ##' } ##' Here \eqn{B^c} is the complement event of \eqn{B}, ##' \eqn{P_x} is the distribution given covariates ##' (\eqn{x} are subject specific and \eqn{z} are cluster specific covariates), and ##' \eqn{h()} is a function that is the simple identity ##' \eqn{\theta^T z} by default. ##' ##' The OR dependence measure is given by ##' \deqn{ ##' OR(i,k) = ##' \log ( ##' \frac{O(T_1 \leq t,cause_1=i | T_2 \leq t,cause_2=k)}{ ##' O(T_1 \leq t,cause_1=i) | T_2 \leq t,cause_2=k)} ##' } ##' This measure is numerically more stabile than the COR measure, and is symetric in i,k. ##' ##' The RR dependence measure is given by ##' \deqn{ ##' RR(i,k) = ##' \log ( ##' \frac{P(T_1 \leq t,cause_1=i , T_2 \leq t,cause_2=k)}{ ##' P(T_1 \leq t,cause_1=i) P(T_2 \leq t,cause_2=k)} ##' } ##' This measure is numerically more stabile than the COR measure, and is symetric in i,k. ##' ##' The model is fitted under symmetry (sym=1), i.e., such that it is assumed ##' that \eqn{T_1} and \eqn{T_2} can be interchanged and leads to ##' the same cross-odd-ratio (i.e. ##' \eqn{COR(i|k) = COR(k|i))}, ##' as would be expected for twins ##' or without symmetry as might be the case with mothers and daughters (sym=0). ##' ##' \eqn{h()} may be specified as an R-function of the parameters, ##' see example below, but the default is that it is simply \eqn{\theta^T z}. ##' ##' @title Cross-odds-ratio, OR or RR risk regression for competing risks ##' @aliases or.cif rr.cif ##' @param cif a model object from the comp.risk function with the ##' marginal cumulative incidence of cause1, i.e., the event of interest, and whose ##' odds the comparision is compared to the conditional odds given cause2 ##' @param data a data.frame with the variables. ##' @param cause specifies the causes related to the death ##' times, the value cens.code is the censoring value. When missing it comes from marginal cif. ##' @param times time-vector that specifies the times used for the estimating euqations for the cross-odds-ratio estimation. ##' @param cause1 specificies the cause considered. ##' @param cause2 specificies the cause that is conditioned on. ##' @param cens.code specificies the code for the censoring if NULL then uses the one from the marginal cif model. ##' @param cens.model specified which model to use for the ICPW, KM is Kaplan-Meier alternatively it may be "cox" ##' @param Nit number of iterations for Newton-Raphson algorithm. ##' @param detail if 0 no details are printed during iterations, if 1 details are given. ##' @param clusters specifies the cluster structure. ##' @param theta specifies starting values for the cross-odds-ratio parameters of the model. ##' @param theta.des specifies a regression design for the cross-odds-ratio parameters. ##' @param step specifies the step size for the Newton-Raphson algorithm. ##' @param sym specifies if symmetry is used in the model. ##' @param weights weights for estimating equations. ##' @param par.func parfunc ##' @param dpar.func dparfunc ##' @param dimpar dimpar ##' @param score.method "nlminb", can also use "fisher-scoring". ##' @param same.cens if true then censoring within clusters are assumed to be the same variable, default is independent censoring. ##' @param censoring.weights these probabilities are used for the bivariate censoring dist. ##' @param silent 1 to suppress output about convergence related issues. ##' @param ... Not used. ##' @return returns an object of type 'cor'. With the following arguments: ##' \item{theta}{estimate of proportional odds parameters of model.} ##' \item{var.theta}{variance for gamma. } ##' \item{hess}{the derivative of the used score.} ##' \item{score}{scores at final stage.} ##' \item{score}{scores at final stage.} ##' \item{theta.iid}{matrix of iid decomposition of parametric effects.} ##' @author Thomas Scheike ##' @references ##' Cross odds ratio Modelling of dependence for ##' Multivariate Competing Risks Data, Scheike and Sun (2012), Biostatistics. ##' ##' A Semiparametric Random Effects Model for Multivariate Competing Risks Data, ##' Scheike, Zhang, Sun, Jensen (2010), Biometrika. ##' @examples ##' library("timereg") ##' data(multcif); ##' multcif$cause[multcif$cause==0] <- 2 ##' zyg <- rep(rbinom(200,1,0.5),each=2) ##' theta.des <- model.matrix(~-1+factor(zyg)) ##' ##' times=seq(0.05,1,by=0.05) # to speed up computations use only these time-points ##' add<-comp.risk(Event(time,cause)~+1+cluster(id),data=multcif,cause=1, ##' n.sim=0,times=times,model="fg",max.clust=NULL) ##' add2<-comp.risk(Event(time,cause)~+1+cluster(id),data=multcif,cause=2, ##' n.sim=0,times=times,model="fg",max.clust=NULL) ##' ##' out1<-cor.cif(add,data=multcif,cause1=1,cause2=1) ##' summary(out1) ##' ##' out2<-cor.cif(add,data=multcif,cause1=1,cause2=1,theta.des=theta.des) ##' summary(out2) ##' ##' ##out3<-cor.cif(add,data=multcif,cause1=1,cause2=2,cif2=add2) ##' ##summary(out3) ##' ########################################################### ##' # investigating further models using parfunc and dparfunc ##' ########################################################### ##' \donttest{ ## Reduce Ex.Timings ##' set.seed(100) ##' prt<-simnordic.random(2000,cordz=2,cormz=5) ##' prt$status <-prt$cause ##' table(prt$status) ##' ##' times <- seq(40,100,by=10) ##' cifmod <- comp.risk(Event(time,cause)~+1+cluster(id),data=prt, ##' cause=1,n.sim=0, ##' times=times,conservative=1,max.clust=NULL,model="fg") ##' theta.des <- model.matrix(~-1+factor(zyg),data=prt) ##' ##' parfunc <- function(par,t,pardes) ##' { ##' par <- pardes %*% c(par[1],par[2]) + ##' pardes %*% c( par[3]*(t-60)/12,par[4]*(t-60)/12) ##' par ##' } ##' head(parfunc(c(0.1,1,0.1,1),50,theta.des)) ##' ##' dparfunc <- function(par,t,pardes) ##' { ##' dpar <- cbind(pardes, t(t(pardes) * c( (t-60)/12,(t-60)/12)) ) ##' dpar ##' } ##' head(dparfunc(c(0.1,1,0.1,1),50,theta.des)) ##' ##' names(prt) ##' or1 <- or.cif(cifmod,data=prt,cause1=1,cause2=1,theta.des=theta.des, ##' same.cens=TRUE,theta=c(0.6,1.1,0.1,0.1), ##' par.func=parfunc,dpar.func=dparfunc,dimpar=4, ##' score.method="fisher.scoring",detail=1) ##' summary(or1) ##' ##' cor1 <- cor.cif(cifmod,data=prt,cause1=1,cause2=1,theta.des=theta.des, ##' same.cens=TRUE,theta=c(0.5,1.0,0.1,0.1), ##' par.func=parfunc,dpar.func=dparfunc,dimpar=4, ##' control=list(trace=TRUE),detail=1) ##' summary(cor1) ##' ##' ### piecewise contant OR model ##' gparfunc <- function(par,t,pardes) ##' { ##' cuts <- c(0,80,90,120) ##' grop <- diff(t0.001) warning("WARNING: check score for convergence\n") coefs <- coef(object,...) ocasewise <- oconcordance <- NULL if (is.null(marg.cif)==FALSE) { ## {{{ time <- marg.cif$time marg.cif <- marg.cif$P1 if (is.null(marg.cif2)==FALSE) marg.cif2 <- marg.cif2$P1 else { if (attr(object,"cause2")==attr(object,"cause1")) marg.cif2 <- marg.cif else stop("causes not the same and second marginal cif not given\n"); } pmarg.cif <- marg.cif*marg.cif2 thetav <- coefs[,1] thetavl <- thetav-1.96*coefs[,2] thetavu <- thetav+1.96*coefs[,2] namev <- object$thetanames if (is.null(namev)) namev <- paste("name",1:length(thetav),sep="") ocasewise <- oconcordance <- list() k <- 0 for (theta in thetav) { k <- k+1 thetal <- thetavl[k]; thetau <- thetavu[k] if (attr(object,"Type")=="cor") { ## {{{ concordance <- exp(theta)*pmarg.cif/((1-marg.cif)+exp(theta)*marg.cif) conclower <- exp(thetal)*pmarg.cif/((1-marg.cif)+exp(thetal)*marg.cif) concup <- exp(thetau)*pmarg.cif/((1-marg.cif)+exp(thetau)*marg.cif) casewise <- concordance/marg.cif caselower <- conclower/marg.cif caseup <- concup/marg.cif } else if (attr(object,"Type")=="RR") { casewise<- exp(coefs[,1])*c(marg.cif) concordance <- exp(coefs[,1])*pmarg.cif caselower <- marg.cif*exp(thetal) caseup <- marg.cif*exp(thetau) conclower <- pmarg.cif* exp(thetal) concup <- pmarg.cif*exp(thetau) } else if (attr(object,"Type")=="OR-cif") { casewise<- plack.cif2(marg.cif,marg.cif,c(theta))/marg.cif concordance <- plack.cif2(marg.cif,marg.cif,c(theta)) caselower <- plack.cif2(marg.cif,marg.cif,thetal)/marg.cif caseup <- plack.cif2(marg.cif,marg.cif,thetau)/marg.cif conclower <- plack.cif2(marg.cif,marg.cif,thetal) concup <- plack.cif2(marg.cif,marg.cif,thetau) } else if (attr(object,"Type")=="randomcif") { theta <- 1/theta thetal <- 1/thetal thetau <- 1/thetau lam <- 1-marg.cif p11<- 1-lam -lam +lap(theta,2*ilap(theta, lam)) concordance <- p11 conclower <- 1-lam -lam +lap(thetal,2*ilap(thetal, lam)) concup <- 1-lam -lam +lap(thetau,2*ilap(thetau, lam)) casewise <- concordance/marg.cif caselower <- conclower/marg.cif caseup <- concup/marg.cif } ## }}} outcase <- cbind(time,casewise,caselower,caseup) outconc <- cbind(time,concordance,conclower,concup) ### rownames(outcase) <- rownames(outconc) <- rownames(coefs) colnames(outcase) <- c("time","casewise concordance","2.5 %","97.5%") colnames(outconc) <- c("time","concordance","2.5 %","97.5%") if (length(thetav)==1) { ocasewise <- outcase oconcordance <- outconc } else { ocasewise[[k]] <- outcase oconcordance[[k]] <- outconc } } if (length(thetav)>1) { if (length(ocasewise)==length(namev)) { names(ocasewise) <- namev names(oconcordance) <- namev } } } ## }}} res <- list(casewise=ocasewise,concordance=oconcordance,estimates=coefs, marg.cif=marg.cif, marg.cif2=marg.cif2,type=attr(object,"Type"), sym=attr(object,"sym"),cause1=attr(object,"cause1"),cause2=attr(object,"cause2")) class(res) <- "summary.cor" res } ## }}} ##' @export coef.cor <- function(object,...) { ## {{{ res <- cbind(object$theta, diag(object$var.theta)^0.5) se<-diag(object$var.theta)^0.5 wald <- object$theta/se waldp <- (1 - pnorm(abs(wald))) * 2 cor<-exp(object$theta) res <- as.matrix(cbind(res, wald, waldp,cor,se*cor)) if (attr(object,"Type")=="cor") colnames(res) <- c("log-Coef.", "SE", "z", "P-val","Cross odds ratio","SE") else colnames(res) <- c("log-ratio Coef.", "SE", "z", "P-val","Ratio","SE") if (!is.null(object$thetanames)) rownames(res)<-object$thetanames return(res) } ## }}} ##' @export print.cor<-function(x,digits=3,...) { ## {{{ print(x$call); cat("\n") print(summary(x)); } ## }}} ##' @export concordance.cor <- function(object,...) { concordanceCor(object,...) } ##' Concordance for Twins ##' ##' The concordance is the probability that both twins have experienced the ##' event of interest and is defined as ##' \deqn{ ##' cor(t) = P(T_1 \leq t, \epsilon_1 =1 , T_2 \leq t, \epsilon_2=1) ##' } ##' ##' Similarly, the casewise concordance is ##' \deqn{ ##' casewise(t) = \frac{cor(t)}{P(T_1 \leq t, \epsilon_1=1) } ##' } ##' that is the probability that twin "2" has the event given that twins "1" has. ##' ##' @title Concordance Computes concordance and casewise concordance ##' @param object Output from the cor.cif, rr.cif or or.cif function ##' @param cif1 Marginal cumulative incidence ##' @param cif2 Marginal cumulative incidence of other cause (cause2) if it is different from cause1 ##' @param messages To print messages ##' @param model Specfifies wich model that is considered if object not given. ##' @param coefs Specfifies dependence parameters if object is not given. ##' @param ... Extra arguments, not used. ##' @author Thomas Scheike ##' @aliases concordanceCor concordance.cor ##' @references ##' Estimating twin concordance for bivariate competing risks twin data ##' Thomas H. Scheike, Klaus K. Holst and Jacob B. Hjelmborg, ##' Statistics in Medicine 2014, 1193-1204 ##' ##' Estimating Twin Pair Concordance for Age of Onset. ##' Thomas H. Scheike, Jacob V B Hjelmborg, Klaus K. Holst, 2015 ##' in Behavior genetics DOI:10.1007/s10519-015-9729-3 ##' ##' @export concordanceCor <- function(object,cif1,cif2=NULL,messages=TRUE,model=NULL,coefs=NULL,...) { ## {{{ if (is.null(model)) { if (!inherits(object, "cor")) stop("Must be a rr.cif, cor.cif or or.cif object") model <- attr(object,"Type") } if (is.null(coefs)) coefs <- coef(object) if (is.null(coefs)) stop("Must give dependence parameters\n"); if (!is.null(object)) { cause1 <- attr(object,"cause1"); cause2 <- attr(object,"cause2"); } else cause1 <- cause2 <- 1 if (is.null(cif2)==TRUE) cif2 <- cif1; if (messages) { if (model=="cor") { ## {{{ message("Cross odds ratio dependence for competing risks\n\n") message("Odds of cause1=",cause1," given cause2=",cause2," relative to Odds of cause1=",cause1,"\n",fill=TRUE,sep="") } else if (model=="RR") { message("Ratio of joint and product of marginals for competing risks\n\n") message("Ratio of cumulative incidence for cause1=",cause1," and cause2=",cause2,sep=" ") } else if (model=="OR-cif") { message("OR for dependence for competing risks\n\n") message("OR of cumulative incidence for cause1=",cause1," and cause2=",cause2,sep=" ") } ## }}} } out <- list() for (k in 1:nrow(coefs)) { ## {{{ if (model=="cor") { concordance <- exp(coefs[k,1])*cif1*cif2/((1-cif1)+exp(coefs[k,1])*cif1) conclower <- exp(coefs[k,1]-1.96*coefs[k,2])*cif1*cif2/((1-cif1)+exp(coefs[k,1]-1.96*coefs[k,2])*cif1) concup <- exp(coefs[k,1]+1.96*coefs[k,2])*cif1*cif2/((1-cif1)+exp(coefs[k,1]+1.96*coefs[k,2])*cif1) casewise <- concordance/cif1 caselower <- conclower/cif1 caseup <- concup/cif1 } else if (model=="RR") { casewise<- exp(coefs[k,1])*c(cif2) concordance <- exp(coefs[k,1])*cif1*cif2 caselower <- cif2*exp(coefs[k,1]-1.96*coefs[k,2]) caseup <- cif2*exp(coefs[k,1]+1.96*coefs[k,2]) conclower <- cif1*cif2* exp(coefs[k,1]-1.96*coefs[k,2]) concup <- cif1*cif2*exp(coefs[k,1]+1.96*coefs[k,2]) } else if (model=="OR-cif") { thetal <- coefs[k,1]-1.96*coefs[k,2] thetau <- coefs[k,1]+1.96*coefs[k,2] casewise<- plack.cif2(cif1,cif2,c(coefs[k,1]))/cif1 concordance <- plack.cif2(cif1,cif2,c(coefs[k,1])) caselower <- plack.cif2(cif1,cif2,thetal)/cif1 caseup <- plack.cif2(cif1,cif2,thetau)/cif1 conclower <- plack.cif2(cif1,cif2,thetal) concup <- plack.cif2(cif1,cif2,thetau) } outcase <- cbind(c(casewise),c(caselower),c(caseup)) outconc <- cbind(c(concordance),c(conclower),c(concup)) colnames(outcase) <- c("casewise concordance","2.5 %","97.5%") colnames(outconc) <- c("concordance","2.5 %","97.5%") ## }}} out[[k]] <- list(concordance=outconc,casewise=outcase) names(out)[k] <- rownames(coefs)[k] ###k <- k+1 } return(out) } ## }}} ##' .. content for description (no empty lines) .. ##' ##' @title plack Computes concordance for or.cif based model, that is Plackett random effects model ##' @aliases plack.cif2 ##' @export ##' @param cif1 Cumulative incidence of first argument. ##' @param cif2 Cumulative incidence of second argument. ##' @param object or.cif object with dependence parameters. ##' @author Thomas Scheike plack.cif <- function(cif1,cif2,object) { ## {{{ coefs <- coef(object) theta <- exp(object$theta); cif1 <- c(cif1); cif2 <- c(cif2) cifs=cif1+cif2; valn=2*(theta-1); val1=(1+(theta-1)*(cifs))-( ((1+(theta-1)*cifs))^2-4*cif1*cif2*theta*(theta-1))^0.5; vali=cif1*cif2; valr <- vali; valr[valn!=0] <- val1/valn; valr <- matrix(valr,length(c(theta)),1) rownames(valr)=colnames(coefs) return(valr); } ## }}} ##' @export plack.cif2 <- function(cif1,cif2,theta) { ## {{{ theta <- exp(c(theta)) cif1 <- c(cif1); cif2 <- c(cif2) cifs=cif1+cif2; valn=2*(theta-1); val1=(1+(theta-1)*(cifs))-( ((1+(theta-1)*cifs))^2-4*cif1*cif2*theta*(theta-1))^0.5; vali=cif1*cif2; valr <- vali; valr[valn!=0] <- val1/valn; return(valr); } ## }}} ##' @export predictPairPlack <- function(cif1,cif2,status1,status2,theta) { ## {{{ theta <- exp(c(theta)) cif1 <- c(cif1); cif2 <- c(cif2) cifs=cif1+cif2; valn=2*(theta-1); val1=(1+(theta-1)*(cifs))-( ((1+(theta-1)*cifs))^2-4*cif1*cif2*theta*(theta-1))^0.5; vali=cif1*cif2; valr <- vali; valr[valn!=0] <- val1/valn; p11 <- valr; p10 <- cif1-p11 p01 <- cif2-p11 p00 <- 1- p10-p01-p11 # pred <- (status1==1)*(status2==1)*p11+ (status1==1)*(status2==0)*p10+ (status1==0)*(status2==1)*p01+ (status1==0)*(status2==0)*p00 return(pred); } ## }}} ##' @export summary.randomcif<-function (object, ...) { ## {{{ if (!inherits(object, "randomcif")) stop("Must be a random.cif object") cat("Random effect variance for variation due to clusters\n\n") cat("Cause", attr(object, "cause1"), "and cause", attr(object, "cause2"), fill = TRUE) cat("\n") if (sum(abs(object$score)) > 0.001) cat("WARNING: check score for convergence") cat("\n") coef.randomcif(object, ...) } ## }}} ##' @export coef.randomcif<- function (object, digits = 3, ...) { ## {{{ res <- cbind(object$theta, diag(object$var.theta)^0.5) se <- diag(object$var.theta)^0.5 wald <- object$theta/se waldp <- (1 - pnorm(abs(wald))) * 2 cor <- object$theta + 1 res <- as.matrix(cbind(res, wald, waldp, cor, se)) colnames(res) <- c("Coef.", "SE", "z", "P-val", "Cross odds ratio", "SE") if (!is.null(object$thetanames)) rownames(res)<-object$thetanames ### prmatrix(signif(res, digits)) return(res) } ## }}} ##' @export print.randomcif<- function (x , digits = 3, ...) { ## {{{ } ## }}} ##' @export summary.randomcifrv<-function (object, ...) { ## {{{ if (!inherits(object, "randomcifrv")) stop("Must be a random.cifrv object") cat("Random effect parameters for additive gamma random effects \n\n") cat("Cause", attr(object, "cause1"), "and cause", attr(object, "cause2"), fill = TRUE) cat("\n") if (sum(abs(object$score)) > 1e-06) cat("WARNING: check score for convergence") cat("\n") res <- coef.randomcifrv(object, ...) var.link <- attr(object,"var.link"); rv1 <- attr(object,"rv1"); theta.des <- attr(object,"pardes"); if (var.link==1) par <- theta.des %*% exp(object$theta) else par <- theta.des %*% object$theta if (var.link==1) { fp <- function(p){ res <- exp(p)/sum(rv1* (theta.des %*% exp(p))); return(res); } e <- lava::estimate(coef=object$theta,vcov=object$var.theta,f=function(p) fp(p)) pare <- lava::estimate(coef=object$theta,vcov=object$var.theta,f=function(p) exp(p)) res <- list(estimate=res,h=e,exppar=pare) } else { fp <- function(p) { p/sum(rv1* (theta.des %*% p)) } e <- lava::estimate(coef=object$theta,vcov=object$var.theta,f=function(p) fp(p)) res <- list(estimate=res,h=e) } res } ## }}} ##' @export coef.randomcifrv<- function (object, digits = 3, ...) { ## {{{ if (attr(object,"inverse")==1) elog <- 1 else elog <- 0; if (elog==1) theta <- exp(object$theta) else theta <- object$theta se <- diag(object$var.theta)^0.5 res <- cbind(object$theta, se) wald <- object$theta/se waldp <- (1 - pnorm(abs(wald))) * 2 res <- as.matrix(cbind(res, wald, waldp)) if (elog==0) colnames(res) <- c("Coef.", "SE", "z", "P-val") if (elog==1) res <- cbind(res,exp(object$theta), exp(object$theta)^2*se) if (elog==1) colnames(res) <- c("log-parameter","SE","z","P-val","exp(theta)","SE") if (!is.null(object$thetanames)) rownames(res)<-object$thetanames prmatrix(signif(res, digits)) ### cat("\n\n Random effect variances for gamma random effects \n\n") ### varpar <- theta/sum(theta)^2 ### res <- as.matrix(varpar); ### if (elog==0) { var.theta <- object$var.theta; ### df <- 0*var.theta; ### for (i in 1:nrow(var.theta)) ### df[i,] <- -theta[i]*2*theta; ### diag(df) <- diag(df)+sum(theta)^2 ### df <- df/sum(theta)^4 ### var.varpar <- df %*% var.theta %*% df ### } ### if (elog==1) { ### var.theta <- object$var.theta; ### var.varpar <- var.theta ### } ### res <- cbind(res,diag(var.varpar)^.5) ### colnames(res) <- c("variance","SE") ### if (is.null((rownames(res))) == TRUE) rownames(res) <- rep(" ", nrow(res)) ### prmatrix(signif(res, digits)) } ## }}} ##' @export print.randomcifrv<- function (x , digits = 3, ...) { ## {{{ summary(x, ...) } ## }}} ## summary.cor<-function(object,digits=3,marg.cif=NULL,...) ## { ## {{{ ## if (!inherits(object, "cor")) stop("Must be a cor.cif object") ## if (sum(abs(object$score))>0.001) warning("WARNING: check score for convergence\n") ## coefs <- coef.cor(object,...); ## outcase <- outconc <- NULL ## if (is.null(marg.cif)==FALSE) { ## marg.cif <- max(marg.cif) ## ## {{{ ## if (attr(object,"Type")=="cor") { ## concordance <- exp(coefs[,1])*marg.cif^2/((1-marg.cif)+exp(coefs[,1])*marg.cif) ## conclower <- exp(coefs[,1]-1.96*coefs[,2])*marg.cif^2/((1-marg.cif)+exp(coefs[,1]-1.96*coefs[,2])*marg.cif) ## concup <- exp(coefs[,1]+1.96*coefs[,2])*marg.cif^2/((1-marg.cif)+exp(coefs[,1]+1.96*coefs[,2])*marg.cif) ## casewise <- concordance/marg.cif ## caselower <- conclower/marg.cif ## caseup <- concup/marg.cif ## } else if (attr(object,"Type")=="RR") { ## casewise<- exp(coefs[,1])*c(marg.cif) ## concordance <- exp(coefs[,1])*marg.cif^2 ## caselower <- marg.cif*exp(coefs[,1]-1.96*coefs[,2]) ## caseup <- marg.cif*exp(coefs[,1]+1.96*coefs[,2]) ## conclower <- marg.cif^2* exp(coefs[,1]-1.96*coefs[,2]) ## concup <- marg.cif^2*exp(coefs[,1]+1.96*coefs[,2]) ## } else if (attr(object,"Type")=="OR-cif") { ## thetal <- coefs[,1]-1.96*coefs[,2] ## thetau <- coefs[,1]+1.96*coefs[,2] ## casewise<- plack.cif2(marg.cif,marg.cif,c(coefs[,1]))/marg.cif ## concordance <- plack.cif2(marg.cif,marg.cif,c(coefs[,1])) ## caselower <- plack.cif2(marg.cif,marg.cif,thetal)/marg.cif ## caseup <- plack.cif2(marg.cif,marg.cif,thetau)/marg.cif ## conclower <- plack.cif2(marg.cif,marg.cif,thetal) ## concup <- plack.cif2(marg.cif,marg.cif,thetau) ## } ## outcase <- cbind(casewise,caselower,caseup) ## outconc <- cbind(concordance,conclower,concup) ## rownames(outcase) <- rownames(outconc) <- rownames(coefs) ## colnames(outcase) <- c("casewise concordance","2.5 %","97.5%") ## colnames(outconc) <- c("concordance","2.5 %","97.5%") ## } ## ## }}} ## res <- list(casewise=outcase,concordance=outconc,estimates=coefs,marg=marg.cif,type=attr(object,"Type"),sym=attr(object,"sym"),cause1=attr(object,"cause1"),cause2=attr(object,"cause2")) ## class(res) <- "summary.cor" ## res ## } ## }}} ## coef.cor<-function(object,...) ## { ## {{{ ## res <- cbind(object$theta, diag(object$var.theta)^0.5) ## se<-diag(object$var.theta)^0.5 ## wald <- object$theta/se ## waldp <- (1 - pnorm(abs(wald))) * 2 ## cor<-exp(object$theta) ## res <- as.matrix(cbind(res, wald, waldp,cor,se*cor)) ## if (attr(object,"Type")=="cor") ## colnames(res) <- c("log-Coef.", "SE", "z", "P-val","Cross odds ratio","SE") ## else colnames(res) <- c("log-ratio Coef.", "SE", "z", "P-val","Ratio","SE") ## if (is.null((rownames(res)))==TRUE) rownames(res)<-rep(" ",nrow(res)) ## return(res) ## } ## }}} mets/R/summary.bptwin.R0000644000176200001440000002163113623061405014550 0ustar liggesusers##' @export summary.bptwin <- function(object,level=0.05,transform=FALSE,...) { logit <- function(p) log(p/(1-p)) tigol <- function(z) 1/(1+exp(-z)) dlogit <- function(p) 1/(p*(1-p)) dtigol <- function(z) tigol(z)^2*exp(-z) trnam <- " " vcoef1 <- paste("var(",c("A","C","D"),")",sep="") if (object$transform$invname!="") { vcoef1 <- paste(object$transform$invname,"(",vcoef1,")",sep="") } vcoef2 <- paste("atanh(", c(paste("rho)","MZ",sep=trnam), paste("rho)","DZ",sep=trnam)),sep="") idx1 <- na.omit(match(vcoef1,names(coef(object)))) idx2 <- na.omit(match(vcoef2,names(coef(object)))) CIs <- c() alpha <- level/2 CIlab <- paste(c(alpha*100,100*(1-alpha)),"%",sep="") V <- c() if (length(idx2)>0) { idx <- idx2 V <- vcov(object)[idx,idx] arho <- coef(object)[idx2[1:2]] mz <- multinomlogit(coef(object)[idx2[1]]); names(mz) <- c("U","E") dz <- multinomlogit(coef(object)[idx2[2]]); names(dz) <- c("U","E") cc <- tanh(arho) names(cc) <- c("Tetrachoric correlation MZ","Tetrachoric correlation DZ") corMZ <- cc[1]; corDZ <- cc[2] D <- diag(object$tr$dtr(arho)) h <- function(x) 2*(x[1]-x[2]) dh <- function(x) c(2,-2) i1 <- 1:2 corr <- NULL } if (length(idx1)>0) { idx <- idx1 V <- vcov(object)[idx,idx] ACD <- match(names(coef(object))[idx1],vcoef1) nn <- c(c("A","C","D")[ACD],"E") dzsc <- c(1/2,1,1/4)[ACD] pp <- coef(object)[idx1] cc <- multinomlogit(pp,object$transform$tr,object$transform$dtr); names(cc) <- nn D <- attributes(cc)$gradient vcovACDE <- (D%*%V%*%t(D)) if (transform) { cc2 <- logit(cc) D2 <- diag(dlogit(cc)) DD <- D2%*%D Vc2 <- DD%*%V%*%t(DD) CIs <- tigol(cc2%x%cbind(1,1)+diag(Vc2)^0.5%x%cbind(-1,1)*qnorm(1-alpha)) } else { CIs <- cbind(cc-qnorm(1-alpha)*sqrt(diag(vcovACDE)),cc+qnorm(1-alpha)*sqrt(diag(vcovACDE))) } K <- length(ACD) Ki <- seq_len(K) corMZ <- sum(cc[Ki]); corDZ <- sum(cc[Ki]*dzsc) i1 <- na.omit(match(c("D","A"),nn)) h <- function(x) sum(x) dh <- function(x) rep(1,length(i1)) ## dh <- function(x) { res <- rep(0,length(x)); res[i1] <- 1; res } ## h <- function(x) 2*(sum(x[i1])-sum(x[i1]*dzsc)) ## dh <- function(x) 2*(1-dzsc) } Vc <- D%*%V%*%t(D) datanh <- function(r) 1/(1-r^2) if (length(idx1)>0) { pp <- coef(object)[idx] b <- cbind(rep(1,K)) corMZ.sd <- (t(b)%*%Vc[Ki,Ki]%*%b)[1]^0.5 corDZ.sd <- (t(dzsc)%*%Vc[Ki,Ki]%*%dzsc)[1]^0.5 corr <- rbind(c(corMZ,corMZ.sd),c(corDZ,corDZ.sd)) zrho <- atanh(corr[,1]) zrho.var <- datanh(corr[,1])^2*corr[,2]^2 corr <- cbind(corr, tanh(zrho%x%cbind(1,1)+zrho.var^0.5%x%cbind(-1,1)*qnorm(1-alpha))) rownames(corr) <- c("MZ Tetrachoric Cor","DZ Tetrachoric Cor") } else { zrho <- atanh(cc) zrho.var <- datanh(cc)^2*diag(Vc) CIs <- tanh(zrho%x%cbind(1,1)+zrho.var^0.5%x%cbind(-1,1)*qnorm(1-alpha)) } newcoef <- rbind(cbind(cc,diag(Vc)^0.5,CIs),corr); ## CIs <- rbind(CIs,c(NA,NA),c(NA,NA)) ## newcoef <- cbind(newcoef,CIs) colnames(newcoef) <- c("Estimate","Std.Err",CIlab) H <- h(cc[i1]) hstd <- (t(dh(cc[i1]))%*%Vc[i1,i1]%*%dh(cc[i1]))^.5 if (!transform) { ci <- c(H-hstd*qnorm(1-alpha),H+hstd*qnorm(1-alpha)) } else { logith <- function(x) logit(h(x)) dlogith <- function(x) dlogit(h(x))*dh(x) Dlh <- dlogith(cc[i1]) sdlh <- (t(Dlh)%*%Vc[i1,i1]%*%(Dlh))[1]^0.5 suppressWarnings(ci <- tigol(logith(cc[i1]) + qnorm(1-alpha)*c(-1,1)*sdlh)) } rhoOS <- NULL if (object$OS) { rEst <- object$coef[nrow(object$coef),1] rSE <- object$coef[nrow(object$coef),2] rhoOS <- tanh(rbind(c(rEst,rEst+qnorm(1-alpha)*c(-1,1)*rSE))) colnames(rhoOS) <- c("Estimate",CIlab) if (length(idx1)==0) { rownames(rhoOS) <- "Tetrachoric correlation OS" } else { rownames(rhoOS) <- "Kinship OS" } } concordance <- conditional <- marg <- c() probs <- function(p,idx=1) { if (idx==0) { m <- p[1] ##else m <- p[length(object$midx0)+1] S <- object$SigmaFun(p) conc1 <- pmvn(upper=c(m,m),sigma=S[[1]]) conc2 <- pmvn(upper=c(m,m),sigma=S[[2]]) marg <- pnorm(m,sd=S[[1]][1,1]^0.5) return(logit((conc1-conc2)/(marg*(1-marg)))) } S <- (object$SigmaFun(p))[[idx]] m <- 0 if((object$npar$intercept==1 & idx==1) | object$eqmean) m <- p[1] else m <- p[length(object$midx0)+1] mu.cond <- function(x) m+S[1,2]/S[2,2]*(x-m) var.cond <- S[1,1]-S[1,2]^2/S[2,2] conc <- pmvn(upper=c(m,m),sigma=S) disconc <- pmvn(lower=c(-Inf,m),upper=c(m,Inf),sigma=S) marg <- pnorm(m,sd=S[1,1]^0.5) cond <- conc/marg discond <- disconc/(1-marg) logOR <- log(cond)-log(1-cond)-log(discond)+log(1-discond) lambdaR <- cond/marg c(logit(c(conc,cond,marg)),lambdaR,logOR) } mycoef <- coef(object) ## formals(probs) <- alist(p=,idx=0) ## hp <- probs(mycoef) ## Dhp <- numDeriv::grad(probs,mycoef) ## shp <- diag(t(Dhp)%*%vcov(object)%*%(Dhp))^0.5 formals(probs) <- alist(p=,idx=1) probMZ <- probs(mycoef) Dp0 <- numDeriv::jacobian(probs,mycoef) formals(probs) <- alist(p=,idx=2) probDZ <- probs(mycoef) Dp1 <- numDeriv::jacobian(probs,mycoef) sprobMZ <- diag((Dp0)%*%vcov(object)%*%t(Dp0))^0.5 sprobDZ <- diag((Dp1)%*%vcov(object)%*%t(Dp1))^0.5 probMZ <- cbind(probMZ,probMZ-qnorm(1-alpha)*sprobMZ,probMZ+qnorm(1-alpha)*sprobMZ) probMZ[1:3,] <- tigol(probMZ[1:3,]) probDZ <- cbind(probDZ,probDZ-qnorm(1-alpha)*sprobDZ,probDZ+qnorm(1-alpha)*sprobDZ) probDZ[1:3,] <- tigol(probDZ[1:3,]) rownames(probMZ) <- rownames(probDZ) <- c("Concordance","Casewise Concordance","Marginal","Rel.Recur.Risk","log(OR)") colnames(probMZ) <- colnames(probDZ) <- c("Estimate",CIlab) ## mu <- coef(object)[c(object$bidx0[1],object$bidx1[1])] ## Sigma <- list(object$Sigma0,object$Sigma1) ## for (i in 1:2) { ## conc <- function() ## mu.cond <- function(x) mu+Sigma[[i]][1,2]/Sigma[[i]][2,2]*(x-mu[i]) ## var.cond <- Sigma[[i]][1,1]-Sigma[[i]][1,2]^2/Sigma[[i]][2,2] ## cc0 <- pmvn(upper=c(mu[i],mu[i]),sigma=Sigma[[i]]) ## px <- pnorm(mu[i],sd=Sigma[[i]][2,2]^0.5) ## concordance <- c(concordance,cc0) ## marg <- c(marg,px) ## conditional <- c(conditional,cc0/px) ## } ## names(concordance) <- names(conditional) <- c("MZ","DZ") hval <- rbind(c(H,hstd,ci)); colnames(hval) <- c("Estimate","Std.Err",CIlab); if (hval[1]>1) hval[1,] <- c(1,NaN,NaN,NaN) ## hval <- rbind(hval, tigol(c(hp,NA,hp-qnorm(1-alpha)*shp,hp+qnorm(1-alpha)*shp))) rownames(hval) <- c("Broad-sense heritability")##,"Risk-scale Heritability") Nstr <- object$N nN <- ncol(object$N) ngroups <- ifelse(object$OS,3,2) postn <- "MZ/DZ"; if (object$OS) postn <- paste(postn,"OS",sep="/") npos <- seq(ngroups) Nstr <- cbind(paste(Nstr[npos],collapse="/"), paste(Nstr[npos+ngroups],collapse="/"), paste(Nstr[npos+2*ngroups],collapse="/")) rownames(Nstr) <- "" colnames(Nstr) <- unlist(lapply(strsplit(colnames(object$N)[(1:3)*ngroups],".",fixed=TRUE), function(x) paste(x[1], postn))) all <- rbind(hval[,c(1,3,4),drop=FALSE],newcoef[,c(1,3,4),drop=FALSE]) allprob <- rbind(probMZ,probDZ); rownames(allprob) <- c(paste("MZ",rownames(probMZ)),paste("DZ",rownames(probDZ))) all <- rbind(all,allprob) cc <- object$coef; cc[,2] <- diag(vcov(object))^.5; cc[,3] <- cc[,1]/cc[,2]; cc[,4] <- 2*(pnorm(abs(cc[,1]/cc[,2]),lower.tail=FALSE)) res <- list(heritability=hval, par=cc, probMZ=probMZ, probDZ=probDZ, Nstr=Nstr, rhoOS=rhoOS, coef=newcoef, all=all, vcov=vcov(object), AIC=AIC(object), time=attributes(object)$time, logLik=logLik(object)) ##, concordance=concordance, conditional=conditional) class(res) <- "summary.bptwin" res } ##' @export print.summary.bptwin <- function(x,digits = max(3, getOption("digits") - 2),...) { cat("\n") printCoefmat(x$par,digits=digits,...) cat("\n") ## x$Nstr <- x$Nstr[,which((colnames(x$Nstr)!="Complete MZ/DZ")),drop=FALSE] NN <- x$Nstr[,c(1,3),drop=FALSE]; colnames(NN)[1] <- gsub("Complete ","",colnames(NN)[1]) print(NN,quote=FALSE) cat("\n") cc <- rbind(x$coef[,-2,drop=FALSE],x$rhoOS) print(RoundMat(cc,digits=digits),quote=FALSE) cat("\nMZ:\n"); print(RoundMat(x$probMZ,digits=digits),quote=FALSE) cat("DZ:\n") print(RoundMat(x$probDZ,digits=digits),quote=FALSE) ## cat("\nConcordance (MZ; DZ):\t\t", x$concordance,"\n") ## cat("Case-wise concordance (MZ; DZ):\t", x$conditional,"\n\n") cat("\n") print(RoundMat(x$heritability[,-2,drop=FALSE],digits=digits),quote=FALSE) cat("\n") if (!is.null(x$time)) { cat("\n") cat("Event of interest before time ", x$time, "\n", sep="") } } mets/R/bptwin.R0000644000176200001440000005640413623061405013062 0ustar liggesusers##' Liability-threshold model for twin data ##' ##' @aliases bptwin twinlm.time bptwin.time ##' @title Liability model for twin data ##' @seealso \code{\link{twinlm}}, \code{\link{twinlm.time}}, \code{\link{twinlm.strata}}, \code{\link{twinsim}} ##' @param x Formula specifying effects of covariates on the response. ##' @param data \code{data.frame} with one observation pr row. In ##' addition a column with the zygosity (DZ or MZ given as a factor) of ##' each individual much be ##' specified as well as a twin id variable giving a unique pair of ##' numbers/factors to each twin pair. ##' @param id The name of the column in the dataset containing the twin-id variable. ##' @param zyg The name of the column in the dataset containing the ##' zygosity variable. ##' @param DZ Character defining the level in the zyg variable ##' corresponding to the dyzogitic twins. ##' @param group Optional. Variable name defining group for interaction analysis (e.g., gender) ##' @param num Optional twin number variable ##' @param weights Weight matrix if needed by the chosen estimator (IPCW) ##' @param biweight Function defining the bivariate weight in each cluster ##' @param strata Strata ##' @param messages Control amount of messages shown ##' @param control Control argument parsed on to the optimization routine. Starting values may be parsed as '\code{start}'. ##' @param type Character defining the type of analysis to be ##' performed. Should be a subset of "acde" (additive genetic factors, common ##' environmental factors, dominant ##' genetic factors, unique environmental factors). ##' @param eqmean Equal means (with type="cor")? ##' @param pairs.only Include complete pairs only? ##' @param stderr Should standard errors be calculated? ##' @param robustvar If TRUE robust (sandwich) variance estimates of the variance are used ##' @param p Parameter vector p in which to evaluate log-Likelihood and score function ##' @param indiv If TRUE the score and log-Likelihood contribution of each twin-pair ##' @param constrain Development argument ##' @param samecens Same censoring ##' @param allmarg Should all marginal terms be included ##' @param bound Development argument ##' @param varlink Link function for variance parameters ##' @param ... Additional arguments to lower level functions ##' @author Klaus K. Holst ##' @export ##' @examples ##' data(twinstut) ##' b0 <- bptwin(stutter~sex, ##' data=droplevels(subset(twinstut,zyg%in%c("mz","dz"))), ##' id="tvparnr",zyg="zyg",DZ="dz",type="ae") ##' summary(b0) bptwin <- function(x, data, id, zyg, DZ, group=NULL, num=NULL, weights=NULL, biweight=function(x) 1/min(x), strata=NULL, messages=1, control=list(trace=0), type="ace", eqmean=TRUE, pairs.only=FALSE, samecens=TRUE, allmarg=samecens&!is.null(weights), stderr=TRUE, robustvar=TRUE, p, indiv=FALSE, constrain, bound=FALSE, varlink, ...) { ###{{{ setup mycall <- match.call() formulaId <- unlist(Specials(x,"cluster")) formulaStrata <- unlist(Specials(x,"strata")) formulaSt <- paste("~.-cluster(",formulaId,")-strata(",paste(formulaStrata,collapse="+"),")") formula <- update(x,formulaSt) if (!is.null(formulaId)) { id <- formulaId mycall$id <- id } if (!is.null(formulaStrata)) strata <- formulaStrata mycall$formula <- formula if (!is.null(strata)) { dd <- split(data,interaction(data[,strata])) nn <- unlist(lapply(dd,nrow)) dd[which(nn==0)] <- NULL if (length(dd)>1) { fit <- lapply(seq(length(dd)),function(i) { if (messages>0) message("Strata '",names(dd)[i],"'") mycall$data <- dd[[i]] eval(mycall) }) res <- list(model=fit) res$strata <- names(res$model) <- names(dd) class(res) <- c("twinlm.strata","biprobit") res$coef <- unlist(lapply(res$model,coef)) res$vcov <- blockdiag(lapply(res$model,vcov.biprobit)) res$N <- length(dd) res$idx <- seq(length(coef(res$model[[1]]))) rownames(res$vcov) <- colnames(res$vcov) <- names(res$coef) return(res) } } ################################################## ### No strata if (is.null(control$method)) { if (!samecens & !is.null(weights)) { control$method <- "bhhh" } else { if (requireNamespace("ucminf",quietly=TRUE)) { control$method <- "gradient" } else control$method <- "nlminb" } } if (tolower(type)=="cor") type <- "u" if (length(grep("flex",tolower(type)))>0) { type <- "u"; eqmean <- FALSE } yvar <- paste(deparse(formula[[2]]),collapse="") data <- data[order(data[,id]),] idtab <- table(data[,id]) if (sum(idtab>2)) stop("More than two individuals with the same id ") ## suppressMessages(browser()) if (pairs.only) { data <- data[as.character(data[,id])%in%names(idtab)[idtab==2],] idtab <- table(data[,id]) } if (is.logical(data[,yvar])) data[,yvar] <- data[,yvar]*1 if (is.factor(data[,yvar])) data[,yvar] <- as.numeric(data[,yvar])-1 idx2 <- NULL if (missing(DZ)) { DZ <- levels(as.factor(data[,zyg]))[1] message("Using '",DZ,"' as DZ",sep="") } OS <- NULL OSon <- FALSE if (!is.null(OS)) { idx2 <- which(data[,zyg]==OS) OSon <- TRUE if (length(idx2)==0) { warning("No OS twins found") OSon <- FALSE } } idx1 <- which(data[,zyg]==DZ) ## DZ if (length(idx1)==0) stop("No DZ twins found") idx0 <- which(!(data[,zyg]%in%c(DZ,OS))) ## MZ if (length(idx1)==0) stop("No MZ twins found") zyg2 <- rep(1,nrow(data)); zyg2[idx0] <- 0; zyg2[idx2] <- 2 data[,zyg] <- zyg2 ## MZ=0, DZ=1, OS=2 ## time <- "time" ## while (time%in%names(data)) time <- paste(time,"_",sep="") ## data[,time] <- unlist(lapply(idtab,seq)) ## ff <- paste(as.character(formula)[3],"+", ## paste(c(id,zyg,weights,num),collapse="+")) ## ff <- paste("~",yvar,"+",ff) ##formula0 <- as.formula(ff) opt <- options(na.action="na.pass") ## Data <- model.matrix(formula0,data) Data <- cbind(model.matrix(formula,data),data[,c(yvar,id,zyg,weights,num)]) options(opt) ## rnames1 <- setdiff(colnames(Data),c(yvar,time,id,weights,zyg)) rnames1 <- setdiff(colnames(Data),c(yvar,id,weights,zyg,num)) nx <- length(rnames1) if (nx==0) stop("Zero design not allowed") bidx0 <- seq(nx) midx0 <- bidx0; midx1 <- midx0+nx dS0. <- rbind(rep(1,4),rep(1,4),rep(1,4)) ## MZ dS1. <- rbind(c(1,.5,.5,1),rep(1,4),c(1,.25,.25,1)) ## DZ dS2. <- rbind(c(1,0,0,1),rep(1,4),c(1,0,0,1),c(0,1,1,0)) ##mytr <- function(x) x; dmytr <- function(x) 1 ##mytr <- function(x) x^2; dmytr <- function(x) 2*x ##mytr <- function(z) 1/(1+exp(-z)); dmytr <- function(z) exp(-z)/(1+exp(-z))^2 ACDU <- sapply(c("a","c","d","e","u"),function(x) length(grep(x,tolower(type)))>0) ACDU <- c(ACDU,os=OSon) if (missing(varlink) || (!is.null(varlink) && varlink%in%"log")) { mytr <- exp; dmytr <- exp; myinvtr <- log trname <- "exp"; invtrname <- "log" } else { mytr <- myinvtr <- identity; dmytr <- function(x) rep(1,length(x)) trname <- ""; invtrname <- "" } dmytr2 <- function(z) 4*exp(2*z)/(exp(2*z)+1)^2 mytr2 <- tanh; myinvtr2 <- atanh trname2 <- "tanh"; invtrname2 <- "atanh" if (OSon) { ## logit <- function(p) log(p/(1-p)) ## tigol <- function(z) 1/(1+exp(-z)) ## dlogit <- function(p) 1/(p*(1-p)) ## dtigol <- function(z) tigol(z)^2*exp(-z) ## mytr <- function(p) c(exp(p[-length(p)]),tigol(p[length(p)])) ## myinvtr <- function(z) c(log(z[-length(z)]),logit(z[length(z)])) ## dmytr <- function(p) c(exp(p[-length(p)]),dtigol(p[length(p)])) mytr <- function(x) c(exp(x[-length(x)]),mytr2(x[length(x)])) myinvtr <- function(z) c(log(z[-length(z)]),myinvtr2(z[length(z)])) dmytr <- function(x) c(exp(x[-length(x)]),dmytr2(x[length(x)])) } if (ACDU["u"]) { ## datanh <- function(r) 1/(1-r^2) dmytr <- dmytr2 mytr <- mytr2; myinvtr <- myinvtr2 trname <- trname2; invtrname <- invtrname2 dS0 <- rbind(c(0,1,1,0)) vidx0 <- 1 vidx1 <- 2 vidx2 <- 3 dS2 <- dS1 <- dS0 nvar <- length(vidx0)+length(vidx1) if (OSon) nvar <- nvar+length(vidx2) } else { nvar <- sum(ACDU[1:3]) vidx0 <- vidx1 <- seq(nvar); vidx2 <- seq(nvar+1) if (OSon) nvar <- nvar+1 dS0 <- dS0.[ACDU[1:3],,drop=FALSE] dS1 <- dS1.[ACDU[1:3],,drop=FALSE] dS2 <- dS2.[which(c(ACDU[1:3],TRUE)),,drop=FALSE] } if (eqmean) { bidx2 <- bidx1 <- bidx0 } else { bidx1 <- bidx0+nx bidx2 <- bidx1+nx if (OSon) nx <- 3*nx else nx <- 2*nx; } vidx0 <- vidx0+nx; vidx1 <- vidx1+nx; vidx2 <- vidx2+nx vidx <- nx+seq_len(nvar) midx <- seq_len(nx) plen <- nx+nvar Am <- matrix(c(1,.5,.5,1),ncol=2) Dm <- matrix(c(1,.25,.25,1),ncol=2) Vm <- matrix(c(1,0,0,1),ncol=2) Rm <- matrix(c(0,1,1,0),ncol=2) ################################################## ## system.time(Wide <- reshape(as.data.frame(Data),idvar=c(id,zyg),timevar=time,direction="wide")) ## system.time(Wide <- as.data.frame(fast.reshape(Data,id=c(id),sep="."))) Wide <- as.data.frame(fast.reshape(Data,id=c(id,zyg),sep=".",idcombine=FALSE,labelnum=TRUE)) yidx <- paste(yvar,1:2,sep=".") rmidx <- c(id,yidx,zyg) W0 <- W1 <- W2 <- NULL if (!is.null(weights)) { widx <- paste(weights,1:2,sep=".") rmidx <- c(rmidx,widx) W0 <- as.matrix(Wide[which(Wide[,zyg]==0),widx,drop=FALSE]) W1 <- as.matrix(Wide[which(Wide[,zyg]==1),widx,drop=FALSE]) W2 <- as.matrix(Wide[which(Wide[,zyg]==2),widx,drop=FALSE]) } XX <- as.matrix(Wide[,setdiff(colnames(Wide),rmidx)]) XX[is.na(XX)] <- 0 Y0 <- as.matrix(Wide[which(Wide[,zyg]==0),yidx,drop=FALSE]) Y1 <- as.matrix(Wide[which(Wide[,zyg]==1),yidx,drop=FALSE]) Y2 <- as.matrix(Wide[which(Wide[,zyg]==2),yidx,drop=FALSE]) XX0 <- XX[which(Wide[,zyg]==0),,drop=FALSE] XX1 <- XX[which(Wide[,zyg]==1),,drop=FALSE] XX2 <- XX[which(Wide[,zyg]==2),,drop=FALSE] ################################################## ###}}} setup ###{{{ Mean/Var function ## suppressMessages(browser()) ##Marginals etc. MyData0 <- ExMarg(Y0,XX0,W0,dS0,eqmarg=TRUE,allmarg=allmarg) MyData1 <- ExMarg(Y1,XX1,W1,dS1,eqmarg=TRUE,allmarg=allmarg) MyData2 <- ExMarg(Y2,XX2,W2,dS2,eqmarg=TRUE,allmarg=allmarg) N <- cbind(length(idx0),length(idx1),length(idx2)); N <- cbind(N, 2*nrow(MyData0$Y0)+if (!pairs.only) NROW(MyData0$Y0_marg) else 0, 2*nrow(MyData1$Y0)+if (!pairs.only) NROW(MyData1$Y0_marg) else 0, 2*nrow(MyData2$Y0)+if (!pairs.only) NROW(MyData2$Y0_marg) else 0, NROW(MyData0$Y0),NROW(MyData1$Y0),NROW(MyData2$Y0)) colnames(N) <- c("Total.MZ","Total.DZ","Total.OS","Complete.MZ","Complete.DZ","Complete.OS","Complete pairs.MZ","Complete pairs.DZ","Complete pairs.OS") rownames(N) <- rep("",nrow(N)) if (!OSon) N <- N[,-c(3,6,9),drop=FALSE] if (samecens & !is.null(weights)) { MyData0$W0 <- cbind(apply(MyData0$W0,1,biweight)) if (!is.null(MyData0$Y0_marg)) MyData0$W0_marg <- cbind(apply(MyData0$W0_marg,1,biweight)) MyData1$W0 <- cbind(apply(MyData1$W0,1,biweight)) if (!is.null(MyData1$Y0_marg)) MyData1$W0_marg <- cbind(apply(MyData1$W0_marg,1,biweight)) MyData2$W0 <- cbind(apply(MyData2$W0,1,biweight)) if (!is.null(MyData2$Y0_marg)) MyData2$W0_marg <- cbind(apply(MyData2$W0_marg,1,biweight)) } rm(Y0,XX0,W0,Y1,XX1,W1,Y2,XX2,W2) Sigma <- function(p0) { Sigma2 <- NULL p0[vidx] <- mytr(p0[vidx]) if (ACDU["u"]) { pos0 <- ifelse(OSon, plen-2, plen-1) Sigma0 <- diag(2) + p0[pos0]*Rm Sigma1 <- diag(2) + p0[pos0+1]*Rm if (OSon) Sigma2 <- diag(2) + p0[pos0+2]*Rm } else { ii <- ACDU; ii[4:5] <- FALSE pv <- ACDU*1; pv[ii] <- p0[vidx] Sigma0 <- Vm*pv["e"] + pv["a"] + pv["c"] + pv["d"] Sigma1 <- Vm*pv["e"] + pv["a"]*Am + pv["c"] + pv["d"]*Dm Sigma2 <- Vm*pv["e"] + pv["c"] + (pv["a"] + pv["d"])*Vm + pv["os"]*(pv["a"] + pv["d"])*Rm if (OSon) { dS2 <- dS2. dS2[c(1,3),2:3] <- pv["os"] dS2[4,2:3] <- pv["a"]+pv["d"] dS2 <- dS2[which(c(ACDU[1:3],TRUE)),] } } return(list(Sigma0=Sigma0,Sigma1=Sigma1,Sigma2=Sigma2,dS2=dS2)) } ## p0 <- op$par ## ff <- function(p) as.vector(Sigma(p)$Sigma2) ## numDeriv::jacobian(ff,p0) ## Sigma(p0)$dS2 ## dmytr(p0[vidx]) ## Sigma(p0)$dS2[1,]*dmytr(p0[vidx])[1] ## Sigma(p0)$dS2[2,]*dmytr(p0[vidx])[2] ## Sigma(p0)$dS2[3,]*dmytr(p0[vidx])[3] ###}}} Mean/Var function ###{{{ U p0 <- rep(-1,plen); ##p0[vidx] <- 0 if (!missing(varlink) && is.null(varlink)) p0 <- rep(0.5,plen) if (OSon) p0[length(p0)] <- 0.3 if (type=="u") p0[vidx] <- 0.3 if (!is.null(control$start)) { p0 <- control$start control$start <- NULL } else { X <- rbind(MyData0$XX0[,midx0,drop=FALSE],MyData0$XX0[,midx1,drop=FALSE]) Y <- rbind(MyData0$Y0[,1,drop=FALSE],MyData0$Y0[,2,drop=FALSE]) g <- suppressWarnings(glm(Y~-1+X,family=binomial(probit))) p0[midx] <- coef(g) } U <- function(p,indiv=FALSE) { b0 <- cbind(p[bidx0]) b1 <- cbind(p[bidx1]) b2 <- cbind(p[bidx2]) b00 <- b0; b11 <- b1; b22 <- b2 if (bound) p[vidx] <- min(p[vidx],20) S <- Sigma(p) lambda <- eigen(S$Sigma0)$values if (any(lambda<1e-12 | lambda>1e9)) stop("Variance matrix out of bounds") Mu0 <- with(MyData0, cbind(XX0[,midx0,drop=FALSE]%*%b00, XX0[,midx1,drop=FALSE]%*%b00)) U0 <- with(MyData0, .Call("biprobit0", Mu0, S$Sigma0,dS0,Y0,XX0,W0,!is.null(W0),samecens, PACKAGE="mets")) if (!is.null(MyData0$Y0_marg) &&!pairs.only) { mum <- with(MyData0, XX0_marg%*%b00) dSmarg <- dS0[,1,drop=FALSE] U_marg <- with(MyData0, .Call("uniprobit", mum,XX0_marg, S$Sigma0[1,1],t(dSmarg),Y0_marg, W0_marg,!is.null(W0_marg),TRUE, PACKAGE="mets")) U0$score <- rbind(U0$score,U_marg$score) U0$loglik <- c(U0$loglik,U_marg$loglik) } Mu1 <- with(MyData1, cbind(XX0[,midx0,drop=FALSE]%*%b11, XX0[,midx1,drop=FALSE]%*%b11)) U1 <- with(MyData1, .Call("biprobit0", Mu1, S$Sigma1,dS1,Y0,XX0,W0,!is.null(W0),samecens, PACKAGE="mets")) if (!is.null(MyData1$Y0_marg) &&!pairs.only) { mum <- with(MyData1, XX0_marg%*%b11) dSmarg <- dS1[,1,drop=FALSE] U_marg <- with(MyData1, .Call("uniprobit", mum,XX0_marg, S$Sigma1[1,1],t(dSmarg),Y0_marg, W0_marg,!is.null(W0_marg),TRUE, PACKAGE="mets")) U1$score <- rbind(U1$score,U_marg$score) U1$loglik <- c(U1$loglik,U_marg$loglik) } U2 <- val2 <- NULL if (OSon) { Mu2 <- with(MyData2, cbind(XX0[,midx0,drop=FALSE]%*%b22, XX0[,midx1,drop=FALSE]%*%b22)) U2 <- with(MyData2, .Call("biprobit0", Mu2, S$Sigma2,S$dS2,Y0,XX0,W0,!is.null(W0),samecens, PACKAGE="mets")) if (!is.null(MyData2$Y0_marg) &&!pairs.only) { mum <- with(MyData2, XX0_marg%*%b22) dSmarg <- S$dS2[,1,drop=FALSE] U_marg <- with(MyData2, .Call("uniprobit", mum,XX0_marg, S$Sigma2[1,1],t(dSmarg),Y0_marg, W0_marg,!is.null(W0_marg),TRUE, PACKAGE="mets")) U2$score <- rbind(U2$score,U_marg$score) U2$loglik <- c(U2$loglik,U_marg$loglik) } } if (indiv) { ll0 <- U0$loglik ll1 <- U1$loglik val0 <- U0$score[MyData0$id,,drop=FALSE] val1 <- U1$score[MyData1$id,,drop=FALSE] N0 <- length(MyData0$id) idxs0 <- seq_len(N0) if (length(MyData0$margidx)>0) { for (i in seq_len(N0)) { idx0 <- which((MyData0$idmarg)==(MyData0$id[i]))+N0 idxs0 <- c(idxs0,idx0) val0[i,] <- val0[i,]+colSums(U0$score[idx0,,drop=FALSE]) } val0 <- rbind(val0, U0$score[-idxs0,,drop=FALSE]) ll0 <- c(ll0,ll0[-idxs0]) } N1 <- length(MyData1$id) idxs1 <- seq_len(N1) if (length(MyData1$margidx)>0) { for (i in seq_len(N1)) { idx1 <- which((MyData1$idmarg)==(MyData1$id[i]))+N1 idxs1 <- c(idxs1,idx1) val1[i,] <- val1[i,]+colSums(U1$score[idx1,,drop=FALSE]) } val1 <- rbind(val1, U1$score[-idxs1,,drop=FALSE]) ll1 <- c(ll1,ll1[-idxs1]) } if (OSon) { ll2 <- U2$loglik val2 <- U2$score[MyData2$id,,drop=FALSE] N2 <- length(MyData2$id) idxs2 <- seq_len(N2) if (length(MyData2$margidx)>0) { for (i in seq_len(N2)) { idx2 <- which((MyData2$idmarg)==(MyData2$id[i]))+N2 idxs2 <- c(idxs2,idx2) val2[i,] <- val2[i,]+colSums(U2$score[idx2,,drop=FALSE]) } val2 <- rbind(val2, U2$score[-idxs2,,drop=FALSE]) ll2 <- c(ll2,ll2[-idxs2]) } } val <- matrix(0,ncol=plen,nrow=nrow(val0)+nrow(val1) + NROW(val2)) val[seq_len(nrow(val0)),c(bidx0,vidx0)] <- val0 val[nrow(val0)+seq_len(nrow(val1)),c(bidx1,vidx1)] <- val1 if (OSon) { val[nrow(val0)+nrow(val1)+seq_len(nrow(val2)),c(bidx2,vidx2)] <- val2 } trp <- dmytr(p[vidx]) for (i in seq(length(vidx))) { val[,vidx[i]] <- val[,vidx[i]]*trp[i] } attributes(val)$logLik <- c(U0$loglik,U1$loglik,U2$loglik) return(val) } val <- numeric(plen) val[c(bidx0,vidx0)] <- colSums(U0$score) val[c(bidx1,vidx1)] <- val[c(bidx1,vidx1)]+colSums(U1$score) if (OSon) val[c(bidx2,vidx2)] <- val[c(bidx2,vidx2)]+colSums(U2$score) val[vidx] <- val[vidx]*dmytr(p[vidx]) attributes(val)$logLik <- sum(U0$loglik)+sum(U1$loglik)+sum(U2$loglik) return(val) } ###}}} U ###{{{ optim if (!missing(p)) return(U(p,indiv=indiv)) f <- function(p) crossprod(U(p))[1] f0 <- function(p) -sum(attributes(U(p))$logLik) g0 <- function(p) -as.numeric(U(p)) h0 <- function(p) crossprod(U(p,indiv=TRUE)) if (!missing(constrain)) { freeidx <- is.na(constrain) f <- function(p) { p1 <- constrain; p1[freeidx] <- p res <- U(p1)[freeidx] crossprod(res)[1] } f0 <- function(p) { p1 <- constrain; p1[freeidx] <- p -sum(attributes(U(p1))$logLik) } g0 <- function(p) { p1 <- constrain; p1[freeidx] <- p -as.numeric(U(p1)[freeidx]) } p0 <- p0[is.na(constrain)] } ## Derivatives, Sanity check ## ff <- function(p) attributes(U(p,indiv=FALSE))$logLik ## pp <- c(0,-.1,.1,0.5) ## numDeriv::grad(ff,pp) ## U(pp,indiv=FALSE) controlstd <- list(hessian=0) controlstd[names(control)] <- control control <- controlstd nlminbopt <- intersect(names(control),c("eval.max","iter.max","trace","abs.tol","rel.tol","x.tol","step.min")) ucminfopt <- intersect(names(control),c("trace","grtol","xtol","stepmax","maxeval","grad","gradstep","invhessian.lt")) optimopt <- names(control) op <- switch(tolower(control$method), nlminb=nlminb(p0,f0,gradient=g0,control=control[nlminbopt]), optim=optim(p0,fn=f0,gr=g0,control=control[ucminfopt]), ucminf=, quasi=, gradient=ucminf::ucminf(p0,fn=f0,gr=g0,control=control[ucminfopt],hessian=0), ## , ## bhhh={ ## controlnr <- list(stabil=FALSE, ## gamma=0.1, ## gamma2=1, ## ngamma=5, ## iter.max=200, ## epsilon=1e-12, ## tol=1e-9, ## trace=1, ## stabil=FALSE) ## controlnr[names(control)] <- control ## lava:::NR(start=p0,NULL,g0, h0,control=controlnr) ## }, ## op <- switch(mycontrol$method, ## ucminf=ucminf(p0,f,control=mycontrol[ucminfopt],hessian=F), ## optim=optim(p0,f,control=mycontrol[ucminfopt],...), nlminb(p0,f,control=control[nlminbopt])) if (stderr) { UU <- U(op$par,indiv=TRUE) I <- -numDeriv::jacobian(U,op$par) tol <- 1e-15 iI <- Inverse(I,tol) V <- iI sqrteig <- attributes(V)$sqrteig J <- NULL if (robustvar) { J <- crossprod(UU) V <- iI%*%J%*%iI } if (any(sqrteig1) breaks <- list(breaks) break.points <- FALSE if (is.list(breaks)) { break.points <- TRUE if (length(x)!=length(breaks) & length(breaks)!=1) warning("length of variables not consistent with list of breaks"); if (length(breaks)!=ll) breaks <- rep(list(breaks[[1]]),ll) } if (!break.points) { if (length(x)!=length(breaks) & length(breaks)!=1) warning("length of variables not consistent with breaks"); if (length(breaks)!=ll) breaks<- rep(breaks[1],ll) } if (ll==1 & !is.list(labels)) labels <- list(labels) if (!is.list(labels)) labels <- list(labels); if (length(labels)!=ll ) labels <- rep(list(labels[[1]]),ll) if (!is.list(labels)) stop("labels should be given as list"); for (k in 1:ll) { xx <- x[[k]] if (is.numeric(xx)) { if (!is.list(breaks)) { if (!is.null(probs)) { bb <- quantile(xx, probs,na.rm=na.rm, ...) } else { if (!equi) { probs <- seq(0, 1, length.out = breaks[k] + 1) bb <- quantile(xx, probs, na.rm=na.rm,...) } if (equi) { rr <- range(xx,na.rm=na.rm) bb <- seq(rr[1],rr[2],length.out=breaks[k]+1) } } name<-paste(xnames[k],breaks[k],sep=sep) } else { bb <- breaks[[k]]; name<-paste(xnames[k],breaks[[k]][1],sep=sep) } if (usernames) name <- newnames[k] if (sum(duplicated(bb))==0) data[,name] <- cut(xx,breaks=bb,include.lowest=TRUE,labels=labels[[k]],...) else { if (all==TRUE) { wd <- which(duplicated(bb)) mb <- min(diff(bb[-wd])) bb[wd] <- bb[wd] + (mb/2)*seq(length(wd))/length(wd) data[,name] <- cut(xx,breaks=bb,include.lowest=TRUE,labels=labels[[k]],...) warning(paste("breaks duplicated for=",xnames[k])) } } } } return(data) }# }}} }# }}} ##' @export "dcut<-" <- function(data,...,value) dcut(data,y=value,...) ##' relev levels for data frames ##' ##' levels shows levels for variables in data frame, relevel relevels a factor in data.frame ##' @param data if x is formula or names for data frame then data frame is needed. ##' @param y name of variable, or fomula, or names of variables on data frame. ##' @param x name of variable, or fomula, or names of variables on data frame. ##' @param ref new reference variable ##' @param newlevels to combine levels of factor in data frame ##' @param regex for regular expressions. ##' @param sep seperator for naming of cut names. ##' @param overwrite to overwrite variable ##' @param ... Optional additional arguments ##' @author Klaus K. Holst and Thomas Scheike ##' @examples ##' ##' data(mena) ##' dstr(mena) ##' dfactor(mena) <- ~twinnum ##' dnumeric(mena) <- ~twinnum.f ##' ##' dstr(mena) ##' ##' mena2 <- drelevel(mena,"cohort",ref="(1980,1982]") ##' mena2 <- drelevel(mena,~cohort,ref="(1980,1982]") ##' mena2 <- drelevel(mena,cohortII~cohort,ref="(1980,1982]") ##' dlevels(mena) ##' dlevels(mena2) ##' drelevel(mena,ref="(1975,1977]") <- ~cohort ##' drelevel(mena,ref="(1980,1982]") <- ~cohort ##' dlevels(mena,"coh*") ##' dtable(mena,"coh*",level=1) ##' ##' ### level 1 of zyg as baseline for new variable ##' drelevel(mena,ref=1) <- ~zyg ##' drelevel(mena,ref=c("DZ","[1973,1975]")) <- ~ zyg+cohort ##' drelevel(mena,ref=c("DZ","[1973,1975]")) <- zygdz+cohort.early~ zyg+cohort ##' ### level 2 of zyg and cohort as baseline for new variables ##' drelevel(mena,ref=2) <- ~ zyg+cohort ##' dlevels(mena) ##' ##' ##################### combining factor levels with newlevels argument ##' ##' dcut(mena,labels=c("I","II","III","IV")) <- cat4~agemena ##' dlevels(drelevel(mena,~cat4,newlevels=1:3)) ##' dlevels(drelevel(mena,ncat4~cat4,newlevels=3:2)) ##' drelevel(mena,newlevels=3:2) <- ncat4~cat4 ##' dlevels(mena) ##' ##' dlevels(drelevel(mena,nca4~cat4,newlevels=list(c(1,4),2:3))) ##' ##' drelevel(mena,newlevels=list(c(1,4),2:3)) <- nca4..2 ~ cat4 ##' dlevels(mena) ##' ##' drelevel(mena,newlevels=list("I-III"=c("I","II","III"),"IV"="IV")) <- nca4..3 ~ cat4 ##' dlevels(mena) ##' ##' drelevel(mena,newlevels=list("I-III"=c("I","II","III"))) <- nca4..4 ~ cat4 ##' dlevels(mena) ##' ##' drelevel(mena,newlevels=list(group1=c("I","II","III"))) <- nca4..5 ~ cat4 ##' dlevels(mena) ##' ##' drelevel(mena,newlevels=list(g1=c("I","II","III"),g2="IV")) <- nca4..6 ~ cat4 ##' dlevels(mena) ##' ##' @aliases dlevels dlevel dlev drelevel drelev dlev<- dlevel<- drelev<- drelevel<- dfactor dfactor<- dnumeric dnumeric<- ##' @export drelevel <- function(data,y=NULL,x=NULL,ref=NULL,newlevels=NULL,regex=mets.options()$regex,sep=NULL,overwrite=FALSE,...) {# {{{ if (is.null(ref) && is.null(newlevels)) stop("specify baseline-reference level or new levels \n") if (!is.null(ref) & !is.null(newlevels)) { warning("can only either change ref or combine old levels, will change ref") newlevels <- NULL } if (is.null(sep)) sep <- "." if (is.vector(data) | inherits(data,"factor")) {# {{{ if (is.vector(data)) data <- factor(data) if (!is.null(ref)) { if (is.numeric(ref)) ref <- levels(data)[ref] gx <- relevel(data,ref=ref,...) return(gx) } if (!is.null(newlevels)) { pnewlevels <- levlev(data,newlevels) levels(data,...) <- pnewlevels return(data) } } # }}} if (is.data.frame(data)) {# {{{ usernames <- FALSE# {{{ vars <-mets::procform3(y,x,data=data,regex=regex,...) x <- xnames <- vars$x if (!is.null(vars$y)) { usernames<-TRUE newnames <- vars$y if (length(vars$y)!=length(vars$x)) { warning("length of new names not consistent with length of cut variables, uses default naming\n"); usernames <- FALSE } } # }}} if (is.character(x) && length(x)1 & length(ref)==1) ref <- rep(ref,ll) if (length(x)!=length(ref)) stop("length of baseline reference 'ref' not consistent with variables") } if (!is.null(newlevels)) { if (ll==1 & !is.list(newlevels)) newlevels <- list(newlevels) if (is.list(newlevels) && !is.list(newlevels[[1]])) newlevels <- list(newlevels) if (length(x)!=length(newlevels)) warning("length of variables not consistent with list of breaks"); if (length(newlevels)!=ll) newlevels <- rep(list(newlevels[[1]]),ll) } for (k in 1:ll) { xx <- x[[k]] if (!is.factor(xx)) xx <- factor(xx) if (usernames) name <- newnames[k] if (!is.null(ref)) { name<- paste(xnames[k],ref[k],sep=sep) if (usernames) name <- newnames[k] if (overwrite) name<-xnames[k] if (is.numeric(ref[k])) refk <- levels(xx)[ref[k]] else refk <- ref[k] gx <- relevel(xx,ref=refk,...) data[,name] <- gx } if (!is.null(newlevels)) { name<- paste(xnames[k],newlevels[[k]][1],sep=sep) if (usernames) name <- newnames[k] if (overwrite) name<-xnames[k] pnewlevels <- levlev(xx,newlevels[[k]]) levels(xx,...) <- pnewlevels data[,name] <- xx } } return(data) }# }}} }# }}} ##' @export "drelev<-" <- function(data,x=NULL,...,value) drelevel(data,y=value,x=x,...) ##' @export drelev <- function(data,y=NULL,x=NULL,...) drelevel(data,y=y,x=x,...) ##' @export "drelevel<-" <- function(data,x=NULL,...,value) drelevel(data,y=value,x=x,...) tsglob2rx <- function(x) { glob2rx(gsub("\\+","\\\\+",x)) } levlev <- function(fac,ref,regex=FALSE) {# {{{ if (!is.list(ref)) ref <- list(ref) lf <- levels(fac) lfr <- lf listnames <- names(ref) newreflist <- list() for (k in 1:length(ref)) { if (!is.null(listnames)) nn <- listnames[k] else nn <- NULL ln <- length(ref[[k]]) if (is.numeric(ref[[k]])) refs <- lf[ref[[k]]] else refs <- ref[[k]] xxx <- c() for (xx in refs) { if (!regex) xx <- tsglob2rx(xx) n <- grep(xx,lf) xxx <- c(xxx,lf[n]) } xxx<- xxx[!duplicated(xxx)] refs <- xxx ln <- length(refs) if (is.null(nn) || nn=="") { if (length(refs)>1) nn <- paste(refs[1],refs[ln],sep="-") else nn <- refs[1] } newreflist <- c(newreflist,setNames(list(refs),nn)) mm <- match(refs,lfr) lfr <- lfr[-mm] } if (length(lfr)>=1) { for (k in 1:length(lfr)) { nn <- paste(lfr[k]) ### newreflist <- c(newreflist,list(nn1=lfr[k])) newreflist <- c(newreflist,setNames(list(lfr[k]),nn)) } } return(newreflist) }# }}} ##' @export dlevels <- function(data,y=NULL,x=NULL,regex=mets.options()$regex,max.levels=20,cols=FALSE,...) {# {{{ if (is.factor(data)) { return(base::levels(data,...)) } if (is.data.frame(data)) { usernames <- FALSE# {{{ vars <-mets::procform3(y,x,data=data,regex=regex,...) x <- xnames <- vars$x if (!is.null(vars$y)) { usernames<-TRUE newnames <- vars$y if (length(vars$y)!=length(vars$x)) { warning("length of new names not consistent with length of cut variables, uses default naming\n"); usernames <- FALSE } } # }}} if (is.character(x) && length(x) maxl, base::nlevels(xx), maxl); antfactor <- antfactor+1; namesfac <- c(namesfac,xnames[k]) nlev <- c(nlev,base::nlevels(xx)) m <- m+1 lll[[m]] <- base::levels(xx) } } if (cols==FALSE) cat("-----------------------------------------\n") } } if (cols==TRUE) { mout <- matrix("",maxl,antfactor) for (k in 1:antfactor) { mout[1:nlev[k],k] <- lll[[k]] } colnames(mout) <- namesfac rownames(mout) <- rep(" ",nrow(mout)) prmatrix(mout,quote=FALSE) } } }# }}} ##' @export dlevel <- function(data,y=NULL,x=NULL,...) dlevels(data,y=y,x=x,...) ##' @export dlev <- function(data,y=NULL,x=NULL,...) dlevels(data,y=y,x=x,...) ##' @export drename <- function(data,y=NULL,x=NULL,fun=base::tolower,...) { # {{{ vars <-mets::procform3(y,x,data=data,...) x <- xnames <- vars$x if (!is.null(vars$y)) { newnames <- vars$y if (length(vars$y)!=length(vars$x)) { stop("length of new names not consistent with length of cut variables, uses default naming\n"); } } else { ## if newnames not given then use fun newnames <- do.call(fun,list(x)) } varpos <- match(x,colnames(data)) if (length(varpos)!= length(newnames)) stop("length of old and new variables must match") colnames(data)[varpos] <- newnames return(data) } # }}} ##' @export "drename<-" <- function(data,x=NULL,...,value) drename(data,y=value,x=x,...) ##' @export dfactor <- function(data,y=NULL,x=NULL,regex=mets.options()$regex,sep=NULL,usernames=NULL,levels,labels,...) {# {{{ if (is.null(sep)) sep <- ".f" if (!is.data.frame(data)) { if (!is.factor(data) || !missing(levels) || !missing(labels)) { args <- list(data) if (!missing(levels)) { if (is.numeric(levels) & is.factor(data)) levels <- levels(data)[levels] args <- c(args,list(levels=levels,...)) } if (!missing(labels)) { args <- c(args,list(labels=labels,...)) } gx <- do.call(factor,args) return(gx) } } if (is.data.frame(data)) { usernames <- FALSE# {{{ vars <-mets::procform3(y,x,data=data,regex=regex,...) x <- xnames <- vars$x if (!is.null(vars$y)) { usernames<-TRUE newnames <- vars$y if (length(vars$y)!=length(vars$x)) { usernames <- FALSE } } # }}} if (is.character(x) && length(x)<=ncol(data)) { x <- lapply(xnames,function(z) data[,z]) } dots <- list() args <- lapply(dots, function(x) { if (length(x)==1 && is.character(x)) x <- data[,x]; x }) if (!is.list(x)) x <- list(x) ll <- length(x) if (!missing(levels)) if (!is.list(levels)) levels <- list(levels) if (!missing(labels)) if (!is.list(labels) ) labels <- list(labels) ### if (!missing(levels) ) print(levels) ### if (!missing(labels) ) print(labels) misslabel <- TRUE if (!missing(labels)) { misslabel <- FALSE if ((length(x)!=length(labels))) { warning("length of label list not consistent with variables") labels <- rep(list(labels[[1]]),ll) ### print(labels) } } misslevel <- TRUE if (!missing(levels)) { misslevel <- FALSE if ((length(x)!=length(levels))) { warning("length of levels list not consistent with variables") levels <- rep(list(levels[[1]]),ll) } } for (k in 1:ll) { xx <- x[[k]] name<- paste(xnames[k],sep,sep="") if (usernames) name <- newnames[k] if (!is.factor(xx) || !missing(levels) || !missing(labels)) { args <- list(xx) if (!misslevel) { if (is.numeric(levels[[k]]) & is.factor(xx)) llevels <- levels(xx)[levels[[k]]] else llevels <- levels[[k]] args <- c(args,list(levels=llevels,...)) } if (!misslabel) args <- c(args,list(labels=labels[[k]],...)) gx <- do.call(factor,args) data[,name] <- gx } } return(data) } }# }}} ##' @export "dfactor<-" <- function(data,x=NULL,...,value) dfactor(data,y=value,x=x,...) #####' @export ###dfactor <- function(data,y=NULL,x=NULL,regex=mets.options()$regex,sep=NULL,usernames=NULL,levels,labels,...) ###{# {{{ ### ### if (is.null(sep)) sep <- ".f" ### ### if (is.vector(data)) { ### if (!is.factor(data)) { ### args <- list(data) ### if (!missing(levels)) args <- c(args,list(levels=levels,...)) ### if (!missing(labels)) args <- c(args,list(labels=labels,...)) ### gx <- do.call(factor,args) ### } else gx <- data ### return(gx) ### } ### ###if (is.data.frame(data)) { ### ### usernames <- FALSE# {{{ ### ###vars <-mets::procform3(y,x,data=data,regex=regex,...) ###x <- xnames <- vars$x ### ###if (!is.null(vars$y)) { ### usernames<-TRUE ### newnames <- vars$y ### if (length(vars$y)!=length(vars$x)) { ### usernames <- FALSE ### } ###} #### }}} ### ### if (is.character(x) && length(x)cuti) to the data-set for each knot of the spline. ##' The full spline is thus given by x and spline variables added to the data-set. ##' ##' @param data if x is formula or names for data frame then data frame is needed. ##' @param y name of variable, or fomula, or names of variables on data frame. ##' @param x name of variable, or fomula, or names of variables on data frame. ##' @param probs groups defined from quantiles ##' @param breaks number of breaks, for variables or vector of break points, ##' @param equi for equi-spaced breaks ##' @param regex for regular expressions. ##' @param sep seperator for naming of cut names. ##' @param na.rm to remove NA for grouping variables. ##' @param labels to use for cut groups ##' @param all to do all variables, even when breaks are not unique ##' @param ... Optional additional arguments ##' @author Thomas Scheike ##' @examples ##' data(TRACE) ##' TRACE <- dspline(TRACE,~wmi,breaks=c(1,1.3,1.7)) ##' cca <- coxph(Surv(time,status==9)~age+vf+chf+wmi,data=TRACE) ##' cca2 <- coxph(Surv(time,status==9)~age+wmi+vf+chf+wmi.spline1+wmi.spline2+wmi.spline3,data=TRACE) ##' anova(cca,cca2) ##' ##' nd=data.frame(age=50,vf=0,chf=0,wmi=seq(0.4,3,by=0.01)) ##' nd <- dspline(nd,~wmi,breaks=c(1,1.3,1.7)) ##' pl <- predict(cca2,newdata=nd) ##' plot(nd$wmi,pl,type="l") ##' ##' @export ##' @aliases dspline<- dspline <- function(data,y=NULL,x=NULL,breaks=4,probs=NULL,equi=FALSE,regex=mets.options()$regex,sep=NULL,na.rm=TRUE,labels=NULL,all=FALSE,...) {# {{{ if (is.vector(data)) {# {{{ if (is.list(breaks)) breaks <- unlist(breaks) if (length(breaks)==1) { if (!is.null(probs)) { breaks <- quantile(data, probs, na.rm=na.rm, ...) breaks <- breaks[-c(1,length(breaks))] } else { if (!equi) { probs <- seq(0, 1, length.out = breaks + 1) breaks <- quantile(data, probs,na.rm=na.rm, ...) breaks <- breaks[-c(1,length(breaks))] } if (equi) { rr <- range(data,na.rm=na.rm) breaks <- seq(rr[1],rr[2],length.out=breaks+1) breaks <- breaks[-c(1,length(breaks))] } } } if (sum(duplicated(breaks))==0) { gx <- LinSpline(data, breaks, ...) attr(gx,"breaks") <- breaks } else { wd <- which(duplicated(breaks)) mb <- min(diff(breaks[-wd])) breaks[wd] <- breaks[wd] + (mb/2)*seq(length(wd))/length(wd) gx <- LinSpline(data, breaks,...) attr(gx,"breaks") <- breaks warning(paste("breaks duplicated")) } return(gx) }# }}} if (is.data.frame(data)) {# {{{ if (is.null(sep)) sep <- "." usernames <- FALSE# {{{ vars <-mets::procform3(y,x,data=data,regex=regex,...) x <- xnames <- vars$x if (!is.null(vars$y)) { usernames<-TRUE newnames <- vars$y if (length(vars$y)!=length(vars$x)) { warning("length of new names not consistent with length of cut variables, uses default naming\n"); usernames <- FALSE } } # }}} if (is.character(x) && length(x)1) breaks <- list(breaks) break.points <- FALSE if (is.list(breaks)) { break.points <- TRUE if (length(x)!=length(breaks) & length(breaks)!=1) warning("length of variables not consistent with list of breaks"); if (length(breaks)!=ll) breaks <- rep(list(breaks[[1]]),ll) } if (!break.points) { if (length(x)!=length(breaks) & length(breaks)!=1) warning("length of variables not consistent with breaks"); if (length(breaks)!=ll) breaks<- rep(breaks[1],ll) } if (ll==1 & !is.list(labels)) labels <- list(labels) if (!is.list(labels)) labels <- list(labels); if (length(labels)!=ll ) labels <- rep(list(labels[[1]]),ll) if (!is.list(labels)) stop("labels should be given as list"); for (k in 1:ll) { xx <- x[[k]] if (is.numeric(xx)) { if (!is.list(breaks)) { if (!is.null(probs)) { bb <- quantile(xx, probs,na.rm=na.rm, ...) bb <- bb[-c(1,length(bb))] } else { if (!equi) { probs <- seq(0, 1, length.out = breaks[k] + 1) bb <- quantile(xx, probs, na.rm=na.rm,...) bb <- bb[-c(1,length(bb))] } if (equi) { rr <- range(xx,na.rm=na.rm) bb <- seq(rr[1],rr[2],length.out=breaks[k]+1) bb <- bb[-c(1,length(bb))] } } ### name<-paste(xnames[k],breaks[k],sep=sep) name<-xnames[k] } else { bb <- breaks[[k]]; ### name<-paste(xnames[k],breaks[[k]][1],sep=sep) name<-xnames[k] } if (usernames) name <- newnames[k] if (sum(duplicated(bb))==0) { attr(data,paste(name,"spline.breaks",sep="")) <- bb for (i in seq_along(c(bb))) { namei <- paste(name,".spline",i,sep="") data[,namei] <- (xx-bb[i])*(xx>bb[i]) } } else { if (all==TRUE) { wd <- which(duplicated(bb)) mb <- min(diff(bb[-wd])) bb[wd] <- bb[wd] + (mb/2)*seq(length(wd))/length(wd) attr(data,paste(name,"spline.breaks",sep="")) <- bb for (i in seq_along(c(breaks))) { namei <- paste(name,".spline",i,sep="") data[,namei] <- (xx-bb[i])*(xx>bb[i]) } warning(paste("breaks duplicated for=",xnames[k])) } } } } return(data) }# }}} }# }}} ##' @export "dspline<-" <- function(data,...,value) dspline(data,y=value,...) ##' Simple linear spline ##' ##' Simple linear spline ##' ##' @param x variable to make into spline ##' @param knots cut points ##' @param num to give names x1 x2 and so forth ##' @param name name of spline expansion name.1 name.2 and so forth ##' @author Thomas Scheike ##' @keywords survival ##' @export LinSpline <- function(x,knots,num=TRUE,name="Spline") {# {{{ lspline <- matrix(0,length(c(x)),length(c(knots))) for (i in seq_along(c(knots))) { lspline[,i] <- (x-knots[i])*(x>knots[i]) } lspline <- as.data.frame(lspline) if (num==TRUE) names(lspline) <- paste(name,seq_along(c(knots)),sep="") else if (!is.null(signif)) names(lspline) <- paste(name,round(c(knots),signif),sep="") return(lspline) }# }}} mets/R/predict.biprobit.R0000644000176200001440000000543013623061405015013 0ustar liggesusers##' @export predict.biprobit <- function(object,newdata,X,Z,which=NULL,fun=NULL,type,...) { if (missing(newdata)) newdata <- data.frame(1) if (missing(X)) { ff <- object$formula; ff[2] <- NULL X <- model.matrix(ff,newdata) } if (missing(Z)) Z <- model.matrix(object$rho.formula,newdata) p <- coef(object) h <- function(p) log(p/(1-p)) ## logit ih <- function(z) 1/(1+exp(-z)) ## expit if (!missing(type)) { h <- asin; ih <- sin if (is.null(type)) { h <- ih <- identity } if (is.list(type)) { h <- type[[1]]; ih <- type[[2]] } } prob <- function(p,which=NULL,fun=NULL,...) { blen <- object$model$blen beta1 <- p[seq(blen)] if (object$model$eqmarg) { beta2 <- beta1 } else { beta2 <- beta1[-seq(blen/2)] beta1 <- beta1[seq(blen/2)] } gamma <- p[-seq(blen)] m1 <- X%*%beta1 m2 <- X%*%beta2 r <- object$SigmaFun(gamma,cor=TRUE,Z=Z) pp <- data.frame(mu1=m1,mu2=m2,rho=r$rho) p11 <- with(pp, pmvn(lower=c(0,0),upper=c(Inf,Inf),mu=cbind(mu1,mu2),sigma=cbind(rho),cor=TRUE)) p10 <- with(pp, pmvn(lower=c(0,-Inf),upper=c(Inf,0),mu=cbind(mu1,mu2),sigma=cbind(rho),cor=TRUE)) p01 <- with(pp, pmvn(lower=c(-Inf,0),upper=c(0,Inf),mu=cbind(mu1,mu2),sigma=cbind(rho),cor=TRUE)) p00 <- with(pp, pmvn(lower=c(-Inf,-Inf),upper=c(0,0),mu=cbind(mu1,mu2),sigma=cbind(rho),cor=TRUE)) p1 <- p11+p10 p2 <- p11+p01 res <- cbind(p11,p10,p01,p00,p1,p2,as.matrix(pp)) if (!is.null(fun)) return(fun(res)) if (!is.null(which)) { tr.idx <- base::which(which<7) res <- res[,which,drop=FALSE] if (length(tr.idx)>0) res[,tr.idx] <- h(res[,tr.idx]) return(structure(res,tr.idx=tr.idx)) } return(res) } pp <- prob(p,which=which,fun=fun) if (!is.null(fun)) { res <- estimate(object,prob,fun=fun)$coefmat if (!missing(newdata) && nrow(newdata)==nrow(res)) { suppressWarnings(res <- cbind(res,parameter=rownames(res),newdata)) } return(res) } if (!is.null(which)) { res <- estimate(object,prob,which=which)$coefmat[,c(1,3,4),drop=FALSE] tr.idx <- (attributes(pp)$tr.idx-1)*nrow(pp) if (length(tr.idx)>0) { for (ii in tr.idx) { idx <- ii+seq(nrow(pp)) res[idx,] <- ih(res[idx,]) } } rownames(res) <- rep(colnames(pp),each=nrow(pp)) pp <- res } if (!missing(newdata)) { suppressWarnings(pp <- cbind(pp,parameter=rownames(pp),newdata)) } return(pp) } mets/R/surv.boxarea.R0000644000176200001440000001430213623061405014165 0ustar liggesusers#####' @export ###surv.boxarea <- function(left.trunc,right.cens,data,timevar="time",status="status",id="id",covars=NULL,covars.pairs=NULL,num=NULL,silent=1,boxtimevar="boxtime") ###{ ## {{{ ### if (is.null(data[,id])) stop("Wrong cluster variable") ### if (is.null(data[,timevar])) stop("Wrong time variable") ### if (is.null(data[,status])) stop("Wrong status variable") ### data <- data[order(data[,id]),] ### if (silent<=-1) { ### message("survboxare()") ### print(head(data)) ### print(summary(data[,id])) ### } ### if (is.null(num)) { ### idtab <- table(data[,id]) ### num <- "num" ### while (num%in%names(data)) num <- paste(num,"_",sep="") ### data[,c(num)] <- unlist(lapply(idtab,seq_len)) ### } ### ### timevar2 <- paste(timevar,1:2,sep="") ### status2 <- paste(status,1:2,sep="") ### num2 <- paste(num,1:2,sep="") ### covars2 <- NULL; covars.pairs2 <- NULL; ### if (length(covars)>0) covars2 <- paste(covars,1:2,sep="") ### if (length(covars.pairs)>0) covars.pairs2 <- paste(covars.pairs,1:2,sep="") ### ### if (silent<=-1) { ### message("survboxare()") ### print(head(data)) ### print( c(timevar,status,covars,covars.pairs,id,num)) ### print(c(id,num)) ### print(summary(data)) ### } ### ww0 <- fast.reshape(data[,c(timevar,status,covars,covars.pairs,id,num)],id=id,num=num,labelnum=TRUE) ### if (silent<=-1) { ### message("survboxarea(), ww1") ### print(head(ww0)) ### print(summary(ww0)) ### print(c(timevar2,status2,covars2,covars.pairs2,id,num2)) ### ww0 <- data.frame(ww0); ### print(table(ww0$status1,ww0$status2)) ### } ### mleft <- (ww0[,timevar2[1]]>left.trunc[1]) & (ww0[,timevar2[2]]>left.trunc[2]) ## Both not-truncated ### ### if (length(na.idx <- which(is.na(mleft)))>0) { ### ## warning("Removing incomplete cases", na.idx) ### mleft <- mleft[-na.idx] ### ww0 <- ww0[-na.idx,,drop=FALSE] ### } ### if (sum(mleft)==0) stop("No data selected\n"); ### ww0 <- ww0[which(mleft),,drop=FALSE] ### ### right1 <- which(ww0[,timevar2[1]] > right.cens[1]) ### right2 <- which(ww0[,timevar2[2]] > right.cens[2]) ### ww0[,timevar2[1]][right1] <- right.cens[1] ### ww0[,timevar2[2]][right2] <- right.cens[2] ### ww0[,status2[1]][right1] <- 0 ### ww0[,status2[2]][right2] <- 0 ### truncvar2 <- c("left1","left2") ### ww0 <- cbind(ww0,left.trunc[1]) ### ww0 <- cbind(ww0,left.trunc[2]) ### colnames(ww0)[c(-1,0) + ncol(ww0)] <- truncvar2 ### ### if (silent<=-1) print(head(ww0)) ### if (silent<=0) ### message(paste(" Number of joint events:",sum(apply(ww0[,status2],1,sum)==2),"of ",nrow(ww0)),"\n"); ### ### varying <- c(timevar,status,"left",covars) ### lr.data <- data.frame(fast.reshape(ww0,varying=varying,numname=num)) ### if (silent<=-1) { ### print("surv.boxarea after fast.reshape"); ### print(head(lr.data)) ### print(summary(lr.data[,id])) ### } ### lr.data[,boxtimevar] <- lr.data[,timevar]-lr.data[,"left"] ### return(structure(lr.data,num=num,time=boxtimevar,status=status,covars=covars,id=id,left=left)) ###} ## }}} ##' @export surv.boxarea <- function(left.trunc,right.cens,data,timevar="time",status="status",id="id",covars=NULL,covars.pairs=NULL,num=NULL,silent=1,boxtimevar="boxtime") { ## {{{ if (is.null(data[,id])) stop("Wrong cluster variable") if (is.null(data[,timevar])) stop("Wrong time variable") if (is.null(data[,status])) stop("Wrong status variable") data <- data[order(data[,id]),] if (silent<=-1) { message("survboxare()") print(head(data)) print(summary(data[,id])) } if (is.null(num)) { idtab <- table(data[,id]) num <- "num" while (num%in%names(data)) num <- paste(num,"_",sep="") data[,c(num)] <- unlist(lapply(idtab,seq_len)) } ### if (is.null(ssname)) { ### idtab <- table(data[,id]) ### num <- "num" ### while (num%in%names(data)) num <- paste(num,"_",sep="") ### data[,c(num)] <- unlist(lapply(idtab,seq_len)) ### } timevar2 <- paste(timevar,1:2,sep="") status2 <- paste(status,1:2,sep="") num2 <- paste(num,1:2,sep="") covars2 <- NULL; covars.pairs2 <- NULL; if (length(covars)>0) covars2 <- paste(covars,1:2,sep="") if (length(covars.pairs)>0) covars.pairs2 <- paste(covars.pairs,1:2,sep="") if (silent<=-1) { message("survboxare()") print(head(data)) print( c(timevar,status,covars,covars.pairs,id,num)) print(c(id,num)) print(summary(data)) } ww0 <- fast.reshape(data[,c(timevar,status,covars,covars.pairs,id,num)],id=id,num=num,labelnum=TRUE) if (silent<=-1) { message("survboxarea(), ww1") print(head(ww0)) print(summary(ww0)) print(c(timevar2,status2,covars2,covars.pairs2,id,num2)) ww0 <- data.frame(ww0); print(table(ww0$status1,ww0$status2)) } mleft <- (ww0[,timevar2[1]]>left.trunc[1]) & (ww0[,timevar2[2]]>left.trunc[2]) ## Both not-truncated if (length(na.idx <- which(is.na(mleft)))>0) { ## warning("Removing incomplete cases", na.idx) mleft <- mleft[-na.idx] ww0 <- ww0[-na.idx,,drop=FALSE] } if (sum(mleft)==0) cat("No data selected\n"); if (sum(mleft)!=0) { ww0 <- ww0[which(mleft),,drop=FALSE] right1 <- which(ww0[,timevar2[1]] > right.cens[1]) right2 <- which(ww0[,timevar2[2]] > right.cens[2]) ww0[,timevar2[1]][right1] <- right.cens[1] ww0[,timevar2[2]][right2] <- right.cens[2] ww0[,status2[1]][right1] <- 0 ww0[,status2[2]][right2] <- 0 truncvar2 <- c("left1","left2") ww0 <- cbind(ww0,left.trunc[1]) ww0 <- cbind(ww0,left.trunc[2]) colnames(ww0)[c(-1,0) + ncol(ww0)] <- truncvar2 ### ww0[,"intnames1"] <- paste("[",left.trunc[1],",",right.cens[1],")",sep="") ### ww0[,"intnames2"] <- paste("[",left.trunc[2],",",right.cens[2],")",sep="") if (silent<=-1) print(head(ww0)) if (silent<=0) message(paste(" Number of joint events:",sum(apply(ww0[,status2],1,sum)==2),"of ",nrow(ww0)),"\n"); varying <- c(timevar,status,"left",covars) lr.data <- data.frame(fast.reshape(ww0,varying=varying,numname=num)) if (silent<=-1) { print("surv.boxarea after fast.reshape"); print(head(lr.data)) print(summary(lr.data[,id])) } lr.data[,boxtimevar] <- lr.data[,timevar]-lr.data[,"left"] ### print(head(lr.data)) return(structure(lr.data,num=num,time=boxtimevar,status=status,covars=covars,id=id)) } else return(NULL); } ## }}} mets/R/divide.conquer.R0000644000176200001440000000650013623061405014466 0ustar liggesusers##' @export folds<- function (n, folds = 10) { ## {{{ split(sample(1:n), rep(1:folds, length = n)) } ## }}} ##' Split a data set and run function ##' ##' @title Split a data set and run function ##' @param func called function ##' @param data data-frame ##' @param size size of splits ##' @param splits number of splits (ignored if size is given) ##' @param id optional cluster variable ##' @param ... Additional arguments to lower level functions ##' @author Thomas Scheike, Klaus K. Holst ##' @export ##' @examples ##' library(timereg) ##' data(TRACE) ##' res <- divide.conquer(prop.odds,TRACE, ##' formula=Event(time,status==9)~chf+vf+age,n.sim=0,size=200) divide.conquer <- function(func=NULL,data,size,splits,id=NULL,...) { ## {{{ nn <- nrow(data) if (!is.null(id)) { if (is.character(id) && length(id)==1) id <- data[,id] if (length(id)!=nn) stop("Wrong length of id variable") cc <- cluster.index(id) if (!missing(size)) splits <- round(cc$uniqueclust/size) splits <- min(splits,cc$uniqueclust) all.folds <- folds(cc$uniqueclust,splits) res <- lapply(all.folds, function(i) { idx <- na.omit(as.vector(cc$idclustmat[i,]+1)) do.call(func, c(list(data=data[idx,]),...)) }) return(res) } splits <- round(nn/size) all.folds <- folds(nn,splits) res <- lapply(all.folds, function(i) do.call(func, c(list(data=data[i,]),...))) res } ## }}} ##' Split a data set and run function of cox-aalen type and aggregate results ##' ##' @title Split a data set and run function from timereg and aggregate ##' @param func called function ##' @param data data-frame ##' @param size size of splits ##' @param ... Additional arguments to lower level functions ##' @author Thomas Scheike, Klaus K. Holst ##' @export ##' @examples ##' library(timereg) ##' data(TRACE) ##' a <- divide.conquer.timereg(prop.odds,TRACE, ##' formula=Event(time,status==9)~chf+vf+age,n.sim=0,size=200) ##' coef(a) ##' a2 <- divide.conquer.timereg(prop.odds,TRACE, ##' formula=Event(time,status==9)~chf+vf+age,n.sim=0,size=500) ##' coef(a2) ##' ##' if (interactive()) { ##' par(mfrow=c(1,1)) ##' plot(a,xlim=c(0,8),ylim=c(0,0.01)) ##' par(new=TRUE) ##' plot(a2,xlim=c(0,8),ylim=c(0,0.01)) ##' } divide.conquer.timereg <- function(func=NULL,data,size,...) { ## {{{ res <- divide.conquer(func=func,data,size,...) K <- length(res) gamma <- Reduce("+", lapply(res,function(x) x$gamma))/K gammas <- do.call("cbind", lapply(res,function(x) x$gamma)) var.gamma <- Reduce("+", lapply(res,function(x) x$var.gamma))/K^2 robvar.gamma <- Reduce("+", lapply(res,function(x) x$robvar.gamma))/K^2 times <- c(0,sort(unlist(lapply(res,function(x) x$cum[-1,1])))) cum <- Reduce("+",lapply(res,function(x) Cpred(x$cum,times)))/K var.cum <- Reduce("+", lapply(res,function(x) Cpred(x$var.cum,times)))/K^2 robvar.cum <- Reduce("+", lapply(res,function(x) Cpred(x$robvar.cum,times)))/K^2 robvar.cum[,1] <- var.cum[,1] <- times res <- list(gamma=gamma, var.gamma=var.gamma, robvar.gamma=robvar.gamma, gammas=gammas, sdgammas=apply(gammas,1,sd), cum=cum,var.cum=var.cum,robvar.cum=robvar.cum, res=res,prop.odds=TRUE,score=0,D2linv=diag(nrow(gamma))) class(res) <- "cox.aalen" return(res) } ## }}} mets/MD50000644000176200001440000004322213623150474011542 0ustar liggesusers63582757f2b101f7698d9a2e25084613 *DESCRIPTION 837ab4be216e8d6e8685bfc8aab4ed79 *NAMESPACE bc2a685759e75c3d17ce9fd0057c8ed8 *NEWS af2d661540f399907241277b5cc102e6 *R/Dbvn.R 7ab6e05e625f27bf60630fde9ef75162 *R/RcppExports.R 385f13b50c7960b9188a38e44a4a5a8b *R/aalenfrailty.R 80d4cb61ae947adfe1e12cc8e4e0af81 *R/bicomprisk.R 89962eced59b6f59bee83fb8a9cc5b5b *R/bicomprisksim.R a190c3d55bb74adf4fce3c5248298c84 *R/binomial.regression.R 1b111ceb83303750a2877da90916bcd9 *R/binomial.twostage.R c59130869e4e1eb30f18e5bed06cda35 *R/biprobit.R 89f0ba1b2ca3aecbcd41af60d4383556 *R/biprobit.strata.R e06025c62e8caa65aca2e90809a95e0e *R/biprobit.time.R 0b2faf24c511f1c09a8ce75c76e3f276 *R/blocksample.R 0c89194d234ddcd2cbdbb0c36ca65131 *R/bptwin.R 55fbd8cc4e66cb3e58d90ffa8f21ebc0 *R/casewise.R 3fdd18135405faa1fefd23ad006f6205 *R/cifreg.R 8a07ec0dd981c5216c99277977429a23 *R/claytonakes.R cd86e4d240944c39e1f0e1be95b96a6f *R/clusterindex-reshape.R 396128307cc075e897c3b576481dc6ab *R/coef.biprobit.R e3f009ba35ba8dbae0cfb2cd8928cadd *R/cor.R d5613f95eb295bc97185e7654e68e179 *R/cumh.R 2a2cc34b97653777bc89c69b4df8acc4 *R/daggregate.R 639d7c845ebcae12e00692c1d8afdda1 *R/dby.R 79e0730f43ad99084f9d30d1cd5d86d3 *R/discrete-survival-haplo.R 7649e1c3e5c1673e280c839e9cc97aef *R/divide.conquer.R 7f4073d3f1da949d4c102f2d7f8bf9d2 *R/dprint.R 013150a925ecf1844ebfb5c33699da87 *R/dreg.R f6b29225395d9c4cc07648123b19296b *R/dsort.R 3e501d6032a3fb75bfdbc697516414dc *R/dtable.R 17ebafdb2290154027ca8b257bc23897 *R/dtransform.R 928411578cb8ba21268245f44c52bfd1 *R/dutils.R 081dfb8ed862ef38ceda68cc381dfa81 *R/exmarg.R 307f9bc8d42a9f071750802cdbe3850c *R/fastapprox.R 832de0fab75477b87151e13ff248fc41 *R/fastcluster.R 350c1f10faa177694cd0d436c8f1cce3 *R/fastpattern.R e1ed50fd366dc285b36871592f3d0b96 *R/fastreshape.R 66813e58f107646d49b31628068b90f9 *R/force.same.cens.R 3102f83ee06b383f8662ef46da9339fb *R/gof-phreg.R 77f8de565a7a0f8ce8c4d463468dc272 *R/ipw.R 40719b88e966a2728bcd79c48e4cac6c *R/jumptimes.R 4ad140f085120cd4814ee859da1e8bfe *R/lifecourse.R fc01593e10534f86d078c470ee19b353 *R/lifetable.R 5b3601eea5ebbbf41c21a170420d32ea *R/logLik.biprobit.R 3df605295134e29eb212dcc2f1b60d0e *R/marginalprobit.R f772cdbbe902c233ec62c1bfdaa556e1 *R/methodstwinlm.R 1d9a68ff55e638779c45aea21d488906 *R/mets-package.R 5ea30f406ba1c4ce58ab0f4a97eb2484 *R/mutinomialreg.R 081b3c96c2f837f3f3046360e4b0a31a *R/normal0.R d069740db8cc52990c62780e28ae3da5 *R/npc.R 33298aef3545196b8af3a3c8896e4d36 *R/onload.R 5c06932ffc82248f589e97b3047f08d9 *R/options.R 829faf4ccd46d6b2347cb89111998451 *R/pch.R f56507e16477a88bf2b5a0592ec2c85a *R/phreg.R 117bd8a3ef9cc69547857d130706d25c *R/phreg.par.R 02447480cc62b5c621114f20aad09454 *R/plot.bptwin.R 936d669fd52e6a92156d9dd6102f50d8 *R/plotcr.R dd21a8b7f70c3ef33c152cbafbe28f48 *R/pmvn.R 0d80d849b109aa23263892f3c88ded5c *R/predict.biprobit.R 719e376ca4b5290fb6e4e96342a7fea2 *R/print.biprobit.R dce3ddcf5d24e0d34e1cb96463adc2cf *R/print.summary.biprobit.R 0d894546616b57c61521781eab3f9a20 *R/procformula.R b1e8e71fccc5f3248cf5754ba4233b8a *R/prop-odds.R 47b5a23cabba5a598da75a579253320e *R/recurrent.marginal.R 0faa3f91fabc55c417a9fd2ba6a6e6d4 *R/score.biprobit.R c022fab324a8e9ee6cd581a60cb9c9b3 *R/sim-nordic-twin.R 26374a2446fc7f0432e5f658b60e4d51 *R/sim.bptwin.R c9ea231c97bdd04a5b8585d383647187 *R/sim.clayton.oakes.R d093ba14a69f98d7385de90f06d1cc73 *R/sim.coxph.R 95982cdaffe3584eb6185a05e4c1ba84 *R/summary.biprobit.R 9019b136ba6085cc2f5194e2fe7efe30 *R/summary.bptwin.R af28a1e4d4edebff272b1e4a702b1274 *R/surv.boxarea.R c2773c8b667bbf3b800f25e97c300396 *R/tetrachor.R 59c68b3e1a064e675c9a5c3ac2206956 *R/twin.clustertrunc.r e1ed2bd76fd5ee0edf5c4fa9a2548386 *R/twinlm.R 31ecfad2d2220025e858041464879433 *R/twinlm.time.R c485b5b35de8963adec573191b663d61 *R/twinsim.R fbb208d8727307068958f484976b31d3 *R/twostage.R 12f6e9ba61bce52f709fd421537f32ab *R/utils.R 7dd9f35f83fe27e7dbcd6683592b40e3 *R/vcov.biprobit.R eee6981d5c2e39622c029e5ff2b4887a *R/wild-phreg.R 375033b7c92949523bd334ff615de480 *build/vignette.rds 7de139a42d407f8f192c09001b3aff87 *data/base1cumhaz.txt.xz 3bf9962cc49fc09331b9f82f694dd236 *data/base44cumhaz.txt.gz 4aa78069cd2f1f4663cc870baf62793e *data/base4cumhaz.txt.xz 88afc9f8a26be76d1e842cba923bac28 *data/datalist 3f20f6cc6684c009694186cd0e400dbe *data/dermalridges.rda ff179c749c45ee161c59be3929427b91 *data/dermalridgesMZ.rda d3109147281d3bae0cde9950715e1f1f *data/drcumhaz.txt.xz 2f73af5df1f4889aac9664b72e157d17 *data/hHaplos.rda 2d8decdf784e19128399e5055e39f212 *data/hapfreqs.rda 667c7c27aa3423b2d39fa2dda35f48f4 *data/haploX.rda b727c94dfd45a7fc7dd130c2a244a507 *data/mena.rda 08c31d30aedd2a20d1e35fbe51130283 *data/migr.txt.xz 3d38e49cf846b831580ed86cd8dc4eab *data/multcif.txt.xz 334a7d7e55ee2619b7504d9cd8998a71 *data/np.txt.xz c3301bedf23d9f5ef13af210945195d1 *data/prt.rda 60c1a649e622fe5fb9b8fd250a2ed63f *data/ttpd.rda ddf8e6287011910671414e1e78f1befc *data/twinbmi.txt.xz bf72221d78336c591f8ad85e21f2752f *data/twinstut.txt.xz 0b0e0f8a029ee55472268a4e0a4eb1cb *demo/00Index 85c5313212b7fe3fa40d0ee8071ddd48 *demo/mets.R 0e05a7599d9d7d4341f374b2c63cf794 *demo/models.R 4c46ad887d2099ae91846a32df25db20 *demo/tools.R 1b52526641e263ef6a041e2f25f45cbb *inst/CITATION 8483fe7f09ddc5107662ee63d2e1b7e4 *inst/devel/bptwin2.R 913d99912ad01d7ff667e324a33ca90c *inst/devel/dreg.R d835038893d56f0af1628cb410cecdc3 *inst/doc/basic-dutils.ltx 94dfbd0283b005f092a8c615b86a107d *inst/doc/basic-dutils.pdf fbab3a080f4d20b27056ac6b7dde8ede *inst/doc/binomial-case-control-ascertainment.ltx 81e856e0aca1e2bcde318c4e9814e3cd *inst/doc/binomial-case-control-ascertainment.pdf 998ecfb2a0857355329aecee710e26b4 *inst/doc/binomial-family.ltx e44df923ec764b8df48299e0392af809 *inst/doc/binomial-family.pdf cf9fff39f408ce613043433e9a026d0a *inst/doc/binomial-twin.ltx f46cd7cbe63d100a8ac4ba3da9c09179 *inst/doc/binomial-twin.pdf 3f76e852d56afed0d2a118ce03c2c7a6 *inst/doc/competing.ltx 989ec221163b41c2e014c784e730b176 *inst/doc/competing.pdf 1cafc47debbfcb7eea5c59a473f8bbbf *inst/doc/marginal-cox.ltx a57a595434a4a74e7fc57b603a8c733b *inst/doc/marginal-cox.pdf f92ef80eacbb8d845a9067a4bc5de760 *inst/doc/quantitative-twin.ltx 52c08e594b3b7ba1bbf452351af21b67 *inst/doc/quantitative-twin.pdf 0bda4054faeeb4f6702c9e9ddc5af067 *inst/doc/recurrent-events.ltx fcd8942667a40d84bf36ab8dbdd1c16d *inst/doc/recurrent-events.pdf 024b0a2b44d790094c0e01bc1af1b56d *inst/doc/twostage-survival-case-control.ltx 2e78f9d7a79695ec14a5d49fce742f86 *inst/doc/twostage-survival-case-control.pdf c8d6f19ae15006011b190effc707c445 *inst/doc/twostage-survival.ltx d453f24e18c3a0b30bf1c05306f29ea6 *inst/doc/twostage-survival.pdf 46393666564385006416ad5948c22484 *inst/documentation/dutils.org 7ec9e2c35a66a5b6a1ddfdfab98fc44b *inst/include/mets.h ecc046fadfe85d537b00b625ddd9eb26 *inst/include/mets_RcppExports.h c682bccf2683cd08933c8b44449d352f *inst/misc/binfam.rda 2db060b6bc3324b9c9e90ac9c0e5e7fe *inst/misc/binomialtwostage.R 0d267747e68a564e78e09325649068db *inst/misc/casewisea.png 4fbc7784178f73238a4b1b9a39b7bca1 *inst/misc/cif2.png 78372a577ba20547edea3905a956d167 *inst/misc/cifMZ.png 191b8a32894b4dc63f525800641c6e35 *inst/misc/conc2.png 925b5f3a171e0bbd1faab284545b7262 *inst/misc/concordance.png 811775355fee413d197fe037933d1284 *inst/misc/cumh.png 5742e3f94d8bdf0b9d67bb87abf2789b *inst/misc/ipw.png 49e073436d613746d41d7f0bf5bad6ea *inst/misc/mena.html 03fa5bde649da03810bf1cbbaaf538ed *inst/misc/menalong.rda 9829b57d272e548de249a8d15a1c9054 *inst/misc/mets1.png dd71ff5cd1ab76b3a8139c5f32f6f769 *inst/misc/obs/workshop-ts.R ebc9998e4419b62014f888c0c136557a *inst/misc/obs/workshop.R a314d95a5cd781a0e58fef12778b02dc *inst/misc/obs/workshop.html e63682330161445227c26fb14c9341b7 *inst/misc/obs/workshop.org 2bb47a553eaaece9e2233c2aa68e13b8 *inst/misc/orgmode1.css 529358a88380052a28341c21d0baabc1 *inst/misc/orgmode2.css a402a9e82ee04f0bfa9ed6c8c354beb6 *inst/misc/pairwise-competing-risks-ace.r d669467921cf8bd6e7681c80f2aabcec *inst/misc/pairwise-twostage.r 1257d9cb0e712725280ef468745c04da *inst/misc/pcif.png 7cb154d5d9a561e4411ddc0ea0dcf5e8 *inst/misc/pcif2.png 69ad9d38525badea754eee6418f03a5b *inst/misc/pcifl.png 8e54451b15b8464e07249ae110797b8f *inst/misc/phenotype1.rda 1f3f2c553d732cafd9dcda88afd62864 *inst/misc/run-all.R 077d07fa77ce242fee0ebf61973df731 *inst/misc/sim-cens-ts.r bfb718d4efbf7b6ecdecc927b2448e1e *inst/misc/sim-nordic-twin.r aaa138578e071d0f6abfb77ae48fff12 *inst/misc/twinbmi.R 0ffeb4b1e32703d94206a3218b47618a *inst/misc/twinbmi2.rda ef2ac73a441c20d192204df490a60e00 *inst/misc/workshop-run.html c24ea9ef7c22cdcf1e948cc9151e1ff7 *inst/misc/workshop-src.org cf29a5d5511e766f172e51f34ea02396 *inst/misc/workshop.html 149b74965ecb0639df38e25acc677504 *man/Bootphreg.Rd 24a392e7de82e6c67fc5f087661e692d *man/ClaytonOakes.Rd a26bf2a78cb05f8fdcc9fad96e7d38e5 *man/Dbvn.Rd 4b920ca03e2905b08da8a1af5ef68171 *man/EVaddGam.Rd 0eaf2b32b0517deb83bbc8a2c9ac7682 *man/Grandom.cif.Rd e9dde38ba062553c0384b7adcd3ac2eb *man/LinSpline.Rd d403f51d32262708e366243762e53505 *man/aalenfrailty.Rd 242d5096c86b54fa7e94e8e6bb1afe9b *man/back2timereg.Rd 37cd7c43a5fb8e550e81eccc9d159ebd *man/base1cumhaz.Rd a81a94cb32ea2ecbf65b8e5ad3832d4e *man/base44cumhaz.Rd f2d0a8cc997deac3d37e4220d4b005b4 *man/base4cumhaz.Rd 1ed45663ca83789a79cd4650d4bf662d *man/basehazplot.phreg.Rd 5943a9447005b936382fb3136f727f6e *man/bicomprisk.Rd 7f747cec18edec58d10e61e361305a15 *man/binomial.twostage.Rd 844c4c26d5dff497639cb725762493b5 *man/binreg.Rd 42f03b98443042143ce2869bee9ba108 *man/biprobit.Rd cb4489e92ec9071fa8fb32ac1cfdd5c8 *man/blocksample.Rd 0e9483ae2111140ee191c115ee531058 *man/bptwin.Rd 21cb8ae1138fc1fca526dc24cbb63b4c *man/casewise.Rd 555de864d843288787e2848e6fa34050 *man/casewise.test.Rd c276a15739e985ba5afed222d0973016 *man/cif.Rd f659b587daac8100bd9612ad74db1776 *man/cifreg.Rd 9eb14627cdb4a2f545f7c38da9ed7584 *man/cluster.index.Rd f2760f5b6ea82a11d44d3763f16f3f31 *man/concordanceCor.Rd 99f0f26b79c779e667f54ea351b59c02 *man/cor.cif.Rd 78a360ec4e45a6f6dcdafe681360e365 *man/count.history.Rd 2592ba4da97a82c6c6f0a710023bc0ce *man/covarianceRecurrent.Rd 0a4a663597e5f5c93791751a005c95a9 *man/daggregate.Rd 6eb93f728fd484a228ea0b184f51e46a *man/dby.Rd b2bd16e782f8d37ddac7c28159527195 *man/dcor.Rd 887c13e7a9e501c7c07bf40795c346f8 *man/dcut.Rd bee2f2fd0705c18acc905f882a02eb2d *man/dermalridges.Rd 769e1ece727eb78020f254b0d5480af7 *man/dermalridgesMZ.Rd 3f4a72b8d1f0f2d62dac21b9359bfe40 *man/divide.conquer.Rd 6022db60c476bd980264773ef32fb0a6 *man/divide.conquer.timereg.Rd 09a8091c62ae3879692cf5fe81759583 *man/dlag.Rd 6e16f61658dcdd0bf9de37caea369b8e *man/dprint.Rd 4254e934bf7d260c014e5705f2e67ec9 *man/drcumhaz.Rd 562597a6d90851c3073c7ac3d1a24d6f *man/dreg.Rd 26e17651e77e607df1c084c315dbea74 *man/drelevel.Rd e310f8fcadda96379d2dd4e787b5a5b1 *man/dsort.Rd aa55fa569d42d14383f77ba0dcd12c0a *man/dspline.Rd c4f29fb7a70fadd2a550e782ffac464d *man/dtable.Rd b8273f5278933a35e86aa44a71a08008 *man/dtransform.Rd 8c3dc16b84b38a712f234b46470a1858 *man/easy.binomial.twostage.Rd 507978a9c470d646714d40e77b67bcde *man/easy.survival.twostage.Rd 94b664a2e569aaab9de0dbb8e9b2b11c *man/eventpois.Rd f6a595eb42e4181eda6e3aba2c960651 *man/familycluster.index.Rd 9e994d6c97e0c82c0f95897febbab569 *man/familyclusterWithProbands.index.Rd 4af69539342f4b90d253cb9a0b5f183f *man/fast.approx.Rd b100e520c04a6995ea4d54b52e57fa11 *man/fast.pattern.Rd 4b79d9871b4df487a1994da6320322b7 *man/fast.reshape.Rd d71e37fd52ddcece6d60209112ad7ba6 *man/ghaplos.Rd 633d1ba2d2893f0f6ef42d59cf2744b2 *man/gof.phreg.Rd 55edf6f0165c4e3611f300e5f2811c1c *man/gofG.phreg.Rd 02024e80ea63a38c44fb9c4a5b713cb8 *man/gofM.phreg.Rd e1dbccdc81013c43838228a1cc49d9d6 *man/gofZ.phreg.Rd fd6bfd00dca261b1c8904f41e449029f *man/hapfreqs.Rd f3a4a3e109f2825161edf891ad101d5a *man/haplo.surv.discrete.Rd ecd71b7776dd65b943a670cf6194a9af *man/haploX.Rd 673f1fad59ad2e3b4fb4594bfb6ded57 *man/internal.Rd ae878987e43a32545b4e55e12c706259 *man/interval.logitsurv.discrete.Rd 0a6aa5d6cfead24228a50151eb0f0659 *man/ipw.Rd 5b57e6ae189700ddd778445ff95d7a65 *man/ipw2.Rd c45f355b39c0f7d086770e51c52f9a7b *man/km.Rd 3ebe34a81cd4aefa9732485c496dac11 *man/lifecourse.Rd 64aad75773abe91070da404713e891fc *man/lifetable.matrix.Rd 2b4597c39dcb1a4107dc6ed3516fb24e *man/logitSurv.Rd f9b8859a7bfe0dc41aeaaf6d91cbffa5 *man/mena.Rd 9476be53d0e33eb2e22bc4ea8f3eb702 *man/mets-package.Rd c026e0cd3e567bf4d24600ec0796b3bc *man/mets.options.Rd fc92d08114de9698f0f93ac232d0b4ab *man/migr.Rd 63f411ac16f7b5eb938069064f5b432a *man/mlogit.Rd 963c38c9aec093f952b75a001e1876d6 *man/multcif.Rd 0730c6405e87b448f04af7fef88754d6 *man/np.Rd 3b81ef428bbd1ec8fe0844f1687fbe5b *man/phreg.Rd 313b2f4eea264b051d421e1d0ba14677 *man/phregR.Rd cbd8167a2024fcb40ddbf2eb0b3269dc *man/plack.cif.Rd 9d20261fbe206277495e02d68d01a088 *man/pmvn.Rd 5c1a54a246454d4ff59c9235f93c143d *man/predict.phreg.Rd 664cac9612657755332853904b085668 *man/print.casewise.Rd a63f76a24171785341a13903c742248d *man/prob.exceed.recurrent.Rd 94db9766e13199ea68eee6af4a015579 *man/prt.Rd 976fcce63a0488391862d12473ac2bcb *man/random.cif.Rd 0ee3a433048e605156480820caade074 *man/recurrentMarginal.Rd 2940e9efbc5e7c849916409d6a62e9b2 *man/rpch.Rd c84e2cf7a1599844b9a422d2218ff85d *man/simAalenFrailty.Rd 10e6a1d5a5359b67873764c1ec747e52 *man/simClaytonOakes.Rd cbe072cd58cbf48646ed7f48240b2c30 *man/simClaytonOakesWei.Rd 8a9d6bba21a9f3160967da8f72b909a7 *man/simMultistate.Rd 27cb999b9ae0b499037a528152b1b188 *man/simRecurrent.Rd d3c2c184beafa482f02e21d87c99bebc *man/simRecurrentII.Rd a1d8369ff3008f009d6ab4812591b81f *man/simRecurrentTS.Rd a820b9d1d5667f5b2838d9309efa1d3d *man/summary.cor.Rd f3de654d09da8f734a861ccb4bdedc05 *man/survival.iterative.Rd 8972de7d3f6f971b1cd2ba8e08814558 *man/survival.twostage.Rd edb419306d024fe44f1556edea1f671f *man/test.conc.Rd f9a1792b9b6087b7acf0188b38311fca *man/tetrachoric.Rd 34278e523babe1920ff5b98461a9b0ed *man/ttpd.Rd c220286886a3f87846b6b80fa9153127 *man/twin.clustertrunc.Rd e472dafc182e01068eb917c9542c590f *man/twinbmi.Rd 1d4b21c5489cbeeecf0ef0db3ff2a6de *man/twinlm.Rd 3677adef9eec153a9c298aae4d7600d1 *man/twinsim.Rd 1515ccd70ba9032bd02d4dfb6cd9408b *man/twinstut.Rd 351fa681456727a767f9363967a045fc *man/twostageMLE.Rd 7d88169e165bf1c60255c384d6605ba3 *src/Makevars a0089cc1021ed29c492562045c3dadef *src/Makevars.win 2949d735a9ae15d0c48a74aa20b67c2c *src/RcppExports.cpp a30940a40d78379ef3455dea6a96b974 *src/aalenfrailty.cpp 528f928ae4152018ace94c938cdbec26 *src/apply.cpp 3a298271a03ae8aa7f2479c3bd746c43 *src/binomial-twostage.cpp a5080b6b3788f3a8ec8836b0ca5f71a6 *src/biprobit.cpp 234d9749cb4c0ed5f3b5171df8457feb *src/claytonoakes.cpp 604f715ee8c5ccab97a11bd3d26995f8 *src/clusterindex.cpp 653bdbec0beb490ca26f7547199ece86 *src/cor.cpp 35989b6c2f309b671428d74276304e45 *src/fastcox.cpp 4209af648d7169f85e9100c521baffed *src/fastcox.h 5ed44c63b944ae903201ee21bbb28c83 *src/init.c 082c1ab6fe2b65e57889b454b3769258 *src/mvn.cpp ae56b6ff31658de4ec8162fabee9e275 *src/mvn.h da47b690e3b738fa75d72f825597a13b *src/pch.cpp f2bfd61a310a221f0ce9bad8bc3047a8 *src/prop-odd.cpp 1d99a0831417bc35fe54e9ac05756cde *src/quadrule.h a83c7965c5072d9097831645d9ad8a7b *src/randomF77.c 8bc6d01fa703e6ca02867ae95d3f9344 *src/survival-twostage.cpp d98bb50ef813442c6980a994525eee5d *src/tools.cpp 9f3257d45c3d12b2b41708eaf67c3122 *src/tools.h 9cba1693b9b31affd2d670fdaf2e762d *src/tvpack.f e9f15c515993dce0e74c69682636b8e3 *src/twostage.h ed14a253253696f3a607929e3ad07b95 *tests/test-all.R 4f3dbcd28398e3e587e2e279d81a68d5 *tests/testthat/test_approx.R a39630c75f489709f68995beacbca753 *tests/testthat/test_claytonoakes.R c907788515930df21a6032c27c7976af *tests/testthat/test_dutils.R b725dd8e405af405aa02b0e918e3c2be *tests/testthat/test_reshape.R d835038893d56f0af1628cb410cecdc3 *vignettes/basic-dutils.ltx f1e67c9680d61ac2aeadc51455aeef8d *vignettes/basic-dutils.org fbab3a080f4d20b27056ac6b7dde8ede *vignettes/binomial-case-control-ascertainment.ltx 436197f863d546c90b417228c6611147 *vignettes/binomial-case-control-ascertainment.org 998ecfb2a0857355329aecee710e26b4 *vignettes/binomial-family.ltx 2c2c0b0cca9146cebfa5efeaf2e91c16 *vignettes/binomial-family.org cf9fff39f408ce613043433e9a026d0a *vignettes/binomial-twin.ltx e04e38b17032ee8de491f32f0f95536d *vignettes/binomial-twin.org 3f76e852d56afed0d2a118ce03c2c7a6 *vignettes/competing.ltx 72e184ea7e15da29fe46153f244776db *vignettes/competing.org 62c715f1875530c7e155c387d458efb5 *vignettes/header.org b5d6acb08eac32e7146532dd298447c6 *vignettes/index.html 0789f6831cd6ca9602da06e7e2a5ff84 *vignettes/marg1.jpg 1cafc47debbfcb7eea5c59a473f8bbbf *vignettes/marginal-cox.ltx b988454c71762b1bae0d72918431c449 *vignettes/marginal-cox.org 9a84999ad552c8a71f171ff3f31bd993 *vignettes/mets.bib f92ef80eacbb8d845a9067a4bc5de760 *vignettes/quantitative-twin.ltx 78a7b60cd9d5986b8f2744e8e97e6501 *vignettes/quantitative-twin.org 20c6a8a94575f0645ed9934e00078f8d *vignettes/rec1.jpg 1d096d973d6179b96bc4689323fbe313 *vignettes/rec2.jpg e5fb9ff58376ecad2e90154571a4c7e7 *vignettes/rec3.jpg eb53e9d4529c4783097d5f018bc0c6e7 *vignettes/rec4.jpg b118852f6e942b206daa786f62e66672 *vignettes/rec4Bi.jpg 9e59a1f023228fd070e5479abe7de683 *vignettes/rec4MV.jpg 578ebecd31adb287d3f74fc68b3e57d4 *vignettes/rec5.jpg d9c87f8885659813a0524dba488a56da *vignettes/rec6.jpg 225f3c61c2f04f6e50ff637756155bc8 *vignettes/rec7.jpg 0bda4054faeeb4f6702c9e9ddc5af067 *vignettes/recurrent-events.ltx 9f6098da7bbd101e6f6220fa4d882904 *vignettes/recurrent-events.org 1b26ed8aa1e3dca95d448b17173c0d5f *vignettes/robcox1.jpg 30c39cb6691b669fb5e46effb8e147d0 *vignettes/robcox2.jpg 41d23ee907cf1aba9a2b24c7525406ec *vignettes/robgofcox1.jpg d24990f90897fe61a3ebcdb64773f6ca *vignettes/scatter1.jpg 65df7ff0a60591a47f8effd9035c3867 *vignettes/scatter2.jpg 27de4cf04bfe79129edceebe11758633 *vignettes/surv-cc-base.jpg 024b0a2b44d790094c0e01bc1af1b56d *vignettes/twostage-survival-case-control.ltx c2305f22979ccf7a96d8f50b2ebd701f *vignettes/twostage-survival-case-control.org c8d6f19ae15006011b190effc707c445 *vignettes/twostage-survival.ltx b0381617fa836e1fe4b24e90eee081d6 *vignettes/twostage-survival.org mets/inst/0000755000176200001440000000000013623061747012210 5ustar liggesusersmets/inst/misc/0000755000176200001440000000000013623061405013132 5ustar liggesusersmets/inst/misc/orgmode1.css0000644000176200001440000003500713623061405015366 0ustar liggesusers/* orgmode.css - CSS Stylesheet for http://www.biostat.ku.dk/~kkho Copyright (C) 2013 Klaus K. Holst Author: Klaus K. Holst This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ /* /\* Solarized colors *\/ */ /* $base03: #002b36; */ /* $base02: #073642; */ /* $base01: #586e75; */ /* $base00: #657b83; */ /* $base0: #839496; */ /* $base1: #93a1a1; */ /* $base2: #eee8d5; */ /* $base3: #fdf6e3; */ /* $yellow: #b58900; */ /* $orange: #cb4b16; */ /* $red: #dc322f; */ /* $magenta: #d33682; */ /* $violet: #6c71c4; */ /* $blue: #268bd2; */ /* $cyan: #2aa198; */ /* $green: #859900; */ /* @mixin rebase($rebase03,$rebase02,$rebase01,$rebase00,$rebase0,$rebase1,$rebase2,$rebase3) */ /*************************************************/ /* General */ /*************************************************/ html { margin-top: 0.6em; margin-left: 0.8em; margin-right:0.8em; background: rgba(230,230,230,1.0); } body { text-align:justify; text-justify:inter-word; font-size: 12pt; font-family: arial, helvetica, sans-serif; color: #000000; margin-top: 0em; margin-left: .5em; margin-right: .5em; margin-bottom: 0.6em; background-color: #ffffff; background-image: url(http://www.biostat.ku.dk/~kkho/styles/logo.png); background-position: 5px 7px; background-repeat: no-repeat; border-top: 1px solid gray; border-bottom: 1px solid gray; border-right: 1px solid gray; border-left: 1px solid gray; padding-bottom: 0.5em; min-width: 800px; } #box-link { padding-left: 0em; padding-right: 0em; margin-left: -1.7em; top:0.5em; position: absolute; width: 90px; height: 110px; list-style: none; border: 1px solid transparent; } div { margin-left: 1.0em; margin-right: 1.0em; } dt { margin-left: 1.0em; margin-right: 1.0em; } p { margin-left: 1.0em; margin-right: 1.0em; } /* Two-columns in

environment... */ .columns { -moz-column-count:2; /* Firefox */ -webkit-column-count:2; /* Safari and Chrome */ column-width:100px; min-width:100px; column-count:2; } .title { /* [-moz- | -webkit-]column-span: all; */ } /*************************************************/ /* Headers */ /*************************************************/ h1, h2, h3, h4, h5, h6 { margin-top: .25em; margin-bottom: .2em; color: black; background: none; font-variant: small-caps; text-transform: none; font-weight: 100; margin-bottom: 0; font-weight:bold; } h2,h3,h4 { background-image:url(http://www.biostat.ku.dk/~kkho/images/dline.png); background-repeat: repeat-x; } h1 { color: black; font-weight: normal; letter-spacing: .02em; line-height: 1.1em; margin:0px; font-size: 2em; padding-top: 1em; padding-bottom: 1.0em; } .title { padding-left: 2.9em; text-align:left; font-weight:bold; } h2 { color: #6E2432; font-size: 1.4em; margin-top:.8em; margin-bottom:.5em; height:40px; padding-top: .3em; padding-bottom: 0.2em; } h3 { color: rgba(149,54,34,1); /* #A34D32; */ font-size: 1.2em; margin-top:1.5em; margin-bottom:.5em; height:40px; padding-top: .4em; padding-bottom: .1em; } h4 { color: rgba(163,107,40,1); /* #A34D32; */ /* #CC6600; */ font-size: 1em; margin-top:1.5em; margin-bottom:0em; height:40px; padding-top: .6em; padding-bottom: 0em; } h5 { color: #CC6600; /* #98855b; */ font-size: 1em; } /*************************************************/ /* Table of Contents */ /*************************************************/ /* Contents inspired by http://jashkenas.github.com/coffee-script */ #table-of-contents { z-index: 20; /* larger than navigation */ font-weight:bold; font-size: 10pt; position: fixed; margin-right: 0em; right: 0em; top: 0em; background: white; box-shadow: 0 0 1em #777777; -webkit-box-shadow: 0 0 1em #777777; -moz-box-shadow: 0 0 1em #777777; -webkit-border-bottom-left-radius: 5px; -moz-border-radius-bottomleft: 5px; text-align: right; /* ensure doesn't flow off the screen when expanded */ max-height: 80%; } #table-of-contents h2 { background-image: none; filter: alpha(opacity=80); opacity: 0.8; color: rgba(20,50,134,1); /* #A34D32; */ font-size: 10pt; max-width: 9em; margin-top:.15em; margin-bottom:.2em; height:1.3em; font-weight: normal; font-weight:bold; padding-left: 1.7em; padding-right: 1.7em; padding-top: 0.2em; padding-bottom: 0.05em; } #table-of-contents #text-table-of-contents { font-size: 10pt; display: none; text-align: left; } #table-of-contents:hover #text-table-of-contents { overflow: auto; display: block; padding: 0.5em; margin-top: -1em; } /*************************************************/ /* Paragraphs */ /*************************************************/ .bigskip { color: red; } /*************************************************/ /* Tables */ /*************************************************/ table { /* font-family: Monaco, Consolas, "Lucida Console", monospace; */ font-size: 90%; margin: 1em 1em 1em 0; background: #f9f9f9; border: 1px #aaaaaa solid; border-collapse: collapse; box-shadow: 5px 5px 5px #999999; -webkit-box-shadow: 5px 5px 6px #999999; -moz-box-shadow: 5px 5px 6px #999999; } table th, table td { border: 1px rgb(232,232,232) solid; padding-left: 0.5em; padding-right: 0.5em; } td,th { padding-bottom: 0.2em; padding-top: 0.2em; } table th { background: #ccc; text-align: center; } table tr:nth-of-type(odd) { background-color: #eee; /* #E6E6FA; */ } /* table#plain tr:nth-of-type(even) { */ /* background-color: #ccc; /\* #E6E6FA; *\/ */ /* } */ /*table tr.stripe { background-color: #cfcfcf; } */ table caption { margin-left: inherit; margin-right: inherit; } .plain,.plaincenter,.plainright { font-size: 100%; border-color: #fff; color: black; text-align: center; padding: 0em; background: #fff; box-shadow: none; -webkit-box-shadow: none; -moz-box-shadow: none; } .plaincenter { margin-left: auto; margin-right: auto; } .plainright { margin-left: auto; } table#plain tr:nth-of-type(odd) { background-color: white; /* #E6E6FA; */ } .plain tr, .plain td, .plain th .plaincenter tr, .plaincenter td, .plaincenter th .plainright tr, .plainright td, .plainright th { background: #fff; border-color: #fff; padding-bottom: 0em; padding-top: 0em; } /*************************************************/ /* images & verbatim */ /*************************************************/ img, img.src { font-family: Monaco, Consolas, "Lucida Console", monospace; -webkit-box-shadow: 5px 5px 6px rgba(0,0,0,0.23); -moz-box-shadow: 5px 5px 6px rgba(0,0,0,0.23); box-shadow: 5px 5px 6px rgba(0,0,0,0.23); border: 1pt solid #AEBDCC; /* #eee; */ padding: 0pt; margin: 10pt; } /* Source blocks */ pre { font-family: Monaco, Consolas, "Lucida Console", monospace; -webkit-box-shadow: 5px 5px 6px rgba(0,0,0,0.23); -moz-box-shadow: 5px 5px 6px rgba(0,0,0,0.23); box-shadow: 5px 5px 6px rgba(0,0,0,0.23); border: 1pt solid #AEBDCC; padding: 5pt; font-size: 90%; overflow: auto; } /* results */ pre.example { font-family: Monaco, Consolas, "Lucida Console", monospace; -webkit-box-shadow: 5px 5px 6px rgba(0,0,0,0.23); -moz-box-shadow: 5px 5px 6px rgba(0,0,0,0.23); box-shadow: 5px 5px 6px rgba(0,0,0,0.23); border: 1pt solid #AEBDCC; background-color: #FFFFFF; /* #F3F5F7;*/ padding: 5pt; font-size: 90%; overflow: auto; margin: 0em; margin-left: 2.5em; margin-right: 2.5em; color: rgba(75,75,75,1); } pre.src { background-color: #ddd; color: #000; position: relative; overflow: visible; padding-top: 0.5em; padding: 0.5em; margin: 1em; } pre.src:before { display: none; position: absolute; background-color: white; top: -10px; right: 10px; padding: 3px; border: 1px solid black; } pre.src:hover:before { display: inline;} pre.src-sh:before { content: 'sh'; } pre.src-R:before { content: 'R'; } a:hover > img { /* border:5px solid; */ } /* a.image-link img { */ /* border:1px solid #000; */ /* margin-right:20px; */ /* } */ p.image-link { float:left; } /*************************************************/ /* Specific org entries */ /*************************************************/ .org-string { color: #00008a; } .org-constant { color: #E3319D; } .org-type { color: #4AA02C; } .org-comment-delimiter { color: #827839; } .org-comment { color: #aaa; } .org-keyword { color: #38ACEC; } .org-function-name { color: #FBB117; } #postamble { font-size: 60%; margin-top: 5em; padding: .1em; border: 1px solid gray; background-color: #eeeeee; } /*************************************************/ /* Navigation bar */ /*************************************************/ /* http://onwebdev.blogspot.com/2011/04/css-drop-down-menu-tutorial.html */ #navigation { z-index: 10; /* small than table of contents */ float:left; padding-left: 4.4em; top:0.64em; position: absolute; margin: 0; list-style: none; min-width: 50px; font-weight: bold; color: #6E2432; } #navigation > li { font-size: 60%; line-height: 3.5; text-transform: uppercase; float: left; height: 100%; color: #6E2432; margin-right: 0.5em; height: 100%; padding: 0 1.5em; } li:hover a { background: transparent; } #navigation > li > a { color: rgba(20,50,134,1); /* #A34D32; */ text-transform: uppercase; } #navigation > li > a:hover { /* color: orange; */ /* text-decoration: underline; */ } #navigation > li.sub { position: relative; } #navigation > li.sub li { line-height: 1.5; } #navigation > li.sub ul { width: 20em; margin: 0; margin-top: 0.5em; line-height: 1.1; text-transform: none; font-size: 140%; padding: 0.5em 0 0.2em 0; list-style: none; border-bottom: 1px solid #ccc; border-top: 1px solid #ccc; border-right: 1px solid #ccc; border-left: 1px solid #ccc; box-shadow: 0 0 1em #777777; -webkit-box-shadow: 0 0 1em #777777; -moz-box-shadow: 0 0 1em #777777; -webkit-border-bottom-left-radius: 5px; -moz-border-radius-bottomleft: 5px; background: #fff; position: absolute; top: -1000em; overflow: visible; } #navigation > li.sub ul li { width: 90%; margin: 0 auto 0.3em auto; } #navigation > li.sub ul li a { font-size: 80%; height: 100%; display: block; padding: 0.25em; color: #6E2432; color: rgba(20,50,90,1); font-weight: bold; text-decoration: none; } #navigation > li.sub ul li a:hover { background: rgba(240,240,245,1); /* #c60; */ /* opacity: 1; */ /* text-decoration: underline; */ } #navigation > li.sub:hover ul { top: 1.5em; left: 0em; } /* Another simple navigation style */ #nav { width: 100%; float: left; margin: 0 0 3em 0; padding: 0; list-style: none; background-color: #f2f2f2; border-bottom: 1px solid #ccc; border-top: 1px solid #ccc; } #nav li { float: left; } #nav li a { display: block; padding: 8px 15px; text-decoration: none; font-weight: bold; color: #069; border-right: 1px solid #ccc; } #nav li a:hover { color: #c00; background-color: # } /*************************************************/ /* Links */ /*************************************************/ a { filter: alpha(opacity=80); opacity: 0.8; transition: opacity .35s ease-in-out; -moz-transition: opacity .35s ease-in-out; -webkit-transition: opacity .35s ease-in-out; } a,a.plain { text-decoration: none; border: none; background: none; color: rgba(20,50,134,1); /* #A34D32; */ } a:hover,a.plain:hover { /* text-decoration: underline; */ color: #6E2432; /* filter: alpha(opacity=100); */ /* opacity: 1; */ /* zoom: 1; */ /* border: 1px solid black; */ /* opacity: .5; */ } /* a.image-link img */ /* { */ /* opacity: 1; */ /* transition: opacity .25s ease-in-out; */ /* -moz-transition: opacity .25s ease-in-out; */ /* -webkit-transition: opacity .25s ease-in-out; */ /* } */ /* a.image-link:hover */ /* { */ /* opacity: 0.4; */ /* } */ /* .fade:hover { */ /* opacity: 0.2; */ /* } */ /*************************************************/ /* Hrz. rule */ /*************************************************/ hr { height: 1px; color: #aaa; background-color: #ddd; margin: 1em 0 .2em 0; } /*************************************************/ /* Fancy stuff */ /*************************************************/ div.shadow { width: 300px; margin: 20px; border: 1px solid #ccc; padding: 10px; } div.shadow:hover { -moz-box-shadow: 0 0 5px rgba(0,0,0,0.5); -webkit-box-shadow: 0 0 5px rgba(0,0,0,0.5); box-shadow: 0 0 5px rgba(0,0,0,0.5); } .fade { opacity: 1; transition: opacity .25s ease-in-out; -moz-transition: opacity .25s ease-in-out; -webkit-transition: opacity .25s ease-in-out; } .fade:hover { opacity: 0.5; } .reflectionstop { border: none; /* #eee; */ -webkit-box-reflect: below -2px -webkit-gradient(linear, left top, left bottom, from(transparent), color-stop(80%, transparent), /* to(white)); */ to(rgba(255,255,255,0.4))); } mets/inst/misc/pairwise-competing-risks-ace.r0000644000176200001440000002352513623061405021011 0ustar liggesusers library(mets) set.seed(100) n <- 40000 ## {{{ competing risks ace model with profile of baseline lam0 <- c(0.3,0.2) pars <- c(1,1,1,1,0.1,1)*0.25 ## genetic random effects, cause1, cause2 and overall parg <- pars[c(1,3,5)] ## environmental random effects, cause1, cause2 and overall parc <- pars[c(2,4,6)] ## simulate competing risks with two causes with hazards 0.5 and 0.3 ## ace for each cause, and overall ace out <- simCompete.twin.ace(n,parg,parc,0,2, lam0=lam0,overall=1,all.sum=1) ## setting up design for running the model ## {{{ setting pairs and random effects # mm <- familycluster.index(out$cluster) head(mm$familypairindex,n=10) pairs <- matrix(mm$familypairindex,ncol=2,byrow=TRUE) tail(pairs,n=12) # kinship <- (out[pairs[,1],"zyg"]=="MZ")+ (out[pairs[,1],"zyg"]=="DZ")*0.5 dout <- make.pairwise.design.competing(pairs,kinship, type="ace",compete=length(lam0),overall=1) head(dout$ant.rvs) ## MZ dim(dout$theta.des) dout$theta.des[,,1] dout$random.design[,,1] dout$theta.des[,,nrow(out)/2] dout$random.design[,,nrow(out)/2] ###table(out$status) ## }}} ## competing risks models, given as list cr.models=list(Surv(time,status==1)~+1, Surv(time,status==2)~+1) ms <- out$time %o% lam0 par(mfrow=c(1,1)) tsf <- twostage(NULL,data=out,clusters=out$cluster, theta=0.01+pars/sum(pars)^2, var.link=0,step=1.0,Nit=20,detail=1, random.design=dout$random.design, theta.des=dout$theta.des,pairs=pairs, numDeriv=0, marginal.status=out$status, marginal.survival=ms, two.stage=0,cr.models=cr.models) coef(tsf) pars/sum(pars)^2 summary(tsf$marginal.trunc) summary(tsf$marginal.surv) ###tsf$score; tsf$score1 ### source("../R/twostage.R") par(mfrow=c(1,1)) ts <- twostage(NULL,data=out,clusters=out$cluster, theta=tsf$theta, step=1.0,Nit=20,detail=1, random.design=dout$random.design, theta.des=dout$theta.des,pairs=pairs, numDeriv=0, marginal.status=out$status, two.stage=0,cr.models=cr.models) coef(ts) pars/sum(pars)^2 matplot.twostage(ts) abline(c(0,lam0[1])); abline(c(0,lam0[2])); system.time( out1 <- aalen(cr.models[[1]],data=out,robust=0) ) system.time( out1 <- aalen(Surv(time,status!=0)~+1,data=out,robust=0) ) ## }}} onec <- 1 if (onec==1) { ## {{{ one cause ACE survival # lam0 <- c(0.5) pars <- c(1,0.5); pars <- c(0.5,1); out <- simCompete.twin.ace(n,pars[1],pars[2],0,2,lam0=lam0,overall=0) ## {{{ mm <- familycluster.index(out$cluster) head(mm$familypairindex,n=10) pairs <- matrix(mm$familypairindex,ncol=2,byrow=TRUE) tail(pairs,n=12) # kinship <- (out[pairs[,1],"zyg"]=="MZ")+ (out[pairs[,1],"zyg"]=="DZ")*0.5 dout <- make.pairwise.design(pairs,kinship,type="ace") head(dout$ant.rvs) ## MZ dim(dout$theta.des) dout$theta.des[,,1] dout$random.design[,,1] ## DZ dout$theta.des[,,nrow(out)/2] dout$random.design[,,nrow(out)/2] ## }}} lams <- cbind(lam0[1]*out$time) table(out$status) ts <- twostage(NULL,data=out,clusters=out$cluster, theta=pars/sum(pars)^2, var.link=0,step=1.0,Nit=10,detail=0, random.design=dout$random.design, theta.des=dout$theta.des,pairs=pairs, numDeriv=0, marginal.surv=lams, marginal.status=out$status, two.stage=0) summary(ts) ts2 <- twostage(NULL,data=out,clusters=out$cluster, theta=ts$theta, var.link=0,step=1.0,Nit=10,detail=1, random.design=dout$random.design, theta.des=dout$theta.des,pairs=pairs, numDeriv=0, marginal.status=out$status, cr.model=list(Surv(time,status)~+1), two.stage=0) summary(ts2) ts2$score ## }}} } twoc <- 1 if (twoc==1) { ## {{{ two cause two independent ACE survival # lam0 <- c(0.5,0.4) pars <- c(0.5,1,0.5,1)*0.5; out <- simCompete.twin.ace(n,pars[c(1,3)],pars[c(2,4)],0,2,lam0=lam0,overall=0) table(out$status) out$status1 <- out$status==1 table(out$status1) ## {{{ mm <- familycluster.index(out$cluster) head(mm$familypairindex,n=10) pairs <- matrix(mm$familypairindex,ncol=2,byrow=TRUE) tail(pairs,n=12) # kinship <- (out[pairs[,1],"zyg"]=="MZ")+ (out[pairs[,1],"zyg"]=="DZ")*0.5 ###kinship <- c(rep(1,5000),rep(0.5,5000)) ### ###source("mets/R/twostage.R") ###dout <- make.pairwise.design(pairs,kinship,type="ace") dout <- make.pairwise.design.competing(pairs,kinship, type="ace",overall=0,compete=2) head(dout$ant.rvs) ## MZ dim(dout$theta.des) dout$theta.des[,,1] dout$random.design[,,1] dout$theta.des[,,nrow(out)/2] dout$random.design[,,nrow(out)/2] ### ### ###out$status[out$status==3] <- 2 # table(out$status) ## }}} ###lams <- cbind(lam0[1]*out$time,lam0[2]*out$time) lams <- cbind(out$time*lam0[1],out$time*lam0[2]) ts <- twostage(NULL,data=out,clusters=out$cluster, theta=pars/sum(pars)^2, var.link=0,step=1.0,Nit=10,detail=1, random.design=dout$random.design, theta.des=dout$theta.des,pairs=pairs, marginal.surv=lams, marginal.status=out$status, two.stage=0) summary(ts) ts$score ts2 <- twostage(NULL,data=out,clusters=out$cluster, theta=pars/sum(pars)^2, var.link=0,step=1.0,Nit=20,detail=1, random.design=dout$random.design, theta.des=dout$theta.des,pairs=pairs, marginal.status=out$status, two.stage=0, cr.models=list( Surv(time,status==1)~+1, Surv(time,status==2)~+1) ) ts2$theta pars/sum(pars)^2 matplot.twostage(ts2) abline(c(0,lam0[1])); abline(c(0,lam0[2])); } ## }}} itwoc <- 1 if (itwoc==1) { ## {{{ cause specific analyses because independence lam0 <- c(0.5,0.4) pars <- c(1,0.5); pars <- c(0.5,1,0.5,1); out <- simCompete.twin.ace(n, pars[c(1,3)],pars[c(2,4)], 0,2,lam0=lam0,overall=0,all.sum=1) table(out$status) ## {{{ mm <- familycluster.index(out$cluster) head(mm$familypairindex,n=10) pairs <- matrix(mm$familypairindex,ncol=2,byrow=TRUE) tail(pairs,n=12) # kinship <- (out[pairs[,1],"zyg"]=="MZ")+ (out[pairs[,1],"zyg"]=="DZ")*0.5 ###kinship <- c(rep(1,5000),rep(0.5,5000)) ### ###source("mets/R/twostage.R") ###dout <- make.pairwise.design(pairs,kinship,type="ace") dout <- make.pairwise.design.competing(pairs,kinship, type="ace",overall=0) head(dout$ant.rvs) ## MZ dim(dout$theta.des) dout$theta.des[,,1] dout$random.design[,,1] ## DZ dout$theta.des[,,nrow(out)/2] dout$random.design[,,nrow(out)/2] ### ### # table(out$status) out$statusc1 <- 1*(out$status==1) out$statusc2 <- 1*(out$status==2) ## }}} ## design for only cause 1 dout1 <- make.pairwise.design(pairs,kinship, type="ace") ## competing risks models, given as list cr.models=list(Surv(time,status==1)~+1,Surv(time,status==2)~+1) ts <- twostage(NULL,data=out,clusters=out$cluster, theta=pars, score.method="fisher.scoring", var.link=0,step=1.0,Nit=10,detail=0, random.design=dout$random.design, theta.des=dout$theta.des,pairs=pairs, numDeriv=0, marginal.status=out$status, two.stage=0,cr.models=cr.models) coef(ts) ### considering cause 1 alone cr.models1=list(Surv(time,statusc1==1)~+1) ## note due to parametrization ags=2 ! ts1 <- twostage(NULL,data=out,clusters=out$cluster, theta=pars[1:2], var.link=0,step=1.0,Nit=10,detail=0, random.design=dout1$random.design, theta.des=dout1$theta.des, pairs=pairs, marginal.status=out$statusc1, two.stage=0, cr.models=cr.models2) summary(ts1) ### considering cause 2 alone cr.models2=list(Surv(time,statusc2==1)~+1) ts2 <- twostage(NULL,data=out,clusters=out$cluster, theta=pars[1:2], var.link=0,step=1.0,Nit=10,detail=0, random.design=dout1$random.design, theta.des=dout1$theta.des,pairs=pairs, marginal.status=out$statusc2, two.stage=0, cr.models=cr.models2) summary(ts2) ## }}} } ## {{{ 2 compete+ overall ace, dependence test, cox ### conditional cox model lam0 <- c(0.5,0.5) pars <- rep(1,6) out <- simCompete.twin.ace(n,c(1,1,1),c(1,1,1),0,2, lam0=lam0,overall=1,all.sum=1) table(out$status) ### out2 <- fast.reshape(out,id="cluster") ### out2$mintime <- pmin(out2$time1,out2$time2) out2$whichmin <- ifelse(out2$time1out2$time2,out2$status1, out2$status2) ### out1 <- event.split(out2,time="time1",status="status1", cuts="time2") out1$mstat <- out1$status2*out1$num head(out1[out1$whichmin==2,]) head(out1[out1$whichmin==1,]) table(out1$status1) table(out1$mstat) ###out1[out1$num==1,] out1$mincause[out1$num==0] <- 0 ### coxph(Surv(start,time1,status1==1)~factor(mstat)*factor(zyg1),data=out1) ### coxph(Surv(start,time1,status1==2)~factor(mstat)*factor(zyg1),data=out1) mm <- familycluster.index(out$cluster) head(mm$familypairindex,n=10) pairs <- matrix(mm$familypairindex,ncol=2,byrow=TRUE) tail(pairs,n=12) # kinship <- (out[pairs[,1],"zyg"]=="MZ")+ (out[pairs[,1],"zyg"]=="DZ")*0.5 dout <- make.pairwise.design.competing(pairs,kinship, type="ace",compete=length(lam0),overall=1) head(dout$ant.rvs) ## MZ dim(dout$theta.des) dout$theta.des[,,1] dout$random.design[,,1] ## DZ dout$theta.des[,,nrow(out)/2] dout$random.design[,,nrow(out)/2] ### ### cr.models=list(Surv(time,status==1)~+1,Surv(time,status==2)~+1) ts <- twostage(NULL,data=out,clusters=out$cluster, theta=pars, score.method="fisher.scoring", var.link=0,step=1.0,Nit=20,detail=0, random.design=dout$random.design, theta.des=dout$theta.des,pairs=pairs, marginal.status=out$status, two.stage=0,cr.models=cr.models) ## }}} mets/inst/misc/pcif2.png0000644000176200001440000004005413623061405014646 0ustar liggesusersPNG  IHDR) IDATxy\?lkkj%S[\ceX42\K]gH[ZVb"" ,y=1aΙ70g3 ˲#  RhB@@")4H!D  RhB@@")4H!D  RhB@@")4H!D  RhB@@")4H!D  RhB@@")4H!D  RhB@@")4H!D  RhB@@")4H!DJ!tSXX?,+t!pJrԩr\B~nl;޿ɓ'B֬Yc2²BW! :~4_ ۱c 1"jB?ׅ3OGz>..W^>>>֭3 ²ljjjLLLvvʕ+)z۶m/^V;uꄆ)B??aLbQl4iRTTԩS+**&L 7lؠV322L&SPPԩSj5?{.3V*j M)AlrFU*?{.36mѣ***/^ jZ~nu*JP( gg'x"!!A?["ٳj'66vϞ=iiiv `˛3gϟ?/tE3sЁgϞݻ\._rwn8Yonnn'N_r֭[.x~~tG :tƌD4t޽{/iѢE{s QF%&&QVVȑ#0 ߵkWoo5k֘-Zdɒ;zxx,[=:tP???:|Wlݺaaa7oB?qRRR]ƭ._|̘1zKZlٲeZ˃wWV8шJiV~:^/!"Z=s̝;wfeeM0K.]t<::k̏ ~F?󄕔snڴI*XGGǚ>(˲^^^5[n6 RyAr(zeew^zĉk$??߼ּysHMC SM&t~F??`79r\/tޝ<<<233,wa:88p^s(?Ȟ;w;３ۻw︸/1/[3τ~툣tǎ,˾t 7o6{n@@'XqnYZZڪU={Ԫn8\kKs-ޥFV^?rbbb233Ne??g}6qH//ÇO6nnnqqqjYYY{gqCB^q͛7gff )Sjq>"4f͚m߾qC.̃SLy5*##?4e-`~zC??0a?@ ` JVk.88xƌ n"_I&æjd]KTg~`2 F.\(H%?3gͬfŊB`5g1@@[6s}q0WM<ۻ}֭g@?$]ƼOhhݬIܚS&}"LU% ,`Y6==].ϮC=$\S ]tEFYjuYf1 YUUUswSLٱc^RZ|mvm߾_Ϟ=5`0XaĈ ,dѼW pg[Ç^102lk8n=`6/^|y^VE G")4H!D  R`f5GT*P4Y 0G}t h!7|嗍Fе4Y\@Kvb*oe?nyyիk-Zx饗qanߧO={… XeY/99̍3f0bڴi}5W ~g$,˖-7oVݹs~ب $lߚ\@%*""b/#GnNE'''"ZtiDDyŋ<**j,ˎ3a37FFFN<9//ɓaaa-ZG@?۷&w_K,),,#5CQ󌞏=c۷o߿߿cܹsy޽{qrpp5jԮ]'Ov ,:̝;wӦMBW:::\]]iӦ͘1rӧO綩{5kVVmVQQӲeKV˲l@@'XYݵk׀|||JJJ^!Cдi҄Bud#z͏Ot:]6mڶmWZuGqtһwo̍CMLLF`SgqQۈH8xֳgݻw%v{!-:~nr6-z>99ƍÆ B?NqݻG iM0a„ BW`4H!"##cر~~~&Mk{Y h!_߿ZZZzzz``Z"C?!N>=}tOOOggŋ{zz ]@áE  zꩧvUYYqF"z^YYY#G ޤh۷_n7hqK"b&>>k׮}Yւ~vGRoecޡ}˞/z6}_|GEEEM8qժUG^O=̙3wܙ5a„.]te,˦ٳgsVݒVff3g<8zs6g@?;c#"|SSVV֔)S˲ٳgtR\\p5k֬^^cY˫|֭,r[XܒeY"*--5/?BJZ,p!<==_ND~˗3{yxxdffrqPd;|G丹#A?!FYfРAD0̨Q>Á:s̀hk׮ǏܹsYY1beee;[ϢnM6)ʮ]vŋD7WLLLffԩSlGD1r}-l ,^6:ub#"9g'~v{NZud#hB@@")4H!D  Rқرc:N*.;;[Nua,#s ]; kua,M63g @?HN D  RhB@@")^jnzڴi3wr~`]gOO0ӧO:Ų9s;uo߾L///"ZjU˖-;u;]RRr n5--ÃXxS@'44#r~~tرc,ݼyT*?OwB??;0?_[@?p4H!Dܹ30JRu7~`]gOϝ;׷o{ou|h,--5jYvu~~r|ʔ)uoe˖ZgΜ ji~~wٳQFUkp޼y+ |H R#G 4gFXl8Dqqqz 񉈈Xn`gօ~~tGtttJJJlllHH˲111+W+B??x m۶]xZsĭeK44X-_ߣ- 2>t h_Zv p_cǹG3o{U`ɤ)*tee++5%A+tupVydo+x/ 681n.Q/.E\oRqz#wpYG Vp[f5G"׼=,HrC^ܪB tngۓO-VrV ڶnR@@CJI9lIVѹcQV`u?YύWBF.mhhohӆ[e:˝ [-4nz .\")4H4ػҌ ^Gn<'GzP'Z}?V^U=#A:L*IOgLڶVmȳ [ ur$#m[{Y\p,}%f9?쳨-Z\ \di'?-:/˩+3l^_Ŋba6yǻ\kv;X,__ggg{m߾}TT?x.*P (E~K^>8Vk.ʂ^fسgρviϞ=111AAA?X ҼG\.2tW^ݿΝ;=zt'O_}Uh<3HsΝ[hQdd " :k@?DY褤M6qz]vJr„ <D$t-~XRIg:CD9Ǐ ]ezȐ!'"ãF(׉̗_F[A?EDto2gώȲo>"z!2tD7L;E|Mti5nVOۼDK`k0P~vX>Łn䎎ż(,$+ɔwF h,S? ꮫ8ywZ*$5]5wA A?uͲlg=wn\>A}%^▷G+oV>]. @h&=o>i6mDTpܖ緺N,gKQ744?{| @?CM$_;-W4]*2"j5= p,9"G+"2Fto`E=DS .\bŽ`$ <ҺϝSvӻzk t;e*h`(m=u ;ҝ|sqqqz 񉈈Xn7g 䠟 KDszTWr@9Yf>>><̍7]vƦ^vmxwu~"bM&MQQ^bb^bb t`hW 򇄓'O5jOLrСf۶m/^V;urƼ-EzzY[(h)J32Jn_~ɤƑ\W}Sl^%:---::ZPѢE a 4)+j}Q!5l[UTACw1{OݟV˖-{׉?3&MCBBrJLL fJMɉ ?rk#zX m8 'G&NzxН/6/77lؠV322L&SPPԩSj_ |8%x\P* l&s;ܥw}i-w׈\er@\ѣ+Wۺuk=ٹs .( #3<6dJs < \5wX肂>}꫃Zr{v lIe9x≄"Zf͚5kl#G 6 m" N,oZz޹,I'7jB?30;fWbs+9Nx31ѩy޽-o ]_zZk}m*VϬm%sUĎ3s@"JO`7sg;QT݁;EFʟ XZXer-oQ[q ^̋~F>IG_K%m-Çx <$ e9׮]˲lxxxxx8a/43]^GV|Ej)lܸjll':{K"7o}E[1""+I^TYWZjll'*n$"^Tyzzw6{LQ0Է?EQ5r :|=uT"5ySuJy3,IDATO_%tQ8$ e9QoZ]砓"""\\\O>-TM ҅_WC2rn)tM~+O>qĢ & Bba2P4ҒwOk3H]܈{֌~'z&E_FD41[iZPp3~yH&̿WW]+U72Le4A?ČF{ T Oy삋r픻Wuw!A{xnYkj3!Φ=.g98ܵEg{ٴ:]`"җ n-tQVVW:DTw(kiڨωՍQ݇5G.NKDU: B@UY"ҕK^C@Uܼi*X­zv&lIViSyy͸zV*lmŸ$_v:BDt+Ar]i".v"h?Ebh;g"\Ӌ|)t%-ɤ3"s hh*dRȷS"D@@ݓZO ")?,k,v*ss݅.mwRSuم&#f~43)b2V_i4WgjJL"S)}„,ZXF5~Ư>#wo%PiVXZzn~ɡT؊lLƑP*4 =VnBPW{KaH#"g;sDBW,;wq޽U^MqHE"SVeFڍ-hE6)'^ :Tyb @@7}ڲ2"MDw-. m/ڎUc )*")4H!D 6A&߸]ͭuAh:**yymz;A7AUEg~ꫜ==DU$o;A7YMy"J\w/q Hՙ s˹L6eiδJn2o{G@mUUnRS,ӘrG~~\9Ү]3~vMh{ g4I~u 99U吣o{裿3y#41F%v|;?CD< ""m nDKD7ׯ%7yM%!L矄Tu*-HDι;RKwú;[V Ch!_<k駟͟?޽*ꩧZt+9 Dtw+y B?IWRBDmJ?IԕO]WodeƌiiӓV*X^?}taN>})e̙ށX9xV1Vw:u֯?=})A?ɨQѣg\:{ɵm tEEdSǾ}233hժU-[s`;4p`+ݟz~擃G۶DD:oʰչW_ֈeBGtIIIHHȍ7NKKMG> KrҥOGƏ `=f<t>}BCCu:ݼy80nܸ%KwB?7=r9paO>v˲yyy7o$"J?<}!_={^_m; g8'p pt^aaՂ摧(`=C?KĮ^XPP}7~x h^q͛7gff )SjbKB![U,u/.XpUTʹp?aK~NII aY6555&&&;;{ʕwl#=Db~:%-[FN ޶mŋsw -%ݺm9ҼP /2ad.Q^^_kh4ڲ.*(~_ܲF[FD׭Zm[۵W0hPknO S@O4)**? aʕ+111&LxK? Ͼ6kѥ5tz# \b~KGR㖫ʋee+W"JRV?dYAD䠑iLåKR*C߰@?KDѨ*ַnq2wm{ѣ5G~Ս`9rdذaF/hz0^egbYw'H{#)a2?N HۿǹUy>֟Ϻ mG 9SI"""cU[l>je5]g*r,'罈كˡ>7@@?$L2uܲdhp:;+==z)}ʛi]–$hq4i&d[=.`=t5TJ#UX71W^kL t{t#B!0t_KUF.o?~6ҥx  -Y<"C#IOi-מ \XZJɝ <ҽ| -q=bɧ+h`3v`~15>\^C@}[xu+lIV6]YFQDD&\-h{<-t6¢\n9U"nP62z2ߌ͹u㵏'Q%rk/Leb yh<E>ٽ#!Pi7hsn]nֹ[{"e r]@G""| \ %`UiK{>:siȜ<zZ2ݰaLz=n=BwQ 4"8 4A@KLOHXDuۖʪ:ܹ܊s;:V[8|x KNGD~ݻ yqĞmkh{xqf=#M<2q"QZ1A@$$̘FSxvvyddkaKt,ڳ$uG4S  ǍkTʉ{wzdnQUZ""l 6Svh a󬄇nwSnڶ. ttVZYil#$td4D'f&t-(wދȤ%"LWP `JVɩ%S녮BТv>4432 M o6蝚Z$l=|B@ZEA]ul8[2!!U9iңܪ\ΌmRPP'nDDr93rd[77ZX7PQhQzߩڴX?ey~荀gnnу*5ɕZ^ EͤlND2Ґ~&}hc Gv-UE̙.] [XZ{~Zrs=Md|} G!v-::CKMl]m^V,( Z\rM&>sݝ_ m{~qg UA@L.nDWѨfRp][U1QWt&(pY6n<0?K%lIbd"q?>lT#pMcǕɓ92v,&A@K͛rffXQe&p#.V$ hoЛGd2F XunFkB@KNgϜ:q#HfNV<  L׮ѭ[UB"FhxdYvA]S-Ү=nyP|ؽv-pp%"LtI-HDnFT.hQX ۶yśSTV+ ~i;e 4U*匙BW!^ha[t ei$e%mEH!ŕ&-!]!"E\:\ X -k)lbM~KF"*okD9% 凒69D\q3WEdGc=N*//A Q@@ Ct 8[NZoЙ3r9D3 PuVE^W^V_ZI_o_B(Le &h]5_ٱ[6}\˭fn^RQqV*@hh>XԽnQ#78vv1rߟ9dvtki{ h>$ڹw]>Uڵp;wLJ!q;2u9)dM'Oѓ@x h^q͛7gff )SjŽ+ovo_%b~@??x蔔ؐeSSScbbW\Or3JzjIx>rnx؏ȡ<m.^Q}rxxx|||N촡 O/pk_~y%to%lQPwg`1 #5ɹI}nYnfӧ\tmಮ|VS@O4)**? aʕ+111&LgOeYnbhA%"ȭ0- 3S.1Ƿfh{gz6lP&)((hԩj㗄ay5?ODEٚԏz."nTgbrɲ~1)JZnb\rHmquO:*T.v[wŹW~Z8]}6Bfq{i`Fk "GSTTrs,BQ]\]3q4?>sNmXӇ]qm-3.{mI߿7++cפd4} )7ʵɗk‹sUUo`+g_fW^t0'ujZnOk*ky˪GTL@VnPrq^~䓁c&HBWML&VSelheFƼ*c+4֨evvk W sYZ&QLu=+,%~n\ʊV;񾺾)u?`fevcǎ;vl۷ߺu˼"kzcu1`er%Zjjne~U'ٺ{V?@.s+p-Trŀټ8)ev73!ٮ#GT*`]gHl>/Z+ '""bݺu3w!; ~~vCS~[੥;N:U^^^QQ AI?31?I~_YMz\.oEYR{~ݛH%MOq4UhB@@")4H!DJ}Y///nY׿[o^V}||뗛+`%)))O>דO>"H1&, ԯH5$/Ree%aÆ䔔'''oܸ2֬Yj322""">+yg_|̩S>;pL=ZFرcwȍDDDɓ'{O%aaa.]bY411QJ˜/2,,b>{nBaXP"B?[̑^@GgYоeeerYY??x{{GGG7k֬G)))V0 \aΝ;'T1 ԯHB?Iݻ|&ɲ`৘77 . 6LV XItt9s ̙-`1f *QA?[~úyoknݻ>} 11GXfYVJ7o^\\-UL#+'Eg3tMݚ5kƏj5͸q֮]O/5͒%K.`%cƌYx1̘1BS- ԯHfgz~m۶mӦ͂ z=?>^zlM,ѱ_mv9"ZzVݻwJbYv̘1?NvZnݒjI0 hZR)zB`YV&,}mKn:ydJv!888p jq̙VZQvvPpZFvZ^Ν; ]@áG3sL//-[ ]@áD 8D  RhB@@")4H!D  RhB@@")4H!D  R- IENDB`mets/inst/misc/mets1.png0000644000176200001440000002550613623061405014701 0ustar liggesusersPNG  IHDR) IDATx\TU3rU0rM[|tM:֣cEw!c)MFZjdf%_G0Qjd((8c"#?f=wx=s9sɛәsY,l#@R4HI )$E@h "@R4HI )$E@h "@R4HI )$E@h "@R4HI )$E@h "@R4HI )$E@h "@R4HI )$E@h "@R4HI )$E@h "@Rjj3f̈R B7|7 qF 蘘S]!ā׸BC&);;;::: /***33l6+su"z)))F1+++44bedd(ShBybˈܰ0,NhBPPPPUUU]]}С)S(su"8srr ɓ'냃 2W-R(z` I ):<<\z)su"Ơۘ&LhGdEEdrtu #SNIIIݺukGnaÆ59矟8q¡,iΜ9zPPPPPP.\8yy%!HJ޷o_tlllMMZW1b~ذ$ņ )6Ia?H @Rh "@R4HI )$E@h "@R4HI )$E@h "@R4HI )$E@h "@R4HI )$E@h "@R4HI )$P@aÆN0矕:hB /1cx?\Hϟ0a?lX/^ܽ{EٳG6f)Ç߹s￯^|_|q\]ˬZ8x`JJJޜeZP@FG}E@0L~~~QQQfY)ԃNII1YYY$55,##C@s ͛7X_FDD憅F7fw3g49Y^^^__̺@ tbbbBBBZZZhhN;zhjj)S|d[nmrάdP@ 'O''' ;3f̘1cܲeΝ;Y)B~"Sm}<==պ:OQ ?+I$JB+ @RlR("+ :`%!tp$ )F@R4HI )$E@h "@R4HI )$E@hBA;P~m_ծ⫯z9qtX/]UBTTlƵ]^ Q Bokk1h "@R4HI )$yā`tA[W\矕,`e;sss***+\v@XbBo ,P*@3]ZZd=<%hK?PQZZv1c([_u__߸k׮k ݃ ںu{mml֭el}݀'Nn۶MzѢEyyy18@y{GGG_xQB4qqq/>|EEŋ>4;_~88899`0MpmtC ]+VB,\pԨQ^7 $2!oK.BW^yeȐ!O=c/o߾xƱ˰/^UTT8±3>a{Ń>8{gϞ={vǏW,ҥKfff;/c2233fs;f{[o}xV@k]׃t .4l޼977722k׮֕[nmglOS)7]I\Y[[[WWwʕK.2֕UUUՇJHH:8TVV8q"00p۶mLzzĉ C~3cƌ_| %E|}}}}}?vvYI f@ߔtEE=c=x%h./^|ŋw} hv?  ر4RszBHH3ʰо6lpX,:'5n;W^xW6*3[|T^2IwN>=:IeNKK۹s']=o=>>^Rt>;|K>}˱m^pʕ+g͚pAr|Eh@D!Ă 0@BOg!Ûm-MАe˖9#Gzzz:!!bAZKtX2π [h b]v˗mDzl@>|xʔ)UUUJ x7x{\u8|p|||xxM~a+!Dyy[n[m}ҤIbŊ;v700o۴ihѶ9vG^xË/ KKKǑϟW$?C!DiiڵknjlUfzׯ}}}]&3 ݃z~)\ 퀮g̘1ydElذd˖-4v?Fy]w5gǜk;7l;|7'O^bE\\ebbb~ߨ],lt^^ތ3򼼼.`l@+\ y@5&թ]tl?d2GfYѢt;wիW.D^WFFF6LQ:tI:w)44Tz$t z̘1|~ՇzHѢtaaaiii][T={>{ｧF=:@!l6z)fw'WUU]lσ/222׿Shuuu J֣E{Ν:t{رYfegg+\VQQaMgNv9ОW\ׯ_aagYYcZPPhƍߪ]l~Eu]vwJBfBxzz]lҥK dЮlDpv@9/BY槟~z'y{[555]_t(|B3ѰMG SawJܼg5mlm޼a׈ܰ0P.]TYY)Q ~aNf¯ɂv\ONiA;JbbbBBBZZZhhN;zhjj)S|[omrk׮ wt999ɓG߿&'-/JHD˗/[Rvz`\;YQ>/}, hk!ڵhիWllSƲY1{yy]HLLΞ3g I4!stt%8?u˘L耀??Lf ggg;j@K/رY;s$=iӦLw l͛7FFFvۺp֭j9((Hbvg\9|"MWP2gΜ!C;(e;"-7he+ :`%!:h :g-$JBڰ@Gvĉ:]F]uM)a? qLӧO !z=ϭr +WT.s, l;d~@ka?8pdoR;wQ-w( mCe`sllT^^ Ah!^Ç;N9R4麀~/裏OO+7MUhu_Λ7oԩSKJJ;^C.m۶nݺ;LHHHNN/ ]zUѹsg Ѷ8jjjzAAA߳gOˌ>j&ɺEaGtԨQIIIh?<쳗.]RǃgNAAܯ_?Uqmu3}.Yz[nv[a%hk]-v9.Rk֬3N4r`ҤI[ti2ng`:(﷟N+ ס @!]VXXx9!DLĽ3lnR s),,JP48z㌋2Z4aX[ \rȑjǗđ#G^*pw&_^^^C Q-W^^^^jW#m~[b t6WTUU !z9~Xŋ=4q ! cgR]%!q}u!!!jAE\bBڵkB 77@F W9vX|||PPܹsUUULTd2>] lS(O>a„CUWW/YzqEKM(4}ȑ]vyyyeeeEEEM:w\MBt:v6ń 'Qx!DN222~i@:/7 T.B|cZ;v#F̥\~B׫] ɓFǭ/'Ng)suM&I1|}wqcNMg2K!DϞ=g͚v9hBC&);;;::: /***33l6+su}WK.mxtt4ge(ԃNII1YYY$55,##C4rkj{ ͛77扈 #'\`Eh5tW]tjgtB n(INLLLHHHKK tGMMM2e|7nlreM>B?ONOO1 'ONNNǏ-[vJg4;!-{&KB;hǏ_vN:=jWPm z߾}<@MMZK/m۶nnn~~~S-cccIg@1EEE_`dC6>^Z $4NYQ_____/4hPNlg9ɻ@8qիctYr:$N/֭[]IFcq^b1hV… B9s$%%]ڂyЀz̙3gϞB~ VG"GpuAЀf؟Nkf>= 2 b6XG| &vi/}||]v t:Mc4w/ /L&n6GQٳy#E hc aIIt[cYhdgg !zeeЀZ2rϞ=u'$$ή-33?GFF[ BHwаǏ9rD1~3f]4>(,,?~}"tddsԮP^oG?CEEEPPoN:~S8IDDbqR:5 [l8ppIsh\{Ijժ7|S*k2:|1b͚5-i!'>}ŋԸ.]${! !z!"54ºO?v9P ؾ}[J$zЀtFFk.!DnZ.$rm۶5>SOyzzUիիWծp"777|ҥ]vk^Hw}7&h ~ *ww~iРA 6lX˿l؃ 8yk/⋙3g]`Mf=^[ncǎm{`_|ƙo߾- BѣGhvUL^v-P=h@e7>*??ԩSe)SP: IDAT Hl6Ϟ=ۺs.]~_?Tsc {߿[nЀD t_~yȐ!M~J!4;edd=zTQYY){U+ 50yyy؜L"9sF6{l뙑#GZdA@j}/LJJjfz l6ر߷th(p !֭[;!t:ݳ>{+^dG@Jӟ_[ݹs_׉7 Ѐs5>}ŋCBBѸN>|}>8@R-޷oZWб555j]vE )d2eggGGGEEEeffܵ`JBˮ$Sm >"ҺaAAAUUUuuCذpٕu @nbgl&7+-ܩS'ModQWW'ԩڅb P*++Ƶ-w^h &;7>ZCϟODFF]H۽;wNJJRۿG}l2 i .̘1SE5HI )$E@\9=<<.z[vfw-hzpHmjjjLΝ;kzuEMb1L;wVvq_rM> #@R4HI )$E@h d?~`````M&ww=..رcBs___nl6 ??̙3Bk`4Ǎ;n8(4u 555 /mVi 蜜BXTTTXXa+jSN=999gΜ8q36oŋӦMrna͚5'O(v ?ԩSO:uԩ\hFuԩ36+DEE8??r{}駭?s``ESWW7iҤ[zxxXh[,K.}7СC_}՟~̙3СC-ڹ?>pwwo8crN;`@_|z|޽{[OYf  ΝkXZsУGݻGFFFnСC Sto֢[hcirmNG}}}ÿNb݊LC3|=zKBkwݻw7>[BTVVz{{w<`Z{ܹsΝ{RRRn1kvZ:88ѣ㒒>}ZN+X,wygٲe |u;|n_Vhz7o^@@3ĉ,Yb&Nh-4Yn\0M&ܹsCBB;o<ɤvE-lٲ;F{; c3gΌ='..ٳg-ZmrmNa?HǠ5 )$E@h "@R4HI )$E@h "@R4HI )$E@DGGt:aÄ:NҀqW8`=i8N6pYM8Q4 qtE.]t>>>/ǏѣСCsssU ! 4hK,޽{QQѻﾛ&0 3g<{m222ԮCpYM8t׮jkkzdrwwX,nnnG.\h_'|R!_cܹ]49|.(++[ժ qM0aڵ&髯 |C [jj̙3{iӦ^z]:4Ơ@R qh "@R4HI )$E@h "@R4HI )$E@hܢ;IENDB`mets/inst/misc/concordance.png0000644000176200001440000003066213623061405016125 0ustar liggesusersPNG  IHDR&T IDATx}\Tup'2܈7 *R`E&f*j+nj\ZFZT4zt#v޵[Whkٍkȍގ(3ǹ@J=s?93ss(uHB$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@G|w/XիBgyƍo|?)::׷?xYYVOťw ,i!EiA^jK;pooz*Rܴ.es=....]۽{]zeMEEEaaյE8qbvvK.ڶmۧ~)TUU=z4--MtҖz@!DMM篿 `Ϟ=_~[;bSEMM߫W/!ĦMf;VU[[An׿l6[UUՄ Ç4nx"}W^7įtGU7>#%7kˌ9B1cԿʕ+fѣ7>Å[x1cl6EQ֯_ww[/P:tPggg8l6k…W^'r!DYFêE)..3foΝN<|Oȑ#Ν5kVppG@@LQ'O>Ý;w1cbxO!9,WMh111޽{8ޡwZ#G(B{{B?U4yyy;Ka;l׮ݧ~я7nB$''Yn"""@}BMT(ʐ!C<%Z\\oҥN!Ddd7 rss?~>(Z+o66D3^pʠi-%%EqܹgWt;-ʀs%!ZUUu !ymWVd2wItEQӅ{wڵKjСBCQQW9|"aaa=zPWWXQŋWVV^vVĎ;,ٳ̙>O<1eʔ})H65k!z)ȑ#G !7d[ce8|e4yf!Ė-[n*jM 9^N߾}'xBѫWK.5 ݺuB; lۋ;vLm3UEQ:u$Ͽ'b׳g%K)ڦRe̘1铚z_ׯ[nʔ)...Ty֬YV_ycO!5Vƍ ~E+//B,ZB6&ziq9bݻw !'ذaڵk]]]ϯ;vHLLT ˗ƞ/q/+&t5$$dϞ=AAAjx;No GVRR/|B={:tHQ+WL4I1j(k*?0@J}BXVvIo < j*͖o( !ڵkWϫEQswj^x!ĢEA͛7;v~%=ƆhX_46eoooT;N+}=շo_5 fْ՟FFFF`:UQC7ի?Bxyy7G_Ug=<<=7'rmXU|>Cjfbʔ)}hhĉoVӧOO:5!!ťSNO_IcO!5V _իWӟzJt߫///E3gpU_]]ݫ:p@//޽{'&&?~\f[nݝwu]wxՏ>{ի׋/xosi*EQ==D^{5??:}k׮`!ć~f8p ..ϯSN&M*((BO!5V _4bϞ=J?Bzi%&s39zA$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@7 5ϟ믵u!ڣqpZqt9;vO u!ЁuEFFGBGjHŲlٲM6Y=z/^V*:::))5ֺ_Ɓ|8>ILLLOO/...))0LrFtƁHPWbbb9 &)???;;;22RN80Ikf9)))$$$88xVurFtƁHOKKKKK3` 4 $!r9I$EN=L)#¡C>cǎɻ|6lh~{KW8)#)rڷo?e|wo7ިlE`gGEE5صkײ+ pv4h9999| *Y*N85&HŒk6RRR***mq`0\ p^4 K΋Ɓp6y80.8/AI$D@" HB$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@" ٹsgPPPDDľ}|||bbb=*gt@hy|͹s80**`ȑ3f̐3:S4 FR?g LNN9}O+V(//_bw-gt@haV\9uT__߽{Ο?o߾w}_W9:E`$EΰaN<.WrƁp4@IcXRSS|}}fsXXXJJJEEq`0"'112==$##d2%&&)#鳜ܬ,u5 &&&((HN80In2󳳳###ˆ l}jmKh g i$D@" HB$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@" )--1cw}7x`ooÇ)#)r7mڴ3f)#)r _|EǏϞ=;00099yrFtƁHI&%%%=˗//++KKK4hq`0nrYj˧MvĉQF[NN80I?cq`0$ DRX,԰0___RQQ!gt@hILLLOO/...))0LrFtƁH,'777++C]  3:S4 FRDGG''''$$LH9:E`$ENffҥKJKKE֭[||뛸ˆ l8/E`8hK;wj6%j@w:w^jh5s***-Z"_OKK<;v<#[lٯ@x/G휽{Λ7/7kӦMW\y'VΥry\]]z޽{:uJZtpKJJJɴ`fGhqh1zMh]\~9iU#W޲efS~uEsYdӦM+/////6m{ｧQy:h@cO\r]vڵի_z%ez4yKh]GΥKl6lZ-Ērqqy罼r9#G5k:6k֬|PrY1#gB;ݽ4f?׵.pRϱ֩S/nnnuuuhҥ x/gƍ/_>~x7m$,@h]\G… ;v}yI. ЩZZ]]墁9/w}A.]$$@8rhѢ .X,EEGGK. #9wyԩSaaa{...~w$З}k\U@JJKZZpr۶mۤx/筷ު jD 9Yb֭[H59i߾%@G΂ ^JNUP1'&O,'"9huz`̙>>>Zׂ6СCxݻws98={Lx雍9rȐ!rJR9/&''o۶f3f2􈀁󈈈Ӻ>0g>|}ܹ㽜/Sjժ޽{˭ %9 LMs3bĈ?/bѢE#F[KL@C~i^^wމ'j[CrVXQ[[~˗K. pKyo=*****j̙=9x/cǎk׮uss\GL@[~~~ZW{9\h9˱_ܰcǎ۷oOLL|%W@pqC8rԋ^pb,Z/n۲8@DDE8;Ǒ7|"9@֞qw?i[ԫWqN*:=⒖h|QQQ6l_ XxZ|zƁHxAiӦ}7AZ|zƁ;ǚ_VVVN~ph4gϞ#~R[[ləIDKjj+F1}/hpUÇs}xV80Ik%555,,l6TTT)#)r+++ӋKJJ222L&Sbbq`0&rss<<<Հ 9:E`$ENtttrrrBBBxxdΎl.رc 69sjfq`0"'33sҥIIIt->>o0|w6lh֭[kV 8#)rn.qqqqqq 6Ν;EKUP@Y'(phf [E@טXHE`8h4pС#Gy2 >8/ 8q"::駟VWf*=7j߾U4Lٜ<}tڲOƁ880HB$!rnh *++o^TT$DIHH=zM8Qr1-ӱcǥKj]E$D@" Hkok׮uwwG&I~=9Ǐ?qqqZ"kIyVZ?2dHF<7n|7e;Sz$#r@( +WSWʴG[DK.egg/^X]G[D]#AI$D@>fZ~}uuuӷS.9Liii=\ӷhΝ;'$$h]9p3gvA]ٳ7?pjjօG$!r9I,bŊO>UQQQuE:F@SV\ٿ 1&9I$" ::sγgV/ZUUe29?x\\VF`$E,X[om߾@θ80Iӽ{~AꚖ6c *gh@hyGO!F1dȐA/#髠&L8tбcW_}uܸq999rFtƁ;@PPPPPl2#4fXRSS|}}fsXXXJJJEEq2v?ٽ{p!D~~-[?c9zDhʕ+_UPWbbbq`0"':::999!!!<4III!!!ӧOZׯ3:S4 F^ZZZZZ%"""""#Ghiq`0\ ~rͦm1FY >\Q .lٲW^[fddK(I[4N+)(( SWoSD,rbcci3g̞={ԩZ,hVR[[;a„+Wj]q6$r,˲e6mTVVfZ{xb___9ɭ[ի7n9rzXYY^\\\RRa2l2Gƍ7j( Ӫ>X6fСgSHHHк C㴪 hЩ¡Cv5tVGh\tiRRRii(ݺuKԆT]]nZb4 y>Ɓp4@Nx yW8.9rd9ڐ?|UІL&h .˅y9hk֬9x`^qiZUWW?{̙sUV*Vw爈:qv#-)((xgo]vm[>g.ACsE mIDATѣOo|  aP륻w|yBBt m@s`JN8|\]]}}}嗤-5Ey:v(aǎ_~i)*q}ƍI:am"NY]w_!F=jW׮Z85c4IWWW_oz.//{O&K 4`CQ{IJJnիW=[+[^5jR`ժU7ovuuBTTTL6Md0j9mTEEɓSSS[os]MMĉ22ti``EEE˗/뮻.Dc7ӆ>|СC?`6[cW~Qڵã_|w(!rڐ~SNݺuBw.edڵngNӦi[&MԿ}k?pf=g]e08DrII-ǷmYFfwZ868DX,4?׿5k֬_vv-[;v{p~IIIǏW fϞm=cGѣGwܩ.xɓ'~JyիO|UA}Ǎh{+TXX_k]E q r ++F=-wp+))L-Ȁ89zuy5,ˈ#FٲC}uEQ-XZq@od}mGVlcw+Vtgزe#ݲe(jUU4s3rqqywZ1ϝ;Q:a )**z뭷yuUϋhG@!`͚G9c#vO8$54έ"r4j=m5 99p`+B{u֩~qiN>۶{}ZW6'77C QWCBBf8W\:tbx?>\] ^c7}FEEi]/qZ >%K!Va|=ԙ;n{3*#J9@k~W\\._~ж_D,IcX-[iӦ2ڣGŋ)@Μ9ON>ُppfO?{OeŊ,sgyN]oN8mI7i%"'111888===<<\e˖ď?XN:2k֬|777!ĵkמ}f<咒o٩SģZcisʕ5k֨=4im"'777++C]  3l'Nm~☛?//f>-V4il˗/˗/_6ͽ{ֶ8H䄄pɔ)gt'3gОz7¡CE[lݽ{ؤIڷob6G}o؏@slhMH̥K&%%*ҭ[I|S9~ѢE{WwvǏ_>~rIPs+ _?>BCs%q od3gb_/n?g}.={6''gĈ꣏>j~ʓ'JK+N:u(~!!ABBwiٻwoVV|….]8ՉhC2Auuu-PM6mvj]b]={zwݽ;p3ZqBCC=zhmUzj]MUN]xŋ5/^5pqqy/7l`={_OxÇb .6O_ϵT fsZmB&l6Mb֭kvn~~n:tpo;z}N\3^6NnstBڊ d!F:5[]"pm/?opރn&ٳg+W=Dov:vܛKUv$rqq@Kq`0.Zh+4w"Y85&HŒk6RRR 9%%%&)11QN80#}0*g@`$Meff椤ӧ[V-c۷o?~@@@.\ps?׮]suuuuu ׯ_Nɓ;v֭VU98:^{1chU@ZZ]w5zh xW 0rH x饗U/bLLo~ #Ƒ8|/ HB$!r!r=ʐ(@4( `kjj5zAMM:ڵkxzz-443j^1BtwI$D@" HB$!r2rzꩀRub7n\ǎ-K`vk.uΞ=;uԮ]&%%UVVJ+G8TBGhNe,_ĉC yՍiiiAAAeee={\lYPYŋz)L:uѢE/^\pԩSՍ xzq{ɒ%r XbŰaW61߅84f=sEQ***ۧnׯ_NN(999SI^^^DDDUU׮]{Ō;C(ooK./^ S;l᠚18?ƱӪqt9;v?TTT^^l6={VQgH(vw_޽{o+عs;vȑ#O=tA1Ci8XPСC>O}:%%e x=z]w3_~;v\@}դG8v5NkXk <}(eeefYطo󟊢ڵ+44k *,,oYl.++Sޒ 8w\mm3l04u8?qh;G{9Fz뭷*++ n7nܖ-[Eٺu[;vٳo߾-2 뮻TUUedd}ݒ 7oޓO>YQQQVV`~Zr9TJCi8c,..wСK塇޽qѵɓ' ,ȑ#C 2dȑ#G$px__;#==ݾ]N h*A/hA%T%rb GD@" HB$!r9I$D@" HB$!r9I$D@" &Iq ԅk[ #42)u h/e4b/yM0A)L K,ׯ+"(//OHHҥK޽{J._;wrJ 81/?Pť}(}}Ξ=+?~fKLL8qVqZDSs9 ={ܹsg޽W\pBPPBQ?;_|ٓdqL&ӵkos̙S]]bŊɓ'B^z}V5::ŋ>@iqS{衇s7~饗VkHHHDDD^^uuy^{*H^@" HB$!r9I$D@" HB$!r9I$D@" zSE`jh*$D@" HB$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@" HB$i%XfMծ`ի׍7O]nI9C߿˗#""Ǐ5j19aҤImڴIII;wn~~ ;vΝ;W^]nu׮]sεE9၁orM|}} xǸy4LR#'>>3z>/ 1...6bԨQ>1I9|7u:ݼyV^iׯ_:`ƥFgϞG9y˗[ߦ>e˖Cֻ$"Ν;g]U}B''’j.KSK$&&K ֭[=`f׫H.gΝ~~~999ڵ۽{Mׯ۵kO >|ҥ6i`[R#W_۷,X`_}˗/۪Y I.'++kȐ!ǃ wmwtt;vرcm,&rFdɒwfgg/YdذaV6(Mj؛ټy͛7{٥K͛7.;|||v!GЄ'xAxHlڴyrdPȉ/rdPqss{eh8F΢E֮]k ,L:UQ P@!5rhʤX4eR#`0L4M6)))sε  }+W74Rˉ駟"##zG}ԯ_-[,Ta׋ hYhtqq1?ptt;@]R#gȑqqqBׯƍ;@]R#g۷o#GtwwePr+G@!#rb4'@!cZu^|_|ߗ;cmΝB7,"s޽Rcɔ-w+N#~̝;׼cmܹO>97nB۷_~͚5[~꒺c{ǎ2{42f9:nѢEH@Ș唝|Y8ДɾE[aad͕5@]R#gΝ~~~999ڵ۽{NH+Or4@jqqq^^^}=x dP2dAݻ'wFΈ#,Yr%K 6LfuI͛7߼ygϞ]tIHHؼyz*@%uiӦ͛s*(9_~R衇~8i߾}vvڅІRK':.W\aJhU-Zv9sxxxFݻwwss߿څІT%A۶_y>*9SNB?[֭ې!Cf̘v!A[_ WܹӥK;U"5rH@#lN8u*N:NqkdDN[pU*8`T ۰aCΝLBА!DϞ^-Z8ۼqN̝`fGˉ\`^B88zHFi$~-iӦEDDL<9(((66v111j@-l[n7oNOOHJJJOO Q.ڞ!t:]hhhpp+CCC੦YΞ={|}}Ϟ=vUX uc0O~رӧO\{ͭi0""bIII3gLII >|U-[f&S%$TwGҦr΢  ܳg+W÷lbMɓ&&&2$??ߚb4uZ?55ћYMWkNn{G fR#'>>~}Q~`77[%!;;¢"EQ8@NάKL_?X~ݫmѣGԩS:ݽWWqzӼup;sLPP*zȑ#ׯ_Ǎ'wFo߮Go.;6lյkWos* 'uc4 6f̘O>̙SPPsyyy͛7/77'Ҫmsn EEBWW'wfmr֯_nݺjǎ ,~ĉx 4Uw`wzVaIzBvضcǎ).puuݵkm &'Of|}899X{{Qt:______!Āl j| wwоe {vuhF͝MvZ";v;؄Pv$i8f̘oFz)9@Usʧg"''7Af9_(&LPٷoV _?u;S$44Tf`C~[7R#vqqt:Yf2{fZI{~>}zjj֭[nj#wҮ]WծBt2\nժ՝;w6mڌ7ϟ{5Fкuk ~{~BݻrpxaT ٭[:ԯ_?{T":ۏ=Xttٱ֥K~ƌj@}6s_~JfU4ȯ+5oNHݱlٲ۷?#EEEÆ {7e6ѭ[+ M"u3a„ &!v)_o*3239*Rg9]O߾}_a&l IG\u VLyܸjעUR/ Z׬w(?~ySARR*iF=ryU_'uە`xwUM0LBv!N\{xx,X\VR+Goʫٚڥ 1>>@s7nvMh%:0:5XՏ:thֽK~E&!11ر[e;VRR Bge51ܢ @t/^[aԋ~ܢs-((}m2F /Hoż)8_բstXX؆ :wŋwLBf. u #rrssCCCGa~7<>lN7>6mZDDQQQV (../B~ٲ?Q튚4+dffn߾tڴi7n\x-wmIII!!!V X⇫W !i=vl'd&_=z([Ү]w}w޽7BCC,YbŊsKƪ~{n2!\]uE3nݺB???wٳgΜ9nnn111 [hQݭl&np*ϸ0}H Ɉ۷g-pV3g >|ժU˖-e JUS3g2>r/wqgYIF['u֤IRSS?쳵k۷ʖ+_Mד7@SpJiIIBGGTf.uX$#rN<o$''waNܹ-GEEmݺЌ7BCC+ l+:M ԩSV\t{N̚5kȐ!3f̰S8ƩS!~ ?!D?i}F)Οmrr8WbQ1mGΕ+W ֺu?%%%Bhf3:ӻ~- !v̜9s̘1ϟ7Lj8))"ׇ>i;rΟ?h"??M6kMái׮ٳgoVXXdR(upDZ5S!֭z5k+V;vs=e˖c~7f$/t)dRׯ!n1y#pgc,<#(..5?Xzu؟]DEMM3)h֌}0@j8O֩SeOܜ8FP߹s?"ёYN#Dj7FcѷB=ZMMb][/͏k]U:"xXTviӥCc;W>y9B㓕v!@cTP %GB t2W_~kBbv!@c(&1%{|NQ: ҶWufZ5` "G!ݻv!8&K5+=oyFw]7)իW8@Ν:Xq!Dn< rX6 Λ7B3kW[q@A!11;ΣGwT`ZV޷ok'..̦Q"rQAAGRSwB t5}wC4V:EQj^;tP۶mծԧ(K=8!8{N߿څj,4+`߾4űCֶmm,۷oĈvjB+Wx{{;VBIJ*-石~NW13yg !JJki GiƉ6spuk]&MS@j"~%B̼U+׺F4DKQQ?VX8wn*Š#rjhFf J%o }}=J_v:tBk8~aL!hsssSt½rO-1Ô){L?zy 5N!huwLJ&’'ᮋ[o5pinܸd"rSrrxMsIDAT{V..¦#rUn0<$ҥw!o@w[FvE "@,oN8y2m[I9,6YYgf*BGo !Zt6K*Dw?Y~Ƀ~>j"rTTaS\\-puujAѬCUdj9W/ooNuF @W3%"eǎڰ᧤SǮ][V^A9@SWafWnݣu:t}==]Tݿ_r副N.[2th#X؟&⠎O8p`ܹO?s;~9ryn..N'woO䄅mذsSL!r*p_K=i.kWMSoPڎ z!yaiii/2={zM֧rސ1#gڴi'O ={vAAALLu Q|7O{B֭[0؅#[n7o޶m[xx%KԮk\3+hG} )o`+ڎ!N ^bE```hhn.4('N%^}/qtt޽e%g!f`ڎ={̙3-&&&::aaa-޽KvPKH'uQKt#Gv [ Dۑ3g >|ժU˖-kwevb4Ϟ}(99Cn4ڎz}ys  _Ns ` rQ?Wpp炂z7R|4{_ڎ`77[%!;;ž={vرGW8ٳ?`e;W׸NQj.^;hРZ"׷yԮMXXŋvjƵ=QF)9D$vdgg/^gϞ-Z={?~nnu,vL>`0$$$$%%tӧ]m>ڵg;vT*EڎaÆ2eJ>}t:ݥKԮ `#gV={[Ei۶mHHȎ;7|R˕ϝ;WYNNN͛5klz溺͆ ЬY3WvNƕ׫W۫]H 8 !Ľ{>گxzzz{{ۯ$U={ϯM6jbc.\klWx񢇇G˗/5=׮]ԩO>^Q=z]U۰0ToooF0҉'~ggEQrssO>m^էO-[deeۼP:|޽{+|ZFh%"nz}ff(jc%%%s̙7oi#ʕ+_yEQʿ.\تU;wμԩSe:uʼP9Ǣ;FQNg~l2-&Gy3::ڼDco8r ˵>.!Dnn(˓O>9k,F0 .X 55u-2/l*cq,iGM۶m/]$tRv.*,^xҥU˵>oȑ#N%ӟ?… 慍`\'N󋈈8qya#WciL="nƏw^EQ &]U?ŵmh4Frqex!(Ç"((hӦM!&&6/l߿֭[FcllC=d^UX@>F!;;j׮ݻv9VY|_4`\iiicƌiѢň#^j^ušC:ŋ慚WVc덻$a@" HB$!r9I$D@" HB$!r9I$D@" rrrrrrtBt:KrR;{N+)))[pB*ԡSEB&kjvtW_}oҥoF=<== !ӧLҦM.]̘1`0Z2`"hwСHNw…;w.[L1k֬gy&99̙3:u>}ڕ4Ž:Yfnnn888(WLJlY 8;;rZj((FjV X+W̜0aʕ+ծ?"hЖ/_n2۹skת]P|Y@" HB$!r9I$D@" HB$9))&|޺xgYYpv  5r^|m^4Sfk _}5Ni]6#nߜ9_х w貧eB8ا{-[nCѯ5-cMo?״ő#7>ћšU5{;W~aff /{wޝ=Pd^3;`Ͻ6|]PM뷪.JJJgӰaݺeUz[uRU _|qorÈ_]%ضYo n+u|X_ZNO3?6MWBǺ6RZxymy`0 E޽oмk}?oW&S׆N6J?r۶ڼߪ֬\5FE#+l=]o?~z':tZЪr1_ӻ.}e˹zx-.*SlQWʺߩf=bSEO#6eשߪ 3E-<}:5kֳ8/-|mJXد쩩Fo۶Y좪v&,U9%kמzow{ҌQEϏYoqlEy}ѪՆlܹۗ/gyɷߦT2~ʸ{z+W+*ᇷ;vlP$nMի}UYU1oj.NJbߩSiЪE걝-pԨ#"_~Ż}μ^(JffGte׵ߪڰpV6 ܹլY{嫵8/[())3Pٌܚm[]TnqP-c%5rM(7oMٯET9 E|9E?τXIQowW{~IIiBBvO/jYmjU >޲YE?^;wȒ%ߕO8!|M:%%;n.xo޼̱Z\b1L]Qjjݽ&XL޾_XXb^!>>eȏ͏ubݻV_v=؅(~~臘EIK3Vfz[ubReѢ=˗֬bU[6T}T P#֞zKdό޼oSE %%7}W!?833„WҡGn-O۶u߶헃L[ lS-S~-iz[]uy86Cvߤ{;[|G~rs-:+uE_~y}„~ѯ.AA6d0Ĝ{aj֬B:~_ԶXl4 +EeW4c?wZ\?anˣ~m˃r.=޺Ƒ#?NI-[(JnnK/ofSg<`9-8nn/ ]ĘP婧v ٴ'/ ml=W JKM~uKOWNNa*j/|x%)l\?dȇ/ޭ喩}լY+*wqݡC?tw:㭦FQamg/s'?$dwѽ{#&lٚO=]wǏ]xUԣߪHK3i#FlW}15*_~aXlaWTSmX좪v܆* K(کW:ZAo^vuuR @=i&r JpAj'Xhff9#r9I$D@" HB$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@" 6NIENDB`mets/inst/misc/binomialtwostage.R0000644000176200001440000001331713623061405016632 0ustar liggesusers onerunfam <- function(i,n,alr=0,manual=1,time=0,simplealr=1,theta=1) { ## {{{ ### n=200; beta=0.2; theta=1; time=0; i=1 print(i) dd <- simBinFam(n,beta=0,theta) ddl <- fast.reshape(dd,varying="y",keep="y") out2t <- system.time( marg <- glm(y~+1,data=ddl,family=binomial()) ) ps <- predict(marg,type="response") if (time==1) print(out2t) if (manual==1) { if (time==1) print(date()) ddl$ps <- ps fam <- familycluster.index(ddl$id) prtfam <- ddl[fam$familypairindex,] prtfam$subfam <- fam$subfamilyindex ### lave afhængighedsdesign pba af wide format zyg1*zyg2 feks prtfamclust <- data.frame(fast.reshape(prtfam,id="subfam")) ### des <- model.matrix(~-1+factor(num1):factor(num2),data=prtfamclust) mf <- with(prtfamclust,(num1=="m")*(num2=="f")*1) mb <- with(prtfamclust,(num1=="m" | num1=="f")*(num2=="b1" | num2=="b2")*1) bb <- with(prtfamclust,(num1=="b1" )*(num2=="b1" | num2=="b2")*1) des <- cbind(mf,mb,bb)*1 mulig <- (apply(des,2,sum)>0) names <- colnames(des) prtfamclust <- cbind(prtfamclust,des) prtfam <- fast.reshape(prtfamclust,varying=c("y","ps","num"),keep=c("y","ps","num","subfam","id",names)) prtfam$famclust <- prtfam$id1 destheta <- prtfam[,names] if (time==1) print(date()) udt <- system.time( udf <- binomial.twostage(prtfam$y,data=prtfam, clusters=prtfam$subfam, detail=0, ### score.method="nlminb", score.method="fisher.scoring", theta.des=prtfam[,names], max.clust=1000,iid=1, Nit=60,marginal.p=prtfam$ps,se.clusters=prtfam$famclust) ) if (time==1) print(udt) zfam <- rbind(c(1,0,0), ## m-f c(0,1,0), ## m-b1 c(0,1,0), ## m-b2 c(1,0,0), ## f-m c(0,1,0), ## f-b1 c(0,1,0), ## f-b2 c(0,1,0), ## b1-m c(0,1,0), ## b1-f c(0,0,1), ## b1-b2 c(0,1,0), ## b2-m c(0,1,0), ## b2-f c(0,0,1)) ## b2-b1 if (alr==1) { if (simplealr==0) { ### cvec <- (ddl$num=="m"| ddl$num=="f")*1 +(ddl$num=="b1"| ddl$num=="b2")*2 ### k <- 2 ### dmat <- rbind(c(1,0,0),c(0,1,0),c(0,0,1)) ### udz <- class2z(cvec,ddl$id,k,dmat) ### ### ZMAST <- rep(1,12) ### ZMAST <- cbind(ZMAST,c(0,0,0,0,1,1,0,1,1,0,1,1)) ### ### outl <- alr(ddl$y~+1,id=ddl$id,depmodel="general",ainit=rep(0.01,3),z=udz$z,zmast=0) if (!require(alr)) stop("'alr' package required") out4t <- system.time( outl <- alr(ddl$y~+1,id=ddl$id,depmodel="general",zlocs=rep(1:4,n),ainit=rep(0.01,3),z=zfam,zmast=1) ) if (time==1) print(out4t) outl <- c(summary(outl)$alpha[,1],summary(outl)$alpha[,2]) names(outl) <- c(rep("alr",3),rep("se-alr",3)) } else { outl <- alr(ddl$y~+1,id=ddl$id,depmodel="exchangeable",ainit=rep(0.01,1)) outl <- c(summary(outl)$alpha[,1],summary(outl)$alpha[,2]) names(outl) <- c(rep("alr",1),rep("se-alr",1)) } } } else { ### med design formula form <- ~factor(num1)*factor(num2) udbin <- easy.binomial.twostage(marg,data=ddl, response="y",id="id",theta.formula=form, marginal.p=ps, score.method="fisher.scoring") } ### if (alr==1) { ### alr til simpelt design ### outl <- alr(ddl$y~ddl$x,id=ddl$id,depm="exchangeable", ainit=0.01) ### outl <- summary(outl)$alpha ### ud <- c(udbin$theta,udbin$var.theta^.5,udbin$hessi^.5,c(outl)[1:2]) ### names(ud) <- c("TWO","se-two","se-twoR","alr","se-alr") ### } ud <- c(udf$theta,diag(udf$var.theta)^.5) if (alr==1) ud <- c(ud,outl) return(ud) } ## }}} onerunfam2 <- function(i,n,alr=0,manual=1,time=0,theta=1) { ## {{{ ### n=1000; beta=0.2; theta=1; time=0; i=1 print(i) dd <- simBinFam(n,beta=0,theta) ddl <- fast.reshape(dd,varying="y",keep="y") desfs <- function(x,num1="num1",num2="num2") { ## {{{ mf <- (x[num1]=="m")*(x[num2]=="f")*1 mb <- (x[num1]=="m" | x[num1]=="f")*(x[num2]=="b1" | x[num2]=="b2")*1 bb <- (x[num1]=="b1")*(x[num2]=="b1" | x[num2]=="b2")*1 c(mf,mb,bb) } ## }}} ud <- easy.binomial.twostage(y~+1,data=ddl, response="y",id="id", score.method="fisher.scoring",deshelp=0, theta.formula=desfs,desnames=c("pp","pc","cc")) ud <- c(ud$theta[,1],diag(ud$var.theta)^.5) zfam <- rbind(c(1,0,0), ## m-f c(0,1,0), ## m-b1 c(0,1,0), ## m-b2 c(1,0,0), ## f-m c(0,1,0), ## f-b1 c(0,1,0), ## f-b2 c(0,1,0), ## b1-m c(0,1,0), ## b1-f c(0,0,1), ## b1-b2 c(0,1,0), ## b2-m c(0,1,0), ## b2-f c(0,0,1)) ## b2-b1 if (alr==1) { if (!require(alr)) stop("'alr' package required") outl <- alr(ddl$y~+1,id=ddl$id, depmodel="general",zlocs=rep(1:4,n),ainit=rep(0.01,3),z=zfam,zmast=1) outl <- c(summary(outl)$alpha[,1],summary(outl)$alpha[,2]) names(outl) <- c(rep("alr",3),rep("se-alr",3)) } if (alr==1) ud <- c(ud,outl) return(ud) } ## }}} mets/inst/misc/binfam.rda0000644000176200001440000221170113623061405015062 0ustar liggesusersqg5LL&G&QderdeerQ+]&ɑdrd2L&G&ɑdrd2L&~;\\/gwǂxp8'C)a`Bpp*"H4%QKݤh4PW6P TU T**;@eoik Tu Tݠ ʞnPP eg78=ݠ enPPvNACS ʞnPPM e68}sAC ʾݠlo;n8# vpɞNCHv`/(pG vpɞNCHv`/(pGom`' !p$;`7 9 ^P8dm`' !p$v`/(pG  vpɾ`7 y ^P8dNCH`'v=`/ ApG;v]`7}~pap͞ 8#hv` `(!pG v]`7}~pap^ 8#hv` `(!pGj` v` pp4`'v=`/ ApGv]`7}~pap^ 8#h= ;.{>P`?8C08f7n@88}o;N {^8 Kv]`7}~pap;`'v=`/ ApGfp,N;`8 g=@K~p8u#vpܕ}ǂ vnp&{`Wjp\ap 8nG]K8'd v3p E`?W:p[p;8 ~cp Ni`78瀽|\ \ +p580; `'8L>p(p) 7plXv.p {9`/8 p\ !p#8 nG(+{Yǂ vnp&{`Wjp\ap 8nG]5p,N;`8 g=@K~p8u#vpܕ} vNp2N`8}"PR\Ap8n-we?`8']4 s^p>..ׁCFpQpW; `'8L>p(p) 7piXv.p {9`/8 p\ !p#8 nG(+cp Ni`78瀽|\ \ +p580G8'd v3p E`?W:p[p;8 ^`8']4 s^p>..ׁCFpQpWc  vNp2N`8}"PR\Ap8n-we8 ;p" N'S.p*8 v3, 炽

Š%Rp.W+p\kuzpn7fp (~c8N'$p28`78 {p.  >p!\ \.rpW5 \ Fp8 n[p;] ǁxp8')`8NLps^p8\ EbPp) + \ :p=8n7ap3 p wg?1Xp'Np8vSitg=lp8`\..~p9\ p\ ׃Cp# 7[ G.pw(8 ;p" N'S.p*8 v3, 炽

Š%Rp.W+p\kuzpn7fp (~c8N'$p28`78 {p.  >p!\ \.rpW5 \ Fp8 n[p;]U ǁxp8')`8NLps^p8\ EbPp) + \ :p=8n7ap3 p wg?1Xp'Np8vSitg=lp8`\..~p9\ p\ ׃Cp# 7[ G.pw$8 ;p" N'S.p*8 v3, 炽

Š%Rp.W+p\kuzpn7fp (~c8N'$p28`78 {p.  >p!\ \.rpW5 \ Fp8 n[p;] ǁxp8')`8NLps^p8\ EbPp) + \ :p=8n7ap3 p wg?1Xp'Np8vSitg=lp8`\..~p9\ p\ ׃Cp# 7[ G.pw 8 ;p" N'S.p*8 v3, 炽

Š%Rp.W+p\kuzpn7fp (~c8N'$p28`78 {p.  >p!\ \.rpW5 \ Fp8 n[p;]5 ǁxp8')`8NLps^p8\ EbPp) + \ :p=8n7ap3 p wg?1Xp'Np8vSitg=lp8`\..~p9\ p\ ׃Cp# 7[ G.pwv{c>8p_N'$p2x(8< G`7x 8< O{Tp.x  >|p!x\ ^ \^./Wr*px5Wׁ5 x# \ o[ mFvpx8 nw[{^px>;]n'8 ;@p"x  N'S.pp*x$8 <  vǀ3c,< O炧x.<%K%eRrpx^ .WW+kZpx\7kuzpno7wf.p x7( |> > ǂ}p?pwG_hpop,8ǃA`'x08 <  N4(p:x4 gǃDp6x28< g<<\^.//Ke`?x% \^ kUujzp x8oׁ7[!Vpxw-VpnwN!p0|$k:'8 ;@p"x  N'S.pp*x$8 <  vǀ3c,< O炧x.<%K%eRrpx^ .WW+kZpx\7kuzpno7wf.p x7( |> ~{c>8p_N'$p2x(8< G`7x 8< O{Tp.x  >|p!x\ ^ \^./Wr*px5Wׁ5 x# \ o[ mFvpx8 nw[{^px>;]n죯pop,8ǃA`'x08 <  N4(p:x4 gǃDp6x28< g<<\^.//Ke`?x% \^ kUujzp x8oׁ7[!Vpxw-VpnwN!p0|$ ǂ}p?pwGf{c>8p_N'$p2x(8< G`7x 8< O{Tp.x  >|p!x\ ^ \^./Wr*px5Wׁ5 x# \ o[ mFvpx8 nw[{^px>;]n'8 ;@p"x  N'S.pp*x$8 <  vǀ3c,< O炧x.<%K%eRrpx^ .WW+kZpx\7kuzpno7wf.p x7( |> > ǂ}p?pwG_ipop,8ǃA`'x08 <  N4(p:x4 gǃDp6x28< g<<\^.//Ke`?x% \^ kUujzp x8oׁ7[!Vpxw-VpnwN!p0|$k2'8 ;@p"x  N'S.pp*x$8 <  vǀ3c,< O炧x.<%K%eRrpx^ .WW+kZpx\7kuzpno7wf.p x7( |> ~{c>8p_N'$p2x(8< G`7x 8< O{Tp.x  >|p!x\ ^ \^./Wr*px5Wׁ5 x# \ o[ mFvpx8 nw[{^px>;]n죯pop,8ǃA`'x08 <  N4(p:x4 gǃDp6x28< g<<\^.//Ke`?x% \^ kUujzp x8oׁ7[!Vpxw-VpnwN!p0|$ ǂ}p?pwG  >|,8|xpp_`$p?ppBB"]"{{K^ ~\~ 0x9pQ c`?qJrUπ+ς׀σׂ_W_ ^~\~8~&x-pmf;z-! ?7??n   -x;p=x/pG>Ov__;w >/1.'8| 7Xp,8p8 I~xS S;g'N  >>< |<< <|18 | xRp:2h`7  UqkYkׁ=77sSS7s7o{33yY[9w}; EE x!p)ar#2~''O+OWW?^~ \ ~ *x5p:x# p-M&[:ww[C[?7?on     5x7p+[w{^6};Gw >  |_cZppOp/p poXq>q}'O'OvN > ><|8|>x |!x8x8|x$bp(ten1+cW3׀ׂ'{׃'og''o瀧ooOggss w ww/ |?x)p A2CRGeG++OOWW?? ^~?^ ~\~2x=p Uk uFZMu?7?on 8 %x+p kn7V=m??w > |/ǰ^1c}ǃ'O;''O'ON>  > ><|8|.x(

> | 70p7_GY==1cǂcǁǁOvOǃON > ><| ><|8 |6xp2\Pya .TEiKG/Wǀg_ __ _   < |   . ^.//. ^ \ |(%K??.? ^~ \~ ,x 9p >><|8|:x |&x0,pl9d)] ##G//_v_ _  <|<|8< <|#8<<|8|3x<<<  \<|<\^^ \||/x >PKK/?.? ^~ ?^ ~\~ 4x5p%YsyZ *uk7_7ׂo ~\~8~!x#p#cv'&a//_[_wn  +7p; p'O!_.Ge=&ǀ >>|"> ><| 8|*x 4p"t `'L`Y$!ssCS烇/GSG//_ N_ _ <|58<<| 8 |-x:|=x"p6xx2Fpx x*&p.f4-`/x:xx&8< <|+8<<||;x|'x>x||7x1p1^}/?.? ^~\~~$x)pij3J5U//׃_׀_o_o ~ \~.x =p>x+pC6GFOMO;;__wn  3x?pWo(wANC]>z   > >|<8|/D|?8|2xpT@iDA3NIC瀓炇_v//_ N_ <|9 <|%8|x,jp&xx<pZu`zD l$dTM\i[^t Lpxx6Vp>xx.6pv<`N|p!x!x.pnb=b%@/?.?^~\ ~ (x18x% p9I*S ggkρk//ׁ_W_ ~ ~\ ~ 6x3p=]{}Vmw?w7n  8 #x'p;g~/Q??w} >|,8|xpp_`$p?ppBB"]"{{K^ ~\~ 0x9pQ c`?qJrUπ+ς׀σׂ_W_ ^~\~8~&x-pmf;z-! ?7??n   -x;p=x/pG>Ov__;w >/1&'8| 7Xp,8p8 I~xS S;g'N  >>< |<< <|18 | xRp:2h`7  UqkYkׁ=77sSS7s7o{33yY[9w}; EE x!p)ar#2~''O+OWW?^~ \ ~ *x5p:x# p-M&[:ww[C[?7?on     5x7p+[w{^6};Gw >  |_cJppOp/p poXq>q}'O'OvN > ><|8|>x |!x8x8|x$bp(ten1+cW3׀ׂ'{׃'og''o瀧ooOggss w ww/ |?x)p A2CRGeG++OOWW?? ^~?^ ~\~2x=p Uk uFZMu?7?on 8 %x+p kn7V=m??w > |/ǐ^1c}ǃ'O;''O'ON>  > ><|8|.x(

> | 70p7_G==1cǂcǁǁOvOǃON > ><| ><|8 |6xp2\Pya .TEiKG/Wǀg_ __ _   < |   . ^.//. ^ \ |(%K??.? ^~ \~ ,x 9p >><|8|:x |&x0,pl9d)] ##G//_v_ _  <|<|8< <|#8<<|8|3x<<<  \<|<\^^ \||/x >PKK/?.? ^~ ?^ ~\~ 4x5p%YsyZ *uk7_7ׂo ~\~8~!x#p#cv'&a//_[_wn  +7p; p'O!_.Ge=&ǀ >>|"> ><| 8|*x 4p"t `'L`Y$!ssCS烇/GSG//_ N_ _ <|58<<| 8 |-x:|=x"p6xx2Fpx x*&p.f4-`/x:xx&8< <|+8<<||;x|'x>x||7x1p1^}/?.? ^~\~~$x)pij3J5U//׃_׀_o_o ~ \~.x =p>x+pC6GFOMO;;__wn  3x?pWo(wANC]>z   > >|<8|/D|?8|2xpT@iDA3NIC瀓炇_v//_ N_ <|9 <|%8|x,jp&xx<pZu`zD l$dTM\i[^t Lpxx6Vp>xx.6pv<`N|p!x!x.pnb=b%@/?.?^~\ ~ (x18x% p9I*S ggkρk//ׁ_W_ ~ ~\ ~ 6x3p=]{}Vmw?w7n  8 #x'p;g~/Q??wj*[;#*[;C*[;c*[;*[; *[; *[; *@ekUv"^ekGUv&^ekUv*^ekUv.^ekUv2^ekGUv6^ekUv:^ekUȫl턼֎ȫl팼ɫl피֎ɫl휼ʫl֎ʫl˫l֎˫lWWډyWڙyWکyWڹyWyWyWyW*[;@*[;B3*[;DS*[;Fs*[;H*[;J*[;L*[;N= Tv^ek'Uv^ekgUv^ekUv^ekUv^ek'Uv^ekgUv^ekUv^e{l퀽Nثl툽ثl퐽N٫l혽٫lNګlګlN۫l5Pځ{Wڑ{Wڡ{Wڱ{W{W{W{W{Ulu^e#*[WVU:9x«lu^e*[W0VU: T:Չxīlu&^eC*[WXVU:xƫlu6^e*[Wx4PꀼV'U:"yɫluJ^ec*[W꠼V'U:*Yy˫luZ^e*;@e*[WȼVgU:4թyͫlun^e*[WVgU:VU:{߫lu^e*[WVU:{߫lW߫ T*[WVU:{߫lu^e*[WVU: T:4PW6PVU:{߫lu^e*[WVU:{i{=ʾVU:{߫lu^e*[WVU:{߫lo߫ T*[WVU:{߫lu^e*[WVU:} T:7P lu^e*[WVU:{߫lu^e*[WʪVU**[WVU:{߫lu^e*[WVU: T:W6PO4PVU:{߫lu^e*[WVU:{h{~VU:{߫lu^e*[WVU:{߫`߫ T T:{߫lu^e*[WVU:{߫lu^e T T:{߫lu^e*[WVU:{߫lu^e T T:{߫lu^e*[WVU:{߫lu^eG T T:{߫lu^e*[WVU:{߫lu^eG T T:{߫lu^e*[WVU:{߫lu^E&'ݣ@ej{߫lu^e*[WVU:{߫lu^e*@e@e*߫lu^e*[WVU:{߫lu^e*[W**[Wg5PVU:{߫lu^e*[WVU:{j/l{=VU:{߫lu^e*[WVU:{߫lw}E=ʾVU:{߫lu^e*[WVU:{߫lO}}=ʾVU:{߫lu^e*[WVU:{߫lo=ʞ@el{߫lu^e*[WVU:{߫lu^e*@e@eo4PVU:{߫lu^e*[WVU:{U}~VU:{߫lu^e*[WVU:{߫lx~VU:{߫lu^e*[WVU:{߫@|~VU:{߫lu^e*[WVU:{߫`z~VU:{߫lu^e*[WVU:{߫P~VU:{߫lu^e*[WVU:{߫pyVU:{߫lu^e*[WVU:{߫H}VU:{߫lu^e*[WVU:{߫h{}VU:{߫lu^e*[WVU:{߫ܤ{4P=^ TvL߫lu^e*[WVU:{߫lu^e*@e@ek7P T:{߫lu^e*[WVU:{߫lg}f=>Nj{߫lu^e*[WVU:{߫lu^e  T*;VU:{߫lu^e*[WVU:{nh4PW6P TU T:{߫lu^e*[WVU:{io{}C@eOj{߫lu^e*[WVU:{߫lo=VU*;ʞ@e*[WVU:{߫lu^e*[Wپ**[W *{a߫lu^e*[WVU:{߫lu^e@e@e**~^@e*[WVU:{߫lu^e*@e*[WO4P T T*[WVU:{߫lu^e*[Wف*[W~ʮj_l5PVU:{߫lu^e*[W6PVU TvmfVU:{߫lu^e*[WVUvVU:{@e@eok?j{߫lu^e*[WVU: T:{߫**{WU߫lu^e*[WVU:{i{߫lu^e5P?6Plu^e*[WVU:{߫h߫lu^e*>@e@e*[WVU:{߫lu^E&߫lu^e*[W4Pٽclu^e*[WVU:{߫lG߫lu^e*[W'7PSlu^e*[WVU:{߫lg߫lu^e*[Wg7PCslu^e*[WVU:{߫lW߫lu^e*[W5P#lu^e*[WVU:{߫lw߫lu^e*;ʾ@e_@e*[WVU:{߫lu^e{lu^e*[W T*{r}c߫lu^e*[WVU:{m{߫lu^e5Pٳ T T:{߫lu^e*[WVUVU:{]@e/l5Pw5PVU:{߫lu^e*[WY5PVU:Klu^e?@e*[WVU:{߫lu^elu^e*[W T T:j{߫lu^e*[WVU: T:{߫**[W/5PVU:{߫lu^e*[W*[WVUvmf߫lu^e*[WVU:{߫P߫lu^e*@e@e*[WVU:{߫lu^elu^e*[W T T**[WVU:{߫lu^e*;@e*[Wnkl5P?5PVU:{߫lu^e*[W*[WVUvgg}VU:{߫lu^e*[W>zL*[WVUvL߫ T T:{߫lu^e*[WVUVU:{@e*{@}J߫lu^e*[WVU:{l{߫lu^e'5P@e@e*[WVU:{߫lu^elu^e*[W٩ T:G6P7PVU:{߫lu^e*[W*[WVU:{=ʾVU:{߫lu^e*[W4PVU:{߫ T T:{߫lu^e*[WVUVU:{߫lu^enom{߫lu^e*[WVU:} T:{߫lu^e*{Q}W߫lu^e*[WVU:{U߫lu^e*VU**[WVU:{߫lu^e*@e*[W.o{~VU:{߫lu^e*[W4PVU:lu^ek_j{߫lu^e*[WVU: T:{߫*[Wٛlu^e*[WVU:{߫P߫lu^e*@e@e*[WVU:{߫lu^elu^e*[W T T**[WVU:{߫lu^e*;@e*[Wnkl5P?5PVU:{߫lu^e*[W*[WVUvgg}VU:{߫lu^e*[W>zML*[WVUvL}L߫clu^e*[WVU:{߫lG߫lu^e*;>VU) T:{߫lu^e*[WVUVU:{@e@e**[WVU:{߫lu^e*@e*[WNm/j{}q߫lu^e*[WVU:{n{߫lu^eg4PW5Pclu^e*[WVU:{߫lO߫lu^e*;ʞ@eOnol{߫lu^e*[WVU: T:{߫*{V=ʾVU:{߫lu^e*[W5PVU:  T**[WVU:{߫lu^e**[WVU:l5P5PVU:{߫lu^e*[W*[WVU:lW5PO5PVU:{߫lu^e*[Wف*[WVU:_l5P/5PVU:{߫lu^e*[W*[WVU:l75Po5PVU:{߫lu^e*[W١*[WVUvCaVU:{߫lu^e*[W7PVU:/] TW T:{߫lu^e*[WVUvVU:{@e@ekj{߫lu^e*[WVU: T:{߫**PW߫lu^e*[WVU:{}T:{߫**w߫*[WVU:{߫lu^e;lu^e*[W T T*[W T:{߫lu^e*[Wv6PVU:! T:lu^e*[WVU:{j{߫lu^e6P5P#lu^e5PVU:{߫lu^e*@e*[Whj{߫*{\߫lu^e*[WVUVU:{@eOj{߫*{J߫lu^e*[WVUVU:{@ej{߫*{N߫lu^e*[WVUVU:{]@e/l{߫**[WVU:{߫lu^e*[W% T:{߫**{y߫lu^e*[W7PVU:lu^e*[W T T*[WVU:{h{߫lu^eW5PVU: T:{߫lu^e*;@e*[Wʮm{߫lu^e5Po7Pٛlu^e*[WVUvVU:{߫lu^e*[Wٍ T T**[WVU: T:{߫lu^e*[Wninw7P4PVU:{i{߫lu^e*[WVUv{sVU:{߫h߫lu^e*[WVU: T? T:{߫lu^E%߫lu^e*[WVU:{}\ݧ>VU:{߫lG߫lu^e*[WVU:{}j=>VU:{߫lg߫lu^e*[WVU:{}n=>VU:{߫lW߫lu^e*[WVU:{}I=ʾVU:{߫lw߫lu^e*[WVU:3q T**[WVU:= T:{߫lu^e*[Wi4PSlu^e*[W6PVU:{߫lu^e*;ʞ@emok{߫lu^e*@e*[WVU:{߫**{q}O߫lu^e*[WY5PVU:{߫lu^e*~VU# T:{߫lu^elu^e*[WVU:{]@e?@e**[WVU: T:{߫lu^e*[Wʮn_n{J߫lu^e*[W*[WVU:{߫lu^e5Po7P~VU:{߫P߫lu^e*[WVU: T' T:{߫lu^elu^e*[WVU:{@e@eni{߫lu^e*;@e*[WVU:{߫**{K߫lu^e*[W*[WVU:{߫lu^ew5P7Pهlu^e*[W>zJ*[WVU:{߫lu^e6P@e@e*[WVUVU:{߫lu^e*[W T:6P٧5PVU:{l{߫lu^e*[WVUvr߫ Ty T:{߫lu^elu^e*[WVU:{@e*{T}i߫lu^e*[W*[WVU:{߫lu^e*[Wklu^e*[W4PVU:{߫lu^e*[Wʞ@e@e*[WVUVU:{߫lu^e*[WVU**[WVU:} T:{߫lu^e*[WVU:7P4PVU:{U߫lu^e*[WVU:Klu^e/oi{߫lu^e*@e*[WVU:{߫*[W٫glu^e*[W4PVU:{߫lu^e*VU**[WVU: T:{߫lu^e*[Wʮk{~VU:{߫P߫lu^e*[WVU: T' T:{߫lu^elu^e*[WVU:{@e@eni{߫lu^e*;@e*[WVU:{߫**{K߫lu^e*[W*[WVU:{߫lu^ew5P7Pهlu^e*[W>zMJ*[WVU:{߫lu^e6P5P>VU:{߫lG߫lu^e*[WVU:Slu^e@e*[WVUVU:{߫lu^e*[W T T:k{߫lu^e*@e*[WVU:{߫**[Wٗ6PVU:{n{߫lu^e*[WVUvf=@e_@e*[WVUVU:{߫lu^e*[W9 T*{j}S߫lu^e*[W*[WVU:{߫lu^e7Ps Tm T:{߫lu^elu^e*[WVU:{]@e@e/ni{߫lu^e**[WVU:{߫lu^e**{yH߫lu^e*[W*[WVU:{߫lu^e**{uL߫lu^e*[Wف*[WVU:{߫lu^e**{}J߫lu^e*[W*[WVU:{߫lu^e**{sN߫lu^e*[W١*[WVU:{߫lu^e76P7POlu^e*[W7PVU:{߫lu^e*@e@e*[WVUvVU:{߫lu^e*[W T T**[WVU: T:{߫lu^e*[Wjn7P4PVU:{}T:{߫lu^e*[Wʎmk4Pʎk{߫lu^e;lu^e*[WVU:{@e@el{@e*[Wv6PVU:{߫lu^e*;>@e*;VU:{j{߫lu^e*[WVUvZ}I=VUvz߫lu^e*@e*[WVU:{߫*{\߫lu^eg5P6PVUVU:{߫lu^e*[W9 T*[Wmon{߫lo߫lu^e*[WVU:9 T:{]@e@e*[Wپ*[WVU:{߫lu^e5Pw7PVUvq}o߫lu^e@e*[WVU:{߫*[WVUvYhVUVU:{߫lu^e*[W T:{߫**{M߫@߫lu^e*[WVU:lu^e*[W5 T T*[W*[WVU:{߫lu^e5PVU:w- T:C T:{߫lu^e*[WVU:{߫**{GYn{߫lu^e*[WVU:{߫lu^e6P6P{H߫lu^e*[WVU:{߫lu^e*>@e@eGlu^e*[WVU:{߫lu^e*[W T T**5%lu^e*[WVU:{߫lu^e*[W>@e@e;lu^e*[WVU:{߫lu^e*[W>@e@e;lu^e*[WVU:{߫lu^e*[W>@e_@elu^e*[WVU:{߫lu^e*[Wʾ@e_@elu^e*[WVU:{߫lu^e*[WY T T**@e*[WVU:{߫lu^e*[Wmon5Pٷ4P*[WVU:{߫lu^e*[WVUvA}{=ʾ5PVU:{߫lu^e*[WVU:{% T} TV T:{߫lu^e*[WVU:{߫**[Wُ5P*[WVU:{߫lu^e*[WVUvel߫@߫lu^e*[WVU:{߫lu^e*~VUk TvVU:{߫lu^e*[WVU:{]@e@e**;@e*[WVU:{߫lu^e*[Wnj?mw4Pٟ5P*[WVU:{߫lu^e*[WVUvkmʎ4PVU:{߫lu^e*[WVU:;_ To TvVU:{߫lu^e*[WVU:{@e@eik^3VU:{߫lu^e*[WVU:{@e*o}bh{߫lu^e*[WVU:{߫lu^e'6P@e@e;lu^e*[WVU:{߫lu^e*[W) T:5P4Pٮ*[WVU:{߫lu^e*[WVUvz߫ T TVU:{߫lu^e*[WVU:{߫lu^eOhk= T:{߫lu^e*[WVU:{߫lu^e*{Z}Km{߫lu^e*[WVU:{߫lu^e*[W;l_߫lu^e*[WVU:{߫lu^e*[W^@e@e@e*[WVU:{߫lu^e*[W.k{~7PVU:{߫lu^e*[WVU:+lu^eik T:{߫lu^e*[WVU:{߫*[W`߫lu^e*[WVU:{߫lu^e*VU**;@e*[WVU:{߫lu^e*[Wnj?mw4Pٟ5P*[WVU:{߫lu^e*[WVUvkmʎ4PVU:{߫lu^e*[W{>$mINj۶mwk۶ͩm۶>9۝_|?f;8sfY>J}fm+;@iJoP}'{fm+ZV4ko[iֺ߶ҬumY>J}fm+ZV4[?(@iJ&fm+ZV4ko[iֺ߶ҬumY>J}fm+ZV4](ZV%lnfm+ZV4ko[iֺ߶ҬumY>J}fm+ZV4"ҬJ}fP@iֺ߶ҬumY>J}fm+ZV4ko[iֺ߶ҬumY>J!(͆ 4ko[i6\fm+ZV4ko[iֺ߶ҬumY>J}fm+ZV4k@i6QY>J(͒J}fm+ZV4ko[iֺ߶ҬumY>J}fm+ZV-'lyf+4[QJ(ZV4ko[iֺ߶ҬumY>J}fm+ZV4ko[iJPm lCf 4ko[iֺ߶ҬumY>J}fm+ZV4ko[iֺ߶Ҭumv(Ͷ@iJP$ҬumY>J}fm+ZV4ko[iֺ߶ҬumY>J}f 4_(@iV 4ko[iֺ߶ҬumY>J}fm+ZV4ko[iֺ߶ҬumY>JcP'xf'4ko[iֺ߶ҬumY>J}fm+ZV4ko[iֺ߶ҬumY>JsP'|f4ko[iֺ߶ҬumY>J}fm+ZV4ko[iֺ߶ҬumY>JkP]'zf74ko[iֺ߶ҬumY>J}fm+ZV4ko[iֺ߶ҬumY>J{P'~fJ}fm+ZV4ko[iֺ߶ҬumY>J}fm+ZV=-f 4{N(ZV4ko[iֺ߶ҬumY>J}fm+ZV4ko[iJwP+=f 4ko[iֺ߶ҬumY>J}fm+ZV4ko[iֺ߶Ҭum(;@iJP}/ҬumY>J}fm+ZV4ko[iֺ߶ҬumY>J}f 4Gٿ(@i@J2F (lZ$*Z@e6PٌH@ Tf3 %P~σm (l$*Yf@J2] (l$*9@J2[ (l$*y@J2_ (ʬPY{$*H@ Tf  %Pu@J2$@eY (ʬPYW$*nH@ Tfz %P@J2%@e[ (ʬPY_$*~H@ Tf %P @J2$@e6X (lPP$*aH@ TfF %P-(@ePH@ Tf#F %P@J2#@e6V (lPx$* H@ Tf-H@ Tf& %PM@J2KH@ TfS@J2[T (l1$*̖@J2[R (l)$*̖@J2[V (l9$*V@J2[Q (l%$*V@J2[U (l5$*@J2[S (l-$*@J2[W (l=$*6@J2P (l#$*6@J2T (l3$*̶@J2R (l+$*̶@J2V (l;$*v@J2Q (l'$*v@J2U (l7$*@J2S (l/$*@J2W (l?$*@J2;P (ʬ@J2;H (`$*C@J2;L (p$*#̎@J2PQH@ TfG %P#@evPqH@ Tf %P @evPIH@ Tf' %P"@evPiH@ Tf %P!@evPYH@ Tfg %P#@evPyH@ Tf %P] @evPEH@ Tf %P]"@evPeH@ Tf %P]!@evPUH@ TfW %P]#@evPuH@ Tf %P @evPMH@ Tf7 %P"@evPmH@ Tf %P!@evP]H@ Tfw %P#@evP}H@ Tf %PUH@ Tf %P=(@ePH@ Tf %P=*@ePH@ TfO %P=)@ePH@ Tf %P=+@ePH@ Tf/ %P(@ePH@ Tf %P*@ePH@ Tfo %P)@ePH@ Tf %P+@ePH@ Tf %P}(@ePH@ Tf %P}*@ePH@ Tf_ %P})@ePH@ Tf %P}+@ePH@ Tf? %P(@ePH@ Tf %P*@ePH@ Tf %P)@ePH@ Tf %P+@eP/$*i̦@J2N (lz$*f@J2I (lf$*Yf@J2M (lv$*9@J2K (ln$*y@J2O (l~$*vH@ Tf: %P- @eQ (ʬPYg$*.H@ Tf]̺ %Pu@J2!@eS (ʬPYo$*>H@ Tf} %P@J2 @e6P (lP`$*!H@ TfC̆ %P @J2!@ePBH@ Tf %P@J2%@e6Z (lPX$*qH@ Tf& %P %PM@J2$@e6Y (, %PM@J2[D (lQ$*@J2[B (lI$*̖@J2[F (lY$*̖@J2[A (lE$*V@J2[E (lU$*V@J2[C (lM$*@J2[G (l]$*@J2@ (lC$*6@J2D (lS$*6@J2B (lK$*̶@J2F (l[$*̶@J2A (lG$*v@J2E (lW$*v@J2C (lO$*@J2G (l_$*@J2;@ (@$*R ( $*@J2;T (0$*̎@J2;R (H@ TfG %P-@evPٱH@ Tf %P/@evPىH@ Tf' %P,@evP٩H@ Tf %P.@evPٙH@ Tfg %P-@evPٹH@ Tf %P/@evPمH@ Tf %P],@evP٥H@ Tf %P].@evPٕH@ TfW %P]-@evPٵH@ Tf %P]/@evPٍH@ Tf7 %P,@evP٭H@ Tf %P.@evPٝH@ Tfw %P-@evPٽH@ Tf %P/@eV %P= @ePCH@ Tf %P="@ePcH@ Tf %P=!@ePSH@ TfO %P=#@ePsH@ Tf %P @ePKH@ Tf/ %P"@ePkH@ Tf %P!@eP[H@ Tfo %P#@eP{H@ Tf %P} @ePGH@ Tf %P}"@ePgH@ Tf %P}!@ePWH@ Tf_ %P}#@ePwH@ Tf %P @ePOH@ Tf? %P"@ePoH@ Tf %P!@eP_H@ Tf %P#@ePH@ TFm̦@J2V (l:$*f@J2Q (l&$*f@J2U (l6$*@J2S (l.$*@J2W (l>$* %P@J2 @ePYG$*NH@ Tf̺ %Pu@J2&@e] (ʬPYO$*^H@ Tf %P@J2'@e_ (lP@$*AH@ Tf̆ %P @J2&@e6\ (lPقH@ Tf %P-,@e6R (lPh$*1H@ Tfc %P@J2 @e"@e6Q (lPd$*$@e6E (l$*E@J2[\ (l $*%̖@J2[Z (l$*e̖@J2[^ (l$*V@J2[Y (l$*UV@J2[] (l $*5@J2[[ (l$*u@J2[_ (l$* 6@J2X (l$*M6@J2\ (l $*-̶@J2Z (l$*m̶@J2^ (l$*v@J2Y (l$*]v@J2] (l$*=@J2[ (l$*}@J2_ ($*J$*@J2;D (P$*@J2;B (H$* %P%@evP1H@ Tf %P'@evP H@ Tf' %P$@evP)H@ Tf %P&@evPH@ Tfg %P%@evP9H@ Tf %P'@evPH@ Tf %P]$@evP%H@ Tf %P]&@evPH@ TfW %P]%@evP5H@ Tf %P]'@evP H@ Tf7 %P$@evP-H@ Tf %P&@evPH@ Tfw %P%@evP=H@ Tf %P'@evPY%@ePكH@ Tf %P=,@eP٣H@ Tf %P=.@ePٓH@ TfO %P=-@ePٳH@ Tf %P=/@ePًH@ Tf/ %P,@eP٫H@ Tf %P.@ePٛH@ Tfo %P-@ePٻH@ Tf %P/@ePهH@ Tf %P},@eP٧H@ Tf %P}.@ePٗH@ Tf_ %P}-@ePٷH@ Tf %P}/@ePُH@ Tf? %P,@ePٯH@ Tf %P.@ePٟH@ Tf %P-@ePٿH@ Tf %P2IJ2F (lZ$*̦@J2A (lF$*f@J2E (lV$*f@J2C (lN$*@J2G (l^$*@J2k'@e^ (ʬPH@ Tf: %Pu@J2"@eU (ʬPYw$*H@ Tf=z %P@J2#@eW (ʬPY$*H@ Tf %P @J2"@e6T (lPp$*H@ Tf %P-$@ePH$*QH@ Tf %P@J2'@e6^ (lPYPD$*IH@ Tf̒P$*E@J2[L (lq$*%̖@J2[J (li$*e̖@J2[N (ly$*V@J2[I (le$*UV@J2[M (lu$*5@J2[K (lm$*u@J2[O (l}$* 6@J2H (lc$*M6@J2L (ls$*-̶@J2J (lk$*m̶@J2N (l{$*v@J2I (lg$*]v@J2M (lw$*=@J2K (lo$*}@J2O (l$*@J2+@J2;X ($*C@J2;\ ($*#9EXIQ!O}̃.d#2H3jϹGm{+ľ;!?,T.!ߗwA>)2ۧO5U>[\Y|ORﯤ?UZ>?]RcwSM~:о'%e޲d>{>;.JA.2pGn>To{m!n6ը!ekٺIԟ÷xj$l:-_'c?7t뻀3ɳ)Sض׫{Jw'ͮ;"~X't\Yj҂!{GHGxt3.?y>r&oj>赞 -?w'ϼqs[TNJu"VNj6/_>?]a`Q/ qԟ#:iz/lbGK<_!Lܝ="?!G2Я O˞ ?O!%F/Qq4[O^oyw{ۧo dx/z)(y_]G q\\k%c?8&]rV;*(A*&ǡGgD6ۡ|]K.w|p-׬K~ޑ.c?z)Ep\azP~>~}OD/~qD/<Ї-_ю+g?נ_Sl)ۻӏ5.  nD/Msy*pukl^ŚsL%ɋ߿9ԡcԟݻ?Zş\;;x_AvxHniP5v?Я>-v$>ovܿ(MP)Ҽ+__hӹ~-k?2^>s|[.ۿ쌅|&V(O_FF/,-k?nQL^.W}rz3r=ܾ|vϯZ3OlKOLCޗGl *<"m)~ɱb14e ~׵|gCX^hogZa'k)r~σoaIq9y);k|@UIJ\7*>cG|7 ~+džz w:3?~kH>v'I9L]G~=1yIn8\@QV/|O۷S"˴iN7bEvsKY/IC{>@+>N;&Y/'I&8D>=Ҭ\3(_Fgqբ62_M+j`>Qv5 tujlnD (^f?c yIHYq jޮ's/ues׏7)u; YjR65̯ɫǵ<.l6ۗ9}mZr(5r=>Nߌšm%3o[>%㸯:.v]G zR: h=|y5e+s5ߣcd~jςE=[bq4HnGQy'r"3gy9rx)>_26)*Wa(d{n~=/k|F0כwvu}?kcQɡy.]ۭ\->iBaet靹c훮vfɐc{w\^o]v=l2RN.&yQ 9IiQȻv4lc$K7X%د&]>׋+8xֱ o|#Z}>\Q\?Bƞ?|~g/GUFwn5_%9N$.^) GR E/;_x5@?A^K=#!rrېS}{l&o o5$7.s@9$)HzTNnxrN{Sp;Th~u_8~;(p.'5~2?M_Bh}q6jt_q8f_zA#}&Y,#9##g*ЦE)}.plj+Ќqܞ˷秉䱍{\/˳E4Yv~NS <|v\+?*Պ[B^KP[8W~+~\Sɫ~*>iK$A?ƧF K];ҦƟ8P)r^_ {#ٷ^9oH΃-<*yۓ౜z^iT*?8O7D?'[v#8WBkvmq~H 1.~ #"l Kod#/? ?'b7/ihRcq o_wE.h"Wɡl0!7E#t+S__bW 8 ]>ǷB͇|jy$[7T!y,cEx'7&fת*ѿ.yWRTiGVqW!Ņ_]\.Ams^]K6k;pbXj~;.w6nIBN(d 3!9f7grgߦGӖ4v_0O[yz{n߿Zr?m/Z\b ulnĈASK|!A=q;+8Oa;ass~dd?av}+y㿛^cn:VhY8 pȿ*\?x==KRw6u~;+_o؀z8S"˕|U? i#j F *ʟֵf[kz"=Qyn)We?#Kw3 :;ofw2ydVw٪ ra*y4tԇݓ>^cKs$.иV# n1/%'&KWU{uh7˭:kUj\xi7}? Kuasوg?Q6~?ޏ֏vg#oSfwNn!sD.tqUsv6u^t`'W!rj}(O?Y2gmU9LWoiX>sr1zJz[nȫMs\>uwxj:!3) Kn!Yq%ZUqf>*-o6116AǏE4s+lN=oy|szu~6GWzcQn gWB~O;m{;4yf3-B֏3a{dQN~ӏ6M&Krt)vEJߧ잴|^˹-1v^xX tG,vi gw,>K}hW k|@n~;zuVR@U|ž.k:{F/ܷ ғ׭L?s;n7QC]q-vt+r\ѹ/?lw=>.: G󅰠<.GN^_,ۘ_p?Lxs1k)«\3GN;oӝ;{uwJ6.TL>v|#vy{/՜Ad՜G/yr53nIٷE!C^#b߄q!}$w:`(/irYtsk2yN*uOU9%)㠥k&O^|y͹㉥vGK?|q?fɇؘJ.3r9|*~. FW+v"6S#.O˟ ۾v=:oj_Uʎ{: yC"'s=<ӕk{zapiWՌujxfpiWo潙9_U$> ZE {_KrtɑcB7[n1/i} Pl߉7xԾ~c>V9񆸧}L&Nmx|4jlT'ɡ'n.%߉Os|;9v*׎)8ߓA^)V: =;iZtdس{?S1r&Ӌ)e*Tb9.:Q?cL/"J7{r ]6Wh M?㶔\:. ޓ?5Q_%V^*wYdW-a^?M{m2߳TrUu߳%xeWï=w}$sy$}uzmjQ{=8'VGPՖ"ȻKܞn8??-u{򽵩_"wgy+FRm_q<U<&x~8ucx{+"ςzyG3?]YB;J3r࿣#" |L&Ǘs\h<Ўy6'+rwҏǽ׮u9-~=qonx?肇gkrf{2Oo\̟,,T?dh,8Z3ka ^*ׂ#8!_wTVȳȨCzdE ]hz*\3S)iE\N;Zl=pKc(mSN39|'^kׯ%&xL3ZݸZ!l9 |nq߁|?<3xdNܮ#{4)^ć\ڿr9p伃+̘ݷ,ܷo<^dy9z7*Ke hfڐIЀ EC.vBo~F {lϡ,93%ϵ p;P;;q0n6?뺑w)O=;k~,;\>1[yn7CIWst 'Wqz}eը-ǡ7[zZJ=:=,q"r:qaܙ &TO5MW9󞸝-8u-+p܎1'Es]v 5>pYy t;A#nO[v<.swv8A+CG~_mx܉[2w'-kreI?ChPp# 9[<=շiS(n_wMz9Qǿk5}wS%vХ Liy O7d(9㳵b_^׎쐞){)f"m?rIls_BnuwO8q;jHC veWOͯ#(hד䗶I c'jO[qJhrf{4kkA^󫄴QqzvCKy>ρ}ĢŤws rkDܿW9X[r-WEqSp}٭@?6b!;c_XkRQO)f+8^A.^=crH<+n͘eྍ*r=0p!*s/Ǎa/s;xܰ\w_ǿ.]\,]xR(eceU[?S~\/r8szSj)GVt.yfU}#8?՛ىէ,|GxˇevyaSu?Sh>(?'s";\[1TL%YisM=LE'Q}嬻F[z6 S>/;S]]?ߛpЮmUc]~{;M:9[Oooݓu HNB{yvܾ>zέS՝R;qӾgblS ܢRr{,;~K_2oOjGqgr;zz>U~k?urMf?9Ul{W}]Y,$K=t~.e'lOף&.iuZQB+&5ܤOyL?9N@L1,_WตuyCU}Õgu?}wݜD}hwQ+5,^}rq6J<и8Ep_|tWV]uMu3B:/7.&k3{L}MI{s 9,E=&ϫ:b|8Jiッ<6[n'%SdʹuyT?-C??{1_gbns}?пsoU?׳%>Go$-frrZGse>?Yk?>{yi~{]n #^ؾRح& WhE_Rڴx^᯾.q#f]TF.Ā^M;z|]smnBvQP~Uj"RȎt%8~ܗ?KϏQ掸ASi3:Arܬɝ%z=#|Z:~y8&3<ȷϙp?A5({Kb]ֵl]wj6;ǥЅ;>xm\jǛ(`ܩܾ}k˸YFQio3Yu|^_>N {B\x7u亥XExqdQe\9?;on/8J]丞9ǩę*~Ԝ\}+/K\|[Vxn ޚwpRx4y8jഈ'[>#ϲq "QB'Wx49~&1K߆zOMr<3ps%*xO^Glݣ\ yg}<s9v^m|^~sIg*ֻשro<-_էe[Zp{+Կ=.9^4/DRqyy<vS/&/p.r1Po'Ʈ R*Spr,u}_+JTr]pywa_q!z-׏N9,ҁ3p?b&|ߡ>,3?BJs}-'統%y\eNfKp}︧8^6,^m rG!E;qgď,N_ ޶*='9N&ܽڀ1pN$HQ Uy;qSW"=?ZΟ?o=3r}^]-MA+B>Mop.: 9NkH}6]XȩH?gq4j.<ϳ68K}rӹmv~98o7֙+__*he>Wx/~{ŪBf-mߖ?&pmoX,c(`4p^a YדB;ro@d@'1uNK6!HLJ|#S>ӟ}k|b>d oނd]~'- ކ?~<Q F^|d,dԮ*=|ѷz}\ܝ?w|Ux.ȩ-{9˜?||^aIwKCMޯv8AFMn}8ڎDaAEx~'q}rL] R&!N'}_tx0xЮɣ\\>OɂesO4)z|-x,Ks op^o>K*:Hn t}];KLLX/Z\< VrW?"58O5iEݳ=ge=rt{\/?͏ Z՚V6ϷO9OlS FcC9.wyYJQ̒Cy{:9|+w'֘:^sKHjw2^s[[_b+ӢF?',Y;p^S+(cS_>QϿV?tz`x퍞{|f$lN/_odX%n7p^du}z~ Ϳb~δS:'yq1TҳJPߓ#:ޕhULڔ݁>}vs!l#τEy;cGݿ'&-yYKO8GyE7]妞 )pn9vݗ^7m=7GGU;dR_'(@RWseU(a~]knuvS2gB|şy(%Ӷ@i)|i,<=nGz~;jcܩױ:n6{wݘ.S87Р}I'I$cE|=%s;=N8Eyql_!:Ei7)vNV%sp\ m| ǹGKsK|>G3G Q%(>]Lٗ}yI_Qr^_S(vp蓬4uKtGoJDr\/Ov.ygS99YpT=r` ǭǰR<'\jᷖrM/}]ONOv7`n=G=$V%s3#LJ39L׽KwwvVѷ/qةh+ο\WD3Hl('ƫxc}M~ir\y9qq.7.].z!:hr>~b.\.<Ք T]3 ӕ/TFЩ-KAK-yh[/DZm(w uiI!!u}œ[o=_F[F | z7Ovyuy<'p|Pc2/N^Gn;Lw=i͸5[X^_؛xg[)phB }yÖL9ߣv ZHAuk-E#@gߩv.*egJ>O>~r9]w4vٗ~CY}w}8 q{J+'yDnYYhwJoخh}_n~.~,'NM&P]ZڐGd5qΏmeylws/8֣z1~}ڑG؎9㕸^,=x<{4nֿ]cw= ;n1v^[n3QY߬'wg|,ݬ/<,[t%r >KZxpȵ|+o.KM|=r藝|ΧֵwHUҀ-k*WU?>l~~?)xbT%n[nϥ._R!JuA 5αzgJ .ÔMbGÄQEm6nG}z!Z'.\U^s\+뫰 >~`}}'2mQt5哐xrCy]}2zZr+;#oM~\Qrgy>Y,$^}eE5ĖW}OMLJ-O%o)j}z~Qt~>!]Sy<%u-6Y?y@e#_z}a<xɛf\t;?{3(I;VJ;6'`s~Wϒ9rpfo\1_8;Qf`)ҷkGWC}mをS!E]mIyg#'j ;a?lwE6y$M\궕'dE%^-\HȈs=U|յz\o&W>NuCS|-. Nw>8.$L^S(z=)^\LOV;]û2vWrY5nVM__\P&?n1mد\Kkv5ד_hz4v%}GϮ=?S694qRuf$x/pp<8?>.rw_e!wj׬i_j ܟV?`k&lټk۩GRO-t O(6( Id$ܞb%]o\9??>nsg)5K'kuvTƒ#}՞ q˚QA#z~-v?\%OGu?h7x ԅ% 1&\a';WmQB-ѻ֧;|~\:ﮉkd!xnHY/u狛\IUۖx>=vq[X7_Tױ9R--ҶSt:ӷ|p y-ϛ VbO<7nU<~FYXOϏvRKW /w\ 2$m=n^QkrƸF]|4ȵθ9f}{^"dh=/AǗϹ_ty6$dfs.NIֆ]DޏfDIJ=t 8}e@:?.%og|ܑ\UYi8tWcTbP~/}y\LzE?a7.ŵ8ٯSsI1U=}~ uo@{~=U˾0/חm{yI~wϏ#z{z\Z4/<80yevǷc n O~̩~?DO[.rrJR2/W燞~E_WLo\qwKh-xxބV((B"L>h>Z,97{q KsH ߽Z]zbl=?%ۧRo uQɭޜy߿i%7Qc^w;H!>/X'ҵ88j$9lwѻ@zQ\3K.9Vugu6Mɯ,{n7nC'./oW?N b|c v+"iשּׁCTs׉ $5>{6뛣J~sjeכON]ڧc<r"B?$.0Ȫs}{ɜpfΨ.q{֞ Pp?~W?Tungjrȿ"~>kJ_=8Z+[۾O 1fˬ%<3 c٦[:ZI3ğ}nWh͙SFDnq&QN#b8Dz={$oGn>,<)p/_W®Rҧxoȁv|fՕG6"7ɽV=WO|\nRK܂q1b(-qLn{ ޟ.B!|^e^_Ix[UHF? W74(OX)y7u/˥rb?wL!_y ^S~Β4?v{=^;z=ޟS5ӇUґҁ\>&z lw^N۽'6+BuNT?y>o~eF4[ | ~/nLA!wwrz4y[&0wY?dRUGzT1[s*E>W\r2d]H,iU~Pl㮏N ?0a*)`mS,N\n J jC^w/KD|Oyw8V@ :|'z}uy Iwgx"87e7.y:“._D̬ب޿}Ex]3G 3E_{btMzcnA3krrem6r8+]?qK,_G7J:>o/MωӤ}_4V=GHs_F\@ѷ>IAowIOCG]ޞ|ڟq#`sZEOBo#tÆz}w}hMtvE(`o<5~|ppEz^SaEMvI_cDĿï)b#V:?}ri:HM ]m9O>j9ϸ~׌ݯck7M.I!;l+h Ғ_6_>~®׻sd"scf!: _ޅܳn% ;Zpϫ{'WJz?'_'ty*jPdl.4lq]'TmS?'΍z:<)NwF{v{M_Is>>ޛp,o.֑ݹy:TO۫wӆRY%Ob&,r}r;zqV*{teyͽԆNPё}Z~\yVM29i=㛽|.n7/w>!z]ma|~n ;\{ :p=%WO+Ӝ0Ӫ*gU-:Ww-)k(xKšoöx:Iȼc`<||7ۿcS8z;R;tp~_{=S% x}Oϯ]tq3_58?޹)<[m'iRMȫ\zuVde~u3~uq5bLn"}x}(fg(&Ýwe%ߠI|=Au ύ.㍥xE9W!3p}ߺsO>Ko{T]0K-rK_ߢt/^S0UKn7vG8p-w*ͦ%) k19Vz;uYnd h9o&77篖u!OL>/{q:y'~gq>zܮG\FP'3splw䵾sNM/NW|Ťq,yO~#lU|dGy8xXZN4nx>K8~Zvwq m0~-6È蘍~Y{; ~pq)vfz}CNEOĦ<Uo0F!=>$^])λ%{^s}[+[yCjuUrgR7WKgҜQ.2%Yex>iixӴVcȻ~?.W#;s>d䴾6Z3s߼S)xG9.$%;?|u?&Y˧ǧg%]YLA>^=nu7>ԛ#Bco.qyF_HTx"/8Lj]V?dE[w&3_ ̴c>*7䑭Tf|Oq3ڢC93YOvk^^uXEܶuIҤx.z|/oTĽ\lJ*̋Ҧ/+#9~|KNJ59y}^S)0_×Oߠ>$ɜ|X?y'/~Z5=޳l$W'NzܹN{.m3sFܚAOkSWsyҬ?I#B>tc~Qw+?}3d٥.Fy|'œycwXtCã|ڙ^8N6o"}9_i뛱3D}aw({ӧuk<Px%ea>oAsqe^(pa=%_vC{C~h].;\>҇7)߻t?O ;M727ks?l,?Y'?W O}"j1q +ҚOc !^o925I~s3~|s^OhNL~Ο>ogК{MGW?n u0ɀ:n3H?pwVא˳Z'z5_^l9%p]sܽ>7\(tOz]2{A\ΖARDێ|_L_Z]hxKri|oKGq;:zEo~H6ί{NjA⮉Іgss=rS04z-Ito58{+wEηU?'߬sV NjxNX{B,;]̯ܖ\ / Ue]KjTqo="_kU;?C-py)ߨOzD—6*O>rߜKѿ:vϩ[1W?xr?0W1OGV_5%wwWGͻx[b/_SQO O/ V EYOK]OU{l8?,ǟBKj<1c-'my~-]1 _}T %\4RPЇ}=Ply<;5ymБ?ח|Q#s=7Q(Fz|\#vS$䉐e%7yyͰ%[rxZ'#"%D;ߙyu/\T2Jg|+6y5?v<Wգn ſ9Q|.?,ߋٗVk7gü:5vfQ7ه~! e?pO MJ ?P dcmsr;I>f1z2.rh)\Շ9ܗSЛ+SW]EYKgfD_Sޜ?ql~(Ozs Σ^igLm^ 𴗞?o9 ?ۮn~β@V") cUzoĥsiomUfUG>s?Rw ^ߌu>~{Lv{6?C?CR7aC<۞C?U N *s4o.Sl?:sq1yO!}6  U~v7g+;Dύa./O~?Fy.xW<ܛwNle.No~+:7ykX +ׇvmV!| Py$ݵJ_?CJq=$7wd L?Gn=&=&W]Tg|~.}G,yofv+JH)p 1nԠb\q嗍l4/w0Rq/uy*8R9=yͤzD }&BʹQ9?Ηl+SΡv>\ MvKzS G|eݟGL}>spWuy8sbE~>~NI((ҽ6.ɵٌ\q{sFYlG9 9o?QU~q.- Y0"%'NۮF+| ǍH ubymZ[ߟiT mSzgRǪe6TI f>r< ^l?s@}J?i9~8~k6A?䝒g8iы|Nǟt q;;#}H/rS>ǻIX{=? KﰑJHAȟ9^z}["ʗHrplj^i5)j ZϿ^˜Oe~= R}ힾܾy9}.s'q:>~LB}?G?l1r۪8=,>c+})G{⨎z*o1OIvژ4>"{sd5swZRБN^4:83ZFN{2r 4k?veC;e(tV:~~}@:~s7so^杤mXO/~{} jѐ.Nq=e~'ㄊSz!^uFy[%GKL\BWt7v9(xγwϲ~UO :5ѓePs1!P`gK߿Wss!>5*Q]u~w4_9S76gI3FO 7>])ussν7py~mJ"A=:-B#yS6N^4MWn_;;yEт򽷒Asz}_=lג/Ig_y3ՑϬwm6HMGכt:/bf,3yڗάO\+ui#n=Jnȶ2e=WqEoōKwE>eN~|cGO'^rgFsAdӿ9~YҝiQm ~-ǛBNyoQz)C8s[r^WKEG~\S_&sRǘ5ɮn{MwA]UZVOSm NNj̳]Tv뱢Dzqv}U8m$~zHlAK/os-~/F̫@k+S{&bn#C]7?кb]32s0:7ljܜ3 ϗ^FϷNwQںM8D8&Amy;5g惷>gwRُR@S(~-4Ak=+k//񟭌ݡǶWN؁Fòy۫\9\s&>LYϷك>{&!I/pb#Wo{tiL/o+'5nBg }bـzi54yGYs7q[^P#DLh_|Nz<ʷ~y.dJ'Or/3"~߫.-SkF_aiwԧL(|дu3/lЦf=#|1]y}wwnUӞqIΰ ܷOq+1!=WKޖ|KЀ3-[.|ܯ'$Pi~\~Z߆߳(e~?Z#k,7kPi!:~<}YTN~էx\o[7E#sSPل{zؔs-qum<-7ums3-q5']%uO?9X y?v=Wni}?,rN;ɡEӴz~s4'ȭߨA4 }?wOu9K[׾V2=yL9!hb!g$^L~^&:yT-gztNVo5\>!zc'-H r^Wk?/N>.=k?2m>2tz~!r{72Bܾs)tǏ8w+Flۯ߀_ܥ]y6GRD7'E% Η;/ǁlbwā Ppyz(nGl⪻|f#_& =-%8^&;^83`ܾp.}N=!a9GA\҂(g% ג"]{:_bf#,^]ղ*VtkA}r3{ǵ?r{_8p;^I3efA=>[q1j&:<9(m~D<+\pѯU|=@w}Y>%GVWʃlِNWOlvz~ :f3ӂKm|]2NooM['mv~$eĶxCÿGDAo<\_O:YZDKs{z~k:}^k|>=z.2g>7\8tGN)߾)8BO+F_#_\zR.9c(I3Mc~PԱ7G=|<\ L|b x/4}İ";!x| l[:{yzE?2D+aJf.ׂ~˟wB~,P&;9LޏzgPhB˸ߓ{(ݿ]8H3~]Unf:B{:5%W/]-G;He7񺥥G|w.>Ki͹:?k~f󵺟lorw*Յ>?d^~^Vp}0qhp!'Ry;Z&zϻŤ4d*_/u۲_OW,L'J*a*w'fOߪn?Ŗ}Dqn=<_ߏ3^}~sdwH?!_Zz|bB05Qv`ve97>o=KN@k.Br=cByGuKvm{dYnOϜ'8rt33>W<^ӟ#;,O~.p Y8q~o&1y~}?h6{{5I:]~B~ o7rٷVv¶w>栀>m_z8{`yL9Ss\ qK1~/PYC ek_^~-ۍW`y\eUzGuo'r. ߻enՒG]JY8><쾟s\36Зr~Rc*#'k=Z?_7jUSh?3\ uMﻊv珃_|<=UVF&?]ڡDbm:m?io7WٷKO4q0|\4cM2ϑ9 q[*4%{,0pi^P RfЛW[qn;F{]\Tϣ.NN_}oײ߸k;UN׺Kn%ｮM1[_d׶Ms]mgee<kޫK(sU[$rnnׅ bM^ӧL3 zq܋c_}d(4rM:ZR'n5%ٕu'6:TEGPX{N3x~ߝ_qyx& ,gu2,hMJ(n]nKӶחYP[k_W}Wj} ?;.d|~)^JBRd4hXY!BE"{eDYHkd^իzsy^e5Ǖ'cѥcO}OChZg~I=pNp~O}5K7ynxCpSR\h-hۑ'&.|::e9۪󗓜/T1 < qQV)A^ tzEթ|M!_:-f/jʛu"?W҆a vL6/4N|xK$36 Tk>H:d{{ 6c_o}Z1tbkq[IW9KA{-ڇWe[p}l?jtl۶qSSׯ(a%5/|?]?tF{Jv1Yاk&"J6uv~S1_dph2a4~K"vi,2ߣXp<g*]xԸ]`6)v#l@c s>[HO?tRR\[.\w0Mut~}kT0|OAG¿C~Un4v]u9;ɆAշ4=l4 X@zz5 E9*s.#EFws%ծW ezt/WGrTsaճWx=O.̧ȃ/˷ 6Q$z9#?3 TM DBԏQm}>&1Өn1 x_rʤB\a}Sl%@w{/>y:'}? :bSIykZǦ\T$5{p^M818}߸ x~SǯJyBj*gnFʏ82.+4Ky; (_Y|q}w-d43;_[V˼G|i(_..ѸGy~^!njaIY08_Q(+;u2&(Iu O{=s< WQ[;(Ϫ9cǓG%ս # )p'oՎvԧ+ry`墽#_Ss l<_nIş)[  P]&fR}_iO G 4p4Y7d>0ߦ@:3,onhWq)LKC~Nzlg]q`)>x&nD,ݧa}s['xa_nC94w/8w)fG3>˷CqS_<K_6C`&X UoN}PO|N0=Q-8>Hp))8zէlv/Ӈrôܐo>]X;⤶/:❀QPPy]Z>D@"rUF_{)dπ?m}>\܌9kUC ڟ*8XT52> ^㼴O͓vV{*o>KF/ЌrxdHs^V䉡-h:y5A5V=!pv07`~\د'+cP9%z$ov=ߗ4NA9k:a*uzɻv?>w4y] "qIRwڹdBՒ? >“65 kwoJZ4~Ov8nnTof4Kėr\?ê E=,OөQ/YN/ x'SHI-o =P~}E!9ij'݇@{Hչ^GeHoi/DIi%>$5| 6^=8;burpT#؆mi_t[{q}%l4R}_$M 俣./oýS; Cs7*@, ΃2ڽ݆jxp^eݳJ?)n+8a ,,Ҡ8)*NJVSiMKyf`j C>J93BҔon'#oRS@H#O<;'p.3#Wxj1}| A&ŘGQܒN̷_g#_\FuKSOpp26硸4͡TF&Xh}HR:/Qgªx2/Es!\=W/žO ? -ݟpZymTى@:R;q>oď&x>*,r_|čydAz_0+*1~is1tqM/n9~n<%$m Я_*ڄr.u0;0m?}Q G:ߍ@jm")Ϩ[,wヰ֔e&ϡGC{SwoyhXڧԿ{TRh:?p~"p8v+kS[gzo RBEN#Pn +ۨϡۙ~SrLoh|SL88xbˣ]>A4 ~ud+P?uɼt6!Ǡk3{9`Ux,\URL8'ga"s.%b~P,vS3*~GQp?z}&|)|n(3afG1VvpDUQgmWh7ڽkl x[ڇcxb^ ~{?>Qrc1'&xI& D_|If[Σ~p5F:R2^{L,@7};ߡ/`/9ٟV|r,g~˷'fͧ !hǾ- ~\]L5k\ i qyf~!|mSl?['8PiX~B~~)@P]~cB}O+é[yZ /3"k,Aj/z&^̘g_  ` E~ ƌGg~i,k|W0sIÞtB+eIg|uRw1ŠCd/ʏ]ϝWwmʬu`?lN'l778nyϹG&n c%ڧfmo8͚ c&#~Y.l%~_km2_3'uuU<7TXz@LVsP?dmՃuJ;4m!}3ΊRJ4^T]t-?ʿENҊ?߆Ķ#TklS8㽺%XߑzaGXcMeŇu[1׽y<U傠_5u >G8~P>sΘЯo`u29z\?eJn㼙+N"SyMz-ӹ8WGVǧ*ð6dg `ϳ'=0E\QlrpE>9{Dй^ݧ<6/Ũaf-\9YM(Ug\U`2 _P:MΞ7F#?b XKrLCݤ%݊״_eSAƌϺno#1Ӱe>90n B}Aq_RgAU=WE|gQ/cij{ BcBsOg|'ݻ^ƥu2[a+VB'OKMB?KO27DƈPooS8oEYcocϛ`v eL܎~UV(O~Si莌AOZ'ܙZ;߯P| }7\Y0X^Do\K}#~f/t`5LSii9 Mx\?sXƎGW فc1X@E0# Q} ߀aB;ʋ5&zCuEJ"q5+1񴽱 q~b\e;f^\s+j?"{,tٌzr%Ak^V-Nf"n -[uC IP_Q}Yav pcFCsQ|qyLD{(  F^?'ih^ l,~Aj2+O|qTDZKŌ_jz}hmTOZ9nE]T S8\g1Э[jCA|0lhO>UZvGoi&ʏ=GrCzFWNK&_svc./&Dw:uO]C}zX8ֵP_#~iǁۯ}UCpeOj8~!\Cj_ P}oCIvkúO1WcO5u^~sв&Kh 17ĸG^-:_ZG3_gOp2 _Ɂ]KŖrOuK/{.D{>\? #u>l6 _)63]{JCd!Mg&[[+@=^msjMW` !N9I]Eu˗m#Z_9 G|4åo!w~1kqmO>0 giE?p\O#(u{,?lcH$(\C]ݝac@:Мm Dy,ty?SYK:ZD1Vҩ9,h#j?v @1>ky,S8]R} Z%sGaH!܉$7*Gws͑Eg있/lĸP=Pپ86nY {QOtۜN/ 6>y&5E ?˨ZEȯܛoL=h?*A%yGa{g"= H"ǦkP(Oʹ*YTd걪y8 4nMyl8cy|L`3^A[EGS~+UZ#yneE[cBj92nrBkhWiёϩXGٴv[~}0"]oNv0ѧ[O`6?|O7 ڢbzعRtJC1]a/v^:Q|T)UOWm?WP$+v{\ޓ# y>̗oWWW@{UuL̤{nףq )>)?pfdQo8Is9b p,(?ms:qݶ'C/~0E~{7햙'ks%w??k|v%G3KMMgдGG^?4?q#Q~=K5޽ax6_CUxթvusBoRR[&]-e$>'zuLg-z~nѽ򯨟U~'lZ߮3E\sM!Bo%w{QyeoSTW`d으/^ZW:&ꀛ=Y =_uWeҧE^ δ {?0'!(qB%\ѩ5~YR=y,d>w3q~HHGA3[Ɨẉ3w5+t p=S>F{ndo\ U7d? >=)Q_qQǑ})g~*jPKj{lo71m>/nA=X/\qk^EH{I^yQo~gL,w..a8/TӠ}~ GوK?h;p!Y`-JVڇ&WLO1=]8u_ȟ7Ao~YB}8S+/yG!/=3X WKq|#^KZ 7Ugc|g J@+wRO}&||Ё1p? ?wb >#<Ƒgn? 65aTUҶ[x?Fa^B-|.♼ޫ<qG418+?8 "yqR+ƛuS!|rTr0 #iWWn꯮g={o?xsa#Q~jb8(:18꼎n[ f?z{:W(khw[zU@bBz$wLUH8'?ꢧ?Czo0?U=`vX3&"M}aKg+c;vu5lvF?\ INҬTtyb}6Fqߌt?H1>ldKYI rxn+@@ܕi,~8_C34$mSPܟ W4s,#^u{]TAnO?)o_ijSwqwSFm"lrI~ hZOڽPj-?w7/\_(Q=ӝ/ܮ&1BzǗWEyThgs#Ho D|;c4)ݹ@ؕmݡ} }Ž\ 2\h[w;,:qכoЎp̢w/P O |^@l2KG .([ޡ}.Kw1'wJ3:qNcxU1>^Oyzw'pH:W Qg~ Mwtnx8dտ[^`\"먈n8 (MIt.a s_b\_60bf{pY"+_Zz.^{돍GU\K`q~kO0%U)s`[%7(o4$Qу#lƺzl|8ϮVUʼz/Royn.FrTAԇtH)`/V6ny]#rjV_N8IW րqlGjbA~# 8f*۪Zb&җԷï#է2j{Xڟ"^pPXDQ /5 ,XFYpp=(@vab2=4=ouc>AC.֯'HrF4ƓZwf\kG?R1]]k+Q~Q3w܎dm>$:2i2q*wę_0|>0F>tf ͜m p>ꢜ*vm }8+?G qe[̋J{]$\Rߤ;G^,sգ>BWg;5 qZS>n րt ͘'w3:Y(j{?Kݽ&Y=F\Gq; _%aS2Dwq,:au;ev)ĦQh3c0wMG_a9ꕼ6=zGqyPozKxX-X}ÐO(@\͈C{fgk!['|>3O?ȏ7P.5A)^ ٨Wi5o٤=aeeڏv~k}\v!~^ֺtVs7#âwjQ,_F~0lPLg Q8v;M?̳p_zk<)/d9xH6H:\=LQcύCvm.~A]7iZCcRϾNd_3.j݉[=V~2nmF qo9L#xo훨3jA )z gݏ!3 䳲G'-Ў &%eY]S~M&3Mw) QGeAPygr`uu3yޖn8~ujcwdWRL\oM Eq+]*y AP?np>EOEFU"Wj=1? q@>|_̣hkV A)|D}<_H9ǣZYm'=\q<҄:i_Q]5ix><ڻg{Άn/C=0{)iaJ\?Ut/)S} =ՃD|罋cW6Bzg^3/60d'9;)ȶ lw}}끈k'-6E^Bn>Gr1Fك98>#0~O"TTo{S(H.dK>~WB^C¾5svk~ /t˿6Jv=\Yhj?Oh޼_BkmR_oNOP+A9~@?;?[w=b|*<=R|Q8nY[WgC;K`tB*2sv7 4`]E} 5BnbԩC*v0K'V}95]+hW0huW6!N*NTMGe/>I$hL#%; nR9o}ʐYoI6o^w3:J~{41D{ Nd{cA;A8knW8?>GD軦+ʿ^T绯eҾ8%%z\?iqkFM~ߨ~i ͓#sP5Solu)C Oǩr Owh^u6Z"j/ݑm)y){L1'Lr3HODv5Ms o=ſ{&gې}~EWOffz9c8CжFFA$a" k!KH-SB.G.;^&앋׮.cX57 ymO*7Ѧ{\>M]PDut>G7!']skYl'#m?8 4uh׊;.]v`]k8SoAy7QE`Aa2A@Uo^ ﮓ"^Fuʝ./` RNbYK< ɚӈoŒ-1W=?=Ӈ^$Sz ߧaY ԷyY;׻8^bןiĸH2_C߈aq3}+G"|YRqo/ƴk?"\z;gڐ s#chr3pL?Y1poi#,pީ7ۦ=Aq\W XM HgSњ7;WNpܸ&UѓC_sQNSP؂Bq-迠9n.I xJeYIoҋvř%Пʡ{$mg?x#~N!ԕ[k[w[x0-w)pB (e6嵙~%Q\Ex .fHwa ْ}A2Fs;\>I5zUBL21u0:'kyT;:I5Z3p.JEoyx{IwppON^z6n M&FS3 {.?%uFT5ŏQ̪vG?;0߆M֢{jG_[笟n.LOb*=`xg۰܍}~Չk Jp/Of:mto:? _fEv]/'=Y!_:8`5pխIZ١ ^5cb\&|b_dPvhmh ]nxQs]P!|Z8iI{XnL BR\OI56.Z食'gQ0"<U"2C [}gzё{lK#XT;L8nA|ʣ̛U[__X:Ŧ.-g Ii5/ L)/`Cs/Ӽ'A:W6.=_kz]yt+~8Cz$-EUƩXt_2E_]S]~>'%w?C+/A ֦#W@<(l Ov{&0>='נJ&żK}艇뺁wq,y& ݾ=GrJL!ZۆQ|3oT^[58yt9o#) u#R$ >fHPݜi ݳ d9ڍ^jIWMc > /sE]#cJpU Q9=&8pH贤{֋<_6|F{YˮY ˗w78l?~^C?֘СHR)=·yuԯΜ ]Sקk[ܷrf-.^-M04yyQS<*AypF{Wdȓ! 8gLCoȳoo56$5ۈsp3b~d&Qo䓶BSXd.{Fp4-g_ځzt?}7]h)ϥvՙGϱ$[ηS,> `??inIYyS=߼P\nh26Vݭc2] CZQ\G̀u*?c z11?tY`7!]Sش.{; D^Y _ ,?e8?j?}r.E@u&F_p{xǓ)"ԖrF 5W)/'\As!28Ba(vQdNpVџнru?<ݿΦMz;R\H97j"؝5dck3(Ofl#\u)DgUFOALp%`b  OQ<_ۺ\vQJ<硼4zۃ/EtnNӨq[EQ_R3noǁCO39?NVK}Wݽ-=:7@w-Wse=$<*m ;T=(x -SAgFv} bA_珿),wyBM0B q!aLӊ,:͐AZCKz-rq⃻7 ͒1Ou0`Gڷz9ϯ+nrʖ\|ő~;FD{tz>Pks ޼8l G[sZ >7](_w!>hNY<#_~$)yÝgTKoU=S5ڬ?  1sQ0֯~8s2m3n  J?y|<s_:9qSwt0>GN}W_vcӿCURئ'YdMm~=6DznsYqXWÐ<~FXӼ6_KmO4fwJQuVnyn7KӃtƋX`YaU욊v5I eeu;fG툗=0( ?Q?/֭sW:{G.~XڀrRjO>ʢrb8]隩 %9?*Ę"™u6G6|<ȼ\NMI3vZ Ҽ·_@}=}fZ(-EPa F4 XT.3;b~⁋ts5`vޥF?< սz>p=|_~[ƳrOveMojpOcAU9O1~t=գ8?Eaxm.O|-R9 -hf>|tU_] W[z]R?'WV~욋~P?5}nANkm[Z \Kzߧ2` 6rKFdt.aSS]<|5{%[!xxyxM^2վ 3<*dPgpZ9[[g6Gv?y-7\cL7(,\Po/Dž/zq;le(/si. zhǚz#՞q>D/|8zWQyɍ'WozgTX> +9Q nrYÆO<4kf(?k[gGWFtAӧA/93a`[B,~\;P诽]SdNèfP_^'-Mimz㵦ʛq~>}Cg+>]wLeZk\^~Sg}TL \ϓ P c̭`3tP}cQ|j:n x DQtˊ?8(a)ڗQpkC@_rⲖxV8\gQB>^8%7"P[KoZ3|ڂtdP}a?lWٹcO]Fn /( FKh$ސ4?=3UGO/ggaMs9w|g"/{ӴE$Eەmvy])(nw.4_=:Ni h_}m^PWru3 b:vt'|&>8/N6z k~oi@-_ m8^÷=cl! $qPTl{z'^Vݷ&LrQKiҋO9\ϰ~veG`b˼),}OO˷ Շ#`Bd`m}/ڧ^3?ުJCꇗx~;|8|6uQS'6I큛c4$"F5Z!%Oۈgۖ^inxM>*ʂ']~=38?|@%_Ttl(8um8;tq@Q!HN*doO1]v9~ݖpmۯ}=H7ǚ "n0 Q^rg?Wl%TAW>Nи~'6q|*N:3b C7l&τfhη moy Y>!pb_gNf{Ks28ř%@+ɶ~&& => ZMҵAjq-'~/kkQ[rc%&Ӻcy-ݻv3+u+&t)֟s{xQ:9uιr*8 ?ƯδKᠫRd ڷ2SFnݵueq7Ϗp| fD1:ݺ&5/bֵ#\n\;J^k$: ,άz _#>oCrjp:A?zV~ԩ;~D?`5Tm(7Ao9= gڃz~lzGl:63~lrҾq˕^Uޮ<j҅~w/>0 >p#p7l ݋UK>}&j]As)gg-Usy'2<P)ꛓE:x8@H~c\_mii:AK>}^[y^_4}kQvoq;y HuՂal-T/ UQ{vǢ|y 6?nsPtʝx\G~zݥ ?gP~{1_mSSrUl6|]ڿ7s$ꇡƛ֌fA:ه*w|/k=&T'bv$oc"8}C?k zpLGgj-03u 1~)~pJRƃ:JJ =O!oݬgG58>}qȣ49?v^ 3w__X1/ޮfj&Llsf"VUfyQƎg}o5M#{ԂQ}NY|E^()?rQ][kGn1Q_RmN)cWjyH%M-/5q ZhY,=XUp0kwⵄ ܒ|}aQ|nC \geg-UP5aQSпpݎhq{n VoVgtcO%YgS0蚝GpnF3rGLpإ>Ӵƃ列ig| ]/'>;gq+QcFĝ,E9lA7^({Gm ӏoY#oy]Xғu+♈;:JMFJٛҍT mOĵ%ɭ/xG,(OQk/FB(N3d!Oߝ+B%L*ևنrM_e{Pt ۥk_g<p/qDNSqUssS tj?uC'"ذ;:i$L~}^z6K7EZoSᴿ"hc1IUf+?2[_hZ?tҒoנMs)zmm8ƑIqA3/:yѸʪ9/y}[Џqpnm13 ]^E;}u2ĭOc{[-$ ^G9(/h0ϩ-}:$X#_]rqpWD)S9c( caX#ub߱2q ~HL\Au ZlF};`A{A7ݣPN]DLJ}"e-1G2Rt~KD?]+/*]+.a\7]̫9Ar,@wQgXp=7R'vig|`88rOz#_ca:뻹RC}1`_ΜIO-iQ3N}l|s]+>gJ߯ ѥ1?)fWtWK =D?={4M!*Oq;n}drَ`_ywN-TW{? nBJ8=f0F^Yvo~ܸevFܾ9 ~_u@Dus]omSOV?)-r+ ]'.=ݯHA5`|қKOg$jʗ;x9WtYX+y6 ΌG~c<"Xu݀gDX12.>ƒ/<\CE~x:6eb>}zuoUӰ?ߝ=8<<)'>E}N ۣs>M}6o]e WruFmkpw]|Oy^÷CO`#Cq95h7[f5 Inپ d8A?Eu&P<ؿu >'^Ow<-ЎSYߢj_IP:K4Xp;ޟ*\-C[r; {ǿW!Gr|l ^)_[#81>B^V7t~D_Lm-{CoS3bU6 ~z69ˡ!75#9 yao@?*[ +cQoCr<|sxu]Dq[u ~8sĤl_E(Mq'SMҗ+:ROqű8_hO>cbo ۆS[p~`R_ !|r8sJ<'țg~kؚy ])>Q\Nw"/EqshjSt^n )|QgGv#ڗ z`+Qס'NX軑/2Iӊc(NQ>Y8ѵts>:Xش~sr<=G:g?o )wmn$ 8OE+Q5AKZcB%BUV@\< n/q}}/ftwHwqf]ɿE߹0#$ʼn:G8?k# 5+}l']x Uʽ?W hU.9+iqGKaȇ%ytcc~N7>E7T[k]'7/x#ʷ2g['5U \_]mLKeI(wiVtǺ31y֨kqƑn'L\O,%⺞wIu*n.ʿr=B}-=|9㧡 (ɷ~F[af@cnv27;tAhnE{@|8/ChCI GS;U{7D9j$sRUh0a'?57!MaYY td7ffOMggZ .ͫo|!ю Wl{R}9T D~o[56iv/"^ɎOt ZxSNqY~ #.r |~C{D;d8ƅ_m 8Or6忏zf}p j0nUٕ8A߸xê[Vx'þg!+3O4\`[OrAWy71&l'F~3ӽCTyǼaaF= {ZϷ~v_bMu} ڙ<$joEB_K,fc{#+OH?| vWh7Mהw)c1#Q+9=:k8Uxp݈uG}Բg]~XmE&={hƮ`]wJqWPv Yo GO[6~>mr ozLy=^7CƇ홸X;"?ptpP~:PJu\lx(4*{ĩ 1W_u /ˍ)^:CCq/gMyw{v. q|`K }~x<5(?]_WJGUͦq]H+oR L3.0o0BX0?"nH>|FC>膹\ i YQ;&o0޹8x DA;iS'ÓXI3K9'զm_pxqpIK~M(<~?pvJ"~][Vխ>y͸A. \;wL1MTJS]V (nt>Z7 ;ERn[Sn{Hl<3ߡw9j`eR~ 5x|(OECq~`0(lsO{Apnk_+ϩLMqTAgR?++i?^Gte{F@?'ύQCn{KrLaz2ȬeotubCs4(@5B3܄uX8; G։;}O:1=?fQ$I}C5K K-E=(MC7&>ՂP~6nOQu۷[=Gy:'}Jlºp/z: ġ^$7uzp{fpL 3j=@:rkyv"O]%{Ge7u@=THԻl.~ݱ; 8?U}T?1}+i?̈#0Q567 ~KK>id?^7˩Mhp/)ݷ!?P_^`Ic@(#qm=}0Ӕ?E ">x|r(WH7M}y>e \g5tNZB1@_{R yQqt-{h\QRέυ`U4CLG^kHg{-F\<tw2K79{?d񇨂Tτژ UK2f!)'uap|{͟s5՟wص.+)&̻xˏoʖ!lu78o7sWRA$Ln?yNZЎ ӦPjIԑ-VY$?z\}D=f bҿ)hYO]{ w E^\X+ QuI|OU/} G,ڟ~;3=QoX[#ST9޽D螀l 9(YMZhpu%qT-c2ڇg~:*3I!Lz&k* kBl;y}At;bx􋷼|&Aym^Nɨ?:^ŝ_A_' [4`#zJ(6o`w [Q}f~vj/xq>/w<`87d 7-Bv]֗^ Z,!~Pof;kgߡ-ahGlySlb_M$?7s!a :j ڇ=ҤL[yW" =a|_dEop{}i ީoã!XV_><3zpsOnʻa}+"mr@w}y'z؍dS#VtI~ۜHoNNS-7{juFy_`?*w6_ )--vFK;-CPC3~#h6AMYy??oX|E`t3ǽs}yBV /,I%{3gs#m'@k޼8 F]ķ."!ql qgR yC&☡oCxiRNun7C`LaLe\E Pn<4p[>@w Sj #]g+98[il1pnmPpviOcime&x~O7Q\c$%k}3m8~~/X 5[8$=~?~N cVďh5.M(ONz5d*Ev ~ rП6@6pkRzHźUEYVu˾nW]2ffKy)wek+5~6Z3@M!^f.ep [NsnEwk͋nOO$+䇺GO{T3k{ ?==`TL7Oa\nPtfsu 8v-o`CP7?Cmy x<g  v|O^ IBuχ?x"Ʀ1H {?KFO =·8<#$FE7ˣ'b&,aV;mϕ<܁p7>ae V`̩YZ&'ܭUosyv7%h(}1Dg}~|jƑ٧׸ 4dK0NiVZoNxֈUQuL sl3ۧ_yu5%=E$ZSen>$6YhÞYg,&?yj(07 '~3ڇ閎tТ!CO7G;(~7Zls =PGU5r}-X7ߎg|Jc}zt)8҄?Яy|TkPl 1U _R~`j3Nu_$T;܉dņ$\oް?k7YXx*VVy=nC=3l)ވv FVIc(RkՕWѶ_ț7Pmyp={/ި_EGE-d5X_+ӑ'_m98ML}-*joh+6ӫwP$Ko+ƼN fضb;U+G)dA{4jgEz>_}Q;SI=j@˖)P}o8iO夯?ܞzʸ:=j}$cxڧ[ խ3@TlQ:uӢDR֍T0U\':X;O} BSUEW0Pc/?V'ĸEŰd{jAwX!:in3= WA6M /qVra^C+sȼ'kOSs9dN>J`P]k[9=**΄gĻ ~an =(7M_~h4mB<doD+a~g1$d7wa1kXS+gy8oЇ0obgF#~'Љ+#۠% ViH?r\Fu #M4cmqS\lΗfd%z  <*_,7k*95ir~VQ_K7mӷ't+WϚP.3VƁv'q^1 Qy1ZAxi]w(<__DyGL^x=Gn l/E LH%^%|zFGޫt)n>wGb}Ep vwPm#*?`益 ٫7 q{y&sfd:#J R|繙d}cSϲo>ٻ+ح ڷS(S֨ge|~ƙә?7,߶A#Qǘ2q}աh2+nn#'Iw4>$〟>"H}sT./v\oK.vXs#c}9/gn N_!wj1GST s;z<8VD{]fD}~V+BE^F?`Mpl Q~lpI:梞{{OUpcy4dT(4kO;q^Y8R~A8 uή"|Fs};k4.{f:܇&Epn0VVq+xW6$޻xs.76zIٟ? ugub[W_%|a׷ğj4<һP&LWp,&6-!{˻xE{Q-/*n'8cV I}-3gZi, U}O޲iwLVy@,_. -Qg!bw);n$uym #Ww] Db\6qMbIP?xz}M T=y/qڋpͣO_P,@UQtYWpx+0H:@?#gs)3 אykPNcpתsT_r<ot?%Y -*FL;W[ͯ+m;VӺ(}1l|$|3Xan%jPs k'du8Ə?HlR直ONQ@ Do{_}xqm:|s|Bq]E(;>&) Z_R"w=TPz9e$H p]d!k0>P|qqٵ;rcqCo|uJ/n4r&^ &wzMm@E}S 2;UcnGܧ1[1t_)골WY31) ϭύ;8xY@ڿc=^`&!I1ԏHǏYڏ|+?=нS\\#NiH`FD1BqȜFy9aЭV̟ ÿpߙX&ЃKPJKfv6At~h?3it =pu$̍n]~^.7C3H]=Cz=;CCcSsfF'/;5tivu3Zq/}BM?gJU+D8w]=8jKt5)&rQXo\uĉu0cx ;g]$j=_ ~)n%gP?šsG (tf+b_]R˯xfD. /W@!K&]+Y[6\Ӓv!\~v ?.r)0ߡ緿u#ѧ*џ{I>DrA?O٫3cNV:0PcLz3///x΋4:kOqXưql\ QCxfYs3{BsfK^8uN 8O]H]zdxو?>Ƕ vhW=tνp#͎8MÿKؤb\{c˧)0p n_cmE{>Rp[W~a|`>=ffX֥OVo)Of1O2'w-}~B/~bܟ?{jO"8L5oI_nU|9#v6D5ur9'6iDw/4O'wAsgAۏ?ufIE`Y 8GM+ei:w3Wս_hp;OeC]5M(/żc o~ /D,v6=Oi8>i78>@~ρ{2f4{=lTn{?ˑ5 ';}$Գ:4E0R{͹p$u `̱xǽIO_4v]h2*Og9Itn-0hI>s6[k_PcN.N<H5W#'X^ 73Nvu3ǀr Οwl7z x=WwZ#TxYmy\?T#pckPǢiL߫˒T}Ųoӈ`Jv>l]˒M;9;/NMdMSn ؽB^rW->[ҽ]U9^ G 噋,/۶Ϲ#uUbȩu+37׃I󂊣!Nm?[V+|2z>/_U~Ngmxki|>Kfo={h:<oK:G0TѸ7B[ m?8ܽ _[p]0z=pt7=fMURo]WXHi+یf߲wWx[Y&HU7%{.09+@N.NͳnfԶkϷ ʍMW^>s0wdй$Ht, '~ sn4MVoX6֖ωC\ԹέLb+7ԁ~7 ieUoH{%8~Gq4 W\D>ߙ` 5sS151±$!:ǡ}m?g5hGOȉz|D >\J3哧_4cԟ{-5Ӫ3s9-W<)8?u ׶ق)u8*(1xch}G`fI7\tƁn̥spV Q5&{ bEs kh|eWI2v][u'c뭘D}/ϧɛ7o"$.\YE#8ng.'ƏǤ w!^ޯ ̶ T2a-rb~ eMkNO4m>G[~?~a8AyPu߈ր/=eQ^wՙ?POgQߺ0q[<aG8L-{ۄ(Gk{)~dGW&z8t*okr߼#l=6?7~r D;Pު̮co};H'+)~z.?7Oc˳P>^,sje>0|z'|Ju3a}I+q9xzꏡǺ~Qg ܫRp}5!_~F靻Z{4f W#75dhX}I򰃈O>w_̮@{԰{kPy~Sحe|-{שY US4ޭpcaW;{ @7!Em0?`2sj#yN:M';bv)І^VR~fK`?n5щn[M]7y`v^17hn|>l`d}SGSmـ3A$8 tcw?RwcJRb< c wTτ-_!<\F? ^IbG7~/(f*gz}ꆑ_AT 0Ҷ9D^+O^f 緫C{<[^ `e}  QnwMFy l]mi`AޖmiYĔ G0|"~QoY{^8;F%p@S&,ٜ'i:#^}yR7>{z\/k?\cޝ1\^؟@Ny}Q.Ie@ӊ{?,2+Hu[]Yį}{K qӆYʁHC hXy msUcOnغڟq E~Nݗ hj;z'HaC|t(P}>iԕ7y;q^'tGA(b&N{ZrV^:E؝?v.VER_Ǹ=i;#ށCuLῸ憎ZI8.Կ??mȹ։8fY7"8 گNgݶa5S*ƗeNN6_1>{^-%Q/-o:!p /g`@j0s:OP\$ް`8<H {~ v .{#/z 3h{Xc<ˏHu\jWI,CIf: } Q|ߪ[m}-H&|Ek;.? 1޷n?s^3BVܡk|-<q0b"￨AxEф;}KiE?\217ڏt[Ԍi‡Ғv$k_sG%KvY'Fw/aOۮq% 4%W(|c_7pO}!8o[kgk{Uy#(~!% lW o"^\7חsfy`6_oƗډK' #=Ec ~Y_5MBo/j ) _}&,8?$CWP¦a fq.m=«7$㺈'.BRRI} _L.eJ^ X-|soJUߋ_&Lm N9Ϧ+ڗjżV'37ͧbf;,A|U=}Af b[Џ|))~?yjt!wǫ£[ޡ<أգR>p&=r pDi(#3>nJRi Kjn晎}8_ps՟0>Ӷ=$\5;ߥi0.؄Yd#NLGSpM4|v%{cͰI{Fgط16ށ !Gih_]] dy#lk%-y9 Oʹ3p?\\<?Tj&kpЈV "V~- h5E'){MOyOtg9? djBE. 괻oO*_g W㫛a.LߊR+p&2K>!?r|ð-bl|`_ la}t6m;p PI}KR/j(a ˫b~ hhڿFu nlop{ \sҌ}G=7ʇWE?d!~G<;0ttBPߡ(?l{Urح]ϾE iE^^kųcQKv ´}U w|;6of h-VW95bo'7N\.1?pTO ׅFb(?ulj;_tvFr~j1$Sc:M\%hk7UONȃ{Zǘ@9K6,_s:(lzHuXϕNF}A?!k\hP(p;]J'Ϭѡt~CK:[D c1zl5.`PxṂ|>RR~4){ 80:8 c,

C@?ޏii6F8Ts@207?8\A\vX 쏾cXMy>t=?шV@P*phZ˩y\ᨗul7|!t U C>I˽[ŸjؚVAݞ7Ehg" hK*quaix:]ېţ8FXþw ~Z6rive Cao|y[~ 'R}ZaI_Wym >  ]&tcF_I8`Eløwlo$2 :1OݯSl|`ŷ"1ځAY qp{r[h.~K&T~B=Uo9nA܋ϻ؋ud;!ֹdH^<SCѥMN׏Е}M%h0lkMQ7Ź)ǧ.:ג iZ$!|+h_xs5/yM;:_Q5$Ɓ:ϫ2q9U>>M@$ ꕓ,\.!.9ԙO;Tmy+.f*u z \ۨ~=3ݹT]YX\{q뛈 qMelI xڻ[^O'm g q[Χ^7a%L mp\]~^#2h oSߋzT:Y .гyhw)7O.D|VV`^z7n:7bEhv&G_l{6Ykog⥶pNߎx#~ԝl]>,/| }7էW|1U 55>x9!l#&xNJaYzОK۲'(_H8N}a9⿪W:y*׼4~{(VxHo.K?ц8/_3{)K^hj}8~xLƮEuIڇw:S{MxHy757D3ug*$YB.r.xۻ'mkHu G[F:h+%X WeCBPJy7<Ë]'5ڧ7'zAxpC[>s!NHYq8(G?0N|c1o^ٛA}M̠{#Oz<ߗ{l?tqsh g>r;S!Ż!_;oUqcꗮ]BtcKng "~rP{f`Wo{ >oVPNǦW?hhڟ(yd[h]+`Yvjb37'@û`Ǽ#:Cgռʐ~8^>tάnb맴4>F:vh,HF^wZ҇3cj2w QX]'P~8ʃ<>//3/ψ6WM2޸e /cc^OuC{p+uGM/u޹/e6IAq|~Y|69־A[RЋUfyS  zv"ڿ΄@\'m?VӀAOxvxsA|ԆXYփJ,[{i5)I"޶F^ rGU7kZv5x w/u&яn>q#g7(q*L3'4>{Q0סV/ t[K=W?tu@|ݵvL$[]J{I}h"VT<<ؕ}eh9 eWO3lx*p_}'~wF9qп 6P_'[nCɨ?ڠNc[SkOψu΂3Fz[zpKk a2:w\%޹(G$jx\v<^K=B|K9u`_ɐZ um"K[?8?7Xnu.Qhe걲%\_^ XqD >=Vi" 7>6ަ~̸FQKŇǼوja}iA٪˗_7u>K%Skn5TNlahC1Yol5x8n Z^Nыqu)!,z~u.y/}pU8&P_d=UGE}L7[0B^*x9s/b7C\QF]ܖ׾%>TA\5Uĥ>v^~2YQ?4~ºGg: ctNj sk]\Ajg| [?魜$zj܈)`W:ӄreT^Cx1 p;r+3N>ۡ}j'ue .1~Q cןqsݰ7G4q^ɶvvqLM.4gȏuyWbːjxObD#QS(o_'K5+RpR Ktނ[m`/]; oiDے5z . [ ǹ^1 xfX?D|/ތG?opJlT_*Ö _PW*} _j;\q^L!_OwvQ~N _sVȏUuk?_ۓfsG#.njYGq:CKzݔW.;SQ۱E'cTr{ NPDxyN@XmIQQf.OlI(_2ۧȫU*P5K]a ۖGHbm,_ +-7=n-< m/!?qB0F{W_ܽE?Awu(CWۧE xLj9-ZuXS*u@('L^.;@q\p݈t_s>8ky+87W@\shp#oH鶲 >Xߗإ{QխV?M+o "^H&SQop̜9~ 8J7,NV%F ,z+˷4aZ5=g3"Op4ڱ!;'5^ؗ vqN^{ %k' ?v효~w@Ւ .wF\UW!~$i"^X78+i!C8#z[ʁrWlmMy Lo4qYx?|p,g6 <|X:F9Ś_VwZ /c:ӭA;}v  >ӕ:hF_P~jɻ-?|{gQ/yP_.zK" =ƣW~":ύrl6]Zpyר߆ oB25!hag'.f~nwJ#^Jʓk=siJvlӼ7x T'[NWgnjqy3G\b=,{{rˡȍ#f|"?+8o=ut%sARScm:]c֟}Gg(/׵.I3n}-Vsp}omD4O}ٗ>| f~c|S u:㸄lq ޘqS`{/=R1] wU(v0$wG?g9tp N3[' Dy[[SiߥW]AWH?χ~D/doK2 %1>56k ǣ^9'Yо5Z+}|?\ĻԣrN=!)ʭvitT嘊qv΍I(oYn ~iˆGgFrpv,;QN# ADXܺ<^JYA+T H:d 0=%CUhSlnd"]܎->ҿ rI: ! [zyݯ2P#GJ"}Xl_ 8/fyq+%λA?͙G3nk  ǝO&9IОLGyI ,فAq͑NхdãQ>~AhsedǢ$:yutYԿ||1&\_X rֆg$ˋLS΁pO#))_k}wmz.Z-9K ǯtZa}Չ(?]iϫ+ ؽG3 Vti5g*{dH=]~"C7`YKq)d.O|[>Nkۥ_(#_l!wnP/hc7ٷZl .i?z^@$?6 \ uPO7/u@ZOe9kێ5;į>!N?>-%PoO kBGSOK ;dk7%[Ѣ]w3vqtޭ%A^Xn@3PdkObpV?:,&8SюQN_9F:Gg4W;_feߒ|O~c]nDqHO ?}M pw.D~'tw<ld-~5W¥u ɷDտ{>{xUzpB ? j {izSv-_dZqf1o%I?wcԂOX ]|$ Q|[ *qh\gNr7 q ^(}XyQkAB_OFPric\޹?+bo#ڈu@DT>F{7U7]?{y?2oZ6ЀrJf^ )%d8-2[˦azCSw938lxԙ%/[сj+׾ t&v'8n8LS\t>4ju{B[ipvɡƭ8/! ןݟQ~Q}#5=^~s5˧=\hy{u$|~rlH wG)=9_jw⒕T>?apG1خ<qNit ('ym斿 -D{^1F"P?NW{^ޔwet͈(GlV?AlWVұd0Cq]8 g\gic}_>v&?v6Chf>_0{/Xn^ 8/t{ vwˊbcz3V!T|~ֵdquYr0Q-WУvb%;>t~' 9=b^b~@J텿ko}z8o;H}^q[')~,crOpqB|`=V#yLk*@",s͠YjFZT_<eZ!D4 /A;&uՈoO&" 0[>+8n6esBzp3{JGr[uI9\.]=!> _yD+_b/lh >.1?T98>oǡ=.W>CҎP` J:?ޘ?VX ܁cXqIPX AG>]6OPC@n˓Ѿq3OQ;c3qœߌآB2q9؟G|gLAIH>xd7r 7?8h-+E:-يv2bUpnp0F /pY PG9ݰ梬X\7."I@ugoѦeQp\1SסGn^:/_ŏȏ|}B\OވQ8N jݻ:,g{PO+`-i ƕJvo) ""-G" ;QcU/i3e-su[w (?em; mJ5 FP~Whwt7Cդ9m^v~ ވ^Qr)_P5yHWw,O.xgGĖ2fe~^G9#\pgBOKO/ %Vm\"^ɞZBT9E!U?[=utٶpG?a79tt9>`J9K@9 bt)Go)yՆ⿾p?7խ[п (/eɭdȽC ~y"ט!הsR|ї2Q5$ _'Fyv7I6= {6|@ngMx*;5ß"vݽx쯨*Њi`Zؤa+)_z?ރݯt="dZ߂g@NrU:?Q|-n p)'~U;_&'M)[н@n^7cph忨UǘϏ/Q^ѯ #Xs>=O`{N&1#^uΟy%tP l{>]T_ ->qqzsKo]=Nexpg S4  qܞ/v8X_!Y ʛJW\WM<7?Ht IhjlkF{5^kLj7;%ПJ㶡SW'ܶ;=,u}p~Wu($+5?w8ﷹ<9(Za4Lk$ +yQiވ)y .N8`v9p>H)-y?+}? o8T|S} 6_A;׀w;0?? zF]U>5S`{M9T% S|4٧ax8e޳fHiaė-j*@/nAz/KQ\3^BUW^Cd۬~ ' vq\zr;BPw5V톀vm)~Osif@1y~ }QQ7LV;OiQr6K0jQ.@p[o3W/>- ~FkX'Ec(?:d6muwE=ԥgG|6=dAx݆+-#{Z&-aGUd"9B0tAf)OK\о 9eq~F>DV cNn|C536t.R'c|0-=`,:x Qc@G}| $,{xM|A:;Z}2PܡN'kX| _udJ#akۛii2]ɰ ^,QN/5]͇}U3Ջ~ ,w.ꓡC ~ xif]6t?V% pqZ1iڙfi!Es$^_ NZ=:dS\HG3X7;/* _2aYy%o[+!hUk~;G ;6_eJM]xG\aw/]|BR_Gy~ʯq,'nJ?XE}.[yil!GQbֲm*:C2xB=*Pp>ɏ{5ڻ4jgSն"c>KF{ :}[ԕ9?i}Z#9;F}R^@4h,#i~ E;3Yik?m4Y-Ŵ>4Aɕ_Ã/vQs1oC7oqܟ5?=Yc.=!P .߂0/XsqLSp% (_T7:pnϷ"n/xʯY*{)2) ?pp{@XRP<@7a߷ &+TwCzM@? oʡ(aۄYk@WϧnEڗ%Zۧǂ?8~w~bܥۏW=l2O}P Fn An}'i-Ŗ:Ž-w4Ƹ4};2eMidޥT7SN4AvLOdF8÷{Ù+Fx_hෝqV8/^13" u[rjsp]UwFxN=Է|_sϺo+Ì(']j$q` 8~@Z~QTݺsgh_`̟tZ76)8/VvbO]jNh`k|m {Xz3=|owR^PpNOvufCU`t)ƝK{gwq_>})7~Q=P޼Owuyguus[Y:▴+Wu*Z'whqTg|?"io(6ѯsc^ )w} y*gmx ;x ֵ<%Is-!me pYʝ-pf7̳Vz\ ,}4&"\]B"$~8Rfs-$~#mwk,؏W 2Uȟf=6(-Ku[_7$zplx\7WE͠>8qj/pnR}"_ṕhL:w@SkOqt߽mK ׼Dq ^UJƹa[%UJB>X(o}~B|PN :ivXp9'iX6|O! 34% ס(et}g @x!=r հWoȿOD`GU@GSj L7q,A|r ^8LyQ+e NͽJ>+7bQ5~.i ~>vdh=iG]H\?FΙRWh8?2~K^^ɫ+{QӢ8ni6~+Y>-ěQ8>oçq65n[!,g-D"ߡ{.1O!oq^14 :^Đvs3O]w9}è6}jQ:U99c^z=h[*g+L俪#`/^ԝf9 G5q] _nVqVHO_&SvSנ,,{7Ugs~b 7;;eA*c H;?)3׫M| U^Wo"h$isjA2-[^:ŴMۘKZnYp >~5Qcd'y :ď(/#{a\spD>ie=A/s,{`kwr _Auބ/2Yh߆Z Pve p+wA-(SRsUkʞ~n(ZڀQΟ@yV-h9m]|k_uhAyq}X+W~| ǫ6vzK`̺+D]`ق-ns e,px6\wo˱2M7%3|c}i]_#WA~{":`)pHR"NOMF~ov|<=_KoG>(@<' QOˆa;AmD[Q8ϕm>uT̫.30m0//'=A=Qu龝ښ_[|q]~P:Ǟ8`>|!Qa75Ef4WQgn%-hO<qlh*=ad`M8`@|zɨVëj/j'{_}?ZW񑽨9N׃T3a7ـ/F!0i׿#xX[ro ydo~#HցjʏK}^]Iϧd|;ׄ/sg]v{ ,Bh}ee^Afu:/g4I%(Aim2AР~{'k'tC? =nom1 X|߯ڥ]0ۑanG|?,"OFY ݿl Zwu|=!I-MqX %ʎx>,5wj'n*u=!Qԡ)p}ί~}D猫f?C9k-79#q_yٗQV<8Uc"A}X9/V8s ڂo'odj W8`12~Td*'w U<{Hx(K-IÕM#}&kW ߷f>wɦNAUVԿ}+X墑v<܎ȯ6/jp76PC_7棯˟-sW#?h'* \_3h'_;mB3:{hgL ޗl|p^ onJz{AH{^6Eҹc? 0O`Kϰ=H|=2U11S_AOoy+<=QWi6d(.z'/Wwp@{1N; >Va>Drh4؀ ]v |>⋗Oi _ca* |>GM8+2m7',|֞iW `i_t@@_b?vU~ F C7ĬY'x3,h'AS!_nYRtG'un>iR{qkPhφ ՕMd| ?*`.;4OA0-]Ջc5|oۍ)U vc`X<-4K_%N\Fi٠ IOU~~mΕ-`zڵsk?kJy S{~Q}KrtM8e˯gq:$FD= x)Ww:)ysWcu_|uW~2Bmx/)퓈mӁu?et{ ǭO뤯١ſ.\xD1ݹ nO%?.ov{M-ia\?wHvx1>3?-.F?1/z պD׭O鍹=fv]?ʟ< elb4p.0˛&q+׏A9fEԟՅ7о JrlH9 S./[;?%3WCg/kǢ?"~s?rztD3 ~1;6>].=ֲinb|+i0fjCFՌ]=H?g}.p]eJ) Smܞ9U̍C_#nqO^ekZ:?XCHWoΛ/d.0Q/Z`vixmC =(sO]~7՟qTw><|܃&\ukn#N~ty}Ks37xoŲ(6˞l+qV)wW3oE0?ɾ{Ҿm1|M}qgf1?q(êaB^Y!ξwT_i;m'ppr %/ێ3[JKh5Q 10e2Շ93kx8np^I@,G4Q~pf_g!!=4'zT[-o AY(Getv"[,m/P~:\7Uc(Oyw8%6yVsՑu!]o|Ve/ |p X}sބ9؟xzrp${yV?>+S*Ӓ@ܑ[ڣG˟#O4.M,.GnęF,=5=x Ny8ѿVW$IϹo[Kݘ^ݜoFb^c|+kW%&B,sϺL(IDhӴT9k_X{aFLg:cApYY\mЊ)g1Epv!њ8NOR10UEpý>=K/fSə qulcV:']|0MAs( &GNY@uV}$G{ț'ߌqlc> In>ݯQ h{WT^q^ڟaЖ!R>8s O=eׇbJwKu`PTqlUգzAm?bP?Ҿiw=/bt7S-~VMk;R]BU}qYyk?KCٓ{h=Oػ/QtqSJ^x8H[3yf"O vkԣ(~/F2%KUM>xR[/XsGF]ѣk|f * pOV2l#G`w t%*I4nm{8{a#ގ"e4MiߨLEm Gw^z<~=ut8AR|T^iFhpuIjF~@qt_zW_| ַWy!/ c6ڟ,zR\s2ژ)遼s@q {~+wثYbp8ʍ͵)iʓx~~.gː{zI{=M~\C@UI1$;q_ _%}UbO.а*Ew{ՒNU@/ۿ>jr \{(*F?P ٢үOPxD-|f# phz pi~[eÙ*9XkQy#;uW\G7=#H'KӖF3%]-|(ڽ>3Ҿ:|Y] ~84Qu_2WG> se_ q7iަ 3zY-꟠*5yih?>YԳ=~GF;Toۇ7/`II[Hĸj$տC0bزIWk1%>D;V ާ}|^]> ĿObKufw_kM?*CNOq\vOG1~MBV-bh{,`9+t \'=1ƾ *_<>ˬP~i߾b|B#:|v+8a{TwA;V̞E4%H@~Ӯ;r XL8 ̸`:[Dh*GGM8OcAKqkOW<_ ˜a[6~SA}_t*3?=ObMho,R^ Odawa|]1^zأ\Ĵq>/G?éO/Mgv5,K'h1lYfpNNCpNQʹVn?ڷ<//sR=ΒM~BpGM}oAB7^C?^rzS|"p{s8* Jn!B;0<]ׁjOG%?5 {E㕭X5>?F~k 8~wz:^GkmF: hˡ4WSŠ9Y?,5sWH ?]~9ho*gT}qǫZF'rm\⿹d_mN ۏiߩcPԏWHUc0~_s'7)2׹p)̥Ƹ]㗠ߖW{%9Ίڷ.plHyJ2Ǹuei&|ӺJ(;˓  +N<(]Gb'q)>Mu~{^F+wA%0KE~vk_c_ RҔO/?I/a>XFXӯp]whŠ?T9?⒀'3]0#UC};&yǧI"xhOukP#ã2ۼ￭t3QMe.=@h qMlEIۛm>qW=~Oa8{/a`3->[rz=՟8k`$9Y{ KN{){? wiVg~ \_E|sa}eh_۩;p W"}dV,Hrɾ6@^IB&?zy8rv?j'0c7;-ouxk>!;NUg#q\oސMUh)/efHzKek轧N8i`wsv[R:'(fxss%h;1Vvs]?pU(_>8oWN/ٶƇ0|;M&\BA@5~. B/:ef=;oI"Ul@3c'L{Se~n5Q8>Bwŭ.Pʀk{?OqN9EWsLXMy am6"^Ijf? 𪾌ǟ9OjONŞ{qQ^]rms#{[QNPwmk.sYK@cnD|v8ܬn#>Oּg[mP*g#OPkP}ƹe@wy[m5qg>]\o' ԗ+- Le _r냨e>E+|&c8/N8N'UO(фNLI!>/U[OTm5Ӂw i~jo_oF˦oYJƼɍWozk 3Ł 0p uی8>%jhYi ;J9F_ʻڍbf=Rv9vC;,%?|O c!K~|}UТO%;<'icm܌`+)\Yu 2EuLHn< kq} Gh~5ڕL"ϪVy?M#q5fD]ޔ Ut+tt\KN׾:}ӵ ݏۈ%eSֵWCp {Qj3aOӪT0XΟwW,Vtm?m&Bu[ ԇ1s[pvYq>UQ:~>JB:XF~m^,N<lKC5(U3'/$b!? A %Y])~)KhNO}|Zn/Le)Y> nOVh-OA.ٳIC(YR3r3jLc9'?Խh}^;p\Ҥ #MupyW~Md_Q^# 洬og;gnc+n\<3}jQh1Ǘ'GcjY1g~uX.'Zepa]%s +]nj r%TΟ¬%@ެ}G9o,{f ɭ(Oz/N]oQEE?M> \wi_]C"QJ91"0.ܭ1[b~H#YPˋNxcY;xœWX>p{c(/9+s@>ڗၟ(?I3EߡF[`|O_+L3}?3ITӏTy!z˨=F߭:rw㿭_b]GsfQ*p'>'.'S~(?zZM7o03Sn 77c 6d"nvh\׷Z刻 L콸| vF";]?o`Zn 6ݗQ#`ױm8Ҿ@ 8nO~ݤc{yAx_Km8ƗYܡz?߽Pmo#N*k=w,}IjP|ݐ Oew=FսMM^Okw9gdW3Sc} ;]&,~ qZy{ g@{ ? k7S|f>C oxnQ"T,.DQz ¨{(YA??޳b]O~2[eTGn*y5JEwҼ4!~YN+/|$+}kN^>ƾ'[sG7) M ̏*;1La[%5|JB|3ĴtJu*vN)}&m"=xfp>&~ !W;><鬏#oC|ݪ;8q\9.<tr?9iFѴF39_\37G:˫#uDab`U@%J\ ~<၂ Tz'k,P}:ueA ~mg kl3jf~B(Opk8Ϣ5q6 s~22x4bcںx>z[ʞcL);m}]Z9ơ_oI+!TMn<7wqHgy{GOh%k)?mAݨ9nƝ6="ߘ}4 onTT?.W >xmE;_xl1;4@Ѱy^DyU%p->~XGlV~QXϥྉ%c^9>OLKɋ cUY7e#i;&?/8/p=9鞳.8 O6RWi/5|}:7?#wlbyGq('ElĿ?JB4~պy86=΢{g3R4W$Jy[?kEGq|oGU 5&ay6hyD6inrgm[@ J>b#w!g·7ͭ0z秝Wq0--DyƲi6Zr\ ~F)وq'{ij;gj5=AwKuֳk$c^@?qSƢe_+ N7|o]jQ,%^֩%~9,_Vy8Fn tt2]InT}8iW^߁ah>Bi~{MO?^ Ϋuq,uRϵSΤkGQ~ qޠh8Do֣6۸VPS++4V Cr b)FE"zY"RxB`͸x 7K.cj~VDûD[-ǜ5^2AdyeVɿ!u0N3මoeɽoo<8po!>~u%T'vlgoEb8~Q`/OL ='Ek͚OÈߌ Gpu,'tk/ϻ_ps3|b?8~A_gv΂wg"$WCo抒EORϽVCF\We@/qOCv\ynV7PtE3>wBcH{ϩF~ 移ж㨇-_ޮA^a {G*W==?z(;qqi0~1w>ua8Sxos\>Ҳ ǫkڞ\J!>~1Z!*>v|gW|kJ.JA|ypLAoQ݁㭃'_^(C3C{цy^^Tak/u濿ܚ8t|/gϚFvR\jǔoMþ&qJ-voDI?_E^*Rװ_&6:LY} oT\ n">y-:Fy5=,_sf =`鏧S_./7ʼnjWIb ,·3t=_W; `ֈ St#)⽘v ꉢ{l,wXlث"^;IڌA\lrx_w~B1H7@? SfX+Wr@̢#as}e%Z)Qu lqI_ҹi8A_)DfݓA~/('zj_ӓۥȏ5NA4 ZxiEfe쿖>΍D>밞SEey5.67 C E]=&7gE5 9UXPΞS=R|q53T?s|0ꗏ-uzO>.034p+6C}c/Psa,a҉1<"iOFMuvpݜiFk~e#v\ke5>~%CβI&1bh!1asO#>O@uϊ=57tt!\Y|H}[a v Bz,Nu?>E{v,Sa@ü]o?5x0/ZeMGNq Uyhhy,_o#X(?zM! Ū8_Cnĥ#8U}ğ7 n(g)v%,`{{JgDU~v_ ̍@}𾾡2s#̎|y8?Rޥ?W_P^v?i 5DKAa5Ar6/'=E(_# ] "@Vn3$5O/eʿ=}Ξ"Wۨ/:Y[G4V~%߾wA!p|~ߕt1{y-TUMod'zF9S~y:JSxYlL=M^gH,~vQ iK}ޯ{5un0;":ڳf=6,:'ի!#n ~ް@|VY+(fQ(? ۺٸ&Ԡ3 |4-oB2̳inrh~'K9zS+/Q-8:!7]_7/pN/mP]u_->&GM/um;N\S@, K֎=}Z:֮a/A:~NyoC@EQx659"~JGWch?~j;>|P2%p ę s^9JZRA^ &~5.i;w+Wpm3+]#Κ:oYaMrv9~I9դxWs&̫K RORG(d?L,.U_cN[xc_@xV]3Ye# 8h3W`=Ϥ'#.z @I6ķehw%y ǣ>y){WO~onbN jmIo|҆ 9~3]Gf%?X?&e>3 ~jUZIv:A磂SW X=)گ4ѩ⋁{Џ_ݺK8@we~E^RvU<,x\{M|wˁ >wX܂?(/ GhYSV].+Eztv~s6g#eoFkQ md5\67P6RDʧ];p?~xw ,;{7ȿBqh!dJ ǫgj/E#a53/ZsDm8u{7tղޟ;y9W&F=3%%l`9kS` #6v$Փn5SrzIKGUp2t8De.`oS߹,P i!Ec5wp- qU5/6"շ|i=)oУM\5߯i wٔgS>vXDzvl^'֤x#O՞Fdm11#A[j^y@i7"YPt DM3338gEu3e_}gχW=" >G7\EsXXʭ޽~Ko_P]suNq~C,ӹ!}4/z'0_|kF7Ռ| 75p"两qLxſPU[6c܁a7q5/;-ˏ?2EI8ngp4o<?3,َB|V!YAZ,z]Ӗñ~^'nb/Re_ f{A['> ϿYEuupy X>|H7SfK߳h¤9t" ?߹F_p[4^&_'"0zT3-VZH{NzqRDWOYAڗr'mq~ jZII4I9`ġ[|ɞkߞ?$j~A{oSrǮp,^Dxxv·RRSh?qbb H^G¿´g9?!U ~QX MT_Us< .ok_P)]=!zڳ(Q%W:u^q}oߵ񽒮I(_kYŘ#-k6/Gykn ? ڧE<F(|/Od; \/|i7^#ڭk?(Xέ8#c`\ssMW*w8>ͨ}'}`kwzA(O?oXB7'j- XNl4ͨevqWt'3#"s[|흋㗖8~j?X{h2XH~}>k9.8B烰Ǝ^y!?ܚu~F-DϬC|ДBc|afIPޞt7;M"}ȟ[K T8p3rE^hO(^uFyk2Mv6G#/:6Q3vuw4; %9l /TD|f+]!շ^YG Sf< CxOvOA*wkar X"SV O vh_nh{;_k*lh%K'ıB.f<;̼Ѿ5_Qhǰ k@a+s'2Ae[1'e_0 +$i635g VJkp;݅~WPcJó9eC W{b8?6vYX8 wyL[X+IzldBR([4](:D}5xfPoɡYd\D{e6nAor3P7kxN_y+Ql'~W6妋ZNlt Np~k诟'w)~G+وs'?mryڠ1P6Wv'O}hw( Lv'|~/_Qvd౔TO|6OЗua7`1f$h>!U/7olg^+C^7&s橿7ɁٱWӈKraǪe=AvW8û2WI%,ozG}*GjOɳ̟b/9d ?ak1>3yDdHkk3QF,C,ON;bᖽj/ϰns͂kўs޴nD|4s?~`osR)~WM?H_6p,2֠,HgM *)'Zupzݻx;\fG^] Ro޲-OwzoA[ĕUV;|u[/!hKڶא|waF/ڱnӴNVv)]^9i} ?A{P_@KJ(%y#ꞃ׈]LWj~0 ^ ;/2|W?#Ÿ< NN wQD\wt! S! 8;`pŮY:rsc#o)p7{bGA"}~{yG&E{gBԫ5ӞONO.ք?;PU?\?+Ƹhל{оK?~ Т_+>Z}Ā~p|bf٧ >L}zZpzAclfycvv~0+_O{7E:(m{=fTK pzϹΆ= nڳnU ƁjwNI WF >2pG?yb:IP&S)QhJsjA4߄8$ڏmoܲԀ?M(g}ˉT8  LL<>--ͤ6YTȻSy"ύ3 {.mbqtMZ^Wִ?Q@:? =s.#.jfj7p| 1~t3@ix.^F:=5x/<F+? /^+vHL}<[ߪsnxyaLpsegny]ִ=/$G0_57ICɵ`jۈg/`eڗp=[[B/5=m,gyuY;Ƙc/?E|8s@Qڜb^Fuu }Gg\_.to& \OغĽF{TӚrY~'7P 7Ϙ*N#[>ߊUG(䵞φg 8<<ɷӪ!ݏ~rΞq};F^߶4~ H7s$w;oD$ yRX 8n+[Ut-9[0NP~sYu :am|V-.kՕƋaki/ar;|өSq9¥ggmbA8{EAQ{-Zauǫ7SV6A?zMWîc}BU]^}l:?FFytIzp?;7$yrPhH! e(-4[EiRm"- ǽ}9{)}@ڷzZ)[IA{VɓB|ƭgi9Zլɴ9]|_`~!]d2wy0ۣfih8NFKEWpi;{)GcJ c~ ?} xz\*]iڇb37QFN՟L@oT-UF8!W~Zrw|h·7.GM4F~ܺwDF |.ʻ@"(< 6ҾUb}V;lU>,xa6D O݋5bBݑO;U&DQ}B׫&燛#Ѯ$~jvz~ T$cDH F;'x^&nPN>>v>g=z`:.+ѤM}q0xصuFgั1^!ϰ?Lu2Ճ=oJw+ gqW T_4n~v=:o=Jd].R}S΄ ^1dk2-P ˡOwz JaeޑFok>aK$:ym$^h0l؎K_6@\|ͽ VLmG+?[p*Qr{ܝSoF(Jq~SX|LW(_BW{^zqF-r#NX{K 쏋)M0UQK ޥ w/9KW㏞ 5T@qéUihZ.`\5uϦO<-7&/o~kLuY:ng;Wt* Scxvq`ث R$l)5i珇7S]|x!.Qݯ̿͠9DG曑xH9n8]?JK#'v% L$?Z[cK{?((O(Rh'5^Vg1?QZ/gbm`O3g0C9h&yXmLmT_ilo#6_x\6[;[:G_5'ǹŚtZ?3D :g R/O~|]j_튵=h=ڷpn{vt>gAn!_Q}0k6!^O>8-OO}i}.ƺnU͗~Ayx5[{j6W~\E\WyUNX90}ĺhsԣ@qV6+v/Hm"t+vYI ,hǿD;8ydB8ww&ٕNPH#׷l} Kt"8jM`=fX 9YFs伦'+_־; P'ֵ;>B|f]̎~C)o8< N>L3䰒 aI Q.SLpjM2*cM8S۲TI먨yq5?⒔8'D} Sٱ8[cr-cT.-khq; >)E;Z%|<7r:}_C}'ǟ^x Ggb .ͦ94؃De`]Zf1AN<qy~0u'Q|j6;dv|LC;jBj_3ZξSnc^Z@u"cxe9GkZ@i]A.3O0캁Xzr'ȿ`L亮=]C}yAhǵ)`~ohOT޹6)\Yjo:yv'UDTG|ڷ2xL_~ltojJ3Xgmy)6<8?eTs7YDvT`!P',^9˫wbmylϸs?#W'-~:w>kHS{`&y!]M_i>|'?p#.!3~;c|M$|>E#/k)[R܆s]:vA_O5WyjB4ڍ]Jﺑ2 뾵8̯{Z7dC{٭*rn϶Z>=lǚ,Zeنf</a.(=*yA/ [>~c]N0?"/{eӔZ3O~ / OUyCtڟvYhؖWCAr̴;~:jW~#Ow`ʳF`9<݁//# OZ IKJ>w~Kn8Yc?kr@{R]>f/`WH]AzD-` ~Fl8 G|`'ݣn&YU˚Ńtțk,!r5|HϧE;V OW}+eu _LQSGԀY(|8ws8->m8XDQ0yDR3n.%wR6>#/NϯEȭ^d<>RLCxA_O7e%w2O xo|XK5y0áwP J ⬺\:^5w :Zc;? ׋G@}fu=D} \#yz;gE.n"N0t3J^p &klr=-xX;Π#Z8>WP`;ڶ _1kZ4݋SDx|D67@%O{3VGa\/gm07?^Cr oTV 7[o7]G93mu#[/8U8r%fbsw~39Ee뿚PW\yw P)zCY1pF 9]fﵫ_Vn~·0?}PQkSюSD %8)ut #F?.7#ٙr bmNUʏ:TrƦ=k:S|uU߼,9wS"ou^w:C/ = 7xF- ㏶"7'irkG3ZoBfyM)XWM8pp#$|pC&W\|a/8vc O6s5-G|NMf/,.?I<}mf'O] GyoW ̊dzG|Rcrr s7 c*:$h7H}>`!?ꐛ`/R9ԕ- 53s՛1d=owx_ tW!n.d/_BgȨ9 _ ʭ@oz{:W_dz%ڑ¤WN48' <9(o:>BP]O菠w HWvE;Qe[5ٶۗk?$M>]v@P]RAOx?O ^Q=!v>O05eSpFe_ G+CO5'&ί?bBJSeh'uޝ]q,'Uż#+՗[ҎK{G\sߦkiQTN#t^(y(C}d}9nh.n{*tѕId_,4(&=^3-YymSZ/5ƐH7rpZ\E|tנ^=2o`s7({DoEʥa4@|s/}X^Lm]3/31ސo&is&p~ }/)>|B6>FFgI~'>k^[xb/ZmGD%8瞲Zz;3TxHDޑB'‹KqڔlZ N| %XZw1jAg_T;+S@\ ǩ<O_U%v'wP joߢe3_ E $gw`㲟k'd<"m/uQY:L`u_pgy>E5MC;X|o?%B)H?e넚y6۾$끴sdSwP?@t.//˧o49O~L?}0qE6p3=geٟ+jqCp8ș~{^Xx /A:'~!n:5lߩ5n~<{>-JYyV1g}<~j?efb=Oc|R^HQܘ&>18]ikAܩlAԠ=sZ^?!G,{0Uq|ο 0/P\Y;/== 톢:ɚv VĞ:KCY3b!\?E/{bb@W%8>Dq0 ١@t"mg&pGb~)ReA?|YC/3{_jh[%-p^ Gu~~8>I`hcpL4,ӖI0^y~A?U>tEYׂkǓ[TȿqV~wP竱b1ޏ|1 ނ 9G)Ãkn=Nym`*Z> zs[穨gw>ݔuup"-o8Ao-o/]GJ-h%cpyS./cGxuL_{{!اfCd=|5)~4~r0l0vKF/"xܮ< +^#iyP@Ƅk'#o; zPnzP^\q@|zzba;姺{2lqgLU{QUeNm `m! GGxξdaֻ:#W~%Yˈ.= ЈI+[}-I ٿ_3H??i7WP|<®s-@hiƌ7& ;۷$kо#n9?ۏOsTrفôl]h:p;}$ߴ-ڿPћyi^ٶ}v&ceU~ԧ&6} >~@}6ɪ]_qUs3wU68új·-ޖǁaLy3ܙh-<3oV Q?Qě`VkM,): S$6SYO9j5s)l*Cc}l7=|Fuײ(gOwS]JE#ϒY!>(kv{wuAOM]ю5R}`ǺKrFyKjҰ/ַ eՕW՜sB?ƸL9(?\7t"mc,%z&ͻVv20IRێq>PU)z\2 {¬,¿RZnڹ/qkG[M$CN:Y~W3/+e\˰~ˬh̟A/hfnׂy8PǫYoWT忢stV砿z{e - ~cO6^+?oC-]94!X/<" 2$?]ATNMFzdvMYr]x$?bԛ~ ܶoo}:nV Ka0ON(sU藜 ҺHK&ٳO_]u2>JS'hi`:̙ǥ @XzWC=CW |.Ina?|HQOo?W7yNSʲmp*9vv=BLᵢk'yWp=y`:0{H cG_i&P}: D~dWO?a}H|jhfӷ&\_P;s/?("=ֵw/ՎTn&=ZRaOU?zGԟgkV>p%Mu.t(IHA|u,go7W(b?h_ڲ'sc1[,~W!TO^ڗf;sXiXW}95JU8aA^8׬ȋ=N82Q;C&}oXj}c.[ ,, WBg~61H-_ܢ]N/%|K/oeSC.hOQ*y.{)0_W!9&˫5`g3&7D\8XSK4_Љ; DO!sJ8- >Lmip|; ^܂gym0?/ '5sRos1*MiDㅻ-unrEomOЏU~<>惝e0 &"թlex_ea)+oMLԞd~:cʰ|(7r+ԃzSxIHTUZ峅i jmɞ=mop/-A<M8>4Ժ`<ʟSYiuw)ȣA8 ^vկCR]av?ڧ O7fb/1vVLw9ɦvP( ԗ=*^{w`;8(wDze4hx/}im(/_G=[+N9⢦vpk֓'xcJm\|U0Ϝb.cdfן_G9R0:G4[|.P>;áZ(!m*JW1/x.~tٺ]6#A:Nk{+﹢Ճny?k?ϥ GMF]e, G{5sC Uf?쟊2#{L1= E+92!0w#[)~Do3BTT V?k]Tt8xQK(G<8luIT&ЌמW }ݨ~kk)C?ϟ B\Ὥ̦}|Kt'2f^1 2oae;P~<)&>3/Gd5'Wmz@xOz_!]M<+q|҉=؉/fA@ ⻼zEخ `=u%+tn-1zw1i Di}E8.fKGwhecPGG'{n| EnplQ=ch"w< @v6_]g|e=P.i(gͶ OϡF}8vN~)bOy ÍoV9R2ίqiƉ"eqVOĔyxw2Q/!CiEH]dž!O؀Ӽ{'yyo{+pnOFb=SϴQ]~WiP'0-tK$VL8\~0|*ì?.*\ Xlѧ;?qQئzSzg_Z-{v﯃egwK =oQW:+Q]x"`WYuō2N%MN:a|E1`i0Pro(?ң,Ogݧ/WוM+ %_+8[\q\מ>׾ 7+h⒪/S.^!peLO2țe+>.ܓ Ku~0V;͏s)O_dbQ^ o6(O~.ylnj'>x_s3{1ّlԖT5G{ ez&=gqC"w>Tfu򿟅` &E<+os#u#^'yyj9L]p隷XЮ?xޟ@81}lu܍\Jq'9܂[{~_kvSzUs/wNtsWzc][ke;0@Wy) :z`|sY''sUA91٣flF?}iFٿ/f8/y/W9S&~wa^{'|7w 0֣#n?o-O~χ_P0I)Zձ՘D|(7a 35nh02|~#'݆'97#' O6QWh 6}Z)kſ9qE6ړ&kʬh')8._ n]\~:Wk!Oi!_[O"4H ֎ U? #Z]IE{W-g7^0-7g^6 G>s-꨿w2C4+A[ ^]LuO.ٯ] UM8_~sndQ>b\[&y#XmAu"￬a1ObM{0/u !<)|ͩȷ/>}{ߏ}9Ot@FXؕ3L7Yb|f+kqʷ8u-/t~LMw\&+4a(gއoӡ/ !ېOx ,AGQ#dCi޸8}taO72z}3{|sjm1Bg=r1QveyrAܨt3_ ޣJ-ɒ^ޠz`Sy Itr{p8WE%e`krceD?W N# ImϿ3qf o]o_kδ w>Q8hpͨZ_8z_SS?bEx୆Y(oG5?zS끫=N)8^QeԃN|KW,CQn3W\uy&:z۶oI>X7j?O5׈v@{',XQ(Wޑˊns4ww k|&"N(ksAU5n 9r'bxG7Vw.T&oڷač/j?"7x|e}6/QiZ?ՔTe9 />-F~*}6 hx l'I0y.MA~(ΐ:1H#I}sŚM3@=3X)nwR[~9~V'`~NwE:ygv\k 'x?L~xxvXv%kxI"Ŭʑ{PKbG2=Hg/Dwta6rkꟜ 7H)? vN12#78Yf9uuyKSW=)(ONC?)/0ij6l_ ܽ?M:m:^υG= ,/wqɺ} -:\W$5'73>t1ڇz{ =]p`uz}7P=i;<`H9OxS<uhG}sZmXx;E1Iͮ gP~!uOdw= FxhK8lB~Բ^vܿ=~Dp8+S_l-k~b'vGx6aI/D!s+q{FN38^ŗc>2܂@hH[L7>;9`v!+RRu}U+s ]ww&XFK8;$#;:fyȲ_V`]si"(U0Iw! 1qȡ )h'I;n35?r:V}#}ԿxUOUG>ŎΜ Qb%h߲='>֟WmѾO1u2C6,olaKhs9g-5?׹[)Uzo?RXO铮gct[W]E2ߣoH"Ց,./:ۏԣ~THY(}lu`<1ZTꓛh;aQ& MvxqB38vù?gw{G3t vUP.#o1+T,[+_J+]KNOcXNVO+CѦ޿}gXf~̈pA=ij^!ܼ2=`v/ʅN,E9k3*z6g){3p?\!b^ڟ8׳9c!'hf_=yN)c]Ѿ\v{cd/Fz9O,`-{RQ&ݹO`rD7O)JiCg0%/[ǜENwF.؜ׅXؗ+!EVO\cb]|jxqILw/Tҭ@?9t8pQ(~>/z\mQ+t]_MSDιrFZx-s]g^I﷾*ܺ5`i W`{wP^>7d ^"^P\LOʛ x̓oq|I2ב Ւ'о& @;Qk'Be~5/yfR_1V ; O!7)1/W幆O KzP 5ݦ#eJ)ߚ#+;[طn >GüHu/\z)`.nx< He)l6 Ox\Xߪӫ,nt^D9?бaHZFw$^@E뢊΅ -0ob3/Z`)Ƽ5ޓ zotut7/'\Z4lPgQ`g/pH[Q:4fF_6Q6ZvYfkRz6uX;~nqvΝt&{Ƕ(V-_xuw3s=s\Rȿn, 8 vt ')&ͽl$+Y _0uؾ|xu <%A3];4/9xl?FdwsuvR`hDuaO-W~C~_Tߞܡ;GTeu%'R:(I#WG?\S:_Uѭ'5V7#OohݻCuxY o Qn"?w7-\V xømKGK314ft4 D‘8.6Ua6:yq?h񶅑NKXvJi=쀙h/&ݠMͶ{XCKI#y>F[&uϧs{֞TSK)x ?RڗU;y4:sc:YsO5ͻ@yghlCyxy2ú+@g8?ԷvCP҃>;?oMK Sd0߬{蔆np8 C/i70N\>Tx^/gD1?f@:olͨ5E:g凞Vh!uH;s)~-/e +>;C}J:wqecou_h}x^pbG?dx}~"^>3I`@ϊxC[}pb(e;|a֧ rf~8Ydc 9-IvM&9h߬8y;*Ѩ_[I6eۯֿ=>uEc@O }337Kb> +Ff;q|΃۪MQw`8ZXz87Q6j!mשǧ^2#~} \9YoAӀ7*'6j5nyܭ3~.;3TdHϯ; BuȅMwu'岊'хG=z<*o.{_bjXhr Xk~FhG}bEv^|[WgwrVfyTK{#к Aׇ&B L', ėWP~Kuqy^1}W+k*;eD^"9u]_O4r9Oy/,=u< 7_Dz#Xg&n} ʎ Rvټre[7`̙;-(9]n/00GuP]fn_#SG@l.P>oQ/3]]&mOC7 رq8>]zY"3'*oE޼ ў_n4c)aY}X= q~Nt&&/HL+%x`\Iz/$՚xŽܶT_R ~*X]믣qʾP&sG9GHЯ~άcP}X_xwd3嗢0=sdGNyj5`k ݗW=|HV`0Dfd\"(EQ1w>$׫_b}O;@!3ryXXي I|zד}M?uZ ,sC+:Srcڋإkiqrp7c]JZmHsУٸN5K8}0z?.1i2sNo+e0Ψ]Xy`3*iocg-IМiu0>Ykｺ<#/]rF{]hCZsDc=7Ůr-`?̚EG~h4 끜U9 )FsVr?sOGR7p©S`WkC:Mѿ+E] lc7hSK~ejmlk5,~mlv#|4qTw? Mz/7Q{nQ@sѡ|;{<#?}TpUo`E xyee5:jW+q`o]K;ޭ#1oէpWsFz?7%􎠟yMZ:,?>=[:t^2 o|^hbq-g_نW/7[ C{$5ZJvo?Eلyb㰅=0Rʠ~#c?z̻rZq]dX؀dd8g-T{\U{&= X\8DuqifYbS}(r$WޭO\맿ypIi]l 6p ш39a]3^eo wy[z8UT#:r0goDskTmgMt,0뺋kmF|SOkڿ%lS%3w8ASO>4xtOt2o,j(^՘_'R}*d6 ~/%sgڿT;Œi4'оzps45"k_%f!p.O:Uw_5[OdB}7Y5>ɕnzǢrGqW3tc5گ^τ Y4 y^xNm=HK}D6.:&waVћ_^:Z\CҥG7o0Q)>7i_{gGcAP.ڭϸJ[]b}j9-m|aRW k?8 "El_߱~Տ^F`W䷌SkG<3q|?Oԟ'αZ}u/lL"tc8hf Vv) r#?5; Wc!GmH5îW8/ybJƫ?V`_'|-O8Pk>=ԣI(S[ΧBKl@>dvAst. _cvߋqUƇE۞x^n=ΓΞQeHv}]W-Dz1NΞkDRM\v-->{NOnq ?$^#Lk=O-KUw,ëE=v Le=v b:<YqIuq|5갈3G*z^=rOMc66Tl7a%E(gݔn[:_k?IOF< øȏO9k$/_cg~uﻁza#ӨOAKø=+8y9z~:ۮ͵L,oSɂ߷wֵvn@7}Twz*T?nChoܿh]k_i}BJ" /Doϧ91+~1İ`K.'{` k'NKKRV~/t#*]g0@ra?.'hʱ~n.] ]Gt37Գg#g<H| ѵ?]K~Y=;nQHzhG:]X܎u,rw/eq|Yj뿘ηC}MP}c@ D!lRNu܆ ͇|?:|ʟf-[Z &R/'°Sl/l^} I^2Dj4!wu3Q @2L%~OӼ8WTË`>|*W7JR*ϸF)ŹcYrYWebWvٖ~ђ8?']2 g1JQy!o.F!(^ |-״ǚ`do/E(7Z<|E3?Cra^tĩ#A!K~O3n S i:MgN75* Vxԏ3ЎS`%-OqT:"}kBe^oU?V+OD|TzZ}ygom1Q׍VU; EIfC?R h } [ _Ӻo5g P=8>AzMիD;ߩr*>g_{e ^Yk8τЦ ױ|-$} ,L,L皨'Oa7`d8F랻)?C7eu{R)? 婋r3(c:ֆC8fyT`+@&DKL:hZT}߇;y8fv!ҞC^QMNwͽ7b}hj1_MM37 r2: &r>>;$?hQH'^Aʩ-hNąԿqQorM?y#v p?(Ot[>B|Rl{;\ [;V}cʫ#w/įcҧfs4PwlH|V .xlLg0?;t0\!@mI}q(?fi~p>k4U 20rD},;2B [ϻ7%8.Pk@y>HwSeXq6q0OpqGVß0Walg/,V>-T(xa|^+q\.G/ݻ 6\ۃ8~fKNi5:^v:HW"?6CjG֡>nq1lɾ?, ~kx}ްi{~2#>,ܶlp8~}:p%_ ;5OAϛow0ڏFQ{VQވ.{Ei?O=/JWb[hļV1kŏΖ ?yP7 {[ҘXZ9+1uv7Cެu F (Z6>[Q_ssMllY5kӭ+3`gAw ֠k7ij3+.^hmǢ w6+,BQ]DuH _8G wE;Pr/K|W`@X#~4ڳ8`52;|]5%er~ŴbCmn8,FȢgWxb`/RcS/{M̷o1w{ '~3[r{xa^DlSq_۩f:8md-`ڑG^AZlu"?GL"?`i;]{4QE%Ez:qI羞vigʎ~Q/[_?[rhI`WԟzTG7\z-Ponzľv~X a/x6oqЯ`Y:sDŽt+. ļ5+|_S&;΋r}cQYo236c]ϋV1^(_AHO 4 huﳴ1A ̀_VE>?~k^YV!?v}dq'ȸ] u]KkITo+W?Qgv?^˔,]zhWף4r e5[t'{SMxNOs~Y9{[yedf#H\MsҲτ S8_4[_v;ٗlfb`u(GsgDՏ~=RM~W 4T]u@ls1(*g):u[ A8wsSA~! 8<U`7ݰ D}'ڗbk06/|ň_Z+z#TuޏM,?٧2@ty >9ݦY}wwއY|+R}~۴stτ6M2cڽD?Rv\ܩv|]8qeAԧ$vcA0{WڏSď2+é?90 {ҹł V(w%M`[ E(o^ WqC:c»|p_Mx_Ux\ ٕc?QʍshN/_m ş[0~8%Lن}k'><?61+n!^xYt~)p`WZwB;0RpȊ(SI2!~۟RUD2`<_C}`!y 5m)E}RbQka7 0;5z4k]xR,3(ƿ8N߁&gWoɈ;NZ%<*?̟\= %K N:b^'ԧ՜#֥nC.4h3~6*4A}j޹ : TCӁvވ虱N{KԲ-GbSc''T2i}o}FC{rl8GaHLRZW8_ qri⇪lՄp!u.=:w?¨aF 0P=_ U9h?&1/~(/+Wo3[?N ^a C֣tΛrڳ d r^/=Ń]ƹ'~Vӫ<3ܬSA>' ?~{?ky.HFS9hI+yMG}?VəW4{|ȋCZ!͞Iq0h98G9kҾ`mGp9#6sc1(4F~֝W!ph}|.o\k8/G> w.[)[alc XyoyI|LHLwFXuWC1˒녳փhLC$sԵ3T?}$MWYVg}h/>g^|0'xL;8=Ը~AF ?8"?5 ﯙN?z3gC{VOyF?Ԡ?4n(+?18]_;'i?zO`o%!InW_tq.ؘQ}3w#4[V:׹T_*6tqǶ`!W~BPgeX;nO$|?:re^9AH1A5+0kY-m{t>KמFSWmىE[8':`_:x >Y XRſ f6H`!wb_Dy~ܚ8_>WW?4'Z<IW]zTk_п_yEsz?s^/ϸ9ʌKP/E^ uʡF|%Q}G3秙K#1>5kʧX_Q(4|.z]KRW&⤧sdqg`,8D Ј@Z4>d_9R#/آ2@!| ?^ْOrzƿ׏G c^:xQ+Z_ꂼPVⳗ89 =KB{mRLr~`e8>8?I?ŷƁঢ{+IEm泶OW;0\qEq50+]  ѿy>c[납z쫣Q_xe 1S Oz;7ɖs0VCy)zwm#,w~G վyNe\y-?Q^֪kJ~0%̛$b1hW ƈqx_Zٽt%kS./BHK[:l_"/X6uAT?qNOK᯻$ ̋L*|5~ɇ'u>>n+?^8]<幻wuokRS~FW?2V%t&󮶙sо/~ " /)=: ae7sf=hDu{ʽmh-V]1Ik%[? Ʌ`a4+eUWhƚ<+xt.H?Cu<^{x>25, /GyhMUZ =?y9G؎dǥ<g ܻ Ρua#9p#dG(VO7.a#}G;ʣ_~\g\\AŮ*W=LSoV^X^}ƸÜDm2_]w])lD~o皘 }/TSGu]P?dVMXtoo#0’6"gZyשS 2)|]#=]?ض-KϺD] v8C~)/qJAm?s6 B`U4ѾI?WlX:Q}́g[u5?}$~pkizN (=9$yJ- ^d~x? M=tG`L ~`[T: %1]/~2ҏ N0ߩ.Cxx;NWbD`X4g8Z=B9{1F;ܡN:A^t Luҕzy`x_ޟ#Nھ x+kQ÷Ӻoo0Nyf9n9D얰l9g_c yS_jYy8yFW KQ*-#Rt*'G|[aP-V1U e[>&}5q_7[xs %=)[<'uHkV2p^,g]}n1~e*[?sTwsPP/ӄUU$x;>Cm{ x(Oa A6kf8tV2@;⊛{e>Ph͙|?G??e^ Կ+:zMe6d#zBG-gG=qY3hΤY` 5s>Ք*=tO:# [=V }w#=qn(/{o}Ln쿣!,-m"8J: Q5,hKφ!޹qTk?pLיlQd/߳o7ž %!3R}eB3hn}/غ9+%+ -EVyEeK>]dK{n]讏 %A`V/1_s>=U'32տSǍUmOsSKэoI~i fT)+/-vu}tmu=ߔ ]?9^PN/mB2y, B_[lrX?wyT,x0 9!^ZMZuHmQzZsK;n{GgzYgƥ8>p}Ww$w~nwG.{QAIwR!]x[Tvp>C<ݯ+0 fEuQd`|[0fm8.2l\_ɟNyiY탕`KMG=z4w܇8@pGDy ZA+na~Qz.%kn;9NJ`Ssh1&mt消7;vdZ ' z>쯵Byq] pao#ghϯZj|Y!QO*1OPG. ,'DŽ2Ghp:LJw~~7kATi}4水+XiEjJvN!-i. 8y7'O-sNyU(a{z7v:6e49z]NF>Y9x\!_mZXhrtDyxc>ƀ)x?V"f0F`.<rd׻飇Q{5 | Zѝf/jg>ݧyL~`<&;X; Gdn硟?>ǧL5o'ob-9ކ&_~Ğh[6S=թqZTSҥ崮ҭx;k pxtp;c֠~4S^sIʉtޕj*^P~ҴD9!R}ץybw(^A񈿢`Iz5؎e<89y%-?8m u9׾1FuU;wIn0-o1F1.߫>S}6+C+/au~ O[ϫ>/F#r뇊?f{K*ڏݏ[FEB{U-P0kov_?G5uա5vsj7=INХ+]{st?7Q?܆eh x{qy?D%N?S+$Gs]r dӫVs\>\ְ}<,p's3dG$;78~M/ ٌ{uy7WP羁堾F.MmQ_N0o4{}h}ܨdnc|VM tW5sQ券5 >nU v~hg'b\xF~;bڟ?jX0k[fg0 (EًzOހdOzoS#}<쌾P~|zѴck@*{ z\ G4s'婶ݶ;R _RF[6?0xF_=k׮M7D&_N:ׯN-V 2M83]r=w_[ 1h_v1q|eZQ=o]؉)wz[ D&Hiܔ` /+Ajrq4]Dk%GL>.s{tJb ݞDkw"Oѽ0,B}zuo)aosԛ7s^'\9 ]br>Mvuc8GnG ~kґ7t)~ x~bR|Q|H='g.͎yhy5g-c'/X?0-Afئk}L0=Ŧ(/0\(yx渽71bWOxSAu(ujǢf-@y7ⅫZF2 g+q wQ9s剻v]nXSc>f;8o{hc>Yəq@qһs˜mpv\ !Tz^ZN (F}1KckЏe q/Fqy[TKWjowl3Apܽ!PXiHuvY|#82XRM?_f/NyPXxKY*v񤅫\|·E4>s'^L Xb88^u|q;{ Mxv&!H.9_Cp6]5ַJؔ*z=:>ۆF֧q%Y^sl]"q,TѺco>Mv|ٱ'Ŕ7RӶ4,ifJ]{|߻ԟz nvٽi7կ5/f~N'P~rCq?O`z=BcV52_H&'<{]bU'~`n#AXyk.ڿ4Hцy"ï{ʱf}Z_za`B#"~!ΪhY @RΥpOCǓ-vx?-Pm' XKq\Wюu+ ՛ܣk?A2`Lwk\J֨`~<='Q[ >Ɵ{]8peȿ$}齁[=?Q[p\AwrG_[iL}+'hH Xsz YU6!/*>{;-m:ҭg:ЕaU:Wtwk??:5-;"lV&]- nn 򀻩3gs0Ni O<|r /Ghu [>4w"<П6i>s&}@M?miWר~k`^aTw px;}xr/ZSO3OXr8aG`z~Q_9{e3(܄ϗ7l3켙=[ՈF#_u`ﾻ^?+y3N;3ESnc]sUլ`ykc)7i{{nK 3<9n7={ְJ L?jX2өѱy}jqt>0l]޸S?7m O%շn]ѐ<h]i{^ExOOS`^cg=3i}٪Y|o81t1T_ ip 4F3^%d8~Ȯ4"iZY}D;t45E-fn7){T;ė7 U B6I\O}g@taa~;g:q[k`vt"YlA}Midķ/k1_Ƈߵ#r0i\?cf;0㓯F* ug~?ɼ񽑯v.lN;p<#(Ղ콴Δ2 SVѺjLoW_?;d/OkWj94?/ߩ-W4WS|xSͭ<:g[dh&=zV89lw_9F;EuȿT5~ i׶J_a=_VI_=-6^u*g# EQ;`{ 2][8ʛ*/ $luuo)˽`㲊șn<>D"2Ƃ3q!{ERNϠ/+NT7boʀu#ykp-8ng=ρt.E}sÜ:2I_Fg+i}nkf xQsxݑtIkKN7D #3E'F/4y)^T&`ax )>G-F^;h;ڱb`Nvx*̾nrTlP۴#{u i kbJLL EsX[}j$E]ɪ3N;գ!p]E{kP@(;ֻ- [RKyj +cx=>h_UK#RWo<og<9Rd?CVˁ7Bc@ߕCArʂ"Nw jbvǾ+CN3λ:"(ϲ0[k9_v낊kG0Pſ~o[gO(GDb'>w<8-Rbph# !-y`y!)B}:`ڿ?pدDgwn|hJml|qqJ;HQ<Ҭ{n˥h`L*U>8 m)?3,X/EK]dzq\烐W?gSDEHۿ)#?6ET z߸Ř k3N ʿ6~S׍[Oo~OZ|=pNB{gm^8kPaGU -TFs~6__%C_$߯~-+AJD_`~ap9MEX?~<|X|xIlDR9X{nۋ'r.J Y̢ۘ?2-'!ƯC=远_EW5\a 6&W _99)yckЬXӅb~:S3fma΍[>9+܄1uR:S}ҖO7:olw* 彿SέmI9/,>^'kE+}0.,g Q;%߅RN+.|` ԑ]nv1^8w 5'HFkY)'E~#ѬuWs%aQoCT|3HRex.=>,HFʾ#~G3nfFR]iF♁:yx~/]bc/_KgMsNo8_QX}:ǡ,D8fȿ70:}#s"7-[P喾X9`? *^A}PEwwK{4`M ᬎGƪi}ģr(3|#lKo5oMC1tbZvJ}o|"{M[K /sodCw">h8}o:2C?mOn6"+[3aÍ 7;|T2qJ*J}4|Xfp:K{m nvXGU~D8v/L}O\pꤎRA%!>׺kӈkD 3(?s׿2$Ô)xǗ<{B^fEHO%ˣP>㾯*ϸ9`wj}Ol0sBZO.-s+'ʓe-Fie(/PiNR'P}=cu5 uY.5nA _~E~]`{ 2Sz ,7CIy=>;eԡS@jrY/o&Ϩ`OiuR.94JʭywϺϾ2#뗀Jh!EΕs`3O$}{SQF3Snx||`3+k?Džۭ2A=?7X9@;::TkD0X}oC(:RZ?|G+G'0 -Zrz~yMkwnX׾%]WBT"22Q$Z"*3[6%RVd%#9_u<{o) nC/ͥ-?:~ 'ڣW)7'6{g7p>K;i߁̥iwR}@c?'eC+vrw:I`k1 tAy: >z{>X̢jrS|ڬӖ\&qݲv7쮛_,^8JS,|vꃏ˚oհo3fu ,EzI,ⵇwSL8t'aaTG2|W߿=5*=fX\qRHR#L+%p{rU0_"'# hѷ|BSpH8b%HX`Ӛ"cqĺ ̓xe󜒑v{΀2=S#ҦHSm=_@yBdQu18,sÌN\H=}fk͸.W+Q}@7->Ht^iC0B'뷳ԑI^)or֟C4s@x/랒d;<(yvU1[ˀ/%cMV#U,xOY.}[s@|icrU+>>5~c⇤e7ÿUÙ{<0Pi!W%_Hn!+(uKI 5e>G`.ovNi{;">0uw~)dM@?&3 ˮ!E0n'lF _[To_}ɲoe h>B}=E7ao?+8?u>2OcAlO`#Pϕ7+MVv Z79p|2nȓ帝8+;wgz ܅|wa{tuD7?]F|S쩥]v׾+FktRa|ڗ*H"н쪶)?Set ]Ud8އo$vW /MlӀm߁Po mæ}i.spHu;2~|8vfi)Pgw?gB'nW?D>#(]%d䶷z4 8{\7w)00;y^h+fcW]{\!;&h9GUvO;rWu^/݃H&T:8󒁘lwEB6 PZEŦp+ g/ zbq9]G1, ,=G3>ENuRHS7_?vhWn ;}8./z#(f(xz;pS0o!wxaۍΕ`::'O\ \r_򷧏p|Zk:Ș|I޸mG/nwOʊqf'O=p]E?ۤ_ڟl??BⅾL=0wLFB% h;Ӻt>~Oݔ_q|A C%x_z҈ZBh?|z~/,Huqܚ7Ny֧S?iѻ5;1NRiT`jY;څ2{)uq}a{ C(s<g] {IZtyt!Wh4X ^]/@P+X޸>O( @ vvGcԯkXolJ_:q ~"D!c^&+ou=~'HnD֘B=5+#gWޱ =n!-JGe=A~hϼsP-?'lAtׅ`܋0헱<= Ƿa| MӉuƼҵͫ> Bv1ٿzmK:ҍT77Gy?Jѯ<.Z6/IA?x~}׌k4ü??>0 G8ddz/o~?8?8?5p~pvFt9v*ڇcF5{{|Fߞ'_DZ޴ڡ DvA/Y2s NiWPx$O"~y@>)x%5؄+r]{F\1O}hD4lzY~}A7gy:JNw9W$;{o 3+Gܥ)#Dh׊hpA{W9/nϖNA? ,)B_,uQzkC&<3k SQ /Yd>[>7O5ke/=8]%qD}9ړם-CiO;=媰[뫯n/tYwS^7`sSI{"/t/6s=7CS~G_~_^E8s{+op(TAe3h3_`w^8_a -~O&^z5߶:fNɾt jOS0kQZ?%IcͷI p3lk}[z`}Rg#s:AQi]0NϏ⨗c*/v(}K'¯w\^>xOI5C?՚GsO%#>n1_g)\Iqql':V܉]+o_$|a!ZLG6ȸIe pt5C|-4O?q^]Ah'heaēڋn|Q.;c~͊#?yf9\s/^&ܪ3[}Y6ߞMylݷ04uҾO)*xCQxwa_k?'uUI&LBlb >L@y:=KHSQN̨ <ϲ9eCzܱ+,1BYțt;g_B9z wƛ;lk6;q ƝS_ $AԷwX;zNs6/BΪ` ~i"OPk}f}Yxj4U~Ԅ-AuI'iK [fk?*bquQMT{][`V_|)6s-UQ'aVgUt70#7O3= OA~mL9ߘ3l!K~Rúљ}̸{~bhO/> C? lޒJ~_u)_|/Xps䙺m]GGR0nkss֒=QLJC5>gRoQvm*}O|x:FM~g&Ѝ:ԟW춣<p=v>{ܾ:,C|kd~CiN1uvAHa˝&Qu͡!u/?XQ~u s(ZCk|=Q)T yVnemun.Qpn.x#NẈ7 h7}JFΓ% F H:@Փﯯ2_Mf(N\R " ɘ)wͮ M@< ӳ^ L_&r.?LitqTZ L-(n(Cݳ)?X9;i=.-yr7ૐ~C2m槿q>'t?~_ubD3ACqAo n@Q̯yaP'Nz@~KOu{ 9i!=AWXhbfs!^m~;@}0[qsF5WZW]S"yKG׶)H"|??'kaG8"ͯ|leq_o2mLF<]!P{{F͇9hNa9qޚ~ QR$p:<5++.-@fnL?6cCs_E&T7XKS 9'G\_XFv['PǶigj:uvV!U"?4g˸FPZ7^Qڡ|_f|s؜By:-sh?^ H&t~+:O; Qm&jOgv:rPKkw*,l'G?w /i4M |[A]jäd!NvsGyogeҭ_E]TT<3/t6 һP?oFTtNzoT<?yÊ_T]4PW{e}Fߕ^cR-.Hu\k)n.@u{74^KkFúi׉3R~ۧsdU$~_}p͸t~z]!I3Nʯ -.%8/9ѿ)v|D}n-V l07H鹋 .?Ye`w.>6яQuYg㼨q${ĹM85#\By/NmW#CǞ˓qެϒc_osK9Nr k{}w9>NT{_ރ-~io*⧱~0q^N zڇ/*O_6Rt^>XN)h1V|Mk5It5vgw C{=)?q+ ]Mo;uT<9\"`|xl \cn涓8=qZbK]Q -R;˒G= ~D9s=pGyaibQ~; [ޒ7kV.l̫?}ri9Cv7PTxBQz2u+¸B}Ɯq.C5-o:pnhہS@ts0W&iɚlťz#Λ_heKa::|.]CZqt$=~L`HقsAF%Lo Vg۲(Q#8?ͣ17th~՝o<|)OSNikW?M7څ<Ż`nUz'8PcQ: G;2Gʵt#W ,9v_q}c~Zx}ۊ_bd6ҶsҲ'm/wC;*irý&n t=Ge^/'B.]UY9bRڗmEǯ[d}CWVG4g2oGhĚ歔o;~Ec֛>8Sկ9JOg'F CځK ݯȾI}[/کm6^}X佢Q.I?)so'|B[hñ[,Cp.u@?gD{J?b)H_ :6C\SMq@eKQ7E_R}ϛ%)D%ѯ.4M}__ɐi6P~pnLxٗSޛ.ioٴ NzFƬD7C{ݎإygFxVSGQp@:/^z)C *Mx]n7G_k'& kKEv{E푟Y ,F?fD!]:@K*RYڇUtY-L@|6$~<6|)pR>f"~Ӿ!>0?"Lήt?k1SXޮmo0W?&.ѿ$")I6^%/Ԕ+χW=|_2^7K)*rTDm«>pqwy ~z.%Mَ+sk;~1>7?Ǡ=' 0l)eK`b{8sΣN=jt }~Tƀ.)?X8y2(Y868/~|^݉;ğuoߤ}^{{E{&6[mw\ԦsbW6oy=v"+ zZ8u@?+{ u" |,̿tH~)[4 rK9Cg|߁!̃"Za)D}p+'; ܛF =Qޭ2 oޅ X7•r H?>|MpwpCrclr? _d}ي֟ןqg;/EhīPoeSƇyݭucu`9E hSmHTs]p7K{ƯQ~ioK6Zԍ˧vsO 1m/g64&]H=L_XP^a ؙO$gVoxdë`-^=? !/1R< $K(>Tɿ|_!XiuC*k5N:#a(6|E+?ugfT^Kr7K9Çt(tBZџ?>!8>n7Wwd}8Tš<=A&ʏ=\U\RΟwq_r8^e js9Jv=~7Hځ$?uyܰ bY-+{_4z .|<0of@)iO>sBF"|4]J|ד  1<)PfשoxsGi}rsy:pgL'{hs󬛒 lE2~k΍lQ[]r +8|R|BSr]gpZxN,:BWa ?aqs@ҏj-l$չw'kŧn\ q}u; qi8_؁Dz\Iu% 'v::C̦ⅺuT1 r v /yJ/ױ9SΤt Ώڙ\8Mr| xz[%EP HLC5'| [yXV?P"o6b #n֩_?1V#ד;@y K̿ʹk۹(7و{x~q0$xpM}!.F8r_T}S [p~Zv#K-O[4}zؖ?U:acрY/xsA$gFU}-2 E{[7|Ao.hZR >ﲕe>KUKhi]:ިX|^},N~zMijN2sNe _ju vQ?'W n}hk7b)WEd!϶4P qxc9^[ߏ>ҭ1Ҭsǚ 6e5?aUm>/mP:Ęc+п8f_ڌVDW~>!!޿#>/Eb@?GAPѝ7ʗ 9Ax'ʽ0`f]QHgZmƻ[v?K[8_DuOivӡ+ZrnpڷV}K#xA RǬ w= W1Q95O`'CqwufN^_7v5ǝ"?NH7&QR_)i>^vw'.ET*P>F ޕYޫSpʅGH^_U Kkd]s "{ מfc!GAR>&Gh*.'vD&"ҿjYڶi0oU|97=:N<5`ߗ/qx50$$S s0pDQ\z)-lg _v٠͈d qav>v"w}moބ/Ǐ~Tď€#ړHaN{%x;6v~h~{4u%7c+.wǠ2ZP@Jo&￠Tec/^7iL\GCW@0kuF2(!r[#3= w5 S]kxnto6rcN7P);;ځnu^V~6G>3?syqWgRKIrcyJC?= T1iG-3R}f0W6%vft7A\UiXmq};<\hnzZd9[\wYNGt[?|oQ qeES"_{ʩr SVs\2sAa{lS Wi7)ק%꛸2}E;WI߻)[y3%gԻ)zIyUE/:ܣyh 3&#Ryi.Hco|= caTv0}3ԙ-gMYHQU;Mnu{Úp^c/ n?dǼ\FU; IA6aH[B;Џ*0: ~ _:|Z㑗kV q'o yU._яWmYM!6J\/m\nۆN 8ێϋl.&~Y}ؒz'0UVv߅9j8;pQ.4ځqʳ|0?Mu@OڇxeW .3@{u\}2% Y+E\t>~qFcx9|s҉8w)3F\~&kE}Om+>CvkՏr-C|j_A|gkno<ډvwnA0fo^Dq})ƨ% =*cs R"^i~X $uB綵=ߗS{Nϯ5f\r]q}zr 8%m0Y_rV=#'] $Nws极>3<-/CڹA<[Н_ߨ;N13£[p70g~WZ?.<wLj#sTǫϝ|O\< iA1n)N5~׆Cizt>_О%<>`?BޱΞsy **`e2`Ax6,&AYǣNeW`X"Gܲ5ŔWE8eq^";ڗ&Xm ..}hpЏtݟp0_o/QnJ}5'߶2U ݷ赶ohp\У^r׵WXx[cg7~YO3CRnX0guF8 79^=Cޭ~T ٔ9.~o^x}]Krqѽ+>doC;w "Gl7\/W˺W~2C|1TKvKmZ .qI3 TQ;|2뽍{ƂxP6'JCg4پMn1b˄>^]P|㐗7|z!bgwc"[;ZpB}}L4ơUdi`+>6rz"ڋֈ?ih}fe(^ŝ!μȔn ~oGj?uN'wR}b8cuJs73|Ogwnݢ0Ql.|[p{R>w{"`r(ꧾaSAjw:ɥGއ`hWq]4K}*m&^f#1(~?+Gg&WTtEREO!az( Ėi~2ݕ*._`zhl^hwn^-~Q[Mk{ S)ڶ Yf|ӲwT_]ݾC$z.wKS4w:rWy& 2v奸[7Q}`}_ms8^n~]|?C^d 3XJ{8e(}G೫B`Eλ}b o72h.ՠ_S\tM1;3kO.8g^Yz7:|9~nV'#6.Y$m35 9C~yɋwx[@ئ,D﨏zgm~{ QHǙ?![e]D+%z:K^ $B!s۔z ;rw ڡۛA2h4/һYԿ4lPG`H*fm^ڧz{w)xcǓ}~ۑ+Kwv"Wbn⏼t/Qʫߖw8Y~tϞ_~ x0}؍`>uw,oC^6x?cݓ--!x581?>zDyEv[EuЫE}OI#C'SU;G3^dM {u%n^ɿexEQSө..6m0"r|^Ĵ@"B^zw$ z4.\hR1)]O#tl+<@ƀԷl8E?aj4vpyw\C;0\N~"Ke7q]qjֻ |SÔQ_7]ZGgIq3v^b{"J1T9_B7JT)y!{9m.7ˤq.)+ Fo_ѡ9'p\n'wA|{OuG=q}oaEG¼B9q?)$ |;{T6Bb]z5cݝOTȹz?JsB\u*p-6w=#3Wnc}y~is]/YEr3HS}C=Q3,ɛV{xUo(!oU!,2r&R}7B4$xC˛ |9v%h/IŜo:6hP>0?N*NQMuaS&\fiDD;߹`5כ9`35B=xp}ѻys?6^U?>+B~֊aM nzŨ,[b7 B9ᴼmgy(ZEk'ˣ8e_Nr<ca38/ݸ/M[(#'\Dy.7s?W50ߣ 8)goA8o~u'H~|䋻AApGD{Ihg OsrxCh4X<@~"\]8:;ks?6$ݿ]GB\WĚAҳ6zz(?δI(Mk|#GNpoG~9W`if,Fr`#)>LP+?MyO=(]TsE] pMCBlF#B 6tGfG(o:pm@= ro5F|`r';=_Q r6OP䔢)`3nkx77lcLcg`,p?ein3^.gzpMF/5p^.9w' *Dy `c{Guޯ磊u $uX_@x̕=vf`~!{>tc;^_vhj|#Y# {4x#2.H@3( .JrƝ+ eqIj|`J)UE(pMٔOzUh`*bg 2#*¿Nz/zjcD}M s)Xozy);<:8Zi6˫Lpn.FT~A}VKXm؃bG @vm`SeTpB\lq\hF˯)h͏3/>X,?iOUS Z҆ <%^{Kѿukv_y@Ar}뚭@}ިr_=v0 s]Po:FSz23⧝(n:"OC/#l3%Ɠ"Ə+QEUf\_g0#tL1+7,ߤ=ǣ4ݺB8b\7lkoMW}G%C:aУ~'A58CepP> zXu l\} t ]׀2=8:!F:S~&kQޒmn{0+⊦pnidBbm~myF{#~e Zq&SшS5qZU9s+cTV'0qLf phne+13l-WU2 98K/G헜8`rʀW *_\aMy/n+hoeF}m)ޗ{fʏ?]KP@~3 <Ƒ/3zkkվ&[vDqec)+KqaLg6S[WnΜ6v[{)?E|D#گ80+Ң6!_$}zrST3KJziA(/@rCkb̭kAp!6L=`Jn# y/wN817a~JH|6p d9qVQ}eb 50O z-K5U >i 4a#=QO1(N?y_-E~ljC|.G'p+'~W*f`8rӒ A2MK';8u-P B:wm2/@}!O_˅G1v_y#e@ ?~/MK:HqSȯ g:{YF}r]{^Ð}C)+N.⿪s阇>wS<<1`3Q]잹pw@~"nq(<$u"g'ux}>O&;(_{ڵYs!ַm@Tb1d8WմzlX(%p:^_ χ,KFޣz$XOŁi8δK.kf f.piWPG{Ag@ T'?P_ ?xp㦅/PTJ)yJ[|.\mvrD6dO?T}P~RxrP,[>9:\/;8!7K|CԇK<7S~Ŕ$zb|!}y9a <{v-S4)CެLǗ6HkcN&֒zԴY UIx&Ӧ/4}40z>)Df;.[pkX Ü4UɫRץRͨ,M8NeepD1i-e@/wxJ^g:gyԶqB? ~s`q=98y%# %8.џf-#ēIv>7Ϧ nJG|Ka@W>8HzE຺JS|'paCmV^xړ[%/Q{POkO貝=ތfQ^_Ÿ].oF&teC0(>B/?tr/O?'gr2Q>H^1Iwv[@ .[~K^=F|4>U\䙆@8/7Ľ[_ B{b:ysQ9륬 ?NK.4@KSee~ۿ/Go 7|_ڪHJ#|Cu7(cK<t8N0yV7o+WA7^&+6 6"r=6s~Y+;E}55n/Gf=%į追>ǣpB;چ|Tovq~l1~ޭ< < u,8?7M6jܔs}FU,Gq Q"tkV8@v~YS.7GmMuo؞^z}f`9YymDpp^Y|8/9Emex`sfӒՔWz Op*וJI68R)x擩`=7\8 ӈOz]ݨ2\O/MIsu̢im2 #.:Dm~벭_s7 ſg W2e|bkP nj&&AԴ0\!mI~!fW㪽?M]6wC-m 3] XO ݝ vV8 ω̱¸C3Dy"}B9y >뢜Pm-v ༮WVaD|WүF?yqβ 徦)!>m_;cp|#iA}Q~ ]Os&:Χ׭jT>e,Nkwֿ/U7}. OAtxx/剑')G7E~E)o_d<@9~]>w'|c^s~; ě9+Rd,ơ 8^SosCq|Еjʿo4pp~)-l7IفTz9OM_ _fӭG>>f t`rY59`!t9 :Vp|DXCe^t3e8~5C8śMo{A2aOgGF^TҼ);DWƎuת%)Y۹Ecm9$Կ}ƽyz*'Ewch3 nG@Wk'̘Ǎ\$s\'!XrP~5XE|gzί] ]C֠ҿk̿yYٯ~{%'\.7͝kvӾ.Ws^eg`8ڼ+?[M_M3Ɏ;m\:ݪCZa~T"#et; qS`V)hƵ~ōvYca빫?KAl:AgΘ?4t [}8+kN;5}f)7-7n[% ?8ń|8U(?O ˿ x]<{cb=3鐜~Ipfh!ʏW>'ڟ;sӈO O'E=2\]8]ũʟP/LCق$= шew|^V~{nu˿s۟]K sL;|x/M휭?gc>=6 8NgRDkR:隷۞c)(;Ca0vBO+Ʊ3˃[SPž/OlZCVE0IE`?= i;? y }jgO+?ڪ~_ R~=G޿Pzc<|^q8߯:gpYy?Cex X` \loӧ?8׭G,\Q>}[)8_Wҽe{֫QB`$A8ed` >?e?+zf!ؘm3Z>v޼68?y|늛bhmwOmsu'~n/}+>N}s6y?1kkdYtjkc?Sk)טtBr$z^CsKtoOX~-X!r3G\{L;?B/KqAO?=Xٙcڷ#\9}uM柠1 1˖۾*9ԵLI|5 xlU+YmA;,B;W}4T7xQt>6#Yǽ݊(0҉WP ^Ax$OMxX,SO(r Y\?ހ̱[b?by+G@42qVmR#wtFcC*4v;((Q]bB?c(~_vתHJTEb嗭<"TO߫&ܓZXA8>Ŕ;.4Wʻp=!#s͉CMߎTRulڿ̝N pI7GO䕜s#b@-%r~OU)B\vP`/WDư֮sP^''r}^w.ۼw %9Zns:ذ?/5C?\b,g:?}A,H'@.h+G9z0t~Hrݠ]WS/wʟ3~O%kIݔ[zq*ĪݞߋXh_=[҇fl9 hoi߯uQo'5):;ݲ^u9LZ]v?VUt,_%H53w\]V ۮ-d?*er;e9'f,qC%/Ğ:;4XoVTkFcs11]]7NM~@kgךc`2՟NJrߌ ;8yѾmq0vć;h`*W4SWD~կQ; SG7h6cO@(Ẉ?b]N=!{/Zyw\oŋ%/.}H⚒}ijy8Ƿ͔_v ݜ눿jo-}P!]SGd {e ?lP+G`\ H^YYODt.:q`[N{ Q֢q@=o9C3nMXv6Q:F~Eۀ*hR2-՛!nf(ݿʘ?ym>_c|iq>k++p6,CqC{O2!|03Om/KW{LS>ޥ:`vAhϨ:pS#)=ĺ/Qҭ/W/u;;WZ8$*>,z9u,uVuꬷ6o ǭLcG7٣:KN7W덴Ker8(OA\v]BA=[Fz% xWNW ~ltv$W.~a1 O,d`39"+r/A\qGj o/75G~.(<vYS Oۧ8A7Z@5CDgzפE. mwvѹ/_Q26- BJ5~'1y)qmwyY_BQ|^γk"m-9u}G{mEqovfXdcH쫡 qz FT;\k䱊!c~+8Z.flKuU#[P~ZJO?CqGC/ݛd|Me5)p@pU˾o׏x,V/y 9).7{9;7 _,7H{gԱ]mʯl@}w/Y+BY1V?=a2ǓW5=^ F>Xrsl`_˒̑)8vA|S:<:c~I14PY2.գpdb(nSklzbX޻QwXw=lW+AyPvxF 'GOv!M`%ڟn>H~<޿Z 婏צY9xo/d)m:}`Yb)G45]o67,S#6(-!å֑|GȓtXs_ب?bc$5P};Xe(/q6>1Qo?Tغ +Euf7"ЇoW>Ɯ tMtD#iop+>^ [] sFήglyO^}^Gx1~Wl}_8>E/OE~顨{1#Es[^w;? u >7!]QUat.QIiK?sM= '-QITWٶz-;.c8 )y0L_`%y_$\?Sotw"o$IéRyWXl6.F׉h_dٚwUF|&~&5Cߩ{jp?kVG77Zoޙ(s @J:oAgUN3_ãK?qܪFA^q-ŗz-i\Dܕ aZqN imf[~(3P͏ϫF89WQ$C9%G-W?l?yTwڪ~Wi_hK>R;@ξ37G zNyC?_NnXƨGA~⹔I b87>y×Ҿ1?8pUQ7&݂Q3?Χ.%헮IcPԟIj\heƆ#nO{d)RQ~m־շi͈]7/_4vNp`U4I~EXڱHc392>&v=y&]Ws= p?دfPPo%hʻS? MpN9~Qφ}L_,\aq9`5ވ#ڸ}t~9Z}!}.H$P_@=ꉢCFWWpA x+~ڧ.uj{ q]__;<VY.kqEPW_z^e(}>1ݱIOUdIIi&(x5X]ٟrWP>C?xX:LdjC1{̿J~^}x0wk`w }Z-0/5ڟ{̈́S ŜHOG{6Ӓ0:9]M$t0 Q:aI?Yշ&[ڏ!#,[R>+^ܟ~Lްq:&}}{Z ;w8~(3:?`.?E[ϫG(/Ź ~s|~Ͻ`'$/I0Iɺ-Gd!s:hsOjGs7_]%o&Wx%Oƌ7)?_45'[tf[⇉열Ƃ݂|U47z_v_)*䂸0 8TEDTй , ٔ;mXÃ}s{mUo87ֲ'X?@2i"~xU7r?F88ݤ=mٮB%v嬙j)XU^e[硾)#|6NW$+?מv 8/D/ѹ2 -5\ju)_q/й>gB,0ډǩmoVZ/-G%֭,NW-|t~ eS}zO䓺UE an}MSeӛ{ycK]Z黎n4,Q"~:~t?!7 %bU~M7|O`St5yUSY p DӿeAGZ#qK+t~|}?1Qd<1{ Ňyn9 շ;Zvnkݛ+{(~c6w+o0:AByC>7:xѬ,wP>`3o2R%&sWwz?.߭h܇:lgEP$꟨ZO#`zWw6/d _r!p)p̳|uJ횔Y>vp998x>.49 ?m!p?l,:/E3ODs 1Oќ˞1bSH; ل$,Ϥ3_˯/lo toCmiPH޸=;soKN:5í( 0/ O#ѽ 2G1._l 'k q}8|`S'Wj^Uo/OM>htK?_c}ж~Sv8!}גHE :˻::q G 3{Svj [FW0ƮH\~وj8Elʢ8ZyݬvgD|uX . 7SV[κ75jO_=}V!~U!yn5p?]u14=N|4TmkPt2l[ ]f{N8 (OrÊE/@"^rG~c9ꇲ!g{wyZqܸg<7 IkT5⛛J>ѩ aB0(5KK^j$x)!rJ?ϻ ~U5xvﶃco@?=|j.YQSVk iF[ [ya\.'M'}SN_eO`76G='s_$$z mz}GE/&,yӢ:.!A46_igU7Y9KNCϝrm;$XuiZ4p;90rT,c|{l1lN=8EP oK0 ?eY;:~-',Z~RwN74#xXMkzS{ވ̶n_ Bwt@27pL<yPDnC>1 ,c1;j̣> /-Yޞ ë6Uh Zͨ)]K磟e G>fS濭›FUWB?qLcwp>%oD1~X;/Fd?Yy6 6Iu[,)(lK 'j3}>(`\o\YdBzmLJ{Y=MbnB,sK`3#xװeYo^w zqc{_8ܴn !NPOc@:_KO!) !TKu{ XA?]mj lR-Es=ڏS7\kCԮяvU O4=q%˴~l3X;q7⺸ns@/￦5z)WYqϻZ+"gƬ?8]Cv(wX~rQ>\g\47}[v<513^u8Z̏ 半q޹*q֐qҽv`])C<`z\ȿǣ*6$7h}AAi|;zxDwN{D?850U/Q5ȏݹ9*|#0/wyyw6߫瘗7E8rOf]xpHׇ{#Y~I>4wgxL.q%lÒ[-);jq!f?77l+!_]? VU{-`yb\Kƻ#V_v1Wg[*'1Z~#^&'#n^PSz+5wy(ϘwWwY˶Ek;}/ݲc@EwNwטDٷ{5yL< M#~ؙF}))N99 Ze:UXA{G?8@;77q>mcg.u|`Ͻl/9{Ox_ qc!⾚~.:xd?S|b̈́tG̠[Il'Ƽl_@tg9`(C Ǝz_@2>};iq 3GK.pܼfJ%|aqh$(MyB+}'^ |MAfNSypoOFՇ򆠞“`5'9uBIa hjשr!Y?nmߣO׎8`&N'Oi?\:>Rˏ(X}j{x񣠅TwO7aX?8y9UĒ糯u;zOѿSyՊ1Ol9j݊r$A7ӍlҴK2@`Υ}u3|xdj}@8I%WwnWŽ4RB} ]3#*#w]pʠAtBӀ+\&%}G.l;hfƒV?_p{m G\ o}9t6La|6ݾA .ݢ7a:'l7kdsْqTQɎ>IǣqX}I6KCw/ڲGϦ_&9Q4᮹(cs- ߦ!ks>ݜ}h#3ÅC )?s'Vvq_!o}&lׅZ @0t4_芸+~_=zrkV[hwG1ȳms/!>jn8 xGK~kQ:_Py-wΉ{W;x~!^ZxRt5@xn*$.N3kώxPԼ{AL|pݷuqW%8q jAfqzuAѥ=o7l.;-ނ~L(+X(%?PQ}/`//g֕7EڥPHO T7ǵRuY0'rWP2f9VP}Wwնau ͚_T9+z1)s&SQg϶~Q N/^5 ,;-u웢* _wKyw;tƕ~m'CW"Ҡq7|[]0}wC.ُ;kG*<!.[~[!oVN]CuȹN250#%&3Nx)1 px.!~)O9IB|AوikQ\ ߫6oT ux{xxJWm4F/ڧbfg @q_Otߵ3ONr"|jhJ%0gD0t㯢C&@^4]p~/J]'C )?s.YEqkKp$ݟ%_֜O݌hIAWq܄kTr6Tǘ5okxND!zgpjˉe@r{IWٳ_DR=1bi8킳@`9sԥ}5WḥcFlbf_c .(%OW&W8ƭf-W9b?fPCS~w~tt3zrăkQ0!#yF}pxgݱw:\wلM|i ]-[ 'h[/5⡰کΡh~ϻӀaT?i/@կ-\$נ*"vX!y`|}c#8\ NCr  AZ _󔭯s O 5ւT>Ѝ^+u8?mV\o¹ϸ18^Nvw·;Pvˁ Go0MOwo ,<$C;'#g>x&YSv*zvk?Nd߃NP~Eza햦_hJD vd0|PΰWܺA9_hΡ&^D}(NMi~4MQss0UY>I*WAyzǡ[y>OvN~eMgiV|~z-j`cPA 㞏Gwg#(?LQ_4Ϸ] 79?\QA\L.[x ˧>z?` ( K{`~Mr`_Š T ?Y[zHLm<0np 9T-y>L`V:_96%1?d7g8XG̿)7f<-,Kq}Kw7sMYwlS+ˍq(~}zݺ -W} ̧!x +췀)3~#ܪP,Z?b͉֥UO鋥?ؙ_2{#>hF_soiBR[hEm vBy~iMTGT&u9/xJ饍jɁayx OlfK]^X]`߻oAo~+[yXUo;3 Qqͮ~ݕ ;!{ -iƢfLCH.}Z/im /wW8 qė)M`Fy;1n*+lޕQEkergo}/\ ?F1.Q]O(GP 29mn=BCFMq2]ۮL{zзU9f;٤Pe|.m\;HcWf(yM!h;/P 7.g]t@􄠝7WA_Sٸ ' GKZq56|(?ݍwjJ}_P{u!aϑVYoʢͨ?/0?t18Y^AQ41)st2^kw~vE?{yIIQ&s( I(OsJz14]KuW? OKwoJw ^vsu}"tfWp&%8Oi8~׳6nc(o=7#|0DyVttjz Wu3'f9{-Ӽl8MeHE|ROYb.|h ^1?>Z @65}wHË)+ϯs˨^<EH,˹*ʌgNEVVVBȊDdeE3 Q$+BdD">~{|ϸ%/yZ]s>QˏjF竱 [߆:nDɻk[NWZwRnӨ,si X+h"eҌ:7 (?!űMw՞g"_5Fl}k_4W$;ɾ~7,Dp.װ52yzHs ]BT̗KUKPWMo^8otΚ@qȡel&x!sGR91 dWX?Gj('vR/ ?+i@?ʣUNVXQ!(w/9Y_?Ѭ"Vs&߫Fo|t-<pq=^kS~i?XItw=`T|#`~ڏ̳v"#ǎ lBPo^Pn.#݇v-J؟ME]Nˇ}j5doQz!9Oq gԏ]xN<gTu1⅏uu;p6ν8=܏>vѿmuK ?Øtʐ]¨ً>;7sAw3`lDq-HƼvvƭf=_V1&gobdA8=+t*6P3x=Au% ;؏4[CD"/v*4,N9{ nm wۆQ $#I?:Up}uW}_Qpg?`ˠ'gs\wazl9wPO3oM d;L3tbe-z/ʅWpU5GO4/S(/\: ĿKw,KΎp}I??\xjW꫾׹O΍1h_&$1ڭ{nwQW{~qxxx?kq o`F/6#7 ^^/I_k?ᱩs7Y;cl '}z]u"Yq 75WK~npxoy8>LߪFyԈ,M17p7lFUJ\D=g)[?62ŅܸՇ/g hwѼUT|LJOkH[~nF6錳]>9ր6,oF\RoN4$h<0ۥQ`hgHi8{]=sp'z̥?.^Ie/OySq.O;u|sOl'~&;>1y?f̳b|3] H58t\[p[dqSˈ'Ù8u''Uu;/op/MY!3l9\TO1ŚGmq7?*]R~{XJ)'TM9 QDNN#'5n| ,DP, I8ZV}FҾYg4<<@ft_&=ޭuJ;uvb+[# Vrĺ~{x n)C=ӗZMS7x[y/rJ)C-wc1!CpI䅇ց1/:߀s8w*h4>c7Sߴz.0,/llIPQߑe`6|;3W̯k]9@dߴ;<8sCpe-E5R_`'_0.7>L|=D@\oO3"Ƈ׍7کy-jwNQެMUȃ픏qr.X g+yY#M/_-ԕƧB}5݉:PZV`Q~=@Jc.\(ߟ|yoJvV3gNԼY ljĸ3bϟ(Y_Ǖoz 85Wh~~F9$S[D0#N{sv`;]ҏG} m^rߦyt^{f/}p/5]\אsV= qZ ݼ|+<"!68R?_ 3`gqٱ9 qA-|'Y2B?h}'ށſި?o4Q!?S pjaGysnjxGq}h%8HK_B#)ncG8 oF2+WG>}ԸyK«NanߏNJF2@DW䂽Tw>}< [h4˩O~c.ٯsq aYW3 O3/E|5inI~T]2o=;@M!+}?`>tXUp+}ig/~\W+cӐ oߤFQT{+j [dDR!Os Xh3buzT¦3Abr&_>O9HݯuYe;3ڢVBml^3`g/mXh/̙wTl9)ҵ~@ }ǠA:T,LD򲭹v>*7'! In}֎P'a'^ }]dOBʢ+$`8>f9ڡ䄅Կ]}o+^kBXGSZw]~a<)f dp>'{Szv Ɓa{9}cQ>AWfΙ{F3y1M+u1ltD;GmT~y7\1/7qSv⡢l3xsE"?STYlOWp./GUaP/)Oў0s 1npiPdpO"y?ՍVm S=r+[>!RxLh8^:db)jwC{4J~B(OmnϱpܬΡ4~~*͓OvnxpnE(g1Q~66⼖}!x|opxÚ9C m8fo] ;SqHd%ݣ=֌5ipWQP.ѯ'x]W_Cި>~i GEGQXo\f ;Hܷio7WkP߼ϖO^]HƺrT`(:*XJ' DP|#i B?/34G"*qg K|e(o=o -Y"`)>OyјW .~KU;|h^p=DUgt[cA3r+.#.ǸUqh4՟ko~.\;[g*#?W~CfqW6Pɕ؈Wނ О|a~amXWk_3ڿ`o1ח:Vlk _ПVv@?$|+[5=jV[~&&o'yQ;R @aDȏUI0~fe]qS2+ڻZa2L 1%Fz韲D#V?t0¨~^g 8wQϵ,8}4ڱ:G{*K1K)E͡su9 *BNSd7bL~ ݨ.fՊNwlVޢshŕstnՐp(-|nd0ſoNNDW8垤|suv^uOwG7><;*!'m1p;+QiQt,?Ո8vy|v~ [0w8گ:x*m(pouE|p4Mcn{ wF~ ݃Kv5()#6E{t)CeQIOÂ@2QEyW} }}&fFkDOPx\ >_\kx-XO Rk2_3M?^/AyTjH㐗(N4:,w&kWk{vlv5'wd#.Ɇ$z+pyiةw_U:TWh`'$+#tA9T8ekՖΛ-\z)?y"eЋ?"l?euTߺ2Ovldv83/ilsMj'w`#nT`=to\ E t$t;YBW\F%ǿOEaڃVO:_RsH_]BV36磷GpWol>[Sv?5Rl`\/Ei]>sytB{$&7,ٌ*}bCuIs/|;rH鯲㧦 4?B*bOJͦSR0\̿~S_<& )D CߥXW/oTq 3-_8:l!+/hV!XCC+왳}`K]b߳_;zؾ_`|)硵lkXS 8{!aGx8X6XF {1}diG_/X5P<̃>6n.TeF1aȁc1qC[eܞy[wr@ڿۮ/\d~h ZfP~7*bEu*Yz&5Or wˮP~. YC+oc`5(sMOпdrŜǒ.R3(.QnIq _k h<~w裩mwoBoox>36,'{P@Up|y(ěNe :Ly=ċT p >>8_}??fzo0;dwkpܞϟjۛ(Nh'|;ģUo=kq޽!L^+NmG]:{Í fԣz-ŧTWʣW9+:>UPgA(Oo:A8y/pnNſɞ?~^EIrf ]މ{j V_p~N7]bUu$/\SJ~\ZY1~#D]O{~ta_ڃ8 _֣XWPf@U 7$}ˢjfAcoVjvM߻rkaIm۰8?w@ɉΟ?>h;=|h{%hzł8~ XhrR&=ݿjW}&F~Ʃwylg߂>T'r\l^q~z^~}Hο }ٕ8_eǫ}Dqׄ;Z?KDB8uEv}坜\+əTŒxq ?א<ޱ'6_V  ί,siPqR*گ>vFFͧNuuݠџG}"ʗ7WzhGq- )e{~:NDmgp=+wXr72(XzΙLg?m|o8.+kbV8 [ n<)Xm6cYz{8 9z!%h؊UIyU1=j@C%>?GQMСkOdKߣ:mɿ1]UKw g䨒]x~=&}:A?D>}ñc{ J?l\)_Gܔj~?/~ k[Br?-j J]qG[ ,$Oܟ'Կz(o;VQ",|?no9Y֓zFw3fq:;hn3v6A>5;my k^uw~.7mTŏyvi`+Zoˏ۽Dyc\'i+5ԋW_i|ga܃6pp$~SWDլ(97}pHNHU_ȿ߼g p= \)ouR ̿t[ sG ԧ[W'vᦢ+%w> =mQ~p[yK .2p[<-|}-)O{%v%X\q(gkI6snJuq7~m '1AK_;f$oTw)e%"~d.\=$ݖ{f&E~)htǩKw&t ޢ&=;"'p,G~kzK8q_YX͔5#ac[nh߬tčTΙ+`607Q~Q~kd3y[9 흛"O,t>*R>]%u8귃#;ǥy5#N;:cNT%C}O˳V~tMٍ[f k}fr"`GQ#4_'MZlBG>E` }k-܀[/4qO ~Ww tv6&Jzm蟙oh@??}cl?mRj\.W}N2e[`ϟK4eT>1 XI1gR~;UQ}364Ы:7ʝsq:di_;_}>dkoƸJS` s?yя=Ɏx?=iF}+^ w8?,עes7AO?J|V=H8M  ٔyslA$/E}ؽ}Sťٔ`8l~v;WgDՍG'o<?DY_*}b6?o"_lp>F;7)g{7x#n%|YYzCHzoşmp]QװT'L@ GLu]LF_Ev^ƴC" \pMcFG^ǸG3/O&..Pv{EE1E-uP?oh k:!$/<%l%|49b} ǻ vq~ ͪ*gpXp0_yL2ca6h9I$3n$UMh/@ u~[cM-,#n }T6/E;W7&./S'j{c/yT'*Q#M=:MAͰP_A{]фΐ!qOwr#ގV\]Xk? ~oz$oCZ?ļ,c;6۵=e$>>㿎p!>R2.sAcfB} uW,#`bFy^vS~J9޹ m mݥ{Ͱ.֦̩8~l&ϣߧ{To>6[q~Ee]KM@H~r-v*B{6uK~ "!l2́oBo<=jsk̮rUמEy8(p[NY ޤp?|%=xT@*u$~ 귆TރdADS(#y2p۲7tM8ߧ]Ip8O,fRCsw/y+oTⅷqt:MWW-u*wv`z; .N: e^}߁3F_(~Bᯟc8Dqf k)+U8yYG9*-A=PZSS`=%\i|p785ٜf?Z hu6,to|2zgaSe hFrٸ3x] BM>NҮd>dquyğ$t=Mѯ3xVxاD8ܘK<-AyNvyvf"ɍ~B}Wu3p"DSo(ܱzוA`;X\8)|n0jw'"?;NmKO_Qe o}GF`-wiGѧȿϵBx5xkpH\Guc**UGp 8/~1̀>uwjDvG?};[/ծX1)ԟc!⓪؉?@<sXq*O}m>%n^fUϫ$O)~cĿ v0Ϛiq?x6OOYiw~'~{6BӌD| qLC{2GVNgv FT;+^1o3OR?˶-1ˣ˘ 2ƂT'rl[`Uoha7E17Ps-GH >v`|Nzz}Gpj7[ew\# Sv*~%3ڗX.8iz=FSNSo4Ĭܾ}߬7qCofkwGaO|_az6>O_(9Hڋ!=y75Cˮ:/i!gn;@եw"!> gQ@/D{uE+޼dY{/4X3?sم/t 2ڟ}>`}Ew}џ򾎺؏ȾjEh{ 9v~z힭G4Pixź$/cڃ$?Emq] p9-\K\iUc?#~\RMٴHӋ4WQdQ9EowqCPy3;j>rz _e?*NOxy̅p4[`^{Buň#ǞPaBNΚJ56 &=~Q~ [fsW`hZJG?s}wgkV`5cYyN4Hw{fp}De~'pGL˾t,+>7E3wũnϘorwi%7XK~ 71{6[1r(WG冃mXd_qHO1xV2`~:5;ߑo=XrOΘWkOմ@rڇ>ei_w%s}@5_[؛q]x-UYuv|{5tu:!nF{E5ohqk4Ņ[$AWۉ3vh>n<{C_5[SA ľ4Q)㌇cTTWujmAc?GSg[Ų9I*kL@p[f?7/[׳Ѷ;j Ǧc~Bu`9]@<>%}҉/^EZPIy[ar7OߵF3^Y%bA>y(oE #Aؐ'0Fhr~[^;:<ƾG-.4[zh*ar:#A}3z3w(U|>O[uBt_d kt9(?gouw7ErO̓+6Ji#Cn뀃P_י93O5gdשAhi_rnM ;겪F?o/SOgizXdjqJy~G(i8bTZ@1W\pE>_ sVZǼxulpVH1uʠmէ,MITVټz=őBxk)Wmy_jH/tu*b^T>{[-JV\S]k{Z I{я?n_|OW5]y.ooFR|ݽ Dsݶ o(?Rkѥ3շ͖l] ID{0^.jrJA`we[ƅ٘y4"WH%oUhwv:ڟibm${g~{bE }tp$S{uyʣ?5&ZߡrfQ sɭv`q~A祻wk KKwLgwC~[/ $O8_i_H#Jp+cYԿ)f#+)C V&Hf-qs~>/O݁)p F^[yjdKC䢘9cak3 kFmփHfuj~G;uaϻ)fvp}dHBƩ|慸Ϲ;wfne X)2Q`2-E\Pvۑ>IR:HFuwa8 M 6t>rզ;<]sݤWc !c[g"c&/|,'g- ӰFl*k}Ld?̨7ןgi ?ۃhR|{MYKѸ^gGy;VKd_pז+P5:_٬(κ\p8@n9Kf肾h&K w^SN>b!_}q8/E}3]U~*綟y'sAGiMo._}Gqy1ȗ C{ I}Xf&?f|'Ok;p`/۝=sVZw\6SCy/ Oz [־I#ڭMgyp|/\-Yf_BL>?\Og0/ίD4/I,> ~hgytf BߐшKO[grtwDTK3o |og`sK7ӷҜl зl١]8 F_:ڍ4z-bџG~3;!mxe`33ڟag#+YuN͹$uI&-G^EݶTt41mW\gYX@\QD J=Kg>2EkҀa& /̤߫zxLYxpx|joooݫg3ur&/oO MH4MQ/<ƽ^v*T?WaWhL;R[wctzOb3ĘDTCQN y|n&G7)@qrYn[zyx/ƼWs4~#nba;g' Hu1u8^.xܔ䟸'?L5e>✤gK wxv LCINڷeӨ\30ڇoi| Lc/oa4ʥZyg-=4^6|ymw)G#+at&.ǩt`==9s6Qeˊ%^mԂz/ؿ}L v$ 2COUyShhQBΎ dT30<5cٯaƀcL&'Qi׊)5bѼ%Y#;UCK8â[3uƌ)q^r ońS 5-?RdN]|pX5{ _6 mK(7C^ZF>w3z8]DmA(gٛ ̃lu~v}nxk 媂 9cdW0LO`}F18( zD\!Guڑ5s ~?őߔ۰|$yp* ?\x._4k9VrԴ1~8oC7~"Ib_M4W>7~#O]P[_6?LRǁKɰas]ä5j=NOkn^̢Usп7Y~q?4b}Ki؝2.KBO 5?y؏^G-A^RmX_{E|i<C-[hyj h?ک40^܍'U~V9p'/\G+~L/^B/õ X)xg@Ϭn;z|gP1O_(Ͻs*-PM 0) -zMgVLGӌKzZ7iiv&i6:)E5ޠ>xKy/y8`ܮO[h֍QlVl]L_p86 e5z iUQ~6j%!>W1ĝ!nI<eI;&{\DŽ@҂t.yz{&I!8e;wJˆG={96oϙ_رʖgyJ&bi1|uOYY6vT)_8 ˸12"/x#pţ-[?x$+)82"z*<|Kp^_7iiVTO8q~]X>\oI.7O#KS"0"=W8qjc~`֧G >|Nz8L2ڟJuaL0>8NیsQᛳ_\0ۜK7,ksie'$W^t~KhhzdlN7 éݑ]6|$t{l/ y_iKr;Tțl-aEK֊֣97|z .OIz>qZ>AqnI=o_EyhG+|u'~\b Gg|iO8y>PZ?~/>_} {}.GM'g뫯<IK#|Em5.w!o6ʇqD㧓(?~U ̏V8n~tϧå('ӷKj0CY7-gp|axp$S>8$?Ys'6y ?ې ?O8CNIPoΕΌb-]ԿPwꩬh ENL#?/o79jd;k׽\׮O{ʃ{qs~'~Xw>z\+tNp.A`8Y;W y̙6XO$gu2+TZ_k?/ cjeyh}qӪ9yJ*hCQ޴`_#^qg)ۣ݃~XؕP~B9{UyIkf/Dw:IQ͝<ڦ^tʕ뫢d0K~! `cHde~Uì YﳽEmߨfqJ)ov Nih?(u\T'9D=jF%P3eQ N5_-z̢|\wJ}-ma Ϧ*Ÿ@+ uu}'cS~fBOGoG;_+Fys.%[(ﳫ,`7x Y|\,d3kٔR`;i Ru_Ŀ5UQhWzϧDfl}ҿȭӲso˛OTaR VwS';S7^+ڻa]q1%8:;e>UR/8.FFe5 U}]s9 \[|E=QLl=+O*\ħ[rād%tOr(ܰlC ^{苨o@&|}Ҽ3p;/;bF͙?+~yeEqՈ XͣO8*y!? 7sy?g< g6?:7KWFh+0zI(p8< \m~Dۨ {WRq^ql?Ϲu,$}<&^͒~XIQx+I_jG=;uy?Շc179S#4x,Qū8#ŧ/vt_<|TYSѺ O^.HQݦ>{3>6^^3/c|"xڷ‡Q_[gh*w>9t4"]vy+QYy;Q4/Q ?~΁˯saªzK GrLqEKa0imP^:9 fq];.+F\W dg܁z`>A{2gzWX`~3>ίۍBD܄4>.*?"rO1sC__qW5gGG:Ji O@^ ml>D6SC${N?jk uy~+8YFq1 4gr_ `?_DJuêk->n ,< Wztmo|uݬn\?sͨ?. 2X'Q{sܩܞ5^1^~r_觯 N_[#>1.ǀw(](K8;C]ot޽?wD|K_cѨ] ~ի5S;۹cBaˬ+̦?e/Ey(?m81rh,ŝNi:R`\'f*v(!_m/pm;[zs}(qF V|UގL9w^]s*iP3S. /")_d菙f2䝪 / ,7Q/Ǻ}`ӬsC-2G}U!l AO+9 ߫?b>K]wg0jȗ@(SLJgw#z ڞ^].湜l7x{W6SIu_.Aȿ=֥,,s 63gG:~\qqLmpC(YEc_^'\Nro=ꅬ/9?Y1>H;Fբ-(7s_VK=lVA>LLiIYU׈53鰦;߀:vB8b""G 9'}w{[л*_N/{t3ꗾq"`^9wu/e56}K-_-vG^0)yv!Kj~t>}xy&z¥ ¿gAӂB*W[qyF͡ )|_ܘz#_۴Vɗuiazs(ʗ?<ʯ=bM: [GĿcٻ//X72Z3u]`dފ߷iTVx0dW:"J˜#Ez~"J|-]? gE5qzAtʝYԴ=HNlxn h_ O"p_wpD_;"%, ?QcU.FffQJe`HVo۹WviEVuʨָi&?nc ?:`L+I*:xFӽģ33|ڞ5B'p:ύn.%?jg-Zq?s4k#SRr<5ʇ9ʋv6ːco@}/QR7_7 XiihwwE#qҷӾM7UmSaEB(|_]"ʴPTpv591?V<|z `q0-}Sz5hIVhO%dA=[[,Eb8zocL{~H~G[ݷ m)dz~%nˊ[΁˦n^_'TRaK](t;M49OfӾ+sf}~~L?|ՊhQ{[f 2w;[Q;>IR-J>@.]TέS' @{g<֍ l`[ -8nnXf_ QMm$L)d7N=vսQ_tE"ޭtmeoEo=cFyȦn9w% 8#⑨ +}yO8x9'~C~~@Ut|#p ޛ>Oxvݓ[,| ܆f"? vP[6ޞeU (~N/+f<lnrSl> ͞L`?K~RxSufK8Gek~_~7qlΑ%_Ƹ=yv`wG /]1n 0 v!O7;~ f^ susgqUITvM+$.c~Wy8>P؃ߗWPy6eXf@`1߹SQhwpj_g}>#;n4BHoBp3M#᫑nmE>a"VP,Ҍ?7$~xCo~*@k#Lݨ?sֽƕ1ϵۤ˘?[yylvU2.wYMKm3p\++w} ܰ-mE s1|N7S)p]#mDK. ^H)c3ڇr{;n_Ѽ30k>;ӹZGCȳrXV 0[P{q*ј8kws'e|XcWEU)A?WvV',ܷhk1R:Eɷ]Ȅq,tW< 6WtO%{BaS.:YsuWo+mྸ<1Hx*^Cpڿ:l@]E_VF4s<=886 A#sJEy^ IthOQ)gϥufITohl;Qhi8gQ57nAڟx"Vz~5ިY_]mYV\j*j[r vӲ-*`Si:>9o8 'FSnԇ8FN[~~b XTyo vU!gSǡUo?mWnS??7v}+DS/~St#5h>T8u_znۆ烫֎Ao4u\IuM]m=}O(~Sn#lF5/ t78 >YZ_cԉc1{Q9#q ^׌̚v9)FZ>xg/HvFD?]KPp%u !9}3MXd4+WBf@mMUDxq!SEu_/(ۙ;=KA}%V8y˲#Ũa=ϲ +WG/'BY1(4oE<& kW=Yɹ -G=2Oǃ-ہۏC2O9׶꟞ޕד%G%ame$qḲx?4y{Kt3r>*nc1x2B<=՝-q~@+q1 ƛ|S;T@ei~>g@p,^0+<%7};%μUu\m_:|U߽UA كs?@}e/?lm8fxoj)ΟYӛ=IR.^.6ZCuXm{:[|Y6UiRbbh?4p=˕Ogu ~B_kqo} ̮[rw(+A./) xl~Ko%ڊ|c;=>W[2a-فxa8Ooe!S}6DOYGXL =7j';3\/vz/AЖ".iNx0{Ԏ~BxTHl#Jf;pdpd[^_봙rڑs;;<5ҋ{SvM}2Оˬg9&?K3_-\z#I?dOQUS\G 02 $1=yp*OY8sx{7`:p@1L7$V74nyl#y{$ZLY<h']n50u(anfy$ye;/jL@ 9˖G4t/ՏT1<5pEjI^=i#7q*mi)@eA +Mhz,123FJq=sc>] u6tXs%! O v0~7`4ӣ|V=Q4mA:%} 8~:#mQ ]x㝳 3=ؖC|-K-F,^0n&/}N 5g BHƾX>azHno (@ ԡ_+6w+ q"8?ˌ'Q: Qdyz1-K%w: =׮8?΁y.l<֡}8뮑19 F{_M}wݦ+zT^QSxXQ sM?.\?mӎK#\PwXW<"It3ki+M%o?z[N;j2qZo7hEXG`׏Dy5>Ćk)%"(ƸLyz` sUpbfq} riPݝ/Yg[>x*]\Y ֏}q\S92u':Sg7'I MyTg[l:'p2*{.wPO#q<ֆaEok*wc{+0rt 5ߌ N: V!^VBI|H71OAl=kMځb[c>ʃ?,Ğ;dUpwckC/$@I^|O9VyD?igymHizg\1ҿ im9 `%ٶ4o9Q=<Ln虉VRO!Va w%XvV7/~ 05GTHHgX8KL?Cٕs` pi;p Z GuZYLqݔ3{F??fpGot&/w,j/Z)O>W5u>Owƫ )wJqc_e_MBt_sQwra.uP4z|g12׭K>2vc((Ow+RݪJoӣ;Z'7Nj{9i/7N8li|u:֕;1ZW>Gl?I[G)ee%%^.8>@y=c^7WƠ,TΘtSp\(*,>r1Y}1!оvm!P+4wO':Q~ót c~j@>:~Qy  }?0GQbA0 _Qtǵ暻)sAqAq8ԇ _h'$è8zm]$8j>i`]KwC̶^I- Fj/ (X,Z +&~#!n4_Gk쬓pR +Oԗ;5_SW7}~$ ZQfu|r \BT?qyN)x=\oӨ>z5OW u-/,%Z^?ZX3AnLw_뿀KZ6>-[oc o5'3@>-]gJs,;enKm8o|X~^f.(எ"o=|}0qV_;`<0BTөi||t { m+a|3|tpoK/(&'nE{RENZa9[ 2 _鳆N[Y/bl>} Gw}kwDo%=2'5; / fMlYpX7sukk9Ce".ʦj}.>6c'Ec+(*~6ڏNM߾T| SNK d_dO}.)q3Ϣ^~gQYp4AL!ٳ,@:3sEQoW{|\m &{8/Ex-W=,DwDh75u{M[ğytoOL+)1=±ypě:(Mp#*ie /l +Q~-5eEsJS^ڂV?KK<-oyF(G^ݚ`=[7p{i=_zt>TL pkp^Ÿ_h?gg|fҲsmv;81qB܌k3HFg&dmʷ"FJ=Li@r=7)g 7=X_wI}a?A< OsUVþ,tw73;,kTtWϪ{= 20N[CuN;T ܇ɿ>kX6+K1v~ `L㋔Wl^AЪ t 8vE#Rޠ]x| tw ʽZ:[f0d5V?egwѿFg8E4<]ׇ{ w~՘߄Lb#N.r΢E578Ulf*8 uS$#Yw/D)#/D0,۴ ݔaPӺaPd]avO?c6C~]/R]d( ]C'^gdП\48Q/%<+5y:!+ }hZ i;{Z9~k+yS#@w]w]~z,6q}+*4MN9iO}zl|CבpG7OuEs9q 0K|*#1QL:^άմ9K?:i6d}WtǞi\EBw[3ii_NYFnGhp>F~Oڹuqb||-7 z|ac FlufS %בO~OvB5gU}`;TaLG}v?!L)[K_XHbJ5Ҧ/'WU9SRN}^vt,ؙAV%u\O^Nu^-MpḸ"[{k'C65ktb*_)?*EP~SiR\O~%!`TBi,~yb0QN qMỔcO+uC_%dHTՊx!]qg ;8't?G&cT_^"7˖n/Fof^LbK뫨kCqN4=nx#hInc.@%p}oq!V/[cMpn|]Pqm?4(c DsCQ^:?9NWޓ~El*vhr4o@ 6ΏKE~$볣:=3oz@g3j8B|.8l ]3RU/Ձ^?}-c=#`/o ?D󕙆GNi9ͯ|q mi]w!?Zp.NG<Tc>+x(a{Ac@OJ#:ߠ<~q 2/er <r \._}Dڍ;oNR orTAP%5VKt?7NY-bs;/]OI*{J{E@<|GOiq=}VϯGX| ZX7ǡi[<0K+/N>W"ΨKW x́(LJu/\RنΟPVͳnρpj|TugC;1iF6HO mV$|g蹌}nzsp(w9("ƻ4qC+SY8oe Q^ IJ>T4mx&]P i3ϝ}Ɏҥn^X1>9dØh xu붿G|Zl|Co8{8?4~{Wܾ,n* ڟڋ7Ə ܿΧP?%1*n>ruX3f6q7$dS*X~l;qRmH ?~,NX2f =52N >G=Ο<;t ڏZsc(wWS4GFy6.9oY%ʍSwMX)q]Hߣ;0Oc_]ƒWcVu.stpZr"oGv;U-KziO"^yN*Ntۆq}t+_mM)?KWC*~䟵IM/kA?.HHbzS2M_fM70YL`i`0{+?h}XпfwuPqF#gg?Ԭ:I}Vac}@̛|KQ#+#r?Sn9FHr p CC-|oMVq s%xץ]OT?)ƯBds؜V^+= ^66w'?{\8}=긺ًroUBW\`&B ~DsvPb蠪>8YÉ)窶^8@?:~c|XH:ȣw5Xrs*ʏC .؄Y7_pUmug:D^JE}tUNnV{:ISCwܢ(|'SǢ Evt7ߵ/PEoө{n4e36Á7!VaQ#gh čn~yƦyb>|;ř[oWTV7Ut3aSy h?9z ѿ+!wr])];?R隡h:^Y^ N ]?^ Cwɾd2C+P.AuZqG 7wa-Ň3guҦT<}ׇo Iu7 lc6s]YҔ.<}1\OrWah[֣!l/ɭ Iyv'=u qY)cc坺8eng݄]v*;tM,XhNM^E.ɕK~N v// (u$Gz-vB.m^ ܚuY`Z (IBWc0n@68;[`{]w6G]U :ptv̿u3e8ކ]D^V.,3Ѽ7XG|s[uliƫ^ܔq~"_~C'8 5}̜~0Rgr|}7mug&N"N{}_2=g>waC݃}G7F 7y畓C5'P8e=Cq᠔T?~!g8'sQ/T!׷ꇪ_\fB&ꥻ?UBǭbS;_oֽTM7pfYOT-h\5H츄LS\QFVEyT>RvS\03@ w=NMgƐVN/P: ^q^ܳ@fk" [Alt$%{rijB9(: ?ow4 q}u ۙPpcOSWvڶ*MYwxG~NA+޿ _՟~倢ZqiO>#*GO̖.NT7Y_61[ c{+m2t,"^5h=4"`+ދ;O (?;d->s [g__v$pl^#Q}v>}gܐ5>RrtGA'WkzW s̽rڷF\9f9J[+oa 6zG_GܐF9E˽+?]~U&+peLڛLϏޯߍ0ii$;3 '#Q֞LKB,7B%Kϫ1+ާzGV_#;U\z46x]nL FQ}=U '%pړk]j50>syg'*=ҷm)8S24kziHsȣ?;~PcK!?֖llCw?r ;c1ó=l3[-9˕ǕE5<Íyy4)\~t<3mI Sr=?U y0""UH63"/ݱv/A _v1Nz O)Pхt>F.A㸅&R߮rkC pyy-ĺƳ׹`; (\A݃54wu" -\@yoWD;W}BAcRkC Uvc{-ɗUlk8ֻ)>EuG{#LJn8)'㡴HW@u$m=x>Ez@U[yVUO1i=u`uA)ۃrO+_SǰoԱ#}1 8wuaLXvٿQoVՆ]vQ?5nmQrjyB#pwedq8O{2`/ x[O.`H:h#o.Hy[k v@3>5\? jm_"`/|@52(i8}GfB0|>iTG:7O54%]ո~?ѹzi`i"VR, .a/2 I}4Cc۫{ô_wsVoh.](CʶIhg~)a9RJ:Uz S4PxkK  !h/둗h>LbX6wj+HTP{k0|ڳgB`>!}h6Mg'ߺ6~khʄ?!kC,:?eF}4t9X¬_bϜ;{@w8X#?[3|28Eyu_?n]>p;CX@S^}+jk\YIT vG};oB/`w_7x[&c}18ӓΣ?K8i]Ae=ߕ5Ɏ?>m]ǢkūOZ/_;a۵{ A!!]Χc&{sF~ 8_O3XҏXS鳭;ṄE9 g|F^鱽3xs#ǘX/ sw<;^w2~X(;Ѷ/t}(Y_J{x{"yF0o;ΩkF)6F[C=WW?;cVhlj'pຫ3PǛ-/W}k2+oqK?q<Ƈ4U˒.Ǒ?2OA7.󔥼@ $m3yvŐo\@48whӿ-W}1ڗy+&j<9?R|7j=m47X>}E'`މ7Oc&!1;:Q~h M׋7|Y(?M J=ʧ+(m_Hky4 KM8*$!=a 0)oɗG[CVz<0߲8?'о+k(nEqj;H@\FUz㺤|E PU0 ®8/^;"VNKTS/G{OoOusjTEor&746TcwD^ϴ({NmoKkNܼa(OIFM?Nq}î8cC%)<f8!{"L8~'_vk9ϡsn8 nzDuK{c@ ܰaI8. KVZ CK?zLj\1+ݡjߨ'`&chS5݀j?g\!H>e{x9{G4 p I }a^_߇j8F`4y'Nv0W+svӺ]m7xs(pzaoE*$UN𑍈GI!˛T#(v.L5"_Q2szI A`[OpGvJ<֗,LC"?8w.cR׊a:S޻Q>gh1guC!;i78|fꅿW6}]#W%@|JƬWG~/Azt n ;]sԷLZR/hbovh'wӾLLjWa8֗g.+P/\?,8FKid!(ӗ=EuZ&g=OL!4Au)e(0߫~}}0>'qU45pQeJƻСű{ګh=ջ`-`/s3vԷG?VoQm*2-`/ZQ6>h6ݷ>[z= Q *hN89=U]|<ըgh&(oߐʥ+A(DigxU#3/V =o}_'I#W%=Ϊ|YL7Yav3V읁TZJ{Xg>֙`yhh_.QT7o=Czo~L/7وPPen펣>}CLGqs:PuwWB+.4yR'%=NsYPHiMʏ?A{ìK07էz۽w/to_m-.Rg9FUuLMҋ1G[-xpr"̣m8QX?WhpQMLpWS}h:x ڑw 8^~:t|ï Xko]Iqhc7#&t%d}ŭ}A![ P Jgtߕsup3Z/MB^I;KH>TEGZ<2C&vE26!=4X?;{#>=KC{; V8{uc ^_trMޏ!`cʠb`- T?6>+6q;\XAs,GۡfmEU(~`ʽoVy?Q͊9I #8u q[{:zS.oQ^ߘw~|/ 6J{7pyPϊ| è?T2:z.a;z7_IqNL4HuM緉ΏܿhǪ w y֞B֬^]̍26OdrqGu򫌿MN83Mw#h&3^{1so^b=rC V<^ܛ mei1Q,3bpR ~ŎG?ў+4my]-Ԭ?n@ O{V5888Y11jfG1u.>̞Կ1v?jg]sqB1['ehQ~yߞc]Iɮ5QBJ`-*w:_)H8uqm1zD+e?OL)a Z >?/F HY|DviY&=G aܕs AtXPL9Y3hweqeYkM@0w]yPf>$r%ߑ CS`#숿/ϟEi1yxEa@n;Koѿڶ cS3!~{rצrSz^O}`O/'~K0ⵦ5!,>Xw:!n>Ǽ]I,yӣ{a|݌^T}Hz/_'_A9B_%R^ fiH~84ǧNBttv_BC3_ Vq]]%:\k:ĸ%7GU78鳃8>UX_ŵvnXY<T!nc6˗*fLѧM Ϧh-@4&BO;hTWCoE$AL9كH<ڽq ǡ=!bY$26}yζ#1 Osk8学gN('mGZ??t{5#F|ḍTϫ75Wq"PxǷRO֩l87+fh +6JSWWϚV{Y P݈~-Uҿ{vdWhzvI>>c3HXz _y= ڇ!j۹!`yNwԯcq}Q&yȧA!|KMG9x0Ypgu{tNx-ɽ 9L3 l&>c<[ДB9(\ ݯyB7`'P=@1\o|@ */sfdj{y94y3:%:q" Xٞ%J.O:g_?^8v!_g-:kO9/pSݸl6}L˪T;u"o_Z~Yq?ԯǨWt~j?3:b;kwe}[q~9 NEw}c|+ocF}bɴU1xZ|#'X"A+=g )i Qn#9d3nXs<+ګdɴu'/\#;[w}e^i N?0?~m:wbz/pa7e.?z7Z<xK|'S.hfC̀k Ÿ!(yJ,K=-v}]ZЬy^_.NxgǸy/tU{(5+vuZv g"[SY\s"u60vo?3?Ν[yӠ]b\U{[nv "цiK8>>3VLìNx~ iKAwݿ!N9jYT+Qq&mD[^0.!<K໳ w틱{9|\*#-b8y8|TKy{bRwc" V#X÷.oN}jʟo:c%}/Yp90c}nK ꃺwShj5('A#}c%cH;?o m?Fy /Ž^>8󷔣=*i@#yON~e4st?/}o?b)ݏt^ƩxnZg\X^4d)ڹݿ7nW!8IоC"*olZimF)*F9TW<[vKS?#Gv+n-os4c|l#efNK@(q 0ǿ`ڇ1{{^CY;T]}gܽ%E;u6o_ #'T?ՁM}*J&GojrKC5X v+M[m W )O2g_wݣeQ]Mukɥi]#;#ζK. yrXԣgy+rOY߫0 d\i| Y{ю/_9"sOX\ 6.,Olfw{$%ī>KUzԷޣJϘ`/#09ihN#s*9ؗo1~xV _wsmuh:WuMm{I=ZX}ecbO./ 9Zl[|+Kz=OZu#k0*>YL:bG[p~v4>Q:g}bgs9˺w覬Fk*w9v$ꋳ8jozo$7Vp(ɲFpnAֶCq7HLbDUbI`/bs7}WλorXae ~I5+ ~<1D C)?juӈwl-B5Tw>TwK#^mEHv>wy o7[yj4=h'h_/>8w Vq~dyõoWyn]>t>M/Q/$&'Eb W?q2_"^a*|J3j= wa8gt/bUOYJ5!ɔAh".5]bNE|OƩO~exXk1h;"gQ(W\-6aNPv]&oDq毪*?v8X6Wa^C (<_nd|5]Mgn1r [ur"|1[V;?]7,/!9cPeY$/Ŋ~J1/ ,mi7?m{.s'wQq#c!׹g4ح\ ѦPJLaƔ} E~Bo:ꯡ#nn2\n|DZ:OUhߠM Zw2{ns_qS$:"[ɃZyej`Sqԟ1ld̈́W6gvWBƼJGqZҿ2܃5pbݭʗ8pIxPn_}T}]̿ ~qMu{'bSضV.WDb\wzگLⱊ=2N}H@WvVx8lN/o7+X. ? 3x")\gZKMqqL?Nc{b!oEau`8 @=2Cܷ=unʹ%֭ .$|K*86_kd_̄IiMuG{ZqRR$iW/WFy^ĸ),{M5WyxT%`:xK|2Wk"-b\)eRs(jvpeQKNev]rf9Qm=hhqews;uV:P}ip}5<G}qqeǢ֔93@j 5]qU)6r~4!oiQXnggTMB\sP;^⣞19|mJE#~z {3j?&>)07A,I[1ks9~Ǹ~u[Y8~y_にf`["w39~:X.97D;h y1AOE?]*Pi+:}g+?yBړYh + <988؈flSRԃu<pyS 鴮a*dG]__p:7L3$?љ'(%jvQ^ЙF< אq-UTU8!UebR^/GSG?8O"C\}<[+)81 CW{}^Oyskn{1MsǫYY\0X8VqUZO@eE3GE#"1ʗ G{OwԏwՈ'1Tg`~‘?|SL5g?8Nq/Ndxɟ _B.C:|'Ʃ 7C~KJ4鱈gS%8}|~6`WR`LIn|ʛiT?L8\|S[2i)?==R[N|5Iw9?{MF=i}Nhç#KП[jO>? vnt=/5Wg>[Xq/gg]XsCgvFޣ_"OruucI_DdvukF;UW} _a^dO^E$m?l-g5Pٜ*qmn]oq [ި/JGu“ɡ@C>:f~_yɄ ,NƕKQNy^Q7n3;1`懺;vmSpx{՛O_B;Cl^\'MDV:uAy*8mV[N lڷg˴&Q(l 9ұ{)_a#hwC(?s~LѝZ_EÙN&ru:Y?>`ϹB;ޱOzy4V{L> ,/A?5[s>jxqj eZ>ӫB[g`"t)P_qEj㵠 HJ;U~<^&F(P-}V~Ƌc-Q(9jFns]-ѹMs0OnC= a~SFk>[mBݟ"n Zߨhu~Xw,He#`|ߚanpׇҼ͢T_[C1K񓢡/^uY7Ρw1oϣhJS%bgo`%??gv3o[ˈ  \aSOs#NQ8~pZ?9,am팿&t OH#͌Ev3ՉReWT6wݧ8Ji?~&q|7_3m\];]YKm!Fssr~?y i|]'!L(OiVQl}w~pg$7 t:O5+^'k1uȻe'~g^O ~pͣɻ |Q ꒜ a[6;?Ʀ 82Cv+rPfPϞ :ݯ<>{3o sTv^ V/F^[ oM}J1?KK+aTޖ!>臿J=d2 s畟cmw^eO[X(V/P>K0NεsޟI@Rl J8]]>;qEWg_AGZb~,hu *!rXoOwoQcL޽5~(=s0f;ÚۘbQϷA;6e=<LaK+d.E>tUC6T疌Y QfbG$r.'fv- D\s-b5#Үoq{w&X2\i}D?{֧b7݈i˨~=\Ӱ$oK`G Om e!ƾǎ#/mPc؝@Xwָ0OǩwcS6m ]џ$ڹ Ooevzj50`r>ݪeoq9gz#OFi;GgO9{P쬚Un[PEc ul cguoܾVSu]Gh>FO6Q?3hkn>i _%JuI.'ӧ^ӳ>ͧX-;4Q{~@n֊_xп}neTw|SL@TS#8pCp_LC;x.! >x xov:sSw 3 Ɋ'|u{nrڏZM;uSatuoK+Q'$K:_ 8ֱ6Ϛl q6X^7XyU+t9<`xuFLKsԯz/m }y}sI\LE}J_VLhZs}r)}`;q$iL؅d>w $*߮3 NNQ'Ȃ[@} ԛIwi?oXIU%帘 5TG訮\WQTܘ2/lk]7_y%Fqsg[|[v#Ni}=x__į&5+S(9"`..Z Sc^q, {QϤnr]ڗI^|f_NT $ ➛; cmzq=3e>yOU4j#1/s,Pl{8~HS~wh•sƔGrY<+)t jӢ{`{ 5ԭ3 > $bEτgNg[\B-yіm Wܔ\sZem;Q'I[;€OsL?ܴ5Whڇ0/?,ԯt3oo3`~^-(wUmUYΔ.n]O"ҬEu&C|x]*zkNfꏨσSmF3z:Z )w Zhitz`}ss*ȲVa}iP^k;_{2=ijn.D!/Uim}A~$ mz-;Nut?\NimDrӣvuaF`(\Gr.fV7+c}@so-ёRreRqJ-y2{Qk[Xz',~tUh&k`a~FY=OU{-lОQ h%S (X}bɿN{"cSU/@7$k(Wy+ۉ$ (0'^^ =(<[㒹"NFeWnޜ( +SP6$>wCbz׻|$u 驛(?oz[NUZ!]sԻLt yنRݫ_;4ezhgE_M 2rO \X E4>:K?u >/Uvv`1ګII>P4& J{ ēS]'yşCʌ6xַd]i8sP^{ x os2GM+3)C|o3kK?G' h}kǡhxc{TH0ΞEfpn^894[of>T_8RlD~i@m:o3e=/m9{5ڑnSNԟaU*&d?vVs]ogM;| S>l-v Ӟy%q606ϥ1Ku%Φ= E#zu\D8~oƢVb|j[Pʢ_=>ti:O,q`s'k_ڱzjY |tsZ^LhgcxE^_ گQW;%'lL˘7_7E }۵eZ8 WM=#XTk>_&vg 9g$ΏȂK[G_Oݞ5׷Qִ>鯧6us/٥0 ̓;/ir4j_.ub06A袚^?'s#jZ?0\v}?e WCk=>S]9'+G>}[oeOcwtƣNd;.uSw凇Q?;0T@(CЏNNznnZ7 M9SdƲy 5co99옖M q{XR^#qG.8o;9O!]!1/yt q:%K܂+(Wa87艓vgጾO"f~~ OŪۤ2y7O?u>մk_=Ώ1]B{>O~Qf mLE=yVs~k}m(')9r;2ggW+>p(s#8^4˶Qp|C*Rca ޶C̒*p /DRڈqR?+W?wX:亠 `p-a܍WjpK՞ nu5)A~{5Igp9ǻւ˖*ߙ4Ps,~DvHܬG;S<B}NAl¸(sS[ӴĻM9gLO른~=\}W3\^KYn0!ڍӺ#hw:@#v3`=)QKCK?VcVq}M&^%Sw},[އ$VHMZ{Ք:9 q@3+w+J#|qGveof`9'8 p͆Ł,#z}%[ F|fو[t_z_?Yd!+kqqN沓 ߹˺9Ñk9F8ʇGSW[Ua KlR^EG35= ] O{!?$LE]q 9Spm|DAoRDx=F璾ɄO{ 7nG/nŔטD]\uy;ǯȚqZkeW"Fף9K'BܔWǧ]΁lJ.rIE?ԣeRk~pM=K㸪zW^*JuS'".{^'oscPv`c\{s n{?>9-_7P7eڧ!ЩCⳭN ܋w{ַ外! qN8Tm]ƸR`lG`aLuuȣc;p#~{jO5+1GL(5@~~ea`@y۶pS]k2ݜ,g{W9tAEդǟ>!fi~ˊX`h,FT}JUK8O[ ;|E!eï^C|0˯'_/A5%įW+7jRi.Y݋gW:E{Lu AQ> Zgߜʦk9Fڃ%?'i<'>6 a1[{aa֏'>wntڍLW=.͘|Ϣh_ybaώa菸`+]{$ V/ĐKG@E|d]ʛc}P^4O@ԫ~:Ϝw_TC}ݧ l䛟!Һ*gm ܛK1|N58NES9k.mh˯\xe$8ȇ4vƅ?\o XoQueG~˃CㆀrO./;IoK2&ŧn|:3o̞.(OvO(Aڒ |;+)*eKXgGs B ¬7 Y&Oڰ"ww"WڍsͿ?G,v*9UPq>e(?7ؘ p^ٝ-b\;?yyG^!5֢^|S~TrFS].GwV N-}/U߉zSѯo!Y-Ѕs\ԫW#N3C0l ]~ `r| ןcFSG,\2$K<ƌ߰nH4b,h8qǨwynϔߦ}43H>SX`o)7Ndدͺ쪎Q!Y?$Og7s}?G2f&EHG%|Wpڻr˙AXa*Ujwr_85u5(/?'C NNx'̏$?޻'$9dtƞ1eeF^g ځZ]`X E-i4ٿj7/Kv?G&{/:%w⫺5填}[WN` _tX'.oY?4ܱsm\//awx^%`ܒ , ?Lmꘓ JOva9t5׽Hy}oBݐwEf]W s\\|bSӂ;6 >+)SG#zD66wTݺ(!|-W򑤏t#*U<༾}ۏ3~ԡ'cION`/{*wadݖYeUHyX{ Lt"lh` dFs_4{su~ܔ3w6);7ǥ8frzN?>/BO"4̮_nxxOopu=W+穚:d< h(m\v#< 7S}Kug3Dkփw9qjF_oRy8%Kqn]|ohjۋƹ; v Be]x)HpBy/9G]R}Aa3T C"!sL}G7y1C7C)h2IhQ.طDtOQZ-kŅk9 婍lڗ4kXO+Z`ʌ1 V@kRhVq_*,EMڻ?Rr^koKbl8xIuwd0EWeL? ۻ&0 Ke)AKB bwVT_zNtr7o8㿲pn-Yu@/53dGׇ9mͥCg۩;Ѿ+ہs9`L6'~`y5W7> >^H$]BІn4z<ٲў<wyh؟5M}~yt b"X< ZN(Rtyj3/3=_1~,LZkNu.As x,xX:_uKȮ |hrߺ#֏&nÞ ^_"g4G#7&J+p,AlsR44-AL1/A=ݎx?~tt<.x hWSi}f^4ͫy=?O^q0c&fĠ?PsKV ^ԧki+c5bqvꟷp[wàzKs GMq A"I];X'ǑIX%ڝC`;գT?V]A:K"i'?mp*ɏU뇸<0M޵ˉAP>Ɵgz*LyA]iq#ظ|aB=m0 Cq\4~.8? ?6AgD!>3zw$=3 h}td^ԃ̻wϵk+cCZأ3k~giju8~Rw.zn7G6#'JkU?V/i2wFcߠrZ1\ Fad >|)/gAԬL?n4~ޅ%^~")o莔 竦?>Gc~vE8?qG%>2(^n`b'IgR]nS/əx"> r71(Y?S޻6yBT:l߃1^9uMC׍֭$ChwnxG~utbw./H~Wst=s=-hoO0g ^;k%7tN`s][ Jd#)M"&x9I^8>/~WMin6E ^Oq^W:G|7Țg9f[2)`ZPj%Wx}_y㓪,HPv ԃ6o-ցdhљk6c}Ra[6ڔG}s"%K.o?8l^Hznvuzyx} ~~#w Q:Rk3?Ou崏g]ae 9h$5t+8-:_Օח)eW w%*;Kœsak5ue)\n/}q+`R(BJJC.|ty.ѧ lT9]ro@e7nPm'Wo{VU?7Û>`5O|c]<)*]:q/_yvt*|fk+fBbTBo} o{51΋WV5 n8`x3='1l9/;6ك8x()P1BmV'\zo8ozs,>l%ڳbO &o6OtϟN}p6,|YITާNG|Q4wpSW{i}XTy4C;5 5G }8ȉ؟Vwx=k _U],1s/ )xۖ[%}ތ: ə[)f_qY`aw^38~eQ}9Z4qTRCn 4[h}Xj>0p/eܠ>^Yc]ssp.k}nP}ժvo(ഀ~{_>ׅO ^:Z##_-K_ewG~my h"_gڍh/mzx'uv[A}vCβrlm Ew_DV$u>}Cmo\JUw >GUce+]+b }CS+wEq]koyq:ocx}97/Y>r+4Q}K0EU{s\Q?l8x[OKQ_;?pȷ= $<^Iut5J95U/`+d 52G~Kǡϻpx<$_#~ +EydQ]F'|?a|7ʛs+P.n'e V7Z4vjp7? hLV>XU6RF gn;v>t83ꑚ'k^VJJ~O컆#ʱ>̋s+]۠t:ڼhG'~=YCk~)aWho`l0+XTFi0~WlU\:ѹ'#_Yb~nG뿘#~LEӽ|K_[ۂm?q$SU`R8Uzp8 C|qR" q@s&zZ㊣v6Q'b08V˗>oI6`4ڏg oo6ǜ@[$>\<_/H 2Fh?BaIeѾG,e}#W8jԄs><X#A IZTO}rrp]o/FG38}ū H,I#S9{OGPn2f&9hrfx:w,wBT>]80g ;*EyNnr#؟{{/hOZ^@Oٹ?eN&ϣu<8So ]ڕ䝘nVoWP|w;mI?i'i.;"^,5!>*&d:!S m')_sDі"={fP7| .OEpcVaA; o_.sFMu]108+}x K4{L{~YI毡CƛP/Ν '赺WucoS`US\G{ZSqƸr,{T r?uؿ΀}X:ٔoG_N'wn)? h\ހ]gbCUR&JgkAgw-wffaxvvn.C|K&jJK*A6Ǵ3K|{w FUu8p7.8Y?Yb@_[!|mrT<$F` zj<8WYf !|z{bvpsңS)B t0=H<}/3P~?@yW ޹$ÙpD9GRl:lڎøv,~:rnk0caNOYs"lҒaS}kJu!X_սL[ >t #mUݩ"pL0W ф/>LjV_n~Dި|2IQKZPܯoР4ϣ`p*yT_(ۭw1> ?N hfѾ>!U'ΞvO8[ho+wYyGһt˃V7V|xXB`Z9({qC+`|K`o-ɯK#yvx8': 8V 8T={ӪN R1T ⢦Kӊ_yOИM_* 8,?riOкo !:@3||JT`v-:Huǫc=wLQ67毢!h|-}W]y2 MĸC!K7maރT%,4'Sq֢(fi_üstwWWNE#ցS)i.F?6,5}dB9%H?[K[ЎMB[=p XJuiL1>]Y/o>(o[u=prM(WIS5|2h &z=;1/s͖; {eK_qr1ju\7~Us/YϨژꂶx;'ٳo5'AWn-Lv`Y=XNyȫKZIO'{E{н:fki&`+x_e8^MW{c_9ʳ>̴~o>/5:21m5S}X]Ok9_-cC:5ٴ[:qW)p7(C#b|5;u8VFʓWC/ ^8{N`|Tu:U>ܸ-s/(7J 2+܆{Q~<{$Ǩ ?N!砞 7N>-gA|@Z-MM`fy޺/()_V%(g 'Ot߻ |l?oRS]pbk }o9r.%v*M~ E}Nvk?>qk>4IQ̲tb֠7n#~zsH"^@˙6ˀS{?۴7_'7q*Splt QEOy`㡽elp˔'w"p Hn Q_O'IWӤZpF 3? iPwms&6NY}/lU_͍sK^#~U0_Qo'=#ODZj(A".ߚ5čh2 Tߵ ]Gul?n(2 D>w78>y):.! :]8'WDY>eC`C",-Fy"q9kg/Xd-N>NG#ޱFVaWoxo.ng!~˨JwjoÀ`Oy;Q/^~3u)p48j|!jLj^Oa֧8^Iml. B);X}}ܠ2_tάz78 @Lu_f"`9zG&c{c=GF'9]ˡ>yݓnNFr/}?u1f^EtYUkzPt 58c}a3#U^~]mgHETvۦomcu >K?#Oƺ/hrhqE8i2sux~&(N`?y!tA: ǁ(uG BnCͺU?wY(y?Vw>)-*sNQ|Z?Ju89ע}3޼a ?ӆ_| Y|\oaY؝e:J yܼtn?S_NG~у;R e9?f Vޘx|8.<_]sJ#J)Q#>qVVPYS uvG:*jܝ g1NzGuMdXe\Q2oXҫ>2eymC_7)?FN_\~o$p~vF%/Gt{;_׮KhXHS1i!1WُoDZp_l6/5u|Ձˎ̶xf|]?FhzK T]yaB;=$Vxƈa8?O[ _YpA0hUu5w&SoBnsX 6z%cRv2OQ.= 'Y3Yѹ~ox sիn(&mvN枋qܱwuk-^]oʞ.N!NR!h/M"://GLѿou!§\XQ=` IndR]Y+;ݷ3Q>#]ȳ?y_Eo6L06g'mtge$G6CP}z> _7t!\v>*Gԁ;S>9;zܥq9>AS=/L#!B +s/cP8/t[(=|fo?JX|?#k6xB_9CQ'T;yrƢ:ԗ.N檀}0#cN#O׻vt EG!.K4stL3׸~cTg]Oڟ΋MQO۳J?URYe-y{nkG\<ğz-%wDןr?!G)sq~QãCJi|-iTvs)lN{;=!F8&IdUt?T(e!Tnq\ x KQSU:zVw]ܥ,EߴU?'?<=#)j9nn5uTmcճzӳ~lF-Ͼq0{"VX!3[Gh%$?Ls@t ۬Q&KoGހq uC+n: 'Ȥx6XU?|E ُRP/5~x\Z`tuLwDk0`~r2>YC3#fN*&؍iqZ7~u5~ld%3&vH(f#Q- /ڏu cYgWӇ-8~&{4> O6΍CR^?o4:><"w|:;o`a|l(D[|ѩ)\t}<~a}a'4/{/N"·ڭOnKǒSnZo] d{N3  [,#zr\vYFl uˈ?X`2qQ9ڑN.Ñ |יx{>ڔ$\N7mScR)7ڋ?JN#sa珁~`Ώt@ OUHCKHWRnF# ʪ{, ^Ȯ&F?ꬋ{yֽM8`h3ag\rb|_FCު=oPwZLq:wТܤk.D;Uy×$2:4lfZ/Hu7j;vE\^%TlXviSq<=G53vc~n¥߁V/68RAsj;dpިX*Rť >ojմSU(a~|΋iLEYDi8yv O~U_@j5g+{8ud1_K`ab|Mʤ;8goc?1GZdpH[^.k`[̿о :~ؙsMhLOvhTu8hp˲yhg}fv8nw2i8Kjq[,G0nk팆8_3.\՘_yL-He[R}d 'J9ZTj 8ѹb('$%mv_a }$( %h^Q!om$/ -w!;`ls^ 1+F|<ޢ~G|T&l[ i?<&q~] DS:?V! G\VyMGo^6>36W~MMaWμ</,iQ?J9=(ȿo)'>;C${?BSU?OU2e+?кV1;z?9 =trL0Y. t}}MQ+% r\rSlyEs{Of^7.Q9T$h?J>}JW/D "C}Y! 2rDΛ@rR _hVmۦڂdX zD; !CAq=l70[;8K#ίf [d-> _n~_KP>tI'cl`ns8SΑלZH5Kho!&<(3 x ơW֓P>!̅\(m^ ΅txX'y?#4֣}KgY~Qpj mR;bQ>rLցxNyg 4Kt+d!s +;7or㴏EajCdXSl}>qdx,r٣T`$7 Lfm//kr8uLZ;#qKT^LUQ(^_-hojb]Ϲ6[ZPJ;JOnɠ0^ h߂i܃<\PNڡ>'+ h1IO;\8>5(wtƬ&PTE8`jx00?ʥNʐjg:a) 1}8/p^qW>hOj'7ÌEˎJۂg{*yH.]5=\gy^ U7>@Pk 1_qB7Ա|} $EzxT'8]WQ}(˫nPw}Ѐ`o8⏓A*a“~sa!K~$Չ'IX #;>`vۖ CΡ>ecL[RA 5?CvCٖwmrIpv6 1)~jĤO;p|k91y|WWV;eWe|CEjAcD_:_ݺ.qsN3{C.~{CC8?mW7k2'b {зI}uJ%7Vvks\Gb|PהOoFv؍~!;i>O}i6Q%շWq*l8t_\XS]QXxτAXxn/f=.E qDw3TTd%{.6ʷ}7)^_8u[c0<& yz򎡴4bcq]ꁢkb|Rof/]__^s4/U C!'n889#~ ~˦cOԊS*jE#Yp~]; 1h?sr1uҹ ī\KDl,BÄeQ\ڑgzss=n5'>Gi=oǬz?qm GܙXה8Ks`S lK˲yj`Zr2 N"wjB:PF{yO8I CeAv̖-ju٨W6 5}Czϴ?؈e(ytSlLX|^oNI-o'Uߚ]j*}ds3rpڿ϶t؍k:`~SxUyK10#̲ng1S@VF x4-@v~36$Т0=l⥉gn M|n:8{KשK0>x6H&*&Nuz`)<Ft/m~qV\z[̄g S٦=A|ӣG3/;QS~g]jw'y.rru_IFFyh ܳb ڊ7kE}^ý'j2 ǣ~z?ß׉S '7wP?3Si~|7+=^l1?;w-`cb>jԋBkq^0C ΟB\ @q''#? LA*y ƏZW]T:O\~Y}9;7R]+#eUt:ïW2p:δrxZХ<*I|0+\x[tI'-n Wcv][C=sF|}1mٰ> G\&?{= Yɇp0}w|@VO֞ފ*/M'/ ~A;䉊u;+N8--{9gܴi_lZ'/plw<ў[WvQUv3*,l -O W?]18~F7Wb^y&|r?`{\;Ν^Xe9QO?O1MCnS_B[]b :qaoaµtVtc8~cpyY U )ov9"H kT\93 'MI)u$8mXwFj}x̞% FP_x0lp38-(x7^y-+q~¾ǩtpzPB`oB9*=uG!t=DZPyFRu`wbui6/' 220u -mpq+4c|_榣](dGyx/ɱy lyB^I&Ƨ.GGp0?笿^<_~ D@}Kf?HFWwB{p ,s~/E@m5|kԿ:ctv92kW6R-\)?Y)Q(:+`_ZUфf-NQ-r?}T+GI/Xӆd|_pGۂ*!'cU}:FK5VK[?{7KNKgo}OB-;D}M4,hGݎ}.0F}o?}Œ8oXR.8 3M2nKU>=!_-;ϻU릻;w%W.Jq޼rF"8!̼q-2aD偖+QtѾ1jh}.NFu*Gg5i> @@QK!󖍺 PI)ڋdZs[U⁣9/C|Uo:v7gp!N?9>5 ^ xN>Kҫ?sѼ(_]v)ŏ'~48Xxa^'ԣr:mP9Ǖ.q^z-ጩ"H):Sʟ0^XOY'*sJFe'>q|N'pL1#_tgT?veO-sfzWъOK] "k,-!όmAzgv"~?[9jָѷh_qH0.s> oOi"_WtuYߣ&7-0u~F`<<%!6x/7hf;c!^(@~%C۶hhL_.nyw?X=1+_wuI58R_Y SW{` [ݭKɔ?z%t>Xo]@}.Fm[te q߳ͤsB_O> v>Dy9FʌRFY)`S bc;Eىw93u_̌qܚs/"zOQ(v_ Vʧs(a/ؽe%~=om4~|e$p_ӾTab=g݋57/ ,+aX_D Nț9@8krnc= @?Tl!PHx"؝SqPuέ/}hX6#ejYN w"[t!+'p3PD}"GH+myaחG:cC3ӾZ4͛n:=zg$^Hn/hئtZ? 4^y ϏnA wyh"?.9|%zw2hUuBn!sRixi_;$fQ]:~+gsQN0OaEϸc\X1.S5/\_mɽv`,Eba뛤h/ 4~aԠ8epj;` {PM~'xRl*\f}T9?w:/؏=Bт+OIq}!9ՈYn70sѮ7VD~ABumYNn'/h^q.[Կ? 8hh T ϗ'R}~P7ȶ]sŦ?w"njsORcSqFӾ?zսFp\[P }hvfK6~%.Qsz ŊǴr+I PJ y;&gP +.][T|k? cIG#[=FT6{Q<;"^zVsM5QNy7|§Ox=u o40.~6D;H[.;:e;خ'tO1 G?7X$dDQƆQja&tû}r?uFw5a c)lώij[՟loE͈kPcIߛ8hǺ1neQ.,I8/H(ndE{߽o)dFRBd=*YɈPVRVHD_ӽ}9{Dq6u|υe늁v|D@=jW{xMWO¦/Cy hէ/Z y)?c;]@{5ߌWBMzhFV:՞fyw^`O V)HiCd]üB78Ħidp͍Zޙ3Wy>&\-)ct=?RȹO7o΋-l|_йo/\z#YW *W4[/C7x:3;o -Kw\ubxj`7QJv:/i>%Fqv.|̣scijm3[/}qKckSZv3ƢV?=ِæM~DuwGߏ"Tl@3y?MefH^r}>B^[㡈U :17R?o<_-Kxa"}jÚ4.'5 <( 穫W(_n.mAzͲMzZ7K@*<@Wϼ2Śѽ-yϰoL1-|<[q̛d]2^q#EV4Z`S_?fa`7<m,}l+7֤}a݈ȟmBLwMXwPpDT'9x1L?"v|%O"+1M6. נ]I|C\(!:UYpmTɦ:gYW?*C]pIvPYXD/B̷D'gOo8Yr2ڗ9i ~)3MRj3M7vynîO0n-n_8s>ӎsq/[Z]OoD!s9nӾПY xC/!o{0G66r8yq"ʛpG ]/?Bs\7кlz1+RE2_1E 'Ӻ紭Tq$}ȟ<ARY,sTCv.tlC8g;oF΂ SyܭIJp==l?!tk9Re#``Ϗ#?8FKaMLC+c|QۙE~MMx/h=QE7rþ[C:S=|?/.(?uF{c=;fw]d7`L͜vwgPh`rĝ8:h8yn's4'yjKr`7'ybњԟjm?5$3w>m>Mc&a(proQ[J}w9UY#^u~lJ]ˬ5m)Cܝ몬#XILSDfkL(>6&L>k3#1S1_y)&S1-S7ּAP-l{rx0Hox>NF`< M=،F_.T׿{ fE|~+">FvgF rO?8osAOZ,""_s5qIySg.;}5{ 86&5A{ ː~txý>`aϋ}՟gJѿ D6Nny(?zQEXw9E.^M/]1x}&I"i 7kPcwLoLO??s^nqJ'VxWS_U"_~:4Pjgȫ~i\{T兇zC 7VM үϣ=/邪'v~XKh}("~-^k?(#oR8TDOއ\!Zp? 07@JxS랚o[1~1`/Z e@{mt>0q"0^y |f._-ݧ`j/-ZEnjW4O|_~Ƹi04MC}/#pG~uZʻZuM7/, 3tǩ9u!)8{ѝ=wh/w 9ߺ?ڝGH;]ɝ3(8߁ù'8\GUޟJI==.yda#Q{8m')@нQDm O"}v~֗m4@= ^7| {P}oAsڃ뤴!3 vɡ>wN*y7~8;|'|v\2?+.k!lFzӍM;iT E*MjPn8y?, rUXfIݒ^]JmQ(Gu{kӧ$~dVԏzM yOvZ>n$hܵC9`sG,%,(>zU"%H{dx!Rɛ絼ᇖ1p|e0 \X-zOja>1ZЍ zv:>I,D.{<Bݧ&yѮ 'OG;4psnɯ\SzK$USkW9S_`Fcc㖓.yhO_tugD/v+>=.XޢijkVƐވ+\טz}JIj3/w 6"O4?O0;']R#ˏ+8v>'?dMv.Q6`3Wrti_8t1m\7Kـ~x/ҧ~DVM_x"c<)?]EާI1>>vy88tyso:;ŕqӺY_K+[?h_uMs5K:i&'{2ʇ%.zގ ynϝi?7p~=_TA{`(#pcƝW GDq<(sg1Fpu !UߪcO($UvO9__9 ]gm6Z'? zP}I<ED밾 ӑtk|%?gLtA~H'1[*%w|^Wt`YSAi]t ҺzԟѣQ8GTH$pJ1}ڭAjng]gO @Ӫwwh%(5 yK"׳{ŅxsoϦI*ZQ[2|=o\̭o#xZȏEСiE~^qlAbK

ɧ㚛~5MgJe^'|̗/VBLR&B|)>em-VrTfwSa>ǽ.:L( o\h69U/(?>6Rf ޑ._XS}޾K:dvJ|Ƹ c}>iQ܇ɺCou _OpE$W`bT@p >_9 fhkߴ|m@:2} *nD ';v}0zw:ʟ:ZbTXh?Y>z gkeF݉-~c2$`RDfy\Uf :&RΙѾy 0/S j.9.nOC0Ɖ꒻B1+ӯ]܏, x۔\MG̥:iu!)ޡ=9)FG̯5;V+"n/rS&A[oM$}nWwYfаcAIBp(OoiDPa[s}(o? Qkhl&sڏ{DNnכ7!)ѷx3p<;:S_!eSٳ֫F(e]сd^Aے_׼Jwy4~sTߚA4UWwsǓlwJ/MNm;E绰09_@=3S*A4uFbowְ8rad.=ֵ RլyqWQ.Z P[E+Gup䟆C]y/e-q /Wm/9(_׳0Լ w7 o`}C#~oׁGFyJ k%L@^/WC74)!?~r{b-|K[:%6yrF~yܪVОyr{c)/qfY8/7+1/ R5V J~%hxRxz  qWv ~n|ltSU7XP77npk!>e9xAV~Zܘ+mSN+QP|U<}6ѺZlC@y%ޢ:Bo w~soE'} yjoYuї_C<3c}Z8&(:6E `?8bto3 x)m01qTUVr.=+]IZc]Gfq̆ ˷CVzr0!ח^3{!QwZ*ʪk#/%1Xoetr)ސ|R_1 FΡ9qwОx5CZl_vw֛Q߲pv(IYCxZ^W8lB[@djC {s/l1JҶѹ8y oXrՕs5X C|S<?7SEZ֢|ϯ| >w%f⿷f= 69kNg*՘'닪^6ˣOMmV'G}'p"`m@K^-mpwS߽hĞ9ۉ_.xy lE{lQFźݧxG?׏7G2[U-ۖA寥kKpmAN+!$l~XC^{Sݝ|GQ3\,,=_[QD\'3 }Ϡ/<@|S q^v $>ܖ^Jm8հ|/sהhYF0/;k7'??͔8DzmםC!8 עoi,_[2Sx{} #DKDӍ>u ?ʺ?g>. GRX~CPwKp0?8UkE?3݇;ȺbE OexZ|)͕} A[Sh!OF)b w OIъi~cV5k3y5&<z֍=ԣ=xa/ͭ[Wxd,OX0l+qS_: SYLa썿w2(?Xwxٹ79\W ymQax֩ņ5Zw)v'C<]ʷ@W=>s#X*Bu&?hd\-m.>ysxvB_71PUNþCqlga^?rrQܜz<2ssz:'TUjZ~Y\&|~(34<830׍}#/WR0IJ|r*F}Ljo/yXs(t^: Q}]|H?Af?RD>KsA4}$g|ե<uQ_ΠRH{]8zZQyuCKwkIh!mfA C>G* 8Ggߨ hkONw33m/+󢽟]Zw\:G[tCp9g@WB3V`dGwY#h ? 7f@=W740 ӾMS75Xk֧:_Nʹ }wz2l=kIo(wRߏ<ɱg{+ [{9;OƮ}Qh/;~c:08-J^x)EyW C6yfo)4,p!~jbqD?|CH!{,>]Gu_|o#/I e&%3חD[ֽGԫbK4We& o_x&kmCooK[$چ| NVvWswGؽqjZ}+5qu`ImWf@Z\Nq72 zPoRL}rȯTc59:%YiSuO>XrpL>AK_kׂVTE" vvmS(~CwFՇԎy. Ŀz4cUl#Mv/@Zݥ婺ȈF눷؊޽Iq`:BAquZfQ}e Sdr㘾`^o1|)<_zԡP=&+ɦy,p;󓖼ģS {c2^37 X @wtKcΔ1 pa4bR H0^zrW|5o {uoyWzFK6R nm{s=]'ʴ7q|w : #בk;}on2v=5DyS;>q?9xAV`ugsg XT}t#-S hW\Z pfMʼnV/fr_uޭhܑeϺz.b xnSq@j 7?x\>ԟ}(AAUv6G qzYs]+xǂ;#gI;]')\O稏As*wqR HJ &|awڒz>?yi_Xixql^c7G~Ϟj]]A4֯=wYeڑꨥ'nuƣ_mUڰOģδVO 30Ӝ^ ,\_^'h_S菆^H@ЮOFn/l󙭯S JT8붙a~*%t":c'MccE[ͩ,Fd=snYwaӈwJ:BCa,6$i63$'9[#=۳_U?2Q7nҾtJI`|~vwBoXLV|~h#KҗOwxGs_-]}S}iz$?ڵ8YgeЗ|?l`޽}Z'(**CQ,o)>"?^K `I}NKq wl)B^ F}(*ܼ{8tg[rRAuӁ Ԣ>3[z: o ~c}MMFçܢ#Qz!I&u\a!Pκ;yy+W+QތňcK1§/{\3rq1lg}BC1/sU|EC$g'W㖺mGhf'3@JMFç C0?ݯo_6m\ U/5!o@ZϢʆ޲? ?ĬGp:ߍ 9ȫ4_:>tNZVc.SuT}l46=~ɶ/sw9[A+]ԃ>!yD?"Da~yNsZ1L˿:$=-o[z{夜{bkj[Mxq}.ӗP}Wa62ѿY܍coMf{?JYUaPlrоes͜T'Q=o?b X[u7_!ug6Tw?u42Q5  B 7ߌdZhgQŽ.'{ߗĿys9pϯ{$`܊q˰pCQn~¹~짽 ɯ#R:pI6Ç6Fg踻6=uqR]y9Puv[fH3OG~P6_ؾ:[ }V][NTgJ3[M͌]``g!]ȟ"^\~gʩWڛ~NTEP: k\l9-ip";;xTak;:F&u$Xt šVQ}ٲT_kơ?w.^R7{un.ct9;b+gZkM#}OL,kCQ}ôf8'f`T3f|A+C~a'ځ6o(5{U.⊒?gil8lD[`u~>1.l~Z )r[ױhʛ-Zޏ-潟cvߺ} =P//~%"'5mj~JҺs0x H7-Ez-=&[ ; jx`gcb:c5e~Nԃii2%z*'F?9kSg̛f[S{ǏQJF>3':"h:Gݥ%/;~-b*QϺ_QnQpEΜx7~]zPOFv]nٯ= }{*}?ڟ.f/13\q~9VӹC?F&e#oH@ĽgE Ю"ORb8;T,Fbԫ |ܭܪ{mI/kRꫫ6뮟Ȝtgs|SY&6lnPE B 8]*K=*ݺv_0>H*Jຘ-79mbyowi>13ܰkR!mnuLXоGK˶/l9Ş>{o'`8ԯt4/%/;ͅ{ AKg6Pʼm|ԗ~bM V>XB}py?сhwVKiEf*^ݩN.6l8FBˎf65#l/JyNfSXE椞/p޺ KXޗ{ ?N;Q2> u߳_ Y]La@}MN?ў*Yþ f|1^UMW)D3 {4 ,3P}쫞F?ߥ%6ؽaɌ%8SP! }[b5 T847n^='KďVQ_ Ze~`sy%~-:a3ւ #6ǭmAn=Ŵ~?s{w pn'+Twzxr*y$ǹ\ڌuk~HmW-ݎi|sg2`jnB+ ^xt|/_`iQQA}` JTOW<>rC GoTč }{߭e#Hڋ@ܡ|78vso)n7\d|NGX9XWQO,>Mo:P 7-KLb_߳o[2~$S9oh됟 M&~F@cq5ʹyp Wx$SPnViʇܡHxjC"=DwUEङfaz2w [_6v&qAtKlޘ,z/+>x _ՐmzK'q=Ni]M%(OulV2o1ړy' ډ~'kD ~>? acکS(/?m JXDOO\'];|5jwIkP|Zi=x ִ/AƟ:OA/Y>],o$E(gu:'5{Š 6V@f3jLS8~3;P_nNic4 LAvu')'xT B24<1xw4'guѓ$٭W S^fȿY#Ocl|"8n> Gc^lf:c~0۶2j1Cg#I4`0wJGfﯡa_x=7LG>"k;{ ,فU8n4_o׻#x?_^G:r=60m7a^ap!3vdes2 lg}U"?e3O @@Ȑgj5e` z< $.?L&Ϥ1y~n5_iyG|zҾ(q}&sO/+w~VvmM⨭/Gf?=?c^g>Yϗ8ӀqMwntQql?^]e 6|:3^2>M/w;1ǧB2!dFHkQdT_?o9&\Ru&[we@ﶲj985ҹN$}h\F`MjyO7ՕO~86vV1_M}קQOoGa=[SM{{itrMprxà=U}~]jqlj{G`խMsVG2mD/7_Nsm$!{t!`zs+`~'(/fc ob<^ݩ3f->gcysxw+OW)85K#,3r}u\ ΢ޞ JC/ 3o`5߾p:{j?ޔy:w#wyD#ipNJApw8_E;/oy.?YQO"sb%n iEd#A@P-`9H@?W( MBY4WON*BO#&} R :狆u@}M€ig?UoĮ%o-5SqxD=OhM00'|m$mC5A8noHE# oh:'`ȧў~t;YL{ c4_?fl6qvŒ^6[Ў#cMwqo\?!>G=ޚ;$ cVLf5: q E(bq)㋻k"ڗQ@M vA<|΄hoKg`r~>C?!Fon}OcØx^^:'taǕ;GsyT3]NQ9y^Zf{:EdP_CC_;vP`tڎ_Zp7l-Q.T+wxrڒ<wiF{, @;T9~IDϰtXBeɤ?G|Z Sw!v-nqD@F UG"nKcrXgEKoՀX=ꄪ9;c3P5jKt8Н{15dN.E^߄4O'FֽV ^B]+4/0; k.rǩ^(7nxU 1~}nnS2ߚeUNIg ޑ54PCX0: ۧ-|6_ ǸvPP_f )"ak;'Zqth?NiߖIJ ڢzuu-r qSVcoݗ 8 myutʿ;nӪP~ø89YlvU8~@v>p_U# xBWn69l+B=Ζ]+fA}*K%@xE6p$}>z` C_oEY!Lu`GF30=)?:D\e eO1C1$XM(?^1)5q>3e)XunEw9} ǡ+[񹗾;[DL'3c|&u`WJc}Y9Z_:fоFVO)eA>qV{;+<&\28t+y1d?OnaI''`D8-{{{V9Dŏ[=Ǹ,{Vh5Ep]1:បŎjp?v_茻P[d–SSk~s0j-HUK8vIoUux}|`]@]9?nZLI-iljCב7cT{Fw1,1~<>%齜NGaSC͛?Mg {tx3= k'Iоթ+BP wC0>vqGunǁy+ɼ;SQW/;e7cyܰ꿴zWNr8D;D^nF%~2zWJMԟ {@vn N y>껔dZ#?l}6ZQ$/<|4yGU. x ڙR='Ɔ\ {>߅x=>HHQ.M{eq?zlepĭ Ko?uڛݜ+ _D!3˘oMQekI]Twt ᇀ]h~:WjmxCzط_&f|aQ~j71\~H{|?Q!&^;T(_^$s;@=mnھ߰~ڻgNp헆zgNq@O & ==0fMBsڇO}Ʃ~ 4U9_߅^ʇ@4#W*tqN*E xc\/2\qCuI0|q (~ >;`Ã\"? ['[(cSH9/E۰E_3ӧW+xO}gOY3ò'ZFO*`Z3y7|Ecr{[cNZOV~cAUng$'-u Ҏ KT{"q=CnHPاֈp|:kיx`lBC]\G@z0(ӣ*&,M2cު{wLNy&LE}c'q~;TcFd)bދ㢛t>smU[[ͩU iBuwr1̟w<ܤ|f 3uSKbgL,QOL]ygLh}~׸ΨݔtVkK!>*ZW#_PI}lQ+K.vjaoҦ<!a<\L֡ܔ0~kXUҽ.V|A;c+6yt=R a6I~ηC/: ~<y"ק u_.݀1U2ch_QtqsQN a-:wi'ac,Owa$74h!:hڏs?O2oDY N7 U ߊ9<qV;Q޲ak'7֗s[G>d\U=y yzqL'9ůMtn>7??j_ C-t iWׇ̺uYJBEu}dK_B݆_V[~_o]Z~d]:R__Y:<sq"v>7{>Śh_=h{ԗ=ɧak݃=Z+CoA!?M}m^䷟'O?4:~l/<@^fnگ?ZWuO΋(.*|1UO?Mp~B ԷT/c@ݾoT~ h]4o^ڶ_"e$/=({4O56 `Y P4^3s2 =ԫ&:߯߿,8ϗ=r&JƸY|9C`r8ÕW4P>G>~ +W_!ukL ǟp)ws/ܫR߇YȋK>j/(C>d_W6G}c&O8nЯ߼zP}"|7ꀭ#/S0UJ=x P2,3pGNF>?}Kig9 8xYgg|D0yFsjB~fy`WU| O_;,>A<\P "_2kmeo$'(8 5}$آg,VoHs^/k!]C+VEG=h_NZ#zwuB]?r/X7TFE78'(WIC:ڇO*ݪֽӺL̓"eq.w^/>u{,9z S;s7G:{^aدރa(eh VN'>!Z${~`5:zFLE'O<,ܣ>Ԕ7 (l7 >?+R_~w:WLJSiOƺ}c6{~GK0 ~gm4Ab4 V62NE=]y_ųi?8 ׁ6'(~%wjE`:p ;}:M\g:`lKhzS-̖O3Oڏoa*XשKFpy {~0 sɴ v@hb}{'ǎpS|-rbF#s4S{JwhcЮoGSd}I|P}v!n㻡x{G/TztH7Z0Z?t)и?,C?{] F)ow׈<^bkZΑY70۞B|dch\G lm[Ou{gvKC v*:wFV8T}CU~lb ,F\+zVV}810r)h$`lq_ySaitؿW3uA盩|bJxtzOdzM+_<}ﯛ`3G>Euގ 엨oRzsliyn8/E%8u7Gs&F`?S}v{7k"^x=Sdm:_]݊֕.:?>G|e/ۏpI^Wws q~/oR"ZPzs{Ax-)iFU߿E_p|R6qvԮn-h-7$rw'۴G''Tp{Wo# I-pF2pq y>YiѺ:u90?g}ڢ}v6}nSeka2)ʫizsFOwo"oN;0@/?NaQ~BeD^u&ޯmDic,Epu=H89_}"/G}CWa}W ׭f5o|ldDY}{d`./s yX~t^l-y8u#o};J?l &%XSMvLH]|=\r:Lu 9^7MOf{X!N"` W`o |)hMM/Q~5L˴?I&p5Oٮ9{GTtaΏ黈3tQz4^^9b\pˣ{ۻJ ĥ)qw7LUō4(ї/UpSoVDWߵ*?Tݖ2>4%<8IY*KѡevCëO5[8 _<"Ed[~ƥ¯hwo_] pb|m wBۑ￡1x0b .7R} Iyc_8]Y1{%i{x[ b wyLg|A5gO;S)5ٖ֯-<.'V\t™y&Q곘ۡ@pYm'!?eN҃NYΐ< 1KX~'NXofVBdnq^SdnrZ. +?g{cr2 N3*簵_v4~ ?zO X>SM+9FX|tzόIH;o3OMˑ/DuLM{.?t-\PC5Έ)ѿ'ds& _d qX紪-HA,iys| `]|x<+} 6sFoj;iݝkSdo=G/_W熂qެ ^?LNSTo_X ~RwOGh_[Vïh|Mf|ګSciy ~%y/8VqBG;g$gOۂJqښvނ/{ wQQ.y3 7@nsp/shz1 ƤR@?ZW|8g/Q]c2,o=?aQT6ΰ 3$ d".N'4y]4^XJC^C량-~YۇdMC ;x@e ڕ[s5k߱3|T~)Ng [2g(jmXԟJ4"5H^O bc'=jO9 bvq(?Rhp3&(sykg;;1ZGb`Dz1kڅ07 ЎmuףW8u2n3[ Wo}Z*D<;#ߢze+O9bCߒN?7p(򷟙~<@9qs£$wk[j_G;^:2uGԦN~э.0LYhUG^_>+Q26n}٘ǫ?3%4{X2f8-`LKaTАR+}~̤s br\%`85[|Kt !q EڹKĬx~(w|s(_XCtMx̣1.8O砟Fs|wx9U>TqP}d#VNE6;5nǽG~8v5hhݷf2ߣm> 8N_F$dkWdDM؋tEy .TZS~S9 N hT|ڟ̺WqCF> nOY .OaH``) ?]8OV3M5vZ']^!L7V?yet)?y9%?"_~ii银WSCd_%ճw,CF?vPZiiSg#a9 Byb`lyJyߺ &AsP`?Ac#x]g.' +fw;zn;CSMҦt)|kftWڧO>W;.e-qw]ڕhwr5l:3y??A;WTڂ/{5,0@ſg.Ճd*?z"XFb] wm\nqK4bޡ?Ё_#]k#Owz5-αa) )xl x0Z[}s_): ɪsB c~ ߮FcTm}| CX^\?]q_]|^;9$h~!>C7c@o.ڭ{o iG|$$oq.}s{qQ ,׭JgG㞴.>=O"1?ҫ6d"mx_WhØGRTm1g%3ى+{~k;$CsN|:c߮FC<ݮ}-_AP绽/ /Ch>sosy}tz/x`~Y,n_ߝ\ĿÞy>3B&~&WHüV?d+_s۲@/h-t3wE~"]>d⟾,1>%H?\߭N(V8Oy1C)NT>ͭx ϘA Z}c92{ZoC:$v2L6籥oCnr|] `n$6lj/' Dfu9sHM6~G&ID#Yp]%nNGhǬw*/nίވ~gȾI,sH`hJ~Kax!nes>"_u78>ֲ_n=,&fIALM 7:ȇg;v/*˝37rgYUѾZ7z܄Igz~n{'ҷS75-է'AQjS/O{%L|}L57mn%dU)󚢔sZq V~+AVOLLU(w qwz3>w}6dK2eJW_}+Ӏ1|+;!)q0 7QdOS?fGW~/ 5U:>7 knT֥~ga|򄠭0~Oe$⧤@nx~1";=O%XS_ʤs ~*W<-KCzE~ [_YMoRs&;FKB!lppX6Y1(|'8RPWC(vySμޥtAC)WwaFAvvUw—'6y0}*HnFyTE'{Hh|ƍ>kZKuWt⎢PO,X%ǸI?Ugn]+Cg| gi;GEf4^(V.Lxlԋ\#8ya绳= }8e~9?{vv?)~b^߭X~{^ ϼW]rn<@Qb#>ڦaY6^`c#`N.VAZ81|l(!1}t\ \>,Ǹ+A{4foQ##޵AWt\#UK{^2GG\>g|bMm잓co:WG΃ãQ_ùu' P@[cm+ne-(Fu0 oV+9UݹUj+@ʋG(nbs,>{;E_u˛|14>c,=Ge7Π ysݏY(']oM0 FGv?>) sWxO2:<2o/.튛<?Ԅ2/Eu֍RSP?' tW9uh1~eF@_^ D#C>jg]t~ xX~+hqGQ@ur^牀8^/||Zvq޻˂9d#j\S~xE5hu3KonZG]}F8 86+u[ӨE? kÞ.S tƃ`\?f캾aǿnl /|Q37UVZV+/GqRL >*C,ڻf7_*nEtJ~ Vk/LBj=.8#..W) $ɚ7mXzZ==]؝zoݍT,>J烪o!iy^"A?SMqVybR;%N`Pm!j@9z+70ϴAGOT$#ޤ#HOm=)ۧ1xK#Gخ>ͧC(7mBq<ݲb.`@}wk)ϭv0;ؤet酸Gi>W)M?Ox%xzM;l&ν {G ?>?Ld%J3 qʛj}J6B9&֜EdGPfߵ^y֯w⑷W?3+;k{^ wf BF;\xg9OtK!S]Υ6M`[~O ~; }Jki;?0@ʺDq':$/s`\pwQ]׈ z#4Q~sztirٚix}5-OS.ۃpQ I̓<ԿF9=r֍aM4|.%3e>Y+zQڛԗ9qչ˳~S wp'3G/r~Ip m߻(O} `e/èOyw6VcXlZYC밆awte)8>vpv Q6C@3d&1#'[}瀨e8oh,MR&-k:/$syϔmSkrsnD%e4C'}amE'"=LoyRKoG4ױ_qޒNCPvCt6Y缔E^uwͦ>o\*^yQF7g+wϼ3p~C{E8ת}^]"|~:q\ nZ w|xk5M~V5[tz_qܚ1å+{:vį?MB)@۴Gsyti|ϓSq^zWWN_N΋ׁ+q^r=~SRDJCsi2ԏnɼ=ZxD+2>Sa"j!;گg.}mG]~?YTaW^ @3d8cXrg H}e_l6}^i)kO}d._@UG)zWZƷ8tօ ~y<}ύ譝+^kP:Oо>/EFU7>U;!_0ރݿ x>!(O}g('Xx<':t!Y1E&tځǃS-Q~ 4Umն;;9gËu?3e~uuOη_K{7F}d&kG{U7k [ <Ջb|@y"1s^#ӣa8y:ٵ^XM {I?I4;wś'izV>t>Á{~ +ש~gu=HscGQHq`߬bٔ1^,~v .>p]=BP5d>;Q Z Q?Uw? o3x`7*s[~ h'" |ȧi$uLG P~8řrg;ϺnT Y,2l0'3:f{ Yp+xt>xA5ڵ *Dz~n%HvM^x֧X#>VoJ-ڕĦT 0!z<~=FPڱBO`B5IN;<|-D9s􅃷+{OKkIvZ/l5QZ:MA}`Q_tO3t_?h9kh'C?V~ܦ}OέX vv=$ss!(ݻi 7WJ _ݻk߄^Z>ms dXQ0qTK8lB+/x9a&7/+c/q]Omu0t)^E<8oqd!| \<8^\/qKnmq!3F|tW('A΁oX~h?Sejc x^qfigG)9D?t]^t-zʇSOVo/C9k~} ed{~)oL|X ܓmWỲ(ē,q~~v%'Xc'*qD{q *>I?19K#~v sp \zWCN.nF&o$|ֲu="v?Tu=#zUAxڏٖ'Q~=0ܴh?;3e-t7j/۝S~뒊uմǎig@*|i}1H*UmJljhvnKeaTgMٙPc8nQ0S~ArA`\-,|_pzHۚ_ `GDѫRTg$Pp_}:vt }OYLv~ u$Wθ ցa5Wt^wy7v9Bp&k<{_`q̥e<kKT}F&QRΊo1kyK*sh,D)eUm(o(Z4ͽK<3ұ?/0U8 B-ވ;'h{c?Wvapޛt)@ ;B뷃;B]8<C;5:o tER껯^p$q M}n!ؕ:yrTM'/w`zod'$\V$sIgT<2ۋ p8[ ?f !c/Oa1nAwϺ]g?PoΦ7tM#b6uB if}w2@8d8Gzf 濚Wn.8.E,xG}E} 'O>< KDXQ8C_(|eit p7Q>-<_ho=e~OzD$D-<$ PEv?)'Nr G8 3^E{ )?g,pmxܒ_viD|\M~ ZBc;ӼTiKW;c3ZUBФ5ͤ}3U(er{qĻ%73V{oNokm6I *iiA=oq&FT֮h|hߺq~ l۴T|ʝB[!vŧM? %J3Ҋޔkc.u?"]ϠMo ܤ&OfwP]҉_ql󈏧R}$QYK~v2S6W>h3YI[K]QF~=vAkG2zz?(y:ڽDuWj-?O N^F35!9/Nk7MFc|QM]O$MuݯyahJ ?GOq8>,08עgz+LM? $P?ΏgZk+ \!`Z֙lF5|uvy3zO28 [UUߒ6L{ Jd3o6pmMq[N>g 8ݿWOq_ÓIT_YzGt%|qQ(f⍚AKܐXQOAFc̳hׅw=1_tuvb \JR^9?CS*&kWX$ma[d_`7vOƸjԋݙި?Xx,L,lsLj߆ K]QN8ڗ̽ww-8nƓOfVBӽ='4ό9Aѫu~ɾ,/h VK5"?p<{'ڭzٹ爏=҃X:hSF8n2ҶuFl:ߊU-z$~.rq HAfG?mڬʥ {(1w5KK뻝lϝОDN#쳢]h5,o9+Bj#O>{SwZOfގ P5QǟR?`_ æq#%s#]Zg&h@e [͞=DRE%Gg;xq}Mc e־u;=Qm2Z Öi('uG3gn 5ۂxGK#&hO]n{COA۔߯yg&tvw>di]ֽ_5}B*\Arv~sw80%|D |zB?ׯ7^D~铖追#8,Y<@~!7һʗ?& yk*'>Pу01zn`䶆sC?R숛jƆ![O!2yGDsW &"hD9x?&v\+N<3ܯD~'tp{SE[A;@4KFω{`5#X`(TP94e `H񷿛D|tZ9Ͷ|c|,P߁JWb|Lu-̋ ]zswt_ WeԷڂ_,.UmO9qxOG>f: ?!wov;V|Cp#E? xNNc1seׁ OUX) 3T_F.3 !WDd~6`- ^]'ӴC{p36~Lh'nǰrn`-?=^>n;;!IFvX/爽A* A}9$I(o,6`kU1Ge<|=/bs>?ZuuY3ڍBbF}4SEv>A˖+ً:kl#ŁI0Q#PzԗWea>V8\B?t,[FӼnu"Z/,yԊ#t>;5_F۲k.?8%I.#*SN;~_Z|i+ ѥOq]v>׆`OJA/0_?qzF;ҿ#Vuh]ki\? y-8?QM6p>>v>|\r ?}O;qeDKn_?U/b97pE`s451k!pj'7`sN'xK|J/˜CMn|Otty%Ɵ}Ev-3IlQ9 0ǟZz-X$C~H8k9:@%`k2D//hY<#7OiU6+Яh6Ǐ)e{QcO+);9K}_ڟUٴd̒oyҹ/kBOCqzc&矫75s]1S/.^ɹ ڡ5EU־_N}ڄoeD|kgxv)O`X[S2 ןi*͏9v%>G׍:K*pC'tG.O8Qk뙧+e=Wڲ/K9:>A0B cuW&LIyV5M礃cOsG6K1 ?ߞ'πdD ,¤fځΎ%GX%Ϛ^FP0no!N@YՍi_++>F`@ ·srS rHn8M"a R6?# fgx֐(xH:ϩ| Zع /q|G@~Ӧi@ҭOoJQOIӝug6F+ş֢təcà %dQ0h_^rD8/Y(7'CE=.NE~)}cm4Xg^'pive7/{ AU86~wp1 ߫yhd"'p7͇gRrO`^;0~CNJP5+~_ցoEgF=Kk8+z՘ߐTF,;c_# 7ͱ] {ыַ| o.CUQl`ԧg\1{K^sP)?qu>կoI;a ވ*aڃ^~r"9EssĘU9rOm{REc>%wEL~oE$sNus^y)pDA}iѨ]=\}t+'}bpVaĿz"zA*c D:!Twʡ}k>O|vԧo@P~w _|[Oq"%ptC~!ް3%?֗ Y_f^/:C{tsZ F';."O?ejQIV]ͣ?vL->|Y> o-Z״P^m;g^?|88Ct{][u)qC;l'՟w HzXv"sw` aU L G}1 2M?z=/&Zkn\nl@=,ͼKuɒV紪k ZB$^Ԉa%~߹o/ MA2IQu B4YR]1"?)s7P#CD.dEڈMyaiuƲ,`9~>w K$7_Xű]=<^';n=}?.e{Ϥ}O*Q/_O_CGm98uI.sk>[x$;TG{S݃6(d7-܈v^S]оDQ~&oVT%(7qCUOzaCsɿ}4 vmN^Eyd'fǡu gþ((~X#שܫOIR]ڄiLO1k#0#_oЍ{^jiN ѣ~:szFC:=NbTq; ]N;qoH> o"UpUl1{M@2 TMQr!o"LK&`^AB}P/2'DRUQA( _3;\ XZ7KXBqp{\ejJT* /e~ᗍPV K4OGQ}nkBnfp\vuؑ)3ϗU]q~ U׸0?Kxʜx_Prg0 X~@Vx}{pFD`!y (E{TL;~$!# >ۭU|#zOKs/p<GC^/@~?}Uˮ\pd0} \'Ub;Gߛ|.)Nz0FoZ{&-k_gR+ĂuWx n眾RyLz>ٵ 8f3bzפ?'-d'J9ϟP}z|~38=ދrWyynY)Big\A-ʓ=ᝑwHwF>q|vQJݓ9?(8*ZU۳Yς{':9~ !g+hrgɁZLr C]1}qc[kP?4{}^1=gt P~˕8ǝ,ý n{scԘaK֭1}1 iYMb9:J{ai[W,~WN`>Kͯ+CwvfOozw ƥOo)?؛c8̞ mqo}$q犴vfz9S[31:$UW4}f>|y/iة&naMG>8zLEkc)?3;5r\QosRNRcLzl TwB.zS?g;?DiGi|>[ǩ^zqφU7]? DgxKqw(Uߍ@uf]#'V[w8ǓGJu 8|K:ރOt!ZWA-ws`1n(zGP5nO: /ɛ&zzOfH}K?4m{Vrvw5 3|a`P|g|W+GC>aU/)kiKTsI]LM:=B3W`tH3Pr4$~?y|J0H>jW{$N~=q{=*@șKaйPɏ|6OkK 뤧+o8K >ࣿs`Fsw{§qG?G1iO?ϭ܈ fjPFE{4Tg5qC^vaF-=]MRS,H;q~es(滬Csd#~肼\:=HK8Z7'>L{z~Ԁr47~o\w#hj1}Wv)!?^^${oT @'V3љ JMWJM^9,CEQ/vVZNGذiryF=q*-!9#@x OiNkWҢMp~\Y#S1qb_|K- ^AE3JP?ߡ]>3EQҴd_{G#nو[uoe#~~<4H/^[(YC*+w)|+•ej؈^;S8=CM-/rqp6̾yc]+ KK)6G.Oqw{qRs&:/W~xS3u"AF6WQ_3ybq⿦w)NːWQq_2~t([ho{ʺ6uɡ7P~n{M+ 9x5`&CXV'g%n >b*3+zzoj!uH;3A" P_fl%嗌fN5w_JxCw'g5D'I9B7p;Pnd:^{a,'8/lMoVCK.M9_P>QLҳQ63Rkm0>V=Yybd!CNg>4o4PREM^O-a;sH'bn,^=oVrscȥkj/a~]a:؞E@p3u'߽ #o,3ܦOngeZp󎉸k8}CwIjxx琁'鞋Clqެs7ʧ=/Ϟ vGA`OV٭T\lkj/M ?㓽/q@1D 6GYgo?@\V}6fv/"`@u=Gk_:x#DZqO= rI8/hZ˨bIG fd'9zt5H-,{O>b\!bxהB|l Spܵ;ʓGfymM@I|^~z)pݞ~+ "7)!}jKgG=ɍ~@=R.{ ǫ=2D(o @yCF^n#DNx+g< \XQy$VYͩޥD)&a˱l }_ahAd߆ޞR{ ze;qnfk$!ڷ'-p#£>gv %~a};DkJB?Hv<\'TyGkg޳5e|\~F;W)'eߺa!pL9q >(]mi4w ʓW6+=jŶW?,t >ꕻӣ{_>x\!3z703Q^H1eRM/ԁms-}6w:sݯg#.Oo>?vG0zXQ~wue; Tg>WZ:υL4)IQ@۸DϠ}z4]S.V`Wpt5\Z6G z5doǛ8>͎> QX QrX /_jy)_}bqhÝmG+6n_)=OAU 9[w0M_DMhjl"9qՋu޻-g}E yۀ=;UGjXu?Zn\ח"՞84S;ө`𓸮?Pթ+$#W?ra_m|Tnd‹RjM%Sֶmz!Ib=?VjoJs!9u i3n9˻@}$͑1^5vg??Q]JFr٩+S2 aIEwP]n30a8P.<;wqS>4#qFH>$ucH7^]}P[{}ۧ4TsP_#܃g}'҄xYGv(iw".+o(oMo[OS-1Ϣc,Ey1.{IϑߪtՎpjUr]M},NFzw}+ڑukSote?;4;FP9;/h?ꕢX2y퇇~.i8d?fΫq0ۓ" nt8ҢE?k̊; 7Χ@^ߢ̢>M퀛tA|];yGf3mͰ@T .m ^kxPq|}Ɨxo8<0[Em)/bv+JOZaIm)0X}@}*ڍSmihĦO]D{qD-֊ fYx8͆Q^/ q= ʍG*o+1PجʏldYYE #\+w'vmοSC. c5\zF R٧z;0WKRA?&N^KymO5~)];tY禕/+ܟ~P$=r.꿨 M840eonU(uZw=Q'zj }h{ڃܷ:I/npO>pCG!nV8 XO)8+']ջ>2{/A`)9:L`W\A|d[MB|hSAFc o.FD9no= ңk_E|5Aߺ.Gb~3媶;S; ]6NdN+< eAƌuJ??v ?C!LC/RvXp#jB2O?ߊo$ꈅ8;se?7bp-0滅m5{sp7r1?qGc  ?kG;v04{Q?-D9n = oZ}*fwz)}dL=@)nu.W/ ٦;Y5?Z _gܹF~/ޢ]q<۽2LSєC13\NSq~:R׏.4g( e|_髴!~"0A_9sf?)ʇZh ܴLgoe 8Z{_!_eM:>X~G0}jw:7KCzר.`?ݺ]>)~}v 99xvx=5C2EY`e}At0O[t M.* Z30{`ۿy>1Q,b/_g?OsWȐ{=+c u-Ԋkyh/lڷ5'FnQx >^`S~2Ь髀y_{Os*G3A_v!ӱK8wqº޸ïߪ߇GÈ/wSkV9k1xJ"I< NWccX^ۀ}CK}!-ԇ7bBƽs'M։x欉Wڛ72 qKbWNy`V(pX1nZDQI1QXFSexv/7;pF믖 wƪ,Ozۚwxd2zS Ϛ먪]HtڟD6MA^9M [QDsnq;t #g&D~bxh?ѵY3'@U 6|3/ ]^@gScS_<^]'AAu{ukmK^(^TY#+/;iLIMN +'yRx2'(wZSZ_eq>&ogܤ;'ށO7ڱƨzq0EYDD}uߊmV.vv]G2 a\B g>kr{%&0C?D 7orogD?yf1ܾ͟ĉ_{HI7a=b@8w}WjxoI;tIһ,L Dv6 fއ~Q]?.. 5s$k+} 2p`\ѯ [my*!^hL0/i'9qe*̕ʫO > _gR}_\r/~q/`WMF0S-6H?Vߐ+ vd8]NKTIv 1/= L=𥉉-u2>-؎g9sr¶{/yMVyO\Y ZK[v#NO K#^|I{ o x(o{;Eˮo;z]| )=#^^ͣ}W\0:.^(_YAv%'Q}%t0Y3Ϸ#i>uy-p{Lm~wť>iᯁKOMU)&۔? 59֥1_oa5l{ ~Yr'o+q=&zDiw"뻜j`6tBOqW0ljG$bK|9i6&@=YTo_۞~W -W\۲Az{ oX+|wzOa#Lyr{pԊg\ @^n=KW{Vrw:T V^ kofR[|69p:dmg~xb:Nܵ7ŗG.vј7#.OQ^MߌiwK>{NoIN"y(c(P9ꔶR~%ڕAgjs֤ HCyKgّ鞪vAS:.(/ΎALW7w/& t[لkju㲓wFtOPD9j*j1 B A iq9 5l4]>WGJHWsP냐.㺳k^'M?q,ލ>% te;6}9k& ߰gV\E?b NuEe QBN\'?>ۉWOS͎ۢc[47;GS^֘vޅf˂om,0\a1.=D_}x*i6_ 9"}\j|'0ƳR|gG\V(*Yw/UE,#/<NnI\/ȫ_'C_+[/Ԡ׬>i@7;¨G}-#ɏ'/ɾiTy-f9G-Aa(G);݉ֈ)Xid!~ۘuKQSDn8k5ʇM}W}8@ozsb%#z( CY{oSID埤W5!obF2eRv>_>;6pͷEevFo16g@KW`\sfp2Pti+u]✽ot؃f]ҏB=7LS2t6 ޷ɵBֻ>E>9QRE%~>10A{$_eTW?wT\8n,|)}"0gq<W|0U]<"S._f n͡R8gnA5{,Aj.뻿?]ZH{egdO 8@=W)T82./T=.#oIvw͑dʯfJSstq*'养_U.:ً/:DzB2L[O<]^Uo3hGMM忲֣\\GݎVZ:QWфv)!_ حzCs^TuA٣\֐]^bW0ÒotEs1s 8OFpB :EMN.~?(￯-Տ- ?rE9c*f3ȱT|_""VշG~ TLm]3⏲͘_ԆE"WQF6b?^ [Q;,ҨRsvc>1otVc[\pp6ѾxFoZ0g'4 .v/]xr^'ѺԿ?ڗ^/3X7ln#ӛfb uaD>4+KClJx>"#+OZ<b:L=v hGjG/S~{2ӌ=)oNDTm9Âk7'M{5ϝcDlkqğky EOx- paܳj_\CbNu#|[#>w~Ju ͏P>`hYt_|bh2?B+1:x /þz Y^ɟk64'Dzl؊dpinv- w}D.ĸ ?oQ֗/˃>]@;C{ۋvp#ԅ!\~r1 ܮE^`Ku](\~M˱Fyh~v ~$pDǞCB1M?u~Wtd0d9߂O*#C9+g !JXivwD7*'{8Ao؝Le#Q~~~{H}YFʏ.> t;Vˁ{hqozOj{åO e {_[f7qZvnyq)?~)k]σӨb6m$)-e ?7O|3^=[*%M;O{_LiZ'"wܱ ^dḵP~s D<>떟pm={ G}昜uZ{vT#>m{oZI  s|zȺqN_^[ XᴾwQ&E=[G݁ɦ`>Ə]{S0K¿Gv1PSCh_&3xsQ|vIPn4G߇rqpqL#ofa_afC !CD8ι=uW!ڏ`s[;R~/u\IF7-#dyK$X_>6spBn=D{FVW}+Cy5cpW&4|K)?cu\'ﲉm;Gvk5.4(]kD{W}'fZ Y+稀ן-1>(osJ~7`(x=/kޖ6Yu Oq7<#ж#w xn\urեaE~9>^+Hx_C_5'ǓWfE` l6/Vu_zzY ܏.\"n*␦xt/|c7It\F~jHԣo8e'kZV6▾U}Fq2gغg[uJ\?؛t,HynG<0k]b_?vO񟻻Y::l0nb߉ ҖG^~"cp@qg+flC?8|̧iI)uq W66QmX[8؏q-e,2f"ZA&bx'9V?v4wqt5c ڑi ia?nZ;xXτւGμju2[;jN `^/_Jq6<$#8OM9{b6&TU^&v0"]Z,[O]_=Q7R+dNʤp\ؐc>/n3cȿj1ٍ;c۩kC~k__3ǻuSDN=nnc<VS~97{/A52~큽mÏslʟ'IKwl;< :c|'>b8>:/=*H7P\uWT|$g Wc͐;D'teNɴ𾞃?W{δqNь,ݷe+g}SB~sAyK߻B}c p}n/|>fzG 0b~N?[$fc fwg [Ò~rW,RG>AUvD8szmk`kʹ\Kcm0ӷlxX vvF!n:GD#զ\bAg'Tf4|mΨi'5cq5C_CyS1❈3G?wsy|qSP0nwqrߨSN?30GܔW~p>LM}N}k:VN_}KqG"Vl_Cϵ?zO(_ yy% Bvا#{b-kD* ĂuڷM0xw'9?wK<0T@9ʲAua|>8)Vqh1~4L=?Lf%>48~bK[3z+7oWƯj_Wrbv%> ׬4,};:XX?7oXLuv iqKa=|z8gFAl:ew{"?3_b69s/SFi7;v;?g| -7_G>_N7 6]7]^|bܣޓ)[T_|}уQ`nør]ſSO8M ?HQ(0Ƽ|0C(~qM{o[ۢʭ@Ο\ pE$Zg~br?4{ؚ/g.76Px֢Nv#z Vp NTq}Qܮ9 瀋s@PDܟBd2:t5O\I6XxЮ ug?ŘΈ$ 䱺JeDI,yM1qXI,zj\zޭtB E9u:3)5z޷)Ww?N{ ykݷܧ{>'W8 d?I'qDw Y#r4DMr{}a6v оku!c.+uGT:x!2۾3nWPwkt_ <8~1Ǎ_.o1>=ȏ_X7z>A©\{ڷlV%71ۚ)}1Ϫ $y o(?`i獘SŮ=XS_gg9y,O(OT|q@(O+Q]"O*CCUºGz5ϼ xÁNJtzu{41Cy C{8TLJ(V#fxł؎򷵢k'1\VFa?2?W{l==Ϲ5w&?7Sۺl_ImGqu+K` PVcF|p 8OM~~7Qou+)7/Ĕ?d_Yg5 mi3i˗=N'F|f+xP{lp[zF_ hoW/iAнn있i(O߷-ֿ@qu3ly)~z];{e#S>8-7oD{wWSuMG|ԍgJ Up fsvE[M vidW%xy=v_[ƃӯ5hvN E;31w_|ّël_S^G> /:QF~_n!?{P~~^9Z:0~;s[2/PM5M'iu"ʅdzpyMϬVWoV;cjO%Il%3=S['nZ;vDI=oNByxl{'CͶʱcp5=?t8=eY_Pi5qYKZgb^Jй>6FA=8^_~%wƘ'NˇI?\(~ؑ\4K\᳢ߪstܭ7ܯ]`FҊy<9+Qxa /hÁሟw+IrF68.  f\w'b|(1 Nx5;e]^? "ݷ Eq |;^x]檝'"# |Qawh_J]^9жM95 7]{}NSlecˉc|}J҄_csW\/nP\O֭~0rpHIK})| N4ҶX}a>[5J铸? |&i|Ҍ8hP}y:$Æ<ϵG$dGHW1 ?Po*>:2f8qv"O15?Mn,˾nx?.Y$| 스8aVW:و3 G/fp{72m¼NXqg!gMm@}1tNN`Y=nM5bSz{us@'z5{ _?q/.'9}_o#}N;7v~kTUZs 5ZrFw]d_[Zy 5(9 EBԩ5ySvG+2D䧯k[l^@>43ZCiU#]u<\-tҮ;>G:{<~<[<@5dLo|]dQ ю}ûhSp ܻcVb%>geO{_#~*PkǎY*R餽㽸a,IY:Gn"_M39/?G1jƪf ȫBd.y} (; #!>_HZFkWS;ǬqJlܧ3pIwئupNΣ}#1O̚WvbG}گAuc`yѸ83`]siOym:TǓn xײZS;~qJf[0#i;%yc/u aп!.Ig̷~hf}h?Ewڱ|{?5tqQQӭ~$qI|/Cpڟʲ[w\Wzy(Mkw>0%E?-88dv߯-6mf3q4vZOcoP<̻k58**񳺴A>GJ.1O0_9d&;֞:σKY+saf7m&a9VkV ڊ+h_p5x&v'f/9pfVh`z͢sou_J-.8'{rV)j5nbvTnlootO~~LC8džT;z$}Yhp CfڽyW[ҁ+E+o5' +evn5ŐOhߠ>6x DwF5 ]9jU@q9J 2A^R/?Qu3 xt^P+E >?۽1G,u@ [džvxqD/'fc/4rW?w3G3?sj9Hy8?]j?POz=A*Wcz_WK,LME(yx}޶o8Esuxo!bLޙ-GŘcG .ˢp-v5aPma 8M?gm3tjcex'wo~@;3M `X'^ &?8W5,_K6 P]p}Uq'_VD*?(҂(_ƽ;tPF2)7]fu [!>,MC>9_d}Gy 1At})EοlF]Gˬ}TEk |xA-C0?{F\ճ ݎ\Gՠ׭hm#*W!o4gwA8b9wlyY_F?nլ3EoCd/y?&-P߶t$9fEw9< c6ڗ|ǞZ|]Ip&6y[C? ul[op-[s,s qYХq`Dr+X?9?S CVhN\tOve[q}]\KyQ8țaAA(ANM&ްigx2>G@`gv'̭z/Cm;0Bɏ8["Otqpp~y| ;|*CU;'wL Yf?., vh>C3kc7YH%ZQV]~e͹(u7yn:F[C~zϑx-뻆A W/Xoпܺ@WcqCi]N Q~>-cWNϙ#>MIs zr僧CܕGnq_%kE]>=W mI~ȡm?ŤEm)ث:e^Hcl׆EMSt'8QN?@߽ϵȟYxYhZxVArĊXwojNgN!CnqXX8ܢ"QyKozUtCW~*͜^C|4F{ ~?g>g .q=<9?.QoJ]яѳ.eo!/Sw >{nT Fǡ \嫹f1(`@y w5G\_}m5Ϻ˒uν<YㆅxXL ?W~<>"[)̝g82"p>g;yT7MuzwGEOv (xUoP_ϯֵ{ 6ut~+;p}eIV(Ž"z`NQs޳Y{G??ڱ~Q Fn'83ڗLdi4? lAA:̆oχ.S.[.WX%3)~2>E;3.wq<+Xhg?R#4?M +눟O:(.Eُ߬ w'!~x&A~%+~*H +0^pHI)y_(xv(?ڇh AOe-ǀXț߾?ҙٽf *<]:GԒ.]zgE!gxLw A8~E 䱚?>95ΗN֭ZF}<R+YB7 /4}nǾqC=|O'C> q,wO %A3sl*k6B`ȉo(S n.3o~E| ގ_ԁƿ-DGߕOOW&sG Q5ڻҪ9sj#z 7G/ՄgEsp>*횵oq0:ڧzp_h`/Q!s|&>ڕp'z/q.d/}8ص_D#K唭 _Fo  I"c/eZ'=}G-Ci:#/Qn)}OxAʥM@A};x+G0lR>&CC[7q5*FK;G%c|&?3 p_UH{tk@`zxtˇpQ~ G /}+:}{iԟIU 0fkgBzug?O=07&=N?hT>)Q~p ys_0 v?5fm~e/p%_|ht܉ux<lFPYM2h? :`Y yc)lҝ񾶽)Ws`я~?`y,<_u\f&pw&d!)-I\x{O'qH奂J^#Q QM<|}fpz4G}aH*T xQ~:1Yq IUVO(_|slՔtwE=F{,țu+ȿ_oy ~}me#iork'Bz~0c*+=^WͯPn @ x>?5|Z)Ŧeԗ8>3fZaYhzL0ksN 9 1 q0٥Y'{ɸ*8ߏ\sd m'J71gC[OKهфR4fW5/'um9Ik&^/Sig 8^~ SCܲ 9o noBKeyO0Lv;>c~?~m2s|rIF$˦zzt $^ofovІp JLZ3GQF\8tZV ^8.ip;-گS3;Ҧf[= S\*n>; ׿LWnx "nőm5t6 2/̘ a~$ \\?ؙQh!j󥭴~n+~yv~F>e+I^s]-F3i߹!n ɏ#:jkYW[\w)c15 phQ)8U}3?AyӁ}3֑yRބ7}?'$}FWwܝz{~Vzx t;)G?F* ǯyP586NB`1Uzoj%-#rRF| |6ִ9hQ}]Q4/bNnJ@#%ⲇsq\W&'npf,/+c mXOzJ X5B~4G0=SՈEŌ?1nV\:xDz+Jg:x5Ƙq5Wm~ q^%,;GNԃFouIs#6 >1y54¾7VުET,YBm(qٿOʜ?GO)4$>%ydECq1=~2G=ènXf:+؂"O_]P,5쨏7?+84)g.N*GxAuV #WE~7wLxA \w4Eӫ'ڒ2ǡ*-0p,'"RDNFʿ/}LoAp=-w`Eu?\ K/ %SK?N;<Ax rR9[Kuop6Zg4!I^awПzD*n^ag[u nsM9 zNFE k|z0"-;|"p-N ؤ q˺5q@xA=Φ/SF8}_[v Jڰӈ8>C>#fhaTz6ڽ>R*J~YL?kF8bf5p.~B1:el ]j]GSamYxn:,+iScP2֊Ο.k>>=ly`?:wfn68&p2w/U؁8n&_".F,DǓ8l}]-9. !OP?*¢b7>Ok*׾,0@nct;-/;4^vV+ݔ<q[P<B QLݖDqMfg?lHZٜ_ /7ơ1\_;׿֟6  bl&bE.ˊgxlx`!;8T_}-Ԫcs>>#ڢ4f H DҪoM_Ď&(kz9*z"추f;ːih? A3]ߌ@ %yo+=6ɨ. u hҩ7Vۀ|U+&WH0OH';>2ğ^[ȥ}F8x_MjQPXBLWhJcؼ8Ź#`0 ScuV g4CM f^7ռ`h`ϵx鯀w EE+geePx #8?zx וYS}Wu?}Q${_ >7kBځf:?D 5$u8>Ӷ3E\ { * l.0E}quԉƏB=-2֢~[=r|pAjc`+auByT- 8hbOxf,D{B}G s}2Jn9vo=R=ͼRoϿ{o giP>syA/"gboya$R<37\FzN&:(&bM_f2Х$&ʓ;= ɏ{ ]P.M_#)m&ob00~54#荶y0ik'UՖa?(ǯjv/BPUHJckpX>csk ;cN"f |S;|A05oe_`lhs5)9W˜LuowcKeMyH}oHyQy8(0.^ 8+eoNh( #ĝ "oЇ9?ڂ9(qs+꫾+nO{k$P>]c_t9G7S^}I?̻E YT>p|ωQ?g&ݴ1@]Zڡ_mͭʋJsW~XAj-Q(oOMieo݁uO2ΏS&OF2M@ˍ:w $#?a=cG8 VSLLu*)'; !{@hz ~`7[,y鎡UvB/:I`Gh_QHQ=:pK.ڡS ^/Tsj./o&Sz"M45Ũ_WQ^VAy+MAySقX]:׿Cn]"~aXmA -eӚuroK~ԇp CR\?6K~Xݩ/vx X-I{qA~^7znG{_|8~]/w@M@}V.xXqrF~ɲ_=~%ǘ|Chlj{<.M>{(_wwhp]1ח;y軸~!UKFyQcucl I]0q9Sz_F5 6Jqmdh.0OB\31b&ߺ떥Qg HIj^q{H NE?QgDRtiϴɬc{i0S=n"9uP"'"޸:o`t L "Y8ɵO0.V;|9A}vbӗȀ]m C=FA|uU`޼Iq3OyfDՑ*dG @(rǨK?q48 G|yeE+|Ge|_AkZ<1kC׌ X}\ 63ޡժbHVm_v)\jYq }0 i; "~Xi }:#+;q#?)W!(7,;h^8UX_R}aԝ2` qyYW0nS_}cp.GZ#5A/}=ToMz Astuѧ]wA ":·]&-p%nu^$^l#埋K_))ď$TyڿBy2zhC4紒m $CX&|b1ڹ:8pغʯ 81O:S垜2s:&AT-``_WK3n:֗!;Z]-TYH6 vÿ#ge78E%ȷ%{vӒ<& /s '軞_6Ul#/n ?d`p<C|t>G?dI}c u>$ɣ<灛!f L~y ;r+Er ^$#\\AzJuglzو?+j./c=)6UsG L y /M6娝`퐫ېWjf4q]s髀0B;:_r`ϙFf^EYgis*Sno ":5ާ ݄ Abpnn ~m=Εq$ ~[Osw+q7 ǎDҭbC0y =xJD\,޾+.죋 KVo<+s$"_._kuT?SI{CPN*p #'?}T6?_:w~N}8ܝe4g.wcTӎ˪rljHy@q<94%uG:D{M\?)qp6!/wH/0O!7W>Wnc|:{ ñCxLޅ}gϳ܍3QO{Q^Y`DWʬP? ϻx$SBei'0nSzpX@>&qoS=P?C{\n5&6U1E:7[pڿםi3}/s=5c?݌]i~Gѝ#>t<oTNE;e 5|&"ٗ[:oDٸ{as9<R}t몥^gF}LWꔗN_}NhY'|̯:Q>k'jW#3]4ۅMCe ip=G nH l /;A}:߲_;?u1Y>9@E򕽚6ME~7n@~i}o|DqM]"g.>JVx)4]֧xy{Gnku-PW74ƻlx;zorcO (j/FAԴx;]ATq⥬94B>k$>)xꇛ`K:1ٳ;7uoj@|wG&>SI31nwKm2zc:}:k\OWҿz`[sDc^Q_SSy R`ys7i)EԱ|@rhɿ,-9c[IVCڮAgaYkχc}Z_"yXP`p ?]3mdW1gS6oyx{fA濅cFN5'{\u ^$Oa}h}C߅> Dv23ICY7꣯mo(m2 @|5݄;hfJ3hǃ3 Dμ"F':(N~C;ZmY7jF<]mقQ Y2a"p3y1I)<^cZBd;$KBuŲ4g~_Q/݈#t;OQpr7#_% y?}QWswʴGkL7_yKCXc>w99yCľT|rG| 8+è?ݏw6m/'fWsqю''-C,q}X_5b>4qi-lWӾ;וc-n_ZG15'ޢ4i~|Wtya8?tu}}9c7/A"^`Yfry\]#P;WQ6-. kǠѾ8#Q cQl ۗR} 4Ӊ͖([h߀f}9kmށyCWثSQ^jΛq{/? dEŞF#Ҍs6@h58[2VvlPx}Oa;![~m<J= {gO1*QIF}< Svs{~E98 ^Nke,p}u{ۃ*e:&326KޫY~^?hA}mt ׃}( i\r|,H V鵯ߦ9Jabe\_)1⊾ p ƨ h+K(,E|z~\ۚm;8*%e~9O}n}~T WRfb! .~f9++<竧?OVU<·ْR%qˬNIeW[9j8]NǞf>/QoUh8NDZ˳ATEQ>> OƬrJ?aŧО9+yODֲ9ڮ?×E$ʁ~IhiK>/m#*Q8__5Rȷ=\[)6NDt W@9$J׾[Tp.v'zIځͫ>]m iݗA7nh.kzɶ~bE~.17 a&8?S}h}8'9Q 0?9&q"/nǿ?H>R]o~PNjsTg-\*E0B26'Q?fۗWv%?N틸|ϛUtvڝ˨GS kC|y2>%$칹⬤'^˚/Y֐)[^>B},фC5aWby`z1 M]?] QՊB`l9OTM]ണ*j4Jڡ^ &wE1Í|A:43#Nhтf?gPP}UQ=1v 88< Ɩݨ5j&nv^p)prRrse:S096}#- 3IoE6''_~S~uczfb +$fZ?׏mǛ8ϩ37yssfҬ$$s46\54p3\g ‡CQԖh>9.+ݞO`9 Ur "h_?}!ώ?!;=??WS)} w8VbU&Ա!0|]{=& 8./.|EO|}App09]>85ۀ1LFv5mma,*o 3k0.6z'6n[B'{2-k!bt-JUIQ 5MN#r8!my("(H Y!&2+JUfHFFu/^{9={`:Gv_t *PS).6I A;VhŖ'GM ׅyEiS?yѪ oQ0~GE;_>8'{I,? h:ΊGi/d\ux~K&m~yIy[>s߫\c y2q$X91].~5;j#/mP,vºeίz~E)|R>.{;߇'iXCujm  #V}] ' asȟNh_ T_tZփO}O"O'irOXd`cB8}?a~ZsJ|tpk)W7s)Jf#M#iq0ϧ܀3wo1?nwcc=#_TZFz(k%]6ß#>;o8벒o=]>!t腾q;)gR51j0nR f{= w@hg$=6~?tokqW_qf,|OܝΠ@3Di}3'ղf8ʏW-Ⰶx yَ#4 ?5ظ.̔).o NzDA~)KJsrjz\GKmjh~n_&c|fKC\:]ͪ[/ |]mwAP>['eMc^UQ{MySW4 ~pv?ÎW;x֗C?܅t ]sf{\X*~⏥t}Aɋ﷛B }֩_  h^ݯ On?擅5_g(}7ix` G)7哗$Dm3`TW+?.\ ӭ{?FP}@&ڿa~ൗoH~kBu/Q~;OvNqA7Sh=gɌYOg5Kh:Eέ23ۇI>]cc=@t K^N1_L;>ivdVFw98Nx}'Rg|)B77^htڹkk?Aɡ5i4/ډLuDM`heKv(թێ; ehC7CA{z:iw#9N=Z[߱?m]Aafu|͋ 엟 X %'FDhz'bfe@uQ3G&o?ז~NkV\MuQag(.)wgR*W&`5kOst;#a8 mIhψOr`ݿ}{Ӫ_7yߑ-(ךx[߮韝Jr$̅ p^CJ?b%^4.tfXHV~Y1^^p^~7QLY=FM?qF5ǎpq^qs}3m_pQn(Gژr 3Ƶ*hcf|dnOZqvao`й#*]0Qb}on]m#Pf]UKfqp2 [g9Nr < Ej򷪈'#F]'[?:O>DQn kHYJ NtƸ3nt{Od:4sA~!{)bhs?W Y QiW^> Ҹ{A% %n=4nb}Wln}VŇlf1m^mr=QlB'Q}rOD!&8AcW⽣*O8Sތ3uˣ{f6zqz f"u9PIO~s+?tӡSп} ~ڐ] %_x_p y'gոn/gVg` {pvtƓJ­C~ ;r݁l%gVEE{Fy1ɏz;>mm wm[9wՀzU~y lN35KE}B0bC6p#gNψ8缜}n8=ʙʯyi^L)F8Lrwzu' x(g z'K *x/{޵_"6몆_`yvA}GTFH ~Κ,:љ6+܆uj|~ WcPw_ ̽]T^FO5iz8j>:/8@6k3oM[EuA;}08^COrTrK_?MqjTocS]~4 c NHsŧ5-6ŻK6⟚vhK'}V V??v&4ó.tߟP| VѻT#|˯0ErY^}A1:. oD-9k \%sB_}yc/~~{xZwd{؇/_."ϯ~#i.}hϺNo%~v4 q];~5[%ok5_(?y1;St>03x' y.8vv]fRe .gwfFF\KZuw#`m3 EZ'HgW}~G!kS)Oe>dK~6pܟ(;? "2?i};;PC:)EԿӳo귝k><.x]8QY4Jÿ:U'ʏ]Y75#I_ɵ2=z1 /7őacB=Pn<dǽ9 Ay[ {a|$7v]S@p,Wx#4%_q?'F :ɽMK[KcѾ#O"HZG"z47_x=Odi%>JC^m;^@?4;O)ڣbo.׹bO0_?~T^RV\>}CFNYoz>_FՌy)˦Hb#D8oMA3) W3?uoOBcOP~ia\ou}@(W9F¿y.Tn^]q;~](/idCz0-82y#S}#93[^7@>aܗZ§mwk׵7~j0aԗvAM(uג}zտn(E>&:L%ŵV3ByxYzN{ &] :EiO̩~8u78Q̏t}LL=OS){u?l:;C0"_[:!NAˁ+{\<7 ^+|{ >' m c?\&qƳ)4<lEp:29aOj%0/̠7*C3 .u_,c7q,xڶL"{!⮬fY6~>oاu;lF{J\i|0WRڹ9E(ܟlq!y')`:h|} SQ8;̤[|V0Oi>r=q`Q ߐ@,KQ}ǻLCoz$bb/Kf .<><=L:?Ea7~&^j <(Vh;U7k?FX$ƃtnS#q]t\81ZzHŷ khe?Ǭ w NlnӃ]"/*P_y'uT0l3p)}FKNx^ ;2eMl=\u8p O2P|2לk_#:L疠_v0&w|<8p xt[⮣TXgsԔ/ |4oq$>7+·s$8άO{{|0@|r'vaNκ5gql}>EgWG&4NJ?@UfB<.鏿q$evZGY݄Yo,`.3%CpF궧4x#E7Eyȿn/9" C=Ga'P G Z ߧ"[˦FuE~?')TgNRlGSk<1d nD lFO/p=`y^eb0>IC}s)޴>KLܺDG]G~7wax=ULu"n?G|&Ee3UWDU&&n3v~;u;H$ّiqeڣ}*bV?~OW6N@}So?`e u6S%O0~/.w'L-;5X<@1ߝLE>}ָ:1;Oք0u[x!MbMyqf0'C? wP4ơeg+9;\9nV@2)puP+>~i {m(_2 eSLwoߌL2hOxrm~fr:XVTC &XNC`:{uǽR֝f Cbqw48y-Ghkytr5?sS_׺O֡{jO4f2?:m$&9'~ 3YGr 8ի_G)_KS/C-|O9f8izA2cc1Qe)kjtΡ h͛cys>C?lHk0fi+s(,;3Sqx݉jBwkUwP_Nַ[d=n>F_[('A>`fPXIEqlZ_'ɦ`X}<)_MG_06ܘ0bḮ yb‹oθ<Ѫ>QpٴswAӛ:_7#}_ 1^:jM! ΃s7{ϯ&\.^i:u#ZY/y"_q>6b= KARO4u p=]wXdXT8ԉ2TUl?+-uf[}G~9QWCgo)03l AN=ڥWe+&)S/ţ ?)?~`>[-7Pb3D|]WElI _q]ݺnˇ}XGyem݀-h8'_о9i}/Zoc .C^)_==(Oow=yR$ѫd3O:oC?PI#\gￂ_X8EG4_`wl9=8O5l)MSNaFa!~Jߕ'Tk>۫y 7G|GOX\1UK Q7l!},{ӑ엻 zP v\I'>E Q.&~zabf90RS~wt_FSk h78 78ﾮgWzk{>x]w\*$W5:.vOE? FnT ^{2yn}i<69 S娿ũsp?w/0 8gjÁY(n1? ˘8ĦQ\._qWKތ8xzS~Tk9ݟP|4, Gu8>vL#][AjSiq _>Bo޷q j|cCpތf*S>QbC)o_Lιx-'Tf&ራctBAz]۶K^xIK9y/+bb0/ID, ֢~k~3L oBp?yiG̹vqr)K@RW:u0U٭;yt%8%Ơt'FӺM:[ٓp 7ggqſCt,|̓/?1t..S=\t}P.f_c98E~7ִkZ;pR_~eG_'>'q<Ҕ: dE mW}|^dIdZvow6V~?y,k,8OXJO^7eohو+nC#QG?3.MjwLB,}С@å.az??m!|tw%8M mMŔjjsQh!?%+^x|gp^u(Z5~獡7}k)Sa$gX/EexU␾\Xk_(w"rhs xᶤ?{]3؅ 7S󝩡l4A4#2NгZ_Uw_v<hwde3ca—gN~ǀ}uE7`BwţlZ|Lvv%SOq{ _zZ ?^]B[@IĪ6'Rtΐ{KF/>`+Y#7r.Qiړ0wF?)vc,ggSg#wEh;<DVݺ(~y e@:X~^J||CWnKY U<5@'PꭅG{Z?_:V;~d_p]Rsߣ^| [ E=RL,;|"X\ӯu}A|E"ޜE;?̸yWC}xu_e΋>r/W}i歼ˍo2FsKկBꇆcAz Ӣe^:g}0C^ߝ/5*{p9CM Za}qL~'Q&_!cIXwL"puSmFi>l$ 9Zi~{؈4Yu,?0_>g;MG?-zJ~k\Ï)rs^;/9w]ӣۛrXxa^ww'y '꺴3__gMx8M԰eԿnbWUj`$qx#f\K|բcn(9GQwΔW N?}?]*@u~7<[ NQ#yu0YhZ2܉1]=PnQIJ7|/BqA_a&9ad;`$T!uwU?Fds[I)`\uD[][)?BΏ=i $qyT_s*? _5+(75H9սt/(?e" Kpq6 WlDd{h|+S]!è{+R`5\F~!lG#m屍k%yU '>c2309sӲ}XV49dV>t^ ”TDzN>n|)$rʟ7nxC~ɾ"`n4[-$K]KltZGgx̺oTQ^&zJ[a~ 6%9V+^1~W^O)kq]Mjoܵ bkEN%np#),'IKڜ+OqA$P$A\R|ZSzwM18,z݉]^$`oz9՗&袦SB|7]\dS=xzx?˴{F*IG{4<:ZK{yюUnP4BG$ qRaj„*ʾ>m]pxޙ}agKiRg>ܛ!Q'L 9j1uS=q>'#([_ t)6 {|7 y/Gh Hn=e|;1DѹntsVwr1t0; \ѿ4zWA~2dF>P~Ԭ!/ "ǣ`2TMt-dy=-U,I=qX6F}ch.Q%?%`)ID+~-ըj&]q5(o;UW}= }#ŕ1^*6P]\9[rG ʇ䵑s6H}̶/˗N{;/oY' 0UVb 3o{ =] ߎD)âu3GV`\O #_C9>.5[.{vкX7'u\>}H4}/- XQ}Wx$)ګk H};ρ+]~BclR5`X2f*^!oݘ8`OuXKV,llڣZ`K\w^[p4Ǣ)U۶7HNn{R)p@}_حK|ˁ~ak3ƣr꧛OVxu^gg_E11Nc~Pݮd5Hn˃QݽǙC ?w9Ń9G?31u9>ڋz;p'j V7uNz'vsN>8?)F(wq;jūyH<<֝h/7p'cP]~#ξ8y~L|Ͱi: D]w=p|'&dQVMԟ,I8!nJ!_4<>>H+ڃz񶴢m`˿A]1/!+;6q>0;0QT^iמ>#Rw΃t.|?>9HXϩ)yJ$'c_ӬwaX}ۂfT"~}۔iHW<]>YUmxF)諪8?PSjڐk'劧nggZvc~- QSc%T½wzbQBtoZkx/rҞs5]ݟ"WτY<-G4;cZ[^[ZvR`4}Q<\R ?{&_ jNsJXP}8iVz⃂џ0nF;)a+ў\n6üG h~>]^p(%eS_sިmg{Ox_ѕ_zhز"WLwiDq)k#N؊痑X$:k{}x[yi=T#/M&xE}XOr]e@7|!.6XT˦sU5[Пk85}7|x1˯d'}7}~L/$3}@\s@ʟ~Gzzs- ޅ󻜣sX ۷q{4ɴ=xw#[Pԣݧ[ ̨xfH/͆u_;dޅ4NL /%8Wq%@?ٚ7UNMܓY͕-}Qo۝Ҫ~7,Q?ջPbFCEDp`v 癡~S_aaҳct_L8>\gO;Zy]:s(;\Jݫg,{#q{dj}G}g> Oe<W^xKhp1-~/s%dF<١sX};s:}jVa'%),^5H/OArn# rs!s~_sW~p~?H^m!L6UU+ ?7X,@v0O:b7Wza+?mnoɯl(C+,C$пS?D碼g{?77j ̟WEz,H9jw 0q)*OQ9瀻8äM P i^ļbO4guܷvm<* #pr8O ͎Ql[~Q~Q{pH"qPBq+4p8_;WIG}p1ը~Id.D2'ŜZz'ʙ֌1h +07'| cxYG )z}C<ؾ. w`m@TFLn҃u4~?k@yʭSi}Y/׏;M_grw~ =J>/sQ@{x)C68u塏u_(a//g P>WD1*[1 CX I;8{*0 !OzlraL=,.Soќu8Cv%a)6$P}wzeAR?U,׏U|ȍSR `h{^l>QVf*"ڮںS#SaK[5hѣM}du O f Xm;zv_~Z>O״۹)s&ݬ shdmA$_E~Gz;v! =F7w>{ٹS6 ߚ j^nrU7ѮS$y4Est[kM7oi:ai|cZHiz;XEE|r\ y~ Cf˕Ae!q9R{ՆaK"==⓽"nn>ctnp0O!? kwzI ɮ'm@Sv}j<;sg=J(Vfc=܇w C^rHK,`Q,*_!v2_ދģzF5 9;Lh_~'$r[C*]n.mә XQe6m}Í `~oK5cB'"yդX8@18P$o/"2okիP.T)6; $҃ENwLm񄁿QcbqD)A\Ҁ=E W.QӄAhsg'~OK< QS@:J3?BS5vEXwg'<7\r.XCe^zүG]nma}h))gs,#w>ڌP? XW׀x{)!Пʻ<Xz#/fW=ag t nZH])yuZpwn5s#9rH7Z{N@y0vC6{1歔I(8; ɘF+3-d?{zg0eQ_sozKJV~8xM;q3~B́Kv|\7sy4[2gOD(?^?lk$3V~F6ɒJ7+u3=f,:O@k Wc1TOz{zXD15TK{+p~ m!-PO-y箐|-~HEm1~}H_ۉz t9_v3U}'J_! gоC)%X1_y@of́%ꅰ>{חk\Z|8؝:Kq-пj=K+C᢮3EgR.aڬ `I?/ק(͊gJ| о֯z M\wq:Y{<۵+Dk #xPˢԛ՟?R+wk_ '4۪L+SMO!zTiA蔟%h$uVGyDy9N*G#(.i2)W76(?Ҽ7jm _,~@k '9>^}v~} :O}%5c*čKN Vn ߣlp[OK2栟P:SSfu,w''E][H! B|Cg-yo ll'Y6%wak\,anz E>n'm0xUICu[$}d>yc|:ꓚ+, pvFx2??zCO>NmvSpVCMi_NJjN6v; A1eo5#~;7Cռנ`Eƃ$`p gT3xooplz\-C\PD}A-H>{ q*wK$_+u(0{=)P|E(6>17l+ڟ-xf$IvC501Od8t՟q*Mw|\זD9SzDB:#0_m8OiwVDq?tf d/A}Rk3P>A}S M)o=x/!nRgоymT][ͻUvs&iS~`~C'm`? K 9nIxu~9>V& #>kvWQQk=l2:a꯶9g|Ap v7rβ\@c0czwŔ_2~s,86%Mu?wNq& +k>VkNC}2#v~*8I_'sj?ϻ7v1hH`ێ(s{6{c}ƕ, !p}߬_?;57ή{TߔJV!~og@i7/^ɪ/iSC(oiq^IWs3،\y Iۣ֎98prf\@=ԯR{zϤHQ}'*|ϟh;)\oa%j ׇIO>9ae^Ĝľ_jDO/=IYMnOh/{@9NʀQo&ֈ@UR֍O>eJ;̮F_,ف.$?u3k\> urP_ےzvd60OMq_L`flVU S~Cxie:GF%{?Zs sGFȺ:4ڦO.Z;le݆U#HOa ԰yI[Li@{,+r8GtAYĸA+>Fv0DA; @='S<5Xu78[bbP\B/?]Ww [{w$y~B{b_}zwo>s9v3->?xTQ| ǸQQ gw8X̥} ?݇T>Ys-8])eք~Y_ߟq}yU?Q~o>e`#2O7.nv4Q<+†~!c&O8@gߚ> bz_ںFoȖ!ic}x7~.O˟_w 'DǥK8*#oEʄQgq\Cոv^PQ Jgpri%16YwvaGYĵŴnVwp5}]j;$Q?*1~è,>A;+Xl+!eve^VôeWjXq_:4 -ŋ;R}1j^FS~lk֞ #ijt_5aUȵ/ anָr~ *Po~^pׇxwPN2gAu47\GU{ς7hS.#cIellpQ}ɿ}},2U}{oo8HSNS9~6[t&G/ pI?5ɾi"|UᶫD]1~s^<3S3]%֧C叭_C^u\sFjm Lw Q1f dz>M vqNw@t3- !WNRQ>yÜ @)²-' a1ba p﮳Qgb^7h|^ߍq  ߈_[)PJCsmٛ x땀e]_G8/m,оY` 3e=2ex#@(6?#<=@ 샷-۾#ߧZve;UrOz.)SZ;mR ZՉu6uã_N7ϡ5\?#}*DM8; ޶؁kn犪tˌȻ/%gEͨ> ʼvvnP!ͯjL0N.xE[{p E3G/6z:nV` LuE{T DPj.6/ ]^lȉ_qdkvGx!ͱ{--D:~L{dM9(o~=vSLzƕJk YatnK1~{1znVL(&v5 #U[;6l<Ú yfk*coZq.ss(oS9s+,3&8~!CΟgѷ?27럶c Cp3p ֛2|Tר.t"^693z{09 7^t!Y?w i>LMGP ! p:& Ofet%~߾@I18N;y|ؓe L܎G48 O[5pK8μC sa麵~N]GQWS1]"K ?=/ {gg>| 挟'?_چ J>u>x8K^b_q[)= Q>,Gf2y2SjdBA-l('zƿ_p( pmxB{jIY_ wsV\]ԗx~^w@P~ϕ R+ηa{IGw XӼ|Tŵ5 .A|VE{rkX0z,CtkyO<}%߯u?| O|$P-co׳j(T)C)\if9 V=gEi~ u(0]B|, 8\gQ];b/ICe IƼ Z?ԟv s& h_8~Y-'"*_]p'޴دnHvk[f RO^R0l&yDHO['ǁsa&ʅYE~BV"Dݔ^lsvWW~þIy`yr5hzM$ߖDQoX'ZP-QT2G05`ޒ#(/M>ީfpwΡEk@]Y]jq֯psjUS\h+(1눼Xrj`)@|iqSwlS b0MG&:SG mOh2v=pj;qǷr!G.(| ͳL˗R?@S\RBg)6f>Ӎـ$MmJ ~۟ x>lnbokŁgY\b꣒=nk󝆀o;[Qp^ CH?^9z'MS4eW_8iAk] Yr-kQ7븿ѵX` CR0o?A4oNآ=6+@辮+_*I}=i:#ЈAcz'X̻s49׳m5O>WcOݶJn`3zdJ+ǸiH7HE4ځfW~= >I5Ot /M˺9ݿKA'0z2s{|\6ZBUE}^MJM/P6AsϏ[8nq+AM UNhk8]:ax ǔ!\T:UZaR~ {<9SgwZ=>(YqY|IuʺFoI/Շ'nOX]efʟy7-#~1rt>px;Q.nmu(O$?p֢\Ts]KLn_.W6:Vg=?t/9ꗶ׃CVrqП{ZZQބ/gFTKgvݷT4\)t?Dmh~I{jz-nqoAk[-ZP8O(?};@)G2@}]=%fW-"!' qCu ON8_R^`@<#_'$`F݂ߕ{qmd ɀWjCe"sGLN|_bR=0Fo8q[ﱾM$[ƞꥸ~u{:ݺϊkW%[=tfVN<@}s ?I'yh?z7C岾@ӡf]5Ӵ2Xȁt>'MRԏvNm(OѶVW}z);8<<jo Ԛ}x/1~[aEdP}af 1ZMcţS}} #ccf$>⢼&k`qm0-$o[aU)_Қ~oA|/Dk)6!#F֎u'yuGwFQ\MM'{#bH2.j8eC. Xݮy%!SĢv\Nח O= "л(_3Ri'1No4Ï}h.E)㭛ߨUܭ_~Ec_0 dEhpBdt("sۮ5 >y[Q毮(ɣ~p;o4ꧫE}<=&g ] nx$G@cy[Џj5~a $=yRgqtͭ .:疛E;"a˒r8_vSrU&a*[Cp0":q-/ l`wu KQp:$>GCq-O} gI㏜3ORߔkq*=,Շ'USƋ>b)`<Ycnt'*~ > I^z'U}lpܬ<657`s. f2ukN!R,~D1Xu$⻬G363O]"i8Ae`6E {PI )]#A'즿qYZF+!+dQ4{އ_1nIe S8-YcG#dۜOt3m8O{P\1EvrL@H.xЪ6];yPSL :ʗթ,ڇ.; C*v;Z8{1>}m_3_l7i|YYq?]w?ȯOc^\ v9pNY>y4xڊ_p8\G6aSU L n]*Eu쑡zDGLy6۩[d C~6b\WD{N  ~pNy4$|N8~qeJʋT:NbTezH/E:{ gefu7 ܅{юe dW%|gOgpa8Xf6b|+|=;EUEHjzgxOv&+1^ߣwΥ}n1qQ{A~ CZ;ąF 9p={=G쵾\U:/C{us-( <wǴ&c+@;==xf} j1y W} 7׻izu f[@oP ȷYKn3"ΫW]IuZV7]ejozCWC!5cګȏe—?,>ܱ.9TbGGi5P ^Xk)h;]VaEy "JCџ9,"; y1/viYcvU8Oʙ]zv&|2墺u7x~ve"w^}lGہ&ڻ翼p=5ꋺF;K_ x>ϯ9SO6=c_``; ~Cv:uG|Ϻum,6Z"#=rh8dP>\k*//P̀tïׄW_}j'/CEn_ՁED^GfoC[g ~^z]مΩմϘOq^HKkec!Un *пCјq<2cEphg$׻[+~F37mkܳ?6PkR/ ^నj]͝M/KA-l@<gTp=Qg/ӟ*^ݣuu!$g#n8ڄA`,r4 ą#MW'pXxK@=/t MϷ*r^8~ХqYN$up]u[VUapX y5Ƶ0~s$ׯjz+)I{.Btd kGsWdiq臎 r1:xnX:fo\m?b:;P}dv,OA%ڗ^[8/QRQ|QO l=?_lc"xnl'8YxP~a:NѿN ,">=UF˶ҥzo0tK[ڟ3 'emIX<]{) ڤ񸏼Pޖ30j$\7Jnή d₮jckP3J'iK^E.H&r&>Vvg/q<3#ƲߣԖ# ?֛ ?El`/S&X)e˥3G_x&8*zNFc'i?z}^߃Z6(S)e}dʷ ʗQ$'#\\'7S6XG`ߡE{g{(GM_󎔅y{ mŜ9K1y5jQǀ9A_O7y`v*~bU#wr5)NXз"،',qM{]w ?X B.:r/9s=+csPbӽ a'_М̳|͍b6 >]<?Q8qց`8͋?^Aq_u큱Fm6f j&/.Kɽtw}B~`%ӎ=9w v!"N-VSy)Mlx`_G'!Fn$uJ\zn)ǩ+'͎) 1+tx+0KR{?~]~l?mmT`4,T WO]ס%X3K߶+7~iZDuy9uSBfS. ;J39U2a#m~# C*hT< f2gǬ5WQJ吺# 5{ ڍBwmq_Kq/XRO'NS|4{rb [AF֬b3țj+W|} ¡7)_!ڡ(0e8N;)IYz  \}})<,vd`!rtYWgQ^DWvC0^y?_WƯ1tvaw[:_D\V\ DޥG\G@qS'/hJ-MOnI7(mʅ_{o^'m~WIyi潜 Arztv/ca(-ֽ oQ{0v(tqf9Ez{Phu_@yrvi;Lmn7GMpuU7gI6D{3cpn9ơnFT^#uܤn^U]xx U 0Ͽ\CA/J{96\83uMq`Su}REW -B\lKGqi`p7I[rBIw>Ny_z%ܘ;G^]l1L{%oo%_HuSWqP`f{q|N+G ( ~"Sp; { "t3x/Y8>OU~oF:n 8ZmϾ{ԗͶm?vfWNhݧ'xGW}G[u4| íye[Dyaڻ\ K>y3Jzy>` ͏+G?)9X4M7w8>'EH #`Uba_Ҏ=C; fOsד~D9.V K"ZW2׍Eŷ:ek<7q(/~*.ynCi}&o7vK~~V’MAڍk?Rxځsu+6{xxGwA{K֎Hٷ&TǗ`.탱%'Y3`rt ;r'Y5,,FsNn ̞Ώec5?DVO=SJqUfeݭ61yQ^GRލ;q\հ[Od#zԯ}\%pW?Ţ--D?7nƂ`1(Ŏ(WQRNŞ +l3g>)LG4L35n(W2}.ſ.|L i~ⓏߵA])~cl|1EvF|c9ʂt^v)5`żEگ aT_yy+Y!v1q{ٸϗ֤^ۉ[gg(W޹h7U:UM G/?Ow[XOi[+!G>Z+zo %C(Ndٯ5|Cy٨ѾuzS;g8~}on]j ~{/7բY]hNnl'GJ\?]V0/Kp.GC?*Vc||gYy8ͩxP3}y(eR}Ϡ}X~my<;f}dQj}ڃʫz!>ػ<|m*u8NW#Bu #.{g@9il'o|i^3vb{iD#~uoɋ T-9b<5n_ٟ~p=_YT#|jwQmn/~)#pzI!)ۯSDC7}(7ϧ\`\fFNwV#>~K^_ *$e?A8 ?CC"ӎ*{7= DGPnKVZP~zC?zND!sRGRs@ p= qdQTߨi{*pTmYVn mQ~ۅ6Mr`}0^+gߦ8[=pu&R)_UN.L WO;# FWCqxyA78luo{V$[-J<BRm"?5ed=X׿؆rw\Y'z t_n%>.eP&/݅s O{9L ^?矑Ws?o(/ `$G텝:4U~ʹs?ߏF=ݿx<18ȏ:cR r1dƺ6cL4흯R޼A`q9bFy(;_MvS職tSxנWU>C4wG w͜u!_&/?]c^A=f._6F\W_ȤN' ꩾQv7Dp^.6S;/V ѭ Q]z_QLK:]1[|F5/Wk p8c86YDb񪟹7.!Ai훉8{ѼNA+A3/k@W;8V60dz*ylMgU#2Ag5lI܍gyZCӭKuxw.\RIBxuˠ~?x7;-st$0%eb 9> Avw ҿGttvGo'{ 83l󳝳p ?E?2YQ#Gѐ.PR Q=3=;۽F~ ǽ8HcX1ps",mGO@Pīׂo3~na1;h&~qяP @:'ڵGf(Nh ;w/63QoăHNxf|jcs1Sn + KhG3( mtL xIyto+A~6,nFS\uEWrI6E<?^z!9yY=oZ.RXh3xHs;kpW~B_UiFavM?w"hj7.׷I`m 1/l[hqߥ["/ |Nb{ 3RL73D3p,:Gy[^0ZWt[vúƁ]3E*vv`GJ ^2s1}Wx)>|p}6ct~&B䇌JNUo> |- 2n*W\2.z l1JH-8nyS[wAs8)c#>DbYOyѸ>QoΐI@b\??z)ꇢn&XXP#u~5 +^Bo%^4cNUk9u:Ut+C}u_і_olz  Q +zoGm uVsAskfUz+uwkfQNP_Eq}ꗗi3|ugX{8Ok\m__= {5^&o'uRp9>;'s#ʼ'/GNgS.|J}G_G(V%G}v˺VS2 &T4 bͥ8fxR GsRmg=W,:VoG磉gX5LPUu+QL7ͮ ?j"Q~ X3=-wUd/׺g?@?9X3.yz;sLgLW7w1B;Ұ6SIA4v\/?Q~{G1\Gg.f9Mra>Z!|ޫ5mpRz?_OS)\'7پ>0 tG~hE O}. AһJ;$ ~eTm+]QQok\q%.[7#/ ѿ||>zDv=kv뇡`{b\/WQ>S|rE@(ԡ_*4C[(F<s}~ we?k+ӻS;|F7A)UlfjGoS3h- uOb:Y22ùG\|^Eޟ8LYA{tNCT| ҷ8C*mXpzΧcڣ fh}xV,ݦ-B$4ؖ?5{B} C1|cH FpKύKi:W $s".3< 0mAχ 5.? y}G|J˟[7sqg~l7 a[Qyg:i8wy~ט!PJJy('E _%8" Nl$dƲ_?wa/ .q3>7K xs'h*gEN!'گ{ yyWʗBM*sph_^ytapXmqGK3 q8)tnArMyyYB@u/wl)>s4.$I{sC/?ׂZ1XBN.-YH kcGFEK@9w{n$c륙4 GF< ̼%E:pkfg$껅n>ڿPgl4'"Guȴ5 <!ivTNjymnq:׉?gON<<,f`~s%hgj_7Hv/m$a8Q(yc>_M}jıԄGy]uob?(?]KVxY(7)8ʾ5&zKckO`NOjgk~n0mP_x 느7}!8>,tw0\øz,/Em#ǵ~圷k~t _:{r+A4o(8?E+~Z_3i܃۰O%J[q Cm`޴,x|A<2O<ҍ5;|kM ڍG:$؊z} ccW#>$~^{kv3W7c~̸}Aꮓ=5>UgQTǪRv781IS(?o9w,E6؉|xFPj?n߃B:Ao)MΣWNh pN3zeթձ~4gq9*bq8Z;ݘÒN>֢ݪNBѽsju)wRTWQӭ%O߸n-"R-kM҉8cӮƪz䟚HE@yOhA}A'9{7<ڗuWOl (?E4Q~` ڄ+=,E8e`oaW_zH82ݙWR=thǩ{9m)7\N[I΁Z980CoJ?j@I(w (_Iv#B3S_ګ8fIh-S_x]鐀|S'}Uޢ/bo&w~J7lqi[?p|^pʴLʓ \Z> G\5Nڦ'VY?5Y^vhF5c*|Oao?~IߣbiCדǣRObNۻB3 p|MK3v#ڥnREkG3an7 IֈmߩGBG?twί6?қέ k;ՌZ9wB;݊O9iTw2|O@YaA` u­Lj~ og0<?y?PTmF"ՙ'|X?ҼGL h # CPY0+;p:p^ =k7[>y~N':ϣh߅;ׂie(q^Ƕv!%_qe%8o3_iip1o@.ERґ'-tndQuŤ_~?Q5m* ]Is޶?s')!h37_8?q}Q|>u-]@/}X&Ħ{-\gSɾe,pU:A$z Q}^=#ռفgV}w(8?%qY0Icg}ώ.JmQ5MΖ;Y[\<;η?K_wf} qC7G l€/A q;-Le઒[9gh,m%$A Hdm^?,z+(-pps UYj |V`^U ԟ A>y~7 n۾@|o CVyv ,5nPuw]ɫWe/gҎ1Q7> {$?S.Gy>$—a_V8U6yim}ox㼙qW.i$|gxX%5~a7}-_Oy1)7oV3'GuK_y]Ӽ.{vj5gn?e<0x*G/$*ѾIO.#s:EL|i(J=2l/Uuɢ*vҺڹv/?&,b#a$}rGwӨP~q'xC#_b[Q?؎c< 6K0+;ec`v)\p읅k޾ľ: r8p5yblp/s.P_!\M0sٹv8]9T܅ڀӗR:1,/S%Qwf`wE=Pxw OMm; C$T5wqo~꺮藡tgЗiW?ܶc˸=˭cK| )N{d̒ N0ELC+Ps-.I_.-亡'@ّ'4`LʯzêLT MJJ3Іcuy;_8z`(\C}@maӬ~ yȋc\{4}o؜E8~k(.wU[UL#sCdF忯{GSS_fȅ3 t#\~NE:8Z3~y'Q{<"u^_I疱6=^w~hsw}> %&6q¡ǣ`Afwĵ&ZyBJ!I'j-8d~3ҊS)e\ӞfWPv|bW^es_mQۋC2 WxΜudI+ t{!77$h@:+ISyw\wPZ!_E2M~|ת<PTلCۣOw~XnQ&(/Tf, G~ ݵ^[ۭoPƫ@*ݻ{Ѻjt{'pHD;T|۽۪M> ss% yN mP}M㞬;]ȶC3 kI1mRr@S6~)g' `OmQ3{աՄ GxVk7(ܓS| K\k; LIY8c8nޛԷ?lzzg:0Òdy%9ʟ|v8(4"_x2YL ꓴylnBaF>mGsU&e 1GFG_#z`ew:<շqn[Akop|KOnjw俭ܖ;Α#?4Y9UA lLk nύYaٹ,)~ǯج'eP ~{=Ŝ6rnS? KOg=yZ#-g R Iw~a n*N񐆗.zg\<֊ 跛/=fס?ob _vgpiD=;k9nwc3N#I5׶;xDP lӺs~jѱ yw3S> qu5S'S)[zM*7bU Յ.\B|h#+D j/ڋppxL1V0ߠ|fG /Fδ?L🧆ܽ_P\-歝l˒+{S4s\$H[C*({p|2/LxtԌ nNf.|M'tQpV%QJg'UY<@v{ool u,>j[n%𔳄l@s!.9k1>b/_5oi;[Fw+p{һ1>V%=^]m1]`-]nv5W0!ԛ;Fdžw8?QGj˹t~.aa3`o'3 (?u@P5~.gO3 h;^=(O`XƩ`ﺛxtq y^_tl"޻;Np[KCܟ[k7(xչ T:Sk}F^Q7~"׈_vis/ʟn 98Iݶ+umX UgP_`Er9D#{Ktd)f^(;^j.1 aNS<->(/q|ZC0+ opqݼ|WU C}H˞3=os;Q]zL3+Μٰd&xV% lm?S7^g iaV (~ wN*88}ӈ_⨺giW| Mԟ }dH}rA}~왔=~ɩ?Vj寫K^DhM"Qκj6V5w;'jsZ迍MhV#ײc.\a ܨp]$[)n鱊;gЄΪ2p3w'b,~O^[B+׃B1?Uݼj3lO[q~/W1W%9 8>٪ϼ.Iyr7Ff7<8+N+=dlLM~C}4]e?mw]|; $y;a|pV1{zx!e7S'PܾX{9/ʌE;f mZTڷRփdI[]ݵG|?9Dt KW>EU:lYq¡4#9Xg`+]xT?q:VSP޼{iwM>ֵ-pr3-'8%;݁SXߍs̢9N6 ~z~F"ZpeE榁 G7e{O8XE7 =p껭temj_7YWϟk`v)gBܐe<uԧ%sW+p~p܆QH˚# / 4 aGk8~8ʟ]`&Q"qcC3k5-\7}WrA1Q!m*t:?oͩwCoqe$bFѾᾴOMWwnzA鸒/W1įG̓{)S(J彣y8~i5;'uF{{` ^lGk?uڃ7zMno>dӤ==Do~H{VW";:"Vw#P7?IòE>Cwڑ!l*:n)A<ֈq=[hQhA?UO w4YTO7_*_\v$HKyK9E@`a8܉Ff&h`YBלjaToo߼wfVS~lڛF2_Ϻ=n=GIczB~-@M0wB1ΔǺ8hw0kkV`~i<'c?.8?%^t < \৊[mhUȫ؇e/3f$^a#Z釡o9tᗖhe0?߁⏐M09߳ DXW_QdN'䫰cԿDੳ?U|9~]^gDY=Ij:RdqP.8D->L:W^uK`<)&iar:%c}HF7 o_{(ƇmYm(ycJ8?ҺUOCZ1gt`3Խ?#1rْ. }#ڰ2|ߡ%?\JbQA.W#y{H`Mmyoj5 W}x-_F:iv.R0N.S`Eᤜ>ce9`[3:▮6w_Us=DD64G}ݓ[z;rCSmhş>=o]NZqT9Zb]owEϫw)>p6yUGYW;`W6(7 /Wn w:qX]GU刓ڡjbpWZ9S^ܼ NsgR}\#|m )W4RXSbmH\??Obm;Poe۽p]P;67{CvqnE k ~E4Nǫ30?+"q -į)?! Wzos"xΘ}Hw?u[NKŸcolsӳtnΝKѿu[SpJqq B7gQꏏI݂\0y:훑-Dr/}ܟ F|<ʥ{bԏ'|9ۯvO/}]9g7U`7#ȟ5LO;=Qx&Jp2m[6ο'*јOQ?`gr[_~) ֔(GQ~ِ6l= nHvnWTpB|c ,d[ MrPW:=ǓoAk{2Cz0URߦwzKYX|s=n &8_L_.@Q—xWYpd_u7OF}y˚!l"O}+~D.:oJ;|ħ{w}y>شf#}ckeOr'-!mSC0y)'m @{W&\q8~Oa(wEgSp̚!1|+Ork$CWܥ^9oHOwxf4C)V@)7>:g _ʫ^ V Nw1>WVd x{qŵQюUQT|^4 U|범X6)>!E/L?àë`h=?s?Bް:/MQ8 U8.5eomL\ 6 7>WRG YO)ΐE~ܖrrwtuHOpbE`H=Mcz W6˭w\/Yǝ ||Z`"ڙW'⯫9m7Znh|m'F_q)حI'7ž?w/XOHH/E燬An)Gh7Q/-qຫ+mٝOxkڥm.o/9y[$=h_ܼH3Bo/7,䱀2=/#1?DK:^׆_8nx,;Cʏe3n-^O'tt:bܞCelcSypq Qώj)/"gV;ςp/(?=blf~D̨0X>Cwy~Z&¿){'WT|S?haX_nke3KN~[ڋ>9;#* p,\:NUA}9\>y}Nn^mAgtZZYILvO}[ o=FҗeaG_9W7Uԟ}zC`Mr!<8ǩ={a7><?ΣQbKƎ ڧvHt{ޛDK,nfVEGh%b>"tV??ghtI ^.8?oQ$Pg9R˥GS8X\ɇ r0ZW$7~wVT?`GROV=f\V 0|r3UzH|^:Y.s ?'`/c<Χ:T/y) F=^5un>vUN<˘5xK?_Q) ?7?VNEwjBy!ۥf+?+F ]b Ec Q>SeS[]#\g.r`]]gUo4U3 F\J;,p@'U:W`] u/RPU4}u xq5+2F~POzچ ;B^OsCU \toI+9 G"1-w&sgܲRYu@I/?nU'\Ȯ 9g TAR0^]@DoՓT{0Ϡ}Ӎ^C0 *AD83Ԣ|`( G78⧲cT؟ǘT#cqO7: ;yK9㐺Mxj̶L<Ȱ)t7n9PVjc+VWߥXߛF./2yKjDWyϼlY9/MRkh34BˮpDS^s(|V*e1Q㳪q@=|5<\%N)4DĎꃯ8WQ=E|Ru5D~C%GYOmRoy ˻/e}orݩ/OI.v W%gѵM-'w}^_2UsDSM&?ֶ~&SQߍ-up՟F֨#y)=A77ߌɏʮm ]vlB~Iڻvg"3sXSO#V-o<篋d6 $'.G=߅_ o^[΀@m>;(p;t o妮(r01 .^Dl:sfk@j2"5[?qk}̉En0wZ W ϶{m~ECWT9MҦi-8t_/yZQ>~M/58^tk:@u)X}zz$ P9vPw\4;gT_Sρwvɀ_("),>DaGvww{\yWQՙo,Ο( {Qt;,NZK,UIw٣ Lk6~S`^U0%<yMKcM?>/|=~>j>kKXğ3G)NRkkvZ7#_nCu9ϋ/_:i؎Ԁ0v2\I4W곱cLFĸT0(?<Y@ NB<;?+#"\3lJ?YSAՏ|Ĺ &}H.6${c-"aQ~HqnJKz&؊)ȟ w2^^G7-T_? W|xt0vD4*Bۜ?fpX*iuԥ䠿010Ețsy8A~Y,gG?߿oX߄Vsͮ<,N"~S{v5a`?>Րx}xPzOZ푈 M('͵Nw?WH]y$ޤb=3?=##x hb\CS&}2nT\һS p3nRvUf #' !/w y"Bx&]]Zccirs0/+~#?n^= b7hDZomAGn <>g|+Q.\h7K=S)C..iz?NP)=+~[~ڻCd7WFQ3חIvG ;sPu;>NE:?Fڷs_uxa>~xP~;/#G5mEs&029wx|~fJ[3=$}W&߅tK6.ݧ[? D3G9rNF|7v?v0oAez[A_:qdO`^ͼawΝٌZkџ` k"n#?un]8K1t ]? dhF΍;3P%;yM{(;vmtqxiS6S}ADOAcӟ?<E?jޅpzog?XyܤBZvq_ 쑬1o"yzՋ54,c߇!8>ב'oME9N_i MT XѼI8po \G^I%+1zwj ڠ<9CgDSynA_y#5E7hwCn.έu1]r y~rg0nٴx;0PO&ޛBQ}vFolGfF oUwؾyז?+3۽G}u'|OU-֑+g7hִ_8}hk6b`{+@hٌ?jr`u6/r⋡` | jNtɁ׈|v -j_XP`{Ѿ:\.M Z` |e>C*,{j_w|~{/-#ag5^F䬛U=Zԭ>-ꗏоaw(e7}[/@ޠqOMV >xhpgVt&sAcѡc1;j;P4O}jywX)cwѵ}y!hx[yDq'<ʳ9xQ&ӝh?Y?"C^sR_p"GuS+=v=V= ?v1/}*KO &~x;۷ flyG֢TU~nl\ms9T?81x&qaI_NuI ďպ#59IΔ }(|G3;ҽQtd`wq7.K0Wz`|q5Us}+1]򗆃(W]p\ =EI%t}@0~I:g-@@W51_~m AN9[h{<<qHo,7. Deuҹ.3GPߵ9π+HxQUg}8fܷ<^LQ0o}|Lu~[L3N:{XWM֞9b=k Vӻ=^ ُS{S|zt58S~t>QiV7^ aZ/߄LF?ێ>:vߣ u7^9U?McVgk zZOًD%N#ߧ3 ] n3'u =w?֎ox/mBDg!A [Wf㸼:$EO̸\_d)n׏t my&yΦcMA{lN㔇8X=I=p+ 3YyQA2o~6r7R\=;ݸ>4_8?>xfZ{E\䄄=&n @yWG )t'骳T?KG;( {Kнjw5ͮ9g)Wgr>Q\>fZ0_{>گ4[_'&M 2n\ *'U%[slnG*EGT_mښzi_M_ID 7_N=Z9&HZpgeE" գ/vӁˈkR|j @c>vK0o;u@e𣟌G =$09m fF",!.58 ''eKrq~a{7=_f-nSf\wVg}?}íכM:pqOK䟚Qz\/ "vU)CA2wďwH]_z|%7oE|Zu>)fdM VB5nwK*d'I^e#R7Iqq6Ϗ\@^SW/llQ`rc7w`uv <>a'Jkt|gIי(wuPŋn}Hh̺O Sw~,k A{\S[kmpYLKaP>+7P-p?cp =%~%aϣ*(k<8%[(>9&0vA=kܕgtp2-oYį{NiOs\38Hv>*EyMs`U[aV3}[ty.qQCz>lX0j_)6&io ̬t2_UBeGOod`y׿ +mGfڕK,gCgwph.O~_Ꞃ?CeO9 ?yL(=q>:wLݥ[7fmy\LKE?j;[? y~{AS-A. Mݪ׺ s -T/k*7cJJMj?9MUj ,19Q\qV#w+[l*5.Ќ~$5ɜ` X BpJ`9i/(w!V]M:?zvfx?`M䔺un::ϺxAsi Jv#|uGhR̛TpmBe+Hю31~%ogejFw9JRvJc-=V o#AM2 LI`r Q]ĩz~R~nv"F/ =J}{j]}-MѨ&"?V>cNs'COI墼$!tb\'\nNZ~Q>qGɿ0>AY#ˍ_lǿ]3?1 LkKPq1>R\3:G49QVr?ݏ|;uc3:|i mkT2쯑 82lڣ*:`6[v iyA03AB?7E}#CFm;}5% c1Zq_}-qCt8O5uPDpNd%\0o`H:6/ٽ0Kg׸tB;Ї{' c\GzZITx:{@͛y29J![G.+kS><4Z,Ev ؄6u.ꇇQ$}Ꙉ1]kPM,SK`폹]ݹ+zzɼ_8,V "|M ͓׼u{[6FVv>GΙs4#|Uڙy=y =cl/GLC~k|`'v$7CLb~p{Cѯy#[r<~־xド.A(>׫pM8FF:CE€5>/ǒ[vS`oLngMh=jKXsz'oyFsf ~O]W(oawϺ3Qu. G_& -([#[bq_]YG[>)#t6"nq׸W/|z?e>zow{_]ĈV','S$:c_̞1?({ A_Ն΂:kq-g;fHWqAu ىFdřpi΍>7g |nzr\COSb@P~ G:ǿ&⏑sgM G_ؗ8ȓ˟º:K CD&b^\x-i+?jf A&ǁ74OW`mQßDYO^3:=`zGt7%X>/AoS'D}xFy锟*)+Ǹyt9wVlM^-k#89U]aME7CN3(<;Us^G5 R{=5Ll ơ]dې*-G=S٢m E Q^ǚx:[T҅l|ǯ0hs{7T?s<<ӡ5>X/H 6>jlOC]Ru0\׮

c`M~> .Gy9qL (a6#-xGQTȾݫxl{ ,E=)(mi_ӕu\P׾}Ƈ7$LFϫ)b[:_0q@gOԔay%"cvGC?u|gw-߅Υ`+|j/̻?'+9O56xTD9y b8z*oKBu]Dk>>Ϣp'(15#nzǦq(tuO'p(nhߙnFg{k?XyJt ޢ}B5-+_?y|Zc?k3/(gqD]% "p7oeF2I-&Onm8ҐTgWIq}Wq_&Gdelp qYǏt&UPW}o;GQ㪁=:`my'O0j2ԥ'$%ʁ) 9G١ouc|Ke uU<=\OO !h_hn!=,v]kҿ!^grڀ}P<OCCl7DunެG=Sp!'6yh偸n̛ 5l} %U|cS^`u/Jկ(gMڅe[GKH џAP7-w^nPZE 0xR]vA;O[(MN^E;њ-b.w=Um8P=v}HY޶Hæ#Z[!mJksCPY~ʻn]eg]0v]xS| ض՗a C_f[g8V߰;GǢqUu;mc>w7}p^nqZk ;XВΗel>Hn|<_cx[/D Σ&\M#xL2ʻUqQʼK;:ւipX+ꃶ:}20rG!6Gб\?!;& cwߞUl5}s&8|0UnWjAwP_TR3pnF=EǼ_+s_yɵk+`cIwF|w |>[?u&d(}1ܲ>;PGy O{ӼMz-ׇ}X]E0)&}S`Fw?T;eM`Po12@xws_v2WeڕbfͤI?ԍGlBҟNӌ{vߊAvڝpꎯN Tfqy)EʊU-ݵ3@6x= {zثf n:;Tԏ6"qAӑS +^I\A֨}pm}ڿǓ: \3g ۇ1 wV ΩN{{-$@c}S=zb>264l3߼k]AFz=='`.> ǡQ) _0oݢ57TP~ӝ2,¸T6f?:)smn3,u S88 {X}L_|TVx?.ˍΏ0Wˁ5?D3{]_%M"H,#P.^'qJ_|],fc Dо8Q3?;0tG\`_h3;vO.=ٍ.[I奱x0csuǂĩ(i΍;ýSZĹ,xrlAq22^aG_{oݑ&H_U C;0cǻ"@<'x`EڟY|e|Pb!9hPJy3]6$v$+wד5$Rn< szPO a=M@GeŸK:o000!]3U?qo:LN-E})1Ar>ڧ,wEY;-g_Q7lJB}Q~&O`lBq=rׯO'0V{U;Q$Jd\ %2?Mv` BE9pc~ k?q+E@XA.TyȑkR`ǁ>e#뮛#2CGǟvfBAf^;W~=K!mL`5xF^涎+1徶T79~V'1kChkQ_v-;d\8D姭fS0~N> R^8WX?Nr +2ؤ xqȳu5r:՘(qYgdL3NCzmпqN\_#Q^| ו/Q;&ayW:oaMȟ_P^/c< X '3Qb#;1iu]Qݛc+9H, bq|Bk*h1 slOt>@PDeGp6sR]X zw98eg~ۄU}?bWhI%Ӝ])/TC+o\x}D.ҽn>#^(,`<>c69 r׋/܅Q .[0%(0<>+.qV=G<͊αԏ36ר﯋qDoek0i%ⓤ _{K"PNʠ5C_ Dc>W1^*п.~pkCW:G}'nnkס)deQ~/R+r7Yݓޱfx?"=%گjh#x'XD@ۭ:C*%7_x v(ѐ&yTWk`|>0#U>R8Ue=jJgá{Q[TYV31/Ր}wf9؆v^? r ~Opcw\C{ڇV8k@_.J1 u眏A;-]r:?MxO\JUG+ _kvng\t6??o~w}oX1:Hz r{nIf0vܜԿcQB}p MB<=BymX?_Fhi'W:Q> WviFj_4^L/þh"i"o|vȃUe/.~ޯZ+W=G^d苿iB_隊XQ֟Mξ2SI?dj69ڇؾ7Aʫ 6![SDt{Q+e Bпgosj;x0監^9c?K>XS y.߫ ҷ/dsSdUo] دeTj=<3@?;$ \68#QC˜ͧ]\~ۂ,=X ä3ʙ}q_s|`6%lȸGugk~+#YS),eEZާ5g^|[f &QtVsBFX5귉GeOOÀ{a#i8'GSt;(7 /~4Т3H~ȦstoxUp\_c~ ?&j>?e9ߕT:^MAh.kwk];+82$v'}g;GSvM=VA6iIq}!R>؃G1rQW8dgީRf+eA[67uz\?΁pFAT;VGX+o/@yE{Ӂۈ)X+ڏqUjy<# 0`sҼQqdJP^'P~Y͡>Safk%Jh0ahC@Ziy^mUG?z>NKq|h@7G_8.#Wڕbz 坨.Vv[z2G vo|vl}nrJ  HV6@\x/˩?U \mR+ͿHh@&Ou[{&c 2Sok։c&G ROOC|+Ve]sO=qy(F|rE}ẉg .tނorm?bbzSTIu/Md炠뾕v=Y4ذN:a=OOǮx|%?keD_/X#6诎j/3/O`nޫ)ۏ;/}7!IИu8߿a6d'}Հ5h۞(f:gͯU? `Pھ\,?B|e)"}/̥b>zǍLS#?"_/Ca5q~(߂+7=fY>Q,m_!힇r y9Fݝ 7'P GN`.wF\& g>Gܻi?Iq]9#ooĽ#`ɸ, Ϻߪ(?^n>^WcˆS6 j"1E!iF?ypY _BsLe&u|s*\'y8Sduƾ?tA\=1Dìً& 'bڗҒTU瞚P~/wL܈I|f1qa-g9W9vW1!צ!*MF>zб/H;Rٽg6<8br/L`~ET yrwŗu @MHxVv:oƆ^VRپ ɯqGhxvU\/ͽs{ V,kArυ:S|ѤD6=d.E{ :)}jq)3" ;.'|I&S|Iyܸ rY` 0t@<שYOfS[sOַ`~Bwߧ}!n3KߥEhchw5Stl`<=3N޷a$ן_-m @P2y>>Q S'{ևh/s[CڧC=cۈyC(Oh' O\Fwl _Du=*_碝Jkov(g8 uzrx0x=dZ%D;Էt_:X?grB B qkU17q~(!:/o]P?QMiE{KTSbei]VԓY1̛~^"9XW!.~V|{O^amo]oOWYG=էL< i+@<2签kSau8p1E[IϓL?u:W?ApwC&^)Z[e8LD^ƨKuE/|ij}?e6׬"E9Puq n` sZLc1;Xc (x~M?]jhW\[8)`bp%=r^|X~%f.П0{PEv.ꓮ6`{<*;igқF vG bV M\~tEy/òD8Qpq ORQAƳUs_YH~ (_{X3)4eץ Z%t7} = w6M'S}˚2  '1~_Cu %@Ҹ?Ly7k{kgMC@tk Lgk܂v_}`A"ڸz֮:F<7\f1 hl \oUbWSGh&ϒϞ {j>@ C4$c&EBğnBzOq]T됖vmY=𓙻Mz立P \Yo_p8a磳Yp^k`o۰@8Յ p,컸-8p=&Vo[_&߂Խ.'N+?γI@#NX϶}θfj?JRy4+n;n^6Zo܊뼠2r\?7~0Q^b^7'gvIJp[|?|ee[U`u|G}{n{^#$έ 5zzl'|E!8!QCP/T珠~poYJ|A݀V5ˑ(]x>>5Z|T?q_h$ԷQyC8intNmK $|)[:?{OdC4AΫI!F=`[: y [\VQؾ'7py=?7-8MzfpOzǾs3"8 NKW?t<-6fv{9gKhW{jKAbofq?nB}`g&1=q[JɍW{|8 };#(Q/}jKJ5k:_F _)ލx:\79h_4G7 \mQڧR#~jkR¼ߵwe }.Wiǣy]`F!n~P \ݭm2AA%h4H8>6%~y%b`xHu@g/%8 NEcjD~De>Rٰ lm@AVJ&Q k{z=A(FP#Eƅ*iS5]G]tWPR#L91;Łf~aK2^Wbp?<2xcL'g\8]x v啞ME">)=ll-(WƝm7QHA +4Steg1ui?s+{'꿱`t;ڕGB#Я &xC'LAh$lĮ)X'0L}rnC(y^?*.A'˭?37k!}om_-?1ZI|Axv _oӲN:m'AdH -([F!є/l3#u$e]8_C>w$P\U;{m}<vM~cPϕtYCUViO> B^Q,2?Uz{W姫/ "֩o~nXp<&Gurc=<;o~]4!~r/n[IiQMqDNEMq 9Rx"zN<9҉<7{%"xZΪBޣ=@|V+s7ATl|u(?gNs6mR?xhF?gHߢ//婹O3"?k>k%O~8^ߛ)o[F`vt+_ܓsB# ò>)_E=eί4 ˳ZK>G8S7`:C;5V1V\k鈋uC>.p1OނE'| A"Nk>齩>tK>t)oŰ:s]n6YΥ 3`6WͷA|De>nXC.?^|aB[CWk:<B21e}2g`Ep團QMro!`ld#+)΅vY1HLvS'$L<X;=yU  [?ߏ>/,箣8~A]g} wOC|ZHw [ˑ?s/i߬.vۀCf+ڽؕߏ~jwa78-=5|Cg2f/~wo w,XU.CSS}.C}&)hz~/Kv/?8a۰FO ՄWfx|K7p]wi*psf ݊`|jw&h`E Q:+{oFofry ^sكԿ7 =~ָ`i0~[;ղՊP+N{o/ژ'i5(PgUBK`jiŒ=! LBJJ95gg 6T~M}pv6<?6yImIU>Ղ*dlZU?rDR|S52p6`~U]?AyWKgJ\ۇsA­|#3F;ޛk_C.M3kgFvw88m &مU:Q0,haZ 賯R.)s?FՐvoS~ [رym27ؐvd@b^/䇒s3hβO=yQ)#]H]W9P݋gsi2[AoLǚ_i {I||E^73;t6I/$SP| S7+=z;0]]'/;Sc^֝<es-Q^ڥ_\7 ː_zGg)D.*!О>h_~ӈ35>jMЙӐh_\D4y7>siLNAdv"$bU_}%Аi_߳&_ސA~+.{MFLn:}ݮq~`Y给iǽwøQV%){q<멯J7kNyA{=GQ'O8|4/=1فʣr,7s?#7忓!TM_c ߩ`cgS=m q ňR#8s|ȯtݗ"SՔ v[bk8NpO"|#+tIz_~_7[2; (o}osL`%OTsqNqw=ڟwaZpFʐo⸵_R1[ij`|,{D;Ә$J,h{v#H#&Rd{o/w}m| 8qRb?> wTn_O@cë: ^Y*D:6\e~U^^w`O̹B6LߏF4}#h52|n~o>ݢs O~,A.6>ṁ[yш߂=&E1>7{nuǾet߭%4 ,Balh{OIuҿ:?N8cxӚ̒I=gCZ"ߏӀy&_d'|A^s|D?z @2_BD*ҿf7؍7Gq_/8O,w ׈Ѯ8=:A7o_[Nz~ {\.L B(w4T?xhUǫ[YF}3MBϊwAt}ʯf7:v@=TUM'Ej߶\F{2nixtr'!;TTm[rP~M Byr$6^WF?) C'qfkwnNѬ҃ٶ[ ȩ^>y9nsB  jg:b_9ڡ&{NECn?rшWt/#Íxб;5$͋>d"ُW?.=N)wڰӜ@_% KQe=lb^I+~H:F6NhL$gM=)?2f<1Ϋ'#pKiqo#Q0e?*Vi8~C!\h?ɧǢ|~^ދz=:A2~ռIhb7({37DSNS`X?8o~93-8  #)=M@^Wb:c<zgQ4z]k\z^w:^ߧ6}/ PUĥL{i ~rt߳k=mʽz׭ _s6\]ݞyS`X -]G5kqZK[=b7.S8Fҋxu/GF% R>r?=5y p契Q>>ta qZ]ov JH5r/ҸШO|Lqm^׹') < QGXxG.I8XvsY|̥{C1dI@yyI[g{8'=0ڄ~~z{MLYI#Q͇iAvs u^hU+KCU=JmoXeڃetSEYa8KEYa[:?Nkv \2]bWc-jC?̘M7c%کoɗ#Ug]iK//^i&{8^TSy[x[y{߽ݹ eq9bZ|uŞ!Oeɱ<{vBᬭ<˙4O?[9~4o- 3Ӳgma|"MYE*JmLUK#@X_Jh:mF 㒧#jn2(iݳnuB )#= eYH"]DfDs޿|tyFVJo?iǍ^ʎXx֎G|m =IPx1wG4~=εgk 8{/Yqc`D^)$?(mL77drÿo<}Z 7Pn/W1a m Uh.%v⺜."Et2iy.s#vp~ ND;4Xb>_<8/'܌ H\Nc":Ễ^o2\;D<Һ߯y#] uY,-pu+)?7ߊ6.3xO_֓w;P#Ц1;r֖@{0䕍$߽ RT<1=?<^8#F>mضxm#V;>4Ssю=_A~]'" F)6Cxek{e] C٧w{cZî;ɨlR5~c7ֿ!kyx#)Դ~Ur]=JuSЩ n|^=?UCB~`|7]j-Vvh9/Q,nɗs| )C1>xs\7.pLypPߚ^ GIP}{k"=q@|l2758\V=^K~wUroID; /RLLirk^L;'^RX2 vR7܍PoQT5k4HD^~mp؀<ƹ}Yo_mz</4t8ߦ3ǧ _ł ?8A~n s& { '?$~|>ЁL_x$ؑ.(O5.6EG? l/Ǹ}o(Ի>u0umA*z=5|[YلN9?ㅸs=_{kp\Ǘ L4|佺#~w~ OCbx[ z='h[q*ٝ'#8ۻ=p|x6NFpOæCr^#^Y\U\W7] S(U'gY8.(q{.4*)`ԪRJXK'lP?ڎ"P O7=*O=~POp>3f(~9꛳.A<ֱ8IMA(է"˩?^'5ګvNgW W儍ξ2XU쏻<ܖP_ёX߳>HF tn*e_v373\h~3IRnãi؅8.|} ]Z{qUtNvNULp99u8{xqhUZ' cK>Nr̻՚V]ƸiƑThTg% s)Z='A"DM'SM~PypGq?(.TeSepLoɰ0mۢ_͝&+n8&/*WvY"/`6@ 6ụ 1#zd^Vh#댸x46~ZKYp֓|'w߉׎ `9{>CW#P=mf+?^}[/xg°j`WF\HhNKUV_A2`Z߬q >ZCmˁ:/X6s>̖T۬Q~o"ӚK;P zu56Bu_8R׷i'՗ז N?Bq`VͦE'چm۴֕?⤫勢R}y=׺ ,X7e_~XMv ;lY Ю$_/ {f3dDT x.j[Fs3Ѳ7GlV!+y;ד[,өh'_uP--o:a`lq[k>Q/=Av#n]zi|Iމt6LJ\fV%浊/GI fM 3l2v2F>f({$6$폊݈9mQt9%t{Pѻ]v~i3۲R ;qBf蓢ޗ̓?!p `;Yf/CifN9=5>}#nCuUT37o'Rx;/7ʏ ;c_5+L?[+B?0o_:boع3F%7O`Zc*A).=lUK$  <O{d _~`^u*?za\ھć!a6>yRڇP8g8*m;73R}ea~`;`տ.rFUm9O|:fΖǚσ#~h'*DMIU1_i7;=/24ʐ(Wށu_fjG\ki}5<ڽ|&qK2: >,~2f%&^]j &3YѿO{tx0uSW:2 '&E43%E q\+ѿKΤ-)8)~d5 E8UE6Ոo Y"T]R-Mwyjۭ |i-y4bXP>NΨk^)7J_!o,ۿLTZg9%cڸ6OS}q-FquE;sI^yP0\{sTvk ˙7z\ ќ5o=Jv>ta^jݘ6hGws\ ^KfU ;N/plwr+1p݌WϝjkOt%LZtOO`g6d*"1v9i槷t?Ẃk^d|D XO/F<@UHS`Ȫ^I?{tHp[)@s'4Oc߇"|޽y*t֙R~>y_vP}xZ4F)5v v'{2PCIvCZ罹mg1㲘Ko?c>m2NZ"t/k|H} ڑB?kniޤ2NS`=~%=E }OqSmY~yV#⥠7*D;RE t>Pv#WN즗]7y<-cm $?׽O_Fq9ބ~-i u._^>[<]4ۨMYȓn7[z+1Kܲ@^-LiYD%r7p3x'P~~OX_}L>LMGu{P}s$yȭ¸qHgn{SؾF\S:jf`3_ZD ]}|Q”ko>.qOlԊ.@S#oo~p:V#IS7UlzMC}6>;RK6|)gi*?;p;݂v# Inz.(yL0ۇZyUݱ{Dʯޑҽ%_"<0=BWs<+P?gQϺrnlBӘ6>nMY-Gt%*=fUH݊Uw87ٺqWm;<BOc&Rܭ}c~UTꋪ/TXy#FXU?/T8.7Ƽ-<;ڮduh°nоuI_ŶFKL&:GywKvhwGՃ<ӌ"?] (z w5hoLwRwCY+6.B}P0P욝}ǁ/1>3P@8ec9^fZ1]Y2=\ٻ?8gt皶OWoƛ/ʘ-}o|(y3\X/9gN< C>kD{pCnrαV1D/t[v]̬G QX{=˛޵ ;wF@a}{<  n:np޴y+wݾxo@e2+L/HtC6a4|A\>2ORY,Xɜv#Wz:>] Ayt6gi`Ѿ.NKF=ڭlh_*F$ B탟ll:jȅu`e@q5 뜚AK=mQn{L">(C2я] nWh΃[8?ehyW>WcvݎvbǩZR\H_>b\j<'uN1l+frQ!oWAu/k{9SEMUD?9s^j(9ŜAq ͣЯ/ ^ܒMAb|@_ͽܟ('%j-Geج{BpuH@`,G~).Ҩ!@{9mqA+;Т/8f5PIro3ϖg?&Eoh}A>֑i]G @:MGRE/F[Ay'UOmwL*Mqpͦ3ua_7q]1[IVz NYz;,H_ֽr|ǀ5%[q3WQ3QE8 >uBiYrGgF;}*A:.EG/^6G1s YmgΝC>WLj*D74޾q]C~,]7Gtg=JgG#{ԯ{iXԜ*BhQ ⌻hE}l)./]O~x, BH+aԧ?Pz9A:6՟wK߶e>q ΫnѯhzΰK@ا.G6 Y N.D@Յ[y!{a*pT8c<0MEO4o!mP"n |ب_դiFf3}/`D"ްоd~w~yN?D\v7MzWwQ ݑi>h&qMk=C/0P.3\}8֗lJc?5`]yρq -tp?x _朡O%a)毚Q>߿w,^йF"|H1q7p1Z{?}%tя+yճun#v"}#{HN_#fΒQ Y❡]:碿Yw/4*MH뇚BƉRvY!z@b]ggA|"48>ݙT_^qk|챍7w!ginP`E`{wΈo~TԾJ4>׬/34W)ڗ̦bG1:vO G|dqD{CL ~55DSsC&KۂӻȾX+?=NsJ V7⧦E >CJЩmѾ945]l ն^;^g ڗ0T6[2&y⦊3z&C;oF!5gu֏_q Ik snD?;KoԈ#mJAە%uy[? '^1>*JY l9kѡqx?["lVp<QzX5v-x=߬h|O(iN [gRxFX|Ww~h^TlGRi0y[ 5$>O {qG=A{qD/Ku3 |K~橥:C O1?⣞7b6y pzx=OkiMQ8ۅ} Gh7]j|7mNٟC>q|juU:gb5t㐷++R}`(NpN1}`zY#Aun?r|e;;_*h)؊kGH&Fk-{{_+e/E:\4{Bʯ-{#104F 52UET׊_4Tfmٚwk~1p+yσۨ%tPJ%85'^y#o8:ٟSHGDNT{?=v6]~G=tό-KϾ?ߝ8|P{TVKZM7'qv:GS XPG;s|k/]# wdXۿv%Iz < W7SBpQJȏvSCKOsZV8oK5[}/$~=dQ9gw@}_t[ցe8|qe@x |9H-:m!?]]Uphw0ʾΈ#^]b;Dx p;Go-:rH=;8P{ecQ(>Tae TW8!2w2 8O뻲['h^ P8tuz/p9n.( }r@ϫ'7) Tna>Cx[t[i"+|->'k>՟!eoɯl.!!H;ŒVL?T/#xs#(bN6PW2ÔJU3%_ί8QW9KDUQDXPEx;0O%}]_/QK1տF,Gvϲrp6t&1ړKֻ#}S~Fi2v >Ҳ 3z%M&O`y `"_h'&\U v=LPwgܯÊ7_Y%?2g' ; Y ~w؇>W>F<3q خD%_\'xSyTKTpZ,˸5CieŰz6(g2$ȔZD;:Xwkߙhl";…s+'HW#~zǤ={:c~a=XmTvpΟwg'& MfRd+jopE}e{?O/OGelIf#<'T(y굴ήScH?w'D}x[xc=sz &{Eq~ߩgUT(E[h7I7oeg/jm?_YfPŵwtߧ?wlu_ִ `%xs:!_eK﹙黨eT)+|$ߩG/Wp8}<nk ?}k4کt~A15gPh45$mpGQ};wSjx$~qtidLSp}һ;f4 F:,@Fp\%^zC1oV>ZU9EX~B3 Ў}oM >@/"ּ])+>繟lGYȯͅ?=@1kM l3ڇSKv$_1u+}/{8 Qס_e(DR(e 4dʙ@L;*7]jk[2l:}=7?>L^NV5ڗ`91S}J1Ɔj}g>ckkA`|IOkS/Dǚ ps[NE#G}e/J_Z?IPb!_POgO<ꩯBiug-!sv?Yߜ#/T$:G ?}h fc~gooS}N9u#ftע=b`? &a(wusK-cW:3>~Տ֦Ȑ_ϟVj5;0ͤh28xSkϭZlъQ~1^Jyik|xAe,$faǔ[ 옃U(O>7Ǔ3_U?AR9)5lpF{*4'pr~})] G5p?5dK-DWep4I~unLp;S@0ã$4QyЌxq{aq5/;V|FJ}غTsڂhғ9|'8[{Y7$a!#1t ʯ&~ٍ^T_ `/P}yv*[JIX$_{dP`^`vKG1c9U~U9ΊQZsO 'F335s͐Ǵ?9;ߡL7#py<|._>uC<ƾF˲,Z,`"ՏJfKJU'u'}5XKohhyzMownDwE^pz|͊uΙWD+Iš;X! }su>]ƯC*_!_h9D,y{ wm΍wg'U?C(?w6¼Qw!X?[6u񽦐n%;Sh}Bf889|XvpKaǩqǩV\ԝܭvU,|?_QD> e|V\8N><i6j+]Wy2|?]ߴ?z~C;yh %Aw9<[^{+]=#3kĿ_Πi6m1PlN}+'ߛ/k[W!@vD M|۹?oޟ͓hlf?,ɳbQ?K _<+Q)q`,E{=(݇8=ꗉy"|gݿ#0G>zx+څ]:pI H2@fGs΄ay9l9޸|A0I1k%IMܵĺfXb}Uʵds]9^:Պa</?[{߯l"J%|r?gMX[L~~@}kDS 㧾 h<&-F=i{j-SH~OL=} lF_PpG5éof?QnUjʏS"LּOq: [p&YWmX3o# GK9\_6%O] ~gϬfU.CyvOu{:f,88[`~<ӮkKSC:!#IFy绳}Qz;l }b*9pQS-1~$0}oKpzn_B ="aq]{_EZ?s/WwCgz`8?#/YoqW?+ 3ePupĪ`/E|\nM87<?;`]>z҈QTGzs@U+:hY%1 \V r%^[_nbz#>{]-Է}gq?_yW;dw_ݯPT?NKAH.8Lᯉߨ7A:\̟I$w:Yp?V XoXhs+F}:L?e&1x]@\>)&15B}\naj<5B?oy~ ?<}(?^Aw}G'aaNaKX$-,lw3-KpvAY|ߧcV@4_!uqڐ^2^ ~5Ϭ8O4 C> ?x uH jςc]hm5[/gm[}OQAj?Ql˷qW͞h(q㻼d3pFu/\o|E\e.~sI5HFVOX"phDd(kZק#)L~ Գ{б~MA·#og}~ܫ]酓g[^0.zNܭZby_ >E˧.O:@:y`KoVԌ8=ҽ%7ʹJ}C[,B+\AlEz R&gOV\qʫϾG弝N Nj5`?̪g73 M(_jͯT::@$ڿ"`fOk~=MO7yu\D6<:b,֪1}aqL?`@W_Opa"ځ`^\OqiDgvP|ˆ۲PۦK48߫*TCQ?^N+tavgo5GpJߠ>.| IhOq]N+j=uG-Os8Oq ߶¡QȟCՇa{No^XjQ֝O|ПH~/?gҭh7Cַw,aGs,qJBpbMȼquKul Csʸk0o1: F^H@|tTǞŚ74a7G(}qF!p ~`۾&ڀZxy,O{r>FYp)N]CۑGUw67*a]"CȮ'~D~xu}yXf+wcU14_,}O k^t[3=Xm8G'vΩgsiȌ=hW %qwn)Ŀ ҺѪP 3\O%ݧa~IyºV߫nׇӁs/%8Fo ~gUwvRՅvPOg$^w_v ^HyfdlAk|ZŠ[.iFwRճ g/{hG} w֮ mcшOo!'p|v]uԿ(8աƭ3}P ]cȣ|y<2K)1yodXas׳2qG4!x׼Pl3h~EJԯ=5{~c:^M~s>1XFy`~RM&#>w鉎(Cܝ[Q{9?104zy|=S>}E?= ikJouro~|?†̑Lux΀ψhLSecc5P=13i^;+ ˑ(_ETA+݈ӷA?=; G w*ٗ9gx:K7c hc/CeTUZ{pfaxa,K^gvr> ܑW}΢B|,nC/J#G6d6i'$th ' eDԯOS)/x OdmL$;6`0ie,M PDf\mq1üM9E+).hXǣ~tnNvv8~$Twy!/u75.dae_mi5HKׯOp'4{jWL}G7q.::30xT74W3J@} ʯAIϵہ1~A Kz,s?"O/>Wccn¯&Ww}ط۽ ڹƃA+qܟ6=.ڏ@PY5p@o##ڧBDdսNwX68oY._K#5Ntk7c(u`pr@pu oVjCf}J$T$ϏGmۛ7cX:A"`Lv .G6~;&e]`Ց -P}'7ԃ-طbܩ>|+ *h73_񸝊9Lo/Y'wRM2qQ, CѮh*pWmޒ~lE)^͌)o4C*8>ߞ!ɽGPfI՝gQj /=tu0z<DQq| q*a_s H6,Eb+pT5/8" />y?(d iɥ";0T:<.e/g`^vyw;5;W7uAEWԏ4mb3E~Jl0lVΙmw_-}@`k=%(/YU^; [99!.-肧MiiS:Aҹc 䥘_@9hJw#_;)0.s{R%gK&ԂR6/q][iCm!D!+G;<{&x=_O (n͊|EI:gNk;ڷsw`OPy(Z?(hxt!"r-H}%}$l`x5R|uf+ieof;U|TyD:& =ץBGO{Olo̒§{?W_evK- 6\/ iPOǞ\[GQ_+1*&&OE^͵A?Ny(p6X),.՛/hln v7?߫; H8)|*o{<qݣІT.(L櫗+՟BϠlQ~3۵P>>?d?GW~ݷGdc2moS{ؽ1Uh_ WߗԷ/8pft\7-}xy9;tzLɷ·>O|7On-~fl3@';wZ 6!}3۝nD) NϹ(n qޜAоVOC}yl߆LpODW-( Hv H. ?{{NU ^(ʤp߲"\NUhߞΊQ/z7׬CM1SdÊ}Âcs}5Uo&rn[ld)zz]=^ǀkF&i/iφ/YZ9zՌ}?M1#(oN* sc,tXg- y}mxB}5QA?]qǡ;g;i:Mm1>xu?F0Ichɿ5D:5|;b=;'kt;ձ8}#3S8WXҾ7LcHZKLC}!K& G{UWVntNr{dcłS伊bܥ_hT 0<'iVn/|_ G>!.!%Ywcz#?mC=\|cT7`~x~rVhO*|AA/ By鿩=n?gӢ\4őu:FZ,)&}4~8]ݸ*{m WCy :k/?~|gIk~Ʉh?lyH?[z?$/qY0ܚxxg2ʓRU WS~XSb1g^{ԭXG닟~upm/GyF??+z/ w"Kkzeʁ7Q.)&0ޚw1pgw}H69 F3z/~lJ6림)\ Ÿ7 if=뀾Mk]n(OixX_.2R5֥w]5 ymzT}~C 㡛}g[Xw̾(3(HL&=7C0G0/ީ~ERgW*y=ۜ8/7-oj`!gb8W"~:G;^/ڥ[^d ܃#^ AFckub=8\@s힁+q%#u)!:9םꓬ!g(?o~ ߑ>xqɈͧ[zA͏E^ 5tMOどtev*aOx2lyPPWb΢Skq̠1r*x?f5/癤 y׆>:f>ޟ`qdv> N+"hfŢ;aY^b,Co"!o?r62=HC<ĝQT6>G9x?_]q~BG8|o-p^>mAyTaW[686P/RAڞ*pw3~T(7a>d8gqUg ž/ g߻ vœ0^RF~z2tl1'QԸۘ?ȥn]̞r8*?dPZ[>uuݚsO+Ol3C׸ϻT*[_[P !E+ʼ GÑn/v+_J.Իj? X+m]y" ]W!&wb YRt;|ՠϮk;~Բ^r*w ֵީGݾ/ډlIϓMGi}Y>}jj? y~.9ų517YSBg*E;?@Gv:۶{X_61x{9|]צј.?>6âk@fҚ5v1(g$ ;.uln482QzW[mGHvt@?P܋K@ϸ8Ac¥pyϮfĂe! WqCUlB߁||[."  |<|D4JutC;\IcSq'o V I_NC-菚k/oo^ #/FL/0׍$nh^t?|hu-%S"/Qt]^eة^wٷ@O`?Z]C:_Put▎w"d$.|Wǧgާks?p޵`^ձR&C#/#^|͘5qV[03`OvFtOv~z΅+yQkf9@܂aF=jԃ}M23dn&8\̫n/_?iTHaU!qI_*]FhZr{#BUsDӚˁ#G#^-۽vC{|1V֝^Tvha3fI{>Te8Om濺{wtW.cOSl:&865uD̺B*~8!{99HzZюeܮȧRub pd%>W._s[t*% X'8Aa_Meշa7[^ɽzWU9n[ڄt>4+ /Wq&~$}>A?ЙOQI g<x6Կ+2|:e*ֶy,sLNgsƆD[/8X=N2Hq?j[º={[P~ouߺ:)R)~n~qɗG[  k™~.o9}\; BYSr%6'|t,VL'ٮ?2f~T)ͶL .k6{<+a1*n[Fj1w7k!ˎvM}~k3s5\\q|?_xwOo٩^{  zY7qo7$`vBrOK˳gd^;@\߈6o_ϳ#hۊNhW'R}ؙ'}7]hekM;v̂Oסs20M;"0ZBq-oS|hkǧ>{O-[+9)r7pKeIlSVO3OġU5f)/۵+ WCy(2V+Qc(_a)/u+ !3Ө?U|{=USGG rq{GڌߍHC;m]\|l4K_y+QrZo0~/,[L|~=,^^ ˟By慄߻7_s߁׷A1asR (D4毚Gӛԯ[ܦ5*B\vM@RTF$t{@(7nu.Ak~}g8F|`(hOaKtҼ ok|e]%m}Mz瞜J**V.$r]oFZG]tL=,޷_;E|ynaa/>G.2-B4QK<ֺm?x!塗/T:yge={|.Cf]78wu a뵺 S5V_4*OJ 60t\Ž nƤ /L(o+O3xl 凢Y&բojp)(1W]c?3-5?yt޽ǩ̇{ܴEWA2Mr,MPy;y-vM}%vT~i&AtǔtG.Yx;ו=WJH㽍昃@{m]6uD132i|m,$|nc~6kbUwoa~wEludW/92D;S@ LX/ 7b|4dYcHɍϓlv Mfai+pQTinNc!?=D p|ߢd]l~ǶZQ[0 zgW)o{wrUԻ+nEǖ~73ǁsn>W|Ry7a'UG5|1w{^IAZw/n@voGTZ?۩>31cd /PzfhSY${k?qc>mW &zv,W-;8E uO%s{}^(. '\Gkay5F;8^Gh߬QZͩ6Mw>Q~wj_{Ս276 'ҽ7+b$gRm'&7sO2Mp"hT%L!;Ohܔ֝FO?L *~=B=o(nmހ8mA&b/`$O0l@/`oB\Eq8 oOУ;F6FgS.ͺ3|[Oňt|JxלQ}7{Ec~yl,C0|x}/^UPƱLkwj0W OEQ$jYs?O?soO'ZdXZO}j1xNuCշzo\_Bwѫ=;0wQ.gS0;ѾXnR&oNvAcʓCw4S^5-@/ם\Pp5iw vhgs';X ¼t_dCO+^Ogl?w]`3o, 3µhψvA}*~{QwLla(=Io%b{M̺I" ]Mi±;fJn | ޒ~Uzw߻5;7_(XSv]> >?;zMO[Hش yj`aJK%vXYA$7Ai ~ =DZ?P3/]ߞq(ځa̘[&~?)술:ѣC+W=)>JOou[KwzXhr+$gL@rX&Úl_9➾"6⥟\/¸)h '- Y韵 lwȖ%w0CQc שg]qF_sp\ >s1`}-*Ww C}1##(:C  G!/Νrr:t𞜯E>%^_ܛ@{cTo3~OxWܽ큽Zu?q~@ '>^<=S{`59>_uW";m:ɢӒέ$^ۄpA7%T8mc-y.S?#!T)__qx>>k<7e[Vu 䘞c*G8݉6aiS~Zu$W?N",eTft )@dXY [3;==>y~"G!蓻=q .;G^p^2ڷHcI"Yڵs DZ~n6ug;rvtMw:ǘ9 [I/J6!QFy#N\oQC G:u3q eJeW'긏=A_|ӛup(Zǘy'H/cxh1cW=ݖ~1u^ixZm~ էc!~Vt2!M29 pcQ/Un%/qyMCDch84~nkȏY,y#rs_wJ-'&VauyڣnɹBszN ~!:rɾ ?zd*קO1MSAsa-=yr&>ҋێE8^833m}J]/-cY.qcX8KtreGoeJ_ y<'zo,pfD~_u]?LǝlG.=<)Fg|$N85PZFq3lҰ VBe܍ίTϰL .찰khqGǂpWԯs^]QF~v#Ht w2ԇGfqݿGjGiv#\oI _20/'Yb}[;н W Y5XgSZ/<I|W7}#ϊS`W ] 3FwGP]l3]3NT\q[~IWGeMsWkB:Ǩ?uׁ3:ɞ/^ſzʲNt򧶉ZԿ,KgՇ͝n?>Ln(?= tn!A;3; c/ڝ<%ʯ{dͧhޕrn]Wql%ppb]̱7*7jW;7g/~O+A|ytC|;mR_qܵ/?s//dk_)em_UQZ5yhpvqlaxHʿ,GjLlGIU1 q +}cWz`?f,'|bN.J 98,KWĎ-~';_{kvQCh}i~[|񅿛~#K֧ m"I&Q5!qJݿL|س բ\}ZEÂymҀ2亃6Av/IgxrxA}|No~ BU!BydgVGgF?Q+]}tͪ?v+̖Uu8'_ɱqc ։h/I?OYg2rKWgPF)geՁlM[bK;`-z[27W>YO>A||01>t ޢ|fբ?|Ng>w_@ޡ>e 7}4LAdAǏHCw=UMu>^DTP}}o:ۗݨ_+YӽQv5}p: Vs ߟt{fWܽDqԏ,ѦUܾx@I3'6IZp2myl_#)߂x㇗]H,inS]wdIy/tɓGE/0?o[}Ne5%F+8WA,> u *_گf'ڸ2ߧij; j/fW?rd曽@[gW.t {?ep^7F^=Y|ͯ ־Q/AsSBsh| A|sǸ5mnw̥sX {n՗Ў| NL3vlD+wGb<3z|p+xGZ<?`jˢ>[^qUUeq}B`gb<t?.Cøe o̘ΠM*l| Y!w kmuXס ?Et< x #XnYhgc8?ÎvkfT]G*n6) 7#Oa|D?6XA8N#T'}ՊcGzϓRP~nk'W,=ѦX,f,? y}O>ئJ[ȞZF{߻-p!~Dz?89M48&!ʝװqXRu[{ ܞeUOLGG5>uve3^O]<\%q~wwm}йKþ,|-߼&4wq:Ŭi5g_8^@^.÷1_0Kz/uV枢ڏUvG 敔oOc&~p4ҡr/#~ n$vZZow[pEKã1OYE}C;&}g+>n3ed,g(/k'{|~H}wtOkv.+1>,&,>U (WV`#32f>peu#v1vjw)0k?,CR(: #÷ _pθ7 ^Nۏ2}msB~?&P˿>k>Y[b|`ٻW#$'cek?p?P>Sۆ-nH؆j A8{  }UiGB|WED=' OfW 2żH1E3=nYY\p}~!wJ)F+w5YAsЯE,b`hx7lY`lF^.0SK) L?)9Ώ۫"ΌCTb }yR=x a.]: kuZ;mX5tuW`t<̽ONL$WS0hٓƎAT_x=;}1h-w*=ԥm hu ({&_ >H/8"Sx~9qG6ޣd:Ut^@DgᅴvWXzt]wAjX0jis#zΩ:2)8T܎y}Bc<,Kk-dPS<Ju/:?7~_)?>=Igҋ08nUU+WM>98!;vfC/z"ި}n0'~䁇XLV{:Hώ恝܍6o՜K'(ƺh^T|7T:no|!l./"+utyX?=Dw7 c(b`khLN EHjzN+6PCլV~W$ε=SzNex`~^=.XOmx&@uFtT)MN6M[4={Mtcސ?18ߪ>t^An~կo?@wE3O4sj 8~w瑷3!|t2\ܱվйqfE(lͬ O}CPOOb+>_tW/ mc:I+%kO?6{wrtƳܡm3\5':s'oaS>sx˃~`^ ږ~ +?>GNW&"/+S=ݷlFek|ͥ'(ݺ釟ƦWpE{7I>QY,795tn݂Jƕ?Ϻ |+zg+ũ.1{ zzU /]rC|hqv[>V]Dfl9BNS8k'`iy 훞?=po(;HDDJg:R_-˜73[|dao_K@w$Wy3w~}{#WZkDm{`9MH+n.n]cXG+U1/ՅG=蝌,7JpmOKץb͚wwPǩ>^r7-A/ϟx.ݏvw nSDHw9Po-\xfmoQbk:>Cۦ @By*&!e֚'r >OL.|!5!+8}aۻt6`\y}) @rff^9oOLK_nW-om׺}G9οg2?GW湍kK}mKbţ|/N w$sEwxzn[ge ş5U0Pyｫ~zzzwz*1gS(3m^ ;N" >B1r~ZpSho|asuѿe=o25ܸt_T׆q =hwYqț䅶ݑhm}X稿E|ꋸV8^e% x* 8Nu:]\r:ÍZ`TNE}_E8{c#jo ~Pf9& EdO/(H=m(0ݣ#^y _qa`FtO(<~ʢ eK#5 5}b>=y@y/u^J ??C_5=|ü~O;^n.b|䴅y˰'c -ٰqC3UG*®W.K#] S򍕎~2*mQh}TQyܚQ!+ArOٹ=ڿnd{\nҽ,c_ F;?9G_fL~hqE|* h%ڇjU~mf w#ފ+~_y ݷ4&5ۨ>*~T5|@E-8pj!. VM:~S/8~B/^+= _-N0(Lͯ .-&|x>,xkayzv FF +~!> }:Owx%9}f ~VT2׆gi/"?-5u>6wv]o7_e~LiEJM&֝ԅ7G链O|[_:{.ڤm~*g$ETRS'TlS=MW6fGQ5DוL?Q D~}yğ@obluh_>AU>Y;kҀŚtoקCdya|G>~mYB} ɸ~ ;.V$?NYOt}'۹#f⮸> kj.#Z{~;0˶ >##|1L:xŴe9v{{ zf>ߐ 1`L|](;@a*'ܾ$ Y$"Gm'=yB;[kY@kku_IPb3!d e,)NF.)7+?xW[p|~}ɭ/(wkڄ9t?МĞl`<`ܲ?.uAݕ|y^^,jU/DL=9.{yb_cwTỸ1P!o(>tj5کbjj-ά2'T~ -؉|R-0z^8֙B-}:~=l̯"Wtk}(EQ|g;<6lH7ܤMOcpbbKƽ&6^ຨɺ[6aw[ù2t_)Λ ZN W@|K?۽AǠ=4+/Ōg\\?!q҇/T4||^!4su}Oko?\vArxU1(̮Y~B?Vhu>l7Ҹo8/EΟڙdsmJ?Lo5i :g%OkWh&gާha 4OKyrer,>%<)JϢ3EȑJl}~N 6V칉v0v쇟?7~Y9ڻ˩텩1Lt퓻vCKkgjFXT/Ii(_XqWxw1K햳@`!G45 dO0=/.xK;}z}e"dٔ?y/xu:8~0F+䱺? O? 8LOkkާO[u>Z;F`]IyvF]xh>8uc')]}mb9:3Y-)W$, -1Kp}XE7v$}{Ck~V};_" *|$Ÿ?>W886dgm\qQV7#zg5?t?GN/#>4< B\*(!wYL/ro۽ D90k@Svy@=;߂qM97x^i?K8?gMgb}@)^ 8v_CQpo^hWʻ_F!VbAN, ։-#ø{8'uhʮrE -%㈦`Ձ֙+N_Lk[v:]j; a|8mQmu`)gQ5Kg?j{u c浥@'~ƃxI_;a8̏5#zI`̰҇%nb_@q9.m 7k N>'s)B9M`)! #Vc^;WA뀆#)?3D_wZ?{j Xںfk$nk3wg#f{``"?UD눆4^qָӱ^M#+<ӂkZE_o\^\E8}a"qzp5;e0nʞ-^+ ?ue穾TSifԗmbu޷+K1qIMڋUG!Lm|o}:7^_GNͣ\oI)# l[paNO;;8~r fŦFSnu!kq/ʵ/kԈ;RA )Fl9P_ !>'=(S$V =hG>38nY=VKu`e#TgM x ڧ0\_\Pp:i>\݆A8ݍ9$ GvZ3/o)0_rqHf_\G V1x~(%,LCW={Y0vڇ_ XsAg>qAcrȞўO=ճj"J$#!B(+HVHFH!!+IH9_|=yq}9j ׯl,M5>g1r-> 7HcD90*#:tcTdMoCo(+(TÑ z ۍ|7 P㷕i%{ 3X?0{ *Bu~()C]=G/O+\ŧ^{bǪ0)4K4veo9ktka`E{KLυPёڷ $d~o;쾂mEbj⛢SL|UyDƺ 7T;Q9d`qy ~_iŦsd4ڗ>[ѨW )_ vd[nF*N撍 =Ï]8 y'Gy[]C5 VPlі x-*h*z' \(iP.} \X[ oGd7|~??b6O(V$g=W&2pƥ X>V4)V<5Dn[_Ȟ?t1TCfQTTo 0x.C|g݋҅.$a gꏶ:GWq:^;2W$Ȝv[CO07p=3k=goeow9sũ-HBW6~<}KMC8c k WNFC;H<'aTjyxoA5V Q rih:5O/| m6(/ٱb?Ww<(yO#58WQn)>G[hx xE6;?*3*'ާױ#3MYR2x&؞K;2)Fy@@p ە%8\G[c<[y8~3o% eVүV[g֚!\~?Ճ4|`' T9GwBnէ \F~oR. ]kp\Υ Ga2DEw* :M;/x \UpOwײC8Ñ*{%///fэ!8Ž#1%ڭۄMuy;v-l*.* d= 硸?ar4kBB:G%?֩dYW!/qUĥkE}3{[ QoEO: 4㯹7м-/[Q~ߣ8OX47ҥ#OS|z݃>4R3վ 4KU̍gz9xT|u+[;穸'Mx˃O_I?P`Xw֞[[+p mCou}pA3/qm? .h5~ʪ hkr`:G::8ozݤ{'G9kZN=zcホT`#'r¯J\ ”l7[׼|P~CRs2h;i:_V[1r>8]gG#P-?$-1X+Bew"9+gI[Vh_|wS6uHi+k*]r񨿎>t*H=Gu/UZ>rЌ*TW8>Mt~˽`7g@p9 /K]jooܞ4vȏdfӎyQci㓅΃uؗ/w9Xڢ^;'EfwrJ]Sߔ-I"5Kʢ}}G;֮+2 ɳR7Y-8׋}q^6m.4 w9B&ݛ9~퓾ۥ{(?ѽfi<1]s\7ZMMsu3:)?3x٦1FʙDfv}8"^;{<wׁm$ҿS~RtϘ9`i8 yo|Ua!{C ׏@гk=2_;l;v9΋'}< ޼`H+X&}.>Sl.=nO/]E zZ CspX`Ӛ};4ښ![xЎ ;8ָq}3FPqhk orx?_v!O|F|fzooznw#\7EZ| #QvhߴqM}ٵ_(؝@?dt#=e/x>S {cS^p6xmPkB\7}A,N L`8Un4@neϔIUú`dﮘ?P0tzxЪ`sn#/h(8׼nͻ`Ywi'}Y ;pfÿoZɸn[·?Bfa| b*YA^bp>ؔm݁g:pɶ< Q߆ k"}o2cWSʋTgz1`h~#ogĪn?P2[/9)"ʳH>3 3Qk3vx6WoqhcCEs,IDnD=3G7DUe2q/ pq۾G;1M6t?RQ εKw/qJOT"āc)1oҫѾD7wJVP+=;4 =F#9 '*-V Cds*O;Et̛_'~1?\#ϩP^,(W r/n |k#|Yw!>@ Pn)Ojl[;~;SS?hiˢfek~QУoHw ؽ/B`{?ۗ#=wUGIƠHZÿm\AT+т<|}V9a5XDn&QݞY)7nRmBu:Rˑ8/̜-#޹YAP{er>\;b|&.YPO5HǠ~9W~f̝Tq~ev:zy_H眑詧%7v,K'k%a`h_㵟6KU/,sގ|pOǼE)%ŋFWn[yg&OWquT Ɏ$Q߆fF`׺"}OGǢ|0 d ߰D,39rσ%_{ D."%gzopKо7R^C@5%-\~M?F&*}^B%o3͸x*/dU ) ܀1V8_Q߷QziIq|_\CR@ӘBza/? o.ׄ/K?9SN+zЂe8/] XkID=Ї/]mnOOtqO[wӾOT΂Luը$*A{9>=&v >?`G$ړe߉Tbs`|ilE 0?1 /c_zuUul_U/N=rzaLyU&:`y2i: #?2 Gn:oK ܿ|P83ܾc?UquXgl@Yѻ\*h$np )>;t]΋3:-n\\kJJja׎}qf "Z"ƧkNP=NnZ׀6&;6v;![SϰǎmAW'ż4'yj'g?8{XقO D{K)s{+s`6zA>,K h:]e931i!uvO+A!E=QPI|At`2g.{8|va"ә`?_zi?$\z^ŋ*I>PUyV \Q0>T.hsT{`>^< wNy.lFw/Qt>ܰ4귭>Nt%!-hY&G]ƸA{c4.9PkqSΠf( B|!?jeo7nR .v_gvnsҮhϊ?M.3 WLC'ik++F6%.q(Z 莟Kݧ^=#OP!< KS_i F9+ZS}mٮGA@QgˍUׁ$>O20J tN(tluwN;NC|W\Gy M{4~">ؿ* ?8"ƼtHeU'8ٳYToQz!~@w= ;=W ګ{xfJ>;v<6:=p,~S[i|i Z7t #bRP~Fڇ(94!+Uk+؜3}:?/=:#?0]Ly3`\j);>Wp}0fOQzpҾa^wg:7b 86=7!q%ϑ.(GH?`95嵼ߌq:mz~7Oȃf 7vpt'?sW7Ǐ{H!(m͒W'xyŶhz0l(2Th-WP~KEm}{o |\ ƨES1t~p;Huf~ȪCV_,΋̅/V7nXm; ] ~C_M鸃9ch߼ul?gvZ]oĒmfR?|곦փQCi}A8um'vw\';5a?P߃+CݭGFF$9כֶ36{p\7u+QoQ.Ɠ?u>(?`_G =s {ڏz7mUnk~KgǴݾBy3G߃]_?7u^N{ie0vF{]dzϻ?ߵn?(wO7oj  N/ _uޒp>C^NؙQvۻ$N%Oi';#9K}[퍞ݱ~erW@̭z+{uxoNt7A?D_?o`2dev릏?L}uCֻAQP_$SgG Y#^?j]_yGݯ9AG5poHFEYThCuYO#?)kiǭm-:MXߟ)'W#O0-~ô-#u#|r N)7 :âF5z+_I{+Yֱ9cl#U;>'~;u44̜+i˸ I+Y8YcNX}[}[|xqR[wr%ħD._W*ԂNA%/J)o7bS*Y0,x+e`|%F\(&?;&1=*ȾG>C\׸ ^@~7֡ȏ.ݍߐio<\[:uQW1oGk.r<9IM6U!W%眲SHםa2\c/p㟩/D=V˞tzY _\ȼvlӧwIG%UۊcC蜌WkAc'P.ZtN <4y$ҽu )?]g3>@B|qħIg{_}ɘ](F/pkuA:/X_B5NMc`o g+kfHq>ZП  bE^id1BʯwhpCz>˖R}i~ 5oU,_|t͎ZoXs673#klN s"v5y#5U kBEt _v3}FϮY~.)>\hrP >4aF]0攳#(~j?Yxd[bڂK+п/؃wcN'id{vqg>ωȟDI0lJޚ35fvPN3cCW;Nw؊Α6./2P\77?To* WgG_.]Qƀ Yj[?z~P rϚq`9KQK}MRL[Zo XsnPD͢xX04D gZ%D*x?KMrXw[ϰxDے]3"OE6\W}Mdvbxp }Y݆[5 Z`X=D]MIP"w GeyP& o|h.Fj1FwS}^k|ݪ<F̿ky&"x@YKČڻU}/p̏u1vq':h5y},0u$8/Aϋim'Ml ;\?/w.2_n*ڿ"%y1>9#Njc.Ob>8QſOXӋ%J_XPN//߳u8e`:Gh)zy.cWL|ۈVʁ7HS$ǯ4 ' [T]Sf/`.8M}`ʨd'(\>bq\-~>y76gVhťSO>|Xot~{P:_~p\O0os|g+Ώ)ya]`Q܌Cm]TJEoV=yZ_iV_3tC2V4v\=WI 3)?Ζz+ͩGi 2PYfIM·О -ڎ>6}[Ey(DTKBϞn n?8VWgVyh˰`wIG<x]jE`!]aiuy2fŏO]ouT@rT8mG/طeuuc](n{m?UkܺuD}ǯF4,괹f&Ɗp^7+?~/4D?,7ܵk;{o=>%ӈm/+ 흻+%k9e?Ϲw5a8>˺<} R}qڕ,.4z%]ڠجuRʩFWO _yh?Z;^.)(?2ki]?3lunehO}%cd4w,CaXGzZ569?vR~]lP{f |=W6i AfܛeoCZkq|?#(,EOP.%fo1k ffqS"*&P&(ߣ -0J<94\$|3wo/I}\jz%`kA9X_,vR\YdsFP֓/6,@ RC.Aʮ% ѡ -}IVC= ?PEQ|hnst 8me ezj<|9uj=\ =?`E|<^92ыQ=D<`jԥ!l\?> yhN/zWs.8❃PwapqI i߮[ n۽x:}Weߧ`o22 D7yM;pcfSF y 7 .hOg\/A|{z N’mc^go Ӑwd;';(b,Y(eӾj43U|%m?p~U5'$ړތM78~UAA׎Nĺ_v9;Muд7fypBfs/Dެ9{+~F\m*PNZq)|&F|gy>GPj8⨶dh̼fp㋥W_wU9A|N]h~,?nH$ $OF\wȦ{h&i~Qҡ['gVT=4qyjwAj|-T-A8%퀛KY^8gvQ]D}?b/cq&]ifO/]ytjՋ^K/Zz!0e8]n/ØsΫAI XIT_쟦Ot$ ŊNAX Mt_WgJ=1:`Nrv=yHya+7I_ Ήq=Mt޺em_66jUsB>"t6f /R.塧9q5KP9{~hmf ¢n0nOp(S#޴| ]9+ ;ߒC>U tN¤#o| q^nKƲuC6VҐmp}7q= 6@t8\O7G:k'M܂Z>770Ҷ~;gYw`o{?w!̣鷝^=]s|7 =c1?sYE>{X1 $SK𹳿F&%;xa&7:lę /Wp=l %pv]D9k,84fO\OE &M>lwkfKn+[T&9l fXr D#V MCǺMX]g_,XSOB}Ιyc>p1*-F}Y}|w`꯼Dw]ѱ [̙71_yrn{'lQrG_:c禲w^oNg$ WVdeAĶ|tL˖? Fb~pU:Ko'&^G~9>YښfD0vn ڭGч)!?^qhy?p| vsER*0^1 j;mG)vߣzjoidd+5(cAQZ`u7=%GW&ziL^5{s.m@?Rm%+(>k]@^:sE}߷Iu( l?ښ&G?-gu{Ֆ(OǛ:~;sAh^Dyʎu-^=Q=: ݆rR䎵p04R~ur~usX&cgMu34tO< :+ wND7x?`(_Qu=vŦoO1sNd81G7TW^@S֕(tUzH7ڧ]7Ԭؙ?Ce⟲5Oh:Hc!4gu#1Y>l&SEpDmԀX&Q]⇆ͺ4۽߿I|;)zy_T0S$YgQ#{^T6.yсBrGO!'a2Q w/?>@9vyCr-SPOugQ݁ kAg§n/bC7?+Uh_"?Rv~S^l_7.e {uFqp. Ys_+#3=r #ܽO7cI3'/fӀs^o)^)ȏձ3L 7>ut>_{Ŀ/ޡ}) h}/w,)@\v R~BG9RHR[ Gm c2Vk_ k? kKnEw.ㇹ(?}]B8[Uz@w&ts#ٯ~j/z|8%GA7=yP{cJzuĄ*8yC/\weָ8Zl'A(/gI[_?ivn: ]tT?8͹s!E;4tY-#~%`|a:SO\Q`pv#-H8NnB5μ2vrC}{xa~gy#< ,8ނw҉IOWu(; Qju?|I)aܯwr8M7G[[7Rޖ'*sM>M ?1 GH8a#%H^>|eL6kNWݴY˰Bm|v8b2!ߓ< yŽy @ecGfUa8~|:'Ofi_ +;{UNٳRgfn5~-Wsl/'Md`7a'[Myx0ϗ{k|'W=YoG*/ۻ$ުк)syUڿwL+bΖp8%k_{^j?C3yofKq3Y]VAJKQð]S|:2k B=/)BUz3;| Kb"rkO!+n͡W“[@g; s4O|떶 BU6,PdꥡόPc~g0,߻Ly9{8w Y `{v<=e+ɡzտ97Px]aⵠ #Ot̓O^I(o|O3qTs坁9w[Xע5J*_V+7]2:i ~v4S}Kv.Ǜ='np~E[4ŊA⣸r!2f~FK^(WE3k1"%_ c\ }ڍ(;3\j@yj>I?h^!?kCPϷ:s=Gymb9Ce oL~3x6&k=~9X~Oȥ>)ދ ;ߊsy,̨ F\V0U6U03p.DqDo? hO»ڣ+'? ?c?co77׵tё|f?;U?WK/LMz/8]L⼿" -wˣv}\՞hyq;LGGo~YN^Yq8 NWyI(wݛiϯ(Ν`ӳ>X 穹A0U MQ_ ط[vn~|00 ٚ ŭMo(*܃y/ͿPO q}eqj3{`\rr'DWCOc&/~ҧQ8;Z-&|W;'qr]u"͆d:P?߾r qie)kڅ 9lt ?6v(9~C3#KYA<؅nqo+<8?\B >v2|f̶Mr`)dvgU7q.Yԟ~z>Q]$E/֋0 ~I;}Et[ߣ\\6DEmE}KP~5nzFrh/L{4gItG4GskQn7bҹ3+?d+r׀W_1WiB~ 8ڣ8Kp.O8};3`KPoV}N瘤UW8玈z]3s_?9zl)aW7t^H|b.H0[_|?w*g_kkTKv0xag]6T@7?f3kNe 6t?AI1غA܂19qM>FJu wt? 'a`j;G^`ok wHP~wtถ=[h_s߶7`^1˱u e}-q[g= !.,v:ߩ-)7fHvABWqYoL~ 4&ǧdxo`m0{k>`8$#g p,/p}UI^\U/b绕FP]=.|1IM($$|5TaPvf~l7qL5ɕ1[R:~oKk)Tc<QdUV(? *AP;Ǯ7Ϊ8n"V5roTy`>jL' fL_4_ ~;{i_v ˣN A y sׯjgciH0{:-ڙNr,Gbs ?ޒ]OLO\GvKq`;*q6'n޽vvN!>ed`Iq8yyd)Zn {0ڕ[uta[ЉeXhfd{gQͻ߳Оu> %OE]9+6uv7XDvUʞċnP~  hh|Mt>W}s~h.sCK?q旧p;_ϯc@_:=>Zpc_`-I_32! X6P/XaZqnW#SJE'ۘgB[]*66>⏱OٴN'k~1n[xɤKo-ֻ .Ų15Լ.<9tN`J9;_0||f堋 >1+ꗯVA`xż4/>_ԧ=8(AʼZK:.uߕS[p٪6qAg~0nS>.]:Ul9AX/Oм}T3Bq^ ?zo Nӭ񹲆715ת/=t׹|+|hZY >/qoOsw&䒃7o+nv8rY/|ZF ؠwCVQ}csPlQ3Z#h](~9\HzP)p]]䗦ZPq& :xMyW&d{h=vvSz@;dZfS_7{8GE^^x6N!/pILՎ [Vpݤ8\1GLOxynVQlx9׈qﵡ6Q[%❬>}$q=lkE}W{TW RJJ<7?D zk)ğ?)"+8N:`D$`! ('=J]Rն&녷qAP^'{C-{RܲEuX6+W0>c%_4`+ ,Zf3wj+`\-5C},לRV }^&\,~o_?,Ǩzד#Jt-yn//翵uV< aJ:3_On <|ꍸB`o ~7ǵ?'6E~p>PWY^Jt6Ÿ~GMşF3'aG U>IkW;_)Zx!nzn ṯt3t$fe`ү x>{coP-GBq؄㔻}Ky6#րC*K̜:܉zb L k|UڷQ#V˝P1}cOT:l\m2 BM]y-{?.kp}?o|2ņ%knW#>QvyN"Hb;itC񫁱/ʗ7.&z٫ zti 8c} -qQL/:ժ5JKW}>~@*q__[Lw-Kq#{V5BauWTm ,Qkىm>e>ٌj^Vmt>&o;VG'R\ZNkcw(Wgu.MN]jG_bVSkEP;"h ~q+o$U ?6<xES]qu==d%=ǧU풿Jnje]R_MX-ɿD)?<?7U56n8?Ә3pxZ7qJ@d1NC o`|xik|?𖿐?WvuF>@8&.._)>lp;kIÐXs yV]Zym-|fEvIb/`LGguA0q &nug7wgo{Mw\_K\ڇ ו+ǔ"Nڝw2UA\s)}(d?n;!M po(~`9_CiSPA(i 6*p +-޹C} 'R\U}Se^{5!9tޙ>>aE=| 8Cͧ5!/Yzd#OB(ϟ,ݘz5۸ڟO!;nu߱*? =QX 5+'d^/:<Ɵ\O/qN`5߫3wW"tcmDOrۏ~K7S L 99տoFf}rt>:hJ9sS|dH2TF+>6w@Fş^WW NFك¼˔0kD=X َr䏪s[~2o2DNBtW$=7;_؞W Ĕl?prƱy(x;7RT}rP.Q&8׆֯_r_)S[cz~S+NlkO;-*zSKŸѫ*(?mU+XǼ))`[>˱h?:~L9]EoEUl\f{5{:8;L]kKӦ6҉Y Lmo⷟?pm+MIVpḀ;>%^?l ⛪#{v+ яSʾҾkf5fR ,ް8kGNMO}ܧi)o7F&;Dvw+ٍ3Xo1Ar_ڟlQx?u uI(n7h6"Λ,x1z m@˰a(-"~޵F ?Ku8?mԚguKlx&̳q}|  {WӎדJ>0y )"њ=}?K~k_KNza3#Ú!S:?OArji uC>LXo 3:-|gݱq04t1?~9S]3 |Ɓ9%{( ^ UY,D?SItxWUn>|}r't殀憐~U;Hvۧ!~\+B>b| Q$_bSP›AM3ut;> H IɶQ(pٯOr'gTuz>6}P4f-s۲y}uszgӥ-wtwMO_r<ƅnJVA.@3v`Ø 9_`c䔍sD5Kw$SO~``?C LE{&](YTGH^|LV v(7э|7EcxD5{Qun0̎K!>qi>64!jшz1n6|^v9FkOw.ګɫQn?}0?PՆ8}}Ez^1˰>s+;gףpe7ʳS6ۃSBceǁC˥9IqsY~pZǚvef?uw!=o4ξepDI}_}_Y6p,1?@6΍B :;/0-Dvov,MOL <.'6Աm`؎K`,F~ 4|$? 3P>dU L:+zŅᔟ(Oػ- G\c6CO;tďß#|]=ՀH ic ׁaW*ŶW}] ۽SDEnGu\e9%\fg{f%Wb R~ď⓾OT)y`ߧ]7O )yTNb3o`MI[8}B} ;,ř<71ǣSX{]祸Kf>lFүHLc.,Bh'Mh"\v3s +c4?i%D[>>}vcS|Ɗ[7Of,'ùkz&yeu}YZHm|;~ODmޫ-J!.OsnӰuL @/'ӺTCy_V߰6*{6_g٢Q7v5n=UOEWE :]a~=ᗲݫDR,4k~G{ѿi eQM6O$TSoy~U~`X0n $蕈3}ջר-* @l{܊[w:#+Yͼi97wU{Cy_ջ\a)ߺ@n`7d⯚5ȯ~մOg[M #vFs|2Q?|pDOͻQ Z}RmԤAmgɆ>pe*ҿ'? oJ{GunR~?/hmJMW-Crkڃ9{GYoc_2u"UmJWުeX~hWcᙸƷT6^ Nt'gQ>JwY#⃪>ڌR%}ހ% :bm>{=[nP`t ?'Ӿ囗J?N(VTOeHom?M5~+0ή8sv#3D]/O?jc8tr6UIDc哀XQx[_<5iKA2«KP59Iq֗@o*A7_->ׅySOrT?e8/e؀'v@Z2C6ڑv䙯N9t/HN+dTwM!ߓ "\z c-$l$Fٳ[],D|6oY'7P~'W"~)V@;Q:.mDh3{+%9y%\#!nC׶ ꡦn@xdljO!iveɰwǶyRֻ*K̻m۟ˋD/m ETob<\ĝSA|. Q 7&*m]1|'z]ˮBTnĺv37h++>+ko;؈|}WF~.٦:QT2YCka]-/yH@?)XKV"0_J Uʃލ=R۽ߧS98}8ChEu+=l/#3ľ(o}dUK Wj~zɦL[ΛgQ?^rcEߘnڭt,L柖]5l옋{05.!c)(Z[p\s+q{ߟ|Nt>ˮ?t愜-?#ˮKrD=Pն\`R m-En\;>U33Fa~EM@q3>i/$"zU%#kM"=:eGs@4|,+ u28ls~gMq>W/'S"| 3G L+]IBW9<*surN+Yį7]| 6 }w0LˆwWw~IY;z"]ar}ĢY Bq7ϰ{3QE|=}^m}2P1dXw~ mzT~}Ap[xK~}N@g_a`k>9Eu ?&߲?ش}؟3u {*ֿ3DGOm?6oM)OLx,mT t4c&dL)T]jov g&[uX@>VcC70lNi#нZj- y'ש5W(;hHط_ _9%q8~}ǩP>#!;c]mdQ<%ԗB4}Ϣ@8⇜X|-U= J||s;_]VjG!֠*+kW)=!N( N ylgZb{%=krHF<3@i.2ד} /:*gC TXJ_e{m{d]m9O yWP~pVuhP Wr ի7V7m*Q0>{և7h֌=A]!z)`H:N<)-GW1gHn> ğg(NJ*1#nƈ. y,8g8Ժm ݕӋ֜7xdqaAop28#gL<9/= WU\k6xr(ּ ُbW:qt'j ,7"1.y>L͙A#_v%s~7A~y $gVMc{܍@2~`f3F1zḿ9е8*.n;un͒E:zm 4#«U^DG`B{Cf3_iA 8~;EؙKh.Þn=QoeM3ңz!-f̍)o,TA Nyhz'Kt,sT[¥sAL3[[;ߓj7n4׽F}M=9>u$zhj `EO|/go,)Y`bY!(S7i3`pwN-G?\%׀yqeuN?lIҍׁ݀|Fwe_dS )}l,>B)ʌC2ğ;'CA3t_z3{\c< N0[_n{Я*?nES 1,c387$U6(կ: [CVh}J V{0_zk8SĈsi0xdSm-l` ͽ}&a?3ϩ]/Ȁ}%>Od܋N Lp5_p#v)Y&yGu_wۏn=x [[r΀{|9\7q8^.u5 O7~eRy*(\)jumw8uN.yuk- ¸-osC^f}"WG!ڻM%LC}ÖoJ?~tNAJP_ՃZBi@^—/vk'1^nR~C'ͭ(~'ho[}~9ݭ_Zjэ+')$+G|tțK#{~-,۬q|ш[Yk1~Q >i~\?:WQTWO]pqB[람l#c| pf I;d,qL<wu_pڑ??-T?G v)3¥.qztU1 ~xE({]Kz)Ps_']3% ؍T[Ӣt.*m_ %yۯLKGy{7|ܤWj1S3.Q?O 8Gwŏh_BkMه 7m ڽTp9ŭSswkt>ڷVr-t6].ا.6'?VZ h|O@.L}#9]7ۣī[7xDs> qhY_ `wKQ~e<Ìw ϻE?pTYPM_&5^ о-G\QDV'xpeǕ+* ſ =-l$zWH/Hdq nyئOSkE.`Ze~6N=}&wE_wﺽ-ˁ}E|HE;ړxkߞ5Ov8w~7ftRݴ考E pjaB9)lNhuO;`E/v_ gL" -'/O}{N)֗ZI7&{8y#gie|7Xߘ t5ѷ9^dc6.]^x2DVNji+7ڿ=#]~Toߦ;!7曣}y <.q !?H#Gm--ڲG,Tc3)wKk yw~A5gi5>_}g_,As4>ӝf(m?'lgOU=6xEhZ?K<ꕢ0%G1+n8="3r".ɯq n&;^i;7G.(--6>wB;VEFNΊwv&O)y8(qYI(:j\r+P?&'`t(ע^rϚ^hWP|{z;Q {/p<w -[iaxkS6M,#8;?^vf\>Zn;Qfؾq}' >כ}*B+(/P~ 9PſmGG5{:;:xa.Tؘ%YXwrw6?LJBK89i|=0vԻa6`ZeuRǧ_{*ඍ^Bg1C~bjzs $oޡ}z$|z--Ӂ-c[Q{&.>뷭ܿYn q܎=PVƲU1H]>S}ӣ/XZC;19y&۰F.e'kh(qǀ74. 5'c + vk] 9 7_*wsL9ݷqwcwAr[<YQsў8KiX\Tmz*'EuXo_?X~?&r16ׇ+M-F6~z`u[OXGjawqmh/8&B?Mgk ^9;]hzӍo;f S=k׵Ѩ{sJx7F?JڷTˢ] 2?*~5qhz!]~0B:^3S>+r>S~j#:q}[2)lZ8m{X#}Qߴx;jO23ߨT?* غ#[}7v SѺINu?np{.R]oez yAW>: :}HxBg UzC]6zĄ`0 3_l L얝}~]pQ'Vuco[< Y]Q-A}VL͞,i [޺s:pɹŁ[ܷ@;S-0da`qY;ut.O^4G>A~jq?W3JIjLr)xKoك}B^ 9Py *6ߖso8~9$o}mf;-{r0՗sJ ߎPؾmvcS&#H~ D~/su3*i|b%өQvmh ߼p*kϳ,GܖǛSRv{`|ZC Oa㖝M{귛zv= htm`7(=Z|ϓjpecڱf(_ëRM;n_A?o ` _$u6ڞIiMϮhl![zOTBvnZ hwkB1=ӗhZqd'=\LyN$G¦#@:3⋻pR:$ *C8?1ۂyzE.{{,]8tmFo݀G׷}9~14Ax%iM}Oi~/- 4μ SVͶ>7ɶi0O7'cɓeӸ nm[1Mo!P p`+QCfAbdT^_3NiݥEz`[ɨ?+O+O2*2k7}7g?P_>Z: )zo`Ov/Ǿy0[|BW1/ō#Q,ݫSx~ 6.:h1;"n"O.v3!Nȍ|=<=p@?}ڏ݊9q,ouw gܵcS*x#OUwр|H_ աH-w8Ǎ凳؆uhg #|1>`td 'DkW^_68C|UѾ!EPO'']xi$m6_Q8`aR1G,qB;^7c Ϋ> KK78ƼjT{vᦩ Kw_$A_ؓ#3Qx~h:uFᬞżCA9sqoowWe-M76\+FKsÁ/k]v IHDbjxٱ A/j#D\ў5{/⛵cLؑQK?+=(i8&^Wy{;;ɑȻHVߤ9y`L\LlCύvq.҆ڵ?o.ɚGbѾw݈~d,`_߬Nm*~]?o~O'Y7 @.؄&_qIN靂`_׃zA@cyՏQEI;_֏ƥ}3]&s*;)hTXT_vKAKVM7.u~BOيcg= >MY7oa~,oEC\@z'R>r"C}߲^c9OR捛s\!9RzKy%/[b;X/|I+#0;y.}1?<:rx]< V7SFVm=۴ ĵJ:}S6GicG=p̂92\yx'g.YU5~hfƖkY$_3;?_A|VL9}oN^>F{O)AO,)ov'|+(=dLqǩcKOV>뤬zyQ ȷFrRλ>@Slגm |y %rׁ3O(J2 ))` 9v$cI?)3::y1W?g&xWY׾St ,l&yBPETϕGW#rHBEóOKن~Ke2~ .N;pʢ-Hr~NL/|ǚbfx}˽(]3SoxNOy~㷅?G`Ʒ؋qk:r-N MJ)Q$l~Rb|N~ޛ~mwҮR1RdtCgR~f2Yox#˻@՗6mQ>-P@|~h qTw nf}{*8)O=3CۖC}gy7eh_O}!~sJ঻7$0?BumNs+.ʇijpp🜂/=WP3*'ilt`\yނMS$?lZ\m]#%&G_| =zaOOɬq w4?T.8I~c27w(fۘ!P|/=t>ocgڷxT>SC{dN(Cb.AtTI~_; ߣv-_pw믑P.?^j/BR#II&r'XF NoF߼?̃ߨ_zm}|iZ?W7IǾAC|ic4${̃b6 [P43'@p'՟| , uAB3obۡ~%Ӿ6:on+`PGՒh7rt^ҫ}-N OKz8 2lh`% }@$I=̾?(h߱S.M}^_'O)h1G)tOyv{{O~1m"pAю뉿k~~'4G_c|羗poR_>C1b,0t8D2^C=ouD{Ru=RkQ#c ],ﶗ_wjD6yqW\GO0i ?뾍Nܯ? ~^I7KC/R|uV?M8.lU$]JN ^ngι|'0MY0V|Wo<ء4ANK ^+WGu!'dXp: ǩ~6 eѿ{h=y?9>ݫ`FiF-ה!GӮ/'AjγF4\/biO\'@p K.-Y1~}8X;բ'mngلط$o^t66t,;/ǥ/qC[A|,GI|S.Wީ$ p^,?C֏oKnzvC2ہ8#Ɠ*5gj3ipk*>G8탡WAbRtm8ˋǸ>WV_4.D}íy`WrUb /溌D~lزf^{.-Ԝ_s{/oov軭B͜_fkl#߁waMz{ڟԪN_N )}s⏁Z:gNI/?|r[O<wfbO`H){IӠk]!ʁC'׶C[?K'_ZҚx{MX*&ǣ7w^kGIMW6H|k^H(BP}~r`Ώ`_rXLxd[ް5Ϲ+yv>Aഎ(/cg'l{_qAe3x+ ]3Z2K^al@F/Lݷ.C橴 AE/=r~Iog{ _|K F=Xe˾G=s#hIs9/9s rOP~UդgeoW;kk(fJ%俥O< O.%~A{/ek?ߨ>uw؛>mg3%ޡa[q}힢14{EMFqӊ~ Vh2ۧmg#~TXfe^zh p`l5J9= ź͵zi?0>' ?;Go&䷆Lg#,_;ijL(_]A5ow`}`x# xxl؛TmQYV0}Ʒ-*8#p:];!ܓ9'?g_& 3M:l_G8w"K܈vl]g->tA5qdW.<v{Km^Q}Ϳo==DQ=5ׁz\m.{gyZmZx_K#bsqp\#8g"i^$4%>$vnghO`[~K҃]jԳ9@|'ٽ ߯jQ܀SH@t? % =?ſ['F9kK\ETw CWzcd3/^Z)|0>>}?#[q7~_"5RvK~T4TE-a 7wF\?7Z{!^ϸ0yl_70PSϒ\ F_sfKlյXaQ?ec>mw^} bѿ*U[&`C Q/u# \BV+ L# Nʂ~҃vOng\iʪ7Pݮ 7~Oz,ẈONk3|~HӍs cށ(>}ꊟuyٗ '*OgXoz,QyWFB:Ikw߭-ycf,蟋՞}~hrvZAŗ7q~^XZ~AcCAiU͂c-ˁsJ6U{Т#ī$-8Oۂz>,_h;|áx&/g§5pjC_ ">]5;kS}Ơ/s_2ߚ>o>t/ xc6T߿yn)=c d`pP"t9Y0Ҥ7š: hEo uEdmVPp5@$ 8?@<ybB/^(Ք]T< *=5Ы~|ldt4gd.CPr> >b%nPTx\ӝ{󸕊 ) PI4D$*ȐA*T44*Cڟ]{X~㜽s=k=yrCH>NOM_v2"iͲ,!s_}ڳ~g?1w̳?I޸ pv)1'%[HKܩ:ÂZygEccH_e] :O⾟$];Hk~!EڮAߛ<\yw^xE:d׍} >O\u|o5!O_]0^y"D߆ֆc{=X厏ElRAx^H|}.y3RlŜ?E9QW/5>ϡK9!s̼)ˆw/6Y?hJߺUE7 +痬=-'/D6>ЕeCM,~cnueqEm疂gnA}!R. 7o>ˮs*<]\EB^,{9߂^QwqOE:"x~{3?6p_l%KIR_~=i/sOV˫OAe}9Վ)ߟm svM]o|`É%#uty_ˊZm.G\$jjU.REn|J~>}77on 4NAxӇ7,⺯k+1%}re}|kꊌ;j]4Ϯ-(gv7w? WKGϹ/ֻ9pw9@vzkt3 2A1|ίE̾Vd]3kivıPך^K>w/ܟ忟;UX}m&?YQ_cKwұ+>ZβA}Y7^Dꪛ快h7rw=\qr~?.;Oٱ(%O迟'/6EO~~a.GDӋ_M׉j{K0Bw Sxra\׏ ;~|s1$ֶl3f'u~}kн9UA~geo6W~&N~7?ovwѰc٢U\ ykh|yG7$1!YRuqϮq >or)_Sfܽ`HyqS糬{w7(2}7G,ɼ ߟ"П)MY}>|A&+t;?!'t5w|=A]ev٣/a.P3~Gޟ.$f"/g\/cO-P.ws1Dvo{7;_3ӕE 2OOhH0=ŌAs9[_ٵ~C/^*KVU_Orw \Oݘ]Ù{7~ؚo靫]l JX#t6O&Δ1ū_ӼpzWI)ԝ2|fϺA \WD|T[STxW"/@vx{V>E3o|B_+҂fpA7]^ VMy͟V]􂨗|{?WZ>p|? ۫/RCAÁY[Y$ |S_M_w1ӯ֟4bG_E3y{ q#_|!WUϓ%3O2oyUQ+#f]?KJ~7t~<9,;ߒc{{_.j>u!jj}(Ʊ=MayWWJZ|ߙ;}傒Jr<^;EjE8w#VIYS,X-bg)}[>W/8m砇MKޗTU)e[p794KYWicWa!xzm焾^|^HY֑_p[jSdd^!pھ%m.LxGaSq|.:kPo,\;mNmQ+~ו5~||rǟ3r]/o瑌݅iP7jUrS>u瞜GA> ?qDj0n (El=sxhX؏gMV_ު#gLY'Ҡ+| /̓Y-6~\~?]#p(i/G_?B 4x=Gc\ص˥I[#{Gj)"bPFypsĎGq#jVx}BM8~)YlRD?Y&1*I&K.1gDwIzk'蕣-+\$&ߕ% 2~ϟ^~WQ&7C]Dŗ_ Dl4Joמmg%4+HyÊ~{o9"u&gG*?嵎"% +mԩbܵE)U5⦾P?︺57O~q/v :]L"ϟX{/;,n^OR*\90e>|j~D9JpaEgҤ; R4.=Jp\YPEu?ͷE_}ɨx-v̽/%Oz.﬚8N{t0ĦP'Y}1$gcdku9_ IF=Ğ~\ uW0<oH>RݶV8_Ø"}Idn/6ۗn|zetwDQIRN}D~貊տXrЋ.y]=/!v>^*V_x S/_/,H wJuz#g߁$?pE^Ϸc~rcN]oF/kW}AΙvZQyQǟ_ ~+J\}Aak߁<Ǜ4NCD>|RCjOxTrܟY;Y7WWKMzfH>˧2/˝võ^ ? z=}I{u)-;hA9m&eyaŎK>)Sk/{(XjtAONK?qm+)J?1.?,/?O+; eRM=X_\$ J/ܴ29>JSE~iU7 a3k؆٫>((^CЃ~~O~"v7fSbe/ߒu+ o| _/" _yҏEu~B 3W{f6G֬H#rAF?+켬cuKSc2?عs}c󌈙:eԏI%~N5*}L}Ou Yw!Q_[bߐ?-Jm|>~Y/sI?{|zxŧ'Kz+}.H\okQ}x/PWKЏE?Rݢ7_ n~ģo*8u"EpJ{"/q`<]+_+n` <>j}FP;<1S$)M!å>$ 17|n7&A/"~ϏPwA[hZW$ںXG^]|ףSVVH~8ץ:k_sT^#O=D4TJxNλyK7t,^zؿؚ _{PGs'h"WA_į8g}|Zz=RԜnXOȏo̫_#:_e2%{ѻI#ѠFB臸'N' YZ0i"ztp=_bG%DO/ϼ`5?W\֥%2N }}gsw-R^=[=Cԗ*ټc/.~sf ~ qF=>BKn V%eQS:oꙿ6}פv}yL IQ5;~n:}[t "jg|xlPk."'eRdR=9;c}mj[(QM5O:t>efڿ̿B]%uxL.lmܐoH72M9kHO~xb#+Dx>{ )[_'?rxN(~ڋDϊعw͆L;{UDϦ́AA/yzO'D;ߕzCso{砂3W4A~Cw]@o?)z9b{m{>)GseYb>৬/p?cGC"K*@^ ˋ[߾%mDԷ#6@*I]_мӶ~V*Ҿ9ɴ_-۸ FS!ќsC?>G*^@HWa=^عE~v⼅=c&go;?Х[1W~ r~`g?>vV\ƿ.9 ~s NjV]]w\?N]R,+6nXjkϠwkDÊONTy/? d|^-2گ $'O+725=1ou&Jt-sRa짻{A{"&ݼu}/ߒyU~Ec/q;T?GߺH|V <"Ἁ _\l& >dL!(|9>blj_shSP7Y뮙)ov})W;eX{ +ͅ{Ģ'q6>[ONr^N^jDQ{H)7΋"~'/.=GToU ϝF/pK|;cE`} 쵯>OH .jNi-|`䫑'>_7c9|Xs837_Ts4.xz;Z\{xx>H 7o>&]E7&z]Y=}o־iH[5=n&A}7fQs ˠ>cvϏ-Wx{7|N4K|xN(N{?dCӆC>ug>]q#Gv?ݻE~@D'S6BU? *MDͻ9t3k8t_:'"]Pƀ^L;W/7 x??vo\*+zQ?}mg17J69>ł n,[nTD׬sPE}'gPԾ2סE@>xYлBox~,_yo}>wZ׭C3zRֿ>;#{}gH7;ٿOC7yj7sγ-v@yG#rŹ~[qgO?˻BɈ`yv_]$-q7(}b菒+$>H]_k|9oʝo-ԗxkI҅=~BZ/mчo(νaDRΗȿS.鯴N$#}FRt$gft蓼Y{wH<2qޔITXQw"~Z7zr*{īC~K{CK{W}1s̽jHmEw_}ktvB xnϹհϥOeֹ"+{פ"u{^Gc'i%+fkIp̾uח' Qw}`A~zXzG}v)N@fxscVJzꑛIz{R]o[k|n<>k;cQ;/}2ƽm^xNvDJ_=ntW߭.pP?髖>mmZ*o}*EaE }糘q\u3`pJ9[J&*^m>TX{y9uxУĿv΁zAA?;?D;RhB> Ds"O7{UAK["},xniF5 w*KϿ`Hp)eŎ{s_#jf"߿~T~?t_wl\yǞ sA܅ }T?~-"GWBg&>򥇗H4@?: vGW;ηs*|%d7toYR4~/Q"viB_$zws>+T{Zޚ?kѢ;p\w+0 ~x/{=SC6M}&M,'+اŽo2&sh.8M;r_珉[}}?yɝVu-\ ܴ7\֘ Lѯ*9~C5N ;5_$}Ȏˡz~؃~/zlݕ,_VxJ׿ ׯR{˿oz[qD~?Op.~w4/gwrˎ6 =kǖ?>"=孰ߙJ:߷k6_\ޥ"jxnɊ'] _%oF~?tч{KH?}|0ye؇-swf#:>bƿ:AV[;˸۪脨A o|OW/[?[^嵭"acW!p{z][$6?5yBe}~].>& uSν91{#S,/W3gO߿o8';=ѷhpۈ1Gח }"V{97g[ީ=v+z{ϳ?+Z7U퓠n25^2xv:EJꘫ3c[9~'w'eA־\-S^?emri=*QNK3+VС?1kO|z7yi@|>-^"Ч{}0M}{I_}wWۈQvu'e}yo>ZxkӇD݅Qߌ]r 6"ͧ~AʟwyW?(dR~>>}vJ|5?zKB^ZݙϗbY]"N!ʤAxYrٰkKYwd.Dߴl<^tdwduuw:~Wo3OK_j[D M>^ޟ]#>h5/nw׋C~z|>͚EEx{kl!R5fPX׼qHؑi>m4VDe4=vګaşEOu6oۛM4bS:.&lsVVOqXsn6XEQe%?KT<G(ҮZ }sBa9S-[]IgQR? x{3. z.(XXq/U9KB Ǣ&{}i "6w7M7%^BbyЯO<亮|x#_b߼W x^(3]EGD΄|owO=)o~Edqd12n3_xgU8485=}/XsgN>EAݦ-xK_/F,<QWCE?7΢UM]ycK-Ћ:iGsu^߶]nA÷2G #]Q{Bn*OY]}\؆m>1]'o5cNWO~.|q˗R_/FzJ/_a?:MQ vU/6OywJll媊nf-{>mt&؟ӯHiWН/,zV=~UԻ?SFl}NX9s]cN,Yy*i#?My}svrY"~f Ok)Ǹ]|qACB/%'jNu^\зzȿs.>Ԛ ^4p;)=Q9Q? pSkq"۞剒K9џM>|˿K]QSE c"ʒT̥5sẁ;jDKz7,*/kuOp秾,h|]Y4+?>*Y E?H}s9sF;W%-kϽqOURRo{Z"1P_)}=*Zqw J5htUEӠe}P޺#˾/R8FfǛԴ9߲{z[̈́ǎ` f4 Qph=7Qo'694_B,uUߞA=&jk@4rݶ6~cnXOdϭ}h7j#%<-Q)2?-bo3{@SCb}Gzazn7~H/\A?3WإKΈwLzH?O9N=,x󮯓z,/w/ /a=F~z^t| ^#nIzB]{K^̄:*viou67$_uϸ+Z|a&;xsY:oHsyz^zߜ\ڽD@bL2Y{W${-JWr^y|RTQcO_Vn5a=%4hGQݕow7S =JD3A_Z47rUvIM"s qSE~ />~o)~B y/o j8#N{s|/Y㏎'%^k05ˍmܭɿ=Ίɧ:n,nԴт"祤Ò7?c{s_r7߃=r> Kn3Ht]sCVS`?V|~WΦלE7yӴ1viWϑy |݉[^zT}1 K>3O~~|!|.iЧiFqpO E/gЩfh% yMqZx?PjYHDzJpɽHj[-Y,h(q5ü]%jy诨%c?j3rQE#[= b a׀Ok=n Caڜρz%"mg@e =kZUxo6݇Օ_,(<WDž}/SVO:GMJy*.|/ˢF#/=1A=.J<QD+z>Qͬ>Y?UϊgxJ}}+o~7TɈ n~pԇF} *v'g-v4K-S&Vٙ[s:mVZ\#̞}lj)w󛬺X37,νGDrUC}D3kKvuAnqD>ԝ..պR"ȡѐۣVsH󗏦X}ʉGg~SV;M~/65W"~ Ӯ_:Bx=+Lu"㝱)t67SL9auǧ[@/^; )xA tnHrm:|ըe5oWv_ #Uߜ8Xi7_.w€c{Ȃ<,!5k#+RxP aQ͏$sZeGjpy)_kvVqÿq_z1krڿ}-CeٗlxH?pjK[ :&_P6-Dy灄'=.4NSg逤)Kv UʔO u6~PԾ^}F*sCqOzh5<t+}mwKB}>(}edbXO+ݳWZu*1<"_~c?s­?\H]|?ѩE:<{HǟMo0ohg1g߯̕)\|r:7m"^+g\us|ɽ_\덕"ay?Pg7RԸ+m1ۻQK+A]}D6C&=D.S{O5>}sSd؟;5>ԡ8d9cFvj/j;xO:?^ѿ\q"ыuz[hܿ DƧ.|aǜ?YVXPQh [+' %O4\)䡛;sF7}/Խ޷)gVU /_ W jy"zs^{I糬?2sV~۴Tޜ^-3L?|͟t5tԝY~nye^K]F~Eܐm֊~7aO{ޝnQnq{ouZz!QO;!qqmMqu3_Dk.V.=z|{G _yI7!N^i ni|TWdwKsO؇ 2~AQKiاߖo*l|Y|N%jF/oԼ4o7~vY/-o.?򅮐^2c|}E}೒~7ݧN_XWNS;svXj%"o@?ŷ|n?!+}Qc@]&:H>w~Kٿ: Js>/5Qjr+G֣>ٙ?}!Kf}gvsh{x)~/S^V}ߞ*GpmQra˾{D~?LJ{rGR*?OܶQg@_j;[~[}7mEt&Я h~9ϚWZm[%+G5wz4_ 䦥S߅6m =oW{>13.'m$k}&?ghg K77a$Љ߯{q["uo뤺s'QyӲ5"nNBˊ~&3P4ʯ3vɿk泟`KMD[@"C~٧E7'[EݖPBfϵSfmS: bo3?޻g=I>d_JVU[m"]à^Rv+}ɞ~t"&jU(yqЏ/˿E&A~1u|]/tUϢVt+G{%/b Ext@Q󢯟}kxVҗ9ӂ*shrÅwomiOEڗ8ׄgaMnq>Kkr秾'9_ܿn"ّ7B$e~ʧy`~_뇀\΄)_|HjBƿ:OcJwg):7O$VZW b6@%V| XGUV@K\`DVM _Q +o旞Ȋ7u1>.]i6˿K;tQ臒~l{9O^,6yR7wP;ߞZ2^(Q ɏ ʒ?s>sNzT$]tFOks^ }3:<򣈯#߾sEd:A>&]t⧍~xλႣ3;M=pHsHs~LUx /$Ԃ^N˚w7/? r:߹/Mΐߺx|~|b#JڋWW[z7;WyOqHoP{4zc0|x.iA$R ٵn y֠g[@~2V}#>%Svh^Q{wI ?>˰y_m*Cj}K;W"Ziiφ@mybDꞕ A3W[Psʵ;0ݶ#?uH8Mw)&g&C~:UjxSE—a_S4:ݰs<? yȨ1{=/kOB^|x.y~~FGƟK]9&3wL  'jiG؇>XS$:i7t'?#ANT7Ԧ_̓R{مQh*uK La :5%Om3E!w W?"ȼU6.߿>TiǏ}{jATt[.?yYx gzZ_.wY󿙔)^>itQ?VlmY?w/ 6;3 x_xOټ}qh n؇tǧzAWE]@y~d-\Gw..4_$}aFǂ_aIŜ)=W, kjzvo‹:4~zon{O'<_g߿.}O-jvGcз˾(?__t;fHطߛn_׺C^d|`+;MSۃ5|[$=}'UsRX{ ϼ:Q}QհAsjsh")s3>qx*Z~כ9bCoQ۶׻6.}mh߂O4bHN?83+ߗlL}9+wCg3v-U=~ 9\_\{}M;%.~B_ C'IIѠ翯)9_1$?8XxvP/ _.$~9XW܅W6%+~V"˭k1[>E~6)q.iJNoNh XPZ5Dם7`AEG~ӟ&Q5U{R=|^YM ?l7|<>p|3o{|~OXj|W7?8POiuQtKFuϔ(xϩR>3Hԯu@{N:In7A+?mz}P5#;هfS~Β˿n~(Ck*[̻#[GܳfeƟU{9ԡyO.xMĴtpt5$ὥ5O-ߺ"u@Ϗ;?dMW񿯯 vRxnY%ާ?EL̇ྛ͗_i{UPej;1o)|.*xXrG%.ou:{|'gRce}dB}3._=}cA/Լ뿯ڙ]Ҫp*tЉҶ%ZDb͖(>,jSLjz5<_X'[~?ܤK"XA_u{GsIʟO]z&`)egUK _rEU~g>#Gz5t*c8՛ VcCΒ߃̻U8 Ke6 Iϗw\wηv-~쪹ۭrG1"aްɥo= RPᡅRpF:7v'nͷo9 WԬ6M6+ӚϏbQӞH%7n5q9|x~{G(.snzQ\tMB]9)?}ڟ/{-g|gsʿ|zЧ|(^IlWߓO}EMO&w'nQzhOo~^qn^#_|L~нX~eGJc㧠;q^#tF^8V$TQ Q𜓕Z}{G|/&ԄĹPy#l(?/πS~i#ɿ)RꧤN i\ 胨qзY/w-Xy"%6c{Pi piKP$g ܟΆZAyz%~3?7X S7BDjIsԅ .BUl9nh#şTC_ī"g>uA~/{hk?_2'\Ehoޚ}*0W~ ?cc#֊{ y+uu_Jm,W{G 珼^rHrt]/sg0 [<9SԈYu E̪EoC^s{{܏sEU;V-_z6hkA7gT:Z\lwHC+Mv"ĩSGw럓/ 'EYCw]*_^~ϫE^߶ʿ,>Y*u[_:{u .s`lU'˄O#`|FGi˺,Ym'g᭠7jq\Sϴ爘i֎:{JW^Ҭå]q3@] oz^~mp|>9a|UQL=o%O̊jVZ Vh}wH o._j#u ~ز\<%o oE>|_anEK`&]|*~>ؼAު*hV/cE6L)vu.}U}B|P|{?./M:p'A֎7C4n^w+DB~21'gUx(=w 7v5Z$cPvCAG8J"^R_R.O/bw\,< _M>c ?s\x~,XuY{ݘ}@Q?]6A﹋A}_تU;ۈ/sN?*oߎ~{^Rz;Гo׹M"OᾛwA7CwxD+co}e*[^ҡ"~kՠoW|gmy}.m=|+xiuQQM-c ?C$1X~?s/i=d> Kƽw=\]ޞ&;vm3. wՍg7P4`\Oj)??Ϟ.,iQQ嬖.;/~_,|qIÇw~M~>q!L\)_.+/Z49mޫ{ծ"};aڬ!p9p[;5^!?p仵sC Ј6W2p>.R;~&]{#3B{pok~*s| Gs4 z}:ek}ƍ˝S~|Mq]vuy1kk/[ꅻ0y|suwݘ1Ccuu/66~yTlMuO|mܺG.W}pn~_uÔi|q.|N`\U_AW~5/j|c]ǹ?6fߠVӝgO8<]?*wΧu^w]jLbmyZX}͝_ݸ3/[unX<:c\_O?3o}ճ<_~yQsuko[q|µ塚P'[\윊OSf?zFm K/mgk\|V}A+f}{8 [\W~ui동q˷~:bL֯_wk}Wt}՝n|8uUO2͓u]|8}+\\15nAW< k?uk;Oç8zgW/tmI]wo^LQw^GlPWG)?|+.WSqqmG,NPG.wpK߹2_q6|림'[׸mSKQpMP]3[K^>)~Ըp|a0?loUy\yPtq\EK_(g_T=ƷÕGn|T?]_u0 ?zơtDꇙ}>Qfåæ|uL}#uZ׾W蚯8+.]3q)|8~?!bn.|uƩs_Wb׹t=q|gʸ@7(W_q\_ 5|i|_7.?j.7o|/u"?׺yQ0 *\Qf[i\Jtrp뀯6ϕ.8~<ܖ.m?c ֭ۇu׾c'\c}Ry̴߹KmUs 6]-ǔ77iǶn1^u*.nP_Z7ǕG۾ [)\luG͗<_3]i\]\uoW\].j[?) O5|wq?WcfO-?[s'_ƥ+ꪯ#mLMVC}A#ReU'C7[_0sSR\xkm37ƧՇL޵_]r꺮qչ.>gkx晎i|W}5?]8OṮ֟[(Uq\;)/5>OÌ+sk_֓->׍/}s￫֩.vYq|m_[ѽnO58uq,.`uzaW]֗ J}+.vNḞSظxҝϵuٗ.fuv]󈍇w>懊[긫uq+|n~B]׍ǭ7Vm8>Kl͔íc:p_k]Qۖ?wV|_c{]kzνHKS]OSms7T/lsq]^}u_qWo\"e\LqכjkzNg֕/[|tmٶuU?tq]wq ~1 [kC̵~uq1s5ύcT׹ؗ^^w}8Qo[ظ?>dۗԸk|ng.} mq(~yU\:O)NPakW|q}}U_5☎ci(T|5xŃ)W߹Ƶu?ο>fTܠxWm_.uKlꬮ.֑t0 {=|LgPoS\j>c:O5z]-?[l+uc\o\q-,"m}<(~\Fpq[i8󣌫tq#-X<\ͣv5>Gtn\]\S\:ĕW03s]<[|ҍgKGm2O/:f4k<_W]Ruyq+/u30?œgzݖ[ŭCt1_yf:k|x]oy~?6lW[tۮu\)Ol>w#.]yr׵8/S ϵM5߷Ns:6O5jtyQ,.q.jOظz]/6OO"Em 3s[S_Sk_l+>C]}ͳ9{ݦC_:t75GA(T\}6n.r'q\5еH7s\c8m׭kAm| 5|Ձ/?S~ظmLu_ຯ`xA5WP0?ulۧqt16u:3q/} Zt[?q.]q듫SU'}(?l\7.eauqmǹCz^]2a(>Սo'.>Sƭ_gVq@׹;6NSa}8fpu+<*+n|Onql]}WqtWq׋zοl3]x۔) K_mutu7\5>ѕzݔ/euG:3VP8Af S];s{ŷŭ<(?]\̸ϴm3}?]8oSgwjxT|CSuͷRq0[?P]뼰vݘq˖o2W7>J]uw?Q W|[/ظz]w^z/LcשyZaje:3n>}ҽU;8/_w5O_5nG[} x>p..fwQ(^8wqWW͵?0<.|zӽn? J7mc8x|].\][Wub㺼Lq렮։mRAWnty_yعol>_Gs奚iݛL뾻փ~Wn~kOg7_Ӿ`A)O5n? Z(Vơq,>fԴOy Z_\U5[]օ旺Ncq^q`q|/?O𥟾Sf:w}omuqtLqz J?laf凙k޸un'jm֏.OW}Z.sšq5K1<_T,u?].}=׍1ӵ?)wQ)ԸsŃi^s_3n돝S<_z21=wOS~\[_q|wUG|[^8 +X:'|tsnMK\>~Uה֭:{<xfu>Nտ:oT1g<3W}s׍ÝWu\}ǾIw^K7mT|+t]v7C~Quj][W8\zeA/u]._xaK\?xT|wʏ(?`znϥqy_q]z(>uOݸAՏ+i|lyc:ϭX<6ϔ)O: ztSc}]ݿPlcxAU>`ma8]_zC7U\7>5]'+kc8>Cw\w\:mt_Lybw}q0<.Ss϶oL[Wtq]{k_P~q﫿ȕjy1#7?]^z[8RZ_n5W^8~<|!4.g:᚞+[(u|.~P^WW`.[=r9*f\BN8*fuZǾuVet{Cu3ۺuuy_}coA._}b[֏iܠVW8uq73Ztcu]?s?(Pu_}Ql1s/Ls:2__:ƽko>w}^7=w7%zwݚuq0taˇ3;U7փm\Թ.3_эo:Nk\럫}ֵ.uuu=+_w3j)-?:~P3.\!..}stfu*|y|ש5e;utq.>QA.;nŵnP\l/eոՍ֧)>Cr͟immyu]Oc~l]]7[zƵa<(|WۮdUpηw\ti(?S3[7?}ǵ}'|sL]wŷQ58W|}*/ܺ35[|.LtqGi^0^5ouT'lm6o<KO0ع-/ ߴly%_<ӼQ 6zӝU׶G5\yGsq#~v,.ey3S^u4?uϮ23]ʃz2uƅwϕŒ{ta<}wP *uݔה7T5_.?}yjk\ 46Υw\NrEi< _5:q1C՝O}dϭ 깩z1Z?>ukL).?835n=71mƝ[[_g~| wL\뎊UxuyQ`ƭߺM1W\;莻։.W]]{W>UQ-SyU7\84Oc׶)^uœ2ϭ{~Ps_ˏ{M󇙯反ck3orͯGֻ+>6>~Puw\<֯.s/Uww}P0U}O\mq]yQlǩuiW_7O]w\t_Ogn|WA/0~o[?.}5~pupէNS/U\5.uu/Wx(L0|*?66>cc\ 㫋OQ8qlys;e\NQDQ8cʏ{}~rnS|LUt)a8:5+.qϕ6nOR1?zuCqLq} ˵.l3w]-o;wO/ɴ^lutko[uk}\mSlK1W}Nl:Mq+:_+oc_n|V5|RxirPyaq(>\ty8lw]wֵi2Ծ֗mPcyԹΗgt1c~\^j{|Ƨ̶>m;lǽoEwͣ)k19uw|_};+a)? E0|r56~Pdϔ.6΅t߸\lPM7:p0\Ӹ\8HcywT5nW;\ƥfg.׺HU/t0_WOk]/[}8MqmK?q)>~#GZzqlyq5v{lrfqWfAՅ./.\[;nk>,k\:募..7oS Zo'̸y׶qpt\ynjty<׹]GT|rUǶz֏~I*ߪ֏u=|</W޺3U?zhUmKL;R(-ߺ|ֶ0\꺭a]B7._\ζ^(>z?4qn|TмtttqM~pf n\S<>UoqL7h} *~u5;,+uu՟8f\ǵ^u4<|`f;1gul8l,(} ŋ2.\#q[_u[G<`fz]752Gs3. {my`qcϥ˶W) T]y`xܺη}n<[>3_:/ 34]o8fZq1? ׵mV/qՏ:;a;P׺/aƭӾxRLySn/ ׍wltuۚi=rTG 57(}/pA;W]U#Lyb;_q(+W}4)}폙k~q$K׃׼rbq([~֏oԍgʋ]u,>ft\Q~qy8\}tsa<_:.美:;׽έ_V(t{#N\Q׹%\і)?]}4kܺ抏cݗ\cOYPc Εol_<[>ǗUDZs[qS\u)V=c83_:W2z *\yWS?Ň£x׍kV0|gˏ[]?ŏšs.tKGCmz?pu͵(}Ww_cKtQf? KWr kGqGw[7[|̸WWp]L>Q](Gs`?<|Qv1s?]BAn\̏2tq|+/j.ƹ_7) v⃙:3˭T|<(qw_]Kqq%Optmc[)Qu4~iʟ)ԏIqM39W\_Cw tgSݶe>6Onîחsq7>ǖqW0H9RT7|l13]ʏ{\U>a;2ubT1[O1gԑ^w剙mނZnL7\SwkLuyP{UOyxտl'8Cm?RqmWbS~Ƨ]7k:Κ/זgהK+o]\ w}vݵov](z35[>/l.y:c>/^oN]\yq^'X|}O|(ΖGṎs[뾩f[.|]|ʟkc#q[}plO᪟Uj> W`fZ7۸~8Z8q\b]a u]?(=.]aoT]/ʟtrjʏ{}<<R㶼Uö_/nݰ兙n_Q(||cquy./:qvݵީTq:WzŗK1s1:4.*m^-b\}ʋ3(MsYPwWi<[\*r(l05wKnpU|,-m]|y/n?_Oqk|̸uϽ^.}uе?\|uRq.Oj/s/_:gOolk?Qu]qg;ߔǵL[_3}]@.s-?tmk\˽\T3z݇'uԍ[# OiRMlq^F~Q|ߖ+>e\n|Wp+׾})L/V1]/zZ}^|Uƣp\umWc\uV'lyaf[yqkw]sk~Lu-#򲝧ǵAVT7AŔ:kA Ӎϥî|׽|T3G۸hӍϵfG֍))? 1T:_SljA۔'W}cxO|׵zx95/R_kcu)])/]|nV\uMǩs[}pLa}/ݲ]nSW œw=z?q]ƵtqkW| [|ߦKW}uZGqyqitN`ǭ{B]̓2ۺx?]_An\\Սz?f0|ޗq]|׾U⸮Ӷnq[# 4.w;?m6>Rq}+_׽Z/_?8wp݇({\7kP|lUm늚ǥ5w姚k5Ws.[uy׃M]_sb|_lu1/s|-)nXWx\~8\[ÚUwKa~ze4?߶QfzPG5>7O _5uly-?O\Wlߗ껯soor]뾹.q븯%Ϙ5iTӝ]uZs;GQa0fIUmn{}ש-t6(6;gxAvݔo;KLcLυå\O#cws2zNS<߼\y7uε3o?jܖ9feöOMMHKlǹWl]ƽ?gˏQ>u[}..5\bC~/\UOƃύcX:6W~x\|({S\xAw)\\¥/w]p:_ן{/=ͣ./<_zoǷcۮuz0kT?+/7/_ 3k?unsWU?Wݸ֕s1S|j?~pի.) L/|3ϥ;C%.}MypwӾuZ_xGr#far+6n^Sxf?ף-. sÅOk8\n00]?n],u]w\71?_ŭSKA:ϔn_z/|lk]}[]|Osq]uk1>}++>siߵ]uȵ.WM|1zuyQ>z6a+/l>CW;Xm늚oQ75å[H.R}[7j<(/>bf\k}®s[Pk/vNqׇ/qg_aT3Gcx:T?Rs:1/ݸ__zl)ǵ\\e/lV\+OT뀻ma_uyP]3\ystn#ʿ-p֗~?߶NLu3W>..6}q5}7])׸u溏5gS}xֵ-/}_G.}]>xOϹUlqM:_j:˵]]lo7p|;.몧]T<-/*n< G6_]\j.>%.cf{ťsʇ2.u_Œ;Og_\q\yɥ|m։)_ոãpur./ո|ƕG?5}ƣ(|_mzVttLqq]f'n𥋶Z\lt>N.6兙+m_sZ?5O5_}ơ1꺮6_*>rTze|[Luv:5Ue\fͧ΃:p>/eKWt}Ѵ~lCs ŋΥ}ô\zUy]^\\K8tSx/jVL\[~\<}iߨuqk?ʛQ7:O5n}sAi=S1|} ZWª]^<.?uv]qwrťx5Wϕ/siDZpm 3 z'\gW?W}r6ơlMP8q党wqաiWWQ\q1:v4;Ws]v>; WnA%vnn^(?:򥻾v?}nsa?O>0?.t zL+|]<Ӹu;bq|)u)8~pVP}m'l ǭuӴ.|_lq}4Wo]?̸XţaqM|5O׺|kRW]W=j8eqyƥrܵ|>Piߺc/->Wr釯؎c9:><0^u/RJŧce}a)G:㪏.Ƈ[߸7n_qO <)γkZvWP~nqS;lo_S)l\L O]xQ};6N)\0g]\ӸqyU|}uyQ\ya4bƥqՍm~s]Ut͵~+.f1 _׷;lpםi\jn< ԸC754k޹K7:5kuɥS<.pӶ1|wP8q3q.׍:;Pu6A˦7UO5S23k.>}T_0so]y#W|]w}P2|lu 3W=?\<Ŕ5?6W/l\寚i)ʟ+??.]?fT\:|M;o߮;]' W7>ŋe:5O<~q-n|lu5׍owߵ~yԹnp{_5_<_hZw\a mkZ?8ui?cƥD>f+8~͛|S?SqSU? G<_1Holtu.Ň Tg͕lʵ?p *|]_Pfϕeu⃙n<ոA ̸myqtaOn:i]OlZfAוSS\/gwWP}i[?RSx<ʸt4o2ŧpur׹O5zd[\T]|]?K)οax}?Wҝ竏{tq8T\.~+.VL1Lݖ_Pasǡs~֯.?]\q8t6~^x8X\.}׸\}fg;눙֕׍g˗afʛ2uo7uaTӝKttG׹u(RTͫi>(}7(=/·Ug|]}.<_k~T|LM'ϵnuݵ?:W8q3'u`~ucZWxԹﾴO5QSƭ\q(q~ i:߶<\MK']~Թ.<7W5Sm\㫿Mtt}t>u;ga893]._c϶\yp:n_ȅMƹ>`iQM1|\:D55ܺZP:iwuNPqu8\ueo{\AƧp^.6On1W jԸRyu?o|ksw]ǥߺsy3WqΙ?>fuڿ~A'އ/(.mVwRMW}+;pu֩z빩8T<.랋<.TW|S~y7šhy_]]\q*-ucT<̟ _7>T|ո[(k k]soWWυǭϦW5n=kqL-uΧqt͋-\}Cͧc[__AםKM󊝛w? W}j\}ttb8kڶι>E/0ܵu͵Iߖ)\x+?jw]5W}q[A1_.tW~ܼtP(WW^?fW}asuuֱu/\uoۮ}j\S8s|.>ڮOuPzok[G\;xX׾ԭOe\γy| ߔmugz ϶V`u]?y8ǽ0W\atL^WU?0*Q|ic(lU(<׸\h_tk]+:5uU uyq./.=rIk\̶nMs70W|} ڟ+jK5?~kun`\ٗ`/ۺT|S>|qq 5v(3SSu1\W]uj/\_}:Sã}Sk=ypJ});jq}(8u {=8?f\m¶\CQ~q ϵ>]um\:tZͽA[\uVGT0<]|]>q}w^tr7uœ2:Ai\\y֏.mSq)o>ŇC_[7^W[0 As{ѝOČl`mVyΝo81 ty]uU׸g?5Tߕ.b?~Ժ)\WsWUsӸX_^׍˥eZ\Ǿt˵~?:fWuˋn86߶NLοk|]玧3W͗~wͯ+?.|l9O]ţ 8~f/> 8W~?vN 7ŧT\Zn|~ K\Ѷy8ƝW /uaf׾G>bևm]W]E?j)OݸS~\u/0姚mPz07|A-k՟KptmmS7m}|m}Ouf:GS^I>ԍg;ϕOq}œ+ꕫ\1amTS|]?)_7@坛wP2=׭?_mOٮ% ;|s'w_Թm>wq铯qTA ?W] uq1~uS}6o~o8׽N375/Qqǹ[߱q׋:꒯|Q)ukݔZPg;_W?uOGO}奋uXpo]?l.꺮t2(^\~sjmLq(|~3nput_Pk(㺟`:eg]>Q_ݸƷ'qT3W̟uWcq(׹xogW8usW^8ͭqg/ 6m|ʏ뾀šιs{W\|>Ϳ-?Sl> 3:ŋ0gn^֯ou]eܼl&uN?~?̂'Oh[\q;̵?M6?TO5ptk\\~a~ع)C̨y\*wX|]Z\L恚cv}.]Q[o]ut 0so5g̸ߴnu}Յ.^Ts'_:4?w|ձ-?:Of:ɕ_}̴1?sՏtyخ§3[)sGaCkS\­\z߮\M_GesոuG uܷT8)>zloUgc7l5=Wp*Wc|uk ϶)\]~:L5}>q*>ǖGX{m;k\xW5:}S5׾݇3õnU+oq*n\S~)^Ag7 k]뽼W| WXfUtq"#"E\U {un{ݵLmUi"57?ոg{b_7嫋ZPFѕ:ō-/:oS|n>lb~x|[~XfAPP,~ ;j]^|] םiWFv8<0?둒Wը'K4>6+)Ýg*u[ 3_u@SX?7HߧO#-?8ff;N]7\p̏WiGߖ|qT-RxOw3pgzd9i(?۸\k%yFDʱ"(l2 ]?umoS^t%MGcQ]//GSQ5ak[H;bP-l(a.Waj}'}ny<+_~*nuq}Vǩq5nY5.mG>DNmꯋi歎c)Sn|nX~TZ5nG|S<: U+/zwPqty)]~auXqZP1>u`{A_^ZqDžvݗ~)U+0]7/nOPU {2^'Ou_^EQ׾Ņg7z{=aA[ZXyRq(\jj^\|}U?T j?t ['|O/,|S['K}^6>G5[>__"|׫.k>^lyq/W|a@Zy+׾Y' WW-_.`xyqM;ϔ6|8\lso=M偝S]Eū}Xi2 GP,35x2;YʏWW~Lqhv,3_)4.7OKYiya1ûW|wPy K[efOy(~x;+zuXaA6':±g/ƃ ?R)dSA-?]?*~k=ul^yYy;αk|O78A3rˌ#v`eV\5>v=7O5 :7igW]y/.pM㖷u_ztd?:4_ݾp.n򿣟c < 1?[Ox?ُe)8XfGk|"eA3͛mu<׸'"m{,uZs}lʧ[W-: 7~,3?ُO5ij+/: ͵Za)o_Mq}`]DJpד/*.f3rQ0|.^:\UXfW+^yoؼU7h=1sQq'k߄wܸl ێeߖj79]񹮇U׾p#Xfw"Ƈ:J_οgZy}ŵ`]yD~ 7cwŷוkw1lx[5<1?[Ut\xi}C5.[tlL_O?(ުq85/R7+jAGJ?Ʒ[dg*4|t]UǮ/U|tI-~eߔg|A zu:,Y닔./Gn*7:iōt}Plq#.T>T+/뎔cEz?GZݝG|:Oy?2;Yx8񩸦l`~x<0 Nmuy|sn|jHݧH(S1<ոjp_Xf)<#Xf]?>Yu}>bf/xu%l|eZ_xy gc>|ǕX,~xGw^XW^eTSty.W?Ye?ˌ+?w~T-ltST {îjLw|]xuɺ~ێe6[ުOᜬ,/Ĝ1oӾ9TaMq?n|[lyr?H Wz,yOW _GǕ:++N+wU>.~,H^k|t]DJ|+{êkj)^fawթ-z]H.|" 6_a#wX:⫎0 6ny,H]^e)Z?6^PVt7/y'\{}:Ʊ'˱| k}'K`Z׺x<:5O7^RT \=1h޺yU {}A.b|lya|_8EzGگH#yąc}I^/t?'RO5. "k\z3zG7O2PH?76]<_n~ѝpUp)GuGVqoCuQtq{^M?Yœ7wc H˅U /^\8mܼ[ ;Ny+1uq[|:uEJ_UVwU3ͷqg7~};ƃ.i<\뎋GP~a1u}`OHˠ?.l7:GQeO⇵yEڱ?Ye,RNS-|`ty_ˌ{s*xG\1jmH?YXܸa鞛Ƴ  z"]/RFН^SܠRy +\\1m:?z1az=h=pŏԾ *N}cǍGw~b#4o.ܠys1ýN]a7.m<iGluzS竆ͧîk^qlMyPM|]ŮG6\1S|.>ڷ\}7 w^ԣ+_/U +a3wy'̂qW 1|qv2]DJ}})yWucny||Ts].w?cH1h_rWLGJs׿.OyXf^|tyk}~V<]?,-/[ǔ|S\:Vvԯz?h=QϹ?\m+(>AՑ:_gOWo;>w>0 }-쾋#kݪ+myDʱq_+nd?lTP5:t]^Siu)GS?h?>c)ZuTuftZ^ot?Eן6ȞZɘrާ~Ngehw׷z>i}OQr[?w?YGF;u.R'JwJhOW]>G-ΫݩϮuZLzz|W[w4o:Uu__ju߮Cֹ[_Ft+etߓW:2{wi}tnuk9Ei꺦KOͯOWT]_Qy]SnY~o}EYE>ݮ7gw(h_Esw;-߫ʏyG:oWϚWct;կh):գ[v^]oZyMsڟ]=f1ŧWGFoWu^Z:y7]~Uw۵N_o5Y)~ע^Ӽ`w=Vͳ߮׫:ny2uN5yUVS^,tʓ?K7^i󼾴O^S>mQMw}FՙrVީnG~UGӹ75}{WҢ{SGo:.1e_]uzwZiuOn}g_5T?Zw?GͺOoWLqϛ'[~et=ӾguNY뼭#cJw׷8nL;ש]}Osn1ڷԓJ;2Gy֝~L]+1+kdDoީ~/?Wt)ww7Ogzu?wGד}Svuyּ>8j=+NdWOS߷6/>[udT[uWdʺCԺ|f{zetSw6_Wݏ(~tdLo]h͓NNnR[/}˺g]Yt={vGq+>Ň3W캧2VgWO_gu_s^WVߧ}C~zT{/4׽֓z֛:(Q:Sۏ?{UҍgUG>vZ}Sֳ{.|fn^WQ^.L;?Y7GΔqwO%?͋(Q:{[F>6]֧xwYYy2N{9/2awQ~t>e>}Ou>e[r)]+}}(#k_wywKw+}g}辇u>~wdLYS;z}W՟6𞯌O{e=:dLه*?Q:Q>,?~O^Gu}Jdw]iTߖ/y^nޥ:Qw]Vy;?H}?}\Uwk8z_5Yu^ԋҗq[?ǩYcW{?.#ޮnS_y]}qEok}ڗQSA[6ʘW=G]FH]wf5/ʇW'jv~/>eQ]w9U֗dtiZSs>穣2N=:;]nSyַ?ڸOٟiV[\}?êSQFVa֍۵ϻ:i}WGg}>uGO}'u4zuo2twWgwZ֧=>ߝk^{G֧Oڼ[];[Z=Kg=>]g;??,:Y~dL?[Z{7]+4y޺>w~߫|޽;?eLYtީ^uc^4]ѽ]̷neX޺Q>qŷk~ZQuze:vumjQ|gv־9;sz}qS˓gM'[ɮ?G9ED}՗|1+ιڷs՝Ӽ}W7{S:J紎iJSQ~L-nSw/ueNi~[sNwl]?M'g~ko}gqE)pkwW79{w?9=u}=[7gh߻|w2CC՝2N![2K>~/)׫of(LRGFG׽ՕyY^(S:֑e/j_xW琉O}]/ʇԉҍWMؽY8h_N=}r+):ͷtNL郬uX5qΨy:#s_uOwJF:tޥ*^2q=ҝ2_FT'U}[_nq}ﺷ֋ֵtD?s7场}j߭hz떬ͷ:)unu|M:)z[?Ω7ַsۺ~Tݮ>ҝR֧|oS|kiX')}/Jgں^ii7}|~YʹI=|-YNuCU?g[ߚ/t_A^.Uo(Q:KZ][?:_ο){=ֺ}iuNWDD~ʸJ^OS(|+ޞ6jݖ{}Q;/JӾGO}nS)k[d{uqJZ|:>oˮ~hǻ~m::uZߣﻷާCj6FC^eϟt\i,ϩkޮC֭qVʗoEQݿUuӧw[7AEՑ1>5ݬzs6j%wn9:vive>^ON;1gwZo׽;}ym\Q;_wQuwuN}hezncں|+#jQ>en:Գo{zߣMW2ZwyqGZ/w?Gҿ?m\;\dLn$#j?z[՝2Di>N}uk׽:w_sWF>ΓZ?tiHvS2~Xu|ioG>nYtyׯmާ+tddKkzu^eLݏ::^k)}}N>ޛ}aG"K7e6qE??T'jc){ҕyODiW5?ۧ櫫?|Us9EDf:s=ͫ~צދӼ}ί(_>N}Y:Qun#nVXwwߏs((?^2k׾{~Yo~qE>DՕ}k2`wuu><]z2E:]v}Xq~D﾿~N~_?eY ?+e/QeDՉ֫>9?Ϸ5o7?ۿן;{Tk͋/#گU7u߱nR7NT=k{vn 9Yy޳OhQׯ׿{9O?DȺ;9ՕS~>(U{?e}'-z[oˇ|9[w׵ӫ몪7ǩ9o7ou|U~ݭ[7|ʸˮ}:ESuNߨYSa׽)/}Ozvu4=3ݼ\u'ηyƸJ?^}~OU_γnuwa-<U{Um~ή?dt7>dT#͋[Z+{u%˾'Vi|Eto/ywu_tCKzW+}/UetȨzvN߷zQ>OWGh{}4nѥ͏Օ{z]WFY;߫[~+gUݮLFM~)Տʗ}Y"z?vEK}Nedt|F׋қ[V=ʸbjf8Ѿ>͏{[vc}սӼίM7}NouU_ze/|ouweLz^^)~qEN>8}_(s=ՏWѾ>GͿ{ֽ>{R˪GZ}еӼwcLɏ,Օ:﯎uȰ}~և=y7e߽vǔ]OFW)X}92=?gw?˘Q~nooSj߽ߵ3^"oZ~ڸoﻺUOu51uߟ::uFV>g|m_k<ܳAF^}=;բjnues̮[>u|Z:QzSuXS?yrŷ^[}+o)edm)y=~z[O~WU}Xic_{wS{ܧ+i^|-}WJ?ZnO#}wVuy:G˷nϾS߉[Q~5(|[YޝWuʋߨ:Siʹ[\uZtC׻]O?m\{\tߓ͏:?}}S}"{_-~_}E>ʘv#:c\q;OƔs?/Nu[׫5USwv}e߫{>vgYuveT?=y*Z]ZWtݗWUySAF[ݩ;/έ)tSV7הQFWTSyM{'*ϫcOv[EWuS)+K{?eDtΫ_zed3[^L-{\1E_Ώ3e\q(oWTfgt[wwW)HD]w+[]Oҧ{~~E׍ο3u1|;ֽgշy㩟Ӽ^}{f/oU+5]o-vhN[g۬:?-/E;iq'p긢o|)SƔ{㊪:*=k^)V{hѽ.9}^YZF})S{m֡>_:{vױf;՟z>{\ѭcyKm+頻x_{1m+wS)o}[w^nyr3ewfͮ#cw~oOw6/{Y˓˘r?|youWǛn1ߏh}k^ϬUG)N_}ރW}-:/cM7J>dc:weU˸]ڼW띰|j߭)dg}\q_2aڨE):>~SU癥}>UE=n2v|oN{K;SkS_ycn?޺2wϘ;:WtyQ:2OGO}M9[߷`}jwXvuO__}_)mqEUP]ڇuY~^,}mnzOWL'Z=O;<7e߭u9q,?:ؽ|(j]r#~k^lg9]ּ>><(OWt;/]h=oPƔ~+^^U:q)N}͏sNןULhzu辯,ɘjN}~^S?QuݔzVW?OJOWן:7UݭW]zU}Xy[/k%˟665tOWY֏]Ɣ}s'nSsW'^U?Zyz(Rǫ;ީ_}s[ϮP/Y~>jwddg5oW'Z[YZ,?]}0qYozW_'~[ޔqE9֭ꃨ{Uﴎ՛vn>vj4=-aYu|]{`3^W|T[OS7E_7ˇi4߷~OunOsz6?]7K_ӽ'8=Z?|5=UdDwj»!<?{\^ݮw=Jw|˸G?}\1]wW/nt_U{uY:vV{}\>zkOSS|ZN}ZyѺwՙ:~8ʨQe^N:wɮ/mm~{o2aw^=8>>[^.R~kޮNUD3u\uyΩ7ϔ:Ջ}-k߭|߭-ct|IK}O}N9XuO}U~E)q|gʰ~:8{m\qzߣ9{UuΫʇhUQGΓq4/orלּ{׵,zѾ^ٿs۟/M/{Z_{}L]OV}9OFvg}>i>u׍zϥbϲu]zپ'[W]Gۭs?}qŔ;ͳtt!ڧtYun-~^Ϯ5Ooz~ן]ʻJw'L,_V񶞖{}ʺet۫U?߫;(}K>ߗ?oɨ:ZwW֗nf{XzjV=;z]79_F׺Nky]SSaXS΋g~oe3:yWs9ݧ>^6xU,j}[o4_dOF־EW'ʟU/ڏWOZ?e:+'tZT痢U㟎+;sVՑy1sݝ7t/JN:Vl_^]~Vw!שݼShyk4S#G9˼()^u^r^:Y>tUs^WT]=uH~e7z_4:2D|xM{{4Mk|Ӽ~q>df]n{vfk)eDީnuS|E{sc͓nM;6ewutuS}{}Yz[KӍgE~۝n|o{'cJVɪ+,={.QyITs+{2}Dͷރ~ͯQ~exxeS)[k\+iuޯ)zUNn}ʺ>_Wx׾O[GW׹3Y{[vuN>⭛3K>^WdﯦsqbJ:^y_Ztߣo;bW7~UE~ɮ"*ϫ;gU?G׽}o:w˗Sߥ)>+Oz_:>yVK>WͷkJtWW=?{tk>-WLQ:9M7kYtU潶?It Ϗ+}Ծ[yɈ>w9ߛ?dcWgέ/-T/nE{uݗl=}dՉ7I]4Wu^YOWL;}:ޘ<+_~߭=z}zkvf}1>U)4(h2Ndw^vީ^V_DyݿW/`ny^tw'JG~t;ZgoT?OQtu|eO}otk}G#Ow>݇oWwc~vzQt^WǮyS!Odd5OuZQ.ɯ)[oͳec׻t|-WcZOh)et_u^ַ|TgvV/wvU>H=K?~v|mnΟvOkW7Wv}ZTݿwoW{}.ZjߪtwudL[ǴqŔ֕yioY_~4^oJ_Vՙr_3m~u|f'v=̗QQ:?ItzEF߇[2^ +߫ŧ7UunG o~:OXYSnukY)dxu]~v{}Y>iE>nϻWVLc❿orOoo}7+V?JWFtxLȮu^?ͷG4jߥ[Yiqv/ꇟ~aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa__~~O_ǯoaIZb׿~ժw}[!KY?O_pR?un+mets/inst/misc/workshop-run.html0000644000176200001440000013252513623061405016506 0ustar liggesusers Analyzing twin data with 'mets'

Analyzing twin data with 'mets'

Installation

Install dependencies (R>=2.15) : 

install.packages(c("mets","cmprsk"), dependencies=TRUE)

OBS: At this point you might have to restart R to flush the cache of previously installed versions of the packages. If you have previously installed timereg and lava, make sure that you have the current versions installed (timereg: 1.8.4, lava: 1.2.6).

Load simulated data

library(mets)

The dataset prt contains (simulated) observations on prostate cancer with the following columns

country
Country (Denmark,Finland,Norway,Sweden)
time
exit time (censoring,death or prostate cancer)
status
Status (censoring=0,death=1 or prostate cancer=2)
zyg
Zygosity (DZ,MZ)
id
Twin id number
cancer
cancer indicator (status=2) 
data(prt)
head(prt)

   country     time status zyg id cancer
31 Denmark 96.98833      1  DZ  1      0
32 Denmark 80.88885      1  DZ  1      0
39 Denmark 68.04498      1  DZ  3      0
40 Denmark 61.45903      1  DZ  3      0
51 Denmark 78.78068      1  DZ  5      0
52 Denmark 90.36252      1  DZ  5      0

Status table 

prtwide <- fast.reshape(prt,id="id")
ftable(status1~status2,prtwide)

        status1    0    1    2
status2                       
0               9278  883  156
1                936 2308  193
2                163  199  106

Estimation of cumulative incidence

times <- seq(40,100,by=2)
cifmod <- comp.risk(Hist(time,status)~+1+cluster(id),data=prt,
                    cause=2,n.sim=0,
                    times=times,conservative=1,max.clust=NULL,model="fg")

theta.des <- model.matrix(~-1+factor(zyg),data=prt) ## design for MZ/DZ status
or1 <- or.cif(cifmod,data=prt,cause1=2,cause2=2,theta.des=theta.des,
              score.method="fisher.scoring",same.cens=TRUE)
summary(or1)
or1$score

OR for dependence for competing risks

OR of cumulative incidence for cause1= 2  and cause2= 2
              log-ratio Coef.    SE    z    P-val Ratio    SE
factor(zyg)DZ           0.785 0.221 3.55 3.82e-04  2.19 0.485
factor(zyg)MZ           2.100 0.278 7.56 4.11e-14  8.14 2.260
              [,1]
[1,] -5.179525e-09
[2,]  4.202363e-08

pcif <- predict(cifmod,X=1,resample.iid=0,uniform=0,se=0)
plot(pcif,multiple=1,se=0,uniform=0,ylim=c(0,0.15))

pcif.png

Assumes that the censoring of the two twins are independent (when they are the same): 

incorrect.or1 <- or.cif(cifmod,data=prt,cause1=2,cause2=2,theta.des=theta.des, 
                        theta=c(2.8,8.6),score.method="fisher.scoring")
summary(incorrect.or1)
## not  bad
incorrect.or1$score

OR for dependence for competing risks

OR of cumulative incidence for cause1= 2  and cause2= 2
              log-ratio Coef.    SE    z    P-val  Ratio       SE
factor(zyg)DZ            2.84 0.469 6.06 1.37e-09   17.1     8.04
factor(zyg)MZ            8.61 5.810 1.48 1.39e-01 5460.0 31800.00

Correcting for country

table(prt$country)

times <- seq(40,100,by=2)
cifmodl <-comp.risk(Hist(time,status)~-1+factor(country)+cluster(id),data=prt,
                    cause=2,n.sim=0,times=times,conservative=1,
                    max.clust=NULL,cens.model="aalen")
pcifl <- predict(cifmodl,X=diag(4),se=0,uniform=0)
plot(pcifl,multiple=1,se=0,uniform=0,col=1:4,ylim=c(0,0.2))
legend("topleft",levels(prt$country),col=1:4,lty=1)

pcifl.png

Design for MZ/DZ status 

theta.des <- model.matrix(~-1+factor(zyg),data=prt) 
or.country <- or.cif(cifmodl,data=prt,cause1=2,cause2=2,theta.des=theta.des,
                     theta=c(0.8,2.1),score.method="fisher.scoring",same.cens=TRUE)

summary(or.country)

OR for dependence for competing risks

OR of cumulative incidence for cause1= 2  and cause2= 2
              log-ratio Coef.    SE    z    P-val Ratio    SE
factor(zyg)DZ           0.736 0.234 3.15 1.66e-03  2.09 0.488
factor(zyg)MZ           1.860 0.279 6.67 2.54e-11  6.44 1.800

Concordance estimation

Ignoring country. Computing casewise, using prodlim. CIF: 

outm <- prodlim(Hist(time,status)~+1,data=prt)

times <- 60:100
## cause is 2 (second cause)
cifmz <- predict(outm,cause=2,time=times,newdata=data.frame(zyg="MZ"))
cifdz <- predict(outm,cause=2,time=times,newdata=data.frame(zyg="DZ"))

### casewise 
pp33 <- bicomprisk(Hist(time,status)~strata(zyg)+id(id),data=prt,cause=c(2,2),prodlim=TRUE)
pp33dz <- pp33$model$"DZ"
pp33mz <- pp33$model$"MZ"
concdz <- predict(pp33dz,cause=1,time=times,newdata=data.frame(zyg="DZ"))
concmz <- predict(pp33mz,cause=1,time=times,newdata=data.frame(zyg="MZ"))

par(mfrow=c(1,2))
plot(times,concdz,ylim=c(0,0.1),type="s")
lines(pcif$time,pcif$P1^2,col=2)
title(main="DZ Conc. Prostate cancer")
plot(times,concmz,ylim=c(0,0.1),type="s")
title(main="MZ Conc. Prostate cancer")
lines(pcif$time,pcif$P1^2,col=2)

concordance.png 

par(mfrow=c(1,1))
cdz <- casewise(pp33dz,outm,cause.marg=2)
cmz <- casewise(pp33mz,outm,cause.marg=2)             
plot(cmz,ci=NULL,ylim=c(0,0.5),xlim=c(60,100),legend=TRUE,col=c(3,2,1))
par(new=TRUE)
plot(cdz,ci=NULL,ylim=c(0,0.5),xlim=c(60,100),legend=TRUE)

casewisea.png

Similar analyses using comp.risk for competing risks leads to tests for equal concordance and more correct standard errors 

p33 <- bicomprisk(Hist(time,status)~strata(zyg)+id(id),data=prt,cause=c(2,2),return.data=1)

p33dz <- p33$model$"DZ"$comp.risk
p33mz <- p33$model$"MZ"$comp.risk

head(cbind(p33mz$time, p33mz$P1, p33mz$se.P1))
head(cbind(p33dz$time, p33dz$P1, p33dz$se.P1))

         [,1]        [,2]         [,3]
[1,] 60.88384 0.001354486 0.0006759148
[2,] 64.98252 0.001738665 0.0007767791
[3,] 66.34227 0.002145175 0.0008759241
[4,] 67.23626 0.002553690 0.0009656368
[5,] 67.96152 0.002980112 0.0010544136
[6,] 68.37310 0.003852670 0.0012192761
         [,1]         [,2]         [,3]
[1,] 58.85519 0.0001741916 0.0001740997
[2,] 67.87387 0.0004044091 0.0002883926
[3,] 69.55123 0.0006488647 0.0003777479
[4,] 70.83183 0.0009069944 0.0004570724
[5,] 71.05738 0.0011672691 0.0005255212
[6,] 71.06602 0.0014276382 0.0005859026

Test for genetic effect, needs other form of bicomprisk with iid decomp 

conc1 <- p33dz
conc2 <- p33mz

test.conc(p33dz,p33mz);

$test
           cum dif.         sd        z        pval
pepe-mori 0.3937372 0.09841628 4.000732 6.31468e-05

$mintime
[1] 60.88384

$maxtime
[1] 96.92463

$same.cluster
[1] FALSE

attr(,"class")
[1] "testconc"

OR expression of difference in concordance functions and Gray test 

data33mz <- p33$model$"MZ"$data
data33mz$zyg <- 1
data33dz <- p33$model$"DZ"$data
data33dz$zyg <- 0
data33 <- rbind(data33mz,data33dz)

library(cmprsk)
ftime <- data33$time
fstatus <- data33$status
table(fstatus)

fstatus
   0    1    2 
9597  106 4519

group <- data33$zyg
graytest <- cuminc(ftime,fstatus,group)
graytest

Tests:
      stat           pv df
1 28.82416 7.925617e-08  1
2 33.79236 6.131919e-09  1
Estimates and Variances:
$est
              20         40           60          80        100
0 1 0.0000000000 0.00000000 0.0001741916 0.006741025 0.01880244
1 1 0.0000000000 0.00000000 0.0006710172 0.017420360 0.05031415
0 2 0.0006970762 0.01974882 0.1141800067 0.504364854 0.93797293
1 2 0.0009363302 0.01655314 0.0948098327 0.443996722 0.90692430

$var
              20           40           60           80          100
0 1 0.000000e+00 0.000000e+00 3.034323e-08 2.115863e-06 9.493584e-06
1 1 0.000000e+00 0.000000e+00 2.250627e-07 9.173278e-06 5.102841e-05
0 2 8.094463e-08 2.487399e-06 1.556735e-05 6.990685e-05 4.769058e-05
1 2 1.752378e-07 3.424511e-06 2.388136e-05 1.271394e-04 1.171775e-04

zygeffect <- comp.risk(Hist(time,status)~const(zyg),
                  data=data33,cause=1,
                  cens.model="aalen",model="logistic",conservative=1)
summary(zygeffect)

Competing risks Model 

Test for nonparametric terms 

Test for non-significant effects 
            Supremum-test of significance p-value H_0: B(t)=0
(Intercept)                          26.8                   0

Test for time invariant effects 
                  Kolmogorov-Smirnov test p-value H_0:constant effect
(Intercept)                          2.22                           0
                    Cramer von Mises test p-value H_0:constant effect
(Intercept)                          36.3                           0

Parametric terms : 
           Coef.    SE Robust SE    z    P-val
const(zyg) 0.944 0.218     0.218 4.34 1.45e-05
   
  Call: 
comp.risk(Hist(time, status) ~ const(zyg), data = data33, cause = 1, 
    cens.model = "aalen", model = "logistic", conservative = 1)

Liability model, ignoring censoring

(M <- with(prt, table(cancer,zyg)))

      zyg
cancer    DZ    MZ
     0 17408 10872
     1   583   359

coef(lm(cancer~-1+zyg,prt))

     zygDZ      zygMZ 
0.03240509 0.03196510

Saturated model 

bpmz <- biprobit(cancer~1 + cluster(id), 
             data=subset(prt,zyg=="MZ"), eqmarg=TRUE)

logLik(bpmz) # Log-likelihood
AIC(bpmz) # AIC
coef(bpmz) # Parameter estimates
vcov(bpmz) # Asymptotic covariance
summary(bpmz) # concordance, case-wise, tetrachoric correlations, ...

'log Lik.' -1472.972 (df=2)
[1] 2949.943
(Intercept)  atanh(rho) 
 -1.8539454   0.8756506
             (Intercept)   atanh(rho)
(Intercept) 0.0007089726 0.0003033296
atanh(rho)  0.0003033296 0.0044023587

              Estimate    Std.Err          Z p-value
(Intercept)  -1.853945   0.026627 -69.627727       0
atanh(rho)    0.875651   0.066350  13.197393       0

    n pairs 
11231  5473 
Score: -3.453e-05 5.123e-06
logLik: -1472.972 
Variance of latent residual term = 1 (standard probit link) 

                        Estimate 2.5%    97.5%  
Tetrachoric correlation 0.70423  0.63252 0.76398
Concordance             0.01131  0.00886 0.01443
Case-wise/Conditional   0.35487  0.29391 0.42094
Marginal                0.03187  0.02834 0.03583

bp0 <- biprobit(cancer~1 + cluster(id)+strata(zyg), data=prt)

summary(bp0)

------------------------------------------------------------
Strata 'DZ'

              Estimate    Std.Err          Z p-value
(Intercept)  -1.846841   0.019247 -95.955243       0
atanh(rho)    0.418065   0.050421   8.291446       0

    n pairs 
17991  8749 
Score: -0.001842 -0.0006881
logLik: -2536.242 
Variance of latent residual term = 1 (standard probit link) 

                        Estimate 2.5%    97.5%  
Tetrachoric correlation 0.39530  0.30882 0.47529
Concordance             0.00486  0.00361 0.00655
Case-wise/Conditional   0.15019  0.11459 0.19443
Marginal                0.03239  0.02976 0.03523

------------------------------------------------------------
Strata 'MZ'

              Estimate    Std.Err          Z p-value
(Intercept)  -1.853945   0.026627 -69.627727       0
atanh(rho)    0.875651   0.066350  13.197393       0

    n pairs 
11231  5473 
Score: -3.453e-05 5.123e-06
logLik: -1472.972 
Variance of latent residual term = 1 (standard probit link) 

                        Estimate 2.5%    97.5%  
Tetrachoric correlation 0.70423  0.63252 0.76398
Concordance             0.01131  0.00886 0.01443
Case-wise/Conditional   0.35487  0.29391 0.42094
Marginal                0.03187  0.02834 0.03583

Equal marginals MZ/DZ 

bp1 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="u",data=prt)
(s <- summary(bp1))

                 Estimate     Std.Err           Z p-value
(Intercept)     -1.849284    0.015601 -118.539777       0
atanh(rho) MZ    0.877667    0.065815   13.335456       0
atanh(rho) DZ    0.417475    0.050276    8.303615       0

 MZ/DZ       Complete pairs MZ/DZ
 11231/17991 5473/8749           

                           Estimate 2.5%    97.5%  
Tetrachoric correlation MZ 0.70525  0.63436 0.76438
Tetrachoric correlation DZ 0.39480  0.30854 0.47462

MZ:
                     Estimate 2.5%     97.5%   
Concordance           0.01149  0.00942  0.01400
Casewise Concordance  0.35672  0.29764  0.42049
Marginal              0.03221  0.03007  0.03449
Rel.Recur.Risk       11.07524  9.15861 12.99187
DZ:
                     Estimate 2.5%    97.5%  
Concordance          0.00482  0.00363 0.00640
Casewise Concordance 0.14956  0.11441 0.19315
Marginal             0.03221  0.03007 0.03449
Rel.Recur.Risk       4.64343  3.44806 5.83880

                         Estimate 2.5%    97.5%  
Broad-sense heritability 0.62090  0.41075 0.83104

Components (concordance,cor,…) can be extracted from returned list 

s$all

                               Estimate        2.5%        97.5%
Broad-sense heritability    0.620895137 0.410750804  0.831039470
Tetrachoric correlation MZ  0.705248651 0.634356556  0.764377527
Tetrachoric correlation DZ  0.394801083 0.308543835  0.474618270
MZ Concordance              0.011489242 0.009421632  0.014004180
MZ Casewise Concordance     0.356715720 0.297643978  0.420492296
MZ Marginal                 0.032208397 0.030073567  0.034489384
MZ Rel.Recur.Risk          11.075239652 9.158610651 12.991868652
DZ Concordance              0.004817009 0.003625030  0.006398416
DZ Casewise Concordance     0.149557550 0.114405842  0.193154111
DZ Marginal                 0.032208397 0.030073567  0.034489384
DZ Rel.Recur.Risk           4.643433455 3.448063061  5.838803849

Likelihood Ratio Test 

compare(bp0,bp1)

	- Likelihood ratio test -

data:  
chisq = 0.0468, df = 1, p-value = 0.8288
sample estimates:
log likelihood (model 1) log likelihood (model 2) 
               -4009.213                -4009.237

Polygenic Libability model via te bptwin function (type can be a subset of "acde", or "flex" for stratitified, "u" for random effects model with same marginals for MZ and DZ) 

bp2 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="ace",data=prt)
summary(bp2)

             Estimate   Std.Err         Z p-value
(Intercept)  -3.40624   0.19032 -17.89736  0.0000
log(var(A))   0.74503   0.25710   2.89787  0.0038
log(var(C))  -1.25112   1.04238  -1.20024  0.2300

 MZ/DZ       Complete pairs MZ/DZ
 11231/17991 5473/8749           

                   Estimate 2.5%     97.5%   
A                   0.62090  0.41075  0.83104
C                   0.08435 -0.09373  0.26244
E                   0.29475  0.22992  0.35959
MZ Tetrachoric Cor  0.70525  0.63436  0.76438
DZ Tetrachoric Cor  0.39480  0.30854  0.47462

MZ:
                     Estimate 2.5%     97.5%   
Concordance           0.01149  0.00942  0.01400
Casewise Concordance  0.35672  0.29764  0.42049
Marginal              0.03221  0.03007  0.03449
Rel.Recur.Risk       11.07524  9.15861 12.99187
DZ:
                     Estimate 2.5%    97.5%  
Concordance          0.00482  0.00363 0.00640
Casewise Concordance 0.14956  0.11441 0.19315
Marginal             0.03221  0.03007 0.03449
Rel.Recur.Risk       4.64343  3.44806 5.83880

                         Estimate 2.5%    97.5%  
Broad-sense heritability 0.62090  0.41075 0.83104

Liability model, Inverse Probability Weighting

Probability weights based on Aalen's additive model 

prtw <- ipw(Surv(time,status==0)~country, data=prt,
            cluster="id",weightname="w") 
plot(0,type="n",xlim=range(prtw$time),ylim=c(0,1),xlab="Age",ylab="Probability")
count <- 0
for (l in unique(prtw$country)) {
    count <- count+1
    prtw <- prtw[order(prtw$time),]
    with(subset(prtw,country==l), 
         lines(time,w,col=count,lwd=2))
}
legend("topright",legend=unique(prtw$country),col=1:4,pch=-1,lty=1)

ipw.png 

bpmzIPW <- biprobit(cancer~1 + cluster(id), 
                    data=subset(prtw,zyg=="MZ"), 
                    weight="w")
(smz <- summary(bpmzIPW))

              Estimate    Std.Err          Z p-value
(Intercept)  -1.226276   0.043074 -28.469378       0
atanh(rho)    0.912670   0.100316   9.097911       0

    n pairs 
 2722   997 
Score: 3.329e-05 -2.252e-05
logLik: -6703.246 
Variance of latent residual term = 1 (standard probit link) 

                        Estimate 2.5%    97.5%  
Tetrachoric correlation 0.72241  0.61446 0.80381
Concordance             0.05490  0.04221 0.07113
Case-wise/Conditional   0.49887  0.41321 0.58460
Marginal                0.11005  0.09514 0.12696

Comparison with CIF 

plot(pcif,multiple=1,se=1,uniform=0,ylim=c(0,0.15))
abline(h=smz$prob["Marginal",],lwd=c(2,1,1))
## Wrong estimates:
abline(h=summary(bpmz)$prob["Marginal",],lwd=c(2,1,1),col="lightgray")

cifMZ.png

Concordance estimates 

plot(pp33mz,ylim=c(0,0.1))
abline(h=smz$prob["Concordance",],lwd=c(2,1,1))
## Wrong estimates:
abline(h=summary(bpmz)$prob["Concordance",],lwd=c(2,1,1),col="lightgray")

conc2.png

ACE model with IPW 

bp3 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",
              type="ace",data=prtw,weight="w")
summary(bp3)

             Estimate   Std.Err         Z p-value
(Intercept)  -2.31618   0.18673 -12.40359   0e+00
log(var(A))   0.85390   0.22689   3.76347   2e-04
log(var(C)) -29.43218   4.34216  -6.77823   0e+00

 MZ/DZ     Complete pairs MZ/DZ
 4716/8835 997/1809            

                   Estimate 2.5%    97.5%  
A                  0.70138  0.60824 0.79452
C                  0.00000      NaN     NaN
E                  0.29862  0.20548 0.39176
MZ Tetrachoric Cor 0.70138  0.59586 0.78310
DZ Tetrachoric Cor 0.35069  0.30328 0.39637

MZ:
                     Estimate 2.5%    97.5%  
Concordance          0.04857  0.03963 0.05940
Casewise Concordance 0.47238  0.39356 0.55260
Marginal             0.10281  0.09463 0.11161
Rel.Recur.Risk       4.59457  3.79490 5.39425
DZ:
                     Estimate 2.5%    97.5%  
Concordance          0.02515  0.02131 0.02965
Casewise Concordance 0.24461  0.21892 0.27226
Marginal             0.10281  0.09463 0.11161
Rel.Recur.Risk       2.37919  2.13966 2.61872

                         Estimate 2.5%    97.5%  
Broad-sense heritability 0.70138  0.60824 0.79452

Equal marginals but free variance structure between MZ and DZ 

bp4 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",
              type="u",data=prtw,weight="w")
summary(bp4)

                Estimate    Std.Err          Z p-value
(Intercept)    -1.266427   0.024091 -52.568381       0
atanh(rho) MZ   0.898548   0.098841   9.090866       0
atanh(rho) DZ   0.312574   0.073668   4.243006       0

 MZ/DZ     Complete pairs MZ/DZ
 4716/8835 997/1809            

                           Estimate 2.5%    97.5%  
Tetrachoric correlation MZ 0.71559  0.60742 0.79771
Tetrachoric correlation DZ 0.30278  0.16662 0.42760

MZ:
                     Estimate 2.5%    97.5%  
Concordance          0.04974  0.04044 0.06104
Casewise Concordance 0.48442  0.40185 0.56785
Marginal             0.10268  0.09453 0.11144
Rel.Recur.Risk       4.71777  3.88751 5.54802
DZ:
                     Estimate 2.5%    97.5%  
Concordance          0.02269  0.01667 0.03081
Casewise Concordance 0.22097  0.16448 0.29013
Marginal             0.10268  0.09453 0.11144
Rel.Recur.Risk       2.15203  1.53917 2.76490

                         Estimate 2.5%    97.5%  
Broad-sense heritability 0.82563  0.50195 1.14931

Check convergence 

mean(score(bp4)^2)

[1] 2.723881e-14

Liability model, adjusting for covariates

Main effect of country 

bp6 <- bptwin(cancer~country,zyg="zyg",DZ="DZ",id="id",
              type="ace",data=prtw,weight="w")
summary(bp6)

                Estimate   Std.Err         Z p-value
(Intercept)     -2.81553   0.23889 -11.78590   0e+00
countryFinland   0.87558   0.16123   5.43061   0e+00
countryNorway    0.68483   0.17762   3.85567   1e-04
countrySweden    0.77248   0.12350   6.25468   0e+00
log(var(A))      0.77724   0.23186   3.35220   8e-04
log(var(C))    -28.96268   4.10060  -7.06303   0e+00

 MZ/DZ     Complete pairs MZ/DZ
 4716/8835 997/1809            

                   Estimate 2.5%    97.5%  
A                  0.68509  0.58704 0.78313
C                  0.00000      NaN     NaN
E                  0.31491  0.21687 0.41296
MZ Tetrachoric Cor 0.68509  0.57428 0.77124
DZ Tetrachoric Cor 0.34254  0.29262 0.39060

MZ:
                     Estimate 2.5%    97.5%  
Concordance          0.02236  0.01588 0.03141
Casewise Concordance 0.39194  0.30778 0.48305
Marginal             0.05705  0.04654 0.06977
Rel.Recur.Risk       6.86967  5.08343 8.65591
DZ:
                     Estimate 2.5%    97.5%  
Concordance          0.00989  0.00700 0.01394
Casewise Concordance 0.17329  0.14505 0.20570
Marginal             0.05705  0.04654 0.06977
Rel.Recur.Risk       3.03735  2.56114 3.51356

                         Estimate 2.5%    97.5%  
Broad-sense heritability 0.68509  0.58704 0.78313


bp7 <- bptwin(cancer~country,zyg="zyg",DZ="DZ",id="id",
              type="u",data=prtw,weight="w")
summary(bp7)

                 Estimate    Std.Err          Z p-value
(Intercept)     -1.581478   0.051318 -30.817030   0e+00
countryFinland   0.491725   0.081517   6.032155   0e+00
countryNorway    0.385830   0.094254   4.093497   0e+00
countrySweden    0.433789   0.060648   7.152599   0e+00
atanh(rho) MZ    0.884166   0.099366   8.898113   0e+00
atanh(rho) DZ    0.271770   0.073240   3.710668   2e-04

 MZ/DZ     Complete pairs MZ/DZ
 4716/8835 997/1809            

                           Estimate 2.5%    97.5%  
Tetrachoric correlation MZ 0.70850  0.59760 0.79280
Tetrachoric correlation DZ 0.26527  0.12752 0.39298

MZ:
                     Estimate 2.5%    97.5%  
Concordance          0.02347  0.01664 0.03300
Casewise Concordance 0.41255  0.32395 0.50721
Marginal             0.05688  0.04643 0.06953
Rel.Recur.Risk       7.25251  5.40099 9.10403
DZ:
                     Estimate 2.5%    97.5%  
Concordance          0.00794  0.00489 0.01287
Casewise Concordance 0.13966  0.09312 0.20421
Marginal             0.05688  0.04643 0.06953
Rel.Recur.Risk       2.45511  1.47912 3.43110

                         Estimate 2.5%    97.5%  
Broad-sense heritability 0.88646  0.55608 1.21683

Stratified analysis 

bp8 <- bptwin(cancer~strata(country),zyg="zyg",DZ="DZ",id="id",
              type="u",data=prtw,weight="w")

summary(bp8)

------------------------------------------------------------
Strata 'Denmark'

                Estimate    Std.Err          Z p-value
(Intercept)    -1.583608   0.051241 -30.904856  0.0000
atanh(rho) MZ   0.992896   0.217349   4.568215  0.0000
atanh(rho) DZ   0.070588   0.186956   0.377566  0.7058

 MZ/DZ     Complete pairs MZ/DZ
 1334/2789 287/589             

                           Estimate 2.5%     97.5%   
Tetrachoric correlation MZ  0.75859  0.51308  0.88937
Tetrachoric correlation DZ  0.07047 -0.28750  0.41117

MZ:
                     Estimate 2.5%     97.5%   
Concordance           0.02611  0.01584  0.04274
Casewise Concordance  0.46093  0.28426  0.64799
Marginal              0.05664  0.04623  0.06922
Rel.Recur.Risk        8.13766  4.72047 11.55486
DZ:
                     Estimate 2.5%     97.5%   
Concordance           0.00420  0.00110  0.01596
Casewise Concordance  0.07422  0.01888  0.25037
Marginal              0.05664  0.04623  0.06922
Rel.Recur.Risk        1.31043 -0.43515  3.05601

                         Estimate 2.5% 97.5%
Broad-sense heritability   1      NaN  NaN  

------------------------------------------------------------
Strata 'Finland'

                Estimate    Std.Err          Z p-value
(Intercept)    -1.087902   0.063221 -17.207912  0.0000
atanh(rho) MZ   0.859335   0.302752   2.838410  0.0045
atanh(rho) DZ   0.393145   0.179942   2.184840  0.0289

 MZ/DZ    Complete pairs MZ/DZ
 660/1633 134/316             

                           Estimate 2.5%    97.5%  
Tetrachoric correlation MZ 0.69592  0.25985 0.89623
Tetrachoric correlation DZ 0.37407  0.04044 0.63265

MZ:
                     Estimate 2.5%    97.5%  
Concordance          0.07008  0.03975 0.12064
Casewise Concordance 0.50666  0.27641 0.73412
Marginal             0.13832  0.11316 0.16801
Rel.Recur.Risk       3.66298  1.85349 5.47246
DZ:
                     Estimate 2.5%    97.5%  
Concordance          0.04160  0.02237 0.07607
Casewise Concordance 0.30073  0.16558 0.48242
Marginal             0.13832  0.11316 0.16801
Rel.Recur.Risk       2.17417  1.00995 3.33838

                         Estimate 2.5%     97.5%   
Broad-sense heritability  0.64369 -0.21675  1.50414

------------------------------------------------------------
Strata 'Norway'

                Estimate    Std.Err          Z p-value
(Intercept)    -1.192293   0.079124 -15.068598  0.0000
atanh(rho) MZ   0.916471   0.301133   3.043409  0.0023
atanh(rho) DZ   0.533761   0.252070   2.117509  0.0342

 MZ/DZ   Complete pairs MZ/DZ
 617/928 115/155             

                           Estimate 2.5%    97.5%  
Tetrachoric correlation MZ 0.72422  0.31516 0.90635
Tetrachoric correlation DZ 0.48825  0.03969 0.77303

MZ:
                     Estimate 2.5%    97.5%  
Concordance          0.05918  0.03218 0.10633
Casewise Concordance 0.50764  0.27633 0.73572
Marginal             0.11657  0.08945 0.15057
Rel.Recur.Risk       4.35466  2.15709 6.55223
DZ:
                     Estimate 2.5%    97.5%  
Concordance          0.03945  0.01840 0.08257
Casewise Concordance 0.33842  0.15583 0.58636
Marginal             0.11657  0.08945 0.15057
Rel.Recur.Risk       2.90310  0.89710 4.90911

                         Estimate 2.5%     97.5%   
Broad-sense heritability  0.47195 -0.47133  1.41522

------------------------------------------------------------
Strata 'Sweden'

                Estimate    Std.Err          Z p-value
(Intercept)    -1.149412   0.032155 -35.745836  0.0000
atanh(rho) MZ   0.836864   0.125476   6.669520  0.0000
atanh(rho) DZ   0.199677   0.092907   2.149202  0.0316

 MZ/DZ     Complete pairs MZ/DZ
 2105/3485 461/749             

                           Estimate 2.5%    97.5%  
Tetrachoric correlation MZ 0.68414  0.53057 0.79423
Tetrachoric correlation DZ 0.19706  0.01758 0.36425

MZ:
                     Estimate 2.5%    97.5%  
Concordance          0.06055  0.04659 0.07835
Casewise Concordance 0.48365  0.38001 0.58872
Marginal             0.12519  0.11277 0.13877
Rel.Recur.Risk       3.86327  3.00137 4.72517
DZ:
                     Estimate 2.5%    97.5%  
Concordance          0.02515  0.01672 0.03766
Casewise Concordance 0.20088  0.13541 0.28746
Marginal             0.12519  0.11277 0.13877
Rel.Recur.Risk       1.60452  0.99901 2.21004

                         Estimate 2.5%    97.5%  
Broad-sense heritability 0.97416  0.53594 1.41238

Wald test (stratified vs main effect) 

B <- contr(3,4)[-(1:3),]
compare(bp8,contrast=B)

	- Wald test -

	Null Hypothesis:
	[Denmark.atanh(rho) MZ] - [Finland.atanh(rho) MZ] = 0
	[Denmark.atanh(rho) MZ] - [Norway.atanh(rho) MZ] = 0
	[Denmark.atanh(rho) MZ] - [Sweden.atanh(rho) MZ] = 0
	[Denmark.atanh(rho) DZ] - [Finland.atanh(rho) DZ] = 0
	[Denmark.atanh(rho) DZ] - [Norway.atanh(rho) DZ] = 0
	[Denmark.atanh(rho) DZ] - [Sweden.atanh(rho) DZ] = 0

data:  
chisq = 3.4972, df = 6, p-value = 0.7443
sample estimates:
    Estimate   Std.Err       2.5%     97.5%
  0.13356053 0.3726923 -0.5969029 0.8640239
  0.07642511 0.3713780 -0.6514624 0.8043126
  0.15603178 0.2509676 -0.3358556 0.6479191
 -0.32255628 0.2594839 -0.8311353 0.1860227
 -0.46317298 0.3138347 -1.0782776 0.1519316
 -0.12908846 0.2087690 -0.5382682 0.2800912

Created: 2014-05-09 Fri 12:09

mets/inst/misc/mena.html0000644000176200001440000002264113623061405014745 0ustar liggesusers Analyzing twin survival data with 'mets'

Analyzing twin survival data with 'mets'

  1. Load the menarche data. 
    library(mets)
data("mena")
  2. Estimate the mean age at menarche in each cohort treating the censored observations as uncensored. Are there seemingly any significant effect of cohort?
  3. Estimate parameters from the Tobit regression model (linear normal regression with right censoring): 
    s <- survreg(Surv(agemena,status) ~ 1+factor(cohort)+cluster(id),
             dist="gaussian", data=mena)

    Interpret the output from the model.

  4. Calculate the Kaplan-Meier estimator for each cohort. Plot and interpret the results. What is the approximate age at median survival time? 
    km1 <- survfit(Surv(agemena,status) ~ factor(cohort), data=mena)
palette(c("darkblue","darkred","orange","olivedrab"))
plot(km1,mark.time=FALSE,col=1:4)
  5. Add the survival curve from the Tobit regression to the plot (for the youngest cohort). Use the pnorm function and extract the mean and standard deviation (scale) from the survreg model. 
    tt <- seq(0,16,length.out=100)
ss <- 1-pnorm(tt,mean=coef(s)[1],sd=s$scale)
lines(tt,ss,lty=2)
  6. Estimate a Cox regression model using the cox.aalen function from the timereg package. 
    ca <- cox.aalen(Surv(agemena,status)~+1+prop(cohort)+cluster(id),
                data=mena,max.clust=NULL,n.sim=0,robust=0)
  7. Calculate the two-stage Clayton-Oakes-Glidden estimate 
    vardesign <- model.matrix(~-1+factor(zyg),mena)
e <- two.stage(ca,data=mena,theta.des=vardesign)

    Interpret the results. Refit the model with a new variance regression design, vardesign, that makes it possible to assess the statistical significance of zygosity.

  8. Plot paired menarche times 
    library(lava.tobit)
menaw <- fast.reshape(mena,id="id")
status <- menaw$status1+menaw$status2+1
plot(agemena2~agemena1,data=menaw,pch=c(2,6,16)[status],col=Col(c(4,2,1)[status],0.6))
  9. Estimate parameters from ACE model 
    s0 <- twinlm(agemena~1,zyg="zyg",DZ="DZ",id="id",data=mena)
s0
mena$S <- with(mena, Surv(agemena,status))
s <- twinlm(S~1,zyg="zyg",DZ="DZ",id="id",data=mena,control=list(trace=1,start=coef(s0)))
s

Created: 2013-05-15 Wed 07:30

mets/inst/misc/twinbmi2.rda0000644000176200001440000013370113623061405015362 0ustar liggesusers &W}~! QBX2-j_a{X0Zʬg,clX2jcX&(eQB& QB:D(eNiꭿ'nss:u[n)g EeZbAlq!׋{1q_<.O{ĭxxF|H<+>&w3yxI|-Ć8ax' xJG܊gćijc9Iq'>#^//ג bC xxD^qxR<%#n3CY1/ϋŗKkIW@\k#xL'ē)q+/ϊ'ŝxA|^(,^_K_. q .5zqO<&IxψgsN|F >/^_/%B<,^#cx\)g EeZJAlq!׋{1q_<.O{ĭxxF|H<+>&w3yxI|-#lq!׋{1q_<.O{ĭxxF|H<+>&w3yxI|- 6ā׈G=/O'S=V_<#>$ωO;xQ|Y$ bC xxD^qxR<%#n3CY1/ϋŗKkIk!ąxXF<"^/}xB<)!xN|R܉ψŋ%$( q .5zqO<&IxψgsN|F >/^_/%Ć8ax' xJG܊gćijc9Iq'>#^//גBAlq!׋{1q_<.O{ĭxxF|H<+>&w3yxI|-ɿU@\k#xL'ē)q+/ϊ'ŝxA|^(,^_Kr+bCq".čxXZFV<"^'^/ 7ě}6xxBS<)%}A!axN|B|R|J܉OψϊċK+%U5$XbGq!n5:zqOQ<&$I.xxxψgGsSN|Z|F|V >'>/ ^___/'łXbGq!n5:zqOQ<&$I.xxxψgGsSN|Z|F|V >'>/ ^___/'oĊ;@ q#׉׋7{1&q_M<..OwĻ{{ŭxxxF|P|H|X<+>*>&>.w39yxI|U|M|=˧鏰"6Ď8'B܈ūkk#u xxLIo';œ])n^q+'/> ϊ''ŧĝxA|N|^|A($,"^___O*!vā8F<,^-^#^+ocMxx\]~xV|T|L|\<'>!>)>%ħgg s E%ez_ #ĉ7ajZxxx'(o NxxJ[GW܊gŇćųc9 I)q'>->#>+^_///Wד bElq NąW׈׊G=Fx/&oOw'ŻS=VO_|@<#>(>$>,ωOOO;iYxQ|I|E$*&GXbGq!n5:zqOQ<&$;œ])n^q+'/> ϊ''ŝxA|N|^|A($,"^__Kߩ #ĉ7ajZxxx'(o NxxJ[GW܊gŇćųc9 I)q'>->#>+^_///WדrA #ĉ7ajZxxxxxLIo';ŻĻ{{ŭxxxF|P|H|X<+>*>&>.w39yxI|U|M|= VĆD<,^-^#^+ocMxx\]~xV|T|\<'>!>)>%ħgg s E%ez"6ā8F<,^-^#^+ocMxx\]~xN|B|R|J|Z|F|V|N|^|A($,"^___O+!vā8F<,^-^#^+cMxx\~xN|B|R|J܉OψϊċK+%U5$R+bCq".čxXZFV<"^'^/ 7ě}6xxBS<)%}A!axN|B|R|J܉OψϊċK+%U5$)!vā8F<,^-^#^+ocMxx\]~xV|T|L|\<'>!>)>%ħgg s E%ezg bI5!ĎH3q!čVjm5kwGw׉- G+(O<&_I/"&~P<.~H]xBx1q.){Ogω (>(~I|HUQkcooO->%~G܉'>#}9ş/?_&"\$B|U5_&ĒXkbCl'đ8gB\-akķ׊%^/[A|'WQ|xL|xq_EMx\xaNcI]'S'ŻO?#nϊ?/> ~A<#~Q|Pea+Yįω%>)~[|J+>-~O|F}Ys/?/?_*,L|ExIkLr1#,&6Ė{@q&.ĕ"*^-MF|xN:]{{7[O?&?.%~B<%~R[xi^3Vx9~3/_"*>*~M|L M [ŧ;g/^ >'P|^c%Wğ_ &$X+bMl-#ā8'L\+q#E<,UZ|xvZuw77o? o?,?")~L<)~\KxJx)gĭY>s/g/_,>,~E<+~U|Tuq9'oOwwŧψ/>+~_ @|N#E'KOŗş?/_@|MCuI^.%"Ć;bO#q"ą7[[ūŷ׈o!)^'K^|xqO|x>~&xxA!v #ēŻOOw?-+~F܊?'/~^|@xF%!WijWGů_!)>!~K|Rq'~W|Z ϋ?_,^"$T|Ys U?_XKbE %vĞ8GD q%nķŷWo.^+C<"SN|xn=^F}1M}6qCG;ŏ'ŏwO?%#~ZW?+'~N_EAKCŇůgů_.>.~C<'~S|Bm);N=gω?$ X(D|I3%(.2$VĚ[bGq$NęWF|xX|x6;#;w׋o#o'/$~@oo?(?$.~X$~Y|XxV517s7'oO#O_|VxACyG ŋOėğ/?_.^!*/ bI5!ĎH3q!čVjm5kwGw׉- G+(O<&_I/"&~P<.~H]xBx1q.){Ogω (>(~I|HUQkcooO->%~G܉'>#}9ş/?_&"\$B|U5_&yĊXbK=q ĉ8J܈oo&^#]V|xD|x.z {=cś-m'ďwO?!?)-~JGxq+~VOxy ć/_ϊ_&>&~]|\xN-ISwĝ]i{3ϊ/?(>/H|AxQSeg+K/W?_P|]eqA,&6Ė{@q&.ĕ"*^-MF|xN:]{{7[O?&?.%~B<%~R[xi^3Vx9~3/_"*>*~M|L M [ŧ;g/^ >'P|^c%Wğ_ &$/?’XkbCl'đ8gB\-akķ׊%^/[A|'WQ|xL|xq_EMx\xaNcI]'S'ŻO?#nϊ?/> ~A<#~Q|Pea+Yįω%>)~[|J+>-~O|F}Ys/?/?_*,L|ExIkL?)%"Ć;bOq&.ĕ"*^-MF|xx.z {=cś-mG;ŏ'ŏwO?%#~ZW?+'/~^|@xF%!WijWGů_!)>!~K|Rq'~W|Z}9ş/?_&"\$B|U_&yĊXbK=q ĉ8J܈oo&^#]V|xD|x.z {7o? "~P<.~H]xBx1q.){Ogω (>(~I|HUQkcooO->%~G܉'>#}9?_*,L|ExIk/O bI5!ĎH3q!čVjm5kwGw׋o#o'/$~@oo?(?$.~Xs/g/_,>,~E<+~U|Tuq9'oOw  np)SC3_kBak_>-U~WkÚ&l߄^W1Og&Ưxlwg>z~?v-_o9{y#Z?7;&⑊hhxr*NR~fc8Gq|;Okh;ӯ*w_hxyy1{>ܝ?8!cx|t~.qrsG2xCO;.w8*OQB:]?b8ݩYLqyϷkmrGt^.hCJ@s<}p 9/_>_/|Bz]ߞ>#z1G$}\.!}Q9 t=Gq9t=׫nN'?w{O{oh%>?.(]ߛγ˸~Gz=CGj!_Lx?Ϊ ~:?UO'Wq<ԞT:>i(0N U>+/gߔ:n*>r|:g O~~|e??嫎oO>ʡ{|1˿;3T{]{O8woϫ/_}f<+_BzB?OC{p9N~ 6b+_^=ݿw~S@{?Hr=YQΫ|C\?jByg]ꏈQϡ~OŃxT)g3_#w/u#yP2?RYf^u@8MǝGܞ},:;q>ûGF#Io5>f=vBʟ RۧfTSyͬ2Oz!UOcoʛϏ3E>?|\Kboc zQe[n_TOJyu}6~(GՏr{%|"q2~vJϾ{!G#Jӥ\\?y#u|F'kq^^3_Rׇ{>Y=>z ~ Ťt+ѿH]_뱰W2/Yڧp|.ϪT/-5>U|ӫxO]MVC"Ϻ__VyG.uˤYjCVtʇ?e^ o, LG#E}^pzILoʛʓ넬Jrr^;;/I_=u9f'|et!s$e3Q~ST>uZ?OVuˆcURt zQ|>b_^ԸDhy;DžR~??CϯȰ<<oSq>_J_/*T>83w4_}Nj E|#빼f^I'oO=|~1yTy 郿9zG)U^(?tx~nN0u|_yLY[+>*n|fR_J=>{ZRF{ǐfs Onogrp6y+7>?wd>O}dOQ/ڏǟ3Cކu,.$.o Wz#V/M|를+^Y\Ş=xŃ#.'d'o/;M_jt2?lo_g^?R!/OF-Pw^J_q"zo(?HGh'CȧyM !^3Jc՟IW(ʕp껋]+/ofHOFg>$Gf|2qy/}ϕo?Q-SNEJ͇ <*'%uuP#?va?㡩q(_?q0>tq{D3o775n/&US.|Og#w_Y޹|3y :n~gȟǬ~|s#>.w.g sd~dWf;k8uŨwWo15/?W3*/JKg8Q_OP21+u|;ۡ3灺܇FǍ'?8RVF^ݑ܏V}s!_O~!|$yL]d:Q_d˚/p^y?q}Qy:qmy)d~mj>ӟnycVA\NH˱>#yry>i/P}O>+Țrg^^?UE^LwO_Od̟N;xH(W'/j泿7.YB;PU~rIӊϧ}EHGVz(WjSϭde?TyP|+ͷʺxqI>ʺ<ɜ9>g!x+[V>e;5G맞͸.ʺ>tzqϰ 7Ӟ~fQo>MhR+N;y:q^L~_x+Ysqg{ʏU? s7JÕH=dCuf>;]i#I_UAr/7G7GGJ;5ɼ_ת_|#Ny1YcjC<__O'< OQ?1;s|+}o%W$7Sf͟Iw@r/!y5?>ͨwRS6xϓP'|鼻i~^3~ρO ^1#ϊG{r(WW|S{}4Qϼ9|rqqJ9;Z?IO(7n?&?OCJo~>/{\Of{O]'kYe/N̓ȳ |L 9gNwwחc<>~[T? 5Gzw.o=>u8= CUK_Q>}$j//Rz3| w~y`}y_ uSCjY[K\^H55o%PrqҲ{I"_HgVb?*_)C~9=GuByp|IǴ!~GU^)ίP_#~Y\+ϳs/>oۡdys;_n/G{C},_ƸF(]Lgx6ߙSU/vۓ=~S<.h~6s}Rk_R둽dRϓt<_{<*._}V^:Lw<[ˣY ?\WHO`G2>{R~AjXu>"{Wl2>K7FuH>xoS+Cx};TIw!_K!ds~O'N ~楩=OOB^8b>\NWwʪ!]f/*g.o޿W)Οп=.:^o~n35Wnxr_F~=lvgSaY!gT/]ߥ}˯Y꾤ϧ/\\S7|%#Ug_Vоu_*oqt|o9/>'i 6CH80w(|PVnIRNj*WP_޺E*}yS/ߣʟ_L#;GnRg!NګwP5+}xSp~oS~3T!SCHַŤ_:>5곌"u=}G2S>?:nO<,վJTSOg?\^wQ||R/$Rό˃Cyғ3~GV!k~fHm|w|IG/Ww@<~;~$uE=x"'nCy9'ՏHn~Y}Q"U88+Q$d< ǗYf/~n-b9z&wC_Sg\ꗄγxG8}>/n\o~odT]usa>d/!^ ?J;z~SNyt9+z~-?!}.a|_#(oſu^"Jww\>:Nw^~8.?ɺOU~U>[wO'8|7X}D՟I_L+U^z&UoW;>:?N$gfW.{Mx>)rt~Gf3 '57~Zi깬_3T'g֛!tV;oVq2r)~>t8T-7|~(?O{?}nO_BeÊ٨~ J ;W!=7Գd/~&ӓ闼M}GҟryN7?\g^#xd|Ru{9YoC|MgV$:ܟwC}pVh2@GM<~(/=|r4/">o(}|7sYroJoU?N|%u>wʃ|wz/Hu\_~)gI],'..>nq:Cy߮۟ _jOgԛ/m~LgZQGB{TB};xάg:x=T{rzFh2~ޕη]7՟R;##SϬ5e]/%J#>K_5pe|Yl^d9r~W__OAUzV{^Dj~x΋z1>Db*}gs,Y#t>x|U/0PR<3I7 㲎?d=okF~Ư\>2/վ="C>:=ʇݞ?ON߬z^qhw|=q?%]/=[2?SH[Wfyu$ZܟWY߹7ˍN'9Ydڳ8>{po8YUyάUd=ߟ8B~|/Ο(:N_Nϳ<.wT|gSSO74}Yy}_xۃPN8t~.UNdc"Sׁ]0'Ϻl??sj|L7iX>~(yf{xr(y}G.9zo>I_RPG8]|fz*}  G|Ӹ#JGTRouܿM=l<<]L2d &!}qy!^G~o5Ex#LdCQ<ɞ{gU^s|<<^󿾞MGO|cOh8wj>ؗGMkTSz|:zu<57nYީr}|i z_^oOM2Ώ +s;~ ?0>˙\Fο_)kO815ҩ-/&ӗcdο:VΟN'>k{LSH޺Rj|mRt>O~|03C*7YשY~o^(_QR TIj!L_ȯKYy=eOHկƿS{:~Ōɪ<Ʒ_TV{q?wwyJ_i6;!Nd_|z'u#3:qn/z!s~ϕY?~![ϷyK/y%sOуԼpW̼/x(y\?//W&{$q+yGrBRrw$yY<=.q=/U>8RvadzsD+Yכg:#gԛWߧ擫N3ɪϵSU3K)]_x~C!~̺?ut07>~8Q-O7Kkek8nFJ`>/YϝDOz^'p+5}ɐNGV~گp_ּ߷ٯWz ՕMd܏ͪ}Tv#帜f?|x^Tjʋ*Uܞ*YAsr`_d ]ȏ~7_/*}qޡ}J<G~1ٞϪRmFλьz'՞W|]iqyo(o.>sQt|g3ʨ}z +>ό7kK<_~ɻx~k޸u|[{qH.TCgo*YJ>xv}\m~jj>WuO|]LS}M>&Oz-?UR><~.Wopep㻼 tO7~Ew?5Πtg=5o=/MsO+>/{9>z/f'>?>V|HǸ]7M,_^Vu=9-{YT;?p~E3Nͯ]j>.YO%A ?JGwoX(Q}:jAj~G|ǣ#|o*=ofy9^T9S|}QxDov7km*tTy1#P~<|(ӧtr{kʟѩoj95R>hӿsz/sȇ]ry*yy|>Qj '~'_qfh/&&уG\_ʺj_d9}|;LO㯮}Zt2/&W;>Gg=~Y:0T}GICQ{O*~:YuooB{he֗/qw})ګשqgէqyC'dկ>E'}rݡt*?RϱT^喙?u=h=j?ܯɥY'\v:^ #9.jRwzn/qAV+Y\dB+:{"ʭ:.a7)kTb2fgf]gOB6GTߏw!ew/o?ɺN?C`藜P|B+lʋ/R:%$#>jwB.5{o|}I=g_RG}Tl?x)#YD?w_Vmp}f?빋Jo(oWO)R[aKB|yT^pթ(\eha9_>ߏo-$??^7F6^8~oK~x;}"H17N,$a?یi_>?lۅqC/:N߸;gM'.?>,xCxko`;3G~o9hh9P/ž_\\r\>}Wֿd#q=?W./iwq=wzJ(!? ttz\TO\~G߇T~7>Jg8b8~h {\ v+qyUC_kyh׸> &xqwqt<|}p}S|ngx\27WY0^__yuy=q]#/<^!IGoe(q{qTzt[px\'Z/n_sss5gxh?Fˋ뙸%?O[Ǎsq]ܿDzYnwyn/{?z!u-86Oө%w^o >J]nް?_/~Pzq/xY}Z/N}a!mY9>Jw]jI};8~qbmGor>.J!ӗWuA#7xkxBC:V(/vv!g= A(5XH/׆t?h> +ީ,|}#o_R&Ϻ/?RJO_ױq2/^pmr{xYlߧGy55nӰ}_?x!^tڣjW߼1Z/xyk^ǃ{;|cFۇqp[xf|܈q?/Z/̃ g/)No|}BЏ sd&OF!_uq{mo_qk9N6~ʞz8Jw>\t2>-p=ʑgUFzB:|J-YO+{?{כq;MK+7Cwxɫ>w9ۛ(޿r<- Cz!?2_Gˡ?sۯHxzWʏUw?$nB=v~|wo &^/T}Fuy/$/U|~Fߧ B{~˷E~W?/q񉐮8˾~7~\.I~InE~a: ~h8k<0c|} ߯p<O}/kpu\ε^x9W|Ϭ!?|_;)xG/fB2q\Κk={xzǙ}]o^Gx=[{>ǯHȺﺯtx>+?B~^<~1uw~\oEC<<^{1~ ?'z,ߐy v'b_"_mWy[ӑZMl~syJGоy q}>WzC{Kk-ruo{簿Nݪ]Gt|σ ߬qu >z^ou_<"?i{ x|ڃ+G<>r~^r93oxu~/|"k~pV^?P_O>_e#/? A/O__.$?t5?*5qO˺OUxk=Nʇi}~=|ܮt>Ϻ~^yOǍ&wxϟˬ>0#\y!>糅 ]2>Y[wSzz ?WCϓϋGO![z|DKM'KW&q8i|?/ڏwoW%gg}_5?߶KW̿Lj]{>N^!ޭbu? ?kF{8r1o-u5/~M`zmRi=;_olj+.Jh[wADq+$K?/Knz#qz,·}"za?} [wZ__G˩rW.{o4_B!0O-#uAq"f &~N<\GpGK+W|.,owLg85t7a\L-a{8zy>%׏Ͽo>ұK~֭x?':??w?'cq=~~a{|~h9wݺK?>/!d}3]ofx|q$-߬׊W߱/!>a=wLOؿ}v~G_Yi<>7Yn鍎+,{<}hsS>ڟ~%?U p>fwDS@۟~7i^؛cOȷz+vxӽd\]ײ[w68?{߈cmvq1Ϸpz%KW۲җ՟};s< HOV&Gd~ry}Lo\v=.nCҧC}.8bAߧKۃqv}О|a]ʋ˃u}qLoO[ܺK{&瑅;>py{8n˯q-i!O?~.ײxaou87Z^"Cmh{[u??^z4_Hotxm8^}(YtNߧbvф>v=;/Dw4aaqS?Ըbt|Czߵ>O/z^swR3d"Sݼnߧ~w!3+|~{>ϯuwszNxmο¬z?u>Z8 ߇~ޓ"nng<JX/^)b7eZJ_xkOcZΪ_xh?}DwpRo܏_lH?_OJ7 vڿuM4|<OuD<Ua}Z1>?o /$Ytofm/%sϑۃOo׻{*܎9Ouqxq?Oɺ>~@T0~omYJۅr=i7uoL\nKv\[`x.7܏xǃzK|_|˩Kmt;ϳOMu)!5\?܍c{ܟǯ}?%=<7ݎ8~ou~zQ;,k8 ecS1a0oI~^(7}T}xuوwC7{y?Я ;Y~_r>^>S?ݕ۬ͩ熴y}]~wοӌ x٫{|u?5?K~/Gyamrgf:.#5Z{of7~ǃt-)]Ufc7svyquٻ0GSwpBrٿo|43\o1Eq?O֋ǿ#%IDg]7;}=G S:qmʓ-}&~^r؅T9CU_ lR5C<q<}~M]<^v>}ꡬqvo)Y Yʺ޼1b?7)'\?tv.~HD tQOt.I/b<~GǍҵLO~?vYS{.n{ft*}-SU?'/$jd: +.v{tP.o&ڋoqBe%txE7k{>^n8Ǣ;˱;8^zn(~p[<.zzh9}vsa?-5{/Zg3>v]FC=ח!=o6V}OD?DӿK7^p>BR9_ IDRqnKo^|WHǍVGBmoߝ~um~>"U/!>B_ C߬t?/|8\ngxyp^vq?c_%>JgޅFߧ%}./q\/Bx? _Χz.>U//5׏yֲ.+..Gy^mʓg?f:_|_2uIaq{?7_E߼<e8n{q}3g~q9}4/ Za=|R\~ w#FMj=s>sȧi~]}}x^6'EfM?&ףC{ho]~YH;}hCaMC>megR8{XoLGq]|}C>R~O?=QH'sWv~E|~#(]0'GO ~^~D\G?<DN%χ~Lo|Gz;~z. uz&|Ἰ|coz^/53ZMz&~[>?ϫ}umG{;R&/7~?Q 9B2]~>!k_Ͽgu>:#0do.$|#֛Q!7$ez<+ϟW}Jv!{oۓП{[x~jk!Q;s}hު<߬%R]rY]i]=-s~o.:DZ<_|M~-畆xe=3q?Eٳozҡt}F߇xo}hP<^|$~|xJx68ߣe'vx~{8!ctܸ uܢ=?v3s6/=G+z/ _W^ -d/sܢtƣC'A;Q&?w:k!u1~ftBrlO|Oq*7}Cy}E 7?׻Ex;gO +$bB|C?=w}w~us~0o_ ߇߻ӧ懆)}@rB?y<-l֏Gg_ }Ayv}|[Hn!oqZHn Uy9Xk:J <Ϸײ矄qtnR+|Lϯz/IW_-{"הԸ2 㲡?+?Z/Ey\!nϝ?zOHO0zO[6?C=리Կ/|yݯw?܂/Kd|ϯնe_wK<}9~d:uZvy{&ʣ%]8BwἹ?w P~B(>|hz%Zs?Z;/C%9//Brˊ_|{2׵~ܟvp_)R9ĭ}f4.d<8Zw8=I_am/(G%5]r:W忐\/?W(\u_____________________________K9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s JJ ѿZa{D_wXݿv}nɿ7-:P"( uBWZ6syBЏ;$c„0%s‚$k†p-CÄ᭄"j6p Bx;J_#_'!#wQu.?NOM' 7){~u*{?Gx/7<}_'# p7 &ap3­E /~!_&N &A8AGKQG8I+]J~uY' :?Go!M§ <^¿@ 4aK %K2sp?_%| / |o$[/mCe¿KxBxpJC1L:?!;6 k;< k_5 k_ڧ~u?5 k_5 k_5 k_5 k_5 k_5 k_5 k_5 k_5 k_5 k_5 k_5 k_5 k_5 k_5 k_5 k_5 k_޸|u_:_u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_:u_o7 o+4 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 o7 oxԞ&7Mo&+5Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo?y]o&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo&7Mo|-o [X-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o [-o뗗qmo~۸6qmVn~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6qmo~۸6޷mo}x6޷mo}W޿qy;wp~;tp~;wp~;wp~;wp~;wp|;8wp|;8wp|;8wp|;8wp|;8wp|{;w|{;w|{;w|{;ww;~ww;~ww;~ww;~ww;~ww;~ww;~ww;~ww;~ww;~ww;~ww;~ww;~ww;~wwx;8~ww;y#:]w.~w]we.~w]w.~w]ux.^w]ux.^w].mzx.Nwq]t8.Nwq]t8.Nwq]t8.Nwq]t8.Nwq]t]ux.^w]ux.^w]ux.^w]ux.^wiǻ].xϻx.w]=|s{l>=|s{>h{=u{x^=u{x^=uvG~h{8np=v{np=v{n=u{x^=u{x>=|s{.p=\r{.p=\r{.p=\r{.p=\r{.pGݣf=u{x^=u{8Np=t{8Np=|s{>=|s{.p=\r{.p=\r{.==|s{>p=\r{.p=\r{.p=\r{.p=\r{.pGݣq>Nq}t8>Nq}tl>Nq}t8>Nq}t8>Nq}t8>Nq}t8>NqOݧv>nq}v>nq}v}w>~}w>~i}i>q}\z>q}\z>q}\z>q}\z>q}\z>q}\z>qO>}|{>}|{6}|8>q}|}}x>}}x>}}6}~>q}~>q}~>qO[>}>}>}>}>G?? ??????????????????????????????xk3?!C?!CdC?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?|+sF?#G?#G?bG#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?z?1c?1c?1;?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?~&? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'? O'?yk2?)OS?)OS?)ON?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?)OS?}+rg?3 g?3 g?3v<3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?3 g?{?9s?9s?9s9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?/ _/ _/ _, _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/ _xb,K_%/K_%/K_%/9%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/K_%/Y W+_ W+_ W+_+_ W+_ W+_ W+_ W+_ W+_ W+_ W+_ W+_ W+_ W+_ W+_ W+_ W+_ W+_ W+_ W+_ W+_ W+_ W+_ W+_ W+_ Wxޯ~+_ Wxޯ~+_ Wxޯ~+_ Wxޯ~+_ Wxޯ~+_ Wxޯ~+_ Wxޯ~7. 85ίq~k_85ίq~k_85ίq~k_hk_85q}k\_׸5q}k\_׸5q}k\_׸5q}k\_׸5q}k\_85q|k_85q|k_85q|k_85q|k_85q|k_85~{k^5~{k^5~{k^5~{k^5~{k^5~{k^5~{k^5~{k^5~zk^x5^zk^״k5nq{k^׸5nq{k^׸5nq{k^׸5nq{k^x5^zk^x5^zk^x5^zk^q6x=7 nop{7 nop{7 nop{np{|C{ op|78 nop{7 nop{78 >oy|7 m{7x ^oz7x ^oz7x ^oz7x ^oz7x ^ozvop{7 nop{7 nop{7 nop{7 nop{7 nop{7 nop{7 nop{7 nop{ m78 op|78 oh7x o|78 op|78 op|78 op|C۽ op|78 op|78 op|78* ǯp* ǯp* ǯp* ǯp* ǯp* ǯp* ǯ`WU}n_WU}n_WU@(`nۂ=}3QEDz۱۱~xxxxxxxg߱xxxxxxxxxxxxxxxxxxxxx8oqqqqqqqqqqqqqqqqqqqqqq[P^ec^[{nMmets/inst/misc/sim-cens-ts.r0000644000176200001440000001113313623061405015456 0ustar liggesusers data(prt) dim(prt) table(prt$status) ### 21000 7000 1000 library(mets) ### set.seed(100) prt<-simnordic(7500,cordz=3,cormz=4,cratemz=1.0,cratedz=1.0) prt$status <-prt$cause table(prt$status) prt<-simnordic(7500,cordz=2.0,cormz=3.,pcensmz=0.0,pcensdz=0.0,cratemz=200.4,cratedz=100.4) prt$status <-prt$cause prop.table(table(prt$status)) prt$cancer <- (prt$status==1) prt<-simnordic(7500,cordz=1,cormz=3,pcensmz=0.9,pcensdz=0.9,cratemz=0.4,cratedz=0.4) prt$status <-prt$cause prop.table(table(prt$status)) prt<-simnordic(75000,cordz=2.0,cormz=3.,pcensmz=0.0,pcensdz=0.0,cratemz=200.4,cratedz=100.4) prt$status <-prt$cause table(prt$status) prt$cancer <- (prt$status==1) ### bp3 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="ace",data=prt) summary(bp3) coef(bp3) exp(-0.1)/( exp(-0.1)+exp(-0.77)+1) exp(-0.77)/( exp(-0.1)+exp(-0.77)+1) gem <- c() for (pcens in seq(0,0.95,length=5)) { prt<-simnordic(7500,cordz=3,cormz=4,pcensmz=pcens,pcensdz=pcens,cratemz=0.4,cratedz=0.4) prt$status <-prt$cause tt <- table(prt$status) if (length(tt)==2) tt <- c(0,tt) prt$cancer <- (prt$status==1) ### bp3 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="ace",data=prt) summary(bp3) ### gem <- rbind(gem,c(pcens,tt,coef(bp3))) } gem gemmzdz <- c() concmz <- concdz <- marg <- cens <- gemmzdzc <- matrix(0,5,5) cens <- gemmzdzc <- matrix(0,5,5) gemmzdza <- matrix(0,5,5) j <- i <- 0 for (pcensmz in seq(0,0.95,length=5)) { i <- i+1 j <- 0 for (pcensdz in seq(0,0.95,length=5)) { j <- j+1 prt<-simnordic(100000,cordz=1.5,cormz=3,pcensmz=pcensmz,pcensdz=pcensdz,cratemz=0.9,cratedz=0.9) prt$status <-prt$cause tt <- table(prt$status) if (length(tt)==2) tt <- c(0,tt) prt$cancer <- (prt$status==1) ### bp3 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="ace",data=prt) ud <- summary(bp3) ### gemmzdz <- rbind(gemmzdz,c(pcensmz,pcensdz,tt,coef(bp3))) print(c(i,j)) gemmzdza[i,j] <- coef(bp3)[2] gemmzdzc[i,j] <- coef(bp3)[3] marg[i,j] <- ud$probMZ[3,1] concmz[i,j] <- ud$probMZ[1,1] concdz[i,j] <- ud$probDZ[1,1] cens[i,j] <- tt[1]/sum(tt) } } ### gemmzdz gemmzdza gemmzdzc ### h <- exp(gemmzdza)/(exp(gemmzdza)+exp(gemmzdzc)+1) c <- exp(gemmzdzc)/(exp(gemmzdza)+exp(gemmzdzc)+1) ### round(h,2) round(c,2) round(cens,2) ### ###h2.3 <- h ###c2.3 <- c h15.3 <- h c15.3 <- c round(h1.3,2) round(c1.3,2) round(h2.3,2) round(c2.3,2) save(h1.3,file="h13.rda"); save(c1.3,file="c13.rda") save(h2.3,file="h23.rda"); save(c2.3,file="c23.rda") save(concmz,file="concMZ23.rda"); save(marg,file="marg23.rda") table(prt$zyg,prt$status) library(latextable) cbind(h1.3,c1.3) ######################################################################################## ##################### MC ######################################################################################## library(doMC) library(mets) registerDoMC() onerun <- function(k,cordz=1,cormz=3) {#{{{ print(k) pcensmz <- seq(0,0.95,length=5) j <- (k%%5) j[j==0] <- 5 i <-ceiling(k/5) print(c(i,j)) prt<-simnordic(300000,cordz=cordz,cormz=cormz,pcensmz=pcensmz[i],pcensdz=pcensmz[j],cratemz=0.3,cratedz=0.3) prt$status <-prt$cause cmzdz <- table(prt$status,prt$zyg) if (nrow(cmzdz)==3) cmzdz <- rbind(c(0,0),cmzdz) tt <- table(prt$status) ###print(tt) if (length(tt)==2) tt <- c(0,tt) prt$cancer <- (prt$status==1) ### bp3 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="ace",data=prt) ud <- summary(bp3) ### return(list(index=c(i,j),cmzdz=cmzdz,status=tt,pcensmz=pcensmz[i],pcensdz=pcensmz[j],bp3=bp3)) }#}}} ud <- onerun(25) prop.table(ud$status) res <- c() res <- foreach (i=1:25) %dopar% onerun(i,cordz=1,cormz=3) ###res23 <- res res13 <- res ###res153 <- res gemmzdz <- c() concmz <- concdz <- marg <- cens <- gemmzdzc <- matrix(0,5,5) cens <- gemmzdzc <- matrix(0,5,5) gemmzdza <- matrix(0,5,5) for (k in 1:length(res)) { j <- (k%%5) j[j==0] <- 5 i <-ceiling(k/5) print(c(i,j)) print(res[[k]]$index) print(c(res[[k]]$pcensmz,res[[k]]$pcensdz)); bp3 <- res[[k]]$bp3 ud <- summary(bp3) gemmzdza[i,j] <- coef(bp3)[2] gemmzdzc[i,j] <- coef(bp3)[3] marg[i,j] <- ud$probMZ[3,1] concmz[i,j] <- ud$probMZ[1,1] concdz[i,j] <- ud$probDZ[1,1] tt <- res[[k]]$status cens[i,j] <- tt[1]/sum(tt) } cens h <- exp(gemmzdza)/(exp(gemmzdza)+exp(gemmzdzc)+1) c <- exp(gemmzdzc)/(exp(gemmzdza)+exp(gemmzdzc)+1) ### round(h,2) round(c,2) round(cens,2) # ###h153 <- h ###c153 <- c ###cens153 <- cens ###marg153 <- marg ###conc153 <- concmz ###h13 <- h ###c13 <- c ###cens13 <- cens h23 <- h c23 <- c cens23 <- cens conc23 <- concmz marg23 <- marg round(h13,2) round(h23,2) save(h13,file="h13.rda") save(h23,file="h23.rda") ### save(c13,file="c13.rda") save(c23,file="c23.rda") ### save(marg23,file="marg23.rda") save(conc23,file="conc23.rda") mets/inst/misc/cifMZ.png0000644000176200001440000001761513623061405014662 0ustar liggesusersPNG  IHDR&TTIDATx{XUumDQRgİh4@NN& =fRSy]F=sLg<:j`Y^2x <m{MkZ_=qZi wrB* rB* rB* rB* rB* rB* rB* rB* rB* rB* rB* rB* rB* rB* $@S]]sNSizcwygĈzsz7vAqyǖ-[VWW7sm۶O0!77jvvSə ϼqs9ZKKCBB9r3g D}aaa,Y$::Zr}]VWW7dȐӧO}TTTt](.ѭr|+UNjjiz k!BS[[;wXjXbccg͚U__/w/t:WZ;]$]RR~ )));UNrrrNNNFFF\\v]f_ t`bdff0 &&fԩ.k͚52{O96-/////OfwE!T@BP9!T@BP9!T@BP9!T@BP9!T@BP9!T@BP9!T@BP9!T@BӾ|S9?~K7^l6S9y*':::##C`N[n V5p. rB* rB* rB* rB* rB* rB* rB*  ;@޽;Ǎ7h olxs…}̩K7^3fڵzs6m/~ /ms9!T@B9i*|sr:^}Ν-*L4#|^Nmmŋ7lPQQrϟoZe9j[|yRs3\i)Bp8bbbE)--ݼyشiL0ر<ߣGtP唔_>(+OII߿4]p41Bjiiiaan;:}əf(C%$z&T9gϞ4-***--m͚52{WZZSS3䐐Cu=ʱlyyyyyy2#Zn??:ǰH rB*'::Zm@'N >|oپ}u ~'QQQ]ܹK̬mv_ T9ݺu{衇,oIHHlmNgssǷy_#[R'؏P(OvjfKHHh3اO ^tBOjS<a1{V\B22bN+tb!ҭrRSS}Ao{9!BS[[;wXjXbccg͚U__/w/t:WZ;m͵]RKKd555yo{D۾}}.O.\f7G{5Oڷo˗q=Zvm'{r drbbȑ?䈎^Mֽ{w/mG@ gDSIP9!T@BP9!T@~ps[napŗ̏Ytƍ=:vاzj!!!f5o]/CNafWѣG͛w=\{$->>W_ 0/سgϘ1c}~|g``ĉELm5JU/B?AAAz.fҶro߮iZzzv{Op3iڦMsL;9s/)ɓ%%%QQQ&^xԩSNzg̘! `>w ^}=|D!_$2e(skr.]@```eep,_9_vp8Ν;zQF OI>}:>>~{:uj||O?- t6}yO==@xׯҥK˗0k|ǂ.dUUBBxhK/s455%'' ʕqL x;<~大+ow twN!I ;Ip'i$ BH ʩy{ݫW)S O3s̠C=z4000;;[8|ڿH>(// QOeSLs9!Wѣx≪3f=Z8|گ˗766544,[L8|?WTTo pzOx2Johr,Yr  p}ڱFWRR_O&qGoo7_9[GX7&mw[=~P0.E!ߩ$&&v}ذa+S9ӦMKOO;v)S0TzO\6 x5@B* rBڿ4t]dfe奛nz;E&ה){勘*ڪihsL, {rҤIaaaYYY2{yZZZOrȑÇΜ9Sf_ z.믿 Seɒ%ђ{K\N]]ݐ!CN>ɓ={;@wBlEQ>TkuBڮ]4M<(!!!ׯOII;ȝQU5"""""BQ;Cl!t`vܹVbΚ5"T9t痕ZJUU!w/:VRR~ )));UNrrrNNNFFF\\v{޲}uֵO-BSPPyYMӢ֬Y=oIHHlmNgss7Erl6[^^^^^^ޒfO>] ;I#Gj? ohnn?"00 s\.MQ ))}; 7{?Arjkk/^aÆ 6|GԣGw  w!{X+((X, :uLw>0>BP9!T@BP9!I(ʚ5G=z/ ̊(rSQ S:>P0*~`S8BP9!T@b+&MT^^w l~_ٯum„ ۸*gڵǏ;`6ۧihH"… Ν륍s` xrxn;v|̏>:0/q 'GEr^Dfڪ~{zs91ckjjNðaցnMӼqUν{9S0~|oEQFrqUW^w &O~gq$0f̘㥍r+WZ/]r+566zo\>BP9!;s 74550-ʕ`~e9꽍rjSz*/pv{ 2ܝw齍rlӰaTT\p?y(恙ر#11K7^hm~;ʕtP9!T@BP9!T@BP9! ++=sŋxӧ99;=?p`O|Bk(ojʔzgs9!T@BP9!T@BUP,[Ùuuy}Q9mj 7v6607*"ml6\@BP9!T@BϜY|??{arN++0sL2`~rs0P9!XWn'3vzSΌ :FHP9#{o)\@5Μqz2fĈ~\τ*v6lp\iiiϷZ2p}jmyС:>?p 'T p(Jii͛ǦMdz=sS OII߿@rsrr222TU----,,2{h}ҥfOfBSPPyYMӢ֬Y#w޽ǎ|5{axNrl6[^^^^^`DWΝ֎?\Ш(ʊ~'|sXq4|Νm+{w@# ! @W"ixWIw-d=EI=zp 0'.aÉ>dfaaO!Cºu7`Z\$mr|E _9MCCƍTX8Lw/޾}u ~'}Ԯ-tɒ=NlZ]]SRFFv8mL:v uw/NHHlm!Fשt]_٥(^xroVuuuVVAM6wAyc{ D)..VՎ~0 *'55X?B*vܹVbΚ5^f_ T9t痕ZJUU!w/!{X+((X, :ump]1n:{pR]]}ɫ̡)$$D ]IӴnݺ]|{zb,(:q@EEEQQQ^ ݶm.\w.vС\];EsdXQL8o;ŷ^@BP9!T@+_]lL(EQ:u}Q(_+}/p\ŋzbNGzb,(XWG.Q9!T@BP9!T@b9|bcmmqjkku $''s}Q---YYYgϞu}QQ|vGv>rz]UUU'OӧOdddffttQW\v݅:sVN]]?|#yyyׯŋuhVZZzt:-[7EYlY}}W_}`󳲲/JQɓ'?555͛>~/^\jm4yG}bΜ93fpzQjw!NkWW[[{}wܸqWEkk+ ԫW/QWW74M5jj>|'܃F_io^xkGLcǎ%%%&%%;v=huUWWY֛o9??qy }u< l>rB* rB* rB* rB* rBTUuHHHPEUU>*@Q}\={N_jwT##XkΛ7/22_|ܳgϗ_~YQgdd{<52 [oݶmۂ TU=|oK/)2}__}cbbI ~6֮jccc``˗uii.]*xQPP8[nݔkl2M4Mx޽{L HrL8qѢE/_JOO_hމ T \ :nw"@rBBP9!T@BP9!T@BP9!T@BP9!T@B/[I yIENDB`mets/inst/misc/casewisea.png0000644000176200001440000003651613623061405015617 0ustar liggesusersPNG  IHDR&T IDATxg\T׾>ߞaf`PHQQb;k,9b XN5$G*z4bDs4FMbbĨ Qi"JrpP`M~x1,֬D.: D0F9"A#` rD0F9"A#` rD0F9"A#` rD0F9"A#` rD0F9"A#` rD0F9"A#` rD0F9"A#` r3}d]m6}W`bʕ+ryG nduֺH}b"Ƿ~;z蘘";c }WbΝ۷o777w!&ϯ D0(rzLH$Qdee)aÆI$/^rlȐ!lfC򁢢3gx{{ӧmllX\N^^\.xb1@EՀjjj.\HD}ф y6!`t`\dfffggզM݁5H /QllK/dw:e…:q:~G0ƚC~rr_Ik֬۷<Ϭܽ{wȑqqqyyygϞ};t˗w mDLڤȢZwYlٴiӈrƍ3gT*2f|;hdvxҷoߏ?XU~~~nCmذAhܾ}s׮]7n|AAɓ 9sy<|0˖-stth41##? ՠdҤI_5󥥥3gtvvvqq5kViiГԳg͛7?{wTZZkooqƆn̨ VSS?A3[nEDDHR`T*0`@^^ޓb|ak-annܯkתT/JR6##իÆ y~̘1_}UuuuYY;3a$%%<߿˗/gddxxxh4Qf3fXti}}SjkkgΜ9o޼길_|QID|FIMMxK3f̈}QeeٳjֺMZ3O'@/S''>}lܸ1;;;;;{aaaO:͛[vڕZNKK۾}Y~7n̘1{yK.w4 遁>_|yrr ^~ea'A׮]߿/.--UT]v-**Z o؇z{쫯K/;w.""믿n6??NqFBz|嗿QF]CbUVVDԧO{>3CMMMMMM7n\[3TZpY`AARFqV:[YY={ 5!ZIkftP5ذs-[999=8cǎG]reȐ!SN~dmmhoND¾իWxW⪪/7!!{wﮪR(ݺuS*Z9`ɯJ:{Gf̘1̙3);k֬ӧWVVΙ3]6i͌?{9ݺu+<<\* 9'HBCCsssth+++WW2}{^fȑ#g͚-[?S̙0o޼J὇&{<3y~Ar(AAA1cߟ1csK---6m;v4k&Q rWFm.ׯ_0ÇTPm۶z rD0y6n>}zN~}f, ,!r҉'#ĉmZÆ k ")EGG;vLx?8\+:556 J߿_x}'6o NNN9/͛sK4ꫯ}}}l٢c& L5w܆}g...6m" &QHHHIx 󎯯ͪUa&Тn1 ->{˅꒒nэ]]]jÇ,X0wܪ Pe.^4YbYǘjn&O7ݻ322wQ*G577oq,ܡ@j/sGx=]28y~ܸq\._jÇF"h4ϟ?Oa6' #*SA;C[ZC8fiiM:U*N6mջvjh[V b,c222Th?xѣGw7z\ xRܤZu'-mѝD9v` aSx nٳgUWW$$$c\M&jqLAs.7Y|Zxc]]Ih,ܡp` Yǟ,)A> `:@E<1㋜[Zb:}e|o7Ө) =eT%rIH҆I_8;;geepœYsb4 Obv:/E]ˤ=00bw">zUAL!rR+?| ` rD0F9"}9a&&>J7VD@;H)]}ap` A#` rD02/~"祗^˼Gn8Nk l h 6' WV%Fsӧ'$$[83!1L0V"g„ W\ ?yɓ'Ln0);ӽ{\{{{777f`zّ#GVX1p@!JIIIIII0e'ƐFOŢ2Iگ,$'''%%鸈`}QZ[[. hq]4ut!>էɻQ [@ENbbbbbׯ_~}~vd]&J$-݂0nngR tRXa99992L$q'QDFFVUU]6+++;;{ߟ`)..qㆥ𭿿BBT*e3;FP(F!RRRvfv0K%&&ϳ OOϴ46s2:>x>J˪ rX=R׶7Ϸ؜ң-"1L 2$dG;]qC䀱EUE.)XI*GSY;-ʯtȁaO{uuMWdLJhDD$w #`0<s.X r0:7?d8> Ibϕ-Gί*>])@!r.J:^yDdP=uqoLmr} pgOTޢ[8fdx5 kZ^T~FtuPUSR[m8 r#ha1~ىnc[8@WI3+oE-l]9O'B.ҭuꤑu@ h"ੴ渐}(|&@{I>d r|GZX1 = r G-vL BE@ka` rS"-\TS@X&;DķMRa9nfЧ}lq r>=bȁlj#Xf9"A#`WU B ZɤCi'C&>&2)@!rډ@qR #ˁ=@)-I̲>5U5D4/wIɪg[鷮=Rp}&YMW֓NWu yDZ*LYjՊ+6nkUUUY[[ٳgl ʨrr:atʕ+/^t^|9,,lڴilfC=r \]]bqZZZ޽߿iWZOD_~e``***8,3x`FUPPi$IrrKaaFٰaE#\NNNNjjS8[olٲ~6nahFcee%vvvn4_ n۶-$$Ҳ[h?rJ":y{l̀Dfff lGw}g":t\.?ydO\r]^YY#'$$ڵkJwrrjyaU ~.gɒ%ׯ~zffĉ,Yfƕӫ-C-)9C`J^ΦM6o=~[&''qHL&8daaam+JΐNWBsѾRgq9s$$$qHGGǵk׎1RSSwտ6 a104#ev233m7n4OHHJmIMM5j9r(#FD;w:88qΨ IV-tOdR 99998MZZڴiӖ.]h""H$AAAϟo): Mж]`O{ {mܢyzze0vگX;puFG{⤤$ƥi9qqqƍЎټy36A@~`Zi9&LţGG{9rdޗ.]3gNDDh?T*'Mtȑ]ta\{92lҤI<_|1. LIJJJII5kJzNʸ,0=#gժU555fffyyyfϞ=E?.8~9?r֍8q˗/_Pj">//ёΜ9ӭ[O>ma`jQTjZx]__RI{t=***######::ÃqY`zGNJJ W, s9;v,ji˙?oy ӾGQ@@@C 6SA,xh7obH㓓ø,0=#g$===33S,>qY`z˹sNii-;wNPхDպ(K;ړPUQMnLhg##""o!GL̺;v>00000ѣӣ}/ҥKJ͍qY`z,YݻgΜ޽eeT?]"@ҾiӦ͛7{{{{{{oݺW^Yf LP>LJ푣R>=gΜ%^w_3x`'''e9~~~yyyGa\fцu}iyĸ,0=#֭a\#M{ō7q5`´_>yf"ruql H{ `i?=jmm-S[[KDEEES97o"ǧL2o߾/^h4111m >|D"IOOÇo4 tRzz: i;w;w.00W^Νk^T*1*J~SյqL0.$%%-Xߟ/_fj0##"""++++++**GmfgϞ=sƍ ahHرc#F $=z;v3EDDDDDE"Q|||Cis̙&qrrrRR۷cǎ&EEE]tib֖,Ybkk{3gt}ٲe>qbbN-[D96mڼynݚ̸,0=#GR ̙R8MNNNddL&Dd6 FD{丸 <999vrrj4UUUk׮^~=qo`D_>:j(???"rss;rH)..qㆥ𭿿BBT*m`DGWhLPDEEō1B$ܹh4\tҀ??DZ}y6!о<==^7׿>sɦ o'^Xd3y)utN033T0VVR;;~jii4we?Gﯯ r9;wqvP*۷ saXT rS8:zvE;NϬg/:թ}w7&Ej#yJG۷!:mŊ( k45鎜cTPXXp=^L0}z*&=D돾>8XK DcѺeӳfCotyP3utUU` D/TDDt";NZwϭ^ksJuEEA8gi":ED*u?҈.{Rlme.Aon0R`cS΢E?[7Av5߷o˪@/9бJu||HRRhs**O?̲$XFzq\vvvJGg` IDAT f@AYZJ__gꁎ R`#>5LL:r\Gh}`֬[R/܏eI`L:rWCqd ZI#]ΜɿwOCɮ_/cV ;Dɪܽ,]ZNLSGC=t= "d8p}K>TFRivc ::9&KOX0EEՋ̲$p0Fp` @=R.Xpuqsܰ!UE, rV,l"_}Mwwߍpidfvv:F9S9r\K{[GD/yÇѧJwxbf\g%'_L/=tϢee::ޝ:6cg#ۛ.!r_TkTk0yc::pmokW r ԺuC]@;E"A#` rD0F9"aZ~}5뇂]'ggJ^|=" 6߫>sXFrرgTmLc۶7o/\sҟ)..vwwV\fFvn/ ]̛wA"D..MZ8:ˆ\cωZ<m6$> mAe3{{Çڲ@_w}lF~觹sc<^G}[N[ N&-#o}{y|io,,/YҸE,6ح$}fstˉHlnnxս{ W&-Rkkao1$o~k<-p^pСI۷R^L]WW<`O;{$rN$j2`'7iy|oSINNNJJح[bbkO@@Wf*,yO>xP=~~JKKܹBXeenri˖a. g6Qoܙys;;O)t=m۶-&&#7keoWUyvy"DU[uv\[sfɉxb}}=R488nnnl NˡwӧݾMD{/hGVݻ -a.c"##֮]~zfv0m%%ZeDDQΏ?~5x={W^ڲB "%H nqㆥ𭿿BB='ׯ3l9zG99H|}GHh={l}|n~KxQ%/?yZ޽[df6/89U޻ODtС |#wt..**r ;:$a~"w$=OI@;k=& o׬fM<ϼ>dSS*Iޭz:˟}ve"۷woW 0p[Z!ӌ}To~tf%t*}3w4;$lGiO9^^6)gY=J˃5::\T,qUT:MDyN3~7L{=kjb֯_nFЩGmYYu|y -2fϞE&S@t%%r UDd& -ʲ"jjKJ{)GJ.Û7y{ר˟}&ܘ+\@-ft6hPmyNUܽ#x† Ν{xFIFkTToX:o\^`oo>~zL1eeJ}^=Y=&W>|HD>ƹFEU޻wqӦYY+B|Ə?d_>\ג3ꤑcm-[R?iGVV =#Gr1|С]]k4WUԸ 5ztEE W0[vM.:N9Gy)\ۿm@;??"3wVX*u80r ~G,Rn\1tz4rZd7RShhW"wҰH@ 8$=/\wݓ'K%&jjeYR {9R4S~C8ʇeeي>sCM}}Ckxf92YT;gݫD@*, ^r~#i\.u-anOOU[kfnNDﯫ ";ooAZί[7zNЀi\+@;/M=w]qܵ}J22Hfk; BY^NDXL"=Dʂ۷1_}դ-|5g.ZԏYI` ㏭[/]dԩ7m79!&ŋ~*N;y>0<h:\sro{]eeK/ º `A&s"~j0A__z::<{2=+3TyyrBQB "DҤ"ef?vԩ~:Z;rLFmYY3fٕ+cHHYZn:4fϞk4~X&kO )u]ypV1x4;D!~ @@t B:j48f%#իJ%9NԸk`g_F~^ 'P}~)M1uhҤ))b޽B"ҨT&5nוB:'Gވ(*UZT̤VVe׮zu^&ϑ#MW駍ˉMZx!r ݢEtyKI[wgVғ &`ڴC"yȑ>>6=z–/M@B{T׭}:Tu꒒;))=z1"_N3wYW߹sg7~;'5iS1z_D(o,J%DQp,\ZncĈny=p)'ܟ}v?4 r^.//_Rkׅdi.16DDWx^, [† +Vo ý/ "OV Ep0;wCzʼnD^$Qhby׮:"Ф$~0"''''66ŋ<7RѥK?͝+((.Nh9}Dfb W=3g4iܹsL&-}ukM/\`4HL&8daaalfC(r"##֮]~zfv0߸qaTfv0X}at`---M./]4 /11QVOOϴ46sabF9>B裏vv\I;;8h***tm6[lVڵkWv%4b뵒m~N|ʊ8++Ç zt5gggd2̙3ڱ[IhhzߒxD0br0!rD0F9"A#` rD0F9"A#` rD0h7h] /"""[ xw ƍU&...D$˩с5㢢b>;dT*FADݻw׷@h!3۷=x`ǎ##FL4ƍnnnz(@Op@5~QQQ!bqiiF<7@$j r:H$""{{{"^X,>q<9sFU8J.ki'& =}tqqAO}VrJPX[[?hp `/^0F9"A#` rD0F9"A#` rD0F?n̔D!IENDB`mets/inst/misc/obs/0000755000176200001440000000000013623061405013715 5ustar liggesusersmets/inst/misc/obs/workshop.R0000644000176200001440000001756013623061405015725 0ustar liggesusers ############################### ## installation, R (>=2.12.0) ############################### install.packages("mets") ############################### ## Load simulated data ############################### library(mets) data(prt) ############################### ## Estimation of cumulative incidence ############################### times <- seq(40,100,by=2) cifmod <- comp.risk(Surv(time,status>0)~+1+cluster(id),data=prt,prt$status,causeS=2,n.sim=0, times=times,conservative=1,max.clust=NULL,model="fg") theta.des <- model.matrix(~-1+factor(zyg),data=prt) ## design for MZ/DZ status or1 <- or.cif(cifmod,data=prt,cause1=2,cause2=2,theta.des=theta.des, score.method="fisher.scoring") summary(or1) or1$score pcif <- predict(cifmod,X=1,resample.iid=0,uniform=0,se=0) png(filename="pcif.png") plot(pcif,multiple=1,se=0,uniform=0,ylim=c(0,0.15)) dev.off() ############################### ## Correcting for country ############################### png(filename="pcifl.png") table(prt$country) times <- seq(40,100,by=2) cifmodl <-comp.risk(Surv(time,status>0)~-1+factor(country)+cluster(id),data=prt, prt$status,causeS=2,n.sim=0,times=times,conservative=1, max.clust=NULL,cens.model="aalen") pcifl <- predict(cifmodl,X=diag(4),se=0,uniform=0) plot(pcifl,multiple=1,se=0,uniform=0,col=1:4,ylim=c(0,0.2)) legend("topleft",levels(prt$country),col=1:4,lty=1) dev.off() theta.des <- model.matrix(~-1+factor(zyg),data=prt) ## design for MZ/DZ status or.country <- or.cif(cifmodl,data=prt,cause1=2,cause2=2,theta.des=theta.des, theta=c(2.8,6.9),score.method="fisher.scoring") summary(or.country) cifmodlr <-comp.risk(Surv(time,status>0)~+1+const(factor(country))+cluster(id),data=prt, prt$status,causeS=2,n.sim=0,times=times,conservative=1,max.clust=NULL,model="fg", cens.model="aalen",cens.formula=~~factor(country)) pciflr <- predict(cifmodlr,X=rep(1,4),Z=rbind(c(0,0,0),c(1,0,0),c(0,1,0),c(0,0,1)),se=0,uniform=0) png(filename="pcif2.png") par(mfrow=c(1,2)) plot(pcifl,multiple=1,se=0,uniform=0,col=1:4,ylim=c(0,0.2)) legend("topleft",levels(prt$country),col=1:4,lty=1) plot(pciflr,multiple=1,se=0,uniform=0,col=1:4,ylim=c(0,0.2)) legend("topleft",levels(prt$country),col=1:4,lty=1) dev.off() or.countryr <- or.cif(cifmodlr,data=prt,cause1=2,cause2=2,theta.des=theta.des, theta=c(2.8,6.9),score.method="fisher.scoring") summary(or.countryr) ############################### ## Concordance estimation ############################### ### ignoring country p33 <- bicomprisk(Hist(time,status)~strata(zyg)+id(id),data=prt,cause=c(2,2),return.data=1) p33dz <- p33$model$"DZ"$comp.risk p33mz <- p33$model$"MZ"$comp.risk png(filename="p33dz.png") plot(p33dz,ylim=c(0,0.1)) dev.off() png(filename="pcaconc.png") par(new=TRUE) plot(p33mz,ylim=c(0,0.1),col=3) title(main="Concordance Prostate cancer") lines(pcif$time,pcif$P1^2,col=2) dev.off() ### test for genetic effect conc1 <- p33dz conc2 <- p33mz test.conc(p33dz,p33mz); data33mz <- p33$model$"MZ"$data data33mz$zyg <- 1 data33dz <- p33$model$"DZ"$data data33dz$zyg <- 0 data33 <- rbind(data33mz,data33dz) library(cmprsk) ftime <- data33$time fstatus <- data33$status table(fstatus) group <- data33$zyg graytest <- cuminc(ftime,fstatus,group) graytest zygeffect <- comp.risk(Surv(time,status==0)~const(zyg), data=data33,data33$status,causeS=1, cens.model="aalen",model="logistic",conservative=1) summary(zygeffect) png(filename="casewise.png") case33mz <- conc2case(p33mz,pcif) case33dz <- conc2case(p33dz,pcif) plot(case33mz$casewise,se=0,col=2) par(new=TRUE) plot(case33dz$casewise,se=0) dev.off() ############################### ## Effect of zygosity correcting for country ############################### p33l <- bicomprisk(Hist(time,status)~country+strata(zyg)+id(id), data=prt,cause=c(2,2),return.data=1,robust=1) data33mz <- p33l$model$"MZ"$data data33mz$zyg <- 1 data33dz <- p33l$model$"DZ"$data data33dz$zyg <- 0 data33 <- rbind(data33mz,data33dz) zygeffectl <- comp.risk(Surv(time,status==0)~const(country)+const(zyg), data=data33,data33$status,causeS=1, cens.model="aalen",model="logistic",conservative=1) summary(zygeffectl) zygeffectpl <- comp.risk(Surv(time,status==0)~const(country)+const(zyg), data=data33,data33$status,causeS=1, cens.model="aalen",model="fg",conservative=1) summary(zygeffectpl) zygeffectll <- comp.risk(Surv(time,status==0)~country+const(zyg), data=data33,data33$status,causeS=1, cens.model="aalen",model="logistic",conservative=1) summary(zygeffectll) ############################### ## Liability model, ignoring censoring ############################### (M <- with(prt, table(cancer,zyg))) coef(lm(cancer~-1+zyg,prt)) ## Saturated model bpmz <- biprobit(cancer~1 + cluster(id), data=subset(prt,zyg=="MZ"), eqmarg=TRUE) logLik(bpmz) # Log-likelihood AIC(bpmz) # AIC coef(bpmz) # Parameter estimates vcov(bpmz) # Asymptotic covariance summary(bpmz) # concordance, case-wise, tetrachoric correlations, ... bp0 <- biprobit(cancer~1 + cluster(id)+strata(zyg), data=prt) summary(bp0) ## Eq. marginals MZ/DZ bp1 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="u",data=prt) summary(bp1) # Components (concordance,cor,...) can be extracted from returned list compare(bp0,bp1) # LRT ## Polygenic model args(bptwin) bp2 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="ace",data=prt) summary(bp2) ############################### ## Liability model, IPCW ############################### png(filename="ipw.png") ## Probability weights based on Aalen's additive model prtw <- ipw(Surv(time,status==0)~country, data=prt, cluster="id",weightname="w") plot(0,type="n",xlim=range(prtw$time),ylim=c(0,1),xlab="Age",ylab="Probability") count <- 0 for (l in unique(prtw$country)) { count <- count+1 prtw <- prtw[order(prtw$time),] with(subset(prtw,country==l), lines(time,w,col=count,lwd=2)) } legend("topright",legend=unique(prtw$country),col=1:4,pch=1) dev.off() bpmzIPW <- biprobit(cancer~1 + cluster(id), data=subset(prtw,zyg=="MZ"), weight="w") (smz <- summary(bpmzIPW)) png(filename="cif2.png") ## CIF plot(pcif,multiple=1,se=0,uniform=0,ylim=c(0,0.15)) abline(h=smz$prob["Marginal",],lwd=c(2,1,1)) ## Wrong estimates: abline(h=summary(bpmz)$prob["Marginal",],lwd=c(2,1,1),col="lightgray") dev.off() png(filename="conc2.png") ## Concordance plot(p33mz,ylim=c(0,0.1)) abline(h=smz$prob["Concordance",],lwd=c(2,1,1)) ## Wrong estimates: abline(h=summary(bpmz)$prob["Concordance",],lwd=c(2,1,1),col="lightgray") dev.off() bp3 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id", type="ace",data=prtw,weight="w") summary(bp3) bp4 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id", type="u",data=prtw,weight="w") summary(bp4) score(bp4) ## Check convergence bp5 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id", type="ade",data=prtw,weight="w") summary(bp5) ############################### ## Adjusting for covariates ############################### bp6 <- bptwin(cancer~country,zyg="zyg",DZ="DZ",id="id", type="ace",data=prtw,weight="w") summary(bp6) bp7 <- bptwin(cancer~country,zyg="zyg",DZ="DZ",id="id", type="u",data=prtw,weight="w") summary(bp7) bp8 <- bptwin(cancer~strata(country),zyg="zyg",DZ="DZ",id="id", type="u",data=prtw,weight="w") summary(bp8) ## Wald test B <- (lava::contrmat(3,4))[-(1:3),] compare(bp8,contrast=B) ############################### ## Cumulative heritability ############################### args(cumh) ch1 <- cumh(cancer~1,time="time",zyg="zyg",DZ="DZ",id="id", type="ace",data=prtw,weight="w") #+BEGIN_SRC R summary(ch1) png(filename="cumh.png") plot(ch1) dev.off() mets/inst/misc/obs/workshop-ts.R0000644000176200001440000002341013623061405016340 0ustar liggesusers ############################### ## installation, R (>=2.12.0) ############################### ###install.packages("mets") ############################### ## Load simulated data ############################### library(mets) data(prt) ############################### ## Estimation of cumulative incidence ############################### times <- seq(40,100,by=2) cifmod <- comp.risk(Surv(time,status>0)~+1+cluster(id),data=prt,prt$status,causeS=2,n.sim=0, times=times,conservative=1,max.clust=NULL,model="fg") theta.des <- model.matrix(~-1+factor(zyg),data=prt) ## design for MZ/DZ status or1 <- mets::or.cif(cifmod,data=prt,cause1=2,cause2=2,theta.des=theta.des,same.cens=TRUE, score.method="fisher.scoring") summary(or1) or1$score rr1<-mets::rr.cif(cifmod,data=prt,cause1=2,cause2=2,theta.des=theta.des,same.cens=TRUE,score.method="fisher.scoring") summary(rr1) pcif <- predict(cifmod,X=1,resample.iid=1,uniform=0,se=1) png(filename="pcif.png") plot(pcif,multiple=1,se=0,uniform=0,ylim=c(0,0.15)) abline(h=0.10143) abline(h=0.1105) dev.off() cifmodzyg <- comp.risk(Surv(time,status>0)~-1+factor(zyg)+cluster(id), data=prt,prt$status,causeS=2,n.sim=0,cens.model="aalen", times=times,conservative=1,max.clust=NULL,model="additive") pcifzyg <- predict(cifmodzyg,X=diag(2),resample.iid=0,uniform=0,se=0) plot(pcifzyg,multiple=1,se=0,uniform=0,ylim=c(0,0.15)) abline(h=0.10143) abline(h=0.1105) out <- prodlim(Hist(time,status)~zyg,data=prt) poutmz <- predict(out,cause=2,time=times,newdata=data.frame(zyg="MZ")) poutdz <- predict(out,cause=2,time=times,newdata=data.frame(zyg="DZ")) ###plot(out,cause=2,ylim=c(0,0.15),confInt=FALSE) lines(times,poutmz,type="s",col=2) lines(times,poutdz,type="s",col=2) ###lines(times,c(pcifzyg$P1[1,]),col=4) ###lines(times,c(pcifzyg$P1[2,]),col=4) ############################### ## Correcting for country ############################### png(filename="pcifl.png") table(prt$country) times <- seq(40,100,by=2) cifmodl <-comp.risk(Surv(time,status>0)~-1+factor(country)+cluster(id),data=prt, prt$status,causeS=2,n.sim=0,times=times,conservative=1, max.clust=NULL,cens.model="aalen") pcifl <- predict(cifmodl,X=diag(4),se=0,uniform=0) plot(pcifl,multiple=1,se=0,uniform=0,col=1:4,ylim=c(0,0.2)) legend("topleft",levels(prt$country),col=1:4,lty=1) dev.off() theta.des <- model.matrix(~-1+factor(zyg),data=prt) ## design for MZ/DZ status or.country <- or.cif(cifmodl,data=prt,cause1=2,cause2=2,theta.des=theta.des,same.cens=TRUE, theta=c(0.8,1.8),score.method="fisher.scoring",detail=1) summary(or.country) or.country$score cifmodlr <-comp.risk(Surv(time,status>0)~+1+const(factor(country))+cluster(id),data=prt, prt$status,causeS=2,n.sim=0,times=times,conservative=1,max.clust=NULL,model="fg", cens.model="aalen",cens.formula=~~factor(country)) pciflr <- predict(cifmodlr,X=rep(1,4),Z=rbind(c(0,0,0),c(1,0,0),c(0,1,0),c(0,0,1)),se=0,uniform=0) png(filename="pcif2.png") par(mfrow=c(1,2)) plot(pcifl,multiple=1,se=0,uniform=0,col=1:4,ylim=c(0,0.2)) legend("topleft",levels(prt$country),col=1:4,lty=1) plot(pciflr,multiple=1,se=0,uniform=0,col=1:4,ylim=c(0,0.2)) legend("topleft",levels(prt$country),col=1:4,lty=1) dev.off() or.countryr <- or.cif(cifmodlr,data=prt,cause1=2,cause2=2,theta.des=theta.des,same.cens=TRUE, theta=c(0.8,1.9),score.method="fisher.scoring") summary(or.countryr) ############################### ## Concordance estimation ############################### ### ignoring country p33 <- bicomprisk(Hist(time,status)~strata(zyg)+id(id),data=prt,cause=c(2,2),return.data=1,robust=1) p33dz <- p33$model$"DZ"$comp.risk p33mz <- p33$model$"MZ"$comp.risk png(filename="p33dz.png") plot(p33dz,se=0,ylim=c(0,0.1)) lines(p33mz$time,p33mz$P1,col=3) title(main="Concordance Prostate cancer") lines(pcif$time,pcif$P1^2,col=2) ### test for genetic effect legend("topleft",c("DZ","MZ","Independence"),lty=rep(1,3),col=c(1,3,2)) dev.off() ### test for genetic effect test.conc(p33dz,p33mz); data33mz <- p33$model$"MZ"$data data33mz$zyg <- "MZ" data33dz <- p33$model$"DZ"$data data33dz$zyg <- "DZ" data33 <- rbind(data33mz,data33dz) data33$zyg <- factor(data33$zyg) library(cmprsk) ftime <- data33$time fstatus <- data33$status table(fstatus) group <- data33$zyg graytest <- cuminc(ftime,fstatus,group) graytest zygeffect <- comp.risk(Surv(time,status==0)~const(zyg), data=data33,data33$status,causeS=1, cens.model="aalen",model="logistic",conservative=1) summary(zygeffect) case33mz <- conc2probandwise(p33mz,pcif) case33dz <- conc2probandwise(p33dz,pcif) png(filename="casewise.png") plot(case33mz$probandwise,se=0,col=3) lines(case33dz$probandwise$time,case33dz$probandwise$P1) title(main="Probandwise concordance") legend("topleft",c("MZ","DZ","Independence"),lty=rep(1,3),col=c(3,1,2)) lines(pcif$time,pcif$P1,col=2) dev.off() ############################### ## Effect of zygosity correcting for country ############################### p33l <- bicomprisk(Hist(time,status)~country+strata(zyg)+id(id), data=prt,cause=c(2,2),return.data=1,robust=1) data33mz <- p33l$model$"MZ"$data data33mz$zyg <- 1 data33dz <- p33l$model$"DZ"$data data33dz$zyg <- 0 data33 <- rbind(data33mz,data33dz) zygeffectl <- comp.risk(Surv(time,status==0)~const(country)+const(zyg), data=data33,data33$status,causeS=1, cens.model="aalen",model="logistic",conservative=1) summary(zygeffectl) zygeffectpl <- comp.risk(Surv(time,status==0)~const(country)+const(zyg), data=data33,data33$status,causeS=1, cens.model="aalen",model="fg",conservative=1) summary(zygeffectpl) zygeffectll <- comp.risk(Surv(time,status==0)~country+const(zyg), data=data33,data33$status,causeS=1, cens.model="aalen",model="logistic",conservative=1) summary(zygeffectll) ############################### ## Liability model, ignoring censoring ############################### (M <- with(prt, table(cancer,zyg))) coef(lm(cancer~-1+zyg,prt)) ## Saturated model bpmz <- biprobit(cancer~1 + cluster(id), data=subset(prt,zyg=="MZ"), eqmarg=TRUE) logLik(bpmz) # Log-likelihood AIC(bpmz) # AIC coef(bpmz) # Parameter estimates vcov(bpmz) # Asymptotic covariance summary(bpmz) # concordance, case-wise, tetrachoric correlations, ... bp0 <- biprobit(cancer~1 + cluster(id)+strata(zyg), data=prt) summary(bp0) ## Eq. marginals MZ/DZ bp1 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="u",data=prt) summary(bp1) # Components (concordance,cor,...) can be extracted from returned list compare(bp0,bp1) # LRT ## Polygenic model args(bptwin) bp2 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="ace",data=prt) summary(bp2) ############################### ## Liability model, IPCW ############################### png(filename="ipw.png") ## Probability weights based on Aalen's additive model prtw <- ipw(Surv(time,status==0)~zyg, data=prt, cluster="id",weightname="w") plot(0,type="n",xlim=range(prtw$time),ylim=c(0,1),xlab="Age",ylab="Probability") count <- 0 for (l in unique(prtw$country)) { count <- count+1 prtw <- prtw[order(prtw$time),] with(subset(prtw,country==l), lines(time,w,col=count,lwd=2)) } legend("topright",legend=unique(prtw$country),col=1:4,pch=1) dev.off() bpmzIPW <- biprobit(cancer~1 + cluster(id), data=subset(prtw,zyg=="MZ"), weight="w") (smz <- summary(bpmzIPW)) bpdzIPW <- biprobit(cancer~1 + cluster(id), data=subset(prtw,zyg=="DZ"), weight="w") (sdz <- summary(bpdzIPW)) abline(h=0.495) abline(h=0.21) png(filename="cif2.png") ## CIF plot(pcif,multiple=1,se=0,uniform=0,ylim=c(0,0.15)) abline(h=smz$prob["Marginal",],lwd=c(2,1,1)) ## Wrong estimates: abline(h=summary(bpmz)$prob["Marginal",],lwd=c(2,1,1),col="lightgray") dev.off() png(filename="conc2.png") ## Concordance plot(p33mz,ylim=c(0,0.1)) abline(h=smz$prob["Concordance",],lwd=c(2,1,1)) ## Wrong estimates: abline(h=summary(bpmz)$prob["Concordance",],lwd=c(2,1,1),col="lightgray") dev.off() bp3 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id", type="ace",data=prtw,weight="w") summary(bp3) bp4 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id", type="u",data=prtw,weight="w") summary(bp4) score(bp4) ## Check convergence bp5 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id", type="ade",data=prtw,weight="w") summary(bp5) ############################### ## Adjusting for covariates ############################### bp6 <- bptwin(cancer~country,zyg="zyg",DZ="DZ",id="id", type="ace",data=prtw,weight="w") summary(bp6) bp7 <- bptwin(cancer~country,zyg="zyg",DZ="DZ",id="id", type="u",data=prtw,weight="w") summary(bp7) bp8 <- bptwin(cancer~strata(country),zyg="zyg",DZ="DZ",id="id", type="u",data=prtw,weight="w") summary(bp8) ## Wald test B <- (lava::contrmat(3,4))[-(1:3),] compare(bp8,contrast=B) ############################### ## Cumulative heritability ############################### args(cumh) ch1 <- cumh(cancer~1,time="time",zyg="zyg",DZ="DZ",id="id", type="ace",data=prtw,weight="w") #+BEGIN_SRC R summary(ch1) png(filename="cumh.png") plot(ch1) dev.off() parfunc <- function(par,t,pardes) { par <- pardes %*% c(par[1],par[2]) + pardes %*% c( par[3]*(t-60)/12,par[4]*(t-60)/12) par } ###parfunc(c(0.1,1,0.1,1),50,theta.des) names(prt) theta.des <- model.matrix(~-1+factor(zyg),data=prt) cor1 <- or.cif(cifmod,data=prt,cause1=2,cause2=2,theta.des=theta.des,same.cens=TRUE, score.method="fisher.scoring",detail=1) summary(cor1) corl <- or.cif(cifmod,data=prt,cause1=2,cause2=2,theta.des=theta.des,same.cens=TRUE, par.func=parfunc,dimpar=4,control=list(trace=TRUE),detail=1) summary(corl) corl$score mets/inst/misc/obs/workshop.org0000644000176200001440000011036513623061405016310 0ustar liggesusers#+BEGIN_OPTIONS #+TITLE: Analyzing twin data with =mets= #+AUTHOR: Klaus K. Holst and Thomas Scheike #+DATE: <2012-05-20 Sun> #+PROPERTY: session *R* #+PROPERTY: cache yes #+PROPERTY: results output graphics #+PROPERTY: exports both #+PROPERTY: tangle yes #+STYLE: #+PROPERTY: tangle yes #+STARTUP: hideall #+OPTIONS: LaTeX:dvipng #+END_OPTIONS * Installation Set repositories (see also =chooseCRANmirror=, =chooseBioCmirror=) and install dependencies (=R= >=2.14) #+BEGIN_SRC R :exports none ############################### ## installation, R (>=2.14.0) ############################### palette(c("darkblue","darkred","orange","olivedrab")) #+END_SRC #+RESULTS[8a346c56f83ba895a925ff381d944f947cfd8cbe]: #+BEGIN_SRC R :exports code :eval never setRepositories() ## Choose CRAN and BioC Software (BioConductor) install.packages(c("mets","cmprsk")) #+END_SRC /OBS:/ At this point you might have to restart =R= to flush the cache of previously installed versions of the packages. If you have previously installed =timereg= and =lava=, make sure that you have the current versions installed (timereg: 1.6-5, lava: 1.0-5). * Load simulated data #+BEGIN_SRC R :exports none ############################### ## Load simulated data ############################### #+END_SRC #+RESULTS[02928e5bb0859e535f0f8436a7abb6f99589a14e]: #+NAME: Loading #+BEGIN_SRC R :exports code library(mets) data(prt) #+END_SRC #+RESULTS[1ac5ae8cf61c58ca9af113b15b7f062dfb3d7162]: Loading * Estimation of cumulative incidence #+BEGIN_SRC R :exports none ############################### ## Estimation of cumulative incidence ############################### #+END_SRC #+RESULTS[f112f393258523a6017aec5f028f0ca868ae8d18]: #+BEGIN_SRC R times <- seq(60,100,by=1) cifmod <- comp.risk(Surv(time,status>0)~+1+cluster(id),data=prt,prt$status,causeS=2,n.sim=0, times=times,conservative=1,max.clust=NULL,model="fg") theta.des <- model.matrix(~-1+factor(zyg),data=prt) ## design for MZ/DZ status or1 <- or.cif(cifmod,data=prt,cause1=2,cause2=2,theta.des=theta.des,same.cens=TRUE, score.method="fisher.scoring") summary(or1) or1$score pcif <- predict(cifmod,X=1,resample.iid=0,uniform=0,se=0) #+END_SRC #+RESULTS[0f9f1d6f4e42e90ca88a1113a01098f8319c1283]: : OR for dependence for competing risks : : OR of cumulative incidence for cause1= 2 and cause2= 2 : log-ratio Coef. SE z P-val Ratio SE : factor(zyg)DZ 0.80 0.111 7.23 4.86e-13 2.22 0.246 : factor(zyg)MZ 2.09 0.138 15.10 0.00e+00 8.07 1.110 : [,1] : [1,] 1.325225e-06 : [2,] 3.458932e-06 #+BEGIN_SRC R :file pcif.png plot(pcif,multiple=1,se=0,uniform=0,ylim=c(0,0.15)) #+END_SRC #+RESULTS[5234604eb50e009ef23083db3cbabd66084b3ad0]: [[file:pcif.png]] * Correcting for country #+BEGIN_SRC R :exports none ############################### ## Correcting for country ############################### #+END_SRC #+RESULTS[68c4a7cd657ebc513b8b06ca5e33d302d5860d52]: #+BEGIN_SRC R :file pcifl.png table(prt$country) times <- seq(60,100,by=1) cifmodl <-comp.risk(Surv(time,status>0)~-1+factor(country)+cluster(id),data=prt, prt$status,causeS=2,n.sim=0,times=times,conservative=1, max.clust=NULL,cens.model="aalen") pcifl <- predict(cifmodl,X=diag(4),se=0,uniform=0) plot(pcifl,multiple=1,se=0,uniform=0,col=1:4,ylim=c(0,0.2)) legend("topleft",levels(prt$country),col=1:4,lty=1) #+END_SRC #+RESULTS[3a9565317ffa0ac815d0b8676a289da2d10572ea]: [[file:pcifl.png]] #+BEGIN_SRC R theta.des <- model.matrix(~-1+factor(zyg),data=prt) ## design for MZ/DZ status or.country <- or.cif(cifmodl,data=prt,cause1=2,cause2=2,theta.des=theta.des,same.cens=TRUE, theta=c(2.8,6.9),score.method="fisher.scoring") summary(or.country) or.country$score #+END_SRC #+RESULTS[7b0909e7376f0bc518fa09900d0faa5504b4eb35]: : OR for dependence for competing risks : : OR of cumulative incidence for cause1= 2 and cause2= 2 : log-ratio Coef. SE z P-val Ratio SE : factor(zyg)DZ 0.754 0.117 6.43 1.26e-10 2.12 0.249 : factor(zyg)MZ 1.850 0.139 13.30 0.00e+00 6.36 0.883 : [,1] : [1,] -1.201999e-06 : [2,] 1.558011e-06 #+BEGIN_SRC R cifmodlr <-comp.risk(Surv(time,status>0)~+1+const(factor(country))+cluster(id),data=prt, prt$status,causeS=2,n.sim=0,times=times,conservative=1,max.clust=NULL,model="fg", cens.model="aalen",cens.formula=~~factor(country)) pciflr <- predict(cifmodlr,X=rep(1,4),Z=rbind(c(0,0,0),c(1,0,0),c(0,1,0),c(0,0,1)),se=0,uniform=0) #+END_SRC #+RESULTS[b70ab6a063342157649738da4117457be713c6ca]: #+BEGIN_SRC R :file pcif2.png par(mfrow=c(1,2)) plot(pcifl,multiple=1,se=0,uniform=0,col=1:4,ylim=c(0,0.2)) legend("topleft",levels(prt$country),col=1:4,lty=1) plot(pciflr,multiple=1,se=0,uniform=0,col=1:4,ylim=c(0,0.2)) legend("topleft",levels(prt$country),col=1:4,lty=1) #+END_SRC #+RESULTS[4e97b31907acfbd4f8064533912000ddedda8680]: [[file:pcif2.png]] #+BEGIN_SRC R or.countryr <- or.cif(cifmodlr,data=prt,cause1=2,cause2=2,theta.des=theta.des,same.cens=TRUE, theta=c(2.8,6.9),score.method="fisher.scoring") summary(or.countryr) #+END_SRC #+RESULTS[4d66db4836791d64d433bd93abfcb00959618d03]: : OR for dependence for competing risks : : OR of cumulative incidence for cause1= 2 and cause2= 2 : log-ratio Coef. SE z P-val Ratio SE : factor(zyg)DZ 0.756 0.117 6.48 9.33e-11 2.13 0.249 : factor(zyg)MZ 1.850 0.139 13.40 0.00e+00 6.38 0.886 * Concordance estimation #+BEGIN_SRC R :exports none ############################### ## Concordance estimation ############################### #+END_SRC #+RESULTS[427cc15fc9e022294eb2043a773da04da8e82118]: #+BEGIN_SRC R :exports code ### ignoring country p33 <- bicomprisk(Hist(time,status)~strata(zyg)+id(id),data=prt,cause=c(2,2),return.data=1,robust=1) p33dz <- p33$model$"DZ"$comp.risk p33mz <- p33$model$"MZ"$comp.risk #+END_SRC #+RESULTS[8932fd1ccf114ddeeeb0391df5ca2ba75cb4c370]: : Strata 'DZ' : Strata 'MZ' #+BEGIN_SRC R :file p33dz.png plot(p33dz,se=0,ylim=c(0,0.1)) lines(p33mz$time,p33mz$P1,col=3) title(main="Concordance Prostate cancer") lines(pcif$time,pcif$P1^2,col=2) legend("topleft",c("DZ","MZ","Independence"),lty=rep(1,3),col=c(1,3,2)) #+END_SRC #+RESULTS[b9596e1acca186c1bee1349b9b05b9977fb5ef50]: [[file:p33dz.png]] #+BEGIN_SRC R ### test for genetic effect test.conc(p33dz,p33mz); #+END_SRC #+RESULTS[9c9ec963fc3e9462696c88b0009dab02aa5f614b]: : : Pepe-Mori type test for H_0: conc_1(t)= conc_2(t) : Assuming independence for estimators : Time.range = 60.9 -- 96.9 : : cum dif. sd z pval : pepe-mori 0.394 0.095 4.15 3.39e-05 #+BEGIN_SRC R data33mz <- p33$model$"MZ"$data data33mz$zyg <- 1 data33dz <- p33$model$"DZ"$data data33dz$zyg <- 0 data33 <- rbind(data33mz,data33dz) library(cmprsk) ftime <- data33$time fstatus <- data33$status table(fstatus) #+END_SRC #+RESULTS[628462f3bd06049b27328dc94b008d294734ae03]: : fstatus : 0 1 2 : 9597 106 4519 #+BEGIN_SRC R group <- data33$zyg graytest <- cuminc(ftime,fstatus,group) graytest #+END_SRC #+RESULTS[26895e594e7441d7fe558b95a48a3e51d1fba2ae]: #+begin_example Tests: stat pv df 1 28.82416 7.925617e-08 1 2 33.79236 6.131919e-09 1 Estimates and Variances: $est 20 40 60 80 100 0 1 0.0000000000 0.00000000 0.0001741916 0.006741025 0.01880244 1 1 0.0000000000 0.00000000 0.0006710172 0.017420360 0.05031415 0 2 0.0006970762 0.01974882 0.1141800067 0.504364854 0.93797293 1 2 0.0009363302 0.01655314 0.0948098327 0.443996722 0.90692430 $var 20 40 60 80 100 0 1 0.000000e+00 0.000000e+00 3.034323e-08 2.115863e-06 9.493584e-06 1 1 0.000000e+00 0.000000e+00 2.250627e-07 9.173278e-06 5.102841e-05 0 2 8.094463e-08 2.487399e-06 1.556735e-05 6.990685e-05 4.769058e-05 1 2 1.752378e-07 3.424511e-06 2.388136e-05 1.271394e-04 1.171775e-04 #+end_example #+BEGIN_SRC R zygeffect <- comp.risk(Surv(time,status==0)~const(zyg), data=data33,data33$status,causeS=1, cens.model="aalen",model="logistic",conservative=1) summary(zygeffect) #+END_SRC #+RESULTS[9558b1e3ed54d186ed8d2737a0b224b1c1e0cfa1]: #+begin_example Competing risks Model Test for nonparametric terms Test for non-significant effects Supremum-test of significance p-value H_0: B(t)=0 (Intercept) 25.5 0 Test for time invariant effects Kolmogorov-Smirnov test p-value H_0:constant effect (Intercept) 2.23 0 Cramer von Mises test p-value H_0:constant effect (Intercept) 36.2 0 Parametric terms : Coef. SE Robust SE z P-val const(zyg) 0.977 0.22 0.22 4.44 9.06e-06 Call: comp.risk(Surv(time, status == 0) ~ const(zyg), data = data33, data33$status, causeS = 1, cens.model = "aalen", model = "logistic", conservative = 1) #+end_example #+BEGIN_SRC R :file casewise.png :exports both case33mz <- conc2case(p33mz,pcif) case33dz <- conc2case(p33dz,pcif) plot(case33mz$casewise,se=0,col=3) lines(case33dz$casewise$time,case33dz$casewise$P1) title(main="Probandwise concordance") legend("topleft",c("MZ","DZ","Independence"),lty=rep(1,3),col=c(3,1,2)) lines(pcif$time,pcif$P1,col=2) #+END_SRC #+RESULTS[e1f3cb818ffe61c18faaa163b47bb44042dac3e2]: [[file:casewise.png]] * Effect of zygosity correcting for country #+BEGIN_SRC R :exports none ############################### ## Effect of zygosity correcting for country ############################### #+END_SRC #+RESULTS[62c9e498baa4832188df750124c66a5a4c62ca39]: #+BEGIN_SRC R :exports code p33l <- bicomprisk(Hist(time,status)~country+strata(zyg)+id(id), data=prt,cause=c(2,2),return.data=1,robust=1) data33mz <- p33l$model$"MZ"$data data33mz$zyg <- 1 data33dz <- p33l$model$"DZ"$data data33dz$zyg <- 0 data33 <- rbind(data33mz,data33dz) #+END_SRC #+RESULTS[57f0018902fc7413874798338801d0f077e6c1ff]: : Strata 'DZ' : Strata 'MZ' #+BEGIN_SRC R zygeffectl <- comp.risk(Surv(time,status==0)~const(country)+const(zyg), data=data33,data33$status,causeS=1, cens.model="aalen",model="logistic",conservative=1) summary(zygeffectl) #+END_SRC #+RESULTS[546357a033b899af074a09ad8835de2dbcaa1797]: #+begin_example Competing risks Model Test for nonparametric terms Test for non-significant effects Supremum-test of significance p-value H_0: B(t)=0 (Intercept) 16.1 0 Test for time invariant effects Kolmogorov-Smirnov test p-value H_0:constant effect (Intercept) 2.01 0 Cramer von Mises test p-value H_0:constant effect (Intercept) 35.9 0 Parametric terms : Coef. SE Robust SE z P-val const(country)Finland 1.160 0.419 0.419 2.77 5.54e-03 const(country)Norway 0.655 0.458 0.458 1.43 1.53e-01 const(country)Sweden 0.796 0.372 0.372 2.14 3.23e-02 const(zyg) 0.932 0.230 0.230 4.05 5.15e-05 Call: comp.risk(Surv(time, status == 0) ~ const(country) + const(zyg), data = data33, data33$status, causeS = 1, cens.model = "aalen", model = "logistic", conservative = 1) #+end_example #+BEGIN_SRC R :exports code zygeffectpl <- comp.risk(Surv(time,status==0)~const(country)+const(zyg), data=data33,data33$status,causeS=1, cens.model="aalen",model="fg",conservative=1) #+END_SRC #+RESULTS[d08e50b4d5eccd70aa13799712a5300b532b7f5d]: #+BEGIN_SRC R print(summary(zygeffectpl)) #+END_SRC #+RESULTS[ce1c35673b56773ca49a2eb7e8a834094e7bbe6e]: #+begin_example Competing risks Model Test for nonparametric terms Test for non-significant effects Supremum-test of significance p-value H_0: B(t)=0 (Intercept) 2.83 0.012 Test for time invariant effects Kolmogorov-Smirnov test p-value H_0:constant effect (Intercept) 0.0101 0 Cramer von Mises test p-value H_0:constant effect (Intercept) 0.00115 0.004 Parametric terms : Coef. SE Robust SE z P-val const(country)Finland 1.140 0.412 0.412 2.77 5.63e-03 const(country)Norway 0.646 0.452 0.452 1.43 1.53e-01 const(country)Sweden 0.785 0.368 0.368 2.14 3.27e-02 const(zyg) 0.916 0.226 0.226 4.05 5.22e-05 Call: comp.risk(Surv(time, status == 0) ~ const(country) + const(zyg), data = data33, data33$status, causeS = 1, cens.model = "aalen", model = "fg", conservative = 1) NULL #+end_example #+BEGIN_SRC R zygeffectll <- comp.risk(Surv(time,status==0)~country+const(zyg), data=data33,data33$status,causeS=1, cens.model="aalen",model="logistic",conservative=1) #+END_SRC #+RESULTS[88eb5af960d328e425fca7e530c12ff3050dbb52]: #+BEGIN_SRC R print(summary(zygeffectll)) #+END_SRC #+RESULTS[5c4d614a2569c779d468a0ea4dfaee563e37f976]: #+begin_example Competing risks Model Test for nonparametric terms Test for non-significant effects Supremum-test of significance p-value H_0: B(t)=0 (Intercept) 75.70 0 countryFinland 441.00 0 countryNorway 6.09 0 countrySweden 703.00 0 Test for time invariant effects Kolmogorov-Smirnov test p-value H_0:constant effect (Intercept) 6.59 0.000 countryFinland 6.24 0.000 countryNorway 1.31 0.574 countrySweden 6.39 0.000 Cramer von Mises test p-value H_0:constant effect (Intercept) 200.0 0.0 countryFinland 1180.0 0.0 countryNorway 17.6 0.4 countrySweden 1300.0 0.0 Parametric terms : Coef. SE Robust SE z P-val const(zyg) 0.939 0.23 0.23 4.08 4.58e-05 WARNING problem with convergence for time points: 64.88587 66.74123 Readjust analyses by removing points Call: comp.risk(Surv(time, status == 0) ~ country + const(zyg), data = data33, data33$status, causeS = 1, cens.model = "aalen", model = "logistic", conservative = 1) NULL #+end_example * Liability model, ignoring censoring #+BEGIN_SRC R :exports none ############################### ## Liability model, ignoring censoring ############################### #+END_SRC #+RESULTS[79d6ea3c279ccbefe06219e2e93330dd564c8160]: #+BEGIN_SRC R (M <- with(prt, table(cancer,zyg))) #+END_SRC #+RESULTS[e2894667fe2c2fb9593c7184f9069f9ff4c27ae7]: : zyg : cancer DZ MZ : 0 17408 10872 : 1 583 359 #+BEGIN_SRC R coef(lm(cancer~-1+zyg,prt)) #+END_SRC #+RESULTS[1fc2a1cec8eed946e93f4499c5bd2ce40cb55c4b]: : zygDZ zygMZ : 0.03240509 0.03196510 #+BEGIN_SRC R ## Saturated model bpmz <- biprobit(cancer~1 + cluster(id), data=subset(prt,zyg=="MZ"), eqmarg=TRUE) logLik(bpmz) # Log-likelihood AIC(bpmz) # AIC coef(bpmz) # Parameter estimates vcov(bpmz) # Asymptotic covariance summary(bpmz) # concordance, case-wise, tetrachoric correlations, ... #+END_SRC R #+RESULTS[31dc25d5c08cc8e94c02d636645330df4012d49b]: #+begin_example 'log Lik.' -1472.972 (df=2) [1] 2949.943 (Intercept) atanh(rho) -1.8539454 0.8756506 (Intercept) atanh(rho) (Intercept) 0.0007089726 0.0003033296 atanh(rho) 0.0003033296 0.0044023587 Estimate Std.Err Z p-value (Intercept) -1.853945 0.026627 -69.627727 0 atanh(rho) 0.875651 0.066350 13.197393 0 n pairs 11231 5473 Score: -3.453e-05 5.123e-06 logLik: -1472.972 Variance of latent residual term = 1 (standard probit link) Estimate 2.5% 97.5% Tetrachoric correlation 0.70423 0.63252 0.76398 Concordance 0.01131 0.00886 0.01443 Case-wise/Conditional 0.35487 0.29391 0.42094 Marginal 0.03187 0.02834 0.03583 #+end_example #+BEGIN_SRC R :exports code bp0 <- biprobit(cancer~1 + cluster(id)+strata(zyg), data=prt) #+END_SRC #+RESULTS[cba00830834c35f753cf4cf64b245caf08303a97]: : Strata 'DZ' : Strata 'MZ' #+BEGIN_SRC R summary(bp0) #+END_SRC #+RESULTS[e5e3737a364b026de5dbf414098405e10fc58c7a]: #+begin_example ------------------------------------------------------------ Strata 'DZ' Estimate Std.Err Z p-value (Intercept) -1.846841 0.019247 -95.955243 0 atanh(rho) 0.418065 0.050421 8.291446 0 n pairs 17991 8749 Score: -0.001841 -0.0006879 logLik: -2536.242 Variance of latent residual term = 1 (standard probit link) Estimate 2.5% 97.5% Tetrachoric correlation 0.39530 0.30882 0.47529 Concordance 0.00486 0.00361 0.00655 Case-wise/Conditional 0.15019 0.11459 0.19443 Marginal 0.03239 0.02976 0.03523 ------------------------------------------------------------ Strata 'MZ' Estimate Std.Err Z p-value (Intercept) -1.853945 0.026627 -69.627727 0 atanh(rho) 0.875651 0.066350 13.197393 0 n pairs 11231 5473 Score: -3.453e-05 5.123e-06 logLik: -1472.972 Variance of latent residual term = 1 (standard probit link) Estimate 2.5% 97.5% Tetrachoric correlation 0.70423 0.63252 0.76398 Concordance 0.01131 0.00886 0.01443 Case-wise/Conditional 0.35487 0.29391 0.42094 Marginal 0.03187 0.02834 0.03583 #+end_example #+BEGIN_SRC R ## Eq. marginals MZ/DZ bp1 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="u",data=prt) summary(bp1) # Components (concordance,cor,...) can be extracted from returned list #+END_SRC #+RESULTS[cf616c979a103f0ee27e572ddbb94cb56851bdf4]: #+begin_example Estimate Std.Err Z p-value (Intercept) -1.849284 0.015601 -118.539777 0 atanh(rho) MZ 0.877667 0.065815 13.335456 0 atanh(rho) DZ 0.417475 0.050276 8.303615 0 Total MZ/DZ Complete pairs MZ/DZ 11231/17991 5473/8749 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.70525 0.63436 0.76438 Tetrachoric correlation DZ 0.39480 0.30854 0.47462 MZ: Estimate 2.5% 97.5% Concordance 0.01149 0.00942 0.01400 Probandwise Concordance 0.35672 0.29764 0.42049 Marginal 0.03221 0.03007 0.03449 DZ: Estimate 2.5% 97.5% Concordance 0.00482 0.00363 0.00640 Probandwise Concordance 0.14956 0.11441 0.19315 Marginal 0.03221 0.03007 0.03449 Estimate 2.5% 97.5% Broad-sense Heritability 0.62090 0.40145 0.79997 #+end_example #+BEGIN_SRC R compare(bp0,bp1) # LRT #+END_SRC #+RESULTS[20e744f4568946d8acc1da67d03b4fd25a9e4707]: : : Likelihood ratio test : : data: : chisq = 0.0468, df = 1, p-value = 0.8288 : sample estimates: : log likelihood (model 1) log likelihood (model 2) : -4009.213 -4009.237 Polygenic Libability model via te =bptwin= function (=type= can be a subset of "acde", or "flex" for stratitified, "u" for random effects model with same marginals for MZ and DZ) #+BEGIN_SRC R ## Polygenic model args(bptwin) #+END_SRC R #+RESULTS[881d9a46f5fc9fcf8680ea466e5be3dd178d7ffc]: : function (formula, data, id, zyg, DZ, OS, weight = NULL, biweight = function(x) 1/min(x), : strata = NULL, messages = 1, control = list(trace = 0), type = "ace", : eqmean = TRUE, pairsonly = FALSE, samecens = TRUE, allmarg = samecens & : !is.null(weight), stderr = TRUE, robustvar = TRUE, p, : indiv = FALSE, constrain, bound = FALSE, debug = FALSE, ...) : NULL #+BEGIN_SRC R bp2 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="ace",data=prt) summary(bp2) #+END_SRC #+RESULTS[457676d0740f60ff891c1d4eea5db64387cd72bc]: #+begin_example Estimate Std.Err Z p-value (Intercept) -3.40624 0.19032 -17.89736 0.0000 log(var(A)) 0.74503 0.25710 2.89787 0.0038 log(var(C)) -1.25112 1.04238 -1.20024 0.2300 Total MZ/DZ Complete pairs MZ/DZ 11231/17991 5473/8749 Estimate 2.5% 97.5% A 0.62090 0.40145 0.79997 C 0.08435 0.00910 0.48028 E 0.29475 0.23428 0.36343 MZ Tetrachoric Cor 0.70525 0.63436 0.76438 DZ Tetrachoric Cor 0.39480 0.30854 0.47462 MZ: Estimate 2.5% 97.5% Concordance 0.01149 0.00942 0.01400 Probandwise Concordance 0.35672 0.29764 0.42049 Marginal 0.03221 0.03007 0.03449 DZ: Estimate 2.5% 97.5% Concordance 0.00482 0.00363 0.00640 Probandwise Concordance 0.14956 0.11441 0.19315 Marginal 0.03221 0.03007 0.03449 Estimate 2.5% 97.5% Broad-sense Heritability 0.70525 0.63657 0.76572 #+end_example * Liability model, Inverse Probability Weighting #+BEGIN_SRC R :exports none ############################### ## Liability model, IPCW ############################### #+END_SRC #+RESULTS[a7458abca3644831514dc5eacaefdcfc4be850de]: #+BEGIN_SRC R :file ipw.png ## Probability weights based on Aalen's additive model prtw <- ipw(Surv(time,status==0)~country, data=prt, cluster="id",weightname="w") plot(0,type="n",xlim=range(prtw$time),ylim=c(0,1),xlab="Age",ylab="Probability") count <- 0 for (l in unique(prtw$country)) { count <- count+1 prtw <- prtw[order(prtw$time),] with(subset(prtw,country==l), lines(time,w,col=count,lwd=2)) } legend("topright",legend=unique(prtw$country),col=1:4,pch=1) #+END_SRC #+RESULTS[561aef2bff0ca8538807fecb42f3fed7ca77963a]: [[file:ipw.png]] #+BEGIN_SRC R bpmzIPW <- biprobit(cancer~1 + cluster(id), data=subset(prtw,zyg=="MZ"), weight="w") (smz <- summary(bpmzIPW)) #+END_SRC #+RESULTS[a9be545d61f59041c45cc4a0ac0c40f4f8d5148a]: #+begin_example Estimate Std.Err Z p-value (Intercept) -1.226276 0.043074 -28.469378 0 atanh(rho) 0.912670 0.100316 9.097911 0 n pairs 2722 997 Score: 3.318e-05 -2.252e-05 logLik: -6703.246 Variance of latent residual term = 1 (standard probit link) Estimate 2.5% 97.5% Tetrachoric correlation 0.72241 0.61446 0.80381 Concordance 0.05490 0.04221 0.07113 Case-wise/Conditional 0.49887 0.41321 0.58460 Marginal 0.11005 0.09514 0.12696 #+end_example #+BEGIN_SRC R :file cif2.png ## CIF plot(pcif,multiple=1,se=0,uniform=0,ylim=c(0,0.15)) abline(h=smz$prob["Marginal",],lwd=c(2,1,1)) ## Wrong estimates: abline(h=summary(bpmz)$prob["Marginal",],lwd=c(2,1,1),col="lightgray") #+END_SRC R #+RESULTS[602b617012ad757420b7e1fc22f655f028bb5224]: [[file:cif2.png]] #+BEGIN_SRC R :file conc2.png ## Concordance plot(p33mz,ylim=c(0,0.1)) abline(h=smz$prob["Concordance",],lwd=c(2,1,1)) ## Wrong estimates: abline(h=summary(bpmz)$prob["Concordance",],lwd=c(2,1,1),col="lightgray") #+END_SRC #+RESULTS[c116ced6b8d822fb4a49d794a8b485b139fdbecf]: [[file:conc2.png]] #+BEGIN_SRC R bp3 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id", type="ace",data=prtw,weight="w") summary(bp3) #+END_SRC R #+RESULTS[d1eeda8bf7576f03d648b7052c5a778945ddfc31]: #+begin_example Estimate Std.Err Z p-value (Intercept) -2.31618 0.18673 -12.40359 0e+00 log(var(A)) 0.85390 0.22689 3.76347 2e-04 log(var(C)) -29.43218 1.13343 -25.96726 0e+00 Total MZ/DZ Complete pairs MZ/DZ 2722/5217 997/1809 Estimate 2.5% 97.5% A 0.70138 0.60090 0.78560 C 0.00000 0.00000 0.00000 E 0.29862 0.21440 0.39910 MZ Tetrachoric Cor 0.70138 0.59586 0.78310 DZ Tetrachoric Cor 0.35069 0.30328 0.39637 MZ: Estimate 2.5% 97.5% Concordance 0.04857 0.03963 0.05940 Probandwise Concordance 0.47238 0.39356 0.55260 Marginal 0.10281 0.09463 0.11161 DZ: Estimate 2.5% 97.5% Concordance 0.02515 0.02131 0.02965 Probandwise Concordance 0.24461 0.21892 0.27226 Marginal 0.10281 0.09463 0.11161 Estimate 2.5% 97.5% Broad-sense Heritability 0.70138 0.60090 0.78560 #+end_example #+BEGIN_SRC R bp4 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id", type="u",data=prtw,weight="w") summary(bp4) #+END_SRC R #+RESULTS[11d7e07eac47a4b69cd26a683e8896afc28c7cdf]: #+begin_example Estimate Std.Err Z p-value (Intercept) -1.266427 0.024091 -52.568381 0 atanh(rho) MZ 0.898548 0.098841 9.090866 0 atanh(rho) DZ 0.312574 0.073668 4.243006 0 Total MZ/DZ Complete pairs MZ/DZ 2722/5217 997/1809 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.71559 0.60742 0.79771 Tetrachoric correlation DZ 0.30278 0.16662 0.42760 MZ: Estimate 2.5% 97.5% Concordance 0.04974 0.04044 0.06104 Probandwise Concordance 0.48442 0.40185 0.56785 Marginal 0.10268 0.09453 0.11144 DZ: Estimate 2.5% 97.5% Concordance 0.02269 0.01667 0.03081 Probandwise Concordance 0.22097 0.16448 0.29013 Marginal 0.10268 0.09453 0.11144 Estimate 2.5% 97.5% Broad-sense Heritability 0.82563 0.33329 0.97819 #+end_example #+BEGIN_SRC R score(bp4) ## Check convergence #+END_SRC #+RESULTS[7e7a3cdc22554b0e037a60127143f39ed6ab7644]: : [1] 2.729971e-07 -8.463577e-08 -5.014015e-09 #+BEGIN_SRC R bp5 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id", type="ade",data=prtw,weight="w") summary(bp5) #+END_SRC #+RESULTS[1ac29f4140a27d60b2657f9a43b50e1b10c8a785]: #+begin_example Estimate Std.Err Z p-value (Intercept) -2.37470 0.20268 -11.71665 0.0000 log(var(A)) 0.55519 0.54480 1.01905 0.3082 log(var(D)) -0.25645 1.36092 -0.18844 0.8505 Total MZ/DZ Complete pairs MZ/DZ 2722/5217 997/1809 Estimate 2.5% 97.5% A 0.49552 0.10422 0.89238 D 0.22007 0.01081 0.87931 E 0.28441 0.19987 0.38740 MZ Tetrachoric Cor 0.71559 0.60742 0.79771 DZ Tetrachoric Cor 0.30278 0.16662 0.42760 MZ: Estimate 2.5% 97.5% Concordance 0.04974 0.04044 0.06104 Probandwise Concordance 0.48442 0.40185 0.56785 Marginal 0.10268 0.09453 0.11144 DZ: Estimate 2.5% 97.5% Concordance 0.02269 0.01667 0.03081 Probandwise Concordance 0.22097 0.16448 0.29013 Marginal 0.10268 0.09453 0.11144 Estimate 2.5% 97.5% Broad-sense Heritability 0.71559 0.61260 0.80013 #+end_example * Liability model, adjusting for covariates #+BEGIN_SRC R :exports none ############################### ## Adjusting for covariates ############################### #+END_SRC #+RESULTS[a3b0a6e83da2e17fa9c6d005008baa29b2dd935f]: Main effect of country #+BEGIN_SRC R bp6 <- bptwin(cancer~country,zyg="zyg",DZ="DZ",id="id", type="ace",data=prtw,weight="w") summary(bp6) #+END_SRC #+RESULTS[872f7096d70f85e257b9f257d0ed18c2fc529d86]: #+begin_example Warning message: In sqrt(diag(V)) : NaNs produced Estimate Std.Err Z p-value (Intercept) -2.81553 0.23889 -11.78590 0e+00 countryFinland 0.87558 0.16123 5.43061 0e+00 countryNorway 0.68483 0.17762 3.85567 1e-04 countrySweden 0.77248 0.12350 6.25468 0e+00 log(var(A)) 0.77724 0.23186 3.35220 8e-04 log(var(C)) -28.96268 NA NA NA Total MZ/DZ Complete pairs MZ/DZ 2722/5217 997/1809 Estimate 2.5% 97.5% A 0.68509 0.58001 0.77411 C 0.00000 0.00000 0.00000 E 0.31491 0.22589 0.41999 MZ Tetrachoric Cor 0.68509 0.57428 0.77124 DZ Tetrachoric Cor 0.34254 0.29262 0.39060 MZ: Estimate 2.5% 97.5% Concordance 0.02236 0.01588 0.03141 Probandwise Concordance 0.39194 0.30778 0.48305 Marginal 0.05705 0.04654 0.06977 DZ: Estimate 2.5% 97.5% Concordance 0.00989 0.00700 0.01394 Probandwise Concordance 0.17329 0.14505 0.20570 Marginal 0.05705 0.04654 0.06977 Estimate 2.5% 97.5% Broad-sense Heritability 0.68509 0.58001 0.77411 #+end_example Stratified analysis #+BEGIN_SRC R bp7 <- bptwin(cancer~country,zyg="zyg",DZ="DZ",id="id", type="u",data=prtw,weight="w") summary(bp7) #+END_SRC #+RESULTS[41de52429860b59b7751a8d685e1b2019a40fdba]: #+begin_example Estimate Std.Err Z p-value (Intercept) -1.581478 0.051318 -30.817030 0e+00 countryFinland 0.491725 0.081517 6.032155 0e+00 countryNorway 0.385830 0.094254 4.093497 0e+00 countrySweden 0.433789 0.060648 7.152599 0e+00 atanh(rho) MZ 0.884166 0.099366 8.898113 0e+00 atanh(rho) DZ 0.271770 0.073240 3.710668 2e-04 Total MZ/DZ Complete pairs MZ/DZ 2722/5217 997/1809 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.70850 0.59760 0.79280 Tetrachoric correlation DZ 0.26527 0.12752 0.39298 MZ: Estimate 2.5% 97.5% Concordance 0.02347 0.01664 0.03300 Probandwise Concordance 0.41255 0.32395 0.50721 Marginal 0.05688 0.04643 0.06953 DZ: Estimate 2.5% 97.5% Concordance 0.00794 0.00489 0.01287 Probandwise Concordance 0.13966 0.09312 0.20421 Marginal 0.05688 0.04643 0.06953 Estimate 2.5% 97.5% Broad-sense Heritability 0.88646 0.22665 0.99521 #+end_example #+BEGIN_SRC R :exports code bp8 <- bptwin(cancer~strata(country),zyg="zyg",DZ="DZ",id="id", type="u",data=prtw,weight="w") #+END_SRC #+RESULTS[7fa9adcc3baa465e73acf37b3d3cf5028ce25fe0]: : Strata 'Denmark' : Strata 'Finland' : Strata 'Norway' : Strata 'Sweden' #+BEGIN_SRC R summary(bp8) #+END_SRC #+RESULTS[f31101c27ef10245c1bafef45d4aefbafab0db9c]: #+begin_example ------------------------------------------------------------ Strata 'Denmark' Estimate Std.Err Z p-value (Intercept) -1.583608 0.051241 -30.904856 0.0000 atanh(rho) MZ 0.992896 0.217349 4.568215 0.0000 atanh(rho) DZ 0.070588 0.186956 0.377566 0.7058 Total MZ/DZ Complete pairs MZ/DZ 760/1611 287/589 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.75859 0.51308 0.88937 Tetrachoric correlation DZ 0.07047 -0.28750 0.41117 MZ: Estimate 2.5% 97.5% Concordance 0.02611 0.01584 0.04274 Probandwise Concordance 0.46093 0.28426 0.64799 Marginal 0.05664 0.04623 0.06922 DZ: Estimate 2.5% 97.5% Concordance 0.00420 0.00110 0.01596 Probandwise Concordance 0.07422 0.01888 0.25037 Marginal 0.05664 0.04623 0.06922 Estimate 2.5% 97.5% Broad-sense Heritability 1 NaN NaN ------------------------------------------------------------ Strata 'Finland' Estimate Std.Err Z p-value (Intercept) -1.087902 0.063221 -17.207912 0.0000 atanh(rho) MZ 0.859335 0.302752 2.838410 0.0045 atanh(rho) DZ 0.393145 0.179942 2.184840 0.0289 Total MZ/DZ Complete pairs MZ/DZ 392/1001 134/316 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.69592 0.25985 0.89623 Tetrachoric correlation DZ 0.37407 0.04044 0.63265 MZ: Estimate 2.5% 97.5% Concordance 0.07008 0.03975 0.12064 Probandwise Concordance 0.50666 0.27641 0.73412 Marginal 0.13832 0.11316 0.16801 DZ: Estimate 2.5% 97.5% Concordance 0.04160 0.02237 0.07607 Probandwise Concordance 0.30073 0.16558 0.48242 Marginal 0.13832 0.11316 0.16801 Estimate 2.5% 97.5% Broad-sense Heritability 0.64369 0.04069 0.98717 ------------------------------------------------------------ Strata 'Norway' Estimate Std.Err Z p-value (Intercept) -1.192293 0.079124 -15.068598 0.0000 atanh(rho) MZ 0.916471 0.301133 3.043409 0.0023 atanh(rho) DZ 0.533761 0.252070 2.117509 0.0342 Total MZ/DZ Complete pairs MZ/DZ 387/618 115/155 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.72422 0.31516 0.90635 Tetrachoric correlation DZ 0.48825 0.03969 0.77303 MZ: Estimate 2.5% 97.5% Concordance 0.05918 0.03218 0.10633 Probandwise Concordance 0.50764 0.27633 0.73572 Marginal 0.11657 0.08945 0.15057 DZ: Estimate 2.5% 97.5% Concordance 0.03945 0.01840 0.08257 Probandwise Concordance 0.33842 0.15583 0.58636 Marginal 0.11657 0.08945 0.15057 Estimate 2.5% 97.5% Broad-sense Heritability 0.47195 0.01989 0.97522 ------------------------------------------------------------ Strata 'Sweden' Estimate Std.Err Z p-value (Intercept) -1.149412 0.032155 -35.745836 0.0000 atanh(rho) MZ 0.836864 0.125476 6.669520 0.0000 atanh(rho) DZ 0.199677 0.092907 2.149202 0.0316 Total MZ/DZ Complete pairs MZ/DZ 1183/1987 461/749 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.68414 0.53057 0.79423 Tetrachoric correlation DZ 0.19706 0.01758 0.36425 MZ: Estimate 2.5% 97.5% Concordance 0.06055 0.04659 0.07835 Probandwise Concordance 0.48365 0.38001 0.58872 Marginal 0.12519 0.11277 0.13877 DZ: Estimate 2.5% 97.5% Concordance 0.02515 0.01672 0.03766 Probandwise Concordance 0.20088 0.13541 0.28746 Marginal 0.12519 0.11277 0.13877 Estimate 2.5% 97.5% Broad-sense Heritability 0.97416 0.00000 1.00000 #+end_example #+BEGIN_SRC R ## Wald test B <- (lava::contrmat(3,4))[-(1:3),] compare(bp8,contrast=B) #+END_SRC #+RESULTS[9edfe2c630260ff8b73d31c834163fd28fe0b862]: : : Wald test : : data: : chisq = 3.4972, df = 6, p-value = 0.7443 * Cumulative heritability #+BEGIN_SRC R :exports none ############################### ## Cumulative heritability ############################### #+END_SRC #+RESULTS[ea88384cdfd337305a3a4d37a3e08367283cddf2]: #+BEGIN_SRC R args(cumh) #+END_SRC #+RESULTS[64bc6b411e2b3bec2b118d7b3f47c4cb8d0487a0]: : function (formula, data, ..., time, timestrata = quantile(data[, : time], c(0.25, 0.5, 0.75, 1)), cumulative = TRUE, silent = FALSE) : NULL #+BEGIN_SRC R :exports code ch1 <- cumh(cancer~1,time="time",zyg="zyg",DZ="DZ",id="id", type="ace",data=prtw,weight="w") #+END_SRC R #+RESULTS[1890daf4d97a78df80a124ea5530a4152cf521ba]: : 65.5691955406266 : 76.4446739437236 : 85.8807708995545 : 117.622394945129 #+BEGIN_SRC R summary(ch1) #+END_SRC #+RESULTS[a501b9faea5a7237b247de20e21e66623b18d524]: : time Heritability Std.Err 2.5% 97.5% : 65.5691955406266 65.56920 0.7038286 0.10969626 0.4586422 0.8695520 : 76.4446739437236 76.44467 0.6757445 0.06363443 0.5411756 0.7864218 : 85.8807708995545 85.88077 0.6204174 0.05652481 0.5052219 0.7234726 : 117.622394945129 117.62239 0.7013847 0.04752116 0.6008962 0.7855993 #+BEGIN_SRC R :file cumh.png plot(ch1) #+END_SRC #+RESULTS[db2530ffda6ac40a43b1e74724910f30bbeacf04]: [[file:cumh.png]] ----- mets/inst/misc/obs/workshop.html0000644000176200001440000013130413623061405016461 0ustar liggesusers Analyzing twin data with <code>mets</code>

Analyzing twin data with mets

1 Installation

Set repositories (see also chooseCRANmirror, chooseBioCmirror) and install dependencies (R >=2.14) 

setRepositories() ## Choose CRAN and BioC Software (BioConductor)
install.packages(c("mets","cmprsk"))

OBS: At this point you might have to restart R to flush the cache of previously installed versions of the packages. If you have previously installed timereg and lava, make sure that you have the current versions installed (timereg: 1.6-5, lava: 1.0-5).

2 Load simulated data

library(mets)
data(prt)

3 Estimation of cumulative incidence

times <- seq(60,100,by=1)
cifmod <- comp.risk(Surv(time,status>0)~+1+cluster(id),data=prt,prt$status,causeS=2,n.sim=0,
                  times=times,conservative=1,max.clust=NULL,model="fg")

theta.des <- model.matrix(~-1+factor(zyg),data=prt) ## design for MZ/DZ status
or1 <- or.cif(cifmod,data=prt,cause1=2,cause2=2,theta.des=theta.des,same.cens=TRUE,
              score.method="fisher.scoring")
summary(or1)
or1$score

pcif <- predict(cifmod,X=1,resample.iid=0,uniform=0,se=0)

OR for dependence for competing risks

OR of cumulative incidence for cause1= 2  and cause2= 2
              log-ratio Coef.    SE     z    P-val Ratio    SE
factor(zyg)DZ            0.80 0.111  7.23 4.86e-13  2.22 0.246
factor(zyg)MZ            2.09 0.138 15.10 0.00e+00  8.07 1.110
             [,1]
[1,] 1.325225e-06
[2,] 3.458932e-06

plot(pcif,multiple=1,se=0,uniform=0,ylim=c(0,0.15))

pcif.png

4 Correcting for country

table(prt$country)

times <- seq(60,100,by=1)
cifmodl <-comp.risk(Surv(time,status>0)~-1+factor(country)+cluster(id),data=prt,
                    prt$status,causeS=2,n.sim=0,times=times,conservative=1,
                    max.clust=NULL,cens.model="aalen")
pcifl <- predict(cifmodl,X=diag(4),se=0,uniform=0)
plot(pcifl,multiple=1,se=0,uniform=0,col=1:4,ylim=c(0,0.2))
legend("topleft",levels(prt$country),col=1:4,lty=1)

pcifl.png 

theta.des <- model.matrix(~-1+factor(zyg),data=prt) ## design for MZ/DZ status
or.country <- or.cif(cifmodl,data=prt,cause1=2,cause2=2,theta.des=theta.des,same.cens=TRUE,
                     theta=c(2.8,6.9),score.method="fisher.scoring")
summary(or.country)
or.country$score

OR for dependence for competing risks

OR of cumulative incidence for cause1= 2  and cause2= 2
              log-ratio Coef.    SE     z    P-val Ratio    SE
factor(zyg)DZ           0.754 0.117  6.43 1.26e-10  2.12 0.249
factor(zyg)MZ           1.850 0.139 13.30 0.00e+00  6.36 0.883
              [,1]
[1,] -1.201999e-06
[2,]  1.558011e-06

cifmodlr <-comp.risk(Surv(time,status>0)~+1+const(factor(country))+cluster(id),data=prt,
                    prt$status,causeS=2,n.sim=0,times=times,conservative=1,max.clust=NULL,model="fg",
                    cens.model="aalen",cens.formula=~~factor(country))
pciflr <- predict(cifmodlr,X=rep(1,4),Z=rbind(c(0,0,0),c(1,0,0),c(0,1,0),c(0,0,1)),se=0,uniform=0)

par(mfrow=c(1,2))
plot(pcifl,multiple=1,se=0,uniform=0,col=1:4,ylim=c(0,0.2))
legend("topleft",levels(prt$country),col=1:4,lty=1)
plot(pciflr,multiple=1,se=0,uniform=0,col=1:4,ylim=c(0,0.2))
legend("topleft",levels(prt$country),col=1:4,lty=1)

pcif2.png 

or.countryr <- or.cif(cifmodlr,data=prt,cause1=2,cause2=2,theta.des=theta.des,same.cens=TRUE,
                     theta=c(2.8,6.9),score.method="fisher.scoring")
summary(or.countryr)

OR for dependence for competing risks

OR of cumulative incidence for cause1= 2  and cause2= 2
              log-ratio Coef.    SE     z    P-val Ratio    SE
factor(zyg)DZ           0.756 0.117  6.48 9.33e-11  2.13 0.249
factor(zyg)MZ           1.850 0.139 13.40 0.00e+00  6.38 0.886

5 Concordance estimation

### ignoring country 
p33 <- bicomprisk(Hist(time,status)~strata(zyg)+id(id),data=prt,cause=c(2,2),return.data=1,robust=1)

p33dz <- p33$model$"DZ"$comp.risk
p33mz <- p33$model$"MZ"$comp.risk

plot(p33dz,se=0,ylim=c(0,0.1))
lines(p33mz$time,p33mz$P1,col=3)
title(main="Concordance Prostate cancer")
lines(pcif$time,pcif$P1^2,col=2)
legend("topleft",c("DZ","MZ","Independence"),lty=rep(1,3),col=c(1,3,2))

p33dz.png 

### test for genetic effect 
test.conc(p33dz,p33mz); 


Pepe-Mori type test for H_0: conc_1(t)= conc_2(t)
Assuming independence for estimators
Time.range = 60.9 -- 96.9 

          cum dif.    sd    z     pval
pepe-mori    0.394 0.095 4.15 3.39e-05

data33mz <- p33$model$"MZ"$data
data33mz$zyg <- 1
data33dz <- p33$model$"DZ"$data
data33dz$zyg <- 0
data33 <- rbind(data33mz,data33dz)

library(cmprsk)
ftime <- data33$time
fstatus <- data33$status
table(fstatus)

fstatus
   0    1    2 
9597  106 4519

group <- data33$zyg
graytest <- cuminc(ftime,fstatus,group)
graytest

Tests:
      stat           pv df
1 28.82416 7.925617e-08  1
2 33.79236 6.131919e-09  1
Estimates and Variances:
$est
              20         40           60          80        100
0 1 0.0000000000 0.00000000 0.0001741916 0.006741025 0.01880244
1 1 0.0000000000 0.00000000 0.0006710172 0.017420360 0.05031415
0 2 0.0006970762 0.01974882 0.1141800067 0.504364854 0.93797293
1 2 0.0009363302 0.01655314 0.0948098327 0.443996722 0.90692430

$var
              20           40           60           80          100
0 1 0.000000e+00 0.000000e+00 3.034323e-08 2.115863e-06 9.493584e-06
1 1 0.000000e+00 0.000000e+00 2.250627e-07 9.173278e-06 5.102841e-05
0 2 8.094463e-08 2.487399e-06 1.556735e-05 6.990685e-05 4.769058e-05
1 2 1.752378e-07 3.424511e-06 2.388136e-05 1.271394e-04 1.171775e-04

zygeffect <- comp.risk(Surv(time,status==0)~const(zyg),
                  data=data33,data33$status,causeS=1,
                  cens.model="aalen",model="logistic",conservative=1)
summary(zygeffect)

Competing risks Model 

Test for nonparametric terms 

Test for non-significant effects 
            Supremum-test of significance p-value H_0: B(t)=0
(Intercept)                          25.5                   0

Test for time invariant effects 
                  Kolmogorov-Smirnov test p-value H_0:constant effect
(Intercept)                          2.23                           0
                    Cramer von Mises test p-value H_0:constant effect
(Intercept)                          36.2                           0

Parametric terms : 
           Coef.   SE Robust SE    z    P-val
const(zyg) 0.977 0.22      0.22 4.44 9.06e-06
   
  Call: 
comp.risk(Surv(time, status == 0) ~ const(zyg), data = data33, 
    data33$status, causeS = 1, cens.model = "aalen", model = "logistic", 
    conservative = 1)

case33mz <- conc2case(p33mz,pcif)
case33dz <- conc2case(p33dz,pcif)

plot(case33mz$casewise,se=0,col=3)
lines(case33dz$casewise$time,case33dz$casewise$P1)
title(main="Probandwise concordance")
legend("topleft",c("MZ","DZ","Independence"),lty=rep(1,3),col=c(3,1,2))
lines(pcif$time,pcif$P1,col=2)

casewise.png

6 Effect of zygosity correcting for country

p33l <- bicomprisk(Hist(time,status)~country+strata(zyg)+id(id),
                data=prt,cause=c(2,2),return.data=1,robust=1)

data33mz <- p33l$model$"MZ"$data
data33mz$zyg <- 1
data33dz <- p33l$model$"DZ"$data
data33dz$zyg <- 0
data33 <- rbind(data33mz,data33dz)

zygeffectl <- comp.risk(Surv(time,status==0)~const(country)+const(zyg),
                  data=data33,data33$status,causeS=1,
                  cens.model="aalen",model="logistic",conservative=1)
summary(zygeffectl)

Competing risks Model 

Test for nonparametric terms 

Test for non-significant effects 
            Supremum-test of significance p-value H_0: B(t)=0
(Intercept)                          16.1                   0

Test for time invariant effects 
                  Kolmogorov-Smirnov test p-value H_0:constant effect
(Intercept)                          2.01                           0
                    Cramer von Mises test p-value H_0:constant effect
(Intercept)                          35.9                           0

Parametric terms : 
                      Coef.    SE Robust SE    z    P-val
const(country)Finland 1.160 0.419     0.419 2.77 5.54e-03
const(country)Norway  0.655 0.458     0.458 1.43 1.53e-01
const(country)Sweden  0.796 0.372     0.372 2.14 3.23e-02
const(zyg)            0.932 0.230     0.230 4.05 5.15e-05
   
  Call: 
comp.risk(Surv(time, status == 0) ~ const(country) + const(zyg), 
    data = data33, data33$status, causeS = 1, cens.model = "aalen", 
    model = "logistic", conservative = 1)

zygeffectpl <- comp.risk(Surv(time,status==0)~const(country)+const(zyg),
                  data=data33,data33$status,causeS=1,
                  cens.model="aalen",model="fg",conservative=1)

print(summary(zygeffectpl))

Competing risks Model 

Test for nonparametric terms 

Test for non-significant effects 
            Supremum-test of significance p-value H_0: B(t)=0
(Intercept)                          2.83               0.012

Test for time invariant effects 
                  Kolmogorov-Smirnov test p-value H_0:constant effect
(Intercept)                        0.0101                           0
                    Cramer von Mises test p-value H_0:constant effect
(Intercept)                       0.00115                       0.004

Parametric terms : 
                      Coef.    SE Robust SE    z    P-val
const(country)Finland 1.140 0.412     0.412 2.77 5.63e-03
const(country)Norway  0.646 0.452     0.452 1.43 1.53e-01
const(country)Sweden  0.785 0.368     0.368 2.14 3.27e-02
const(zyg)            0.916 0.226     0.226 4.05 5.22e-05
   
  Call: 
comp.risk(Surv(time, status == 0) ~ const(country) + const(zyg), 
    data = data33, data33$status, causeS = 1, cens.model = "aalen", 
    model = "fg", conservative = 1)

NULL

zygeffectll <- comp.risk(Surv(time,status==0)~country+const(zyg),
                         data=data33,data33$status,causeS=1,
                         cens.model="aalen",model="logistic",conservative=1)

print(summary(zygeffectll))

Competing risks Model 

Test for nonparametric terms 

Test for non-significant effects 
               Supremum-test of significance p-value H_0: B(t)=0
(Intercept)                            75.70                   0
countryFinland                        441.00                   0
countryNorway                           6.09                   0
countrySweden                         703.00                   0

Test for time invariant effects 
                     Kolmogorov-Smirnov test p-value H_0:constant effect
(Intercept)                             6.59                       0.000
countryFinland                          6.24                       0.000
countryNorway                           1.31                       0.574
countrySweden                           6.39                       0.000
                       Cramer von Mises test p-value H_0:constant effect
(Intercept)                            200.0                         0.0
countryFinland                        1180.0                         0.0
countryNorway                           17.6                         0.4
countrySweden                         1300.0                         0.0

Parametric terms : 
           Coef.   SE Robust SE    z    P-val
const(zyg) 0.939 0.23      0.23 4.08 4.58e-05
   
WARNING problem with convergence for time points:
64.88587 66.74123
Readjust analyses by removing points

  Call: 
comp.risk(Surv(time, status == 0) ~ country + const(zyg), data = data33, 
    data33$status, causeS = 1, cens.model = "aalen", model = "logistic", 
    conservative = 1)

NULL

7 Liability model, ignoring censoring

(M <- with(prt, table(cancer,zyg)))

      zyg
cancer    DZ    MZ
     0 17408 10872
     1   583   359

coef(lm(cancer~-1+zyg,prt))

     zygDZ      zygMZ 
0.03240509 0.03196510

## Saturated model
bpmz <- 
    biprobit(cancer~1 + cluster(id), 
             data=subset(prt,zyg=="MZ"), eqmarg=TRUE)

logLik(bpmz) # Log-likelihood
AIC(bpmz) # AIC
coef(bpmz) # Parameter estimates
vcov(bpmz) # Asymptotic covariance
summary(bpmz) # concordance, case-wise, tetrachoric correlations, ...

'log Lik.' -1472.972 (df=2)
[1] 2949.943
(Intercept)  atanh(rho) 
 -1.8539454   0.8756506
             (Intercept)   atanh(rho)
(Intercept) 0.0007089726 0.0003033296
atanh(rho)  0.0003033296 0.0044023587

              Estimate    Std.Err          Z p-value
(Intercept)  -1.853945   0.026627 -69.627727       0
atanh(rho)    0.875651   0.066350  13.197393       0

    n pairs 
11231  5473 
Score: -3.453e-05 5.123e-06
logLik: -1472.972 
Variance of latent residual term = 1 (standard probit link) 

                        Estimate 2.5%    97.5%  
Tetrachoric correlation 0.70423  0.63252 0.76398
Concordance             0.01131  0.00886 0.01443
Case-wise/Conditional   0.35487  0.29391 0.42094
Marginal                0.03187  0.02834 0.03583

bp0 <- biprobit(cancer~1 + cluster(id)+strata(zyg), data=prt)

summary(bp0)

------------------------------------------------------------
Strata 'DZ'

              Estimate    Std.Err          Z p-value
(Intercept)  -1.846841   0.019247 -95.955243       0
atanh(rho)    0.418065   0.050421   8.291446       0

    n pairs 
17991  8749 
Score: -0.001841 -0.0006879
logLik: -2536.242 
Variance of latent residual term = 1 (standard probit link) 

                        Estimate 2.5%    97.5%  
Tetrachoric correlation 0.39530  0.30882 0.47529
Concordance             0.00486  0.00361 0.00655
Case-wise/Conditional   0.15019  0.11459 0.19443
Marginal                0.03239  0.02976 0.03523

------------------------------------------------------------
Strata 'MZ'

              Estimate    Std.Err          Z p-value
(Intercept)  -1.853945   0.026627 -69.627727       0
atanh(rho)    0.875651   0.066350  13.197393       0

    n pairs 
11231  5473 
Score: -3.453e-05 5.123e-06
logLik: -1472.972 
Variance of latent residual term = 1 (standard probit link) 

                        Estimate 2.5%    97.5%  
Tetrachoric correlation 0.70423  0.63252 0.76398
Concordance             0.01131  0.00886 0.01443
Case-wise/Conditional   0.35487  0.29391 0.42094
Marginal                0.03187  0.02834 0.03583

## Eq. marginals MZ/DZ
bp1 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="u",data=prt)
summary(bp1) # Components (concordance,cor,...) can be extracted from returned list

                 Estimate     Std.Err           Z p-value
(Intercept)     -1.849284    0.015601 -118.539777       0
atanh(rho) MZ    0.877667    0.065815   13.335456       0
atanh(rho) DZ    0.417475    0.050276    8.303615       0

 Total MZ/DZ Complete pairs MZ/DZ
 11231/17991 5473/8749           

                           Estimate 2.5%    97.5%  
Tetrachoric correlation MZ 0.70525  0.63436 0.76438
Tetrachoric correlation DZ 0.39480  0.30854 0.47462

MZ:
                        Estimate 2.5%    97.5%  
Concordance             0.01149  0.00942 0.01400
Probandwise Concordance 0.35672  0.29764 0.42049
Marginal                0.03221  0.03007 0.03449
DZ:
                        Estimate 2.5%    97.5%  
Concordance             0.00482  0.00363 0.00640
Probandwise Concordance 0.14956  0.11441 0.19315
Marginal                0.03221  0.03007 0.03449

                         Estimate 2.5%    97.5%  
Broad-sense Heritability 0.62090  0.40145 0.79997

compare(bp0,bp1) # LRT


      Likelihood ratio test

data:  
chisq = 0.0468, df = 1, p-value = 0.8288
sample estimates:
log likelihood (model 1) log likelihood (model 2) 
               -4009.213                -4009.237

Polygenic Libability model via te bptwin function (type can be a subset of "acde", or "flex" for stratitified, "u" for random effects model with same marginals for MZ and DZ) 

## Polygenic model
args(bptwin)

function (formula, data, id, zyg, DZ, OS, weight = NULL, biweight = function(x) 1/min(x), 
    strata = NULL, messages = 1, control = list(trace = 0), type = "ace", 
    eqmean = TRUE, pairsonly = FALSE, samecens = TRUE, allmarg = samecens & 
        !is.null(weight), stderr = TRUE, robustvar = TRUE, p, 
    indiv = FALSE, constrain, bound = FALSE, debug = FALSE, ...) 
NULL

bp2 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="ace",data=prt)
summary(bp2)

             Estimate   Std.Err         Z p-value
(Intercept)  -3.40624   0.19032 -17.89736  0.0000
log(var(A))   0.74503   0.25710   2.89787  0.0038
log(var(C))  -1.25112   1.04238  -1.20024  0.2300

 Total MZ/DZ Complete pairs MZ/DZ
 11231/17991 5473/8749           

                   Estimate 2.5%    97.5%  
A                  0.62090  0.40145 0.79997
C                  0.08435  0.00910 0.48028
E                  0.29475  0.23428 0.36343
MZ Tetrachoric Cor 0.70525  0.63436 0.76438
DZ Tetrachoric Cor 0.39480  0.30854 0.47462

MZ:
                        Estimate 2.5%    97.5%  
Concordance             0.01149  0.00942 0.01400
Probandwise Concordance 0.35672  0.29764 0.42049
Marginal                0.03221  0.03007 0.03449
DZ:
                        Estimate 2.5%    97.5%  
Concordance             0.00482  0.00363 0.00640
Probandwise Concordance 0.14956  0.11441 0.19315
Marginal                0.03221  0.03007 0.03449

                         Estimate 2.5%    97.5%  
Broad-sense Heritability 0.70525  0.63657 0.76572

8 Liability model, Inverse Probability Weighting

## Probability weights based on Aalen's additive model 
prtw <- ipw(Surv(time,status==0)~country, data=prt,
            cluster="id",weightname="w") 
plot(0,type="n",xlim=range(prtw$time),ylim=c(0,1),xlab="Age",ylab="Probability")
count <- 0
for (l in unique(prtw$country)) {
    count <- count+1
    prtw <- prtw[order(prtw$time),]
    with(subset(prtw,country==l), 
         lines(time,w,col=count,lwd=2))
}
legend("topright",legend=unique(prtw$country),col=1:4,pch=1)

ipw.png 

bpmzIPW <- 
              biprobit(cancer~1 + cluster(id), 
                       data=subset(prtw,zyg=="MZ"), 
                       weight="w")
(smz <- summary(bpmzIPW))

              Estimate    Std.Err          Z p-value
(Intercept)  -1.226276   0.043074 -28.469378       0
atanh(rho)    0.912670   0.100316   9.097911       0

    n pairs 
 2722   997 
Score: 3.318e-05 -2.252e-05
logLik: -6703.246 
Variance of latent residual term = 1 (standard probit link) 

                        Estimate 2.5%    97.5%  
Tetrachoric correlation 0.72241  0.61446 0.80381
Concordance             0.05490  0.04221 0.07113
Case-wise/Conditional   0.49887  0.41321 0.58460
Marginal                0.11005  0.09514 0.12696

## CIF
plot(pcif,multiple=1,se=0,uniform=0,ylim=c(0,0.15))
abline(h=smz$prob["Marginal",],lwd=c(2,1,1))
## Wrong estimates:
abline(h=summary(bpmz)$prob["Marginal",],lwd=c(2,1,1),col="lightgray")

cif2.png 

## Concordance
plot(p33mz,ylim=c(0,0.1))
abline(h=smz$prob["Concordance",],lwd=c(2,1,1))
## Wrong estimates:
abline(h=summary(bpmz)$prob["Concordance",],lwd=c(2,1,1),col="lightgray")

conc2.png 

bp3 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",
              type="ace",data=prtw,weight="w")
summary(bp3)

             Estimate   Std.Err         Z p-value
(Intercept)  -2.31618   0.18673 -12.40359   0e+00
log(var(A))   0.85390   0.22689   3.76347   2e-04
log(var(C)) -29.43218   1.13343 -25.96726   0e+00

 Total MZ/DZ Complete pairs MZ/DZ
 2722/5217   997/1809            

                   Estimate 2.5%    97.5%  
A                  0.70138  0.60090 0.78560
C                  0.00000  0.00000 0.00000
E                  0.29862  0.21440 0.39910
MZ Tetrachoric Cor 0.70138  0.59586 0.78310
DZ Tetrachoric Cor 0.35069  0.30328 0.39637

MZ:
                        Estimate 2.5%    97.5%  
Concordance             0.04857  0.03963 0.05940
Probandwise Concordance 0.47238  0.39356 0.55260
Marginal                0.10281  0.09463 0.11161
DZ:
                        Estimate 2.5%    97.5%  
Concordance             0.02515  0.02131 0.02965
Probandwise Concordance 0.24461  0.21892 0.27226
Marginal                0.10281  0.09463 0.11161

                         Estimate 2.5%    97.5%  
Broad-sense Heritability 0.70138  0.60090 0.78560

bp4 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",
              type="u",data=prtw,weight="w")
summary(bp4)

                Estimate    Std.Err          Z p-value
(Intercept)    -1.266427   0.024091 -52.568381       0
atanh(rho) MZ   0.898548   0.098841   9.090866       0
atanh(rho) DZ   0.312574   0.073668   4.243006       0

 Total MZ/DZ Complete pairs MZ/DZ
 2722/5217   997/1809            

                           Estimate 2.5%    97.5%  
Tetrachoric correlation MZ 0.71559  0.60742 0.79771
Tetrachoric correlation DZ 0.30278  0.16662 0.42760

MZ:
                        Estimate 2.5%    97.5%  
Concordance             0.04974  0.04044 0.06104
Probandwise Concordance 0.48442  0.40185 0.56785
Marginal                0.10268  0.09453 0.11144
DZ:
                        Estimate 2.5%    97.5%  
Concordance             0.02269  0.01667 0.03081
Probandwise Concordance 0.22097  0.16448 0.29013
Marginal                0.10268  0.09453 0.11144

                         Estimate 2.5%    97.5%  
Broad-sense Heritability 0.82563  0.33329 0.97819

score(bp4) ## Check convergence

[1]  2.729971e-07 -8.463577e-08 -5.014015e-09

bp5 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",
              type="ade",data=prtw,weight="w")
summary(bp5)

             Estimate   Std.Err         Z p-value
(Intercept)  -2.37470   0.20268 -11.71665  0.0000
log(var(A))   0.55519   0.54480   1.01905  0.3082
log(var(D))  -0.25645   1.36092  -0.18844  0.8505

 Total MZ/DZ Complete pairs MZ/DZ
 2722/5217   997/1809            

                   Estimate 2.5%    97.5%  
A                  0.49552  0.10422 0.89238
D                  0.22007  0.01081 0.87931
E                  0.28441  0.19987 0.38740
MZ Tetrachoric Cor 0.71559  0.60742 0.79771
DZ Tetrachoric Cor 0.30278  0.16662 0.42760

MZ:
                        Estimate 2.5%    97.5%  
Concordance             0.04974  0.04044 0.06104
Probandwise Concordance 0.48442  0.40185 0.56785
Marginal                0.10268  0.09453 0.11144
DZ:
                        Estimate 2.5%    97.5%  
Concordance             0.02269  0.01667 0.03081
Probandwise Concordance 0.22097  0.16448 0.29013
Marginal                0.10268  0.09453 0.11144

                         Estimate 2.5%    97.5%  
Broad-sense Heritability 0.71559  0.61260 0.80013

9 Liability model, adjusting for covariates

Main effect of country 

bp6 <- bptwin(cancer~country,zyg="zyg",DZ="DZ",id="id",
              type="ace",data=prtw,weight="w")
summary(bp6)

Warning message:
In sqrt(diag(V)) : NaNs produced

                Estimate   Std.Err         Z p-value
(Intercept)     -2.81553   0.23889 -11.78590   0e+00
countryFinland   0.87558   0.16123   5.43061   0e+00
countryNorway    0.68483   0.17762   3.85567   1e-04
countrySweden    0.77248   0.12350   6.25468   0e+00
log(var(A))      0.77724   0.23186   3.35220   8e-04
log(var(C))    -28.96268        NA        NA      NA

 Total MZ/DZ Complete pairs MZ/DZ
 2722/5217   997/1809            

                   Estimate 2.5%    97.5%  
A                  0.68509  0.58001 0.77411
C                  0.00000  0.00000 0.00000
E                  0.31491  0.22589 0.41999
MZ Tetrachoric Cor 0.68509  0.57428 0.77124
DZ Tetrachoric Cor 0.34254  0.29262 0.39060

MZ:
                        Estimate 2.5%    97.5%  
Concordance             0.02236  0.01588 0.03141
Probandwise Concordance 0.39194  0.30778 0.48305
Marginal                0.05705  0.04654 0.06977
DZ:
                        Estimate 2.5%    97.5%  
Concordance             0.00989  0.00700 0.01394
Probandwise Concordance 0.17329  0.14505 0.20570
Marginal                0.05705  0.04654 0.06977

                         Estimate 2.5%    97.5%  
Broad-sense Heritability 0.68509  0.58001 0.77411

Stratified analysis 

bp7 <- bptwin(cancer~country,zyg="zyg",DZ="DZ",id="id",
              type="u",data=prtw,weight="w")
summary(bp7)

                 Estimate    Std.Err          Z p-value
(Intercept)     -1.581478   0.051318 -30.817030   0e+00
countryFinland   0.491725   0.081517   6.032155   0e+00
countryNorway    0.385830   0.094254   4.093497   0e+00
countrySweden    0.433789   0.060648   7.152599   0e+00
atanh(rho) MZ    0.884166   0.099366   8.898113   0e+00
atanh(rho) DZ    0.271770   0.073240   3.710668   2e-04

 Total MZ/DZ Complete pairs MZ/DZ
 2722/5217   997/1809            

                           Estimate 2.5%    97.5%  
Tetrachoric correlation MZ 0.70850  0.59760 0.79280
Tetrachoric correlation DZ 0.26527  0.12752 0.39298

MZ:
                        Estimate 2.5%    97.5%  
Concordance             0.02347  0.01664 0.03300
Probandwise Concordance 0.41255  0.32395 0.50721
Marginal                0.05688  0.04643 0.06953
DZ:
                        Estimate 2.5%    97.5%  
Concordance             0.00794  0.00489 0.01287
Probandwise Concordance 0.13966  0.09312 0.20421
Marginal                0.05688  0.04643 0.06953

                         Estimate 2.5%    97.5%  
Broad-sense Heritability 0.88646  0.22665 0.99521

bp8 <- bptwin(cancer~strata(country),zyg="zyg",DZ="DZ",id="id",
              type="u",data=prtw,weight="w")

summary(bp8)

------------------------------------------------------------
Strata 'Denmark'

                Estimate    Std.Err          Z p-value
(Intercept)    -1.583608   0.051241 -30.904856  0.0000
atanh(rho) MZ   0.992896   0.217349   4.568215  0.0000
atanh(rho) DZ   0.070588   0.186956   0.377566  0.7058

 Total MZ/DZ Complete pairs MZ/DZ
 760/1611    287/589             

                           Estimate 2.5%     97.5%   
Tetrachoric correlation MZ  0.75859  0.51308  0.88937
Tetrachoric correlation DZ  0.07047 -0.28750  0.41117

MZ:
                        Estimate 2.5%    97.5%  
Concordance             0.02611  0.01584 0.04274
Probandwise Concordance 0.46093  0.28426 0.64799
Marginal                0.05664  0.04623 0.06922
DZ:
                        Estimate 2.5%    97.5%  
Concordance             0.00420  0.00110 0.01596
Probandwise Concordance 0.07422  0.01888 0.25037
Marginal                0.05664  0.04623 0.06922

                         Estimate 2.5% 97.5%
Broad-sense Heritability   1      NaN  NaN  

------------------------------------------------------------
Strata 'Finland'

                Estimate    Std.Err          Z p-value
(Intercept)    -1.087902   0.063221 -17.207912  0.0000
atanh(rho) MZ   0.859335   0.302752   2.838410  0.0045
atanh(rho) DZ   0.393145   0.179942   2.184840  0.0289

 Total MZ/DZ Complete pairs MZ/DZ
 392/1001    134/316             

                           Estimate 2.5%    97.5%  
Tetrachoric correlation MZ 0.69592  0.25985 0.89623
Tetrachoric correlation DZ 0.37407  0.04044 0.63265

MZ:
                        Estimate 2.5%    97.5%  
Concordance             0.07008  0.03975 0.12064
Probandwise Concordance 0.50666  0.27641 0.73412
Marginal                0.13832  0.11316 0.16801
DZ:
                        Estimate 2.5%    97.5%  
Concordance             0.04160  0.02237 0.07607
Probandwise Concordance 0.30073  0.16558 0.48242
Marginal                0.13832  0.11316 0.16801

                         Estimate 2.5%    97.5%  
Broad-sense Heritability 0.64369  0.04069 0.98717

------------------------------------------------------------
Strata 'Norway'

                Estimate    Std.Err          Z p-value
(Intercept)    -1.192293   0.079124 -15.068598  0.0000
atanh(rho) MZ   0.916471   0.301133   3.043409  0.0023
atanh(rho) DZ   0.533761   0.252070   2.117509  0.0342

 Total MZ/DZ Complete pairs MZ/DZ
 387/618     115/155             

                           Estimate 2.5%    97.5%  
Tetrachoric correlation MZ 0.72422  0.31516 0.90635
Tetrachoric correlation DZ 0.48825  0.03969 0.77303

MZ:
                        Estimate 2.5%    97.5%  
Concordance             0.05918  0.03218 0.10633
Probandwise Concordance 0.50764  0.27633 0.73572
Marginal                0.11657  0.08945 0.15057
DZ:
                        Estimate 2.5%    97.5%  
Concordance             0.03945  0.01840 0.08257
Probandwise Concordance 0.33842  0.15583 0.58636
Marginal                0.11657  0.08945 0.15057

                         Estimate 2.5%    97.5%  
Broad-sense Heritability 0.47195  0.01989 0.97522

------------------------------------------------------------
Strata 'Sweden'

                Estimate    Std.Err          Z p-value
(Intercept)    -1.149412   0.032155 -35.745836  0.0000
atanh(rho) MZ   0.836864   0.125476   6.669520  0.0000
atanh(rho) DZ   0.199677   0.092907   2.149202  0.0316

 Total MZ/DZ Complete pairs MZ/DZ
 1183/1987   461/749             

                           Estimate 2.5%    97.5%  
Tetrachoric correlation MZ 0.68414  0.53057 0.79423
Tetrachoric correlation DZ 0.19706  0.01758 0.36425

MZ:
                        Estimate 2.5%    97.5%  
Concordance             0.06055  0.04659 0.07835
Probandwise Concordance 0.48365  0.38001 0.58872
Marginal                0.12519  0.11277 0.13877
DZ:
                        Estimate 2.5%    97.5%  
Concordance             0.02515  0.01672 0.03766
Probandwise Concordance 0.20088  0.13541 0.28746
Marginal                0.12519  0.11277 0.13877

                         Estimate 2.5%    97.5%  
Broad-sense Heritability 0.97416  0.00000 1.00000

## Wald test
B <- (lava::contrmat(3,4))[-(1:3),]
compare(bp8,contrast=B)


      Wald test

data:  
chisq = 3.4972, df = 6, p-value = 0.7443

10 Cumulative heritability

args(cumh)

function (formula, data, ..., time, timestrata = quantile(data[, 
    time], c(0.25, 0.5, 0.75, 1)), cumulative = TRUE, silent = FALSE) 
NULL

ch1 <- cumh(cancer~1,time="time",zyg="zyg",DZ="DZ",id="id",
            type="ace",data=prtw,weight="w")

summary(ch1)

                      time Heritability    Std.Err      2.5%     97.5%
65.5691955406266  65.56920    0.7038286 0.10969626 0.4586422 0.8695520
76.4446739437236  76.44467    0.6757445 0.06363443 0.5411756 0.7864218
85.8807708995545  85.88077    0.6204174 0.05652481 0.5052219 0.7234726
117.622394945129 117.62239    0.7013847 0.04752116 0.6008962 0.7855993

plot(ch1)

cumh.png

Date: 2012-05-20

Author: Klaus K. Holst and Thomas Scheike

mets/inst/misc/pairwise-twostage.r0000644000176200001440000002154513623061405017002 0ustar liggesusers library(mets) ### set.seed(1000) data <- simClaytonOakes.family.ace(8000,2,1,0,3) head(data) data$number <- c(1,2,3,4) data$child <- 1*(data$number==3) out <- ace.family.design(data,member="type",id="cluster") ### 8 random effects with 1/4 * var.gene, and one shared environment 1 * var.env out$pardes head(out$des.rv) ### aa <- phreg(Surv(time,status)~+cluster(cluster),data=data) ## {{{ additive gamma models with and without pair call ### make ace random effects design ### simple random effects call ts0 <- survival.twostage(aa,data=data,clusters=data$cluster, detail=1,var.par=1,var.link=0, theta=c(2,1), random.design=out$des.rv,theta.des=out$pardes) summary(ts0) ### simple random effects call ts1 <- survival.twostage(aa,data=data,clusters=data$cluster, detail=1,var.par=0,var.link=0, theta=c(2,1)/9, random.design=out$des.rv,theta.des=out$pardes) summary(ts1) ### parameters c(2,1)/(2+1)^2 checkderiv=1 if (checkderiv==1) {# {{{ ts0 <- twostage(aa,data=data,clusters=data$cluster, detail=1,numDeriv=1,Nit=0,var.par=1, theta=log(c(2,1)/9),var.link=1,step=1.0, random.design=out$des.rv,theta.des=out$pardes) ts0$score ts0$score1 ts0 <- twostage(aa,data=data,clusters=data$cluster, detail=1,numDeriv=1,Nit=0,var.par=1, theta=c(2,1)/9,var.link=0,step=1.0, random.design=out$des.rv,theta.des=out$pardes) ts0$score ts0$score1 ts0 <- twostage(aa,data=data,clusters=data$cluster, detail=1,numDeriv=1,Nit=0,var.par=0, theta=log(c(2,1)),var.link=1,step=1.0, random.design=out$des.rv,theta.des=out$pardes) ts0$score ts0$score1 ts0 <- twostage(aa,data=data,clusters=data$cluster, detail=1,numDeriv=1,Nit=0,var.par=0, theta=c(2,1),var.link=0,step=1.0, random.design=out$des.rv,theta.des=out$pardes) ts0$score ts0$score1 }# }}} ### now specify fitting via specific pairs ### first construct all pairs mm <- familycluster.index(data$cluster) head(mm$familypairindex,n=10) pairs <- matrix(mm$familypairindex,ncol=2,byrow=TRUE) tail(pairs,n=12) ## make all pairs and pair specific design and pardes ## same as ts0 but pairs specified tsp <- twostage(aa,data=data,clusters=data$cluster, theta=c(2,1)/9,var.link=0,step=1.0,var.par=0, random.design=out$des.rv,detail=0, theta.des=out$pardes,pairs=pairs) summary(tsp) tsp1 <- twostage(aa,data=data,clusters=data$cluster, theta=c(2,1),var.link=0,step=1.0,var.par=1, random.design=out$des.rv,detail=0, theta.des=out$pardes,pairs=pairs) summary(tsp1) source("../../R/twostage.R") aa <- aalen(Surv(time,status)~+1,data=data,robust=0) tsp2 <- twostage(aa,data=data,clusters=data$cluster, theta=c(2,1),var.link=0,step=1.0, random.design=out$des.rv,detail=0, theta.des=out$pardes,pairs=pairs) summary(tsp2) c(tsp1$marginal.surv-tsp2$marginal.surv) ### random sample of pairs ssid <- sort(sample(1:32000,20000)) ### ### take some of all tsd <- twostage(aa,data=data,clusters=data$cluster, theta=c(2,1)/10,var.link=0,step=1.0, random.design=out$des.rv,iid=1, theta.des=out$pardes,pairs=pairs[ssid,]) summary(tsd) str(aa) aa$id ### same analyses but now gives only data that is used in the relevant pairs ids <- sort(unique(c(pairs[ssid,]))) ### pairsids <- c(pairs[ssid,]) pair.new <- matrix(fast.approx(ids,c(pairs[ssid,])),ncol=2) head(pair.new) ## this requires that pair.new refers to id's in dataid (survival, status and so forth) ## random.design and theta.des are constructed to be the array 3 dims via individual specfication from ace.family.design dataid <- dsort(data[ids,],"cluster") outid <- ace.family.design(dataid,member="type",id="cluster") outid$pardes head(outid$des.rv) ### tsid <- twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1)/10,var.link=0,step=1.0, random.design=outid$des.rv,iid=1, theta.des=outid$pardes,pairs=pair.new) summary(tsdid) coef(tsdid) coef(tsd) ### same as tsd ### now direct specification of random.design and theta.design ### rather than taking the rows of the des.rv for the relevant pairs ### can make a pair specific specification of random effects pair.types <- matrix(dataid[c(t(pair.new)),"type"],byrow=T,ncol=2) head(pair.new) head(pair.types) ### here makes pairwise design , simpler random.design og pardes, parameters ### stil varg, varc ### mother, child, share half rvm=c(1,1,0) rvc=c(1,0,1), ### thetadesmcf=rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) ### ### father, child, share half rvf=c(1,1,0) rvc=c(1,0,1), ### thetadescf=rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) ### ### child, child, share half rvc=c(1,1,0) rvc=c(1,0,1), ### thetadesmf=rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) ### ### mother, father, share 0 rvm=c(1,0) rvf=c(0,1), ### thetadesmf=rbind(c(1,0),c(1,0),c(0,1)) theta.des <- array(0,c(4,2,nrow(pair.new))) random.des <- array(0,c(2,4,nrow(pair.new))) ### random variables in each pair rvs <- c() for (i in 1:nrow(pair.new)) { if (pair.types[i,1]=="mother" & pair.types[i,2]=="father") { theta.des[,,i] <- rbind(c(1,0),c(1,0),c(0,1),c(0,0)) random.des[,,i] <- rbind(c(1,0,1,0),c(0,1,1,0)) rvs <- c(rvs,3) } else { theta.des[,,i] <- rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) random.des[,,i] <- rbind(c(1,1,0,1),c(1,0,1,1)) rvs <- c(rvs,4) } } ### 3 rvs here random.des[,,7] theta.des[,,7] ### 4 rvs here random.des[,,1] theta.des[,,1] head(rvs) tsdid2 <- twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1)/10,var.link=0,step=1.0, random.design=random.des, theta.des=theta.des,pairs=pair.new,pairs.rvs=rvs) summary(tsdid2) tsd$theta tsdid2$theta tsdid$theta ### simpler specification via kinship coefficient for each pair kinship <- c() for (i in 1:nrow(pair.new)) { if (pair.types[i,1]=="mother" & pair.types[i,2]=="father") pk1 <- 0 else pk1 <- 0.5 kinship <- c(kinship,pk1) } head(kinship,n=10) out <- make.pairwise.design(pair.new,kinship,type="ace") names(out) ### 4 rvs here , here independence since shared component has variance 0 ! out$random.des[,,9] out$theta.des[,,9] tsdid3 <- twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1)/10,var.link=0,step=1.0, random.design=out$random.design, theta.des=out$theta.des,pairs=pair.new,pairs.rvs=out$ant.rvs) summary(tsdid3) coef(tsdid3) ### same as above tsdid2 ## }}} ##### simple models, test for pairs structure ## {{{ library(mets) source("../R/twostage.R") ts0 <- twostage(aa,data=data,clusters=data$cluster, detail=0,numDeriv=1,Nit=10, theta=c(0.17),var.link=0,step=1.0) summary(ts0) ts0$score; ts0$score1 ts0$Dscore; ts0$hess mm <- familycluster.index(data$cluster) head(mm$familypairindex,n=10) pairs <- matrix(mm$familypairindex,ncol=2,byrow=TRUE) head(pairs,n=12) tail(pairs,n=12) dim(pairs) # cc <- cluster.index(data$cluster) ### ts0 <- twostage(aa,data=data,clusters=data$cluster, detail=1,Nit=0, theta=ts0$theta,var.link=0,pairs=pairs) summary(ts0) ## {{{ simple models with pair call library(mets) set.seed(100) data <- simClaytonOakes.family.ace(8000,2,1,0,3) head(data) data$number <- c(1,2,3,4) data$child <- 1*(data$number==3) ### make ace random effects design out <- ace.family.design(data,member="type",id="cluster") out$pardes head(out$des.rv) ### makes marginal model (same for all) aa <- aalen(Surv(time,status)~+1,data=data,robust=0) mm <- familycluster.index(data$cluster) head(mm$familypairindex,n=10) pairs <- matrix(mm$familypairindex,ncol=2,byrow=TRUE) head(pairs,n=12) tail(pairs,n=12) dim(pairs) # ts0 <- twostage(aa,data=data,clusters=data$cluster, detail=1,Nit=10, theta=c(0.2),var.link=0,step=1.0) summary(ts0) ts0 <- twostage(aa,data=data,clusters=data$cluster, detail=1,Nit=10,numDeriv=1, theta=c(0.2),var.link=0,step=1.0,pairs=pairs) summary(ts0) ts0$score ts0$score1 ts0 <- twostage(aa,data=data,clusters=data$cluster, detail=1,Nit=10, theta=c(0.2),var.link=0,step=1.0,model="plackett") summary(ts0) ts0 <- twostage(aa,data=data,clusters=data$cluster, detail=1,Nit=10, theta=c(0.2),var.link=0,step=1.0,model="plackett",pairs=pairs) summary(ts0) theta.des <- model.matrix(~x1,data=data) ts0 <- twostage(aa,data=data,clusters=data$cluster, detail=1,Nit=10,theta.des=theta.des, theta=c(0.2),var.link=0,step=1.0) summary(ts0) ts0 <- twostage(aa,data=data,clusters=data$cluster, detail=1,Nit=10,theta.des=theta.des, theta=c(0.2),var.link=0,step=1.0,pairs=pairs) summary(ts0) ts0 <- twostage(aa,data=data,clusters=data$cluster, detail=1,Nit=10,theta.des=theta.des, theta=c(0.2),var.link=0,step=1.0,model="plackett") summary(ts0) ts0 <- twostage(aa,data=data,clusters=data$cluster, detail=1,Nit=10,theta.des=theta.des, theta=c(0.2),var.link=0,step=1.0,model="plackett",pairs=pairs) summary(ts0) ## }}} ## }}} mets/inst/misc/menalong.rda0000644000176200001440000012220213623061405015421 0ustar liggesusers X](Hdeo{(B_CRJJYJJADQ4I2 IT(S}>9ϲ}<ϲ~7Yδ'g#pzpzE_hس)NONd/o'J47/1$cX2%cX2%cX2%cX2U?όd,Kƒd,KƒX/X2%cX2%cX2%q?$cX2%cX2u Zh?vZu?9OLoShJON>??~r'gh})@lb%7>O@hTx: G>-A8#@r{3K@hPh|U{P?9 ÌCӀ98jtnha44@to@R3 p;RW̿}Y{d_-)A )LWLaFMXx:AU+5^k?Yhz 4_9FMcܺzad5W$g:n(.jb#}S3i`ŝL-A#辨] xmm[ G_-aK{ޥ @~/ ?jz\3];Q_LI' ݗ捴FjL#+g5(WF7{-h/ ڤ:U0/.2\tQYy]y On ]]ySZ::~v{!pgWO ʷ+@\˃sqhAp20ìƧvT_eG/;Q[?7㌘ ;;K'D`̲w23Z>fB-=E =4{M:*ʆMҥꛀVp.9gf!ު ^ pԦY 8vbbm]Gx9S?B(P=Za>KHt[+1p*'ZNY+g<CtAޠ9gA3WGx1?}/+*`qIT9WGn܆=g@3﷫?h9躁s2>M#oABo^5QOZz@S6$9ƞ_4Ǣ}tzgo;Rcdlmٞ.9W'|8/"D4ucļC#>b p>1VwtaOTî#?浓URQ30M:p5ǩ?=M^Ր{1v> ٲ&8#Wn~}X'7uV{˹fz.]G@cLM,1]#xMd6(kH S2>]Dv_~YGkcnry2Ai"S/ RKvxh%_~* xUR1wX@cۛĿ lTR =}Om`jZ A*/Wp)(~=΢h&ȸe+f]\!/6w&c KnN=LU_t .TPwI͝Ye?Y`(ھ8Υh).V)O[:sÏͷ Éo ec=m11 @ K[Tbݑ1ryQ- xFN6$P2 XX|6e:fSՖz<_?\5lAc}j޲a _d Ǫwn=}vw@+l5B(;Ak(T>-9 0G?5PY4}j<&'@dz~70`Ƽ89`8C7Rp'^wACjB4X6 kQA8ggIepz?` ;ǣ8 C}3 9rq Umz/G0jnP|y hakQi ΤJ l̡(gSQYyS*KOwTx1+jՂ/}<LGѲGπ]εC ueRg[n [T֩Bqoߚ()7R Ⱛ?B;\ 6.֋}3v ;s\倯e?)Sٱ'|6g;b-[?mmcN+|:mp[_6RT^8&8 ǓV>tS)WJio,n'4gLہFsh =zYwOj sP}Zo*}`hk$nxy hxmJ@S 7λ.j,Y'|VNiCԞ/&f-kzHez5c{}rqVK];~''=MQ8i@m*Z4͞t:y04`YCU _Rٕ̞<2/<-a~7sc=EK.ƦO25:M7m X+2׃ m>۹,?O|q _r\y@i>yo1rVQ>-`"w cG7`p y K`}\qyErzN-C^9ZT^]ye K-|9s`;ko@i;(߇x%]9fh;ܖU.;&s/uX㗴6# ^ո :Qis 5FbW6u;5BWTu\XSIcg|^^MM"o>@nf禁yJSAO'9}DfTK9<{ŶM-2<̣zmNRp6Fo 4/1sܛ<`enuxGq[{Nm4~ٞZXOkpjQѢ|@'>t>P9ڎ1h\76 諏gSڔ}18g7ب<}99o5JOzv=.w~!|^wL[XT' n| 7 6nm툞Q΋q(̺ Dv+|"'x39Ǣ:n?2x]KyE @k|8B듎8er=uk'0QZv{~og+oTx0MJb{KG9?7(I \fz;-G$sq^GosR70Pٰu?00n_n@u 6ی8i0S~*0jgFAS@ê~f >/ت"Oq)~fvΎju~s[+;KS;etZ_ ^頑\#P|w&|۾ ֨?,+k5O{Uq@OZWlV]=9؁e[?MvǨY!eq.hnҺ5__ןU7z4c^NH߽ڪv[S2@ZRze{A1wu _Yi+|;¬/z_zyI 4Oge¡u:n߼{ 3 =j|Őq+[ \^uC>V/%PŲOh+F/T'UP}յx T'*_C۪#㚀o멉V$<*W^kDpqj cђק?+Fy; TM^7NQꃆV=>RcC̈+nfͷy:}6ʻ{<ښ6ԛI{M?t5캹n'P="8K7_ $F}K\#0&Wy@E5P=0^)(`;sπpX͝Z1}AsžU@?2?\vf8Orx\4oVjhVAD4ڧgej6@tmeSe@6{ G3]].*gT3خ#ͲP:}n():sY/fc{iߣH=F5 :j?0)RϽ́Ww>) b`o( @x4o|Cݧ֧.~4۶:I:n>J:Q-#{Kt} 4ꂒ1feoˁ}/ՉҼcړ+u\-`]cU=΀ FT-dnx>P/[4sycdV{LyFV6mlF~ PT1 )S!%> 12Ϫ mߗs{ɠ)z+hDl 3[wF \kGPKx ŇQ]]@vI`]Emw D|m͹o(Rc a80>0O;;c =١zbO>3ܦk|}>۳ѲLOV\2pCz9R^AsϠB୯TGv껓V{7KuߌٱJߪ=@u˸Q|r=Ꟙv t{LDu%vjI(.tJʞ[P?۴7ҍپP#W}Z'"hQ~^'3Ϲe |^`w/t|e d\Vhy>{k=o䷬ `&!wcMn+6껏*FoKJ-?\h/ }5[R3h}j>JN8 n躢?2́ "P_6׾ 0;.w.A`,d7Z(l^`J ?AK:mY³ 3 }6݄FvXؘN2 ɋz+_U=':[QZş쏲[.1VՇѻlcA+T( 6%p?m{EyhQ*I50S]E. TF^n@Vjnn^5hZfxW_H_109t'x>чu D:֋Wo" sTCS ႈw"u% }t+=C)_f5 ]nv"+7{MPAufVCc}d! ќ.O\襮_;-o= xQ|Cn7l3PufPwLQ)(B|iԾܚC?h`T\|w4pW[on@ݍVz+C}֓P0|A> onëPRTw~ Mu;#tlS.ǎjyN} Y ʏN;q&{tIPlةa1lԾ pӏ[@ϗzdzQCn߁~//xXYʲ@.k ;B1Ɵ6Mح>L |zz9:)J{L xK2Gp0#+<5G_4V`VHǒs{N~Wgu=8m?}!+{;w R}FLDfّF\7F}'@8|fs0žhFqܐڪT _TǸ7{k`%_AV_^ڶЩMgrہpE*Assȧ}.?Y öԚz Ŝ{{c8~.E-;8{eThtA)*+mjNaR(z2Hgi`h^`e++ʩ-e`7^q* E}v)p_AغJ'[Rzʧ# Ѿ q04::rqڤOFQs΍AT{;]߭9εQt})u/{Dyjgѣ5P=E^]>]%5az]-mC6?ԳLV|fΗ FA9;:7wߖau Q9KW @udD`[n c;y=8}|h|U_w-@scw~@9W \>q@dE=c?x>Wfx\Fo?L=[6~<.èCP}ݳP +ZPogZt]n V1ݢ=&&j`gKorgwTqT[mWӺ6S/KATӧD%029LCy^`\&cxq NfVjgꋎc8 ?~姚1@Uխ]>Hk+j0X-hL_39;'RxٛM?mJ7`辠 |gQ=5^'qj}6꼃/2t?O74=jKORFse:Uw̑zԡ P^ޯnZ9~(ld#p>cG7]RcYw7cѨΫVwzD> o/ԀhE9-2OzY\X腁V`s{|OV(~k {ɜ@ϸydnc֑a ? obڀv!I ɵ> ~ը?J_WيP֤Vuj칬`Lhd噭LVѺNS& M晢y{:4x}@ܮ|"Yrl\TG(|7zl }GkUQ'dfY/C:_9}n=s?J>ԭ Qs/XTP" iC7W JaHVy D{ sޱz;-ˬmC+3;^G6ԌY̨n@}+kvZwۈA8`)L-{"d5~#nY>Au~xɥe(?o"C<mF(w~kE֮hJ8yWxww7`*D|=%GK@kPճ xoЍNܲtey#>>IfQ'Ւ;?MxjM/[@2;l)PJiny2MOM3܁}w~`sP=޳⧠&=I?pLJuS TF8MM%[7=\ܧvh{~'<l;telp ؊WIQ}GKSۆaUQ0|فh K<toˢV`/u/en@u\td߬= qF3A/h=խ)ՑgG洮ON|ga*g9@LɅT(bD;?"jM*=^! T+SqU$qP N}Á*!u{PӶf(>s|lή^ZS;ʼf~O@}v/wb*f&f7g;aAKq}<Ф|KZ ˪T:~I@ ]KiniےD}`<g]P(*niޅ9"Ot<>o\ZOԷn}-0 +YS}v qyLvZ |W=!&(33e (uaRN4hy|Qϓwmѭ?N(_؃V| +θ7L>|(1'- PH0[>Z 兗%mI7?ج~~a.`Ͽ1PbΡt=/.K]Dn=cluEm^&s.w+k6Vj/ 3Yo_cBUZt&lg njCUq_m4^g=2Sxe:+wye_]w;*j UvvV:eбtBCXϰٽP`9(]}&8a::t] P}mzG(b%և 8 l )`l/d`Ƹ,,՞~^nɽg}lɰCQjs #|8=nU bԖ>@$? GuR:[y>PLfd2ԏY-ݐ,#{]3'T_|řS&yz|(OuUO k*7Q>..FWYGxlTڻFݶZjQ=,6"$N {٩.n[CqjY]9/@K6xeJQQ,JO`m<~D]\}ŏ5EKKHfFß@KVlTw{XwzZ^h2ʂѷ@Mh\)ߏwь8+Z3g.i@U-5ˁ"V6:أMw.]z|C!ouEcz/.<UкP=?#.@{[} meAvn2BuWQ<+X-~D촉 7=%4ˌԗ 7Wz7 t.sZ9ZEF^[O.%x 5WFЛ(?&-"LƲmQb"s6La8ޫgtw 5 ^{{: ͣ׊Ac^ԃVcMtUD3]/Ego8P b::ö׾ҟ@Tv(qo`5R|YTfqԸQ-(GǝD(lظ6f=/.n.Z"ӋS~3%wg78cxg$-rM(ᤉMx'3oX,DqVÞ_~J~$ڿ{&Նk#A0-{hyz|G@}O~\1j >|ŒW XvMfre>(ϯShY?G}hA اCcG6(rZ& ̛FLS@B\ͧ4.<(^ԑ=OO՚Uۣ尛f<ǠVY0{m'?]rW8!Ѓwz?Ud6)ІK' }ՏйG|9b}\l}^6stL[,orf Q#.?s}V+gxiゔm([.k#P ae@ߘ|o@'^,o?$uaE}/h603':tAfgh4xu[U ]p L~´+^2#uP*T<:\ ۯoks:+P q1]=f_H t;IV_`C8`6F.J3 W1f/ܼsPݴhX]@-;w)۵-tuGbsNZ pgvnXx ;g LR)kR s|,͇PݭiO | ye7~ۇ2s`] n^d[w=S7\svh^~<\'zeMAqpK1K5A}ܛ39@d|h/%~MAظL`qܬ~꯳`-BxۋFݽI'X5~@`u9ءg=xNqQ#RhX5g{= ޏ,MXD'Snu߀f7ѾWoyvsVQ3@վ[lhrjs9o 3DzX- {mcٷWԸbji\8x Bֻ/h^9Rc mJbPY]%ɛ@2hڷ<ӡh]LV=Qɕρ>~qySИAHk櫮꤯_mߛs՟ޯ;?{ﴃf 16n?Ul\O2ú߃` ûPs$t7($fNE!Vh}؀zE-uH>Mϱ!/tL#׿=&kD1goYO@^nB&൅lw DTLoovKmv.w3\AaƏhs00M6; JMp.`'\]~fO*1#5)u*ʎz;=eB Q=?gc>m90aJE7^W஺ `~I{AIXltr9 GFuGqAXts>sW6yFIYn֏ ԦMFϟ\At1&˪_⎺3o5۽O}~o t7reꌮC{c(`R/>S#Sm?nkW1oA픖T8 SPxif5Uժ0>nM}gm{Aj@`S^[9\4`?Vsب P=d+t4p>]<Ay\h!V& @(lY{}{Aa.7,T {i7q~m%<5CϰիP'EBL? zr9-7~ݙ ܣ‹#P7UYJrBP_s t?-;Ԭ0x|}Dg;E\@\`3dm~4団|tkAIf"P{//^MkMUW˕~ 37qbBxjfМt~A5uOf)/Vpr>ho9rS=Vu9՜';sM>GV%7B}kfvAֿLռ@ŋ*Gq$jzCOjTĚ{=pO{>3B-eXW,@*Fh:4\5hB`h2OWC%pN\>Cg {94E@%ؤ u3)m_ڬCcWZߥݧN(OY{FM O|;\|f0)O >)sxpEC^&:NCv0 BwMסifՎzcu/K(Ǜ7έ[rPkxR~ K3#@8驠P'S{opXߔ P)~0Lx/Ʀu) ,l)]85{Ģu$Bw&P_4Ok͆s@88{!s|= [+>Ϊ{iv:wlPi~m\ǾUY23DvdlmB|]bSͳwtvZIyޛzAzzNob*wr8bnvYEP!0^/\qM5F姖zI ţP?lKG¶D=]5?aMjkӀ{z_J}T7UC\Ƀ]^J"c>('ʛlO??^?S$hRʚ>b$Ч_t5(jܙ6`]@r z="&K#V5[#N|TAuTQ0&/;f>(;>j lع{@;?Ph X}{]9t#ОӺo*li|t/ *l&zޗ_P^`x }v~+uKRVM]Mf)aJ}sx]05bd|lt2]@qIY//~bp5F +1Q Ө>7nyQG->y;PӲZб^~j_s5_%Tgvo}x{J@\b=ph=;9G>x">#= zܑ\St`3p=u1-, -ԗ0U]r?P=WkͅWx/+_ByQ3Q Y}sPgw0hQ*# gi|݉ [ۣ8؜@MGyU\o}+{ ?g櫍~Ʈ٧i(z섮4nxlҋ4w!{?V<Ż֠u4q|{{$vD684]>{ xw ߍ@8eݫչ(j =rW~~,2Yf/C9־#hji=-X5}|>Ey3p'^/r?&}0ZΈX#4ծ8WmvC-zwdg/:I(>Q9" >ϯ#8bUΒ;1}vN>l]_އ@m\aW>U,v-WqtE<㽵s".|.;TuW~UYXx .}:.c5,5'_SnXsVۋ⃪񖵃v?(P:f޹4__tl|Wuql.=η-ƮziL,`8jUzt}eWGz7=MdCڴ̫wWX{6ټ@=,/#ꧣ}q`CG窸AuW˾ @q0P3@u꩎{-zBWS%+2KXͨ_VY91ޭ{N!3oݭ_ޠ>yWm๟vG5T7Ay[dr.M~E\Swzԁ[YK@t by-[s}ъfquF{yr{wwy BE}YC>~l#ܛ* ɑ[y`{>፳i0=3cΙ省&*u.5d=o*Y376xE]yY\5K&}#4y9%ι8@kx`^Uu?mjh8w4U:7o܃vޥV{A-r`֭Q#Mti,V1Sc?dް[w  $[뭘}.p8 j)S?G[uzP {>@rnp#,Lxo-s ɩw(u;?g5e;>dYKQGuoƺ@o~gBT6j٩⻣Px4(˺D{nm"?-_b:W17DuH}n(wGcn|GfRU)EOoY}"vf*4zfg2aj8&e9~EXKGe;KX}M\r%\Dq5QzY =ϯ~`a+>1wTPO>]6p0`f ѺjŽwޝ\ Д^Si cD_J< \k/t𞩻=Y.@G>'-TO{~˖%zjA;3F:pu k@H'@V%K~a ~oh^{W,aqкM>4=]nO&MеbO7TlLToY<ү*)B<+ݼC#rIϛqd.($:Ҩ><0C0L`6&j[h}doz,8l6c˛AѽdT5OJ+\+S+Rr#[P @`-iϯnHC>rhZqn/GϺ|Zyɠ̊{}.9=EnUZ:c Fx'.'O(U^L֗[~wKO-##k[;yaNy͚-ֺ-L’?~~(z[5%uìlU'8|aEaʑ)>:y򽝧VUTlvtoyT*0(ۃr8k_[~@qZ#; H46F׿fxKQ`TI24Nz}mW]#Q?K(oJ3ոqK_@X~/i܌?{Q&6gP'{o'f䬚1dAuK+ڠ*kygw)}x4r`}< Qw %KxG輾F6~|*_Pt`cčۧ~VOT֍pz੬_;"+gg WNN=)Wwx=nfѾ0HΛ;Ft|?*;qsw @üz[V_6Oz~QUtqm#=;\Q[TP-_<˩ ]~5yR5Cz~Uv{,\D5}hy,Sݪ~@SNf)BNX&?/bfx(&_-qޙ>ն:=ڇj QݕyySỄ t3:Y x=^Z{JL6Y眴\tMeÿFk2Mg#{٬Eh*Q \%ceW?됵W?F^\r>?]wm-:q{w4cvm/^'M;Ũ^ՑQurImhm~n8.{Ac^jcSn,x{2C֖jgwVNTM瞲xQуw;6ƞ_7P4dFD@}]LGI.W3(@uQoVnOGKe0N?l㌶ <{}k_27dp,Fn5˟rsS|{6bt6: Sys}l >i*:nsԇw֎ g6j L^kQp%K{ y24_S5xځSfkٞ4YTvJ{.z V LѰ&9C'hfG|ְ'7fGr󊞱tO|hFϕkƂ Y3nO>BdmN@[h՘U4pdw\> HYETޱR \ǿ{{ʷtfxZ4=_EIMMIvܘӝ{D_RBu3+]?Lbވ>hP?0wl40|HrZ[p>q(hv\69XF]漋4_}.rTVzvO0Q 3v.kYiWMQvr@m>x#wkA#ɍ ˫V EGj[:hq07q_=s *P_+ 4#"M{5f0:ש 7Pp)/5 } ޺ }ߪ]ÎTO{B2pONWvų>v 4] /̰d37maՐzSQ/h~2Qݺ ʨf3h1i}dz^:OW:I æuRg~gi +b[ņ\PwnUɜw<3[_١5p]97^n ͅڅA{B,_29S杵BGί4B֟4BsFmZyi+y gQ(p4uXp[?F˥:[zDYO'DqI[g(М=W:w._!Ens@c4'Ax۠taTk~{C-P` FB[L5cP4fZ6 óOwg7 !V[Y,恍Cb@#B.G3r\h+T*)ՕTT wyӿ5׏@kd}~4͕4:&So3h1h f}s.QpfoQe>$hۖq 0)!T@;r"-jJt=z<5/uM͇3Al4C০~q7hWww:˾gU}nUއ}_9y}UqU=8O믮_/?{_ۯܿk_]w;<UĊȉWۿ3;ę߱6~Un9ǿ+~1}U䯜ۯڃ>Uyw?r:{w_~wr_~=ﶆy-Wb?7o3gg;]=cm^Z{s5kUW]سz߹=+c1{?X'kh#+\]|;?vJK鏟g%yɼd^2/K%yɼd^2/K%yɼd^2/K%yɼd^2/K%yɼd^2/K%yɼd^2/K%yɼd^2/K%yɼd^2/K%yɼd^2/K%yɼd^2/K%yɼd^2/K%yɼdo=~,Ae NPhc j2E#MPx#8$'Bp*A@RsqtAϝ!(39?אCPsgqslAϝ!(&k!(s9?׌CPs9?ׂC y@PLZrA1;C @PLZqA1⟻C \kA (&Xsm8`]!- ,v@PLsA1⟻C \A (&XspA1!N:L&XL:q lK9 AGb 6\gAu@Б`2b ?w:A HPL0`1!N:L&XL.T' &,&sWp l#A1d~:A HPL0`1!N:L&XLzp l#A1d~:A HPL0`1!N:L&XLT' &,&s}8  %L0`1r ~*AeEAG>c &$XL`!LP  HЇ`,d l sWs*T'("-:!(&K0`&b\?AeEAG>c &$XL`CP:AA hAБA1X3 ,'@T&NPDZt$CPL0`2L 6l8  %L0`1r ~?2Au"@Ђ#Ab f,&XN` T&NPDZt$CPL0`2L 6l9  %L0`1r ~n 2Au"@Ђ#Ab f,&XN` T&NPDZt$CPL0`2L 6l8  %L0`1r ~n02Au"@Ђ#Ab f,&XN` T&NPDZt$CPL0`2L 6lq?Q2AUyEAcm:t%CП`X  $G` r6l#n%LP:AAA=@ИA] '(&A0`di3 ,&XB`5~8e *T%NGPDP 4&hAІ#AW> F%@0`Ly ,'XM`36~fAYU # Z!HЕAbc &L&F0`b% Vl Lয়!(KP*Au<"z1A 6 !OPL0`,f#XL`9j  s8e *T%NGPDP 4&hAІ#AW> F%@0`Ly ,'XM`36~n8,Ae -t$JЇ?A1&L#I0`1 6l&F!(KP*Au<"z1A 6 !OPL0`,f#XL`9j  sDYU # Z!HЕAbc &L&F0`b% Vl Lয়CP2AUyEAcm:t%CП`X  $G` r6l#n%LP:AAA=@ИA] '(&A0`di3 ,&XB`5~ T'#("G hCБ+A#L L0`&<K&@`O?w;,Ae -t$JЇ?A1&L#I0`1 6l&Fύ%LP:AAA=@ИA] '(&A0`di3 ,&XB`5~ T'#("G hCБ+A#L L0`&<K&@`O?7CP2AUyEOqyR:)O}1Tt. 3nMí|OX ` ݘŒzl1AU+0Jf%LJ?Ňuςu7c?7(;G0Y=Z0 S0лߋ%RcW+s kd.^\d4./L&GƽS\˃s0فR}1b0'ǝ}8Qx&{BRM5T8 ~=<#b z~o8~zL~bgku)۰ &]7pNƧI쨉ra 4( ?F7)8=sK[1JlO]\bS#&cļC#0VwbR ZVgd>tr7&{UCnLA>t0Y;/b}=ڵS0'Kofg אQ1Ev_0C}&W5dmc\c N52Sh%_~* q&[.S0V L6QxYbs;`2V5w*c;\1KR&ڣv=1YG|¤k"0ES*(S K[ށ坣t}[& SIe4Scm18WY/!fPLFէo1z\[vZı얜e1wf-<ɓ_or"SHqSCjB4LP%iC}dNH$ĤX r. ɼRYu~&?ܮ: SPPY?GO;&;*ن+*+o ^ۯhU &Q,3L㥘~kV^]I_UoeqlfMLmcNc zK1iuS(ҝU pֳ_!I1Ks0i LA-sp&JɆwYI=qL*axUŠ߻~(RSH/-XIݶp6^r̕qیf?U¤\W` 4u*NNIP=rwKїv;ܹ=zYa2;̾mh=-ON52w4&;"c,2rYL~&q%&9N(?(>LjOuxLu֑FK35+P>Ggvao<}ZĬ|mܨW>ƤkoUJL4r~ _R)|? S+OXt2&4zsƘ,]sY2nqk~ј~&L{^aeޕg1ᵷ6Si2W1`Kґc k #?d'u\XSItx~Rz)40Oi*Wl;LFd6'Lz|:L[6*S(_xW9ڎ3b'oQg)w w֎1Ev+a2h=SpfQcm-L8er=ڲ@\R㞘la R`:S(^?9s)`\c/OM:S0yVuatv|WL}fߋwä.?a#^bc2 &_;cL&0c^߽ڪqFt^L˻#bw8= Sd-gzU5Q7F/) UI=yULqj c36={8LQ~luΛ8ښ6gb 캹n'Sz٘}wM?`2 Ea4wja Gmc$c_;loɜ?] wCy/+&uyY&tK9,&#\Հ)H?6['JܡSS$b1C^i߄ɨdpja WHk4Ƥ^=:l1= L脢i|5cdB1MƤޭg3&?|TgL_ss8L0aӸ+-f49zS,Ugs U!&o|JL2xLV8o{Kf.]R1[1cңNfŤ/t|e)\=0IwȝIߖZ[_veXᘂD/]3Lba2ޏzs S*J8I٦>m`0[Ra2fZuS`w]0&)*~ 9;.c2Ƥ`^?يICa2=:0فGRL]SXq<ݍSs\S)z`߮J\ޝԕ`LS6kLv"+7qY`K]vl]܄)h12AIML n3Ƥ=iۈ-Džëp7;I}bjbR֘=dׄ/ /Zt nV2-STq޵hpL6/t[k SdF{Mre Ƞ@wLAÀlDodLA m1go-='cRTWe/&snY]mV~!LzΕ^hyQN~'&;50>pӏ[e/)u9\jb2 J0ك0Wdb"U0=rnaX\'Ei1Aʑ{0c'Uda g+q}!&J1>8}t L!UשS/&t&ssȧ}0٠Lk.E1O阌aR(j4?o0&-5D~ML~)&=uN[sOc+>N ST{;&0EJdM.z]-$oŧamDַ8}|&kU Fv{[L~X6?/p1&sJlF^0.$~%ه%S1_5 b.`NfYp~6F]Tۂ_R]*& 8 LynytLFse:l~us2L|_&3-u=O~)~s&U%38iU096_)5>j&OY)pZ(ɖܽߎ>d#&_]sLJb[#hE9-}|0\os1EƘu`ێ6//7N&oSoaMܮ|"&U3Țt~lW #157]ɾ-XYfv$&{ sL+30QA0=[km܅\/R8 SedHnA1Z`R.TlLܲt?Q%w~*&:x찥MOM3qD{ϊɟR22ЕelkmԚXLX*xmLFœNјvS0G˺]0E}Du>~Is jd@_'&m;*IFeQ+&?:o֞RLL6LpHL~{#0E;?cR3R>*8j*&c;a~ )c/)Z˞d&5~V1}'S(} &j8U斶-IǤ]# \فI=);SzCL0冽w6ɋ;a5}w͸S`|&=QY Lc _\uwQYI t),.T: ]UU&3rc)3ؤ"L&YJ&|܊1iQw%0هGNKLܤ1&zI-~ 4B8LZ1~lȂ8L^m}tbqǦ_0RSM9.wŤlf`!JZgio\i)2GSء[Cb2 P0ULXo^(K16*Lz&EIbG6&SҺ wy8;SK6-xIܦ7_GԒ%jc6cW>SлhF&VLoӝK1^\̅e__.'z :ASn4zJ>&?yLFn檑}zQb"&̻} PvApSLtKWH+LA_zL߉"otb OX#ŗŤ&5}K-̨{l_: .HgJ`&oLQtc ,umܼWnC0JE9`55 BOBӡ1#07)^ѷVkV{+W[Ud6)rĜ#קcbc S}ϊtŤKL[;eԉv7;a2Xp?&ֈ4LzP{ L*wγ1gZ]]Iߘ|oNdg1/k0Y#c Mud'Ř&/X96r & wqpݩK1Ed'@L&_ĔvL[|@^&eus$p -kLbWvLu͙LMAظLL y[R?]?c&LMXUWo-۫}S4B_La;qŘw_L7fL/IG%Wjh>d5UW~{PLj,L1f=)GyR!&"^+LB~1&s 0yn"d}T/Ĥ=7Sd5jIL^-:)bzr9-/a2}C_ŤoQY)28(xzLkAIf"&~+Lzn5f3&SX_`{zBLΝ9)^1FUĚ{IFao^2OWc=[f&U}I{3ɜ27UzoB m0˒GƤ7<{?S8驠wLL] 0yKCTm¶=0\j H:@^+oeStֵ!L]bS0{S8Hbn=?+LaSz&݇&L¶D=]`X/&] yl{svYLڊɼ\"wc7VSX'g ;mI?n0f8&HgeGL~̈i&Vd|GޮMc=[}28ILi_oHji}d^wl:7є ;wSUӱ&9r `XWa&k{G1M]M0)=ѻ=qdd4_?ݎ)7RLvw}O/`X5:|O]yF4VuPäWϿI~g<:f8K+&6] y὆_/NLG@clqųWp.L vVbLtJY͘ԨUpە'ybwdg` >ϯbRk6(`2#ٺ-d|XZɜ-Kƍ. ֜<M:x&Pb&}[Uy&k}"̓'Ǥd`1^Ho_iɄi zZUޛbg^;IXm#Sq0P3(Ťއ1=0Y L9;0^)1#xᦿ8k^&wIј챊!t阂-[0=NJC16|9J Q&3֤cԓt!i]՚ނP80/' I-hPYG8&}e=Ř[eLo0G-RoÎ̄'bG]9m)M2L d |3=UX|w<&{nm"?w>7;wz{RLbbuGL}AA730dsvpRl|Qe#K6뮭Ťm_!Ԇ)ykU-dY[Ǥj8E GGԛU0[ǿd̍1نrsS|O䯼 w- _0YmB;=b2EÚ| qߌH}C/ Y3~)W~U"`R/tRYMLZH~&4&,kQ`i&#q+&0mUu&%sKgzk&&[R<2x~N%%LQP\U1`2wlboJCM&`RY9=1aP&]yr@pL 0鈣_c_=s *~wzLSR 0*y{&`Od'$c2k/}.J6VQ/nЇ71YIJ')aҗlW\MT;d &CK;c^p"&3ʼVJC6?d>; ދ)$LQ֓I7b2+\nSxۘTǹw?fY3&YY,b2+ =6.ՒŤ5>yی,ZI١>&cL=Siۂ|k2v&?5 ܈كHqzr {y;yF?~|q^?iӟooce9Z?zߕ_Ԛ0Qϱ8-?OwH?SKO[I^r5q3ȣ^"r =t 8yPPɗQ.G&Ya%D=soC4$Ҽ?WH}ZliS^mjMYgtK49@̾<=s>j=1 5JpuڕdۮX .`/w.g:uxHw쨳PA h:4aC)Б#ڗhDPdΞ`d"([6r{$s+!%[* -\pwζ#܋ɀ%[Lr{&DIDpw@N'nqlbBB>G;ХyuoC q)%yϤgRJw{nuz{#طU=Zʎ9ngO ە4^,={= ^ #MsKW͕#eKw(#`D \PŏBܓ龇OCv';' '$ZS;lbO1)߄SOp ;-7YKk1߉2|~=f }Yȧb;HD($f?o YJs{%x!B aY֍ i{7Kf< . doXth(;$҆z:A<!m?j2FmDMjrcJ3Ėv׬%d-7jT0_%Cclcg g3, yAUd-rE9h~/HaI4k$]I߄m4k;i+Ò+BVhBCF'Q"ˤsf ;H,wo5cʧ RX؆DnqN ~_9( jp= ѵH͖ҕpS$-Y SnAjN h(`#ݽ:(U>MTQ aKrjTf<ҍ.'urQ/<;BMaHupn.L L`%5iMxl\DrR\IeZ}$n :6 ӲVnnwyXY,!JҲ4_ÚL\"vND*F`hDd)+ DDGryq:d:QrNMNqf9)I)kRj6|JHŤհ Lv۷[~U`=P\M!}j_`e +k? eBI&~ WTI 1W;79DA)LJ0eu?.?D:ԌӗzdY5Z*rP_-,7"TMɃ݋j*92aw7mAal$7jID=+=V.aIi\ Wз ,E7]>Vi%}*rסe’C"_qB ,qWń47LskDsr%J)(1٩5O9|񑢮l(@5TiDT=O#&HuOQO/ 87 1^4Fc!WRs]):mi@94&>KRi꠺ _@VkSMMXIT'Vs.sd*LEGqro0'J*,7qN: '1Ed%8xƓ!ndr X&E|XY|O]YRwv$J+Y6·ߔ1#e`xmPQpwɷH`IůXc`c.*!9jR[IXJ;=JD{)Kj)AkAhI$N֩T9Z߯&$#̀WyքASi/ 09t=_h ^$q vhhχuQzHp saaӡ1M8s[s#]gu6ϝ! u />jU\Q>!f\~q}g.J4=k @VEҰ_G&|0iȆ[K=E2\{.;(QAoжN=%6 m\\.x{g}︉ZZMuN}x/B0AL'-NG'EI/qh3a6quua;~,P9HEp?Lg:gtK-IgmlkQd5v.s7G~wR\} EY&] Ohꔳc/|/<Y|ک!Kxr Ÿ5j&A*0/KrIi짠0,Yy~Qyh<#WG6&4:>,ft~NTt]3GsĿ:4gO}E3=чM&;5 B\?_GƮiܻx]볦e;XxgWL]3#}ԨOF)#40.D2ܿwg\Zj~ȳ`+g]Lz%Ń3,,Ȝ s ĴH&1GX eљ=5!<}[Nn!ó(34($d4u6IBR? ֌Cp7g1< RN ЁIoYX&OKXi)E~ŃNuG~vpghТ؎>p6IVk |-rƍyL˅HCR?neu7pIB# IQK{CL̓qa, }jS; BܰCmyh~qO-o mӔYw 3z_*s &˳r{hmi|ntfL!_(;zBOF\Y#!зIUdZ q$1|׏ˡSAbCRGYಧl~ЫQ013b~Y/ψKNX)etB`NHuclE 9] Rm%-b[M4?ȨydK}g#5QjĖ}/0|ϡ *X=2F~f?P ^uxދ8kz^|Jwg|uiRS3`\o#[:"N\qe` v+ i~@cL Δ{Fo1*SL7x&K`y 5缸WXw 628Os"~93v\;HM&Aѭ[bэژqFmL%5EU#1ŃLp6 4ήByI mۀäX?ɲƏ{ZEOi؂-`ׁOV?í~FH,jhA0,"?/>[+4 2?H%yX6%ql2?HˢQbE?R7h5$-ak3zܯ _2?OzxzprGѡ|g/6b$‡L&1=E(q/ _:J6x\|C5|AM 3|#WmIhCC\1ptBM; _]`BYF-GX֋,egb@S߸ă3]{?OP$.]3?^Y d>y|j = y4lfdos+&uf9?4֣. 'ЯѨ)5̍Q'߈W7l6%NKiPTg u[zT=U496`V71+iIfx%bzH0jnI瞾H<YjQe,W8>nYPK 3h4>Ń||L.| }@FLq-En((bg3ݡ,/?FlȧCe3tʗO!zQrd@<-7v#DkQL='o=b֓729a//pDl F Lb"`]ėI a?.폳}Mu/Apzz31p?Oux;E?;v[#eiǥq}k^`:BE=FaA[#Af>6?H/Hu,.=)>ZN2y?y' zQ|88<)K>#qFOOkVү-_o=?_~??MXmets/inst/misc/cumh.png0000644000176200001440000000374413623061405014604 0ustar liggesusersPNG  IHDR&-}MPLTE !!""##$$%%&&,,--..//5599??CCIIJJLLOOPPSSTTYYZZ[[\\]]^^__``aaccddeehhnnoouuyy||}}~~_%#RIDATxsTUᵛDņWD@ v{( n U?0G{_nܴy틧.wFb\xMGl~]޸.v\l]78=}|u\N=tã{g^X[ ^xs>pz^wOY>qZߴwᶷufYY9t~h6#cþg?=Wo _>[ɑ??)k϶'M|q]츦a8qtc×Wr2uݰ?{ofS&6NY{e=oZ8> ufL 738 _2Mg8e٦diiɉq]츦ƾg]9:g_N>ܰ?>aj8O&>lY_ɟG629qMݰkK|7{KϜ?{[VwΛGoݍLN?q]츦v.؟Ҳ33uᵋ.-;3%Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB Ȅ@&2! LdB >TyKIENDB`mets/inst/misc/twinbmi.R0000644000176200001440000000464513623061405014737 0ustar liggesusers# # BMI data on twin pairs # library(mets) data(twinbmi) str(twinbmi) head(twinbmi) # restrict to data, where response is not missing twinbmi <- twinbmi[!is.na(twinbmi$bmi),] # install.packages("lattice") library(lattice) plot( histogram( ~ bmi| gender, type="density", col="red", xlab="kg/m^2", main="Histogram of BMI", data=twinbmi) ) # BMI is often studied on log-scale. # boxcox(bmi ~ age*gender, data = twinbmi) twinbmi$logbmi <- log(twinbmi$bmi) ## Saturated model a <- twinlm(logbmi~age*gender, id="tvparnr", DZ="DZ", zyg="zyg",data=twinbmi, type="sat",control=list(refit=TRUE)) mean(score(a)^2) aa <- twinlm(logbmi~age*gender, id="tvparnr", DZ="DZ", zyg="zyg",data=twinbmi, type="sat",control=list(method="NR",start=coef(a))) mean(score(aa)^2) mean((coef(a)-coef(aa))^2) ## Ace model ace <- twinlm(logbmi~age*gender, id="tvparnr", DZ="DZ", zyg="zyg",data=twinbmi, type="ace") mean(score(ace)^2) ## Convergence? # lnbmi.flex <- twinlm(logbmi~age*gender, id="tvparnr", DZ="DZ", zyg="zyg",data=twinbmi, type="flex") lnbmi.flex$estimate$opt$message mean(score(lnbmi.flex)^2) compare(a,lnbmi.flex) # lnbmi.u <- twinlm(logbmi~age*gender, id="tvparnr", DZ="DZ", zyg="zyg",data=twinbmi, type="u") lnbmi.u$estimate$opt$message lnbmi.u cl <- lnbmi.u$call cl$control <- list(method="NR",start=coef(lnbmi.u)) aa <- eval(cl) compare(lnbmi.u,lnbmi.flex) # lnbmi.ace <- twinlm(logbmi~age*gender, id="tvparnr", DZ="DZ", zyg="zyg",data=twinbmi, type="ace") mean(score(lnbmi.ace)^2) lnbmi.ace$estimate$opt lnbmi.ace$estimate$opt$message lnbmi.ace # lnbmi.ade <- twinlm(logbmi~age*gender, id="tvparnr", DZ="DZ", zyg="zyg",data=twinbmi, type="ade") lnbmi.ade$estimate$opt AIC(lnbmi.ace,lnbmi.ade) # lnbmi.ae <- twinlm(logbmi~age*gender, id="tvparnr", DZ="DZ", zyg="zyg",data=twinbmi, type="ae",control=list(method="NR")) lnbmi.ae$estimate$opt$message lnbmi.ae compare(lnbmi.ace,lnbmi.ae) #CE lnbmi.ce <- twinlm(logbmi~age*gender, id="tvparnr", DZ="DZ", zyg="zyg",data=twinbmi, type="ce",control=list(method="NR")) lnbmi.ce$estimate$opt$message lnbmi.ce AIC(lnbmi.ace,lnbmi.ce) twinbmi$y <- twinbmi$bmi>25 lnbmi.ae <- twinlm(y~age*gender, id="tvparnr", DZ="DZ", zyg="zyg",data=twinbmi, type="ace",control=list(trace=1)) # GOF-Table? # mx and openmx for same data # reshape wide - twin-twin plot. mets/inst/misc/orgmode2.css0000644000176200001440000000310313623061405015357 0ustar liggesusers/* orgmode.css - CSS Stylesheet for http://www.biostat.ku.dk/~kkho Copyright (C) 2013 Klaus K. Holst Author: Klaus K. Holst This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . */ @import url("orgmode1.css"); html { background:rgba(215,215,215,1.0); } #box-link { margin-left:-1.7em; border: 1px solid transparent; } body { margin: 0 auto; width: 900px; } pre.src { background-color: rgba(215,215,215,1.0); color: #aaa; background-color: #073642; border: 1px solid rgba(0,0,0,1); } pre.example { color: #222; border: 1px solid rgba(0,0,0,1); background-color: #ccc; } img,table { /* font-family: Monaco, Consolas, "Lucida Console", monospace; */ -webkit-box-shadow: 5px 5px 6px rgba(0,0,0,0.23); -moz-box-shadow: 5px 5px 6px rgba(0,0,0,0.23); box-shadow: 5px 5px 6px rgba(0,0,0,0.23); border: 1pt solid rgba(150,150,150,1); border: 1pt solid rgba(0,0,0,1); padding: 0pt; margin: 10pt; } mets/inst/misc/phenotype1.rda0000644000176200001440000002006713623061405015723 0ustar liggesusersZy2#$<۵ ~%_'-LVAu]JקR6Bsxw/޽CFߡhھ`jۯ%+wOgVS=>fjWY3حfH~:xp/OE*LSdE| ~)[+A^kz7ff`ǻ'i@4zpWh{)9v@'>myۏZJ`԰|𛃒>}mP,>aN-#F ׎99}_՗9^}~$מ8 ' nY%uu"e2Ķyjm`/)BȢd\/7 +TRHaC7g@xҥ)F7&ۜ!v`ˉ%!Џ+t ߦ͝IEv֚DUWO"NeqV@a-j"y*}pv C^LN]=Pkurn9g/Tϯʦk‹ !(k{GM^*2Ty[8ѷ!l"̠WCEbmF,.(4HG%\_d&"tG 9#,i8>`4/N>v?!r'M$u3w0/ GV| F捠V툪:ږVn¥rG{hɬP+*LBcޘcM-Lhm77!}(SH]l&LuAsTC7I_V(_03p,^nϯVm<{PNNpoٴB ޯI>QP㕷*7ÖxZ'[GJfQSqFe>qڧ=~ns砶,cxr ?- udm\8L>@/!{ ?я my[/:|b5Emb{t菑 !BCxjo"*,L>~@Yne zY˶P>J`a|K kg!^ ׎kU=fxoVf?|堊 '_\N_,.n"65!uYbcb)-m{zs7AJnɛ-p3OQ '<|}0H{055~df } Zv ?u! N~y K'ު9$/e1VHUϼ2z=i We[W@L ()867|5O[Oժ=1\= jӻ \QJfn]=Lc|-刑PTmrazuspz(vJ3/-$`{Iλuɺ43]zb :hQ ;\ ܺ9Xfl~F܃d qꚖ|rwjnMJDd=j3 'oj֚{>O09nYk?mœ(US> #z-3ko-ʅ\m?!;"28D/CoW,mͩ-!ČIվY|~ &@LWGjuPx)8g|V'w<Ϭy- 7:>?-ܿ'4q@ϱ/ .O/tc,?n-㧧%q8'FqXiɿqHU%YXȒ!f͕Z4-[Ӂ䩹&󛢠)=|VJp @D?m4Oy;͋qAeŌj 'MKCrMsI's[]!mhr}QP*|2+(Rp=[/3.gw]6Қ rQmGxާ3;ΩQ>4?KUzyr` CXItٔ!Z}\ҟR?&ϾحCb!ȴXv8 ԽW1o}X ģ;'&Cx"rHG*8}yX]5蕋IOvfKgZ͚~SR@  Nޝ}yP590{Ev֤@ͭ;g>_W6 =֕k('lޖ kB$:=0 |*ߧUX>z ΧZ ߯^vCtrq9 P6D'^h ݠۻKNHCg97b@ĽڠsuK`^E@m}*y: ~yF* X>Azm6jM,Ӄd}EwM5)8_-  j(+h8g8}_l(q :3b=3wrW͘G.!z1f(\>5;u,.Մ!O}^Y(Ds~-$kλʫ%EZ^ȨLi V=TEg*A" 8ԣ''}q3Yuԇ{U\mљ㮎H]p7iP*6 ~1֯7˷ڃY*:t5ki8YJ]"__Oeq˛_n'|Q/J ^ a˽o:TB:qŸ`~F|Jcૹm6'8-DwͰ ;:AyrV#?jHj H/15s[]Qi xփH߿Eؐ؈Ů쮾?NL1sSs_:-/xlD9*h3r0sΏ!=ʊP޶rm `~_Y44zQEУzW}q$. `?ҍ[p oVrh=x!ȡřع^ s n+':9>5 8s(Z@nR0+%O4*B y!|цd[,=0ժQ0kn}_@|} o@!ErdO-tE?D Q D?c?/gqNۓ!w}jsCxuӄJ0Xu9q8|?F5y50}{>)%uqxum.=t /T\|:4Uo~|&"w00vI.ܟ9RYBjgpgTLƺj @] UY0717Lfiu:£ެgEV'Yv>ЈLK|D{RKms[Hg\Ԝ' N&?/+ =w?yل6 GÖ8%#C 0}د̰f1w ,]?w"ßvBU-/>r (l:eXB%ŷHߖq?xJ;zGd?gh|4*#e3k[.4ș=.hs*ѷ-;=A;f_0K.,0~Q;zd0VB4^&X.# >P6!Axcnssޠ'm^usyNbFOd#߻ͅ[2B@sJ<֔>cq.ZvyҼNV:&·7ްx^ [^jN/#C=C#y [A4)|?]Ƀ M%o˵f;~a[gK{*7.6CyxKo/+NO!~|9?1ZBx_BPgLZ&A<޿)!ӟNS(~!*Ex?ēJl[Jx%jPc_l#up:tep 7YLeuS{/!e}5kp]ڢ\ΨY}v;S=Qp jAyx cS?}6m ?H "ucUj;RC6*Ll8ѷW8Ѫ??{jpݛkjxHZrY 5Ԍ2URKʇgJ=sI7XvR}gJ/Ͼcw T4^wV%"qopW4߾gD%"u!xPl=Ā7պL3SP&cGWӟĂ-5MD)ˇxȂs3Ci+*׷eAM^1MVJ@{ׄ~V1g!EtCoHV6F-!Nw %z>D2^; u.99_ߣwV{|}kVu}5>:^3Yc??gucYYkXws]Y#VwƬk>;{;~\tzdk|;lu7\1nwqUkqwZ#ݭ:KW''\.o]c0% k.ww哮tYu]K֘;l+t3,|t=]ʊ'Y[r'=Y슍ZYkvɮtSw?iZw1^e娻E韸De?YZ~dpq`wsʚś]}u͹Xn[Wut\ֳwuwjw9 p'O9Yݹ~EY5eXdiZw.6]O7iݟjU֚/kp ]sҕ{0?#^+7\{U+<<4#WwCϮ=?7p2\5( l߯pׯNɿ~uYY#cЂ ʿW_JE0mets/inst/misc/workshop.html0000644000176200001440000006120413623061405015677 0ustar liggesusers Analyzing twin survival data with 'mets'

Analyzing twin survival data with 'mets'

Installation

Install dependencies (R>=2.15) : 

install.packages(c("mets","cmprsk"), dependencies=TRUE)

OBS: At this point you might have to restart R to flush the cache of previously installed versions of the packages. If you have previously installed timereg and lava, make sure that you have the current versions installed (timereg: 1.8.4, lava: 1.2.6).

Load simulated data

library(mets)

The dataset prt contains (simulated) observations on prostate cancer with the following columns

country
Country (Denmark,Finland,Norway,Sweden)
time
exit time (censoring,death or prostate cancer)
status
Status (censoring=0,death=1 or prostate cancer=2)
zyg
Zygosity (DZ,MZ)
id
Twin id number
cancer
cancer indicator (status=2) 
data(prt)
head(prt)

Status table 

prtwide <- fast.reshape(prt,id="id")
ftable(status1~status2,prtwide)

Estimation of cumulative incidence

times <- seq(40,100,by=2)
cifmod <- comp.risk(Hist(time,status)~+1+cluster(id),data=prt,
                    cause=2,n.sim=0,
                    times=times,conservative=1,max.clust=NULL,model="fg")

theta.des <- model.matrix(~-1+factor(zyg),data=prt) ## design for MZ/DZ status
or1 <- or.cif(cifmod,data=prt,cause1=2,cause2=2,theta.des=theta.des,
              score.method="fisher.scoring",same.cens=TRUE)
summary(or1)
or1$score

pcif <- predict(cifmod,X=1,resample.iid=0,uniform=0,se=0)
plot(pcif,multiple=1,se=0,uniform=0,ylim=c(0,0.15))

Assumes that the censoring of the two twins are independent (when they are the same): 

incorrect.or1 <- or.cif(cifmod,data=prt,cause1=2,cause2=2,theta.des=theta.des, 
                        theta=c(2.8,8.6),score.method="fisher.scoring")
summary(incorrect.or1)
## not  bad
incorrect.or1$score

Correcting for country

table(prt$country)

times <- seq(40,100,by=2)
cifmodl <-comp.risk(Hist(time,status)~-1+factor(country)+cluster(id),data=prt,
                    cause=2,n.sim=0,times=times,conservative=1,
                    max.clust=NULL,cens.model="aalen")
pcifl <- predict(cifmodl,X=diag(4),se=0,uniform=0)
plot(pcifl,multiple=1,se=0,uniform=0,col=1:4,ylim=c(0,0.2))
legend("topleft",levels(prt$country),col=1:4,lty=1)

Design for MZ/DZ status 

theta.des <- model.matrix(~-1+factor(zyg),data=prt) 
or.country <- or.cif(cifmodl,data=prt,cause1=2,cause2=2,theta.des=theta.des,
                     theta=c(0.8,2.1),score.method="fisher.scoring",same.cens=TRUE)

summary(or.country)

Concordance estimation

Ignoring country. Computing casewise, using prodlim. CIF: 

outm <- prodlim(Hist(time,status)~+1,data=prt)

times <- 60:100
## cause is 2 (second cause)
cifmz <- predict(outm,cause=2,time=times,newdata=data.frame(zyg="MZ"))
cifdz <- predict(outm,cause=2,time=times,newdata=data.frame(zyg="DZ"))

### casewise 
pp33 <- bicomprisk(Hist(time,status)~strata(zyg)+id(id),data=prt,cause=c(2,2),prodlim=TRUE)
pp33dz <- pp33$model$"DZ"
pp33mz <- pp33$model$"MZ"
concdz <- predict(pp33dz,cause=1,time=times,newdata=data.frame(zyg="DZ"))
concmz <- predict(pp33mz,cause=1,time=times,newdata=data.frame(zyg="MZ"))

par(mfrow=c(1,2))
plot(times,concdz,ylim=c(0,0.1),type="s")
lines(pcif$time,pcif$P1^2,col=2)
title(main="DZ Conc. Prostate cancer")
plot(times,concmz,ylim=c(0,0.1),type="s")
title(main="MZ Conc. Prostate cancer")
lines(pcif$time,pcif$P1^2,col=2)

par(mfrow=c(1,1))
cdz <- casewise(pp33dz,outm,cause.marg=2)
cmz <- casewise(pp33mz,outm,cause.marg=2)             
plot(cmz,ci=NULL,ylim=c(0,0.5),xlim=c(60,100),legend=TRUE,col=c(3,2,1))
par(new=TRUE)
plot(cdz,ci=NULL,ylim=c(0,0.5),xlim=c(60,100),legend=TRUE)

Similar analyses using comp.risk for competing risks leads to tests for equal concordance and more correct standard errors 

p33 <- bicomprisk(Hist(time,status)~strata(zyg)+id(id),data=prt,cause=c(2,2),return.data=1)

p33dz <- p33$model$"DZ"$comp.risk
p33mz <- p33$model$"MZ"$comp.risk

head(cbind(p33mz$time, p33mz$P1, p33mz$se.P1))
head(cbind(p33dz$time, p33dz$P1, p33dz$se.P1))

Test for genetic effect, needs other form of bicomprisk with iid decomp 

conc1 <- p33dz
conc2 <- p33mz

test.conc(p33dz,p33mz);

OR expression of difference in concordance functions and Gray test 

data33mz <- p33$model$"MZ"$data
data33mz$zyg <- 1
data33dz <- p33$model$"DZ"$data
data33dz$zyg <- 0
data33 <- rbind(data33mz,data33dz)

library(cmprsk)
ftime <- data33$time
fstatus <- data33$status
table(fstatus)

group <- data33$zyg
graytest <- cuminc(ftime,fstatus,group)
graytest

zygeffect <- comp.risk(Hist(time,status)~const(zyg),
                  data=data33,cause=1,
                  cens.model="aalen",model="logistic",conservative=1)
summary(zygeffect)

Liability model, ignoring censoring

(M <- with(prt, table(cancer,zyg)))

coef(lm(cancer~-1+zyg,prt))

Saturated model 

bpmz <- biprobit(cancer~1 + cluster(id), 
             data=subset(prt,zyg=="MZ"), eqmarg=TRUE)

logLik(bpmz) # Log-likelihood
AIC(bpmz) # AIC
coef(bpmz) # Parameter estimates
vcov(bpmz) # Asymptotic covariance
summary(bpmz) # concordance, case-wise, tetrachoric correlations, ...

bp0 <- biprobit(cancer~1 + cluster(id)+strata(zyg), data=prt)

summary(bp0)

Equal marginals MZ/DZ 

bp1 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="u",data=prt)
(s <- summary(bp1))

Components (concordance,cor,…) can be extracted from returned list 

s$all

Likelihood Ratio Test 

compare(bp0,bp1)

Polygenic Libability model via te bptwin function (type can be a subset of "acde", or "flex" for stratitified, "u" for random effects model with same marginals for MZ and DZ) 

bp2 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="ace",data=prt)
summary(bp2)

Liability model, Inverse Probability Weighting

Probability weights based on Aalen's additive model 

prtw <- ipw(Surv(time,status==0)~country, data=prt,
            cluster="id",weightname="w") 
plot(0,type="n",xlim=range(prtw$time),ylim=c(0,1),xlab="Age",ylab="Probability")
count <- 0
for (l in unique(prtw$country)) {
    count <- count+1
    prtw <- prtw[order(prtw$time),]
    with(subset(prtw,country==l), 
         lines(time,w,col=count,lwd=2))
}
legend("topright",legend=unique(prtw$country),col=1:4,pch=-1,lty=1)

bpmzIPW <- biprobit(cancer~1 + cluster(id), 
                    data=subset(prtw,zyg=="MZ"), 
                    weight="w")
(smz <- summary(bpmzIPW))

Comparison with CIF 

plot(pcif,multiple=1,se=1,uniform=0,ylim=c(0,0.15))
abline(h=smz$prob["Marginal",],lwd=c(2,1,1))
## Wrong estimates:
abline(h=summary(bpmz)$prob["Marginal",],lwd=c(2,1,1),col="lightgray")

Concordance estimates 

plot(pp33mz,ylim=c(0,0.1))
abline(h=smz$prob["Concordance",],lwd=c(2,1,1))
## Wrong estimates:
abline(h=summary(bpmz)$prob["Concordance",],lwd=c(2,1,1),col="lightgray")

ACE model with IPW 

bp3 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",
              type="ace",data=prtw,weight="w")
summary(bp3)

Equal marginals but free variance structure between MZ and DZ 

bp4 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",
              type="u",data=prtw,weight="w")
summary(bp4)

Check convergence 

mean(score(bp4)^2)

Liability model, adjusting for covariates

Main effect of country 

bp6 <- bptwin(cancer~country,zyg="zyg",DZ="DZ",id="id",
              type="ace",data=prtw,weight="w")
summary(bp6)

bp7 <- bptwin(cancer~country,zyg="zyg",DZ="DZ",id="id",
              type="u",data=prtw,weight="w")
summary(bp7)

Stratified analysis 

bp8 <- bptwin(cancer~strata(country),zyg="zyg",DZ="DZ",id="id",
              type="u",data=prtw,weight="w")

summary(bp8)

Wald test (stratified vs main effect) 

B <- contr(3,4)[-(1:3),]
compare(bp8,contrast=B)

Created: 2014-05-09 Fri 12:12

mets/inst/misc/run-all.R0000644000176200001440000000006713623061405014632 0ustar liggesuserslibrary(testthat) library(mets) test_packages("mets") mets/inst/misc/pcifl.png0000644000176200001440000003224713623061405014745 0ustar liggesusersPNG  IHDR&T IDATxy\Uual(1t4uʚsi,S-.Y4MVژ+Yai.`"=?n?2#a߻z>rs>_Mޜs{UUdMHB$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@" HB$!r9I$D@" /]rrrsuu,rRSS;ڍغ^{Gqr,@ݬ[.::Cع),,|7mڔc0BCC͛S]uDdڵ&Mrq_)Xw}gK-8!!Aׯ\ԩS٫WV%!!A@oiii7nt/۶m[9GI3cƌHEQ6o-[ ===L6~x9:H:KIIIIIs8 b-@Isĉ'xZQRR(lș8q322 üy`S$ENFFٳWX}'N9(ҬY*=?(4[>rH޽SRR&Me˖e׮]6lacFFƄ ,f.m۶۷o޽&)rwРAG^jՠAv}w-=za%K,c}x{{%%%}Gnl k#F8vرcM_&%%YfѢE7y_iժ~fȐ!B\t)>>e˖۷0a^7(v-""bŊ5Ν`GDD.^]Geulٲ_>((yyyݻww M޲m۶YFQF?ƍ'zHCУG~uzKPPЅ 'O7nܺu***/_jΝ;_ :'0mڵ;ϟ_͝;W1o޼~811ѣ{>}-߽{uNN=3gΜ1c4d j%]ӧO_j%:?sLxx^!DEEhBjzm`طoߚ5kLּ%//uj\oUUU;jMĉOӪUKnܸ4CzѢE!<DN. z{{;7y׿~'jf̜9&C 9{l6$< hH#0I>Eqvv~Kuu(7Ϳ1&MSO7k,tQ7dk6i45Ժnt?Z";E;v|We,.3ސ=4!jdeׯjժI&]Z׍6%ox˴iӄgΜqvva`-rtyy5dn͛k)\Qޗ_~YYYGoٺuc|||^G6"# # ]ԾnɃ>ƌnݺ?zӯ#4V`-$!r9I$D@">E? [ ",Ya.94{sȩ.%_e-yg Ò%KXPP#+~>}lݺU1k֬VZjVL'Lɓ.]jĉ_yFni ڃwiUN~޹sgӧtӧO !zꩧ~zڵo߿ݟ~]q1UU=<lyyyYYٳ>;xE2d… ccccbbۗ^Pt5xܹsȑGi޽{5^lYYYYvڷo_YYipC?>66Yfv[޽u:[>`РA0` `?P$&&veҤInD;c޼yCA}..wM4iΜ9:tdӪ222Ο?w[h(.ٴ-[w}+V6jԨQFY h$!rܹsÇhժ_/6|E 9裏~ qUN:eVRRrA!ӯ5j41 /">ꫦoJQJKKnz6k׮͙3ǴZ+19vZOOȌ7|ӴV^h`ҥKv^~e!ҥKFcvj_Pk%88&HB$!r9I$D@`zz ݅͵v p#DEEY [O[c?çLb.u&^c=V^^;zhS9:H~zǎtuu5=DHz9!K/*7Isϟ7}yI___iGXӧOTTԏ?(obccMM k{UU577ҥKBww7W@޽EQ~l $!rHP6r"租~ٳ-[ߺ[ ,I<<<Ǝ-m6jkIX>}znؘxMa@EΞ={>M"'66Фpa ),,3gNN|||<==;u4sLMIHH+W}n^S^Y}EtU9-i$C~fleO?V\yeEյF9`}__m<-wZ^y.E=;;yje>~T~ְ?տFD≑kbpi۪j|DX?[Z*'ܶl鮬K)>{ֻMOHRW^ye!!uX%.k4#رcQQQݻw7nȑ#}||$6kɇs4 a~?̝;w_Iz7e5p48p{5MUUU۶mF9Tȑ#t]6 kvB1O>F?` jl?,0PBK{9 Ҽ?iζ[;Qe֬YVUUbW`v}?;skbaVۗ,ےf\!`FD­bI-ߓVBqlZy^Kҽhmc& kTyvZZU5hRBbq[?-^wn|S k f-|ۘ-Tb棠̞=Vj8D҃ ̙өS'OON:͜9X9y}}}&!!Aׯ\ԩS٫WV%!!ؑڧ7ZloڐämܸQ}5-P h"j'O!/^̘1#>>>22RQ͛7GGG7p )MQ$i\GԩS_x !֮]SO50ׯONN2eʅ TU {%jaOw|Of,Zyr??+7?fT f+FBޢ% .O_4b쒲P]]=q{OB7<75?νɹ-[zyݡo!wH5-GҥKgϞ]YYi{Xǀe:c.Y ׮]o߾/Yf }zzqVZ4|GÇ.#ò#ӿ> r ڷw)vAީ?>K\Pi;k=S{uuu߿ҥKCCjXE !n;֯Y+:]Xgjpk*nڱVk6eJᛵэp;1HZI_ܴiSNN` 7oO ęV>}ӧ,XyD@J< i%iq 5UV?_ؔI$#4}镓?2E:(L^DП5H)((1c֭[F!C-[gGh,2Sm~aT]]C3m4 EQΝm jg0V{7bԻf+OپF5|SФٹsgvv^k߾ܮf]۶lKa~`;jAo{ꩧ $-=r/_^QQY^^l2mOr"##SSS׭<'sj?y饗x˗/Kj?1~bŊ--Θ>qOÉPnෑc06 \+.|&&ͻY&M҃ݚx-J גf^ȸ&\*8ؼ]-ޱtq1OBShdD[}g-'ȔhHB$!rp/ nyלbo4>9LsK^͍¿jhƂ7`*Jf}5½$D@" rU5TU/4%K r؄gdz5f+M-z9Kh `A%e啚}V+}f+3<55XRFkf{y5ِ`-DK1+J{va .]`Y!#_.+ZVjxv'9I$D@2-k j`) vv0[XWMbBED4lWЫ~o D,^3gC>HB$^Qz}*++SSS#F̟?_.^vh0B!Xd uGM٩m:WpI(̝\xĦZqǏ_Ry=4!r!DyAif">_/ ۴iٿq9B\dYc\Ϡ m8hP[oݭE >iU^Or;#a==]۷!84 QvY6[C\*>5 "rǦ ga'%}=wnD' =/$LUUh=tleŋAGLN,-yEzE\߳b'ř`AD`|K)B #-N.3!33ҥkZ*=4l?c9yzp.j/߫2豾ҠW #rlYjtF `0VV&N:ztgJn-%t+"rXVǎ v D` eWʘl_-'Cqf9R|2+`V9RDYw=R"K`P㥥f+N@Avɠʡo^ȏ9"rMuQC#ls^o P>biӎv# jyRT֭A9/EEGelsi;-W !Փ's ?lѺw&BB9pxWKrizƳAvr- kq:;zժBQt +"L +R}pW4oP8_.ɫKg__bj-`$ENaa/iӦ7o<CRC9?'D DD4"'!!!,,lʕB-[$$$|'r@S֮LY|Z-Z]R5A+{;WC9iii7n~M300o߾mr ϛ qСKZ{lXg91113f̈T%++krSt-lP/K\ilwz#G.<{d; E듓LrUUCBB}9GП?o2[{k_> Un!/j رƣ!)rRRRRRRwx]K=6n>_V-n橄Ɔ|3Ne-ZhvW8I֯_9eʔ𰰰 M>}Yf_?F~~ɓ'k9XYYnFrZiiifV# ^ťΟ?i:Sݎ;-Zd.YFFƓO>i.Y~~o.#hAًQF]r]$!r9I$D@ǏggggggkwȜ!%T{셭ԃ`p%%%^^^zoookw`P8~l pHB$!r9I$D@LOOϚ/ WXXh'&&F=izԩ111.\0mA)#PB/2::;::2mq7UVSLv::1#G---ْҶmۜ6mڼVTUz^_li]Jlٲg7mA3o޼S bܸq>lAAܹsǍgh0aBhhhFFÇϟonZ|]wU{ITR 0#Fذaسg{쉈^wգG//Ç暶TU޽{zz4mA8zh.]JJJTTddU V^}뭷6^jz]PPfzmJMMݲe ?kG瀑Oz_g^^yyyVk^W\IHH=zi]JUUYfѣ>(={ݻ 58pѮxǏO:UәnZb9څ/b۶mIII7lWUtU]a0 ѩ۷o7mA !UU=vؽ;ydF{ɒ%KzէOӗ0Yf=3/^9sٳMz\?5dȐvjGh{/RәXEIKKBdee !Znm.|Nsss3A !OOfff6᭷JLLڿbbbpppbbMz\^?uTtttNLzP׫u VE΢EjW1lذ-[g >m͵kFyʅ 1´ݮ%{VXW\ٳgOF{"55M6;vZfMIIիufhzg׿̞=2mA]ցXt.w ܺuaÆ3FqŊ:tHHH(**2mA3p@~O>(UUz^x-0Ǐ˫O>Ǐ7mqz+WnyxD@GYD@" HB$!r9I$D@" HB$!r9I$D@" Sn\\\\\\E1ѣBQk(k7ث#G^(R]]]}֬YVuo¿#@.š(s ^`#""|}}/^,tR|||˖-۷o?a^oՖIvcǎ^Q? .BL<8{Ç) Z͗TTT:99zxx䤪׵kjg8,Hәyxx뮹:uJUUUUKJJqBquu%fvB܀ aaat:zM!A%i :::̎Btc- @HHhܹ}QRRrsskmm $fvB܀ ______bC!ąp4BBh4&((hhhx=R2?i;Һܹs'޺u+44Ç/^߿?SUW7TVde]02jmldyjn߿r@;T͍&JSDinJcZ]Jmj$TQi4ayy~II^]LLDA@. -- ZZZ:&&fĉׯ_%;AH+9?褐'!!={TWW35'BUU 1UU UUuBZsvѪ?>R[ϗTJ3 :Big44Ph*45imohic9|x̊Ȭ/S+":+,lq#k?ǵ5CK 4U@K-4C}>~|%V~>OUA\$t@5Cjn655@cyyIzz]aaEO%$ >qq##% e$;2Bfmm/655o4JP.\}K.\CӧO/X-(({nݺEEE77e˖rܹ+VO]\\liitҙ3groa))goUW7efVdeUdfgfVdfVܸ}tMwx,-mmUĺÕ@xE ΂ʗP5YP 9!uBAE* ܽJR̾q#'66+* xD{b$Fͽ{7mzؕEN)rrryyy0gs566gcc^r@SSƍZZZ6lxe||]{Yv=<Ԕ#?>1%GAAw+9_c0ѣ7.U<(r$]Yc8ބQ0h5KZZJ^xs:^!!;{䖜CLJ(**jkkKKK|}%_HӧL'// )--=|-9 D]]~dddYlɓw1bn[za=m",qk71n2.2fde6 >x8l. 2 \PP@t_~VUUJKK?}`,Yݽhp__|ɓUUUΚ5+..]?o# 0m4!nv{BK39UVӷT47hB gZatǃ<<W ut.&1-1۷{k¼ˑݻwoXXX -[gРAʻwfym۶jjjZZZΞ=DDD92|fw>] ` nX-b̪UOBXx@LFHI 3ÛOl~0dB#5>(@7n˼[S̷(q5nσdG `|b>b! b`͚/?a"8 Ksx4CMm؎RV/`qtӱjȎr06$E0ZU4-[$$H$nD]䰂N6xS٪Zmv[sOPouAeeudbyCC7_R]Јigϒ,9wjzjҳMpsٹ8CeD [OjoXQ̙ Mv|XrJ\Xw$ /=v³\ o /XH]* :yת{Q3f^N֜9۶w.@rrrdee'Oφ$vfv>|"3j1ֶNnvoB0yR Y'o'R(Ԍpt|y4in̙JJJs!;䰓޾zU(#/_'a=7Iq8X@x7 $L]BwW92f֑֬ɒg͚%!!! n:III KY[xWMĻvǥeuW q`x x@]'.p횆͛n%;c988 ;wF ޲/ʾx񢰰IFFo߾fjmlڴio#BkkkСC$ܟYøBY>|M#DLj5y@A@ZչdGbnyDce;';x0ى>o2I!+V/@M^^acedA@SUUyFFW r S\\:mڴ{{={2taZRR2--cBaaaL viwgG/j|w)&yAp)<` !u-d ]wrY{Wۇ.**ݶl'!!uuuyy={fUUUHHѣ8`0,Y~|jjJ3/:=]{, '8Qc/Bם}Ѧn20F݀J5@E͊ȼr,Ocee~₂B޼yabbbJJJo^WWW\\loo}Akkk}||GHn%8҂!A3O7)wo93Żdb+9 y h*'; 놮Z%7ti߾%; >}ZHHHGGg/^8rH666t:~az޽mmmZZZGGr|C^j=]PKtmQysϻ3x>+Y )E5gĺu'tIOO533`ë{rvl-MdGc3at,4|PFv esB٫W?Ҹk޹3%Ő*E'`&O=L,D@6ӰH\n"; B,9d6W֮{ ĸyf+Ol yH]Kv ^GW&L(}6lE@XrHFQ?wMMڦ3wictmBJ`xT-u4sҭ[T-W!~ KW\\?{y߉Rl{9S5 CCqd&B={Xݵk΂P%((\:az ~VZ~,z4r*u #΃@/HpӰBwbV՗<y( [7Wmm%,XlP#>? {vvIu y %p C*6߿4-ʕdgA^˷ۛPÍ$ܙwܵ33Q64u8%a?P Ɏ 5y^:U-o"nc#KR)tTݶDGvo<=:!5ns!m^&; +wwƊ|ʼn~ju7ѣ}~tJ[p lzeA;2-uqO،7?i8h0.*:p;[Y[ :ѥ@כ-}p_' ]v˖-N6{~={֬[l.o/}ۧ>=uNǤ\W`C i.L;wnA~>k M|Ӎ|֖ܹ TNMakbEZ6&gcV~$; 30*qm qdAl40i$ii];\KN!))pݮ]&Wd4}20Ő3nl:kr{CU'369s Ax>69= /]̙ׯ΂[n޼fh_N6Xr/!NYXNr.5k{ pjՄ]u dg=V@o<7 &4jFKc۶mgN6,[jllݿ֭mF]R{'#z&tackp0`daµiӲ\UU΂7/堎xVl55q[cR{(%JMaXԃN} R$lhN{7/_NP<=Pw%ukҰa=ͻK\#+KaY[OԗCP5CWʊKH ; BMJJI!!ee 'Mh-x⹹vGń]sTҏd1E WcK颢Ͼ{_!#XrNN^ںLQQYbl҅3hpWܻ! P /@5.E߄KB@zABaamϽ6Pq0Y ewڥg%;? cɎ 7nսn@GP6lKe tvx~q=R8|Kӳ<0! 'Qi4-w7or΂={xѨ ۷Q\zl]aY*jM( 4!B..bwmmdgAêU~" KΟA-)i]&!!o?5q8+zԬ[XH:\Gnoʃh,;M~.*jvmGǎu+WlmmݳgٳW^3f(+ДBɍ1"::eee m`9s>ٳ!_L7cƠGҿ|*)1t^#)cAbo_x;P i`dT[T䞑AvĴ/f%E'P"=]bΛϞ=366NJJ߿'t:dɒӧOp \zoȐ!>}b0߿P(_7nllٶmݻwSSS{;?G_Flٲɓ'ijj{4ec}삔+y@3:RBvFj_FQ&$1ٹ]f͈#o1 IIɢo|9`<\CCۻwEkmmMLLneΜ9uuuӧO (**JKK+((466KTT˗mmm'Ofabb"--]YY *0ѣiin˖ ?TWDiM|jg0^Ea'@>FPDr3ܴI\E%ͭ? `޼y_۷^YYo߾MMM_MnnlM-,,G%**J *eW9wK66t}!S01kRvTp.a=Lvʌ! &|CCFFF2uʟp߻wA=y\DD͛7̎ࠖhOG(rK϶>PZݥ;Ɋ9X5{5ĉELKX IDATZZg_,p/x_h4ND-+%%*p0ir3DOIKEE/4UsK!DVrܹBCCs…{ v2yh02& P=ive3*/OO@% ]Tt+/Ϝ!; B\;Iͭ {ܹq'f66zR)<O7*^EPOZե L}@j +SL5j8Aő#G֭[ǡN4N "nMrp2u굿." TU.k/o}6u.iqe2I79z_7qbºu^I@vC-JKK+// ͲC] :(++[jU~DDDTvx &\Pv p6Lzuua=OD*]FuROf<<6n$7BL={vff&'YkuucDzO8APu@\NLeϧwz~;ewY-WI}Htá'2::KqJNBB_{mii#G&''3;1cuP(Æ߽;G²M85BcSGΩo$i]Q(TB+NNUHbA%3>>ӧO%%% :::̎BKK+VO١5N;>^Aћݕsҳ @ގ oA6!'@cȍ#+B\ $$4w>}())3;bii0{??Ŷvq^ΗD>Ç0Po龤+*!z8S#ą*9o޼سg1#[z?<0JEElzjve^]`C!?5{ c)h# gy<5B\ Vl:ׯg[[54t7 ng9w[ ,FA:Y(tGKb…AA։ }b%YӣLug~z:v`?"rci߿<#6Xr&NNIO4X%63kŠ^#.XyOˁUh*}8 ̮6aݕ+q ,9ʺ_?{7?i5#{.8U3 m0L#`B*6tŊ'O!.%hL1cgώٵ+S<Σ7Y+umn"1!?1,A{|N0a_kkI'~~̅’؏N 訾reEMMn*,噱'ڈ4dM!>Fpz*=;; ˹}s!ą Y{y 9tɑuuX-CesFQwX\*~YHpomcTc!.%q JٵYCx~6˪vB!)[h(TꎎMUU!.%q֢E7n85 먍]CTP~m e?z0:HTZ^qz" qGNN޳yȱc?N\XsEUsunea'~0>\GĤ-[8:BK"B^ Sͻ1|_[Ov7b[GώO >mJccGM^`΂"--xөSc=+ +._GhLZӷи'"64p<%CC}<ѝuML !%B77`O~y_N9.$6p{mZ=΂W6aZx}ZZÕ;t7kʫr+4Upn-wgEs Xr ƌQ>uj{y!|NWmǤ ퟽ aAh(8:=zDNDWd9ʩRJ-9b.̂&ϯիܸ8͂H3n\I56>,zڎ@L Z8Ym>787BK"ȑ <iī Jtc`csl/H8^1~jA4ES7!!͵hC;`A$S9}zl||I\TWO>@?H8cP[!'#+rrɹ)Xr9bnS?Qk"RΣ7rѲ'o"9n.1ݠ%G=zeڙ3!%qy=cn/~MQfKT:g=nni>̡IB pޗIU99Jy{}e!%q;6&&űVQ!ΡZ}ye" e5m6a.*##D:,95KkѣϧNܣu^́~ otg {Q@{3T+tQ>ƽp"=egih ~YRO/S3<;sbl{H@hcwk ^geBK6<=/?v,uϞ'̞KD5#cNJ((RlH%u';w٩[w@尿ٙS5e]M#; z[]]V[X"ԝP͕Daa!.,uՑ?BwWpmڴV#ͰnFQQuA\]\ae#K'ol<1E҈>>wiH`~PigٿB!`AݏHtD==Y'G04Щ9E]{Ms-H9lo2`lhQEV{GF,XrP$.wر}.ul #HvU_bogg,`D,𣁩Tۋ)4%KZN*9yyyɩfffAoh1=Z9r#.|:zYS3sܾ k ?J8 xƍ!RTr$$$7sLss SSSwwwbfG*~~Zd´i.]z"R쏍6fUXo `so3g>;p##D{L@0ts#) b?g钪\iu% A]P 2'4Z2\a8wy۷wذa̎l¼7o:w['OMUQZBN gWCm^KHFW7˫͹BhkkϜ9~~~zzzyyyΝ#fvtnԨqwu) "!FčV e֭u>v"D8JFziiiisss~~ӧ䈙;g$jm}m3)_J{!e U k~DBTI I?G^qqUUmmï_fq~6v.dcAn4cF9thaRR[3K@0;wP( .t7HI \*no~Q88wqRt~/|HdkǏoBC;,BD0ܫW/GAAAp0?LyyuҒfmƪ^_1i6NN]/7E=ٿhkwo1e) ﹻpbίrҴ,,,Ξ=[oFB?:z"wDgc9/C<;ɚ`x(T%KjF;{V2&2 w‡ M=>}ZY8y:ݻxРA ˗//..~qTT,6.LHH3119rorrr#kJJMMXNkwzIJnaZgqTXǮ"R%'==}gϞ--#GX|3>>ӧO%%% :::G&&N75 ޵+q [d5bibZX { C@Ccۭ~"w5 BD$%%;N@sss޽iΝۧO%%%77@s#ERRf89\v-˽ [d?^9C˛#|WHhϞU}`q 8B$Xr))Nkjjvq __7ofddٳGLL"DD聁ֳgknْSDZ3l|1vݿ~A3(aa!t,9nb0\N?nigy3P)<h`EM-ŎT7Y{⪪]>Q+&(8sfʺu}}6?]h&kguuա2Ȼl6|ڪÇ5 BP(UVIb3 K'Oj;<`7wCE/\rml)${tO3n;[Y!2|Sr Ǝ;ڿ耤x%(ٹu_<7kEgt4WAb0bW?ի늊"vFET*Q{M}ƝOWm쌱{rR=:\(YXѶ~;!u#dCCnp5Ks..ѭ,^7(DԢO?;Tdh`mNVW\*(-!D7~|qω[]z̘ЂZV4j}?;t^h*UMԁ^>AXCuk:56)BQѯbs5ue;r^8 mP_ @:PTݻ^"XC4_w,,gш°ծt^}SmSm )ҏ@DZK+aچrqCspBÇx6-t֬6K).*$}6ƳxAk#>~A9vul !k}fe88)Q,WA)W.M) eT{rsذ~ ee] !dffZYYIII999}XkȆ #BB޸_gھo6:}z c!ݷ+iXU)t^r\\\455q/5߱~G>>5lZ*泬`:=$HR|MJCa)57w}48W9[nׯm^ 86511 .-eq@eeNu$fЕ++odhqH%篿ڸqw޽{iӦ%K !r\9u"X\[VsR0?]̿ݝ CI>jw5.@_++Ew}(87o޲eʖ-[bcd$ɓ#Y^M /ns/dRemqok*/jV>>}O'O޼hqv@臦N?*""kk,aS1|GmQY7*u]OښBfztKKˌ3ZHw!!$::/xݵjj'Ů't^r~XqU ;qży7rz?5B䗼7zzpذySR,imi[kHy9}tbbk~~ɓ' Wټ{c%<"3-mMB~rz7ȍPg>1۷gƾ+u^rrss.u^r?NR/]TYY`c!ĵV>ի2{uD?$y5Yy %SN=~ vI!zؤBs󐜜*c{XTHȕ9בH 665yy]8vFNNꡡv_\bqE B Fk#dvEMOU{šb#$&LP l+MM "+cr%o@n4Ș:}Bddcy]2B셝bѽOwN̙66^uMPZ )MMg6B]y7݌Kͻ[̬nPa$L7Q=jT}E ̋7m2 {kiyFyT|JnWun3gv:B,䤤 :TPPP__?%%s9s#Vz9NN,lb=~!ckE>܅7Yg8y^NՈ`ߔwww{{"kk3fq!!!W7J`uvܽQG\J }W ˝U*>ؕ`b}^wFD䤦_"""/NMMe4= d2/!ϞН"NTDPr=Uޛ,/)= :Mikk)))N{y//f|hĉ[|IYN8١CfAF!q33|W^yO+"B߳牒Ń:]DSp۳Āh%ńe 0tgLڽ{Ȋ̞S(k٘GAAApp0Ab3ll.߼7Pk?4X0:Mٹìsqƿ繻pbpܢ !@={ [Z^ad!%~爗ehkc32߿qA%G]]]TTTHHH]]}ŊUULzL\)b'G~Fjk 2exSn:$zr%s" JkuucDzO8AP\]]BAA$*j//48;3ETaYxأM+kk5wŋ_k1???iiiii#G&''3;B݈ؿNlll=:sWۂeS畼pk ɍ}}ecfͪ/-e.4BchhӧooobfG{ёٽEbF0xi]3+w}:4K43_! ͝;O>JJJnnn̎P3{ޑ#)ZZgә;Pc9׽[Z~lA/^*(ѶmLFW*9o޼سg1#ڕ7Lĵ W$ƽq/oėgδ3{)B?^|d̝ DT >ϼq ̵.j./)>ݰ lmU&O~gӘ8&FT:1j'-nniͳF4XmXXWF;*}߲DdmBf}UיmJDѦUHD)5FBs~9yϘr=A 14]="*6 T=q}q1Q^s lJm}Wd 'ig5D#޸3x>YxLaҊGgU֖vP~))#o+W2NǍw0r\0!ʕ% P Y&w<^QS܄ܢm-gl|wŊqeAwLN>|ǭ.?4#;Pt)OF-̏X e1ʼn2x0r5DDx.^tөvvYY]=LwH@$hh)qaQn=8Jt=L~)(WZ0rM&4Y[_v-Kʀi|zK@LHv%8ss>z /A12yskߓ.#i Zix <\GlG;:=ZJ[.4KqAӓ}e(ŋcz:e|/aRa3\Ull V>$)2z%YYpGuuqO۟>ua]5d wu6Aכ;wsOچWVvm08- 9AsٰGy?Ϳ{yfEu}pǏiV30rjO=z04-}l`2(q@0,Y8dyUᾋ.Y8YCçǏ>#!1s͛Zml.ui)F" 4#|oشvF7V~sBw8J e̘gԍ'] }xrJ Z==bEDao/9dȣjEQG8Py2fX,k_+NQ m϶;\|s|Uduo, EꊋC _z oApݽ;]ȑt'vPxIM=λ܄+a˛:GG7VTܞ7@#!$ u͍*>K d2U07ͿO>C7M|7qq[ q0rXVVʉӸff绺0G6́@7X==bWF҃}؂nn[ܜ538FBljkK9;tiхO* _x0V~^ f7ΊP2RYݬ:: Pkg #!'*s u|}ӧNjmBxAhW՗1!Y/t8CU7!"bJ||mqqDk+JAFB~={/_uwѥ`f׃:@\,}fPΙ+kddrˈ XQ 9Wz{=mhԅ`# e_&p0˳ ]>lNuWv52jgQWAپQ>t!h|0&\!<^YNRmI>Wf_ @؅Q} yfv'ܾ}ٙA:Tyl@qqNrdhG$ "fp?ɻuiHX.~-3'~~UllX^nfffrs֯7umhhUޥct :`hGӕ-ӷV\K>@a~pö>#D--Gƾ| .=}W`ׇ ye5c_ EAחIHG;6l̘@ O!{_ ?KVO7߽mrysgF}FB}XV_IIzz!7nta e OCcۧ>)@3gMU:~ϧwϯ~%#>M@?z(+ eӦ:yVK  9ݮ,3wgm$"ڵ,=m0rBпHRҴioz\TT~G{ k 8 Mfʩo:8o9/ždWA;ggUPPxuԎ;hwœL8 q}H?k п,VT^uŊ;lCz5V9C32f*,Zc`ZV8*`xzPV#OQZvUCG=FB}11.Ydd| E'MPz mSY,ۤv^zν&zΪq #!CT*erf%K>n60t38khw?*g<;iA^]B #! 33\ٳ:x͛la&09)m 5/~ԏrF' =7]-&z P焅lN{釶{(¨kT hl j}DSmmqpWTFŦ:AZ}FBfT}U-^\xG=Hik+[YeǤx?k;5>sbFj9Ϻ5F!pJPN@RL0!++kƌ̗v ܾ};9gGpLkN\77Q>i kK&5gNNiYܻT IG]K>89Xή[XXt|զ1;;BuAA}, k5k]0lh~ge++ɓYT*mYD㡮c [$ܬwYPUᬠI$%%ssDJJTII#z%m0jܹC$;sFPV޽JGt͉ 4?|\t^W~ IW9&&&˗/OHHCyyyRRҚ5kttt9;BTasHtOf08];vȍh?\zI^r|+s |/}*dQ7 )rBBBTTT̙`0BCC9;B`Uut1;s&&*nhj |q?X,py1xļVF=F}]˖-+--p!kRST>\2/{$$:)0^4*} ~,:GABѩ! % _[Y]qsؠA?75-NL' e3wZ?|8wpb+`zI^p"c+۷0xʔ)_:sӞ$f[f{Q$Fςb79;\+>-lܘUVV 3ܙ?";KIɊ¤fONρtvhh vw+JJ'6lHhBDU7qqЅi4q Vi {OCHu #!3Ȍ~fonZ[߹3 vfa|KCCؘ1acDGwA gḎ;(,  .0u #!c PpP-rMXq皚@V`֭ӯ::geuJS_=o]rû #!ԓHqP /3)7cr7co6!ijwŧn?v{MXɇl\i|͛7{ ?uuuBe@ ^deyE``fRz輼edy1?ŵČsYp JQWdd8+:AHV@{dE"-~ru%* &^11n!t)'8L{F3)QԜy7_>f0xExY]Sam!*7hHps9Es…:ZZCymOe M8!Q.""k>lfqr `1zrꬬA`` w!s+Խ ۷۝ڡ>{i_YY-0n"K9E}JY6TduYWP z6 C~PJJ³fiťqh܎x ;)IDAT W||x?/³= @9^GFE* B|w99N=piI4mVC"]5ەS/3.8C&;@?#!PAw/ 59R7+Rt[\tAEZZA˖?{V'Ur<.!*vwCJna z3!ԗ`QUU^j Ik>>thE1?[( 3Ըŋu_hٓ:+2~﹉-W@ xO7O"?bݺ> tȘmLcb  zSgP6]3#d73"敔簠>#! q#8v@1&OV[;l`2CMMl[GKJ~y)cY>cwC^Cҗ` z' Èz3sod󐐗/1qZpBH_8 dj;B2/L͉dU9}/jٲe.\`@B= _H[ 0\jhݻ<""_wܶߓO""<4SSy qoo#~~NOR>#-$ UaaQn:UUUVt z9%% )!} J[92u>[qի QmmS^^evǫW筑,}VYZdy|zp/_Vd2&rB'(Ӌltv~}o4nhQߓ/ĦOXTODg"^eeM >h\.E瑕rBc0 HvZP @ј>=7y9mJ6GwPѣFVjii]*ACCbfBZ\ccW^WdA e3V#k>#*`zt[ ?emBKAAM35`wg׾-u0YdQK(v/bk9!3߂PyyeO̽699AUGqT_tR;ɧ憐Տso`5Z41Yx4B!{BRx#+6hؠ/3r)($m4dȠB,\(>xp5}< F;8h'rB(0d#HtEWY\]5&sǏ[<>r$cŋ/ \h_tb'vpJ}}GXWRW9!_%Q<h<`r=4o/}>/[--WmͣG t{>vR~ ^ `7b @d(Oy3?**~ٲp;;U{{˃Ey6010I=|۶KT!FB}GXƥ@|3AU^s K@SxsgyB m:RPИ1M#77mr+ZY]bi)fi]BUCQ8G4ɑ#֮2kV?4iM%z2LxxhFFrga PQAy(Ods@qdcb4i}F13k{IHcrݺuVB4Ӌ0FEx}bGCx?EI"bb_i7o&"ݽ??? Bsvb :?;30=P pEÛKCYH`-)))< ʀ7a| ?N|IH11={ٳ!PODq}22*@UG & U&ib~EW_^2: >Wpd#ݻsRۇr߿//G!ԋs q9('Y@QQB+zkbbbzzzm2Bg@!D}!IpB$BBBBTTT̙`0pSpB$!*!A!DB$鹳KDDdΝW^e@:WRRR\\ ϟ?{ $g(HgQnjjh4!4hP"t<;wˋ!ëWv2>>ݣ SHH0B;vZYY{ dMNN޸q#'B#!I0rB#!I0rB#Uέ@R>D ~EۧeKx4455wͮb(Hrz>:$?aB$}z!a " FB!` " FB!` " FB!` " FNￇ "**jnnltppwttdݳgb[ZZ-Z$%%ebbRRRlb !!AGGGHHHGG޽{FAAAۖv 䘪]W9͛7nnn'O,--3g}Ϟ=JJJ{e Wuuٳ뿶pj),,466޴iS777oo?_͍I5_LU_/;߯===?}VBBݻw {Z[['Lpҥo8X]]'OQSSlb >֭[vjΑ@MM AYYY666c6rjf͚իW}vժUk׮e6rpLU9]ŋ߶8011 { 4Mfm~5rdAʾ} Rf#K@ii)Ao߾d6r^m-^6_UNHNNzjdd\]]]]]!** k׮999wem~MMMCq=z___ȩv```]]]@@aØ\/Srj|bEA۷oo_leeCUU{ qjcǎ677c6rjAdgg ggg396~IU[/߯p6B$B#!I0rB#!I0rB#!I0rB#!I0rB#!I0rB#!I0rB#!I0rB#!I0rB#!I0rB#n"--AǂPυP7HHH,//bX(GBn_ׯߖ-[=z(AW577GDD̘1cʔ)aaa?jjj<<MPݻw...0`ܹskkk=vHЯ֖733f~j*xӧO{Λ7ٹ0==]YYݝFtBԩS__lٲEZZ:33_~{ ?}uO))26!6~ISSիW ֭[ 4h{եoFBΝ;JJJJJJ̗FzMVV}||['Mk׮2'']voFB$,,K^^1c\tzzz"""}vտ}G X"22rذa \v !6ëX"))~++++))Yf3Ga >>>jjjׯgb?` !I*!I0rB#!I0rB#!I0rB#!I0rB#!I0rB#!I0rB#!I0rB#!I8((\iIENDB`mets/inst/misc/pcif.png0000644000176200001440000001670513623061405014572 0ustar liggesusersPNG  IHDR&TIDATxXTus1ÊJ.bܧc$kOጪi=vArBH@!9!$ BrBH@!9!$ BrBH@!9!$ BrBH@!9!$ BrBH@!9!$ BrBH@!9!$ BrBH@!9!$ аg  7䔕cƌ{0^{j2\(9fZzuSSӜ9sv2eʔˆ~\o ㏽ͅ^yWfΜzĉǏϙ3G_ za/TeʕqqqgKaÆԸ>={l>}НPrҒO>(ʾ}233]nBݫiZ]]ݥKE ݲeKFF@UUE9ry>ũȜ ^9sѣ.]z{%w޼yscǎ 6HJN^z!X,N/BX;wnX,)))_[[sCp@n)//薜LM:;@Bc-Za6ϟ,sv/Jfs8UUUׯWUfɜ nزedr}1h |Pr͛jeeeiij9;]X+))1͹ 3fp:7n9;cXdNA$ BrBH@!9!$ BrBH@!9!$ BrBH@!9!$ BrBH@!9!$ BrBH@!9!$ BrBH@!9!$ BrBH@!9!$ BrBH@!9!$ BrBH@!9!$ 0&MSv9R _!9`LǍ_>gOރ|i_!9!A2+Vغukmm錋ZdIDD` Νs.~M`nJf/..NJJRrǎ6m21o'N& ]BɩزeGEEedd 4H`NEQKNՓ%'==}޼y999IIIVVVZV۴c+7o:E6,2%iB)))),,ͽpႦiYYY7n9;ƖNUծ Zy'RTTTTT$s:GxM!$ %'..NuG_ t3gFt/ٽ{͛;-߿?66hiix'G-%W^=lKRRR,KEqf׏y_#;?*=<8((~(ܹsubIIIؿڞ exrptL܆"#CsrWvZyyJdffJn_hQbbbDDlNLL?~ss@(96pWUUUWW_^UU&sv/-Bx6螑#_zx`Wx6& hoGx6Q/XBH@!9!$ >9.^(< 'ĉǏ_[ zlذaݺuvzϟN6?yǣH^o64\VocTk!!!.]p;sܹ3g[nʔ)[6wyر~SZj۶m'O8qO>9~O>d„ $Q-^azOadsŋ{ｷ^IKNN~嗥_w\3 y|4~w**οz~7$$˃SSc Lu;sa WZi锄>zErbc ;B>9gϞ0aB>}훓sy>9ӦM1b8pwl6WAϞ=[QQ(ʋ/+;ϟ;wܹs/ٳ7=}`/YDh"Aonkk>}(csUV;\WW'<x'/ˁl6ŋ7l0n8&隚ѣG:thƌO=dq/yɓ_ ϹOWZu=Y&!! k|ҥ{WÃUU (}?e˖=ͻqFzzzaaX\9ɓ##Ccb rlEQx yk&SqzOnI!n 0ə3gd:vɓ'{PEQ?,sv/J+6s'N?~<88xΜ92grʾHEQV\'yv^ijj6lXMMӳgG %'---99۷/3316!tam޽]tIQ-[dddȜ ^QU5:::::ZQ#G#.E%&&FDDs4VcGqqqUUUuuUUl2g k[l1LO222 $sv/JNzzyrrrTU,--Z%w޼yszsR%077… feemܸ$%%btZt87ooJb)*****֗tZ߿mmm“Bt{cjypf7=8)0n̤7?:p;=?>:a_xWPtjN~{! A(9v}Ŋ[nu:qqqYYYK,nXB~}`.܄3f8o~`|!$ BrBH@O(qϏ T7 PEq(|yFPP?BCRSc?SO8$$P)`XBrBH@!9!$ ~0C.= @r#{ŏm;a\۵wMAEBrBH@!9!$ >7<[YɑgCB=!{Ox]{1u^!9!$ BrBH@!9!< ښ5"axN(9HtG-Z0|UQk'1]l2ygd;&i={jvZvfc.0M𮊊 oUɑ^R :`L$oc3\ɑUߍ!Z`'6v32Ąuyߛ>}ĉhn;{tJJb8p.t3f`50O]q<W_ܦMG]hѐ!C,@n)//Wծ`%'33ӿ#.%n/Z(111""l6'&&Ο?Y_ p8ׯ_f9;}`.܄3f8Nޢ n+~w}wQQQICCٳg;C{{7BCC'iҫW/a׮]ݻS06/ZZZRSSqA,66+iFk׮˗=E;v?={4aSbԩ_~S|!9!$ ''00000P)zX@@@@ )EQu`SNgkknrJXXS0=M 6% `l$ BrBH@1lr?n6;>&Mʲ:g֬YET[[[^^^TTTzz \)QS|V5<r䈦i͇r-:=ztW\ ?ύׯ;]~˗/>nllw}쏛*++۱cGnD09O>izMuǎ駟~6t4M\`bIII9zk7:jԨ{>5<ԃz_Ν;uT^^dr:%Ftߝ.ٳgΝ5Ms]UWtXֲ2YXXzS477kvĉo̙EߔK/Z`O?}/\еzWO>6L!!!zSDEE͝;7&&?~k7(ӟ߱bM}G111}kѯe6mp8Vkbbkݯ7u+}wFK;~SEӴ EQ&McMzl잫WN2ԩS7nXlɓ]~)EQ~_]p5ʵRl?:V 6\rewukѯOmnn]pٳ]~[݈' & 0`ҤIk2o߾6ɵכ4vܸqG>sk7iگlԩSiiiaaaiiiNr-"""uTnDm!FY$ BrBH@!9!$ BrBH@!9!$ [뮻TUu}(z g}@Uն 4TMoGG k.^8&&^xڧO_|QQK.o;D^BrBH@!9!$ BrBH@!9!$ N.=_pzIENDB`mets/inst/misc/sim-nordic-twin.r0000644000176200001440000001066613623061405016351 0ustar liggesusers F1addfg<-function(t,lam0=0.5,beta=c(-0.5,-0.005,-0.004),x=rep(0,3)) # FG { ## {{{ baset <- 0.13*pnorm((t-.70)/.13) xm <- matrix(x,ncol=3) return( 1 - exp(-baset*exp(xm %*% matrix(beta,3,1)))) } ## }}} ##' @export corsim.prostate <- function(n,theta=1,thetaslope=0,crate=2,test=0,pcens=0,mt=1,same.cens=TRUE) { ## {{{ ###n <- 10; theta <- 1; thetaslope <- 0; mt <- 1 xl <- sample(1:4,n,replace=TRUE) ###xl <- rep(xl,each=2) x<-cbind(xl==2,xl==3,xl==4)*1 tt<-seq(0,mt,length=mt*100) ### ###n=100;theta=1;lam0=0.5;beta=0.3;crate=2 thetat <- exp(log(theta)) F11x<-F1addfg(mt,x=x) F12x<-F1addfg(mt,x=x) ### thetaslut <- exp(log(theta)+thetaslope*(mt-mt/2)) p11 <- thetaslut*F11x*F12x/((1-F11x)+thetaslut*F11x) p12 <- F11x-p11 p21 <- F12x-p11 p22 <- 1-F12x-F11x+p11 ###apply(cbind(p11,p12,p21),1,sum) if (test==1) { ## {{{ for (i in 1:2) { print(x[i,]); F11xt<-F1addfg(tt,x=x[i,]) F12xt<-F1addfg(tt,x=x[i,]) p11t <- thetat* F11xt*F12xt/((1-F11xt)+thetat*F11xt) cortt <- ((p11t)/(F12xt-p11t))/(F11xt/(1-F11xt)) ###plot(tt,log(cortt)) if (i==1) { plot(tt,p11t,type="l",ylim=c(0,0.1),xlim=c(0,mt)) ###lines(tt,F11x[i]-p11t,col=2) ###lines(tt,F12x[i]-p11t,col=2) } else lines(tt,p11t,col=2); ###if (sum(diff(p11t<0))>0) stop("dec\n"); ###p11 <- max(p11t) ###p12 <- F11x[i]-p11 ###p21 <- F12x[i]-p11 ###p22 <- 1- F12x[i]-F11x[i]+p11 ###pnn <- 1- F12x[i]-F11x[i]+p11 } } ## }}} ###apply(cbind(p11,p12,p21,p22),1,sum) ### types <- rep(0,n) causes <- matrix(0,n,2) stime<-matrix(mt+1,n,2); for (i in 1:n) { ptype <- runif(1) if (ptype<=p11[i]) { types[i] <- 1 myhazx<-F1addfg(tt,x=x[i,])/F12x[i] ### if (abs(max(myhazx)-1)> 0.001) stop("not dist\n"); stime[i,2]<-Cpred(cbind(myhazx,tt),runif(1))[1,2]+runif(1,0,0.001) f1<- F1addfg(tt,x=x[i,]) myhazx<- (F12x[i]/p11[i]) * (thetat*f1/((1-f1)+thetat*f1)) ### if (abs(max(myhazx)-1)> 0.001) stop("not dist\n"); stime[i,1]<-Cpred(cbind(myhazx,tt),runif(1))[1,2]+runif(1,0,0.001) causes[i,] <- c(1,1) } if ((ptype>p11[i]) & (ptype<=p12[i]+p11[i])) { types[i] <- 2 f1 <- F1addfg(tt,x=x[i,]) myhazx<- ( f1 - thetat*F12x[i]*f1/((1-f1)+thetat*f1))/p12[i]; myhazx <- f1/F11x[i] ### if (abs(max(myhazx)-1)> 0.001) stop("not dist 2 \n"); stime[i,1]<-Cpred(cbind(myhazx,tt),runif(1))[1,2]+runif(1,0,0.001) causes[i,] <- c(1,2) stime[i,2] <- runif(1)*mt } if ((ptype>p11[i]+p12[i]) && (ptype<=p21[i]+p12[i]+p11[i])) { types[i] <- 3 f2 <- F1addfg(tt,x=x[i,]) myhazx <- (f2 - (thetat*F11x[i]*f2/((1-F11x[i])+thetat*F11x[i])))/p21[i]; myhazx <- f2/F12x[i] ### if (abs(max(myhazx)-1)> 0.001) stop("not dist3 \n"); stime[i,2]<-Cpred(cbind(myhazx,tt),runif(1))[1,2]+runif(1,0,0.001) causes[i,] <- c(2,1) stime[i,1] <- runif(1)*mt } if (ptype>p11[i]+p12[i]+p21[i] ) { types[i] <- 4 causes[i,] <- c(2,2) stime[i,1:2] <- runif(2)*mt } } ###stime ###causes stime <- c(t(stime)) cause <- c(t(causes)) ###same.cens=TRUE if (same.cens==TRUE) { ctime <- rep(rbinom(n,1,pcens),each=2) ctime[ctime==1] <- rep(runif(sum(ctime==1)/2),each=2)*crate } else { ctime<- rbinom(n,1,pcens) ctime[ctime==1] <- runif(sum(ctime==1))*crate } ctime[ctime==0] <- mt; cens <- (ctime< stime) time <- ifelse(cens,ctime,stime) cause <- ifelse(cens,0,cause) id <- rep(1:n,rep(2,n)) country <- c() country[xl==1] <- "SWE" country[xl==2] <- "DK" country[xl==3] <- "FIN" country[xl==4] <- "NOR" data<-data.frame(time=time,cause=cause,xl=rep(xl,each=2), country=rep(country,each=2),id=id,cens=cens,stime=stime,type=rep(types,each=2), f1=rep(F11x,each=2),p11=rep(p11,each=2),p12=rep(p12,each=2),p21=rep(p21,each=2), p22=rep(p22,each=2)) return(data) } ## }}} ##' @export simnordic2 <- function(n,cordz=2,cormz=3,cratemz=2,cratedz=2,pcensmz=0.8,pcensdz=0.8) { ## {{{ outdz <- corsim.prostate(n,theta=cordz,crate=cratedz,pcens=pcensmz,mt=1,same.cens=TRUE,test=0) outmz <- corsim.prostate(n,theta=cormz,crate=cratemz,pcens=pcensdz,mt=1,same.cens=TRUE,test=0) outdz$zyg <- "DZ" outmz$zyg <- "MZ" outmz$id <- outmz$id+nrow(outdz) ### out <- rbind(outdz,outmz) out$time <- out$time*100 table(out$type,out$country) table(out$type,out$cause) out$country <- relevel(factor(out$country),ref="SWE") table(out$country) outk <- out[,c("country","cause","id","time","zyg","type")] table(outk$cause) table(outk$type,outk$country) table(outk$cause,outk$country) ### return(outk) } ## }}} ###outk <- simnordic(2000) mets/inst/misc/workshop-src.org0000644000176200001440000010015213623061405016303 0ustar liggesusers#+PROPERTY: session *R* # +PROPERTY: cache yes #+PROPERTY: results output #+PROPERTY: exports both #+PROPERTY: width 550 #+PROPERTY: height 450 #+PROPERTY: tangle yes #+PROPERTY: comments yes # +PROPERTY: eval never * Installation Install dependencies (=R>=2.15=) : #+BEGIN_SRC R :exports none palette(c("darkblue","darkred","orange","olivedrab")) #+END_SRC #+RESULTS: #+BEGIN_SRC R :exports code :eval never install.packages(c("mets","cmprsk"), dependencies=TRUE) #+END_SRC /OBS:/ At this point you might have to restart =R= to flush the cache of previously installed versions of the packages. If you have previously installed =timereg= and =lava=, make sure that you have the current versions installed (timereg: =>=1.8.4=, lava: =>=1.2.6=). * Load simulated data #+NAME: Loading #+BEGIN_SRC R :exports code :wrap example library(mets) #+END_SRC The dataset =prt= contains (simulated) observations on prostate cancer with the following columns + =country= :: Country (Denmark,Finland,Norway,Sweden) + =time= :: exit time (censoring,death or prostate cancer) + =status= :: Status (censoring=0,death=1 or prostate cancer=2) + =zyg= :: Zygosity (DZ,MZ) + =id= :: Twin id number + =cancer= :: cancer indicator (status=2) #+NAME: Loading #+BEGIN_SRC R :wrap example data(prt) head(prt) #+END_SRC #+RESULTS: Loading #+BEGIN_example country time status zyg id cancer 31 Denmark 96.98833 1 DZ 1 0 32 Denmark 80.88885 1 DZ 1 0 39 Denmark 68.04498 1 DZ 3 0 40 Denmark 61.45903 1 DZ 3 0 51 Denmark 78.78068 1 DZ 5 0 52 Denmark 90.36252 1 DZ 5 0 #+END_example Status table #+BEGIN_SRC R :wrap example prtwide <- fast.reshape(prt,id="id") ftable(status1~status2,prtwide) #+END_SRC #+RESULTS: #+BEGIN_example status1 0 1 2 status2 0 9278 883 156 1 936 2308 193 2 163 199 106 #+END_example * Estimation of cumulative incidence #+BEGIN_SRC R :wrap example times <- seq(40,100,by=2) cifmod <- comp.risk(Event(time,status)~+1+cluster(id),data=prt, cause=2,n.sim=0, times=times,conservative=1,max.clust=NULL,model="fg") theta.des <- model.matrix(~-1+factor(zyg),data=prt) ## design for MZ/DZ status or1 <- or.cif(cifmod,data=prt,cause1=2,cause2=2,theta.des=theta.des, score.method="fisher.scoring",same.cens=TRUE) summary(or1) or1$score #+END_SRC #+RESULTS: #+BEGIN_example OR for dependence for competing risks OR of cumulative incidence for cause1= 2 and cause2= 2 log-ratio Coef. SE z P-val Ratio SE factor(zyg)DZ 0.785 0.221 3.55 3.82e-04 2.19 0.485 factor(zyg)MZ 2.100 0.278 7.56 4.11e-14 8.14 2.260 [,1] [1,] 1.246052e-08 [2,] 3.140461e-08 #+END_example #+BEGIN_SRC R :results output graphics :file pcif.png pcif <- predict(cifmod,X=1,resample.iid=0,uniform=0,se=0) plot(pcif,multiple=1,se=0,uniform=0,ylim=c(0,0.15)) #+END_SRC #+RESULTS: [[file:pcif.png]] Assumes that the censoring of the two twins are independent (when they are the same): #+BEGIN_SRC R :wrap example incorrect.or1 <- or.cif(cifmod,data=prt,cause1=2,cause2=2,theta.des=theta.des, theta=c(2.8,8.6),score.method="fisher.scoring") summary(incorrect.or1) ## not bad incorrect.or1$score #+END_SRC * Correcting for country #+BEGIN_SRC R :results output graphics :file pcifl.png table(prt$country) times <- seq(40,100,by=2) cifmodl <-comp.risk(Event(time,status)~-1+factor(country)+cluster(id),data=prt, cause=2,n.sim=0,times=times,conservative=1, max.clust=NULL,cens.model="aalen") pcifl <- predict(cifmodl,X=diag(4),se=0,uniform=0) plot(pcifl,multiple=1,se=0,uniform=0,col=1:4,ylim=c(0,0.2)) legend("topleft",levels(prt$country),col=1:4,lty=1) #+END_SRC #+RESULTS: [[file:pcifl.png]] Design for MZ/DZ status #+BEGIN_SRC R :wrap example theta.des <- model.matrix(~-1+factor(zyg),data=prt) or.country <- or.cif(cifmodl,data=prt,cause1=2,cause2=2,theta.des=theta.des, theta=c(0.8,2.1),score.method="fisher.scoring",same.cens=TRUE) summary(or.country) #+END_SRC #+RESULTS: #+BEGIN_example OR for dependence for competing risks OR of cumulative incidence for cause1= 2 and cause2= 2 log-ratio Coef. SE z P-val Ratio SE factor(zyg)DZ 0.736 0.234 3.15 1.66e-03 2.09 0.488 factor(zyg)MZ 1.860 0.279 6.67 2.54e-11 6.44 1.800 #+END_example * Concordance estimation Ignoring country. Computing casewise, using =prodlim=. CIF: #+BEGIN_SRC R :exports code :wrap example library('prodlim') outm <- prodlim(Hist(time,status)~+1,data=prt) times <- 60:100 ## cause is 2 (second cause) cifmz <- predict(outm,cause=2,time=times,newdata=data.frame(zyg="MZ")) cifdz <- predict(outm,cause=2,time=times,newdata=data.frame(zyg="DZ")) #+END_SRC #+RESULTS: #+BEGIN_example #+END_example #+BEGIN_SRC R :exports code ### casewise pp33 <- bicomprisk(Event(time,status)~strata(zyg)+id(id),data=prt,cause=c(2,2),prodlim=TRUE) pp33dz <- pp33$model$"DZ" pp33mz <- pp33$model$"MZ" concdz <- predict(pp33dz,cause=1,time=times,newdata=data.frame(zyg="DZ")) concmz <- predict(pp33mz,cause=1,time=times,newdata=data.frame(zyg="MZ")) #+END_SRC #+RESULTS: : Strata 'DZ' : Strata 'MZ' #+BEGIN_SRC R :results output graphics :file concordance.png par(mfrow=c(1,2)) plot(times,concdz,ylim=c(0,0.1),type="s") lines(pcif$time,pcif$P1^2,col=2) title(main="DZ Conc. Prostate cancer") plot(times,concmz,ylim=c(0,0.1),type="s") title(main="MZ Conc. Prostate cancer") lines(pcif$time,pcif$P1^2,col=2) #+END_SRC #+RESULTS: [[file:concordance.png]] #+BEGIN_SRC R :results output graphics :file casewisea.png par(mfrow=c(1,1)) cdz <- casewise(pp33dz,outm,cause.marg=2) cmz <- casewise(pp33mz,outm,cause.marg=2) plot(cmz,ci=NULL,ylim=c(0,0.5),xlim=c(60,100),legend=TRUE,col=c(3,2,1)) par(new=TRUE) plot(cdz,ci=NULL,ylim=c(0,0.5),xlim=c(60,100),legend=TRUE) #+END_SRC #+RESULTS: [[file:casewisea.png]] Similar analyses using =comp.risk= for competing risks leads to tests for equal concordance and more correct standard errors #+BEGIN_SRC R :exports code p33 <- bicomprisk(Event(time,status)~strata(zyg)+id(id),data=prt,cause=c(2,2),return.data=1) p33dz <- p33$model$"DZ"$comp.risk p33mz <- p33$model$"MZ"$comp.risk #+END_SRC #+RESULTS: : Strata 'DZ' : Strata 'MZ' #+BEGIN_SRC R :wrap example head(cbind(p33mz$time, p33mz$P1, p33mz$se.P1)) head(cbind(p33dz$time, p33dz$P1, p33dz$se.P1)) #+END_SRC #+RESULTS: #+BEGIN_example [,1] [,2] [,3] [1,] 60.88384 0.001354486 0.0006759148 [2,] 64.98252 0.001738665 0.0007767791 [3,] 66.34227 0.002145175 0.0008759241 [4,] 67.23626 0.002553690 0.0009656368 [5,] 67.96152 0.002980112 0.0010544136 [6,] 68.37310 0.003852670 0.0012192761 [,1] [,2] [,3] [1,] 58.85519 0.0001741916 0.0001740997 [2,] 67.87387 0.0004044091 0.0002883926 [3,] 69.55123 0.0006488647 0.0003777479 [4,] 70.83183 0.0009069944 0.0004570724 [5,] 71.05738 0.0011672691 0.0005255212 [6,] 71.06602 0.0014276382 0.0005859026 #+END_example Test for genetic effect, needs other form of bicomprisk with iid decomp #+BEGIN_SRC R :wrap example conc1 <- p33dz conc2 <- p33mz test.conc(p33dz,p33mz); #+END_SRC #+RESULTS: #+BEGIN_example $test cum dif. sd z pval pepe-mori 0.3936686 0.09835827 4.002394 6.270472e-05 $mintime [1] 60.88384 $maxtime [1] 96.92463 $same.cluster [1] FALSE attr(,"class") [1] "testconc" #+END_example OR expression of difference in concordance functions and Gray test #+BEGIN_SRC R :wrap example data33mz <- p33$model$"MZ"$data data33mz$zyg <- 1 data33dz <- p33$model$"DZ"$data data33dz$zyg <- 0 data33 <- rbind(data33mz,data33dz) library(cmprsk) ftime <- data33$time fstatus <- data33$status table(fstatus) #+END_SRC #+RESULTS: #+BEGIN_example fstatus 0 1 2 9597 106 4519 #+END_example #+BEGIN_SRC R :wrap example group <- data33$zyg graytest <- cuminc(ftime,fstatus,group) graytest #+END_SRC #+RESULTS: #+BEGIN_example Tests: stat pv df 1 28.82416 7.925617e-08 1 2 33.79236 6.131919e-09 1 Estimates and Variances: $est 20 40 60 80 100 0 1 0.0000000000 0.00000000 0.0001741916 0.006741025 0.01880244 1 1 0.0000000000 0.00000000 0.0006710172 0.017420360 0.05031415 0 2 0.0006970762 0.01974882 0.1141800067 0.504364854 0.93797293 1 2 0.0009363302 0.01655314 0.0948098327 0.443996722 0.90692430 $var 20 40 60 80 100 0 1 0.000000e+00 0.000000e+00 3.034323e-08 2.115863e-06 9.493584e-06 1 1 0.000000e+00 0.000000e+00 2.250627e-07 9.173278e-06 5.102841e-05 0 2 8.094463e-08 2.487399e-06 1.556735e-05 6.990685e-05 4.769058e-05 1 2 1.752378e-07 3.424511e-06 2.388136e-05 1.271394e-04 1.171775e-04 #+END_example #+BEGIN_SRC R :wrap example zygeffect <- comp.risk(Event(time,status)~const(zyg), data=data33,cause=1, cens.model="aalen",model="logistic",conservative=1) summary(zygeffect) #+END_SRC #+RESULTS: #+BEGIN_example Competing risks Model No test for non-parametric terms Parametric terms : Coef. SE Robust SE z P-val const(zyg) 0.944 0.218 0.218 4.335 0 #+END_example * Liability model, ignoring censoring #+BEGIN_SRC R :wrap example (M <- with(prt, table(cancer,zyg))) #+END_SRC #+RESULTS: #+BEGIN_example zyg cancer DZ MZ 0 17408 10872 1 583 359 #+END_example #+BEGIN_SRC R :wrap example coef(lm(cancer~-1+zyg,prt)) #+END_SRC #+RESULTS: #+BEGIN_example zygDZ zygMZ 0.03240509 0.03196510 #+END_example Saturated model #+BEGIN_SRC R :wrap example bpmz <- biprobit(cancer~1 + cluster(id), data=subset(prt,zyg=="MZ"), eqmarg=TRUE) logLik(bpmz) # Log-likelihood AIC(bpmz) # AIC coef(bpmz) # Parameter estimates vcov(bpmz) # Asymptotic covariance summary(bpmz) # concordance, case-wise, tetrachoric correlations, ... #+END_SRC #+RESULTS: #+BEGIN_example 'log Lik.' -1472.972 (df=2) [1] 2949.943 (Intercept) r:(Intercept) -1.8539454 0.8756507 (Intercept) r:(Intercept) (Intercept) 0.0007089727 0.0003033296 r:(Intercept) 0.0003033296 0.0044023587 Estimate Std.Err Z p-value (Intercept) -1.853945 0.026627 -69.627725 0 r:(Intercept) 0.875651 0.066350 13.197393 0 logLik: -1472.972 mean(score^2): 1.667e-12 n pairs 11231 5473 Estimate 2.5% 97.5% Rel.Recur.Risk 11.13385 9.12561 13.14209 OR 25.34928 17.69032 36.32415 Tetrachoric correlation 0.70423 0.63252 0.76398 Concordance 0.01131 0.00886 0.01443 Casewise Concordance 0.35487 0.29391 0.42094 Marginal 0.03187 0.02834 0.03583 #+END_example #+BEGIN_SRC R :exports code bp0 <- biprobit(cancer~1 + cluster(id)+strata(zyg), data=prt) #+END_SRC #+RESULTS: : Strata 'DZ' : Strata 'MZ' #+BEGIN_SRC R :wrap example summary(bp0) #+END_SRC #+RESULTS: #+BEGIN_example ------------------------------------------------------------ Strata 'DZ' Estimate Std.Err Z p-value (Intercept) -1.846842 0.019247 -95.955194 0 r:(Intercept) 0.418063 0.050421 8.291403 0 logLik: -2536.242 mean(score^2): 4.795e-08 n pairs 17991 8749 Estimate 2.5% 97.5% Rel.Recur.Risk 4.63766 3.44436 5.83097 OR 6.03709 4.26005 8.55541 Tetrachoric correlation 0.39530 0.30882 0.47529 Concordance 0.00486 0.00361 0.00655 Casewise Concordance 0.15019 0.11458 0.19443 Marginal 0.03239 0.02976 0.03523 ------------------------------------------------------------ Strata 'MZ' Estimate Std.Err Z p-value (Intercept) -1.853945 0.026627 -69.627725 0 r:(Intercept) 0.875651 0.066350 13.197393 0 logLik: -1472.972 mean(score^2): 1.667e-12 n pairs 11231 5473 Estimate 2.5% 97.5% Rel.Recur.Risk 11.13385 9.12561 13.14209 OR 25.34928 17.69032 36.32415 Tetrachoric correlation 0.70423 0.63252 0.76398 Concordance 0.01131 0.00886 0.01443 Casewise Concordance 0.35487 0.29391 0.42094 Marginal 0.03187 0.02834 0.03583 #+END_example Equal marginals MZ/DZ #+BEGIN_SRC R :wrap example bp1 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="u",data=prt) (s <- summary(bp1)) #+END_SRC #+RESULTS: #+BEGIN_example Estimate Std.Err Z p-value (Intercept) -1.849284 0.015601 -118.539777 0 atanh(rho) MZ 0.877667 0.065815 13.335456 0 atanh(rho) DZ 0.417475 0.050276 8.303615 0 Total MZ/DZ Complete pairs MZ/DZ 11231/17991 5473/8749 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.70525 0.63436 0.76438 Tetrachoric correlation DZ 0.39480 0.30854 0.47462 MZ: Estimate 2.5% 97.5% Concordance 0.01149 0.00942 0.01400 Casewise Concordance 0.35672 0.29764 0.42049 Marginal 0.03221 0.03007 0.03449 Rel.Recur.Risk 11.07524 9.15861 12.99187 log(OR) 3.23267 2.87294 3.59240 DZ: Estimate 2.5% 97.5% Concordance 0.00482 0.00363 0.00640 Casewise Concordance 0.14956 0.11441 0.19315 Marginal 0.03221 0.03007 0.03449 Rel.Recur.Risk 4.64343 3.44806 5.83880 log(OR) 1.79800 1.44936 2.14664 Estimate 2.5% 97.5% Broad-sense heritability 0.62090 0.41075 0.83104 #+END_example Components (concordance,cor,...) can be extracted from returned list #+BEGIN_SRC R :wrap example s$all #+END_SRC #+RESULTS: #+BEGIN_example Estimate 2.5% 97.5% Broad-sense heritability 0.620895123 0.410750791 0.831039456 Tetrachoric correlation MZ 0.705248649 0.634356555 0.764377525 Tetrachoric correlation DZ 0.394801088 0.308543841 0.474618274 MZ Concordance 0.011489242 0.009421632 0.014004180 MZ Casewise Concordance 0.356715718 0.297643976 0.420492294 MZ Marginal 0.032208397 0.030073567 0.034489384 MZ Rel.Recur.Risk 11.075239606 9.158610607 12.991868605 MZ log(OR) 3.232669332 2.872936675 3.592401989 DZ Concordance 0.004817009 0.003625030 0.006398416 DZ Casewise Concordance 0.149557552 0.114405844 0.193154114 DZ Marginal 0.032208397 0.030073567 0.034489384 DZ Rel.Recur.Risk 4.643433529 3.448063130 5.838803929 DZ log(OR) 1.798001419 1.449361036 2.146641803 #+END_example Likelihood Ratio Test #+BEGIN_SRC R :wrap example compare(bp0,bp1) #+END_SRC #+RESULTS: #+BEGIN_example - Likelihood ratio test - data: chisq = 0.046769, df = 1, p-value = 0.8288 sample estimates: log likelihood (model 1) log likelihood (model 2) -4009.213 -4009.237 #+END_example Polygenic Libability model via te =bptwin= function (=type= can be a subset of "acde", or "flex" for stratitified, "u" for random effects model with same marginals for MZ and DZ) #+BEGIN_SRC R :wrap example bp2 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id",type="ace",data=prt) summary(bp2) #+END_SRC #+RESULTS: #+BEGIN_example Estimate Std.Err Z p-value (Intercept) -3.40624 0.19032 -17.89736 0.0000 log(var(A)) 0.74503 0.25710 2.89787 0.0038 log(var(C)) -1.25112 1.04238 -1.20024 0.2300 Total MZ/DZ Complete pairs MZ/DZ 11231/17991 5473/8749 Estimate 2.5% 97.5% A 0.62090 0.41075 0.83104 C 0.08435 -0.09373 0.26244 E 0.29475 0.22992 0.35959 MZ Tetrachoric Cor 0.70525 0.63436 0.76438 DZ Tetrachoric Cor 0.39480 0.30854 0.47462 MZ: Estimate 2.5% 97.5% Concordance 0.01149 0.00942 0.01400 Casewise Concordance 0.35672 0.29764 0.42049 Marginal 0.03221 0.03007 0.03449 Rel.Recur.Risk 11.07524 9.15861 12.99187 log(OR) 3.23267 2.87294 3.59240 DZ: Estimate 2.5% 97.5% Concordance 0.00482 0.00363 0.00640 Casewise Concordance 0.14956 0.11441 0.19315 Marginal 0.03221 0.03007 0.03449 Rel.Recur.Risk 4.64343 3.44806 5.83880 log(OR) 1.79800 1.44936 2.14664 Estimate 2.5% 97.5% Broad-sense heritability 0.62090 0.41075 0.83104 #+END_example * Liability model, Inverse Probability Weighting Probability weights based on Aalen's additive model #+BEGIN_SRC R :results output graphics :file ipw.png prtw <- ipw(Surv(time,status==0)~country, data=prt, cluster="id",weight.name="w") plot(0,type="n",xlim=range(prtw$time),ylim=c(0,1),xlab="Age",ylab="Probability") count <- 0 for (l in unique(prtw$country)) { count <- count+1 prtw <- prtw[order(prtw$time),] with(subset(prtw,country==l), lines(time,w,col=count,lwd=2)) } legend("topright",legend=unique(prtw$country),col=1:4,pch=-1,lty=1) #+END_SRC #+RESULTS: [[file:ipw.png]] #+BEGIN_SRC R :wrap example bpmzIPW <- biprobit(cancer~1 + cluster(id), data=subset(prtw,zyg=="MZ"), weight="w") (smz <- summary(bpmzIPW)) #+END_SRC #+RESULTS: #+BEGIN_example Estimate Std.Err Z p-value (Intercept) -1.226276 0.043074 -28.469378 0 r:(Intercept) 0.912669 0.100316 9.097910 0 logLik: -6703.246 mean(score^2): 8.069e-08 n pairs 2722 997 Estimate 2.5% 97.5% Rel.Recur.Risk 4.53325 3.70162 5.36488 OR 15.06945 9.15935 24.79307 Tetrachoric correlation 0.72241 0.61446 0.80381 Concordance 0.05490 0.04221 0.07113 Casewise Concordance 0.49887 0.41321 0.58460 Marginal 0.11005 0.09514 0.12696 #+END_example Comparison with CIF #+BEGIN_SRC R :results output graphics :file cifMZ.png plot(pcif,multiple=1,se=1,uniform=0,ylim=c(0,0.15)) abline(h=smz$prob["Marginal",],lwd=c(2,1,1)) ## Wrong estimates: abline(h=summary(bpmz)$prob["Marginal",],lwd=c(2,1,1),col="lightgray") #+END_SRC #+RESULTS: [[file:cifMZ.png]] Concordance estimates #+BEGIN_SRC R :results output graphics :file conc2.png plot(pp33mz,ylim=c(0,0.1)) abline(h=smz$prob["Concordance",],lwd=c(2,1,1)) ## Wrong estimates: abline(h=summary(bpmz)$prob["Concordance",],lwd=c(2,1,1),col="lightgray") #+END_SRC #+RESULTS: [[file:conc2.png]] ACE model with IPW #+BEGIN_SRC R :wrap example bp3 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id", type="ace",data=prtw,weight="w") summary(bp3) #+END_SRC #+RESULTS: #+BEGIN_example Estimate Std.Err Z p-value (Intercept) -2.31618 0.18673 -12.40359 0e+00 log(var(A)) 0.85390 0.22689 3.76347 2e-04 log(var(C)) -21.60061 1.29095 -16.73235 0e+00 Total MZ/DZ Complete pairs MZ/DZ 2722/5217 997/1809 Estimate 2.5% 97.5% A 0.70138 0.60824 0.79452 C 0.00000 0.00000 0.00000 E 0.29862 0.20548 0.39176 MZ Tetrachoric Cor 0.70138 0.59586 0.78310 DZ Tetrachoric Cor 0.35069 0.30328 0.39637 MZ: Estimate 2.5% 97.5% Concordance 0.04857 0.03963 0.05940 Casewise Concordance 0.47238 0.39356 0.55260 Marginal 0.10281 0.09463 0.11161 Rel.Recur.Risk 4.59457 3.79490 5.39425 log(OR) 2.63276 2.15803 3.10749 DZ: Estimate 2.5% 97.5% Concordance 0.02515 0.02131 0.02965 Casewise Concordance 0.24461 0.21892 0.27226 Marginal 0.10281 0.09463 0.11161 Rel.Recur.Risk 2.37919 2.13966 2.61872 log(OR) 1.22877 1.06721 1.39032 Estimate 2.5% 97.5% Broad-sense heritability 0.70138 0.60824 0.79452 #+END_example Equal marginals but free variance structure between MZ and DZ #+BEGIN_SRC R :wrap example bp4 <- bptwin(cancer~1,zyg="zyg",DZ="DZ",id="id", type="u",data=prtw,weight="w") summary(bp4) #+END_SRC #+RESULTS: #+BEGIN_example Estimate Std.Err Z p-value (Intercept) -1.266427 0.024091 -52.568381 0 atanh(rho) MZ 0.898548 0.098841 9.090866 0 atanh(rho) DZ 0.312574 0.073668 4.243006 0 Total MZ/DZ Complete pairs MZ/DZ 2722/5217 997/1809 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.71559 0.60742 0.79771 Tetrachoric correlation DZ 0.30278 0.16662 0.42760 MZ: Estimate 2.5% 97.5% Concordance 0.04974 0.04044 0.06104 Casewise Concordance 0.48442 0.40185 0.56785 Marginal 0.10268 0.09453 0.11144 Rel.Recur.Risk 4.71777 3.88751 5.54802 log(OR) 2.70711 2.20930 3.20492 DZ: Estimate 2.5% 97.5% Concordance 0.02269 0.01667 0.03081 Casewise Concordance 0.22097 0.16448 0.29013 Marginal 0.10268 0.09453 0.11144 Rel.Recur.Risk 2.15203 1.53917 2.76490 log(OR) 1.06411 0.61335 1.51487 Estimate 2.5% 97.5% Broad-sense heritability 0.82563 0.50195 1.14931 #+END_example Check convergence #+BEGIN_SRC R :wrap example mean(score(bp4)^2) #+END_SRC #+RESULTS: #+BEGIN_example [1] 5.902721e-13 #+END_example * Liability model, adjusting for covariates Main effect of country #+BEGIN_SRC R :wrap example bp6 <- bptwin(cancer~country,zyg="zyg",DZ="DZ",id="id", type="ace",data=prtw,weight="w") summary(bp6) #+END_SRC #+RESULTS: #+BEGIN_example Estimate Std.Err Z p-value (Intercept) -2.81553 0.23889 -11.78590 0e+00 countryFinland 0.87558 0.16123 5.43061 0e+00 countryNorway 0.68483 0.17762 3.85567 1e-04 countrySweden 0.77248 0.12350 6.25468 0e+00 log(var(A)) 0.77724 0.23186 3.35220 8e-04 log(var(C)) -33.42341 0.11521 -290.10502 0e+00 Total MZ/DZ Complete pairs MZ/DZ 2722/5217 997/1809 Estimate 2.5% 97.5% A 0.68509 0.58704 0.78313 C 0.00000 NaN NaN E 0.31491 0.21687 0.41296 MZ Tetrachoric Cor 0.68509 0.57428 0.77124 DZ Tetrachoric Cor 0.34254 0.29262 0.39060 MZ: Estimate 2.5% 97.5% Concordance 0.02236 0.01588 0.03141 Casewise Concordance 0.39194 0.30778 0.48305 Marginal 0.05705 0.04654 0.06977 Rel.Recur.Risk 6.86967 5.08343 8.65591 log(OR) 2.82584 2.31543 3.33626 DZ: Estimate 2.5% 97.5% Concordance 0.00989 0.00700 0.01394 Casewise Concordance 0.17329 0.14505 0.20570 Marginal 0.05705 0.04654 0.06977 Rel.Recur.Risk 3.03735 2.56114 3.51356 log(OR) 1.38153 1.18508 1.57798 Estimate 2.5% 97.5% Broad-sense heritability 0.68509 0.58704 0.78313 Warning messages: 1: In sqrt(diag(vcovACDE)) : NaNs produced 2: In sqrt(diag(vcovACDE)) : NaNs produced #+END_example #+BEGIN_SRC R :wrap example bp7 <- bptwin(cancer~country,zyg="zyg",DZ="DZ",id="id", type="u",data=prtw,weight="w") summary(bp7) #+END_SRC #+RESULTS: #+BEGIN_example Estimate Std.Err Z p-value (Intercept) -1.581478 0.051318 -30.817030 0e+00 countryFinland 0.491725 0.081517 6.032155 0e+00 countryNorway 0.385830 0.094254 4.093497 0e+00 countrySweden 0.433789 0.060648 7.152599 0e+00 atanh(rho) MZ 0.884166 0.099366 8.898113 0e+00 atanh(rho) DZ 0.271770 0.073240 3.710668 2e-04 Total MZ/DZ Complete pairs MZ/DZ 2722/5217 997/1809 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.70850 0.59760 0.79280 Tetrachoric correlation DZ 0.26527 0.12752 0.39298 MZ: Estimate 2.5% 97.5% Concordance 0.02347 0.01664 0.03300 Casewise Concordance 0.41255 0.32395 0.50721 Marginal 0.05688 0.04643 0.06953 Rel.Recur.Risk 7.25251 5.40099 9.10403 log(OR) 2.95065 2.42382 3.47748 DZ: Estimate 2.5% 97.5% Concordance 0.00794 0.00489 0.01287 Casewise Concordance 0.13966 0.09312 0.20421 Marginal 0.05688 0.04643 0.06953 Rel.Recur.Risk 2.45511 1.47912 3.43110 log(OR) 1.08717 0.56716 1.60718 Estimate 2.5% 97.5% Broad-sense heritability 0.88646 0.55608 1.21683 #+END_example Stratified analysis #+BEGIN_SRC R :exports code :results value bp8 <- bptwin(cancer~strata(country),zyg="zyg",DZ="DZ",id="id", type="u",data=prtw,weight="w") #+END_SRC #+RESULTS: #+BEGIN_SRC R :wrap example summary(bp8) #+END_SRC #+RESULTS: #+BEGIN_example Strata 'Denmark' Strata 'Finland' Strata 'Norway' Strata 'Sweden' ------------------------------------------------------------ Strata 'Denmark' Estimate Std.Err Z p-value (Intercept) -1.583608 0.051241 -30.904857 0.0000 atanh(rho) MZ 0.992896 0.217349 4.568215 0.0000 atanh(rho) DZ 0.070588 0.186956 0.377566 0.7058 Total MZ/DZ Complete pairs MZ/DZ 760/1611 287/589 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.75859 0.51308 0.88937 Tetrachoric correlation DZ 0.07047 -0.28750 0.41117 MZ: Estimate 2.5% 97.5% Concordance 0.02611 0.01584 0.04274 Casewise Concordance 0.46093 0.28426 0.64799 Marginal 0.05664 0.04623 0.06922 Rel.Recur.Risk 8.13766 4.72047 11.55486 log(OR) 3.24111 2.13448 4.34774 DZ: Estimate 2.5% 97.5% Concordance 0.00420 0.00110 0.01596 Casewise Concordance 0.07422 0.01888 0.25037 Marginal 0.05664 0.04623 0.06922 Rel.Recur.Risk 1.31043 -0.43515 3.05601 log(OR) 0.30910 -1.24175 1.85996 Estimate 2.5% 97.5% Broad-sense heritability 1 NaN NaN ------------------------------------------------------------ Strata 'Finland' Estimate Std.Err Z p-value (Intercept) -1.087902 0.063221 -17.207912 0.0000 atanh(rho) MZ 0.859335 0.302752 2.838410 0.0045 atanh(rho) DZ 0.393145 0.179942 2.184840 0.0289 Total MZ/DZ Complete pairs MZ/DZ 392/1001 134/316 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.69592 0.25985 0.89623 Tetrachoric correlation DZ 0.37407 0.04044 0.63265 MZ: Estimate 2.5% 97.5% Concordance 0.07008 0.03975 0.12064 Casewise Concordance 0.50666 0.27641 0.73412 Marginal 0.13832 0.11316 0.16801 Rel.Recur.Risk 3.66298 1.85349 5.47246 log(OR) 2.48001 0.96954 3.99049 DZ: Estimate 2.5% 97.5% Concordance 0.04160 0.02237 0.07607 Casewise Concordance 0.30073 0.16558 0.48242 Marginal 0.13832 0.11316 0.16801 Rel.Recur.Risk 2.17417 1.00995 3.33838 log(OR) 1.22415 0.21090 2.23739 Estimate 2.5% 97.5% Broad-sense heritability 0.64369 -0.21675 1.50414 ------------------------------------------------------------ Strata 'Norway' Estimate Std.Err Z p-value (Intercept) -1.192293 0.079124 -15.068598 0.0000 atanh(rho) MZ 0.916471 0.301133 3.043409 0.0023 atanh(rho) DZ 0.533761 0.252070 2.117509 0.0342 Total MZ/DZ Complete pairs MZ/DZ 387/618 115/155 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.72422 0.31516 0.90635 Tetrachoric correlation DZ 0.48825 0.03969 0.77303 MZ: Estimate 2.5% 97.5% Concordance 0.05918 0.03218 0.10633 Casewise Concordance 0.50764 0.27633 0.73572 Marginal 0.11657 0.08945 0.15057 Rel.Recur.Risk 4.35466 2.15709 6.55223 log(OR) 2.69720 1.19745 4.19695 DZ: Estimate 2.5% 97.5% Concordance 0.03945 0.01840 0.08257 Casewise Concordance 0.33842 0.15583 0.58636 Marginal 0.11657 0.08945 0.15057 Rel.Recur.Risk 2.90310 0.89710 4.90911 log(OR) 1.67675 0.28373 3.06976 Estimate 2.5% 97.5% Broad-sense heritability 0.47195 -0.47133 1.41522 ------------------------------------------------------------ Strata 'Sweden' Estimate Std.Err Z p-value (Intercept) -1.149412 0.032155 -35.745836 0.0000 atanh(rho) MZ 0.836864 0.125476 6.669520 0.0000 atanh(rho) DZ 0.199677 0.092907 2.149202 0.0316 Total MZ/DZ Complete pairs MZ/DZ 1183/1987 461/749 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.68414 0.53057 0.79423 Tetrachoric correlation DZ 0.19706 0.01758 0.36425 MZ: Estimate 2.5% 97.5% Concordance 0.06055 0.04659 0.07835 Casewise Concordance 0.48365 0.38001 0.58872 Marginal 0.12519 0.11277 0.13877 Rel.Recur.Risk 3.86327 3.00137 4.72517 log(OR) 2.46295 1.83001 3.09590 DZ: Estimate 2.5% 97.5% Concordance 0.02515 0.01672 0.03766 Casewise Concordance 0.20088 0.13541 0.28746 Marginal 0.12519 0.11277 0.13877 Rel.Recur.Risk 1.60452 0.99901 2.21004 log(OR) 0.66610 0.08952 1.24268 Estimate 2.5% 97.5% Broad-sense heritability 0.97416 0.53594 1.41238 #+END_example Wald test (stratified vs main effect) #+BEGIN_SRC R :wrap example B <- contr(3,4)[-(1:3),] compare(bp8,contrast=B) #+END_SRC #+RESULTS: #+BEGIN_example - Wald test - Null Hypothesis: [Denmark.atanh(rho) MZ] - [Finland.atanh(rho) MZ] = 0 [Denmark.atanh(rho) MZ] - [Norway.atanh(rho) MZ] = 0 [Denmark.atanh(rho) MZ] - [Sweden.atanh(rho) MZ] = 0 [Denmark.atanh(rho) DZ] - [Finland.atanh(rho) DZ] = 0 [Denmark.atanh(rho) DZ] - [Norway.atanh(rho) DZ] = 0 [Denmark.atanh(rho) DZ] - [Sweden.atanh(rho) DZ] = 0 data: chisq = 3.4972, df = 6, p-value = 0.7443 sample estimates: Estimate Std.Err [Denmark.atanh(rho) MZ] - [Finland.atanh(rho) MZ] 0.13356056 0.3726923 [Denmark.atanh(rho) MZ] - [Norway.atanh(rho) MZ] 0.07642511 0.3713780 [Denmark.atanh(rho) MZ] - [Sweden.atanh(rho) MZ] 0.15603181 0.2509676 [Denmark.atanh(rho) DZ] - [Finland.atanh(rho) DZ] -0.32255628 0.2594839 [Denmark.atanh(rho) DZ] - [Norway.atanh(rho) DZ] -0.46317298 0.3138347 [Denmark.atanh(rho) DZ] - [Sweden.atanh(rho) DZ] -0.12908846 0.2087690 2.5% 97.5% [Denmark.atanh(rho) MZ] - [Finland.atanh(rho) MZ] -0.5969029 0.8640240 [Denmark.atanh(rho) MZ] - [Norway.atanh(rho) MZ] -0.6514624 0.8043126 [Denmark.atanh(rho) MZ] - [Sweden.atanh(rho) MZ] -0.3358556 0.6479192 [Denmark.atanh(rho) DZ] - [Finland.atanh(rho) DZ] -0.8311353 0.1860227 [Denmark.atanh(rho) DZ] - [Norway.atanh(rho) DZ] -1.0782776 0.1519316 [Denmark.atanh(rho) DZ] - [Sweden.atanh(rho) DZ] -0.5382682 0.2800912 #+END_example * COMMENT Cumulative heritability #+BEGIN_SRC R :wrap example args(cumh) #+END_SRC #+RESULTS: #+BEGIN_example Error in args(cumh) : object 'cumh' not found #+END_example #+BEGIN_SRC R :exports code ch1 <- cumh(cancer~1,time="time",zyg="zyg",DZ="DZ",id="id", type="ace",data=prtw,weight="w") #+END_SRC #+RESULTS: : Error: could not find function "cumh" #+BEGIN_SRC R :wrap example summary(ch1) #+END_SRC #+RESULTS: #+BEGIN_example Error in summary(ch1) : object 'ch1' not found #+END_example #+BEGIN_SRC R :results output graphics :file cumh.png plot(ch1) #+END_SRC #+RESULTS: [[file:cumh.png]] ----- mets/inst/misc/cif2.png0000644000176200001440000003572313623061405014475 0ustar liggesusersPNG  IHDR}Ծ$iCCPICC Profile8UoT>oR? XGůUS[IJ*$:7鶪O{7@Hkk?<kktq݋m6nƶد-mR;`zv x#=\% oYRڱ#&?>ҹЪn_;j;$}*}+(}'}/LtY"$].9｟%{_a݊]hk5'SN{<_ t jM{-4%TńtY۟R6#v\喊x:'HO3^&0::m,L%3:qVE t]~Iv6Wٯ) |ʸ2]G4(6w‹$"AEv m[D;Vh[}چN|3HS:KtxU'D;77;_"e?Yqxl+7jIDATx x7B` Q E!\ԢVZZ6JE"D /`-VThK+-?пPRh5 -ݰvg9L$$L  P& @@ !  ` tD@6 $`Щ@0 6m@J@Hl  @*@   ` tD@6 $`Щ@0 6m@J@Hl  @*@   ` tD@6 $`Щ@0 6m@J@Hl  @*@   ` tD@6 $`Щ@0 6m@J@Hl  @*@   ` tD@6 $`Щ@0 6m@J@Hl  @*@   ` tD@6 $`Щ@0 6m@J@Hl  @*@   ` tD@6 $`Щ@0 6m@J@Hl  @*@Ho)^ X@8.D>J2)~go̞=[nF}EK@lxW_^z%۷O222$996MT{r' @غu8-_X[lCJNNkNƏ/UUUP) "oڴI˭gΜ)]v]vڵkeǎ1! &-p +ӦMLܹ0T @<O-sӀu# pmA|ʔ)>b> nZ:XP @$Z$Jg?mT lkaFO ^ {@6mT e{@lڴGz]EBv\`@@w*3fcǪgk}@@ ècm?#k54 @$`7.!h+@RVV&ڢ0@ v#W_}~D>S%;;MZhQy] i'L {쑥KJNUVRZZ*7o'JEEc8@ J#Gˆ #^K$9O#^ƉH˗/uIvҿ3gL: ,WȓOѧUy'"w]V\)7pCz|`VVV|f 8C*IOo:I<}t=zHnnIII(kٲenC\-ЬYS<WmpZ$޽{;v^ށJRRRqQ@HJ(55U 5C@ VZ$ٳgKUU1+7xu R].ª+{@ hysēZkcL  EVf͒o]9"[nͧ~jj[Jfff şGg1x.-MVIW_mcQ?ۺ:gC\୷6U?h-H!I!,@MrrO~i,GeagpJ@">/ZHΝY4B@!<)S8f" {y'OIIIVV$Ti?~P@hL@ h\XX(yyy= ^xqfE  E=8<@ hq:Q^j\zN3ڏT`2ٷ|8lTjX QɄ  J*VUU]㩧3>@@p߾}#[R  ` zڵpuUuEx @A Uǎi׮v%@+}WAlR~ay%55պ"zȑSꮄ  @Xо`;w 6ȑ#GqG@h@=#=z5 en׿[U &`uՋ/h^d\~德  :p!ku_~~w.;v찒C=X @|A gjAgffc D'SmIL  8[E=XZ~k+  aѣG[o>}4@@ӐΚ@!Q  \iH%%%w^9묳$55#͢@-}OCR`[䥗^ÇeĈ<!$H 9`5md0HaȬY4A@a/w{ԩS'կ~%{5 @ Mb5k֜ >++yA@VУGk/?XԽ@ nٲӟTjkkeСi&իWkcI@O쳭=`u; V p-dɒ%ӐrrrJyꩧb ֆ8X¼]hTWF\ "={ m۶AxYW?9ArrQ?#]u/ @xCxE57> J/~һwo{_yc[ Jh@nYߧk`Q ygW^k| gϖǏ{ͅx@@P....Ȫ4//믿k#X9 ^JҬY3CFFTTT@/tXT7on]\VV&qjJII5J 4\ dܹ kTfMj7x@@A pR{L  82! @|.Šou@ @H6S% $`@l ۀN @Al:U" @f@@8lhU"Z >|L:qjkR ' rs#Ojd(E'@΋ ?MFQII"W\qnDe)O@ @g3$?O^"[֓!  x߾}R]]QB@iZ$|/,-[СC%''Gڵk'Ǐ*^@"oڴI˭Μ9Sv*v풵kʎ;DcB@MZ$@w}WM&ҹsgydժUEx Ijowү_?9pvƍһwo{^  -nC3f裏JII… ={NVXkb@@/E4i5KiizȐ!rJ֭ [H~lҚG3! F-WVVɓ[RRR Zj%ݻwѝ@<. dϞ=tRԩCo޼Y&N(2n8w#I@=˗KaaY{̑ӥ2gYx̉@bXj^rp A]d jƼy^ l۶M:v3f" h-eRPP fݎTTTdlٲ\n6Q?:3! h-hcn:kIu>XuH @7 h|cРAA Ge4 f 8Y@qѢEW_ /@z}wy 2F;^#)S9kEO=Z)CD?@fwy m.WWWKYYdddB .vgzhr˅פI90PzDe)@CHj$, XcA5mH=v؆r %B:t=>Z$`Fg% `$8S  'h}#aвf$P3@8tM "3Va H 8HXn'6@ hqػD UW{@l O ^ {@VT UW{@l O ^>`vq#@tiiF`eeMD(@H>h]cJIӦIѺ7o*:eFTB$J(iA;TXx|1Y'+AۡN  {~@ԉ y7@ ۡN  {~@O݆4`ٹsԉ1(+;.ǟ/>˫͵-|O%m۶If&7۶Q11>"+VK}WF[nm6#@rXύl3mT eO{]<* 5滱(#:RH6S%zgK.(:dRb2.i|@$(0a=UnVAc@"=༼<ٳgW8p@UU'U~:q߶M/p=yU~'8 t9Nk>j=͛'/U( (*V x^ken P'O믿 O%JINTȶlTT@4IIMȑ*1$~?lLjjjb2 4RH@G@!$   7@hH !N,q:"?yIK3NƬ6@O)@ 8@ OJD@b/@)kD@$Q@ co@8 D@@ $؛F@N*@>)@#aޔ5"RP/۷@ :pt^F61ch,II|i3OZ @|c;o 9+RpHf" _p|}Y; !H!Y @|He  da&  ח# R WHRScDTWIIED( ח#w$\j4mX cɪC`߾#V?>DҚGԄ6mR%7mDe) Ǖ"pn#~JBhǠR 4J(>F@anK!7 YK>*[[X1O?[֌@~eҤeQ-۬Y͢Z ` ^jG Hƚכ4P3Uii>bh*@ִchwt9URS٫@n",0!h)@ֲ[h 8&>dF|UoL&M;m{4"]2ȈKD |~QV{I7/3SN.oxeeL6M,X blR:vhގ1IƎ{H(MD̄H&L={ҥKSNҪU+)--͛7ĉBƍk3# x-.Z|J^^nZmҿ3g,^.ǫ/UTW׺+xAhܽ{wYrp AA-YD3fX)=<[W-6S+_ӧѣ|Fi9OHQQ-nXv _.ݵĶvWifÃ#)n͌,@Z$޽{eݺuc|U}hFw̟qTUw!%Q-Ca@ P@* x )xou>Wh舫N,@PZ$`nC 5kԩy_ċ>\!gF.謈  X-0!5ݽk+?8?V}#G2]qY ""ېvc iԩ|hTUq+sؼylvon׬@OqYmۖҫu> O3eȐQ<zME'EmHj$?!>3i߾}꛹u>9[_Y>\+Ήx1/qy " hcuҵ^+Æ ih")//Y}3;v̔sG f -N/Ǽ_u!oX!\"6$u% 5{kjjB}Tf͚m "  X5wRlb}@pcAׇϝ;"| '7eʔp1@ h~>tcAi8 hHX'O61MLGe@p Q E{j$B˓֭[[O?  k1U   7V(%Kum~`#d#330kxG s#0V\i~醹?w.P񖗗[?氌V(o8|a[hXlS;0&Ol7'4tb|G05>SҸ 9P[sQs1.\hmZNfggEEEVq=XݸMI0P5lbm>}1j(Gc###0>u-Hxa 3NzB6F60}X|co۶bްaQRR?7nV{'67onũP?0 e7m߾HOOu&M2nF,nܦ1>ޱcl^qoG}sN#99P_ d{w 7O8!2n86mbeͽbvډ_%\"CSB1OxW hiϞ=C&x k`~3ʼyBk N[J Ynݦ[j%dnئ5 /=Cӟ$w ZOcjo;Suĉ< )9Q1!YIiݺurꩧZ{n?3g9uΝ^״iSxE+ucV{NW=nP]abꪫDV[VVf!%,un=n?n7+<"u2c ?u]T[P!^xEJ vC /Xwwr݀޼H T"صko ,sZߞ^SsL֕NRԏ:̞bUqbߤUW:yRtV_4Գ}WxU bٸqu8+Ͳ=my ?>}X_,Tq6(e* I8CIII߱}O՗mGl8A~u!yHx7]ZW˞ޘ| uh u<`1ŠB]dނdg?CE\ue*?0I s0lü|#x Λ jiuEE0@[ Hڍ۴_mn5_ uo݋ 7WA[j?uJBݻw7ðFnnu+RRΛ3{lü0n5/ V6uں*yX%[_+fuK//ni0&X* s_[SomZ]X_͋ O> ٭۴-ǼW0m7~X_Unn/F'lI>'+++|~6uqZݙX?A:x:SCҁTs˹½v6bUnZZZPnܦfA;ر7 8y @ :AT @ 8P $H hA@ Pk@$@N4  (@5   'j@ j@ M5  5x @H @HF@ A$AS  $@ ^# p@@p@H 8AT @ 8P $H hA ^F4I&ҪU+}INO?W(dSe1L ''G^yK-۵kdeeIfx l*/۷o7ʍ7(wymV bͿKE%;{=ٳiFF)  86mT򭨨~,X :tO>D+~X~my[6L>)**t9s0*Ԇn^Er[ %%EjjjoWwzQ\\,' 4\p;DqM6=i+ ˗˪ 8 {^ @8xCր.rdV\juVmm$`~4Pg̘!?C?/=k A@kֺ{h nYԌ{H["CXswMCp ؽ}Kd  5 ^{@4 k94 @$`-!h,@ָsh {H["CXq4@ ۷D XΡi  o @@cƝC@+@vo $`;!W޾%2@?ïI;IENDB`mets/inst/doc/0000755000176200001440000000000013623061747012755 5ustar liggesusersmets/inst/doc/binomial-twin.ltx0000644000176200001440000010207413623061405016252 0ustar liggesusers%\VignetteIndexEntry{Analysis of bivariate binomial data: Twin analysis} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Analysis of bivariate binomial data: Twin analysis} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Analysis of bivariate binomial data: Twin analysis}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Overview} \label{sec:orgc699b56} When looking at bivariate binomial data with the aim of learning about the dependence that is present, possibly after correcting for some covariates many models are available. \begin{itemize} \item Random-effects models logistic regression covered elsewhere (glmer in lme4). \end{itemize} in the mets package you can fit the \begin{itemize} \item Pairwise odds ratio model \item Bivariate Probit model \begin{itemize} \item With random effects \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \item Additive gamma random effects model \begin{itemize} \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \end{itemize} Typically it can be hard or impossible to specify random effects models with special structure among the parameters of the random effects. This is possible in our models. To be concrete about the model structure assume that we have paired binomial data \(Y_1, Y_2, X_1, X_2\) where the responses are \(Y_1, Y_2\) and we have covariates \(X_1, X_2\). We start by giving a brief description of these different models. First we for bivariate data one can specify the marginal probability using logistic regression models \[ logit(P(Y_i=1|X_i)) = \alpha_i + X_i^T \beta i=1,2. \] These model can be estimated under working independence \cite{zeger-liang-86}. A typical twin analysis will typically consist of looking at both \begin{itemize} \item Pairwise odds ratio model \item Bivariate Probit model \end{itemize} The additive gamma can be used for the same as the bivariate probit model but is more restrictive in terms of dependence structure, but is nevertheless still valuable to have also as a check of results of the bivariate probit model. \subsection*{Biprobit with random effects} \label{sec:org86402a4} For these model we assume that given random effects \(Z\) and a covariate vector \(V_{12}\) we have independent logistic regression models \[ probit(P(Y_i=1|X_i, Z)) = \alpha_i + X_i^T \beta + V_{12}^T Z i=1,2. \] where \(Z\) is a bivariate normal distribution with some covariance \(\Sigma\). The general covariance structure \(\Sigma\) makes the model very flexible. We note that \begin{itemize} \item Paramters \(\beta\) are subject specific \item The \(\Sigma\) will reflect dependence \end{itemize} The more standard link function \(logit\) rather than the \(probit\) link is often used and implemented in for example \cite{mm}. The advantage is that one now gets an odds-ratio interpretation of the subject specific effects, but one then needs numerical integration to fit the model. \#We note that \subsection*{Pairwise odds ratio model} \label{sec:orgf29d361} Now the pairwise odds ratio model the specifies that given \(X_1, X_2\) the marginal models are \[ logit(P(Y_i=1|X_i)) = \alpha_i + X_i^T \beta i=1,2 \] The primary object of interest are the odds ratio between \(Y_{1}\) and \(Y_{2}\) \[ \gamma_{12} = \frac{ P( Y_{ki} =1 , Y_{kj} =1) P( Y_{ki} =0 , Y_{kj} =0) }{ P( Y_{ki} =1 , Y_{kj} =0) P( Y_{ki} =0 , Y_{kj} =1) } \] given \(X_{ki}\), \(X_{kj}\), and \(Z_{kji}\). We model the odds ratio with the regression \[ \gamma_{12} = \exp( Z_{12}^T \lambda) \] Where \(Z_{12}\) are some covarites that may influence the odds-ratio between between \(Y_{1}\) and \(Y_{2}\) and contains the marginal covariates, \cite{carey-1993,dale1986global,palmgren1989,molenberghs1994marginal}. This odds-ratio is given covariates as well as marginal covariates. The odds-ratio and marginals specify the joint bivariate distribution via the so-called Placckett-distribution. One way of fitting this model is the ALR algoritm, the alternating logistic regression ahd this has been described in several papers \cite{kuk2004permutation,kuk2007hybrid,qaqish2012orthogonalized}. We here simply estimate the parameters in a two stage-procedure \begin{itemize} \item Estimating the marginal parameters via GEE \item Using marginal estimates, estimate dependence parameters \end{itemize} This gives efficient estimates of the dependence parameters because of orthogonality, but some efficiency may be gained for the marginal parameters by using the full likelihood or iterative fitting such as for the ALR. The pairwise odds-ratio model is very useful, but one do not have a random effects model. \subsection*{Additive gamma model} \label{sec:orgdb54e35} Again we operate under marginal logistic regression models are \[ logit(P(Y_i=1|X_i)) = \alpha_i + X_i^T \beta i=1,2 \] First with just one random effect \(Z\) we assume that conditional on \(Z\) the responses are independent and follow the model \[ logit(P(Y_i=1|X_i,Z)) = exp( -Z \cdot \Psi^{-1}(\lambda_{\bullet},\lambda_{\bullet},P(Y_i=1|X_i)) ) \] where \(\Psi\) is the laplace transform of \(Z\) where we assume that \(Z\) is gamma distributed with variance \(\lambda_{\bullet}^{-1}\) and mean 1. In general \(\Psi(\lambda_1,\lambda_2)\) is the laplace transform of a Gamma distributed random effect with \(Z\) with mean \(\lambda_1/\lambda_2\) and variance \(\lambda_1/\lambda_2^2\). We fit this model by \begin{itemize} \item Estimating the marginal parameters via GEE \item Using marginal estimates, estimate dependence parameters \end{itemize} To deal with multiple random effects we consider random effects \(Z_i i=1,...,d\) such that \(Z_i\) is gamma distributed with mean \(\lambda_j/\lambda_{\bullet}\) and variance \(\lambda_j/\lambda_{\bullet}^2\), where we define the scalar \(\lambda_{\bullet}\) below. Now given a cluster-specific design vector \(V_{12}\) we assume that \[ V_{12}^T Z \] is gamma distributed with mean 1 and variance \(\lambda_{\bullet}^{-1}\) such that critically the random effect variance is the same for all clusters. That is \[ \lambda_{\bullet} = V_{12}^T (\lambda_1,...,\lambda_d)^T \] We return to some specific models below, and show how to fit the ACE and AE model using this set-up. One last option in the model-specification is to specify how the parameters \(\lambda_1,...,\lambda_d\) are related. We thus can specify a matrix \(M\) of dimension \(p \times d\) such that \[ (\lambda_1,...,\lambda_d)^T = M \theta \] where \(\theta\) is d-dimensional. If \(M\) is diagonal we have no restrictions on parameters. This parametrization is obtained with the var.par=0 option that thus estimates \(\theta\). The DEFAULT parametrization instead estimates the variances of the random effecs (var.par=1) via the parameters \(\nu\) \[ M \nu = ( \lambda_1/\lambda_{\bullet}^2, ...,\lambda_d/\lambda_{\bullet}^2)^T \] The basic modelling assumption is now that given random effects \(Z=(Z_1,...,Z_d)\) we have independent probabilites \[ logit(P(Y_i=1|X_i,Z)) = exp( -V_{12,i}^T Z \cdot \Psi^{-1}(\lambda_{\bullet},\lambda_{\bullet},P(Y_i=1|X_i)) ) i=1,2 \] We fit this model by \begin{itemize} \item Estimating the marginal parameters via GEE \item Using marginal estimates, estimate dependence parameters \end{itemize} Even though the model not formaly in this formulation allows negative correlation in practice the paramters can be negative and this reflects negative correlation. An advanatage is that no numerical integration is needed. \section*{The twin-stutter data} \label{sec:orgf3a7afd} We consider the twin-stutter where for pairs of twins that are either dizygotic or monozygotic we have recorded whether the twins are stuttering \cite{twinstut-ref} We here consider MZ and same sex DZ twins. Looking at the data \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) data(twinstut) twinstut$binstut <- 1*(twinstut$stutter=="yes") twinsall <- twinstut twinstut <- subset(twinstut,zyg%in%c("mz","dz")) head(twinstut) \end{lstlisting} \begin{verbatim} Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.5.1 mets version 1.2.1.2 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined Warning message: failed to assign RegisteredNativeSymbol for cor to cor since cor is already defined in the ‘mets’ namespace tvparnr zyg stutter sex age nr binstut 1 2001005 mz no female 71 1 0 2 2001005 mz no female 71 2 0 3 2001006 dz no female 71 1 0 8 2001012 mz no female 71 1 0 9 2001012 mz no female 71 2 0 11 2001015 dz no male 71 1 0 \end{verbatim} \section*{Pairwise odds ratio model} \label{sec:orgbf74e81} We start by fitting an overall dependence OR for both MZ and DZ even though the dependence is expected to be different across zygosity. The first step is to fit the marginal model adjusting for marginal covariates. We here note that there is a rather strong gender effect in the risk of stuttering. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} margbin <- glm(binstut~factor(sex)+age,data=twinstut,family=binomial()) summary(margbin) \end{lstlisting} \begin{verbatim} Call: glm(formula = binstut ~ factor(sex) + age, family = binomial(), data = twinstut) Deviance Residuals: Min 1Q Median 3Q Max -0.4419 -0.4078 -0.2842 -0.2672 2.6395 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) -3.027625 0.104012 -29.108 < 2e-16 *** factor(sex)male 0.869826 0.062197 13.985 < 2e-16 *** age -0.005983 0.002172 -2.754 0.00588 ** --- Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 9328.6 on 21287 degrees of freedom Residual deviance: 9117.0 on 21285 degrees of freedom AIC: 9123 Number of Fisher Scoring iterations: 6 \end{verbatim} Now estimating the OR parameter. We see a strong dependence with an OR at around 8 that is clearly significant. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} bina <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,detail=0) summary(bina) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se dependence1 2.085347 0.1274536 $or Estimate Std.Err 2.5% 97.5% P-value dependence1 8.05 1.03 6.04 10.1 4.3e-15 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} Now, and more interestingly, we consider an OR that depends on zygosity and note that MZ have a much larger OR than DZ twins. This type of trait is somewhat complicated to interpret, but clearly, one option is that that there is a genetic effect, alternatively there might be a stronger environmental effect for MZ twins. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # design for OR dependence theta.des <- model.matrix( ~-1+factor(zyg),data=twinstut) bin <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,theta.des=theta.des) summary(bin) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(zyg)dz 0.5221651 0.2401355 factor(zyg)mz 3.4853933 0.1866076 $or Estimate Std.Err 2.5% 97.5% P-value factor(zyg)dz 1.69 0.405 0.892 2.48 3.12e-05 factor(zyg)mz 32.64 6.090 20.699 44.57 8.38e-08 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} We now consider further regression modelling of the OR structure by considering possible interactions between sex and zygozsity. We see that MZ has a much higher dependence and that males have a much lower dependence. We tested for interaction in this model and these were not significant. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} twinstut$cage <- scale(twinstut$age) theta.des <- model.matrix( ~-1+factor(zyg)+factor(sex),data=twinstut) bina <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,theta.des=theta.des) summary(bina) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(zyg)dz 0.8098841 0.3138423 factor(zyg)mz 3.7318076 0.2632250 factor(sex)male -0.4075409 0.3055349 $or Estimate Std.Err 2.5% 97.5% P-value factor(zyg)dz 2.248 0.705 0.865 3.63 0.001441 factor(zyg)mz 41.755 10.991 20.213 63.30 0.000145 factor(sex)male 0.665 0.203 0.267 1.06 0.001064 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \subsection*{Alternative syntax} \label{sec:org3f01206} We now demonstrate how the models can fitted jointly and with anohter syntax, that ofcourse just fits the marginal model and subsequently fits the pairwise OR model. First noticing as before that MZ twins have a much higher dependence. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # refers to zygosity of first subject in eash pair : zyg1 # could also use zyg2 (since zyg2=zyg1 within twinpair's) out <- easy.binomial.twostage(stutter~factor(sex)+age,data=twinstut, response="binstut",id="tvparnr",var.link=1, theta.formula=~-1+factor(zyg1)) summary(out) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(zyg1)dz 0.5221651 0.2401355 factor(zyg1)mz 3.4853933 0.1866076 $or Estimate Std.Err 2.5% 97.5% P-value factor(zyg1)dz 1.69 0.405 0.892 2.48 3.12e-05 factor(zyg1)mz 32.64 6.090 20.699 44.57 8.38e-08 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} Now considering all data and estimating separate effects for the OR for opposite sex DZ twins and same sex twins. We here find that os twins are not markedly different from the same sex DZ twins. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # refers to zygosity of first subject in eash pair : zyg1 # could also use zyg2 (since zyg2=zyg1 within twinpair's)) desfs<-function(x,num1="zyg1",num2="zyg2") c(x[num1]=="dz",x[num1]=="mz",x[num1]=="os")*1 margbinall <- glm(binstut~factor(sex)+age,data=twinsall,family=binomial()) out3 <- easy.binomial.twostage(binstut~factor(sex)+age, data=twinsall,response="binstut",id="tvparnr",var.link=1, theta.formula=desfs,desnames=c("dz","mz","os")) summary(out3) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se dz 0.5278527 0.2396796 mz 3.4850037 0.1864190 os 0.7802940 0.2894394 $or Estimate Std.Err 2.5% 97.5% P-value dz 1.70 0.406 0.899 2.49 3.02e-05 mz 32.62 6.081 20.703 44.54 8.13e-08 os 2.18 0.632 0.944 3.42 5.50e-04 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \section*{Bivariate Probit model} \label{sec:org1b646d8} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) data(twinstut) twinstut <- subset(twinstut,zyg%in%c("mz","dz")) twinstut$binstut <- 1*(twinstut$stutter=="yes") head(twinstut) \end{lstlisting} \begin{verbatim} tvparnr zyg stutter sex age nr binstut 1 2001005 mz no female 71 1 0 2 2001005 mz no female 71 2 0 3 2001006 dz no female 71 1 0 8 2001012 mz no female 71 1 0 9 2001012 mz no female 71 2 0 11 2001015 dz no male 71 1 0 \end{verbatim} First testing for same dependence in MZ and DZ that we recommend doing by comparing the correlations of MZ and DZ twins. Apart from regression correction in the mean this is an un-structured model, and the useful concordance and casewise concordance estimates can be reported from this analysis. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} b1 <- bptwin(binstut~sex,data=twinstut,id="tvparnr",zyg="zyg",DZ="dz",type="un") summary(b1) \end{lstlisting} \begin{verbatim} Estimate Std.Err Z p-value (Intercept) -1.794823 0.023289 -77.066728 0.0000 sexmale 0.401432 0.030179 13.301813 0.0000 atanh(rho) MZ 1.096916 0.073574 14.909087 0.0000 atanh(rho) DZ 0.132458 0.062516 2.118800 0.0341 Total MZ/DZ Complete pairs MZ/DZ 8777/12511 3255/4058 Estimate 2.5% 97.5% Tetrachoric correlation MZ 0.79939 0.74101 0.84577 Tetrachoric correlation DZ 0.13169 0.00993 0.24960 MZ: Estimate 2.5% 97.5% Concordance 0.01698 0.01411 0.02042 Casewise Concordance 0.46730 0.40383 0.53185 Marginal 0.03634 0.03287 0.04016 Rel.Recur.Risk 12.85882 10.87510 14.84253 log(OR) 3.75632 3.37975 4.13289 DZ: Estimate 2.5% 97.5% Concordance 0.00235 0.00140 0.00393 Casewise Concordance 0.06456 0.03937 0.10413 Marginal 0.03634 0.03287 0.04016 Rel.Recur.Risk 1.77662 0.92746 2.62577 log(OR) 0.63527 0.09013 1.18040 Estimate 2.5% 97.5% Broad-sense heritability 1 NaN NaN \end{verbatim} \subsection*{Polygenic modelling} \label{sec:org8788a7d} We now turn attention to specific polygenic modelling where special random effects are used to specify ACE, AE, ADE models and so forth. This is very easy with the bptwin function. The key parts of the output are the sizes of the genetic component A and the environmental component, and we can compare with the results of the unstructed model above. Also formally we can test if this submodel is acceptable by a likelihood ratio test. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} b1 <- bptwin(binstut~sex,data=twinstut,id="tvparnr",zyg="zyg",DZ="dz",type="ace") summary(b1) \end{lstlisting} \begin{verbatim} Estimate Std.Err Z p-value (Intercept) -3.70371 0.24449 -15.14855 0 sexmale 0.83310 0.08255 10.09201 0 log(var(A)) 1.18278 0.17179 6.88512 0 log(var(C)) -29.99519 NA NA NA Total MZ/DZ Complete pairs MZ/DZ 8777/12511 3255/4058 Estimate 2.5% 97.5% A 0.76545 0.70500 0.82590 C 0.00000 0.00000 0.00000 E 0.23455 0.17410 0.29500 MZ Tetrachoric Cor 0.76545 0.69793 0.81948 DZ Tetrachoric Cor 0.38272 0.35210 0.41253 MZ: Estimate 2.5% 97.5% Concordance 0.01560 0.01273 0.01912 Casewise Concordance 0.42830 0.36248 0.49677 Marginal 0.03643 0.03294 0.04027 Rel.Recur.Risk 11.75741 9.77237 13.74246 log(OR) 3.52382 3.13466 3.91298 DZ: Estimate 2.5% 97.5% Concordance 0.00558 0.00465 0.00670 Casewise Concordance 0.15327 0.13749 0.17050 Marginal 0.03643 0.03294 0.04027 Rel.Recur.Risk 4.20744 3.78588 4.62900 log(OR) 1.69996 1.57262 1.82730 Estimate 2.5% 97.5% Broad-sense heritability 0.76545 0.70500 0.82590 \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} b0 <- bptwin(binstut~sex,data=twinstut,id="tvparnr",zyg="zyg",DZ="dz",type="ae") summary(b0) \end{lstlisting} \begin{verbatim} Estimate Std.Err Z p-value (Intercept) -3.70371 0.24449 -15.14855 0 sexmale 0.83310 0.08255 10.09201 0 log(var(A)) 1.18278 0.17179 6.88512 0 Total MZ/DZ Complete pairs MZ/DZ 8777/12511 3255/4058 Estimate 2.5% 97.5% A 0.76545 0.70500 0.82590 E 0.23455 0.17410 0.29500 MZ Tetrachoric Cor 0.76545 0.69793 0.81948 DZ Tetrachoric Cor 0.38272 0.35210 0.41253 MZ: Estimate 2.5% 97.5% Concordance 0.01560 0.01273 0.01912 Casewise Concordance 0.42830 0.36248 0.49677 Marginal 0.03643 0.03294 0.04027 Rel.Recur.Risk 11.75741 9.77237 13.74246 log(OR) 3.52382 3.13466 3.91298 DZ: Estimate 2.5% 97.5% Concordance 0.00558 0.00465 0.00670 Casewise Concordance 0.15327 0.13749 0.17050 Marginal 0.03643 0.03294 0.04027 Rel.Recur.Risk 4.20744 3.78588 4.62900 log(OR) 1.69996 1.57262 1.82730 Estimate 2.5% 97.5% Broad-sense heritability 0.76545 0.70500 0.82590 \end{verbatim} \section*{Additive gamma random effects} \label{sec:orgff761d3} Fitting first a model with different size random effects for MZ and DZ. We note that as before in the OR and biprobit model the dependence is much stronger for MZ twins. We also test if these are the same by parametrizing the OR model with an intercept. This clearly shows a significant difference. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} theta.des <- model.matrix( ~-1+factor(zyg),data=twinstut) margbin <- glm(binstut~sex,data=twinstut,family=binomial()) bintwin <- binomial.twostage(margbin,data=twinstut,model="gamma", clusters=twinstut$tvparnr,detail=0,theta=c(0.1)/1,var.link=1, theta.des=theta.des) summary(bintwin) # test for same dependence in MZ and DZ theta.des <- model.matrix( ~factor(zyg),data=twinstut) margbin <- glm(binstut~sex,data=twinstut,family=binomial()) bintwin <- binomial.twostage(margbin,data=twinstut,model="gamma", clusters=twinstut$tvparnr,detail=0,theta=c(0.1)/1,var.link=1, theta.des=theta.des) summary(bintwin) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates theta se factor(zyg)dz -2.61194495 0.4854454 factor(zyg)mz -0.01817181 0.1030735 $vargam Estimate Std.Err 2.5% 97.5% P-value factor(zyg)dz 0.0734 0.0356 0.00356 0.143 3.94e-02 factor(zyg)mz 0.9820 0.1012 0.78361 1.180 2.96e-22 $type [1] "gamma" attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates theta se (Intercept) -2.611945 0.4854454 factor(zyg)mz 2.593773 0.4962675 $vargam Estimate Std.Err 2.5% 97.5% P-value (Intercept) 0.0734 0.0356 0.00356 0.143 0.0394 factor(zyg)mz 13.3802 6.6401 0.36573 26.395 0.0439 $type [1] "gamma" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \subsection*{Polygenic modelling} \label{sec:orgc97abc0} First setting up the random effects design for the random effects and the the relationship between variance parameters. We see that the genetic random effect has size one for MZ and 0.5 for DZ subjects, that have shared and non-shared genetic components with variance 0.5 such that the total genetic variance is the same for all subjects. The shared environmental effect is the samme for all. Thus two parameters with these bands. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} out <- twin.polygen.design(twinstut,id="tvparnr",zygname="zyg",zyg="dz",type="ace") head(cbind(out$des.rv,twinstut$tvparnr),10) out$pardes \end{lstlisting} \begin{verbatim} MZ DZ DZns1 DZns2 env 1 1 0 0 0 1 2001005 2 1 0 0 0 1 2001005 3 0 1 1 0 1 2001006 8 1 0 0 0 1 2001012 9 1 0 0 0 1 2001012 11 0 1 1 0 1 2001015 12 0 1 1 0 1 2001016 13 0 1 0 1 1 2001016 15 0 1 1 0 1 2001020 18 0 1 1 0 1 2001022 [,1] [,2] [1,] 1.0 0 [2,] 0.5 0 [3,] 0.5 0 [4,] 0.5 0 [5,] 0.0 1 \end{verbatim} Now, fitting the ACE model, we see that the variance of the genetic, component, is 1.5 and the environmental variance is -0.5. Thus suggesting that the ACE model does not fit the data. When the random design is given we automatically use the gamma fralty model. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} margbin <- glm(binstut~sex,data=twinstut,family=binomial()) bintwin1 <- binomial.twostage(margbin,data=twinstut, clusters=twinstut$tvparnr,detail=0,theta=c(0.1)/1,var.link=0, random.design=out$des.rv,theta.des=out$pardes) summary(bintwin1) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 1.5261839 0.2475041 dependence2 -0.5447955 0.1942159 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1.555 0.187 1.189 1.922 9.11e-17 dependence2 -0.555 0.187 -0.922 -0.189 2.99e-03 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.981 0.102 0.781 1.18 8.29e-22 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} For this model we estimate the concordance and casewise concordance as well as the marginal rates of stuttering for females. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} concordanceTwinACE(bintwin1,type="ace") \end{lstlisting} \begin{verbatim} $MZ Estimate Std.Err 2.5% 97.5% P-value concordance 0.0182 0.00147 0.0153 0.0211 2.61e-35 casewise concordance 0.5033 0.03256 0.4395 0.5672 6.49e-54 marginal 0.0362 0.00188 0.0325 0.0399 7.15e-83 $DZ Estimate Std.Err 2.5% 97.5% P-value concordance 0.00235 0.000589 0.0012 0.00351 6.45e-05 casewise concordance 0.06501 0.015836 0.0340 0.09604 4.04e-05 marginal 0.03620 0.001877 0.0325 0.03988 7.15e-83 \end{verbatim} The E component was not consistent with the fit of the data and we now consider instead the AE model. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} out <- twin.polygen.design(twinstut,id="tvparnr",zygname="zyg",zyg="dz",type="ae") bintwin <- binomial.twostage(margbin,data=twinstut, clusters=twinstut$tvparnr,detail=0,theta=c(0.1)/1,var.link=0, random.design=out$des.rv,theta.des=out$pardes) summary(bintwin) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.9094847 0.09536268 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.909 0.0954 0.723 1.1 1.47e-21 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} Again, the concordance can be computed: \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} concordanceTwinACE(bintwin,type="ae") \end{lstlisting} \begin{verbatim} $MZ Estimate Std.Err 2.5% 97.5% P-value concordance 0.0174 0.00143 0.0146 0.0202 5.00e-34 casewise concordance 0.4795 0.03272 0.4154 0.5437 1.20e-48 marginal 0.0362 0.00188 0.0325 0.0399 7.15e-83 $DZ Estimate Std.Err 2.5% 97.5% P-value concordance 0.00477 0.000393 0.0040 0.00554 5.94e-34 casewise concordance 0.13175 0.005417 0.1211 0.14237 1.14e-130 marginal 0.03620 0.001877 0.0325 0.03988 7.15e-83 \end{verbatim} \end{document}mets/inst/doc/twostage-survival.ltx0000644000176200001440000013131313623061405017205 0ustar liggesusers%\VignetteIndexEntry{Analysis of multivariate survival data} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Analysis of multivariate survival data} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Analysis of multivariate survival data}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Overview} \label{sec:org3befec5} When looking at multivariate survival data with the aim of learning about the dependence that is present, possibly after correcting for some covariates different approaches are available in the mets package \begin{itemize} \item Binary models and adjust for censoring with inverse probabilty of censoring weighting \begin{itemize} \item biprobit model \end{itemize} \item Bivariate surival models of Clayton-Oakes type \begin{itemize} \item With regression structure on dependence parameter \item With additive gamma distributed random effects \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \item Plackett OR model model \begin{itemize} \item With regression structure on OR dependence parameter \end{itemize} \item Cluster stratified Cox \end{itemize} Typically it can be hard or impossible to specify random effects models with special structure among the parameters of the random effects. This is possible for our specification of the random effects models. To be concrete about the model structure assume that we have paired binomial data \(T_1, \delta_1, T_2, \delta_2, X_1, X_2\) where the censored survival responses are \(T_1, \delta_1, T_2, \delta_2\) and we have covariates \(X_1, X_2\). The basic models assumes that each subject has a marginal on Cox-form \[ \lambda_{s(k,i)}(t) \exp( X_{ki}^T \beta) \] where \(s(k,i)\) is a strata variable. \subsection*{Gamma distributed frailties} \label{sec:org3bb9661} The focus of this vignette is describe how to work on bivariate survival data using the addtive gamma-random effects models. We present two different ways of specifying different dependence structures. \begin{itemize} \item Univariate models with a single random effect for each cluster and with a regression design on the variance. \item Multivariate models with multiple random effects for each cluster. \end{itemize} The univariate models are then given a given cluster random effects \(Z_k\) with parameter \(\theta\) the joint survival function is given by the Clayton copula and on the form \[ \psi(\theta, \psi^{-1}(\theta,S_1(t,X_{k1}) ) + \psi^{-1}(\theta, S_1(t,X_{k1}) ) \] where \(\psi\) is the Laplace transform of a gamma distributed random variable with mean 1 and variance \(\theta\). We then model the variance within clusters by a cluster specific regression design such that \[ \theta = z_j^T \alpha \] where \(z\) is the regression design (specified by theta.des in the software). This model can be fitted using a pairwise likelihood or the pseudo-likelihood using either \begin{itemize} \item twostage \item twostageMLE \end{itemize} To make the twostage approach possible we need a model with specific structure for the marginals. Therefore given the random effect of the clusters the survival distributions within a cluster are independent and on the form \[ P(T_j > t| X_j,Z) = exp( -Z \cdot \Psi^{-1}(\nu^{-1},S(t|X_j)) ) \] with \(\Psi\) the laplace of the gamma distribution with mean 1 and variance \(1/\nu\). \subsection*{Additive Gamma frailties} \label{sec:orge7e6b98} For the multivariate models we are given a multivarite random effect each cluster \(Z=(Z_1,...,Z_d)\) with d random effects. The total random effect for each subject \(j\) in a cluster is then specified using a regression design on these random effects, with a regression vector \(V_j\) such that the total random effect is \(V_j^T (Z_1,...,Z_d)\). The elements of \(V_J\) are 1/0. The random effects \((Z_1,...,Z_d)\) has associated parameters \((\lambda_1,...,\lambda_d)\) and \(Z_j\) is Gamma distributed with \begin{itemize} \item mean \(\lambda_j/V_1^T \lambda\) \item variance \(\lambda_j/(V_1^T \lambda)^2\) \end{itemize} The key assumption to make the two-stage fitting possible is that \[ \nu =V_j^T \lambda \] is constant within clusters. The consequence of this is that the total random effect for each subject within a cluster, \(V_j^T (Z_1,...,Z_d)\) , is gamma distributed with variance \(1/\nu\). The DEFAULT parametrization (var.par=1) uses the variances of the random effecs \[ \theta_j = \lambda_j/\nu^2 \] For alternative parametrizations one can specify that the parameters are \(\theta_j=\lambda_j\) with the argument var.par=0. Finally the parameters \((\theta_1,...,\theta_d)\) are related to the parameters of the model by a regression construction \(M\) (d x k), that links the \(d\) \(\theta\) parameters with the \(k\) underlying \(\alpha\) parameters \[ \theta = M \alpha. \] The default is a diagonal matrix for \(M\). This can be used to make structural assumptions about the variances of the random-effects as is needed for the ACE model for example. In the software \(M\) is called theta.des Assume that the marginal survival distribution for subject \(i\) within cluster \(k\) is given by \(S_{X_{k,i}}(t)\) given covariates \(X_{k,i}\). Now given the random effects of the cluster \(Z_k\) and the covariates\(X_{k,i}\) \(i=1,\dots,n_k\) we assume that subjects within the cluster are independent with survival distributions \begin{align*} \exp(- ( V_{k,i} Z_k) \Psi^{-1} (\nu,S_{X_{k,i}}(t)) ). \end{align*} A consequence of this is that the hazards given the covariates \(X_{k,i}\) and the random effects \(Z_k\) are given by \begin{align} \lambda_{k,i}(t;X_{k,i},Z_{k,i}) = ( V_{k,i} V_k) D_3 \Psi^{-1} (\nu,S_{X_{k,i}}(t)) D_t S_{X_{k,i}}(t) \label{eq-cond-haz} \end{align} where \(D_t\) and \(D_3\) denotes the partial derivatives with respect to \(t\) and the third argument, respectively. Further, we can express the multivariate survival distribution as \begin{align} S(t_1,\dots,t_m) & = \exp( -\sum_{i=1}^m (V_i Z) \Psi^{-1}(\eta_l,\nu_l,S_{X_{k,i}}(t_i)) ) \nonumber \\ & = \prod_{l=1}^p \Psi(\eta_l,\eta , \sum_{i=1}^m Q_{k,i} \Psi^{-1}(\eta,\eta,S_{X_{k,i}}(t_i))). \label{eq-multivariate-surv} \end{align} In the case of considering just pairs, we write this function as \(C(S_{k,i}(t),S_{k,j}(t))\). In addition to survival times from this model, we assume that we independent right censoring present \(U_{k,i}\) such that the given \(V_k\) and the covariates\(X_{k,i}\) \(i=1,\dots,n_k\) \((U_{k,1},\dots,U_{k,n_k})\) of \((T_{k,1},\dots,T_{k,n_k})\), and the conditional censoring distribution do not depend on \(V_k\). One consequence of the model strucure is that the Kendall's can be computed for two-subjects \((i,j)\) across two clusters ``1'' and ``2'' as \begin{align} E( \frac{( V_{1i} Z_1- V_{1j}Z_2)( V_{2i}Z_1 - V_{2j}Z_2 )}{( V_{1i}Z_1 + V_{2i}Z_2 ) ( V_{1j}Z_1 + V_{2j}Z_2 )} ) \end{align} under the assumption that that we compare pairs with equivalent marginals, \(S_{X_{1,i}}(t)= S_{X_{2,i}}(t)\) and \(S_{X_{1,j}}(t)= S_{X_{2,j}}(t)\), and that \(S_{X_{1,i}}(\infty)= S_{X_{1,j}}(\infty)=0\). Here we also use that \(\eta\) is the same across clusters. The Kendall's tau would be the same for \eqref{frailty-model} due to the same additive structure for the frailty terms, and the random effects thus have the same interpretation in terms of Kendall's tau. \subsection*{Univariate gamma (clayton-oakes) model twostage models} \label{sec:org138bf8c} We start by fitting simple Clayton-Oakes models for the data, that is with an overall random effect that is Gamma distrubuted with variance \(\theta\). We can fit the model by a pseudo-MLE (twostageMLE) and a pairwise composite likelihood approach (twostage). The pseudo-liklihood and the composite pairwise likelhood gives quite similar results in this case. In addition the log-parametrization is illustrated with the var.link=1 option. In addition it is specified that we want a "clayton.oakes" model. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) data(diabetes) # Marginal Cox model with treat as covariate margph <- phreg(Surv(time,status)~treat+cluster(id),data=diabetes) # Clayton-Oakes, MLE fitco1<-twostageMLE(margph,data=diabetes,theta=1.0) summary(fitco1) # Clayton-Oakes fitco2 <- survival.twostage(margph,data=diabetes,theta=0.0,detail=0, clusters=diabetes$id,var.link=1,model="clayton.oakes") summary(fitco2) fitco3 <- survival.twostage(margph,data=diabetes,theta=1.0,detail=0, clusters=diabetes$id,var.link=0,model="clayton.oakes") summary(fitco3) \end{lstlisting} \begin{verbatim} Loading required package: timereg Loading required package: survival Loading required package: lava mets version 1.2.4 Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 0.9526614 0.3543033 2.68883 0.007170289 0.322645 0.08127892 $type NULL attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates log-Coef. SE z P-val Kendall tau SE dependence1 -0.04849523 0.330665 -0.1466597 0.8834006 0.3226451 0.07226526 $vargam Estimate Std.Err 2.5% 97.5% P-value dependence1 0.9527 0.315 0.3352 1.57 0.002493 $type [1] "clayton.oakes" attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 0.9526619 0.3150119 3.024209 0.002492843 0.3226451 0.07226526 $type [1] "clayton.oakes" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} The marginal models can be either structured Cox model or as here with a baseline for each strata. This gives quite similar results to those before. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # without covariates but marginal model stratified marg <- phreg(Surv(time,status)~+strata(treat)+cluster(id),data=diabetes) fitcoa <- survival.twostage(marg,data=diabetes,theta=1.0,clusters=diabetes$id, model="clayton.oakes") summary(fitcoa) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates log-Coef. SE z P-val Kendall tau SE dependence1 -0.05683996 0.3322322 -0.171085 0.8641569 0.3208241 0.07239207 $vargam Estimate Std.Err 2.5% 97.5% P-value dependence1 0.9447 0.3139 0.3296 1.56 0.002613 $type [1] "clayton.oakes" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \subsection*{Piecewise constant Clayton-Oakes model} \label{sec:orgedb6727} Let the cross-hazard ratio (CHR) be defined as \begin{align} \eta(t_1,t_2) = \frac{ \lambda_1(t_1| T_2=t_2)}{ \lambda_1(t_1| T_2 \ge t_2)} = \frac{ \lambda_2(t_2| T_1=t_1)}{ \lambda_2(t_2| T_1 \ge t_1)} \end{align} where \(\lambda_1\) and \(\lambda_2\) are the conditional hazard functions of \(T_1\) and \(T_2\) given covariates. For the Clayton-Oakes model this ratio is \(\eta(t_1,t_2) = 1+\theta\), and as a consequence we see that if the co-twin is dead at any time we would increase our risk assessment on the hazard scale with the constant \(\eta(t_1,t_2)\). The Clayton-Oakes model also has the nice property that Kendall's tau is linked directly to the dependence parameter \(\theta\) and is \(1/(1+2/\theta)\). A very useful extension of the model the constant cross-hazard ratio (CHR) model is the piecewise constant cross-hazard ratio (CHR) for bivariate survival data \cite{nan2006piecewise}, and this model was extended to competing risks in \cite{shih2010modeling}. In the survival setting we let the CHR \begin{align} \eta(t_1,t_2) & = \sum \eta_{i,j} I(t_1 \in I_i, t_2 \in I_j) \end{align} The model lets the CHR by constant in different part of the plane. This can be thought of also as having a separate Clayton-Oakes model for each of the regions specified in the plane here by the cut-points \(c(0,0.5,2)\) thus defining 9 regions. This provides a constructive goodness of fit test for the whether the Clayton-Oakes model is valid. Indeed if valid the parameter should be the same in all regions. First we generate some data from the Clayton-Oakes model with variance \(0.5\) and 2000 pairs. And fit the related model. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} d <- simClaytonOakes(2000,2,0.5,0,3) margph <- phreg(Surv(time,status)~x+cluster(cluster),data=d) # Clayton-Oakes, MLE fitco1<-twostageMLE(margph,data=d) summary(fitco1) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.01888 0.08970192 22.50654 0 0.5023489 0.01110764 $type NULL attr(,"class") [1] "summary.mets.twostage" \end{verbatim} Now we cut the region at the cut-points \(c(0,0.5,2)\) thus defining 9 regions and fit a separate model for each region. We see that the parameter is indeed rather constant over the 9 regions. A formal test can be constructed. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} udp <- piecewise.twostage(c(0,0.5,2),data=d,score.method="optimize", id="cluster",timevar="time", status="status",model="clayton.oakes",silent=0) summary(udp) \end{lstlisting} \begin{verbatim} Data-set 1 out of 4 Number of joint events: 518 of 2000 Data-set 2 out of 4 Number of joint events: 274 of 1232 Data-set 3 out of 4 Number of joint events: 247 of 1203 Data-set 4 out of 4 Number of joint events: 594 of 953 [1] 1 Dependence parameter for Clayton-Oakes model Score of log-likelihood for parameter estimates (too large?) 0 - 0.5 0.5 - 2 0 - 0.5 0.0019673733 0.001451886 0.5 - 2 0.0007297083 0.003142920 log-coefficient for dependence parameter (SE) 0 - 0.5 0.5 - 2 0 - 0.5 0.687 (0.069) 0.677 (0.093) 0.5 - 2 0.733 (0.100) 0.718 (0.060) Kendall's tau (SE) 0 - 0.5 0.5 - 2 0 - 0.5 0.498 (0.017) 0.496 (0.023) 0.5 - 2 0.51 (0.025) 0.506 (0.015) \end{verbatim} \subsection*{Multivariate gamma twostage models} \label{sec:org1b5ea9b} To illustrate how the multivariate models can be used, we first set up some twin data with ACE structure. That is two shared random effects, one being the genes \(\sigma_g^2\) and one the environmental effect \(\sigma_e^2\). Monozygotic twins share all genes whereas the dizygotic twins only share half the genes. This can be expressed via 5 random effect for each twin pair (for example). We start by setting this up. The pardes matrix tells how the the parameters of the 5 random effects are related, and the matrix her first has one random effect with parameter \(\theta_1\) (here the \(\sigma_g^2\)), then the next 3 random effects have parameters \(0.5 \theta_1\) (here \(0.5 \sigma_g^2\)), and the last random effect that is given by its own parameter \(\theta_2\) (here \(\sigma_e^2\)). \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data <- simClaytonOakes.twin.ace(2000,2,1,0,3) out <- twin.polygen.design(data,id="cluster") pardes <- out$pardes pardes \end{lstlisting} \begin{verbatim} [,1] [,2] [1,] 1.0 0 [2,] 0.5 0 [3,] 0.5 0 [4,] 0.5 0 [5,] 0.0 1 \end{verbatim} The last part of the model structure is to decide how the random effects are shared for the different pairs (MZ and DZ), this is specfied by the random effects design (\(V_1\) and \(V_2\)) for each pair. This is here specified by an overall designmatrix for each subject (since they enter all pairs with the same random effects design). For an MZ pair the two share the full gene random effect and the full environmental random effect. In contrast the DZ pairs share the 2nd random effect with half the gene-variance and have both a non-shared gene-random effect with half the variance, and finally a fully shared environmental random effect. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} des.rv <- out$des.rv # MZ head(des.rv,2) # DZ tail(des.rv,2) \end{lstlisting} \begin{verbatim} MZ DZ DZns1 DZns2 env 1 1 0 0 0 1 2 1 0 0 0 1 MZ DZ DZns1 DZns2 env 3999 0 1 1 0 1 4000 0 1 0 1 1 \end{verbatim} Now we call the twostage function. We see that we essentially recover the true values, and note that the output also compares the sizes of the genetic and environmental random effect. This number is sometimes called the heritability. In addition the total variance for each subject is also computed and is here around \(3\), as we indeed constructed. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} aa <- phreg(Surv(time,status)~x+cluster(cluster),data=data) ts <- twostage(aa,data=data,clusters=data$cluster,detail=0, theta=c(2,1),var.link=0,step=0.5, random.design=des.rv,theta.des=pardes) summary(ts) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.2111163 0.2219525 9.962113 0.000000e+00 0.5250665 0.02503201 dependence2 0.7431872 0.1706430 4.355217 1.329349e-05 0.2709211 0.04535315 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.7484 0.05898 0.6328 0.8640 6.669e-37 dependence2 0.2516 0.05898 0.1360 0.3672 1.995e-05 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 2.954 0.1426 2.675 3.234 2.514e-95 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} The estimates can be transformed into Kendall's tau estimates for MZ and DZ twins. The Kendall's tau in the above output reflects how a gamma distributed random effect in the normal Clayton-Oakes model is related to the Kendall's tau. In this setting the Kendall's of MZ and DZ, however, should reflect both random effects. We do this based on simulations. The Kendall's tau of the MZ is around 0.60, and for DZ around 0.33. Both are quite high and this is due to a large shared environmental effect and large genetic effect. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} kendall.ClaytonOakes.twin.ace(ts$theta[1],ts$theta[2],K=10000) \end{lstlisting} \begin{verbatim} $mz.kendall [1] 0.5984888 $dz.kendall [1] 0.3257834 \end{verbatim} \subsection*{Family data} \label{sec:orga7a0fcf} For family data, things are quite similar since we use only the pairwise structure. We show how the designs are specified. First we simulate data from an ACE model. 2000 families with two-parents that share only the environment, and two-children that share genes with their parents. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) set.seed(1000) data <- simClaytonOakes.family.ace(2000,2,1,0,3) head(data) data$number <- c(1,2,3,4) data$child <- 1*(data$number==3) \end{lstlisting} \begin{verbatim} time status x cluster type mintime lefttime truncated 1 0.26343780 1 1 1 mother 0.26343780 0 0 2 1.14490828 1 1 1 father 0.26343780 0 0 3 0.86649229 1 1 1 child 0.26343780 0 0 4 0.30843425 1 0 1 child 0.26343780 0 0 5 3.00000000 0 0 2 mother 0.07739746 0 0 6 0.07739746 1 0 2 father 0.07739746 0 0 \end{verbatim} To set up the random effects some functions can be used. We here set up the ACE model that has 9 random effects with one shared environmental effect (the last random effect) and 4 genetic random effects for each parent, with variance \(\sigma_g^2/4\). The random effect is again set-up with an overall designmatrix because it is again the same for each subject for all comparisons across family members. We below demonstrate how the model can be specified in various other ways. Each child share 2 genetic random effects with each parent, and also share 2 genetic random effects with his/her sibling. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} out <- ace.family.design(data,member="type",id="cluster") out$pardes head(out$des.rv,4) \end{lstlisting} \begin{verbatim} [,1] [,2] [1,] 0.25 0 [2,] 0.25 0 [3,] 0.25 0 [4,] 0.25 0 [5,] 0.25 0 [6,] 0.25 0 [7,] 0.25 0 [8,] 0.25 0 [9,] 0.00 1 m1 m2 m3 m4 f1 f2 f3 f4 env [1,] 1 1 1 1 0 0 0 0 1 [2,] 0 0 0 0 1 1 1 1 1 [3,] 1 1 0 0 1 1 0 0 1 [4,] 1 0 1 0 1 0 1 0 1 \end{verbatim} Then we fit the model \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} pa <- phreg(Surv(time,status)~+1+cluster(cluster),data=data) aa <- aalen(Surv(time,status)~+1,data=data,robust=0) # make ace random effects design ts <- twostage(pa,data=data,clusters=data$cluster, var.par=1,var.link=0,theta=c(2,1), random.design=out$des.rv,theta.des=out$pardes) summary(ts) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.185967 0.19164670 11.40623 0 0.5222132 0.02187458 dependence2 0.947110 0.07648339 12.38321 0 0.3213691 0.01761183 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.6977 0.02997 0.6390 0.7564 7.182e-120 dependence2 0.3023 0.02997 0.2436 0.3610 6.359e-24 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.133 0.1737 2.793 3.474 1.074e-72 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} The model can also be fitted by specifying the pairs that one wants for the pairwise likelhood. This is done by specifying the pairs argument. We start by considering all pairs as we also did before. All pairs can be written up by calling the familycluster.index function. There are 12000 pairs to consider and the last 12 pairs for the last family is written out here. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # now specify fitting via specific pairs # first all pairs mm <- familycluster.index(data$cluster) head(mm$familypairindex,n=10) pairs <- matrix(mm$familypairindex,ncol=2,byrow=TRUE) tail(pairs,n=12) \end{lstlisting} \begin{verbatim} [1] 1 2 1 3 1 4 2 3 2 4 [,1] [,2] [11989,] 7993 7994 [11990,] 7993 7995 [11991,] 7993 7996 [11992,] 7994 7995 [11993,] 7994 7996 [11994,] 7995 7996 [11995,] 7997 7998 [11996,] 7997 7999 [11997,] 7997 8000 [11998,] 7998 7999 [11999,] 7998 8000 [12000,] 7999 8000 \end{verbatim} Then fitting the model using only specified pairs \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} ts <- twostage(pa,data=data,clusters=data$cluster, theta=c(2,1),var.link=0,step=1.0, random.design=out$des.rv, theta.des=out$pardes,pairs=pairs) summary(ts) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.185967 0.18986604 11.51321 0 0.5222132 0.02167133 dependence2 0.947110 0.07929082 11.94476 0 0.3213691 0.01825829 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.6977 0.03044 0.6381 0.7574 2.659e-116 dependence2 0.3023 0.03044 0.2426 0.3619 3.010e-23 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.133 0.1713 2.797 3.469 1.057e-74 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} Now we only use a random sample of the pairs by sampling these. The pairs picked still refers to the data given in the data argument, and clusters (families) are also specified as before. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} ssid <- sort(sample(1:12000,2000)) tsd <- twostage(aa,data=data,clusters=data$cluster, theta=c(2,1)/10,var.link=0,step=1.0, random.design=out$des.rv,iid=1, theta.des=out$pardes,pairs=pairs[ssid,]) summary(tsd) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.655 0.05345 0.5502 0.7598 1.606e-34 dependence2 0.345 0.05345 0.2402 0.4498 1.089e-10 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.055 0.3253 2.418 3.693 5.923e-21 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} Sometimes one only has the data from the pairs in addition to for example a cohort estimate of the marginal surival models. We now demonstrate how this is dealt with. Everything is essentially as before but need to organize the design differently compared to before we specified the design for everybody in the cohort. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} ids <- sort(unique(c(pairs[ssid,]))) pairsids <- c(pairs[ssid,]) pair.new <- matrix(fast.approx(ids,c(pairs[ssid,])),ncol=2) head(pair.new) # this requires that pair.new refers to id's in dataid (survival, status and so forth) # random.design and theta.des are constructed to be the array 3 dims via individual specfication from ace.family.design dataid <- dsort(data[ids,],"cluster") outid <- ace.family.design(dataid,member="type",id="cluster") outid$pardes head(outid$des.rv) \end{lstlisting} \begin{verbatim} [,1] [,2] [1,] 1 2 [2,] 3 4 [3,] 3 5 [4,] 4 6 [5,] 7 8 [6,] 9 10 [,1] [,2] [1,] 0.25 0 [2,] 0.25 0 [3,] 0.25 0 [4,] 0.25 0 [5,] 0.25 0 [6,] 0.25 0 [7,] 0.25 0 [8,] 0.25 0 [9,] 0.00 1 m1 m2 m3 m4 f1 f2 f3 f4 env [1,] 1 1 1 1 0 0 0 0 1 [2,] 0 0 0 0 1 1 1 1 1 [3,] 1 1 1 1 0 0 0 0 1 [4,] 0 0 0 0 1 1 1 1 1 [5,] 1 1 0 0 1 1 0 0 1 [6,] 1 0 1 0 1 0 1 0 1 \end{verbatim} Now fitting the model using only the pair data. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tsdid <- twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1)/10,var.link=0,step=1.0, random.design=outid$des.rv,iid=1, theta.des=outid$pardes,pairs=pair.new) summary(tsdid) coef(tsdid) coef(tsd) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.655 0.05345 0.5502 0.7598 1.606e-34 dependence2 0.345 0.05345 0.2402 0.4498 1.089e-10 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.055 0.3253 2.418 3.693 5.923e-21 attr(,"class") [1] "summary.mets.twostage" Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 \end{verbatim} Now we illustrate how one can also directly specify the random.design and theta.design for each pair, rather than taking the rows of the des.rv for the relevant pairs. This can be much simpler in some situations. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} pair.types <- matrix(dataid[c(t(pair.new)),"type"],byrow=T,ncol=2) head(pair.new) head(pair.types) # here makes pairwise design , simpler random.design og pardes, parameters # stil varg, varc # mother, child, share half rvm=c(1,1,0) rvc=c(1,0,1), # thetadesmcf=rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) # # father, child, share half rvf=c(1,1,0) rvc=c(1,0,1), # thetadescf=rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) # # child, child, share half rvc=c(1,1,0) rvc=c(1,0,1), # thetadesmf=rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) # # mother, father, share 0 rvm=c(1,0) rvf=c(0,1), # thetadesmf=rbind(c(1,0),c(1,0),c(0,1)) theta.des <- array(0,c(4,2,nrow(pair.new))) random.des <- array(0,c(2,4,nrow(pair.new))) # random variables in each pair rvs <- c() for (i in 1:nrow(pair.new)) { if (pair.types[i,1]=="mother" & pair.types[i,2]=="father") { theta.des[,,i] <- rbind(c(1,0),c(1,0),c(0,1),c(0,0)) random.des[,,i] <- rbind(c(1,0,1,0),c(0,1,1,0)) rvs <- c(rvs,3) } else { theta.des[,,i] <- rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) random.des[,,i] <- rbind(c(1,1,0,1),c(1,0,1,1)) rvs <- c(rvs,4) } } # 3 rvs here random.des[,,7] theta.des[,,7] # 4 rvs here random.des[,,1] theta.des[,,1] head(rvs) \end{lstlisting} \begin{verbatim} [,1] [,2] [1,] 1 2 [2,] 3 4 [3,] 3 5 [4,] 4 6 [5,] 7 8 [6,] 9 10 [,1] [,2] [1,] "mother" "father" [2,] "mother" "father" [3,] "mother" "child" [4,] "father" "child" [5,] "child" "child" [6,] "child" "child" [,1] [,2] [,3] [,4] [1,] 1 1 0 1 [2,] 1 0 1 1 [,1] [,2] [1,] 0.5 0 [2,] 0.5 0 [3,] 0.5 0 [4,] 0.0 1 [,1] [,2] [,3] [,4] [1,] 1 0 1 0 [2,] 0 1 1 0 [,1] [,2] [1,] 1 0 [2,] 1 0 [3,] 0 1 [4,] 0 0 [1] 3 3 4 4 4 4 \end{verbatim} And fitting again the same model as before \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tsdid2 <- twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1)/10,var.link=0,step=1.0, random.design=random.des, theta.des=theta.des,pairs=pair.new,pairs.rvs=rvs) summary(tsdid2) tsd$theta tsdid2$theta tsdid$theta \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.655 0.05345 0.5502 0.7598 1.606e-34 dependence2 0.345 0.05345 0.2402 0.4498 1.089e-10 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.055 0.3253 2.418 3.693 5.923e-21 attr(,"class") [1] "summary.mets.twostage" [,1] dependence1 2.001187 dependence2 1.054030 [,1] dependence1 2.001187 dependence2 1.054030 [,1] dependence1 2.001187 dependence2 1.054030 \end{verbatim} Finally the same model structure can be setup based on a Kinship coefficient. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # simpler specification via kinship coefficient for each pair kinship <- c() for (i in 1:nrow(pair.new)) { if (pair.types[i,1]=="mother" & pair.types[i,2]=="father") pk1 <- 0 else pk1 <- 0.5 kinship <- c(kinship,pk1) } head(kinship,n=10) out <- make.pairwise.design(pair.new,kinship,type="ace") names(out) # 4 rvs here , here independence since shared component has variance 0 ! out$random.des[,,9] out$theta.des[,,9] \end{lstlisting} \begin{verbatim} [1] 0.0 0.0 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 [1] "random.design" "theta.des" "ant.rvs" [,1] [,2] [,3] [,4] [1,] 1 1 0 1 [2,] 1 0 1 1 [,1] [,2] [1,] 0.5 0 [2,] 0.5 0 [3,] 0.5 0 [4,] 0.0 1 \end{verbatim} Same same \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tsdid3 <- twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1)/10,var.link=0,step=1.0, random.design=out$random.design, theta.des=out$theta.des,pairs=pair.new,pairs.rvs=out$ant.rvs) summary(tsdid3) coef(tsdid3) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.655 0.05345 0.5502 0.7598 1.606e-34 dependence2 0.345 0.05345 0.2402 0.4498 1.089e-10 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 3.055 0.3253 2.418 3.693 5.923e-21 attr(,"class") [1] "summary.mets.twostage" Coef. SE z P-val Kendall tau SE dependence1 2.001187 0.3400847 5.884378 3.995533e-09 0.5001483 0.04248537 dependence2 1.054030 0.1277271 8.252205 2.220446e-16 0.3451275 0.02738838 \end{verbatim} \subsection*{Univariate plackett model twostage models} \label{sec:org5250adb} The copula known as the Plackett distribution, see \cite{plackett1965,anderson1992time,ghosh2006sjs}, is on the form \begin{align} C(u,v; \theta) = \begin{cases} \frac{ S - (S^2 - 4 u v \theta (\theta-a))}{2 (\theta -1)} & \mbox{ if } \theta \ne 1 \\ u v & \mbox{ if } \theta = 1 \end{cases} \end{align} with \(S=1+(\theta-1) (u + v)\). With marginals \(S_i\) we now define the bivariate survival function as \(C(u_1,u_2)=H(S_1(t_1),S_2(t_2))\) with \(u_i=S_i(t_i)\). The dependence parameter \(\theta\) has the nice interpretation that the it is equivalent to the odds-ratio of all \(2 \times 2\) tables for surviving past any cut of the plane \((t_1,t_2)\), that is $$ \theta = \frac{ P(T_1 > t_1 | T_2 >t_2) P(T_1 \leq t_1 | T_2>t_2) }{P(T_1 > t_1 | T_2 \leq t_2) P(T_1 \leq t_1 | T_2 \leq t_2 ) }. $$ One additional nice feature of the odds-ratio measure it that it is directly linked to the Spearman correlation, \(\rho\), that can be computed as \begin{align} \frac{\theta+1}{\theta -1} - \frac{2 \theta}{(\theta-1)^2} \log(\theta) \end{align} when \(\theta \ne 1\), if \(\theta=1\) then \(\rho=0\). This model has a more free parameter than the Clayton-Oakes model. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) data(diabetes) # Marginal Cox model with treat as covariate margph <- phreg(Surv(time,status)~treat+cluster(id),data=diabetes) # Clayton-Oakes, MLE fitco1<-twostageMLE(margph,data=diabetes,theta=1.0) summary(fitco1) # Plackett model mph <- phreg(Surv(time,status)~treat+cluster(id),data=diabetes) fitp <- survival.twostage(mph,data=diabetes,theta=3.0,Nit=40, clusters=diabetes$id,var.link=1,model="plackett") summary(fitp) # without covariates but with stratafied marg <- phreg(Surv(time,status)~+strata(treat)+cluster(id),data=diabetes) fitpa <- survival.twostage(marg,data=diabetes,theta=1.0, clusters=diabetes$id,score.method="optimize") summary(fitpa) fitcoa <- survival.twostage(marg,data=diabetes,theta=1.0,clusters=diabetes$id, model="clayton.oakes") summary(fitcoa) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 0.9526614 0.3543033 2.68883 0.007170289 0.322645 0.08127892 $type NULL attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates log-Coef. SE z P-val Spearman Corr. SE dependence1 1.14188 0.2784057 4.101497 4.104867e-05 0.3648217 0.08158643 $or Estimate Std.Err 2.5% 97.5% P-value dependence1 3.133 0.8721 1.423 4.842 0.0003283 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates log-Coef. SE z P-val Kendall tau SE dependence1 -0.05683487 0.3239422 -0.1754476 0.8607279 0.3208252 0.07058583 $vargam Estimate Std.Err 2.5% 97.5% P-value dependence1 0.9448 0.306 0.3449 1.545 0.002022 $type [1] "clayton.oakes" attr(,"class") [1] "summary.mets.twostage" Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects With log-link $estimates log-Coef. SE z P-val Kendall tau SE dependence1 -0.05683996 0.3322322 -0.171085 0.8641569 0.3208241 0.07239207 $vargam Estimate Std.Err 2.5% 97.5% P-value dependence1 0.9447 0.3139 0.3296 1.56 0.002613 $type [1] "clayton.oakes" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} With a regression design \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} mm <- model.matrix(~-1+factor(adult),diabetes) fitp <- survival.twostage(mph,data=diabetes,theta=3.0,Nit=40, clusters=diabetes$id,var.link=1,model="plackett", theta.des=mm) summary(fitp) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates log-Coef. SE z P-val Spearman Corr. factor(adult)1 1.098333 0.3436264 3.196298 0.001392032 0.3519988 factor(adult)2 1.231962 0.4938132 2.494794 0.012603018 0.3909505 SE factor(adult)1 0.1016635 factor(adult)2 0.1417283 $or Estimate Std.Err 2.5% 97.5% P-value factor(adult)1 2.999 1.031 0.9792 5.019 0.003613 factor(adult)2 3.428 1.693 0.1102 6.746 0.042861 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # Piecewise constant cross hazards ratio modelling d <- subset(simClaytonOakes(2000,2,0.5,0,stoptime=2,left=0),!truncated) udp <- piecewise.twostage(c(0,0.5,2),data=d,score.method="optimize", id="cluster",timevar="time", status="status",model="plackett",silent=0) summary(udp) \end{lstlisting} \begin{verbatim} Data-set 1 out of 4 Number of joint events: 529 of 2000 Data-set 2 out of 4 Number of joint events: 248 of 1212 Data-set 3 out of 4 Number of joint events: 254 of 1219 Data-set 4 out of 4 Number of joint events: 633 of 960 [1] 1 Dependence parameter for Plackett model log-coefficient for dependence parameter (SE) 0 - 0.5 0.5 - 2 0 - 0.5 1.761 (0.083) 1.628 (0.128) 0.5 - 2 1.74 (0.128) 2.017 (0.092) Spearman Correlation (SE) 0 - 0.5 0.5 - 2 0 - 0.5 0.532 (0.020) 0.499 (0.033) 0.5 - 2 0.527 (0.032) 0.593 (0.021) \end{verbatim} \end{document}mets/inst/doc/competing.pdf0000644000176200001440000022200313623061751015427 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 3157 /Filter /FlateDecode /N 72 /First 591 >> stream x[[s6~_f'Advj'>mEGR~/E;j;h<@0Ŵ-fP̰H,dB}Ǥ'Lodhc#GDŽfJ(ńaJy ,b*T oH^NJL*10-@3Da:P2ma2;ӄ@} 9f -|l4T,3QdoX("C*q #T0%R&XSG C`S!ms}O$BD[D!Q(Hړ3 BHB@>X|q&(tX!(`@^輨@$!kiAp̠k@Y )=oH AR B Km 3,'I"ɃNI׻mOk5/n*-H1Gt14 5*ǔTzh_ڽ"ٗ{ǎ+OdZ̸QqGI FFc0$b  xRNf4)wNr_u* ?fwtĊa!*dܺ鸸=oC|߷[{̗: ir ꣶH)Zs+SOUs/͡|kw!K}EezL:fxQk^B#bDPwIz}Q^-w.|;>S~_?Ƿw,c~G||~ůR~o׻dS'OyI$*\iFxy /h+,B8f_I+8mw׿Nz)Umt5 i-ZEr+ ט_GBٕݝ˳䢹p:z "1ݚa)pp1ڋ %rWG6h'|Ky4?s?gӄfd$F Rz[ȂlѴɸ4۴k7(k[eRxCg嵯/SP\Eq0:>i.&{{wuj e#{a|lui|c$Hayd|&䥚[xi5I{↞f|xvxaW6ՍZF&2]mA)Y)Ty`c,]BU|Pug œJ&KI|{9tm\CujDSNצIKսw^nN.UۡKTʬCڰbH:d >.Zd7G3K78cyN@&`\#[^8Nٕ::DPέ*+Je-!E]\"~f2 f(eL‚W9h٧ϏV|]AW=iK*Bjp"&r՗iUv-jڵCÑ.!r ɥ m{|8w}kjTBx#EE)ZH*lɵVvup~n pYMU2h3V~4iSnU7[!}\ƣOۿg62t,1oI<[a V68aSfww?cao#::7]!Y\uAkHf| ;7֑Gu2^= m { *f,qM.l&5IדbϏ>n/z Va=?>|;d,|u\a`mStѫ8Cx5[.܏&m+J)\$3S7;i}q˦ҮRt 鎼tU le&p%:Bҭ]+͕P#kEoDn7 eɊr^D]?|xtcL2PHL'Uw{JL*N^J ^^i(#vǞe0qfbU-:F(>zxMt=~lzcUhP+o~6 L}{?`{f5/h4|ڦmt{=}Wp Wwҫ{ oڮҋaρEJ]LhUҋIx|"! ؋ ֺ `tnB(! P~gsnkp60-WGendstream endobj 74 0 obj << /Subtype /XML /Type /Metadata /Length 1635 >> stream GPL Ghostscript 9.27 2020-02-18T23:23:36+01:00 2020-02-18T23:23:36+01:00 Emacs 26.1 (Org mode 9.1.14) Analysis of multivariate competing risks dataKlaus Holst & Thomas Scheike endstream endobj 75 0 obj << /Filter /FlateDecode /Length 2210 >> stream xY˒۸BLY.=TUΌUdAQPnԐTt#\ăj8^hv{ej??]Hw_dxk8$,t-d)SLs3,s\8] ĴvҝW!xt]9<](MkHhe`E %Ş]cb \6 MѹCɇMiT"p SĹPuRbc\N r:DH iuC@W4$uq{o"A/[Sm=ɰ ɣϙ l?;) u״T bjXu:R5bS'Im*[#UpjP(ieM2F>/P6toi6齋`7Ho^:/'7DŽgC/6JdwzCku}{.PDrWeST^vh (Tw5pm.[ݕ#EstIH\f޹5}{18-֕18}B.]tæ$6D{A ^I jʅȗ1o*6 3,>h(=#i:]JEks9S=Oڤ7EgՈEFUjrtQz Y +P/-NMLSX1z$<|3}.0$>Oǃ)f'A* f@)6L?'a.r/C2:C NJ@Mo9`fԋD"/Q0X%.3L~ i$#n[5P5ϥ\20А@#k3H1*d 'ʤZahH?^ۏl+;ߕʋafIꪭASöl ?#֤endstream endobj 76 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7106 >> stream xyT[WcɠhrNK$8Nb'v;S{q)*B*GBHދk;NqIϽo ̻뽻X%霳_(Ɣ;QQQ;%&DBydȯ3M/[?QȜŸ{yGW3h0}J(wrϭ%QQQA ?sW TaV,nŋTq?][) f H\'ȗ=] e 2"A܊- m^7gqkI(.A&m 2Œ8ѭ/q L(Η>L'- CtAAܸ$O(qBi\$5_&Ȉ"yFd{{8_W y Z*A,I%Y1a[6ʲSe}Bt9N#rM*̗E>i @B $IRa~֯ύR%"trHT~/7^Tϊ'eL*e>s6E,L-q eI+ W)67gllLښ-ܞ#whW91wc c1#'V G2v0v2cbh1ICfb9pNͩ7?ڮR ̋> 4SV!nI v~ W`d5 L"A(f.ы-)&*!U m{]$0N0 s{A&-bӇ‰0u);j{mV}.]IR3~6uv<ck/|gGԗ!Hg32%`SO_t5ErrA(;"lu[@V*SW v$ba>X+]k(Qd~D 6l#7ulB#y&\ 8q6+%fP NK48К*9N{5 AEkZbidx1ȣҨ ieTa ep6]OL#%p1j|`Ī\^(kv C5 QHHxj9# / \kѰ={.ٺ6gމMC#C23{B`.JQV;W =c΋LMZ|=) kYWPбX|H'Y|brz+IJ$ zIy)G||So u-/ڕ2ֈW|e&0 ,EW4Tu,jjn3q}mbXj/=-Ǧwf_QG皷-Q at_Ϝ収oxŞ&fsNņg]3ظy'|3_0̓t;U%pV½leaVBV?` R@kOIKץ/5X+nK|ܐ*u:x}vS|ߒtzڮ|e~nI'z#) \/OQͼT h/Ax!(7*9n39 sL&bb8q"YȢL=Kd(quƊ~gz_}8e$qsDitg=TY`Ay ~Wh ^|p_碚$}t,= l!ƎYHpPj5={ *gCj[J?OO(6PmąSY͠U~G̮%-L۪nvPTςA=U~k`λ62xǹ<T1n{HFP`sޞ=lgZI`{{ŲslPRVg'n`3~E?n{H#i!4xR4HWTWjJzF+|_y7,^o֏)5FB( * f$O׆R/, sCr!)e- @P+! zE&Ѳɜd9-ɜSZxP QA yQN꓍bS9n6hrjL6FfVDBj+t[+zlOt{lX͚OH[CԆTU)P (l~>嬇Qo1ѳXTdh/0m0yUJG#dW*P'[5:H-RPs2*t@<_ws?|Qi”Nr 'sS9>ZmV:po8Qs^J ËB%kW`8# \_!eI ]/_|]R_F.|8oS&@Ek*-f`ױC@pJM@%T>e|hCуc/\l' 4f!"~ʛpX 'Cy^(_1pbs (ht/ӏi6iy-? ~W8vjf`6-xH,b/qxBd썭Fn u/?"\2ڑ³"ΓbrZib4mISK0XW9~-`b ٜl_?ڟyra1܂} `=U`l||+۞ۼ55[w 'k@=1"" X[ skF!~ >N/~͉u$Hv2F&'08kY2RAIu@M)(%L,Oڰ{Vb>p k.r~JKYyECo6WN>z N|+gt:ZLJ1}0+ORD| (BԪ\ߎT%Uvƥҳ6=+CUSГ0 >tm]*Ċ.-oZa8nqh[skG/+P3 +Yc5xFRKg# 4xXΉ#/_g>}o9JĥI9y^dem%oP,[YI-^~݆ή`M܅LHX?9dzYUI/֛2Z uJOíI!:P7Z.i>Л=#7ʃ7j=ZY܂gӘfod<;)9EPST%懻>ЂkJ9{xT6e]Cr/d:3& */^Dڽ| c:;'G³ƣ|[r_pzlO&emOڑ,x<~b(cÃPnAq6ߏk=S$JUsE&\Ɉ\(`S t&o._UBd9jсBdGn:1ubIQjUF=8`-Z~xQǫ30>v*'.e c(!cr͡6ʏz9YZ3ӖeSP_z-֠j#P˱x)hotj+9njYTn2t?U |ET[ N)n/7bf}>\ V;VG SzXhcL&H! -e/,"Z|4͆^rSyA;N3׬J޽%!|qN|?:vbON v< 9\{U20EZ%f)xh.KvQmw~L9ehTTxL*kJ^ҔJDoc7Xytb&YW%䉲zĥ+5cfYc>0R{[wk2FAm76}|Qˉ_ZZj@#*cFa5({6Ym )OҌ<#W:2VQ/bV#§xFiA3($퀝][ހ;.EEx3XnF,T3NQiىڤH ġ@[J#v %ZR@ViJD%"(WF!WQm6A6;EYmlG_7%̍a"Idǹo7km1(y𑥧E5 zzbKX;tDcEB/xUv`/KJZjFL pĭ_7J'2xFܥ\] cgZ7j+=2Q`'I,u:yq69AVsvme%(%*I`f(^hKhAd*V2>zI{n<噊]<%~uC{Ck_CI@GbI56+PNt81mcُoHRѮI`+XԷ}2xYs6ƞrݟv *Sx͋)aܯM+;)΁uUzEK>,mMĺIWu\``ύHȹW'Gnͫ RFhd9iGo0m*U P9l8sfZ~d "Rgހg5$R9`Ka*yf+QvpًZxF=߂O"⓷ZA>yF{A`L@yb,7`CזƫW'ܣxFގ5hkn?ԁer0:*̙C,srl<2zEJ)$_]S9sK=Ԣ&ԃ+onl+Lz`/9zZh.FQRb*QWݦinN /mS cW[;6+/D-gĬcqE* qѲ.Ꝡ~ lǜ}.g=YMQ~D|f|n4lwyPW8^Ϸzh7&栥}]n$]FC7.id&)&UW1IE^4Z ;7]v&H ,E4j߭-}DP֬(#Wq+~lՑbՁͼWY=d;P퓧tBW:W6lu6WOƇn(˖Ӭ4z_֡[3;ЫDYzcP/67Ye385_uGK#&8-7F*$ڧ2ּր.3Eيd?ϖGOox ʵ[*BJ5 5֦vkȒ\FG^g[Qڵf@Mߵ߽wNXYpU!mҁRWK;+^om˺y"ǣ{f` %mö`6Hvo[~G*/q;>+эr?oxܩOZ㆓esM)/Úv ,sq0䙼sCA`~a^8_3թE|n"z;rVPS-aC^Zh,!bVd:Zp)'[1Z4R>X[GBe삊m!aaqʠr+ܔ^?k(JP K(>~]'zW7ʟHO# X5t5C ӧ30Uendstream endobj 77 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 960 >> stream xURmL[URlc@7)'*a8󃏔tmCm`'l^V 4NtqQ2[ du~]~1L$wB69s7/MP4M ۼ 1a$^hV0R>|?Q?RdȱUdÅ.Å$EbO(z_*,2M )Z_紁bmgR;4IOVnMNxib"-/ƎW|zE%WVGklESp+ vom7}OF$'_ޟ[բթ՝+y*oxfݢaDG.lYg?9_uRwu5y52}%Kׂ7ĸvl\ ]}'CI6yendstream endobj 78 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7033 >> stream xY xSպ=$9*TlM,4AA2j[22tH۴ڤsNidCi::0ʠ xxīW}"朳q!Ə#\\\܃6n JC#$ W7*ḑoО.qpOCʚB9/%q@d`TFɦͱARyi_d^/g79s b*@L# b%b#1DLl&fALb F$fۉUīD0C s obO:bx#[3DNp 5xH"&l‹ $!#&n$b5&21wr\RGYw᜗8_H''cTF&*'~~zӡ^T̚gF%Goq=[{G?'~zp3O =7z͝[Dvb){#ҷ|=:3SDX2w՞ܺ $td'mҔjI/trOD/ܜyp+|zμSbx^|MFm2;8N>ͱ=c~_]r,{'-=ۡdC7#9ž ++VD '54f^s {s.0_ypZyl';0Є_a}6pR:4W[ c桟$t"#Ӽ-g}NO.Bnb_fqZ&ӓ5))Q>?#99a2RϙXv67 ]]CzfJw0ЫtՃwSs CX1jς:?tAH_I菼DCwaOnH$L!wnPW:+IH%p t|>OϩͰ hX^h ߠT;WL'x'tG\)y(Xo`@F`7\?"gjm {,{@ss  Hqm!TWShN U2]QkU| 8;w3BFm2Fg'*wfH6hC Yb|+e,vЇ#R{r3l *>n9JFi CA4#kW Rbvr6j| Zts<( ~ e]NA %W@BI$qKjK$8ߑӘgjr]7W4\v0(vx ~=% l E0 ɔgIu t?:1^i<6f_O3zjeқy\yoCmu^uR8!$0d 6-1~/'_Hn1fyy(X`k}4 2jh Kəd2l~NWOwSG=ڣpNS\;XKa4|N~4uvև߷4$ۄqM1,V y҅#!BCM[Q%axYzDaK汴ٵ@LmO}Xqs&wKG}v68R=$ a*"y_XJ:] TqZ`憆E%C[}faЀ'or@BBV(b3"@4PfTkAsCXj*[.!MBrg.Pʓgr0w +CVO6a>v:Цt;H&lJ f`U&j3 3_ Igtim-'̓;w܀a~_0W"d88¨ '-v6O1vcٯ ,3å`,zoznkiA;Aqe1@f& ENIU+%ؚDUԭI|ت ƒaAKNYP,OƬvဳVΣ}yhx;e+BPx|Hs@CaQ!tx*4JPWb1o.F9Ȑ[3:m@sh.ZX8w%t7FrK4g4 D&oc4/8 YwNp8Sr y@NdUU^өGƚXw!:u[ #Nm=oAb'D5Wb _n -=Fز6en@gրZ;Wa·`a{ǧ[F`u̓ ]M Ԃȶ` e6ʃ?X1%| &š6 E\8 >u]qxZު*o05 B8V:Y6]EnN.nZ.t_>^;ph4Y{X~K/8@sanU8fNNJd;w9:$7<'~C#D  ܀Hm4¼2\#L3fB?Ź-)αhp*2 Y@JZ2k5kjPzMxOgIJIݵ={ ] XRbt^ӂPm#ͮkŭ@i>5Z^,٥!gзr .nۥu֍jl%i,>83ȬOs*|ͻw&"u0q篸0[@dZuBsTe`ҙde#ms., ֲj_;}5%}gaC)p4fe6-p0noMe਀QNZ6/V0mͫ7x^sza @'S ݟ`o2 N않&Zէz.w.]XhN|?toΒf]]rgW^٫rqwY> stream xQAHQ~jI"Pڕ,[[,;μy7{[n(- !dEP 6D]n]ԡKB17u))v#R J33q%8QtDi@T~,"/OvfxHoVYV֔ݒ7aN%%t*|~#091m8)ۘ2gۢr0b\͎]Q6vU B m{`.4fDf>A`&> stream x}R}P0n.ݦ_%MQ3Z0²q_wrp}w",$ڦ*c4QѦIN.v{i;x{^DD Ȫ]%L"]HA"Fn G^IǞm^# #Y&,w֭wnx3zŒ&wGЄ;H#Ml v);wF}T|0R6tHlr666:v\W 0C^6Nh":p!;AwSQT|*vxǙ[݁^Mߣ۷|^7K9 w% 8[H\}0P!'S-=HRr2_|k CM6݆/3xZfK] R!0O(2q-zZP8l "{S.<D?gz:"JSvF<Έ?'ż"߾DڢېPzۺ@'*i4X _U3րu8m=t4vn֔U] \?<:Tݞ=5\e)} fURW7 &_/.ͷU!T"N$EtzMHρxo+¶#ုT]A+R)$ ^5_|~n!%hl?`{vT2 f1V]go,=.YWǐ}/wN(J@qSx_o߻~+۟];܈B xzۓՊ\KCÏʊk+abm7z>o7;UL+f4Fe?h-0OCDW/,[P !`aUe+]OzpG32ٿendstream endobj 81 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 566 >> stream xMKLQtڡ&eњ mR !6aHPKC Әƅָؘ .\?BHܜ#f8NG{\8MդڴEA2jhExcP\v vwУ@KJD,E1%.%cJ=ܡ}rBRƨT\QOvv%Grzt{UJJ#R4@#rJbIhXN*RF)"{GqFDDb3 a\Ęמ*FŹ\]@ֳSf@U˰1~n3.L6%ϴ?}:[4_a-zC1ly\9Ь y-7u]q`IC7,1f_/.0-7/Psh8q |>71/[v  ;ϚYIkn>_X ޻_Z1+Z*TvisܭG6Bݎ-endstream endobj 82 0 obj << /Filter /FlateDecode /Length 3145 >> stream xZ[۸nq~Vnc7z(@/^Ȥg_ ٤؟s(R$eJvҾ2M|~FJ:#]^U+2zE3gn X53LΖwWݍtƔ))3edguQj|AyIHosBS.] Uqco nHI1KYUJzvϒ,Zg%HZp[F0Fi/3 q aYL. Lv _?Sx.5|@[ g[pa*Vŏ͇9)7u cevmgV|ܴGwUl[{vnN5wUWuvlwEUEgi#&`0ҞmJC}w͙(M9fsww_ƌٯ֥]ޢ_4;mIn;7/y/}ξqLRIfW_]ˇuGjC}ro󪸇 -:x%j~T Rn3]D:!p;7JQ;@hd,\E~=/-+JgfPnu;EsCQY<H@mpqj]bEV7@rV1Db+,Ks1X I zx:n{8xڐv9 VnP}0!?9Cj%P KgǷ|Ay@2TQ25(L/܈3|~A0^ZdF6P1~R8./v)JAH{vcg+`zd^)xn4.[mfQ3|უ) SM~B=x(zlp>֚ ~A*7 1_ceC@}3la 2"/ 2tB&- I2e0M ܕL^aM,r|m9zqh7ގQ 2iy]?mU(TBo\1@^B]WwߘNԻ]vӴϛc 0xB' M ݺ;c$zLk(zKiy dv#O)֩G,(6QQgyHSo,h>sہny6O ܸ0rn12 O}|>@O /8TJ`yBGR)3|*yR יYP!"G3s6Eʼn*E:ҐںCn)lwm'hzI}t$&*0*ˇM{TO ߑQi~kzA-OȏfgynېAPv)I*Ox{X<a5S<6 ,Ȍ$t +ȻCVp_4ׯR+'n_BnR4EUc*.LlE~^:luV؆K@yğv%5Аpʛ e(xc[9`ND㮁HeY %:]Y~gCn%(+T^ߎ:Ӻ) .;4XCtm9(P20cr!NMB0bkLy8 >hXoJtF~Xb/^ij3aɄm pU)5qq +a4:GAe-$Κ+K0Aʐ/dbf$#QTYo[-Іb>{(BaTUBѣً^e__x )lp#hTVv3,fQV yOtU")MOA u*ς|"y'dȡ:`N!m=ĭp,ݱN:#cYj kQ(( aTi TN85"5& gHX j<BzX:ƽ!@l'IQcS0 F:T$)GxbY$ru#>,:٠5˒[mxY3H 0(b{>- l]@&ŀJlta1@3_}5@`YQQb. Emx`FCGem yi DX;QX;Z)Wl8[ S*I "<#\N:nV} >Lu/%}A7ʠnHjo}W"u'|škkf:4|^3 yb^ˀD Pqܭw Nb@7JdXF=S5џ :xnf 5G(uVjJʸFo-IJڼ}^d=~0pg61jvmX^׷ ]Gc ))ΣNپ'WĞҚDbf?̧c"UVR@Ѯ`lᾯ?eg? &JLBй ft_Jj!VPY6 Z(5Yrޚ.JP[})ycu˩ʹ*6BN-ǣ!_{(w%H68*{S/ dk`eǚPC#V̥d@&V\NN dN|,0ÙOq7p[WJendstream endobj 83 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3684 >> stream x}V{T׺*#$h- HD@@{73@x"**⣊>kke}TiY{ۻݓs׬5ٳ}eaL&i7FKAqL|a8I_с&.%m/5ⱏdşPriS{Ys2)6݌u/Ϝ9Ȝ s VcY7dL46Kt\YuzS.–o6dE :[Ad4tAk7X[i &]xfɘ 5&V˺$KK6l[nutC,2d'ҥt醌4JuF.9Cou6hN0e&JxlӥgX4lnڬ tD ^іIqFYgI"3- 'lz٪mRx.hM7sH\UzѝBhN~}.ÐH4}%V=Znqg=oY D!!Bui]O5%s ?'S5lIϰ29 dc)ޘ7 ޡ"H*ZOEST LZAVQPj FQ*yJM&P>T%L?lİZ#;_)ɟsx}ĶWG.ylc2GEG]}r4IVGp3i ,%Ұp ѿ {`7zq?+lJk; cn\N>),vFȺgo%QQa1R5~g鈚&9h zF_ouȳ 4ݺ{>%"ےP\ )6q:>ɞd|X -& ; gao KO`Ut>T\<` ͈ sp9ZW|h~/"՚ ,28 a?lu'xW K*Do)uPC!2Uȭ߃_G}4V5m>ǘ/bzJgy`cAP( :}MY>mSRpn1k(ʊ'#$Waj13% ?ܜm:{\\Fq{#74110bMK'WrJaUP2ќ£ _~xx;rV4hYw9f_;/)hSﵗg'&F-wYU-q΁9uV3ʊ4)#g8g 妡kInȼ|pMbO.|'$Am쏻(a"9E/EExVtfF[4|t>d!6B.ĻWX58~ԫ(>K>B25V/+Д7W6sO=<I-tvԧiв 'hvnO/(:(͜rr l^v 38|6jf1x&=98X~?js*6_'L={bv4 3sL>61M۠˛fʠ/3y;'0/]/M\wǠ{%ֵ[ S<%Xx"6.gҙ+/++,+eTls&N\Šs'k5 YB_IA bN;SSTz2n$DCu'2mZ!IѥBsՉ ^!"4B"7#>‰d_eFm\Di@XO Z.F ]-$Vn 0qf)i~wٓ+Zc[Ɵ̵ǰ*ؑjFg@s蒸 ~mbT_Пpc~#ymΊA,_jsc΂ £<ݱUһrhT_^oOgڜM9k[}v/W 3QR`7"5~Ze.ҫ8`EZߪڧƩJ.KD+D~7d"}YWP8?M5VeGˑa$DH FRlkyD[V!raS50dcK|zsE]RH!}mTН[r1Q:ixXK$/a*R~G/ z79 E-(Ưh9/92 ޚ =TTGzT{?HUd$uM9{]8"8sF?fTYJB UABE{-?sU5+1I!yUT|iTwb:>{#3`ohKG?ј>ʳ~oy[N#NS݁ 1٨`鍁(f~hy__=Юԣ|Sຌzr!a; k$Fo;Dtˠ% >ӱ/ݍ~_} x18$VSDOքԝ1ymE] ?yۛEΪ(Yyhčnzendstream endobj 84 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 542 >> stream xcd`ab`dddw 441 ~H3a!g&VY~'Y)Krnn?& }^=[19(3=DA#YS\GR17(391O7$#57QOL-Tа())///K-/JQ(,PJ-N-*KMQp+QKMU8TB9)槤gf$1002f1I0012,ceb`Aa#ˏ+G~e|{>ŋXx 93~gݕrL++;WUS{蜹WvWVU]^>{<ߏa3P]&:vBniSLm./9%:;'˃L<0៺?Ӿ?]:K]3ĵۧ;z[Զ;ݻ9~3f2Ȟ3o~|wkOtޝ'a_}gz&WB7smbK<yendstream endobj 85 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 394 >> stream x]JAgj 9&!Q A 6Rj]YCLj2!JRD^cGѭ8'Sh7*,g%!ގo%N[ o{e%mE`8%BEΝg1\Oa4mH$wE$BEHb\ rH!I>nrg1*" eྔH YR %d2H,m| e;yfM1ޟofZG1{zA]"Z?t=qnRͨy;μP =ҫ14N4CQUE5-T7 Wt~giȒMq8;mk?o=s/miendstream endobj 86 0 obj << /Filter /FlateDecode /Length 4771 >> stream x\[uv*vj…+%(3%۵3ھO9 @$͞JV/<8\g3?7_Qo͏o˙c-,`bfJ#>iHgLR:SF|vy j|AyI`yJ×XoBjY'R&c6yJt^K^ XE4:s31C}6{GT`mIJwaAIJ{HѽS-?n DLY$#yUQ=_ f!ȫb2E?4~~^ ԃlj_mݷT'ŦD?% t.Tp­f4NT?͑@m_[8F9,bx֗zsK@`v돎3Zlz94j5!&a- RjcnL(cbQhWPԮ%D!GJ-g47@JX u(f! $GN(`Ph,w$'JA*>x~YFhsޣo2TӢ ܷ_j ЬcsEίⱌd,#u)Dov<-Px1<"3gUrZ-ii兎@̱)++iP{Ob!_7S} ^mx!!` $t21yV2c2 UrN }\]_zn?c`r}:7 g}`{02R @ihyG !pI@}6[S/[ +4dUZ! Om5e~6@q.ΛDM(+֔Ф4ڙP`†V\-hg셦xa|5 رKbS"L/*UqbSpKݺ0wJ ԧ=do*"gjK,ɰt(SEJ;VlFʪKeXZu_f, %% fois0a?Ɗ}|%K" M5\PXb$+KEZR$?eXg/ %&;9RMDFEpHߛ%>b& nRM]2Ddg"0zb A()Ǻ2mWJɵqɈTI=eY[9ӌEu1w* P%f$̆T.` J3 <ddxV\gOV(yɰǰyy`/ۂHo˅]Th8 X 0lK? 5 mc1LYT{$K1R0o,=O+53n]/ |UWil춡m%6jYZG{ v˸كn2N*aGH2I V-ݿ XY(~6wksu +Fr^cg؝Xg~,- :^z}؅Vtp1{gX!c]Jەb 'I4T"ʊ%ذ7WV{2CR){iދ# IhRMw=Uޥ+Zj'iEp. MgM9"`8ZZ)v3U(Zhm ̉6)Vf2@$B\byXOBm[rL ZWſ葴G1FaƂm'kF pMV=׸wTٌ5Tօ֏;֊4W#:Bcd.;tFF>*G~n#ø\}wΤvb=a; A\Ɋ% %zǧU$Xd $ZևkQo^`ñvh>Xz!,:'r&AXh:Bӑι|aPw١+ ЈWȿktNd&r~XG1AdeZ6[=v3J%)p&*`;waJ!}=P&aش6NgĢ5VT+6 7Z6T FÃ!Ĺ Dǵ‹L!zzPu~bugF'|I@U ;`/ӫT-I}Eh2EWXP'6`6?'v'Xm׫1D(ř1Gj4?R 5:ԛh̨^F5C~Ģ#!ϯ:7qz?.&8|˩L,SIcQŻa\BKfTZ*t^i?w1|@UFB)NBLfhPw.ͽ'- ?u)tCU_zA^0,09Afdl =Ƈn4<Z}[ΟCqlr5Dv4y( (bG2ᰐUaX\:AHMQ x 3B9~GTy,7$j`~wi j ׻LҰdddAc֎Q szdjx^DI>ŻZ\pDFrJr석1p]`%axOFCgi(" epWqub(u/q|d<5E񓦎2qZ4dzuPzU0z?N\ c`me b3oM7<\&OͶGy#,Ƅ*(Sb9)]zZ/E5u8,(Y5`]=ԹKqR^%8Կ]$p5'p:x4j'K1.gTeɹcʩ'Ӌ^Mw09k+EKJ" FLsA9+=יc"ZA"mX3Uo3_c2߼T wNȿKwyg c1&&/x[ls£eӋ *TIh FpZNa L=?mZVuh :N hP]ƋV:2,Mud<0hlos~fr3,l=ZQx}XKG''riKEQl:{Tҙ~r fz Bd}zNb;߄zI[PWDz#vc60 {HgLH׉ϖ e%M\ gCaH-a p:Y2$+B#]z_if:bM[H#'1DZ&<7qe7TW/BքQ9kxu]9FxŰy%^Xt olܾpC{endstream endobj 87 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1247 >> stream x}Qoeki] ellH"ɔ4FX^W^swl{ۤP["( 戛B4DƸF]~ͽ|<0:]ﰛ]_  S)VXtًƸU^a- 2M_(gDq~4~ n/ 0>vF|UcQyБhu[:&pi 7p3!^[UF+}H%ܚT UpRh** <0f`C0k4i K;0V!s^4*' nhgF zKli֫uzXw$ho xZ`]=\횮F@B!h8OV4.u`B\p=e]gJ=_Zq6'0 \=?E[RaeJ&RQ@@GWWsl[7y}$1kN8'#5 SGd%R6Gc.XO>j^z2SY8"^ۤf#:Zӹ85ORRߔ%qWlϘt#T?H8UeCʒL9о>e- 4ǰ"Up&M5T\۽++TGrLbNO³LM.I!~>vyddjxt[={礋Rqm qrnD֧;HTC1):~n~k{JZB5 "/x`'wa0?|9?ע L*Ђ8ȡ38ݓ32K_|3L@`$zEn6'covp;*L\j/L+O/N5[5"\c/@F]Zm?2\-/ɛ;T VrlڰC5l.5ZIj@woN|y4P_˾Q?fL"cZf玺.*)pw%y?ZD g67o/7Ւ@8z*p;5< Q*Ө oZ[wwP-_}>O6 $/3#+ZOg͔F$Wqu{k^uGJڭ!A3EsW,2_,:rb;j)?s+Xendstream endobj 88 0 obj << /Filter /FlateDecode /Length 3832 >> stream x[n.O!J56˙ФiڴANL╨l~%W{;3#Qmk )jtx;gGYFs'_Mg?wXȦVq5=k~F\۔16Vbt9?JEFd1`"2ûqY1Mˤwo9Z9ZK^Z%p;O&g1Xa /<;zD^*{*%Õ5[Rt7|?Č&`ztAʙ]_En3RNRL鲾@2KF6`iZ(77cC|֮3ynÒBd9oBUv|ySλGM RA^ogEP/H IF;1?z5ܓ|r^a+5p1*VӢr#} =2BGZDљL$wk@ 'vNp|6R e'Oբ])@M).-D\fuKQrU[W^ 1$ؖ >=G3u8XfF孽X#2-w/݂^4Ww*0mKNh)=%T'R:mτ3xP`w,6m}Le+OnzӉ8k;ATJ= #J#搶d.m+PNe4n{3]WMHLr{슷H. ל{i7xJOSOqز8u(&^(c@HQz!Jrk,*}=4 JofKYn/š-9$C6=xZtWN.kf޽/wk|6'mH E Vf9TO)nu֝sj۳eOmMphuMYņӳ<^m,Z tkZ 4ON{j|(_hꥦZ C܈}Jہ zB6L( O(( e8d:}ލ#j"MHҳ{3 c E"LrPȩ@zGh5mBdk'ġv"GN7o n؇ 2U9:V@ɮKq (^egE{M*Ϸ?pL6`1M Bn4)"Y?G ߑ`Q2庚΋t?I0{*큙Wv,h*dyP ɲɲk/톸AΚ]JXOՙ(z21|4+jj= irHgHIo5v rQXyQ z RũKEe}t _{MQ웞 "K%rBP]4LX-Bp\a/BPM?lP^Γ3eפ\BlU}yW+|/qcAiX4#h[3, `z}ZBicu\ͨJJw=Q9 GZ 'vSo 3fMBu+MҎ ,1B?X%K8ȤKfqSzyoyJx'0zl<*^oړWMqCԶlHLwE)MNB\ d¬"6ZD-OM!.a}kfhߑ0ѡ}-Um- fX|GZע@`zntM~ƺo_g9mwyX&Sw9Y79{(q{7(n ($ ;0Qtrn$%ĪN~;i)1b{Mendstream endobj 89 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1370 >> stream x]{PTuuEImfA(CE+(esa!"]᷼(*[I RS$Ql8ư 28ENsnk.i63;="3B  S+}dģ圔{]9q.BT̝܅ pq k!t6/BJB(KH Rfe%'&eK<ҍnn|ΓKB?JUR%G$!apeLlPK˓ e$Z+ld,"&r[Js&>aG4 b H8V ffcB_aIt 6DWMorj-1;;9#0Mbn7ũIWyQ 9lr3 i85zԓ./,0㴊'PuNwroS 󧫧EA:JIC,"zh?*Lmю([`95>;nu 4Ollf^ybtv5%KC=75;MD\9"=ICc}?/#(~xqӠ)Jp]& Ԍ&UЁ@]y]wggimרQFG I 6=KYZͯD S÷L>AdL]Uuё>Ut5r3=;pɓW3z\ȝ8A @X"/4$3 2 Wq֔  TAw6Bȶnd0dclW b A 毰ߌ Jy"I\&K>Ŗxу ":XZ?&鉔$wXBCD͌n 9{z0oAzꌊ3 vп΃ze>|*1&7iϾ}:MS\s衬3}}흽G\3v6x?րՎE_5_)޲[5WצDm}i&5w(6]MMgɲ\T(9R岇,rj`ue4f#"$oct]?Ώ̴P_] ghpp~7[=y+cc|޳z0EK հza'F ı=rϧgSqḣeǍc1;_rZF+nZ&+~#R,+pGԝb ViQR)v.+--W=w`VA 8<$.8@vwѽ߁3Mq#~ji4Y1hkj[ǟZ]Gu@sQk5rf+o?endstream endobj 90 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6036 >> stream xX TS־**^V]֩֡֡#(f !@@vyYU8Zo$ }YYs9WDYD"j''Yl֤u>ߦ #E¨~»qpwGw!;bE`-ڲsc+?A[l( h4hL0uʔi&vE9,3@ s8i0NwgA&uuusvuYcϐE%!KCʝVGy:E{v[!50h14g|g=g}8mm&DQΔ 5ZKQcʕHm6S-bjZBMܨG2j ZAQtjrPC)wʖP۩wK ~=eAFRV(]JLqTj5KYSy`jeC-&Π,) uF4M֏OYY޷cuvsLQ|0r`/[ trWLr}P7lGVIHNcN+f؃>;OJ-#D#6x9rH#ŏZ0J Gzgb.9&4rPs;yYۢ9]|:FPŝ;# ]XM'h!-a. uuuMxrr]Ջ>72Yd3gl&6xd,@6,cE9~o\rʑ m ݅τH" Ixoh4U>b2>=td Ueױ2B7$]UR)(MzDl=['˭хx a7llUpSyF m1gkh3l"r}&>*<[ ي!'y\7mZri]H'nN7^Fl <-ל<O"-=an\Xrݴ4?5RFxlWC&K,ׇmoQHȖư"}vf̃V:.UVk$DOX򍑟I{9ﲭMX=E=,?oKz0xV\Pr{d(MEYu)PN6GCh w /WIJC NLH<~,jEi^iߘInΙX%#b5-ߛ]2ps0%Q{ ?(t̜79T)tzՐ{3pAP:nGbZ[{'8֖@dgfA%ӛoP3 ADl:GKTG\ 'ˮ?:z0d]NW_ Lmyy1#.{Q[. !p) 8A!n0.ki_Or+4] ]|61] 8Hct>0űqO^щ3rsa/hKvF5{CýT08Cf/7#=(, gJ? 7wՐh1B=ѝrNK0E#m[YB_HDZQYd P^<cGJ 1чLV}e.=_uj?tP=ƔoRh7Y$ĴEUG2K@ৣObbлTwt>1^FQ] d'Bu s+ 1?a8Ȇ/;hı'|4ŹtكKph[m ):g@%$|yN)BrVW֢ò؍na0+Ǟ .c=h-pKyKd!GrJ4,Pϛe9ac՛XԉE8}KW*))4!#/\>yml78}DHPakwrR<_`&-\4MZPkU!;+dwu53Wg$Au}>![BK$T"R9Fm#0?nߤ+R u! *+#7{4I̭sF 5~,$!} VfDC(6smhh7Iɇ("=M Ǡh ߧbFV47 >!?|mqVƜSF?tS+^J@S`..9=+))I(|SG Q#7<*ztI7d01Nk{}f ߛHL31h8VcI{׼Ñ%zF Gna8}h̵nݺ66r$J"n2]Get1AsMpL}$a Oe"9d 6B$|L<%06%G#N5ͅntLq%Қ8֣JJ$7X㻩B>m f7SWH F[~{TGB73϶uwl}O!簂>{Y>WzUA63^b_Iה4T$d%e%G֐ڰmRWgOcDPcCV)qO\%ag°&+SÀ"֥dI%7 [PCOfbI[jj)|t8"T&VMG6m>[ !-f9gߛ[!+.ڷ&go^R\L`nivy!Q){FI Gn^eF|jZfڃ.-}"$,\7uh(ӫ(=bKT%њDSEB<Ɉ.WVcexgK rr2ȅU~lyD 6Dkj.v-(¢.RK@x!zE$rt(ND`H&8=C} s v~m)748FGnw\|րd}5+I(ϛr{@,B !K32r ;H#{ty\fyn*>u\]jj eyH,{% dz!P,[PI3N,&1D{2GE-in |goƒhKG .eYiZ*龌X%BXIye_g=;lpa].AWkIGtg; &[2 .M\]z1<3Zvuy'p>l/i챔4/u>wvo q+rٜd\qB" bOdMvpAt-+9U`_jCҿ7&ߺ s0̢8L$FX=Y;[p`ܩSI%Sgg@ #QWEW˕Aۚ\F&R6q3b׮=k%Βx! cvGڝ@b#p%%o9 F wPS|3- z׮G! -kUqaVW%*Ce>x}ܞ]y(_ ?9<7pQBP C6/ :  GwZy<8,q> >h^Ѕ7R|mF3Y./pB_ynǡY$s13N_m4z*iGWN2cW,5,Я$՘+oYW0$E*71g7|#=o;)63G縳(y 7MZDM%7no\ʍJNՂR͈-]޺X$"UyNFZZɡ) Oavm>ytC:rTHRJ#_G}$Ic|CU_{?[!GӜr!)WڤatIAJF,9!@vn.͉wG}Ǝ5&\WJ"ҟ塗煉lUdQT62x% ԥ9yM_] :Ȳ',Ch@nuVKLOMוf[[Ver:zEHendstream endobj 91 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5171 >> stream xXitTUEJbzoA@Eph 9$$!PjJMIjLvTjLR* @P@hKV۶ε/?ީ!ݯ}^jUN﷿o?xlܴIT ZdҔR>{8(duU?0se~ DGAq9}5F;!xE̬ҸeK@Cb>FVjL `CAءF^zQn榑(LA\ &JP_gkqO6K ~g9T@C8fg[qdQ8F*b/W^ o`N( <(=MFHUF% 1!m]GzF TI>CKCQ\55@0 ]ФLPAew\!3=ps3$tH0]Sԟt(Sf3ePCV_Ӓ̪ܹ_n>Ku ǩx R:p5% $&$8`QQNbg09%A + a;|:6w MiccIdRiT (2jF*uE:Ͻ/>lmwM`u6=mq*'DnmtBK;^1V˘YZq&sy>h y[~2<F O ^]_\mUkVqCӱ[~a橌]#49kt>?P]YeuNvd,L[g^E"HcAtﳭ<ݯ`ÙtHAH(B45ݺmM5 Sw,ugkJy5^EAӴK2H{@ k5L;ut olhsdLU  5WThz4gν.>vF5%9ͲJ6ccܽ[C> -6gdfdޝ ʨrGYGvҁ֎Z^oR6+Tи+޾/+ct4d:hT:4saӁa=r"&L^j]s]YPݿ;V"ٚ'|?6TwsYs( .#|D]4I\2]~-W S+^UcMpN"~XɒΡdQO@}^\q{M2eW>^؃KwMr+ Ԁ+WY һ>p~gE^sqGFPZ_eG7!?E<ŔAs-"]JD Y-{l2&Ns tN\>,.vۘ&WF:/78> [ zZ7jrx T@9YVS+, Ky/'мߝn/'8j:vA4} ր[AWXc@@+w1PSԁ~]*NbϦŪ2_'0vs4c~-86#$1[ J6sO8oiu/bz847;C*V-ix*kkA/-}8Cn&Dz@-4U(4VV\AmҁTD? ]tl\2 ~TCç6=6Q)[=U؆Qz?`̈́w]o_x0CYuɤP|* ηK%)^޷T&\Ggg"J{M=L ؠP]2s@8c5)rA2zt~.,ob0o8tČO4ȗL2`Ӹ3p ,/HЍ qfY/ ?&>gT1k#{G)K*P?wlmfם' rn '~mwhz,zQ-nM|֡ h/e&] " @ ufj)Z^0(Ui堦4E{3@?xs)ᝮl#muD/' Z!h,sez1ɚ=){!-s Shƍ=R9Umu~M}@]L['nلY-\]烠jZ8T##꣸as be޿Nqtb/>pVfst/^jpfH&TBnA;x>FÖ{~Av`Z?4a4/|ޯ=vGv0bI~!u~WtU&=-Irfݏ-#> 5sGBO n|0pH)xۻss$Gpg`H @xdCVVsd7@jFPY48owH/La`^9hHp8~GWy߰eQ٘H Tk5&9="ɆrIFb3{҃ U$e~BQlIzRybbV;wSF[S[Ѝ #8n9xv;͊([smBuqfk d$]߳nM}Y|fvΫu .VTjѧfŇ'm)++ XT.U t%3# N`L4+  S$>VZ3YZW h?GZ]C#b-wF!e\vM"L= ڟ. ꡧױYLMDO ѓ}ȟ\GG3jDO&kSendstream endobj 92 0 obj << /Filter /FlateDecode /Length 2302 >> stream x[KsW0NTVƢFTfsrHXD{2{oO,=cJ "%PP>ɷ?bub5uݏEXl?]LXTq};/B%Ph/7^ |(Sn wSB_Z&\ pw,wgo]JE^JJ(U>+te{} kkh)?Z%in orqz-c(z/C޷'b+xO Dvz /yݥ)OD-hԱQ]X"%zr;Db+nc[@厮 Lg-% 0h\Jt/X¨whO^j1W}]-9L:ݲ^wύ&-Swnʯy1sѻ)7w?. mn_/y6zvh0UbxhllYUZ, šV&(AA)«tTƭ= '^!ZsZnW ˠi^,r@4O՚vU=w:? b}nצMk2[+迂N&WRP"MD~}AbzC=U{nW0UKuؿqif5ếCAg 'TnY61Hx_7jyWJYbd4$+O|_I!5S %4mum/VׇdhPc> E&n:usc!LRސ2˜COb|`QgKPA%fDd{OSI|NvI5bq;9*z P.zMZ0mbD ;]czqF`p'{ԖFm 8Ŀ>U@(P$5VSBdnRC3<#P:heDCQLPD3x/"ԛ r\(.\(6௮y#ep[ VLcj38|@d<0$ E)[Yiv(;B:l?;IS%{hnz mZE aNn_|%]3e>}NIKhEBK&1PŁpCh9Tƫ()QGkRPFnH#J&@|1dZ<,vlje~='4c ū{dU&eBJu0uӳFzj/`g7%(L#NP3^՛@$F!};2;*5 9f(j42o4D>>qZ G<2z)]xg@1> 9 `p[0$ Lpr.Rd.tpdS/O͡>"l|k(ǭ-ߪp<^%cp_s  /wўٗnل>xR:c3dgFwbu}^!@ιU>bӄvr'elpƉ Uѻ)#mGx1/iv2ϊyopHJb*NߛZt0ɀAbJEl.09=̺;L"LDPYޣ{@T̅jO/1ּvb? 0c1dx6d0wkh_xcKW1l/v c!?D?4zeʤh AF+BOd(czϘW ӧ+.>V= \ux6YO~yuoK-d1HCɛ&cPwUԖR 5IwZ<&C ,:6aarǛnw%CY˪ J_DqLb+F&T{|ƝA4q" u26YBzCհv̞ ` ֵK}-FmeЬ{>3KЂy&KKTRS}%UXWͶZJw>6v NE]u8!M@*WDxS &.05O[\\݁@JVI&Z0h:^1ɣc:q/mi DeްpJx f(Mcr] dKG4tЌy9Ee2 br 2̬N"qQWr栵k@?rbCg&> stream x[IsW0TŇdj*U$Mʁhi-rߞ@ip)-3H?Omζg2}{x #g$ BHD,ϖy1:?o C 9\p./4R敿eB"?^}tw1~~+0DЭKe)^p_ǒ4|bv n|}YG1JH;ש}:Zh#RU@PM?\'R6m DX8"M,X$ ޲cxF[ m[)fJT;Ș7\M!IG)DB'g8dd{& \3mH~߁̕PRR-WنN(䐶b>%ڗ .{s|H~)t3(W `GUpygP5543QA(b eQ)%uiKx>%/ޕ3 `,efRGk@D@T|,ho8B C[e} c8X$8f# ScF 'X4 f0cJyteɯf$)V~J{T\5eaSH@\sRu}l|ܘ7M=!󬎗Zx6&$I><<(%H:a_CS W9/Y`Hһ]᱄qN`?iqզsߵ鰆j3fvN,A>[,^rܙ#I0qoʦr=zS$Hl4_`X0}N+)s%/!^4!#j'YS) K%/E6N7}ʆ`17F5)׊bf xْW+[ `8)'5kܞv*D̶Í7ծ1Ť*ݝ72ؐ,i zBӮ|Cv~KDZL-]2lgq!@H(c%" k_a"\dBQj'_vڮz;C1 X  H;[)C [:X"U$ Ic%I9=2渿t\r%Hrl*RxwGhFMmAt>2ju S୏* *N}Q@t"ҕkN!%$[vC7e\.a(i=H5HPpx KN˶> stream xZ[۶~<ȭN\PHo>(֫w(QfE#@f3P uu]}8v Y?oq%V1!aHU'.7e8Tn.F>U*-K#dz޷O)i9P0*=34i? pZLXt鎊HD0~$]\}0ݓR#&0$pۦ1 jn%K]68۾H_m$xdn  L5tQCI D۸. <TapyIdD3Dlb7jWG õ}?+t1cT$_5J hĔVf:s^?Mg2 \YԖ-XaQw`wT{Rɸefͭe'ZTs).EBz,' LeƟD' 4wJ1•50`RD5H"uqt$%DH;VqDSJM|^Q._f™9<]Yg4ˆ BYvB)uQc'_ HMjtthМzA˓VY /b]g] mOcܶbep9 8oYNۈ&@i T1yw?hь#δ-6ԑ ^4Y9 "Q<ЧAψsGn12B=Z-7'-ހ`DGnQʹD)/qt{WzD`_oBL(Dm}G"׹ײ d7<"Ggʂm&Ԕ:R\ TɁ߶2/tcT,#@RNN`73r/x_bx#&BCɫiI)*k:NF8gr*Dӥ韃)DٔkF-盛 &(0g Cs,ݟ7zh\m]ө^ç !\Qw*;~M@ƙ(sEڝDp-clw ms{\|5]#"ܙ`xįh3G4]3]c/~ߛpWuFgj8'B:P|&AU 0gڣ]/h ޖpL%b|[BLp:\\]>+×}AD(x_$Fwp+] ݷ̱ARpƁ'[ l,\voںEUFe Am|[Nep8~? ppendstream endobj 95 0 obj << /Filter /FlateDecode /Length 2174 >> stream xZK6W"n7%\ A艹Ɩ5I߷(Q=Mwf4h˲TWUcJ`Lݟ\lG?zD?b;/`rlULWF3m U,<(& g7Be8YwVY.%^!p;KȶI cB.05@i"ޯuR,4*b-أ! l-@e -ȚP,O3_Ga#v%UDD1%R¸*F% _|v< DQ ¤qޒI6y[-rlnO qs~=Ma>O"riӺ)3 tz^6̍&FgwqU[dYz7xHӴՄ;ߞ<'Q Ѫ;S…7x?jKv)z( Я̈7Ce P (OHit(uHVV"9DK}.yONȇ2OX:*Κ/<2Gpyoi60H anfPy Uy_fF[ZDbP)e}NiY{ۡ:}6+* jgEoKJ C-pMZԐisCr{XCbqC{ Tcvlӯ r2AF;DZD^bWl8<1{:dvhĖ{![t6`:4%j<.1ki[d!ׇbQ^|LhU6M['Ne_.dhlrbһThJun:[[bbWuQ ux-Z,r7o(՛hٍNH?l0[r9R_,L0.F$,q:(C'"_Q:ξ-n4%$FۢL-yOqN{7UW\ fƦ_݅N9Jn(* ~ō-VD olql7$i`סˇw*›e%qkϦ6ШM/GAu T%lX~<6W5S,oq}BwAc[7÷2(uDrsѲ*29~ph||(82 v'cМPYN )+u<,uIqW~>틅DF\rԂB4(/,?A+#;Fx]McӅ8< MvŗU^7$?=~A%M#ng]T (c&[nk(XJb?eFZf5Uڅ zH`a59͍*>*,A!XU=Դ~rC.ˋa-m cu*Of;0oRú:Xw|ŧ5L9.dm199O,bh0.,x[6?$endstream endobj 96 0 obj << /Filter /FlateDecode /Length 2341 >> stream xZn+ABtOA MI^J\QcO5٭n٤=z`HXtؿf ?nf?[e g_gun"3H*l!ɨ2)#n2/7nR acA㳻9eNvá2!',!ܻbf~#0D)~B\BE~ g#sNJzN娬ʪ 4gN1JHx38`a>G!2 ?g1|?g2H|2 <!)3R ڶ ʙ=6u t_4~7OΟbWbB`09Z:E,'GDFYW'#)@D1Dzb҂ Ɩy%&5:LzLܬ2 )x*H .:` \ڨ#QYm"jeac,J;'=:U("ͽ;׍BFC`׫d5lѮX>.(J$'Om$-C"^_E 8T? pF{Z8:e LѾz)1P0[\`eG)հ'pA1I ݘCPBo<57 HJ DIhK7%H PgH*̼+*pen3T% Bɨt$Bђ@pX2=ftfmx n14Ѯt$?lsϒ8ٻơMvLD)C^Flۆdlmh|kMM-jW={3>/8 -V"_`/Ȳ!}M#!a h}AnmiV[,0/ `v J]A0#eHQi kɗB?+6 ȻyܝR5~2.J (mxc<[`A[3$^V]su=i!A I"4m\~w"8{(qTPxؑ )Ha ^<ÜS2qB)Nf f.B ],bb %'i{Zȑ Š H+P}S1o머:9@;8RB$_"/X|El|K ɸ:1FV` ~婣?5vos8@'#H\7͡{p$~Y.KoCvю.?!Z |FEA*,$mwNHNZR޵|T},CW[Zzq0C[+F#km09/h|0F%:uL"ʼxH2jq'05h/|<1.+=񠝩ﻘ>@C|q( n3H$ӓH |y¡>x[}8ޡ )e< nv@cO 4|;q|-މ6  LqŖb_ X2|<#[[oqP\IòӞas(c΀$@SrdF ADMMd(*$#*^aE3v&n|8 ڂQVOAv$o|2i+}[6+6yA^TZ-gw8A xdzCD;M`0A^\f,c6Ld2e0v> stream xZMo#W(\.rm߬9HmVK=)JvU,>VS`L~>>}>iYmz0E ȩfrWճ9nvqE~y@)S}.CoLCvxtsUmf73T/y vA0\p_gJG,#G"V`VkYc@ CPGِ= dCC#ްH*_/v+abOY3);Lk3(9 ]G|Q.xKn;)=ŗQ9`}ݭn"BG܄C,RzYa簜͏'xNpHg@XtEep x8}5W r&U4swFyr^^D</5@Pm1AjP(T9q,P M>|Tw `|^rmG0+É `}YōRqKWȉ3n}_5N b`Kg6.6@qfS/,@LPIInPS$j x xєE:an4N#<NBj&hEU0u#;2zfHHQ#WjYyoB=darQ(g ӎz);BEΎ_$v{nICU{߮C국S.j+mSTJS{7aT!G8sjQ]8[=yt„52U9)]-g49 jߔv"K% S,yZ0i2jr(M԰}S 'CLq3`DSj 3+yye$JT)BOPfz` j=K<c$gX y1Ooݺ5[5)͊6|?f=daWn ;*'ǺʢZzh\j*py=# 6=k>J5X>|ANMxTK 4} nȋqua 0*}cӦش=D&_B"M^2XU|e-T|&9WU%1ITڧk>Jt3qYeJ|WD;ed Ds+v+R\/O?SG4պ;4 ʔK3҂ o\ݑh9>x%"Hg!'AMIq ~8Ç6 X% 7~Xi-J4⿭B!fGZEeu>AIfMwEa‰-gA6l湟C[,(GZFQ8;Gb 8Z7-s> 9e1nÅ )?IK ;BYa' V1/'ox, ؉endstream endobj 98 0 obj << /Filter /FlateDecode /Length 2019 >> stream xZM۸W9P A%{æv39@K1cQ%9ޝK~{" B6屭VjĢn?3_]׳jg{0"̅U zgVsθl8"](Pd/vdUTߕZ:ۏ> w9WY՜qp&{NG8 Bgx7P߷6WH-&~ ol=1LLdO'ˉ!'f&&{?>lW}"^w9,~it 'Ŵ[ cg,Sv0oÌ3伟:d a% wFSz/R<y).y{(n "4m?W٦芛pҤiEf,k=weY%nOE;i0KIjP^'`9g=0퉷k?mo"X9^Zm#g0 $Kkq rbR1T@H,#/ ,!p!D]%prO pq-55uܚ;T&Agk' kgdo& o1Q:~Ә K`#! Bԉݻ?mW<(OL.SG~^2GA x!Ҭ, Kc qATIpC4:3:rJiNp$.R,-f<뮍Fi[=&m,QPP NbNmL='N<,Q-JF FFvWNGC#ߛ|:bWem קoBu|^SL4>I,. Ğ"R@\[7OEg6@}@F(6vAy$֞b͇3R b}5YR<ņ_ISjWlo*k>{7QtVlg7) 2 s!]E%YQLڊb[XUu]=c ARjoQM8 qk;$Zyʿ"!|rd}e^8@jCHpw5xF'Roh }Tc]_D[ ;nP 6p1B e7!@Laj⢳ bZnOr^EX,0h*RZM0W70b~5djnVICb2D M O*`2V5A%jS q̜E2cpNx'=3p䍅1GJxɧk-ўgwx]˯^qDO\p"X"']5n.Yk1Q.n$u-a B:!h1Küb #/endstream endobj 99 0 obj << /Filter /FlateDecode /Length 1327 >> stream xYn6+g ԛE. .Bpԍ}lZbDZL b 3R"t[^ Q^ <.mӜ4h_RZHo󪞜)~WLΐ@-ӻRܷCoL ]Қme{WUm'gZ@g.J]5DI~t^zk`kI8~Ӄ]$dI.x<q 5y^Ή*xR}i0`9XPD5UqYԊ2L+#FFHU RI'Zexۨ p(` pSY@%mKDZ,٢`bi1C,{L,yXՏgaCQW͗}S_U]O/ꦞ_~߬v_Ņʁx : /xȓpb `+f"E#b CGxldf}s=SN AL,.wi\rI<ݦ^^NYp/B@s/C(N_)~wa9>uTv-cAxp:o]i2|SV30eOv:b"xRK_CjFqWWb.FZZIj)^s!A>4fPLOzVJXb Vw >{"Rk섮xAIS/p'ZrвmR-w܍MzcbDnv믋߯.'p+NΩWWQk&ڮ;!xouy[4y<5CqF]K kjH'p/wa:׈L椲խ#DC'/7) _r @W~в,\nXJHӋLߔ46SL(3cH)੤ |+܏zӲF A+ѹJ/@68HI_A!ĺ'SC\%CtE}ّ-浙7ዻ 8SAx's`xk&&HBj=GwK$G%>\J_:rB> +0~P/q,(HdK iopRBL; A/r)l {mjx?ץsr]T")> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 101 /ID [<26e1bfc74eed422680e2559263f25be8>] >> stream xcb&F~0 $8J?ϩ@6VPq22 E̾ "7HR0DL@$S9| "߀HVK)fo@h/wf_"y cl !c endstream endobj startxref 74356 %%EOF mets/inst/doc/binomial-family.pdf0000644000176200001440000016071313623061750016523 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 2379 /Filter /FlateDecode /N 53 /First 407 >> stream xZYs8~_V*rڊ5sLM偖`YtH*o7d˶vfhtnA€HtDB&DM( RBZ3_' (9H"X"B)HaBd5\8CC8#(.P@T%DD8%#x WPj\؅Fn"X1%Ki?B@) h L T J2M `i0 C rKLI%tFº ANBa"F  K@xgT@BF"1`D %zЁ-I\$ AI#B(p~wc ݇Y:%;;nJ3^^2&/Sct`3h7vYae;We³L|?7R 4U77$ą%/q  % ~aq >z]%G OJAE^eɓ5Ryl~$'/A:yaNcGrtE>ΒDg?pΓbfH֋⩨ӱjQPUnW>/mCeQ#p+bi/x]߽T6.=N`K'Bar,G`k ;/rG&I²H, FM4q+<]dcGgC Tz[lرirV17 C]3BOcRd [WĹu ңG/?>,$ɫz;d>E|(9Lؿ3KvliMrYb\s2)ƸqK&%p'X;[ޗWT\SJ7VPASW]R""jG\o(!e8G$vQrKhbF߼ GP K;zLO鐞sfy< :t:j%L^ѫ+; FgiJ3ӂ. 5g^n2_dfA8]gwS8pA`Β:Ya?5~;$ N~i/OÆ?wyR7Ԟ1h:5]_ @E sp9F--~OM=Bը*Њ$j4]5>]]Ʒ [u-f:tnm#qð.ALy3ktA@,B7,S!G/ a|-b J+Q`ktpPayՒZ!^ !W>!-J\؁^D!>cClp>m'pFmܣ=}OO#J/b6F8GIo 3{Y%sNw}vr1++e'o>%;g MmFʄr7zA_0@IuO޽?gIﻷ{9d2+fLþʳpaV0-GF-Z0fH^K'=RCI`yr fY\e,hw/>kn' tBb]]g)(@#7n3dC :67Ѯ~Z-`>i(5C(g@۲>tit|<4n׻.d/-gf7<~?ZcJ)2cG8'I&Go^d-\2v#$sΖh/Y tJ62 xJs܂*-^Fts5@O`q:i#3B+3 eŁuy/ :QY}L0+xiU|V'zK]=: ?sAJU}uu|'񛐯dʿlVymu1} XAí x%o[O8OGố7M9sΛ:v꞊nN~؝ Vr~KXr/w!@ |TYʦ@d"} ^z(I9fMA_/hOh♦xߡ&6EϚ)5[TFVMAZlSq$HIK 2 ӿ#r4IH}$PrS~lV镤]Xendstream endobj 55 0 obj << /Subtype /XML /Type /Metadata /Length 1645 >> stream GPL Ghostscript 9.27 2020-02-18T23:23:36+01:00 2020-02-18T23:23:36+01:00 Emacs 26.1 (Org mode 9.1.14) Analysis of multivariate binomial data: family analysisKlaus Holst & Thomas Scheike endstream endobj 56 0 obj << /Filter /FlateDecode /Length 1914 >> stream xXnQ_ nFH̃w3E2^<$ߛ"%G66dDN:UaIϢ ~S O1Gф_a nj4i# \0Kr#me}!L0sRgWrTj'Q)Gh8eSWA!?^0*c3yKp$9i\` ]W_G箑KCqV'eDߪCHy <Ͼ _8dyʹbm%ŌPB%4^n "|d1b5i*NI,c)M|x.OR "tJUR4@Sm4g‚j<S՞yhLFŚ C5geHVbxk%hGRX3μa8M!?oEFKrѽ,>kĴD5i!-t뛅X֑ j' +]S:P&˱\5|O3׳. ?Q]Pg@N= ğPH;VAȢdR} MfeugVo Fp +F3tWWJ ;ƵZVuN9#Y[151RLҋ:ny;kw.pU9 $*_+rܖe;eHgd=q*u9){$\AgMY 5&NysG %!s\ .BJyPt'[WaP>s))8G@+_m8Wu9Eʹ6h!Ԇ{ˋ;Rz~ϩ@$KN4< "s骼,;1O[}ovQ.ɱZc/3"̌lu&|LLi{ CHtrߘH0>:kuue3.Zl%0C.P ,o߲'" Zg_5ٺ :š{JSh"n}dYC@@~ Wendstream endobj 57 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4798 >> stream xXyXSgOĄhђfzNIͶV. .,!@6Jl@ U$, ql;3s|9'8tϽ|˻|.RfΠP];s¢$M"aruYb>5Ăb;52UI[@fՂG6LKP0gf_6OmswOd=5F~)'\V"e|+Vp5p21g %ROxq|T qnڳicly"!'KY,p9.O,=)8{?8\DH9"\ K*.OX̑d"\N~srNHp@*KRX$侈!EeI 9W&*8ƬulTIr͑'K$\eқEU)zy\*,ҐzIQR`\ .HV"ɧ&_q~uT*LߕLA@! K&}9dܟ.#LQ(GV% bR.Rf9BE3?EldQ)Rr((SvSr)y5Ŕ|:zJe eYF&f(mTr%e&θ;erm?=IF̲̺ llќ9s =ܮyOͫ~O~FᅮR{: GH4IObޝue4Q*cSmP>#=.-?|Z:D͞ fl@3IvT(뤔J>ǰhAbFiIS4v$PW}m0,5]B5Lo<~]HU v.7@ɂHב_*0K?}z{= M ^NǗr 6sNU]JKdMh*f!W}bjl3FX<+{.gxI v5J ;c m=1n :LQ782]q!߈cí@o!'h{&b!#PYnpt9ȘͻҶ2JՂ{%ȇicS O<&8-N]I:GH^jli2j`&v/ oIM !Tz Z4hZ4m*2p L0;mta.WMN֮Pc[ɘ&Uz:&N'VtL&bxvZՓ֛ ~늌B/x`0[YfZkl*#`8 :N;ر3"}GY@MC_9%5yr֗]M-D܊]/v{:&Gۛvwʣ=Q)b#iu gyp,D/6(O}5?/@ HN }qЃYZkk,{Y+ݮ@X fv5asriE?Xīy=k/>6ii'  NP;Vsx.{]_ ey9G#ȓy;=;:9bk߂oOm-> $ꟍirZi_,6"np N<$jnB޻)6LaʫwOvw:GCr\зg3%#"f_?z{9 _jmk$ވ/WƖԔIE4SR'?I|($b &vy\;lQC`o,asV_ZH l| įW}  9 g]>>q.v##z/&>;MC !f8ug>688n]Hp@/ ZA @k7rR/2ԽfɪDoM""ئ4Y"a x556Ԧk5!{}C_odt/6'\<ȰG3?0,qڹ2F|o&aďM%~J<4>Ez"p5ihOK*՞RvpP 2If΂9I̶ iӌI7|lݯ_b.H EDxXļk--05|w;v/F7j,I+(gk3&(4A5JdK+xⰦpϡnu}d=::I=~u_ $t1f]Z(Vᙒ / @LzJTXWx'f}>zP믯]~\C Wu=Qq`תҢ>2+D]W"ch `g o}+~͝pH==f{^.0*߁a0\}}.b55-I;X}H1%bAoDD$^V]хQ_L5Lg7٪Šыs~jG?_}năϨ86ٕ"5QuXVc'J_[)w+$Ŷ&9,$IθBB@Ӎ? 35-+ryXߠF. FoЈ=MMTD(=f=sP(endstream endobj 58 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 961 >> stream xURmL[U61@*a8I6`r{/n+IJl R5NtqQ2G du~]~1L$wB69s7/MP4Mۼ 1a$^hV 8<޷M`W !0Ƃ$pe |)H*P'" ! B)dADbx"ćXX'uV J!R^AV䐄DGosJ'2"0X 0+O0E_"%Jh 1Mw`ulI͈"_Y"C".p.L'(EQ{j^mP6lUH1""= h=ځ z:y۠Nk`}Tb1Op-goMgn};g> stream xXy\S׶>sZ-iDPCkXApf$IB!@Aerjm;[{[jGZ{^={p}{}koml ˎbqpHViL0ḿ51&fM&z6ݻ;rw€#pW=}MmDIc+FΙ;wZ,9N,Z| $YpDN(EH3яX*JۄB"R(}6fo! ł(T+ J9pi@< T* )DR|`\,˄"4I*12a\H.G" ".X RH*cGå@'E1h- +q"Bv X5f"2X+a4}& gNhL, a'D(ed/ZJ'/I">O'  u<>Sdd\Gr8|>rdaؒ5OZٺq^ xД0?x@DVѶ@?Ϛ=yo_a1lmmfb۰Yvl6^]'{ [maޘ[m|͘ S`F`/b/a1M–"b0"<_r\øV8K}A~Q/y|[NNsDN:8 ^>bƹJ+?swr0k '_˘wJ)SNCFcI@a/)i9i; $5:'CkX18gn24D n4*@%=nB>W+2Sq i 'ڧw<.2gVE7:NB<],gꆦEf-.ߎ@Ո+GOp9ʍ^ָ,b4" |X*U9xZ%pRmU7XY\Pߗp|ŻÝN>D-1L]8[0A4:!LG:(/ V`=ȣZ΍3I"S\iI"Mզr*g:3w[ H6H ؎[ -~ hTLqdAA̎0'bع:FKΖj|@0EZ֢*5pmS1 J1@!:_A 6 i 74I(I6|Ԩop4[sMdhoe\=>R]^.NEɀSS̶O;y1//UCLNk^GAp& bf쵟xNI7$ҽPoq1nx$vSK]?ƼO\9 .dL9tVU}UVJ ;s]9WXq9!cꈢd-X}:@)Tմ $vC<;pg[~InTď6.UmeiǶ]+A3鸙.yA,Cp N!Zs~kxSb&xrb&R7hU@Λ6#OC@c9=sI d3qވ=ʅKkڣ*(*t:KOMT0VWVL3JHyZRe'b=2*vPaJ(O`g7 L!#ق{jA ']a@+! ^'׿3X%Zx"n(ٽMZ3 dp0XtB!FH -IITcŸAP\Wӓv˷75\y]&3^у 7j~x6a|vC1uGCyx s*= ^-Z۠)ͬAº,SE/  HSJdWdUpx${ij0Z5=qڃYG ZB$'uf\0PWz($ےo۝ypOk*mYѪ=oBJ&LI:]8^j_ 7]/]z53 Q) HR.IO (L$~+G` Y1dgur^zFH? .H'ꅔw!)Ȁ<'N>rkL'XV4 vHC[$7w WpA-۷Hga~<)mGg˩1lf)Ҡ= $_}*R%FYG{U2l*aGꕹ}\3` L98b9 ũёSA>x j1dno0SƒD1y)nw|>*͛ RfpRڪ=GkZ\_ J 5AQ [IػS M}M%e uÈ(ueǎ6 vШEIGMTGjm7Nѳigs~Pi$8~J0v= QAP΋ .;Ûcb޶sLF%)q[|HIr?!q/1+Ϣ[tt?_삓SkkeֳMCȱe6xgLQê%Pl45w с=o4)o8[ǃ~|f[ `g4b~MƤk{=ϫ(B;`~Kg;G`+wr6["J+=D-Z5>#rPԡA$NNOY/p@yiS_X`0uG^p X4eٵ{u`ے{?yzwE.dVl|ct>Zƾ*~jw>pϰ KS66t7tc7F΍818ev;]s MU@d(yJ^y18Ҁ,FHU2+Q*2A Ȗ -Be3%'9$wNU*^KÕ's9\4ctt #6uـG}Hc2c6#FGjU;̧W7oG{vS,wRR^lT4&JPh+VuϾŠfQ9ƝSC ]~TKe ڹ`;N\8&4p+ tdA]|%Ee(i hTCTH99P} 8L*iY[%6;cR,.fhr"$FW\{p;|IZϕcw,~ƻFt_4.1~:k?ݽk;fnӱ\\|-/RWmx@JND~s_#Me-8T ch6T'YXm.3 ,<#2ԔQC&GIz^cE6*9ڡ)Օ3ԙ Gh1լfY#xphiV3g BOʏ/?iP%ʸ=V.{ϯ߹7P<~G_ܥ7- Ix;McLϫAc Iǜ10p"tȤ11M6kSk*{xʼsߨ(ُ{tTY]i9+>{ߩB 4ء> | 2XsNj$g.\VA̡Ema_C :{Rs{{?A@'p]aO!q;)喍u`X*amؽkDoq#g`,tb?5ms~uX԰Q3YQ^\UсO҈gΤg?4ƒp"WJٙ^qL毿\^1΋vhn˕]ɖy898#Q(?{lD|id|i4= 7endstream endobj 60 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3409 >> stream xUV Tgڞ%%XѺ^ZR]oՂRXE$RB$p 3kEܼ_ nֵj߿u|ozٓsrf<| bBP 1~`6'Lȷihq$瓢'V!-3nɁE- lē*F(N((nM0%ؙIL~)/F͞=ٔlYd-e4[ӌ!!SU $&ڞb̘D=$F&|eڥ+3e3lJd"MF8If0f hLvbʼkc[1ф7&ݘf3c1 حɒh4xbg3x> ࣢6-1ÔngpĨE~fӌ5 4X3e &rMF`rp\|Tz!f$>0&'dF\9+/1/NHO7Z}7mFsTH&: ?3 6\fN~&aJ0{1Ak͞)`ĔBMYM+("!b"'?bbXA 'FU&F BKD95` %,j[]K.'; A̠A n֐!R@aOH|Gp(n[ƈt4W1@o EDſ6ev)> DK{ Ҷ PHro)@UWոP_ 9!n$ƏF~y|zv~~w N.Ow:i roE u3!=9.'phT~9%t9/4p@hn6U($Ҙo:{tǮ\J>o3=8`^JNljn+8Rݹ9B?]t7fϬT}kKIANÓmY RtO{L8~:锯ݰjWrUmU-8l,Ew, H}i-WuTpAj?d 9X4 =hj`5ާ1FΝՄ^աwHUv> B.vXRrP6K>E ZҠgn:[)f^'JXNZ3 I%% Ek]Ux(jmGh{k}leX_՞>z.XD:^P!Yq !*z]D]+f5B_xw.c|Cdy}tWY'.{q"DQ_UYUWn*۞2ǪLB-'40`! J:z"ȵjsc*_cǜNNR˦X 3s̹87®i{p[BoJt+y/Pb0Y+4 \Oص;pmzѼ[b,{Ԁte]#РhQδ$Uۏf.- $u&]aI&?µ֜uNhp^f(GKpxf4=gV_[_2c%1`]{Ncs_sbE[rjJc*N~UN)u( /,1y^b+YV`4WjqgY H1$/ E Hѳ Hw"Qө"fû-Ё[JTMOȫ?7.K9SzGb~^@s9V &[|ɂh/ޢ@o)jJ^qpR kl M^n8^5B[  -u۩liHTE\~x@o^UVY/[}۽ڱҫ`;_'Y,-)~NQ/>"i‹)q%v5'kJ6FĽhW#нcg(.륡'zJsJOkK~I8ykcڏ|| _51raԚELo[-9|7h5o&a$}uPqn Y84 "~sS)# XKr"G.::S,uS&,R(] "."MH^R^84z8iT!̕w=R-| |=~unB Xe[*U 36$іn.ܲ$%ϋWfN؃Qtjn+'t7S79>׎ACIhϿqeڴF霅 - Zrޖ.-Kޙ2 WPS߼T5+>ʭC?C܏"QzI"JS踴 *Q{hޔře4:6jHF"_hO$)v=|{c! 4`nU t̘3/ws\|ٙz7|K{օ0,K-oEm7)7?CX'?7)Hz͉RD^xixm"LÞԚ8@qw^zԹtFT6 9d_E@ͪW(/Mendstream endobj 61 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 450 >> stream xRAkSAMLГF(^m1 !>"7{.mA!ԋ5ě xWDzYfjq"%ݽeZf7xqR4V&xR4n?ܫ"6V&Q9_/_/Ջ|'l֭6cKN݆~#prwB6CT/2OWOz Rdڂ\\ *%OZʃ:ÀX;KCP-zK]GT'r R<R3Rn2-|D7-Z#z^uOޡZaaBi񿩥IgcgL ՍZ1/ύǻ7g˧kwQ4ONHendstream endobj 62 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6951 >> stream xx \Sͭm\ťjjj⮠R}5lav^jmZƥU_D_?3w2sb:'y\nah aa( G ]K ]0vUCY[~2fFpCa0JdaWcpHtO3ޝ6omt7H[N흃#ɤAR/`/m[6-wde ޚE9- v YQK#5A-S;; jIfQw5lj-5ZGG9Qs)gj5\)zMIHʖD(ʒMYQ45(ר jeM QCr&"Kc>  (YT-FYuJG|0"sFl.QG=ut1h&qu<>~}q3ƅ3:X ihɑBHj"_*;#P @1([U"?TJW?Yt Wx)H0Kv(yy̋c[묵Q:!(scHJ-e:V@*nwӈ^oL,4ElOfͨ)+yiZ8H 36 OǏa88_2iӕw/\rºٜa$97+<P\ '"q0/?OQAmELa 5ӕޑܞ{Jm+J(w8L SplrY?aˏc9ɡ$o}o;}1G_T 29O?$'[ Wp|8}SHhIClƵb Zhw/6SuF͛Olfe9bj*NЂN;H%/ n2Oh>Շ 4 F,w ZeXA<f_ia#8l$^yPף3oyb"to}z_P1mz&<-!5s@"Lg  h- QK+O/ BElJ n-Tq΢jEo_d6LiAAq JA!4kodO$Iz8G {j/y㹮7b\9T`cGp<Ń'x^Ol g5WVލOķsŬ}m9kHx[w7-0Br %&&eq"Ae$\(dzo3(,`!O7EcJ}텯_%ɋ+3NZc I{9yE6΅tU5pCPn=*}͜ $?l5A r~޿&FnHvFrZ4"![/ߟÌɖ:z||nUgJeh"HQ AHmw+ i"X\<д wXe qI>I+BR-lNfRF,EN)DicTN*A9%e= wU%UjnωBw53IIܢVduNR5؏&E!U-UM%9TRiU1PM\ryjHj2NnjԳ# 9 bXMgV m=09YhJi< f&XTDToB+[UtcR<ϰ2؀`[L[C^| F^&O,ES پ,:i%Oy_:H@ԠZ}j Ⱥf/9t>_g30ؼLH{6GȾ!l UTh@hb:5,40ٶLuU0_NˎJ2ɗVT!2B?H (Q&CLHdt x}ƥ: +P˶+)*DZ~ODPژBB“-"3+WgPrvPMLbZjnL@x̽Oa&-Z\{I"ST('čMFxm#QJO IݟVоv&7+5hBjdz^dO^TsԉEWp(Na~Tr4EU_Iu/SbJQصh?S/f=$%|,Z~eGţP8@r2id}}/]eVob\'.EȎ]\Ⅼ ؋`&$eE$qv$h[ QX|%xDz:أ?4 .˾:Gu3f^@T]&;Gø&փsmJF䐴=q{T;=$IEⓚs;IX -G[$DJZrz䋹(v\rnb,Y2ۿا&gSQ($$a?Ot1]K~~> T- a IT+ZڵmbRdU籓C[9ھOv}}dV_$n9vUeGu<ܣ?%zA=hF* W__PjF.F59([7)ܾ(+1T q'ڍG)Rܮ&$V*5Y*9bB!L8eVx3t/[y]CYtDٚ(v.-AL3PN5Qekē&fP w:])^hx"9 OmbbJ" ?y+kZy9îp8~Q/rx kO*`~.؝,%t j@-uQ`X4|{?$n.3~jNW> .5Ϥj7-f6>a* Ň_͞[,\4˥ճ0?7Z̡$%e!(ٺgeUeU{(̊MTI;M:E3i''PH <%b,DX$  $eAR坟X :]]@_I8H;I~D:[;Ce]baXlkW?Z&,za QEƌ  `ijZL3I3&2&3v]o~ V tdZ\Anw#̘ߧ'puO9$6ʪ4~O> = 0,#2YdcN+c*%2 :xqAіssELAr%_ȑuM55My `.zƥ{Aacx_.۱aӌ脔V";6?9 QuA1o0G pWRW$.N* G)(5/8"ڗ1LNSS) 4(/8":"嶠l_KX!s0:! p5RxNH.0/ǑXMGHwpz3!ļ_5d^*4>i{t{w$C %],"f/%)}x\-Amy9\ios؊uKV羭3)Р2fRƱqs_ }vDߠ9{)`Dcz֏RS*K7P5L+NNKMK@ {82fo癩x K8 |±WgIuqt?}~r\sTw_ߦSʣHem)X 9ȥ1x%D$hWs'u?v;Cn^om-,PƄf-l&h9@ %ƪsսսǐfmb̟ "/M:1}iꍋGM{0F̀vɶͻ8a9~|>(Y2c]:ګx[VA pho \Jr <<2XÕ=de׫ X_xw\ٵ:Uc},NC%"ABJlyMl5a>Ef}D^>.1#$/cP!.00J_#RuϹ%q^w.5J1bO޽ x7BPvI%p ୎ńW!YIE~Y ,WKDB|@`ʕN"Oi'*̘i(milJ[=٫x 跙o1wa4́F{GC8|Os/%|<ҭH_J{ RkSӒHƄțj5=!r`CA %-@߁! ,*נr16Hnj b9/2]Sk6J6n#}TcJX7T\w93M8>4"%Х,k+ɎG8'yvesөOzpQz#ˢCQqǢ4jwC~Uq.~[S>{.Imxйs:C(슊HI?UU_TnlѪJ_˅HslҪޗ|+m Vk P]]TyTbZ2÷Gr"E!FY7mi:(Ke[UU^"6ݸ~âC!NNVxu"~:0j!EINxҗCN_A Ԋ9QW| m-V9wMJKHALtylE# FJ1) ^"**6ܦ86U)J$ BEyBTmp U$ෟ-tʻvX~h%%($Wn<  VjW"2 ~˨F'( Sni}VuhazJ"#EQL]+o DrHp *K)L(|$TFyq\rVV|&50V 2y\| ) 2.N*/Iդl9!UwHhMbYJ~<В2M ͍q٤ە7c7Oiۍ%fov0u:R[:sE6ހ '$ 性_J9c^܀xezEjOǑ{|U\.^* OΈJELLyL_π{F $V_xH~[ibיT:LO53yP}E]..f"^3cwB|J)qjD?6ZR[,#llnl7)S228K]xQnI ~RX*Z;P7h95d=IE>ٹjuuGIJ]RUփ)>?rendstream endobj 63 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5171 >> stream xX TS־1psUT${yuSk:(ND$ !@Œ yǀL⌕*VogkժYuZI@rqr=o{GDYD"ZggB9g}= #EQ8\8z5dɢQju 6bxe'X ECf[J,m.U"}:N:u9{#LqtԄ:Qx9:MqN!_:W*z ;*厛:m\a .n?^R5G\  Ui]Ew[@TQ3gΚc>7'N1yGBRcj#r6S[jLmQ˩Tj%ZM9Qǔ3JyPvIGd0ʞS#55P,՟@ >lAj05)+*:+!:܏,/ΰZ!kmEӧ%rI3i?(mn6a߇x yhn{s袡vt{sdde.6XNU^ Ă/ !ɿ`kl=y<Ŷ/& +d%egɦ,YW~t 5.&W&f%BP } ̴9BcЇ߿a<-҃k V*')?+}1ZвFW`0,UxG!{dK`MnĮmYǞH+}y(:Cޖ`y G"N/_ ;nN,zp!wbWd{_EMvo5)I܅tT `zUl!Nc'a;hUoCGNkb$'rZ>{Ao`Q;W8x. L/ґw{28LjA%-iY>W xg,xx?ƣ!ht/E=Lh]sW1J/1VyVm&(8変xȓ j;QrpDgDe&sp1v[zwdN1귾;r2$D58,TһBT/C_=};" +c ċGwłW7QfPC6XX5/FWa8ex$MlC#ڞTs Υ˾|Kvd-bu&TB.:쌝T>^Bhmg`% 2TY:2o+8SACL[X.̻G69 3n&c\X^:P.?E߾?Ȧ*ZWK뮜6_M_9<2dFu]rVYKf KCxm\ !eNcf_?x-(elDCB!֜4P鐟c57tZ2P H($uNX$s۽{'::N8sn7w,<c'ZIg;'HtKwRJ`*Z_KۨZewIt}*}k܁1fIqB.J U*Bꪪzք?b!Ip7>[( R2 }ziUPnt*(&cz4YY7S{h$<uս<?ǬݲyڳYOQî4xW,z޵Au)N}$g[5g36K-TSqJ@Va^6%=~ F>Y#wH|ݩ er DةQ,+rb #Ri"ު"n,8<׺_p2BYB#8O:;d{[McQӅ6YR8F͔@o`ǡƂamʩwV6AK&@Xe*ݠ7t檡sAhJ5D&רo"J5`IpBR||ޣ٬I-CVo_XQSSQ^s /)m2 ̍6^e^`.(2"W3Y8k7 Z~ڇ3eMEPHw h(e#Y$2:11>E)B!3"c5=e<%Ȓ r!=DSL<6U|jȅܮ',$]*ѯtsBajtVc>>R QGf~K^[%\^;eM2O#ܺ =#Pg1R 7e-Ȩ}il0TC9-'4ר܄lR+2;[?ogIk33"*MxFWD-od7l]0o /n]m޴VBdr$!w$o5/WTƆFițakx$ p7kH+XcZyH?YwRB!T@9ȩ9Pm>5Ͷ@ej? =]t#-,e;/ m_)aUW"`i}x~t4$W:=\a;ZbA+ ([~8$yZA,:vȽ;t8YXdBs/YqY^opl;zg YDgnd79 '}=}7.5d,>5wR=jԋ/ߚD$u671g?g,aNꝞ H؟L|fGs/y 7-Äo--ВmLSj؟6U C'X*< Ą7#INyyMF/>j_v|3,o Cw+L}uX1,fGa7ɊÜ$ "+:[Ck>هXI25 #k\.Oxxɍ֬,&#FjFWQb{!=.WfuWL[Z&{$g5;ݙUWwW^5g1aX# /#% ZHD2]iuNi 7KAYcyh~a6)mŹuCĐmcZeHH7s:o32endstream endobj 64 0 obj << /Filter /FlateDecode /Length 2481 >> stream xY[o68BoJR%4-HMmh83jtq$cEHMd'fS#r|pDz/iW8د> Ɵy  (WHJӈA(oHk2&\88h2x`{7؛ǜsT8I`EZvgF1f 08:^B4QOm(OS߮nũT,ʒ m540rܹ 8 #<;>?WRy^^(N#v.«?N3ǣ483+~SJ YM%SH-AT{jv0!"${YFy4hseM2Wؖ\cN~8 XT$1E7x/ {yR%kUc J^~5qRݖ~C=܊%_*㣂ʮ/i$QO-?FW/'&VaaC2nj~We`flu#ڏ3Y v ~k-{usos.j7z x£q:D>ᓠp+~]C6c\.pV'r5̉,4Wѓa|3y>%( .q NU EcR<ωS'nz/V#\bJ1HHB)Gh#H&K}|bCSEmH}H}@))9Kظ"^FANz ]y&WϡϢ9T&h㥣EDnCuof#Fm3P߉xX3L4x@3eiQjR.-(eAFե] QL&p$L%!: TzHsN-ESXso}=V ʏ U7k-7շS_:ݨJ>bsI8'q&l(813L߾47EL0l)VveQJ%jIRU>쇲W對\^vHL'rhۡw~szQ5\g;&9ΗA3shvƀ0=f =}t'M2+x$1tiU֠zi4)i@ 53w Ryj8=shWyӉ'j*{̵ 8"n;3H5{P6ێ%=EzAvD i877[wR ^&63iZbR+XU۱\NB&R3L~?z.V}k RίvZ]'~)yRb,DSȭSi28SHgF3c&g֝\:5 U6o()3^(g։pA{ٜ4ɟ|l!:/J 48ٙnygt{SϬ{⥣^S^Ot5B}[K J0Qt=4ǦP<NCܰ{2J͇Ĩ)Sc hc1x},amم)LղD@`&P4}R ]EeC{4M]@86zBQ}'FeEN0/?MY6Z4Ql#_d[̏c Ya=TX0uxu:}~}P@ γ#y֒ʅt(N2K?X8Na?XmZ!BATS;|<3PߪB/[vT ҫ$#mتor/8WyW꿈lendstream endobj 65 0 obj << /Filter /FlateDecode /Length 2009 >> stream xYKo#_p&; &lIzGY=)`ۭ= T,֛_q~b;˿LvWMXv7}ǬXlod\g7Irn9)D>-31S&RǞXťӚOJ!"wIgQVczB8"uOM>~cR,SbTVUH ^DDB{"K\R}C,7?$. RalnO#1l_Ln5ٴ5/և7_&B\Pi2!(xv(' J,zv De3c˩N&JAɨZ5CI jQ` R̢ZnN5smR!jl׊RY_$bLU,j}ӜZ5?ϴ9jJ ~r:f5Ris?ֽ5F*#ޒeQmT{cWp*``Ux_^}:6׉oSV0K _-6 K }vCi>;yIbi'^ uGW4Lw3g5X;z8_oM"sY,oMh=-;$O= Un`RTB%cD /+ c* K]%| E\˃H-B 2fNdӯ{5gG(Xpn+ch[z_ԅf4 Z JxAyw~ ib4O_E c(B FQn12є>ܙ(ݲ-=SBɁZ cD%D|9[prf?U;+50d/Imǔ 8ӱ.sooāڐ+FweUL|##(4|&/1agCv[ ^?ɕָc8^WHފ$C6N'V/ot aUZl Ua6JcD0Wτ}FIQYC_ozIqh!?颉3k埳bsl=償kz?h8ߴ '+&VrX✈Fsq9>E0.m;$oo,gkžfF7ӿ?|@.췞ȩaӡnCscaEA~ %X)g21]w> stream xW}T[r{b`flZ[VSZ[KZ J P/_> !@J@Җ$mg}xq{3o\eno9ɹoy{~{$b՝;U׮.*<,(Y[ +qRd?3vxhȫK̩,HMԔw_OC} hߏdk/jZV#(-XիgyE2ކ5W + 5;v %̢WTRVxy%{x[;gk~ߗ-VԊąEC%2A'^vcX`c{ Fl یmb۰+ثNlv/R0.5}2'ImɋGSVy8~~%J ^]4xweȒD>XuzckT2'.BorNli@x[trMsNJXе<{cRWjIT%BpZ7uygr;=r^c"+iAz%M:ԛ'].ʮ.: }x'ICw, f?DLh_ +k9wF伦O鏵 wY,*3+aD3ğ*~9؟+Jv iq}8IdWFa$RO7d`M@'qpY0ӡƾ[CCIXCW(C>ŊHFWlyz ԃڡ}@z:MiW h i׼<G H;tzʅtӝOFPKTwޣ?iOh*3Xw3z}&=68-l4 vyw_Op;fitIS/pPr"k3e HV2\@iMȈglyzhl5[ftwT hxH7S4{#H8z>aF?4ib4TRxI& ,*޷\y;sjrAKQN󓅣AGN]bQWO߭.zR/R֟OwvϵҐ*b}P}FR9r--ޣ 5۞ 1K{ќe{3|v@'Fƨi6Q"ʤ w6 鼂ē>u5". ́Ih>}2BưaʀK^{6ٳaK fIiTlپ<+֩ɥs=*h кHM-qӃڌS_ !}8 U2rA4zdA&GlROK9λnZ}o_{cQΔs9"jrg?1u&xQ0DPEғP + SC1RhTmq~p͎I/s mrыF%%2sNWS&CgvmX^Eo +KqL'яjUgsd:">ZZyJpe5TTK7:v>L{hqj:ŜuwA_[ԻwАG[I*2MM MM כ`%f\RȕXa !-pڬv'p0=0mlЗЏ-KČ޶YM9>຾r =s-n$ɉhg d6>af(!~̌IN1w\-apSlz9;W.QF_j.jiiwӈ/g0mlbܒv;zm5E䢔laBH]g^6sӞzl[K9Вz ?Dendstream endobj 67 0 obj << /Filter /FlateDecode /Length 2220 >> stream xYݏBlFoREڴF-{$}dQ{t)j8/89)Do7ٷѾ~ Q9F[!RV_c2i(Vٚ$@: K4% gs!y'+?J p\Jiw~69Η21EN;$ـ粒`^PXHJ y! $nH%J!5odO/, 5!7팼~z9E5c)ΘeA`N38 1CvÐ؂}uLP'5^&Yy*t ڙ|UY7RG?V߬?(q8/@,Jnk;^5V*9^80r,=ɧ,iIdHwZE^P}{io2ɗVhg+4ǎ'nJ(d]6; k9P:q_i x~N!?y"8Ԥ"Жb%~ 19Y^t[%&[٩d<.>-́m)N1xL[f_G! Tj- sV?gy/ol;-%:p,z_$s`׏i>0;~P7o]" #80J?fh_bCx{G񫲺>._;3Lм \7p`.>bfqz.Nmo}ZDD@!iu:ԽbI S+ 6[|Uv?lIt9ID(M8FDe:PzߓKC-39&ju9~!X-Tw30 xJʹth F[ȂEM#ۚ]]rͲ9`bJKGM];87*3|h 3M?_slＺ.UQnPAo\>XDks[wU2}ɨ;Xjԡ)׳g͎^qI,efbm$t mnuBn>2dXON,ʛc((IE>`m6xu# #~8㇢K_FKT+V~ƕ Kt?lL?,!Y۹C@S&bsw NYMĂE~/s{|b (x0ݐ[\h}]+Լvr -Bj% 8oS71nHtP$jt{sZnojsqX5#"\!72 [/ H}9\&-3@f((FWɆ0_ XJk*A Z7192Tsob3 !^BmĠP8U碪}%)8p},ƍ,WMmd k߀] /l.( LkEbv#a x/qTN7aCw/$!JGMl?iiɗjS)8GTbh0G]HhA, ɶo]~ յܙ^v 'ߊf=I:;&륍TƴCxU 7SJr>< UiM4[)Wz#,m4?h9Q'&UmȰUe.j>/<}+0hj&PtD͢C&I>Q6ԭWSNhK1`f/)FqVM(\*r˲,~*=N:5h\0@ ]+4Bn<^(F%CEYAfGo^uaߜ|G?endstream endobj 68 0 obj << /Filter /FlateDecode /Length 2099 >> stream xY]o6_!J/ߤ@Q`(]`ADk7ͿPDJ(` 9$`iW蹜yeBkUD(Ʊb*o&E11ӑѼ,P2`gA=|*!BﾳtX)5MAm/,$yۍ%Dbz/ &(tGǥL~N7 MQ_ AA@O#l}`AA!ȹzbФA m3>i‚01r3_OOSXsBXX2[ⓣ@]`\$L&Є^J"9548 il2iTlvՋ} /+LTi<طthn/iL$ۗo%{ 2ؼqiAp].)l`Z>SBGX4˗H}k_Q$Z7,*B5,C9}Vʤcl5׿&,]| <v;\ݻM`m][ҵGy )).]+"z,?˓FNZJK.#ىQY%xA ItUe綋ٴI^b#+ٮav鱪y=#mZ'E("oWz`FyL_8; lwsլ2{ָ[VLc*atqܬᚦ1` t3h,kmz%͛Up8& ۦޤl7uN |ʶivh{i6[g |K B%V*ẘV;-'@< 8R073JcP/hJ}:L`tA[g.fńkz:#4R6> j1٩JyXiAGdk1Dj$:F"xC)2 :Kn/2[Coj:v=,m hCHA?۶*wj!]kRpoLM]Bшy'1ǻwmlȗ D(h̀jE*'{y5۸⊤g.&)+wF7ۮv;E1fYjb_[rcKpƤKVR8U[ ΰ8z*E]eFW[֬Jq.dA[凲Jw@ÜƊVVc.4s-P(YxY]l2:+)? c0=wPW)=lx\)OE?#yr`J}BߊXt -ʐJ )-nzj~gP($bKST^; НI0@_Od 齍6o{l!O0qƁ vbÚ5b1,pw^أ;f1(4ѽ=FRAkAg`ͨ@mAl߲u7/ všwֵƚ[Q"CD&қ!\f{|07|\ž>ޅ$$\@Esep%sِ> stream xZo [Ԣ^-(g>(=[4=~)٬U!Lof8)Mؔڿj78~V4K2t4ٔ44t"dIٕ8 fWL$*?$.1<<6֤l/%OR>4O)d7R4hre\:<~IiuheieVǒ P"#uKD dq43Ot.ه,/<4aRzB~ʜNRAiF,1;yE1\o~ ߸SF9eD;t'p a3jiL2XTZͨd'C>cdWԅf.=Lo"c8n.5?FM?L_/?CW+ ~΢|vyܺ<և.f9lfªvȫ{tJf6L&(UWSoUX+ DzXc>#G+MY+uJ&uzKzX~[3~y!wz `#0c+V-W5`΁qO[Raȼ[ SVdmmƊ= M2ֺձW6'uwAA.5Դ8#ر.u L\G"1 $ƖB W"i*P]-/2S^Uk{{};GSpomw͌pqI{_2luG '7\wƒA1$UأqKؓUq V0Śy!<:N}dH-M5"IՔ&2 ^x(& Drax-H6jl'?ATb"HsLDos{*WL=S`ײub^ZzR?~t?^k6& \uj5IUp=ֿ\1vU͗c,M0y<-^l *zkg5 Gvj߾׳ F z~|`@FrM"i*'q)TvW.1N9, ~c/+MA˭-{,Y!&t"|^!6J(ձȱH!slrKivmWN;)q!FjkϮR"q$ ǗѨE*THMd:6Fa\v?yG3=̴ }̴-l-k¡3>aC1 +$R5,3zbq h,a#H8"v"yKRnc,ûw#x%J@?.Dr-z8(8NB>M{dX5%yAVO  /((FI=$Ź1!@Y!uo'8ܔJMllNq/ut g`>>y8m)#X&ȋ oic47KSr co |XXbF|`b2Ii^P{AޒE$־Q _1 qP'1c$ﵡ޽/m&Nckztg1gvԸ"az|V >-+㞕 i%m9vBIh;GrڑJ&kɗ64 t6 %}!&\6wF!_`1ֺ{bZP#l]mD׻5g KW%eڞݒ1]ͺKNo.QOa퍥G0ZRC!OKVajO/uiX>=!и!}Y3V3pI[+7 v N ,Wj|HCZttϳey&l<]bx;zlM뗽:chE 7`br77D 9Eо1HǻCX.pd Z'Z.OP<*0.Ww}kUIZ ۮ{,70*Q&莎~u+o懙>x@u[TE]گ&=HxV C6rV}(M pMnq ZQTA^;V30FDZ[/h&Tg~y]qm}/:iaO&8igbHFo\Jfm8B-H?+Yo6endstream endobj 70 0 obj << /Filter /FlateDecode /Length 2545 >> stream xZop7Eڢhqm>8X][ZRH9r6$L pcF0ׇُ͈};#㌺/3g}p  6v;_c3i0n*Krz"Yt?0BaRCAS.%̐sSB:̗`BsܺIŧOs}S^bbRViUPX+QDD\yDRxj° KˆTHfo{95'$g1g2JEasR)tK ΅ʖ=L =4m[ߗ ]zh]q+(Cq,eW[ poП^ y>~ˮZ8*Kc(`rݵAAlhN`} aToW MP\*"PYsj QTʺ+s[G2CjE*:hݱhɅ=dqZtJ[mZ^Gw}dS YBr h_t0d評e%p6KeLLHݫs*{UǺMOg`݊83+a}^|u˔^9}9u(QKg{meҤ|OE K^nD O2ً7JlF)gpqw(Pp{uU}Q{h6~ f\4Oխm9G쬺{T.*ZE/Ga!n/*zM=gW>JF :ERq|yj˴ocז4RkK_JP7(,$, rr`Ld%D8T_1lUbbStōUmck/Nj36Z>H„Wc19倯^#`"Iͥu LGY!wiLr "T*qi2`JE\7$:fr=F+S*Bt3 ;lno\OG $,+} JO*}<;,HSrSv\^kYno`ΒSP֛^]]uto[ql_}^~d箩(>m`H}fWt@m-`~Mvc](rϨfF9dmTʥ xDVW #5r^-Ls(\+xxv.%Fݚnwed&mq(#cyEb߇0\WxKi]0g֨E&a?p 褣r͗) DAћu69Dm dպzvxzlÆyz製z}2}:WYw& 1't-[Wjis 7~WA5D>CMg6i70IjF3-<#c*ŷ+]G7୷mB`";q(b@X҃ys$r0VK{ p.ic\[kM8"NL[fS8&ޱ?ǀ=*hd&MU5٠見Fb^Cd$Ee RH[ g*6pIQH}DBS!V[;K~Lrz7?Lɵ JV2#Ool>4 K !B6zPjAܤ$ ~ 4x%dO0| x0pr]S0?[Q=r lmsoՀWY$6}[IοePendstream endobj 71 0 obj << /Filter /FlateDecode /Length 2328 >> stream xYێ6r-*lG*vnv7P,6m3ؽɅƖm,ɑ>F߷?)RfIRb5"iD?.?] niAo7@@E4aIt]iĘLE*M0n-:hT+1!X z71MTGA.($GmK@et %XIԍϱ`p^PJXHʍ l t?+ 4ԝ4ܓJG ~7? .(LlO#` =ŭqw|LQF(L"퟉7S&0-EZf+ngL#% i(M4jvA|)}udf OuM g.*4&OgE5)Y/XP_++8=ߡ#[T;Lʠ>CxŮCfWǠ{[qy*8!X>_(9;n!*+DIJX\"Ͱd/)=ߢ]U4v\%I g/Wb2;߲w S q.dܼym **\:_G ?P ÁЉMDPLE`JBc6  I_gQyY\m=+蓜VQ,hy5&W ;J&`Ԯ2$]u>\%SA;:|-#QL^Ne/ҰѰb^q,|$5XAfo39I(؜nY_$LN\?1 ġ1K aC Kĥѫ+YCA܌Mw;*pW!Ӿ=v$61t"5KI|[7YIBm; z1 U. X?onk7ņ;C羨{.w(˖ˮf.oZnֹ"Չ1FPs5GND2/ XgI nvvH^-c[64)Bycvi/)}/`un4P]cf-D]BWbBug7[{,ˬysQ`Ƅڣ߹4@Y#?&ֱ&fuȚ,\ nd)zj|nV ~;kZ[d7)ڮ)]npQ*5όjif`pͷQ| Cn׼nYTTtb }ɝV_ה>/ʚݱ0WN/柆̇l:EZG\*9C]VΠzi ~Y*1 O?/ MoK7qj =DPK3BW5"8GN kYVG>| VYLS^.5C.^ʚH#E2bjv17.IFü5lsw[jRŒO42Tg]BlBXFU60ƛjla4| JtK/C H')jg͈G`S4vUhY@tLӄKw(4_˟b 6ͨٝ4jV.BAe8)ЙhSw{~TNl~0TB2cffx<[}G L3|tAڌx!ɀe~tߺ. c7$MQZʽ)zwoOG@ ǘ~3:Ư{}Z@9vӐttT{vЦP}<1ʳ ]jfmj;'j;QONԢon=iD'?]V]OA-4$9}ς N4]Є[H91&KQ:endstream endobj 72 0 obj << /Filter /FlateDecode /Length 2477 >> stream xY[۸_aLSnlˢ`yPl]ٚ4{H"5L.>tE\C:'ΉnvF淳_g??W0V151k0_gרX3ʠbE9&D|ZBi V)/u\J!QބQB/V`BB24}XkjzYSIY`Xw X<;V!m¨50b_/, #S!7WfqǞSXsBLqȌG@P0\LF)aZGk fΌX9ؼ)g73 kg\sj0I0Z,$X>fl!mW 0@'Š;\]WsyIQI񳯷eEF%uFːz&8ZΚL9lG܆E _<=#  tW`N,{[|X]]ӷn^ZsEы$mU[8YЌ4-(58'×?ԝ&$vF= r-͐Vg.6%HqDH!'Adn)RHHvyNe6(we#(sO1|?aSŴY(NOM{H^" %n!;(u$*N Q16<<({ 7`tSn\UPmU%h{xm"}_W1':r[ٳU[;Ԗ> :G1lT_6QO'7QQ,ӢP6E58<=3};u? < ٢.ô@~ٙPD E|SB_I㤬Uݮ7+pfmfUDވn1Fhu1!dM?X$dg] B8r w+n. 2.7=ͦ_Ls+"fP4 \ܟXIq-~/6OYOi 鐅pSqK5vUbn i؉#x 9@] 57аJU:Gjb/ae/[xQn_teNM0"tvKO趴q92O[Q5CLx<>F&5 FCxо2fK6j`nD)1O+=bܾbNCt0uK씿>cBSDJ$Sz!' 8^ŨO' WMax6RꡨML9v8M`* sT\ OŌ&X*W@T#p?F 2PAx@DuAX-WQ1RK0/I 8]endstream endobj 73 0 obj << /Filter /FlateDecode /Length 477 >> stream xSMo0WX(RXTvs v*H[ͪϛy ݵL|Z"X^ң՞͉QaQPzexղenXB<a>HK^Wp{} -D8G 'QhePxV:1hr/iCHu]Sj}&J[qw*,Q}Y"QntB ,4ZV1:(̩ ya_s/PHւ=b7X؂U Giaiyen@Rx [v79z(SFN!31㩙O)n!DTgj0q+7,zeXv#6p{މ볳ȩǑvk0d[9'7xܶuTmsH>4 RRendstream endobj 74 0 obj << /Type /XRef /Length 95 /Filter /FlateDecode /DecodeParms << /Columns 4 /Predictor 12 >> /W [ 1 2 1 ] /Info 3 0 R /Root 2 0 R /Size 75 /ID [<6638324d9042b3987fb0aa11fe394d26>] >> stream xcb&F~ cgC0,R@BHL@BH _ J@Hp~qk@ D$o կ endstream endobj startxref 57437 %%EOF mets/inst/doc/twostage-survival-case-control.pdf0000644000176200001440000013071713623061753021553 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 2193 /Filter /FlateDecode /N 35 /First 263 >> stream xY[o۸~?oE*J:($q68bӱJruc80d93iH ˆ$'<& #E4eHBG! Q@8#< Ή uI$pWDAbhChUJDD0aDP!$Hh#4ѱ!,2 %#`0%ꂄ *R]D4FH`&!(ϫW2'eB` JL c+~B,#{{vf9y51 c1=3pI"hg*.PUp?: {`Mn24 )3c zPvKŸD ܹ*CfǢdƵq.q1<cγ.{l<;:#'Ӭ(Qޗ$~)BpˌJ+]Zjj8%㧆x=Mk^O]e*O{?S. s۷6X6/kZW=ƇlY>(5YR ]{UlfE Kߦ1X ov(͢,t 49@_/ANK@g"[#Žʓ.Nz jy66%HWc0< ronYe9Y>Of^^ޒ2_Z[5$)UH?<?xf8^)QbH i^$ǵH@_w0CҚ.gt\N%aٕt?0څJ2@cJМo"JKȠN6\ ` =zL_ӷ^w4E[:l>O:S/tFtA3ӂtIP: 5*dz7uÁ \ VЊ"nTePY<nslǗ7Û7A4I͍2&'mQqOi&? s$T~T2Beˎ")=# 0,~xmRd#3P k1dbQ$m{P O!op$_i#kq,'YVWtx.g3SZRe5NRz8q?5 ɿjDyOPl`̇gF+&en4 Am{eLHw1&?8 h*>fdep 8keUFsꚹ㤘үKSতAۢNQU$ڱݥ=c =9z8x~v~--gCkbhyQYrv^u5AO?uu ?cӯ^k-ݬC5Ul3 g*fǬy2b`k9)rnS6׎3(e.H߀aﳍ)d7qqdؒSX+*+v -jOK\!weqi1T |ld= T`W N6< h͈dyxtpztk7vs3bTMW)51۲㺻2׭ٹOTSѡ+,FiZ"B m~]& "Tg(|eFKp(lQ!v`00|' 7lOOr7S}at ֆ!ﻷiC_Nvg0F"cb9wAzU_2=oaY]p.2eeUuΈ?BjyUV—5~O2F$]*=y&O@zyq}p(0 mO;>\RJt:/cuyߣU7ͦ}jMF['䜩+~{ mw# … P;ς?^ӓ>=yzo04ͥl&״eL\% c=It21 8?sQ,KmDbM;*endstream endobj 37 0 obj << /Subtype /XML /Type /Metadata /Length 1655 >> stream GPL Ghostscript 9.27 2020-02-18T23:23:38+01:00 2020-02-18T23:23:38+01:00 Emacs 26.1 (Org mode 9.1.14) Analysis of multivariate survival data based on Case Control DataKlaus Holst & Thomas Scheike endstream endobj 38 0 obj << /Filter /FlateDecode /Length 2073 >> stream xXMQ%@{Xq%ث*fr(hD/E$5!M J#H l{ݯѭ_(g}Y~e%,I1K9D"TIaHnJOm *$NC^ EC)tg<2[~un`QXsSW]UD2HaEJ}h$.n%ᒡ(oMѸ ft62'3Pp!"/r_2+p%_BUg)V2zxe&m8 sfL0>>)g^ħsaI:z` wF@(ܾFSTJ-ʺXT%kJ̈ Cc(6if.6~Ɇ<{,` C q]e,xPmv*K=/-&K 7Lf`FJcHe%(M^&DhL׆Pfc: (S!BT\HGzmmt/vKjb<+8 Lӎ),gMJ^eA9ёhqe~;$ =zSH3vLc:@ H=(`۾:P8b]m]/Ǣ:7.oNtA7oYBJq&K%8ɰL}k#Nr?/@%*aʱ' Nc/.:vVoD]ݹоy]Hf!_:GGg9LQ̓W?s8;ukdЗ c<($=}v1V̼X #gQ;ݠ,y7Hp#A)fzM¬]E}0Mٟ|輳!s E)DVMm+i& ð3Ln;_DMAř>xFWpAnxw\shlW_:I9&H/o&^9[2pPl^jY@6!Jb&xKoa_52܎^!GڟB+K%s}\޶Mٶ=wеdY.? @أendstream endobj 39 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4451 >> stream xWyTSO jzMZ[mZS** ʠ2@HC&$@EADFWgkjm{;_X7v;|oTʌ(T*u)Av._&y uex5󣈕DTm>e3^RfΦQ` ߟ;T#S]D ~z%ϓ^fㄽ+ %W "s$.-qy|a{bڦmEv"4[NTvɸOR #|H{͖I>y[J"KTȗg6_Ηf\\8EnD==O,%R1y.$OHQb\Ƒ%r61qclyDOy䟹b"?|-#zr\L"VzIQ)/U-per#Q?]^gK$]_ϗ˸ȀI2;2s_KBa7lo*-9jN.w{\(.\B܀B+HY&܀hJL *HnZJ]DJm #)-qzLxRmaThت8u9Įb˩mwjZX3ra[F_( 3ˁzJ;\k**+:+m>,Weq\>W:AZ u\EzfL8Q R}נZ +Y`oIF <6ٷ!||vj38s0ł2wʢ @vGC31Ȫj3z2?ԑF72:S w V73_Ngb&}nC:;SԯXKz9s56~:x+;O*h OSu00}no&<:ҏ\+X, ,YdUcj MqԢTM^;j?*b&8֮ ;kA5!1aL?Ù0a :3n Jrܤ B`MkMjU׃:IW{Sp֩/ߑEpYFp`pv)wxASFZ09]!x:"+A80('Y0K1 6'% NJh"pp.Zqd$(zP򏠬<9| jصe^XؖcV[׻5d2ΤwxUm1;טWͣ6[#px02hcoA{")Tm::xt 5dbB&GN1c/Q$}Nfm={ϋ$Zi b tШ}ɻ< ې[1  ?H"Y*KV)*H >dzuMJLoru4O~{p*.L4zQUBP!%^C3EZ8k!8Hf,v8kmXf,Y8" `tNV9'tNx3澲:趮tZ-plA!``zzƊrB}QlYQvrZ~3La2!2;lEuG,C5 %-ЗZJdXi%$֣$>~u9΍͂|0Pd"-YYؼ,&=1;DZ4^K\F@ &:Uuǚue'K5[uV3+8R2,V+pd"[E{$_{ l:H82SqHr ?k51 ZdJΫ*L/OFZ龐ܠ:A=hx"fgO!&Fc/\n=U+}Xy*uNO>CY)Rs_;:u t2hY'8koƿkڗzf1x `%/yp{L}E HBwȍ2#U*k&+ĢaC.Pb9%v<1P$[Biz b6x[Af(80rE%UjAby w70_ƖJl %R+ `m,7| )/mQ]pfGqMȬTDsK8zj ",XeliD? صmؖCkٯU(ޖZZ:rҪ\pT rx%m֣Πo#GG;~}% VL1*<)E F̬j%FZZx{j!/80˷/ R B,UR ^EBU)}@g56>:{a 28O5:{5HɰA%0!Y}A-&|,uJE#Њ/5=SHv=AЅJˌ{<#WqTZ lвD>iO]b‹G'$;]`]~Rjr:q88q !Ta$uHa"jilsdPi@w?G?lz%&%)-P-/!ݝ^/EBPJ y㴮9SPd%KRACb[yY1@4v8w.%-mvta]y$ByH, Q (xF1d%{T+?ntt;k=,2ILDme ӄ,&+Nv eƞ:Tv7 3y{S,qY6C!!_Í$̝ tzb a'v|n ,8So2ٌq0QqPu{`- \A#=msѫ!X |iμ|䝧H8\T8e؛I`v*Y֚0 h+8 +E5NAhb0˴e EP4G2H&zO)y6EN yũn-3fymZ<`;s[+ Fκl\L,%*0rc#ĆoU n}5RT}Y1-uk:=ѪmPN`D%}*)Jl(޻պtF\D 7Tɵj[S^˄k)HTz5m=mR,I2N+Py=*eۏ; 38{z`e*VR]/䁝Ȓŭd~#L6fhS&$bp&w=+aS\ҹ&'kQ*&5!b2 *`YEe6|iVRV)vkkkH缬j7;x}ϸ`yl<WQNYWSd'33*B 7V{E,B^~c{i~::q n()zyӡmF؉3Gkd2r&d.ikc#ԱcW|. 0:BET(2IƿAF@thXP')I3?_:}ӱ 0Th+F?%! ZMJ _)ʗVNDJ@hX1M^FP^&7٬Ct`w9nte4w;>Vry{/ /H9X.}~zggS("endstream endobj 40 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 961 >> stream xURLekmNgt 0)!چڀ"wۮwݕ$&)a`CHql$Gڅ ]Hr7w >yI I-X~IXJ.Vw3jXFl{Ogwf6~ϼE{v' 9K!B\DN4쩨pnUԀP!"x^tC`_]Uϩ/fe_8(V?@A,^MFP#P,BZ FaIp`x9ɈJP+ H #  CA@bIvHdH 1Z @y j&%Y HkpmQdWB xFc|8~$ cFRqWD񅘄Ȗ0B4 ]}*[RS7z #$Ke*}F/Kkck\(AU{_!v¨mQHP9Ir2uӠ̨PF*Ӕ'yW27f73/8$<娶hbes?_sYl/(:Jj-q1_ 6䷱yΟ/^'s'ͻF.4M);>34::=.MZu;%VA )oA#ųÙSl~''>ɕ&ƌV?&:w"=j1"gZ~]}ճEl__u㶎WzEӖK#YhĪ*Qev(g:piu=)1ŨXr}iu])ZY}z%} O rXUѦS{MN5W8uvf؂_t])ڷKYMcJauW+ˏypҼ Eendstream endobj 41 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4977 >> stream xXy\Sg־)&NEܦ&EIj])VEEQ\qA%@$IX" H&a M\>Z~]ڙRmRNh]g~w#{<99{ c0۷DFĈD1Bi[o= ϔzԫ0l.=2M,0 t}@]h K{-y%da.޻Mtd 3bK7XTA܇$fq89-tXP*@ doh 8+p K[ujo:voÆ("O}&w䚎pa70jDi*<ǑX`0qɢ(uP L"XzvF-xlԌoR7p|| S`Lj \١w4;͇Oیڴ8Kk99H@7)"!1/+3p ]&.ؠV[7 CS-Y-^ux}e4{0 ;`+qH g;BV*Ob7QpU*kص߰?Jی˄ӣЕhQH4}=?%aJ}4ASmW i\fjw`/RJ -b֣4i'A|mȧɹAEڨ|flt78N<itN1s'$>Sm(*دenmZp€H2IJ ؎M-~9pSlaP 0'ĬHF)PFxg 4 ̅@I&q fod Aq 7Z6ooj)i(iuOƦAk"͜HsYop~gxK}vrM`=斩U+əi򭡜p2~Sy(ٍ!p5lo'`QBty='^mx2Ԟ]JǼ\h һ=wEO&olǝqxijj0,s*8,Zg3X/Kb~FQ:G1y"/ٰ=a^/ ̜]Ѓ`Pzw\z9F|_E=罋lR)&gǃ$ ȬˮѶ>cR] >uz\M?!SEs͗: ۈ<i OgۍUL Tp!{5drAV#y#ɑ Pa/JgC=xqQG@nzqZ_RP!G p&sUZkuSEi;P~ux!޶ښ%H߅],fi2;B; Yf[қqJ}d݃K*+tpGsUVoi48>h \i\Y`vҶ"[QXjPTHs ջ(>'?5?=y)c#߅@C?v~Z Gvb&Pg(M>&sΈ9ErSkk mp$`CMoPX6}^k.) lIl qIǺ-u}rȆT3˝D!26+-(*R5ZL2"!&절tNIJnhȶfs/jF]e7XeJ{=jQ$s˳-y-I\+Iт9Kn5bp-F࡛>-o,[cw@~PWzyq Ӯ)tt#YV_}SN_[3+~#j*%%pVqjbZ>5.|ȕm H#.3 vF 0SP[T h" wJ{֌p} k;pg.|udM"g>7 ? MHm1y-$ <쭇$ -` =!T acMkPz+38Ϩ2C| zdz}Z)-;aqJ5GW:v'ںA`{xF֭?GjX* MՊQ6 zKг -vWE 3ّz!I0X`ss vTe $uĸҏz4=bS\j% jJ>|`ŇJ;Æxj|WHQL\? .tvnxN $LoHA(b&0Gr Y/]p^v\}eצ ,EqYm'?0dr1y_cwZ;P횻pSآ,%gMz~~tqB}K Y͕'ϋ\}GJ}6Տ|lM))b3lvR2#>F68Ua=^[uҁ)mjn[b!A}-3שtUJ]b- ̿LfUԂss(Ղ׃vcUS~55botgVd%[8~PMu9QA-:- VgQ*о|cspEp F%2TⒹ[Ζn9\*}tPd{B@,vn3WImr+_$v: G`u QEgxQ[?g?ߚI_w@v1Øs;/(Ϯ_}ѝwӯF=y5'I4k/źB7H5̐ op2\,û5jslX\mO'n-o04]hKyU>AGqfs%:K~7`t$:ҀW83=u `kt6F Ys뚑"*O+m[fY `&|so=/hق9ׂnڝ˾|Es!$  82X6]-R{^K+}קAN7T}~57mucBwn×ѯO*nƶU.֔Kݑ}1c@~8-Ө vdioSχ/?eNn\X¤jXu%L:/_û|yd|w;eendstream endobj 42 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 601 >> stream xQAHQ~%"iPKr% ٙ73/yo˭., !dEP 6D]n]ԡKRوެu)(ZEi|5R gT'#Jp.hxAi+]ߎgo|Kދ1"^,x|=|IlM+ʊKv$)Ĵ\~#091m8&[2g"YAX B1/e]Q6vU | m`.h։ )8A`&f*9> stream xXX֞eav"2C책[ D-(mһ -JoRtEA+h 5j՘53yvaO}f曯}ϊc#B$rtrqFykŏ wd"1vΟfG@fbdf|ndsb4QX$l/ gc9w=cZ E=Buk,n[ϐX{J<|e>֛[7otpheߘo$b}0pHEZOXog:~6nr yk,\x;N:};f͙˝ &b1p!M b3Jl!vlžCl'V;M}†XEE&> ‘XH8gb4aN!,%aEqx„ xF,!ˈH–XA 8_d+:fبHl,Ve\j2פA%2 1k ӫfj3}őG9fhכ?|bnY,86{2jU8q}4xzcA5h[Q>DgUg)_BUEج? 6R #kmLBB_ya;pa0Mwy1JI( deG6QKw(HᕒW2+dvfTuϡ+aff8O%馧9Q /F fFr dZt^u1/ FS3 ȧOa4qZiotK_8ϑͻ4prOXʴPJB䞈,v7&Cԛô{~?zmsrT@5LTŞ4({'%} Do:W,5\_%[{?#HJ6n?-YaϽ3U =㋧?vqexZtWeBo/Yxذj*Iz Da07`3lľ`|[`ճE5P+Lߍ70`O5Q*E2V*DlL< x_:aϝ(»dE4n˚[lςt+n\sXYgy ѯ'f?{!%(C3(_Vi[h$?)9R_ TsMXz“LSL77mnR,"N=ˇt(uxѝ;JD5UHm~C t< jL;$mj.p([U\QsclN`*lI陬gr,rOΥNB)_i|'OlF垲DIQx 7OBG2UIun[ {6#T+nYU3jUwhJȆ-izr#HZ^])o{9C}z0f~QE^4 nxƢwe{ ;>ǫoi|2]镰HB[7252ٚ:2淃s0%g4*o@%-B:d(7<}oZVG_ciK_ ..a zEp %%vez_Go^ mCQXI9$FmSCS4S! Y(em!:Ԉ;l&QxeJ>C̗jV664I wdM=)eT )5|AVJfMNPdl.{ҚFduU6WڣL* ۻ-/UTylh1HO4׫H楰 [sOp ZZV\v(EEJeyN !>8k%W|L[q꠺Si@]睝8~g^0jJ9DjX6oC}ZYҥ>1MiCǽ. k$:m>N҇hGB&TyB|Kne|}jE:Elᯀ&cP".A\RSI@VeeslRۄۓ~=fb` L:PpDg4_HhQ!'*"Tnu8Ű }(FH+D|JCV>M? c Z!$y ,1xv7 $CGa1C\ܖخvV@qM&qUoi3NcU~lRq D}˄#(Q#䊡_A)x%Y爲j7Rt>GZu:}Ԣ/P>cS#SبS;%ȚFf`9]0ϧx&n)LepYq5z Q~TtA+b>>f[ьaP܅Ba87CAmʶmoH^|",}/, ;lhT-"gPܲsdi`Lf&} /*fs%T#n_!ک!M:ibRGG5+Z!q ;I'Jclv* q/˧.æmdE1|ooǦH"jK8z*Bdei$+j@zP(EՒ7ՈpG(.L>}#u%[Y+Iy __p&xv! 9MS^~c_ ְKۡP̷L󀗊 Iۧje@ wh]GL`'u͕E\ᮖs{m [9W&&g8+ jK\Ǟ~qMM, :|yI籶^ ugeLbSvBI6cquuU{p] u;~_. ڰ'6[`#~bn"ߤB}wvv =|w50+Q-(MHHBI^VS}~' oUX:?flfZ{ t7n\ܰ5dc:tkK:|}Y'1xd$8ld~|pFܹR2jpj$N㬁r+fϠ۫/GjEw}_䝷@SGغ],ѣX8lݴӖU=sĭ[ݶq䲘]9ܧ|˛W~ViF#g1DטaQ?+r"ڐ~Өvި82r?jC9 J\j I4l|}6~ɂB6\jc ?PqyeSLCpp"dS >6s d׸oɭ{W}⽘ }IC0xlb9% : k?rŧrO~=//^E˵^>}lDvVEy`zFjSu準xZ%{HgxPHKLItGK}oP Kv5$vJj_t}<> stream xX Xڞ;&p[nuZ[Q,a%%@;'la_FEnXQVUZ[{{' 'p2g{C@X VYl^ފCS?F Q8_5b0'z#c,aS*3f@[zxLjpEsm#l)C}mzsgM_Δں{ ʤ{u޹~Nۍ;v98$bil|ߺ!0pۼ>;|wpxb>m|s9#G‰Fl'VӉN}™E&v^b-1G#\[b>Dl&bb xp 1!!&I$H5!FĻb,G'@D %X$86B񕀃ݜ#' %&YTA$wzH?/Fr>ԝYEFˀ_(fO|,M7كp )inKggQBEсx_q,>ߜ_Xn0VsDrLdςShŬ o?+ |'n7w`=%AL<zP 7~~+ *g3k@@U9 YQ1g$ 167@$$D@&8e׏F`i|K! C>ikLVկr%8((|5o[E+LtK3d Nc8dQ9JAh8cJE.W AM[(P2ߤ&އ]% mFnDnp $8i3ٜssDn.^g!yK؊~Ey=H8O[h-dBB&63av~dv`=*2(yS> b%%'ƙ䞨9>חi6_h^,)avlpz>Stye;80"Ma{0/Ȣ2NѤ`2 ( \('<ΈPL΀ƐbହŇ76o3|Z&]VgģքHN$Ф؄ƫ|x\/R OzUY KQqI$e¡TE* o*.0\zw;>Xu88^) pG) i%iLPk@w5 "VѢ/HcNm=+߈鯐|'o=ƐN[=?t.]442RAZڳt0Շ3l!6) E uMQ EO-9 q gY;,aĕD)5X7W , kr?:iF&E}Du!D A*jZL{I?Tՠ*ql:@F^iOZҒRlEcF P*Exߺ4<3@+_l-Jt })?.i>g\@}voV"kW&%Q.8ލ[ nA!AP桤$͑@T'gGv'8݃D(,:,E_9[ne5>'8 $Dh҃ 79 R_"2(}#8eϰrRY;T'0QUc g6^/Q@`]kWxW!EJsZ2 VdG'Y`e-[MRb,%4(zC{CcffA1ca|; 3@nЁ_1 ] TxSu֩-yE=ݺz?7d@%5Գ?1GB^ t*W &Ayh=pҢ4SiZMo]\ ;Ӂ+Z M]0o4X<"q n.;I_6/+,*o}j1C584@=^UM5sс2 rC*=vaΞ&4,H(mm"O2\å;78x]ng3p=B>3P.07t|06?UW0W%![H#ȫT2 VU}>yw`ppBvlj,=|LӤDqsゴe&~XͮhGyGد[Mc ^ɰzCd`#+%D,3]s[ 7| B`p^A߰?OVw=E3̴ ̄;vÑfF!o_a2Q*-2E _\vU몘38|AOB&JYo殱[$-/ a5QqA n*(4&1[ v^ٚj&9*9|_o4A+ ?CV괆 J SZ~\wEKOAOyy~CWa+/n8F/믤 >L Zn4nXdMc% BCez {z'K|\A&M{qϳ9aYv1[)PTk`"51LzG*M S*"tElqףJpnTar) gE_MU[G )b$ho+bFH_[z"^Ŗ:Us%=X\ƈX~3LnN|іGe8CZ|k.5PG[u Ym<\QSSMO1uRwYg0♪4o#1$Zg%A2ٹ ==h32kA!*EߚtiTidLBFèCAHΊ,-PV JS@YYZ2E d&FÎbQWP_q-= x]6x2|;}F') z#xP$H Zʲr#:rj{.PZ.O^`V z:h 'g1|D'tK`ad%)DUF 9>R|/%7.`1=u-]E#APUQxTwhr>s~@HEPmY V} ?)ygr @U w[{f1Q@)ϊ{).G9tV!%/PP*\.,\)kzw/nu?a`*8"(^NfPkSS&4Fb`Kl9}ۻhgꈏ͠G|} <4^Qq*','?>:u SzXLC~>֏iɍӡtE9¦FQJi.W' Pir`֥@鋫Lxν;6~'|(CKr QƌcF+gjKsƌiJL/vCnX_ZSWendstream endobj 45 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2565 >> stream x}Pg7@Umi؞V^wikE-*J); o ȋ"* (RKՓZf/:7id[n3}vyEa,Wᓛ6&K kObքֆ- =Zm/ * Ȉk"3P^t>,:/xIX&xOmڴyF澕#m-J+laޮ8nY x9y%/%//sߞԽɿ=b@XVQ)KsrKJa{X`~, ۆmN,ۅ%b`Y0<9|eH(;v;7)._|r`e\4̢kzc旙Tr#J0M&CCQp7;+WO*+%U2h MW 4-^ \NSgQI`J[ހ팋lE :\ڢlz22ȍJϏVRD9$̼@WTL@iЬMtiS(3zo}ߡ]Y[;5w6ts3 !)̴!*rYj?T/du}T͵Q{%W H76-~ Oځ)"eĞ,?@+>\" E1~,MRI"&*uENxy<DcIhZIMJy ]?z LLv F*ζA̢gCrˁ2M  }h @R7WC 36u[NLe ?Al5%_5_U1\齲8G% L/0=khzmwxaV]I]-bt5ՁR'6ȈhN.>yuwe>5CM0)x7[)VK;5;#޿ 5\q!m|}?c}4ԑ/'ȏmߊ\h~G7|z.E9PeYt,kSOCsQG;_ג":xW37WFjsX롅lR$1k'o5Ɲw?}K=pvڽǁL&y!jStv_ >m_|2#_V4_M VW?ycϛs>݌Ԝ ?8=,m9?v#a2#WSDE UF,&}/N_uܖw( uF}g4ИHR +:jo2ZܩCGScˋ]Nv7UКufj cT +< Z1@FB9qB$>[^>ɜbRJ{u8q5]b;z-3o5 ۅqD`H&\Gӫ?Oms:(zzcdp}Uƺʘ /-JArQ243ZbP/%?y߿hW˦=0fbHq0tKa5Z loD0'_FT BT2 \K?je#`qL{/#G@t"&%ڱnߨ36RZ `w5-IгhaY-`ax)JTkbZ^> stream xZ[o~ׯ B5t zhEb RHh:9C.&&V49/s1slT/g8>H0p?, Pd$nּH" HĂU6[B|~M˜{9_eIͥ2L%'.VЯkZl~-0D/H] apJudaI/bKܧt` b(l6;HBjaA:F;$pOHh/!i[x"tۓ{E֞wA7EBv`4iϟ`5{0 AJ` qb$( #X$̷pErD`f<@Hi8[TV[`ل\kJ]TE^!CZ 3ϴB̃2x{O1%)p,'V;F;9DB&@ ڐÿui#\#VwVFК6k[YZgi$­7$nZ^8nZ~j$CK[nsAta#br#!zp-t=BE\Gx.ݲ義3DPER(s9{zzE3X U)Y&T5k)[EݦSI//Pi1J/+gR`*lz H4CMjxT )>2=M}ަuÀv{!NoG#HƗ:/lpX.d4f",OjѐA(#9~gϚ/zׄɊ0Ifm GB@{USH`ܨ Vc[&WZC=ERzz2+k7A,PGąmA`|,TUӦ@ܵ1_l{VNeGcAYmu*cqKҸ:i#$Z / 6*4azHiPQhF{l&$}v %._R`X J(EWvh;s9rz,q:6˰'r933Ŝa/ǟxpP,}!Y}Jʸkj]8XTx4gvImiYiO-UC6n%r[]U.LHs=PZs맷B -6g:(;%_#iRVȅ1J`Šsn%Ɨt:6.K`=yRT==d~?nbtQn@_֪\ZAc̦ĸ QuyxudY/A+`q qtMj$|,9b<>YX6yfхe՜O=X 4Ĉblg֦(%YM4KM3TJVa7#Nt ,*Iԭ+7 +t42-9:(:=.m-ʐr-&Y7)K$DsT #ZUR\Y\qcw(OMﷰGtSlFQ o11jU79a:ZM -Y\/X{Ă{ЬLC~ǴL!~%_~@ `_E\ !MOg_m.aҍ)4C'>x-2}n}n%=~uCDI\cf'Hpw%Z H~E )$] ͙[`BT bKjD(9 rmCH$eVDHI:]D[  ܧg% Sendstream endobj 47 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2858 >> stream xUV{TWFVR]k]w\|H"F H#l=w<{')jp&~^5d3_ZbT4L'$̗Hp(ӃC4Ӭf  wfr)װٯ!f=͐lDoY G^k7譆$͖T@?^<(he%z֘HGit^OےtC""wnH/MoZ#hH zUN4F:llHZj'p>+Ao&h>-`o`Ҵ&^G̴`LIxd-if{uBIQ//u.e-g1mPQ 4Jm(.M$.݆މ6H")v;õG.-`;}U\$ W3e?Xyjrt i&jTޏHqATʚ5)?gn5[LNaC8w iOq3hE!CC2BWx(ה56TokۆA$6]L:!U=\8D˅^E>ء3d尔uL^IĹ5 Ȅ(HݘԤ岠PҜȗC#4c"#VϯF 4o~@Y qҳ=  I4㏾◭bJ4Yc@p)KMk#!$=dƵTձej|9hiӜП׽l.Ǻpb(y29F־6"vPW7BzW8\>~O.9wW(lUBcp-Q \Z&B*U5": ,÷hS֓ `M0e}%x|/%Uy;@#COn!ko!~v89uykvi!_@ӟE/\ o` MX1ڱQ}Mx2|#6spZs}/a:xJK6\3;lgp~^h.^sschs\x8q@x& L.{d.}w񤳗K3^Ɓm sw^/; LfQ$sXG!r{{Uۧ͟]NS>VlEʑ^ pzc>&axssߓfAf7U0l*E\b*).qhTXyIغGJ!tC}J%LTe?;L>4Oy|nBغȘ pGU#Q]ՑDDsx6` dB *4M* .:z[.] ] /$P늓+|[ākEP\nUBGb>-E(ܞ_}{A )!endstream endobj 48 0 obj << /Filter /FlateDecode /Length 1915 >> stream xXYF~ׯ ^l+}/ z٬ 16zOhkG'$5߾_5(DY㫣焧"]ׇ?kzƓ3^&e}Huiz#MrDJ'M5 α|)Ty6Z3\̰ݚqno1lfV֠ЬvKS.aHowR&3e4UX3-l{b x6XmEx9&-&n12c29hϙͤEOW_ϔvG}>EwqUы3 C$|xS=hazV㚥vwWaQ)%łzBr-(-WDix`rvk8nzNdLVU~ h -Sd،S}؀g6-ꖀ v(7>HA[W.:a#}yxd]T7 qeO# kXVzI2VlQbԃR^E9tFZZ{~Y8.(e@WѳX6w5>i3L 3`K\pwYkg1!1TkmTu`ڐKrՃ˦cH"Vx DaEl1`,o@OIa# XPIeϛw!Z?ٳ>'e~$/gn'P|gf ;#Io(6dbNE FlD|%Pʈ;JĞ\qσ\8HyS,G|77 >iPπ*ҧ*Bؑ]kI˗XzH֔ J0r7hx9g{܉Ώ2u 0FCfǢI"`.@sdik Y]ϧ9Rg>=MDv6ʺog 4aPY2E%JIU̶3z"kf*TS3g"#}Y hNK# %8dq2 &ʆj)N_䉃ALejA]|iyh|G-Noٛ.#BmJHx/غ|[Vʹ4.dPLbm1fnw̙nSiB28^W!JҜ&o,ͩnVCP)@jdgtsDnYSOv!Tahz1G8+_(*,yv+'y¾EC 6b׼-@]H+\w+i9R.@!פִ67PsĎ:nzws\V5м2Ȑ_ ݀ UCwy~l!xzĢKڨ}t~cUY4fҹJ9z]@5T.MUI)󪿬N[ h5bfwDmMڧi%Y邎hYM (٭4xp9Zf_jhuO.cv]QuVt:EI4W-JX:Yc̃m)rW90 )i &`#q/ZO' 9=͑qx b,R83FGшK?$: Cީ M9D78mDsÍOn|??sendstream endobj 49 0 obj << /Filter /FlateDecode /Length 800 >> stream xUKo0 vayUQo  {.|[wp4īؿGi7A2E~Hc g@xkMί-Y '>K%9:K6<ٽpL(ͬ&҇Xbf0ޥ'*"[B,2#,R #~PS1C)E5IJoQ^NA>leqm8p.]z2hb<׮CEѤ8D<Ζ0e8iRFuӲ@*ʟ#2 wiGeO~H%߄]qkX-i!Aٯ/uW7c%"d1?1YB(bt"2endstream endobj 50 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 238 /Subtype /Image /Width 291 /Length 5658 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK#" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Z( ( ( ( ( ( ( ( *+-帝E v=@?f[ONi)D#±mq=<S@VMt"/cQ*R>"xIsm̹6 OӚҢ4P YT2@,Uai:ͮG(1eX~!OԀhEQEQEQEQEQEQEQEQEQE#0E,$g?p?,@h_B~4fg?p?,@h_B~4fg?p?,@h_B~4Y͟*&pv Emfi.$j10@ OSo ?/g?poi{8 ʄAxqV&Ŝ4rKqOYa #><֗hг?cN$I[ƐU]y3}+\ѴTXITA {0v,&hг?YhYƏ ?/*hг?YhYƏ ?/*hг?YhYƏ ?/*hг?Y fMv08Z((* i5U[Adoq+puH~C@((((((((((((((G*"(5?6]OͪQEQEgc;\IMj?/iX=ʷF!T$|DpA-I;-K($|4袊((((((((((Ju,I%77x833ϧosi7,Twc\LZ\RE gb3 88H&T5Y633;=+v((4Pԇ3Oq1=zלgN)Š( %mV*U(u ࿴IYH JJV=cJKyPFv1~_z-P׿׬ {V-e1/Fr8МA[zzТ(((((((((B@@jBKŽ}~{4~v8oώZ,ߋRopr6N3"mw>ƭcf=2Gpy=/H)FnYA1KE(('r_b\X(wR=nȱ9p0hh!3s;Њ QDw t G2odvJϞK"x5Q| ۮTmK;kIH΁=+Zk_Z((((((()(i3A sұ&$k}4K8?O9i\Ե+]2w(EԱcZXMI`E?D`/ 裓ZbY[ıDTάQE2B(((( %mV*U($K,\DM0 ̭2~^r٬]bc yFKrӸl׌m55o6Df*˕#`]^&HܷnCo}L[D-d#@4QEQEQEQEQEQEoK4h2s@UGU+y? VzwWH~i_Sִt*Oy?)$S%DiךXo*ߨScunb(8QaUF¤6QE((((('r_b\X( }_py Cr5\!Ȕm%wugk__XMLX3 ʁ);^98v΅׬ QEQEQEQEQEU[BNw2Āg,Ϩ&]6Q9=O$E{l QL(((((((U'r_b (3%7ŖP<3:$*Z(&Gw ` 5CV&|\detZC^^&/EQEQEQIP]g Ag=Xu$@]lb7s}..$k1W&[)1qUQIH/-SQEQEQEQEQEQEQEQEQEQE]OͪW_/j@Q@Q@P׿׬ 4cc==k_)*,a^kHbvܐ9 \Mc>-uY!R=gO' Dc7}_c֤qh5 0PV1[;M3tN3zOd ֍b6QE((((((((((('r_b\X(( ~R}zqg'p { lacu.w1\c$?*^EQn]p1 _?_ZIU(-$\dU_I&v;][1?` sU~ _?>k??'W ` sUpeWR1S-$\dU_(}~.2O*ZIUFCv-ӧU\dU` PZIQ _?MqJ _` sUx Z _?>k??'W ` sUb-H_#.= (~.2O*ZIU(-$\dU_2ME]?@lo)}&wώ[ԜULREPEPEPRܰq 9Y ヂqGz q$莸X8MJIy8Ԣ ( 1ܦ,i#) Wzdķ\9Z4h?B`Y*ī\KHA9~Z4Q@!KEat J7frRP1`z)lR@Q@]+rilwOoRYx#`> /W [ 1 2 1 ] /Info 3 0 R /Root 2 0 R /Size 52 /ID [<32b6713777c8858aa056d25aeaca8772><33c9643d24d5e4886743b0d3a07d8651>] >> stream xcb&F~ cN{L l'nL{> $7 n !" $AD G@J2@J63 endstream endobj startxref 45168 %%EOF mets/inst/doc/recurrent-events.pdf0000644000176200001440000050535313623061752016772 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 3328 /Filter /FlateDecode /N 80 /First 663 >> stream x[Ys8~_V*rk*U;58-6g$#Rg~~ %t=v44qF eywdSa4 dJ9J(w͎\c̑fϼ@]Ťk&]zHL^R3*` K/dĊ[*@|9P jQ` v]&$MCG#j(瀾ePIoIG(DmPM}.-{ڼfߥ M|s#BqA CQUg&Ż>+ASl78ʓt1{^q\p~⧿qv9?˩n!&P[Nmq%zVv..9 \{}G6ܔ}nnQƯMY3[N'O*ÐN6hcZ+T,߰PfC\g}Vs(׶1<6L4m *8D] kyN N: =‡+gj|muRWSVx0D]M'}fx#mee:?G;/WB?J8..vv =@Fʌ64\]EgK~]ڳovjDD>I ]G#:O͘e`_ȡwYtLQQ倎'lNB5n.ԆXeB} z5f^1Ӳ+rkFPU,@n(3,Rkx.v;Cw۾E4MdJ6*6L6GS^Βyo]|:)坭wdp$#ؿjbi 1&hܰe5I~3P;k~$FWPuqX[ hKJCЛ -"H2Rb-e- sNj˗''< ^60{,/Ѩ=v=uÑT7-IlـL %Q8>(v}A-i6[mʜMm/X{ǀ%÷&[I4볶PPŧ}{jI~?5|{kljpЖRUK-mQkכS_0η1j<,7kJ^W+J]g$ z7>usUbo,[=imn鿔4j+Φ\z9ċl.Mo7Xykϣl/5nI9@7wrgaݔlwa~?mYg}멵G[Z-h6O]ØہgA*A=& 7$`qxz{32NgJ:!pn'.=_Ba~ufӒ^и#Hbd̗EK}Ȧ.gH[@Kl=;^~Şhe;[~ðǗ=0NԡBn>6At`%m":LȊҶ3Y?3mM?9'!2>O# ˾ 7xpSKXm%nvDMG㛃d7뭞 I) x}ܪt]X= y*J=jF]yl5S.2OrVWwDOr 4GJ.HoCPĘ#Md`xFdoX|jgD&7'xWaȏpKG5s.:2PܞSCDK>勻tKÀM%ZtpnOF5C-f_O_endstream endobj 82 0 obj << /Subtype /XML /Type /Metadata /Length 1606 >> stream GPL Ghostscript 9.27 2020-02-18T23:23:37+01:00 2020-02-18T23:23:37+01:00 Emacs 26.1 (Org mode 9.1.14) Recurrent EventsKlaus Holst & Thomas Scheike endstream endobj 83 0 obj << /Filter /FlateDecode /Length 1975 >> stream xYn6_*HJ$З(.PNdU6+?PE^8MaޕFÙ33 $7_]DzzA'oV csnAT@$1V TaQ$)Ru.8M៫J$1*S$X=_BlCkfێZ~dhi-ߨoWCX`FX DdAtyf$Z8f2ЈFZ"Ʃ "X%Ղ qS{=@kI:VoKu7IS1iL,7{+%W6&h \<F1| R0s$އѨ(*.%Aeg$l57W_{1T֝H ssӄT'!Нmj`γS/(.21MT> ::d*5@>ېl_fuܳܣ}(5u-{N&Woєx 3v8S$XB ~lh.8:$3Ъݹ1Uo0n:\'`pڙy9nO*b%x^4TBwqsݕ߫]Ӷ\gz;ؒmq*h\y %X#sS>]݅L\Mߵ~rI0bq&{{M S^؛p(G^|'KX&"b> b7ff8$pO B2:Q-r4LnN+ >>7K(5 ݁tC}nF-8{~Zb x.:޽[Z9 9撙x[oJd8dȺ;M) Zw-RPRTe7zr 9#A hIVI|Lo]{5~׮IڷЗx987쯏o|~m=JŅG%'HzaŐ *B=+5`ώi~2㳜N{CNojɤͶmNͽ{xSuTL~%InTyCh_i֪VSn)nqkf\(R/~.>'@,6!A!{Hf5g^4=@>ݎ /! VI~iQ8v'riPZ)$/33|&ϳ 3#?<ϴ'wyrr'z|-!d\1ixrW^O7SlZqxe[$1ous' K u ḙ'|6.`PS*B]mx30,k#暵y-V^S{ M#bpSA>|7cLt|}F nX1uXrGb2n.Fy=$<Q (qѪ1>m?OI?G7D٥^I:n۹3JL/\..Șҳa.n2±}=IVuVUq}2:eܛRv[;?rz8[SFpL' Ul<ɂI=YY/270atjcb|jE`/g:Q̓C}rTDOq˩}#O t>0G;M-31b/|[endstream endobj 84 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6315 >> stream xY TSWg֚f|O$S;ֶj77T\A\%@ $! aFw_ ;KnmZci;mg:n|.zƙow8~7 0"""o$% %1ϬU$W"B} 4+^D#z,9Y/wS`J$2![.g1á?O5.+⛹h'~zrT-g(/^tB s@$f Ċg["CObwݸ?w@$&)a@,c5yZ:Ƌ"FFc"!Ƴkx;2/242dUO|rOzpٓߚ~PuS.6ڍG6?rdvϏp^ߴX4N$yhuhCqqjlV |.ma|2=si\uZ;Q לtëgs f>GgL P@|Ս5Wjry- Qvj7Q)W%l 2$¸ep!nV/+T-N ^a^m]ЮOW~<⫱yQK=5LYoSI]bH2s.e H6]$$lY]NFHpၷ5p耴6&۳{2Pڌ]C=uGfa- 1d JDTQL8I/>l*1eR%TzB?p|JP5r `7{ӣ[COűb5ݡkx-}`wެ%Tw[n??=do/v|&>EKS+sJD,=Cr_`SǞ3c5GǢ86ygbt'ԯg3iV9żˌ$M QQ욯F9&\ H'Us<||[^IOl|)udi4|kקQ&3n6-fF,+  h৑/B&`-[6`lnzҫ Ff_[wO\o̖8k_%\#z ox\ .8Zt"2-AhN9=4 \8~/bI;rvq3T9p2n k厥\*U>^HoQYMyU4Wi+hs^G3n,wϒz7x*qVa2+ƺ) 9hoRD]pyؚ }2T}.ecu{(b'"33E[imN/#Pj e= ή}װn|9u<06916uc6fU ȃd 6| p :XT5q-K`,Ӊ^TAj*uޠ_' [}2ɋ $8V{AUBsQ Nb5VrHՃ&& 4V?*nQmT- ΀>U~gιlJL9IO!q HAc_K%%a(Z3T0*@uNkбsp42Mt]IPdKrbrS ᤈЄPhsi&ʈJB$O[K>^u:q{Z 1b}tr (k;*muTݪ8I4?}EȂ0&~xj<`L3ŋpD;:εJ|Lb S̒J0͜"u"))RѷW2ٔƎqmj@ ك(ik^oR:@S!Xo =;}_K34{p U=[cY-K+MFNrٗ@Rmh7VKܙ l޵ c#gYϖJ5HI\"pT. l;Ii1K!(#x:_VY+TZ tFwYc{^,aIh ߡc?*Jdx2G6Zpkt,u\=.gٚr(b,zEFd)9Q5𠦫?D5#"S,]Ab,%Lz)ײ3ډSJ(](Ûm9}gE-Y(zn{ G $RD x~˦>5Au8I { G"7nQ: p"a&[-MmE FOZh וպ"տǭӘH-iЇ-:l¯ !`Q[A~ =jCsr3jbGack0϶8[UjCQr8zQұ2W&fáEkaչAQ/ؐMzSK Dp*O[%$VBR# J΢1I5۰ZVhTR6:2x{}h۹!j.^ɜ^ϝ:a!2Pȿ%Þ eyGa4WL?Y(EH$g,C&_r=K9`3Rɘc`c蹣D (}7:ٿWqp].9 N#BD'Sd( PDٲDVv׶ws{]lܔoQ)5hLDPW0]lqr鈼8aܖ6nXIiyӹf8^PLнpUք&af.CzqF{z6Ǝ.N҉5_5QTeFq8+5 jX RIz@hAT.b~ 79}AX].S)ly9qJ|q9¤d꽆|!Kysnf`f"u$xבփ/߾gn]O)v9K⥙^ҿq 2WdmY]ū~@і0>2Biw7l]/?XtY|(67 @J0|j5 Cy03?yJ^! }]?4-.](Fk"Kvg,L 2szQ T9;nL  ԇm^fD;/OfRÏ *7~#^sJ@dH:acyZ;5GBE4 =xSrwuy O oߖ x <=q>}P| ?[Ž7 Cݼzw+;伩X6 ŀbm"i|PB%S5K-GMUZC N xќS TEThEw&eYO/UpZ(gk"|w_Ea$qo"DHhD_?GSr?^sfK}hJR]}fkb%8atT-z=# < lGbxfEUK:VKSW{l@oqM1 `lSԗ5soV'iP\-<s lL@W(jG-Tk%CZ;ԲXfPH)ōK5tğ kLBZH=bNxɆR}IdFH[WfќdK!xng}y Y_@ՎHPT^0/1XFԈ 6X_]phn oH<`*]lM{G|3`֝US;` 'O4_K:NR`KcUek-ժČq2(]WOCH妎ZzӛW|nuy~:|0j(3PE@OOW&\ǣ?I.!{'J }~,{YarTC&U'T~=/qGtȩ@757*乹%ٚ-*^37Yt\1wK][dM]FLjT5Z{O_} VvwQrtl`G{>tuQkHBE.(B8AG5ymJk5~(Y|\"gu!hA(A 9 QzGs4Ӻbks6x}zڹw Q= X܈OyqSbPY6j=2-s(ۙ5I^(7YPPQ# .ME2QaH(K)؊wdNeC¦jP|sz6;EYm߽ǙCz,~=한j)V%xK&ncMz/rlI_+7fˑWx;'|P%.O¥TY 'N7`] gx])wZ9q6:ZAT3wp3=*~i Pi8¥q^]V-XJuGwqe9;> WYV6쓡ԥ^[92kL:uUMc/ؘn@YmʛX)[Of4xi2ㅈ7WhL So-mЋDKхzG }x}p 7M# 8S(Էַt(1l$2.CP\e?8>Ż,ovlߗ7e-ؼk.(kM5{b6^M!h(s@]uc_Z޺]ų:P;8ck]^Irrރ7!6|[X/Zwd)6kxd)i'nqM: P; 3frNĦZz_O. WPBj闙-,)G"ngvk*T_zxIrE UUmB3'^AXi]S]*@lo'.ѻV7 R_>:Ԇɋ8G68usRC ,S,vm%`-xuzyx余SH>]>y_ni92*M'آfާ)%U&lPYGрu2WgoOMJ i97 }[-m GO M^02kYg%Ht4o+:'O9츳h_H hV̹6 wEq;K:Q<'|yrE pi}bzFnތU, ֖dMMnsL+>?4ok^#:~ 0]_K异5%͏7ۯ">0CW 7+ߤ${׉Th3#8,8n:դބb{Sk0;5|W N ݈AQy.u`5['>D"Of(tГ>_ 8aˠ'?˖o?*BhzjU|[d`_b:R/+QDxhWi+C/~p vGASЕҽR~ bOҨStp7LDٜ+z+/g ۖOLUCYA'~nǔ) eBlendstream endobj 85 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 961 >> stream xURoLe@7*a?)!چڀNʻ]붒H !0]\ &3@AI[矴 05&~$w_l7{/?(, H,y(hĻ_h)K]tZf=*z5(xLb ?gޢSs kΒ QS{-{+*[} F(. QNůqKbc!!;!` AV i@ |Qr ^yF29IHk'P'E@D8@l:s2D^ãIxI"d9];)Yј4a28 $T\դm|!&!."P"BiCWV>Ԕ ^~dJmÅnZD(FDaվ b'a!0j@DHΩ@τzpL6(3d;vn{#iʓ7<+[3[3;<娮h|e?_Yl.+wo9Nj-q%_ 6w緱H%./^sͻ/7 II;>7822=)MaZM[/%VA )[@'ƳC3l~˧.JFdLR`ٳԳmL>Ib"//FWzEӖYhĪ*Qev(g:6?'bIWjR:9Jk@?ޑMY~׫pw8>\?뺆Soҵ./>>ScES԰ټ|v(iFكendstream endobj 86 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7285 >> stream xy XSALιU%$EIV[Z[VYQq@q`@$ H2!a a3 c[vko}{j?p8{^]kkDA899l yQ~}vwǏ'83G 8&NٓB{&`3iׁyqXک,woN["I Wg͝;W,~4"^*GIœK$J-*7I$bED%/Yj |+$RI\`;>(*"X,%Sš8q`4$B!ʧŁby$8/$Kb؁iI\t\rqX\T! +dipT|=**1q2<G(o\!QKT#XgȂ<SFHb$I$DcXTL\Đ iؓݧ$aq!Q\*O'~ԁ11QCkeCKBcK:YoOA%1W(W%$I J^N1b͑>Q[}gzw'~d͂L}cĴDb=1&^#6&ub31!oV“FKb)1F,#fˉ,b%xXM&^b-xxp%xxg$$< BDxEDcb,I؝f9 QÜٜ߸ (r'ISۨ% WFu}te }w^0\?_&^.|w~ѸWՏ-YI8BA^YEy {ya-śr^܈.{I3쮼|zڀ7?+-4'm 3F,!ML C5hxܝWUPMd1ܨ,r!:,@]4)A%Tu6@#Z-|<kʬpp:G|CijC~;*8?,ٍXgD4HŠ1"#MvhzLj/%PUJw+XXGVgj lݭg_HbA(QI}uWCy03|ޖL"tGů.bFI8H;QP_chq7n Q"@b+=թ:t|fט̫߼h:zOL%xܺ䃩~D辋_\T|emą d|qhC^\Т?4æKs%0OXpW;D( [UlL[>B;]uuݷЯ;C.G.κ?YSn`BVj}Z-ZE¹={5,@(4{>5AWlq5XUa2xF!]&W*rY%F ifS4Q~c~xߧg!a~: /l |p AO-T&69 [R\m6]KK }! -P+04:4hl*s ߛ,6(0>:F-LΖiVA D# ͅp N涨jsVp6z qt^]xءb\hPv Ml<!lV>׹Ʋ50jpIg>TYQ-B3 M ԄM?,DgM٫ A&.]N;Py^> R8Hi}y-0un:'AԐq,JZwVeH(?Rӷt0%9.7sHAoqƹek<+!36:F\%h 'Yo-b'fInE* ' f3֧2W$@!h$Z`N:V8gŭ7kj <)+r@j?$Bee83! @2F ZF.$.Ì|Y.ebV@KϖHO)2Ydz̚Z^n#- W'W7+m|NR]&M3^C;邾e1<0|;Q}=>ă/\o@d9݉zm.R!Y@.mάT!c2_dH3dQKS)ZTX?d8ȩ&gޟ]ܦ-Xp9-ԃTҦ*T8= PXYe6EeFHg30ňwphڒĺ2pzPJ~Mhߏ3?pzUsL9S4StXʚeGkҶNWɘi3r~X9!Azڞ݀3&6'c-wPn61yf8$DkH49C THNo-'k1Sx%`, iTkT.Jn+ 8MH C~!!G43Le),dŨ 1Qjac.yYQiՙ%m (ȏtt!xbTRd0%j0u1sZ/(ݜeVS(reZˏj&2Θ0gagR?;SvgNh` ku1e9}b;p/V=Dp6|J!jWcc=6o [Ѹ c+ .nt\vBd$Z r*Vs~6o< r7ذi4řeBĔ9VX6?b]{!aA/'<[~ӝqb>ʁ{]1>0T+gҫjepyN킍ѡ05:&U^;ԘM;gLár}J C׫Pgg_&߃3aȫ4Vk YT&^_QoSEUJqdmqu *l7!qH0IG & :+Q}h8:6`<ǐ_ZD(TX >CIj4&sUT_".k.:xZ^i](5lΰ.F%DBxJ|܆UnXEˣ8Ug6>.3:Ћd1-ǩ:֣!z~3LQC750nn4avK6k49Vd -  C\pfN) -I12Ƴ{6knMƬ.-TrWp lFoC6ז϶~-7ޯt9¯+f&6p'lMo:Xܳzu\%̖ڗ>;@cҳC^7Ѩ'/`fs} %fk} `0,pz$b֟_4guu"޿V8zfgQq*V;D}rp'2ʔL׳?ݬl}toVN6>ou[tI /ox/͙ṁ*+E9V1X),M5e /Q T%^ XyEX.e N[[kv:ieǙ=x\fܬbYt=Š#蟃tP31] ؼuMßܥـNDFKc1 Չ; &LmZvX6i*CŸ5ƈڢzR+ofg+khy vzd_Drɸvm|ΎSqqy"__{zQxk` 3q) 7gۙњbM3J 6 \qz9ǿy0%ki "-jKM{n][燎_4&F&mq475KܓbwEŸJ7"W.jpޟgv뫍uU <\4?Dd MхH!͝y>z'Xhf7Vo-rdaĺ ix<'=uw=fdȇoAbnclԐrVD6%AX{fIv4:fMΐ(Oo鈪L<7@49!=X/Ȩ$U_et? uҶyOȾk gZ[}3("Q?c#W=˽@>0O׵UZ$Zs+~<鹂2=ChAꅹzZWiBҤ1kmҙtF0 Ю\~'lE?n<Zg;^w`[z0+۪a?>:|[ةpnFTpE䥠 *9uW$iؾNq*X7ZM.(Y -M3 }v5W* htF0.`ާjmHnڔ+y"x`B0ēW4EaB4jd#,;Z̵؁%o'\5v~T1cfg2_&On Sf v෠zGh'$'&y䒭V>1'$%>sA\DdD9ș#n58d(z0oM7lN$62YCF6j f&:'b쥴s:PjnnzKk|WGH(TB5R+ [H8n[bWo*\*yvtpchzX C۳n\(|KBߵF6ç[^^^aRwr cn#t&\[)+ ːm{;뛾l+@u*umL'ӔHBPQHXixPv𣘑wQ>q̓c}69u) ICg.Uy(]4i@VlQ b!  wp q׀`{;?O:nvHc_kT⑓6hh\>3Ec~Fc^/Kh 'I'(=?D빌n9uw'^槅*e&-ߒao)奵vugLo*ϭv?}ӸYkwi-RrN5$>Ps3:l/&/ۄO>Z ~T/4=hdjJRX}W|q>D^llm>D˛k%NL>)V us-K}0aImK ] 6^ ͧ|'Wձcvk3ђwc!W *2sΑ9&F$^ҔT2=dqw}DZ-2Ei="m?Ս'2m<(|U-'Zh,P(|@F Ǩsƭfio9)djG˹2?w(`VRK}`BvcC$endstream endobj 87 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 943 >> stream x}R]lD&F@BC/ *1Fa{(#RuT a_H3ntmwbtxEc& Ƈ&!^ TGdsd|}?hޖ`ɯ(nXauN;Anx྽}{]_ XwbWn'uqqut }^o_ 3Yv`r$r  9א 9ĥANJs*@Y?x$NeI 0F`4"XFd5O+Q<141X)\  n*)R?P8UF@Fe%J)!=9e EI]$"54RkfHɒFЀdZNDj7\$PS@|r2˰jZശ JC % *Phs6_4Nch;ۭ8FX1f(EQ#o>hL/s9z~dRذ_wqjߏKBNeȄ&_b$XUGdx#kLx s5G[GVj τfUrol}i wOԲμuMn?e$S[s=2 hwj<4ri$ ;Ìqv.6MRxVETâ KNQͮ~f۴rnkG&,LդI4װQs ~z߇|849[xuHTi͹pP/;ФΘGB 9"|>P?c}];ϾV߿yο[endstream endobj 88 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 567 >> stream xMKLQtڡ&m{mbGk01 m NA*BlZ!KCJ]D7.DqBnB䜜|1qB7A8d2\<0*U,.u[jhF x Tl(Po;;;Z@KX$A{"JTGZCR難$Oćrj贯1%J{a)uWrB"qhX'G)E{) ÄI=i "Ȉta\W +FsgIac`םfܳ]m it;C'h03š6^l cx f@dkLZd79^\ܬ64ޫm@ Z.Ifsl_޷(0 ؙAv50 ykv67wFeaXŗ|sm85ְ,θY2{XKBҺł>R2+X+ Rݳ}s.֗. mendstream endobj 89 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2533 >> stream xUUiTWH Ҷ54=( ê`CWcMwnEvv;nlBE ADtb5I\c2&fcPc9u^wｒ`.0DJ41Bc0hzS[Qn{u7] |شʦc\]^8cl$`RIM4}+97&2y|^,'AEl$g `2RF"~^DFj :2ʚhQEZwPNoMBȹ!bJȈD> 'QF 3dɨ[&e>Ԑ3$,.f*-UocRo!4F+%&RoL2kExa^g2ZIsIXOVR&Ւ7[I1"(;4VעINԚEY5zRYV'"z٠pR4-zc t2J֤i e ~XkfCxi<|Btύ@Q˜ Ԙ-B ZAlH>9=0a45=#]EaX`Xc0LMƔl*扩0/L!8s$s'|*]*e\ .2wU| >g %X!S\A)e) z**aEyV:Lfa/Fحly|B 8:{9PGB g>ȃ!o.+~3_T27Lk{RTj5h8@ ⦰;(h]Sm۾#Zzy|Pkw| xL=')Jo 9vmfS 7T&S@\į3$.-/GELU pp~AYQZ/ӞrhA~ zO\B{m,xfCS`-)v7wg9wX`;g2<뫓 b_Ke60Mr0U7;u'PG3_{Y<5@Ӹlzqe"Zd5Z G]73nz7&u2YbK`g| ΐ Wv*U}Z}g>GUx* BV[;UV/WنV:t60Fr„wYH":,O|&[-x$:e5 mGjv^; w'Û6XŴl&|~rt`H AǵH(Z{mꙪ"'LGarmTi| w0M59lAtɅRM=â|r[&]]\ a^/-J9gaO՛ɺpm> @"z:> v YnЋ&R19:)NZC3jE^7g;\!Imm)*R |޼ʿOJq6rkWc@׬V_ _[z+^PU3o :J  pqKDZlnE:W=,~b|EK9 yY~de> g2lG@uDvPͶ:+}<z@AH ߆; kZ6:4|d +%@szPW!*pk0tkI}}u7KC R ʴv3KgVG3|5e}UAr=-:oiCw̋2dD3 N :|KaS 4q _ @o7P0s*W4P !o-*[*9JA2@%Q|R"]3KuP )+UP DmMP a2Mgylu6{ DɱR)wlܖt4Rwl˷3I]hoyɡh)75KIܘŻ?y)єGW|M["ԅv{aI+ Zs_;s㚕^E^ {N Nc^+~5pTGSO>ChNxb})@MUQbh_шk/ ȓ 6=cQ7*'ebVNazEen8bUH 7xZ kDU3Ԋr!@&ES_<KB.>ju⫰aφFmLӮՈOуÒ;{|pP |t4|EK=^<~}ɓ {IvCT%8 YRv6+Ō>y> stream xRAkSAMB}&ZI#sƀmKڧRy/ewEOo)Bo^ ܗhW/|73rV0󗱐Rw7L&/nUx\N\jƃ֊GKg79?fd){n7l\Fo D}$^n:AVH=I t)Ap2mA/h'\ 8 &A`ȹ9ȭPSH%r!iXA@Uw%!(;}_RQAg2ɰ!Y CG*_7b.l*x˭,惿쭞U]w(VX8qPZojaӬyuu~Lzs+7Gg'ՓQ4Okendstream endobj 91 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1134 >> stream x}Q}LecY ϦX2$1%9XGwݕlK 0^(PWX!12Ӊ&sqL&^M޼=y~AEѬIx˳Gx$ Zy)b~jBE~%S"P i]|R\WYtWk*zEqƒ=4Bxާ 67eY[pPU] p g1R4ȓWNq8cyn͔MO"lE&̐z߫8 ,p'h08k%8N~f< @ڌl/M4e*#T ' ,fAMa`"d7MqMr6جAq[OǐC?Bf58YH$Dtlq魮 I>1Hf Q YCA4+ɰ2BC夑4c !,T})kdz{ߡB, 6owwtHOW0 OamX{|3p};cg-FmB>jN_E493Npo`B@g판T9=^8]sUa77ژ7lVTCWwBħS}& ƾ.8'z'|*ԉP/:P3=Pa{X(C@*˭L#_b> stream xZn# 7Ye߻4a]"ANƈ XNj(,9UEVSfv=soYYgoLv7)&̿̚ws0ieR:3N"'tʢdt&6_O@6٦΄[?}X|)l 㓤fĆWп0 NRdܕvri~8_=,,ߵ26XʯV򰯮Lv%z,rksWRXit~[0/ KVYX'$aE)Ll$%LzA>0p6 fT|6N3ie6gJLg n,Y wa (3+iy5\>DdNz#Yc2Z-W׵x/Y/$?>L+./ D&Qov:0UpaX6cv_O$vfJ8emZe{-N-nI!, @"|:+ D5)Cada[$* yO Ǎ=6WM9-Ts^*PCO{LW{pq:#Evh-/y!b@ ד~ nu&"m޾JRVΨj0uV3ո֞fF xE4jPFjc^# N0;: O0{ԡ V{EW}6^-L "Ζ6aM|ȤL:L;VU!a0E5^sӧ"(gƮS_"1 F+82(}H9%rS(v!VUr#>u}9iE2[q &HNjN4Lc| vO2uZ#j?jj̒g^ ވݥ@k~?0NS=fDp5@`k !5 djixsGQh1dQPl"3>E6k@yE< ̻=@ٶtnlgrT +}>/#3r#ej}~eV`]7 5*=u"~uڿ(Qf_m7T=12IT5Q[WT.o~`0zåˠX|_fgtC^ ,#@:~Xo6=gպ}wZA=JL$^Hvits ,Ț^ 8d+G~Gr{ȤF$}E^ۥbsX_v섆Yq=t,pT9*^*UkIi˱JZE樘$60swvŸ%B0ȼ̓ N2,S1 *#xx>ُed(I%ef_S6,:wb3ʝtjAZ>]&C(5[[]~mQg)/qW](DOIJJqY Ful9~MaG0wQŠCTZq%%ίo9&Ҩr7lokE߸ /|n~V /%*o'#(3Yb9uig)A{J(AGJ*4ـqOKA ,A*dQZ.b`w'Uk4i>Nvon>H q&Q( ]M/ʐBl=mKu;u?s$[6C 7]kOv{O#ػ4<{aHt c0S#߉EROdUjq^HA=`X8-QQbo͝)1P4hJpK ;=`t_묃Q)HbL}Yoa:7V[uCJ*M2bOgoXyUs0xtP%R}ssA*g**bC> stream x5]L[eC =lӬ NNlK1a!I2?:n&ڮrhүe--Cٰ B f3B 7fN5Vx>O}~K q"B24m6 ݬ`Tq mְj23M}ѠgK CQkȠc#=l`zŬPkf(SLMT; 9yMDq>EcEh@Q%zD|CoCw.h\4EO=-o)T>p,q2ɞ+B]U^S\ 72QAEPvwIB&- eFˎ{D`ēk˦>mHzk.|O s"gfX%P(P~ Y$DG8*}wţWbף'~)f)(g牅:?@{v\rvd5\gƮn: n+vY {앨7%ӝ=j >&[lqXT=|E Xe&eW%e!oE6w^ ̃uI?v/# awi']o;l#gbM_ri9B >.O"t䲹ܲ{}1f2erّ/ẑr%nX , HAOvqݞ v9OƭP+`v> stream xcd`ab`dddwu041 ~H3a!-=s7,IƵ|<<,~,){+#c~iE% ɚ : F Eɉy %%@NBp~rfjIMFII~yy^bn^~QByfIBPjqjQYj[~^_bnĥz9?$H7?%(/3$5(1'% '-I(a``` b`bf`a\ WK2~ g{,^±hvIqQMFu|܍|| 37|Y]t {UΪ"%Ջ/`ߌB:~WnoNӻuusz;?YtϽ/"Z"=.;lɋgr(QQ^Z7ݏ.퓿3+1%;v\X\]ˑn3V\篓e_%W{]o^l2+-Rùy20endstream endobj 95 0 obj << /Filter /FlateDecode /Length 3208 >> stream x[͎YO! vJF {Ib璌rЎ8;GҘz@1&[lJf= EUnꇱ0{}َ/͟H~xҎFBk%vj|ݰr25 5zv}jfj2U ޾`YLAH/̔*Pr<Ւ _/P?m6O2oٗBCݦo?7\ypȗAnrݾʚ&WPh`" آЕB#hchE{*L- ;}"Ő{OA=HZ\5xeդbH5&H@^司aEӠv ~ow8v;_'.5ȶZUm a0mh0߾_=Vjyڣq&` 4:U ]nv8Js獤<4DUFv#Cq E(po頡aDDސ>܉Kez8=\768ɐS[.AE,LC݉ 5Pw) 8|Ny!GQW a"٭H"Dԡ5XL)Đ* 'ƿ41R %.E_sR!P ТNEYD8Zvv=hQ[G 8zP 3uȣtt\]CC{%z(ʰבǸ 482G,>gP[Roh Aaf8^= pN>Dh1-#ZDG:T1ʃsn;3N<.]4tca8 F8ziQ\_gm'pFF o`hsb"Mb[rBNK>a4r\M//|WV/lTB> pD_`G$NiC[MKBKa{8 jR5rnD6tlWvvCN$9ݛ2uIS(ߌ8XxS{O -btXZغ;o;Ժ'"+ͱө17G6hWy[C*hOr 3el=,_ j;`>PH,. (-*-ŌCqYaaL:IvYW桹85? $JY5jeZ1tP ][cO^يjQ_{æ$ߥqwdqUFeg:r6M܏!Y 4BMu/4ix1%3ruUQp8;Ro$*%%N+[!5. e^T 7Xt6B"{ZCTI@Pڨ:kdYQױP:PSlXdVR7+$H P2Bttmqh[O>KBf}quZgƭY0 Bϥ7Yr_x% m->Ǥ%0".#ᮼ ]9!\/ f0ⴵ)wahɖKm>ŠhIXh# ҋ0!r ̩Ɯxg<'KuӷA,g* 99l1Zrvy( qg ,ր񫯘x#s1b)<Γ|-JB no!=wI\ )Iaλ~vF|<cW͘y>g}Cў|_#Y.^wߞ/'4}Y&4+[blշ*d,^ocqվa}j*&7IzkwyӴ`s#;@FGTG*qݲj'f=}UQ+zSŲfQ> stream xV TWMHЪN4H0H0jTDPQTD㆑fYeߠ( ج-+$FXq n1c\D2$W9?b0NrO:FH$Sj-ӽ7ld4a2)2#33,pHHIP"*1&dCpC{{9M(s( S+Bd~2e^xa3D6^)A2Jesܽ/_콉oI,RKH D8LriGSNx b1XJ,#| •XE&wbAx +& šIo œp&,K-#˜":D#3b'qBMM!$T !CCKM-M֙5e<\z.⠕~0|^B#j6{M@z:C_j(Zø`dY=w I=qm+C%tnB8ـ,L9%NnjW@,c Sb <@>} ÙYۥs<=k..rbz1qp/|!')60tס8z%*4䞈Igp{+/ΝpdU ߭|:OJ`F'K/ e! Nր[g xֿCHݺ6d!2]䠘]`b/ OU=*KT3auQͨhQChlvjV._bOyM왌h5AP}^dD"JbYG 9)99(rr2 7\1FHEU'oq CU6~]̫x AڽA^Hek562K|򃋑߶5k+%r[-^UyTbK@TM򌂭 %{¶~HT(60KRl7h#PjvD|AI< @ cL;u.)y?Iy?Ԁ1;=HRBj{NDZ&.z0B&Q(>[DI ImLv{n*G+ɾq b<2wgV?KaH-A 4TN ~9;?2- 2ȂLu6B(7zzFbRHtlPnQȼqZ%#X:`吝[o~UÀ=SQaMVMR2L }m"oiތ-FmGj)PQO, Ji ^܃yJ$%0DmB+Hį[\뉍)8AV֢f0sr8)> `uLxGKHs8-\E r"X(4ISF~jgu zP̀p&@+4=N^<9Te{tKdOxߔ1Eғ5 ޯlAV~ƍvU.S.߹si>^'wS+:m8ͬXK)dbkɘi?wmngRLJKҲĚU,g'ߖzys>ޕ3_x'f^v `+`+顰EXp^EӡM >i^S_mѥJiU_%~Ai٣%! =w@> stream xY XS׶>18#(=۪:թ* f ! BayFR*Vl֢Z>MvIc{_Z+Qdz( ,+:f|qGqQ$w䥃5bזFw`EtNJ9 j'ݖ%^+F/\d|r;(;v%@!v m(Cْ;OAb;n.68:os88$bmd4t}XL)BqpsgcVA;,R.]w3`s;‰XNA83m 1N \bFZbX@뉷 Fbp o2b+1 GL&41JX|baKx`b,>1O$&Մ% x$޹QGug-&ZtiR3V j;:htߘ1w:2q5!ueK$IUe"NΙv?4mTNk$oVcOlmm{kWNmjz'l*:mRdCӞ=F0k*2V@ۍz;di#h5kHQӿ) wfPx06k4cZǚvzh/h:, mّJ)~TѴpJ?HyrɨT 7P0 r"&PF JMoo2N}_[Tw< [!>"w`)A-œВYG/rwg׮_t\`*=VG ԝ5H. ) 4ID_OWjp|VW#K-Vj,de!=v_3GFBAk((LAh\c~,<F1rB@|$P bLY~WgB{.\;a)3%=+1lG ݆)sZP#E] _9YφSKKY>+&L;|b߾ӵ҉1DM2tvq~,4o%d֣(VBay28 +jW2wma 5 CGKF䷳#B[/b8ƟxeK;"]3CïzW`gFXćcIݳ+B7&LūzezzX7t?AOPKxW]X@UQ\dJ,ٙx2Ihh쀵ʅGËƔ1_āTPܭ^UL.H( ](TikYi^c>9Ìx#r^'*\0h<\!M Ez`%[HD80+5->+HIqƷ i'# xx4!e+WV "%9]hupTB9V3!1o]0e9"FƖ#8WI\YXј nj`!#AT-Ň(uӐ^w(T|.{n51d 1$6+Ϧ/HUlS)@0p&9EFA!,)CՀ|DZ'NGU]a(✪Ů"D QS}xq{5c̞GI(@3XHEƄ Va=D B87pgA2HY u?dRm Fc:J@4H2[ˍ-Kes1B`c-y[埢KjR .K* T9YW(A ld ݄_CZkҳ#[ { %z8soX&4LN.l,~ !1!mL0$7%uBP̌\lt1هmF^Rry[g6f_]|ZPs+ zyV=2qp AB=%8(l:d@~_Ǻ 2g=NwPE"=ꉍjZcKRDʗ&58oU8Q 87>kjv\ş;MbEIh98Uq0ց }k.Em[+> 9Q ~HnKPPgѐr`n<|x(d9 4J}@-ic9MpDїx=$ ,e3Pm`Y Oj )&̛p2va- ΠQ!wȧ:87o5ʃpT86qϖ;MY#SӰςppчF$o]43YҪ*@iKMA{^yJop>M-;eCČҿP/VꘄP VI27LsJjoNP^}@[@Iq 1+1K@ 9 u ~0U]VejrCKqeѮ:}+hfilk4;H+oGwho0ap't1PLr2 rյL\[HMj%3mͧ9ە_ 9a;mf4R8X= 26bN 5e>`j H8+ #5W?hWE7j$L"564HgOI AGOyGWe+= SBaقl&;"U4#qIQ0,U$.goN]v-& MZ7il_UP.e6fg ]D*ꂒ7պf0nZN()lSKǂÐʭkW>H?SE= \$Xv{2ّ']q yUSD^ W'F7NՕ:2(Z?,%+p}ۆAs4:NEH0 M´4Z@38 :0kh4G873x9hQza俛nh4- \*ZгVКu8YLͤ1=t7-`?IA ,0\hދ'kUY t L'6H\1iDu\2Kꕦ̐`JQ_{Hxkp1e%'͇g+ES+* : V.tn,D" gOB7(8vȒ١+VÊ,Zc]}EsUb^J[]K޷׻:y(y$&%%Q8؏R:'4ޔ(|Ӡƌ|h:&D#OAÀNśJff3Z m2MI0Uw魺o~ 1}N'U]L2l1m z 'Ğ8O064:*#;]atp|޽mۡ?c3r @ff de)BeJ%?IpʃG8KJRelHx$H9Ŋ*L3i$C芒V AvJELq.߸TGf!(4.tL>p=yx lO,cB0䈳VǁtAdv2P3iD8kum4 $a A`"7}) U#5݇E%Bѧ z2'0i>|w7y׮.9j23M8+txM᤟B.߄ V߇;JCb['Sm~:Pj*dM :m3-ܑ Wʈ.B_![e\>/85VanC&̜V K&GJݘ"}Y٤&~B5L6_i+2qc_")@ PHIt=)Aa5F5t⿛7Aܼ 0Do7^ g!eh/'ΖaŋqQed J *":CLw1˾\K޼Ҿcg/ϐXPăPć_p|#!P, H[;ZZ_4Kf=TXթgqKu==GK=S1bJ/z}1B&HckJe1l7@LnNA1#ta1A֞\  mk eʳw7&6z{{;[oPKZ,ws‹Gw߽ ]ieޡ޾_>>ownag}v?5eQ U*~_ 6Uuyֿ.y6 !p%ɦ'{n~ (I<10 K!VE8yBPs܃O_W8GpkIEכ_s0x\\NIKK:4C~~/Qq cf\KT2&2>'2m?\d D r0Ka@j2u;jXlteZuտi7CMvĜg*3R,u?&a@9"ml0W3,9Ti Bէȡ_M-<6Il>>' 7H;4L&ENJrJYm}~Z0;> stream xWyTS׺?4Oc9X[\mjbdF2@B&B 0Q**U*h:^^ok>qv@ Gb콳!&N 8Ό?o.Z|(>3-18y<6Yl%y7AXM|GDhh&* B8}YٲܴTQ+Z.2A~E $/#-2>hWDJ`ZaVdBRj|fr092:i=wܼ{]{+A sDbI6i,莤Դ=V~|/Ӳ+b'1ED{hb/:O' AUb#$LFl!kmvbND!Db.A$1%ӈ,N y$t۹YܟxIk&Ց[7O~;tCSøa^dڇWMbfvUAiLn7a 0hR֐mP8%H]vÛ;I=;eɔ7"R!G,K/TbRc]v\2hTeR m7( GmVsQ54|~w|?x6TOdz9ɘִo#A$D8X ؊뵟#Q'ρtt-v_Mɳ -|CK?z|jrLޗUC`^۲b#xHEsy8п"n(1eev c?C$Efd'_t fANWu񿊹jQa5)!riu(jvPz[>1W_R!2 _9x*?AI΢} @ IoqMz%wi|r266W ~|X/ Q{)e[?ȥ"hnu6ZP98%rGDM}:Jd^Ma]uOm6B>|:ƱǙl(npB%C\-)5֢wN^\.LY/*)[r[٦$(PdR %YhnxI6X0:JUҮ-(.+J鈖%}1s\=z zo!&\ [WgE|48a#Кt&U.1!&%⭢d h-6]*NyoζTwTUbl^Έv}jNE ldC1_B9ʜeC:8O>TvdOo4Qp:/cI&}d1 eH&ʑ$8nL`y,|́7N;UUCI&Py$=JAFn s@J@0-XԈamcojnQvz^F5{JA݁p*"?bLyߢocP*4PF wq[]jvUz܃]ȕŚB(1+$\*;Lrf$⪴оk չ2u>nP~D!Cem,dmamnCMv*ܩkqnݿŎ8 !3ƺdE^:u `l`Ѣ~LP F傋 2o5;a~݈5xDSҮr!7MЬsV%fx t}_ k˻ڿMԒZfgx6A+Uu߅m)*RhԹtb!%13Y(MlBPtU*h #U%;z^A?G_Ս(g=WZSXՕ(,]N^ DEנpZZydvk>QLdhN8oXoa~x]ILdWC.:?z#mf(1fr0CI~OZ͇)mWE6vǷyُ$'@zdPE9 9YIyN;}ЯCfl?iqۚ@ZeA'DM A/+y0Rwu|2Bf2zyW'\6_u'n蠅,נx倠d4͘ AgnzѢ\WY*bI<|k{gOxG_ XmTO_ _s'sބ\E}<6>om6-9v Xv* 霃3ߟBVv:)ʪ{ TČck>+Wp wӃhuVY{@Vņz-WhA"x7Ph;A(iTjhTZ$UBIsg?*qF ikn2& U^~ʓ3yЏbtXhvXfo`y$jJ$6T3DY\XH5ʣE ^7ne9goE359;SAEE.EܷxNEw'[1r$O+)6[]GTi ./]čRG*^(y|^P瑀{_>9E[P̔H8L]>x: EfF7ִM$.Wht%z5u?Mu*ܩASСv6iv flmު[c&<D!)p8jtnÁ$iPDy̑+yht5vd(o a2G{lLr?1tP@\Қ4HL/^{5亽Xj{)U@mGQSU}9ql4{aW]Tc[;[lo{1^;|z9+YP+JJIߎ?;o-N1YNEm/zE #%8Th4ѼjNWeXM`4S}q,T1)1jAfes ]b";Ij=xDA7Z2 4';iE+Z2ySЉ°6+ְKFՄ^{T_8*endstream endobj 99 0 obj << /Filter /FlateDecode /Length 2773 >> stream x[r]d}bB70oR31=N,d5MQm&|oHܔ-z!"?f9eYz&ٍfq1_g f:uvq=jd9Vgi*蒔i4'x"Ֆjtcj5]7|zcxrp.dUV Kq%(f˲#0NS;!(0>B 1\L1ii(yZRx-BnͩXf<1y^wHu;dW6YW%EYnp,.>?PM06t'h(^r$59 weqS{zpUTs?)]%UdpJ۸'kÅ-=kn|:ᫍuTWrxqAt֮l C zV,7U+b ^U<j__eye1ߗeX& VسEz(|"NlՑ4l5K0nX>ʼAJM56Zwy\HBXKϫU)ʸ$]oWĵ摍 ךGBP|㍏\C?E[z$~lF?>fL"naRyc<\KmӗK}}F?PgrW2e)Tc7rE;xuc? r!*AXSGས鶎|\3ļ 1c(J+rBAz[vC =ďP/I S}`O}WHڷ wMil9 67_C+)/ʔ1˫3?[)5u#wYr+ތ'@j(G1xɾ.19uz7Űwt~GW{ǃ+g|!2$o|szk`u?O ; *&S+&Aƴ}1 9'UaQi1[0N1~2)=bzLQH=1^9\a牷NؘTTZn#=v1k(푉KZ61u@V㵏xxa 0Kéc"'"2";Vw;`1ܛSboJEJ=J8jDkAƑʳ є@ƚPi 2b סaR:<d0m-z1 HGXl };Pg_L<1ηc}*(CvUŮU`Iu?FL8\îKܼ@ggՒ5pZn7a5`5 9UG^3]"W]1ui5qtKZnrw_=֫?Y%{uKˌP0!3Vg~UUn]5*A⳻{j\j…/'eE||sDn"PR (!&A!VV\ М멒WExEwa>F{1K!86C$s˜AG,g.5%jʱ'W`oΜzD؛2RdwG8c<`;sS3T8yѪ2Tڿs* r}қ2NLyzչ?:(}|?P7swU|`f1\1*̡0IOu{YI&:cx [ $xk=:L=y;PCl\hP5 u JIR[uAbS,$ԺOyҬ!ۻ =1 NEwڇ=W{9e l <%IN?[zt z-=SDy|i1=U z[ǏUt;f wl\}8CPo̹yb<晕' X=|~5A.s|(6{^-<$hֳ LfX^_혺ԝWэ ua(V ̈́ ^!׭=R\?x~T/ O4~}I3_T^>"|8Fc>tA`K0pfʰ0B]$T` w ͗~Am]}7q;i gendstream endobj 100 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 238 /Subtype /Image /Width 291 /Length 7579 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK#" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Z( ( (` 63@cӵ jQ@1N:qӞ-"Aw|Am$ Rry?\iEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQERXg!Yd3|ϴ8>j?"{*êYʔg)7m53 ?Eh? ?EEx[ss4Xf=y#=[sޱ#㯿 f$$yTPI(OI%ռ4fgU&aށ$ac㜜ZYrjǛw>Ցy os"^^HU$wt+yGw>jϲIk1-v̤g8 < A/jEPIKT`yeF!$!G?Ϸr(BjgJn\ $FM#!zp!ZTR@ Z()H̕n1YV2-3?ֵhǼ$DkT?_1jRԥ)JU1j%Pb(RI$ӫ3Y$cԓ?N)^Pʙ2S1r~=ElC?ʲ+'!$m[Fz{V?Sk6EH$r>-e*cr-$"܄=_ƴT4ZE}v <‚;}*P:p_Nr$i%b3t}vkUT( @t}GS_N( Z{_ūKUxv ( (4{Yٲ0f|7A/{|O%?BG~V\.B!ROC?ʠc鮋"aN3uX=m$a*5/@5@Q@ Tn6cn ڊN7 +mBsY)O_RAudPl@ ݌>M\EڠSdWNP_jK%( |1p@G- L*%fdݲ r!i},뜿-hPEPsI对X%̿i?,%1ycc96s!۲[}:um@By86HjZ(AΝM~?: {uH|&il+R[1.|C~jRG<Z@Q@UԮViv ժՏu[228{?@jz{Fkm2$9nI]QKIS!ROC?ʐ' vq%ᶜpU΁פ ħWli&0c3ҵi)i)j>8?="8V n/r չ5).vJ"EªKU];CicP():؛|40nmqW+,6|Gd?;P},-hV},-hPQZ u"[Fpfʱ(?7_EWFrq>: =GL01PıQJ (:u5t=Emo 2FўV23mtKUxvj|CEP]bpɬ>gXn$c`! ]xnr>_5%FF*QEԧSOG2@/c?j\ :RYZj_/kB aHU'KTϙ$o ڸ<~8&TU&  r>O皵MQ:QE*봿1Uӿ?vF5Z(1eξ _PLewu'g#~UoE mn3؞M{mSK bݼq8;F3۟P\bօfNdܲR \6O+NYRWP!#_UŵHU'JJ&SMg!F~g4z((}GS_N ۹V]w,@HVrxtҬ~Ą( ߌHڭ]5 *, $P:{_ūKMw\C/SZQE!840fl3b^S#dkV^b9Lȿ05W=AET )OG!R@ui ob@SA#v^*^V UFN,!֨k V0A1HP:qӊК%'#G# ;~i!YzLIF}R8{J)X #'8WM[IbBr?LReDj)QEWNP_jK-QEJut_-a13T=zsZQ@?s쵡Y?s|(7Ta=͵eu=J.:g="B7iUcD6x~vAtzq@Q@Q@ ~?::uQY5;Y)-vHʐyVlhQ@Q@Q@ ~?::u٢ r2"]{dSc4KU?zCU-Tb?F-\ \Z +!N;iVeR4Pq߫{vӪQE QEԧSOGE6I$/#"Y >!^JvvTo05_ x$YgL\I;JZAKLAEPEPUt]эV봿1Q@Q@_sbHG.GV>T5^C?_ӠZ#}o,EQEQE>ө}GPEP-W=bԚ$.QO8UI_!ыM5Cq*sgCS[.m;(mohsۻ}IjRzQEQES!ROC?ʀQ]Df JR@r]VrPJ)3T!^BPGȱ.ߩ-) )h((KU];CicP( (e H-(B #?{"ŏsetZ}*V@~ER%-±$ckV$XXaP }Q@Q@Q@ ~?::uQP]\}-Ls.Z!տ?F-%YGo$$ tzSui{_sO R@=MjbI!wBzQH((t*}2)T(nvr3#?L_RYV-2OrǖT5#w~j[G$lF⇰5 6O l(QEQEWNP_jK-QETo r2_H;ʤ(bf7 ˬx0r=)k|.G(MIÌڀ)BC3,.w"<nj,E;QK>PG2)m6Ecob+}o%]au\0ŀ?M\#0 gB BBf#?>q8}BKx$.F2pR}o2Bʌʻ@2h޼M ıLIocW+MSQUiMNW:󍭍PE^] =}C$*X\C dQY$d\ Hq٠ :nl.Ȍ*;' ?. B,N~$+>APnn8gH΄B"yn &sgVIIka8?:kjN1ۛ 2Dgnj)PyЫƲfb8$/>|{\\s}G $K (a8#?߫VAd';N:gڞhNάØ@?ЫQ FYrjw ,Zob3FNv9)GPE:[t˛xTxZ4^eHJEVHʯk4 A$*wےG@ɨIFasj7\Quͻ($O,H$f6=P> _H땰H8$FѫX\F9 \=+.Rv 5@8q&ޣc _k|.d:̅y1~Y$bs955RkZom{T(CVgw$tF $HtƜ)Ye{9 =>`sbOXL.I $ƀ'(((1KEQekr&7(cjky⹉ftaߵ;ɏy-w &8$ *(` uQ@Q@Q@%-q[[ HWpQ6G=K{nI=;" i"4TɠEQEQEQE636A9 zD`cPA@죍$bf8=?VFo1!GSU-`In =~0G0G\~_.6%,Gs 6AM`}O((endstream endobj 101 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 238 /Subtype /Image /Width 291 /Length 8263 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK#" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Z( ( (` 63@cӵ jQ@1N:qӞ-"Aw|Am$ Rry?\iEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQERXg!Yd3|ϴ8>j?"Boc͏wր OGϔZ$_i8YnWӃ׶k1gE|`c$nC|Se#‚OIigV(k _<:tn= ŢK 3)cO ~{P0Lj_6}xԧSrP.qUk:uQECs+CMPI uj?6}cj}bț$ qy>u$?b[aH9>i˳ 7J?Oj?֠y>ƱdNuKs_O#-eASUT͑AFq 8nRl $6}l?7vCj@|ۿO֫ې7'oǵOGE_PV7EK"i h'Cj?"j_/jܒ" gJ?"?P8?$!s%8HwBۗcʱLvR7qz wsOG<VQOi&s?;g4K{2ƂW;x:ׂVM73Ծm'S4--e=O] m'TWi Fs SUW ԟҡӿ?vF5Z(J:ڸ1oj7-P~oA}QzE3F7\֦E^4s!?MTc'$dqבWh*J( +_?c?}CBhbժf9?:_T(7ΟEEo2fZPI8ik7Y[X3PFϒ¹At*|4ߙ6nm˴QuPOG˜yZCv 2I8S+̰.2G$c>*kefЯ0e{Y0r|Zu)3+Gk'Fp=kLp(>oΏT(7GG͎@[bϝ |z|-ͰaOI"54J XU;CicVd9 79?'ӿ?vF5$9+dRxfUeG88#0qׯ7i1@N-0[&Wk}Y?s쵡@Q@Q@TT=c 8@2I4ߚY[0ڵ+< A,@g ([O*SKy qx4S Ps"95T_!ыWh((B']a*PʿȞ]FxVM'K OOj<;i,ݷvNz 3ޢOܙ[deI'$&aRLFRT%+)!^+??Կ_օQEQQ'=(8SgK($hQ8y\`sm rlCTK`Y2 6PD$Qޥ6Wd.[>];CicU+u&d pd;CicSDTܵES3 (31c\kB1c\kB ( JZ}1E (Wv+_KmWǽdE=+y 0sX>-˛c'ʾk8g7|x﷟J(*BQoJCnz EAiUxb19#Պ(KUxvj|CEPEdks$vBw6[w kol`X|M$dcרRw7傊ԧSOG0Uhm$=~]Xg9?AV): }vφPyP ~?Zت!^((+>uRYU^bq+\@~9.BuSIv2LH4fR9Uʧ#nZBIaNqՎ0ޒ51A)4]эVj봿1[j(AIZu KF\l|$!ŏse ̜IfYcj}ΧEHz9M[lUGy0C?ʟLJ?2EGq?QICpN>⛃*!eyFpW' ;@m?:큁j^SS*:NC?ʟLJ?81x"h2ܧ~#UMX9{/9Rl~ϡР v <=~d rBkRC Ke hPPJ@(z I0[A2fm=35J].6C$A?;g nv6v(lTCw,rI'Wi$]GQEªKU];CicP(3\XwP1yr:w:VhS[kxetbz"m껎N2h,-hV},뜿-hPXZFiXz>_?5q'7|qXqNyCT ʓ4Ա VW)R!(>ө}GPmuĮL$+p9Ө2ɩLQn;FTO|VFFUEMEg걧 R< r?xT_!ыWh`n61WlJiv >ZxMbHmaq''PWEm,_*1 diTP@)-Rw (!LJ?>t*dv1Hc}3C Ke hV׬ mB7;s8-l!>W]eKK02I %OֺbR(EPUt]эV봿1Q@Q@?sfQ X.RpVŏseudH-GIcIwaFv܉ɑ??w㞝+f?.%^RPO(dQ@ ~?::uQER?F-]Z{_ūV׵@lM2%9>jn"B|  Y5 I,|>HkE ( d?SԧP"BY?z}2Xh920f%E͵ sP`JוSڊU ^8Tdڀ2mѮubvBw8$Ycu{i\f'ҵ)"QL(wƫUWNP_j(($$bSI&'6emFnAץVŏseTmj.rGvMEݓ9rqF5-A`osI~!EPEP_NAΝ@Cuu bIbg?˷|55! ^@F<𕌰HiU-W=bC,Q~"BVK^0Y28T$\IQL(C?ʟLJ?>)(׬k{2) @y ֛j_/iu@Q 져TPpƱFIH)hQEQEU];CicU/jEPEP},뜿-Ia幹<~vGQ]bԚTF+<62';7} ((kQ>Ө(?1iukѧiMϖt8&?1jkqٕCd? qWc?`t*$b҅F8l>+J Z(QES!ROC?ʀU3ZKRŔQV( }f'O ]-n 0VɫZ1ĊS(Zj_/if|"-P ((wƫUWNP_j(*eBDJH1c\i+=ro1*3U5)I!FhQE ( (:u5t(4[fb\CǴZR}bpRi؏t^QAJ" `~5&fml8p)cBv(AEPEPLJ?>t*}T7SIHSK|~g@|C Ke >fX`C*ƧlVljrrI`9Cr1Ҵ`@F 'P4MEP ((wƫUWNP_j(xcFqߏ~U%GP1n\G#ҟnx`i" 8?Ԝ8=$38-Q@KT0jO r0Ɍpuq8zVr=,&,a9`hjN1ۛ #8@hDdړv̑1 Tw*񬙵;䘪in71ϻ >7\Qt5 '9RldջFFcvPY ӎ&30<`*CV\6aDc*3} |:V$t ѓF{%`"ETit˛x@$,: R-䭒7W*f`10>onIC&$mdm\cO\s}Gww6Cpv6u'pJ 84םěsze-}o2K eg,[rIFEkcRأGYXTn$!pe 8( sI<Ia0''80(((-PFm˷ܢ68qr9%ч~&=x'XH$hQ(QEQEQEPb(ơmo8Wa!]Dl-aVh:$z6pXt$sDq@Pc&EPEPEPEPTWP`䃎=j[xgǝIA=VW4I6dMZ4vylj]tąN1VdT $@d g,,HXqPi|ؗزci)?CS0E-6]>((endstream endobj 102 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 238 /Subtype /Image /Width 291 /Length 7659 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK#" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Z( ( (` 63@cӵ jQ@1N:qӞ-"Aw|Am$ Rry?\iEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQERXg!Yd3|ϴ8>j?"{*êYʔg)7m53 ?Eh? ?EEx[ss4Xf=y#=[sޱ#㯿 f$$yTȠ! o_e53LݪC G&a -÷2ZIE{iRYZR@ E-TͷSsRHŸF`\3ȓ t8)7a7br4/P.O_֭iK`Y#Hcy`c/j"QLaEP},-hV},-hPEPEP] Je|5=sY!eHh9%?SB`mr$bOrI&ܑΧ( Z{_ūKUxv ( (W3ljHd`|?=fl%hT쌰] SI؋ :@0Hƀ/F4U`RC?ʟLJ?>* ͵ Ip< j_/kB53F$6@Q@!JCRT`X.9 #UhJQ =q 5 jo5q\b}h ~w l̬Z~봿1wƦ2Q@Q@?s쵡Y?s쵡@Q@2YkS6cqjKZr!MbxPG|3r(L8_Z[y0$]\tzd(kUT( @t}GS_N( Z{_ūKUxv ( (4}Y23E39p+QTV V>h/Y!9$~{@2)Td?SEvQ@,~Q a֕g@zР(ZFBNxzA=iJ!ci-IЗ:ˌ);If#dIWNP_jK-QEU+䕦1.29lHgWi(63rp_/˗i:֝gbօQEG4Zl\÷.y`O,~.=smRBge2+y[[w{v6H>DPNJ6GjZ(AΝM~?: {uH|&il+R[1.|C~jRG<Z@Q@Uyv zv5jNO Iq qS/mۤt7Hs̚HS!ROC?ʀHN)jn Km9*RIZOp"M` 9@ϿJ֠4e2O;ˑ1ޭ[Q *AYiZ{ɍCc9|;zwҶrWqheUӿ?vF5ZwƠ TQESnu#k6>ha یޮVXlm0:SwԠ X9ZЬ X9ZР!=dѐ V9-EWFr>_=铲*X8 (}GS_N ݴWc m{n/X oMQ>i#=Oߡ@_!ыWj?1jQE5"<2kq,nlG O,?57+ 2\v03´ acQQ(t*}2)T@H△`|Ka>B3@1j_/kBC Ke hPU5KiaӨ6mՄbW]&P9#8yt:7Ɵr1!$c <;Ww mJK9_ ?1jg8SkօQHNh"a c@#جfh?әW`bƵ(C?ʟLJ?Qդ1N^Ig<=x!yX1U;TZ%[ l!B29N+Bhh6.T€(ki!iVov.#is!'֥-e²ۢĭX>kIJ6K3u^?B)=4(c ( /jUt]э@H%:\:/Հ*qC{t9 ( X9ZЬ X9ZNh7Ta=͵euQqؚЍhsT,/n.iUcd6x~vAtzq@Q@Q@ ~?::uQY5;Y)-vHʐyt*dv1Hc}3C Ke hV׬OXŧLI75f(4TPb}B [?_n-QLaEPUt]эV봿1Q@Q@?s6pm7¢HG= X9Z[3_YÆ L<?Mʙ1*0 I ▀ ( (:u5t(ǼZT_!ыWh,yڅQH GiZVW,7ci3fhlt{v!4 n~߉$4n((t*}2)T1$ên+sSQ@:ؑ<9|'<ҵMP5/@5rUbmfSd]ſ UYD HAys1~ժKa-(0(wƫUWNP_j(jr[Oh4X23d1ӯS"J@89!^62Ff CP5"d@55ZKT,ObХQEQEWNP_jK-QEQEu!/V-%dy"eucT5^C?_ӠZ/jEPEPEP_NAΝ@Q@_!ыRj7_cpF?W$ƣ?F-2lw93(m6V0[b@rݏ9?Z(()OG!R@3@ Xc%Ch z9xZ+I9F( {ۥ\xj0I+ %1E_/jXSNv$)Y&&Zc ( ( /jUt]э@(^^[t*M L$ C?_ei)[I1KP Ē B62B?XbcA@@(QEQEQE5tkQQEAuqh26ĹjVx&$Ydo$%!o$}DG7Vypǵ4$ HOASi"ک#4Wq$//@(()OG!R@;wh#<23Uu/@55[qc[Z5X-&#qCg֔vmߠ@Rb{Z(Š((KU];CicP( FVtV+I~?!TPBSlVuG?sυRHE@qɩ9q{P1HfxPǘHyj)cGE-Ȭz>׳cLPo>?]D,.+cɫ1Df$ ֨A]W=g:z~>OIo=Գ`NO>?]ZHYQWsHMU[גc BX) >jcɪj*M!ݱ q'\}q: Z(++"a"6 8'a$K (a8?: p=j+9d̖ a 0q4]'[ͅs0AB\s}Ga^eiąw* ;ЁHQO-AdvL _4I"X\u 2cMmI;sauH*;xLڝLU4tĘgݿq k|.dasE 2cgjX#y#1(,iLSS{cr՘s0j!z+.MNoS0A"^1T+WymXR:hG#=@]E(X`2Q@5 s.so ^HJEE^if3yHU l7$€!P6Z26 o;ۻvQ H;_F:=x> stream x\K#G&.w쩅GEe6?&YvVh-iĺ3?? U-KRxAaVuvV>J雄3H8/n“7&:5.x0Iv#$Jr&I7L&M4gHә{q颺X]6P]OgR|΀ S=iS"L*ǸL n79f_nCh_9Xd^jbCgqe1aD2:2m!,2j^48&-L)t$Zc>r!7QHՂϖ !rH0ޖ( #Gn!7w~ B:ߕd8S@K“?Y% WֆYcMf B+DiM)J(y.IB&\ xg$$ecTGm"$SshjѤ7QFJ;Br]Sf͘s[`ۅgnjM[]F)Ke(]L _:c\A7 51(t֙ͩ ݪJDpn#`:l[eϧJ 6P!u(Úđ!ܳ-YRM&ŒBm"Al ڌ_i>}"Mzɋ2luT0n90S9-Mh*Un1z * Bd[_G"pduv%ՙ!Cdy;1m+IMMW!2z>άlt:ztJ@m9ïr=.^g 0tpdGcӘ==3J10 ruay ^eCs9@n(LfSpJ(}G9 SU>o2RgDڀh<2pݐH&8"pZi吋pdR2}D.d[{r[}!B"}EU~<֞)z`23<Xޅ8S&ń^ɊaE*ő.sPJgUpH̨,'hjyE2pUtۯ@C:ʀd}4 TF8`h6B肐9m0+Ѵ_|1?$ӒhkNJⰀ^]kH5]kIA.&tWXU&x[3+W3b*[LYXp`( "TV]5h =6Hxpܸj*p qf%LɎy&T=!ד/_&<=.1b%K.YOa*|ztG!k@ ׎,'4- &^ɱ4 =vA YPi|ZBRpt=DVaȫ_T[Djwv;/CB%`ә|qmftMєQmәxhB!g=vv}u̾y/X.VG/޼Zj7g% 4S=u3Q/`!~$z]:l(#\)p()ծ>Y$Дo)ɲMz dіf!ɢ\sOz4e58O}ǮJfTYO֥rJuL;Ӟ_bG@ES4O{*4 Tk}\lJG2ީ@UG.>$<#@?O:Y+/5a5x4'y~`Az:G(9.wuz.0*ihX =KZiu+Y"e(ϒű&ގT8BZA%5c5 c8@Qn W?ŇN]-,ݶY(NGS7%df/ZAUABeXhR+/WFE]Þ^/qYG>#YWo8v߾]҆,~ܵS9`~tXh+Qh+7 \.֊M4ѻegϑs̍͠-qa6n/xD nhi1 BQn/Ԝ=L(,A1){7*̚W O>l+/o9Bbt"Z72}~ }tY/TwR;_Ȁ%K L B%Ae&Qг@)P>ޅiDa O;YF"P_ b.ȉC/oN> stream xcd`ab`dddw441H3a!ܝVY~'YyyXV~'=C{*$fFʢdMCKKs#KԢ<Ē 'G!8?93RA&J_\/1X/(NSG<$C!(8,5E-?D/17UL=土[PZZZh ܔ?g;O&L={z })Q7iB ږ&Ɇ)Mz'͐+]yڴsNƾ2|%yxTiyendstream endobj 105 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 238 /Subtype /Image /Width 291 /Length 9593 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK#" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Z( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (fdڀO >g?P@(o?b? >g?P@(o?b? ?,?ƀ,U,Gh[B~4hYƀ,U,Gh[B~4hYƀ,U,Gh[B~4hYƀ,U,Gh[B~4hYƀ,U,Gh[B~4hYƀ,QCs3G&޻~U-QEQE[RuqiODǖ\n3}4GA_ e8Wt$ke}1p0 }1'[v(X~auٍ۳=sTag\nBA'zH#[ Bd 㜎J.m$E̲Y I$pGך۱6 "YJM 3w8GXV˻ulpO\T_׼ LG9ij7i&cPw71Zq3%.i8sXmȯ>ֲ:\KeZ0H6#{hG=+fI'>>i3,3(w\4z`"0@1*/\`5֛iBFDD("}{?wF5 !cxpqjzT_h}faY u¶mkDdRL]q]1Ǧw7?gs пvk)L1[x*UΡOOL C.n٘ev !UY7@ -<`C! Ģ3*/!ظ,-E^:eqmnWIGp0k)0Ye vB|xsDԣa巊vPF01G8O/orX2u x8 U+tcy%HA$Gt3?)SjƋIaBn9<4qj+cЅK@fLr\E8-0(Z*% "@9z<ߴ'8fKEDeK,n'qDׯ@Xrp8]iş/֠,IIL't^S)q&9!s-Q@Q@Q@Q@?KڬUu?6QEQU,5:HN"0ea@ "M#r^[@ d9. A4ls)N{:O~t}G85u&I( r4Z2 {Ab-8i]PP N2~"MJMF8n#FCG(A~:u /F@G! #iB62@%Iy8(յ g !| 3>88gpDbŕ@$dpxxdH^^a I&it̐)!d=֡m A:,e6cۖTn]Hy!Aҫ,+D w`:jZSUb`N?TPՃ1%@ۖ XYrqb.w véje ՞)2pP[9RAiƠ4eY>R/-yN!i{%Ld*7x8 KI~׷w_r@1yWёLʲ,9x2Pɘ_UٯRo63 a'ր/v?_Th P|ez`5@Q@w )3QC/ߥSdE?qOn5%Q@?KڬUu?6QENZ b hOrw18ӎEtU{?suia*/ |n JP1qDa&U[(7\O3qmQg v!auߙ9=sQOov"$H2H$c?(q:#Ȭ̰(&

vc_cx}d&yόg=3 K\O6?LM[x$dh|J=>a2\{@ EPu?6]OͪQEaemNK գ1.{:gn* A4-wPAB`Lu_׼ DaQ"dۚ|ĝ~ɒ'Ac #ygNӚuSIk$p\y3IJ*70fyqIraߵ.@:HeciivHIPM)\9-@L ĎF$18x|ǨhZV471I@AVG! G =w.w!p?߯l=)[' zs@@+ %czzSS-44*?5-v/i؞dKLgU@'ޚc3ƞ 5c4an!R@Y#O0,ݗsO4ǕuQN)P__і}1,|'c'%ǪVJ4LE~Hg;XOͪW_/j@Q@Q@71/65,.@y #s \O,amʨ\7zҴqU5_׼ tcސF>`#Y-KyYI6{wU,"D3.qM>s0 x&$M`Tƪ-|+#7osJ`sxjGk}hvJ( ᳂c8'KR;+4k 0e%2W=g rihKmG+.bmېs;#LSPhRMFѶx 5t7}^QGN1xM7ZMkx!,}F|zphm K\yz1XGl|;,m|뒙E36@u0UO׽GA䋮` n-2+*-ȟ2F~n'$U p?$X.p8TQBLŘ6R1=^y'XGǁntfKHMFc&IT~iokN [O1jȊ39)<4dJ$}N*?#q:QI 'Ԑ]}pX!3(:E)x@Є+f8#`'?RN4ާv LPXO:]BDO*9!UP)>~t\J1I{QTs>IIҁF@OͪW_/jTEPEPF,{l.e]##zRky?QHB8@C"T`et\ ]n6}.]N?)nhUSL6Ѷ촿1?.x88#k'ͅ<{!p}jZmg8rdsF{bF`2Gҡ[220 Jg۟ONǃ@M1~q#ƄW@%188_ $s4$W;c*+`.Pp9sLJZKX*U)cgSes4Ҁ$ppE|~l; 2Irv +v[q9%vȫwv}Ks e0Uu#mVQ@B)ر̀e9ߜX{~~}3V s3)rM Xyh8E 3VwHs1?Vr,Jus6n@5 RzZiqd7)R08V&7J3GOƥdTm ɷ!ri1,jpvzPR2Oϒ/@d\SY7%}R` 4CЍ Ub͗cMɩ@÷?J\C~aӓ(۞/y>osi 1A@f'S;Q7 O<cA p:J;M9\Tm, 3il?A9$UXHO0EL.9rzeb!qv'L7E1 žtEO+\X%mV(((* =GeMH݋gU>cy=m#zA4b RHͤ} pڬwmghFF\w8ϥC`t)K鶛$trL 8&IU8$pG<*@=*S* ]#'{ӷ)8cH"D@yɁ&[R>h,Ve6Мֆ!|r=]@r49ƪ~k|^4`sOLZ'xϦMVi[ 6d)` }vN\Ero3q:JyH ڠ~t @c+҃1;g ㏧S[ 9-~jX)꧍3g1G,4rҨQRvNHP+@c*:# *s:f4B'r_b\XaEPEP$u:[b_%D8%qjL q(mK>^9&QE[Z1 P%h; JV|qYm=9|8c')?֬QEIRR&LDc)3,W#*JTvWtBig>kcG[Il"P۰#zϰYFFt+%s(c̎~76R`}aW- 6/2;[*zkMM ˅?ҤmlyN̍9c׽^csGC朏֡}7OnVٝ'}F,o!r1V\(*(60mh~i-6ijܞ~@֥s>dU h* 1ߍ'٭Pn.Ȩrs+ :C5= w!6+4ۘ!ӑvû{dGv P~MG\Yҭ๺kٙ IY5EQEwgy- Qg!dw|p}O; 8v0JJH }N3 )1K@0>.qCm'(IcP#lT4D?^>lgC(F-e^BW.H_5IK@Q@څ&)*TIJm1!Xds'5SNmI L_ib[`1`!clbx$fHdMOET<7D̲I* =g,O |th@1,;ZAtp\CbمF~֥(((((((((( z6;vnQN#./b1ȧGbN1#(`hZo9+pdkI!!PC z@=x=3V2I$d&#ۀ W9dg9!puL+,l)68UewK=לpKy*y=9zL Z( ( ( ( ( ( ( (?endstream endobj 106 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 238 /Subtype /Image /Width 291 /Length 5811 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK#" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Z( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( +>[#0 ` ssx?^*PA>xqUo ?/g?pEVг?_ 4Uo ?/g?pEVг?_ 4Uo ?/g?pEVг?_ 4S#%@:"@Q@Q@]* O ?/*hг?YhYƏ ?/*hг?YhYƏ ?/*hг?Y fMv08Z((͗NԷr$ Y]󎇦~j~ =GM_A4~((((%LP #wW'קyW,g D6 =1fS;G_nO@@hAOKQAOK@( _ER v:x9ctOͪW_/j@Q@Q@ (J[^^&ܝl%mBdg!A%[o_Fm\[K1Q@TQEQEQERb>eq}W$,D,_R CD'Xb UR}MI@7 Z(DPuRPuREPIYڶ,Xɓı&;r{gVy@_?sǜqEPEPEPHzR;]KHYVmŊ@T3 EkA @BjDT@00)]OͪW_/j@Q@Q@P׿׬ C^^&/EQERQQ\L"8,O A@ rơl A%rGS%&%%et=!-SQEd|Եd|ԴQEVKhAƨrxehIW 3%TuE sp~Fh'}\QEQEQER+uAZQEW_/jU?KڬPEPEP<G(|^rn@ lwҦ݆~lٶG)54m,+3@|qAB@=yk_( (uv<>xϦ)$g ˟Ez}3VdQ@(('楨'楠(8jZ|sC$7A*F9 >xet#AWE9?G=_ pX7d+B ( ( (M"!"cZY,™?))b=ysi2srFڧ#eĒ>U('r_b\X(iPO@OZuC^^&&ne*nߐJg' 8'v΅׬ QE`Y I=.jnh͂ : vX4\^&P)hŠ(AEPEPPuRPuRETKĒ2ry$V!Ά9P\aGB;}%-%QOWꆋrz@Q@Q@S@z{d[m,rN fHZc01߀sKdR\3֕P׿׬ QE!yf͵<Ɲw!1T?1?JFP C8RE1Q@Q@Q@AOKQAOK@0EoL&c`vrVY#H~R@iPı\  SNpr0r5411$Ij(QRy?S@uP$C*ppye8o2ycRp?II@4LL\g?Bh'}\QEQEAy?T?y}'D|46e*G?sڭV};y$j ( (+\X%mV(((A5B[k'̠sh cxJt[_IIP%-Cu)&`2 @nFrO;bqǯ1)F" %'':(QEQEQEd|Եd|ԴQERU WT:o!J%c=늺dC0aO@_?sl#ol@Q@SQr v`rr=nf[mFq ~4Z*0 I45Q@Q@Q@?KڬUu?6QEQEU {@zzT5?/hVhcsvf;^8 H9tf>b>aޝu;"VvPgՈXT@B>(((( %mV*U((* =GeMH$& 1 =*={@zzR*¬ Zo`f'tU@AhQEQEQEQEEY?5-EY?5-QEGE9?G=Ms;ۅig\q$TgNI[ .ԙ=ȭ$)/ p?&kn'2ǻw'(((((U'r_b ( (2[-Tq6Чoupz{Ժͬwmטdq\kB1-C9M/Xg(ǦƤy}:<8sK@ cty}:W]Fqu3͏^EqnݱB(l_Ώ6?O-3\ɿw(ߑWw?I{yq<{qqSmhm>a#y)h(7UѠ&gh1G oS=GWeIbH2Դvsf]Is2?MxwKN1"y}:<&qsOy}:<>E\h4y}:<>#۳>c?Oրct߁OuP>Z͏'{o±ٶX3[~4KfQEQERP+HeK@Ù 2Hz.=ONdHQqsV A dZY2# JN-6VAtF 0HcGiQ@ Eb^{, c|ÌNg5VM\yW,6 [̏8IF()h3.'Qj+n8\ FHG"M|ۃ0&?+p6z:LP=.)} H[ya Q@Q@Q@%s(,`p$ )|簫Q@ڟriJҖئm˜S^-Rok}3yt?Fv(hP^mwsl7< |`~NI,Tf/>d|?\TPm:)bU9gnNJbUsU( ROcq,$2+ @ Ջwڧ. A ђÌ=v>, Ŷ R >qIK@Q@Q@Q@Q@Q@a:5Χ52K,PDft|,ۜ>S#2O>EcXiPU7.v_2F:lEQEQEQEQEQEQEQE_=F@6I+nmx1EshڔV1\M (GYrCKEQEQEQEQEendstream endobj 107 0 obj << /Filter /FlateDecode /Length 4049 >> stream x\n }S:I/FH Bl1(r%Q"riE0TϭgwfBNh3:u.cfm~²ד&<1ɾ<2_x#LvjR3%Y!ɬ7No&/tY|:Sx_OڧnۧLj*}k3<7etXy=_ 3(-ͤ,KdDH"S;ܪBf"LzM3H Y0#.SX@h.$OOߖmbspa-Y~jx,'lz6mf%,2A^q8cW7gbqrwX嫫8Y}?#rY$|O?ݟ ya0H[/-UCҴXW* <^8]3zaߢ:\O"j}zt˜.uCpPG5fy%AzLlR^E'1!Tqk[pPڙeY_^aW$Zu-/_^]_>T7^b0eΠz8HF^@[~?k/_<,[ryqR.Cpv6=Qؕ T_+(7\׉2GKL-oihqURws>=Y#a `Ч2DHF䑍Fn1"j/ۋ~EpA[Yk$:" )Ŭ6v==<ĨӈZ]_P4P0!{R. f~oEGJ27pgC+cUqOW%=mE[H)zF~j)Ktr\KKbVƷ5ZqƹBČ/t6WS9ݼu  tGH$ŌVU(fA%x1g3e _;v%w.AFc dbb)jwDCw 0nK@"KJF@ FJ2QPRiYy+hJS⊟3Q1q948ձئ>S~KvR.=k@̝թSb/LP,Ț$rivYa20?l= Ը;jkxՉahA5SLGMh$*4"I8MfUt'Ɂ c$8 C}&JPRz~q~}].uzsn.LPL?zq*9fhtT :$&5_jO >t6L&Q84o@~klIbncYdL= /bwlSyb;za}87E!ЮwF}"'ae"' iG݃w)Ρ豴,@] K(#[tX! &v"K@Q%X_BJ^2`4co- *F)%/K,=N0w Di)ؠa1Z :T&OM um*num9=l)SoV4f)[o7얃9jqu> N!mc?{3x%k["OH+zek΀qt@L C:^z)JFSr ه>qe -*V& p3)/;ӿ_$4~Wו<Х~0[/b+M]_FtVd؟(JH7 c>v"@%)]ztvl?UmNov(rjICcD]JP8'0D*yϋ剃 };g&7#t[?n 2XFg\m!P]Yt0 {VazֶM(Rszb@ljZq9]0 jbt?˱O5ݱҸq8آŲJwV):MKZk"j0?n?E` b}G-E[ *GV׽}[Ao{tStӤuB5t$L&)ɻP##Y}Ok;,K[ M䦹SA ;%Jڙ-`T7vP!?uj: *m)_`/`̹KX)'X oUneQ )}c֡L&wn@wH]h9[gUmgko7tF7xKnFjЀ!ƥvzׂF(#鬂JHlYESOqyC aT|ud_AuT|YP6yO!^SQ!JR' g^yRysN ! b&bɮP,ἤj!BK*q'P)B^cEdrBqHJQ%*֗0Ms*0-[)e}#~B!qYD鑎ݡi'MOtFb)Wz"+<[\\dW%-H-ei P}jY&Db(8{hvi(?cW$z2"}Q+J愈{=n;_;#~xot{(k^JIQjf|2U<=_]i)?|G[/Ȫֿu.nΗM~3?[[(^qf=9_o˦>D};'V<ETGk(y}5~f]endstream endobj 108 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 238 /Subtype /Image /Width 291 /Length 8796 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK#" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Z( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( +:]JUEZLѩP`>nxcw#u۔]hF\ジ=OI1+۰6mbǜIvSKz SyQrpy+:+V/HwF;~vXz*;TVVGH0|7@zP+<|Ls"=sQ[ʊc]9r6r0A'6w(1CFI'yLO ANچl9 9 j]%jʗ,F} SUmufT]B0z$2?G ((((IԲ"Ub !#rOC8=imV& `(s,jaV~Uvql_E\5OSJ8aVH8?(Nd GPeIfxp 5b4XQ* $)Lw'qEKo7H 봟|?JP %mV*U((* A5^MN5ah,Ahg8~]x/O`45}4qړw+LvsJ XFN7qӞlkq5%r.A;'<[rSȱ 88Zd_-@a)1Rn|w^yXF#E8y3>?*Hc5.a`%%+oNd8=-ީbrOaYmQ;\DuÚ2/)V\Dj=1- t9 inVm6HQ.WDGdqjί[+J|p(N6aP #[_X$|D*qe i$6 B2@イr18ȠE+6)!-RtB 1AGp@ʪ%Ƒeq O J"Oj1?IEPE^kh0$5b UݖlczhZɕlJ29ݑr8s(k/- Ѽ;lrE+];9Q.6ڭK@ DHj(Q)Q@Q@Q@Q@Q@?KڬUu?6QEQEKbx 23:X$`Co?uNvzipUqNth`g8ky?@؟&)%2qԊϬߚT+1o$x'4WtU@8TӮQYH R \X($0dAҭ^,v3Uc%+gUM2S┠B` H:u[oi,kI?sܱ9$ rLm^}c9eU w3r`-m<> 9T<[4 hUJR\4KKᱢpvhʒ 35KMfB{p "rA;I$ *0kF$ņ`Hb)-ՂҲEyȉ8g>PzրOq,[cbS.3#[=Sac%NN{cN%?6]OͪQEVMޣsm,, 4EU z7`H"]J=\(,dFh8 pOL$p@?)W*v躃uŴ4mˌl⛺o'=<^z-ߚl1clpFF>_L2їlq2ޮ~M4mo~XK{7Ks4$!*bT.95.nl 'x9m./?@&m]^F-q"҂q{g$M>+mMVln%Da@,jso 'Wm.[ƀ2EG+BN bX%X #9+'[}?&eylc-{ƀ PIcc,DQw99?U/?ƥY"Er q@QEQEQEQE!4T>s m\gdinv=[1pm=1Rž\j rX~U%\(( %mV*U(N5a<`oƍi#ɒHmŴ85: n #*f2,A~ֵvlr@A4=x`F+Kgnmݽx]^&/EQEQEQEW=e1BF$l)v8POWwRo6{NV/v߁ے'KKHmϗ ,i K[q|9#s1y'`v(((iDJOVHIʱfGI"2v {:#P.@Ch AL ?Jr C!"i?ߥ U=Ibs9p(ATȄ#]ӨvH'r_b\XaEPEP7s-$"_2 o00.kC0,-1q\m}i9:A4~(JϙoxXmPf9Nx' nYCZĹsgs~,hTPEPEeQ94rIRK6"NӮjڠ=HF$($3H*cqp)1f yTq~nAø椊!89,rX}O3B4 rzLKٔshT6 z㠦MD!H`z :R`Q@Yc<.w{v) $2⢊&"_gV v N@wd<`T v`3s֣hJ"da 9& Y0PX$~TaijmNI 7™! 4U'r_b ( ( QYQ2d 'qfzRk:^&/EU0"{L6ȕSԟ(=B%uKaɇX1[) K8*TVvm ػcp=f=0"P QG{_omK :A=zq۞x̻HN;a4͵8^`Qlop3' 1wbye1X:sP+’.P8,$u=JBŲe*3Uc֟avnhGrVS<)'^}V |sq'o=:uSg۹Tf_Qa9$ pQ})L 6zbvRJ|b9D*2d@?ާbuc#u!}9)'Rz6խ\`*=zTgT7 xr?shfO֋1;YY*IEV y#|2:r9+e‚9h$q|aYYA=@#5Zf7Y6^aE#&OUGmo[yh8p1@Iu*2U7r{z6̝\nv(ٕa")&@NORg>n2O*hFw}AM io$?5^1e?uJI@gsTٶǟq'Z4PFomsu}RGᄒ?5˶O[ƴkM_cGC8ǯ+I08## a0E8V'MJVZXǧnΕ#Z;p:tQdY}Q/ꥪyd߷ȔɌgwˏoa(tQKGJ(2?G@ #ty}:}24ؤg9bzzGct(l_Ώ6?O'bJZLt>Vi1K@Q@Q@Q@_G$SeF6izVA@ i@Q@aK<.@YYc*~\xEsoj8{]L'e( v2SJLRE!jZRt6OԖ5;)FeCDJ#pMtTYj/n ! +$JP鍯ݚڤ( mBPTIa*bY6䐬2N9퓚jk6$ &/-00ciP61K Wy$JId&* {fY$Y_a ?v'CO 4l p -ng.c!1m# Ͽ^MkREPEPEPEPEPEPEPEPEPEPEP6]^Gqi*D Hw1agQEw\w!AH$ޢREQEQEQEQEQEQEQEQEendstream endobj 109 0 obj << /Filter /FlateDecode /Length 4408 >> stream x]Ko#.9Nl`~?lÁa^Ám{9 yu3H^.S]U]U_UuJ؄W}c&ovgt3\&\f'8,{M[=1N1X]&LQBb:6} ?M34|့+Mgr'f?P< H3IN/A1?8|Y:,w<{4g]U77~T\ cߕY8ȹ:Vã׋o}U~+j~eb8dq2aeej.&ZOf4C2Pp&Z#Zm_$ QcUfs adIsSgN˫e2\.o2l!V)x )dHɤE4ZPX06?)jp,",c8Nf^& ˤ!p#9/_]<":`Z-zH˜3`FGSb2hi#b~Qiq5dk i)>=+h aME5X75$& @M:PS^jj?CjBUy,XD0dS'n ㅻ~_ㅒ(giCryO$QmbjZEyr@% 첓Zr㺏i ۍZQ0sK,Ef$`SZqӒ42\0XCp2τF "kr[2P`of9[E7#;-nIh[QѶUKG^'%%F5m8ܪA`mj!jOM'fGDZi>-@+Lxn) vO} zE@|seQwPeYez>eTey95pOG83mw,)A/M :^?u;!iqb(|{cWyY"K`̹g;ÞYnSJmdƱl Mq"3GsRmeMŰLNJ#pdP;48ڃGsܰ[lՙ)0Q̀ܥUo$Qa @Y18 bb+%|oŸ2؊?V^@8Ҭ$89{M^C[BtjEk >ky_|ܵP"V|_c -KaiR\q4{)Œy>__gm 2HagkFʂ67G6ԁ: q>H̜ү9a{Ab1CѼ>:Iş?g9YFj #[]iQK,LF}-),_jW2$Y0v V wrԪ >8=g#b Pd(_ܝj[cu<}=9۠{;hs5 tG-cM<:kr5OӚ>Ҍ9iuev$5#$IdXUi*(k+:T$*@*, k*+ }n̸f);ܘ)(%*957 92wxr\8olX)+D*ۂck:)[aӅ22ԞSd9)UPj9wYK C > @ @<ֵzN!wb:v6VwyWើ_ O@B:'6ĘGk,qf`\cݱW`@i;l0wU<3=^'m$w3c~bߡ{?/OT廈x .',"0`N wA>ۅj_ӻP{av: {tNer^Ȳ|WkxydqwCKHl\ͳ&z/tj:J[<G4jf采źԺ.EuqtX΀Ѿ0%`,݄;S-|*p+׈$h[ V&]^U9?׻f4N'Wnj1,TTR B%e.YQ%U j-<-W˻]u%oWS̷SjNK~(Q!ǗgL>n1&M/ŕ( nNim>N#Xpw}PN#јa.ddzʗ^_J7亨prD&[i{s.Nˮ0ןЄd`%rXxR|hJuevкy|A #eiGY_ռ$%"/˛)^Բ'7&)7'nL[˙m}`t/Zuq܊OY!wOU͔x8 `ECgzѭ:杧:v=?${B>n]?n{Ku:Be) Aω0u*ԊwPr@𒯯2NyS]d (*Qlg4#uE"4- gb*[M0.DSz`J(-pog2] KC:{'\j3&c<Qg7?xgoi%v"xv:~8xX/j1] Lbv#0k Ɂ4*bvy=U)X]WFGH gć 4&by|V0 y by>[bR]N&`4HI4IHBLD>7ǎ R~L., !Blnx !F8|Y"YO'ɧi|ʢw)5O?-<PfP> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK#" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Z( ( )+-/Svh,+˹rSg+l<tVF;dK) :+`1֌کܱW^6=GKM-/>=QEQEQEQX:^n|.L{7A([#Iۢ[󲺲yF>< t#O: @H xn@V~m+p%T 8퓡@Q@Q@Q@VM{6nLk媪FLs~88<`Z—OZa)ku7w'YCː.aRr; wlYwE/X7Dc85@Q@Q@To4QȊp>޴԰0B(fhqp}E3 ?EUj?";Q(?$bU%Rp7nb1Q ~_ ?Ev>PI*_ V#u 'ҤL! X) ?Ve@"ngҤn?Z*GhrP.qUk-7yJ'zպ)3KU#E,K*n1E{nU rHͼXZ~L.&Ud@cv:Ȋ@|o??֩nfb.NBarʚy8ǧRC?ʀ(+"aM!Q|G|S|C Ke Zhl;}(ϔPI*3L|6ORѲaEs c9#s(v>PI(OW &FZ\\ՋYo+e#9oA/jEPP]˜ATP\MϹ ^ }8[:u$;rO$*pWI<wU1 m~Q>h#A#9 g:oHSfІxKTņ@R둎sa6v<L?*]>'.6@5Lo$e{oųx W)}G (VWuBXJ䵅fi/'uB)2gPZE]~Q=qƑ-H~`R\ XE;zE"N!_gL' l L_s.Fy͌F2~`A<##|g'?"9DЍOK_|ݼ8ק_fi_4,QBĞP&Q>UaopIY ¯C?ʫi,KKpc =՘ԧP-3b4 "{w\8 ЊSם_ڋ#VA hVf_m$o֮}o $|—P$b̎sۿ;?`hD m8 9t1 %_e#n98o} ƀ(ê$lF?NzBu(LU7Uxv*g χ?'V ~dχ?'V-PI9''SUuMNQ٪Q孱Pɓ3qw&w/ԧSJl?S}Q@!^+??Կ_օQEQEɦJ'(7˝3´JłF5 -4Q21nC;rOlmb&lG5EPiKU];CicUZ(#?-s!/Zs!7ZQEQE%gl^{ud $ۙ[I~v gF~3BМӆ#C{$#Q>ө(ǼZT_!ыWh((Ξ\PK3WٹPNXdq>RAfɍU>g>zQEmRWnP@zbOSWV d?SԧS$}TyE0u 2w V5/@5Y%<5x| `!z((^ :{M*. ˒#4Uၘ˻uf<>j6YY3*)ezB^];CicU/jTQE△;6̈́J䟻9@ya@s!/Z:|.>zӠ(W3-66ƅN84SJo9 ȒbT=ЪZ<^Flv0vw<𫴑RkQ>ө^Yu"w/X+2h?WEBDxH"&+ċձҪZ{_ūQESXN#Wg1.9(Wv"lR(V7h9;@ c5ڑUp*JC?ʟLJ?EP׬ 5/@5@Q@RPM ^8pVb\ek7X\YK}fyｷ8\@VLvUt]эV봿1-QEQIsR},-hV},-hPEPYvF;{7}qZ3uxΦFt}O8h( R Z5tkQQEKUxvj|CEPT.IYw$p06ST">\}"TK"Bt*}2)TBqLhdWp /QWS(߁iV}Ʊc\kB (vZ{1@ 9ϡ>jsmg<BT8M-a<Z(!}GS_N Wso C]0?7`x֍D901xR-W=bڥǼZ@Q@ vdڳ8ۼۨfקנ65VaA)Rd2)Td?S;YknY}kRZ,)+I#)Nj3C Ke hV׬ (Cұ-{J˟ا;#}umᨊf HiLi-ZFRUwƢ-(gVªgy?;CicP;5j(AEP},-hV},-hPEPn᷷`I%mSZ"JZ}Z$Ģ8`Fc|W=(}GS_N)ʐyQGR*|C-T?F-]( nR-Psw(x #9Z#f\[$P-G-2ۜEjR)삊(HS!ROC?ʀEm'ϴU$rGQ@C Ke hV.C7EaBjpMFÒ1'?lE%VņqtF*2s8j-=}NjڮP:E;cPޭJFU/R0H+KoA=S%B(v5lj=Cv)nZVfrO|A)ߡI.i cg,d6Lu;Oӿ?vF5ZwƧ-;Q@2 o؊F܌=?zELP\9E.kV1c\kB CKUk{)Ly(B~t]%|ƻ#`=|Fp| OV(CEP!}GS_NqXك~ g"A xs xr3ZUKUxv (c9gi^P2*6\ʴ?D &uO4iօ$T (!LJ?>t*}Q@!^+??Կ_օ c\{"#UydHby$`YSYZ!kV"[ͺٓUL7S_\dH$`};'J<]>9&FF6_ry?ZZRwaUt]эV봿1EPEǚ4eWUpOJC?o+>C?o(%>i* ;Yc`*>[?Կ_օc8BCFG~@Q֮K,vŁlvE]5f[Lv] =;L2vZ,-4-+xgc$fH"mre#`~o/V,Sc'=kD 5$9{EUWNP_jK-QEU[wd*ኘnӭZ3n#[|Z9r ?JҬ X9Z@N-meX.qJK Q1@b2rj p^I3ʢƯ(AEP_NAΝ@Q@_!ыWj?1jG</,#RqɪSy>ͦi]#q sSu_߈l?͆ }Auu+d-QA!EPLJ?>t*}%-_/kBC Ke _$C"`T،hw&GNf?,K<(ꆕhp$ q^xC?o]\Gio$6OԞUqZ9)K=OҤK,| vlK> qpf}|r}2M]w (Q@ ~?::uQU5)t~ R ݅Q@(t*}2)T(nvr3#?L_RYWu\nV2IhC=/d8z >֓vf|6Jc#aܐ1{oEGDU@ң-dHU8o],*QEWNP_jK-QES$tV(ۗp=PB_D7.8=oyeBv=쨥k|.QΐF)!I C@lF]KxocW+2PII o~+LtKL%Et8;XdS HG 8'ҢIT"1>BN8OoK 0Nxzw8ړv|9RRo/2B qԌ@$('젲g;O{ho$,.v1?:kjN1ۛ 2Dgnj)PyЫƲfb8$/>|{\\s}GahRTdЌ~ۻo$f7d$r3O4KABlnCcB1@eɩ#mf$K2?wбwʓj-RKG@9Hg(ZkȥC+ FA(ne.mP Ѣʐ>y+g7W*f`10>onIC&$Mdm\cO\s}Gww6Cp |mxfGy#1oB:l.q>}?MP7Z2 5tJ 84םěsze-}o2K eg,[rIGZh>'-4pU{e>FRI1 ~VYq`バ<6/$ %䟐@?hz( ( JZ(1KEQekr&7(cjky⹉ftaߵ;ɏy-w &8$ *(` u%-())h-P[BqBٲ?R[t8uV*HilHH''hM>((((s{F1 !!@B#(Hf7>{zI Eb*H"CdW=vf$(((endstream endobj 111 0 obj << /Filter /FlateDecode /Length 2381 >> stream xY]o8ѿB&ybwL7ލTVZ>,ʑ3X(RKxxїLpDww0feFìYﲟ,`ͮfMGʴ\z`ʮw%+\}lݷ>ɻ*_(cq[z$A;)/ySol%7*W\= ACz]m(˜|Ҳ}yp'$ۗ rwh%p)aqfYllU}tUF6CwkYom#g{YqUU] ¶P'DŽ)?xNuǧjëδ>>뮁b% u\~GmfOnB`/C :](+ f׉,*͔S%{l}^(pcZL kD xRqKKf6<#ڲ& g$mءrÌsˣNZ.:RC-:izuUnW}~*⡺ae9#]TO&&ID~URr)5\VW ,V PrwmB፣SDXkR~,Rq} SEVqd..KE5`=Dc_{)a HqX)S3%"Y] \5flvO6;x=,}?"?ũWFɛ|^|9ǓԨ)RJ^G پ`FM( pqlHN|^C><!4׾ 9=ZCl_A>p=q|`ŘHI-RB\{ %'BWjtvͪ!q9'=\„^&EK'Ԅ ]^pufal5't禟nk+krky;`y?xCrZyGx~BZpw$x2 ӽ"VB._lQ4VB lۆ`G@5L<^>BlGqҒuFAX%z_a(GwmI+Z0B T6VHプ&Ĩ_*Ӣ!,gbZA#WG?bnP2ic{?7Y YmhtFXyI$c &ǍN`UT\(Z-4Q%Z@TX!V ۓJ\hqD[m~Mvophe$!4=X{Ld{6 D~JNiwL^)9 lD PidĸZ i  k^-l&L0>B9o:V]@4g8)Bܞ q,5J]ԼwQeaF@f Hqp3^ 0ۼ-G$o/<4Rt[]8iT]Q+ EO܊1鷭(+VUn%\ 9*Nm"z/Ov.J)þ7s[`ZF,v}V}Ɨ[ m@HlT+lG8J}.ca_sم߭V2 ʲbK|<OFpA[([7RyG}]$i|~6ߖNPxyko7lMK03P{jHkoh+5xM%A$uSRגR6%ԴL,lM'hK'"Dfn[-ezVd]{ʭ6Ey,Aʨ v3seVVzlN^M]ZW" T- RT_H {gGY2w)bmw~:aKue uz!vK}ypi"=?Et(xt \ΛmߴMC#2Q2 INէh.Nfq'MdĤDj{'ixSˢ1 noqw&煫v>}2>ٞs|>&F ]ՠjG~Iw5@{L{1x2>9G 'j4iz(ww n٦LDF q9(A%lP5Dpz)8~*<\ӓ}"HTt#>?)endstream endobj 112 0 obj << /Filter /FlateDecode /Length 2493 >> stream xZIoFrԯ @}L_d3HAvDLKZעLQ$^{ )E5ݯ&3mffz5] 6094ì>")(VGi"6>Η4R6^Ojwؾ_-K4pWkWQ7t3lfxJA"CsD)Ì5a#[cTxpe~b77Oi[BZ&V EJvOrߗjan.Мu{ӽٸ:53g^VFFr"h,qbv[_` 1ۍ]*/;U72̤%D|x-|s0I BZ>g`w3ahWL%[;Il&#Ia; \\>{T3'e1!2-UC~sq?%dmx:ݯ*,Z:{3q8ݗU..dP.YC2ۥC˂0Kg43‰>oUD}l,Ԙ?ԒQtц*bt{0 fEE+ςWČHkPRPO5?@ٌ㳖Z_!kё9yhoU!}_U.Z,w1[qw'˻y7)Z Nv)$1"fœs/IM! e\F4s0s/+hUd޲(@@X}jdL)@@1r`G)Ác+J1{- B1n>&)ʀ_,44 !2jVOn˚ kR1IuYg2C>ۆbZ +`HdO1meǟdg6"v<.[+WdӍ!ۮVd Ke}%ە Ki|{Jk6W5d|73=I?נII+RX%RPJ/ڵDD{kRTpV>c*$ҳaQ: BY #yj"\aԧWF/@DS|M|,,J:ӞSESM\8!;=Ĩl"r]HLSM_ȭaYPmMVa\)l8: ZpH Ġ~ FM2#5])io嬠1^F'ov}&y^ЗE;lcˡV@DB] R7G9Or Oո.=+ c.4⮜8JRgԕrHm7Y//}p DRǰnz)9DO@p}^t1 U@xj! v$MI7D#mʐ%HஞϥT!4+F>E I]ONAB9c}w>0H܈8p9Lf*:dꔟ$q/snCkq+- T^-Xeh%Ւ uΙ_;J^c.);)u9Rc :s7r?E (ƋaFǛd7Px6|/)`!k.ev*WJc./}#w0E|\k~ scܢO`_;s̠P^u'6hcF =Q1f?(e?M1endstream endobj 113 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 238 /Subtype /Image /Width 291 /Length 7349 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK#" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Z( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (fdPU,Gh[B~4hYƀ,U,Gh[B~4hYƀ,U,Gh[B~4hYƀ,LDz2}QEQEUvV*P i?,@h_B~4fg?p?,@h_B~4fg?p?,@h_B~4f',!96h((g70Ǖ zu& ecI?=T&6={`Ulh#)o! hB(((((N1JHPE۠:j(:h()`[{3Ru\%C39Ѻ s3r3W]gkTO$E? @ ǻicU4bLZAq:E*%q2q֯EPEPEPEPHH'גNI4?6Yo#y/j@Q@Q@ QYWꆽ =GeM_(((('Q9n 򎃹?#~r?2Ts#i#>3t/{O>w4zuRPuRԌ(LQKI@t_?sǜqEPEPEPEcFI(v=ҳu)Xny}]A.H9zW܍p޹ӷ;KtKڬh65%Q@Q@w PNgYcTGS÷<\:M6=N]#=SVA6 %GQj =GeM_(((F OP%<dҪM2Yzsfs7nd{a(&QG$zcI y.d0H 0{SYZ\mj:<~WT;\A8>.FSPH$rʮX:j(:k2B( }d1|6}!C:a Zq0!B*X>)Aq:;#p8*U @tLLUzЪ/y_W9QEQEQE!UbqK)izҰow*{SK0޸9bgs^r~QIM9-Ӿ0;ԅ+~g :wO~*K+r79'AӥwUmE\Y\XQEQEC^^&qq,qBcH&)#'͞xC7~3f^A|Q@Q@Q@C30H{ΥbYϓn+iV!y>?}ZHYֵ" wJl6遹HH ONmF0X|ǠoIh1OͪW_/jREP%ζm_ڀd5C2|'=g8C`[4rFP`a 7H 6m<4"$ngʧoB@84w@zzT5?/hQ@Q@RPs8FG'W~d 9##[zළ<9}}Es61btۅFA,ZEipݙ@yyۆ 0 9,% '׿&=F=8JZ*@jZjZohfYtWyrbWzgd˦Ips3'W g Vo6rV&g .g{}OצN;֥F16JUzZ'oNhS+Vf 3UeBqҪ+[$F.N3Oq't芠O5t_.m<{rjDNœA(Szօ@9Z.]wp@}ѬUW|41U{Z#7צ)@=z^;h| zzֲv B))k!Q@AOKQAOK@/#8K#2$dsG;Zeڴ[Уʃd5 yo-bux-,\A~Sϡ8#aoq"ơvu# %V\KJ!$q8VY#R,H^@ 91ԘgLbMǜqEPIKMvڤ߲ڱ7S{-Dd<яa~M׮dԌ(XGpNXN~bR0K2öPԽmWo|Ut(vQEW_/jU?KڬPEP5掳z֛գ"VA sOlEC^^&HRڕo48L\@;g׿׬ QEQE!83Jy`۔ mHT'QCR7vU#PFzMik{ \n{ڃTpDƨGa(@QEEY?5-EY?5-cZ! 2 ~\ ܂4,"xl-cY%VXB8Q@%Tbp;A#F2Oi[r4KE9?G=_/y_W9QEދ;7r{\G~;GA] 7(%Y$nOһH# 0ϯꆏj v:{bNBE QEW_/jU?KڬPEPEP >Jmؾ?~3CRh$h춲,ӪA4~(*zvEG q-p94, #~OCZ%>i1AդryC]ŒrzN˔+0 ( (" ()_C$,-@x0U *⥤ uQ.nBh'}\QE5"bIC\[ $b3\,~p}~֓wj)gr~r?4%S9u?uc."FzQEf ((U'r_b ( (*˨Et!b=70< '^^&KlT{Jecq~duN'bwѯșL A?jQE!&KxYI^MIJ 7ӜoupU3p2cց&mWaZ/q_,iZziP \0޿^QEQEQEEY?5-EY?5-QEU Dgf'=A'j>q!S´E.b\s4XkMv"\hm .f\(~bT(QE ( (+\X%mV(((* =GeM^23Tu?/hkQ6n*FV3L3J9ǯ'óv'? =}GZkI#wTK@QE ( ( (" ( P<b++ww $ʋSҴgl)UQ~f +R$q1A*iwg7u7.ԋ%cCjQU*x#!F %w)QEQEQE]OͪW_/j@Q@Q@ř ȜΌ˺" ;wy'v))c@,ySІR&&jyqԾb_ΝX|!}v1#6?G@ cty}:mFʖݗf=X~-3͏Yw9?^g͏өv9ctyyv:qJKrAjjJZ(͝nrHr^8#vgj'ِ@ꍁXcZ;Pno_;6au=Cz_Μ*;|y" z3l_ΝK@ cty}:b@VI䐹n$B٘|H!Dg`.> stream x[[oȀER`P@ݝ/vQ(&—lDYTV$!i8΍<'?O))u?u'=;NneZbS돓0LNT[Ez7Yfl!)XVcӇi0vki5[pwOP\0 orX 'O.#T [doD8lCSٺ,dWpCA! P` 7nFTLmDf J N*RAƅiHM)\ȐxN"vZ!$kViGΫmq_u,}k|mߨX#bϗs91[FZYPI |[̊G,{bb1[^$8C2<я&yZNZ73찯_dUL@CVHs# Xv*| %FÊDs -@[*mM E+y^[GZ=SWF״TsmMpTNwNNOU3~T‹3u2 aFo[ L7Mᢽ 3aoEպ -@[,ȏ=ohmr@ :1wym06Fh_RytDҳ\`훘ѻɏrMp'(1419e.siYL0w_0i8wn5 Bl'N@:=aUx&30nAAfaQ (p̌2pZS9f :5t%B0ء*},_.׫j bL`O _#Q\c\ VZp(񴸉$ hyhyXa):,M-' 4z" $RRĔ4Bd<u[$cZ0ZPN`;0~~oiA) kN`捬u<mٸ#'1$x0WL婹rTM<XT3瘂Cub:eXW;4T㡈 @pqjb0Kuup[tqbHJ)Mr[DDUV}>B3ԙNYlҡcqRmc+_aqLtB/ka4&M [fCIvyɼgf]9+¤cI |͇e1tS7)-tom oωn7@]pt"ІPt0^Qʑ,TOTWWSJ[/u!ͦty[z9,ik DDf''{`yɆ>wSGlbIwɍp7Oq|Ca8^l^]҇#ܩ$k4`]eyU5pKmI8׽).^DYK2;es:Qųpn\is/òb\2\O8*C.&ܰ[fHg&w=w1wg\kz.#}Q-!mܶړ>gmx m~w-dV̎a *HxydEԁrn_jDbS&vƅIjv⥖@~$1?ӻ+bw׈vxl!}9,,h;b]t'Rucz!1>~\"FEvƸ3"E[o`hT˽E>Xw τYߦ"Z&!޶+eY|r_&cjJ!lu w 1g kʜp}3? 3U}4u۹,|op<<0Xu={D><=~}a_9Ywωy1ܘ"gx{\A}pD7ACYILW\nZ?ulQ#\7J`{-q %> IpdNS8Mvb'L*m0у3 !v3 Cw0383g*iHk\LB)cSvF`B)F'm0i:7/ʱ!X' oS1GD_7 Q&kNڧxpl?,gIA3We]Wn|O\H:,EͯhRHD W $t: 4ҥ9H@㋮\ʢ+peߢ_&} /p+ea_['09۲`U)(U/L\ SB̑XߠE _%_^Ri7$HKE7C5SG{q}XH-EiGzKc!`i8LKc5͗4 n#e^O$F}Fu]UqeKendstream endobj 115 0 obj << /Filter /FlateDecode /Length 2255 >> stream x[[oF~ׯ  ggΙkQ,,hkE* Ef-tq%:S /0&gfr(9:ɯg"ONM~ˬXm f9 :y;Ő80Naz8BC^L/%=cWՇjpcj9DwWKi\BL{nB_32fFd`adB83$-#0TLs^Aӛ+Nݒgԭe'mooֻܕ2uZI_U= ͇{`)p1ZÄN5 d\Xk ^5'zx,-`(  l mbwT*;|u!ooErEByXꊶ~25{Ƚ, ϢU 3t_'~0O~/@x"tb9P_m$9%~$ 4}e_{]wϫr8 i$g^jB'?!}zA׻<ح(wSZBG&;vmYS'"dJzkUȔ Bf7dYnE]wRÐhTWnyX[u:ƓA'R>ϴJ4iUn\Xdڅym)hB*fﲃ ]vSMϚ#v4%Pee/3 PfzixU\/:bL.?tNF._C&b,v k<.E^>,U^f,Usxk)l,[5Ⱦ9Yb J0~ 2fêLb%<ҷҕ?hh t6⢠2eu/ \}1!M//MvUDzBGa8hPks>{<)gŲ|VwˏWw5BqDtJU9kU9 'me6eV66ф66j+ٻt۬|/W[eMgQMٹ>l|.؏2^*%̎|8&(:PA6F#P*z~ˇ*!d/'#Ig|V84^1BmIǫJhd@_|Ob6KF B!WirpxnX|k!}8H1m!퐆j"}7<25R% ĜcX$GbYI J* ,)i= vģ<ܣ:uOUꉎ:M.up#V/9'd1YdBtLVO' V= 1Y=e?ɒF_T/4׆ɒԄu`2YRc_b2#N!;?[lɊhth$)ACSY%]Hd\`,Oʔ uųh́qDm5ƢQEwMR||5ӘK<%.9}VmXB<=NVVVL[0K^,${M%kN=t3c:V/ICmœ΀fdGGr3pfPiqIm1å6LZǤI~ fij\J&  ,oFpLq }-DZ(a2"-MM6<a|4酫D2'bBTZK 1GB OǸfsܗpiHgrRћ>=mn6--zbj! Vj`-|}B-@>~8QL]f23];R*r\m4c&@Pj :0(`f3mvBF P'i)$ ۼ!.FZ!z)5MZ7&=&(ޓjTpB jə 5p:H+ L> stream xPN0+hbv׏+ȷCUDh|?( jfwV< QGE%\ƦE%6GPvjxa:G렴j;SHT^4)&ӌ^q}`*5o7F<Ι'$B9ˊ=G_16H9&-aJzxmN,G/gd@yQ:q81VVd^C?t냩8`ݯC/hoAendstream endobj 117 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 450 /Subtype /Image /Width 550 /Length 25090 >> stream JFIFC    $.' ",#(7),01444'9=82<.342C  2!!22222222222222222222222222222222222222222222222222&" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( }m[ymqe8lҶҟ::M^T{$|-%߰n `VoωK.p2yQ<lg+R6dޫ:յ+auO\3.B^y[Gyrvri<_r8 (⻯uXRG5w@2O-ӨZr@'<3ҟ::M^T{$|-%߰n `^Ey )e."EzYF|;|G/ F?M~_z(#~G%?7& Vҥ ]v*pp@F=Z?elPEPEPP^^su % <09EOYyJ~I V?O~$kfF4U߉?٢1*ѿğMhO&h oJo'G%Z7?(~I V?O~$kfƏz$G' Ў)hO ț>ElPG%?7&J4oMk@haqsV7U< 5n x#xhb((( ZcyI,TxFr͂A'c4)|A! Q淨M~. "M4?)ߢ0?4(CR:~gk X%8˅:O2H.!I:dg hsSiOUHt{iǚ1\N:QO}̡/K 9d@4(C(M~. "M4?)ߢ0?4(C(M~. "MȑU;S}˓qVc_ D~Ri00 zU>a ?QEQEQEs5ZoҺ k"Gm]q= <@QYn &Y\jH-I v`#Ĥ#XKSvno>1 r8?֫ꊍ{na;ϓ/d_[V2FG`"U|''@ +冟g:_;$@Wh۝#@k:`QVYԫnL|p@#h>/߫Gy1I,$3[w엶,VF$J@ӞTz:z|?Pԯ5 "K^)GrKDPCbNl3Z^ EPU.(MO2ċuC¬P*[K&u|@ }N;>ƴm쿥S}ǶS} (m>qܦ8IL q޸Rpq޵*Xo-pN9A }i&HV?j^[a ijnF85C!V#2$q)Ǡc=g,۶3wa׺F6xJ2O@, ف1'&vt?Zcķϥ,Xc;4838R%jt$\[yzsʏ\POEpֹqY-,wE_$m̂,`䁌6ZJ<\K bbh aN~׿i'Hf6YI$ - 9$d֎y{uB$K.$1I;I;I 3Ҁ-xOD-kb'"n`@Q@%qMP?1If&g|~gQi~GN4 QE30((HkNJӵTDl-oUn!YQVg?5o ?ֽկڕG4X9OI7]? ?&i~EZF͹%@$5fM.Ns+"lF h9CJn@"߇'`|4Cm ST7ܙvfި%,̿._]eWi"YGThqAcaA VCR͸xXĞ^bnVw Vo,mI~ײB;}o8 މ5Y-y.IP6ك:ƀ:,[v+!Ppw9QʎU` ŊFiQGU 7uR "}#C4y㝄Rf?5*Y.ph((}oB+Za&@گ$K[}W%(((k"GtEi뽿J((+Va C`paasV ڋ~GާkʶAACV<ٞq8b2(<0 d~bʮXR0APUK* ")U2#MX%E7PrAm]c8[@QEEsq6RqYu֑*[)wLfurVf{$>i1? ·6(7zIH1F3 8XFݤwE[>F\c>F\QQEQEVO?jֵd=-?FkQEV6$ku䡆Q/$<űV3͏1o_0.3Jv6; yѬOU*fUa:SL#"K*=G)Wy}q9-ȥxXY#u !{qUb 9P rHih  ț>ElV?Moֶ(]7ueBcb#t#3“vW.9gaۋSg-n?cUmEe[mTE2j.}ʱcDUJW[QL(vzT)-GTggr I88J Ufhؑ!B$U  ]A"[Q,{F'ԒI$s@ޱi~"ŽӦ!hY t( Tx,Ai 3 bC7§ֿG@5 oaɸ_"K1]cpmooER *@>pAI?'Y#[*{7LsW 1 kkb[+dYO3G?i_'fr] 51,R? = k,‚ <FrB=۴H`N2z{`#v<;J?sW{m=<[pl-Bl\8xs֝jY=2*ZF`㴤H  #v<;J?_[>X Y |f, fmHY%Awg$q (Ē% yaC0 GRHP<{wD˦R:]j7m *s.1ߚ魭⳵ (ƃT VX*v5cgv=P2I"ϞmǶS}ǶS}faEPEPY> KOѫZՁmi $6UIiFHC@71K4Ab{vw?OU~{APy#v<;J?&i*r/:[ ;up&<[.yN?ҿ>O3G?i_'˯0}J< 5q+ p6aGx[|9w,0ıK(X|.6 ;J?|fCܵk$.X(S1_ m+ye apqZ|;J?|f0#MK'PKH|vu26z㞺ltkEbK'PPG@+4y#vO ț>ElUM3AӬ%ey-mcz#ۊ@`_a]LJ xId#j8淫d υ(Gs[QEQEQEQEQEQE@ik9WiXQFnZ~ki0z*~m{7.ml0~yIJORzmc}0 /~>_I+@گ$K[QEQE^\r,V^3bmAȌRA`Fpq[TPIφ/E;o_vu|BjWO@Q@Q@Q@Q@Q@`jǧƂW'̸zo5\G[6:^L8Ϲ& ?'TtiKswDΙZ;oStNKtcօU9jї5X9jї5@Q@VG=sѹA vP $<s2U?:XCozw-V1F@UO'g 6I%kUc&>>O,{((((((o~ė3 $ ~nߝu $:\ׁH@{K/U5c~Gc~GQEQEQE`C>oV?3o ?QEQEQEQEQE}DdV0:n~dVr^9!mEX[2C~.YVmAwߡ"N4ݷz}~[ 9mtZ6G+PYD$R0Uʂ& )EY*)Et1BO䵱X!'Zئ0((("=Ԯ_#J(((((''r tzr\!Ϡ1$OĚI(3+Bga! DլTi.T( $ §y?v_סEU9jї5X9jї5@Q@CukAq& > 6&B}S4+_ G] s2U?:h((((( )V*n-:Uo (v T5d 5шt $ ܁ 璾isUG:[h!@`T[f#5dc[cT`lQEQEQE [w5X> υ(Gs[QEQEQEQEQEW zDRdmoV!+}Iw"h4 ׊@2rG-5~xݯԮ_Ln?}pq0U~VvY.rގ(΃@گ$K[}W%(((>!ȏ?5+cCRz(((((fc/]MLzZrDz_QEFF=Z?elV=Z?elPEPEP\cak*e  XTtEQEQEQEQEVE˪jSY̰Z[*9n.pA;^M3Rom,VPWcS^}jeHޓ䋩Y/_ot=Kdv#5VN\ J,(G$IjwaXG2VPF# H(R4P0€9][Y|I[kx9 Z\YX> υ(Gs[QEQEQEQEQE2z d ? idZh;╉w?5p]_BvֳjM4q,a,:ѰAzcCXswa֟?kQ[!'Zج}j-lPEPEPEP1 D{ѩ]=sGzEPEPEPEPE ZZMs!DhM#|kĘ,xo1Mi56$yH1cJ:mZ *{o?˚ج{o?˚ؠ(*+--h1F =I< *UmYZj I I #|e  XTtEQEQEQEQE4\9e6?\ o¨>bR ~j`kcX޹)v!ݹ20#d3(4P*;T[f=F7:(1 ?1Iᭊ?1I ( ( (0|A! Q淫Hkz ( ( ( ( ׮š^N3DUVq?5tt$ViQ@U!#F>ڦ~85MwC Wﶡ}!\}b1cjd}k MxKHҜ%q>?nsZJ*1QJ+QEc{UkbBO䵱@Q@Q@^aasy6|xWjN?*k&O*xvƓ!g#}mcvh\ҘYdv1YF\c>F\QEMFY<ȶU1|ֵ)FFʊ 2@ gq0!coN7$lq*ݱi'=X94C#or>°|e  XTtEQEQEQEQEfmWQ\E]-N=\ kƵm>(2 ?1Iᭊ?1I ( ( (0|A! Q淫Hkz ( ( ( ( ־&gIC`39y?H7mCx^ ;Sp<# ~V5ucmgc((>a ?c{Ukb ( ( (9_#J"=Ԯ ( ( ( ( 5BV=yrMY"6@rK|QDmKE)y~z~W:((ǶS}ǶS}((+-aQC\cak*:( ( ( ( k;*I=:[tl%L-W-I+NoPEPEPEPEP]qE!=BQ$ǸEH=WS x{P8+nO3:n9?coEZ~oQEQE}W%>a ?QEQEQEsGz1 D{ѩ]=QEQEQEQEx;7Z+QЀHeV9n\X`Kܜ d ,dIH§I7 (G-O2+G-O2((({_ G] s2U?:h(((+ű|>%Ͳ [xg״]=jh=je/}KtQEQQEV>!O lV>!O lQEQEjsvн_-c6 f h,FsRWis,KueG.V+bAAEr߈3o7HKKi,hqir8fPkg#(((('<|낱FX?Q]MX[EpD/@W'χ4\2?"OkaI?E7 EVEP>_I+@گ$K[QEǫ5ݣi҅vFJd+ SUKK on6 QsY)E[kkWieGʞ F '@ǯ=)G$EcɕG tQEsGz1 D{ѩ]=QEQEQEQEs2yb^FcPKD)O@3= _|QnٵM#_`*B( {o?˚ج{o?˚ؠ#$m݌i i ֯3^1ƥp<[3= $) r#6FR:S%(#2M"FY2p9>$uχռ߰S0 ovQ7P]@IH$+_ GW_%xE&MDE:@?KlK;5ױīvL}<|X@}Q@Q@Q@Q@s-.׵bRV,$dV52c%?߿us+K;%kjqHN-Xvҵ.lXA.p:%$V(+ ɲ"62vT5ԥi=Ъ;G3Fīgi7a'xPW/އFt|BjWO@Q@Q@Q@TKee54-ucrx8ɤnm -čaܐǽ뫮kօ-nmpa {yVWKSfݶ ((ǶS}ǶS}+LWg{G7`YnmȊD=7`G^+ `( e  XTu=/XZJ(((( ?-eX͏Z6kH`^+Ƒ-׆i m ]è*) |L_(2 ( ?1Iᭊ?1I (8MGR?~PW+]GJ'8' @8k[vkxyAQE [w5X> υ(Gs[QEQEQEV'9YTֶr=׳m1Xuo.~4?SO:k((>a ?c{Ukb ( (#-1F썛hc884+YWJDCk6I<#9ǵk@_K}BjBAfq]sGzEPEPEPX>)a}z[^uVv9+oo C.tn}>7[t[KIX<sjUQ@Q@9jї5X9jї5@Q@Q@s2U?:k-aQCEPEPEPEWS]7Jd.a ?YQEQEQEsGz1 D{ѩ]=QEQEQEGd7S~YYFoaK,+By.'" Yc[C>>>3ػiN6zRwóJ(1 ( (1ri.kbri.kb ( (. {^I*$(Ze  XTug}i[+.a$$2\#-aQCEPEPEPX.5KsGVyva[ukr>HET98P=7u S=>ڝ=QTbQEQEc[c@QEQEgkt6oh.daS!@>V<gnќX ~.ĉVT $qWSVaJE$ҴE=6nzuu [w5@Q@Q@Q@Ϗ0x2c,R?v5ieZ Ai ľ}?ZT x;3O F7.}~50֤_žg/EkQ[Ess 7,pĥ(w]]̐wsj+{munne\ZA/j%+h:hP\v Y_&IaQ@?S]%``QN1V"gZ.ˢ- }j-lV>_I*B(((cCRz>!ȏ?5+(((W%o5ig%?WU\Ө&+(KRv&?Kr?]eL{VѨ_[QTbQEQEc>F\c>F\QEh :`UPO GѠF"2t[Iri.xsJ`bMXd[Y /{Hdc˳vxAV?Ҩ(((WÊo|S Qಋ8؎TGA溪|L{4M^F9T6%/QTbQEQEc[c@QEQEQE`C>oV?3o ?QEQEQLT &f=&9 GFP8 ]=s"XOw,[1b7~ O~o)>2YR^Y\$h9$Mq4%ԙr>}i9r3GWh[쿭iZru^:UR<#ϰUQBUEl/wQEY}W%>a ?QEQEQEsGz1 D{ѩ]=QEQEWQ6Z|UhN79GHZ_sU_O MO)= (9ݩ/m^^n޳O!ٸG+5Qc~-4r{(QEQEm#`Os[m#`Os[QEQEW=/XZJ*Ut4QEQEQEbko\=:JQ1"A;үi6_ٺ=THqY$e<=o xnyHT?#tu+YKݤ}EQTbQEQEc[c@QEQEQE`C>oV?3o ?QEQEmtIq~%f #۽o//tM7v\e]]t1 >Um?;-EjҭQEhI+"{\^6ؠck3VSZh1Mwޱ'01Ua ?c{Ukb ( (#[$1! *kZYc'Lgk.7) Q4֖F rd6;Xkq 1Z\4o‡dSz ԚO_#J|/Ht?6_buvQEQEW,Ծ$åXM#`@,;!86o&9}H G\YRiCݧ)w:z((((ǶS}ǶS}((+-aQC\cak*:( ( (f dP9D]E;l-[$ v?:IXZn$4 VLvvQEF!EPEPXGoPEPEP\_Ղ i5~SV]^Tc,{~5/V;O=\pc/zWmEF=Eꉢzd#ongܐ+B;۸!ȏ?5+cCRz((|fuie%.V#%!`}@GEGDUG@A\Vv&>oHi[!#ISu6ߛQTbQEQEQEc>F\c>F\QEf̓H v O>!ȏ?5+cCRz(+3_%tyfU{ Vl+E϶X iF6|#_6}H lkE'+׮LFl*{}I>EVm;(QEQEQEm#`Os[m#`Os[QES%9hE7dqG(+kk{8 X"%āT~e  XTu=/XZJ(( o뫢؁yglzW >kDƕXXaAHoBOrjWK(&Y;d4CkrjmRЊoaEUQ@Q@Q@c~Gc~GQ@Q@Q@> υ(Gs[Ճ [w5@Q@s~11h`5J)?u?1Oj+GQJ@DZ^dkiAu˯zhF#4`W;H5|=i'ԙIoE5n-?=e|~u$G&M+Jjo3Pc=[:aN^[u/װޏh_3Y"cB0:+S(((>a ?c{Ukb ( ( (9_#J"=Ԯ (Q݂N8 kk3/^s?詁ϭ/[[; u9<(pV̭q[jQ@ ;/QEF!EPEPEPEP=Z?elV=Z?elPEPEP\cak*e  XTtEVf6fDpdTdr}:j->ͤmrHxڥTqMS'Ҋo[-|sA&,\]}C=Ԡ`4}+R)mQE ( ( ( ?1Iᭊ?1I ( ( (0|A! Q淫Hkz (1OD%-s!ۢPsoa冚cI'NAXd8]/DV>G=Ȁ{vR]ͰiH)9X'ʤ7%WэiKSKͿ_4뻋_I(((cFw`%֪z~}!5 SpN(CRz>!ȏ?5+jyt[b* E؞j͖w#o|7QG,k7OoI5iLM~`2G !RDk+sozMiw)<ƪRm)p9X,GV ܢiY9)QEQEQEQEc>F\c>F\QEQQ\\Ain3G 10UQIPxAV?ҨjPWP\IHdFG/XZJ+3Tm4H[dRZ 9p)6F2Q6,:}^j*L/P?C(~5kEGecw>T?jڔa܋w8q=krW՚Tqۯ.EUQ@Q@Q@Q@c~Gc~GQ@Q@Q@> υ(Gs[Ճ [w5@s%tfծƿ}:Gcxtc5-c''Ong&a ?QEQESͨoch-)=YI_yw"wٙ6qF\c>F\QEMV!/zzZbh)QddEcxe$\jjdi7yidMwcj#f]lL;0.c#c?tp,EKcfxA҈ڂ]lӥӡ+,H 4 +̔I-3Nۤ VsOi.^U (QEQEQEQEQEV>!O lV>!O lQEQE.֑fPe bR?s3o^I["n,Wv78qWh[S]ROp%ۦ#)عE w+/4;&rhe_s֬?IÝYEIY74tWsڢq`dR$AEUQEQEQEQEQE}W%>a ?QEQEQEWQaCR>:MzeŒbƳv-.DJꪓj+f?jcnvۻwmp3Po!gk<ַ;[BY'h.nBJ,v , -;04kv3\cj!gk<!n:00IÌ?oqҵ, [g/\*ARU B(3~^ڥxFPE[gݭm(3~^ڥxFѯ]7b&0 ݎ82U, O,K3u5 f vѐBoʍܸ݌_~?Z/O4yHuBQhP_vg#p|5-m]?Lov Cy{j1ƶlL7l[D-uxӦ%ꕆci1Q  IV fַ;G!gk<㵿Ym²ϋtA%yNg)~'E~?Z/ջ_WQAr+@ N8JFv@k:؍_c |2~w3~^ߢ0??[^u=A%־ ~Fb̓k -/nS F0J<[&A"yyQ;f446Kh-V@F21K9$unXjV/-*6#)l`AtQEQEQEVchv.dF'c9c8y:(KE%IfyQ㉣Cn^7Ѻűߘ|WMEfiZ$ I4DhX.onNOEQEQEQEkj|D"b6G2,N9+N(.B DW10@e#+YӬ[~Zmt>Fʜ8tP6qi}"x(?ASES͉ɹJC3Z}7t=ӥ۫&QVbr0?.2Kg9wmtחK$K;;'EL{J/ys] QEV~E5N"Fe;ЊТ9>үFsgçwG~cqZzVoI#,n!Q!G(8ۓi@Q@Q@Q@fiZ$ I4DhX.onNOE{A{|o|nqI"+̘ 2ȕxJ(>gO^ k7mFTvwg+~-?OCoc@'*z((>lǍßpGu< GDkMEdf x 6>^+0|+gaz1]; dv];VA ӎ+v(('YM!P`˜FGk>OhMj16 ۰}g5Q@t2=294O If+":vQ@Q@Q@Q@Q@Q@Q@gkO`aeW@-##Ѣ8؏&tT'b fuOk髯o5/1 6v`9+v((((((((((=sRN *ȨYpAnA=Ⳓ+ucȈA,` w1I90:kI_-|Tm*ĕnEQEQEQEQEQEQEQEQEQEVu[$UIJ r [P'.dstf,s,!M`0#׶WV]9eK&W̎4`W#bwsע ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (?endstream endobj 118 0 obj << /Type /XRef /Length 161 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 119 /ID [<0b0f7c4bbdee898586657f1d220e93f9>] >> stream xcb&F~0 $8JC?oF }(9@$+d2A$+d"l  D2wHދ`qy)D Hn9)RɨĖo|f.j RD HHeBM`6`d?d9%A$c8LY) endstream endobj startxref 166199 %%EOF mets/inst/doc/marginal-cox.ltx0000644000176200001440000003164613623061405016070 0ustar liggesusers%\VignetteIndexEntry{Marginal Cox} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Marginal modelling of clustered survival data} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Marginal modelling of clustered survival data}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Overview} \label{sec:org4291342} A basic component for our modelling is that all these models are build around marginals that on Cox form. The marginal Cox model can be fitted efficiently in the mets package. The basic models assumes that each subject has a marginal on Cox-form \[ \lambda_{s(k,i)}(t) \exp( X_{ki}^T \beta). \] where \(s(k,i)\) gives the strata for the subject. We here discuss the \begin{itemize} \item robust standard errors of \begin{itemize} \item regression parameters \item baseline \end{itemize} \item cumulative residuals score test \end{itemize} First we generate some data from the Clayton-Oakes model, with \(5\) members in each cluster and a variance parameter at \(2\) \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) set.seed(1000) # to control output in simulatins for p-values below. n <- 1000 k <- 5 theta <- 2 data <- simClaytonOakes(n,k,theta,0.3,3) head(data) \end{lstlisting} \begin{verbatim} Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.6.3 mets version 1.2.4 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined time status x cluster mintime lefttime truncated 1 0.1406317 1 0 1 0.1406317 0 0 2 0.4593768 1 0 1 0.1406317 0 0 3 1.0952678 1 0 1 0.1406317 0 0 4 0.2057554 1 1 1 0.1406317 0 0 5 0.6776620 1 0 1 0.1406317 0 0 6 1.6093755 1 0 2 0.1092390 0 0 \end{verbatim} Now fitting the and producing robust standard errors for both regression parameters and baseline. Note that \begin{align} \hat A_s(t) - A_s(t) & = \sum_k \sum_i \int_0^t 1/S_{s} dM_{ki}^s - P^s(t) \beta_k \end{align} with \(P^s(t)\) a derivative wrt to \(\beta\), and \begin{align} \hat \beta - \beta & = \sum_k ( \sum_i \int_0^\tau (Z_{ik} - E_{s}) dM_{ik}^s ) \end{align} with \begin{align} M_{ki}(t) & = N_{ki}(t) - \int_0^t Y_{ki}(s) \exp( Z_{ki} \beta) d \Lambda_{s(ki)}(t) \end{align} the basic 0-mean processes, that are martingales in the iid setting. The variance of the baseline of strata s is \begin{align} \sum_{k} ( \sum_i \int_0^t 1/S_{0s(ki)} d\hat M_{ki}^s )^2 \end{align} that can be computed using the particular structure \begin{align} d \hat M_{ik}(t) & = dN_{ik}(t) - 1/S_{0s(i,k)} \exp(Z_{ik} \beta) dN_{s.}(t) \end{align} This robust variance of the baseline and the iid decomposition for \(\beta\) is computed in mets as: \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} out <- phreg(Surv(time,status)~x+cluster(cluster),data=data) summary(out) # robust standard errors attached to output rob <- robust.phreg(out) # making iid decomposition of regression parameters betaiid <- iid(out) head(betaiid) # robust standard errors crossprod(betaiid)^.5 # same as \end{lstlisting} \begin{verbatim} n events 5000 4854 1000 clusters Estimate S.E. dU^-1/2 P-value x 0.287859 0.028177 0.028897 0 [,1] 1 -3.461601e-04 2 -1.449189e-03 3 -3.898156e-05 4 4.215605e-04 5 3.425390e-04 6 -7.706668e-05 [,1] [1,] 0.02817714 \end{verbatim} Looking at the plot with robust standard errors \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{robcox1.jpg} \end{center} \captionof{figure}{Baseline with robust standard errors.} \label{fig:robcox1} \end{marginfigure} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=robcox1,caption= ,captionpos=b} \begin{lstlisting} bplot(rob,se=TRUE,robust=TRUE) \end{lstlisting} One can also make survival prediction with robust standard errors using the phreg. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} pp <- predict(out,data[1:20,],se=TRUE,robust=TRUE) \end{lstlisting} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=robcox2,caption= ,captionpos=b} \begin{lstlisting} plot(pp,se=TRUE,whichx=1:10) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{robcox2.jpg} \end{center} \captionof{figure}{Survival predictions with robust standard errors for Cox model} \label{fig:robcox2} \end{marginfigure} Finally, just to check that we can recover the model we also estimate the dependence parameter \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tt <- twostageMLE(out,data=data) summary(tt) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 0.5316753 0.03497789 15.20032 0 0.2100093 0.0109146 $type NULL attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \subsection*{Goodness of fit} \label{sec:orgb08000a} The observed score process is given by \begin{align} U(t,\hat \beta) & = \sum_k \sum_i \int_0^t (Z_{ki} - \hat E_s ) d \hat M_{ki}^s \end{align} where \(s\) is strata, this has as iid decomposition as \begin{align} \hat U(t) = \sum_k \sum_i \int_0^t (Z_{ki} - E_s) dM_{ki}^s - \sum_k I_t \beta_k \end{align} where \(\beta_k\) is the iid decomposition of the score process for the true \(\beta\) \begin{align} \beta_k & = \sum_i \int_0^t (Z_{ki} - E_s ) d M_{ki}^s \end{align} and \(I_t\) is the derivative of the total score with respect to \(\beta\). This observed score can be resampled given it is on iid form in terms of clusters. Now using the cumulative score process for checking proportional hazards \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} gout <- gof(out) gout \end{lstlisting} \begin{verbatim} Cumulative score process test for Proportionality: Sup|U(t)| pval x 30.24353 0.401 \end{verbatim} The p-value reflects wheter the observed score process is consistent with the model. \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{robgofcox1.jpg} \end{center} \captionof{figure}{Goodness of fit for clustered Cox model.} \label{fig:robcgofox1} \end{marginfigure} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=robgofcox1,caption= ,captionpos=b} \begin{lstlisting} plot(gout) \end{lstlisting} \subsection*{Cluster stratified Cox models} \label{sec:orgf70f1c5} For clustered data it is possible to estimate the regression coefficient within clusters by using Cox's partial likelihood stratified on clusters. Note, here that the data is generated with a different subject specific structure, so we will not recover the \(\beta\) at 0.3 and the model will not be a proportional Cox model, we we would also expect to reject "proportionality" with the gof-test. The model can be thought of as \[ \lambda_k(t) \exp( X_{ki}^T \beta) \] where \(\lambda_k(t)\) is some cluster specific baseline. The regression coefficient \(\beta\) can be estimated by using the partial likelihood for clusters. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} out <- phreg(Surv(time,status)~x+strata(cluster),data=data) summary(out) \end{lstlisting} \begin{verbatim} n events 5000 4854 Estimate S.E. dU^-1/2 P-value x 0.406307 0.032925 0.039226 0 \end{verbatim} The cumulative score processes can still be used to validate the model \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} gg <- gof (out) summary(gg) \end{lstlisting} \begin{verbatim} Cumulative score process test for Proportionality: Sup|U(t)| pval x 27.55616 0.195 \end{verbatim} \end{document}mets/inst/doc/quantitative-twin.ltx0000644000176200001440000004342613623061405017203 0ustar liggesusers% Created 2018-11-19 Mon 19:21 %\VignetteIndexEntry{Twin analysis of quantitative outcomes} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \usepackage{units} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Twin analysis} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Twin analysis}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Mets package} \label{sec:orgeaaf733} This document provides a brief tutorial to analyzing twin data using the \textbf{\texttt{mets}} package: \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library("mets") options(warn=-1) \end{lstlisting} The development version may be installed from \emph{github}, i.e., with the \texttt{devtools} package: \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} devtools::install_github("kkholst/lava") devtools::install_github("kkholst/mets") \end{lstlisting} \section*{Twin analysis, continuous traits} \label{sec:org0778a55} In the following we examine the heritability of Body Mass Index\n{}\cite{korkeila_bmi_1991} \cite{hjelmborg_bmi_2008}, based on data on self-reported BMI-values from a random sample of 11,411 same-sex twins. First, we will load data \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data("twinbmi") head(twinbmi) \end{lstlisting} \begin{verbatim} tvparnr bmi age gender zyg id num 1 1 26.33289 57.51212 male DZ 1 1 2 1 25.46939 57.51212 male DZ 1 2 3 2 28.65014 56.62696 male MZ 2 1 5 3 28.40909 57.73097 male DZ 3 1 7 4 27.25089 53.68683 male DZ 4 1 8 4 28.07504 53.68683 male DZ 4 2 \end{verbatim} The data is on \emph{long} format with one subject per row. \begin{mnote} \begin{description} \item[{\textbf{\texttt{tvparnr}}}] twin id \item[{\textbf{\texttt{bmi}}}] Body Mass Index (\(\unitfrac{kg}{m^2}\)) \item[{\textbf{\texttt{age}}}] Age (years) \item[{\textbf{\texttt{gender}}}] Gender factor (male,female) \item[{\textbf{\texttt{zyg}}}] zygosity (MZ,DZ) \end{description} \end{mnote} we transpose the data allowing us to do pairwise analyses \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} twinwide <- fast.reshape(twinbmi, id="tvparnr",varying=c("bmi")) head(twinwide) \end{lstlisting} \begin{verbatim} tvparnr bmi1 age gender zyg id num bmi2 1 1 26.33289 57.51212 male DZ 1 1 25.46939 3 2 28.65014 56.62696 male MZ 2 1 NA 5 3 28.40909 57.73097 male DZ 3 1 NA 7 4 27.25089 53.68683 male DZ 4 1 28.07504 9 5 27.77778 52.55838 male DZ 5 1 NA 11 6 28.04282 52.52231 male DZ 6 1 22.30936 \end{verbatim} Next we plot the association within each zygosity group \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library("cowplot") scatterdens <- function(x) { sp <- ggplot(x, aes_string(colnames(x)[1], colnames(x)[2])) + theme_minimal() + geom_point(alpha=0.3) + geom_density_2d() xdens <- ggplot(x, aes_string(colnames(x)[1],fill=1)) + theme_minimal() + geom_density(alpha=.5)+ theme(axis.text.x = element_blank(), legend.position = "none") + labs(x=NULL) ydens <- ggplot(x, aes_string(colnames(x)[2],fill=1)) + theme_minimal() + geom_density(alpha=.5) + theme(axis.text.y = element_blank(), axis.text.x = element_text(angle=90, vjust=0), legend.position = "none") + labs(x=NULL) + coord_flip() g <- plot_grid(xdens,NULL,sp,ydens, ncol=2,nrow=2, rel_widths=c(4,1.4),rel_heights=c(1.4,4)) return(g) } \end{lstlisting} We here show the log-transformed data which is slightly more symmetric and more appropiate for the twin analysis (see Figure \ref{fig:scatter1} and \ref{fig:scatter2}) \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=scatter1,caption= ,captionpos=b} \begin{lstlisting} mz <- log(subset(twinwide, zyg=="MZ")[,c("bmi1","bmi2")]) scatterdens(mz) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{scatter1.jpg} \end{center} \captionof{figure}{Scatter plot of logarithmic BMI measurements in MZ twins.} \label{fig:scatter1} \end{marginfigure} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=scatter2,caption= ,captionpos=b} \begin{lstlisting} dz <- log(subset(twinwide, zyg=="DZ")[,c("bmi1","bmi2")]) scatterdens(dz) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{scatter2.jpg} \end{center} \captionof{figure}{Scatter plot of logarithmic BMI measurements in DZ twins.} \label{fig:scatter2} \end{marginfigure} The plots and raw association measures shows considerable stronger dependence in the MZ twins, thus indicating genetic influence of the trait \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} cor.test(mz[,1],mz[,2], method="spearman") \end{lstlisting} \begin{verbatim} Spearman's rank correlation rho data: mz[, 1] and mz[, 2] S = 165460000, p-value < 2.2e-16 alternative hypothesis: true rho is not equal to 0 sample estimates: rho 0.6956209 \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} cor.test(dz[,1],dz[,2], method="spearman") \end{lstlisting} \begin{verbatim} Spearman's rank correlation rho data: dz[, 1] and dz[, 2] S = 2162500000, p-value < 2.2e-16 alternative hypothesis: true rho is not equal to 0 sample estimates: rho 0.4012686 \end{verbatim} Ńext we examine the marginal distribution (GEE model with working independence) \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} l0 <- lm(bmi ~ gender + I(age-40), data=twinbmi) estimate(l0, id=twinbmi$tvparnr) \end{lstlisting} \begin{verbatim} Estimate Std.Err 2.5% 97.5% P-value (Intercept) 23.3687 0.054534 23.2618 23.4756 0.000e+00 gendermale 1.4077 0.073216 1.2642 1.5512 2.230e-82 I(age - 40) 0.1177 0.004787 0.1083 0.1271 1.499e-133 \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library("splines") l1 <- lm(bmi ~ gender*ns(age,3), data=twinbmi) marg1 <- estimate(l1, id=twinbmi$tvparnr) \end{lstlisting} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=marg1,caption= ,captionpos=b} \begin{lstlisting} dm <- Expand(twinbmi, bmi=0, gender=c("male"), age=seq(33,61,length.out=50)) df <- Expand(twinbmi, bmi=0, gender=c("female"), age=seq(33,61,length.out=50)) plot(marg1, function(p) model.matrix(l1,data=dm)%*%p, data=dm["age"], ylab="BMI", xlab="Age", ylim=c(22,26.5)) plot(marg1, function(p) model.matrix(l1,data=df)%*%p, data=df["age"], col="red", add=TRUE) legend("bottomright", c("Male","Female"), col=c("black","red"), lty=1, bty="n") \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{marg1.jpg} \end{center} \captionof{figure}{...} \label{fig:marg1} \end{marginfigure} \subsection*{Polygenic model} \label{sec:org336bb16} Decompose outcome into \begin{align*} Y_i = A_i + D_i + C + E_i, \quad i=1,2 \end{align*} \begin{description} \item[{\(A\)}] Additive genetic effects of alleles \item[{\(D\)}] Dominante genetic effects of alleles \item[{\(C\)}] Shared environmental effects \item[{\(E\)}] Unique environmental genetic effects \end{description} Dissimilarity of MZ twins arises from unshared environmental effects only! \(\cor(E_1,E_2)=0\) and \begin{align*} \cor(A_1^{MZ},A_2^{MZ}) = 1, \quad \cor(D_1^{MZ},D_2^{MZ}) = 1, \end{align*} \begin{align*} \cor(A_1^{DZ},A_2^{DZ}) = 0.5, \quad \cor(D_1^{DZ},D_2^{DZ}) = 0.25, \end{align*} \begin{align*} Y_i = A_i + C_i + D_i + E_i \end{align*} \begin{align*} A_i \sim\mathcal{N}(0,\sigma_A^2), C_i \sim\mathcal{N}(0,\sigma_C^2), D_i \sim\mathcal{N}(0,\sigma_D^2), E_i \sim\mathcal{N}(0,\sigma_E^2) \end{align*} \begin{gather*} \cov(Y_{1},Y_{2}) = \\ \begin{pmatrix} \sigma_A^2 & 2\Phi\sigma_A^2 \\ 2\Phi\sigma_A^2 & \sigma_A^2 \end{pmatrix} + \begin{pmatrix} \sigma_C^2 & \sigma_C^2 \\ \sigma_C^2 & \sigma_C^2 \end{pmatrix} + \begin{pmatrix} \sigma_D^2 & \Delta_{7}\sigma_D^2 \\ \Delta_{7}\sigma_D^2 & \sigma_D^2 \end{pmatrix} + \begin{pmatrix} \sigma_E^2 & 0 \\ 0 & \sigma_E^2 \end{pmatrix} \end{gather*} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dd <- na.omit(twinbmi) l0 <- twinlm(bmi ~ age+gender, data=dd, DZ="DZ", zyg="zyg", id="tvparnr", type="sat") \end{lstlisting} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} l <- twinlm(bmi ~ ns(age,1)+gender, data=twinbmi, DZ="DZ", zyg="zyg", id="tvparnr", type="cor", missing=TRUE) summary(l) \end{lstlisting} \begin{verbatim} ____________________________________________________ Group 1 Estimate Std. Error Z value Pr(>|z|) Regressions: bmi.1~ns(age, 1).1 4.16937 0.16669 25.01334 <1e-12 bmi.1~gendermale.1 1.41160 0.07284 19.37839 <1e-12 Intercepts: bmi.1 22.53618 0.07296 308.87100 <1e-12 Additional Parameters: log(var) 2.44580 0.01425 171.68256 <1e-12 atanh(rhoMZ) 0.78217 0.02290 34.16186 <1e-12 ____________________________________________________ Group 2 Estimate Std. Error Z value Pr(>|z|) Regressions: bmi.1~ns(age, 1).1 4.16937 0.16669 25.01334 <1e-12 bmi.1~gendermale.1 1.41160 0.07284 19.37839 <1e-12 Intercepts: bmi.1 22.53618 0.07296 308.87100 <1e-12 Additional Parameters: log(var) 2.44580 0.01425 171.68256 <1e-12 atanh(rhoDZ) 0.29924 0.01848 16.19580 <1e-12 Estimate 2.5% 97.5% Correlation within MZ: 0.65395 0.62751 0.67889 Correlation within DZ: 0.29061 0.25712 0.32341 'log Lik.' -29020.12 (df=6) AIC: 58052.24 BIC: 58093.29 \end{verbatim} A formal test of genetic effects can be obtained by comparing the MZ and DZ correlation: \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} estimate(l,contr(5:6,6)) \end{lstlisting} \begin{verbatim} Estimate Std.Err 2.5% 97.5% P-value [atanh(rhoMZ)@1] - [a.... 0.4829 0.04176 0.4011 0.5648 6.325e-31 Null Hypothesis: [atanh(rhoMZ)@1] - [atanh(rhoDZ)@3] = 0 \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} l <- twinlm(bmi ~ ns(age,1)+gender, data=twinbmi, DZ="DZ", zyg="zyg", id="tvparnr", type="cor", missing=TRUE) summary(l) \end{lstlisting} \begin{verbatim} ____________________________________________________ Group 1 Estimate Std. Error Z value Pr(>|z|) Regressions: bmi.1~ns(age, 1).1 4.16937 0.16669 25.01334 <1e-12 bmi.1~gendermale.1 1.41160 0.07284 19.37839 <1e-12 Intercepts: bmi.1 22.53618 0.07296 308.87100 <1e-12 Additional Parameters: log(var) 2.44580 0.01425 171.68256 <1e-12 atanh(rhoMZ) 0.78217 0.02290 34.16186 <1e-12 ____________________________________________________ Group 2 Estimate Std. Error Z value Pr(>|z|) Regressions: bmi.1~ns(age, 1).1 4.16937 0.16669 25.01334 <1e-12 bmi.1~gendermale.1 1.41160 0.07284 19.37839 <1e-12 Intercepts: bmi.1 22.53618 0.07296 308.87100 <1e-12 Additional Parameters: log(var) 2.44580 0.01425 171.68256 <1e-12 atanh(rhoDZ) 0.29924 0.01848 16.19580 <1e-12 Estimate 2.5% 97.5% Correlation within MZ: 0.65395 0.62751 0.67889 Correlation within DZ: 0.29061 0.25712 0.32341 'log Lik.' -29020.12 (df=6) AIC: 58052.24 BIC: 58093.29 \end{verbatim} \section*{Twin analysis, censored outcomes} \label{sec:org4b5f762} \section*{Twin analysis, binary traits} \label{sec:org4c17447} \section*{Time to event} \label{sec:org843c812} \bibliography{mets} \bibliographystyle{plain} \end{document}mets/inst/doc/marginal-cox.pdf0000644000176200001440000020747113623061751016037 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 2802 /Filter /FlateDecode /N 51 /First 398 >> stream xZr8}߯d+FVUĎcVd;qfjh9CJ|vċd3>m(64 ˆ$E4 &pb#nDp OA>!{@)&\|h}cPOF3Q(@;E"~0CaPAhxD"сON|)HP$=#ArI#}bt"x*4 ,#FiBӀ@> ] ML?14&4!8& t$ ZÄ޼!t4,BPfL(r}zIzGleqf,n'p n P^y3WyswO~UgZ/*x,>}7@, 8]ED^G`!Kajr8w52E䥌0m4ٶ(dmM]<}MiN^0t,.'QF^>͋|1 ?Ia$Z}ZR\f&gbDYu֎\_Xϖw}g}|>*_:LŠ߀oXs{CW,hQD.;qx>Bg .ek@\ׁ>Fa!mqlago$ GpeT@ttt DtW`HyÄЋѐptFlUףUM<߽y=4 $i]]LiC; ,/Ì'Q\?pUaYv|W¸q?AV}ҺޓP?Gga Pʷy#-bXϚbamb}yE'x kr߱5ֶ7HGZ|Nû(W+ݧ-='=gtHKzE L! Q):INiDgt;zOc'M.hJ3ӂ.>o@(+a$C?pya#wW~'~ibr˦fۖcMemf[ ۱DtLg~YNӦɊ43+zӾ\; 0 0FĵC|]xe8a06;@|pHi *b1#>.): R?M?A?97?ceDeMY=s&͟ ˣ5BE>!hVTf S2-mi8O1"dg- llKqhYQiY?K@-(;aXܗ$Rbm ,쵑{Ӱ'6:j?8nu+M4Elr&IW`5ͶM{=}w|ax>xy8Äsd]3-3}CL ݏY][ƴ^_0Նٰz 'kLrM>e Yo}<8jYi2i<6XB7i爚A )P`MOjM 0>fZzBF<~;r04x5 (Tp^i]znE;C=.quYe]{j/o7r7!,Ŏ`1v˰Ac`$](E,gʴ'8cfn~VF2s,b9zVk!>}EeP\Lai9IcrSVM6laIy%#*;޿t}9ـDg!zG)+TY-:lC>k6Ko]wӽ#?QQ(n 9.DMq2}qC(I2/`8[k;hb/'l6yyOlm!I [c7NQ9OaK.+k6H 7p}]a$nyqe;,:C巵m~J4JtOq-җwO+55q+b2rsA8JxXa?Rieָ{tXˆ <4J9U'êj=j+ŀj35LrUUjR1Q> stream GPL Ghostscript 9.27 2020-02-18T23:23:37+01:00 2020-02-18T23:23:37+01:00 Emacs 26.1 (Org mode 9.1.14) Marginal modelling of clustered survival dataKlaus Holst & Thomas Scheike endstream endobj 54 0 obj << /Filter /FlateDecode /Length 2312 >> stream xYioQ@fXXӹgKmvSRmsMHiorxZ'bOO m`IgKpE2"Y,ybsՒڌ'=?Yr[*] ̒]-G2H}_ M[g9LmVx4Ӻ-bk*?6#G>^Jwy 7wEy_ vA)ևc~]hBXY*3&vAKW<-\fP^-~X(%y]X&WqFSœBZi(3ÓjKtbKy[ x 4a EM: e,x7&*wط#'M}xC`_wy ɫ*2xU4EHS&QykMoOI3emd}},mD\ _Con#qX_8U'Ah R]T΁xA&ߏ=ڶUܤ{Vզ9Rr?^wh]FEroۂvJ ēeMz.Љ#iX䛻Qش7ͨxƗs]84-ksQtچb[-7] eKKADsMEAIjqKF1>5A9=r)D G'ygSp3*rTh*RD1F%"XdC;0CTR3tŇsQ蹢C%~FK[&r\gޕ?Pōl0mz %}Ƨ 5:+GZ_S~Jri`#D  G*A]ϕ!bjjBMxQf>e3EQ~>x h̉<9S7YQD̏FxLIcLPv'%MNTCe4Z2+{|-ͱizM:BAuAo^vdiM@*!•B< }[ǩa8tKE10i7DZ 7ek>g(/#OR[y}*o!Blٌ7ݱ[bjM=CM}֎m lߔB-wHb~Zx9׫(!0h xwr֜#Df9Ƃ6$eX5s:*L5BÇd'֚K8ė3Ak6E}G8cl"'xUgๆfM~.-cL52@ E׸\`hm7eNBD:J3jϥ`H['%fcD~g}Z"͡5 ,l wMr7mx^Be%~ w. sQ{qJ]*/ w :1ME7L'aZL*I E&ȁ j쥩D%Z5DE' :w#XOtТ[hbHYg$Č˄X$!dq(}2KV>NQ4N ݯ V6j:t MΰS=nO]*zX@7}l_KP_ڗ\ ?,aendstream endobj 55 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6336 >> stream xX tS׵c$?!E{HP2@H @&F3mFAe˒-ɒehݧy-˖6ۀ!$@B ۤM4W&Iմkd={w}ιqiwٙ&ee[ިLľ]]yR+' X^9oѾ6Ίgx0sZ̙Ƚo{ow,kqO=`@#g(._\~DVgKH"+IwDBeH%k'۸m׋"yDT.g3DR aL.C!fbTpB&T2%Qq `@$+PfӤJQP),T),|-$S(rqRvLZx'FeN2B eY藙X6?TTz5NSZ@|:>L#Hc K$t4J$d${*A{.c"WTSs=> jq8Q52`"RRY$C_tI_\ފQ8Xr8oŎ3 {hxg7 /qrW-gx~)C{U^!;6 6x6kbO <=1T4 F@ϡAfZ~f"UdEfH&ܕH]d7sD^w\WM[ض2Vol!m#q$`Ri4,>Eq:jΊ`9X._wvn<1{ư?^o[~}zge@0.#L]pQ02z}p.}-%#$_?{ PA߹kD!RdQ EM2R2](=q;2KIv!vip4&~O^s~2nLRu:WHFCeH8x)N紀f yWضQY!hrV;|.1;z@\&Z[7r'}*G>$0̤p ƽv&egT 4(Y󟟤qFoIX AHGHvSqD1.hM"+須N`PEh?6+J"opz\tZ4sw nm Qdd♻*mow5>>γiL` 95pjgVUۃa0s >Mu!j ʬrA2ؖ ~ȻR?nրLlӡԵ j'8q'+2M{ƬX9\wu`{LLF/$DVIa '1f;{9o4îJګ( \@Ӄ;Z3m9T R@6.MV6 ~bv1=z\f=+/ݑ7oCՕƚZm4dU4W}%'xRdE"8VsD/g^SU^Ϛҭ!8 <,{=Nble+8ϒZGhbHado(*ÖoF:iv] Z0H`L-2k9a3lE}^Zx;[(v wp6w ~QZ"RT &G jiĪ~̘>gQ iVh Y9ΐ4H__bLѽ,_/9H$-zymVQnqQ*ZSE5 6H[v]J ADބiG%K uIk$K؝/ln$lMv:NBy,\[ѥ]dέaqE^;Q- '/mg 5jS) 9N=sߣ˭&ZZ`.ۍsCp$7JGyA%tgf-a}ifՎk'W]vp0Lo3cQx u(б WO2+JUgGW* N-ߪ")~kitRep~.wr /7۬%>,^b˻w_:}>.ߔJʁvdo.z/W"s\7Q հmW\P[ ʶJrSKe,5$%eĮZS/ 5 6Jm6"@gTr'Ỽ"&8Ym;/lԊׂƳ 5؎~hb& Z[ 幫G~B\=C8|yA-]y-FC5SX:A fgq8 Cu0 Z8JJEi)3 @Kh5KX&13Sgo7 +qob xg<IYBj[8 :Fnx0riCf Agm8nΗPecTk赶i»F.4t fʅ>{MN 2@FօYQџ=Is A5𰱽+R\(O?܊gl=A'`p݆V\+<׍xɅ٦5¦br e'G)D$9{Tm1ߺ>S>du@ͲҔ/ap+7o&fxH0j j8:0tt[Ǵ AE$/g>wx GY@9bGzs 7_jPىYIٟZ&Gh%-5%e廂.guQ+Υ@9e06*V#mcȾϼ¬۷z r ZݱnM`t!c{p*:o, 8^"])cO hd,939 *.>A]u`= Dk!/OiAF u $VRR,Vf 5y2z'OIY na~5ɺVG:]Mt*Lu귲U?3Q!P8nmpUO4k2l-)6BB"!eN9NPEmck@kf9 t`Q 9:ќ0ިgfLE cHO9dzxkk t?+"ܐj@ׇÍM]kS%FiČ\ M mMPLkjsNE(*p-ATk#Lt mrHƭn{MDH*f@=SfeMJqrsMBxg$nMsf8Q{Ͳtu :w'9_DOAÅ^,&8+2f*`ZTB{ًx>>E`?.b#}͙} {^k{>xkcm5hmUL dن@?V7sb/12͌|뵃p1c0o |Io鏪/:W.`߷e8?"~@7B;7Q.UmTټŮ(7Pi՟D;hхt"Jlj2E]o]7:2'.-ٟim~([fnDH:H:~Ԍ7Q-hW]KgeQ RaXk{H8$;,C&9- RIK̵5z'<5'RuA$ټ݇z0 N0Nzd}µT>[&}ũҤ;ZCEZAM`%,XV 2oq("{T=G-e j.v81j<¸2OOȮ-Xrbڲ;.twOnt쵏Xn[8uJ4gIcdSJkV] Ɖ!UMeȜ+HaRLٶ"PL(%\yaPoݻ#-JRqDީ`V$WbSJYb-Sl@ sh6EY+p<ǓJs򐶱QV!05hd݀.^;uWupcF X ^s$]v}?RA)k;k7>GTёs~BnaC|l`p!$dh~`Sƪ^p꛿;ZNߵtN<{sXzQLmVN \zZO6K4a8zoKx}^4Β";Bd&skM0GIt0O\eҕdFDW pq\߄':qsEb-S8RљLxoU~‰-&hz,{Y3Ӿp+'z4??ZmHelÎjwh*Ԕ!y4NF:)6Om*nӎGou6>o>T^]>~5DT'Ep7tR.A'nwQz\ ՑJjdQm%>4l_y>P{@*$p;Ꝑ~ʦt1ZHsd᜜p8C+vSjզBwU;BM?-{yP׍0即牡e9E 'Y#npVAc ';s yvKv$&GZD'Nƍ|8rQ]t g䅥>T*7,\X7H_+\!dI2sT韯+4?(Y?x?8r  ֋jTZ]398-*$8`] G1ޛY"s/sp.wGFZ;\8 lRv&̊6j |ojQAL*~5i塪v;6N5:d+1'Krg?s!st>b[K;Ĵܙe˰ ]}7LcǮg|>:\\5tid6 J~R$!^w;=q}THj+Z,ߝBRGyx(>̙,Hsendstream endobj 56 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 961 >> stream xURoLekmNgt t8?)!چ\{wwm%0I B:0]\ `%l.Ld\Ԙe&~_޼y~>H I-XyEXInQw3EjXAloxuntLb?gޢCsۓAל%y!!h v[TU9*{kkkA8MPBQ<]Ab`_rsˠba ! ` A v7{jxX <(9  /v"Zc啿&M|rƝZْ EbKOak ,_x{m}} -<{:j޼kRЙsCʑT&خ{T(?Rf򆭡4c|HX"7=vWY|:w|yrhClkg)QU\=J?8&箟O-b{0|1'~P2m:S^_ʬSmc hXn7CyJyL1*ty_a]WJVfV^i(óV&::k>3~I߹LJ+pڴRNXy`ەգJh??qul^>;2o#ҹendstream endobj 57 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5687 >> stream xXyXS׶?)&'JzXjjZkb" "y$B !@ *S:lVmZOwZ{Z  b<6I$abk0훔 [%a[9|Sc00 euU051Dy;}ƌ+q p… +•"8Z&~$$8H%$ 1"aX"ܶv5kD2QBD.G"B4]%OJ#"J\%\ q1:$J1 3qX@b0:!LE rX!IdԣQrR GRDJED8N)DWo2&LUѲPvF#<\Se Rd􄋄bE$,E#&$*IJGg Da bD.Gaqqԑ] $jr Le{.nL\".ab21)9,%?5"-r( *:FiX4x-oN~[ʴt{ml `S@e]l a[`l+ۆ^Bvl6[`Zl6xa^XŞŞäXLc|Olfge ?*nݣFc'orvѳgx迍8F<深cs/7ei /Oh@y|]z~ | -q߉'fyx>dOU١m@";#*?c =WOϖ%&jQ-5ҋWc@Lmƣ1ƬbPC5G$xUXaPAN:A!GNq#; sb_$ Q;uUgAՐ'OO<zPk+G2.1"b >=**Id-W*ܚ%/Ļ kt"5jvU&$ 4.jbpc  ;5uʃvx }fWO^AK  F \)ޡ[>a3sI%ΛcT*Lh)`i{"M5w,u%j.oV \oz6}m1(^lhP nyaE uV{} Ҝ,`ܩCmԢ6VM8p Rb:ez:ҍ3kEA⇋Гh|늷Nc+pwmK>{U{X`z"Aȁp_""+ZpŽ ˭< 7L0gKwfwbG~|ɻc^&:9#!B F v< ߻xsj4J \&~m747*:7#{R8oC$p!NrS:v =wH@:y!hj^#| 4xMv;Z#K3]Gk2c+k8%pLNqja*KAlzR¦8|h;uQ -ɛ%KahˠQcSHS A l\) XҨS䚵 bb}N7%ω3!~7m H\^Ơ^)Aw| vhx}O} tgjq $wRoyt~ {/{nv)XEK;\y- ~OU +젗{wihL@-[lȬ4wkŽI3zrMZ<"]]|Tn.-pֺdҥ;T:ajܳVC,rNυ>8h,MroZ ykzm (SqfUdE2ChHH18 ;_p:^LtWϲݥ<_{nȻxVUBfFA G>_gAc\v)ȐfIrR} rWcI;s F=~9UDē-$fʕJ<63yizuf~$ZS=~CtP.oqP*xOhwCEuP+Mեt0pxRgVt>HWeK^"erz4&5VT.KK+ҁOG6=!vm֔_jNQJzVf7p]/a.*{ M-DjJtf`Vs0 iHFӌHCZA`q4SYv DfrkuZ]sZc#k!\ku GmvA6ZH%%.qxlW&v&a<x+`><V/^ 3YiP԰4wwDR%7-5}^DLK%I C<ԋv^UMp<|"7"P\-xRdFj#!joV~c!OXl^`FmUNsIS|֦ʹdz9j3+ժ\O).5*w{|)4\DP˱ Ӡx1[mΩ@h:t օ!7+PwO`8uqUdWGW|Gq?k*~<>Bk/{o0 [l6GӁn:FH XqPB] Uo$D ~:XL'IG,4Tk0 K2}bPa7Mѩu:~L_dSӣ_rd#׉9u_X@yN߫Wٴ>d5m_!Pࣄ4Up8չՀ?ubȮFCL02P~@&Ȱcq5#@#b_Li86VZ^g}V]aiͭJUE#":$9x@'wzjJ_DIV]vjn3batNҞ4eR!L ,J&~+`RN4uozA~SSA!RT 03`mk,q߅DV;@> k 556АeS,3"5>lܨmBϤqtJπ;8E !I'ڝCf"CQ\ p;?::-Wd6fXZR'k'X WK؉B6E 4,Ba;x85qTMϻ=-PѭvX!;܉eQe! l Wl `Yy>܌,<-?s^(ɣ32$/̹pm#y`EY\P+(2 ]!p v5K".nsOߝǮ\9'" Mu^*kojjlhr9䨩&vydܨMT[N,jiٌ(t{ F7 %w8s Ie2".hAv,G s>ءMy*tiDC 0+=vpΞ@g^Fw[ZiQVtYtjG$o7zop0-weʞl2# M7D58{mU.PW0! M 2tsH=`jM$b/zl}0\4=9\Phgƅ9P+ } LV9t2EAz.\7m4D?~ *7m2,۞l랂Än0khy&hM?6pUŶY`̱! X֎Z+u"%Ij0۰j_;+h02<?"&NhНg<x9ѹu7o)5:|Tpk8ӻΎS޸\z5~4YQXa,כsF9"zc"E3|)ޥqjJ hNCÙ$ K<1c9Iv/ V{| ҔJj-%0Caw HCӄHUI4.n:NNIy_u\Nm ׍yN&9YMCf VfM5S!gI(mg|'(C90Vb_ j`t1Y4P up qZ=T p*sr448 R/+2tF>Ql6斂c|;<'^)˿Oԍ+wHGe?"%Կ:0XPK;tw~m~|iފm!i$v[y~4i2MAWD,sf\u+o-5=K,깯 'up 0H pVlȥ{wfKoByff=k,Ϭ1m fkJY,|ߑѥ:Mp"̅췿9ۣ{S8%jhl[-ў][p?j` B. n4N.6ʛZ-rD˻bpk!AO8W8e!-UvoԧۯgY\֌EߩEnXq#?Or?_k7\krʬ͢Y+ ?;\F}ut,q|S[wZ!\8~Pt')ROl _h %I+o_:xZn Z>"P@}@ՄxW@VxR4c'XɋwqD*5KzI߻3s ʢ1FH~SY-?=O)*KXƞ> stream x}Rmleۆ;fY'[B@!ŀe7owZ;al֮knZZaG,B6@5*-w4ZEɓ?$ $xFmslm^F3FJ~rb{kyժWXlǖ߯w7w6Y~rLKMW2"ŵG555i$s T2@^zi0`5-^}>#NQTL+QG❨ mu@E.Δm.(!NNQ;i!D .^eioݢ$fR]2'! ʠ~+Y4Ks nɊ.=DslCYS$$sTLcǃ%v!T0m1wGhpƥ~*r$n\]Hӻ*%^܍)/N23OmΒxtbx:?in;uMMϟtbG]tܫC{ K*+g{bd63xhÔӾ ]FUOv]K?_-jJ#ɏ/ocG__:]p=3~ބ (3+CÙwх |85:KivTL9݌)۽F0TKvoc͝xeVҚqOUmyl<XVb /endstream endobj 59 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 504 >> stream xMKhQd/&Z0iMkZVTpuj]?3~q? wֹ``&эG XݶT+b*7p0w= _y-},*jrW-? ?y{of,V>a+45P-kmQZFc3o9͖I_endstream endobj 60 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 450 >> stream xRAkSAM>[I#sƠxi@AbB}*Ezܼ7e`nF7Ro^ ܗhW/|73rV0뷱RL6/Tx\O\iƃǟk݈qTxWŷz֜?ku}cRnCoAG{!8@oD}$xn:{AVH=I t)Ap2mA/h'\ 9 &Q`ȹ9ȭPSH%r!iXA@Uw%!(;=𥮣Bea9%)|CH)FA7PKTPo\T[YM-[='Pfp0t¤13Y~LzsiiM&c9Zendstream endobj 61 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5721 >> stream xX XWQi*⚸Ѩ \f}_Dn#hAcL4QK$-3,sʹͻ t;{4|UusS"l%9Cs|#vlE¨hq&:_4M utmy~d!FfgGq6D}1~v3ߝ:gc8n@y"nGi.VˣM!v2A>vrMv>Z25~δs(!r%aK""Q;VE{:xzYQ An3g;k{s掙oumӶO1j-5ZG\ GzmjFm6Qj3DMPKRj:!eO-fP˩JjM9SQ.j55)zRVʚHʖ2 j 5L-P5ZL9LPfT#r0w@LӬ|y9=VHIJw77N5 A`բkC<n v{x#,S)l,{y3^:AZ`eec!#Z̴Qt22gf++lCm> `(y&FÐ? (X-z*P@@ FmAju( L<$?J7?pk'(4{Z(!KRxw6Lƣ8MdžQD5 iyH0% '4V~l5Z&wuRu0J '*T'H9'ou#Q0 C7cm^(tYVqU_}[\ς7ci=@ 9*}(1SDs+^K/j{,ʗÖf@&:) oJp=oQx6EwޢEqT8=->c n\jq"sʪ߂7hݹnJ+GL}Mes?h,ohX3RɚZ,+^]1urcT\N`=*E=b#228J/Ar0rߴ_~HϦNB[_Y,ϕ\fΒPx ?S¦#2;)&[|_U$Mr5mZ pvA3D[#tʻ^.kÞ^ oԪ/FUwƢc9Ec-^`qHSe5ۀJd kޔ1k`h%LsCPjXrJx6 |CeѹZ0KRD!G. )$Wģ?VET5PJUS@%zo Cy6yU?:3mc`)Qw4Öyg'ڮl= ZQ Rk5Eҧ>1 ktGN^YcoU6NB/UlV4cQ8\[7!'SmH0q>,4j~e+S9*c{s=SՑ]Ŵ2OSW2u"H|?,#{cJT ?DNj>)$$ .!gQHtu78a)(ˣdPCXX,UtEU*&<:=rEF8A~ތJOD2s sPc̜ >oW2_sTRcb"| D)̳5^w} ԈrlwJƴ[Z BP}ʄlJ&d:wW ]{lU6J GLKվc;p-&0F~f^?\(+pl/*@6Q A>ǒ~d O'4hS*94?CACoT!?P$Ў=D'oO,Ϧ!߁ݝuMͤ((ˠx̕jWWk~xܸpfz~EXr1N_Hx<7րflZy D}G #(1KMW(ƫ_~)]vUİ{`dd>ԀlMN^ȮXBeЈBc>cS#Sm[R#r<wStUjeO4ƃ^Q0/%tٵ h#T4o3c[,gRT65xud(5VknQC)7GOG!EM3[.*=&JnCKiDY#~9-c*eQaI&=R&A 2QA'K:J40"QizI#bҿ:K-[F `ɇvsŻBv3X*W ͛Z'UDrU㱋tn[DmyOz t1c'OXrHnjO=X[_߸u,/j6cLI&' "㷄ji.8XSյIe]b! KQgܱVY{P{Nֲb$s䉫 ;3h'MML#ZѼЏh™jTcGs#)K"+BQa=ˮʮm1+%mE Mi"{~ШBB>&Pt# aTXdHir=hdaa\'$TDa"CD0<`I S#&t*훘l ܾg`XbT``>]o0d2%g"(zB`f6icD)-sxnph1{L"2ƶ7{ B/:LЈnh!Naʄ;#zF77TVB׫ g.* Aٌx0.4tA MSF 48UK N6IžđM%DW40cz+/x3JnQ[ q07n|55_!Q"$mMLֿ HLOs+!;> E1IyʖSť\&o8Jem1')F2o$K~'IFmAƲV-(HŽJ{!S{>xX;<0e\]78t1nYv&%(FװPc*3W˟o}~\ۮu'~LXX"E/o?ڍ>g,iK0a,p7LƎ>Z(#;Q`v!%'kLdknּaP-A4cTiLZ]1#**}3<0h"nBi^HIq$.,o1w5s=7UGw2fRa񾳿_!!B_٤${zA ♏0=t &mT*3S332PvWFT4w{GѤW܊3aв{^ ~Qt*W'u_oܸng:Ǵխh"6n=zU=4f1/Cx-dmUy_!wnՅy1N ഫPUS؜N/G9߃ߛ?o}JwV[4rc{ǏtmvX'Nܺu}3_I]\r՟]\>w {q?)4ПI 5(yW=TQ9-f?ʩS1Vި8x{RٴZUcHl]DgTIB666;L3~}2/KCۣ)TXZ^S YpD߄ +?tpg^̅l/&?/yy둦>m{}t x?F^Yqnk?k~6-}[3Er:YYLh; P7G($ctH%.uBѶ01ᒭAiO}2q>V2{o$`tmVtR%aoɧI'^WJ%C1$mu[}ba0uA~*C}̤tĔU4k`ŽF."9?c7B{H,))AyLij"o#q>._]WXY^D:A*ad@DJlBr^Ja%\mr&IL#$֪,j^ِANK[|_dș$EjMTo_ѭၾ~NjrU=\L"ʃ$|%}u6ɿ&ΦշEYi]8|N&݆JxJ]+8 GxTex2L^_Waӏ>_#{ns[$O&+* OM7;e#f/(7Uz!P@d{ϯlqaxRlʦ&eC@Z,4\9Q$_'Hp*e*Z3P;h^n֨"?9{Tչm%%"JU$ LQ &Lendstream endobj 62 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4457 >> stream xW TS׺>1prTdQzh@EP#N a&L! B@0ydFEQJC5jmVzoOvcesme6֛\\d!ųʃ~Oo ' hwgժv-;i,̺Sg^۠ +˚ ;e1~g&{دc|+P?mң GAd='lgO d^DJdU\<{zc*:v=po%q9KBbJ0Ixi*`. MFӿy[WpYG!6'*@VJ#+ջ`!~ o0<!߼08uh]Oص Ώ\ y c/Og3Yts𩘳 Ȗ[9fUkboģ\پbthѴ~1?|sQHͮEHlE>f},ڇŶh->t4D=/jMg{>J^yisxXk^1n\ bځIE¹E[7EaEðpR ō$t  HZlcD҆"`jqC8] Yޏl%Qu4<{vԵ4|]\f u+662%!SbI]W+d# cQ )R.&(of+ 62@ Is)!Xې~w*I~WtJafAd%$aSi{ZE#G`ͱ״&EP4`Vғn}f5q5T,4AlєRZܹwEբ?Ȣg_=Ϊ 4|?¿m`ѓn2ҙ )!ءI<)@Px C5%oX(UB>$i1ĂG,|@gJRq[Txp&ޅΘ0(ZJޮ2~&e=5_k*5ŌΔ\3OC9TeخZ4}Grg[2 ,}%;VTԖ6\d2!6sxiXte=8M_ V DI 5wNplm|u YkKIHڽhl"lNԓ`ɯ9QnÜuk-FX?#eh9G^t\X?Hωbb<,gؾCt# oha R*ٿ7ٌQ<<#U-!hvJ:ډ^i[܄rE'K%Xt,2>PI*F0 ;`)Qv+'$Z kNFQJqх#F4N/r2D OVإϏF|Vg94R 1.7X B y)HyC W؃kyg'Cˊ!LӤkԙWVߝxf<[sB*z緞W=B^K,/5pbh-$&% v^񞇃H7&6ZFu/0[z^(Cw>4LՈ#BBn`oܰ&hܺ«Nv-~b14bE+jΜm8q2z6Q:N g~B}ߒn[ w;kiSMMt9u&|ib3C⪀+6G_CK>|5N )#>-7o8D r(^Ytȅű"uH?xc_l'ё$P<f|*Ok/x,ۚB3@˗:Əoߘ'K$Z,Lҟy|!mh$ua6hWe< EABmD&=$ض]|Ic1*rњO 9Kl͊K^-%ye]YSU6%+;{tW ֺzp8{$%''r,vPt(Uvl>9f?GSPE' !F2HH3~@$iH?D NQ>"g3K]F"% #^BYpRR0'R>mP!Uv >Ċ WEF L$6V`S1>;cGbQT@Ȉ@W<%o>w xƐ`ۣ0 :mr:="ѳAr 8V2ԡǕ]~e@=ij_]gjhHv2`1di>3#KSkaVQF:Q endstream endobj 63 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2870 >> stream xVyTSWJdj;:Z[TO[ 7@E%%+d%daK@PQhp֙svZ紽9}9"No^y'}"'a -KKo2c/efO ͉Jg?9،UoYΊQgg?~4jfOc Bi1/;G}yɒt)wUwSZF_\nnAwgq3I kw&pܖ=q#a %Hq 3+;0lہ%`X ۍ%cl-[m6b-X<Ħc30MaĚT1-/rq7Lk }USN陚=4QkQ*P`zY;n2B#ByWKu|([`ulM2YYDV] @H[/O6;;~Q]0UJ5ˡ[[N;ۭw.{ɡMMHT'ߋb#(&#B&cq-j5Kq#k?B8z Ţzb,"LB#Í;WGџTD?QQ/^5)|Bp&դ4(ˋ$y]P>9/X3TA2f6KQ|?8IUd*m¾G \G:oۧȄд0zQ(CS5Uҝ#Pgl%kz4ZO/5L`ׇ3]}#MBNb!Qa4"$Epo~C=6Pcx:}P .fFc( סmJy$MPS>pCqH{2TǓfK D(VW;փEhvU&:Nq|QU@"BDY Qʾ}DVLz c'O@f(sI 4J"ZȌ{; T73+h 4?ʀo N,&\np;wZfNخkJb?VM{ 8<M!`'>ψKآpfLx.i!ZR_-%3%^|PHwQ'nA?\m^0XQFAm|&~({5BwЁ0Ik5RRr(\W&$HM_{%S1ϵY憚n]JW@'SO''=l^[~.[L\0>a+ T%jVx%oc;oiM \-#$}?JKd bU-VWa9MeRLe i%P\j!E.:{kkI% BQ1;N-C=@LH@ N:JJ^$80ZLVrŠ&&vHbPpA=H"l+Ie!(rH{ Db{$eAO|j21nG/w]J&vVSl*z"wx3C =px嶌ѥ"k7EC3KVS'Xq9cG"MI,(F2K5}u.> stream x[ێͳ@^dHb1 ؆?36*;͊ys~4S[sԔ4XibuץO*r?d?zɷ6f,}c~ܬ/! yKo.Κy&,+Tzvf%yp3.߶WF+? .KƴoRXf.G%W :pfol7|Zur;^vۤm^}ُsߙ.8zG^.4JW>˿#\D1.9+h]vy~a<-pvgP^`? C0 R[mªgt4[EWu>/XXm]RX%җiH@:)ciSbԊ-j'L'N3|ɣ3./gO :C"yem0͕ .H-ľuV8l 7Bcuł m0IPhnVBqNTOLF9 yߓIqlA/9ZA^aGN`JIi$%$nu@8~2Od /Bz.}Vb=.8]`C.*9'4CXU")c:Uv(yk0P$ R &bu\!;aM*[oq GcD [#`K|r-T!u (Sy 8O?w9D8 #(&l`(9HL`; #gXT9Ej#1v]}Z,E*Ȩ?mAw:85_ӇpQQ.&d92Iq`]PPd}M]wb7X1P X1\X\-Hx]èt`3UgQ3pvB!8д#JsکOeݜPBٵj*x?Qu,{ ӄM#J$IV}tFkGk夻;6 EEv>UXb`1QQ{s`AyT =oO)Þ78:n8?;?hnK~Ԁql@6GiђG=X`4Ɲ;nyނ͍8 bS=P͞%a|>F}0*3GJG-0poa~Qf7juQ>ޓ&$&Vdt6Sp77˪ZV澙X&_l4}\Ŷ^=-Uw竇 Víղ[ˆKU6ئiesw*lexv3ϖN^kXx^ jhGT(Uɸgj7uNy w7^9ʼ[<}6ěP lvP%ub}M_冣q&:#GÿI,66K[tdrocceLO3=;Yi0g%6Ne*bttV`^;tfT0f~Lyx|$0j{mM5=ϐ4HI::G""<8'W*ՁCD7| ozD/f4yo!Vjpb{*614PgRB4\}OTSzY@> {{u9fƳ38Sʊ+V&XƊlQP~of '([Ϥ8ͦr?{ I h{NA'L,RߴoXdVe> zeNFW2gJk7;Twwuzx׫?#ߖ2ENz[=>C;yF3jFCkPs&,Eg[ZczN,J3 1@6q NrlAbQ׋wH q’@Ҝ= 𧻓rvEIgy㴲M&Iэ>Œʇǚʰpb^.,l̺DCPgͪPsz/˪jVUZ*z#PP]zd]i[~>J8p0@i^XdMˍ[.`Okq&VTigH|plSxƫU˖Eip&p^Ώ5c MF̪i4%#o~1: sQf0,x3X _Us2 oW%kE T~L f=Mńҿ"\qWcVC!C5yf!)4|YE`"1]T;Q9҂:$6)j AA{Zz6WڼadAj'D t/~W9:1IR14iE薛by?C-6L>G&)V6njm1zK``S|2!4J(AFB 038.5v3J,t/OJdOqF ?ң6*r\9hNHRz3:EF>VL.Ҍ(AEbݕovJX3R΢gL}s %51j߽hXE&B$!_9z+ofendstream endobj 65 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3274 >> stream xUV TgڞF d^[뢥ZV "x$@JH" bI"-r"UDjo[]VV*n=x=&˞9'g]}y$B"LoZr\8.ϐxX- bb[Vڞ8i&O"b-4=?acₗ^Ztdݹgz!D/zْ7O/ Y(JoS8[n>sӶ4=b0鰘-:Bhtln!2$MV:ŜIGf`3MEVZK[-dޤI[ĉEaZ;mҩZMmf`J6fxZ-MkZ x6:srɜMk0Yi>&٭uŨyq(KWB`J}}!Ofz/S|31׷[$fSaЏ@GqZu\ $ܐb T&sՖMSR ƌK^ yu"%x"D$Z-"  D41B(%1F*"ˉ#*$1TKr?f۲Ay&I]1v؆qύ6OD\?]ѯR4Qy!2L?SY TC*gvf'A_̠ ɝvYߪP.<<j?H;&g1}o"˼J|1IHN7KX$CL4-FX͛BƑDϿ.4;$¸EOĝZ !]p*7.XOu+=uEg(QCvoèK@BzMԠXMnQ55TK 3WmAϩ$t> 2[ v_VHrٗQ>[>A@_+T ͞^.mOcfiqU;3Thͣ3rj@3::\(aMvcl덻=L+Ü! { ;7N?)ܕ*p*v8)ŹlstϚ(Ivv ޽\6McèFh (!49#A HlnMåȺpk:=; /bU@?~ S'mms1Z'="k$.d 0o7p'+zUI۟ I081 k] b{s{6c/ٛ[l;z ,֑bhb[bӰ0k\4%9't;x=C=GjzhU)L#am{]s[1lu0PC#<^ȴɢ\r9]U%WV8K 0-f0|kOKy!b<5(k?)nTVsv볋v!YHS"}Dv?KS$N4o|M8iJ;LeeN⸣OOAzZ>_ ϖ0Xb= gڦww_0"ee44RSB7lX?ۊ:ןĭ1otŬfc_Y! K}D xJwCxك>:Cաwu(y|uH$Jx_#|X.:~WsE_&& R \:W0aM֭V\;$h] ^ <x@U[5a LXZ,Wp x.Ϋ%:ګa|"WFL{ ܳŰٮP&rjmH*6Z?=['EX#-IsCM[?սL1eBDhQ)7#WJHRܽ>6t?|HFy5kY@o@S!P)nO˸-Ebvj[/m! bb#w<1uZ>'0 (Wyr_eѪ,j-EZd!.G!Q#ɫoB%N1"M| j/M٠A12,s#\e%]f_glMwăٳBqz`)l. =V延ԕ%&wtb)#Ih=)0Dr;UCfPsM >sKFXv;?uS«eFa7nU4д=>6x-ɧBPvg^~ IGop3 Dyu$ϋ""[0O/zAˍG)G*N9|uuTzyih%Y;g#+[DjH"h͔y/vtof CVR+C!)DmQ^2&A,*FuuF@&+o0苁3W l ݘ[U؛y(Y~lܝǪO 6endstream endobj 66 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 288 >> stream xcd`ab`dddw 441H3a!"VY~'YH|<<,+O!={3#c~is~AeQfzFFcnjQfrbobIFjnb ZRaQRR`_^^[_nPYZZTWqr-(-I-ROI-c```e L,?:~^ޏ?տWΙ=~ewlUs/i4\Xy87b^`nendstream endobj 67 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 726 >> stream x}KhAw&}&PhL[[ %)ՓZ*Vf3;QPۤТHP-xЛxSQvhep5U>R/4Q`Vmզr6u_:}Inpf l97W!{ 8y5xwFr:v#I C`Owwwe퉱::NiRL`GRx6 Lߒ5w~+hnM/%[Éo#yWb4.n:va@{Cˁr~DIendstream endobj 68 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 417 >> stream xcd`ab`dddwu041 ~H3a!-=s7,ABnne?DW ~/^,Ș_29(3=DA#YS\GR17(391O7$#57QOL-Tа())///K-/JQ(,PJ-N-*KMQp+QKMU8TB9)槤e敤%d$V2000F10v1012Lc?G ajBo~za,^tuK8.).Ɉ؛xΑu߷]™~{1kN$6u^RߞYU]đz% bwB\Go?]*m[)wUwzwnl2+-Rùy20(endstream endobj 69 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 238 /Subtype /Image /Width 291 /Length 4841 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK#" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Z( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (fdڀO >g?P@(o?b? >g?P@(Ə ?/*hг?YhYƏ ?/*hг?YhYƏ ?/*hг?YhYƏ ?/*hг?YhYƏ ?/*hг?YhYƏ ?/*hг?Y fMv08Z((* Ռ}LM? EA`ԜS>'Qo?Z\\$\1qs:UA` Spv]H` M5ݬܓԷ7QL"Ӏ,L΁`Cb88[ZI/>d`I^8yUžIʒ?)ʗv#G'Ja7p%N 88pxZ?ZU8[U+N6F\yQEQEQEQEQEQEQEQEQEQE5(ZEm٨YuH8 FHjoEPEPEPEPEPEPEPEPEPEPEPHHi 9@.U<~5.V%"IP2zsP$ǩ/ɛ?Ӻ g%8/jGZ͙d1PmQS-hRQLeu?6]OͪQE&h VvZ"0Ufgwxl@`U{@zzgҩk_( ( ( ( ( ( ( ( ( (g͏y}:<3*z))6?G@ cty}:}G^Rݜ6qZ_6?G@ cty}:}A{ڬ ΍v3g'͏өhl_Ώ6?OctEmv=~R?I@ cty}:}6?G_ΝQ;n$vwLgh4``jIZ(((`P[mH|VK<j|^;cd8qIZ( ]G6H7:pUrEiQ@%3NǾ3קlw])JZ( uӖwi <<pR@Q@^JYN#ީ<ZKم@#8+F2%9F@2EQ@g]%RFO' l u98鷝( b>y 銽IK@!KEaKKEpp۔?1 1z.kZHBԴQE 4" !'tȭ|V@]&ۀeܹ m5I@ EPEPEPEPEPEPEPEPEPEPEP6]^Gqi*D Hw1agQEw\w!AH$ޢREQEQEQEQEQEQEQEQEendstream endobj 70 0 obj << /Filter /FlateDecode /Length 3043 >> stream xZێ 7~@0fL߻%l$Z+?P,6ɡ9CeR+y<䰺$Kyѿb;6Y,YM~cYl@ħ_N<6KT&vrәҌ;әg;4O`&teeZ6ә*[c>X6q[lE[(P%=颗7bv? _cX5*N|>=lu8X&yܶhL~ϬdS˅&ۏ4_91gY,Nf.9_½_젂I],o8+Ѓ[fooA'7-fÔ\arŮ1z]]4HQH]>Ude5-)Wntq@k^5JԓdšlyzYVWS̭XJg瓯 ,jXD8cSe)Sg9Or"ɚHO{rRkDZ f#"? Z4 ۗkI6oOSeb6Obfdg3`d2ʀnP7b<w@:ՙ{ ;__W?>y[E678lĨL>!Spe4X\DzZ df]एwh ،ǚTM šiXPL^ =E565jX Zقq-[tVEHG m6,Ǟ?+2ߌ¿{IxNFOֻfv9Rw*ڽ[\["DW} ¬sÚҺ|QL%%=*kO;x ֦QhPZ*iΫ°nMm^A13 ;w:!}#"x<0,?.XUׅ@DϞ?k*/R톚/\)4\[yn燷`; VINW5 JCyB!VޣƸ2lq u!>Am(!اB F:ߞnaU}ΰ OT_.ؿAoh6Fͺʰqo )':l-9:m227eڔexh3ϧ 2A\G&>9*xLgyU^GMͼ,5G24^GMf% [i(z8.jyQ&eTDrTXXQ$׶.u-^yEdʚf-SEUނ^5o]Du͔xbzϷ.BPʋl#CS`!vGtinZĬkz tt̬ Έy@HY-jpTM ZL#c2k2OaSK?!QM厄BKO8C Ȓk!1wnb4QPxcAtonoȱNiSj(%иIR*AqDa K2hI٘ O6Xc^aL&lvaBSt#T|v[J9oC0h3&9M9*s@6V!$:Q` LfDMD+ ݍA% :5>|  rKUq q\ݧSq5~2pw KlðpВ3Lŀn.ߝ1UP/M?5}2=¿o;>DOtu з;QW ^>ЭVt [R*yt9ݜv$>_LҸa 8O>DaJڴ"OwMC6&z~/{oqU/Sᆵ%?&d;1!@u]l%z>b=e85`_H :P &F?9Pu8D7I-1p<=1 Oz'ѤGd'="(5鉸]Uq <0cQyT<5ىEG:gfɯ4ț]lxܚ U^CnF?^MadqW 3dPX  MBr% {ûy:~9R:R+Y6 7=ͱC4œ G~xxq;+ TkĢؕwUxq-VC#uo{P=lLJAS2>=^yD楎a}_hTNqU8Ӏpc(͓ ,ċZ[Ҫ#@ '}Bj?ۈUendstream endobj 71 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 238 /Subtype /Image /Width 291 /Length 5213 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK#" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Z( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( )(fUR@P2I@ EVг?_ 4Uo ?/g?pEVг?_ 4Uo ?/g?pEVг?_ 4Uo ?/g?pEVг?_ 4Uo ?/g?pEVг?_ 4Uo ?/g?pEVг?_ 4Uo ?/g?pEVг?_ 4Uo ?/g?pEVг?_ 4TP9a ɷK@Q@Q@t.CNWNs)5N" d_!2mH?XγS]}1Pn=z T:^&/te#BmXZ((((((((((((( %mV*U((2\fC嘦/|yl#7zY2IdՃhMslg>P_JZ(7V[1nrEO4{,%RRT#\pG7ÞoI/ 8 ~V-U@A)j ( ( ( ( ( ( ( ( ( ( ( (+\X%mV((2)k7[}UZ5I+as=s]J+9@.ʀT5?/jFj =GeM_(*դw 5n9*ǔrZ=˦]@tZ'b=kn)/auzpH??zURMNH$^$Oh+hQE ( ( ( ( ( ( ( ( ( ( (+\X%mV((n[fhi",;8y {t#s3kB +6 E1=z :tUCMGxH'Zayqi7rOlևcv9֩_( (*ǽ硬=R)4=@j6)Ĩ8x>^0ƒSޥhRv&#aj(_ j>[){)qЌuMK$NXpEPJ6%($(((((((((('r_b\X( ]HG=I`o!C,6;$qaz+m+QXZԓGHQ`daO'oC^^&8JQY@袊(*m3UB2)5p)CشNW3ssz[g#ӃutGuߡPRh4.2bR,Xdޟ\m߇JZ&<۟=q]lq' bZ(B((((((((( %mV*U(k4Nc?t*|Bk|twS7[J>,e\@vG$adKm}f Ee@d*nlgrUhbDb~SІj {@zzEPEPEP$A"a[KQOjQʅXu_AaهQ\Kx=)9^Ƨ)"F;[B; 诠D^jqVW њг[?[Zfmz9O= C7עR@QEQEQEQEQEQEQEQE]OͪW_/j@Q@Q@P׿׬ &;!=Yw q|Ϋk_( ( ( (#%vT %aW鬡&@RTH? L,VN랿~ε9-t|O J=zI)69[=vN_&#>2kMп=Quamv?~5Z|}=ِ|{>ߊyuYxwp?B-̬}3 qhE RHQEQEQEQEQEQE]OͪW_/j@Q@Q@7Ry.Ȳ 9=f~~[ N-Y-U O\ZXG^^&/EQEQEQEQE^[Es~VfM\ "Y;]w/b:XhFjR#"hK!(Ǹ+.[ͅw7V?`ỻf,3Fy~WAG '4]A_'uQЂO8~ş,xg1!Nyd\V@9 <5erT;kE4s.W\*r)B r?aDS'Ⱥ3 >Z1zq]asI)wnWfJRkcn&P?)KqgEk$?霚6")v܏iE_ڏ=#wө*xWbVXA eknC* BDdsE%ap7Gtrx⬥>牛\YF3oO`N?:s{\? 9Z'Az+".mszV:KxnϘq!iN'r_b\X ((*u}LbLam vHw\IZEs\\aee3Z4PwctTvyEwsg6?G@ cty}:}AwP>Ͳ#1@y}:<>g͏y}:<3*z1Sl_Ώ6?Oct+9flՉl_Ώ6?Oct[ PY&~3 Z͏Դ6?G@ #ty}:72~G<d_ΟE3̏$ONy[v| @/OULREPEPEP~ʂ݈<nG Op=;梵]bY䐋V $$sZLPEVh=FiDpy 1ӂ3+JG<6.v =;cjPHzR@Oc.+H'l%x܇/;(7TvH=I:\F-\ *1)pFr2i(t+:.?8h2~Y8f`HM@tgg-vXLUJZ)JZ( ]^.WfܥysZbEg M楥(C_jo8#XL4:vyđ9Eu} 5Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@Q@ޕu{uŤk<*K!UmEr#J p 'zAKEQEQEQEQEQEQEQEQEendstream endobj 72 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 238 /Subtype /Image /Width 291 /Length 9319 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK#" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Z( ( ( ( ( ( ( ( ( ) :t5 C ?:EPEPEPEPEPEPEPEPEPEPE z Z*Whг?YhYƏ ?/*hг?YhYƏ ?/*hг?YhYƏ ?/*hг?Nr{ HFx y>s;p:X*hг?YhYƏ ?/*hг?YhYƏ ?/*hг?YhYƏ ?/*hг?YhYƏ ?/*(n`hcʥ((j_/Yڗ#@h(`g݉h-Q@TrJ g40SZP( >7\۱^7'ij)P=:r1+=;#84 -hi (0((((((U'r_b ( (9ٵ+(YU)| -1{]^_+Krۻ{)F$iFE. z={@zzEbd@yO*9#VvX i#oؑR`.z#wfJNMUI!} a"pBF'GPMMWӏ_T2yg$wcVEb4Ǒy$':MFJ C G8N2GSΚv%zGa֥sӾj|RДn! 7U#HH-Ʀ"{cQcdڟPvihc ( ( ( ( (+\X%mV(((A5~k_CKHhAv5"a/ MKROC,WL9q(ktǏp1 gS [CV\4`$Jal-Ɏu3۾ M)J)Z( ( ( ( (+\X%mV(((1믺T 4q.b~Mn62@8_N4k*8>&#=kO:A4~[hZF.2=Sos:9v TZά#veZ>mJ /RTa5  t(Nc\KPrVBP,GO D5-=`q#?uo?ZMiqH#"qěd#? W%V,vY">X\n*@ ~9ڛHLhB7N VoŠYy. /$?¢D!6C'n)Ժ[g|Lڧ_?SX;6C7$HMFfL*cۜJ˞%`(YJ׍*qkN]et Eb2EqqL\<g#;Lc\c+xԍNU[0? :U\^G> 돦OQM6w߸(~翷"Xnuہ8n3Zf3$;>b 63= 6׷oݩuݞqϿHQm9I$TplQvmOg!c uSjS*mccEgMxg%Y@lr=zT-y'8SZD[\g׵ f69[h;~\gE}1:\*FEB卸,Âq֚fX! y}iܫr ή21R*Rf ( (+\X%mV(((A5z_\6r}V w'y.)!3$H93\XnTXg:twZ<=8 OZPDQ3gEi=ajFڌz텏@#9;4:v9{QCuiuv]9A}zX$"P-~QJrV&敋d {vsm-ΖM:?t?"!sjI\Go!Y3znOul|qfyoz:iu[QIJI݅v ոn1z`T4M^FNқWcp?:s_*I~@|C}{UnSO|2X;80u^W#[KTge$3},Hf *` 9k뿵,,c&,yeR3+kW.[RqaI.H)*HUz( UnT[j:6DIxjU]YNb09Zğ\[Il.ӹSőǘg5Z/mgOk #m& UgyP;iI4;?*?]KĉA+)`䁌=9p:Nk/جX)Jpq鸑Q1෷i 멈Ǘy9.B`U;<0w)MGvw[&\}"խϿxg v̲FT9FJ6u5+ (l,p?Q2T7 ?V2(ŜsY'W#qQq~n=*n@'r_b\X(( "Ϋ$YYJlݻ9ώԞ#[_y2DYw?)r1ZC^^&.KxnFq\YEgw1޼Ķ r=+7sQE[wb-;d$G$_ʶb27힄 ꬭ4K{rŌr38$1V3m§-'^F?^cSvXԭg5h# 7WMǩs4r "RPnxS>K/teo2L̪O`yg3L2wGAt? K,Flab8UGS*$a 28Gy⯕YDUe]m {KjfQ*[w39|OlHYıDh8_JVFq$)w3X=:RO bI3.tB%#|$FTSmŕRq+ #jrWYp }q5S|z?N2Od8"V%%L@Xj25='=Z$aJ T G@@e!G9ҴKSYK&#[y21G>sJ~[nZECEvi3ky'DuGBel9 A}o2mw 2SדjGkj zqS ҕ'{Ѡ黶@'r_b\X((* =GeMNom"|2 zuA QY@V[jsH7@1]s~*{vF~VbzsL\9C$īt8o*(,H73 j౉bZwn8Aq '1zzWsTՏ,me[z  I 1 ?, \^A5AeG~k\>[_aѬn#y0DNr~#Ts?쐣v[>F([pQRRy.\V}M#Pyao"|mdT:Q9S[8Os[vmGLcltra*9b=H4֤r2. zYV)#Q+"o,$F0=Af/L|7>SQGoBtIT@c52zs6 ,IqKhnZw4o"agޒYnﵳ$BoAY`&'t%mgu3' W. KP6z`N +H,(G`H<yPW AfwqMqPb8E8EC`uccHe}a.r~GyuY hF,mLLY71=K[!rq"{u̦>NJڑ ~QYH /)jW t#G n9!#,ˍ;; 0tJCo+')>IvXX,z֊)(Њ+tqJ-Q[;r1s權ZTiʈڟ1KEQE]OͪW_/j@Q@Q@Vk+(dpWJs<:bߕp#o_֍Q׿׬ CTD1ɐ=NӊQ@=J+J`eǜҝeIw (# 8l%U˜ryq$$FPc;OfԬ/5;>ۼhsŐXun-4(TX#`wfX40y\t=?*m1GͷU{|~c.$f8[84f"n ą>U;[bCSU2D]a,XjcEaXh۷㎘x*NҨ?N`/s_UUܵ@7ˎF *nNN*V/ ;J}SQEQEQEQE]OͪW_/j@Q@Q@P׿׬ _QKjh0AsZA4~~ӳTbpC sQ28Zܻ\@8jI2T1F89*Gs72䑔]dS)9'>%Mlc䀧8ye(xHqW-\r3cdьh-Cu6yvzg&agW$B~SzUwaRȆeHOz߮-LG>a!F[XgT%d8v;B[m% ]6g0D$6 d֑ư,bNˌԖЈP ǩEj)lCJ r>(x:SKNñVXC4C'8*uT @KE)(((((('r_b\X(( 9>"fC#jwkm6|L.~S ^5_RuqhQ@jj1>Ƭ##9К$1T'?DdnC }bIV\wq~ZKe*`=J^ dt( GOjq1Klg8(a(c ( ( ( ( ( ( ( ( (+\X%mV(((ڗ#Vh<;^EQn\;̏GP<l_ΟP^[$ogl~8Ict(l_Ώ6?Oct̪c<l_ΟE3͏yHWvrǫh|l_ΟE3͏j6:6M21Pl_Ώ6?Ny}:<>g͏Ic}H%3͏P<b}:uF]c1у_ɂժ&)h(((?UeAnG i#'QZޮ,HEeDAx퍒tƭ&(h+4Eu4i"o<DcW?ERңP A;K_x^5v(=)h 'NXݤ6|dnCKEQEA{i*Fde;Hb܏z^i.#fHl8#9()h κK(9$Nrqo:4P63|}ݸAz CҖ6n*#$$Uٷ)b~cAcj\ֵm!Y2v9ih(i-DCN?9_Y[pM˹rA9Nkf(((((((((((((((((((((endstream endobj 73 0 obj << /Filter /FlateDecode /Length 1890 >> stream xXmoFQ.{v_/ 6*pdH+NY.ɥ8CZ ggf[(moV,ۯ~[c?5Hy0vտ3aRe*iuENye 8%Ac x9/iv To= rAP Sxv7QMMk iI/gN5tפ׼ cߙ;rO|cIy9.Rgܢwz}u욶ۄuᖦlE# WgAN<6. Kl+]:=  HPzHvv3|j[L=9ζ~li_ie5d$X c'} X+Rwqn)y IJn:Pۢ}P9q\)D}Уl7#YTCԷfLSTp34Y-r e9ʜ3{QdHyE-Y"xEI^0[j34J'#6%jcyR,&MvBjTrhC *1Y WN5Rō6+,ЇU;Ȋq`!'e/卙8/jH 85B̴z4ϋ &~$A#vCclKhKv>3vl'B@eprJq"”KfZle]X::}#P+XOZ1 H!`{&"L]~⾔89Ik%N:P.62~Lp]ݓXV j*lڈy1XzZŗ#9 5=} 2ԒRaВx, {3`tw]:}B0~ef/# ),7Yq~Z endstream endobj 74 0 obj << /Type /XRef /Length 106 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 75 /ID [<05e9e5bc40f5b5364c5679675aff47b8><26e1bfc74eed422680e2559263f25be8>] >> stream xcb&F~0 $8JEgN?dog ,`R|"m "L` R0"yOIJɬfM`Y) H22'e endstream endobj startxref 69055 %%EOF mets/inst/doc/basic-dutils.ltx0000644000176200001440000010177113623061405016067 0ustar liggesusers%\VignetteIndexEntry{Manipulation of data-frame data with dutility functions} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Manipulation of data-frame data with dutility functions} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Manipulation of data-frame data with dutility functions}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Simple data manipulation for data-frames} \label{sec:orge9cc1d9} \begin{itemize} \item Renaming variables, Deleting variables \item Looking at the data \item Making new variales for the analysis \item Making factors (groupings) \item Working with factors \item Making a factor from existing numeric variable and vice versa \end{itemize} Here are some key data-manipulation steps on a data-frame which is how we typically organize our data in R. After having read the data into R it will typically be a data-frame, if not we can force it to be a data-frame. The basic idea of the utility functions is to get a simple and easy to type way of making simple data-manipulation on a data-frame much like what is possible in SAS or STATA. The functions, say, dcut, dfactor and so on are all functions that basically does what the base R cut, factor do, but are easier to use in the context of data-frames and have additional functionality. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) data(melanoma) \end{lstlisting} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} is.data.frame(melanoma) \end{lstlisting} \begin{verbatim} [1] TRUE \end{verbatim} Here we work on the melanoma data that is already read into R and is a data-frame. \section*{dUtility functions} \label{sec:org995ef5a} The structure for all functions is \begin{itemize} \item dfunction(dataframe,y\textasciitilde{}x|ifcond,\ldots{}) \end{itemize} to use the function on y in a dataframe grouped by x if condition ifcond is valid. The basic functions are Data processing \begin{itemize} \item dsort \item dreshape \item dcut \item drm, drename, ddrop, dkeep, dsubset \item drelevel \item dlag \item dfactor, dnumeric \end{itemize} Data aggregation \begin{itemize} \item dby, dby2 \item dscalar, deval, daggregate \item dmean, dsd, dsum, dquantile, dcor \item dtable, dcount \end{itemize} Data summaries \begin{itemize} \item dhead, dtail, \item dsummary, \item dprint, dlist, dlevels, dunique \end{itemize} A generic function daggregate, daggr, can be called with a function as the argument \begin{itemize} \item daggregate(dataframe,y\textasciitilde{}x|ifcond,fun=function,\ldots{}) \end{itemize} without the grouping variable (x) \begin{itemize} \item daggregate(dataframe,\textasciitilde{}y|ifcond,fun=function,\ldots{}) \end{itemize} A useful feature is that y and x as well as the subset condition can be specified using regular-expressions or by wildcards (default). Here to illustrate this, we compute the means of certain variables. First just oveall \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dmean(melanoma,~thick+I(log(thick))) \end{lstlisting} \begin{verbatim} thick I(log(thick)) 291.985366 5.223341 \end{verbatim} now only when days>500 \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dmean(melanoma,~thick+I(log(thick))|I(days>500)) \end{lstlisting} \begin{verbatim} thick I(log(thick)) 271.582011 5.168691 \end{verbatim} and now after sex but only when days>500 \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dmean(melanoma,thick+I(log(thick))~sex|I(days>500)) \end{lstlisting} \begin{verbatim} sex thick I(log(thick)) 1 0 242.9580 5.060086 2 1 320.2429 5.353321 \end{verbatim} and finally after quartiles of days (via the dcut function) \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dmean(melanoma,thick+I(log(thick))~I(dcut(days))) \end{lstlisting} \begin{verbatim} I(dcut(days)) thick I(log(thick)) 1 [10,1.52e+03] 482.1731 5.799525 2 (1.52e+03,2e+03] 208.5490 4.987652 3 (2e+03,3.04e+03] 223.2941 4.974759 4 (3.04e+03,5.56e+03] 250.1961 5.120129 \end{verbatim} or summary of all variables starting with "s" and that contains "a" \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dmean(melanoma,"s*"+"*a*"~sex|I(days>500)) \end{lstlisting} \begin{verbatim} sex status days 1 0 1.831933 2399.143 2 1 1.714286 2169.800 \end{verbatim} \section*{Renaming, deleting, keeping, dropping variables} \label{sec:orgb2de04c} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} melanoma=drename(melanoma,tykkelse~thick) names(melanoma) \end{lstlisting} \begin{verbatim} [1] "no" "status" "days" "ulc" "tykkelse" "sex" \end{verbatim} Deleting variables \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) melanoma=drm(melanoma,~thick+sex) names(melanoma) \end{lstlisting} \begin{verbatim} [1] "no" "status" "days" "ulc" \end{verbatim} or sas style \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) melanoma=ddrop(melanoma,~thick+sex) names(melanoma) \end{lstlisting} \begin{verbatim} [1] "no" "status" "days" "ulc" \end{verbatim} alternatively we can also keep certain variables \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) melanoma=dkeep(melanoma,~thick+sex+status+days) names(melanoma) \end{lstlisting} \begin{verbatim} [1] "thick" "sex" "status" "days" \end{verbatim} This can also be done with direct asignment \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) ddrop(melanoma) <- ~thick+sex names(melanoma) \end{lstlisting} \begin{verbatim} [1] "no" "status" "days" "ulc" \end{verbatim} \section*{Looking at the data} \label{sec:orgae42906} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) dstr(melanoma) \end{lstlisting} \begin{verbatim} 'data.frame': 205 obs. of 6 variables: $ no : int 789 13 97 16 21 469 685 7 932 944 ... $ status: int 3 3 2 3 1 1 1 1 3 1 ... $ days : int 10 30 35 99 185 204 210 232 232 279 ... $ ulc : int 1 0 0 0 1 1 1 1 1 1 ... $ thick : int 676 65 134 290 1208 484 516 1288 322 741 ... $ sex : int 1 1 1 0 1 1 1 1 0 0 ... \end{verbatim} The data can in Rstudio be seen as a data-table but to list certain parts of the data in output window \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dlist(melanoma) \end{lstlisting} \begin{verbatim} no status days ulc thick sex 1 789 3 10 1 676 1 2 13 3 30 0 65 1 3 97 2 35 0 134 1 4 16 3 99 0 290 0 5 21 1 185 1 1208 1 --- 201 317 2 4492 1 706 1 202 798 2 4668 0 612 0 203 806 2 4688 0 48 0 204 606 2 4926 0 226 0 205 328 2 5565 0 290 0 \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dlist(melanoma, ~.|sex==1) \end{lstlisting} \begin{verbatim} no status days ulc thick 1 789 3 10 1 676 2 13 3 30 0 65 3 97 2 35 0 134 5 21 1 185 1 1208 6 469 1 204 1 484 --- 191 445 2 3909 1 806 195 415 2 4119 0 65 197 175 2 4207 0 65 198 493 2 4310 0 210 201 317 2 4492 1 706 \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dlist(melanoma, ~ulc+days+thick+sex|sex==1) \end{lstlisting} \begin{verbatim} ulc days thick sex 1 1 10 676 1 2 0 30 65 1 3 0 35 134 1 5 1 185 1208 1 6 1 204 484 1 --- 191 1 3909 806 1 195 0 4119 65 1 197 0 4207 65 1 198 0 4310 210 1 201 1 4492 706 1 \end{verbatim} Getting summaries \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dsummary(melanoma) \end{lstlisting} \begin{verbatim} no status days ulc thick Min. : 2.0 Min. :1.00 Min. : 10 Min. :0.000 Min. : 10 1st Qu.:222.0 1st Qu.:1.00 1st Qu.:1525 1st Qu.:0.000 1st Qu.: 97 Median :469.0 Median :2.00 Median :2005 Median :0.000 Median : 194 Mean :463.9 Mean :1.79 Mean :2153 Mean :0.439 Mean : 292 3rd Qu.:731.0 3rd Qu.:2.00 3rd Qu.:3042 3rd Qu.:1.000 3rd Qu.: 356 Max. :992.0 Max. :3.00 Max. :5565 Max. :1.000 Max. :1742 sex Min. :0.0000 1st Qu.:0.0000 Median :0.0000 Mean :0.3854 3rd Qu.:1.0000 Max. :1.0000 \end{verbatim} or for specfic variables \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dsummary(melanoma,~thick+status+sex) \end{lstlisting} \begin{verbatim} thick status sex Min. : 10 Min. :1.00 Min. :0.0000 1st Qu.: 97 1st Qu.:1.00 1st Qu.:0.0000 Median : 194 Median :2.00 Median :0.0000 Mean : 292 Mean :1.79 Mean :0.3854 3rd Qu.: 356 3rd Qu.:2.00 3rd Qu.:1.0000 Max. :1742 Max. :3.00 Max. :1.0000 \end{verbatim} Summaries in different groups (sex) \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dsummary(melanoma,thick+days+status~sex) \end{lstlisting} \begin{verbatim} sex: 0 thick days status Min. : 10.0 Min. : 99 Min. :1.000 1st Qu.: 97.0 1st Qu.:1636 1st Qu.:2.000 Median : 162.0 Median :2059 Median :2.000 Mean : 248.6 Mean :2283 Mean :1.833 3rd Qu.: 306.0 3rd Qu.:3131 3rd Qu.:2.000 Max. :1742.0 Max. :5565 Max. :3.000 ------------------------------------------------------------ sex: 1 thick days status Min. : 16.0 Min. : 10 Min. :1.000 1st Qu.: 105.0 1st Qu.:1052 1st Qu.:1.000 Median : 258.0 Median :1860 Median :2.000 Mean : 361.1 Mean :1946 Mean :1.722 3rd Qu.: 484.0 3rd Qu.:2784 3rd Qu.:2.000 Max. :1466.0 Max. :4492 Max. :3.000 \end{verbatim} and only among those with thin-tumours or only females (sex==1) \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dsummary(melanoma,thick+days+status~sex|thick<97) \end{lstlisting} \begin{verbatim} sex: 0 thick days status Min. :10.00 Min. : 355 Min. :1.000 1st Qu.:32.00 1st Qu.:1762 1st Qu.:2.000 Median :64.00 Median :2227 Median :2.000 Mean :51.48 Mean :2425 Mean :2.034 3rd Qu.:65.00 3rd Qu.:3185 3rd Qu.:2.000 Max. :81.00 Max. :4688 Max. :3.000 ------------------------------------------------------------ sex: 1 thick days status Min. :16.00 Min. : 30 Min. :1.000 1st Qu.:30.00 1st Qu.:1820 1st Qu.:2.000 Median :65.00 Median :2886 Median :2.000 Mean :55.75 Mean :2632 Mean :1.875 3rd Qu.:81.00 3rd Qu.:3328 3rd Qu.:2.000 Max. :81.00 Max. :4207 Max. :3.000 \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dsummary(melanoma,thick+status~+1|sex==1) \end{lstlisting} \begin{verbatim} thick status Min. : 16.0 Min. :1.000 1st Qu.: 105.0 1st Qu.:1.000 Median : 258.0 Median :2.000 Mean : 361.1 Mean :1.722 3rd Qu.: 484.0 3rd Qu.:2.000 Max. :1466.0 Max. :3.000 \end{verbatim} or \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dsummary(melanoma,~thick+status|sex==1) \end{lstlisting} \begin{verbatim} thick status Min. : 16.0 Min. :1.000 1st Qu.: 105.0 1st Qu.:1.000 Median : 258.0 Median :2.000 Mean : 361.1 Mean :1.722 3rd Qu.: 484.0 3rd Qu.:2.000 Max. :1466.0 Max. :3.000 \end{verbatim} To make more complex conditions need to use the I() \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dsummary(melanoma,thick+days+status~sex|I(thick<97 & sex==1)) \end{lstlisting} \begin{verbatim} sex: 1 thick days status Min. :16.00 Min. : 30 Min. :1.000 1st Qu.:30.00 1st Qu.:1820 1st Qu.:2.000 Median :65.00 Median :2886 Median :2.000 Mean :55.75 Mean :2632 Mean :1.875 3rd Qu.:81.00 3rd Qu.:3328 3rd Qu.:2.000 Max. :81.00 Max. :4207 Max. :3.000 \end{verbatim} Tables between variables \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dtable(melanoma,~status+sex) \end{lstlisting} \begin{verbatim} sex 0 1 status 1 28 29 2 91 43 3 7 7 \end{verbatim} All bivariate tables \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dtable(melanoma,~status+sex+ulc,level=2) \end{lstlisting} \begin{verbatim} status sex 1 2 3 0 28 91 7 1 29 43 7 status ulc 1 2 3 0 16 92 7 1 41 42 7 sex ulc 0 1 0 79 36 1 47 43 \end{verbatim} All univariate tables \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dtable(melanoma,~status+sex+ulc,level=1) \end{lstlisting} \begin{verbatim} status 1 2 3 57 134 14 sex 0 1 126 79 ulc 0 1 115 90 \end{verbatim} and with new variables \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dtable(melanoma,~status+sex+ulc+dcut(days)+I(days>300),level=1) \end{lstlisting} \begin{verbatim} status 1 2 3 57 134 14 sex 0 1 126 79 ulc 0 1 115 90 dcut(days) [10,1.52e+03] (1.52e+03,2e+03] (2e+03,3.04e+03] (3.04e+03,5.56e+03] 52 51 51 51 I(days > 300) FALSE TRUE 11 194 \end{verbatim} \section*{Sorting the data} \label{sec:org4adbc9e} To sort the data \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) mel= dsort(melanoma,~days) dsort(melanoma) <- ~days head(mel) \end{lstlisting} \begin{verbatim} no status days ulc thick sex 1 789 3 10 1 676 1 2 13 3 30 0 65 1 3 97 2 35 0 134 1 4 16 3 99 0 290 0 5 21 1 185 1 1208 1 6 469 1 204 1 484 1 \end{verbatim} and to sort after multiple variables increasing and decreasing \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dsort(melanoma) <- ~days-status head(melanoma) \end{lstlisting} \begin{verbatim} no status days ulc thick sex 1 789 3 10 1 676 1 2 13 3 30 0 65 1 3 97 2 35 0 134 1 4 16 3 99 0 290 0 5 21 1 185 1 1208 1 6 469 1 204 1 484 1 \end{verbatim} \section*{Making new variales for the analysis} \label{sec:orgb492e14} To define a bunch of new covariates within a data-frame \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) melanoma= transform(melanoma, thick2=thick^2, lthick=log(thick) ) dhead(melanoma) \end{lstlisting} \begin{verbatim} no status days ulc thick sex thick2 lthick 1 789 3 10 1 676 1 456976 6.516193 2 13 3 30 0 65 1 4225 4.174387 3 97 2 35 0 134 1 17956 4.897840 4 16 3 99 0 290 0 84100 5.669881 5 21 1 185 1 1208 1 1459264 7.096721 6 469 1 204 1 484 1 234256 6.182085 \end{verbatim} When the above definitions are done using a condition this can be achieved using the dtransform function that extends transform with a possible condition \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} melanoma=dtransform(melanoma,ll=thick*1.05^ulc,sex==1) melanoma=dtransform(melanoma,ll=thick,sex!=1) dmean(melanoma,ll~sex+ulc) \end{lstlisting} \begin{verbatim} sex ulc ll 1 0 0 173.7342 2 1 0 197.3611 3 0 1 374.5532 4 1 1 523.1198 \end{verbatim} \section*{Making factors (groupings)} \label{sec:orgca893e7} On the melanoma data the variable thick gives the thickness of the melanom tumour. For some analyses we would like to make a factor depending on the thickness. This can be done in several different ways \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} melanoma=dcut(melanoma,~thick,breaks=c(0,200,500,800,2000)) \end{lstlisting} New variable is named thickcat.0 by default. To see levels of factors in data-frame \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat.0 #levels=:4 [1] "[0,200]" "(200,500]" "(500,800]" "(800,2e+03]" ----------------------------------------- \end{verbatim} Checking group sizes \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dtable(melanoma,~thickcat.0) \end{lstlisting} \begin{verbatim} thickcat.0 [0,200] (200,500] (500,800] (800,2e+03] 109 64 20 12 \end{verbatim} With adding to the data-frame directly \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dcut(melanoma,breaks=c(0,200,500,800,2000)) <- gr.thick1~thick dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat.0 #levels=:4 [1] "[0,200]" "(200,500]" "(500,800]" "(800,2e+03]" ----------------------------------------- gr.thick1 #levels=:4 [1] "[0,200]" "(200,500]" "(500,800]" "(800,2e+03]" ----------------------------------------- \end{verbatim} new variable is named thickcat.0 (after first cut-point), or to get quartiles with default names thick.cat.4 \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dcut(melanoma) <- ~ thick # new variable is thickcat.4 dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat.0 #levels=:4 [1] "[0,200]" "(200,500]" "(500,800]" "(800,2e+03]" ----------------------------------------- gr.thick1 #levels=:4 [1] "[0,200]" "(200,500]" "(500,800]" "(800,2e+03]" ----------------------------------------- thickcat.4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- \end{verbatim} or median groups, here starting again with the original data, \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) dcut(melanoma,breaks=2) <- ~ thick # new variable is thick.2 dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat.2 #levels=:2 [1] "[10,194]" "(194,1.74e+03]" ----------------------------------------- \end{verbatim} to control new names \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) mela= dcut(melanoma,thickcat4+dayscat4~thick+days,breaks=4) dlevels(mela) \end{lstlisting} \begin{verbatim} thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- dayscat4 #levels=:4 [1] "[10,1.52e+03]" "(1.52e+03,2e+03]" "(2e+03,3.04e+03]" [4] "(3.04e+03,5.56e+03]" ----------------------------------------- \end{verbatim} or \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) dcut(melanoma,breaks=4) <- thickcat4+dayscat4~thick+days dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- dayscat4 #levels=:4 [1] "[10,1.52e+03]" "(1.52e+03,2e+03]" "(2e+03,3.04e+03]" [4] "(3.04e+03,5.56e+03]" ----------------------------------------- \end{verbatim} This can also be typed out more specifically \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} melanoma$gthick = cut(melanoma$thick,breaks=c(0,200,500,800,2000)) melanoma$gthick = cut(melanoma$thick,breaks=quantile(melanoma$thick),include.lowest=TRUE) \end{lstlisting} \section*{Working with factors} \label{sec:orgb002bf7} To see levels of covariates in data-frame \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) dcut(melanoma,breaks=4) <- thickcat4~thick dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- \end{verbatim} To relevel the factor \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dtable(melanoma,~thickcat4) melanoma = drelevel(melanoma,~thickcat4,ref="(194,356]") dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat4 [10,97] (97,194] (194,356] (356,1.74e+03] 56 53 45 51 thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- thickcat4.(194,356] #levels=:4 [1] "(194,356]" "[10,97]" "(97,194]" "(356,1.74e+03]" ----------------------------------------- \end{verbatim} or to take the third level in the list of levels, same as above, \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} melanoma = drelevel(melanoma,~thickcat4,ref=2) dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- thickcat4.(194,356] #levels=:4 [1] "(194,356]" "[10,97]" "(97,194]" "(356,1.74e+03]" ----------------------------------------- thickcat4.2 #levels=:4 [1] "(97,194]" "[10,97]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- \end{verbatim} To combine levels of a factor (first combinining first 3 groups into one) \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} melanoma = drelevel(melanoma,~thickcat4,newlevels=1:3) dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- thickcat4.(194,356] #levels=:4 [1] "(194,356]" "[10,97]" "(97,194]" "(356,1.74e+03]" ----------------------------------------- thickcat4.2 #levels=:4 [1] "(97,194]" "[10,97]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- thickcat4.1:3 #levels=:2 [1] "[10,97]-(194,356]" "(356,1.74e+03]" ----------------------------------------- \end{verbatim} or to combine groups 1 and 2 into one group and 3 and 4 into another \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dkeep(melanoma) <- ~thick+thickcat4 melanoma = drelevel(melanoma,gthick2~thickcat4,newlevels=list(1:2,3:4)) dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- gthick2 #levels=:2 [1] "[10,97]-(97,194]" "(194,356]-(356,1.74e+03]" ----------------------------------------- \end{verbatim} Changing order of factor levels \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} dfactor(melanoma,levels=c(3,1,2,4)) <- thickcat4.2~thickcat4 dlevel(melanoma,~ "thickcat4*") dtable(melanoma,~thickcat4+thickcat4.2) \end{lstlisting} \begin{verbatim} thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- thickcat4.2 #levels=:4 [1] "(194,356]" "[10,97]" "(97,194]" "(356,1.74e+03]" ----------------------------------------- thickcat4.2 (194,356] [10,97] (97,194] (356,1.74e+03] thickcat4 [10,97] 0 56 0 0 (97,194] 0 0 53 0 (194,356] 45 0 0 0 (356,1.74e+03] 0 0 0 51 \end{verbatim} Combine levels but now control factor-level names \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} melanoma=drelevel(melanoma,gthick3~thickcat4,newlevels=list(group1.2=1:2,group3.4=3:4)) dlevels(melanoma) \end{lstlisting} \begin{verbatim} thickcat4 #levels=:4 [1] "[10,97]" "(97,194]" "(194,356]" "(356,1.74e+03]" ----------------------------------------- gthick2 #levels=:2 [1] "[10,97]-(97,194]" "(194,356]-(356,1.74e+03]" ----------------------------------------- thickcat4.2 #levels=:4 [1] "(194,356]" "[10,97]" "(97,194]" "(356,1.74e+03]" ----------------------------------------- gthick3 #levels=:2 [1] "group1.2" "group3.4" ----------------------------------------- \end{verbatim} \section*{Making a factor from existing numeric variable and vice versa} \label{sec:orgdcd4633} A numeric variable "status" with values 1,2,3 into a factor by \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} data(melanoma) melanoma = dfactor(melanoma,~status, labels=c("malignant-melanoma","censoring","dead-other")) melanoma = dfactor(melanoma,sexl~sex,labels=c("females","males")) dtable(melanoma,~sexl+status.f) \end{lstlisting} \begin{verbatim} status.f malignant-melanoma censoring dead-other sexl females 28 91 7 males 29 43 7 \end{verbatim} A gender factor with values "M", "F" can be converted into numerics by \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} melanoma = dnumeric(melanoma,~sexl) dstr(melanoma,"sex*") dtable(melanoma,~'sex*',level=2) \end{lstlisting} \begin{verbatim} 'data.frame': 205 obs. of 3 variables: $ sex : int 1 1 1 0 1 1 1 1 0 0 ... $ sexl : Factor w/ 2 levels "females","males": 2 2 2 1 2 2 2 2 1 1 ... $ sexl.n: num 2 2 2 1 2 2 2 2 1 1 ... sex sexl 0 1 females 126 0 males 0 79 sex sexl.n 0 1 1 126 0 2 0 79 sexl sexl.n females males 1 126 0 2 0 79 \end{verbatim} \end{document}mets/inst/doc/binomial-family.ltx0000644000176200001440000005721713623061405016562 0ustar liggesusers%\VignetteIndexEntry{Analysis of multivariate binomial data: family analysis} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Analysis of multivariate binomial data: family analysis} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Analysis of multivariate binomial data: family analysis}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Overview} \label{sec:org413d47e} When looking at multivariate binomial data with the aim of learning about the dependence that is present, possibly after correcting for some covariates many models are available. \begin{itemize} \item Random-effects models logistic regression covered elsewhere (glmer in lme4). \end{itemize} in the mets package you can fit the \begin{itemize} \item Pairwise odds ratio model \item Bivariate Probit model \begin{itemize} \item With random effects \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \item Additive gamma random effects model \begin{itemize} \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \end{itemize} These last three models are all fitted in the mets package using composite likelihoods for pairs of data. The models can be fitted specifically based on specifying which pairs one wants to use for the composite score. The models are described in futher details in the binomial-twin vignette. \section*{Simulated family data} \label{sec:org9bae582} We start by simulating family data with and additive gamma structure on ACE form. Here 40000 families consisting of two parents and two children. The response is ybin and there is one covariate x. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) set.seed(100) data <- simbinClaytonOakes.family.ace(40000,2,1,beta=NULL,alpha=NULL) data$number <- c(1,2,3,4) data$child <- 1*(data$number==3) head(data) \end{lstlisting} \begin{verbatim} Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.5.1 mets version 1.2.1.2 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined Warning message: failed to assign RegisteredNativeSymbol for cor to cor since cor is already defined in the ‘mets’ namespace ybin x type cluster number child 1 1 0 mother 1 1 0 2 1 1 father 1 2 0 3 1 1 child 1 3 1 4 1 1 child 1 4 0 5 0 0 mother 2 1 0 6 1 1 father 2 2 0 \end{verbatim} We fit the marginal models, and here find a covariate effect at 0.3 for x. The marginals can be specified excatly as one wants. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} aa <- margbin <- glm(ybin~x,data=data,family=binomial()) summary(aa) \end{lstlisting} \begin{verbatim} Call: glm(formula = ybin ~ x, family = binomial(), data = data) Deviance Residuals: Min 1Q Median 3Q Max -1.5283 -1.3910 0.8632 0.9779 0.9779 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) 0.489258 0.007291 67.1 <2e-16 *** x 0.306070 0.010553 29.0 <2e-16 *** --- Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 206272 on 159999 degrees of freedom Residual deviance: 205428 on 159998 degrees of freedom AIC: 205432 Number of Fisher Scoring iterations: 4 \end{verbatim} \section*{Additive gamma model} \label{sec:org85bea3a} For the additive gamma of this type we set-up the random effects included in such a family to make the ACE valid using some special functions for this. The model is constructe with one enviromental effect shared by all in the family and 8 genetic random effects with size (1/4) genetic variance. Looking at the first family we see that the mother and father both share half the genes with the children and that the two children also share half their genes with this specification. Below we also show an alternative specification of this model using all pairs. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # make ace random effects design out <- ace.family.design(data,member="type",id="cluster") out$pardes head(out$des.rv,4) \end{lstlisting} \begin{verbatim} [,1] [,2] [1,] 0.25 0 [2,] 0.25 0 [3,] 0.25 0 [4,] 0.25 0 [5,] 0.25 0 [6,] 0.25 0 [7,] 0.25 0 [8,] 0.25 0 [9,] 0.00 1 m1 m2 m3 m4 f1 f2 f3 f4 env [1,] 1 1 1 1 0 0 0 0 1 [2,] 0 0 0 0 1 1 1 1 1 [3,] 1 1 0 0 1 1 0 0 1 [4,] 1 0 1 0 1 0 1 0 1 \end{verbatim} We can now fit the model calling the two-stage function \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # fitting ace model for family structure ts <- binomial.twostage(margbin,data=data,clusters=data$cluster, theta=c(2,1), random.design=out$des.rv,theta.des=out$pardes) summary(ts) # true variance parameters c(2,1) # total variance 3 \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.2425610 0.03747680 dependence2 0.1255742 0.01607478 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.659 0.0611 0.539 0.779 4.25e-27 dependence2 0.341 0.0611 0.221 0.461 2.39e-08 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.368 0.0252 0.319 0.418 3.31e-48 attr(,"class") [1] "summary.mets.twostage" [1] 0.2222222 0.1111111 [1] 0.3333333 \end{verbatim} \subsection*{Pairwise fitting} \label{sec:orged91ad8} We now specify the same model via extracting all pairs. The random effecs structure is simpler when just looking at pairs. A special function writes up all combinations of pairs. There are 6 pairs within each family, and we keep track of who belongs to the different families. We first simply give the pairs and we then should get the same result as before. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} mm <- familycluster.index(data$cluster) head(mm$familypairindex,n=20) pairs <- mm$pairs dim(pairs) head(pairs,12) \end{lstlisting} \begin{verbatim} [1] 1 2 1 3 1 4 2 3 2 4 3 4 5 6 5 7 5 8 6 7 [1] 240000 2 [,1] [,2] [1,] 1 2 [2,] 1 3 [3,] 1 4 [4,] 2 3 [5,] 2 4 [6,] 3 4 [7,] 5 6 [8,] 5 7 [9,] 5 8 [10,] 6 7 [11,] 6 8 [12,] 7 8 \end{verbatim} Now with the pairs we fit the model \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tsp <- binomial.twostage(margbin,data=data, clusters=data$cluster, theta=c(2,1),detail=0, random.design=out$des.rv,theta.des=out$pardes,pairs=pairs) summary(tsp) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects Error in theta.des %*% theta : non-conformable arguments \end{verbatim} Here a random sample of pairs are given instead and we get other estimates. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} set.seed(100) ssid <- sort(sample(1:nrow(pairs),nrow(pairs)/2)) tsd <- binomial.twostage(aa,data=data,clusters=data$cluster, theta=c(2,1),step=1.0, random.design=out$des.rv,iid=1,Nit=10, theta.des=out$pardes,pairs=pairs[ssid,]) summary(tsd) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects Error in theta.des %*% theta : non-conformable arguments \end{verbatim} To specify such a model when only the pairs are availble we show how to specify the model. We here use the same marginal "aa" to make the results comparable. The marginal can also be fitted based on available data. We start by selecting the data related to the pairs, and sets up new id's and to start we specify the model using the full design with 9 random effects. Below we show how one can use with only the random effects needed for each pair, which is typically simpler. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} head(pairs[ssid,]) ids <- sort(unique(c(pairs[ssid,]))) pairsids <- c(pairs[ssid,]) pair.new <- matrix(fast.approx(ids,c(pairs[ssid,])),ncol=2) head(pair.new) dataid <- dsort(data[ids,],"cluster") outid <- ace.family.design(dataid,member="type",id="cluster") outid$pardes head(outid$des.rv) \end{lstlisting} \begin{verbatim} [,1] [,2] [1,] 1 2 [2,] 1 3 [3,] 2 4 [4,] 3 4 [5,] 5 6 [6,] 5 7 [,1] [,2] [1,] 1 2 [2,] 1 3 [3,] 2 4 [4,] 3 4 [5,] 5 6 [6,] 5 7 [,1] [,2] [1,] 0.25 0 [2,] 0.25 0 [3,] 0.25 0 [4,] 0.25 0 [5,] 0.25 0 [6,] 0.25 0 [7,] 0.25 0 [8,] 0.25 0 [9,] 0.00 1 m1 m2 m3 m4 f1 f2 f3 f4 env [1,] 1 1 1 1 0 0 0 0 1 [2,] 0 0 0 0 1 1 1 1 1 [3,] 1 1 0 0 1 1 0 0 1 [4,] 1 0 1 0 1 0 1 0 1 [5,] 1 1 1 1 0 0 0 0 1 [6,] 0 0 0 0 1 1 1 1 1 \end{verbatim} Now fitting the model with the data set up \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tsdid <- binomial.twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1), random.design=outid$des.rv,theta.des=outid$pardes,pairs=pair.new) summary(tsdid) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects Error in theta.des %*% theta : non-conformable arguments \end{verbatim} We now specify the design specifically using the pairs. The random.design and design on the parameters are now given for each pair, as a 3 dimensional matrix. with a direct specification of random.design and the design on the parameters theta.design. In addition we need also to give the number of random effects for each pair. These basic things are constructed by certain functions for the ACE design. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} pair.types <- matrix(dataid[c(t(pair.new)),"type"],byrow=T,ncol=2) head(pair.new,7) head(pair.types,7) theta.des <- array(0,c(4,2,nrow(pair.new))) random.des <- array(0,c(2,4,nrow(pair.new))) # random variables in each pair rvs <- c() for (i in 1:nrow(pair.new)) { if (pair.types[i,1]=="mother" & pair.types[i,2]=="father") { theta.des[,,i] <- rbind(c(1,0),c(1,0),c(0,1),c(0,0)) random.des[,,i] <- rbind(c(1,0,1,0),c(0,1,1,0)) rvs <- c(rvs,3) } else { theta.des[,,i] <- rbind(c(0.5,0),c(0.5,0),c(0.5,0),c(0,1)) random.des[,,i] <- rbind(c(1,1,0,1),c(1,0,1,1)) rvs <- c(rvs,4) } } \end{lstlisting} \begin{verbatim} [,1] [,2] [1,] 1 2 [2,] 1 3 [3,] 2 4 [4,] 3 4 [5,] 5 6 [6,] 5 7 [7,] 5 8 [,1] [,2] [1,] "mother" "father" [2,] "mother" "child" [3,] "father" "child" [4,] "child" "child" [5,] "mother" "father" [6,] "mother" "child" [7,] "mother" "child" \end{verbatim} For pair 1 that is a mother/farther pair, we see that they share 1 environmental random effect of size 1. There are also two genetic effects that are unshared between the two. So a total of 3 random effects are needed here. The theta.des relates the 3 random effects to possible relationships in the parameters. Here the genetic effects are full and so is the environmental effect. In contrast we also consider a mother/child pair that share half the genes, now with random effects with (1/2) gene variance. We there need 4 random effects, 2 non-shared half-gene, 1 shared half-gene, and one shared full environmental effect. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # 3 rvs here random.des[,,1] theta.des[,,1] # 4 rvs here random.des[,,2] theta.des[,,2] head(rvs) \end{lstlisting} \begin{verbatim} [,1] [,2] [,3] [,4] [1,] 1 0 1 0 [2,] 0 1 1 0 [,1] [,2] [1,] 1 0 [2,] 1 0 [3,] 0 1 [4,] 0 0 [,1] [,2] [,3] [,4] [1,] 1 1 0 1 [2,] 1 0 1 1 [,1] [,2] [1,] 0.5 0 [2,] 0.5 0 [3,] 0.5 0 [4,] 0.0 1 [1] 3 4 4 4 3 4 \end{verbatim} Now fitting the model, and we see that it is a lot quicker due to the fewer random effects needed for pairs. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tsdid2 <- binomial.twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1), random.design=random.des, theta.des=theta.des,pairs=pair.new,pairs.rvs=rvs) summary(tsdid2) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects Error in theta.des %*% theta : non-conformable arguments \end{verbatim} The same model can be specifed even simpler via the kinship coefficient. For this speicification there are 4 random effects for each pair, but some have variance 0. The mother-father pair, here shares a random effect with variance 0, and have two non-shared genetic effects with full variance, in addition to a fully shared environmental effect. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} kinship <- c() for (i in 1:nrow(pair.new)) { if (pair.types[i,1]=="mother" & pair.types[i,2]=="father") pk1 <- 0 else pk1 <- 0.5 kinship <- c(kinship,pk1) } head(kinship,n=10) out <- make.pairwise.design(pair.new,kinship,type="ace") names(out) out$random.des[,,1] out$theta.des[,,1] \end{lstlisting} \begin{verbatim} [1] 0.0 0.5 0.5 0.5 0.0 0.5 0.5 0.5 0.5 0.5 [1] "random.design" "theta.des" "ant.rvs" [,1] [,2] [,3] [,4] [1,] 1 1 0 1 [2,] 1 0 1 1 [,1] [,2] [1,] 0 0 [2,] 1 0 [3,] 1 0 [4,] 0 1 \end{verbatim} Now, fitting the model we get the results from before. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tsdid3 <- binomial.twostage(aa,data=dataid,clusters=dataid$cluster, theta=c(2,1)/9,random.design=out$random.design, theta.des=out$theta.des,pairs=pair.new,pairs.rvs=out$ant.rvs) summary(tsdid3) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects Error in theta.des %*% theta : non-conformable arguments \end{verbatim} \section*{Pairwise odds ratio model} \label{sec:org2ddc2cf} To fit the pairwise odds-ratio model in the case of a pair-specification there are two options for fitting the model. \begin{enumerate} \item One option is to set up some artificial data similar to twin data with \begin{itemize} \item a pair-cluster-id (clusters) \item with a cluster-id to get GEE type standard errors (se.cluster) \end{itemize} \item We can also use the specify the design via the theta.des that is also a matrix of dimension pairs x design with the design for POR model. \end{enumerate} Starting by the second option. We need to start by specify the design of the odds-ratio of each pair. We set up the data and find all combinations within the pairs. Subsequently, we remove all the empty groups, by grouping together the factor levels 4:9, and then we construct the design. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tdp <-cbind( dataid[pair.new[,1],],dataid[pair.new[,2],]) names(tdp) <- c(paste(names(dataid),"1",sep=""), paste(names(dataid),"2",sep="")) tdp <-transform(tdp,tt=interaction(type1,type2)) dlevel(tdp) drelevel(tdp,newlevels=list(mother.father=4:9)) <- obs.types~tt dtable(tdp,~tt+obs.types) tdp <- model.matrix(~-1+factor(obs.types),tdp) \end{lstlisting} \begin{verbatim} type1 #levels=:3 [1] "child" "father" "mother" ----------------------------------------- type2 #levels=:3 [1] "child" "father" "mother" ----------------------------------------- tt #levels=:9 [1] "child.child" "father.child" "mother.child" "child.father" [5] "father.father" "mother.father" "child.mother" "father.mother" [9] "mother.mother" ----------------------------------------- obs.types mother.father child.child father.child mother.child tt child.child 0 19991 0 0 father.child 0 0 39837 0 mother.child 0 0 0 40212 child.father 0 0 0 0 father.father 0 0 0 0 mother.father 19960 0 0 0 child.mother 0 0 0 0 father.mother 0 0 0 0 mother.mother 0 0 0 0 \end{verbatim} We then can fit the pairwise model using the pairs and the pair-design for descrbing the OR. The results are consistent with the the ACE model as the mother-father have a lower dependence as is due only the environmental effects. All other combinations should have the same dependence as also seem to be the case. To fit the OR model it is generally recommended to use the var.link to use the parmetrization with log-odd-ratio regression. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} porpair <- binomial.twostage(aa,data=dataid,clusters=dataid$cluster, theta.des=tdp,pairs=pair.new,model="or",var.link=1) summary(porpair) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(obs.types)mother.father 0.1269881 0.03132228 factor(obs.types)child.child 0.3819107 0.03108233 factor(obs.types)father.child 0.3046284 0.02239909 factor(obs.types)mother.child 0.3293741 0.02233648 $or Estimate Std.Err 2.5% 97.5% P-value factor(obs.types)moth.... 1.14 0.0356 1.07 1.21 1.16e-223 factor(obs.types)chil.... 1.47 0.0455 1.38 1.55 4.26e-227 factor(obs.types)fath.... 1.36 0.0304 1.30 1.42 0.00e+00 factor(obs.types)moth.....1 1.39 0.0310 1.33 1.45 0.00e+00 $type [1] "or" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \end{document}mets/inst/doc/binomial-case-control-ascertainment.ltx0000644000176200001440000007154713623061405022527 0ustar liggesusers%\VignetteIndexEntry{Analysis of multivariate binomial data: case control or ascertainment sampling} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Analysis of multivariate binomial data: case control or ascertainment sampling} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Analysis of multivariate binomial data: case control or ascertainment sampling}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Overview} \label{sec:orgad14f2c} When looking at multivariate binomial data with the aim of learning about the dependence that is present, possibly after correcting for some covariates many models are available. \begin{itemize} \item Random-effects models logistic regression covered elsewhere (glmer in lme4). \end{itemize} in the mets package you can fit the \begin{itemize} \item Pairwise odds ratio model \item Bivariate Probit model \begin{itemize} \item With random effects \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \item Additive gamma random effects model \begin{itemize} \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \end{itemize} These last three models are all fitted in the mets package using composite likelihoods for pairs of data. The models can be fitted specifically based on specifying which pairs one wants to use for the composite score. The models are described in futher details in the binomial-twin vignette. \subsection*{Case-Control Sampling} \label{sec:org93e2d83} Sometimes, pairs are recruited after a case-proband is selected. This proband, can be either a \begin{itemize} \item case: must be representative of cases \end{itemize} or a \begin{itemize} \item control: must be representative of controls \end{itemize} First thinking about pairs, we estimate parameters using the conditional likelihood given sampling wich for a binary 2 x 2 table can be written as \[ \frac{P(i,j)}{P(j)} \] the probailty of seeing \((i,j)\) for the pair, given that the proband was observed as \((j)\). We note that if the marginal is known, or possibly estimated from the full cohort. Then we can estimate dependence parameters using just the terms \(P(i,j)\) for the pairs. We can thus ignore the special sampling for models with marginal specification. If the marginal can not be obtained from other sources we need to maximize the full-pairwise-likelihood in all parameters, that is both dependence and marginal parameters. Similary, one can select a whole family based on having selected a proband, that is selected a representative member of either cases or controls. In this case we fit the models by using composited likelihoods, considering all pairs that involves the probands. This will give some lacking efficiency compared to looking at the full likelihood of the family given the proband. \subsection*{Ascertainment Sampling} \label{sec:org6773872} Similarly, in the setting of pairs we can select all pairs where there is at least one event of interest. First thinking about pairs, we estimate parameters using the conditional likelihood given sampling wich for a binary 2 x 2 table can be written as \[ \frac{P(i,j)}{1-P(0,0)} \] the probailty of seeing \((i,j)\) for the pair, given that it is sampled. If the marginal can estimated from a full sample we can then estimate the dependence parameter using the ascertainment likelihood. Generally, when whole families are ascertained the computation of the true truncation probability can be hard to the fact that families are hard to define in the real world. Nevertheless, if a random sample of such family is at hand. We suggest to in these families take out all pairs that satisfies the ascertainment criterion. With a family, with given size \(n\) we have binary observations \((Y_1,...,Y_n)\). The family is sampled or a random sample of families such that \[ \sum_{i=1}^n Y_i \geq 1. \] We let the conditional distribution given sampling, be denoted as \[ P^O(\cdot) = P(\cdot | \sum_{i=1}^n Y_i \geq 1) \] Now, we note that all pairs within these family that satisfies that \(Y_i+Y_j \geq 1\), will have distribution \begin{align*} P^O(Y_i=o_1, Y_j=o_2 | Y_i+Y_j \geq 1) & = \frac{P^O(o_1,o_2)}{P^O( Y_i+Y_j \geq 1)} \\ & = \frac{P(Y_i=o_1,Y_j=o_2, \sum_{i=1}^n Y_i \geq 1)}{ P( Y_i+Y_j \geq 1, \sum_{i=1}^n Y_i \geq 1)} \\ & = \frac{P(Y_i=o_1,Y_j=o_2) }{ P( Y_i+Y_j \geq 1)} = \frac{P(o_1,o_2)}{1 - P(0,0)} \end{align*} since we only consider the probabilities where \(o_1+o_2 \geq 1\). Also here we could condition on covariates. So considering these pairs, or a random sample of them should yield valid inference. When standard errors are computed we need to rely on GEE type arguments. An advantage of this is that the ascertainment probability is much easier to get for the pairs. Again using the pairwise structure will lead to loss of efficiency compared to using the full likelihood of the ascertained families. In addition we note that when looking at one pair that has been ascertained then \begin{align*} P(Y_i=o_1,Y_j=o_2 | Y_i+Y_j \geq 1) & = \sum_{k=1}^2 P(Y_i=o_1,Y_j=o_2 | Y_i+Y_j = k ) P( Y_i + Y_j =k | Y_i + Y_j \geq 1 ). \end{align*} where \(o_1+ o_2 \geq 1\). Note that the dependence will affect the probabilities \(P(Y_i+Y_j=2)/( P(Y_i+Y_j=2)+ P(Y_i+Y_j=1))\) and \(P(Y_i+Y_j=1)/( P(Y_i+Y_j=2)+ P(Y_i+Y_j=1))\). In particular when the marginal parameters are known the dependence parameters can be estimated using the proportion of concordant pairs compared to the non-concordant pairs with respect to the outcome. When considering the pairs with different responses we learn "only" (up to model specification) about covariate effects. For example when \(\mbox{logit}(P(Y_i=1 | \alpha_k )) = \alpha_{k} + \beta X_i\) for \(i=1,2\) with \(\alpha_k\) a pair (cluster) specific effect and subject specific covariates \(X_i\) for \(i=1,2\), then \(P(Y_i=1,Y_j=0)/P(Y_i+Y_j=1) = \mbox{expit}((X_i - X_j) \beta)\), and with the standard definitions \(\mbox{logit}(p) = \log(p/(1-p))\) and \(\mbox{expit}(x) = \exp(x)/(1+\exp(x))\). \section*{The twin-stutter data} \label{sec:org51abefd} We consider the twin-stutter where for pairs of twins that are either dizygotic or monozygotic we have recorded whether the twins are stuttering \cite{twinstut-ref} We here consider MZ and same sex DZ twins. Looking at the data \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) data(twinstut) twinstut$binstut <- 1*(twinstut$stutter=="yes") twinstut <- subset(twinstut,zyg%in%c("mz","dz")) head(twinstut) \end{lstlisting} \begin{verbatim} Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.6 mets version 1.2.3 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined tvparnr zyg stutter sex age nr binstut 1 1 mz no female 71 1 0 2 1 mz no female 71 2 0 3 2 dz no female 71 1 0 8 5 mz no female 71 1 0 9 5 mz no female 71 2 0 11 7 dz no male 71 1 0 \end{verbatim} \begin{itemize} \item First, we select an ascertaiment sample of the data, thus selecting a random sample of all ascertained pairs. \item Secondly, we select a case-control sample of this data to illustrate the use of the methods. \end{itemize} \section*{Ascertaiment Sampling} \label{sec:orgaa08da8} Selecting the ascertained pairs \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) data(twinstut) twinstut$binstut <- 1*(twinstut$stutter=="yes") twinstut <- subset(twinstut,zyg%in%c("mz","dz")) dnumeric(twinstut) <- ~. dfactor(twinstut,labels=c("DZ","MZ")) <- binzyg~zyg.n ddrop(twinstut) <- ~"*.n" twinstut <- dby(twinstut,binstut~tvparnr,stuttot=sum,nn=seq_along,n=length) twina <- subset(twinstut,n==2 & stuttot>=1) \end{lstlisting} Selecting on the pairs where there is stuttering at taking a look at the tables of discordance and concordance for the twins. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} twinda <- fast.reshape(twina,id="tvparnr") twind <- fast.reshape(twinstut,id="tvparnr") dtable(twind,"binst*"~I(stuttot1>=1)) dtable(twinda,~"binst*") \end{lstlisting} \begin{verbatim} I(stuttot1 >= 1): FALSE binstut2 0 binstut1 0 6632 ------------------------------------------------------------ I(stuttot1 >= 1): TRUE binstut2 0 1 binstut1 0 0 289 1 281 111 binstut2 0 1 binstut1 0 0 289 1 281 111 \end{verbatim} Now doing the analyses \subsection*{Biprobit model} \label{sec:orgb7a66bb} Looking at the full data for comparison. We estimate an unstructured probit model with different correlations for MZ and DZ twins. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} b1 <- biprobit(binstut~sex,~-1+binzyg,data=twinstut,id="tvparnr") summary(b1) \end{lstlisting} \begin{verbatim} Estimate Std.Err Z p-value (Intercept) -1.794821 0.023289 -77.066826 0.0000 sexmale 0.401430 0.030179 13.301756 0.0000 r:binzygDZ 0.132458 0.062516 2.118802 0.0341 r:binzygMZ 1.096915 0.073574 14.909085 0.0000 logLik: -4400.536 mean(score^2): 1.022e-06 n pairs 21288 7313 Contrast: Dependence [binzygDZ] Mean [(Intercept)] Estimate 2.5% 97.5% Rel.Recur.Risk 1.77662 0.92746 2.62577 OR 1.88752 1.09432 3.25566 Tetrachoric correlation 0.13169 0.00993 0.24960 Concordance 0.00235 0.00140 0.00393 Casewise Concordance 0.06456 0.03937 0.10413 Marginal 0.03634 0.03287 0.04016 \end{verbatim} Note, that the Casewise Concordance is a consistently estimated under complete ascertainment, i.e., when we consider a random sample of affected twins (at least on of the twins must have the event). \subsection*{Odd-Ratio modelling} \label{sec:org1c452c4} First looking at the marginal model based on the full data we find the overall level of stuttering and also that males have a much higher stuttering risk. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} margbin <- glm(binstut~factor(sex),data=twinstut,family=binomial()) summary(margbin) \end{lstlisting} \begin{verbatim} Call: glm(formula = binstut ~ factor(sex), family = binomial(), data = twinstut) Deviance Residuals: Min 1Q Median 3Q Max -0.4127 -0.4127 -0.2716 -0.2716 2.5763 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) -3.28191 0.05000 -65.64 <2e-16 *** factor(sex)male 0.86171 0.06211 13.87 <2e-16 *** --- Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 9328.6 on 21287 degrees of freedom Residual deviance: 9124.7 on 21286 degrees of freedom AIC: 9128.7 Number of Fisher Scoring iterations: 6 \end{verbatim} First, fitting the OR model for MZ and DZ for the full data, we find that MZ have a much higher dependence than DZ twins. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} theta.des <- model.matrix( ~-1+factor(zyg),data=twinstut) bin <- binomial.twostage(margbin,data=twinstut,var.link=1, clusters=twinstut$tvparnr,theta.des=theta.des) summary(bin) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(zyg)dz 0.5238541 0.2400861 factor(zyg)mz 3.4930902 0.1865567 $or Estimate Std.Err 2.5% 97.5% P-value factor(zyg)dz 1.689 0.4054 0.894 2.483 3.111e-05 factor(zyg)mz 32.887 6.1354 20.862 44.913 8.308e-08 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} Now, using the overall marginal we look at the adjusted likelihood and find very similar results on the ascertained sample. Note, that the marginals are crucial for this analysis to give useful results. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} theta.des <- model.matrix( ~-1+factor(zyg),data=twina) bina <- binomial.twostage(margbin,data=twina,var.link=1, clusters=twina$tvparnr,theta.des=theta.des, pair.ascertained=1) summary(bina) \end{lstlisting} \begin{verbatim} Dependence parameter for Odds-Ratio (Plackett) model With log-link $estimates theta se factor(zyg)dz 0.4874213 0.2472523 factor(zyg)mz 3.4753766 0.1985974 $or Estimate Std.Err 2.5% 97.5% P-value factor(zyg)dz 1.628 0.4026 0.8391 2.417 5.245e-05 factor(zyg)mz 32.310 6.4167 19.7335 44.886 4.771e-07 $type [1] "plackett" attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \subsection*{Additive gamma modelling} \label{sec:org524055f} First, again for comparision fitting the full data for the AE model. We get the size of the genetic variance in this model. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} out <- twin.polygen.design(twinstut,id="tvparnr",zygname="zyg",zyg="dz",type="ae") bintwin <- binomial.twostage(margbin,data=twinstut, clusters=twinstut$tvparnr,detail=0,theta=c(0.1)/1,var.link=0, random.design=out$des.rv,theta.des=out$pardes) summary(bintwin) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.9094847 0.09536268 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.9095 0.09536 0.7226 1.096 1.469e-21 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} We first here take at the look at the marginal model for the ascertained sample, and note as expected that this sample give highly biased estimated for the marginal model. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} outa <- twin.polygen.design(twina,id="tvparnr",zygname="zyg",zyg="dz",type="ae") marga <- glm(binstut~sex,data=twina,family=binomial()) summary(marga) \end{lstlisting} \begin{verbatim} Call: glm(formula = binstut ~ sex, family = binomial(), data = twina) Deviance Residuals: Min 1Q Median 3Q Max -1.334 -1.298 1.028 1.028 1.061 Coefficients: Estimate Std. Error z value Pr(>|z|) (Intercept) 0.27895 0.08739 3.192 0.00141 ** sexmale 0.08242 0.11237 0.733 0.46328 --- Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 (Dispersion parameter for binomial family taken to be 1) Null deviance: 1851.8 on 1361 degrees of freedom Residual deviance: 1851.2 on 1360 degrees of freedom AIC: 1855.2 Number of Fisher Scoring iterations: 4 \end{verbatim} Now, using the overall marginal model we look at the adjusted likelihood and find very similar results on the ascertained sample. Note, that the marginals are crucial for this analysis to give useful results. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} abintwin1 <- binomial.twostage(margbin,data=twina, clusters=twina$tvparnr,detail=0,theta=c(0.1)/1,var.link=0, random.design=outa$des.rv,theta.des=outa$pardes,pair.ascertained=1) summary(abintwin1) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.8920274 0.09732786 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.892 0.09733 0.7013 1.083 4.946e-20 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} In fact for this model we can also do a full-MLE fitting jointly the dependence parameters and the marginal model. This is based on the twostage option (twostage=0 is MLE). Here the starting value is given at the marginal model for the ascertained model. This gives quite similar results to the previous analyses with a genetic variance around 1. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} aabintwin1 <- binomial.twostage(marga,data=twina, clusters=twina$tvparnr,detail=0,theta=c(0.1)/1,var.link=0, random.design=outa$des.rv,theta.des=outa$pardes,pair.ascertained=1,twostage=0) summary(aabintwin1) coef(marga) coef(margbin) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 1.014398 0.1045593 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 1.014 0.1046 0.8095 1.219 2.967e-22 attr(,"class") [1] "summary.mets.twostage" (Intercept) sexmale 0.2789484 0.0824214 (Intercept) factor(sex)male -3.2819072 0.8617053 \end{verbatim} \section*{Case Control Sampling} \label{sec:org56e8f5e} First, taking out all cases and one control for each case, we establish the pairs of these probands. This is based on keeping track of the twin related to the proband. Here using some utility functions in the mets packages. Then we write up the random design vectors and the parameter design for each pair using the kinship coefficient. When specifying the pairs in the case-control setup the second column should be the probands. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) data(twinstut) twinstut$binstut <- 1*(twinstut$stutter=="yes") twinstut <- subset(twinstut,zyg%in%c("mz","dz")) dnumeric(twinstut) <- ~. dfactor(twinstut,labels=c("DZ","MZ")) <- binzyg~zyg.n ddrop(twinstut) <- ~"*.n" twinstut <- dby(twinstut,binstut~tvparnr,stuttot=sum,nn=seq_along,n=length) twinstut <- subset(twinstut,n==2) twinstut <- dtransform(twinstut,nnrow=1:nrow(twinstut)) twinstut <- dby(twinstut,binstut~tvparnr,nnn=seq_along) twinstut <- dby2(twinstut,nnrow~tvparnr,pairnr=rev) cases <- which(twinstut$binstut==1) controls <- sample(which(twinstut$binstut==0),1217) rowsca <- with(twinstut,nnrow[cases]) rowsco <- with(twinstut,nnrow[controls]) rpairs <- c(rowsca,rowsco) cc.pairs <- cbind( with(twinstut,pairnr.nnrow[rpairs]),rpairs) ids <- sort(unique(c(cc.pairs))) pairsids <- c(cc.pairs) pair.new <- matrix(fast.approx(ids,pairsids),ncol=2) head(pair.new) dataid <- dsort(twinstut[ids,],"tvparnr") dataid=dtransform(dataid,kinship=0.5) dataid=dtransform(dataid,kinship=1,binzyg=="MZ") kinship <- dataid$kinship[pair.new[,2]] out <- make.pairwise.design(pair.new,kinship,type="ae") names(out) out$random.des[,,1] out$theta.des[,,1] \end{lstlisting} \begin{verbatim} [,1] [,2] [1,] 4 3 [2,] 16 15 [3,] 18 17 [4,] 32 31 [5,] 38 37 [6,] 44 43 [1] "random.design" "theta.des" "ant.rvs" [,1] [,2] [,3] [1,] 1 1 0 [2,] 1 0 1 [1] 0.5 0.5 0.5 \end{verbatim} Now doing the analyses, first with know marginals, that is marginals from the full data. For this analysis, since marginals do not contain dependence parameters we do not need to specify that this is case-control sampling. Having a correct is crucial for this to work, but this is certainly often possible in register based studies where a full cohort is also available. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} cc <- binomial.twostage(margbin,data=dataid,clusters=dataid$tvparnr,pairs=pair.new, random.design=out$random.design,theta.des=out$theta.des, pairs.rvs=out$ant.rvs,case.control=0,twostage=1) summary(cc) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.8791843 0.09707036 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.8792 0.09707 0.6889 1.069 1.339e-19 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} We now do the same analysis specifying the case-control sampling. This should result in the same dependence parameters as is also the case. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} cc3 <- binomial.twostage(margbin,data=dataid, clusters=dataid$tvparnr, pairs=pair.new, random.design=out$random.design, theta.des=out$theta.des, pairs.rvs=out$ant.rvs, case.control=1,twostage=1) summary(cc3) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.8791843 0.09707036 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.8792 0.09707 0.6889 1.069 1.339e-19 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} This model can also be fitted using a full likelhood of both dependence parameters and marginal parameters. Here there is no need to have a correctly specified marginal. We here use the marginal fitting from the case-control data as as starting values. Again we find a genetic variance around 1. The marginal parameters are also consistent with the results from the full analyses for the marginal parameters. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} marga <- glm(binstut~sex,data=dataid,family=binomial()) cc3 <- binomial.twostage(marga,data=dataid, clusters=dataid$tvparnr, pairs=pair.new, random.design=out$random.design, theta.des=out$theta.des, pairs.rvs=out$ant.rvs, case.control=1,twostage=0) summary(cc3) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates theta se dependence1 0.9222504 0.09729347 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 1 0 1 1 0 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 0.9223 0.09729 0.7316 1.113 2.566e-21 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} When probands are related, here we may choose both case and controls from the same twin-pair then we need to adjust standard errors by grouping together contribution from related probands. This can be done using the se.cluster option that specifies how to cluster in the computation of the standard errors. In this case, however, this will be same as the clusters since these also are identical across pairs. \section*{Combining Case Control and Ascertainment Sampling} \label{sec:orgff68ee7} When specifying such models based on the pairs, it is in fact possible to combine ascertained pairs with case-control sampling by specifing vectors as the case.control=c(1,0,1,0) and pair.ascertained=c(0,1,0,1) arguments. Here with two case-control pairs, and two ascertained pairs. \end{document}mets/inst/doc/binomial-case-control-ascertainment.pdf0000644000176200001440000020540213623061750022461 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 2807 /Filter /FlateDecode /N 67 /First 537 >> stream xZ[s6~_f'@dƱco:NhEWҤ~MRDd84@\K2 Y,d)fX a1˂PX`B Td,ULI+X2ZcS΄,0L  0ķc:r""b(X `BBj YY|fΕZ-sHm2*``PI8(G*l`8 ZU 4Ro GZ@}:`.2Z XfNXߜr:b.DZ&8 9x; Bk 5u0y"B4XK`B@q$*'tBf1D! GE8@60Q'Og'IO"f8[ $ ewseoYg mr{+L(īcElC|zʹ_ Uqx9Y$qfHؓH"+T*|*պasRD~6pĹ{"|{ W]־UDfiΞl)|t9I1;",ǂe˛%ûJY"HJ*҈ݮ$ϸLiH!QZg*ȊA5Wj%2ל>bE\F+x-X}[NJUFբ\OԴ^=y?[ rru q77+F)t`Ͼ)>SBҼV'ϋd^,*i"$h$t8{y:/<[.&G^~(. R2C'["\& C|(6f5b/N?`kV,I9?:雋x6iv짂@Oi:c:8Ly/;{Ra%+q\- 2£B5^% 鴸'QF, Ϭjto?n*-I5zu*V0V+GNDK}zito/w Ff-!rt&:x91t />?? ~ɯ[+y,x>7|',Ç<ɜw>|3<_O":dg]NۋR%oa:Kpv6do~g)`^iCۼvxa"y$ePٯhL3U"ؔ7tQՎYDqS݃;~˷%4YllPhm$,'Czt}4\;jSd:XK>:~WxYeѾ~_c^+¬W>O׼ u+?)y ܶ1ϱ[JINWX]צ6UT5M63T}T.nYɈT ~SRꝆԆ~!h|6. խh~Z-jvJniGGm7%GKBC"4 9oInI{خ8_Rqܱ]Sڿr2 O<#o@M)gؒ (#R"z%QY]pZ֟H6[}qUPwGI̗vT+eΰ&]a#sendstream endobj 69 0 obj << /Subtype /XML /Type /Metadata /Length 1668 >> stream GPL Ghostscript 9.27 2020-02-18T23:23:35+01:00 2020-02-18T23:23:35+01:00 Emacs 26.1 (Org mode 9.1.14) Analysis of multivariate binomial data: case control or ascertainment samplingKlaus Holst & Thomas Scheike endstream endobj 70 0 obj << /Filter /FlateDecode /Length 1827 >> stream xX͎OSB+E$%mY'p xi W?cIyySHQ]@`UU_U}U_,QfUetwYt=)!,%,hZ ݏ讓Ө8!%O3LQ4e*A'9h9ղqdr Q%G+O}7 16R9G}fA %<G^Er0IݵkF>4;ϭ{8E1'RA _T7џ#Esmt_ku.rx 2"#!/ ‰%ZXJ1؉dF~#D2# c%-)K3ivʦ`'/KOjգ3D(#|F\xp}V &20 ?/D䟱˜bO!!:@ؤO,tV^+CRu$df Kbys$e NQTWW :qZJPY~yqRC0!.3T5ԶV/q EZ1y^ 2v^(GP}+icZADL8jHFZ I3aooqRQdWm1c-kIW^4u Ue$甀1x0! Ue!. N)zg]kۻ珦@# BP+{jQYK6M#LC/w BAL͜e:+IZьϯ2/%O˚gfZmR3J ɻ.l%ҳyp4PPՠ[5.p Q =j]**sGQ5@g:}hV9p6 EB' n27\,v/m3]Ӟ 67,;{Y)g rޭ-<%wL̅J=5o[0u1P&70KhaMB2CІGVK:g+Clߙô[|&ѓCvp)Yק: EH K1)TEƝZHPR0d<2O9WvAK4P\ f55QB3clS}pYRcw1BK1bv81> stream xXyXSgńc֒#cֶZU Bپ}BHAd_dVwkcNL_{{33}w~QIQbLJL27IKqQ=M,%Z(OY5OfN`xj'`KkT]TWwȍ‚<˒-_`m+9W /wqlipk'۴m{ކm{B8MN,H9>+p3Eb6G$K"%j ;-rGB7/%7/aiB)7-B #r<_* 2_"{ H>GP(W ׈K d- Nw{f"/k'WA9 ^Pl,̦$RVP̧̥$Q)k( ((k))uxB"F&bfʫ-%V6J%ey{IʨagN0;ZWL$|ߝ>5uO8rɩO*G];Nϧt3wi{#3ޞq ڦgBE! #X#>qv)|=&7Pscl3!1I6%ܮ`p- -"j܄p=FTDT*.]!]m\^Rg3>*!M BPT}eGklV|.*9ؓNf4 :g ؚCN~A:$簒,]Q ا 6v/h+-W:M<-;t%Z|H\%(HZ[d4WϬ#x?^0h1Wq=F |8q6ڰf+9ԠbD1m Pc@c) %D2:Uʁ#.+sВnɵ(VrtN`kk^۽UϮN HT%jK7f4l C9+viw9uyH!_;eo; ߧe)dj@voAj|rUsdx16Iglt#&o!fd1ɈXh17FN‡*E_4[s-Ϫsw4Qϩ??~5{VZUMd2LY X/U&XЛ-;˷`xbۉ"B]_Ww/Lo$J|at/G.Oiaa^(ruZo|`.A'tYaz\.o5S%E&%P8j ?ċ`DN,1=* xp-zAA9R 35n'v8#3Ofx-׺> PWmﴡJB @*%s5(OMHi׌R1vP2_CFVopyVu0bG` VPMVo\ TZ+ 3\Y+Aԕ^ڨGd߭~ Ud'V,zO {cJݫ |bpYMH,pң|=K`32PTYZYޱ{[THÃκ?M#PY1* IGs֓[E8J s)`%kkۻ='o :j,2+gxJu}|,)3F#ҩ+T: <}FUOڶ9QU4]j;Ī?UW=@q@kC(p )^mٚekujѕI=(|xN1fk:-NR G1R /5x _ &,J`ZeG1@-gC-avl. J,}SKrjRWAii 'uGG[FP]+VQJڐ.2(C;F/7յlUUt68rnl[u^gb\>(ГniUDj}[Q9 ١i&ɄA2_Lڗӭ-Ō2[ZTjXXsXL`2FOuc~8 @tzROC$ W/*N:W'BE$w3+; u fO+ZZ%P̅ѥFr+kg̈́'hs| 62i0n_]!֧ۜ s?gzkH|& GJ\ ~2 {d+.,)XRIUv4uTy[!UN)IohoJ Թt\/ 4ݮ\")V)s<@~RQxA1􁓭=׾{h+ww S'?ۧ3覟H<31ʕV:.@^R dC9(!GwؼNg5GS_"(k/.;*3YVA"dhd91bE0MպNTts飰=6R{p$燧3f7<)*qmz^[쐁t05{WpX1xC>f:W(H.MM@) 3YAEZD~Sy}TA7qjC;1x,Dx=cHR|ڲ;wWwmb6zO|~xl osׯߖwoD=zM#JD *Y\1-cHGW(YDg,_݈xqu zVj5 ,a`\>Uå$4hL$ʅfCm4:qtmtbЪw#:BjU8C&y(cgRi& I$c+6ѻpPi &ǡq ،w6o=΃{[Fh3 U}xPTonmIQj,fm"JC#%"zV!: SwgBa6_Wַַt׫22cqd$ RC٭pRqf?nN26 ރQARa,ҦC<u?єnԩikendstream endobj 72 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 960 >> stream xURoLe혴6P'3JEßtmCmNʻ]붒H !i..JsK Ngڅ 샋D/A6˛=yI$I}R4/"^ɥCuR}H4^=+oV* Il6`s[Կ?=ItYy"v`W-ڹUS__‰hryr[ڽN|Q,rxQ{1RPBS0^p{~;1 ÙgOOΛw\l>:ݛSv|vhttzZ9\ʤ2#ujw_ʭVް5OK䆳n:ON~HBMv(0%{JbE> stream xYyXSWڿ{*ZDFI3VuiVEEQ"$C IPpunR̨{@Վ<\s{{{ "<<<|B6GdRE˛ 3)fg%L%&:s{q yOs0zf&^fug͞=gB$S,^X.r #E"S($r\Dc2xUPMk3n %I2qprL%FI*,q"I,CGKR\5WR%()$I(ف9b$)ARbJ!WKjX*%G1 ZLR< VԪ$R-;QfUIXVD%y0Ub$M)GKUJYD:/LMHVIw#NF$E$*WOȩ#JY{ՃjD3;\+@1 FĒr?*e5Iu)iQ37Ibc6K/K۴?.99/ϝGӈ b:LxXBL /[D1FD ?bx#VsbO' uD*XHl ^#& 9‡ 5I _i"OxRaX1SuWy\r ‹aѳr4IDikKx(Aማfț9, ]f=^z6%(uMڋh "㬀o48Dޮg\y4t26F.&Ip \ W|cThU'i:Q[}eï,oFuARH_A3`^Ǯte _/'ly}\7#` ],?Xh?|o] c~O=}ؼL+8ߒaBb%Uu} 'uBt[#aa~z5WΡh֛9Dd1DH4bn 0INGoiiS Lxqp\ءLΒRnf"@]^VF$קt#d:𜝧&!] A-Ug @|?8 p/bu`Lw51` q8~-X_6938^kr|9֤mȮO?yx /k!AaAv9fι<njp~ {2SP!H Q- +=Pw &޼׶ .?KzCBo.늭U?qZv[ pEWOh̎mqe@3S"i"y3mPx8t?^ 6 qmE6]64ҺSz;-,Vp`ijzORdSuo]9.JlWjZ R'w}WOƅt޴ҹ>,uQ.$Lμu4!Hx_hvr cx\pt ^Pf= .n]DzrKIi2ۊmW z cS\b(` T"]nZPv^3 @>!^0ԑi-jl7sa Wvh_RV{촦.);0 3E,?pz)J, 4@!qRA?rgG`;Pe KG X1՛%A1 'PL̏bcc4HlJ5QߙQ%ݏ[Udpq@0y7%J0N6Nħ}n?oWa @%xqYe*3"N#joTZ-lUu68c?3$m6-}RR '䑁h@E;;D-5oWZ RRG `+?UAc1MDCCg5VI{/Il4m8aeZA\\Y_m)~>Zd2plkUG>B:׆}wJ_tIS5GӉVz\/"yZ람}Ksd}Ynh$Jݚ~oboi 8Zk~9Ԋ_KOLݺ Tk5|zy-[ɭ^x͒_, +2 qJhxzB:kTC.ݣ9;zhuXFjгXTQUx/@ns p)@utKlZ5qjkmף%@ iͨ4\Պ amhk85>욭Z-:(zhʓ/`@yoHlI J!9S4|jbR㵱wO\ȱԤzQ&5_s ! ХtVI hyM@gX>+)bZ4XPi>cN/qwnѷ#/PKgt>k𗿰tK9L&icՔ֖tUCƛ_^\>t#Y La1V^+n/tnʾ Rk|_% .Mc\ cv=h6/;&($pӗ!(B7[\cdƐ݇Eg>۲_aJ*HҼ9!,KGȇ44C|:pN=㵦JTFeF;Q>B>FCndXoӨap,B39ЯQ9Eٕ3 S18> 𶘴`_} O$dFd,+p/cpin3Fē#_9ތ*4Wt{04 w AHxZa8OzT*)Hyը"}6IO@ԷU4VRoL^AeR) 7U69v tVMi_ܲlp44DJgp7T71H (ID(COyh)n 75+>=V;^5Ǣ .#9|f7"H'^Ai-?[H=ɲhr Usmر?%߹.xhw~L/2$^܃q~ǜd"[jy8pܷAta0jD1F9>dV/d~teRMSe*/Ƕ\dmdjP*$yqrmfW" (_˨givWW\c6Xlk|qKmMQA7cןN}E 7z7$`"/=xnƌݡy]Ȅ+&M6[k"D4vcّʪh-8-o~&>|KyJOuhG0lX yKTn 9*ô)ˡb]}YHW#ؾXɲh hUƅ& ԬUFI2V\Skh8J 7[-y.Y/]0?^0m7|oͼD*Abyv9!zC#ۥ*`37!pm,aOoOvZW@S8ܪ-W!VDD4'x]lK;>{<~~n2))ɩid7΁&:f4䔴Ա1oh)L=y JEBB١pD;GutXsg=S$ވi c"_Xf] ϠmU_'K&üOs [?o苴V[%iV@2纮迼I0Iϻ~ 8pCAUɽȷIKZ[xbzjX3:nܰmx_xETcendstream endobj 74 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3732 >> stream x}VyTqIG $Zj-ZuW(\p"!A6d |g (WAP*"ZVjKՖg|{gygəܹ~|?+#!d2pPɤ1Z Ʀ #d}rs?X1`KC{<6=ds< ~LȥN~ߒl&DX5qҤɯGΜ9S)"g֍/%)`Mֽ?wn l2 -ޠ5 :ekC&,-6 z.4e 2FVD]%Ygc6l[hu$C/2GuIDՊuF..Yobt6h6Hxl%%[Dojڬ$G ]Л-^oZgXS$FUg3ۤ8 5ɤqVIFw )V9uɺdC>9dXyOj}R)ý*f5b`^ A K:}2S &? 0ƥ$= fKRՖߔc3}N3>IˈPb9FJbG"c"XL,!D1JF '5MhD Lߧrp:K'%Cuܟ3 x@Ǯ} s%=i2Է=됣B:A8G%'$ELHodm5 Cl2\jOnu'xh`l&xݛאUAPa!?У诂?1 BS`MA]hY8Qa(Ekz L]*j@dH-z$oӉI$fBȒ0_Ϭ`us{ٳp:nXz Pi 4u)0(9*$+-к0]WOӚ`UQS.Uذם9E.ڕ>gSxT@&b/ |=hב҆u%Wq8F .u  :^CPK$(Z6Ͳ j"Zbo|:\ՃЗ|=Xfj"2sm1DsՙY9IA11~au͌ª@$82LG3<٣=J;ºQianFӞLvvT? f!tLMc1R. Կ)y#ki(S\4HB-pӀo&(ekpJ$v xbfȷ -ĊnUt[o*q8R0{vhzKp-kuT*X?^uT:|1CThQ8<U%l;DeO1}sT&т3'hpbO-+w ̬[,e![<$@.UMŒŧM& A>tU\K<5s&;/*ZEDX=wբG^nNHqE";JI+縠J 뺨_Q:g({*^22êAB%4SjBR,.@^Ne?ss!>ϳڅɧraw7]芲lZ jqOHǵ[[I\~jYͲsYfdJEuwW~ډjS OP6op#=+*^Wcy)LL7p3hZucLWpB&'hB^\S7Yq5l w{5\ix AK[~=hmŠa5T~2),gQ<{R.H٧Hy&.= 7!:ϵOSJl%P U^ NHc233k쁠FlM$w՝ ؕb%kwLlP[]\CFa'mw׭侎uEFU۸ li@KNy V l a#9+$q|t⽋^]i|ً%Kc/Oc3m cwp^LZ֌1v5rYEʷi y:[yhSt&?I m%o(+1FYJ%eG$\^L"ȑ )H+ڱ#IlNy=?;3"j#@p5 4WȒWD_&M"Xp$ GIpa0g [#̉/4ժ9Ivq8O)lwz]ܗJ/`oˏLÈVH6Oy>)&E} 4؊/""ommnQd3Am.<[b2 J{%?`\.{{w__^8^+"^L6&*kx?tʷ~B{CDr8O2yh]B }F/N2x h>K*C[J\bYXPZq? D0aRVh p|ti:ZŇpV.\ո:H.H$N}[d臟W-+2.6E8_9DR `@߸p/ȉD-ٟ\uoP?̼lUF0 m2=n1`ׄ]4tFߟQMll~-e'ܦخytЂUrR86K}}OM>PkѴ.Vk ɉ)ڞvqh4 C /aPM u\ l$aɱ%^ Ķs+RVLU^S@h1Au Q5/b6CC@> *צk2:f$XH Jj^XP`aK#v6{h3LTmW>5$-KJ'\}K)muzo HJXDaOGo#2֨5B59yNgN~ +Zr?ߞ %󦯿T<6]ٗb,]8ۙ ?G$G\F.&(w?dߕPd<7t񑄨t}YzUjTiZnB|N[;U+)}kNJVQcG 4 BLTըB}=J;F3OꄝzexvϴZsNQ> stream xRAkSAM>[I#sƀbBmAy/ewcPzzM^' k^2;̷U+s Rti,Ah,ˍoo5Z_kÈqTtWzޜ=?ϵfd){xn7?좣\Co[D}$Ϋ^:{AVH=I t)Ap2mA/h'\ ; &q`ȹ9ȭPSH%r!iXA@Uw%!(ƻ/=𥮣Bea95)}CH)FA7PKTPo\T[YM-[='PfprPZoja㧌iVἺ:P ?&zi(']~Dendstream endobj 76 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 566 >> stream xMKLQtڡԡ%M4J{%Bi5b5Mqi6NSE*Bl %ء[iLtB|lHdk\.zYX!$nNINp'#=?0sӪRuL]KvyƆ e'8v#9.94St|0P__ vtZ@OHx_4I#Q%&%J-ܣr_\Rw:(S!xޠiyضְO 9R6qPgg&y[c- 9:p/cra,;um[<6sHODqK endstream endobj 77 0 obj << /Filter /FlateDecode /Length 2776 >> stream xZKN{ ƌH Hl" fdגw?R%/Yv" r жL|N)[o?~|ԭ~\OoekCj}\/a4̬sXoOR$ jMdM,xV'2ELϔ&(ETH +$iCldJSg2.Ivd^@bqP8#2Z[Z 6X[5<5z&X$]4,aE~l?ΝWFq{E_kU 5hm_#2kid+_;93nDY!}a#$|m.$F7ˌ9$&Es&6}όteY5O Kfl֔S%FMJ5(ոZd@TM `TM+ޏ+nq"eVd.Qtbfv؞eDh&E>sYYSe?P; nj\: ygw0B1.l i'aؿE2_e m][Y$o"]nЮcNj+#S{#)֙{BLqE^}5ܮ8=޿}:;?ڸj8ݾ諶qZfGP.wgxAv^/g>c#N(Z8le1 BhA.ìڷ>OGu<7Cr65+7ucTWpYA)h1>R`vlS(л.P1d Z8*m㬑nʺ˱Kc'}?9m]X$i%TA-)fbV{ܲG'c*Ѱ9v RveCLu\~+ Ug V9=[=ߨ;[X y|݄uj7+Tr98.xAh5²oOP]+FtCyҖ $MG5iNs}yi(ʕKUj"> =^ ɐdF+Wu6Xɭ|Tm%6wGA7-m;i,&m?Jj2RƵ 7ݾVQ)%՘F#ȧW>+eG&jDhr0]|lKOV0x/,: m2a(8 M-`$tΙR.H}"Uص'dMRk,XJ!m*$$E/C)TcPBTT,IALb@Mes %(ӊ.6{n2Cb/gT鱵B8{\d_FD+t\H9ߗͩU+Ev-1zJ_]35z}Z ){R>ܞvi'lIsܒ*0$lPTl6'(i 7 >Ii&K q7B,3sF8O])UȜ %UaU$6C",2S)"FOy8b]i;Z{. /Rly;~w#G3c P6O^7WeSq.L9:Ca^jF/J3;6m-L4|2ߚqHFR0`׃_#{zhM@ٌ;]Tk&S HCCC{vR|S :3Y]rGiag+L>a2I1.OOe:"W8+u\Ǫ :Ώ..̝V2APv-4]A8돡d!8aX[MYé%j\ZZ,81Jpm ,M0X3Txa8n%1/R#iS;%uTl]- /Ep[` [@1R~ɺ::($p|f2"$\~T hZf܄{nUGʿj8f7M5'!ڬMɘ{kwLRP^;VjrFA-.؞Ȕv#"g~_E92?vM %Sn-e:Cg^)nl}G= 1f F@=əs'W]-v܇svڞG[X́n}8]nGӔJ簊2#EWl d%]-&XDĎa5l) xE܍>OSիl9c 7ϨfPy?^ (IlQ`\?P1D9!Y~j=4wCaDנnB`b45;}R՛[l M$;f 1T1 {< JK- iT$̷qJendstream endobj 78 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 482 >> stream x5N]kPwZb焈2 F֩(X6ݵ,I N7b,e"y/|1nbXp8p; l.?7'/ IAN{w 1c1Z9 XYbib@)4\F +c\%#2K(ذ͒aTn̘)J.Z42F =:jxW=dGeUR5r"֔媴@t9<70Ň˿7 OC>-꽞([C Ml$%][rbB"i݃}h߱X-b6IE0Qq?pk'-qNϽlDc]O{!;!1kխft LJ5R?X8э{#ި0ž}Nz9.)˺endstream endobj 79 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 597 >> stream x}Mk@3v[mm %TO^Z+ ŗ&@62+TeMki/7,Vo^#?#!k:F8P4wT>7~+D}ܿOD7)t}D/PaB/ oi0UV{*{sl0{b{-z6 ѱ0L48wT*VK_U&XE^V< u"$]N3 .1q4'%s m/&u8e|^ˁzP&jN&`@MQiPobqpSNAkkmRGz_qIyYO7݊2H:K? \nzi/pmSMmcM-%H~J(2 FRiޯFѐ_Onf進ZJ < ˝뫰SO뷖+ OQ.V2щ\XvnԷg)+:_B'AɍYRjfrs=ɗ n|y+C{ƇO7eyoS>,Iendstream endobj 80 0 obj << /Filter /FlateDecode /Length 4277 >> stream x\KsN{-:KSq\I9Ǫrm ILcf%։kK{5nd⓿mqn/ Yr3% |rvysQHf1 %L2dUjaaqzeX=:(ʏAV} 2!`7Ct3_(߬IvgJ9U3ILzJqົ'Hulk >xߗBH THX.Wo߶AU,rUT'X8:cR7X?pd߃pV?f J;YMVocG𚷰`& D-P,9 "f (ƁdBYL#y r ~=_D UIN2jm9 wm G_DGnmHj$ f%X_4K Q6FG9Xe~]6c4r^"M 룕g㚛Q %βp^of![aq.#88"O\jQ>(`9)uV: ƁRA5a?θ55-b*F{eMZSlsRL$<҆f&: cc24(DUq*%U4GImHH?$Tf Pk5 )(D1e$2 7TS^(Sg ژQf0ԑq$Wrޥˋ.X_\P*̨2 nn.wXd}QgQ0cz931 7jAD-(FM)ߣnFn -]t9P*(!,5Ç-1 AF!>cv &c"ڣ(9H㓏igYjؑcԚ}99GPkUDF]IEtKJP @r@-c >no:S%x"yJ1_\nPR$OqZL?I9P  ƟIC|w*Lj`g߱P?іς]>ݖQR"6I̲#O#M|)ztQʟlyiIzZfX)e=agĦ9ո瞗 c wώkauZ<^Zˡc-0gm8jږeB~5C `c.? @8/7I )8OIC_)L 3OHxlVxbDw^Eqx[U/X M\LĶ5 #Ni~m\UdN4x0"6_?Vy`El"[:O]3wsUll$+X'}OvB TB1Ǡ *M]P1s U4 M2>/Du5ZP!OA9BbiO /+_ɹp=W5|]e&mHADlS#"~vYO술50C>rbO(?E='ٮ^]]+~ڡ3gGiug/]Do߲R,-SNSҌKAߔLJ}s斞b;MvsPWܷtzM.bM,lOWq]eA%y5_^\~|췖ObGe?`>"%jĂ&EMyȒw4H}r֏X‚|hN}CtO뚜Gc;sl;ˆ4)ƌ!nӽJ s,EQ86lPX1$ ]Xi A`vP-jr4q$z[͜h44`6fWR_2"8ws(7Yҽަnm$_i,*7452CX߁o_%oGz} B :λ4OEL8 g 5)!9Wi$~`ܤm݊{Q6JZ&;%F NrC!d+7֢BXkcLX{zLjDc}b\37[ptO;ȼL:i8tf=ݎ`otz.25^K!BIMЈP4֨vɽ 9J9`fVɓ|5 *ᏈɥMiu- ` I$4ݞj-y,H }DlY6WQJ:{~!R=xDOʼnU6zt4t ,OvlyX'& xFRW!` v6˓7uI鮮GHAm^f lcз7/UNYY&-o\;M}I&! @^Lpݹݔ~|ŪhJj^TR [}¨>9%*Ssu 0*|,ӫ՚jCsJ̶PZWP [ (tZJ2iP#Ax;G:M6)qynԫ|bvQ%!3`lK.{ o78et[8GtĦ?Xw`wz{{[nܖp$ѰQNȷ$QӼ)>124 @KVтb⮢HB Z|8Tz*+й69R IQ^db*Gw{_`>_7.š"1:"ILNi W7j(mhxFMKZ"/A+C'eivҀ5nmeԄgpL3`n9)@hH`fL"`~ɐ;So Z\H?<=%EiS -Ac?O]^8y{0x' v55t?ˋpHiA!thbM 5cSPf{pzB$9!&q׮6m.=SҼ4yw?Ba)Bn0pls`Sˍ9xͭN* 7xN'qD#T.Yqjp{f Csv&7Nk[Unꟼ.Li l ʸa y}`2OIe2d`w2FJf $տC?-/ ^ёaG7F96_H=֎+5\@Xcl OI z)]&N(D/ri,(?d{ӌh1!Sľx; ~ ւsk~o墚.ny.S8R]EU㜡U4 ܛ mő)@Tkd_w VZԿ`oI|!"$l ̾Fo'G9RT\d߯YwUT&ԑsO|נ>X6+o28D,{ L}y>$Gk\)sHl}6I/z8zOfu0W8nFc _TK7@ڥ7i> stream x}Q]LUai;+bk {_ڄ.cI66&nCM4:3{waf2aKwYgYBK鿴XAbSc'&_}8Z};9CSeMӕ!S>0+"ޫ=o=evo1эjoV\j*{mi%ٓ'i^?8(+{} BփtVc*1}TYpXmCI`o c奆x<$=(BZ0E /^ 4ȕ> stream xX \L23nuں+%{ a pBwQD@qWp-Xkոֺڪkﴗ}Q7ɽXVŐuNN!!󦺈}" f#--Qtͷz1xèiWnsoӆw C!bwcHhLogMoctwπ(I{iNCM?wB=ľ!lZ~-6;$iIpceaWHVFDFG{tro-A[ψ9+a3q,w'6u״{b @#6 bHl&!$b+XJl'b1I,'#VӉ b1XM"b>D%yP†p#hb`[b8aG1IX$1` ~Db1XD " b KEXqD1yP+xiuiK߄ӷ6u~]'|.X=6!Cbcks^L {ozW m aWlSxۈ3#u< 7Khlj ׌ ˒v e &) ?_ B(Ă/4/ 7bW45`5IVL}C-. ɂֳP:F)H47,7vu6?衕Gy(c=`$bKvz&' '3lPJ#tw/ &$]3'X$!ञ'9c:xEgq^+>2pԗB hl2$!.c;-sttׯ_^75lۋ2iɲȽl*"'!G _~ :4(U\ZAM9G _W9P (hG|: :x7Jj8?!t/.,>Sa9$]ʄ_P5İ;20!͛["VÑٳP!DY ^$e,lR7s{"G"'ژ# 6 k=" R{B=Xl&M[$s9jli7Oټ?ы| PSݒ 3lNɩ$NIˠ-ISİUO<Ҕ!;,-5$Ceˁ Bp:6 l]^Y Q5M/b2fWOgF'ee aQ\iNƝKvP>NHEnN!M2U=TZT} p_U:V=,q3HhI+Sd,OO/r~o]eWKSSbY^jh$Z7Up>u'O8s}U93^Q6pf7[;-s0%%g4*jpB@1?P4t|/dك7ߛ/X/^caO(.U[^95@;9FdP 閌5]c*΢J~ c8?(S,XXueF#@T jZoIC:ؤOM ~ENn:̨H>.ms23,r'l>IJԏJ5w gQ]}(RcV$W.-ޞ@5kaW`\Ot6PW52 Y(_shXZX^_tHɂ|B,T"@}}{3gڗ4hp+3N3#dDxES&++aNh)9Y{{)&8 XSjoAjG֥B>fu">[A A E0 "p_!۝EƀpmE"3t6abOR jR %jK:=a9tnGgn@s@QluC,KR9Q J64.-ruZ8YFqZ$6‰vZdT*R_NWFq N%W2>L ((:*4*&+=qj5 KA=U 27s_s *@*6fgy?pWéY E\[ cZ&aṕg&,uAˮg]{(*%º^xm$@8HvO I;^زKik<XzPuKa}^xMRsUI( g (9\CبPS78|l@b4[h>2ٲ$DWщxw-=mрpFobl>o{v='ːT4вa}%h4c&u=n\:myuu6oR>܎Y2PF]@#xpr'$RU/ZD{+u bEb*PD2E;gU ҍAG_tw wYlԮ`)Xz*.O5X1hxb|:]-gPxn& { l֣92A핡p=tG 'm$I'ς*TxJs&er|$śO3qOewL6 s1Vu )u;  KuPÎrY,1zEҿqF3hkRP&aOp)x(E>?|G{E_󮜺7_i_{_vP6m{alJz&-Y2;з2А ((?Mr1b$C!>l6H$38:@*OÕ&7͛'sX픹r@Քpɞەk?qt+D^4amt*w |w~R.JаڀҀr?EV4dqJY-P+s$')N3>%*HL*kR@HHSJB\a ,"i ~J$ zɢ SPYXvf?ôa~AX/vyIEHC8879<"?2?O?,FV7/~XS tpPL7gd״tv4DE%JO+԰ݓgun9̜%n EB&D$ZLt6wm>(S#$X]]p<47!{hYie}ISQzqJ>Wrpe6e Ii NdG{Egs;׷p >.c+ ڎ56wO; wܵ:?W_YY_7go.w2$k^{}̀̍{c0ӗ xb_-۱aघSr@T$PeFWE| ·y7R>`JKI"@*HM*-p GFBjc5&VDXnj+_ ^qnaR̀n6X _S @2e%HQR@&R9 ,T_ofD֘w.C+H@uu=;ł¼7r7 uam"+r_UcAXsInvA[\+@9bݒyl+m河5@K헔IX ",gη%_>n߀9ܷoS{"- |ٮpWo P^)HxYDccyNhZvts^܇Ŷ.?⧧oܸq!k5{|~/٠{djI4]0r{z9$hĭ-V; U2Y7c4P7)Ɏ cEWEq{=g@f/}iꍋGL}<BǏgf],3Oܺum;EuN.Xe]+ݻeU/HK)g@A<6 ^8}: |TKMImLuPP4x_!0sq^[ Fp$GZp~ h <|@3N[^ݻ Oz7?~b8=Kٞȶ;9PM[g4=Atz %,w P wV'i@ U], 75NcXo 75-"MLH72v7㑤i\=n(zt'^H< hUhwf\WMsWgׯw8mK@_"sŽ-NX]baۦ皻PC;k1a4sޤt&,+/aߗf*s@L+F/s֋z3#SSbjKMa*JԌV%&ȁTQW4XWj @ vD䴕Iyih |soѷ\;v`QR2?ڍF<M5e#I> GG$ʒr q:09VdJnq׻HyGZ̗2@Z,/|(P:ia|JVVB$;e Rui|BBOdJ9K¤EiT6' L(* +j H=\:)Vnw!8Kl=wlfg٣KSX\^NpFB.g>W=4nK@qWLY\Il\l5j)kkS32X> stream xW TS־1psUT$FK[uYZjPkEpV"C S!at)cg'JU*^g;Zm}]s](Ys9[DYD"''E||A^^'hGIk^\OvVb%?Q$˚D1~.\<>g{ǃ^ UDo{N *T䡿lE Bngm߸yWK(B TnRr/|}7|̷g\59ns퟿kLP j&NvR9nj@Qʍ@Cmޥ6QʉJMl()5:@Ml)15hEJBGQ㩷)+jHMP2hʂΊV*Dx$YȴxdLIƦaxv|xdhu~B'OzyfNnYoS(6HLqR-{[+8rGZ' UޙOv E-Pаy_[c|X鵆Cej:NPu#+&]-64]@I\`7gpGnN^a? (H-[?,ŃȚ]kwO]iKpхa D}[!,h?VH|vjb:A v"w{y.Np 'e?J*Z.hIЀ_9o *Ւhlo < O@2$ɫĢGtk^a_|rA ꑡ%o9؎^fHR2jdh4[ZB4nj+g_ш>_bnkx~TNDd q74=d* l g6x}vUtq# '~Kv[bwX̎CPP "kٶ-;fZ>ϟ#6|{V|~ѕof,kUq|$osG  #JjóTL]Kwe+ lrڛ%PTXb:BŮzpTCʯa/7wWdJ-PCJ4RRlle?;&5FMR٠?@P؉d0ЪU遇t7/?0kCh9./JYL@3~~7lv9I䖠Q }XNKJ_,yG=JMtMp ʧx ^(DB]<[w?: ܳ4 :0v/OB#ay.'ƒZܷ![:8, <nEÆaJ2wPN$p#+XEp\^4?9g>Z5D&/{4wc_ 6IJcT.;` 97)*Fٰ둽I%Jr2PĘO uyit# 5zfkHϊ\ QzhӍm1(bC=^F*Adgfy^%obADJM2>:6I{p0osΙ)eŇ 3tԛLf;^O_'4MB4\2W{W,I# &s\v QߵL"nHnLlֶ:"7F]/0C9XMS$Vs6}5wfkdG\޶Y aMuY}5/oCӦiIv'eGjΓ u(wjH#iixЁv>̳;9Cb{8DSmA hSEX'ΛIh z^ ͐|O} ~iGM'ofrؽsGjC3k57,ԃƎ4Jx) TWSQW<+} -Kh%'ůa^ټ+@rU3byQ`yS'ATdo<fcg$E6@C<3Ր ZsAdAav^Y }߶b븪’bCNX5v"N={<:zz::Μ>ƂkǬWNt8 3.r!nύ1Ij⽋p]}Y3G5HOu]PA.ijJYCdBPTG64TW7<"y5A4\xda6\JyKśFrmp}82МڍP!t?yVO}i͑aQ2:36MvJ \$JY,JtlzV C闍*0$ 8#S½!!Z/v}qSQc%a_æbS Ho%ֆ2u&-,Қ;⭿id|^@Ǯ\ơho޼:=hMTP:EB!mn`cd6hWW2UABcjk$#E9{t$zBIY0FXI;,Vy~fٟakVjǮX&'jI,aMueMzcJ6WYw/aW>)) 4vf8磎Gd LQ *oȇ|fIJ@yhP9[9Gp' ^&ztSkep.chbZueac^ أsf@K0ټVEp+%9嚳9yPEAzu _ -P_B<*>`ʶpf~j-.<og\iqp32z2J_>&_1>g5G\ΜmbUGĄUT.=9-tvQeFSA68de|{g#DDo #ܼ֧><ͭ<`o_}$, ~d`K46FsҮVY![K}{'IU.7ŁƴCLz xG_"kRA t#ҹMo*U{U 4尾{wQăS}աǼ}zig jd.=0N ~,'xh4ܹ2QuU 9WXkMz:N Q&GaܪN(RS`u]%dQocC:|GC]p9<ע,h/}Cq\>EI:q\J*'q oħKj>«K32rXDd7OIv67dP3b;`:>}fc6a&?uvvײE-wy^ϝkɈcdz~1zL\{+{Ȝԫ9dfX|k>O }rJ"]NT}|Ğ{]1Aqh*tu&gbW!-ǮBSҥڜQk.Ojpgg\7gNQG'd''r-2b!.Dm$A]J?vzkkC|z-M0L%fsO%0zy~$d:HI5OOqtzM\a93~\n!bQ9$E]G> '+s-"+Z >GClE ;;ܽÃF(c|bAhJb*Z~=,C4$nendstream endobj 84 0 obj << /Filter /FlateDecode /Length 2357 >> stream xZ[s6~ׯx-P\HȬ:M;>4ѾB"eHu/xhnRh@i@̿{w\|> Ծ گ1&0PX &~,8fT*R|zc20UͣLjQE0#BE~ rL[Ev3˹4MC9٣J‡ x8TvY6l."FbZ׻(6ͪɮGG!Lb"3Ps@#^4;L@bz8w2wL9HnjS94,nGcDӓ0Y&JcpjQXl4]r0s[:XƳ(Y=Lbj9B=:ZQx^dͽWbg:,Z3'ŧVqC+2eCAe>c(̺5I.g:3$ B >%ɄB5 j[M8^Mp?_v:3.C cRl(m2a)"+Oct0knN`RErq"6i@Kݷ#Tw޹W!1 v7o}xk> dE?6i/W4Ytm&,Wpl6w}竱5376rUjڼ%#_> stream xX[o_A(:l-s1/n-(`+h٥Duspze/1`rx/I$?sXJ'n' >&|*YT-44ӌD[duXܐ"] 4%YNBG Gxʥ In8Dt),FSɤL>~JZGJb1eqU (8sգZM h@P#_)ZDHZC¢\gTHj O VVفlXDFQ\L6Ӣ(G:DٵtQ3;ΘJb]=3I ۻ)4}JtfuN2c&ř4CtisN 3$yR4&NerH҂?#dpm9Ì̸<(4c7A[\XˑR:గ:;ә op(g-jR0{| )J /Eؕ/73[%%Ko62BVQLkgϡٖNz5BFO۝z|cd[x]Ms/ڪkdB KU28Pq]Bݞ6Kgj vjSזEn;7 r֣3J;{o .4ȮsM:C_\ojCuWo1m!dtiH; iIHg 3JgB'gĒ\X&dCSAq"іe\O)$fYBC'9J`H$danW_nRbV?*3cMIW[[Hz zlv/~]ҿ/ 7γھ |ӏ i8f27 (WJ9 SuY.?AoTL>N%%Ϡ{̌3u$D_ߟ:t8#$} u\](M4f|VSG*R$PtHw5aoSF]ۺ9ɵwԒ姢>6Y0i`?}n{ P!)N 64'FL %̗\)ÔF-T桨iSH*a SARNd3 ߞ myOr)gB W1I{e:XF19s bUR9N\jR<7r<29#>[NBPjY>9[YפUZ[_NuC4uP7A9V.s5H("Ed9#0)8` (wͱoAJ3qLޖq[7eO,u]*ބ .@k!se(u0nwšߜw-hy~=CUkXoZ aaa Vǘ۴:> stream xY[o7_!YZc4 6i&k#GwfA߾pȑe, /~4dr35]l:!p,7§9%H9|rt39Cf6pQk YƓjs=Q뗹엂]&ޟMKt3 gDKK; E 3NRPMOI9HHMXXu5Ber`I`7{2|/f .- :4 eoeEjr7Q*Q5XI>WZIeHgawd xw%$% B&y|5Rnk/&mO''z9p!ӛdrp2 RB$\W:nHD .zꗠ z_nnٹYvu@miF\h1;t8\8յ=[t$U-*he W.WGr%$\ؘ̜'OгCi¾7E[vCU{I3ɦs O%) QD^DNAPXx^۬ʮ_O|DLi3 U7"nɆșeLP9V\EtU +.?orc$oyԍ7h~x}7|̆f~vE,dGs*r1cj8y !, K[Z̭1ɓ'NAAlcQeCKiFD=o=`oUm2|>{D!Qޖmyc,U b:RA廰iCe ZTygcFB/E>KHz,г*&b\&zl p}CmtY+@6M3H\ I̐!BrWU1W}E8@Ahs2=''ZNxkE녫ϓŪ*!IbT\ʓ8';ՅD}er uMDˡIx,k oؗՑ:EߗEzvY7vE)!JLWCL'єiC ySSv, ml }~uN3]უصՄ $mBwoXKd@gEN\t##>:4Jl(eir.M 8tz*܅1 הCA2TDk@"*rQݩ́b*\W-q5Hv=G/"@!,/D)Ī\MY e)&[v? !e0̈́)vR&r hUk-G3dF"& T`驆|k'@Bgeŀ#Z~CnO C0>' - [<Ì?ux`zoDbgU<\4>mgmL?W)9>lM3:\"}?oO[V*f;}wtXA0`ZgŰr5A$6-H$Kˈ">NHjGر+Z P-cA 4`%2I?VH7Qֹ@*,:nߦ4ElUĈ7m7a<-S⑓a… Mp>5< SfEPVjOp((н0 ,> ?$Y$s biR^x݄*O04 !#_z@M)r0XoYl+Xi #3&3)#6Q'0E1Äb#Á(ð^zx)=2vsĄYa,vĢC ,~k2 u*7~w}UT"9N.GW}VLׁG*o{#ژp_s0ڔÄ0)ׇJ5gˣT(L]{;@&)kL6ƙŌH˭If-{0ԗዠ#/"^ˢ*@b>/zx@SL5˶Ƚ-aH4Nk7c Rڨ~PzA,ΔA /\ULe:xMT19[2'{sB/Į[;.RHoç"iT9=͇;,F)ꁱIZ*@p<5ู/lr'7U x(7_D*zX!PQd&#r#,nLJp+Q Cѐp/'Lc zLl>%9BF{*ĵZ:bT":DY2ðf ü}ƈK3FFŒ1?6cp84gg %<T+é7endstream endobj 87 0 obj << /Filter /FlateDecode /Length 2267 >> stream xYKs#bJT Wtp썫R[KIXrDMv2gtoO7X~kSٗ?hSh3ubo@dd\Gwv#,3 q$!|cs RjjMn BjN"bT1Y.e2H3 >%Jm;N 0-ɻHVjU#Al@FJL0d0k=r BcCT|5~4jRܐh;Ԁ60*05xSUSZT@p:NQy? s'ϯ5YZ(zTsr3tVrH3v2 v2Im]6}HuZc2N ZnH‘j!oJՊ|$=5U޽O!|_6~4ߵ:[gu$2XbQU|sphwc˔ݍJ ˴"H}67x>dR rPV) tUCWU0r#΂p9ry4Kˁ'yRpw{(FAP$K~?^@/TEcs\+=]Ҽ x"C޾}jpSq hI!Q&z?:< [՝,@1$Ɯ 3u@`écNwu>o|Ns  ,-lġ *H #,$j m^UG}Lc4gqtqe XQ MФgey:<@uबtrB0Zy+ay=%Kg;ûՃ1 6#rwR^Ry ~&x` K,M9@Ϳ qqe@C(wXP2d{Ɨp&:suݳH &ODD3x`)i(9'L>v!phoC Do#lw;WdUo ;T,<ޯ,{p=s$Ҁ{h8Ҍ@?[Xo7.?@LR}n W]3>`q aD\4>0a[[z\]"3m~fsI#H^5f> stream xY[o68B")TY`7vHMݗ@QIcEHI~ȟ$Qbv2Itv2~'X@(sDtrpiX2G21NXR,TqXL񛦂 cB=Brx̸Yin.WY'T [e W˔aQ IpeqP6 춂G 06X[dG\0>_NmR‚D4͐͂<^|O@ro{]Ej6p*p5b5FEP#szmV> k$0JCaLhY`͗3>%$ʦC n?w sаg,S _)"%(1RobIM2F"e&81a-'/_+b0Lq\hyje2,WxrnC2F07ZCz*UD!eɋ[V v%ªΠg]_n9xb2@ؼYGɳmZJ~GsrUT;FjO~ӥ{R<{ݮǎ)I̤3hL@(1Fpe1:Zё5cхӿnJ۔ #KYRƭJqI/%V5)JӪ!jh1괽)/=nG+]M]BVЭ92 d -{&+ s#&ܞ>n#.87]wȸ3E=*%i,TĔq*#c%ч^/}]˹3m\)Hx3-JTS>ɤhZS(Vfg&"c56$ 2@$UК"K9+ͽd+K }j2MO`x\dq7"6CAq2$ĭ+mz_VFUOc?<^[t==*x2!\vGiSZS \\ Te-q^B`*E̸ Z6,V{!LQdχ . vG}m\wUa@C +ޣ3eW(m7˯'_i9*J!kRWA_z&@3S "01UaMԫNm@"YCc:ul[H@ލ3͔C/0ƮqH=#|]M RY:ś Xzr0`Ӱ$$RV򰿹I<9IуuU4č͋B<%=$ " /xK ʑIAE(W\TCfG^(z wX/^`(7Ra,%u~J0_\!ܳY0v3*7MpڥBX2Srq-@/p^6I-?e)`˃{`4b6XX6AtNG:\ԞU7ri<V/yl]ԇg{u3 287==D>53%2y{32 potjHeo/^Ҏ\e9wvL%?5g^u$x]=q/̃(><5$ve}}ay'_+0 1Dlvc,tSO#{3λеtlxv ՛C|  (fK +Rj`3&$!6J 8,5;Op٬B(9f2Kp672+%JzOdT*#`:f_/%endstream endobj 89 0 obj << /Filter /FlateDecode /Length 2453 >> stream xY[۸_a &(,Elmmʹ:(d[QcK$C~{I](ǞFswG8&<ՈGGԿ7v8@b߬G"[5v||ݢd2pOfcBDx s *f)R :l:LLQh<)DT'u#ʆb( `[ u[@$lt6l]8,)Zs CL&?řE&aDc*$f5BLnwh4ʆh٣N"@EP# 69_12!b|fg#0JcbX+b˻yރ|9zs?;XBHcfB)XJ:.zD|!$h<I-0@= Iĝ/x/77cDLRere-^Uvϋ}\!"]!F :E *ՀaN|2BIL:t5>Qyȡ.n N0Au-a6^g=j&JEOYNO`rhx |o8Q"j"]!vD@^>*5;vQ"3>cyN~;X@Fb]-73.}TJ0UD-{JPݜK mY}o˲5.G W/>{L6FOG9PScXr ɌAO2%のKch{[1`8Ud2ϯGMeǨM^ 'C;87:Dքy78 ּU)錱CpuyjTՆIiw-rnUO,PC!A,]ϯfTکJBI6A3Pە@33 w޴&詽f M3,8Z'˺d$$;'dۊ5CZ]H-̻v~E$jlu&cn ּ$Ff jћ" u?tF;xlw,?:&@pb:}~8X0Ʀ=dw}ڼ[yڒ0PMZ:H鯘P)dпrħ'?Ah8Yl!3Hѡ^0ʸkwAOߋ,s C( sՋY-35 T2Y~hX  -\ҏ Τ/NCCrX*66E&}"zT p~eB~0Pg\D`4s1s}1aY=d^,QN|fy}Ly u.s/Mp: n]ug*n^췱~EHҗqNI=8iwgNCvǵ!!$ V 5*SHLm-J?1<>0C027V|HUR'w>sV>$&1A)eBS\/zR~?k֌"~4=+_IĴ ^=QAraD'lE ?hzo0=RB~yWYjy.`&W9]m>H4&8}F`@9RW21q_/9Q!o2[W}:^(4ˢzGaB"b+?oQtlE.:v;b"vW`0fBôoD?KHI1 n'sZaB*a89s~5j Q#+&l FTq~u4Q*bps|Q@ŧa tSrZՏ04whE=iϫWSbrhhTzl~7i~_?L bƁDk`C}q3z v-EOV"X?E~72ɫuQnc e4߸G7Oi&LBG'#rElބ:1byyGpF\zt*a.i}y>Pad1$ڏp?O4endstream endobj 90 0 obj << /Filter /FlateDecode /Length 2522 >> stream xZIorԯ iR7=Y#H>p$Jf,^(6m3Sꪯv>G &Qbqh̒h?<#=QSIe$+H8[,^p 0$֭`ygPY9` ioL4P3 _B ODk?>~`iD!Ra"BR,|%X|LF& cR,frL6Q0`O(ƙ4ob\;!aS , :CgqsH;XBQ!`1dw0|n,y8$))zwd;3.q;fm]wvYt+; ݔ갤 I͛4ISӛSApOh"noij=YÐ7O )ڞ< ح6kb;^ܷ.u5me1(aHPJ9(u~9eP1]=&`Q0_r~.L(M'tzpsVZn:+]U~i y*NK"eX8ʍSJuPf[kK~u\3B3 z] 9^ 3v!3 n 0 k{OjNG+0ofo&Mtyo>Ʀ#BչUs s:UژڟZڼ%:UMS|:#9:C_hnm϶i"󣗧AS[? zzN=P!pNfKl31, `!NjyG#ܫw+wDLg]cek ÑәF??L</Uf|mr&,9~] ίk =0$f e^x./X 5@ko@hS:`Y,M7/mŲo[GWK@R/0M3ՑN7Fܼ\?qp倝u"ӕYD}67uKe2aLi%gVkmr!|~5'2?;Z0E 54}Vn<(N@PRF]ۊʹ1Aͳ+n2EmU.=_6m~EfBQ.hRwJd]@icb߁L05"]g'QBAь 2y ^Tvt`#qfxz5kNlj#pN>ͼS)00N?/3$0۲{Ahto>ſx2c\e\):O#endstream endobj 91 0 obj << /Filter /FlateDecode /Length 2044 >> stream xY[oq~`lP*EC.4I=ÙQIc/=.YgQ X<|sd$7<ׇɮ]dn˂X`ZP IiH-0KVd%J*]Gkeɹ@ÚP_^sVYÎme(}ϓuAD.K w@2G7OpPbaC$lׄ gWZ=a|5O;$4pfYmO_lejsho*i@DF^" c;;6@ {#PBbbՌ(b÷3X܁|u4!nVo{ؐKd"Xˌ1(sLU9:wQAa\Hڛ]Ӂr9qkN2g/ ?3Yޙh=éQs[[mlN3hXʡ^S^$h,]RhխRW5T՝ilwi?Kvuu)_OrMbjj?0%awSG%9RRSGեJμFFB'4ie $ڋq5b]kNHnӠȺp0>֔KZmgv"r.z⠘L'"bc ֡ˋ:Bzx~ܮ9ja: [-Zn[.EHcZ\UפxR9 e2K{cMjB:r3r!=(ͶDz pjW} Ρ:}ۉI 5LѶnJ&Ԯ]]-a~XeCeHP4eX۱K:mk#TQRuӋr_#B0V6e]{$~kdžaI7rؕ>@#|؋|Sc Dq6V>!cI=>j83ETxBlNy|I=|]8;}tC/>9;> ˥ ׬﹉ڞ7]g.}bh@}{,,~微g)ט>l t7ɶڄ:Z vPԕj;ODhZMIm\MS]$ۛODg+F&)dA|lmPk~'bʙϨ\e&Ux1=>9[p T@7;M3gzNbH*->a/vf)td6aySE&̲uss3ɣƃG 7̧geT4̧0ۗd赐bW{z7 oaS(|vY3jU1SGs=<+;Tc^Na\ITs\F8$sw-?s/L2(59'C{g!!ή<\IN_[fkEp5zu:\uj^Y%څP> stream xX[o8BXlEYvXMw>x k4c3D9(R x$^s~L2ʒ 㿋d?dqd2T/XdbQ\%mdVF'QT$ꆔZBIY&C*WJE1Rs"aENy c319od<'c8 zJۋ"R$),/QÒ>?@2ګՅ2,8\'-<25L)%<+( hlWO懧!WY݊Rˋ\DFk#"S#M3X-,ug|6Hڅ0$zhiagAL¸f-~hn"πp *1C%}ڭ2B%NL1YHs?cHt{k.tW1)DBܩlӶ~6 ި&] *MgĝMTN@͊P~ 0Y%W))2&\gp$?5AOu*ͰKfiTeȱkb]gdá[׆<]gz+a9v`ˈ$Onʾ)ʞa"nڕqu 0ySf! ώ1UvCF.(UW`SK5&B"Y h-M8P& mjvXlm 2 0q<@(FJ7y?>+ ⡻aOA:;,E@$0;U_*c2Syҏ}YMS׬ Zߗ^Frۋx gCo} rl0J;Cd| enQN!>Xn86C1#Z `YN,(z-eN b &8.19"8`h&B aB`}J8_8Q`w.H!5XBs>׿ 4~! H0QOO5^ o! ~A= ӶkvA 4wu4wh`o^1HJkN4w]7 CZ0g97uMlɜ ; PbyRS eK2YW<4{ my nI]0Ԁv X3 /ֻ&[@R "ԦŤ;v56 փm#t3aР~!3Ve`vm$$8Hw8hƻr j~WA]}xQE8d6Uw<2* JO1c`BV?kc /9QKT NM L&W!c$yhi/ZFI9&#Łت^0;60t3rܸMU.9[Y9T!frׄN\.@0#;6>hM?Sh]ҋ_gҼCUcٴGo.x:Kr$xLm}xšeH (P8 8iAn g +949u Cs{) XY|pGӬf&Ԃ%yD Y)Grp!@*Ʈ.>0\/sZ0*8h 0fѻE.AoVd/Ȁ'5ef]L>ak!QF"O=/#k!r We<F3#TaQ +$y,,*9Mx>?zoWӷ1endstream endobj 93 0 obj << /Type /XRef /Length 117 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 94 /ID [<6638324d9042b3987fb0aa11fe394d26>] >> stream xcb&F~0 $8J ?w> (^s@s" ""@$ ܊ ,D z"ARU"9)  $9\AlP~E endstream endobj startxref 67965 %%EOF mets/inst/doc/binomial-twin.pdf0000644000176200001440000022335713623061750016227 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 3046 /Filter /FlateDecode /N 73 /First 596 >> stream x[[s۶~?o͙L AL&3;;Q}KNhJ#Ri_H&tá b/.,`> < XEL3<2c$ B%'g|<=&S233ԖA0? =ixAȼ)E)mB& ƕ |ALPEL*(j@ f$6PJJjҢH1DلhLn({|i2IK(РP)BR 4A!GT:@ʃ #{#P_aSSO"E;e|$9Pf_ο%~ݰgl6[5tx%C@"#|vu-T]Wm&e/ &_փ& 4<7$.l~ {t?I]I_~,eA=Ѯ'ЮvKCy̋d{BT)Q@iN<[.ƠG^|) tCCmϒ$_ |Y o,2nt<4zÊ2ZףU]<__]|||q~O$͎*ԋ8ߧ&Ԅh{2Ionي: sKw|9G+ylw6'[~6S>s;9//+b Yz"{~8orxl翻tPF,:o\,s "J C T$h}yp1{||h!D00Ww uƠhVy6OxWƿ%iHΎH4-S [( 1cƨk{ٵe{˲,R. :fqÌa[WƓ}nB4xZ [^MStb^詅Ԯe ?vTک]|Ȉ=eDٹђZe,|Sa#Ri;S( 3oGnQP=)V1Cª}~_ W 6^6^tkkiOcS~=i"tzCAQ0M WZXFO drR7Z>[irUz.a֚HYt} 0}1GlojuIݻۊfI$Nl"ANiK#S֍+i$Q# %Sסء3_MAѯ}|Uݩ-tԙ"х& &{t2qŨbԲ9]Rm׽֙|X0hQ e mkx]klV@{4gON k]q"{UoV Zٜ{mdt<*j?[ҮO :&]lC64n^ǖŠ֒"bhMꗸka\кU*3K˜ϖ"~-S",6FWcc{8?y-ɗI"ٶ'EpkWڤ= 6ֹ ^+oq˗fMXzX&@t{I].{6u}Qjӻ9ҽn96G]-r҇g׸ > stream GPL Ghostscript 9.27 2020-02-18T23:23:36+01:00 2020-02-18T23:23:36+01:00 Emacs 26.1 (Org mode 9.1.14) Analysis of bivariate binomial data: Twin analysisKlaus Holst & Thomas Scheike endstream endobj 76 0 obj << /Filter /FlateDecode /Length 2256 >> stream xY[8x_'p+w^JhTU+;&i˱vUb5S!3;<xe&W.Ts !h IDT7x<\I ȌKl%x$9\).FU@ݹ"%ۍQɧl1[OfK-lJsE6!p3O3!D1^$f \t,jҮ$uUgؿmnY!TSg)Jj"0@f1GƃEdS@> /~| P}_p8OT8>Uq9̴ΩHgraXӯ~VQזZk1˸Q97w } 0+SBžLu o])a72n&A@`^xbq ݨ9 `̀*T30<ÄX?tg 5CKR9:OdC~yd8"Ҙ嶈VKi媵{9LT;~k.Ϝ϶_su53<>E g2osC+` )Ԅ])o &oL$dlY:koQ @n#~u}y p\$&,VFjgq>0I|9 Պa3+jw1B(s"̑NߙMmV K:$i/=X`**)`̧DvtIh&?Dm(͂,j fK*kS> stream xXwx[՗q$ߐ`^H*P @Rwa-˲lY5-K5{mYWG<HI$$@SFRJ[f_7}]9Ӵ|IgDw -)))mYy"Q^PM6+c6LjNHr %GYF"Ȅ"+Vp5Okr@}$RXwUBfGM7plؾ/DLeHnb9!nDIBP"?]%qR>OH}/񥉃\)_V*˩\+By"eAzyDJe꼔:DeJ 9O&*ԍkQQH+R\I!fLXÙ"O(srE|>@(4Խ(L8R. uR/ȓ9 >ΓJEo%sopP! g[( y?}0G^%^-'͑+6*U-޶LApWҕ,}Fv-K.ڃݴ=h{iYljR>Zm-1:z2Mʹi[hжҶўmRhRiPGGKZ~ v_w$n~;Xx+erecUͿ?u~-\c:w;XޕzCwh9J@Wl=V8Kcz{X_`F+4cj+4=tfc8'v#%˥%tW A!h%3vJ #$qQIBWsRbR\|80cO:)bgLxV,%|#.`!QO' fo´sO|tq&Ʈ2p"SM,7^PV!.WTB"D9a"XV;/VgPwFsNUZc\]ӭeΩqb0ǧe2gWق/Ӱ zz6w T']$qQkz &|FM @M9D;Rx)X(%C6Ǵ+d3i"t^n$vV#D_: J\|wPQs~jQT4*`qX=,Ȁ:Ofbv)kт@J[j-yk:@;à htf)0U7[*8Z#m*k, tw LP{~sA:V\ `@D'䷬_{իT W1Z' 'H4:k\dܻj+EeUa0`R*^Mq08PqdC2<6:~1_"w9v!uг~QE)҇ÜP %ƣxe67B&Ar^!r1A]Ep;Ͼߎ$3AL6T}a1\9.1 x iϣ~ڻ]e<ق U>NnwJ[GRv3X|kiŗf.).VNggn Crّ3p-;/R 2[IC*j*D@fGCXg4;#g'Ge'0s`oǟg5;  m5ʃ+y䂽/q]>{ g*YT578?#Ly9?U{+cX̬J:3toM'{qb6z,%e R3mPfcA'p#:ۨL1W8?)>/r zG a4`^-fۆ#Z/D}_v&y䝜%w5{Zg\a)w AB53W{GQ wEphw7a'- YР)!*@>+t1CxB=K^M@*hhϷ ;iGЉQnm|wulqI FQeQ8ֆqom2&`xB4pA p7neͮ.24h8>||q'J:W;B0̌b3/AMݜsD%bߏ0?+d{Ug蘹^ sRQH҂| ?1Œ{X~܂;zZ=h}}5ƆC"Zm4d״]넿ԾA+#to:Ch!RH/#_DsUeQFtuSQeqk|6ru'Z l.QYEb<[~"&s1j&F +: zx%,Gr,k5f3lJǾW礍uz*|GR*#7 ](̮*K`[)~ZK(&љӘ'_,r萟6X@ylΐ+!0b]06Tu/6`^X9k=SrցZ,jT;~qg+yarA%4(šYxzg8_Ү^ o %^#ThܷCLԦ*`|<]LRjTFQ_$jphs¼ȋl`O}XFϝ*TmfsESKsPG):?oarrjd|Q+pſJ)&o` ~~)@C#_λ-ol%Z]vZmY+ʟW,GVyw٦\ (ǯ}%\=#fHӪXj9he kp~[.jjT\^@rh`S {tphU1Dm ""e*<ٖ֯jaa%RISu\ﲔdRy0g,8W S4t?kP..^akIӦQFKofE؏{)ztS@]j#qx㰭>U7P8U y'y{(_e8E}>߀+ W7Oc4~jGUuCqK\o=`{*.o.X899=R:P4LQÀS%7=yչze/܍VOQY/L/J3C#ƮXUz@S~6Fa$q:b3L_*/%Cl!K*X0>h Z*,9p<}Ƿ`4[UR2[Z\y VELfNz^5;ZG{z_7((bISo\NYT+rxh;x \Ά?o5Eҁ@(;'WIQUS3JԢaظRbWHs z}.78͜ ҆y ց>+lrݾV$m~"1)~x|tR+E^?s@<\(*9{#ٿ:1?>6bk+K<}3=iowd\IZMO,d9,HDҊB#+ɇW~rj9^5AFdqX_\,]n p%z[:j2RFՐgE1\/@+fƩoއ?\~&cz&[m2dvau# B QMw8`KF5JPh iqnHJR `k>-ک^ E6K:"c=CT,C P0>iie_;m*Z 3U:9j(giyj[fQ1O^MeT(jQO;=HPMƗ&BLf+; 8jtr~ۃ!ち 2)޷L^]\6"/tՎ+gr;P]C*QuInс,GR)02R0s4ixٽ,H&nrk?~':r>\F(5=s#iia{UD)ۼp& aO-|?pױ&Q)(F=3 }GmM+zSm/.s(#o쁠5pDt`c׾b S7sl?mymn u[E L wN)XK~*7VYl [%gi1қ\0WAgy&cS@,T`ÕK,.ږ]DE9cF35L%A% 9eu1'|uGjhl,\t~s{Jsp4g::` ;W׉UY-"?r96Gqpi{}7xzv-mINݘ;(5-%a̟▪ T:K2'+3H>0^4E^"yȆV_ԎuOAJ1G,^SMx{]zD1!G9jlϽHAA/ ov Ǯ޽|S̪W] Ti z)gNM$J?[q#uhbe\0 D~b;BӿBfSh:XCR\+ K#RG,fЫmg_~9x\W}ƐVz(g}\c0!Qc2o7;WVm~bƺ#"ex+U Lniltb >HI25FbzMc';Ǥ+Os[+v&?SKcKK∦@Qy ݃sx2>{,iK𭷿K6$"S_ ʬ2fe+%BQA*B89Uo[߽r=p *5&'(P&~Jvi d Z2JKfG|82 'H/V\^ 9Np{j|uU}<`$TC0\xu6-2>L꫽ۉwz?L哲ݼl,~%E)NcdKb`1x = h t?endstream endobj 78 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 960 >> stream xURmL[URlc@gJE#%$]P0mi9{oD$%l6ta(- J2:?.Ld?\,L$wB69s7/MP4M۽ 1,\/( B٩CNZ{@+7^ =˩ oۣ46Kwhn~2蚳]~ %R@mwUcerr[ښ|2\XR5A.ˆ} *~ 7$ / ,H|HA/Wz0@a&x<EpJQ$ "+bnOaW( HyYC@M?*]ʈ@&+bzG ^ <>AX$'DJb2#[ #7tlI͈"6X"C.\M<\<K'(EQ5{j_T ellUH1= kځIz:uˠh`sTa)O_wd&ngo~kʼ`O 돓gwWΞVlrTqog^T\}ʴ6kR@jol}с ]8͟_|;1 sgONΛw\l:8ݛS6|vhttzZ=\L'#tZw%ϿZD5amh8\6gNgu/ʞ$W3Zڙ5-H=W޵?K];\ĶU!jOO7hHV}}5-hjT]vǹ#ΣݴjTKrie]-ZY}z-?O [4̱k<>kP?Z辊SoDcjީ(>6WEW+#fyE (.endstream endobj 79 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6560 >> stream xY XSWھVEm41JRTZ[G+ K@H ;$,!@ pZۺvL]juM2:3}}wp#<#ܼJk[q7i=9z{8Mꔲ&c}O?hv=j'lrֽ:n&n33g͚RHMDED-Z$ K+%Q24|$qbjhX,REEX?`例k7֊eP( 1L* I2x(R ߈J")V(E"B.)bbH!N(Z$QBe*qH%Id<~)D9~J2z?Iuخqk}P}/]^: N ؉ډ &Yw`<φu" fN٭((Ԃ%! "s3sx*mVo2PnP*\|*Lw[KujqȩCo4}ťg:|,zy%SmJ@77:^ij` =#ɝN[-wAKhڴ?fA.{_wdaj $DXǙ?)pK =;8vkx|}n _ QÝ'\~vxBOXNZ$ )|MY_}^} j'iK¾o&Pw=lC` 4>~f-CZAsq?j\@ NdTNFIjCPRyrAeQYEMkOo }w*XmaxsqMq3sE<k'7qhiL|oHGr vFBNFr:53-3;e$nXƑP,;ʆm:p(z/amaQ}y5jf{:tGl= u&P~l\ 9%TZ̯ *%cG>($܄UC75۰sa یm=iRe\ GӿrS'M]fm]+t<$o! b'}΅9z̀Н|1fđ%vQ5$@́2^tG>> [ a1`M)TxGsA2^TJyc_ً?wdB&P0l?̄;8r1[eB6K !Q,1th;8=꣇BԔv&M2g8l}>PO-P$ js`'i7gEW$XmlN.>'d4\Qb@^Rc΁y|wBѱ&q/H1 ggPŖ=&+_hgR]Pz ]D3}llP6f_cx 212.'/:q>3ڻ] Gg~MOJxɓ>͘} B[I=p k} q}@d룱38Q$L2~ݺ]20PSC]| w$~ӫ(h.luN5Si'^1&o)fQ9'kWNFUvx޸ܾ6$ /6W?Iؒu:jF_N]swWQ>A^Y|gR,KWpd@ޱt12upHC\pMV+uH Jۤ/% mv/3yAѼ)M*DOx#C{h/.%Wt^o_TR}촺&!3#?#mDž DAXHpmUSfĩ98c &FHO~A GWؼ61Ikh@OWH)W euvpO=XZw _8Ttu!jT (%'s}{7,cf^KA`'PW FHV,}JקA:H5pW,ZEV\˼,Y\6{yy , JKM<;9ˏe fwEye 8nNkTVeXk\k5B`ښ!وDoV`PUai2b,fl+c ]|a8 aK-{ _xmWk\\VXdvPRbgw"/7179v"^f֖ۂ3..'^7a؟pŃ_0^"d88¤4Xq>@ig_xJ=lVXK68i7#&%l 2.s\T 0?qG9MUV~QT@ =Þ.H,.)+J"6V.ѐ]!Bd^Q|Аi UZ:/7%ej{uS{hQϢK3-9-S l+)~F&Y*̦Ynr<_uq5i1KdmIvp( <ޡC9 h. h+)rrHpj|MZ[]ko=X 8׊҅A+:\ӇQw]!MǺ4R\p-2n .%G ;w9쬝Ak0d<\e h i} M<ݘz|\˫)VPYfi4`H*ÿZ}<*P}UYVDq@ZҪ8jry]Nu~_G|ѼCki2ۙ9<ffZ /, =;=^ea`ؚ/^7r5xwfÉ>zwTE&jv yN\Za&okԶs{? ϩ`DKH\ hI@!gJ@4NU_3P-[H] ͨj4ЧS ч]٭;l74g~U_LR {H;e%UU%p ɫl-obG;zzF<CVNja}mgbT .<,3-(8#bpGlՁFcV;u ЩY$`c֎$i^Xqy/w~%(2/AnޖH,n=%P_6XXTo(8WP 1uJ 6q;D>TT^VC!X} GA3?pHt3 gOV!~';Ws5`cgNqCߧB`4 e8s#l8ʰa Xr(+ӕɧ.Ӎn4X)Z<Nc_GʌRP΁qO ^L~U-CۯH?=[RV_QX ӹAz! 7"0PP\H1 յyQCE)h6(NCP#P0- DF/`,j⟕ʚ,j;|t vyu|}oL~iOnSoA9RU {0XY0V,w&^NFJ^~,sAB҉G݁:-`)[*,e "j(=Nu6MW[AW.\gǺ=_( BA7l"'?k=T#M!GL%Ιܳ"Y1юcLz>OG9E7wﲴ1r~¹>GF0/Lm.(W+Y^q.iK4" RĚӋ5(睭l.l.ٱQqt89?||0o?-Ӥz/[{9e G&5}$ 9Lp ̕"fi^q1]64g*|#u@g!P&M&^Yr줍i{D܋]Mu2`ki%{N Blv]+nJpPy``vX @z~|ݜ@n(N:a5eh49pK|/̩z4H$7  EWS\+rF`bF)J%APvvnĀs`z kpm3甁S|{2hdUܼX̶]6YJiuzajj@dnX@ݟccD N읆&Z绛w.]Xh4,]dYחܾ;~W`BY7:vrmP6(fmf!1 )sV; Y;XٝPł{榝qc#oMfȮszBs>Tqc;7N!kv[vxY[; /rԼe 7Ϫگ{ܧGmO: NCƭc+ 7c'}|eRW-~̛:'lxf:* Xwp2 oDkZ;ۏr ?")Ol iZd[o] s%kXQ}N`-`ƙz$w1_]{$rٌȅo5\MGP8Y@(yZ`.OGf28!fWD O1b 7Rc ͈]ɷ&1ǔT1#{6iڼpw :`,J~ U]> stream xUV TW֮R .VcSK4.hT" 4СFA@[U@FdA܍"cN\b'̜W 2SU{~)(B1"ܰ64d3ZB(.UH );S,O|5G=~kå#(?TcBj͔7ޘs1OG1N$%%`Meϟ?s?]mgli1fC46``m6h2+C-]N^Ȅhc2Ʋ!Xj[RY k1mF:}FC,2dR䁩l!5hgheR6CkFs)-NNO[66%BƓ jڬK2.hKyF2Z8KlL٘-h6CMc`St&KB!Y٧8Ws~ SRLk-7ڬS46,<)V?+MqH1!-`E-V[=:&3@('OYm.EB0*Pk*ޣ`jZAFQeJKP>EQsAeJr˃VP,oțC`ȣơ5ԫ1 v܉u*8)CA$ǸN$0GgF.Iv7:J(:U̓B9 J;cz [ɺ"Yb:_t*o B)/Srj[x< OBx4MG#4 Mz#Q'bMb'/![GCiJrf1G٥ߐ ʪ淁 ɕUd:ٝwӍGwbUJ8E svwFđVYpGtfN*˘Vuq7\Y_բf2)^ mO dqIn\ZΧU _ Bg ٵt)X."5%AѧDe#b䍰-\QCUWoʝnj_2!_0:'lugnsu\Na6dע{卂]T&B=>gƗ|&ig]:m)Z|*w%T@cEnᰬ~6ב&܌oVQw N¾-u)u֒b" էőXF*dk\^w/p2mH: ۈUbPdu.C朸{{ij'nb~KHHcD_-OEKD/^Hp gfǻ4s!I'2Aa!+O2&b2_heHmyiY,Rmzw}-\e)d'+]ɗ:#km" r`qCChY(4ɖVυSIr帋 79sdA9}lT R-[;{Qmg.3{Kj]-+VsYuΥMPVYo.4jSX`⣀ 4B?y@&b9]nhM|XI@K8AnF OJk3ZڮFJ)Xl(.".~;+v^HIg;=kf~UF]{>#=6?C9x; ^DNKvR5D| s31)c& (r>k2IjGbЩplKqachza{?!lasSjRvkv@_VbCJSʡ\AzEd?;F#!B ;,x%z eOw?yv) H~}$}$AiQēiQR`6:p[2H^~#1=ٟ&"/?JS^dYMoQ-%B^<+~lG&B@+Nr1\̪S:t֚R^%O臇ދ-sJ!ݵtepv@+Qz 5bk$b>5H}Ԓ=w5k 7 IhQw/I˺{kN-}~P/V'lK2G@?bCYH=w֕Xl6mpU7l[Bf4A/ɉWRJ^h^m4 Nɑ%>OTP=NW7kPA8Iey#Q%kxB *-:F^r%% UKT APK^%EE~Qɯ v\8U_shSa'0o^eRVfNbߋQ(gjwc_{mf~dlu MyBBq#c>|g|,|<6s>6[ f`$D0sBΛ~Jk7uBڒw:~JUqˢF^EwIuWΟo _-;/1 b?:U9Q|=={3ck"aqGKƪ*Q7ְ}e^^*^zWendstream endobj 81 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 448 >> stream xRAkSAM>[試IR S)q޼^ xW(}6z7}3-g 㜯| )EJwW˴>,6xqR4V&xZw76ZI2Zc^/YX[{ڌ-:}t+(mx~D{yvЅf /)%nA-Rk#3<> H.d<xG?u`YLu2*¼ /u)9#8*ciȑʗ- Jtsr+௩1r<UWʬZ1G4p^]Ixy]?Q{7=ߙ^?9:E4/Fݒendstream endobj 82 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 566 >> stream xMKLQtڡԡ&.KR4ֈj01 mRE*BlZ!%`n1э 1qA\@ea99''99Gq s0g^6quHq߶DDss&rFs\bt:J}3 c@@$A{#jTGZKtTUGNuthGJrLkbjɣrCWj;_ Wr #O!M+n{̈́wg[k^y {#70;š^l~¦'K0 }>g:/Mfd<k5e sxu7|y v]'>M=e0SJ{ޱd`gȚL ٹ\agl Aea\W|mp›85p](BI :[c- HslW0X( R3a b}(nb!endstream endobj 83 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 539 >> stream x%OKkQ7&DŨvr-B[(i kDVؤ83qf0d6NN|tH@Rw>{8|wAvw,51Q 5c]<,v{},?c}}")\ 9פ\VA!K&ox4DyNeJ,ǧGBb&)UUU#i^ܝa,zɜEEAAO> stream x}}le6^Nc;:`QA!Eqm^u{Cnco] +k8Ȼ/Q00[L4F0sau?O^>(2. AQ4@om:)S*T3YuJLntYȔWg)22Ɲ94ǩ),dRJmAc"z~FGV6mH+$+1[hؙHq1<.H|ƭZ!yV{|D2϶"…#H,o]hRQ4iZ9:W, 8 iT Dr"2q wp+O0)c%3ոeDY5oW3-&DqÚ7p E 7>CYZifMTɉH)͔фSRO c>I+iRMmE2SgFG;zٱ(%7e4rWFR$NЄh&I A&F+!(@^ԇ2Q84LJ5}rFeO -T{Wku㉓`gM'\Zyb9k1xjR'tb@z"'][ V`v  iz6Q=}3' 󳆡;_LN׶įA~_W",2cJ2 /1}mӐ=lD&a[~ޢ-9YnUxa?32eGGpt0i;ҷ9q .cX< { .EyS[4>=4rRNXyqwsKmSvW]); x`ؓy$n,QWuFG79eG]pK+tN/|mR_mFpC[T8*T58>Av 'yNFa񝍛sDyEo[RQv>yy! +V~Wr\wp2,Y<Ǿ?wkq1\2WuỺL> ?IFkv;Se,} WO>z.p庥j>uUŻ9hi&=8GÇ|1Qs-\bwTuZ q8D[Z,!hLP,͊B0sҍɺIM+322n45g< oendstream endobj 85 0 obj << /Filter /FlateDecode /Length 3393 >> stream xZ[o6oP]L>6@M8}%$:"ߞp.PmPJs9ߜaYhYܿw_]wq.U8˫ۅ!ZbKB,^)\V>Pʋao?*΋}H?% Vta}ZU O,DqfUY!㥵aV amwxn{`4"+S%'2տ͎cKQb0vQ~un^ RUҮU`ey(27,^7OQEN TJ!-H=kp#JZq>WH~ӂXpImX~N }bveby7_:Pw_aDž6 %q xC=ow-T9/ U["̰3x;X+U . [B8k@Ɩڕ bWnڍ D=8+QX-u3N5G x\ "a B3#,^mCkw(vsg?cx} M,\0Nc3H@O!RFׅ0F"HOպ*%|[1犷@Ľ_}2,1bh*^gJN[@T,o:@J_*&; DDTS}%AR0DKz|_ &i;qR8+9RJ,|V‰0X꜇@ 1U"-%e!Z1uΤ+%BTRJwRQZg7'V/1ezR579aG-yIhļV`zt*qNkp$$o)KB!p4B~+]s`yOH1  l/pj[r>q'h&o`JɧןjXHXqh(owG[c{88@FfnMW!k ;lFJ+x)Ψmb/Vgr}kͱZbm7ãCVfD! )>#*9T5}ن&4*I)@: ?k~jov *D&wJiiRa-W$QU)~hc NY1o2A{d BZ \xCi_m\y`S37k8'[ntϜhEcg`4V4]AE0 mC$<`*AÄiLvCCنgRϠ;փMs~C*׍Yr^8Y">B_L Fvh|?ɊǾ;t]25{hZ MGHqk9c?z()De %)M˛뷡G\òk@56דAޡxLZjg7&2OTwh+ F Iۡ#m`ݣ "h:.471 R)< Z靴u jZHDE41.@9& njH&E~٤ `?|޿ ɵo5pxesx!֤o *֐B '*' c3 E]sYA|"1/$^w\OP|jNVƏ| =HvrDz,pI%T%SrjkL'%Ly:)4||ZקF@$ 27`0Ƀ4x h 4XL4}'3P8³[&u-TJ9{eOh+HЦEL$i9)!|sZ_ H@:"! ٘Аeh>g~yqQUVHga*% MQÀTEAWt 8_u>y}L, Am%_!Fr^v=!|s.ǧ.}s8tVbޒ()KA'׳$<^] hW_:K}_2c)/%qifL&1cY,? M1P| =Oγ.A8ٓV급,pٱ)u5ݝ1:)[Xiz\h_LZ+n9ݼ0 s%#,%bɩM}r!!g[tԒgr* -&,r3zr]`>O Q/t(ѼO=Q{':cqHY#bb,4}" I8,%|{礼 $?$%t2 8J &;?BjrPWDjc:>{lPΦ tʆŒz>`D0!>z mTfy!GNJ .sǃ~Clri=c3dž#]cu3\EKL^2hinMy7XdE݇8v?^BK9 fN3$(F( ׃izc(u(cdRvbTtLC4I0zg;~lXwM5~Jzy :~\$LH3w`j]<ѩӉF܉WuܿZ$ K}M<3:7;>""^}@)M\,&( iVV Cn$Hc(Ѕqr/V͕Zk5`}49|45.@A"Ceczʻ~8ݦ>S_z M94!sFXE)寃XHvGYl\_0 @>^qy"զm<:V"H2!;?#MGMǔm{G0%CnV6>wfH;hR ޺/xxf8 :$~L蕻}kn ˃]*Qq^rD4\b0~Rw \Q嚻m!mzsAS{82{?eք<۷çendstream endobj 86 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 840 >> stream x}Q]hWhk`͒&\Kݰ}!ц6]-AKggwaWibdgV6D6yвj )U-})JE*|΋wބs}眏z8w$y#d;FWkxmz]&Ï#0G4?ݺ hl[~a-fVF$9UΝ8&9=-@2>CZj4u psxWn+=FKh{%+8~kV^(iNE:S* jw.WoH7n+[l 1z?}%<۫+пO^u´w $- tdj_|fI ~̖{=&)=J3dM 遨?)]foSO Jsfln7r=?+ !HɪMn H[o?EZW%߀kyY__+EO||!zCs^:XPUZqMTHўZ yQs;gχïryJendstream endobj 87 0 obj << /Filter /FlateDecode /Length 3606 >> stream x[ےMq^ z hN2v9\KNb8nfQ@Qڝu\j(>h0)r4)ӿɪ)&nrbYl&D'*W}M09CxN&}VNgI.tH^ OS (;i?*γ~H?%iQ? ^{3"\0"/в",;^v2Ímx tNX*ۃXN=;.EAMu_-<(d;> cicœja)lklJм;Y1!L3%#{9cbj-0E/noDL 59Nfp^g0NrN1R`}^Z BDvuΊxVTPY^HtzE"baKs R̄Rb~ Gđ v~0\ Ds(]K &#D0zLJX4̴=k R; 8P;ǃ[cTn/$):@pk(̰!H)P}|xiYo@vR)g8'St2WM˓".8$6COx!&ЂG[Dθ!b`Q:BE&#׉Pť2f' +@ ~m"%9#KhEej>\B]KC 9 #/7:#dH$gZyIMb3"#EμpM ynh.reT8;iw6MȲ XF@Oe*ŀ*@vS A%//D~5}]b` ڐVϩN.7x|ܦM;Aٴ&cD!TԔc)vs1ϔ5Tj(v~/.0FB`oFᵪvUs놳YK-H\ /,+xy^:O\!LyimږKp\+ ,ߝ2MM4dJiF#˚&6v ӆ2ū4,y~8dX2EhU5(/O,. s-cQxku3۱hǯ FPGnL AǛa ̵8Ap˚^HdhB{v!1U=`aĺ>ekQuVuQ!$,W]XT,5m08##X^h JWRS/\hh+@(}gBXx]oX?7S]Lf;Zԯ7iO;=XgH[@m&$)d {Dė nq •u7*h A%S[:id8 FT4x(A4I)v QTL ]̬7-~8r̹K T Ao +6$Mq``ػW|t,㏌H`{pRvU„ bʀϱ 0*.SLJ@[R0>Q- ZqLN׍07Й.<>*x;qm*z)yכa}j;u7Tx߹ nKj6]9|>ÅU>0c6u1wo@:|t})JrK(K)" D`F?HJgoޖ 2 taq&H\o+_!_քLs -NTCؔ.~L=HYtS*BPҥdǶ#U΅e0';>u۹$.^D̺7MQ]カ\PXF۱KV]%dq$E`(wc CetpCI c+ZhO!_:G(.ԥҖ,ƼOӅ V 8)mY~s˨bCc^-(f7dgƺ+?Q R8wDzVK帒q0 g cA[]܍tWM7\"Dә WO6.}g&AD! 2%EPaNHe0F{=KYVg8P.(Șn Lrܻ=5-6y{>29HD}Qbߺxο-#c en\[/_(`*6P`KHv>Ny.+J9|c\Z/10`yԑʦ@mjb>^ e;~mu,Pm7PFd[/|Y1Tƽ $v6mpʳ=ҕ^RbձAz'ۜF"S9BhErb,7$%?e˰Ƌ//k`"I35 X2Z8)n䝸'X jb .BHO: CpK.8i֦M{Ai0|cݯR8n-8te0/xukuwkIkLXwMsú/h$ű˞,8L_;p+ֽl3oC:endstream endobj 88 0 obj << /Filter /FlateDecode /Length 2460 >> stream xYm۸+*H](k/EflqJli#iwp3(Rwa?Xy慜yC&4Jo\z-MHÂcrY_.4bYd4E|xCx)`i%If,\/sR*2ؑｴi*ʯƂRjxIJsn-ed{5ja> (La;:Wᡃ\@_dG :=ngەL8Zði7!;kt |݌@G a BD8c䞠%l, 㞳~wP7xɊŒJ/.TMݔ['eW(./<;3F4DʢWog{Ŋ?K[;umϦIauSfmB - ghFI\l,y[r<Jݻ7 c{k(>$ɝE @A7-FMUYdv]%娽 T.P3 1֕.6ZWޙ=7*l$FmBp~` SAI!\ \? ]amlʡh!GzW ѺU2VLd3U Usn %pW7~ L*rHr8&k2Ҍ#<^ (f<@9i/mQ`yD@TiT}(#׽Ĉ7B6-Y$S rU/&8f&Y YE'P ^2vO)6?̐#R2zOȧ)Ȋ,Qp$ʦk -$h L󛂊$+r8YDb#f<7 )g.Ba 6Ҷ+'١XsHy"$& tD^F& =c# c?f~Bd=J%[x§>L,0 |9HbP{b%cTj ՊC5 #ݚEEq$4Kzd M|V߬z=|qnY_GH.f>6L@ک"͋)vQ3ReIȵP Oϩ@ڕ._;h"ٵ-nj hCA5$$آF6U[V7ɸ:̸4)ns6Cm3`S-؜q6io& m} SA%{rRq[C-a}-- f:rhgasfȠٙ0- k&6M%`na:QM2had.[fB;Of;c d?y ~iٞm*gMlv']Lp.ܪJ*}Y29N ƽY(wKב_64wh=M{7u]XV֥ às:hF)׍ZCA炔NGj [Pt{706 Ʃ(Kdʢ؆gw^1zD?;SKԙijek5,C"cq@<#J!=aԻrFS9M;T75NsA*O O(wG'VxH5wRQILeTѬ&xEQr# OtrMi0#R>eսv mU[N h|dde~(;5sj{!9O%IC#STrg]}BLc~%:FiZk~,Eؤ5 u+4qG(У }L)KII|f HGGᮺv.(f  17DwYb7 Wy9@Mi'xpPH%\[ H=<$ /Bq8=/ &fe:#$fp /zh lC.?B ~YQL J.?#T"i$r{q|RCdFv#QfdqTRrȏӞ,̧[arLendstream endobj 89 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7048 >> stream xXXT>p.'GY9X **ԥ- 0 YzQDA+Xbq1jL)ywɽ9;;WƂ@YXX _<;"--q8v8NĎkQ=K`c'}o-Me8%x+!8$:'vYoϘA~/ui?8RkifL[H [w[mfV-;o]~ˆM7E_d}YnQ=c<6xoqKKފv̛?a&/\4ukO1 3w&P멉jzL9SSMTj3rQS[){j@͠S˨j9&EޢVQjKޡy5AYSKJ8j$5dM(GC +@jL SCa5ZJm ,X"wSK7Vrڂ.hf*WnX:hݠ2{f ms?`u >j¨QGb&+=;1vcΏ8T~68O8f+ͱlk_ل e `({FZ4A1k E<$V$G$ @1( E~~ͨD.iF--!(HzdYVA!/)`{p0KEqFCg)sCsmS礳^z!(wm',ᑔijכK=taFT&ŝٽטXhCgOFlOʦMTi3EgPĂb,,M;}\}^%HZw4D@0 ڹ]읯*j|aC0Y˟Jf: zK``茟0SP%=T 2G;$^Ou=8<ž&&4W}tћ[\f){wQla3=\bVuEa[+4XܽlR!bi7?ȑ%d&Û{f9ק;f18g-{k汔e YA f*Gt0@g}SEQlSh]^ȩbZ~|QQ_ivVfxZBj:^I>,3T; h;-QO+S9 fKٔ8RX\ȟ󻈪Hy-a=`O:6=؉60JHvFzİg ;?[#Ɨ {j_܇%Q))1~Bobx ^m`#MUw*<)k[S " ^zH`JML Y=;D>f)P+HKHQ뫠h:1p)g$uW>!)I]%[1m7O^b/=>NC37grP[/Y -ƺ(*~5>L(_{M#8l,vBeJYԋ1KcdK-=<>5 y'6\_kuɪQҶ%|mH&ebD,2lb04-rvmVtz}\gҁie^Hm d;m @/*e|?O^QdҮo5YD/hK@_6e G:zPE5-{xKﯹ}0 -hl,>ţ|FU)Gňf lkw@KbPݑ~zLcU`(3a>c6hqBM9MH`aXjQꭕ_81[a}<.5fG0+L[)C c\/[:^baS'Faت I"zl`jTc`/%aQ)5;pȹ(zGnxCiGޭ>F 1v᱄!JDzTi6qSHVڔR& 3NˊLr3ȇf֤!CK J/<Q@LHdtV{Ek<7F%+[X*s1ID?J“]/s~v_yFfDYA1ii30t <-7]z7 ~M ByQ!mhKt$ C rg#6Mjb6Ј4_3YS=5Ҝ8x *@9Ь)dz/Y='~Ф-|pýQ}`eu(8RxW,<7z!íg ̿@i!BCf`V`SGÀ}ڃQ1ϱ-ή V9{ݼ|nfsiuv6o23}{2iy6#(1g(QJD)ziu(jiG j@2vUSC3f&I^:/@{הw1II|Iٟtej+`6~caE0tgCT;C`=84Q~I6"mۢD EuɄs+!.^:Xx G*Ƃh9b Bk&3'Pn3M wN3&d0Ȍ_.Tn(;`P{{QM6q=¯X*(G3I{n>y,,p.n'gّ+*̿z*lj|%X 8_q"X,ZsÚVɹڭt"P@BG88M}跁Z,>%{@Ҍ ;n:r͢x WQ(C#qF96 D>>-$C>i>!w[ pN?pv5@YP?4ϔ~' ܉_12Jv/Vq͊@"0N\WVT: h!C 3ZyT9ȋ<9}usBjQa 1)>-&ohlςd۾[1Gl.Eǖe;7,)!Ϭ̬0+54Qm]"~I>9e)%L³?g b<;7ЂMw^b<&"$w(L@ZǖQFi%!ddleq1Gά0OnXCTGa_x28ff`j1k-fʤoVhZN(vy ;ow?+<ꅼ KU$t7G[gNuruﻸRq/zLW㏏ynWMa6\ )E"*D/&;R2|8~r^nY&֡Gm8lqOгNY#A0RoxYv9umŞ+ C[~q|ԡ`mfRB˦p7hT: N3*YD){G ÷8F7^_b1["bXzw7oڌ줚XLNJMڅӗ]q !m8ƅʄ=iّ6$#W#ܻ M(& edW\dh4,mzIsa$,kxX ` Óbfu$鳛7?'Uf 4~L≠$*Ow+=gUny9*W%#H|=t1n[i4+3CsN=SpYَg'zWbtJexua.swULA;y֒nɼ=9{r WH#\?! gglIh'8ΊNɅBU(c&{o}TmPhx.0~I|˕ǕGūɋS*Q JM,)% ')_ZPGOZXSyo*_"g86tp5=LL.0đXIGHķ5yYcB?4V^ Wꀴ];!S<0mO.֒En٫~IjWIcPhkYނl뗈{bź+wZ%ݛE~Eg C~C&toߤZ-Hf?RSJkwPH+JNKMK@ {4"z_x,G8 |Ƴ70XX-\\͛7.ͱL|N)"RawACc KJ70HvXZk~ { ?;3lfz'=hdYuɡ1_λGoKnz3͂0ѣ0uN;m| 'o߾M(ŇuyyӇݺݻeU_OJ8ChO_$p3`hYxdʇ/Ż5YHeiJpO5$2<4֗+K؏d(VS5+sPIH>@-o&.C[@u*7͚ ,eP>600J)*l~9q]ȧ0 |o8z@+XY?ݻУ'V_"g~l;K{}[<3}JjZ)jecu+1RՉ~(Hųw;hgÛ05ayyZT4D)TMSab,%UTPrL܆]%iwV zq}c<ÎOńS$ lA5t-XvwuN~F#)/qw=/n㸌g_o:s9VUYK?IHCʢ?[reg{~K\9um?|ngTDJrtݱʺPsO;WT(R̍$!]CU'VXi(OeQeQi{<{$Q )=lJ3 33m*+jyӝw,1Q{$yP P[QE'ɑ K>U( 8D9+:84:%?/KͣdkRZB fb`g0/HpƤ<xyTTl89MQx%nūSH) DZR <酹T%{9ϡļԽ::?|xY(&W(.<| [ *KkE2(| F'Ũs RNyǢJWuhMYjȌ0t[ $JсDt$l~P[bg(.933>cS60V e\| ӳHL UjS_7Oڜ28$:@_LnjUhqL]uO憸,“ꢆ=Lևӟ`:X)-LnaA Fw(< U,HɿmX2_$n;#B͒?s{۱;ۿDaFaQ()8/(ʾpI?dxx^;T4:m:mf+2!?iydw,7)&? &L/ODH-STU ye2]9jR<UĖńeW454))> stream xW TSW1psT$F{isZ'ԪXyG$ aH!aތa "Zk[S5V[m=w[$ X!+so-Q"#OOEɫvvYMF #ʼn8R(}a?>$wbpx}= F(HAw"$*,`mԩ3&O&rs7P pc 5y6NGM!w[mݚū׸-YnS%EQ+l^8,\PO?`m`ީӦψ}s?{-EQoR^Jj4MRk:j=HSfjM->PKe6IPΔJmĔ=ES#)O (Gj 5D $Oa~Se^/jjw~}3=>'a1ݿ ;phvtt pm 0(f7gCDC*<9T#=9T2tMC/$eP0F-jBB%4l 5xCBUEkC pOrHDCs r Cɫ]Gkex]$-hJ!&P{'0V娃4B1 6|=-{XՆ<:FAt[l+]@,!orZӭ,s s89GyQY, r3a'dCvO!'vQ6ƣ?z ,Ƿ hl'Tրf{hޯN\VX-$%PJ 1NZ< x)^?hƣI<:tEsl#:؟>;`u`M{E=A܂a=/u {M"z|dTӌHTGeO%P-2uetK/wmSn$m|+,^ *-y^_Q>Q:dhhve/6REVȗFÿCor̬Žn[{gkX-)x2gAҎX9K '={~,vFh_Gzr[b `LiRVGK9@TO4#;1kG&U5rLARȁ=|Ql!ʲnP_+y<-؆e^[=dGβhc>3@f(-xYKw-T&%~!qvbB?!WM]W ·M0%(!TsS%Zi.)66䲟5?uy4X&|D㙰dӨSTo_U0 Chx]ڒVzêg,&la-=vY/KIƯ-A}6mDNKߝ0XT%,zۭcf|ĭ^6)$F )›M{ш}C\JpZ(<\?i(tb![%k4|BoGzͧ}ڳɥr Z*<'9I7?k;H\Af~YgtSz1LEg+3CC]j{I)3R8-40Fhe,)m96dC0_ܳóSgyW=ނC$52ªJJU3Җ[!yʝ-۟GN齗K${J/iHFO)^9[-c" +[E;L#{<;i&U%s薣`+|?`""+3h_aRL?p_jVcf b&RcsbJT)،'($IgB);J/|de !1!@,祐IHKzjV,?lm7XjpIm ˏF۴̵7rh  ;57ULoҌ9*yPm~GCˊ 33K7o`1iF5\қtv3ҙWqTvF~8Ox^\DVSv#o[=#ԋt4q{L,AS^Rw[1~ޒX%Wk#!od^OxSqV>,~*, 5u,cajbJ"]#ʢ+klսt']n$"x7XXȕmTQ5NTT敇ogQKWlyj>~<ͭPnܹBZ0U,?)6/ވ[-7BkHK꟎-+ΠK+I!t10妒j ڛoڄb21,~F?(@6Ok : n7YH]|r̿,'@giˠ4>Go.v"~[|Չ÷ڏ|d&p/`M!wW\î=I&/ʫy9D,F/U'˞l>3I*&?!/C.3`FVywAs"{){_eK+BbھkHE]^|V]H mZbjyFm:t0vXcj\ZMd\v\yNr,ј33 aijVhͭOSkh3H/j*);9ԡ`M$b~lIwB?IúgyyZy$nTxCYpPr0'ё~mP!uv 9J Ok6 "Ɖѿd|v#i33$Uh}JT"mITEgksDKv~JMl5'Y{0^.6/ӯLnb@yHP)9a4^p}d> stream xYkܶq~uaa7eZ-RԎ '3Yzl${I4HQ쇡(ux_)& j[wt_ rT˿—$o$K*$d2ZGyNKdENSAeaDWqLJT CN,Vĵ;?ɶSxTlDS"tiU$T>5V$aZN\D430$00O~>u;]+Lz0,+گx?5F u_׃F aBDpf8^Y20,a]8S)N Lu-f"=ĺ(<{/55muHT]~A'E0A-图iר3ЕubSMؑ|o“MUQ^g+`!j"/pʑs8c-WF6KO/ݽO\y1 DoMWl+$ ex3bD)E Vdf 'wE4/O:\sYHjAb'R}ɓT fV0ŒeVRgMab~0NX}E8zE6{Dc.A+f{nY̆mEP~P,Cp$^x$hs:ﻨ5nǏfUQOKNe UL[S9J HJ25بSj$Y,?XȕG~XQՃ d_p`Hv`ZG}]pfk-S)JU?~>W]J >$.2?zCч5z^tgɦ,o#c:yt[ HHΟ 3dA@}M8p1nM2޵퐩 b f4z (ZQgE֘+rDGmSݕ|]QŴ9(]Bpp:TYD*RHhI"/j`R3yI.B3+(ON/yfXqE@>@[qk"Gp1ɬe83&kp@]&V3{Q֜zkl%#WKK2>ˢ? [PA)^%z(ߌi8M}Sw%+ћ䭽ǣl&{cJ @Ȗ\){TKZưVT[-l_^9.)Z,S XgŻqs:I֓;TRPfTS5V $w\/%SYFw+;.D˦롢Q{>i`hGyˢg{D/ 0{\[ Efm[7KXG[E4$N bFP4N3֝Wѫ-&1UoҸF[;Ì_/D`Ab:ʳ͛ A#+ sFvKfzkkBk7M6΢ HTyPfb\9cq렢 B#( AԵѺ=[< ,`-WʃJ-N_:A_"eT|Lz}f&w MpMNY]F>p^(d`^#xjՙNߓ#m}p6 ${8lʨoux=ĕ2n̻Pͮ1~J  oC 6t"Pa; MPz nvV=45P{)Vļ{Htq)pW xG竄qGѾ*puӛ48>݈bRhՄgUx>5`~}x-c@ǧxy ʱax6//#Wt֬m2 6MuVۨ탂9>ps,@[Ni'#5#$u(4ЦpxTy+)SNO7MP!K_F+4hDVc?"BblG9~5'؟h@:[{ꋢM2,Vm \tzg(z]S@OuX.N뛩&cXI3>L{DAW@#Hb dT꾍C=@qmu_~ݕ !I)VRF;i[׏;s;^ŧ5s7c:3]Hi0.h4E|0ͰT t%-pfPz:nn}Àx/i7tE@;"N0!E$ r~/ބendstream endobj 92 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4058 >> stream xWyTS?sQˇrhmBB/bCHևj \,VlsAǪ].|Fh)V6⬚(Q;v>ՐwUL(~p[e@SFݿ5߈d?`ngI4"U8& 瑪_C'hJC #M^B鬚DNnF:{l6:})^Z+ i`PK 1xLњ6"=TU&.hTC "Z>l;y xxEDoꠐ*W6օgA!P$+Głx.Wڡw jU(2 w n~$quAPJe~ aRH:;S^l A~?62,AT5.'$5&C#ٲ{}Vd,hi|bR"P*yÑh Bs`*aVW_VAq&*ۛKS:[dRA^ sx 5[EԈEA823ugI4qw<ԅeɜ@^m7VVk,+Թ&j }qAk[G>6JugwgEm6z F( ˕rb gpA)"NNj_FG=Լku]PEjkbj`p3@;:Ú:^r*dMU y 3$b*:+f3ɉ#V:ty\MԃDSz'ZŪ]2dMvv4UG!*Lt,+GŽ,9{m.c6%3ԇj/V~@F@|#HG{Mf(>^0,v èag\}hbo`Cي\Elܫz&\?ޚcEQ(Yѧ-@tyqC@]LnOZ&7pGll(fԤ+-d@PJKn|v#(Ak{^hZ$ӶؾCѤ[(q=,_\,)כL%"puV??nP"*A9w:NEqsLl 3M膳Z:nDc_=@*󸍳3c9Ta *[԰(X P?Fc$%/bMaE|\йb5,ov8J Ӕ&LGY%LmE |2[:nv3|C*=p=x`LVqԥkY؆`f?W\=܂is=TW !9cGא >nzhA4&߼U4Xu?%aߞ+;{"Je~j ԧm%;_y1c=v Cз_El'3M,[$zuL*)&/>B-:n/QRI DW?:qENW/oz6qJhḾ{ԃ^Өw5q*WF:'Qu"b8zz7j_x TbU ʆ|$Ї\nC/putDiYO3])ľihMV5\a|Ʌj&$ukf{S>F T]R=bmzA]%h#_R(.u+FO迭>Apc\nZjnv;iqTî,5 ,Ӂb+̶E\:z7IY&SLѽdj#6 . "Q^F:"}s˗j fgB8C$%ŧd8H\Bmj)҃ 2SI l<*%8GW6B-|"|TU.dT3gt&!k)zX[mM{{ҔUc=^E",RuZiIQTQ\ڕު3wW<::"G)k<US^\PZaȂ ıYkά:5xD|0op'jnӉh`ʺk8z'[ ޱ5a!/TU~ ']pǕ5x͸v HsтYkd qtwC7>(aD^0<ԩrY_!̈́np38n?f0d8mh)_Ss[HFՠ Y6pԹpL͌B(z/=>Nt6ed5u/qT::}Ht0M<:Ns;"3^IsߓTi/4 Aw&]R3Aߓa$roqq;ہj}[$lkTg\*}9RZc3z5̍jxm..BUVfQ }-%5fZ2CGГ'ĉNSjqڦNh,g: FRendstream endobj 93 0 obj << /Filter /FlateDecode /Length 2300 >> stream xY]ܶ8Bp]jv-(Z$qPo393-i^?DiY;~X{FqKv+>F1%6pe4BG7+C 4MľT<)1]=Rjr[iMQr(a_eL:ٻX |6f׊QƵnͽ\(҅ՠ|NC K԰cXC.c5K0oW݊O}h_coj[Tbn\1?6R]6<`Ng)4n{PS(ZPJmMC'>UW/'>9p:Xm4L V!&.wUdW 'RE*Rm($O"j L[&E] qi$ZA&GGdT=P?Pɴ~ۍ! w=C'LHY1QmYݩ{ACMvkxC xvbc_U?(g>#_=4# _}8tkϗzpI14+ү|סK7o(IW6863.SH1y&\4!EC_8~Ҭ34\U K|e~JeòwyC~}/sb021Amω1wᄺ۴Ϻwoj.F5< gH'WZَ aɓ.jw-S[[Ze^n$X❿ _}OM;:C=|Ɩ;t}jۛ nOoOিYR+ѶJ[UdDm~h^%ήQ6mWnUemະwFSPgnL 0p~z?2:]%C/ +2! +ʄorxA1>= DžRFKŦ&3 åaHS`0tda`SULϣRw 5| ~ft^nE)0޾][|qGUW5nExgG \0$?up \W鮐pϝ#UiWS{eRK"b O]ϔ %wt%ZƄzیOT$},$LGj/hʗendstream endobj 94 0 obj << /Filter /FlateDecode /Length 2295 >> stream xY[oFQvQkR/m(vtR硿}3$EґMb8"g}eί2o&峛r"ɯ>f|dG\veVf>:ә\pm3VWSc{1:VͣevY a؛n(|Ov?Yt,JeYDa) Yp}6D':Bh1<}̧/IjW}<6^ jHkޔޠm#(TynU)L$Ob`1VUOpIr"} ̈n WX'2CIdi9G&e&}QeqCKfOI7mYWgϴG:8_-NW)%kVv pwW۷5/^`E^̎5=tmQ|o32W5p#ӣb*F># \Z ~lw_=%ܛLxÓe`9{N[l3^#>zt #b>~xλ XAA2).|*(B(#X>J) M,~H[ Wy%0|otԬnQSLQ<_/ϫ궅l8@J((&2 ,4#xIjB8+:&.5C-F[SǢORP;iO:qZ)FT0]Lɽ!6 -:4%N[̈́DUIEe_:0l8IQ\O p[uf I:3:;Uz+`G.x%_w;kvͫ LyYLr36Ge<*)κZBV)dB1^al*GzD"1ejQWۛvgXoh_4kNj@' mZQXNKP|*,UN&DMvQ @E[4q_53lww+Wz X4"?X{%-D)MICm#<ƲE\/4א,u6Z Pr<  i4z[,(4v4³b#OAD-:gTTj^| r l& ]^VlW(+@6֑$.!uaE8@AmNgP) hت]$A n}]eE&9Qy]ܶ-ҫ}5h?b4\ݏJJS~h%@.w_$G]qPI {Qzv҇R=Q;SAyjF#:(Jr)MbS-rY~3[oF2F`H쌬zJ4G$vE#GSAMp4PfY^#"V$ y?D7\UN#V->y5Z!VBu2[) + L!i S9;`xWqz<Fb@nhSz1XvEU͛6uYW1ܬ7׬vmP]OB'qN5E*րhV ;O `2ZmeY.n"m=X4S5*"b%n]feo%>ueE5?6)%S. nn]6+41.aN5T8wCvOkJC~ۻGJtkBV7ܚ Gt]TbB^ˍ%b^r"o (nF'iƨDOi m^;dJ&82ZhDU0tQ[{<=a)<ot0k׻iW }FoLCEtl1NL/e M0|_sj&ކ4` (育Pш"h7^Ӧt3c~o hZS$ESp F JÌ#Ŭ?܌*lSV@s [ZTxq40BàU}˻a;0NtXXu 7yr^q 8/Dendstream endobj 95 0 obj << /Filter /FlateDecode /Length 2570 >> stream xY[o_At_C6Nn@}%V+Q^T ?^ڪhsޮݷuRgwe9U&H!)R4%Xkh6*}z<'1Dk!D// 7.M($(n*9E~@H)(J3m]8ˣ#*#ꛋidIdocT}kg|9[-2Bϝ4 ]]P.Lh>F2mxS<#r6:P/Yߋǜ s|I6ӊp|SԕW39:8ДO2~ixXǮ㹁*004$9 p"7|(@pR\bS$819X ü<_~} UqfcYΎ:~hM;~?ScA&26=ީ]m`ŔD`N1i6}*ˑz˔uxi˦]WWrWO%im9<MYjT3&ENf뢍nC{Y'P rۀD wݖjkῢ ^o"De_{]zAە]fecz5y9;Ò7Vh42M"é6>hs&jn"9^ )Wb_-/})H~ Mϥf)sIMyD.wA^C\.3,h%o2CgIߢl}D7-WL*aO{+bs׬CBr8 a'"%C.LJ`3u OEȘNj=·:oTߟ;9dvp(ΝηVU+ h'-Ъ}U}".$hfjRtlBvb|O 1|6)AV@vᦤ_cdu:|y4*`Yf4)f݆{@! h#̣ H?ty~IA^”Nv)]_tBk&]s!M 8r\l]}[@7#[o|ɟ+Bcg$CBoD?0Sx~\+x8ĺ/ D(հ./!D݁Wi, p8vPCwGTPf\nщS(;aT社EJ vZO}72SG}Œ1Ƨ c aGz \^":(d=.3nÝ >۵&ʾ:ƒ|ݔm5ƼB`%+JR 0L8Y^ۙ< "9y9tr>+ۺX^\/,vlghlN؏Q4Y=[|2 r> `0(.0Z?C  7s>GoJDFp"ZWgT `ӈx?dƻ`$@Ԍ?5*Z1Cӫ҉_:JNTK' Mȶ4ztD~$xʠɍњ47R{s>ܫ,iHbLt5˙] l㉺0# ESVM1].52b[\7s,L7ƏŏfTOГAD# Lrm߳~mʧhnﶼ1lٜ ;d2-9?y+c/׈ 28@[VDfC\N7x.dd{[X6 m3 GuVRJr6Qۢe67vqeydM^{s.d> stream xXr+PJ3%¸x]II+[Y@$$1CvE=M)Nb/7.}d)%.6&&Yr=mBe,6OsL\4j|H W:US7,$䬶l;HLt=xRjl>JB)H(d,r8>4ՖәҌ4EDՃl5hߧaۂYN*ׁ bK<N={̧Ňa&|9a?N8LN2H|]Ɖzm(By$o<&ox)e)"掹1ܓ|$ $y,@BE_`. HU]ull[nʵbF4\a|nH}ՉiXZ名|t!ŢuOU_DഈZ׫zuuL7/TTD#:inIIH!Jbr5AmϽ#$0B^ ,&K~f'QrT i|bgp塮'EbQNmG. {“_wE8ڑ446=pL0oA{[Z p_HQ*^zHdcg/O1}8Ƥ G(K穼$4-oɟ^1"j*㏴ oePki{k),a,|Ok&}WF!01rkLߔX6{TBьOz_Z7<"5 Cux~E5 Lb^L:Dj2ahP\J-x*m@/TMJ$:&]) Y!( в9,zT vf^9Q1*3} [?PARlK"F ׺"۬M5f>l0]yZ0mxdÃ5=|`:.u.@g?ݤ .>qրwT[ wҭd)GOYa,_9Po> stream xYmQH]dٞ6>4"$~I;<_;|[]󋔢03>;3%a' uW6g,2eYmo0SoIWv!OT XoLksqL\RƴG7 CQqZ Mvܫv1E.hٻT xmmm5OZФ渃C;0gbŶ èwtߋ""Y*zFIyx.ZɘkgMkueg(@9qn~ι#r&8,|1a`;O~P&≥2j*Bz^*c,V7X $y(FV (  sKdyssy)\)Y"s:F->yX8.~+Wj)j1dp85҆"8 E ™0M"lU_v#}SDMYImzA8T2R(+irFkmѴvYu]*iI=Rx7Aʸ7"_V#@-wjxwxj?T"UB)l6%yyLAK0%Jpn@"r!p»?#.h­x&wVpF〱lc1ˬ"k ]2,<lM2==rxf!D@Ganpiˮ)ƴPN ,3 "FD$Wd+3Mɼw!S$p$Hk0HsVl=u`N*RNxΌZs>X(FNhG5ŞfKƪ[}.h+ !:n3._ݶ,ɯUSOEQ4MQ^RF EU7/1Mxd&:t?!2MRuq Wy" .9myJ@7 EF exe>{EŒzJ5/A,2{#%qo$ (\_^z* Y.aGܗ磉m^nZQԣr͸qT)k WyWF0]Qր4OaئHidkadxFc>bEle~mV*Gu1u!y,#00oBpdqSSt[m܏7HQ]\\UNGg@&IOR8&RRxIϮfK|7N"v&-d #ُ$p<d298b 'dT? Č=Wf@5y  s\4]*os|!c=%Ɓ_U2=[gMvX6&SnсG# &8QkUk7z]O VCpvm9Lml$,L{NMඤ2J{FӰnW7ua|PyH8΁X{9,dNpH|Jŗ9ۓy6i#F\1rOjs[Cx> stream xY[oѿRY)݇vE/ݠ<(|ٵ%'H~}gHIN/fy1Rl%l*G^_WsM[gS-&~KOo|=$*+y-ק #0٪v}'?$bd +H>GiUzϫjfzWůC\edU lLZw/ Sxg$ei'=bH|KV>2B&Ν :QjjUgj N,n3xHP2 lyZ|F!ہ_&FQam("j`iS5vg&P xLőYX![kz5 05A@"Uz-X6<" WU&2Ѕ$S&1(T4 g=c@Vr;Żt}p(ω?51pTނB[; !x)lP\?D2*\s i)ԦiB'J8jծ" 9*<6RIFo:JF]@H8ޮ`QH,/WfSpJvYeD[JRL1xK3 uVE\c0" 9tK 9xG!oBiG&ebVEMZ +oQHBJeVF6깕Wmސϟke V*]B!ttȁ5Ŏai uk!+w4UrqR7xwG~8(K("5*;"$]>@tHB gǛLYV-Oj]dTI~Ph"{ UG=H!6Fuy^Ć Zik*}H4[YVj5бG[!q$vº]T`bw~%%1pz~Z5vOdl׹u=[]2WCGm9(v I{pc|1{>GTdORv,"g+K(E9 (yfВr?Ƃ~p-lvKw> t\B`&.\6Րdv|<_7tE2"hiT7gWL_q:A)|d64̡l?%\ ~;t3_6oMCD"Py qdSȖؚ!is墝jx܊FD;ΰhg|M;Gs} ٝg UA鿭0GZ8oK iLWi]"DXDOԑm utcTۺ6F8gKbMw%Sl9ICpVzzɁs`(ML[6^0< @ZhzcdVol'jȻ'*:0H4SeɶӪrX'Ưm8bM5؆̲*klfe^z#L:pd S$"G_L \A?z~i]|Ƚendstream endobj 99 0 obj << /Filter /FlateDecode /Length 2295 >> stream xYn#ȯ T;[6l.\OdOv˝Nn&)kۙvZ2Bb7LJrks &>pr bȟRh?TkP@$(VkTG"Xm⣍K7V1D$~?ǒzs%(NYuYϰ`Ye+q5G2ɯ 4FjuܱsxGW96j m+|_n+ovl>KOˏ- :A|lcR=@,U?yl-(6/SO.Qv&h1m%#.S,dB=P Q+ooj8Y3k>;iqLGHQ"wFrE0J`TH6U9GVAl}W#ׅ@ d^J\~N͙ XM A:696fұḠY_ٹ)@y\/;C#Ii^;( ;By43=V@NЀ#rH'- z.O"v~ɷW+~K\-FPwR;3(p[/Ǜm9 rah!!K/7rkH6|P8v=Pi13|SdCKC[)D!'AP8kLD]/ NJ>UZAsGIko@/p2G "%H }iǼ!A[?tA$H}iG'6qS B 1H}iO?^ȓ6~S3Ԅendstream endobj 100 0 obj << /Filter /FlateDecode /Length 1367 >> stream xWn7}߯X)JuibKq֎Zkh71=$n3s 1r._6/żYW0 {"K)>wrv+K ^,Iq!^-4Z[v;N6ien)*c`a~HBhv>N}^hen\S2HҰvu@M=*<0 C[,½aVZcCRV>"8럯^aj;}&%wB~Q 5f_ǕYGϾQ$Af}=TX3^GE4vR YAٶw10Z6ɻpeM pq#C}kx{o:HCOx(;}ηu-?M׎ys*NJӐJى`tޤ mlτV;=ŗ{78Aqd'FINxGVnAiWkY$<ܠFQSmr%ҬJuT7fg h' ΡDfKI'h2hVn&./]nOL<ƋLΜAYJ4>'S- u>f3-Ƒn%DU Dy6ϟ:=0xv@,7K\ D, 1=+, E.i08FSyb}Ĥ$^ IctА"Az>]BP#bc'0endstream endobj 101 0 obj << /Type /XRef /Length 120 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 102 /ID [<6638324d9042b3987fb0aa11fe394d26>] >> stream xcb&F~0 $8J?O }(8%Axd~H3 ,fH`.B"HG RX 4 &@s} ,e[Y endstream endobj startxref 75109 %%EOF mets/inst/doc/basic-dutils.pdf0000644000176200001440000015746513623061747016055 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 2378 /Filter /FlateDecode /N 60 /First 464 >> stream xZYs8~_V*AVU$>╓d恖(ItH*q<$R,٣M(@F݀`3if] , dI!ҰIg% 4Jɔ(SI&=IA<+10--Ơ1#a2豖4S;$3*L`}T| uì eV ;G[ "ԐE0kZ㘧P:0A> ’AYfcN (=)"bZ1I(9c5s&9aEI6G!`1vܷ6iC U~@0e !Pw,4>JM  @c$W?p!v1~F4\T>|?@8e{{ŐY>JRj B!l4 O%mXQeeiP5͠_5(WcN ,cMyL5듵 |{ŷ#TEH7sWȯy]ftox$!#>~7_7~ϿɐZʁqxQ,4q"Sq<F¼/Iwߟ± +2[a%<5 azj۴~/xK{]{b콶R涻*lkDѰsa#E#OϿ%(M$ZHEF+MVYV\exཥ٢,2Պ;98jQ/ 5by<՝ZvVȼSn6j+ܞ2`sg2Q+|\IgPΉ|rVR\ң"Lgik4MQt#vEJ!RڣٳU4rE%P-ֶR/mdCxԷO+Zxլy<Dp7aofq=hzvR _wtQ!{ rذ-7ⷲpwq 7qB/UYU09 Y֙_-PH(Ns<:xE;v*4'z#ީx)3;y=3SKAu)ϣ?n6=~]d:'O/DR~u۟fL'\ΥsՁhՑi.>T[5f ijCs]ieڼk#48bOjC2S+Vn'3:ts8]a _P4L4?L4SQy a_asĜ)sy;ۚp?rendstream endobj 62 0 obj << /Subtype /XML /Type /Metadata /Length 1645 >> stream GPL Ghostscript 9.27 2020-02-18T23:23:35+01:00 2020-02-18T23:23:35+01:00 Emacs 26.1 (Org mode 9.1.14) Manipulation of data-frame data with dutility functionsKlaus Holst & Thomas Scheike endstream endobj 63 0 obj << /Filter /FlateDecode /Length 1746 >> stream xXr6)xj Gw6&`@QŚLo $+I [Z''_A4y,X{ eT)_&<)wKeqWe}lK&iWi*uՅ]ڰ3<}eUqEdΔx}[h4a$F4LYw,~%TٮyT]o_)>r4u֍:Qro.%v2@ ːl+P,:RhxL-f\9e[X"{ŀ͓ 5B( \V*;N< UƝ7eXYg),R8@nZK &,EʕuϿe4!6=J)@̖U]"N^Uѻݑݭvp?Ez꾷M0 'Y?>Í/_:.{@H- 1hdGF2AmV?o^&o{%=.p8Hv?Tk'i"1/鶳d<ܻTU,Ukk$sM%]]e٪ ە2/pph;L ԿdlRzM:<+*P6vMm@~sȇcE Aվw,F6eqii&3$˧ fpUeU&8}R{0 f:qc()סjs& t ܊OE2Nwq^GATVƎd+.Ѕkۦw#HmHoIH^L 5vJ%0n2LU9%N=x<)JXwܺ i2en~Tԡ5BIZUgz8Y\LꙷJӆIVǦ Κ)@]^$`U cb^S&U8/k6ctu˩ƤAH9{ j^vl" &M^#xҶ эjnSX4 8ǵSˏ:תAX,wqD@htu(`s=fϨlkh \c]DVF<Ɇ"@񍉯RP!Z$"TgJ0>硒@e[{ܐiRDu\Ьn Q`僴(LΌ+4uӠ|ofYPEه 1AG'*- w.zʹl EmvoP}IH)mOma"z&O;큙cw+4 `3Adxܱ+XPP9(G@4b'p 5ᐻ_; ϣcd4D0@О;,Ipe=%21-U"!]8  'ZՋQi*nCjw[tw YebR-i7g3d~V19{69biL-Z}O%F)=N}v#5vy%g\3~LW`!.WwAЂ1`c&<=i8}EUbT 7K=F؋$>V mv9CB$aQFTjy!>f4Ej$f܇Xh/(Y]6endstream endobj 64 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5428 >> stream xXyx׵c,@d&IIZ I )h0`1eY-KV˖[bmeYnavB RB&M6m\}od}{͝{9wMMy0kl0;W Nyy<[$6;!Gbs%doIshZ1'Rk H3~xͼ/ґИГc?fb:!@ oä>~vu 1@(?wvVlT'gKb|dj O8;#&rU>U7*63*$l +y]+YbUܓmu`~dW m [KaM'SH|" sٍqMUC)1+XU[m/T=oUK͝(BQU`#u'AT:)6,֫-v-< P1&sx<=NllKʀ Mx4 -•8ךdpF"6u|?MTQߧAH(|aLbwx TMU)Ö`?VWe `PF( A+OOYsvj8]V~wkÕYa][Qh64Z!mKs:B#C1/jZ!b {,Q7hב˭T5U&ƅ[d$.ϐm~+lgnR...X- }fWUX(컃Qx^饛RZ6YփL !6T"c $P$\h&3q3@O_#p& >KDzyŽ哨noL,?#3Ko$j4w9 6וj{XvGJoI*pܤ:Qs'`MV&NU,_+6c/Ihf/]f#{k}y`?Xߑ{<4cSưz4`;D!#&o;@Kd俭QG,?ddޚB;`2zL((ȹO,'_|h&n@1FdɟMTemVQ!:5.-򜅎R?bO5:832pͤFo?. Mb9Ê u2A2G(yNSZ-3ks8+DUĞGބq3[LR䓸[ ^^m dc0jd:wBTe)CBN֝spPf2DF S9o0!x >Lw`"SVG^QϹfg;u$j7{=}#2*h߽L\)U#o ~tY ndEG[j۫(j Kr~Idb싓 /`%zP]V3VFSj?mAЪ .]oFA#=(2-rB+o׼T&Ѣ@Ѝ;{a|G<.s$}meuuZǨO0y6_=ﾻp.`SF'P3ԊɗṛV[ GO`Cwj >Vm doULhV6/A_e `KVT/U%E1of'8)[h?МSa4~9Or ^ w^Y8ZHo<;ng=7IHLtFjnszhLm)`)p|iL/P GG؞+̋$t>|fZ@MBG%؎,X;yUY?MH3קО|bp}ƚ 5E= Ջ9-sFaĩ~:QyJ~!/_Q6a>P#kĮ{;5SqSPHj \i _R̅ԠϏ4^Rԁ `jj KiFxǹW ,[LlCl+*ΐTyF@ u+\ʨ1QH6q{-+MlUnZv)5EϽN7ދv4?gWQLz%Θw cm[]rbd H{1Zu1jlbSm-%n<](_IAd;|Iq_п Bxe"V̵q ʊ)XYr j_!Qs6 &w682| I 9jvzZ;7`m,?gn5b+5?@Qq_yUL%P:@WڎuLrop!ұn(pO-1m;1We(X"WRQ3ZBM028kkIjNTI^T+k:X#z46~4au_u%4af ^y@-RFbai07_Ir+ 6zG:+,t:{U#T :ez̫Rp/}[K&U:QXd6ڃWQZD~A>N>{`w;Ը|T7pPzaD[.%In/f.Zٴ}x! 2֥۫4BC5Z|j= |G>:wT eޡg; 8b:U_nB- 0 sVg|U}#켍Lפi ,.Wv6!LMg0B;DɪH0E轏~<=c?] 6endstream endobj 65 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 960 >> stream xURmL[URlcQN-Tp.2)!چڀNnsns$&)a;!j$PP9M0pQc⟙Hrl蟓sy^v`WewEs1rrꪪN|43 r!"|5)QB_cG7ݝ@QFpSE.+#CYFL.f5k! Խ[^|lT=2G>SW3)"endstream endobj 66 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5677 >> stream xXy\SW)&EA!պ뎢 K@6H!@&a aa aE6QkEi]j}}KGg>1Y粰 a,}֠8$\$}L¼}dQSѝb4lҪ"._q\1\'XNݙs1FV-u;{Μe8QdRpɒ%d`P! f BL.JۄB2J(՛wZCN(ƅbQ_&*8xAL.RdR/!1$)?9lSJxpsDdVѶ1bIPE5}ٻf?7y6یb`[?a[mثvl^Â]*l7{ۃa{|[c~؛l{ 6a;>L\0/{{`17l'6Y>:aol'g>?GF>^HzދiN."}ʃz{۽ pqG6o[5@VZ @@_DDdVZגqGڍ Jʪzq zwn#+6kRxpxJH:`'U{—m^Q/^p"Q}w~AAOnpn9FBwkj?"ŁTMp۠+ ^a$ժӭ{VW=Aߎ{6lufԓg` 5ED0W8%{ĻZDeAn b8*\3ttEwo7{4/?D=Q0]of74xrlLMb 27Lu 6פTzpkfQr~2K@LjB6?'K>ԍ: -G$w=06O@֪6ǑfUQ>!Zu^6?9[!@d hÛ8Ӓ]cJbC 1J @OE8@p R$~Մ`>8ާ;j{\ Щbi) n" |ܻ>D.8|)5}?עKy6DYRn}P}/ǣpPoji, Ejݦ5%x7fLv,:kЮUAC=3?$;GZ8xa)ڥuWR@%L:nfW}! Z"Z FK~kxCb&r"&޿4@.#O9CC9&5(nfyֽa{;W\/(*8KOMT۠7/ŧi9C88b4_(!i8$1$ _N@~<*7z}4PW2z 'ji(siD6㫴  jӾx>A0UPoH4/QP5 X Ql8(u$x?I•6 LU8O)2YLz8JM %ⵅbk\P\@wycH էj \e?෌S K?Q,@ccQj߬K֧Tll$dxRoVT>H3$!$32;􋰇)זPR\Ti4|$5a6*t9%q0VYX\nXF[mFFG:,D=w -M Hm ̠`fNNHDLΡ+KlX' sWmGT.STc3ޫ \@6_.5YK,TFmЗgdhtݴ̎NYB(ޮe78fĉ{-WyƋUÍ C F 9I2B1 ]SRo);pid5aY*SA _IC:ehnKg%H2DY,saQI~;p`sj3D4HtK:ҫYQr?E~STb/V:*̟#Ћ :678ݜeؓiA;E/8S!ÜYi((Kð+36HN֢LH$6嚵9dwgwlgI? E5_ H{ccocLkt' -ZZ:( %:K q*/PXJ~On`+kZ~ b8ZFH59L" g$Pteŋ?Y<9UyKuCL6-ğUנ-ͬC]XgQXw1o %9Pq+*s28y+x"^`r02}Ŵ#ӎ\ @Se!OP,. x z;JB^-ip큈M;ħ֬u$b.nAйo{El|U5ʥwG[C&8O4Z|FAqrdB HC&,5#'I:LGL]ާ=0v+З0sJ1\lmUVVT.uC_ʍ,o*3鍲wsk^3V' m0]_Sz%Z \z|&(C~.GQ&-3 N"9/D3Ǔ䠨/&3=:tP~m2sEN}VI*,m k./ȇ.I|TzRO3(5(t6Ǔu* U#3& ,RGE:uC*EwMz d }QGypiεm5n3 ) E|} *58 L4L>e?yL >O͑ēpw;\Ƣ>,J5b&`Rơ;KjP J MUP%ћ _QؽS=ƒBb LH4=v2{M*6HjZ| 6<=٨~GM vaq&Q)q[Hij?#Bp_1;Ϧ;72I Ϙ;d$xLUPUZa-Pva3lx =y=JUl`e߮O}Ȭ\OfMH_Lr|p|.twh(m,3k |QpX[m78 lڲ|wo !cGv r[>{sEr]]iv놲"liXCݕ+cʀb|s]o?NB7Qh^f)vss~; ~>wU[hBwNFʔW◧3? lhԅj J-Fgt1D8H.՝r kOѓUz 0f0b=Of3 jǸ~ CmϤϿg׌g-JئF{C^_8ª侍こSK[[a6N{)l{RP]ȴ+ R4 -\ae{r/c8d/s>]|3qgUg\ ԯjٽB [6p>]i^m)%i&iV N3؆1e>26|YYk3ʴtn1P*$94gnA<\.6v{sS],wFK_6NIdP~gbcZSsDmP-. .Y2Ffå ͓~v.P6[87Yb'*LE`3k  vD|3&-V&vҪ4DFvd GuWWԾ'2j, Gu:C&dw3M/2}8wkr/zݿS]]̧c4ѧ?|0?JNMZ.Rh/G:9w#%z|[\hc9Լ Sd17TYh[ǚo:h\uhKr h^K#$Nknp6+mXRhuVB 4 qH>|ql+[8ŭ~ Kwmo;h(~6tv)q x|-sYvuofa3, #`'4i%`޳]Nv_R8vpvN D[.o%$'&ym.67ᚁ_^Y j oİ2ph c?Ъ(T#qj%od%[.؁oe}_X>h/yۅc׫ր@0s`a%vq:wbS[?B@Wp]Qeq')% 58ky؅{WJǐ ]P\Ѝ^V>zL|zi_@@ʩxZ4Ji44pONٙYa˜Lo:gs;` rn"PL('CD.HeMƖfChsq:^~:lqawzendstream endobj 67 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5497 >> stream xW TS־1ps85 jjk+Tm,8Ee3yN@yA# sϊ5uֶU_km]?!`⳯O`s=go(AH$,Ϟ"tMƈ8Jh}0׽?7"s12793v~Ka )H;Qn3n66Sl{#~6^6˧8OY)$~6o˃mmaa͢r7{y҉(Ñ#{FՎ*꒵>'mGo;gkO!C01R$,T8)Z90bX [r^Mij6s#L{\!UHna0Wd)ty39#[fHetXGyc:x$x@w4W50Hcy]ŚQl RTz@╷dI"tW?{P1b閔&Ĵ Σ#ϋ;߱gRz+# YKY IqH.i)Nj\Ai`X%ї\&+F)IaY+xd,@gxP IyqxZhْGј]%zVOwM{h7x4{lCljn`{j+nXzT>q"Ј $Fr &7^Pb->H/[տQR5!\,d 㤺s1RG:4H TVju-Gm`Z5:wtH.ufMNn4hLw&ΘMa333b,z !2RǟweՙURpOU]MV_PyW\Bu(<|cUdD$pi,OjAI%V</ḰٕLrw мꈖƒ*PJU1_^ax&-OZ KIk;2Niܣ+0H(+aK}Ƭh=ZQHMaA}jQ t/h6`;SoK萣6_cT2P}z<iD}.~aѫ͢Q oa7-$ Eڵh7ɽ%aDA)3;Xwə{}#Mpc:Ƒk,}CF11 UTe*р*&<*-bYZYFYZPk`U299EE1~9=;:l"/ UN*!QJt_hwFaU־rbB"xs߶۝=_q0YXWQ^uBTW/T,%SG)\6$^t}\dPJvpmLbZw7Gnxj̽͟#`ܾ')׈tà'$(*=ZCG0(s -x$m_zEe*)1kAhD{^$t@Ë ^*InXNRQ5JSܢТ*bz=Ea/ҽaMBr)yM`bPG&$GyI^HrW*`ɗ{;mvqAv6tgCyzƽք|M1aɋ(?u7\[Y5įOkj- "(^R_ 8 51kzM,)=*kƱJV칏`W@R6-0 CE >×xyDsMsQ{ݛnJ:PQQ[ ۻcqi\VuVOŬDxK*sڊSš}yKgI ȨҼ4 Ulao q |6osV6H#N6@7Lޠ8Ul5ʻ3^o} MuC/!Y׈k!\^74jz :qQb0UhwJ Mxp9~(|c$Kf;5"[ɝ:Nu)'`k;G)?5,K7 .?~-7XC#EnԪL i]b(ӹmSvfg%H&1Or뵝fIbot${#>\A}[|K>I`ϳ÷O)ǵ3sm+7/LHJKGz{`,. 1]ѧKnyzLۮu#vRB ,AmiB1]4ՁT@]kmܙ3߷"*@̕c2޾|p<3 sΘ,$] ]WwKN으"]d'!UήiO6I#%Ir6 DO)0đXJI@H&q*Zܐث~ ^@ Tk.v-tl3b+ hMS}y\#Ay _!ֱN =ߵ3{U - 2 M $iɾgKA<gl8mW EAU)i(aUT6wycDm0xS&9??K:g:wyR Q)wQ(UG(~{?sKcW3IHvPZ~, uS.,C%pXG]RNýK(E=K9ttCYwCޟT{$;D.[3v0F>|OJ7jϱjuNr͛g6e6ǺZnͥw\ZG\ =…x_oWEf (^U"CcmJU^d݂TՌ>P3uօJLRɵH*?{]'yʙ/A\*az=0=R$fi %rNt%vԦ}r)J韕%V5@'y!W*/17ueK֎V:3&q2Ja"*cvw9+yb/gXfRI c`&+w顀&_Oy>y롦}>eʜeg/!ze_܎<gWGpϷ#pJmV"Rlm*m yߪϱ%99h`b$[ : KQ'jw",^e"%(XFMAɏe7n*ƩFd[+c7;L<:'0]%4'؏|XsG&$B?m?6mMd(2C#]v@d@F ?}thy6T]P-9=qf+b+0ߥ_*H9a@ kJ(L ?,M-C+^[Ҥ Hi^[J r9 ˋJ Q@~"yeOyU&>S;:wd<4J᏷8/*^ڋnCW 6\Ƶu:]]9![_BrVv 1E1uj !ٚ߭7`k{:}_Q'c!bPd 1/0<]e$ȈǼE*IȫD Y/= =;1WzȖa>uNJrT\.AJHɈJCLLEL_ς%|)}^Kz%?ɸCM!\1\lEմ5xi}dytXjLR:aGlB֊\!BP"hv0gfNn2֨"\UMNy[I*HV ̇Punendstream endobj 68 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5297 >> stream xX XW 'UuZqRQQP5&a s¾aE6AQH]pw#bֿu<r{Xlڊʙ͚=g–# bp Y.b7p"{b#L,$Ob†FBb!"&DL&̉Q'S c=B@0Eb,aB#VUb;aDD]Oy /7mt.LHT豣:=iΤq4w|%'i5{ %} r(H/5I&N4vrA9qא6wv1(O!j fXx}ez>ih:'dD,h̚,c۵k}w[Wl0x9,8hoEKd.fD/DfHg[i3Yh @AP(^3igk{|&^yMF~a)v(e8r{dHҟ;Q P> Ѹ3!yB1;",+:;||ݖm_i IB~GV.p)gC ʠP B[Z@e|^'Љ2ܾ/haގ&(׽UHGjn ϩ8.Xb5a/S/_  ?^><."$F|8Y-$4Im\*Kj`qb6aa.k(A}PE@ UPi> -*ـYE/8!*.,q֩ۂcM! UՉ"/ͽ%C06aD,zztY8A)@ߋs4Ud&yPk@w…!_CgJ| H|wo{Gck9- ҼOGw(!EV+|VzV<#{=~s[vF`NGr ʎ HFĈÐ%*1b>aRq'`yU%qlV1hjrbAָzcF|I%(e?GȢڑ;s|.n0Dsr:nB&֨VM,/VmD:'R)Uݠqj.h5$h Bܕ1k?Hj jʔippI4~ ypqYTWh;g?q^wqHhccwR0S\"8 * G~f?- cJ嶳vl 2 ǫFfF%314\IO>Np+'(jWfjAFV(p O0B59I:jzcMN\-UK̓s% ׻tm~m/ #";0 TPC?sȣ90qp Z3‰%) ]K֦h5i>51ŀjMh64u!p!]4[4di,搊2JG̋ٳX&<#G0Aqf"hE/[>ݞw9 pq,0y ip+~ ہU9;H]hFL2}3NS:TWi4%^9ze`^ ̝//\8{*nhI%a&M^*TYua?\QUҶBǫBVosGMkFV k.5\eɛ\Z-A=V e֓X bT DPU @:ȩQkw jqE~Qj63<IJ*1FEU*4Z81'pb`}]aS}b-V Γ(EpGN "l.Hrwf`8{+hm: 43Wh2>S5&FmO?c48Əwܘ dx%ᵶFnOqx&2.wOR(AJUv\Wɼp&R[.O b\ <[ZAKѬپt?N FB RgOBC-G\?Qp/)#D/_,71gY '+O68غQ rj Db'my1_.Cswk9aM+*U$%d15,ԭ,#P䑬4ɐ2F?N>aV{OVe\ MK?, V,In0UIxd\Fè#A $fG+}@GB%1 //)a @.HO(QGB@ɯ-?Ւ rkM~o> 8 |E6x3R2ħD 5 PVjَφI~Po veqI} 8K8hOZuKP0p+qS J\>Q؉ [Vn[꾫]!jrqVBeQ'?kwUqI@EspIp]ITh_]\~l_/?W] ᰴ><@uq+cx 00ۼw]h|,Q制I ,7yYVe!ބpq^52}%=Vdڃڰ6`%ڦt\ە yF}K@okh@|{k酒&2A&V+nݶ]sٔ.B(|Y[靶.Q/>>$.D-;1"e[]twl_SmYZٛ J`* Cwλs la#ÿTRxш7ON} :d"hłXqIʢ PBԕR2;H©X=.~;n~qzN&[ "'m" E|-5~^RSFϕ_[X(}fR /xþ1Yt,khpɣWSY^+)yL@־@b$D+@ )^.̌|PJUU.N.(<_ V/qޑ GN)hYcߖH JW"\^wCt%7y?.2'& 5M ~U -) 8Ѹ'"8BMvC~YI9)PeY(dy/{@SLTTW,|p)Rңs>p?nTt[|ώOC濜L2uR bK!- j,A7kSi"S5BVFeDƈ}p E*]NFZZɁ)@n AsvM |yJhw h%N=n(1PLi&$FbA4! Őg1!xOB3j#𠯤Fޒզ2 0ᚤxEae B#>MsxэmG#:LEF,Z\N||g">K@V+ëv5Y,mݬ. wdz\:>:[?-LӒXfNh`28-I61iLMHO-tCdA/ ~endstream endobj 69 0 obj << /Filter /FlateDecode /Length 1623 >> stream xWn6WhI*>E.ZE_St3w.Y5#ˎ%5 0_{/ (NЦE9璼 1$Ջ8-nԾ |&2`]tҀQ1IĨ9KG1ՊR7ZiR٢5[кa`rIҸYqKqnqV¬ R54s+J*0 ]md>>.4Uqz)E}֊*1WEkv^C-&vT-gg./)ΐqގՐq1JKDå`Q,709a, }zʭF# V-V_Ngmfn I(L*\2üCn_Q }4iͧ<5(|3,]4{!F,71Nj7 jŜ@x(3[aIgiwmv6W7C" 7\а.,| !TTUlOVؖ/-=ix4!E>m06n3NqV 0e9(oH㎅(6>Og/I}ʳ|B=.s h6kPt^\'A@;tV(7@{@MM۲YQƮKޅxy4G0lmkE=vMݙȎS;~OJ;D0UAGpM( Fp{-p!aP5Δ?EH&&8.#Tn2JdA-x!6K78)%|c1:kv_JeZ}ݚݚاuѭ_A#&T uk_3|ĂM̀htpX$S>&$KDfC)dg`fe4S#W X1ƹM!`3KOnj@òA=Ν% p#2ࣚlr^e"#8x 7&=n> stream x}V{TH#-j}Ub|` D4'3o (UDmjj[mŷzmwq3IQ[Ś̙}1p!kօu:u~n&7Zčoyid,1oظKM n 9/aܽX?m|ziӦy3s޼yTtF Lc멉!M3$'iԛgNϦVuqT)5ZIAi4)ACiu?$t}`rjjQ:m 荚)T!ҹ~P1}֤53FJM51ZI$ өdMJhϔHŧ&M,e2PZ}.5VH&*9ŀד *`4cR& g ]hJPF-^ qXCL@I)&$PZcN⭒SNF>MT&^ UyÏz:9Y58z_k2jtq3~!PATX~Fܟ],.~&OMc )FSYK|fw#"#‰b #"eD$V`b1 bAxJ‹uE $E={N,l<^呑>h rmТ_"4 =\"ɁpLXi,*DGўIgv*{=(oJT!C^x:p(ѿdcqYl< v522s(.'L($DCL4 B3Ф >*K 9;ȫ6/Eh*Rd*wKCY hKIe .E$}fvR%`! e3g,ZԘVa)T;h!]`PJTp)P9Rr^Pzb߷gt0RW}QmPCA];SvT@.W!%;ϣeե ׶1_ojia+8\<+hCe:ܖ6Tη#?E/E !/O-2Aj lLٌhg.lפ ^Cԉe@HhVa.[Ѵe B;#dZX{`-LƟuFu ]̅J>P6e͞4] >..)gvAD 簈|j6r`hKb*K.-kۊ,U ?)yn$FKoH*hI݊#=nq@T!C[|+uIbz_\ɭR@m^ lJjzz]oz z.~M{ +SrR?^<.%%|/:U-Oܾ^E#ʰ9k (>7R\ܮؖ ?(cBjBA0,hXQI~wg޸~i\6ZCԀ;lqfx^{a 9LO ljmwwinhԔ>~w`E:kf$%cck.]<4!4]4hx,~rl=A<;գ,Z3Y-9Yt^`DKH(kbIv{=<(U Pi=V3[Sj^G_E_f7M5q)זduLa*Ze&؅kbw΅nּZi44-9 gC*>%d& @z$t _]9i|9xc'.3L s^{mݞ;2ZDXz;rM*vW휕u ']_1Іi\꜈> &,.wdJf lh gKĘ`G8 <.Hui 0 HH]? bsq`]i'n] /FPpve8ӥ?D3]۝p*<ܧL=2QjI(G,; !w ]N;ކ2`aOl-ѭ`4ƎUS >My"$e4&Vt_ۏ| `ӥف}i+_(7m,]\m,6/qZe( t!οUp#F9 |-GOG9GOж;⛜TQ.EC%lQdK&B3W@Z{=*44W6m%1}~Z~~,ض( ià<,*V>h[%l%/<~eHi8K/ϳ$DzG8R{uP\6o@MjCۿ G1}sIݍ ^zy?k>,(/~$t2K*dvqwT6Ʃ rz] k$HƣhzEP#FB4EJz  `U4?jQEiҺ u耂ODtUh$ DG~B}rn0ŭR Rvڐ\q1Vc!큽PVŒ%mfI &9t8Uq! wLRq U? ṖЃsGh]1WW5-1ڼ.J97w~,ϻRQO@c,ƸI;7z[rl6Kn gߟ t yTTN5v N+>NQSrpTq$:rC0Dam>A$3U`] Od(u|UzQJT+T,0T7.'zˮ /-ɿ3mn}vb_wO0>0J+C/')N¡ݑ˚U- ?{k9(V>oH{[_P/endstream endobj 71 0 obj << /Filter /FlateDecode /Length 2101 >> stream xZMoF_AԊޮn`w,rIV7;Fm#3k ߞ$[lٴ9@0,6_WUWnc!8"~_ra" 5g)9Nd4T`*5̮eJo=U+ C?౿\@ פau/v'S(c.FT%. 7]$sSIs$̝/'j6sg(ɊnuZזּ2E桪әޤjyЛ/Np3xا^Ǘ lXH1լwɏjTؿ ǃǬWu0DFJmpj)b߰PS,>ݮ<+[\pPҷ!@DÅdRKq=i𶁊d1a2J . ÕQJR3|1PpSn@2̡_z+ojor_աfr|p)=ݰOǯ&X\SX9,8I4H.Y]s4< 1j7 -x.{6 uhY35e àFs ܻ9T>Gxsp!pN;GVaü4yl> <'cYnll'iNa5C }"bͦ=ɟzI$rK\اY,Q_PGyUߧMĀ@]u0 5b$lZNRxlIڧfdgCE g"-XkўS\YsW ؝1=qBg,Lt t,'ZCI=:J&9FS҃DitO"JHaat%)Gԓ_}Z`"uhytM'hw w6e{)sSMn~m1eٔ4'fo]p/%EQPf^aHW*֝b4Klm|"rM4\U?_BndqFk~e~pdVE}$; Öˆ:COb8Ԅk50Fd;$ʒFcuF.K^JTrTGWyC>T_s(4ғ])K6Cz_ a*X0l#oQddpK/0!0^ӱ9E˶M-@:ɴii,qz1;iZq{0EMGl5\CoDNMWSTY9,I.L,$KQV9V(^R4G[u{1PqQnFJ-MF9-\ ^1K&57-UY`'WG*D?$I1 9 d(=7.ii] HNpϒ^;INrD;" -Pu#g ;G"'~Ї`~{oFM׷jN҅xv|%1K쟅={}X7'W(^}MC"ad(=.5Ѣ$H=N\#Yʟ_LefI2V|윖(n$R.׷db g,ufE5ch uKX16r717 ,ȓ+1?j+u[~;q~uO_g__!5[9?;ǪE;VwM鉴qSٕ+I2z"L `F-E|< 9WX]gSh?#U4j8$_鱭&9A`o'aM~7YdQI?7b ُlBendstream endobj 72 0 obj << /Filter /FlateDecode /Length 1850 >> stream xYK7 W̡@䦞z+@.E.I}Kzz7n3no/qY'hGdž_殛nqa/K\ d[oiM+vm [ΰ|p3=T&I.8}MhW)ѰBjrn6H5J!-o**Vy.ofl1_y lW ok#(u:\Pf&$+X'D{'djqpg߶֡\`Āzh/Q-PnVV}yJoV}+LjX)T+]#ĸZf{|.GюLZPAr?}X$jtV묓y $=o]רU|8o BBFW^0|5*suƪ-mvv>(8q[.ZB|ODM쓆VBoH.%p'A623` zaF8LFS՜?O35i0@lwNAEְV~=' %"p#CV#T(YΦSr8afVRLHS(hAQZAJGi& ul5SD,b5Ibɫ8F'l6V[QVDGVDYj"f~jlGŪ` :ю誷>B769+ ԘZlX̟$9";_傹>J3/JqrGHrZyB_aLy`#Q5` .f#*FAP.ꎹ‡:I:0'=Ax i02k=@_z}(%R蘼  ;}?/hB^EB]abz^Ǜvv1؉`~ 2Twq ^ŮHK(7b$_1 Nxj|QMA4G)+34 jғ\!= ;^<8+֨ :#rϩmu:FmWvMiv|9~UGeJG߈W^€W.)BB)Eo_8#.DD9ENzXi`?E.>BJ>P,N|,veSΌ |D&{Q.G)=slOz̲E:d|̨St}w~tGAtbl89t""~*7ߙO؁$tLnaE4wȆ:bt*#{c9fDlʣǀqC)?|C/+q"b,[aa]7뮾? dendstream endobj 73 0 obj << /Filter /FlateDecode /Length 1900 >> stream xYI[7 zxGUͥ@Q6=^/M(K-V'q'@,QE~)/nox:MX4y?AXT]@: ?Ny\SP0NSQw[MәwdG7娓 h | 9!B(M3U8* 9q1} nCU.t۝&d6vkVi<&jR_$ZWkWu%VC7}M|M\w4}kHy3xg;v3Di>y4AE\alV*M!@q\OY8[|@9<@]&tnF׍hlr`Q5\E8(_Qk }%ׅŸ25f5at7d.ʹ rp^q$F$7/Q >8cT[t ,b1 }:/<}%8ƫ#ųf.epj#3 ɤ(f!-|*oI9&|d`>4HR; Jp@*0X嬞ƩQ 7 2ieh'id᧳ .*B[my\yL_8]S[^8].~, 3]\(t吻#fL%>m[kC0a܆a"RR˕Qy.]VF2>>l@}& }5.C{#4H+] Mg(\LҖղ \PIׅe-tڱ,m&}6@kfeϾC&ΡX#D{:kpJATbPȩskd#jaaAGr+@T:@/2/#Fg[1>fgZ@$^Ydjh)ʭ9o֥:͙Rˎ> stream x͘Mo7{*:f9Z(Z$9=(&Q#ɉ$ܥҦrp8$3 *?o~sՋHT/FoFͲq<5d4T`&5[/eo=[y# ^\@ Ӥa^ZXYB˅pyH5 vtWdyT\Nf#v9 =Yj\eV(W !3Ơ &0|*s/F&qK{BLVA>Oys a zׄBhq/)mxȐc:Fl ņCZ н]^Ntj6oWfڪgYl+vfBwXSPA9]u:HزjY;wSp0j k;hmKtFYψ:.zA[9 Z Qt[Yrf ҂[Qۡ _Q9ʟ}{_Qw{|U#5חEi+Y}7F^q*Ħy3i[R!B8GeAj} RљBimN){00i;*I%g&- Ha&(:ن2p.53Vq}荹FtOБJn`Z >;uj]^wTۇEn{6G:uJs 9=2^ީ+'r>~YRd #v `v*;.7zPg RNN Qv3TD=endstream endobj 75 0 obj << /Filter /FlateDecode /Length 1194 >> stream xWKs6 WVYo3ۙN.QOXG77K{AJ2)[Nmv2q O3 E  IR*3к*㌣$]RLG MwIY \Hm6~ RRExc.?T!T9TPLypyAeq2$s`xq<茡j#\djEѡBÚ>f3},#xLK!?3"Mqok[DV wG@N{[y:9)U CSr4hmq1ZǔqҴץpu xW%CyR]7QU2^A^C RzGzR4b/o$p L͋cHC |%^3@H=Ͳ*M@x\ee֙O OȔhϙNͷKh<ݯKmwMGۮcl{@ ѠHO3)K M%K BZ:kj*)#%OA QqUD^w3.R2@'@e h)[灖<|MbwߓTuS{GAgIVqw: >k^1W'ξeD0JWbnn9^o_Fr>+[RZZp;;{YjlQ"-^>YG1A'ձ|QTFaQΒ|xѿ,C%хGޜ Wy|L悗86w8"~?;9\4e25 qcRFqJpYBYOire ť!e1/6d*Ў!o} jm? i6q;B*ˆ#a03p\]xuy-wjkïyM(3^PUΦ-ZN߇l|]/4W?endstream endobj 76 0 obj << /Filter /FlateDecode /Length 1863 >> stream xYo6B{2`0t !]VNӾoGJiGRD ԉ<|,Jʊ~Of?) /g)~cNs]̯'BVp)W0NSQ7KTIKf535V[$骕:ȇ4. i L`W䐤BiZ&^{T% Rw7?*㹫LR8ܝ/'d6{ A-e7Ӛ:5cElfOs%+r?,B1GzD/Ɇͻ i8vp'ƈ | w3D\aTق[m4@ŮpG".6aB{zW?IrDY:sT7,z.,D^؀+a>q+ӅE^i+`cҶ[UToqԍi.jvyj"9#aK-0c-C lδ2{&UK+ڰΛ4eI|+vLJvd=DB[SARhe)P3I8-C]/+t}xGp3ƩX~ɀS7loC͘r2 o\FwXȂ7דP4S:^ȔbY:UșVdgHLC&dZ6Isa}p2u@8rEe{`w$祍Y,twC}|=Ehue9JUBrYUG A8Ϥ7Gn}X}Xq#+VUuq"fl/3=ҊǙCMLY41k7>J2V*c)cv$δ}Suf03(L>֣#E)J1,PlQBX6/ 4&~AX ƌ'(ES?ݒrgm!Z6U޷mڄ5v 1z }Р_}K;w>u " 9D(U Um: aԻӼ,Yl\c$1LzbPgMY[;zWmf*!?6YrCR㉒ 5 6rW33ڞrFt,a嚏4ޝxDvUGoKe|k/;޿ Xooޒs[]AJ(5T%XrC֙[PPN<nH\)|@H\͙=iNA,U1 P۩*'>i7L*L4?*/rČHU&2#ļe4ɍS:C9CtjFJVm*(5 taqZFڢCm 1M,$WQ#V\rnK:r\Z[J$UG'T/dWaYVնGH7DL۞@]YleИޢiQ5]~ !m_%Idp}jɑˈ8K?Kxu F1M՟u? XiAK&xד!ȇ~j?@Eb4p.!KM6Â((sё@z-P\[fC$fnipSȼ\\a@e,QcVNDrmOݻY÷\9H51ʵ-7u9='Hc-Y]D tM"|#VE40| ͺmyJmyjN8#s$"\[o'vQF+ sdnJ빠H/o&p endstream endobj 77 0 obj << /Filter /FlateDecode /Length 2042 >> stream xYoMx_2 0 / @B\%>l퍳ėvf2v$HUy}f̹, fbub58q>Wslaͤ}*4/7TlʙfqgHUqƑm6-+N> qK&49&jawrԆ2fsMjPY⑃?V*\Qԝ/'dV1$uܰnU81Jg wZ"P̟%*0aԚn{[l23jKxƊb_OB%x@]L(f'6eO=ը' * .sTHP .lFUA 7C3s(c֧x=|~Ξ⚰`l̮߱Kd}/KnV:ubV;=:۲[UL`PHT0עY!x,}F=]>8Oզ^PXTGUSGZ;Tc-is̙C2 3nYyc~x缷ȟ:UuLjzHP[!GM"&OOaA]1K#ِ7nwy#>gIG--F*:bb1ʠJi#C΄#9:1*>ǣ랑\\ ;f`wk:i=[ &YjYi.qg-hb))0IIO0#dinjc/V I/PZevmlf:_jOcDerx(?FwD(O0J;1sq\ȸ=Gg[,EIS^t"$3yix y)`}T^GFj@{5?1|t2v C^cb8]=ں&ͱ<#?YC}5u9mgz%]Yn8C9>WcN9+ 6"`T+C9ūmmR FY&. $gՅ/LoB|__ :|۠simٴVLWaYZ?,2D*G.TPZţJJ~saVMk@W#i[@qLujǀ^EjU5/9qvflu64bT΍ʟEIYGOOP3ڌϗfϘ|,{a1X^kW 8K4\tTƪcheť)*oobܞ 6Njÿ8{=%fZendstream endobj 78 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2397 >> stream xuU{Pwj,TwSZVjwkb-V @< /ț|$ᕀA-Z= ^Mki_:guwfg3| ,% c0_ܸaWCi|d!FbeRbU2PuHb–m*eꥐ )V.[?X2ϫ! 6n|j[&n.-ҚCݙٙ=B1]p kejWUpf>{sy0,A$.-+ 7mU&by~,+c;簝.l71-71:d҆oSJRf;_dƯ/n_|E&u,#9Fpl^AA!BFuFG{G{EzN48_SR.)pT$U+rAkl'$>lpI2Z5d5dP@+~e bNy ˣ,.KIT/^4(92'JHeLN@q>.9 p1먵;;dۨ{2x[AV| ta9?946 0ըӫ4PwʺQ4q#,za69!Ek8`+hsD1h/ A\56C .зw}Xv4,"&E@zXRf%AmjCzh)d^ NNIh%'we7H5pq#/#7&hDJr+2l^5ShkխzR@0af(ZGBz1+7Qt3H21BX5fpi95:ON}M:Ό)hTy]Πy6MZ ୓eltz4>yw"M ̠K+'t 8h-:hPħpLڱn#D_Dʃ`0Xq+kЋh^jjygt3 J%T FscHL&F]iIpvH#Q fxbd?O =.?~591qW0QuDC$\1bSeOn%hdj#Q5RiNaSQ39Wf^?NU=eaz:: ©-h5Z4\B̏}oz4WQy+Ojqa>;ީ@AOKڠ6-T^iԂ8Ss̠%C[x/565HP88x/ƧXd,ڰF) "^O+6K M&ѨT(@z;moM&4HU7Ѕ0(`ALֿk(MӂUr^0:8 & v0ۼ$b% jI`qo  ҳ՞?JB6 h %Ke4:w陷Nђ)bC[QIԦ'(n¥w!cѷ_)߱i[)E#sfbs "C=`Dn+m臏Ō*Rը#ZA dZ=^N<Y@kK3=*Wݏ&:x瓭In1jiDvlV C^0ңjUPOs/fC^dQky,vM LPe؈3(/ C]=z Tk^`E!ix<:#6hjf.G,I.&}fv쩩6~1_endstream endobj 79 0 obj << /Filter /FlateDecode /Length 1721 >> stream xYnFWiFQԛA*`$VG"5ɷ̐6#6 /yS(X?яomvriŬ_ d7dӋQu#TzCe6]fdO4;C|p3lZ鲒zvu\Kh M4ѰE*eD:&"E(戉ࡧb=T1! PILv ~>(h T;\8\⠆U`uV \.eE$a~`R;B Z0I@GWhejRIXc&d^̡>Nr~ERm9ggy^@-JLoI zpRyv&I^J$ɻ2Zϫr^-&bS_~[_}\Pp\4J>4 öШ9\RmۅB0'UG@Gc{5hm;𫋐@z큓h?]",yg#J`ܪ&,غzwz4>|qPS p([77ra餈I\zI@Õ^3ն8ÄqDjo7.`x|k!iš˥bWN xW^_8x >|#;>vJS:Ju=VZ`9ƻ䍠GPT6жoFendstream endobj 80 0 obj << /Filter /FlateDecode /Length 1618 >> stream xYKo7zԯX(n#7i4E>(XR"9 zoG.)RʏX/pp!j(߳৿Lu4々*~/pQ94|MdgrS&1cІYMXbՖ,rU$#ܼMh`Ӹ"7аZB(MƔWW34zݮԜ֧?)㥧LR8 ȸI+;cbNk^k^bQ FكbEY t[`܃&-d6n~x-{qñc06,n7VcPgVƬQUFJʝaKn.fg;13c֌99o xb#3#d+Z Hx pUӆB!#zĨF9 Z!ѭt=֮BD؉%F(1=Xӓ]9ayu~nAZ(Aod&2`4N # Cl#G'"X$@2 Yo0(){ѓ Z#o{g8k:wA`Pud6:h6{ɜGXFk{ \`t'뎜 r%\eC5^HK:#-cO߷iDW 3c!{_51i\ːAtqrHrTuI <ē*c.ˠk=JZYOI Ʀ8[\ws٣ tH_T  ZV*M% j!߳P0GZozoTNQ:8YIJ|wB S¶!O ZnEۘb9S-y UFl$V~RchI[8(TC.CQoCzC&2Nbg EehNߩ"Q._˛[dveTُcRd @8Y>q$q3dZ&\gL<7|v>tdB>!?6i;u^u#ϖ)i>}NlR T\|:q2Tdh )F^&F1*%*c!L8;ڞDKAH!R qV"RS$RH/SKy&" G4#p{Y" qGWrifif%o˞${ZRL=(D ܎)^*2й`C2Y?[Y{'N:PlnEdma˭Eز+Y.U Иnb]\bysٮK騶wQ BJ=E╉6z*U^ڎ(_qd8#]:bE<4h)T_]yo ׏HоwǺPW mhhȜG|$I_n1g_4Ԉnc7*9aM=TD2 S|}'&LlJD?3eI v }% &ҀVZVp|xdk}r}氪{حx+H o!Wlendstream endobj 81 0 obj << /Filter /FlateDecode /Length 2236 >> stream xZr+X"дo+^$$Ubl/hv+nj$wls$(SiH* 9)r?e$Ϟ'?OXxŏ6-p94Ӥ2&3NSn'wd;[jR[dήY']76ȩM(;Git*Ja֝ӭTR&tޮ&d1Ϲ.LZY'&(. gZ Š|f.:thnzg<$b3$^ێ8#vyT(ɩPi2hóC9p6G{:NЉnf67$EC1G>͜+qdX&Ҹ\ᯢ:y \ 23 2%f5džY=pO|S~,7Ǜ=s6sy?Asg~ rxʇeqqE.](6T/02KBmhsBg<f4:L[{,պs.C NUKY,cG2U᎒P[M:JcwIx\g+՟52M;qƧ^,ʲ׃k9hJQnsi'eZ\({BhrqxP|^;r&sgr|r7QXNBGž) {[S\ *x ƙo$R*$x\ITSDbQ3e{T^my %5, ,Dkc-#. ?L&U魰+_u֛hD|fIQ4$Zd#Nm}q{F6aTnMNqX]b.w/^KP_%nUazYVG~,TUO i CW 1CT^|Z>;U:sD# v8"\4gEVW36Vw}]B7V,yJT^(˫PLLQpӖz&b `ԑ; j#aڪ8_HI11bvyFMi2z[/mY?iѫdl%_D\_}5k*SJ HN? jFf; b؟>!]^e;\Iշl}u_6gMrT"8 TBu `L ª9)1w y͋͵N]upY]%#]Ua%}Q_EX#}Eȗi.38n+ ؚɪIUڻgIX&Mn/mnzA: W8@>i O߯nVc=7}zgr|v$(6-nUP׆sh:8[ eY/͍@ǙєS 0^KעR̿w5p9te qьbIw՝Ŗ s=hKܷUr;n}ūyj@FӡՉ?p5N^{4OBY Nx!8-53rQĐh Z9n|f {)%q=4&I0r2KqAƔumvh_!]'O?L ߉7endstream endobj 82 0 obj << /Filter /FlateDecode /Length 697 >> stream xn0 ~ PeXT%+aإontdMv{Q; 9IOZL `Yt${ʞ3/YXcIΠa:@eXfs)$W|{74_}Ko6I@Q{vgG)лޜqdVp)hR*YsBLjb3ﻮ (Tw_tp&(#iqVwLzzA/s9}n2@K3UG4w4Y ÝB:zjyvU+W3`x[.sQD?[{`CCBj=IJ(,⪼7ɝ"i"oP}x^O!F9i !'GMs<{0W(vץPMZ7$'uV$MYtQ֝ @g=LiwMŷ/m?1,NNe0OHEUlDy5WiaŹ}q٨/Tmwc[4!MSz$R[ld"օx0) V!]Bː} J5NRO3#3.yO%oPațvB$:Mo"wNߓx=y \endstream endobj 83 0 obj << /Type /XRef /Length 103 /Filter /FlateDecode /DecodeParms << /Columns 4 /Predictor 12 >> /W [ 1 2 1 ] /Info 3 0 R /Root 2 0 R /Size 84 /ID [<120499356cb63a0252b38fd60b23ba2a>] >> stream xcb&F~ c%9eb` 0vi !$X$AvqHrd >o Y6 @-H~q'g  $;H032;E endstream endobj startxref 56766 %%EOF mets/inst/doc/recurrent-events.ltx0000644000176200001440000007247713623061405017031 0ustar liggesusers%\VignetteIndexEntry{Recurrent Events} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Recurrent Events} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Recurrent Events}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Overview} \label{sec:org01ebcd2} For recurrent events data it is often of interest to compute basis descriptive quantities as a first go at getting some basic understanding of the phenonmenon studied. We here demonstrate how one can compute \begin{itemize} \item the marginal mean \item the variance \item the probability of exceeding k events \end{itemize} In addition several tools can be used for simulating recurrent events and bivariate recurrent events data, in the case with a possible terminating event. We start by simulating some recurrent events data with two type of events with cumulative hazards \begin{itemize} \item \(\Lambda_1(t)\) \item \(\Lambda_2(t)\) \item \(\Lambda_D(t)\) \end{itemize} where we consider types 1 and 4 and with a rate of the terminal event given by \(\Lambda_D(t)\). We let the events be independent, but could also specify a random effects structure to generate dependence. When simulating data we can impose various random-effects structures to generate dependence \begin{itemize} \item We can draw normally distributed random effects \(Z_1,Z_2,Z_d\) were the variance (var.z) and correlation can be specified (cor.mat) (dependence=2). Then the intensities are \begin{itemize} \item \(\exp(Z_1) \lambda_1(t)\) \item \(\exp(Z_2) \lambda_2(t)\) \item \(\exp(Z_3) \lambda_D(t)\) \end{itemize} \item We can one gamma distributed random effects \(Z\). Then the intensities are (dependence=1) \begin{itemize} \item \(Z \lambda_1(t)\) \item \(Z \lambda_2(t)\) \item \(Z \lambda_D(t)\) \end{itemize} \item We can draw gamma distributed random effects \(Z_1,Z_2,Z_d\) were the sum-structure can be speicifed via a matrix cor.mat. Then we compute \(\tilde Z_j = \sum_k Z_k^{cor.mat(j,k)}\) for \(j=1,2,3\) (dependence=3) Then the intensities are \begin{itemize} \item \(\tilde Z_1 \lambda_1(t)\) \item \(\tilde Z_2 \lambda_2(t)\) \item \(\tilde Z_3 \lambda_D(t)\) \end{itemize} \item The intensities can be independent (dependence=0) \end{itemize} We return to how to run the different set-ups later and start by simulating independent processes. \subsection*{Utility functions} \label{sec:org9be05a8} We here mention two utility functions \begin{itemize} \item tie.breaker for breaking ties among jump-times which is expected in the functions below. \item count.history that counts the number of jumps previous for each subject that is \(N_1(t-)\) and \(N_2(t-)\). \end{itemize} \subsection*{Marginal Mean} \label{sec:orga8b27b9} We start by estimating the marginal mean \(E(N_1(t \wedge D))\) where \(D\) is the timing of the terminal event. This is based on a rate model for \begin{itemize} \item the type 1 events \item the terminal event \end{itemize} and is defined as \(\mu_1(t)=E(N_1^*(t))\) \begin{align} \int_0^t S(u) d R_1(u) \end{align} where \(S(t)=P(D \geq t)\) and \(dR_1(t) = E(dN_1^*(t) | D \geq t)\) and can therefore be estimated by a \begin{itemize} \item Kaplan-Meier estimator, \(\hat S(u)\) \item Nelson-Aalen estimator for \(R_1(t)\) \end{itemize} \begin{align} \hat R_1(t) & = \sum_i \int_0^t \frac{1}{Y_\bullet (s)} dN_{1i}(s) \end{align} where \(Y_{\bullet}(t)= \sum_i Y_i(t)\) such that the estimator is \begin{align} \hat \mu_1(t) & = \int_0^t \hat S(u) d\hat R_1(u). \end{align} Cook \& Lawless (1997), and developed further in Gosh \& Lin (2000). The variance can be estimated based on the asymptotic expansion of \(\hat \mu_1(t) - \mu_1(t)\) \begin{align*} & \sum_i \int_0^t \frac{S(s)}{\pi(s)} dM_{i1} - \mu_1(t) \int_0^t \frac{1}{\pi(s)} dM_i^d + \int_0^t \frac{\mu_1(s) }{\pi(s)} dM_i^d, \end{align*} with mean-zero processes \begin{itemize} \item \(M_i^d(t) = N_i^D(t)- \int_0^t Y_i(s) d \Lambda^D(s)\), \item \(M_{i1}(t) = N_{i1}(t) - \int_0^t Y_{i}(s) dR_1(s)\). \end{itemize} as in Gosh \& Lin (2000) \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) set.seed(1000) # to control output in simulatins for p-values below. data(base1cumhaz) data(base4cumhaz) data(drcumhaz) ddr <- drcumhaz base1 <- base1cumhaz base4 <- base4cumhaz rr <- simRecurrent(1000,base1,death.cumhaz=ddr) rr$x <- rnorm(nrow(rr)) rr$strata <- floor((rr$id-0.01)/500) dlist(rr,.~id| id %in% c(1,7,9)) \end{lstlisting} \begin{verbatim} id: 1 entry time status rr dtime fdeath death start stop x strata 1 0 133.1 0 1 133.1 1 1 0 133.1 1.185 0 ------------------------------------------------------------ id: 7 entry time status rr dtime fdeath death start stop x strata 7 0.0 813.3 1 1 1729 1 0 0.0 813.3 1.5495 0 1004 813.3 1288.4 1 1 1729 1 0 813.3 1288.4 1.0535 0 1658 1288.4 1315.4 1 1 1729 1 0 1288.4 1315.4 1.5330 0 2150 1315.4 1449.4 1 1 1729 1 0 1315.4 1449.4 0.8944 0 2539 1449.4 1726.1 1 1 1729 1 0 1449.4 1726.1 -0.1931 0 2851 1726.1 1729.4 0 1 1729 1 1 1726.1 1729.4 0.4081 0 ------------------------------------------------------------ id: 9 entry time status rr dtime fdeath death start stop x strata 9 0.0 433.5 1 1 5110 0 0 0.0 433.5 -0.4660 0 1006 433.5 2451.1 1 1 5110 0 0 433.5 2451.1 1.0647 0 1659 2451.1 3629.7 1 1 5110 0 0 2451.1 3629.7 -0.2506 0 2151 3629.7 3644.7 1 1 5110 0 0 3629.7 3644.7 -0.6748 0 2540 3644.7 3695.8 1 1 5110 0 0 3644.7 3695.8 0.6510 0 2852 3695.8 3890.7 1 1 5110 0 0 3695.8 3890.7 -0.2033 0 3112 3890.7 5110.0 0 1 5110 0 0 3890.7 5110.0 -1.6981 0 \end{verbatim} The status variable keeps track of the recurrent evnts and their type, and death the timing of death. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec1,caption= ,captionpos=b} \begin{lstlisting} # to fit non-parametric models with just a baseline xr <- phreg(Surv(entry,time,status)~cluster(id),data=rr) dr <- phreg(Surv(entry,time,death)~cluster(id),data=rr) par(mfrow=c(1,3)) bplot(dr,se=TRUE) title(main="death") bplot(xr,se=TRUE) # robust standard errors rxr <- robust.phreg(xr,fixbeta=1) bplot(rxr,se=TRUE,robust=TRUE,add=TRUE,col=4) # marginal mean of expected number of recurrent events out <- recurrentMarginal(xr,dr) bplot(out,se=TRUE,ylab="marginal mean",col=2) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{rec1.jpg} \end{center} \captionof{figure}{Marginal mean for number of type 1 events, rate for death (panel (a)), rate for type 1 among survivors (panel (b)), and marginal mean (panel (c)).} \label{fig:rec} \end{marginfigure} We can do the same with strata \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec2,caption= ,captionpos=b} \begin{lstlisting} xr <- phreg(Surv(entry,time,status)~strata(strata)+cluster(id),data=rr) dr <- phreg(Surv(entry,time,death)~strata(strata)+cluster(id),data=rr) par(mfrow=c(1,3)) bplot(dr,se=TRUE) title(main="death") bplot(xr,se=TRUE) rxr <- robust.phreg(xr,fixbeta=1) bplot(rxr,se=TRUE,robust=TRUE,add=TRUE,col=1:2) out <- recurrentMarginal(xr,dr) bplot(out,se=TRUE,ylab="marginal mean",col=1:2) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{rec2.jpg} \end{center} \captionof{figure}{Recurrent events} \label{fig:rec2} \end{marginfigure} Furhter, if we adjust for covariates for the two rates we can still do predictions of marginal mean, what can be plotted is the baseline marginal mean, that is for the covariates equal to 0 for both models. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec3,caption= ,captionpos=b} \begin{lstlisting} # cox case xr <- phreg(Surv(entry,time,status)~x+cluster(id),data=rr) dr <- phreg(Surv(entry,time,death)~x+cluster(id),data=rr) par(mfrow=c(1,3)) bplot(dr,se=TRUE) title(main="death") bplot(xr,se=TRUE) rxr <- robust.phreg(xr) bplot(rxr,se=TRUE,robust=TRUE,add=TRUE,col=1:2) out <- recurrentMarginal(xr,dr) bplot(out,se=TRUE,ylab="marginal mean",col=1:2) # predictions witout se's outX <- recmarg(xr,dr,Xr=1,Xd=1) bplot(outX,add=TRUE,col=3) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{rec3.jpg} \end{center} \captionof{figure}{Recurrent events with cox models for rates.} \label{fig:rec3} \end{marginfigure} \subsection*{Other marginal properties} \label{sec:org2fcaab7} \begin{itemize} \item \(P(N_1^*(t) \ge k)\) \begin{itemize} \item cumulative incidence of \(T_{k} = \inf \{ t: N_1^*(t)=k \}\) with competing \(D\). \end{itemize} \end{itemize} We note also that \(N_1^*(t)^2\) can be written as \begin{align*} \sum_{k=0}^K \int_0^t I(D > s) I(N_1^*(s-)=k) f(k) dN_1^*(s) \end{align*} with \(f(k)=(k+1)^2 - k^2\), such that its mean can be written as \begin{align*} \sum_{k=0}^K \int_0^t S(s) f(k) P(N_1^*(s-)= k | D \geq s) E( dN_1^*(s) | N_1^*(s-)=k, D> s) \end{align*} and estimated by \begin{align*} \hat \mu_{1,2}(t) & = \sum_{k=0}^K \int_0^t \hat S(s) f(k) \frac{Y_{1\bullet}^k(s)}{Y_\bullet (s)} \frac{1}{Y_{1\bullet}^k(s)} d N_{1\bullet}^k(s)= \sum_{i=1}^n \int_0^t \hat S(s) f(N_{i1}(s-)) \frac{1}{Y_\bullet (s)} d N_{i1}(s), \end{align*} Compared to "product-limit" estimator for \(E( (N_1^*(t))^2 )\) \begin{align} \hat \mu_{1,2}(t) & = \sum_{k=0}^K k^2 ( \hat F_{k}(t) - \hat F_{k+1}(t) ). \end{align} Probabilty of exceeding "k" Note also that \(I(N_1^*(t) \geq k)\) is \begin{align*} \int_0^t I(D > s) I(N_1^*(s-)=k-1) dN_1^*(s), \end{align*} suggesting that its mean can be computed as \begin{align*} \int_0^t S(s) P(N_1^*(s-)= k-1 | D \geq s) E( dN_1^*(s) | N_1^*(s-)=k-1, D> s) \end{align*} and estimated by \begin{align*} \tilde F_k(t) = \int_0^t \hat S(s) \frac{Y_{1\bullet}^{k-1}(s)}{Y_\bullet (s)} \frac{1}{Y_{1\bullet}^{k-1}(s)} d N_{1\bullet}^{k-1}(s). \end{align*} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec4,caption= ,captionpos=b} \begin{lstlisting} cor.mat <- corM <- rbind(c(1.0, 0.6, 0.9), c(0.6, 1.0, 0.5), c(0.9, 0.5, 1.0)) rr <- simRecurrent(1000,base1,cumhaz2=base4,death.cumhaz=ddr) rr <- count.history(rr) dtable(rr,~death+status) oo <- prob.exceedRecurrent(rr,1) bplot(oo) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{rec4.jpg} \end{center} \captionof{figure}{Recurrent events: probability of exceeding k events} \label{fig:rec4} \end{marginfigure} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec4,caption= ,captionpos=b} \begin{lstlisting} cor.mat <- corM <- rbind(c(1.0, 0.6, 0.9), c(0.6, 1.0, 0.5), c(0.9, 0.5, 1.0)) rr <- simRecurrent(1000,base1,cumhaz2=base4,death.cumhaz=ddr) rr <- count.history(rr) dtable(rr,~death+status) oo <- prob.exceedRecurrent(rr,1) bplot(oo) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{rec4MV.jpg} \end{center} \captionof{figure}{Recurrent events: probability of exceeding k events} \label{fig:rec4MV} \end{marginfigure} Mean and variance of number of recurrent events \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec4MV,caption= ,captionpos=b} \begin{lstlisting} par(mfrow=c(1,2)) with(oo,plot(time,mu,col=2,type="l")) # with(oo,plot(time,varN,type="l")) \end{lstlisting} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec4Bi,caption= ,captionpos=b} \begin{lstlisting} # Bivariate probability of exceeding oo <- prob.exceedBiRecurrent(rr,1,2,exceed1=c(1,5,10),exceed2=c(1,2,3)) with(oo, matplot(time,pe1e2,type="s")) nc <- ncol(oo$pe1e2) legend("topleft",legend=colnames(oo$pe1e2),lty=1:nc,col=1:nc) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{rec4Bi.jpg} \end{center} \captionof{figure}{Recurrent events: probability of exceeding k events} \label{fig:rec4Bi} \end{marginfigure} \subsection*{Dependence between events: Covariance} \label{sec:org0e76a6d} Covariance among two types of events \begin{align} \rho(t) & = \frac{ E(N_1^*(t) N_2^*(t) ) - \mu_1(t) \mu_2(t) }{ \mbox{sd}(N_1^*(t)) \mbox{sd}(N_2^*(t)) } \end{align} where \begin{itemize} \item \(E(N_1^*(t) N_2^*(t))\). \end{itemize} \begin{align*} E(N_1^*(t) N_2^*(t)) & = E( \int_0^t N_1^*(s-) dN_2^*(s) ) + E( \int_0^t N_2^*(s-) dN_1^*(s) ) \end{align*} Recall that \(N_1^*(t \wedge D)\) and \(N_2^*(t \wedge D)\). \begin{align*} E(\int_0^t N_1^*(s-) dN_2^*(s) ) & = \sum_k E( \int_0^t k I(N_1^*(s-)=k) I(D \geq s) dN_2^*(s) ) \end{align*} \begin{align*} = \sum_k \int_0^t S(s) k P(N_1^*(s-)= k | D \geq s) E( dN_2^*(s) | N_1^*(s-)=k, D \geq s) \end{align*} estimated by \begin{align*} & \sum_k \int_0^t \hat S(s) k \frac{Y_1^k(s)}{Y_\bullet (s)} \frac{1}{Y_1^k(s)} d \tilde N_{2,k}(s), \end{align*} \begin{itemize} \item \(Y_j^k(t) = \sum Y_i(t) I( N_{ji}^*(s-)=k)\) for \(j=1,2\), \item \(\tilde N_{j,k}(t) = \sum_i \int_0^t I(N_{ij^o}(s-)=k) dN_{ij}(s)\) \end{itemize} Estimate of \$ E(N\(_{\text{1}}^{\text{*}}\)(t) N\(_{\text{2}}^{\text{*}}\)(t))\$ \begin{align*} \sum_k \int_0^t \hat S(s) k \frac{Y_1^k(s)}{Y_\bullet (s)} \frac{1}{Y_1^k(s)} d \tilde N_{2,k}(s) + \sum_k \int_0^t \hat S(s) k \frac{Y_2^k(s)}{Y_\bullet (s)} \frac{1}{Y_2^k(s)} d \tilde N_{1,k}(s). \end{align*} \begin{itemize} \item Without terminating event covariance is useful nonpar measure \item With terminating event dependence generated by terminating event. \item In reality what is of interest would be independence among survivors \begin{itemize} \item if \(N_1\) not predicitive for \(N_2\) \end{itemize} \begin{align} E( dN_2^*(t) | N_1^*(t-)=k, D \geq t) = E( dN_2^*(t) | D \geq t) \end{align} \begin{itemize} \item if \(N_2\) not predicitive for \(N_1\) \end{itemize} \begin{align} E( dN_1^*(t) | N_2^*(t-)=k, D \geq t) = E( dN_1^*(t) | D \geq t) \end{align} \end{itemize} If the two processes are independent among survivors then \begin{align} E( dN_2^*(t) | N_1^*(t-)=k, D \geq t) = E( dN_2^*(t) | D \geq t) \end{align} so \begin{align*} E( \int_0^t N_1^*(s-) dN_2^*(s) ) & = \int_0^t S(s) E(N_1^*(s-) | D \geq s) E( dN_2^*(s) | D \geq s) \end{align*} and \begin{align*} \int_0^t \hat S(s) \{ \sum_k k \frac{Y_1^k(s)}{Y_\bullet (s)} \} \frac{1}{Y_\bullet (s)} dN_{2\bullet}(s), \end{align*} where \(N_{j\bullet}(t) = \sum_i \int_0^t dN_{j,i}(s)\). Under the independence \(E(N_1^*(t) N_2^*(t))\) is estimated \begin{align*} \int_0^t \hat S(s) \{ \sum_k k \frac{Y_1^k(s)}{Y_\bullet (s)} \} \frac{1}{Y_\bullet (s)} dN_{2\bullet}(s) + \int_0^t \hat S(s) \{ \sum_k k \frac{Y_2^k(s)}{Y_\bullet (s)} \} \frac{1}{Y_\bullet (s)} dN_{1\bullet}(s). \end{align*} Both estimators, \(\hat E(N_1^*(t) N_2^*(t))\) and \(\hat E_I(N_1^*(t) N_2^*(t))\), as well as \(\hat E(N_1^*(t))\) and \(\hat E(N_2^*(t))\), have asymptotic expansions that can be written as a sum of iid processes, similarly to the arguments of Ghosh \& Lin 2000, \(\sum_i \Psi_i(t)\). We can thus estimate the standard errors and of the estimators and their difference \(\hat E(N_1^*(t) N_2^*(t))- \hat E_I(N_1^*(t) N_2^*(t))\). Terms for \begin{itemize} \item N1 -> N2 : \(E( \int_0^t N_1^*(s-) dN_2^*(s) )\) \item N2 -> N1 : \(E( \int_0^t N_2^*(s-) dN_1^*(s) )\) \end{itemize} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec5,caption= ,captionpos=b} \begin{lstlisting} rr$strata <- 1 dtable(rr,~death+status) covrp <- covarianceRecurrent(rr,1,2,status="status",death="death", start="entry",stop="time",id="id",names.count="Count") par(mfrow=c(1,3)) plot(covrp) # with strata, each strata in matrix column, provides basis for fast Bootstrap covrpS <- covarianceRecurrentS(rr,1,2,status="status",death="death", start="entry",stop="time",strata="strata",id="id",names.count="Count") \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{rec5.jpg} \end{center} \captionof{figure}{Covariance between events} \label{fig:rec5} \end{marginfigure} \subsection*{Bootstrap standard errors for terms} \label{sec:orgc567a4f} First fitting the model again to get our estimates of interst, and then computing them for some specific time-points \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} times <- seq(500,5000,500) coo1 <- covarianceRecurrent(rr,1,2,status="status",start="entry",stop="time") # mug <- Cpred(cbind(coo1$time,coo1$EN1N2),times)[,2] mui <- Cpred(cbind(coo1$time,coo1$EIN1N2),times)[,2] mu2.1 <- Cpred(cbind(coo1$time,coo1$mu2.1),times)[,2] mu2.i <- Cpred(cbind(coo1$time,coo1$mu2.i),times)[,2] mu1.2 <- Cpred(cbind(coo1$time,coo1$mu1.2),times)[,2] mu1.i <- Cpred(cbind(coo1$time,coo1$mu1.i),times)[,2] cbind(mu2.1,mu2.i) cbind(mu1.2,mu1.i) \end{lstlisting} \begin{verbatim} mu2.1 mu2.i [1,] 0.04101096 0.03656491 [2,] 0.09303668 0.08572694 [3,] 0.22613687 0.21906324 [4,] 0.35727148 0.34562539 [5,] 0.60258982 0.59071900 [6,] 0.80089841 0.79020220 [7,] 1.03031183 1.03424672 [8,] 1.16860632 1.16686717 [9,] 1.25782175 1.25105963 [10,] 1.38716306 1.40250244 mu1.2 mu1.i [1,] 0.03501045 0.03259566 [2,] 0.08803686 0.08526834 [3,] 0.16709531 0.16634828 [4,] 0.27720710 0.29485672 [5,] 0.38034407 0.41985665 [6,] 0.53057410 0.56459585 [7,] 0.69387628 0.72234676 [8,] 0.87226707 0.88771625 [9,] 0.96949736 0.99728527 [10,] 1.06074066 1.06854228 \end{verbatim} To get the bootstrap standard errors there is a quick memory demanding function (with S for speed and strata) BootcovariancerecurrenceS and slow function that goes through the loops in R Bootcovariancerecurrence. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} bt1 <- BootcovariancerecurrenceS(rr,1,2,status="status",start="entry",stop="time",K=100,times=times) #bt1 <- BootcovariancerecurrenceS(rr,1,2,status="status",start="entry",stop="time",K=K,times=times) output <- list(bt1=bt1,mug=mug,mui=mui, bse.mug=bt1$se.mug,bse.mui=bt1$se.mui, dmugi=mug-mui, bse.dmugi=apply(bt1$EN1N2-bt1$EIN1N2,1,sd), mu2.1 = mu2.1 , mu2.i = mu2.i , dmu2.i=mu2.1-mu2.i, mu1.2 = mu1.2 , mu1.i = mu1.i , dmu1.i=mu1.2-mu1.i, bse.mu2.1=apply(bt1$mu2.i,1,sd), bse.mu2.1=apply(bt1$mu2.1,1,sd), bse.dmu2.i=apply(bt1$mu2.1-bt1$mu2.i,1,sd), bse.mu1.2=apply(bt1$mu1.2,1,sd), bse.mu1.i=apply(bt1$mu1.i,1,sd), bse.dmu1.i=apply(bt1$mu1.2-bt1$mu1.i,1,sd) ) \end{lstlisting} We then look at the test for overall dependence in the different time-points. We here have no suggestion of dependence. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} tt <- output$dmugi/output$bse.dmugi cbind(times,2*(1-pnorm(abs(tt)))) \end{lstlisting} \begin{verbatim} times [1,] 500 0.3572253 [2,] 1000 0.4577012 [3,] 1500 0.7136132 [4,] 2000 0.7956959 [5,] 2500 0.3837459 [6,] 3000 0.5134406 [7,] 3500 0.4209237 [8,] 4000 0.7632914 [9,] 4500 0.6836682 [10,] 5000 0.6598813 \end{verbatim} We can also take out the specific components for whether \(N_1\) is predictive for \(N_2\) and vice versa. We here have no suggestion of dependence. \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} t21 <- output$dmu1.i/output$bse.dmu1.i t12 <- output$dmu2.i/output$bse.dmu2.i cbind(times,2*(1-pnorm(abs(t21))),2*(1-pnorm(abs(t12)))) \end{lstlisting} \begin{verbatim} times [1,] 500 0.71706002 0.3918872 [2,] 1000 0.81454942 0.3202626 [3,] 1500 0.95715638 0.6006314 [4,] 2000 0.21300406 0.4942293 [5,] 2500 0.02182129 0.6086128 [6,] 3000 0.11688970 0.6805457 [7,] 3500 0.25587816 0.8965495 [8,] 4000 0.63373150 0.9578608 [9,] 4500 0.41743073 0.8548733 [10,] 5000 0.83041113 0.6805618 \end{verbatim} We finally plot the boostrap samples \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec6,caption= ,captionpos=b} \begin{lstlisting} par(mfrow=c(1,2)) matplot(bt1$time,bt1$EN1N2,type="l",lwd=0.3) matplot(bt1$time,bt1$EIN1N2,type="l",lwd=0.3) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{rec6.jpg} \end{center} \captionof{figure}{Bootstrap samples} \label{fig:rec6} \end{marginfigure} \subsection*{Looking at other simulations with dependence} \label{sec:orga99167a} Using the normally distributed random effects we plot 4 different settings. We have variance \(0.5\) for all random effects and change the correlation. We let the correlation between the random effect associated with \(N_1\) and \(N_2\) be denoted \(\rho_{12}\) and the correlation between the random effects associated between \(N_j\) and \(D\) the terminal event be denoted as \(\rho_{j3}\), and organize all correlation in a vector \(\rho=(\rho_{12},\rho_{13},\rho_{23})\). \begin{itemize} \item Scenario I \(\rho=(0,0.0,0.0)\) Independence among all efects. \item Scenario II \(\rho=(0,0.5,0.5)\) Independence among survivors but dependence on terminal event \item Scenario III \(\rho=(0.5,0.5,0.5)\) Positive dependence among survivors and dependence on terminal event \item Scenario IV \(\rho=(-0.4,0.5,0.5)\) Negative dependence among survivors and positive dependence on terminal event \end{itemize} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=rec7,caption= ,captionpos=b} \begin{lstlisting} par(mfrow=c(2,2)) data(base1cumhaz) data(base4cumhaz) data(drcumhaz) dr <- drcumhaz base1 <- base1cumhaz base4 <- base4cumhaz var.z <- c(0.5,0.5,0.5) # death related to both causes in same way cor.mat <- corM <- rbind(c(1.0, 0.0, 0.0), c(0.0, 1.0, 0.0), c(0.0, 0.0, 1.0)) rr <- simRecurrentII(3000,base1,base4,death.cumhaz=dr,var.z=var.z,cor.mat=cor.mat,dependence=2) rr <- count.history(rr,types=1:2) cor(attr(rr,"z")) coo <- covarianceRecurrent(rr,1,2,status="status",start="entry",stop="time") par(mfrow=c(2,2)) with(coo, { plot(time, EN1N2, type = "l", lwd = 2,lty=1,ylab="",xlab="time (a)") lines(time, EN1EN2, col = 2, lwd = 2,lty=2) lines(time, EIN1N2, col = 3, lwd = 2,lty=3) }) legend("topleft", c("E(N1N2)", "E(N1) E(N2) ", "E_I(N1 N2)-independence"),lty = 1:3, col = 1:3) title(main ="Scenario I") var.z <- c(0.5,0.5,0.5) # death related to both causes in same way cor.mat <- corM <- rbind(c(1.0, 0.0, 0.5), c(0.0, 1.0, 0.5), c(0.5, 0.5, 1.0)) rr <- simRecurrentII(3000,base1,base4,death.cumhaz=dr, var.z=var.z,cor.mat=cor.mat,dependence=2) rr <- count.history(rr,types=1:2) coo <- covarianceRecurrent(rr,1,2,status="status",start="entry",stop="time") with(coo, { plot(time, EN1N2, type = "l", lwd = 2,lty=1,ylab="",xlab="time (b)") lines(time, EN1EN2, col = 2, lwd = 2,lty=2) lines(time, EIN1N2, col = 3, lwd = 2,lty=3) }) legend("topleft", c("E(N1N2)", "E(N1) E(N2) ", "E_I(N1 N2)-independence"),lty = 1:3, col = 1:3) title(main ="Scenario II") var.z <- c(0.5,0.5,0.5) # positive dependence for N1 and N2 all related in same way cor.mat <- corM <- rbind(c(1.0, 0.5, 0.5), c(0.5, 1.0, 0.5), c(0.5, 0.5, 1.0)) rr <- simRecurrentII(3000,base1,base4,death.cumhaz=dr, var.z=var.z,cor.mat=cor.mat,dependence=2) rr <- count.history(rr,types=1:2) coo <- covarianceRecurrent(rr,1,2,status="status",start="entry",stop="time") with(coo, { plot(time, EN1N2, type = "l", lwd = 2,lty=1,ylab="",xlab="time (d)") lines(time, EN1EN2, col = 2, lwd = 2,lty=2) lines(time, EIN1N2, col = 3, lwd = 2,lty=3) }) legend("topleft", c("E(N1N2)", "E(N1) E(N2) ", "E_I(N1 N2)-independence"),lty = 1:3, col = 1:3) title(main ="Scenario III") var.z <- c(0.5,0.5,0.5) # negative dependence for N1 and N2 all related in same way cor.mat <- corM <- rbind(c(1.0, -0.4, 0.5), c(-0.4, 1.0, 0.5), c(0.5, 0.5, 1.0)) rr <- simRecurrentII(3000,base1,base4,death.cumhaz=dr, var.z=var.z,cor.mat=cor.mat,dependence=2) rr <- count.history(rr,types=1:2) coo <- covarianceRecurrent(rr,1,2,status="status",start="entry",stop="time") with(coo, { plot(time, EN1N2, type = "l", lwd = 2,lty=1,ylab="",xlab="time (d)") lines(time, EN1EN2, col = 2, lwd = 2,lty=2) lines(time, EIN1N2, col = 3, lwd = 2,lty=3) }) legend("topleft", c("E(N1N2)", "E(N1) E(N2) ", "E_I(N1 N2)-independence"),lty = 1:3, col = 1:3) title(main ="Scenario IV") \end{lstlisting} \begin{figure} \begin{center} \includegraphics[width=\textwidth]{rec7.jpg} \end{center} \captionof{figure}{Bootstrap samples} \label{fig:rec7} \end{figure} \end{document}mets/inst/doc/competing.ltx0000644000176200001440000006502313623061405015470 0ustar liggesusers%\VignetteIndexEntry{Analysis of multivariate competing riks data} %\VignetteEngine{R.rsp::tex} %\VignetteKeyword{R} %\VignetteKeyword{package} %\VignetteKeyword{vignette} %\VignetteKeyword{LaTeX} \PassOptionsToPackage{usenames}{xcolor} \PassOptionsToPackage{hidelinks,colorlinks,linkcolor={blue!50!black},urlcolor={blue!50!black},citecolor={blue!50!black}}{hyperref} \documentclass[a4paper]{tufte-handout} \usepackage{etex} \usepackage{etoolbox} \usepackage[utf8]{inputenc} \usepackage[T1]{fontenc} \usepackage{mathtools} \usepackage[strict=true]{csquotes} \usepackage{xcolor} \usepackage{natbib} \usepackage{amsmath,amssymb,textcomp} \usepackage{bm} \usepackage{graphicx} \usepackage{wrapfig} \usepackage{rotating} \usepackage{capt-of} \usepackage{listings} \usepackage{booktabs} \usepackage{multicol} \usepackage{longtable} \usepackage{zlmtt} \usepackage{float} \usepackage{fancyvrb} \usepackage{verbatim} \usepackage[english]{babel} \usepackage{hyperref} \usepackage{environ} \NewEnviron{mnote}{\marginnote{\BODY}} \NewEnviron{snote}{\sidenote{\BODY}} \usepackage{xspace} \usepackage{url} \usepackage{amsthm} \newtheorem{thm}{Theorem.} \newtheorem{prop}{Proposition.} \theoremstyle{definition} \newtheorem{defn}[thm]{Definition.} \newtheorem{exa}[thm]{Example} \newcommand{\R}{\ensuremath{\mathbb{R}}} \newcommand{\Real}{\ensuremath{\mathbb{R}}} \newcommand{\Complex}{\ensuremath{\mathbb{C}}} \newcommand{\Z}{\ensuremath{\mathbb{Z}}} \newcommand{\N}{\ensuremath{\mathbb{N}}} \newcommand{\norm}[1]{\ensuremath{\left\Vert#1\right\Vert}} \newcommand{\var}{\ensuremath{\mathbb{V}\text{ar}}} \newcommand{\cov}{\ensuremath{\mathbb{C}\text{ov}}} \newcommand{\cor}{\ensuremath{\mathbb{C}\text{or}}} \newcommand{\E}{\ensuremath{\mathbb{E}}} \newcommand{\pr}{\ensuremath{\mathbb{P}}} \newcommand{\from}{\leftarrow} \newcommand{\To}[2]{\ensuremath{#1\!\to\!#2}} \newcommand{\From}[2]{\ensuremath{#1\!\from\!#2}} \newcommand{\chain}[3]{\ensuremath{#1\!\to\!#2\to\!#3}} \newcommand{\ichain}[3]{\ensuremath{#1\!\from\!#2\from\!#3}} \newcommand{\fork}[3]{\ensuremath{#1\!\from\!#2\to\!#3}} \newcommand{\ifork}[3]{\ensuremath{#1\!\to\!#2\from\!#3}} \newcommand{\pa}{\text{pa}} \newcommand{\abs}[1]{\ensuremath{\left\vert#1\right\vert}} \newcommand{\ipr}[1]{\langle#1\rangle} \newcommand{\set}[1]{\left{#1\right}} \newcommand{\seq}[1]{\left<#1\right>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Analysis of multivariate competing risks data} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Analysis of multivariate competing risks data}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Overview} \label{sec:orgbe56752} \begin{itemize} \item marginal modelling with standard errors cif, \item cause specific hazards \item cumulative incidence modelling \begin{itemize} \item random effects simple cif \item Luise model \end{itemize} \end{itemize} When looking at multivariate survival data with the aim of learning about the dependence that is present, possibly after correcting for some covariates different approaches are available in the mets package \begin{itemize} \item Binary models and adjust for censoring with inverse probabilty of censoring weighting \item Bivariate surival models of Clayton-Oakes type \begin{itemize} \item With regression structure on dependence parameter \item With additive gamma distributed random effects \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \item Plackett OR model model \begin{itemize} \item With regression structure on OR dependence parameter \end{itemize} \item Cluster stratified Cox \end{itemize} Typically it can be hard or impossible to specify random effects models with special structure among the parameters of the random effects. This is possible for our specification of the random effects models. To be concrete about the model structure assume that we have paired binomial data \(T_1, \delta_1, T_2, \delta_2, X_1, X_2\) where the censored survival responses are \(T_1, \delta_1, T_2, \delta_2\) and we have covariates \(X_1, X_2\). The focus of this vignette is describe how to work on bivariate survival data using the addtive gamma-random effects models. We present two different ways of specifying different dependence structures. The basic models assumes that each subject has a marginal on Cox-form \[ \lambda_0(t) \exp( X_{ki}^T \beta) \] then two types of models can be considered. \begin{itemize} \item Univariate models with a single random effect for each cluster and with a regression design on the varince. \item Multivariate models with multiple random effects for each cluster. \end{itemize} The univariate models are then given a given cluster random effects \(Z_k\) with parameter \(\theta\) the joint survival function is given by the Clayton copula and on the form \[ \psi(\theta, \psi^{-1}(\theta,S_1(t,X_{k1}) ) + \psi^{-1}(\theta, S_1(t,X_{k1}) ) \] where \(\psi\) is the Laplace transform of a gamma distributed random variable with mean 1 and variance \(\theta\). We then model the variance within clusters by a cluster specific regression design such that \[ \theta = z_j^T \alpha \] where \(z\) is the regression design (specified by theta.des in the software). This model can be fitted using a pairwise likelihood or the pseudo-likelihood using either \begin{itemize} \item twostage \item twostageMLE \end{itemize} For the Multivariate models we are given a multivarite random effect each subject \((Z_1,...,Z_d)\) with d random effects. The total random effect for each subject is then specified using a regression design on these random effects, with a regression vector \(v_j\) such that the total random effect is \{v\(_{\text{1}}^{\text{T}}\) (Z\(_{\text{1,\ldots{},Z}}\)\(_{\text{d}}\))\}. Each random effect has an associated parameter \((\lambda_1,...,\lambda_d)\) and \(Z_j\) is Gamma distributed with \begin{itemize} \item mean \(lambda_j/v_1^T \lambda\) \item variance $\backslash$( \(\lambda_{\text{j}}\)/(v\(_{\text{1}}^{\text{T}}\) \(\lambda\))\(^{\text{2}}\)\}. \end{itemize} The key assumption to make the two-stage fitting possible is that \[ lamtot=v_j^T \lambda \] with clusters. The DEFAULT parametrization (var.par=1) uses the variances of the random effecs \[ \theta_j = \lambda_j/(v_1^T \lambda)^2 \] For alternative parametrizations one can specify how the parameters relate to \(\lambda_j\) with the argument var.par=0. For both types of models the basic model assumptions are that given the random effects of the clusters the survival distributions within a cluster are independent and ' on the form \[ P(T > t| x,z) = exp( -Z \cdot Laplace^{-1}(lamtot^{-1},S(t|x)) ) \] with the inverse laplace of the gamma distribution with mean 1 and variance 1/lamtot. Finally the parameters \((\lambda_1,...,\lambda_d)\) are related to the parameters of the model by a regression construction \(M\) (d x k), that links the \(d\) \(\lambda\) parameters with the \(k\) underlying \(\alpha\) parameters \[ \lambda = M \alpha \] here using theta.des to specify these low-dimension association. Default is a diagonal matrix. This can be used to make structural assumptions about the variances of the random-effects as is needed for the ACE model for example. In software \(M\) is called theta.des We consider \(K\) independent clusters, with \(n_k\) subject within each cluster. For each cluster we are given a set of independent random effects \(V = (V_1,\dots , V_m)^T\). We let \((V_1,\dots,V_m)^T\) be independent Gamma distributed with \(V_l \sim \Gamma(\eta_l , \nu_l), l = 1,\dots,p\) independent gamma distributed random variables such that \(E(V_l) = \eta_l /\nu\) and \(Var(V_l ) = \eta_l /\nu^2\). \%\%Let \(\nu =(\nu_1,\dots,\nu_p)\). The \(\eta=(\eta_1,\dots,\eta_m)\) parameters are given such that \(\eta=D \theta\). Letting the rows in the matrix be denoted as \(Q_i,\dots,Q_m\). \%\%\%As is commonly done \cite{korsgaard1998additive,petersen1998additive} To facilitate our two-stage construction we also assume that \(\nu=Q_i^T \eta\) for all \(i=1,\dots,n_k\) such that \(Q_i^T V\) is also Gamma distributed with \(\Gamma(1, \nu)\), that is has variance \(\nu^{-1}\) and mean 1. We get back to specific models where this is the case, but this assumption is often reasonable and needed \cite{korsgaard1998additive,petersen1998additive} Let \(\Psi(\eta_l,\nu,\cdot)\) denote the Laplace transform of the Gamma distribution \(\Gamma(\eta_l,\nu)\), and let its inverse be \(\Psi^{-1}(\eta_l,\nu,\cdot)\). For simplicity we also assume that \(\eta\) is the same across clusters. Assume that the marginal survival distribution for subject \(i\) within cluster \(k\) is given by \(S_{X_{k,i}}(t)\) given covariates \(X_{k,i}\). Now given the random effects of the cluster \(V_k\) and the covariates\(X_{k,i}\) \(i=1,\dots,n_k\) we assume that subjects within the cluster are independent with survival distributions \begin{align*} \exp(- ( Q_{k,i} V_k) \Psi^{-1} (\nu,\nu,S_{X_{k,i}}(t)) ). \end{align*} A consequence of this is that the hazards given the covariates \(X_{k,i}\) and the random effects \(V_k\) are given by \begin{align} \lambda_{k,i}(t;X_{k,i},V_{k,i}) = ( Q_{k,i} V_k) D_3 \Psi^{-1} (\nu,\nu,S_{X_{k,i}}(t)) D_t S_{X_{k,i}}(t) \label{eq-cond-haz} \end{align} where \(D_t\) and \(D_3\) denotes the partial derivatives with respect to \(t\) and the third argument, respectively. Further, we can express the multivariate survival distribution as \begin{align} S(t_1,\dots,t_m) & = \exp( -\sum_{i=1}^m (Q_i V) \Psi^{-1}(\eta_l,\nu_l,S_{X_{k,i}}(t_i)) ) \nonumber \\ & = \prod_{l=1}^p \Psi(\eta_l,\eta , \sum_{i=1}^m Q_{k,i} \Psi^{-1}(\eta,\eta,S_{X_{k,i}}(t_i))). \label{eq-multivariate-surv} \end{align} In the case of considering just pairs, we write this function as \(C(S_{k,i}(t),S_{k,j}(t))\). In addition to survival times from this model, we assume that we independent right censoring present \(U_{k,i}\) such that the given \(V_k\) and the covariates\(X_{k,i}\) \(i=1,\dots,n_k\) \((U_{k,1},\dots,U_{k,n_k})\) of \((T_{k,1},\dots,T_{k,n_k})\), and the conditional censoring distribution do not depend on \(V_k\). We can also express this via counting processes \(N_{k,i}(t)=I(T_{k,i}t,U_{k,i}>t)\), and the censoring indicators \(\delta_{k,i}=I(T_{k,i}> stream xZ[SH~_oTZRkk*U`ɀ$LAhb,b2~-Y72B>:by̗Ld>zXhBfTBI_`2p +11ODI<ItfB&EBu(͈ha~Latb2 &|#,0g +%9ʰPXB`!M*q=PfaY ~FËB20c1VL d&`^H^9|/"W, Xaƫ a1Rx Ox_HAB0` q !>(KAYz@p(hh|wƇI&k;dwfsMrs#"#!йu7BU>ϸ_q47$l {EC4xY _ Wӯ!\wYy5ƄxBWgdFqݣQl>^`f{6Q2g/ώmyzhGp+4&嫑(ðSR+]I{_dYwG)8%;܆n0xig0?})ʊ,Ofn,gx/{M;pB ig"[GG<9K9~ȓS; g$e~v$_sV27d$SOφLˤ]V]./_~8QgjuNjTň&D/$XId/.}!?g_c'E<k>.c><_='c&7+iN> %?eb 4,(X=9Ox%k?H U~% OG `@gȓ {Y"*dZb9q::]45)ZE3ҌuD YPPl%f ?<+J]WDFViu?xoh8"EX؎.?~4. +Nˈ TݟC@*=ALܽ|j#frQ+\ ቆB{D='Bf(c4A0DHbhD:|aēlaSi)yܒgC{ g-A~??TI5!zo҇5>P;/PyǣIna(; &f'qhoE W 6 i ij-hkmՙlUӓwbV<,s5z zRQH˫kM֍ӏǧIwT}n& #c.ɵiN sx$ ɷe<]!(h -yK IbatMa*`m*.6} 'I('.^z}[6=8l{&_󷻰OC6Z.:uיΧn uK4hkGgf]R:.]ڥD;D ")JV\xOo/g&kܼ*=νثDj{oȬ*pM7Z_Wv_~`yPLi..iؚONbe{m54u+x2ІZ_-eKQ[7ڞ#e~\_ ~~{Duؽ Ǯ7`oV[}X.ݽ1QÐLciIS) D$\'Ab~ԁN ` gzFkg'%4Fܽ0fJe>Lևt7? hbD "=B y{VN;ʶ޷('Q$(q28+%ceYqkQ訵(:fueD YU9ʱvg,'M+Lv>Ws6R3ww$΂թ;+dڳl\NW,8 W>3/ vގ -SyNSɼ@5bZ;t&jPϕ%OV̔Ow2 kwP }Kҷbcq Z=֍pᭌ}jRtbOzYSAiXDMf]{YO6۽)VJY<?a3O/l+2{+bD.!-tL"9 =h:Z$E髝!š9Ư*I+lO P˳~Z] `?lֻǕ K}8& Z·DocGg+*N-!Z;m ۩_rti=H'wqL\M>Qh5oDOd1!促7雫u@]m oNQ$Ցu#F]E׽t2EXzl|GU`C?$MZkMDO>]).-6tJ ,G44Lݦuq{eM)4|/o l\ >S}Z5e`kՇ<}K|5YkM/ d쏤M7W"zUQ: E  f\ Lc-P{y:Z>@Dr=7endstream endobj 61 0 obj << /Subtype /XML /Type /Metadata /Length 1603 >> stream GPL Ghostscript 9.27 2020-02-18T23:23:37+01:00 2020-02-18T23:23:37+01:00 Emacs 26.1 (Org mode 9.1.14) Twin analysisKlaus Holst & Thomas Scheike endstream endobj 62 0 obj << /Filter /FlateDecode /Length 3163 >> stream xZ[s6~7 MЎw }Hoi6~jCKZ"Ur=T(;5<&spy^'tTZ)ci8 n?){,h]ۢvB[T+u_R(޿l}W7e C]m3x_VF]4a'y1e$ow EM'6r3-B5}G`XB=<Ɛ@Ih1$ c`TK T]XTdfdž/BXG o2,(F"6%PG@F*chCMb+%Oi mS^6PI(j7S8$٧o}*b1G3 K~OSҧ=Vﺲ .o/U !sX"17IV;6+jZ1qf VBŠC)[,lҌWДM %sM>yִ`j6_0w$%,j|)֡Ht*Q')x"0cu//{ ?n> ;`0f ހ`K׬s loriPbEpp]Wà0ihau'$@*:Nf4-Q.6wD5L-%҂?>'S4l%lP8;R?}5]'T s9y N>ʠJ>UG?2fv„0_O1]G%36gUfDڪfՃ`+;Wi$*)r#%3O.2VuՕվkkCkU UV M1#~r[@3"PX *̷e+SEv"uh$DIOfrgXxe߄ϰrOaߢ˼KHDt^5=iղY(GŮn^JI˻su1\09^l #`mmcBğ>!)dLx a%sC1@@s,- -o ed(mٴ`M3:1!ԆD  pT@BNr*c"OxưuiNRi#8$fFD?ܖ'8LNs%cUBYn|}Y VAk$%0c{W3B9B&mg=/vyS5PDolqXcskG@L :8$`5.?A((ALM($NNb%Ǝ@$}`wa3tZ3iXLXA]jS i0vS$$fkd/@^EIsŠdcG+ѱ[jP ryPj t'-\O,n=a NjdّD㇡~4PHб6Z?H TO}Ȱ$Ԅ~g }4LLwQW0Ūζ?{#H>OB^S7a94 *0EMe ȷ}oyB:RO%Hy xb I Lu4^O(]2aA"܍7!ت%DYvq(;oKGG2[ ?ղI/T@ UB"oZP6 " ?[yP_hUꐚ@F/\5]^CCsDO[.i}[8% `j΁2 q6bSq,GHodD|/}g#gwysid `cϦ6=ʄ2> stream xxyXSWw(&\4{똤X[ZmujUT\ADB@H +!,vnnB6 AV\pi^[[c[tig:=a>l;μ>rs]N c=Yw$%"iW"c"'2'^F#~9q9ϭ'gD`z,>%?̚}`}O3t4|;~rk(;G_|r~Z\-ETB _(Q<)9B~H,ٖ6l eb~2C,DD.|%w LB$ȟ毒@^  BYH.G"9?[.Q3 )_$YR_ (+@G+&]gtEt]=K/3e4??S$rBX!gt Z*&$Z}_&NeɸQTu>]N/(k&ߕNE P4~e_? U5)k67gh[2۲svvϝQ6F"cqvced~~`JCƪ2CE_j9R7\}]aHTH?]vgjuzD0G*JZ :GcƪU2i5wF$QY|ߍ H->b=2[_,-޳/pst`-U+=/Ԓ 2waE&zvW[pc.WBIiR J¨d t+BN DZ2+Eg;$HfW檾0ή> 7nysD:41-31Ís NQ{~p l M[?n>h,Uۚ~#Ԓg6[: &'\d+unL@O>a=o@Hqm*M!5 jAXoqTV+谏Zxh^afCJb BU8=Ĩ$q ϳx>U9I ڪt;n'= ف S~ܔf2dy Y>V h&?yv#\-v>P4jjnJjHE" aPNπe!HbyvrA&\ FOeCe :B,~|jtՎ8fYk/E;]Idg¾9w/,v}߫tHba6%RHblk BL)(g=Ò]]}H'Tf4x/@9)MT-r ?k{!Ⱦ8cNt10RwD}8N嵯9`8e_lWc?zrAؚo@'~Ȼ\v2j@&iZnM؇q3džp | 0g'}n۬DVʱhm_xKjF;<" QX)]WeKxP15<;K=0 "w"))g-j$t.UKFINпzxB B`~ \@RLRsa1,Jh3цٵAv{DR"AWupc-k@I$ojSDKv1-ek uY8TGV6˜HqɻX\RAJ$.ZV0qTygrԀj"d*Ub-`RS4 >8r?"LV~4kubGL{k%Z+Ud㿠/3ՖD:}?NDzZLTt#%Y^ubÏ"^ mV!=E?$E2sS藓u{WDNAk+ڷNNDiFʗ&9,pޙ+E(x?Scp~>aq vJ?6y:6|HΛ񏵚'e%c夲hY-HiE"WOEUb;iӃBd3ѿ]kJvxRj&kf׀{7UݨV = lVvLϸnvT=KIMٺzZBc?Ԣ0sbӫʹ\Bxp'|++N猁c՗г4sú W~?"l37:{ z8@%ωj}+kJ"VE[U!W*u;J^3j`V7XtRU$拳zŭi(E>kFS(:F]kxm73ί~>ymYwϩu#9A rx r] jt]!E#;4XdR9=ȑh3ۄqzGs4ӱdNȃp׬mo]SoGmTG6RaZ)5m-z̧\*4-Jݙ.b/ !Ԗ4ze$K,e0yՑmDe!BgB$ƾM[7a{m=:HvbI_Xc\o]wg+ww";9g}|ߺu[>ĥyw5.3xU]qsЍ}=jLcsyt!ۢE?"HOe"V:@hhD[s$ps$Śj~W4\Qieƴlnc4f]wWIlO(* +sxn2hحU V{ƲtRǾ4`'^!A=dê[Y#`~^uxk%M異fc~y-L m2Bg^W==x~!Vυ+YD+MMM%As\36@5 6b9O{khRjxd,MP?U֚v` ־naUGqLtIde@d66ռR.\᲼C-c0fr(-6V+|a}}U,\J. q x஭tub~"j3pChܺ!_Dc`>4^>^`#k"ҩQT=1҉CFm2U9255s#ǁmAKPK;_DUYk+}d/QT"W9 ;KkM:< RQZPsp+7@NNCp SB*m~e.nHڴ0$pg흻@42}+ɔ@wM0ӯ#Çvr4+^ntu}qNy\Z|M(ަBk썖ћo~) sZ഼ăʳeg2763+,qf*闞*oǸ?y=p Q#HAX⇴ٲX \e፶@p={ӌ-_o^yG,tUk^'U`rf%zr & 9 26X,]ώԺO4Tㅧh?_Cg#| b|zw« | ϖj.(FEY\ `aɒṛU*@?~ӑ> Ջ$<峲]db: aVOuM`/+p^endstream endobj 64 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 961 >> stream xURoLe61@7*a8RBҵ \{wwm%0I BmasqQ2[ duI0}pQL$dCy}~DqAd[O,E#bL(:Tn'grQZf鏁 %[ R?sVm[_$ y E;e3ҺҵY][[ ‰hryr=.|P,r͚%;GILm'/_38[z~1?xdĜeӡS=)<LM)RTfncZwS-ƪsMPЄCePT;l_f܉&dcRS-YG.~u.$gI-`/zxL >W-C)Źendstream endobj 65 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6945 >> stream xY TS>s*Zԓ$^:tj'Dqd 0C0%'!a sAAĪUk[[kzAk{_{+.W8?bwJepBfuL0ǃ;3UV &.,a8%`'S=ibonh~:w̙cSZټ BRdȖ5l(Wcc*l\Jlk6M_!@J+eBP"Tg2?djUBP4eid2M@D{yY%^f{B# }L9)kI'?2y| 7Hi.mF/wD^v[deg7)ҷqhnȌLURJQnĐ%>Z @H*%(?T{uF} .ԁ^Yi]zm4~;+,qYUFH^G/5o%9F"m,o1P#(c\(=7&<17%w礨J_=10c[DC殑r $r=3_lfZ-lh,w$(??օ;^b^{0̉nv![oL7|2lj,7j1'5C2^'P1da0IFT$$deZR4%|)R(3QYO>7v]w>yܥ(y6d/qPuđCGrskbѶ,A>ɞX=ҚmR1"Tone0wqTR/PRãY6Inė3FF>3nr)Q_|đۗf*7fKT9Зu3{E qs BnY -`L I Δb :QKs1Ax]JFjF Mg$''[LT9%eV\goH¼ђ5y3>\]a8t%#"SNDI=TC%Tc~UGێw/w0" m|8."W_,ӎ}}>]ᰕf^ÀWF'P4Yd:}MFuʑ)(^X `7(q6ʋ=5)vܠGaؓ|^c rxo/\ƻQd$m_?RngD_ ׅD)nhBmUa'4V tN q聓gTuIy)R~ j;Ky7XuG- aQA,1|qXqDG4Oe,pv~ӌ}:eF>% M\?'R*:HP/BNX{*Fh9a Q)$ۊKp N,vpzpYxi)(P{fh2%>j gRCR G$Zm~i8}hc1Z-!j͈YE)) -kI}GH^q~{ߋl~n/7nӛcJ2s)9(e1 B+od2*fV0j=F,ʔOEY1ґ֛bsWTѽݽqArj+>u ާR|nljWˁ>qc_Z{Pǹ uquhWUPv(/-g<}`yZml4eUDJWZeTh7DKS+(P&2$P^6[Msŏc6a!CF}A6ƤcGTtV ־І [+(YcT}k۳+“}\zѿ=#IҢ _Wٿqs};Zx%,@+O]'[> X$\Va{hr$$G;:ђvͻb}\MZhQ%w二)4Mx Y.2L Q|CnL>&w0*.(?)n.uڨM(MhԘ"pXaT{P&]ul]TʲǨmœ!撹Yt. GӸhҢWB9xij-¸9܃n' 3 O%)η?y;XXiA4D&oZCt{` LT Ke{ܵM s tN5W&69 vzmE3W'~f+Y/qc_A7 5,${a{FfK*6k?YNaiG2EpsC"4= zo@MYNjͅv k48rj)klscWv M_JZY2_CߎE[c֑[9rC7~{(^oDQRwv,Qz`tҼRL')Od"?h[mz2hRKZmI骸$4D,o*?: oW&҄cXa VPKn%3}yz_Gqx:{[YGrf?1qq1WKk]aă 'N{[q2#&9"Zbʁ+Y]YMڦ2-Y;u+}s.L yۘTiiܚ,E? :MȎ`7Ww|q''ٷ#4ݢmvw9qC}yۿ?'azL6=ϛfav T]@*6Vju655ݣHuz2\f[P{آ`Yx^orv?Y:(4GR=)\D E43Zf5.#Ma*HfCD*ƺk%m«僓E3 mec}u .—o%˭߶I pѕHu"`wsY'jO\fw߭duO 8n4.O2S)%Pg/i6ZLې ̫f<ЂmwI=ɦtH)#Mi`T*UFuƂX}J޶k7,Ϣjw\Wf~u +"'ʒsO~;k'JQ93$.2lb͉zs6({~b?|lr'jr[}{oNRFwx9)V80__ yev%;@$1j*X8iRA 0g3b q-]^#H1|%:fr9HtTWQD灺PBUU cW[qa@#MJp?{?x+꿮 NaCw;l; sendstream endobj 66 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 762 >> stream x]oHqK1w&3p,! J$+C)Mܭ͊̿m+l妥6?VMizHo7EP.ɠ/<aXBHu/CڂIIRr$l|lT2Nƿ\( RR> stream xX \TUۿ#xgTv\ŵrKMSAT\PI1Td`Xu Ⱦoஸbkfi>~g`Ƭ~ ȹ9?e܏DoMy;hF1F8Th}jI!͛ AP2>ut5cӦ-,[trȽvZ8Zn;b,\iYf!s(li2 6vk7?س(zaMOCW*\Hֹ{3cfĬfpM\EguTiӷS8j-5ZGMSS);jHKmޣԧfʊQRj:ZFO-l j%5ZMRka)H1vS#(3ʜIhj QPʄL-PC)Kj)IeLS]hѹ~;n)ˍY:Vl"_L|>`فM6iC ]5[oVc:4̄2W`'JßX1lYX0s#Gng 6Zk7ylv,f蜦S O?,Qi2IpZFm5H39$P8 A-G/Tr̵"n =ig^\mL8 4SɣEA8,32d-*ar|25ثMi PXpD,u񥊣eɭ~#}z+@4Gnw_7 0f:UfW춝fs-p1p j@H7 C%X2m=4O0nq;v/_~ٜnZHRć'B$,deHczR|81P0&}g~;X7 I*az'Źp;w;# 6Fx ^m#~=5LQ̈́x g?sV9YK ~-u]:zO0aj'kb/9\oZtQ$vmqJ<[KpGW"wTDMZS;]qѩ)(\ZJ9nn ϸ|rF4a90+qKsi*$ҳXlMH/,ס@9پg|P$M8J\ qJ{ I[x]xM[E{/0Z{KV}yW4[ u;_M$gBFPOp!CϽwfqt_ o+suyaDo?\k㊑to+5SPCz!)HԹf.˷[Hʫ?J Sqi^(ݨLNHK]P Ţ ɟFwl[\bqR/HQ@?KG YCniz].w*'h^dզM(!ٰR NǁxXZZ$aN,| .>{pSsu'Gxo LζԖ{P~w0WX#D-ah)Lfc}Q2 cw?%l%0[\TK!C<}z¸jTKPS_q#¢5J`Ez/yEwQkW<HwolT+.y~OuŲ7F[5] 79*BnO_c,}3PѨ -@ :Ɋ>쒏ׯࠡU FB0f-x|i<\_k; UW*TY Mk FBnrvMS3nH(%VhKOjQ%͒T!6+*?UtgU]U Ye뉻6=`Paw6]J+o1M@ʂjq([*HS|$WFL̒k~s.̻5=Zn~, F 55j:ƃЯ$*=v: R{Y']t i)Gg:VKhq"zNCܳ{3 0ؐqvj6|F -㳒Q ڌ'E8}@\P zxǬH\T"1|91-,L%/,=NJ86L?-9,>H$~!a>p]ş1H?.f0YzQ J j54M!B~Aqqȋ跘teSV.0->U򺺪"uhn$kÞf˭ͤy.@\8;D:يxd v]DNp,לXބم䪠"?-߱ L k\Zy(_?|h D4ܞDMM0` 鋩SLWt:%fzٹ}k'4dkݓ<,]u07ot,2 ZosB(%ɑJ3=#vsdD}y&xIokQ(/B<>-⁎&,؎?'`s۾#?氒[ d 0g7n|9׷2#5 A%IR&rۧ;&yDFDItfpֽy\הYa8m_-C:'j85K]4c865|jg[5 ' ؚ('LCѰsWCR8hч<֎E󤢦!?06/9x ܹ8wݺ5y쎗F$$psY<2 _϶>;i8;Pϕ͇EEW0Yo"#U#TTԔ$e$e{.U#vDRR')R 1lrKm5i陹(--לɊA]ա0'= k>[QG>\D<ţ̘*,*'@M^<71Qq(<,  Sa+e` Uzf7xd2T" UyzIS~*=W*S LSendstream endobj 68 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5895 >> stream xX XWמ 턶gq[k ((nƾIB-,7웈j*ոh~KI';s{s3l%,W;9IsxʂvmCׄ)8?5jGi'F-B,z^媭 jl&݋!a~v3O5u*;#a.@<)ۦN6EA9SoRkuߋ45ml{(Rp4W&$#D%&%aѴ24r F.C~0j'C] ^XȨ̈B7u2z4ZX+>Ɨ %[u͉6eTxp X)[Qܳ8w&rd,]ၢ`2I7^?Ob9D5V}Zno ZΡnF.r8Vv*4B#Ƞ@{xG2!fIܭ^$[BbMKvOe-Ti?`9GlͧN–=ٓ`-cg8;888|w.88LS4pn>5-4g}WL'~?.'WW"Odј+x}u&r\2W #*T"8\!|XaE6HiUd( Etv*KThS9xF n wpӈM7IuMNuŽ{=>aĈE* .%sOA\`W&`zlG|? )-`/7:ͧKuˋ [?xՕknl@ آwvqGGFEy2p/ʛV+=Q{R??hxs,8%xFC=z:*{.]ݸV~1lf|K3J:$Xiݳe4% i`/WK|<%!iAY[,871V &BcuCwZ&=Jv 2ɡwh=ț>{xȦ^q(/ܝ]*mo$N]`xc!t0ˀ2!Jm_)q!fJ呼H#C| 3NmcxИ7,=̄4 IA6U!u3]dC9 s76*xqmyQiRr(|18b# 5IotŠگRR߲N 笸èEy·Mu]aS4kNh c|yl e$ʋWnD0xot]yk ) k$x^:vGo1WF{zP~Rs)EHO9#nݎخh?lXW {O E\/yYMOFps<3=iE?ܰN |]̘@\@_„)`Gܐ (X-Wj!<~OKI.Q2>b=h~q[ V',TjuAVG^B-)0MǐSƖZNp)Y~*ZDorY2̒"TLuO+1UifBx bNώC'b2XWeVitTgSz>Yo*Pɴ,C{Aq] Ae,.T\2fRļ+([RPX]xkrNj`Yx'(x2c*[^!GvsLԢ.\~D:&^WXyyR[:YUuC-~hw@qcݚW- /.C[P o.̩cU$#yc"@wi g+nF@j%$Xc % (y }djA)ɘWM2B˪国or5a/?oAgn`YcD"YbzWn)c  l,KkPiT:I aFps(-HFp"$ wY:4g 0?`2 _&+0؃:Bg5tx[.,Hq$ᶒ?~6)翿mndce|{&fc֞=0Ԩt.+FQR!8"~aE+3'{|. (k#%؇V!f"Y>%"1]53MsKh$hJx *A٨8Q٪jEcTM1 eКR*$ Xם;7oudNWW̳KwN|pWg\/ڟ{YU_eZ+@z"* KIU/\U\'T{O};k<+;Gnu.9?KcZ*oU͊/tI<[^W>?[ );/`"qiLAɈ| Q+FDHMMMLN< &y;P5;7?X)Պ 5gx[,L(g  `N<^? yA u_!jMG6_ĩKL9Qx QIP$d( Ou0;Lt#44 Yi 27n}&q$@]oF >A#%FRg4՛6n\}9Mf=Ϟ=<6 yFc2?x̗^u߱n}T9f&-\zvqWB`B쯚QmaѽC{DY_㇪Kb8#Rp&Ô8F@i;6βff|"iX0g0EE,~ 07n\u@k@ *U'qx\&ڏ-BU{}˧mҏIu"=tdnE1G;M:ؘQ qih va1٥:T66qr$L~1I.hgg2Cv3Ckkgz6ďnVm3;|y@PDpXF>f}o\F?20|ؒ+[z%qG -5Iy9GN"Kw:{Hp"vOJNNFJ]pݠ=m!j4 Az ҏnپwef8bAMtۄ聊B[?ݽ> t&@˙ Kζԡ`6[ =ؤ:h#iX̢N()(+(JP!NPWG#77|ԙY 乆OwC=]? `: dEbUq(E2ٱ8Pw6)+v@-igq . I34Vh!.dOm^V1#{h'r%w .%AGoOW͛,ܿ䩎Ϯs[U$O MdELM}^uQ / 2sQٛd gdޛ~ۣ"Tu]Ǫj *I|;դڣG:|oFrt!Eqy[>XQWjle%JBRocd$ARU~*@뼴 DjLuY.Z`í;F!GP,ұ^g?*OG<٬%p|AyJD$zϿ$_q6<1W{~Ak4{}ּ”ꐈ9f63-A+J\ҽ zҷVyVmZ!JJd哭7> E4U(L.HØCo z%&xVF6;{S}ο \&!=S[QM\JMKK%z5??v ƟKT!R_(u.(D) ra(& ut Mz=:e&?6eU:sӼ%1@ER8-iOHֽ%JRǁg%nWxs oCF,%;QȈN@ޝPg1&E>LO Y.w>!yyju&*JNA2FY]4qFCs싕Iۛ% i//_[*ޞyJ$nw$@6UʺJ]8!I8L(YjZ3L;fAj1Y ?P^HVWd[Xtffdg z@c1endstream endobj 69 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 912 >> stream x]L[Ukk kCދYV!f c$n meKBፖnñnJXt[kGj4f?jF!j%MEcxvi䜜==T i f&=m,jpֺ cB.PB<(cF[VZ,Es@_(p_.V4]mH]{S`2)*J%B]P& /HPV/TfQ!ua&54:Q6lmUjm)ݏ)RKO}vQVFUSۨrLiRd*&zD*ǹ( ({z:@ .Gx<3I:Wgk?>}޻}#g%g(>y5~ϑL:C2&(oL^1&Î1ã!8 T{4f$8byG 8kW`C78|./#]xIκ??} Qΰw9&8OD|5LZoں3צ-}կ a\4m}]Gm$(k#&)dBHvHoO"DKBe5Zj ٗPWV˻x@yxaŠWn DV2RY%m&h XV;>}<1}Jendstream endobj 70 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2402 >> stream xUU{TT?0sMDe:: '+4C/(8̜afb:<=Þ`REHuU.M#RjYﰎ@fwZoo#!|&dJ"!^m0zS "~9%9}M6bw|6c3ߜBH\'$w%4s- 3/i]s/x|hɒ%LZ# Ӎ|f &sk-`/Y ĬStL͞fd- el,X&2.~̼IL4&ޞfk5Zɨ&u!Q3V3 6GÚEZV+>3z+nQmQck^g2ńY؂Sś6Ƣ7\1~e8F[&ֵ걙1鰧֤ eF+ccslb4f:ũUoL\}caYyf!w,4W}t GB`b,|f"f+OAōDA6:Wo^!/k AD R5D,1'ēML#JBE ‡(̐4NX8K:COC]/_%! yF_R4ϡ衲ȏ^%TNEh=~2ջ[R ߩP-N?zgTs-PB]yu#r?9pnq";\m;Op\pQ9uOsUݪL}RaK0a5:JkZkzzĩSp"`TT5n5 ҙ:5ʝeȈf04I, 5"i8 $(ύv+_5 .P-o?" C{i!S2ѐLl " ;aKA@_?#79tA(N]=3W^"Fk.TycIlŮ-I&2Ľ֝ *bۊ{p4KO bq9v'Bqtۧ%?R>d45LslHU= 0\yhLDF]zjc֎7z'%$\9zV- <56vhQAGWşJ8*@>D?|{&+ebW%2ߜNv(Dy'Ug*zA%7صb G(h%Tta(DlsڳYֱg-G24 )Wt@t~x:Ϟ&, {[(DmϚ@;z>tV|s ?|M,5@ nj)MŋzTk'I?WKawg M,NU(jt.}rZ5u)zq}W~0p@?G3CIOL> stream xUypSsrEXI[)n:`CaKeɖ-[)$ ##߇ls%$CZk8J&4f^$:V}v1QKxk.RV5[T=يb%Qb#K[3·h`IlZHf9/đAK+\A") U8r@?=gL7R :Ѣ@&SS6[VaM6| BQB%-^yNHݴkiBH?+۫ߠ-lH9l +w_[G`wC6:MM9b I'0477oiOBeW/4::GJӤ/,_|[U_b. A8qt zﮫƊ)CGNy;>@֓</9~mViDRylf.+:b+2o,L Ӎ̛/05/Hft7ݶ9+l ..r]R[5R ҺB\{&D }ZfȐtŐdmkS8GɃtbfSЀGt)EiJFN3Ua6D}s,cu˛ b%WjXAo&\RfٮǸ+ON@2Nܘ*4?s~O$v q3RHj ըSCy8E 5ށM6yمe'?F-?Rrk$>sp ԯ)d %NMɭ3X61@If z8jPT [2ƂJƤ2);詪S4Sw=O):39vZk-P۰46l N|@glSGOj]7tqbXBPq,(ޞ+go4uYuGCFjX ;G]m-MCm^O#aofӜ>Bxd *O3i -D]+BS1F]]d!1X-PM cAzuQ߻L>Ho2^yX mm(v G/?Y+iV> stream xZ[o~]`ضh1S`;) ڕeL&[,*;1-+sH}bLkWM=؛QEJ#2yIE9E759yLtcJݨ91Gi?F Abs`aT :7` <$T1 W4Ät82Mb\y)&8E#&! 1gIddd#W' _$FLo~t Il#H5hE~_yDT}!8 _Ob\~D¢>]Nx9Y0ORՃWh{kI3hhSr-ޣ-PJ&Y "j-۹&6cj}DAnJ"?ǃ(3ZЄ:yb^T_Ƹ*=TjqB *uL,.$zp f]TyYվ(]V[.rn&qe$p:b݃"`ܹ52O0! 13 yH~E7c\R 은aH.xAys?jwE~X[1#'Xb8u9g0ݦʡ嵝vVf$g 5ڡㄵV(J鬬O3fS4ʼn<XUYqm}Z">#C 0,l; 3nk1bNblEPypUi`t%@|f;í;Y= Qahwzh yΠ0~ &Z7!jqjC }:[NU3]4Nk~ p&svJgƕ^^R4% ޞ(Š |VĝZ8w8%SGۃ$9Y1,1"@I…٬a<1 F *&+i#]dj+X\n%is| u`lA@osWb{H`&ggZ.R讵ʛ2TcJtgM߽s/eim#!udB>/4Ua;F =S#>stn6h ?!|O«Ն"|3 Xih3 |pKKLB~6)gyg E'3L:=x5S`Wk`kɈ@'$ɼf ޵:vU:5%۴+ht׵v6 ҃oWbk5.ٶq'h_n*7=svJpMLw]_Z:X:CJ&+5 c<튻w -5 .ҼMT  2//1S P*MɨemP&S~.fvf~ha+iuLmM\Շ,viyI&ْ pǙJSI/+nnoaϋs# Jb9pOMo۩~@-!'sllU6ׂes`bBކAT'Qzcʖfڽ&5%#)iT}E]o])8=POiuoeAlNdo6vi_r> :ah|7h_V>UĪղ|j4=Q;pNw"MR~os]endstream endobj 73 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 238 /Subtype /Image /Width 291 /Length 9598 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK#" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Z( )?9-7րN}hր9I#Q8DPK3RM:_jv/is.KC{ 5Iњ nf1$O~9ώ4AIcO$R}kH4:$NێNmIRBsGWPC)r q_o}By8F!I=I_O>U;8VZ#Ln@y6 %eY执-ϭ!斚:uKϭ-&~`=֐c@Z9)iiy ( ( ( ( (*]YL[2.I901*IDhdOV~.aGa_jL:}ON^{Qz^}G>=E7/>E7~u Vp44NOw$ԓYfKxYHE3p[R$%_i;`^O8 K%?KLO/h2F%5ssIct%D7R|ޢY,f3Z> ^&?qC i:m?D_Cb8AѼdtgQzqu~u% zCӹ4xt=~oQG)y΀G(l?:^}@|RsK@Q@Q@Q@Q@Q@:2KEcB˸FX'ϱ=bGtx(*9qڥ?4dt49'#5RT|˿^Xt'b#ff =k}Netd2|r;n# 㹢mM̾\(ےsX#:@5 m[Vc9DJ3h( >Ǝ PcF}PO>Ƃx L&)Q==-nVQH%?<kcw'%dR 2 ].@IC]ێOSsN=y< Pm:Ґ|, [-k2ɷ/!꧑ӽX'CYOOFOOK3@IOFOOCRIE-&ih(((((&X2 2=J#:(,tPȬY\yd@_n wlֽ-r:B9X{E$Yfi3}I9?wjVC'!bC=wtS^ h{E}h=8OC=h{E}(=8_C=h{E}0h ?/Q_خ{F'!bC=wtQ{4ph{E}>R{4pR=E~er? s>N1Yȫji1I[fr\GSG1/0&1˼WOEMbxI=doZ6:Վ;Ck1yw7>bH`=)h ( ( ( ( ( ( (ǽ- @ E&=ǽKM׵.=iOƌ{0q@cހz 1@9{'ҝz;W~d2Ԙy1eQdPzTRZo*9=jFҀEEBۑ~by^zcހ=i* ˿ Tfy.+tA}@@ BҐsڔ:WKzEuCti1Zq׸QH:Q@ EFP"C7?\JETXS\ck>R@ȣ>TYC$y;t>~;R7OQjFW,nv> _ΝH(`H ZdHe1屌|:\Ώ[~TBW߷?^ۛki9d*.KsU彵5'F82X8ycqqq:m+ʎO˾+YIU΍Lw9$qbZ]]ZV!X̻Ā`p~|gQKKm07HPpOjG3WȻh|IT':eo<ݨ0FXp:9OgEd,X5Ukya9Mi5}餗eA9PzN{.Mƽ7}γyF҄G\Ƿ*桾U#\MbNǯ9lʱ4q!bONׯt/lw:ɽ3 q?1Ri\~jκ S׍O^3ڬF@FeQC{?ӬqZOi`)$ASTe>.'1,bI_˒7 I>iD*̯͕NZi4Tp069HƤQ*ܤ!QH*:1J:P* ˿ UWTmq&xho~rMM.0<'[n2[f8I.C3O5ޑdFGP0#ҦQLɣqߩ\֕Id-O 3^{]G|GJ?X5ctC;{?H`( ws4/(Df2af1ךYԭK)Y%r0IAViY~Њd!6(r~=*O-|7{nݙzo)Ex1gw\Ts>X~\$Pg' _:Elnv41*I/]`$,Ӱ,-pN*hq)b!ל bZ98׀>{qIlPEHeD$]p8 \z K7I,9ГrO92,[#[B=}k"gve1`<r;t+xͲwl/v`nCDu,:m ?! P˜cJ]=ƮpYFvqOJY#+_2aI2d uc9+!Hm"cssm!]N9}ja`Ke/77S>ʲKlP(+d=<{z3PI\)iF([8 <2;[Bu{VU/F?Hǰ"Οoj:~n_ Lx`00ryfQ"3FzS}(y?vͻsqRgګj /UuOMrmǎS%us9]ҵfӿssC펥QJ4;(IdHeY[ PE=NqpI5ve#r9sqi^,~MPu=9e$QҊ((-%,HۖLaOoOzե (G,qNf~e\Uy I9Av>$fR8uR n t =:j$s,E4_1w$߷6{n%U2x8$}2Gނy(Ip`y_P{fܑ;Fr3ڟqB]L zgԌLJ0=(izS e!{ /UO]Mr֒I]G(wPEtK9 3p?R(֋nzSų> _qu%9nȒ40v;{aLȮcHT@ 0>0(5*ɼ\B3=vcygLm;uXJC0QrMQdHv ʌg>^HZ93-=k$r29妻$;VRI͞qW}ӛi 9~_Q-ȴk@!mNbݐF9#OU=A HTlep?:$:h]bVi#'`\c>±&K;6[i24Gv۴g91kX?/k!vHT#99+U''hi$'2#8kEyl-q2Z*&)8$p}nտEv9$o28#zLBL $$Igqd5(U?0$NzUQ;$dMŷ>B[\8'0I5)*O ;ȫzcv !#[?sٷ>.^A0$|QǬJe$Ir",~o }19m۽¦:cdd==W̖!q ꣨cڱlGk, ,pOqb-n1pjR rdF{*hq,$l]zܠoB^ Tz)mchDn90)!IYLF#bK;ʊ\^a,cրx#BېΞzR*@$ۉhߛڏڀڏڀUuOMY2ho~6w'5rz('g%֢Z XH$pr}i6IYP FK' +{GL.6'bVz;ޛç2 4O5us1Xw6,;  v* E E-Q@Er, m^^6IFG]c1XzMFYw;OˈG#=k!LIr^8>Ө&<1Goal "FO??z!|!|͆ۉ~L,WE-WHѶrq!N}PѦ`nVV $En!Nˌgp%CtAFNvt8'Ihf-o O;P0=ջxapK>qޡȫ\]Gu<;rxL+TFۤHabsj.\ $&0's9uc5#tEEj4*nRNrZf$dh- (hN斓zS:(RWTeqժ6h+v渽u&F e#[ékfU6"3~nJCҔ?x})OCHaH?u5:~& w~" )h\[,a\JA ~OL_)[=F}.K; OV}ihހ=Ԃ#TgwE'1APq:RpwuF={cސ~CȠǽ-:tcތ{@ '\{ޖ9^{J}4Gրcޖn=RPVm6($\;j#t4 myF=8@NM!0q֗&=q֝H(=ha^◽ ҀҊZ((((%H^Ede~Y2{sh֨KEQEf#PkQ@~ssګi\= Ku\*d)kb0)B ǮTV\iّLoeurqȍ$'hB((=8ˋ; LcǘN 1J(+dxTE O֥(*ͯ 6X[c=?5b))hg$6崁Jߍ0E%帺]VʐAd4kؠ`g> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK#" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Z( E9P}E&v/ҀE'4s@Bhs}(R;NGk#AnhSpݎ; FphJnƣȑHʈs3=I!yqn##dVZ_7FԌr3I86TU% u*öpz{9w+Fܒ/V5躗Ȑ*\Ł*@㏡52iQI8(SQHq~)9ȥv/4RREPEPEPEPEPKB 9"If\ڻ#>9:s?m^IqqzUU]Fʏyf,ܙu=G^ ,W >䧾='w݊V?}_Ϩ%]JSjզ}d Rv!t~O1>;}γ'O0e+'ߌ/l}R6S9 {QRQ@??? ~Q"4QEQEQEQEQET\R OLh]_H}(ۇr3Yw~ 4nvȠeV6r8dԠ P<~*$L?ކEj*RΩH±tPu Ss rq@TImP$*q]-ZD8_vph{E}8]+bh~h{E}(=8_C=h{E}h=8OC=QGa(D?/WwIGa}+0h>i+f U\o>`uE sV*1q&ky@.{@Q5n:tvL1 Vū:B(?Hd?-Zu Ql.2CF@ZҖ(((((((KM=GրEPwK@'~(QMfTRB$@ ޖ) <#%@e= @ $v cN ݿgm#(s>6?/BhYUI8H` ЊIdBST"P; r< #MrG41 ƀ$z~&7e! SO$I dr tZ2h'zvo"͊쵥ހKHih!iE!+t?JZFK@Q@Q@4i>PclF9!TO^)  7JZ~E"Dtl}sSc̉K0fs{ZEks50AeS}chϗ n;ڀEj-9Pr[qPA -Y#*r698?UEs@ȅXeX`HXTAT`AO.7,BFa/7yٍvzR^;s>0vQcJ$Q e$FAZVeQ$a$-^je͞DYC[# } )~{ .2rA׭VXs?Pzk5?2wKB2~ufIP2nL$][\LVdqac.\֪jZ>藂NG:PǾbuNMF&.RdLJn9:J]Em5̅1LxdtDna稤$I1 ׍olVu;CI֞nKA\0ϵ/Qۤă Jg* ˿ UWTmq##<2+X${#]-1+G"FZR4iM}G8|8kC|ڏڔZhϵ';NS! )~oj-QEQE%!ըCpe+&H,WijFbDqF}@sM+|Mz'?+I!2I-wb!ki} qɷ[ h}+x58\۷0A۞F:Ts[,̱C$RH\VcF'*Apg,:d?JM+ֲ3_=G - ?>:(dVE6FxiXjZZ :GnB1cܚ+g 0G#m1)"']pEK-&j ˿ UWTmq&xi"u r=}k-jAQ]8 8t.I?z FP O<\!LȬʟrD8e k9A=F~q?ҹ< GW {vqE0I#eteʲ8ɦ5M1~S OҖŠ(ʾxu+`V@cܸ 7q~eǾDv/;$InߑoN }jYT22B(#Ԛz΀E&sCGM=q@ %Ye2H.6zuH1I4mIb$rݧXҞǨ9{4dOnQS>¬Ir]FOj3oazdX7Vo^ٖ5G,9 sۯ*$q=rڥH`%|L`\cywXՖBt0&^/ڍQ~1C_i.-".#D&-,9G1 fM$d$mnӭb]>M%:b3a玃NmF Y6XA?2O=gkrjǾ KDh`: s]DW7Bau}w ͐0?WlRYV$iwRdӿ9ʆW#+vȩ좹[mʷ qq;x~;"Յ7?ٽ eԭ;FxA-/OmKPY$?.&P7r0;qR_F,T.B.2zc=hp63jk15c"ې$Ԟ /g[1hy8M.R!(IWpǏ^=gOۛWM!H’O={gCn^hy6y\@23-@|?Ksj1ZjN<㎟j}qyrv-k*N=ǥM#gTKۙFew\wCf)5]fg;Ov{c@[]'iX 8:ĉj9'ϽH8ܬwQgx:]n&_Ϋj /7֕~)i1F(Yi,YJ6<\N=ӱiWoNg RW3c5\4UA 9Ѓ=#wApqu/gv>'Bѕz)(,-%,HۖLaOoOzե i>9QIϠ`cNpwvOP{[(&fK"'h8'.W|ö?jsIEqnR9U@,8'Jj(uD*nԃ ycw3{M/dTS3sO<|aX$#v[mB =Yᐟ6crsןjy"nHs,cd;e؏'N)"YO<!&vXd99Lמ+tI"YN'sן%uʢ[f,@p^\jz4AnP#L,Zב-Az7zZbHH<8^82h]NmBQ( $w׭z)#"1ƨYM]̺T$ec1GB~Az{+$(h7dg{Ć$i6[-*/\~?;-b2.=Ƴuqܤɛ컋s n&ڧ.&9FMl?ZOZ9Bhw(U(m`]a6ϨWǶEg`*18zիk%̑Bͱ樛. ٢(ur23F=H?i>1άѱ!N2Azzye3˓&O4+/?|ۈ [O?ω'YcpJ2-+ѕp`tϹ /mch%-qYN17A`=x?d1*rl&AU&USvy=&d]E$FOdwrOʣ?>yPZMrdFXKAӼE7K#<z_Kuh)q#,pX֭ { f-$˧Xc`'9f띠}k)䷻e=w 7[v={kA|N?_OjҲ&{+xzV՞eFgW',y#~}ȣKK4y!ys9 c5i]ŀ;ue$@+lzu_,$Os$gb/|\sa𩠼D;ZBDP`U1g|u8;:Kc@Xidڳܫͨ#]"0`n qgws 2nIaN~E1C<BJүH qcץMaa ZyX$[8d^ITǣ}(с"NE7rx~tn_΀#3H#޼RJ'VPŀ֢cQFȐ?RSUvVKlBt7SOA !*W1jfvB<Ҽ3[`۳2J.oê1Ɏxh =Vꤲ|dmCU [B{%B6K ϧNd2"|c'-0>_5R ilH.'t>f'nj'h05}zW4=#njI+})\(?X@cgw^EkZ_#VJv}@1UͦɤSGP0U{{|"?g .&M#cD4ƭ !$?Qk\XNmo%jckE!{} {%#RCJCR[: ( ( iN@ hή%!@  IsKEU!fE3T44{X2f{s[2mpqP3ګEn7  ڥ]2Up1x#j@3nm6q?ҔR>P?J\Pt)h(W3"_Rc-3ci(\(UJPW_UYCN=E4g@ CKcGzZLi2IFO##% vzSg@ CQ~ .w=Kޖ>ƐOH;cF}-zishh3i4E3hϱϱRg}L]՚FhiR BAg'=)ԝ >dRZh'ғ'x㱧 OC@ڗ'҃4QEQE,d;!2KGNr:֕ R^[LE<`錩FA@+>F V qO9 Q2[3*Tu ,V\Q4͝FlA15<5vtO);gxi#QEQEendstream endobj 75 0 obj << /Filter /FlateDecode /Length 2963 >> stream xZKsFW`U몡-NJb尡|DH†%=݃%E㪈fzu77 Og IVƐ|:PYk.pSjRܵ7w-,Lh8ӏ'L~{͓?E&[cQ1ڕ.5l8AВo&"_t{G/*W 9P%vr=Xݦ|WDPθihs+jڋUnEM!*"Iruw7lt^W{Cm{#۫ ^$#1$bUr^lj(-׫+H+Hw-ϯ>bJ&''IߓY!!,8KJ7yy;E"1NR3'R ;'?/K?OUyHeZ@Szrs2Q#IٮfgEݎ[b2]՗|Ί }^_ BrfG_e2Nyz:m!8W&KM΂b3fa.YO |h) M=EMFC3 bX*#|%|/ 9Y1\D#f3\yN[=\Z5xɫѻSLgN>G,l!bl4 &뭥6o4xXnYbo+|/ܮT;q#f  0K|(x vL_X{)8K|H~>D.VLG1!u  O!H*5~{CwX" ᶚ"~qcզɑc+Oo=@n {ZhA8`-M+!ߵs: Dx4ѥk ҙ-24k%FVйD`q3,ΝĢ+\ǜlOkayΪAgՆi9k}'G wXk2#cLmmۻSQjT?a}9 '1 r ]) qثTfd_TNSh,PBz!A)ԃ=2|lQ,:V(G~Hx1"P[CPbCbi"^;V=eHnқS"ᇫ4,8P6rcˈkL\=Zj CpAߨr0tAF@ˎm9fti9;$o t(4x̘>hLEH+"t#(?"h2  $4^۾\g̨6IR ܜ\6iYR#6?7v;ϲV{: 6JP^/ק/_\CʌZ^J:PAwL쐫wDmZҡ$a>8'ջ~qwԾV ( *x>S]LoOn~ k i_yw 'p4W ǽ.`a vd@ = ?VF1݆Q&I6S@P}E'479y=I.%V0H=aLjُ+^nyܒOg†7IdHI3"N4NߦfWO0O6kFV> stream xM]HSa߳7 ^NҹaFł>4> stream x}QMhAmjU'(I1 V6fgu[/'eDO JPPi/"HC"TA"%=8z/}{ӵM]e"4E 1] C22ԖA0>|o64i$9M 􅯶ן0 Y0C;f###7Uu.{6b jJ'B yT\l l!# Ar g srrQUfŴ&p,$дE9Wfz =mUJ<ʄTaP8 Uݦx\TUM,&LqhZ>65g G9M 04\ۺU5xLtĤԝisI?l0fizQk4FSrDB"<;iCrpf)㗍2e-.$=xG[9*.VSdk ժ7K+wߦ7fÕg˩r IzFtNWsU&݉9X3z4'W endstream endobj 78 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 238 /Subtype /Image /Width 291 /Length 5842 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK#" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Z( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (fdPU,Gh[B~4hYƀ,U,Gh[B~4hYƀ,U,Gh[B~4hYƀ,U,Gh[B~4hYƀ,U,Gh[B~4hYƀ,U,Gh[B~4hYƀ,U,Gh[B~4hYƀ,U,G@hro]?* ( ( :5fj_/Y((((((((((Ɵy~^ۮs ӚESmFxu[T9!bF@dINQ?ƪ\\l]_Y o }&y[+ ^[gp!!V`GvȠ M/r8J?W;=#miP߇i,ݜ|rW./I\X%mV)QEQEeSbF{?@>{Tǧ]y"fcNMa+6U8鑞 -GeM_((((((-1B e\jf=gI~&rv]!.}@_Ÿ*#z,NԎ%+f;>FG͞FT©??:%dڣ-FNgS/tZtnw-ݝ{G&.;g!W'(EN| K}MspC \(-B[iIKto }>^a,bbvhLY:;x"m7FuA 5Y1!<$8O>9H2@G9>mse88j02}? læ(Vϲ*P _`ť;̽S>~y4cȣjQ@M~fx ov55-QE%-ǑcbU~&v*0rضeުz:F3k>[/,$qqM,}k蜓Cc4R'W£-39?Ÿ HI=OR~%Vl1)}Ī{oåKWV*DßugUM$_>TgSXOͪW_/jTdQEQEBP$&RyUj?/j ~lIC=߃H bv.|`$բ((kc:uQid>)9$9?ϩrtFZ\nr4:i9$Wϩ*ݽP{ G>ʕXDQmN0VE1QHIHhP=ihfQEQEW_/jU?KڬPEPEW{qYD.WV(A5~k_( (w7) B{p;$ʈq?ƒտédCɟ_\vQzvƮ1ŽBu=SӞG2ao@=8v|,zR K@Q@Q@Rfus*Xo_Jyf>N+B<QOӹI7h{Ƿʆyslpdj6ljȧojXb5 ?ίEjMN: ZFd_2AzQ@Q@RPQ2D>c`+2 rIIBj*(\LGȇFoN >i'4f!G_sV ugzk#fIYnWTQE֯KEZV9''vQE2B((((((( %mV*U((* =GeMF, dX u݌dc9qNU5fYp Ѣ((de=s@%rBp9݁RHʢ?3bl0O:.L(Y z{=Ngegvj @0VBp^kQO((((((((('r_b\X(( s̲Ȭ]\8;Q>U8鑞w@zzT5?/hYII#{M5Pey!HsM~.FѢ!W5Ak܊~*ؖ?nA~ EoSSg-=[$IH~4Z0-ĥdQ@Q@Q@Q@Q@Q@Q@Q@Q@Q@?KڬUu?6QEQEU {@zzpP:' ?1Uӝ QY@a>a_0#9ŽOڷ"&V ;}*doEvʩnda1֜~iOj!'hQUD&)h((((((((((OX!kKygI4nV"Cs/"o"<~i`Aio$`TR  (ǽZ_/jU?KڬPEPEP=ݍԷj?:6 e(Ig'i$ c>iΝsp qPh@ ޟ_ΑLh0M<:ְûwc46?G@ cty}:}6?Gv.3Ii6?G@ cty}:}Eo 2eݳ}'(l_Ώ6?OctJo͏ag{5-3͏P<l_ΟP[ۘf>Q&1"?4'dW/$p;Vh g8BP_~VXP0*zJФ eL2I ]zߧaA7IWQ33az=O~Fqy[9wN)ZtZ-QEQEQEQETԣ[I `m=ޠ . w0`Npp9{8VQE^9xmg$qt8ڬQ@-b[$218m#sW袀 (!I$ `=p{gֲt[MJ7s4)>$Ö<[PRZ*wb, x :+,̅N | \ |u5IK@Q@(I"eVGA:tel]ĩ 1ztƽ%-PU+wxc}v#X0u(mwpd p㏐ݤ((((((((((( Vkǀc nLCy#z3 ?VfX.5%ko+t斊(((((((((endstream endobj 79 0 obj << /Filter /FlateDecode /Length 2902 >> stream x[[o~/6@a#n~1)IԇJ* Z\lE!i~g6K-IIDΞwsf18~_e7n?DUfWgX e`ή"ӆZg.\eg[Gp\ `-G؜sZ\ K5>hm⪕Uɹ`zϳbZ1`v `@6E0ͽ"˽$XT{xƀszh)B,kijŦu#WutS7wuSPXV>H6FlG˝u}*A`UŲ> .h%ch@mwf* Ψuj<5Nzu\W5bR %Pp$)i-~%1QSU?˨ͅW|[}Τ2A?OVE}4R/?iہw]|p7AwHx3C }3tO}tȐw4!%ڬ 땤&g{&hgiiG?J';q&=V9^/&.Š|G~3\nF1^qޣQ`֢qAsOBn`il7 D<* Y|#Ciέ8:"3 5[a:i'RHl9mxg6i|M.6/=uyfŮ>s4Gfca3˝ۆ \wU1?Wu1ɧSB[''Ȥ5Ojj?Y"[fVyDe# 3+w`؁Դ bmRG/$e=zl;v{ Go{G=z%P쉻Ktkw/3SUbn HIgz]GfNs=+vzc-ch}_/OOu6SeEx]9!rT[$ddttry1{&s{j)pWN Dv3aȌSFLS]هϾn;lod6(͕"+0F(FK@ =q eԣ+eX T!v&БQy>?LgS 1f0Wb2+wvnyQHvKu_h6))byRM?0;0Z`RA=>2B/FSq/Ο&dˇU)R8K@v$^61?}yv;4OvCc"e7cM'G[JIu^;^ΗnCN˷پ8K[Ư W0ЊHW-S:O#q,v T|_^H^R$&31ՕTh} [I+'6Zi Ҷ£%q鉸n*j7<:rp !t; J0wȩ OB0t>RE@ ?JlλY< !b(Uz!+I\Z>Vy `qK> [R=v[?xMGT Tl6^~dv Bl+l8 h& y?CNҟ){3>jQ!xvp r-ЧZ%Q\X~悝x]JH 9.后m$s#hWK?\F/n*b`zRZ*z].~}1*q.04Ȩ;Z%FH i΅ ʕ2$ZuVE-7T)]մKQlCK-MXR,gۢRK] k^G͒-mCobyU] BF(*ɐhYe{*ΣuD2d2]Om"jt%,1͍h -"0%yA륱 K|xd~YFyL @x"- 6uq}ɎaadBHtD]іesprJ7x73ޕ `"Jc4ٲh!I EkN 9G&g / ZuoXv(/4fyyҊ}#3SqhAVpC'^6A4~["Mh&X㣢ouv|\cļ ćP鼭O*=kT0%ˀZ錨sF\h1>H틮Z(`!DZ JWL~d v8-[ElrV:c3( u:~P4/ӫ"W\uq(zϮZ`et^Lڥ,Bj1~b7E2`[/3].&X!iw$1SBh:OFJ^ mZDpTGzJ+*~j1_c6O pݿ%B&V8k6NwБendstream endobj 80 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 548 >> stream xCMSY10/nYfB@舗  snjouCopyright (c) 1997, 2009 American Mathematical Society (), with Reserved Font Name CMSY10.CMSY10Computer ModernsimilarN/YW@>M,v}'^a~ogsB];hklTl[V"kp兟wnso-p[|ywdq{vYslw˾!I)-fx+ITEL[ZXWGP0kַȋʋ``]]ϋs?  f C`endstream endobj 81 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 618 >> stream x}QMLAݡ+?& 5H<D4QScBgA!,7$d>xZ#Z*Ad H}? ^Cԝ64mL q(}0 g.h_-|R!swC;ȷ]̫UM5xHt1f\ZOn2 ttO*8idF fql]E__KMw'H6Nr9(ѭJ[Cm o:WKO?7r.;;{}& 2/ 3sO/6T~OV*GƵWrEМɫ,uZ( Hs!?5cܬ0~Mendstream endobj 82 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 547 >> stream xM?laڞWJ4>B#I;hiB $*Ak Z>"Nb\]>i8yg{^ a`­q76#ﵔ*T-l$faZPLex4&cgd|^x|\BprLH.b$.Y<ԉL&'nQG]8c,(&e|9{b"5/ L%!9'ܕhtvv!dG2 Czz۽/X2~0)I'a*84nB?8a# ~' i̮‚BŮ+zgzN4^+LjR۟sE%aW+d>e7aswt+ypQ,-jo~C ؠm vNyERX&vJ^jDOP@=*LLZ_9SV4[GKfendstream endobj 83 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 759 >> stream x}Q[HQ;նÚby)ȮKD`[#J 3Vѥ,*Z2z"(3tfz _;\EtF? lqxgMXNllvh |!Ib}_U\T7̤T1Poe@1 -C#]k4Ȳ (XH\ 2yOzUUBAD qF-a ưf)]e!/հ4 `؍}$)dtarҔ-dThx0ǰ|g!a=%^t.;U,qWxqW{7Bؽk?E^ig5?iv?WEJM}P;pkLUī鞋}}'cv]6(O59`p~@ +/W4>A 4̎'/GFg O uS@f09B2Caz# xApj4r>LFȏOvLX^B!ng|8A_#̯fx%Yh'"ucA\#ѱ9[OΟ7cTw$'O |{+@?`qŠCˊWB B+97_Wendstream endobj 84 0 obj << /Filter /FlateDecode /Length 2319 >> stream xX_sܶ} g:[J4q:Ƒ2:1#L& y'-[S#bw]($J;_Ove=I qg^FR\L$"GH̢ 5񔃜SxPBPWLH$,T WW1 %^@- $OLO&?L`A)lTB[%Z`&uThúiNYhYêo(IȨ62ȯ ìԻMΜSB lZESpFlMZ\Pu)m8<: ?Z04ƽ%HuX%'( ulʈsєTxWuZ }{wU6Yzf{{e/~w+B( ԗ2DkQ-*b kE4[ī^\Qh0Še4%Rt_BAr'lXvVhXa綺?LG+PX;;mg&ᆣo5%͋z׹].E=C2#ˬXd^+gZ@.Y x]X0 0)tQ_%B8L>)>J jR>98}79D >?- xK}VP)o8 1*|bl$IssVEϩ1@U5|7Y&1~3 $).y]ŰX0bws8I ?N}8 mshS `cm3@[}^ v06O'jlbb4:4Oᯟ/~s3dSWQ/gUU^_@Hᆁ*s`*KS?9GB_{W߻~ ㇬n:ΖU(B'tkjvS tEg }@TE c" S-XDJiܜȠw=D QƸ*ߐlJhZCh+wd:]eYۚĎj'TcJ3Ӈv`o:EU#ɀSq1H 3#PD,Iay^똛6>"oHKt`s|U.gPas87I8A |EpW0! 9P~ >xjmԇE62$jf BU {@^n x g})tV$U:p=J0(@FX+!awf08#= y uϤI -xaqpڧ1(!m?]9 Ãr$cg> FؤQօ.|Xo6eUeUDp71Ayуt?| ؁̈SR%B*MGe`p( DoǗ6>>3Os')IkvfhqLԳE_@ŐѰۏ~{5A7Aim|ӾI U$@ XT){҆R]{vID󬨁eVZ+T^7r9* |:PTi]B<{6eM56bѷ?gkZ-mi*e\/rOh ww}htqjzWsEfj*M ޕ2<-n;,CA3=ĩXܲU])=_u-0bHa"34ŢCVMY?N yՈz8 ( "GB?0n(M9xOArL^[) z̘@I[ד˘˻ɥG!9N> QȊk O^8b-_o2RvFA49ܳIj2q{Uy+(:;VXdm:7 m@@oD`:6;?v4AKiD- vB0)`C7dX`3ց#MH?LVendstream endobj 85 0 obj << /Type /XRef /Length 117 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 86 /ID [<47305700e82363b70a8d5bb800577469><26e1bfc74eed422680e2559263f25be8>] >> stream xcb&F~0 $8J҄>} \renewcommand{\subset}{\subseteq} \renewcommand{\supset}{\supseteq} \DeclareMathOperator*{\argmax}{arg\,max} \DeclareMathOperator*{\argmin}{arg\,min} \DeclareMathOperator{\sgn}{sgn} \DeclareMathOperator{\mvec}{vec} \DeclareMathOperator{\tr}{tr} \DeclareMathOperator{\im}{im} \DeclareMathOperator{\diag}{diag} \DeclareMathOperator{\bias}{bias} \DeclareMathOperator{\rank}{rank} \DeclareMathOperator{\logit}{logit} \DeclareMathOperator{\expit}{expit} \makeatletter \def\mathcolor#1#{\@mathcolor{#1}} \def\@mathcolor#1#2#3{% \protect\leavevmode \begingroup \color#1{#2}#3% \endgroup } \newcommand{\Dto}{\overset{\mathcal{D}}{\longrightarrow}} \newcommand{\Pto}{\overset{P}{\longrightarrow}} \newcommand{\Wto}{\overset{W}{\longrightarrow}} \newcommand{\VV}{\bm{\Omega}_\theta} \newcommand{\independenT}[2]{\mathrel{\setbox0\hbox{$#1#2$}\copy0\kern-\wd0\mkern4mu\box0}} \newcommand{\indep}{\protect\mathpalette{\protect\independenT}{\perp}} \DefineVerbatimEnvironment{verbatim}{Verbatim}{xleftmargin=0.5em,xrightmargin=0em,numbers=none,frame=none,fontsize=\footnotesize,formatcom={\color[rgb]{0.2,0.2,0.2}}} \setlength{\parindent}{0pt} % Kills annoying indents. \let\iint\relax \let\iiint\relax \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=r,label= ,caption= ,captionpos=b} \lstset{basicstyle=\ttfamily\small,keywordstyle=\color{black},commentstyle=\color{gray}\ttfamily\itshape,stringstyle=\color[rgb]{0,0,0.5},columns=fullflexible,alsoletter=.,texcl=true,escapeinside={*@}{@*)},escapebegin=\lst@commentstyle\,,breaklines=true,breakatwhitespace=false,numbers=left,numberstyle=\ttfamily\tiny\color{gray},stepnumber=1,numbersep=10pt,backgroundcolor=\color{white},tabsize=4,showspaces=false,showstringspaces=false,xleftmargin=.23in,frame=lines ,rulesepcolor=\color[rgb]{0.85,0.85,0.85},basewidth={0.5em,0.42em},language=python,label= ,caption= ,captionpos=b} \setlength{\parindent}{0pt} % Kills annoying indents. \newcommand{\n}{} \author{Klaus Holst \& Thomas Scheike} \date{\today} \title{Analysis of multivariate survival data based on Case Control Data} \hypersetup{ pdfauthor={Klaus Holst \& Thomas Scheike}, pdftitle={Analysis of multivariate survival data based on Case Control Data}, pdfkeywords={}, pdfsubject={}, pdfcreator={Emacs 26.1 (Org mode 9.1.14)}, pdflang={English}} \begin{document} \maketitle \noindent\rule{\textwidth}{0.5pt} \section*{Overview} \label{sec:org37fdee6} When looking at multivariate survival data with the aim of learning about the dependence that is present, possibly after correcting for some covariates different approaches are available in the mets package \begin{itemize} \item Binary models and adjust for censoring with inverse probabilty of censoring weighting \begin{itemize} \item biprobit model \end{itemize} \item Bivariate surival models of Clayton-Oakes type \begin{itemize} \item With regression structure on dependence parameter \item With additive gamma distributed random effects \item Special functionality for polygenic random effects modelling such as ACE, ADE ,AE and so forth. \end{itemize} \item Plackett OR model model \begin{itemize} \item With regression structure on OR dependence parameter \end{itemize} \item Cluster stratified Cox \end{itemize} We have discussed how to fit such models in the vignette about twostage survival modelling. Here we show what can be done if one has data available from case-control sampling. First we set up some case-control data \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} library(mets) set.seed(100) ncases <- 2000 ncontrols <- ncases*5 data <- simClaytonOakes.twin.ace(100000,1,2,0,3,Cvar=1) theta <- c(1,2) cens.prob <- mean(data$status==0) # data2 <- fast.reshape(data,id="cluster") with(data2,table(status1,status2)) controls <- which(data2$status2==0) cases <- which(data2$status2==1) cases <- sample(cases,min(ncases,length(cases))) controls <- sample(controls,min(ncontrols,length(controls))) nccc <- c(length(cases),length(controls)) clustco <- data2$cluster[controls] clustca <- data2$cluster[cases] # med <- data$cluster %in% c(clustco,clustca) datacc <- data[med,] datacc2 <- fast.reshape(datacc,id="cluster") dd <- with(datacc2,table(status1,status2)) # # out <- twin.polygen.design(data,id="cluster") pardes <- out$pardes des.rv <- out$des.rv aa <- phreg(Surv(time,status)~+cluster(cluster),data=data) out <- twin.polygen.design(datacc,id="cluster") pardes <- out$pardes des.rv <- out$des.rv # # # needs to use pair structure to profile out # baseline mm <- familycluster.index(datacc$cluster) pairs <- matrix(mm$familypairindex,ncol=2,byrow=TRUE) # kinship <- rep(1,nrow(pairs)) kinship[datacc$zyg[pairs[,1]]=="DZ"] <- 0.5 table(kinship) # dout <- make.pairwise.design(pairs,kinship,type="ace") des.rv <- dout$random.design pardes <- dout$theta.des # cr.models <- list(Surv(time,status)~+1) tscce <- survival.twostage(NULL,data=datacc, clusters=datacc$cluster, theta=theta,var.link=0,step=1.0, random.design=des.rv,theta.des=pardes, pairs.rvs=dout$ant.rvs,var.par=1, pairs=pairs, case.control=1,marginal.status=datacc$status, cr.models=cr.models) summary(tscce) \end{lstlisting} \begin{verbatim} Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.6.3 mets version 1.2.4 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined status2 status1 0 1 0 16121 15661 1 15828 52390 kinship 0.5 1 5963 6037 Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 1.006966 0.08370828 12.02947 0 0.3348778 0.01851575 dependence2 1.838534 0.08963533 20.51127 0 0.4789678 0.01216686 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.3539 0.02812 0.2988 0.4090 2.496e-36 dependence2 0.6461 0.02812 0.5910 0.7012 7.193e-117 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 2.846 0.06515 2.718 2.973 0 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label= ,caption= ,captionpos=b} \begin{lstlisting} # known baseline from cohort aa <- aalen(Surv(time,status)~+1,data=data,robust=0) ts <- survival.twostage(aa,data=datacc, clusters=datacc$cluster, theta=theta,var.link=0,step=1.0, random.design=des.rv,theta.des=pardes, pairs.rvs=dout$ant.rvs,var.par=1, pairs=pairs, case.control=1, marginal.status=datacc$status, cr.models=cr.models) summary(ts) \end{lstlisting} \begin{verbatim} Dependence parameter for Clayton-Oakes model Variance of Gamma distributed random effects $estimates Coef. SE z P-val Kendall tau SE dependence1 1.032045 0.07944442 12.99078 0 0.3403792 0.017283117 dependence2 1.897001 0.06795064 27.91734 0 0.4867849 0.008948751 $type [1] "clayton.oakes" $h Estimate Std.Err 2.5% 97.5% P-value dependence1 0.3523 0.02247 0.3083 0.3964 2.030e-55 dependence2 0.6477 0.02247 0.6036 0.6917 1.079e-182 $vare NULL $vartot Estimate Std.Err 2.5% 97.5% P-value p1 2.929 0.07785 2.776 3.082 0 attr(,"class") [1] "summary.mets.twostage" \end{verbatim} Figure \ref{fig:surv-cc-base} shows the baseline \lstset{numbers=left,numberstyle=\ttfamily\tiny\color{gray},language=r,label=surv-cc-base,caption= ,captionpos=b} \begin{lstlisting} plot(aa) lines(tscce$baseline,col=2) \end{lstlisting} \begin{marginfigure} \begin{center} \includegraphics[width=\textwidth]{surv-cc-base.jpg} \end{center} \captionof{figure}{Baseline with robust standard errors. Black based on cohort data, red based on profiling for case-control data.} \label{fig:robcox1} \end{marginfigure} \end{document}mets/inst/doc/twostage-survival.pdf0000644000176200001440000030125113623061753017155 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 3599 /Filter /FlateDecode /N 96 /First 808 >> stream x[[s6~_f'ӂw:Iqb%/qNh4M;LY"H8 y,d"t$CX%~b+-1?V,D:PYz}Y( /bD(\3IОbk бPybMý` d2_1a@3$LxzL =qVaTDא)zڋXbqiA51AEz x! X hL=Ij cTcj ~$hxȾCtԇ k-"ȱGDO45`% G( thL j"e&Px. 2h$A&$ O 9 !5ɆȡbU$&91 5c:r21]d 4 T$o=IZ"2b1A Pdq0:(Ĩ#$'dk_e|$)*͡9MOW3骸^,ٯ ϓc|!&*d @Y'/;z}H{3ci®Ɍq5$^f7 :. 4+5B)-Q#r=o4KTU(ɒAIn|WjX3?egd  .Hs<+]Eڋ\'8iWYBQ=mϏp[y_/u^"g1ɒg/X5%_HI #^.iX-ǀG)O _BxrVіIZ2?r/@>y⮬ZسY2eшUZV IL?lQ2&lqAANjI6b Z_.<{hlK"oݾCމ,2{\S{ė8@t+[4Dᠵiӗ~t%xaXH/͋4-='3> ~oHea[KZ_|??C@ &W9a3,?O>k&>{4(hd&ί`M'o*"*{ SJ@UkO?1b+].\N"-)!qyXĀlor6|q_cybY m;g[<|Ӻ/fǸ4mM $"ml'4~~Ǭ20aIv  "BRƈiq*c-kJ=(10u&y Kj2o5&[Gr졦9bFdL# ![b@҂<4A{eWDDi`8 6Y ⇰¯>.b5EV2gd h6̤F>[L'i(t0=mzβb|021-K荩|z6FVCDlXi)uŇeaZFW-^m{!¬&HlCHV]cn7g>!Jsjn'pݎn-0MaiOaBn|8~srQbץws=b '-MAB3@B$DA2m\@Fҍյk횉--`)~5MfW&z vێ@Qԍ/%"fds{292ytv1Afr3Q}yLաJ?ԫѨۍZGݯLWy}4=TTFj69V+f2>YWMIlk*69Ժ&{S iZZޝxWOvÍSG<񑾿V5WQI)EZu*pqՂ23sYuee7HΆ^ٗVnk>YĦQ:͒WuIx+3ފu[:߽xfT䷚1+/Ŷ $z$5)]O M׳C(|؇}{{di:CO~Eti4sۚeUgiLyze6m)MZJ^oqN mCzz{ bAo_/5@5$UF;Zk%\r]'8uWu*S?;;=?9XqEM6oqFE}G=b=T-k9NVSnUifL,l:fjmr۷M ||ͱ7. >U8lUwUϥ]u=wH /m1SjUw@|ܚtzKhTU_JMז5`ەmtxVG%R"b6LuZӥ7Zl =᷵U[vq7l~{+12)L!xb J}wN j OqtI QjtRm&SJɬ[I)5E/QlԺ[/+uץa7{o^ޖ{+ަE+qwiWowi}u> stream GPL Ghostscript 9.27 2020-02-18T23:23:39+01:00 2020-02-18T23:23:39+01:00 Emacs 26.1 (Org mode 9.1.14) Analysis of multivariate survival dataKlaus Holst & Thomas Scheike endstream endobj 99 0 obj << /Filter /FlateDecode /Length 2289 >> stream xY˒R_UFx2q*vInq"evH j8T/Z>_)& ?}H_=\5PKa \-Rj3,5YOmWm&+*N C͝,OUW>2L=*ͻ<=k5=k5>KSJGֻf"Δ1p^?,Пxʏ/X bItJAvJ֟/dspMbJE`F(!Ԟz^ȰV'pw Rl*X~$8/5WE2JppbUãAPK*k4Bs`M jN3ͦ-z9V+ ^fz)&> 5C`F8 =̜ CNZg܃c-z oMvSѝ^<As*1ͨ &=)$Q@>-Ars6xXi҄Mŀx0ECS 鮁F잃'@dMt¿裧\V*Ǣ֞(%Co߽8z!yI`iAn%. 麑߇BA:ov\8ԣAfI:dD/zW̎g١9No+2}M,':Ѷ恘M8T.VKӍվs3 F'W۞wq֢"+,,m9mC7`Cp!+#󦬛^yi=#$Ǚ`Y\52L(:g+1=& C|6tRm,F s_T7^2JiۯdxTݦ QMoHt_i 2z/cث[aq٫@U+3V:»3]m?D3Zن ibz ?vQhz^/)=^К\tV>L-fB)hoq 4& ÄY?QJ1(Pe@US_fʀSÛK@3Q2Q\"8 6`t/Rԫf vЍ2Lr!& ӛ(NJ@_s$ _0 >jI5A ioL@4#NFR{ d`Xp-咁|֒fNEpF0BUa%3飘-`5_?xd4*>|:8 YAHG('- =8|X'h'NJKlN5wâjdg{lyYuX:{~/?6ɯwMq#8UFIM9xkƔ6zfR0S[0a;>):^+l| SghFl:ۭ[TL[%ym'.vw+n!D>+({h`|J]n?KÚyfѢB_+ub0¸~#b|uc LWVғiP ۨ˽sMKݶn#(Linn\BB endstream endobj 100 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6825 >> stream xygx[Eڶ#Y!!ڜC@-,ޛS8qmٲdZlU9Ŷ,Kر@z`-KXvGޓ}o ײ}wgy9qiwJNJ ӳOm c.ΉGxj Ehw^fE93i`f<9-t?Io&;{n}3~'$\oex*#| Gě>(Bqa_${rl[#ix6l%B^/)H3O HE2~O& DByVlz}X$JhPIbL)xhƤoQ.+a82K)eӘ,] dbYl >/K -м(TD0T y~N$KȗNōx?:PzV<Ȥ|apޏʋ _s6F-Z%J)L]N^AQIY8C$#;)gg`wޞ}s=>)!2ZNhvͣ=NG{L{B[MOO[CK=M;@[G[O[@@[HH[DDL{wo[(U J".Nu*@٠SaxPc^TTv%Aj2+. ]=`K/yx.f1uԙι׆!||饜l>l>RiS0ûzw`Κ|F5㣟G iѪc+ZwUl2ɺvPw)&o sp=zSU/ZKw9؅D+9YQ+ќHtޫf̓ Jgcl Zs^0᭣v;5epNɜ\eQNR9B `R_oG&1mJRxr!nz"FvopMlZIطk2H ruۏ\R3X1=`*&l DT8( EbV(,gB$.lGoRmXݻg9R]8jBk1#HDtF3hGk"ųܲÆG90h 5EXqs<Ч*TL3I@A!H3YWVMҚL"ll'ϑ|+Ϩd'Ü=7 }A+7Jj^z7әH/CYc;\AB%Ҝ,,kVbz݄9CJDH̄~e;PԽ\)vԻJ{Ys~b45\[oLL9~<3=>_ .#{^bdF1$ L5!J )(c%"Òc,.ZItsj@+яx\{plq/( j 4@t@k!ȹA}O=dM&f2A&08k2BA #@M*H%Q_&SRgl?+1S#V.oȚ |R:Aku8 \R:h u PG a]U =>zY;04UN,cp 2s=+CY[ؓ4ȍXm]*亝.#x`FA86isZ3fF/!j  ڠW)(0KS T)KݢX\>3$C_/7ήv0HMF6a<қ;Wxn{nD:Y܆R`T<7%5MS~=HVbAn-Ԕwlw@u='y('BdkD8Ԋj[U\瓺5F x]^\_68 VNٓ<|r('"#8~~I.wރqk9S,ZUD(P SL"n-^ŨUd;aу"dGo1ulZ#ȮFjNh"麲|G8𣳬X:k8wჟ%a<~[!XkJBԘDʜ9FщF bC19Ud`[x̍^>|%e [}o-ZTrjδT8 2 rT+j¥rby 4; >L[J.*&((RS>5 erJ @D,]&k- Дvo{eb9eoTb0SO ]O9pr>x9jlK3"&PӆB ]g4a^mB 6"DrPV=춤ܼLi1` U0\R0h-,5%H!xxƳ%9?(=hvr 9csTо3~K`5ld8|WZ}ʡp3;t%ruae~Zd W\;GVV M;7qYؔZMmµȅ p;j#GNE~J@La]E/bWpG_Gn۩N( {UfIuD*ՌZ8Öco͚\vo[:GhmIrmn,C4J f9va]@%gSqUR0G_ᕸ_;]e4roN_ѩP ]vD Y C0~fH7gǸ, (7?v8I`>͛-d}O=ukXN1ק/]kl_MwG32oGw_mYȁu"RRƘ8٬Ij%]qFXS>k+QW.DP*S/1_檔6`"\_7axzӤSeb,jb+] |5>C7qSCEq鿻?^w\ TyrrE%CIJ d7(m߫/3YdR&d e*}Z;3d/2lžfDyIPנ )CSM2 *TMvΓ2jBo E |_ ;Y֜ v1^~E{ {Lu㒉 @c{Gq7Wm*.t,3e4#R^GձJ[ =7"#U[ :.v\  ̪etɪ\r+*p ~-mo1=faz . %6v[|SQK魌Wݞ>w/vcr%{m@^WdلP\d6{hzlAgDgEqiu5G @ =(DYtZelknդ;/}eJqgQ>UGsM]Gxa}<}'MTl~☳ɡ{=Xmo~|H[ `zƲ\9Ƞp]+ڿU6<:{0.Zj-?Uo-١$'VٌF'Ǎ _&:n3C"/D,=R\,,f*RP?[;zqWAPĎ}P^`0PZǯQ6W$H2*^* < |7gB;neU8cgSJXÓ {Z F_x lK?> stream xURoLekmNgt 0ɟtmC`'{ݮwu[I$LR U4L%%@AI[矴 05&~$w_l7{/?(."H,{(hĻ_l)EKjLZa=*z5V[^x`頙f6ϜE{V' 9C#7BBDN wUU97+@8MPBQ<]Ab`_[Sǩ{A+2/B wB FO3 f(a-p$ 0؍dsR5$FODN @1$I$Hq2E8kud 4D,ED$@s56(wR+! <1i>?d q Y C@#I`I "ZB\B\t DDҺ>|?)A`:?%2> `c#'.P? ݵ/6BX ;a6(&(b|UJՁ 9q[mPUv(>FT ox֖㷦33wg_p$ +^y*Q}Gw+6GK~rؤ\R޸sTՠ-yP$tHEW/?g }'c~(389KMgCgzRxҎR20vcZE2VЌ#壉PLۭ_eܩQU DyWYHgP6O~A49{|j]q{+~=Qԃ)˕J,WfUf;JGqiMScQ{2R29r0@ pXUӦ{{MNUW$}n_.Bw]i79McZa oWS)ayPʼ endstream endobj 102 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7153 >> stream xy XS׺UjI;EIVuhU댠Tq` I a!@!0XuZ{zvsp?}5|~#\\\7m B¥ ߗ6)bBث2.̔ǘawSƙJG' IT#Q?}Q*e#*F;T"​X+fA?xJnAY)_X Z6KN!)79lcJ?" 2jt-сml{eEӖ,{:scs\_; t"xD 6/[D 1JHl#9b5D!;<‹O#ބ XHl ^%|EFxxp'xD•BxIKf7gޞbfݝoa8i9i[ y ʐ'&zN _a @ =0G5BJu\`/!T]!XO yRsl~fe ©ȇǠ;:qc[vz7M\k~2 [dKr4Ƃ ~L4뼯/"2+-s $]ep1r2KqieswoQt4[Bzaf~M|9[|=g7qbA'X!5&"x܂+~sy$nZ\VZb&9=%==LQIIX*3aܠ;-o ܜM ]zz5rݜávn&}OjpH@U_kyg\aHxy (RdO㎽ƽF\o_oтe#kSyv8#ht皃Iu 䟂8`b xn Hidka%}r۴9\$Y` >j55*ϕLh$_b53f)M6 f;X=m36 =R]Y-3 0D&m~!]!1'i B( RXE쇣Cb#di9_`f;q82Roy9 ,Mf^kw >̿ >&;x]?7?U[d6+yrqyG;z/_<,R;H ]onZYulYVڟ j8z)/:Hx;$k[unăN!b\T N"׶EK7 7c~^ GX<,R{: Ŭ8HC1d߄ ]hՂT!H)3bB2 IKKC*.*(9 $I/w 8_T XJUqs~3x Y6I7"k K t;LrȎn62@2Ć\$#;t&},O'nqIW.`P+417<+8"H8# TKly܌FQg4 s~,:G$P kPUN]ԦU`Xs$C>9.ߒ]oR|y8cT%VPj0u} v0 ǁ,Z$ Irܷ{4NQMzd8)Ski-b7lLз Bרsd Y6L>eN?M49ƨOpE @c Qkq6+$3<8{2_."PƒOиU}t[$zQ ު[0U͠2F&/ƚÇA;hT)k8FMw=lo JBsLDp wC5|.JĐBq\3rC(hzCK}pwEnh/kZwf Q)qoP}Bz8|z 0tqp''<Η$$Kt %8?8mѦV4ʜ3;,]fƊleyB8M8e ~n0jDF9lxMYB٧[5`;bbj+~}potMa*7ACo^ Y{Phy+ԏJ`B)RS|!{v7g'oAw]rJJōɔo3`'{k{ `חfi͋և{WΉs@եBc5T*ew_iswH?p|}ߡnVtG}޼ܜG;-,⿞ٹhުOFQ1he漢 U?Bm֦<`Ÿ(ky]K9@STYcq{nQpړh'2&aKq"f{vyDsB?+~ ߀sqx`#;֌ abKcbcc䍱MCGma.Cܐ+Kv۶&l"^BJ#YmFucB Vdف\시h.kxe}: *~>?iW4CJѸrV\ iM)ify& jPlǍ):o&|3$P𼩦lDB_hg9p9عM W*&9Qwak V%=W#Zd]kny\(ҪT+Oӫp9H@/s@ ue)rq3"NLGk,܍9|3Z'*dSG2ç;L t5tJaCp٪us-.395w}Cu>y$> o[exO蕄/rM_@'1?1<=.p7W鉛3vYCL`gOvo_[|DnѴh)hGC޼(65s M^@T ԗ$qiZs䗛hfm6NVTkj. O4,d;Ź4n@o#j8B3!ga47acmY܋]^`%b`Z[Qi"woh}3n"Mh-<-jWUFߵlD.(;N!X3 +-C󖢧P.zfFg3=Af '"X+kGYHW3Df= ˙r9.q MӀV%N&@1KA-bw;AqLu92ߒ51󣅣6|s~-N;2?]ةt WP6LLeDzHm qˮ A)h [_q"x;pъ-O1K͟}u>ze5^者7_ݜ+hV*x8?wEL4:ckajKo^:y?ﹻB1"U.2F8|8|{bGoa0F6U;p>wf;u;=B_=!6C g6&Q3P{=&~$3KY';;+dp^Hyz znXz3,J%+VsEsa4a#\va  eV Br-Ԋ@WRE=j`pv"%pGUchM%e{!p\i~{ݓm> stream xQOHQ㟒ZwKRS(nbDTڂٙ73/yo˭v負lt1޺dC3bDovK}}? EQƮH:aӃalpB NtPoGnG"^N)v4 *ʪKvćsi 8F`sbpJw1e$E/1aa00t-uH#c6vU l D6`0hu"y/\wFdҰqp;I81 [Y=yI|R"*ŸKR15|:Tr"a`ԙ ÄJlOP'A'ܡjNJ*%z\lN1WZuJ՞>SW8 I-7oنX@CR73?i/Ho7 ~nc͛|KlNXDV؜X+OZ blT^h}ji{װ=~~T6; ^ihwV3krxuFo)۲p`^qBqx`;>b_ eendstream endobj 104 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2067 >> stream x}Tipb[0@JMh:2dB0c%Ykݕe,mٖm>@ 66(`04[ҙh7;<{̋RgVP(YꝬ$In1--MqiљKE󷽹`ֆ},MR@Z%hy 8n> QziFbrL ȇc) vh ^U/"petUغk׾xe v 5ɠi؎=tb 5n`pU=flL[H\ˮL]me0%q5!@jafa`04$Y # jҤz ,f)_ xlaibe6%dԔ`0J+Dj(J`,^&yT8!#&^H01A#*uJZC dW, ,I&kh$-/rQ?,ıN?S$TFRJ#*2Ju`Ds4JP4R7A#\aODqƽSS2+;a#S94m ݬW=:ٽGn;չ'Q6$GK㲀''/%h#0Q]I7 FFɬ]j^Mox^w?ܛRgaM%u{Hl*|%֒2l[uPb0>5G/F5PmUSWP욪RZbi5gG(w0/'SqT;o!E@O[672}>,@wko|lXC]DRv @+@Q3ySog< h*|" 7134|?|?u?MW W 8.y$3mF3klۍ.p_PRm?ȑ+ #xq bi6aTrʠ/W4{ " 7cC1R"7Җ pJPs]ig5\ε#\n?} ?K$by$i@U}*ra0:9Ƴ4u;ե G4Pv.nJqw1[Sw92@wpk? q FeExt[kk^(g=ʑG_,+qm-;A_ˇ6IaT:[XQynVR1ǼF62/]DCNkd#/7i(Gn3#)<G-_ڮBh%OٹEK\-͠ 4iޔQf'okgUrŧҷ?,0|[ٶ,V⫊"tcQ`r|Z}0ԖW8ǂgC'xt y:Wk6#`Tʗ(W<[won++P*(ҕt%CglXNX~0|WQs=V/)-Eygc`Фd?3qr7{o6* S] W<]!\ YewP8PTPL":pW>䌔[GU 71gǝi򴾞 ,Sl9 $>9|12rEvDmBWAS]cmp@ Fݞp߻^_߼>yA8Uf~$>S)QqP?nN~%wڝ /znp% M ӯ>k&d?m=y4p>@߃Ox7TdN\_3 E}C͡vR+P8Έ|0;2grlNJ0+'6?-m2ؘ6O$7Cendstream endobj 105 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 566 >> stream xM_HSqwwNnN{s+dbQhH-Qەڝ21W&Ml׽>ꥇKуCE~R^pp>1qB0s>(g3<0"U-s DDՈxHM呱dl8P@ wvZ K@$A%*#J5ܥ}@LRƨLTQFNS^99|1%J{' ҐPH\{7{#ayPJ&!.OqB\XdLBD2flx2Ui+A\)!)dҠEXq?XLw Mm33mO~{ Wu6؃vt> stream xZY۸Nq~ĢxT%$U[U9T9v6ęCʎ$%rG4n_9Y߽Z<6w_.?wkX@FRX?u?$ FT Y(#sXrPK+4ts}6K#eV/9OBdG(x_DD`%Td4ÒSR\^KA2W"HA R&Eᶠ#-$#Kt7`B(W97tS8ыl_w][XgQl2fP_;KiP(=W3MHg)rU{dbOS4bkWWszkm.<'լ\@P2R蕔j"[JCDDθ.u]WOo^t iZWo"X|VSbϝsdL*gj3B8j#c(cogu ׽?B$F;N~iȗ1Ձџ$Q3 $,x)7cold0=HPמ!hFAOX`W<nl@vxאoӮ hBe-IHJBrn}ߜj`#8`K U<*iÍHM\Uz]D^k(zIqi&m(}\qqŊPfXIg1{Kbk]H;RU}s5B1, wS\j@xYؽ=aٶjGw|4ܭlS ' JkOE`6f zäu!eZ>]VX2R[2 -0L2/+"/Mǽ ν'^ K1ʯ[@\%I2_{`1lmǤVe $q|5|~;(6&|նsSH9#?MfWvidujH ⽧:(܂Dڱif}rWL`":5%dz؉ AdLjM>2$6$^cND)_`嚅ɍe5ڍW(ഗd5@]?V&631!~I~KA+?Q?1vs~Al4_r4endstream endobj 107 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3240 >> stream xUV Xg⑎h]j]U-  HzD %$0ɗ0RaQ""k\Z[ڪn}q}v 'ϓg濾{~CL62vd鍖Wc¤Y8aDǣGW'F.vɜ_~-/wQFGr鬓Ys2)6fjܚiӧx62k̖'32՘lf&,ɒf0f0!aLIL-sِ11[I2 Lu"^31љ[LD&ʘh0[ Ә$Kc|a-ff37x!;ѐ.M` iF?3F+3 zfaDS^ Ǔ,faixmڬt#F/ hK٤V#f,Ixޒ)~:gVfȶIqњn BhN~}aHeM\)+1ϱ֥r|{-UOmV)i&DL0]gI33 _Llɰ2t9zfuo+TMUp?#'y}ϟ@"@@#Cw~? NZ|M( bfh(Luhxq(EG l6!=zO 9mI P$V'h=>K 8.DfQ$; z);nOnwwzuZ:׮KxӴeB 4:Ck}JX?ޮfc!˂S*͍֬ ϥT?pE1+ ҳ P Rӑ#@|'NTjV[wPRРQ=費AssD6ܓ f!Np͂Y`:k8*z=UmI=VLY8 EkI$ҀםZO6*XU§W1%I_x.{xȧQHZ4 ɍtpPM>5U=&Wɤ8!&u&NUOe;`([r=aoEH-FNB4X75Y2!Ѣ }.sPv֔7z6r ֶ @"mlQFKWPBP˙F^W/9Pę=j'luz( ! (F`6^eC3\ΗA-4`"bPF2G]7j1XHTQm7s2]VF>]xG qopO^UCM^GM_c<`Wwkt/O^@2qY qY˺Wֶ'eMe-pYHpNo~vA#ł(0BP["mr(ܖ_`˙LGTJ+4`.-2HDaiFht7]s+L1nS59;SBY7q ni~~kG8b igQ1=<8VtFCucUyš1 VG\Wds3INgٜƥNμBdg/^Z_gY>%6rZ~7JRlNQnNQ3tx܈1 @gڴ|] g8gP[#=SUڍsT*yRT Uw6Nu rӨڡ;;ff;8eoz٥O.{cJ>ceR?K0:12g]n{6=m)Ys,ܽE6-gЭ&x/ܑ#@p_f=Z sSg;|;0za=e[cTґRb.).qUҝqب lg =a8$<*ٖq`O onʯ JJ^8x\U+#!>HLjS%cjS$mAuKi3- c"ޚ|rA+\]+ vp" J@ːPĨ'_}|U_oM f;I$**9pZ2hzA 2\ Cԧ v3P$sʏn/|#]TpYXZ`,-FUخR0e75vk)MLRX!}u$(YYwh-(N&18o z 'KNQv;P38GHu:ro/}tNy$modIt6a|sx$cHvDf+O(`%!*UVt5*2B;ѝ]Z_|X]Ho2!t} R1y-Q٧Q}ݹcgn-d8 M}ZuT{ޠ ='. ]__+?ePm/bnԃ=-g~aQh_@S qb&uMOԝ ڕ/j썂q玝(Qy`؍*oT@endstream endobj 108 0 obj << /Filter /FlateDecode /Length 201 >> stream x] w7(u0,8hPJ|{9Pc>C3oi2W&|LK2$prQG:ޞy.@WGl.m˕Mf`l+:׆TTV*bIAU%*[NvYWk BLx4,)aJF~H]<^f_endstream endobj 109 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 826 >> stream xuRkSw~Ě:i^C$S:u+tuA˽%%ܴqiMz8C*O^sn[19|99=3;7+Ilvn0S|9n;~!y|$ȉql%5~}2[Nė"{&tt &Ϣ\|)ٙAj"l,ĉ dX?=^$0*cgϱҒf.dx"4.\<-Zc 8 `pQ# !E y>Bh Vaԇ&<`:ޱ}ohd{w cf\.}ʭe|o޽S 9jբV}!פi -o viq{w|c'yА$H$|;h6 tms1%%TJustTRJ6+{$oLb^$od$kw|<H^{ꚦCzwRZӳGS c1S5)H^6*5.P-qk=?Աzn7_KӤJN[r\$x1q:NljC4P95?=F\3l>뽤ˀⅴ/imJŨdd5IᐩGhu;I!>3endstream endobj 110 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 332 >> stream xcd`ab`dddw441H3a!ܝVY~'0{Sonn }=I19(3=DA#YS\GR17(391O7$#57QOL-Tа())///K-/JQ(,PJ-N-*KMQp+QKMU8SB9)槤100010301297e{ 'tOsD>xendstream endobj 111 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1149 >> stream x}QoLg+; VwY!`DeL2 0rڻu nBۗ d, T18 :2aX{4ے7yIdZ$7:V?6[zKtVSqGe]b#-23~zZ-=E&Q@Α C>Jܥr>B> 8m۶uuY`[H< {8 (~mIl/sį(+pLJW6Wr])-dYРݜ@/"',weXTVyw yx`FǠr RA 42ƤGpSX@S(5D [ɐ^$J'bpyl@:VXW*23'1Oʞ[q^CCID权N'Jd,XƱjLTy9ԚֺϨGپDr>P)ߜ`&Q2S6 &jaB#C),p75g_OC/_v0d즉ޯ hCgTb~fفLD]XC 7"~WODXdvg&;ޚ7 F Ǩ4*<Fֽs()RLg|L[@gcQ:I5TBG''ǧGŏOS/Ijo4kGQz *HSH=Ij L̨+5&7uO=h{^CE)+ }86څ:]&g?/-r'/-3Sn|# Sˈ7WkV<-WWtC}gp;7w-uyͯ#ڧg ⒕_ߚ:[7syL/WgqF^RY}@)LU =gt@8OF݇i$~.I3>pE FѷS8yoGw2;^}bf5{QDtMAʸn}L3Qԛ^taZ=Dm\۴ecۆmmĖM endstream endobj 112 0 obj << /Filter /FlateDecode /Length 4394 >> stream x\ۖ۶|JCmuMiLL@43u뒱= )j<ۮxU6A>QsdDM. ; j2~˩,a3I~e?s]%2vzq-~ ueXSh P6 vUô>_5,;X d#ٳ[Vf!]1̈V( L5]lWm۵77Sp2Y\kEx!{foD\wB<X3Xʙ"WtA$Xx}>`XHk*kBR*óu"JHZivGP2'TYG'ΈQ5QзBRrV| XvݳB$ϜnkEeM#c]W(;]uZXbg _\ڣED.c5z4DlFCP=e!Wp첌- BPT`bs$4aAi.xM|qed9ŶrSVbDf;x\-ep˜JZ y Wb`\>gI@R8QR !n"H-,~d4qVjvEѰ&όb%aw61B R[sGb_gk jyt㝻hCN% r€ 91YZSbzI4<{8Pʑtջ6A=7T%6S-fT`\b5"DAtwxb;bʖ*l\;p89; :招:|YnM6 ߻М xnt<<+^-Ս_B^/j`UNQq/!g?_nΨS0s%g!%~Q ֩ QQ ^!(/:T|Q,nG2}sMt?n.kն-e<`I\~;_-_1y| bڅv|Z&=*p%;q {('("BUE M4WbέK鐤ANH`|{$T*:<|4E,Ѐ׀ !jAhrH Lu<"Jz;9, a@Nt6]W(!1{`̺lbN@ a'('BdDhUua)g0Ky~CUߧr$aR^1H{Ud$9nRKQԙn+7أD'@'uBFQ)=kٙaQ2C48E UU()̓ zBFlz6Z"%oD7Q ]؂-e=\w //&m/A/5)G/>L^ qK6ka`u% 1|LBȄ24e3d2,VP&ȑbA8A|ybF!i h|L6PR1gfuɺ.4}<" KV{ I$ۃ);m,߹%v"[&)S4~MBh+P\WfAW諠}vN >xyЦ ݔ[j=7MpP$3Z*YZF =YWHHR#ѽRPuN'k$xX_~0k`aF*B$ʹ!uS)`Q0tbeА5f1T@|?~F_pI@\MPƊy]SAuq'C8i2Ւ 5LH1E5D4 1umD_F6==.L}:*,.V2 l呁#1PH'%=̩ҭhWn}>u͓%>) "'qF @MGO N! [e-IyZ̼$­ J+Mtʧd_I/SGx.pj >L#q #n 0SR7no}l ~aB*)rwP$cf*5oa7&gޱd`F?{'%{ӿ7Ɓѿ\ P,~a0+t5z:5=@' "@I7P|?HWPmh!KeS G*φ=Hyob3#Kn]f/ovͭ\6*bվpi_t3ć(.|N7IPrqE묁V)_c!]gev (٢jv>y'VE.(V3uVc8I 1*>jJ V@tfP`a5 /s4-f:3f#EQrFxb9+ٿ'gZ,Sᢘpȫ X/(877Ԋ6vfBO'ȗ87%vww d3 ,~yRٗ}E!_ϸc)CF ka7$n`yЇˌtBAAydjhpxzRcnڛH2I麯@,zeGH K1j<+jU+WCTJ\jf[=WT0VjL!ѳ3 ׉}B=+=&8=isv5ЈOEzЗ wU.ܠ d8΀["\)݆S%}oE"P+LރiVѪ`ӯ/xendstream endobj 113 0 obj << /Filter /FlateDecode /Length 2792 >> stream xZ[o򸿂P djs11ҋ6@RUo?{ 2%}+ r8{\.a' WonzŻj&x0"'[j=O7T&%ҥ8K\RƴnRJr? CQqZ MaueLmԌ2 95\h #w{kvU,#`M6++G 凉0 *lN  èwLq_t'ȏg)dJwzA^?jDMqꘗq?<.DW8(kL;DE57L:pFъr&*8EPDRQ8\tD$yJtb3'Qq L1:'sm!L,hb]#)cO"Z??"mY IGBdŧ\u?d~h?U(h/ _o1.r/^6kZCGz;n3M޲5Cl[IR5TuPI`yP7yUpO.\Ffe9I:Mů)uDތz"oF a㾍_AYqΣ6HA9zbH<ɃPESqt1P7aȚ[FΩi4#p–hn!n=5Rr;ȯS0 N\Z\,VC1#uj]49(Gi(w}##uPs5?g>֩αv]VY6Z '7vV)w2{%ֆλ-}E/&L`}L=D)H>&fpvR@ZfjQ !:?w^erL%m(|$&SP/z4~B cY"!}0&),׃9~z vTRfV3^9NJS4uP9hD+1#apg,ۑm5ݡՂ,bUCQD*4>lz~B48`cy2?xmMygpsSDʹr.6﫬iOp;*B7󶬦;&i)W28]]{[=w CWLL$vnm4%vt5v3A֓`VHw4ih#gyv7 PZCqrg,U6“H|qC]v-elb6f񺟤F2R LF]%(㍮յmS\yj׬tv90` mSVva g.ATv~qK#iK!eo&'4,O&!(1rV-33%,ΫX {+AG}WҲp.@˪bAByQ _AI+edWXՓnn7Wu U1PQ!bpI$[uxoCu͵U!@iqWX_Qqz g&#l[ORy@Q c6v_DvZsVFP |q5v]45flq%?B;{$uͦU,HZ}vG|QOGح)g ž/pDy>:`yi>a:cˎ˘|1O5iqmhWOD|6,{vj>ej`Q T `1L$F*3iRͤ< +K>>#!kג<iGICzAc_yCUGyCXX)xE>yc$i`'獑O %'Khxyk0)S6`Wm57e 9|Ȥ2eG$F$:烇 Ke|X19+2ī2[{-n;iϙm6-M; "k6]`pPPz ΟF&Ue <t-r xN&u[@Np px5HT.xw¯P]r(fzFÃC4(__FqY^,z?GUZ&>0>Q4]*y2]- %> stream xxXDQ#Q̐KFI,(bPaa]Y^7)(v1Fo-DMsgw]U3{|ք23LLL^^ko4;-Tl8Dg*HKm;-y8 lYH(N/S-^vAQ}lfϜwmܣli/(B-fo8El^ q{ylmټqF6ƛ p`HQ `e!C+nk"FyG{:yqܵoSf=g;{'My}ۧMw&ES $ʑLm6QS)'j ZJMQv ʙZFImSoQ+JjzZM͡Pkw({j@ͧFRKBq(j4eEYSj 52h^l!ʂF-S#(;rJؚ5dhL%yhb><Ӯ(͌bj_l!CMMúO/|H7-},/WnqXThvt0[qL؝ck9+Ƨ0~)kK!5tԖ?jL4Nk F1;O{wv$ҒQ/co#*:qaFԪ}Sp[mx|ey,Adf*`n M &4PAO1p<4~F=k.HRjN  1y}U|ǨǥViEL;` 5*S#x%VXx%00:U45_6Jܭ=°?cݣyp8R̛3/#(b@`ţf\|)N}zʹjO4Drs{$B2Gq%lTfx=%,F"yPJДLk-k@FRRY=A5|cHk&bD,nl<İ g IcϦ{!J:73)#ɢC ڐY>u|7_VY%UV&,ݳ-' U:qeUdt$ߟ-Oj@A)ֶj3'KV$ ]}p"Z\RXr0GJeiv #^%%W# pA[={ ު2>RP[i "?_/?v9LL n<`UL'Eρv{j gn2{aYoxxSX~>ͤkhE#Jp,7!WF҃%tZYasaLtG-ڋUM.A̪j/wIYI|$?-=%'z+a: CLq0 Bjt- &>C"t):;qWM0FrhMږ-2-$O8FBn1tCmf`C&lN<}6,6wfp}{30T膡F78}dQW ];͢Ņ܏K|rn+b.Y2ǯا&D`_RƠX4M@$30a'D'Q*?;WHj;7kߗP%TΓW&V!^6N<[DmuѮG\cܦˎ8٣߃zϐ?} C G&7K ஶFsSSq!؈ }܁LLܝSjZE9î=x'c]xT&kCɖ>a퉺rWM5Hb=VV"F:T{ ďĹ9W~1S^|z6`&?5#7% 3b5"---=>ĩCBנD 9&ڮJV`N8~{fuyW꺂>DJ]5Yhcga֜z#pՅ`8nuҟSjRm[SRj/ON1{ /rr1Juq''.# 6:4A]_Sq0*bK*‰314Do0D`0HI` `fjgDUsӇ~^X;ӷs<|PII78u ʌeDR>=e'Ox(5¬4~O<8ED=G>ѿ[G4bHtJLqC\.n;jie}jKz_R?|vR#mq4\{aBRJDD,&E..04r;픲!: T%FgǠdtbdjNlX{ڷV[`kT1WT*E;&> T嗜0a帞y 5µ#UnG,Pgttwm O5^ţ_V9~ix(I0<r[5[,u_';tIόˊM@LBdWsq)?mT/KR=}5 'pK 95X09 z]BLG ޢwee<$mOrPq,b\wqV{ei(ZO'QmyoUc c%F2 hK[PKy֌˓y55yfyƦ{ A~ң_.s^~fLW.Bը289-5-%0lgheXKKUMsixOlvCW50{r,Y܂5vv>_a!o\G5tNrzwy$$FM]=4fDx=d퇔m弲ǎ{`훭|vUFd }(^YƀxrmA{"Bbvwf+u ʮSV1+3NUI%}A 6:6.%f]ω|>X8s&JG>HQƠ򆨺HEN߁',sXw${0`,̅& c%-;?p623;zp/WG{D?Xʡ\ãpJiV% 9\hi* ~'u/vhڱ-PRT썬 6L 142=7nV)[_ Cna`aﰏgW{SQ eD/eȸ.g˶ޞhv>yGΛ}Žζ^!GGEDƦE鉙i(:"!8},)Ey֧qmNvvzN';9HWU}~QE ]Gj +nI %LLTZT(پ璔E1Q1{*?* `mIEoPEb~jDo;pލN͡+G;().AyLircp>.ok}ae |_O Җ퓈>b"wvUs] 1 uU94oifǮpy|J>rfP̑2a\|d'>p "b\w߰ļT=[ֵpUh-CjfT| .&(tXlkr m$5kf2utJ鮢V[l Eܒ$J1]:dHFF俞D2g{j/!>C䑮0gJO=lw 9VR*sx<3>9#23ѕ~?O@ʁa^?4Zc%[&9o4gBbBŊ r1> stream xX TS־H{yUXk"*2!H$0<8RZjPCgkקo޿ }b{|%,7;8Hgmo '%HK{U+&XufF(7&`ſ1E-)3`$hTn7oΜft3\ߙww)ʑrPVjNP;.j5MfQ{5lʕZKKP Fj>eO-R(j 5r(OʚFQ([ʂL )NFRR2j 5V7PT,uN0_pd7lYڼ"ip0D2}Ã4wGfG]t1౻>\k6n8ոr.*i] Nh?i⿬/،g5aLo;vʶ>j׀jV?ꐓn/n@G =݋F{Mr:F PʝĽM#]m'h%-jC==%aN, uMu3 8rr] >֡Jr[̚-?y,ٕ⹎Vr7n^qǒ fM!  {|?v`82Q5ȃM#E:!D3sx%ψ+ߺ9ŕmn6ǿĽKL#Ta0QHZdڷb3%MIV7x]8mh>ݏVY=@Bdښ>Oa3z < E_tUs;Šʆ/ba7K 6*P R@VZ۔~{#>`\Ң +tw Oy$ x"- Msz8 _3 @ VtpΒJn~>k8Q9MIrJ9GHhQϢeq~ˠE5?Ȣg] w++ZUw_k@Y/ xS#m`hCC|X$jz(:﬛ߝPǛ[6-x鄏E:ڨآ:Z&HU)%nL:hi<]MEmw q ,(JS)a4t!G^{ *r\DZ7A; VgtHNpvwS" 7E>i"&5 ۔Y|q ak7x/.%BQbO#jN]=:\\+xg'Cn49[tVC)nj(~o򫅥Fb)&?T#L5h<Y7pE|=C x5@q'ǢHXtWsf{lQW7xW3 d.Y)x$kI+C NbްO8s_ kX~n0j0fPtZa*/|~!UbX dX^ \diď_#Vh+VpB Bo)D-csbJS483 RI͊s!7Jî(-R`ZIY?Hn&E/֚X KTrдJCQH"en~m3ˡ 3l2Jry?סf ժ|yl l*Z`[wt4u_cB0UUw^c1Eo\j"2.2ra'u}!!1! oH$0$7'Ʒ#Wfu0FA 7 iWl&{rF|{Yg兴@ 5d]A.̀U Պ)z|!Ңb6`q?N\gIz(Z j!WŢy \٪XL2kDgJ$cljG3}a+}Tm-]}bk>b}(!c jL[7N";,F|͚̑0Q& 4lĘ/:ixMpH Z5H2!YMΰCAtU AOX̜Jdh<[q]M87w\Сrmh!BO264|1uq;\ a!ğ;_B\[Eg=h+v) kyE4J+@䄍YAwS;͔P)5MChOѷ/kZLYʆR8*gW:OI9xquG` ++fU%aZ!pZA{P1uD"d[w-5\"BbR!^/"P YPߨjUwm4DRXBjʊ:c}.'N={݅bϵ^uDg۱YlI*x0.n'۟/hӟ/}!z?VthMWJ |W>wHAMOg|Tp*LF?[~A4OMRixTZT[dD97oN@D m^ }"Wf+9 'ӧ#a,6+(MÄNuU88Zd[KZ>l&bsl1 O"ڵ9̑34 ٳ+ xtu c4&AИϡIB2^ VLE !hB }7/aMfz<i( 꺎VWղJ!~$t:x782y}m[g~[";<|ɒ8g[B)+z\PR͕<@Kޅk]=9@e}H{d54CÆS[l&ؔGJ#-T$-\A o<13ZFGtJD6LAHE;V'oz >?Vk nշ~F|ogݸg}PMT}}uUC”\Q 9xHc=Bt^i tdEkwm0dy_.#3'22 l@U Wq+&<ފGؤ$UEBfG){dq7IZ$0eŹliIs]%@VJ(*XXT}3 E -aQQn$r3f9ݑӡ嘷VBD0Y1GX8$l0`rsM(ha\7:H}$>=R,ڌ⇼ҫ7Or"; m9]Ck7-[sg 9h22 86(B"q|,IzRC(nTIeѤgHn`ndQu;D<2yXQf!9t"3t_z,o$X<7Cϻg%`sqIM& l@SB˭5z3PhgY=@f?}G]3bW 6UPTcV$yhP#|[Q_|Ţ#`FQ HU],SDmsB4%}d}!v޺kْ[n||Zl<=b EkH\ };$Iş7CėMZ$hTX]IR u܄GKK!!]#1T'Ch5@ rKڦ^^"HǓ{{%'%ԏsAjV>dI6M.2$Ӱ4.lc{1>w[e泐wxs;*e ^|xf͝ ]A\o#@&Kb ~Gc/VfC[!XY1||]s!Xl"$XJsۻjOrŲ3ؠwt;x%?N| bXoa(ONc,xxIO钣p3ekrԹb[stkn6QB Jy6vHdg3{VXLcNUMg~%U}_Җ`an(/mIDkD?yO?@NwL~uDq,fG7HȈÜ0|"ޝGC|54#" ?%'ܼB%\&MGyVJ9*l{q&CHŌ.y_n4D5߶xƐU&\MWF"5%/3x)Ҩ0udJTB:$لW*+ \Wȵ_ȯ.DKK25vn$;|tp5HY1=#KS7jTgmFfvVF&iG,Oendstream endobj 116 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5099 >> stream xXiTTW%U(X2ɽqFF^hԈ2@P#)b*@ Dq8E%&Q4 fXt_'97}NQF~QkV:gob(LܸiPxт9ᵥQQI~ģ+_{rǫvO0Es@tS1ϓ x&N$8E✬Ҹ%=`B\4n¸ yqI^N\j 7-,Ŝ¸8Af\BƮln[۷l{z[ -*J\}`MqIP$Nmox+sKVvN^~-]6}+s>̂x'^"f[6"N vnbH$V =b-XG,& &b31!& {x_':iX@M6@*((H;@YJAۛSXdЄ n*6f|"bSp3Cg81k1~(h=Y ʀ&_Tc9Φk6.%/(/+bhxpx- lSY(Cv>l8Q.8:WTr IEoWL"R8fjCZ|N`I@>+@Eo#V0+ߧr):E ZwLFC3g qb#@NfZKaq5cKM()jV/bk|!@]]GSރn m#@xn R+ޒJi"'^VP*VuYhk vt8z1 8ٖ0 DY>+܆ڪS :1]Vrwk-A/h zZ= Ne |sP7|,y=T.@g--(i:ꙑbNgzf'.訮Mx}TkeUZ ۞9W3i+߆"1A?q؏ٖ_xS90Hf@HAR6rцҴL@nmnړ\{m X(#/Ջpvd8MLM`uiUaNݍfM~U.0A#rVB 6Vh: H9ͺ# %oebHʵJ@tLsOw:)<8:! ]nD=xb;`P)$~O^$M]Cfw>_Ƈ;Э*T95qm= b(uNpX3m!@tU:fZڱO)|P9 XyCq@kP'ֵ r>3CKq`O ,ɥL6#7 M?xjsSCwi{h{yfkgTs*8[2WIo)k{oSO0 FI~~]bOTFvXa%+ QtwUqB֞:/T<ܘllSZVVnԔ3s{@2ռFY|-] xA3T@+H5n?2s~8\ZozyVg4bie9?eߠt1Z}PE @G;{B<GL| 3>~tnpt9<122P3ک9|iUEB2Z` A}DH"臱,@qk@Nw,jM2I&?0mjQ`n9MH4~>W >2ø w9l+\si}EX t]< JG'7 ng7 FFHMˋu)-m옗'kZnql / \"̬ݻӶUf7l.oiMF%n88:ms}aGvы5}@ "C?u1wT֡aX>s8߄'m8oBޝ7GQ([ZNnzS<d"W 7s!v%F*K[KzF`G+\T1}T'̒ ԡ'dߢye CZUb9|A+4ւ6xDAI~A1|0[@g߀Ŝ-=y@M'ly B# d:_\Wysϓ \E2&졅Z+J35%ꚫ\V,s˟Uwc  w{V G.я*ӅIAL ;>I7V.;"W FGl+N?iF-/:.I}7Y+1AW/]p3M0r5Nl>p D -tKj T3b6 xKG_.ĺ\T ^s3>"x+f RTT;T: 'I =+3s(O3 勼y630YhqFW))mꃓ>9c|(w뷜bloE.y06 &Yڑ_/M<:MO(e+.;8;:A=DVS}d[_= 5endstream endobj 117 0 obj << /Filter /FlateDecode /Length 2691 >> stream xZˏ۸zw!Mt3VŗHͥtvn0ރb3JH,9{=g2dQad_Q(zǟLtUj~˨3_GbБ]*hy$qi,ztɲDaM-ی'\IEu5VxP*e2<4eE8JCmwVDx86e>ϗ ͪnGX |oL_]M+VH I˪/  aEdaM*Z"ir(fXߒ&HsDOz!ǐE' $qHl~ToF>3.%6"|}x Fy}Un.IWVOfc,r^g:Te\l*;el:W-BY"4GE3vZA}\Al3EvYSAnQծxGqDeEbr ϫKifrؗ~)-CtyRti)|bW/_Ul; V%$2*r؇!'qNL)wKGA)9ޮZ|$!H\#kXX%C њUJRҧdHH 3}>gE,t7MN7F@ G ǜXvUl(0#ɐeUyiq:onHƚjr _ԛ^l0uJu MPpĎђ5 n HC\Qi|4jsCTwϪ i$Ӡ(;ZWZ ˆeE3kYUXI~Ug)mâ6۲$&r$Tw1vr*E*IID|nBuۍUGH ij7YdK9k4LDA\4he :&ѝ9el6U~S$xwI$=cۂͷFW l6iIt~], M1`Oodld;[}Ncel]z8ӤV\pz_ثÌ/վ,=wyV}f:cb6Hy2 Xh2 |Qd!ek*|tgZ#?=K,6*wP myo^?'"1[n$it2汝k9.PP|ixޣI`S!1roă(ODjeT <ԳtѣVA:EN(H&==Lj^_W})Y+4sWӰja퐨'v(diOh l~"s 7pfĝZ +745ON| OcTqtEVt !H-Sk|spbpTC)I==x0G 9aM/ n=<%BwXZX6D^NCcR6-/MTx!EAP]v>:$T]HŶe9~!HT²Ea4M8{ן`vo6Ce5胈iOD(2B&8c 636FY:H]#vf0ͬ ym!1 C` }P IoEw0^ .!EUP'޾Kl&NAdՀ4i5woCz1S1gXc* ̧5`p+ޫe>w`ꂻ{BQ$PIID0)c8&H WbԬttt)8]I'!w $}F0BH’pFrϐ}J jDH'#ߜs `V΍44qu?1փEFhyxHE$c O(2iuu!t6͇Zc ׏]eDw[8F+ +Jy*h$18Ֆpdi3A^9 ˇ&RPF5;;6K;TH5\Eܷu,WcF]<bfQ`]YV#Ձ͖͜]v9.ct;b[Cft86d'T7WJFއw7)iOWhxӀphsVia80g.OGDPFW_ݧUU;f ֚c:NC-|%|`9Zr jǣb`:V6DcŅ G4Um]t)HP_nwUJ' }7? B~fUeMA|Rpd$4Mֵ XEg) _6d5Ԁ>ǶU[+6^ʖ nmψe:Tݎm+C? Kendstream endobj 118 0 obj << /Filter /FlateDecode /Length 3289 >> stream xZ]sG @ACim$n`+7Hqo?z.HDiݵ;}0/=85gѧ]9wG=7fﯰ@l*~%ב|mjtͲ4BLXr"IR,Kh.NwRXئ[{[ߍㄭ&SG17)ۇ;}Pr'ZzYhBlPVN*{$V`!*,I,c5*Ko:OA|"QbxJ$܌"5M4 iVβe QLncͺu7LÄHm؈-&WhAEpNKTz5a)bO)j&DBK#yU#Ou4w+d$GFv]Ot.esE։!+(ۮ]['+=!)vM:-:oӛoH#ĢxYmXy-O" +C^2*⬯MR4^jEB=3p$icf%F/O e^yzpO.y3OdPJu%S!#M,~6X*}6б|N6g' 9B؈0á!w0dAQ!>Nnv ф -i*r( ,OcI@r?{QFߍÝr()4iyHx Bg7)a.G)xǛDBRzpn'IDZ!+z9ᱹ5V)fwCERƗ 7~~i5T JHGR.?h,nKo'MBclPNo'Ԭ6wx;F`:U B45{]f뼥,eg,kgoplwc)^64mڑBotە9cB<9D٬vd&)nw`VnY*w> Cқt΍y cMB[*Zυt}_Mb:.4I| '}^A + |[-}"C+(Ap{%Pc *qթ# ۬c'uN ?Dq)9QҠ*הxTnueu:esho%89K|u5nw#Tvu5TG7x 4Q<]mcx3^wEZ[[GL89z[*s  =:K'ji 3`lNV5% MkTB9.qn\.%5R:4K^xFƋ7`kvwEcvwvn U~ T˛ɿ~dܗ.7_L.F_OyFgF%H:/d]U^~3}d`MlpS eyհ"_:胖8OՁۢmga0릉u&ah&K bS4SϷ3VW1Q^\qFk*&mmqlYz#`)ᬞ`n% JS AS1c4h! :[`WvcBM;GY4%eRAִG_Ŋ|kgPYPk=\7'_l[@tkg_ZWoeQ|]dmާt7~FsodpugHiA8( ދa8U Fqϲ_Y.L&ԙ85PӤTPUȱm>8&oVn/F>~MmzO?aB*88wq{,t\R(郪a!DJg-3N@0o/DE+[–<}lM/eVo'L_.G'Y1!"@Ev1Tt}{8Bb~tZJE03ǰV ܝJݗ@ECמp ^;vW@wLŸHm$y_@'/X8c̐@\_ M| 9}Q ۉaR/ݐ,Ag56Ā8r%}ٗex`ρzBB3c8GX7}5rT0a > stream xZ[oܸq~(T~)Zm-zI-vVvf4q_CRɱ|Es?9Ww]|*.Ľ,?mS@Ea*#,N/ )Q2PFV8.P].9lR]$XtuSrx\G#%jGN*vŽ~cR -!K@C\M~*9J|GZN[zVcYS1WC9,l,YЎh V>b!50D ;D "3RW\*%UP/f4#QJPwPc)N2=/@>24̈83t,mg}䖸=cq[ivf*&RiL0n}]m:A{&ЫM펀 ṇmn6Fˑݪ7`Mwܴ4tCx=/^ضqK&lNwC䈡s4DztLՇݗW\R)QXqdׄ :uz*yCsIT IN[)+T/H4'&m-l._-*MV&Z2–~-d*H* JankS`ۮ꫰ҢKcM pZ ECƥ+n6~+뮤#۰p@=&9&ȓMѪޅ]Ld$^qq}? RA.ʕ9ݧv_[*M'eQ9*h W>ClF0/4 ֬(vE{ޕCh@vzl;9ۛMs^{%nóU`d̋ҕ'h [cz=+pSdJl 8I>VBhTo?G6f3}J".h00Bj!avyqNbnoIwZT`!u~F$q^DY|’grhEF]}I\cJ6YWmgV0|IpB.}jQ oӷѪŕyZyyey%<94};2<3 %.t]8g)pl& 1g/EEǝ)Ev)gxYc!g 9ɜaSN|:X=iCfqj iбCI1h V@)r;U&xjH& {`6wfXh_$| lu#i+R-.f t[h+hU]0eCXN+ŻiPD@ok ~HYaޝtv TAQ¶>Zb(4DlB++X KPW'm Fsݾv8fDUjrOXUCk~(@g 5Tboe_8.2;]t;jwLuҮ1~* ToWvr!R3VNq 5v_m+D;T`ߌ+VNTPd_/kBmej[ֳd)L{'fȰb3 ~k2zuHT芏V:;L|yvBPU?qgJtp6sƞ?%}O'tfUsr h^ڻ=n-st36 us1)H"6fs]ifծѦ&lk|dL9B&;WYOs[vsg y|.iV8r}$m&9?VO=G#ԩ{ YP@3@PB}g飍61&7 R5_q#%SKM8Iڏ#e:Rt4Tm`;Ħ4hbl<-8m;?\|H! [ߺ|}\!CtNGs]zDU<U97X M]ROP109_bhư*nPu'>KgfOi`,_wUu?< T}/7̊~wI(^*o fa|5T18;:qܗ@q M]tC{u?.nendstream endobj 120 0 obj << /Filter /FlateDecode /Length 2413 >> stream xY[۶i+8; 2S4d:iSoۙx܈jv=cp SF0͈;<ׇvAO ̆ &0YlSv/kK3maJD }.E`ۿZP5 F0C&tW`BBt/euq4! k:bVV ()D-eٜY{'c%+Qk W7Ji,ϊ e"ɮ6W8`= P 0K趬ձ7amN LmufSt_u;EѮoveXu8VE.q lqB 9@U+ޣiFAŒQcnaP]*MU䣊y[Kif-4cFau96X. i{8=_9(uvXp!N8_'Q Ld,?r!<=Z`8Q,;W?|` %RYFaޣM f֟?wFQs^Z(bO*sl°"]ğCw(KCY ەzpʒ]T#cf.U,'lLI3D[0pptEjLW2b'%t7\+5g&gmz꤁W D`PcNj@}w!5mWܖQT1pPaY"H^Y TfWt)<ܣmtWxP*督 kR;r1Hdg OUqc*eS€@u#@z„@A;ut usHce;v&Pg7쭫a⎜hk88I]=O`Q6v(!'m=oWUS(UMboDR85Q>h^ms,Hm懄ډfzR*:qqưsМMt&3h<."=U)G8[5`gꖰPxZHBm60ۈⶉ4ZHfSb{;^BNu|ޟڮ<^/7EWr1Rҵ:r=e<2&J<5.j,rS:,m"Ć]&`s7)& kĖ<8}Uځwr  şe"xnu[Wݍy+8Q \ڟ=̅}*=S 1p6-2ix y-J@j_w%$z/*eUAvٱ]_$/"nCԫ?B3k6~_c |<ȳ,v jNu1V[w堹cTi؇EP¶ jo8xY ;i!IM !kCݫ$ňgck`8Xs)iDhK63nAoGP7Q 7 I4(ȃ8L"O9I{ga@Wi8#e"Lu)85LJA 0ɨ raLA{J,(8"l,{ {+λz_ƍr-#DGv IcoBa7ǣ8CWgy pڹ֢^!D 6^&X"Y" +&z8=9TYzns <ݜVP@#<} Cg̻A5aMG=V3x>l|tvwΖKC؇aC&nj>*ʕM XBu@' E۾x2CÐygRmQ{q;*)NjW-$ձ4E*D]\u{ ]K%`Ȼ{J/ 66n(&ws[N=US:vkvaLkKXn4^XCm_gǣŧxju'dt Ʃz1֙jy=0Ia_2s3p"tq7jˮغ;՘3maǻ2} 0D1.UNj]s'Y3tzGt&w. Sendstream endobj 121 0 obj << /Filter /FlateDecode /Length 2646 >> stream xZYo_A z>Cv3@6Ak-wuxDjίOU7lʴe?*V_׌Qm?ɇ춞vuYd_W#Ns]Lƒ,Xf&"L.b:@hͷ9RTBJ?uX:]JB)P |3+J(:?'sWy&|M%Iڷ4 M1ʫD4lTÀ#pQT%]gD薸KM\x9(a9".NC (T;];7uQ ͝.j HŪlI*bs?\npf'?ȩP]'[l uZx1vabĂY(>ůf@V$P xp"cLʺ@r: 㶝,ov޲BD>LQ!҄Nwͪޢ̲>lP5WjhX{aإn^ބͮ_Ik;/ "ya0vV{o7)ֽj͔Yd+M K})`-jL.yZϓxOFo'pr"n!dBkNrr3~6x'0&LD:'鈴y2^*ϓu0 7@HiFsA599 )/"Ff ?fW[YڒbQ^M).ٗY\/ 5;>TVF50JZyi?2 ?Wٸ/#f t$f9e.3.S[ )As!ExkO%L뵏JDm`kH^ iZbH!ZS9 S|ca8 RLAp  ~.6 nQ@)$epD }(#=YV6Qu|[k2]%s(0J6Xʺw} 'DeCvmF !xw4m *ì&9X>dLU^J|LS"aisīVX] T= NQI4xxm֔EX'm?\囲P'1^vnuِ,W9{2Js oשvq 73ĮARO({_f|ft&/:{B !n۪,h'}*?ch+Mv}znﷇuo} wq >3ʙ5t`uv{n>t!m*R|d2(´8 ҩ)l;gu)2y:MjSb=9] ۯC`0 !9?L}-x~6j2Vi8.ifoͻܗ;jhRe >X[-R&UKˑJGapSB0S{SA! *8%\&!ܴ8};qW\,52pkI,=±m܍t#:fv"n*!i? [Ėfo0=Þ51%ЋztbUԣȪ/C+F CFhhGqŒ ˨tv?HIB0) 8?b]y}%z\ /wUOz]moǧZ @03h44i{Č0QL)рgcepwm-.e7! :YiՈNvcpDʽkw w(DUˏ at]ۊA^(D&;s`)Fg- @j#T4.=T1i(DiT/e<9fGڝY(Yx5@rƿK6؋bDv?Qy> stream xY[o#_!l(H,C.4:탽cidOWg4<#9#&Xqx9\xӘQ>f_;_Fl|;iǎ:#r9XrA3>P9\H>)LF61-@)C]:cH Rkd]YYOfQ3C}/lD /W2 iAZ`Z%`!"|c~U5?:oI~줘b0ř_K76!+E ˻iX8<õO`qΑf\Uߥ]Nyz,2cc)ifeI ' ]܆ATYj~GfO]{UQ*MH4l]!mH#Ef_Z2//w0Ǎ%!=N\SjA3.w>- ͂2a,B;H~I*:C~*IRx!, FDPi3YCUkæ% о2TE"6%R4̧*ɓ( +:a1W 5q^I_+)}F QDfLR`G҄5~tꪄ#2Q̸OX..470<]wvLg<2#ǏchW$: &%#,b 54uF:`=o)qˤW[i;|pֵO ~5ʬ*fVt@&k(Smg|{ӔǏ6\V =ĨPMٛ3tB;ʙn;\߳Fm?9'<5H^iݯXtn&-SD/&-\ceKkHwy-n7ɘ33SMh?NB*5qS4x&!Zs F$ Yv"u ű_‹ЕN7^ +'H^M׌Ir_:"!UqiA3nv墨yJLG{ ١_,E{ gf 5_Vӹc|vU ; Za;\=MD&!-N>oň,y]nvjMRZy38#RZ!c1[܃n{#m'ZwY]=$$Ӏ@Oȴ~Pb9I8H@C_@yS}$q}s\"O3788#ܗqlݫF+ "M> stream xY[oQRtTHsKmKD;lteHv€49s|Dڥt3s+ZbESWvvϳgtĦW"8)g|jBIs~'3c3>;sOgz>qi%1+I(qg|nBTZqnB_C,ݛFl[*7DtJ0NXe 4XM]KR,4æ؆'jDzoTwźt9cji ʄ3*C8s~MI+M뉬Qd" T;dT?;pYp9jM#eI*CחtF0FOB^eZןU+p*|,SU*>n5RmǡJb(ׇqġzEĂH[ɻ+آW8Sk]OtM;aG7EU5x?u.Ea2NQ_@\bp.zv\&p?WI7%[!,DU.?>p~pH8d5 4vKS24Goz5FUF0!i]/0rs {w<>?柊bg~,HᦻX>GHu/80ى{Xr5,nnQźFEUb{:#1v aPPLE޽Z֓ohvp槆?0q)&hLwI"(OΡmagw S]0CC*6a>ܲx cLe?L+TQJ< qNP01"ngʚh! ۥ+9rL`g&뇻bCRZoPj_=Ǜz~Wo1-dDpIe$]:M}}%Rvwy8H`[owCbiUH^YrS&zhW (zLK4~Y_qsPx<6̛|0F|_BhLj9'ĜȯD-J>CJhNo϶1~MH%^E'4"foL,Q95iUvGpŒy4lWn xy|endstream endobj 124 0 obj << /Filter /FlateDecode /Length 2213 >> stream xY[o_![ ]8*R`P,}Xtֲ2l{HB%dfmy0E$urY~uAˤٖ_n@ĤFRa!I&22eMXlyANKkRgK%z'04Rrf !P5,kSLD؂K@8}Zr 땊;]M6:$LDP06wօS 10$0k+KoO7_$y;OYR0U"):`G{a5N$2DR_0 3!p*Eq ҠR, DBh¸8a)Vq)*5>pj|^ڗGp4hMn>{iCZeW%$8\Q8kO|mi2kmD_ rYuO] Y=]`Ѝ1CYmQ3U$@a$QfWգO׬|f Q\ f v~x$A`##>1PwHMcmC$C"LvzB8Evt`m޿nL,&nVg(S٦ْ%Q.v;9mr|[Y9óoG-~7j0O&f.Jn`*2E y: zTkSJJK-P3 4Kr/ BA'Z>QQoqoq h)7+D7~q@őOJLqжFE n RhV!ot<_vPMSgUbYO3gf@r}萁,1Y;g'~Զ/|U&f `/6 =j A,0ؐ?h\æ<㮔|WՊOXOpZt%~.$,RyFHn#4!R.4`!0*N #jrfFϸ/ ܶ@*qW׫pn*+z.H 5Y݆?~H.KIGci6JwE5;!-fuXrV(E(lhaQ FK{9!AZkc1G{RC]ݣC|9, ]~͇q^'/_S? 4h"]$w|;.yv,/ Ó]OgbƦOx;o鑱P}ue?,endstream endobj 125 0 obj << /Filter /FlateDecode /Length 2319 >> stream xYnz-:*9o n#Q6It\ãlib€53 .~_癌/z?(;Ox┛_lgE9R >q\/K.V XIͅj[,qaجeۥ ˊ°be28v7JeY=~Zޏ*[XNGAM: +#͘#`(dl $ ; $mM#% Jxಜ?]+rXo "ʆFf:bv$]tvm1ٚV@vv;c0#^3'|F/xT^t,)оQ֏B9B}XDG`p>'7Yg*6َDJvW-_t6uf$ms HRsϵ$lḑP溍]wąp{R&7Bܾ HX=!}ŭ jb<@+i@4.Y]mrU~Ek2%Y}_Tuz]4]_YwwUUM>/%bk%p5QԂ#%SKyV姴\,9jW;ܙFaS&yqWCxeo4V˝Kd/8O$˜Pb6- Q~0NmpU$ξޝGЪ>-~'ɉYɑ{c=sjm]dۗYBrOmJ343;:pRz7$n2iqT*PRo.$gH#ٶ w4^A!8~̪x&w5m:bi|mo žOa M^e2ֳ DE'gžŸe@Tt|UuOg94/l bBZR{3EK+_VҞ]C㟲n7HgFOeGhXAb#"6jߚ7*"!!BC0ڇNi J$mzl=\E΃>JK t1]-:^y9pTBl%]GWGt)C!҅mMp-~.6ڿ.%E4ho%=vH ȇV}AyTo SXPMWxqy4/lb;]֘Wl^EΗQXsIM:Bu=j wfMzF-ResT:Oj؏{[NEM3B=ޗTezihzy|6p)VJJt3@ +ndhDKt0-X*;WZ[@Uu\3֎87]NT&^k@r#] 1 y=tqQ>|}O(=t W8ʓs8=V) B_@h f8]g=HXLUtCvRmiG6[ۇb8[ABfiwa=}9:Ե0*K7)4'O[MVV,,&7"\*AGiь̘ s|sqP49q?>Խ0b3MM^ #~)f׈-KV3Wy'vbU쳑.PM􋽔r]RPk^>xmz­@ mNj2Nh R{}&M֬M0!Dz9Hi>PMsy\#Ufg&/la}6AM:g7n;0]~Kk/e㑤y;y;Ө3| bܯ@q|~I }"=q!Qv9)IJ'=͉K$ .ȦSY@#'ߦ3W jS )&LKE{ׅendstream endobj 126 0 obj << /Filter /FlateDecode /Length 1725 >> stream xYKo6W)Pȅr8|ͥ@Q襭oN޸]'bCHRd`o8RS W풟1 /n6#Rǜ:r YH .gT6{LJĽۉ::ʦ:TM " =u˹v⌃٧xb^*{ޗ4ޘخ}KFYtZy4uO-eHS4YN^-yǩlIM^gL?Y7>!=L(TXm4)cJA_%3 S`L9z e=??"Cb-/qdZ@o9)d~]Ĕ(~_Gώu&r~3ECO)m}cvD>l88G^Qs*HR:zY_uǡvLSǡvI[Qd!xX`JTڮZ;fQ 6;]3kT+}Vu.V7/u܈iY~M>o͞=>{ HP$(K$A~|žp<2iF gYˬ~x`wa󐻁"D(8p҃:",[l}t#.`(0y~7&q4/1nuhi9][9EI}|*ʊJvT3M#76X&@XySY,OEHdhA10-buHYV]uFs=H+#U~vZN]:I9zݠ +OFBA]bRSK[Y:v:Pendstream endobj 127 0 obj << /Filter /FlateDecode /Length 2085 >> stream xY[sHG WMٽ}Pa)`K[Έed*Pwn% kJj>}|?gY˿]1c3?0 {0ݬ: zC0%b#b%eL~PʐnKî;]˘"J3ʸ3C Mna[ۧ\25(4`I\ecxGId%ǮwOHha⻛?̾Ab[-}ZMcOEvnoJz@xEyHw_ZY[hnE ^%!Òvʼn KQ=z;Ͳ+&ň;HHUd~CackEYf]x}^.!ǴI͛pܦn!ϋ  e~n<)TٹY姳Lgux;̤fg[ ژjqr+tQ`XչV5UAF Ta $nIYlE!~zX]&I&erdf_鹨q!˨Cy@H%"~D8\!dV7k"|Cr,t͖t [wYՈ\^MͪvĈ9ɷݦEv_wo)馶keE5vdꕞklKΩST*jm$S_pHΏڭ_` YjZM"jJrz͛Qvʩ HF^L[^Kʧv4Aٗc藃kPDnZKFȪ?AU}zJmo@:7X )9' N)2[H((§X|OY<|SZ5K*R9KMZcސ>\]͊}/Un -Ǎ%Cu=IwtS7I2;$@۲\I5[HcEa!iW4~hLNre~,0Ր @vDM[`Fl%BdŘS6DsJZ׈-ebM2Tvdw4uB9-m$5r.ti$kZayK` AZ0}銛%D[t +.!7)] > KѠF#g> CyTk-}{>Gvy-wYn$W`IZ_+XKiqIthX:dͻ k^Pu}qsإB /Ujx)s:f䍲ȟ@2l" 2{_S Q륢56:2SXiPx_ǾJT/ۀ|PNv<I?)+T8c뢈"^(LAsd' 6]rjmk]U ZTxՀ-mৢ&!ˑI )ojIa$y-F$ش?uInDZvU\"~}J ,j1%d46x&_l4/h?‘~^z,f s4* pѰ"Uu37,fyk ֋W?/pե4~>PtF=l$u6Cz ѩC@<\HJC YEozȇŐ]r!_JTBM( 1CR F'>Ο5Eo/&WNP=ahS3 5O45aX^_B/6lD*5lcP!7aD>it_s6VhOn]|{+aˌendstream endobj 128 0 obj << /Filter /FlateDecode /Length 2615 >> stream xZ[sܶ Vu.^x2zڤV"R{=$]J#u:@wP0 Koawff<,ҟm ]x0ͬ xa.I9_*9n2E+,2YKo YaWj MM˘"R3ʸ3>?!˅&Ͱ8W[uHI!M9ɫ "l\3#8l񚬰Hnvr3{٫OʻP K-8Tk^͌Q,m95L 킯 g'?8JcT%C?-bxa 7 Nޕçu]UUHؠzW߮|F8|hR*zV^Wg^[4Y^{~ߤM2?o]TPBQ2*U EN6Y:|vBxn,f"Q)tաJO@5~ޭ 쮫DP1yRߖjսVz]ܖu Wģ.!(Q܏a]pG oy2ˑ\vE"BGF&=1#"\QOh ߓ^4jCˑ\i_7ꊔbU6ygZ\o:Ez^LVxƎI&A]F_o`V#v__Wo8[z-92l14; k~ޫ-cgZI>!6[?:f~>j0\C8RZygZL̘ g yMsQYި'[}ݖW<eϜ/m4􏂘qW7_i8Ј@3n繁!*p2qJ%n yj!]y(+$0`2~f[~aݯ,0> ߤi~(*quo>ܭB]{X&@)/YoKl_ } RxC޼ Kȏˏe/ĦU&X j"-^& m7=[MwJsg[ٚ1l0즩sJZՒy/eęTCv) 4wZޖSrA.˥ ksApՒNV%#I1"&pGG AK0\Ҭ3'T8yTo}u8DC2 B5oiLt[H< sK5:ܝ3uPCʜى:D~~[GT; cs=8##o ;etPw &`*ZSo{WI gvp˦9\bu~Yg5$SZ.E{35PD}e\S_be]*rTWYdPCҾ H:.P$wx+pϻu I%mUӄ~IM}&]u%hAzqG]7ҳ$w01>m$k(@m7{E~hcIUDCYNM4{(&\jeY#NpTLXӢ,nveNTHAdE%x/ɷ&_02exĦ.aBXtV xh`k̘ߑ#~'꺑 Ya^:l0qK^#1i3'LKGn]@LC vCppw"0?vWaslj#a"Vip]L=8;#+:Z@d.h Ya@TC->K!Kr@o6\tH_`\Z^ Z tܶ},=-EvDrendstream endobj 129 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 505 >> stream xcd`ab`dddwu041 ~H3a!-Ϥ Na|<<,~,>E{/6FҖ˜ *23J45 --u ,sS2|K2RsKԒJ +}rbt;M̒ ԢTS s~nAiIjo~JjQ^RQbrjNjZIR g0000[X00v1v3ðG/ ~C;OKzziY/yݏ8~8/)f+*[ٿ9@>Ԥ"2?9E {ɝf[ӳT{wވ K|/.{Rw.8敿S~VhhִBnM󍺍@@8GϟH w.4cjOO\E]=Erlst2ϾkKe>I<<@zendstream endobj 130 0 obj << /Filter /FlateDecode /Length 3518 >> stream x[KsNs~j8ʛC6.' %!6_KBڬP\Kࠧ_w>%0~B ?&տ*5,*qiI%qbYb&"^MnetU4o7yV,h,? ؂9FYX"YЎS>2 GJ?3ٿac)dHf$(`pcѢmXw0J!-UaM:Rb@"{3Fb ᠛ٔsi[Pmݥ-VTiSmMWY;Om b-^jD:߈Z^kޫϫ*Y}ʹӮ*K6M3e聖+SfwC6_>;f":p$ ӁAd 4knQ &) MMyٺYN9Db.rOT)|K'CL*}jeع{\fyL- 71i؄;X;&?'!\%zBԳUJ.:2E#%~! *ӒR>N-LZGcXµ5%|LiIuT\4l.}޼uv@<#s |95Af%S5pW'1O}f8dq-1ҟ K4E$@*ʽ06jhvie?s6ũjS[È@IPYb=/ֳp-|U.rǁҴ@=Nx詾t-.ָ2֦۝/iQ l4hEH- /VE͉ui/He rS/]vep@nl5R>q~vOz1oE(wˢлͮrϋ}{6ߗ,A܃|F2_{ cF}9(-|b?mÚi4 ڧ#Sj^ca7 S0 ;^:Bj}/DŽPNkVIu/rNhg\C9{CϨڦqPJ͇,EJGO˂woЁV>Js3fdfхBuBC{ Y>6?>BΞ'MXaB'uY%`fR6Wø(,( kƝpNs6hM?!JgDdp̐<}jv>Ux*܁u嶨m? :gxP'`x'| ,S JUPi=oם6)3~һ"/Cdl.VX#*rlӝ(v:n'=Uۉn5_Nش˦ѐr`v[HWyt BUT].:dMKY]GjZVA]},ql2"烕>(>_f6 D0ᥛ+0v :ξ8@mKpH:c&3/~DR!"u)ԼszUAup|x &=9TV; z y;Q%6gЈU\vga=RO 0i9)Mg4I3½U@Dߚ=l9mC#2~@cRS%yIcjXE&1G4kA1TuQ UA>Hv%*HioqbͼXJnr*%,u b|C2M ]u\+` yƧe 1R < aq: *3R0|ȁMc# W~U\LCiFλ^Bs_u-ن}9-?lg '+dP@{jCN@\(8SyF\tcKt<7BHW@H 0Dw|cQm9B[(F[>|"]^tA>dW4']r]&b3XEBeY[*Cs},{)_:uݢ IKzjvsэ"fJ^Kz5>ǍnP6` %{*W7|1:5)ugOIvpնJ@^.>C-j%DmU/W+DoW-4i{tCMdل[Ep˝CGX n#4,(ΔZJ:Ym|y%R mjZX0_Dj:hGs:́~Ia`^(=>_lpuAA˺Aq.:⠽V'_iҷK?H6 R- 9Y. 9}8ef<DJ&ՀOk?TJpS$P@ЄH_5x8GljD ┒> stream xXKs6Wp<j-o3'3m&/΁(G(9$=H #tt ]|J ;.?Y5`ӀcL:IijIf!O$Ħl8R#KʘP!j1d6RkdN^)#(ΐU_C˅&uɽ**[YFšlܛ`Э6Iੀmr0bNM]1k^/wwǿ 8ye`L,M- R|%/~{|xǀ\xw8.Ox>d`ŁZUagpxHuZEV^"k6eUgg^IG#yVfCN Bt~M^N&a LHI5zճeQINɫy65m{IC7˒l4->ƙ.f>ɫzVduͭn,Y4jUDDzHuv7FL!6}xgy :[5496oyΩو+^T +8neMFĉaV4DJkM˴["+ϲ 5Ѻt*<3mg6w`]9 la~6 (р6.ynΔys`<|eU?dp]|-F@3Bw%mpFXGӝжK[>LB  GiAmƋ';o @79A 7ۣ lT$MwD*DoIzЋrw!x݃*"-E(QdຩC}%'7y2ԡ&$?kR j\t $N-qơTW%KMD`:ѻ3,Nk(i%jG֓Xyk'u+Q}4(†F竷DhT΄" VN`1jgC1J;!'@j\p(SW9=OqddW\E RH@$bGx8Q s_obQʋ(x짤8?Ca/{ŬގTRwou R!ņ!Akʧ&Z`$'m<_U5Of}\_|?AO 7>l,nJWo{CaI2P`>6Up1;G8zPm[(!{KZRۄ~p7ik6i_qN zBIhH뽫[ ^|mzHs k>B~,-Z6xE%c"@!=gFu3Y#I]jaR֣RO\u)Oendstream endobj 132 0 obj << /Filter /FlateDecode /Length 1723 >> stream xXKs6Wj;: ,^D4ti7+F%3ίӦr'H.3c~s~eCǸ~,wϗ8TlՠuXp Tė芤ӹyN~:2?J|Rn Vk_%wB)H]Q$MQM} ^.En{3UXکM:94˾@ Ua` _9 ͫev2zC-.aJj }E!aJoʋIWStV)8e4jS|ʝS/h$QiE2MO2&4V֟@ ALgf?I$? ˬbSb*"rq>|{_۸7C-jljKjM|"dNq.FؠyYmvi9g&Պ[\Y$M}E݈5o㉗q 3/{>.1끃 0lDˍ5=Q.kpb3h s`A%$`ՎZFWk5xnR@P犿n}VU;ns3ӪBgS<-b: Cۥ-enQ9JZ}*&ݎ昐13Pec^Reb4Pib!hb"֑@#_FS]$TۑmtNJ}-&G1U5\Hg ,E M #Z@5B0 M>nJeGNqaee=m)-VeHVWv_jr?3Ī;D(7>Wъ}Lh蹥C%NG_I~MU Rnv/mLgcl34efe0eg0f-qoHu~kAjd3 UUKL+ܧcR# :8FWf ]shRVd JVrfm:>T c:ʌd240D|&O'cCu6jgلK*B F)FnptyDαpTr#$- /8Ր rHjsqU! )"n"j-!K]~E S F? Y m<Hk3g ,Z0&2B*'=endstream endobj 133 0 obj << /Type /XRef /Length 154 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 134 /ID [<90c879e602f3c69511ee0d2bea753fda><33c9643d24d5e4886743b0d3a07d8651>] >> stream xcb&F~0 $8J$Z@ DJHi)"7H<0{  Q~ dZ"YoHm"%Ax$q`Ӓo/d|&z|1Dqe$+ endstream endobj startxref 98557 %%EOF mets/inst/documentation/0000755000176200001440000000000013623061753015056 5ustar liggesusersmets/inst/documentation/dutils.org0000644000176200001440000003036313623061405017072 0ustar liggesusers* preample :ignore: #+TITLE: Utility functions #+AUTHOR: Klaus K. Holst and Thomas Scheike #+email: k.k.holst@biostat.ku.dk #+LATEX_CLASS: tufte-handout+listings #+LATEX_CLASS_OPTIONS: [a4paper] #+PROPERTY: header-args:R :session *R* :cache yes :width 550 :height 450 #+PROPERTY: header-args :eval never-export :exports both :results output :tangle yes :comments yes #+PROPERTY: header-args:R+ :colnames yes :rownames no :hlines yes #+OPTIONS: timestamp:t title:t date:t author:t creator:nil toc:nil #+OPTIONS: h:4 num:t tags:nil d:t ^:{} #+LATEX_HEADER: \lstset{language=R,keywords={},morekeywords={}} #+LATEX_HEADER: \usepackage{zlmtt} #+LATEX_HEADER: \setlength{\parindent}{0em} #+LATEX_HEADER: %%\setlength{\parindent}{default} #+LaTeX: \setlength{\parindent}{0em} %\setlength{\parindent}{default} #+BEGIN_SRC emacs-lisp :results silent :exports results :eval (setq org-latex-listings t) (setq org-latex-compiler-file-string "%%\\VignetteIndexEntry{dutils overview}\n%%\\VignetteEngine{R.rsp::tex}\n%%\\VignetteKeyword{R}\n%%\\VignetteKeyword{package}\n%%\\VignetteKeyword{vignette}\n%%\\VignetteKeyword{LaTeX}\n") #+END_SRC * Introduction Data summaries | =dhead= | a | | =dtail= | a | | =dsummary= | | | =dprint,dlist= | | | =dlevels= | | | =dunique= | | | =dstr= | | Data processing | =dsort= | a | | =dreshape= | | | =dcut= | | | =drm= | | | =dkeep= | | | =dnames=, =drename= | | | =ddrop= | | | =dfactor=, =dnumeric= | | | =dsubset= | | | =dlag= | | | =drelevel= | | | =dsample= | | Aggregation | =dby= | | | =daggregate= | | | =deval= | | | =deval2= | | | =dscalar= | | | =dmean=, =dsum=, =dsd=, =dquantile= | | | =dcor= | | | =dcount= | | | =dtable= | | #+BEGIN_SRC R :cache no library(mets) #+END_SRC #+RESULTS: #+begin_example Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.5.1 mets version 1.2.1.2 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined Warning message: failed to assign RegisteredNativeSymbol for cor to cor since cor is already defined in the ‘mets’ namespace #+end_example <<<<<<< HEAD #+begin_example Loading required package: timereg Loading required package: survival Loading required package: lava lava version 1.5 mets version 1.2.1.2 Attaching package: ‘mets’ The following object is masked _by_ ‘.GlobalEnv’: object.defined #+end_example ======= >>>>>>> a0fca72dd6d410529ed706d9ac0e8261178e266c * Data summary We will use a subset of the TRACE data available in the =timereg= package, which consists of a random sub-sample of 300 patients out of the full cohort consisting of approximately 6000 patients. It contains data relating survival of patients after myocardial infarction to various risk factors. #+BEGIN_SRC R data(sTRACE, package="timereg") dhead(sTRACE) #+END_SRC #+RESULTS[01b4952643bb968b9b1e194a2056b925ff7c5052]: : no wmi status chf age sex diabetes time vf : X1944 1944 1.5 9 0 84.924 1 1 1.345000 0 : X5783 5783 1.9 0 1 74.193 0 0 6.910000 0 : X784 784 0.8 9 0 78.081 0 1 0.196000 0 : X3763 3763 1.3 0 0 55.479 1 0 7.543000 0 : X2927 2927 1.6 0 1 62.997 0 0 7.126000 0 : X4511 4511 1.0 9 1 67.644 1 0 4.532606 0 \citet{TRACE} This data frame contains the following columns: - id :: Patient code (numeric). - wmi :: Measure of heart pumping effect based on ultrasound measurements where 2 is normal and 0 is worst. - status :: Survival status. 9: dead from myocardial infarction, 0: alive, 7: dead from other causes. - time :: Survival time in years. - chf :: Clinical heart pump failure, 1: present, 0: absent. - diabetes :: Diabetes, 1: present, 0: absent. - vf ::e. Ventricular fibrillation, 1: present, 0: absent. - sex :: Gender, 1: female, 0: male. - age :: Age of patient. #+BEGIN_mnote Here a margin note #+END_mnote ** a #+BEGIN_SRC R n <- 20 m <- lava::lvm(letters) d <- lava::sim(m,n) dlist(d,~a+b+c | a>0) dlist(d, a+b~c>0 | a>0) #+END_SRC #+RESULTS[84fda9ca89b2ebc100e10fa6305cd1c85694c607]: #+begin_example a b c 1 0.2931 0.08600 -1.523897 3 0.7401 -1.52052 0.602183 7 0.9079 -0.50419 0.001286 10 0.3768 0.42186 -0.824860 11 1.3748 -0.09775 1.386935 14 0.7545 -1.80065 1.494348 15 0.4461 0.54516 -0.337498 17 0.5001 -0.23887 -0.562333 20 0.7586 1.66598 0.482238 c > 0: FALSE a b 1 0.2931 0.0860 10 0.3768 0.4219 15 0.4461 0.5452 17 0.5001 -0.2389 ------------------------------------------------------------ c > 0: TRUE a b 3 0.7401 -1.52052 7 0.9079 -0.50419 11 1.3748 -0.09775 14 0.7545 -1.80065 20 0.7586 1.66598 #+end_example #+BEGIN_SRC R dmean('Petal' ~ Species, data=iris, regex=TRUE) #+END_SRC #+RESULTS[62e576971a5c3a003bbb36ab4ea834eb293e063d]: : Species Petal.Length Petal.Width : 1 setosa 1.462 0.246 : 2 versicolor 4.260 1.326 : 3 virginica 5.552 2.026 #+NAME: fig1 #+BEGIN_SRC R :exports both :file figs/fig1.png :results output graphics plot(1) #+END_SRC #+RESULTS[e3904b17cae30c3ef0f5d112eb46725fac469094]: fig1 [[file:figs/fig1.png]] #+ATTR_LaTeX: :width \textwidth :center t #+CAPTION: Important figure. label:fig1 \vspace*{1em} #+BEGIN_marginfigure #+ATTR_LATEX: :width 2cm :float nil :center t #+CAPTION: Important margin figure. label:fig2 #+END_marginfigure * Tables #+BEGIN_SRC R data(sTRACE, package="timereg") dhead(sTRACE) dcut(sTRACE) <- wmicat~wmi dtable(sTRACE, sex+diabetes+wmicat~vf | age<60) dby(sTRACE, wmi ~ diabetes+sex, m=mean, q50=median, sd=sd, REDUCE=T) dhead(sTRACE, 'wmi*' ~ sex) #+END_SRC #+RESULTS[b5f8d7f29e1ed8fbda4349938306044b44e90c62]: #+begin_example no wmi status chf age sex diabetes time vf X1944 1944 1.5 9 0 84.924 1 1 1.345000 0 X5783 5783 1.9 0 1 74.193 0 0 6.910000 0 X784 784 0.8 9 0 78.081 0 1 0.196000 0 X3763 3763 1.3 0 0 55.479 1 0 7.543000 0 X2927 2927 1.6 0 1 62.997 0 0 7.126000 0 X4511 4511 1.0 9 1 67.644 1 0 4.532606 0 vf: 0 wmicat [0.4,1.1] (1.1,1.4] (1.4,1.8] (1.8,2.7] sex diabetes 0 0 4 2 3 5 1 0 2 1 1 1 0 15 17 37 24 1 0 3 2 1 ------------------------------------------------------------ vf: 1 wmicat [0.4,1.1] (1.1,1.4] (1.4,1.8] (1.8,2.7] sex diabetes 0 0 1 1 0 1 1 0 1 2 2 0 diabetes sex m q50 sd 1 0 0 1.437762 1.50 0.3810298 2 1 0 1.384211 1.30 0.4272173 3 0 1 1.434839 1.45 0.4017105 4 1 1 1.150000 1.15 0.4299009 sex: 0 wmi wmicat X5783 1.9 (1.8,2.7] X784 0.8 [0.4,1.1] X2927 1.6 (1.4,1.8] X1085 0.9 [0.4,1.1] X5249 1.7 (1.4,1.8] X6311 0.7 [0.4,1.1] ------------------------------------------------------------ sex: 1 wmi wmicat X1944 1.5 (1.4,1.8] X3763 1.3 (1.1,1.4] X4511 1.0 [0.4,1.1] X3122 1.9 (1.8,2.7] X5441 1.4 (1.1,1.4] X1280 1.1 [0.4,1.1] #+end_example #+BEGIN_SRC R library("magrittr") library("mets") op <- par(mfrow=c(1,3)) l <- iris %>% dsubset('*Length'~Species | Sepal.Width>mean(Sepal.Width)) %>% lapply(function(x,...) lm(Sepal.Length~Petal.Length,x)) %>% lapply(plotConf) par(op) dtable(iris, Species+dcut(Petal.Width,4)~1) dtable(iris, Species+dcut(Petal.Width,4)~1|Sepal.Width>median(Sepal.Width)) dtable(iris, Species+dcut(Petal.Width,4)~ dcut(Petal.Length,breaks=2)| Sepal.Width>mean(Sepal.Width)) #+END_SRC #+RESULTS[14a09cf4e6531704516d9d76305b8cb3355e7a04]: #+begin_example dcut(Petal.Width, 4) [0.1,0.3] (0.3,1.3] (1.3,1.8] (1.8,2.5] Species setosa 41 9 0 0 versicolor 0 28 22 0 virginica 0 0 16 34 dcut(Petal.Width, 4) [0.1,0.2] (0.2,0.4] (0.4,1.8] (1.8,2.5] Species setosa 28 12 2 0 versicolor 0 0 8 0 virginica 0 0 2 15 dcut(Petal.Length, breaks = 2): [1,1.6] dcut(Petal.Width, 4) [0.1,0.2] (0.2,0.4] (0.4,1.8] (1.8,2.5] Species setosa 26 9 1 0 versicolor 0 0 0 0 virginica 0 0 0 0 ------------------------------------------------------------ dcut(Petal.Length, breaks = 2): (1.6,6.7] dcut(Petal.Width, 4) [0.1,0.2] (0.2,0.4] (0.4,1.8] (1.8,2.5] Species setosa 2 3 1 0 versicolor 0 0 8 0 virginica 0 0 2 15 #+end_example * dby #+BEGIN_SRC R library(magrittr) sTRACE %>% dby2(chf+vf~1, mean, median) %>% dhead #+END_SRC #+RESULTS[66b2d4af5d5a7bb11ea96d4d0101df9819e74cc2]: #+begin_example no wmi status chf age sex diabetes time vf wmicat mean.chf X1944 1944 1.5 9 0 84.924 1 1 1.345000 0 (1.4,1.8] 0.522 X5783 5783 1.9 0 1 74.193 0 0 6.910000 0 (1.8,2.7] 0.522 X784 784 0.8 9 0 78.081 0 1 0.196000 0 [0.4,1.1] 0.522 X3763 3763 1.3 0 0 55.479 1 0 7.543000 0 (1.1,1.4] 0.522 X2927 2927 1.6 0 1 62.997 0 0 7.126000 0 (1.4,1.8] 0.522 X4511 4511 1.0 9 1 67.644 1 0 4.532606 0 [0.4,1.1] 0.522 mean.vf median.chf median.vf X1944 0.058 1 0 X5783 0.058 1 0 X784 0.058 1 0 X3763 0.058 1 0 X2927 0.058 1 0 X4511 0.058 1 0 #+end_example #+BEGIN_SRC R library(magrittr) sTRACE %>% dby(chf+vf~1, mean, median,REDUCE=TRUE) #+END_SRC #+RESULTS[1f8eaa03cb32b30d5b54c3910cbb531355aef819]: : mean median : 0.29 0 #+BEGIN_SRC R :eval never dby(iris, 'Length' ~ Species, mean, REGEX=T, COLUMN=T, REDUCE=T) dby(iris, 'Length' ~ Species, mean, REGEX=T, COLUMN=T, REDUCE=T) dby(iris, '*Length' ~ Species, mean, COLUMN=T, REDUCE=T) dby(iris, '*Length' ~ Species, mean) dby(iris, 'Length' ~ Species, mean, REGEX=T) dby(iris, 'Length' ~ Species, mean, COLUMN=T, REGEX=T, REDUCE=T) dby(iris, 'Length' ~ Species, mean, REGEX=T, REDUCE=1) dby(iris, 'Length' ~ Species, mean, REGEX=T, REDUCE=1, COLUMN=T) dby(iris, 'Length' ~ Species, mean, REGEX=T, REDUCE=1, COLUMN=T) #+END_SRC #+BEGIN_SRC R lapply(list(median, mean), function(f) dscalar(sTRACE, chf+vf~sex, fun=f)) #+END_SRC #+RESULTS[e727cd7a1e3e789e19c8941719fef4e5d47c3172]: : [[1]] : sex chf vf : 1 0 1 0 : 2 1 0 0 : : [[2]] : sex chf vf : 1 0 0.6172840 0.07407407 : 2 1 0.4763314 0.05029586 #+BEGIN_SRC R dbyr(sTRACE, wmi ~ vf+sex|age>80, mean(x^2), mean(log(x)), mean, n=length) #+END_SRC #+RESULTS[cb7e817a19236a46a94c2b2ebd27d49dce7be1cb]: : vf sex mean(x^2) mean(log(x)) mean n : 1 0 0 2.344286 0.33534719 1.471429 21 : 2 1 0 1.370000 0.02439508 1.100000 2 : 3 0 1 2.212162 0.33285730 1.445946 37 : 4 1 1 0.745000 -0.17833747 0.850000 2 * backmatter :ignore: bibliography:mets.bib bibliographystyle:plain mets/inst/include/0000755000176200001440000000000013623061405013622 5ustar liggesusersmets/inst/include/mets.h0000644000176200001440000000035613623061405014747 0ustar liggesusers// Generated by using Rcpp::compileAttributes() -> do not edit by hand // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 #ifndef RCPP_mets_H_GEN_ #define RCPP_mets_H_GEN_ #include "mets_RcppExports.h" #endif // RCPP_mets_H_GEN_ mets/inst/include/mets_RcppExports.h0000644000176200001440000001507613623061405017325 0ustar liggesusers// Generated by using Rcpp::compileAttributes() -> do not edit by hand // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 #ifndef RCPP_mets_RCPPEXPORTS_H_GEN_ #define RCPP_mets_RCPPEXPORTS_H_GEN_ #include #include namespace mets { using namespace Rcpp; namespace { void validateSignature(const char* sig) { Rcpp::Function require = Rcpp::Environment::base_env()["require"]; require("mets", Rcpp::Named("quietly") = true); typedef int(*Ptr_validate)(const char*); static Ptr_validate p_validate = (Ptr_validate) R_GetCCallable("mets", "_mets_RcppExport_validate"); if (!p_validate(sig)) { throw Rcpp::function_not_exported( "C++ function with signature '" + std::string(sig) + "' not found in mets"); } } } inline arma::mat _loglikMVN(arma::mat Yl, SEXP yu, SEXP status, arma::mat Mu, SEXP dmu, arma::mat S, SEXP ds, SEXP z, SEXP su, SEXP dsu, SEXP threshold, SEXP dthreshold, bool Score) { typedef SEXP(*Ptr__loglikMVN)(SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP); static Ptr__loglikMVN p__loglikMVN = NULL; if (p__loglikMVN == NULL) { validateSignature("arma::mat(*_loglikMVN)(arma::mat,SEXP,SEXP,arma::mat,SEXP,arma::mat,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,bool)"); p__loglikMVN = (Ptr__loglikMVN)R_GetCCallable("mets", "_mets__loglikMVN"); } RObject rcpp_result_gen; { RNGScope RCPP_rngScope_gen; rcpp_result_gen = p__loglikMVN(Shield(Rcpp::wrap(Yl)), Shield(Rcpp::wrap(yu)), Shield(Rcpp::wrap(status)), Shield(Rcpp::wrap(Mu)), Shield(Rcpp::wrap(dmu)), Shield(Rcpp::wrap(S)), Shield(Rcpp::wrap(ds)), Shield(Rcpp::wrap(z)), Shield(Rcpp::wrap(su)), Shield(Rcpp::wrap(dsu)), Shield(Rcpp::wrap(threshold)), Shield(Rcpp::wrap(dthreshold)), Shield(Rcpp::wrap(Score))); } if (rcpp_result_gen.inherits("interrupted-error")) throw Rcpp::internal::InterruptedException(); if (Rcpp::internal::isLongjumpSentinel(rcpp_result_gen)) throw Rcpp::LongjumpException(rcpp_result_gen); if (rcpp_result_gen.inherits("try-error")) throw Rcpp::exception(Rcpp::as(rcpp_result_gen).c_str()); return Rcpp::as(rcpp_result_gen); } inline NumericVector _dmvn(arma::mat u, arma::mat mu, arma::mat rho) { typedef SEXP(*Ptr__dmvn)(SEXP,SEXP,SEXP); static Ptr__dmvn p__dmvn = NULL; if (p__dmvn == NULL) { validateSignature("NumericVector(*_dmvn)(arma::mat,arma::mat,arma::mat)"); p__dmvn = (Ptr__dmvn)R_GetCCallable("mets", "_mets__dmvn"); } RObject rcpp_result_gen; { RNGScope RCPP_rngScope_gen; rcpp_result_gen = p__dmvn(Shield(Rcpp::wrap(u)), Shield(Rcpp::wrap(mu)), Shield(Rcpp::wrap(rho))); } if (rcpp_result_gen.inherits("interrupted-error")) throw Rcpp::internal::InterruptedException(); if (Rcpp::internal::isLongjumpSentinel(rcpp_result_gen)) throw Rcpp::LongjumpException(rcpp_result_gen); if (rcpp_result_gen.inherits("try-error")) throw Rcpp::exception(Rcpp::as(rcpp_result_gen).c_str()); return Rcpp::as(rcpp_result_gen); } inline arma::mat _rmvn(unsigned n, arma::mat mu, arma::mat rho) { typedef SEXP(*Ptr__rmvn)(SEXP,SEXP,SEXP); static Ptr__rmvn p__rmvn = NULL; if (p__rmvn == NULL) { validateSignature("arma::mat(*_rmvn)(unsigned,arma::mat,arma::mat)"); p__rmvn = (Ptr__rmvn)R_GetCCallable("mets", "_mets__rmvn"); } RObject rcpp_result_gen; { RNGScope RCPP_rngScope_gen; rcpp_result_gen = p__rmvn(Shield(Rcpp::wrap(n)), Shield(Rcpp::wrap(mu)), Shield(Rcpp::wrap(rho))); } if (rcpp_result_gen.inherits("interrupted-error")) throw Rcpp::internal::InterruptedException(); if (Rcpp::internal::isLongjumpSentinel(rcpp_result_gen)) throw Rcpp::LongjumpException(rcpp_result_gen); if (rcpp_result_gen.inherits("try-error")) throw Rcpp::exception(Rcpp::as(rcpp_result_gen).c_str()); return Rcpp::as(rcpp_result_gen); } inline arma::vec _rpch(unsigned n, std::vector lambda, std::vector time) { typedef SEXP(*Ptr__rpch)(SEXP,SEXP,SEXP); static Ptr__rpch p__rpch = NULL; if (p__rpch == NULL) { validateSignature("arma::vec(*_rpch)(unsigned,std::vector,std::vector)"); p__rpch = (Ptr__rpch)R_GetCCallable("mets", "_mets__rpch"); } RObject rcpp_result_gen; { RNGScope RCPP_rngScope_gen; rcpp_result_gen = p__rpch(Shield(Rcpp::wrap(n)), Shield(Rcpp::wrap(lambda)), Shield(Rcpp::wrap(time))); } if (rcpp_result_gen.inherits("interrupted-error")) throw Rcpp::internal::InterruptedException(); if (Rcpp::internal::isLongjumpSentinel(rcpp_result_gen)) throw Rcpp::LongjumpException(rcpp_result_gen); if (rcpp_result_gen.inherits("try-error")) throw Rcpp::exception(Rcpp::as(rcpp_result_gen).c_str()); return Rcpp::as(rcpp_result_gen); } inline arma::vec _cpch(arma::vec& x, std::vector lambda, std::vector time) { typedef SEXP(*Ptr__cpch)(SEXP,SEXP,SEXP); static Ptr__cpch p__cpch = NULL; if (p__cpch == NULL) { validateSignature("arma::vec(*_cpch)(arma::vec&,std::vector,std::vector)"); p__cpch = (Ptr__cpch)R_GetCCallable("mets", "_mets__cpch"); } RObject rcpp_result_gen; { RNGScope RCPP_rngScope_gen; rcpp_result_gen = p__cpch(Shield(Rcpp::wrap(x)), Shield(Rcpp::wrap(lambda)), Shield(Rcpp::wrap(time))); } if (rcpp_result_gen.inherits("interrupted-error")) throw Rcpp::internal::InterruptedException(); if (Rcpp::internal::isLongjumpSentinel(rcpp_result_gen)) throw Rcpp::LongjumpException(rcpp_result_gen); if (rcpp_result_gen.inherits("try-error")) throw Rcpp::exception(Rcpp::as(rcpp_result_gen).c_str()); return Rcpp::as(rcpp_result_gen); } } #endif // RCPP_mets_RCPPEXPORTS_H_GEN_ mets/inst/CITATION0000644000176200001440000000267613623061405013347 0ustar liggesusersauthor1 <- "Klaus K. Holst and Thomas H. Scheike and Jacob B. Hjelmborg" year1 <- 2016 journal1 <- "Computational Statistics and Data Analysis" title1 <- "The Liability Threshold Model for Censored Twin Data" doi1 <- "10.1016/j.csda.2015.01.014" volume1 <- 93 pages1 <- "324-335" textver1 <- paste(author1, " (", year1, "). ", title1, ". ", journal1, " ", volume1, ", pp. ", pages1, ". doi: ", doi1, sep="") author2 <- "Thomas H. Scheike and Klaus K. Holst and Jacob B. Hjelmborg" year2 <- 2014 journal2 <- "Lifetime Data Analysis" title2 <- "Estimating heritability for cause specific mortality based on twin studies" doi2 <- "10.1007/s10985-013-9244-x" volume2 <- 20 number2 <- 2 pages2 <- "210-233" textver2 <- paste(author2, " (", year2, "). ", title2, ". ", journal2, " ", volume2, " (", number2 ,"), pp. ", pages2, ". doi: ", doi2, sep="") citHeader("To cite 'mets' in publications use:") citEntry(entry="Article", title = title1, author = author1, year = year1, volume = volume1, pages = pages1, journal = journal1, doi = doi1, textVersion = textver1) citEntry(entry="Article", title = title2, author = author2, year = year2, volume = volume2, number = number2, pages = pages2, journal = journal2, doi = doi2, textVersion = textver2) mets/inst/devel/0000755000176200001440000000000013623061405013276 5ustar liggesusersmets/inst/devel/dreg.R0000644000176200001440000001773713623061405014361 0ustar liggesusers dreg <- function(data,y,x=NULL,z=NULL,...,x.oneatatime=TRUE, x.base.names=NULL,z.arg=c("clever","base","group","condition"), fun=lm,summary=NULL,regex=FALSE,convert=NULL, special=NULL,equal=TRUE) {# {{{ ### z.arg=clever, if z is logical then condition ### if z is factor then group variable ### if z is numeric then baseline covariate ### ... further arguments to fun ### funn <- as.character(substitute(fun)) ### if (is.character(fun)) ### fun <- get(fun) ### if (!is.null(convert) && is.logical(convert)) { ### if (convert) ### convert <- as.matrix ### else convert <- NULL ### } ### if (!is.null(convert)) { ### fun_ <- fun ### fun <- function(x, ...) fun_(convert(x, ...)) ### } yxzf <- mets:::procform(y,x=x,z=z,data=data,do.filter=FALSE,regex=regex) yxz <- mets:::procformdata(y,x=x,z=z,data=data,do.filter=FALSE,regex=regex) ## remove blank, to able to use also +1 on right hand side if (any(yxzf$predictor=="")) yxzf$predictor <- yxzf$predictor[-which(yxzf$predictor=="")] yy <- yxz$response xx <- yxz$predictor ### group is list, so zz is data.frame if ((length(yxzf$filter))==0) zz <- NULL else if ((length(yxzf$filter[[1]])==1 & yxzf$filter[[1]][1]=="1")) zz <- NULL else zz <- yxz$group[[1]] if (!is.null(zz)) {# {{{ if (z.arg[1]=="clever") { if ((ncol(zz)==1) & is.logical(zz[1,1])) z.arg[1] <- "condition" else if ((ncol(zz)==1) & is.factor(zz[,1])) z.arg[1] <- "group" else z.arg[1] <- "base" } }# }}} ### print(z.arg) basen <- NULL if (z.arg[1]=="base") basen <- yxzf$filter[[1]] if (z.arg[1]=="condition") data <- subset(data,eval(yxzf$filter.expression)) if (z.arg[1]=="group") group <- interaction(zz) else group <- rep(1,nrow(data)) if (z.arg[1]=="group") levell <- levels(group) else levell <-1 res <- sum <- list() if (is.null(summary)) sum <- NULL for (g in levell) {# {{{ if (equal==TRUE) datal <- subset(data,group==g) else datal <- subset(data,group!=g) for (y in yxzf$response) {# {{{ if (x.oneatatime) { for (x in yxzf$predictor) { if (length(c(x,basen))>1) basel <- paste(c(x,basen),collapse="+") else basel <- c(x,basen) form <- as.formula(paste(y,"~",basel)) if (!is.null(special)) form <- timereg:::timereg.formula(form,special=special) ### val <- with(data,do.call(fun,c(list(formula=form),list(...)))) capture.output( val <- do.call(fun,c(list(formula=form),list(data=datal),list(...)))) val$call <- paste(y,"~",basel) val <- list(val) nn <- paste(y,"~",basel) if (z.arg[1]=="group") { if (equal==TRUE) nn <- paste(nn,"|",g) else nn <- paste(nn,"| not",g); } names(val) <- nn res <- c(res, val) if (!is.null(summary)) { sval <- list(do.call(summary,list(val[[1]]))) names(sval) <- nn sum <- c(sum, sval) } } } else { basel <- paste(c(yxzf$predictor,basen),collapse="+") form <- as.formula(paste(y,"~",basel)) if (!is.null(special)) form <- timereg:::timereg.formula(form,special=special) capture.output( val <- do.call(fun,c(list(formula=form),list(data=datal),list(...)))) nn <- paste(y,"~",basel) if (z.arg[1]=="group") { if (equal==TRUE) nn <- paste(nn,"|",g) else nn <- paste(nn,"| not",g); } val$call <- nn val <- list(val) names(val) <- paste(y,"~",basel) res <- c(res, val) if (!is.null(summary)) { sval <- list(do.call(summary,list(val[[1]]))) names(sval) <- nn sum <- c(sum, sval) } } }# }}} }# }}} res <- list(reg=res,summary=sum) ### res <- list(setNames(res,funn),summary=sum,...) class(res) <- "dreg" res ### structure(res,ngrouvar=0,class="dreg") ### return(res) }# }}} print.dreg <- function(x,sep="-",...) {# {{{ sep <- paste(rep(sep,50,sep=""),collapse="") sep <- paste(sep,"\n") nn <- names(x$reg) for (i in seq_along(x$reg)) { cat(paste("Model=",nn[i],"\n")) print(x$reg[[i]],...) cat(sep) } }# }}} summary.dreg <- function(x,sep="-",...) {# {{{ sep <- paste(rep(sep,50,sep=""),collapse="") sep <- paste(sep,"\n") ### cat(sep) ### if (inherits(x$lm, c("lm"))) { ### print(x$lm) ### if (!is.null(x$summary)) print(x$summary) ### return(invisible(x)) ### } if (!is.null(x$summary)) { nn <- names(x$summary) for (i in seq_along(x$summary)) { cat(paste("Model=",nn[i],"\n")) if (!is.null(x$summary)) print(x$summary[[i]],...) else print(x$reg[[i]],...) cat(sep) } } }# }}} stop() library(mets) data(iris) data=iris drename(iris) <- ~. names(iris) iris$time <- runif(nrow(iris)) iris$time1 <- runif(nrow(iris)) iris$status <- rbinom(nrow(iris),1,0.5) iris$S1 <- with(iris,Surv(time,status)) iris$S2 <- with(iris,Surv(time1,status)) iris$id <- 1:nrow(iris) mm <- dreg(iris,"*.length"~"*.width"|I(species=="setosa" & status==1)) mm <- dreg(iris,"*.length"~"*.width"|species+status) mm <- dreg(iris,"*.length"~"*.width"|species) mm <- dreg(iris,"*.length"~"*.width"|species+status,z.arg="group") zz <- dsubset(iris,~species+factor(status)) zzf <- apply(zz,1,interaction) paste("ts","|","g") zz <- interaction(zz) levels(zz) ###with(iris,split(iris,species,lm(sepal.length~sepal.width,data=x) )) dmean(iris,"*.length"~species+status) x=NULL;z=NULL;level=1; base=NULL; z.arg=c("clever","base","group","condition"); fun=lm;summary=summary;regex=FALSE ### data=iris x=NULL;z=NULL; x.oneatatime=TRUE x.base.names=NULL;z.arg=c("clever","base","group","condition"); fun=lm;summ=TRUE;regex=FALSE regex=FALSE z.arg="base" z.arg="clever" convert = NULL ### testing forskellige calls y <- "S*"~"*.width" xs <- dreg(iris,y,fun=phreg) xs <- dreg(iris,y,fun=survdiff) ### testing forskellige calls y <- "S*"~"*.width" xs <- dreg(iris,y,x.oneatatime=FALSE,fun=phreg) ## under condition y <- S1~"*.width"|I(species=="setosa" & sepal.width>3) xs <- dreg(iris,y,z.arg="condition",fun=phreg) xs <- dreg(iris,y,fun=phreg) ## under condition y <- S1~"*.width"|species=="setosa" xs <- dreg(iris,y,z.arg="condition",fun=phreg) xs <- dreg(iris,y,fun=phreg) ## with baseline after | y <- S1~"*.width"|sepal.length xs <- dreg(iris,y,fun=phreg) ## by group by species, not working y <- S1~"*.width"|species ss <- split(iris,paste(iris$species,iris$status)) xs <- dreg(iris,y,fun=phreg) ## species as base, species is factor so assumes that this is grouping y <- S1~"*.width"|species xs <- dreg(iris,y,z.arg="base",fun=phreg) ## background var after | and then one of x's at at time y <- S1~"*.width"|status+"sepal*" xs <- dreg(iris,y,fun=phreg) ## background var after | and then one of x's at at time y <- S1~"*.width"|status+"sepal*" xs <- dreg(iris,y,x.oneatatime=FALSE,fun=phreg) xs <- dreg(iris,y,fun=phreg) ## background var after | and then one of x's at at time y <- S1~"*.width"+factor(species) xs <- dreg(iris,y,fun=phreg) xs <- dreg(iris,y,fun=phreg,x.oneatatime=FALSE) y <- S1~"*.width"|factor(species) xs <- dreg(iris,y,z.arg="base",fun=phreg) y <- S1~"*.width"|cluster(id)+factor(species) xs <- dreg(iris,y,z.arg="base",fun=phreg) xs <- dreg(iris,y,z.arg="base",fun=coxph) ## under condition with groups y <- S1~"*.width"|I(sepal.length>4) xs <- dreg(subset(iris,species=="setosa"),y,z.arg="group",fun=phreg) ## under condition with groups y <- S1~"*.width"+I(log(sepal.length))|I(sepal.length>4) xs <- dreg(subset(iris,species=="setosa"),y,z.arg="group",fun=phreg) y <- S1~"*.width"+I(dcut(sepal.length))|I(sepal.length>4) xs <- dreg(subset(iris,species=="setosa"),y,z.arg="group",fun=phreg) ff <- function(formula,data,...) { ss <- survfit(formula,data,...) kmplot(ss,...) return(ss) } dcut(iris) <- ~"*.width" y <- S1~"*.4"|I(sepal.length>4) par(mfrow=c(1,2)) xs <- dreg(iris,y,fun=ff) ######################################### mets/inst/devel/bptwin2.R0000644000176200001440000004675513623061405015027 0ustar liggesusersbptwin2 <- function(formula, data, id, zyg, DZ, group=NULL, num=NULL, weight=NULL, biweight=function(x) 1/min(x), strata=NULL, messages=1, control=list(trace=0), type="ace", eqmean=TRUE, pairsonly=FALSE, samecens=TRUE, allmarg=samecens&!is.null(weight), stderr=TRUE, robustvar=TRUE, p, indiv=FALSE, constrain, bound=FALSE, varlink, ...) { ###{{{ setup OSon <- FALSE idx2 <- NULL mycall <- match.call() formulaId <- unlist(Specials(formula,"cluster")) formulaStrata <- unlist(Specials(formula,"strata")) formulaSt <- paste("~.-cluster(",formulaId,")-strata(",paste(formulaStrata,collapse="+"),")") formula <- update(formula,formulaSt) if (!is.null(formulaId)) { id <- formulaId mycall$id <- id } if (!is.null(formulaStrata)) strata <- formulaStrata mycall$formula <- formula if (!is.null(strata)) { dd <- split(data,interaction(data[,strata])) nn <- unlist(lapply(dd,nrow)) dd[which(nn==0)] <- NULL if (length(dd)>1) { fit <- lapply(seq(length(dd)),function(i) { if (messages>0) message("Strata '",names(dd)[i],"'") mycall$data <- dd[[i]] eval(mycall) }) res <- list(model=fit) res$strata <- names(res$model) <- names(dd) class(res) <- c("twinlm.strata","biprobit") res$coef <- unlist(lapply(res$model,coef)) res$vcov <- blockdiag(lapply(res$model,vcov.biprobit)) res$N <- length(dd) res$idx <- seq(length(coef(res$model[[1]]))) rownames(res$vcov) <- colnames(res$vcov) <- names(res$coef) return(res) } } ################################################## ### No strata if (is.null(control$method)) { if (!samecens & !is.null(weight)) { control$method <- "bhhh" } else { if (requireNamespace("ucminf",quietly=TRUE)) { control$method <- "gradient" } else control$method <- "nlminb" } } if (length(grep("flex",tolower(type)))>0) { type <- "u"; eqmean <- FALSE } yvar <- paste(deparse(formula[[2]]),collapse="") data <- data[order(data[,id]),] idtab <- table(data[,id]) if (sum(idtab>2)) stop("More than two individuals with the same id ") if (pairsonly) { data <- data[as.character(data[,id])%in%names(idtab)[idtab==2],] idtab <- table(data[,id]) } if (is.logical(data[,yvar])) data[,yvar] <- data[,yvar]*1 if (is.factor(data[,yvar])) data[,yvar] <- as.numeric(data[,yvar])-1 if (missing(DZ)) { DZ <- levels(as.factor(data[,zyg]))[1] message("Using '",DZ,"' as DZ",sep="") } idx1 <- which(data[,zyg]%in%DZ) ## DZ if (length(idx1)==0) stop("No DZ twins found") idx0 <- which(!(data[,zyg]%in%DZ)) ## MZ if (length(idx1)==0) stop("No MZ twins found") zyg2 <- rep(1,nrow(data)); zyg2[idx0] <- 0; data[,zyg] <- zyg2 ## MZ=0, DZ=1 if (!is.null(group)) data[,group] <- as.factor(data[,group]) ff <- paste(as.character(formula)[3],"+", paste(c(id,zyg,weight,num),collapse="+")) ff <- paste("~",yvar,"+",ff) formula0 <- as.formula(ff) opt <- options(na.action="na.pass") Data <- model.matrix(formula0,data) options(opt) rnames1 <- setdiff(colnames(Data),c(yvar,id,weight,zyg,num)) nx <- length(rnames1) if (nx==0) stop("Zero design not allowed") bidx0 <- seq(nx) midx0 <- bidx0; midx1 <- midx0+nx dS0. <- rbind(rep(1,4),rep(1,4),rep(1,4)) ## MZ dS1. <- rbind(c(1,.5,.5,1),rep(1,4),c(1,.25,.25,1)) ## DZ dS2. <- rbind(c(1,0,0,1),rep(1,4),c(1,0,0,1),c(0,1,1,0)) ##mytr <- function(x) x; dmytr <- function(x) 1 ##mytr <- function(x) x^2; dmytr <- function(x) 2*x ##mytr <- function(z) 1/(1+exp(-z)); dmytr <- function(z) exp(-z)/(1+exp(-z))^2 ACDU <- sapply(c("a","c","d","e","u"),function(x) length(grep(x,tolower(type)))>0) ACDU <- c(ACDU) if (missing(varlink) || !is.null(varlink)) { mytr <- exp; dmytr <- exp; myinvtr <- log trname <- "exp"; invtrname <- "log" } else { mytr <- myinvtr <- identity; dmytr <- function(x) rep(1,length(x)) trname <- ""; invtrname <- "" } dmytr2 <- function(z) 4*exp(2*z)/(exp(2*z)+1)^2 mytr2 <- tanh; myinvtr2 <- atanh trname2 <- "tanh"; invtrname2 <- "atanh" if (!is.null(group)) { mytr <- function(x) c(exp(x[-length(x)]),mytr2(x[length(x)])) myinvtr <- function(z) c(log(z[-length(z)]),myinvtr2(z[length(z)])) dmytr <- function(x) c(exp(x[-length(x)]),dmytr2(x[length(x)])) } if (ACDU["u"]) { ## datanh <- function(r) 1/(1-r^2) dmytr <- dmytr2 mytr <- mytr2; myinvtr <- myinvtr2 trname <- trname2; invtrname <- invtrname2 dS0 <- rbind(c(0,1,1,0)) vidx0 <- 1 vidx1 <- 2 vidx2 <- 3 dS2 <- dS1 <- dS0 nvar <- length(vidx0)+length(vidx1) if (OSon) nvar <- nvar+length(vidx2) } else { nvar <- sum(ACDU[1:3]) vidx0 <- vidx1 <- seq(nvar); vidx2 <- seq(nvar+1) if (OSon) nvar <- nvar+1 dS0 <- dS0.[ACDU[1:3],,drop=FALSE] dS1 <- dS1.[ACDU[1:3],,drop=FALSE] dS2 <- dS2.[which(c(ACDU[1:3],TRUE)),,drop=FALSE] } if (eqmean) { bidx2 <- bidx1 <- bidx0 } else { bidx1 <- bidx0+nx bidx2 <- bidx1+nx if (OSon) nx <- 3*nx else nx <- 2*nx; } vidx0 <- vidx0+nx; vidx1 <- vidx1+nx; vidx2 <- vidx2+nx vidx <- nx+seq_len(nvar) midx <- seq_len(nx) plen <- nx+nvar Am <- matrix(c(1,.5,.5,1),ncol=2) Dm <- matrix(c(1,.25,.25,1),ncol=2) Vm <- matrix(c(1,0,0,1),ncol=2) Rm <- matrix(c(0,1,1,0),ncol=2) ################################################## ## system.time(Wide <- reshape(as.data.frame(Data),idvar=c(id,zyg),timevar=time,direction="wide")) ## system.time(Wide <- as.data.frame(fast.reshape(Data,id=c(id),sep="."))) Wide <- as.data.frame(fast.reshape(Data,id=c(id,zyg),sep=".",idcombine=FALSE,labelnum=TRUE)) yidx <- paste(yvar,1:2,sep=".") rmidx <- c(id,yidx,zyg) W0 <- W1 <- W2 <- NULL if (!is.null(weight)) { widx <- paste(weight,1:2,sep=".") rmidx <- c(rmidx,widx) W0 <- as.matrix(Wide[which(Wide[,zyg]==0),widx,drop=FALSE]) W1 <- as.matrix(Wide[which(Wide[,zyg]==1),widx,drop=FALSE]) W2 <- as.matrix(Wide[which(Wide[,zyg]==2),widx,drop=FALSE]) } XX <- as.matrix(Wide[,setdiff(colnames(Wide),rmidx)]) XX[is.na(XX)] <- 0 Y0 <- as.matrix(Wide[which(Wide[,zyg]==0),yidx,drop=FALSE]) Y1 <- as.matrix(Wide[which(Wide[,zyg]==1),yidx,drop=FALSE]) Y2 <- as.matrix(Wide[which(Wide[,zyg]==2),yidx,drop=FALSE]) XX0 <- XX[which(Wide[,zyg]==0),,drop=FALSE] XX1 <- XX[which(Wide[,zyg]==1),,drop=FALSE] XX2 <- XX[which(Wide[,zyg]==2),,drop=FALSE] ################################################## ###}}} setup ###{{{ Mean/Var function ##Marginals etc. MyData0 <- ExMarg(Y0,XX0,W0,dS0,eqmarg=TRUE,allmarg=allmarg) MyData1 <- ExMarg(Y1,XX1,W1,dS1,eqmarg=TRUE,allmarg=allmarg) MyData2 <- ExMarg(Y2,XX2,W2,dS2,eqmarg=TRUE,allmarg=allmarg) N <- cbind(length(idx0),length(idx1),length(idx2)); N <- cbind(N, 2*nrow(MyData0$Y0)+if (!pairsonly) NROW(MyData0$Y0_marg) else 0, 2*nrow(MyData1$Y0)+if (!pairsonly) NROW(MyData1$Y0_marg) else 0, 2*nrow(MyData2$Y0)+if (!pairsonly) NROW(MyData2$Y0_marg) else 0, NROW(MyData0$Y0),NROW(MyData1$Y0),NROW(MyData2$Y0)) colnames(N) <- c("Total.MZ","Total.DZ","Total.OS","Complete.MZ","Complete.DZ","Complete.OS","Complete pairs.MZ","Complete pairs.DZ","Complete pairs.OS") rownames(N) <- rep("",nrow(N)) if (!OSon) N <- N[,-c(3,6,9),drop=FALSE] if (samecens & !is.null(weight)) { MyData0$W0 <- cbind(apply(MyData0$W0,1,biweight)) if (!is.null(MyData0$Y0_marg)) MyData0$W0_marg <- cbind(apply(MyData0$W0_marg,1,biweight)) } if (samecens & !is.null(weight)) { MyData1$W0 <- cbind(apply(MyData1$W0,1,biweight)) if (!is.null(MyData1$Y0_marg)) MyData1$W0_marg <- cbind(apply(MyData1$W0_marg,1,biweight)) } if (samecens & !is.null(weight)) { MyData2$W0 <- cbind(apply(MyData2$W0,1,biweight)) if (!is.null(MyData2$Y0_marg)) MyData2$W0_marg <- cbind(apply(MyData2$W0_marg,1,biweight)) } rm(Y0,XX0,W0,Y1,XX1,W1,Y2,XX2,W2) Sigma <- function(p0) { Sigma2 <- NULL p0[vidx] <- mytr(p0[vidx]) if (ACDU["u"]) { pos0 <- ifelse(OSon, plen-2, plen-1) Sigma0 <- diag(2) + p0[pos0]*Rm Sigma1 <- diag(2) + p0[pos0+1]*Rm if (OSon) Sigma2 <- diag(2) + p0[pos0+2]*Rm } else { ii <- ACDU; ii[4:5] <- FALSE pv <- ACDU*1; pv[ii] <- p0[vidx] Sigma0 <- Vm*pv["e"] + pv["a"] + pv["c"] + pv["d"] Sigma1 <- Vm*pv["e"] + pv["a"]*Am + pv["c"] + pv["d"]*Dm Sigma2 <- Vm*pv["e"] + pv["c"] + (pv["a"] + pv["d"])*Vm + pv["os"]*(pv["a"] + pv["d"])*Rm if (OSon) { dS2 <- dS2. dS2[c(1,3),2:3] <- pv["os"] dS2[4,2:3] <- pv["a"]+pv["d"] dS2 <- dS2[which(c(ACDU[1:3],TRUE)),] } } return(list(Sigma0=Sigma0,Sigma1=Sigma1,Sigma2=Sigma2,dS2=dS2)) } ## p0 <- op$par ## ff <- function(p) as.vector(Sigma(p)$Sigma2) ## numDeriv::jacobian(ff,p0) ## Sigma(p0)$dS2 ## dmytr(p0[vidx]) ## Sigma(p0)$dS2[1,]*dmytr(p0[vidx])[1] ## Sigma(p0)$dS2[2,]*dmytr(p0[vidx])[2] ## Sigma(p0)$dS2[3,]*dmytr(p0[vidx])[3] ###}}} Mean/Var function ###{{{ U p0 <- rep(-1,plen); ##p0[vidx] <- 0 if (!missing(varlink) && is.null(varlink)) p0 <- rep(0.5,plen) if (OSon) p0[length(p0)] <- 0.3 if (type=="u") p0[vidx] <- 0.3 if (!is.null(control$start)) { p0 <- control$start control$start <- NULL } else { X <- rbind(MyData0$XX0[,midx0,drop=FALSE],MyData0$XX0[,midx1,drop=FALSE]) Y <- rbind(MyData0$Y0[,1,drop=FALSE],MyData0$Y0[,2,drop=FALSE]) g <- suppressWarnings(glm(Y~-1+X,family=binomial(probit))) p0[midx] <- coef(g) } U <- function(p,indiv=FALSE) { b0 <- cbind(p[bidx0]) b1 <- cbind(p[bidx1]) b2 <- cbind(p[bidx2]) b00 <- b0; b11 <- b1; b22 <- b2 if (bound) p[vidx] <- min(p[vidx],20) S <- Sigma(p) lambda <- eigen(S$Sigma0)$values if (any(lambda<1e-12 | lambda>1e9)) stop("Variance matrix out of bounds") Mu0 <- with(MyData0, cbind(XX0[,midx0,drop=FALSE]%*%b00, XX0[,midx1,drop=FALSE]%*%b00)) U0 <- with(MyData0, .Call("biprobit0", Mu0, S$Sigma0,dS0,Y0,XX0,W0,!is.null(W0),samecens)) if (!is.null(MyData0$Y0_marg) &&!pairsonly) { mum <- with(MyData0, XX0_marg%*%b00) dSmarg <- dS0[,1,drop=FALSE] U_marg <- with(MyData0, .Call("uniprobit", mum,XX0_marg, S$Sigma0[1,1],t(dSmarg),Y0_marg, W0_marg,!is.null(W0_marg),TRUE)) U0$score <- rbind(U0$score,U_marg$score) U0$loglik <- c(U0$loglik,U_marg$loglik) } Mu1 <- with(MyData1, cbind(XX0[,midx0,drop=FALSE]%*%b11, XX0[,midx1,drop=FALSE]%*%b11)) U1 <- with(MyData1, .Call("biprobit0", Mu1, S$Sigma1,dS1,Y0,XX0,W0,!is.null(W0),samecens)) if (!is.null(MyData1$Y0_marg) &&!pairsonly) { mum <- with(MyData1, XX0_marg%*%b11) dSmarg <- dS1[,1,drop=FALSE] U_marg <- with(MyData1, .Call("uniprobit", mum,XX0_marg, S$Sigma1[1,1],t(dSmarg),Y0_marg, W0_marg,!is.null(W0_marg),TRUE)) U1$score <- rbind(U1$score,U_marg$score) U1$loglik <- c(U1$loglik,U_marg$loglik) } U2 <- val2 <- NULL if (OSon) { Mu2 <- with(MyData2, cbind(XX0[,midx0,drop=FALSE]%*%b22, XX0[,midx1,drop=FALSE]%*%b22)) U2 <- with(MyData2, .Call("biprobit0", Mu2, S$Sigma2,S$dS2,Y0,XX0,W0,!is.null(W0),samecens)) if (!is.null(MyData2$Y0_marg) &&!pairsonly) { mum <- with(MyData2, XX0_marg%*%b22) dSmarg <- S$dS2[,1,drop=FALSE] U_marg <- with(MyData2, .Call("uniprobit", mum,XX0_marg, S$Sigma2[1,1],t(dSmarg),Y0_marg, W0_marg,!is.null(W0_marg),TRUE)) U2$score <- rbind(U2$score,U_marg$score) U2$loglik <- c(U2$loglik,U_marg$loglik) } } if (indiv) { ll0 <- U0$loglik ll1 <- U1$loglik val0 <- U0$score[MyData0$id,,drop=FALSE] val1 <- U1$score[MyData1$id,,drop=FALSE] N0 <- length(MyData0$id) idxs0 <- seq_len(N0) if (length(MyData0$margidx)>0) { for (i in seq_len(N0)) { idx0 <- which((MyData0$idmarg)==(MyData0$id[i]))+N0 idxs0 <- c(idxs0,idx0) val0[i,] <- val0[i,]+colSums(U0$score[idx0,,drop=FALSE]) } val0 <- rbind(val0, U0$score[-idxs0,,drop=FALSE]) ll0 <- c(ll0,ll0[-idxs0]) } N1 <- length(MyData1$id) idxs1 <- seq_len(N1) if (length(MyData1$margidx)>0) { for (i in seq_len(N1)) { idx1 <- which((MyData1$idmarg)==(MyData1$id[i]))+N1 idxs1 <- c(idxs1,idx1) val1[i,] <- val1[i,]+colSums(U1$score[idx1,,drop=FALSE]) } val1 <- rbind(val1, U1$score[-idxs1,,drop=FALSE]) ll1 <- c(ll1,ll1[-idxs1]) } if (OSon) { ll2 <- U2$loglik val2 <- U2$score[MyData2$id,,drop=FALSE] N2 <- length(MyData2$id) idxs2 <- seq_len(N2) if (length(MyData2$margidx)>0) { for (i in seq_len(N2)) { idx2 <- which((MyData2$idmarg)==(MyData2$id[i]))+N2 idxs2 <- c(idxs2,idx2) val2[i,] <- val2[i,]+colSums(U2$score[idx2,,drop=FALSE]) } val2 <- rbind(val2, U2$score[-idxs2,,drop=FALSE]) ll2 <- c(ll2,ll2[-idxs2]) } } val <- matrix(0,ncol=plen,nrow=nrow(val0)+nrow(val1) + NROW(val2)) val[seq_len(nrow(val0)),c(bidx0,vidx0)] <- val0 val[nrow(val0)+seq_len(nrow(val1)),c(bidx1,vidx1)] <- val1 if (OSon) { val[nrow(val0)+nrow(val1)+seq_len(nrow(val2)),c(bidx2,vidx2)] <- val2 } trp <- dmytr(p[vidx]) for (i in seq(length(vidx))) { val[,vidx[i]] <- val[,vidx[i]]*trp[i] } attributes(val)$logLik <- c(U0$loglik,U1$loglik,U2$loglik) return(val) } val <- numeric(plen) val[c(bidx0,vidx0)] <- colSums(U0$score) val[c(bidx1,vidx1)] <- val[c(bidx1,vidx1)]+colSums(U1$score) if (OSon) val[c(bidx2,vidx2)] <- val[c(bidx2,vidx2)]+colSums(U2$score) val[vidx] <- val[vidx]*dmytr(p[vidx]) attributes(val)$logLik <- sum(U0$loglik)+sum(U1$loglik)+sum(U2$loglik) return(val) } ###}}} U ###{{{ optim if (!missing(p)) return(U(p,indiv=indiv)) f <- function(p) crossprod(U(p))[1] f0 <- function(p) -sum(attributes(U(p))$logLik) g0 <- function(p) -as.numeric(U(p)) h0 <- function(p) crossprod(U(p,indiv=TRUE)) if (!missing(constrain)) { freeidx <- is.na(constrain) f <- function(p) { p1 <- constrain; p1[freeidx] <- p res <- U(p1)[freeidx] crossprod(res)[1] } f0 <- function(p) { p1 <- constrain; p1[freeidx] <- p -sum(attributes(U(p1))$logLik) } g0 <- function(p) { p1 <- constrain; p1[freeidx] <- p -as.numeric(U(p1)[freeidx]) } p0 <- p0[is.na(constrain)] } ## Derivatives, Sanity check ## ff <- function(p) attributes(U(p,indiv=FALSE))$logLik ## pp <- c(0,-.1,.1,0.5) ## numDeriv::grad(ff,pp) ## U(pp,indiv=FALSE) controlstd <- list(hessian=0) controlstd[names(control)] <- control control <- controlstd nlminbopt <- intersect(names(control),c("eval.max","iter.max","trace","abs.tol","rel.tol","x.tol","step.min")) ucminfopt <- intersect(names(control),c("trace","grtol","xtol","stepmax","maxeval","grad","gradstep","invhessian.lt")) optimopt <- names(control) op <- switch(tolower(control$method), nlminb=nlminb(p0,f0,gradient=g0,control=control[nlminbopt]), optim=optim(p0,fn=f0,gr=g0,control=control[ucminfopt]), ucminf=, quasi=, gradient=ucminf::ucminf(p0,fn=f0,gr=g0,control=control[ucminfopt],hessian=0), ## , ## bhhh={ ## controlnr <- list(stabil=FALSE, ## gamma=0.1, ## gamma2=1, ## ngamma=5, ## iter.max=200, ## epsilon=1e-12, ## tol=1e-9, ## trace=1, ## stabil=FALSE) ## controlnr[names(control)] <- control ## lava:::NR(start=p0,NULL,g0, h0,control=controlnr) ## }, ## op <- switch(mycontrol$method, ## ucminf=ucminf(p0,f,control=mycontrol[ucminfopt],hessian=F), ## optim=optim(p0,f,control=mycontrol[ucminfopt],...), nlminb(p0,f,control=control[nlminbopt])) if (stderr) { UU <- U(op$par,indiv=TRUE) I <- -numDeriv::jacobian(U,op$par) tol <- 1e-15 V <- Inverse(I,tol) sqrteig <- attributes(V)$sqrteig J <- NULL if (robustvar) { J <- crossprod(UU) V <- V%*%J%*%V } if (any(sqrteig