relsurv/0000755000175000017500000000000014351055733012114 5ustar nileshnileshrelsurv/DESCRIPTION0000644000175000017500000000205714351055733013626 0ustar nileshnileshPackage: relsurv Title: Relative Survival Date: 2022-12-21 Version: 2.2-9 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.2.3 Packaged: 2022-12-22 13:09:50 UTC; dmanevski Date/Publication: 2022-12-22 13:30:02 UTC relsurv/data/0000755000175000017500000000000014344051441013017 5ustar nileshnileshrelsurv/data/slopop.rda0000644000175000017500000070057514162606446015052 0ustar nileshnileshgPV53H9g3(@Eŀ HEP(HɈ"9)9]vS<,=z* 9 S$T**$$dHB;wWО^<<԰xW2V?>3yumoѿhӯu{ؒ#bwD/%捸yз rE7Qχ)^ы&w^,:V&DV vѳ]h|@\*q=uq˓hb֬|Y*o9_@59fGc4Y{hvX=w4ێrmA '@:efWhy*:- P,iMk{5\K_J)x(sag_u@A_@&4o ?SRǂЧFYS]<aZ+\{nEΙh-ԋrl%W62G* =Y6W@ȉ%m3f; `{-p9Ȳ78ZS\!i߶撧MR 0 g:,WE$5N qSŗ&Qh|I},ڋ:Ps[APùԨ%x|1nT6">%*Z_ v-yI5TûcBՏdHpxG-ѷ'"׵wu"ꑘ-忍zsE^ܳl~2~in1~ T?^|6# ?_ \1ׅsԢ;-MрO疽hTp}4S,JGC}ؗp ҇AنhLW-41tVk }Y.&|B\є,[i?);f%yբYs&ѼمY3h1ܚr&Z+G*rPmRƂC~_v>xl4W|@, PݧV5m4vaiz+<ZM`j~mjEE~*omv: V'vgDV>_<.?|])ր`^侵P>iBD7L;8$$Zu{lG@YawYPLN H/ہʐN e::؁{AB*^)t}Mo c@F90,)Mctهg]a9T ̦nC$XJUE</WLLeN]_/Q{4Cy{\ɾnK!%}똮 #oG܎;;:6jGP'7ms &ݰ.,{s`f q\ 8I&+fz[GZ:9QlClj3Pɞ~_˨'䭌>10G- }ʚ쪏 3WUI4aCsIJU0Tf8Kw ΐgGTwhFKp j}%67įs]}aVcߖ9;jiYC?jv/ Iu@;Ҧ*yG@8Qȿ1udRD][c$$2gP ;znԽƓ@KBQz e0>UWKXq% zI+Iқ@іpZLN{+)PP8̲ utp\tî ٸ+𔥵q k%7]:gkQFw6^4OYvvOܩƐZMd8̆&*9)?&7S&Bڏg$>a $55@PRLn ԷJoZo.ݜ7π2>5zN!M?*F! 試?C r6lg \T@$]srY,c$:yd mRP<P2>tþ&hnhV`5Ns؞l|ܧg{aO[8Xp.KaD'y.8'j4mG ^˦K/8Sl.g--B^2tQ53fGG'ٮF 'l?PՍd~0 ΐ1o]" OGJ 9zQ}MGI/y< ;tl{'P:e!A $?/GbO/|O^n'PS|4 4!MQ zA#1uyo?D4uJLɊM,KW@3#h~[AЂ$hQZ,W7WNɜy ߁,/i2PXwp^}.=4a@xhg +n L*T\{ЫV`ݔM:5?O='~\gt4mHME=*iHvݥa+@DN I%w|AU/+@ RbLǛ@i"K|8u[l,2+DC=@#0g349x=r@'bర: [Y`zSl_[6%x>PAYsaj,Pb,+MI5ނi`& s`>un#fx 9_zoxFMOK%%P?O<6LGODKn.oB{E)QۯJӝ1 I{5el br2'}gP睍?G+cqcJ\OթXR$Ǧ39^G.M7מ"fm|jTN-8K3LPːZcw[rC8{z+,8О,|+,zeg`G}Bw|jUoBFlgi8h\y4\zD:yg`KAhJA˶g{WCkW|*]TZZ7u!Y7 'rȁ_"*}|o:sE2&Y+0}v#0{?r 8K$[OAL^ENG p3Hws;~r {M}!~i%]Q(e"gWABv:XSN^ b]rRCSi_W+ؘh6X+G/2LmaS_EppAmW*;Zum{98 ^7oJ 'U^_TlO9Ӭ4D>100.0Ctoڡ/V$'oN7:rS-oq)})| ǵT'2dk:ky}2UZ:WEXfǶ9.*Eu_#IUv߈yYX[07fk&<ЊnF3&lݻ> h~ߑ tQ|Is3[֓\B)]|^sˡM%L5O Eh xS#Z;THOݥ ̏~٫қ=& )P!qP֊W&qSӆ8NN-z'=6>/tq١ORvϝg~n@N8or$j,m15BlazbD7C|ۧNIkDkuډ>uG"Wk8!`:B2жs-|~8F2w^4QڱMH%f'3.飕lR!*^~CyS,)ҾӅ_rޚˌ|VǨ 3@7a}'ЇGw1eG0V]Tw IDq5˽5Se<<ϭڨQWAۀz7ku28#p/Ru^*/:Cob'n+ 5= [Csc7();n]*\7- j(i@s/V6-z+g7ylt7b* '. *A`) '`fN,lY )|5J:Z-cm&0"ydxwX6 SmIٻ@yƛP1.fհ7oɦI_Ez[%#-`a`]f~z7Wހy Ϋ>u;QC[~ `(=aF>'xOSkXԡB=Qx:7iQ>&.˃Ѩ@ !/P3JGߏ7vLDM n*SGs,؅4Y~'a-0g,vI6}7fw)kɞC]@&VaD72y䏌(I5T@sZ>#P=C V]`Cف︀YvB&0gi?e%'8k[s;y̩9vmQ`J}v,İ![ 8b6: btr@Re0d&O}ڱ OvKP-(*O4'澁Zû4. (&=&:Ǭ+;AOR`Q⾚ M2](>LJh>.I+_0FY?_\q6 VX2HcXA+fצu, Qϸg[sH.:#y9 x=n3!p<15%՟ho?ߊ*y\qZMK GUm'eK f B#tuk4b(M Tv;x_lA=|'x3LLpw% q,gC$j14pքM=9 ]tъQy%'?&<4LU R8e0ǗZg6;Uh`:6Me 솓[űG}wl|w{r k~(/^GF5Vhf@v#_>ќ4­Y_A`N{ R>iZPlO7@I"+ /5AJ;y,赝߮"qțAԲ3tn;Iz ɯ^I u {gZZ~# ʧUXƲw@UQ97 [93ɩAfMjYa]?|!@OyYsMPZn0}x@arX^~5|MK-wɾ9Ei,&ZqFY[UUXj<qakN׉ v"k"OY+ Y$#a|uo":غK5x:NGsi =4WCԃp#Y.AM>OE w8f Xj"ŷ;@v"ќJXH˙rvo]@K*#Нlz+UlżY`V|\ѷY+9?YN`+3 % l(~Kϓ9PuZ xJ{5n)߱ Sӱ38ff ZOKTj%g̎\- v9(]gLc:hmP t } g~悶2>r.ّOozm/x/]`[LX4nJ~$#nUejav l\4 .[ڐgXrwׁf6G΃D+rj Dqu4:)z=>gpd~ӵ=E ?ߏg*4?%#U<x[yo^P2:zOqa}C˞7Я=]uhBK+X3 BtR999<@SΆDw9mBGԔY^B Qa{cb ; 4Y/WpZZ噱s{Lq>q*\&\?WKIC Xf\;K1RKՃ+A|ưz؃ oHnP^E1䝳,{N?Ԃdjsσ.sJЎi`[)l gW(qu0#ϤT=נnbdbs c`~WzDT!٧49<8xeXjk{ R'/'Z(H7薜r"(. |f=xܐl Hј5 }1~ކcиVм[Ah|+`ฐ'to7Wt %X %%#{ bK 4,}=M9IvUCw oWU%p_ˎh1At-Q.4k5@&Lҽ{Z|H֠Ճ@-5;0[{sQ?0RXd< v+e[SLS **fR@k@ʮ{OSfoG%!SL=Aי} 1+3mnjgVVo >EIe [Zn|3p8)T?O_1m&uAlM٥z@fv׹`U!t3sgGu'*rN'#ޮ > Gwl2rWas3̱ޥg\2m#\r@ ] U?98|yKΏ0Aq!z p~߱*5}5;@ԙp֩}<0b/ھDk[aѯ g/5ô'|h<borjq MչȆfO hkF _:2$DsVwdWm~ &ȿ€U7P&pnZnuS)Q@2*.{}ט 2X{e+?yօ]"{׭4J;ߖ;ǿ]ǹRAC.D~y"Gbg-Q XQyeRu3)bE;tPv8R>ZjNFgV['@Cl hX IZ0ԍ1rQ1dq Ӝ6 SW\ MX~F|\`cpr ZOqdg`Wz8@'\Zm%ևpR\sөZv&zTE?#Gu8KT 93Qljub&/g]~iu妔 D}8 gɜa| eܾ x}8n`UX0%FN"sAC~)3eh[N-bnajE=g |+mT Z! dUКU^ ?rP̶MHcSĜEeV}u \ ~ML"hXJ b~#@g|F(xk]ߛP6} QvHo/3.Ƚhg pj }ib V'@GNP HyoK8ôA9{]/<} NH-)aS :bcjM*~ _eo\<u*y<^ŋSRک`%*?2.̏~s:(N'fKDG/O4"87LոQbXN]lai}p#D E=,@E5yJ Ō7Ŭ`lnqFO 5/kt.};lEs܇. 38FJM#'oy\؀g 2wrAV$0!IgM 7  ~?? ? 578TzÎs,A)`IBM Vw`~`30iW}ܐ,S(mFu·g^OK%9_'g`A/wa0:??05=#|m1QJ^su8/?+`})%8<ǁ3{?j]e&Xq| \!gz j{ NF+ig\:hj?r Ђ[-kd%Qd"E \< #] h¼Ci;TM3/t-\g0y:~#<π7#X:㩦Ug.]4;#KՓI2_#F|b8 s>Ty0%Dܶ'aJ8kDȳ;* +ێϜxΨ}F-D#q&=@SoK<*~Ys.iEٞԤhuj>vLb Q H^e5Ha=H.;"e PRhiKXѶ2o:Va`kb)`srNկm>%*)Gp/.AI[YD~q:#|b?x^8nTa_^8  u sc>yxadt/hSDOU]E*`Qd6>f-U qp5b.WP^KdQr41O #'Hr nFQ2sΣ$`)LxDۉ6nA]`Y:$טpYk9DOx+Zc㰿hGz_%];BuN?8~x,v8/uQǁ.q1*rG?s֭|>q_Ώ}۸gcMbh5=ߎD36Thjv=yaA23>=Z)L2 _RW(|*@}țצ=]2 67Lw5g10WXS OF[ɇAQb""fyς} W=٘k |G_Q5;=1DW {Q s1z_Wdۂfo9C@%ߺސBT7= 2g@>|_ $stĝB϶&)~0ɾj/M",ܲQLvM+S3ԕF^j_8d1N7ZA5=G?̸Ը`w |q?>qA;^%xDz]SGXoz\ݺpa~Op,5'|j8߯}6h*Ix ^ ^lFCAwc@&ҿ^(J{{(3 ԓ8'[@is͢2hq{|Zɵ3y#t~J/0t?L M &ΐHL6m~V;|%`v5=*j vg&_x ;D"lc}^ Og鳄-O_'ɛ(,ĎПyw突KdZ<rI_Cw?t.c.ޕ0ð6(o<_483ٓe*Z&~q?ssX'K(lj~]W5z^EZk/?NN\4z$(Z0Jq^N$I87]E4Ի7=@3}EbN[5y<> ۱+7Gʩ̍s_ oC%u&#fO;Qä犨t>T:rZ *61?O}?<[Lb<ީ}/TP3¨uATjEVE5Jo1/%RFPCXz@f. }MvFwenDHZ~ַ47-?pnzuvѲ 0rg?y/۠Tsa+y(jΌF5PD݌D@Fq$\XL̳@"'U  U#VW;P0O =\vdG|TP;{f` 59B+`nWOtB;+׹_d@07n =;=PVW ;j̡٠x-2[U=>hcuy`F* v1KI,*zCe } Ge۪ecGwCQ'2*MN;>r }:O';uVF5vsS:>nY7,5z })>#tUFw@MQsPKORm2#G3g8Yԏ\G& 9Pso6]"z|C/riX { ( ˢwau=OL>03?gF\Gp=Z ڋeCK=/6eN _rI :H=a@㸭\ P04Pi/C` Td3'GKOXZѯ ps} DeR:@^~__!k3+uj>h>[4[NkY'AK?w+B+I5@eauK>Ŷl髁|3(NEeo/]Ps?K30Q\TI7dȤ"f=;=LlLgQp_ӟ2򲣰\R@{kq V4~i:#'.ؑ#E~ s*w ?{Vu()MS NZ-kP j:b5^fWU,h #`j0e+; Me%~0!18zI Y]lzgXZn Yay_stڶyo~xU_-S?QA.iM36I=(t[KK qU>9|=\۝^ λ:^ۤeS=@oӽZ񟯢ehQq7^c(GN|KA֩^캕zu\mB*=0?oҎ^G%0z ܘ^S-<ћQ]J-W*Sw\mHUU%%N&wcS5.(Ï߫{P"똼CoDM3>Xqz=t| 2^|FJYCe]FC' 6{kЈ=d<2?ZE~}ISݏm]&PUz`ӕ h(}H5a1. /h(f^l~h2ZڞYؐriT8 wSwɁf9(fSSKȀ? '->Ɂx&d(D@xX$nQ K_lm -?ک@z.>ky%BCl?suw^l1hL^RAw`(V]#`>o /~\2'WCjSaS-LܲmFƞtSRצa aӁh}eK+5!%%DgrZDWHr3JVN& QAr=?@:{Y@6#(In^T#5;`p6ul>Ly2X́0j{47_nMݱ&8ַݮ0W'=В#>_^LYI\u]4GY¹5(5o$ Jq}ykRfUbx|Ls gQP?8h ?I^>Pqlڇ$䫃T(;$y8G[ YPցde"($)?|PɢWЛ}g,Lm'P%K<2޷1S'D}^*l  @%| WF./ǿSuenVV؍*x5@5W[\zJ9ٜCިQ[c}Rf,36n!)̏ށzUb Sh \Սh/+0wY  ?@8!5=!K^{Xsʝ LY~< &b)u7?I㕆H0' ;-[!'SspKp+5!c2DF ~nEc ^h@wҫT`a^ՏF(S#}P+peuj o]og (<%VV[чmۆFQavlfQdaO\"G :PasqFT貨Cj|/?A Qi(5{T:bJϬYhF#Q Q3S5U>r@j${ԝ&x 5m=emr''[xӱges^Q8Fi'jwǻ{QoRGԄ7=y5~f՗_@#=Gㅊ({Bh܊ ޢY5sѼPJ^o4Jz Z]$ $Rk27ׁ4Df逼K\] PHpϋdrQu8SŔɛ=Tb~<۟XS NTRy9U+n>w; StT(FV@ac s}-, Cj3㶂2{U;,$w@)htLy:>< zh-Y>yCd7mQgU5!q#$0Kd<؈f_؄oTAEԨza I՟Ypfx?_Bob5ƅ/QR7TlG~GxPas%n::!wq511QKC9 U4Aw/ڍ`suDmurl4?hy뎈` 1m Hlrw2OE cPHw^;썳[ف| ЙTq",~`9:,X)yد =ambꕿ o/|L]6iWa d* ^Q'3_@tL{MC5n:uU\bN/4F%eǴ[ | ~ /px" /&A$uRUo@ Y pUhv߿ J:f:@Jud,hhD_|$'U 64CP٭`[q ̖oU6gK ϧm{`waiZǸ3ADLjÓ1пOFn(ؑLemK$G Pxφ\LGԤ RD%`{ۿ%y;XXpؔ'L6v] *9%oQ=ߌ^> WAbE=CQΗt1􂢳|8~: "HPy TTUzwRJ5_@slΪO?9wVBn]D+\Eշ,A<C*9$t*"182I[T,QUjHyTiJo[J*?:9ڡO;J;6ԼX 5gUeyP[.g}Pcݻ7Y֖Ɨ-QOhF@?^ =M Q|OXF8/Q 2LGJm}&jёI4n,ZJ:f߯WvEqhqoa:GaܠLB ])z ÿS%O=OSn] te0><* XhD'l`+w[E~ʾbXiqg"p>x 6ST_JvbS<D^s?"e{]?S Ӑ{ ~5ce^AOG> 2S|_)gbBo (Ǜ0615.oӠ>wuo o)`v&en^#ksٕ]`+v_Z-lCl?ޫnj8ԃCSج5[7=@72}8B]-E%m Q33MӋOt{-\t2w(B認QܠC|,2Zä^@/_;WEeiIZcBܹn*r )zrd< T?8r85c*(E[MQj8ʱ >B>L@S>$!)էь_q1 A9L'ԛ LfGy 5H` ~yWxt"/iK_\Eknb]7˜:w^MO+Q.k h:{+%=S;}1}bgL#yA:6vSz@!X ~PQvU;;A-dq 2=cpft䎜ԫ\y`d1LIyu+_j~vk `cPrR$XVMvpp ^' $iy|1.{~=,vze=5U6 [ ndG3\Sߠ{M7 ~_ d4QA{1׆i8un!-`%=+ghF74?} |Ӱ5>_!Ӄ8:n}:Nw^<}'X깓⬳/GCId-}pGj$.aѻ+1F\/Ͼj><3Q4A]؛>6L?aSPV4ĠO)@],EH:vy1͞=W{{s4<'e4?AvsJ-)3{"{VЅy{t(unc`yH쳧mZ< jeC`[PL77`nXhonv3Wn.̨6prQk>cϕkAcU~$h_-dK"uSr^dv0x@,طXyƂ2l}O?9 &>+-ۣםV ֬k2sљtpv7\\N'c-?dh?OY~hv±ዃ} _w~oODY1grq]c|c_EmC\QMSʶ~b߾]OK%q3itJKG4h!Zhh k31}m3AO.iͼEs'bKR_R쇰F2sYޚKv&Pܟ@ۉx=/To%#XHN8 X+7_qa^ έxaOsN/rA󴿵$h]* ϖt0w?M= e,@![ (-L i8 jھcFN䯏͞˯L3iUGGg`v!l'kNӛO&!`޾;XF=1S6`P OTmo,Ms)?..r@|GApf2 kP ZY[ZڗsLϾK}b)ϻa*<?J]X?6{sx^TI"FK%ob*n9:<}mqc:%:.EqY{%fxpB( c1q{M=A[E藢J=h645*Wh5_' Vmxr*, Yt(/Ia5a7+@O;`s305q( _,71)@%2X^S҈%\iWb:AHnlḓUOAe> |Mp8 ;X¶^k\N$!~ywJ̥`|aR߃)gU~D8WY=a9?v{QQWv_#IU_=&pXTb=7)]fq[`/jtNN/p| Y\=qk$]Knbޛ-9r.}SFsTxe+Y8H[ahfD4;q!N-N7)3BwgT^bΛ9@%pxf2b1~YbK>3`;*t~`h͜OGg*5Lc? •Xbn1"ycHD]deqN =<Ǎ9!t}dJ|LDf\sϿ->m솝ۖf. IVؓˀ]o='bI~ޫދ>7#KG\k8x^[?yGp܆1>p܈/]n"ΏǼ8쓀}-Ga]_;tlmR[b/ޫ}0=[C<>7TsheKh}Y.&s] G+g ˈ'Kb)ߥM#^=@'E@a=yeP}j8K%d{؆Doc쾗'ex=ݼG/_FRwmCvʯYѨf yUuh+ȟoNfrP; ÍRи4Z\M$#u\&}tB }rLb*︷=&D-70< V1w|W[%|ٞ?Q_緁\yœOx{8ø+w53xf ?7710q bOʺ q|)7tjJh(XڝOx&n?ny<2#fN+Al_ ng\mNro Q{*g7G[i1 "15:/uhi2Um$5`5*(q^6lY<ɫ r[Z-&kp33uG`r3]Uo<ȘS[U,3`j\5#Vwns|< z-{NccI%6%@83~1Np|?8Nq~ޫq%'qΎ9aa>xyc5σI{nQr"7m&7yoIgC$j14\zD:Βhwn)18fj]!{6 G y;sr׏:,X Ok@iܔUT-C}u>_z6P$Mi >= Ͽ;ѹ?iDwpA[?L< 4zj;,<+5["Nvf# }uĻs͋W`C} L۳w ׉V[e8k 9~c>8<o]8's tW8ğcxg|Vʖ;t9:޷obh;P0do f'RA*$kes &5y1P}* 6Kkj@MRђ̷DžL}9`Qʼn=`&xE9.̀Re0rxe,E9ÔlR"xɘnX9u% I/o'to;ĸXz߸؏70`]8a>Xω2/{uZc {+X&<bŻ2e "C~4S&%d`,0pr|}o%pM N]Rђ {24ֵ: ;-h7g R5,)AʨBJ/-qfD_ԴXYAF͠6m޺oRkP2O +/s0 QI0ZXUAZ)}0,YV#\,X}>[#$fހI FniC9`u;E0"s1HL ]F?UG?Y?jm8zA^ #WHOΐ?uu_?X_X>ؿ|4X{H܎B~";8] P!%hAau3q{7=u Nc^QZu19wh: %`w}x-O0Kx#Λp%\OQ& u~ {6 fW**66{2'=i?;6lE37Ulg/ܖC?jƐI@*2sKȒm>"c@濝 [3-O흝K i{!|w2v{e~P̮e}<<~[?^8DqM \erfSkA:Mݘ dYd0́O%ޠddI N) l]L@suȁgGr#Kh%FC`c6>FMYV(薀4ڽț"-}C:HV"lU$~>c~p 8 _t>#K1:{1'00ャDe#U anqE]o_9?BQg$+j@@e}qѤe{>UbPTI/anRSH$V>Zc1mGӿN8/*iQm,~ }qG~8Yo'}؏`㉜w`8yޏ/0o?/o0no,yA7w?JS!ׁpރJ2Ceɨ Wu" 4ԑB#!!_9  1e5^B<ȹ[q@aBd (խRZoR"YyoЋbeasGQi![s8HK|<Vu ê5rB@^DG/1⨊tw!KwϾhf<:#O>E|$hCDGиTAyxtADNJ20հ~>R& /vEZ1BM+9ߡ༽p1يз Ρ[qqt6D~/ ?:2 w.?0^8qK1߆5㶥s*["mo$~pFDxNSѸg;2τO1Z/xNڑ~2c"?*}XLZ(6{kbOz@s0y n sr`enF%StDɶ!}o\87ni~4[Zc~ s8-:(78p- 泗 a:+0߆x51_t2=MF7CzHy]7l[A}v! 2Eᾆo^Zt4u^H6:'<I3Dϥ!/Iz!{8.O0س_q݌d;rL'Hpޝ!X"NM[ ̧tr*pd㦖 먥c/g.Y3 >Z%[5~=K:W7|?G5Mb~1p ~<㋬&vik< L?@/^{H}./rsY9@؎1)DH)qM2h2\Vџ?;,hbK#t~NJgɾk&ỽs;Xi \&ȹ\\tZƏ#5MjTC[@j,J}D-7Jz& &U |5N%.d;g/An}Ҡ3e];Qd ;As`$TUS'|'w^fS*j`CN;zئM2u97Ћ'arSYji_8Y:C6Ώ00mi}ɷ< ҾKCgi_+YGą8"#??ד:~xJVl$ s òvgd`y1 dM˕GIJgt,?+|VT>"{>I=JE !JΟ 9֟emC>9[;5nyDX򀦸rn6kYNs뱍/M ȫw""rr.yW)Vk?/~Tg)RYYV򡔟Y^KλR `$7K+3KW|t.0:}A8|6"[ ?\z~C(A7o;@_xFXT9MOm|}M~m{YmgSI@=i@wa*dRKo0rZ p(5*=f. V)S7xW*鯯]`ӆ tG5v0Lx<W/7 '^m" s5$b-s*To1 N ;A+f^~9*Y`h2* / f&oS zErNȕmzեR?N GwDQ[oCQdt9Km/00N8~g ti=Ώbށ :8O7}x#mϳm_Gm 벎r VJ}\Ms]'g&xz'{j:t&fP#t zؐC1;9 a{XIg_r׽ {tH4qrZ z47q}T<69Tm9^ɝ@w' dg9*|2N }8w$182Djw*jÖ#M 7 =; bDQAP=#|*@5֔}v`{jVh5AU`-ǟ#̙kHy#)0ub`~(Z=0#Tg#*NѪKvtc<wσ`*&"E֕dtnEsޕ 76y/i 7~~-]Z7A~ #/͏p!<'z7< !j\Cf/X 74C]/7<5'o>7݀z%qrژYm4LY4jZI4uM{)$.+,Ds*׼NB >C 㟀Ͷd_]?kYNacZp$ؙdUUOgk^tDž a๵A {&;;^Z9 =`M) ZKTQMqZ؞נ^Pehٝ] @#`md͇`#0 Nn}ByfZ c_}_ϛ`u]Rۙo eD &ہnDV1@e|t/T鳆`緝Oo6/~ ?)wӻ8{iI07_؛|O &ݞ7LA}?f;?R N6|(-^ͺ rڦ^_ jN?(gA£LK%0j6Cx?K@)0tI~1 ̧6Q`n{ݖ` !.+XάksV:&..z7xEf}S_޿[ꏈup-xYk/ DGl~a1߇yu\׃ \Wx"6BOb=MGWyμQ2}=n>yl[c@o_MP/E~cIL(qUF m:ԗ ssER+/ڶB1sv*M]@!;c OǪ݁qDg`y>: 8ܮ`w!8/07<\uB5S14ts8__{m#~_G qRʭ no8' ٠) WGUNf(H2&8: W\pH=zF{sY<(۲|0)|4C0sj`iNIzr`\*]Q&f͒X?]#>^ oD2i0~|pRoo5G8q^8zÖkT_ׂ ݛ[u@Ck!'()8۳2"~[[j 98~ZVm/2qcvm@/^鼑J =#F]9| $g/bH=yl j+M ߆g$c!1o?K KRދ܏guu KHaO[Zig7 m$R :yN}+5<(;ee@3`"c ةuWUոQʏRV8]FJi~ 8۷80I>k}xx?qܿ30q K{>OuKt:n?a/-O šd7:WC+~T%hgZ YГ{WXXl  d}̡©яgf~o)$|fـX+\;4biL'Ȗ-Rvh HT?i*C޸ wWC E0 qoUםzAq-tGGH`^FUW _c"lkឬ7VTdnTk;+,g|8ys+,}G]/|_/嵱]ZnnzR{/s~!^5e4oǕ C|߯o9w*N7gw,-. "tpvUW$? -Gz3;>wDzDsLw.Z{ʣMWs[puuw^X]˙޺ r./p1y7}L?Ba^ ^ q]o|$EWjeF}CKy!{doULW?pH1+|3i堺{BF7((ܺp7Զ) Jn%>FRWq"͵x?+^ <ޖؿ\4ל;&G'͢;^d@)k°%qǍr Fj}J@NqobbV'mv{g{x?:9(JV9p&C("c8zo@S2 JPz^Ċ ,wM(ZtGcY-^ЕU_IຐP.}]haWZOtwQw'/*aSH⸌k,5zv9;TzoTwF5i7?rZCvA7vw965Jplztnk-Ԕ9qGrPgp`}QOpky-;$祿fWCi7Q& cw$MY^X/dr0zmRh_sq[}KMFDvV-z㺳ӣDb!zZ21}?U5fʍG؀4Z@p~@Z~X سWoYmm [y\ZwDg[*]iS|d*Rn*w? 㮛.09UkZ\ 9֗7P!kS0ɩ/;*?z}JPݻSde yՀ&C_ë `|._=5[3318!ոF7o}r@1I߾W@1R6둑 vUƍ Y!֨FqaEe ebogvJS֗(*O(&lPyQ6흹(aSJy7aPճ,;Fn߾6<*eΕFQJ[g bWTdQ1e݌Y诊ғLֿ,e#(뾸tp2*T?̪6eG,_ߙ FUy-ɍХ{ߊS']әb5Ez ks>T6~+Jq;z.I j:\Fj/=Ӊw|@mPTij7Za'E}3ƾ?ЀQYk4C`4O}b?}-< }YK)}}> ۟_ޠwUB㳦ks'WX >)o9A=Yh;_t">8dz'PdV{+ =M@eӗٞ SRWE lFB G,pU 5?y ʫGg RZ,I<+_ W'ǧxQLӉ(&1UGcJlu6*v?1]({Z3L.t⁠pi/<3u([e՞]5(])pCzyRK2_7 h>U0D_.ۇGoeB~-W=Ӽ49xTN,vRz`aV{+z]zq.}U$n8@ݲ#W덪֚8/Ee9-Ѩ)M͊C[QXy\{T uLo~i:YW LzfTnE=!|R_*4|th*iEh- ]8FW>yUFn4FgXMX^[M^@?yErq €Qh@{Ks@ƒ@?)h NSH )(·,[4׺/O3-&XٽCZ>vP"z/8o⿤gd~c S()85Th+@ղB6芅3|-/n {l {&^%b;f,N} L҈J ~?_Npdt32 lb<d,jsYѧgݼ8R*ʻH,$dGز߽S_}q2E{B~_ӦYȘ0`akǓRcnmiZA'ĺ Al Rd_x{w2_F.4/AZl@Wg9N3 `Cދ9ѕ0 ?z]3gbPMEv^QGGWEZ?@E+ؿLO׾~{;r[t8*Mf˽&=]vv5HT3}ղ,,DW2~AuEkQm`qԤqɓTwTY*eT"j]ޯ8ZyXV jJj::W.Y<,/\zE/lGtmoQޅQsPh[hHރY :.@={\aG_6z FÒ>̂h[ܔ*MIQ*42CΎhaj\}h~WᗊCskMa_(]nųs0[._9N{XA|=]d½*=<, K4;?1dVvn+׾ Jw6N}'@{͵۶;WNϝ'V衽l0V+"#H Zww]uy?bIz`۫jx?8Z(hwyU/xc%xbF4J}Sd-Ҭzն?t}8μsc~|;fe* Ǖ=:wiVKC3ځwf^;W٠(Sq$w+ZY}us^c('N縚>j6Q/AntZQQA(kǕo7jP۲s^8Gꔉ(y&㱷(*xAt/8IheJJ8* f>ѩ>zu8U\4)I~ՙ]eQh/?fQ_EއiGW)LՐAp܎2F5˅ǽZ'Fߞinj)ڄ=&X[^c,(w(*w[LCݱ7Ae[Ynt tL1A77p ~y G%)sޡHyya$"] ,H\9ssrWsTS1Ƽʒ7en@C GYwFO-gxPBX*<*{ٛiRK6ٵQfkkdFC_"a=zZTm&#=odN=z2#]pP踉^K=йɀ3ޱoyA5fYHF@M)«^'FF*PgUyC+=~9"YmT:r %١M9mhDYT@#eI8&Mڼ3jhyCi4i]3~衐@igoxf/ih3CwlE23 =@%H([;Pş'&/{ljUt²,O聵*g$芸qX3X˨y x>2LQ&`ª 6pc٫ ѲjV9mƋYeNUeLpIM7:~Gz#0I}@&Jly $sՀEN0oyfxj߀GB&X|y"2v1h:gpj;7glkin/Zl>_@ъق_hjnt/>Z=yWrOqo웿a[u'Pѷw5q%^C?uhsU>2cO/&!yID"&bYTXx}@ww){ $ɠ,we ٴQ2j>rlT8e }_*ܧRLi{~e4 lG7X$%P~l;zZD]| lz7 e</|,^7, X6Rzwѣ&Ď!z+)T@8z7ǟI7[DFT3~}h3>ISpC=;t.٠>NɠoPWлG#:1yР_;~+~m4.+3/Y&ϊ2'&REv_0Y^=LJuw иPuqqk.u>ؾ^:)\̨-JUK8_<I]66mv: +4^(B6 {&?$4րA pp, TOWV`] :~Qx!:%}gr L.+ f魵q`-4!]c'_=|K*牎%M3-sEM^S(5-GE7Ρ++x`eEZmnTN BQf׮QO˃4(#k?DZffeÏ]W_n|.(|՞r]Bl?,]vE]j(Fpa:{#c\<(*Z.|܌*;_V@_FU. Ѓ Matg/cNJa6r7kAEZ7wGeʏ8yvˢ_dc֨ztEF֑t3Tp`/*Ϻ5_Ǩ^}ȳ s;YZ~6[l4G_y$֠w#LJO?Ovӥ["ʟnIEFcmv6ԥZ.sM%]4[/>ay MD4 ƠР}Jh"E(4C~hf89nr6KtO%;wJtonfZ/e灺^o`zǝx3R]J~ p{|n}+ENy':U X.gu. ɜYRad_ i AͰp?htIԲ'@GS|aNn>6f惙YvTG1\,M#汮8юM{9#ǁ+1Wѽ-TuQ#&m+iقhˈwoʗuK zǓjP(5(W-G;{P,{UrgP:r}2y"kib㙗 **߁K{ ?1tuj(Փ/P:u?{Q|GltF?j>FqsT5~[~/!.D\'QQᖔW(KV,N1uNĠBuU٪ qG.gC\Pꜱ9nx1yΟ[r3Tj8 rҠ;jƷ]K%PSN}\ƭ9[߸ވGqZOKSfWaM@Wn73{+hUU* dETֻЌuSW4zB ҟwN4A3}.G?2 gU>Zeo0Q~TVa`7P'Ȫa!7}gIVY[ 6=7@dK -xP?Ln<8T o7od7/σ֋MWT' 5w4AϪ5Tμ Lb&h/Bit6o5'>XǣZ{[ݙ8%/Υ_iW@K?.H𝣙0x_qۓqG?1NL3wR5WEn36 ]~9Ā2S?+G2mVX*By?Br%֬YrWk\PFȯ'X;5D[ aqYtzsu U,ݶ^dNi.%^Cw}\Bʛ<(4V?*iI]%l.*>.R'⦷޼CO >{EBQEۅ!TzHDzgzctwz^Cܝro{;̹?GU,Z~eP)xHsA-7MFÚYPD=WAB;̞n[G Ik}h`37_%W,?]h ~̣1BB ?d7 vӢqm,\7s}*1pkA1FÖ2g]@S:x*#P6Ϟ?]2 QauՀ2x!Dp {8< !f:Cp)iӓ2mA6Ypn4<\^4oE;NAEr"}/FD6ImM7oPrL_F3{Vi-`4]Ο~VzYᄁpcq$̀!^KB,ze F1{_}ֈ=oE^Wx]u/[CP͙wO94l޷ݹ?e]/63 v >f:棸5< Hņݥ3ߘ}?$Q`Kaʘ-hF7uEw<ʟ +h,Q˻_G42;=櫉EKQUG*6GAUdHT6MF/| ߟJ{ u)'ǡ+zULb7Qf~M5ז--˞U5j '\:}J x4}~ڲݓae;/łЫ w@4f(*t }77қRݠB3#땯ql՜⸠:;{\d<iF`܇SFo~M`8ըX_hMXG'k%Xq9? vKdTGW/E &7[P4;/{XP| 3(Z3|/8EޗRofNbrGC2ѕUmf ~>!.H{ ťXEE/23@qgOsf~CqL)lץ)5-r.+S@Jb݉:xfpe>QREgu=P#Rö tYsǨbvGt'5Fhy-/ea 3a+&fmI!_;* >=y~z%fͣBTC+uLnR5Xn^Ė]B-gxQە5ϝPNv1cY]4ze'Їkiޢ^U{(V4%ѷVh<§Lh-BmVl*hᑵ431hp1h+a4}-o[.Z9j2T#szu{zN `ZfL{x"h70 +=z>oΝO:o7 s3x9_(5 1g/YYAOZU=:ܸy,= Y-. ZZAG`J|fss&;xSe-0or #ꨅR-ьG5 pm^+jٙ= n.O>EM ޮi$o2SJF1oWtq_ɴCl/kJ/}niW6?vx0gp~x qacou|}}-`xT^t<۳ Hf_cMeu|rzs~n|BnնAPHL(8B`mwtf΄V'T(j"xU@=Y6; KG+5g]>ybOmĖl#vnj"'eWz::U3~4AMoV oaPӞ 5T?eہ}o8>Q`@*{<ߦj'V'hu o\{;ʠ\J4Xa?a~ {ոDr4l5&9^fj@h]7p{g*|tڍ&hQ)C Py+3~f5]>453L#`()m%,uuAn/u\ayj?>*`,@rB d o_#xd%̭@I'/NV T䟎vf㞍Z@wӛ:>`ͪ-Md mhX\ μ,m%UMjZ(7Kx{tX-0\=Qv+Uນрِ, կۉ˰_gYB'%1:lw_\ı##a18$h-^$cC)(_ -=]ޛB6n?Bވ-%.5x?Ѩ)y籆ǚ8Fk?k?k?ރΟ:?:?:?C^WUYYUXX5XXq]\WUuUq]\WUuUq]\WUU&*/ߏxLߡA |QcXyow[rͿ |;S,v{M]~$# qӞ],? {ߋy l`Uy vҩ_ 7L#gn,[s|vI9*f<⸂Mv| oezɻ21#^߈i~a)q+t<} {<͖\j8oVt +W4U)qg}^F ׫,Xtaq0|N\Q5)_ex?SNex_/8w^:gxaW|:ugu:Kz}?dxoԞb ~q4 4?iH|v_6l$>_kimD|e4|!mA?հ-ӆ]ߋA†њǷ5l%6z_oа~3'S{_ ==. [‘CE ;ﯣWaÕr}F&] ?'7SYң~vsnrmQNNֲyeI|c.=chEnua視״`M]7AbHdoDQP:MA!B-(ˣXAA!yBjBƛB ޯSdQP(PP(Pc5O Z:z<Z t 6 p ! *6(()(SP8SP8RP8WPP*RP]]k;85#m|Cfyc~G=A.N??84o ?A~{E\~\q[̿ݩJAFtD|5RI߿)ITv ;{ e&,;a+LXq,ާCT\4jɔn'HȡFG_ڝ:]x߄h׋|ŋ.mw#||;B1I? mi- x,YPyy-hD#VW[)1w7X bC4Q{8 44rSJb, 7!_@Yv;WdzhA^B^H (>X{DmjmYkQWz4"n6_kMewYV;iāIkVLE˾es-ܟD ,v:vA$ҬeVtpӟ1.MO)^uX;.ӚZϗ8p]pv nGj{7YOdf;}3rVuJ[/ȁ,o4b p;&}4HlN R7R?+\@ @)#4MFؤ)A~+P84o|-}YK'*.bLOzggNAcʏzufU%Ab-,O`eo'ޝEUMvc*2&\Pi+?l2!dWf^݉11aǹ< z1bIҏ}-?u|fwǘi2!TN$}8!uFޥ녺 &HJ@]U%Ƈr{PwLcc~߲hOKfu0v %0qǍ&h!I'Հ"te Pqv@\ $dڽBҗN]c,Q/ BX{e ?w<.oK N'5.N7M;iu[XӮ_nUTrl+AHe7Y ՚un YXg#}H=qٛw [AMdB?){.oU8<@Zz M[⚾\iFDD?r 0~I+ .nˏtlJ#dm\&B՞txL9bk(/6]1ɂgUCߒx"ĝ+/ƊvIbGgEF*ORO]|O1xsJn0|w<@i$Wb\%0(U&]!ùgՖ>]6:~{`lw`%&s#xA'ro}>u|H/P@+Ȋ֣ u=1ѴG8Y NÊ_Ì"_><LvQ!;M _r8UAe:H`[t߲v Bdor-?a?{=!GH/#o$pq{<2s$ 37 گ04XH '枡]?=Cc'4W2TV hp\&1ƥ}__`%!\z9!1<_HgPU.@c3#nmU6Ыlf8 ueJ$/cƔ馡!煇jW x6wt2y1tr7l`] i \_)Dq:b+)@ ?SSlK6V~U>|v]Ǯ䵍[s|w-)Xbx2J_sճ?3#t(N{ؤj0 neqZ٘) ?b] dWS*cq AQ 1PQ2 [_:un@sXOؽ\+F3ObFZ0v`P!0 -5E]v?] {w}]-`k=E[dz\,/{J⣏;!v$V<|.'oy:ݫHн>{ lJⒻW|)#-[mXo~跬П[KG">oY7QkCSb19N\w"!@8qܻRҐ=)K^As"-'O)kaEd^1;j\1ʚ}3vDߓGS\}DV~_ŖcG#9It(O@}sN;$xZ=A_B0.Khry@Q-ìъ{BVV t;u+{)j Y]V6i ˭?b][+~z_{P%J Bwu1汕 ]k"_jy aAoJv(F L$ټMg@e>r]P7\ƵG:(XRٲĜݾ_YI_ {6r^/ٖO ơy{?8&27˷T( RQR?@JAqLvP-VM\~o+@s#@hn\AaĠ6ms*p>~cFΗ89\>9߱ۉ|t@6{ PU?0*B_z<}gT@Kˆ%$~f`ȡA-{-~H TnF!;:?4V-OiޢB|Lg Dr{rm~=.'^Nf}(,*Ye?OZS%Ig@&%zLi.TE?wqZzG+:ILa2_q{N0l%\] -$0q߲6̰zu>Ix -魶錣ʖnˉ$xzLvD` ҐE?atp]vkM%/qouڨc4|sE]]U<=v~ Mm(\2YfwX[|D9IUئ(A5Nm5cI)t Nt>f;ʔa5y<Īj w:ۗno9d#^7Woa%#wp^{ME{R!Eԣ⸵a,Td[{ɯ&yn qQܦ8XmI澁/d}>?&ׁpĨ@u j6}<ƫ/Ŧ͑3&◨o*@ygW*/2fEE[>QO rv#sVWUzr󔡳^sz%Yw4,N$5x__dB]g/MD@0#gU lg>  +q1vRi{^lkwG@OKPJ#$7f:@*ӓ 0t iƒnMGpЗ7-p dԷ[Iշ ?v-`H[ _rO zٻQ?<$$Kۣ}0|&8}A0Եz"Ʃ_~ {ښ?' %!]/Tn›<!dH<8[:^~ ocmp{q7Yϋ߲>|^qڛ g,5#$np 8G xc-I?yý7LH S VO'g9ԕ!FOftLr/ д .;S.4YV/ca.hm#۹Ku֗lQ{q@߻,yWKO^,'Uݲ> l7gvrI:SXn4*p.+>=ZǧR| LqU5 m~s:Db@f݋> FײzGYB_DNM.P1:( )v]A$je/h}frV* z}3{7$h"]b0^| V}[cL{o`x!b/:k#0q,:a dn_Rx+oY\9z>\{ >G6ķRgbN0zm1.l-?Nq"Yo~UVBTgmGSyqv+<,FSW0hghc2'ZBGs`y*_^`3kt gHp,o<e+Ԯ< +Cv;U"y?pN|hr2?yѫQgA̪:2~ 2Ԫ E̷^ܥW2 For k6s8ü6pP[;NȺ&O{2E}ifEzu_^uHRRFca,[E֩ɣ*wEӉOM?~ֹHxZqYjoP%o1ִ\TS0!XKI`5zD ؕ-'K.`2I;\UwxkP-$ <u.tWXߧU=BfaApGs3: bayc Q_-Hyf/޼:Ӏr#KsCr;A#roDlpG}(:ן'A40a xK FEd*y2 fV:/+ ù`;u̍uW4c9A`mЭT.lR 7Ţyyu=Y28<g:)Gy1^pqI?=~%̋p<H?F#< !y9: z:p15pqذ^4}HcSײN0lTgZu4wkQ0"0YIK'XֲVek_NHsҟ6ʼʛ8x}Hnylu@iDâXT|8aaǴ䣱?'?x`Ϗ6|Ze /8.$9ux?{X#y="e֓5 zO 멸r!#ҁ/jE0EUhn0>\og8s1 Jh5<%$Xɚ`Sy<N;ߒ)gV FY^^lvuUz15lZ X` 翕 D5)2)= Fl#e|(Wu ӭLkO[1ES:ʟ(7L] rrwAK5Q(z@=#(Ahɑ;j芺N'uJ< w}[sF)̊ 9U[2/`5ϭă5[#T=j.8юԴ^77ExaŢ]]UYqߓ~ +H[##r%ӥutUsH >]KHic02:ǰ¸u:8vEH0/{,2Z.󌎓;uI~FU@l3w|ahӏWA^ f16 {kk-HNn,]wkWrWilF^<s[(4"#ᠲ,P6#TCЪVqO гT) `{xp2`u/lKϻzud>bE+~f2={p\ϑ8G`ҥCd}b Ȕ!> \Kum.]4z}Qk7<ĘKbdο#쏖u8= sg>ܶoȺ1i?hLu;q8 7di'{}Zy/mmSql=6 JDySE dc"dfghTסwa'JhQy t='*RzlרQ}@l<^Տg - ^:{Vg!ٿO6+9>]g +(|BEU;1jVJ'%7!grě n;z7|}5֧z!crooPI\mߒ7cEcɜ3[Q?z?PP \#T\=ӼO}tm)/ ؤ0NdMGKaIXH׉ӟ=96G?Z4!4q'GǕk?SSO"3 `>"̿a_;gDރEorV|$p]A(F֛8"pyV̎IޓVv{*VlGu~ W^ G<,ǟ} 兏dFUG5+9軲EjeY\>(2^eRf˳]+:]G`1 + ,͢6bxa`g{Ux!px \MOn"9]"Q1!*1!O~6 :y5tVN$w /c]5G d*ƷQ " 0T2|g={.fF=s .tl2-q΀Zh 0-pBmX|Ov(mۃH^Xf]͏D%#?|ol5!9H诡Mg`IDI:x qqR~oc^|:Ҿ8nI}4y0^՗ #d8pLj.&Xq| 4L͹5d7^F9 ${l CijuktBu1:jWEh7Q{9|_-\7ʖ3'=~5k.LY7sH.Rf_8y;5^!&úal֝RX3g %/-J 2(@tkw@-A2m p/ײk8wڽ383KԂ`5,jeIh\:{tX?2<tq~8 ж<`qS5*, |߲ih0ޟs.<*I4F%ڱ8V=. Au(?G:yҎ\͢o&kW"%<5pނ00_σ_W~#тYS'FP}o[Piq?wygp^ۚq'q8!z35_QTb" CBjо8>;oH\~UVƺm~(- C4c:ZZ&,mY4縍!~)LX z۬E&+y`Ck_^viTl̊wسE[ZfV2*4 J4]9rGPovi&qYd ybj:n@"Z}g0̘u-W@.} TvsDj91j:/NsƦZvN{ 2Tvy60Z=/9ܟs& 0eU4\ Ln,_쐋 8ϫoaCiUEcO?}:^g0?/gg#<yx*՟咭4n$pw0.q(N]~%PQeoGs , 3/ WJ_OG'HhpmQb9?`%HN -] BS_7zPCy' Io O<'.xqR9q8=(վ)q5#d U.@ƥ(VtnVf ~jʣ* Vr rϛlbaO0r9MC {,7{YÓmHWؙZI5惫L{O5O{Xi6x= X`*?&>@Œ:i 'Ko8 uGb?_8n8^ú>q3$ sc?c #&\ǃWq/>9u"=YQeO=!;MќwИ(H$gԙt {>A+(VA`>㥧93eƛ^ךTW+mɜ)/n/кc/sݔk7n)@tA] V[U]"w@ Z_αdRׇ[ Al`#wF:ꮴAj@9hP4θT\aP>X@.0XsW06 ;7/ø6;f d^c&/6j%^?}^q'sM G$naK?u=KW _uNpGH?q".8qO0ou 8?: X m:S\ L4~o@;Wտ<5"B#tR=aV&C^kz~8K*?. E灏{Tu}%N^Q, 04l:yuX<Fe#`aش)pf'yQ}w =fn&( ^K{@ec y+{>H*3rǤoﮱYb >|Z,(;* lшjΊ@М7 =f_o͌c`()D@DD{8M9Hs ԽjL*v^.#,^U5^VSMzAp;ƆTۋIi߬[o?```_|xni܇|~_\/1z=KN1/@mйUuO. בbuY|<^^o|60~p?m&d44_0F?E(zSNOH}jF?L܍]>'wczii>OjΛb!@vR]@'tX\ 5vkÁP;`-y8/{N8L"CD,jLQ֑}uγ<\ o |Tl]3 pE D |팺˖?Ak)c~Xa誼^ؘq !n~'Aju]0"9m! e;v}ÌY`G]9}-{XCKT֕x}_3+`4~ by:ߑ~ .:+pC-\uL0q4)YG~z"Bd9I>)q3[R4x4Y3nLY׃̹#u|k/@ڠ:k} uMNd3u>?dj7 d*tkֺ`?yxvZB-C 8lW+Nb+o|B2zR 3Y?1 o#A:ndmV{} S-7Ofp; ϝCi2_a?A['p}OKbn e9`ڶ'f<) "m]?m-Uu.t43mz ^6lWr4&q%x!orTpP1uJI>qw@1揨8o##_xY8R?൱?u8z@Xr>KٴH`#ѩeȢ K5 | Zt[frB!M$~X[|I!u)dgl4?A* qM[ WӚ6 24O s뻬σ|eV@׊ö$ncE8-^qQGAȾTS~^e=ރpiPN5f?V\ /h8:#D8_m*kip wtfjP Z3[>5&`(HC‚??lg&j,}V?^T0_gI?K7xu)~pp_7٧@u 3< `a`c?K5y_Kqq+.Օ eSےԙ':&ʹ1ےu$^ ٳJ|zDΓx \xr|ШzV SMyӓdGkHl͚[qg`;hҀ3ph=`8\_eo3<;@>H>Ycz@@0ǖQn OAZɢ;sW}R}#,S*oN5JQSw{C@+6/sg(ZtaIe,6XHT:F6eF^ jz޲P!\]nm:Yp?8/eD9Gwkd=ϙk`˺?3u 3躐PntkFU7v^)0Kq/w&uQtu 7PtCQֵzЅoJiZSImj?}&AEPPZy:livNI]uj}%8<4P gwY.'lqк_}9PX%~5V'Kzm'dEjSEڱpx ^+\W}o=}~pzyxv ʉR</I|/Ei栻QA) Q$$DEJ0P.)A$;>}\/z9 \s^{s1~l5n%W^BGiPY=J()Z% \H"݆1Grs(b|gq%Ӈ(B V$pf W薹KR)cǏ^m|yY |k~*_LRDǮ%T%{ŽTQ!o] zu0:TBa[+ִ# jF5TA W|h>l0HW/OScnH֕g|gf`m zݟ)*oE_kS'?F5{;>Ǣ )]-î{3j7dk+V`:BPJㅟL7,Sץ[H }1޹K 2^.#u^Ə۩;Chi4C=kwNrGchq]5-:&,9l+TL5zkFCSϴ5k)ۜ5`w_k_1޻+px3^CË#H&]Ie% >W2`iN?2g`fN 8\7i $R{I﭅._CFqx׶(#zpe'5itomoh&|qq ;iKZGҶk$Xz=Cdhl!J Z:DzEFF:_c8ծ?d\jg-e /V,&ُq:doW7i䀅[ome'yc8,ו zmSq1%4nޱc)*e<=#Zq<1|qmZ@re-Hw wFyK~Dp/(94a@ *KƁָ7hꢯ>k ޶ Kua*̾1'MB[ >?VןO٤FquyP>0Y7jIzWnذhoau"7>96ohp|J;t~ŵCaLa$XwS(r:s(G>ʼn+%Ԧ䒂 (sLTdCWl-ZуgQс탨Xya>SL=GsW&*Ie^lR"52< *㰚gˋ݁Td>~Dll3LQ…~m塆%)t= f*:yP]B6 tD}lsXr-rFo'G?Q6c4슷 *:\ eE>?a&rʜv!O}[T&^{\:U\ :~4p9`yx?=k9*fj/~tTV|J x+Z2 DF٠fݞ}Ps`SҎ[^u/p~+F}[e>`FFk]:αlv4jM[ M58&VT3MrݭL.9zyk$=jt-i#<_]9+rz &@$Z$н϶WVqKL@WE6zJ<V=9D[ul0O$,z7vDι}1S xŦ+ُFK'|k8 BGhYm'`}NH<T GIu%~}#4h.MoFAFK@lDN@6wż[3=I#`ZN րb!OX660300}6~dao_{bm4G`_S IvGb(Nm/΃O(3~TK;X{GqhP7JvS3_D*)[?^7V7)Hޗ<ن(w9m ߍ^PBe͔Q|g \)EvugNTI5J۔? dvZٵV2kuiT;U0qOxNʔ[{F7krѷ[β63y jLEV-Xkw?Z&9b̀ϼOs@٫_q}^7> A>co.i45i*W50mEsU_ y7R[^W\VbwNmz}r@1r}z 0TjOmV&C/ӯE(K8/r C;;X1`E*T ku¢MhDlchٷRZ^\T: v(w[A(_1g՞3LwA(G}h'bnv&|ɐK3`(Vug :\+AaXHXh_R΄=g~[%!W}'فF[H8ޟk{UPX$~Ч4e_z^WNs$יi{R:n[}؄PIQL{(qLU͸E kЫCT|E<Ü'Ћۧo]@E268JJU6mAt լY㊪x5%R2P#gԠ+9/Rݏ,UQﹹQmS.Ӯlg}h-! o+>&oO[A3Ќ1oh鰂@=“lb5OhA upWxsUGw0f p^˫ xN}uX_-BGe!%dD\:z%:Y6aѭ94F woIjtPO{8}@g@U#!>K0USp)L#de}s0([qqO!R䪳 FM 㡗ߢ2$Q},JEl~;bB<' p7I)qϑj#"\WV*(?2ў*T7|YևًʲOmF/eއVCocb ١em};%;QQ}ېZR^WzO׎[Q@(׀j-b *mu];ZTAϽPFN)ʖ̛ Quu~T.~n̦zcnˡiGŔѠhܙ1/hv/4g0|4)dp^ M ,@Si$ Y6JYOE{ٕg@“@!Ӫ]zi'mblJD`96*P6U^4Fnr4ן8{uxgZ^kd\5)ϔu=0;L>&I| >bi`Jc1 묎|VKX^v&' -{QHэgnql<*I?;w9wv[7L1hJgz EκbGS\>@͂3\E:J'ыlг=5;%Q~J{q(*lo&JsG CY2\W#q#ig-e'[v@y$7R](_dcN5dn9{=]j/*5Ÿe[ժ4]}i5zΰU]TJ*ʲoDU3l@UswD'ҵn/=%oaslCb:9cP=3xZBlq6w9XϢ1իѤ`(1/ˋF}:j 蝆3w-':L&x̃E@˜kTO -|@uےG(:ˏv`)q\~#pPsLm˙-{x^^:RnxwDk)jOI6EaX7sYl?<b5Ը)Y +؞=}/wsq}r<pqXFh³Tfм xD\t=}@ߛi8G/$ӓGu~n{㲇*.E/[$)mPڸ6f ;sZ ֶ]^D v2D/o}* Q(7$Y* 'DԹ;CQ3HUA_KIy"}_n{wKD )gzwz %|LPq&-wN(zPR?Yؽ91zq-]ˏ \(K}57;%=u I6 5DIkF!k" o;5uP/Mmsrм6(dBl3Sr,P 5M%U(U3Yuks(> sw*1Q`rپLU},.0=V]N6R z;/u؉??dm̑$׽Pxoy )z2hĹkR(40ou-5P7·=QٍC}7&7 B.BbʳoJ֡鰻 "P4HX,zސ!H3Q3Q.49sk5P'Nk赊GŀM;՚14T8ecyJ9 l׫8^1u;l;UeMf8J|7? ȌϏ6DdÍfR+;K{*Ϧ+w}7Xg+wӗ;m^Vi~ڔ{Q76C- .GzPυO-P>u%+5)?ۈމٲ:|B苯B1 hjK4ZE-4A94_DlPT(]55Տ'@2;x f <6XmV7N~vم ۲`o֐-ʹYMg2J. XC4օ=_W1 k#B6%^BNA$Y'm \ޠA:ԃ4' O@.21jQnX тA'Xtԏxn"oauIbUbcAvn0=ܡ\<6.U`gM{y-ykZkq?I%{,Ӯbq~{pbMpqz i%Q\&{X.hi#)ǡ2fyUOB&J"|Mz^>.Ao~9Ӊ^Dg1B}g+LCyXh(z*Z2Ь༄>*8{=e\=6:-Kގ>"@|LZSK:KTD7u;zЅ<4.qeZ/Q/žm޿л+@qNO+lPnP7[ѡF5~?MWR|y7G-nV/77RCQcPOkϗu*o?VB}.j]%p eʂͭ^iAhlMrwey}4>g erON0kmBD7ib% g(Cq]`z[/`;>z']%<pvm.gTwpװsFLސBXgV&:4w.lk0F*AVSdXE bT |C(=zX;(g:'tOͼà87 ݚHZ;h΂q=`r/5$,u}ۓO95V0xkp K_ w^xkSvkWz꟤=ӹv^ʏUheS4A״h OiQPC'xF5ͳdWw\k*ǧ2Uk>j4G%+uz0G[gcD.>5UM,D\7=9w6D~@O--QovR'yc.ͿEo*Lv g|?H|ci4Fyx_ 6/ :&hnh࡚k:1؀&.F ɳ|~M)woNDS&"e}qA ߳7pE[]]#PkabCԳj(ҧ%xLf+KN |,5t؀kckLebHW8n+E a:ͶSWAC#}= b3ԬTQ>pldXrZ}E`@GP 往TyJP|$rh~}V}ǖAPke?ify\}G["GJLryr.4E`}XQ6"Xq&>kG`w]`ql)+X^b+8tmy;:/̟9ž3{VI/F.'L^*AϽ}u jmU9pgN8 b,{ڀ GaIٲVmik.  PFFs=/zKĕ9gڝtRWM qؐ+s؉gtUAmYPU ޚ@+O@.hݷ`{ H?5tw̗LW({/0 a<sֹo8YC`~JgWTڷ`UXq~>ײKM~~&;1$R)8twoUKíַ^x3roO#|7Cq}z׃G $p6{y8_UL'FWHq#bG1_F#,Z/r @VZ ~F %:##!B{g>Eh=/3S+ Nj2u}1QD]uMHl`4!) !TIv$6O{]w94Gz@sZXkoƣfvT{8k7Z]K.e9 uQC^o=Nk2V LxmZka'0wKKt`CuTY?oO6A5Oq&|HW"z()!v;;8+ 0ʺtWa~̂N \a)+KR;1Ij8ø"I?ac·Eh_EYg`7'Z\guBQp2lӣ ۇeMbgcaPUxeХ_`I!#y<\j%_ʺX+qgE o+`;K\${O$;lml7x{&Ҫbx~0O]< %?|啼ʇD _!x}q]Usg_}Oԯ!Yf 9w„h^ܼ=/29Üv0v{ɜhśhi¦sУ ޜ*,x.R'G~͟r/c>i>k//Jo#tt5֮|CC#T @EDFwD{&=ߘr홤y7voC߂ꍍ}lb[ 4=hK@IsP0fÞ똌ԙ)C՗ A,Ps{%=0Խk$Pf/Ԃ]ͩQNRip>Tio,ۈqb||c0?Hbg%<ykΝaH&ۛgWXb`aQ'/ؾV__~}C c~y=V;)6_>ӛF<H}voqfhk4*~ S|b3a-UIPd^l]ρKlА] QIy0#2u4E"Wwٳ`l  m$sRom1O[,_ǧjѠcBoDsVC DzA_gnc$I$51 p?܎ϋqNv> N+qZg0>x&\kv]SDc\]i/m E_xꠑM-yk/0[WOM'#4Bu\';N'xgl9G̀/K߁,y߭ *yШWU`p:b=}}f;6A_kl닒g@FLp&}kfN#)Qt $?%%Qo7yh[/KR#f'EP5;F8=lH rZi'Aљe~5i&LZ?f4tƃ#? $P[z l{ ,mȸ+5^Qrۉ~L`-=k*(~5wǺhk&Eo~+]aqz+ a=_#4|9> 0c`{gL|ȕ i&pҞ#֩pU uT=׾اs&Qp 7^+\xgk.』tuhD9~P1LL&AthILWo~0@{-z_U 7}a¿Mq)=&0p%l16>^#]24xk<Oyl-))֖ ԔtKAd]ObpW:ͼH^60H s[MA+5:Ϥkw*g~6$ ky0فveW~@q,Qg8]6NYZMب}rX} N'U26Y`X yn ==`y:.?H ~wXN0~p?l묬O 'x?u]cR'Xn00(b#^W"·^~lM_X/~|C:/W::؏=b5<Ӏ 2Ġԅ]#ģ6hOq4EvH7e0ZH oqB@,%P]l.:Ԣ›?@h5 lӂ=#&g͑/E+V6~/^soRg Bd?~Ciskc %t\d9Ku:GA*Yb!9(^OjW/)ۂ} 6jZΌrM09z4YIJC`.Q|0?7&E/DFo15B/ӪvsS }?@QZgq9[YǕc00>1n6aJ\mLj%X`J;a}cv/_u=+؏M;>/'`uM-Q%?7(͌|)/_D >;{pv{X?cTo5#p#S:ú:pT^})׭LnPΌod_]Do"z35_C̵F:Pk =ޚ/]!JAS.X?Li\#zE @~X1COS'3X@=)ד% P7iq9:*L)w .q`RJ[7 w OR+E@J/40`VYm'R/n F20ۜ.> vd>,K;?sӜ^(˜/VHzq?x&&BDԭ:H115'۬Aз_? cf^M=M}}e ):zzwGnRYLbkܦ O]` *5&0}LLM{A`,q,) m:Wk׿\ȿiF./!н.[uma龶J~?LL!?I4_g|Ą{ ϏJaOv&cBӒX.Dj~1;DOu݆MT"`aq=GYa|ks|*o|ٸDx8+XfSV6f>i{ʇwڇs |F4P l`I=|1C[ z@_S/33b sT}L09񬰚7Y0c/o@[xZ`(ޟ’O_xvD;OGX/Gx~KܾRa_/'0YYke]VDep*{ b^/vdyF ʶo 28ѨYri*QO(0[4sRNBs ;U~tzqN+Ptr&ί}%Vg,ʎsٿce]/p84ErOaZV ypu}SX*bnMw04XoeA"i%C71RG׊鈀n^ ( 5褆JPǺu_"h9thtO`pla<``1~p:T߃48\nP6Ӷ4"WȆD,=Z!4hɥnhF.^w4?o#Z+~A-ʽ,-+L7z:W-9ef7s~uΔ؜\:7ק{_FmZ"eVr78PU_&A-`b~1؆u ro鐃`e郈c0XK{}`Q{4&t#H󣀧k xǸ8ZY_Ko~6+??Oؾ#wIv0~\m^n[Yll5\T7&'4"O8]*C h2p6s'".^#.%syCDGKw7ٜFxƲߧ|oSVD=!ē1ܒ @c"+E 0ڱ)|`o28Ę~wrhZƉ!<;mCoc]B,CGQŲ|rD3*+!9/;&9tpl\Y^v^"^4^].$eS: 1>H>~iU RA>jPo uPp.*TE@-b+m6h:4M# [Y{ɨ LO#/2"3`,物sM#׃ɿfP ,b4:a='x.Izm$>؎׿h}r~Ү[۱ sx1O_A)|~8laq+yux #פ8ޠ}{;Qg~p=](@?{^قz/^$փp^/h?M\[]H N:E[(+L֮k[eQ&S' v5>/mc?tg~Y'C{66\ Jug3Yb }{ha?/;<Tsz7_ս!S@QH=hgݛ3mLU;b~9<z%^[0Kby ,^Io`WG[xl_,qVnJ'r}qk}D i`ZYAsӞc@+ؑ RN^zƗoѾ "AXvz>Zo_Fc;qF/Uq';\E 5IqU+u0uIz#'[2>+*Vî[?+Zx<]YIq^1_Cn *b^{R;J .E⛖ß*ЅLI[@O}++i;xwa 5zt7Z0e9ҫd}AsA`$" Aĕ:T7QD}B;61I}Gzo¸<ޱV濮 ZIz #a χ:*?ǻWXa?o`#kPGmaxr$B oc&}_VWyfߊ1TZfZs4S;h Zp Z$!nse]ع'h/P}s/gh͕1I`cRpTޱn`}ݏCX6tQXVvxvhƦZZLHO:oNmPYk.6[3J/VrKyIP3_`uhLOvyg`ϐkHЍڪ{ #tSD~uԹ$0K`k ^?2if'y,R?0_"p9#HJ?).O:^i׭\Z#g%gG]9/믘' $`~f|N1\AvkbGؖ#<x%'%gн <,V,ur#XNy%K$c\Yȟ@i"^oI* $%ڟy빗o yT_ B{/JWƂ`ڇ rG3ϓ ' I_LA; ah)K`H5OHJvsSV|UU]PVBeA!#Š){ tm>i6VbW`lLNy nb=՞tDL)V7xڍ^z>H~?pJJ}D~_ˑ첕y|/++DpbuX~u׃A8 bDm$>^w_c2OhhPGg05M_)mVn3;L/cIōkDw^B_'w%JyGƱ/}fF}o+eqNW`v&$Oϗ ρFYoUٟJ/ 0BL &x|ˮe?zAk3|PtA"rAy 4r42ޥ&[q^[2JAEڇLo9L0Q1Q!NU5X\=O+S. yqӟQ?Ik{0 ݆J|/ VƩ\%uyWg?o%Vbخ[gخq _~dvU RDPKApiԹoW}"@| ܌Is; 8N蘺\qfM<>hb*לЌxh!@\ΧȤ,T6y P~k)ԶC熁˶],H|l mSͫv\,δx2>m̥ЅՆy ^7`}fC^O_ XޞAպ_MdFKb* ;ÊA0P<#5t4jno dxVm`vv 2H2W"Ȯ2̀*~:wWIww9ejOnSA4$x,<~W+G)~4?xapJ}2oo5G؎v^8|7rSYp)O8q wm{xP`;^嵐dc\r66ϋL[k;z܌>@¥bmbT4b4|@ }_288ANњEȔFAז|kAPN>j51>m-wMO0轹c \: FRvцxs`,ٞ7oLf1Ow`כܖ$ rqOxoY0Ec3r}Oy{x?^7Zǀ2+q+ば"ߍ㴫R֍~OwI{bJu"#$Oy $#`_B?x}cGjF7q6byp92 \ X/ՉN{LZ?w|5m,0\ɊH>ƼM9!ss> Ub6}\`5' va.pa{so _)#FAbLsqx~[an4=R7}A cu04?|sd= [ C?3{_v89rT*}hm|IxXG?la 7Xo^?xg~®[[Gqwx?a7itSCj.T՝/㧫\ibg)1PwQr؎ID|BףlA1_3eot\9&ë/ff߻uP;y++wU\ FbzK]`,gѫuwXK@#{x 28 BvQ a?5 ~5Sdw๧mnFA&{zh-,7 ^[Pizڳg巟ӑ_$\q5`<| v~WKya;M/ݩx?I&Vi6?'J [l)ue+^re7ʸwxI+p܎Hy8w q>]nz} qeYw;Ñ |_]a}?'ᗽP[2QeyA$+w'Eѹ͆YPOe~3h>j4ϐuqsr E[$)`^ pI> x ݃`AyuB;v<De@\_xݢצ; jR@#C<(Us`|+{Pxde?ɎCZRu$xm3]6/%Zi瞉ˮkK߀s7IT(>fSXQB'Y'bPdsfv[UpgZ{zP)cet]l\Wl([C}vJ'z"o܉v#ce'tRQ|!i+fi(#N>ނd$XOZ=EeiIkPSpjTQ;iC63FjAqvUG*P zjM;!zc_ԠfnJGWяlvP_[! 4t*avs>  ġCg4+n#}hlIF&۽y -Oy_NbEp&# ><WزͯDnJ#w\ktlN{vQV*8]Ju-o͚s=j%3 t-ռ+N* q> {˞7@EPݸ3̀)"P%++27dm qPU.(.bAfgsgUtk*Նv';޺T l>vg-4^\wNEڃ7I}?BwVFYѓנӧcBLmE퇽S$ߠ*wDQ6Ƕ Kjˈ"ΩCl+,l*ElHgpk1۶TdG~az|ʚ Jb"y={b9KlB!QP3GZGiO[JI>O߫9G q?)=PJzX!sl'z:tX5KTMAwӓĐݨkrѶ;QHE^},_N܋Z/-cةD4E[јiwrN4xd nZ[s ^Ggm< (8@;.aINni&2koWM=sW.;SO炙Vw26{AH+,2 |ϏJ[7SɰP6/Ōd3[zjyf759N7+Ch,i}}6H=RgTsTl_HX_+6lvnd8 g.dHL\IfrwtKC(ݝ*?$sEaMm& Jimz_EzC7\DS-%$~hFIyp?3o#ۺ_Oŭ }TzRx:wTqzBJWc(>Bi\`@ dgBܗo7/a4NteRj tK,k@ K~n ltw+Q)J;}d7ʽ=VW:>J:򄠲qg.݇I=&ggTk''do7STyM#|N^"-Ttxoj\ZIKGN/F5.[8,Ar+j?aou/l|V~QV@?dߠ>[ߧhk20ky>6y[.4(Cim4)jHqA9*40A̍`}8zYp0ho/P\ }&O;Ys ,g.<=Q7CK5f~{߰pJz8\] YMUnO[:oX`Bo믵dS}^& !:W)&;}f3(9ckZi]Y'AK\CM;[~laxV~02e[#'%`٭Q9xlMZYh8NX%wo;C>O5.R@q2ECf[>IoDTs_{{ԗ((\@Jp (K{a~S\zO?}CIuAk*yUL~3=J?_\9arO]&J`Fv)thŸ+uy8F˭FE}b鷷wFZQˮcL<8m~2ռ˗\@MJ5뜷cPͳ1]fWQMG>'P=;;|=F}=k#P!/u*8 QIu@CтKЈS7h)pXMz4@" *O:s󪮟hFJ2-}J.xѧwF%YWS0<-V54=_0U#M/5pުxk^ښ 鱞cWG $g{QDo &EFYeAac%u]"ȫ~R6cVRFQ=KPV>q>}i;:9= ޻ Y:`ԎN0U!!),k&{y`͹dSZJޡ޽+&x$jWEr \Kyt(f'$Nƃ7|EZڟ?̓|rMf=zT}>=#LRY~ Aqe (ٕGGt7SH Jb{~%V*YY08<b;n՜j(ablC)2L5(/XFP fgA9ŦSeW 8j)T;Tu" J:A z3-M&T$!oߪ^U6Lz})*mDKx8<vE5k:߹sC *L-w\Fc Mh5%)4Rzxn*NjC/ecm䔧^/hJ!ff2ZY\j WRE?xҁbW`X=p`|Ƭ =D5 Y\LЫC @= {5Ye.$.ZڴdN~1 yEzP^Zo4O6q@ [4$PNސ`=F6L+uMoCAk)2 }>T%c$j0nq oH];0Sro|kR9w}nܾ7?AKnmP"q~9xyx)7^O"QF?Qre6(}'Oe{[BoM?+{d1T;C6BwqmDSy/%ԁ\;ɢ1QNƴCfb4Is mgTI˝ʁr$TNGO܅J˔f^FUG]t^Wu7[kEqBЇ q$p/AAWQ&G%ߢY {PGQpRtMnD_'Quyk܊iۤϛ=fUI1FhQJrA_f-݅ƭ(ИUO%% b0*&5S{ d6bbI nI-_-?N dp\0xhFJ$S57V6C9pX<ntn`ןu;5Vo { (f)өl6쉑c8A/QP5+AV#wRluГ eˁ'gYVgW<|(%۸_ fX ۳Y n2IAtAV”XǹPMVz>OT.&:_EjT8\ QUx6xj{i&4jox2 =&:7B:}hyQT?G5NF <Ǥ̓Q^zuvN2V ]sBdZg>CTf 6!ZQAE(Yu?HRDmDEgBQГ5ףAo]{֡Ni#7{;Bwq/ l͞(9Tm:cӾ 5f9AblFwM/NKƛ;o\kBueǬPgniHuzJ{\ }U-n?G?n?RٌF*KD8UxW_J4܎&yC3 MoÂ, Os4{U3(vHlQJK}ߎxfǗ$ j+j(=S<ẁdOqe5HK<@PƢ 1ea מN% x W]}} ?F5n{*B@|mżQY9K<͚@Om4SE; gfDn; ludK!_͗s./{[cg@t.dAlOykuYV4QPe #l(֯x.KUsi}{pDyXBcQQŧ(}7C)VQGh~v|GuoDtQ z1lأKcWc,P+0A댽YPs/Amv^|O䕩"W׾Gm}f47NFϱn@#?’u|Шxf[h)c4p?4ZLX}P&A π%mmP]> (g O8].wkǁ%ͦ8pi4W|D M2A}aLA r ;_^j7]8 c~|#7#(d&8WLx4Л:$㸉s&ezX5\ f'梎fSMn6ϊ81>~% y ^tTtnbCQϯ ʷ5>>zr]/SS?zΆr8yA.d8`@)8VLC#fѧG$#PŶ4%TP+A }z>o?=A7#T?Ha#j߭NhᑰYEY͈MxQ{+W7j1i`^Hzכ.DCOuD}eh47\|˲=~D;x{Clh@(](~Q^JQXW(kL&Ŏ e# lr$jU D"J/\=DN)H(-`BP!ԻU$,r5hf_O 7;xVE4a3y$mSl_Gyg=UTS Xj D>Tl5Tѽ\ibKa %flfg%r>@AxȒ'xϤmv5o8YCu2k$}{R}k:EL\acSTeAaU: bxĆ( Vq ❃F(΃CmS%ы^IOb:u$y$H$Ir$%cH$H$H$Hr I (I'V$IR$IR$uIҐ$MIҒ$mIr#I:6t#IMH\bHI'I=OI*IVV= 2*2eI}'4^_nԓ}Hu7{_clW?.U^C_^$[֤Ɛ^6O=af{l݇O/IS0馓=ieMCUa&YrLhd%W0O:Ql;t_z^,y w[D:Q9?bu~wӻtwOo|-!]r7[FOu薓t+HUQqFn%>wwt?Sj~&oLuH]6j0|n5)Ou_=jkbo\}jz}-֒W}6 ֒_Ƨ˷i[GT|[_4U?N=@rR׷m$=2uHϣoDz.7Lz>-IcF-RhXJrBzngO|m%=nnֺ_IB#_Iϳn;D6sF0I~+jYvsn׼n;yGYOm'=ǢAzWvXv~/Ǘ;v~NJ#uߥ^_٥z!ňl2u/#j22aDF&NF&L";'22Sɟ##SXF rKR-LLs5HFIP2jU X _bF?LLߑ+Y,ѭ_Glz_Edd7mw~+W{'齶>~}wWr ҿ#{]VIoR^[I`CN?B+ђѐu_ﺿT_//v#L.um%%6p.?t.;q ?ܼI. u>><ܤI%#L: m_%I$)IjZq>'Nznߗ~ 8iבB 8ő ӵvH4^>~VCoj??tܿ?c>/_G۷8_O?Īs?h~"ܿ+RI@%~֭ _ヌ.I}3:H&dr߰sO0c ;v[Ys/_?v^%g3Wd#4e}N?î$$Q.OA/?/ >n"g_HT؟!פZs}? k2Oe__zY>^w#?劺q~"dsv8Y:_7__ocIG>5:M￝ y9瀿{oWUӵJ L:TLVDVRLQ n3poԇy_~~g\{fk~{ ߫#/;ot~3L;;PY9?; wk+Ktt9s'54{_/{þ®24ƛ|O>9ͿiNߙStdҺӹ7:ḆchR緼z?^h͜ZcasWH7vULs/դܚ UKҿ\Q^dl D_nA6q %ojV y5>r;kzt٦~VG?] ^Y2ԟ',UU^wTVםV_^_tmJч_XS?"v F?;|y^~tYҀ++@\iҠ@D4(%4Ωk1=z,2wWk0Xī؇a&z?Wl˘>CY{*|Y:G'P|wQXj)Isb԰C)MjBx5u:gqqr?9g%r*iYAת{u1ު--*P':}/+k5~?[X`r\_|{PA#Myf5L-\ Ɩ{w'ҹXLZs.ok?(AkN;y9.n+%odsC1]\bLPSAJݳ}?M\;O5_ĵG֑N)͏(Zf.\b*έ߽Yfi-fiӋiWy)?!F (HM3UN7Oi0k4oTg ~H< ړU5jܘMϿ_]V?ן2 I4q@ ?axssn~ :~G߼z4>&:|?!9ZGѤ VZjY??7Oz߻SL1C5?ӼJ뤿}!w- d/7u|#M:!1~<¿\j=v G,Mْڗ}4K:y:LQsjZ[USΝh/1-5?eѶogwW;&'HeE/Ŵj7y4fl1&͗i4?`]~f9i9[9NGf`io1o|oek#bl'Nb"b(b{_UP^vb!b->bdvjzX8PO}8Xf!DNw&zh{E'O͏+GI5hnf?oyߚsq *TLBTKҀ+"P[>KA|4hMiL]KKAzҹZ Ivi_k/`A4]A#i@!XW1>y:gw-#=ۇAuCӀM0&i _`t:1F`3ncs '0A`$i@#0U`4:400 3`##Qi Ф._g(;oBz5Xiz^[Ӥ^m֩i>]v_|W`Ҟh *觠 *`! *`#T0Jh9'OcJΏ9?r~#GΏ9?r~#GΏ9?r~#GΏ9?r~#GΏ9?r~#GΏ9?r~#GΏ9?r~#GΏ9?r~#GΏ9?r~#GΏ9?r~#GΏ9?r~#GΏ9?r~#GΏ9?r~#GΏ9?r~#GΏ9?r~#GΏ9?r~#GΏ9?r~#GΏ9?r~[.b$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$GN FyTŻǮm(Ҳ͑Pyľ-P(dO:>tP.HC?2³4Zu>زWjЖ(v:\3[HЦ]e'Kxh007gLpބ{pmP,6W>=`1j,:~w3ڈBwM^|j1Dǎ]6u݀_Do'n׶=ȆN:ܫ%绍Yhnnm}:um[\YhX#FW&5\xr꣏3ZO3 Y~/&;=+tS+aę]Hra؆nl˅n=_vG=bsz1Pַz\vkP4Xb*PX}$bz8\`\X-tbdXkP}bNhǺQxZтzO}yag< g\G67i׹m(_M~}_o+%r}[B|9mtr,~T¤6D{-x%N?X{GDmu5 ;>O/qdž{qmι/% RW>}\:|sJtF%~--˄+/;J_]=xr_56=x#v|إㅃg2iPRJ)xny[~ˌ֏ذSVԍv)_z~U NCB~a63Y&z^Z24DT=XeX>GڈwU3ē]gcw;3 "!uKq!X.u=kLkpixOۛ=Z\f ?a3k n]aa.[ኲqofﴁ&X屠ףܬxxqXbKpqvԫlmfla%{~ םi;6,rpRlUz^]f=Uؙ-W^@Ip]3`UlܨKvx=zkR>[un\w&f:-|r ~2e ^x1Wέ0}{QfC&uya!{^E No~*=qO/f2ؕbfh ?X~$whnXI͎4 Z}ݍÞ#vK$Uµe^ws 9-X#s=Sn>Lp0f <{90&ПɋWș>|oۦqXI/Ћ=^'dgIba-./2r> ={T=n}RSiIɆ)W~z\$aL3)\Se\E" 3Sv$4="`Ye֢c.LSǰ߭!=u1='%+vH~Eb:U%?bfYM|o9l,1h;X\SGXc '녥$®]I~3xGQw,uyXpp#UjQ=, X/48\tz,VsaôXi|7k"܂u:wVB+2q–W +"zܲuvE/3۲[ԟ w>|Y.`9-8vCffg{-]^O}܂57fS G7<:9?*ܰ36Y au!2y,[/epoხ"סݗ{"&|U!?޹03W/"vK9tmqc?g\=xh3bG.gq# upQ*ɚOYڸש eP LwaEi ާ;6Hls9U2̛?>]nn쩃LkN${NnJDGO#G3fO7]R7_|9Wr|;ɣ0d@zC0Ԋ)"0=gm:G>_Fd EαMV]M#SIVKQDhE9u=3nVU)rzvߦcZÌ=T~g5f}e=Oa}9A\PO`풲<|SڴZe5Yhp{C\.k+zw=!&m #?F LyZOgVÆt٭k'D~tlYWD=<&iuDe+ 1L,V_83׬ n yH z( ْW7ˁK2z74[ЪW4z:7f{?=Qq5I\OIA_z>L:)rFgcŠ\alwuڃ-эs Ԭjt>Qź?=Aar\1W> agzn[[F)Az#@R԰_-u; ?$u8󽮪/N`z!&<0I`:E6L ? S>:+~#~cAAgŜwI-zk=kv۬Bv‘ n\u,vd肽McVxyZ\0tx8nsgk}8ͪymcMӌ{hpEӖ80 D-Xusݧj88Nb`zWIJoq>x.(Fb5& >O׳'᪗qErE{umO-x/VD9>T!ho:h}WaK}e|՚?tJo_FhssRDU/uyFӌmMks/ ]nt. r1O6 re{ya܌ /#zmYHO\|dV?rvJ9V|_Fx|F&la#O2fq=^}m5?}X km`'+rjNv߬U KW$|,. x,vيRX7bM1O>:SCgÆg7f-巶f/?=ܘvaw9+q"dVjff|~\#9[o=AW#; i]#X4E_SbB_-YoHdωǶ2)Qװ'6(+`%ܭ…Ϝg6;L>[ONDbaFÕ?ˎ[y-'#,]YХsb<b[O??rr#otО:A$?L'`t'ݪ0,wfoc]M]ǃZ;'UCR8S{j87).f˂-U/cσ 1VJ˺)}g=oGSͤ7 p?3C3-p[bFUR0v@0W?-gmdm[O p rbNXJ1U'_@هpv}ih6ͱ&TF_-®vUؾ'mf[}>@ccM{S/Es/jXk@x4Bx}[]ⰢUnGt3͢`eLV2GE?:5wӧo14FD:CEԍpϛ a;(*"b68>}C|?4Csη=xEZ_~ W¸vW1qcKl~#zU'#ƕ+Z]wB/$?Z*Hl>Asa4czvؘ//T&'nF]&(}bw=m޳CKwJTtOwUFUKDOwc\QHn7';U9>wgE?淺Q+? KyA%_.{K\wY)j/?ĔɵIoʣ9|yRz^z3m]gȯwKgp<\~GϩXj@X4WkY_a=ޓnE.Cy*=ծ8K8ehoTfԅiqıoɏ_2O2? {3+!C0EyUk="Gs0β;^yٲ?PHQhee˟_dBqeLU"I|s]b[eZO{\o?wߞ}_ 0`Ks~Jß(]q|(Wh%SOeY 0G'B܊[xaug;e俷•+lñ8-iW7-Yf+&E͌Z1P,hq-2A$ܺp?.<~9mXEC|BNv-HA4d|A=nVG?t:3IA >$D|j\uKvI.QI%?9S,r=Ek9L SިsVFeÒpan{5Ro/PkO6{$6 /By:cAY/q8ß􎉢؉զ_kQ]?SQ*-CV9Ό\NRGmȄO=ZWS$&E.X韜%&ŬLx?gE}~̌Ya5i%fs?vOgnwr  BLAk".GשS6=ĢPfPS/2ri.{v)Cj5̝v Y{ <4iMܞ<-Y-kl| '7+n̜5\\̂YPϭK0¾s?uAO]S/kX\=xAn(WӍ8ib̦qj&f_}|ֵA͠k-!dktan͝=OG0Y3E{ w崓5|CbvmkY!bܺs&ˊV=nG\zZ\q;[,52fwǁqqb$3w5:^cU!W D#^)^K$ĺ w'^W$h$'!N"=Qw|.~ʪsL/~@5;~Ř3 I'{"? 3E=PkJO#24Oq%3+1ӫ,\>Lg\j>L@\6%l߻5V)lL?Ίީ ,~XzW`- UE:Y<%juu0&62]lQ~E냯L58lvW*n*"wx:JIg؝)˩}r,í,8mxvK_ O |;2z᮵u.%1 |Z PNQ3F C^ܩDƒ8]36"\{LCDq7GΣL-b-зZmp X4!vpJ31F`_sO{ Sv ~<wV%E[惀Ovx A_z9 Km92g'q wDM,q=gAso(`^gzrǼqCȓ@WLCAzRgx'q$wu0.>*H_#~!{o$7nV9Rĺ&?Hny$ȯH)ϑ>7YF7\)߄L`S~) ?y(Nޟm+&$-]VX(f+_H tk,߷."~ŸUZ:L?êk$?ȏFr'QϞ&:\D;ND~sɿF?vn"D#C@{'K~3sjGȣ!̯0[OCIy铋çduGUM|5{3'u< eє;j~0?T?n/ZZ^% LUy"31U5]5.{"ݝAAm{rx{e`"-FA: ^L{\͢ZK#g M~ "_E0 ? Og_Lb< E\r2o;-ŞЈaK"NLd{F[ָh&{ VYs" y$OH:{FKdܡL~iϘ糤ƁHN)Qr[U=jX$HQsSc Q1"Oh5Aə ڌ-σFfة .҇U˫pb^q@r},;mQrx,y^Xʂ$eXY'Z`KYK1l( 6-ܵ%7}KlqC cw ;M,X {}S`Koh{;< x*W?;KNf] +GV)Nf {"9e> yE0+GXD5o' Q튪3Ѣ3D"jZIEs(}Ӝ˨(Pkq~U=0&a/Gg>r/q:OKr_ 9DG!>#I$Z[¿NKrI;Oqo#9D+_SFz'_@OWʇ3~\t6 7?m;,5>f7(F7Pqo,df'lX DKc5^OYLDT6 `>-T2(F2;W6ߦ9 >#?9_}SpX~_/j]4&gWOTg~]%%YWm=ߴDcYtoibqBXy {-0P TD4~A8ݛXAoCH8"eh.f /d@L*޶oBdw$"#I 8e@SeN*ᑣȻ8!c◣#7G@nInAZrv^ /7sbI%#ʓ#D~z2#gmnі3'z{8éy=߈o!{'!Ajߵy95I<7P&"C<8LJTCϩy)4ɝZ(@[.<aP$dOQ=+]'Ⱦ㨞dPZ+Kq[7TN|H|6eJdoЬ NRdXusYZ<'xGk:pρnpP,` Oe'ZwE%b;?z/W4&lVW(\E-"䖕5ʂ7y ;]ܭ[ lÞyI{69>'Kq[>[7R?/m#v/?' 8%A=n7=²I,x{328-3db,>EthC%!c+!U}=O~QkMvdO}&,j%ROȲ7/`a6I7i>D[`ܧ$JURS&oXgJJGc5, gs 쨵&.YE6.•?0'y۹6;j>;ƂϪy^q_L^cu]Y&)\pMDFop[1?"C6IPQW޷ Q@Tɿ@q##GvQ #75T]QcV W:?R`KpVȏ༕7"G`FqJխޝXVѸʢI}Mvg] ';vnnM;P۟f@ <|sA.* ),Cxg}!6!\āNxD#D<\QĈzDbR#Ba)b#*zlё]W=$G8&Ϭ+Q>k3=egu8Z$oSBO"{*Z8ՎW )/Nͫ<gɑ^򷑽D}RoEXU}kB:6:V]X9!om-?nJU>Tʼ}2a;٧>鍢)Cw'#9NAUנm!{HG#m?HKz(Gr =j|XSz˩n)M%>$; Dxgzgy:=ZThQW-+_B x[VpY[KTtᔎXҪ c 6 1,mIѼaai'/~y~f|uŔ8W6'}`#\7@6fpZ py,7"u|m/$Dt~? ˼J&u^"; (?>GyۢޚCunMyϞQޡ /"Uy矟ÎJQlh Y81,=ecש~nSZۓ )RX'c;{UrutZ汣Ga.~Q'l$O)4X6H/qP;ʻg!P <]n"Y|sCĈ$ObʎrqMa\DRW=\r.mfثǑ9̾FCz! ޴vC$R_yH._~6w||'($OHDZ?jpj?nzTC~6u Sm"ȜU}#f\Xam1w g}uaǺO Sr.(xBXŬemS^(/rV\y:]PNVgwޙ%z..}qAwo~?§c9p\C3msJde 8oPQQp)]yY.8"yPoD:qqUk&.5\f2F"{PYK u]MzvFBZ}䨯:~!4ɯF#;?P]Q^+kʷ! L|7?eOuoG~s/ߢשojk; 6 ?8!S: ]3Φ>YNiTN,XߧO8o{K\ >\X;,[x`.,., Eq5#o}wVuP-Rbtz^<x]uu?c$7k,. ?I^O' sG$(5ex}Wv">C4 Qb]ź(XG>~ oԀR _ռS7~t6h=hLJ$!S"x$/h_ۆP)IuG7!kTg@y4_Y5rQ -%lՁ= A` ZE+M;,ncs,{,Qy3V͵"_ejS}'֋~OF~mt}UGLĎ*Z,2-xz0gʼn}B%q a?ۮ籈ܑUy_YwipUoN܃ȶpیLGt˾ÜSJ9ìpFA#EP_w| ~XN؎0.}#&Ri֡?P_埙ܭ38>Cdi¿vvU Q뼅B'Iv7MnozT wHENB٨}Ozԟނs1Vmy"? %=gj%?`>=PYunoa?jb9sa랉uF߰ۀYlut>s;xhy$,mxm_mpwD7Ly,3+b8:̳tjԸ#*{f7Ee^._\DM J}J#nߠqqF\}#LWy))?BL_Ԏ_i\y>BEqMң(ՕR(5ߚ|kz1Gd$dP)Q~O{Mft٫ݙsMTRcXо ֻ/l GtK+<@A\,R'^*>@kc# ߊMl綺 [E=\=oL.՝O+xp~-|I׸b;<o X;EoiխկeJqח/ږIFxNp>V㌇AptWp"uF\y|X77pZwV%qy4+|ɕLq%ޫ_9|ެ.R^׈_H IZפ}NCr(+.:&9Eqz]_HBg ~LJU9$e?_<8uU}Iۂl0 ,`#.;O7 v|õ8_}C]E?]ڧq9k5U֊6]uVƦɯ㶗gpeAlkϰՑ~D`/ߟ25 ɓ\7ϖ7s×o@[TYp8vI& W ]a^G"ϲr7;8+( ;##O$U߷ꏻ#\n7 {Eȯ@N;>CS~}!ErJ=G"v.'F;S%9=Hώ򯩏#;}&}IRTCnLu@{n*R=@-DǚzT Akuu5#Pv G& mJbc=6t[m< {ݕ+4vER8<+ b~T㯇Dځs޶*=XÓyoˍBvC_<v ?).َ5 ߷kKj8@@,/΋x^O^>xl'ĉ}(n%/~5 +5^JN֝FrI;?A%4: }H}O߭'PHnt~u?w@(p_j=G@TDϥld=j5t`%4oΎWO0/16Xc1_Es7J ]ź:u?޲YyO9pm]ѵ. ߦS#p pAġ xr}6| RidgzYYOqF?'m#eBw#F8SO B$H8/RQ~hX9ҚL2]ul~9Nfǖ_IWD>N}]s|5=dFv r$8u9?JuJa/QGCO*? q[o(!hu_/J|8!pR‘3\}ѨxJ})Oy8Z@G2,ҰσU<k^T7N}r_W7Z7nfNo. ZcTv)7[am}S:&Y@wx:[+_zނ'0 D$*C"Vw5 aP\;⣛"WL@hYƇC_(_ΣDڗC)*DM!HP]_s(D|]WAM}<`+Ez&1ag9DѾX3DZDǹ>udG}<*;ߗFڭoAE7mʝ[ =E> aϬX#m06߅ymh[Ģ΋kaG!OYKakg !pe8L[քCb fےEŸ]z8hp7h&'X,'_י\#; \Ey) >7g/`3x_=Dv'a rbvGgϩTZ\MGw+ЮcOIsi~=5H=#D`.).Dux7R*?o QROBz QG~< Dh!czj?aį1&`|*ѧpZē6M m-;wDc1kTCh/+75Rz\ta(ەq'$o˓[yBEpW`bu8bX&,Dvȣv! TSegϾVʅ;"WE4Is&5$?$ TyU?D~ZdP޵Z-*}\Ir5א\#dS^6h.$a&&OMqj|V}cj_޿*HtT/ku>ϥ'5h .IHl?p]Ld=LGݟΔ;-1iYaVT-#ykӸ+\mR!m |ےXyë0j<VUoVo;l(nmw{x6خ*C:>a/-B(+x[!2mYm+r4uʩ}ݚjq4QO}!źuIujI#/BrddS}ߍDTwMS$Ng#3}N (5ݏ0>"E3ڈD!GQMXn?521npGm7Y>j__g`O]WGFK. ~/iH!+?GvDz"#U5]kJzo Q*w})K?5]:f'=fsd f%;⮶"Unj>3Or󓖭ڢk"шu_$foy<+>, -dGPt#Kd]m ל5ZâQLS|t f!,{F(C#\yz?hfiƁպea{DF/Pחx_Y~RZv|Q8(qBr6u݊}Gh}ߍ&Q] dĉ:7JaWuf3_]T%=Ml籇_GA}.@2kE^$oZ/K>xx_k0w ymaiػ^o@aq dO'9V`91wa|-C$W<*| rugyƖaUQe[u?TJ UˑU[Zs??N;O~dCqRj_,"/OH+>D7䧣|g>_jR [SW%?QQExn=n<] 9zy]uVx|Y{ҝU+qN'7NDCd~"f^Goy*D6#l>q^~<ʿ)IQ_Ȼh$}CM0W7[]?6z"=syx~+XA d8> D<bxrL헽?`5k5뷼-T+'V|u{+Jl>׿_xcp3ccζ h{MGpgs/o>`7/.C|oqR~иdUfv<|9}mJG=͍9l؎\X8Pu=y#:jOq]h֛^X^劬1IysTs1P]v\mx*T3K/Ӗ3 I/_|IE?(G̸y}5f狣ڏcSlGS4R>65@ -y޵5O|#?Է~pXKw1ֳQn Whܟ6bku~Y-)>x ^^>8+ݏ!׉A Ao3 a,[Dtg>@?o9bu!fO϶_ B^Z)ɸ|ya?ȏu|9m{HR4 6q lmyCHͫrE]^+Q^88ՅcOHXܢ?8FQhLyCw"Q75OsKdca`kj>|s/=8C5{e*^iGHI6~ <<3x y_=|c/k~]3 e5|<0 DcO81.K62�Eþ UNPiߍR"ޢw羶|τ򱧱4o Wgorgck%{#Y}x~~Nl(@ڧ~ g/ 7eXxcŰ <-\]l~C l EW'a_&E* <,|=__[;E'O0)u=xܦ*BE]8N~o1c|jHf4E" qV~`\be?}fjˑdh9׵6Ӊ+hSRo@ Ad:i"վ״P΁䟶]4m隔~آ?)WxF ? ,XW'hvkgPF^oӭz%py%xBr*f_X5ʚu"޿I&x-)\Vxܛ =5ҷ-tCOmG2 -XA]:8&\ P @r"d=~5X%c k -ຏot Vkw}jkحSſgEɏ]lC#Ȩ#? 鼾I?TJŖU T)JY+rSa̓[Ex=Z,̲V~O@j.c@(6,\>l]K<;`f0"%xi[fNHX=ƶi- *AY#8Q?<[U p1y!ٕBiq"y nNz;Gz3[p+&pqW)ѷ;Ilzp1uuflDx8mc"k(zgtɟkB.}Iy楿-DJGoKt q#!?W ~n%-ϵW년\}D]>%/_?ćߝh$3Y(K}*0~_$#6y;a8Kr#7ꙕ?..*r2mBIu8/af2Fy(^k)WB\/_#^Gnˑ͵?Ӵ_WgjLr,?.Q4ŁԼm!H^lGuqO{]U"f<'5IQ~=VjID&.uЛlce)HD<,떱]Jb5b{'X#7?։z͙nRXGXPl7oXB Ƣ{/C=%gOg-VJ? 8S놜NJsFDZD!1B#9+pXbX&]'#uG!xGM c Vԝ_I+1TEuO}~5RACuk Łkkq'[zL]%&lmjM ?DA;_^јOV$/NE͇Ǎdre'`4sKPSR4 3y\V.OrRM5q}/mݑ?[K~ձH?/n%?DfQʲg@W]bs{%/|9qj\5ř=1yy":F8ۇfO epOBۮ }IJ֮OK meo޾ 7`[EPf!{޸ MJ}zBƥ||ϳ:$4 UR{ =3ڭ*sI~^Sg{AS&,2?cZsl!-XY0z_bt7:1JL:+ƋOzGe~OI?~Ol(6vHCﶛYcn+W ,ޭi gqςe.gN5z5ln+w6jLN[ ,~*rԱ/ ^SV_\hnǬzX7tcRvB.߇=uή}U}ZցGLI>pb%v=ؿ}e]+4~Ůh8|Qf_70ʷ`lQC*>EGOhXӥQ2ZiE.>*Mؽ([zǏ-=zyL; =g}:>g&d}>a:[om*޴UI+&O͂qo1irm7`zGvĴNJ1,['={:eۂ7u0ްf~t68wVbQy$XNkڶo"]Խb޸IGv{D:EpeZ`S-, sH$b~`m䊺b#oj}ye>Qe˿ͺtdr׾39 |—E%@qhWy)mX3bD[C#yln Q~?#|V fGlEL73ߤ=Uk[.{7[z>GVL؝jS+!U,_1k;}o?X|t'oQ<߄I] QFU+{QoPlm)6̂ ePSάEM~E]*m{{p8aRж~}v%MĥaK4ٰ\~TsW.car`r Ap̶`)}8[smr75x$7649=r=]S:(4vϬשH{L`AW?υ~2|,ptW{x/Df#S ,qY)%{>؉mqm^΅~\HQkD1kؠF >MdT:.fVj;[fZ|Bѥ/>uQ OPNJƮ\:/μWr!JL,g(5jUu󺏨lStOi753n5lQY^aDu|W.*z4nqhO /2BIֹ|_~|vֳ7CZ)|XPYj,ẗ́:|9uĿ٭Ae{ rpum]4Kf4J=7MZ+vC%_[7@sW26DuO:̽^oS>T]N>:TҢcTΉF |[v&b<Ή͌V\3P\ gm~mל',=ǴvcgŰ KY܊˵&crwϪK #`1?~]C`~mT{u쑤IPj›u _trBv|Wс}Aph{X>OœpH:}x 7vHNdiR}}l[ >0o!X[}ljqβ{ "^5{:ݫJ`ץ;u]+\  oX^G7]2+5X ycZ 3"`qy#ɘ4ssu9;Vp`Ƨ#"}7>;]3/dݨna`1 V_šŚJ+(xs8ÞM~DF z%+U9?r.|{K/?*{mM2lmoeW-sq^"dzD*R+]{Sn裃Ӫ%w}-;?ѠӅmKB+mnTKvLAw)ak*0.6RY-6=.4ڼ`:U2a\JSdY%u:/lb1{_Qɰ:—sL:xLꍟmۥ:_6z)zV#߶cXƓs][Ţa Wƒ}cJg%-y׵5uc,Ky_p>ԠX@ǍbcDA>6qXZ퀳kغ.X-!ؙipyگY;ꨗ)v>O=Pu-?<Sku'x8p\>s.x~[qqEN`P!^.y*ŕ}B,_, Mz4k>_Ex{&3ڝQb{`7SݡQl[v-k/c{'YURwѦn & \G݇.SʯKw8tWO(79^"=y͢L0Quy^X6ͤJ7\mz*]s?쨱ɦWtC1Pt2S>uFS+}EAKsRzl[{\?D_}?_"Kw)c le.4L oM6o<_v҆hrc|J.'rur _ڦ>2U6L|N3Yn3=[7sB}E[m*z] aXSt0Ӷ'`h@1d#M-fs`FbwY8!&Y!؝WLoA]d|x[XxzDsoNg/8{6? s&yV9y]G:qJ߾AsD_y N8uNX1p3XԴqHxP|U(uF*U*űqLĂ2ôۇcE"maz`A_'X8^bەIĬE]fԃyH֭aWk[òOZyG%JF&VӖ3 t~ѯVjhZ4ؼKV+:k&]kۍ]4yIp:9ڢr1}Մ:7fɎ^WyVC|+1q!o5-c#5)T#7YfCqw|` 8p>Fu9^wE;jR g%t{vNョE:mꉅvb׆?+{~;Vejkn]e10j\N1xӾxIyæ9=껜U#mhun<0ᩚgukmq<زG"\p^k;tRLW",Z#"yq6GR`3?upf+BL vQ:*4wZ'pY`Q'pMuN2? MJDe+靄:k̢CiNJ9)ǀGe8c|L_0Dsdɐ~fg50~stJ)Rgʙa2h1ʹ͹5q++dR0&ָfY1=zC;{"fv$ΘZ{>,mzvIļFu {ҁpڿL:pr,Xw l\X8<',va5,i){Kw6Ɇ'|+G8s b; *ze4&6æcXݤk|鹧ůs*lpp&|Ѽ/N.yQmeVD X]ZԉCz)RЀQc+r٧.Ä́#O{L?ETٝeOW>Wc QmfeM4ڹB=4p(6Z#Lʵ$B'tߺP"lMJ+zawǯ l,zC:(OC9Le;[;zKD^|@O0m)c6NlfBVwagGU5?]6ktr.[,(Ulm{ɾ{}ݰ́Nc_mg^%ss[6[pn-p΅//ű5l{#tCm N[]=5._ᙯS|fU&N/]Z¹NK vhS&6 Iv={aF7p8)*1,W 'tS *^]M]^%wtPDbվ$JWovu#6oSPݾb^ۼFèo{j [+΁6|8jozSr M'u(HEl۝ٲR>9~=U^ =ttpѩVd4VZ%9&?zy.ߙ|7<>ύ);Rl8G[>W]wn٧Hxr`Zz~n6 5;քUt̅ Z%F:瓈/OY9V쟩' Şy :`wzr<#.Խk-J5 V'4) .ɹ &\_r87ŏu 7pR(1{Rj^z\ay.zOG˷{Ymz]f ̚t#07j\I/(?#i`aSjQd;b> =?|[o|I(;ih87~LaC)he몇:lr92К;h4fWztjvyh;| ߷\[fTUSLnEoz 5\Ԡ}wF_b խn̅A1x! c訽%coV+g{uT8c Sd'L]h{7+LwZlkY/63|KtsfwثsPum=k5qV|*@=&_}t /Z+F6kF,gÿaQWv(ͨJw*7ϼ5Aso7..-4.] ;k%&8 ^-~&|k(~jG0_~]Ϧ;i/ٿ/B]n+xT{*Vx;Ȝ7FG԰,f@b͞5VApaݙ* ^wͷY[r!GDI.y;ߨ`BuRVc &sGCQVTyr诩AEQ}_b t71ʇI0*˔ɂb-U<27uQe*+:"JGdS̵6)|qjjY'B_G*G<3ׅ(h ])P>zhdXmkξFhus{q~uh|'OB]-f` =ȉ>dX }M۟'"\j|w1[wZ=" ?&[0m۫5~:/S!p^^V/^,FSLjL@^j%f;lX'zylgLzM-7j.S%Kl. [x } 6kuk,}SX>)'V\6avXt3c!;&NSn4^R Uo!yXӰ& PyŞA4tlOtVB 93t&su>VM.n^U;K-j'֜SL*EUǼkVty&>f._zӅ{|*[O6ףv\xxxMp _X9td8n7cY18*6;w)}1Ϯ8¯0=kBKTcn}j=}+} aIiz<19,P~`}_{_5Rk}Bl۔}W!ת+^uVPn8f:hqޣ\~Ff6tPdI+X.w_LJk t3Ճ169p堾p1ٰ}xl[n$l7_qN,36\73y 77MwYl[ 8C\0<٩;`ԙ95فȬe6k>YqtI1ͮo!Mo֬18#ͺAUo+-~zpcӠb[A6Dz&.,1wKD^?U]?Q4xU|<3o q4#^AB_SۤeHL \~U~H+sUdnQYWlrXZd2_mSu~VQ n qJaIWG,Zaj{ZvDo3/usg`ר}=WE_P'~ϫ m}:/SBgE>ӉSD'n^mh۫[/D2=)@Z FZ\ۚdel^n{GR͔4@Ջ3+fhqw҇Z0cqvs~b=}bϓW ]'X(~ґMb`h#^c?.Ơ/]5n_ӳz-LϮQRNpm=apWLy`c秇58>;=?,-aW,|ziz_oa~>o Iz%=&FoG|i6!M|,`2vu0wTA .d,آbӏ:~j6a޿ 2m㨜.־ypg-pY\p{a?JZÓ8{8R!p{8urcpΐtu`Þ>*_c@8_`IQ}pycUbA}.+Ոz^߿j%v}US=Mɯv^ѺpB}ſI)4`W4oO?C[^w4و< YWLW;j/ ۳Nw"\}NҼ6 jo?=GÖ߰^?j_[C5&,LRcp&_-/R~|D+5^jVTt>mgkD]L5YLi V! gm .DJK{i4`ɥʳhژ=!n L0m41mh򘓹$^;,|~Ӧw6oXn ๔?bue#ϕ*ro5c[|O4`yҸ,aVl%[;פ9s3p^y˚ǸKDlk4H;]j:Ğf ^yʗՋ;u{bߌ]'b_FXk> f0]g͝=cURn0hK8 8{jV-pnLtA7p#jen~C%RTĺyV D/.(;b${#$1Dlz^'εHH5nY/tvo@O\=z>V|?u".ƱnW-"ƴ;j*oF7{F͇{ů#~O>Jgب?~˱["tf_]*)yE}3':ko{,o\$̓6PnQ֐!  J*{κ{P oUDD(&%o7Tf1:5__h٩=,UbgΜ}k՜=S N{n]A=}W>kU/:WVlLU23K)׈~+#(BJ% _Ϝ9qBk+]YL5Q4\-y>n<]F? F;T?w_ ^ִIjOZX9gna0-V,$+Dž5Y@l6:m3C ղ % WU[ Ѱ۲nT+t mR1Smfh3>},v-9:;zɾ oβ8~j^/l/wps88F`u8tt 9M>1z \.8:E\I:b< <ִ_ƝY5 FYFǿ @IKLN`~g.'~`łUa]KbIi=mM[-,LXk2鵗KZa]e3*Lօ~{iOXWMXA X:9 ֱ]](mx*iWPF \!k_lZ: ðz7kK<,ko:n[{.ؓ1z˨aطszj8^ 4Bxdw^P"mb ]7|pm3pV؅TiغqBOu+-|-=ݶ+w.7>芹-Zs.k=U\t#i*wZ~h;2z.yzd|-7k,}k HV3 7eUm6OS'_o'8C˖95G_EuE5QQZvvEQj[/}wOh?#2hcؼ{ht8{Ctf0FgtisNY;\aYվ6~3HwmTyަ㲾zv:^wZZu>^+zq*=*U>UQ>)WCG5J4ji'ӛ*SߠCO$BW?jj~2ð'-.@);}э?6BDi_0,'| LZ2bޕ1+k61Zw40O~E0irQJ)p\],?keX4|Z=,m4Ը@0^2n!L\& [f]VW3-acߦjbcO:huaؘS,*3r/{tM;8F0i(>I.)S{>Lݱe}ۆ{bgH&p>ݵ^88xU*qYQأY]{Ӭ u } ~Cʚv-M:#ĈW mIٟq>b~g6yggw D}_:hbMBbKm_#ꬽpr ' ˕5䃝-"ƦO56A΂U]ˤ!ꊹ-GZ.ræ9_ǹuP#ק*-[}u&'k=zvҾ:`Yŏuwb G1d_Fxy@7}UG;7(~t%a|̤bWݻ;}}+c~I?0~Ս;0aˎg/~X z2bҘnޙ/U0de`v+o6Ŵa\L[V+laj[a騒 |؇̮`Rӣe=7XPo&9,,{_~;X4 *Ħ!kS~_>G#w(~P,ۍ`[sMsߵ7c:ouBDKw컹U`w8%k֍w e绞8Aυ }$'|0u7}#׽֕M#^j6'b2G?.ɉm^[ aKDPCdz2vrv[3Nh c{rzo/!:Y_Ыԇ5n]lx7YRI5G} hWN ĵ56m4Y~!ȸ?`cišzqM.svڰW{VJ=^Fž 7ëGՆnő^cVXշ9ڟ6{/Nqo{z/dkNU!$-CkisDukx7Q:_]Q~uvE 6ێlG 9_"֓ңyTH\k=^hLe}R3޹AqkZ\gk"w:};r![t?z5\W/Txi;:```"4xofhalu5| kM]%hv~ýl0D7C}Z1Z4ȮD9B d_C1Nj00g?pfBNY_C;.5-nͷnj64C&S^ޥ^WWҳXMS= 1|hP7|&nxqmGL`oe1>7S4&T~X+O>}[L;-b|hi#3zaw+njXP!sI%1V4cFK`~v6by3`\j~&X;Xt)ꁽNg;`Y%]Zb?;șSîzY_4C50ww*G%vjN5'l=_] ~o8}ڑ>>&k{{s:³ד~ns᭵zrF*9tonTξZ MolNVmSZ] grV\ۆ}crAcVMGȾ.rB;S+C.Z^DV%lK#ݼ ğ툿kіHtM8-U,\!à l@wv/U~.vUG%t 6N/qfg\;Ka<#M+<6ὲޡQF6EؗU_)\%UDGm`r3z\{~qns/3Ekyw^+ m~ZܽoSUEʗzV3>k, fj*\`ciC/5X.1?:Y2e9)k4o.8jjKBf|~:AnAD`q0ٿ`$=Lv[g. uBTaj\1ka3H?yj?9jߐE -UuDN*"M9feF  :7jʅk)W3HpI5: CoF#' K{B3~}j֘&7`B->}E 殛v*^-{iW[yx/&n4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJSҔ4)MiJS654hh4vU"!!8(!!𖐐cKHH1$$$$$$+( ?F#FBB+!!LjcKHH1$$$$ ?F#EBB⏑*!!Ǹ*!!Hc\cKHH12$$$, ?F#GBB⏑+!!Ǹ.!!Ǹ!!!Ǹ)!!Ǹ%!!Ǹ-!!Ǹ#!!Ǹ+!!Ǹ'!!Ǹ/!!x !!x(!!x$!!x,!!x"!!x*!!(U ?A ?_BB$!!Ǹ$!!Ljc\cDIHH1%$$1X ?F#^BB⏑ !!Hc$IHH1%$$)T ?U ?F㚄#]BB⏑!!!ȔcdIHH1%$$9\ ?u ? ?M ?- ?m ? ?] ?= ?} ? ?C ?# ?c ? ?S ?F Ʈʨ)!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!e44ג(G9Qr(G9Qr(G9Qr(G9Qr(G9Qr(G9Qr(G9Qr(G9Qr(G9Qr(G9Qr(G9Qr(G9Qr(G9Qr(G9Qr(G9Qr(G9Qr(G9Qr(G9Qr㿎e44j?1h  ()` PJ@ T(PI@ )PK@ 4h(H@ h)J@ t(I@ )K@0'_`@A &0\`HQ'0^`DIL&0]`LY '0_`BE蟜?r#珜?r#珜?r#珜?r#珜?r#珜?r#珜?r#珜?G9G9G9G9G9G9G9r#珜?r#珜?r#珜?r#珜?r#珜?r#珜?r#珜?rO9G9G9G9G9G9G9GΟ#珜?r#珜?r#珜?r#珜?r#珜?r#珜?rGM7v=$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$(6mWJm_r&-Y7,WO7[< 6u8|I(9{[7lˁGmW5`~uGM$e_ ֧ }[ KZDK./jf1}k[A RX`Xݠ͆X2_Xs|fպXqJ4\(ktbiyX#.k4JC/0=va6{l|!m1yo̖ڏ5 J*cc;0m Svxtݙ!]4aƮZ&Gu'43z>Yb]EKGח9wH .L+e:X=?{&̯trZQnFa{4ޣ>68Sݞ Ʊ5>֑I{l&}fhU#o`xD X<\Al\1Y5AmNт7͍ڸ8:+]8c.D l>Z#>0}xֻg1'{* FF?s}ÆcK~Cofި'~҈YWaVmvp3~G>Ҥ!;kڧK{`c<[TΣFz_x]fmY[z\]ߌVmmbװCƾkuwboGc*l[}6CqHe`wC쓇ɐAw޺cL<*fEa_GuЕ֩n=\ksûqps;pۘUy筂njapq8Z+Z:Jq*)+~ϟXr. o}g7SF͏̲=;ٖ [ "jm?"ߖn#|4}_ 0-68?,bv";"tZ1ݒRJ63f8B\Tfa7p_ ٲL$>(3pjȨ_^l *8#Mp(5.Έw}v%l{3W0sHn2od{$$ nx`>I;Ꮄ ^N腔 _gX"]'Ǥ*l!گvKCi76WD6_u3~!˾*c99Ȏ72[ =*Yd}=x2Ö 7j_m:W2N=6 nrz!d:޸es9,uOꇇ'T|ܮevэdR xTM`ß?U?vjb<a{|㼡al>Pl?۪`(_uo{~To:}sWR_ovp1*|cÄV׻tKWB۟-Qgo\J a */}b-^] w1K|X kr/V(y[Z紖W 1{) ;b ^Sh[T/Z9njً\+,;"le?| `ۘF>t[dVpRVUv{t챹ݍ'b#~C,~X:U!\ͯRRV7`m|F|;42êM ; ˜~]Us֩; lp\3`6mf3ǝb,ns–'1mֶԴ#QZõ2֘3v|1F[͉ ->.C̪+7bϕ6ܚowGJǏ}slvb?'.ƑlC5نlwio$ÏFM rS7e=Gßo[Y?rqsPhii{+. 7ھvUIm&)\fއF duz!(ʵȣ1œj*;f8_4vpë 絋=p"%.^tFr, "˹ۋ*ڻ"*hϫG.yRY=lfBj?H`48{8UnY=$e 4,mfA [_ iy psBg5;X#Tײ=Ҟ~_XrYV 8ilCoe#u]a֠J.Qmgn9jzE&nAj} HF^?+({\QC]g}l3l7#&q vc51G'K41cU0!#51VYS}Ql箉m;[|>m(wT摺Gu' ^oޕA#霷*|7睳 1 O9 /X[=_;Vyt~A=(]2_qCTl/*3~nuVV?Wzd_blZ\F ʩ~Tו1V*O/_s(`S we^){˕`vVx(0ݟ0yĒXŶɅ7Яaj`M[|S卅/e%L:_kC/ݚRv~[@<`K4!X'lTՙ0%,5Lm1Oǘw/X芍g g=y|o z-OGB?~qο.Kw?m VW lUow?zﵫw?[k+;3JZ rQC;olgikꝌ=b.].kpFWfւ8x7A0LQQK2|Kl= %Xv^#Ee#px SZ=37y|1*[woPX07!8״yjf+U{+n@U6`-B<~ g=3B~.Z?tyt h;&X2wז i_"n]iyb`,خv>ٮXrgbӒ֏A ( IJO;7 qﶗZ3)l jy>$4g{Z!%P=jp-߼fҚa\d]H1dBdwi(2GWPV7d5ypdZ lřНg^o19a@a+R"O R\翋?u _"nN[|ҸxqiINxynwrEjgȬ35Nb.S\/ |]K ⏡lAS]u&*/S@Y}{fo f<*_q|{y뙔QHY̷0Z%1{><[0WB9.- 7P?EwlwC m/dKX0۪( E\j%_|EqK?x|-~{_9XJpedqG:jpو;ǚڢuZe6UTsqƌ/'bc >VvGbR(|TgȲ*?9sOˇjUO2ZBÃk\)3_X{[\EĆ$[=eroسyR'CÑn#ˇ3*#p[qHB1!~" "NGӣ$,{ͼsa4#jnR:`JHe6t2Rطhx${9M@zvIz"=uC+[!2<|@ߪ k;< eM[ { c:א6c Uv7wFnMk|,a?;,M]g룬~_T+oO|R+n|cGM*lü{yF|]WZȯ ?glϼvWGB$ ]~~H'޵DO6Tlnn="=]?Ot=W?,ݪxʓ3:BD\׉+^?$> ZjC#m!lW]. Yx⏋O2~!m1[P)hb9w5U~Z6q,SݧqXcΏvo`vMBYKQsxm8@ugV B%ƏkM|XXHYwysH{C_pȮU&1<up`N-1j%(C,g^x}oj!+,y4^7a|nB)6v` Gt>c??Vx+N|V|9'*W U/c^= yF5es]*O{./]*Y#c?⚑) SLvbƱ9[Ucnږ4d]{b_SWl}+;iyշ< p<OPq<:hģܷ/,-OWF}?Ey"PiXWG%/⣥, "[XaR;` zj|o 0󆶚"DŽ;x:EL3vY._hL_f/p.OlEKczm],% G{z B˗ ᗢp;a@^S:h/N%~7f8^|뎯I Ը rt2 ~\W`Éu!\~P:l^8])ޅquŖzAGY;}}$,5ET?"#^3~ ;?"mW f+.1@ R {!ֿsV$w,2^ȉXl^xE@RF'`϶`^Z}7< nʯ`dLgXr9v3/cT6lEr, ە l?mY qH4}SqF%v>7|1h}W=#+*Ov0=8Iu4Kȧw ЬO>%w UvpF$[K&FGnPxA'p$rkҘ6J~&O[o9v _\_h {M^Bë:pA"teFG }x 71lk9hmDeu=BxQ q/ſiQX(,s<>Ѷ+|3: yU(Ԟ5y79k㘢Iyi/Fc@2 Cј ʔErFqe,t.u\>7,6>-aG"9}|C$v/aHr5 Aڵ_\@mF!sqW=>*].KW![ckQ@Ah}3,!??v.6qn^;!8ٴNS*6 پ_SՓM|GM+Ȧ H_BIf橺ƥd~Ey*S>^9!ŵf2L[k_K^J)ഋq0_v/-[[_'Ï]>q\.#w^ i|Pf٨[,#9RUa-nsNl? " Kd ^ SÛY v_-VY&ӛK3e>mgF vFZ,QweC[?.l>oC,Vk\p/G?C񥰏G2[HaiaH2jj䦯r <H#O&z#\od@K\,Ri޶!ˁO\V2t2}9ZjGid,c99Ƅ !3nIHuedtr!Pk2~)_fKjz>RԸ >Ai=(DWoh]L%#>u8DEr]T]gG|0#P\zp>=z%=/Q>_-|FE%'G]BN5##cQwEF67Q>7ݤ,gb[5FLBvU8cZs= sEyxCG}6~&e8mY4lWeg/YfX+!ݸDz&Y}s,>fnf?L\0Re5ܙhZߴ>VՂˈ,:_捷h{g3ľŸ[5 7tukR Fゝs[U;&u>"+cʔ8ܨE=ئuM >up?Oo~; yg-'vnĔp|o ArڪAyz<UQt;_(A$V3P_eU/'s<SbOO~]Zgfi(OB?#~"=8QGz$Z略QՉoaXW[Y95/m(xbq=^ؽd+~8]+ |݂?-&w8T;jϖ$iX9uf*n"?Gf5zإ1zLx!ao,/cY~j?+Y>uɹyGU-sOpr$UZ\uE/우>ucxW$}uMrM(u_#3 B}IYIDV8XK^e8~#:H/#8Qyy_" 'G#mGt""~!>}8N'WT!jX,C8Wu^y}avy%B>^t@GÒNOy!Aybϝu/OS<%+sZa8qcX) XhGZǩ^?]?}P cQ./S6kW|9بAq0lxHlD}'l>/p~rxq~ބYUC^f\k]co?y A7wңe`߯=.⺒"yhS_6yjG:<%?`1;gf-opiSl5{uܺ xZWcC0SyvgqzPV:,ï?X0>/Swp绿| 8o*`Hs!,Wg/;荾m:.۠́e0(D~imEBN`bs:WXZo󯱳f0@t +$6F"m3{ ˥!""L]p&Ґ9h`w19Q!2ŔH:vqUDf]dfX8M@JC)wոYVS8DX'_ܿc}՗qJ:$u]%(m U^o|R8M`qi/'oquXNEW<D,zIE& 7ʃ}>OM}#ߠ> :M>H7FDǍ-?P3X=I H@ XPZ%tmwM U]!Cjџ'zMy}o}x'Au7E:280 IvxJʎزD~GTϳmT K'upQ_PmVldGCT'! G³*/t-kY:-سra4l^y8p=O9ܯzg7еmtx|mH*T[p4|.z:k/P?'8Y'[YYU(j{Z0oy8nqAA|XJ,]j{F846di8dw؅O_+l"X}Ib]ՁW ID/ \=7bADf[܍K'ÑrEЏ%pGדCe"5͑:$yMf H}7VBd{it7ID4\+]J#efq V<>]ą_2&8!ո&=#΢_н:I'Gzgƍhݦw3Ol'yD/g(򤈳QGqL |?՟RVtb UWAl SZͯ^lT6yA[i&^~zL&+x|?ľª=kcEswQX_[xxcU'Yײ ?; j0gę, ́z,;jt>o-.O 29qE(Byׂu!,We&.kA&j9hԋF$x7˗E) a ^Iden#.Jxdɢf}Nxyu+ 5O3Iv\h4g}I g|(/x8m BK?۔״^Ԧ} G5!u##8PwV>">"!cZ7I7G|AB~7#[IMA4Wj)FO^Gjs|MqVϑIqzm@q-gזr*OR' k"]Ho _ͫPU?tgGQ97Q?BGUɌՇPuOt;-~ڧ~*?< -}0z`}~(:﩮UN_uGsS^xlw?_\?Gc|PqMoDB|Dq(S#7}PHE|O=?ȿQgh_@QO^^'9P~)Cutҝ~.*s~&>WÐrހjw_}e=O+M>Q;|S?bd?/19<׳e5/-[Ժ&MPMa`ƪΏ 3ѿeaj~oZ~sZRrDzjݓgԛ܋j9zwySp6c|􆁚.T]fQzp鉡8u w&?&[t{ffu)tpnt28~cx)\eaۋeo' >q뙯"/1=q $oaYO4' N!IevEO8 (QwڶFosZ ,X.;ȱLH< jUox>E?dShbC>F~9ɊS2}}$Ek[udEYG[.?|qM2T=v,+KV;ԍ:}zFZ8ԼՕg (6}Tussh$^un'?]< b1xNM%ZW?nWb]/ϣ_~<&#Sz6n7x!}4.ݟbݧ8BCB~G8(齉ǩz8q9&~ KAէRrH/G: o}S;Sg=j}* },;X:l}3HǑyxN,=3,B=b+0[s(Iz!:O}vk`a[ۨu79awÎc¾/kYF hG+_ Oϧ'6 } Uԋx{d\US.s~g47O8ڇ8OwiyW}Iorq~GC޿O3|3a x</g~=BE,R=.pA}ve.`v阇Ƚ3BX2fb(4B'pL7ĉ䗙|L$9P|_KĹ 7KlWGܨ HWF: 3781oҷѹG[+/>֔qWKao\J=0ҕQʆo5z";9J=s*6zZW% ϻ7<70r*?n@L7,bvWW0gaMd2OQ_v@St]^gsKp!WfnW3{MD+ o7/a3~k!}m![N|.Ү^lݙeP! t8 X+ܵ89 {q*wx"D^`ҧpqnDkc:WD_Lݧgh,_{7e^q-Y&\H}* X"kbNu5/ꁫcxC޸ڹ?,B)&%鼯;2ۤVV>H}y,V.KWHc]M^fؔJ&saa_VlRW __aMūȯ(Gj\FGt{qG:֣ˑ_ĺDOD#xg8ĻwQAкJx?׈?feux?_}xO} <@ҷѹAj|MէRRQ?#~:=ޚ@s,8 CC~6𼒶磾w4s6b,~ |?hX3Kۅ& 1[[7+֑f]\Wn9˛^qvN+Ȃ/Vnw^j rO7zAg;!'m*U X<<;D]P?W><9 H,b |c9[VPk< zrJ8'_/e'IJ-+? Rϗ`¼bc90o:B^ą%&v#Vٵ?n+foi8B=\YuhUkb&p7U\G BTQo"G=Ma‘ϸn䲄fH}Q3F:?Iː;6Sm7PQ𶏓 "En|Vzc'x?ۤlZjjl_PC])nE|D珊GG#UwW\@~J1??WxCx[FA_I_Mݟ Z_};!ۣE܉t?Wy#[*>ig/PyR^mӈ_6yo()mBk٩zw:_c|\6oJbko0R=o|zނ;ӹu})ɇ-/?쫞cG t`-7yNR|nIuMc^Qcq(vߏ΃xc|<9phb?; 8`N<gz)7ºco㨨u}[%\yHq^=o??g9?yQ⺨xcS>'Q}}Ovv꿘MUG{H'n^zc :_tx|]P^8}_ȏ?ď[S~}_: i`p~ZDHǷCL}Y*_T]OV9󹭹_ q v<=b|]p4ڨ8|D@ GGT{4v6+3w28r`8GRny"QKw&ja=$vtx|Np=|;Wg^GH3v51?ʤ'VFlcv-^7CLv't6%t~U/XF#,?utb_OGM:Dbߏ#'~ šu(A|D:0zx8?-~/nSNo(Wizxg(^G*N*m_>|BG+{(^HuϢvKy?̒*,}O>:{wUN u:Ng*Ή5L3!γ|7TDCKtjs'9j]Q?S'M7ZQC{FWw:מA ;bRc7ѿΦdOihRvmO+;΋9N݇3sClȿ8,.UزvSzh5&<]|fx=}^DC`OŨ)8y˾g`?? q7?/=?6GJx cYc2bDU'd ayj҈ @ug_ȋ2b.1yG}+ד^zfBE-Ǘ2oS BsP!QS臚*Nyë؞!gվ)229kYSS%d]N蟔Ώ)8THu3T۷~raW5<:jodQP|5AC ř(?C|D|# u}~]8#}q5K1z=*x=,(E GHoM Ukb]ύB=_HZ1OK~.OO|Hq*^[Q} |WK#B(Ph:Vϯs΅XԷF=PmCq5^yLXUJ-5OFzC<䛚!Yȶ# `B*/RGmYK9 ZpT2}քX:g6cg}~[ի`+ow\ &bK\zĹǑٮzG;Rﹳ2N|u$AG"9ˮ&\~axܧ?X,xV~B4@֨􄚧x٩CenvH/j<h;&X4?>':D=t#EpZ1vy?3Tűrp+t&q8sW鈪8F ii:4%~TĈn//dbLz$(?f##=9̎Oq*H.@| @2; D5D_TLATwյ,W&F'#f}c; &o<:*i]L} \v `*n3{@6Ou3t;i=t'cG,Q܉"~>g%^x哈O%\mKRoX9ޡx/NG(:AO$`)gzBռ[.g>8 mǴ'%4߾~v>O8ho`ȓdQ~U7y_/;%bY$rzP9Y<{L"v*fgیGuq8Z牊&?FCw 9;7n.oP|My'Z/(n?P|eOG'NVUD߀#5&??7Bq'QU'PޟDC*O_Q_<I'"}5My^␔g!~iy(3lX<ҩ-qFD3 b5:%'^\/n->}/H\}{2XXCuTκ-+POO!CӧmLjl+;G#5S,>X硿 =w.~O_'!>"5(M: Q_4'O/T"U-EP"~GIwV\o~=gzz<~BoM :N=_HgJ69Tϻtl=Rm >uxgSVN.T!:)CeX}ΓOsa{^OAK&Þ/ ح(Y#8ԟԙ3<[E~bwr=b/q^ޤצvx<4}>VkW66>xdV a(~8CWC8M k W"1s/U9,=e5Ys N5:zغMqDT F[‡#{O/*ss ."]}i`nrod^o^|~np%.27ztD1s@bUDVaF2Ot@<ōK8k<5<yYa6W_U7(% 5:"/W6?h5Fn N#L*rC# ۘ_m[?Ru¿ݟxut?ZG>?jLz?/?/?CWէ ~uY=_BǿG}|/P|GgC7#:O %!~#U<;?O?jMRGԗPGKSR|J/t?&&Ng?ϴ@ 3!`#i:*Xs=?6<~V2?vT3HM3K^.ȉT[q yd?>E_7?oȟ?'yn?{(Z*,Z7pdxߊ*w"MKm4?#Nx~*ċ?I&t].?_9Of;~Ѕ?"F^>/Umf٦$x^Lgnz[<|ߋAPo/_ ?T>'t;Ql^M}Fq?_Pfq=NgGsѺ DޞtOj=@C}(I/!e:)^GBw~އ15~'?tJL *PPPny,6V[CEnM;@}ayf϶}JlɱOkC)7>VϷs\g0au_N[D_~AWΥ:=]q:XO.l~XVy78My:e~)82Y8 '7N?ΨכΫ&kkrb3Hw7.~0kZW ?7ׁk8_v~PNsxvuD@+$‹;#"pw!#XO@ {6u9BV(;4*գF~18[} ovE _G`g8b1r&8/($9BҨB[M岎eaՃso߇ÏsTY3x ۄd↑~K*XL36g!h-GG\xb|xݿzbS]0i}D8_*~>'t=Du^ mWM?/#~!=8K^'s~ψH@8ʻP躈{%>q qoR^V> UwA:GY{]{GUgNEZǩ?x"}7;sIf[|c났׵;6j|^#U/{-+P-܏Feo(cl\S4@Ϲ~1\W#~lLXkvcV"! ǒWND3k#|\aoD>*Jam!j?!L˸2ud;\XVb2.vetqŁJ#M+XQ?,?S[a*VՐuȰ:c䙩HCwD!UԹf9le'1 e2G)vO(2|-.2E NsXg .lq_:b|Egu$bWwZi-^Y*WR!!WGq-)D|>C/~>9huBG)"!!]4s]3-PHWUmC̙N_KX*r=~uwx} ذjQp;C_*s(HG{@vd]nj-`8'Ți "^SK>`=\x}^UɱrŽ. (z=p[-Ooxb~?Mz"6KyO8?,qnv0 N5~—Dn7=p kt 1bk\uuqN1z*^E1gzr%x2nijc\@+ ixlD4֘68Bs\' ߝ5k I:tԴv To|1wc&a#!!Czg-g :/'pS缼hx7x|x=N_AqOQ[J6??t 8O9{?t{Y@k'uFfXiU]Ũn~_ر"ůuc2~OǽM _ȣUجʩ^ȎYSqFlyfKz[p=7/|x pRw t;/s _۲{~spO*y6g'g#󾣧./+W7bD炣ovB,cŸ< ]U, m+1f"~wڈpwUEQeoꉬ#72XϱwTFv~▰e 1 v;w;ԙ_ WLX|XA tQkWۘ'qMCOsgV?o P4C&fߪvSf?/|3;?D|Czz9zG@]/;ԗMG*"K >@<dfo#vtz*LxMNaw^fհ˪-8]Z9sg@{t@F8> EQ<2p\dnK`Q)vXOs""js"YCD>?=0!%j(h.#L Y$_J\fT|d2Y65bXGq4Ƌ GpMwa>~\(x.@$;f:2Ek\n옩nl'&z{lXooLYrgK<#x`-WI?O˝޳DB>w@%â}9ڝzsCS@Jvifyꀢ{mz]w4~A1.j|N,9P{;Ǹ_)@5AkהY;L}{/eo@!~YΫĭUmK?ФWEx!"zmyh7`z_htuU!'u0ٿwM.WѨU/nVx|=S>FGKdOٯ٣.C_hED[}Wu t*kz4`Dw籶CM1dQ}r'6cw`ýSO#@yհ<-ֵ[!&)IO}Irna>PmL;Ѹj*OZ!I ZtX0סo1%vUEl?)#{ĸK|KD˳BKxɾio0.Ւz0yޠ{{u"j 7FMD N/9ѭf0Q%(\_g>Xag7)6V* ˒?~5 }XZlh axj5U?scZ5~a8Ť}cvnobOZUƊR{`d|/}Ӓ֏ٝkIcvZcgna3a _gX„%\sд Kg)]LvfFG嗧 ̻741k9En{"<  Ǻ뻖O6f6 ݮ;4&MwlgC  z6p[h[q_bjz_>}".uzZ~8je'[vC1!3tSh~oUDJCoo7&z3cg>6Ѣ69x^! 7 pkmeWݦm{A2;|C D^]Ȋzf=]ëR+s9VTwk۞D_p%ߏZ{cQ`0Prj,;.ߧ"E'ż3ٰzfiRaL-.]UFFqOHYXWsׯQ?!Ln;%,Og{~\ӼH<,eҪ7t|D<|/uַ!s%jm5{dF~n^?fzR"j:Yu͜'j }Ԯto}mQM+wsgШhph_Ms~ۦM5pSԮ;MY4wusp\ۓubucw TZl;۫5oe;oo5?yoc>>Xf-43Dž0pQ55jc쌴1:KZc Qix~uٿ:0OTKHA_9>`uZ5P[{ڝ!=+ }{Fxs:}鯁QV6fh#s5|]A|FU*B#N{IFv THkae[Q/jYkZٴj0#KsQ2['~3{Z8Q&?fpgں5㮭m>Շ{a{@Iho>6`ɔ%7/_+Lŭ3i)Tެ9凧ð3ﮁU\PAb ~bh߱yYVp߶|Zi0X[c֘pm]}i6%ׇYo/ļ{N׆ͫk`Υo[;V6WݵFg79]]zF +:0<&":GaEO[^̓c^}MX^Һypfwtyw({N.l}nϯ; ε*6k^:a[i:|w< 1/7eݻ=.--.ibwI]|&<-vc*Fcߚkb8XXe/0sB;l}7ffYx FO%t1/(¸w{7[dNoB:XbBث o&|o|\?sf{6c 7Xsg ^ ^S^gahk+acHXZjZVr->aG^ʃC)#Oi}A<ĊU-nY=^ 4Uj \"׉l&2nuiYg(<8TٷQ?avXp6,c *<`|-o_0xִ~iX~6c$ޮcVƬ'eW+grWS񥻯Xu*[F٧#WbM|߼۸?58m'e/u낫T[s0Ωi(^Ӱ{_Uza/}q2A]M6 uĞ]:;:9cY½T*زv;$f\~ˤߘD2.T_ϝGq!!?|Kвq81P ?6o.;g?Ts f]m})%Sٷ*~@c쟷B7Voup'0ld◽to왌v8,?!͙.?fkJԷ+ЪN钻E}8Uꁖ{qR}yYrD1-w>U3AL0WVKa0aZ2._"[^Zs(͘-DO/=HhsUẠH;kdz6et ޻v:žKjֶ*@_U~-t=y'ZΚ;eN!zo_/J.^? 8_'ZٰGv5}V ;\ڝAoNޢ][Ԍ4jO~r[4 Z>5 ɡCx04@'O3>+G͕02!mF3[g.kf(ac׆͗v+[Dj50rUǷ]n_eeW oW>l_k76Y߮Q) t8-tr~=Ot0QB40j?mr9PDrVFT,3HRQTI2s΢Ht^ujuz;8>pA >RQ&|tԷIxrfkOk6OMRjn'6i>9ڣer\Svj܄k"Li]si;5aͦیrڃg>`⠑\9 /ʙ{{iѪA.xz^Xͳ_X/ֻHS=z^tە y}|tϒ>[/^&L5A"-nQ:qI̍?rڽ?j\X|Gl&d gE7wȠ\X?Jzwge2he7Z)~o^] -];u)F_=$gtYQ/ YkP懤i,|rO:q\۹M`odʘo}v% e|*r 2kk.:^ƭ^1 ~́S2Nۘ+6}}qUʵ,~ɼr7}2dT~C)dM(C{VOgɎ]ͧt/7mޒ fzZ}?/7Ow`K%2S_n7חq~vK^V/XӣaҢ_(?cp4:]eƏ;lT.?~]d˺tL>'ˬ?8퉗3nяȬ]?~yVk?Y^rmr Nl_w" ꎜ9tNC_8uSep/3ˤt=5R⺯?8Vnhڰ]yȰW\6_?YkbfsxO[(v{X]vg~ܩ]yd\M &-^0{e;dĂꙑrG`e= 2wNj59w~eA޼V&|wJĝrW=LvvE wt~Lk-w_ [~Yf^nч妓9^}g׷͑j?3&u\oy+k3{yxI77]1EsO,4l}7+|Ϛ:_̫斥N<Ŵh6Ny誗 s K~]k˪ꋃtd&kj_08C>KjR̐uw[, +{5kN||d)'.ixǎL^ի}pk2s9PݳV̺Sc6I!#Y&U\uv?YeoΓxD<߮)uB_ߵQD{i/C]v 9sIq#ߑkKwј;TߗhJdȏv7SHψw9`4r}'>_ZIWqOMos&iKKμ-k[z6iqsп{_ehdOnRq-o6q(Tyޚ?Iv;Cr4fyN&pH^6yHZgI*f=RѤ-4Hnv;N8L ˻?Ct^vQjZۚ1VZQmۤK?taiO' bڥ}9|w-hQN]>F}~Kv,/Y9Tҍrmg}m{wv_i2x'nx597u6N{G=c֬E~/O߾wac՛nKF)c^p&IbVg/~ݗ}wjS^hRJQk4r޶Dم.͠OuV:ۚ_w?G|_q8mԲ~˝126/2Nz&k%$792|ofޏFM:x.q\k[ _T.'cg*;#'ɸY9[x2a̰7(Y]ۗIG/wvn+gorGtOnrڰOdFkm1r5o/ 7ONw~y`O͓o&ˢ7dvglBn3Ls7=e,>IɖoP\j·\8_߸ad!:S/{.o _>ru}[tR8̺lgȓ;l]!uʷ_!Kվi<|gt_^+d;vǧ̕W̫2zyiO?s;r4{ת/k]eqp^<ҕFÀ-&[?[&.{ ܲ%ÁX,{9?\/[d^:#öǿp[FvW޹&Y8v[NԢWeϽT+?P ~I?ޗpX7ێNsQnu%~k~ -]|3֛ {[I {G/O3<5?xζ߿_<,G7~B48c_GvQn˱~Lv̨gk$ה;*n6w^vvyT\7qIbS,ޭG31J{9yUcؿukFie>㯵v]:nS[ԛ}r/YsubƓS;'9և?~XBnrcWiohHlrz㓮_"-nxzquIYU_pɏ٧|J =G˾ݬSv}&|K?£w]er{BۯC4wP:~?%~c6q4Z^ۍd󊋯YPN-k:f_Y-&5zKeE({@N1v0A*jtZׅsYzpn& #\йcř#w͝:'X덕1^.s]cp%>_HV,rY=^Ufn#\$RkqңNf'C^)=62tj=8Bθ[vɰ+Ϩa 49jM2g;nx\mfG%g49.}[ȠU}GGQN|øru},t\f{e]X.o=2ʕ?L| 9kc?YX:&|Hzk'׎}:֛!z}_{z\_8`QMrel&^ #j^͔ѫމVx~2Zy/j$NU<}ͪ~;o6X}ڼ9s v{,kf66x@Vyl䏲yiWȋ;.]vJWÑߙdCrڔ!ʚ|Zʆu}eY7_?fȫٺ^l {Cd)>qMח-֌u; V>첎_{+-=YmzYJ+dKK ϙxUN۞8&3W+OndgU__ugzg[y0{'~߿~G/?벃rk$uwxK2~3֔G˾z}kFԋEKjv(N|u8o޼~SR-jU=[y^& yTtzfin{B&SOtc'Yç2۾؞/Z\cĺ*a8}tgmOk~2UM󌷎~cx۱ŷڒzf_N~z׏f }8±d!i{׍rR[l: .^r'{겟䌎uoSt."VOe Se mr;}IgW ~2yY=q©'|ѻMf&w;-W˾Jկ6oο~%k\4wݖi=-y_J?TnsiqB9fҨx<nQξ}IOBl坷/쏦l*j_zXz$Gw: 8?pEz}8xKO z J|iOZgpS\yBWXeSg}ýE_fo2u[}䑎FL8$rHF/kBd Nټ1qrs?ZKOi7n6x̼DDžrku[ZfL#U%IyW-neSdj|;wϕ{~vlx7ZΗDm-\`BĄAL=aIG;VǗ4]-^>{,y뚾LX5dٱo}ɲ~ډF6[ +|{lO[ ;=a%iȪ;w'Ϭz`;=??ɵ6~bYjHeXyBkv?vM߱zl9\w}7&;8s|^)6\Dv^?֩M[F$;n֐c3ۖjulzz(IC}XsCo;%IԻh;MjLoduF*H|/?Y*rj_cIJδ:G>K=rdԺ?z ]SGa;qˠ`&-Zd|=$i5|C:NqKjAg=.u|Ƚr΁?J۟Wan5D'{̭+;k~ID6?C>k̞R_ʯmiJ7wd6KzXj>7v?Ҳ˃~pP:pq_0Hf5mΜN6Ǽ{R [ӥ; ;n4J˕e3'|i/F '6vjer֧˞Y6-Tgznt]2ׂ#rj;vsqtwx;^v׼c,r#oIM글tjsu681 :C2̘s'\tc!N?퓁m=t~4_tϮJ> ڸ~J;&NE259d {{"K/;Z~X^ƊߡYn|n\uzNdj]/>(M2C2K|B ?Y&wy=2O4F.wnb;c=y|^]+\eʱ~P&6u]Ȱ{or2ʰk< SWM 12nL4og';G_'7Ol?NXc .޼yHw=6cmїne&Fw?gٺ2s}}N7gݴȔlarϾw=$uxc̨~۬wB Xдqe궡ג2sPw͗9&ڌ! M_.d^W_tL5Y=p^WUuLۊpAQb^/;| eV q}_03YaDUK*j=nwg׮yyx,!KMd--7?جB W_)^yn毞KnYX۷SV@YzܰX^#.\ohX5IyJOJʨg++Oeo5[OqaQVv権nW^{+ׯ lߓywd5,0㊛[,gg)iyz~΄TeC/g\#+|᝟nݎ{[8rl{ZE?.eWFɦzl9>“eqKU?SNg_0?jD<_?:y9ejOOlxbP/Q&؄_6ۧZztH>op,CǡxD[j$VՕܹo*ϼ=d?~OrJ쩍ߙK9P(QϪ_}xWZxGN(NTmC39+HQoЄ 'Iwϴ)itwTrsCۍoI'm=ޙ{f'uV7~qK+އmhX[mIݵsCҪS&0/6c۶ºɱ:|!ֹruӰ'0'*SjY~sU7L2i}gKNk:yLµm8TTݴu`~;>Ü᫻uHJo^sݟۇHăr`aiײſ( ?{I_/xw}'!9S'WZ5tZ>g]V4?Ǿj3g#'F3>9,~p S?|󀌉v]R&x}2:L._Fzg}E4='ɸ7[f'9[nįCƽl;5:2a+D2)7۷t4^vV?|=reEvy_=qJC-6g2'1]n}S-ei}W|;&wP`x>n4{ȕTR <港!3/:?\e,>"8rֵW?,zJ/&sK9}=_$^ZA_Y|gs .]?H~}msx}_r`U+yoOygd6,VnYh۝n]A?!+T}`;ynd坻r[ yyEλ_'/ucZ?Vwyi L5]4lѭKg~x~"9yPؤ.gvG>l>g;eۅkGdqVs ̗x}n:=o} rإ[hª87Ipok ծpָf&99peOuh"ډ#v%ym7Kz_}-!$6Ô;!7u\(ﯯ / u4Kؿ2E%I t匿7 4tMUΐ_–u{-n GeҨ+JnmK~ZWONT$s>&f;zIUA*l '_#MtH߹wԭK#.g~﷧=ox}w_0b7d=K[N={NuO~`5s;wjc?ഫ,/}`I7u=7$KO{; WHO-.=/w?2z゛/msp >Vg_Sz-ӥcrDŦ[Sժtm~q^^!<O'l墰t_Z(]î3rIǥKz,iT.W| ʕ_N5uŌM~-WqՏ,FtZZ[:%]v]Yo?{sd{Cږ=#ڜ鸭\Sosd5ܔA.c^k|..x.zdpg>xY2iOK^<>RQVmwʤ-}+C>9O"_![LuoQ\;ꮳ6/72>rܶ}lC-O7TF+;gSsWɨd.]vΧ̖ .Տ_z8i{bzb_{}ҙq ?7+j'7 z1BfEo4\uH>dv ?l]/ XJ[ &ϗ;,5OCn]۱rG7;wj2zdtdy/nrC5fzKIɢsɜ[MV): ~)O]I?zqgdhjywtV/'dсoW]:LG\>SV0b_ei7-/z|߭3 v?ڢ5f;u 73܂-̻[1ܚ擙e>y7.>1a~-3 Zi2ctf̟0)sϘ;2܉ fU/;3|g3|]c>{`>G 0weݙ)cYO}̽3f>܇/3;fe2ײ >)A c Dz% +RqĠl 'c0`Q,s30\v%˸uPte|?0ac8#̸a\Lj2xScd hO<0R4c,c#ǘP6Q`Lf,e%rT1U72211-;q38-[3nc`8q&c:NFm]:<)Qq/>>FFx`iY`66ì 2kyAfm6xYg0kGfm6xY,dڀ'Fm6X̬ 0k`6xY,g0kgsyfmYd|/~ˇ_>|||||||||||||||||||||||˧ ˧ ˧ ˧ ˧ ˧ ˧ ˧ ˧ ˧ ˧ ˧ ˧ ˧ ˧ }/~ˇ_~|χ_~ᗟ>s|/~ˇ_~|/~ˇ_~|/~ˇ_~|/~ˇ_~|/~ˇ_~|/~ˇ_~|/~ˇ_~|/~ˇ_~|/~ˇ_~|/~ˇ_~|/~ˇ_~|/~ˇ_~/?~ˏ_~/?~ˏ_~/?~ˏ_~/?~ˏ_~/?~ˏ_~/?~ˏ_~/?~ˏ_~/?~ˏ_~/?~ˏ_~/?~ˏ_~l/?~ˏ_W/?~ˏ_W/?~ˏ_W/?~ˏ_W܈ A4`W ]+@vh A4`W ]+@vh A4`W ]+@vh A4`W ]+@vvvvvvvvvvvvvvvvv~+_ W~+_ W~+_ W~+_ W~+_ W~+_ W~+_ W~+_ W~+_ W~+_ W~+_ W~+_ W~+_ W~+_ Wvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvi A4bWA ]A+H viĮ A4bWA ]A+H viĮ į 7(_A Wį ~+_A Wį ~+_A Wį ~+_A Wį ~+_A Wį ~+_A Wį ~+_A Wį ~+_A Wį ~+_A Wį ~+_A Wį ~+_A Wį ~+_A Wį ~+_A Wį ~+_A WĮ666666666666666666666666666666666666666666666666~+_A WBį~+_A WBį~+_A WBį~+_A WBį~+_A WBį~+_A WBį~+_A WBį~+_A LB¯~+_! WB¯~+_! WB¯~+_! WB¯~+_! WB¯~+_!nXB¯~+_! WB¯vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv~+_a WBƯ~+_a WBƯ~+_a WBƯ~+_a WBƯ~+_a WBƯ~+_a WBƯ~+_a WBƯ~+_a WBƯ~+_a WBƯ~+_a WBƯ~+_a WBƯ~+_a WBƯ~+_a WBƯ~+_a WBƯ0vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv~+_a WƯ0~+_a WƯ0~+_a WƯ0~+_a WƯ0~+_a WƯ0~+_a W 0~E+_ W0~E+_ W0~E+_ W0~E+_ W0~E+_ W0~EaW"Ư~+_aW"Ư~+_aW"Ư~E+BvEh "A"4`W ]D+BvEh "A"4`W ]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m_W"~E+_W"~E+_W"~E+_W"~E+_W"~E+_W"~E+_W"~E+_W"~E+_W"~E+_W"~E+_W"~E+_W"~E+_W"~E+_W"~E+]Qm]Qm]Qm]Qm]Qm]Qm]Qm]Qm]Qm]Qm]Qm]Qm]Qm]Qm]Q@!J(vEiŮ( A4bWQ ]QD+J(vEiŮ( A4bWQ ]QD+J(vEiŮ( A4bWQnpQ ]QD+J(vEiŮ( A4bWQ ]QD+_QWů(~E+_QWů(~E+_QWů(~E+_QWů(~E+_QWů(~E+_QWů(~E+_QWů(~E+_QWů(~E+_QWů(~E+_QWů(~E+_QWů(~E+_QWů(~E+_QWů(~E+_QWů(~E+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +_QWbů~E+_QWbů~E+_QWbů~E+_QWb~+_1W bï~+_1W bï~+_1W bï~+_1W bï~+_1W bï~+_1Wï~+_1W bï~+_1W bï~+_1W bï~+_1W bï~+]1m]1m]1m]1m]1m]1m]1m]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm_qWbǯ~+_qWbǯ~+_qWbǯ~+_qWbǯ~+_qWbǯ~+_qWbǯ~+_qWbǯ~+_qWbǯ~+_qWbǯ~+_qWbǯ~+_qWbǯ~+_qWbǯ~+_qWbǯ~+_qWbǯ~+]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm]qm_qWǯ8~+_qWǯ8~7+_qJWǯ~+_qJWǯ~+_qJWǯ~+_qJWǯ~+_qJWǯ~+_qJWǯ~+W8~%+_ W8~%+_ W8~%+_ W8~%+_ W8~%+_ W8~%+] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m] m_ JW~%+_ JW~%+_ JW~%+_ JW~%+_ JW~%+_ JW~%+_ JW~%+_ JW~%+_ JW~%+_ JW~%+_ JW~%+_ JW~%+_ JW~%+_ JW~p7$+I$v%iĮ$ ؕA4HbWIJ ]I$+I$v%iĮ$ ؕA4HbWIJ ]I$+I$v%iĮ$ ؕA4HbWIJ ]I$+I$w&I$v%iĮ$ ؕA4HbWIJ ]I$+I$v%iĮ$ ؕA4HbWIJ ]I$+I$v%iĮ$ ؕA4HbWIJjJWį$~%+_IJWį$~%+_IJWį$~%+_IJWį$~%+_IJWį$~%+_IJWį$~%+_IJWį$~%+_IJWį$~%+_IJWį$~%+_IJWį$~%+_IJWį$~%+_IJWį$~%+_IJWį$~%+_IJWį$~%+_IJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJiJр!E~+_)JW R¯~+_)JW R¯~+_)JW R¯~+_)JW R¯~+_)JW R¯~+_)JW R¯~+_)JqR¯~+_)JW R¯~+_)JW R¯~+_)JW R¯~+_)JW R¯~+_)JW R¯~+_)JW R¯~+_)JW R¯~+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +_)JW ¯4~+_)JW ¯4~+_)JW ¯4~+_)JW ¯4~+_)JW ¯4~+_)JW ¯4~+_)JW ¯4~+_)JW ¯4~+_)JW ¯4~+_)JW ¯4~+_)JW ¯4~+_)JW ŷ!_iJWƯ4~+_iJWƯ4~+_iJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkJkhhhhhhhhhW2Ư ~+_iW2Ư ~+_iW2Ư ~+_iW2Ư ~+_iW2Ư ~+7Y24~e+_JW4~e+_JW4~e+_JW4~e+_JW4~e+_JW4~e+_JW4~e+_JW4~e+_JW4~e+_JW2ؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕؕ ~e+_W2 ~e+_W2 ~e+_W2 ~e+_W2 ~e+_W2 ~e+_W2 ~e+_W2 ~e+_W2 ~e+_W2 ~e+_gC,~e+_W,~e+_W,~e+_W,~e+_W4bWY ]Yd+K,veiŮ, ؕA4bWY ]Yd+K,w6K,veiŮ, ؕA4bWY ]Yd+K,veiŮ, ؕA4bWY ]Yd+K,veiŮ66666666666666666,~e+_YWů,~e+_YWů,~e+_YWů,~e+_YWů,~e+_YWů,~e+_YWů,~e+_YWů,~e+_YWů,~e+_YWů,~e+_YWů,~e+_YWů,~e+_YWů,~e+_YWů,~e+_YWŮ666666666666666666666666666666 xr4aW9 ]9+Gvhî rؕAr4aW9 ]9+Gvhî rؕAr4Wrï~+_9Wrï~+_9Wrï~+_9Wrïw<_9Wrï~+_9Wrï~+_9Wrï~+_9Wrï~+_9Wrï~+_9Wrï~+_9Wrï~+_9Wrï~+_9Wrï~+_9Wrï~+_9Wï<~+_9Wï<~+_9Wï<~+_9Wï<~+_9Wï<~+_9Wï<~+_9Wï<~+_9Wï<~+_|ǯ<~+_yWǯ<~+_yWǯ<~+_yWǯ<~+_yWǯ<~+_yWǯ<~+_yWǮ666666666666666666666666666666666666666666666666~_y*W ǯ~_y*W |WU<~+_WU<~+_WU<~+_WU<~+_WU<~+_WU<~+_WU<~+_WU<~+_WU<~+_WU<~+_WU<~+_WU<~]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m]m_*W U~_*W U~_*W U~_*W U~_*W U~_*W U~p5_*WU"~_*WU"~_*WU"~_*WU"~_*WU"~_*WU"~_*WU"~_*WU"~H"H"viPĮ" UA4(bWE*Ҡ]EH"viPĮ" UA4(bWE*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*j*WUį"~_E*WUį"~_E*WUį"~_E*WUį"~_E*WUį"~_E*WUį"~_E*WUį"~_E*WUį"~_E*WUį"~_E*WUį"~_E*WUį"~_E*WUį"~_E*WUį"~_E*WUį"~_E*i*i*i*i*i*i*i*i*i*i*i*i*i*i*рDvhP® JUA J4(aW%*Ѡ]%DvhP® JUA J4(aW%*Ѡ]%DvhP® JUA J4(aW%*Ѡ]%DvhP® JUA J4(aW%*Ѡ]%D~_%*aJU¯~_%*W JU¯~_%*W JU¯~_%*W JU¯~_%*W JU¯~_%*W JU¯~_%*W JU¯~_%*W JU¯~_%*W JU¯~_%*W JU¯~_%*W JU¯~_%*W JU¯~_%*W JU¯~_%*W JU¯~\`W6rm]ʵvk*U \`W6rm]ʵvk*U \`W6rm]ʵvk*U \`W6rm]ʵvk*U \`W6rm]ʵvk*U \`W6rm]ʵvk*U JU_%*ǯ~W _U¯r*W9~JU_%*ǯ~W _U¯ri(ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr*ǯr6P9~W9~W9~W9~W9~~g`~g`ٮGdzdخGA&z`#l#z]N?v=خG0 a%{_Xe/_>by?țaٮGXv= 7 ]v=k' 'uQdL2 v5 lWv5 lWv5`jՀ=ݮc`]0`u=X c`]0`u=X c`]0`u=X c`]0`u=f2`{ 1.* 1.`{ 1.`{ 1.`BX c`]0`u=C{ 1.`{ 1.`{ 1.ǰ=X c`m0`Ѓ`k{ 16`ku``]0X y|?ǃO!=OppK܇:\QbTTsnV_%je+/+pe\j/ˎU~]OrVrRy.'RyT*S<~<\88ʹTRyjj_?OWUڭFe ko=_;~ 8}?>x|Ǜ|=7_vtчL5q/j[Wo\n,g( =md>q+/_ܟWG/2K? <}{ҟ?>{ 0q/nQpm ~ zQqZ5jqZW{~}_8Ktab{8 0O\c?\ῼF5}{N}vEG_?菾V{¾zc_mP'}]{}+ -b8CGչ ?OvX/HmM}^V*+K~1[O6r+n[欼$}q~Gf68GpV׿}w5|sY:jD*G9"GQ#=j_`lo~Ka5~vz㌡ʽo{oc򴶿;}`8G=uj7[5uQix獎7{Q78G}~mhu]kQm|6>zuG]o߯NZQ9G}^y>ox獎}>zkuG]oQ[}>z2ptǯKg1Ukog'-}Cz.u.=7m'z:匿o`t.=oJ=o+mWLo~x^Q{eT~}/ݟjS*'V7+`hɳV ?7N9`8%-;0Ngk 3>6:*daͳ>78s!={kfӯ^w7uw? ^wsuho ^w1u!^wy?uy^w?Y relsurv/data/rdata.rda0000644000175000017500000001562413551065110014607 0ustar nileshnileshBZh91AY&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ƶMo)!#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/R/0000755000175000017500000000000014350674534012322 5ustar nileshnileshrelsurv/R/plotrssurv.r0000644000175000017500000002345412700667377014764 0ustar nileshnileshplot.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/mystrata.r0000644000175000017500000000607412531603441014344 0ustar nileshnileshmy.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/survfitrsadd.r0000644000175000017500000001171614070550360015220 0ustar nileshnilesh#' 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/cmprel.r0000644000175000017500000004427714070550360013772 0ustar nileshnilesh#' 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/Rcode.r0000644000175000017500000044612114351053431013535 0ustar nileshnileshrsfitterem<-function(data,b,maxiter,ratetable,tol,bwin,p,cause,Nie){ # cause: = 2 (unknown), 0 in 1 known. Lahko preko argumenta cause v rsadd dolocis, ce kdo ima znan cause of death (ne rabijo vsi) . # Nie: to je lambda_0 (ti), ki se oceni v M koraku v EM algoritmu 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)) # exp(linear.predictor) #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) # exp(linear.predictor) } #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 je sum_{at risk set} ebx 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 and left-truncated individuals: replace by the difference if(any(start!=0)){ # Calculate hazards at non-event times: timehaz <- data.frame(time=sort(data$Y), Lam0_2=Lam0) timehaz_tmp <- data.frame(time=unique(data$start), Lam0_2=NA) timehaz <- rbind(timehaz, timehaz_tmp) timehaz <- timehaz[order(timehaz$time),] timehaz$Lam0_2 <- mstateNAfix(timehaz$Lam0_2, 0) timehaz <- timehaz[!duplicated(timehaz$time),] # Prepare object so that you can calculate Lam0_event_time - Lam0_entry_time data_lt <- cbind(data, Lam0, id_0=1:nrow(data)) data_lt <- merge(data_lt, timehaz, by.x='start', by.y='time', all.x = TRUE) data_lt <- data_lt[order(data_lt$id_0),] # Check: # if(any(data_lt$Lam0_2[start!=0] != Lam0[wstart[start!=0]])){ # browser() # } # Edit Lam0: Lam0[start!=0] <- data_lt$Lam0[start!=0] - data_lt$Lam0_2[start!=0] # Old calculation: # 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 je sum_{at risk set} ebx 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 and left-truncated individuals: replace by the difference if(any(start!=0)){ timehaz <- data.frame(time=sort(data$Y), Lam0_2=Lam0) timehaz_tmp <- data.frame(time=unique(data$start), Lam0_2=NA) timehaz <- rbind(timehaz, timehaz_tmp) timehaz <- timehaz[order(timehaz$time),] timehaz$Lam0_2 <- mstateNAfix(timehaz$Lam0_2, 0) timehaz <- timehaz[!duplicated(timehaz$time),] # Prepare object so that you can calculate Lam0_event_time - Lam0_entry_time data_lt <- cbind(data, Lam0, id_0=1:nrow(data)) data_lt <- merge(data_lt, timehaz, by.x='start', by.y='time', all.x = TRUE) data_lt <- data_lt[order(data_lt$id_0),] # Edit Lam0: Lam0[start!=0] <- data_lt$Lam0[start!=0] - data_lt$Lam0_2[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 ord_id <- order(data$Y) rform$cause <- rform$cause[ord_id] data <- data[ord_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) # The cumulative population hazard of dying at time Y: 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) # The population hazard of dying in the following day (for individuals that had an event): 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(ord_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. \code{Surv(start,stop,event)} outcomes #' are also possible for time-dependent covariates and left-truncation for #' \code{method='EM'}. #' #' 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(inherits(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(inherits(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/rsdiff.r0000644000175000017500000002147414070550357013765 0ustar nileshnilesh#' 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/rformulate.r0000644000175000017500000002051614275445016014666 0ustar nileshnilesh# 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& inherits(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(inherits(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/rssurvrsadd.r0000644000175000017500000000655314070550357015073 0ustar nileshnilesh#' 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/R/years.R0000644000175000017500000016564314350542671013603 0ustar nileshnileshcolVars <- 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 performed, argument #' precision is set with argument \code{precision}, which defaults to 30-day #' intervals for intergration. 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). #' @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'. #' The 'greenwood' option is possible only for \code{measure='yd'}. #' @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 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. #' For \code{measure='yl2017'} values are reported only at the last time point. #' Functions \code{plot_f} and \code{plot_years} can be then used for plotting. #' @seealso \code{\link{plot_f}}, \code{\link{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, # cause.val, is.boot=FALSE, first.boot=FALSE # ,estimator.observed='Kaplan-Meier' ){ # OLD ARGUMENTS: # F_P_Spi: Tako kot F_P_final, ignorira censoring. Ali pa vzame samo admin cens # F_P_Spi2: Vzame ves censoring # @param cause.val for competing risks, to be added. # @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}. ############ # # PREPARE OBJECTS: ############ # estimator=c("F_P_final") # #' @param estimator which estimator should be used for calculating # estimator <- match.arg(estimator) arg.example <- FALSE # @param arg.example temporary argument, used for checking additionalities. Call <- match.call() if(!missing(rmap) & !is.boot & !first.boot) rmap <- substitute(rmap) measure <- match.arg(measure) var.estimator <- match.arg(var.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.') } if(!is.data.frame(data)) stop('Argument data is not a data.frame object.') data <- as.data.frame(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 Surv(start,stop, event) (possibly + mstate) if_start_stop <- length(as.character(formula[[2]])) %in% c(4,5) if(if_start_stop){ start_col <- as.character(formula[[2]])[2] stop_col <- as.character(formula[[2]])[3] status_col <- as.character(formula[[2]])[4] starting_age <- as.vector(as.matrix(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.')) } } # Check if no. at risk falls to zero at some point: if(if_start_stop){ # Prepare at-risk matrix: find_tajms <- unique(sort(c(data[,start_col], data[,stop_col]))) mat <- lapply(1:nrow(data), function(x) ifelse((data[x, start_col] < find_tajms) & (find_tajms <= data[x, stop_col]), 1, 0)) mat2 <- matrix(unlist(mat), nrow = nrow(data), byrow = TRUE) # The sum of the individual at-risk processes: yi_left <- colSums(mat2) # If there's an empty at-risk at a later timepoint, censor the data: wh_yi <- which(yi_left==0) if(length(wh_yi)>1){ if((!is.boot) & (!first.boot)){ warning(paste0('In the time interval ', find_tajms[wh_yi[2]-1], '-', find_tajms[wh_yi[2]], ' the at-risk sample is empty (nobody is followed). Survival cannot be estimated in this time interval.', ' The data is censored at time ', find_tajms[wh_yi[2]-1], '.')) } # Censor data: data <- data[data[,start_col] <= find_tajms[wh_yi[2]-1], ] wh_cen <- which(data[, stop_col] > find_tajms[wh_yi[2]-1]) data[wh_cen, stop_col] <- find_tajms[wh_yi[2]-1] data[wh_cen, status_col] <- 0 if(!missing(add.times)){ if(any(add.times > find_tajms[wh_yi[2]-1])) add.times <- add.times[add.times<=find_tajms[wh_yi[2]-1]] } } rm(mat,mat2) } data_orig <- data # if(starting.time=="left.truncated"){ # if(!missing(admin.cens)){ # if(!inherits(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) # } # } if(if_start_stop){ starting.time <- 'left.truncated' } else{ starting.time <- 'zero' } # Starting age starting_age <- rep(0,nrow(data)) if(if_start_stop){ starting_age <- as.vector(as.matrix(data[, start_col])) } starting_age <- as.numeric(starting_age) ############ # # YEARS ON DATA - GENERAL: ############ # 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){ if(if_start_stop){ survs <- c(1, mod$surv[1:(length(mod$surv)-1)]) t_diff <- diff(c(mod$time[1], mod$time)) } else{ survs <- mod$surv t_diff <- diff(c(0, mod$time)) } auc_data <- sum(t_diff*(1 - survs)) auc_data_vec <- cumsum(t_diff*(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 # Exact hazards: 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 } ############ # # SEPARATE YEARS FOR EVERY MEASURE: ############ # 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(0, 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=tis) # 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 } # spodaj <- mod_sum$n.risk + cumsum(mod_sum$n.event) + cumsum(mod_sum$n.censor) YL_O_vec <- colMeans(val_mat) # colSums(val_mat)/spodaj YL_O <- mean(it_auc) F_O_time <- mod_sum$time F_O_ext <- data.frame(time=F_O_time, area=YL_O_vec) # Subset: F_O_ext2 <- subset(F_O_ext, time %in% mod$time) F_O_time <- F_O_ext2$time YL_O_vec <- F_O_ext2$area } else{ YL_O_vec <- out$auc_data_vec YL_O <- out$auc_data F_O_time <- mod$time if(!(0 %in% F_O_time)){ F_O_time <- c(0, F_O_time) YL_O_vec <- c(0, YL_O_vec) } # Prepare extended F_O object: if(0 %in% mod$time){ F_O_temp <- data.frame(time=mod$time, surv=mod$surv) } else{ F_O_temp <- data.frame(time=c(0, mod$time), surv=c(1, mod$surv)) } F_O_ext <- data.frame(time=tis) F_O_ext <- merge(F_O_ext, F_O_temp, by='time', all.x=TRUE) F_O_ext$surv <- mstateNAfix(F_O_ext$surv, 0) tis_diff <- diff(c(0, F_O_ext$time)) F_O_ext$area <- cumsum(tis_diff*(1 - F_O_ext$surv))/365.241 F_O_ext <- F_O_ext[,c('time', 'area')] } 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) 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] <- cumsum(c(0, 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) F_P <- data.frame(time=tis, area=colMeans(it_auc_P_mat)) yd_curve <- data.frame(time=tis, est=F_O_ext$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) } } # Values to be reported: if((!is.boot) & (!first.boot)){ if(if_start_stop){ # Report only at last time point - the values until this time are not suitable to report: out <- list(years=utils::tail(yd_curve,1), F_O=utils::tail(F_O,1), F_P=utils::tail(F_P,1), measure=measure) } else{ # Report full measures: out <- list(years=yd_curve, F_O=F_O, F_P=F_P, measure=measure) } } else{ out <- list(years=yd_curve, F_O=F_O, F_P=F_P, measure=measure) } return(out) } else{ # measure == 'yl2013' 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 # Calculate measures: haz.pop <- temp$yidli/temp$yi 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, doesn't work ok # # 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) # Calculate measures: 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) # 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 ) # 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) } } else{ # measure == 'yd' ################################################### # # 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(0, 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 } ### # # Greenwood Variance of area (not F): # First prepare objects: mod_gw <- summary(mod, times = tis) gw_df <- data.frame(time=mod_gw$time, surv=mod_gw$surv, n.risk=mod_gw$n.risk, n.event=mod_gw$n.event) # Then calculate: times_all2 <- c(0, diff(gw_df$time))/365.241 surv_all <- c(1, gw_df$surv[1:(length(gw_df$surv)-1)]) auc_all <- cumsum(times_all2*surv_all) area_var <- sapply(1:length(auc_all), function(x) { numer <- gw_df$n.risk[1:x]*(gw_df$n.risk[1:x] - gw_df$n.event[1:x]) numer[numer==0] <- Inf sum(((auc_all[x] - auc_all[1:x])^2*gw_df$n.event[1:x])/numer) }) if(is.nan(area_var[length(area_var)])){ area_var[length(area_var)] <- area_var[length(area_var)-1] } ### # 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(TRUE){ # (!missing(admin.cens)) - tega nimamo vec data_spi2$stat <- 1 # data_spi2$stat[id_admin_cens] <- 0 # - tole ni bilo zakomentirano, ko smo imeli admin.cens 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 # 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=tis,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(tis[1], diff(tis))*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(tis[1], diff(tis))*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 # 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=tis,fast=TRUE, cmp=FALSE, ys=0) 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 # 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(tis[1], diff(tis))*out$F_P2)/365.241 out$auc_pop2 <- sum(c(tis[1], diff(tis))*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: F_data_yd <- data.frame(time=mod$time, F_data=out$F_data) 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) 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 <- area_var 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 # Population part: 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 ) ### # Greenwood for prob: greenwood_est <- (mod$surv^2*cumsum(mod$n.event/((mod$n.risk - mod$n.event)*mod$n.risk)))^(1/2) # If Surv(t)=0 in the end, take the last var estimate: if(any(rev(mod$surv)==0)){ greenwood_wh <- which(mod$surv==0) greenwood_est[greenwood_wh] <- greenwood_est[greenwood_wh[1]-1] } F_data_tmp <- data.frame(time=mod$time, prob=out$F_data, prob.se=greenwood_est, area=NA, area.se=NA) # Add values at time zero: 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) # Bootstrap: 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 #' life years difference (Manevski, Ruzic Gorenjec, Andersen, Pohar Perme, 2022). #' #' 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{\link{years}}, \code{\link{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) # Checks: if(years$measure != 'yd'){ stop("The plot_f function is available only for the YD 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, linetype='dashed')+ 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{\link{years}}, \code{\link{plot_f}} #' plot_years <- function(years, xlab='Time interval', ylab='Years', xbreak, ybreak, xlimits, ylimits, conf.int=FALSE, 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(years$measure=='yl2017' & nrow(out)==1){ stop('The years measure is reported at the end of follow-up thus it is not plotted.') } 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(out$time[1]), max(out$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), linetype='dashed')+ ggplot2::geom_step(ggplot2::aes(time/365.241, upper), linetype='dashed') } 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/zzz.R0000644000175000017500000000532314351045534013276 0ustar nileshnilesh#.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/MD50000644000175000017500000000544014351055733012427 0ustar nileshnilesh3673e16b8a24d8b8cb275a50009e441b *DESCRIPTION cb64b9f81f29874afd34bc45cef0cc3b *NAMESPACE 87526fda85dd2a5548e8a82f321d0517 *R/Rcode.r 349a599e32b83cc74898f83171628843 *R/cmprel.r 476d5effd3aff473f5ce65717dd4551a *R/mystrata.r e8c5220a2b671c39c0be09d5991f5aae *R/plotrssurv.r 6509223a26bd09e95df1f96d274160b7 *R/rformulate.r 5a1d04506504414eaa1db26c12211794 *R/rsdiff.r dd7db35d55a5b85d7e266e962dffcce9 *R/rssurvrsadd.r ad6a3841c5ca78ebce134d96d7092193 *R/survfitrsadd.r 1eff1bd813ff10a2092923541411ce1a *R/years.R 942e3ee66cf8db07b0812e8f321eb64c *R/zzz.R 3d33b58409d59c1f05de22766960f039 *data/colrec.rda da512257141fedce138de599b5e9997a *data/rdata.rda 1c28c53317cc8d5728fa55c619667921 *data/slopop.rda eb7093b9f50f7f6c4b928caa368e537d *inst/CITATION de847fc89b726f827923d39f598274a7 *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 c423cc2e6bf6fb5b01cf7cf1bc241ae8 *man/plot_f.Rd b22263efa2422f2d070f970cb7938981 *man/plot_years.Rd c28a88ecfa1f891e98c8fc9ef7566e55 *man/rdata.Rd 6250388945cd3d7d16d350ffdefbc776 *man/residuals.rsadd.Rd f9c97c4a0155e5369b7f3b6efea06f86 *man/rs.br.Rd b7e2bd60b2746fb417bd9cd42568440b *man/rs.diff.Rd 93df353bbae122a53951176d5b34decf *man/rs.surv.Rd 9e15fc20ce29b0a0c6e695414ff853e9 *man/rs.surv.rsadd.Rd 8fd62311b08d3fbf8536f38c85625e50 *man/rs.zph.Rd fd151dad3db43b0a68441e56bd844fbd *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 5a57497196254e9c4ae15620f16a5f71 *man/years.Rd 905d41c845358123bdb6790e7eac6d71 *src/cmpfast.c 6853ad4d02cc6b1ff9e2e786f7dad4b5 *src/dmatrix.c 35fe86cf308d11c704de3aaf3e58a629 *src/exps.c 0553be7d03225d831692b0995a3d9f63 *src/init.c 290f6dc48600c3b032c675d00f1e34f0 *src/netfastp.c cf08c1197fb1785378c385b0430c5170 *src/netfastpinter.c 40b37675819c028869b525f1b01ca354 *src/netfastpinter2.c efc2b2569dbe343bd85568e4303b3296 *src/netwei.c cc28deac6535fac9ab5b4be0121035c7 *src/netweiDM.c dc827fc540501192a675ffb139f9da33 *src/pystep.c 93bdb0c6d09be683150878f866cf1730 *src/pystep2.c 6e2403b71ca2b54fddac291e40163574 *src/survprotomoj.h relsurv/inst/0000755000175000017500000000000014344051441013063 5ustar nileshnileshrelsurv/inst/CITATION0000644000175000017500000000202414060340642014215 0ustar nileshnileshbibentry(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:" ) relsurv/inst/news.Rd0000644000175000017500000000601514350560361014333 0ustar nileshnilesh\name{NEWS} \title{NEWS file for the relsurv package} \section{Changes in version 2.2-9}{ \itemize{ \item 21 December 2022 Make a few improvements in the years function, primarily for measure='yl2017' \item 21 December 2022 Implement left-truncation in rsadd (time-dependent covariates already available) } } \section{Changes in version 2.2-8}{ \itemize{ \item 12 August 2022 Update Sint objects for new version } } \section{Changes in version 2.2-7}{ \itemize{ \item 09 March 2022 The slopop object has been updated containing data for 2020 \item 09 March 2022 The C scripts cmpfast.c, netfastpinter2.c, netfastp.c have been updated to correctly assign individuals at risk for left truncated data \item 09 March 2022 A small bug was fixed in the years function \item 09 March 2022 Change if(class) to if(inherits) function where Debian servers gave a note } } \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/NAMESPACE0000644000175000017500000000220414127251471013327 0ustar nileshnileshuseDynLib(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/src/0000755000175000017500000000000014351053436012701 5ustar nileshnileshrelsurv/src/netweiDM.c0000644000175000017500000002115114055413722014560 0ustar nileshnilesh/* ** 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 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/src/exps.c0000644000175000017500000000751313551065110014023 0ustar nileshnilesh/* ** Person-years calculations, leading to expected survival for a cohort. ** 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" /* 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=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, int *fac, int *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" /* 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] #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/dmatrix.c0000644000175000017500000000062713551065110014513 0ustar nileshnilesh/* $Id: dmatrix.c 11357 2009-09-04 15:22:46Z therneau $ ** ** set up ragged arrays, with #of columns and #of rows */ #include "survprotomoj.h" double **dmatrix(double *array, int ncol, int nrow) { register int i; register double **pointer; pointer = (double **) ALLOC(nrow, sizeof(double *)); for (i=0; i #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/netfastpinter.c0000644000175000017500000002054213551065110015727 0ustar nileshnilesh/* ** 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 #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, int *fac, int *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/survprotomoj.h0000644000175000017500000000255114275433125015650 0ustar nileshnilesh/* ** $Id $ ** ** Prototypes of all the survival functions ** Including this in each routine helps prevent mismatched argument errors */ #include "R.h" #include "Rinternals.h" #define ALLOC(a,b) R_alloc(a,b) double **dmatrix(double *array, int ncol, int nrow); SEXP expc(SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2); SEXP netwei( SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2, SEXP status2, SEXP times2) ; SEXP netfastpinter( SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2, SEXP ys2, SEXP status2, SEXP times2) ; SEXP cmpfast( SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2, SEXP ys2, SEXP status2, SEXP times2) ; SEXP netfastpinter2( SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2,SEXP ys2, SEXP status2, SEXP times2, SEXP myprec2) ; double pystep(int nc, int *index, int *index2, double *wt, double *data, int *fac, int *dims, double **cuts, double step, int edge); double pystep2(int nc, int *index, int *index2, double *wt, double *data, int *fac, int *dims, double **cuts, double step, int edge); relsurv/man/0000755000175000017500000000000014344051441012661 5ustar nileshnileshrelsurv/man/expprep2.Rd0000644000175000017500000000226514067312526014730 0ustar nileshnilesh\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/colrec.Rd0000644000175000017500000000150512705412213014415 0ustar nileshnilesh\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/rs.zph.Rd0000644000175000017500000000451514124561334014404 0ustar nileshnilesh% 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/years.Rd0000644000175000017500000001051114344122650014272 0ustar nileshnilesh% 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, 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).} \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'. The 'greenwood' option is possible only for \code{measure='yd'}.} \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{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. For \code{measure='yl2017'} values are reported only at the last time point. 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 performed, argument precision is set with argument \code{precision}, which defaults to 30-day intervals for intergration. 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{\link{plot_f}}, \code{\link{plot_years}} } relsurv/man/cmp.rel.Rd0000644000175000017500000001107214124561334014514 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cmprel.r \name{cmp.rel} \alias{cmp.rel} \alias{print.cmp.rel} \title{Compute crude probability of death} \usage{ cmp.rel( formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, na.action, tau, conf.int = 0.95, precision = 1, add.times, rmap ) } \arguments{ \item{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.} \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{tau}{the maximum follow-up time of interest, all times larger than \code{tau} shall be censored. Equals maximum observed time by default} \item{conf.int}{the level for a two-sided confidence interval on the survival curve(s). Default is 0.95.} \item{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.} \item{add.times}{specific times at which the value of estimator and its variance should be evaluated. Default is all the event and censoring times.} \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{ 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}} } \description{ Estimates the crude probability of death due to disease and due to population reasons } \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. 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. } \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) } \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" } \seealso{ \code{rs.surv}, \code{summary.cmp.rel} } \keyword{survival} relsurv/man/transrate.hld.Rd0000644000175000017500000000367414124561334015736 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{transrate.hld} \alias{transrate.hld} \title{Reorganize Data obtained from Human Life-Table Database into a Ratetable Object} \usage{ transrate.hld(file, cut.year, race) } \arguments{ \item{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.} \item{cut.year}{a vector of cutpoints for years. Must be specified when the year spans in the files are not consecutive.} \item{race}{a vector of race names for the input files.} } \value{ An object of class \code{ratetable}. } \description{ 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. } \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/transrate.Rd0000644000175000017500000000307612705402360015160 0ustar nileshnilesh\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.br.Rd0000644000175000017500000000454414124561334014210 0ustar nileshnilesh% 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/rs.surv.Rd0000644000175000017500000001300614344115517014577 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{rs.surv} \alias{rs.surv} \title{Compute a Relative Survival Curve} \usage{ rs.surv( 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 ) } \arguments{ \item{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.} \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{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)}.} \item{method}{the method for calculating the relative survival. The options are \code{pohar-perme}(default), \code{ederer1}, \code{ederer2} and \code{hakulinen}.} \item{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)).} \item{conf.int}{the level for a two-sided confidence interval on the survival curve(s). Default is 0.95.} \item{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}.} \item{add.times}{specific times at which the curve should be evaluated.} \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{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}. } \description{ Computes an estimate of the relative survival curve using the Ederer I, Ederer II method, Pohar-Perme method or the Hakulinen method } \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. 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}. } \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) } \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. } \seealso{ \code{survfit}, \code{survexp} } \keyword{survival} relsurv/man/plot.rs.zph.Rd0000644000175000017500000000440314124561334015355 0ustar nileshnilesh% 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/nessie.Rd0000644000175000017500000000422713400170743014442 0ustar nileshnilesh\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/rsmul.Rd0000644000175000017500000000724713332517377014337 0ustar nileshnilesh\name{rsmul} \alias{rsmul} \title{Fit Andersen et al Multiplicative Regression Model for Relative Survival} \description{ Fits the Andersen et al multiplicative regression model in relative survival. An extension of the coxph function using relative survival. } \usage{ rsmul(formula, data, ratetable = relsurv::slopop, int,na.action,init, method,control,rmap,...) } \arguments{ \item{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. } \item{data}{ a data.frame in which to interpret the variables named in the \code{formula}. } \item{ratetable}{ a table of event rates, such as \code{slopop}. } \item{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. } \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{init}{vector of initial values of the iteration. Default initial value is zero for all variables. } \item{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.} \item{control}{a list of parameters for controlling the fitting process. See the documentation for \code{coxph.control} for details. } \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{...}{Other arguments will be passed to \code{coxph.control}.} } \value{ 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.} } \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. } \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. } \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) } \seealso{\code{\link{rsadd}}, \code{\link{rstrans}}. } \keyword{survival} relsurv/man/rsadd.Rd0000644000175000017500000001545114351045520014252 0ustar nileshnilesh\name{rsadd} \alias{rsadd} \title{Fit an Additive model for Relative Survival} \description{ 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. } \usage{ rsadd(formula, data=parent.frame(), ratetable = relsurv::slopop, int, na.action, method, init,bwin,centered,cause,control,rmap,...) } \arguments{ \item{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. \code{Surv(start,stop,event)} outcomes are also possible for time-dependent covariates and left-truncation for \code{method='EM'}. 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{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). } \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{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). } \item{init}{vector of initial values of the iteration. Default initial value is zero for all variables. } \item{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. } \item{centered}{if \code{TRUE}, all the variables are centered before fitting and the baseline excess hazard is calculated accordingly. Default is \code{FALSE}. } \item{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. } \item{control}{a list of parameters for controlling the fitting process. See the documentation for \code{glm.control} for details. } \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{...}{other arguments will be passed to \code{glm.control}.} } \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. 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. } \value{ 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.} } \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") } \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. } \seealso{ \code{\link{rstrans}}, \code{\link{rsmul}} } \keyword{survival} relsurv/man/joinrate.Rd0000644000175000017500000000265712531542107014775 0ustar nileshnilesh\name{joinrate} \alias{joinrate} \title{Join ratetables} \description{ The function joins two or more objects organized as \code{ratetable} by adding a new dimension. } \usage{ joinrate(tables,dim.name="country") } \arguments{ \item{tables}{ a list of ratetables. If names are given, they are included as \code{dimnames}. } \item{dim.name}{ the name of the added dimension. } } \details{ 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). } \value{An object of class \code{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. } \examples{ #newpop <- joinrate(list(Arizona=survexp.az,Florida=survexp.fl, # Minnesota=survexp.mn),dim.name="state") } \seealso{\code{\link{ratetable}}, \code{\link{transrate.hld}}, \code{\link{transrate.hmd}}, \code{\link{transrate}}.} \keyword{survival} relsurv/man/rdata.Rd0000644000175000017500000000122211203231600014224 0ustar nileshnilesh\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/residuals.rsadd.Rd0000644000175000017500000000324514124561334016246 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{residuals.rsadd} \alias{residuals.rsadd} \title{Calculate Residuals for a "rsadd" Fit} \usage{ \method{residuals}{rsadd}(object, type = "schoenfeld", ...) } \arguments{ \item{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.} \item{type}{character string indicating the type of residual desired. Currently only Schoenfeld residuals are implemented.} \item{...}{other arguments.} } \value{ 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}.} } \description{ Calculates partial residuals for an additive relative survival model. } \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) } \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. } \seealso{ \code{\link{rsadd}}. } \keyword{survival} relsurv/man/slopop.Rd0000644000175000017500000000035510063271174014470 0ustar nileshnilesh\name{slopop} \alias{slopop} \docType{data} \title{Census Data Set for the Slovene Population} \description{ Census data set for the Slovene population. } \usage{data(slopop)} \examples{ data(slopop) } \keyword{datasets} relsurv/man/survfit.rsadd.Rd0000644000175000017500000000541714124561334015760 0ustar nileshnilesh% 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/plot_years.Rd0000644000175000017500000000254214344115520015333 0ustar nileshnilesh% 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 = FALSE, 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{\link{years}}, \code{\link{plot_f}} } relsurv/man/survsplit.Rd0000644000175000017500000000257610221543070015227 0ustar nileshnilesh\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/plot.cmp.rel.Rd0000644000175000017500000000641314124561334015474 0ustar nileshnilesh% 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)