relsurv/0000755000176200001440000000000014151655142011760 5ustar liggesusersrelsurv/NAMESPACE0000644000176200001440000000220414127251471013175 0ustar liggesusersuseDynLib(relsurv,.registration = TRUE) import(survival, date,splines) export("epa","invtime","joinrate", "rs.br","rs.diff","rs.surv", "rs.zph","rsadd","rsmul","rstrans", "residuals.rsadd", "survsplit","transrate","transrate.hld", "transrate.hmd","rs.surv.rsadd","survfit.rsadd","cmp.rel","nessie", 'years', 'plot_f', 'plot_years') S3method(residuals, rsadd) S3method(plot, rs.br) S3method(plot, cmp.rel) S3method(print, cmp.rel) S3method(plot, rs.zph) S3method(print, rsadd) S3method(summary, rsadd) S3method(summary, cmp.rel) S3method(print, summary.rsadd) S3method(print, rsdiff) S3method(print, rs.br) S3method(survfit, rsadd) export(expprep2) importFrom("graphics", "abline", "axis", "box", "legend", "lines", "par", "plot", "points", "polygon") importFrom("stats", "approx", "binomial", "coef", "delete.response", "glm", "glm.control", "median", "model.extract", "model.frame", "model.matrix", "pchisq", "pnorm", "poisson", "printCoefmat", "qchisq", "resid", "symnum", "terms","as.formula", "model.offset") importFrom("utils", "getFromNamespace", "read.table") relsurv/data/0000755000176200001440000000000014122600241012655 5ustar liggesusersrelsurv/data/rdata.rda0000644000176200001440000001562413551065110014455 0ustar liggesusersBZh91AY&SYr]L6 @,;`>$lĉ6bDM A 2h&M11i#@ѣL`F#&&'IƩSOL dmOSLOa'= lL5@!OS&Tx  MhѠ24hdd4dbcHѐM &'e =M &Jz*CڛJd )STOTHh@ 2@zOP0 `& @A4=F#bɠ4d4h4 100jh1&4i05 @EN9ؘxv&|7V|%0*n3bqf*۬Qf0_`)Y0&]*ֵ/-6%{Ÿ71V3cJ옖̠r!J!סɡ-Oơ zMm_p,J,qG^h/dh}/)y%FGXEftM-rQ6,/cU.'Cw/7MNs\r{5z kjxtT8I" L)޲c$0igKv7߅͋5iKFh P]<8oLI #zX$ %'8-)푕 Zv"v&8,Q ӃY#$n1%jKeWKRԎ:n;$9 2Fn  ,s:"m*dq;$+B)!]6W+qF㒻H HqYcV,Vhv9]n"UdV2%R)[r7bmEeHI`L ,W$+9)mPZ$Z2Yea+cM–d$Ip!ۅepY+$ #XYm% h&lnYIq#S%nlIG$Heq8i*6V:5#5ⅬAj225\V[a "$:m.La×%ǦOժ #?yѢ_b_0"p)Hzi@f>?t{,>ܻa C;iX=o厽|_lcm ||Y7+oejߊinB)Sߗ@fJ}Tc06zʲT2SvKZ33<"sk%k>}/[EzrhX:k7rOO9ѵ7[?OqN)[t4>S\Iμѻ d̲Ƥ`:vcw65h3SͣZٰ߮۫UZGM/> dK XVm %Xe${.{e wwC2Yލ8FiZb;uutsoYQ Z'F+ͳ+g[W"Br\50ߋ= s*l]nkowS{pʹ+sճbหnٺZ9riyQ 7&׭U\m476N z{۱ٻ'YK$p{3aGmJ.\`j^f~]Mː5= Tʷӧ'Ҏ7պa/%D8vژ;6MPdux3l[ɑÛ+ 7ۣ~*lx43<,~joEʺbiÂӗG~mYAWLjӔ5,L}˜]$hlLVa8ݲoϼzπ Q3o]\Db|WX—!e[SJHqw~qYX6}H\6ҵUn ٿ德QOb VP/b} x*rg&^rj@@ w.~Zpy7}[2IHg!Ǩ 0VΚ׋. 4x ~3$ܹ}gkWd;7T?3QߒF&Ÿv dFpPpV b&ԑYax'`OƗ*sl4vb^Z}ɶIREn|Xs!@ "O'JU~ՁE܈i `iz3p.6y-/{OP%—,c2QEwqKXĠ]Kn6!s+'3(YGm1F.G>ӣл7uJר\skp HQˊ8I=5lƋH}zrt2/@gTK[*9MS{Hvz̪DVrSUʔ::8 m.N"9Dd~KgVaaQtjcxdෲ\8Sey,o1㧃i323yd$=1۞QFfkܟr\'~}/s %m_ye9j}59DDKkc6e6Q+|Jv^^~7(ܳR\XkBnw6o3_ZdYvEM4kyZ_SUwƠꃩR8 [Һ8&9n7"p<׷R;BN =GXdPWQmjfQ3$[id=TQkV ѢW! ܍҉Ʃ޴{=g%Ĝ[n&/V֐=PMkd.0ҩx#l2iUupz. }]*G0 *=H;ԅa6K'|AI$uABHߝ>u]u]uE4M4M4_S{]3cF0!{RAT4 s:Olox66m f2kR:1ћ98`+pĥaL ř<@l  3 O'F.&uaN:giY6++`qZ-`5ijhlm6bl0i 18!4<"`pƑ*FԎ1m $'e ? q$q!tBLI$y~\R@I7n HeQ8Ϡ MG pBwMshi &mšeC[ug!KMq0Jde\|M]`ɶ峚- :o9F0HDǣ؉#n$,tˆfdvD{rRMՉ6Aqᘄ<=t($GſJ(`:$ R-U<@] *4bӇ=q sȁ-eQ|.i[.^~8pa i8^Y7=e] ǣݳ~{jh0,YqĎT v2ǩ :?3 U}!vFYyz߿(a`F0#a-1}]UUUUUUUuuu)^^JR!ZըF%Kʖmmk**ʊ**ʊ*`3]c FMs9s,,,̓}}|QUUVTUUUUUeEUUYQUUVTUUUUUeEUUYQaB!afC`*QT)JR9s9()JUB0nݻjʊ**ʊ**ʗ&-Ro/r /\p1$JJJJJJJJJJl$`TB eYeYM,,, {{zYP P P P=|=mmJ=cDZ뮺 Q)JR%)JR.=UVUT{{³xY )JRs:(R*(F*TUURTTTTTTTT02Lݻr˗.\U`(0L>&Ư'9sXe] 2L50` l Dk cd``,pH:[۷#6ؓblob1")"1DEbL)1&"FDɉ6f5A"1bƈZ4E F"1%Y*(,`hDbDLQbB4b(0 ø AQ!5A%!$ʀ(I4P 2b҆63X i6jSIxctφp#d#\$$F1FRRLAL 2 bFa̓2%$AL`Q JL$S3de)d"4!"LL! 2! &i HФBJe,Z@JcSK $c0#2E1`dYFe |D 4m46eX,. P-٪$Zo2H<}٠ZEur-pD@JI 9 aВQ#ALLqH7iyz 8.uOUxcMd$v=g1\]sLR-9"SOE/3¥K砖<+I{jTl.T1J-a.':RxΰH*ǃL_\t455h̃9 uq?j»$=ByUusɢ͟yU3F FJFj6 U3aE-y=~ ጽqc#ok;;AMbLv9sObus2zǐ9A{k2Z8f2NO=`4b;Ա݂77:\ty/ ZA^Pmu`=RB@r b~ 鋳@9͍wqDc&G*F\Iydt.g~;\?Q; @yASM>ţhG _U }#zP'B O[L$.I QKu- }hH )m E2~e͜UA\DךdE"Ojae2#bŽ{UQ4J Kssu?Nmm7}@iդ?x/d赾5&N:|ZfJxuaN9{wG |!F]Dtu=6ilkO+xQj J~O,3YjޓoNLY؇௲k;’ݡ whIȵφ2Ij||| U2n S0- *[ʹ![(;X&M*4FrSEs cbDbS=iC(SYN!-JI](bk!;sY;DC+RZC&%tY\ ɑ T2`b9jOEѪaD*Ej A9JЄikFʏ']GIBw(*iF1l8Rifʮ=5+4U'9KAX,4⵶iœ.0Br$͂3;!$ &2А`  NU34=RI+s3:dl[yZ zeJXzRL{c[{EԨ(Y'Zc ԥ ٜ cudABٜ;n(0h`s <)X"]KJ Bqsg[Qks:w c᳏fF}.f|}.}~nyxc$$|9 JOJX0YƶMEh}@m;mKC-Q"s]0֘/˰J~I;/uv #;4yεv1"Y'7+6O{u6sD!R|'@[ADR^Pu&Tz;}A-7Ɇ 40kBRPpٿz.oNǿ}|0n_q08# LNgٲ~V4X|&7-Z"6 ϥӷ0`oIqr7~ N̅Bە`ؑs(b  [ Ғ2 mj(VFh|IC(Z}2q10 =s !t౦ .ZjVQ+_R0.a5j[_YZ!^okvC6V4jSCo{D(fz^su1}Fa,)ԙTm0RͰYCY n͕B7ԓ0Dgk)<8PYЈS/m so NE-}hj]~NJ[4Sc@WŒk-hŃ'DVH>2@Zz>ԟq8?>^&0wUfguםY%?jf.rtߣ* Z=h' 3S!zV0I&ma ¿݂no(iu*Ҹ聜P*h .=L,!fe 4J.yOm;+?Y!Y"0IxͮF՝>N^xfmTy1,\zcMT-ݫ ] IעfV`_];)oLVRm%nwaǂpF@曎Ơqشp|K74nȳ"j Jh~d B_w>wIo(GLoN;j$ze nv.f%31)]c6ULnx yР:jJstB;2[xh, g~B{}ji4>!~ M8x]wMQ~)ND97o%Ll_cmh9lQlH*9%*lYPOlۅM1[tK@7+s`() ]$úJϹio^>8\ߺhaR?{TetWQch>ovr~ BZXY6 ?;Mאs$:N_)@Mkz`ϝ@(yHj*jϬ[}9*A]t7e]@},Â`h&|w?aqk܎SGg)R#`pn`O0ߘ5c4GmikL;vfE~) ki L3`qx| |mO˦kt.0ji&K%-_51S;o'pUuz$JuKb3Rot##{y|O0~&_Ѩwtp~0~rIF?ņ~&_MBԦ{ _ s3Oj8*_^ꭏPWa.m=mtJ26A;EفOnD\8UlƎ>+Mcl(Dg$,hє|E94Ck6=\vN UG;k`|5v2v0IO q+R2%;yj@nh zPX2 J]R`7P3ޞ udv@HtuC=K-@@K%yT=T[%z`̓zń 3t-mЫY3RU0vL3qX8\y7+#'C+cxm |2ۭוFSm;t[K"(~䧮˰G~BC~ j_EiZq<:QgsFv_QT\#BUX̩zvc}29\-Ljkwvap@Sr@:?Q%?xj*jWPk!VV!ػ |;@ЩGdJAUwQJi;6G7 .HTdDMU&1UZPI}|ߺ)TcLbgݹК_9F@g_M@E0L>]gF;d]Ng\`e1Co ,HL5 ;Rg8ǿ̻AE.Fʂ˞6fW;ٹiU£ȴ8؛)m)rKT5/V{[~788^lH]:a,`R[K~^MjpOZ-SvAUٜUB5]TϣZꈑPS;WAG#?XϐFFz37yrt[PWaqup#m}`fzՋzhS8HN$6b Ïf( H!PU?briU~_e34qNyx |U|#5 =lh;mj)fچq^SR}፷@O*Y.0(Jjӆ&x%RI0/GU:Pc(,_} lގ4b#Z2T]q6-W<`Գ;*[Vv=-OKx`n8NkMvf>FzWviCߍ١D˃^Q Ja?5c>H=> ۗ>8k>ks叝~p|~w6 tr;b\a>^ *oF5$QOrǦ%9X(z_F;t2u {j[E;㡿af-n-RVO-M gZdڗ翴iɭO*^7νgJ TG%#| >ԏaC.B`v 7z˥ҕ%]2wd6rvo$ѧ]&]9]sP D@e=֏`ʱZfś0x1T[S V^D13O&0=4_/8;c .;ĨѲj>O?7ɪT_ OAUbe{ <`G ZYC;\}DI&DKOG!ޭ|B{ K^ѿ&pTCram2lװƪܧ+Wsᴧr#:? Y?Am#o]Em5G8tׄz}Bmˮ'BДSSt#̟:]cSfuIC Z֋h֭1=-P[SބVx- *Pj̪L}fe1Y8;mQQڄh{ K6D¹UH]g)%0WcW>L'_Ztӓע_;nKGE `(itflM|j4)n9qZj[[-:;U"^~{r%AOLd9(8+#`kGknGl6 jM[.'[~6?9ꊾwM:[]ȸΥ-P`p(` MS( s0~::пzT.c3P#Zv/5ԡoǔpW [qMWw)]){S]ݘXЈKEJnU&B >I ]y h9 iFS]}\~rXvUCVe`)a~1`?4Rv7pMk uENr׿e |> Xlcr)R!s&pB?[^Zҹ4\1PUQhb<y j|g_x8>vmY>m'3q?r"?(/>;O>Je%TҶB0Q4vMa`x`.?yk-ు`qz|d50Nk#Ӟ<6a:(|u[:?-yl_tpȦF61VMAM y/,]>?z0y \71&GE ż &xi^ZaPyRyӇffT(ɾ#j@&f@7VSyO z)2);TМMM>RCCzGt#0K/Otg|D=ǝP`':s1>se :n( hm֒z_N=}[A5F+˓$8Ym@jT]@V7.Dȸz 5%A陏lİ} Ԭsiy)0y#e!H3.z4Kpeu\uҠ=(>/awA9b?h8˼WYtʗr߃^LG(O2{;FLţ6`|*_N+4[`w13jn[B6!ЕBv$;zuxl.|vhȎ˒xRZzk0&5a1/x_qs10/ҸKΛ;-~_A;2#\7$keB8?둰?2\χu+}gճ{O<ȵD]6rp^r܁i\wB6.Qo&" 7H6s8o45ZPWts~џV@n*_Sa:VqhܿEz.N_O]T4s̗JX!jc~GdMĀP$[zmÔ{(л_+ߺL&.ggJGE`eL^ꆏŶ[{.i`K% ·eV ǟ-VNM^m}Qm.& qz8OFi2u=grd:ok=͖eA!Ԗ-C (uT{@io gP ="<^46h =pņ|j#s|WzPBE`pLA0;qxA0#%3/]jrRdSӻ .o3CS;7mhz8?,ZQfW'xI19[ܮg ?xuvdG|TEvE,a[3vańqMϣ'jOk=8׸~>9u {X1`º }ns>{SF<%?i%_cwǙ~"{.燰0_FL>͡?R;_ƪNP%a c@κz8X (j JY}6~2oba5r ĽL@y;3$*zQ OČWڳt]Azi)PEk3(zHKKeJ7P>pVp> \ϓfNjN:Z+Y聊fj ziҍoSn.SXZ,!0P:Bb[|)t)`G9vD<7p~'>#hwGq"v ^y}?TN[Gk!>ט0Nz"O/X+;Q'`es0oa:3HsXhOy>,:>S)EJo*d?ϖ 0G>=40jPJ 9#M:H~rVAS *+Uz'U%'DZ4biOɮ ٞJ |sOkkaHp ,=t9?~ڗRX)̳rSxa;5pz 1Sckpz0FW9}@_G6Z>C4OP(׹ >#8VM+sͼ~K/7ɃTn. =mm@vO"&%򷉋R[6Z{3Utz8Ws<۴0?u;JWa{`p8XRΪDÇe; SdObjr:+G5NuD>:</ucUX_P-gq_Xquk[w<C#С!IИ D?Bo%3 ͜T3܋濷JDdO] &xCE'PJ'ܴZnU3ɑ@4"{.yX '\UxYSѷ}_DqsaJʺ~ux%aӶd=ͷUbǸJ66 S =I*D?Y5m"&es Kϱ6UO'=ElS@a繂lvH|=Av>XlW`jхegԴ&hA_;ڕDpۅ0|QhG w 036is遏`hi&N]訟jW85ׅn&ևpRP}˙*r&6rDe?#G:Ͻ}j;#sXgE9?G7%.gM~i%Ɣ |Du؏ QgΜjx_,s]>Hamʭzg 9d~Rh'~ѷ0W>uW]ڷtZ!2-]2m+ݑhU2/CfZ&?=&)ڦHmw lιC$u`M)J/pIF[ To->@3$N%LK ҿAd V: f,N06#졺3Ȋ ^Ō:bྂ㲠ZT4 Tɝy4^_MLFg6qQ>'g h{67υ`CQ21Lq~XO ǛS3})<ЄLjMp̎2z5|Yu߮,?";@GXxZ-p'?߃qu|1_szm'*={7u.X|w8=ڑ7%pKkz:Y:Z\yʤPoڵHRB#]J{w,0 'G]& )^d7v_hxb6S0}T$晒=,FZCjO)WbH: ,(] @z^?j d" {Tyi?|$mKރߺ@lOՏu} S+A9c`9(u=<T{BNq,>*?*9 B{3`\:q[:+镧}U~.`ns'Z>vo t#ɉׄ?d>t&t&ɺ``Z/kҨȯo:a nƔGX~ S]|_SV/Ͱ }ؿq nc >4'ޡeַW2f\Zhrk~9\Z-hޥ5"ͅh*MFvہBB6Z96~~\>8cߞc twvm< fl#{~OOۉ-/`3^{F벀7b!J?3u>aN Z dgn&4Ye/  yΝb ҵ7oe\u|^P|9[ag|l LˤtQMw+h2%d d3|WN*l^YQi0zsL`BU4*n VG)DŽܶ8l?9ez=so@7MD y 'X;l1 /F ;-"u:5G8n|:'\ooJDc"~YSG>ZT;}~[ïcq[NY!އ.aޮ:Sg))gsKާd5zb ‹F}&0(:T;-WM܅j9Uh%OB7*c}HdUN379jT*psPDm~ 4ډ-'Q4y'Ǹ8)-eCU쯎`u8u7pĊ|^| ?;>F#߲ukX*מ0JY郾H/SQ)G-ĚYãc9 GNIH'1ncwYx(M._Mt?hٙ-U\սce,qIphs}DƩ7(r,-Y,`B=)uL"d}X՞[kҡK'QQxdR,o(1_-g0x:~g[cT^H/\ۗ.cb#KՐI0_Da]U܄Go XەNGQq#17 xj&sb񯎰Vσ\Lv Ca -&two "Mבx~z#](g>Ep%'J0N3y`B+9),dEǁ[IvPgw&{ ,玀#nwѰI$ ]Ή=gV"@z蓇f\E~dZ-9[;H?~YkMǃ\${ Tr-A9Т &D=֞h[v9l0#Ы;0&X-w[vrs"[\kl[#8cv[?ˎP?2eUq)|:hM;^,gY)2mކ!q-߰?^gy\׀u7dSr;9hxof {*X @rK[Ȭ/u2Wb@N~& ze~"%Y)foA@oo -78TZMaK:ex=UY߷ P~Kc.6+_ۓ f|ALgpqxH|ژ@ eAnB#᧳Ъf{VjMϘS^:j=٢K?dA[!V$ =T_yy矯 ۇhvjmf x(VMZ!`md.Q4%;.H}rUv^/z {QvcQ!pD|:#l1ܯu|*\|yߚq1a~u D濵 U܇|?pyWZGKr ?N>Fƅdx дW'N[r?q9}IԼhy*7 ]? dvog>T(XI~o h_׊0,FnT|3wK`{&Qlb.%P/WHv/~ dI}&`B_n/09-3 ۿ^w9OB +e'HG%|u@Fma-t) 8P~srTb47~ o9;Ct>:[62mлI2^8 cxxཛޝ`=%74Y9M5‡8RPJf S?5󺣶sz?l=o]ϺU(r?5sbۗmdѻ q΋b=wyY/ }Xnu 8>s+\Lq}vW *0T'F}ouw&bTF M̼4| K#,ɕCS'6ַ|B3y 7+ @bZrm; TN̞G~OԿm% [hϴf1zԙkuD6 uDn6ZZ2"GCus:?x֙q ֩q=ޟ[a}ay}_ uXWy=b]uv~FT,R0)Qp)0pؿV{oy؅t?4^;~*}E >eP 1xUY1 I:GX-r%Ԇ0O~, y&$Mǜ*I+oۭ@Yjm-h9)ô70ܾUr6 "kv pJNi~#szɐN xIdGbv1~ypDfSI,?.1Y3'V茴w Sr/]HW'b$@u^sRP5ϴoo5ҤàɕoutV KX4 c~nQ0xuӧ`fө,n1 WKϟ `, d d iU*g}GͧmX7' ٰuE;`:+X'88z;ao.{_s wݯΓb:<.kXyVCsLqX##t5t?\[0O> )z!;Bh [=EE gܵzr+W&ׁwO;oqA&lT P5x*)1$FePsYОxK F^?_-=R*׼*e\ޛB -5?fw3bw^j!JZGau@Xox3jTnbv{V&Dw?WTqls8|1Bc}uPzZ=ˈykq Wmku x#_8,>b~šוb?ϻzXq7E".~C?N}FY=i|:>Mq@V) ݷ(JGf<1gDjRf;G+P:xR>iSndqC?%4B䅘Y| ܻ䝕Ӿck7:3{ ?o?X&pc%5Aqq+Sϕm~b^&ZDݨX'|\Z&-Ϋtûf@,*C̳f2)쓹L̵Bδiب~ $,TMmr~'ەs 1,qkw->ыY"ŝza)`vZS_ǯ 蚕'CA 3Os58^\S X_T[WCzⰍ80:IDRw-xZu aQG_γwORG)K)jBv6'Hů,/^zwL!^[ OuzW9l.=WMSv{rXCo8eT8R="iTl%Hb]xi(m$V7 Eɗ,NIC]QD@uU'(/Nf78C(B; ccAiң3,bnRMJӈG[6:a N)FѨ=M}#HC(.A:N|9>ZK F>r|(Au?][I]:ɣ(6&BE6 !toPs-*rw0UKm_B]π6=`-Qiٝ!3V]j`=ūM\ w>BEMGXo+:ơx-~Œ徿MCu|޲k͟?x)R%׫[e(ejVxس '8OBQ0)Q?t]zyiTg h9Ӫo҃Lv.?BYBYC?\Ai;&NiG} >=[AzBGײ8W?6;wĠqPb^7׹;;HhGSSgYC㍾:/V4ke -R^ vxV9@ݺBv~P꠲QN29ڔ5{,ey.~_GLJ31XGAl,pzC\O:\-An1rHvy;u} Deԑ}GAvPP2yJ>V/zZ֎Q<X zkDLx5v{Aqvv0}y&Q֟8YLFis(zQ27x 6Qҥoܵ2&CM#负x7[ \` uRquRJ5tX]_<2m%$>qSr;ؖɏ"u} VAC%ã}Z݃b+ *GH#z_#>uT(<6-*mR;>-92iA{dnDԊoX7'I?墢cvK2Z"0>Cuc*c}ܓ 8:~)*]~{P Wz/KCQwɀ]A jw+M˧gK{WrS*j>Ժ:* Y0x߀:ۗBzzi0Bg '"oI/=*~%$76)GC㪕kY8jBOhY;Su% l+i ?J0j9˭S3&]@W?9 +*)f}r`Z ?!giu^ׅdd`.𼍱Mq) .-V#Z ThۛAm[ۯV*ܸ;Oyp>Ť<9`Ezd -t\ @5csXОrq[::]:W@OoSaw^5JÅ/KY`ff}l8d)5lu^컍Vϗ[qTKx6Q})sT?[|ըo5xhaBqawI'P\Y(^H&ܿtN\j@g*5SDʝ7| %letf,JzqYq6u~l+3Gۯp8(c|qT0z yV 5f(QS6ʯ̉>?ҥD[-J)h?ůP޴&8i4 ؂J)DPqW˨uL2 |Օ;p 5R 0yo ^!Ԣdފ:ѿCmCx2io,/Ѳ@*}WV].gUjE;r@ .8%h.{CZ~+VJѻ`'C{8{s d  V-mg -_;T!Q2{@ӽctO#WNL m{r)Rp ,#RDžԣEk4^S^9N@`ܒ%?eDxmbWIɌ%6ip# #Js#?%yT*HAiFCP%3$+%9х{wnڗ~;qMesF3+2S8XS>v\>6{B{ׁ[\`_rHaE=F8z,/$<#o']6EaBYjNOqeyzs;TbQ/aruR(JXp0_}~vm E qOA^*@9u P]6*" m,(в.yf,|en[B%a!>6DtW>i?<p}ȩy:}J*C_,^ 8(7fW"#Vӡz5U3Rq~J[}\cG_楢''=rIBuݨ8j빳?5 sF]:w*ׅ=fu,wd]J}̀/MK*AT uhީ ͗@M郁;Wj&A7!nm ]g4f yjWq3qV si[dhܐUEވZe;$7玓uկC; kwXW;]Cl-SyXoi#3'!z&۵^{8 B~VA4o]sydfkz1H4}ciR gRt _>tmvP5ss >+_YS>ƺE _d~u`V^&1rvsoX6Xӟk׃ [rV7(f4%(xjGqaٗiTDz'T53yl} e=8ER 6蛝vFZ!Hf-qZoZ;dQ{rۈT}>:U[5xy:ЯO i6+iO#jFsgTgn-)A̯oDc$yp4޼,?Gmc2M+ݿncBKj-h1Vn& -J Ymr  buRLMvC :`hUyʷC"B6`ru5`xt؎rz/l>GYo t/1$6L'ڵhw9IL sK x G-csbJwo~9Ñ ֧I`{[As!a}OZY@鍘%.0:t&W Fqj#8$t*>};L/^&:g#/WJ9gT/.8QBqTgr}l7gHۋ&ZHxo^E&*D%"[;QU1o'Q-ݨKKRTTaG]O$uIמ@ܗz_ H\o~n2":gfeX4PH~.Pٜ~j4bXsWOA#QG|'ڥ.4Ё8? @##|[LUL 0f8 Vka'M[V\jmŃq;tïBfQs5g%=ej,5א1!snp7I qbK Eu=yu +*6H_ E&Qi\̗cQq;+*;}Q^FtVND.dH:^ˌ(iAU{\JB~[P5'TP<bέ/U*ThF"lQ\ҥd`9=IYTќzrTAٻyq} >m| ~K/'xd !npIJ#5Lj˛x/Ї P{d/uly6f _Bҏ}N@cy&)|h܂>U [%ќ`r~O4Jr.,r+?yb74g耼CLUQO ؑT"/q'`#0';*7ƍ̀FI/=}8=ΏSm w[Θ~شai,|zuvU<ȂezgHXa x94~jQGA=E3v޷I5 -۪;HXP&LE/>ߞe<)l2`FeYNy V7~/(DM#E鷱:{/¤__2l[/n|j'J0% ~l&WS;A!7p5epy?/O@ %_Ae\Kx}i'ꑂx:'k27Hv鯀އ3@At[(k5pkw@֦99/Fճ}`)`W~L&=oW3.[_]5s ŋ`\L.l=Kk.@3F7~zEl9OKsXBuBr/|w位º6ddZg&TP/9jRsmŖݳœ0Xχ;PlI&:bS"s=D۔y/6WϥbQYa>`=Eԉ ho` _@,ӏ<&r~ԎF Ň5h)R>&X-/:Jg/ju_+UQπ5A,%PT=Ȍ@j,"AdZ6Ov/XdmKISX8+87lԎ*M?@ 9 u93T v=uyNN$φ<R(|\w(13&)Pu쾾RwO6RN/MguCKPn7{DN'wC8ƒݙ#`v~z&X E +~_`Qyj.lUܞ6?UWr?(o?|޷4Osm}MokQ:sދtݗP9DMQW-Gd_;}K`V4U @M sCX?q w UO7@Liq퓚hN џr|:.HD>"]@ucb7mւa`d .QM.":=X?ݚN9M]$xVZVP#gjmUO?H̗ip? k6["p_g{ϕu?yS_ϫ"b/4 }Qo<ϫjP!x'jyg1O~Ώ9=NgW c /LJ (P^͏{WM('\>ɳVh/~/V&4GfOE-&sq?zȏj@K$xBtV2Ҁv\RZ[a@A(E j kA?sNs!^ظ}gcؤxI\n$ B)ٚM RK%΀u{F^Ӯb+ !sY>vp\\xMOA-[+b hg)%#KzT@wZ#AoO0 'XNN-dOA`ں0L2V`\IV7_D;;֓<:|}m$pS;< ~7ܟPZӼI Vdžs>mM?6:v3yvBMV1_i_%rΧpPѴ`ԽO?O-2{Ncm?[]ܺ){ZXh/hLMSǞ0w^\dwlr~/{T@"9Bz iBYK=4`tUXlns}¼$T+A}-A kAZtH?H͘, {l$ȿJ>Gʣ>r1\Gbvy:fCޘ# zcv-{ 9^e}G/|yZ0O<ݸ/9i|.fB۳~993`Ǚi؅9?} ~_ ) =v*xg]=rrMmFlb3# ~/c9 xޣ<+=x^#W6 [GpO-tB?wG`o}Iyk}ۘ0~< Ϸp7\"k}x7޿.v\%FUw}KFĜlbyxm?Ok'v =DwڡYU2rSiX89FOT2\(H0 UǏ@z1h3i¶1y7b8w͗S#m',߭-k9o˵l'Sө 2[8rONnPE$eP%0o+<؎K}tؿX2';25~>8 ebPWً} *uy$"Im24 kr_'2(XysEߘ3IΠ\4[d/}ybz~h' [U@/^}``1EK,)7`ʮϵlNsn [o+AOBs٥$Ƒ3.TqoodU>˖SsyD,ӒC # 7sEg>{}<ϷJb<,G }X7خ#aca\ h-sA6;}0D7EMC.E6Ͷ >00lo|vj vYA|òw$5.*8]{S*@@KH(ڽ30 ӧ՛:^ EW@ӣ_tT؜_ܷ!D90H fmI1"tBmr'04D I>ܻ*F#ةO^=&sqz?|7<~h}){h?{|ldN[<&~}?E;{1c~x=`:!-C=~sr;\uOSg7re+n$گ+iSqAÃ3u lmfvsPgf f\8qG>6wJ`A}z_qOQyqs&NCdUsNZ-q)(㽰:gt7dGKYQq"16.B;Eb*pʓP`t8ܨ6v-\~Uxee{@"y hjMϷ@,"S|{dy>?'5Ժ(JAuCnӺ.h+7 ~t+N$'rA#/y0:d<~hO"i4XtL Žڻ_5eߋI˒vN|g\#`?mG9x/c? _%<jΎ9aa>xqÊ5<_W캥rL>݁~6Oa}O4Ex&Ǟ Ԣhܱd? 3RC4NqB߽ z{smٔ(ͫ]@et ۟i:4{ߋ68=o.6g6Յ֜vbN6}C)QuTS6u2~|{qhs9UzYO%(,3:+Ry.cO{0# ikꆁQ~}`zRGv SFRu}q&iIa~y8A[KG eZ|697UW\8a5cYL>,}=7ܯý~0ϯ?m-q~0_Ǹ u-&ߑ!uk%rQy*/xs~Hϵ;W^2-Gm׮%ཪ5'/{|nSq#ú mZ4&nۜeCbz{v|/&+5qޟ9wm#>Y_ :` ,b`=ݘ0|Db畈=_kXs{N#p}%cFsJ56Xu4¾^?~Ow}$@ˉ쵇QD7 }{fJJ/)@#$r#FĜ`>`͆řgV8'8I}7ktO6"`!G첵 zTlʹ5iEIM@QsI %QRp]*PbꏄߢZ()H@tg}L_<ԝ _ʟ&SW,4(^ vo E"%6׶sk /^׮ cY$)%~9.~#>c}܃ﯝ^'  _yֵx3Oa~﫩ֻМw`;~.0^=fc͈]s;mrE'\?qnܧQ 4ޠ+Kn!tmaj]~NJ[4EƷ7Mrϵ%l؎{n)}u_mmA/Ux:%Z} {d<$'2ۭו O݋ oV2ٟQ{trਮ*pZor6UZæ_>lBY6 ? 3o[ )Z@E|.,(^:R &-uI r^DP gk`zﲇ=l@wY\=+0-WNwA]4}ԧ[\h/߂Ŕw5Dd3g&3-&S[xrQm$>),#&+|p `? _t>#Ko__دߋ x~?8D]Gub :(?q|:#Aiԝ_]V+RG*N }(UZ$ %<.hh1ňn_=N>{@$伛{B;Zվ?kRYuϥQ`Ha >?#ـ3# -\(k $YTսyu:/+ *zYŔƠ'e w~ovJ\m͕GACթ@ޟAJny8 gcj*KPsꯢ`"LE6_:56 2S`up`BQD/sǭ6e=Nc:^a^'X ><?k|q;~50b`uk a]ϙ-\>;󩸾iqxְψ{O"_&+ԽקFSWn,Fo~vmD 2H k,W"_L\Έy ˀ]v7'ͤmI^@~:%}cvVwݙu N׻igw=pݜxw4?t)*x4█7}ACNpDGk/n8!׭ςwG` 㨑g!ME"+s9$Q|3퐨"OކZ]UD^hĉAnb䊫ED~)nbѭU@gޓZR: '_B>ȵgE̥ng]e96F fK闀!7$DJD^-Ae0wRg@:lܦ*QͬVYB )=ă2n?0wP [W;(eM5{IZw/*IɊ΅>`je> m:<Ц}Ǐ!!$2yc̓<3ϖ|k2*q[̫J]o_Y늚?x=s"u :~)/ռe6_\t*}eݐ_W+?YԥTMd^_M|MSC5qE*T\x Uy/~Þ?3/;We2n^c-Wc>Rc2׋2wn?&nSouR4·;Nip8{[~~go+yƺ!G?6z^wU\e_)w]ho8oiܙM^kpޮ7۞݋We7sV= `=*vZz*->L-nHͧ~$'y?}CtqO8ޑ9TO^˿bG7+x_ xϿůw˿lU( x7Z}цv/Ѧ }ux,{onO^}+=HQߏھ|כG9zr~_.'whrߵ_mg+'}7,[۵mղxjz-wK[qWU-e\\vd\)jwO=qz¯? OKT(9e]8> 㺰Gs2ΑxLt!NA~#)yIN4SgOYW'?|*{~glf r/W~V?ݧANGb_ۀi]KxU⟷Ɗ?qjh湯m_Tj'N\=Mn[p֭}{ȸA_XMU}~)/ߞ/AmmyIiau+f~f+Ak:oozK[<|gsXj o^"9|Qi[an-oWpe享q<RG]M-OX#%{|rɿSs&˸Iܯd#!O_JەwWH/2/~o5&~K:\tqr9:3Nd)k8$om}: x}ӬoeGP)⢿U]5 i[wyŧ(7[V} *8Z_(P`j^j}KP?W\y/]a)^:{NG|̈́.ūn߾֪>l[hK|~͞Ľޓt7#O<;Ρ-kmzmk~c^+y ^͗ nʛ1o٣V;^XO="M~6>3~O[wSz1U$W;O ŷy@9uY+Nǥ_îO>>u2o$#Se<3'/+ٚޠpy9}O^a>~kGg=?^67V Sx_~ oUkC?.ů[zjwZy[Kujݗ<W$;Q;qB={υt^<_տKM.oZɜ?Kes)/zoeto+ry{xjrֈ=۰(wʵsxMx}٤+8ypU ^͞=zϝztxy {7+cuNѽm2&ó[iUf}}~~ol_TV.pj~ݝ^s]j?U^Aτwᾦru ~!|srR>#Nyt=qyS9d}y$mwMTy/:8OgjJ`?(1>;PwСn/UQoxK7~; -ױ?=qk~]S:'ls4k;?_FsoFސq զ]#a%瑜'rJ֧J|'%9<ԗ r(\*yupqVk$ґ>wOenQڇ+:?_~z+.h|MyN}؉>Vvpƒ.Fdt|jPvr|WZ]Urc.}ӯs:RGo;cgxٝϔI^qx>Vkfe5n |S'nKo1ߘYbNA=qfkfOey/t ^whMxACy)3ݛ7q}jH7uyG4ougVTֳkxdGy2͛pUߩ}(F7r}G7 ׿uCr~$H7sFyk_A^g}1gU後xG |Q'n{~ޤwCsRZ Owo4Bł;P̟voPtO]P;Up͟KjI<'1k< tA:Oq]8/GRg*:~4ɒ> ҟgW㥅[}[/U9b/^=VvQ9aGr;ЁUY+;M,|.}`囶WOr3CtP /'kZ{8}GMPy~{ߵ`X| /o˲_y+ߗZ^t6eo$xɮ~]^z] /'f{Wsf\«sS ;a9*w[zuy\)-+m30+~iCO^kkx7t!kϿoe[pfm9г7o}vՔ[>S.pJ%yq(>4eRO#aN /Itx? -O?8N:בL3}Jͣ8-.AGZ{e zɳy#}y23:?~Ja'>?wNgL>u(Igʧ+|':_9?).t'v1GI'K>$ Rg9.A.Mi̖^[wXt/V_[U[ҩ6~3O~^^>gMJ իh۬ŵܹSW׽K8ȭ^៛n]#G-kS`#cQKk}^nkx}-'ι҅KCy"~Uo꿺#t_+KO+Rj?<|/%q9<T=2o1{P>ҟ8Dž@rRQ:lëu[&u`^gD$~J}kK칤ѻ+U9?V]gJ*^[m28_o6K]o\qBK<'b^Az%ok5Y~Cbv6*g wb׿zMזoM%^VocxC`^~q;6[G*<E^ܞVVy?x57aCx2džׅ[{S9s}:SO=k8_b)oo͚SwVRdB][蹶|'k5}y4hr2ƭ܇x- 8.G3H>AoaBx|O )w||/J糥^NI+Y.}v{ .rwyW:앣T˖>WGhzueorƻ +} K*<_O8L.y~~H?t[;eSgymC&n8<_חᵋΨs'Z}m7;![/[FXC5/W+-z^w{d7Z︩Q^2t^wSyч:mz/gWQzO y^?k I_[76n.ؿdŏnX7.u`M=>*i[wvk_q)8(?W79n%^KG ׽#a^[ uú(=](Wudwڲnƃyq+FtH7NٿV7WHZUVuAq+Yzv?&לU<ٳ}<Юe~掋xmڠ<{]5GzG`FF;j~JY%w&^=+:SpS:;ν綧:]4d4/7}F. Tͫ{'Op}tO̹sw^gyM^קvm7_ЙWG[棯?!wu\^a'ZXoq-{kNݵ~RMmk蹄w]3xկO\'ݻǺ~gr-&j)Sy|̩W[Y 98Lm8y7vSsL鉍xsLymo?'[>ֱƂ-fG5};؟5oy^vF.P͙EvO]['+߶h:;طuqy`=}^vNw{-gFd<\b'G4t3ʨ7*_C?gXǯ9^+5|qnjgFrv\oZ~˝SmY'}[׊tfYy\k/nKXҗ:h3Z}hˆ7yF[5e*?:OVq޽X^/WoӮ|hyeeoM54OٌCǍ}>Gyx|<[˙o٘O_rFύo7 ?ǯʱ;ao|ï÷=lFq\ŕdSrrҊg>!iFݎEلv'lQG, n̂nd?i6k8{QǏe=kl= 6m]_춿Ѽ%W0ͯsS9>|~Kf+[\|5NOoʖک﹙-ӵ_j!ثJ3Zo7R* /u)jGmb[_jmα?8^h==v=eٞ﮻v= zm[w١w ;\s/SQhω| ;ê.eSt5akoƥ1fNmN]^Nm~ag;ߞ?GЯ߷8ồiV 9Zyڴﲋ\oaћުoLXC봪ӟ雚]'?lh}F]+Nz}Cg?/̖ ?r=go.oՔMxmC*7kX=>`ͅ7~acþlZ͛JLdK>v뗝-ZՏlѰ|'>y'_߭>[e+r(c u\=>5βoh7bکlϱ'{;^[Ʋ{TK :}3­6u(uy3=̶~MgT#؉yW`ǬZ{SreGv]N58wTz..}L[icm/Xs~5} ۛ?̯=Se<<,KK{5Cx~ĥwxmה yu~^tlevϼ#Gn}|ټvmcGZڱ ݂tmB[/W7Si^s9B~}0o|e`c?/WpBϜ؞UD&<ǺkO<{<w)^{( Wn[xoox[fl̘ݔ*uP?P4?/s?:W[˳G+Vy_#+_睼>_ճ}j̽xѶ?8 k/5w^{Fu{ؓ>67\]^}yFoJ/w4mIޢ=m[XM(~:^1mjRd=MٴqaFv~g}jfɹxQ?7]=6㆟r “ma[OI/Uw,{Oi7mT6狚}76?y~yϚK*՟[s.YksVmO׊YdN'c{ʬɦwٸ}|wlB#c{Z6o5gkhe?ͻqf7`֌{鷧Ϟ]4Gaӯ5ICs|²WO,V9cϾc+T.]oy8lCrG컾mun1۲zi9evmC7 [f /;f}Г/7ʫnᚭӹ:ɪͧV7qMZĽ Z5_5s^oZF7YJoW]Bzk^w„7O آU V-6k9oGV.&sֳe3vk3u#]?u/Y*ov._lن+} xrj{fC*~~mGV-cُT0}mTꖍc>?eZlF_V~Fongvc}Dk"V{>vۄȀT.v(.^asdka|;تMwbhWm\ZnM/mV顯1]|+xnSQ}o^t~vyo.{u䯙յ1nba߳?W 1MqEl֜CW^k{۰~MK=+|+wUY?l\+dXFsKVj-kgxb}NuΚl+T3BnOӮz,6l&ޠ 3WUt'Zwﺸn-w8]y;>Vwo5#Sdۛ7QsJЍQʹʳ2n0 W?Բ˿l.6z?ju+ؘ/lna3NU/a:196}W_gXiƦ_~^l5Ǣ:Ug g ŵfٛ%޹l?:MnzfluJޛis{/ڎMsO9V.5qw}3;sm>x{?峳ybͶlՂk,-ßy[{g}ٜ?ĐgJ(~Cgl㽏=5%[SLڂmo}Ý_e[߳(xn)֏^K؎zcٺY_[ Y'U^ösmlrk?Ln~\[Ji/){ ;|Z};}3[~͎to_+NRR52Q[׌%v9+jų]ke{5_qV~VJkc =ӥ|&u|R^¹;M7m?o[q݃xQgrs_my[*OBj'Z]%ןW\khXxwv[ѬOvdp:a sׯG` zvs 9jyqSK{f/ ⍇yk7b,˻>wW=ERd?lllԪC/VwT+?F~Kb^M.ڨfy2;/Wq67l|Kׂ3w/Y7~C΋GzE\Ҭ-Qe6o#쭒gl-sy,նml^|z6۷>\4{z [}scbqO<ӫٴ?zl'lvfw[0ϱ/vUl'ylP~U=Q02呏7؜;hE.nV}{6c+fOnlrѦ ۳Oue?db Jp\PiNJVמbϖb|Ee3/~՞`+]}O\3ߙʎl;raQeGȿ/_٩9ϷkVv٭GGz3:s׭~cz\ۼXb f U<96vxg+\xF <탾>1{>~͝( еwܒϻȼ/Zޘ'[Kй] p÷{i\Z%z_-71x]m'Ujْ{jӾ!|nfl{^^*/e+r?=BE8i/?Μ՛hڔ3]xGI&ǒɗ5J֭xoyۛ:͛ ap7kSd;Lyl=쳇NgJ?6jY<etdv65on@0gWwTUuŢ2G;/}9gㆥ\oFs,C<Ö3qzlt>[sXγo'0\ql={O{ծ2?{p熯ޘ}}g36selX=~[F`,硻a  sw٢>~|-[ô^4 lvkʎIȖmSo;s-oyH񷁭ogEؗ`ي-:[{#<67{2ei멵㚟zm_zχ|ֵSTcmy/sSDzcZlk6;T^dDZw?*n;AػK㷱L)(;SQg3G_ݸ/;yWfmtFkh5mov~|C_|S⳿)^[5h <⟮~]Ɨxeޒ0 >ʋ?ph̬0/пRtz^cx:=]v ^5dW>c|ɫ{_>ˍM>Z7'6ɶ7w%֧y[]6Z5I/^wyݳwAm[8՝Uwڿ2x<Ὰ]m=H-ǿ5Rd m>Mg{sỵwW\~i-/SgzAa3[k{RY맦:_5zǍb3+J9^#;^M oY>ۆg]>7|]jnke#ן=R6_Ilr߾{6s]t̳^]3,Z#v}{wӒ.l]XS-ٗ,-z w-LFk"[uwlV۝dKh1\focK)]ҿن 77v5Ś۔h~e?YڴN>r֝a*l{$Ylӊ^٫egmwڗ~$vq/kKyxkF3l^}?*m5곙gKn{6YtX~ے3{oH6f3[cc,dZmjGJuZlZyT`sZ<6layfX{5&V;cßJSQ<5c=}Ĩlc#-}wݷM,s-9ly}y_}:%ؒcR66ڳn?d6JMsIl˿|}k[{e]緰,Kl}ư"6-`3[z#gZvaמM.6۾eڭmXfWRܩk]`-xE6۠^oߋ#kXS^zr۞d'扒Jﺕ}m݉ܩsva֐'\/}_>~s(7O2t_9M9v?Uf)Rg,-ُ9W{`n8X.͹{i "zG>x9gZ]cu;ݬޏ+:Aް؎(ĸr/^[5n^Z5-9flKi+c#~qlk^9qϴc4ߣ}S7yg޶S{*1o>5k^dc&moxǰ{u3/y43xRv2z].aW5lŅZ7zG_Ukd4͆7ѡyآef:fv/Vj4%2v`>hyز^׻%)Mdr_ľygM~߽E! ;Y-Y{웑7{lCo_w>[{Ma/[Ȩ:lCm֎^}*MWzӅO=Ͷw=.X?lv׍k:n=^Y~~x9mfB4ڐh M)Əʨ&Sv9ىퟭ;unۮF:~/4soihۜ4d/?g:ۊ'Kssc5ؕ/41~ܹg<Vk 񼷴Kyy~]T 5^x_ ՞§lŞX1ߊ8w.%ko(]6=czVVnE^i5Ync.77W R}鈻}@+Ѥc?;|o81N~{y?;.?SygqtjM^UK]+:p[{RK9':h=sU_R7P5rf--gZ#k^YCw^?mAϦ_t!1/Ŗ8W_/uM ~oQ7OakakakakakakXakXakXakakk8k8k8kkkxkxkxkk/C״W=~5+BF٭syx@')hzr}ob{]Odn3ȝg<8h`>+7V@22?r稒=TrI? 3ޏym_={MzG׌O`x|>isO;}Gތ_RK?X?7쒱,~/]?qA_ϻz*sWn{X׵WT뵌[G45cMZ&~o_=eԾuY,.~_m1 ~{DƆm}W7@}np]>~?;GkCz̟9~2פE2yc2ĿϖzLƏ㤂-x鶌ok6glm5Y|mm屟=?1zS;WyJ2vğÎC?t9awe?]-1ygw?7-cw9^QwÆ 3~?;0@ ?ş۞j?Oe3ğߞϚe?BpɌ佳_k/h}_=?{yoWP(coy{}ɚX^K3þY? ?sT9eǧP[ʕm+]rf\lFvkiiQjsZZVô7Ux9-鴴ʝҪlߑVmvZZii ii:McCZ]Z4wfZ_(-д;LK^侥Yk՚VCMKkpOZZii&ҚKKkdZZZIKk2-Mzx%{gr1T+MŖ=]w%7y %zAzuOΕ# `n㏎VnKvC8Nzt ?732ujT{@wuۥ*5_ޏq约#AzۧoЃVJZ:ŖelzU-mj[afj]nZE{نht1 6 }Î}DOwm#t6ۓGMu tѤ隯{oٮKw[tiϠA1u<'oٶOlӎ}Mǟ;9n쨓n4'K|͠6׶MO)ta]O:rs5N;r=ǵgԉt}zHh%EEsM&Ǫ{Mӣ'Kn9w6M=lˤ'yٖˏxaaGwQߠt,5C7kڎ[nkw5m˦AVDtnkiz94biKjMNk7}NGpԦu'~\0uW#7]ô<[ȣ}!Ɩcj81 1ӈ4]ȣIJw'ZY4G6 t61sЉ6LZfM41iqiѦAIEokE&Ȥ v1ӡظ[=yCΦe8kʧJ#ȡqyt4s!ڡ{{oOn?B56Ǧ' IM7tF}Z\S~Ѣ_ďؠh'bG=3=^:AOӦMݣ̀<˝h2B3׈Nk:Vu pz, |d |zߠA+']i%}X·\3V?og! A[= ąÖh i4 ]2j&m7KbK$VԦ9IW!9\:aNU |O% [E=2 p*,{׏;CO+fB'P3 }76%iD[,My(^vj'b;a:4Ȓ!@e*A bz@Z!Ң0Y@>ŔBd"rtf QL(@נ ^VFב1t`_C}khhTbZD@ڠqM-Q-r>kw:45!`@ϔ@*yGm h $@00 y-`$^;-O](VX 3@( fm%Z4_ ;`&r5~PaO OA>Z5l4 `ħG;:j&;upX)@ -ᝧcxX#=?wtY^ FF2H$@N )X Fl30Zy Ft -\+LcՔn`COBzQhJeq>gNңM=mO?S4+3i$Fkk)BG؁WE ~`>l yox 3u"hnh|-ؙ&ݞtLY~}yGH؀ 5!LY \SxpP ݐ-Fvw5;( AKhvp-S°.U4(@ʣAS'D9]$,ɵIi_@۳zH?S&"ک=,8$ԣHD`^50(Y Ҹ-[< z\KB0:Y O̓  @NҽYX0:XEK$i؈t8!2ƮA+ԔJK-,`ڎ"jȃi{1{L%9X 4i[Nd|nqC'&x|[~@4"lZɃG㊐7_Buڅhw!bqv\A:s)*ÚLkcłof?ph$N'=)Ҝ=@oF)B̴TqB@6FQD%},?ª#T4iSoa5-w:BG&!MbW; Z&8y=z<41m!H"mG)H;/0ADkoF8yOPr\䲐6AMEc`PBܐ41FmD 2FM 2t`B SQ#bB,/Mk¾hXKy_0C#ph+2vwfX>QD> c%a(!'2nMrTVB9K7Q=7Ay!0-d@:- {adTӒd,>R7,IѸ#d|~| A.CtLV)WZ2sA&my,9TrТh q О3` JsEHK B[DRH-ȏ<4&)FO/q]#5[0Qtu #D"SO L@B\!tHȇmIw:G!)ǷΎ*P| ^cPZYEhۧ,^%|# ze0-ׂ{v4FIA0..\(I褧dC6g4j<(m䗂'iI`$ 6 Q%3&@d u [:KF(4̃(VxFMȘ3 ۔fȯFlvn  z/|U(r&gz!/!Њgr܄Eh船b30+R~ZE(&}5(m>ށPQ%!y]jO8T"@_ĚS@)ZirB&]"4%scҚH+PE=Hx aJ6+Ub0j(8,:cM{9~$j<=̥!#CЦ@_O\ItM B‘?%BK(dRJ _IR]" JP`ShtdhL\*(:2e_iSD͈r+z4qУJȃ ݑʴ/< bʥbAH!k +YWs5Z o0t,~#Y',? z@A6rII$66i3rAlyyNkvG$ASDiBڬ-[ @`'H0b\$(-7$2Pፖ(bh9H B .T:#28䂐0EЅO&[0RLQ~TJوluhѺ12I؉t$3Tx#$ؠ yDLQXH߫D&Ky1+%< 5=x6LB4}YrkHx+bJ JGq! >*_ m!:}3p4i i{6OХK R_Ŧx@ i AH& m`T PRFJa)xwFVc(htp!=IZ4]!ۤAPIɃ"z$(!##NϞ@PLWb*!s: t`1 3E]/|"h@}YFISO!W5Q+ e!d$tE(KP>:#GFv A OG}(E^k3!%EUK0Ї ~!!+t"K"V;W϶Q@` diJR Ԉܥ "+5qE"x-)INBF/+]H[ U5hX(BE$:[Xޡs <Хm~@y9wrJAݡSK/+=BJB܍Mb%3 id o\KC3Rf##f"RJT%IRlN 9m;`$u/~LHuG@""4ja0(diP.!u2O̅A'l? }ɢ'A g`X8#wLsBI‹*a( Uү`P<'l#ph5_buBL ;f b'R[d !c1J=d1^E0ZIEhy>ȘhH"j%D2L`h[! f3,H(dZ[z Ԝ-զ.WC`D5i\Iℯ!"CDBZ|B4wl" VKhDoDM NCB#(G!`@hKԋzK 8m iBRd4 },Qn:H/T͐gM0ĆX6WmCKPHCKG|4 uU` _$~iZ/C*1|4D#YLGp >Q F`eli YNbE!(Ӧ+A͛ 5Kib":f }չA?]2[Km%)@*( ۀJQ"WzQF; ^xK ") ~RURxh@JڴB,* R!FS7%LDb%SWrQFlSq|CAɡ MBaV`A:5-ˬyKYk>N*H%lLlbGa-r=:N+1G|L5qC4(`C$N zBzY2{ Z^KPI(0-7ϙrL\yTNpET "Аtԓo1>b[{5 u<E§(h4 Gߍ'U9i>I pnDtôZ >aAB~8~H)"C-GUvel&!p*RiPpƢ)'oY^ؒV`Z 8Ah7ՠ/SN""<.@GDPc/]%+gxHkd(`ҔK'@I bkG RG݋4iQG:XbPRˎ' R3r f !b@{QՅ}=`-xJB;J`ئ0l(&:Y'M}9`l:^F_4n#(ɍ(M RlQ!3`5fakE"E4\[A(Hy ̶"ѕMrA? 鰅"xIDPBt(U%HC G-*r=¶J:7+_r-B(Y:mOSdp\qrRZd,eh#aJ opP?eP PJ.s:xA- P)(!NW| K,u1_ zWÞS}5O|`z -VJP5hYF%Ae%6p6&!(uDKPy=!(kB0mߺm !V /5dp4g#&m6Vwti*i|[1X 0t>Wdy8\:;ĆQhbU =kp`*()B)!x15M $ُ# l $K+"%35H" StbxTnmVv'Q5#YYՊ6AŃ㉿ԍpbIXATa%+r:Y" [/UkQ)YQ]111p0KϿhX祛z~*a Uhá4,;@nX'n "C1 |yg!Hʣ(L0@ %1J<rRA!XB_pMiIELkM8n_ r(̄ϳl.oA;\DB$DBD"vE0xYP9_<ОMFRr&ր0⻴#h d%?-Ԑ9FP`u4O =hb2$…e& 26F`K$}g ?\0z[K ΃L`ne⁙0O)xW;C#1oU)11a?pfp))`2 cX8XCx[D$ T;QP/+U :hԼ^hp)FWj(*U 2PPd#₽ jKЄ6VQWf0e&k.VBƈdlPaH1NФ¦;|"HT1]UJV'ʈv8IrHN{`i4}؍=KP܈7GMHk1ĠB!]!  ::H!"H/#$ ;{=6@!a<:ز=e:mEB1RExՅe~2 &H@(Qdð[0 ;@x* a.Dn{L5t(r~W@Ƈ2jL$& Cԉ"Hl { jpOx m>ABEF҉|Z -IsH X "kn_pR{+8*2.N3 (]l%4V< jC ]*7RK`!Դc`l{(@!5<j*)N O`> Cb 3dAD p0e2mwѤ@Ǐ- "@MuX,/` ~@>T Qͬ)mGxʌo a CE+|Í`iH!C(\[ Z^AYyC7G؄,@A;,zYk8zs 1&-# "YS$CчM*'!G„ L,@~cQ9XXPc VǂN_X1jvU,,Lq7\#< +O\eTNHЅkM>8j|'wEEF 񬠚" =" щ-8.#/̏CM{,Ӱɏ?}$A: "ED BV/#Z]PUU:)H $2\h$$/UkpJ_.WEQYވ ;,F pMRv,y t D+,UJ/Rt3h2er(A"y($v&RoAM&^۞ahDlQ[†87s+ȇP(h 9LPR/܁!'s|U0( 9 䗊P5 9",71i&՝ ,(9h7J*,A~DKи8ksV+Ѻ 4w ;Z!CͨDC*^VWitXS0ǵBc HR)뉄Dz&at!`8{סh]B{0O9P%':LEJmFќ9{^rBqMy]%,XK(lCT:r" 8ȭ(Tr`$C~GvDH^xFiXnt R{GHV)B n'p1ᚂ2\6PD;<4e ͨ0:ZLǘ&,NT)/CDZhwȃ <ׂ&VAC4 A[6Hr)Qf,sTt)i4x̊!EeIH(ĦkPtSmW ,+UiF~؎1X_TZTE &n٘.hKV`ۆMXtrNHb4jpUQDnۗp2"zAoܺ\k.|4dy"ZQnZeoYF׊Fk"SJEE8ex]cAk!Etn,I8asaZ ? Ԉv&氶*a#vF8B+SQ%Y&aY,ksS}(.o}%xGHI] UT"[g?Є%B$x,ΓUEm,i$!2f0@ophՊdh;mJGM=aZ v] !h@M)^30}YK:j @;M 7tsѤߠih,? DZ(NtSdԈl-A%H۴ehmʇ,4\J X :Є-ny";υ AUš: Kˣ4 og(-Jkp: LaЛpn8C VV PE*H0H$L-+gy_G-t:wR4 6+ t0٨O?v)o2.4CadsAV5ԏrS/(C*P`3AR@k_@/ᶫ6jۅ1r _ Vf"0mHAE(?ЛVZ4G ̇-0tAQmf$ҧ"g*,7( |QiXbRk JpBue -Km3㱇pI1o,<HłjMm`%b7U_HL@ ے Q?2Euw[GB#62$Kh\ E{Țm~F.jU) Qd)hq+E|Z􉢪ҥE5hY$#dKEfV' Th[ќ1 ` [eAPD֬hOD!8VunBT|Zm[ SckORb4u`@D 96_t I8ߣMdD*]jQdC (JjKӌ[ %~nKo(&bBON <mz+[AJ5}%ۊ^*G Lr 0@^@%MgK:dt:4BfU т z4$7e _>h(4s.LX2rZIA#aв_hB'B 5*.WPU@ Y51aUn^(pc өgJJ42)UH" !h)nD h &e T[3*6-Z;8p:Qҋ`#Y8&ES]/ܘ2JS`y aO O e+o*`ilne1^,)a <: HbC FE4:;fv$^@8YUE!T,]jW_K%R@dc3ֱq[BwJ^5H~Le:.@k&L DԊ.J1CT6n/ O+e_acBgΝFo8xxXPXwѦhezIHyt3'TCJ>,B35C*brݸjlBB}C ISlj74_FiĐNdY]e/kѱkxJ +")} @,5yeh)4H6&f:26A=B Nh۠>Wv Ҽ2ؐN!( /CjH7AQIԅ| nh uTs@DU𕅯W_Ոa , Kcp+Y.ۂ aJӥ@ȊtIrh0F.:)y 5s)j֧s&0fnbu3%OyKrJ4vw xnγ-5Cr Qψv(hHTEj/dT5 PhTBX &-D@ fPF$T3<Z? aH9Rẍ́LfE? -h;'d`TQZHo-:Z*s (,eh"R6+IYFhCLG7d#hn YteH!Kհ5sv/DQtG4 םy 'b#>><ґ 6,+b3҉&:>{u'Kk"'كvYDwTe~`MEfG!-$VEG Y)?b(QpRƴ/ً`ņB!;Č/F^2-B< Wu?ԁti%]rbM ť v""1 UM0 z:4  Ճb /roTd(79_YQkdAm#a `E]k2Jظ@fSX0d^tN4U-BleVX qh,+وVA.X ٦`Y> Q> Y(HT*S*@X]` >w\)|Ǧb%qbFv#ҤYmpKmtOX}숂.uK$G/K4yQbr :Df=\ y0*iaBp!Sh|7DՉ\_ 'O<1H 00.;FjDLQpw#4eTlV<0$KG,Ѯ0w؆0szDju0p$f YXY >wFPK\R2:M+{(ĈeZ0X3'b5O1)a (u/(-s6 [d^R@5OQd <dʓ{I Y!.SNzTgTၨF_&'Hh* ?B`cOk߇VEAq-' qiKЧ}QP4g $ : L.:MȹS( U!<5R:-̨TErV*JH S6Aݩ:vwy g;PQkUE,M'z5zDжU$k?T'g8uݚB%43DBiBI@_H:tΒE'Aq0@ Z*FGDwPPZ`hX ݸ-R;$"Ji*e٨5S30[]x\HEڭh!u3T`$be}HPW$dNN@ I6EȞ=ef*@NPPi$uRi/< QnaK^@{./mш>(hN$nv B!$mzzP'pc <NGrU>IA#i} KпKsT`h%`:T ) ςcGd mY 7~Y*ӊHuKG81(GHLD ,3y/ 4SAШǓEi`Fʩn@U:贺ۄ!=H# *,cCd'(N]I1LJ60&񰔓!0:5bS EX`-hIh_3xg`>(Yt 8iMA{-e%1H_: NhKIr@G-P@:;TB;<]@#9,x]SE:( vZ=qPPm+\t /2+h#xr MdkyC YgYc :"ReZo2r8\2R?QH~I?ڨ7K蒅芈,5qP,UCNY[LF"!Tt`:QT2g;ݺpN! Z^ B;zE&<E1hN#]SP*=lVG44N/:+xc&[֊npa0FV{n o6EN)w/Cvm)`{Rr{3xܯ 9zN.v  ^-?q 4 U~Nl:7Zˣe=L})MX҄P:*eRR@EVDF&/@"dG-w(#neŜl' 2n@#|leU;݌.dΗMEM+QOEn7tXMlzAG+.-Ĕq gcO tطKUYdB0n\pȨ@ h:N/Zb=x(%d]4J ȠD1Tv {jy'tPZAɚR bQ >q@2U!puw d@CKYҼhf貃m WB T)Rᑂ` @Ot!&AZZA{몪@oUқ {#>$ 1BL!D >p6?6GS:@9Z wOh\8 Ө."+J=4zv=)&#Y^TiPһ "[Zv"`_bߢM2|Ѧ$#;Y07Ѣđ>sa J=)uwhXJJ89FW^1G!B I>} ?tC(pAa<ȋhx/* _di{/BȖ/CE^Df@-l48?RO4H^>:&?ؽjPbeB|EA 3;WK%l|K&29BKEhB88h=8ޑmUiaa&-jcKR" ͌sGpDMp%d25y^":g:R9(!fB:ڢD SD-ν耏R^m4i&,O&+@1bE#EEEpꚈuSjE mE:a2J4+B.5FpYzP%CgIdu`r b33hKdOK"qEͪAhMѥv֨}4ˎ+ Qa ^TQi$3lYȢ!@quAa;~0FC)RMFiThVh _gdR&!ЋNCCAѠ J٧7 70Q3i龒Y!;uFŽ)6 uʼZ#\= 6թPW¼ ( VY–]v"1@ V) "fe!g…oЖPGQ܈gypd Mu?%Dey:63:x󺨊PTbl;": U[*6 mETҸB)4 7!nY+E3[G0!G!; Dxh: 2 z( Ljm!Q |<:г[?`tnȗB3 SH@vfC4B5JD  }+e&:ܨu_0CIaMbJц \hIQ*ʹ Z"hN/#L|.u6 'Tm'mhaUH6L 2C&x3q/hEMHpc+ ҊAPګLS(]p %4'fLaUSMd i4&^|&GÅO!i4ЀP.0"ih/Л&C+}mPkfV-,?ճ%;zRC#3ꊇOs>}4;tNfU?DZXDQZ%CȊ&^ Q&F v@#ήfmSk.uN0\=( MgKPB)) Wx9w,Ri#Jj}5^"I2 8M&]Xh`-"P[ `REaקhYrY Z2: +!|ao|(FTGQVA# OЁ-(4lD(ח5YU,m :L_lmlh%gh#>hH3B-Q" hH&"1x{QxAxa yV Ȇ`MbG8{=65sx†!6 !M2MC$`tSo>aG V6z* tRP˓ τ\ 2)*I;aZ%Z WoM^PDkL@&yP$H :|FRކ>COQP0""#&gGAdi5ʾ#f$$²*(Έ2ztq[0+!8Q殑:]Z9p^0Ts.KK#r;t[vRлEd _b+66I'=k@hNPp  Y ?fZeK:AH_ fz =c'OFuW h ܐkZJÔwen }=BU Ǔűe% x%<YI#*Hʃ(:C(#Ti []dѪKht8.ykg/l["5:X::]%,ȶ\czh1x5XP/ =a]"K*R@-0 Ȑ_ I4^pl!4.}`)1C4|yWȕPz!rqzB74ea.&~XP6mt q?.j9Zc $ ,pa#:^bt% VnJMT0ps2yx\ 1'6^;.ߠ'E;`Q*E7O? rM(6B7eð *D S Ux6X"8Rd=7Mk17n-+Y\hNՉFu1.0sDVͬ8ѫy:4C!+dl,4U<7Sh#=ʲ Zm?#e5"p*A⁥dq؍Z 6K>:  4\2ۈHJr3m.Zh!'Bz2 3C5hR;|HH࿋b>x:Nr]4Z.x몏 əJ~LB( Y':h q PeM=I-JPK,ԗ,0\bx-qH91B'gP :J+=xhѢ[`& tQxy4  1BK@}lP-#uLp' .L`J]) xOY 9: ]8<"a { 0,eN3@ @Q~E+c_8*: Įja]I$~M@ h6DWu&Jj c4~'>-.0 KY BpɵUbWf꼀n~g,9J& :Az˪`t\@&8Ɵc჉gO,_QEi_QEi)JC?zVhPZhY6%h3YNqRr$(p2FLYg,в XD",D{jZ*PDaBw-5ihu],$GYA^@j)EyJC7i@d*EÄhLi4 /F!h"g[H  l[+wCX`fFƐ8xǮ "Ж#[E0#7W,L}Dɕ^-Bg$iOoTb.%^7D&#x,@Ja'T /̙P'NU BS$!oT{ qe5a'vzE eTt|G}Ne[ vXH`wX&TZ>v>G+R mFC'2mKNi]v_fxSdذ Jj`SI= W*xK`5c?YǴ ~Kr1U(  9t6G.D=.P, (s6H~<:О;(W@}( sUEjJjWDPteёD[ 2V+$e~2UI|F$myj`,k9RxՉDD/?ۄFh[oJ&N);64 -ᣛrFB-F ]Ȓ41UUjoRTO(3+Yd(?>@h9 #+DorgD^YɋSH,ݷ4/Kl1ߋ&Jv5mOUXp ]N*C8A`nD9.a C>@ B*hJ8Q@P6ڲQ6ïYB4X 4Ѭ֡|`"Z?)&4'e E A$by.ҴY JTiJ#-daSh@EaII^}WC{REP|CBE}iÅ[|Oo^:h.I{*hCmO@'GG\C$&a $bԴ /h5p#uw<mQ3a8^8jdd>`kKa@ dBs 94&+ZLͰ|WxdL |x$rE_b8\H lKb\8j`Hh sptز$+?'46h=ef@TȉX $"X)tK@M!a%Z҄gVFS[ E2WL4"@M>]Լhcg$1u60=6Ni]>@&9u91o*%OM1a /zQlj(ghi:E(B棻2HE5Ƈ{X%h^.T\an2-<]f0mERсV>YNX]Er/cgb2Baڤ::e؇맟\^ DL WшI.i )8x% Esi'6 L ltՒP28ŜNd{/&2V N7(DL^4#x¸YCgzGG32($Seх* %sȨ$~ @аHh/l&ZJ%k _ olp uam(T:6P1{_/r: >/ 9r1ŬDIi,`<na+B>x e#qBI4 hUѦ%H(pU3SɀYb[g471tF|Fh̦Pa eB2w/-:5i)0WYЇ lxŷT0=p+K-#{=g]-V^-hV-EVYtfDt"ݧt@FXa)a ʜf,L$׵UZh(X4seȮ@3E7P#pgsPiRPL*)VT"[ӈkHTi*/ԭB#ۻH5 N EtCCe'+WKmE{ln\!|E(Ԅ}"vUW513K0Bp"ˠrՔ- XLX[aBъ H-0D6>4x)"1[msi%%r [Az Ь]3m/A'4&=+[L K8'FxĚY2 pO 2!aaˇq-oAy5΃ 90?kxF D8:}PiŅ+kҾ fB6J쿆ntDii ABB*!D`lh\ t/Ct.,q#FQT.[xBLG0VRWrbY,;uCX*\KC4m9C[LrGoAE9\՜,ŴEy&ZnO`gc?s.XW;TY$ A8х&>aBmgw Tuk)2,#֗Y@* ZLfJMKoYc鑈+XQ^Qcx!mВl( ahOh7,RxD QEMd͏6I*!&>+ZoO0#RQy[qOs6s{E3Z n[0Q#G(.KuQݣzH#XhNcU,0&P|yÍ>a;N+pGf! C:D$.?=hB!gt! d8h`7"E>,"HFcG/ "Z]͸,!#Ƙx.y<ƫH)DLJ2eԚE'MDxY,%v2m^aG3dUjiz:hC:_8 JlBpm 9a  3#>&Ejzꂡ=P?zŅmF}݂btJCZ49(-7Q`9\@2LѩLfl}/E!uD;:<|zV̇L``Y`wH}mx 8@yYj.* C7aS^C/+P¤ S2f3@d8 В!9 nA } }<[batLV!#L0q(rCʒ`GvP$;Q'F6|]J0doZ䢂W;\/AOoއ=0 aV(f  vDh0W@9݂L:(ʇmYl'Ugfu xpD \zh*(PB)pGri WRh'Mر&R$ h5Z9l`C7^Ay .ī!<`j 7eG JѪU}#XX@4&ݐ)S~ͤ|`}S" 7vt"A.+bIXeiUȱ)o8 ))o'@=Z5"p?\D+bh I<  ᠋,t"?F' !IJ rМ4S 0w,CGp*R#ZsbcF7kTjGDAZB2*}ȀGDp׶б mR4TQ*É\1(mˁ*-B|"p;uѿzKS~+Eܙ2^ta2u z, D KGO | a.AM 8=3!N3bE3L|L[A&2~ 5,x)NO5(`[smaƬ<-F[ɷcªgJF8}$OZ]ArWtN~}!D(D]6$Rkʃ jh4hN8M>%H4h7IJBcѵ$rJyJf G"d2D.eF2@+ xYr#LHU^~Lc{2 AX"؞c+z.H xFJ: c$nBuKIF1V apo'Di4/0b0P;.0eT9JxO(\UױAÄv$a*tDKTPDIPAkJ?$`WB'o,=HP5|PP ybN/Џ H,j`n_= ^yTXa:d0G&, <F, 9! $[.lЪ M9 *Cc0bRtH ".eiC ㉼f$mebyG^/SF 3IJÁO"!!DE2fXP&(K m `顾м-j#hjt6miFbK!ET ='(@4mͦAuTT{Xcs-HG;Q.'xB0Ä͢rUvanA;OГBѤÈe*ttaT|1Dܖf)RՏ-^Cnx $"vǢۙm Nf"t#!E76Bl7D0Z P@&-FRX'&=If.\T|0QXPm#(P !*UE6~F ! ;tt,m^̠ȰY-_s/+Hk"b|D/W¬ <4 EiDx֬dDjH$  ـQTH0@u_L@Nj Tfts0vQ'c6aPb{&lL4 @wo"%5cź#o|DkH)n0; dt( Yئ&*m!2tRP?Z/8_4V` ^;0@(DEuC4+0B;7iov4@U}"IM* naJN氍S`Kt:Mհ(, 1/u-d  o}j-(BeFb0k pGXaԤH'_@/βA y]͢R A`1#Y(izJe0SD8J~ @V6MxLچ Q6.&;N;F\xX42VMt1tGuj;Sa /_LHs{ɪM!7.Chd2rP(j%)LQm)O=#YU RiDLp!Rha|:a9StKWNl)|/ |#`,BȤd!0,ψ(P-(A'h"PCer 5bs H+ Äik9j> ?6JA%z&PQ䏚pYCA'@A2x jD'%P]T,BؠD1LTBif)BX >.!+&:n3ɣp @va1g ) b8@iY5@B7y^J<~X/k.P-,& mf Y\ _?LJ>@ EȲwJBE-X%pE !ֆ7p~VɲP! {T@=vÐK\/I_;^z]8 J 3S$&(Pu 3(ҊDk4 @HG;DV<`2"~|i ;RcB1s¢|l#N#)[(hUJRI>=vUBT4]}%P>Զn/ E^"8R'$:_"yRiБ]&8 # M'(E!* Q '&-%^=j4@V>CB~ h xߙ{w2 Վ S zxeoбdB1W՛]CN{(NmD:4L;n2[懽kaBU/GɢGn}:+h04M3JKXA%cUޣKg֫'Xd,lQ7]|d]0Ndl8:yk#h YMXѠ]< ʹA!oHud;TIsk1G^u%B@H)oB)IS4qﮬӤuV~dI>hgP6{tniղI#gpЎk47G׃h |= Viզb ʂcVDїaֵ_#RL`F<+9B^ "C=D"9aoaI{XroG m&g uy+GB]6(F B[0O2f1l/ܺ* idgg?z.H"$$4) J HQ "HQPR)=\c3I띎3k9(:N4/y?]=tXi"@4k)r*c7H&[T\8FGi(7EٺC vOHw ⵨bx"z`Z%>T#9@$y-4ViW' Hs؏J^4 fFN_glq&U˯~q{rj>$zOI%h86l,ɥR’j}C)~<{4/Tzm'vTʱ[5 v&]%f &M="JLlF[K1U.]kW@(9&hkhQӎB" x*Zd )zxr F͚K[}l|{[@oFZ?)~/۩,wf{˦Grj28wa5Gm<<|pz|FlMh3F{mcͮwX#Xk11vL- ~pKRTDYOgdbA*u-QӭLЦSēIE1@x fK\q&PqO#L h:L}嚈RAꕇ؞aZ:baV1('3󴁷`T@qLXLQGu9yV@$CS4ZJ 9uUSTR)bSO=,Rsbg5A-R$SC=1 ,]Wk/ D2.oJ)yj {#篷 DnMr50%>f}FJZS>!ߢlOOtT8 gͯE ߑABb %v> wę&7*vSI/fveD:d2M2X>|682nc1*I)FMc4ZMGl⥣DT"D+wպۊF5n+q+kifPrs>1'A9̠#GL$HWjYLDt=>kϩ'URO,Pkgh 4*N*Iϟ mM\(Bj͒eH Jb~AS?Yb<%ܗ W5NB/`, VS-Ž}? &І],iH!͡'-bOj8/4?m48[k^.<`i90>Se~ʾ@g$!jQVbd+!TkBfT;bKi09]QSڐ{^]'~A.!:s&*4HVg94i"xГIm]i-L-ښ^/Jjг\]( D@èO<9n©.x @Kib)K /iEZ7fDt.!Ίy 瀖@<< 2U5Spz \PjGۘ6}r0 5)\llVh*hbz)C}q|Nb#W%&4>)2jW% Eo@"C96c"#B|uJ}]:`7Z1u4GPX3 X K" viUh~Fۮ?{n!jxc8ɦ'e9wU3v)۩f!@?aIÕ2Yaaz|ZU~eH{6GB˸Vy^scV Ul~rQDn:k_>"u^j;m)NMP[^)i=g9 k;HQLiGj _,Kd~3Pd~תf])y%rKF0,L] '(TA#RxqT+O->襈}hJ&ز;$6-w6;hR;7=&ir1 j:j 9mA IBJt[D0Չ@]-hN#N׏=&pC9ch~_yJz+%M_v{8:);6_UcJXDuwL[͎WZ=-`QILb w RNw2ZH˗gMY*5ؓYUڎ$"F͛2)36p=O&()fHƴf155Я]s'6!*heq ѩ$3jbQތN㾤5XdH+PIvT* j|PE o eڸ"ڽRmL4]@ KH(Qq"KTz3iEϿ /B&^(\Q)ףgܬi֗M8l8izzIO X4Z +G7F˙"){ԊVʺpܶ=O]s*U47 atp6a8(Yi5h>W.eFf=$:)u@"-5}q4` ў i!/;^DOI kE2 f%̬Naȭȶr̷U#W$ \4PF x& K:YOkS2!R 1"\* bِ,*Nt63 b0eߖwg2j F\EZ1ȡ~ <q"RtS)k%P ƲU&#mfUTqH^? y_& =%1,x:GZ>^F r(DWU;CuJ{V^kwSoJ:F9kꡙWBdHHWx*&JyvI 357J Ey(|Y1?ކϒF-!YSk;ּ7`-Mu^m= DMiC۩u;oZqlhe$NсJO, yK*\AEIŖvw䔇q0JLE} CTI+ 2ReEwioAByqb唀q^CF0P}gBk:HEGz߈}K݉ŤOK(ۋFߥM+mNԲ}ju&$PNt4o5F~z/;TPm|L[No3Ъ}m˩m]!CJp·A'oh(]cՇC,s&l:XE$V]Ǡ)J+}j AZx?$ ڲV˚<2FI*b=SkjeǏ1w6ǾIhȱ̻,3-۫a"8ʠR87M2Fy3ŐCH}h0Nt]tvtZRRiv 5Ξ{dFjMXtڌ2hQ[Ot^[`YKMIX;9JA%Ux TlVS6zfM~H*4up%v+>B;xcDLrzywPNdkp;?d=mV Hf#`s,&@I-Srdz8cO$OrL?C?~NqPN-A"@nmU:$edp2AwкB p,dŢݼAeJ`5d]4%Gr& 7_앾0~rX3NBDccCNR.bgG"]e9^g@ʻW"LJ.M*u.3rt&cj<N!6%.~# R_NIIٵ~B]I;bOiU-wdߗb底ݳf֏.i eY8 R5^7L6sN5@$Ue(qvL&꺏FkD3,^~o8* Ȫ_gjFU0^ahAh;Yr>"(:>`8 `hnQmJA0/FڜiNVԳᡝޡcIzL“.N!ͧxѻ5zh(kuJ.1 cQxs!_Nlf u 7}'Xrgh7y}6-O>y/dzQlϪ*^n \ni $/ƉgA2'׈w y DNRsl BT >uƩI`@#[_01KW=dkM܄D+c| 3Eqwjۗ% -, pz.J}OPU\[=qj Yk*z_[$hqJec??3B;YpfRfE嵐,Y  SrXN+!g  a!ֲ9=Ӌ3 LeJO2/g]lY^Zhl𼋍-"eYƻԦ٨EH4h96#Mj&?;m6uʌլg/&DZ3&?^3μY8dW5~KhgAg+^F[QHr**_&=ݎ<|l ) 9 A<L?ےRc1'C߇9hз&Bo׾L>5ۭb3Й׾qc}܉+AtM|{83lkm cM]}*X,ꦕ687^g1z͈#U~6 8EWK$Nܱo#j4fP~1bA{*J͘c>!Q: =?*gHHrbӄ-R yM|P|elYYh#o7;jJsS<:2%Ӏjꥨ6;nZGkSإN>mzH5XƼ6bFNY764]ҞޅJLӴp,)-uO㈤-"XZ?0RcҴjƌ6N봭y&gXw5$"Wj!d:KzO١gXv.԰(~cxH2W/(~{@ڏ0 7&}&FXepQ12C\j_)/ؤ|jQHWFPRݒ"4z>j R{S{>t;{SwڞfP) Iymb)j?!ȄkP)>hzW񦟦#V1%Ga½ZGSi sSZ*&)pE JH (k\)) .$1ɣYs:tT*uXMiyiVd?zz9a wu1f$ͿnV@20wuzL.ؔ/UzS&\L2͚IA^p@uU9Q@hEM̲~pnD Lyhvc;r$"jlrAC%Fw"u-FRLQ`Z ,9:T`6jPk XZTC\G\svTvJOο%?Pd%;vl1G6gj捏ٶjvf }jͼ:NEM7;=Ӧot >)ȯ3qOJo,E9mʮhRP@9.k^6\u;/ۗFg7—7ph#yby:"TѪ՞ggȟ} Qq4'#!!gpyDͥ :<_Z]DfJKj%^Ӷ҈ڠ׍]j4BZz<9Gp~8 kWu)s-M BB i.J0bF_ <5x5/k+WgNF9]h Q]_4ѯVr#.k?qPv3[nR~0ߣb2"d<3٦A7VwaiOJ1Y? e!XWm%&  HLhP۷Z[7C_T|$I HJ*߆s%9rJ8) 11&OA:檂@pÉ(ab$I?<4it؃yb †P^&q1yQr0Yzq`嵧&*x,rW߿vTr4y9{ Jm-~\T74~+:JHq i ӽ\s2!<+uEOR91&=HV&I eiI8bHHC:O"(MsZE3[6Ee䮰1ې6p%󶷋^ +o6e~B3l6i7 t8ܻTxyx14WޅlȤOD$D!n;l,+ideHW40nF)_,7r ~~HjlPfeZV&JjXSbj O\d̀ !6rlJ_k<} >YœX@{}i-ŦN6a1afABf(Bd5AeQͰ$F%G 7D Fa^-dؙ؅N$C$Lv"e@pS9l,6e6fJ;̲a.܂Okx?DF7hPZt],FeԉU[B>ꁢ^Y2G5uX..U+p\QZ|JWط:%MiN>O,8[L?BPܦtE{${l{t+peLwWmء$B'~?c ŁhFJC❫NcE COm6x'n|:mYݻ#mҗEfSR%] op!ѻ%TTn8rf1-yv6ٌym?<݆?i2dhS35CXPY_Y~hnhwڤ)jRq C~u5tІ&qĶjEZu#iL!m}GRԖU%@g9yiKzcDi$WxfֳPchc?!&K09 fu2p>5@vA(r~}j#yq@IÆhU8xvj#p$>t}>e'86P*Vij"\NMCc'4)I!_N:RGΦ1 c$mwf5.]iB7|\;&1?N> רTX b8tz1N '5fٵc MS@NADzI< uC>C=FJh;PYPc8gՅ=L(!EP&ـd㒚{` ]٢aG=$;!KpE~\'o4md臓ǡG'.ca"ˋ:Yjd 8WոC*r%#5 v,%Ytv8AdoDJٔ jrb@6$[STLm|('.fC-Ll=R4$M=e^VL2c/D#嘆 rweI]HVj;O۷Ҙ|_boe6zCdψ!PDmgS ~KtZrFs/˷s؏yClþ|lJ[x*0q-5 GL=:Rc5@EصSL2`,Nɕ0- EB=.9'[b>{ySej&Jt0WcTD3)Amrtt'rɍ=(W 36ŪWVS{O_!GFN'`%$=6P_ da f镬Mp.)GzVC_;tPN O.YT/)4E'SV:\+g̺Nʶ"pL1o^ hl>E.o8 )/gμm]#b?1&.Woba]1>4{ @m2[3:+Du7ƻC^˔+M[C-maG KXYBڛjY*9=%yO^O@]7%3M4h^U]b*Y#d}66wة[hY6A6gRU4i"ܱM1/P K մzh k_Sdk[47+MQP4کhݶCQ>QP3ҘV.a!Kx̽1"/&R ΂zj;_.L&I Qn2p#&gLkG Ac2E[ 1X|*&54%Oы!X*p oP1t#,2l9b.u.ASȓ!HM-3ztR,=Dnd_7l؈Ji)ѧk!9vyj'9nQMdnxY)KRKmi1/](J!"(m-挘).Nϛtyb G7$lT1w1VZC,)7=}#fZ*`?cJTɱO`B1#gm ^YӰ/vJg4SF#zjB"_--dnuґnUΟMo7׾aϑLMB.5}%!l#SκÕ.S@0Ӫ;|à5Pv}9SOF"v}6(mfY4Vw"vd;Mf$^3H9s&@:1Ŵ8|& 2{"&AkbGC=;U1 U|?O3AU[N^ 5՞PE@X<{jvLĎ^NjnQ i!T.YWiE;ɚqW'jMp'7Dm-9cfڳ(@\AcEUBdxi *UpE@ZrԐC{ԦtMI{y}mRۊjjIGHהu&5x+MibQr&^k!A/ M{\кdywFh(Uh .$Hjl)⬡ ,Q>`da01"KViLr HLE2* vl;AyuMd(׼c5Ya 4sNΞbmomSKtvv+䭆 Ŵ#ȱV)y+衻M@|mHۛ?P5sFX'}e6rܾYlrr ړ02UsZEUe'ލ1s/S+-u^N4KAae Y7f\#x%0-1M0HB!_d0M@Ca5g7EY} պ%Ϝzo]5z^^bm\hn>6ep&4hvZfr@ FK̘yjEOdH.&"+ߨۏm*̈́9;2G盏,jwrkK`8~C͑@ҟ0&9k^{W6Oʷ``Si"p.ecl} Z5WVNkFDiR''NaH4QQlT& P2yГx -{`1u"׾%QF3J[0y3dAfD2awQDVγ&6J`:1 @L|(/V/VkhH0BTG *%TrB!i'ó3|R|(=*MYfUo75&Vjoi9 e|zG 袓ޚ?En.j58" k2Da4MVijEY$$N1M!+f͝"?Cb6֤tWZrF kUAiHWi=&7$\r߆hLrUSzIB6t30kO) B9@R0mE j@'\ZJZR]i-m/V8c h$1Mzm9$E\gmy\ F#cD$ +B#*nzG.z ^Oε61ZWL#\H:HօZ$2TI6ֻ!' (z׊pʧ!eRꃇe0QR!qfڥɷ+bTBy#Eyb- K{$_6MlzN$JEsqW~X,M _-`8Y86Ӛhqo?Φ*LQ~y;pg8G!2E)sYX}MɁj\yGߓEΓڐo%@] hʜpYR wu#@bZ!ȻY)oѮ*DwZjjDy ]5ၪ"DX6SjKJzLn$ .{fiC35K',+toHWcPũN&Ww2:#]MdhMfsn4(ؿpV,aPܸ{?y>G%G+M4 _2mqet@7+A#a7+Mk0ts?۴RNVkG^,l䶦؜EY5>DhM} %~i^ ]5P@юW生ZO"{X@N cu2NU -9]b'4ywDzp,CN>h]#Ag,|KFڽSf]d-f;l`zil]/lso޿o>YkI̳o3i9'>Fl# 7mj9[{xNaUl2ԝh s洬+Uq o8p<ࠗ ʹ#\[:mi#>TNꗳX2uOW%SO a4E:dy?v*a+Re tɻܯ*JH h=]Hb"oExaTc@?@6E*'*4E<3=X] I(k_}lZ%,Mv'\UisځW1!6*?q3LEڟB rNxکh{ro0W,(Hm'n8rViO68O!qjJzR'[^$1MLA[84b'V?RѸC5=h`R+ \Y!{S@t?Lq N++i &) 1Ī\5ΚRmZj)mԠk4$4SA}88u01 H3A[ t6NMF c?24~"KoZyW#Ef d"Vɦg(d~(vzsgRQݴkfԶ.MbrFZTp}k?mS.=5|rH  lr_|L%~fN?r^0O(voiCVOZ0h-oZ^ !̺V!T I24:PSP2G6l~Q ֜,$z(s(ƌIbbXKK>3&b]Y*D,ʚ^34&#-o,>fn-Iwɪˏ I>.4xE.al=@~gptJoSF:cX%]r8}WsQ+9S?Ӓ6#`MU0Ұ4%vM;{To\(Hk6 T=1#Cl}'9WaT{EҒ~Zc9=.У(_&-Ars̼o2pi䣎s6b9վqʼzgCs ƾTϼk3}~,4HLȖwn|lbgnO3$j eeyǼaO =m,B8`ݼԣc\x0H~橃x*(JTSeA8jۏjq|bm7'8eFdӵ8ҦiadLKOm%<7zMf\޻.44 KV2 ! kInuE ZHi+DMӭKuFNS(mE3wMddQT(䧔CY1-D>s>?R]akKY.SpTA s۝bÆ*_X}? ҵ7覫cOj}C)VvFy46ź/U~H Z>ş2(Tf8l=9tZC6XUxESw6=o=WH!/*_@Nƍ抩DcXwKVcYNB\ QۯQTZ:xmeG78MJLLΘdT1M1v%Dt#vdW'l>fn]GDCP(l¢ #suzAoQyI]bMb׾F/MU&9W"X&>W[i `tqo06_5fReΞ7-?b6@6廩M:׼3O;lSGa*Ɠ`:F-RWjìmk/}QBp6PDMN-Fq[D;ke~ODZ@/o,涀;Bӑ.k֔ |KSMۈaDEOVQ*oF4BR/'ˊܖ@z#}[eLb6%&۪! ,e3 ZhhWD ۙFíP^vJEA<0p{jUXR`Ƹak!_*M)튔/w<5{5PrߋA)cm4O\Yp6UAr kAJi#f$pS+j5J=Mj(-xjZb@ Z# Rr\)Vo'6y mp}+' RcS6&7ae[k9 SNbV*ɔSes* `D)8H2`'+*-Lt d'pkHhaFVZ+N/.uor7JdamN?}L0ujM\Me8hzI^卥K?~Nv_|Y%N0sAL8rZ3vʳd2ﳽ2'VC*$_"}o̅AR2Wx"H[-Y&bg}Ar%ڌ,,Z,aKĔ]CNy!׸Z&ց8 )u72@v;y`˩R<8&V}9 ּfm-jF"ׇ荘1X˶`y CĹ?`kE]QƘ1 )i4}E>ݓ0a&wH6@s"cբDsQ6w4ݍ#[^*Bx2,7[v-6pѰ^Fg…~`u9jM0]N3ؑQKO4ֽzJ!)!YΞu~q8IK<ԠC4_cTi_SkY8ZN' P珣X3 KB?vr)B,CjvJ:%.5}@?18(O9,' T4bxY9YslJ(˙}pĮU=UX͠eҋ3W%2ҤK,S&Kl.AvF~~fk;Õ{m]&vYSex] 8L묞m~R|s˒Ok!Єuhl⏪kLd_gvkfebAI6nJ؝< >EC e7fe_'tbɷ.F`+ئPh bj* WOl6-UنmS9B>G1)[Ide)|2ZAvzMz]܇J< =-h̞DKp)eݥ}XrJeL̉\Ej1.ji)ckUūb]A1j Sl_"`p񲍌bI7^E̜*VwbPEJzef FnM@EIKT A+}'l~NM[)_NRk*H4Z|ZNFCmϑ~r %)d-"=a:8ɻ^Vf{"z`dMb]I }bqǏMV`B)`d4-߄kL-E>iDyhM%ӲKrqK&pB[k~l#TV؜uYlM噂ə[{d|o?FS/7RN\ irv٦JFp9ۨ3>|h#1izm ٿ6 xvqDeoGU|~3ElreGEF F H6ՋB4`r03_`| z_ glG%+x1G9ֵcjh_?swnrur*hh3bS,>7Yѹ5V:z99LMwЩ^1ik7 YGdXIh0ԑKhf5ðіu)K% $ksooJ,>62K~oY;R8ڥ0pic|"pO5' , {{c½|(l˭=!Gu=;>;5 ' UJZ'6fbg9}|~'H)+A 1 48J sO>+8;q*M)ZOn#+fmaȯc8~:,ω]_+{[Rǣ(9]pGPMݤR36)caЦ f4`)7ߨCM'~ⒺGZořuI&B l,2-{&a!KW<*NRϸt/K2PWd^Xybsp 7`]*ŰKofnڐٿ'mt]Jˆl՝M\^7˰@i^1n3KP? ۓ`W[( i,=4붡&Sd!rY{NN8Tϥi6Kf%wTXڛ1r(1Ys &[ i4aDFZ5j"n]Ȣ'@G.-r*7 i5EXS }|syi"(`yTvZřؑR~* HY6ɛa_+|$h E@\ɦ+]Psƒ=RKk^_ ,yn:HxcƦ84$}y9USd.ɵn(=.e>@-!'K*5Ah_+YYlc;I|h'sɻhi`P$)}I1=_ 2;NPb+:>( Lr6uXelyPWH&kgK2a?|SpbvpöX)U,36;6XZm2I\ >dFuq9& bʙo#_oS ڦ}刳69X-caD$SyƱM\6Zff ٧]T;qrR&AJKSUB&m,XLBË\v]lR0REHoe٤1fi7UcMD9HFW3AIfX9{k ;|UMe1ജ}_Z_dQ2uK?eOeϒ+Ul~xS$f `ca6ǚz61R7Iڸ =f3TeǴbJdŰ utv;MOә[q?ijULj~,jG3v5dq%@bTYx 0+n5 Hk' ("AoRZû<:.YcY=II@ cŮS#l1M G3$g;VSB{^"ͨjUz:k љCNȻ.CFNĺ[~8B, I8)~s~_vCÜ@v)wʑkm--OPV$'qm:y$rDʰ")*CJ)p6Aᡈ^\y 6Ϭ?e*x5͘/pXm'2iJ|ՏY{ʟ'nȬœQ?)P8^ВaDh9 zʼu) ]h'jꊺ.0!]$^Ⱥ$Rե#bהoي3H>ue촍=]!\B-" c*]9j CA6/0Rxia CR@Nߤ7{pyhdxFc,V"'-M  gxF*,x܅?,WKHX\ls _=ӉL"<5 |4PR{iǁz?Sk`;m+JQ؅Љא5q& ZUwxPt& ߝ\"Fi9l<ũQjNBS !ydft4Cr:j.ZVFCO%ɗ!)%9_(h~(ȲLZؘ81/ĥHڟ`bc~ljDIo6'l mNaKljv)Xx 63wm'ng*6LlȴtY*%[^ɉGFEC8]K5y"l-S-K e%3J-7덈+{Յ~26(F^(b\xhfiD~a[!vrvQRYA5d pAaG"絞*!Ь"]9y[C٘:>]YvS^U.3 5uIV07Acm4i*<'\1(f gmE@RsiCx!JYU1_Fٻm Ɣ6=20Rz:pf Éy/FC>JJJMgNúzΛV]/ h#U'ȲzA*ͬ^4ZX8x6Ա,Z/-U 97F("f&j?D&:~* sC 9PL==yVӂl#Lu&xm,4? @9AP78a4^6ǎgs1Jp=ͷakP`(wPBz@mf]kLy>/b7XIXe nCswފȇFڲ9b?֝2rQ?gy*Duziwά|e˷dLy}of|u i+q?{lzr^R}5f8#g@EntA˾'ގΚ2߭QG &q' Pe!0*ol*P~_-#TH?xc7sJtl+#+P!ʒ)Mp))|-Kl*dէ`8i.{0Z̩Ien{Z޵@̓tM#E\syjL0U'O/;4ac M^gp.HJ5@0@(jWJEE+X9=?(w#-6w0Įur=H4tL3.8c@u]+K,5`@p%\6Euڮ[eSxP6ԩcXt2L DTfU9tR[Űۓ̖X9Ut$ŝِF(0~GUT j>tMC!Ul@@}hR7٠EyTSeS439^vR,wbf R@mfօNWrqcOhFŰ6bKSoCm[6-!L &<<UNx5N)sHE6e<;x`3!U+ɸ]%s=z- gb|4x*X5٨V[_<1j' g CECDЮٛ'eAKM*vҪ;b-FH"VX˥-:b=D8O|`9Y{=5)OrsO!F1`n而e )e >ّz> 5Mvs 2P0Q*L2Ғnq|<vbEvI&rڠdİp;aTh*ʶTj6E2XġL]^17TJ0-amhaV(a#]ݲч2>Z :GjI6[\XpLݖ"OWɰ,xLK4YuVSg2@Qǡ)לJ`dxgD4+Ԓ$sK2)!`Zs)gX(yO|;;JZ0͗P||Š|sY@#;%H,^SFjp+&RS<%^혎xGMroJ]Ű~3RePB`5FeDk.)Iq-N&M\Acf3i]CN=(1a);KoF~LHjOcML{7\Tu4=ZQ;V4m]N!cUȋ,`i@>DrS3 ѕ$a^ÚĽ A[4avWʫAzLSe~@s%'P xbb+0ۙAr JGzmo4F/Z:əf::ν>ѧds㹍pu 7Wgȇyv5CP0ɗo`'=!nNmeܶGvc:ٷ1) KVZG(XOT\G&0 34ٸ)ILwWzȷVkY VKR>SRlr&$1)f#9î<]ErF]JV%+Ynb84On;d/>Si+rk Lԙu +& =Ds`.,̅/6yBb3 L5F4&4 T-5)+=uDHpd5mpvPKVfpAYP^top$QǀzU;$Nm['>e,+LU4*{(I:CGkkMv(a?Y_4.4@c͙T-}Sw9e)E 4hl To#_̤IlBzu$ϯɀjk -a[$MiCok ? Y !-*"=MHDVUu1~G@O h^sH [V˫QMjJv8 hHtE3Nv2rR_GؒY`c]^Ah&6y iuJ9F]۴34EzQzMOD}t1 0'FD_$O?HMB LgX'O$XϜCg-&z\IdRޥ#Rb+G8** Ap*6&yEwe)7\h \][y;U`rcl| K13Nw~y8*?2ԸA]S7Bn)cܖQXDd'C\lKAW5H{G2 ~ >3$ ۠lܛE܏tha!)F0AA"䐧I͒pEL S DC:}^Zёkƛ%,ѭH\@:~(o#|I 1l" bn;a6&,clĪ0FY5˪fHMb4YȀ`Zk=G4S ߋ<ԺYѷCvVDw,9b|S}cd f h\tEa-C1JG*ڥ5\Ü=EN:j 8U[VW$j߬2%uU4+uҼvyOQ`5t;ߟ܇3(SF+Dr"%^h\`,ous7% Ả"ԥY"1/uشi~Ӡ[)#T?Gq$[n1mMTh4D#jEtSDk3R.R>Gf 1`ǣBV]Nhts#%yI+xWcaArADw*+'yIt>3FWpim!)ELIZi< qHn|ϪɗBWb|阮 ?i1\) i3hP`.И]QDRKBvi[ yfp3SW̓-RA )Y>D{à N}$ިNiHޝ˫_ y%9$m ' UOU]jyDZQBXV6D8Z'úԪ-m #F2esc<-]kIX=;5e})f@Dz1Y O5hDB.hzKjvMrZnA$Zjܚ|e|z:qTAFIͰUi}W @'D6/\ނJmAG AMO>j$ث;RPGÝpu)8QoƋDD1u"Ն@zjb/<ú-\R^7CVn- }ӿw*ٞ! hvogxұ)66xJj=DwKr"!%`SVwG12 x(elF%N{RMWT9,Tp=Q~b-jAhq7W桎'1`VVtz'FQ$QU IA}fR2 ]*L/b]f6X:|ТnsDZtW Dwm*՗!II[iIt4]?Z5IKNA$'Ipi&#/;E$ϙ\҄01%67.*UT5 t V1ٶzg#mB)VN.yB' G_[ kXgRaF8wmmILTv ,@BwHJx؈ԱںKr= NcF֯Dm'ͮKAsqFIi%U?z:bͺUC'uq@5ӗcCdxFmy鸨 2jjL]oq=PPγF!g Z\"-ou ٛRr%{>Jr6P;@N|kvG!o&FJCԒ'=3"բ]1u0;eI` )gùzh3!<.!m"PÉ^f{mPîB $#N=@ ^P}d U8ezF4B8 ug6Ӽ22ZZIZqQ/ BCrAUQ{S3Mv4YkP:9ڠD=Ԙk:F}[EbOCCD{ȝˍ,oDf][n6.|ڶS+$N) p7{%ǩ3a?UBbpbYyӍ1 P Pp^chx8;*&H%%frk2NQIa7:ðLj~5}qPii r<;oqBCpd&H~49E(ܪ)gc8ŴbF [um4NO>(:@Ҩ0 JGlȡ^#+ZXC:%[ĴA;\B{4SJ[ 5Qj*C_-; K:"MNŴD4!a$߅|pG%q _5WQp5A5V+$SJ*EᄲdWg6) @бj"ؗ { vk;˸{5vc=^XV=:ZE(#r MX"K;4s+I=jT{+4jn= J)R'qdlƉ1I^ȤM"(HĀwJ3Tj‰SIsDߣ%N]xīDDExkW3M\[d) Asd_l[.;-Dkfa#NAWScs!J2O1e5{p ˖ls/2aǎPwJL'6Vxʿn,g2I#t`[n$\6]R#iZ3Ճayрj Wr(ȼhShEUux>1FDi9}E9pg]IM< ?Vd8)*adj5|eAS e}j؃`6>}!$Mhw`gM|6!ÖjbdQLxZBV%+׎> (L0㴛TJI-$yjU5񨭣J>qΜА!G`r{5j=:R5e l$͋=Pq1<2迮˩e\jI26Uxd- %gx0㆟x H0\6%@}5.l?M=V)x8V)~zIZq֍_M$z&kyIQh `/'_\31Ld'&X`4VIԑ40$'I[<D]*hD=vjo9M$*[bhɉ.;a?[jTxVoɚslv8+1ÖB) _9E(7wTrJ:Żj͑(M=_ VJRZ]sIILG, \*飁W< el]ht>ly̦>KtZ@TLSC¸د)*oJXVF<1J2߬}O)E9+-1K׿Չ>r<,\YkGi,鱤Wcńtæޫr P{iey@^EYnS!æҵVbN8J΍ ǣIIô@Ҝw؁#ѝz?Dʈ>Tm1Fv *5+8a@i{x#?efTAWB?,`$S$4̫敕*f7]D#.C,MAu= * л>#Q[jF~FxLH+ }"#U]NV^N%3k4 a&d~&4d][ fP*F9EM z8Fn|ZPsz[(U- Sh^V'M)HIO>{\$ЌW!'fIO gon -)L-,ű_g,gaԞ3dR)nfc #]#[mՕmjJ;h!m ڂN6q%M 1dfýmxU)Iү"V3}FOg4gXTںqZަp**MSDl;5gy"+C]L.tij1hȬM}Zj1>2œB49F8#ٔJ"@;G)ŌlwPވ@/>kysJ6,ciyCJoO'gctDfj㥁jE$pilCĺMލJh=[(nP*5 E(ES$ $P\h݇RM3gPAG).2A\")m@5!vv'vtEr) &+ԒC1,3iX/mUcvTpUr#UjcFiP+lnxZm43`Gkt\)H=s[n}0e1&\ %^_H{*2 [% syo*fժřSL iiRV4;xzBJvbܧp:uī"w価^{̼/TZNq2Oa);tfyB:"7fCDpbce]h3/;MƠ@YǠ cZ31\F%[rtٗ~ o<;、UbİRDD:C6n$]Gw'3}q%*z覠toVi hMn]Ȕr1$P7yH@rgMz6Zbbzًʚ~(h$QlM$!6-a!̚1V)!jnCQlGm$u K+(}qу~B_h䜄: p⤼G첍1ldYj\=f&wrˁ:a@=4)7.vWDOoTꔺސfRhR#3)#oFogmG^&$سl LTϲfRq鮩|…w'D49!kl-ƁRSG[rπ,67 K>kh<[#d&I*dz1&/3AԕB4E/V\ʵ6ScXȞ.Z(J]>N? ]3 DӉzXGg-`W4p,ȏ σrIԯ̙bM &ۍB7FixkJ0n8!ٖ24$C94,nvd@\5tZwϒgLU8ߡQ~ TpO8;Ӑ9Ӣܗ5/UC%$\:=zuj߀b,i-V( FY:yhڞ Hֶ鴋ӴT7pݦy$/~!|p"l5qXa(q^ux+e:N"%K!n4Qs5K(p6l,xcM,%Cs4)AZ.76xۢ 8^[GL *7Q3:xqtZ4-/XY*BkzDI66%VG:vJ5I=o=aB(c`s+4j䎤 DrN=wC(h휺ҕ |S3U:XXk-!]ia㯛5_DS& I3zͣ.?w,ͧBmIQEXbnvԽAK–,&z0DT\hJ}wnEșW~p \?=9s8Nt;"uYWkZ3׏Uٶ~օ[}Yh뙳rz>sϺqr:sy''هu=ꨣ{Ͷd|{E7G{y7ݱdw? ` Et)!ϯT'Ӝuz}._MnMT}%m/8!wbmqօbm\twu`y\x0BN@I4Cz>jIk&:Jv>.bWkwZEjz"W"/g-{ݥ#u;1sy_GHQ#gNj:7E[Ϲ{r?zyw]ns^dEEgc||N8p}7~(w+=t/|8Æܾ W.ɘ}c|c~~9 /n!wr% t!>3_AQA.!_hf>'sU#W׏v{5?oG84#4|2 h?&ȓ¿RFo_I^ÿd7wcg:e57vNՃ e\;7k ' $_yg}7鷂q<7 µÒ)eTWnIï~_!7_9iofW׮2n-+_'O+' L үe)7;N>Uiw nIÿ/s nIÿoA?uz۫Hgd<,7 ' N ү#d<27G+'  үϣe<&7ǸNc#y $_eBFo毜49V~}!?u&QWd/_:i zɎNd:7W ' 5N үx}FowWN~+H>o:io`sG2ޖv_e;7w+' =N_x_Fosw4WJ/d|87 ' #N ү_xFowWN'~+H>?:i cµc? ' sN ү?_9i_r |EW3z- ׎M?d|37o ' [N ү^FosWN~+H>?:iDžkrr^ܡ}G/ ;A짗;*7or}/w\FoǹNA|v|>]/wbFo' '  kfM7_鷂s nrvd}n$OvN_g[ƍ3zÿr үO# uw4.]%YʸYFo7sN)N d/r7 n' N02n' 6Ap^2zÿp S2]7 rSƽ2zÿ;Úsd7?AyfP7[A9Wy:i}'Ge(7/2 үϓe<%7NSpd}~Q/eKnI/2s\ ү d07N~=n&em  UnIM үke.7׹No5U?Iӟ߿P[2zI _Ό8i kW?d~? ^_e|0749}2>' /5 nI/lFouWN;V;2]' Acڏ%2_d{Fo毜4o8V~}-;u ׮AFo?pN~_[,>8d~+H>gnD_+\|}.%dpuen}./寚UoG޷zFoWww4kk?ϵep \_ 2zÿro[A^`Fo' +];YJF~/4AdnIÿoOqZFoNNП!s[ʸUForOpp̌tOvo Oqwq%]'Y˸GFopOp'24;*ț98;7S4uõ&0 n NNb~})れ/pOv/tU~}#??I\_/\^>?'I??Iӟ__?WA2S4gOk?do/4w82H>毜4?q O3z o!a #n NG q nN_;*H|}Zg2zA>Je97A:YƗ2zI?*kq7e|+7o ' N ?_ߓ毜4r wdOFo:iϡ8,/ ^wУdnIÿodn堷JG .3z_ ' jNo8~})Z_鷂#ޡ znAp6[=7ᯜ~_(2z/_:V~}Z]FoAY ?OqNNo1>7qo{Owz~}n-6uov>wqnj/4;92H>wq毜4v Kƽ3zÿ'o8Yx`FotN~_8'7s3N_dn/µ"YGxtFovNc~}'d7d' N ҝ}fT7' 烾 d}~I32zp  nI rPƋ2zjWҝ/}gr7' Nb~>U2~37t8it󡯓NZxcFootOp'-2ޚ[N9 Sƻ2zq7Zs3 nI/e|(7+' /~+1_N_}|RƧ2zp? |VgnI үd|17/N?} U2WU_e|#7o+' ?~+H>ߑ݌:i}'? nI/t].N| `s2 74' Ƞµa>#،uNqN ?ɻ2z?_9i r_]52zÿXЏژNFoqNu~_ȸaFo7tWN~+H>]' ;o$Yk2zo:2H>yIFo7qWNM~+H>Mõ&s+gdpo )v_9iw Y]2zÿTЇ3J>qό/4{92H>q毜4~+H>gxpFovw4NI2 \7 \ Œ/tWNEN_x\Fosw4 zϓd<97' ' )N үd<=7+' ~+H>ϒ:i矖e 7 ' N ?/Ҍ_p_RƯgnAoא|zkd67׺'8isz]4sz-y? |? Ce#7w ' NG1_2:7vWN8V~}>#o3z[7IEvd}>'_8i_pe _N: k2Ӝ4 5|KƷ3z?1H>2+7rOvWAGfnN-õ[ r2.?ɀÝ \hW nN~[+/_?IÿJ*\U>r_j_?Iÿӟ_k?Iÿӯs=?O:i3µ3g Wn NA?1HB! t8i Wdn?õ[2{?_A fpOsenpzFo+' Nÿf[7IɠMvd}(N_8iwve~}&3zi7鷂so >nߠme<(7'8ig;A?ϸ49 ~e<"7G9i ~h 1nI/d<17'+' ~+T?ϻN/ڙ-w2z7I}>\}>o/47;2H>oGr[Ay? ]' ApW2zp |H_dnIo/eUFo:i;kwLS2>_eCFo毜4t |Q?eOnApN|EW3zp |CdnIo237tw4õ;'C? GnI_p_>__9?鷂ts2 H7I?*e>+㸌sNN ү` 毜4~+H>אc_3*\d}#__8ise~}n(F_9i';V~}oN]idnI~_ȸiFo7uWN͜~+H>߇f:i7kwKG:7[ ' 6N үc>7ۻ+' N_y^u?t>q/4{;2H>qVFog+' N_xHFoqw4õ's2z?_8i;2Hw~?BeI  g' Ap 3zs7I`'\O>?/4te~}Zd7nIooe]Fo:i kM2E__dkFo毜4/;V~}.2z77I_vd}-;_8iue~}KgnIoe_Fo:x?\|}`#wNN ҭWq毜4c~+H>G\YU2zÿ_5 Jj2 _e\;7k+' $ үOȸ~Foww45!刃tOp |D) r8it!7qǠ`Cϩ2N 4782H._9ir wmedFo?:igµ%s'w nIÿ/## үG77Npd}qvFog ' N үxXFosWNÝ~+H>Ȍ:iõ' nI/'??y/:iO k3e<+7gWvW Wd_Ռ8i_~xd}C73zp 2} үe(7;Nŗ ΝϑqhF<_8/Œ_:i/ GkJd,7 ' N үoxUForWNo:V~}^+uu-p F_e%7+' N_wxgFotw4wcµ$2,7?sN{~\3zI ?8i_~ld}F'3zp? w2>gN/d7Ib?.\{\>*_8i_qe~}MƿgnIo2w]' ?l>-_8i?teu=.?d?rN0H|8<7' ˏ?_$㘌qNN ?G]EU3zÿrOp wd\=7Nŗ=!Yk $7_Ad7鷂ۣfq-pT2k77N ү c tWNM~+2z?uwµK2n/ƙ毜49V~}$u-pI]=2zÿp W2zÿr[Ay3z?u-p ?G=L3zӟۿz 2zÿ?_zlFouw4|/?%\{!Gd_d<-74; o:i!m2ޞ4w8A2ޓ{N8 > nZCχe|$7 ' N ??毜4v we|&7ϸNõ'2>y_e|)7/+' _~+H>_:i__ אoe-7' Nbg}7_N0H|Hd?nAK/2>Ta}?07d? N ?G3z?_9iWt }3z?qא9Z~ӣ/49A)Z_?Iq_򣎾e=7T' '3r'8i+?1H>7Qd_';iӯ2zS4>=+Y8%7S4S \-2zÿӯsk 6nNmڳ;fG7' NNb|]e-74vAϽd;7{;N}õ_>d~~f@7?ACe9nI үy2 |7ID?'\{N>/482H>毜4':V;)2S]' sgd 7?Ass3zr鷂B/ EnA+گ$2/ nI/*o+' ~+H>N?/\{^>/_8iore~}"_9i[Aywe.7I~d}L{3zp |PƇ2zr鷂1_N_ µ$I SnI/Y߻+' ~+H}A3zSп0\{a>_/4:2H>._9i[A8nFouw4 k/J2~#_G\r}G篜 Wo犇8"7#]' ȠpWscdnI?A['drN_˸FFopw4 k/NGtWNFoqNu~_ȸaFo7tWN~+H>]' ;_$YZF~/4Ae$7+' N_y_q'77I k/MV2 7A9S2zÿro[Ad7Ipג{fO7Ag7[A9[ƃ3z?$_,Y877s/s 3zÿ_9i9V~}+q?u6_d<;7g;N/+µW$#_ B_GއW|iFo/uWN9V;2~=7_ww4WkL52^k:_ 2~77uWN9V~},2z7Iàp W|wd7' Nbοz? ?_?8i!#2>G1_O_9i[A8یu._*Y|FowN~_/_9i[Agu7Ip 韯ovFovOp'韯? ?_#3z_7Ip?W:L2._8t/tϕqŌ毜4+9V;xW nud}3_j__8iWwe~}%3zq7_鷂s=?ON5kzUFo+7te~} eFor+ үO' ww4!_6YSdnI?A3z?_9it Fm3zÿdп.\{]>wq/4;;2H>wr[Ad7Iÿovtו(A??I?O _W:Gd3n' aN0H]| nȠpw?/4:2H\{}>ϐ̌/4g92H>ϕ+r[Ay_ W]' Ap yJ nI/ϗcW?y×J9i אFo Mn N o*2z#7FNۜ@7spye>7' Nb~}>$/2z 7FN@7u)2z+7fNǃ5Ud|:7OWu? o^?dn 4t :iyGe_ +n4|/1\C7dGFo/4o:2H ?= ?Ì8i? 7ko1"|Fp2s/ts2 H7[A8cdno7koNGEFo 7 \CƏecnIÿocDwu2zÿ[|µ?HG%(7 ' d_G>1o+' Nïe47nk+iFo7uN͜~_f毜4;V~}n%㌌pw4|/%\{K>qo/4;82H>wSr[A{fO7IÿWп5\{k>qVFog ' N үσe<$7+' N_877s]' Q>ʸ(7(_q2~67uWN~+H>O:iO koK2~17_tN/92H>ϖr[Ayd7I÷õ'R ' eN үϯ_9ir Fk3z[|;1 ' ~_OÌ_9ioq =u-p? OgN үdyFo毜4:V~}>"u-p] oI_K Ng`~gy7IBq _e__9i[A8ovFovw4|/;\{w>%3zo7A_+'>GϨ ҭϱɸBFNŗg>^Qƕ2zÿpqen}d7_鷂#^-7Nŗ$\C:?._?I?O ҽ  n' N0H>VWniNpO?*7_8i/O/c pWN[A857S' !s[fK7' VNb 'NN0H>wq8i_~oCO˸{FowwN=~#_9is we<(7NAp}e07?AyGfH7_[Ayd7I÷õ'D?Ϲ ' IN ү_9iOs *_9i/q \+2z[|õ?Od:7W ' 5N үx}FowWN~+H>o:iokLd-7 ' N үǾ;7w+' =N_y:i_Pd}BƇ3zp? gq7鷂) no"Yp?  % үWd|57Nׂڇ nI/2} үe(7NGµ84/  w2z?_9iG;Vn}qe >|N D7/~_q͌毜4k9V~}#_u >ύdnI? oe87';iӯ<72ڌ[7T' א|zMe,7'8i8A긛gs7d' N ү2nS4_ke!7;'8iwtS2]49*H>q;?}Ό:i OkJOeYFo/4:2H>._9ir w2ze:\t>rɌ?/4O92H>'_9i[A/d7Ib&\L>*_8i_qe~}MƿgnIo2w]' A-?IӟC?$N/t3z?q sd1nI?AȸjFoWuWN Nÿgu7IÿF6\l>זInIÿ/s}7 nIÿoG3z?:i[A=_W2k7' qtcFo_Y2z??I sK VnI?A33z?_9is wd97;N]5.?Iÿӟ{?_ ~n' N0H~~3z?q >d<<7'8i:Ay 2zÿ?_ n|CxRFoOrN~~A2zr[A8gxVForw4gµ/$< nI/ϋe$74:  nApZk2zp_ zo nI] rIƛ3z?kd=7 ' N үϻe'7+' O~+H>:i9YHFoqNG~_DFopWN_;V~}yg2zm)\R>?/4;2H>yRFo_rWN8V~}*kuK>ߔ/4o;2H>ߓ毜4r G2'7qw4  u>W>Ta}anɀ+82HwQ2 h7d' N ҝ/|3z??Iÿr9\r>b]y_8iWszqϕ)Z__9i?[A8ʸ^Fosw4k_IG~+ pWN үύenI/~+H>.7ujd}n&㔌OqNN үe"7[+' t үϭe&7۸Nmkג;fG7Ae77o^2]' >Ap<@3zp $?_8ite~}#?_9i[Aye"7IՠFd}^&_8ipe~}^%73zM7ou2~;7vw4 #Yߗƌ/4792H>o֌毜4?r Sƻ2zq3\f>&_8isesPFor8iˌq*}+YOTForN~_? үd|17/;N{};\v>bo_+_8i_ueᕿ7Nf]7IϠNd}~ _8i?ren}(ͽ2._9ry ҭUqDFoGNAp12 X7 \U 毜4o25]' ǂ?õLGtWNFoqNu~{\2n N`sVFo[n ׾O- qN~ 3ʸIFo7qWNM~+/kqw]' 7}?Y[8#73k_L vnIÿo2]]' µJ2=/_~2o韯e<87;NCõN2 \7 \ Œ/tWNENe87I٠Ad}$?_8iOqe~}&?_9i[Ayggl7Iad}/_8i/te~}^"_9i[A2~=7_ww4k?J52^k:_ 2~77uWN9V;2 7?pw4? א.*oO ?'IS?/80+ek qdzwݻqٍǕ$www!J\­ᬪZYo 3ٹZOn~Eߟ$\>V S4?H^ _}F׈ߒpMZ/nA>J> ?}BS43WϨF2/GZ7?:瀫g'xcm }mhybp.}ڵ,po[x[ZLտ 3o/K. 3'O|AW`gBW>OͿ/ρh_6īh~pNog}pGO,9%?O%9SrV o Ks€B'濈x\&<꿜 F2'C_ΥKIrs3oB67S4{Wϼ#U[ o<˗߀_'xI58uiyM?Z\h_x)\a__Bտo&>KhOGI owo g}zHz\=ix'p}m9#W6 >6)3F26KhNnQW\kbml[4:oHkK ס}3w6 gѾG}Jݦhm͉g ZMտ Ϳ-3ug'WδOͿ __{H }mh~pO3-l~fK }#^(WѴo613x 91?x=.9#?u?x=s伀<7x|.\p_BFo_ ™-_%:꿚!z W ϼ#]#h_xvp/ɽWOyHp03o?BIS8OͿ$MI,p/KtD~_H\mi_xx8#߯W'HIק}ms4g#Wƴ/Ϳ x8{d+'ߚxl/!߁w$>Jv w}m~{-Φ}$\ҾG$\ӾmCWpWyH^p*?I}mh~NpJ%9;? g}.\p_DO|%W\W>6s4gڀZ}JYrK oJ6x Ҿ6 *}KF\#hx$+p}ms4}gpO}s8}KV W}mh\duWͿ*ﳎdF?5o >̒lpoHOl&<ߜ kFmտ- oo>΁,%߅w%>{J }mhh_x@Ap*PaWaO89ZrL 3oKgH Ϥ}mhyiy9sҀRbCRՒkkhxArc#3oDJ }mhÒGGhyQ9䩀)|JyAb"oD"5#>I}Yoby?] |$#OdɀI'oE6:S4g}̀&3oo@[I}mmhiy'9ﳛdw|KNO}mhϩhyt9?-9'?5o Φwҋ$\ӾGχ++i_6Uīhϵh_6NJ-[[ix6)ߟ$w\w>6=s6<p?Hy\D$z4?J }yYJ kbX[i_mwף>H> ?}>J> ?}OsRE >6S4}()&k]G o >ɥ'pϧ}mS4ݧ} Iˀ߾%3o_x_Jtտ4 o/>)ާ}kI o%>5> SgoO ΦGHF\#i_mQۏӾghmIW$7z2t8ޟ%+\+>6S4?Kנ}m5h~fH ץ}mWs}6lpoDO|%[\[>6s4g[vWv/Ϳ=JpT.]]ix7)~idoWͿ*~i@׼p\aix)ߟc$\>6qs4?'INO}mSWs}ΔpEgO|%\>6s4ReWe/9p65udN?u濖x=npDo&^E;;h_6Z>I} ^<"y4o?F<%y:5o?:7[EKWKO2__Kߠ}m7ߕpG|,$?%>_J }mhwi_x5ljU[;z4}-'oKs&f;ZpaIIo/EC%ax8*3Z2&CǂπsFCpO?x毯iW4gN[K }mmh~vpD;|%{\{оm=ׇ~i_mף9D2;M%^E}pE sĀD'?x4Wϼ]#9ssi_x< ܠt%\>6S4JUWUϼ5Nr}= o> Y*-꿍o'>wK }m{hσh_xa ܰt'$O\O>6SS49WϼyEj* o䝀'x|((|$\Ӿ6<ɷW6wOi_6/īhɟWy/Mܤ̗,>VWy/z4}}u[toWWqdp?5opn^Hɨ?x=3^2!@W|IWd׼?| 8hJix)֐pIk5 ף}m~-K?:npoLO|eտ%3ooE{K }m}hρh_x`ܺt%G\G>6S4XqWqϼ<NpBOmJ9Krv6oC7Ino}m[h;;i_x.ܮt%\>6S4QcWcϼ8yZL o? =ۗ倫e'x!y3">Iߧ}mws}>|pJO|$_\_>67s4{W/#pXoix)߀_gxt$/ 3@20Hh083o >c$c/?|W8w-GNO?xLL>6s4gUjWj/Ϳ:npV:W '_xl pϢ}m hϦh_x_vs}N\>6vS4Gv9ߙw!>{H }ms}p@O|ْCCiy09s耫h~=ܳt%'\'>6S4tWϼ&9Wr^ o{sҀR'濌x\%:꿚!>Kno}m~νKMr{;oA6S4g/W/ϼ+SW o ?MMuZЬYfپ[#^Ͽ:7e WͿ$*z<,p/K _8XV.oGuS4?K:\hy#MO箒nW7~ .t#p}G#ڹpWi_6Nm!WJ| z"GJF\h?ApTz?]p7>6xsdJ?~$Y9_W?΃KYSVտoMCJRUտooM6 S4ɩWϼ9Krv6 oˇyX>J. /}mh++hyJ93Grm- o_~8s䖀'濕xpE&^E￝<p?@#6S4?H }mh~^pL 瑥)y+&>K>?}mh'OOi_x_?_> ΣJZM o#>?H~ }mhoi_x_?_>ΣKW_o'>]KZ.-hyKK9ӥd)ϗEeI뀫5o!>viy?%sNWg׼ͯ/ 籥 {>6o)_p7>6xgd`?q G>6H)3V2.Gh6FS4?I67}m-h~lpoKp6u[,%߅Ϳ+ݟ{J }&hmOs䰀0'?xG6s4ɥW/ͯ/)\-&꿆O|$7\7>6Ms46W/pZϽhx~)䑀gx<)y*6KS45WϼyGn. o~:M?̕|pL:oB?|!2oE|pG3$WwgAC$Cϼ?}}FIF\i_x 9pS]kW )3E25JӈhjrpBW?sKYKvտ6oC6s4?K6 7}mMσ}lpoMO|$;\;>6Ns4g7W/Ϳp_Ͼhx)s䐀gM|hyt9#opC_煥\$8꿘/!>WH }mh|亀:׼=Ep^T-[[ix6)sng濇xɃW/p^\''hxI)乀9gx,y%8/)-W۴O@a!3oD|pF_ 祥|#pϣ}mohϏhyg9䏀~༬t$OͿxtk!ip}nRi_62yZ&oCmhO$ SgoO+JV W}mh55hyM93Cnտ. o~5Wd#'ߘxl."߂$>J }m}vpJOg/W޴xU49@r` k?|sJ9Lrx8oAJ~ }m߉hߒhy_9#Y}u37/zKJZ\hx))}9WϼͿ\u/͟-tt ;>6g)#{3o$>}%~/ͯ^yk>> @hPɰ3o'>%c1/?68o+G\݋}mS4gdZ?|U$\Ҿ6jy{>kK ס}mS4gdgE;Jv w}mh==h_xO;ἳt$\>6S4쀫63oJ|pN_gS}SyooiO'Wϴo6/34Cg'p>PzK\ hxG3)ޟ-%&fKXZLտ o/ 6[s6W[yz4?=&=\im34?=H\]imnТOޒ>W'K\Hɨo&kdB?'I&\i_x #p>RJix)ﳆd̀Mg_x+Y/_GKHqտ1ooBJv w}m݉hޒ}}hy_9s䠀 ?q8/pWO$9Vr\3oOH. /}mhei_x '|t9kkix:)s怫fg濅x?pI Φ\оG?cWcxqU4i3W3yY|$y9_!yCf&3oEpO}mIS4?$鴯xEU4?JV W}K#pϠ}muh~6 g>6s4?J6 7}m_}lpoKO|$;\;>6.s4gɞW/Ϳ+pRhx@)3[rh(3oFH ߥ}mhGW\gx|." Φ毯o%\ѾG=pBoJ6s4?,p/Kˁ;ާW[IoO|WgH򬽪Ws93X2$BC߃}FIF\ix Fg|ɒ)W >X%_W%>kJ ע}mhzi_6LljƒMMh_mMף^[J }[>Kvw};燥g7WOͿ>}}iy?9F$\Ӿ6!Q>GH }mhqiy9sԀT? |.sK9[rNoKJ }m뉧h͒[[hyV9s䮀.8?)ɃWOyLx83o?A?o#}hxs⩷|pCG#:'i??D$\~t%\>6|)~{78[>Vst$K\KѾ6~_,z+HZ\ix w}_O)M?$pw}p~YOOIo&>% W3oWh~k o ίJ.p}mS4gd\?Ͻ/{b?? 4}=M2=NϗWpNkO|u$3ϼͿ.YW,ϗ}6lpoN[O|m$\>6vs4g'Wδ/ͯ/σs^>{J }mhhy@93[rh( om>GK }mchωhyd9s䌀 ?;8+<WODri)3o_FI\si_xctyWOM|?]+xͿ,%5o?s>I}mhςf4 8MoYxMӔ%%h_6~ ,z>J }m剧hV.oGust%/ͯ/ 篥tD\ixO߀/3o#O5Ҿm~|78+gdh?O|QWhgCKf\3ix)ﳱdgߔxl)*ߊ?t$;\;>6NS4g7WϼͿGoտ/ oW>K }mS4ɑWϼ9Nr|< ow>JN O}mӉhْsshy\9s䢀"ϗ}\p_IWO|k%\>6s4f-W-/ͯ/ gSӿ.Wݴ6=s$\ҾmWci_6_yV\o?OH> ?}mh~>|pF?'^E䛀׼?| JQSoL\Ѿ6?>_nMB2mI[}'>},p/Mt+HZ\i_x bxJ}Ӏ?}m,pw}ms4ߧWߋrxB(p}ms4gdD?rx>6)3Q2)DhtɊW/ͿxK<}VpAkO|uuiy=9;Kaտ!k|qJ }mhΒ]]h_6K(g/W޴OͿ9@r` 3oD6S4]{W{ϼ>+8?_Ͽl>_J }mhwiy9׀W |9Xobϼ߯9M'^[2_[/_~WOͿ? \uϼ͟|WG}p}mS4ߧ_ߏ|&sߺtaW0'NS%iO?x"Y5_W#YKvտ6 o߶t  hxDiտ)3ooF6 S4ɫWϼyKv6 oߡt%\>6\)|&<oA?H\h_6KIs3oB o/},po_xҒeeh_6īhkI 3s>ܿ}ߞ;O"pw}mns4?{Iz\i_xx<S?pg6x=ߟAW`W?xȀ$? +k/pO}mF)ߟIWdgBW/x<}<p?FO|%\>6s4EKWK/2x_<SoH ߤ}"^毯$\ӾmW䓀׼)x?<뀫k'xhmgqU[{wp=/l?ix?)ϼЂxaIIk_ ,lOhx5M__ jHoNW'7z38\A~^jp}{GW o6 M~]3 mxg6?$O?x毯1WXgGWJ }mhuiy9F[$\Ҿ6~wva}pCO|%\>6s4G~?nx"!x!<'y>_ >H^ _}m׈h~v6 oCCKPQo%>I>?}m/h~0/G߂+'WϴO Cg'3oE%\>6s4?֒6WϗGG#ϕW{'@qwߛ,G^+Y՟>6x >69#[p}m~|yT>% OHqe%_|4t>kH פ}mhϺhy}9ﳡd#ϗǔdˀK'ߊxl'>ߞw >Hv w}mǖd'ߗx(9(?&>I}m~|a}pGO|%\>6s4LYWY/ͯ/.l  ix")srg濂x+H\sh_6~&>7Ino}m[h;;iy.9ߟ$\Ӿ6~/lϣhxq)䙀gx(y)_sa}ސpIoO|$\>6s4c'W'/ͯ/>_I}mohhyG9䷀7ϗ''߀_'xdYß5}Mɖ [Ѿ6~t6'[^Bտo&>ʒ?}mz9Q)D {>6/)O?O s4Gwـ oSSJ&p}mS4G~\ciy9+e|泰>$OͿ"YUZտ3oNJ6 7}m͉h9ZMտ kϗd瀫g'߅x!3ߓ">I}ojْCCi_mÈףɎpMoC^u倫eg_xg ɚWy_?_^ϿN>Iק}mS4g#WƴϼͿ Beտ%k |F>Kvw}mhϮhyw9F%\о6~.}pLO|%G\G>6s4XqWq/}.\p_AWO|9kkiy:9s怫f|&f>wJ }mhhyA9䱀1ϗ7oP3ggix9)倫egx!y3YxY/ ?$響U?|pJ?#^E_I}x KAc#oD$ϼ?x Ӿ6~)ےd\??xK>1HoO"o$o6~du'_xG~g\3hy]9:pϢ}m 7o^WOͿFmտ-3ooG Ҿ6+ ɗWOV]3oOC$C60h(耫4?xȳh i?5;3E25J:oO#^49V W}W%>kJ עo f~Y_23IOyƒMMhyS9F~}aVWV/Ϳ5x]KWv w}mhniy9ﳏd߀_|7<SCCh_m##i_6Qīh8WyޟS%\>6S4?gK ϡ}mshs䢀"O6{( ɕWOVr]3o_O?M[W[o6{nix#)>|pF5-&ߧt%?\?>6S4wWϼ'W_ oϿB2lI['>,p/Mg Wk׼|?<~i՟>6{tt >6W9ޟ=%^/|<B(p}ms4?%#y$xJ'p}m S4gdR?'LpH+?t%k\k>6S4gd݀]g_x̒lpoH?t%[\[>6S4g[vWvϼͿ=YKտ o ~0}祁{\{>6>S4G\>6As4PaWa/8!xCJ9Frl,oG7Jn o}mh]rG3oI0 >H~ }mYߒhx_)3HA&f[tAKH }mVGZ>,p/O+O|v9A1H]A=Oߓx >69WNSPɰo'>%c1ϼ?xȟUjW cǖ3U2-FӉh*UUiy59|d퀫m׼Ϳqx>?hdyz43hɦWx3U4g+WִyǗޟ%;\;>6S4?K}m=pG?t}m쀫6oJ6s4Gw W /"xK9Mrz:oAtz7x>tրVO6m'O.n=W=6|%\Ѿ|%O\O~?J>I}_ ^"y5 x%y;xSKPQ?x=s7x >d^?4,p/Ct%m6/ <W{'@Oϗ}*<9LSh]QRտ3oLNN}տ=o@6S4?I}G9Frl,kϗW+?&>K./}x?I./} ^_#pϡ}%7Jn o}oACrg'oE6S4EKWKϼ2y]F o/*=WOXI 3oJC48C>VS4gȒVW+g_x YN|տ< o˗/-G!I՟>6=߹t ;>6g9#lH o˗/+ݧߟh=p}ms4gdX?_翼t1WX'G6 9~~2SAտk~%}6lpoFO|%\>6s4gGNWNy_?_ U>{H }mh~iy9FC$ٴ/(xK9Jrt4oC6S4~:D~rI ) M!W\WѾ<}p@7O*-꿍o'[rO o-!WôOyBd$3o?EVC,p/KOtm$mϼߎxsh= o7o*ݧ[ߍO|ޒ>WgK6T)ﳒd倫eWͿ *ﳆd̀M7z_n75}3t=W6LhyFimMghӆn!2ߒͿmxJ^CտͿ#z4gWnWno634go>W>m}olѯ$\>6!S4>\rD3oIJ }mljhӒgghyY9䥀%n<ݥ!y3">Iߧ}mhǒOOh_x_?_O>_I}mohhyG9䷀7ϗ[?ix?)~&=y֜okA>3lIIkϗ߷}-/Y!_[O װ$OhyxgY:S߉C3IhO?I?3o7| p}m~|< >6)3F26KhÊ}m~|A6S4gUjWjϼͿ:Y[Nտ oP>Hf\hxC)ﳩd3gߜxl-&߆d瀫g'߅x!3ߓ">I}m?RlɡWO9Jrt43oCJn o}xK=ހ^'濏xG{8!kBd$ oO(y W O"yUZ3oN6s4gۀ[ϗ?Uϒ__hxW)䯀/gx̗,оVz?4E3)KK>6S4g2eeiy993mߖgϔ^!@hOWI3ow'ϯ%}>y_?_~l>2pWix?'%C!o6P>>R2*EFo~.W#_#^OL оmīh~VpLW|>kJ ע}&^'Y?_o$^Ed〫c7z_?_~BElpoE[Og{WϼͿ#]#h_x_?_~b>H }mhAiy9s䈀?%?O >HN O}mӈhYi_x_?_~r>J. /}mh++hyJ93Grm- o_ }npBO|;%w\w>6s4~W/ xWK?p?NOO<6ـYW*/\/ӾojM[W[6|%\оmW|O$\Ҿ|-&OǀGgx7W/x7JW_o'>#KZ-hyDK93d)_M6J6S40bɶWx;U4;Ivw}{xJSWտoM8uy h~\ҾmWpϥ}|!2"V]3oOWϗ?VO7Iߝ{O|>W_gG6NS4g7WϼͿGoտ/ o_.`!W!O?x!92?">I}mSϩhxt)s䜀g?x\((꿈yxy\!2꿒"h_6īh|䖀׼ͯ/t$w\w>6=S4?H }mh~<p?NOtg%\>6S4e+W+ϼ*ySV o@a!z4}#? ?}v7W7o6<?ޟ%?\?>6S4?K}m?h俀?׼ͯ/qgT Iˀ?%?jqhzF-%Y:_o/CZA:oMۀig=JW?:K\]hy+]#OI o?.GU +O͟O|AW gLJ }>;Kv w}w{Kwտ7Ϳz4w:@r`  =J o}pK:oG9Irr2 9Crf&'x,?s䂀yBhTrY+濜x?\-&꿆5o WE()꿉o&ϯ%w\w>6stJ }m]#GGix1)逫igx y1_O>Kߠ}m7hϻhy}⹷J>?oB|z"|pIIϗ}-;WOFpJ~㨿i_x-z?^,71'ݜx^Bdտ$3o">,p/G|<}uWo'S4ߧcߑ;|n; o__PO_Io'>MMpϼ?z>C$C/͏ϗ[4na} l o%Z_}*~=E25JrdՀU'_xg-WڴϼͿWL-dӀS'ߌxl%:ߚ!>;Hv w}m~|ܢE>K}m=hϾhy9pBg,HQWQO49^rB3oH_n$}<p?DOϗF?.y" x>9YsWso6JyEj*oFH\hy[9F%?\?Ѿ6?>_n4}pIOG~=?O#^ipǴ}[c_Ͽ̢#eehxY)ޟ1%m6ϼߖxgL$ S-/[OI׀+ow#>$޴ϼ߇xȻ8pWh_x?_Ͽ\>$O?x G>6(93N2>O|xK$pO}m)S4gEJWJϼͿ2Y]Fտ o }֕pGOy̆h_6īhd ׼͏ϗ[.g;WOͿEkտ++ߍxKwտ7k-۔s䠀 '?x毯$\>6stH }m~|ܢ-m>'KN O}mShϙhyl9s䂀-\&<꿜 >H\shyZ9s䦀&7Y|;$w\w>6]S4>WϼyDh( oxyZL o?K_nQojCƼ'y?ux=XI +x~})*5o }p@:oHMg̯hm߉gh?cpCFo ~K}m~|+~i_mף쀫6+?xM?_=RrTkϗޟ$'\'>6IS44W鴯x U4?Grn.ͯ/ww/b%W%O)__WJ }mh~\p_Ox毯[%\ѾGs䞀W/*䡀!׼0xO<ɀI'x9Wϼ]#+WWi_x_?_Uےwwhx])ߟ%\Ѿmīh~>|pNx毯yooi_mף>?I~}>H }r<3_ _@[M__ZJ8M k_ZLտ o/ wk#ip}mvS4Gw\iyu Ҿ6~5N޷q}>6_h'\+k 0kϗ;gdT?GOL'>6#M?5M'ӾS$Y9_W!韟[Cfտ&Ϳ YW^տͯ/?ӅHqտ1ooB6S4go>W>ϼͿ/9PrP ogV ?.9"?u?x=?+9.?oO'KN O}-l~ΒpMO\ 0꿐/">I./}2o"6gڀZ'濎x&WʹxU4ɝWy_?_XhxA)ߟG%\>6stOK }m~|yP>/I^_}mWh77iy-9}ϗӀS'x|%:!>K~}mw'x#7#>78ӾVx|y(JTտo/M6s4?JV W}mGGޟu$36 $Yo634>~SfWfo6J6mmix;)ߟ$;\;>6.s4?{H }mGG䀀'?x?%\ҾmÈW(WѴy1x毯%'\'Ѿ'G33hm3ghƟ+9/?>X<}.\p_J:o_FUi_65īh~p@olѯ$\>6S4Gro/3oGK^_}mUZxuГ䝀O6~im$pϥ}soL%:%//h_ϓ|pK 4'Wϴm~|s6J }mh~K\ hyq'8Me86g2eeix9)|F6oKϗ >oOela}J\hx;Mτޒ>WgK6P)#Lp}ms4?|„kϗ=ma}{Մ)W'J{K }T<}pLO|%G\G>6stJ }msԀT'?x%9;?!>H. /}m~|y:z>K}m+hɵWϼIrs3 o"}pEwO|%\>6s4QcWc/ͯ/_tg$\>6sS4%W˴ϼ ߟߐpI+䃀'x|"4?#Ju5 o˫Ac#z4wW*ߟ$\Ҿm~|yU=$=/ͯ/_t+S4gd`?|aWpϗQXɸo'>81Hh8=Nx5Kqu'_x#pϠ}muhYW,|-H }mhNi_x_?_^Ͽv>{J }mhqWx@U48[rh(kϗSђcchxX)ߟ%'\'>6s4?KϠ}m3ggs|'激xɥWx2U4?WI}xuKArc#oD ҾmggˀK'x|+.'kYK o ƿ$\ӾGׂ?}[ňWԚDտk_|֢OmYrWrOͿ<MO]ߎhzj%/|C$Ѵx *#s1o}kԦH\Si_miO֚\оɿd-O67)?]mf?7 6 7}mMlpoE[oGɎWomDӿVM{տ;{pKߏ 4i$\~pߦɑWOqiy9FS$\Ҿ6~9}ΖpCO䢀"ڷ6;\rEso_I| z"H $o_͒[[h_m[ף;%w\wѾmWh_6~%q'xg$\>6sst/I^_}mWoUϛhxm)䃀gx|"4[䛀'G%+\+>6JS4g5WϼͿ]#:W ϗwX,ɆWOͿiy 9#ommi_x_?_ ϿS>;Kv w}m]hϞhyo9ﳿ䀀?|g<Sšh_mÉףђcch_6īhs䤀$׼ͯ/ߥ!93?"9Or~>3o_@6S4a#W#ϼ(yRT o˻w/ɋWOyMz:3oA پV}&.!Y2_[OtJ }mhĶvW;ϗ753cߑuDM?L&ӾmīhgbI߀/kϗSzK6 7}mM_Vix)ﳃdǀGg߉x{ww}m~|<6q?'ߟx,9$?g|#$G\GҾ6~| }p@'O|S%\>6s4l9W9/ͯ/?t$\>6%S4 ɕWϼVr] o_~0[$\ҾG%]io@#i??t%O\OоOGӿ5YsWso634]_pB |6v>oIߦ}!^| 0 x|*,9xC-ɼoK6stK}m?d~?ͽͿxK4EZHZI-i['Mۤ$K\K~!>Mۤ$ִm6㾇/~NIi՟>6{sRgI 3ow%S+Ex#J%*W3⩷J\hwDW?\2"A#Dӿ6id\?ͯ/652I\&\h_mg&MpHW"^E?du׼ͿQxJ ɺWOͿ_$\>6FstI67}m~|h<ѥl+.ߎ'>;Kv w}m]hϞh_x_?_>L>ix )#?L:,?'>򼓎 }m~|X<$99?O!>gH Ϥ}mhs|׼ͯ/?tK%\>6S4j5W5ϼ?xɍW/ͯ/?t%w\w>6S4u侀>W?*IK }'逫i'xɋWϼ__I^_}o?tw%\>6S4g〫cgx ɗW/ͯ/?t$\>6S4ɯWϼKw7 o~2E}͉h%$K\K>6+93yYrWr/ͯ/ojbϓ:y?!^ϓ;H:\i_6'U4}Mqw}=OZzJ\hx?O_\93o ~H\Ci_x_?_> Z>%c1O?xkW 93E25JxKYEjտ*oF6fS4g+WִϼͿ Acտ# og,gwWOͿ'W_տ3oO!?O$>viWi/ͯ/?ts$\>6yS4"WŴϼ Bre% oNr}=z4sրVW*Krw7kϗ[z<p?DO<.y"$yV\ o?~}^pJO|$o\o>6;s4ɇW/ͯ/?t$\>6S4ɼ3oK693eҒ,~!E3ei2W2OͿ,MZ&oCmh|ϟ\) o/*ݧkߕO|^WogCz4]S6lpoDooLHv w}w#>{Io~9f~9PrPoL6stH }m_QɒSShxT)s䬀,g?x{S./}m /۔iWomk$s9__ݑ7Jn o}'oL zopA濓PT+/꿏Ӽ?UH }so?F%)OI}{o?C#)/H^ _oD|)\~ >S ߥ4o~5kj6Wq1oBU~?:4Jo#WhO6~|=#Z kO_O%OpO}mistMUUh_x_?C>kIצ}muh~MMh_xS7d뀫k'߆xSw w}mhni_x_? S>J }mh~<gM6%S4?++iy*9zuWu/=x[K~WOKrw73oCI\ixMB2OkI['>Ӗ,p/Mˀ߅kLk-ip}mS4GWJhOgI ow.ݧwߛO|^3pWhy?#ϴAW ׼?<= G>6()?O'?62̊y čdz@B۝!Fݕ{N ߪEQyo잞9mԯ4;HϞ2{\{Qi~}|Oi?e\]x+)+EO&^p~^~ S?4)__cd\cyY!$Wd3SfV?gOy2<Ϳx,/ߏ8"sh(OF(Ux5__|pAOIɯod ~{OHi??pB*OJIϿ:)Wyou_ǬS]y?VY#_U_x5i]ϐttk=͟??Jϝ4 P?4&S$: Eտk<Ϳ%Z$}鴭vWvԯx_q~=S󀫿9O@_~:- Q?4S$E_i"u77_4>_~dߧ~iH~}}"i)3OF_~ en o~iH2w\wP?4s$^_x_/%<,H<(j$y*5x-~Woi)Gu~-Ux5#\PEχ2\Qi~}.*+2""wWw<=Y!2\P4>_~t%w7<j$]?]$ 8]QS]V%^2k\kPi~}>Odק~i H~Kp'<_M*ήi՟Ri~}5*+~{NMMx3)^]W<Ϳ Y!kM_C787ip~iHޏw5ߕw##y?rܵmߖ8]K^];\_iW#%]\]_ikwp~{OKd\Owp~3O !y?rul?=ͯϟ_ed)W'Jg濟x!_x_?Rϓ2O\OQ?4S$9穟y9̫W/<ͯϟ-mwwx])GWG<1\拀 Ͽ#~pGOpBϑ?e ~i_y?$ 8Q?TUHOeנ~i5HOue ף~i~}Gi?ݒ?~ij)XI߄7!#W7aݶ~O~>ߞO;wkp7~iH~ZpD;U2O<߆xߵ[p<Ϳ'Gcߑ8ߥtp~iS$璘L3O'#y?e\C_x(?8?p~i1S$gĀ"3OO"#y?d\ө_x_?[W\'GP栀 W<08!sd$OE?~iOH~2"#2\QH/2\R?4oS$/y9=_T<_{I!{pIkO~c}g߀x_=?~i~<_HOMMx)BfˀKgߊxg;_4?/ǙV$G>!߁[Odvw~i]H~ip~i68ui?g{pI{OGGNW'x3Z$_?ez\=_4?/=׊/'?O*O ^ p~E~FɌGSi~<_{DIW$'L_ߴ7e ߢ~iH2\P?4s$SϨ_x_/ooV2\P?4S$Gyg9W/<ͯϗ77/UV?Y?TOgݬpFf_x=זY'_<ͯϗXy?=~FWFO<_E8ߘϑtKͨ_xs-q-KFfۀ['ߎxY{\<͟ϑ2;\;R4>_ ߪdvw~i=Hޏ\=\yBsH52\RFÛdno~3OBgY&l,O?G ?~iωHޏ:8(SOL߳e./~i Hϥ2\Q?4s$jkk_xZp$ss3OBdV 8}V~>HO5d פ~i;uIϿ/Aտ<ߐx5^_}d}jx?%^i"Iտ {)xgsi?[lpoE*OoMI?g{fW3oi56o.CտzxKi?;pB*OJI?֧L y- I?G^+} ~;O/w#[WgWy j$劉Lπ'y ɯ~2oi~n8UVz3TfX?Oƞ_,$_B&ߏxSO$sp074!)̑WG I?GpO]=ݑ/}N O~wO_g˜pCO>\Q?4sdr犀 =q\'s}=O@w\wS4>*AWR'xqǩy 9#}\˨_xY8~^y9_!"y?r̀Mgxq_x>8~>,?'"y?r뀫kgx c# O8]e~$^;?_k<_4^$}:fs?Oߵe ס~iuH~60ߐ7"#+ξF/<ͯϟW~g\QFWnpoCOoK׏پY՟QiZ8RfǀG'oE|U浀5W<ͯϟG#KyG݀]'x|$q13OB Oo>Sڏ_u_M)i"Iտ 3O7%#y?[lpoIy,?e\ͨxx4!߁[ϑdvw~i~}<WOk6W'oK\92\R?4yS$}E2\SE~W\p_IuIߟw W ԯ4īEn-꿍<; نwpC|*?2\QF~y"<$ ٖd ~;O/O+W+ԯ4ī7e ߢ~3OMp?EϧC_p@zx}$_r<𵀫574#swwo܋|pDo>K~_\_R?4WS$߿﨟y{9B~K O ~Zi?r<o'x T/GSV%#i?yW/<ͯ|:$ǃק~i Hޏ%WBs$G^\M_x3p3JA[\[R?4VS$GmpoO͈Hޏo\ͩ_x_L~xWO<Ϳ A<߆x**G> pw~iS$GVp~is$ݿ A~ԯx?8٥WP'F?~iH~T泀3xsH~^.u5+b~~)&"W<'W激?WoO)Afog߇xtpw~inWW[O߇O2AOHWTgFG]!ez\=x'r<_ߏ<ߟxcO!W74PM;_ GQG7yȄ4>~}x:O "?2'Cs yȢ OpJ!\Q?4S$GpAGϑr\ OqK!\R?4iS$GpMϑra! O_~Gi?r<䊀 '濒x먟yz9#_/pBN~xWO<!\R?4R9#C ~i~}|Wi?r34ߔ7##y?r~e ~icHω2'\'Q?4s$t33_x_???Ry2\S?4S$KKy29sW/<ͯϟ-Fxf)sW<'__4>~ ކ>p?BO'e ~iH~y>_We^ _~i׉H2\P?4s$C_x_???Q2_\_R?4WS$[﨟y{9/W//<ͯϟ,/x)3LrX?3O[x []f OOaɬpOOt1L\Ò?~"yXc&WW<ͯϟ.g --x+)~>av2\Sϐ pD/cH!f&y-=WoilDOd> ?ƞxOWroioie~fȝ/~ Ξ.a\P+Y?TS$?k\kQ?4sdr<|o*ji?r<< S'oD\=7 R?4s$GopoE5~𚀫3)#[\-y%]]_x_?^ڏop~ivS$GpEHޏ?pw~i~}Fi?r @Hޏ?p~i~}&fi?r<|l?O?>9LSHޏ?pϤ~iYoo#\x\Q?4s$`CC_x_?]ڏ?:?!"y?r<ĀDg?xө_x_?Sڏ?/?'"y?\p_Bϑ~U OwqwK7\7R?4MS$GpNwϑ?~o/ O^i?<p?LO?d$3O?E~=ՀU'xy9̇Wԯx_?%|e~$^?Fۀ[x;HO2?\?Si_??,]?pEO#pkIr- y?!#+Xqߘ\ڏ[\[P?4S$g[y{9Sg?~i~} Ii?dv w~iH2{\{P?4k9__#*WOuI#pw~;FO7WwxZ$紐L߀/+ϟ2C!O^//.x)̃W<ͿxQǨ_x_?]32eO<,?/ʼpDOL2o\oPi~} _GGpO*O@c#> ?~?#^!oi-]??pH?Od~~ ^#o/{?pV~F֗ipKx̉WO<_xW<Y!<7?K~X撀WyRH(# ~&^䯏r<򆀫W<ͯϟ+6۩_i;W#y?r<ހ^x>HT桀!4>}__O<p?IOO\Q?4sdr<򕀫~ޒy;!"@ÀCx#H~}ϩ_4>_m-OG_ke ~i뉧H2\P?4s$N_xϟ4̃WO<Ϳx<*X3O?Nx~H~}=$p0+;YSWSO<4<p?OFxcO"j*x5M-WoiwBMd> ?>7]WO<%|pKFxc$|d~~sOB~>j3<8v~xʘ:fzSx}$dVW~i5o/ǬpKZOG9 _(߈{zϟ`'+1w8oLMH9FD\S?4s$1\Ri~<n3y՟S?4s)#cZ\y'_pNxI+#S +O<_OyOտ3Ow$#y?unW7uIp~F1rߤt+s\OO$?ߢd\˩xk)W<#U淀7[[̿WO<IL?>3Om@yE3SfV?gO|̓pϧ~is$_?Kd ~i~}9DЀP'?x%st43OC"$#y?|pK|y~~%%"y?pEϑxʸ:fSr WO<Ϳ&I?zWzԯ4kp|WpWQ8~4 P?4&S$]?ㄍ"߂$#q\Q4?~8]8qkp7~w ^맕NWNԯ4kqpA[[㊀~i=H~pw~iNs$_?d\ݩ_x`'~ Q?4)3XfH?ϑ2Q/ݵd./~i+H~kky:9Bdno~i~}ο[i?wpEwO?@3O?HnYy?Wpק~ Hx?Vտ3OM S'oD\=?4oJϑ?Uտ Og|aE~^t|M_C-<ߒx\P4>=6mߖO?Wտ3Ow #y?rj$}v2\PEϕ2W\WQi~}7οwAƀF'濉x6۩y9{d ~i;+WO<yBɀIgx<+\ O8]6$+2\RCOF ߒy;{5ȶ@ÀC4>w*]?|pA_O||#m-3OGw+NWNO<Ϳ3]fgoMWAןg'v ;Q?4g)'ʵ6G߃{ϑv|ޘ/G#\Cx%3:Mc yĀ" Oo#g\3x&IGy܀.k^ڏ?O2꿒""y?r_ڏ|>oO)Afog߇xtpw~inp p~iS$g̠3O&#k|ޛ4"A >Xڏ\o\㩟x"35JӈH~fgS4pI,Yp/~iES$gy@93Pè_4qɥ#sl,OG_x_y_y4Ux58)_ig"y_4q5שx )wd ߥ~iH~>8?(]?_|pE*O/'^;_i"E׀WW<ͯϟg3K2\P?4S$]?ɬp3OOOmߖpJ)O<Ϳ7)].<ߕxg)^/<@~x O""%S\é_ik)cԯxA8A)W'J(?&#+\拀 H~.'"y??pBϑ?e ~iZy?S% 8SQ?TUHeנ~i5Hue ף~i.G{jp'O<_MߞO;Omp7~iHzJf'W<Ϳ38!:oMmHޏ]WA{ϑ|#1HǕ]G߃{O2~<ߟx p~iǗ3Jft?O 2/M=2?""y?r=O=>?O #9EԀT''s9W9O<.IS/(꿈5濘x-e~|d~>꿞o "y?pJOFKnW<)8)<(4_JOzLqgx<#,_F?Kz3%_iWW##2o\oR{OEنɼpO4gWgO<9ry9Bd~ ~i~qK]揀'x+_3O93L_Ǭ_x53p3Vϴe ס~iuo(aտ!y#=/iFoi7E o6 7~KOoF:ߚ;yx_N k3{_[PO$r>׿ R?4;⩧x^W^oi#WWg74-?<6t'?xgڹW<H‫b<~xUWUO<5i7\7P?4s$GpF_ڏO7꿗#"y?Ke ~iHޏ?O{"翠?\O?O?~ OA|G\PO{W|$s3OB_~K)gV <_FLyOտk<ߑx-/f9\ݨ_4>_~tp~i~S$_?d\y׏p~iQKqpO~iS$g̴3OO'#y?e ~i~}Pi? e\x19@@g?xח<X擀 ~Yp/~iH2?\?P?4s$Wߨ_x_/??Y?2\R?4S$g֪2_~a2O_/$꿄OqKJꀫj'濆x sc#3OD2<߉xtpw~iouI7L74 ޟgp~3O%!2Qoioo 2O~EրV'濍x˳;꿛5濇x-1_4RpJyLq'x32e<,Y!2/\/Q4#fpIoOgpOϑOd> ?~i??*gWO< AǀGgx&{; O1_WԯT|p^}48u5_x-]Kf퀫mW<Ϳ'8'+_?60ߐ7""W}\yc9}lpoJZ2\P?4S$G{,Ϩyx맅Lˀ%+3~v-ߍw'"y?me\y=^2/<Ϳ78tpw~inS$輪L73O!#y?d\_x8 p~iS$g̸3O'#y?e\S_x*8̒pϦ~i}H|Wg_H3Oo@___e~ ~i߉H2\P?4s$}'pJ__g̓mZWZO<Ϳ6IW<ߐxg]U\/<͟[&2MO<Ϳ)Rf+gߚxl/,oF5LO$"y?;pBϑ2m6/<|}~+ߋ;Oy^'Wgx Z$=Cgߓ< |~ P?4@)2a|R橀)WyiHWԯ4 k̫Wԯx5qK2\P?4S$_?|pDϑ||.E O K|pG<=Iw,K yW/+=7N8N+_? % 8 Q?TUH~.Fտ3OIߞUoFIya󀫿94k|y^pDv|WL뀫5O!"˅E_P?4s$_?t ;R4'pJ.#A=HLk<ߟx-/,3$B^(Wh'C?5?x->,,Ux5\뀫kxH2?\?Ri5mEׯe~i?HWS$_?]d\]yO/WoοOi?e\x0.3"A#HXqW8XWT'FC̀Lx,H_tWoi u_.,꿌U濜x5s5W5ԯ4kF_4]q;;x.)__pOϑ?,H O? VS2O\OS?43S$_?˼p@OHϫ2\Qiuɯwd ߥ~#^|$q1k< Z$ //_4W=p;著x)__pJϑd~{dV 8W~H5d פ~i דY?_7*Gκ:ꯦ~ix4$߄ϑ-d ~i{uI?ip7~kW#gqs_ikZWԯx>8ZM߆O|ȿ==y/9_X)D}K=O<ߋxp~is$gЀ( O+g̘ O%"y?e&\y2.3#A3K+3/GHb%Wgߏx$sp0 O>Pϑ2G\GQ?4S$xyD9siWi/<:@`i?ȜpKOd./~iKH2W\WR4UpA\/sCOHZg2\S?4S$kooy[9~>a2?\?Q+??x/)*ȗ_ǬyH~jWj/<Ϳ:pY̺WO<ͿIYFWF<_EW4_8# SCW#yȀ$y 8Wx418UV~*3-FӉH~-oտ/3O!#+_ 0_HcK9@@'?x&sx83OA=wA?Xp~9?O8q?pR'0of?^!p,8q?'vkC?T '4.ӡZ6|6н\K7qsshuυ~Rqs h.t/~RM/Ki;\͡,+ir~l'x\Gs=SK~>Z[.[,Cr~l':o.Z-|p~T?'g`0cKp~FЌtGB?T(g<'8q?Si9\Ӡ[:3f?2oo"bK/q~yp~^y3Pf?ЬrWA?XU' 7.7[- '~C._a>Ù|H`GOi>s?~lMN~ 0Hf?lsA?X{'G.[g '7.ߡZGf78a?\g1~l)%'ӔvKC?T?)p~T#Nϑ4cK '(e觖q>X`Gh;\ա[Sg?~jZgs*M].Oq~Τ9? O8q?Y1p硟Z?e~Χip7~T#N4.fЏ- ~?4W8\W@[0ϵ4-.xĉ ops;O-ߚyG>~ip~T}#N}oRO8aGz8oϼ8:vpw~/䄟uI{/p~Rwwgp8 ,?x!'g X,s3f?yKOaޅߥ4.Y <|ǖ_<̃I.Z)|~ q@?X(3f? GO8q?i&8\Z_/gt:g8q?sh:\s[fſ034:\B?X9'Erǖ x‰yfſ `>~ޤy Ro8ӻ4.uЯiǜx!Z_/'g4.M/T 9+-,5"Nfſ yK|'., ;.sx'o=-տ0>әsIsIKw>x ?KӔq@?TY 'a4.[_/':.:?@R 9\_9K Cs5##2NSK^ȉM;rkA?gq~Npׅ~R1YbY4.?xĉ/tN.p>M SKQ|Q4R8q?Wдp[@?TNϵ4-.O-|љR8q?wдv[C?TNϽ4m.6O-/ϗdӎ!!K? <;wC?T<_.qӥ͡? x _]*Tt+B?g#qWrvpW~RG1矚OUc.c,?'.TI8q?g OO))?x .hpπ~l3'y7ip7~jF̧~ѥ1yy/T 9O49\A/sϟ4 -9|\Ms ,-BN 47:\7Bos~n -;|Ms ,/BNO[._R9q?~:tr;ARr~p{@{9q?}i9\R.PKq(h,?x..o`IdCW]f8\3,?xĉ_si9\[>34K.%O-$|gis~EK?:Ӽpx__h^u_~CK|^ymmKq==ǖx‰.Zc3D9q~|p RO8q?hw~j//g_._,տxĉϻhp~R/=4{.[ Oג4:]~R#N~)p~lC'pt-Os8SK|Qf?t֮!#' Џ- S88觖?b>~賢kM&s#NO-.[6S44觖?>~Ӝp `#N]pRO8q?Mh.p/~j ?2Kh.u/~Ts'͕Џ-ޟyK_)>SLs oq~Zp RwO8iCsSK|)8C4;\CR/ip~RqӅyKwc4~zq@R}r~ rA?g8q?iF8\#TH)kx<'85f?O8E3 Rs?6uſRG>p? RO8q?h^p_~j?.48\@?X ǖx‰YKSKy>|@!78q?i>u?~lπ'KK-e|e|K8y͏Y'E_i~s~R3Bf?p `=#N~+Q?i8cKw;x™79?K3v(aa/~ sA?X83f?O8q?i&9\Z2Wf3f?RGy4.Џ-տx‰YB$SK?5>kZ.,տ xĉn/;\/C?T '55觖|3yfſRkGhw߇~lNG4;\C?T'WWg9 <|M cKop~3_ntwBR/ߏ͟ЯicNn{iq~CKM>4_`)/t/KskZp#.#R+;w.s411ЯicNwGs<Yo.Owt9\9K#Nx~2Mm6cKpO-_>~Φip7~TC's.s[1sͅO-ߔZ>~.ip7~Te#Nϕ4W9\WA?TNu4;\C?T -4:\B?X6魯 ,7ʜ ,xmsol~y.pw~TG'^]i9\ݠ[;?{q@:>~ vC?X3f?GO8Hq4.[e3f? RӁG4s.9Џ-?x™BE"觖ig.g,,͋Џ-տx‰YI SK|o:\oB?X-'p R'h>t?~j ?ϧ49\A?X%WWЏ-տx‰;;觖?G.,3Џ-տ x‰p 0߰~z?8/fQx q0Mi4cKpP.àZ_/(Qp@?X?8zES /DZ4T5?$uKqSg?~lZŃ)4:\B?T<_If?gҜp`#No#p[?p~Σ9?F>qV4.f?R\p_o<感/ZZ7T<_i R78ǖo <{.{Z_/,i9\,Џ-x‰D R]oo'M/{8q?i8\[ 3f? |3C3 `q#N$dǖ<̠pτ~j~y~,p@?X!$SSЏ-տx‰yyy觖˛3yfſR+G5.סTjEm5-տ|/3yfſR8c=>q?~lN~ 觖_VK <@R;'_hv:\;Z_/ooOnKqzvpwpo~T#NW4[.-Џ-5C=9\۠Z{?|ϟ., ;.cKTp׀~TM'νj9\[d '^?uB?TiY4.?xĉkO[ '|&觖꿀|3iFs /q~ip~l+'kiZ:\-Z:2iEs3oq~ip~l;'^Ҵq@?o#v49\A?Xa'q{ǖx‰Og.觖O>p~T'g@ cKp~ wC?T3K3`#Nd)ǖ <̤pς~jBK/q~Yp/~l'i9\ˠZ~kJ% , BNjiV;\T8y Z->K<Fǖx‰4.O-%|g+ͷ/Tw 9N^ĉN_._To~__xĉϿ49\A??}|O8a?Kp3-0hu~Ta#NO 4.Џ-$3~rpW~j/Nx}Js, ,?}͉Y$ExП;\1/?^}OS.S,*S ,&"NOC-߈|2iLsq)EEЏ-1349\A?TKKfs555xĉFFǖ x‰66觖꿝|3K A p~T0'gh4cKpD-?|3N3`#NK3/,Yp/~RO2//ϳ49\A?Xy'^?i^r_~l'yy_c^_&hv߆~T'g{{Џ->##觖yY>~6|p`/G-4_;\_C?T7N6.Zg_._,տxĉEcK B?XO)']}:\e[ 'Oy.áZڧ/~T<ϯ>Uhv~R/ϯ>hs~R3?Xf?5hj:\5,՟qSddǖ <.iiO-:|ԧ9?R G9?piBsYBK.K,xĉiAs%cK_<%uuO-=# ?s3--/T 95͝Y.Eӆ>>-? | !.,: <@A ǖ Lf?7p`V#N|}Fs;cK<̃n{.{Z^UU3yAAKq~y p~:tr;A?T<_>lf?=hz:\=, xĉGR'!4C.O-/ϗ_f?i8\c,?xĉH3R'3f?yKd^_-y4._<,yp,ssO-/ϗK4/;\/C?X*kkЏ-:O-տ|3y}}Kq~>?p~6|pR|> |M 8q?pRہ'i~q~jO4:\B?X7ǖx Jp;yK'O?p`r#NOip~l N~ߥ__R|YK}w 8q?~xxǖ?x‰AS R|K4.[_/=Cs.8q?\p_RM'x\Bs)SK7g}**K_ <\Gs=cKϣ9?O8,v\p_ R|^f?\p_`#N54:\B?TK 'F.Z3gds;o ~twC?XӇO8q?h;\Z d3f? RG4. Џ-?x‰J3R|B>̡pυ~T<'gb1cK/p~yrS>~^Yp/~TK#N|~fſ 9K ߟߠyyKe.:q!cK<|J/+-K <|GRO8''觖2fſ R8q?q@?T^ 'g bR%|K4e.2/ <єwC?gÁq]v`_/_Oe*K p~T 'gp8cKp~ЌuB?T8Wg2 8q?3if9\[63fſ2ϩh:\K_RO/ei9\ˠ_^R/ӬpW@W?F:Z5pS6 Z-9/{4;\C5|}'>RGx9Y3"NHq~R[_6h;\ۡ,տxĉ?twB?TqHQ(X4BN|O3'/ϯ4.i[_/5s̡pυ~T<'^?h;\[ ? SKe"r9_q~^Yp~lW'7ht߄~j~y|;~ޥYp~T{#Nχ4. Џ-)ggO-տ|;2fſR_8q?lsA?TNϏ4?9\?A?T<_no4.]xĉq@?g8)}<|_̴R|;4e.2/ ]TpW~T#N.jЏ-sMu:SKwgC.Z?xĉ9_Op~Τ9? 3Of?:\)q~Χip7~l 'i9\͠Z_/7+hZ8\-,%s-MK%cK_~npk5q~3p~ip~j~y|~ip~T#NOg.ǖ ~nR78q?pRO8..T=̟?O[., CCu~lǀ'xtpw~jN;;dӝR=G4.~Џ-x‰L3RCwwgh48q?h&:\[__h;\ӡT 2K3`#Nb%ǖx‰34:\B?Ts;;g%%K <h^u_~R/oҼpFy>~Ѽp`Gxl?p&SKμ+kf?[hv~T7#N6.[ ''.Z2Eq~uB?T?NPʡ%%Z̻￟eh:\e,3<Џ-CסO-_ȼGf?Uhv~T1#NO5.[x ':M SKdޓ3Z4';\'C?X6S44ǖ?x‰9_fދ+Cqρ~T#NO . [B '%%O-)|ޙRW8q?-is~l'V47;\7C?T-dӚNNK<p~~LuB?X3f?O8q? h:\ Z|,yR8q?h^p_~l'4+.O- |yRo8q?kiq߁~lw'48\@?TeSSK_ N9? Ê."״T<感Cs YT34g:\gB?X,'^?woRy '^?isσ~jq18q?\p_RWO8y48\@?okF., xĉvvǖx‰48\@?TGGe̓o<~p~TX'g"$cKOp~pg@?TLcc3G3`#N'.'[) 'Y.砟Zy2yeeKq~^y _p6[4o;\oC0{4;\C?X=Џ- M4;\C?T''d577 <|OcKop~~w2矘4:\B?X7ǖx ^@O-?I|IgxYC.C,_x ~8Џ-_x‰B# Ï9? ~gq4;\C?gqp^ şdij;\,_xĉ9tt,_x'ܿOs6Y|s.s_` 9q?\p_/K.KTs2ϕ4W9\WA?Xj'\Gs=cK<̃f[.[ZV3..K ?#'h:8\,xĉJR݁'4}.>O-ߗL>~ vC?X3f?GO8q?t0|?'0矕_ pO~Tt'g6cKp~,rA?Tb3yK? <@"cK/p~VҼpRkNf?oмp `Gwhu߅~luN4:\B?Tss333Koq~ O8q?|pRۘG.,3Џ-տ x‰oo觖|>8s8LQx!'|q0Mi4s/?800-_>GTv+C?T '\?#R՘//$uKqSg?~Rqs ͩ[.E|EIs8q?wwY?^ĉ9||-߄b>~.ip7~T%#N|}]NscKp ͵O-ߒ>~nip~T#N4w8\w@?Tk '{.{Z 'Of M;q~yO8q?h:;\Z Oeӓ RG4.Џ-?x‰J3RÙ//g X,8yd2s~:bL&YOgCߗF,p@?X!G˙Oo `Giq~lG''h:8\Z_/Mw;{8q?}h:\}[3f?0__HQ(Kqi&8\TDEj*4˯_g\.8YD_ RK'xg.gZ_/>F.wC?X%'^?__^ĉ4o:\oB?o~y*~ޥYp~T{#N~>po~l'x|JSKob8#po~^ȉw4.mY{ExH˯_\?rwA?X'o=,տx'?u_̴(yϿz*MS/`#Nx}:_p~ZUp@?o >TpW~T#NQ.jЏ-sMu:o쇜j9\,2s*M].cK[П:\)q~Χip7~l 'y_LoR|m>ۙ\Ao`+GkiZ:\-[: '&V+觖꿙>~ip~T#NϽ4m.6Џ- M;SK|; p~T 'gp8cKpX-/ϗ'|5f? I3g/̧Yp/~R|y]f?O,uBRO/|B`OG/h6;\[K 'V觖3N`G4:\B?ToNϟ4.O-/ϗ?Ͽ49\A?Xt 'gt)bRO8a?)p~jC/Nx]_?x!'?pW~RG/TuB?o~yϿag 4':\'B?X$'^?ϣc?~l" '^?i8\uZ_{}(z4g8\g@?XL'MC!cK7p~Υip7~j849\A?Xb'9eeЏ-9sO-/> 47:\7B?X&'V.۠[v '..Z3iKq~yp~:tt;B?T'?;M{8/M?s? q@?o?'~p~/ 4.ЯiIcF3|Sf?si9\_` 9q?i8\K_RO9q?74R8q?Wдp[@?TNϵ4-.O-|R8h4.YNEyKo Ǵyx!'q{,"NOg.-ߕw|2O/oKqk@ cKp?f?6>~ҌsA?X<4S.)Y*"N~frgA?o~y=~,tB?Xh:\K[i '^?,sA?T<_Cf?+hV:\+, :j5cK_?cp `8{͉Џ-r.%:48\@?XT'Џ-&ӀN>~Ӝp`G49\A?TNOs.ˠZ_/5iq~T#N 47:\7B?TMNϭ49\A?T48\@?X^'?y9K?ߟyyKgӑ RGxtp~lN~sA?T2B3 `a#N(hǖ4K.%O-$?f,ssxĉYNcK ~ޢyRkGu49\A?TN.Z_/+M4;\C?X 'g Џ- {{觖쇾oR;Gz?cK isN>\p_xh.q/~#K Z\p_ `G?%uuЏ-=3V47;\7C?T??_.SݾRw8q?mhs~l'oGkYa9=NoƖ2B `n#N/oǖ<̃@ SK2;q3f?R#G4.qЏ-?x‰L3RS?0Y4.<4 .ЯaEs)R7T??_.S_*e4/8\/@?XE'^?+hV:\+[ '^?ӬvWC?T??_.s~Ҽp`wG48\@?TN'4.O-ϗ?84_:\_B?X+'g+ͷЏ-fſr|ҙJq~vpRO8q?}rO-Oo쿟s?`Kq~Ɨ9?p~WpW~j~~\,lf?hr~Te'*ͱЏ-? '.Z/9_w_pAR BN:48\@?gS~>3[/)/~F#KG.?<<,>"Nߔ""7T??_.s(~.RW8u555Џ--3hnto~j~~\0>aFs;q~p~~y R8q?i:9\[3ӝ{2?xf?h;\,?xĉB3 RÀ'Q4.O-ϗ?"4.I v?~T'#N&.ϡ[ 'g O-ϗN%{.,տxĉǖ <r>ӾR8a?JpO8'p~&愲Y觖e g}M8?RG .Bǖꏀ'p5 [/Qf?p`G45.Џ-՟pSdd觖͜}9ttKq~Ӝp R ':s.sZ/9Tf?\p_`#N%4:\B?Ts '͕O-ϗT'gu4;\CR7/䄟oL,+"N|iMs'UU2}4;\C?X-hv~lG'xy;0?tf?]i9\ݠ,xĉMR}'4.AO-?1|c2A3 `Q#N8xǖt?~MKosSS7Tg̫K.,տxĉ?|pRۀ'yb~~~RGhv~l=N%JL,p3x￟ӔvKC?X 3P.à[<3"͑O-_>?e藴T8#DЯdjD._RՁoH[M,rR|DS.S,_xĉ4g:\gB?TYN>~b#SKKy4;\C?X SO8q?\p_R|p_~R-Ginro~lVNx[_/w}^^Kq~yO8y11觖n_~:tv;C?X Ӄ{O8q?h;\Z_/y_~ sA?X83f?O8q?j$SKe/q?3hf:\3,? x ?8f?9K/^ĉ?Kht~R|_s4;\C?Xh^v_~lN~^y _g%N|fſ_ hw߇~Rq[_/w} X3BN48\@?g8q?p3?r__twB?XW'wO8KSK|gҁ4I,? 'gRYC.C[3p#.#Z:|:5?)r#KW.48\@?TU '8.㡟Z_/?%z/ssꏁG'vkC?T '4.ӡZ_//N'Mo#-xN:\\״Tc1'v4:\Br]>}~M x!'|~M**,5"Nt[_/?[hnuo~Tm#N|}IscK <̃>.Z-g0##xĉy;O8q?]i9\ݠZ_/M_/8q?h;\[3f?|32O3`#N|J3/4s.9[_/?3E4._ 7O8q?_|pR|l>ٙ|G`Gi~r~l'h~w~j]w*%o=Kq~&?N>/fڏ-?$3`i觖|_ɇєwCR/ϯ\p@?g>&ES 0g羄g2.j?xĉI4.Џ-_x‰OI.k1g&uBR/>O'p/yrC?o9l_~Χip7~/^ /ip7~MK_z=?q1''Џ-տx‰4_8\_@?T<_af?luB?X['vǖ6p~2c~~Zp `[G;hZ;\[N '^6觖7oCCxĉyp~:tq@?TW7oMo78q?h:\[3f?r+>~ҌsA?X<3f?O8q?3if9\Z_/94 ._< x!'9KO+^_Jp3-0;/Gs(KZ0,__YH9+ӦUr+A~ gmӿV :?x.R'2o.4֦ `"'|N]Lpׁ~lS'yNSR|N>{ʹCK7q~Υip7~l' i:\MZ"w9eexĉjjǖx‰i78\7@?T<_wf?y=66KOo =|{2yQQK?Ùԥ9? R8q?gwC?TNxN:\)ˏ xĉiFs cK_ <  觖꿒|G3iIsq~Zp RO8q?wдv[C?T<_~Xf?}{}}x pCCYaEzyK?q>tpw~T7'^?hz;\[4.O-/ϗg3f?R#G4.qЏ-?x‰L3RS?"Y4.<,Yp/~lENS4K.O-/ϗ;;dKp?~R/Oh6:\T<_f/./,4:\B?TwNfſ,/ϗ;ߧJ ,;BN~vp^ĉϿ49\A?o)%wwQ<;3~Ti'gF9C.CTa8a?3*Tt+B?o~yܕ5J4G9\GA?X2^_3p Rp͉O-n|neF_`xĉCs cK <[L3.F8q?isσ~l'x4/fރ_<2.ˡ_`+rV48\@<7p꿉yO>sxĉwp^ 3C3s~^ 6pw~MKwszɼ7wf?h;\_` 9B3 /Q4.[ >|~NOpO~IKO^3t WTL9ϥpσ~-K^Ri8\K_RO?~m34:\Br_߯o4/9\/A_^Rh^u_A xiKIXmXgsA~O368\_R?t.Ϡ_Ry1 ,/ϟWN39\۠,=.[g '~~.ߡRgq@?X/>bg^ _3yfi4LzM,p~T#N~fwcK gt<_0.j?xĉ.Џ-_x‰)3ş@?T<}άpׅ~Ti#Ng'gsA?TCN~yO-/ϟeC38\],xĉ㙽.^Џ-x‰.O-/ϟgҟ9K^ ?ߘI3:\c_RǜtC_frgA?X6?_R 'xfſR8yfſ?p1''O-/ϟGGgf3q~po~lo'h;\ۡZ1|1R8'n7s x'yK|gV)b`)Y8uM9cK qV.۠_`ہr..T=8u?M[-d>ͣ xĉOGǖ<Mw;SK)|)p~T'g0cKp~~a(SK|լDKOq~LwC?T 'g\.SKi|i,Yp/~T#N34:\B?TsNϋ4.O-/ϟߟWѼp Kߟߤy 9K ߟߥYp~R1/Ί@T'|lg4.MЯiρǜtW4[.-oh\?hw~^ȉgg״T/cN4.]oh~ggefſx!'g6gЯi)9a?KӔq@2矽~f9??x!'p״T!S_ -49|9%]88K<ϯij8\5[&3~wk9\Zdss3KsOq~΢pׇ~l'٩şB?ToBsKZB,ߌdK +hZ8\-_RW?RҴt[B.y*oip~]K tK;.;_Ry1xof~y<4.vxĉ_?8cKpOdz;;\Z |p~ToguװT@9N|J3 3C3 `q#N~xd2cKOpC߷gtgB?T<^_]o8\ ,տxĉy))ǖ_ <.硟Z_?//e Kq~xЏ-տx‰k.5O-տ>~ާYp~T#N7O8q?t< 觖OVK <vǖSI `Gt<__,"N?S/f[A̗9ДsA?XP'g4. Y""Nω.yKOgCTuB?XX'.[D g99?R1gdS_R8q?t/1_p~xNSKgfs.Mc1q~xNS)cK_<s觖꿌s|2jjK_Es7qs?M[-cK?LpO~T 'g\.cKp~~sb1SK/aϿ<,q~3gſ_p~^Yp~j~y~ޤy Ro8q?ҬsA?T{Nχ4. O-/ϟ_g4.Mxĉfſp~po~j~yϿ"h~v~T/#N4.]Џ-7SKeϿr̥[[Rsq~斦)p~lNh;\塟Z_?%/q~*Tq@?TN.jO-/ϟWWeCpk@?X&C繵.ZЏ-2s*M].SKU>qgwCHK M Y_?-s4R8t4-.YJEp:ZK-gӊffKw&,Z6oefſ_h:\KT8ye2-oo]p~T+#NCsW;\[ ЬuB^\O_Ɩkxfſ%-)RfſYK9+VWT h;\ۡ_R;y>p~K_qOnK> .Z?fϿ.sԦpׁ~T)#N~Np׃~l3'>+kp7~R|=>{gռcK<\Ho RO8y.O-gsxĉǖx‰y:\B?T<_^_]4w;\wC?X'~[ǖx‰y8\@?T<_Af?h::\, xĉFR='? R|C> p~TP'I3G//?72F3`#N\,?x'~~b-տG|2yYYK?<׋4.Џ-3WhV9\Z_/87ir߂~T#N}_RO8q?zR|>'|F`ρGh8\[[k ';m6觖3ggKp?~T#Npo~lO'L7;\T̿:\B?X;'g;cK4:\BR^ȉ9DD״TIcN] b?~CK1Cf?uhNqO~O^ȉGskZL1'yAC!Z|49??x!'_,hJssx'|~-hNs꿜>?/K_ <7pR7O8࿕66觖꿝|3K oN`?G?^R{' p8SK/Ͽ? KӔq@?X,y,8"NxYH .->SVq@?Xh'\? -pW~l'xu觖쇜 k9\,2C5uB?TiN~xYY[>?fCvap?xĉM.&Џ-?^oRy78+hZ8\-_`+r/lp~R/r[A?o+sAo `;Gx6ǖx‰/lp~j~y7~ip~T#N~:tq@?g8I>~ tB?Xa4.Џ-?x‰X觖{{3L3`#NLY,ǖ <̧Yp/~j~y~Yp/~T#N4.eЏ-2 SKd/~^Yp~T#NZǖx‰yfſ|2fſR8q?_lv7C?TN74[.O-ϟ˖/q?iv8\;,#WWǖ x‰{ w;\Z?=@f?t-RJ8a?Jp3ǖ?x YtM9SKʜ/a?*Tt+B?XH'ݢJ%ǖ? x‰9_sfs͉? x . qEi8\uT??.[_*z4g8\g@?XL'^? h:\ [si;\Z<)EExĉiNscK_<\Es5SK.,s+mmЏ-;sO-|ҙyR8q?Opׅ~-K6'^t,,7T}xʼn'o8uSK<|&ǖx™?/np7~j~~\"bf?Wдp[@?XJ'ZKǖx V+7T;ϾAo `;G/M kX>9N/np~CK岼}yRO8LR]'y^/觖eL3f?RGa4.Џ-?x‰c.O-ϗ 3L3`#NLY,ǖ <觖e3}_~Yp/~T#N4.eЏ-CNjW8\+Z%sβ/q?ӬvWC?X 'g Z-cK<ӬwC?o~~\(>Q|B`OG/h6;\[K '^?txſre>~pw@?XG'g'ͯЏ-'n7SK*|*Kq~=˒bRO8a?K)p~j~y|4o/pW~T#N%.JЏ-s MUqY]E, h&Q0 *H{PQ`WW,`o;6Zzo`ػ{=Vcw|ss/&f>r}>~9?9q?. ǜBf3''86o ~^p~`Wi^s_~dׁǜ7ir߂~b~y|4~F|pR9q?i8\cY,3f?1|cR)pO~`CN\G<,Yp/~b~y܈(4+.,տ xȉYG_Rǜ-4[.O,/߄/~`CN4_:\_B?TWcNw4;\C?T߼ ͯ,E7-Ng,gd)~ {MU*KWr3` G ~>?Zx[_?7翿橿ߥ4.e,տxȉ?_Yp~/K.X_?Hg;K9ݏ~p R9- |r~~pGs~uB?T=oi@sK7r~p RycN}l| Kل4.VϱTk๜g<?gҜpRٗ'| . XB!'/%%Џ,)ӟ '==RZZxȉFFG x̉vv'꿃|S>>xȉyaaGx̉yqq''OJY.Xy!'%.Y1' 'd>649\APK<?ϳT'#Nh;\R~'gB3 RӀ̤pς~dcN|wTBO?h;\ˡc๜j5[-NFM&wTfOMgM_ Kˉ_|pũip~`VCNO[.YCʄş~by>~twC?T!''))Џ,*?% r~pR79q?pRR>6'Cs/s,\N5!![a511g,//_z~yr"KKЏ,2ip߀~b/_;4:\B?T{CNχ49\A?TcNXq8'RL3RS43.Џ,? x̉G3R?j?Ki9\ˠX9fſ9q?h6:\X_?_"4;.,_ <?s~>~pR?9q?pR9q?p RJ>{gb},~`)9a?TwC?TcNĚ4.ZO,/_'vkC?TaCNO}.áY1'Ć4G;\GCa~5~:1r#/r~ i9\͠Y9~>ؚ88g,/Ӂ;9q?]h:\]Y1g'ҜpR'3ϟM_LEs:s,\NՉgӜp?M{gpgKO OC.CRfͩxRKr9Ǔ<.#YIt?oR>-d7C?T!'ǓZ8\-Y%ps~~<|[S¤ş~`xȉn7GX/CI.,CI.Џ, yx`0K;wCۤ.۠Xv!'Ǔq~d{ǜx3wLǓs~`ǁiq~dgǜxҋO,/ߕݏ'pR#Ozs~~lpo~`MCN6vG64G;\GC?RSpC?RNOSBK7c>?$9?9iORǜwpw~b~y~N9? Or~Np~dӁǜ4g;\gC?T~pj?\p_R9q?\p_R9q?ht~b~y~p~`끇hnvo~d[ǜoN|GSwp~`L~9q?O(K<|B3 Rcǜ" 'ˏKgM_ RӁ4s.9Џ,?x̉YH_R~q>ЬpW@?TJ!'g-:#Ks~6lq@?TVO??p~ˀrϟ|p|K ,/?z~~r~ x'g Spg;Y_~ϔip~ߘrϳT 'NqsROLCS Rg ) .Џ,3F4.O,/3|gR!&o LpO~`)CNݏpg@?TL1'S9\X>/fſ9q?+iV9\Y5C). O,/_6vpw~`CNOg.G <9?>~Np~`Ӂ4g;\gC?T9cN4:\B?Tϥ49\A?TCN+.+Y*1'Z.렟X7os, s͝Џ,sO,/#4:\B?TP!' '.'Y)1'9.硟X_?;yi,C7.7Y-1'=.X_?'OhF;\X SD3Rǜ4.iO,_]>̦pρ~`CNBE"G_ <,)qKX_?/4.u,տxȉLR[ǜRN'Os/./XK!'[.Y{1'ԟh~v~R0ϟ49\A?TCN}W??˴YZe1'g~4;\C?c~y3 .Xs(MşR3h8\uX.ClZK<4ip7~dcǜ&vc'?JMK%Kr~pRǜ\q3O,՟0ϟMx3Mw;s,x.'ߙ֓[T3Π9?,/?z~Σ9?/rӇ/s~4.X SHs K_ < osf+mmO,;1|1Cs/K< ys311g,8|lןghu~ 6E.gGi^y-?8>~6]]X=๜Nx'>?ti.qX_|L3RS5f?g93G3R/RYJ_Rˁ_E_ ږ_7lt7B7Ym4.of[pM+p~wK|q+._R‰?q@^Rpx}N.Ro Ŵ},~wK7q4.jЯlpo1ݏk:\5_RO_Ks.\7TR,sAo hr~wKIM\L?9\y,՟<_ŴSG/sfOV+'ϓSqq{=Kwr~R R]ǜz{8\=X_?OOIŧ9\A?T/!'Ž.Џ,6C . X_?OOMK.KX2!'.Џ,%Ck.kX_?Ogt?. 9x.'ܿ~\|,'^.R_z~~\K? xſ9_<ov7C?R[pCRKd>?;|F9K<:\B?TwcN|~~\K9|9A'K6fCSQ9⟱/\NUi9\ՠg#NyF MwT-R?cs9q?h;\gÁGc3ip7~GK|5uj?gpC?R\NOSByoF.Xf!'|q;Џ,'3{is~b~yϩiq~eK? '>?t? #K 6Lis.sX?t?y1#Ks~~~9q?hw~dc ~<'ϻRnnxȉyAAG?U.נRy7wj?oѼp R9q?h>p?~dǜp~b?DI$ <LwC?T 1'~}C3 g|RYL_RK4+.Џ,տ x̉:z'ϟ?O~ޞRہz8/~dcN4_:\_B?TEj?pR{_h~u~d߀ǜhv~b~y%˽32>g}XV!'g4U.Џ,_ x u0M Kd?:+υtV]z=Y>j@s;Y_?:ПuVşRCN|~4uB?T!4.VO,/O;{<,pw~/ﳺp{@?c~y-?pu*iiϱT/๜hz;\op~ΧK_;>wK.KX2!' [Jkhu~R~{>F.cr~nx'^.T_Cyxȉ_ysf,ssO,<=|=eW.WcWr3f?x'~Ԭwis߃~GK#?48\@PKp6x"-?xB3 vI3,?OߟR_@_C-տx?.Yp/~KGj5wT_ϩM4.Яl-pASpBwcOi>s?~]K>'~,yu77oborv?}=#Z_/_pR9׿49\A??}93M},~b~y+׽3:́,3!!Џ,(Cٵ.O,/4G8\G@?TCN48\@?T#1'\#?~bOMs9Kr~ip~dcN}ϝR~>ת'8\'@?T7!'$.Y'Ӌtt'Ls.sXp?~`x #KsC.O,/O1t:Kr~uB?T<1'dz;\X?W+O J_RESpA?Tn!' /./Y+1';.Xo_._X7!'s~PΩpgK~@S RՀ9pk@?TM1's?~b~~\ Jj?ui9\X>Ӏ((Go<Ϝsu~b~~\m_>69Mh:\McB๜Ϝ4.VϷTkY|N;3o|?>~v99NR'99TT'Y4.,6s>Џ,!ӗ'4.,%s ͵Џ,s͍O,|NsK ~FЌtGB?TCNϻ49\A?TcNG4;\C?T?v ~9\E,?xȉB3 RӀǜ4.YO,?A|RY@_Re4.Џ,_lpo~`-CNRw9q?|pR~Z >~r~~ s~~r|WJgi?9a?sſ#K<̥st~b~~\{͡,՟<Ԧ9? 9q?pRG2w> ӹ4rA?Rr̥-p gx 6Ms9;Z/W㝔' M[-s,<\NYvr;A?R'+  h~~\T9?x.'t3.3g3Gshuυ~GKj5<4}.>,xȉ_.p~dc 2sz`WT pͽVV׶Tmpͽnn7T= 9>@ ZsIy9f? rЏ, R/ wC_^ȉ55wT?_ϔߢy-*-!:4c.1ob 9qt?;fbt<\.#KsfO㹋.O,/fſW9q?h;\YC[.O,//~`CN4_:\_B?TWcNݏ~pR?0篗/4:\B?ToCN_4;\C?T?cN?ҼpR9cc','gs?~b~y_3 ͷ,>H-3N;X_/R,~`)r3?;9\A?TcNx~W9?2Yp R9CNOm.àYCG8\G@?T .F,xȉ?c1'Ms9Ke7ip~`ぇ4.NЏ,՟s~ҜpR~ ''p~`Sipπ~d3ǜy94:\B?c~yܔ4i8\}X/s9M?#KssO,?y!0i;\X!'[.[Y61'..X_/77KA!xȉJ3R9).T_nop.X%!'5.סY 1'>?oѼp R0oo4:\B?TGCNyX[Ni&9\Rgyt X&\Nsi9\g#Nb%wTR<+iV9\W8=[#34G9\GA?T_nT?}.-s_RXM.RT?}Xo,x5৯ 9\T?].H. ,xCwgr? NqO)=< rς~`CN.Y1gt^ R0 ?.+.+cs9t?^p --N-.Tnoz~~vvxȉݏp R9.X_?.ǡX !'>?t?^,-N|~%%g,/g//p~GxϷT{ 8q?t^3T?ݏwCW OS.)ЯmpϷt^0 &|wTwR|x2s,տx.'>hV;\o5 8Fg,տ9+OF;.,_ <įt?^)#K<̀ v~bowwNg͏,C;\C?TcNݟp R1,9 u8L<,;uG?x &M-;Y5~zќpRg9q?gӜpR9q?\p_R3e4;\C?T?!'J.Yj1':A '꿞|Sxȉ..Gx̉'I|Ryf?9q?OYkz8\=XD!'>?tѩЏ,C]t;Y7|ީOsK_<_\p_|K_ ӟ wT_>ϟMk.kcr 47:\7B?R78Fs;;Z_Z~'!.gGG˩h>v?~eK ']4f?-_'Lq@Y43.ofY[pv?ݏwCw~w)2+[9*_E_ }-տF`Mq.vn%[Njv;\Roy"++d_G64{.=,#>xooЏ,;3~?/|~N/*gi \wv;C0SiDD? x _?yiiЏ, x̙?ݗv{C?TC_o_p_R9q?\p_ R9߇y3꿒%|KR.XC79\7A?TcN|~'꿓|KS~~xȉG.GYQ1'ϋp~b'_,?/~_r~Gx̉A3 Ro2yj?t?^>Kr~G X/kצC?/-p~`+z tB?T5cN|~p~b~_ϭ49\A?TCN48\@?TcNσ4C.!O,/} >~ip߀~`CN48\@?TcN͇X#SK3RぇI4.Џ,?x̉t '7oHg|>K/r~%K.Џ,տ x̉YI_RF>lpo~`MCN6vG4UUYcNx~VpW~bo߲~֤pׂ~`CzfRǜz4.O,/oߚOC.X!'>W;\Џ,-ߔ/~K7.xMk5X_/&~4.?R?.Z+ږAs"TIr649\A{of~/p~sK %gwxa~y|;?Kh.u/~`ˀ׶TXKu~]K_>g!籥7:\7Boނ~r)}--;49\A?TCNL;\C?T#c qq'w ?..砟cr¿.җ.oWpt)ݟpG@?cߕz~~==xȉݏ~p R9x'w~t?ZK~t? y ?t?^_Rkǜy&K{C㥥)Kr~~33Gx̉o.oX_?// r~~Gx̉.X>}&|Z,~ ߿xفϷTA 8ײZ48\@?c~ye.àXCeG8\G@?RG/y11X_??0z8\,9kY3sGo<_~,/Ce.N,՟r~~G<̀NvO~b?4g8\g@?TCN94:\B?TycNE4;\C?T~pj?sA?T!'*.Y 3zz'ϏI[.[X6!'~_v7#K<įvكXG3f? r~ysp8K|F:K?,14c.,?xȉH3Rǜbt'ϏKg.<Kr~,q@?TR1'gJ%Kb8~lp7@?TF!'g+6#Kos~vє9\eO,/?ϗ4_9\_A?TCN4?8\?@?T1'_._X_??2iq~`iq8LWs~@S R)>S{gy M\ބK2Lj?hZ;\X8!'>?h;\Yzwv;C?T~lj?=hNtO~`SiNsO~d^cN|~΢p~R~9>s\@s!K_<\Bs)#K_< 'OZ.Xs#MMЏ,3ip~Rw2ϟMpK?<>?L-(N g,/p>C.X!'>?/ӼpR93A3 R/1G>s,? x.'>?|p|K^`4EcKORSh:\S_hi[&,[X6V跶TBm,O.eokYj5[_?T?ݏor7A7 w8\;_RX?u?~]KkknoK4{.=oi<t^OT_#u~ _?K\R/|K Rt.pW~lrߖ_],_+W*vR:\!K.^B}G?x̙?ݯK:\ X_ׯ_M퇞|?#!'NK .BGo<k'k|~NWTGU8 =%]..Яmpuɉobrv?ݯKNsO~WKb:I璳.X!'>t./sy ͥO,/7oC+.+X*!'%9\A?T 1'%79\7A?TܯGGC;.;X.!'>.Y1'%8\@?TܯGGC'.'X)!'%;\C?T cNyg,/7لJ_&s,\N%;\C?Rp~~] 3[|RݟK&8\X"?LsA?T13Y4.O,?|Sq"K/r~~\Rp@?T 1'%k.O,տ;|wRq KorW)N'-տ x'~~ssg,w-ww,=h~v~d_ǜA'K=>{{J+pgK <؏fG?x ϊir~R3~j?jEşRsM#KsH'o|Tj?h;\XX!''.9M Kd~pR퀇zWd. #K'cN 4.nO,ߝ|SIs K Gp~`K~4.Џ,s5@ K_c>ǩ or~n os~e ~?6̠pτ~`YCN|~wC?T1'>?Kh:\KXq|qYp~`5CNFG4:\B?TgCNW4_;\_C?T7cN4{.=O,/EF;K6j4.ϱTs9MZ-Ygseph~y'~ h.t/~/R\p_  x+h~y?yЏ, 3~p~b"|~eT*KOr~r? g9Vy3_|:zj?t?^_R%CNݟWq@?TZ1'>?t^Rg>R9 <}i%ݟW~p|K?K|&fʟ.Xg!'>?t^#K <+s~b)U{?ٟe,տ?ϫt~dǜUhq~bCN~XuKr~G?x̉c.cX9|9ПeU_R1}`,yo<~?jp~'Ke>?7rpw~` Y{  Џ, x̉ݟWp R=Kt3.3XL!'ǫuυ~dǜ0矟4.~,xȉjjG< 3__-4:\B?TmCN]4w;\wC?T=cN4:\B?T SJ3R9q?O~ЌuB?T8!'g"$#KOs~边j?g0__}[5R󁇜Zp/~dcN J'_|)ij?i68\X#fſ 9q?h.2'|Yj?_|pR_9q?pR{ǜ_h~u~bߘ//Oo.X_!'gue},~d)UǜTuB?T5%|MM&Kr~:υ~dx̉KSRH(C?xȉ~./r~./s~p~b~yϿ&kis~`ACNύ479\7A?TcN4w8\w@?Tצs,_~[Qb4O8\O@?c~yϟMx9.硟cr¿~YU'4#.h~קϱT(๜i>q?~G8q?i."wTRJ3KϯY4.ϷTfſK/bϿ_% KZ^p~mK^Rh6;\_R[,R,տx N՟|p˛oSo.oX;ࡥ -3:׵T[ǫs~W)5t?^ٟeo`7l ~pWq?x[ΞISS,/7ys =+kj;\X0ࡥrЯm#?\C;_s4Xk{ɚ|?]-1T?94sA‰gqqqЯm6pM,x!'k8\]R]of?9? Orh ݟr{A?Tc ll'?6>~""xȉ.ˠYr1'kt~RW1ߞݟ rA?TCNݟp R9;.;X.;;R.XA!'ku~dcNݟsm K7r~Zдt[B?T+1'-O,ߎ|/S!OX3Ӎ{9q?=iNqO~bS*3irς~`CNy4;\C?TcNO_'꿄|SOsKr~\p_R9q?inpo~b&hnwo~`;{hu~dǜ!49\A?T̿c4;\C?TCN34:\B?TscNϋ4/9\/A?T̿4#.,?xȉy]]Gx |p?f=~ьwC?T3f?9A3 R!4 .,տxȉYJ_RˁǜU4.O,/}>~6lr7A?Tf!'g;#K9q?t\)K?C~pR9q?Y##KpgX?r~g.nЏ,x̉:z:\=X?W߇ϿOj?t?^&KC}.>O,ߗy>~~r~~~?s~p~b~~\}_>xmm,;C8\@?TcNEC.!X?WߏϿ_j?hs~`ǁiq~dgǜxO,?ip߀~`CN48\@?TcN4:\B?T?~~ҌsA?Tx!'gd2#KOs~pg@?T?^_5y4.,տxȉ??/Yp/~/į?+iV9\T?^_- 4.,տ xȉ6vG<秌fſ?e^_=hv~`oh8\{YG1'W.ߠX?W?`j?t_/K~./r~. /s~\p_ R!|lh9\crhnvo~o^_K꼓~.XA!'>?G9q?i."GC--N#OOXgS4:\B?T_CN|~T?˴Yǜl~~O,/[[콟pR9a?9?sǜ49\A?Tno4,xȉ99q?\p@?T_no=o[8\-X%ӆs~g͝.NO,՟aޚϟMn7X;\NYGO', ~~|:d~y|?\.p?l-x࿜,xS?R~ M?p~`nuo~o^`hv~l{7T4:\BRC7T?ݏ7uBoe~o~ -46.RÁϛ_u_ifyOo9\oA?TCNEͣ.QЏ,Rt< &~?d3ݟ7Op'@k~/~eKO^~?gl9׶T\u8qt޼_&_ Rt\p@Wo t޼_ 5O+O - <ϯRNGtR݁ǜg=.O,/kXy~LL? xȉ.Y|1'[8\}X/s~&C-.,C-.Џ, s=`0K?C-9\A?TCNݟpR9q?t2R1;Gy~~11xȉyGx̉.X%'OHu7.7XC-8\@?TcNݏ|pR1;Qy~ҌsA?Tx!'gd2#KOs~~e?g2;_y~wC?T!'g R)#K/snJU*g,տy>~6lt7B?T&!'gv;#KsSF R2?bj?_|p R9q??q@?TcNϯ49\A?TOgm__X?๜[pg-ſu_*M53d>{??[krkA?T!CNx~NRǜlGSR3!ϱT1s9{kş|KG 8iJSpB?cfOz~ZpRmpw~dcN|~辰2w.W[OrO~`hz9\Yt1'7O,s~T i.r/~`Ki.s/~dˁǜ4W:\WB?TU{{s K_OK?<YL)vX:3f?9.Yp/~'K|ީЬpW@?TJ!'|fſ_fſ,տ|SIReCN4_8\_@?R_/|K;Y_/&/~9x.'~?ir~qv06?2w6y|.ܽmpRUgA4;\C?T 1gw-ρ~by|RCS R'-:~v[#c7T 9e7CSoAo RoKs,xȉ_?~93.X s=`0K<~VVY6'|v~'K!WTCp7op~mK?yu- p7T[pn.נR3.Omo;\oC?T;CN@m8\@?Tc m?2&|&9\cs9ۦ;\ӡo 8y\.3Ǽ/o%_ RW9q?\p_ R1ej?7pR79q?pRw9q?pR3Uj?q?~G償)ro 8Sh:\ST4I=?hf;\X4 .Џ,տx̉2r'Z>Yp~`uCN&fG<)uKX'ץ, ͷЏ,#OOO,3A|AA'K 4ip~`CNO[G?x̉geG'Kg1h9\ݠX;~ّut{B?R/vNs37oJ\.X|!'>?q@?T_1'r~?g,/oߜc?r~`Gx̉VVg,/ogMss,/\N , sAc~+433,,4/:\/B?TKcKF:X mm7T;[ph>p?~wK6-;f?9w"$#KOsf_L3R~v>̥pσ~`CK/Yp/~mK/^4+.obU -O.of [pO[.n~y|qM_ʖ ~KKkYt?=Z9;~q~3K 'y__n~y|'e>K)K+;Xt!'|}+pRUǜ``'w9O( .-՟ '|}+g_-_xK+mp7~]K>g!\o f?x NxK⏡Rw_6'giK%KZϥ;\Cc~Y4pg_R Kn77Tw-8O n=wOϥg:\gB?TYCNR_p|Kwt.p~R}7?wC?TCNOҁ@Gx̙4.O,/لo)Joso~oˉ=ϥ8\@?R/ץC.!X_O=?t.} r433Џ,,C.Tܯ?ݟKp߀~`CNݟKq߁~dwǜCC'|SK3Rぇ?Nv'C?T1'ϥ3.O,?>~\:R ?.uB?T21'g%*Kf~~\RnwC?T1'ϥ.O,)Cү.X!'=Gx̉qooO,;GͿ,;8YR;s~vxg5KWg(ѽ&M-K<<;C?~dcNݏwwC?ṪӐhh?xȉw;\Џ,9q?Mi .B'o|Xj?is~`6CNO{G}m, COw>p? RCǜ:'.'X)OyyZ8|UUY5'~Α4o:\oBb4>(K<|B3 :``Y~?mWs.wT|8xj?uh:\ucYsvu'x`CNy}7| z<ٍnYγ<gyv;}=4eבåAhK=F|4sA?Ŕ˟tucKo~?*柳:/l -3psחm}?RE?x+6Ͼ_ok? x;ΎϾ_dY?˕/}?^R +?^R+苿x-N;__,տ9w#fx]Ko/s RxK蘒/R 973xcKZA_߯hǖޔ??R{*G87 Z x;N¿NeNG? eǫZJ}gʫso5,_ e*YA_[F2x]KV>'W|U} 9\eƖ?2rcK[A_yro-,ߤo e*T o'|L>RW;s^_67Cә?^RI}w^?װT '~Tx`S*T!'~,x]KYA_gy$^v>ϫ/7_7T <?^֟?[_}ޔ?^6?RWW@8w`x[K__A__d[*_t+&~xUK]A_Ήt?/a+ZKaRC+?^4/<t/o`*8K_^7Tw}KRArnnsյT >]?WK׬/Zrnns5Tn}8w7bbK׫/rnnsTQx+NM-?ݴd&//;{?ojVxuNݝװT o'~fh:K'xȉt݃?^R+苿GO7T)*Kg[ ? x'~}RUr/w号T '~}wx[K/q/wwT/we?U-?o^'$gY/>,l#@2 d9鮽2 $dA$1*, & ^ ., .W L2 W>3sLMN?]>U>???kqsK}_-O:kesv;:ǕӖ忿w/߿=W_ݛ\+ _|s{˯Wzs{՛/X+ xޟSkxs<.ßXrgi7|S|u]7w;̕/6rwoZ_Zs{6ǟ~@|sv+;l_¿g[g/ׇ=7v.m w7ǟ=}~|~>~i?'=,K6s}/=ŕr9?_sc7\9.흛[W_psIK]>as{6ǟߖynO+g/n}r{i7Ͻj}{n}+/sx\ng}us{]/^1q_vnO?k_e7ʖ=snO?k9إ݌{5}s{+?usIK>C[ܞ+Ӗv3~/?ܞsKayW_?l߽7,s{_9?lǥݎps{^9/^-uK_vnO_e~C?]̹=+cv;zֹ=+zsIK:?kn<?vsKwnO+~sݎO=qi{Ornxi/;?k~9ƇsnO+cv;@/\unO+v;H߱|׹=ۯ;6ǟ%|3u/n;ߕ|sݎ竖=UqikCS_w?9ݎ/߿ܞcW_oZ7=d-9k߲9إݎo,:kfsIKߡw-unOksiKߣ-?ܞ+v;_\޹=W_v;X|r_K{s{Ǯ7__vnOrt1vOOxzz/߿=]>a>l9~]+as=_MO:k|7/^6siܿy`rﳴW_ o=ܞ/wyz|=/|k{?9K{ۜ8 .ܿl ^9>/mfw<_cꎣ}?V[s{q}k9|~>zos{lsݖ >p'l=6o-7>|'oʹ=)O]gn4}>Oߜs{36ǟ ?gsܞiiߤ_8˹=/\ڗn 9h9KX/p|K6?ܞ]_{ ls{SosKM_p|+7=6ǟk vsS_9>_oOKMߠ7^8?ܞ.[2~mǞS߾9ݎ?w\8ܞ'/vE}ٜn?si_/_;`s Hp|7s{G6~Цo tsS?e||C/_=I>?qOls{l>}ӿ'/_8-v7ls{/v_._`s~8OK>?uOms{?,ǿ}_o=/vY}Džkcs{SÅK;vM9̥}ަْoz usw?,m/_Mp|=//MOp|I_znOr,Ϝ_zS7?ܞ7Y._O>9~n7z_8unOs_kʛ6ܞuӿ7 SqsEKMM/p|_qnO߳?ozk/ݜs{C6ǟJ}>ݜs{oߵ*}^}7?ܞsM._ù=QҖMXp|c7s{l߳//Mp|_~nO[ǟ{D}~kzs_9ݎO^8k7?ܞuw-vz}>ܜs{6ǟ7ySqs|^ ps ߲9?]q؜s{w.2>Cϗ/_ݛwnO',&~/+._}nOOYU|k_9n?p|o?Sds|Zܞ,vf}oٜs{O-ǿcM?9qn/_O>]KOt_ڜs{/o?giW/__pnOyi_o\876ܞ/Z Sw9·Kx?ܜs{m?ai._g|nOv;~o}Յkjsgs9K?oMis 6ݎϿp|n=6_?._O_qnOw-2~>?}Ooܹ=3OX:~DžK;smߵswp|6?ܞ,f1k9pnO?vs|Zu;7s{=Kp{_8ޛ_~nO?y97?>Op|wnO?cs K?Y 9s6Z@}w6?ܞsv3ܧgz|9Կ_?%}kys 9?^|7ܞ_X_xX|sWl?ai7}/p|ls{7ǟ /_ynOv;|>_9pnOܞ{v; }~krsu/./>d|>|'oܹ=)OXi|k9glߵ ?gsnߤ_8_pnO._m_xnOv;~}/ޜs{?e||C._;v;~~>_yWn=6Z}ݜs{6ǟG ~s ?9>/v|>x7n=M/Z us+o[2>!G}qwlܹ=OXx{._O>wsݎ_8unOsHp|7}nO vornO C6=}ksu}?Xp|'6?ܶ;Zm nOO\ڕrn:].7lunO߫ϛznOg.v}f}v; ؜s{^s~J|ܥ}>9t}ߞ7t} v_pnO3OKy._rn׿opi7Iwp|7=.t}Mz܅kۜn7}i>q{l=[K׻~S._>_yMO?csߥ}Ϲp|9snO?wsvݯw_8wSwo`i7wܞiiwrٜs{.2y.ǜS/޹_p|oS>e//_wSn B}>؜s{#7ǟ~Hp|c6?ܞśw/K ?~s?x\n|…k9s{Wmxi7'_8ɛ_vnOr,qgl̹=79|k9ֹ=6ǟ|k_9s{7o?miEgS}sK_ϗ\8%wnOv;>_vmK_p|+7snO/v>_{nٹ=u_?d>?91n7M[7o?ii[ ms]o?migS߹9ݎ\8=wnOKk߿9ߟS?9v;Hp|7snOv;>?znٹ=cX\ݹmi.}_?śܮK._tn[xq=p6W=rn_o~^}7ܞk.s{._/;6x=K._KW.~W 7_WI;>k9>_9?E|O~Z}>mcu|ޅ?ms6/i}>ugmʹ=ߟ[s{!o=c|S-37[/_unO=d|?9?/lױe>-ot}ߨ7]8M_xnO/rm?=t}sK?w.߿ܞw7/=/,ȹ=.6_vnO/nܞ}WKu^Ka~nO'みv_ۜs{??to ox=xsb=co<[^Ӯ%?.?uivt.7ǟk:._Zϖ=Ou.6ù=xnO xZڲ_=/6_xnO _wsz>]8> ׷ܞޟwds{.ܿƱy͹= k6?~ܮ'lҮcsc_{Ixiy<:~|/}~{s/.kמyʕ7םSϸ0vnO?i?=e8qe?8-߿Ϲ=ل OO_5~׿?ݹ=/w9:?<([|:?<\8nsj} ٜх_qʹ=ݟnpi_K:_yKyKj.{.9^8/; /Mcs{?9ʥ}~>|s{:\99K7k{W,=˯+5|?iss{z~ϧ\8)znOS/n{ڹ=ݟҾ~>|t\99s{I/X=_8 6> psܞoܞv_ϗ.s{:w]9_97>_|s{]9˗c_7|]J?r==?\85vnOk/G6}g, }aYtras9KrE?|t>kzs~>vzms{~oo~|K;m_{s{׿=wױf;Kg_}|k|=]=Gx9:-]:c}GZn}w|ƫwlwOOϺ1ttuyW^׽>5W{Gea}_Wsw}G/{k^Qs܁G??^׾YyW|r}ԇ5K_S7_Hܴ}Gُw1sy7p7p7p{7#{zo7ennnnnnn=8+sx޽wVdnnэ_~_ݡzGU+ϻƩ yGzx~t.1z+?/}>C_s~nSs?vƨ˧_/x+-~.nۿ#~Մ-⿵=}p><$A=u~؏ky4^[ӵ<-t-78~Ü8~;>?>;>cY??cocOO\x>ڑ4j|g?:_'=ū`aӜ\js.E\]|1ZjκX 9_~\Rnq .sMA8S<9Sy*]p>bL%ת{ 0&7O)\s1u_F}Z'?0|\On75ǙW#ٸ\KS'KQWQJt%?K5 t=Kd3*n\ٗjS¦T!j(NWäoݍ@ChY'=νS'u!e9 ɓs2sӆn<k ѩoh\(r֭sS=SMej-^˜JT7.6OU:wp1S7~%49͋ߧuSmEQˏֶ@rEM3LEG_ݡd΢MgC(~vf-h, ­)fn=hM4Y'_a]q2B p| y}te:3c!֓O;}g-^^\&EGr*ѕ/kf%;HsԿZKi7ƾ"J VI7 κϓl9kɲԘh5dY%2s=%G32=ˊ{R\57n2 PfI|umt;VFB%j%N~YVe_[PcaIi7Z*V>XWK񇨻삓XV(j3+"LJD6Ol^1>`Is>I4Å 芦X^'UN4_(_Kӫ.X7{r8d8g~Ȑi2R'K֡~1Nz&0+ȅQ@53Qtx4|ъ \&ܨYӇ_"Y_VcT^>PYN2u{,'%8'v#Z,+M惞&fMtZ옜F||z7b k+ Y8[e#͌A ɋᤁeZA(/:M;D;`μm%Nj1 b +b{4ZB"Boz(ǹ(wY[rJÐ399=Y]r+.66iMSHVDEwN.E+j2DͰRLxzE peہK eCy^j2"EZiYUV5sķ0qk׳L[57 +afd=s9 ^PƊhedv*pb3̿::PeEMur֬X.W]4 X>.\k@^&D2zv3F75^4d+Ns v*xݷ Z~eJcɲ8sw6d)Bw̳!ܒ,'Wnb/蘽Xdi֜O]d<Z88G.6k^{ L kҚped2+a=􇪻+^k:uk&" gV$M)l:3vhF@`}^ ؿfZxT鐘,LM]-p8,>&CvXG8,k6Id sk>/I`MgnF$&:&"CISr,xv-0F᧵:3zբJm3f/rUK![o~f$Q{Š=DV6,nJ53O0BՅφg)p%\c0 Ijb2zE"%FVÐfhk[0=< XpXaf&;LdE ٢U%eCVISmգ=0U&eA. ,MO(Zi]q%3t4s]Ƙȃ}g{&, N%ayZL'IqS 0DNZ6Ҕ;'вgY'/S{f?kNp΋kH3)X `:ل'2fqb{ε"qrĢ9B<##NV\,Is0P˰4thc "t%n#Ke!k_y}V:Gh"& ~nb&—Lvڝ IN7(;j xP2 } z~Fo _vw=l>WYEOOr .$zuΣ {粂:Qy-SrPDcya.ogevZ/u*6lʺ`])k8;0M%*589:V j)07\8i5~tros8h%#Hhb ˆLZ=Wn+1ªUaSvAn*R2xQqe2Y.c.|?bA+U7dX64Z_x P^p8!e9F1lhb ;3h,aG?w!KaJrog FMm;c`V$LY yr9r$13`\ It0xO\Fewb,7dH"袙0R%FFd7 sd"Q+eJ&+Ɔ2U<%gGx&Y/lǵs7,7D'OFnF d2.[3_,"];Z IvKw=iy߃ЍRf܎L 9+I~0fYƎ >A!><7OsfpV sR3eڒKYfԾ'=˒, ]I?kOh' S  /-Ҳ<#D6`|BFrwxr \'d+]Cc'-欯12iB $yts?w>΄#=Ű]j`5kUӐCxGYZYoVI$Sl]FiX=-jϔv<@$Se5FVY"4AȈ΄z/E&6XDS[o;DXOD#(&cDkjϩR _.Mªy_owKeIP m6NT4!B-XM ɤ PԬ[CD9AB+#;F.IAsc C V(&HXdx(b<32:u j4Z7KS f CF&18y+Y1VpCV0 f39HVB |wa;NYabr$|أU$%XHX,e|k ;<{,79uNa#rT4mI936JDދ;*Ku BAkBL 5irEhB!PR(!mzn庶aC׊T%7bs.ㇾxez4Aِ L&}(FjDtN3W}glZH\#L޾o[]Oy}XV:,xuv3^4%%Czy\HɑLar[AMF]'޷3"mMm&BFTxQ23 ;Y>,á+Q$2;vsSB2!fBBvx?U W5yHn@\1bxm+Ĉh5L޳LuR;9)Jd'2HBN\geiϥN$ljVm @A lXy[#.yJ5jiGFK1 -Ĥ7]k"SC`3QnWryD .ZQl-~fgB7"E<03(1y%wHxQ415zWLdL(;=WBi묒;\0˒AT:PNzB\i5t-},-"iLHɸ(lxy#6^G `2BV6EX) E3< fRZv*{<Uk'eWԞӮǮ.#Hrˆe=-FE.ZDCHMLһ9#i &1g#@w=5eBl5$ؓ}[x$1jvҁLR\u8WR'XͣYl0(RHHTP`)MצWܖb%aNf<VbTɗlY#)C'6K.N~jrq+18Z q$ز++*@^AӜ eL>&Nh}e`SC5$Q 7H+QWfT*;vnJD"[X!}w*Þtl~W dK}IOc XD&r=];W;bvse*d `妮Jo1|5iž IyH P'`Svݎ: T}zV%̰ւq4Sgxf}5\+>Yٔ:Q 33ȼǦVF[H1=~қfE ,kc fghN7y, ģ4e1w(Cf[ݪOtl/# DZl!HE!%?[W2c_y >RZYod'lHf<)Iёg-1JA1u5D]@C)F{ޗ)} ="YfJjϘiqKnSxn$C\+Ф˷}JTZAQAѪGd+ubX`/lB*W 0+O4Օd ?,|Қ&B$iJ7R#񽭇`8̝F~/ {+r`_H-kԩ_bZt7s(kcIHV1Ca?Z`"+pVVJ "g !>Y d7 ,y9kpU2h tD#lg  p&㗹*wRFI8h_Q;`GSIZ2@DEˈ̲$S530gYkCEvlTm~ N$RIO(Vx#L@Tx]c&;gy0hko=0=ʬkYsb$FD"{&/Am9 >Ch (j.2J8,/[OTxlOktЈrfڲ m3ifShBP[&[)ߗkZ ͞)+KaQ Դ둁CNc e{o pX](WJ0\'&֡ [a*1)5A,Mpj䂊aPJtOO679螄#(D(;[w LBV4^Ȯ:i<2S:˦eS4bjrFZc@g?d׸/hhF!&C~T*fFّžg%K] - 艺oS@%T 8rE/hV0a8Ύԥ]E\a"R%x߇lGKR g'O;{WhWϻ$vI242l}uA 9=10TXv #VHa9%lT>ߩSKw6H|1̼D0V;*QKׯtو͎wIK<VyWsۘO&kl\5˸)PcL9*Iv"wܑצ(MfhCɊ軼\n% c//4s ݏخ#tFDmfsNt 7|Dj7HA@T' XM`%R/2N'wKrk\+e-?-ZTlTjlF Ɲ\ d ɎBk @ reAͶXzۭHc%y䀑H}"-Hzʕ2],*`xƛ#-q5( ds`td*6Ig.}5\fYzW62x4 t'Z2{ O:i Rlfƚ J_^IZ4"Oqm TXٓ1ʓ;DWQQ^:.H*;+1I7,It$V` 4%6#mE$ۄ3#8Q $及*0GD7JH]GdBBs!*N(W 3eC;P 7!4M!NaнK IL$+sq 'b n5&,+Pd䖷K[(I;#)[l.9{*/6*)݋rN&VdϘV*D\^S"$#H# $O׺$:N5*3j3@3&l4[X3ۊ@)gD׹_S&b6˧A\Pܒ4fџ<mC#lMX9`;Vvz+ k>+(ѵQdEjwe= VIjq}s]]?{8LbpI4Gzww&JۛGK|_N|*V6!')S<(pm+C1z_V=GqX~ҒpP` ;pX#MCäG c`rG2B77`~bt$|+PiaFQܢ]H]C΂YKmGW>Ċ7n Ax&Dm*idȰIgvT,.ùBS4!UvU |%){0پٷ@LMSJ5{H HASŎKr FzL(W7ֺ.*ғkLCޒBb߂Ga)MVnŚr/hqEi¼r$!h˘l/[5]`'|LewݰLm$$\b77ڕ+Ki'f\G.Hvřve퉬Q,2ULvJrR$v1vP%VUq'(^&N1]l;k{r4dub+kG+ǰcI!r+sn!Oy~&T>A/(lmC H2J4j QxΨSX֙f:cۿҜZv3処F@{B#b Z&3H 8S+D3Oss_>f,,wj+O2QC` z2x3Z $9oqaS&5iy{ H!G'#3 !ϳpa;0鲻$6"Q?>8REe罦 Y$=#+DB0zC i3d.XTKJ`K͝JXW` ڵbaK `%G`T,j Gw}%Ae͜".˖"tòMC0%dyԐղĊ\ېI[3I#K&Ŧ8pdWԻVmuj֗pZ,^ћe+ޒf,~3ZY0ZEWAzH܌WKa)5>(S8g(&#$<\ w%!˵%lVxv͚D59ZBBwTVv z t"cnخatZ[AZ ̭ܴ]G2|B\xZ,jC;5vڥSCL&c:vI/e^sg"CAl# 6qI]ew)e@C6Y1=Ef4{R0)aFXv'Jq&[qBV!g[T:DUzc,[\NzyF æRLv&(cJsH[13Ƽ:u4lkOHB=)EJt]i)ĝ@[kБ1:[KY)bvLeՐAG6 BbH )a(X1z^K\^^?ok_SE[5 tOL!l%5Xie Dq#PΑΔ(x 3J$q %x̹|*M(jB5ʂjO;<:uG'ZmѶT [lWy4 eæ}Ý3e5)q=ApU)5rI[`2V܎;yGfWhg4( W&'xs.خ+t<-C޲!Y@Fy<.cGUO[Kzg|gGnLd1e|p!.m{$ BvVz276BDn\rVOeqPTB!hwTkXhbvjcc_w)h,ȓXzU+/^-/PpZ|0Ziq5cYxwL,WqVz/B5ĺ|VݧpKE16 dg7#HvJt5#c#8YhY rìwB!`8dZ2JZS_D*%ag&jfru1VH^\hEj`([ %N8)Zz 4B%*6h N0H) V8UyLS ZMDk'#]ϰX`0b9+N_mX 1&%"i{9*/럮RZhH$b(h/>ԇӴ{`%`#MqIaֵԆ]Là Y}7%jR>_q.GI28'J-X%78ʴ# `yךkz3`g%jZT$e}˝KdƊ(&KVY&iH9*h,阺V  Iƈ zAuGބM1Sv7?4G+->8㾃 gSnSw롳EjѬFa)iқgRиvl=4Ehf#M^C/r5S 0wpG=:Bz,dtaJ~v{7cFn`{JUK+ړv=б+mhgW]ɡEer $f'epWi5hgKF4IGʾ7 UF+U?S#ʦ!aU}O2ОBa\{&**685dtxVHhO8Ǯ֮".jӘ6%=c$ g.#z0ҹ&Vse_Z̔+R/=rRxěAPajF"DCő1k8@R*iM0Y@kl)RJ?yXM6IV|+`FyW);H_ֿT:n&?8ͬd%ErYf#@SƤV̧rlD]Z ,'6,ejESӾ޿ٸɽK\G 'aᓢi*OftBI!#(Y5g4uNČ,1QھS뷑qRr-vD=16+.#3XhnvS=V1d{(V&Bf6Kxκ؊UL,E5ZR<0YJB wQhpXD'I$bA^.͖F{lbh. 5M!dy13^$5@ 2o TΛkh*לm ˫kWD|B(3f!2ˤ[欨Sn8r%%EvDf+c02`ؠӻ3XHrn>75#zeUsEf 6~ }jˆho QG,:6ʮ2W61 W"[Y@棆C@8l4H 8<2JIH\R۞<'txmL%)K}s.mDJEDe[jn^Mg%#\f{ʘuQi{8Ί7/gbUhkg]L'|z:p\{]$[KlV&w4MIgwsl}jT̥3a`Dv,Jbwv $z LYH&0ٵV&Jd 4+Y%HQI%lR+ӘX7|/ΨuJCTm? EhIT_g8^-iHÑZyhy f3m[WZ#.<[Q*1Fk˜' D!:s2@s>Gj EXjgk7k3hÎjG|4ku\*bf@F)ngfOhi` 9dh1kܼP=[VTyq;hJ@5X\TI]?H r֊@.ŤtpQl;%oN꤅1lddB&hhNdA=4;Q#wHFiO=]ӻ({{Q&zfZ䰾j._eRdTwZ!2 )6ťODǨb ʸI_ *15HX`LcN)sJu]| ;t\Vvi6k"kaC)O;ٮWIdCn׼\DBTsDz?&[SA'Ny^mRj9CIG,fxd ;%]eTP{+YQrPuuV ЊJ#9r~զD^-20}H4j,rSwR#QMkr:z[rؖ~55?}'ķ GLZC&''ai\FGfiz<)G}zwL9UB7ncM]; XW%2v%W7KpM@VL9KiWخ(k54"f8uБvfrWeƱ ev5z^ldE%u ?2X'^ 셃_ԃhV+Yܷ|Ɏ#ꘖЮt]REUCi?fn@[t\Rn,p08!q IC,g+쎁+ٌZ+ g*` e2Rld ,3^YE l,4/TE!7N e^P.Y#Y$0Xy?fٙB->5FgjG4kd̮"^.MvFVW"32AwQ/6i}! k{+xS*i騠K?|.䦪%/#HHԹ#FCӰ0Tbד4h)3Zѱ aa`dC>딂Z!@en!J%@H)̮a$0r"iW6ٲC3)n7MmXYZ(,h 䦼ӮXG!"a*Kb[˺f?ĕMVɴ rY+12}0Yfμږ&ruC]YL;uC*K+{Oa~jCe.zaҸ )eYzЅcJAu{;OF̆H{$XA#?cfd]O.ALH!.nc])9"FϏ2DqL('jDuo.%~#XfhW ]]v=]wcs0#M̱pqY@DXl0@I] t r/%q#2'uQ @\d&פ) kvHleM틸15s:{ԦvyR'GFy2մv]B utLxƘzTjj374L _r8Y98|Tq+C^OIt˺W3 }Rط7ȶ:.l-!k6d:͙=D}<^~BЈfwl@άLqDp=),er`$*93,iIg2h"m1PyF%)Dy[#YGOP&K4#ӧ̳7nt͚ݣ g=/> [WΚ-Km8usA>Osf gd h$V㎬ k( 'uHג xF5-xughdxA\%~\WmDXpVFY"9c'1 GN˧6˯y1P:piHVPM^+ GhJEtQ`GN`nU2CA떥mş/')ȑT73$L)[Kɚ[1#7XI$vHZ16"h7P&?B$oI%*n>-[l& h ړE12PnC80&x4_sE2!յd=X(C,zc/ltNC)JH:y|plpivR^CCMۻ#7L7/a .1k@"Nd@3Xno%ߜ ?l2drnkM]jlG9bSa8M>-RugG^z-DrI+(KԿ%!O/9MT s_ zBM"ŕD3Oz+ 2K.PkL`SL^0kjTRC̈:ا#!*4!9gu >fxZwMX|Ms ;YA)R^͸D54<HbD FGȊiFJms`'}04f ɗ}Am(x:>D3HV_ݮRg^(M׈K< G2B33h22P)UC+ @zBِ~>軩F:03OYrƃ ›!_rQ,q쳕I%ot&bwDu7f)R|i4Z;D}6-h֣wqny؈YXt#YQ*[Leb3]m3ש^(_'xp."P@Q/E6SWrFeՕ&Jh[A67k'j[4x4erxd#)E&zp)I* 6Ƈ6-}d.r~3[ؾ,6z,;5vwe =rb3η=ҙF:̌ )Se?fv$C4ihNŊUJߥƣQ:aT*YU/y޻Rv殥#qȾ$L71gP,pm{{rv)C?)sZg^ìKU.ͪx3>T?t`8ԆTI.9D(Fc0kB Y>!$#TQv90q`VK[dFD%5ovS+-ƈ3f!RZ!ӭ:<͡w{6}ɧF\4|Lq1Qvh\3{[P2{Db&uc!F;K ^>e|WJQf,4ag#ԣQ|$4ZTR fAshN5iZ~yȺS?T-vk5Aa m&PeH>W*Jp[BZw,"[Jޣle26G05'ԑoFᘑC[+Ij>xR5{n|G'٤E٣kŜQ]Ohv%=T 1%'}D#9ߠbDTD%#v6׻'DZS| @{cVp4g?ٱ lb?TTt+fP2Al]1tS%4$O6h".]Vt@ɡ߽k)hb5VS-,Fvcj;^b=9Mr7qNZy-6Y@bkm <ds:Ôr F$W\7 ܦnvyW:Ԯ"mF{F;sv !٪` ԩޑBuhy;$XeZaJpw{ b kCӽm1) QXb3Vn?&ثC)Fg:H iMѼ|=/lFV9hPJz[+dKqZ (#e)Y|%#GzlZVB(~XyM_2J^f t(J2j o2<l*%xB6;DYyVG8.+|$A,@DkutРC 8S<"R-J/:v R~ӡc!l\KxbФabZ$|6͉zSkaCkj0Գwi53[?Rt'&`ae<1 0%#_I8zFӉ=R:-G-&i- aiNGܛOh3Y 5[lEL̆-δd;+DXC8"KTQ &Dy!/Z &kRa#;\2HtMCS`cgM/7~k(:ʋ? SRPG>\J#COꤙ/,hj35va8܍ܼR< dB4J5*\hG٥}DLIޢP\ޛvl[lVbEmM滹h;S<,JCG+ss-*K$cJ3g%*{65Qr.JS?/EbAaJ0F7(#b54R-sWN`mV@c)>KhZ-vTlI$+MRLiLsdIχOk65zI{`n66MF-wK!ڢlfz&=̊;x)+=43҅^Sq"^sSsZxZoSSITȜS3;E"pQRǚw-m+&R(Xdai %o%ԫAĢ$u (NK}&$24j U [A̭NI*ua&fyϭY^ غhAsBXM1 OE9cSs&6[bO2yXA#4d&.jbxڎ*.}芏Z8Sos"&k`d܊jcĒC'HQqvH*Y h浊`jZ~YPKZm`g6V1⫬.qnn47fÜIld+LNu^/#^UmlN]q֠p2b<7 5,;lEz~aGPXLR#Q՚5v]Ů׎$,.1*7wE&%5P̈<}Cl:#&fdɼL<]в+j.7(pl]٨tKo-u 2Ln{\JpD]E>wߕ'ǪP&9;Lj*F#וKd>`8cSa8(J["PFyEАl(Us2jLf9Ω p(Dp\Q>CAAQ3#mѡ&O,ǠP;4ۣXg#̊ !&o@;*ZjY~ !Zgri`*Q+\L{^Ĺ'4­ʡ3qdY3Dgc(ޗO@w%CtESi-fٵJ.BN&Tln(Pԍ6B'1pHeȣKfPH$|Xa' 'ȆCSy)j1V-dǨV63mȨXN%l|;NH 2>pu"y2XǤj CoF9$ae4w"B˯#Ո!4T)i TT`^1)3Yz6|= 22_:3n`D+nX~ڴԶJ"_⠻t=i]{]=%w1Ev]# z:͞_{$w-$zLW2 @j2Kcsv=`cS},l@@n0vqd0SG{ոs^%3}O7H{ijIQ1bֳ|dHY.,5y#uL<qU7$NV9y+lN7"F;=f5[R*Z !R_AWϭt}&H{ MFuC[*wO9W ͚0pԐ%Fxj'ӗbDЯ]^t%>h Qȕ2{\HK42<\CJ{[:q1;zDD('$\Q8#$ ɔ'2fUȥє%mtos9 )ɭ & PIj &Ck}2 tɪO AAZ)Dviu7CB0=}} ',U(VgF!IhfAƆ|h1kzd3e(;jMcЊ!La*&Tn9N53Q3|FLj5:zX˝Z11%Jv-@ZZt\ߪ/ԊYߘ!:)fKb0Sx R2Qt3bP5C-lĠI`Ncf778 U,u62#)4%# wTmX+nuEOڨkeFQo~uT|ۨLzW c8Asdh@"*w2ii(w<ߑش+ڵ֮d[awWČVΖ|w;IBU PIy6wte5 fdYͼ$1-骍>p!֭= 7" U3(a Ek3!ںjy_"Z?(kjrkGT҃72m(G^"\h@{5IruXH@z~3DS i4Rɇ;v 6ULva,%|+8 Sϕ(=8 yiE9 F7!,K@ Z[{%P7/[ NZ%f7HPtCX'yg X"艽Q?攼OMJTlбXN$[\^gH\Z|CО1U;WdZ ߠ[%D5gzgq|Q^gZU{G=)ݦb,]V .G2s¶-ɹְe S!oG BlM.s+0hD*n91)'QgGe]BA(7"~fWgo^ӎϮj{cXQ/*vyij"9 "awHaZ{:&҅as/ S-az~`K7z&mZ?WHfn1θRBX\9SNc8*4.*MT [b6n%TONS:ܡ[E7j3 hIj;ʓbFҜ,&:Ҥ?`V™~(]<4huQ$Vĺ%#ύ񕍋ȌM =].d!Gn7hQ%".RO:Sβ*<(s_Rb:>F"3Y"&$6^gzA2*T1MU;Tݎ:͡%1]8pȸr)Zc Ax/ͯvfyYJ%CkLC5+BFs<8=5zFwSo"JǺBjqV]ovRa~CIZH.D[׷x^yJk[ !MSsPHB_g'-ehMU[On` lNcC$ Ai9ih:hZ;4>"qUؒڎECzKV9lOKK~^Ɍ &EB?҂rS;;;$1G*cI"DrV<i򜼕CB3I3z70WzZ&GQ%}UB7ĆxfHF؎qgn ;TNh8R-;+H2D=A"W1)"Y~+,ar,RV< J.ŀ9(Q{dH zFhjuaHL7#$MM^S\#4N&dl2!VVb+$H`*0gj{]ճ2J 3l3j"Ȅ[,D7&TV&XkN(fTmHBpf| UdpȘM`eXtC FCZh4!+C1j7a^xqZoÏqMdLF}TU,(B!OVB7INtUAFZs%Lf|^v-ot+ I,7 f8DwfO#}!m>ph Jk!OiS` DV(Uke-!@Z !v5yBȓ!SOӵ| Zf-rf~LVd u씮(Zt!VQc0XlϦNFYA;t;f4P, ߪb;be#PoLHUWo) |AL"CC#xDZ= TWN^=ш1ᥕd>*CZB23PԘ aG:Y]nŹ"ݽ[G 8PƁ=p^k33W` St5Kcz0Q\pra%TgKxBP~!Fb+&W*YMH3pFYq ]K JH*Tcs`vOYsk%h"9;а OY>Qh6(P3 QU6M6)#, ET$s ) 8:ÌЅ"y١ΖJ9$^OZZe1ƈ&f0`(3kB]ZT!0pdeqjeKl$p\Բ#R.`'|(mܾj,e* `[7>uul{TvlP"O%L}~j"kzG? iJ$r]~uBFC ʲbs !7o訂G8ˤ uU;n n6K97Edəq?fI^e]gB,SE[J6J MtPѡTФpC R;T "\f-F6R MňyBS?44ɴITp/C.DCu>tZخAFl"q7@`}MOV TuIp,HUmVZHDC:Z5[+A%ÏOz<#%5 FrUU8 ASS;VF{$N$)W3ψS̄mŠDb#"S5G8nŶ|Nnnڮk".SܕѬs@JZWPIYM&fB)aTaIO΄d 䡛^ey6CzK[qBU%D 2IF|Q3]L"A Ŋ%/U9dxjg9;n G(^>ay{T3b"|q8 z26^ĐGMYZX,.ttI8H%'=.,*j 3XW0/SM0"h@6DPؚnyd `/a6S҄ */+0+arY׌lL\f,0It"ZO@T9^T(';؈K M+؂4ϲIZ\_b#-g-8Ǜ8-UZۭT]ɮ3ufoGDVk dV3t\1^uپrl;WC?e4DA݂dh]lͶPt0z ` Nwsj3_<8l$ +*a`^6okTN>Sct# /W.fr*d%ForHMy,P(M(%(ZvM2 歟8 vMԡΔGFꓬ1|'Vm9N3iK E-H# SȣR,"kFK\$f[f8*5WQSRo[,LM&&Jz M8kl،ay4۹CRnMQa9m"XcvP k2c˥/]L Wv;Ji&lNJn/bT`D0+$̱= 411z+pq$Y+DQCtFi@#x'2DEv)l!gVآ*"lSq V.0Emt],iiw`JN}~ Ըu;vli;던U(1afBMJ'.\v}J'X*}5,ttG=eK,:C@Q.!.pЊB>χ۱m/2)In\0Fz:\@;XJe{S9$͓!R\ I 52٪}NˬC2T3t@ +1w_F B-@M2Ƕ/U`dF͂JcDx!(aC'̭iČо#,/!Hgx Q⺜.dJJ{ Fd} jB)L"g"8KiKx&eiHl1{2zy:[MEgCmSC*E.ى0f^]ptR""E J = v٨hpJ9c7+rوI.de%*'h2^(٭}?[PX 45UeBXGKk|dRj dg 4,0eMhou^‹Jy%u=浰d&n;+ӼQd Dd%-J ԼKMe *Nij4Nml+=)>FP--Zvːd0<.Ivr gsHfbA(9,ш63}e8vLU:&1,HEMccűX%E`_O{Y&j8$JUA͙QN-GY'y$ilzdPfvRJ'Ur_o$JZb ] 4'j-}~E7 B>)Z$ C,[0)xt՞'u3k`_G\̭^6d0/@ofܛrhut9\9܁ԃwL\۶bE6̳?* b+5ÛȅV(˗LŐ?L  o% áYW+[Kǩ{3 AaY:PԨ֘E6A6=gbΠEO+1W>1H3ț<U|4Ɇ"GuS- `Ckˡi2Qy[ϥoSzץxK/&>@W+Cs½P4ҽ%1MKГ7&_}E*ZE Q +&Pp0A8rz`]DC|;4uhvode= d.k#2<̞'Q0(Ѩ/DEFѫ@&3~-r*ʦnUvSrVצ+w5B 9)cTlrT-$1AP\T&IT? ]nV0gA.6R3#"EbVnm2bBl"~Y z0,bDMg#l32Y9ѓvL9[ 4hv6؂(Ife,A!RiPrfCgbU1T)1n:$%Jm^8|j$9Q;L7?[ZmKqP nJLjAdi={x ,&vJ`If%ۃ>E`qYݴ82FT)@o-ZEѢ MMA!!/|Ln J],$$ۣr;8DFqŭ\]dnek}z}4KFG#CsF~s3qLo(z{t 4Y5Z±VLF+Bjvԥo7b`g5B.:uRP|,ɑT0\(eIwg {hPe&J4[@f~FSVNB3b‚;#ӊ@f<5dFҬ,d+oil (GfQwTTCלH!#( cUʕ#"s?T L_Uو-t52RdNTLFzy'"WܓenRZN$`b2TҺbѨi2j24hl{lwLp*N)\dG7n [fQLN|lG&h DȱU_8|PXژ5tᖒjNh# !g7^M;({vNwK"T$ =i7tDZ1ޓ<*UDyΪ(<7Z5f m9d-ds2yvvTb2?',Kr a@b#о",Ĥl8cj"~\o& B`Xמ;r3̞ :U1ԒsHM>XbsP 5aOI4v5Q)|pKXDI2/ȃմ7EG9ddLA|ЏV3]۾NSEi.bN%6d"Ȅl썺vV" ;\q \)84B;~R7"kXDuLVPzs6!PZnIkIkO f,5} }LG%L|S3(:r]cT(d6knHfC22끤h)p&ϡ6|"2b+35dvUnvPae7i`B-|/1j`D\dgb&zF3x5tf0+[ i9H$ZޱGjdwxWo/Սdț!a PYrbg ` D@ kvC*=ZiTcΐJ.LJ4jKkz)PT"ޟ4!o+[1bf&h8f$7` OT(ac(6c*L1QB)0doPިAE`fv[YEJ5ڛjA(Kj}a`E*-5YIzDbiPw`Qzf)y8 cf!r'f2/T{XݒSɟIFR/c"dUAZ *zM E! HX2(g&yU,(JMUqb?.4kZS ESL:a#E&R#U rdFϮ"A֬Q@+S)١vZ)$#Ǭ-tEaJ_'d(YF +ҶI.m̸Iޒ13g(-%&f-FcXfd(5A402޼\n2'bTFEly#EиգmFߜLLLon^nNCQzCہBJ~$1sD[m LjDtZ6tnP<= `n(C?39.XKFJ:` ̖NvMt7#.;2sX"Z4qj;`1 n(e- l G䴣 !*v4zԣ53 _ |߀Jpbht=DB ḙT^T۹B^.He\?'/ê5BɈPn#C%Z)]NV}ؾ>XA 'X`rxDd)PRuA0jQgF Y"{yV R\8҉|1ΎԒ@y e71R[0J7\πCdiZl$[ͅs՝4i3O)3YBMG[?>sWߕy6\P#uX{JPFC35Z-chPsrx&(=YMdvSˮJ DܾdjPEi* P f!7x(N,j~O wE,i Ɛk+FZsk41ơPphVZy8o(y'`\t l3tZG"Kw#R R=̄VVJA`oH8 ƋpUЈKlMs:oS FQ$i; !J1G$G}P+{K$-jq2Ddfhq|x|g0rj}_3tLޙ_z ES晇2y7ʃBUNk*;RՊhBR$k(;o$5]}I0hctL<'3CF įZM~i6R=}}ۂ'2Gc\'Y]sAhӴZjf9D=itBE[<,{դsS= T@u(1r雪l 9L& uV[/C lY!H5׳-NTg8"Z0kSPrψEr-188PfGÉwZyViJNӫgc锷"G a"Gdk<lZR9-%0ty#l"F.d[r{ lqCd-Ũmd#bD4j5`5[qE %umdˇ$a"[sDM:~.q=%sm !?)PxY?J9s+Yޔ5 ޖөq3"r82}_ խI0 }1G)ɸs$'@& J3 1PsB}KDk@tl{(A'vsd=&oFrΰ $VBT2CP=~m\DJl]\)2e)#){/i]r.@X!2-|)6St{fth G29s禮aܽ2@ %Zj3{v1-X2,1q"9!B}l:Vc&jl+H՚LfOrd>~BFU̺ zE6TvO2$ieD?!RK. Phg^ܙ}S\ږ>IrB1A#!OD/7JE7Q>NQ@=Cs'8 "SQVL2 FhC R:H*+`"'*(]+0 BAtnt{$õv[Ŭ>`'B ETAN{ `羅M&HXƦ" 6uLHuG0m!/Ғ Y d69hKΚxM f,sgVYD@ZSAn!䧇WZFdi,>nnd!ߚwNOٳJ&Eq`/1Z9!^UZ#oDkC}DL-shi =3<7ߪ"- [g]Mdq"-p"@ ̑Ǘɐ.RsgXuMaMB&ۀz+r֭cIo!w2Fr@ j?T8pAh `K)]HI5BD ^#b0RćWOq2nQS6w 5[M䇛FZ@ z_f13)x Q#M8ZxY F/Z <*Hn`s  f\/2يg?k((xA`m12-FNIV&gb$ nŠͤ5L2Pn@Ns6]<bƌ|6wuwIҾNzp$kHs琬`1x\J&d@n2-pёCΚkd$v-BT*8c\tk|, {nXjd;WC^5 tr;A?U{n ꄌ%t:Þj:3yf71gejQRTVD2s PҤ/'fSp"GAAJ(J3$ JЯMq#6Vwy V >Nem KǙӈ$B-"b"t3dS AC׊mɆqB8^NN+"zB)ⓤf&`Q&,!߈H!؀L6 G،H D<:U/ 4#䐡uslBdEeo8ag5MkrϪA"%edlQrj^6Ei?lt#jp.^yQ,l@bRiUEC S7M]#px7/E45_P/h9fE]š]#&chMrTz ¹c0}6ryRhGC3A)'װAtݑP \0K3LvOz;3s(EGf?> F@P$3Kۧ6Q_jUT3IY1 ג+Bq$X`)Nf@K n+Fu-xlS&Zi-7I!҆qē1ޮIS9Cm*^Tx=g!O̭Ҋg_;B@ .*,LJٞҋu FCaJVЪ EXv8K ݌IL1RPvӢ ++FZ1:S"J2()?Y,Ev0B9Vb_o1ZwaEp-ivXX[TSSyw 7&1N2t`[CB" ZTld#MX+…MXuֈKNldAXviMոq: 'C05Sia`}4t!2#I$c.wL M'|UPIׄd ]V%G#_̌l0TAZc1vYQN>ke5:Ci )`ئ:Cv>ZMVi`I<5QРXbq %cǠ!|GrAz(;b!f[LJF5dXJhbFc$TW&b\ƘHˁn>tF}0M;f­0E8r,8b$7 *+8T 04DJJФQέU `m{k25)SVXXL&54U/5 :g (s}$ڬYX\ y E"h˨`tҫ漰zpFu9QHe+]D3H.35[sS0VgA+k{]:TUn$uͅcI>K@{#2_|9[EduU+kjsF:gij A|?j3X?=jMa+ftgCaVI&wmR8&Mң)xZr)bs_rVӨP͆W3+AzHR3Jٳf7)ۻE3OD2oe@!*ejUb pBP#v1PQH%@Lebi;WZ ԞqD;%f,7XLM C#y%%6ŷ(Q]g$_b4KA.yl8^K/i"f7xf qr#?"4W}=ܷ]v|v,lG@%*ؑHNRǀQ`&a:v(YcS݌#!^݊ vyo6l+/P^f. :ua[dɹz9:%pCe& u^Bݠ*MĵJ2VQL{DZԈ:JnP vB Ys*eQȰ|nG(3%?i$#&k 1l55ZA!)#b9bƼOuS㙴9\{bD0!Q'lHFm4"L^I&IY#:FgmeJ%*S4ו[e qg]z ,B,TԟՓ^kU]G= X^qA2_J2`_Rd$9Dpvoʭ` >8H`9J$W83\/`Y HlUu[DnJM3ܪDkzx +Yk}(wHNV[>o'HjHS\.Ef`rנɟ0/{$x^}ėr[āȳc:s?L !%@"f8k/fƻ;z{[u}o{9!в3h IF$ y Rs{/਍*SNz!ynr2*: LGlЯȕ(>c64.#RF~m;t0 6C!Mٺض#};cVBK,Z$G,! ﺌU﹌]]A]]ǡD(p8!j^鸉Z{֔,rQe&5JH蠄Ҫ/?h0Q6oE~Zug$4+&(ΓY,]JdµbJ|@6Dڥ$go9)N7k62 5bAFgvp| c8q-g `T"ig- Uso-68EAtM+I*bZh ˺\QгP%^8tzŊBȈGR'.9S^~`lmp'x q)^BQ-^T̺X@S|'FL5`f fr).ĮѮƞ}Mg;pT&H;UP7=rRLuV0+#kgyYFT3sؑU3K+~xW(gWěk*[L:#kW]{NGFEF֘xbNN1n]Aub7յ4TwP${z;fl<=]~}띳o O"+LzMKepl^r1z<>|B(UƓT:yj0&hZe19NSKR.0+5-RX3,ώ3Of$kqhgf-i1k4i)CN/ VHS(O& nϷetk+jQS<5Y!T1-31B`A9`X6BB&5g܌L!XdT 9:`@"jUjfZq-ZdFYJJG]dk*Ф1{؝U ; O+K5 QɲV['bb{W )XxhVBuԒzLEBB#Ud"n6CKTAC+Y;xiOJzDA*ϒF%˚rYyͼv*-Ш[/EA=DlG]B$o,$\j0]]N̮t]?pe w=]7NeܕU#+L 0=eL!k0#a9V9PjCV*^g ]\jҮL]]:ۻ"hvE&<k{rҁ܌=Ox@,a#D- zIC`L Sh1ތ"+ BJ$bZ,0qg*PT Z>,Tq,#@g/M ?e *k8V̨D}gҢ!7oWQCy,lDdch-|sc["&ַ`h)k`oc7SM(k&'8>7Fn6AX*O֪LpEcB"Z}1.E(L>)о0M0Y<%Kو(, jKZlFkKZjE覠֢t*5it'u7XV O*0QWYaM ˎl?jekhBE-4mx|_w[yδwɫW#01@ I9][-9nC̙UyrŮ]yl\qY;Zs9kDN]vOFI͆uT=_"?iв`D =]ze7(AG; @3x.o<ܰ Yq b+zP\&E`AphS(rm4rP рڴyI+*u~LkF8I H>leh51/z.ڸ"OHNA;r:^Vyl(]ut\rXjww25kZ- .D.x/Zʩ zH0Jz; +=V7뜡 l:5 BzʶMIQ3VBsj LpHkr>(mj\ Ti lh-=[ڼgU5%A#-Xi˵i[)Տhv$lESjpW@ŋuzfTѫ1k75طXB['cбF4ظ0{#qY}:#8GdNm{Ej"@PhRز>Q$reL%ļT1!6Q%=*iaZú5ˬfKK7 d)>1@Jӥbs/gx8Sk5i5isֲ+vTgxcokN"NA؀+1?@2 i<)2YuL38cna㙖L6!sZ5b"up$#hG󚖆ƔP]*V@ DḍT_Xf4OH'r3eY?pnlSIZ'd]5H~L>'YBmx7o .mIM\9n}^ Z#"փ57yP8Ӭy'6:p ze,0jq𻳹OD8G`vBT:ɔaV{cɔtk|:x68Cj-;jD]x|x-tJ2M^P+_^}h6GџdYۂp+@:Jue|Z/$' 7S6?MTwf^r%fúĈ:4Ep47oz|q\mnv~7@E9L|g*e$LòE93LS:`ʉsyE{{{A"u'=>֠U5z]"D ;6 *\ <7zմijYz!&Ul z%l1ԊOos喦p$2Pi8&v_9 ͰHѼS*"~񑛨 Yu-e44A>iEU/Ud2ڠ2{ЀSQېn3ZBC[Lu, KfఢlNa ( Sw8"1:L1T5pֵ 2Oa,i,Jg.2C/Vڵ`t`Ÿ́NzQX/԰PNiuoDYRC\wAY_sLlpD}&/sb߇eAϚHmRURpǮβ~|WR?ϩ u*X8Ƥ/84[2NsKz|״޸CڴlPv_svbZ~1 | n$zƄ6quZ:z(!CZcsɠ fz6:8}7VYM [J(^Ɔ@|0r_Va:G K .8#f7aCӛAied̄:e9P3ځ!4] 5͏#hBj BkߦU%1o4fQSJ?%rʚ d;aJIA6ܡ0"їhʥU\кVkbJ]h``(`Vzbp+AJlW5S%ԇm✤ g𠂑^,yh}3zհo8JPӒ %ߡ ܻюbk'N\<*r wd ,uuB>Ѽ=D<:;'Io4aaxP]Gb?AiLB7*icq$ 3CxNzj{YJlbiDju\#Й3qZ8Jp-`{sǃpdžpc{+GU!1սd,qMwnZ 3PǛƫ .1Yn…Fs*C$/͜iUgSmDĈ'7M>ⵊY_Kb6q]B-bҖҦ(-om a^;_ X(nِ67DǶ?ncu$&`4C?P}ܢK18]H/>nO0Rtʙ&SԆ=CH/Z'd'd: Ўď_7uOk"ڵh tuZb infp$<[{N&V-m';1%gqUw-,XT tAL&j ̀Xz`7eګ@`!#j*}t-٩ !*][DG РL @1jSt璝8H~{]5''49]FҦ7I-܆AM]b 5&J$m c2eF&tLen{kbe`%rrƪ- guڊ=hAl8>꪿_,u,zn-M o.R|.kW)հB}@ȖYpMʬJ2gѝ=&{fQ5Fx*M=i(l\hn 3Y $쉴 J&߶~=Å1lzjA R#PX7=kPkj,% 骺 -aO$blu|BT$kۨ `ЭN$yW<$ʹ;Ép0$jU[q"k>~&#Y%50OKC 夎aCF5„$) L{qmmѴq:2u ~$wGQERk3fÈfbv ZaTiVZ^;m6;E8Ey~Эwܰ]--XE甇k3WƧ1\Զ92Ui+wmq UuJĚ"MUN;΀HHKx@VROhkc`nY [RW-2E]^Wг !S(+-#B`IEfv@gG^n)I.1;2eҵ'iVU, u0,(s[rN_jR;[r*m9԰V]B"H&-aID t`ޝ3/_BH:%bEAu?aIע.Q\W H;yCgqAb̋MVC>pmwtq*32bbC@p} :T$ړ$G=Hy {u!FpRҵwם1F +wd>6& 8O&ޟuX4>|ZWWr݃-Hizw<^*mlڠG|;<[6YDԖn+mOϵlY&m ɛφ oS6m-[FU\TsQ66_XD#OCsMB@MĘ@5B@ubfp,76`Ե oGWVf*~5@9 hKUZ-6' ݢW=-_,2cj!ev+8-远89TбVw˝[h/+#cd.74D6sYNF4F"f.xZ FN*A^g2]hSѪ\38X%c I`*49+M"ۀp)DfeNq >my4ď2ͺmcTQ2U飮Zņ㺕!5,#Bq*8hBL!bv%"O23p?qQXe+ުn Z3vZ-Pxn8k-S#0n"OV,rs^hR0¸^pI˪RK.&B.<@%v& $i5`~?LG1F7<؄5Uh}pfh{Aor>yt}fpdxіl>Xi(tТ2"H^OV&E^Жfn_f퓣 \^B":;7eLH <%+Ct7o҈*Uf0*j o_d]4f0mu&KtnpGC)md-'fl@[im);jjAht^F;ah;LZpFɔ7G Gfqj]޲L hH5&MQ39ofknc+있rLIa&40ڃUAEX҂BQ''={;S( 5 uv$Z\m4͝rJԘOP̳iϺ[i,5 b>ZpIM[a{:Ԇň C(*736Vqjxe: NԪ8a %#"}2WSoF@dsҮDiy*WȥT ] hԏc`ME3ᤙ ,w(] pP7]Lb}\ N#1;=vYDR $ t;=~y)sv'K U-oE!g^[L-з D[p[M[̎-WSE 7_pG8T-)7fqoo)m9W[z\jq%l@oPŜi+,pIgbޢ ZL=2eg~*b1 ̰\h(ɂ2bvGvDŰTOd UPR~"Sq-Bnl(%v~D3[u2<4`ɐ marLp;\BY8*2&FuBH2x"P^y =vD,7PhF^ryt&]UVoeSi__aTcW %C`qu2{Vcpmh1⭿ﹰMA⤘`>9%}z猴*Ui!cv=@ ܅>`-ɇh`@i@Zz]3Ľf޻#Bcfݥ;i\ӸK2>¤= & uD]4_l">ɡ93 "c2vZ䡫G3 ]m tjjnVYGAxjw"OA{}]7('/ʂRaTJ'fv(6cɸ3^*t;8ΰN> ‹};k-P36I'lG3/l/ѥ=lFmG;K:)\m(,+oA[7v Un6H4[ЖlkCԌmIv4c[bǥy[P[P[ٌ :+Q `[ c0'QUgvoL^OgpۜEUpmXE+ 0}N PF. 6 U:4l'dհ19hx / Dbp kpad3tC3;w崌>ljx6ͼ,R_Qۃgr-UګxԦ#=ѪN/@b3[8;]lSB'@`We ){R#2 g[R ic2Bѐ`kq=0؊YOpSudR QK'b5GfviZ{B,W̜-C"W)'VT7kMu#ޠm-@rz'\*XNvy;VTPKue*^.ֆ9Θ}'VM5*'՞hפqua;G*<]mʗP/Q} ֡;^)2^Χ3[λkz^vbk؍g &Aƫ Cx} <};;\]t - F{-pfKy &Fz%ڢo^z-6&A6W{/ySa+g{ٳ78k&zi"8UV'^k&g3 %N96 \E l'Y5b D'Naw_OWf$/UXRuW&rj4l$8YѪ^d~EwVX<][ $'2Rcsr?zO5pUwH^[Mf iI>\p\#/E,ZArueј!s=I:"hnh'gd$N, 2kZ58Uv`-˝P wz0'U#IôGTױzR4J3)mJ_PVI=̼Ω|M.'yبʔʕ9YVU_ TRgS)s6\׬zLL•x7{dH<4]#H m h<,Rԍj\ tuqx&zpYv5:s+l>OҊDai0il0, 5W @W,HF k ?mF㥣娅 `ɱ^}`M=>,K&T$je3>5֊ )3 -LAϣ1WWNti\&TT6*=}Mڜ"V^`g!jxc}( ݪ<׆ ϪM'\ ҺhuSfu&Q&]pUlL+nC:`ed飕YӍV^Xy#Z_K3nzd/`#X@vTHȜ+u$gwZpAtj"ҕU:C_UqXOI)s aR1[ZŘf|6 =ܞ khx/-U%˜<:@zz2zͬ. ,;P37o-P7l]7cAރG#}=f `^x z)|jpmv67v-DžL[ es7HFI%ߊtm:m4b]'B3}j.$ /^ntf*2Q0Dw£>z*caQT1!7(e iG-Q9uLK.)*b/˗Vu`0krqWq i1dDւQh٘iRsWMNZV}NTNNf4pq 1Su+o9Zr`Q/{y6[kfs]~SQdU;3ZZ)8K!A"~Usu12I~V qrHQuN,oZ&)BߊKh~ZiTcX^Ș7 `Ux/v+' bTFfY>hb$:w`"Xm EX*ebVm󽴎mO/xbtp"h\觔ʣ4+teMk;ɧ!"8S?pozRgۀO ҹET=M}u2+TݟUfPi߆z4Mz]%6]Ю,6kEǔ0f7P,Y:5](VOk1#F4sJ۬9A{,kLh},H._*E ~ }~3ꖐů/?c1UC)uB0NZͳ oCd-hGB~{2ɛAMRfj@WVra/[xMlܹe mjZ[]njrBr u򂠮ѯ] ѓMTۀ[M,I`jnq8#zSIaqGEn=& y2Jv}_ҒK^RKg˷gDJ՞Ԙf޸6fٝsutL@0_ev2/2> fiLaq 4Z i$`뀤qT<0:@7 OM8V9 x؅'΅Pi'8Zk TY L"f2;fzEH:3@Oe{4=-BA6sgpU vrC:ntZ LÄ|@s{N )z+ 9Uu+~Uw>T IdexgkZ̏3F.G]H O©ǔS>V8m.g㆝d\`صLĸZ kҺėbwogMp몬& $Ok.2"oB[ւ$%uϙMRBR]}qSjfb>*$];7?a<)|5~2<"ۚ-cʛя֐~/h޳w}=B^ي ۵u6,vDzщ+Ʀ3^ׁai<$]FyBKި\n61O/ %^D2NF ϱ'7 XEߔN>9[UBdwiNGRS2S:F(NeN<_ l n5BߠU hvxJKfYeY5əw|R4;:Mscl Ӯ&%5%>W#`$;`mNa`_Әԡ9LhHv DseL \X)jL8/-p8MV6z[H?ep\ #ͦ{ %zĒ3 -Ƽ\Lrer*٩RMe!{;ok<󰫊|'P}ri뀎`L"CT=]Id5{]g舜P;@@q9rr:$q;KiSMr(C/fcLzb6 zvq~:hgj cK_JKi,#&q{VzQa[[ڒ,-Jfhzt[ԬM=aM# -(2>jIOxiJhӺKG#uA#a5n5q٣(mZ=IAB]y *4%@kްQ71 "Ocd(P.sg\Y $ldJm.I0'M2ii>cfC EcON.ձg'ۑxmtSI2 {ZO"ϟ Ps* Hզe&EkDF&A)77񡡦ҖQ0"=o}6ۨ|)6s04 @='i@ "|*(#FO=Y 쬎;Cf}$u-HmzS FY'ekkS-K57"'ί!Zk$P-JӚV3ā"e 34KwsDH*SSE^x<tz 2rt5ԕ>hM>ȭcy}V뼮7w BhLǖ-]Q'38|eOOeCOмx'gCzUrSܫ{y^0c v!I[݋1v^?!Rk25 CBo0[{z-(AdXB>Wjz DْAicV^,d|7cqyrm|-.#x6=m9@U.0qƗ;K- X|$v2v̄[64AD'QȍL/8>[\[UnrԼA1@A[6CZ`j ͩpJ8l}z4%-Lu1ò?68\G߭i!2fTgCL+1pqf0&=OZgq$h"8U; -DŽOu^;!韫SoAJḬL8$^N"c!-DC6 2cJci_(<#93 V+شWߏYSU&ܡ83oNaz5(~R?qfXvpd}iWCgU@~zH0%ZL׃2wHl ]\QӬ"G[}F38>t(ȣ4sSmz Ofg醌XiOҖ[,u 'Ta^`޺ >{Q)2r}n995&-j-@'n̛Цׄn8HӃ(G[tM6o ^?}SɴZނeL8[[ᔃY:49~{ޕ=$m&mYlP67|7y KzAI2|4u`5aѣIűh3*Min'NZtXpH79i&9"g_eЅTx0k^ 3øZk5Jzb{p.6x2MfyE\1p6Oo`btՎ sղ ݘ n%z ЛJ.=oQ`)X_ހ8>{r4f<i@wJejO*) aKM\p0/F oT 0fpkduN-.Cxʜ9I#2V4`OH"ŴY_AӲ ˷~KZڂ> ݓ$E!c3h3έ N6> hd(Ef6zTғftvx9P+EA0J/P@fp-mB[v@ (OB` :bgNYZ:-Ҳ 2НOq%qrgs^d뙱>nEdw8)BXh+F7̡L6De 8.߳xq]`}1@cZ/3{gdJa'nE@Y­Pҗzz߂"2 Zt59 )c> IV}f(L>6=ҦQT͇81C@@8-Z5c׃t\[PQ9&|R/a0L0{0Yr撡@Z(^';;jX@MEE I[pQmXQPh!.a8, L)  E`KQX_9Z\)@9@k0aUER6k H%=i AT%2f@ YAaa|G%(N|Gtì* 0Ib굶JOz29փuA2Va*gL{WD;8MGN_ѥ$| 0~&!vXSڡ4P]zYzVJqsyuzWZ;J\%Ura^H ﳚ+0 %V'gQ4OSj;an7@lYzu2T }|uY<'7cT1DNapnכY+Uld4pX7=GpR26`ia_ ~& Lg4i'`QWI|F/6RuX"HX*lr UXE .>km/gʍ)#$esz5Xl00$k81[A!瀥ʩ2xi(IsBV]l+YOr͐E:sa}ǑH?ťQ͌>~-,mZՌZAo-erA2xDX}ej~;cvGgRurȓO9T;O񇉓rt|iLi$;!;΍6s[JSå2PCUFl6 ,#y-d=L7F\d5 m=GRoNzbQ[,hkwސ;R&558)Qph5k3iۇn> W Yqk^ |/C1z/hE>؀Mg!ȤӷB SrTRtr :NʲL"lkar?*"(9hi".,0!ă3rX;:dU)mXpW OL}=Jz7bb_Ua5XcRPy6${S*4b@{TNvQ(:p 90ipTMTJ8PuZ \ aԇ-d$WokqPa RDEpv^(jփArHՙ` Nv6 K`d}м3X{_0QDs,Hs]{LRC 0t?Gk՜N#v=z넣_;UbX_PZfgCZ8J1\x\E}}HeSA}qR8Z} ^1.c*@_==V/3,`LHyq2dS|7]q QE ˼Z:aɐY(6W!~LlDd ئNt@MudI (*lFu$\Ъfs6 SLO P͚C5mwQ_ƽE%P ri骗 )O-V9eCUnZiOrt7 b3%Hxy(Lmva@2k6ҲBa0nZ KF-RRk ~d4Of(9Z;4BJ qV[u&#,lx&^wZR1b#tPTNn:$ 0]0Y{zZ?v\L9@%z7q yڧy,rޚ}Fɑ]7q]S@sJj}c'ؒ`].HwaO}F}!8m?^6)yv0,S\-(48jX;ѓMy#v/̽F<@zy 'U]9 m3aV97U $z{u>{?,n$ u ࢎŘ*UG| {SYߢdo'l(VŁz$HL8J #6{u(bLv0Cx4p(ًuEBXߨK3&l#Z\3 &JNdX^3'LG#X*#°T%@FhxnpRG{Fp#$$ǒjY 𘆿)Nw!H詫]zzt zv|F7CIi!bb:(ɣ6%fOa-|T#cpЛLG ."c]c=cFS>qp(ZNH4ęZ LĊ`4oT%F]S솄'^LO^NpU_T~=1hR /skO:l n(Ade Ħ!hP:5k*@8TPgU \DHiLC99*rʳM$ባ$T㒢+wmSF7 dg8jBQpuVGA o\^])p` tiIHuNL^o8I$5hS`ty.>[Pc0êCv#b@Piǜbͻ:WjA#yWgl -VIz78qI3`șqrA"a<Mĉ@QYnFP8z7M! mn渇|Ot'Q"K[7G {>Ώ1z&h)s4tߪU9ΌAY *68Ɇ$ܑ#TG,ʷ]i¸+u0m|0N1ȖcUTěO_ŁGJ~c9R1'z5XjF$Msw|v ~/3fX"ϼ;!$X7ϕs%Qwj7ř K!ʏwL+pNBe2@_OO K3X;oIAX*(";_Ka뤣x6,ls#yta5iY8CbJluѪiM-2Ņ=7#[,6 B$O `6dgMGA"^2εQ{gXmb_z.q3;tE|GUvF8^ityd@{G%`tc~\T@۵ T$zz}:]B|*U<*{ȗN~}, nZHIBl 0.ɿݱcL(BC2a 1M#)XjuDin v2@}90N7-n0Fh3S#X ϶[ >_tw\}Ar;Ԇ%'VGt/#gظۆ_IIጕ3Rc0|:[&E}guE@lmBۛ$IIX:H->DIqz)!ۭ# ta#O M橬d96dBxX!^ȔTAE_11DP}|yZoT |͹5 D5L63ە.'$,:SQ&CU<KH|ג. 5è?L|Τ7D!@tE+%ˆܕPi!$թsT $` SCKFH&[jM@r`1J4րOlJ$LMiK0dg ^8bO%rXq8DG] kr|CZLfAkFבղϼ:TouTrZ.hcdG#@ d]#qa5gT3zZg_3MmWxNak"<~}<N:j{.N1UzNX%fwznP8[z!$ajǷG 숡8pVhIu2Jm*6bbs2 /*\'Y=,&TgqB"guD[mP'Mׇ$*zl+_e- PēǑfV{CQ64 =':ʃ+{'/_rNU[QJЯmz4+bHe3/pXOϨ/8f0<)/"BI"2is)ҹ6}# @~P]zQNE*Z9zN>i [sɩEUo&C8rnj)wyvuPkr!Q0^SZ4 ux.Kh:K+aLX?톰ՐyA^S\&X;fF-EAuYnrBHVlE ꜅M3Ϩ0ic 0‹x20fUrܢuAךSi 2}z.o#F&y&<9>"1s;a6ZlV;@8^1t jghHȓP0nڧ;"s8Tr~]>1n)fO;9Zi`(^ IAJ )0l@R! s0XQ&Z (,ᦥ +&45\!u]wt 2o6ykY^=4PgBvpflGyo^H0D  L Zw CrH枫 8VEMQk;G:HaUwי\r2 ^FUƃr7s>p|Èp"h2H[׉=+\H[a`+AKfX4 6lF-mMkvG3O"%66`lE9GnSka\f-!.3FTGIjHF >."sN Qռ7XJxà߸,Np1pU.{Zޕ uz12gշV}5Z2='=Rr]?uƧNҨݛ\<F_Ɲrij:xdU~{np QjÑX[@C%'k}wD,Y\YۃQ]+'I.EYxIb1q U(03L_&Jmg3<лAl$ a * [PGwd)hX~rCi(@#"/Qf=6-?ٛ kt o̜p-/o}~FyZ0Ϥa0Ğ@Hc3apV.5Sz5mmbF@6yyTP{d@tjrN)!e='L lX~!mF-R=ǘ2(Gx n6<jb*b,&ә>5rykaCh@Nx7^N !E2eٌi»Iδ7?M> )&a1 :49 kzY8)(|HǴiT C4[Pi{ zD\r8<^-c&ǃ;%$  u'&6-4::Dzj OCmTdD. -Dp\ !%O R to S;` $:i;k9kփ+$SCd.ʌܭك_I &Uyk% .@gTM27ޅ 8;oLEgA~, (b aڟ|*$:P:.^/RX {CZVd~f}uwH 5jg'|:V;Jځʱ7q$'4 OdVP^eӶ 9]UUxlf<]dheַG3?WȻ99uɩK W |m9X=܈os'> `xh52T`*R!S3(@_rA0|h*ֆ@m3FbF([K4w38lw9m-9)dtymV^%6q&LL| %!uhCm$`j2ƺ'"*¢(x>dy&,(BʫF_ +]f5ȸ4ONG]q~5v8Il3VpnCpơlqš|79jn86XTwnjtAu&lr8 ߒR\T.ECW| ֊X'{DF45$Kay+2 DLhQH $H=3~'Z Yah5T~&U~ JL2X q WS{ z2;wU!c I719kGX9fĆcBjgv/9 /$  λZhljHPlԧO)8-Z3qdllaZZ3d$ou= 4ԋ9{eѥkPR;C=O2'26|KqPIAp/ Drb0fGxx3!L{ICx?7bOݜUp$↓Wcͳ+B]QR"1g:Q.qDGi$h @e{$;jNT$< p`TΠpv+L%RXPeGDQyٖe\qDmiif)NzS "Lp&*SΙWy=OBڬN:~^85s=qz_ . ҃H-Vmg*1֜Zd: vrjM#F [ZAhj qZM,E]%qjQv ;ٜ,XUC`]LSD>H˙:ύȚ1' 6z8+5˻`.8Jة6 ?YEK\aoCA*o^]A{.AJ~p#9c*7/[:1'HB) .^)dDDz}֛Bhv$uM$H*#WP%41ihNe*{"e[le0 Gem4'Wco2 7 \fK?zd>g8r^;V􂹜Fުb0nTQFoErw' D9aNjۘH^;+Nciv\Q/e|?}b-%Z 6j}7Zdijɒ Diz_=Jq GPUfR݈{ rt11f-2Sׁ) ,!N"':ԡ3å|kW1# ,/ΩZK38!I59;R)5݉j\gfU:S8ND{K'8Au-$Q FOHITRkGW2 )-O`pX@``,O}|a::h8l^&†6%'O ^|Rjji}ۯasr ay43k9??O~/~?}M˟]]{gߍ>~O?oyuo/>{7''_YX,.~?ˋgmٸ? ^ό~x=5ד^ώ~x==f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(f(fffffffffffffffffffffffffffffffffffffffffhfhfhfhfhfhfhfhfhfh\T1^O?#~z=IYzg~/}'X]xy>Ï3?^Mxa7|~_a[6ŷȏ_679w9ŷ9:5x5k 5x5kj֠5x=kNxx=knxx=kxx=kxx=kxYk~_?G~]~~m_-ӟwO>ǟ7vgI ^c__m j/Krn>//PZ/ٕykq0z0ŇP`V\(|=`p,4 q,LǗ;?jY H=_an,!#]|{6Dxj~XKG "~1B ʵ2#9t9:& cd(y R6|\o)kFT} 㚍'APYL+y6i8 [.NC]ܻQTcw=*!/2b)ňO\#}۩o_hD0S,X8I|a]:)-%cz=EGq 9ʵGmhBHY.>#Ľ]#o^k*zJ{|M1(E]xňrVxuSJ !)SY{|8YUB)Ezw1%Gm1=Bp?tYc1_q(5FT} $t/~/ۦt?|0 ?;(ic>w._rpD)럒9O[]Y?Uj˟~@?⿞4X~ycהj?*~KEOch/T?uVˤ}U/tAEekc"6q2}ї@ux9;?F` O/v?{x7;[@ο_~7_?ї?gO?xp~?]?{'$N!O?7ٟ_{?;7wn\Mۻc?z8~x璗o87^{,?ozw_?]/}G/>ї}q+c55M7[3//~_ӳuAۏrӟ_o>?~ŧ?~O/[»ח{'_~?<9sc~{䇷g=t]'?V?g?Y?֎W{īgk7?>UK0U+HTϿ~>ŏ~GS hk|;BKwo?}.fw{_w??_>r+o?_]Wwϼz*_ݯy~]߯nwկ~;_~_܇>?#ۿ޾lf+ooT{ G/f c_kj|sw_oɭ̲eի|TF:Mʣw?gvft鯽"?+m#relsurv/data/colrec.rda0000644000176200001440000011134013551065110014621 0ustar liggesusers7zXZi"6!XF])TW"nRʟOqcWK=*6K\3?Amϓ4%ʁAsUS4<7rtQr'$vX~ւT3P{o"PXK#V^5b7]q:S?7+gb?>o)!#NMZ{CX~X]O4e+G5[6 QצhyQnqF4mJ̣~8&ȷUƴr1] >/fm\Q޷MLD][O<([H=o"98iutVr&: s1CuAt*ƒ`"7V]žB6`K1~7+H_KdHǡc]Rrԥoms2EaжYm"$aK^l Т' /C,a omp͘;uװ[ދC[AƑTCRRirm茘پ@Golq;Y&CΠHSqx];ȫ9J ,I 1wˡW@:,4ʵ*aRkz†PW`v>cZJ0k5h]}4ԩPxѭ<YN It[2!o7#2¼Jh-Y0*ڬ2;=̱Vو*ciqwBm2ȴ/s-*JΤἢ#i9م$@$?`)$(; zKw;8?6_$ ډv" >1., #h]^By<0KȰ*^ri.)ފ犡eƴi߾Z]${|lх*D(bE6^֪0M!Z* Dzy#:Q?}s|fcl Fw86$w+MaDŽ M!2"4ڼ tO'N.{rmԝjk-4szlќf.ۨf~/IVe-!B`֮.G\f7x*{yVџ"JA.}҂IîU]`@ssly<8?}cHG _YTsmѝUsg3M iOU!ԃD[DζA7fIIpΙ;)"ު_!zA 5W]Df(>Z NSߞ ;jo7d9+d+dG1|tlIAb. N5GZ~HW!'U ՌSzZʨv\:Ά;HIH{냛WR GukuFPNMߐ@O0VkP)LhgD0Tk&,|9d{֏\!2|@Wu;-ŗD#?5.@軃rPYm7qrod`1a}`6;"vLUk%Fy<SB> N"V&#BKαlȫ>cA :$J(|xWGZo QDDqشazׂu sEpW]39[~2~Ľ' U5M{)y"׏ m @2WF[˵*dtjXNc1u*hjC=-(0ӝ' m_-R5lSBI7kD0k!M\Ts?4W Ъ]E}*6Hz*^*H*IPF&#N,IiHc<ь"^lP-oW>s`o҃)r8W/ ީr7"#b0'ڰ~y -s\R6+ }^m>BL~4]N'wHC%_?FKzXzYWIѪ{h'9Z &JijǺ i2_tTx{ř5x]{~_xGߓn6oX}ۺ;P][HFaU?^b g[/ tfKZ<߷NtG:gc|).Tm5ucr$2q%m6x A}lE#B *uW/Z֎gƵmo&;&6vöq$#UtNb )*ylaD.[^jX >X,b#B.$垒mNR<@p!KMeG T{'8U w=,@9Z_Z<|"ǥiOT:!]`q0 85UXAZ@9;҃ %Np>w=!Or[]@irs M&vFWb)xE5# 3eB6h(ɐ\7+5G[_ٍi E8oU ފM_R#|3(D-?X%Zf8;HJr{Q20 g\GV[4x}u*O/69.U|y@u!m,b~__ zt"?[AWo9l.=ᐨĽ*&uT/l4]rs]uP}ko yP~3j^ M}P|m'Efـ@.<'' QW+P ON25̞\0/N_+1J/_:YRD8xÚLG+Q7K<^oNknS?'g#V^5pB.e#-5M/߳8!#k/5oUրW тh c-a$6A`IpUɿK$!Z}~+Iu>=Q{l.׽[yԳ|jq՜#yeFt.#idn>P`T9N5GJq0f"*}X]& Ӿ+h DUy?f+\S >?6od.+{~jܘ3ciƦH1='Dh/W,1"]c7iU4YfƋ'^ kʆ[B-~ި*[~(CF,UN:|/)+v'-{B!jK~K gXI;NѰ8O`ƭ~CdmE? bdHVvp VKuK_8L ~Y:-VP _k.(:Rhȥs|݈Q{d q]"ؤP\YbNI<ׅdhz062.}~12ÇŐSن|cJB4OLss qsd\8 (0-Pj"o}[It@B qFOojT\Ds̈́6u<CԻD31~C}:y't[q~1:w赍;עZjHPDqne;FKS?5(ʷ W_X\i^+ou[6ƅ^BMߙP3DZy1lCt,@ ,ƓOVNՎyYǺu<@O:Nw@On/W𓭰J{ڮ7/;/ +fP/ z hT5 vzZdLRY gwFS%%x% +k8SbRqel\NEۄ SSX#B;Bޕ=mbuiQa7Eo{B&jC*TCދ?CiSn1J`FIٰ^DBsՉPRSu.;ތJW")p`M>Soc*5)}#5{JHy^Dӭ%)Tyjg}&Osr1o%fRWA&~ᦎ~IqU+9gkA2|Tc6, ŃAʥrFf$xV* b'_˵EZn9Vכ֖?f3< Lpѵ4mVo hLUGÔArP7'GjĞ+[D, yeaS4X4OzHaq |N})=[F'F~yC( p] ٧o؜וmB̐ ;7-^ZE֭ß \-:;u3[&("{fݫrč{9`o)f$v͚R?pldɆGaS(΄6-XeY.Afg [2(-XssM&I\1u8wB[M+ fynmsQ;kRnAi<%ZT 2!9a]Su Zx &e,Nf2Em1@a PX.S.gdW"{06- b&QoUyMHط w&HkT\/˂(@-{% JYR (N^d]UW_n4v!k㱷9`:]D;"(6;ϐ=?fwwc}zC[՘T-胺w3'yikb*-L^!^EW &RB[0~SݟXvBy) 讃&rê!-(X\ɴ^NpOZTYcگA&.cv2͒Ū 6a7ih\ Ulp|eSN*j[zvD2,M@_g~PR_=:= VS5 Ժ4abIĴǤNu!3!jxtJBpSv-נ0lRJf>}3R`kVA _i,5.+]J,7mD4γ*ȇg֍[VQ6!/|T_)ן>)Tq;6+x8֚6}FYnMrD (%nTc;oF˞[NދѷnU}ӵHB%2pJuC-*єzZ"0798&d$C?uW n௶N^:Jzزc{{0Ȅ1H7 C-6>] voXġqis9!MҔ5}X%[%5!E/-ȻTCi -D'w*t"{ŖZ- V=LG&j,tu%f"Ov%+ Y~\)~Hߞ,^we~n9Sl rLz5#g˝෇ :B[(ᩕ"*8Q71PPL:7";-qTaS[V]wdcUG`~ s-Ԧ_-T{x2LsI8jL3r2-rXHYf0rI MlmD($o[/GcOTԼA(i- @̻ǕqGe?s6BS=H-!ehG|0I8:^z 5;Wd*y*|9t{]R+/::Wa` $bp"V",#Etup ||@ҬAc՜FOMQI.L%^ !\a/R'cEaWٕi4A染"0Q.݂=vN7E[on>a?xt3>C6~Ŭ L!ϰ .V4|v;⸾LEJ:,XY99δPK壬{6UvHU`”qCc툀Ϲ$lr rdIۋGG\)&f/{@ B-+/vF5ClTYrSd9"1Dᙂ%V׎ˠUTw#vҲ2ٛ!G92M}v{@:qgE8!Oۧ'iDIאS id-$_I9qt)&ff+EwpeZiߖeg}ǽV[-C͐Hɥ]-)D3D>-2q' [_f #mdדE^Oښѐ㞖)3?-IAKOAptӯzmװԷ{R5`*b!خWC$qF" &Y1j$np0rkC_)!fL6ArmiG^ϝ}I>1.q+7OeqF4Lh\M}_ Ç6օ-f; !}v6<'`T^V1VM܅2qd^p(<ϦE$BTabhW7}A{a"!da`gm\iHyV#1꠪D!/.bW˼]AR8;(8{4bg/y6rH>e~o,*RzU+c)769wrx0o2΋b6ߺB#[f-.+ILVɕ %20OuCB$'a:u&>[@g`Ze4}QX sY? L=a6X3rmn!o2;]L csI"W]+LH12F^/YrGzWSmnEѓGC5^oNW˷CxYШ_'_`#OVQR%M褪 LQQeX4Oޕ?35wa{7RRyjȻ-K Gج!YqWb>3M*ﯯ{Ŷ rXZZrÂC/+"<2Ż*X8L֪{9;'Atv2~CԾ~2Ө‡|4@;W/\/CǴO-x:Z1Ί-O/4_9GQK*!+eOa4[O3|l$Y-ދRWt jLp' AU)8M5zi&5¡{7M3zz&I$jYGC3YϢetdgm;A8dfD (IԨ\:s@a\;_!Ni JhjJ^K1 |%"6bFceKDq_؃kkd~^1kj8f}[Tf84xh ny2#)MYW5id6_[4YjdUxSp P>'D}}!9'= z+m[6:lUtwD<ϐ|Jǭ4 a,מ3}(kGR,E?sRB&R5J݅eSI'n*QoWVA/Ӄ JGk|SoYX2f#};@BXM L|Ĭoω?S$l^J\ٚ5e ozh39$W_%%[٢[prYfQ3v_OWΥFٜ(V͠/l_0΄"dѾzgWFD#\]pScGڵnįV c)OE^O!>Im"Z/cQp "Ac2ΡK17Q"CU=ee1fgfy9x _sD-kM?XΑZ7Uk/wpʇq(muK]1}A ^=lgv4p&]÷̓*#DCCY8Ŧ-0I(-4HU{ G+YfCMj k:{:N<Hg$έıσ%6,w(ŧ~[|yE&;K 4BAӖwA2掖)ԂH$fy.drKfи!&}vX|f2$'P |nGI߾?s(完]鎏O~5,0&,w6+].5c=9JjБЋU,Â|}@@J~ _Qk m6m:<Cbe8^E G`pn.e5 swzU+|BĶ{@^*Dk橃65R,,5Diy$TFFش2*)ym,G (l/=bY%.⻋@L@|@>16p\eUzj+$:pfjց)a×P]h!ܬ.۬&^5J29P l,*@(OujE>`<5wNѹ[ ?/Pc$ `QF]OCmk2^r:lW6Juc9<>~70%T'_N!M(RWKq_>BS~dCcKceNY\DOeawYE_P#Xرrd@dƐ] V Qh[hWQHO$)qa100a7*- 0tj kgT5 g;EVw؂2uiiD֚$u3gt7p,/t,fc'3Q( I}B%OA~ ˍ ~J$̯ix=;Kt?ƌ,!@"rz'%c#0׍xJL =~+r%83?NUϋ _Ch)уL9S BM铊KLs6ǀ *H}5U )G3a#99ih6TҠr++)RZ]bdϑ]K=rSɽ7,iǭX'aEF: dIR>Y=Eyx| ./8&Fi5ǵ+ uK<;Yw dWǍXSE]uxPPzYlIczSn]aCЕlrER@]fe.ggBH#iff ]x m vRu\3e~(" dvȪi7M/ugrq$؄is_[*DxӬAUDCVx+bCr lλAP O%:Y&:0^ZRw$.8w%~䰔UV;kkM{۹Ʒ.h)|iYjbO*`@P0 >5Lл8/w%w\-s|J*gRm41ϠЪ k1zM"eDuS/[IT VAFAoqۓdAm3s˹oMK0QL 9@:Xz/\"RT"%yscTT&(taMީ- kⅳOw!OCt:B0)5RŏZ@q/Ot,:";8u:s%s|5y!9d? D|rrAQv`slw"]4vP%mzTtx}!tFL"Q*~' )nR5>SCJVApwPmjǀ\'q\)m'~=!" 4}6:XsO]ˉz_QJ%d0e~ߪg4D#J.6ٜScB8GL %9XwXE}8 ݒ7:(ܶO:']0XiT}!PC 5,eWԝ^)Bw v<" ͫێmdC_N 4CtijeIɜ"- Z[rNeH\tRI`~Sh-r]Ba S{g$(s?+NBܘk61v"o܄nvxL; $?[׃۶z\Tk9#mlM&q<*>0GiH|?ݴ)f5+OMD]N#9loL~ >q˳[5I8eWTPRhu{H"~J@A%9 dU6?$mln  Ā)exfY㌖zşT?ul?0Qsr GnM(.9{ '(UJ)Z>I( B 'CM.` 7qҫ٧m)N!& Vr$~W}7 zCV@ԑDU;KT, k?rpɩ2laDLss"zn|Qq(x/Xje* 0MX!zɗ[ 48ԭQʘnNM̉vR6txw,6'Pm/YY^o] l5i~2 r_f}6` 8O2o*~\ ^$P[ SRG? [Ԥځvv(v8m{L,Ps@,şȸ{ڦ A^e^)DZAh.+xX?=ըqZceILUU5ڝ{(axv X]x 2WV9C$@$%O fAK"}lzfD醫HQѡX2L8f0R)>aw3Wȟbhaz(NK. Q d0x6JU8o_cut<#}ms ps5 KE%e*{cw Vqe68borXN$őQv#ڊvNV=+/BLf0Xڸ?AڣۂςכtW }> PKL.g6KK~z;oydlv҂ :(CX"qIi[>W1$U3@w{[1Ⱥbw|Uj:.(qoePȸX:B KIhvAAIQ-5؞؅Y*9%S:`@6 x? 1虳UyG z;޵RaW;,n*ǬL\,<G<Q.1]@e@n;wOV)A(+Xvaosdh4lV9#ipa+5@VƗE:F.aeU \p%QTcm*sV$C^|:ޚ A*vNphOKK@ثI=sd7ה/dsc0Ԗ4v o.#M)2o+9$ 3awk' &ۄD3ӟ^6Ք>zJ HO[oO_Fz)rs]ƒPeNPD:._EN X+xBmU0~9@i9r)@0haN#8IQ٘qOJLZc>*Q"׀5zAUz{GC}4S*`<&'0gbreDB~R>c: b:kCaR³uO+v'cj/s|`}Ƙntl2Z A6Q98+eݣeI;6) dF6ԛ1g^ar`Һzg^6YLUvB,6aI gJ b*߶k΂]7Mi;洨@2yLqL)y@V6@@9ߺQIik[Wf?ۡ}kI-aB˧~imcvq(6elJjy N2 97mdNP *C9&$obW0 X#\,ۓ"(Ijhc; 1[PKe;#z=gE4,wO}$.߂R,!rCFp[LAeT b.-S+aPr41ItGH(1Ƹ/~ű;pUrZ'80#@ >CJE"`,焟^[溋`vxkEogӸU&I"eϋȇ:aŏ;&I^;%(2wa-To}OUus$tntgѽ:VK˙ghoKyO]͐bZ` ͔T$5_{9VI`/R)~SE<7,$ǒ=g[[}%=k+ lڋaǮRT%k(,cx?@IxQ#p.#,Tn_AVP" ,@W2 4F!" o7Sl tPU 3 AV,Pӵ) Dkvmo&ʒ+D|mV؂-FhNiЊs쭚ٷH{ny9sn|SsYU ނ #(˘nHĈ>ʑruo[݃C+ 5 ̓@L>ݑS䃫vMKuz>mW*/ar0a:vޏ6`Ȫ^84&F tN˅c1`Ug }HM`bpK0Sħ gdHQycROs|A.߭x[V@F}nXr-4Vq\~ǚ1u9ykt{т|-I#j&mv.NC\vH7AչCK !!Igx\HB J65bӛӗ!fYJ P% Kh4؍Z"rfYni^^B(T 2HWkCo7]\d`,psiP(!D\'<- ,q:%E!65<[Ku^BНHqѸ V&ƞ9/a,3/t8DԖVukF뿹 Sl9lK}0/ vLcbRmB6 &ĔJypַJvdW~6(htK+&X.,88Yp*$ y*6;oWZ^M|b}Olxrk,)xwHS֯*j``i؄~+hډ[ %l QԨțYY&F[W}?H^]1F G).&SϧuEqapҾ,0:c袏C^/=![~ԍC|ңw}5n>pF!gxD3 j~b@azPYVϿP=υ92.1Eq .FbZwY̧cR^Cz4([,bluVa,$q*_ o2m_G`vXHjE>6Iͳ}b2n9*/3Vck{N]vmcdtqAȤK8Hqd^1;Xw. . -+ )T7v_F4nTBskSw7 nN M.*INQb)yuk5zn`.GqM"EES0N=G .eJ^ .X|cI |վ4yؕ>PeƠ!cIY#CF6,>%%wtc(DLa`z瑗,ջՐPndsAgGxbu7ĘBT{P=wn"VtWAA6`Fk,@!0=@s/ 7?ATt}*WU,2 ΍ܵ?]kgى ǂ ݣ(e} y`ˠ*n{)^VDUL/,Ss99mDx64`d(aψLp-icS&ːʘ`;SHM޲5n}lޭj%I)3dd3x ,gѥn7hhaX+[+ҋ,(n]^豬bO'VXw/hx|m{gFpI0 {EurQ*uP ښS;m&>&|֑=rA8[@4]wORI]TͮD#Ba"C #n r.#P>h^wGEij!oڪNݧB*<ߍicȶ睬SVp}=v;_A&x έȢ*]_XlڡȈwa,Dj׳ ׄIKl4[ՒYT(}Ev< y'ZaHCK #]nR6`R|I^K/BiJsa`v0 g|.Q`{(  {eӽ=R1&K-i]k#q9mDe1~qsd+W99NkoJ30͐V9Y/>2>~jTЪO,H^g/lZ'jޛNA\8ʫV!zg1m Ȯ EOwNS\=E-hV"v."PVj+?!n.rBgx2Q-><#C|RBvJ]lSYhT*! %3tIz= f@݇7a4J/ jP#g3j 9DT j 8%9mKw~I& |-J4&rA,e1|]/gۂgQgXi`皒Bj?h "Nh-Y`R^ܰ,3᥃O5cR/n9s#LrE,=oISKqE (Yh6P+r /nwÆ{RP[^@u6HOFa@z~B6~}E"kj Bֻ۸y퇉)UDc[2"MUiO4;HA'7Œ܂vD]9b)՗&nZ0qslZ_k4|)>LQ9/-0@-x@,U%K&`p!7s̛rpBꎡpOHI#irZOp0W9KAjΔ YVtCg'0k^{p昼;dVWGܧ}dq,7 Z.r]QW1 $K-e汛0=t 66-vQ|?bׯ[ҳ/ 1N?F; Cۍv,veᥥPlnm z6$cjeL`8 wL2˜)f2}[DH{6^TvV?- ,t&IV:MBuBsPqhR%Ɂp PqL;t.r(Vw"QTRT ^tGA?._,= tuSf~DRq B{w~*Gޥ|rm썼6tXN~A#eӈ22! ^[[S) Wg2/-x͙G݇ *%|piF㛤)O'9R:%qӫ F)M4Q#G t>Pa2 a6.^g`B~"`,]l*jpQ ?Ay:CR2>XNXAZ"?_A9* W]Âʄn9Ռ(} al"Q&1ys>.2áhk@M9ޛAUu9 ΢@Kk?a LL&iUdhuL%~%(=NQѓM'\I6 %۩m ё܏hpa{= 'rGO.PM~!Jr'ÀIP 51rԜP*{-na+s`o-YĘN@0/n!(2YnMOhw-O cXgw~(xY?6W" 8nQagw UkkwX̄KG8mU( [6+>%AdLWHJ[r"< z#9b>"}<_+ Td-_6ovx+EH 6<! U~,}1X,/ ~ePfvLJU[{:jj˴"g˭$gyQ򰭘"=>+V~ab҂t;꟦,Jrown67?%AQ!V;ʉ4(AwF=Ÿ0r0t >A珫iQS͞EK p>\I5_4h_'R.izvY E5AN9J۩j'P{Q!yC3X)o"3lx~j|Zܖ/7~G2jԚZBtI'pa\`5Y"KM1Bd_%J\fSXcZ#ig,k"%O- 9Gju9:=r)Ief[+qȽ0,QO#޸r] jBbzܞ`+#W'q,*lwE*colZ:._S%Kd8ڢhEЊOBtRz,a )\aQVwVR4PEo} ɣfnENxa({v4wԾ}z{NPNzR xxA]ƵG5aCSQDˁܹO~ + b)9LXۜ1eu=$/ lQXB")aX@u[_k_dmjn0#oxC^eG( _6k]*aYG5Fj2GǏ"8В lWNȐ #ųxiC1WzmEmA$K^\Lѐ&*֥~Ka \i` Ã`x0SɹhMtǖjSp7c!hܢGQNm %LIoo%KMxXL H5#HW,<:u,r_^}=hdT֬Lv+GBi]#Z2 sm79 ;&M&_?TC*,O*RL@(ώD8<,Сw˲`ansi65G\In)q/FTW[޸73')WЄ(@Az4Ql0x~n|h*y\l])W6?^Z EI$ q4 qRnU* 9 jjT*E+Jv]Ay4U? wB ;?30[讒 q-! )L:-.Е,'Y ɫ 7iߒ/4DԢ%5T1 |mVin+ <ܩ\T r[!7z ʦd*1GM"Z|sr<ق0d 3$b$WGjBGhl_!4cUuz0cdCf)q1)x92]d/W"v8vyv+&UNrpY(| L])_5tg pD?<7y _Ǹ[r0I;lKZ,cOE<=Npn%g멡c6aػ TmQ ~xZn,(O9e]{qTƣ/IF睈v]=,Φs:Py;0QU*m Ǻ9 Qωfg.x8uWzkGm*uV>侃7I%oE q\=,ڪy>U#5MVS/"@ 13@?Ne^gd1 *e\6Y/{)"?xaQcrݝ1uVa֍]L ϟţd[=IҬ% vyo^-n䍱XX|H53%tUt;*yD7KDq*_^+3naB?+W4>-f$>e /Sr偊 J1f-+5٩1 E,-0GVL lwPg|ʑB2KBwmנ(z? wȧ`ga'%?e0p2 90y֠q:) WJy[u}!ec)",b)g LvEޅI1:#ge{3'T މuɐ2a~ %L ;Ws/޿qBq \T; mҤ:6V ^yy^Ҭ.r汣bsu/$ͤɀHE?L\wXymux@,lgyLR<2ߏ)wj=EMTE[C8El xYSLЈ\˝+E _Ȼ5nb?, |4X0&K:D_ uA4cPwapɪ$b7-ܤik7NV9j/ųHE5=YhE([ G[ ;\nun-%؝A%YT"Qi NIgb٨0uu΁`x4X՘IXhs!&yea=L^\5=y>~' xNhx.ߪ I INa]5CmgU+Eeѯ\G8>lP&\7l Ǵ|Xˋ#wcKr+'WQ?V*^{;qg\j3@cSuuhx0$ ۡy%D;E!ZʥB7[(9ghTϕMP=;}Rv33QhyVY}ѕ]B$_4 Nj<DΔvaz(R?<*z:ebRPU +k6HGXBBGp+ʕg~x֍*X$bߐ!sNp) gKMTV'`{낵hFxϦ Va;,};HN79ݻ5)\y׿Xgv;"4˗aOyh(VqPJ 3qg.t;:.7gA.=HTKMg%{kLZ iԃzZk- "Q(D _<'d&(+W6{C.GFu7==4;) Q}5EnB8mB?yxgO\1 .k*1Nch&Z.۵F.(3J O6Rp3K~"Aeg`^)<]u5Tۺ):[<߂~4YFS8aOF~Sj"OCFdphR3+a>~DZx9i`RUufȘE]Fu@X%Ob=1/lٞQ(uFbp1{swY' AOi&ObQ%=$AT ?_tIΞ߅|H/Qi⛉Qm8-z "2t&Ĕt0Q=}PٟԑI}kJm,oޟBOu6hE;ׇ]=$;y`xN++]?1%o1=M8fF\~\0jg֔ ViDof k'|'ܿR|630{^{咶rg3)1QwAd~`Ŭ%385qO;|*q\k+$xi 6,&{:OUy4L_ɘ?xؚ)^=(g;x|wİ)YKQ(!"P!4RQgh)*;2+v៨Qx$)[: mS09]Mc *^63GVWdWMIK{9+geôü:2z/F+R4ښz-ce\Rg@)75w^ӷmոe[|ddz{- > =P:JNʤ 8`bc; lMI ?vI7M"o=>KUN]iy#伻i"~8NQnV?8c4q.ͮs4l*i VǴ3Vv F} ݛ[d!K˟]]߷0??FK;~յRz[:T.ReS-'rk1ArNOzۘUYN))Vu^e)(r&*jD`e\&GS§SS13VZr'F[CLlkg]D5Gx^ 4w2GkĎ+WF_2$$Z5v'ǵ+eȘr1a~,C0#T q;cqnq⬪ۈw;3pX3™91x{L0WQ꾿#?jxiO"B_2l\b1IKhCj'O%tS,#?ց fۢ87Khx؛c!Ns;F-u:{ܭq<zb#4zr$C"b2:N0%Z^U} .T6eLG ,b@k4⪘2V&I.ruY4ڠft)=kobh:1w@#4E$ֈ.yprB*^ Ls;&1E=\9 i-Yw`#\T #R;6ߎ7Bjn'ԶP5JGm}˥pV~v*od,|aT-P֜H>0[s0Lc|hFp{w=xe]($RUJXx%K*̡]!ƺf[)cZꀟ9d~ւN0mF}ܚ' $&cF\*"y2U-u~Ƿ"HFf?I-; V9(b+hi&m}7sn :~w+2վ>EWs-> K;/mW!ti!iIPW=L\k#3o8OdxATG,2z!I6]\&] O;-ZeAi^#uEi^Ϣ]H/f! U(Uj)IE'(Elim '$Q .ŵQh4=8UXsGZ2VmrrR.C~Aܤul -捶?*E3}ܩ>3 9l[,{\@ iLG:dsG!m4o٣ԣ2%mM;Ri}Pi׋@U_M!ƚK^G]<W?g inR| buiVXT ¤AbiEOy;F%K&Ta,@D̔-QW˞ RE?sGChZ3qGre[aE\~%LuR]F%H!c m8C58JܣC<@ޖڿbg?[왅Li%RVF€A ū0}X~,z dSJZxϭʕORf|j 9/BluWR^cbTgw.y{)q{R\c8@;j(pEiFjCRuDPQ11df-# 3Y!wU!\cR" }H~.- (C^MV;>VD9X'00vPN#M'UfQ(5iNVNWtEr62𥉉Pޔڮ+ Xv+}h]#]Z2̣4 y0[ѶwjmEfD vX*:$9uCf5!y? 4h><J=LkTz>#W̫؜m,]g,# I ցTƇӊGP0sY\H%4U%dKڼW\[ -KvXV7#$gknMøPVB9"f:wha.2 '^پa; pܐP;EmH k|stͻPKÎ_Nx@=sܷs!#2 $m\1_鍇[q&v ،4#9(bj$ae8PsR7&./RcbX _Xˆ*ߩ^Q .7??j(nZ%T8r?], m09߀}:` ~Y{@` $*IYdO2S=gc 361ܔbߦ4Cmu.wAE8lXPmQK[i@nIn-Z]cՄZa$>c:!@qVu H+tۣC6qyb~\*۰ׅ0`BSi/q_hK3}"\" &|Ab2r9asZ\9g+vvyVa2z`PK"QMg,.x}+!|\&}{.ܛG3p0u@"fse'!tcs Gђ- RX*uXCgxPVvlQ)ٝ6X7jō1@u `?[NO^yvdL.Q76< 5bΛHǢ2L"׳;RO\rm {O'Z:uGM6Iŝ-e?,Ţ!;|۝H!`#D5`N=% qpAwAt榌MJɶ{wmVӣr Q DLx3p3("eso%AVg΃]P Þz.Pi`o"3,.{3-|$E&̈́C345Ck(Sq 1x`QaJA䪈AYE sa=xG 7O9eI dҶIvEd)sfbDO.*B{(J?ӂ8k,r}x?DY΀HL~kCߊ?Wh.1o^ETfؕ_0Seڃe\2tP(ѡӎ4FV1뻫@g~乕%*Xԧ@TY|;Hv_ >gXjzXsp s"eYl.~5j^Վ?|_qiTbAh92#IWr~}lA\vcǴ>?J Y;rNCxgpK%m\wh^ ?QxYav?lNpn)jZw> tOLȁFߵ#IxJՏ;zhT@0b@ľav !0jk#H6c1x4=JCD4i6h D VACrH2S^FS+Y'km QF=gj8Mcm\h S/s[uc2R{Y.VeO7RPc/3f`#PYtY̏{waO ȁ=K~_e4=Dk"`#nM{ l! P!/w& 3lm̨jY+42d]GEuihZ.O^ڥ͙7D>Cu-Pqnn3KHRVOⴼw2'B{ނvfGZ~'ڸoilV(g+ֈkRM׺iU93P ,4X=Ii~.{n"ڳOb ی$FX<Vyxj~eüOXϑV.G|Bq۔0q4 ٗm?+^'̍=bɇ|Hn:/P/}b}(Q0RĒ]a(ɑ8nspFoV8r )6cѫusD&(X2"adZ7JY}h+1`0;WjHl 6/v4vь4:5tF-९0ӕ4!~iCOuɠ^C|:l/ W3k/kmv6'ĸ&12k'8F/<(˳KuXV<;da}ĆAc\|e AV[+SM )( o#oܖr]v%;_Q<6 LUq <^FH3R4Vq";: v"bt+IH{gȄPuzj{Zj{, p; ;ꦘ(ujxOBѤ<=!Ijcc ^j'6f|q R1(\gPNvPiU4x -OH, ?6eC/YÞQvAT=nc2Q:OR !]nޢ>f&gc=o(`)%4baRb/i`0>GM\>s 9H[cS"zSRs!q:7KU]kia }s^4ڐ#G6Ƒa,DuDM,RA-:ňEb"8]dxrb>bb9j -WxXW%+;П&!:lzUD/fqIyW y즈ȟV4He4GRSS*dphjB,TE^CA㪍2̀ "hC)a΄V8p`MATRDm6cT0fcPq9:k-"h.-7p g6WH!h5.>X-G(@UYBp"C{1bPO3E.A6O!1"n>Y: ܪjA!ۜ&-WgC@ӢȖ[($᳅lOy(L-:\IreEW^BC2dwmuv(e]RU ѸS{1Li%lzY޾*>󱵉㲏 3 NǗYv0+t ǹ_+c[[z@-q%ٚ9w7QS3RGֿm_ZEN2nB sYLfq gWNVѽRFw)]gQ%=S@У3lIPbb{ϫTi _akXڧܴGU"{"m`duJ`G}#{9HޛQwռ,ߝ,.VTiBH1/pM2iҭ YGds\ɞ&JjCg<1k(jJ-th= & xlFP=1/,꿻"VkkMOB~/6O)ZG=ma~X߶X>pmo8]|݅]QBufQE5gc0Й1>ž%5Kvo!3.ITwxHS"XLK_omOmۇ`Q@Vjo]R|Ce=.l' #'~Gf$6i*Ĩ&;W*kh$!vv";X";[qb??&!aw*- Ŀ\i!Dy 6w0b]1%ODDZ%}pFG|}hST vޒ,[Pj$sZYgӘDƖ#z2%\ #@pܯ) [%uaeTjs &;U=@iE)5A3A݃) VY&=MrQI/ΟA5) ykǩƥ:qh\*!ǖ yU&p-ޑO暞Hͥ5{B⅄+Wv-0,@Gz<~+țz:'BrԢ^Mؿx߮ˑ!#PՖrcU[0fU7K/> jjq r$6yύW~fEN('vK^ҖhyWɓD{d3ii#dAhNi-.x%yt[0{?(.ԝ) oES}FEJ%0})&TJ)ìSZ@:0ZqUxfey&J;!VSSd`ܗL&g)Ip% Ef$ ,cW#hf͙&=f;i&O!\jD;U`%JRqU}}Ǽ]E")rt 2._.ߓ-NA? 32v$0 YZrelsurv/man/0000755000176200001440000000000014127257052012534 5ustar liggesusersrelsurv/man/plot.cmp.rel.Rd0000644000176200001440000000641314124561334015342 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cmprel.r \name{plot.cmp.rel} \alias{plot.cmp.rel} \title{Plot the crude probability of death} \usage{ \method{plot}{cmp.rel}( x, main = " ", curvlab, ylim = c(0, 1), xlim, wh = 2, xlab = "Time (days)", ylab = "Probability", lty = 1:length(x), xscale = 1, col = 1, lwd = par("lwd"), curves, conf.int, all.times = FALSE, ... ) } \arguments{ \item{x}{a list, with each component representing one curve in the plot, output of the function \code{cmp.rel}.} \item{main}{the main title for the plot.} \item{curvlab}{Curve labels for the plot. Default is \code{names(x)}, or if that is missing, \code{1:nc}, where \code{nc} is the number of curves in \code{x}.} \item{ylim}{yaxis limits for plot.} \item{xlim}{xaxis limits for plot (default is 0 to the largest time in any of the curves).} \item{wh}{if a vector of length 2, then the upper right coordinates of the legend; otherwise the legend is placed in the upper right corner of the plot.} \item{xlab}{X axis label.} \item{ylab}{y axis label.} \item{lty}{vector of line types. Default \code{1:nc} (\code{nc} is the number of curves in \code{x}). For color displays, \code{lty=1}, \code{color=1:nc}, might be more appropriate. If \code{length(lty) Data by Country) into a ratetable object. } \details{ This function works with any table organised in the format provided by the Human Life-Table Database, but currently only works with TypeLT 1 (i.e. age intervals of length 1). The age must always start with value 0, but can end at different values (when that happens, the last value is carried forward). The rates between the cutpoints are taken to be constant. } \examples{ \dontrun{ finpop <- transrate.hld(c("FIN_1981-85.txt","FIN_1986-90.txt","FIN_1991-95.txt")) } \dontrun{ nzpop <- transrate.hld(c("NZL_1980-82_Non-maori.txt","NZL_1985-87_Non-maori.txt", "NZL_1980-82_Maori.txt","NZL_1985-87_Maori.txt"), cut.year=c(1980,1985),race=rep(c("nonmaori","maori"),each=2)) } } \references{ Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. } \seealso{ \code{\link{ratetable}}, \code{\link{transrate.hmd}}, \code{\link{joinrate}}, \code{\link{transrate}}. } \keyword{survival} relsurv/man/expprep2.Rd0000644000176200001440000000226514067312526014576 0ustar liggesusers\name{expprep2} \alias{expprep2} \title{expprep2 function} \description{ Helper calculation function using C code. Saved also as exp.prep (unexported function). } \usage{ expprep2(x, y,ratetable,status,times,fast=FALSE,ys,prec,cmp=F,netweiDM=FALSE) } \arguments{ \item{x}{ matrix of demographic covariates - each individual has one line} \item{y}{ follow-up time for each individual (same length as nrow(x))} \item{ratetable}{ rate table used for calculation} \item{status}{ status for each individual (same length as nrow(x)!), not needed if we only need Spi, status needed for rs.surv} \item{times}{ times at which we wish to evaluate the quantities, not needed if we only need Spi, times needed for rs.surv} \item{fast}{ for mpp method only} \item{ys}{ entry times (if empty, individuals are followed from time 0)} \item{prec}{ deprecated} \item{cmp}{ should cmpfast.C be used} \item{netweiDM}{ should new netwei script be used} } \details{ Helper function used in rs.surv and other relsurv functions. } \value{ List containing the calculated hazards and probabilities using the population mortality tables. } \keyword{survival} \seealso{rs.surv} relsurv/man/transrate.Rd0000644000176200001440000000307612705402360015026 0ustar liggesusers\name{transrate} \alias{transrate} \title{Reorganize Data into a Ratetable Object} \description{ The function assists in reorganizing certain types of data into a ratetable object. } \usage{ transrate(men,women,yearlim,int.length=1) } \arguments{ \item{men}{ a matrix containing the yearly (conditional) probabilities of one year survival for men. Rows represent age (increasing 1 year per line,starting with 0), the columns represent cohort years (the limits are in \code{yearlim}, the increase is in \code{int.length}. } \item{women}{ a matrix containing the yearly (conditional) probabilities of one year survival for women. } \item{yearlim}{the first and last cohort year given in the tables.} \item{int.length}{the length of intervals in which cohort years are given.} } \details{ This function only applies for ratetables that are organized by age, sex and year. } \value{An object of class \code{ratetable}.} \examples{ men <- cbind(exp(-365.241*exp(-14.5+.08*(0:100))),exp(-365*exp(-14.7+.085*(0:100)))) women <- cbind(exp(-365.241*exp(-15.5+.085*(0:100))),exp(-365*exp(-15.7+.09*(0:100)))) table <- transrate(men,women,yearlim=c(1980,1990),int.length=10) } \references{ Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. } \seealso{\code{\link{ratetable}}.} \keyword{survival} relsurv/man/rs.zph.Rd0000644000176200001440000000451514124561334014252 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{rs.zph} \alias{rs.zph} \title{Behaviour of Covariates in Time for Relative Survival Regression Models} \usage{ rs.zph(fit, sc, transform = "identity", var.type = "sum") } \arguments{ \item{fit}{the result of fitting an additive relative survival model, using the \code{rsadd}, \code{rsmul} or \code{rstrans} function. In the case of multiplicative and transformation models the output is identical to \code{cox.zph} function, except no test is performed.} \item{sc}{partial residuals calculated by the \code{resid} function. This is used to save time if several tests are to be calculated on these residuals and can otherwise be omitted.} \item{transform}{a character string specifying how the survival times should be transformed. Possible values are \code{"km"}, \code{"rank"}, \code{"identity"} and \code{log}. The default is \code{"identity"}.} \item{var.type}{a character string specifying the variance used to scale the residuals. Possible values are \code{"each"}, which estimates the variance for each residual separately, and \code{sum}(default), which assumes the same variance for all the residuals.} } \value{ an object of class \code{rs.zph}. This function would usually be followed by a plot of the result. The plot gives an estimate of the time-dependent coefficient \code{beta(t)}. If the proportional hazards assumption is true, \code{beta(t)} will be a horizontal line. } \description{ Calculates the scaled partial residuals of a relative survival model (\code{rsadd}, \code{rsmul} or \code{rstrans}) } \examples{ data(slopop) data(rdata) fit <- rsadd(Surv(time,cens)~sex,rmap=list(age=age*365.241), ratetable=slopop,data=rdata,int=5) rszph <- rs.zph(fit) plot(rszph) } \references{ Goodness of fit: Stare J.,Pohar Perme M., Henderson R. (2005) "Goodness of fit of relative survival models." Statistics in Medicine, \bold{24}: 3911--3925. Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. } \seealso{ \code{\link{rsadd}}, \code{rsmul}, \code{rstrans}, \code{\link{resid}}, \code{\link{cox.zph}}. } \keyword{survival} relsurv/man/plot_years.Rd0000644000176200001440000000252314127260173015204 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/years.R \name{plot_years} \alias{plot_years} \title{Plot the years measure} \usage{ plot_years( years, xlab = "Time interval", ylab = "Years", xbreak, ybreak, xlimits, ylimits, conf.int = TRUE, ymirror = FALSE, yminus = FALSE ) } \arguments{ \item{years}{the object obtained using function \code{years}.} \item{xlab}{a title for the x axis.} \item{ylab}{a title for the y axis.} \item{xbreak}{the breaks on the x axis (this is supplied to \code{scale_x_continuous}).} \item{ybreak}{the breaks on the y axis (this is supplied to \code{scale_y_continuous}).} \item{xlimits}{define the limits on the x axis (this is supplied to \code{scale_x_continuous}).} \item{ylimits}{define the limits on the y axis (this is supplied to \code{scale_y_continuous}).} \item{conf.int}{if TRUE, the confidence interval is plotted.} \item{ymirror}{mirror the y values (w.r.t. the x axis).} \item{yminus}{use function y -> -y when plotting.} } \value{ A ggplot object } \description{ Plot the years measure obtained from the \code{years} function. } \details{ A ggplot2 implementation for plotting the years measure. The type of curve is dependent upon the measure calculated using the \code{years} function (argument \code{measure}). } \seealso{ \code{years}, \code{plot_f} } relsurv/man/survsplit.Rd0000644000176200001440000000257610221543070015075 0ustar liggesusers\name{survsplit} \alias{survsplit} \title{Split a Survival Data Set at Specified Times} \description{ Given a survival data set and a set of specified cut times, the function splits each record into multiple records at each cut time. The new data set is be in \code{counting process} format, with a start time, stop time, and event status for each record. More general than \code{survSplit} as it also works with the data already in the \code{counting process} format. } \usage{ survsplit(data, cut, end, event, start, id = NULL, zero = 0, episode = NULL,interval=NULL) } \arguments{ \item{data}{data frame. } \item{cut}{vector of timepoints to cut at.} \item{end}{character string with name of event time variable. } \item{event}{character string with name of censoring indicator. } \item{start}{character string with name of start variable (will be created if it does not exist). } \item{id}{character string with name of new id variable to create (optional). } \item{zero}{If \code{start} doesn't already exist, this is the time that the original records start. May be a vector or single value. } \item{episode}{character string with name of new episode variable (optional).} \item{interval}{this argument is used by \code{max.lik} function} } \value{New, longer, data frame.} \seealso{\code{\link{survSplit}}.} \keyword{survival} relsurv/man/rs.surv.rsadd.Rd0000644000176200001440000000375314124561334015547 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rssurvrsadd.r \name{rs.surv.rsadd} \alias{rs.surv.rsadd} \title{Compute a Relative Survival Curve from an additive relative survival model} \usage{ rs.surv.rsadd(formula, newdata) } \arguments{ \item{formula}{a \code{rsadd} object (Implemented only for models fitted with the codemax.lik (default) option.)} \item{newdata}{a data frame with the same variable names as those that appear in the \code{rsadd} formula. a predicted curve for each individual in this data frame shall be calculated} } \value{ a \code{survfit} object; see the help on \code{survfit.object} for details. The \code{survfit} methods are used for \code{print}, \code{plot}, \code{lines}, and \code{points}. } \description{ Computes the predicted relative survival function for an additive relative survival model fitted with maximum likelihood. } \details{ Does not work with factor variables - you have to form dummy variables before calling the rsadd function. } \examples{ data(slopop) data(rdata) #fit a relative survival model fit <- rsadd(Surv(time,cens)~sex+age+year,rmap=list(age=age*365.241), ratetable=slopop,data=rdata,int=c(0:10,15)) #calculate the predicted curve for a male individual, aged 65, diagnosed in 1982 d <- rs.surv.rsadd(fit,newdata=data.frame(sex=1,age=65,year=as.date("1Jul1982"))) #plot the curve (will result in a step function since the baseline is assumed piecewise constant) plot(d,xscale=365.241) #calculate the predicted survival curves for each individual in the data set d <- rs.surv.rsadd(fit,newdata=rdata) #calculate the average over all predicted survival curves p.surv <- apply(d$surv,1,mean) #plot the relative survival curve plot(d$time/365.241,p.surv,type="b",ylim=c(0,1),xlab="Time",ylab="Relative survival") } \references{ Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 } \seealso{ \code{survfit}, \code{survexp} } \keyword{survival} relsurv/man/plot.rs.zph.Rd0000644000176200001440000000440314124561334015223 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{plot.rs.zph} \alias{plot.rs.zph} \title{Graphical Inspection of Proportional Hazards Assumption in Relative Survival Models} \usage{ \method{plot}{rs.zph}( x, resid = TRUE, df = 4, nsmo = 40, var, cex = 1, add = FALSE, col = 1, lty = 1, xlab, ylab, xscale = 1, ... ) } \arguments{ \item{x}{result of the \code{rs.zph} function.} \item{resid}{a logical value, if \code{TRUE} the residuals are included on the plot, as well as the smooth fit.} \item{df}{the degrees of freedom for the fitted natural spline, \code{df=2} leads to a linear fit.} \item{nsmo}{number of points used to plot the fitted spline.} \item{var}{the set of variables for which plots are desired. By default, plots are produced in turn for each variable of a model. Selection of a single variable allows other features to be added to the plot, e.g., a horizontal line at zero or a main title.} \item{cex}{a numerical value giving the amount by which plotting text and symbols should be scaled relative to the default.} \item{add}{logical, if \code{TRUE} the plot is added to an existing plot} \item{col}{a specification for the default plotting color.} \item{lty}{the line type.} \item{xlab}{x axis label.} \item{ylab}{y axis label.} \item{xscale}{units for x axis, default is 1, i.e. days.} \item{...}{Additional arguments passed to the \code{plot} function.} } \description{ Displays a graph of the scaled partial residuals, along with a smooth curve. } \examples{ data(slopop) data(rdata) fit <- rsadd(Surv(time,cens)~sex+as.factor(agegr),rmap=list(age=age*365.241), ratetable=slopop,data=rdata,int=5) rszph <- rs.zph(fit) plot(rszph) } \references{ Goodness of fit: Stare J.,Pohar Perme M., Henderson R. (2005) "Goodness of fit of relative survival models." Statistics in Medicine, \bold{24}: 3911-3925. Package: Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272-278. Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741-1749, 2007. } \seealso{ \code{\link{rs.zph}}, \code{\link{plot.cox.zph}}. } \keyword{survival} relsurv/man/rs.br.Rd0000644000176200001440000000454414124561334014056 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{rs.br} \alias{rs.br} \alias{plot.rs.br} \alias{print.rs.br} \title{Test the Proportional Hazards Assumption for Relative Survival Regression Models} \usage{ rs.br(fit, sc, rho = 0, test = "max", global = TRUE) } \arguments{ \item{fit}{the result of fitting a relative survival model, using the \code{rsadd}, \code{rsmul} or \code{rstrans} function.} \item{sc}{partial residuals calculated by the \code{resid} function. This is used to save time if several tests are to be calculated on these residuals and can otherwise be omitted.} \item{rho}{a number controlling the weigths of residuals. The weights are the number of individuals at risk at each event time to the power \code{rho}. The default is \code{rho=0}, which sets all weigths to 1.} \item{test}{a character string specifying the test to be performed on Brownian bridge. Possible values are \code{"max"} (default), which tests the maximum absolute value of the bridge, and \code{cvm}, which calculates the Cramer Von Mises statistic.} \item{global}{should a global Brownian bridge test be performed, in addition to the per-variable tests} } \value{ an object of class \code{rs.br}. This function would usually be followed by both a print and a plot of the result. The plot gives a Brownian bridge for each of the variables. The horizontal lines are the 95% and 99% confidence intervals for the maximum absolute value of the Brownian bridge } \description{ Test the proportional hazards assumption for relative survival models (\code{rsadd}, \code{rsmul} or \code{rstrans}) by forming a Brownian Bridge. } \examples{ data(slopop) data(rdata) fit <- rsadd(Surv(time,cens)~sex,rmap=list(age=age*365.241), ratetable=slopop,data=rdata,int=5) rsbr <- rs.br(fit) rsbr plot(rsbr) } \references{ Goodness of fit: Stare J.,Pohar Perme M., Henderson R. (2005) "Goodness of fit of relative survival models." Statistics in Medicine, \bold{24}: 3911--3925. Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. } \seealso{ \code{\link{rsadd}}, \code{rsmul}, \code{rstrans}, \code{\link{resid}}. } \keyword{survival} relsurv/man/survfit.rsadd.Rd0000644000176200001440000000541714124561334015626 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/survfitrsadd.r \name{survfit.rsadd} \alias{survfit.rsadd} \title{Compute a Predicited Survival Curve} \usage{ \method{survfit}{rsadd}( formula, newdata, se.fit = TRUE, conf.int = 0.95, individual = FALSE, conf.type = c("log", "log-log", "plain", "none"), ... ) } \arguments{ \item{formula}{a rsadd object} \item{newdata}{a data frame with the same variable names as those that appear in the rsadd formula. The curve(s) produced will be representative of a cohort who's covariates correspond to the values in newdata.} \item{se.fit}{a logical value indicating whether standard errors should be computed. Default is \code{TRUE}.} \item{conf.int}{the level for a two-sided confidence interval on the survival curve(s). Default is 0.95.} \item{individual}{a logical value indicating whether the data frame represents different time epochs for only one individual (T), or whether multiple rows indicate multiple individuals (F, the default). If the former only one curve will be produced; if the latter there will be one curve per row in newdata.} \item{conf.type}{One of \code{none}, \code{plain}, \code{log} (the default), or \code{log-log}. The first option causes confidence intervals not to be generated. The second causes the standard intervals curve +- k *se(curve), where k is determined from conf.int. The log option calculates intervals based on the cumulative hazard or log(survival). The last option bases intervals on the log hazard or log(-log(survival)).} \item{...}{Currently not implemented} } \value{ a \code{survfit} object; see the help on \code{survfit.object} for details. The \code{survfit} methods are used for \code{print}, \code{plot}, \code{lines}, and \code{points}. } \description{ Computes a predicted survival curve based on the additive model estimated by rsadd function. } \details{ When predicting the survival curve, the ratetable values for future years will be equal to those of the last given year. The same ratetables will be used for fitting and predicting. To predict a relative survival curve, use \code{rs.surv.rsadd}. } \examples{ data(slopop) data(rdata) #BTW: work on a smaller dataset here to run the example faster fit <- rsadd(Surv(time,cens)~sex,rmap=list(age=age*365.241), ratetable=slopop,data=rdata[1:500,],method="EM") survfit.rsadd(fit,newdata=data.frame(sex=1,age=60,year=17000)) } \references{ Package: Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine,\bold{81}: 272--278. Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. } \seealso{ \code{survfit}, \code{survexp}, \code{\link{rs.surv}} } \keyword{survival} relsurv/man/colrec.Rd0000644000176200001440000000150512705412213014263 0ustar liggesusers\name{colrec} \alias{colrec} \docType{data} \title{Relative Survival Data} \description{ Survival of patients with colon and rectal cancer diagnosed in 1994-2000. } \usage{data(colrec)} \format{ A data frame with 5971 observations on the following 7 variables: \describe{ \item{sex}{sex (1=male, 2=female).} \item{age}{age (in days).} \item{diag}{date of diagnosis (in date format).} \item{time}{survival time (in days).} \item{stat}{censoring indicator (0=censoring, 1=death).} \item{stage}{cancer stage. Values 1-3, code \code{99} stands for unknown.} \item{site}{cancer site. } } } \references{ Provided by Slovene Cancer Registry. The \code{age}, \code{time} and \code{diag} variables are randomly perturbed to make the identification of patients impossible. } \keyword{datasets} relsurv/man/years.Rd0000644000176200001440000001143514151642233014146 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/years.R \name{years} \alias{years} \title{Compute one of the life years measures} \usage{ years( formula = formula(data), data, measure = c("yd", "yl2017", "yl2013"), ratetable = relsurv::slopop, rmap, var.estimator = c("none", "bootstrap", "greenwood"), B = 100, precision = 30, add.times, na.action = stats::na.omit, conf.int = 0.95, timefix = FALSE, admin.cens, arg.example = FALSE, cause.val, is.boot = FALSE, first.boot = FALSE ) } \arguments{ \item{formula}{a formula object, with the response as a \code{Surv} object on the left of a \code{~} operator, and, \code{~1} specified on the right. NOTE: The follow-up time must be in days.} \item{data}{a data.frame in which to interpret the variables named in the \code{formula}.} \item{measure}{choose which measure is used: 'yd' (life years difference; Manevski, Ruzic Gorenjec, Andersen, Pohar Perme, 2022), 'yl2017' (years lost/saved; Andersen 2017), 'yl2013' (years lost/saved; Andersen 2013). the population cumulative incidence curve. Relevant only for \code{measure='yd'}. For \code{measure='yl2013'} and \code{measure='yl2017'} the estimators defined in (Andersen, 2013) and (Andersen, 2017) are used.} \item{ratetable}{a table of event rates, organized as a \code{ratetable} object, such as \code{slopop}.} \item{rmap}{an optional list to be used if the variables are not organized and named in the same way as in the \code{ratetable} object. See details below.} \item{var.estimator}{Choose the estimator for the variance ('none', 'bootstrap', 'greenwood'). Default is 'none'.} \item{B}{if \code{var.estimator} is 'bootstrap'. The number of bootstrap replications. Default is 100.} \item{precision}{precision for numerical integration of the population curve. Default is 30 (days). The value may be decreased to get a higher precision or increased to achieve a faster calculation.} \item{add.times}{specific times at which the curves should be reported.} \item{na.action}{a missing-data filter function. Default is \code{na.omit}.} \item{conf.int}{the confidence level for a two-sided confidence interval. Default is 0.95.} \item{timefix}{the timefix argument in survival::survfit.formula. Default is FALSE.} \item{admin.cens}{if a Date is supplied, administrative censoring is taken into account at that time in the population curve. Works only if there's late entry, e.g. if the formula is \code{Surv(start,stop,event)~1}.} \item{arg.example}{temporary argument, used for checking additionalities.} \item{cause.val}{for competing risks, to be added.} \item{is.boot}{if TRUE, the function \code{years} has been called during a bootstrap replication.} \item{first.boot}{if TRUE, this is the first bootstrap replication.} } \value{ A list containing the years measure, the observed and population curves (or the excess curve for Andersen 2013). The values are given as separate data.frames through time. Times are given in days, all areas are given in years. Functions \code{plot_f} and \code{plot_years} can be then used for plotting. } \description{ Provides an estimate for one of the following measures: years lost (Andersen, 2013), years lost/saved (Andersen, 2017), or life years difference (Manevski, Ruzic Gorenjec, Andersen, Pohar Perme, 2022). } \details{ The life years difference (\code{measure='yd'}) is taken by default. If other measures are of interest, use the \code{measure} argument. The follow-up time must be specified in days. The \code{ratetable} being used may have different variable names and formats than the user's data set, this is dealt with the \code{rmap} argument. For example, if age is in years in the data but in days in the \code{ratetable} object, age=age*365.241 should be used. The calendar year can be in any date format (date, Date and POSIXt are allowed), the date formats in the \code{ratetable} and in the data may differ. Numerical integration is required for the population curves. The integration precision is set with argument \code{precision}, which defaults to 30-day intervals. For higher accuracy take a smaller value (e.g. precision=1 makes the integration on a daily basis). The observed curves are reported at event and censoring times. The population curves are reported at all times used for the numerical integration. Note that for the years lost (Andersen, 2013) measure, only the excess absolute risk is reported. } \examples{ library(relsurv) # Estimate the life years difference for the rdata dataset. mod <- years(Surv(time, cens)~1, data=rdata, measure='yd', ratetable=slopop, rmap=list(age=age*365.241), var.estimator = 'none') # Plot the absolute risk (observed and population curve): plot_f(mod) # Plot the life years difference estimate: plot_years(mod, conf.int=FALSE) } \seealso{ \code{plot_f}, \code{plot_years} } relsurv/man/rs.diff.Rd0000644000176200001440000000566214124561334014365 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rsdiff.r \name{rs.diff} \alias{rs.diff} \alias{print.rsdiff} \title{Test Net Survival Curve Differences} \usage{ rs.diff( formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, na.action, precision = 1, rmap ) } \arguments{ \item{formula}{A formula expression as for other survival models, of the form \code{Surv(time, status) ~ predictors}. Each combination of predictor values defines a subgroup. A \code{strata} term may be used to produce a stratified test. NOTE: The follow-up time must be in days.} \item{data}{a data.frame in which to interpret the variables named in the \code{formula}.} \item{ratetable}{a table of event rates, organized as a \code{ratetable} object, such as \code{slopop}.} \item{na.action}{a missing-data filter function, applied to the model.frame, after any subset argument has been used. Default is \code{options()$na.action}.} \item{precision}{Precision for numerical integration. Default is 1, which means that daily intervals are taken, the value may be decreased to get a higher precision or increased to achieve a faster calculation. The calculation intervals always include at least all times of event and censoring as border points.} \item{rmap}{an optional list to be used if the variables are not organized and named in the same way as in the \code{ratetable} object. See details below.} } \value{ a \code{rsdiff} object; can be printed with \code{print}. } \description{ Tests if there is a difference between two or more net survival curves using a log-rank type test. } \details{ NOTE: The follow-up time must be specified in days. The \code{ratetable} being used may have different variable names and formats than the user's data set, this is dealt with by the \code{rmap} argument. For example, if age is in years in the data set but in days in the \code{ratetable} object, age=age*365.241 should be used. The calendar year can be in any date format (date, Date and POSIXt are allowed), the date formats in the \code{ratetable} and in the data may differ. } \examples{ data(slopop) data(rdata) #calculate the relative survival curve #note that the variable year is given in days since 01.01.1960 and that #age must be multiplied by 365.241 in order to be expressed in days. rs.diff(Surv(time,cens)~sex,rmap=list(age=age*365.241), ratetable=slopop,data=rdata) } \references{ Package: Pohar Perme, M., Pavlic, K. (2018) "Nonparametric Relative Survival Analysis with the R Package relsurv". Journal of Statistical Software. 87(8), 1-27, doi: "10.18637/jss.v087.i08" Theory: Graffeo, N., Castell, F., Belot, A. and Giorgi, R. (2016) "A log-rank-type test to compare net survival distributions. Biometrics. doi: 10.1111/biom.12477" Theory: Pavlic, K., Pohar Perme, M. (2017) "On comparison of net survival curves. BMC Med Res Meth. doi: 10.1186/s12874-017-0351-3" } \seealso{ \code{rs.surv}, \code{survdiff} } \keyword{survival} relsurv/man/nessie.Rd0000644000176200001440000000422713400170743014310 0ustar liggesusers\name{nessie} \alias{nessie} \title{Net Expected Sample Size Is Estimated} \description{ Calculates how the sample size decreases in time due to population mortality } \usage{ nessie(formula, data, ratetable = relsurv::slopop,times,rmap) } \arguments{ \item{formula}{ a formula object, same as in \code{rs.surv}. The right-hand side of the formula object includes the variable that defines the subgroups (a variable of type \code{factor}) by which the expected sample size is to be calculated. } \item{data}{ a data.frame in which to interpret the variables named in the \code{formula}. } \item{ratetable}{ a table of event rates, organized as a \code{ratetable} object, such as \code{slopop}. } \item{times}{Times at which the calculation should be evaluated - in years!} \item{rmap}{an optional list to be used if the variables are not organized and named in the same way as in the \code{ratetable} object. See details of the \code{rs.surv} function.} } \details{ The function calculates the sample size we can expect at a certain time point if the patients die only due to population causes (population survival * initial sample size in a certain category), i.e. the number of individuals that remains at risk at given timepoints after the individuals who die due to population causes are removed. The result should be used as a guideline for the sensible length of follow-up interval when calculating the net survival. The first column of the output reports the number of individuals at time 0. The last column of the output reports the conditional expected (population) survival time for each subgroup. } \value{ A list of values. } \references{ Pohar Perme, M., Pavlic, K. (2018) "Nonparametric Relative Survival Analysis with the {R} Package {relsurv}". Journal of Statistical Software. 87(8), 1-27, doi: "10.18637/jss.v087.i08" } \examples{ data(slopop) data(rdata) rdata$agegr <-cut(rdata$age,seq(40,95,by=5)) nessie(Surv(time,cens)~agegr,rmap=list(age=age*365.241), ratetable=slopop,data=rdata,times=c(1,3,5,10,15)) } \seealso{ \code{rs.surv} } \keyword{survival} relsurv/man/transrate.hmd.Rd0000644000176200001440000000320114124561334015567 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{transrate.hmd} \alias{transrate.hmd} \title{Reorganize Data obtained from Human Mortality Database into a Ratetable Object} \usage{ transrate.hmd(male, female) } \arguments{ \item{male}{a .txt file, containing the data on males.} \item{female}{a .txt file, containing the data on females.} } \value{ An object of class \code{ratetable}. } \description{ The function assists in reorganizing the .txt files obtained from Human Mortality Database (http://www.mortality.org) into a ratetable object. } \details{ This function works automatically with tables organised in the format provided by the Human Mortality Database. Download Life Tables for Males and Females separately from the column named 1x1 (period life tables, organized by date of death, yearly cutpoints for age as well as calendar year). If you wish to provide the data in the required format by yourself, note that the only two columns needed are calendar year (Year) and probability of death (qx). Death probabilities must be calculated up to age 110 (in yearly intervals). } \examples{ \dontrun{ auspop <- transrate.hmd("mltper_1x1.txt","fltper_1x1.txt") } } \references{ Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. } \seealso{ \code{\link{ratetable}}, \code{\link{transrate.hld}}, \code{\link{joinrate}}, \code{\link{transrate}}. } \keyword{survival} relsurv/man/rdata.Rd0000644000176200001440000000122211203231600014072 0ustar liggesusers\name{rdata} \alias{rdata} \docType{data} \title{Survival Data} \description{ Survival data. } \usage{data(rdata)} \format{ A data frame with 1040 observations on the following 6 variables: \describe{ \item{time}{survival time (in days).} \item{cens}{censoring indicator (0=censoring, 1=death).} \item{age}{age (in years).} \item{sex}{sex (1=male, 2=female).} \item{year}{date of diagnosis (in date format).} \item{agegr}{age group.} } } \references{ Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272-278. } \keyword{datasets} relsurv/man/summary.cmp.rel.Rd0000644000176200001440000000246113332517527016065 0ustar liggesusers\name{summary.cmp.rel} \alias{summary.cmp.rel} \title{Summary of the crude probability of death} \description{ Returns a list containing the estimated values at required times. } \usage{ \method{summary}{cmp.rel}(object, times, scale = 365.241,area=FALSE,...) } \arguments{ \item{object}{output of the function \code{cmp.rel}.} \item{times}{the times at which the output is required.} \item{scale}{The time scale in which the times are specified. The default value is \code{1}, i.e. days.} \item{area}{Should area under the curves at time \code{tau} be printed out? Default is \code{FALSE}.} \item{...}{Additional arguments, currently not implemented} } \details{ The variance is calculated using numerical integration. If the required time is not a time at which the value was estimated, the value at the last time before it is reported. The density of the time points is set by the \code{precision} argument in the \code{cmp.rel} function. } \value{ A list of values is returned. } \examples{ data(slopop) data(rdata) #calculate the crude probability of death and summarize it fit <- cmp.rel(Surv(time,cens)~sex,rmap=list(age=age*365), ratetable=slopop,data=rdata,tau=3652.41) summary(fit,c(1,3),scale=365.241) } \seealso{ \code{cmp.rel} } \keyword{survival} relsurv/DESCRIPTION0000644000176200001440000000205314151655142013466 0ustar liggesusersPackage: relsurv Title: Relative Survival Date: 2021-12-01 Version: 2.2-6 Authors@R: c(person(c("Maja","Pohar","Perme"),role=c("aut"),email="maja.pohar@mf.uni-lj.si"), person(c("Damjan","Manevski"),role=c("aut", "cre"),email="damjan.manevski@mf.uni-lj.si")) Author: Maja Pohar Perme [aut], Damjan Manevski [aut, cre] Maintainer: Damjan Manevski Description: Contains functions for analysing relative survival data, including nonparametric estimators of net (marginal relative) survival, relative survival ratio, crude mortality, methods for fitting and checking additive and multiplicative regression models, transformation approach, methods for dealing with population mortality tables. Work has been described in Pohar Perme, Pavlic (2018) . Depends: R (>= 3.5.0), survival (>= 2.42), date Imports: splines, ggplot2, pammtools, scales License: GPL LazyData: true NeedsCompilation: yes Repository: CRAN RoxygenNote: 7.1.1 Packaged: 2021-12-01 10:45:30 UTC; dame_ Date/Publication: 2021-12-01 11:20:02 UTC relsurv/src/0000755000176200001440000000000014151651112012540 5ustar liggesusersrelsurv/src/netwei.c0000644000176200001440000001744714053435762014230 0ustar liggesusers/* ** calculation of various quantities needed for the rs.surv function - sums over individuals at each time ** The output table depends only on factors, not on continuous. ** This version converted to .Call syntax for memory savings ** ** Input: ** ** expected table, a multi-way array ** efac[edim] 1=is a factor, 0=continuous (time based) ** edims[edim] the dimension vector of the table; edim is its length ** ecut[sum(edims)] the starting point (label) for each dimension. ** if it is a factor dim, will be 1:edims[i] ** expect the actual table of expected rates ** ** subject data ** ** x[edim, n] where each subject indexes into the expected table ** at time 0, n= number of subjects ** y[n] the time at risk for each subject ** status[n] the status for each subject ** ** control over output ** ** times[ntime] the list of output times ** ** Output ** ** */ #include #include "survprotomoj.h" /* using thernau's habit: name a S object "charlie2" and the pointer ** to the contents of the object "charlie"; the latter is ** used in the computations */ SEXP netwei( SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2, SEXP status2, SEXP times2) { int i,j,k; int n, edim, ntime; double **x; double *data2, *si; double **ecut, *etemp; double hazard; /*cum hazard over an interval */ double thiscell, etime, time, et2; int indx, indx2; double wt; int *efac, *edims, *status; double *expect, *y, *times; SEXP rlist, rlistnames; /*my declarations*/ SEXP yidli2, dnisi2,yisi2,yidlisi2,yi2,dni2,sidli2,dnisisq2,yisisq2,sis2,yisidli2,yisis2,yidsi2,sit2; double *yidli, *dnisi,*yisi,*yidlisi,*yi,*dni,*sidli,*dnisisq,*yisisq,*sis,*yisidli,*yisis,*yidsi,*sit; /* ** copies of input arguments */ efac = INTEGER(efac2); edims = INTEGER(edims2); edim = LENGTH(edims2); expect= REAL(expect2); n = LENGTH(y2); /*number of individuals */ x = dmatrix(REAL(x2), n, edim); y = REAL(y2); /*follow-up times*/ status = INTEGER(status2); /* status */ times = REAL(times2); ntime = LENGTH(times2); /*length of times for reportint */ /* scratch space */ data2 = (double *)ALLOC(edim+1, sizeof(double)); si = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - to je zdaj pointer, vrednosti klicem s s[i]*/ /* ** Set up ecut index as a ragged array */ ecut = (double **)ALLOC(edim, sizeof(double *)); etemp = REAL(ecut2); for (i=0; i1) etemp += 1 + (efac[i]-1)*edims[i]; } /* ** Create output arrays */ PROTECT(yidli2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ yidli = REAL(yidli2); PROTECT(dnisi2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ dnisi = REAL(dnisi2); PROTECT(yisi2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/ yisi = REAL(yisi2); PROTECT(yidlisi2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ yidlisi = REAL(yidlisi2); PROTECT(yi2 = allocVector(REALSXP, ntime)); /* sum yi at each time*/ yi = REAL(yi2); PROTECT(dni2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ dni = REAL(dni2); PROTECT(sidli2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ sidli = REAL(sidli2); PROTECT(yisisq2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/ yisisq = REAL(yisisq2); PROTECT(dnisisq2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ dnisisq = REAL(dnisisq2); PROTECT(sis2 = allocVector(REALSXP, ntime)); /* sum of Si at each time*/ sis = REAL(sis2); PROTECT(yisidli2 = allocVector(REALSXP, ntime)); /* sum of Si*dLambdai*Yi at each time*/ yisidli = REAL(yisidli2); PROTECT(yisis2 = allocVector(REALSXP, ntime)); /* sum of Si*Yi at each time*/ yisis = REAL(yisis2); PROTECT(sit2 = allocVector(REALSXP, n)); /* Si for each individual*/ sit = REAL(sit2); PROTECT(yidsi2 = allocVector(REALSXP, ntime)); /* sum of dSi*Yi at each time*/ yidsi = REAL(yidsi2); /*initialize Si values*/ for (i=0; i0) { et2 = pystep(edim, &indx, &indx2, &wt, data2, efac, edims, ecut, etime, 1); //sit[i]+=1/expect[indx]*(si[i]* exp(-hazard)- si[i]* exp(-hazard + et2*expect[indx])); if(expect[indx]==0) expect[indx]=0.000000001; if (wt <1) hazard+= et2*(wt*expect[indx] +(1-wt)*expect[indx2]); else hazard+= et2* expect[indx]; for (k=0; k= times[j]){ yidsi[j]+=exp(-hazard); yidli[j]+=hazard; yisidli[j]+=hazard*si[i]; yi[j]+=1; yisi[j]+=1/si[i]; yisisq[j]+=1/(si[i]*si[i]); yisis[j]+=si[i]; yidlisi[j]+=hazard/si[i]; if(y[i]==times[j]){ dnisi[j]+=status[i]/si[i]; dni[j]+=status[i]; dnisisq[j]+=status[i]/(si[i]*si[i]); } } } time += thiscell; } /* ** package the output */ PROTECT(rlist = allocVector(VECSXP, 14)); SET_VECTOR_ELT(rlist,0, yidli2); SET_VECTOR_ELT(rlist,1, yidsi2); SET_VECTOR_ELT(rlist,2, dnisi2); SET_VECTOR_ELT(rlist,3, yisi2); SET_VECTOR_ELT(rlist,4, yidlisi2); SET_VECTOR_ELT(rlist,5, sidli2); SET_VECTOR_ELT(rlist,6, yi2); SET_VECTOR_ELT(rlist,7, dnisisq2); SET_VECTOR_ELT(rlist,8, yisisq2); SET_VECTOR_ELT(rlist,9, dni2); SET_VECTOR_ELT(rlist,10, sis2); SET_VECTOR_ELT(rlist,11, yisidli2); SET_VECTOR_ELT(rlist,12, yisis2); SET_VECTOR_ELT(rlist,13, sit2); PROTECT(rlistnames= allocVector(STRSXP, 14)); SET_STRING_ELT(rlistnames, 0, mkChar("yidli")); SET_STRING_ELT(rlistnames, 1, mkChar("yidsi")); SET_STRING_ELT(rlistnames, 2, mkChar("dnisi")); SET_STRING_ELT(rlistnames, 3, mkChar("yisi")); SET_STRING_ELT(rlistnames, 4, mkChar("yidlisi")); SET_STRING_ELT(rlistnames, 5, mkChar("sidli")); SET_STRING_ELT(rlistnames, 6, mkChar("yi")); SET_STRING_ELT(rlistnames, 7, mkChar("dnisisq")); SET_STRING_ELT(rlistnames, 8, mkChar("yisisq")); SET_STRING_ELT(rlistnames, 9, mkChar("dni")); SET_STRING_ELT(rlistnames, 10, mkChar("sis")); SET_STRING_ELT(rlistnames, 11, mkChar("yisidli")); SET_STRING_ELT(rlistnames, 12, mkChar("yisis")); SET_STRING_ELT(rlistnames, 13, mkChar("sit")); setAttrib(rlist, R_NamesSymbol, rlistnames); unprotect(16); /*kolk mora bit tu stevilka?? kolikor jih je +2??*/ return(rlist); } relsurv/src/cmpfast.c0000644000176200001440000002573513551065110014355 0ustar liggesusers/* ** calculation of various quantities needed for the rs.surv function (for PP method and Ederer II method) - sums over individuals at each time ** ** This version converted to .Call syntax for memory savings ** ** Input: ** ** ** efac[edim] 1=is a factor, 0=continuous (time based) (edim is the number of variables in population mortality tables, usually 3 (age,sex,year), efac tells if they change in time, usually 1,0,1 (age and year change, sex does not)) ** edims[edim] the dimension vector of the population mortality table; edim is its length (for example 111, 2, 40 : 111 ages, 2 sexes, 40 years) ** ecut[sum(edims)] the starting point (label) for each dimension, if factor variable, then NULL. ** for example, for age: 0.00, 365.24, 730.48, 1095.72, 1460.96 ... ** expect the actual population mortality table (values - hazards per day) ** ** subject data ** ** x[edim, n] where each subject indexes into the population mortality table at time 0, n= number of subjects: a matrix - one row per individual - his value of age, sex and year at time of diagnosis ** y[n] the time at risk (follow-up time) for each subject ** status[n] the status for each subject: 0 (censored) or 1 (death) ** ** Output ** ** dnisi: sum(dNi/Spi) at each follow-up time ** yisi: sum(Yi/Spi) at each follow-up time ** yidlisi: sum(YidLambdapi/Spi) at each follow-up time ** dnisisq: sum(dNi/Spi^2) at each follow-up time - needed for the variance ** yi: sum(Yi) at each follow-up time - number at risk at that time ** dni: sum(dNi) at each follow-up time - number of events at that time ** yidli: sum(YidLambdapi/Spi) at each follow-up time ** */ #include #include "survprotomoj.h" /* using thernau's habit: name a S object "charlie2" and the pointer ** to the contents of the object "charlie"; the latter is ** used in the computations */ SEXP cmpfast( SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2,SEXP ys2, SEXP status2, SEXP times2) { int i,j,k,kt; int n, edim, ntime; double **x; double *data2, *si, *sitt; double *dLambdap, *dLambdae, *dLambdao, *sigma, *sigmap, *sigmae, *So, *Soprej; double **ecut, *etemp; double hazard, hazspi; /*cum hazard over an interval, also weigthed hazard */ double thiscell, etime, time, et2; int indx, indx2; double wt; int *efac, *edims, *status; double *expect, *y,*ys, *times; SEXP rlist, rlistnames; /*my declarations*/ SEXP yidli2, dnisi2,yisi2,yidlisi2,yi2,dni2,dnisisq2,yisitt2, cumince2,cumincp2,ve2,vp2,areae2,areap2; double *yidli, *dnisi,*yisi,*yidlisi,*yi,*dni,*dnisisq, *yisitt,*cumince, *cumincp, *ve, *vp, *areae, *areap; /* ** copies of input arguments */ efac = INTEGER(efac2); edims = INTEGER(edims2); edim = LENGTH(edims2); expect= REAL(expect2); n = LENGTH(y2); /*number of individuals */ x = dmatrix(REAL(x2), n, edim); y = REAL(y2); /*follow-up times*/ ys = REAL(ys2); status = INTEGER(status2); /* status */ times = REAL(times2); ntime = LENGTH(times2); /*length of times for reportint */ /* scratch space */ data2 = (double *)ALLOC(edim+1, sizeof(double)); si = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - this is a pointer, the values are called using s[i]*/ sitt = (double *)ALLOC(n, sizeof(double)); /*Si at the beg. of the interval for each individual */ dLambdap = (double *)ALLOC(ntime, sizeof(double)); dLambdae = (double *)ALLOC(ntime, sizeof(double)); dLambdao = (double *)ALLOC(ntime, sizeof(double)); sigma = (double *)ALLOC(ntime, sizeof(double)); sigmap = (double *)ALLOC(ntime, sizeof(double)); sigmae = (double *)ALLOC(ntime, sizeof(double)); So = (double *)ALLOC(ntime, sizeof(double)); Soprej = (double *)ALLOC(ntime, sizeof(double)); /* ** Set up ecut index as a ragged array */ ecut = (double **)ALLOC(edim, sizeof(double *)); etemp = REAL(ecut2); for (i=0; i1) etemp += 1 + (efac[i]-1)*edims[i]; } /* ** Create output arrays */ PROTECT(yidli2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ yidli = REAL(yidli2); PROTECT(dnisi2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ dnisi = REAL(dnisi2); PROTECT(yisi2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/ yisi = REAL(yisi2); PROTECT(yisitt2 = allocVector(REALSXP, ntime)); /*add tt*/ yisitt = REAL(yisitt2); PROTECT(yidlisi2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ yidlisi = REAL(yidlisi2); PROTECT(yi2 = allocVector(REALSXP, ntime)); /* sum yi at each time*/ yi = REAL(yi2); PROTECT(dni2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ dni = REAL(dni2); PROTECT(dnisisq2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ dnisisq = REAL(dnisisq2); PROTECT(cumince2 = allocVector(REALSXP, ntime)); /*add cumince*/ cumince = REAL(cumince2); PROTECT(cumincp2 = allocVector(REALSXP, ntime)); /*add cumincp*/ cumincp = REAL(cumincp2); PROTECT(ve2 = allocVector(REALSXP, ntime)); /*add ve*/ ve = REAL(ve2); PROTECT(vp2 = allocVector(REALSXP, ntime)); /*add vp*/ vp = REAL(vp2); PROTECT(areae2 = allocVector(REALSXP, ntime)); /*add areae*/ areae = REAL(areae2); PROTECT(areap2 = allocVector(REALSXP, ntime)); /*add areap*/ areap = REAL(areap2); /*initialize Si values*/ for (i=0; i= times[j]){ // if still at risk /* ** initialize */ for (k=0; k0) { et2 = pystep(edim, &indx, &indx2, &wt, data2, efac, edims, ecut, etime, 1); hazspi+= et2* expect[indx]/(si[i]*exp(-hazard)); //add the integrated part if (wt <1) hazard+= et2*(wt*expect[indx] +(1-wt)*expect[indx2]); else hazard+= et2* expect[indx]; for (k=0; k0){ So[j]=So[j-1]*(1-dLambdao[j]); Soprej[j]=So[j-1]; } else { So[j]=1-dLambdao[j]; } if(j>0){ cumince[j]=cumince[j-1] + Soprej[j]*dLambdae[j]; cumincp[j]=cumincp[j-1] + Soprej[j]*dLambdap[j]; } else{ cumince[j]=Soprej[j]*dLambdae[j]; cumincp[j]=Soprej[j]*dLambdap[j]; } for (kt=0; kt<=j; kt++) { // ve[j]+= (cumince[j] - cumince[kt])*(cumince[j] - cumince[kt])*sigma[kt] + So[kt]*sigmae[kt]*(So[kt]-2*(cumince[j]-cumince[kt])); // vp[j]+= (cumincp[j] - cumincp[kt])*(cumincp[j] - cumincp[kt])*sigma[kt] + So[kt]*sigmap[kt]*(So[kt]-2*(cumincp[j]-cumincp[kt])); ve[j]+= So[kt]*So[kt]*(1-(cumince[j] - cumince[kt])/So[kt])*(1-(cumince[j] - cumince[kt])/So[kt])*sigma[kt]; vp[j]+= (cumincp[j] - cumincp[kt])*(cumincp[j] - cumincp[kt])*sigma[kt]; } areae[j] = thiscell*cumince[j]; areap[j] = thiscell*cumincp[j]; time += thiscell; }// loop through times for (j=0; j #include #include // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .Call calls */ extern SEXP cmpfast(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP expc(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP netfastpinter(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP netfastpinter2(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP netwei(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP netweiDM(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); static const R_CallMethodDef CallEntries[] = { {"cmpfast", (DL_FUNC) &cmpfast, 9}, {"expc", (DL_FUNC) &expc, 6}, {"netfastpinter", (DL_FUNC) &netfastpinter, 9}, {"netfastpinter2", (DL_FUNC) &netfastpinter2, 10}, {"netwei", (DL_FUNC) &netwei, 8}, {"netweiDM", (DL_FUNC) &netweiDM, 9}, {NULL, NULL, 0} }; void R_init_relsurv(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } relsurv/src/netfastpinter2.c0000644000176200001440000002656613551065110015673 0ustar liggesusers/* ** calculation of various quantities needed for the rs.surv function (for PP method and Ederer II method) - sums over individuals at each time ** ** This version converted to .Call syntax for memory savings ** ** Input: ** ** ** efac[edim] 1=is a factor, 0=continuous (time based) (edim is the number of variables in population mortality tables, usually 3 (age,sex,year), efac tells if they change in time, usually 1,0,1 (age and year change, sex does not)) ** edims[edim] the dimension vector of the population mortality table; edim is its length (for example 111, 2, 40 : 111 ages, 2 sexes, 40 years) ** ecut[sum(edims)] the starting point (label) for each dimension, if factor variable, then NULL. ** for example, for age: 0.00, 365.24, 730.48, 1095.72, 1460.96 ... ** expect the actual population mortality table (values - hazards per day) ** ** subject data ** ** x[edim, n] where each subject indexes into the population mortality table at time 0, n= number of subjects: a matrix - one row per individual - his value of age, sex and year at time of diagnosis ** y[n] the time at risk (follow-up time) for each subject ** status[n] the status for each subject: 0 (censored) or 1 (death) ** ** Output ** ** dnisi: sum(dNi/Spi) at each follow-up time ** yisi: sum(Yi/Spi) at each follow-up time ** yidlisi: sum(YidLambdapi/Spi) at each follow-up time ** dnisisq: sum(dNi/Spi^2) at each follow-up time - needed for the variance ** yi: sum(Yi) at each follow-up time - number at risk at that time ** dni: sum(dNi) at each follow-up time - number of events at that time ** yidli: sum(YidLambdapi/Spi) at each follow-up time ** */ #include #include "survprotomoj.h" /* using thernau's habit: name a S object "charlie2" and the pointer ** to the contents of the object "charlie"; the latter is ** used in the computations */ SEXP netfastpinter2( SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2,SEXP ys2, SEXP status2, SEXP times2, SEXP myprec2) { int i,j,k,jfine; int n, edim, ntime, nprec; double **x; double *data2, *si, *sitt; double **ecut, *etemp; double hazard; /*cum hazard over an interval */ double thiscell, time, et2, fyisi, /* fyisi and fyidlisi are the values in the finer division of the interval, ftime is the tiny time in those intervals */ fyidlisi, fyidlisi2, fyisi2, ftime, fthiscell, fint, sisum, sisumtt, lambdapi, lambdapi2, timestart; int indx, indx2; double wt; int *efac, *edims, *status; double *expect, *y,*ys, *times, *myprec; SEXP rlist, rlistnames; /*my declarations*/ SEXP yidli2, dnisi2,yisi2,yidlisi2,yi2,dni2,dnisisq2,yisitt2,yidlisitt2,yidlisiw2; double *yidli, *dnisi,*yisi,*yidlisi,*yi,*dni,*dnisisq, *yisitt,*yidlisitt,*yidlisiw; /* ** copies of input arguments */ efac = INTEGER(efac2); edims = INTEGER(edims2); edim = LENGTH(edims2); expect= REAL(expect2); n = LENGTH(y2); /*number of individuals */ x = dmatrix(REAL(x2), n, edim); y = REAL(y2); /*follow-up times*/ ys = REAL(ys2); status = INTEGER(status2); /* status */ times = REAL(times2); ntime = LENGTH(times2); /*length of times for reportint */ myprec = REAL(myprec2); //nprec = LENGTH(myprec); /* scratch space */ data2 = (double *)ALLOC(edim+1, sizeof(double)); si = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - this is a pointer, the values are called using s[i]*/ sitt = (double *)ALLOC(n, sizeof(double)); /*Si at the beg. of the interval for each individual */ /* ** Set up ecut index as a ragged array */ ecut = (double **)ALLOC(edim, sizeof(double *)); etemp = REAL(ecut2); for (i=0; i1) etemp += 1 + (efac[i]-1)*edims[i]; } /* ** Create output arrays */ PROTECT(yidli2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ yidli = REAL(yidli2); PROTECT(dnisi2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ dnisi = REAL(dnisi2); PROTECT(yisi2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/ yisi = REAL(yisi2); PROTECT(yisitt2 = allocVector(REALSXP, ntime)); /*add tt*/ yisitt = REAL(yisitt2); PROTECT(yidlisi2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ yidlisi = REAL(yidlisi2); PROTECT(yidlisitt2 = allocVector(REALSXP, ntime)); /*add tt*/ yidlisitt = REAL(yidlisitt2); PROTECT(yidlisiw2 = allocVector(REALSXP, ntime)); /*add w*/ yidlisiw = REAL(yidlisiw2); PROTECT(yi2 = allocVector(REALSXP, ntime)); /* sum yi at each time*/ yi = REAL(yi2); PROTECT(dni2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ dni = REAL(dni2); PROTECT(dnisisq2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ dnisisq = REAL(dnisisq2); /*initialize Si values*/ for (i=0; i= times[j]){ // if still at risk - this is the same throughout the time intervals - the crude fine intervals are at event and censoring times. Spi must be calculated also for those entering later (period...) /* ** initialize */ for (k=0; k0) {*/ //this loop is needed if changes can happen between the interval points. et2 = pystep2(edim, &indx, &indx2, &wt, data2, efac, edims, ecut, fthiscell, 1); lambdapi = expect[indx]; lambdapi2 = expect[indx2]; if(ys[i]<=times[j]){ //he has entered before the crude interval - this guy is at risk for the whole interval - contributes to the values on this interval fyidlisi+= lambdapi/si[i]; fyidlisi2+= lambdapi/(si[i]*exp(-fthiscell* lambdapi)); fyisi+=1/si[i]; fyisi2+=1/(si[i]*exp(-fthiscell* lambdapi)); if (wt <1) hazard+= fthiscell*(wt*lambdapi +(1-wt)*lambdapi2); else hazard+= fthiscell* lambdapi; //length of the time interval * hazard on this interval } // if start of observation before this time /*for (k=0; k #include "survprotomoj.h" /* using thernau's habit: name a S object "charlie2" and the pointer ** to the contents of the object "charlie"; the latter is ** used in the computations */ SEXP netfastp( SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2,SEXP ys2, SEXP status2, SEXP times2) { int i,j,k; int n, edim, ntime; double **x; double *data2, *si; double **ecut, *etemp; double hazard; /*cum hazard over an interval */ double thiscell, etime, time, et2; int indx, indx2; double wt; int *efac, *edims, *status; double *expect, *y,*ys, *times; SEXP rlist, rlistnames; /*my declarations*/ SEXP yidli2, dnisi2,yisi2,yidlisi2,yi2,dni2,dnisisq2; double *yidli, *dnisi,*yisi,*yidlisi,*yi,*dni,*dnisisq; /* ** copies of input arguments */ efac = INTEGER(efac2); edims = INTEGER(edims2); edim = LENGTH(edims2); expect= REAL(expect2); n = LENGTH(y2); /*number of individuals */ x = dmatrix(REAL(x2), n, edim); y = REAL(y2); /*follow-up times*/ ys = REAL(ys2); status = INTEGER(status2); /* status */ times = REAL(times2); ntime = LENGTH(times2); /*length of times for reportint */ /* scratch space */ data2 = (double *)ALLOC(edim+1, sizeof(double)); si = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - this is a pointer, the values are called using s[i]*/ /* ** Set up ecut index as a ragged array */ ecut = (double **)ALLOC(edim, sizeof(double *)); etemp = REAL(ecut2); for (i=0; i1) etemp += 1 + (efac[i]-1)*edims[i]; } /* ** Create output arrays */ PROTECT(yidli2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ yidli = REAL(yidli2); PROTECT(dnisi2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ dnisi = REAL(dnisi2); PROTECT(yisi2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/ yisi = REAL(yisi2); PROTECT(yidlisi2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ yidlisi = REAL(yidlisi2); PROTECT(yi2 = allocVector(REALSXP, ntime)); /* sum yi at each time*/ yi = REAL(yi2); PROTECT(dni2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ dni = REAL(dni2); PROTECT(dnisisq2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ dnisisq = REAL(dnisisq2); /*initialize Si values*/ for (i=0; i= times[j]){ // if still at risk /* ** initialize */ for (k=0; k0) { et2 = pystep(edim, &indx, &indx2, &wt, data2, efac, edims, ecut, etime, 1); if (wt <1) hazard+= et2*(wt*expect[indx] +(1-wt)*expect[indx2]); else hazard+= et2* expect[indx]; for (k=0; k=2: special handling for "years" dim of US rate tables ** dims[nc] the extent of each category ** cuts[nc,dims+1] ragged array, containing the start for each interval ** step the amount of time remaining for the subject. ** edge if =0, then the cuts contain +1 obs, and we are strict ** about out-of-range cells. If it is a 1, then the ** table is assummed to extend infinitly at the edges. ** ** Output ** *index linear index into the array ** if *index == -1, then the returned amount of time is "off table"; ** if one of the dimensions has fac >1 -- ** *index2 second index for linear interpolation ** *wt a number between 0 and 1, amount of wt for the first index ** this will be 1 if none of the dims have fac >1 ** ** Return value amount of time in indexed cell. */ #include "survprotomoj.h" double pystep(int nc, int *index, int *index2, double *wt, double *data, Sint *fac, Sint *dims, double **cuts, double step, int edge) { int i,j; double maxtime; double shortfall; double temp; int kk, dtemp; kk=1; *index =0; *index2=0; *wt =1; shortfall =0; maxtime = step; for (i=0; i1) dtemp = 1 + (fac[i]-1)*dims[i]; else dtemp = dims[i]; for (j=0; j shortfall) { if (temp > step) shortfall = step; else shortfall = temp; } if (temp < maxtime) maxtime = temp; } else if (j==dtemp){ /*bigger than last cutpoint */ if (edge==0) { temp = cuts[i][j] - data[i]; /* time to upper limit */ if (temp <=0) shortfall = step; else if (temp < maxtime) maxtime = temp; } if (fac[i] >1) j = dims[i] -1; /*back to normal indices */ else j--; } else { temp = cuts[i][j] - data[i]; /* time to next cutpoint */ if (temp < maxtime) maxtime = temp; j--; if (fac[i] >1) { /*interpolate the year index */ *wt = 1.0 - (j%fac[i])/ (double)fac[i]; j /= fac[i]; *index2 = kk; } } *index += j*kk; } kk *= dims[i]; } *index2 += *index; if (shortfall ==0) return(maxtime); else { *index = -1; return(shortfall); } } relsurv/src/netfastpinter.c0000644000176200001440000002054213551065110015575 0ustar liggesusers/* ** calculation of various quantities needed for the rs.surv function (for PP method and Ederer II method) - sums over individuals at each time ** ** This version converted to .Call syntax for memory savings ** ** Input: ** ** ** efac[edim] 1=is a factor, 0=continuous (time based) (edim is the number of variables in population mortality tables, usually 3 (age,sex,year), efac tells if they change in time, usually 1,0,1 (age and year change, sex does not)) ** edims[edim] the dimension vector of the population mortality table; edim is its length (for example 111, 2, 40 : 111 ages, 2 sexes, 40 years) ** ecut[sum(edims)] the starting point (label) for each dimension, if factor variable, then NULL. ** for example, for age: 0.00, 365.24, 730.48, 1095.72, 1460.96 ... ** expect the actual population mortality table (values - hazards per day) ** ** subject data ** ** x[edim, n] where each subject indexes into the population mortality table at time 0, n= number of subjects: a matrix - one row per individual - his value of age, sex and year at time of diagnosis ** y[n] the time at risk (follow-up time) for each subject ** status[n] the status for each subject: 0 (censored) or 1 (death) ** ** Output ** ** dnisi: sum(dNi/Spi) at each follow-up time ** yisi: sum(Yi/Spi) at each follow-up time ** yidlisi: sum(YidLambdapi/Spi) at each follow-up time ** dnisisq: sum(dNi/Spi^2) at each follow-up time - needed for the variance ** yi: sum(Yi) at each follow-up time - number at risk at that time ** dni: sum(dNi) at each follow-up time - number of events at that time ** yidli: sum(YidLambdapi/Spi) at each follow-up time ** */ #include #include "survprotomoj.h" /* using thernau's habit: name a S object "charlie2" and the pointer ** to the contents of the object "charlie"; the latter is ** used in the computations */ SEXP netfastpinter( SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2,SEXP ys2, SEXP status2, SEXP times2) { int i,j,k; int n, edim, ntime; double **x; double *data2, *si, *sitt; double **ecut, *etemp; double hazard, hazspi; /*cum hazard over an interval, also weigthed hazard */ double thiscell, etime, time, et2; int indx, indx2; double wt; int *efac, *edims, *status; double *expect, *y,*ys, *times; SEXP rlist, rlistnames; /*my declarations*/ SEXP yidli2, dnisi2,yisi2,yidlisi2,yi2,dni2,dnisisq2,yisitt2,yidlisitt2,yidlisiw2; double *yidli, *dnisi,*yisi,*yidlisi,*yi,*dni,*dnisisq, *yisitt,*yidlisitt,*yidlisiw; /* ** copies of input arguments */ efac = INTEGER(efac2); edims = INTEGER(edims2); edim = LENGTH(edims2); expect= REAL(expect2); n = LENGTH(y2); /*number of individuals */ x = dmatrix(REAL(x2), n, edim); y = REAL(y2); /*follow-up times*/ ys = REAL(ys2); status = INTEGER(status2); /* status */ times = REAL(times2); ntime = LENGTH(times2); /*length of times for reportint */ /* scratch space */ data2 = (double *)ALLOC(edim+1, sizeof(double)); si = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - this is a pointer, the values are called using s[i]*/ sitt = (double *)ALLOC(n, sizeof(double)); /*Si at the beg. of the interval for each individual */ /* ** Set up ecut index as a ragged array */ ecut = (double **)ALLOC(edim, sizeof(double *)); etemp = REAL(ecut2); for (i=0; i1) etemp += 1 + (efac[i]-1)*edims[i]; } /* ** Create output arrays */ PROTECT(yidli2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ yidli = REAL(yidli2); PROTECT(dnisi2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ dnisi = REAL(dnisi2); PROTECT(yisi2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/ yisi = REAL(yisi2); PROTECT(yisitt2 = allocVector(REALSXP, ntime)); /*add tt*/ yisitt = REAL(yisitt2); PROTECT(yidlisi2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ yidlisi = REAL(yidlisi2); PROTECT(yidlisitt2 = allocVector(REALSXP, ntime)); /*add tt*/ yidlisitt = REAL(yidlisitt2); PROTECT(yidlisiw2 = allocVector(REALSXP, ntime)); /*add w*/ yidlisiw = REAL(yidlisiw2); PROTECT(yi2 = allocVector(REALSXP, ntime)); /* sum yi at each time*/ yi = REAL(yi2); PROTECT(dni2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ dni = REAL(dni2); PROTECT(dnisisq2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ dnisisq = REAL(dnisisq2); /*initialize Si values*/ for (i=0; i= times[j]){ // if still at risk /* ** initialize */ for (k=0; k0) { et2 = pystep(edim, &indx, &indx2, &wt, data2, efac, edims, ecut, etime, 1); hazspi+= et2* expect[indx]/(si[i]*exp(-hazard)); //add the integrated part if (wt <1) hazard+= et2*(wt*expect[indx] +(1-wt)*expect[indx2]); else hazard+= et2* expect[indx]; for (k=0; k=2: special handling for "years" dim of US rate tables ** dims[nc] the extent of each category ** cuts[nc,dims+1] ragged array, containing the start for each interval ** step the amount of time remaining for the subject. ** edge if =0, then the cuts contain +1 obs, and we are strict ** about out-of-range cells. If it is a 1, then the ** table is assummed to extend infinitly at the edges. ** ** Output ** *index linear index into the array ** if *index == -1, then the returned amount of time is "off table"; ** if one of the dimensions has fac >1 -- ** *index2 second index for linear interpolation ** *wt a number between 0 and 1, amount of wt for the first index ** this will be 1 if none of the dims have fac >1 ** ** Return value amount of time in indexed cell. */ #include "survprotomoj.h" double pystep2(int nc, int *index, int *index2, double *wt, double *data, Sint *fac, Sint *dims, double **cuts, double step, int edge) { int i,j; double shortfall; int kk, dtemp; kk=1; *index =0; *index2=0; *wt =1; shortfall =0; for (i=0; i #include "survprotomoj.h" /* my habit is to name a S object "charlie2" and the pointer ** to the contents of the object "charlie"; the latter is ** used in the computations */ SEXP expc(SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2) { int i,k; int n, edim; double **x; double *data2; double **ecut, *etemp; double hazard; /*cum hazard over an interval */ double etime, et2; int indx, indx2; double wt; int *efac, *edims; double *expect, *y ; SEXP rlist, rlistnames; /*my declarations*/ SEXP si2; double *si; /* ** copies of input arguments */ efac = INTEGER(efac2); edims = INTEGER(edims2); edim = LENGTH(edims2); expect= REAL(expect2); n = LENGTH(y2); /*number of individuals */ x = dmatrix(REAL(x2), n, edim); y = REAL(y2); /*follow-up times*/ /* scratch space */ data2 = (double *)ALLOC(edim+1, sizeof(double)); /*si2 = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - a je to prav???*/ /* ** Set up ecut index as a ragged array */ ecut = (double **)ALLOC(edim, sizeof(double *)); etemp = REAL(ecut2); for (i=0; i1) etemp += 1 + (efac[i]-1)*edims[i]; } /* ** Create output arrays */ PROTECT(si2 = allocVector(REALSXP, n)); /* Si for each individual*/ si = REAL(si2); /*initialize Si values*/ for (i=0; i0) { et2 = pystep(edim, &indx, &indx2, &wt, data2, efac, edims, ecut, etime, 1); if (wt <1) hazard+= et2*(wt*expect[indx] +(1-wt)*expect[indx2]); else hazard+= et2* expect[indx]; for (k=0; k #include "survprotomoj.h" /* using thernau's habit: name a S object "charlie2" and the pointer ** to the contents of the object "charlie"; the latter is ** used in the computations */ SEXP netweiDM( SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2, SEXP ys2, SEXP status2, SEXP times2) { int i,j,k; int n, edim, ntime; double **x; double *data2, *si, *si2; double **ecut, *etemp; double hazard; /*cum hazard over an interval */ double thiscell, etime, time, et2; int indx, indx2; double wt; int *efac, *edims, *status; double *expect, *y, *ys, *times; SEXP rlist, rlistnames; /*my declarations*/ SEXP yidli2, dnisi2,yisi2,yidlisi2,yi2,dni2,sidli2,sidliD2,dnisisq2,yisisq2,sis2,sisD2,yisidli2,yisis2,yidsi2,sit2; double *yidli, *dnisi,*yisi,*yidlisi,*yi,*dni,*sidli,*sidliD,*dnisisq,*yisisq,*sis,*sisD,*yisidli,*yisis,*yidsi,*sit; /* ** copies of input arguments */ efac = INTEGER(efac2); edims = INTEGER(edims2); edim = LENGTH(edims2); expect= REAL(expect2); n = LENGTH(y2); /*number of individuals */ x = dmatrix(REAL(x2), n, edim); y = REAL(y2); /*follow-up times*/ ys = REAL(ys2); status = INTEGER(status2); /* status */ times = REAL(times2); ntime = LENGTH(times2); /*length of times for reportint */ /* scratch space */ data2 = (double *)ALLOC(edim+1, sizeof(double)); si = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - to je zdaj pointer, vrednosti klicem s s[i]*/ si2 = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - to je zdaj pointer, vrednosti klicem s s[i]*/ /* ** Set up ecut index as a ragged array */ ecut = (double **)ALLOC(edim, sizeof(double *)); etemp = REAL(ecut2); for (i=0; i1) etemp += 1 + (efac[i]-1)*edims[i]; } /* ** Create output arrays */ PROTECT(yidli2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ yidli = REAL(yidli2); PROTECT(dnisi2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ dnisi = REAL(dnisi2); PROTECT(yisi2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/ yisi = REAL(yisi2); PROTECT(yidlisi2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ yidlisi = REAL(yidlisi2); PROTECT(yi2 = allocVector(REALSXP, ntime)); /* sum yi at each time*/ yi = REAL(yi2); PROTECT(dni2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ dni = REAL(dni2); PROTECT(sidli2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ sidli = REAL(sidli2); PROTECT(sidliD2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ sidliD = REAL(sidliD2); PROTECT(yisisq2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/ yisisq = REAL(yisisq2); PROTECT(dnisisq2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ dnisisq = REAL(dnisisq2); PROTECT(sis2 = allocVector(REALSXP, ntime)); /* sum of Si at each time*/ sis = REAL(sis2); PROTECT(sisD2 = allocVector(REALSXP, ntime)); /* sum of Si at each time*/ sisD = REAL(sisD2); PROTECT(yisidli2 = allocVector(REALSXP, ntime)); /* sum of Si*dLambdai*Yi at each time*/ yisidli = REAL(yisidli2); PROTECT(yisis2 = allocVector(REALSXP, ntime)); /* sum of Si*Yi at each time*/ yisis = REAL(yisis2); PROTECT(sit2 = allocVector(REALSXP, n)); /* Si for each individual*/ sit = REAL(sit2); PROTECT(yidsi2 = allocVector(REALSXP, ntime)); /* sum of dSi*Yi at each time*/ yidsi = REAL(yidsi2); /*initialize Si values*/ for (i=0; i0) { et2 = pystep(edim, &indx, &indx2, &wt, data2, efac, edims, ecut, etime, 1); //sit[i]+=1/expect[indx]*(si[i]* exp(-hazard)- si[i]* exp(-hazard + et2*expect[indx])); if(expect[indx]==0) expect[indx]=0.000000001; if (wt <1) hazard+= et2*(wt*expect[indx] +(1-wt)*expect[indx2]); else hazard+= et2* expect[indx]; for (k=0; k= times[j]){ if(ys[i]==times[j]){ si2[i]=1; } if(ys[i]= times[j]){ yidsi[j]+=exp(-hazard); yidli[j]+=hazard; yisidli[j]+=hazard*si[i]; yi[j]+=1; yisi[j]+=1/si[i]; yisisq[j]+=1/(si[i]*si[i]); yisis[j]+=si[i]; yidlisi[j]+=hazard/si[i]; if(y[i]==times[j]){ dnisi[j]+=status[i]/si[i]; dni[j]+=status[i]; dnisisq[j]+=status[i]/(si[i]*si[i]); } } } time += thiscell; } /* ** package the output */ PROTECT(rlist = allocVector(VECSXP, 16)); SET_VECTOR_ELT(rlist,0, yidli2); SET_VECTOR_ELT(rlist,1, yidsi2); SET_VECTOR_ELT(rlist,2, dnisi2); SET_VECTOR_ELT(rlist,3, yisi2); SET_VECTOR_ELT(rlist,4, yidlisi2); SET_VECTOR_ELT(rlist,5, sidli2); SET_VECTOR_ELT(rlist,6, yi2); SET_VECTOR_ELT(rlist,7, dnisisq2); SET_VECTOR_ELT(rlist,8, yisisq2); SET_VECTOR_ELT(rlist,9, dni2); SET_VECTOR_ELT(rlist,10, sis2); SET_VECTOR_ELT(rlist,11, yisidli2); SET_VECTOR_ELT(rlist,12, yisis2); SET_VECTOR_ELT(rlist,13, sit2); SET_VECTOR_ELT(rlist,14, sidliD2); SET_VECTOR_ELT(rlist,15, sisD2); PROTECT(rlistnames= allocVector(STRSXP, 16)); SET_STRING_ELT(rlistnames, 0, mkChar("yidli")); SET_STRING_ELT(rlistnames, 1, mkChar("yidsi")); SET_STRING_ELT(rlistnames, 2, mkChar("dnisi")); SET_STRING_ELT(rlistnames, 3, mkChar("yisi")); SET_STRING_ELT(rlistnames, 4, mkChar("yidlisi")); SET_STRING_ELT(rlistnames, 5, mkChar("sidli")); SET_STRING_ELT(rlistnames, 6, mkChar("yi")); SET_STRING_ELT(rlistnames, 7, mkChar("dnisisq")); SET_STRING_ELT(rlistnames, 8, mkChar("yisisq")); SET_STRING_ELT(rlistnames, 9, mkChar("dni")); SET_STRING_ELT(rlistnames, 10, mkChar("sis")); SET_STRING_ELT(rlistnames, 11, mkChar("yisidli")); SET_STRING_ELT(rlistnames, 12, mkChar("yisis")); SET_STRING_ELT(rlistnames, 13, mkChar("sit")); SET_STRING_ELT(rlistnames, 14, mkChar("sidliD")); SET_STRING_ELT(rlistnames, 15, mkChar("sisD")); setAttrib(rlist, R_NamesSymbol, rlistnames); unprotect(18); /*kolk mora bit tu stevilka?? kolikor jih je +2??*/ return(rlist); } relsurv/R/0000755000176200001440000000000014122605064012155 5ustar liggesusersrelsurv/R/survfitrsadd.r0000644000176200001440000001171614070550360015066 0ustar liggesusers#' Compute a Predicited Survival Curve #' #' Computes a predicted survival curve based on the additive model estimated by #' rsadd function. #' #' When predicting the survival curve, the ratetable values for future years #' will be equal to those of the last given year. The same ratetables will be #' used for fitting and predicting. To predict a relative survival curve, use #' \code{rs.surv.rsadd}. #' #' @param formula a rsadd object #' @param newdata a data frame with the same variable names as those that #' appear in the rsadd formula. The curve(s) produced will be representative of #' a cohort who's covariates correspond to the values in newdata. #' @param se.fit a logical value indicating whether standard errors should be #' computed. Default is \code{TRUE}. #' @param conf.int the level for a two-sided confidence interval on the #' survival curve(s). Default is 0.95. #' @param individual a logical value indicating whether the data frame #' represents different time epochs for only one individual (T), or whether #' multiple rows indicate multiple individuals (F, the default). If the former #' only one curve will be produced; if the latter there will be one curve per #' row in newdata. #' @param conf.type One of \code{none}, \code{plain}, \code{log} (the default), #' or \code{log-log}. The first option causes confidence intervals not to be #' generated. The second causes the standard intervals curve +- k *se(curve), #' where k is determined from conf.int. The log option calculates intervals #' based on the cumulative hazard or log(survival). The last option bases #' intervals on the log hazard or log(-log(survival)). #' @param ... Currently not implemented #' @return a \code{survfit} object; see the help on \code{survfit.object} for #' details. The \code{survfit} methods are used for \code{print}, \code{plot}, #' \code{lines}, and \code{points}. #' @seealso \code{survfit}, \code{survexp}, \code{\link{rs.surv}} #' @references Package: Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine,\bold{81}: 272--278. #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #BTW: work on a smaller dataset here to run the example faster #' fit <- rsadd(Surv(time,cens)~sex,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata[1:500,],method="EM") #' survfit.rsadd(fit,newdata=data.frame(sex=1,age=60,year=17000)) #' #' survfit.rsadd <- function (formula, newdata, se.fit = TRUE, conf.int = 0.95, individual = FALSE, conf.type = c("log", "log-log", "plain", "none"),...) { call <- match.call() Terms <- terms(formula) #to rabis, ce je model mal bl smotan - as.factor ali splines ali svasta Terms <- delete.response(Terms) popdata <- newdata newdata <- model.frame(Terms,newdata) resp <- list(y=formula$y,x=newdata) n <- formula$n nvar <- length(formula$coef) nx <- nrow(newdata) nt <- length(formula$times) temp <- list(n=formula$n,time=formula$times,call=call,type="right") Lambda0 <- formula$Lambda0 Lambda0 <- matrix(Lambda0,ncol=nt,nrow=nrow(newdata),byrow=TRUE) rate <- attr(Terms, "specials")$ratetable #rat <- attributes(formula$ratetable)$dimid rat <- names(attributes(formula$ratetable)$dimnames) #mein <- attributes(newdata[,rate])$dimnames[[2]] mein <- names(popdata) x <- match(rat,mein) #R <- as.matrix(newdata[, rate, drop = FALSE]) R <- as.matrix(popdata) R <- R[,x,drop=FALSE] R <- data.frame(R) names(R) <- rat #newdata <- newdata[,1:(rate-1),drop=FALSE] labeli <- attr(attr(newdata,"terms"),"term.labels") colnami <- colnames(newdata) if(length(rate>0)){ labeli <- labeli[-rate] colnami <- colnami[-rate] } newdata <- newdata[,match(colnami,labeli),drop=F] if(any(formula$mvalue)>0)newdata <- newdata - matrix(formula$mvalue,nrow=nrow(newdata),byrow=TRUE) nx <- ncol(newdata) #getl <- function(times,data=R,ratetable=formula$ratetable){ # -log(srvxp.fit(data,times,ratetable)) #} #Lambdap <- sapply(formula$times, getl) # Lambdap <- NULL # for(it in 1:nt){ # Lambdap <- cbind(Lambdap,-log(srvxp.fit(R,formula$times[it],formula$ratetable))) # } Lambdap <- NULL for(it in 1:nrow(newdata)){ Lambdap <- rbind(Lambdap,-log(survexp(~1,data=R[it,,drop=FALSE],times=formula$times,ratetable=formula$ratetable)$surv)) } ebx <- exp(as.matrix(formula$coef %*%as.numeric(newdata))) ebx <- matrix(ebx,ncol=nt,nrow=length(ebx)) Lambda <- Lambdap + Lambda0*ebx temp$surv <- t(exp(-Lambda)) temp$n.event <- rep(1,nt) temp$n.risk <- n+1 - cumsum(temp$n.event) class(temp) <- c("rs.surv.rsadd", "rs.surv","survfit") temp } relsurv/R/zzz.R0000644000176200001440000000532114151642242013137 0ustar liggesusers#.First.lib <- function(lib, pkg) library.dynam("runproba", pkg, lib) # use .onLoad instead of .First.lib for use with NAMESPACE and R(>= 1.7.0) .onLoad <- function(lib, pkg) { # library.dynam <- function (chname, package, lib.loc, verbose = getOption("verbose"), # file.ext = .Platform$dynlib.ext, ...) # { # dll_list <- .dynLibs() # if (missing(chname) || !nzchar(chname)) # return(dll_list) # package # lib.loc # r_arch <- .Platform$r_arch # chname1 <- paste0(chname, file.ext) # # browser() # for (pkg in "C:/Users/dame_/Dropbox (MF Uni LJ)/Damjan Manevski/Research/relsurv/relsurv_2.2-5"){ # #find.package('relsurv_2.2-5', lib.loc, verbose = verbose)) { # DLLpath <- if (nzchar(r_arch)) # # file.path(pkg, "libs", r_arch) # "C:/Users/dame_/Dropbox (MF Uni LJ)/Damjan Manevski/Research/relsurv/relsurv_2.2-5/src" # else file.path(pkg, "libs") # # file <- file.path(DLLpath, chname1) # file <- "C:/Users/dame_/Dropbox (MF Uni LJ)/Damjan Manevski/Research/relsurv/relsurv_2.2-5/src/relsurv.dll" # # browser() # if (file.exists(file)) # break # else file <- "" # } # if (file == "") # if (.Platform$OS.type == "windows") # stop(gettextf("DLL %s not found: maybe not installed for this architecture?", # sQuote(chname)), domain = NA) # else stop(gettextf("shared object %s not found", sQuote(chname1)), # domain = NA) # # browser() # file <- file.path(normalizePath(DLLpath, "/", TRUE), chname1) # ind <- vapply(dll_list, function(x) x[["path"]] == file, # NA) # if (length(ind) && any(ind)) { # if (verbose) # if (.Platform$OS.type == "windows") # message(gettextf("DLL %s already loaded", sQuote(chname1)), # domain = NA) # else message(gettextf("shared object '%s' already loaded", # sQuote(chname1)), domain = NA) # return(invisible(dll_list[[seq_along(dll_list)[ind]]])) # } # if (.Platform$OS.type == "windows") { # PATH <- Sys.getenv("PATH") # Sys.setenv(PATH = paste(gsub("/", "\\\\", DLLpath), # PATH, sep = ";")) # on.exit(Sys.setenv(PATH = PATH)) # } # if (verbose) # message(gettextf("now dyn.load(\"%s\") ...", file), # domain = NA) # dll <- if ("DLLpath" %in% names(list(...))) # dyn.load(file, ...) # else dyn.load(file, DLLpath = DLLpath, ...) # .dynLibs(c(dll_list, list(dll))) # invisible(dll) # } library.dynam("relsurv", pkg, lib) }#end of .onLoad relsurv/R/rformulate.r0000644000176200001440000002060113357572312014527 0ustar liggesusers# This is a version with suggested updates by T Therneau # All updates are stolen from survexp in the survival package, with comments. # Most changes are used, some further corrections were required. rformulate <- function (formula, data = parent.frame(), ratetable, na.action, rmap, int, centered, cause) { call <- match.call() m <- match.call(expand.dots = FALSE) # keep the parts of the call that we want, toss others m <- m[c(1, match(c("formula", "data", "cause"), names(m), nomatch=0))] m[[1L]] <- quote(stats::model.frame) # per CRAN, the formal way to set it Terms <- if (missing(data)) terms(formula, specials= c("strata","ratetable")) else terms(formula, specials=c("strata", "ratetable"), data = data) Term2 <- Terms #sorting out the ratetable argument - matching demographic variables rate <- attr(Terms, "specials")$ratetable if (length(rate) > 1) stop("Can have only 1 ratetable() call in a formula") #matching demographic variables via rmap if (!missing(rmap)) { # use this by preference if (length(rate) >0) stop("cannot have both ratetable() in the formula and a rmap argument") rcall <- rmap if (!is.call(rcall) || rcall[[1]] != as.name('list')) stop ("Invalid rcall argument") } #done with rmap else if (length(rate) >0) { #sorting out ratetable stemp <- untangle.specials(Terms, 'ratetable') rcall <- as.call(parse(text=stemp$var)[[1]]) # as a call object rcall[[1]] <- as.name('list') # make it a call to list Term2 <- Term2[-stemp$terms] # remove from the formula } else rcall <- NULL # A ratetable, but no rcall or ratetable() # Check that there are no illegal names in rcall, then expand it # to include all the names in the ratetable if (is.ratetable(ratetable)) { israte <- TRUE dimid <- names(dimnames(ratetable)) if (is.null(dimid)) dimid <- attr(ratetable, "dimid") # older style else attr(ratetable, "dimid") <- dimid #put all tables into the old style temp <- match(names(rcall)[-1], dimid) # 2,3,... are the argument names if (any(is.na(temp))) stop("Variable not found in the ratetable:", (names(rcall))[is.na(temp)]) if (any(!(dimid %in% names(rcall)))) { to.add <- dimid[!(dimid %in% names(rcall))] temp1 <- paste(text=paste(to.add, to.add, sep='='), collapse=',') if (is.null(rcall)) rcall <- parse(text=paste("list(", temp1, ")"))[[1]] else { temp2 <- deparse(rcall) rcall <- parse(text=paste("c(", temp2, ",list(", temp1, "))"))[[1]] } } } else stop("invalid ratetable") # Create a temporary formula, used only in the call to model.frame, # that has extra variables newvar <- all.vars(rcall) if (length(newvar) > 0) { tform <- paste(paste(deparse(Term2), collapse=""), paste(newvar, collapse='+'), sep='+') m$formula <- as.formula(tform, environment(Terms)) } m <- eval(m, parent.frame()) n <- nrow(m) if (n==0) stop("data set has 0 rows") Y <- model.extract(m, "response") offset <- model.offset(m) if (length(offset)==0) offset <- rep(0., n) if (!is.Surv(Y)) stop("Response must be a survival object") Y.surv <- Y if (attr(Y, "type") == "right") { type <- attr(Y, "type") status <- Y[, 2] Y <- Y[, 1] start <- rep(0, n) ncol0 <- 2 } else if (attr(Y, "type") == "counting") { type <- attr(Y, "type") status <- Y[, 3] start <- Y[, 1] Y <- Y[, 2] ncol0 <- 3 } else stop("Illegal response value") if (any(c(Y, start) < 0)) stop("Negative follow up time") if(max(Y)<30) warning("The event times must be expressed in days! (Your max time in the data is less than 30 days) \n") # rdata contains the variables matching the ratetable rdata <- data.frame(eval(rcall, m), stringsAsFactors=TRUE) rtemp <- match.ratetable(rdata, ratetable) #this function puts the dates in R and in cutpoints in rtabledate R <- rtemp$R cutpoints <- rtemp$cutpoints if(is.null(attr(ratetable, "factor"))) attr(ratetable, "factor") <- (attr(ratetable, "type") ==1) attr(ratetable, "dimid") <- dimid rtorig <- attributes(ratetable) nrt <- length(rtorig$dimid) #checking if the ratetable variables are given in days wh.age <- which(dimid=="age") wh.year <- which(dimid=="year") if(length(wh.age)>0){ if (max(R[,wh.age])<150 & median(diff(cutpoints[[wh.age]]))>12) warning("Age in the ratetable part of the formula must be expressed in days! \n (Your max age is less than 150 days) \n") } # TMT -- note the new class if(length(wh.year)>0){ if(min(R[,wh.year])>1850 & max(R[,wh.year])<2020& class(cutpoints[[wh.year]])=="rtdate") warning("The calendar year must be one of the date classes (Date, date, POSIXt)\n (Your variable seems to be expressed in years) \n") } #checking if one of the continuous variables is fixed: if(nrt!=ncol(R)){ nonex <- which(is.na(match(rtorig$dimid,attributes(ratetable)$dimid))) for(it in nonex){ if(rtorig$type[it]!=1)warning(paste("Variable ",rtorig$dimid[it]," is held fixed even though it changes in time in the population tables. \n (You may wish to set a value for each individual and not just one value for all)",sep="")) } } #NEW in 2.05 (strata) # Now create the X matrix and strata strats <- attr(Term2, "specials")$strata if (length(strats)) { temp_str <- untangle.specials(Term2,"strata",1) if (length(temp_str$vars) == 1) strata.keep <- m[[temp_str$vars]] else strata.keep <- strata(m[,temp_str$vars],shortlabel=TRUE,sep=",") Term2 <- Term2[-temp_str$terms] } else strata.keep <- factor(rep(1,n)) # zgoraj ze definirano n = nrow(m) if (!missing(cause)) strata.keep <- factor(rep(1,n)) attr(Term2, "intercept") <- 1 # ignore a "-1" in the formula X <- model.matrix(Term2, m)[,-1, drop=FALSE] mm <- ncol(X) if (mm > 0 && !missing(centered) && centered) { mvalue <- colMeans(X) X <- X - rep(mvalue, each=nrow(X)) } else mvalue <- double(mm) cause <- model.extract(m, "cause") if(is.null(cause)) cause <- rep(2,nrow(m)) #NEW: ce cause manjka #status[cause==0] <- 0 keep <- Y > start if (!missing(int)) { int <- max(int) status[Y > int * 365.241] <- 0 Y <- pmin(Y, int * 365.241) keep <- keep & (start < int * 365.241) } if (any(start > Y) | any(Y < 0)) stop("Negative follow-up times") if (!all(keep)) { X <- X[keep, , drop = FALSE] Y <- Y[keep] start <- start[keep] status <- status[keep] R <- R[keep, ,drop=FALSE] strata.keep <- strata.keep[keep] # dodano za strato #NEW in 2.05 offset <- offset[keep] Y.surv <- Y.surv[keep, , drop = FALSE] cause <- cause[keep] n <- sum(keep) rdata <- rdata[keep,] } # I do not want to preserve variable class here - so paste R onto here, give it names temp <- R names(temp) <- paste0("X", 1:ncol(temp)) # with the right names #if variable class needs to be preserved, use this instead # variable class. So paste on rdata, but with the right order and names #temp <- rdata[,match(dimid, names(rdata))] # in the right order #names(temp) <- paste0("X", 1:ncol(temp)) # with the right names data <- data.frame(start = start, Y = Y, stat = status, temp) if (mm != 0) data <- cbind(data, X) # we pass the altered cutpoints forward, keep them in the date format (could be changed eventually to get rid of the date package dependence) attr(ratetable, "cutpoints") <- lapply(cutpoints, function(x) { if (class(x) == 'rtabledate') class(x) <- 'date' x}) out <- list(data = data, R = R, status = status, start = start, Y = Y, X = as.data.frame(X), m = mm, n = n, type = type, Y.surv = Y.surv, Terms = Terms, ratetable = ratetable, offset = offset, formula=formula, cause = cause, mvalue=mvalue, strata.keep=strata.keep) # dodano za strato #NEW in 2.05 na.action <- attr(m, "na.action") if (length(na.action)) out$na.action <- na.action out } relsurv/R/cmprel.r0000644000176200001440000004427714070550360013640 0ustar liggesusers#' Compute crude probability of death #' #' Estimates the crude probability of death due to disease and due to #' population reasons #' #' NOTE: The follow-up time must be specified in days. The \code{ratetable} #' being used may have different variable names and formats than the user's #' data set, this is dealt with by the \code{rmap} argument. For example, if #' age is in years in the data set but in days in the \code{ratetable} object, #' age=age*365.241 should be used. The calendar year can be in any date format #' (date, Date and POSIXt are allowed), the date formats in the #' \code{ratetable} and in the data may differ. #' #' Note that numerical integration is required to calculate the variance #' estimator. The integration precision is set with argument \code{precision}, #' which defaults to daily intervals, a default that should give enough #' precision for any practical purpose. #' #' The area under the curve is calculated on the interval [0,\code{tau}]. #' #' Function \code{summary} may be used to get the output at specific points in #' time. #' #' @aliases cmp.rel print.cmp.rel #' @param formula a formula object, with the response as a \code{Surv} object #' on the left of a \code{~} operator, and, if desired, terms separated by the #' \code{+} operator on the right. If no strata are used, \code{~1} should be #' specified. #' #' NOTE: The follow-up time must be in days. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param ratetable a table of event rates, organized as a \code{ratetable} #' object, such as \code{slopop}. #' @param na.action a missing-data filter function, applied to the model.frame, #' after any subset argument has been used. Default is #' \code{options()$na.action}. #' @param tau the maximum follow-up time of interest, all times larger than #' \code{tau} shall be censored. Equals maximum observed time by default #' @param conf.int the level for a two-sided confidence interval on the #' survival curve(s). Default is 0.95. #' @param precision the level of precision used in the numerical integration of #' variance. Default is 1, which means that daily intervals are taken, the #' value may be decreased to get a higher precision or increased to achieve a #' faster calculation. The calculation intervals always include at least all #' times of event and censoring as border points. #' @param add.times specific times at which the value of estimator and its #' variance should be evaluated. Default is all the event and censoring times. #' @param rmap an optional list to be used if the variables are not organized #' and named in the same way as in the \code{ratetable} object. See details #' below. #' @return An object of class \code{cmp.rel}. Objects of this class have #' methods for the functions \code{print} and \code{plot}. The \code{summary} #' function can be used for printing output at required time points. An object #' of class \code{cmp.rel} is composed of several lists, each pertaining the #' cumulative hazard function for one risk and one strata. Each of the lists #' contains the following objects: \item{time}{the time-points at which the #' curves are estimated} \item{est}{the estimate} \item{var}{the variance of #' the estimate} \item{lower}{the lower limit of the confidence interval} #' \item{upper}{the upper limit of the confidence interval} \item{area}{the #' area under the curve calculated on the interval [0,\code{tau}]} #' \item{index}{indicator of event and censoring times among all the times in #' the output. The times added via paramater \code{add.times} are also #' included} \item{add.times}{the times added via parameter \code{add.times}} #' @seealso \code{rs.surv}, \code{summary.cmp.rel} #' @references Package: Pohar Perme, M., Pavlic, K. (2018) "Nonparametric #' Relative Survival Analysis with the R Package relsurv". Journal of #' Statistical Software. 87(8), 1-27, doi: "10.18637/jss.v087.i08" #' @keywords survival #' @examples #' #' #' data(slopop) #' data(rdata) #' #calculate the crude probability of death #' #note that the variable year must be given in a date format and that #' #age must be multiplied by 365.241 in order to be expressed in days. #' fit <- cmp.rel(Surv(time,cens)~sex,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,tau=3652.41) #' fit #' plot(fit,col=c(1,1,2,2),xscale=365.241,xlab="Time (years)") #' #if no strata are desired: #' fit <- cmp.rel(Surv(time,cens)~1,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,tau=3652.41) #' #' #' cmp.rel <- function (formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, na.action,tau,conf.int=0.95,precision=1,add.times,rmap) #formula: for example Surv(time,cens)~1 #not implemented for subgroups - DO IT! #data: the observed data set #ratetable: the population mortality tables #conf.type: confidence interval calculation (plain, log or log-log) #conf.int: confidence interval #tau: max. cas do katerega racuna { call <- match.call() if (!missing(rmap)) { rmap <- substitute(rmap) } rform <- rformulate(formula, data, ratetable, na.action,rmap) #get the data ready data <- rform$data #the data set se.fac <- sqrt(qchisq(conf.int, 1)) #factor needed for confidence interval if(missing(tau)) tau<-max(rform$Y) p <- rform$m #number of covariates if (p > 0) #if covariates data$Xs <- strata(rform$X[, ,drop=FALSE ]) #make strata according to covariates else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 tab.strata <- table(data$Xs) #unique strata values ntab.strata <- length(tab.strata) #number of strata dtemp <- list(NULL) out <- as.list(rep(dtemp,ntab.strata*2)) for (kt in 1:ntab.strata) { #for each stratum inx <- which(data$Xs == names(tab.strata)[kt]) #individuals within this stratum extra <- as.numeric(seq(1,max(rform$Y[inx]),by=precision)) if(!missing(add.times)) extra <- c(extra,as.numeric(add.times)) tis <- sort(unique(pmin(tau,union(rform$Y[inx],extra))) ) #1-day long intervals used - to take into the account the continuity of the pop. part #if(!all.times)tis <- sort(unique(pmin(rform$Y[inx],tau))) #unique times #else{ # tis <- sort(union(rform$Y[inx], as.numeric(1:floor(max(rform$Y[inx]))))) #1-day long intervals used - to take into the account the continuity of the pop. part # tis <- unique(pmin(tis,tau)) #} k <- length(tis) out[[2*kt-1]]$time <- out[[2*kt]]$time <- c(0,tis) temp <- exp.prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis,fast=TRUE,cmp=T) #calculate the values for each interval of time areae <- sum(temp$areae)/365.241 # sum(diff(c(0,tis))*temp$cumince)/365.241 areap <- sum(temp$areap)/365.241 #sum(diff(c(0,tis))*temp$cumincp)/365.241 options(warn=-1) out[[2*kt-1]]$est <- c(0,temp$cumince) out[[2*kt-1]]$var <- c(0,temp$ve) out[[2*kt-1]]$lower <- temp$cumince-se.fac*sqrt(temp$ve) out[[2*kt-1]]$upper <- temp$cumince+se.fac*sqrt(temp$ve) out[[2*kt-1]]$area <- areae out[[2*kt]]$est <- c(0,temp$cumincp) out[[2*kt]]$var <- c(0,temp$vp) out[[2*kt]]$lower <- temp$cumincp-se.fac*sqrt(temp$vp) out[[2*kt]]$upper <- temp$cumincp+se.fac*sqrt(temp$vp) out[[2*kt]]$area <- areap options(warn=0) ne <- sum(temp$ve<0) if(ne>0) warning(paste(names(tab.strata)[kt],": The estimated variance of crude mortality is negative in ", ne, " out of ", length(temp$ve)," intervals"), call. = FALSE) if(!missing(add.times)){ out[[2*kt-1]]$index <- out[[2*kt]]$index <- unique(c(1,which(tis %in% c(rform$Y[inx],add.times,tau)))) out[[2*kt-1]]$add.times <- out[[2*kt]]$add.times <- add.times } else out[[2*kt-1]]$index <- out[[2*kt]]$index <- unique(c(1,which(tis %in% c(rform$Y[inx],tau)))) } if(p>0)names(out) <- paste(rep(c("causeSpec","population"),ntab.strata),rep(names(tab.strata),each=2)) else names(out) <- c("causeSpec","population") out$tau <- tau class(out) <- "cmp.rel" out } #' Plot the crude probability of death #' #' Plot method for cmp.rel. Plots the cumulative probability of death due to #' disease and due to population reasons #' #' By default, the graph is plotted as a step function for the cause specific #' mortality and as a piecewise linear function for the population mortality. #' It is evaluated at all event and censoring times even though it constantly #' changes also between these time points. #' #' If the argument \code{all.times} is set to \code{TRUE}, the plot is #' evaluated at all times that were used for numerical integration in the #' \code{cmp.rel} function (there, the default is set to daily intervals). If #' only specific time points are to be added, this should be done via argument #' \code{add.times} in \code{cmp.rel}. #' #' @param x a list, with each component representing one curve in the plot, #' output of the function \code{cmp.rel}. #' @param main the main title for the plot. #' @param curvlab Curve labels for the plot. Default is \code{names(x)}, or if #' that is missing, \code{1:nc}, where \code{nc} is the number of curves in #' \code{x}. #' @param ylim yaxis limits for plot. #' @param xlim xaxis limits for plot (default is 0 to the largest time in any #' of the curves). #' @param wh if a vector of length 2, then the upper right coordinates of the #' legend; otherwise the legend is placed in the upper right corner of the #' plot. #' @param xlab X axis label. #' @param ylab y axis label. #' @param lty vector of line types. Default \code{1:nc} (\code{nc} is the #' number of curves in \code{x}). For color displays, \code{lty=1}, #' \code{color=1:nc}, might be more appropriate. If \code{length(lty) 0) { i <- pmatch(names(u), names(formals(legend)), 0) do.call("legend", c(list(x = wh[1], y = wh[2], legend = curvlab[curves], col = col[curves], lty = lty[curves], lwd = lwd[curves], bty = "n", bg = -999999), u[i > 0])) } else { do.call("legend", list(x = wh[1], y = wh[2], legend = curvlab[curves], col = col[curves], lty = lty[curves], lwd = lwd[curves], bty = "n", bg = -999999)) } for(i in conf.int){ if(i%%2==0)with(x[[i]],polygon(c(time[index][!is.na(lower[index])],rev(time[index][!is.na(upper[index])]))/xscale,c(lower[index][!is.na(lower[index])],rev(upper[index][!is.na(upper[index])])),col = col.conf.int[i] , border = FALSE)) else with(x[[i]],my.poly(time[index][!is.na(lower[index])]/xscale,time[index][!is.na(upper[index])]/xscale,lower[index][!is.na(lower[index])],upper[index][!is.na(upper[index])],col = col.conf.int[i] , border = FALSE)) } for (i in curves) { tip <- "s" if(i%%2==0)tip <- "l" lines((x[[i]][[1]]/xscale)[x[[i]]$index], (x[[i]][[2]])[x[[i]]$index], lty = lty[i], col = col[i], lwd = lwd[i], type=tip, ...) } } my.poly <- function(x1,x2,y1,y2,...){ x1 <- rep(x1,each=2)[-1] y1 <- rep(y1,each=2)[-(2*length(y1))] x2 <- rep(x2,each=2)[-1] y2 <- rep(y2,each=2)[-(2*length(y2))] polygon(c(x1,rev(x2)),c(y1,rev(y2)),...) } print.cmp.rel <- function (x, ntp = 4, maxtime,scale=365.241, ...) { tau <- x$tau x$tau <- NULL nc <- length(x) if (missing(maxtime)) { maxtime <- 0 for (i in 1:nc) maxtime <- max(maxtime, x[[i]]$time) } tp <- pretty(c(0, maxtime/scale), ntp + 1) tp <- tp[-c(1, length(tp))] if(length(x[[1]]$add.times)>0 & length(x[[1]]$add.times)<5){ tp <- sort(unique(c(tp,round(x[[1]]$add.times/scale,1)))) } cat("Estimates, variances and area under the curves:\n") x$tau <- tau print(summary(x, tp,scale,area=TRUE), ...) invisible() } #' Summary of the crude probability of death #' #' Returns a list containing the estimated values at required times. #' #' The variance is calculated using numerical integration. If the required time #' is not a time at which the value was estimated, the value at the last time #' before it is reported. The density of the time points is set by the #' \code{precision} argument in the \code{cmp.rel} function. #' #' @param object output of the function \code{cmp.rel}. #' @param times the times at which the output is required. #' @param scale The time scale in which the times are specified. The default #' value is \code{1}, i.e. days. #' @param area Should area under the curves at time \code{tau} be printed out? #' Default is \code{FALSE}. #' @param ... Additional arguments, currently not implemented #' @return A list of values is returned. #' @seealso \code{cmp.rel} #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #calculate the crude probability of death and summarize it #' fit <- cmp.rel(Surv(time,cens)~sex,rmap=list(age=age*365), #' ratetable=slopop,data=rdata,tau=3652.41) #' summary(fit,c(1,3),scale=365.241) #' summary.cmp.rel <- function (object, times,scale=365.241,area=FALSE,...) { tau <- object$tau object$tau <- NULL ng <- length(object) times <- sort(unique(times))*scale nt <- length(times) storage.mode(times) <- "double" storage.mode(nt) <- "integer" ind <- matrix(0, ncol = nt, nrow = ng) oute <- matrix(NA, ncol = nt, nrow = ng) outv <- oute outa <- matrix(NA,ncol=1,nrow=ng) storage.mode(ind) <- "integer" slct <- rep(TRUE, ng) for (i in 1:ng) { if (is.null((object[[i]])$est)) { slct[i] <- FALSE } else { z <- rep(NA,nt) for(kt in 1:nt)z[kt] <- rev(which(object[[i]][[1]]<=times[kt]))[1] ind[i, ] <- z oute[i, ind[i, ] > 0] <- object[[i]][[2]][z] outa[i,] <- object[[i]][[6]] if (length(object[[i]]) > 2) outv[i, ind[i, ] > 0] <- object[[i]][[3]][z] } } dimnames(oute) <- list(names(object)[1:ng], as.character(times/scale)) dimnames(outv) <- dimnames(oute) rownames(outa) <- rownames(oute) colnames(outa) <- paste("Area at tau =",tau/scale) if(area)list(est = oute[slct, , drop = FALSE], var = outv[slct, , drop = FALSE], area=outa[slct,,drop=FALSE]) else list(est = oute[slct, , drop = FALSE], var = outv[slct, , drop = FALSE]) } relsurv/R/mystrata.r0000644000176200001440000000607412531603441014212 0ustar liggesusersmy.strata <- function (..., nameslist, sep = ", ") { #nameslist = lista imen spremenljivk words <- as.character((match.call())[-1]) #ime podatkov allf <- list(...) #podatki if (length(allf) == 1 && is.list(ttt <- unclass(allf[[1]]))) #so samo eni podatki allf <- ttt #ohranim le podatke (ne listo podatkov), v obliki list nterms <- length(allf) #nterms= st. spremenljivk +1 (row.names) if (is.null(names(allf))) #ce ni imen argname <- words[1:nterms] #jih dam else argname <- ifelse(names(allf) == "", words[1:nterms], #ce so prazna jih dam names(allf)) #imena so v argname varnames <- names(nameslist) #1. iteracija what <- allf[[1]] #prva spremenljivka for(it in 1:length(varnames)){ if (length(grep(varnames[it],names(allf)[[1]]))) break #poiscem ji mesto v svojem poimenovanju } if (is.null(levels(what))) what <- factor(what) #ce se ni, jo prisilimo v faktorsko levs <- unclass(what) - 1 #nastavim prvi level = 0 wlab <- levels(what) #imena faktorjev labs <- paste(argname[1], wlab, sep = "=") #prvo ime = 0/1 labsnow <- 1 allab <- NULL dd <- length(nameslist[[it]]) if(dd!=2) { mylabs <- rep(argname[1],length(wlab)) mylabs[wlab==0] <- "" } else mylabs <- labs for (i in (1:nterms)[-1]) { if(length(grep(varnames[labsnow],names(allf)[[i]]))==0){ #ce je zdaj to nova spremenljivka, moram najprej ustimat prejsnjo mylabs[mylabs==""] <- nameslist[[labsnow]][1] if(!any(allab!=""))allab <- paste(allab,mylabs,sep="") #the first time - do not separate by comma else allab <- paste(allab,mylabs,sep=",") mylabs <- rep("",length(mylabs)) labsnow <- labsnow+1 } what <- allf[[i]] if (is.null(levels(what))) what <- factor(what) wlev <- unclass(what) - 1 wlab <- levels(what) labsnew <- format(paste(argname[i], wlab, sep = "=")) levs <- wlev + levs * (length(wlab)) a <- rep(labs, rep(length(wlab), length(labs))) b <- rep(wlab, length(labs)) mya <- rep(mylabs, rep(length(wlab), length(labs))) allab <- rep(allab,rep(length(wlab), length(labs))) myb <- rep(argname[i],length(labs)*length(wlab)) for(it in 1:length(varnames)){ #it se ustavi pri trenutni spremenljivki if (length(grep(varnames[it],names(allf)[[i]]))) break } dd <- length(nameslist[[it]]) if(dd==2)myb <- paste(myb,rep(wlab,length(labs)),sep="=") else myb[rep(wlab,length(labs))==0] <- "" mylabs <- paste(mya,myb,sep="") labs <- paste(a,b, sep = sep) } mylabs[mylabs==""] <- nameslist[[labsnow]][1] if(!any(allab!=""))allab <- paste(allab,mylabs,sep="") else allab <- paste(allab,mylabs,sep=",") levs <- levs + 1 ulevs <- sort(unique(levs[!is.na(levs)])) levs <- match(levs, ulevs) labs <- labs[ulevs] allab <- allab[ulevs] factor(levs, labels = allab) } relsurv/R/Rcode.r0000644000176200001440000044202214070550360013400 0ustar liggesusersrsfitterem<-function(data,b,maxiter,ratetable,tol,bwin,p,cause,Nie){ pr.time<-proc.time()[3] if (maxiter<1) stop("There must be at least one iteration run") n<-nrow(data) m <- p dtimes <- which(data$stat==1) #the positions of event times in data$Y td <- data$Y[dtimes] #event times ntd <- length(td) #number of event times utimes <- which(c(1,diff(td))!=0) #the positions of unique event times among td utd <- td[utimes] #unique event times nutd <- length(utd) #number of unique event times udtimes <- dtimes[utimes] #the positions of unique event times among data$Y razteg <- function(x){ # x is a 0/1 vector, the output is a vector of length sum(x), with the corresponding rep numbers n <- length(x) repu <- rep(1,n) repu[x==1] <- 0 repu <- rev(cumsum(rev(repu))) repu <- repu[x==1] repu <- -diff(c(repu,0))+1 if(sum(repu)!=n)repu <- c(n-sum(repu),repu) #ce je prvi cas censoring, bo treba se kej narest?? repu } rutd <- rep(0,ntd) rutd[utimes] <- 1 rutd <- razteg(rutd) #from unique event times to event times rtd <- razteg(data$stat) #from event times to data$Y a <- data$a[data$stat==1] if(bwin[1]!=0){ #the vector of change points for the smoothing bandwidth nt4 <- c(1,ceiling(c(nutd*.25,nutd/2,nutd*.75,nutd))) if(missing(bwin))bwin <- rep(1,4) else bwin <- rep(bwin,4) for(it in 1:4){ bwin[it] <- bwin[it]*max(diff(utd[nt4[it]:nt4[it+1]])) } while(utd[nt4[2]]0){ whtemp <- data$stat==1&cause==2 dataded <- data[data$stat==1&cause==2,] #events with unknown cause datacens <- data[data$stat==0|cause<2,] #censorings or known cause datacens$cause <- cause[data$stat==0|cause<2]*data$stat[data$stat==0|cause<2] databig <- lapply(dataded, rep, 2) databig <- do.call("data.frame", databig) databig$cause <- rep(2,nrow(databig)) nded <- nrow(databig) databig$cens <- c(rep(1,nded/2),rep(0,nded/2)) datacens$cens <- rep(0,nrow(datacens)) datacens$cens[datacens$cause<2] <- datacens$cause[datacens$cause<2] names(datacens) <- names(databig) databig <- rbind(databig,datacens) cause <- cause[data$stat==1] #NEW IN 2.05 (next 4 lines) fk <- (attributes(ratetable)$factor != 1) nfk <- length(fk) varstart <- 3+nfk+1 #first column of covariates varstop <- 3+nfk+m #last column of covariates #model matrix for relative survival xmat <- as.matrix(data[,varstart:varstop]) #NEW IN 2.05 #ebx at initial values of b ebx <- as.vector(exp(xmat%*%b)) #model matrix for coxph modmat <- as.matrix(databig[,varstart:varstop]) #NEW IN 2.05 varnames <- names(data)[varstart:varstop] #NEW IN 2.05 } else{ cause <- cause[data$stat==1] ebx <- rep(1,n) } #for time-dependent data: starter <- sort(data$start) starter1<-c(starter[1],starter[-length(starter)]) #the values of interest in the cumsums of the obsolete values (there is at least one value - the 1st) index <- c(TRUE,(starter!=starter1)[-1]) starter <- starter[index] #the number of repetitions in each cumsum difference - needed for s0 calculation val1 <- apply(matrix(starter,ncol=1),1,function(x,Y)sum(x>=Y),data$Y) val1 <- c(val1[1],diff(val1),length(data$Y)-val1[length(val1)]) eb <- ebx[data$stat==1] s0 <- cumsum((ebx)[n:1])[n:1] ebx.st <- ebx[order(data$start)] s0.st <- ((cumsum(ebx.st[n:1]))[n:1])[index] s0.st <- rep(c(s0.st,0),val1) s0 <- s0 - s0.st #s0 only at times utd s0 <- s0[udtimes] #find the corresponding value of Y for each start!=0 - needed for likelihood calculation start <- data$start if(any(start!=0)){ wstart <- rep(NA,n) ustart <- unique(start[start!=0]) for(its in ustart){ wstart[start==its] <- min(which(data$Y==its)) } } #tale del je zelo sumljiv - kako se racuna likelihood za ties??? difft <- c(data$Y[data$stat==1][1],diff(td)) difft <- difftu <- difft[difft!=0] difft <- rep(difft,rutd) a0 <- a*difft if(sum(Nie==.5)!=0)maxit0 <- maxiter else maxit0<- maxiter - 3 for(i in 1:maxit0){ #Nie is of length ntd, should be nutd, with the values at times being the sum nietemp <- rep(1:nutd,rutd) Nies <- as.vector(by(Nie,nietemp,sum)) #shorter Nie - only at times utd lam0u <- lam0 <- Nies/s0 #the smooting of lam0 if(bwin[1]!=0)lam0s <- krn%*%lam0 else lam0s <- lam0/difftu #extended to all event times lam0s <- rep(lam0s,rutd) #compute Nie, only for those with unknown hazard Nie[cause==2] <- as.vector(lam0s*eb/(a+lam0s*eb))[cause==2] } if(maxit0!=maxiter & i==maxit0) i <- maxiter #likelihood calculation - manjka ti se likelihood za nicelni model!!! #the cumulative hazard Lam0 <- cumsum(lam0) #extended to all event times Lam0 <- rep(Lam0,rutd) if(data$stat[1]==0) Lam0 <- c(0,Lam0) #extended to all exit times Lam0 <- rep(Lam0,rtd) #for time dependent covariates: replace by the difference if(any(start!=0))Lam0[start!=0] <- Lam0[start!=0] - Lam0[wstart[start!=0]] lam0 <- rep(lam0,rutd) likely0 <- sum(log(a0 + lam0*eb)) - sum(data$ds + Lam0*ebx) likely <- likely0 tempind <- Nie<=0|Nie>=1 if(any(tempind)){ if(any(Nie<=0))Nie[Nie<=0] <- tol if(any(Nie>=1))Nie[Nie>=1] <- 1-tol } if(p>0)databig$wei <- c(Nie[cause==2],1-Nie[cause==2],rep(1,nrow(datacens))) if(maxiter>=1&p!=0){ for(i in 1:maxiter){ if(p>0){ b00<-b if(i==1)fit <- coxph(Surv(start,Y,cens)~modmat,data=databig,weights=databig$wei,init=b00,x=TRUE,iter.max=maxiter) else fit <- coxph(Surv(start,Y,cens)~modmat,data=databig,weights=databig$wei,x=TRUE,iter.max=maxiter) if(any(is.na(fit$coeff))) stop("X matrix deemed to be singular, variable ",which(is.na(fit$coeff))) b <- fit$coeff ebx <- as.vector(exp(xmat%*%b)) } else ebx <- rep(1,n) eb <- ebx[data$stat==1] s0 <- cumsum((ebx)[n:1])[n:1] ebx.st <- ebx[order(data$start)] s0.st <- ((cumsum(ebx.st[n:1]))[n:1])[index] s0.st <- rep(c(s0.st,0),val1) s0 <- s0 - s0.st #Nie is of length ntd, should be nutd, with the values at times being the sum nietemp <- rep(1:nutd,rutd) Nies <- as.vector(by(Nie,nietemp,sum)) #shorter Nie - only at times utd #s0 only at times utd s0 <- s0[udtimes] lam0u <- lam0 <- Nies/s0 #the cumulative hazard Lam0 <- cumsum(lam0) #extended to all event times Lam0 <- rep(Lam0,rutd) if(data$stat[1]==0) Lam0 <- c(0,Lam0) #extended to all exit times Lam0 <- rep(Lam0,rtd) #for time dependent covariates: replace by the difference if(any(start!=0))Lam0[start!=0] <- Lam0[start!=0] - Lam0[wstart[start!=0]] #the smooting of lam0 if(bwin[1]!=0)lam0s <- krn%*%lam0 else lam0s <- lam0/difft #extended to all event times lam0s <- rep(lam0s,rutd) #compute Nie, only for those with unknown hazard Nie[cause==2] <- as.vector(lam0s*eb/(a+lam0s*eb))[cause==2] #likelihood calculation - manjka ti se likelihood za nicelni model!!! lam0 <- rep(lam0,rutd) likely <- sum(log(a0 + lam0*eb)) - sum(data$ds + Lam0*ebx) if(p>0){ tempind <- Nie<=0|Nie>=1 if(any(tempind)){ if(any(Nie<=0))Nie[Nie<=0] <- tol if(any(Nie>=1))Nie[Nie>=1] <- 1-tol #if(which(tempind)!=nev)warning("Weights smaller than 0") #if(any(is.na( match(which(tempind),c(1,nev)) )))browser() } if(nded==0) break() databig$wei[1:nded] <- c(Nie[cause==2],1-Nie[cause==2]) bd <- abs(b-b00) if(max(bd)< tol) break() } #early stopping time for no covariates??? } } iter <- i #if (maxiter > 1& iter>=maxiter) # warning("Ran out of iterations and did not converge") if(p>0){ if(nded!=0){ resi <- resid(fit,type="schoenfeld") if(!is.null(dim(resi)))resi <- resi[1:(nded/2),] else resi <- resi[1:(nded/2)] swei <- fit$weights[1:(nded/2)] if(is.null(dim(resi))) fishem <- sum((resi^2*swei*(1-swei))) else { fishem <- apply(resi,1,function(x)outer(x,x)) fishem <- t(t(fishem)*swei*(1-swei)) fishem <- matrix(apply(fishem,1,sum),ncol=m) } } else fishem <- 0 fishcox <- solve(fit$var) fisher <- fishcox - fishem fit$var <- solve(fisher) names(fit$coefficients)<-varnames fit$lambda0 <- lam0s } else fit <- list(lambda0 = lam0s) fit$lambda0 <- fit$lambda0[utimes] fit$Lambda0 <- Lam0[udtimes] fit$times <- utd fit$Nie <- Nie fit$bwin <- bwin fit$iter <- i class(fit) <- c("rsadd",class(fit)) fit$loglik <- c(likely0,likely) fit$lam0.ns <- lam0u fit } em <- function (rform, init, control, bwin) { data <- rform$data n <- nrow(data) p <- rform$m id <- order(data$Y) rform$cause <- rform$cause[id] data <- data[id, ] fk <- (attributes(rform$ratetable)$factor != 1) nfk <- length(fk) nev <- length(data$Y[data$stat == 1]) data$a <- rep(NA, n) xx <- exp.prep(data[, 4:(nfk + 3),drop=FALSE], data$Y - data$start, rform$ratetable) data$ds <- -log(xx) data1 <- data data1[, 4:(nfk + 3)] <- data[, 4:(nfk + 3)] + data$Y %*% t(fk) xx <- exp.prep(data1[data1$stat == 1, 4:(nfk + 3),drop=FALSE], 1, rform$ratetable) data$a[data$stat == 1] <- -log(xx) if (p > 0) { if (!missing(init) && !is.null(init)) { if (length(init) != p) stop("Wrong length for inital values") } else init <- rep(0, p) beta <- matrix(init, p, 1) } pr.time<-proc.time()[3] Nie <- rep(.5,sum(data$stat==1)) Nie[rform$cause[data$stat==1]<2] <- rform$cause[data$stat==1][rform$cause[data$stat==1]<2] #NEW IN 2.05 varstart <- 3+nfk+1 #first column of covariates varstop <- 3+nfk+p #last column of covariates if(missing(bwin))bwin <- -1 if(bwin<0){ if(p>0)data1 <- data[,-c(varstart:varstop)] #NEW IN 2.05 else data1 <- data nfk <- length(attributes(rform$ratetable)$dimid) names(data)[4:(3+nfk)] <- attributes(rform$ratetable)$dimid expe <- rs.surv(Surv(Y,stat)~1,data,ratetable=rform$ratetable,method="ederer2") esurv <- -log(expe$surv[expe$n.event!=0]) if(esurv[length(esurv)]==Inf)esurv[length(esurv)] <- esurv[length(esurv)-1] x <- seq(.1,3,length=5) dif <- rep(NA,5) options(warn=-1) diter <- max(round(max(data$Y)/356.24),3) for(it in 1:5){ fit <- rsfitterem(data1,NULL,diter,rform$ratetable,control$epsilon,x[it],0,rform$cause,Nie) dif[it] <- sum((esurv-fit$Lambda0)^2) } wh <- which.min(dif) if(wh==1)x <- seq(x[wh],x[wh+1]-.1,length=5) else if(wh==5)x <- c(x, max(data$Y)/ max(diff(data$Y))) if(wh!=1) x <- seq(x[wh-1]+.1,x[wh+1]-.1,length=5) dif <- rep(NA,5) for(it in 1:5){ fit <- rsfitterem(data1,NULL,diter,rform$ratetable,control$epsilon,x[it],0,rform$cause,Nie) dif[it] <- sum((esurv-fit$Lambda0)^2) } options(warn=0) Nie <- fit$Nie bwin <- x[which.min(dif)] } fit <- rsfitterem(data, beta, control$maxit, rform$ratetable, control$epsilon, bwin, p, rform$cause,Nie) Nie <- rep(0,nrow(data)) Nie[data$stat==1] <- fit$Nie fit$Nie <- Nie[order(id)] fit$bwin <- list(bwin=fit$bwin,bwinfac=bwin) fit } #' Fit an Additive model for Relative Survival #' #' The function fits an additive model to the data. The methods implemented are #' the maximum likelihood method, the semiparametric method, a glm model with a #' \code{binomial} error and a glm model with a \code{poisson} error. #' #' NOTE: The follow-up time must be specified in days. The \code{ratetable} #' being used may have different variable names and formats than the user's #' data set, this is dealt with by the \code{rmap} argument. For example, if #' age is in years in the data set but in days in the \code{ratetable} object, #' age=age*365.241 should be used. The calendar year can be in any date format #' (date, Date and POSIXt are allowed), the date formats in the #' \code{ratetable} and in the data may differ. #' #' The maximum likelihood method and both glm methods assume a fully parametric #' model with a piecewise constant baseline excess hazard function. The #' intervals on which the baseline is assumed constant should be passed via #' argument \code{int}. The EM method is semiparametric, i.e. no assumptions #' are made for the baseline hazard and therefore no intervals need to be #' specified. #' #' The methods using glm are methods for grouped data. The groups are formed #' according to the covariate values. This should be taken into account when #' fitting a model. The glm method returns life tables for groups specified by #' the covariates in \code{groups}. #' #' The EM method output includes the smoothed baseline excess hazard #' \code{lambda0}, the cumulative baseline excess hazard \code{Lambda0} and #' \code{times} at which they are estimated. The individual probabilites of #' dying due to the excess risk are returned as \code{Nie}. The EM method #' fitting procedure requires some local smoothing of the baseline excess #' hazard. The default \code{bwin=-1} value lets the function find an #' appropriate value for the smoothing band width. While this ensures an #' unbiased estimate, the procedure time is much longer. As the value found by #' the function is independent of the covariates in the model, the value can be #' read from the output (\code{bwinfac}) and used for refitting different #' models to the same data to save time. #' #' @param formula a formula object, with the response as a \code{Surv} object #' on the left of a \code{~} operator, and, if desired, terms separated by the #' \code{+} operator on the right. #' #' NOTE: The follow-up time must be in days. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param ratetable a table of event rates, organized as a \code{ratetable} #' object, such as \code{slopop}. #' @param int either a single value denoting the number of follow-up years or a #' vector specifying the intervals (in years) in which the hazard is constant #' (the times that are bigger than \code{max(int)} are censored. If missing, #' only one interval (from time 0 to maximum observation time) is assumed. The #' EM method does not need the intervals, only the maximum time can be #' specified (all times are censored after this time point). #' @param na.action a missing-data filter function, applied to the model.frame, #' after any subset argument has been used. Default is #' \code{options()$na.action}. #' @param method \code{glm.bin} or \code{glm.poi} for a glm model, \code{EM} #' for the EM algorithm and \code{max.lik} for the maximum likelihood model #' (default). #' @param init vector of initial values of the iteration. Default initial #' value is zero for all variables. #' @param bwin controls the bandwidth used for smoothing in the EM algorithm. #' The follow-up time is divided into quartiles and \code{bwin} specifies a #' factor by which the maximum between events time length on each interval is #' multiplied. The default \code{bwin=-1} lets the function find an appropriate #' value. If \code{bwin=0}, no smoothing is applied. #' @param centered if \code{TRUE}, all the variables are centered before #' fitting and the baseline excess hazard is calculated accordingly. Default is #' \code{FALSE}. #' @param cause A vector of the same length as the number of cases. \code{0} #' for population deaths, \code{1} for disease specific deaths, \code{2} #' (default) for unknown. Can only be used with the \code{EM} method. #' @param control a list of parameters for controlling the fitting process. #' See the documentation for \code{glm.control} for details. #' @param rmap an optional list to be used if the variables are not organized #' and named in the same way as in the \code{ratetable} object. See details #' below. #' @param ... other arguments will be passed to \code{glm.control}. #' @return An object of class \code{rsadd}. In the case of #' \code{method="glm.bin"} and \code{method="glm.poi"} the class also inherits #' from \code{glm} which inherits from the class \code{lm}. Objects of this #' class have methods for the functions \code{print} and \code{summary}. An #' object of class \code{rsadd} is a list containing at least the following #' components: \item{data}{the data as used in the model, along with the #' variables defined in the rate table} \item{ratetable}{the ratetable used.} #' \item{int}{the maximum time (in years) used. All the events at and after #' this value are censored.} \item{method}{the fitting method that was used.} #' \item{linear.predictors}{the vector of linear predictors, one per subject.} #' @seealso \code{\link{rstrans}}, \code{\link{rsmul}} #' @references Package. Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' #' EM algorithm: Pohar Perme M., Henderson R., Stare, J. (2009) "An approach to #' estimation in relative survival regression." Biostatistics, \bold{10}: #' 136--146. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #fit an additive model #' #note that the variable year is given in days since 01.01.1960 and that #' #age must be multiplied by 365.241 in order to be expressed in days. #' fit <- rsadd(Surv(time,cens)~sex+as.factor(agegr)+ratetable(age=age*365.241), #' ratetable=slopop,data=rdata,int=5) #' #' #check the goodness of fit #' rs.br(fit) #' #' #use the EM method and plot the smoothed baseline excess hazard #' fit <- rsadd(Surv(time,cens)~sex+age,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,int=5,method="EM") #' sm <- epa(fit) #' plot(sm$times,sm$lambda,type="l") #' rsadd <- function (formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, int, na.action, method = "max.lik", init, bwin, centered = FALSE, cause, control, rmap, ...) { call <- match.call() if (missing(control)) control <- glm.control(...) if(!missing(cause)){ #NEW: ce cause ne manjka, ga preverim in dodam kot spremenljivko if (length(cause) != nrow(data)) stop("Length of cause does not match data dimensions") data$cause <- cause rform <- rformulate(formula, data, ratetable, na.action, int, centered, cause) } else{ #no cause if (!missing(rmap)) { rmap <- substitute(rmap) #rform <- rformulate(formula,data, ratetable, na.action, rmap,int, centered) #get the data ready } #else rform <- rformulate(formula,data, ratetable, na.action, rmap, int, centered) } if (method == "EM") { if (!missing(int)) { if (length(int) > 1 | any(int <= 0)) stop("Invalid value of 'int'") } } else { if (missing(int)) int <- c(0,ceiling(max(rform$Y/365.241))) if (length(int) == 1) { if (int <= 0) stop("The value of 'int' must be positive ") int <- 0:int } else if (int[1] != 0) stop("The first interval in 'int' must start with 0") } method <- match.arg(method,c("glm.bin","glm.poi","max.lik","EM")) if (method == "glm.bin" | method == "glm.poi") fit <- glmxp(rform = rform, interval = int, method = method, control = control) else if (method == "max.lik") fit <- maxlik(rform = rform, interval = int, init = init, control = control) else if (method == "EM") fit <- em(rform, init, control, bwin) fit$call <- call fit$formula <- formula fit$data <- rform$data fit$ratetable <- rform$ratetable fit$n <- nrow(rform$data) if (length(rform$na.action)) fit$na.action <- rform$na.action fit$y <- rform$Y.surv fit$method <- method if (method == "EM") { if (!missing(int)) fit$int <- int else fit$int <- ceiling(max(rform$Y[rform$status == 1])/365.241) fit$terms <- rform$Terms if(centered)fit$mvalue <- rform$mvalue } if (method == "max.lik") { fit$terms <- rform$Terms } if (rform$m > 0) fit$linear.predictors <- as.matrix(rform$X) %*% fit$coef[1:ncol(rform$X)] fit } maxlik <- function (rform, interval, subset, init, control) { data <- rform$data max.time <- max(data$Y)/365.241 if (max.time < max(interval)) interval <- interval[1:(sum(max.time > interval) + 1)] fk <- (attributes(rform$ratetable)$factor != 1) nfk <- length(fk) data <- cbind(data, offset = rform$offset) data <- survsplit(data, cut = interval[-1] * 365.241, end = "Y", event = "stat", start = "start", episode = "epi", interval = interval) del <- which(data$start==data$Y) if(length(del)) data <- data[-del,] offset <- data$offset data$offset <- NULL d.int <- diff(interval) data[, 4:(nfk + 3)] <- data[, 4:(nfk + 3)] + data$start %*% t(fk) data$lambda <- rep(0, nrow(data)) nsk <- nrow(data[data$stat == 1, ]) xx <- exp.prep(data[data$stat == 1, 4:(nfk + 3),drop=FALSE] + (data[data$stat == 1, ]$Y - data[data$stat == 1, ]$start) %*% t(fk), 1, rform$ratetable) data$lambda[data$stat == 1] <- -log(xx) * 365.241 xx <- exp.prep(data[, 4:(nfk + 3),drop=FALSE], data$Y - data$start, rform$ratetable) data$epi <- NULL data$ds <- -log(xx) data$Y <- data$Y/365.241 data$start <- data$start/365.241 data <- data[, -(4:(3 + nfk))] intn <- length(interval[-1]) m <- rform$m p <- m + intn if (!missing(init) && !is.null(init)) { if (length(init) != p) stop("Wrong length for inital values") } else init <- rep(0, p) if(m>0){ init0 <- init[-(1:m)] data1 <- data[,-(4:(3+m))] } else{ init0 <- init data1 <- data } fit0 <- lik.fit(data1, 0, intn, init0, control, offset) if(m>0){ init[-(1:m)] <- fit0$coef fit <- lik.fit(data, m, intn, init, control, offset) } else fit <- fit0 fit$int <- interval class(fit) <- "rsadd" fit$times <- fit$int*365.241 #dodano za potrebe rs.surv.rsadd fit$Lambda0 <- cumsum(c(0, exp(fit$coef[(m+1):p])*diff(fit$int) )) fit } lik.fit <- function (data, m, intn, init, control, offset) { n <- dim(data)[1] varpos <- 4:(3 + m + intn) x <- data[, varpos] varnames <- names(data)[varpos] lbs <- names(x) x <- as.matrix(x) p <- length(varpos) d <- data$stat ds <- data$ds h <- data$lambda y <- data$Y - data$start maxiter <- control$maxit if (!missing(init) && !is.null(init)) { if (length(init) != p) stop("Wrong length for inital values") } else init <- rep(0, p) b <- matrix(init, p, 1) b0 <- b fit <- mlfit(b, p, x, offset, d, h, ds, y, maxiter, control$epsilon) if (maxiter > 1 & fit$nit >= maxiter) { values <- apply(data[data$stat==1,varpos,drop=FALSE],2,sum) #NEW: deluje tudi, ce je ratetable eno-dimenzionalen problem <- which.min(values) outmes <- "Ran out of iterations and did not converge" if(values[problem]==0)tzero <- "" else tzero <- "only " if(values[problem]<5){ if(!is.na(strsplit(names(values)[problem],"fu")[[1]][2]))outmes <- paste(outmes, "\n This may be due to the fact that there are ",tzero, values[problem], " events on interval",strsplit(names(values)[problem],"fu")[[1]][2],"\n You can use the 'int' argument to change the follow-up intervals in which the baseline excess hazard is assumed constant",sep="") else outmes <- paste(outmes, "\n This may be due to the fact that there are ",tzero, values[problem], " events for covariate value ",names(values)[problem],sep="") } warning(outmes) } b <- as.vector(fit$b) names(b) <- varnames fit <- list(coefficients = b, var = -solve(fit$sd), iter = fit$nit, loglik = fit$loglik) fit } #' Split a Survival Data Set at Specified Times #' #' Given a survival data set and a set of specified cut times, the function #' splits each record into multiple records at each cut time. The new data set #' is be in \code{counting process} format, with a start time, stop time, and #' event status for each record. More general than \code{survSplit} as it also #' works with the data already in the \code{counting process} format. #' #' #' @param data data frame. #' @param cut vector of timepoints to cut at. #' @param end character string with name of event time variable. #' @param event character string with name of censoring indicator. #' @param start character string with name of start variable (will be created #' if it does not exist). #' @param id character string with name of new id variable to create #' (optional). #' @param zero If \code{start} doesn't already exist, this is the time that the #' original records start. May be a vector or single value. #' @param episode character string with name of new episode variable #' (optional). #' @param interval this argument is used by \code{max.lik} function #' @return New, longer, data frame. #' @seealso \code{\link{survSplit}}. #' @keywords survival survsplit <- function (data, cut, end, event, start, id = NULL, zero = 0, episode = NULL, interval = NULL) { ntimes <- length(cut) n <- nrow(data) p <- ncol(data) if (length(interval) > 0) { ntimes <- ntimes - 1 sttime <- c(rep(0, n), rep(cut[-length(cut)], each = n)) endtime <- rep(cut, each = n) } else { endtime <- rep(c(cut, Inf), each = n) sttime <- c(rep(0, n), rep(cut, each = n)) } newdata <- lapply(data, rep, ntimes + 1) eventtime <- newdata[[end]] if (start %in% names(data)) starttime <- newdata[[start]] else starttime <- rep(zero, length = (ntimes + 1) * n) starttime <- pmax(sttime, starttime) epi <- rep(0:ntimes, each = n) if (length(interval) > 0) status <- ifelse(eventtime <= endtime & eventtime >= starttime, newdata[[event]], 0) else status <- ifelse(eventtime <= endtime & eventtime > starttime, newdata[[event]], 0) endtime <- pmin(endtime, eventtime) if (length(interval) > 0) drop <- (starttime > endtime) | (starttime == endtime & status == 0) else drop <- starttime >= endtime newdata <- do.call("data.frame", newdata) newdata <- newdata[!drop, ] newdata[, start] <- starttime[!drop] newdata[, end] <- endtime[!drop] newdata[, event] <- status[!drop] if (!is.null(id)) newdata[, id] <- rep(rownames(data), ntimes + 1)[!drop] fu <- NULL if (length(interval) > 2) { for (it in 1:length(interval[-1])) { drop1 <- sum(!drop[1:(it * n - n)]) drop2 <- sum(!drop[(it * n - n + 1):(it * n)]) drop3 <- sum(!drop[(it * n + 1):(length(interval[-1]) * n)]) if (it == 1) fu <- cbind(fu, c(rep(1, drop2), rep(0, drop3))) else if (it == length(interval[-1])) fu <- cbind(fu, c(rep(0, drop1), rep(1, drop2))) else fu <- cbind(fu, c(rep(0, drop1), rep(1, drop2), rep(0, drop3))) } fu <- as.data.frame(fu) names(fu) <- c(paste("fu [", interval[-length(interval)], ",", interval[-1], ")", sep = "")) newdata <- cbind(newdata, fu) } else if (length(interval) == 2) { fu <- rep(1, sum(!drop)) newdata <- cbind(newdata, fu) names(newdata)[ncol(newdata)] <- paste("fu [", interval[1], ",", interval[2], "]", sep = "") } if (!is.null(episode)) newdata[, episode] <- epi[!drop] newdata } glmxp <- function (rform, data, interval, method, control) { if (rform$m == 1) g <- as.integer(as.factor(rform$X[[1]])) else if (rform$m > 1) { gvar <- NULL for (i in 1:rform$m) { gvar <- append(gvar, rform$X[i]) } tabgr <- as.data.frame(table(gvar)) tabgr <- tabgr[, 1:rform$m] n.groups <- dim(tabgr)[1] mat <- do.call("data.frame", gvar) names(mat) <- names(tabgr) tabgr <- cbind(tabgr, g = as.numeric(row.names(tabgr))) mat <- cbind(mat, id = 1:rform$n) c <- merge(tabgr, mat) g <- c[order(c$id), rform$m + 1] } else g <- rep(1, rform$n) vg <- function(X) { n <- dim(X)[1] w <- sum((X$event == 0) & (X$fin == 1) & (X$y != 1)) nd <- sum((X$event == 1) & (X$fin == 1)) ps <- exp.prep(X[, 4:(nfk + 3),drop=FALSE], t.int, rform$ratetable) ld <- n - w/2 lny <- log(sum(X$y)) k <- t.int/365.241 dstar <- sum(-log(ps)/k * X$y) ps <- mean(ps) if (rform$m == 0) data.rest <- X[1, 7 + nfk + rform$m, drop = FALSE] else data.rest <- X[1, c((3 + nfk + 1):(3 + nfk + rform$m), 7 + nfk + rform$m)] cbind(nd = nd, ld = ld, ps = ps, lny = lny, dstar = dstar, k = k, data.rest) } nint <- length(interval) if (nint < 2) stop("Illegal interval value") meje <- interval my.fun <- function(x) { if (x > 1) { x.t <- rep(1, floor(x)) if (x - floor(x) > 0) x.t <- c(x.t, x - floor(x)) x.t } else x } int <- apply(matrix(diff(interval), ncol = 1), 1, my.fun) if (is.list(int)) int <- c(0, cumsum(do.call("c", int))) else int <- c(0, cumsum(int)) int <- int * 365.241 nint <- length(int) X <- cbind(rform$data, grupa = g) fk <- (attributes(rform$ratetable)$factor != 1) nfk <- length(fk) Z <- X[X$start >= int[2], ] nz <- dim(Z)[1] Z$fin <- rep(0, nz) Z$event <- rep(0, nz) Z$fu <- rep(0, nz) Z$y <- rep(0, nz) Z$origstart <- Z$start Z$xind <- rep(0, nz) if (nrow(Z) > 0) Z[, 4:(nfk + 3)] <- Z[, 4:(nfk + 3)] + matrix(Z$start, ncol = nfk, byrow = FALSE, nrow = nrow(Z)) * matrix(fk, ncol = nfk, byrow = TRUE, nrow = nrow(Z)) X <- X[X$start < int[2], ] X$fin <- (X$Y <= int[2]) X$event <- X$fin * X$stat ford <- eval(substitute(paste("[", a, ",", b, "]", sep = ""), list(a = meje[1], b = meje[2]))) X$fu <- rep(ford, rform$n - nz) t.int <- int[2] - int[1] X$y <- (pmin(X$Y, int[2]) - X$start)/365.241 X$origstart <- X$start X$xind <- rep(1, nrow(X)) gr1 <- by(X, X$grupa, vg) grm1 <- do.call("rbind", gr1) X <- X[X$fin == 0, ] X$start <- rep(int[2], dim(X)[1]) X <- rbind(X, Z[Z$start < int[3], ]) Z <- Z[Z$start >= int[3], ] temp <- 0 if (nint > 2) { for (i in 3:nint) { ni <- dim(X)[1] if (ni == 0) { temp <- 1 break } X$fin <- X$Y <= int[i] X$event <- X$fin * X$stat l <- sum(int[i - 1] >= meje * 365.241) if(l==1) ftemp <- eval(substitute(paste("[", a, ",", b, "]", sep = ""), list(a = meje[l], b = meje[l + 1]))) else ftemp <- eval(substitute(paste("(", a, ",", b, "]", sep = ""), list(a = meje[l], b = meje[l + 1]))) ford <- c(ford, ftemp) X$fu <- rep(ford[i - 1], ni) t.int <- int[i] - int[i - 1] index <- X$origstart < int[i - 1] index1 <- as.logical(X$xind) if (sum(index) > 0) X[index, 4:(nfk + 3)] <- X[index, 4:(nfk + 3)] + matrix(fk * t.int, ncol = nfk, byrow = TRUE, nrow = sum(index)) X$xind <- rep(1, nrow(X)) X$y <- (pmin(X$Y, int[i]) - X$start)/365.241 gr1 <- by(X, X$grupa, vg) grm1 <- rbind(grm1, do.call("rbind", gr1)) X <- X[X$fin == 0, ] X$start <- rep(int[i], dim(X)[1]) if (i == nint) break X <- rbind(X, Z[Z$start < int[i + 1], ]) X <- X[X$start != X$Y, ] Z <- Z[Z$start >= int[i + 1], ] } l <- sum(int[i - temp] > meje * 365.241) interval <- meje[1:(l + 1)] } else interval <- meje[1:2] grm1$fu <- factor(grm1$fu, levels = unique(ford)) if (method == "glm.bin") { ht <- binomial(link = cloglog) ht$link <- "Hakulinen-Tenkanen relative survival model" ht$linkfun <- function(mu) log(-log((1 - mu)/ps)) ht$linkinv <- function(eta) 1 - exp(-exp(eta)) * ps ht$mu.eta <- function(eta) exp(eta) * exp(-exp(eta)) * ps .ps <- ps <- grm1$ps #assign(".ps", grm1$ps, envir = .GlobalEnv) # ht$initialize <- expression({ # n <- y[, 1] + y[, 2] # y <- ifelse(n == 0, 0, y[, 1]/n) # weights <- weights * n # mustart <- (n * y + 0.01)/(n + 0.02) # mustart[(1 - mustart)/data$ps >= 1] <- data$ps[(1 - mustart)/data$ps >= # 1] * 0.9 # }) if (any(grm1$ld - grm1$nd > grm1$ps * grm1$ld)) { n <- sum(grm1$ld - grm1$nd > grm1$ps * grm1$ld) g <- dim(grm1)[1] warnme <- paste("Observed number of deaths is smaller than the expected in ", n, "/", g, " groups of patients", sep = "") } else warnme <- "" if (length(interval) == 2 & rform$m == 0) stop("No groups can be formed") if (length(interval) == 1 | length(table(grm1$fu)) == 1) grm1$fu <- as.integer(grm1$fu) y <- ifelse(grm1$ld == 0, 0, grm1$nd/grm1$ld) #weights <- weights * grm1$ld mustart <- (grm1$ld * y + 0.01)/(grm1$ld + 0.02) mustart[(1 - mustart)/grm1$ps >= 1] <- grm1$ps[(1 - mustart)/grm1$ps >= 1] * 0.9 if (!length(rform$X)) local.ht <- glm(cbind(nd, ld - nd) ~ -1 + fu + offset(log(k)), data = grm1, family = ht,mustart=mustart) else { xmat <- as.matrix(grm1[, 7:(ncol(grm1) - 1)]) local.ht <- glm(cbind(nd, ld - nd) ~ -1 + xmat + fu + offset(log(k)), data = grm1, family = ht,mustart=mustart) } names(local.ht[[1]]) <- c(names(rform$X), paste("fu", levels(grm1$fu))) } else if (method == "glm.poi") { pot <- poisson() pot$link <- "glm relative survival model with Poisson error" pot$linkfun <- function(mu) log(mu - dstar) pot$linkinv <- function(eta) dstar + exp(eta) #assign(".dstar", grm1$dstar, envir = .GlobalEnv) if (any(grm1$nd - grm1$dstar < 0)) { pot$initialize <- expression({ if (any(y < 0)) stop(paste("Negative values not allowed for", "the Poisson family")) n <- rep.int(1, nobs) #mustart <- pmax(y, .dstar) + 0.1 }) } if (any(grm1$nd - grm1$dstar < 0)) { n <- sum(grm1$nd - grm1$dstar < 0) g <- dim(grm1)[1] warnme <- paste("Observed number of deaths is smaller than the expected in ", n, "/", g, " groups of patients", sep = "") } else warnme <- "" dstar <- grm1$dstar if (length(interval) == 2 & rform$m == 0) stop("No groups can be formed") if (length(interval) == 1 | length(table(grm1$fu)) == 1) grm1$fu <- as.integer(grm1$fu) mustart <- pmax(grm1$nd, grm1$dstar) + 0.1 if (!length(rform$X)) local.ht <- glm(nd ~ -1 + fu, data = grm1, family = pot, offset = grm1$lny,mustart=mustart) else { xmat <- as.matrix(grm1[, 7:(ncol(grm1) - 1)]) local.ht <- glm(nd ~ -1 + xmat + fu, data = grm1, family = pot, offset = grm1$lny,mustart=mustart) } names(local.ht[[1]]) <- c(names(rform$X), paste("fu", levels(grm1$fu))) } else stop(paste("Method '", method, "' not a valid method", sep = "")) class(local.ht) <- c("rsadd", class(local.ht)) local.ht$warnme <- warnme local.ht$int <- interval local.ht$groups <- local.ht$data return(local.ht) } #' Calculate Residuals for a "rsadd" Fit #' #' Calculates partial residuals for an additive relative survival model. #' #' #' @param object an object inheriting from class \code{rsadd}, representing a #' fitted additive relative survival model. Typically this is the output from #' the \code{rsadd} function. #' @param type character string indicating the type of residual desired. #' Currently only Schoenfeld residuals are implemented. #' @param ... other arguments. #' @return A list of the following values is returned: \item{res}{a matrix #' containing the residuals for each variable.} \item{varr}{the variance for #' each residual} \item{varr1}{the sum of \code{varr}.} \item{kvarr}{the #' derivative of each residual, to be used in \code{rs.zph} function.} #' \item{kvarr1}{the sum of \code{kvarr}.} #' @seealso \code{\link{rsadd}}. #' @references Package. Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' #' Goodness of fit: Stare J.,Pohar Perme M., Henderson R. (2005) "Goodness of #' fit of relative survival models." Statistics in Medicine, \bold{24}: #' 3911--3925. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' fit <- rsadd(Surv(time,cens)~sex,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,int=5) #' sresid <- residuals.rsadd(fit) #' residuals.rsadd <- function (object, type = "schoenfeld", ...) { data <- object$data[order(object$data$Y), ] ratetable <- object$ratetable beta <- object$coef start <- data[, 1] stop <- data[, 2] event <- data[, 3] fk <- (attributes(ratetable)$factor != 1) nfk <- length(fk) n <- nrow(data) scale <- 1 if (object$method == "EM") scale <- 365.241 m <- ncol(data) rem <- m - nfk - 3 interval <- object$int int <- ceiling(max(interval)) R <- data[, 4:(nfk + 3)] lp <- matrix(-log(exp.prep(as.matrix(R), 365.241, object$ratetable))/scale, ncol = 1) fu <- NULL if (object$method == "EM") { death.time <- stop[event == 1] for (it in 1:int) { fu <- as.data.frame(cbind(fu, as.numeric(death.time/365.241 < it & (death.time/365.241) >= (it - 1)))) } if(length(death.time)!=length(unique(death.time))){ utimes <- which(c(1,diff(death.time))!=0) razteg <- function(x){ # x is a 0/1 vector, the output is a vector of length sum(x), with the corresponding rep numbers n <- length(x) repu <- rep(1,n) repu[x==1] <- 0 repu <- rev(cumsum(rev(repu))) repu <- repu[x==1] repu <- -diff(c(repu,0))+1 if(sum(repu)!=n)repu <- c(n-sum(repu),repu) #ce je prvi cas censoring, bo treba se kej narest?? repu } rutd <- rep(0,length(death.time)) rutd[utimes] <- 1 rutd <- razteg(rutd) #from unique event times to event times } else rutd <- rep(1,length(death.time)) lambda0 <- rep(object$lambda0,rutd) } else { pon <- NULL for (i in 1:(length(interval) - 1)) { width <- ceiling(interval[i + 1]) - floor(interval[i]) lo <- interval[i] hi <- min(interval[i + 1], floor(interval[i]) + 1) for (j in 1:width) { fu <- as.data.frame(cbind(fu, as.numeric(stop/365.241 < hi & stop/365.241 >= lo))) names(fu)[ncol(fu)] <- paste("fu", lo, "-", hi, sep = "") if (j == width) { pon <- c(pon, sum(fu[event == 1, (ncol(fu) - width + 1):ncol(fu)])) break() } else { lo <- hi hi <- min(interval[i + 1], floor(interval[i]) + 1 + j) } } } m <- ncol(data) data <- cbind(data, fu) rem <- m - nfk - 3 lambda0 <- rep(exp(beta[rem + 1:(length(interval) - 1)]), pon) fu <- fu[event == 1, , drop = FALSE] beta <- beta[1:rem] } if (int >= 2) { for (j in 2:int) { R <- R + matrix(fk * 365.241, ncol = ncol(R), byrow = TRUE, nrow = n) xx <- exp.prep(R, 365.241, object$ratetable) lp <- cbind(lp, -log(xx)/scale) } } z <- as.matrix(data[, (4 + nfk):m]) out <- resid.com(start, stop, event, z, beta, lp, lambda0, fu, n, rem, int, type) out } resid.com <- function (start, stop, event, z, beta, lp, lambda0, fup, n, rem, int, type) { le <- exp(z %*% beta) olp <- if (int > 1) apply(lp[n:1, ], 2, cumsum)[n:1, ] else matrix(cumsum(lp[n:1])[n:1], ncol = 1) ole <- cumsum(le[n:1])[n:1] lp.st <- lp[order(start), , drop = FALSE] le.st <- le[order(start), , drop = FALSE] starter <- sort(start) starter1 <- c(starter[1], starter[-length(starter)]) index <- c(TRUE, (starter != starter1)[-1]) starter <- starter[index] val1 <- apply(matrix(starter, ncol = 1), 1, function(x, Y) sum(x >= Y), stop) val1 <- c(val1[1], diff(val1), length(stop) - val1[length(val1)]) olp.st <- (apply(lp.st[n:1, , drop = FALSE], 2, cumsum)[n:1, , drop = FALSE])[index, , drop = FALSE] olp.st <- apply(olp.st, 2, function(x) rep(c(x, 0), val1)) olp <- olp - olp.st olp <- olp[event == 1, ] olp <- apply(fup * olp, 1, sum) ole.st <- cumsum(le.st[n:1])[n:1][index] ole.st <- rep(c(ole.st, 0), val1) ole <- ole - ole.st ole <- ole[event == 1] * lambda0 s0 <- ole + olp sc <- NULL zb <- NULL kzb <- NULL f1 <- function(x) rep(mean(x), length(x)) f2 <- function(x) apply(x, 2, f1) f3 <- function(x) apply(x, 1:2, f1) ties <- length(unique(stop[event == 1])) != length(stop[event == 1]) for (k in 1:rem) { zlp <- apply((z[, k] * lp)[n:1, , drop = FALSE], 2, cumsum)[n:1, , drop = FALSE] zlp.st <- (apply((z[, k] * lp.st)[n:1, , drop = FALSE], 2, cumsum)[n:1, , drop = FALSE])[index, , drop = FALSE] zlp.st <- apply(zlp.st, 2, function(x) rep(c(x, 0), val1)) zlp <- zlp - zlp.st zlp <- zlp[event == 1, , drop = FALSE] zlp <- apply(fup * zlp, 1, sum) zle <- cumsum((z[, k] * le)[n:1])[n:1] zle.st <- cumsum((z[, k] * le.st)[n:1])[n:1][index] zle.st <- rep(c(zle.st, 0), val1) zle <- zle - zle.st zle <- zle[event == 1] zle <- zle * lambda0 s1 <- zle + zlp zb <- cbind(zb, s1/s0) kzb <- cbind(kzb, zle/s0) } s1ties <- cbind(zb, kzb) if (ties) { s1ties <- by(s1ties, stop[event == 1], f2) s1ties <- do.call("rbind", s1ties) } zb <- s1ties[, 1:rem, drop = FALSE] kzb <- s1ties[, -(1:rem), drop = FALSE] sc <- z[event == 1, , drop = FALSE] - zb row.names(sc) <- stop[event == 1] out.temp <- function(x) outer(x, x, FUN = "*") krez <- rez <- array(matrix(NA, ncol = rem, nrow = rem), dim = c(rem, rem, sum(event == 1))) for (a in 1:rem) { for (b in a:rem) { zzlp <- apply((z[, a] * z[, b] * lp)[n:1, , drop = FALSE], 2, cumsum)[n:1, , drop = FALSE] zzlp.st <- (apply((z[, a] * z[, b] * lp.st)[n:1, , drop = FALSE], 2, cumsum)[n:1, , drop = FALSE])[index, , drop = FALSE] zzlp.st <- apply(zzlp.st, 2, function(x) rep(c(x, 0), val1)) zzlp <- zzlp - zzlp.st zzlp <- zzlp[event == 1, , drop = FALSE] zzlp <- apply(fup * zzlp, 1, sum) zzle <- cumsum((z[, a] * z[, b] * le)[n:1])[n:1] zzle.st <- cumsum((z[, a] * z[, b] * le.st)[n:1])[n:1][index] zzle.st <- rep(c(zzle.st, 0), val1) zzle <- zzle - zzle.st zzle <- zzle[event == 1] zzle <- zzle * lambda0 s2 <- zzlp + zzle s20 <- s2/s0 ks20 <- zzle/s0 s2ties <- cbind(s20, ks20) if (ties) { s2ties <- by(s2ties, stop[event == 1], f2) s2ties <- do.call("rbind", s2ties) } rez[a, b, ] <- rez[b, a, ] <- s2ties[, 1] krez[a, b, ] <- krez[b, a, ] <- s2ties[, 2] } } juhu <- apply(zb, 1, out.temp) if (is.null(dim(juhu))) juhu1 <- array(data = matrix(juhu, ncol = a), dim = c(a, a, length(zb[, 1]))) else juhu1 <- array(data = apply(juhu, 2, matrix, ncol = a), dim = c(a, a, length(zb[, 1]))) varr <- rez - juhu1 kjuhu <- apply(cbind(zb, kzb), 1, function(x) outer(x[1:rem], x[-(1:rem)], FUN = "*")) if (is.null(dim(kjuhu))) kjuhu1 <- array(data = matrix(kjuhu, ncol = rem), dim = c(rem, rem, length(zb[, 1]))) else kjuhu1 <- array(data = apply(kjuhu, 2, matrix, ncol = rem), dim = c(rem, rem, length(zb[, 1]))) kvarr <- krez - kjuhu1 for (i in 1:dim(varr)[1]) varr[i, i, which(varr[i, i, ] < 0)] <- 0 for (i in 1:dim(kvarr)[1]) kvarr[i, i, which(kvarr[i, i, ] < 0)] <- 0 varr1 <- apply(varr, 1:2, sum) kvarr1 <- apply(kvarr, 1:2, sum) if (type == "schoenfeld") out <- list(res = sc, varr1 = varr1, varr = varr, kvarr = kvarr, kvarr1 = kvarr1) out } #' Test the Proportional Hazards Assumption for Relative Survival Regression #' Models #' #' Test the proportional hazards assumption for relative survival models #' (\code{rsadd}, \code{rsmul} or \code{rstrans}) by forming a Brownian Bridge. #' #' #' @aliases rs.br plot.rs.br print.rs.br #' @param fit the result of fitting a relative survival model, using the #' \code{rsadd}, \code{rsmul} or \code{rstrans} function. #' @param sc partial residuals calculated by the \code{resid} function. This is #' used to save time if several tests are to be calculated on these residuals #' and can otherwise be omitted. #' @param rho a number controlling the weigths of residuals. The weights are #' the number of individuals at risk at each event time to the power #' \code{rho}. The default is \code{rho=0}, which sets all weigths to 1. #' @param test a character string specifying the test to be performed on #' Brownian bridge. Possible values are \code{"max"} (default), which tests the #' maximum absolute value of the bridge, and \code{cvm}, which calculates the #' Cramer Von Mises statistic. #' @param global should a global Brownian bridge test be performed, in addition #' to the per-variable tests #' @return an object of class \code{rs.br}. This function would usually be #' followed by both a print and a plot of the result. The plot gives a Brownian #' bridge for each of the variables. The horizontal lines are the 95% and 99% #' confidence intervals for the maximum absolute value of the Brownian bridge #' @seealso \code{\link{rsadd}}, \code{rsmul}, \code{rstrans}, #' \code{\link{resid}}. #' @references Goodness of fit: Stare J.,Pohar Perme M., Henderson R. (2005) #' "Goodness of fit of relative survival models." Statistics in Medicine, #' \bold{24}: 3911--3925. #' #' Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." #' Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' fit <- rsadd(Surv(time,cens)~sex,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,int=5) #' rsbr <- rs.br(fit) #' rsbr #' plot(rsbr) #' rs.br <- function (fit, sc, rho = 0, test = "max", global = TRUE) { test <- match.arg(test,c("max","cvm")) if (inherits(fit, "rsadd")) { if (missing(sc)) sc <- resid(fit, "schoenfeld") sresid <- sc$res varr <- sc$varr sresid <- as.matrix(sresid) } else { coef <- fit$coef options(warn = -1) sc <- coxph.detail(fit) options(warn = 0) sresid <- sc$score varr <- sc$imat if (is.null(dim(varr))) varr <- array(varr, dim = c(1, 1, length(varr))) sresid <- as.matrix(sresid) } if (inherits(fit, "coxph")) { if(is.null(fit$data)){ temp <- fit$y class(temp) <- "matrix" if(ncol(fit$y)==2)temp <- data.frame(rep(0,nrow(fit$y)),temp) if(is.null(fit$x))stop("The coxph model should be called with x=TRUE argument") fit$data <- data.frame(temp,fit$x) names(fit$data)[1:3] <- c("start","Y","stat") } } data <- fit$data[order(fit$data$Y), ] time <- data$Y[data$stat == 1] ties <- (length(unique(time)) != length(time)) keep <- 1:(ncol(sresid)) options(warn = -1) scaled <- NULL varnova <- NULL if (ncol(sresid) == 1) { varr <- varr[1, 1, ] scaled <- sresid/sqrt(varr) } else { for (i in 1:ncol(sresid)) varnova <- cbind(varnova,varr[i,i,]) scaled <- sresid/sqrt(varnova) } options(warn = 0) nvar <- ncol(sresid) survfit <- getFromNamespace("survfit", "survival") temp <- survfit(fit$y~1, type = "kaplan-meier") n.risk <- temp$n.risk n.time <- temp$time if (temp$type == "right") { cji <- matrix(fit$y, ncol = 2) n.risk <- n.risk[match(cji[cji[, 2] == 1, 1], n.time)] } else { cji <- matrix(fit$y, ncol = 3) n.risk <- n.risk[match(cji[cji[, 3] == 1, 2], n.time)] } n.risk <- sort(n.risk, decreasing = TRUE) varnames <- names(fit$coef)[keep] u2 <- function(bb) { n <- length(bb) 1/n * (sum(bb^2) - sum(bb)^2/n) } wc <- function(x, k = 1000) { a <- 1 for (i in 1:k) a <- a + 2 * (-1)^i * exp(-2 * i^2 * pi^2 * x) a } brp <- function(x, n = 1000) { a <- 1 for (i in 1:n) a <- a - 2 * (-1)^(i - 1) * exp(-2 * i^2 * x^2) a } global <- as.numeric(global & ncol(sresid) > 1) table <- NULL bbt <- as.list(1:(nvar + global)) for (i in 1:nvar) { if (nvar != 1) usable <- which(varr[i, i, ] > 1e-12) else usable <- which(varr > 1e-12) w <- (n.risk[usable])^rho w <- w/sum(w) if (nvar != 1) { sci <- scaled[usable, i] } else sci <- scaled[usable] if (ties) { if (inherits(fit, "rsadd")) { sci <- as.vector(by(sci, time[usable], function(x) sum(x)/sqrt(length(x)))) w <- as.vector(by(w, time[usable], sum)) } else { w <- w * as.vector(table(time))[usable] w <- w/sum(w) } } sci <- sci * sqrt(w) timescale <- cumsum(w) bm <- cumsum(sci) bb <- bm - timescale * bm[length(bm)] if (test == "max") table <- rbind(table, c(max(abs(bb)), 1 - brp(max(abs(bb))))) else if (test == "cvm") table <- rbind(table, c(u2(bb), 1 - wc(u2(bb)))) bbt[[i]] <- cbind(timescale, bb) } if (inherits(fit, "rsadd")) { beta <- fit$coef[1:(length(fit$coef) - length(fit$int) + 1)] } else beta <- fit$coef if (global) { qform <- function(matrix, vector) t(vector) %*% matrix %*% vector diagonal <- apply(varr, 3, diag) sumdiag <- apply(diagonal, 2, sum) usable <- which(sumdiag > 1e-12) score <- t(beta) %*% t(sresid[usable, ]) varr <- varr[, , usable] qf <- apply(varr, 3, qform, vector = beta) w <- (n.risk[usable])^rho w <- w/sum(w) sci <- score/(qf)^0.5 if (ties) { if (inherits(fit, "rsadd")) { sci <- as.vector(by(t(sci), time[usable], function(x) sum(x)/sqrt(length(x)))) w <- as.vector(by(w, time[usable], sum)) } else { w <- w * as.vector(table(time)) w <- w/sum(w) } } sci <- sci * sqrt(w) timescale <- cumsum(w) bm <- cumsum(sci) bb <- bm - timescale * bm[length(bm)] if (test == "max") table <- rbind(table, c(max(abs(bb)), 1 - brp(max(abs(bb))))) else if (test == "cvm") table <- rbind(table, c(u2(bb), 1 - wc(u2(bb)))) bbt[[nvar + 1]] <- cbind(timescale, bb) varnames <- c(varnames, "GLOBAL") } dimnames(table) <- list(varnames, c(test, "p")) out <- list(table = table, bbt = bbt, rho = rho) class(out) <- "rs.br" out } #' Behaviour of Covariates in Time for Relative Survival Regression Models #' #' Calculates the scaled partial residuals of a relative survival model #' (\code{rsadd}, \code{rsmul} or \code{rstrans}) #' #' #' @param fit the result of fitting an additive relative survival model, using #' the \code{rsadd}, \code{rsmul} or \code{rstrans} function. #' #' In the case of multiplicative and transformation models the output is #' identical to \code{cox.zph} function, except no test is performed. #' @param sc partial residuals calculated by the \code{resid} function. This is #' used to save time if several tests are to be calculated on these residuals #' and can otherwise be omitted. #' @param transform a character string specifying how the survival times should #' be transformed. Possible values are \code{"km"}, \code{"rank"}, #' \code{"identity"} and \code{log}. The default is \code{"identity"}. #' @param var.type a character string specifying the variance used to scale the #' residuals. Possible values are \code{"each"}, which estimates the variance #' for each residual separately, and \code{sum}(default), which assumes the #' same variance for all the residuals. #' @return an object of class \code{rs.zph}. This function would usually be #' followed by a plot of the result. The plot gives an estimate of the #' time-dependent coefficient \code{beta(t)}. If the proportional hazards #' assumption is true, \code{beta(t)} will be a horizontal line. #' @seealso \code{\link{rsadd}}, \code{rsmul}, \code{rstrans}, #' \code{\link{resid}}, \code{\link{cox.zph}}. #' @references Goodness of fit: Stare J.,Pohar Perme M., Henderson R. (2005) #' "Goodness of fit of relative survival models." Statistics in Medicine, #' \bold{24}: 3911--3925. #' #' Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." #' Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' fit <- rsadd(Surv(time,cens)~sex,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,int=5) #' rszph <- rs.zph(fit) #' plot(rszph) #' rs.zph <- function (fit, sc, transform = "identity", var.type = "sum") { if (inherits(fit, "rsadd")) { if (missing(sc)) sc <- resid(fit, "schoenfeld") sresid <- sc$res varr <- sc$kvarr fvar <- solve(sc$kvarr1) sresid <- as.matrix(sresid) } else { coef <- fit$coef options(warn = -1) sc <- coxph.detail(fit) options(warn = 0) sresid <- as.matrix(resid(fit, "schoenfeld")) varr <- sc$imat fvar <- fit$var } data <- fit$data[order(fit$data$Y), ] time <- data$Y stat <- data$stat if (!inherits(fit, "rsadd")) { ties <- as.vector(table(time[stat==1])) if(is.null(dim(varr))) varr <- rep(varr/ties,ties) else{ varr <- apply(varr,1:2,function(x)rep(x/ties,ties)) varr <- aperm(varr,c(2,3,1)) } } keep <- 1:(length(fit$coef) - length(fit$int) + 1) varnames <- names(fit$coef)[keep] nvar <- length(varnames) ndead <- length(sresid)/nvar if (inherits(fit, "rsadd")) times <- time[stat == 1] else times <- sc$time if (is.character(transform)) { tname <- transform ttimes <- switch(transform, identity = times, rank = rank(times), log = log(times), km = { fity <- Surv(time, stat) temp <- survfit(fity~1) t1 <- temp$surv[temp$n.event > 0] t2 <- temp$n.event[temp$n.event > 0] km <- rep(c(1, t1), c(t2, 0)) if (is.null(attr(sresid, "strata"))) 1 - km else (1 - km[sort.list(sort.list(times))]) }, stop("Unrecognized transform")) } else { tname <- deparse(substitute(transform)) ttimes <- transform(times) } if (var.type == "each") { invV <- apply(varr, 3, function(x) try(solve(x), silent = TRUE)) if (length(invV) == length(varr)){ if(!is.numeric(invV)){ usable <- rep(FALSE, dim(varr)[3]) options(warn=-1) invV <- as.numeric(invV) usable[1:(min(which(is.na(invV)))-1)] <- TRUE invV <- invV[usable] sresid <- sresid[usable,,drop=FALSE] options(warn=0) } else usable <- rep(TRUE, dim(varr)[3]) } else { usable <- unlist(lapply(invV, is.matrix)) if (!any(usable)) stop("All the matrices are singular") invV <- invV[usable] sresid <- sresid[usable, , drop = FALSE] } di1 <- dim(varr)[1] di3 <- sum(usable) u <- array(data = matrix(unlist(invV), ncol = di1), dim = c(di1, di1, di3)) uv <- cbind(matrix(u, ncol = di1, byrow = TRUE), as.vector(t(sresid))) uv <- array(as.vector(t(uv)), dim = c(di1 + 1, di1, di3)) r2 <- t(apply(uv, 3, function(x) x[1:di1, ] %*% x[di1 + 1, ])) r2 <- matrix(r2, ncol = di1) whr2 <- apply(r2<100,1,function(x)!any(x==FALSE)) usable <- as.logical(usable*whr2) r2 <- r2[usable,,drop=FALSE] u <- u[,,usable] dimnames(r2) <- list(times[usable], varnames) temp <- list(x = ttimes[usable], y = r2 + outer(rep(1, sum(usable)), fit$coef[keep]), var = u, call = call, transform = tname) } else if (var.type == "sum") { xx <- ttimes - mean(ttimes) r2 <- t(fvar %*% t(sresid) * ndead) r2 <- as.matrix(r2) dimnames(r2) <- list(times, varnames) temp <- list(x = ttimes, y = r2 + outer(rep(1, ndead), fit$coef[keep]), var = fvar, transform = tname) } else stop("Unknown 'var.type'") class(temp) <- "rs.zph" temp } #' Graphical Inspection of Proportional Hazards Assumption in Relative Survival #' Models #' #' Displays a graph of the scaled partial residuals, along with a smooth curve. #' #' #' @param x result of the \code{rs.zph} function. #' @param resid a logical value, if \code{TRUE} the residuals are included on #' the plot, as well as the smooth fit. #' @param df the degrees of freedom for the fitted natural spline, \code{df=2} #' leads to a linear fit. #' @param nsmo number of points used to plot the fitted spline. #' @param var the set of variables for which plots are desired. By default, #' plots are produced in turn for each variable of a model. Selection of a #' single variable allows other features to be added to the plot, e.g., a #' horizontal line at zero or a main title. #' @param cex a numerical value giving the amount by which plotting text and #' symbols should be scaled relative to the default. #' @param add logical, if \code{TRUE} the plot is added to an existing plot #' @param col a specification for the default plotting color. #' @param lty the line type. #' @param xlab x axis label. #' @param ylab y axis label. #' @param xscale units for x axis, default is 1, i.e. days. #' @param ... Additional arguments passed to the \code{plot} function. #' @seealso \code{\link{rs.zph}}, \code{\link{plot.cox.zph}}. #' @references Goodness of fit: Stare J.,Pohar Perme M., Henderson R. (2005) #' "Goodness of fit of relative survival models." Statistics in Medicine, #' \bold{24}: 3911-3925. #' #' Package: Pohar M., Stare J. (2006) "Relative survival analysis in R." #' Computer Methods and Programs in Biomedicine, \bold{81}: 272-278. #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741-1749, 2007. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' fit <- rsadd(Surv(time,cens)~sex+as.factor(agegr),rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,int=5) #' rszph <- rs.zph(fit) #' plot(rszph) #' plot.rs.zph <- function (x,resid = TRUE, df = 4, nsmo = 40, var, cex = 1, add = FALSE, col = 1, lty = 1, xlab, ylab, xscale = 1, ...) { #require(splines) xx <- x$x if(x$transform=="identity")xx <- xx/xscale yy <- x$y d <- nrow(yy) df <- max(df) nvar <- ncol(yy) pred.x <- seq(from = min(xx), to = max(xx), length = nsmo) temp <- c(pred.x, xx) lmat <- splines::ns(temp, df = df, intercept = TRUE) pmat <- lmat[1:nsmo, ] xmat <- lmat[-(1:nsmo), ] qmat <- qr(xmat) if (missing(ylab)) ylab <- paste("Beta(t) for", dimnames(yy)[[2]]) if (missing(xlab)) xlab <- "Time" if (missing(var)) var <- 1:nvar else { if (is.character(var)) var <- match(var, dimnames(yy)[[2]]) if (any(is.na(var)) || max(var) > nvar || min(var) < 1) stop("Invalid variable requested") } if (x$transform == "log") { xx <- exp(xx) pred.x <- exp(pred.x) } else if (x$transform != "identity") { xtime <- as.numeric(dimnames(yy)[[1]])/xscale apr1 <- approx(xx, xtime, seq(min(xx), max(xx), length = 17)[2 * (1:8)]) temp <- signif(apr1$y, 2) apr2 <- approx(xtime, xx, temp) xaxisval <- apr2$y xaxislab <- rep("", 8) for (i in 1:8) xaxislab[i] <- format(temp[i]) } for (i in var) { y <- yy[, i] yhat <- pmat %*% qr.coef(qmat, y) yr <- range(yhat, y) if (!add) { if (x$transform == "identity") plot(range(xx), yr, type = "n", xlab = xlab, ylab = ylab[i],...) else if (x$transform == "log") plot(range(xx), yr, type = "n", xlab = xlab, ylab = ylab[i],log = "x", ...) else { plot(range(xx), yr, type = "n", xlab = xlab, ylab = ylab[i],axes = FALSE, ...) axis(1, xaxisval, xaxislab) axis(2) box() } } if (resid) points(xx, y, cex = cex, col = col) lines(pred.x, yhat, col = col, lty = lty) } } plot.rs.br <- function (x, var, ylim = c(-2, 2), xlab, ylab, ...) { bbt <- x$bbt par(ask = TRUE) if (missing(var)) var <- 1:nrow(x$table) ychange <- FALSE if (missing(ylab)) ylab <- paste("Brownian bridge for", row.names(x$table)) else { if (length(ylab) == 1 & nrow(x$table) > 1) ylab <- rep(ylab, nrow(x$table)) } if (missing(xlab)) xlab <- "Time" for (i in var) { timescale <- bbt[[i]][, 1] bb <- bbt[[i]][, 2] plot(c(0, timescale), c(0, bb), type = "l", ylim = ylim, xlab = xlab, ylab = ylab[i], ...) abline(h = 1.36, col = 2) abline(h = 1.63, col = 2) abline(h = -1.36, col = 2) abline(h = -1.63, col = 2) } par(ask = FALSE) } Kernmatch <- function (t, tv, b, tD, nt4) { kmat <- NULL for (it in 1:(length(nt4) - 1)) { kmat1 <- (outer(t[(nt4[it] + 1):nt4[it + 1]], tv, "-")/b[it]) kmat1 <- kmat1^(kmat1 >= 0) kmat <- rbind(kmat, pmax(1 - kmat1^2, 0) * (1.5/b[it])) } kmat } kernerleftch <- function (td, b, nt4) { n <- length(td) ttemp <- td[td >= b[1]] ntemp <- length(ttemp) if (ntemp == n) nt4 <- c(0, nt4[-1]) else { nfirst <- n - ntemp nt4 <- c(0, 1:nfirst, nt4[-1]) b <- c(td[1:nfirst], b) } krn <- Kernmatch(td, td, b, max(td), nt4) krn } #' Inverse transforming of time in Relative Survival #' #' This function can be used when predicting in Relative Survival using the #' transformed time regression model (using \code{rstrans} function). It #' inverses the time from Y to T in relative survival using the given #' ratetable. The times Y can be produced with the \code{rstrans} function, in #' which case, this is the reverse function. This function does the #' transformation for one person at a time. #' #' Works only with ratetables that are split by age, sex and year. Transforming #' can be computationally intensive, use lower and/or upper to guess the #' interval of the result and thus speed up the function. #' #' @param y time in Y. #' @param age age of the individual. Must be in days. #' @param sex sex of the individual. Must be coded in the same way as in the #' \code{ratetable}. #' @param year date of diagnosis. Must be in a date format #' @param scale numeric value to scale the results. If \code{ratetable} is in #' units/day, \code{scale = 365.241} causes the output to be reported in years. #' @param ratetable a table of event rates, such as \code{survexp.us}. #' @param lower the lower bound of interval where the result is expected. This #' argument is optional, but, if given, can shorten the time the function needs #' to calculate the result. #' @param upper the upper bound of interval where the result is expected. See #' \code{lower} #' @return A list of values \item{T}{the original time} \item{Y}{the #' transformed time} #' @seealso \code{\link{rstrans}} #' @references Package: Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272-278. #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741-1749. #' @keywords survival #' @examples #' #' data(slopop) #' invtime(y = 0.1, age = 23011, sex = 1, year = 9497, ratetable = slopop) #' invtime <- function (y = 0.1, age = 23011, sex = "male", year = 9497, scale = 1, ratetable = relsurv::slopop, lower, upper) { if (!is.numeric(age)) stop("\"age\" must be numeric", call. = FALSE) if (!is.numeric(y)) stop("\"y\" must be numeric", call. = FALSE) if (!is.numeric(scale)) stop("\"scale\" must be numeric", call. = FALSE) temp <- data.frame(age = age, sex = I(sex), year = year) if (missing(lower)) { if (!missing(upper)) stop("Argument \"lower\" is missing, with no default", call. = FALSE) nyears <- round((110 - age/365.241)) tab <- data.frame(age = rep(age, nyears), sex = I(rep(sex, nyears)), year = rep(year, nyears)) vred <- 1 - survexp(c(0, 1:(nyears - 1)) * 365.241 ~ ratetable(age = age, sex = sex, year = year), ratetable = ratetable, data = tab, cohort = FALSE) place <- sum(vred <= y) if (place == 0) lower <- 0 else lower <- floor((place - 1) * 365.241 - place) upper <- ceiling(place * 365.241 + place) } else { if (missing(upper)) stop("Argument \"upper\" is missing, with no default", call. = FALSE) if (!is.integer(lower)) lower <- floor(lower) if (!is.integer(upper)) upper <- ceiling(upper) if (upper <= lower) stop("'upper' must be higher than 'lower'", call. = FALSE) } lower <- max(0, lower) tab <- data.frame(age = rep(age, upper - lower + 1), sex = I(rep(sex, upper - lower + 1)), year = rep(year, upper - lower + 1)) vred <- 1 - survexp((lower:upper) ~ ratetable(age = age, sex = sex, year = year), ratetable = ratetable, data = tab, cohort = FALSE) place <- sum(vred <= y) if (place == 0) warning(paste("The event happened on or before day", lower), call. = FALSE) if (place == length(vred)) warning(paste("The event happened on or after day", upper), call. = FALSE) t <- (place + lower - 1)/scale age <- round(age/365.241, 0.01) return(list(age, sex, year, Y = y, T = t)) } #' Fit Andersen et al Multiplicative Regression Model for Relative Survival #' #' Fits the Andersen et al multiplicative regression model in relative #' survival. An extension of the coxph function using relative survival. #' #' NOTE: The follow-up time must be specified in days. The \code{ratetable} #' being used may have different variable names and formats than the user's #' data set, this is dealt with by the \code{rmap} argument. For example, if #' age is in years in the data set but in days in the \code{ratetable} object, #' age=age*365.241 should be used. The calendar year can be in any date format #' (date, Date and POSIXt are allowed), the date formats in the #' \code{ratetable} and in the data may differ. #' #' @param formula a formula object, with the response as a \code{Surv} object #' on the left of a \code{~} operator, and, if desired, terms separated by the #' \code{+} operator on the right. #' #' NOTE: The follow-up time must be in days. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param ratetable a table of event rates, such as \code{slopop}. #' @param int the number of follow-up years used for calculating survival(the #' data are censored after this time-point). If missing, it is set the the #' maximum observed follow-up time. #' @param na.action a missing-data filter function, applied to the model.frame, #' after any subset argument has been used. Default is #' \code{options()$na.action}. #' @param init vector of initial values of the iteration. Default initial #' value is zero for all variables. #' @param method the default method \code{mul} assumes hazard to be constant on #' yearly intervals. Method \code{mul1} uses the ratetable to determine the #' time points when hazard changes. The \code{mul1} method is therefore more #' accurate, but at the same time can be more computationally intensive. #' @param control a list of parameters for controlling the fitting process. #' See the documentation for \code{coxph.control} for details. #' @param rmap an optional list to be used if the variables are not organized #' and named in the same way as in the \code{ratetable} object. See details #' below. #' @param ... Other arguments will be passed to \code{coxph.control}. #' @return an object of class \code{coxph} with an additional item: #' \item{basehaz}{Cumulative baseline hazard (population values are seen as #' offset) at centered values of covariates.} #' @seealso \code{\link{rsadd}}, \code{\link{rstrans}}. #' @references Method: Andersen, P.K., Borch-Johnsen, K., Deckert, T., Green, #' A., Hougaard, P., Keiding, N. and Kreiner, S. (1985) "A Cox regression model #' for relative mortality and its application to diabetes mellitus survival #' data.", Biometrics, \bold{41}: 921--932. #' #' Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." #' Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #fit a multiplicative model #' #note that the variable year is given in days since 01.01.1960 and that #' #age must be multiplied by 365.241 in order to be expressed in days. #' fit <- rsmul(Surv(time,cens)~sex+as.factor(agegr),rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata) #' #' #' #check the goodness of fit #' rs.br(fit) #' #' rsmul <- function (formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, int, na.action, init, method = "mul", control,rmap, ...) { #require(survival) if (!missing(rmap)) { rmap <- substitute(rmap) } rform <- rformulate(formula,data, ratetable, na.action,rmap,int) U <- rform$data if (missing(int)) int <- ceiling(max(rform$Y/365.241)) if(length(int)!=1)int <- max(int) fk <- (attributes(rform$ratetable)$factor != 1) nfk <- length(fk) if (method == "mul") { U <- survsplit(U, cut = (1:int) * 365.241, end = "Y", event = "stat", start = "start", episode = "epi") fk <- (attributes(rform$ratetable)$factor != 1) nfk <- length(fk) U[, 4:(nfk + 3)] <- U[, 4:(nfk + 3)] + 365.241 * (U$epi) %*% t(fk) nsk <- dim(U)[1] xx <- exp.prep(U[, 4:(nfk + 3),drop=FALSE], 365.241, rform$ratetable) lambda <- -log(xx)/365.241 } else if (method == "mul1") { U$id <- 1:dim(U)[1] my.fun <- function(x, attcut, nfk, fk) { intr <- NULL for (i in 1:nfk) { if (fk[i]) { n1 <- max(findInterval(as.numeric(x[3 + i]) + as.numeric(x[1]), attcut[[i]]) + 1, 2) n2 <- findInterval(as.numeric(x[3 + i]) + as.numeric(x[2]), attcut[[i]]) if (n2 > n1 & length(attcut[[i]] > 1)) { if (n2 > length(attcut[[i]])) n2 <- length(attcut[[i]]) intr <- c(intr, as.numeric(attcut[[i]][n1:n2]) - as.numeric(x[3 + i])) } } } intr <- sort(unique(c(intr, as.numeric(x[2])))) intr } attcut <- attributes(rform$ratetable)$cutpoints intr <- apply(U[, 1:(3 + nfk)], 1, my.fun, attcut, nfk, fk) dolg <- unlist(lapply(intr, length)) newdata <- lapply(U, rep, dolg) stoptime <- unlist(intr) starttime <- c(-1, stoptime[-length(stoptime)]) first <- newdata$id != c(-1, newdata$id[-length(newdata$id)]) starttime[first] <- newdata$start[first] last <- newdata$id != c(newdata$id[-1], -1) event <- rep(0, length(newdata$id)) event[last] <- newdata$stat[last] U <- do.call("data.frame", newdata) U$start <- starttime U$Y <- stoptime U$stat <- event U[, 4:(nfk + 3)] <- U[, 4:(nfk + 3)] + (U$start) %*% t(fk) nsk <- dim(U)[1] xx <- exp.prep(U[, 4:(nfk + 3),drop=FALSE], 1, rform$ratetable) lambda <- -log(xx)/1 } else stop("'method' must be one of 'mul' or 'mul1'") U$lambda <- log(lambda) if (rform$m == 0) fit <- coxph(Surv(start, Y, stat) ~ 1 + offset(lambda), data = U, init = init, control = control, x = TRUE, ...) else { xmat <- as.matrix(U[, (3 + nfk + 1):(ncol(U) - 2)]) fit <- coxph(Surv(start, Y, stat) ~ xmat + offset(lambda), data = U, init = init, control = control, x = TRUE, ...) names(fit[[1]]) <- names(U)[(3 + nfk + 1):(ncol(U) - 2)] } class(fit) <- c("rsmul",class(fit)) fit$basehaz <- basehaz(fit) #NEW 2.05 fit$data <- rform$data fit$call <- match.call() fit$int <- int if (length(rform$na.action)) fit$na.action <- rform$na.action fit } #' Fit Cox Proportional Hazards Model in Transformed Time #' #' The function transforms each person's time to his/her probability of dying #' at that time according to the ratetable. It then fits the Cox proportional #' hazards model with the transformed times as a response. It can also be used #' for calculatin the transformed times (no covariates are needed in the #' formula for that purpose). #' #' NOTE: The follow-up time must be specified in days. The \code{ratetable} #' being used may have different variable names and formats than the user's #' data set, this is dealt with by the \code{rmap} argument. For example, if #' age is in years in the data set but in days in the \code{ratetable} object, #' age=age*365.241 should be used. The calendar year can be in any date format #' (date, Date and POSIXt are allowed), the date formats in the #' \code{ratetable} and in the data may differ. A side product of this #' function are the transformed times - stored in teh \code{y} object of the #' output. To get these times, covariates are of course irrelevant. #' #' @param formula a formula object, with the response as a \code{Surv} object #' on the left of a \code{~} operator, and, if desired, terms separated by the #' \code{+} operator on the right. #' #' NOTE: The follow-up time must be in days. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param ratetable a table of event rates, such as \code{slopop}. #' @param int the number of follow-up years used for calculating survival(the #' rest is censored). If missing, it is set the the maximum observed follow-up #' time. #' @param na.action a missing-data filter function, applied to the model.frame, #' after any subset argument has been used. Default is #' \code{options()$na.action}. #' @param init vector of initial values of the iteration. Default initial #' value is zero for all variables. #' @param control a list of parameters for controlling the fitting process. #' See the documentation for \code{coxph.control} for details. #' @param rmap an optional list to be used if the variables are not organized #' and named in the same way as in the \code{ratetable} object. See details #' below. #' @param ... other arguments will be passed to \code{coxph.control}. #' @return an object of class \code{coxph}. See \code{coxph.object} and #' \code{coxph.detail} for details. \item{y}{ an object of class \code{Surv} #' containing the transformed times (these times do not depend on covariates). #' } #' @seealso \code{\link{rsmul}}, \code{\link{invtime}}, \code{\link{rsadd}}, #' \code{\link{survexp}}. #' @references Method: Stare J., Henderson R., Pohar M. (2005) "An individual #' measure for relative survival." Journal of the Royal Statistical Society: #' Series C, \bold{54} 115--126. #' #' Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." #' Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #' #fit a Cox model using the transformed times #' #note that the variable year is given in days since 01.01.1960 and that #' #age must be multiplied by 365.241 in order to be expressed in days. #' fit <- rstrans(Surv(time,cens)~sex+as.factor(agegr),rmap=list(age=age*365.241, #' sex=sex,year=year),ratetable=slopop,data=rdata) #' #' #' #check the goodness of fit #' rs.br(fit) #' rstrans <- function (formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, int, na.action, init, control,rmap, ...) { if (!missing(rmap)) { rmap <- substitute(rmap) } rform <- rformulate(formula, data, ratetable, na.action, rmap, int) if (missing(int)) int <- ceiling(max(rform$Y/365.241)) fk <- (attributes(rform$ratetable)$factor != 1) nfk <- length(fk) if (rform$type == "counting") { start <- 1 - exp.prep(rform$R, rform$start, rform$ratetable) } else start <- rep(0, rform$n) stop <- 1 - exp.prep(rform$R, rform$Y, rform$ratetable) if(any(stop==0&rform$Y!=0))stop[stop==0&rform$Y!=0] <- .Machine$double.eps if(length(int)!=1)int <- max(int) data <- rform$data stat <- rform$status if (rform$m == 0) { if (rform$type == "counting") fit <- coxph(Surv(start, stop, stat) ~ 1, init = init, control = control, x = TRUE, ...) else fit <- coxph(Surv(stop, stat) ~ 1, init = init, control = control, x = TRUE, ...) } else { xmat <- as.matrix(data[, (4 + nfk):ncol(data)]) fit <- coxph(Surv(start, stop, stat) ~ xmat, init = init, control = control, x = TRUE, ...) names(fit[[1]]) <- names(rform$X) } fit$call <- match.call() if (length(rform$na.action)) fit$na.action <- rform$na.action data$start <- start data$Y <- stop fit$data <- data fit$int <- int return(fit) } #' Reorganize Data into a Ratetable Object #' #' The function assists in reorganizing certain types of data into a ratetable #' object. #' #' This function only applies for ratetables that are organized by age, sex and #' year. #' #' @param men a matrix containing the yearly (conditional) probabilities of one #' year survival for men. Rows represent age (increasing 1 year per #' line,starting with 0), the columns represent cohort years (the limits are in #' \code{yearlim}, the increase is in \code{int.length}. #' @param women a matrix containing the yearly (conditional) probabilities of #' one year survival for women. #' @param yearlim the first and last cohort year given in the tables. #' @param int.length the length of intervals in which cohort years are given. #' @return An object of class \code{ratetable}. #' @seealso \code{\link{ratetable}}. #' @references Package. Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' @keywords survival #' @examples #' #' men <- cbind(exp(-365.241*exp(-14.5+.08*(0:100))),exp(-365*exp(-14.7+.085*(0:100)))) #' women <- cbind(exp(-365.241*exp(-15.5+.085*(0:100))),exp(-365*exp(-15.7+.09*(0:100)))) #' table <- transrate(men,women,yearlim=c(1980,1990),int.length=10) #' transrate <- function (men, women, yearlim, int.length = 1) { if (any(dim(men) != dim(women))) stop("The men and women matrices must be of the same size. \n In case of missing values at the end carry the last value forward") if ((yearlim[2] - yearlim[1])/int.length + 1 != dim(men)[2]) stop("'yearlim' cannot be divided into intervals of equal length") if (!is.matrix(men) | !is.matrix(women)) stop("input tables must be of class matrix") dimi <- dim(men) temp <- array(c(men, women), dim = c(dimi, 2)) temp <- -log(temp)/365.241 temp <- aperm(temp, c(1, 3, 2)) cp <- as.date(apply(matrix(yearlim[1] + int.length * (0:(dimi[2] - 1)), ncol = 1), 1, function(x) { paste("1jan", x, sep = "") })) attributes(temp) <- list(dim = c(dimi[1], 2, dimi[2]), dimnames = list(age=as.character(0:(dimi[1] - 1)), sex=c("male", "female"), year=as.character(yearlim[1] + int.length * (0:(dimi[2] - 1)))), dimid = c("age", "sex", "year"), factor = c(0, 1, 0),type=c(2,1,3), cutpoints = list((0:(dimi[1] - 1)) * (365.241), NULL, cp), class = "ratetable") attributes(temp)$summary <- function (R) { x <- c(format(round(min(R[, 1])/365.241, 1)), format(round(max(R[, 1])/365.241, 1)), sum(R[, 2] == 1), sum(R[, 2] == 2)) x2 <- as.character(as.Date(c(min(R[, 3]), max(R[, 3])), origin=as.Date('1970-01-01'))) paste(" age ranges from", x[1], "to", x[2], "years\n", " male:", x[3], " female:", x[4], "\n", " date of entry from", x2[1], "to", x2[2], "\n") } temp } #' Reorganize Data obtained from Human Life-Table Database into a Ratetable #' Object #' #' The function assists in reorganizing the .txt files obtained from Human #' Life-Table Database (http://www.lifetable.de -> Data by Country) into a #' ratetable object. #' #' This function works with any table organised in the format provided by the #' Human Life-Table Database, but currently only works with TypeLT 1 (i.e. age #' intervals of length 1). The age must always start with value 0, but can end #' at different values (when that happens, the last value is carried forward). #' The rates between the cutpoints are taken to be constant. #' #' @param file a vector of file names which the data are to be read from. Must #' be in .tex format and in the same format as the files in Human Life-Table #' Database. #' @param cut.year a vector of cutpoints for years. Must be specified when the #' year spans in the files are not consecutive. #' @param race a vector of race names for the input files. #' @return An object of class \code{ratetable}. #' @seealso \code{\link{ratetable}}, \code{\link{transrate.hmd}}, #' \code{\link{joinrate}}, \code{\link{transrate}}. #' @references Package. Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' @keywords survival #' @examples #' #' \dontrun{ #' finpop <- transrate.hld(c("FIN_1981-85.txt","FIN_1986-90.txt","FIN_1991-95.txt")) #' } #' \dontrun{ #' nzpop <- transrate.hld(c("NZL_1980-82_Non-maori.txt","NZL_1985-87_Non-maori.txt", #' "NZL_1980-82_Maori.txt","NZL_1985-87_Maori.txt"), #' cut.year=c(1980,1985),race=rep(c("nonmaori","maori"),each=2)) #' } #' transrate.hld <- function(file, cut.year,race){ nfiles <- length(file) data <- NULL for(it in 1:nfiles){ tdata <- read.table(file[it],sep=",",header=TRUE) if(!any(tdata$TypeLT==1)) stop("Currently only TypeLT 1 is implemented") names(tdata) <- gsub(".","",names(tdata),fixed=TRUE) tdata <- tdata[,c("Country","Year1","Year2","TypeLT","Sex","Age","AgeInt","qx")] tdata <- tdata[tdata$TypeLT==1,] #NEW - prej sem gledala tudi AgeInt, izkaze se, da ni treba. pri q(x) bi bilo vseeno tudi, ce bi gledala TypeLT=3. tdata <- tdata[!is.na(tdata$AgeInt),] #NEW - vrzem ven zadnji interval, ki gre v neskoncnost in vsi umrejo (inf hazard) if(!missing(race))tdata$race <- rep(race[it],nrow(tdata)) data <- rbind(data,tdata) } if(length(unique(data$Country))>1)warning("The data belongs to different countries") data <- data[order(data$Year1,data$Age),] data$qx <- as.character(data$qx) options(warn = -1) data$qx[data$qx=="."] <- NA data$qx <- as.numeric(data$qx) options(warn = 0) if(missing(cut.year)){ y1 <- unique(data$Year1) y2 <- unique(data$Year2) if(any(apply(cbind(y1[-1],y2[-length(y2)]),1,diff)!=-1))warning("Data is not given for all the cut.year between the minimum and the maximum, use argument 'cut.year'") } else y1 <- cut.year if(length(y1)!=length(unique(data$Year1)))stop("Length 'cut.year' must match the number of unique values of Year1") cp <- as.date(apply(matrix(y1,ncol=1),1,function(x){paste("1jan",x,sep="")})) dn2 <- as.character(y1) amax <- max(data$Age) a.fun <- function(data,amax){ mdata <- data[data$Sex==1,] wdata <- data[data$Sex==2,] men <-NULL women <- NULL k <- sum(mdata$Age==0) mind <- c(which(mdata$Age[-nrow(mdata)] != mdata$Age[-1]-1),nrow(mdata)) wind <- c(which(wdata$Age[-nrow(wdata)] != wdata$Age[-1]-1),nrow(wdata)) mst <- wst <- 1 for(it in 1:k){ qx <- mdata[mst:mind[it],]$qx lqx <- length(qx) if(lqx!=amax+1){ nmiss <- amax + 1 - lqx qx <- c(qx,rep(qx[lqx],nmiss)) } naqx <- max(which(!is.na(qx))) if(naqx!=amax+1) qx[(naqx+1):(amax+1)] <- qx[naqx] men <- cbind(men,qx) mst <- mind[it]+1 qx <- wdata[wst:wind[it],]$qx lqx <- length(qx) if(lqx!=amax+1){ nmiss <- amax + 1 - lqx qx <- c(qx,rep(qx[lqx],nmiss)) } naqx <- max(which(!is.na(qx))) if(naqx!=amax+1) qx[(naqx+1):(amax+1)] <- qx[naqx] women <- cbind(women,qx) wst <- wind[it]+1 } men<- -log(1-men)/365.241 women<- -log(1-women)/365.241 dims <- c(dim(men),2) array(c(men,women),dim=dims) } if(missing(race)){ out <- a.fun(data,amax) dims <- dim(out) attributes(out)<-list( dim=dims, dimnames=list(as.character(0:amax),as.character(y1),c("male","female")), dimid=c("age","year","sex"), factor=c(0,0,1),type=c(2,3,1), cutpoints=list((0:amax)*(365.241),cp,NULL), class="ratetable" ) } else{ race.val <- unique(race) if(length(race)!=length(file))stop("Length of 'race' must match the number of files") for(it in 1:length(race.val)){ if(it==1){ out <- a.fun(data[data$race==race.val[it],],amax) dims <- dim(out) out <- array(out,dim=c(dims,1)) } else{ out1 <- array(a.fun(data[data$race==race.val[it],],amax),dim=c(dims,1)) out <- array(c(out,out1),dim=c(dims,it)) } } attributes(out)<-list( dim=c(dims,it), dimnames=list(age=as.character(0:amax),year=as.character(y1),sex=c("male","female"),race=race.val), dimid=c("age","year","sex","race"), factor=c(0,0,1,1),type=c(2,3,1,1), cutpoints=list((0:amax)*(365.241),cp,NULL,NULL), class="ratetable" ) } attributes(out)$summary <- function (R) { x <- c(format(round(min(R[, 1])/365.241, 1)), format(round(max(R[, 1])/365.241, 1)), sum(R[, 3] == 1), sum(R[, 3] == 2)) x2 <- as.character(as.Date(c(min(R[, 2]), max(R[, 2])), origin=as.Date('1970-01-01'))) paste(" age ranges from", x[1], "to", x[2], "years\n", " male:", x[3], " female:", x[4], "\n", " date of entry from", x2[1], "to", x2[2], "\n") } out } #' Reorganize Data obtained from Human Mortality Database into a Ratetable #' Object #' #' The function assists in reorganizing the .txt files obtained from Human #' Mortality Database (http://www.mortality.org) into a ratetable object. #' #' This function works automatically with tables organised in the format #' provided by the Human Mortality Database. Download Life Tables for Males and #' Females separately from the column named 1x1 (period life tables, organized #' by date of death, yearly cutpoints for age as well as calendar year). #' #' If you wish to provide the data in the required format by yourself, note #' that the only two columns needed are calendar year (Year) and probability of #' death (qx). Death probabilities must be calculated up to age 110 (in yearly #' intervals). #' #' @param male a .txt file, containing the data on males. #' @param female a .txt file, containing the data on females. #' @return An object of class \code{ratetable}. #' @seealso \code{\link{ratetable}}, \code{\link{transrate.hld}}, #' \code{\link{joinrate}}, \code{\link{transrate}}. #' @references Package. Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' @keywords survival #' @examples #' #' \dontrun{ #' auspop <- transrate.hmd("mltper_1x1.txt","fltper_1x1.txt") #' } #' transrate.hmd <- function(male,female){ nfiles <- 2 men <- try(read.table(male,sep="",header=TRUE),silent=TRUE) if(class(men)=="try-error")men <- read.table(male,sep="",header=TRUE,skip=1) men <- men[,c("Year","Age","qx")] y1 <- sort(unique(men$Year)) ndata <- nrow(men)/111 if(round(ndata)!=ndata)stop("Each year must contain ages from 0 to 110") men <- matrix(men$qx, ncol=ndata) men <- matrix(as.numeric(men),ncol=ndata) women <- try(read.table(female,sep="",header=TRUE),silent=TRUE) if(class(women)=="try-error")women <- read.table(female,sep="",header=TRUE,skip=1) women <- women[,"qx"] if(length(women)!=length(men))stop("Number of rows in the table must be equal for both sexes") women <- matrix(women, ncol=ndata) women <- matrix(as.numeric(women),ncol=ndata) cp <- as.date(apply(matrix(y1,ncol=1),1,function(x){paste("1jan",x,sep="")})) dn2 <- as.character(y1) tfun <- function(vec){ ind <- which(vec == 1 | is.na(vec)) if(length(ind)>0)vec[min(ind):length(vec)] <- 0.999 vec } men <- apply(men,2,tfun) women <- apply(women,2,tfun) men<- -log(1-men)/365.241 women<- -log(1-women)/365.241 nr <- nrow(men)-1 dims <- c(dim(men),2) out <- array(c(men,women),dim=dims) attributes(out)<-list( dim=dims, dimnames=list(age=as.character(0:nr),year=as.character(y1),sex=c("male","female")), dimid=c("age","year","sex"), factor=c(0,0,1),type=c(2,3,1), cutpoints=list((0:nr)*(365.241),cp,NULL), class="ratetable" ) attributes(out)$summary <- function (R) { x <- c(format(round(min(R[, 1])/365.241, 1)), format(round(max(R[, 1])/365.241, 1)), sum(R[, 3] == 1), sum(R[, 3] == 2)) x2 <- as.character(as.Date(c(min(R[, 2]), max(R[, 2])), origin=as.Date('1970-01-01'))) paste(" age ranges from", x[1], "to", x[2], "years\n", " male:", x[3], " female:", x[4], "\n", " date of entry from", x2[1], "to", x2[2], "\n") } out } #' Join ratetables #' #' The function joins two or more objects organized as \code{ratetable} by #' adding a new dimension. #' #' This function joins two or more \code{ratetable} objects by adding a new #' dimension. The cutpoints of all the rate tables are compared and only the #' common intervals kept. If the intervals defined by the cutpoints are not of #' the same length, a warning message is displayed. Each rate table must have #' 3 dimensions, i.e. age, sex and year (the order is not important). #' #' @param tables a list of ratetables. If names are given, they are included as #' \code{dimnames}. #' @param dim.name the name of the added dimension. #' @return An object of class \code{ratetable}. #' @seealso \code{\link{ratetable}}, \code{\link{transrate.hld}}, #' \code{\link{transrate.hmd}}, \code{\link{transrate}}. #' @references Package: Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272-278. #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741-1749. #' @keywords survival #' @examples #' #' #newpop <- joinrate(list(Arizona=survexp.az,Florida=survexp.fl, #' # Minnesota=survexp.mn),dim.name="state") #' joinrate <- function(tables,dim.name="country"){ nfiles <- length(tables) if(is.null(names(tables))) names(tables) <- paste("D",1:nfiles,sep="") if(any(!unlist(lapply(tables,is.ratetable))))stop("Tables must be in ratetable format") if(length(attributes(tables[[1]])$dim)!=3)stop("Currently implemented only for ratetables with 3 dimensions") if(is.null(attr(tables[[1]],"dimid")))attr(tables[[1]],"dimid") <- names((attr(tables[[1]],"dimnames"))) for(it in 2:nfiles){ if(is.null(attr(tables[[it]],"dimid")))attr(tables[[it]],"dimid") <- names((attr(tables[[it]],"dimnames"))) if(length(attributes(tables[[it]])$dimid)!=3)stop("Each ratetable must have 3 dimensions: age, year and sex") mc <- match(attributes(tables[[it]])$dimid,attributes(tables[[1]])$dimid,nomatch=0) if(any(mc)==0) stop("Each ratetable must have 3 dimensions: age, year and sex") if(any(mc!=1:3)){ atts <- attributes(tables[[it]]) tables[[it]] <- aperm(tables[[it]],mc) atts$dimid <- atts$dimid[mc] atts$dimnames <- atts$dimnames[mc] atts$cutpoints <- atts$cutpoints[mc] atts$factor <- atts$factor[mc] atts$type <- atts$type[mc] atts$dim <- atts$dim[mc] attributes(tables[[it]]) <- atts } } list.eq <- function(l1,l2){ n <- length(l1) rez <- rep(TRUE,n) for(it in 1:n){ if(length(l1[[it]])!=length(l2[[it]]))rez[it] <- FALSE else if(any(l1[[it]]!=l2[[it]]))rez[it] <- FALSE } rez } equal <- rep(TRUE,3) for(it in 2:nfiles){ equal <- equal*list.eq(attributes(tables[[1]])$cutpoints,attributes(tables[[it]])$cutpoints) } kir <- which(!equal) newat <- attributes(tables[[1]]) imena <- list(d1=NULL,d2=NULL,d3=NULL) for(jt in kir){ listy <- NULL for(it in 1:nfiles){ listy <- c(listy,attributes(tables[[it]])$cutpoints[[jt]]) } imena[[jt]] <- names(table(listy)[table(listy) == nfiles]) if(!length(imena[[jt]]))stop(paste("There are no common cutpoints for dimension", attributes(tables[[1]])$dimid[jt])) } for(it in 1:nfiles){ keep <- lapply(dim(tables[[it]]),function(x)1:x) for(jt in kir){ meci <- which(match(attributes(tables[[it]])$cutpoints[[jt]],imena[[jt]],nomatch=0)!=0) if(it==1){ newat$dimnames[[jt]] <- attributes(tables[[it]])$dimnames[[jt]][meci] newat$dim[[jt]] <- length(imena[[jt]]) newat$cutpoints[[jt]] <- attributes(tables[[it]])$cutpoints[[jt]][meci] } if(length(meci)>1){if(max(diff(meci)!=1))warning(paste("The cutpoints for ",attributes(tables[[1]])$dimid[jt] ," are not equally spaced",sep=""))} keep[[jt]] <- meci } tables[[it]] <- tables[[it]][keep[[1]],keep[[2]],keep[[3]]] } dims <- newat$dim out <- array(tables[[1]],dim=c(dims,1)) for(it in 2:nfiles){ out1 <- array(tables[[it]],dim=c(dims,1)) out <- array(c(out,out1),dim=c(dims,it)) } mc <- 1:4 if(any(newat$factor>1)){ wh <- which(newat$factor>1) mc <- c(mc[-wh],wh) out <- aperm(out,mc) } newat$dim <- c(dims,nfiles)[mc] newat$dimid <- c(newat$dimid,dim.name)[mc] newat$cutpoints <- list(newat$cutpoints[[1]],newat$cutpoints[[2]],newat$cutpoints[[3]],NULL)[mc] newat$factor <- c(newat$factor,1)[mc] newat$type <- c(newat$type,1)[mc] newat$dimnames <- list(newat$dimnames[[1]],newat$dimnames[[2]],newat$dimnames[[3]],names(tables))[mc] names(newat$dimnames) <- newat$dimid attributes(out) <- newat out } mlfit <- function (b, p, x, offset, d, h, ds, y, maxiter, tol) { for (nit in 1:maxiter) { b0 <- b fd <- matrix(0, p, 1) sd <- matrix(0, p, p) if (nit == 1) { ebx <- exp(x %*% b) * exp(offset) l0 <- sum(d * log(h + ebx) - ds - y * ebx) } for (it in 1:p) { fd[it, 1] <- sum((d/(h + ebx) - y) * x[, it] * ebx) for (jt in 1:p) sd[it, jt] = sum((d/(h + ebx) - d * ebx/(h + ebx)^2 - y) * x[, it] * x[, jt] * ebx) } b <- b - solve(sd) %*% fd ebx <- exp(x %*% b) * exp(offset) l <- sum(d * log(h + ebx) - ds - y * ebx) bd <- abs(b - b0) if (max(bd) < tol) break() } out <- list(b = b, sd = sd, nit = nit, loglik = c(l0, l)) out } print.rs.br <- function (x, digits = max(options()$digits - 4, 3), ...) { invisible(print(x$table, digits = digits)) if (x$rho != 0) invisible(cat("Weighted Brownian bridge with rho=", x$rho, "\n")) } print.rsadd <- function (x, digits = max(3, getOption("digits") - 3), ...) { cat("\nCall: ", paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n\n", sep = "", "\n") if (length(coef(x))) { cat("Coefficients") cat(":\n") print.default(format(x$coefficients, digits = digits), print.gap = 2, quote = FALSE) } else cat("No coefficients\n\n") if(x$method=="EM") cat("\n", "Expected number of disease specific deaths: ",format(round(sum(x$Nie),2))," = ",format(round(100*sum(x$Nie)/sum(x$data$stat),1)),"% \n" ,sep="") if(x$method=="EM"|x$method=="max.lik"){ chi <- 2*max((x$loglik[2]-x$loglik[1]),0) if(x$method=="EM")df <- length(x$coef) else df <- length(x$coef)-length(x$int)+1 if(df>0){ p.val <- 1- pchisq(chi,df) if(x$method=="max.lik")cat("\n") cat("Likelihood ratio test=",format(round(chi,2)),", on ",df," df, p=",format(p.val),"\n",sep="") } else cat("\n") } cat("n=",nrow(x$data),sep="") if(length(x$na.action))cat(" (",length(x$na.action)," observations deleted due to missing)",sep="") cat("\n") if (length(x$warnme)) cat("\n", x$warnme, "\n\n") else cat("\n") invisible(x) } summary.rsadd <- function (object, correlation = FALSE, symbolic.cor = FALSE, ...) { if (inherits(object, "glm")) { p <- object$rank if (p > 0) { p1 <- 1:p Qr <- object$qr aliased <- is.na(coef(object)) coef.p <- object$coefficients[Qr$pivot[p1]] covmat <- chol2inv(Qr$qr[p1, p1, drop = FALSE]) dimnames(covmat) <- list(names(coef.p), names(coef.p)) var.cf <- diag(covmat) s.err <- sqrt(var.cf) tvalue <- coef.p/s.err dn <- c("Estimate", "Std. Error") pvalue <- 2 * pnorm(-abs(tvalue)) coef.table <- cbind(coef.p, s.err, tvalue, pvalue) dimnames(coef.table) <- list(names(coef.p), c(dn, "z value", "Pr(>|z|)")) df.f <- NCOL(Qr$qr) } else { coef.table <- matrix(, 0, 4) dimnames(coef.table) <- list(NULL, c("Estimate", "Std. Error", "t value", "Pr(>|t|)")) covmat.unscaled <- covmat <- matrix(, 0, 0) aliased <- is.na(coef(object)) df.f <- length(aliased) } ans <- c(object[c("call", "terms", "family", "iter", "warnme")], list(coefficients = coef.table, var = covmat, aliased = aliased)) if (correlation && p > 0) { dd <- s.err ans$correlation <- covmat/outer(dd, dd) ans$symbolic.cor <- symbolic.cor } class(ans) <- "summary.rsadd" } else if (inherits(object, "rsadd")) { aliased <- is.na(coef(object)) coef.p <- object$coef var.cf <- diag(object$var) s.err <- sqrt(var.cf) tvalue <- coef.p/s.err dn <- c("Estimate", "Std. Error") pvalue <- 2 * pnorm(-abs(tvalue)) coef.table <- cbind(coef.p, s.err, tvalue, pvalue) dimnames(coef.table) <- list(names(coef.p), c(dn, "z value", "Pr(>|z|)")) ans <- c(object[c("call", "terms", "iter", "var")], list(coefficients = coef.table, aliased = aliased)) if (correlation && sum(aliased) != length(aliased)) { dd <- s.err ans$correlation <- object$var/outer(dd, dd) ans$symbolic.cor <- symbolic.cor } class(ans) <- "summary.rsadd" } else ans <- object return(ans) } print.summary.rsadd <- function (x, digits = max(3, getOption("digits") - 3), symbolic.cor = x$symbolic.cor, signif.stars = getOption("show.signif.stars"), ...) { cat("\nCall:\n") cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n\n", sep = "") if (length(x$aliased) == 0) { cat("\nNo Coefficients\n") } else { cat("\nCoefficients:\n") coefs <- x$coefficients if (!is.null(aliased <- x$aliased) && any(aliased)) { cn <- names(aliased) coefs <- matrix(NA, length(aliased), 4, dimnames = list(cn, colnames(coefs))) coefs[!aliased, ] <- x$coefficients } printCoefmat(coefs, digits = digits, signif.stars = signif.stars, na.print = "NA", ...) } if (length(x$warnme)) cat("\n", x$warnme, "\n") correl <- x$correlation if (!is.null(correl)) { p <- NCOL(correl) if (p > 1) { cat("\nCorrelation of Coefficients:\n") if (is.logical(symbolic.cor) && symbolic.cor) { print(symnum(correl, abbr.colnames = NULL)) } else { correl <- format(round(correl, 2), nsmall = 2, digits = digits) correl[!lower.tri(correl)] <- "" print(correl[-1, -p, drop = FALSE], quote = FALSE) } } } cat("\n") invisible(x) } #' Excess hazard function smoothing #' #' An Epanechnikov kernel function based smoother for smoothing the baseline #' excess hazard calculated by the \code{rsadd} function with the \code{EM} #' method. #' #' The function performs Epanechnikov kernel smoothing. The follow up time is #' divided (according to percentiles of event times) into several intervals #' (number of intervals defined by \code{n.bwin}) in which the width is #' calculated as a factor of the maximum span between event times. Boundary #' effects are also taken into account on both sides. #' #' @param fit Fit from the additive relative survival model using the \code{EM} #' method. #' @param bwin The relative width of the smoothing window (default is 1). #' @param times The times at which the smoother is to be evaluated. If missing, #' it is evaluated at all event times. #' @param n.bwin Number of times that the window width may change. #' @param left If \code{FALSE} (default) smoothing is performed symmetrically, #' if \code{TRUE} only leftside neighbours are considered. #' @return A list with two components: \item{lambda}{the smoothed excess #' baseline hazard function} \item{times}{the times at which the smoothed #' excess baseline hazard is evaluated.} #' @seealso \code{\link{rsadd}}, #' @references Package. Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' #' EM algorithm: Pohar Perme M., Henderson R., Stare, J. (2009) "An approach to #' estimation in relative survival regression." Biostatistics, \bold{10}: #' 136--146. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #fit an additive model with the EM method #' fit <- rsadd(Surv(time,cens)~sex+age,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,int=5,method="EM") #' sm <- epa(fit) #' plot(sm$times,sm$lambda) #' epa <- function(fit,bwin,times,n.bwin=16,left=FALSE){ #bwin ... width of the window, relative to the default (1) #fit ... EM fit #times... times at which the smoothed plot is calculated #n.bwin ... number of different windows #left ... only predictable smoothing utd <- fit$times if(missing(times))times <- seq(1,max(utd),length=100) if(max(times)>max(utd)){ warning("Cannot extrapolate beyond max event time") times <- pmax(times,max(utd)) } nutd <- length(utd) nt4 <- c(1,ceiling(nutd*(1:n.bwin)/n.bwin)) if(missing(bwin))bwin <- rep(length(fit$times)/100,n.bwin) else bwin <- rep(bwin*length(fit$times)/100,n.bwin) for(it in 1:n.bwin){ bwin[it] <- bwin[it]*max(diff(utd[nt4[it]:nt4[it+1]])) } while(utd[nt4[2]]tvs[nt4[it]] & t<=tvs[nt4[it + 1]]] if(length(cajti)){ q <- min( cajti/b[it],1,(Rb-cajti)/b[it]) if(q<1 & length(cajti)>1){ jc <- 1 while(jc <=length(cajti)){ qd <- pmin( cajti[jc:length(cajti)]/b[it],1,(Rb-cajti[jc:length(cajti)])/b[it]) q <- qd[1] if(q==1){ casi <- cajti[jc:length(cajti)][qd==1] q <- 1 jc <- sum(qd==1)+jc } else{ casi <- cajti[jc] jc <- jc+1 } kmat1 <- outer(casi, tv, "-")/b[it] #z - to je ok if(q<1){ if(casi>b[it]) kmt1 <- -kmat1 vr <- kt(q,kmat1)*(kmat1>=-1 & kmat1 <= q) } else vr <- pmax((1 - kmat1^2) * .75,0) kmat <- rbind(kmat, vr/b[it]) totcajti <- c(totcajti,casi) } } else{ kmat1 <- outer(cajti, tv, "-")/b[it] #z - to je ok q <- min( cajti/b[it],1) if(q<1)vr <- kt(q,kmat1)*(kmat1>=-1 & kmat1 <= q) else vr <- pmax((1 - kmat1^2) * .75,0) kmat <- rbind(kmat, vr/b[it]) totcajti <- c(totcajti,cajti) }#else }#if }#for kmat } kern <- function (times,td, b, nt4) { n <- length(td) ttemp <- td[td >= b[1]] ntemp <- length(ttemp) if (ntemp == n) nt4 <- c(0, nt4[-1]) td <- c(0,td) nt4 <- c(1,nt4+1) b <- c(b[1],b) krn <- Kern(times, td, b, max(td), nt4) krn } exp.prep <- function (x, y,ratetable,status,times,fast=FALSE,ys,prec,cmp=F,netweiDM=FALSE) { #function that prepares the data for C function call #x= matrix of demographic covariates - each individual has one line #y= follow-up time for each individual (same length as nrow(x)!) #ratetable= rate table used for calculation #status= status for each individual (same length as nrow(x)!), not needed if we only need Spi, status needed for rs.surv #times= times at which we wish to evaluate the quantities, not needed if we only need Spi, times needed for rs.surv #fast=for mpp method only #netweiDM=should new netwei script be used x <- as.matrix(x) if (ncol(x) != length(dim(ratetable))) stop("x matrix does not match the rate table") atts <- attributes(ratetable) cuts <- atts$cutpoints if (is.null(atts$type)) { rfac <- atts$factor us.special <- (rfac > 1) } else { rfac <- 1 * (atts$type == 1) us.special <- (atts$type == 4) } if (length(rfac) != ncol(x)) stop("Wrong length for rfac") if (any(us.special)) { if (sum(us.special) > 1) stop("Two columns marked for special handling as a US rate table") cols <- match(c("age", "year"), atts$dimid) if (any(is.na(cols))) stop("Ratetable does not have expected shape") if (exists("as.Date")) { bdate <- as.Date("1960/1/1") + (x[, cols[2]] - x[, cols[1]]) byear <- format(bdate, "%Y") offset <- as.numeric(bdate - as.Date(paste(byear, "01/01", sep = "/"))) } else if (exists("date.mdy")) { bdate <- as.date(x[, cols[2]] - x[, cols[1]]) byear <- date.mdy(bdate)$year offset <- bdate - mdy.date(1, 1, byear) } else stop("Can't find an appropriate date class\n") x[, cols[2]] <- x[, cols[2]] - offset if (any(rfac > 1)) { temp <- which(us.special) nyear <- length(cuts[[temp]]) nint <- rfac[temp] cuts[[temp]] <- round(approx(nint * (1:nyear), cuts[[temp]], nint:(nint * nyear))$y - 1e-04) } } if(!missing(status)){ #the function was called from rs.surv if(length(status)!=nrow(x)) stop("Wrong length for status") if(missing(times)) times <- sort(unique(y)) if (any(times < 0)) stop("Negative time point requested") ntime <- length(times) if(missing(ys)) ys <- rep(0,length(y)) # times2 <- times # times2[1] <- preci if(cmp) temp <- .Call("cmpfast", as.integer(rfac), #fast=pohar-perme or ederer2 - data from pop. tables only while under follow-up as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, ys,as.integer(status), times,PACKAGE="relsurv") else if(fast&!missing(prec)) temp <- .Call("netfastpinter2", as.integer(rfac), #fast=pohar-perme or ederer2 - data from pop. tables only while under follow-up as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, ys,as.integer(status), times,prec,PACKAGE="relsurv") else if(fast&missing(prec)) temp <- .Call("netfastpinter", as.integer(rfac), #fast=pohar-perme or ederer2 - data from pop. tables only while under follow-up as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, ys,as.integer(status), times,PACKAGE="relsurv") else if(netweiDM==TRUE) temp <- .Call("netweiDM", as.integer(rfac), as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, ys,as.integer(status), times,PACKAGE="relsurv") else temp <- .Call("netwei", as.integer(rfac), as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, as.integer(status), times,PACKAGE="relsurv") } else{ #only expected survival at time y is needed for each individual if(length(y)==1)y <- rep(y,nrow(x)) if(length(y)!=nrow(x)) stop("Wrong length for status") temp <- .Call("expc", as.integer(rfac), as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y,PACKAGE="relsurv") temp <- temp$surv } temp } #' Compute a Relative Survival Curve #' #' Computes an estimate of the relative survival curve using the Ederer I, #' Ederer II method, Pohar-Perme method or the Hakulinen method #' #' NOTE: The follow-up time must be specified in days. The \code{ratetable} #' being used may have different variable names and formats than the user's #' data set, this is dealt with by the \code{rmap} argument. For example, if #' age is in years in the data set but in days in the \code{ratetable} object, #' age=age*365.241 should be used. The calendar year can be in any date format #' (date, Date and POSIXt are allowed), the date formats in the #' \code{ratetable} and in the data may differ. #' #' The potential censoring times needed for the calculation of the expected #' survival by the Hakulinen method are calculated automatically. The times of #' censoring are left as they are, the times of events are replaced with #' \code{fin.date - year}. #' #' The calculation of the Pohar-Perme estimate is more time consuming since #' more data are needed from the population tables. The old version of the #' function, now named \code{rs.survo} can be used as a faster version for the #' Hakulinen and Ederer II estimate. #' #' Numerical integration is required for Pohar-Perme estimate. The integration #' precision is set with argument \code{precision}, which defaults to daily #' intervals, a default that should give enough precision for any practical #' purpose. #' #' Note that even though the estimate is always calculated using numerical #' integration, only the values at event and censoring times are reported. #' Hence, the function \code{plot} draws a step function in between and the #' function \code{summary} reports the value at the last event or censoring #' time before the specified time. If the output of the estimated values at #' other points is required, this should be specified with argument #' \code{add.times}. #' #' @param formula a formula object, with the response as a \code{Surv} object #' on the left of a \code{~} operator, and, if desired, terms separated by the #' \code{+} operator on the right. If no strata are used, \code{~1} should be #' specified. #' #' NOTE: The follow-up time must be in days. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param ratetable a table of event rates, organized as a \code{ratetable} #' object, such as \code{slopop}. #' @param na.action a missing-data filter function, applied to the model.frame, #' after any subset argument has been used. Default is #' \code{options()$na.action}. #' @param fin.date the date of the study ending, used for calculating the #' potential follow-up times in the Hakulinen method. If missing, it is #' calculated as \code{max(year+time)}. #' @param method the method for calculating the relative survival. The options #' are \code{pohar-perme}(default), \code{ederer1}, \code{ederer2} and #' \code{hakulinen}. #' @param conf.type one of \code{plain}, \code{log} (the default), or #' \code{log-log}. The first option causes the standard intervals curve +- k #' *se(curve), where k is determined from conf.int. The log option calculates #' intervals based on the cumulative hazard or log(survival). The last option #' bases intervals on the log hazard or log(-log(survival)). #' @param conf.int the level for a two-sided confidence interval on the #' survival curve(s). Default is 0.95. #' @param type defines how survival estimates are to be calculated given the #' hazards. The default (\code{kaplan-meier}) calculates the product integral, #' whereas the option \code{fleming-harrington} exponentiates the negative #' cumulative hazard. Analogous to the usage in \code{survfit}. #' @param add.times specific times at which the curve should be evaluated. #' @param precision Precision for numerical integration. Default is 1, which #' means that daily intervals are taken, the value may be decreased to get a #' higher precision or increased to achieve a faster calculation. The #' calculation intervals always include at least all times of event and #' censoring as border points. #' @param rmap an optional list to be used if the variables are not organized #' and named in the same way as in the \code{ratetable} object. See details #' below. #' @return a \code{survfit} object; see the help on \code{survfit.object} for #' details. The \code{survfit} methods are used for \code{print}, #' \code{summary}, \code{plot}, \code{lines}, and \code{points}. #' @seealso \code{survfit}, \code{survexp} #' @references Package: Pohar Perme, M., Pavlic, K. (2018) "Nonparametric #' Relative Survival Analysis with the R Package relsurv". Journal of #' Statistical Software. 87(8), 1-27, doi: "10.18637/jss.v087.i08" Theory: #' Pohar Perme, M., Esteve, J., Rachet, B. (2016) "Analysing Population-Based #' Cancer Survival - Settling the Controversies." BMC Cancer, 16 (933), 1-8. #' doi:10.1186/s12885-016-2967-9. Theory: Pohar Perme, M., Stare, J., Esteve, #' J. (2012) "On Estimation in Relative Survival", Biometrics, 68(1), 113-120. #' doi:10.1111/j.1541-0420.2011.01640.x. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #calculate the relative survival curve #' #note that the variable year must be given in a date format and that #' #age must be multiplied by 365.241 in order to be expressed in days. #' rs.surv(Surv(time,cens)~sex,rmap=list(age=age*365.241), ratetable=slopop,data=rdata) #' rs.surv <- function (formula = formula(data), data = parent.frame(),ratetable = relsurv::slopop, na.action, fin.date, method = "pohar-perme", conf.type = "log", conf.int = 0.95,type="kaplan-meier",add.times,precision=1,rmap) #formula: for example Surv(time,cens)~sex #data: the observed data set #ratetable: the population mortality tables #conf.type: confidence interval calculation (plain, log or log-log) #conf.int: confidence interval { call <- match.call() if (!missing(rmap)) { rmap <- substitute(rmap) } rform <- rformulate(formula,data, ratetable, na.action,rmap) data <- rform$data #the data set type <- match.arg(type, c("kaplan-meier", "fleming-harrington")) #method of hazard -> survival scale transformation type <- match(type, c("kaplan-meier", "fleming-harrington")) method <- match.arg(method,c("pohar-perme", "ederer2", "hakulinen","ederer1")) #method of relative surv. curve estimation method <- match(method,c("pohar-perme", "ederer2", "hakulinen","ederer1")) conf.type <- match.arg(conf.type,c("plain","log","log-log")) #conf. interval type if (method == 3) { #need potential follow-up time for Hak. method R <- rform$R coll <- match("year", attributes(ratetable)$dimid) year <- R[, coll] #calendar year in the data if (missing(fin.date)) fin.date <- max(rform$Y + year) #final date for everybody set to the last day observed Y2 <- rform$Y #change into potential follow-up time if (length(fin.date) == 1) #if final date equal for everyone Y2[rform$status == 1] <- fin.date - year[rform$status == 1]#set pot.time for those that died (equal to censoring time for others) else if (length(fin.date) == nrow(rform$R)) Y2[rform$status == 1] <- fin.date[rform$status == 1] - year[rform$status == 1] else stop("fin.date must be either one value or a vector of the same length as the data") status2 <- rep(0, nrow(rform$X)) #stat2=0 for everyone } p <- rform$m #number of covariates if (p > 0) #if covariates data$Xs <- strata(rform$X[, ,drop=FALSE ]) #make strata according to covariates else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 se.fac <- sqrt(qchisq(conf.int, 1)) #factor needed for confidence interval out <- NULL out$n <- table(data$Xs) #table of strata out$time <- out$n.risk <- out$n.event <- out$n.censor <- out$surv <- out$std.err <- out$strata <- NULL #out$index <- out$strata0 <- NULL # out$index = indices of the original times from the data among the times used for calculations # out$strata0 = the same as out$strata but only on the original times from the data for (kt in 1:length(out$n)) { #for each stratum inx <- which(data$Xs == names(out$n)[kt]) #individuals within this stratum tis <- sort(unique(rform$Y[inx])) #unique times #if (method == 1 & all.times == TRUE) tis <- sort(union(rform$Y[inx],as.numeric(1:max(floor(rform$Y[inx]))))) #1-day long intervals used - to take into the account the continuity of the pop. part if (method == 1 & !missing(add.times)){ #tis <- sort(union(rform$Y[inx],as.numeric(1:max(floor(rform$Y[inx]))))) #1-day long intervals used - to take into the account the continuity of the pop. part add.times <- pmin(as.numeric(add.times),max(rform$Y[inx])) tis <- sort(union(rform$Y[inx],as.numeric(add.times))) #1-day long intervals used - to take into the account the continuity of the pop. part } if(method==3)tis <- sort(unique(pmin(max(tis),c(tis,Y2[inx])))) #add potential times in case of Hakulinen #out$index <- c(out$index, which(tis %in% rform$Y[inx])+length(out$time)) temp <- exp.prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis,fast=(method<3),prec=precision) #calculate the values for each interval of time out$time <- c(out$time, tis) #add times out$n.risk <- c(out$n.risk, temp$yi) #add number at risk for each time out$n.event <- c(out$n.event, temp$dni) #add number of events for each time out$n.censor <- c(out$n.censor, c(-diff(temp$yi),temp$yi[length(temp$yi)]) - temp$dni) #add number of censored for each time if(method==1){ #pohar perme method #approximate1 <- (temp$yidlisi/temp$yisi +temp$yidlisitt/temp$yisitt)/2 #approximate <- (temp$yidlisiw/temp$yisi +temp$yidlisiw/temp$yisitt)/2 #approximation for integration approximate <- temp$yidlisiw #haz <- temp$dnisi/temp$yisi - temp$yidlisi/temp$yisi #cumulative hazard increment on each interval haz <- temp$dnisi/temp$yisi - approximate #cumulative hazard increment on each interval out$std.err <- c(out$std.err, sqrt(cumsum(temp$dnisisq/(temp$yisi)^2))) #standard error on each interval } else if(method==2){ #ederer2 method haz <- temp$dni/temp$yi - temp$yidli/temp$yi #cumulative hazard increment on each interval out$std.err <- c(out$std.err, sqrt(cumsum(temp$dni/(temp$yi)^2))) #standard error on each interval } else if(method==3){ #Hakulinen method temp2 <- exp.prep(rform$R[inx,,drop=FALSE],Y2[inx],ratetable,status2[inx],times=tis) #calculate the values for each interval of time popsur <- exp(-cumsum(temp2$yisidli/temp2$yisis)) #population survival haz <- temp$dni/temp$yi #observed hazard on each interval out$std.err <- c(out$std.err, sqrt(cumsum(temp$dni/(temp$yi)^2))) #standard error on each interval } else if(method==4){ #Ederer I popsur <- temp$sis/length(inx) #population survival haz <- temp$dni/temp$yi #observed hazard on each interval out$std.err <- c(out$std.err, sqrt(cumsum(temp$dni/(temp$yi)^2))) #standard error on each interval } if(type==2)survtemp <- exp(-cumsum(haz)) else survtemp <- cumprod(1-haz) if(method>2){ survtemp <- survtemp/popsur } out$surv <- c(out$surv,survtemp) out$strata <- c(out$strata, length(tis)) #number of times in this strata #out$strata0 <- c(out$strata0, length(unique(rform$Y[inx]))) } if (conf.type == "plain") { out$lower <- as.vector(out$surv - out$std.err * se.fac * #surv + fac*se out$surv) out$upper <- as.vector(out$surv + out$std.err * se.fac * out$surv) } else if (conf.type == "log") { #on log scale and back out$lower <- exp(as.vector(log(out$surv) - out$std.err * se.fac)) out$upper <- exp(as.vector(log(out$surv) + out$std.err * se.fac)) } else if (conf.type == "log-log") { #on log-log scale and back out$lower <- exp(-exp(as.vector(log(-log(out$surv)) - out$std.err * se.fac/log(out$surv)))) out$upper <- exp(-exp(as.vector(log(-log(out$surv)) + out$std.err * se.fac/log(out$surv)))) } names(out$strata) <- names(out$n) #names(out$strata0) <- names(out$n) if (p == 0){ out$strata <- NULL #if no covariates #out$strata0 <- NULL } #if (method != 1) out$index <- out$strata0 <- NULL # if method != pohar-perme out$n <- as.vector(out$n) out$conf.type <- conf.type out$conf.int <- conf.int out$method <- method out$call <- call out$type <- "right" class(out) <- c("survfit", "rs.surv") out } #' Net Expected Sample Size Is Estimated #' #' Calculates how the sample size decreases in time due to population mortality #' #' The function calculates the sample size we can expect at a certain time #' point if the patients die only due to population causes (population survival #' * initial sample size in a certain category), i.e. the number of individuals #' that remains at risk at given timepoints after the individuals who die due #' to population causes are removed. The result should be used as a guideline #' for the sensible length of follow-up interval when calculating the net #' survival. #' #' The first column of the output reports the number of individuals at time 0. #' The last column of the output reports the conditional expected (population) #' survival time for each subgroup. #' #' @param formula a formula object, same as in \code{rs.surv}. The right-hand #' side of the formula object includes the variable that defines the subgroups #' (a variable of type \code{factor}) by which the expected sample size is to #' be calculated. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param ratetable a table of event rates, organized as a \code{ratetable} #' object, such as \code{slopop}. #' @param times Times at which the calculation should be evaluated - in years! #' @param rmap an optional list to be used if the variables are not organized #' and named in the same way as in the \code{ratetable} object. See details of #' the \code{rs.surv} function. #' @return A list of values. #' @seealso \code{rs.surv} #' @references Pohar Perme, M., Pavlic, K. (2018) "Nonparametric Relative #' Survival Analysis with the R Package relsurv". Journal of Statistical #' Software. 87(8), 1-27, doi: "10.18637/jss.v087.i08" #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' rdata$agegr <-cut(rdata$age,seq(40,95,by=5)) #' nessie(Surv(time,cens)~agegr,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,times=c(1,3,5,10,15)) #' nessie <- function (formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop,times,rmap) #formula: for example Surv(time,cens)~sex #data: the observed data set #ratetable: the population mortality tables #times: the times at which to report NESS, if no default, then all unique times { call <- match.call() if (!missing(rmap)) { rmap <- substitute(rmap) } na.action <- NA #set the object just to be able to execute the rformulate call rform <- rformulate(formula, data, ratetable,na.action, rmap) #get the data ready templab <- attr(rform$Terms,"term.labels") if(!is.null(attr(rform$Terms,"specials")$ratetable))templab <- templab[-length(templab)] #delete the last term in the formula if the ratetable argument is there nameslist <- vector("list",length(templab)) for(it in 1:length(nameslist)){ valuetab <- table(data[,match(templab[it],names(data))]) nameslist[[it]] <- paste(templab[it],names(valuetab),sep="") } names(nameslist) <- templab data <- rform$data #the data set p <- rform$m #number of covariates if (p > 0) { #if covariates data$Xs <- my.strata(rform$X[,,drop=F],nameslist=nameslist) #make strata according to covariates #data$Xs <- factor(data$Xs,levels=nameslist) #order them in the same way as namelist } else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 if(!missing(times)) tis <- times else tis <- unique(sort(floor(rform$Y/365.241))) #unique years of follow-up tis <- unique(c(0,tis)) tisd <- tis*365.241 out <- NULL out$n <- table(data$Xs) #table of strata out$sp <- out$strata <- NULL # for (kt in 1:length(out$n)) { #for each stratum for (kt in order(names(table(data$Xs)))) { #for each stratum inx <- which(data$Xs == names(out$n)[kt]) #individuals within this stratum temp <- exp.prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tisd,fast=FALSE) #calculate the values for each interval of time out$time <- c(out$time, tisd) #add times out$sp <- c(out$sp, temp$sis) #add expected number of individuals alive out$strata <- c(out$strata, length(tis)) #number of times in this strata temp <- exp.prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=(seq(0,100,by=.5)*365.241)[-1],fast=FALSE) #calculate the values for each interval of time out$povp <- c(out$povp,mean(temp$sit/365.241)) } names(out$strata) <- names(out$n)[order(names(table(data$Xs)))] if (p == 0) out$strata <- NULL #if no covariates mata <- matrix(out$sp,ncol=length(tis),byrow=TRUE) mata <- data.frame(mata) mata <- cbind(mata,out$povp) row.names(mata) <- names(out$n)[order(names(table(data$Xs)))] names(mata) <- c(tis,"c.exp.surv") cat("\n") print(round(mata,1)) cat("\n") out$mata <- mata out$n <- as.vector(out$n) class(out) <- "nessie" invisible(out) } rs.period <- function (formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, na.action, fin.date, method = "pohar-perme", conf.type = "log", conf.int = 0.95,type="kaplan-meier",winst,winfin,diag.date,rmap) #formula: for example Surv(time,cens)~sex #data: the observed data set #ratetable: the population mortality tables #conf.type: confidence interval calculation (plain, log or log-log) #conf.int: confidence interval #winst: start of the period window (inclusive) #winfin: end of the period window (inclusive) { call <- match.call() if (!missing(rmap)) { rmap <- substitute(rmap) } rform <- rformulate(formula, data, ratetable, na.action,rmap) #get the data ready data <- rform$data #the data set type <- match.arg(type, c("kaplan-meier", "fleming-harrington")) #method of hazard -> survival scale transformation type <- match(type, c("kaplan-meier", "fleming-harrington")) method <- match.arg(method,c("pohar-perme", "ederer2", "hakulinen","ederer1")) #method of relative surv. curve estimation method <- match(method,c("pohar-perme", "ederer2", "hakulinen","ederer1")) conf.type <- match.arg(conf.type,c("plain","log","log-log")) #conf. interval type #machinations needed for period survival: R <- rform$R coll <- match("year", attributes(ratetable)$dimid) year <- R[, coll] #calendar year in the data ys <- as.numeric(winst - year) yf <- as.numeric(winfin - year) relv <- which(ys <= rform$Y & yf>0) #relevant individuals -> live up to the period window and were diagnosed before window end centhem <- which(yf < rform$Y) #censor these - their event happens outside of the period window rform$status[centhem] <- 0 rform$Y[centhem] <- yf[centhem] rform$Y <- rform$Y[relv] rform$X <- rform$X[relv,,drop=F] rform$R <- rform$R[relv,,drop=F] rform$status <- rform$status[relv] data <- data[relv,,drop=F] ys <- ys[relv] yf <- yf[relv] year <- year[relv] if (method == 3) { #need potential follow-up time for Hak. method if (missing(fin.date)) fin.date <- max(rform$Y + year) #final date for everybody set to the last day observed Y2 <- rform$Y #change into potential follow-up time if (length(fin.date) == 1) #if final date equal for everyone Y2[rform$status == 1] <- fin.date - year[rform$status == 1]#set pot.time for those that died (equal to censoring time for others) else if (length(fin.date[relv]) == nrow(rform$R)) { fin.date <- fin.date[relv] Y2[rform$status == 1] <- fin.date[rform$status == 1] - year[rform$status == 1] } else stop("fin.date must be either one value of a vector of the same length as the data") status2 <- rep(0, nrow(rform$X)) #stat2=0 for everyone } p <- rform$m #number of covariates if (p > 0) #if covariates data$Xs <- strata(rform$X[, ,drop=FALSE ]) #make strata according to covariates else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 se.fac <- sqrt(qchisq(conf.int, 1)) #factor needed for confidence interval out <- NULL out$n <- table(data$Xs) #table of strata out$time <- out$n.risk <- out$n.event <- out$n.censor <- out$surv <- out$std.err <- out$strata <- NULL for (kt in 1:length(out$n)) { #for each stratum inx <- which(data$Xs == names(out$n)[kt]) #individuals within this stratum tis <- sort(unique(rform$Y[inx])) #unique times if(method==3)tis <- sort(unique(pmin(max(tis),c(tis,Y2[inx])))) #add potential times in case of Hakulinen ys <- pmax(ys,0) #tis <- sort(unique(c(tis,ys[ys>0]-1,ys[ys>0]))) tis <- sort(unique(c(tis,ys[ys>0]))) tis <- sort(unique(c(tis,tis-1,tis+1))) #the day after exiting, the day before entering tis <- tis[-length(tis)] #exclude the largest since it is beyond observation time (1 day later) temp <- exp.prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis,fast=(method<3),ys=ys) #calculate the values for each interval of time out$time <- c(out$time, tis) #add times out$n.risk <- c(out$n.risk, temp$yi) #add number at risk for each time out$n.event <- c(out$n.event, temp$dni) #add number of events for each time out$n.censor <- c(out$n.censor, c(-diff(temp$yi),temp$yi[length(temp$yi)]) - temp$dni) #add number of censored for each time if(method==1){ #pohar perme method haz <- temp$dnisi/temp$yisi - temp$yidlisi/temp$yisi #cumulative hazard increment on each interval out$std.err <- c(out$std.err, sqrt(cumsum(temp$dnisisq/(temp$yisi)^2))) #standard error on each interval } else if(method==2){ #ederer2 method haz <- temp$dni/temp$yi - temp$yidli/temp$yi #cumulative hazard increment on each interval out$std.err <- c(out$std.err, sqrt(cumsum(temp$dni/(temp$yi)^2))) #standard error on each interval } else if(method==3){ #Hakulinen method temp2 <- exp.prep(rform$R[inx,,drop=FALSE],Y2[inx],rform$ratetable,status2[inx],times=tis,ys=ys) #calculate the values for each interval of time popsur <- exp(-cumsum(temp2$yisidli/temp2$yisis)) #population survival haz <- temp$dni/temp$yi #observed hazard on each interval out$std.err <- c(out$std.err, sqrt(cumsum(temp$dni/(temp$yi)^2))) #standard error on each interval } else if(method==4){ #Ederer I popsur <- temp$sis/length(inx) #population survival haz <- temp$dni/temp$yi #observed hazard on each interval out$std.err <- c(out$std.err, sqrt(cumsum(temp$dni/(temp$yi)^2))) #standard error on each interval } if(type==2)survtemp <- exp(-cumsum(haz)) else survtemp <- cumprod(1-haz) if(method>2){ survtemp <- survtemp/popsur } out$surv <- c(out$surv,survtemp) out$strata <- c(out$strata, length(tis)) #number of times in this strata } if (conf.type == "plain") { out$lower <- as.vector(out$surv - out$std.err * se.fac * #surv + fac*se out$surv) out$upper <- as.vector(out$surv + out$std.err * se.fac * out$surv) } else if (conf.type == "log") { #on log scale and back out$lower <- exp(as.vector(log(out$surv) - out$std.err * se.fac)) out$upper <- exp(as.vector(log(out$surv) + out$std.err * se.fac)) } else if (conf.type == "log-log") { #on log-log scale and back out$lower <- exp(-exp(as.vector(log(-log(out$surv)) - out$std.err * se.fac/log(out$surv)))) out$upper <- exp(-exp(as.vector(log(-log(out$surv)) + out$std.err * se.fac/log(out$surv)))) } names(out$strata) <- names(out$n) if (p == 0) out$strata <- NULL #if no covariates out$n <- as.vector(out$n) out$conf.type <- conf.type out$conf.int <- conf.int out$method <- method out$call <- call out$type <- "right" class(out) <- c("survfit", "rs.surv") out } #' expprep2 function #' #' Helper calculation function using C code. Saved also as exp.prep (unexported #' function). #' #' Helper function used in rs.surv and other relsurv functions. #' #' @param x matrix of demographic covariates - each individual has one line #' @param y follow-up time for each individual (same length as nrow(x)) #' @param ratetable rate table used for calculation #' @param status status for each individual (same length as nrow(x)!), not #' needed if we only need Spi, status needed for rs.surv #' @param times times at which we wish to evaluate the quantities, not needed #' if we only need Spi, times needed for rs.surv #' @param fast for mpp method only #' @param ys entry times (if empty, individuals are followed from time 0) #' @param prec deprecated #' @param cmp should cmpfast.C be used #' @param netweiDM should new netwei script be used #' @return List containing the calculated hazards and probabilities using the #' population mortality tables. #' @seealso rs.surv #' @keywords survival #' @export expprep2 expprep2 <- function (x, y,ratetable,status,times,fast=FALSE,ys,prec,cmp=F,netweiDM=FALSE) { #function that prepares the data for C function call #x= matrix of demographic covariates - each individual has one line #y= follow-up time for each individual (same length as nrow(x)!) #ratetable= rate table used for calculation #status= status for each individual (same length as nrow(x)!), not needed if we only need Spi, status needed for rs.surv #times= times at which we wish to evaluate the quantities, not needed if we only need Spi, times needed for rs.surv #fast=for mpp method only #netweiDM=should new netwei script be used x <- as.matrix(x) if (ncol(x) != length(dim(ratetable))) stop("x matrix does not match the rate table") atts <- attributes(ratetable) cuts <- atts$cutpoints if (is.null(atts$type)) { rfac <- atts$factor us.special <- (rfac > 1) } else { rfac <- 1 * (atts$type == 1) us.special <- (atts$type == 4) } if (length(rfac) != ncol(x)) stop("Wrong length for rfac") if (any(us.special)) { if (sum(us.special) > 1) stop("Two columns marked for special handling as a US rate table") cols <- match(c("age", "year"), atts$dimid) if (any(is.na(cols))) stop("Ratetable does not have expected shape") if (exists("as.Date")) { bdate <- as.Date("1960/1/1") + (x[, cols[2]] - x[, cols[1]]) byear <- format(bdate, "%Y") offset <- as.numeric(bdate - as.Date(paste(byear, "01/01", sep = "/"))) } else if (exists("date.mdy")) { bdate <- as.date(x[, cols[2]] - x[, cols[1]]) byear <- date.mdy(bdate)$year offset <- bdate - mdy.date(1, 1, byear) } else stop("Can't find an appropriate date class\n") x[, cols[2]] <- x[, cols[2]] - offset if (any(rfac > 1)) { temp <- which(us.special) nyear <- length(cuts[[temp]]) nint <- rfac[temp] cuts[[temp]] <- round(approx(nint * (1:nyear), cuts[[temp]], nint:(nint * nyear))$y - 1e-04) } } if(!missing(status)){ #the function was called from rs.surv if(length(status)!=nrow(x)) stop("Wrong length for status") if(missing(times)) times <- sort(unique(y)) if (any(times < 0)) stop("Negative time point requested") ntime <- length(times) if(missing(ys)) ys <- rep(0,length(y)) # times2 <- times # times2[1] <- preci if(cmp) temp <- .Call("cmpfast", as.integer(rfac), #fast=pohar-perme or ederer2 - data from pop. tables only while under follow-up as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, ys,as.integer(status), times,PACKAGE="relsurv") else if(fast&!missing(prec)) temp <- .Call("netfastpinter2", as.integer(rfac), #fast=pohar-perme or ederer2 - data from pop. tables only while under follow-up as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, ys,as.integer(status), times,prec,PACKAGE="relsurv") else if(fast&missing(prec)) temp <- .Call("netfastpinter", as.integer(rfac), #fast=pohar-perme or ederer2 - data from pop. tables only while under follow-up as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, ys,as.integer(status), times,PACKAGE="relsurv") else if(netweiDM==TRUE) temp <- .Call("netweiDM", as.integer(rfac), as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, ys,as.integer(status), times,PACKAGE="relsurv") else temp <- .Call("netwei", as.integer(rfac), as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, as.integer(status), times,PACKAGE="relsurv") } else{ #only expected survival at time y is needed for each individual if(length(y)==1)y <- rep(y,nrow(x)) if(length(y)!=nrow(x)) stop("Wrong length for status") temp <- .Call("expc", as.integer(rfac), as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y,PACKAGE="relsurv") temp <- temp$surv } temp } relsurv/R/years.R0000644000176200001440000015645014151642217013441 0ustar liggesuserscolVars <- function(x, na.rm = FALSE){ f <- function(v, na.rm = na.rm) { if(is.numeric(v) || is.logical(v) || is.complex(v)) stats::var(v, na.rm = na.rm) else NA } return(unlist(lapply(x, f, na.rm = na.rm))) } # Copied function from mstate:::NAfix. mstateNAfix <- function (x, subst = -Inf) { spec <- max(x[!is.na(x)]) + 1 x <- c(spec, x) while (any(is.na(x))) x[is.na(x)] <- x[(1:length(x))[is.na(x)] - 1] x[x == spec] <- subst x <- x[-1] x } # Helper function: nessie_spi <- function(formula = formula(data), data, ratetable = relsurv::slopop, tis, starting.time, include.censoring=FALSE, arg.example=FALSE, rmap){ data_orig <- data call <- match.call() if (!missing(rmap)) { rmap <- substitute(rmap) } na.action <- NA rform <- rformulate(formula, data, ratetable, na.action, rmap) data <- rform$data data$Xs <- rep(1, nrow(data)) n_rows <- nrow(data) # Fix demographic covariates: if(starting.time == "left.truncated"){ rform$R[,"year"] <- rform$R[,"year"] - rform$R[,"age"] rform$R[,"age"] <- 0 } if(include.censoring){ # browser() wh <- which(rform$status==1) rform$Y[wh] <- max(rform$Y) if(arg.example){ wh2 <- which(rform$status==1 & data$age==18262) rform$Y[wh2] <- 1826 } } else{ rform$Y <- rep(max(rform$Y), length(rform$Y)) # status is not relevant in this case } out <- NULL out$yi <- NULL out$yidli <- NULL l_tis <- length(tis) temps <- lapply(1:n_rows, function(inx) { temp <- exp.prep(rform$R[inx, , drop = FALSE], rform$Y[inx], rform$ratetable, rform$status[inx], times = tis, fast = TRUE, cmp=FALSE,ys=data$start[inx]) s_pi <- exp(-cumsum(temp$yidli)) s_pi_helper <- which.min(temp$yidli==0)-1 if(s_pi_helper>1){ s_pi[1:s_pi_helper] <- 0} if(include.censoring){ s_pi[(s_pi_helper+1):l_tis] <- pmin(s_pi[(s_pi_helper+1):l_tis], temp$yi[(s_pi_helper+1):l_tis])} c(s_pi, # s_pi temp$yidli*s_pi) # l_pi * s_pi }) temps2 <- do.call("cbind", temps) temps2 <- rowSums(temps2) out$yi <- temps2[1:(length(temps2)/2)] out$yidli <- temps2[(length(temps2)/2+1):length(temps2)] return(out) } # Copied scales::trans_new: # scales_trans_new <- function (name, transform, inverse, breaks = extended_breaks(), # minor_breaks = regular_minor_breaks(), format = format_format(), # domain = c(-Inf, Inf)) # { # if (is.character(transform)) # transform <- match.fun(transform) # if (is.character(inverse)) # inverse <- match.fun(inverse) # structure(list(name = name, transform = transform, inverse = inverse, # breaks = breaks, minor_breaks = minor_breaks, format = format, # domain = domain), class = "trans") # } #' Compute one of the life years measures #' #' Provides an estimate for one of the following measures: years lost (Andersen, 2013), years lost/saved (Andersen, 2017), or #' life years difference (Manevski, Ruzic Gorenjec, Andersen, Pohar Perme, 2022). #' #' The life years difference (\code{measure='yd'}) is taken by default. If other #' measures are of interest, use the \code{measure} argument. #' #' The follow-up time must be specified in days. The \code{ratetable} #' being used may have different variable names and formats than the user's #' data set, this is dealt with the \code{rmap} argument. For example, if #' age is in years in the data but in days in the \code{ratetable} object, #' age=age*365.241 should be used. The calendar year can be in any date format #' (date, Date and POSIXt are allowed), the date formats in the #' \code{ratetable} and in the data may differ. #' #' Numerical integration is required for the population curves. The integration #' precision is set with argument \code{precision}, which defaults to 30-day #' intervals. For higher accuracy take a smaller value (e.g. precision=1 makes #' the integration on a daily basis). #' #' The observed curves are reported at event and censoring times. The #' population curves are reported at all times used for the numerical integration. #' Note that for the years lost (Andersen, 2013) measure, only the excess absolute risk is reported. #' #' @param formula a formula object, with the response as a \code{Surv} object #' on the left of a \code{~} operator, and, \code{~1} specified on the right. #' #' NOTE: The follow-up time must be in days. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param measure choose which measure is used: 'yd' (life years difference; Manevski, Ruzic Gorenjec, Andersen, Pohar Perme, 2022), 'yl2017' (years lost/saved; Andersen 2017), #' 'yl2013' (years lost/saved; Andersen 2013). #' the population cumulative incidence curve. Relevant only for \code{measure='yd'}. #' For \code{measure='yl2013'} and \code{measure='yl2017'} the estimators defined in (Andersen, 2013) and (Andersen, 2017) #' are used. #' @param ratetable a table of event rates, organized as a \code{ratetable} #' object, such as \code{slopop}. #' @param rmap an optional list to be used if the variables are not organized #' and named in the same way as in the \code{ratetable} object. See details #' below. #' @param var.estimator Choose the estimator for the variance ('none', 'bootstrap', 'greenwood'). Default is 'none'. #' @param B if \code{var.estimator} is 'bootstrap'. The number of bootstrap replications. Default is 100. #' @param precision precision for numerical integration of the population curve. Default is 30 (days). #' The value may be decreased to get a #' higher precision or increased to achieve a faster calculation. #' @param add.times specific times at which the curves should be reported. #' @param na.action a missing-data filter function. Default is \code{na.omit}. #' @param conf.int the confidence level for a two-sided confidence interval. Default is 0.95. #' @param timefix the timefix argument in survival::survfit.formula. Default is FALSE. #' @param admin.cens if a Date is supplied, administrative censoring is taken into account at that time #' in the population curve. Works only if there's late entry, e.g. if the formula is \code{Surv(start,stop,event)~1}. #' @param arg.example temporary argument, used for checking additionalities. #' @param cause.val for competing risks, to be added. #' @param is.boot if TRUE, the function \code{years} has been called during a bootstrap replication. #' @param first.boot if TRUE, this is the first bootstrap replication. #' @return A list containing the years measure, the observed and population curves (or the excess curve for Andersen 2013). #' The values are given as separate data.frames through time. Times are given in days, all areas are given in years. #' Functions \code{plot_f} and \code{plot_years} can be then used for plotting. #' @seealso \code{plot_f}, \code{plot_years} #' @examples #' #' library(relsurv) #' # Estimate the life years difference for the rdata dataset. #' mod <- years(Surv(time, cens)~1, data=rdata, measure='yd', ratetable=slopop, #' rmap=list(age=age*365.241), var.estimator = 'none') #' # Plot the absolute risk (observed and population curve): #' plot_f(mod) #' # Plot the life years difference estimate: #' plot_years(mod, conf.int=FALSE) years <- function( formula=formula(data), data, measure=c('yd', 'yl2017', 'yl2013'), # estimator=c("F_P_final"),#, "F_P_Spi", "F_P_Spi2", "F_P", "F_P2", "all"), ratetable=relsurv::slopop, rmap, var.estimator=c('none', 'bootstrap', 'greenwood'), B=100, precision=30, add.times, na.action=stats::na.omit, conf.int=0.95, timefix=FALSE, admin.cens, arg.example=FALSE, cause.val, is.boot=FALSE, first.boot=FALSE ){ # F_P_Spi: Tako kot F_P_final, ignorira censoring. Ali pa vzame samo admin cens # F_P_Spi2: Vzame ves censoring estimator=c("F_P_final") # #' @param estimator which estimator should be used for calculating # estimator <- match.arg(estimator) if(var.estimator=='bootstrap'){ bootstrap <- TRUE } else if(var.estimator %in% c('none', 'greenwood')){ bootstrap <- FALSE } else{ stop('Incorrect value provided in argument var.estimator.') } Call <- match.call() if(!missing(rmap) & !is.boot & !first.boot) rmap <- substitute(rmap) measure <- match.arg(measure) data_orig <- data out <- NULL late.values <- FALSE # These were arguments. To be deleted? exact.hazards <- FALSE # calculate hazards on a daily basis (to be checked) find.cond.time <- FALSE # if TRUE, return time at which there are at least 5 individuals in the at-risk set. # if(!missing(cause.val)){ # data$status <- ifelse(data$cause == cause.val, 1, 0) # # Remove NAs: # eniNAs <- which(is.na(data$status)) # if(length(eniNAs)>0) data <- data[-eniNAs,] # } # data$age <- round(data$age*365.241) # data$stop <- round(data$stop*365.241) # if(starting.time=="left.truncated"){ if(!missing(admin.cens)){ if(class(admin.cens)!='Date') warning('Object of class Date should be supplied to admin.cens.') end_date <- data$year+(data$stop-data$age) if(any(end_date > admin.cens)) warning('There are events that occur after the date of administrative censoring. Please check the values in arguments data and admin.cens.') id_admin_cens <- which(admin.cens==end_date) } # } starting_age <- rep(0,nrow(data)) # If Surv(start,stop, event) (possibly + mstate) if_start_stop <- length(as.character(formula[[2]])) %in% c(4,5) if(if_start_stop){ starting.time <- 'left.truncated' } else{ starting.time <- 'zero' } if(if_start_stop){ start_col <- as.character(formula[[2]])[2] stop_col <- as.character(formula[[2]])[3] starting_age <- data[, start_col] } else{ stop_col <- as.character(formula[[2]])[2] if(!(stop_col %in% colnames(data))){ stop(paste0('Instead of \'', stop_col, '\', please use a column from the data in the formula.')) } } starting_age <- as.numeric(starting_age) # CIF on data: surv_obj <- as.character(formula[[2]]) if(missing(formula)){ stop('Missing formula argument value.') } else{ if('mstate' %in% surv_obj){ juh <- 1:nrow(data) mod <- survival::survfit.formula(as.formula(Reduce(paste, deparse(formula))), data=data, timefix=timefix, id = juh, na.action=na.action) } else{ mod <- survival::survfit.formula(formula, data=data, timefix=timefix, na.action=na.action) } } if('mstate' %in% surv_obj){ surv_obj_new <- paste0(surv_obj[1], '(', surv_obj[2], ',', surv_obj[3]) if(length(surv_obj)==5){ surv_obj_new <- paste0(surv_obj_new, ',', surv_obj[4], ')') } else{ surv_obj_new <- paste0(surv_obj_new, ')') } formula <- paste0(surv_obj_new, '~1') } status_obj <- surv_obj[length(surv_obj)] if(!missing(cause.val)){ mod$n.risk <- mod$n.risk[,1] mod$n.event <- mod$n.event[,cause.val+1] mod$surv <- 1-mod$pstate[,cause.val+1] mod$std.err <- mod$std.err[,cause.val+1] mod$cumhaz <- mod$cumhaz[,cause.val] } if(!missing(add.times)){ mod_sum <- summary(mod, times = sort(unique(c(mod$time, add.times)))) if(any(!(add.times %in% mod_sum$time))){ if(!is.boot){ if(!first.boot){ warning('Some values in add.times are after the last follow-up time. All measures are extrapolated up to these times. Please consider removing them.') } late.values <- TRUE miss_tajms <- add.times[!(add.times %in% mod_sum$time)] mod_sum$time <- c(mod_sum$time, miss_tajms) mod_sum$n.risk <- c(mod_sum$n.risk, rep(mod_sum$n.risk[length(mod_sum$n.risk)], length(miss_tajms))) mod_sum$n.event <- c(mod_sum$n.event, rep(0, length(miss_tajms))) mod_sum$surv <- c(mod_sum$surv, rep(mod_sum$surv[length(mod_sum$surv)], length(miss_tajms))) mod_sum$cumhaz <- c(mod_sum$cumhaz, rep(mod_sum$cumhaz[length(mod_sum$cumhaz)], length(miss_tajms))) # First fix std.err: if(is.nan(mod_sum$std.err[length(mod_sum$std.err)])){ mod_sum$std.err[length(mod_sum$std.err)] <- mod_sum$std.err[length(mod_sum$std.err) - 1] } mod_sum$std.err <- c(mod_sum$std.err, rep(mod_sum$std.err[length(mod_sum$std.err)], length(miss_tajms))) } } mod$time <- mod_sum$time mod$n.risk <- mod_sum$n.risk mod$n.event <- mod_sum$n.event mod$surv <- mod_sum$surv mod$std.err <- mod_sum$std.err mod$cumhaz <- mod_sum$cumhaz } if(find.cond.time) return(mod$time[which.min(mod$n.risk<5)]) # Calculate AUC: if(length(mod$time)>1){ survs <- c(1, mod$surv[1:(length(mod$surv)-1)]) auc_data <- sum(diff(c(0, mod$time))*(1 - survs)) auc_data_vec <- cumsum(diff(c(0, mod$time))*(1 - survs)) } else{ auc_data <- mod$time*mod$surv auc_data_vec <- auc_data } out$F_data <- 1-mod$surv out$auc_data <- auc_data/365.241 out$auc_data_vec <- auc_data_vec/365.241 # HM? if(exact.hazards){ mod$time <- seq(min(mod$time), max(mod$time), by=1) mod$surv <- exp(-cumsum(rep(ratetable[1,1,1], max(mod$time)-min(mod$time)+1))) out$F_data <- 1-exp(-cumsum(c(0, rep(ratetable[1,1,1], max(mod$time)-min(mod$time))))) out$auc_data <- sum(out$F_data)/365.241 } ### if(measure %in% c('yl2017', 'yl2013')){ # YL_P preparation: data_yi <- data rform <- rformulate(formula, data, ratetable, na.action=na.action, rmap = rmap) data <- rform$data if(if_start_stop){ if(!(start_col %in% colnames(data))){ data[,start_col] <- data_orig[, start_col] } } # Check covariates: p <- rform$m if (p > 0) stop("There shouldn't be any covariates in the formula. This function gives non-parametric estimates of the hazards.") else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 out_n <- table(data$Xs) #table of strata out$time <- out$haz.excess <- out$haz.pop <- out$std.err <- out$strata <- NULL kt <- 1 # the only stratum inx <- which(data$Xs == names(out_n)[kt]) #individuals within this stratum # tis <- sort(unique(rform$Y[inx])) #unique times if(!if_start_stop){ tis <- rform$Y[inx] #unique times tis_seq <- seq(1, max(rform$Y[inx]), precision) } else{ tis <- sort(unique(c(rform$Y[inx], data[, start_col]))) #unique times tis_seq <- seq(min(data[, start_col]), max(rform$Y[inx], data[, start_col]), precision) } if(!is.boot){ tis <- sort(unique(c(tis, tis_seq))) } if(!missing(add.times)){ tis <- sort(unique(c(tis, add.times))) } ltis <- length(tis) # Fix demographic covariates: if(if_start_stop){ rform$R[,"year"] <- rform$R[,"year"] - rform$R[,"age"] rform$R[,"age"] <- 0 } if(measure == 'yl2017'){ # YL_O (used only for yl2017): if(if_start_stop){ it_auc <- rep(NA, nrow(data_orig)) mod_sum <- summary(mod, times=unique(sort(c(data_orig[,start_col], data_orig[,stop_col])))) lsurv <- length(mod_sum$surv) val_mat <- matrix(0, nrow=nrow(data_orig), ncol=lsurv) for(it in 1:nrow(data_orig)){ it_wh <- which(data_orig[it, start_col] == mod_sum$time) it_surv <- mod_sum$surv[it_wh:lsurv]/mod_sum$surv[it_wh] it_auc[it] <- sum(c(0, diff(mod_sum$time[it_wh:lsurv]))*(1 - it_surv))/365.241 val_mat[it, it_wh:lsurv] <- cumsum(c(0, diff(mod_sum$time[it_wh:lsurv]))*(1 - it_surv))/365.241 } YL_O_vec <- colMeans(val_mat) YL_O <- mean(it_auc) F_O_time <- mod_sum$time } else{ YL_O_vec <- out$auc_data_vec YL_O <- out$auc_data F_O_time <- mod$time } F_O <- data.frame(time=F_O_time, area=YL_O_vec) ### # YL_P continue: it_auc_P <- rep(NA, nrow(data)) it_auc_P_mat <- matrix(0, nrow=nrow(data), ncol=ltis) for(it in 1:nrow(data)){ temp <- exp.prep(rform$R[it,,drop=FALSE],max(rform$Y),rform$ratetable,rform$status[it],times=tis,fast=FALSE, cmp=FALSE, ys=starting_age[it], netweiDM = FALSE) # temp <- exp.prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis2,fast=FALSE, cmp=FALSE, ys=starting_age, netweiDM = TRUE) if(if_start_stop){ it_wh <- which(data[it, start_col] == tis) hazs <- temp$yidli[it_wh:ltis] hazs[1] <- 0 cumhazs <- cumsum(hazs) F_P <- 1 - exp(-cumhazs) it_auc_P[it] <- sum(c(tis[it_wh], diff(tis[it_wh:ltis]))*c(0, F_P[1:(length(F_P)-1)]))/365.241 it_auc_P_mat[it,it_wh:ltis] <- sum(c(tis[it_wh], diff(tis[it_wh:ltis]))*c(0, F_P[1:(length(F_P)-1)]))/365.241 } else{ # it_wh <- which(data$age[it] == tis) hazs <- temp$yidli[1:ltis] hazs[1] <- 0 cumhazs <- cumsum(hazs) F_P <- 1 - exp(-cumhazs) it_auc_P[it] <- sum(c(0, diff(tis))*c(0, F_P[1:(length(F_P)-1)]))/365.241 it_auc_P_mat[it,] <- cumsum(c(0, diff(tis))*c(0, F_P[1:(length(F_P)-1)]))/365.241 } } YL_P <- mean(it_auc_P) YL=YL_O-YL_P F_P <- data.frame(time=tis, area=colMeans(it_auc_P_mat)) F_O_tajms <- F_P$time[!(F_P$time %in% F_O$time)] if(length(F_O_tajms)>0){ F_O_tmp <- data.frame(time=F_O_tajms, area=NA) F_O_ext <- rbind(F_O, F_O_tmp) F_O_ext <- F_O_ext[order(F_O_ext$time),] F_O_ext$area <- mstateNAfix(F_O_ext$area, 0) yd_curve <- data.frame(time=tis, est=F_O_ext$area - F_P$area) } else{ yd_curve <- data.frame(time=tis, est=F_O$area - F_P$area) } # Bootstrap: if(bootstrap){ data_b <- data_orig data_b$id <- 1:nrow(data_b) yl_boot <- ylboot(theta=ylboot.iter, data=data_b, id="id", B=B, verbose=0, #all_times = all_times, ratetable=ratetable#, add.times=add.times , starting.time, estimator, precision, add.times = add.times, formula = formula, rmap = rmap, measure=measure ) if(ncol(yl_boot[[2]])>nrow(F_O)){ varsincol <- colVars(yl_boot[[2]], na.rm=TRUE)^(1/2) varsincol_df <- data.frame(time=yl_boot[[4]], area.se=varsincol) varsincol_df <- varsincol_df[varsincol_df$time %in% F_O$time,] F_O$area.se <- varsincol_df$area.se } else{ F_O$area.se <- colVars(yl_boot[[2]], na.rm=TRUE)^(1/2) } F_P$area.se <- colVars(yl_boot[[3]], na.rm=TRUE)^(1/2) yl_boot <- as.data.frame(t(yl_boot[[1]])) yd_curve$est.se <- (colVars(yl_boot, na.rm=TRUE))^(1/2) } # Add CI: if((!is.boot) & (!first.boot)){ if(!is.null(yd_curve$est.se)){ yd_curve$lower <- yd_curve$est - yd_curve$est.se*stats::qnorm(0.5+conf.int/2) yd_curve$upper <- yd_curve$est + yd_curve$est.se*stats::qnorm(0.5+conf.int/2) } } return(list(years=yd_curve, F_O=F_O, F_P=F_P, measure=measure)) } else{ temp <- exp.prep(rform$R[,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status,times=tis, fast=TRUE, cmp=FALSE, ys=starting_age) temp$yi[temp$yi==0] <- Inf out$time <- c(out$time, tis) #add times # Calculate hazards: haz.pop <- temp$yidli/temp$yi out$haz.pop <- c(out$haz.pop,haz.pop) out$cum.haz.pop <- cumsum(out$haz.pop) mod_tis <- summary(mod, times = tis) F_E <- cumsum(mod_tis$surv*(mod_tis$n.event/mod_tis$n.risk - haz.pop)) ltis <- length(tis) # To be checked # # Var as in Pavlic2018: # F_E_st <- sapply(1:ltis, function(s){ # (sum(mod_tis$surv[s:ltis]*(mod_tis$n.event[s:ltis]/mod_tis$n.risk[s:ltis] - haz.pop[s:ltis]))/mod_tis$surv[s]) # *c(0, diff(tis[s:ltis])) /365.241 # }) # # Klemnova: # F_Ese <- (cumsum((mod_tis$surv)^2*(1 - F_E_st)^2*((mod_tis$n.event)/(mod_tis$n.risk^2))*c(0, diff(tis)))/365.241)^(1/2) # surv_int <- rev(cumsum(rev(c(0, diff(tis))*c(1, mod_tis$surv[1:(length(mod_tis$surv)-1)])))/365.241) # # # Moja: # F_E_int <- rev(cumsum(rev(c(0, diff(tis))*c(0, F_E[1:(length(F_E)-1)])))/365.241) # F_Ese <- (cumsum((surv_int)^2*(1 - F_E_st)^2*((mod_tis$n.event)/(mod_tis$n.risk^2))*c(0, diff(tis)))/365.241)^(1/2) # # # Observed: # F_Ese <- (cumsum(surv_int^2*((mod_tis$n.event)/(mod_tis$n.risk^2))*c(0, diff(tis)))/365.241)^(1/2) # # # Predlog glede na Andersen 2013: # F_Ese <- (cumsum((surv_int^2*(mod_tis$n.event - temp$yidli) + F_E_int^2*temp$yidli)/(mod_tis$n.risk^2)*c(0, diff(tis)))/365.241)^(1/2) YL <- cumsum(F_E*c(0, diff(tis)))/365.241 F_E_area <- cumsum(c(0, diff(tis))*c(0, F_E[1:(length(F_E)-1)]))/365.241 F_E_df <- data.frame(time=tis, prob=F_E, area=F_E_area) # , prob.se=F_Ese yd_curve <- data.frame(time=tis, est=YL) if(bootstrap){ data_b <- data_orig data_b$id <- 1:nrow(data_b) yl_boot <- ylboot(theta=ylboot.iter, data=data_b, id="id", B=B, verbose=0, #all_times = all_times, ratetable=ratetable#, add.times=add.times , starting.time, estimator, precision, add.times = add.times, formula = formula, rmap = rmap, measure=measure ) # Calculate area.se: area.se <- yl_boot[[2]] for(itar in 1:nrow(yl_boot[[2]])){ prob_tmp <- as.vector(as.matrix(yl_boot[[2]][itar,])) area_tmp <- cumsum(c(0, diff(tis))*c(0, prob_tmp[1:(length(prob_tmp)-1)]))/365.241 area.se[itar,] <- area_tmp } area.se <- as.vector(colVars(area.se, na.rm=TRUE)) F_E_df$prob.se <- (colVars(yl_boot[[2]], na.rm=TRUE))^(1/2) F_E_df$area.se <- area.se yl_boot <- as.data.frame(t(yl_boot[[1]])) yd_curve$est.se <- (colVars(yl_boot, na.rm=TRUE))^(1/2) } if((!is.boot) & (!first.boot)){ if(!is.null(yd_curve$est.se)){ yd_curve$lower <- yd_curve$est - yd_curve$est.se*stats::qnorm(0.5+conf.int/2) yd_curve$upper <- yd_curve$est + yd_curve$est.se*stats::qnorm(0.5+conf.int/2) } } out <- list(years=yd_curve, F_E=F_E_df, measure=measure) return(out) } } ################################################### # ## Prava varianca: times_all2 <- c(0, diff(mod$time))/365.241 surv_all <- c(1, mod$surv[1:(length(mod$surv)-1)]) auc_all <- cumsum(times_all2*surv_all) out$auc_data_var1 <- sum(((auc_all[length(auc_all)] - auc_all)^2*mod$n.event)/(mod$n.risk*(mod$n.risk - mod$n.event)), na.rm=T) obs_var_time <- sapply(1:length(auc_all), function(x) { numer <- mod$n.risk[1:x]*(mod$n.risk[1:x] - mod$n.event[1:x]) numer[numer==0] <- Inf sum(((auc_all[x] - auc_all[1:x])^2*mod$n.event[1:x])/numer) }) if(is.nan(obs_var_time[length(obs_var_time)])){ obs_var_time[length(obs_var_time)] <- obs_var_time[length(obs_var_time)-1] } ################################################### # # CIF on population: data_yi <- data rform <- rformulate(formula, data, ratetable, na.action=na.action, rmap = rmap) data <- rform$data if(if_start_stop){ if(!(start_col %in% colnames(data))){ data[,start_col] <- data_orig[, start_col] } } # Check covariates: p <- rform$m if (p > 0) stop("There shouldn't be any covariates in the formula. This function gives non-parametric estimates of the hazards.") else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 out_n <- table(data$Xs) #table of strata out$time <- out$haz.excess <- out$haz.pop <- out$std.err <- out$strata <- NULL kt <- 1 # the only stratum inx <- which(data$Xs == names(out_n)[kt]) #individuals within this stratum if(!if_start_stop) tis <- sort(unique(c(rform$Y[inx], seq(1, max(rform$Y[inx]), precision)))) #unique times else tis <- sort(unique(c(rform$Y[inx], data[, start_col], seq(min(data[, start_col]), max(rform$Y[inx], data[, start_col]), precision)))) #unique times if(!missing(add.times)){ tis <- sort(unique(c(tis, add.times))) } # Fix demographic covariates: if(if_start_stop){ rform$R[,"year"] <- rform$R[,"year"] - rform$R[,"age"] rform$R[,"age"] <- 0 } if(estimator=='F_P' | estimator=="all"){ # Prepare at-risk matrix: # browser() # mat <- lapply(1:nrow(data), function(x) ifelse((data$start[x] < tis) & (tis <= data$Y[x]), 1, NA)) # mat2 <- matrix(unlist(mat), nrow = nrow(data_yi), byrow = TRUE) # # The sum of the individual at-risk processes: # yi_left <- colSums(mat2) # yi_left[yi_left == 0] <- Inf # # mat3 <- lapply(1:nrow(data), function(x) data$age[x] + c(0, diff(tis))) if(any(rform$Y[inx]<=starting_age)) browser() temp <- exp.prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis,fast=TRUE, cmp=FALSE, ys=starting_age) # Fix at-risk process, if needed: temp$yi[temp$yi==0] <- Inf out$time <- c(out$time, tis) #add times # Calculate hazards: haz.pop <- temp$yidli/temp$yi out$haz.pop <- c(out$haz.pop,haz.pop) out$cum.haz.pop <- cumsum(out$haz.pop) out$F_P <- 1-exp(-out$cum.haz.pop) out$auc_pop <- sum(c(tis[1], diff(tis))*c(0, out$F_P[1:(length(out$F_P)-1)]))/365.241 } data_spi2 <- data if(estimator=='F_P_Spi2' | estimator=="all"){ if(any(data_spi2$start>=data_spi2$Y)) browser() # Take into account censoring: exp.surv2 <- nessie_spi(Surv(start, Y, stat)~1, data=data_spi2, ratetable=ratetable, tis=tis, starting.time=starting.time, include.censoring = TRUE, arg.example) out$haz.pop.spi2 <- exp.surv2$yidli/exp.surv2$yi out$cum.haz.pop.spi2 <- cumsum(out$haz.pop.spi2) out$F_P_Spi2 <- 1-exp(-out$cum.haz.pop.spi2) out$auc_pop_Spi2 <- sum(c(tis[1], diff(tis))*c(0, out$F_P_Spi2[1:(length(out$F_P_Spi2)-1)]))/365.241 } if(estimator=='F_P_Spi' | estimator=="all"){ if((!missing(admin.cens))){ data_spi2$stat <- 1 data_spi2$stat[id_admin_cens] <- 0 exp.surv <- nessie_spi(Surv(start, Y, stat)~1, data=data_spi2, ratetable=ratetable, tis=tis, starting.time=starting.time, include.censoring = TRUE, arg.example) } else{ # Don't take into account censoring: exp.surv <- nessie_spi(Surv(start, Y, stat)~1, data=data_spi2, ratetable=ratetable, tis=tis, starting.time=starting.time, include.censoring = FALSE, arg.example) } out$haz.pop.spi <- exp.surv$yidli/exp.surv$yi out$cum.haz.pop.spi <- cumsum(out$haz.pop.spi) out$F_P_Spi <- 1-exp(-out$cum.haz.pop.spi) out$auc_pop_Spi <- sum(c(tis[1], diff(tis))*c(0, out$F_P_Spi[1:(length(out$F_P_Spi)-1)]))/365.241 } if(estimator=='F_P_final'){ # Shift all to the end: if(if_start_stop) data_yi[,stop_col] <- max(data_yi[,stop_col]) rform2 <- rform rform <- rformulate(formula, data_yi, ratetable, na.action=na.action, rmap = rmap) # Shift all to the end: if(!if_start_stop){ rform$Y <- rep(max(rform$Y), length(rform$Y)) rform$data[,"Y"] <- rform$Y } data <- rform$data if(if_start_stop){ if(!(start_col %in% colnames(data))){ data[,start_col] <- data_orig[, start_col] } } # Check covariates: p <- rform$m if (p > 0) stop("There shouldn't be any covariates in the formula. This function gives non-parametric estimates of the hazards.") else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 out$haz.pop2 <- NULL kt <- 1 # the only stratum inx <- which(data$Xs == names(out_n)[kt]) #individuals within this stratum tis2 <- tis # Fix demographic covariates: if(if_start_stop){ rform$R[,"year"] <- rform$R[,"year"] - rform$R[,"age"] rform$R[,"age"] <- 0 } if(any(starting_age>=rform$Y[inx])) browser() # temp <- exp.prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis2,fast=TRUE, cmp=FALSE, ys=0) # temp <- exp.prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis2,fast=TRUE, cmp=FALSE, ys=starting_age) temp <- exp.prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis2,fast=FALSE, cmp=FALSE, ys=starting_age, netweiDM = TRUE) temp$sidliD[1] <- 0 # temp$sisD[1] <- 1 temp$sisD[temp$sisD==0] <- Inf haz.pop2 <- temp$sidliD/temp$sisD out$haz.pop2 <- c(out$haz.pop2, haz.pop2) out$cum.haz.pop2 <- cumsum(out$haz.pop2) out$F_P2 <- 1-exp(-out$cum.haz.pop2) out$auc_pop2 <- sum(c(tis2[1], diff(tis2))*c(0, out$F_P2[1:(length(out$F_P2)-1)]))/365.241 out$sidli <- temp$sidli out$sis <- temp$sis # DODATEK: haz.pop.ves.cas <- temp$sidli haz.pop.ves.cas[1] <- 0 haz.pop.ves.cas <- haz.pop.ves.cas/temp$sis out$cum.haz.pop.ves.cas <- cumsum(haz.pop.ves.cas) out$F_P_ves_cas <- 1 - exp(-out$cum.haz.pop.ves.cas) out$auc_pop_ves_cas <- sum(c(tis2[1], diff(tis2))*c(0, out$F_P_ves_cas[1:(length(out$F_P_ves_cas)-1)]))/365.241 } if(estimator=='F_P2' | estimator=="all"){ # Shift all to the end: if(if_start_stop) data_yi[,stop_col] <- max(data_yi[,stop_col]) rform2 <- rform rform <- rformulate(formula, data_yi, ratetable, na.action=na.action, rmap = rmap) # Shift all to the end: if(!if_start_stop){ rform$Y <- rep(max(rform$Y), length(rform$Y)) rform$data[,"Y"] <- rform$Y } data <- rform$data if(if_start_stop){ if(!(start_col %in% colnames(data))){ data[,start_col] <- data_orig[, start_col] } } # Check covariates: p <- rform$m if (p > 0) stop("There shouldn't be any covariates in the formula. This function gives non-parametric estimates of the hazards.") else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 out$haz.pop2 <- NULL kt <- 1 # the only stratum inx <- which(data$Xs == names(out_n)[kt]) #individuals within this stratum tis2 <- tis # tis2 <- sort(unique(rform$Y[inx])) #unique times # Fix demographic covariates: if(if_start_stop){ rform$R[,"year"] <- rform$R[,"year"] - rform$R[,"age"] rform$R[,"age"] <- 0 } if(any(starting_age>=rform$Y[inx])) browser() # temp <- exp.prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis2,fast=TRUE, cmp=FALSE, ys=0) temp <- exp.prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis2,fast=TRUE, cmp=FALSE, ys=starting_age) # Fix at-risk process, if needed: temp$yi[temp$yi==0] <- Inf # Calculate hazards: haz.pop2 <- temp$yidli/temp$yi out$haz.pop2 <- c(out$haz.pop2, haz.pop2) out$cum.haz.pop2 <- cumsum(out$haz.pop2) out$F_P2 <- 1-exp(-out$cum.haz.pop2) # out$auc_pop2 <- sum(c(tis2[1], diff(tis2))*out$F_P2)/365.241 out$auc_pop2 <- sum(c(tis2[1], diff(tis2))*c(0, out$F_P2[1:(length(out$F_P2)-1)]))/365.241 } ### # Bootstrap: if(bootstrap){ # browser() data_b <- data_orig data_b$id <- 1:nrow(data_b) yl_boot <- ylboot(theta=ylboot.iter, data=data_b, id="id", B=B, verbose=0, #all_times = all_times, ratetable=ratetable#, add.times=add.times , starting.time, estimator, precision, add.times = add.times, formula = formula, rmap = rmap, measure=measure ) L_OP <- yl_boot[[3]] F_boot <- yl_boot[[2]] yl_boot <- as.data.frame(t(yl_boot[[1]])) } ### estimator.orig <- estimator if(estimator=='F_P_final') estimator = 'F_P2' out$strata <- c(out$strata, length(tis)) #number of times in this strata names(out$strata) <- names(out_n) out$strata <- NULL out$auc <- c(auc_data=out$auc_data, auc_pop=out$auc_pop, auc_pop2=out$auc_pop2, auc_pop_Spi=out$auc_pop_Spi, auc_pop_Spi2=out$auc_pop_Spi2) if(estimator=='all'){ F_P_final <- data.frame(time=out$time,F_P=out$F_P, F_P2=out$F_P2, F_P_Spi=out$F_P_Spi, F_P_Spi2=out$F_P_Spi2) } else if(estimator=='F_P'){ F_P_final <- data.frame(time=tis,prob=out$F_P) } else if(estimator=='F_P2'){ F_P_final <- data.frame(time=tis,prob=out$F_P2) } else if(estimator=='F_P_Spi'){ F_P_final <- data.frame(time=tis,prob=out$F_P_Spi) } else if(estimator=='F_P_Spi2'){ F_P_final <- data.frame(time=tis,prob=out$F_P_Spi2) } # YD through time: # if(is.boot) browser() F_data_yd <- data.frame(time=mod$time, F_data=out$F_data, var=obs_var_time) pop.times <- F_P_final$time[!(F_P_final$time %in% mod$time)] if(length(pop.times) > 0){ F_data_yd_tmp <- data.frame(time=pop.times, F_data=NA, var=NA) F_data_yd <- rbind(F_data_yd, F_data_yd_tmp) F_data_yd <- F_data_yd[order(F_data_yd$time),] F_data_yd$F_data <- mstateNAfix(F_data_yd$F_data, 0) F_data_yd$var <- mstateNAfix(F_data_yd$var, 0) } yd_data <- cumsum(c(F_data_yd$time[1], diff(F_data_yd$time))*c(0, F_data_yd$F_data[1:(nrow(F_data_yd)-1)]))/365.241 F_P_yd <- F_P_final yd_pop <- cumsum(c(F_P_yd$time[1], diff(F_P_yd$time))*c(0, F_P_yd$prob[1:(nrow(F_P_yd)-1)]))/365.241 yd_curve <- data.frame(time=F_data_yd$time, yd=yd_data - yd_pop, obs_var=F_data_yd$var, # obs_var22=obs_var_time22, yd_data=yd_data, yd_pop=yd_pop ) ### # Add values at time zero: F_data_tmp <- data.frame(time=mod$time, prob=out$F_data, prob.se=mod$std.err, area=NA, area.se=NA) F_tmp <- F_data_tmp[1,] F_tmp$time <- min(starting_age) F_tmp$prob <- 0 F_tmp$prob.se <- 0 if(!(F_tmp$time %in% F_data_tmp$time)) F_data_tmp <- rbind(F_tmp, F_data_tmp) if(!if_start_stop){ F_P_final_tmp <- F_P_final[1,] F_P_final_tmp$time <- min(starting_age) F_P_final_tmp$prob <- 0 if(!(F_P_final_tmp$time %in% F_P_final$time)) F_P_final <- rbind(F_P_final_tmp, F_P_final) } yd_curve_tmp <- yd_curve[1,] yd_curve_tmp$time <- min(starting_age) yd_curve_tmp[,2:ncol(yd_curve_tmp)] <- 0 if(!(yd_curve_tmp$time %in% yd_curve$time)) yd_curve <- rbind(yd_curve_tmp, yd_curve) if(bootstrap){ yd_curve$boot_var <- colVars(yl_boot, na.rm=TRUE) if(late.values){ last_val <- utils::tail(yd_curve$boot_var[!is.na(yd_curve$boot_var)],1) yd_curve$boot_var[is.na(yd_curve$boot_var)] <- last_val } yl_sd_boot <- stats::sd(yl_boot[, ncol(yl_boot)], na.rm=TRUE) } # Add areas: F_data_tmp$area <- yd_curve$yd_data[yd_curve$time %in% F_data_tmp$time] F_P_final$area <- yd_curve$yd_pop#[yd_curve$time %in% F_P_final$time] F_data_tmp$area.se <- yd_curve$obs_var[yd_curve$time %in% F_data_tmp$time]^(1/2) # If, add boot variance: if(bootstrap & (!is.boot)){ F_data_tmp$prob.se <- (F_boot$F_data[F_boot$time %in% F_data_tmp$time])^(1/2) F_P_final$prob.se <- (F_boot$F_P#[F_boot$time %in% F_P_final$time] )^(1/2) F_data_tmp$area.se <- L_OP$L_O[L_OP$time %in% F_data_tmp$time]^(1/2) F_P_final$area.se <- L_OP$L_P^(1/2) } # Column order: F_data_tmp <- F_data_tmp[, c('time', 'prob', 'area', 'prob.se', 'area.se')] # Choose relevant columns: if(bootstrap){ yd_curve <- yd_curve[,c('time', 'yd', 'boot_var')] } else{ yd_curve <- yd_curve[,c('time', 'yd', 'obs_var')] } yd_curve[,3] <- yd_curve[,3]^(1/2) colnames(yd_curve)[2:3] <- c('est', 'est.se') yd_curve$lower <- yd_curve$est - yd_curve$est.se*stats::qnorm(0.5+conf.int/2) yd_curve$upper <- yd_curve$est + yd_curve$est.se*stats::qnorm(0.5+conf.int/2) return_obj <- list(F_data=F_data_tmp, F_P=F_P_final, auc=out$auc, yd_curve=yd_curve, starting.time=starting.time, estimator=estimator.orig, out=out ) if(bootstrap){ return_obj[[length(return_obj)+1]] <- F_boot names(return_obj)[length(return_obj)] <- 'F_boot' return_obj[[length(return_obj)+1]] <- L_OP names(return_obj)[length(return_obj)] <- 'L_OP' return_obj <- append(return_obj, yl_sd_boot) names(return_obj)[length(return_obj)] <- 'yl_sd_boot' } return_short <- list(years=return_obj$yd_curve, F_O=return_obj$F_data, F_P=return_obj$F_P, measure=measure) if((bootstrap & (!is.boot)) #| ((!bootstrap) & (!is.boot)) ){ return_obj <- return_short } if((!bootstrap) & (!is.boot)){ return_obj <- return_short } if(is.boot){ return_obj <- return_short } if(var.estimator=='none'){ return_obj$years <- return_obj$years[,1:2] find_cols <- (!grepl('.se', colnames(return_obj[[2]]))) return_obj[[2]] <- return_obj[[2]][,find_cols] if(length(return_obj)==4){ find_cols <- (!grepl('.se', colnames(return_obj[[3]]))) return_obj[[3]] <- return_obj[[3]][,find_cols] } } return(return_obj) } utils::globalVariables(c("time", "prob", "Curve", "est", "lower", "upper")) # Bootstrap function: ylboot <- function(theta, data, B = 5, id = "id", verbose = 0, #all_times, ratetable=relsurv::slopop, #add.times, starting.time, estimator, precision, add.times, formula, rmap, measure, ...){ ids <- unique(data[, id]) n <- length(ids) if(!missing(add.times)){ th <- ylboot.iter(formula, data, starting.time = starting.time, estimator = estimator, precision = precision, ratetable=ratetable, first=TRUE, add.times = add.times, rmap = rmap, measure=measure, ...) } else{ th <- ylboot.iter(formula, data, starting.time = starting.time, estimator = estimator, precision = precision, ratetable=ratetable, first=TRUE, rmap = rmap, measure=measure, ...) } simple_par <- TRUE if(missing(add.times)) simple_par <- FALSE # Prepare objects: res <- data.frame(matrix(NA, nrow=B, ncol=nrow(th[[1]]))) if(!missing(add.times)){ add.times <- sort(unique(c(th[[1]]$time, add.times))) } else{ add.times <- th[[1]]$time } Fdata <- data.frame(matrix(NA, nrow=B, ncol=length(add.times))) Fo <- data.frame(matrix(NA, nrow=B, ncol=nrow(th[[2]]))) Fp <- data.frame(matrix(NA, nrow=B, ncol=length(add.times))) L_O <- data.frame(matrix(NA, nrow=B, ncol=length(add.times))) L_P <- data.frame(matrix(NA, nrow=B, ncol=length(add.times))) F_E <- data.frame(matrix(NA, nrow=B, ncol=length(add.times))) # Iteration: for (b in 1:B) { nek_obj <- ylboot.apply(formula, b, verbose, ids, data, id, add.times, starting.time, estimator, precision, ratetable, th, simple_par, rmap, measure, ...) res[b,1:length(nek_obj[[1]])] <- nek_obj[[1]] if(measure=='yl2013'){ F_E[b,1:length(nek_obj[[2]])] <- nek_obj[[2]] } if(measure=='yl2017'){ Fo[b,1:length(nek_obj[[2]])] <- nek_obj[[2]] Fp[b,1:length(nek_obj[[3]])] <- nek_obj[[3]] } if(measure=='yd'){ subnek <- subset(nek_obj[[2]], time %in% add.times) sub_vec <- 1:nrow(subnek) Fdata[b,sub_vec] <- subnek$F_data Fp[b,sub_vec] <- subnek$F_P subnek2 <- subset(nek_obj[[3]], time %in% add.times) sub2_vec <- 1:nrow(subnek2) L_O[b,sub2_vec] <- subnek2$yd_data L_P[b,sub2_vec] <- subnek2$yd_pop } } res <- as.data.frame(t(res)) if(measure == 'yl2013'){ return(list(res, F_E)) } if(measure == 'yl2017'){ return(list(res, Fo, Fp, add.times)) } else{ if (verbose) cat("\n") F_obj <- data.frame(time=add.times, F_data=colVars(Fdata, na.rm = TRUE), F_P=colVars(Fp, na.rm = TRUE)) L_OP <- data.frame(time=add.times, L_O=colVars(L_O, na.rm = TRUE), L_P=colVars(L_P, na.rm = TRUE)) return(list(res, F_obj, L_OP)) } } ylboot.apply <- function(formula, b, verbose, ids, data, id, add.times, starting.time, estimator, precision, ratetable, th, simple_par, rmap, measure, ...){ if(starting.time=='left.truncated'){ start_col <- as.character(formula[[2]])[2] stop_col <- as.character(formula[[2]])[3] } else{ stop_col <- as.character(formula[[2]])[2] } if (verbose > 0) { cat("\nBootstrap replication", b, "\n") } bootdata <- NULL bids <- sample(ids, replace = TRUE) bidxs <- unlist(sapply(bids, function(x) which(x == data[, id]))) bootdata <- data[bidxs, ] if (verbose > 0) { cat("applying theta ...") } if(length(unique(bootdata[,id]))==1){ next } if(!missing(add.times) & simple_par){ add.times.arg <- sort(unique(c(th[[1]]$time, add.times))) } else{ add.times.arg <- th[[1]]$time } add.times.arg2 <- add.times.arg # Remove unnecessary times if(starting.time == 'left.truncated'){ add.times.arg <- add.times.arg[add.times.arg<=max(bootdata[,stop_col])] } else{ add.times.arg <- add.times.arg[add.times.arg<=max(bootdata[,stop_col])]# - bootdata[,start_col])] } thstar <- ylboot.iter(formula, bootdata, starting.time = starting.time, estimator = estimator, precision = precision, ratetable=ratetable, add.times=add.times.arg, rmap=rmap, measure=measure, ...) if(measure == 'yl2013'){ return(list(thstar[[1]]$est, thstar[[2]]$prob)) } if(measure == 'yl2017'){ FoO <- thstar[[2]] FpP <- thstar[[3]] thstar <- thstar[[1]] # if(nrow(th[[1]]) != nrow(thstar)) browser() if(nrow(FoO) < nrow(th[[2]])){ mis.tajms <- th[[2]]$time[!(th[[2]]$time %in% FoO$time)] mis.tajms <- mis.tajms[mis.tajms <= max(FoO$time)] temp_df <- data.frame(time=mis.tajms, area=NA) FoO <- rbind(FoO, temp_df) FoO <- FoO[order(FoO$time),] FoO$area <- mstateNAfix(FoO$area, 0) } if(nrow(th[[1]]) < nrow(thstar)){ thstar <- thstar[thstar$time %in% th[[1]]$time, ] FpP <- FpP[FpP$time %in% th[[1]]$time, ] foO <- foO[foO$time %in% th[[1]]$time, ] } if(length(th[[1]]$time[th[[1]]$time <= max(thstar$time)]) != length(thstar$time)) browser() pogoj <- any(th[[1]]$time[th[[1]]$time <= max(thstar$time)] != thstar$time) if(pogoj){ missing_times <- th[[1]]$time[which(!(th[[1]]$time %in% thstar$time))] if(length(missing_times)>0){ # There are times missing in thstar, add them: add_df <- thstar[1:length(missing_times),] add_df$time <- missing_times add_df$yd <- NA add_df$obs_var <- NA add_df$yd_data <- NA thstar <- rbind(thstar, add_df) thstar <- thstar[order(thstar$time),] # redundantno thstar$yd <- mstateNAfix(thstar$yd, 0) thstar$obs_var <- mstateNAfix(thstar$obs_var, 0) thstar$yd_data <- mstateNAfix(thstar$yd_data, 0) if(nrow(th[[1]]) < nrow(thstar)){ thstar <- thstar[thstar$time %in% th[[1]]$time, ] } if(nrow(th[[1]]) != nrow(thstar)) browser() } else{ # This means there's more times in thstar than needed. Remove unnecessary times: thstar <- thstar[-which(!(thstar$time %in% th[[1]]$time)),] FpP <- FpP[-which(!(FpP$time %in% th[[1]]$time)),] foO <- foO[-which(!(foO$time %in% th[[1]]$time)),] if(nrow(th[[1]]) != nrow(thstar)) browser() } } return(list(thstar$est, FoO$area, FpP$area)) } L_OP <- thstar[[3]] Fobj <- thstar[[2]] thstar <- thstar[[1]] if(nrow(th[[1]]) < nrow(thstar)){ thstar <- thstar[thstar$time %in% th[[1]]$time, ] L_OP <- L_OP[L_OP$time %in% th[[1]]$time, ] Fobj <- Fobj[Fobj$time %in% th[[1]]$time, ] } # Ali kaksne vrednosti manjkajo: if(length(th[[1]]$time[th[[1]]$time <= max(thstar$time)]) != length(thstar$time)) browser() pogoj <- any(th[[1]]$time[th[[1]]$time <= max(thstar$time)] != thstar$time) if(pogoj){ missing_times <- th[[1]]$time[which(!(th[[1]]$time %in% thstar$time))] if(length(missing_times)>0){ # There are times missing in thstar, add them: add_df <- thstar[1:length(missing_times),] add_df$time <- missing_times add_df$yd <- NA add_df$obs_var <- NA add_df$yd_data <- NA thstar <- rbind(thstar, add_df) thstar <- thstar[order(thstar$time),] # redundantno thstar$yd <- mstateNAfix(thstar$yd, 0) thstar$obs_var <- mstateNAfix(thstar$obs_var, 0) thstar$yd_data <- mstateNAfix(thstar$yd_data, 0) if(nrow(th[[1]]) < nrow(thstar)){ thstar <- thstar[thstar$time %in% th[[1]]$time, ] } if(nrow(th[[1]]) != nrow(thstar)) browser() } else{ # This means there's more times in thstar than needed. Remove unnecessary times: thstar <- thstar[-which(!(thstar$time %in% th[[1]]$time)),] L_OP <- L_OP[-which(!(L_OP$time %in% th[[1]]$time)),] Fobj <- Fobj[-which(!(Fobj$time %in% th[[1]]$time)),] if(nrow(th[[1]]) != nrow(thstar)) browser() } } # thstar$b <- b # Save result: # res[b,] <- list(thstar$est, Fobj, L_OP) } ylboot.iter <- function(formula, data, #all_times, starting.time, estimator, precision, ratetable=relsurv::slopop, first=FALSE, add.times, rmap, measure ){ if(!missing(rmap)) rmap <- as.call(rmap) if(first){ is.boot <- FALSE first.boot <- TRUE } else{ is.boot <- TRUE first.boot <- FALSE } # Round, if needed: tolerance <- 1e-15 if(missing(add.times)){ object <- years(formula = formula, data = data, ratetable = ratetable, precision=precision, var.estimator='greenwood', is.boot=is.boot, first.boot = first.boot, rmap = rmap, measure=measure) # estimator = estimator, } else{ object <- years(formula = formula, data = data, ratetable = ratetable, precision=precision, var.estimator='greenwood', add.times=add.times, is.boot=is.boot, first.boot = first.boot, rmap = rmap, measure=measure) # estimator = estimator, } if(measure=='yd'){ if(first) return(list(object$years, object$F_O)) else{ # return(object$yd_curve) Fobj <- merge(object$F_P[,c('time','prob')], object$F_O[,c('time','prob')], by='time', all.x=TRUE) Fobj <- Fobj[,c(1,3,2)] colnames(Fobj)[2:3] <- c('F_data','F_P') L_OP <- merge(object$F_P[,c('time','area')], object$F_O[,c('time','area')], by='time', all.x = TRUE) L_OP <- L_OP[,c(1,3,2)] colnames(L_OP)[2:3] <- c('yd_data', 'yd_pop') return(list(object$years, Fobj, L_OP)) } } else if(measure=='yl2013'){ return(list(object$years, object$F_E)) } else{ return(list(object$years, object$F_O, object$F_P)) } } plot.helper <- function(years, obj){ df_poly <- data.frame(time=years[[obj]]$time/365.241, prob=years[[obj]]$prob) df_st <- df_poly[1,] df_st$prob <- 0 df_end <- df_poly[nrow(df_poly),] df_end$prob <- 0 df_poly <- rbind(df_st, df_poly, df_end) df_poly } gg_color_hue <- function(n) { hues = seq(15, 375, length = n + 1) grDevices::hcl(h = hues, l = 65, c = 100)[1:n] } #' Plot the absolute risk (observed and population curve) #' #' Plots the estimated observed and population curve for the following measures: years lost/saved (Andersen, 2017), or #' life years difference (Manevski, Ruzic Gorenjec, Andersen, Pohar Perme, 2022). Note that this function cannot be used for the years lost measure (Andersen, 2013). #' #' A ggplot2 implementation for plotting the observed and population curves. The type of curves is #' dependent upon the measure calculated using \code{years} function (argument \code{measure}). #' @param years the object obtained using function \code{years}. #' @param xlab a title for the x axis. #' @param ylab a title for the y axis. #' @param xbreak the breaks on the x axis (this is supplied to \code{scale_x_continuous}). #' @param ybreak the breaks on the y axis (this is supplied to \code{scale_y_continuous}). #' @param xlimits define the limits on the x axis (this is supplied to \code{scale_x_continuous}). #' @param ylimits define the limits on the y axis (this is supplied to \code{scale_y_continuous}). #' @param show.legend if TRUE, the legend is shown on the graph. #' @return A ggplot object #' @seealso \code{years}, \code{plot_years} #' plot_f <- function(years, xlab='Time interval', ylab='Absolute risk', xbreak, ybreak, xlimits, ylimits, show.legend=TRUE){ # years: object given from the years() function # xlab: define xlab # ylab: define ylab # xbreak: The breaks on x axis # ybreak: The breaks on y axis # xlimits: Define the limits on the x axis # ylimits: Define the limits on the y axis # show.legend: TRUE by default (shows the legend) # library(ggplot2) if(years$measure != 'yd'){ stop("The plot_f function is only available for the life years difference measure (argument measure='yd' in the years function).") } out <- rbind( cbind(years$F_O[,c('time', 'prob')], Curve='Observed'), cbind(years$F_P[,c('time', 'prob')], Curve='Population') ) if(missing(xlimits)){ xlimits <- c(min(out$time), max(out$time))/365.241 } if(missing(ylimits)){ ylimits <- c(0,max(out$prob))*1.1 } colorji <- gg_color_hue(3) colorji <- colorji[c(1,3)] g <- ggplot2::ggplot(out)+ ggplot2::geom_step(ggplot2::aes(time/365.241, prob, color=Curve), size=1.001 )+ ggplot2::scale_color_manual(values=colorji)+ ggplot2::xlab(xlab)+ ggplot2::ylab(ylab) poly_data <- plot.helper(years, 'F_O') poly_P <- plot.helper(years, 'F_P') g <- g+ pammtools::geom_stepribbon(ggplot2::aes(x=time/365.241, ymin=0, ymax=prob, fill=Curve), alpha=0.3)+ ggplot2::scale_fill_manual(values = colorji) if(!missing(xbreak)){ g <- g + ggplot2::scale_x_continuous(expand = c(0, 0), limits=xlimits, breaks = xbreak) } else{ g <- g + ggplot2::scale_x_continuous(expand = c(0, 0), limits=xlimits) } if(!missing(ybreak)){ g <- g + ggplot2::scale_y_continuous(expand = c(0, 0), limits=ylimits, breaks = ybreak) } else{ g <- g + ggplot2::scale_y_continuous(expand = c(0, 0), limits=ylimits) } g <- g + ggplot2::theme_bw()+ ggplot2::theme(legend.position = 'bottom', legend.title = ggplot2::element_blank())+ ggplot2::theme(text = ggplot2::element_text(size=14))+ ggplot2::theme( panel.grid.major.x = ggplot2::element_line(linetype='dashed', colour = 'grey85'), panel.grid.minor.x = ggplot2::element_line(linetype='dashed', colour = 'grey85'), panel.grid.major.y = ggplot2::element_line(linetype='dashed', colour = 'grey85'), panel.grid.minor.y = ggplot2::element_line(linetype='dashed', colour = 'grey85')) if(!show.legend){ g <- g + ggplot2::theme(legend.position = 'none') } g } #' Plot the years measure #' #' Plot the years measure obtained from the \code{years} function. #' #' A ggplot2 implementation for plotting the years measure. The type of curve is #' dependent upon the measure calculated using the \code{years} function (argument \code{measure}). #' @param years the object obtained using function \code{years}. #' @param xlab a title for the x axis. #' @param ylab a title for the y axis. #' @param xbreak the breaks on the x axis (this is supplied to \code{scale_x_continuous}). #' @param ybreak the breaks on the y axis (this is supplied to \code{scale_y_continuous}). #' @param xlimits define the limits on the x axis (this is supplied to \code{scale_x_continuous}). #' @param ylimits define the limits on the y axis (this is supplied to \code{scale_y_continuous}). #' @param conf.int if TRUE, the confidence interval is plotted. #' @param ymirror mirror the y values (w.r.t. the x axis). #' @param yminus use function y -> -y when plotting. #' @return A ggplot object #' @seealso \code{years}, \code{plot_f} #' plot_years <- function(years, xlab='Time interval', ylab='Years', xbreak, ybreak, xlimits, ylimits, conf.int=TRUE, ymirror=FALSE, yminus=FALSE){ out <- years$years if(conf.int){ if(is.null(out$lower)){ stop('Confidence intervals not present in the years object. Please set conf.int=FALSE or use the var.estimator argument in the years function.') } } if(yminus){ out$est <- -out$est if(!is.null(out$lower)){ tmp_lower <- out$lower out$lower <- -out$upper out$upper <- -tmp_lower } } if(missing(xlimits)){ xlimits <- c(min(years$years$time[1]), max(years$years$time))/365.241 } if(missing(ylimits)){ tmp_vec <- out$est if(!is.null(out$lower)) tmp_vec <- c(out$est, out$lower, out$upper) ymax <- max(tmp_vec) ymin <- min(tmp_vec) ylimits <- c(ymin,ymax)*1.1 } g <- ggplot2::ggplot(out)+ ggplot2::geom_step(ggplot2::aes(time/365.241, est), size=1.001) if(conf.int){ g <- g+ ggplot2::geom_step(ggplot2::aes(time/365.241, lower))+ ggplot2::geom_step(ggplot2::aes(time/365.241, upper)) } g <- g+ ggplot2::xlab(xlab)+ ggplot2::ylab(ylab) if(!missing(xbreak)){ g <- g+ ggplot2::scale_x_continuous(expand = c(0, 0), limits=xlimits, breaks = xbreak) } else{ g <- g+ ggplot2::scale_x_continuous(expand = c(0, 0), limits=xlimits) } # Helper: trans <- function(x) -x inv <- function(x) -x reverse_fun <- scales::trans_new(name = "reverse_new", transform = trans, inverse = inv ) if(!missing(ybreak)){ g <- g + ggplot2::scale_y_continuous(expand = c(0, 0), limits = ylimits, breaks = ybreak) } else{ g <- g + ggplot2::scale_y_continuous(expand = c(0, 0), limits = ylimits) } if(ymirror){ g <- g + ggplot2::coord_trans(y=reverse_fun) } g <- g + ggplot2::theme_bw()+ ggplot2::theme(text = ggplot2::element_text(size=14))+ ggplot2::expand_limits(y = 0)+ ggplot2::theme( panel.grid.major.x = ggplot2::element_line(linetype='dashed', colour = 'grey85'), panel.grid.minor.x = ggplot2::element_line(linetype='dashed', colour = 'grey85'), panel.grid.major.y = ggplot2::element_line(linetype='dashed', colour = 'grey85'), panel.grid.minor.y = ggplot2::element_line(linetype='dashed', colour = 'grey85')) g } relsurv/R/rsdiff.r0000644000176200001440000002147414070550357013633 0ustar liggesusers#' Test Net Survival Curve Differences #' #' Tests if there is a difference between two or more net survival curves using #' a log-rank type test. #' #' NOTE: The follow-up time must be specified in days. The \code{ratetable} #' being used may have different variable names and formats than the user's #' data set, this is dealt with by the \code{rmap} argument. For example, if #' age is in years in the data set but in days in the \code{ratetable} object, #' age=age*365.241 should be used. The calendar year can be in any date format #' (date, Date and POSIXt are allowed), the date formats in the #' \code{ratetable} and in the data may differ. #' #' @aliases rs.diff print.rsdiff #' @param formula A formula expression as for other survival models, of the #' form \code{Surv(time, status) ~ predictors}. Each combination of predictor #' values defines a subgroup. A \code{strata} term may be used to produce a #' stratified test. #' #' NOTE: The follow-up time must be in days. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param ratetable a table of event rates, organized as a \code{ratetable} #' object, such as \code{slopop}. #' @param na.action a missing-data filter function, applied to the model.frame, #' after any subset argument has been used. Default is #' \code{options()$na.action}. #' @param precision Precision for numerical integration. Default is 1, which #' means that daily intervals are taken, the value may be decreased to get a #' higher precision or increased to achieve a faster calculation. The #' calculation intervals always include at least all times of event and #' censoring as border points. #' @param rmap an optional list to be used if the variables are not organized #' and named in the same way as in the \code{ratetable} object. See details #' below. #' @return a \code{rsdiff} object; can be printed with \code{print}. #' @seealso \code{rs.surv}, \code{survdiff} #' @references Package: Pohar Perme, M., Pavlic, K. (2018) "Nonparametric #' Relative Survival Analysis with the R Package relsurv". Journal of #' Statistical Software. 87(8), 1-27, doi: "10.18637/jss.v087.i08" Theory: #' Graffeo, N., Castell, F., Belot, A. and Giorgi, R. (2016) "A log-rank-type #' test to compare net survival distributions. Biometrics. doi: #' 10.1111/biom.12477" Theory: Pavlic, K., Pohar Perme, M. (2017) "On #' comparison of net survival curves. BMC Med Res Meth. doi: #' 10.1186/s12874-017-0351-3" #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #calculate the relative survival curve #' #note that the variable year is given in days since 01.01.1960 and that #' #age must be multiplied by 365.241 in order to be expressed in days. #' rs.diff(Surv(time,cens)~sex,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata) #' rs.diff <- function (formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, na.action,precision=1,rmap) #formula: for example Surv(time,cens)~sex #data: the observed data set #ratetable: the population mortality tables { call <- match.call() if (!missing(rmap)) { rmap <- substitute(rmap) } rform <- rformulate(formula, data, ratetable, na.action,rmap) #get the data ready data <- rform$data #the data set p <- rform$m #number of covariates if (p > 0) #if covariates data$Xs <- strata(rform$X[, ,drop=FALSE ]) #make groups according to covariates else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 # Xs is a vector of factors determining the groups we wish to compare strats <- rform$strata.keep # added for strata str_num <- length(levels(strats)) # number of strata out <- NULL out$n <- table(data$Xs) #table of groups out$time <- out$n.risk <- out$n.event <- out$n.censor <- out$surv <- out$std.err <- out$groups <- NULL #TIMES ARE EQUAL FOR ALL GROUPS if(!precision)tis <- sort(unique(rform$Y)) #unique times else{ extra <- as.numeric(seq(1,max(rform$Y),by=precision)) tis <- sort(union(extra,rform$Y)) #1-day long intervals used - to take into the account the continuity of the pop. part } # start working kgroups <- length(out$n) #number of groups if (kgroups == 1) stop("There is only one group in your data. You should choose another variable.") w.risk <- w.event <- dnisisq <- array(NA,dim=c(length(tis),length(out$n),str_num)) #MATRIX - COLUMNS ARE GROUPS, ROWS ARE TIMES,levels are strata #numOfSmallGrps <- 0 numOfFewEvents <- 0 for (s in 1:str_num){ # added for strata for (kt in 1:kgroups) { #for each group inx <- which(data$Xs == names(out$n)[kt] & strats == levels(strats)[s]) #individuals within this group #if (length(inx)<10)numOfSmallGrps <- numOfSmallGrps + 1 temp <- exp.prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis,fast=TRUE) #calculate the values for each interval of time out$time <- c(out$time, tis) #add times out$n.risk <- c(out$n.risk, temp$yi) #add number at risk for each time out$n.event <- c(out$n.event, temp$dni) #add number of events for each time if (sum(temp$dni) < 10) numOfFewEvents <- numOfFewEvents + 1 out$n.censor <- c(out$n.censor, c(-diff(temp$yi),temp$yi[length(temp$yi)]) - temp$dni) #add number of censored for each time w.risk[,kt,s] <- temp$yisi #Y_h^w w.event[,kt,s] <- temp$dnisi - temp$yidlisi #dN_eh^w dnisisq[,kt,s] <- temp$dnisisq #dN/S_p^2 out$groups <- c(out$groups, length(tis)) #number of times in this group } } #if (numOfSmallGrps > 0) warning(numOfSmallGrps, " out of ", kgroups*str_num, " groups is/are smaller than 10.") if (numOfFewEvents > 0) warning("In ", numOfFewEvents, " out of ", kgroups*str_num, " groups there are less than 10 events.") w.risk.total <- apply(w.risk,c(1,3),sum) #sum over all individuals at each time point ## Y_{.,s}^w w.event.total <- apply(w.event,c(1,3),sum) #sum over all individuals at each time point ## dN_{E,.,s}^w zs <- rep(0,kgroups) # added for strata for (s in 1:str_num){ # znotraj danega stratuma inx_str <- which(w.risk.total[,s] > 0) zhst <- w.event[inx_str,,s,drop=FALSE] - w.risk[inx_str,,s,drop=FALSE]/w.risk.total[inx_str,s]*w.event.total[inx_str,s] #value under the integral of zh # integriramo po casu - sestejemo po casih dogodkov zhs <- apply(zhst,2,sum) # the vector of test statistics zs <- zs + zhs } # cat("vektor testnih statistik je = \n") # print(zs) #covariance matrix: covmats <- matrix(0,nrow=kgroups,ncol=kgroups) d <- diag(kgroups) #identity matrix of groups size (for the kronecker deltas) for (s in 1:str_num){ underint <- 0 inx_str <- which(w.risk.total[,s] > 0) for(kt in 1:kgroups){ #matrix calculation through the groups ys <- matrix(d[kt,],nrow=length(inx_str),ncol=kgroups,byrow=T) - w.risk[inx_str,,s]/w.risk.total[inx_str,s] #preparing the matrix for the first two terms #yslist <- apply(apply(ys,1,list),unlist) #a list, each row of ys (each time point) represents one item yslist <- as.list(data.frame(t(ys))) #a list, each row of ys (each time point) represents one item yprod <- lapply(yslist,function(x)outer(x,x)) #a list of matrices with y products through all the time points, yproda <- array(unlist(yprod),dim=c(kgroups,kgroups,length(inx_str)))#y terms transformed to an array dnisisqa <- array(rep(dnisisq[,kt,s],each=kgroups^2),dim=c(kgroups,kgroups,length(inx_str))) #dnisisq terms transformed into an array of equal size underint <- underint + yproda * dnisisqa #the terms under the integral } covmat <- apply(underint,1:2,sum) #summing down the array covmats <- covmats + covmat } # cat("kovariancna matrika je = \n") # print(covmats) # del za testiranje zs <- zs[-kgroups] # the last one is deleted zs <- matrix(zs,nrow=1) # print(covmats) covmats <- covmats[-kgroups,-kgroups,drop=F] # print(covmats) test.stat <- zs %*% solve(covmats) %*% t(zs) p.value <- 1-pchisq(test.stat,df=kgroups-1) names(out$groups) <- names(out$n) if (p == 0) out$groups <- NULL #if no covariates out$n <- as.vector(out$n) out$call <- call #class(out) <- c("survdiff", "rs.surv") #cat(zh) out$zh <- zs out$covmat <- covmats out$test.stat <- test.stat out$p.value <- p.value out$df <- kgroups-1 class(out) <- "rsdiff" out } print.rsdiff <- function(x,...){ invisible(cat("Value of test statistic:", x$test.stat, "\n")) invisible(cat("Degrees of freedom:", x$df, "\n")) invisible(cat("P value:", x$p.value, "\n")) } relsurv/R/plotrssurv.r0000644000176200001440000002345412700667377014632 0ustar liggesusersplot.rs.surv <- function (x, conf.int, mark.time = TRUE, mark = 3, col = 1, lty = 1, lwd = 1, cex = 1, log = FALSE, xscale = 1, yscale = 1, firstx = 0, firsty = 1, xmax, ymin = 0, fun, xlab = "", ylab = "", xaxs = "S", ...) { dotnames <- names(list(...)) if (any(dotnames == "type")) stop("The graphical argument 'type' is not allowed") if (is.logical(log)) { logy <- log logx <- FALSE if (logy) logax <- "y" else logax <- "" } else { logy <- (log == "y" || log == "xy") logx <- (log == "x" || log == "xy") logax <- log } if (missing(firstx)) { if (!is.null(x$start.time)) firstx <- x$start.time else { if (logx || (!missing(fun) && is.character(fun) && fun == "cloglog")) firstx <- min(x$time[x$time > 0]) else firstx <- min(0, x$time) } } firstx <- firstx/xscale if (missing(xaxs) && firstx != 0) xaxs <- par("xaxs") if (!inherits(x, "survfit")) stop("First arg must be the result of survfit") if (missing(conf.int)) { if (is.null(x$strata) && !is.matrix(x$surv)) conf.int <- TRUE else conf.int <- FALSE } #if (all.times == FALSE & x$method == 1){ #if (is.null(x$strata0)){ # nstrat <- 1 # stemp <- rep(1, length(x$index)) # length(x$time[x$index]) == length(x$index) # } # else { # nstrat <- length(x$strata0) # stemp <- rep(1:nstrat,x$strata0) # } #} #else { if (is.null(x$strata)) { nstrat <- 1 stemp <- rep(1, length(x$time)) } else { nstrat <- length(x$strata) stemp <- rep(1:nstrat, x$strata) } #} ssurv <- x$surv stime <- x$time supper <- x$upper slower <- x$lower #if (all.times == FALSE & x$method == 1){ # ssurv <- ssurv[x$index]; stime <- stime[x$index]; supper <- supper[x$index]; slower <- slower[x$index] #} if (!missing(xmax) && any(x$time > xmax)) { keepx <- keepy <- NULL yzero <- NULL tempn <- table(stemp) offset <- cumsum(c(0, tempn)) for (i in 1:nstrat) { ttime <- stime[stemp == i] if (all(ttime <= xmax)) { keepx <- c(keepx, 1:tempn[i] + offset[i]) keepy <- c(keepy, 1:tempn[i] + offset[i]) } else { bad <- min((1:tempn[i])[ttime > xmax]) if (bad == 1) { keepy <- c(keepy, 1 + offset[i]) yzero <- c(yzero, 1 + offset[i]) } else keepy <- c(keepy, c(1:(bad - 1), bad - 1) + offset[i]) keepx <- c(keepx, (1:bad) + offset[i]) stime[bad + offset[i]] <- xmax x$n.event[bad + offset[i]] <- 1 } } stime <- stime[keepx] stemp <- stemp[keepx] x$n.event <- x$n.event[keepx] if (is.matrix(ssurv)) { if (length(yzero)) ssurv[yzero, ] <- firsty ssurv <- ssurv[keepy, , drop = FALSE] if (!is.null(supper)) { if (length(yzero)) supper[yzero, ] <- slower[yzero, ] <- firsty supper <- supper[keepy, , drop = FALSE] slower <- slower[keepy, , drop = FALSE] } } else { if (length(yzero)) ssurv[yzero] <- firsty ssurv <- ssurv[keepy] if (!is.null(supper)) { if (length(yzero)) supper[yzero] <- slower[yzero] <- firsty supper <- supper[keepy] slower <- slower[keepy] } } } stime <- stime/xscale if (!missing(fun)) { if (is.character(fun)) { tfun <- switch(fun, log = function(x) x, event = function(x) 1 - x, cumhaz = function(x) -log(x), cloglog = function(x) log(-log(x)), pct = function(x) x * 100, logpct = function(x) 100 * x, stop("Unrecognized function argument")) if (fun == "log" || fun == "logpct") logy <- TRUE if (fun == "cloglog") { logx <- TRUE if (logy) logax <- "xy" else logax <- "x" } } else if (is.function(fun)) tfun <- fun else stop("Invalid 'fun' argument") ssurv <- tfun(ssurv) if (!is.null(supper)) { supper <- tfun(supper) slower <- tfun(slower) } firsty <- tfun(firsty) ymin <- tfun(ymin) } if (is.null(x$n.event)) mark.time <- FALSE if (is.matrix(ssurv)) ncurve <- nstrat * ncol(ssurv) else ncurve <- nstrat mark <- rep(mark, length.out = ncurve) col <- rep(col, length.out = ncurve) lty <- rep(lty, length.out = ncurve) lwd <- rep(lwd, length.out = ncurve) if (is.numeric(mark.time)) mark.time <- sort(mark.time) if (xaxs == "S") { xaxs <- "i" tempx <- max(stime) * 1.04 } else tempx <- max(stime) tempx <- c(firstx, tempx, firstx) if (logy) { tempy <- range(ssurv[is.finite(ssurv) & ssurv > 0]) if (tempy[2] == 1) tempy[2] <- 0.99 if (any(ssurv == 0)) { tempy[1] <- tempy[1] * 0.8 ssurv[ssurv == 0] <- tempy[1] if (!is.null(supper)) { supper[supper == 0] <- tempy[1] slower[slower == 0] <- tempy[1] } } tempy <- c(tempy, firsty) } else tempy <- c(range(ssurv[is.finite(ssurv)]), firsty) if (missing(fun)) { tempx <- c(tempx, firstx) tempy <- c(tempy, ymin) } plot(tempx, tempy * yscale, type = "n", log = logax, xlab = xlab, ylab = ylab, xaxs = xaxs, ...) if (yscale != 1) { if (logy) par(usr = par("usr") - c(0, 0, log10(yscale), log10(yscale))) else par(usr = par("usr")/c(1, 1, yscale, yscale)) } dostep <- function(x, y) { if (is.na(x[1] + y[1])) { x <- x[-1] y <- y[-1] } n <- length(x) if (n > 2) { dupy <- c(!duplicated(y)[-n], TRUE) n2 <- sum(dupy) xrep <- rep(x[dupy], c(1, rep(2, n2 - 1))) yrep <- rep(y[dupy], c(rep(2, n2 - 1), 1)) list(x = xrep, y = yrep) } else if (n == 1) list(x = x, y = y) else list(x = x[c(1, 2, 2)], y = y[c(1, 1, 2)]) } i <- 0 xend <- NULL yend <- NULL for (j in unique(stemp)) { who <- (stemp == j) xx <- c(firstx, stime[who]) nn <- length(xx) if (x$type == "counting") { #if (all.times == FALSE & x$method == 1){deaths <- c(-1,x$n.censor[x$index][who])} #else { deaths <- c(-1, x$n.censor[who]) #} zero.one <- 1 } else if (x$type == "right") { #if (all.times == FALSE & x$method == 1){deaths <- c(-1,x$n.censor[x$index][who])} #else { deaths <- c(-1, x$n.censor[who]) #} zero.one <- 1 } if (is.matrix(ssurv)) { for (k in 1:ncol(ssurv)) { i <- i + 1 yy <- c(firsty, ssurv[who, k]) lines(dostep(xx, yy), lty = lty[i], col = col[i], lwd = lwd[i]) if (is.numeric(mark.time)) { indx <- mark.time for (k in seq(along.with = mark.time)) indx[k] <- sum(mark.time[k] > xx) points(mark.time[indx < nn], yy[indx[indx < nn]], pch = mark[i], col = col[i], cex = cex) } else if (mark.time && any(deaths >= zero.one)) { points(xx[deaths >= zero.one], yy[deaths >= zero.one], pch = mark[i], col = col[i], cex = cex) } xend <- c(xend, max(xx)) yend <- c(yend, min(yy)) if (conf.int && !is.null(supper)) { if (ncurve == 1) lty[i] <- lty[i] + 1 yy <- c(firsty, supper[who, k]) lines(dostep(xx, yy), lty = lty[i], col = col[i], lwd = lwd[i]) yy <- c(firsty, slower[who, k]) lines(dostep(xx, yy), lty = lty[i], col = col[i], lwd = lwd[i]) } } } else { i <- i + 1 yy <- c(firsty, ssurv[who]) lines(dostep(xx, yy), lty = lty[i], col = col[i], lwd = lwd[i]) if (is.numeric(mark.time)) { indx <- mark.time for (k in seq(along = mark.time)) indx[k] <- sum(mark.time[k] > xx) points(mark.time[indx < nn], yy[indx[indx < nn]], pch = mark[i], col = col[i], cex = cex) } else if (mark.time == TRUE && any(deaths >= zero.one)) { points(xx[deaths >= zero.one], yy[deaths >= zero.one], pch = mark[i], col = col[i], cex = cex) } xend <- c(xend, max(xx)) yend <- c(yend, min(yy)) if (conf.int == TRUE && !is.null(supper)) { if (ncurve == 1) lty[i] <- lty[i] + 1 yy <- c(firsty, supper[who]) lines(dostep(xx, yy), lty = lty[i], col = col[i], lwd = lwd[i]) yy <- c(firsty, slower[who]) lines(dostep(xx, yy), lty = lty[i], col = col[i], lwd = lwd[i]) } } } invisible(list(x = xend, y = yend)) } relsurv/R/relsurv_2.2-5-package.R0000644000176200001440000000315014070550360016115 0ustar liggesusers #' Relative Survival Data #' #' Survival of patients with colon and rectal cancer diagnosed in 1994-2000. #' #' #' @name colrec #' @docType data #' @format A data frame with 5971 observations on the following 7 variables: #' \describe{ \item{sex}{sex (1=male, 2=female).} \item{age}{age (in days).} #' \item{diag}{date of diagnosis (in date format).} \item{time}{survival time #' (in days).} \item{stat}{censoring indicator (0=censoring, 1=death).} #' \item{stage}{cancer stage. Values 1-3, code \code{99} stands for unknown.} #' \item{site}{cancer site. } } #' @references Provided by Slovene Cancer Registry. The \code{age}, \code{time} #' and \code{diag} variables are randomly perturbed to make the identification #' of patients impossible. #' @keywords datasets NULL #' Survival Data #' #' Survival data. #' #' #' @name rdata #' @docType data #' @format A data frame with 1040 observations on the following 6 variables: #' \describe{ \item{time}{survival time (in days).} \item{cens}{censoring #' indicator (0=censoring, 1=death).} \item{age}{age (in years).} #' \item{sex}{sex (1=male, 2=female).} \item{year}{date of diagnosis (in date #' format).} \item{agegr}{age group.} } #' @references Pohar M., Stare J. (2006) "Relative survival analysis in R." #' Computer Methods and Programs in Biomedicine, \bold{81}: 272-278. #' @keywords datasets NULL #' Census Data Set for the Slovene Population #' #' Census data set for the Slovene population. #' #' #' @name slopop #' @docType data #' @keywords datasets #' @examples #' #' data(slopop) #' NULL relsurv/R/rssurvrsadd.r0000644000176200001440000000655314070550357014741 0ustar liggesusers#' Compute a Relative Survival Curve from an additive relative survival model #' #' Computes the predicted relative survival function for an additive relative #' survival model fitted with maximum likelihood. #' #' Does not work with factor variables - you have to form dummy variables #' before calling the rsadd function. #' #' @param formula a \code{rsadd} object (Implemented only for models fitted #' with the codemax.lik (default) option.) #' @param newdata a data frame with the same variable names as those that #' appear in the \code{rsadd} formula. a predicted curve for each individual #' in this data frame shall be calculated #' @return a \code{survfit} object; see the help on \code{survfit.object} for #' details. The \code{survfit} methods are used for \code{print}, \code{plot}, #' \code{lines}, and \code{points}. #' @seealso \code{survfit}, \code{survexp} #' @references Package. Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #fit a relative survival model #' fit <- rsadd(Surv(time,cens)~sex+age+year,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,int=c(0:10,15)) #' #' #calculate the predicted curve for a male individual, aged 65, diagnosed in 1982 #' d <- rs.surv.rsadd(fit,newdata=data.frame(sex=1,age=65,year=as.date("1Jul1982"))) #' #plot the curve (will result in a step function since the baseline is assumed piecewise constant) #' plot(d,xscale=365.241) #' #' #calculate the predicted survival curves for each individual in the data set #' d <- rs.surv.rsadd(fit,newdata=rdata) #' #calculate the average over all predicted survival curves #' p.surv <- apply(d$surv,1,mean) #' #plot the relative survival curve #' plot(d$time/365.241,p.surv,type="b",ylim=c(0,1),xlab="Time",ylab="Relative survival") #' rs.surv.rsadd <- function (formula, newdata) { call <- match.call() Terms <- terms(formula$formula) #to rabis, ce je model mal bl smotan - as.factor ali splines ali svasta Terms <- delete.response(Terms) newdata <- model.frame(Terms,newdata) n <- formula$n if(formula$method=="max.lik"){ nvar <- length(formula$coef) - length(formula$int)+1 formula$coef <- formula$coef[1:nvar] } nvar <- length(formula$coef) nx <- nrow(newdata) nt <- length(formula$times) temp <- list(n=formula$n,time=formula$times,call=call,type="right") Lambda0 <- formula$Lambda0 Lambda0 <- matrix(Lambda0,ncol=nt,nrow=nx,byrow=TRUE) rate <- attr(Terms, "specials")$ratetable R <- as.matrix(newdata[, rate,drop=FALSE]) rat <- attributes(formula$ratetable)$dimid mein <- attributes(newdata[,rate])$dimnames[[2]] x <- match(rat,mein) R <- R[,x,drop=FALSE] newdata <- newdata[,1:nvar,drop=FALSE] if(any(formula$mvalue)>0)newdata <- newdata - matrix(formula$mvalue,nrow=nx,byrow=TRUE) R <- data.frame(R) names(R) <- rat ebx <- exp(data.matrix(newdata)%*%as.vector(formula$coef)) ebx <- matrix(ebx,ncol=nt,nrow=length(ebx)) Lambdae <- Lambda0*ebx temp$surv <- t(exp(-Lambdae)) temp$n.event <- rep(1,nt) temp$n.risk <- n+1 - cumsum(temp$n.event) temp$time <- formula$times class(temp) <- c("rs.surv.rsadd", "rs.surv","survfit") temp } relsurv/MD50000644000176200001440000000553414151655142012277 0ustar liggesusers564b19a961e2ab8e0ce5acd6f826cbdc *DESCRIPTION cb64b9f81f29874afd34bc45cef0cc3b *NAMESPACE 6e1dcddd9af9684194b01d988e6da927 *R/Rcode.r 349a599e32b83cc74898f83171628843 *R/cmprel.r 476d5effd3aff473f5ce65717dd4551a *R/mystrata.r e8c5220a2b671c39c0be09d5991f5aae *R/plotrssurv.r c3a39cf32981ded299ebf6682903ef6a *R/relsurv_2.2-5-package.R a68b2a2e02b73cfbbd7a99710a01f69a *R/rformulate.r 5a1d04506504414eaa1db26c12211794 *R/rsdiff.r dd7db35d55a5b85d7e266e962dffcce9 *R/rssurvrsadd.r ad6a3841c5ca78ebce134d96d7092193 *R/survfitrsadd.r 1f2ea22efa772871393207b0d2ae8ec0 *R/years.R 57ae60e1950ce5ed7d651fe4378123bc *R/zzz.R 3d33b58409d59c1f05de22766960f039 *data/colrec.rda da512257141fedce138de599b5e9997a *data/rdata.rda 3c3911dd7383d8c3a39057655a7978d4 *data/slopop.rda eb7093b9f50f7f6c4b928caa368e537d *inst/CITATION f4125517d598ee88f1f39e2a015e827a *inst/news.Rd 596ab3b86df7a65e108233ef82d47b51 *man/cmp.rel.Rd e9e43bae88190dd04b902a6e3e4e702c *man/colrec.Rd 9107f531f6c42fb0b11f6f607d2ca0ca *man/epa.Rd ee54074161ebafca61f9a338660046a7 *man/expprep2.Rd cd16fc0741fa54b6ce43293678704531 *man/invtime.Rd 185f03cd09bda2acfecbde763fce4209 *man/joinrate.Rd 612ee95ccbd481320a22c018d52675cb *man/nessie.Rd 20bce6009224687971766e0eda63e94a *man/plot.cmp.rel.Rd 7d3c56fdb98b7f6206776a33555e2bff *man/plot.rs.zph.Rd 16c09360173df65032001387275b208f *man/plot_f.Rd 26393eef7878e2e94b8f5e26cef4ebb0 *man/plot_years.Rd c28a88ecfa1f891e98c8fc9ef7566e55 *man/rdata.Rd 6250388945cd3d7d16d350ffdefbc776 *man/residuals.rsadd.Rd f9c97c4a0155e5369b7f3b6efea06f86 *man/rs.br.Rd b7e2bd60b2746fb417bd9cd42568440b *man/rs.diff.Rd 86bd19cca5099361d1daf8c1b49dd841 *man/rs.surv.Rd 9e15fc20ce29b0a0c6e695414ff853e9 *man/rs.surv.rsadd.Rd 8fd62311b08d3fbf8536f38c85625e50 *man/rs.zph.Rd 64a1f206fc6690cc3b0b3a0f3466b860 *man/rsadd.Rd 45932d98be554ad05806c9074aae80fd *man/rsmul.Rd 3f5027f1683a5d943c101e89a9320eac *man/rstrans.Rd be655c8edf2364de4cc91c03c6e61487 *man/slopop.Rd b4255e5550219ff1c8213cd714370b70 *man/summary.cmp.rel.Rd cbfa220e137d653bb298d6f190d7c163 *man/survfit.rsadd.Rd 43de679849893f7f8847efb130cd7af5 *man/survsplit.Rd 713ee65969b8de3669824feed81846cf *man/transrate.Rd cf4fc8e8e26c47320eb1c66f774205ac *man/transrate.hld.Rd 306fbfe05524abc49ef46c681ef2ca93 *man/transrate.hmd.Rd a86d69251566da890b4c4c95ce066c01 *man/years.Rd 3165b274aef1ec5d5313b1c357ff23c7 *src/cmpfast.c 6853ad4d02cc6b1ff9e2e786f7dad4b5 *src/dmatrix.c 35fe86cf308d11c704de3aaf3e58a629 *src/exps.c 0553be7d03225d831692b0995a3d9f63 *src/init.c f1508f17270fdc2fef10788b7ca034be *src/netfastp.c cf08c1197fb1785378c385b0430c5170 *src/netfastpinter.c 9da637dbb10add8b072da100f842ecf4 *src/netfastpinter2.c efc2b2569dbe343bd85568e4303b3296 *src/netwei.c cc28deac6535fac9ab5b4be0121035c7 *src/netweiDM.c 2d85cafe474de3c4d9cb2df04eafb8bb *src/pystep.c cf7cd04af54914c338bf99663db7e2d2 *src/pystep2.c fffb5d75a0a72415aa59db882ea7933f *src/survprotomoj.h relsurv/inst/0000755000176200001440000000000014122600241012721 5ustar liggesusersrelsurv/inst/news.Rd0000644000176200001440000000424114151651012014171 0ustar liggesusers\name{NEWS} \title{NEWS file for the relsurv package} \section{Changes in version 2.2-6}{ \itemize{ \item 1 December 2021 Function years has been added for calculating the years life difference } } \section{Changes in version 2.2-5}{ \itemize{ \item 5 July 2021 exp.prep is copied and exported as expprep2 \item 5 July 2021 All R code has been roxygenized } } \section{Changes in version 2.2-4}{ \itemize{ \item 8 June 2021 The latest version of slopop is added (1930-2019) \item 8 June 2021 The C code routine netfastpinter has been changed to correctly assign individuals at risk for left truncated data \item 8 June 2021 In the summary of ratetable objects as.Date is used (instead of as.date) \item 8 June 2021 A C code routine netweiDM has been added (based on netwei) } } \section{Changes in version 2.2-3}{ \itemize{ \item 28 Nov 2018 The CITATION changed to include the paper descrbing the package published in JSS } } \section{Changes in version 2.2-2}{ \itemize{ \item 10 Oct 2018 Corrected a bug in rformulate. Strata did not work correctly. \item 16 Oct 2018 Removed package splines from Depends to Imports. Set the depends for package survival to >= 2.42 } } \section{Changes in version 2.2-1}{ \itemize{ \item 10 Aug 2018 Corrected a bug in rformulate. R in (rtable)date format is put into rform$data, the original format of the variables is not preserved } } \section{Changes in version 2.2}{ \itemize{ \item 15 Apr 2018 Multiple changes to rformulate function (by Terry Therneau) to be in line with the new survival package requirements - several date formats are now allowed (date, Date, POSIXt) \item 7 Aug 2018 Add the rmap argument to functions rs.surv, rsmul, rsadd, rstrans, nessie, rs.period, rsdiff,cmp.rel, as is the practice in the survival package, and update the manual pages and examples. The ratetable() argument in the formula is still allowed but flagged as deprecated. \item Allow all the transrate functions to work without the dimid attribute \item New Slovene population tables included (up to 2016) } } relsurv/inst/CITATION0000644000176200001440000000202414060340642014063 0ustar liggesusersbibentry(bibtype = "Article", title = "Nonparametric Relative Survival Analysis with the {R} Package {relsurv}", author = c(person(given = c("Maja", "Pohar"), family = "Perme", email = "maja.pohar@mf.uni-lj.si"), person(given = "Klemen", family = "Pavli\\v{c}")), journal = "Journal of Statistical Software", year = "2018", volume = "87", number = "8", pages = "1--27", doi = "10.18637/jss.v087.i08", header = "To cite relsurv in publications use:" ) bibentry(bibtype= "Article", title="Relative survival analysis in {R}", author=c(person(c("M.", "Pohar")), person(c("J.", "Stare"))), year = "2006", journal= "Computer methods and programs in biomedicine", volume = "81", issue = "3", pages= "272-278", doi= "10.1016/j.cmpb.2006.01.004", header = "For regression models cite:" )